diff --git a/V4.0/inidata/namelists/namelist_cfg b/V4.0/inidata/namelists/namelist_cfg new file mode 100755 index 0000000000000000000000000000000000000000..61b956db6330dd776a3c7e85924414f8ad5053b9 --- /dev/null +++ b/V4.0/inidata/namelists/namelist_cfg @@ -0,0 +1,1463 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! 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 = 'eORCA12' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 87600 !!!! change back to 7200 ! last time step (std 5840) + nn_date0 = 19850101 ! 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 = .true. ! start from rest (F) or from a restart file (T) + ln_rstdate = .true. ! Use date in output restart + ln_rsttime = .true. ! Use date/time in output restart + 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_out' ! suffix of ocean restart name (output) + cn_ocerst_outdir = './restarts' ! 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 = 312 ! 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 = .true. ! mask land points in NetCDF outputs + ln_cfmeta = .true. ! 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 +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.0 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 360 ! time step for the dynamics and tracer + rn_atfp = 0.05 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=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 ! data : Temperature & Salinity +!----------------------------------------------------------------------- + sn_tem = 'bigthetao_1950-1954' ,-12 ,'bigthetao' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sa_1950-1954' ,-12 ,'sa' , .true. , .true. , 'yearly' , '' , '' , '' + cn_dir = './' ! root directory for the location of the runoff files + ln_tsd_init = .false. ! Initialisation of ocean T & S with T &S input data (T) or not (F) + ln_tsd_dmp = .false. ! damping of ocean T & S toward T &S input data (T) or not (F) + +!----------------------------------------------------------------------- +&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.3 ! 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 = 1 ! 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 = .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 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 = 2 ! =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 = .true. ! 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 = .true. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .true. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_wvinice = .false. ! use mask indicating where the wave forcing was influenced by sea ice + ln_wspd = .false. ! use 10m wind speed output by a wave model (usually not the case). + ln_rhoaw = .false. ! use the surface air density as output by a wave model (usually not the case). + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ! ln_cdgw can only be used if ln_NCAR is true + ln_charnock = .false. ! Charnock coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ! ln_charnock=true can only be used if ln_ECMWF is true + 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 + nn_sdtrans = -1 ! = -1 the Stokes transport is determined using the mean wave period based on the (-1) moment of the frequency spectrum + ! = +1 on the first (1) momement of the frequency spectum + ! Ideally the +1 option should be used, but traditionally, only the mean wave period based on (-1) has been + ! has been available from wave model output + 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) + nn_hbp = 1 ! Steric height and bottom pressure + ln_sglread_sbc = .false. ! Read forcing fields on master processor +/ +!---nemo_wam_model-------------------------------------------------------------------- +&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 = .true. ! "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.0 ! Air temperature & humidity reference height (m) + rn_zu = 10.0 ! 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.0 ! multiplicative factor for precipitation (total & snow) + rn_efac = 1.0 ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0.0 ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + cn_dir = './forcings/' ! 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 = 'u10' , 3 , 'u10' , .true. , .false. , 'yearly' , '' , 'Uwnd' + sn_wndj = 'v10' , 3 , 'v10' , .true. , .false. , 'yearly' , '' , 'Vwnd' + sn_qsr = 'qsw' , 3 , 'qsw' , .true. , .false. , 'yearly' , '', '' + sn_qlw = 'qlw' , 3 , 'qlw' , .true. , .false. , 'yearly' , '', '' + sn_tair = 't10' , 3 , 't10' , .true. , .false. , 'yearly' , '', '' + sn_humi = 'q10' , 3 , 'q10' , .true. , .false. , 'yearly' , '', '' + sn_prec = 'precip' , 3 , 'precip' , .true. , .false. , 'yearly' , '', '' + sn_snow = 'snow' , 3 , 'snow' , .true. , .false. , 'yearly' , '', '' + sn_slp = 'slp' , 3 , 'slp' , .true. , .false. , 'yearly' , '', '' + +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 2 ! 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 = .true. ! 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 = 'oce only' , 'yes' , '' , '' , '' + sn_snd_alb = 'none' , 'no' , '' , '' , '' + sn_snd_thick = 'weighted ice and snow' , 'yes' , '' , '' , '' + sn_snd_crt = 'mixed oce-ice' , 'no' , 'spherical' , 'eastward-northward' , 'U,V' + sn_snd_co2 = 'none' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'none' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'yes' , '' , '' , '' + sn_snd_thick1 = 'none' , 'yes' , '' , '' , '' + sn_snd_mpnd = 'ice only' , 'yes' , '' , '' , '' + sn_snd_sstfrz = 'none' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'yes' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'coupled' , 'no' , '' , '' , '' + sn_rcv_taumod = 'none' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'spherical' , 'eastward-northward' , 'U,V,F' + sn_rcv_dqnsdt = 'none' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce only' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce only' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'yes' , '' , '' , '' + sn_rcv_rnf = 'coupled1d' , 'no' , '' , '' , '' + sn_rcv_cal = 'none' , 'no' , '' , '' , '' + sn_rcv_co2 = 'none' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'coupled' , 'yes' , '' , '' , '' + 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' , '' , '' , '' + sn_rcv_ts_ice = 'ice' , 'yes' , '' , '' , '' + 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' , '' , '' , '' + sn_rcv_chnk = '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.0 ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! 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_sstr_bnd = 0 ! Method for capping SST damping heat fluxes + ! (=0 No capping; =1 capping Max; + ! =2 capping Min; =3 capping both Max/Min) + rn_sstr_bnd = 300 ! Capping value for SST damping heat fluxes [W/m2] + ! Max = ABS(DQDT_BND) if nn_sstr_bnd=1 + ! Min = -ABS(DQDT_BND) if nn_sstr_bnd=2 + ! Min=-ABS(DQDT_BND) and Max=ABS(DQDT_BND) if nn_sstr_bnd=3 + ln_sstr_mxl = .true. ! Capping SST damping heat flux only at MXL > rn_sstr_mxl + rn_sstr_mxl = 1000 ! Min value (in m) of mld (0.01 density change) that triggers capping + rn_dqdt_limice = 0.1 ! restoring term factors under ice [ratio] + rn_dqdt_limice_thres = 0.005 ! Minimum for apply rn_dqdt_limice + nn_sssr = 2 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + rn_deds = -33.3333333 ! 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.0 ! ABS(Max/Min) value of the damping erp term [mm/day] + 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',24,'sst',.false.,.false.,'monthly','','','' + sn_sss='sss_1m.nc',-1,'vosaline',.true.,.true.,'yearly','sss_weights_bilin.nc','','', +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .true. ! specific treatment at rivers mouths + rn_hrnf = 10.0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T) + rn_avt_rnf = 0.002 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T) + rn_rfact = 1.0 ! 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_tem_mask = .false. ! the temperature field is a mask + 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 = 0.0005735 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150.0 ! 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 = .true. ! 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_s_rnf = 'runoffs' , 24.0 , 'rosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_dep_rnf = 'runoffs' , 0.0 , 'rodepth' , .false. , .true. , 'yearly' , '' , '' , '' + sn_cnf = 'runoff_1m_nomask.nc' , 0 , 'socoefr', .false. , .true. , 'yearly' , '' , '' , '' + !sn_i_rnf = 'NOT USED' , -1.0 , 'sofwficb', .true. , .true. , 'yearly' , '' , '' , '' + sn_rnf = 'runoff_1m_nomask.nc' , -1 , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' + sn_t_rnf = 'runoff_1m_nomask.nc' , -12 , 'icbrnftemper', .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000.0 ! 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.0 ,'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 = 3 ! 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 = 0.0001 ! gammat coefficient used in blk formula + rn_gammas0 = 0.0001 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30.0 ! 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.0 ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'runoff_1m_nomask.nc' , -12 ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='runoff_1m_nomask.nc' , -12 ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='runoff_1m_nomask.nc' , -12 ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12.0 ,'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.0 , 'drag_coeff' , .true. , .true. , 'yearly' , '' , '' , '' + sn_usd = 'sdw_ecwaves_orca2' , 6.0 , 'u_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsd = 'sdw_ecwaves_orca2' , 6.0 , 'v_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_hsw = 'sdw_ecwaves_orca2' , 6.0 , 'hs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wmp = 'sdw_ecwaves_orca2' , 6.0 , 'wmp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wfr = 'sdw_ecwaves_orca2' , 6.0 , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6.0 , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_inice = 'wave_icemask' , 6 , 'wave_icemask', .false. , .false. , 'monthly' , '' , '' , '' + sn_wspd = 'wspd' , 6 , 'wspd', .false. , .false. , 'monthly' , '' , '' , '' + sn_charnock = 'charnock' , 6 , 'Charnock', .false. , .false. , 'monthly' , '' , '' , '' + sn_mp1 = 'mp1' , 6 , 'mp1', .false. , .false. , 'monthly' , '' , '' , '' + sn_rhoa = 'rhoa' , 6 , 'rhoa', .false. , .false. , 'monthly' , '' , '' , '' + sn_phioc = 'phioc', 6, 'phioc', .false., .false., 'monthly', '', '', + '' +/ +!----------------------------------------------------------------------- +&namsbc_fwb ! namsbc_fwb Fresh water budget +!----------------------------------------------------------------------- + rd_fwb = 1.0 ! time scale to apply fwb correction (days) + ikt_fwb = 1 ! freq (time steps) to estimate fwb + nr_ssh = 0 ! 0 for global sl=0. 1/2 for external SL/Mass file + cn_dir ='./' ! root directory for location of ssh file + sn_ssh = 'ssh' , -1 , 'ssh' , .true. , .true. , 'yearly', '', '', '' + rcap = 1.0 ! mm/day cap for FWB adjusment + lfwbr = .false. +/ +!----------------------------------------------------------------------- +&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 = 1 ! Turn on more verbose output if level > 0 + nn_verbose_write = 300 ! Timesteps between verbose messages + nn_sample_rate = 192 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 88000000.0, 410000000.0, 3300000000.0, 18000000000.0, 38000000000.0, 75000000000.0, 120000000000.0, 220000000000.0, 390000000000.0, 740000000000.0 + ! ! 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.0, 67.0, 133.0, 175.0, 250.0, 250.0, 250.0, 250.0, 250.0, 250.0 + ! + rn_rho_bergs = 850.0 ! 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.0 ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0.0 ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0.4 ! CFL speed limit for a berg (safe value is 0.4, see #2581) + + 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' , -12 ,'soicbclv', .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 = 2 ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. + cn_shlat2d_file='shlat2d.nc' + cn_shlat2d_var='shlat2d' + ln_shlat2d=.true. +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- + ln_spc_dyn = .true. ! use 0 as special value for dynamics + rn_sponge_tra = 2880.0 ! coefficient for tracer sponge layer [m2/s] + rn_sponge_dyn = 2880.0 ! 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.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.0 ! Damping time scale in days + rn_time_dmp_out = 1.0 ! 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.0 , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24.0 , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24.0 , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24.0 , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24.0 , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24.0 , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24.0 , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' + bn_h_i = 'amm12_bdyT_ice' + bn_h_s = 'amm12_bdyT_ice' + bn_t_i = 'NOT USED' , 24.0 , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24.0 , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24.0 , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24.0 , '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.0 , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24.0 , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24.0 , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270.0 ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10.0 ! -- salinity -- + rn_ice_age = 30.0 ! -- 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 = .true. ! 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 = .true. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 0.001 ! 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 = 0.0025 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 0.003 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50.0 ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 0.001 ! 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 = 0.0025 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 0.003 ! roughness [m] (ln_loglayer=T) + ln_boost = .true. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50.0 ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! 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 = 0.0864 ! 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 , 'gh_flux', .false. , .true. , 'yearly' , 'geothermal_heating_weight.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag + nn_bbl_ldf = 1 ! diffusive bbl (=1) or not (=0) + nn_bbl_adv = 1 ! advective bbl (=1/2) or not (=0) + rn_ahtbbl = 1000.0 ! lateral mixing coefficient in the bbl [m2/s] + rn_gambbl = 10.0 ! 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 = 0.1655 ! thermal expension coefficient + rn_b0 = 0.76554 ! saline expension coefficient + rn_lambda1 = 0.05952 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0.00074914 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0.0001497 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.109e-05 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0.0024341 ! 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 = .true. ! 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 = .true. ! 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 = 20 ! 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.027 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Ld = 200000.0 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) + ln_outfile = .false. +/ +!----------------------------------------------------------------------- +&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 = 5000.0 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800.0 ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20.0 ! 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 = .true. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 21 ! 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 = 1.5 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Le = 33.0 ! 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 = .false. ! 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 = .true. ! vector form - 2nd centered scheme + nn_dynkeg = 1 ! 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 = .true. ! 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 = .true. ! 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 = .true. ! 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.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 = .true. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 20 ! 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.1895 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10000.0 ! 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] + ln_outfile = .false. +/ +!----------------------------------------------------------------------- +&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.0 , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120.0 , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120.0 , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120.0 , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120.0 , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120.0 , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120.0 , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120.0 , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120.0 , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120.0 , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120.0 , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120.0 , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120.0 , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120.0 , '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 = .true. ! 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 = .true. ! enhanced vertical diffusion + nn_evdm = 1 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 10.0 ! 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 = .true. ! double diffusive mixing + rn_avts = 0.0001 ! 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_zdftmx = .true. ! old tidal mixing scheme (Simmons et al 2004) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! coefficients + rn_avm0 = 0.00012 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 1.2e-05 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst=F) + nn_avb = 0 ! profile for background avt & avm (=1) or not (=0) + nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 0.01 ! maximum value of the vertical viscosity + rn_alp = 5.0 ! 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 = 1e-06 ! minimum value of tke [m2/s2] + rn_emin0 = 0.0001 ! surface minimum value of tke [m2/s2] + rn_bshear = 1e-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.0 ! 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) + ln_wavetke = .true. ! Use wave model TKE flux + ln_ebbavg = .true. ! average out the surface value over first layer + rn_swhfr = 0.5 ! fraction of significant wave height to scale the TKE flux penetration (if ln_wavetke = T) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1e-07 ! minimum value of e [m2/s2] + rn_epsmin = 1e-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.0 ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000.0 ! 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.0 ! 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.0 ! 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.0 ! 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) +/ +!----------------------------------------------------------------------- +&namzdf_tmx ! tidal mixing parameterization ("key_zdftmx") +!----------------------------------------------------------------------- + rn_htmx = 500.0 ! vertical decay scale for turbulence (meters) + rn_n2min = 1e-08 ! 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.0 ! ITF tidal dissipation efficiency +/ + +!!====================================================================== +!! *** 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 = .true. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .true. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .true. ! 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 = .true. ! Logical switch for T profile observations + ln_s3d = .true. ! 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 = .true. ! 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 = .true. ! 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 = 10101.0 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 10102.0 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0.0 ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0.0 ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0.0 ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0.0 ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0.0 ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0.0 ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0.0 ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0.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 + ln_split_output = .true. +/ +!----------------------------------------------------------------------- +&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 = -1 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = -1 ! number of processors following j (set automatically if < 1), see also ln_listonly = T + !jpni = 160 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + !jpnj = 103 ! 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 = .true. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii + ln_timing_detail = .false. + ln_timing_onefile = .true. + ln_timing_barrier = .false. + ln_timing_check = .false. + ln_sglread = .false. + ln_sglwrite = .false. + nn_ompopt = 2 + nn_ompht = 2 + ln_write_domains = .false. + ln_diawri_instant = .true. + ln_diawri_full = .false. +/ +!----------------------------------------------------------------------- +&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.0 ! 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) +/ +&namzdf_mldzint +nn_mld_diag=2 +sn_mld1=1,10.0,0.2,0.1 +sn_mld2=1,10.0,-0.2,0 +/ + +&namdct +! nn_dct = 15 +! nn_dctwri = 15 +! nn_secdebug = 112 +/ + +&nam_diatmb +! ln_diatmb = .false. +/ diff --git a/V4.0/inidata/namelists/namelist_ice_cfg b/V4.0/inidata/namelists/namelist_ice_cfg new file mode 100755 index 0000000000000000000000000000000000000000..d9d5e3e477704f01d75f7933e3e62ddf94521147 --- /dev/null +++ b/V4.0/inidata/namelists/namelist_ice_cfg @@ -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 = 4 ! 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_out' ! suffix of ice restart name (output) + cn_icerst_indir = '.' ! directory to read input ice restarts + cn_icerst_outdir = './restarts' ! 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,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.0 ! 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.0 ! maximum bottom stress per unit volume [N/m3] + rn_lf_relax = 1e-05 ! 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 = 20000.0 ! 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 = .false. ! adaptive rheology (Kimmritz et al. 2016 & 2017) + rn_creepl = 2e-09 ! creep limit [1/s] + rn_ecc = 2.0 ! eccentricity of the elliptical yield curve + nn_nevp = 120 ! 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 = 0.01 ! 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 = .true. ! 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 = 0 ! 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 = .false. ! 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.5 ! 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) + rn_oiht = 0.003 ! ocean ice heat transfer parameter zch in icethd.f90 +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ + rn_beta = 1.2 ! 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 = 10.0 ! 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.0 ! (nn_icesal=1) ice salinity (g/kg) + rn_sal_gd = 5.0 ! (nn_icesal=2) restoring ice salinity, gravity drainage (g/kg) + rn_time_gd = 1730000.0 ! (nn_icesal=2) restoring time scale, gravity drainage (s) + rn_sal_fl = 2.0 ! (nn_icesal=2) restoring ice salinity, flushing (g/kg) + rn_time_fl = 864000.0 ! (nn_icesal=2) restoring time scale, flushing (s) + rn_simax = 20.0 ! 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.5 ! maximum ice fraction that contributes to melt pond. range: 0.7 -- 0.85 ?? + 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 = .false. ! 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.0 ! initial ice temperature (K), North + rn_tmi_ini_s = 270.0 ! " " South + rn_tsu_ini_n = 270.0 ! initial surface temperature (K), North + rn_tsu_ini_s = 270.0 ! " " South + rn_tms_ini_n = 270.0 ! initial snw temperature (K), North + rn_tms_ini_s = 270.0 ! " " 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.6 ! dry ice albedo : 0.54 -- 0.65 + rn_alb_imlt = 0.5 ! 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.0 ! check at each gridcell (1.e-4m/h)=> stops the code if violated (and writes a file) + rn_icechk_glo = 1.0 ! 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/V4.0/inidata/namelists/namelist_ice_ref b/V4.0/inidata/namelists/namelist_ice_ref new file mode 100755 index 0000000000000000000000000000000000000000..73cee6247f7b87d6e557f0172979a6c3d8c8391e --- /dev/null +++ b/V4.0/inidata/namelists/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 = .false. ! 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) + rn_oiht = 0.0057 ! ocean ice heat transfer parameter zch in icethd.f90 +/ +!------------------------------------------------------------------------------ +&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 = .false. ! 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 ?? + 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/V4.0/inidata/namelists/namelist_ref b/V4.0/inidata/namelists/namelist_ref new file mode 100755 index 0000000000000000000000000000000000000000..c2c1752ebb99db0b3e51d8ba42989e91ba989b6f --- /dev/null +++ b/V4.0/inidata/namelists/namelist_ref @@ -0,0 +1,1441 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! 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 = 'eORCA1' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 175200 ! last time step (std 5840) + nn_date0 = 19530101 ! 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 = .true. ! start from rest (F) or from a restart file (T) + ln_rstdate = .true. ! Use date in output restart + ln_rsttime = .true. ! Use date/time in output restart + 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 = 28800 ! 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 = 720 ! 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 = .true. ! mask land points in NetCDF outputs + ln_cfmeta = .true. ! 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 +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.0 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 1800 ! time step for the dynamics and tracer + rn_atfp = 0.05 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = 'domain_cfg' ! domain configuration filename + ! + ln_closea = .true. ! 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 = .true. ! 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 = 'bigthetao', -12 , 'bigthetao', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sa' , -12 , 'sa', .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.3 ! 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.0 ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1.0 ,'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 = 1 ! 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 = .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 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 = 2 ! =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 = .true. ! 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 = .true. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .true. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_wvinice = .false. ! use mask indicating where the wave forcing was influenced by sea ice + ln_wspd = .false. ! use 10m wind speed output by a wave model (usually not the case). + ln_rhoaw = .false. ! use the surface air density as output by a wave model (usually not the case). + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ! ln_cdgw can only be used if ln_NCAR is true + ln_charnock = .false. ! Charnock coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ! ln_charnock=true can only be used if ln_ECMWF is true + 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 + nn_sdtrans = -1 ! = -1 the Stokes transport is determined using the mean wave period based on the (-1) moment of the frequency spectrum + ! = +1 on the first (1) momement of the frequency spectum + ! Ideally the +1 option should be used, but traditionally, only the mean wave period based on (-1) has been + ! has been available from wave model output + 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) + nn_hbp = 1 ! Steric height and bottom pressure + ln_sglread_sbc = .false. ! Read forcing fields on master processor +/ +!---nemo_wam_model-------------------------------------------------------------------- +&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.0 , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24.0 , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24.0 , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24.0 , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24.0 , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .true. ! "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.0 ! Air temperature & humidity reference height (m) + rn_zu = 10.0 ! 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.0 ! multiplicative factor for precipitation (total & snow) + rn_efac = 1.0 ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0.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 = 'u10' , 3 , 'u10', .true. , .false. , 'yearly' , '' , 'Uwnd' + sn_wndj = 'v10' , 3 , 'v10', .true. , .false. , 'yearly' , '' , 'Vwnd' + sn_qsr = 'qsw' , 3 , 'qsw', .true. , .false. , 'yearly' , '' , '' + sn_qlw = 'qlw' , 3 , 'qlw', .true. , .false. , 'yearly' , '' , '' + sn_tair = 't10' , 3 , 't10', .true. , .false. , 'yearly' , '' , '' + sn_humi = 'q10' , 3 , 'q10', .true. , .false. , 'yearly' , '' , '' + sn_prec = 'precip', 3 , 'precip', .true. , .false. , 'yearly' , '' , '' + sn_snow = 'snow', 3 , 'snow' , .true. , .false. , 'yearly' , '' , '' + sn_slp = 'slp' , 3 , 'slp' , .true. , .false. , 'yearly' , '' , '' + 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 = 2 ! 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 = .true. ! 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 = 'oce only' , 'yes' , '' , '' , '' + sn_snd_alb = 'none' , 'no' , '' , '' , '' + sn_snd_thick = 'weighted ice and snow' , 'yes' , '' , '' , '' + sn_snd_crt = 'mixed oce-ice' , 'no' , 'spherical' , 'eastward-northward' , 'U,V' + sn_snd_co2 = 'none' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'none' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'yes' , '' , '' , '' + sn_snd_thick1 = 'none' , 'yes' , '' , '' , '' + sn_snd_mpnd = 'ice only' , 'yes' , '' , '' , '' + sn_snd_sstfrz = 'none' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'yes' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'coupled' , 'no' , '' , '' , '' + sn_rcv_taumod = 'none' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'spherical' , 'eastward-northward' , 'U,V,F' + sn_rcv_dqnsdt = 'none' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce only' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce only' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'yes' , '' , '' , '' + sn_rcv_rnf = 'coupled1d' , 'no' , '' , '' , '' + sn_rcv_cal = 'none' , 'no' , '' , '' , '' + sn_rcv_co2 = 'none' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'coupled' , 'yes' , '' , '' , '' + 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' , '' , '' , '' + sn_rcv_ts_ice = 'ice' , 'yes' , '' , '' , '' + 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' , '' , '' , '' + sn_rcv_chnk = '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.0 , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120.0 , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120.0 , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120.0 , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120.0 , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120.0 , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120.0 , '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.0 ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! 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.0 , '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.0 ! magnitude of the retroaction on temperature [W/m2/K] + nn_sstr_bnd = 0 ! Method for capping SST damping heat fluxes + ! (=0 No capping; =1 capping Max; + ! =2 capping Min; =3 capping both Max/Min) + rn_sstr_bnd = 300 ! Capping value for SST damping heat fluxes [W/m2] + ! Max = ABS(DQDT_BND) if nn_sstr_bnd=1 + ! Min = -ABS(DQDT_BND) if nn_sstr_bnd=2 + ! Min=-ABS(DQDT_BND) and Max=ABS(DQDT_BND) if nn_sstr_bnd=3 + ln_sstr_mxl = .true. ! Capping SST damping heat flux only at MXL > rn_sstr_mxl + rn_sstr_mxl = 1000 ! Min value (in m) of mld (0.01 density change) that triggers capping + rn_dqdt_limice = 0.1 ! restoring term factors under ice [ratio] + rn_dqdt_limice_thres = 0.005 ! Minimum for apply rn_dqdt_limice + nn_sssr = 2 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + rn_deds = -33.3333333 ! 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.0 ! ABS(Max/Min) value of the damping erp term [mm/day] + 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' , 24 , 'sst' , .false. , .false., 'monthly' , '' , '' , '' + sn_sss = 'sss_1m.nc' , -1 , 'vosaline' , .true. , .true. , 'yearly' , 'sss_weights_bilin.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .true. ! specific treatment at rivers mouths + rn_hrnf = 10.0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T) + rn_avt_rnf = 0.002 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T) + rn_rfact = 1.0 ! 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_tem_mask = .false. ! the temperature field is a mask + 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 = 0.0005735 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150.0 ! 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 = .true. ! 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_1m_nomask.nc' , -1 , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' + sn_cnf = 'runoff_1m_nomask.nc' , 0 , 'socoefr', .false. , .true. , 'yearly' , '' , '' , '' + sn_s_rnf = 'runoffs' , 24.0 , 'rosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_t_rnf = 'runoff_1m_nomask.nc' , -12 , 'icbrnftemper', .false. , .true. , 'yearly' , '' , '' , '' + sn_dep_rnf = 'runoffs' , 0.0 , 'rodepth' , .false. , .true. , 'yearly' , '' , '' , '' + sn_i_rnf = 'NOT USED' , -1.0 , 'sofwficb', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000.0 ! 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.0 ,'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 = 3 ! 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 = 0.0001 ! gammat coefficient used in blk formula + rn_gammas0 = 0.0001 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30.0 ! 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.0 ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'runoff_1m_nomask.nc' , -12 ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='runoff_1m_nomask.nc' , -12 ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='runoff_1m_nomask.nc' , -12 ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12.0 ,'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.0 , 'drag_coeff' , .true. , .true. , 'yearly' , '' , '' , '' + sn_usd = 'sdw_ecwaves_orca2' , 6.0 , 'u_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsd = 'sdw_ecwaves_orca2' , 6.0 , 'v_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_hsw = 'sdw_ecwaves_orca2' , 6.0 , 'hs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wmp = 'sdw_ecwaves_orca2' , 6.0 , 'wmp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wfr = 'sdw_ecwaves_orca2' , 6.0 , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6.0 , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6.0 , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_inice = 'wave_icemask' , 6 , 'wave_icemask', .false. , .false. , 'monthly' , '' , '' , '' + sn_wspd = 'wspd' , 6 , 'wspd', .false. , .false. , 'monthly' , '' , '' , '' + sn_charnock = 'charnock' , 6 , 'Charnock', .false. , .false. , 'monthly' , '' , '' , '' + sn_mp1 = 'mp1' , 6 , 'mp1', .false. , .false. , 'monthly' , '' , '' , '' + sn_rhoa = 'rhoa' , 6 , 'rhoa', .false. , .false. , 'monthly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_fwb ! namsbc_fwb Fresh water budget +!----------------------------------------------------------------------- + rd_fwb = 1.0 ! time scale to apply fwb correction (days) + ikt_fwb = 1 ! freq (time steps) to estimate fwb + nr_ssh = 0 ! 0 for global sl=0. 1/2 for external SL/Mass file + cn_dir ='./' ! root directory for location of ssh file + sn_ssh = 'ssh' , -1.0 , 'ssh' , .true. , .true. , 'yearly', '', '', '' + rcap = 1.0 ! mm/day cap for FWB adjusment + lfwbr = .false. +/ +!----------------------------------------------------------------------- +&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 = 1 ! Turn on more verbose output if level > 0 + nn_verbose_write = 300 ! Timesteps between verbose messages + nn_sample_rate = 192 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 88000000.0, 410000000.0, 3300000000.0, 18000000000.0, 38000000000.0, 75000000000.0, 120000000000.0, 220000000000.0, 390000000000.0, 740000000000.0 + ! ! 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.0, 200.0, 50.0, 20.0, 10.0, 5.0, 2.0, 1.0, 1.0, 1.0 + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40.0, 67.0, 133.0, 175.0, 250.0, 250.0, 250.0, 250.0, 250.0, 250.0 + ! + rn_rho_bergs = 850.0 ! 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.0 ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0.0 ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0.4 ! CFL speed limit for a berg (safe value is 0.4, see #2581) + + 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' , -12 ,'soicbclv', .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 = 2 ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. + cn_shlat2d_file='shlat2d.nc' + cn_shlat2d_var='shlat2d' + ln_shlat2d=.true. +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- + ln_spc_dyn = .true. ! use 0 as special value for dynamics + rn_sponge_tra = 2880.0 ! coefficient for tracer sponge layer [m2/s] + rn_sponge_dyn = 2880.0 ! 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.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.0 ! Damping time scale in days + rn_time_dmp_out = 1.0 ! 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.0 , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24.0 , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24.0 , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24.0 , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24.0 , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24.0 , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24.0 , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' + bn_h_i = 'amm12_bdyT_ice' + bn_h_s = 'amm12_bdyT_ice' + bn_t_i = 'NOT USED' , 24.0 , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24.0 , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24.0 , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24.0 , '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.0 , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24.0 , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24.0 , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270.0 ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10.0 ! -- salinity -- + rn_ice_age = 30.0 ! -- 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 = .true. ! 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 = .true. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 0.001 ! 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 = 0.0025 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 0.003 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50.0 ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 0.001 ! 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 = 0.0025 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 0.003 ! roughness [m] (ln_loglayer=T) + ln_boost = .true. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50.0 ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! 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 = 0.0864 ! 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 , 'gh_flux', .false. , .true. , 'yearly' , 'geothermal_heating_weight.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag + nn_bbl_ldf = 1 ! diffusive bbl (=1) or not (=0) + nn_bbl_adv = 1 ! advective bbl (=1/2) or not (=0) + rn_ahtbbl = 1000.0 ! lateral mixing coefficient in the bbl [m2/s] + rn_gambbl = 10.0 ! 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 = 0.1655 ! thermal expension coefficient + rn_b0 = 0.76554 ! saline expension coefficient + rn_lambda1 = 0.05952 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0.00074914 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0.0001497 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.109e-05 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0.0024341 ! 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 = .true. ! 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 = .true. ! 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 = 20 ! 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.027 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Ld = 200000.0 ! 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 = 5000.0 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800.0 ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20.0 ! 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 = .true. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 21 ! 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 = 1.5 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Le = 33.0 ! 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 = .false. ! 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 = .true. ! vector form - 2nd centered scheme + nn_dynkeg = 1 ! 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 = .true. ! 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 = .true. ! 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 = .true. ! 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.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 = .true. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 20 ! 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.1895 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10000.0 ! 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.0 , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120.0 , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120.0 , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120.0 , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120.0 , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120.0 , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120.0 , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120.0 , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120.0 , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120.0 , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120.0 , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120.0 , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120.0 , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120.0 , '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 = .true. ! 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 = .true. ! enhanced vertical diffusion + nn_evdm = 1 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 10.0 ! 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 = .true. ! double diffusive mixing + rn_avts = 0.0001 ! 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_zdftmx = .true. ! old tidal mixing scheme (Simmons et al 2004) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! coefficients + rn_avm0 = 0.00012 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 1.2e-05 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst=F) + nn_avb = 0 ! profile for background avt & avm (=1) or not (=0) + nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 0.01 ! maximum value of the vertical viscosity + rn_alp = 5.0 ! 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 = 1e-06 ! minimum value of tke [m2/s2] + rn_emin0 = 0.0001 ! surface minimum value of tke [m2/s2] + rn_bshear = 1e-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.0 ! 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) + ln_wavetke = .true. ! Use wave model TKE flux + ln_ebbavg = .true. ! average out the surface value over first layer + rn_swhfr = 0.5 ! fraction of significant wave height to scale the TKE flux penetration (if ln_wavetke = T) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1e-07 ! minimum value of e [m2/s2] + rn_epsmin = 1e-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.0 ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000.0 ! 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.0 ! 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.0 ! 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.0 ! 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) +/ +!----------------------------------------------------------------------- +&namzdf_tmx ! tidal mixing parameterization ("key_zdftmx") +!----------------------------------------------------------------------- + rn_htmx = 500.0 ! vertical decay scale for turbulence (meters) + rn_n2min = 1e-08 ! 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.0 ! ITF tidal dissipation efficiency +/ + +!!====================================================================== +!! *** 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 = .true. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .true. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .true. ! 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 = .true. ! Logical switch for T profile observations + ln_s3d = .true. ! 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 = .true. ! 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 = .true. ! 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 = 10101.0 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 10102.0 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0.0 ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0.0 ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0.0 ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0.0 ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0.0 ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0.0 ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0.0 ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0.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 = -1 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = -1 ! 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 = .true. ! 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.0 ! 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) +/ +&namzdf_mldzint +nn_mld_diag=2 +sn_mld1=1,10.0,0.2,0.1, +sn_mld2=1,10.0,-0.2,0, +/ diff --git a/V4.0/inidata/path_to_initial_conditions.txt b/V4.0/inidata/path_to_initial_conditions.txt new file mode 100644 index 0000000000000000000000000000000000000000..f1a35340638a261b665123f9561909e3b6952978 --- /dev/null +++ b/V4.0/inidata/path_to_initial_conditions.txt @@ -0,0 +1,21 @@ +#Path to inidata for ORCA12 in MN4: + +/projects/bsc32/bsc32655/Earth/DestinE/inputdata/ifsbased/eORCA12/common/eORCA12_Z75/common/ + +#Path to forcings for eORCA12 in MN4 (from 1950-1960, 1985-1990): + +/gpfs/projects/bsc32/repository/fg/ocean/ERA5_HRES_eO12_smoothed/smooth1/ + +#Path to restarts for eORCA12 in MN4: + +#For 1950: + +/gpfs/scratch/bsc32/bsc32835/nemo-spinup/exp_outputs/ospinup-1950-1954-restarts/ospinup_19550101_000000_restart_oce.nc + +/gpfs/scratch/bsc32/bsc32835/nemo-spinup/exp_outputs/ospinup-1950-1954-restarts/ospinup_19550101_000000_restart_ice.nc + +#For 1990: + +/gpfs/scratch/bsc32/bsc32835/nemo-spinup/exp_outputs/ospinup-1985-1989-restartsospinup_19891231_000000_restart_oce.nc + +/gpfs/scratch/bsc32/bsc32835/nemo-spinup/exp_outputs/ospinup-1985-1989-restartsospinup_19891231_000000_restart_ice.nc diff --git a/V4.0/inidata/xios_configuration/axis_def_nemo.xml b/V4.0/inidata/xios_configuration/axis_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..a7d66bc6a820460428095e722764d0dfbcf5c2ba --- /dev/null +++ b/V4.0/inidata/xios_configuration/axis_def_nemo.xml @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/context_nemo.xml b/V4.0/inidata/xios_configuration/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..c5bbe64d374f4b16aafd6fae441056a4a37d8574 --- /dev/null +++ b/V4.0/inidata/xios_configuration/context_nemo.xml @@ -0,0 +1,22 @@ + + + 1900 + 01 + 01 + 1026.0 + 3991.86795711963 + 0.99530670233846 + 917.0 + 330.0 + 1.e20 + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/domain_def_nemo.xml b/V4.0/inidata/xios_configuration/domain_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..e9b8309457088888b000d39f5fc1bae4f690538c --- /dev/null +++ b/V4.0/inidata/xios_configuration/domain_def_nemo.xml @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/field_def_nemo-ice.xml b/V4.0/inidata/xios_configuration/field_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..631d2bf65bfab0e7c4fdccafa57637f41217f73c --- /dev/null +++ b/V4.0/inidata/xios_configuration/field_def_nemo-ice.xml @@ -0,0 +1,660 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 + + this * maskMFO_u_ice + + @ymtrpice + ymtrpice_ave + + this * maskMFO_v_ice + + @xmtrpsnw + xmtrpsnw_ave + + this * maskMFO_u_ice + + @ymtrpsnw + ymtrpsnw_ave + + this * maskMFO_v_ice + + @xatrp + xatrp_ave + + this * maskMFO_u_ice + + @yatrp + yatrp_ave + + this * maskMFO_v_ice + + xstrait_mifl + ystrait_mifl + xstrait_msfl + ystrait_msfl + xstrait_arfl + ystrait_arfl + + + + + + + + + + + + + + + + + + + + + + + + + + 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/V4.0/inidata/xios_configuration/field_def_nemo-oce.xml b/V4.0/inidata/xios_configuration/field_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..467626d329323a0313e612a7c80e551d978ebcdb --- /dev/null +++ b/V4.0/inidata/xios_configuration/field_def_nemo-oce.xml @@ -0,0 +1,1102 @@ + + + + + + + + + + + + + + + + + + + + + toce * e3t + + soce * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + + + + + + + + sst * sst + + + + + + + + + + + + sss * sss + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + this * maskMFO_u * $rau0 + + @voce_e3v + + this * e1v + + this * maskMFO_v * $rau0 + + u_masstr_strait + v_masstr_strait + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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/V4.0/inidata/xios_configuration/field_def_nemo-pisces.xml b/V4.0/inidata/xios_configuration/field_def_nemo-pisces.xml new file mode 100644 index 0000000000000000000000000000000000000000..c6210558a3a36d07cf1926cc6fdf819b4ea31c75 --- /dev/null +++ b/V4.0/inidata/xios_configuration/field_def_nemo-pisces.xml @@ -0,0 +1,319 @@ + + + + + + + + + + + + + + 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/V4.0/inidata/xios_configuration/field_def_xios2.xml b/V4.0/inidata/xios_configuration/field_def_xios2.xml new file mode 100644 index 0000000000000000000000000000000000000000..8a5faf48d8836cafa67c825831d5ad14c9f8f2e8 --- /dev/null +++ b/V4.0/inidata/xios_configuration/field_def_xios2.xml @@ -0,0 +1,1753 @@ + + + + + + + + + + + + + + + + + + + + toce * e3t + + soce * e3t + + + sst * sst + + + + + + + + + sss * sss + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 + + + 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) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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_iso_z1 + ttrd_zdf - ttrd_zdfp + strd_iso_z1 + strd_zdf - strd_zdfp + 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 + + strd_evd * e3t + + + ttrd_iso_x * e3t + strd_iso_x * e3t + ttrd_iso_y * e3t + strd_iso_y * e3t + ttrd_iso_z * e3t + strd_iso_z * 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_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 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + petrd_zdfp * e3t + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 + + + + Num * e3t + + + + DET * e3t + + DOM * e3t + + + + CFC11 * e3t + + CFC12 * e3t + + SF6 * e3t + + + + C14B * e3t + + + + Age * e3t + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/file_def_nemo-ice.xml b/V4.0/inidata/xios_configuration/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..cd309ca022dffaca06e4f8d5a369519e0031912a --- /dev/null +++ b/V4.0/inidata/xios_configuration/file_def_nemo-ice.xml @@ -0,0 +1,151 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/file_def_nemo-oce.xml b/V4.0/inidata/xios_configuration/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..6a5d7640613a113e0417cc39865e4ca73c215bb1 --- /dev/null +++ b/V4.0/inidata/xios_configuration/file_def_nemo-oce.xml @@ -0,0 +1,103 @@ + + + + + + + + + + + + sqrt( @sst2 - @sst * @sst ) + sqrt( @ssh2 - @ssh * @ssh ) + @sstmax - @sstmin --> + + + @mldr10_1max - @mldr10_1min + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/file_def_nemo-pisces.xml b/V4.0/inidata/xios_configuration/file_def_nemo-pisces.xml new file mode 100644 index 0000000000000000000000000000000000000000..d739549c022ee107c65492856cac7a12a2020770 --- /dev/null +++ b/V4.0/inidata/xios_configuration/file_def_nemo-pisces.xml @@ -0,0 +1,128 @@ + + + + + + + + + + tdenit * 14. * 86400. * 365. / 1e12 + tnfix * 14. * 86400. * 365. / 1e12 + tcflx * -1. * 12. * 86400. * 365. / 1e15 + tcflxcum * -1. * 12. / 1e15 + tcexp * 12. * 86400. * 365. / 1e15 + tintpp * 12. * 86400. * 365. / 1e15 + pno3tot * 16. / 122. * 1e6 + ppo4tot * 1. / 122. * 1e6 + psiltot * 1e6 + palktot * 1e6 + pfertot * 1e9 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/grid_def_nemo.xml b/V4.0/inidata/xios_configuration/grid_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..eb6d72d22a914aeede5ca27dbc2a16e39234a075 --- /dev/null +++ b/V4.0/inidata/xios_configuration/grid_def_nemo.xml @@ -0,0 +1,268 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/iodef.xml b/V4.0/inidata/xios_configuration/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..d4be5c1bd4104bfd3e1a69db33d6647804565cf9 --- /dev/null +++ b/V4.0/inidata/xios_configuration/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + 10 + false + false + oceanx + + + + + + + + + + + diff --git a/V4.0/inidata/xios_configuration/xios_server b/V4.0/inidata/xios_configuration/xios_server new file mode 100755 index 0000000000000000000000000000000000000000..9223d5639bd85953c3870aa443693e4ecd7985ad Binary files /dev/null and b/V4.0/inidata/xios_configuration/xios_server differ diff --git a/V4.0/nemo_sources/CHANGES.rst b/V4.0/nemo_sources/CHANGES.rst new file mode 100644 index 0000000000000000000000000000000000000000..90a08089d11134ee4383c3664ba9f3feb64f0948 --- /dev/null +++ b/V4.0/nemo_sources/CHANGES.rst @@ -0,0 +1,7 @@ +******* +Changes +******* + +.. todo:: + + List the main additions of the the new release diff --git a/V4.0/nemo_sources/CMakeLists.txt b/V4.0/nemo_sources/CMakeLists.txt new file mode 100644 index 0000000000000000000000000000000000000000..f49562013af168573b81dca190e131b371b2f44d --- /dev/null +++ b/V4.0/nemo_sources/CMakeLists.txt @@ -0,0 +1,169 @@ +# (C) Copyright 1996-2016 ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation nor +# does it submit to any jurisdiction. + +### EXTERNAL + +###################################################################################### +# definitions +###################################################################################### + +include( grid_configuration_NEMOGCM_${NEMO_VERSION} ) + +list( APPEND BUILD_DEFINITIONS_GRID + ${CONFIG_${GRID_CONFIG}} +) + +list( APPEND BUILD_DEFINITIONS_NEMOGCM_${NEMO_VERSION} + ${ARCH_${ARCH_CONFIG}_NEMOGCM_${NEMO_VERSION}} +) + +list( APPEND DEFINITIONS_INFO + ${BUILD_DEFINITIONS_GRID} + ${BUILD_DEFINITIONS_ICE} + ${BUILD_DEFINITIONS_NEMOGCM_${NEMO_VERSION}} + ${BUILD_DEFINITIONS_XIOS} + ${BUILD_DEFINITIONS_MULTIO} +) +ecbuild_debug( "Building NEMO ${NEMO_VERSION} with keys: ${DEFINITIONS_INFO}" ) + +###################################################################################### +# list directories +###################################################################################### + +list(APPEND ioipsl_${NEMO_VERSION}_dirs + ext/IOIPSL +) + +foreach( dir ${ioipsl_${NEMO_VERSION}_dirs} ) + ecbuild_list_add_pattern( LIST ioipsl_${NEMO_VERSION}_srcs GLOB "${dir}/*.c" QUIET ) + ecbuild_list_add_pattern( LIST ioipsl_${NEMO_VERSION}_srcs GLOB "${dir}/*.F*" QUIET ) + ecbuild_list_add_pattern( LIST ioipsl_${NEMO_VERSION}_srcs GLOB "${dir}/*.f*" QUIET ) +endforeach() + +#remove executables + +foreach( src ${ioipsl_${NEMO_VERSION}_srcs} ) + file(STRINGS ${src} is_program REGEX "^[ ]*[Pp][Rr][Oo][Gg][Rr][Aa][Mm][ ][ ]*[a-zA-Z]" LIMIT_COUNT 1) + if( is_program ) + list( REMOVE_ITEM ioipsl_${NEMO_VERSION}_srcs ${src} ) + endif() +endforeach() + +###################################################################################### +# add libraries +###################################################################################### + +ecbuild_add_library( TARGET + ioipsl_${NEMO_VERSION}.${PREC} + SOURCES + ${ioipsl_${NEMO_VERSION}_srcs} + LIBS + ${MPI_Fortran_LIBRARIES} + ${NETCDF_LIBRARIES} + ${DRHOOK_LIBRARIES} + PRIVATE_INCLUDES + ${MPI_Fortran_INCLUDE_PATH} + ${NETCDF_INCLUDE_DIRS} + DEFINITIONS + ${BUILD_DEFINITIONS_NEMOGCM_${NEMO_VERSION}} + ${BUILD_DEFINITIONS_GRID} + ) + +### NEMO_V40 + +###################################################################################### +# ice model config +###################################################################################### + +if( ${ICE_CONFIG} MATCHES "NONE" ) + set( ICE_${NEMO_VERSION}_SRC "" CACHE STRING "Ice model: none" ) +elseif( ${ICE_CONFIG} MATCHES "SI3" ) + set( ICE_${NEMO_VERSION}_SRC "src/ICE" CACHE STRING "Ice model: SI3" ) +endif() + +ecbuild_info( "NEMO_VERSION: ${NEMO_VERSION} " ) +ecbuild_info( "ICE SRC: ${ICE_CONFIG}, ${ICE_${NEMO_VERSION}_SRC} " ) + +###################################################################################### +# list directories +###################################################################################### + +list( APPEND nemo_${NEMO_VERSION}_dirs + ${ICE_${NEMO_VERSION}_SRC} + src/OCE +) + +foreach( dir ${nemo_${NEMO_VERSION}_dirs} ) + ecbuild_list_add_pattern( LIST nemo_${NEMO_VERSION}_srcs GLOB "${dir}/*.c" QUIET ) + ecbuild_list_add_pattern( LIST nemo_${NEMO_VERSION}_srcs GLOB "${dir}/*.F*" QUIET ) + ecbuild_list_add_pattern( LIST nemo_${NEMO_VERSION}_srcs GLOB "${dir}/*.f*" QUIET ) +endforeach() + +# MC +list( APPEND nemo_${NEMO_VERSION}_srcs + tools/OBSTOOLS/src/obs_sst_io.F90 +) + +# Following files are executables and cannot be linked in same library (duplicate main_ symbol) +ecbuild_list_exclude_pattern( LIST nemo_${NEMO_VERSION}_srcs REGEX "src/OCE/nemo.f90" ) + +# Fix for SEGV in wrk_deallocbase of wrk_nemo.F90 +if($ENV{CRAY_FTN_VERSION} MATCHES 8.7.7) + set_source_files_properties(NEMO/OPA_SRC/wrk_nemo.F90 + PROPERTIES COMPILE_FLAGS "-O0,fp1,omp") +endif() + +###################################################################################### +# add libraries +###################################################################################### + +ecbuild_add_library( TARGET + nemo_${NEMO_VERSION}.${PREC} + SOURCES + ${nemo_${NEMO_VERSION}_srcs} + PUBLIC_LIBS + ioipsl_${NEMO_VERSION}.${PREC} + ${NETCDF_LIBRARIES} + ${XIOS_LIBRARIES} + ${MULTIO_LIBRARIES} + PRIVATE_INCLUDES + ${MPI_Fortran_INCLUDE_PATH} + ${NETCDF_INCLUDE_DIRS} + ${XIOS_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR}/src/OCE #include vectopt_loop_substitute.h90/lib_fortran_generic.h90 + ${CMAKE_CURRENT_SOURCE_DIR}/tools/OBSTOOLS/src #include obssst_io.h + DEFINITIONS + ${BUILD_DEFINITIONS_NEMOGCM_${NEMO_VERSION}} + ${BUILD_DEFINITIONS_GRID} + ${BUILD_DEFINITIONS_ICE} + ${BUILD_DEFINITIONS_XIOS} + ${BUILD_DEFINITIONS_MULTIO} + ) + +###################################################################################### +# add executables and installation +###################################################################################### + +ecbuild_add_executable( TARGET + nemo_${NEMO_VERSION}_${GRID_CONFIG}.exe + SOURCES + src/OCE/nemo.f90 + LIBS + nemo_${NEMO_VERSION}.${PREC} + DEFINITIONS + ${BUILD_DEFINITIONS_NEMOGCM_${NEMO_VERSION}} + ${BUILD_DEFINITIONS_GRID} + ${BUILD_DEFINITIONS_ICE} + ${BUILD_DEFINITIONS_XIOS} + ${BUILD_DEFINITIONS_MULTIO} +) + +install( TARGETS + nemo_${NEMO_VERSION}_${GRID_CONFIG}.exe + DESTINATION + build-nemo-${NEMO_VERSION}/bin ) diff --git a/V4.0/nemo_sources/CONTRIBUTING.rst b/V4.0/nemo_sources/CONTRIBUTING.rst new file mode 100644 index 0000000000000000000000000000000000000000..780797fb2131b9969d753bb76b0bdfd190620a5c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/INSTALL.rst b/V4.0/nemo_sources/INSTALL.rst new file mode 100644 index 0000000000000000000000000000000000000000..6eec799f960bc78c5b3fe765a459c1caa1223e59 --- /dev/null +++ b/V4.0/nemo_sources/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-block:: 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-block:: console + + $ svn co https://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/r4.0/r4.0.6 + +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/V4.0/nemo_sources/LICENSE b/V4.0/nemo_sources/LICENSE new file mode 100644 index 0000000000000000000000000000000000000000..fcc8df26b07f09b1d12fc9c8e8b161423ae45bdf --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/README.rst b/V4.0/nemo_sources/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..3d6f72bbae2f0ae52232e14a4c75fd4ffc308859 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/REFERENCES.bib b/V4.0/nemo_sources/REFERENCES.bib new file mode 100644 index 0000000000000000000000000000000000000000..bb87f26f1b78fe0532d89611b29ec153b6948fa2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CMCC/arch-gfortran_athena_xios.fcm b/V4.0/nemo_sources/arch/CMCC/arch-gfortran_athena_xios.fcm new file mode 100644 index 0000000000000000000000000000000000000000..356559c473d005440b346eab0503590b5ab13c15 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena.fcm b/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena.fcm new file mode 100644 index 0000000000000000000000000000000000000000..eb6fec29ea3cdb912a19fc9e43e857222895c958 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_debug.fcm b/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3b04e5b775e49be5aa163fe14a3478a77b6f9f63 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_tools.fcm b/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_tools.fcm new file mode 100644 index 0000000000000000000000000000000000000000..eac9f2685b78096b5cb1b89fe56cf6d561572fd9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_xios.fcm b/V4.0/nemo_sources/arch/CMCC/arch-ifort_athena_xios.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b18dfc4b2668608b594a0c32ee4d1181521a912c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA.fcm new file mode 100644 index 0000000000000000000000000000000000000000..dd57e9772ba1131e2d2f3858f799d142644681ce --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA_DEBUG.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA_DEBUG.fcm new file mode 100644 index 0000000000000000000000000000000000000000..2ac5e70c2ceabb72479c2f3538dd180cc3e9e051 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA_O0.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_ADA_O0.fcm new file mode 100644 index 0000000000000000000000000000000000000000..489b8f9cea79d3fa04e8b520fe8f55252c4d6dd3 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_IRENE.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_IRENE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d24e954baa2ed81ad2312cb70cd5be68b94e986f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_IRENE_DEBUG.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_IRENE_DEBUG.fcm new file mode 100644 index 0000000000000000000000000000000000000000..25b50f675731353d860557ad9e060f8a67bfdacc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_JEANZAY.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_JEANZAY.fcm new file mode 100644 index 0000000000000000000000000000000000000000..cb2137c9e53d3d83668b1f098d1c039996d2b92b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/CNRS/arch-X64_JEANZAY_DEBUG.fcm b/V4.0/nemo_sources/arch/CNRS/arch-X64_JEANZAY_DEBUG.fcm new file mode 100644 index 0000000000000000000000000000000000000000..fbc7ff5626ea59510838c192d160b34dcc0b7f91 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/INGV/arch-IBM_EKMAN_INGV.fcm b/V4.0/nemo_sources/arch/INGV/arch-IBM_EKMAN_INGV.fcm new file mode 100644 index 0000000000000000000000000000000000000000..fae77f4dcbab511a45906610617770fdb8e577f3 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/MERCATOR/arch-openmpi_KARA_MERCATOR_XIOS.fcm b/V4.0/nemo_sources/arch/MERCATOR/arch-openmpi_KARA_MERCATOR_XIOS.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b83ed3c83edb80d10502ee2afd639208daa4afa9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/NOC/arch-ALTIX_NAUTILUS_MPT.fcm b/V4.0/nemo_sources/arch/NOC/arch-ALTIX_NAUTILUS_MPT.fcm new file mode 100644 index 0000000000000000000000000000000000000000..10d53a43c566d7691deb9d0007bb952a2c7b0aa4 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/NOC/arch-THALASSA.fcm b/V4.0/nemo_sources/arch/NOC/arch-THALASSA.fcm new file mode 100644 index 0000000000000000000000000000000000000000..937f6b4aab5781b7a36d98f5260e46a959355b67 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/NOC/arch-X64_MOBILIS.fcm b/V4.0/nemo_sources/arch/NOC/arch-X64_MOBILIS.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d0466731a8665f483faddadd81cf1ab537a1e4fe --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/NOC/arch-XC_ARCHER.fcm b/V4.0/nemo_sources/arch/NOC/arch-XC_ARCHER.fcm new file mode 100644 index 0000000000000000000000000000000000000000..519063a2ee8d983150841cb6c55713c3dd5205df --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/NOC/arch-XC_ARCHER_INTEL.fcm b/V4.0/nemo_sources/arch/NOC/arch-XC_ARCHER_INTEL.fcm new file mode 100644 index 0000000000000000000000000000000000000000..00f64f565b705e357f38335af2d80c68066a50bc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/UKMO/arch-PW7_METO.fcm b/V4.0/nemo_sources/arch/UKMO/arch-PW7_METO.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d1bc356e2caf3abde712d58cb1050e4562c63840 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/UKMO/arch-PW7_MONSOON.fcm b/V4.0/nemo_sources/arch/UKMO/arch-PW7_MONSOON.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b4738abd52d287ec7a567f34176927be12ac2aa2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO.fcm b/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d4dcf57ad81fa96f21ff2e4f2fdca60965b63ad4 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO_IFORT.fcm b/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO_IFORT.fcm new file mode 100644 index 0000000000000000000000000000000000000000..83470b69a78a76dd10af9336db6619e0a06f2352 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO_debug.fcm b/V4.0/nemo_sources/arch/UKMO/arch-XC40_METO_debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..e3805f8e2cfaad350b5057b01ff337d66961e987 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-gnu-debug.fcm b/V4.0/nemo_sources/arch/arch-gnu-debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b4c69f34778beef6cc57e919d33e07497faeb6fe --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-gnu-debug.fcm @@ -0,0 +1,30 @@ + + +%XIOS_HOME /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I/apps/NETCDF/4.6.1/GCC/OPENMPI/include +%NCDF_LIB -L/apps/NETCDF/4.6.1/GCC/OPEN/lib -lnetcdf -lnetcdff + +%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 -Dkey_nosignedzero +%FC mpif90 -c -cpp +%FCFLAGS -Wno-argument-mismatch -fno-range-check -O0 -fdefault-double-8 -fdefault-real-8 -funroll-all-loops -fcray-pointer -ffree-line-length-none -g +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O3 + diff --git a/V4.0/nemo_sources/arch/arch-gnu.fcm b/V4.0/nemo_sources/arch/arch-gnu.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b89408b43513c4af83eb53e04819b8bfe1cd52b5 --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-gnu.fcm @@ -0,0 +1,30 @@ + + +%XIOS_HOME /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I/apps/NETCDF/4.6.1/GCC/OPENMPI/include +%NCDF_LIB -L/apps/NETCDF/4.6.1/GCC/OPEN/lib -lnetcdf -lnetcdff + +%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 -Dkey_nosignedzero +%FC mpif90 -c -cpp -Dkey_nosignedzero +%FCFLAGS -Wno-argument-mismatch -fno-range-check -O3 -fdefault-double-8 -fdefault-real-8 -funroll-all-loops -fcray-pointer -ffree-line-length-none -Dkey_nosignedzero +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O3 + diff --git a/V4.0/nemo_sources/arch/arch-linux_gfortran.fcm b/V4.0/nemo_sources/arch/arch-linux_gfortran.fcm new file mode 100644 index 0000000000000000000000000000000000000000..9f767f1d851c4542ab65339897102c63af443210 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-linux_ifort.fcm b/V4.0/nemo_sources/arch/arch-linux_ifort.fcm new file mode 100644 index 0000000000000000000000000000000000000000..f83590a6ee8e46a8595f6a27ffaf7cb19527e829 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-linux_ifort_omp.fcm b/V4.0/nemo_sources/arch/arch-linux_ifort_omp.fcm new file mode 100644 index 0000000000000000000000000000000000000000..e695f81128fbf221a792fae958a549ce8b4b38d3 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-linux_pgf90.fcm b/V4.0/nemo_sources/arch/arch-linux_pgf90.fcm new file mode 100644 index 0000000000000000000000000000000000000000..24d3cdca1395214bd0ec8e8df741f45af6455f3b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-mn4-debug-2.fcm b/V4.0/nemo_sources/arch/arch-mn4-debug-2.fcm new file mode 100644 index 0000000000000000000000000000000000000000..dfd26d1c6813be403fa0d7798eb88c92cf9d3d8d --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-mn4-debug-2.fcm @@ -0,0 +1,37 @@ +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L if you have libraries in a +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC additional include files for the compiler, e.g. -I +# USER_LIB additional libraries to pass to the linker, e.g. -l + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O0 -fp-model strict -extend-source 132 -heap-arrays -g -traceback +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/nemo_sources/arch/arch-mn4-debug.fcm b/V4.0/nemo_sources/arch/arch-mn4-debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..db5c70d3b1271b357b0843493eea80ba9a4ee213 --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-mn4-debug.fcm @@ -0,0 +1,37 @@ +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L if you have libraries in a +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC additional include files for the compiler, e.g. -I +# USER_LIB additional libraries to pass to the linker, e.g. -l + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O0 -fp-model strict -extend-source 132 -heap-arrays -xCORE-AVX512 -mtune=core-avx2 -g -traceback -fpe-0 +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/nemo_sources/arch/arch-mn4-debug_bad.fcm b/V4.0/nemo_sources/arch/arch-mn4-debug_bad.fcm new file mode 100644 index 0000000000000000000000000000000000000000..7e7c2bf5493328b6e3823091f8cc00126f6c7d81 --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-mn4-debug_bad.fcm @@ -0,0 +1,43 @@ + +%RPE_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/rpe +%RPE_INC -I%RPE_DIR/modules +%RPE_LIB %RPE_DIR/lib/librpe.a + +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L if you have libraries in a +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC additional include files for the compiler, e.g. -I +# USER_LIB additional libraries to pass to the linker, e.g. -l + +%CPP cpp + +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -g -traceback +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC %RPE_INC +%USER_LIB %NCDF_LIB %XIOS_LIB %RPE_LIB diff --git a/V4.0/nemo_sources/arch/arch-mn4.fcm b/V4.0/nemo_sources/arch/arch-mn4.fcm new file mode 100644 index 0000000000000000000000000000000000000000..925856ee6c5e211ef7187ce247cee1e92750d3f6 --- /dev/null +++ b/V4.0/nemo_sources/arch/arch-mn4.fcm @@ -0,0 +1,37 @@ +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L if you have libraries in a +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC additional include files for the compiler, e.g. -I +# USER_LIB additional libraries to pass to the linker, e.g. -l + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/nemo_sources/arch/arch-osx_gfortran.fcm b/V4.0/nemo_sources/arch/arch-osx_gfortran.fcm new file mode 100644 index 0000000000000000000000000000000000000000..708204cb78efe7bc3c2ced6aca0e618309cfd37c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/arch-osx_gfortran_debug.fcm b/V4.0/nemo_sources/arch/arch-osx_gfortran_debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..bf251ea72d9be36375f273db05cc300a6b32a3f5 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-ALTIX_JADE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-ALTIX_JADE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..deba776fa2a920e0e7ec017845c3597d2a096ab7 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-BG_BABEL.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-BG_BABEL.fcm new file mode 100644 index 0000000000000000000000000000000000000000..ad4d22fb7de6cdd3a3e5e10171a31bf6711fea03 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-IA64_PLATINE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-IA64_PLATINE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..71ad8cf9c7c56fc1349626cccce4c105aa8a14c5 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-PW6MONO_VARGAS.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-PW6MONO_VARGAS.fcm new file mode 100644 index 0000000000000000000000000000000000000000..c9718e1139f77ebee38ccd5c52d4c0fe5f75c51f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-PW6_VARGAS.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-PW6_VARGAS.fcm new file mode 100644 index 0000000000000000000000000000000000000000..1be6a56d26e591d9ad035615b812d801272edef2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-SX8_BRODIE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-SX8_BRODIE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..1af6300db8178f301f00a6ddeea9c8a57bd1167d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-SX8_MERCURE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-SX8_MERCURE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..36953ff0a3d2fc5f18a71583454433bc5ee5a289 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-SX9_ES2.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-SX9_ES2.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3300b08d499eacf740f14bea30b1f4973da17c9e --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-SX9_MERCURE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-SX9_MERCURE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..a47f0883841e4d4c5bbdf88d671a0b53fa1f0d1d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-TX7_ULAM.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-TX7_ULAM.fcm new file mode 100644 index 0000000000000000000000000000000000000000..36138cda508373d249052ddcb9152f8418d4ebd7 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-X64_CURIE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-X64_CURIE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..8689911b484a91890ab427a4472f1f9d377e1a0b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-X64_TITANE.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-X64_TITANE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..31ff8ae69892855a62f17ae23136149964e2be20 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-X86_CESIUM.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-X86_CESIUM.fcm new file mode 100644 index 0000000000000000000000000000000000000000..146e23a7d8551a64efc2181e24f4ae002764b627 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/CNRS/arch-ifort_CICLAD.fcm b/V4.0/nemo_sources/arch/depr/CNRS/arch-ifort_CICLAD.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3243cac7f23bea3199065360766db10dd9466360 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/MERCATOR/arch-ifort_MERCATOR_CLUSTER.fcm b/V4.0/nemo_sources/arch/depr/MERCATOR/arch-ifort_MERCATOR_CLUSTER.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3bc0b5d253e9e8dab50dfc8eebc3a199eb988cbd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/NOC/arch-ALTIX_NAUTILUS.fcm b/V4.0/nemo_sources/arch/depr/NOC/arch-ALTIX_NAUTILUS.fcm new file mode 100644 index 0000000000000000000000000000000000000000..1f1a6e9d8f5353d1065129c32ed316e11893e4dc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/NOC/arch-XT6_HECTORcrayftn.fcm b/V4.0/nemo_sources/arch/depr/NOC/arch-XT6_HECTORcrayftn.fcm new file mode 100644 index 0000000000000000000000000000000000000000..8d2f10927286351d81b2d457ba21fd8ef11cbd5d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/NOC/arch-pgf90_mobius.fcm b/V4.0/nemo_sources/arch/depr/NOC/arch-pgf90_mobius.fcm new file mode 100644 index 0000000000000000000000000000000000000000..82dcbc91c904641e1723ac5bb7b6664126885618 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/UKMO/arch-PW6_METO.fcm b/V4.0/nemo_sources/arch/depr/UKMO/arch-PW6_METO.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3a651f9f0d061ab165e4b0796ffb7c8792528fcd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/UKMO/arch-XT6_HECTOR.fcm b/V4.0/nemo_sources/arch/depr/UKMO/arch-XT6_HECTOR.fcm new file mode 100644 index 0000000000000000000000000000000000000000..da0355570d3373ce01931b1534dc51fd5302f1a8 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-linux_g95.fcm b/V4.0/nemo_sources/arch/depr/arch-linux_g95.fcm new file mode 100644 index 0000000000000000000000000000000000000000..c8bdd0b2c89ef9df4bc73a2f20fd985d02411d0c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-linux_lahey.fcm b/V4.0/nemo_sources/arch/depr/arch-linux_lahey.fcm new file mode 100644 index 0000000000000000000000000000000000000000..0e649813cb58629a84e4edc81d1fccfe3ee0e419 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-linux_nag.fcm b/V4.0/nemo_sources/arch/depr/arch-linux_nag.fcm new file mode 100644 index 0000000000000000000000000000000000000000..401f42ffa23e289884fbc68668bee11bd0bc1351 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-linux_pathscale.fcm b/V4.0/nemo_sources/arch/depr/arch-linux_pathscale.fcm new file mode 100644 index 0000000000000000000000000000000000000000..e9338257b46a95321853695cf5879df73836ab92 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-mpxlf_aix.fcm b/V4.0/nemo_sources/arch/depr/arch-mpxlf_aix.fcm new file mode 100644 index 0000000000000000000000000000000000000000..3dc72eca32a208ee5e3f3ed4a25ff4e7c8a8f8e2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-osx_g95.fcm b/V4.0/nemo_sources/arch/depr/arch-osx_g95.fcm new file mode 100644 index 0000000000000000000000000000000000000000..ac6e7aa0b5eb87ca004e509653fc26d0962b204a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-osx_ifort.fcm b/V4.0/nemo_sources/arch/depr/arch-osx_ifort.fcm new file mode 100644 index 0000000000000000000000000000000000000000..bb1e6327f4534a1102dd5d30a8f2564242bc5420 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/arch-osx_xlf.fcm b/V4.0/nemo_sources/arch/depr/arch-osx_xlf.fcm new file mode 100644 index 0000000000000000000000000000000000000000..534f61ab320027c5ff5fb7b5d2bd8060c3cc0e47 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/misc/arch-PW6_C1A.fcm b/V4.0/nemo_sources/arch/depr/misc/arch-PW6_C1A.fcm new file mode 100644 index 0000000000000000000000000000000000000000..aa82328fd276342ec15e773c8159162cc895e682 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/misc/arch-X64_VAYU.fcm b/V4.0/nemo_sources/arch/depr/misc/arch-X64_VAYU.fcm new file mode 100644 index 0000000000000000000000000000000000000000..ce8993b0df76be51a3812290f4e758a5d5cac110 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/misc/arch-X64_YELLOWSTONE.fcm b/V4.0/nemo_sources/arch/depr/misc/arch-X64_YELLOWSTONE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..6df53cf53710d3e73cc12ea5c5d2b3e6becff078 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/misc/arch-xlf_aix.fcm b/V4.0/nemo_sources/arch/depr/misc/arch-xlf_aix.fcm new file mode 100644 index 0000000000000000000000000000000000000000..310a3f24c691927d46e876497b0e99da6d29bb46 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/depr/misc/arch-xlf_pwr6.fcm b/V4.0/nemo_sources/arch/depr/misc/arch-xlf_pwr6.fcm new file mode 100644 index 0000000000000000000000000000000000000000..f86e81748165516c782ba02024cdb69fcc5c0708 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/misc/arch-PW7_C2A_XIO.fcm b/V4.0/nemo_sources/arch/misc/arch-PW7_C2A_XIO.fcm new file mode 100644 index 0000000000000000000000000000000000000000..9e8b618cc33ec125f12c41b863fae52019315700 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/arch/misc/arch-X64_BULL.fcm b/V4.0/nemo_sources/arch/misc/arch-X64_BULL.fcm new file mode 100644 index 0000000000000000000000000000000000000000..1f5db75d2273c84aaabdd8f3c72eed5dcd70048a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1ccdc4912db6116c4f1c2da4294bf33e556b888d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..e351986feb4dc176435c3d25facea48a85ae8b14 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml @@ -0,0 +1,42 @@ + + + + + + 1900 + 01 + 01 + 1026.0 + 3991.86795711963 + 0.99530670233846 + 917.0 + 330.0 + 1.e20 + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..37482d1b32e013eb7861cc4cbd4a03d468ddff06 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-ice.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-ice.xml new file mode 120000 index 0000000000000000000000000000000000000000..8d41d507e2c112142f90b9b8deb0329cd0eab73a --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-ice.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-ice.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..0e209593f235eee38043b2a20592006673492720 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-pisces.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-pisces.xml new file mode 120000 index 0000000000000000000000000000000000000000..ee60c11e381c91f3ba94405b50ecced4be8de64d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/field_def_nemo-pisces.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-pisces.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-ice.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..b578a4dd9489bb58b06386ce72b6999779f337a5 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-ice.xml @@ -0,0 +1,151 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..9f0eb1c8c3f8138ae4db21ed580fa4ba98a620ef --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,168 @@ + + + + + + + + + + @toce_e3t / @e3t + @soce_e3t / @e3t + + + + sqrt( @sst2 - @sst * @sst ) + sqrt( @ssh2 - @ssh * @ssh ) + @sstmax - @sstmin + + + @mldr10_1max - @mldr10_1min + + + + + + + + + + + + + + + + + + + + @uoce_e3u / @e3u + + + + + + + + + + + + @voce_e3v / @e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-pisces.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-pisces.xml new file mode 100644 index 0000000000000000000000000000000000000000..d739549c022ee107c65492856cac7a12a2020770 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-pisces.xml @@ -0,0 +1,128 @@ + + + + + + + + + + tdenit * 14. * 86400. * 365. / 1e12 + tnfix * 14. * 86400. * 365. / 1e12 + tcflx * -1. * 12. * 86400. * 365. / 1e15 + tcflxcum * -1. * 12. / 1e15 + tcexp * 12. * 86400. * 365. / 1e15 + tintpp * 12. * 86400. * 365. / 1e15 + pno3tot * 16. / 122. * 1e6 + ppo4tot * 1. / 122. * 1e6 + psiltot * 1e6 + palktot * 1e6 + pfertot * 1e9 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..a279623c6d56ac41854ef1d315057c6e0bae37e5 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/iodef.xml b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..d4be5c1bd4104bfd3e1a69db33d6647804565cf9 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + 10 + false + false + oceanx + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..ae4580c79c19e757ea896c42a4986b99e77a82d6 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg @@ -0,0 +1,425 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ORCA2 - ICE - PISCES configuration !! +!!====================================================================== +!! *** Domain & Run management namelists *** !! +!! !! +!! namrun parameters of the run +!! namdom space and time domain +!! namcfg parameters of the configuration (default: user defined GYRE) +!! namwad Wetting and drying (default: OFF) +!! namtsd data: temperature & salinity (default: OFF) +!! namcrs coarsened grid (for outputs and/or TOP) (ln_crs =T) +!! namc1d 1D configuration options ("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 = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5475) + nn_istate = 0 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 5400. ! time step for the dynamics and tracer +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "ORCA_R2_zps_domcfg" ! domain configuration filename + ! + ln_closea = .false. ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .true. ! ocean initialisation + ln_tsd_dmp = .true. ! T-S restoring (see namtra_dmp) + + cn_dir = './' ! root directory for the T-S data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_tem = 'data_1m_potential_temperature_nomask', -1. ,'votemper', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'data_1m_salinity_nomask' , -1. ,'vosaline', .true. , .true. , 'yearly' , '' , '' , '' +/ +!!====================================================================== +!! *** Surface Boundary Condition namelists *** !! +!! !! +!! namsbc surface boundary condition manager (default: NO selection) +!! namsbc_flx flux formulation (ln_flx =T) +!! namsbc_blk Bulk formulae formulation (ln_blk =T) +!! namsbc_cpl CouPLed formulation ("key_oasis3" ) +!! namsbc_sas Stand-Alone Surface module (SAS_SRC only) +!! namsbc_iif Ice-IF: use observed ice cover (nn_ice = 1 ) +!! namtra_qsr penetrative solar radiation (ln_traqsr =T) +!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T) +!! namsbc_rnf river runoffs (ln_rnf =T) +!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T) +!! namsbc_isf ice shelf melting/freezing (ln_isfcav =T : read (ln_read_cfg=T) or set or usr_def_zgr ) +!! namsbc_iscpl coupling option between land ice model and ocean (ln_isfcav =T) +!! namsbc_wave external fields from wave model (ln_wave =T) +!! namberg iceberg floats (ln_icebergs=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition manager (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 4 ! frequency of SBC module call + ! (also = the frequency of sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk ) + ! Sea-ice : + nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! except in AGRIF zoom where it has to be specified + ! Misc. options of sbc : + ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) + nn_fwb = 2 ! FreshWater Budget: + ! ! =2 annual global mean of e-p-r set to zero + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + 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) +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008) + + cn_dir = './' ! root directory for the bulk data location + !___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_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' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue) + ! + nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0) + + cn_dir = './' ! root directory for the chlorophyl data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_chl ='chlorophyll' , -1. , 'CHLA' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) +!----------------------------------------------------------------------- + nn_sssr = 2 ! add a damping term to the surface freshwater flux + rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day] + ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2) + rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day] +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .true. ! specific treatment at rivers mouths + rn_hrnf = 15.e0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T) + rn_avt_rnf = 1.e-3 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T) + rn_rfact = 1.e0 ! multiplicative factor for runoff + + cn_dir = './' ! root directory for the location of the runoff files + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_rnf = 'runoff_core_monthly', -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' + sn_cnf = 'runoff_core_monthly', 0. , 'socoefr0', .false. , .true. , 'yearly' , '' , '' , '' + sn_s_rnf = 'runoffs' , 24. , 'rosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_t_rnf = 'runoffs' , 24. , 'rotemper', .true. , .true. , 'yearly' , '' , '' , '' + sn_dep_rnf = 'runoffs' , 0. , 'rodepth' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .true. ! activate iceberg floats (force =F with "key_agrif") + + cn_dir = './' ! root directory for the location of drag coefficient files + !______!___________!___________________!______________!______________!_________!___________!__________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F ) ! 'monthly' ! filename ! pairing ! filename ! + sn_icb = 'calving', -1. , 'calving' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!!====================================================================== +!! *** Lateral boundary condition *** !! +!! !! +!! namlbc lateral momentum boundary condition (default: NO selection) +!! namagrif agrif nested grid (read by child model only) ("key_agrif") +!! nam_tide Tidal forcing (default: OFF) +!! nambdy Unstructured open boundaries (default: OFF) +!! nambdy_dta Unstructured open boundaries - external data (see nambdy) +!! nambdy_tide tidal forcing at open boundaries (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 2. ! no slip +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- + ln_spc_dyn = .true. ! use 0 as special value for dynamics + rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s] + rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s] + ln_chk_bathy = .false. ! =T check the parent bathymetry +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_drg_OFF=F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_drg_OFF=F) +!! nambbc bottom temperature boundary condition (default: OFF) +!! nambbl bottom boundary layer scheme (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_lin = .true. ! linear drag: Cd = Cd0 Uc0 +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 2 read variable flux [mW/m2] + + cn_dir = './' ! root directory for the geothermal data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_qgh ='geothermal_heating.nc' , -12. , 'heatflow', .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag + nn_bbl_ldf = 1 ! diffusive bbl (=1) or not (=0) + nn_bbl_adv = 0 ! advective bbl (=1/2) or not (=0) + rn_ahtbbl = 1000. ! lateral mixing coefficient in the bbl [m2/s] + rn_gambbl = 10. ! advective bbl coefficient [s] +/ +!!====================================================================== +!! Tracer (T-S) namelists !! +!! !! +!! nameos equation of state (default: NO selection) +!! namtra_adv advection scheme (default: NO selection) +!! namtra_ldf lateral diffusion scheme (default: NO selection) +!! namtra_mle mixed layer eddy param. (Fox-Kemper param.) (default: OFF) +!! namtra_eiv eddy induced velocity param. (default: OFF) +!! namtra_dmp T & S newtonian damping (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nameos ! ocean Equation Of Seawater (default: NO selection) +!----------------------------------------------------------------------- + ln_eos80 = .true. ! = Use EOS80 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_lap = .true. ! laplacian operator + ln_traldf_iso = .true. ! iso-neutral (Standard operator) + ln_traldf_msc = .true. ! Method of Stabilizing Correction (both operators) + ! ! Coefficients: + nn_aht_ijk_t = 20 ! space/time variation of eddy coef + ! ! = 20 aht = 1/2 Ud. max(e1,e2) + rn_Ud = 0.018 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Ld = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) +/ +!----------------------------------------------------------------------- +&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) +!----------------------------------------------------------------------- + ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .true. ! use eddy induced velocity parameterization + ! ! Coefficients: + nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.03 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Le = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) + ! + ln_ldfeiv_dia =.true. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .true. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4 +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = -30 ! =-30 3D coeff. read in eddy_diffusivity_3D.nc +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfevd = .true. ! Enhanced Vertical Diffusion scheme + nn_evdm = 0 ! evd apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! evd mixing coefficient [m2/s] + ln_zdfddm = .true. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm) + ! ! Coefficients + rn_avm0 = 1.2e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 1.2e-5 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst=F) + nn_avb = 0 ! profile for background avt & avm (=1) or not (=0) + nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + nn_mxl = 3 ! mixing length: = 0 bounded by the distance to surface and bottom + ! ! = 1 bounded by the local vertical scale factor + ! ! = 2 first vertical derivative of mixing length bounded by 1 + ! ! = 3 as =2 with distinct dissipative an mixing length scale + nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs + ! = 0 none ; = 1 add a tke source below the ML + ! = 2 add a tke source just at the base of the ML + ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 2 ! 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_cfg b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..87d3de1e0c3b54fc53bf672680ee981d2634d5da --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_cfg @@ -0,0 +1,85 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ + ln_aEVP = .false. ! adaptive rheology (Kimmritz et al. 2016 & 2017) +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_ref b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..46b604583df4e381310f02355cef579a393f2be7 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ice_ref @@ -0,0 +1 @@ +../../SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_cfg b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_cfg new file mode 100644 index 0000000000000000000000000000000000000000..7fcf6a35c9b8f8b4bf0f4300c6dba1bcd9bb2300 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_cfg @@ -0,0 +1,132 @@ +!----------------------------------------------------------------------- +&nampismod ! Model used +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisext ! air-sea exchange +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisatm ! Atmospheric prrssure +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisbio ! biological parameters +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zlim ! parameters for nutrient limitations for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zlim ! parameters for nutrient limitations PISCES QUOTA - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zquota ! parameters for nutrient limitations PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisopt ! parameters for optics +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zprod ! parameters for phytoplankton growth for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zprod ! parameters for phytoplankton growth for PISCES quota- ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmort ! parameters for phytoplankton sinks for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmort ! parameters for phytoplankton sinks for PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmes ! parameters for mesozooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmes ! parameters for mesozooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zzoo ! parameters for microzooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zzoo ! parameters for microzooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisfer ! parameters for iron chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisrem ! parameters for remineralization +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampispoc ! parameters for organic particles +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampiscal ! parameters for Calcite chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampissbc ! parameters for inputs deposition +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampislig ! Namelist parameters for ligands, nampislig +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisice ! Prescribed sea ice tracers +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisdmp ! Damping +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampismass ! Mass conservation +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobphy ! biological parameters for phytoplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobnut ! biological parameters for nutrients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobzoo ! biological parameters for zooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdet ! biological parameters for detritus +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdom ! biological parameters for DOM +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobsed ! parameters from aphotic layers to sediment +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobrat ! general coefficients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobopt ! optical parameters +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_ref b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_ref new file mode 120000 index 0000000000000000000000000000000000000000..1af37ed08081e87b1a2af44648602b809bb0c651 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_pisces_ref @@ -0,0 +1 @@ +../../SHARED/namelist_pisces_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ref b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..730143a114bce42d8dc3e86726f733b6c690078a --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg new file mode 100644 index 0000000000000000000000000000000000000000..7474acd43ee1ae6fe89c3475db330a80c8b538ee --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg @@ -0,0 +1,114 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/TOP1 : Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_top_ref +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namtrc_run ! run information +!----------------------------------------------------------------------- + ln_top_euler = .true. +/ +!----------------------------------------------------------------------- +&namtrc ! tracers definition +!----------------------------------------------------------------------- + jp_bgc = 24 +! + ln_pisces = .true. + ln_my_trc = .false. + ln_age = .false. + ln_cfc11 = .false. + ln_cfc12 = .false. + ln_c14 = .false. +! + ln_trcdta = .true. ! Initialisation from data input file (T) or not (F) +! ! ! ! ! +! ! name ! title of the field ! units ! initial data from file or not ! +! ! ! ! ! + sn_tracer(1) = 'DIC ' , 'Dissolved inorganic Concentration ', 'mol-C/L' , .true. + sn_tracer(2) = 'Alkalini' , 'Total Alkalinity Concentration ', 'eq/L ' , .true. + sn_tracer(3) = 'O2 ' , 'Dissolved Oxygen Concentration ', 'mol-C/L' , .true. + sn_tracer(4) = 'CaCO3 ' , 'Calcite Concentration ', 'mol-C/L' , .false. + sn_tracer(5) = 'PO4 ' , 'Phosphate Concentration ', 'mol-C/L' , .true. + sn_tracer(6) = 'POC ' , 'Small organic carbon Concentration ', 'mol-C/L' , .false. + sn_tracer(7) = 'Si ' , 'Silicate Concentration ', 'mol-C/L' , .true. + sn_tracer(8) = 'PHY ' , 'Nanophytoplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(9) = 'ZOO ' , 'Microzooplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(10) = 'DOC ' , 'Dissolved organic Concentration ', 'mol-C/L' , .true. + sn_tracer(11) = 'PHY2 ' , 'Diatoms Concentration ', 'mol-C/L' , .false. + sn_tracer(12) = 'ZOO2 ' , 'Mesozooplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(13) = 'DSi ' , 'Diatoms Silicate Concentration ', 'mol-C/L' , .false. + sn_tracer(14) = 'Fer ' , 'Dissolved Iron Concentration ', 'mol-C/L' , .true. + sn_tracer(15) = 'BFe ' , 'Big iron particles Concentration ', 'mol-C/L' , .false. + sn_tracer(16) = 'GOC ' , 'Big organic carbon Concentration ', 'mol-C/L' , .false. + sn_tracer(17) = 'SFe ' , 'Small iron particles Concentration ', 'mol-C/L' , .false. + sn_tracer(18) = 'DFe ' , 'Diatoms iron Concentration ', 'mol-C/L' , .false. + sn_tracer(19) = 'GSi ' , 'Sinking biogenic Silicate Concentration', 'mol-C/L' , .false. + sn_tracer(20) = 'NFe ' , 'Nano iron Concentration ', 'mol-C/L' , .false. + sn_tracer(21) = 'NCHL ' , 'Nano chlorophyl Concentration ', 'mol-C/L' , .false. + sn_tracer(22) = 'DCHL ' , 'Diatoms chlorophyl Concentration ', 'mol-C/L' , .false. + sn_tracer(23) = 'NO3 ' , 'Nitrates Concentration ', 'mol-C/L' , .true. + sn_tracer(24) = 'NH4 ' , 'Ammonium Concentration ', 'mol-C/L' , .false. +/ +!----------------------------------------------------------------------- +&namage ! AGE +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dta ! Initialisation from data input file +!----------------------------------------------------------------------- +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_trcdta(1) = 'data_DIC_nomask' , -12. , 'DIC' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(2) = 'data_Alkalini_nomask' , -12. , 'Alkalini', .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(3) = 'data_O2_nomask' , -1. , 'O2' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(5) = 'data_PO4_nomask' , -1. , 'PO4' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(7) = 'data_Si_nomask' , -1. , 'Si' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(10) = 'data_DOC_nomask' , -12. , 'DOC' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(14) = 'data_Fer_nomask' , -12. , 'Fer' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(23) = 'data_NO3_nomask' , -1. , 'NO3' , .true. , .true. , 'yearly' , '' , '' , '' + 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.0 ! - - - - + rn_trfac(14) = 1.0 ! - - - - + rn_trfac(23) = 7.6e-06 ! - - - - +/ +!----------------------------------------------------------------------- +&namtrc_adv ! advection scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcadv_mus = .true. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths +/ +!----------------------------------------------------------------------- +&namtrc_ldf ! lateral diffusion scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcldf_tra = .true. ! use active tracer setting +/ +!----------------------------------------------------------------------- +&namtrc_rad ! treatment of negative concentrations +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_snk ! sedimentation of particles +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dmp ! passive tracer newtonian damping +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_ice ! Representation of sea ice growth & melt effects +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc') +!---------------------------------------------------------------------- +/ +!---------------------------------------------------------------------- +&namtrc_bc ! data for boundary conditions +!----------------------------------------------------------------------- +/ +!---------------------------------------------------------------------- +&namtrc_bdy ! Setup of tracer boundary conditions +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_ref b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_ref new file mode 120000 index 0000000000000000000000000000000000000000..fcdb44393e1873b82b0a1a7a930d85537d901e80 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_ref @@ -0,0 +1 @@ +../../SHARED/namelist_top_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/README b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/README new file mode 100644 index 0000000000000000000000000000000000000000..242aadc3736d2ece50b9b6cf539b659edfd956dc --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/README @@ -0,0 +1,61 @@ +#---------------------------------------------------------------------- +# prerequired +#---------------------------------------------------------------------- +First, you need either : +- IDL (version 6.4 or above), see : http://www.exelisvis.com/ProductsServices/IDL.aspx + In this case, you also need to download SAXO which is a free package of IDL scripts: + define $PATH_SAXO, the path where you will download SAXO and get it through svn with the following command. + > PATH_SAXO=... + > svn checkout http://forge.ipsl.jussieu.fr/saxo/svn/trunk/SRC $PATH_SAXO/SAXO_DIR/SRC + +- or the IDL Virtual Machine which is free to use and does not require a license to run , see : + http://www.exelisvis.com/Support/HelpArticlesDetail/TabId/219/ArtMID/900/ArticleID/12395/The-IDL-Virtual-Machine.aspx + the virtual machine requites std_main.sav that is distributed with this README. + +Next, to use these idl tools, you need to download some climatogies and mask files; +that you can find here: http://dodsp.idris.fr/reee512/NEMO_OUT/ORCA2_LIM/ + +There is the wget command to get all those files (thanks to F. Pinsard) +wget --recursive -l2 --no-directories --no-parent -A.nc -erobots=off http://dodsp.idris.fr/reee512/NEMO_OUT/ORCA2_LIM/ + +You will aslo need the meshmask file (set ln_meshmask = TRUE in your namelist and run the model for at least 1 time step). + +#---------------------------------------------------------------------- +# define your std_plot_vardef.sh or std_ts_vardef.sh file +#---------------------------------------------------------------------- +These files are needed to define your PATHs, the experiments and variables names you used in your experiment. + - std_plot_vardef.sh is used to do all plots based on temporal mean (maps, vertical profiles...). + - std_ts_vardef.sh is used to do all time-series type of plot. + +To build you own std_plot_vardef.sh or std_ts_vardef.sh file; use the examples provided such as: + - std_ts_vardef.sh_example1 or std_ts_vardef.sh_example2 + - std_plot_vardef.sh_example1 or std_plot_vardef.sh_example2 + +Note that if you use the IDL Virtual Machine, the variable SAXO_DIR defined in std_plot_vardef.sh or std_ts_vardef.sh is not used. Any definition will be ok. + +#---------------------------------------------------------------------- +# HOW TO USE +#---------------------------------------------------------------------- +./std_main.sh -plot -pdf +or +./std_main.sh -ts -pdf + + + + +########################################################################################################## +# short note for developers of this package on: +# How to build the tarball required for IDL virtual Machine: +########################################################################################################## +# +# we need to recreate std_main.sav as soon as we change IDL programmes files as +# std_main.sav contains all ".pro" files aready compiled to be used with the virtual machine +# +. ./std_plot_vardef.sh # or . ./std_ts_vardef.sh +idl -IDL_STARTUP initenv +IDL> .r std_main +IDL> resolve_all +IDL> save, /routines, filename='std_main.sav' +IDL> exit +# +#---------------------------------------------------------------------- diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/initenv.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/initenv.pro new file mode 100644 index 0000000000000000000000000000000000000000..b028e662c9c950dfa14e22372a09e91dc095c785 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/initenv.pro @@ -0,0 +1,56 @@ +; +; This is the initialisation file. +; it defines the !path and the defaut values of some of the common variables +; +; this is supposed to speed-up IDL... +; +; a = fltarr(1000,1000,100) +; a = 0 +; +; path definition +; +!path = expand_path('+' + getenv('SAXO_DIR') ) + ':' + expand_path('+' + !dir) +; +; compatibility with the old version +; +keep_compatibility, 0 +; +; define all the commons +; +@all_cm +; +; define default directories +; +homedir = './' +iodir = './' +psdir = isadirectory(getenv('PS_DIR'), title = 'Select the default postscripts directory') +imagedir = './' +animdir = './' +; +; define printer parameters +; +printer_human_names = '' +printer_machine_names = '' +print_command = '' +; +; colors ... +; +device, decomposed = 0 +device, retain = 2 +lct, 65 +; +; postscript parameters ... +; +key_portrait = 0 +page_size = [20.9903, 29.7039] +windowsize_scale = 1.0000 +archive_ps = 0 +; +;======================================================== +; end of the part that should be modified by the users... +;======================================================== +; +; if needed, keep compatibility with the old version +; +@updateold +; diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_common.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_common.pro new file mode 100644 index 0000000000000000000000000000000000000000..d9e3c3eb661a46837e0f83cffde473957a7c524c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_common.pro @@ -0,0 +1,9 @@ +COMMON std, cnt $ + , std_iodir_climato, std_iodir_data $ + , std_file1_T, std_file2_T $ + , std_file1_U, std_file2_U $ + , std_file1_V, std_file2_V $ + , std_file1_I, std_file2_I $ + , std_file_msksub $ + , date1, date2, date1_2, date2_2 $ + , allrec, blabla, htmltxt diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.pro new file mode 100644 index 0000000000000000000000000000000000000000..18b67787750e264e88454806b403843602583e2e --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.pro @@ -0,0 +1,12 @@ +PRO std_main +@initenv +; + type = getenv('PLOTTYPE') + CASE type OF + '':print, 'The environment variable PLOTTYPE is not defined. We stop' + 'ts':std_ts_all, /postscript + 'plot':std_plot_all, /postscript + ELSE:print, 'Wrong definition of the environment variable PLOTTYPE. We stop' + ENDCASE +; +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sav b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sav new file mode 100644 index 0000000000000000000000000000000000000000..0ac35f7b1c99850fb8c1c34cfc49885b084172cb Binary files /dev/null and b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sav differ diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sh b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sh new file mode 100755 index 0000000000000000000000000000000000000000..406445e1b56b39f6077a762d33cf8e3ddc4579fe --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main.sh @@ -0,0 +1,239 @@ +#!/bin/sh +#+ +# +# .. program:: std_main.sh +# +# ================ +# std_main.sh +# ================ +# +# ------------------------------------- +# launch idl scripts to produce graphics diagnostics in Postscript, PDF or HTML document +# ------------------------------------- +# +# SYNOPSIS +# ======== +# +# ``std_main.sh -ts`` or ``std_main.sh -plot`` +# +# DESCRIPTION +# =========== +# +# .. option:: -ts to produce time series +# .. option:: -plot to produce maps and sections +# .. option:: -html to produce html document +# .. option:: -pdf to produce pdf document +# .. option:: -noidl to skip the call to IDL and the production of Postscript +# .. option:: -vm to use IDL virtual machine (free) instead of IDL +# .. option:: -help to get help! +# +# variables have to be defined in std_plot_vardef.sh (or std_ts_vardef.sh) +# before calling std_main.sh -plot (or std_main.sh -ts) +# +# EXAMPLES +# ======== +# $ ./std_main.sh -ts html +# $ ./std_main.sh -ts pdf -noidl +# +# $ ./std_main.sh -plot -pdf -vm +# +# AUTHOR - date +# =========== +# Franoise Pinsard - 01/2010 - LOCEAN +# Simona Flavoni - 01/2010 - LOCEAN +# Sebastien Masson - 04/2011 - LOCEAN +# +#----------------------------------------------------------- +# Usage... +#----------------------------------------------------------- +# +#- +system=$(uname) +case "${system}" in + AIX|IRIX64) + echo " www : no specific posix checking" + ;; + *) + set -o posix + ;; +esac +# +usage="Usage: std_main.sh [OPTION] +Options + -ts to produce time series + -plot to produce maps and sections + -html to produce html document + -pdf to produce pdf document + -noidl to skip the call to IDL and the production of Postscript + -vm to use IDL virtual machine (free) instead of IDL + -help to get this help +" +# +vm=0 +noidl=0 +format=ps +while [ ! -z "${1}" ] +do + case ${1} in + -plot|--plot) PLOTTYPE=plot ;; + -ts|--ts) PLOTTYPE=ts ;; + -f|-format|--format) format=${2} shift ;; + -html|--html) format=html ;; + -pdf|--pdf) format=pdf ;; + -h|-help|--help) + echo "${usage}" + exit 0 + ;; + -ni|--ni|-noidl|--noidl) noidl=1 ;; + -vm|--vm|-virtual_machine|--virtual_machine) vm=1 ;; + *) # other choice + echo "${usage}" + exit 1 + ;; + esac + shift # next flag +done +# +PLOTTYPE=${PLOTTYPE:-NG} +if [[ ( "$PLOTTYPE" != "plot" ) && ( "$PLOTTYPE" != "ts" ) ]] +then + echo 'the type of plot must be defined with the option -plot or -ts' + exit 1 +fi +export PLOTTYPE +# +set -u +# +# +tstexe () { + type ${1} + status_type=${?} + if [ ${status_type} -ne 0 ] + then + echo "eee : ${2}" + exit 1 + fi +} +# +#----------------------------------------------------------- +# define output directory for POSTCRIPT files +#----------------------------------------------------------- +# +. ./std_${PLOTTYPE}_vardef.sh +[ ! -d ${PS_DIR} ] && mkdir -p ${PS_DIR} +# +#----------------------------------------------------------- +# run IDL +#----------------------------------------------------------- +# +if [ $noidl -eq 0 ] +then + tstexe ${idl_command} "idl not found" +# + if [ $vm -eq 1 ] + then + ${idl_command} -vm=std_main.sav + else + ${idl_command} -IDL_STARTUP 'initenv' << EOF +std_${PLOTTYPE}_all, /postscript +EOF + fi + status_idl=${?} + if [ ${status_idl} -ne 0 ] + then + echo "eee : error in the execution of IDL" + exit 1 + fi +fi +# +#----------------------------------------------------------- +# produce the final document +#----------------------------------------------------------- +# +# build the list of ps that has been created by IDL +pslist=$( grep "img width" ${PS_DIR}/std_${PLOTTYPE}_html_body.txt | sed -e "s/.*src=\(.*\)png.*/\1/" ) +# +case ${format} in +#__________________________________________________________ +# PDF + pdf) +# check if ps2pdf available + ps2pdf_command=$( which ps2pdf ) + tstexe ${ps2pdf_command} "ps2pdf not found" +# check if texexec available + texexec_command=$( which texexec ) + tstexe ${texexec_command} "texexec not found" +# + filepdf=all_${PLOTTYPE}.pdf + [ ! -d ${PDF_DIR} ] && mkdir -p ${PDF_DIR} + pdflist='' + for file in ${pslist} ; do + ps2pdf -sPAPERSIZE=a4 ${PS_DIR}/${file}ps ${PDF_DIR}/${file}pdf + echo "ps2pdf ${file}ps done" + pdflist=${pdflist}' '${PDF_DIR}/${file}pdf + done +#pdfjam needed to use pdfjoin + pdfjoin ${pdflist} --outfile $PDF_DIR/${filepdf} + texexec --pdfarrange --result=$PDF_DIR/$filepdf $pdflist + rm -f $PDF_DIR/$( basename $filepdf .pdf ).aux $PDF_DIR/$( basename $filepdf .pdf ).log + if [ ! -e ${PDF_DIR}/$filepdf ] + then + echo "\n ATTENTION !!!!! \n" + echo "${PDF_DIR}/$filepdf do not exist \n" + else + echo "${PDF_DIR}/$filepdf done" + fi +#commented because convert gives images of bad quality +# convert ${PS_DIR}/*.ps /tmp/all_${PLOTTYPE}.pdf +# convert -resize 800x600 ${PS_DIR}/${exp1}_${exp2}/ps/*.ps /tmp/all_${PLOTTYPE}.pdf + ;; +#__________________________________________________________ +# HTML + html) + filehtml=all_${PLOTTYPE}.html + [ ! -d ${HTML_DIR} ] && mkdir -p ${HTML_DIR} +# check if convert available + convert_command=$( which convert ) + tstexe ${convert_command} "convert not found" +# convert each ps to png + for file in ${pslist} ; do + ${convert_command} -antialias ${PS_DIR}/${file}ps ${HTML_DIR}/${file}png + done +# creation of the HTML file + cat << EOF > ${HTML_DIR}/$filehtml + + + + + + +EOF + cat ${PS_DIR}/std_${PLOTTYPE}_html_body.txt >> ${HTML_DIR}/$filehtml + cat << EOF >> ${HTML_DIR}/$filehtml +
+ + +EOF + echo ${HTML_DIR}/$filehtml done + ;; + ps) ;; # nothing to do... + *) + echo " format ${format} not implemented" + exit 1 + ;; +esac + + # +#===================== +# prepare to put images on dods +# +++ to finish it +#LOGIN=xxxx +#Tag_Name=ORCA2_LIM2 +#rsh ${LOGIN}@gaya.idris.fr exec /bin/ksh < /dev/null 2>&1 +# /usr/local/bin/dods_cp ${exp1} DODS/pub/${LOGIN}/${Tag_Name}/CORE2/INTERAN/${PLOTTYPE}_pdf/${exp1} > /dev/null 2>&1 +#EOF +#===================== +# end +exit 0 diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_1Y.sh b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_1Y.sh new file mode 100755 index 0000000000000000000000000000000000000000..406445e1b56b39f6077a762d33cf8e3ddc4579fe --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_1Y.sh @@ -0,0 +1,239 @@ +#!/bin/sh +#+ +# +# .. program:: std_main.sh +# +# ================ +# std_main.sh +# ================ +# +# ------------------------------------- +# launch idl scripts to produce graphics diagnostics in Postscript, PDF or HTML document +# ------------------------------------- +# +# SYNOPSIS +# ======== +# +# ``std_main.sh -ts`` or ``std_main.sh -plot`` +# +# DESCRIPTION +# =========== +# +# .. option:: -ts to produce time series +# .. option:: -plot to produce maps and sections +# .. option:: -html to produce html document +# .. option:: -pdf to produce pdf document +# .. option:: -noidl to skip the call to IDL and the production of Postscript +# .. option:: -vm to use IDL virtual machine (free) instead of IDL +# .. option:: -help to get help! +# +# variables have to be defined in std_plot_vardef.sh (or std_ts_vardef.sh) +# before calling std_main.sh -plot (or std_main.sh -ts) +# +# EXAMPLES +# ======== +# $ ./std_main.sh -ts html +# $ ./std_main.sh -ts pdf -noidl +# +# $ ./std_main.sh -plot -pdf -vm +# +# AUTHOR - date +# =========== +# Franoise Pinsard - 01/2010 - LOCEAN +# Simona Flavoni - 01/2010 - LOCEAN +# Sebastien Masson - 04/2011 - LOCEAN +# +#----------------------------------------------------------- +# Usage... +#----------------------------------------------------------- +# +#- +system=$(uname) +case "${system}" in + AIX|IRIX64) + echo " www : no specific posix checking" + ;; + *) + set -o posix + ;; +esac +# +usage="Usage: std_main.sh [OPTION] +Options + -ts to produce time series + -plot to produce maps and sections + -html to produce html document + -pdf to produce pdf document + -noidl to skip the call to IDL and the production of Postscript + -vm to use IDL virtual machine (free) instead of IDL + -help to get this help +" +# +vm=0 +noidl=0 +format=ps +while [ ! -z "${1}" ] +do + case ${1} in + -plot|--plot) PLOTTYPE=plot ;; + -ts|--ts) PLOTTYPE=ts ;; + -f|-format|--format) format=${2} shift ;; + -html|--html) format=html ;; + -pdf|--pdf) format=pdf ;; + -h|-help|--help) + echo "${usage}" + exit 0 + ;; + -ni|--ni|-noidl|--noidl) noidl=1 ;; + -vm|--vm|-virtual_machine|--virtual_machine) vm=1 ;; + *) # other choice + echo "${usage}" + exit 1 + ;; + esac + shift # next flag +done +# +PLOTTYPE=${PLOTTYPE:-NG} +if [[ ( "$PLOTTYPE" != "plot" ) && ( "$PLOTTYPE" != "ts" ) ]] +then + echo 'the type of plot must be defined with the option -plot or -ts' + exit 1 +fi +export PLOTTYPE +# +set -u +# +# +tstexe () { + type ${1} + status_type=${?} + if [ ${status_type} -ne 0 ] + then + echo "eee : ${2}" + exit 1 + fi +} +# +#----------------------------------------------------------- +# define output directory for POSTCRIPT files +#----------------------------------------------------------- +# +. ./std_${PLOTTYPE}_vardef.sh +[ ! -d ${PS_DIR} ] && mkdir -p ${PS_DIR} +# +#----------------------------------------------------------- +# run IDL +#----------------------------------------------------------- +# +if [ $noidl -eq 0 ] +then + tstexe ${idl_command} "idl not found" +# + if [ $vm -eq 1 ] + then + ${idl_command} -vm=std_main.sav + else + ${idl_command} -IDL_STARTUP 'initenv' << EOF +std_${PLOTTYPE}_all, /postscript +EOF + fi + status_idl=${?} + if [ ${status_idl} -ne 0 ] + then + echo "eee : error in the execution of IDL" + exit 1 + fi +fi +# +#----------------------------------------------------------- +# produce the final document +#----------------------------------------------------------- +# +# build the list of ps that has been created by IDL +pslist=$( grep "img width" ${PS_DIR}/std_${PLOTTYPE}_html_body.txt | sed -e "s/.*src=\(.*\)png.*/\1/" ) +# +case ${format} in +#__________________________________________________________ +# PDF + pdf) +# check if ps2pdf available + ps2pdf_command=$( which ps2pdf ) + tstexe ${ps2pdf_command} "ps2pdf not found" +# check if texexec available + texexec_command=$( which texexec ) + tstexe ${texexec_command} "texexec not found" +# + filepdf=all_${PLOTTYPE}.pdf + [ ! -d ${PDF_DIR} ] && mkdir -p ${PDF_DIR} + pdflist='' + for file in ${pslist} ; do + ps2pdf -sPAPERSIZE=a4 ${PS_DIR}/${file}ps ${PDF_DIR}/${file}pdf + echo "ps2pdf ${file}ps done" + pdflist=${pdflist}' '${PDF_DIR}/${file}pdf + done +#pdfjam needed to use pdfjoin + pdfjoin ${pdflist} --outfile $PDF_DIR/${filepdf} + texexec --pdfarrange --result=$PDF_DIR/$filepdf $pdflist + rm -f $PDF_DIR/$( basename $filepdf .pdf ).aux $PDF_DIR/$( basename $filepdf .pdf ).log + if [ ! -e ${PDF_DIR}/$filepdf ] + then + echo "\n ATTENTION !!!!! \n" + echo "${PDF_DIR}/$filepdf do not exist \n" + else + echo "${PDF_DIR}/$filepdf done" + fi +#commented because convert gives images of bad quality +# convert ${PS_DIR}/*.ps /tmp/all_${PLOTTYPE}.pdf +# convert -resize 800x600 ${PS_DIR}/${exp1}_${exp2}/ps/*.ps /tmp/all_${PLOTTYPE}.pdf + ;; +#__________________________________________________________ +# HTML + html) + filehtml=all_${PLOTTYPE}.html + [ ! -d ${HTML_DIR} ] && mkdir -p ${HTML_DIR} +# check if convert available + convert_command=$( which convert ) + tstexe ${convert_command} "convert not found" +# convert each ps to png + for file in ${pslist} ; do + ${convert_command} -antialias ${PS_DIR}/${file}ps ${HTML_DIR}/${file}png + done +# creation of the HTML file + cat << EOF > ${HTML_DIR}/$filehtml + + + + + + +EOF + cat ${PS_DIR}/std_${PLOTTYPE}_html_body.txt >> ${HTML_DIR}/$filehtml + cat << EOF >> ${HTML_DIR}/$filehtml +
+ + +EOF + echo ${HTML_DIR}/$filehtml done + ;; + ps) ;; # nothing to do... + *) + echo " format ${format} not implemented" + exit 1 + ;; +esac + + # +#===================== +# prepare to put images on dods +# +++ to finish it +#LOGIN=xxxx +#Tag_Name=ORCA2_LIM2 +#rsh ${LOGIN}@gaya.idris.fr exec /bin/ksh < /dev/null 2>&1 +# /usr/local/bin/dods_cp ${exp1} DODS/pub/${LOGIN}/${Tag_Name}/CORE2/INTERAN/${PLOTTYPE}_pdf/${exp1} > /dev/null 2>&1 +#EOF +#===================== +# end +exit 0 diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_5D.sh b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_5D.sh new file mode 100755 index 0000000000000000000000000000000000000000..3feda7fd8fc78a553144ff5bf8c753ef957cabb6 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_5D.sh @@ -0,0 +1,238 @@ +#!/bin/sh +#+ +# +# .. program:: std_main_5D.sh +# +# ================ +# std_main.sh +# ================ +# +# ------------------------------------- +# launch idl scripts to produce graphics diagnostics in Postscript, PDF or HTML document +# for output of 5days for 1 year run +# nota: it is like std_main.sh but it calls routins for 5days +# ------------------------------------- +# +# SYNOPSIS +# ======== +# +# ``std_main_5D.sh -ts`` or ``std_main_5D.sh -plot`` +# +# DESCRIPTION +# =========== +# +# .. option:: -ts to produce time series +# .. option:: -plot to produce maps and sections +# .. option:: -html to produce html document +# .. option:: -pdf to produce pdf document +# .. option:: -noidl to skip the call to IDL and the production of Postscript +# .. option:: -vm to use IDL virtual machine (free) instead of IDL +# .. option:: -help to get help! +# +# variables have to be defined in std_plot_vardef.sh (or std_ts_vardef.sh) +# before calling std_main_5D.sh -plot +# +# EXAMPLES +# ======== +# $ ./std_main_5D.sh -plot -pdf +# +# AUTHOR - date +# =========== +# Franoise Pinsard - 01/2010 - LOCEAN +# Simona Flavoni - 01/2010 - LOCEAN +# Sebastien Masson - 04/2011 - LOCEAN +# +#----------------------------------------------------------- +# Usage... +#----------------------------------------------------------- +# +#- +system=$(uname) +case "${system}" in + AIX|IRIX64) + echo " www : no specific posix checking" + ;; + *) + set -o posix + ;; +esac +# +usage="Usage: std_main_5D.sh [OPTION] +Options + -ts to produce time series + -plot to produce maps and sections + -html to produce html document + -pdf to produce pdf document + -noidl to skip the call to IDL and the production of Postscript + -vm to use IDL virtual machine (free) instead of IDL + -help to get this help +" +# +vm=0 +noidl=0 +format=ps +while [ ! -z "${1}" ] +do + case ${1} in + -plot|--plot) PLOTTYPE=plot ;; + -ts|--ts) PLOTTYPE=ts ;; + -f|-format|--format) format=${2} shift ;; + -html|--html) format=html ;; + -pdf|--pdf) format=pdf ;; + -h|-help|--help) + echo "${usage}" + exit 0 + ;; + -ni|--ni|-noidl|--noidl) noidl=1 ;; + -vm|--vm|-virtual_machine|--virtual_machine) vm=1 ;; + *) # other choice + echo "${usage}" + exit 1 + ;; + esac + shift # next flag +done +# +PLOTTYPE=${PLOTTYPE:-NG} +if [[ ( "$PLOTTYPE" != "plot" ) && ( "$PLOTTYPE" != "ts" ) ]] +then + echo 'the type of plot must be defined with the option -plot or -ts' + exit 1 +fi +export PLOTTYPE +# +set -u +# +# +tstexe () { + type ${1} + status_type=${?} + if [ ${status_type} -ne 0 ] + then + echo "eee : ${2}" + exit 1 + fi +} +# +#----------------------------------------------------------- +# define output directory for POSTCRIPT files +#----------------------------------------------------------- +# +. ./std_${PLOTTYPE}_vardef.sh +[ ! -d ${PS_DIR} ] && mkdir -p ${PS_DIR} +# +#----------------------------------------------------------- +# run IDL +#----------------------------------------------------------- +# +if [ $noidl -eq 0 ] +then + tstexe ${idl_command} "idl not found" +# + if [ $vm -eq 1 ] + then + ${idl_command} -vm=std_main.sav + else + ${idl_command} -IDL_STARTUP 'initenv' << EOF +std_${PLOTTYPE}_all_last_year_5D, /postscript +EOF + fi + status_idl=${?} + if [ ${status_idl} -ne 0 ] + then + echo "eee : error in the execution of IDL" + exit 1 + fi +fi +# +#----------------------------------------------------------- +# produce the final document +#----------------------------------------------------------- +# +# build the list of ps that has been created by IDL +pslist=$( grep "img width" ${PS_DIR}/std_${PLOTTYPE}_html_body.txt | sed -e "s/.*src=\(.*\)png.*/\1/" ) +# +case ${format} in +#__________________________________________________________ +# PDF + pdf) +# check if ps2pdf available + ps2pdf_command=$( which ps2pdf ) + tstexe ${ps2pdf_command} "ps2pdf not found" +# check if texexec available + texexec_command=$( which texexec ) + tstexe ${texexec_command} "texexec not found" +# + filepdf=all_${PLOTTYPE}.pdf + [ ! -d ${PDF_DIR} ] && mkdir -p ${PDF_DIR} + pdflist='' + for file in ${pslist} ; do + ps2pdf -sPAPERSIZE=a4 ${PS_DIR}/${file}ps ${PDF_DIR}/${file}pdf + echo "ps2pdf ${file}ps done" + pdflist=${pdflist}' '${PDF_DIR}/${file}pdf + done +#pdfjam needed to use pdfjoin + pdfjoin ${pdflist} --outfile $PDF_DIR/${filepdf} + texexec --pdfarrange --result=$PDF_DIR/$filepdf $pdflist + rm -f $PDF_DIR/$( basename $filepdf .pdf ).aux $PDF_DIR/$( basename $filepdf .pdf ).log + if [ ! -e ${PDF_DIR}/$filepdf ] + then + echo "\n ATTENTION !!!!! \n" + echo "${PDF_DIR}/$filepdf do not exist \n" + else + echo "${PDF_DIR}/$filepdf done" + fi +#commented because convert gives images of bad quality +# convert ${PS_DIR}/*.ps /tmp/all_${PLOTTYPE}.pdf +# convert -resize 800x600 ${PS_DIR}/${exp1}_${exp2}/ps/*.ps /tmp/all_${PLOTTYPE}.pdf + ;; +#__________________________________________________________ +# HTML + html) + filehtml=all_${PLOTTYPE}.html + [ ! -d ${HTML_DIR} ] && mkdir -p ${HTML_DIR} +# check if convert available + convert_command=$( which convert ) + tstexe ${convert_command} "convert not found" +# convert each ps to png + for file in ${pslist} ; do + ${convert_command} -antialias ${PS_DIR}/${file}ps ${HTML_DIR}/${file}png + done +# creation of the HTML file + cat << EOF > ${HTML_DIR}/$filehtml + + + + + + +EOF + cat ${PS_DIR}/std_${PLOTTYPE}_html_body.txt >> ${HTML_DIR}/$filehtml + cat << EOF >> ${HTML_DIR}/$filehtml +
+ + +EOF + echo ${HTML_DIR}/$filehtml done + ;; + ps) ;; # nothing to do... + *) + echo " format ${format} not implemented" + exit 1 + ;; +esac + + # +#===================== +# prepare to put images on dods +# +++ to finish it +#LOGIN=xxxx +#Tag_Name=ORCA2_LIM2 +#rsh ${LOGIN}@gaya.idris.fr exec /bin/ksh < /dev/null 2>&1 +# /usr/local/bin/dods_cp ${exp1} DODS/pub/${LOGIN}/${Tag_Name}/CORE2/INTERAN/${PLOTTYPE}_pdf/${exp1} > /dev/null 2>&1 +#EOF +#===================== +# end +exit 0 diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_last_year_5D.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_last_year_5D.pro new file mode 100644 index 0000000000000000000000000000000000000000..84b9e6427684126aa79005dd405aa18fd4db8045 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_main_last_year_5D.pro @@ -0,0 +1,12 @@ +PRO std_main_last_year_5D +@initenv +; + type = getenv('PLOTTYPE') + CASE type OF + '':print, 'The environment variable PLOTTYPE is not defined. We stop' + 'ts':std_ts_all, /postscript + 'plot':std_plot_all_last_year_5D, /postscript + ELSE:print, 'Wrong definition of the environment variable PLOTTYPE. We stop' + ENDCASE +; +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ArcSal.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ArcSal.pro new file mode 100644 index 0000000000000000000000000000000000000000..84fc676b170eb2acce62df324abe8abcf62c20cb --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ArcSal.pro @@ -0,0 +1,62 @@ +pro std_plot_ArcSal, S1, S2in, SLevin, Z100 = z100, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + CASE n_params() OF + 2:BEGIN + Slev = S2in + END + 3:BEGIN + IF S2in.arr[0] EQ -1 THEN return + S2 = S2in + Slev = Slevin + END + ENDCASE +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla +; + IF keyword_set(z100) THEN tmp = min(abs(100 - gdept), ind) ELSE ind = 0 + sdepref = strtrim(round(gdept[ind]), 1)+'m' + filename = cdti3 + '_Arctic_Sal'+sdepref+'_'+std_file1_T + IF keyword_set(S2) THEN filename = filename + '_' + std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + domdef, 20, 380, 50, 90 +; + varunit = S1.unit + titleorg = 'Salinity ('+sdepref+')!C' +; + IF keyword_set(S2) THEN BEGIN + title = titleorg+std_file1_T+ ' - '+std_file2_T + plt, S1.arr - S2.arr, MIN = -4., MAX = 4., INTER = 0.2, CELL_FILL = 2, STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, CHARSIZE = -0.55, GLINETHICK = 2. $ + , /ORTHO, MAP = [90, 0, 0], LATDEL = 5, boxzoom = [ind, ind], /zindex, /portrait, _extra = ex + ENDIF ELSE BEGIN + title = titleorg+std_file1_T + plt, S1, MIN = 30.0, MAX = 36., INTER = 0.2, CELL_FILL = 2, format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, CHARSIZE = -0.55, GLINETHICK = 2. $ + , /ORTHO, MAP = [90, 0, 0], LATDEL = 5, boxzoom = [ind, ind], /zindex, /PORTRAIT, _extra = ex + ENDELSE +; + IF keyword_set(S2) THEN BEGIN + title = titleorg+std_file2_T+ ' - Levitus' + tmp = S2.arr - SLev.arr + ENDIF ELSE BEGIN + title = titleorg+std_file1_T+ ' - Levitus' + tmp = S1.arr - SLev.arr + ENDELSE + plt, temporary(tmp), MIN = -4., MAX = 4., INTER = 0.2, CELL_FILL = 2, STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, CHARSIZE = -0.55, GLINETHICK = 2. $ + , /ORTHO, MAP = [90, 0, 0], LATDEL = 5, boxzoom = [ind, ind], /zindex, /NOERASE, _extra = ex +; + domdef +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqS.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqS.pro new file mode 100644 index 0000000000000000000000000000000000000000..88189228e25c30808896c9c5ef74360e2882c88d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqS.pro @@ -0,0 +1,34 @@ +pro std_plot_EqS, S1, S2, SLev, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_EqS_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Equatorial Salinity!C'+std_file1_T + pltz, S1, MININ = 33., MAXIN = 37., INTER = .2, typein = 'xz', FORMAT = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], /PORTRAIT, _extra = ex + + if std_file1_T EQ std_file2_T then begin + S = S1.arr - Slev.arr + title = title+' - Levitus' + ENDIF ELSE BEGIN + S = S1.arr - S2.arr + title = title+' - '+std_file2_T + ENDELSE + + pltz, S, MININ = -1., MAXIN = 1., INTER = 0.1, typein = 'xz', STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], /noerase, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqT.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqT.pro new file mode 100644 index 0000000000000000000000000000000000000000..edc651bff854d54991fac3311679a86c77bdf4d8 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqT.pro @@ -0,0 +1,42 @@ +pro std_plot_EqT, T1, T2, TLev, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_EqT_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Equatorial Temperature!C'+std_file1_T + pltz, T1, MININ = 2., MAXIN = 30., INTER = 1., typein = 'xz', FORMAT = '(I2)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], /PORTRAIT, _extra = ex + + if std_file1_T EQ std_file2_T then begin + T = T1.arr - TLev.arr + title = title+' - Levitus' + min = -4. + max = -min + inter = .5 + fmt = '(I2)' + ENDIF ELSE BEGIN + T = T1.arr - T2.arr + title = title+' - '+std_file2_T + min = -2. + max = -min + inter = .25 + fmt = '(f4.1)' + ENDELSE + + pltz, T, MININ = min, MAXIN = max, INTER = inter, typein = 'xz', STYLE = 'so0so', FORMAT = fmt $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], /NOERASE, _extra = ex + ; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqU.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqU.pro new file mode 100644 index 0000000000000000000000000000000000000000..2a166e24c4ae1eff00b2af2e3e659a14b327c0f9 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_EqU.pro @@ -0,0 +1,28 @@ +pro std_plot_EqU, U1, U2, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_EqU_'+std_file1_U + if std_file1_U NE std_file2_U then filename = filename + '_'+std_file2_U + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Equatorial Zonal Current!C'+std_file1_U + pltz, U1, MININ = -1., MAXIN = 1., INTER = .1, typein = 'xz', STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], ZOOM = 500, /PORTRAIT, _extra = ex + + if std_file1_U NE std_file2_U then begin + title = title+' - '+std_file2_U + pltz, U1.arr-U2.arr, MININ = -.5, MAXIN = .5, INTER = .1, typein = 'xz', STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [20., 380., -1., 1., 0., 500.], ZOOM = 500, /PORTRAIT, _extra = ex + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_GlobMeanTS.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_GlobMeanTS.pro new file mode 100644 index 0000000000000000000000000000000000000000..1f123cbcbaab0f07a62adf16aab8c9597c9a39ea --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_GlobMeanTS.pro @@ -0,0 +1,39 @@ +pro std_plot_GlobMeanTS, T1, T2, TLev, S1, S2, SLev, sEXP1, sEXP2, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_GlobMeanTS_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + varunit = T1.unit + title = 'Temperature Global mean!C'+std_file1_T+' - Levitus (Black)' + if std_file1_T NE std_file2_T THEN title = title+'!C'+std_file2_T+' - Levitus (Red)' + plt1d, T1.arr - TLev.arr, typein = 'z', ticklen = 1, MIN = -2., MAX = 2., boxzoom = [4., 5300.], /KEEPBOTTOM $ + , small = [1, 2, 1], XGRIDSTYLE = 2, YGRIDSTYLE = 2, TITLE = title, /PORTRAIT, _extra = ex + if std_file1_T NE std_file2_T then begin + plt1d, T2.arr - TLev.arr, typein = 'z', ticklen = 1, MIN = -2., MAX = 2., boxzoom = [4., 5300.], /KEEPBOTTOM $ + , /ov1d, COLOR = 250, TITLE = title, _extra = ex + endif +; + varunit = S1.unit + title = 'Salinity Global mean!C'+std_file1_T+' - Levitus (Black)' + if std_file1_T NE std_file2_T THEN title = title+'!C'+std_file2_T+' - Levitus (Red)' + plt1d, S1.arr - SLev.arr, typein = 'z', ticklen = 1, MIN = -.2, MAX = .4, boxzoom = [4., 5300.], /KEEPBOTTOM $ + , small = [1, 2, 2], XGRIDSTYLE = 2, YGRIDSTYLE = 2, TITLE = title, /NOERASE, _extra = ex + if std_file1_T NE std_file2_T then begin + plt1d, S2.arr - SLev.arr, typein = 'z', ticklen = 1, MIN = -2., MAX = 4., boxzoom = [4., 5300.], /KEEPBOTTOM $ + , /ov1d, COLOR = 250, TITLE = title, _extra = ex + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceAge.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceAge.pro new file mode 100644 index 0000000000000000000000000000000000000000..2cedfa96374e4f220291fdf374d4b56d5d6757cd --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceAge.pro @@ -0,0 +1,75 @@ +pro std_plot_IceAge, Iage1, Iage2, Ifra1, Ifra2, ARC = arc, ANT = ant, FEBR = febr, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'IceAge' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(febr) THEN var = var+'Febr' + IF keyword_set(march) THEN var = var+'March' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + IF std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + IF KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 50, 90 + vmin = 0. + vmax = 7. + vint = 0.5 + fmtd = '(f4.1)' + vmind = -3. + vmaxd = 3. + vintd = 0.5 + fmtd = '(f4.1)' + div = 7 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -50 + vmin = 0. + vmax = 2. + vint = 0.2 + fmt = '(f4.1)' + vmind = -1. + vmaxd = 1. + vintd = 0.2 + fmtd = '(f4.1)' + div = 5 + map = [-90, 0, 0] + ENDIF +; + varunit = Iage1.unit +; + title = var+'!C'+std_file1_I + + Iage1.arr = Iage1.arr * ( Ifra1.arr gt 0.15 ) + + plt, Iage1.arr - 1.E-04, MIN = vmin, MAX = vmax, INTER = vint, /STRICTFILL, CELL_FILL = 2, format = fmt $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, divisions = div $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /PORTRAIT, _extra = ex +; ; + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + + Iage2.arr = Iage2.arr * ( Ifra2.arr gt 0.15 ) + + plt, Iage1.arr - Iage2.arr, MIN = vmind, MAX = vmaxd, INTER = vintd, STYLE = 'so0so', format = fmtd $ + , small = [1, 2, 2], COAST_THICK = 2, CELL_FILL = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceFrac.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceFrac.pro new file mode 100644 index 0000000000000000000000000000000000000000..713c14c523f29e6903d100fcc496f41f3c3c50bc --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceFrac.pro @@ -0,0 +1,60 @@ +pro std_plot_IceFrac, Ifra1, Ifra2, ARC = arc, ANT = ant, FEBR = febr, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'IceFra' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(febr) THEN var = var+'Febr' + IF keyword_set(march) THEN var = var+'March' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + if std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 40, 90 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -40 + map = [-90, 0, 0] + ENDIF +; + varunit = Ifra1.unit +; + title = var+'!C'+std_file1_I + Ifra1.arr = Ifra1.arr * ( Ifra1.arr gt 0.15 ) + plt, Ifra1.arr - 1.E-04, MIN = 0., MAX = 1., INTER = .1, /STRICTFILL, CELL_FILL = 2, format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /PORTRAIT, _extra = ex +; ; + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + Ifra2.arr = Ifra2.arr * ( Ifra2.arr gt 0.15 ) + plt, Ifra1.arr - Ifra2.arr, MIN = -1, MAX = 1, INTER = .1, STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, CELL_FILL = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex +;;SF finire, aggiungere lettura obs +;;SF endif else begin +;;SF title = title+ ' - Observations' +;;SF plt, Ifra1.arr - Ifra_obs.arr, MIN = -1., MAX = 1., INTER = 0.1, STYLE = 'so0so', format = '(f4.1)' $ +;;SF , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, CELL_FILL = 2, TITLE = title $ +;;SF , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex +;;SF endelse +endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceSal.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceSal.pro new file mode 100644 index 0000000000000000000000000000000000000000..21c923914108a7a5efa484059f4c04c83b12cae4 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceSal.pro @@ -0,0 +1,57 @@ +pro std_plot_IceSal, Isal1, Isal2, Ifra1, Ifra2, ARC = arc, ANT = ant, FEBR = febr, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla +; + var = 'IceSal' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(febr) THEN var = var+'Febr' + IF keyword_set(march) THEN var = var+'March' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + if std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 50, 90 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -50 + map = [-90, 0, 0] + ENDIF + ; + varunit = Isal1.unit + ; + title = var+'!C'+std_file1_I + + Isal1.arr = Isal1.arr * ( Ifra1.arr gt 0.15 ) + plt, Isal1.arr - 1.E-04, MIN = 0., MAX = 10., INTER = 1., /STRICTFILL, CELL_FILL = 2, format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /PORTRAIT, _extra = ex + ; ; + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + + Isal2.arr = Isal2.arr * ( Ifra2.arr gt 0.15 ) + + plt, Isal1.arr - Isal2.arr, MIN = -2., MAX = 2., INTER = 1., STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, CELL_FILL = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return + end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceThick.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceThick.pro new file mode 100644 index 0000000000000000000000000000000000000000..865fefec49fabb04799f775cf784ab46ace24274 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceThick.pro @@ -0,0 +1,75 @@ +pro std_plot_IceThick, Ithi1, Ithi2, Ifra1, Ifra2, ARC = arc, ANT = ant, APRIL = april, JAN = jan, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'IceThi' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(april) THEN var = var+'April' + IF keyword_set(jan) THEN var = var+'Jan' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + IF std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + IF KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 50, 90 + vmin = 0. + vmax = 6. + vint = 0.5 + fmtd = '(f4.1)' + vmind = -3. + vmaxd = 3. + vintd = 0.5 + fmtd = '(f4.1)' + div = 6 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -50 + vmin = 0. + vmax = 3. + vint = 0.2 + fmt = '(f4.1)' + vmind = -1. + vmaxd = 1. + vintd = 0.2 + fmtd = '(f4.1)' + div = 5 + map = [-90, 0, 0] + ENDIF +; + varunit = Ithi1.unit +; + title = var+'!C'+std_file1_I + + Ithi1.arr = Ithi1.arr * ( Ifra1.arr gt 0.15 ) + + plt, (Ithi1.arr < 10. ) - 1.E-04, MIN = vmin, MAX = vmax, INTER = vint, /STRICTFILL, CELL_FILL = 2, format = fmt $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, divisions = div $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /PORTRAIT, _extra = ex +; ; + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + + Ithi2.arr = Ithi2.arr * ( Ifra2.arr gt 0.15 ) + + plt, Ithi1.arr - Ithi2.arr, MIN = vmind, MAX = vmaxd, INTER = vintd, STYLE = 'so0so', format = fmtd $ + , small = [1, 2, 2], COAST_THICK = 2, CELL_FILL = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceVel.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceVel.pro new file mode 100644 index 0000000000000000000000000000000000000000..c15b33732d83ce37e8aff8c978c34835799a6670 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_IceVel.pro @@ -0,0 +1,60 @@ +pro std_plot_IceVel, IvelU1, IvelU2, IvelV1, IvelV2, Ivelo1, Ivelo2, ARC = arc, ANT = ant, FEBR = febr, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'IceVel' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(febr) THEN var = var+'Febr' + IF keyword_set(march) THEN var = var+'March' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + if std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 50, 90 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -50 + map = [-90, 0, 0] + ENDIF + ; + title = var+'!C'+std_file1_I + + Ivelo1 = {arr: Ivelo1.arr - 1.E-04, g: 'T'} + ; Ivelo1 = {arr: Ivelo1.arr, g: 'T'} + + plt, Ivelo1, vecteur={u:IvelU1, v:IvelV1}, unvectsur=[3,3], normeref = 0.5, cmref = 1. $ + , small = [1, 2, 1], TITLE = title $ + , /ORTHO, MAP = map, /PORTRAIT, _extra = ex + ; + + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + ; + Ivelo = {arr: Ivelo1.arr - Ivelo2.arr, g: 'T'} + ; Ivelo1 = {arr: Ivelo1.arr, g: 'T'} + ; Ivelo2 = {arr: Ivelo2.arr - 1.E-04, g: 'T'} + Ivelo2 = {arr: Ivelo2.arr , g: 'T'} + + plt, Ivelo, vecteur={u: IvelU2, v: IvelV2}, unvectsur=[3,3], normeref = 0.5, cmref = 1. $ + , small = [1, 2, 2], TITLE = title $ + , /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return + end + \ No newline at end of file diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_MLD_ortho.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_MLD_ortho.pro new file mode 100644 index 0000000000000000000000000000000000000000..f1ff7f4b2f473368efd7852e409960e2e7aa4dbc --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_MLD_ortho.pro @@ -0,0 +1,48 @@ +pro std_plot_MLD_ortho, MLD1, MLD2, ARC = arc, ANT = ant, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'MLD' + IF keyword_set(arc) THEN var = var+'_Arc' + IF keyword_set(ant) THEN var = var+'_Ant' + + filename = cdti3 + '_'+var+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 40, 90 + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -40 + map = [-90, 0, 0] + ENDIF +; +; varunit = .unit +; + title = var+'!C'+std_file1_T +; ; + plt, MLD1.arr, label=4, cb_label=[0, 15, 25, 50, 75, 100, 125, 150, 250, 400, 600, 850], format = '(I3)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title $ + , /ORTHO, MAP = map, /PORTRAIT, _extra = ex + if std_file1_T NE std_file2_T then begin + title = title + ' - '+ std_file2_T + plt, MLD1.arr - MLD2.arr, MIN = -80., MAX = 80., INTER = 10., format = '(I3)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title $ + , /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sdepth.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sdepth.pro new file mode 100644 index 0000000000000000000000000000000000000000..04c3c55cd318ccf7d022fa2e37efd708b736b0ab --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sdepth.pro @@ -0,0 +1,36 @@ +pro std_plot_Med_Sdepth, S1, S2, SLev, lat, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + slat = strtrim(lat, 1)+'N' + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_Med_Sdepth_'+slat+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + title = 'Salinity ('+slat+')!C'+std_file1_T + pltz, S1, MININ = 35., MAXIN = 37., INTER = 0.1, FORMAT = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, endpoints = [300., lat, 357., lat], TITLE = title $ + , boxzoom = [2000.], ZOOM = 2000., /PORTRAIT, _extra = ex +; + if std_file1_T NE std_file2_T then begin + title = title+ ' - '+std_file2_T + pltz, S1.arr - S2.arr + valmask*(1.-tmask), MININ = -.4, MAXIN = .4, INTER = .05, STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, endpoints = [300., lat, 357., lat], TITLE = title $ + , boxzoom = [2000.], ZOOM = 2000., /noerase, _extra = ex + endif else begin + title = title+ ' - Levitus' + pltz, S1.arr - SLev.arr + valmask*(1.-tmask), MININ = -1., MAXIN = 1., INTER = 0.1, STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, endpoints = [300., lat, 357., lat], TITLE = title $ + , boxzoom = [2000.], ZOOM = 2000., /noerase, _extra = ex + endelse + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sspread.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sspread.pro new file mode 100644 index 0000000000000000000000000000000000000000..d765397ed2ad857bd06c7b69f5af4122c4674b5a --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_Med_Sspread.pro @@ -0,0 +1,34 @@ +pro std_plot_Med_Sspread, S1, S2, SLev, depth, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + tmp = min(abs(depth - gdept), ind) + sdepref = strtrim(round(gdept[ind]), 1)+'m' + filename = cdti3 + '_Med_Sspread_'+sdepref+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + title = 'Salinity ('+sdepref+')!C'+std_file1_T + plt, S1, MININ = 35., MAXIN = 37., INTER = 0.1, FORMAT = '(f4.1)' $ + , small = [1, 2, 1], boxzoom = [270, 365, 5, 70, ind, ind], /zindex, COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex +; + if std_file1_T NE std_file2_T then begin + title = title+ ' - '+std_file2_T + plt, S1.arr - S2.arr, MININ = -.4, MAXIN = .4, INTER = .05, STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], boxzoom = [270, 365, 5, 70, ind, ind], /zindex, COAST_THICK = 2, TITLE = title, /noerase, _extra = ex + endif else begin + title = title+ ' - Levitus' + plt, S1.arr - SLev.arr, MININ = -1., MAXIN = 1., INTER = 0.1, STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], boxzoom = [270, 365, 5, 70, ind, ind], /zindex, COAST_THICK = 2, TITLE = title, /noerase, _extra = ex + ENDELSE + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_S100m.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_S100m.pro new file mode 100644 index 0000000000000000000000000000000000000000..7f94a23fddb7a9bc4542fe7e2f5fdd8919aff175 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_S100m.pro @@ -0,0 +1,34 @@ +pro std_plot_S100m, S1, S2, SLev, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + tmp = min(abs(100 - gdept), ind) + sdepref = strtrim(round(gdept[ind]), 1)+'m' + filename = cdti3 + '_S'+sdepref+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + title = 'Salinity ('+sdepref+')!C'+std_file1_T + plt, S1, MIN = 33., MAX = 38.2, INTER = .2, format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /PORTRAIT, _extra = ex +; + if std_file1_T NE std_file2_T then begin + title = title+ ' - '+std_file2_T + plt, S1.arr[*, *, 0] - S2.arr[*, *, 0], MIN = -1., MAX = 1., INTER = .1, STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /noerase, _extra = ex + endif else begin + title = title+ ' - Levitus' + plt, S1.arr-SLev.arr, MIN = -1., MAX = 1., INTER = 0.1, STYLE = 'so0so', format = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /noerase, _extra = ex + endelse + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_SnowThick.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_SnowThick.pro new file mode 100644 index 0000000000000000000000000000000000000000..7617d89e6d0330ee9527fb891574444a53285124 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_SnowThick.pro @@ -0,0 +1,75 @@ +pro std_plot_SnowThick, Isnow1, Isnow2, Ifra1, Ifra2, ARC = arc, ANT = ant, FEBR = febr, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'SnowThi' + IF keyword_set(arc) THEN var = var+'_Arc_' + IF keyword_set(ant) THEN var = var+'_Ant_' + IF keyword_set(febr) THEN var = var+'Febr' + IF keyword_set(march) THEN var = var+'March' + IF keyword_set(sept) THEN var = var+'Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_I + if std_file1_I NE std_file2_I then filename = filename + '_'+std_file2_I + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + IF keyword_set(arc) THEN BEGIN + domdef, 20, 380, 50, 90 + vmin = 0. + vmax = .6 + vint = 0.1 + ;fmt = '(i2)' + fmt = '(f4.1)' + vmind = -1. + vmaxd = 1. + vintd = 0.1 + ;fmtd = '(i2)' + fmtd = '(f4.1)' + map = [90, 0, 0] + ENDIF + IF keyword_set(ant) THEN BEGIN + domdef, 20, 380, -90, -50 + vmin = 0. + vmax = 1. + vint = 0.1 + fmt = '(f4.1)' + vmind = -1. + vmaxd = 1. + vintd = 0.1 + fmtd = '(f4.1)' + map = [-90, 0, 0] + ENDIF +; + varunit = Isnow1.unit +; + title = var+'!C'+std_file1_I + + Isnow1.arr = Isnow1.arr * ( Ifra1.arr gt 0.15 ) + + plt, (Isnow1.arr < 10. ) - 1.E-04, MIN = vmin, MAX = vmax, INTER = vint, /STRICTFILL, CELL_FILL = 2, format = fmt $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /PORTRAIT, _extra = ex +; ; + if std_file1_I NE std_file2_I then begin + title = title + std_file2_I + + Isnow2.arr = Isnow2.arr * ( Ifra2.arr gt 0.15 ) + + plt, Isnow1.arr - Isnow2.arr, MIN = vmind, MAX = vmaxd, INTER = vintd, STYLE = 'so0so', format = fmtd $ + , small = [1, 2, 2], COAST_THICK = 2, CELL_FILL = 2, TITLE = title $ + , CHARSIZE = 1.05, GLINETHICK = 2., /ORTHO, MAP = map, /NOERASE, _extra = ex + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_T100m.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_T100m.pro new file mode 100644 index 0000000000000000000000000000000000000000..2ef05c40a3bdd572caab964ccba32274132e3d0c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_T100m.pro @@ -0,0 +1,34 @@ +pro std_plot_T100m, T1, T2, TLev, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + tmp = min(abs(100 - gdept), ind) + sdepref = strtrim(round(gdept[ind]), 1)+'m' + filename = cdti3 + '_T'+sdepref+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + title = 'Temperature ('+sdepref+')!C'+std_file1_T + plt, T1, MIN = -2., MAX = 32., INTER = 1., FORMAT = '(I2)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /portrait, _extra = ex +; + IF std_file1_T NE std_file2_T THEN BEGIN + title = title+ ' - '+std_file2_T + plt, T1.arr - T2.arr, MIN = -2., MAX = 2., INTER = .2, STYLE = 'so0so', FORMAT = '(f4.1)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /noerase, _extra = ex + ENDIF ELSE BEGIN + title = title+ ' - Levitus' + plt, T1.arr - TLev.arr, MIN = -5., MAX = 5., INTER = .5, STYLE = 'so0so', FORMAT = '(I2)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = [floor(gdept[ind]), ceil(gdept[ind])], /noerase, _extra = ex + ENDELSE +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ZonMld.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ZonMld.pro new file mode 100644 index 0000000000000000000000000000000000000000..5994e85b7a488dc3a3f6ce5932a006825624283f --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_ZonMld.pro @@ -0,0 +1,32 @@ +pro std_plot_ZonMld, MLD1, MLD2, MLD, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ZonMld_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + ; + title = std_file1_T+' (Black)!C' + if std_file1_T NE std_file2_T THEN title = title + std_file2_T+' (Red)!C' + title = title + 'DeBoyer (Blue)!C' + + plt1d, -MLD1.arr, MIN = -300., MAX = 0., INTER = 10., typein = 'y' $ + , small = [1, 1, 1], boxzoom = 5500, ZOOM = 500, CHARSIZE = .8, TITLE = title, /PORTRAIT, _extra = ex + ; + IF std_file1_T NE std_file2_T THEN $ + plt1d, -MLD2.arr, MIN = -300., MAX = 0., INTER = 10., typein = 'y' $ + , /ov1d, COLOR = 250, TITLE = title, /NOERASE, _extra = ex ; color 250 = red + ; + plt1d, -MLD.arr, MIN = -300., MAX = 0., INTER = 10., typein = 'y' $ + , /ov1d, COLOR = 100, THICK = 3, TITLE = title, /NOERASE, _extra = ex ; color 100 = blue + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all.pro new file mode 100644 index 0000000000000000000000000000000000000000..5225124342d391335f16b54e9bf1fa14bca143d3 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all.pro @@ -0,0 +1,589 @@ +pro std_plot_all, doplot = doplot, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + ; scripts for nemo v3_2 and v3_3 + + PRINT, '' + PRINT, ' ############################################' + PRINT, '' + PRINT, ' LAUNCH of std_plots' + PRINT, '' + PRINT, ' ############################################' + PRINT, '' +; + std_iodir_data = isadirectory(getenv('DIR_DATA'), title = 'path of data in NetCdf format') + std_iodir_climato = isadirectory(getenv('DIR_CLIMATO'), title = 'path of climatological data') + std_iodir_mask = isadirectory(getenv('DIR_MASK'), title = 'path of mask files (ex: subbasins)') +; meshmask + std_file_mesh = isafile(getenv('FILE_MESH_MASK'), title = 'mesh_mask', iodir = std_iodir_mask) + std_file_msksub = isafile(getenv('FILE_MASK_SUBDOMAIN'), title = 'sub-bassin masks', iodir = std_iodir_mask) + +; climatologies + std_file_Levitus_T = isafile(getenv('FILE_TEMP_3D'), title = 'Levitus_T', iodir = std_iodir_climato) + std_file_Levitus_S = isafile(getenv('FILE_SAL_3D'), title = 'Levitus_S', iodir = std_iodir_climato) + std_file_reynolds = isafile(getenv('FILE_SST'), title = 'Reynolds', iodir = std_iodir_climato) + std_file_oaflux = isafile(getenv('FILE_FLUX'), title = 'oaflux', iodir = std_iodir_climato) + std_file_mld = isafile(getenv('FILE_MLD'), title = 'Mixed layer depth', iodir = std_iodir_climato) + std_file_ice = isafile(getenv('FILE_ICE'), title = 'ICE', iodir = std_iodir_climato) + std_file_snow_arc = isafile(getenv('FILE_SNOW_ARC'), title = 'SNOW_ARC', iodir = std_iodir_climato) + std_file_snow_ant = isafile(getenv('FILE_SNOW_ANT'), title = 'SNOW_ANT', iodir = std_iodir_climato) + + IF strlowcase(getenv('FILE_GEOHEAT')) EQ 'no' THEN std_file_geoheat = 'no' $ + ELSE std_file_geoheat = isafile(getenv('FILE_GEOHEAT'), title = 'Geothermal heating', iodir = std_iodir_climato) +; + allrec = 1 - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) + +; Output run experience1 + std_file1_T = isafile(getenv('FILE1_T'), title = 'exp1 grid T input file', iodir = std_iodir_data) + std_file1_U = isafile(getenv('FILE1_U'), title = 'exp1 grid U input file', iodir = std_iodir_data) + std_file1_V = isafile(getenv('FILE1_V'), title = 'exp1 grid V input file', iodir = std_iodir_data) + std_file1_I = isafile(getenv('FILE1_I'), title = 'exp1 ice input file', iodir = std_iodir_data) + +; Output run experience2 + std_file2_T = isafile(getenv('FILE2_T'), title = 'exp2 grid T input file', iodir = std_iodir_data) + std_file2_U = isafile(getenv('FILE2_U'), title = 'exp2 grid U input file', iodir = std_iodir_data) + std_file2_V = isafile(getenv('FILE2_V'), title = 'exp2 grid V input file', iodir = std_iodir_data) + std_file2_I = isafile(getenv('FILE2_I'), title = 'exp2 ice input file', iodir = std_iodir_data) + + PRINT, '' + PRINT, ' std_iodir_data : ' + std_iodir_data + PRINT, ' std_file1T : ' + std_file1_T + PRINT, ' std_file1U : ' + std_file1_U + PRINT, ' std_file1V : ' + std_file1_V +; PRINT, ' std_file1W : ' + std_file1_W + PRINT, ' std_file2I : ' + std_file1_I + PRINT, ' std_file2T : ' + std_file2_T + PRINT, ' std_file2U : ' + std_file2_U + PRINT, ' std_file2V : ' + std_file2_V +; PRINT, ' std_file2W : ' + std_file2_W + PRINT, ' std_file2I : ' + std_file2_I + PRINT, '' + +;######################################################################### +;########################## Load Grids ################################ +;######################################################################### +; load the grid + load_orca, std_file_mesh +; reading variables + masknp = read_ncdf('tmaskutil', file = std_file_mesh, /nostruct, /cont_nofill) +;######################################################################### +;############################ Read Data ################################ +;######################################################################### +; + allrec = 1; - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) +; +;;; 3D ;;; +; temperature + T1 = read_ncdf(getenv('VAR1_T'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + T2 = read_ncdf(getenv('VAR2_T'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE T2 = {arr:-1} + TLev = read_ncdf(getenv('VAR_TEMP_3D'), filename = std_file_Levitus_T ) + TRey = read_ncdf(getenv('VAR_SST'), filename = std_file_reynolds ) + +; salinity + S1 = read_ncdf(getenv('VAR1_S'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + S2 = read_ncdf(getenv('VAR2_S'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE S2 = {arr:-1} + SLev = read_ncdf(getenv('VAR_SAL_3D'), filename = std_file_Levitus_S ) + +;;; 2D ;;; +; Net Downward heat flux + Q1 = read_ncdf(getenv('VAR1_QNET'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + Q2 = read_ncdf(getenv('VAR2_QNET'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE Q2 = {arr:-1} +; Geothermal heating + IF std_file_geoheat EQ 'no' THEN geo = {arr:float(getenv('VAR_GEOHEAT'))} $ + ELSE geo = read_ncdf(getenv('VAR_GEOHEAT'), filename = std_file_geoheat ) + geo = geo.arr*1.e-3 ; convert into W/m2 +;climatology + QNET = read_ncdf(getenv('VAR_FLUX'), filename = std_file_oaflux ) + +; erp (evaporation damping) + ERP1 = read_ncdf(getenv('VAR1_ERP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + ERP1 = {arr:ERP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + ERP2 = read_ncdf(getenv('VAR2_ERP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ERP2 = {arr:ERP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE ERP2 = {arr:-1} + +; emp (evaporation minus precipitation) + EMP1 = read_ncdf(getenv('VAR1_EMP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + EMP1 = {arr:EMP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + EMP2 = read_ncdf(getenv('VAR2_EMP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + EMP2 = {arr:EMP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE EMP2 = {arr:-1} + + ;mixed layer depth + MLD1 = read_ncdf(getenv('VAR1_MLD'), allrecords = allrec, direc = 't', filename = std_file1_T ) ; 10 m + IF std_file2_T NE std_file1_T THEN BEGIN + MLD2 = read_ncdf(getenv('VAR2_MLD'), allrecords = allrec, direc = 't', filename = std_file2_T ) ; 10 m + ENDIF ELSE MLD2 = {arr:-1} + ;climatology + MLD = read_ncdf(getenv('VAR_MLD'), filename = std_file_mld ) + + ; velocities + U1 = read_ncdf(getenv('VAR1_U'), allrecords = allrec, direc = 't', filename = std_file1_U ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR1_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR1_U')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(U1.unit) EQ 'm3/s' THEN BEGIN + ;IF it is a transport it is transofrmed in velocity + U1.arr = U1.arr / e3u_3d(/e2) * umask() + U1.unit = 'm/s' + ENDIF + IF std_file2_U NE std_file1_U THEN BEGIN + U2 = read_ncdf(getenv('VAR2_U'), allrecords = allrec, direc = 't', filename = std_file2_U ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR2_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR2_U')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(U2.unit) EQ 'm3/s' THEN BEGIN + U2.arr = U2.arr / e3u_3d(/e2) * umask() + U2.unit = 'm/s' + ENDIF + ENDIF ELSE U2 = {arr:-1} +; + V1 = read_ncdf(getenv('VAR1_V'), allrecords = allrec, direc = 't', filename = std_file1_V ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR1_V')) EQ 'vocetr_eff' OR strlowcase(getenv('VAR1_V')) EQ 'vomeeftr' THEN BEGIN + IF strlowcase(V1.unit) EQ 'm3/s' THEN BEGIN ; test on unit to understand if it is a transport or velocity + ;IF it is a transport it is transofrmed in velocity + V1.arr = V1.arr / e3v_3d(/e1) * vmask() + V1.unit = 'm/s' + ENDIF + IF std_file2_V NE std_file1_V THEN BEGIN + V2 = read_ncdf(getenv('VAR2_V'), allrecords = allrec, direc = 't', filename = std_file2_V ) + ; old formulation + ; IF strlowcase(getenv('VAR2_V')) EQ 'vocetr_eff' OR strlowcase(getenv('VAR2_V')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(V2.unit) EQ 'm3/s' THEN BEGIN + V2.arr = V2.arr / e3v_3d(/e1) * vmask() + V2.unit = 'm/s' + ENDIF + ENDIF ELSE V2 = {arr:-1} + +; ice + Ithi_1 = read_ncdf(getenv('VAR1_Ithick'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + jan = where(mm EQ 1, cnt) + Ithi_jan_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + sept = where(mm EQ 9, cnt) + Ithi_sept_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + undefine, Ithi_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ithi_2 = read_ncdf(getenv('VAR2_Ithick'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + jan = where(mm EQ 1, cnt) + sept = where(mm EQ 9, cnt) + Ithi_sept_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + Ithi_jan_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + undefine, Ithi_2 + ENDIF ELSE BEGIN + Ithi_april_2 = {arr:-1} + Ithi_sept_2 = {arr:-1} + Ithi_jan_2 = {arr:-1} + ENDELSE +; + Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + jan = where(mm EQ 1, cnt) + Ifra_jan_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + febr = where(mm EQ 2, cnt) + Ifra_febr_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + march = where(mm EQ 3, cnt) + Ifra_march_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + april = where(mm EQ 4, cnt) + Ifra_april_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + undefine, Ifra_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ifra_2 = read_ncdf(getenv('VAR2_Ifrac'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + jan = where(mm EQ 1, cnt) + Ifra_jan_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + febr = where(mm EQ 2, cnt) + Ifra_febr_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + march = where(mm EQ 3, cnt) + Ifra_march_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + april = where(mm EQ 4, cnt) + Ifra_april_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + undefine, Ifra_2 + ENDIF ELSE BEGIN + Ifra_jan_2 = {arr:-1} + Ifra_febr_2 = {arr:-1} + Ifra_march_2 = {arr:-1} + Ifra_april_2 = {arr:-1} + Ifra_sept_2 = {arr:-1} + ENDELSE +; + Isnow_1 = read_ncdf(getenv('VAR1_Isnow'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + march = where(mm EQ 3, cnt) + Isnow_march_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + ;undefine, Isnow_1 + ; + IF std_file2_I NE std_file1_I THEN BEGIN + Isnow_2 = read_ncdf(getenv('VAR2_Isnow'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + march = where(mm EQ 3, cnt) + Isnow_march_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + ; undefine, Isnow_2 + ENDIF ELSE BEGIN + Isnow_febr_2 = {arr:-1} + Isnow_march_2 = {arr:-1} + Isnow_sept_2 = {arr:-1} + ENDELSE +; + Isal_1 = read_ncdf(getenv('VAR1_Isal'), allrecords = allrec, filename = std_file1_I ) +;SF ready for mask : remove 0.15% for observations +;SF +;SF Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) +;SF msk = Ifra_1.arr gt 0.15 ; remove 0.15% for observations + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} +;SF +;SF Isal_1.arr = Isal_1.arr * msk +;SF +;SF Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + Isal_febr_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + ;undefine, Isal_1 + ; + Isal_2 = read_ncdf(getenv('VAR2_Isal'), allrecords = allrec, filename = std_file2_I ) + IF std_file2_I NE std_file1_I THEN BEGIN + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + Isal_march_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + Isal_febr_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + ; undefine, Isal_2 + ENDIF ELSE BEGIN + Isal_febr_2 = {arr:-1} + Isal_march_2 = {arr:-1} + Isal_sept_2 = {arr:-1} + ENDELSE + + IvelU_1 = read_ncdf(getenv('VAR1_IvelU'), allrecords = allrec, filename = std_file1_I ) + IvelV_1 = read_ncdf(getenv('VAR1_IvelV'), allrecords = allrec, filename = std_file1_I ) + Ivelo_1 = read_ncdf(getenv('VAR1_Ivelo'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + IvelU_febr_1 = {arr:1./float(cnt) * total(reform(IvelU_1.arr[*, *, febr],nxt,nyt,cnt), 3), unit:IvelU_1.unit, g: 'T'} + IvelV_febr_1 = {arr:1./float(cnt) * total(reform(IvelV_1.arr[*, *, febr],nxt,nyt,cnt), 3), unit:IvelV_1.unit, g: 'T'} + Ivelo_febr_1 = {arr:1./float(cnt) * total(reform(Ivelo_1.arr[*, *, febr],nxt,nyt,cnt), 3), unit:Ivelo_1.unit, g: 'T'} + march = where(mm EQ 3, cnt) + IvelU_march_1 = {arr:1./float(cnt) * total(reform(IvelU_1.arr[*, *, march],nxt,nyt,cnt), 3), unit:IvelU_1.unit, g: 'T'} + IvelV_march_1 = {arr:1./float(cnt) * total(reform(IvelV_1.arr[*, *, march],nxt,nyt,cnt), 3), unit:IvelV_1.unit, g: 'T'} + Ivelo_march_1 = {arr:1./float(cnt) * total(reform(Ivelo_1.arr[*, *, march],nxt,nyt,cnt), 3), unit:Ivelo_1.unit, g: 'T'} + sept = where(mm EQ 9, cnt) + IvelU_sept_1 = {arr:1./float(cnt) * total(reform(IvelU_1.arr[*, *, sept],nxt,nyt,cnt), 3), unit:IvelU_1.unit, g: 'T'} + IvelV_sept_1 = {arr:1./float(cnt) * total(reform(IvelV_1.arr[*, *, sept],nxt,nyt,cnt), 3), unit:IvelV_1.unit, g: 'T'} + Ivelo_sept_1 = {arr:1./float(cnt) * total(reform(Ivelo_1.arr[*, *, sept],nxt,nyt,cnt), 3), unit:Ivelo_1.unit, g: 'T'} +; + IF std_file2_I NE std_file1_I THEN BEGIN + IvelU_2 = read_ncdf(getenv('VAR2_IvelU'), allrecords = allrec, filename = std_file2_I ) + IvelV_2 = read_ncdf(getenv('VAR2_IvelV'), allrecords = allrec, filename = std_file2_I ) + Ivelo_2 = read_ncdf(getenv('VAR2_Ivelo'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + IvelU_febr_2 = {arr:1./float(cnt) * total(reform(IvelU_2.arr[*, *, febr],nxt,nyt,cnt), 3), unit:IvelU_2.unit} + IvelV_febr_2 = {arr:1./float(cnt) * total(reform(IvelV_2.arr[*, *, febr],nxt,nyt,cnt), 3), unit:IvelV_2.unit} + Ivelo_febr_2 = {arr:1./float(cnt) * total(reform(Ivelo_2.arr[*, *, febr],nxt,nyt,cnt), 3), unit:Ivelo_2.unit} + march = where(mm EQ 3, cnt) + IvelU_march_2 = {arr:1./float(cnt) * total(reform(IvelU_2.arr[*, *, march],nxt,nyt,cnt), 3), unit:IvelU_2.unit} + IvelV_march_2 = {arr:1./float(cnt) * total(reform(IvelV_2.arr[*, *, march],nxt,nyt,cnt), 3), unit:IvelV_2.unit} + Ivelo_march_2 = {arr:1./float(cnt) * total(reform(Ivelo_2.arr[*, *, march],nxt,nyt,cnt), 3), unit:Ivelo_2.unit} + sept = where(mm EQ 9, cnt) + IvelU_sept_2 = {arr:1./float(cnt) * total(reform(IvelU_2.arr[*, *, sept],nxt,nyt,cnt), 3), unit:IvelU_2.unit} + IvelV_sept_2 = {arr:1./float(cnt) * total(reform(IvelV_2.arr[*, *, sept],nxt,nyt,cnt), 3), unit:IvelV_2.unit} + Ivelo_sept_2 = {arr:1./float(cnt) * total(reform(Ivelo_2.arr[*, *, sept],nxt,nyt,cnt), 3), unit:Ivelo_2.unit} + undefine, Ifra_2 + ENDIF ELSE BEGIN + IvelU_febr_2 = {arr:-1} + IvelV_febr_2 = {arr:-1} + Ivelo_febr_2 = {arr:-1} + IvelU_march_2 = {arr:-1} + IvelV_march_2 = {arr:-1} + Ivelo_march_2 = {arr:-1} + IvelU_sept_2 = {arr:-1} + IvelV_sept_2 = {arr:-1} + Ivelo_sept_2 = {arr:-1} + ENDELSE + + Iage_1 = read_ncdf(getenv('VAR1_Iage'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + march = where(mm EQ 3, cnt) + Iage_march_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + undefine, Iage_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Iage_2 = read_ncdf(getenv('VAR2_Iage'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + march = where(mm EQ 3, cnt) + Iage_march_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + undefine, Iage_2 + ENDIF ELSE BEGIN + Iage_febr_2 = {arr:-1} + Iage_march_2 = {arr:-1} + Iage_sept_2 = {arr:-1} + ENDELSE +; + jpt = 1 +; +; shorter file names for legends... +; + std_file1_T = file_basename(std_file1_T,'.nc') + std_file1_T = (strsplit(std_file1_T,'_grid_T',/extract,/regex))[0] + std_file2_T = file_basename(std_file2_T,'.nc') + std_file2_T = (strsplit(std_file2_T,'_grid_T',/extract,/regex))[0] + std_file1_U = file_basename(std_file1_U,'.nc') + std_file1_U = (strsplit(std_file1_U,'_grid_U',/extract,/regex))[0] + std_file2_U = file_basename(std_file2_U,'.nc') + std_file2_U = (strsplit(std_file2_U,'_grid_U',/extract,/regex))[0] + std_file1_V = file_basename(std_file1_V,'.nc') + std_file1_V = (strsplit(std_file1_V,'_grid_V',/extract,/regex))[0] + std_file2_V = file_basename(std_file2_V,'.nc') + std_file2_V = (strsplit(std_file2_V,'_grid_V',/extract,/regex))[0] + std_file1_I = file_basename(std_file1_I,'.nc') + std_file1_I = (strsplit(std_file1_I,'_icemod',/extract,/regex))[0] + std_file2_I = file_basename(std_file2_I,'.nc') + std_file2_I = (strsplit(std_file2_I,'_icemod',/extract,/regex))[0] + +;######################################################################### +;###################### STANDARD PLOTS ################################ +;######################################################################### + + IF keyword_set(doplot) EQ 0 THEN doplot = 0 + +; fixed color tabled + lct, 64 + cnt = 0 + htmltxt = '' +; + cnt = cnt+1 & blabla = 'Erp salinity damping term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_erp, ERP1, ERP2, _extra = ex +;; + cnt = cnt+1 & blabla = 'Evaporation - Precipitation - Runoff term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_emp, EMP1, EMP2, _extra = ex +; + cnt = cnt+1 & blabla = 'Net heat flux' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_qnet, Q1, Q2, QNET, _extra = ex +; + cnt = cnt+1 & blabla = 'Meridionnal Heat Transport' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mht, Q1.arr+geo, Q2.arr+geo, masknp, std_file_msksub, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Barotropic stream Function' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_bsf, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with New Reynolds' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sst, T1, T2, TRey, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sss, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2 at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_T100m, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_S100m, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD1, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth differences' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD1, MLD2, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth ortho plan ARCTIC' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_MLD_ortho, MLD1, MLD2, /ARC, _extra = ex +;sf + cnt = cnt+1 & blabla = 'Mixed layer depth ortho plan ANTARTIC' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_MLD_ortho, MLD1, MLD2, /ANT, _extra = ex +;sf + cnt = cnt+1 & blabla = 'Zonal mean Mixed layer depth' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ZonMld, MLD1, MLD2, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Vertical Global mean T & S' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_GlobMeanTS, T1, T2, TLev, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Global (no Med)' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'GloNoMed', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Atl', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Ind', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indo-Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'IndoPac', _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Temperature' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqT, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Salinity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqS, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial zonal velocity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqU, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=700' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 700, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=1000' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 1000, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=40 N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 40, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=38 N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 38, _extra = ex +; +;; +; all plot are done for ice fraction > 0.15% +;; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: JAN' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_jan_1, Ithi_jan_2, Ifra_jan_1, Ifra_jan_2, /ARC, /JAN, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, Ifra_april_1, Ifra_april_2, /ARC, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, Ifra_april_1, Ifra_april_2, /ANT, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_sept_1, Ithi_sept_2, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_march_1, Isnow_march_2, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_febr_1, Isnow_febr_2, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_march_1, Isal_march_2, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: FEBRUARY' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_febr_1, Isal_febr_2, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Velocity: FEBRUARY' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceVel, IvelU_febr_1, IvelU_febr_2, IvelV_febr_1, IvelV_febr_2, Ivelo_febr_1, Ivelo_febr_2, /ARC, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Velocity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceVel, IvelU_sept_1, IvelU_sept_2, IvelV_sept_1, IvelV_sept_2, Ivelo_sept_1, Ivelo_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antartic Ice Velocity: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceVel, IvelU_march_1, IvelU_march_2, IvelV_march_1, IvelV_march_2, Ivelo_march_1, Ivelo_march_2, /ANT, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Antartic Ice Velocity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceVel, IvelU_sept_1, IvelU_sept_2, IvelV_sept_1, IvelV_sept_2, Ivelo_sept_1, Ivelo_sept_2, /ANT, /SEPT, _extra = ex + + cnt = cnt+1 & blabla = 'Arctic Ice Age: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_march_1, Iage_march_2, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: FEBR' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_febr_1, Iage_febr_2, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + + IF n_elements(htmltxt) GT 1 THEN putfile, psdir+'std_plot_html_body.txt', htmltxt[1:*] + + return +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_1Y.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_1Y.pro new file mode 100644 index 0000000000000000000000000000000000000000..8f9336cdfc87920165d94cb9bb7fcd18801fa95d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_1Y.pro @@ -0,0 +1,510 @@ +pro std_plot_all_1Y, doplot = doplot, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + ; scripts for nemo v3_2 and v3_3 + + PRINT, '' + PRINT, ' ############################################' + PRINT, '' + PRINT, ' LAUNCH of std_plots' + PRINT, '' + PRINT, ' ############################################' + PRINT, '' +; + std_iodir_data = isadirectory(getenv('DIR_DATA'), title = 'path of data in NetCdf format') + std_iodir_climato = isadirectory(getenv('DIR_CLIMATO'), title = 'path of climatological data') + std_iodir_mask = isadirectory(getenv('DIR_MASK'), title = 'path of mask files (ex: subbasins)') +; meshmask + std_file_mesh = isafile(getenv('FILE_MESH_MASK'), title = 'mesh_mask', iodir = std_iodir_mask) + std_file_msksub = isafile(getenv('FILE_MASK_SUBDOMAIN'), title = 'sub-bassin masks', iodir = std_iodir_mask) + +; climatologies + std_file_Levitus_T = isafile(getenv('FILE_TEMP_3D'), title = 'Levitus_T', iodir = std_iodir_climato) + std_file_Levitus_S = isafile(getenv('FILE_SAL_3D'), title = 'Levitus_S', iodir = std_iodir_climato) + std_file_reynolds = isafile(getenv('FILE_SST'), title = 'Reynolds', iodir = std_iodir_climato) + std_file_oaflux = isafile(getenv('FILE_FLUX'), title = 'oaflux', iodir = std_iodir_climato) + std_file_mld = isafile(getenv('FILE_MLD'), title = 'Mixed layer depth', iodir = std_iodir_climato) + std_file_ice = isafile(getenv('FILE_ICE'), title = 'ICE', iodir = std_iodir_climato) + std_file_snow_arc = isafile(getenv('FILE_SNOW_ARC'), title = 'SNOW_ARC', iodir = std_iodir_climato) + std_file_snow_ant = isafile(getenv('FILE_SNOW_ANT'), title = 'SNOW_ANT', iodir = std_iodir_climato) + + IF strlowcase(getenv('FILE_GEOHEAT')) EQ 'no' THEN std_file_geoheat = 'no' $ + ELSE std_file_geoheat = isafile(getenv('FILE_GEOHEAT'), title = 'Geothermal heating', iodir = std_iodir_climato) +; + allrec = 1 - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) +; Output run experience1 + std_file1_T = isafile(getenv('FILE1_T'), title = 'exp1 grid T input file', iodir = std_iodir_data) + std_file1_U = isafile(getenv('FILE1_U'), title = 'exp1 grid U input file', iodir = std_iodir_data) + std_file1_V = isafile(getenv('FILE1_V'), title = 'exp1 grid V input file', iodir = std_iodir_data) + std_file1_I = isafile(getenv('FILE1_I'), title = 'exp1 ice input file', iodir = std_iodir_data) + +; Output run experience2 + std_file2_T = isafile(getenv('FILE2_T'), title = 'exp2 grid T input file', iodir = std_iodir_data) + std_file2_U = isafile(getenv('FILE2_U'), title = 'exp2 grid U input file', iodir = std_iodir_data) + std_file2_V = isafile(getenv('FILE2_V'), title = 'exp2 grid V input file', iodir = std_iodir_data) + std_file2_I = isafile(getenv('FILE2_I'), title = 'exp2 ice input file', iodir = std_iodir_data) + + PRINT, '' + PRINT, ' std_iodir_data : ' + std_iodir_data + PRINT, ' std_file1T : ' + std_file1_T + PRINT, ' std_file1U : ' + std_file1_U + PRINT, ' std_file1V : ' + std_file1_V +; PRINT, ' std_file1W : ' + std_file1_W + PRINT, ' std_file2I : ' + std_file1_I + PRINT, ' std_file2T : ' + std_file2_T + PRINT, ' std_file2U : ' + std_file2_U + PRINT, ' std_file2V : ' + std_file2_V +; PRINT, ' std_file2W : ' + std_file2_W + PRINT, ' std_file2I : ' + std_file2_I + PRINT, '' + +;######################################################################### +;########################## Load Grids ################################ +;######################################################################### +; load the grid + load_orca, std_file_mesh +; reading variables + masknp = read_ncdf('tmaskutil', file = std_file_mesh, /nostruct, /cont_nofill) +;######################################################################### +;############################ Read Data ################################ +;######################################################################### +; + allrec = 1; - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) +; +;;; 3D ;;; +; temperature + T1 = read_ncdf(getenv('VAR1_T'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + T2 = read_ncdf(getenv('VAR2_T'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE T2 = {arr:-1} + TLev = read_ncdf(getenv('VAR_TEMP_3D'), filename = std_file_Levitus_T ) + TRey = read_ncdf(getenv('VAR_SST'), filename = std_file_reynolds ) + +; salinity + S1 = read_ncdf(getenv('VAR1_S'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + S2 = read_ncdf(getenv('VAR2_S'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE S2 = {arr:-1} + SLev = read_ncdf(getenv('VAR_SAL_3D'), filename = std_file_Levitus_S ) + +;;; 2D ;;; +; Net Downward heat flux + Q1 = read_ncdf(getenv('VAR1_QNET'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + Q2 = read_ncdf(getenv('VAR2_QNET'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE Q2 = {arr:-1} +; Geothermal heating + IF std_file_geoheat EQ 'no' THEN geo = {arr:float(getenv('VAR_GEOHEAT'))} $ + ELSE geo = read_ncdf(getenv('VAR_GEOHEAT'), filename = std_file_geoheat ) + geo = geo.arr*1.e-3 ; convert into W/m2 +;climatology + QNET = read_ncdf(getenv('VAR_FLUX'), filename = std_file_oaflux ) + +; erp (evaporation damping) + ERP1 = read_ncdf(getenv('VAR1_ERP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + ERP1 = {arr:ERP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + ERP2 = read_ncdf(getenv('VAR2_ERP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ERP2 = {arr:ERP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE ERP2 = {arr:-1} + +; emp (evaporation minus precipitation) + EMP1 = read_ncdf(getenv('VAR1_EMP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + EMP1 = {arr:EMP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + EMP2 = read_ncdf(getenv('VAR2_EMP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + EMP2 = {arr:EMP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE EMP2 = {arr:-1} + + ;mixed layer depth + MLD1 = read_ncdf(getenv('VAR1_MLD'), allrecords = allrec, direc = 't', filename = std_file1_T ) ; 10 m + IF std_file2_T NE std_file1_T THEN BEGIN + MLD2 = read_ncdf(getenv('VAR2_MLD'), allrecords = allrec, direc = 't', filename = std_file2_T ) ; 10 m + ENDIF ELSE MLD2 = {arr:-1} + ;climatology + MLD = read_ncdf(getenv('VAR_MLD'), filename = std_file_mld ) + + ; velocities + U1 = read_ncdf(getenv('VAR1_U'), allrecords = allrec, direc = 't', filename = std_file1_U ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR1_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR1_U')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(U1.unit) EQ 'm3/s' THEN BEGIN + ;IF it is a transport it is transofrmed in velocity + U1.arr = U1.arr / e3u_3d(/e2) * umask() + U1.unit = 'm/s' + ENDIF + IF std_file2_U NE std_file1_U THEN BEGIN + U2 = read_ncdf(getenv('VAR2_U'), allrecords = allrec, direc = 't', filename = std_file2_U ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR2_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR2_U')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(U2.unit) EQ 'm3/s' THEN BEGIN + U2.arr = U2.arr / e3u_3d(/e2) * umask() + U2.unit = 'm/s' + ENDIF + ENDIF ELSE U2 = {arr:-1} +; + V1 = read_ncdf(getenv('VAR1_V'), allrecords = allrec, direc = 't', filename = std_file1_V ) + ; old formulation: we tested variable name + ; IF strlowcase(getenv('VAR1_V')) EQ 'vocetr_eff' OR strlowcase(getenv('VAR1_V')) EQ 'vomeeftr' THEN BEGIN + IF strlowcase(V1.unit) EQ 'm3/s' THEN BEGIN ; test on unit to understand if it is a transport or velocity + ;IF it is a transport it is transofrmed in velocity + V1.arr = V1.arr / e3v_3d(/e1) * vmask() + V1.unit = 'm/s' + ENDIF + IF std_file2_V NE std_file1_V THEN BEGIN + V2 = read_ncdf(getenv('VAR2_V'), allrecords = allrec, direc = 't', filename = std_file2_V ) + ; old formulation + ; IF strlowcase(getenv('VAR2_V')) EQ 'vocetr_eff' OR strlowcase(getenv('VAR2_V')) EQ 'vozoeftr' THEN BEGIN + IF strlowcase(V2.unit) EQ 'm3/s' THEN BEGIN + V2.arr = V2.arr / e3v_3d(/e1) * vmask() + V2.unit = 'm/s' + ENDIF + ENDIF ELSE V2 = {arr:-1} + +; ice + Ithi_1 = read_ncdf(getenv('VAR1_Ithick'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + jan = where(mm EQ 1, cnt) + sept = where(mm EQ 9, cnt) + Ithi_jan_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + Ithi_sept_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + undefine, Ithi_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ithi_2 = read_ncdf(getenv('VAR2_Ithick'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + jan = where(mm EQ 1, cnt) + sept = where(mm EQ 9, cnt) + Ithi_sept_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + Ithi_jan_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + undefine, Ithi_2 + ENDIF ELSE BEGIN + Ithi_april_2 = {arr:-1} + Ithi_sept_2 = {arr:-1} + Ithi_jan_2 = {arr:-1} + ENDELSE +; + Iage_1 = read_ncdf(getenv('VAR1_Iage'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + march = where(mm EQ 3, cnt) + Iage_march_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + undefine, Iage_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Iage_2 = read_ncdf(getenv('VAR2_Iage'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + march = where(mm EQ 3, cnt) + Iage_march_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + undefine, Iage_2 + ENDIF ELSE BEGIN + Iage_febr_2 = {arr:-1} + Iage_march_2 = {arr:-1} + Iage_sept_2 = {arr:-1} + ENDELSE +; + Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Ifra_febr_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + march = where(mm EQ 3, cnt) + Ifra_march_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + undefine, Ifra_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ifra_2 = read_ncdf(getenv('VAR2_Ifrac'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Ifra_febr_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + march = where(mm EQ 3, cnt) + Ifra_march_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + undefine, Ifra_2 + ENDIF ELSE BEGIN + Ifra_febr_2 = {arr:-1} + Ifra_march_2 = {arr:-1} + Ifra_sept_2 = {arr:-1} + ENDELSE +; + Isnow_1 = read_ncdf(getenv('VAR1_Isnow'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + march = where(mm EQ 3, cnt) + Isnow_march_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + ;undefine, Isnow_1 + ; + IF std_file2_I NE std_file1_I THEN BEGIN + Isnow_2 = read_ncdf(getenv('VAR2_Isnow'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + march = where(mm EQ 3, cnt) + Isnow_march_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + ; undefine, Isnow_2 + ENDIF ELSE BEGIN + Isnow_febr_2 = {arr:-1} + Isnow_march_2 = {arr:-1} + Isnow_sept_2 = {arr:-1} + ENDELSE +; + Isal_1 = read_ncdf(getenv('VAR1_Isal'), allrecords = allrec, filename = std_file1_I ) + Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) + msk = Ifra_1.arr gt 0.15 ; remove 0.15% for observations + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + ;SF Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + Isal_1.arr = Isal_1.arr * msk + Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + Isal_febr_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + ;undefine, Isal_1 + ; + Isal_2 = read_ncdf(getenv('VAR2_Isal'), allrecords = allrec, filename = std_file2_I ) + Ifra_2 = read_ncdf(getenv('VAR2_Ifrac'), allrecords = allrec, filename = std_file2_I ) + msk = Ifra_2.arr gt 0.15 ; remove 0.15% for observations + IF std_file2_I NE std_file1_I THEN BEGIN + Isal_2 = read_ncdf(getenv('VAR2_Isal'), allrecords = allrec, filename = std_file2_I ) + Isal_2.arr = Isal_2.arr * msk + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + Isal_march_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + Isal_febr_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + ; undefine, Isal_2 + ENDIF ELSE BEGIN + Isal_febr_2 = {arr:-1} + Isal_march_2 = {arr:-1} + Isal_sept_2 = {arr:-1} + ENDELSE +; + jpt = 1 +; +; shorter file names for legends... +; + std_file1_T = file_basename(std_file1_T,'.nc') + std_file1_T = (strsplit(std_file1_T,'_grid_T',/extract,/regex))[0] + std_file2_T = file_basename(std_file2_T,'.nc') + std_file2_T = (strsplit(std_file2_T,'_grid_T',/extract,/regex))[0] + std_file1_U = file_basename(std_file1_U,'.nc') + std_file1_U = (strsplit(std_file1_U,'_grid_U',/extract,/regex))[0] + std_file2_U = file_basename(std_file2_U,'.nc') + std_file2_U = (strsplit(std_file2_U,'_grid_U',/extract,/regex))[0] + std_file1_V = file_basename(std_file1_V,'.nc') + std_file1_V = (strsplit(std_file1_V,'_grid_V',/extract,/regex))[0] + std_file2_V = file_basename(std_file2_V,'.nc') + std_file2_V = (strsplit(std_file2_V,'_grid_V',/extract,/regex))[0] + std_file1_I = file_basename(std_file1_I,'.nc') + std_file1_I = (strsplit(std_file1_I,'_icemod',/extract,/regex))[0] + std_file2_I = file_basename(std_file2_I,'.nc') + std_file2_I = (strsplit(std_file2_I,'_icemod',/extract,/regex))[0] + +;######################################################################### +;###################### STANDARD PLOTS ################################ +;######################################################################### + + IF keyword_set(doplot) EQ 0 THEN doplot = 0 + +; fixed color tabled + lct, 64 + cnt = 0 + htmltxt = '' +; + cnt = cnt+1 & blabla = 'Erp salinity damping term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_erp, ERP1, ERP2, _extra = ex +; + cnt = cnt+1 & blabla = 'Evaporation - Precipitation - Runoff term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_emp, EMP1, EMP2, _extra = ex +; + cnt = cnt+1 & blabla = 'Net heat flux' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_qnet, Q1, Q2, QNET, _extra = ex +; + cnt = cnt+1 & blabla = 'Meridionnal Heat Transport' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mht, Q1.arr+geo, Q2.arr+geo, masknp, std_file_msksub, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Barotropic stream Function' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_bsf, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with New Reynolds' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sst, T1, T2, TRey, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sss, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2 at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_T100m, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_S100m, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD1, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth differences' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD1, MLD2, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Mixed layer depth' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ZonMld, MLD1, MLD2, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Vertical Global mean T & S' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_GlobMeanTS, T1, T2, TLev, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Global (no Med)' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'GloNoMed', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Atl', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Ind', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indo-Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'IndoPac', _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Temperature' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqT, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Salinity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqS, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial zonal velocity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqU, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=700' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 700, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=1000' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 1000, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=40N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 40, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=38N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 38, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: JAN' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_jan_1, Ithi_jan_2, /ARC, /JAN, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, /ARC, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, /ANT, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_sept_1, Ithi_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Age: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_march_1, Iage_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_febr_1, Iage_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_march_1, Isnow_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_febr_1, Isnow_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_march_1, Isal_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: FEBRUARY' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_febr_1, Isal_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, /ANT, /SEPT, _extra = ex +; + + IF n_elements(htmltxt) GT 1 THEN putfile, psdir+'std_plot_html_body.txt', htmltxt[1:*] + + return +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_last_year_5D.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_last_year_5D.pro new file mode 100644 index 0000000000000000000000000000000000000000..0049084ecd6f67e9c863a942f0c0ca1230386591 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_all_last_year_5D.pro @@ -0,0 +1,531 @@ +pro std_plot_all_last_year_5D, doplot = doplot, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + ; scripts for nemo v3_2 and v3_3 + +;; script for max MLD, output 5 days + + PRINT, '' + PRINT, ' ############################################' + PRINT, '' + PRINT, ' LAUNCH of std_plots_last_year_5D' + PRINT, '' + PRINT, ' ############################################' + PRINT, '' +; + std_iodir_data = isadirectory(getenv('DIR_DATA'), title = 'path of data in NetCdf format') + std_iodir_climato = isadirectory(getenv('DIR_CLIMATO'), title = 'path of climatological data') + std_iodir_mask = isadirectory(getenv('DIR_MASK'), title = 'path of mask files (ex: subbasins)') +; meshmask + std_file_mesh = isafile(getenv('FILE_MESH_MASK'), title = 'mesh_mask', iodir = std_iodir_mask) + std_file_msksub = isafile(getenv('FILE_MASK_SUBDOMAIN'), title = 'sub-bassin masks', iodir = std_iodir_mask) + +; climatologies + std_file_Levitus_T = isafile(getenv('FILE_TEMP_3D'), title = 'Levitus_T', iodir = std_iodir_climato) + std_file_Levitus_S = isafile(getenv('FILE_SAL_3D'), title = 'Levitus_S', iodir = std_iodir_climato) + std_file_reynolds = isafile(getenv('FILE_SST'), title = 'Reynolds', iodir = std_iodir_climato) + std_file_oaflux = isafile(getenv('FILE_FLUX'), title = 'oaflux', iodir = std_iodir_climato) + std_file_mld = isafile(getenv('FILE_MLD'), title = 'Mixed layer depth', iodir = std_iodir_climato) + std_file_ice = isafile(getenv('FILE_ICE'), title = 'ICE', iodir = std_iodir_climato) + std_file_snow_arc = isafile(getenv('FILE_SNOW_ARC'), title = 'SNOW_ARC', iodir = std_iodir_climato) + std_file_snow_ant = isafile(getenv('FILE_SNOW_ANT'), title = 'SNOW_ANT', iodir = std_iodir_climato) + + IF strlowcase(getenv('FILE_GEOHEAT')) EQ 'no' THEN std_file_geoheat = 'no' $ + ELSE std_file_geoheat = isafile(getenv('FILE_GEOHEAT'), title = 'Geothermal heating', iodir = std_iodir_climato) +; + allrec = 1 - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) +; Output run experience1 + std_file1_T = isafile(getenv('FILE1_T'), title = 'exp1 grid T input file', iodir = std_iodir_data) + std_file1_U = isafile(getenv('FILE1_U'), title = 'exp1 grid U input file', iodir = std_iodir_data) + std_file1_V = isafile(getenv('FILE1_V'), title = 'exp1 grid V input file', iodir = std_iodir_data) + std_file1_I = isafile(getenv('FILE1_I'), title = 'exp1 ice input file', iodir = std_iodir_data) + +; Output run experience2 + std_file2_T = isafile(getenv('FILE2_T'), title = 'exp2 grid T input file', iodir = std_iodir_data) + std_file2_U = isafile(getenv('FILE2_U'), title = 'exp2 grid U input file', iodir = std_iodir_data) + std_file2_V = isafile(getenv('FILE2_V'), title = 'exp2 grid V input file', iodir = std_iodir_data) + std_file2_I = isafile(getenv('FILE2_I'), title = 'exp2 ice input file', iodir = std_iodir_data) + + PRINT, '' + PRINT, ' std_iodir_data : ' + std_iodir_data + PRINT, ' std_file1T : ' + std_file1_T + PRINT, ' std_file1U : ' + std_file1_U + PRINT, ' std_file1V : ' + std_file1_V +; PRINT, ' std_file1W : ' + std_file1_W + PRINT, ' std_file2I : ' + std_file1_I + PRINT, ' std_file2T : ' + std_file2_T + PRINT, ' std_file2U : ' + std_file2_U + PRINT, ' std_file2V : ' + std_file2_V +; PRINT, ' std_file2W : ' + std_file2_W + PRINT, ' std_file2I : ' + std_file2_I + PRINT, '' + +;######################################################################### +;########################## Load Grids ################################ +;######################################################################### +; load the grid + load_orca, std_file_mesh +; reading variables + masknp = read_ncdf('tmaskutil', file = std_file_mesh, /nostruct, /cont_nofill) +;######################################################################### +;############################ Read Data ################################ +;######################################################################### +; + allrec = 1; - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) +; +;;; 3D ;;; +; temperature + T1 = read_ncdf(getenv('VAR1_T'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + T2 = read_ncdf(getenv('VAR2_T'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE T2 = {arr:-1} + TLev = read_ncdf(getenv('VAR_TEMP_3D'), filename = std_file_Levitus_T ) + TRey = read_ncdf(getenv('VAR_SST'), filename = std_file_reynolds ) + +; salinity + S1 = read_ncdf(getenv('VAR1_S'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + S2 = read_ncdf(getenv('VAR2_S'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE S2 = {arr:-1} + SLev = read_ncdf(getenv('VAR_SAL_3D'), filename = std_file_Levitus_S ) + +;;; 2D ;;; +; Net Downward heat flux + Q1 = read_ncdf(getenv('VAR1_QNET'), allrecords = allrec, direc = 't', filename = std_file1_T ) + IF std_file2_T NE std_file1_T THEN BEGIN + Q2 = read_ncdf(getenv('VAR2_QNET'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ENDIF ELSE Q2 = {arr:-1} +; Geothermal heating + IF std_file_geoheat EQ 'no' THEN geo = {arr:float(getenv('VAR_GEOHEAT'))} $ + ELSE geo = read_ncdf(getenv('VAR_GEOHEAT'), filename = std_file_geoheat ) + geo = geo.arr*1.e-3 ; convert into W/m2 +;climatology + QNET = read_ncdf(getenv('VAR_FLUX'), filename = std_file_oaflux ) + +; erp (evaporation damping) + ERP1 = read_ncdf(getenv('VAR1_ERP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + ERP1 = {arr:ERP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + ERP2 = read_ncdf(getenv('VAR2_ERP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + ERP2 = {arr:ERP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE ERP2 = {arr:-1} + +; emp (evaporation minus precipitation) + EMP1 = read_ncdf(getenv('VAR1_EMP'), allrecords = allrec, direc = 't', filename = std_file1_T ) + EMP1 = {arr:EMP1.arr * 86400., unit:'mm/day', grid:'T'} + IF std_file2_T NE std_file1_T THEN BEGIN + EMP2 = read_ncdf(getenv('VAR2_EMP'), allrecords = allrec, direc = 't', filename = std_file2_T ) + EMP2 = {arr:EMP2.arr * 86400., unit:'mm/day', grid:'T'} + ENDIF ELSE EMP2 = {arr:-1} + + ;mixed layer depth + ;; nyear=jpt/73 + MLD_1 = read_ncdf(getenv('VAR1_MLD'), allrecords = allrec, filename = std_file1_T ) + caldat, time, mm + march = where(mm EQ 3, cnt) + MLD_march_1 = max(MLD_1.arr[*,*,march], dim=3) + MLD_march_1 = {arr: MLD_march_1, unit: MLD_1.unit} + sept = where(mm EQ 9, cnt) + MLD_sept_1 = max(MLD_1.arr[*,*,sept], dim=3) + MLD_sept_1 = {arr: MLD_sept_1, unit: MLD_1.unit} + MLD_1 = {arr: max(MLD_1.arr[*,*,*], dim=3), unit: MLD_1.unit} + IF std_file2_T NE std_file1_T THEN BEGIN + MLD_2 = read_ncdf(getenv('VAR2_MLD'), allrecords = allrec, filename = std_file2_T ) ; 10 m + caldat, time, mm + march = where(mm EQ 3, cnt) + MLD_march_2 = max(MLD_2.arr[*,*,march], dim=3) + MLD_march_2 = {arr: MLD_march_2, unit: MLD_2.unit} + sept = where(mm EQ 9, cnt) + MLD_sept_2 = max(MLD_2.arr[*,*,sept], dim=3) + MLD_sept_2 = {arr:MLD_sept_2, unit: MLD_2.unit} + MLD_2 = {arr: max(MLD_2.arr[*,*,*], dim=3), unit: MLD_2.unit} + ENDIF ELSE BEGIN + MLD_2 = {arr:-1} + MLD_march_2 = {arr:-1} + MLD_sept_2 = {arr:-1} + ENDELSE + + ;climatology + MLD = read_ncdf(getenv('VAR_MLD'), filename = std_file_mld ) +; if monthly climatology +; MLD = {arr: max(MLD.arr[*,*,*], dim=3), unit: MLD.unit} + +; velocities + U1 = read_ncdf(getenv('VAR1_U'), allrecords = allrec, direc = 't', filename = std_file1_U ) + IF strlowcase(getenv('VAR1_U')) EQ 'uocetr_eff' THEN BEGIN + U1.arr = U1.arr / e3u_3d(/e2) * umask() + U1.unit = 'm/s' + ENDIF + IF std_file2_U NE std_file1_U THEN BEGIN + U2 = read_ncdf(getenv('VAR2_U'), allrecords = allrec, direc = 't', filename = std_file2_U ) + IF strlowcase(getenv('VAR2_U')) EQ 'uocetr_eff' THEN BEGIN + U2.arr = U2.arr / e3u_3d(/e2) * umask() + U2.unit = 'm/s' + ENDIF + ENDIF ELSE U2 = {arr:-1} +; + V1 = read_ncdf(getenv('VAR1_V'), allrecords = allrec, direc = 't', filename = std_file1_V ) + IF strlowcase(getenv('VAR1_V')) EQ 'vocetr_eff' THEN BEGIN + V1.arr = V1.arr / e3v_3d(/e1) * vmask() + V1.unit = 'm/s' + ENDIF + IF std_file2_V NE std_file1_V THEN BEGIN + V2 = read_ncdf(getenv('VAR2_V'), allrecords = allrec, direc = 't', filename = std_file2_V ) + IF strlowcase(getenv('VAR2_V')) EQ 'vocetr_eff' THEN BEGIN + V2.arr = V2.arr / e3v_3d(/e1) * vmask() + V2.unit = 'm/s' + ENDIF + ENDIF ELSE V2 = {arr:-1} + +; ice + Ithi_1 = read_ncdf(getenv('VAR1_Ithick'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + jan = where(mm EQ 1, cnt) + sept = where(mm EQ 9, cnt) + Ithi_jan_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + Ithi_sept_1 = {arr:1./float(cnt) * total(reform(Ithi_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_1.unit} + undefine, Ithi_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ithi_2 = read_ncdf(getenv('VAR2_Ithick'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + april = where(mm EQ 4, cnt) + Ithi_april_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(april)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + jan = where(mm EQ 1, cnt) + sept = where(mm EQ 9, cnt) + Ithi_sept_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + Ithi_jan_2 = {arr:1./float(cnt) * total(reform(Ithi_2.arr[*, *, temporary(jan)],nxt,nyt,cnt), 3), unit:Ithi_2.unit} + undefine, Ithi_2 + ENDIF ELSE BEGIN + Ithi_april_2 = {arr:-1} + Ithi_sept_2 = {arr:-1} + Ithi_jan_2 = {arr:-1} + ENDELSE +; + Iage_1 = read_ncdf(getenv('VAR1_Iage'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + march = where(mm EQ 3, cnt) + Iage_march_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_1 = {arr:1./float(cnt) * total(reform(Iage_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_1.unit} + undefine, Iage_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Iage_2 = read_ncdf(getenv('VAR2_Iage'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Iage_febr_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + march = where(mm EQ 3, cnt) + Iage_march_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + sept = where(mm EQ 9, cnt) + Iage_sept_2 = {arr:1./float(cnt) * total(reform(Iage_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Iage_2.unit} + undefine, Iage_2 + ENDIF ELSE BEGIN + Iage_febr_2 = {arr:-1} + Iage_march_2 = {arr:-1} + Iage_sept_2 = {arr:-1} + ENDELSE +; + Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Ifra_febr_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + march = where(mm EQ 3, cnt) + Ifra_march_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_1 = {arr:1./float(cnt) * total(reform(Ifra_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_1.unit} + undefine, Ifra_1 +; + IF std_file2_I NE std_file1_I THEN BEGIN + Ifra_2 = read_ncdf(getenv('VAR2_Ifrac'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Ifra_febr_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + march = where(mm EQ 3, cnt) + Ifra_march_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + sept = where(mm EQ 9, cnt) + Ifra_sept_2 = {arr:1./float(cnt) * total(reform(Ifra_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Ifra_2.unit} + undefine, Ifra_2 + ENDIF ELSE BEGIN + Ifra_febr_2 = {arr:-1} + Ifra_march_2 = {arr:-1} + Ifra_sept_2 = {arr:-1} + ENDELSE +; + Isnow_1 = read_ncdf(getenv('VAR1_Isnow'), allrecords = allrec, filename = std_file1_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + march = where(mm EQ 3, cnt) + Isnow_march_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_1 = {arr:1./float(cnt) * total(reform(Isnow_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_1.unit} + ;undefine, Isnow_1 + ; + IF std_file2_I NE std_file1_I THEN BEGIN + Isnow_2 = read_ncdf(getenv('VAR2_Isnow'), allrecords = allrec, filename = std_file2_I ) + caldat, time, mm + febr = where(mm EQ 2, cnt) + Isnow_febr_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + march = where(mm EQ 3, cnt) + Isnow_march_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + sept = where(mm EQ 9, cnt) + Isnow_sept_2 = {arr:1./float(cnt) * total(reform(Isnow_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isnow_2.unit} + ; undefine, Isnow_2 + ENDIF ELSE BEGIN + Isnow_febr_2 = {arr:-1} + Isnow_march_2 = {arr:-1} + Isnow_sept_2 = {arr:-1} + ENDELSE +; + Isal_1 = read_ncdf(getenv('VAR1_Isal'), allrecords = allrec, filename = std_file1_I ) + Ifra_1 = read_ncdf(getenv('VAR1_Ifrac'), allrecords = allrec, filename = std_file1_I ) + msk = Ifra_1.arr gt 0.15 ; remove 0.15% for observations + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + ;SF Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + Isal_1.arr = Isal_1.arr * msk + Isal_march_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + Isal_febr_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_1 = {arr:1./float(cnt) * total(reform(Isal_1.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_1.unit} + ;undefine, Isal_1 + ; + Isal_2 = read_ncdf(getenv('VAR2_Isal'), allrecords = allrec, filename = std_file2_I ) + Ifra_2 = read_ncdf(getenv('VAR2_Ifrac'), allrecords = allrec, filename = std_file2_I ) + msk = Ifra_2.arr gt 0.15 ; remove 0.15% for observations + IF std_file2_I NE std_file1_I THEN BEGIN + Isal_2 = read_ncdf(getenv('VAR2_Isal'), allrecords = allrec, filename = std_file2_I ) + Isal_2.arr = Isal_2.arr * msk + caldat, time, mm + march = where(mm EQ 3, cnt) + febr = where(mm EQ 2, cnt) + Isal_march_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(march)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + Isal_febr_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(febr)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + sept = where(mm EQ 9, cnt) + Isal_sept_2 = {arr:1./float(cnt) * total(reform(Isal_2.arr[*, *, temporary(sept)],nxt,nyt,cnt), 3), unit:Isal_2.unit} + ; undefine, Isal_2 + ENDIF ELSE BEGIN + Isal_febr_2 = {arr:-1} + Isal_march_2 = {arr:-1} + Isal_sept_2 = {arr:-1} + ENDELSE +; + jpt = 1 +; +; shorter file names for legends... +; + std_file1_T = file_basename(std_file1_T,'.nc') + std_file1_T = (strsplit(std_file1_T,'_grid_T',/extract,/regex))[0] + std_file2_T = file_basename(std_file2_T,'.nc') + std_file2_T = (strsplit(std_file2_T,'_grid_T',/extract,/regex))[0] + std_file1_U = file_basename(std_file1_U,'.nc') + std_file1_U = (strsplit(std_file1_U,'_grid_U',/extract,/regex))[0] + std_file2_U = file_basename(std_file2_U,'.nc') + std_file2_U = (strsplit(std_file2_U,'_grid_U',/extract,/regex))[0] + std_file1_V = file_basename(std_file1_V,'.nc') + std_file1_V = (strsplit(std_file1_V,'_grid_V',/extract,/regex))[0] + std_file2_V = file_basename(std_file2_V,'.nc') + std_file2_V = (strsplit(std_file2_V,'_grid_V',/extract,/regex))[0] + std_file1_I = file_basename(std_file1_I,'.nc') + std_file1_I = (strsplit(std_file1_I,'_icemod',/extract,/regex))[0] + std_file2_I = file_basename(std_file2_I,'.nc') + std_file2_I = (strsplit(std_file2_I,'_icemod',/extract,/regex))[0] + +;######################################################################### +;###################### STANDARD PLOTS ################################ +;######################################################################### + + IF keyword_set(doplot) EQ 0 THEN doplot = 0 + +; fixed color tabled + lct, 64 + cnt = 0 + htmltxt = '' +; + cnt = cnt+1 & blabla = 'Erp salinity damping term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_erp, ERP1, ERP2, _extra = ex +; + cnt = cnt+1 & blabla = 'Evaporation - Precipitation - Runoff term' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_emp, EMP1, EMP2, _extra = ex +; + cnt = cnt+1 & blabla = 'Net heat flux' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_qnet, Q1, Q2, QNET, _extra = ex +; + cnt = cnt+1 & blabla = 'Meridionnal Heat Transport' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mht, Q1.arr+geo, Q2.arr+geo, masknp, std_file_msksub, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Barotropic stream Function' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_bsf, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with New Reynolds' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sst, T1, T2, TRey, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_sss, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic mean Salinity diff with Levitus and exp2 at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ArcSal, S1, S2, SLev, /z100, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Temperature diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_T100m, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'mean Salinity diff with Levitus at z=100 meters' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_S100m, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD1, MLD, _extra = ex +; + cnt = cnt+1 & blabla = 'Mixed layer depth differences' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_mld, MLD_1, MLD_2, MLD, _extra = ex + + ;SF: add 2 cases for max of Mixed Layer depth on march & septembre + cnt = cnt+1 & blabla = 'Mixed layer depth on March' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_max_mld, MLD_march_1, MLD_march_2, /MARCH, _extra = ex + + cnt = cnt+1 & blabla = 'Mixed layer depth on September' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_max_mld, MLD_sept_1, MLD_sept_2, /SEPT, _extra = ex + +;; SF: commented because not ok for max MLD, output 5 days +;; cnt = cnt+1 & blabla = 'Zonal mean Mixed layer depth' +;; IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_ZonMld, MLD_1, MLD_2, MLD, _extra = ex + + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Temperature diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_T, T1, T2, TLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Global' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Atl', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Ind', _extra = ex +; + cnt = cnt+1 & blabla = 'Zonal mean Salinity diff with Levitus: Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_zonal_S, S1, S2, SLev, SUBBASIN = 'Pac', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Global (no Med)' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'GloNoMed', _extra = ex +; + cnt = cnt+1 & blabla = 'Meridional stream Function: Atlantic' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Atl', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indian' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'Ind', _extra = ex + ; + cnt = cnt+1 & blabla = 'Meridional stream Function: Indo-Pacific' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_msf, V1, V2, SUBBASIN = 'IndoPac', _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Temperature' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqT, T1, T2, Tlev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial Salinity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqS, S1, S2, SLev, _extra = ex +; + cnt = cnt+1 & blabla = 'Equatorial zonal velocity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_EqU, U1, U2, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=700' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 700, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean salt tongue at depth=1000' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sspread, S1, S2, SLev, 1000, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=40N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 40, _extra = ex +; + cnt = cnt+1 & blabla = 'Mediterranean water at lat=38N' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_Med_Sdepth, S1, S2, SLev, 38, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: JAN' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_jan_1, Ithi_jan_2, /ARC, /JAN, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, /ARC, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: APRIL' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_april_1, Ithi_april_2, /ANT, /APRIL, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceThick, Ithi_sept_1, Ithi_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Age: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_march_1, Iage_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_febr_1, Iage_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Age: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceAge, Iage_sept_1, Iage_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_march_1, Ifra_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_febr_1, Ifra_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Fraction: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceFrac, Ifra_sept_1, Ifra_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_march_1, Isnow_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_febr_1, Isnow_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic SNOW Thickness: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_SnowThick, Isnow_sept_1, Isnow_sept_2, /ANT, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: MARCH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_march_1, Isal_march_2, /ARC, /MARCH, _extra = ex +; + cnt = cnt+1 & blabla = 'Arctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, /ARC, /SEPT, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: FEBRUARY' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_febr_1, Isal_febr_2, /ANT, /FEBR, _extra = ex +; + cnt = cnt+1 & blabla = 'Antarctic Ice Salinity: SEPT' + IF doplot EQ cnt OR doplot EQ 0 THEN std_plot_IceSal, Isal_sept_1, Isal_sept_2, /ANT, /SEPT, _extra = ex +; + + IF n_elements(htmltxt) GT 1 THEN putfile, psdir+'std_plot_html_body.txt', htmltxt[1:*] + + return +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_bsf.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_bsf.pro new file mode 100644 index 0000000000000000000000000000000000000000..c8be2525c640d4a529221a1a9b090c0920f0773e --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_bsf.pro @@ -0,0 +1,40 @@ +pro std_plot_bsf, U1, U2, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_BSF_'+std_file1_U + if std_file1_U NE std_file2_U then filename = filename + '_'+std_file2_U + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + domdef, 0, 6000 + + ;formulation for variable: TRANSPORT + ;bb1 = bsf(U1.arr, refvalue = 0., refpoint = [25, 0], /transport ) + ; + ;formulation for variable: VELOCITY + bb1 = bsf(U1.arr, refvalue = 0., refpoint = [25, 0]) + title = 'Barotropic Stream Function!C'+std_file1_U + plt, bb1, min = -200., max = 200., int = 10., /portrait, FORMAT = '(I4)', STYLE = 'so0so' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, _extra = ex + + if std_file1_U NE std_file2_U then BEGIN + ;formulation for variable: TRANSPORT + ;bb2 = bsf(U2.arr, refvalue = 0., refpoint = [25, 0], /transport ) + ;formulation for variable: VELOCITY + bb2 = bsf(U2.arr, refvalue = 0., refpoint = [25, 0] ) + title = 'Barotropic Stream Function!C'+std_file1_U+' - '+std_file2_U + plt, bb1.arr - bb2.arr, min = -20., max = 20., int = 2., FORMAT = '(I2)', STYLE = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /NOERASE, _extra = ex + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_emp.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_emp.pro new file mode 100644 index 0000000000000000000000000000000000000000..5cb62cb5e9dfbb799f5531f11f0537b4cc6bea7f --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_emp.pro @@ -0,0 +1,29 @@ +pro std_plot_emp, EMP1, EMP2, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_Emp_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Emp!C'+std_file1_T + plt, EMP1, MIN = -10., MAX = 10., INTER = 1., style = 'so0so' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, format = '(i3)', /PORTRAIT, _extra = ex + + if std_file1_T NE std_file2_T then begin + title = title+' - '+std_file2_T + plt, EMP1.arr - EMP2.arr, MIN = -5., MAX = 5., INTER = 1., style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, format = '(i3)', /NOERASE, _extra = ex + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_erp.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_erp.pro new file mode 100644 index 0000000000000000000000000000000000000000..bb325d0b63e324f0e6ba93ef0d1832809ded1dde --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_erp.pro @@ -0,0 +1,29 @@ +pro std_plot_erp, ERP1, ERP2, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_Erp_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Erp!C'+std_file1_T + plt, ERP1, MIN = -5., MAX = 5., INTER = .5, style = 'so0so' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /PORTRAIT, format = '(i2)', _extra = ex + + if std_file1_T NE std_file2_T then begin + title = title+' - '+std_file2_T + plt, ERP1.arr - ERP2.arr, MIN = -2., MAX = 2., INTER = .25, style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, format = '(f4.1)', /NOERASE, _extra = ex + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_max_mld.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_max_mld.pro new file mode 100644 index 0000000000000000000000000000000000000000..6e10c56baee6676d7eedf57882fd0e96375f9b9d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_max_mld.pro @@ -0,0 +1,70 @@ +pro std_plot_max_mld, MLD1, MLD2, MARCH = march, SEPT = sept, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + + var = 'max_MLD' + IF keyword_set(march) THEN var = var+'_March' + IF keyword_set(sept) THEN var = var+'_Sept' + + filename = cdti3 + '_'+var+'_'+std_file1_T + IF std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + IF KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + varunit = MLD1.unit + titleorg = var+'!C' +; +;; IF MLD2.arr[0] NE -1 THEN BEGIN +;; title = titleorg+std_file1_T+ ' - '+std_file2_T +;; plt, MLD1.arr - MLD2.arr, MIN = -80., MAX = 80., INTER = 10., FORMAT = '(I3)' $ +;; , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /PORTRAIT, _extra = ex +;; ENDIF ELSE BEGIN +;; title = titleorg+std_file1_T +;; plt, MLD1,label=4, cb_label=[0, 15, 25, 50, 75, 100, 125, 150, 250, 400, 600, 850],/NOCONTOUR,FORMAT = '(I3)' $ +;; , small = [1, 2, 1],COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex +;; ; +;; ;ORI SF plt, MLD1, MIN = 0., MAX = 500., INTER = 25., /NOCONTOUR, FORMAT = '(I3)' $ +;; ;ORI SF , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex +;; ; +;; ENDELSE +; + + IF MLD2.arr[0] NE -1 THEN BEGIN + title = titleorg+ std_file2_T + ; plt, MLD2.arr, MIN = 0., MAX = 800., INTER = 50., FORMAT = '(I3)' $ + plt, MLD2.arr, label=4, cb_label=[0, 15, 25, 50, 75, 100, 125, 150, 250, 400, 600, 850],FORMAT = '(I3)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /PORTRAIT, _extra = ex + ; + title = titleorg+std_file1_T+ ' - '+std_file2_T + plt, MLD1.arr - MLD2.arr, MIN = -80., MAX = 80., INTER = 10., FORMAT = '(I3)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /PORTRAIT, _extra = ex + ENDIF ELSE BEGIN + title = titleorg+std_file1_T + plt, MLD1,label=4, cb_label=[0, 15, 25, 50, 75, 100, 125, 150, 250, 400, 600, 850],/NOCONTOUR,FORMAT = '(I3)' $ + , small = [1, 2, 1],COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex + ENDELSE + + + +;; IF MLD2.arr[0] NE -1 THEN BEGIN +;; title = titleorg+std_file2_T+ ' - DeBoyer' +;; tmp = MLD2.arr - MLD.arr +;; ENDIF ELSE BEGIN +;; title = titleorg+std_file1_T+ ' - DeBoyer' +;; tmp = MLD1.arr - MLD.arr +;; ENDELSE +;; plt, temporary(tmp), MIN = -80., MAX = 80., INTER = 10., FORMAT = '(I3)' $ +;; , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /NOERASE, _extra = ex +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps +; + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mht.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mht.pro new file mode 100644 index 0000000000000000000000000000000000000000..2f31dfe0791fd57db8ecaa4255b4f52c88df76c3 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mht.pro @@ -0,0 +1,89 @@ +PRO std_plot_domht, Q, masknp, mask_filename, ibce, htr, htr_atl + + compile_opt idl2, strictarrsubs + +@common + + Qave = moyenne(Q, 'xy', mask2d = masknp) ; mean value + Qnet = Q - Qave + ibce = STRTRIM(Qave, 1) +; + msk = read_ncdf('atlmsk_nomed', filename = mask_filename, /nostruct) + msk = msk[*]#replicate(1., nzt) ; from 2D array to 3D array + +; *1.E-15 to have PetaWatt + Qx = moyenne(Qnet*e2t , 'x', mask2d = masknp, /integration)*1.E-15 + Qx_atl = moyenne(Qnet*e2t*msk, 'x', mask2d = masknp, /integration)*1.E-15 +; northward heat flux transport from antartic + htr = total(Qx, /cumulative) + htr_atl = total(reverse(Qx_atl), /cumulative) ; ! from north to south + htr_atl = -reverse(htr_atl) +; we take from values north till 30 South + htr_atl[where(gphit[0, *] lt -30.)] = !Values.F_NaN + +return +END + +pro std_plot_mht, Q1, Q2, masknp, mask_filename, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_MHT_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + +; find the x index with the highest latitude (for the plot) + index = where(gphit eq max(gphit)) + nx = index[0] mod jpi + gphi_save = gphit + gphit[0, *] = gphit[nx, *] +; compute meridional heat transport + std_plot_domht, Q1, masknp, mask_filename, ibce1, htr1, htr1_atl + +; update data informations + varname = 'MHT' + varunit = 'Pw' + vargrid = 'T' + + title = 'MHT (Black) & Atlantic MHT (Blue)!C'+std_file1_T + subtitle = '(Qnet='+ibce1+' W/m2)' + plt1d, htr1, 'y', min = -2., max = 2.5, TITLE = title, SUBTITLE = subtitle, /portrait $ + , SMALL = [2-(std_file1_T EQ std_file2_T), 2, 1], YTITLE = 'PW', XGRIDSTYLE = 2, TICKLEN = 1, YGRIDSTYLE = 2, _extra = ex + plt1d, htr1_atl, 'y', COLOR = 50, /ov1d, _extra = ex + + if std_file1_T NE std_file2_T then begin +; compute meridional heat transport + std_plot_domht, Q2, masknp, mask_filename, ibce2, htr2, htr2_atl + + title = 'MHT (Black) & Atlantic MHT (Blue)!C'+std_file2_T + subtitle = '(Qnet='+ibce2+' W/m2)' + plt1d, htr2, 'y', min = -2., max = 2.5, TITLE = title, SUBTITLE = subtitle, /noerase $ + , SMALL = [2, 2, 2], YTITLE = 'PW', XGRIDSTYLE = 2, TICKLEN = 1, YGRIDSTYLE = 2, _extra = ex + plt1d, htr2_atl, 'y', COLOR = 50, /ov1d, _extra = ex + + title = 'MHT (Black) & Atlantic MHT (Blue) '+std_file1_T+' !C (Red) '+std_file2_T + plt1d, htr1, 'y', min = -2., max = 2., TITLE = title $ + , SMALL = [2, 2, 3], TICKLEN = 1, XGRIDSTYLE = 2 $ + , YTITLE = 'PW', YGRIDSTYLE = 2, /NOERASE, _extra = ex + plt1d, htr2, 'y', COLOR = 250, /ov1d, _extra = ex + plt1d, htr1_atl, 'y', COLOR = 50, /ov1d, _extra = ex + plt1d, htr2_atl, 'y', COLOR = 250, /ov1d, _extra = ex + ;plt1d, (htr1-htr2)*1.e3, 'y', min = -250., max = 250., TITLE = title $ + ; , SMALL = [2, 2, 3], TICKLEN = 1, XGRIDSTYLE = 2 $ + ; , YTITLE = 'TW', YGRIDSTYLE = 2, /NOERASE, _extra = ex + ;plt1d, (htr1_atl - htr2_atl)*1.e3, 'y', COLOR = 50, /ov1d, _extra = ex + + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + gphit = gphi_save + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mld.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mld.pro new file mode 100644 index 0000000000000000000000000000000000000000..1ea4bbdaca22af5ed57daed985cc33383999c894 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_mld.pro @@ -0,0 +1,55 @@ +pro std_plot_mld, MLD1, MLD2in, MLDin, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + CASE n_params() OF + 2:BEGIN + MLD = MLD2in + END + 3:BEGIN + IF MLD2in.arr[0] EQ -1 THEN return + MLD2 = MLD2in + MLD = MLDin + END + ENDCASE +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_MLD_'+std_file1_T + IF keyword_set(MLD2) THEN filename = filename + '_' + std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + varunit = MLD1.unit + titleorg = 'MLD!C' +; + IF keyword_set(MLD2) THEN BEGIN + title = titleorg+std_file1_T+ ' - '+std_file2_T + plt, MLD1.arr - MLD2.arr, MIN = -80., MAX = 80., INTER = 10., FORMAT = '(I3)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /PORTRAIT, _extra = ex + ENDIF ELSE BEGIN + title = titleorg+std_file1_T + plt, MLD1,label=4, cb_label=[0, 15, 25, 50, 75, 100, 125, 150, 250, 400, 600, 850],/NOCONTOUR,FORMAT = '(I3)' $ + , small = [1, 2, 1],COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex +;ORI SF plt, MLD1, MIN = 0., MAX = 500., INTER = 25., /NOCONTOUR, FORMAT = '(I3)' $ +;ORI SF , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex + ENDELSE +; + IF keyword_set(MLD2) THEN BEGIN + title = titleorg+std_file2_T+ ' - DeBoyer' + tmp = MLD2.arr - MLD.arr + ENDIF ELSE BEGIN + title = titleorg+std_file1_T+ ' - DeBoyer' + tmp = MLD1.arr - MLD.arr + ENDELSE + plt, temporary(tmp), MIN = -80., MAX = 80., INTER = 10., FORMAT = '(I3)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /NOCONTOUR, /NOERASE, _extra = ex +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps +; + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_msf.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_msf.pro new file mode 100644 index 0000000000000000000000000000000000000000..ffdf583a4a051dc402914b5d608a2fc4a5b412ea --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_msf.pro @@ -0,0 +1,60 @@ +pro std_plot_msf, V1, V2, SUBBASIN = subbasin, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + if KEYWORD_SET(SUBBASIN) then subname = subbasin else subname = "Glo" + filename = cdti3 + '_MSF_'+subname+'_'+std_file1_V + if std_file1_V NE std_file2_V then filename = filename + '_'+std_file2_V + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + if KEYWORD_SET(SUBBASIN) then begin + CASE subname of + 'Atl' : var = 'atlmsk_nomed' + 'Ind' : var = 'indmsk' + 'IndoPac' : var = 'indpacmsk' + 'GloNoMed' : var = 'glomsk_nomed' + ENDCASE + msk = read_ncdf( var, filename = std_file_msksub, /nostruct, _extra = ex ) + endif else msk = tmask[*, *, 0] +; + CASE subname OF + 'GloNoMed':lat_ext = [-80, 90] + 'Glo':lat_ext = [-80, 90] + 'Atl':lat_ext = [-30, 90] + 'Ind':lat_ext = [-30, 30] + 'IndoPac':lat_ext = [-30, 70] + ENDCASE + + domdef, 0, 6000 + + ;formulation for variable: TRANSPORT + ;mm1 = msf(V1.arr, msk, indexboxzoom = ind, maskout = ma, /transport ) + ; + ;formulation for variable: VELOCITY + mm1 = msf(V1.arr, msk, indexboxzoom = ind, maskout = ma ) + title = 'Meridional Stream Function, '+subname+'!C'+std_file1_V + pltz, mm1, 'yz', -20., 20., int = 1., boxzoom = [ind[0:1], lat_ext, 0, 5500], /xindex, FORMAT = '(I3)', /portrait $ + , small = [1, 2, 1], COAST_THICK = 2, zoom = 5500, maskdta = ma, /no_partial, TITLE = title, style = 'so0so' + + if std_file1_V NE std_file2_V then begin + ;formulation for variable: TRANSPORT + ;mm2 = msf(V2.arr, msk, indexboxzoom = ind, maskout = ma, /transport ) + ; + ;formulation for variable: VELOCITY + mm2 = msf(V2.arr, msk, indexboxzoom = ind, maskout = ma) + title = title+' - '+std_file2_V + pltz, mm1.arr-mm2.arr, 'yz', -10., 10., int = 1., boxzoom = [ind[0:1], lat_ext, 0, 5500], /xindex, FORMAT = '(I3)' $ + , small = [1, 2, 2], COAST_THICK = 2, zoom = 5500, maskdta = ma, /no_partial, TITLE = title, /NOERASE, style = 'so0so' + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_qnet.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_qnet.pro new file mode 100644 index 0000000000000000000000000000000000000000..08d028f0d438a365afbbf52deedaa7fa073f6ef4 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_qnet.pro @@ -0,0 +1,34 @@ +pro std_plot_qnet, Q1, Q2, QNET, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_Qnet_'+std_file1_T + if std_file1_T EQ std_file2_T then filename = filename + '_OAFlux' $ + ELSE filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + title = 'Qnet!C'+std_file1_T + plt, Q1, MIN = -200., MAX = 200., INTER = 20., STYLE = 'so0so' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, FORMAT = '(I4)', /PORTRAIT, _extra = ex + + if std_file1_T EQ std_file2_T then begin + title = 'Qnet!C'+std_file1_T+' - OAFlux' + Q = Q1.arr - QNET.arr + ENDIF ELSE BEGIN + title = 'Qnet!C'+std_file1_T+' - '+std_file2_T + Q = Q1.arr - Q2.arr + ENDELSE + plt, Q, MIN = -100, MAX = 100, INTER = 10, STYLE = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, FORMAT = '(I4)', /NOERASE, _extra = ex + ; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sss.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sss.pro new file mode 100644 index 0000000000000000000000000000000000000000..80ae835dbebb180afcc2d7e92a59afa974d3d95c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sss.pro @@ -0,0 +1,34 @@ +pro std_plot_sss, S1, S2, SLev, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_SSS_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + varunit = S1.unit + + title = 'SSS!C'+std_file1_T + plt, S1.arr[*, *, 0], MIN = 33., MAX = 41., INTER = .25, format = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, /PORTRAIT, _extra = ex + ; + if std_file1_T NE std_file2_T then begin + title = 'SSS!C'+std_file1_T+' - '+std_file2_T + plt, S1.arr[*, *, 0] - S2.arr[*, *, 0], MIN = -2., MAX = 2., INTER = 0.2, STYLE = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /noerase, format = '(f4.1)', _extra = ex + endif else begin + title = 'SSS!C'+std_file1_T+' - Levitus' + plt, S1.arr[*, *, 0] - SLev.arr[*, *, 0], MIN = -3., MAX = 3., INTER = 0.2, STYLE = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /noerase, format = '(f4.1)', _extra = ex + endelse + ; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sst.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sst.pro new file mode 100644 index 0000000000000000000000000000000000000000..aa5fe7517177c3cad555b29e0f3034511bf9bc80 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_sst.pro @@ -0,0 +1,43 @@ +pro std_plot_sst, T1, T2, TRey, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_SST_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + if std_file1_T EQ std_file2_T then begin + T = T1.arr[*, *, 0] + min = -2. + max = 32. + inter = 1. + STYLE = 0 + title = 'SST!C'+std_file1_T + ENDIF ELSE BEGIN + T = T1.arr[*, *, 0] - T2.arr[*, *, 0] + min = -1. + max = -min + inter = 0.1 + STYLE = 'so0so' + title = 'SST!C'+std_file1_T+' - '+std_file2_T + ENDELSE +; + varunit = T1.unit +; + plt, T, MIN = min, MAX = max, INTER = inter, STYLE = STYLE $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, FORMAT = '(I2)', /PORTRAIT, _extra = ex +; + title = 'SST!C'+std_file1_T+' - NewReynolds' + plt, T1.arr[*, *, 0] - TRey.arr, MIN = -8., MAX = 8., INTER = 0.5, STYLE = 'so0so', FORMAT = '(I2)' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh new file mode 100644 index 0000000000000000000000000000000000000000..a040212785d3855d560addd98009d12307994314 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh @@ -0,0 +1,129 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/p4H25a50-testht_ps_plot +PDF_DIR=$( pwd )/p4H25a50-testht_pdf_plot +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=p4H25a50_20410101_20501231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=p4H25a50_20410101_20501231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=p4H25a50_20410101_20501231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=p4H25a50_20410101_20501231_1M_icemod.nc # exp1 ice input file +VAR1_T=thetao +VAR1_S=so +VAR1_QNET=qt +VAR1_ERP=wfcorr +VAR1_EMP=wfo +VAR1_MLD=mldr10_1 +VAR1_U=uocetr_eff +VAR1_V=vocetr_eff +VAR1_Ithick=sithic +VAR1_Ifrac=siconc +VAR1_Isnow=snvolu +VAR1_Isal=sisali +VAR1_Iage=siages +VAR1_IvelU=sivelu +VAR1_IvelV=sivelv +VAR1_Ivelo=sivelo +# +#===================== EXP2 ===================== +# +FILE2_T=testht_20410101_20501231_1Y_grid_T.nc # exp1 grid T input file +FILE2_U=testht_20410101_20501231_1Y_grid_U.nc # exp1 grid U input file +FILE2_V=testht_20410101_20501231_1Y_grid_V.nc # exp1 grid V input file +FILE2_I=testht_20410101_20501231_1M_icemod.nc # exp1 ice input file +VAR2_T=thetao +VAR2_S=so +VAR2_QNET=qt +VAR2_ERP=wfcorr +VAR2_EMP=wfo +VAR2_MLD=mldr10_1 +VAR2_U=uocetr_eff +VAR2_V=vocetr_eff +VAR2_Ithick=sithic +VAR2_Ifrac=siconc +VAR2_Isnow=snvolu +VAR2_Isal=sisali +VAR2_Iage=siages +VAR2_IvelU=sivelu +VAR2_IvelV=sivelv +VAR2_Ivelo=sivelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.last_year_5D b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.last_year_5D new file mode 100644 index 0000000000000000000000000000000000000000..ad4a61543739f35dff053cfb43017c2d25acb192 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.last_year_5D @@ -0,0 +1,129 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/l3fwb178-plot_lastyear_ps +PDF_DIR=$( pwd )/l3fwb178_plot_lastyear_pdf +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=~/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=~/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=~//idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=l3fwb178_25010101_25011231_5D_grid_T.nc # exp1 grid T input file +FILE1_U=l3fwb178_25010101_25011231_5D_grid_U.nc # exp1 grid U input file +FILE1_V=l3fwb178_25010101_25011231_5D_grid_V.nc # exp1 grid V input file +FILE1_I=l3fwb178_25010101_25011231_5D_icemod.nc # exp1 ice input file +VAR1_T=votemper +VAR1_S=vosaline +VAR1_QNET=sohflxdo +VAR1_ERP=sowafldp +VAR1_EMP=sowaflup +VAR1_MLD=max5dmld +VAR1_U=vozoeftr +VAR1_V=vomeeftr +VAR1_Ithick=iicethic +VAR1_Ifrac=iiceconc +VAR1_Isnow=isnowvol +VAR1_Isal=iicesali +VAR1_Iage=iiceages +VAR1_IvelU=iicevelu +VAR1_IvelV=iicevelv +VAR1_Ivelo=iicevelo +# +#===================== EXP2 ===================== +# +FILE2_T=l3fwb178_25010101_25011231_5D_grid_T.nc # exp1 grid T input file +FILE2_U=l3fwb178_25010101_25011231_5D_grid_U.nc # exp1 grid U input file +FILE2_V=l3fwb178_25010101_25011231_5D_grid_V.nc # exp1 grid V input file +FILE2_I=l3fwb178_25010101_25011231_5D_icemod.nc # exp1 ice input file +VAR2_T=votemper +VAR2_S=vosaline +VAR2_QNET=sohflxdo +VAR2_ERP=sowafldp +VAR2_EMP=sowaflup +VAR2_MLD=max5dmld +VAR2_U=vozoeftr +VAR2_V=vomeeftr +VAR2_Ithick=iicethic +VAR2_Ifrac=iiceconc +VAR2_Isnow=isnowthi +VAR2_Isal=iicesali +VAR2_Iage=iiceages +VAR2_IvelU=iicevelu +VAR2_IvelV=iicevelv +VAR2_Ivelo=iicevelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.new_names b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.new_names new file mode 100644 index 0000000000000000000000000000000000000000..f1e0dde0c1f1217492952399874cb27adf429028 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.new_names @@ -0,0 +1,129 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/sbcmodMV_ps_plot +PDF_DIR=$( pwd )/sbcmodMV_pdf_plot +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=sbcmodMV_20410101_20501231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=sbcmodMV_20410101_20501231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=sbcmodMV_20410101_20501231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=sbcmodMV_20410101_20501231_1M_icemod.nc # exp1 ice input file +VAR1_T=thetao +VAR1_S=so +VAR1_QNET=tohfls +VAR1_ERP=sowafldp +VAR1_EMP=wfo +VAR1_MLD=mldr10_1 +VAR1_U=uocetr_eff +VAR1_V=vocetr_eff +VAR1_Ithick=sithic +VAR1_Ifrac=siconc +VAR1_Isnow=snvolu +VAR1_Isal=sisali +VAR1_Iage=siages +VAR1_IvelU=sivelu +VAR1_IvelV=sivelv +VAR1_Ivelo=sivelo +# +#===================== EXP2 ===================== +# +FILE2_T=sbcmodMV_20410101_20501231_1Y_grid_T.nc # exp1 grid T input file +FILE2_U=sbcmodMV_20410101_20501231_1Y_grid_U.nc # exp1 grid U input file +FILE2_V=sbcmodMV_20410101_20501231_1Y_grid_V.nc # exp1 grid V input file +FILE2_I=sbcmodMV_20410101_20501231_1M_icemod.nc # exp1 ice input file +VAR2_T=thetao +VAR2_S=so +VAR2_QNET=tohfls +VAR2_ERP=sowafldp +VAR2_EMP=wfo +VAR2_MLD=mldr10_1 +VAR2_U=uocetr_eff +VAR2_V=vocetr_eff +VAR2_Ithick=sithic +VAR2_Ifrac=siconc +VAR2_Isnow=snvolu +VAR2_Isal=sisali +VAR2_Iage=siages +VAR2_IvelU=sivelu +VAR2_IvelV=sivelv +VAR2_Ivelo=sivelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.old_names b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.old_names new file mode 100644 index 0000000000000000000000000000000000000000..55f0c2eb017bdaa386ce74977c9662580587e0a0 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh.old_names @@ -0,0 +1,131 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/500yfwb0_ps_plot_500y +PDF_DIR=$( pwd )/500yfwb0_pdf_plot_500y +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=500yfwb0_24910101_25001231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=500yfwb0_24910101_25001231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=500yfwb0_24910101_25001231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=500yfwb0_24910101_25001231_1M_icemod.nc # exp1 ice input file +VAR1_T=votemper +VAR1_S=vosaline +VAR1_QNET=sohflxdo +VAR1_ERP=sowafldp +VAR1_EMP=sowaflup +VAR1_MLD=somxl010 +VAR1_U=vozoeftr +VAR1_V=vomeeftr +VAR1_Ithick=iicethic +VAR1_Ifrac=iiceconc +VAR1_Isnow=isnowvol +VAR1_Isal=iicesali +VAR1_Iage=iiceages +VAR1_IvelU=iicevelu +VAR1_IvelV=iicevelv +#VAR1_Ivelo=iicevelo +# +#===================== EXP2 ===================== +# +FILE2_T=500yfwb0_24910101_25001231_1Y_grid_T.nc # exp1 grid T input file +FILE2_U=500yfwb0_24910101_25001231_1Y_grid_U.nc # exp1 grid U input file +FILE2_V=500yfwb0_24910101_25001231_1Y_grid_V.nc # exp1 grid V input file +FILE2_I=500yfwb0_24910101_25001231_1M_icemod.nc # exp1 ice input file +VAR2_T=votemper +VAR2_S=vosaline +VAR2_QNET=sohflxdo +VAR2_ERP=sowafldp +VAR2_EMP=sowaflup +VAR2_MLD=somxl010 +#VAR2_U=uoce +VAR2_U=vozoeftr +#VAR2_V=voce +VAR2_V=vomeeftr +VAR2_Ithick=iicethic +VAR2_Ifrac=iiceconc +VAR2_Isnow=isnowthi +VAR2_Isal=iicesali +VAR2_Iage=iiceages +VAR2_IvelU=iicevelu +VAR2_IvelV=iicevelv +#VAR2_Ivelo=iicevelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example1 b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example1 new file mode 100644 index 0000000000000000000000000000000000000000..206e92751bdd6bad5958784260da964bf5353380 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example1 @@ -0,0 +1,129 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/ps_plot +PDF_DIR=$( pwd )/pdf_plot +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=~/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=~/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=~//idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=500yfwb0_24910101_25001231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=500yfwb0_24910101_25001231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=500yfwb0_24910101_25001231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=500yfwb0_24910101_25001231_1M_icemod.nc # exp1 ice input file +VAR1_T=votemper +VAR1_S=vosaline +VAR1_QNET=sohflxdo +VAR1_ERP=sowafldp +VAR1_EMP=sowaflup +VAR1_MLD=somxl010 +VAR1_U=vozoeftr +VAR1_V=vomeeftr +VAR1_Ithick=iicethic +VAR1_Ifrac=iiceconc +VAR1_Isnow=isnowvol +VAR1_Isal=iicesali +VAR1_Iage=iiceages +VAR1_IvelU=iicevelu +VAR1_IvelV=iicevelv +VAR1_Ivelo=iicevelo +# +#===================== EXP2 ===================== +# +FILE2_T=tr33beta_00910101_01001231_1Y_grid_T.nc # exp1 grid T input file +FILE2_U=tr33beta_00910101_01001231_1Y_grid_U.nc # exp1 grid U input file +FILE2_V=tr33beta_00910101_01001231_1Y_grid_V.nc # exp1 grid V input file +FILE2_I=tr33beta_00910101_01001231_1M_icemod.nc # exp1 ice input file +VAR2_T=thetao +VAR2_S=so +VAR2_QNET=qt +VAR2_ERP=wfcorr +VAR2_EMP=wfo +VAR2_MLD=mldr10_1 +VAR2_U=uocetr_eff +VAR2_V=vocetr_eff +VAR2_Ithick=sit +VAR2_Ifrac=sic +VAR2_Isnow=isnowthi +VAR2_Isal=iicesali +VAR2_Iage=iiceages +VAR2_IvelU=iicevelu +VAR2_IvelV=iicevelv +VAR2_Ivelo=iicevelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example2 b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example2 new file mode 100644 index 0000000000000000000000000000000000000000..17cfc534b4a9b27cc10b1b0490dcb4c16c58125d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_vardef.sh_example2 @@ -0,0 +1,129 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_plot.sh and std_plot.pro +# +# EXAMPLES +# ======== +# $ . ./std_plot_vardef.sh +# +# +#===================== User PATHS ===================== +# +#idl_command=/Applications/itt/idl64/bin/idl +idl_command=/Applications/itt/idl71/bin/idl +#idl_command=/usr/local_linux/idl/idl_6.4/idl64/bin/idl +#idl_command=idl71 +# +PS_DIR=$( pwd )/ps_plot +PDF_DIR=$( pwd )/pdf_plot +HTML_DIR=$( pwd )/html_plot +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=~/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=~/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=~//idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +VAR_SNOW_NH=SnowDepth ; FILE_SNOW_ARC=Warren99_1954_1991_arctic_snowdepth.nc # Snow arctic +VAR_SNOW_SH=sno_dept_mm ; FILE_SNOW_ANT=SMMR_SSMI_antarc_sno_dep_mm1979_2004.nc # Snow antartic +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +FILE1_T=500yfwb0_24910101_25001231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=500yfwb0_24910101_25001231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=500yfwb0_24910101_25001231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=500yfwb0_24910101_25001231_1M_icemod.nc # exp1 ice input file +VAR1_T=votemper +VAR1_S=vosaline +VAR1_QNET=sohflxdo +VAR1_ERP=sowafldp +VAR1_EMP=sowaflup +VAR1_MLD=somxl010 +VAR1_U=vozoeftr +VAR1_V=vomeeftr +VAR1_Ithick=iicethic +VAR1_Ifrac=iiceconc +VAR1_Isnow=isnowvol +VAR1_Isal=iicesali +VAR1_Iage=iiceages +VAR1_IvelU=iicevelu +VAR1_IvelV=iicevelv +VAR1_Ivelo=iicevelo +# +#===================== EXP2 ===================== +# +FILE1_T=500yfwb0_24910101_25001231_1Y_grid_T.nc # exp1 grid T input file +FILE1_U=500yfwb0_24910101_25001231_1Y_grid_U.nc # exp1 grid U input file +FILE1_V=500yfwb0_24910101_25001231_1Y_grid_V.nc # exp1 grid V input file +FILE1_I=500yfwb0_24910101_25001231_1M_icemod.nc # exp1 ice input file +VAR1_T=votemper +VAR1_S=vosaline +VAR1_QNET=sohflxdo +VAR1_ERP=sowafldp +VAR1_EMP=sowaflup +VAR1_MLD=somxl010 +VAR1_U=vozoeftr +VAR1_V=vomeeftr +VAR1_Ithick=iicethic +VAR1_Ifrac=iiceconc +VAR1_Isnow=isnowvol +VAR1_Isal=iicesali +VAR1_Iage=iiceages +VAR2_IvelU=iicevelu +VAR2_IvelV=iicevelv +VAR2_Ivelo=iicevelo +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW_ARC VAR_SNOW_NH +export FILE_SNOW_ANT VAR_SNOW_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +export FILE1_T FILE1_U FILE1_V FILE1_I +export VAR1_T VAR1_S VAR1_QNET VAR1_ERP VAR1_EMP VAR1_MLD +export VAR1_U VAR1_V +export VAR1_Ithick VAR1_Ifrac VAR1_Isnow VAR1_Isal VAR1_Iage VAR1_IvelU VAR1_IvelV VAR1_Ivelo +#===================== EXP2 ===================== +export FILE2_T FILE2_U FILE2_V FILE2_I +export VAR2_T VAR2_S VAR2_QNET VAR2_ERP VAR2_EMP VAR2_MLD +export VAR2_U VAR2_V +export VAR2_Ithick VAR2_Ifrac VAR2_Isnow VAR2_Isal VAR2_Iage VAR2_IvelU VAR2_IvelV VAR2_Ivelo +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_S.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_S.pro new file mode 100644 index 0000000000000000000000000000000000000000..4c7e914300a80a4c49c6a47e0a9ee01dca21b68e --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_S.pro @@ -0,0 +1,55 @@ +pro std_plot_zonal_S, S1, S2, SLev, SUBBASIN = subbasin, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + if KEYWORD_SET(SUBBASIN) then subname = subbasin else subname = "Glo" + filename = cdti3 + '_ZonalS_'+subname+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + +; looking for longitudinal index corresponding to the highest latitude (closest to the North Pole) + index = where(gphit eq max(gphit)) + nx = index[0] mod jpi + gphi_save = gphit + gphit[0, *] = gphit[nx, *] + + if KEYWORD_SET(SUBBASIN) then begin + tmasksv = tmask + CASE 1 of + subbasin eq 'Atl' : var = 'atlmsk_nomed' + subbasin eq 'Ind' : var = 'indmsk_nored' + subbasin eq 'Pac' : var = 'pacmsk' + ENDCASE + msk = read_ncdf( var, filename = std_file_msksub, _extra = ex) +; from 2D array to 3D array + msk = msk.arr[*]#replicate(1., nzt) + tmask[firstxt:lastxt, firstyt:lastyt, firstzt:lastzt] = tmask[firstxt:lastxt, firstyt:lastyt, firstzt:lastzt] * msk + endif +; + title = 'Salinity, '+subname+'!C'+std_file1_T + pltz, S1, MININ = 31., MAXIN = 36.8, INTER = .2, typein = 'yz', FORMAT = '(f4.1)' $ + , small = [1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /PORTRAIT, _extra = ex +; + if std_file1_T NE std_file2_T then begin + title = title+' - '+std_file2_T + pltz, S1.arr-S2.arr, MIN = -1., MAX = 1., INTER = .1, typein = 'yz', FORMAT = '(f4.1)', style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /NOERASE, _extra = ex + endif else begin + title = title+' - Levitus' + pltz, S1.arr-SLev.arr, MININ = -1, MAXIN = 1., INTER = .1, typein = 'yz', FORMAT = '(f4.1)', style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /NOERASE, _extra = ex + endelse +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps +; + if KEYWORD_SET(SUBBASIN) then tmask = tmasksv + gphit = gphi_save + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_T.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_T.pro new file mode 100644 index 0000000000000000000000000000000000000000..a89fae59a3e5ccefdb222fbadb49fe5d372d4467 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_plot_zonal_T.pro @@ -0,0 +1,55 @@ +pro std_plot_zonal_T, T1, T2, TLev, SUBBASIN = subbasin, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + if KEYWORD_SET(SUBBASIN) then subname = subbasin else subname = "Glo" + filename = cdti3 + '_ZonalT_'+subname+'_'+std_file1_T + if std_file1_T NE std_file2_T then filename = filename + '_'+std_file2_T + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; +; looking for longitudinal index corresponding to the highest latitude (closest to the North Pole) + index = where(gphit eq max(gphit)) + nx = index[0] mod jpi + gphi_save = gphit + gphit[0, *] = gphit[nx, *] +; + if KEYWORD_SET(SUBBASIN) then begin + tmasksv = tmask + CASE 1 of + subbasin eq 'Atl' : var = 'atlmsk_nomed' + subbasin eq 'Ind' : var = 'indmsk_nored' + subbasin eq 'Pac' : var = 'pacmsk' + ENDCASE + msk = read_ncdf( var, filename = std_file_msksub, _extra = ex) +; from 2D array to 3D array + msk = msk.arr[*]#replicate(1., nzt) + tmask[firstxt:lastxt, firstyt:lastyt, firstzt:lastzt] = tmask[firstxt:lastxt, firstyt:lastyt, firstzt:lastzt] * msk + endif +; + title = 'Temperature, '+subname+'!C'+std_file1_T + pltz, T1, MININ = -2., MAXIN = 30., INTER = 1., typein = 'yz', FORMAT = '(I2)' $ + , small = [ 1, 2, 1], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /PORTRAIT, _extra = ex +; + if std_file1_T NE std_file2_T then begin + title = title+' - '+std_file2_T + pltz, T1.arr-T2.arr, MIN = -2., MAX = 2., INTER = .2, typein = 'yz', FORMAT = '(f4.1)', style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /NOERASE, _extra = ex + endif else begin + title = title+' - Levitus' + pltz, T1.arr-TLev.arr, MININ = -4., MAXIN = 4., INTER = .5, typein = 'yz', FORMAT = '(I2)', style = 'so0so' $ + , small = [1, 2, 2], COAST_THICK = 2, TITLE = title, boxzoom = 5500, ZOOM = 1000, /NOERASE, _extra = ex + endelse +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps +; + if KEYWORD_SET(SUBBASIN) then tmask = tmasksv + gphit = gphi_save +; + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_AMOC.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_AMOC.pro new file mode 100644 index 0000000000000000000000000000000000000000..5a256a7467b24efd56f396cc82965e8c084e8c97 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_AMOC.pro @@ -0,0 +1,143 @@ +PRO std_ts_read_AMOC, var_name, dt1, dt2, prefix, suffix, t45, t70, t50 + + compile_opt idl2, strictarrsubs + +@common +@std_common + + list = rseries_ncdf(var_name, dt1, dt2, prefix, suffix, /fileslist) + nfiles = n_elements(list) + + t45 = 0. + t70 = 0. + t50 = 0. + ts_Time = 0. + + trans = strlowcase(var_name) EQ 'vocetr_eff' OR strlowcase(var_name) EQ 'vomeeftr' + ;trans = strlowcase(var_name) EQ 'vomeeftr' + + ; ADD definition of mask_atl_nomed to compute AMOC (with no Mediterranean Sea) + msk_atl_nomed = read_ncdf( 'atlmsk_nomed', filename = std_file_msksub, /nostruct, _extra = ex ) + FOR i = 0, nfiles-1 DO BEGIN + var = read_ncdf(var_name, allrecords = allrec, filename = list[i], /nostruct) + ts_Time = [ ts_Time, Time] +; + FOR t = 0, jpt-1 DO BEGIN + msfatl = msf(var[*, *, *, t], msk_atl_nomed, TRANSPORT = trans, /nostruct, indexboxzoom = ind) + msftot = msf(var[*, *, *, t], TRANSPORT = trans, /nostruct, indexboxzoom = ind) + yaxis = gphit[ind[0], ind[2]:ind[3]] + +; computation of max Atlatic Meridional Overturninc Circulation at 40N and 50N + indy = where(yaxis gt 40 and yaxis le 50) + domdef, 0, 3500 + ;SF commented because we've to compute msftot starting from msf atlantic; i.e. without mediterranean sea. + ;SF t45 = [t45, max(msftot[indy, firstzw:lastzw], /NaN)] + t45 = [t45, max(msfatl[indy, firstzw:lastzw], /NaN)] + +; computation of max atlantic Antarctic Bottom Water between 80S and 65S + indy = where(yaxis gt -80 and yaxis le -65) + domdef, 300, 3500 + t70 = [t70, min(msftot[indy, firstzw:lastzw], /NaN)] + +; computation of max Antarctic Abyssal Bottom Cell between 65S and 30N , + indy = where(yaxis gt -65 and yaxis le 30) + domdef, 2500, 5000 + t50 = [t50, min(msftot[indy, firstzw:lastzw], /NaN)] + + domdef, 0, jpk-1, /zindex + ENDFOR + + ENDFOR + + time = ts_Time[1:*] ; remove first record of 0 + jpt = n_elements(time) + + t45 = t45[1:*] ; remove first record of 0 + t70 = t70[1:*] ; remove first record of 0 + t50 = t50[1:*] ; remove first record of 0 + + return +end + +pro std_ts_AMOC, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vV1 = getenv('VAR1_V') & prefix = getenv('V1V_PREF') & suffix = getenv('V1V_SUFF') +; get exp2 info + vV2 = getenv('VAR2_V') & prefix2 = getenv('V2V_PREF') & suffix2 = getenv('V2V_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_AMOC_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'_1.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' +; + iodir = std_iodir_data + +; compute the MSF +; + std_ts_read_AMOC, vV1, date1, date2, prefix, suffix, t45, t70, t50 + if prefix NE prefix2 then begin + tsave = time + std_ts_read_AMOC, vV2, date1_2, date2_2, prefix2, suffix2, t45_2, t70_2, t50_2 + time = tsave & IF n_elements(time) NE jpt THEN stop + ENDIF + +; plots... + + title = prefix+' '+d1_d2+'!C'+'Max Atlantic MOC between 40N and 50N' + pltt, t45, 't', MIN = 0., MAX = 30., date1, date2, /REMPLI, /PORTRAIT, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], TITLE = title, YTITLE = varunit, _extra = ex + IF prefix NE prefix2 then begin + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'Max Atlantic MOC between 40N and 50N' + pltt, t45, 't', MIN = 0., MAX = 30., date1, date2, /REMPLI , /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; BLACK + pltt, t45_2, 't', date1, date2, /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; RED + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + title = prefix+' '+d1_d2+'!C'+'Max AntArctic Bottom Water between 80S and 65S '+d1_d2 + pltt, -t70, 't', MIN = 0., MAX = 20., date1, date2, /REMPLI, /PORTRAIT, XGRIDSTYLE = 1, window = 2 $ + , small = [1, 2, 1], TITLE = title, YTITLE = varunit, _extra = ex + if prefix NE prefix2 then begin + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'Max AntArctic Bottom Water between 80S and 65S' + pltt, -t70, 't', MIN = 0.,MAX = 20., date1, date2, /REMPLI, /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; BLACK + pltt, -t70_2, 't', date1, date2, /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; RED + endif + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + if KEYWORD_SET(postscript) then openps, filename+'_3.ps', portrait = 1 + + title = prefix+' '+d1_d2+'!C '+'Max AntArctic Bottom Cell between 65S and 30N '+d1_d2 + pltt, -t50, 't', MIN = 5., MAX = 30., date1, date2, /REMPLI, /PORTRAIT, XGRIDSTYLE = 1, window = 3 $ + , small = [1, 2, 1], TITLE = title, YTITLE = varunit, _extra = ex + if prefix NE prefix2 then begin + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'Max AntArctic Bottom Cell between 65S and 30N' + pltt, -t50 , 't', MIN = 5., MAX = 30., date1, date2, /REMPLI, /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; BLACK + pltt, -t50_2, 't', date1, date2, /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; RED + endif + + domdef, 0, jpk-1, /zindex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Drake.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Drake.pro new file mode 100644 index 0000000000000000000000000000000000000000..2841c7840b7238ea4c7c0198ef22e31d29ac21e9 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Drake.pro @@ -0,0 +1,75 @@ +pro std_ts_Drake, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vU1 = getenv('VAR1_U') & prefix = getenv('V1U_PREF') & suffix = getenv('V1U_SUFF') +; get exp2 info + vU2 = getenv('VAR2_U') & prefix2 = getenv('V2U_PREF') & suffix2 = getenv('V2U_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_Drake_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data + +; find a point in south America (around 60E-30S) + if max(glamt) gt 300 then testlam = abs(glamt - 300) else testlam = abs(glamt + 60) + testlat = abs(gphit + 30) + index = where(abs(testlam - min(testlam)) lt 1 and abs(testlat - min(testlat)) lt 1 ) + xindex = index[0] mod jpi + yindex = index[0]/jpi +; define a domain limited to a thin band going from Antactica to this point in south America + domdef, xindex, xindex+1, 0, yindex, 0, jpk-1, /index ; keep 2 points for x to avoid degenerated dimension... +; + u1 = rseries_ncdf(vU1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, /nostruct) + drk1 = fltarr(jpt) + ; old formulation: we tested variable name + trans = strlowcase(getenv('VAR1_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR1_U')) EQ 'vozoeftr' + ;SF trans = strlowcase(getenv('VAR1_U')) EQ 'vozoeftr' + FOR t = 0, jpt-1 DO BEGIN + tmp = bsf(u1[*, *, *, t], TRANSPORT = trans, /nostruct) + drk1[t] = tmp[0, nyt-1]-tmp[0, 0] + ENDFOR +; + title = prefix+' '+d1_d2+'!C'+blabla + pltt, drk1, 't', 0., 200., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], TITLE = title, YTITLE = varunit, /PORTRAIT, _extra = ex + + if prefix NE prefix2 then begin +; + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + u2 = rseries_ncdf(vU2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, /nostruct) + drk2 = fltarr(jpt) + ; old formulation: we tested variable name + trans = strlowcase(getenv('VAR2_U')) EQ 'uocetr_eff' OR strlowcase(getenv('VAR2_U')) EQ 'vozoeftr' + ;SF trans = strlowcase(getenv('VAR1_U')) EQ 'vozoeftr' + FOR t = 0, jpt-1 DO BEGIN + tmp = bsf(u2[*, *, *, t], TRANSPORT = trans, /nostruct) + drk2[t] = tmp[0, nyt-1]-tmp[0, 0] + ENDFOR + time = tsave & IF n_elements(time) NE jpt THEN stop + + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+blabla + pltt, drk1 , 't', 0., 200., date1, date2, /REMPLI, /NOERASE, XGRIDSTYLE = 1 $ + , COLOR = 000, small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; BLACK + pltt, drk2, 't', 0., 200., date1, date2, /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], TITLE = title, YTITLE = varunit, _extra = ex ; RED + + endif + + domdef + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_EMP.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_EMP.pro new file mode 100644 index 0000000000000000000000000000000000000000..237439197192682dbab1534dd36c2809fe9bf4b1 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_EMP.pro @@ -0,0 +1,51 @@ +pro std_ts_EMP, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vemp = getenv('VAR1_EMP') & prefix = getenv('V1EMP_PREF') & suffix = getenv('V1EMP_SUFF') +; get exp2 info + vemp2 = getenv('VAR2_EMP') & prefix2 = getenv('V2EMP_PREF') & suffix2 = getenv('V2EMP_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_EMP_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data +; + surf_oce = e1t * e2t * tmask[*,*,0] * masknp + surf_oce = total(surf_oce) +; + ts_EMP = rseries_ncdf(vemp, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + ts_EMP.arr = ts_EMP.arr * ( 1.E-09 * surf_oce ) & ts_EMP.unit = 'Sv' + title = prefix+' '+d1_d2+'!C'+blabla + pltt, ts_EMP, 't', MIN = -2.,MAX = 2., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = 'Sv', TITLE = title, /PORTRAIT, _extra = ex + + IF prefix NE prefix2 THEN BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + ts_EMP2 = rseries_ncdf(vemp2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + ts_EMP2.arr = ts_EMP2.arr * ( 1.E-09 * surf_oce ) & ts_EMP2.unit = 'Sv' + time = tsave & IF n_elements(time) NE jpt THEN stop + + title = prefix+' (BLACK) - ' +prefix2+' (RED) '+d1_d2_2+'!C'+blabla + pltt, ts_EMP.arr - ts_EMP2.arr, 't', MIN = -2., MAX = 2., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , color = 250, small = [1, 2, 2], YTITLE = 'Sv', TITLE = title, /noerase, _extra = ex + + ENDIF + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE.pro new file mode 100644 index 0000000000000000000000000000000000000000..3358a8b1ed1c54dd83b0da12d76869f306c85d64 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE.pro @@ -0,0 +1,204 @@ +function read_arr2d, filename, varname, t1, t2 +;; function that read input file and return 2d array with monthly timecounter +nyear = (t2-t1+1)/12 +arr2d = ncdf_lec(filename, VAR=varname) +arr2d = arr2d[t1:t2] +arr2d = reform(arr2d,12,nyear) ; put in 2D array +arr2d = total(arr2d,2)/nyear ; total over 2th dimension (i.e.years) + +return, arr2d +end + +;; here start procedure that use function read_arr2d +pro std_ts_ICE, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vICE1 = getenv('VAR1_ICE') & prefix = getenv('V1ICE_PREF') & suffix = getenv('V1ICE_SUFF') +; get exp2 info + vICE2 = getenv('VAR2_ICE') & prefix2 = getenv('V2ICE_PREF') & suffix2 = getenv('V2ICE_SUFF') +; get ice climatology info + std_file_ice = isafile(getenv('FILE_ICE'), title = 'ICE Extent Climatology', iodir = std_iodir_climato) +; + time_ice = ncdf_lec( std_file_ice, VAR='time' ) + time_ice = (time_ice - FLOOR(time_ice) ) * 12 + time_ice = (round(time_ice) + 11) mod 12; round to nearest integer + t1 = where(time_ice eq 0) + t1 = t1[0] ; january + t2 = where(time_ice eq 11, count) + t2 = t2[count-1] ; last day of december + + vICE_ext_NH = read_arr2d(std_file_ice, getenv('VAR_ICE_EXT_NH'), t1, t2 ) + vICE_ext_SH = read_arr2d(std_file_ice, getenv('VAR_ICE_EXT_SH'), t1, t2 ) +; + vICE_area_NH = read_arr2d(std_file_ice, getenv('VAR_ICE_area_NH'), t1, t2 ) + vICE_area_SH = read_arr2d(std_file_ice, getenv('VAR_ICE_area_SH'), t1, t2 ) +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_ICE_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data + ; ICE Area in NORTH Hemisphere + domdef, 0, jpi-1, 30, 90, /xindex + ICE_N = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ICE_N = grossemoyenne(ICE_N.arr, 'xy', /integration, mask2d = masknp) + + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_N = reform(ice_n, 12,nyr) + ICE_n = total(ice_n,2)/nyr + ICE_N = {arr:ICE_N * 1.e-12, unit : '10^12 m^2'} + + ; ICE EXTENT (Area minus 15%) in NORTH Hemisphere + ICE_N_15 = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + msk = ICE_N_15.arr gt 0.15 ; remove 0.15% for observations + ICE_N_15 = grossemoyenne( msk, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_N_15 = reform(ice_n_15, 12,nyr) + ICE_n_15 = total(ice_n_15,2)/nyr + ICE_N_15 = {arr:ICE_N_15 * 1.e-12, unit : '10^12 m^2'} + ; + ;ICE Area in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + ICE_S = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ICE_S = grossemoyenne(ICE_S.arr, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_S = reform(ice_S, 12,nyr) + ICE_S = total(ice_S,2)/nyr + ICE_S = {arr:ICE_S * 1.e-12, unit : '10^12 m^2'} + ; ICE EXTENT (Area minus 15%) in SOUTH Hemisphere + ICE_S_15 = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + msk = ICE_S_15.arr gt 0.15 ; remove 0.15% for observations + ICE_S_15 = grossemoyenne(msk, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_S_15 = reform(ice_S_15, 12,nyr) + ICE_S_15 = total(ice_S_15,2)/nyr + ICE_S_15 = {arr:ICE_S_15 * 1.e-12, unit : '10^12 m^2'} + ; + ;;title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) '+d1_d2+'!C'+'OBSERVATION (light blue) '+'!C'+' Global Annual Mean Ice Area (CONTINUOUS) '+'!C'+ 'and Extend minus 15% (DASHED)' + title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) '+d1_d2+'!C'+'OBSERVATION (light blue) '+'!C'+' Global Annual Mean Ice Area (DASHED) '+'!C'+ 'and Extend minus 15% (CONTINUOUS)' + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_N, 't', MIN = 4., MAX = 16., /REMPLI, /PORTRAIT, LINESTYLE=2, XGRIDSTYLE = 1, DATE_FORMAT = '%M' $ + , COLOR = 000 , small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_N_15, 't', /REMPLI, /PORTRAIT $ ;;; dashed lines is LINESTYLE=2 $ + , /ov1d, COLOR = 000, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_area_NH, 't', /REMPLI, /PORTRAIT, LINESTYLE=2 $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_ext_NH, 't', /REMPLI, /PORTRAIT $ ;;; dashed lines is LINESTYLE=2 $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex +; + title = 'Southern Hemisphere'+'!C'+prefix+' (BLACK) '+d1_d2+'!C'+'OBSERVATION (light blue) '+'!C'+' Global Annual Mean Ice Area (DASHED) '+'!C'+ 'and Extend minus 15% (CONTINUOUS)' + pltt, ICE_S, 't', MIN = 0., MAX = 20., /REMPLI, LINESTYLE=2, /NOERASE , XGRIDSTYLE = 1 , DATE_FORMAT = '%M' $ + ,COLOR = 000, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_S_15, 't', /REMPLI, /PORTRAIT $ + , /ov1d, COLOR = 000, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_area_SH, 't', /REMPLI, /PORTRAIT, LINESTYLE=2 $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_ext_SH, 't', /REMPLI, /PORTRAIT $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + if prefix NE prefix2 then BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + domdef, 0, jpi-1, 30, 90, /xindex + ;ICE Extent in NORTH Hemisphere + ICE_N2 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ICE_N2 = grossemoyenne(ICE_N2.arr, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_N2 = reform(ICE_N2, 12,nyr) + ICE_N2 = total(ICE_N2,2)/nyr + ICE_N2 = {arr:ICE_N2 * 1.e-12, unit : '10^12 m^2'} + ;ICE Extent minus 15% in NORTH Hemisphere + ICE_N2_15 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + msk = ICE_N2_15.arr gt 0.15 ; remove 0.15% for observations + ICE_N2_15 = grossemoyenne( msk, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_N2_15 = reform(ICE_N2_15, 12,nyr) + ICE_N2_15 = total(ICE_N2_15,2)/nyr + ICE_N2_15 = {arr:ICE_N2_15 * 1.e-12, unit : '10^12 m^2'} + ;ICE Extent in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + ICE_S2 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ICE_S2 = grossemoyenne(ICE_S2.arr, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_S2 = reform(ICE_S2, 12,nyr) + ICE_S2 = total(ICE_S2,2)/nyr + ICE_S2 = {arr:ICE_S2 * 1.e-12, unit : '10^12 m^2'} + ;ICE Extent minus 15% in SOUTH Hemisphere + ICE_S2_15 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + msk = ICE_S2_15.arr gt 0.15 ; remove 0.15% for observations + ICE_S2_15 = grossemoyenne(msk, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_S2_15 = reform(ICE_S2_15, 12,nyr) + ICE_S2_15 = total(ICE_S2_15,2)/nyr + ICE_S2_15 = {arr:ICE_S2_15 * 1.e-12, unit : '10^12 m^2'} + ; + ; time = tsave & IF n_elements(time) NE jpt THEN stop + + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + + ;;title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'OBSERVATION (light blue) '+'!C'+' Global Annual Mean Ice Area (CONTINUOUS) '+'!C'+ 'and Extend minus 15% (DASHED)' + title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'OBSERVATION (light blue) '+'!C'+' Global Annual Mean Ice Area (DASHED) '+'!C'+ 'and Extend minus 15% (CONTINUOUS)' + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_N, 't', MIN = 4, MAX = 16, /REMPLI, /PORTRAIT, LINESTYLE=2, XGRIDSTYLE = 1, window = 2, DATE_FORMAT = '%M' $ + , COLOR = 000, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex ; BLACK + pltt, ICE_N2, 't', /REMPLI, /PORTRAIT , LINESTYLE=2 $ + , /ov1d, COLOR = 250, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex ; RED + pltt, ICE_N_15, 't', /REMPLI, /PORTRAIT $ ; linee tratteggiate LINESTYLE=2 $ + , /ov1d, COLOR = 000, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_N2_15, 't', /REMPLI, /PORTRAIT $ ; linee tratteggiate LINESTYLE=2 $ + , /ov1d, COLOR = 250, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_area_NH, 't', /REMPLI, /PORTRAIT, LINESTYLE=2 $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex ; light blue + pltt, vICE_ext_NH, 't', /REMPLI, /PORTRAIT $ + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex ; blu scuro +; + title ='Southern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'OBSERVATION (light blue) '+'!C'+'Global Annual Mean Ice Area (DASHED)'+'!C'+ 'and Extend minus 15% (CONTINUOUS)' +; title ='Southern Hemisphere'+'!C' + pltt, ICE_S, 't', MIN = 0., MAX = 20., /REMPLI, LINESTYLE=2, /NOERASE, XGRIDSTYLE = 1, DATE_FORMAT = '%M' $ + , COLOR = 000, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_S2, 't', /REMPLI, /NOERASE, LINESTYLE=2 $ + , /ov1d, COLOR = 250, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_S_15 , 't', /REMPLI, /PORTRAIT $ ; linee tratteggiate LINESTYLE=2 $ + , /ov1d, COLOR = 000, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, ICE_S2_15, 't', /REMPLI, /PORTRAIT $ ; linee tratteggiate LINESTYLE=2 $ + , /ov1d, COLOR = 250, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_area_SH, 't', /REMPLI, /PORTRAIT, LINESTYLE=2 $ + , /ov1d, COLOR = 100, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex + pltt, vICE_ext_SH, 't', /REMPLI, /PORTRAIT $ + , /ov1d, COLOR = 100, small = [1, 2, 2], YTITLE = '10^12 m^2 ', TITLE = title, _extra = ex +; + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + endif + + domdef + + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_FRAM.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_FRAM.pro new file mode 100644 index 0000000000000000000000000000000000000000..3aaf8431deb3c9a049d9007018e48842c7510207 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_FRAM.pro @@ -0,0 +1,211 @@ +function read_arr2d, filename, varname, t1, t2 +;; function that read input file and return 2d array with monthly timecounter +nyear = (t2-t1+1)/12 +arr2d = ncdf_lec(filename, VAR=varname) +arr2d = arr2d[t1:t2] +arr2d = reform(arr2d,12,nyear) ; put in 2D array +;arr2d = total(arr2d,2)/nyear ; total over 2th dimension (i.e.years) +arr2d = arr2d[*, nyear-1] ; select last year + +return, arr2d +end + +;; here start procedure that use function read_arr2d +pro std_ts_ICE_FRAM, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vICE1 = getenv('VAR1_ICE') & prefix = getenv('V1ICE_PREF') & suffix = getenv('V1ICE_SUFF') + v1_Ithick = getenv('VAR1_Ithick') & prefix = getenv('V1It_PREF') & suffix = getenv('V1It_SUFF') + v1_IV = getenv('VAR1_IvelV') & prefix = getenv('V1IvV_PREF') & suffix = getenv('V1IvV_SUFF') +; get exp2 info + vICE2 = getenv('VAR2_ICE') & prefix2 = getenv('V2ICE_PREF') & suffix2 = getenv('V2ICE_SUFF') + v2_Ithick = getenv('VAR2_Ithick') & prefix2 = getenv('V2It_PREF') & suffix2 = getenv('V2It_SUFF') + v2_IV = getenv('VAR2_IvelV') & prefix2 = getenv('V2IvV_PREF') & suffix2 = getenv('V2IvV_SUFF') + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_ICE_FRAM_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' + d2 = '('+strtrim(date2, 1)+')' +; + iodir = std_iodir_data + ; ICE Area(=Surface) in FRAM Strait + ;; FRAM Strait points, computed with ncview meshmask for ORCA2 grid (133-1434-135-136, 137) + indx0 = 133 + indx0_last = 136 + indy0 = 137 + indy0_last = 137 + ;; ORI domdef, 133, 137, 136, 136, /xindex, /yindex,/memeindices + indx1= (indx0 - ixminmesh + key_shift)mod(jpi) + indx2= (indx0_last - ixminmesh + key_shift)mod(jpi) + indy1= indy0 - iyminmesh + indy2= indy1 + ; + ;OBSERVATIONS : mean seasonal cycle/month + ; vol_obs = [0.261625, 0.230750, 0.325375, 0.252000, 0.172500, 0.0805000, 0.0805000, 0.0805000, 0.0805000, 0.176500, 0.148500, 0.235000] + vol_obs = [261.625, 230.750, 325.375, 252.000, 172.500, 80.5000, 80.5000, 80.5000, 80.5000, 176.500, 148.500, 235.000] + area_obs = [0.103292, 0.0997500, 0.107625, 0.0944167, 0.0612083, 0.0262500, 0.0262500, 0.0262500, 0.0262500, 0.0843750, 0.0914583, 0.104083] + ; + domdef, indx1, indx2, indy1, indy2, /xindex, /yindex,/memeindices + ICE = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, /nostruct) + ICE_thick = rseries_ncdf(v1_Ithick, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, /nostruct) + ; domdef for V-Point in j-1 + ; REALLY NOT NECESSARY, BECAUSE FLUX CAN BE COMPUTED IN J POINT, is the same + domdef, indx1, indx2, indy1-1, indy2-1, /xindex, /yindex,/memeindices + VN = rseries_ncdf(v1_IV, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec,/nostruct) ;!! warning positive northward + + ;; Area export + ICE_area_export = (-1) * ICE * VN * ((e1v[firstxv:lastxv, firstyv:lastyv])[*]#replicate(1., jpt)) + ICE_area_export = total(reform(ICE_area_export),1) ; in m2/s -> need to change the unit? + + ;; Volume export + ICE_vol_export = (-1) * ICE * ICE_thick * VN * ((e1v[firstxv:lastxv, firstyv:lastyv])[*]#replicate(1., jpt)) + ICE_vol_export = total(reform(ICE_vol_export),1) ;! in m3/s -> need to change the unit? + + ; needed for seasonal cycle : + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ;; AREA + ICE_area_export = reform(ICE_area_export, 12, nyr) + ;ICE_area_export = total(ICE_area_export,2)/nyr ; old version monthly mean average over all years + ICE_area_export = ICE_area_export[*,nyr-1] ; dim= 12, index 0-11; last year choosen + ; ICE_area_export = {arr:ICE_area_export * 1.e-12 * 86400 * 365 , unit : '10^6 Km^2/year'} ; annual mean + ICE_area_export = {arr:ICE_area_export * 1.e-12 * 86400 * 30 , unit : '10^6 Km^2/month'} ; monthly mean + + ; + ICE_vol_export = reform(ICE_vol_export, 12, nyr) + ;ICE_vol_export = total(ICE_vol_export,2)/nyr + ICE_vol_export = ICE_vol_export[*,nyr-1] + ; ICE_vol_export = {arr:ICE_vol_export * 1.e-9 * 86400 * 365 , unit : '10^3 Km^3/year'} ; annual mean + ICE_vol_export = {arr:ICE_vol_export * 1.e-9 * 86400 * 30 , unit : '10^3 Km^3/month'} ; monthly mean + + ; + ;title = 'Fram Strait Areal Export: LAST YEAR'+'!C'+prefix+' '+d1_d2 + title = 'Fram Strait Areal Export: LAST YEAR'+'!C'+prefix+' '+d2 + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_area_export, 't', /REMPLI, /PORTRAIT, MIN = 0., MAX = .5 , XGRIDSTYLE = 1 $ + , small = [1, 2, 1],YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, area_obs, 't', /REMPLI, /NOERASE, psym = 4, THICK = 4 $ ; light blue + , /ov1d, COLOR = 100, small = [1, 2, 2], YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + ; + tot_area_expo = total(ICE_area_export.arr) + ; + xyouts, julday(5,15,1900), 0.49, 'Tot. Annual Export OBS = 0.851 million Km2', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 0.46, 'Tot. Annual Export Model = '+strtrim(tot_area_expo, 1)+' million Km2', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(7,15,1900), 0.41, 'Data from Kwok et al.(2004), 1979-2002 ', ALIGN = 0, CHARTHICK = 2, CHARSIZE=0.8, COLOR=2 + ; + ;title = 'Fram Strait Volume Export LAST YEAR'+'!C'+prefix+' '+d1_d2 + title = 'Fram Strait Volume Export LAST YEAR'+'!C'+prefix+' '+d2 + pltt, ICE_vol_export, 't', /REMPLI, MIN = 60., MAX = 500. , /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = '10^3 Km^3/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, vol_obs, 't', /REMPLI, /NOERASE, psym = 4, THICK = 4 $ ; light blue + , /ov1d, COLOR = 100, small = [1, 2, 2], YTITLE = '10^6 Km^2/month',DATE_FORMAT = '%M', TITLE = title, _extra = ex + ; + tot_vol_expo = total(ICE_vol_export.arr) + tot_vol_expo_Sv = tot_vol_expo * 1.e06 * 1/86400 * 1/365 ; annual mean in Sverdrup + xyouts, julday(5,15,1900), 490, 'Tot. Annual Export OBS = 2124 10^3 Km3/year', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 460, 'Tot. Annual Export Model = '+strtrim(tot_vol_expo, 1)+' 10^3 Km3/year', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(9,15,1900), 440, 'in Sv = '+strtrim(tot_vol_expo_Sv, 1)+' Sv', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(7,15,1900), 360, 'Data from Kwok et al.(2004), 1992-1998 ', ALIGN = 0, CHARTHICK = 2, CHARSIZE=0.8, COLOR=2 + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + if prefix NE prefix2 then BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + d2_2 = '('+strtrim(date2_2, 1)+')' + tsave = time + domdef, indx1, indx2, indy1, indy2, /xindex, /yindex,/memeindices + ICE_2= rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, /nostruct) + ICE_thick_2 = rseries_ncdf(v2_Ithick, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, /nostruct) + ; domdef for V-Point in j-1 + ; REALLY NOT NECESSARY, BECAUSE FLUX CAN BE COMPUTED IN J POINT, is the same + domdef, indx1, indx2, indy1-1, indy2-1, /xindex, /yindex,/memeindices + VN_2 = rseries_ncdf(v2_IV, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec,/nostruct) ;!! warning positive northward + + ;; Area export + ICE_area_export_2 = (-1) * ICE_2 * VN_2 * ((e1v[firstxv:lastxv, firstyv:lastyv])[*]#replicate(1., jpt)) + ICE_area_export_2 = total(reform(ICE_area_export_2),1) ; in m2/s -> need to change the unit? + + ;; Volume export + ICE_vol_export_2 = (-1) * ICE_2 * ICE_thick_2 * VN_2 * ((e1v[firstxv:lastxv, firstyv:lastyv])[*]#replicate(1., jpt)) + ICE_vol_export_2 = total(reform(ICE_vol_export_2),1) ;! in m3/s -> need to change the unit? + + ; needed for seasonal cycle : + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ;; AREA + ICE_area_export_2 = reform(ICE_area_export_2, 12, nyr) + ;ICE_area_export_2 = total(ICE_area_export_2,2)/nyr + ICE_area_export_2 = ICE_area_export_2[*,nyr-1] + ; ICE_area_export_2 = {arr:ICE_area_export_2 * 1.e-12 * 86400 * 365 , unit : '10^6 Km^2/year'} ; annual mean + ICE_area_export_2 = {arr:ICE_area_export_2 * 1.e-12 * 86400 * 30 , unit : '10^6 Km^2/month'} ; monthly mean + ; + ICE_vol_export_2 = reform(ICE_vol_export_2, 12, nyr) + ;ICE_vol_export_2 = total(ICE_vol_export_2,2)/nyr + ICE_vol_export_2 = ICE_vol_export_2[*,nyr-1] + ; ICE_vol_export_2 = {arr:ICE_vol_export_2 * 1.e-12 * 86400 * 365 , unit : '10^3 Km^3/year'} ; annual mean + ICE_vol_export_2 = {arr:ICE_vol_export_2 * 1.e-9 * 86400 * 30 , unit : '10^3 Km^3/month'} ; monthly mean + ; + ; + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + ;title = 'Fram Strait Areal Export'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2 + title = 'Fram Strait Areal Export LAST YEAR'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d2_2 + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_area_export, 't', /REMPLI, /PORTRAIT, MIN = 0., MAX = .5, XGRIDSTYLE = 1, window = 2 $ + , small = [1, 2, 1], YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, ICE_area_export_2 ,'t', /REMPLI, /PORTRAIT, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 1],YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, area_obs, 't', /REMPLI, /NOERASE, psym = 4, THICK = 4 $ ; light blue + , /ov1d, COLOR = 100, small = [1, 2, 1], YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + ; + tot_area_expo = total(ICE_area_export.arr) + tot_area_expo_2 = total(ICE_area_export_2.arr) + ; + xyouts, julday(5,15,1900), 0.49, 'Tot. Annual Export OBS = 0.851 million Km2', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 0.46, 'Tot. Annual Export Model 1= '+strtrim(tot_area_expo, 1)+' million Km2', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 0.43, 'Tot. Annual Export Model 2= '+strtrim(tot_area_expo_2, 1)+' million Km2', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(7,15,1900), 0.41, 'Data from Kwok et al.(2004), 1979-2002 ', ALIGN = 0, CHARTHICK = 2, CHARSIZE=0.8, COLOR=2 + ; + ;title = 'Fram Strait Volume Export'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2 + title = 'Fram Strait Volume Export LAST YEAR'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d2_2 + pltt, ICE_vol_export, 't', /REMPLI, MIN = 60., MAX = 500., /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = '10^3 Km^3/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, ICE_vol_export_2, 't', /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], YTITLE = '10^3 Km^3/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + pltt, vol_obs, 't', /REMPLI, /NOERASE, psym = 4, THICK = 4 $ ; light blue + , /ov1d, COLOR = 100, small = [1, 2, 2], YTITLE = '10^6 Km^2/month', TITLE = title, DATE_FORMAT = '%M', _extra = ex + ; + tot_vol_expo = total(ICE_vol_export.arr) + tot_vol_expo_2 = total(ICE_vol_export_2.arr) + tot_vol_expo_Sv = tot_vol_expo * 1.e06 * 1/86400 * 1/365 ; annual mean in Sverdrup + tot_vol_expo_2_Sv = tot_vol_expo_2 * 1.e06 * 1/86400 * 1/365 ; annual mean in Sverdrup + xyouts, julday(5,15,1900), 490, 'Tot. Annual Export OBS = 2124 10^3 Km3/year', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 460, 'Tot. Annual Export Model 1 = '+strtrim(tot_vol_expo, 1)+' 10^3 Km3/year', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(9,15,1900), 440, 'in Sv = '+strtrim(tot_vol_expo_Sv, 1)+' Sv', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(5,15,1900), 410, 'Tot. Annual Export Model 2 = '+strtrim(tot_vol_expo_2, 1)+' 10^3 Km3/year', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(9,15,1900), 390, 'in Sv = '+strtrim(tot_vol_expo_2_Sv, 1)+' Sv', ALIGN = 0, CHARTHICK = 2, CHARSIZE=1, COLOR=2 + xyouts, julday(7,15,1900), 360, 'Data from Kwok et al.(2004), 1992-1998 ', ALIGN = 0, CHARTHICK = 2, CHARSIZE=0.8, COLOR=2 + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + endif + + domdef + + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vel.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vel.pro new file mode 100644 index 0000000000000000000000000000000000000000..c38dfa0b830bde39731cf5ef9ed25981c7ab7631 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vel.pro @@ -0,0 +1,132 @@ +function read_arr2d, filename, varname, t1, t2 +;; function that read input file and return 2d array with monthly timecounter +nyear = (t2-t1+1)/12 +arr2d = ncdf_lec(filename, VAR=varname) +arr2d = arr2d[t1:t2] +arr2d = reform(arr2d,12,nyear) ; put in 2D array +arr2d = total(arr2d,2)/nyear ; total over 2th dimension (i.e.years) + +return, arr2d +end + +;; here start procedure that use function read_arr2d +pro std_ts_ICE_Vel, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common +; get exp1 info + vICE1 = getenv('VAR1_ICE') & prefix = getenv('V1ICE_PREF') & suffix = getenv('V1ICE_SUFF') +; get exp2 info + vICE2 = getenv('VAR2_ICE') & prefix2 = getenv('V2ICE_PREF') & suffix2 = getenv('V2ICE_SUFF') +; get exp1 info + vICE_vel_1 = getenv('VAR1_Ivel') & prefix = getenv('V1Iv_PREF') & suffix = getenv('V1Iv_SUFF') +; get exp2 info + vICE_vel_2 = getenv('VAR2_Ivel') & prefix2 = getenv('V2Iv_PREF') & suffix2 = getenv('V2Iv_SUFF') + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_ICE_Vel_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data + ; ICE Velocity in NORTH Hemisphere + domdef, 0, jpi-1, 30, 90, /xindex + Velo_N = rseries_ncdf(vICE_vel_1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, /nostruct) ;!! warning positive northward + ICE_N_15 = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, /nostruct) + print, 'N15', max(ICE_N_15) + + + ICE_N_15[where(ICE_N_15 lt 0.15)] = 0. + + ICE_velo_N = grossemoyenne( (Velo_N < 1.e10) * (ICE_N_15 < 1.e10), 'xy',/integration, mask2d = masknp) + ICE_N_15 = grossemoyenne(ICE_N_15, 'xy',/integration, mask2d = masknp) + + ICE_velo_N = ICE_velo_N / ICE_N_15 + + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_velo_N = reform(ICE_velo_N, 12, nyr) + ICE_velo_N = total(ICE_velo_N,2)/nyr + ICE_velo_N = {arr:ICE_velo_N , unit : 'm/s'} + + + ;ICE Velocity in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + Velo_S = rseries_ncdf(vICE_vel_1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec,/nostruct) ;!! warning positive northward + + + + title = 'Northern Hemisphere'+'!C'+prefix+' '+d1_d2+'!C'+'Ice Velocity (Black SOLID simulation)' + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + + + pltt, ICE_velo_N, 't', /REMPLI, /PORTRAIT, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, _extra = ex + ; + title ='Southern Hemisphere' +'!C'+prefix+' '+d1_d2+' - '+'!C'+'Ice Velocity (Black SOLID simulation)' + pltt, Velo_S, 't', /REMPLI, /NOERASE, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, _extra = ex + ; + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + if prefix NE prefix2 then BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + ; ICE Velocity in NORTH Hemisphere + domdef, 0, jpi-1, 30, 90, /xindex + Velo_N_2 = rseries_ncdf(vICE_vel_2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec,/nostruct) + + ;;;;;; if grossempoyenne is not present dimension of array is not ok: 54 Array[180, 54, 120] + ;;;;;; with the domain dimensions [jpi/nx, jpj/ny, jpk/nz, jpt] = [180/180, 149/50, 31/31, 12] + + ICE_velo_N_2 = grossemoyenne(Velo_N_2, 'xy', /integration, mask2d = masknp) + print, 'max ice velo', max(ICE_velo_N_2) + + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_velo_N_2 = reform(ICE_velo_N_2, 12, nyr) + ICE_velo_N_2 = total(ICE_velo_N_2,2)/nyr + ICE_velo_N_2 = {arr:ICE_velo_N_2 * 86400 * 365, unit : 'm/year'} + print, 'max ice velo', max(ICE_velo_N_2.arr) + + + ;ICE Velocity in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + Velo_S_2 = rseries_ncdf(vICE_vel_2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec,/nostruct) + + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + + title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2 +'!C'+'Ice Velocity (BLACK) ' + pltt, ICE_velo_N , 't', /REMPLI, XGRIDSTYLE = 1, window = 2 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + pltt, ICE_velo_N_2, 't', /REMPLI $ + , /ov1d, color = 250, small = [1, 2, 1], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + + title = 'Southern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2 +'!C'+'Ice Velocity (BLACK) ' + pltt, Velo_S , 't', /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + pltt, Velo_S_2, 't', /REMPLI $ + , /ov1d, color = 250, small = [1, 2, 2], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + endif + + domdef + + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vol.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vol.pro new file mode 100644 index 0000000000000000000000000000000000000000..a9943582f336b93cacaaa5b72d2b3aab5e2cf62c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_ICE_Vol.pro @@ -0,0 +1,135 @@ +function read_arr2d, filename, varname, t1, t2 +;; function that read input file and return 2d array with monthly timecounter +nyear = (t2-t1+1)/12 +arr2d = ncdf_lec(filename, VAR=varname) +arr2d = arr2d[t1:t2] +arr2d = reform(arr2d,12,nyear) ; put in 2D array +arr2d = total(arr2d,2)/nyear ; total over 2th dimension (i.e.years) + +return, arr2d +end + +; +; +pro std_ts_ICE_Vol, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vICE1 = getenv('VAR1_ICE') & prefix = getenv('V1ICE_PREF') & suffix = getenv('V1ICE_SUFF') + v1_Ithick = getenv('VAR1_Ithick') & prefix = getenv('V1It_PREF') & suffix = getenv('V1It_SUFF') +; get exp2 info + vICE2 = getenv('VAR2_ICE') & prefix2 = getenv('V2ICE_PREF') & suffix2 = getenv('V2ICE_SUFF') + v2_Ithick = getenv('VAR2_Ithick') & prefix2 = getenv('V2It_PREF') & suffix2 = getenv('V2It_SUFF') + + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_ICE_Vol_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 +; + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data + ; ICE Area(=Surface) in NORTH Hemisphere + domdef, 0, jpi-1, 30, 90, /xindex + ICE_N = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ICE_thick = rseries_ncdf(v1_Ithick, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ; Volume = Area(=Surface) * Thickness + ICE_vol_N = (ICE_N.arr < 1.e10 ) * ( ICE_thick.arr < 1.e10) ; limited mask value of 1.e20, because 1.e20 * 1.e20 = inf for idl + ICE_vol_N = grossemoyenne(ICE_vol_N, 'xy', /integration, mask2d = masknp) + + ; + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_vol_N = reform(ICE_vol_N, 12, nyr) + ICE_vol_N = total(ICE_vol_N,2)/nyr + ICE_vol_N = {arr:ICE_vol_N * 1.e-9, unit : '10^9 Km^3'} + ; + ;ICE Area(=Surface) in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + ICE_S = rseries_ncdf(vICE1, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ICE_thick = rseries_ncdf(v1_Ithick, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec) + ; Volume = Area(=Surface) * Thickness + ICE_vol_S = (ICE_S.arr < 1.e10 ) * ( ICE_thick.arr < 1.e10) ; limited mask value of 1.e20, because 1.e20 * 1.e20 = inf for idl + ICE_vol_S = grossemoyenne(ICE_vol_S, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_vol_S = reform(ICE_vol_S, 12, nyr) + ICE_vol_S = total(ICE_vol_S,2)/nyr + ICE_vol_S = {arr:ICE_vol_S * 1.e-9, unit : '10^9 Km^3'} + ; + title = 'Northern Hemisphere'+'!C'+prefix+' '+d1_d2+'!C'+'Global Annual Mean Ice Volume (BLACK) ' + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_vol_N, 't', MIN = 0., MAX = 40000., /REMPLI, /PORTRAIT, XGRIDSTYLE = 1, DATE_FORMAT = '%M' $ + , small = [1, 2, 1], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex +; + title ='Southern Hemisphere' +'!C'+prefix+' '+d1_d2+' - '+'!C'+'Global Annual Mean Ice Volume (BLACK)' + pltt, ICE_vol_S, 't', MIN = 0., MAX = 12000., /REMPLI, /NOERASE, XGRIDSTYLE = 1 , DATE_FORMAT = '%M' $ + , small = [1, 2, 2], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex +; + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + if prefix NE prefix2 then BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + domdef, 0, jpi-1, 30, 90, /xindex + ;ICE Area(=Surface) in NORTH Hemisphere + ICE_N2 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ICE_thick2 = rseries_ncdf(v2_Ithick, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ; Volume = Area(=Surface) * Thickness + ICE_vol_N2 = (ICE_N2.arr < 1.e10 ) * ( ICE_thick2.arr < 1.e10) ; limited mask value of 1.e20, because 1.e20 * 1.e20 = inf for idl + ICE_vol_N2 = grossemoyenne(ICE_vol_N2, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_vol_N2 = reform(ICE_vol_N2, 12, nyr) + ICE_vol_N2 = total(ICE_vol_N2,2)/nyr + ICE_vol_N2 = {arr:ICE_vol_N2 * 1.e-9, unit : '10^3 Km^3'} + + ;ICE Area(=Surface) in SOUTH Hemisphere + domdef, 0, jpi-1, -90, -30, /xindex + ICE_S2 = rseries_ncdf(vICE2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ICE_thick2 = rseries_ncdf(v2_Ithick, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec) + ; Volume = Area(=Surface) * Thickness + ICE_vol_S2 = (ICE_S2.arr < 1.e10 ) * ( ICE_thick.arr < 1.e10) ; limited mask value of 1.e20, because 1.e20 * 1.e20 = inf for idl + ICE_vol_S2 = grossemoyenne(ICE_vol_S2, 'xy', /integration, mask2d = masknp) + if jpt mod 12 ne 0 then stop + nyr=jpt/12. + ICE_vol_S2 = reform(ICE_vol_S2, 12, nyr) + ICE_vol_S2 = total(ICE_vol_S2,2)/nyr + ICE_vol_S2 = {arr:ICE_vol_S2 * 1.e-9, unit : '10^3 Km^3'} + + ; time = tsave & IF n_elements(time) NE jpt THEN stop + + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + title = 'Northern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2 +'!C'+'Global Annual Mean Ice Volume (BLACK) ' + jpt=12 + time=julday(1,15,1900)+30*lindgen(12) + pltt, ICE_vol_N, 't', MIN = 0., MAX = 40000., /REMPLI, /PORTRAIT, XGRIDSTYLE = 1, window = 2, DATE_FORMAT = '%M' $ + , small = [1, 2, 1], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex + pltt, ICE_vol_N2 , 't', /REMPLI, /PORTRAIT $ ; linee tratteggiate LINESTYLE=2 $ + , /ov1d, COLOR = 250, small = [1, 2, 1], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex + ; + title = 'Southern Hemisphere'+'!C'+prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+'Global Annual Mean Ice Volume' + pltt, ICE_vol_S, 't', MIN = 0., MAX = 12000., /REMPLI, /NOERASE, XGRIDSTYLE = 1, DATE_FORMAT = '%M' $ + , small = [1, 2, 2], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex + pltt, ICE_vol_S2, 't', /REMPLI, /NOERASE $ + , /ov1d, COLOR = 250, small = [1, 2, 2], YTITLE = '10^9 Km^3 ', TITLE = title, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + endif + + domdef + + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Q.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Q.pro new file mode 100644 index 0000000000000000000000000000000000000000..96a8f2535777a56bcb5d35256fa327931efea6b2 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_Q.pro @@ -0,0 +1,48 @@ +pro std_ts_Q, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vq = getenv('VAR1_Q') & prefix = getenv('V1Q_PREF') & suffix = getenv('V1Q_SUFF') +; get exp2 info + vq2 = getenv('VAR2_Q') & prefix2 = getenv('V2Q_PREF') & suffix2 = getenv('V2Q_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_Q_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data +; + ts_Q = rseries_ncdf(vq, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + title = prefix+' '+d1_d2+'!C'+blabla + pltt, ts_Q, 't', MIN = -4, MAX = 4, date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, /PORTRAIT, _extra = ex + + IF prefix NE prefix2 THEN BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + ts_Q2 = rseries_ncdf(vq2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + time = tsave & IF n_elements(time) NE jpt THEN stop + + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+blabla + pltt, ts_Q.arr , 't', MIN = -4., MAX = 4., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + pltt, ts_Q2.arr, 't', date1, date2, /REMPLI $ + , /ov1d, color = 250, small = [1, 2, 2], YTITLE = varunit, TITLE = title, /noerase, _extra = ex + + ENDIF + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_S.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_S.pro new file mode 100644 index 0000000000000000000000000000000000000000..421b9edc69eb44822bb32d9215649a43327a5274 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_S.pro @@ -0,0 +1,85 @@ +pro std_ts_S, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vsal = getenv('VAR1_S') & prefix = getenv('V1S_PREF') & suffix = getenv('V1S_SUFF') + vssh = getenv('VAR1_SSH') & sshprefix = getenv('V1SSH_PREF') & sshsuffix = getenv('V1SSH_SUFF') +; get exp2 info + vsal2 = getenv('VAR2_S') & prefix2 = getenv('V2S_PREF') & suffix2 = getenv('V2S_SUFF') + vssh2 = getenv('VAR2_SSH') & sshprefix2 = getenv('V2SSH_PREF') & sshsuffix2 = getenv('V2SSH_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_S_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'_1.ps', portrait = 1 + + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' + +; read levitus data + std_file_Levitus_S = isafile(getenv('FILE_SAL_3D'), title = 'Levitus_S', iodir = std_iodir_climato) + Lev = read_ncdf(getenv('VAR_SAL_3D'), filename = std_file_Levitus_S, /nostruct ) + Lev_xyz = moyenne(Lev, 'xyz', mask2d = masknp) + levz = moyenne(temporary(Lev), 'xy', mask2d = masknp, /KEEPBOTTOM) +; + iodir = std_iodir_data +; + +; read exp1 data + std_ts_read, vsal, date1, date2, prefix, suffix, ts_Sal, ts_z, masknp $ + , WITHSSH = vssh, SSHPREFIX = sshprefix, SSHSUFFIX = sshsuffix, LEVZ = levz + + title = prefix+' '+d1_d2+'!C'+blabla + pltt, ts_Sal, 't', MIN = 34.54, MAX = 34.76, date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, /PORTRAIT, _extra = ex + + title = prefix+' '+d1_d2+' - Levitus!C'+blabla + pltt, ts_Sal - Lev_xyz, 't', MIN = -.05, MAX = .05, date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + title = prefix+' '+d1_d2+' - Levitus!C ZT-plot (0-1500m) '+blabla + pltt, ts_z, 'zt', MIN = -.5, MAX = .5, INTER = .05, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, boxzoom = 1500., /portrait, window = 1, _extra = ex + + title = prefix+' '+d1_d2+' - Levitus!C ZT-plot (0-6000m) '+blabla + pltt, ts_z, 'zt', MIN = -.5, MAX = .5, INTER = .05, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, boxzoom = 6000., /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + IF prefix NE prefix2 THEN BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' +; read exp2 data + tsave = time + std_ts_read, vsal2, date1_2, date2_2, prefix2, suffix2, ts_Sal2, ts_z2, masknp $ + , WITHSSH = vssh2, SSHPREFIX = sshprefix2, SSHSUFFIX = sshsuffix2, LEVZ = levz + time = tsave & IF n_elements(time) NE jpt THEN stop + + if KEYWORD_SET(postscript) then openps, filename+'_3.ps', portrait = 1 + + title = prefix+' - '+prefix2+' '+d1_d2_2+'!C'+blabla + pltt, ts_Sal - ts_Sal2, 't', MIN = -0.1, MAX = 0.1, date1, date2, /REMPLI , XGRIDSTYLE = 1 $ + , COLOR = 250, small = [1, 2, 1], YTITLE = varunit, TITLE = title, /PORTRAIT, window = 2, _extra = ex + + title = prefix+' - '+prefix2+' '+d1_d2_2+'!C ZT-plot (0-6000m) '+blabla + pltt, ts_z - ts_z2, 'zt', MIN = -0.1, MAX = 0.1, INTER = .01, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, boxzoom = 6000., /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + ENDIF + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_SSH.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_SSH.pro new file mode 100644 index 0000000000000000000000000000000000000000..7e03ed0744c9886663e4be90c9a97f8c9f12dcfb --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_SSH.pro @@ -0,0 +1,48 @@ +pro std_ts_SSH, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vssh = getenv('VAR1_SSH') & prefix = getenv('V1SSH_PREF') & suffix = getenv('V1SSH_SUFF') +; get exp2 info + vssh2 = getenv('VAR2_SSH') & prefix2 = getenv('V2SSH_PREF') & suffix2 = getenv('V2SSH_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_SSH_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'.ps', portrait = 1 + + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' +; + iodir = std_iodir_data +; + ts_SSH = rseries_ncdf(vssh, date1, date2, prefix, suffix, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + ts_SSH.arr = ts_SSH.arr & ts_SSH.unit = 'm' + title = prefix+' '+d1_d2+'!C'+blabla + pltt, ts_SSH, 't', MIN = -12., MAX = 12., date1, date2, /REMPLI , XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = 'm', TITLE = title, /PORTRAIT, _extra = ex + + IF prefix NE prefix2 THEN BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' + tsave = time + ts_SSH2 = rseries_ncdf(vssh2, date1_2, date2_2, prefix2, suffix2, FIRSTONLY = 1 - allrec, direc = 'xy', mask2d = masknp) + ts_SSH2.arr = ts_SSH2.arr & ts_SSH2.unit = 'm' + time = tsave & IF n_elements(time) NE jpt THEN stop + + title = prefix+' (BLACK) - '+prefix2+' (RED) '+d1_d2_2+'!C'+blabla + pltt, ts_SSH.arr - ts_SSH2.arr, 't', MIN = -10., MAX = 10., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , color = 250, small = [1, 2, 2], YTITLE = 'm', TITLE = title, /noerase, _extra = ex + + ENDIF + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + return +end + diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_T.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_T.pro new file mode 100644 index 0000000000000000000000000000000000000000..8afe39d52ed1fa1c824ea79f7e8744f7c3fe484c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_T.pro @@ -0,0 +1,84 @@ +pro std_ts_T, masknp, s_iodir_data, POSTSCRIPT = postscript, _extra = ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + +; get exp1 info + vtemp = getenv('VAR1_T') & prefix = getenv('V1T_PREF') & suffix = getenv('V1T_SUFF') + vssh = getenv('VAR1_SSH') & sshprefix = getenv('V1SSH_PREF') & sshsuffix = getenv('V1SSH_SUFF') +; get exp2 info + vtemp2 = getenv('VAR2_T') & prefix2 = getenv('V2T_PREF') & suffix2 = getenv('V2T_SUFF') + vssh2 = getenv('VAR2_SSH') & sshprefix2 = getenv('V2SSH_PREF') & sshsuffix2 = getenv('V2SSH_SUFF') +; + cdti3 = string(cnt, format = '(i3.3)') + print, cdti3 + ') ' + blabla + filename = cdti3 + '_ts_T_'+prefix + if prefix NE prefix2 then filename = filename + '_'+prefix2 + if KEYWORD_SET(postscript) then openps, filename+'_1.ps', portrait = 1 + + d1_d2 = '('+strtrim(date1, 1)+' - '+strtrim(date2, 1)+')' + +; read levitus data + std_file_Levitus_T = isafile(getenv('FILE_TEMP_3D'), title = 'Levitus_T', iodir = std_iodir_climato) + Lev = read_ncdf(getenv('VAR_TEMP_3D'), filename = std_file_Levitus_T, /nostruct ) + Lev_xyz = moyenne(Lev, 'xyz', mask2d = masknp) + levz = moyenne(temporary(Lev), 'xy', mask2d = masknp, /KEEPBOTTOM) +; + iodir = std_iodir_data +; + +; read exp1 data + std_ts_read, vtemp, date1, date2, prefix, suffix, ts_Temp, ts_z, masknp $ + , WITHSSH = vssh, SSHPREFIX = sshprefix, SSHSUFFIX = sshsuffix, LEVZ = levz + + title = prefix+' '+d1_d2+'!C'+blabla + pltt, ts_Temp, 't', MIN = 1., MAX = 4.5, date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, /PORTRAIT, _extra = ex + + title = prefix+' '+d1_d2+' - Levitus!C'+blabla + pltt, ts_Temp - Lev_xyz, 't', MIN = -1., MAX = 1., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + if KEYWORD_SET(postscript) then openps, filename+'_2.ps', portrait = 1 + + title = prefix+' '+d1_d2+' - Levitus!C ZT-plot (0-1500m) '+blabla + pltt, ts_z, 'zt', MIN = -2.,MAX = 2., inter = .1, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 1], YTITLE = varunit, TITLE = title, boxzoom = 1500., /portrait, window = 1, _extra = ex + + title = prefix+' '+d1_d2+' - Levitus!C ZT-plot (0-6000m) '+blabla + pltt, ts_z, 'zt', MIN = -2., MAX = 2., inter = .1, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, boxzoom = 6000., /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + IF prefix NE prefix2 THEN BEGIN + + d1_d2_2 = '('+strtrim(date1_2, 1)+' - '+strtrim(date2_2, 1)+')' +; read exp2 data + tsave = time + std_ts_read, vtemp2, date1_2, date2_2, prefix2, suffix2, ts_Temp2, ts_z2, masknp $ + , WITHSSH = vssh2, SSHPREFIX = sshprefix2, SSHSUFFIX = sshsuffix2, LEVZ = levz + time = tsave & IF n_elements(time) NE jpt THEN stop + + if KEYWORD_SET(postscript) then openps, filename+'_3.ps', portrait = 1 + + title = prefix+' - '+prefix2+' '+d1_d2_2+'!C'+blabla + pltt, ts_Temp - ts_Temp2, 't', MIN = -1., MAX = 1., date1, date2, /REMPLI, XGRIDSTYLE = 1 $ + , COLOR = 250, small = [1, 2, 1], YTITLE = varunit, TITLE = title, /PORTRAIT, window = 2, _extra = ex + + title = prefix+' - '+prefix2+' '+d1_d2_2+'!C ZT-plot (0-6000m) '+blabla + pltt, ts_z - ts_z2, 'zt', MIN = -1., MAX = 1., inter = .1, date1, date2, /REMPLI, style = 'so0so', XGRIDSTYLE = 1 $ + , small = [1, 2, 2], YTITLE = varunit, TITLE = title, boxzoom = 6000., /NOERASE, _extra = ex + + htmltxt = [ htmltxt, '
'+blabla, '
' ] + if KEYWORD_SET(postscript) then closeps + + ENDIF + + return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_all.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_all.pro new file mode 100644 index 0000000000000000000000000000000000000000..83f9d55227531d45df1eece2c984b09a3248d3a8 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_all.pro @@ -0,0 +1,89 @@ +pro std_ts_all, doplot = doplot, _extra=ex + + compile_opt idl2, strictarrsubs + +@common +@std_common + + PRINT, '' + PRINT, ' ############################################' + PRINT, '' + PRINT, ' plot of all TIME SERIES' + PRINT, '' + PRINT, ' ############################################' + PRINT, '' +; + std_iodir_data = isadirectory(getenv('DIR_DATA'), title = 'path of data in NetCdf format') + std_iodir_climato = isadirectory(getenv('DIR_CLIMATO'), title = 'path of climatological data') + std_iodir_mask = isadirectory(getenv('DIR_MASK'), title = 'path of mask files (ex: subbasins)') +; meshmask + std_file_mesh = isafile(getenv('FILE_MESH_MASK'), title = 'mesh_mask', iodir = std_iodir_mask) + std_file_msksub = isafile(getenv('FILE_MASK_SUBDOMAIN'), title = 'sub-bassin masks', iodir = std_iodir_mask) +; load the grid + load_orca, std_file_mesh +; reading variables + masknp = read_ncdf('tmaskutil', file = std_file_mesh, /nostruct, /cont_nofill) +; climatologies + std_file_Levitus_T = isafile(getenv('FILE_TEMP_3D'), title = 'Levitus_T', iodir = std_iodir_climato) + std_file_Levitus_S = isafile(getenv('FILE_SAL_3D'), title = 'Levitus_S', iodir = std_iodir_climato) + std_file_reynolds = isafile(getenv('FILE_SST'), title = 'Reynolds', iodir = std_iodir_climato) + std_file_oaflux = isafile(getenv('FILE_FLUX'), title = 'oaflux', iodir = std_iodir_climato) + std_file_mld = isafile(getenv('FILE_MLD'), title = 'Mixed layer depth', iodir = std_iodir_climato) + std_file_ice = isafile(getenv('FILE_ICE'), title = 'ICE', iodir = std_iodir_climato) + std_file_snow_arc = isafile(getenv('FILE_SNOW_ARC'), title = 'SNOW_ARC', iodir = std_iodir_climato) + std_file_snow_ant = isafile(getenv('FILE_SNOW_ANT'), title = 'SNOW_ANT', iodir = std_iodir_climato) + + + date1 = long(getenv('DATE1')) & date2 = long(getenv('DATE2')) + date1_2 = long(getenv('DATE1_2')) & date2_2 = long(getenv('DATE2_2')) + + allrec = 1 - keyword_set(long(getenv('READ_ONLY_FIRST_RECORD'))) + +;######################################################################### +;###################### STANDARD PLOTS ################################ +;######################################################################### + + IF keyword_set(doplot) EQ 0 THEN doplot = 0 + +; fixed color tabled + lct, 64 + cnt = 0 + htmltxt = '' +; + cnt = cnt+1 & blabla = 'Global Mean Temperature' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_T, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Mean Salinity' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_S, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Mean SSH' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_SSH, masknp, POSTSCRIPT = postscript, _extra = ex +; +;;;; cnt = cnt+1 & blabla = 'Global Mean Q net' +;;;; IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_Q, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Global Mean EMP' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_EMP, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Drake Transport' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_Drake, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Max AMOC' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_AMOC, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Sea-Ice Cover' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_ICE, masknp, POSTSCRIPT = postscript, _extra = ex +; + cnt = cnt+1 & blabla = 'Sea-Ice Volume' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_ICE_Vol, masknp, POSTSCRIPT = postscript, _extra = ex +;SF; and probably useless +;SF cnt = cnt+1 & blabla = 'ICE Velocity ' +;SF IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_ICE_Vel, masknp, POSTSCRIPT = postscript, _extra = ex +;SF; + cnt = cnt+1 & blabla = 'Sea-Ice Volume Export at Fram Strait' + IF doplot EQ cnt OR doplot EQ 0 THEN std_ts_ICE_FRAM, masknp, POSTSCRIPT = postscript, _extra = ex +; + IF n_elements(htmltxt) GT 1 THEN putfile, psdir+'std_ts_html_body.txt', htmltxt[1:*] + + return +END diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_read.pro b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_read.pro new file mode 100644 index 0000000000000000000000000000000000000000..18bcfe96f1bd3cee9395506c10da500e82f20cee --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_read.pro @@ -0,0 +1,44 @@ +PRO std_ts_read, var_name, dt1, dt2, prefix, suffix, ts, ts_z, masknp $ + , WITHSSH = withssh, SSHPREFIX = sshprefix, SSHSUFFIX = sshsuffix, LEVZ = levz + + compile_opt idl2, strictarrsubs + +@common +@std_common + + + list = rseries_ncdf(var_name, dt1, dt2, prefix, suffix, /fileslist) + nfiles = n_elements(list) + IF keyword_set(withssh) THEN BEGIN + sshlist = rseries_ncdf(withssh, dt1, dt2, sshprefix, sshsuffix, /fileslist) + IF nfiles NE n_elements(sshlist) THEN stop + ENDIF + + ts = 0. + ts_Time = 0. + ts_z = fltarr(jpk) + + FOR i = 0, nfiles-1 DO BEGIN + IF keyword_set(withssh) THEN ssh = read_ncdf(withssh, allrecords = allrec, filename = sshlist[i], /nostruct) + var = read_ncdf(var_name, allrecords = allrec, filename = list[i], /nostruct) + ts_Time = [ ts_Time, Time] +; + IF jpt EQ 1 THEN txyz = moyenne(var, 'xyz', mask2d = masknp, ssh = ssh) $ + ELSE txyz = grossemoyenne(var, 'xyz', mask2d = masknp, ssh = ssh) + ts = [ ts, txyz ] +; + IF jpt EQ 1 THEN tz = moyenne(temporary(var), 'xy', mask2d = masknp, ssh = ssh, /KEEPBOTTOM) $ + ELSE tz = grossemoyenne(temporary(var), 'xy', mask2d = masknp, ssh = ssh, /KEEPBOTTOM) + IF keyword_set(levz) THEN ts_z = [ [ts_z], [tz - (levz[*] # replicate(1., jpt))] ] $ + ELSE ts_z = [ [ts_z], [tz] ] + ENDFOR + + time = ts_Time[1:*] ; remove first record of 0 + jpt = n_elements(time) + + ts = ts[1:*] ; remove first record of 0 + ts_z = ts_z[*, 1:*] ; remove first record of 0 + + +return +end diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh new file mode 100644 index 0000000000000000000000000000000000000000..fb654c1bc31c02d41b91e438a5306f53235ed560 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh @@ -0,0 +1,133 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/ts_p4H25a50-testht_ps +PDF_DIR=$( pwd )/ts_p4H25a50-testht_pdf +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +DATE1=20010101 ; DATE2=20501231 +# +VAR1_T=thetao ; V1T_PREF=p4H25a50 ; V1T_SUFF=_1Y_grid_T.nc +VAR1_S=so ; V1S_PREF=p4H25a50 ; V1S_SUFF=_1Y_grid_T.nc +VAR1_SSH=zos ; V1SSH_PREF=p4H25a50 ; V1SSH_SUFF=_1Y_grid_T.nc +##VAR1_Q=qt ; V1Q_PREF=p4H25a50 ; V1Q_SUFF=_1Y_grid_T.nc +VAR1_EMP=wfo ; V1EMP_PREF=p4H25a50 ; V1EMP_SUFF=_1Y_grid_T.nc +VAR1_U=uocetr_eff ; V1U_PREF=p4H25a50 ; V1U_SUFF=_1Y_grid_U.nc +VAR1_V=vocetr_eff ; V1V_PREF=p4H25a50 ; V1V_SUFF=_1Y_grid_V.nc +VAR1_ICE=siconc ; V1ICE_PREF=p4H25a50 ; V1ICE_SUFF=_1M_icemod.nc +VAR1_Ithick=sithic ; V1It_PREF=p4H25a50 ; V1It_SUFF=_1M_icemod.nc +VAR1_SNOW=snthic ; V1SNOW_PREF=p4H25a50 ; V1SNOW_SUFF=_1M_icemod.nc +VAR1_IvelV=sivelv ; V1IvV_PREF=p4H25a50 ; V1IvV_SUFF=_1M_icemod.nc +VAR1_Ivel=sivelo ; V1Iv_PREF=p4H25a50 ; V1Iv_SUFF=_1M_icemod.nc +# +#===================== EXP2 ===================== +# +DATE1_2=20010101 ; DATE2_2=20501231 +# +VAR2_T=thetao ; V2T_PREF=testht ; V2T_SUFF=_1Y_grid_T.nc +VAR2_S=so ; V2S_PREF=testht ; V2S_SUFF=_1Y_grid_T.nc +VAR2_SSH=zos ; V2SSH_PREF=testht ; V2SSH_SUFF=_1Y_grid_T.nc +##VAR2_Q=qt ; V2Q_PREF=testht ; V2Q_SUFF=_1Y_grid_T.nc +VAR2_EMP=wfo ; V2EMP_PREF=testht ; V2EMP_SUFF=_1Y_grid_T.nc +VAR2_U=uocetr_eff ; V2U_PREF=testht ; V2U_SUFF=_1Y_grid_U.nc +VAR2_V=vocetr_eff ; V2V_PREF=testht ; V2V_SUFF=_1Y_grid_V.nc +VAR2_ICE=siconc ; V2ICE_PREF=testht ; V2ICE_SUFF=_1M_icemod.nc +VAR2_Ithick=sithic ; V2It_PREF=testht ; V2It_SUFF=_1M_icemod.nc +VAR2_SNOW=snthic ; V2SNOW_PREF=testht ; V2SNOW_SUFF=_1M_icemod.nc +VAR2_IvelV=sivelv ; V2IvV_PREF=testht ; V2IvV_SUFF=_1M_icemod.nc +VAR2_Ivel=sivelo ; V2IvV_PREF=testht ; V2IvV_SUFF=_1M_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +export VAR1_Ivel V1Iv_PREF V1Iv_SUFF + +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +export VAR2_Ivel V2Iv_PREF V2Iv_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh.new_names b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh.new_names new file mode 100644 index 0000000000000000000000000000000000000000..449da913dcfecf40a474eab6ec014c7a6ba4a2b7 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh.new_names @@ -0,0 +1,136 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/ts_sbcmodMV_ps +PDF_DIR=$( pwd )/ts_sbcmodMV_pdf +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +#DATE1=20010101 ; DATE2=25001231 +DATE1=20010101 ; DATE2=20501231 +#DATE1=00010101 ; DATE2=00101231 +# +VAR1_T=thetao ; V1T_PREF=sbcmodMV ; V1T_SUFF=_1Y_grid_T.nc +VAR1_S=so ; V1S_PREF=sbcmodMV ; V1S_SUFF=_1Y_grid_T.nc +VAR1_SSH=zos ; V1SSH_PREF=sbcmodMV ; V1SSH_SUFF=_1Y_grid_T.nc +VAR1_Q=tohfls ; V1Q_PREF=sbcmodMV ; V1Q_SUFF=_1Y_grid_T.nc +VAR1_EMP=wfo ; V1EMP_PREF=sbcmodMV ; V1EMP_SUFF=_1Y_grid_T.nc +VAR1_U=uocetr_eff ; V1U_PREF=sbcmodMV ; V1U_SUFF=_1Y_grid_U.nc +VAR1_V=vocetr_eff ; V1V_PREF=sbcmodMV ; V1V_SUFF=_1Y_grid_V.nc +VAR1_ICE=siconc ; V1ICE_PREF=sbcmodMV ; V1ICE_SUFF=_1M_icemod.nc +VAR1_Ithick=sithic ; V1It_PREF=sbcmodMV ; V1It_SUFF=_1M_icemod.nc +VAR1_SNOW=sndept ; V1SNOW_PREF=sbcmodMV ; V1SNOW_SUFF=_1M_icemod.nc +VAR1_IvelV=sivelv ; V1IvV_PREF=sbcmodMV ; V1IvV_SUFF=_1M_icemod.nc +VAR1_Ivel=sivelo ; V1Iv_PREF=sbcmodMV ; V1Iv_SUFF=_1M_icemod.nc +# +#===================== EXP2 ===================== +# +#DATE1_2=20010101 ; DATE2_2=20101231 +DATE1_2=20010101 ; DATE2_2=20501231 +# +VAR2_T=thetao ; V2T_PREF=sbcmodMV ; V2T_SUFF=_1Y_grid_T.nc +VAR2_S=so ; V2S_PREF=sbcmodMV ; V2S_SUFF=_1Y_grid_T.nc +VAR2_SSH=zos ; V2SSH_PREF=sbcmodMV ; V2SSH_SUFF=_1Y_grid_T.nc +VAR2_Q=tohfls ; V2Q_PREF=sbcmodMV ; V2Q_SUFF=_1Y_grid_T.nc +VAR2_EMP=wfo ; V2EMP_PREF=sbcmodMV ; V2EMP_SUFF=_1Y_grid_T.nc +VAR2_U=uocetr_eff ; V2U_PREF=sbcmodMV ; V2U_SUFF=_1Y_grid_U.nc +VAR2_V=vocetr_eff ; V2V_PREF=sbcmodMV ; V2V_SUFF=_1Y_grid_V.nc +VAR2_ICE=siconc ; V2ICE_PREF=sbcmodMV ; V2ICE_SUFF=_1M_icemod.nc +VAR2_Ithick=sithic ; V2It_PREF=sbcmodMV ; V2It_SUFF=_1M_icemod.nc +VAR2_SNOW=sndept ; V2SNOW_PREF=sbcmodMV ; V2SNOW_SUFF=_1M_icemod.nc +VAR2_IvelV=sivelv ; V2IvV_PREF=sbcmodMV ; V2IvV_SUFF=_1M_icemod.nc +VAR2_Ivel=sivelo ; V2Iv_PREF=sbcmodMV ; V2Iv_SUFF=_1M_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +export VAR1_Ivel V1Iv_PREF V1Iv_SUFF + +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +export VAR2_Ivel V2Iv_PREF V2Iv_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example1 b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example1 new file mode 100644 index 0000000000000000000000000000000000000000..ee026035501f9055d9a8a8954d6ee555f6d0cd88 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example1 @@ -0,0 +1,128 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/ps_tag33_tag331 +PDF_DIR=$( pwd )/pdf_tag33_tag331 +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +DATE1=20010101 ; DATE2=21001231 +# +VAR1_T=thetao ; V1T_PREF=tmx_2000 ; V1T_SUFF=_1Y_grid_T.nc +VAR1_S=so ; V1S_PREF=tmx_2000 ; V1S_SUFF=_1Y_grid_T.nc +VAR1_SSH=zos ; V1SSH_PREF=tmx_2000 ; V1SSH_SUFF=_1Y_grid_T.nc +VAR1_Q=qns+qsr ; V1Q_PREF=tmx_2000 ; V1Q_SUFF=_1Y_grid_T.nc +VAR1_EMP=wfo ; V1EMP_PREF=tmx_2000 ; V1EMP_SUFF=_1Y_grid_T.nc +VAR1_U=uoce_eff ; V1U_PREF=tmx_2000 ; V1U_SUFF=_1Y_grid_U.nc +VAR1_V=voce_eff ; V1V_PREF=tmx_2000 ; V1V_SUFF=_1Y_grid_V.nc +VAR1_ICE=sic ; V1ICE_PREF=tmx_2000 ; V1ICE_SUFF=_1M_icemod.nc +VAR1_Ithick=sit ; V1It_PREF=tmx_2000 ; V1It_SUFF=_1M_icemod.nc +VAR1_SNOW=isnowthi ; V1SNOW_PREF=tmx_2000 ; V1SNOW_SUFF=_1M_icemod.nc +VAR1_IvelV=vice_ipa ; V1IvV_PREF=tmx_2000 ; V1IvV_SUFF=_1M_icemod.nc +# +#===================== EXP2 ===================== +# +DATE1_2=10101 ; DATE2_2=20001231 +# +VAR2_T=thetao ; V2T_PREF=core2000 ; V2T_SUFF=_1Y_grid_T.nc +VAR2_S=so ; V2S_PREF=core2000 ; V2S_SUFF=_1Y_grid_T.nc +VAR2_SSH=zos ; V2SSH_PREF=core2000 ; V2SSH_SUFF=_1Y_grid_T.nc +VAR2_Q=qns+qsr ; V2Q_PREF=core2000 ; V2Q_SUFF=_1Y_grid_T.nc +VAR2_EMP=wfo ; V2EMP_PREF=core2000 ; V2EMP_SUFF=_1Y_grid_T.nc +VAR2_U=uoce_eff ; V2U_PREF=core2000 ; V2U_SUFF=_1Y_grid_U.nc +VAR2_V=voce_eff ; V2V_PREF=core2000 ; V2V_SUFF=_1Y_grid_V.nc +VAR2_ICE=sic ; V2ICE_PREF=core2000 ; V2ICE_SUFF=_1M_icemod.nc +VAR2_Ithick=sit ; V2It_PREF=core2000 ; V2It_SUFF=_1M_icemod.nc +VAR2_SNOW=isnowthi ; V2ICE_SNOW=core2000 ; V2SNOW_SUFF=_1M_icemod.nc +VAR2_IvelV=vice_ipa ; V2IvV_PREF=core2000 ; V2IvV_SUFF=_1M_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example2 b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example2 new file mode 100644 index 0000000000000000000000000000000000000000..6f2a2fb67f5faca0a3d4941dc92457d37219f798 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example2 @@ -0,0 +1,128 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/ps_tag33_tag331 +PDF_DIR=$( pwd )/pdf_tag33_tag331 +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +DATE1=20010101 ; DATE2=21001231 +# +VAR1_T=thetao ; V1T_PREF=tag33 ; V1T_SUFF=_1Y_grid_T.nc +VAR1_S=so ; V1S_PREF=tag33 ; V1S_SUFF=_1Y_grid_T.nc +VAR1_SSH=zos ; V1SSH_PREF=tag33 ; V1SSH_SUFF=_1Y_grid_T.nc +VAR1_Q=qt ; V1Q_PREF=tag33 ; V1Q_SUFF=_1Y_grid_T.nc +VAR1_EMP=wfo ; V1EMP_PREF=tag33 ; V1EMP_SUFF=_1Y_grid_T.nc +VAR1_U=uocetr_eff ; V1U_PREF=tag33 ; V1U_SUFF=_1Y_grid_U.nc +VAR1_V=vocetr_eff ; V1V_PREF=tag33 ; V1V_SUFF=_1Y_grid_V.nc +VAR1_ICE=sic ; V1ICE_PREF=tag33 ; V1ICE_SUFF=_1M_icemod.nc +VAR1_Ithick=sit ; V1It_PREF=tag33 ; V1It_SUFF=_1M_icemod.nc +VAR1_SNOW=isnowthi ; V1SNOW_PREF=tag33 ; V1SNOW_SUFF=_1M_icemod.nc +VAR1_IvelV=vice_ipa ; V1IvV_PREF=tag33 ; V1IvV_SUFF=_1M_icemod.nc +# +#===================== EXP2 ===================== +# +DATE1_2=20010101 ; DATE2_2=21001231 +# +VAR2_T=thetao ; V2T_PREF=trunk331 ; V2T_SUFF=_1Y_grid_T.nc +VAR2_S=so ; V2S_PREF=trunk331 ; V2S_SUFF=_1Y_grid_T.nc +VAR2_SSH=zos ; V2SSH_PREF=trunk331 ; V2SSH_SUFF=_1Y_grid_T.nc +VAR2_Q=qt ; V2Q_PREF=trunk331 ; V2Q_SUFF=_1Y_grid_T.nc +VAR2_EMP=wfo ; V2EMP_PREF=trunk331 ; V2EMP_SUFF=_1Y_grid_T.nc +VAR2_U=uocetr_eff ; V2U_PREF=trunk331 ; V2U_SUFF=_1Y_grid_U.nc +VAR2_V=vocetr_eff ; V2V_PREF=trunk331 ; V2V_SUFF=_1Y_grid_V.nc +VAR2_ICE=sic ; V2ICE_PREF=trunk331 ; V2ICE_SUFF=_1M_icemod.nc +VAR2_Ithick=sit ; V2It_PREF=trunk331 ; V2It_SUFF=_1M_icemod.nc +VAR2_SNOW=isnowthi ; V2ICE_SNOW=trunk331 ; V2SNOW_SUFF=_1M_icemod.nc +VAR2_IvelV=vice_ipa ; V2IvV_PREF=trunk331 ; V2IvV_SUFF=_1M_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_ipcc b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_ipcc new file mode 100644 index 0000000000000000000000000000000000000000..397eb70650384b0c1767881cadcaafc3edeff186 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_ipcc @@ -0,0 +1,133 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/ps_tag33_tag331 +PDF_DIR=$( pwd )/pdf_tag33_tag331 +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +DATE1=20010101 ; DATE2=21001231 +# +VAR1_T=thetao ; V1T_PREF=tag33 ; V1T_SUFF=_1Y_grid_T.nc +VAR1_S=so ; V1S_PREF=tag33 ; V1S_SUFF=_1Y_grid_T.nc +VAR1_SSH=zos ; V1SSH_PREF=tag33 ; V1SSH_SUFF=_1Y_grid_T.nc +VAR1_Q=qt ; V1Q_PREF=tag33 ; V1Q_SUFF=_1Y_grid_T.nc +VAR1_EMP=wfo ; V1EMP_PREF=tag33 ; V1EMP_SUFF=_1Y_grid_T.nc +VAR1_U=uocetr_eff ; V1U_PREF=tag33 ; V1U_SUFF=_1Y_grid_U.nc +VAR1_V=vocetr_eff ; V1V_PREF=tag33 ; V1V_SUFF=_1Y_grid_V.nc +VAR1_ICE=sic ; V1ICE_PREF=tag33 ; V1ICE_SUFF=_1M_icemod.nc +VAR1_Ithick=sit ; V1It_PREF=tag33 ; V1It_SUFF=_1M_icemod.nc +VAR1_SNOW=isnowthi ; V1SNOW_PREF=tag33 ; V1SNOW_SUFF=_1M_icemod.nc +VAR1_IvelV=iicevelv ; V1IvV_PREF=tag33 ; V1IvV_SUFF=_1M_icemod.nc +VAR1_Ivel=iicevelo ; V1Iv_PREF=tag33 ; V1Iv_SUFF=_1M_icemod.nc +# +#===================== EXP2 ===================== +# +DATE1_2=20010101 ; DATE2_2=21001231 +# +VAR2_T=thetao ; V2T_PREF=trunk331 ; V2T_SUFF=_1Y_grid_T.nc +VAR2_S=so ; V2S_PREF=trunk331 ; V2S_SUFF=_1Y_grid_T.nc +VAR2_SSH=zos ; V2SSH_PREF=trunk331 ; V2SSH_SUFF=_1Y_grid_T.nc +VAR2_Q=qt ; V2Q_PREF=trunk331 ; V2Q_SUFF=_1Y_grid_T.nc +VAR2_EMP=wfo ; V2EMP_PREF=trunk331 ; V2EMP_SUFF=_1Y_grid_T.nc +VAR2_U=uocetr_eff ; V2U_PREF=trunk331 ; V2U_SUFF=_1Y_grid_U.nc +VAR2_V=vocetr_eff ; V2V_PREF=trunk331 ; V2V_SUFF=_1Y_grid_V.nc +VAR2_ICE=sic ; V2ICE_PREF=trunk331 ; V2ICE_SUFF=_1M_icemod.nc +VAR2_Ithick=sit ; V2It_PREF=trunk331 ; V2It_SUFF=_1M_icemod.nc +VAR2_SNOW=isnowthi ; V2ICE_SNOW=trunk331 ; V2SNOW_SUFF=_1M_icemod.nc +VAR2_IvelV=iicevelv ; V2IvV_PREF=trunk331 ; V2IvV_SUFF=_1M_icemod.nc +VAR2_Ivel=iicevelo ; V2Iv_PREF=trunk331 ; V2Iv_SUFF=_1M_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +export VAR1_Ivel V1Iv_PREF V1Iv_SUFF + +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +export VAR2_Ivel V2Iv_PREF V2Iv_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_old_names b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_old_names new file mode 100644 index 0000000000000000000000000000000000000000..5484b873e8bb149ce12128e58846e1a73e74f9c2 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/IDL_scripts/std_ts_vardef.sh_example_old_names @@ -0,0 +1,133 @@ +#!/bin/sh +# +# AUTHOR - date +# =========== +# Sebastien Masson - 04/2011 - LOCEAN +# +# DESCRIPTION +# =========== +# define all varibles needed by std_ts.sh and std_ts.pro +# +# EXAMPLES +# ======== +# $ . ./std_ts_vardef.sh +# +# +#===================== User PATHS ===================== +# +idl_command=/Applications/itt/idl64/bin/idl +# +PS_DIR=$( pwd )/amax9999_ts_ps +PDF_DIR=$( pwd )/amax9999_ts_pdf +HTML_DIR=$( pwd )/html +SAXO_DIR=/Users/sflod/SAXO_DIR +# +DIR_DATA=/Users/sflod/idl_PLOTS/DATA_STORE/RUN_CLIMATO/lim3_ada # path of data in NetCDF format +DIR_CLIMATO=/Users/sflod/idl_PLOTS/CLIMATOLOGIES # path of climatological data +DIR_MASK=/Users/sflod/idl_PLOTS/MASK # path of mask files (ex: subbasins) +# +#===================== Model GRID ===================== +# +FILE_MESH_MASK=/Users/sflod/idl_PLOTS/MASK/ORL2PISV35_mesh_mask.nc # meshmask +FILE_MASK_SUBDOMAIN=subbasins_orca21_nored.nc # sub-bassin masks +# +#===================== DATA ===================== +# +VAR_TEMP_3D=votemper ; FILE_TEMP_3D=potT_annual_mean.nc # PHC3 +VAR_SAL_3D=vosaline ; FILE_SAL_3D=Salt_1y_corr_PHC3WOA09.nc # PHC3 +VAR_SST=sst ; FILE_SST=NewREY_ORCA2_1991_2000_1y.nc # Reynolds +VAR_FLUX=qnet ; FILE_FLUX=OAFlux_1my_01_12_1984_2004_orca2_qnet.nc # flux +VAR_MLD=mld ; FILE_MLD=mld_DR003_c1m_ORCA2_1y.nc # Mixed layer depth +VAR_ICE_EXT_NH=extt_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent North Emisphere +VAR_ICE_EXT_SH=extt_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Extent South Emisphere +VAR_ICE_area_NH=area_NH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area North Emisphere +VAR_ICE_area_SH=area_SH ; FILE_ICE=sea_ice_index_2000.nc # Ice Area South Emisphere +# +# Geothermal heating -> define FILE_GEOHEAT to 'NO' if there is not such forcing +# -> define VAR_GEOHEAT to a constant if geothermal heating is constant over the domain +VAR_GEOHEAT=heatflow ; FILE_GEOHEAT=geothermal_heating.nc +# +#===================== EXP1 ===================== +# +READ_ONLY_FIRST_RECORD=0 # if 0 then read all records in files else read only the first reacord in each file +# +DATE1=00010101 ; DATE2=00101231 +# +VAR1_T=votemper ; V1T_PREF=ow_amax9999 ; V1T_SUFF=_1m_grid_T.nc +VAR1_S=vosaline ; V1S_PREF=ow_amax9999 ; V1S_SUFF=_1m_grid_T.nc +VAR1_SSH=sossheig ; V1SSH_PREF=ow_amax9999 ; V1SSH_SUFF=_1m_grid_T.nc +VAR1_Q=sohefldo ; V1Q_PREF=ow_amax9999 ; V1Q_SUFF=_1m_grid_T.nc +VAR1_EMP=sowaflup ; V1EMP_PREF=ow_amax9999 ; V1EMP_SUFF=_1m_grid_T.nc +VAR1_U=uocetr_eff ; V1U_PREF=ow_amax9999 ; V1U_SUFF=_1m_grid_U.nc +VAR1_V=vocetr_eff ; V1V_PREF=ow_amax9999 ; V1V_SUFF=_1m_grid_V.nc +VAR1_ICE=iiceconc ; V1ICE_PREF=ow_amax9999 ; V1ICE_SUFF=_1m_icemod.nc +VAR1_Ithick=iicethic ; V1It_PREF=ow_amax9999 ; V1It_SUFF=_1m_icemod.nc +VAR1_SNOW=isnowthi ; V1SNOW_PREF=ow_amax9999 ; V1SNOW_SUFF=_1m_icemod.nc +VAR1_IvelV=sivelv ; V1IvV_PREF=ow_amax9999 ; V1IvV_SUFF=_1m_icemod.nc +VAR1_Ivel=sivelo ; V1Iv_PREF=ow_amax9999 ; V1Iv_SUFF=_1m_icemod.nc +# +#===================== EXP2 ===================== +# +DATE1_2=00010101 ; DATE2_2=00101231 +# +VAR2_T=votemper ; V2T_PREF=ow_amax9999 ; V2T_SUFF=_1m_grid_T.nc +VAR2_S=vosaline ; V2S_PREF=ow_amax9999 ; V2S_SUFF=_1m_grid_T.nc +VAR2_SSH=sossheig ; V2SSH_PREF=ow_amax9999 ; V2SSH_SUFF=_1m_grid_T.nc +VAR2_Q=sohefldo ; V2Q_PREF=ow_amax9999 ; V2Q_SUFF=_1m_grid_T.nc +VAR2_EMP=sowaflup ; V2EMP_PREF=ow_amax9999 ; V2EMP_SUFF=_1m_grid_T.nc +VAR2_U=uocetr_eff ; V2U_PREF=ow_amax9999 ; V2U_SUFF=_1m_grid_U.nc +VAR2_V=vocetr_eff ; V2V_PREF=ow_amax9999 ; V2V_SUFF=_1m_grid_V.nc +VAR2_ICE=iiceconc ; V2ICE_PREF=ow_amax9999 ; V2ICE_SUFF=_1m_icemod.nc +VAR2_Ithick=iicethic ; V2It_PREF=ow_amax9999 ; V2It_SUFF=_1m_icemod.nc +VAR2_SNOW=isnowthi ; V2SNOW_PREF=ow_amax9999 ; V2SNOW_SUFF=_1m_icemod.nc +VAR2_IvelV=sivelv ; V2IvV_PREF=ow_amax9999 ; V2IvV_SUFF=_1m_icemod.nc +VAR2_Ivel=sivelo ; V2IvV_PREF=ow_amax9999 ; V2IvV_SUFF=_1m_icemod.nc +# +######################### Export Variables ############################### +# +#===================== User PATHS ===================== +export PS_DIR PDF_DIR HTML_DIR SAXO_DIR +export DIR_DATA DIR_CLIMATO DIR_MASK +#===================== Model GRID ===================== +export FILE_MESH_MASK FILE_MASK_SUBDOMAIN +#===================== DATA ===================== +export FILE_TEMP_3D VAR_TEMP_3D +export FILE_SAL_3D VAR_SAL_3D +export FILE_SST VAR_SST +export FILE_GEOHEAT VAR_GEOHEAT +export FILE_FLUX VAR_FLUX +export FILE_MLD VAR_MLD +export FILE_ICE VAR_ICE_EXT_NH VAR_ICE_EXT_SH VAR_ICE_area_NH VAR_ICE_area_SH +export FILE_SNOW VAR_SNOW_NH VAR_SNOW_SH VAR_SNOW_area_NH VAR_SNOW_area_SH +#===================== EXP1 ===================== +export READ_ONLY_FIRST_RECORD +# +export DATE1 DATE2 +export VAR1_T V1T_PREF V1T_SUFF +export VAR1_S V1S_PREF V1S_SUFF +export VAR1_SSH V1SSH_PREF V1SSH_SUFF +export VAR1_Q V1Q_PREF V1Q_SUFF +export VAR1_EMP V1EMP_PREF V1EMP_SUFF +export VAR1_U V1U_PREF V1U_SUFF +export VAR1_V V1V_PREF V1V_SUFF +export VAR1_ICE V1ICE_PREF V1ICE_SUFF +export VAR1_Ithick V1It_PREF V1It_SUFF +export VAR1_SNOW V1SNOW_PREF V1SNOW_SUFF +export VAR1_IvelV V1IvV_PREF V1IvV_SUFF +export VAR1_Ivel V1Iv_PREF V1Iv_SUFF + +#===================== EXP2 ===================== +export DATE1_2 DATE2_2 +export VAR2_T V2T_PREF V2T_SUFF +export VAR2_S V2S_PREF V2S_SUFF +export VAR2_SSH V2SSH_PREF V2SSH_SUFF +export VAR2_Q V2Q_PREF V2Q_SUFF +export VAR2_EMP V2EMP_PREF V2EMP_SUFF +export VAR2_U V2U_PREF V2U_SUFF +export VAR2_V V2V_PREF V2V_SUFF +export VAR2_ICE V2ICE_PREF V2ICE_SUFF +export VAR2_Ithick V2It_PREF V2It_SUFF +export VAR2_SNOW V2SNOW_PREF V2SNOW_SUFF +export VAR2_IvelV V2IvV_PREF V2IvV_SUFF +export VAR2_Ivel V2Iv_PREF V2Iv_SUFF +# diff --git a/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm new file mode 100644 index 0000000000000000000000000000000000000000..c67c274170b663e3aaf4ade560fa024403de5b7d --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_si3 key_top key_iomput key_mpp_mpi diff --git a/V4.0/nemo_sources/cfgs/README.rst b/V4.0/nemo_sources/cfgs/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..b13565c081fafac1f46bf8d9207f637202f0858a --- /dev/null +++ b/V4.0/nemo_sources/cfgs/README.rst @@ -0,0 +1,331 @@ +******************************** +Run the Reference configurations +******************************** + +.. todo:: + + Lack of illustrations for ref. cfgs, and more generally in the guide. + +NEMO is distributed with a set of reference configurations allowing both +the user to set up his own first applications and +the developer to test/validate his NEMO developments (using SETTE package). + +.. contents:: + :local: + :depth: 1 + +.. attention:: + + Concerning the configurations, + the NEMO System Team is only in charge of the so-called reference configurations described below. + +.. hint:: + + Configurations developed by external research projects or initiatives that + make use of NEMO are welcome to be publicized through the website by + filling up the form :website:`to add an associated project`. + +How to compile an experiment from a reference configuration +=========================================================== + +To compile the ORCA2_ICE_PISCES_ reference configuration using :file:`makenemo`, +one should use the following, by selecting among available architecture file or +providing a user defined one: + +.. code-block:: console + + $ ./makenemo -r 'ORCA2_ICE_PISCES' -m 'my_arch' -j '4' + +A new ``EXP00`` folder will be created within the selected reference configurations, +namely ``./cfgs/ORCA2_ICE_PISCES/EXP00``. +It will be necessary to uncompress the archives listed in the above table for +the given reference configuration that includes input & forcing files. + +Then it will be possible to launch the execution of the model through a runscript +(opportunely adapted to the user system). + +List of Configurations +====================== + +All forcing files listed below in the table are available from |DOI data|_ + +=================== === === === === === ================================== + Configuration Component(s) Archives (input & forcing files) +------------------- ------------------- ---------------------------------- + Name O S T P A +=================== === === === === === ================================== + AGRIF_DEMO_ X X X AGRIF_DEMO_v4.0.tar, + ORCA2_ICE_v4.0.tar + AMM12_ X AMM12_v4.0.tar + C1D_PAPA_ X INPUTS_C1D_PAPA_v4.0.tar + GYRE_BFM_ X X *none* + GYRE_PISCES_ X X X *none* + ORCA2_ICE_PISCES_ X X X X ORCA2_ICE_v4.0.tar, + INPUTS_PISCES_v4.0.tar + ORCA2_OFF_PISCES_ X X ORCA2_OFF_v4.0.tar, + INPUTS_PISCES_v4.0.tar + ORCA2_OFF_TRC_ X ORCA2_OFF_v4.0.tar + ORCA2_SAS_ICE_ X ORCA2_ICE_v4.0.tar, + INPUTS_SAS_v4.0.tar + SPITZ12_ X X SPITZ12_v4.0.tar +=================== === === === === === ================================== + +.. admonition:: Legend for component combination + + O for OCE, S for SI\ :sup:`3`, T for TOP, P for PISCES and A for AGRIF + +AGRIF_DEMO +---------- + +``AGRIF_DEMO`` is based on the ``ORCA2_ICE_PISCES`` global configuration at 2° of resolution with +the inclusion of 3 online nested grids to demonstrate the overall capabilities of AGRIF in +a realistic context (including the nesting of sea ice models). + +The configuration includes a 1:1 grid in the Pacific and two successively nested grids with +odd and even refinement ratios over the Arctic ocean, +with the finest grid spanning the whole Svalbard archipelago that is of +particular interest to test sea ice coupling. + +.. image:: _static/AGRIF_DEMO_no_cap.jpg + :scale: 66% + :align: center + +The 1:1 grid can be used alone as a benchmark to check that +the model solution is not corrupted by grid exchanges. +Note that since grids interact only at the baroclinic time level, +numerically exact results can not be achieved in the 1:1 case. +Perfect reproducibility is obtained only by switching to a fully explicit setup instead of +a split explicit free surface scheme. + +AMM12 +----- + +``AMM12`` stands for *Atlantic Margin Model at 12 km* that is +a regional configuration covering the Northwest European Shelf domain on +a regular horizontal grid of ~12 km of resolution (see :cite:`ODEA2012`). + +.. image:: _static/AMM_domain.png + :align: center + +This configuration allows to tests several features of NEMO specifically addressed to the shelf seas. +In particular, ``AMM12`` accounts for vertical s-coordinates system, GLS turbulence scheme, +tidal lateral boundary conditions using a flather scheme (see more in ``BDY``). +Boundaries may be completely omitted by setting ``ln_bdy = .false.`` in ``nambdy``. + +Sample surface fluxes, river forcing and an initial restart file are included to test a realistic model run +(``AMM12_v4.0.tar``). + +Note that, the Baltic boundary is included within the river input file and is specified as a river source, +but unlike ordinary river points the Baltic inputs also include salinity and temperature data. + +C1D_PAPA +-------- + +.. figure:: _static/Papa2015.jpg + :height: 225px + :align: left + +``C1D_PAPA`` is a 1D configuration for the `PAPA station`_ located in +the northern-eastern Pacific Ocean at 50.1°N, 144.9°W. +See :gmd:`Reffray et al. (2015) <8/69/2015>` for the description of +its physical and numerical turbulent-mixing behaviour. + +| The water column setup, called NEMO1D, is activated with + the inclusion of the CPP key ``key_c1d`` and + has a horizontal domain of 3x3 grid points. +| This reference configuration uses 75 vertical levels grid (1m at the surface), + GLS turbulence scheme with K-epsilon closure and the NCAR bulk formulae. + +Data provided with ``INPUTS_C1D_PAPA_v4.0.tar`` file account for: + +- :file:`forcing_PAPASTATION_1h_y201[0-1].nc`: + ECMWF operational analysis atmospheric forcing rescaled to 1h + (with long and short waves flux correction) for years 2010 and 2011 +- :file:`init_PAPASTATION_m06d15.nc`: Initial Conditions from + observed data and Levitus 2009 climatology +- :file:`chlorophyll_PAPASTATION.nc`: surface chlorophyll file from Seawifs data + +GYRE_BFM +-------- + +``GYRE_BFM`` shares the same physical setup of GYRE_PISCES_, +but NEMO is coupled with the `BFM`_ biogeochemical model as described in ``./cfgs/GYRE_BFM/README``. + +GYRE_PISCES +----------- + +``GYRE_PISCES`` is an idealized configuration representing a Northern hemisphere double gyres system, +in the Beta-plane approximation with a regular 1° horizontal resolution and 31 vertical levels, +with PISCES BGC model :cite:`gmd-8-2465-2015`. +Analytical forcing for heat, freshwater and wind-stress fields are applied. + +This configuration acts also as demonstrator of the **user defined setup** +(``ln_read_cfg = .false.``) and grid setting are handled through +the ``&namusr_def`` controls in :file:`namelist_cfg`: + +.. literalinclude:: ../../../cfgs/GYRE_PISCES/EXPREF/namelist_cfg + :language: fortran + :lines: 35-41 + +Note that, the default grid size is 30x20 grid points (with ``nn_GYRE = 1``) and +vertical levels are set by ``jpkglo``. +The specific code changes can be inspected in :file:`./src/OCE/USR`. + +.. rubric:: Running GYRE as a benchmark + +| This simple configuration can be used as a benchmark since it is easy to increase resolution, + with the drawback of getting results that have a very limited physical meaning. +| GYRE grid resolution can be increased at runtime by setting a different value of ``nn_GYRE`` + (integer multiplier scaling factor), as described in the following table: + +=========== ============ ============ ============ =============== +``nn_GYRE`` ``jpiglo`` ``jpjglo`` ``jpkglo`` Equivalent to +=========== ============ ============ ============ =============== + 1 30 20 31 GYRE 1° + 25 750 500 101 ORCA 1/2° + 50 1500 1000 101 ORCA 1/4° + 150 4500 3000 101 ORCA 1/12° + 200 6000 4000 101 ORCA 1/16° +=========== ============ ============ ============ =============== + +| Note that, it is necessary to set ``ln_bench = .true.`` in ``&namusr_def`` to + avoid problems in the physics computation and that + the model timestep should be adequately rescaled. +| For example if ``nn_GYRE = 150``, equivalent to an ORCA 1/12° grid, + the timestep ``rn_rdt`` should be set to 1200 seconds + Differently from previous versions of NEMO, the code uses by default the time-splitting scheme and + internally computes the number of sub-steps. + +ORCA2_ICE_PISCES +---------------- + +``ORCA2_ICE_PISCES`` is a reference configuration for the global ocean with +a 2°x2° curvilinear horizontal mesh and 31 vertical levels, +distributed using z-coordinate system and with 10 levels in the top 100m. +ORCA is the generic name given to global ocean Mercator mesh, +(i.e. variation of meridian scale factor as cosinus of the latitude), +with two poles in the northern hemisphere so that +the ratio of anisotropy is nearly one everywhere + +This configuration uses the three components + +- |OCE|, the ocean dynamical core +- |ICE|, the thermodynamic-dynamic sea ice model. +- |MBG|, passive tracer transport module and PISCES BGC model :cite:`gmd-8-2465-2015` + +All components share the same grid. +The model is forced with CORE-II normal year atmospheric forcing and +it uses the NCAR bulk formulae. + +.. rubric:: Ocean Physics + +:horizontal diffusion on momentum: + the eddy viscosity coefficient depends on the geographical position. + It is taken as 40000 m\ :sup:`2`/s, reduced in the equator regions (2000 m\ :sup:`2`/s) + excepted near the western boundaries. +:isopycnal diffusion on tracers: + the diffusion acts along the isopycnal surfaces (neutral surface) with + an eddy diffusivity coefficient of 2000 m\ :sup:`2`/s. +:Eddy induced velocity parametrization: + With a coefficient that depends on the growth rate of baroclinic instabilities + (it usually varies from 15 m\ :sup:`2`/s to 3000 m\ :sup:`2`/s). +:lateral boundary conditions: + Zero fluxes of heat and salt and no-slip conditions are applied through lateral solid boundaries. +:bottom boundary condition: + Zero fluxes of heat and salt are applied through the ocean bottom. + The Beckmann [19XX] simple bottom boundary layer parameterization is applied along + continental slopes. + A linear friction is applied on momentum. +:convection: + The vertical eddy viscosity and diffusivity coefficients are increased to 1 m\ :sup:`2`/s in + case of static instability. +:time step: is 5400sec (1h30') so that there is 16 time steps in one day. + +ORCA2_OFF_PISCES +---------------- + +``ORCA2_OFF_PISCES`` shares the same general offline configuration of ``ORCA2_ICE_TRC``, +but only PISCES model is an active component of TOP. + +ORCA2_OFF_TRC +------------- + +| ``ORCA2_OFF_TRC`` is based on the ORCA2 global ocean configuration + (see ORCA2_ICE_PISCES_ for general description) along with + the tracer passive transport module (TOP), + but dynamical fields are pre-calculated and read with specific time frequency. +| This enables for an offline coupling of TOP components, + here specifically inorganic carbon compounds (CFC11, CFC12, SF6, C14) and water age module (age). + See :file:`namelist_top_cfg` to inspect the selection of + each component with the dedicated logical keys. + +Pre-calculated dynamical fields are provided to NEMO using +the namelist ``&namdta_dyn`` in :file:`namelist_cfg`, +in this case with a 5 days frequency (120 hours): + +.. literalinclude:: ../../namelists/namdta_dyn + :language: fortran + +Input dynamical fields for this configuration (:file:`ORCA2_OFF_v4.0.tar`) comes from +a 2000 years long climatological simulation of ORCA2_ICE using ERA40 atmospheric forcing. + +| Note that, + this configuration default uses linear free surface (``ln_linssh = .true.``) assuming that + model mesh is not varying in time and + it includes the bottom boundary layer parameterization (``ln_trabbl = .true.``) that + requires the provision of BBL coefficients through ``sn_ubl`` and ``sn_vbl`` fields. +| It is also possible to activate PISCES model (see ``ORCA2_OFF_PISCES``) or + a user defined set of tracers and source-sink terms with ``ln_my_trc = .true.`` + (and adaptation of ``./src/TOP/MY_TRC`` routines). + +In addition, the offline module (OFF) allows for the provision of further fields: + +1. **River runoff** can be provided to TOP components by setting ``ln_dynrnf = .true.`` and + by including an input datastream similarly to the following: + + .. code-block:: fortran + + sn_rnf = 'dyna_grid_T', 120, 'sorunoff' , .true., .true., 'yearly', '', '', '' + +2. **VVL dynamical fields**, in the case input data were produced by a dyamical core using + variable volume (``ln_linssh = .false.``) + it is necessary to provide also diverce and E-P at before timestep by + including input datastreams similarly to the following + + .. code-block:: fortran + + sn_div = 'dyna_grid_T', 120, 'e3t' , .true., .true., 'yearly', '', '', '' + sn_empb = 'dyna_grid_T', 120, 'sowaflupb', .true., .true., 'yearly', '', '', '' + +More details can be found by inspecting the offline data manager in +the routine :file:`./src/OFF/dtadyn.F90`. + +ORCA2_SAS_ICE +------------- + +| ORCA2_SAS_ICE is a demonstrator of the Stand-Alone Surface (SAS) module and + it relies on ORCA2 global ocean configuration (see ORCA2_ICE_PISCES_ for general description). +| The standalone surface module allows surface elements such as sea-ice, iceberg drift, and + surface fluxes to be run using prescribed model state fields. + It can profitably be used to compare different bulk formulae or + adjust the parameters of a given bulk formula. + +More informations about SAS can be found in :doc:`NEMO manual `. + +SPITZ12 +------- + +``SPITZ12`` is a regional configuration around the Svalbard archipelago +at 1/12° of horizontal resolution and 75 vertical levels. +See :gmd:`Rousset et al. (2015) <8/2991/2015>` for more details. + +This configuration references to year 2002, +with atmospheric forcing provided every 2 hours using NCAR bulk formulae, +while lateral boundary conditions for dynamical fields have 3 days time frequency. + +.. rubric:: References + +.. bibliography:: cfgs.bib + :all: + :style: unsrt + :labelprefix: C diff --git a/V4.0/nemo_sources/cfgs/SHARED/README.namelists b/V4.0/nemo_sources/cfgs/SHARED/README.namelists new file mode 100644 index 0000000000000000000000000000000000000000..b4799e635bcef0e65ff3cbe9b16ef3542f59cbf1 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/SHARED/README.rst b/V4.0/nemo_sources/cfgs/SHARED/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..2adfd0ac5031b9de1d0a20cd54ca3a21aebfa2c1 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/SHARED/axis_def_nemo.xml b/V4.0/nemo_sources/cfgs/SHARED/axis_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..a7d66bc6a820460428095e722764d0dfbcf5c2ba --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/axis_def_nemo.xml @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/SHARED/domain_def_nemo.xml b/V4.0/nemo_sources/cfgs/SHARED/domain_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..e9b8309457088888b000d39f5fc1bae4f690538c --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/domain_def_nemo.xml @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-ice.xml b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..170c0a7915dca7745f6e429eda0c5b25a5d273b2 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-ice.xml @@ -0,0 +1,632 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 + + this * maskMFO_u_ice + + @ymtrpice + ymtrpice_ave + + this * maskMFO_v_ice + + @xmtrpsnw + xmtrpsnw_ave + + this * maskMFO_u_ice + + @ymtrpsnw + ymtrpsnw_ave + + this * maskMFO_v_ice + + @xatrp + xatrp_ave + + this * maskMFO_u_ice + + @yatrp + yatrp_ave + + this * maskMFO_v_ice + + xstrait_mifl + ystrait_mifl + xstrait_msfl + ystrait_msfl + xstrait_arfl + ystrait_arfl + + + + + + + + + + + + + + + + + + + + + + + + + + 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/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-innerttrc.xml b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-innerttrc.xml new file mode 100644 index 0000000000000000000000000000000000000000..2ccfbd714368c518cb3ed1d8ee7880c66510e9ba --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-innerttrc.xml @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + CFC11 * e3t + + + + + + CFC12 * e3t + + + + + + SF6 * e3t + + + + + + RC14 * e3t + + + + + + + + + + + + + + Age * e3t + + + + diff --git a/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-oce.xml b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..f7e82c8b6b4cf17b0f19bcd7c2129b48f550dc2b --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-oce.xml @@ -0,0 +1,1042 @@ + + + + + + + + + + + + + + + + + + + + + toce * e3t + + soce * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + + + + + + + + sst * sst + + + + + + + + + + + + sss * sss + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + this * maskMFO_u * $rau0 + + @voce_e3v + + this * e1v + + this * maskMFO_v * $rau0 + + u_masstr_strait + v_masstr_strait + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-pisces.xml b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-pisces.xml new file mode 100644 index 0000000000000000000000000000000000000000..c6210558a3a36d07cf1926cc6fdf819b4ea31c75 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/field_def_nemo-pisces.xml @@ -0,0 +1,319 @@ + + + + + + + + + + + + + + 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/V4.0/nemo_sources/cfgs/SHARED/grid_def_nemo.xml b/V4.0/nemo_sources/cfgs/SHARED/grid_def_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..ff6fdefea05b41ed88da98d39c6559287cf2f2ca --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/grid_def_nemo.xml @@ -0,0 +1,268 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/cfgs/SHARED/namelist_ice_ref b/V4.0/nemo_sources/cfgs/SHARED/namelist_ice_ref new file mode 100644 index 0000000000000000000000000000000000000000..1c3e5f5ad770509cbbd836d6cf1b2807eaca41ef --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/namelist_ice_ref @@ -0,0 +1,269 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! 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 snw layers + 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 ?? + 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/V4.0/nemo_sources/cfgs/SHARED/namelist_pisces_ref b/V4.0/nemo_sources/cfgs/SHARED/namelist_pisces_ref new file mode 100644 index 0000000000000000000000000000000000000000..37fb5da76e0def997ea8f025a16939da6fccd7ad --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/SHARED/namelist_ref b/V4.0/nemo_sources/cfgs/SHARED/namelist_ref new file mode 100644 index 0000000000000000000000000000000000000000..bffece9584731a7122888fabf63c7164a7ddb8f0 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/SHARED/namelist_ref @@ -0,0 +1,1380 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! 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 +/ +!----------------------------------------------------------------------- +&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_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 (safe value is 0.4, see #2581) + + 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 = .false. ! = 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/V4.0/nemo_sources/cfgs/SHARED/namelist_top_ref b/V4.0/nemo_sources/cfgs/SHARED/namelist_top_ref new file mode 100644 index 0000000000000000000000000000000000000000..49108fd1c10c9a50e89a1027b7c6226160e998b7 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/SHARED/namelist_trc_ref b/V4.0/nemo_sources/cfgs/SHARED/namelist_trc_ref new file mode 100644 index 0000000000000000000000000000000000000000..109393b60b46cd0c90285a518cdfc6f9abf95a0b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/cfgs/ref_cfgs.txt b/V4.0/nemo_sources/cfgs/ref_cfgs.txt new file mode 100644 index 0000000000000000000000000000000000000000..55c88d0c08bc7cd6efafb438347daa389d4ee6ad --- /dev/null +++ b/V4.0/nemo_sources/cfgs/ref_cfgs.txt @@ -0,0 +1,10 @@ +AGRIF_DEMO OCE ICE NST +AMM12 OCE +C1D_PAPA OCE +GYRE_BFM OCE TOP +GYRE_PISCES OCE TOP +ORCA2_OFF_PISCES OCE TOP OFF +ORCA2_OFF_TRC OCE TOP OFF +ORCA2_SAS_ICE OCE ICE NST SAS +ORCA2_ICE_PISCES OCE TOP ICE NST +SPITZ12 OCE ICE diff --git a/V4.0/nemo_sources/cfgs/work_cfgs.txt b/V4.0/nemo_sources/cfgs/work_cfgs.txt new file mode 100644 index 0000000000000000000000000000000000000000..39c583fed297df4c763cfb602ed256aa4ff65341 --- /dev/null +++ b/V4.0/nemo_sources/cfgs/work_cfgs.txt @@ -0,0 +1,19 @@ +ORCA2_OCE_ICE_DEBUG OCE ICE +ORCA2_OCE_ICE_RPE OCE ICE +ORCA2_OCE_ICE_RPE_TEST OCE ICE +ORCA2_OCE_ICE OCE ICE +ORCA1_OCE_ICE_DEBUG OCE ICE +ORCA1_OCE_ICE_GNU_2 OCE ICE +ORCA1_OCE_ICE_GNU_PREPROC OCE ICE +ORCA1_OCE_ICE_GNU OCE ICE +ORCA1_OCE_ICE_GNU_GOOD OCE ICE +ORCA1_OCE_ICE_MIXED_DEBUG OCE ICE +ORCA1_OCE_ICE_MIXED OCE ICE +ORCA1_OCE_ICE_MIXED_OCAST OCE ICE +ORCA1_OCE_ICE_MIXED_NOVECTOR OCE ICE +ORCA1_OCE_ICE_GNU_MIXED_DEBUG OCE ICE +ORCA1_OCE_ICE_GNU_MIXED OCE ICE +ORCA1_OCE_ICE_MIXED_NOBUG OCE ICE +ORCA12_OCE_ICE_MIXED_NOBUG OCE ICE +ORCA1_OCE_ICE_MIXED_ORIGINAL_DEBUG OCE ICE +ORCA1_OCE_ICE_MIXED_ORIGINAL OCE ICE diff --git a/V4.0/nemo_sources/compile_nemo.sh b/V4.0/nemo_sources/compile_nemo.sh new file mode 100755 index 0000000000000000000000000000000000000000..e7485e4136145e74e10849003164a96295797f87 --- /dev/null +++ b/V4.0/nemo_sources/compile_nemo.sh @@ -0,0 +1,22 @@ + +#Load modules +source ../utils/functions.sh +set_environment + +#Choose name of cfg +CFG_NAME_DOUBLE=eORCA12_OCE_ICE_DOUBLE + +#CFG_NAME_MIXED=eORCA12_OCE_ICE_MIXED + +#Choose arch (for MN4 it's either mn0 or mn0-debug) +ARCH=mn0 + +#Choose compilation keys +CONFIGURATION_DOUBLE=-r ORCA2_ICE_PISCES -d 'OCE ICE' del_key 'key_top' add_key 'key_asminc key_netcdf4 key_sms key_xios2' + +CONFIGURATION_MIXED=-r ORCA2_ICE_PISCES -d 'OCE ICE' del_key 'key_top' add_key 'key_asminc key_netcdf4 key_sms key_xios2 key_single' + +#compile NEMO +./makenemo -m ${ARCH} -n ${CFG_NAME_DOUBLE} -r ${CONFIGURATION_DOUBLE} + +#./makenemo -m ${ARCH} -n ${CFG_NAME_MIXED} -r ${CONFIGURATION_MIXED} diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modarrays.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modarrays.F90 new file mode 100644 index 0000000000000000000000000000000000000000..971ea6c7a42773b8397acede153f6959e953bc27 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modarrays.F90 @@ -0,0 +1,826 @@ +! +! $Id: modarrays.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Arrays +! +module Agrif_Arrays +! + use Agrif_Types + use Agrif_Grids +! + implicit none +! +#if defined AGRIF_MPI + interface + subroutine Agrif_InvLoc ( indloc, proc_id, dir, indglob ) + integer, intent(in) :: indloc !< local index + integer, intent(in) :: proc_id !< rank of the proc calling this function + integer, intent(in) :: dir !< direction of the index + integer, intent(out) :: indglob !< global index + end subroutine Agrif_InvLoc + end interface + private :: Agrif_InvLoc +#endif +! +contains +! +!=================================================================================================== +! subroutine Agrif_Childbounds +! +!> Computes the global indices of the child grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Childbounds ( nbdim, & + lb_var, ub_var, & + lb_tab, ub_tab, & + proc_id, & + coords, & + lb_tab_true, ub_tab_true, memberin ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: nbdim !< Number of dimensions + integer, dimension(nbdim), intent(in) :: lb_var !< Local lower boundary on the current processor + integer, dimension(nbdim), intent(in) :: ub_var !< Local upper boundary on the current processor + integer, dimension(nbdim), intent(in) :: lb_tab !< Global lower boundary of the variable + integer, dimension(nbdim), intent(in) :: ub_tab !< Global upper boundary of the variable + integer, intent(in) :: proc_id !< Current processor + integer, dimension(nbdim), intent(in) :: coords + integer, dimension(nbdim), intent(out) :: lb_tab_true !< Global value of lb_var on the current processor + integer, dimension(nbdim), intent(out) :: ub_tab_true !< Global value of ub_var on the current processor + logical, intent(out) :: memberin +! + integer :: i, coord_i + integer :: lb_glob_index, ub_glob_index ! Lower and upper global indices +! + do i = 1, nbdim +! + coord_i = coords(i) +! +#if defined AGRIF_MPI + call Agrif_InvLoc( lb_var(i), proc_id, coord_i, lb_glob_index ) + call Agrif_InvLoc( ub_var(i), proc_id, coord_i, ub_glob_index ) +#else + lb_glob_index = lb_var(i) + ub_glob_index = ub_var(i) +#endif + lb_tab_true(i) = max(lb_tab(i), lb_glob_index) + ub_tab_true(i) = min(ub_tab(i), ub_glob_index) + enddo +! + memberin = .true. + do i = 1,nbdim + if (ub_tab_true(i) < lb_tab_true(i)) then + memberin = .false. + exit + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Childbounds +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_get_var_global_bounds( var, lubglob, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(in) :: var + integer, dimension(nbdim,2), intent(out) :: lubglob + integer, intent(in) :: nbdim +! +#if defined AGRIF_MPI + include 'mpif.h' + integer, dimension(nbdim) :: lb, ub + integer, dimension(nbdim,2) :: iminmaxg + integer :: i, code, coord_i +#endif +! +#if !defined AGRIF_MPI + call Agrif_get_var_bounds_array(var, lubglob(:,1), lubglob(:,2), nbdim) +#else + call Agrif_get_var_bounds_array(var, lb, ub, nbdim) + + do i = 1,nbdim + coord_i = var % root_var % coords(i) + call Agrif_InvLoc( lb(i), Agrif_Procrank, coord_i, iminmaxg(i,1) ) + call Agrif_InvLoc( ub(i), Agrif_Procrank, coord_i, iminmaxg(i,2) ) + enddo +! + iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2) + call MPI_ALLREDUCE(iminmaxg, lubglob, 2*nbdim, MPI_INTEGER, MPI_MIN, Agrif_mpi_comm, code) + lubglob(1:nbdim,2) = - lubglob(1:nbdim,2) +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_get_var_global_bounds +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_get_var_bounds +! +!> Gets the lower and the upper boundaries of a variable, for one particular direction. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_get_var_bounds ( variable, lower, upper, index ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(in) :: variable !< Variable for which we want to extract boundaries + integer, intent(out) :: lower !< Lower bound + integer, intent(out) :: upper !< Upper bound + integer, intent(in) :: index !< Direction for wich we want to know the boundaries +! + lower = variable % lb(index) + upper = variable % ub(index) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_get_var_bounds +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_get_var_bounds_array +! +!> Gets the lower and the upper boundaries of a table. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_get_var_bounds_array ( variable, lower, upper, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(in) :: variable !< Variable for which we want to extract boundaries + integer, dimension(nbdim), intent(out) :: lower !< Lower bounds array + integer, dimension(nbdim), intent(out) :: upper !< Upper bounds array + integer, intent(in) :: nbdim !< Numer of dimensions of the variable +! + lower = variable % lb(1:nbdim) + upper = variable % ub(1:nbdim) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_get_var_bounds_array +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_array_allocate +! +!> Allocates data array in \b variable, according to the required dimension. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_array_allocate ( variable, lb, ub, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: variable !< Variable struct for allocation + integer, dimension(nbdim), intent(in) :: lb !< Lower bound + integer, dimension(nbdim), intent(in) :: ub !< Upper bound + integer, intent(in) :: nbdim !< Dimension of the array +! + select case (nbdim) + case (1) ; allocate(variable%array1(lb(1):ub(1))) + case (2) ; allocate(variable%array2(lb(1):ub(1),lb(2):ub(2))) + case (3) ; allocate(variable%array3(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + case (4) ; allocate(variable%array4(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4))) + case (5) ; allocate(variable%array5(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),lb(5):ub(5))) + case (6) ; allocate(variable%array6(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),lb(5):ub(5),lb(6):ub(6))) + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_array_allocate +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_array_deallocate +! +!> Dellocates data array in \b variable, according to the required dimension. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_array_deallocate ( variable, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: variable !< Variable struct for deallocation + integer, intent(in) :: nbdim !< Dimension of the array +! + select case (nbdim) + case (1) ; deallocate(variable%array1) + case (2) ; deallocate(variable%array2) + case (3) ; deallocate(variable%array3) + case (4) ; deallocate(variable%array4) + case (5) ; deallocate(variable%array5) + case (6) ; deallocate(variable%array6) + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_array_deallocate +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_var_set_array_tozero +! +!> Reset the value of the data array in \b variable, according to the required dimension. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_var_set_array_tozero ( variable, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: variable !< Variable + integer, intent(in) :: nbdim !< Dimension of the array you want to reset +! + select case (nbdim) + case (1) ; call Agrif_set_array_tozero_1D(variable%array1) + case (2) ; call Agrif_set_array_tozero_2D(variable%array2) + case (3) ; call Agrif_set_array_tozero_3D(variable%array3) + case (4) ; call Agrif_set_array_tozero_4D(variable%array4) + case (5) ; call Agrif_set_array_tozero_5D(variable%array5) + case (6) ; call Agrif_set_array_tozero_6D(variable%array6) + end select +!--------------------------------------------------------------------------------------------------- +contains +!--------------------------------------------------------------------------------------------------- + subroutine Agrif_set_array_tozero_1D ( array ) + real, dimension(:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_1D +! + subroutine Agrif_set_array_tozero_2D ( array ) + real, dimension(:,:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_2D +! + subroutine Agrif_set_array_tozero_3D ( array ) + real, dimension(:,:,:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_3D +! + subroutine Agrif_set_array_tozero_4D ( array ) + real, dimension(:,:,:,:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_4D +! + subroutine Agrif_set_array_tozero_5D ( array ) + real, dimension(:,:,:,:,:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_5D +! + subroutine Agrif_set_array_tozero_6D ( array ) + real, dimension(:,:,:,:,:,:), intent(out) :: array + array = 0. + end subroutine Agrif_set_array_tozero_6D +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_var_set_array_tozero +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_var_copy_array +! +!> Copy a part of data array from var2 to var1 +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_var_copy_array ( var1, inf1, sup1, var2, inf2, sup2, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: var1 !< Modified variable + integer, dimension(nbdim), intent(in) :: inf1 !< Lower boundary for var1 + integer, dimension(nbdim), intent(in) :: sup1 !< Upper boundary for var1 + type(Agrif_Variable), intent(in) :: var2 !< Input variable + integer, dimension(nbdim), intent(in) :: inf2 !< Lower boundary for var2 + integer, dimension(nbdim), intent(in) :: sup2 !< Upper boundary for var2 + integer, intent(in) :: nbdim !< Dimension of the array +! + select case (nbdim) + case (1) ; var1%array1(inf1(1):sup1(1)) = var2%array1(inf2(1):sup2(1)) + case (2) ; call Agrif_copy_array_2d( var1%array2, var2%array2, & + lbound(var1%array2), lbound(var2%array2), inf1, sup1, inf2, sup2 ) + case (3) ; call Agrif_copy_array_3d( var1%array3, var2%array3, & + lbound(var1%array3), lbound(var2%array3), inf1, sup1, inf2, sup2 ) + case (4) ; call Agrif_copy_array_4d( var1%array4, var2%array4, & + lbound(var1%array4), lbound(var2%array4), inf1, sup1, inf2, sup2 ) + case (5) ; var1%array5(inf1(1):sup1(1), & + inf1(2):sup1(2), & + inf1(3):sup1(3), & + inf1(4):sup1(4), & + inf1(5):sup1(5)) = var2%array5(inf2(1):sup2(1), & + inf2(2):sup2(2), & + inf2(3):sup2(3), & + inf2(4):sup2(4), & + inf2(5):sup2(5)) + case (6) ; var1%array6(inf1(1):sup1(1), & + inf1(2):sup1(2), & + inf1(3):sup1(3), & + inf1(4):sup1(4), & + inf1(5):sup1(5), & + inf1(6):sup1(6)) = var2%array6(inf2(1):sup2(1), & + inf2(2):sup2(2), & + inf2(3):sup2(3), & + inf2(4):sup2(4), & + inf2(5):sup2(5), & + inf2(6):sup2(6)) + end select +!--------------------------------------------------------------------------------------------------- +contains +!--------------------------------------------------------------------------------------------------- + subroutine Agrif_copy_array_2d ( tabout, tabin, l, m, inf1, sup1, inf2, sup2 ) + integer, dimension(2), intent(in) :: l, m + integer, dimension(2), intent(in) :: inf1, sup1 + integer, dimension(2), intent(in) :: inf2, sup2 + real, dimension(l(1):,l(2):), intent(out) :: tabout + real, dimension(m(1):,m(2):), intent(in) :: tabin + tabout(inf1(1):sup1(1), & + inf1(2):sup1(2)) = tabin(inf2(1):sup2(1), & + inf2(2):sup2(2)) + end subroutine Agrif_copy_array_2d +! + subroutine Agrif_copy_array_3d ( tabout, tabin, l, m, inf1, sup1, inf2, sup2 ) + integer, dimension(3), intent(in) :: l, m + integer, dimension(3), intent(in) :: inf1, sup1 + integer, dimension(3), intent(in) :: inf2,sup2 + real, dimension(l(1):,l(2):,l(3):), intent(out) :: tabout + real, dimension(m(1):,m(2):,m(3):), intent(in) :: tabin + tabout(inf1(1):sup1(1), & + inf1(2):sup1(2), & + inf1(3):sup1(3)) = tabin(inf2(1):sup2(1), & + inf2(2):sup2(2), & + inf2(3):sup2(3)) + end subroutine Agrif_copy_array_3d +! + subroutine Agrif_copy_array_4d ( tabout, tabin, l, m, inf1, sup1, inf2, sup2 ) + integer, dimension(4), intent(in) :: l, m + integer, dimension(4), intent(in) :: inf1, sup1 + integer, dimension(4), intent(in) :: inf2, sup2 + real, dimension(l(1):,l(2):,l(3):,l(4):), intent(out) :: tabout + real, dimension(m(1):,m(2):,m(3):,m(4):), intent(in) :: tabin + tabout(inf1(1):sup1(1), & + inf1(2):sup1(2), & + inf1(3):sup1(3), & + inf1(4):sup1(4)) = tabin(inf2(1):sup2(1), & + inf2(2):sup2(2), & + inf2(3):sup2(3), & + inf2(4):sup2(4)) + end subroutine Agrif_copy_array_4d +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_var_copy_array +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_var_full_copy_array +! +!> Copy the full data array from var2 to var1 +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_var_full_copy_array ( var1, var2, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: var1 !< Modified variable + type(Agrif_Variable), intent(in) :: var2 !< Input variable + integer, intent(in) :: nbdim !< Dimension of the array +! + select case (nbdim) + case (1) ; var1 % array1 = var2 % array1 + case (2) ; var1 % array2 = var2 % array2 + case (3) ; var1 % array3 = var2 % array3 + case (4) ; var1 % array4 = var2 % array4 + case (5) ; var1 % array5 = var2 % array5 + case (6) ; var1 % array6 = var2 % array6 + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_var_full_copy_array +!=================================================================================================== +! +!=================================================================================================== +! subroutine GiveAgrif_SpecialValueToTab_mpi +! +!> Copy \b value in data array \b var2 where it is present in \b var1. +!--------------------------------------------------------------------------------------------------- +subroutine GiveAgrif_SpecialValueToTab_mpi ( var1, var2, bounds, value, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(in) :: var1 !< Modified variable + type(Agrif_Variable), intent(inout) :: var2 !< Input variable + integer, dimension(:,:,:), intent(in) :: bounds !< Bound for both arrays + real, intent(in) :: value !< Special value + integer, intent(in) :: nbdim !< Dimension of the array +! + select case (nbdim) + case (1) + where (var1 % array1(bounds(1,1,2):bounds(1,2,2)) == value ) + var2 % array1(bounds(1,1,1):bounds(1,2,1)) = value + end where + case (2) + where (var1 % array2(bounds(1,1,2):bounds(1,2,2), & + bounds(2,1,2):bounds(2,2,2)) == value) + var2 % array2(bounds(1,1,1):bounds(1,2,1), & + bounds(2,1,1):bounds(2,2,1)) = value + end where + case (3) + where (var1 % array3(bounds(1,1,2):bounds(1,2,2), & + bounds(2,1,2):bounds(2,2,2), & + bounds(3,1,2):bounds(3,2,2)) == value) + var2 % array3(bounds(1,1,1):bounds(1,2,1), & + bounds(2,1,1):bounds(2,2,1), & + bounds(3,1,1):bounds(3,2,1)) = value + end where + case (4) + where (var1 % array4(bounds(1,1,2):bounds(1,2,2), & + bounds(2,1,2):bounds(2,2,2), & + bounds(3,1,2):bounds(3,2,2), & + bounds(4,1,2):bounds(4,2,2)) == value) + var2 % array4(bounds(1,1,1):bounds(1,2,1), & + bounds(2,1,1):bounds(2,2,1), & + bounds(3,1,1):bounds(3,2,1), & + bounds(4,1,1):bounds(4,2,1)) = value + end where + case (5) + where (var1 % array5(bounds(1,1,2):bounds(1,2,2), & + bounds(2,1,2):bounds(2,2,2), & + bounds(3,1,2):bounds(3,2,2), & + bounds(4,1,2):bounds(4,2,2), & + bounds(5,1,2):bounds(5,2,2)) == value) + var2 % array5(bounds(1,1,1):bounds(1,2,1), & + bounds(2,1,1):bounds(2,2,1), & + bounds(3,1,1):bounds(3,2,1), & + bounds(4,1,1):bounds(4,2,1), & + bounds(5,1,1):bounds(5,2,1)) = value + end where + case (6) + where (var1 % array6(bounds(1,1,2):bounds(1,2,2), & + bounds(2,1,2):bounds(2,2,2), & + bounds(3,1,2):bounds(3,2,2), & + bounds(4,1,2):bounds(4,2,2), & + bounds(5,1,2):bounds(5,2,2), & + bounds(6,1,2):bounds(6,2,2)) == value) + var2 % array6(bounds(1,1,1):bounds(1,2,1), & + bounds(2,1,1):bounds(2,2,1), & + bounds(3,1,1):bounds(3,2,1), & + bounds(4,1,1):bounds(4,2,1), & + bounds(5,1,1):bounds(5,2,1), & + bounds(6,1,1):bounds(6,2,1)) = value + end where + end select +!--------------------------------------------------------------------------------------------------- +end subroutine GiveAgrif_SpecialValueToTab_mpi +!=================================================================================================== +! +! no more used ??? +#if 0 +!=================================================================================================== +! subroutine GiveAgrif_SpecialValueToTab +!--------------------------------------------------------------------------------------------------- +subroutine GiveAgrif_SpecialValueToTab ( var1, var2, & + lower, upper, Value, nbdim ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Variable), pointer :: var1 + TYPE(Agrif_Variable), pointer :: var2 + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim), intent(in) :: lower, upper + REAL, intent(in) :: Value +! + select case (nbdim) + case (1) + where (var1 % array1( lower(1):upper(1)) == Value) + var2 % array1(lower(1):upper(1)) = Value + end where + case (2) + where (var1 % array2( lower(1):upper(1), & + lower(2):upper(2)) == Value) + var2 % array2(lower(1):upper(1), & + lower(2):upper(2)) = Value + end where + case (3) + where (var1 % array3( lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3)) == Value) + var2 % array3(lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3)) = Value + end where + case (4) + where (var1 % array4( lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4)) == Value) + var2 % array4(lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4)) = Value + end where + case (5) + where (var1 % array5( lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4), & + lower(5):upper(5)) == Value) + var2 % array5(lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4), & + lower(5):upper(5)) = Value + end where + case (6) + where (var1 % array6( lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4), & + lower(5):upper(5), & + lower(6):upper(6)) == Value) + var2 % array6(lower(1):upper(1), & + lower(2):upper(2), & + lower(3):upper(3), & + lower(4):upper(4), & + lower(5):upper(5), & + lower(6):upper(6)) = Value + end where + end select +!--------------------------------------------------------------------------------------------------- +end subroutine GiveAgrif_SpecialValueToTab +!=================================================================================================== +#endif +! +#if defined AGRIF_MPI +!=================================================================================================== +! subroutine Agrif_var_replace_value +! +!> Replace \b value by \var2 content in \var1 data array. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_var_replace_value ( var1, var2, lower, upper, value, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), intent(inout) :: var1 !< Modified variable + type(Agrif_Variable), intent(in) :: var2 !< Input variable + integer, dimension(nbdim), intent(in) :: lower !< Lower bound + integer, dimension(nbdim), intent(in) :: upper !< Upper bound + real, intent(in) :: value !< Special value + integer, intent(in) :: nbdim !< Dimension of the array +! + integer :: i,j,k,l,m,n +! + select case (nbdim) + case (1) + do i = lower(1),upper(1) + if (var1%array1(i) == value) then + var1%array1(i) = var2%array1(i) + endif + enddo + case (2) + do j = lower(2),upper(2) + do i = lower(1),upper(1) + if (var1%array2(i,j) == value) then + var1%array2(i,j) = var2%array2(i,j) + endif + enddo + enddo + case (3) + do k = lower(3),upper(3) + do j = lower(2),upper(2) + do i = lower(1),upper(1) + if (var1%array3(i,j,k) == value) then + var1%array3(i,j,k) = var2%array3(i,j,k) + endif + enddo + enddo + enddo + case (4) + do l = lower(4),upper(4) + do k = lower(3),upper(3) + do j = lower(2),upper(2) + do i = lower(1),upper(1) + if (var1%array4(i,j,k,l) == value) then + var1%array4(i,j,k,l) = var2%array4(i,j,k,l) + endif + enddo + enddo + enddo + enddo + case (5) + do m = lower(5),upper(5) + do l = lower(4),upper(4) + do k = lower(3),upper(3) + do j = lower(2),upper(2) + do i = lower(1),upper(1) + if (var1%array5(i,j,k,l,m) == value) then + var1%array5(i,j,k,l,m) = var2%array5(i,j,k,l,m) + endif + enddo + enddo + enddo + enddo + enddo + case (6) + do n = lower(6),upper(6) + do m = lower(5),upper(5) + do l = lower(4),upper(4) + do k = lower(3),upper(3) + do j = lower(2),upper(2) + do i = lower(1),upper(1) + if (var1%array6(i,j,k,l,m,n) == value) then + var1%array6(i,j,k,l,m,n) = var2%array6(i,j,k,l,m,n) + endif + enddo + enddo + enddo + enddo + enddo + enddo + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_var_replace_value +!=================================================================================================== +#endif +! +!=================================================================================================== +! subroutine PreProcessToInterpOrUpdate +!--------------------------------------------------------------------------------------------------- +subroutine PreProcessToInterpOrUpdate ( parent, child, & + nb_child, ub_child, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, interp ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer, intent(in) :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer, intent(in) :: child !< Variable on the child grid + integer, dimension(6), intent(out) :: nb_child !< Number of cells on the child grid + integer, dimension(6), intent(out) :: ub_child !< Upper bound on the child grid + integer, dimension(6), intent(out) :: lb_child !< Lower bound on the child grid + integer, dimension(6), intent(out) :: lb_parent !< Lower bound on the parent grid + real, dimension(6), intent(out) :: s_child !< Child grid position (s_root = 0) + real, dimension(6), intent(out) :: s_parent !< Parent grid position (s_root = 0) + real, dimension(6), intent(out) :: ds_child !< Child grid dx (ds_root = 1) + real, dimension(6), intent(out) :: ds_parent !< Parent grid dx (ds_root = 1) + integer, intent(out) :: nbdim !< Number of dimensions + logical, intent(in) :: interp !< .true. if preprocess for interpolation, \n + !! .false. if preprocess for update +! + type(Agrif_Variable), pointer :: root_var + type(Agrif_Grid), pointer :: Agrif_Child_Gr + type(Agrif_Grid), pointer :: Agrif_Parent_Gr + integer :: n +! + Agrif_Child_Gr => Agrif_Curgrid + Agrif_Parent_Gr => Agrif_Curgrid % parent +! + root_var => child % root_var +! +! Number of dimensions of the current grid + nbdim = root_var % nbdim +! + do n = 1,nbdim +! +! Value of interptab(n) can be either x,y,z or N for a no space dimension + select case(root_var % interptab(n)) +! + case('x') +! + lb_child(n) = root_var % point(n) + lb_parent(n) = root_var % point(n) + nb_child(n) = Agrif_Child_Gr % nb(1) + s_child(n) = Agrif_Child_Gr % Agrif_x(1) + s_parent(n) = Agrif_Parent_Gr % Agrif_x(1) + ds_child(n) = Agrif_Child_Gr % Agrif_dx(1) + ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(1) +! + if ( root_var % posvar(n) == 1 ) then + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(1) + else + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(1) - 1 + s_child(n) = s_child(n) + 0.5*ds_child(n) + s_parent(n) = s_parent(n) + 0.5*ds_parent(n) + endif +! + case('y') +! + lb_child(n) = root_var % point(n) + lb_parent(n) = root_var % point(n) + nb_child(n) = Agrif_Child_Gr % nb(2) + s_child(n) = Agrif_Child_Gr % Agrif_x(2) + s_parent(n) = Agrif_Parent_Gr % Agrif_x(2) + ds_child(n) = Agrif_Child_Gr % Agrif_dx(2) + ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(2) +! + if (root_var % posvar(n)==1) then + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(2) + else + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(2) - 1 + s_child(n) = s_child(n) + 0.5*ds_child(n) + s_parent(n) = s_parent(n) + 0.5*ds_parent(n) + endif +! + case('z') +! + lb_child(n) = root_var % point(n) + lb_parent(n) = root_var % point(n) + nb_child(n) = Agrif_Child_Gr % nb(3) + s_child(n) = Agrif_Child_Gr % Agrif_x(3) + s_parent(n) = Agrif_Parent_Gr % Agrif_x(3) + ds_child(n) = Agrif_Child_Gr % Agrif_dx(3) + ds_parent(n) = Agrif_Parent_Gr % Agrif_dx(3) +! + if (root_var % posvar(n)==1) then + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(3) + else + ub_child(n) = lb_child(n) + Agrif_Child_Gr % nb(3) - 1 + s_child(n) = s_child(n) + 0.5*ds_child(n) + s_parent(n) = s_parent(n) + 0.5*ds_parent(n) + endif +! + case('N') ! No space dimension +! +! The next coefficients are calculated in order to do a simple copy of +! values of the grid variable when the interpolation routine is +! called for this dimension. +! + if (interp) then + call Agrif_get_var_bounds(parent, lb_child(n), ub_child(n), n) + nb_child(n) = parent % ub(n) - parent % lb(n) + else + call Agrif_get_var_bounds(child, lb_child(n), ub_child(n), n) + nb_child(n) = child % ub(n) - child % lb(n) + endif +! +! No interpolation but only a copy of the values of the grid variable + lb_parent(n) = lb_child(n) + s_child(n) = 0. + s_parent(n) = 0. + ds_child(n) = 1. + ds_parent(n) = 1. +! + end select +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine PreProcessToInterpOrUpdate +!=================================================================================================== +! +#if defined AGRIF_MPI +!=================================================================================================== +! subroutine Agrif_GetLocalBoundaries +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_GetLocalBoundaries ( tab1, tab2, coord, lb, ub, deb, fin ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tab1 + integer, intent(in) :: tab2 + integer, intent(in) :: coord + integer, intent(in) :: lb, ub + integer, intent(out) :: deb, fin +! + integer :: imin, imax + integer :: i1, i2 +! + call Agrif_InvLoc(lb, AGRIF_ProcRank, coord, imin) + call Agrif_InvLoc(ub, AGRIF_ProcRank, coord, imax) +! + if ( imin > tab2 ) then + i1 = imax - imin + else + i1 = max(tab1 - imin,0) + endif +! + if (imax < tab1) then + i2 = -(imax - imin) + else + i2 = min(tab2 - imax,0) + endif +! + deb = lb + i1 + fin = ub + i2 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_GetLocalBoundaries +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_GlobalToLocalBounds +! +!> For a global index located on the current processor, tabarray gives the corresponding local index +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_GlobalToLocalBounds ( locbounds, lb_var, ub_var, lb_glob, ub_glob, & + coords, nbdim, rank, member ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(nbdim,2,2), intent(out) :: locbounds !< Local values of \b lb_glob and \b ub_glob + integer, dimension(nbdim), intent(in) :: lb_var !< Local lower boundary on the current processor + integer, dimension(nbdim), intent(in) :: ub_var !< Local upper boundary on the current processor + integer, dimension(nbdim), intent(in) :: lb_glob !< Global lower boundary + integer, dimension(nbdim), intent(in) :: ub_glob !< Global upper boundary + integer, dimension(nbdim), intent(in) :: coords + integer, intent(in) :: nbdim !< Dimension of the array + integer, intent(in) :: rank !< Rank of the processor + logical, intent(out) :: member +! + integer :: i, i1, k + integer :: nbloc(nbdim) +! + locbounds(:,1,:) = HUGE(1) + locbounds(:,2,:) = -HUGE(1) +! + nbloc = 0 +! + do i = 1,nbdim +! + call Agrif_InvLoc(lb_var(i), rank, coords(i), i1) +! + do k = lb_glob(i)+lb_var(i)-i1,ub_glob(i)+lb_var(i)-i1 +! + if ( (k >= lb_var(i)) .AND. (k <= ub_var(i)) ) then + nbloc(i) = 1 + locbounds(i,1,1) = min(locbounds(i,1,1),k-lb_var(i)+i1) + locbounds(i,2,1) = max(locbounds(i,2,1),k-lb_var(i)+i1) + + locbounds(i,1,2) = min(locbounds(i,1,2),k) + locbounds(i,2,2) = max(locbounds(i,2,2),k) + endif + enddo + enddo + + member = ( sum(nbloc) == nbdim ) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_GlobalToLocalBounds +!=================================================================================================== +#endif +! +end module Agrif_Arrays diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbc.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bd06b2329a886370b4106c0907b5a274cd0b164b --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbc.F90 @@ -0,0 +1,649 @@ +! +! $Id: modbc.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Boundary. +!> +!> Contains subroutines to calculate the boundary conditions on the child grids from their +!> parent grids. +! +module Agrif_Boundary +! + use Agrif_Interpolation +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_CorrectVariable +! +!> subroutine to calculate the boundary conditions on a fine grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_CorrectVariable ( parent, child, pweight, weight, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer :: child !< Variable on the child grid + logical :: pweight !< Indicates if weight is used for the time interpolation + real :: weight !< Coefficient for the time interpolation + procedure() :: procname !< Data recovery procedure +! + type(Agrif_Grid) , pointer :: Agrif_Child_Gr, Agrif_Parent_Gr + type(Agrif_Variable), pointer :: root_var ! Variable on the root grid + integer :: nbdim ! Number of dimensions of the grid variable + integer :: n + integer, dimension(6) :: lb_child ! Index of the first point inside the domain for + ! the child grid variable + integer, dimension(6) :: lb_parent ! Index of the first point inside the domain for + ! the parent grid variable + integer, dimension(6) :: ub_child ! Upper bound on the child grid + integer, dimension(6) :: nb_child ! Number of cells for child + integer, dimension(6) :: posvartab_child ! Position of the variable on the cell + integer, dimension(6) :: loctab_child ! Indicates if the child grid has a common border + ! with the root grid + real, dimension(6) :: s_child, s_parent ! Positions of the parent and child grids + real, dimension(6) :: ds_child, ds_parent ! Space steps of the parent and child grids +! + call PreProcessToInterpOrUpdate( parent, child, & + nb_child, ub_child, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, interp=.true.) + root_var => child % root_var + Agrif_Child_Gr => Agrif_Curgrid + Agrif_Parent_Gr => Agrif_Curgrid % parent +! + loctab_child(:) = 0 + posvartab_child(1:nbdim) = root_var % posvar(1:nbdim) +! + do n = 1,nbdim +! + select case(root_var % interptab(n)) +! + case('x') ! x DIMENSION +! + if (Agrif_Curgrid % NearRootBorder(1)) loctab_child(n) = -1 + if (Agrif_Curgrid % DistantRootBorder(1)) loctab_child(n) = -2 + if ((Agrif_Curgrid % NearRootBorder(1)) .AND. & + (Agrif_Curgrid % DistantRootBorder(1))) loctab_child(n) = -3 +! + case('y') ! y DIMENSION +! + if (Agrif_Curgrid % NearRootBorder(2)) loctab_child(n) = -1 + if (Agrif_Curgrid % DistantRootBorder(2)) loctab_child(n) = -2 + if ((Agrif_Curgrid % NearRootBorder(2)) .AND. & + (Agrif_Curgrid % DistantRootBorder(2))) loctab_child(n) = -3 +! + case('z') ! z DIMENSION +! + if (Agrif_Curgrid % NearRootBorder(3)) loctab_child(n) = -1 + if (Agrif_Curgrid % DistantRootBorder(3)) loctab_child(n) = -2 + if ((Agrif_Curgrid % NearRootBorder(3)) .AND. & + (Agrif_Curgrid % DistantRootBorder(3))) loctab_child(n) = -3 +! + case('N') ! No space DIMENSION +! + posvartab_child(n) = 1 + loctab_child(n) = -3 +! + end select +! + enddo +! + call Agrif_Correctnd(parent, child, pweight, weight, & + lb_child(1:nbdim), lb_parent(1:nbdim), & + nb_child(1:nbdim), posvartab_child(1:nbdim), & + loctab_child(1:nbdim), & + s_child(1:nbdim), s_parent(1:nbdim), & + ds_child(1:nbdim),ds_parent(1:nbdim), nbdim, procname ) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CorrectVariable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Correctnd +! +!> calculates the boundary conditions for a nD grid variable on a fine grid by using +!> a space and time interpolations; it is called by the #Agrif_CorrectVariable procedure +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Correctnd ( parent, child, pweight, weight, & + pttab_child, pttab_Parent, & + nbtab_Child, posvartab_Child, loctab_Child, & + s_Child, s_Parent, ds_Child, ds_Parent, & + nbdim, procname ) +!--------------------------------------------------------------------------------------------------- +#if defined AGRIF_MPI + include 'mpif.h' +#endif +! + TYPE(Agrif_Variable), pointer :: parent !< Variable on the parent grid + TYPE(Agrif_Variable), pointer :: child !< Variable on the child grid + LOGICAL :: pweight !< Indicates if weight is used for the temporal interpolation + REAL :: weight !< Coefficient for the temporal interpolation + INTEGER, DIMENSION(nbdim) :: pttab_child !< Index of the first point inside the domain for the parent grid variable + INTEGER, DIMENSION(nbdim) :: pttab_Parent !< Index of the first point inside the domain for the child grid variable + INTEGER, DIMENSION(nbdim) :: nbtab_Child !< Number of cells of the child grid + INTEGER, DIMENSION(nbdim) :: posvartab_Child !< Position of the grid variable (1 or 2) + INTEGER, DIMENSION(nbdim) :: loctab_Child !< Indicates if the child grid has a common border with the root grid + REAL , DIMENSION(nbdim) :: s_Child, s_Parent !< Positions of the parent and child grids + REAL , DIMENSION(nbdim) :: ds_Child, ds_Parent !< Space steps of the parent and child grids + INTEGER :: nbdim !< Number of dimensions of the grid variable + procedure() :: procname !< Data recovery procedure +! + INTEGER,DIMENSION(6) :: type_interp ! Type of interpolation (linear, spline,...) + INTEGER,DIMENSION(6,6) :: type_interp_bc ! Type of interpolation (linear, spline,...) + INTEGER,DIMENSION(nbdim,2,2) :: childarray + INTEGER,DIMENSION(nbdim,2) :: lubglob + INTEGER :: kindex ! Index used for safeguard and time interpolation + INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the limits of the child + INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where boundary conditions are + INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres,ptres2 ! calculated + INTEGER,DIMENSION(nbdim) :: coords + INTEGER :: i, nb, ndir + INTEGER :: n, sizetab + INTEGER :: ibeg, iend + INTEGER :: i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2 + REAL :: c1t,c2t ! Coefficients for the time interpolation (c2t=1-c1t) +#if defined AGRIF_MPI +! + INTEGER, DIMENSION(nbdim) :: lower, upper + INTEGER, DIMENSION(nbdim) :: ltab, utab +! +#endif +! + type_interp_bc = child % root_var % type_interp_bc + coords = child % root_var % coords +! + ibeg = child % bcinf + iend = child % bcsup +! + indtab(1:nbdim,2,1) = pttab_child(1:nbdim) + nbtab_child(1:nbdim) + ibeg + indtab(1:nbdim,2,2) = indtab(1:nbdim,2,1) + ( iend - ibeg ) + + indtab(1:nbdim,1,1) = pttab_child(1:nbdim) - iend + indtab(1:nbdim,1,2) = pttab_child(1:nbdim) - ibeg + + WHERE (posvartab_child(1:nbdim) == 2) + indtab(1:nbdim,1,1) = indtab(1:nbdim,1,1) - 1 + indtab(1:nbdim,1,2) = indtab(1:nbdim,1,2) - 1 + END WHERE +! + call Agrif_get_var_global_bounds(child,lubglob,nbdim) +! + indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) + indtruetab(1:nbdim,1,2) = max(indtab(1:nbdim,1,2), lubglob(1:nbdim,1)) + indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1), lubglob(1:nbdim,2)) + indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2), lubglob(1:nbdim,2)) +! + do nb = 1,nbdim + do ndir = 1,2 +! + if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then +! + do n = 1,2 + ptres(nb,n,ndir,nb) = indtruetab(nb,ndir,n) + enddo +! + do i = 1,nbdim +! + if (i /= nb) then +! + if (loctab_child(i) == -1 .OR. loctab_child(i) == -3) then + ptres(i,1,ndir,nb) = pttab_child(i) + else + ptres(i,1,ndir,nb) = indtruetab(i,1,1) + endif + if (loctab_child(i) == -2 .OR. loctab_child(i) == -3) then + if (posvartab_child(i) == 1) then + ptres(i,2,ndir,nb) = pttab_child(i) + nbtab_child(i) + else + ptres(i,2,ndir,nb) = pttab_child(i) + nbtab_child(i) - 1 + endif + else + ptres(i,2,ndir,nb) = indtruetab(i,2,2) + endif +! + endif +! + enddo + +! +#if defined AGRIF_MPI + call Agrif_get_var_bounds_array(child,lower,upper,nbdim) + + do i = 1,nbdim +! + Call Agrif_GetLocalBoundaries(ptres(i,1,ndir,nb), ptres(i,2,ndir,nb), & + coords(i), lower(i), upper(i), ltab(i), utab(i) ) + ptres2(i,1,ndir,nb) = max(ltab(i),lower(i)) + ptres2(i,2,ndir,nb) = min(utab(i),upper(i)) + if ((i == nb) .AND. (ndir == 1)) then + ptres2(i,2,ndir,nb) = max(utab(i),lower(i)) + elseif ((i == nb) .AND. (ndir == 2)) then + ptres2(i,1,ndir,nb) = min(ltab(i),upper(i)) + endif +! + enddo +#else + ptres2(:,:,ndir,nb) = ptres(:,:,ndir,nb) +#endif + endif +! + enddo ! ndir = 1,2 + enddo ! nb = 1,nbdim +! + if ( child % interpIndex /= Agrif_Curgrid % parent % ngridstep .OR. & + child % Interpolationshouldbemade ) then +! +! Space interpolation +! + kindex = 1 +! + do nb = 1,nbdim + + type_interp = type_interp_bc(nb,:) + + do ndir = 1,2 +! + if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then +! + call Agrif_InterpnD(type_interp, parent, child, & + ptres(1:nbdim,1,ndir,nb), & + ptres(1:nbdim,2,ndir,nb), & + pttab_child(1:nbdim), & + pttab_Parent(1:nbdim), & + s_Child(1:nbdim), s_Parent(1:nbdim), & + ds_Child(1:nbdim),ds_Parent(1:nbdim), & + NULL(), .FALSE., nbdim, & + childarray, & + child%memberin(nb,ndir), .TRUE., procname, coords(nb), ndir) + + child % childarray(1:nbdim,:,:,nb,ndir) = childarray + + if (.not. child%interpolationshouldbemade) then +! +! Safeguard of the values of the grid variable (at times n and n+1 on the parent grid) +! + sizetab = 1 + do i = 1,nbdim + sizetab = sizetab * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1) + enddo + + call saveAfterInterp(child,ptres2(:,:,ndir,nb),kindex,sizetab,nbdim) +! + endif +! + endif +! + enddo ! ndir = 1,2 + enddo ! nb = 1,nbdim +! + child % interpIndex = Agrif_Curgrid % parent % ngridstep +! + endif +! + if (.not. child%interpolationshouldbemade) then +! +! Calculation of the coefficients c1t and c2t for the temporary interpolation +! + if (pweight) then + c1t = weight + else + c1t = (REAL(Agrif_Nbstepint()) + 1.) / Agrif_Rhot() + endif + c2t = 1. - c1t +! +! Time interpolation +! + kindex = 1 +! + do nb = 1,nbdim + do ndir = 1,2 + if (loctab_child(nb) /= (-ndir) .AND. loctab_child(nb) /= -3) then + Call timeInterpolation(child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim) + endif + enddo + enddo +! + endif +! + do nb = 1,nbdim + do ndir = 1,2 + if ( (loctab_child(nb) /= (-ndir)) .AND. (loctab_child(nb) /= -3) .AND. child%memberin(nb,ndir) ) then + select case(nbdim) + case(1) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + + call procname(parray1(i1:i2), & + i1,i2, .FALSE.,coords(nb),ndir) + case(2) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + j1 = child % childarray(2,1,2,nb,ndir) + j2 = child % childarray(2,2,2,nb,ndir) + + call procname(parray2(i1:i2,j1:j2), & + i1,i2,j1,j2, .FALSE.,coords(nb),ndir) + case(3) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + j1 = child % childarray(2,1,2,nb,ndir) + j2 = child % childarray(2,2,2,nb,ndir) + k1 = child % childarray(3,1,2,nb,ndir) + k2 = child % childarray(3,2,2,nb,ndir) + + call procname(parray3(i1:i2,j1:j2,k1:k2), & + i1,i2,j1,j2,k1,k2, .FALSE.,coords(nb),ndir) + case(4) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + j1 = child % childarray(2,1,2,nb,ndir) + j2 = child % childarray(2,2,2,nb,ndir) + k1 = child % childarray(3,1,2,nb,ndir) + k2 = child % childarray(3,2,2,nb,ndir) + l1 = child % childarray(4,1,2,nb,ndir) + l2 = child % childarray(4,2,2,nb,ndir) + + call procname(parray4(i1:i2,j1:j2,k1:k2,l1:l2), & + i1,i2,j1,j2,k1,k2,l1,l2, .FALSE.,coords(nb),ndir) + case(5) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + j1 = child % childarray(2,1,2,nb,ndir) + j2 = child % childarray(2,2,2,nb,ndir) + k1 = child % childarray(3,1,2,nb,ndir) + k2 = child % childarray(3,2,2,nb,ndir) + l1 = child % childarray(4,1,2,nb,ndir) + l2 = child % childarray(4,2,2,nb,ndir) + m1 = child % childarray(5,1,2,nb,ndir) + m2 = child % childarray(5,2,2,nb,ndir) + + call procname(parray5(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2), & + i1,i2,j1,j2,k1,k2,l1,l2,m1,m2, .FALSE.,coords(nb),ndir) + case(6) + i1 = child % childarray(1,1,2,nb,ndir) + i2 = child % childarray(1,2,2,nb,ndir) + j1 = child % childarray(2,1,2,nb,ndir) + j2 = child % childarray(2,2,2,nb,ndir) + k1 = child % childarray(3,1,2,nb,ndir) + k2 = child % childarray(3,2,2,nb,ndir) + l1 = child % childarray(4,1,2,nb,ndir) + l2 = child % childarray(4,2,2,nb,ndir) + m1 = child % childarray(5,1,2,nb,ndir) + m2 = child % childarray(5,2,2,nb,ndir) + n1 = child % childarray(6,1,2,nb,ndir) + n2 = child % childarray(6,2,2,nb,ndir) + + call procname(parray6(i1:i2,j1:j2,k1:k2,l1:l2,m1:m2,n1:n2), & + i1,i2,j1,j2,k1,k2,l1,l2,m1,m2,n1,n2, .FALSE.,coords(nb),ndir) + end select + endif + enddo + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Correctnd +!=================================================================================================== +! +!=================================================================================================== +! subroutine saveAfterInterp +! +!> saves the values of the grid variable on the fine grid after the space interpolation +!--------------------------------------------------------------------------------------------------- +subroutine saveAfterInterp ( child_var, bounds, kindex, newsize, nbdim ) +!--------------------------------------------------------------------------------------------------- + TYPE (Agrif_Variable), INTENT(inout) :: child_var !< The fine grid variable + INTEGER, DIMENSION(nbdim,2), INTENT(in) :: bounds + INTEGER, INTENT(inout) :: kindex !< Index indicating where this safeguard + !< is done on the fine grid + INTEGER, INTENT(in) :: newsize + INTEGER, INTENT(in) :: nbdim +! + INTEGER :: ir,jr,kr,lr,mr,nr +! +! Allocation of the array oldvalues2d +! + if (newsize .LE. 0) return +! + Call Agrif_Checksize(child_var,kindex+newsize) + + if (child_var % interpIndex /= Agrif_Curgrid % parent % ngridstep ) then + child_var % oldvalues2d(1,kindex:kindex+newsize-1) = & + child_var % oldvalues2d(2,kindex:kindex+newsize-1) + endif + + SELECT CASE (nbdim) + CASE (1) +!CDIR ALTCODE + do ir = bounds(1,1), bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray1(ir) + kindex = kindex + 1 + enddo +! + CASE (2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray2(ir,jr) + kindex = kindex + 1 + enddo + enddo +! + CASE (3) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray3(ir,jr,kr) + kindex = kindex + 1 + enddo + enddo + enddo +! + CASE (4) + do lr = bounds(4,1),bounds(4,2) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray4(ir,jr,kr,lr) + kindex = kindex + 1 + enddo + enddo + enddo + enddo +! + CASE (5) + do mr = bounds(5,1),bounds(5,2) + do lr = bounds(4,1),bounds(4,2) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray5(ir,jr,kr,lr,mr) + kindex = kindex + 1 + enddo + enddo + enddo + enddo + enddo +! + CASE (6) + do nr = bounds(6,1),bounds(6,2) + do mr = bounds(5,1),bounds(5,2) + do lr = bounds(4,1),bounds(4,2) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + child_var % oldvalues2d(2,kindex) = parray6(ir,jr,kr,lr,mr,nr) + kindex = kindex + 1 + enddo + enddo + enddo + enddo + enddo + enddo + END SELECT +!--------------------------------------------------------------------------------------------------- +end subroutine saveAfterInterp +!=================================================================================================== +! +!=================================================================================================== +! subroutine timeInterpolation +! +!> subroutine for a linear time interpolation on the child grid +!--------------------------------------------------------------------------------------------------- +subroutine timeInterpolation ( child_var, bounds, kindex, c1t, c2t, nbdim ) +!--------------------------------------------------------------------------------------------------- + TYPE (Agrif_Variable) :: child_var !< The fine grid variable + INTEGER, DIMENSION(nbdim,2) :: bounds + INTEGER :: kindex !< Index indicating the values of the fine grid got + !< before and after the space interpolation and + !< used for the time interpolation + REAL :: c1t, c2t !< Coefficients for the time interpolation (c2t=1-c1t) + INTEGER :: nbdim +! + INTEGER :: ir,jr,kr,lr,mr,nr +! + SELECT CASE (nbdim) + CASE (1) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + parray1(ir) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo +! + CASE (2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + parray2(ir,jr) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo + enddo +! + CASE (3) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + parray3(ir,jr,kr) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo + enddo + enddo +! + CASE (4) + do lr = bounds(4,1),bounds(4,2) + do kr = bounds(3,1),bounds(3,2) + do jr = bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir = bounds(1,1),bounds(1,2) + parray4(ir,jr,kr,lr) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo + enddo + enddo + enddo +! + CASE (5) + do mr=bounds(5,1),bounds(5,2) + do lr=bounds(4,1),bounds(4,2) + do kr=bounds(3,1),bounds(3,2) + do jr=bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir=bounds(1,1),bounds(1,2) + parray5(ir,jr,kr,lr,mr) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo + enddo + enddo + enddo + enddo +! + CASE (6) + do nr=bounds(6,1),bounds(6,2) + do mr=bounds(5,1),bounds(5,2) + do lr=bounds(4,1),bounds(4,2) + do kr=bounds(3,1),bounds(3,2) + do jr=bounds(2,1),bounds(2,2) +!CDIR ALTCODE + do ir=bounds(1,1),bounds(1,2) + parray6(ir,jr,kr,lr,mr,nr) = c2t*child_var % oldvalues2d(1,kindex) + & + c1t*child_var % oldvalues2d(2,kindex) + kindex = kindex + 1 + enddo + enddo + enddo + enddo + enddo + enddo + END SELECT +!--------------------------------------------------------------------------------------------------- +end subroutine timeInterpolation +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Checksize +! +!> subroutine used in the saveAfterInterp procedure to allocate the oldvalues2d array +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Checksize ( child_var, newsize ) +!--------------------------------------------------------------------------------------------------- + TYPE (Agrif_Variable), INTENT(inout) :: child_var !< The fine grid variable + INTEGER , INTENT(in) :: newsize !< Size of the domains where the boundary + !< conditions are calculated +! + REAL, DIMENSION(:,:), Allocatable :: tempoldvalues ! Temporary array +! + if (.NOT. associated(child_var % oldvalues2d)) then +! + allocate(child_var % oldvalues2d(2,newsize)) + child_var % oldvalues2d = 0. +! + else +! + if (SIZE(child_var % oldvalues2d,2) < newsize) then +! + allocate(tempoldvalues(2,SIZE(child_var % oldvalues2d,2))) + tempoldvalues = child_var % oldvalues2d + deallocate(child_var % oldvalues2d) + allocate( child_var % oldvalues2d(2,newsize)) + child_var % oldvalues2d = 0. + child_var % oldvalues2d(:,1:SIZE(tempoldvalues,2)) = tempoldvalues(:,:) + deallocate(tempoldvalues) +! + endif +! + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Checksize +!=================================================================================================== +! +end module Agrif_Boundary + diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbcfunction.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbcfunction.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e78bbb03afee752c13dd8e8cf30ff23aa15c5b55 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modbcfunction.F90 @@ -0,0 +1,680 @@ +! +! $Id: modbcfunction.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +!> Module Agrif_BcFunction. +! +module Agrif_BcFunction +! +! Modules used: +! + use Agrif_Boundary + use Agrif_Update + use Agrif_Save +! + implicit none +! + interface Agrif_Set_Parent + module procedure Agrif_Set_Parent_int, & + Agrif_Set_Parent_real4, & + Agrif_Set_Parent_real8 + end interface +! + interface Agrif_Save_Forrestore + module procedure Agrif_Save_Forrestore0d, & + Agrif_Save_Forrestore2d, & + Agrif_Save_Forrestore3d, & + Agrif_Save_Forrestore4d + end interface +! +contains +! +!=================================================================================================== +! subroutine Agrif_Set_parent_int +! +!> To set the TYPE of the variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_parent_int(tabvarsindic,value) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + integer, intent(in) :: value !< input value +! + Agrif_Curgrid % parent % tabvars_i(tabvarsindic) % iarray0 = value +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_parent_int +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_parent_real4 +!--------------------------------------------------------------------------------------------------- +!> To set the TYPE of the variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_parent_real4 ( tabvarsindic, value ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + real(kind=4),intent(in) :: value !< input value +! + Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % array0 = value + Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % sarray0 = value +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_parent_real4 +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_parent_real8 +!--------------------------------------------------------------------------------------------------- +!> To set the TYPE of the variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_parent_real8 ( tabvarsindic, value ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + real(kind=8),intent(in) :: value !< input value +! + Agrif_Curgrid % parent % tabvars_r(tabvarsindic) % darray0 = value +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_parent_real8 +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_bc +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_bc ( tabvarsindic, bcinfsup, Interpolationshouldbemade ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + integer, dimension(2), intent(in) :: bcinfsup !< bcinfsup + logical, optional, intent(in) :: Interpolationshouldbemade !< interpolation should be made +! + integer :: indic ! indice of the variable in tabvars + type(Agrif_Variable), pointer :: var +! + indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 +! + if (indic <= 0) then + var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + else + print*,"Agrif_Set_bc : warning indic >= 0 !!!" + var => Agrif_Curgrid % tabvars(indic) + endif + + if (.not.associated(var)) return ! Grand mother grid case +! + if ( Agrif_Curgrid % fixedrank /= 0 ) then + if ( .not.associated(var % oldvalues2D) ) then + allocate(var % oldvalues2D(2,1)) + var % interpIndex = -1 + var % oldvalues2D = 0. + endif + if ( present(Interpolationshouldbemade) ) then + var % Interpolationshouldbemade = Interpolationshouldbemade + endif + endif +! + var % bcinf = bcinfsup(1) + var % bcsup = bcinfsup(2) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_bc +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_interp +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_interp ( tabvarsindic, interp, interp1, interp2, interp3 , interp4) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + integer, optional, intent(in) :: interp, interp1, interp2, interp3, interp4 +! + integer :: indic ! indice of the variable in tabvars + type(Agrif_Variable), pointer :: var +! + indic = Agrif_Curgrid % tabvars_i(tabvarsindic) % iarray0 +! + if (indic <= 0) then + var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + print*,"Agrif_Set_interp : warning indic >= 0 !!!" + var => Agrif_Mygrid % tabvars(indic) + endif +! + var % type_interp = Agrif_Constant +! + if (present(interp)) var % type_interp = interp + if (present(interp1)) var % type_interp(1) = interp1 + if (present(interp2)) var % type_interp(2) = interp2 + if (present(interp3)) var % type_interp(3) = interp3 + if (present(interp4)) var % type_interp(4) = interp4 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_interp +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_bcinterp +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_bcinterp ( tabvarsindic, interp, interp1, interp2, interp3, interp4, & + interp11, interp12, interp21, interp22 ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars + INTEGER, OPTIONAL, intent(in) :: interp, interp1, interp2, interp3, interp4 + INTEGER, OPTIONAL, intent(in) :: interp11, interp12, interp21, interp22 +! + INTEGER :: indic ! indice of the variable in tabvars + TYPE(Agrif_Variable), pointer :: var +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + if (indic <= 0) then + var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + print*,"Agrif_Set_bcinterp : warning indic >= 0 !!!" + var => Agrif_Mygrid % tabvars(indic) + endif +! + var % type_interp_bc = Agrif_Constant +! + if (present(interp)) var % type_interp_bc = interp + if (present(interp1)) var % type_interp_bc(:,1) = interp1 + if (present(interp11)) var % type_interp_bc(1,1) = interp11 + if (present(interp12)) var % type_interp_bc(1,2) = interp12 + if (present(interp2)) var % type_interp_bc(:,2) = interp2 + if (present(interp21)) var % type_interp_bc(2,1) = interp21 + if (present(interp22)) var % type_interp_bc(2,2) = interp22 + if (present(interp3)) var % type_interp_bc(:,3) = interp3 + if (present(interp4)) var % type_interp_bc(:,4) = interp4 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_bcinterp +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_UpdateType +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_UpdateType ( tabvarsindic, update, update1, update2, & + update3, update4, update5 ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars + INTEGER, OPTIONAL, intent(in) :: update, update1, update2, update3, update4, update5 +! + INTEGER :: indic ! indice of the variable in tabvars + type(Agrif_Variable), pointer :: root_var +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + if (indic <= 0) then + root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + print*,"Agrif_Set_UpdateType : warning indic >= 0 !!!" + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + root_var % type_update = Agrif_Update_Copy + if (present(update)) root_var % type_update = update + if (present(update1)) root_var % type_update(1) = update1 + if (present(update2)) root_var % type_update(2) = update2 + if (present(update3)) root_var % type_update(3) = update3 + if (present(update4)) root_var % type_update(4) = update4 + if (present(update5)) root_var % type_update(5) = update5 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_UpdateType +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_restore +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_restore ( tabvarsindic ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars +! + INTEGER :: indic ! indice of the variable in tabvars +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + Agrif_Mygrid%tabvars(indic) % restore = .TRUE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_restore +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Init_variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Init_variable ( tabvarsindic, procname ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(in) :: tabvarsindic !< indice of the variable in tabvars + procedure() :: procname !< Data recovery procedure +! + if ( Agrif_Curgrid%level <= 0 ) return +! + call Agrif_Interp_variable(tabvarsindic, procname) + call Agrif_Bc_variable(tabvarsindic, procname, 1.) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_variable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Bc_variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Bc_variable ( tabvarsindic, procname, calledweight ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + procedure() :: procname + real, optional, intent(in) :: calledweight +! + real :: weight + logical :: pweight + integer :: indic + integer :: nbdim + type(Agrif_Variable), pointer :: root_var + type(Agrif_Variable), pointer :: parent_var + type(Agrif_Variable), pointer :: child_var + type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid +! + if ( Agrif_Curgrid%level <= 0 ) return +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + if ( present(calledweight) ) then + weight = calledweight + pweight = .true. + else + weight = 0. + pweight = .false. + endif +! + if (indic <= 0) then + child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + parent_var => child_var % parent_var + root_var => child_var % root_var + else + print*,"Agrif_Bc_variable : warning indic >= 0 !!!" + child_var => Agrif_Curgrid % tabvars(indic) + parent_var => Agrif_Curgrid % parent % tabvars(indic) + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + nbdim = root_var % nbdim +! + select case( nbdim ) + case(1) + allocate(parray1(child_var%lb(1):child_var%ub(1))) + case(2) + allocate(parray2(child_var%lb(1):child_var%ub(1), & + child_var%lb(2):child_var%ub(2) )) + case(3) + allocate(parray3(child_var%lb(1):child_var%ub(1), & + child_var%lb(2):child_var%ub(2), & + child_var%lb(3):child_var%ub(3) )) + case(4) + allocate(parray4(child_var%lb(1):child_var%ub(1), & + child_var%lb(2):child_var%ub(2), & + child_var%lb(3):child_var%ub(3), & + child_var%lb(4):child_var%ub(4) )) + case(5) + allocate(parray5(child_var%lb(1):child_var%ub(1), & + child_var%lb(2):child_var%ub(2), & + child_var%lb(3):child_var%ub(3), & + child_var%lb(4):child_var%ub(4), & + child_var%lb(5):child_var%ub(5) )) + case(6) + allocate(parray6(child_var%lb(1):child_var%ub(1), & + child_var%lb(2):child_var%ub(2), & + child_var%lb(3):child_var%ub(3), & + child_var%lb(4):child_var%ub(4), & + child_var%lb(5):child_var%ub(5), & + child_var%lb(6):child_var%ub(6) )) + end select +! +! Create temporary child variable + allocate(child_tmp) +! + child_tmp % root_var => root_var + child_tmp % oldvalues2D => child_var % oldvalues2D +! +! Index indicating if a space interpolation is necessary + child_tmp % interpIndex = child_var % interpIndex + child_tmp % list_interp => child_var % list_interp + child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade +! + child_tmp % point = child_var % point + child_tmp % lb = child_var % lb + child_tmp % ub = child_var % ub +! + child_tmp % bcinf = child_var % bcinf + child_tmp % bcsup = child_var % bcsup +! + child_tmp % childarray = child_var % childarray + child_tmp % memberin = child_var % memberin +! + call Agrif_CorrectVariable(parent_var, child_tmp, pweight, weight, procname) +! + child_var % childarray = child_tmp % childarray + child_var % memberin = child_tmp % memberin +! + child_var % oldvalues2D => child_tmp % oldvalues2D + child_var % list_interp => child_tmp % list_interp +! + child_var % interpIndex = child_tmp % interpIndex +! + deallocate(child_tmp) +! + select case( nbdim ) + case(1); deallocate(parray1) + case(2); deallocate(parray2) + case(3); deallocate(parray3) + case(4); deallocate(parray4) + case(5); deallocate(parray5) + case(6); deallocate(parray6) + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Bc_variable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_variable ( tabvarsindic, procname ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< indice of the variable in tabvars + procedure() :: procname !< Data recovery procedure +! + integer :: nbdim + integer :: indic ! indice of the variable in tabvars + logical :: torestore + type(Agrif_Variable), pointer :: root_var + type(Agrif_Variable), pointer :: parent_var ! Variable on the parent grid + type(Agrif_Variable), pointer :: child_var ! Variable on the parent grid + type(Agrif_Variable), pointer :: child_tmp ! Temporary variable on the child grid +! + if ( Agrif_Curgrid%level <= 0 ) return +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + if (indic <= 0) then + child_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + parent_var => child_var % parent_var + root_var => child_var % root_var + else + print*,"Agrif_Interp_variable : warning indic >= 0 !!!" + child_var => Agrif_Curgrid % tabvars(indic) + parent_var => Agrif_Curgrid % parent % tabvars(indic) + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + nbdim = root_var % nbdim + torestore = root_var % restore +! + allocate(child_tmp) +! + child_tmp % root_var => root_var + child_tmp % nbdim = root_var % nbdim + child_tmp % point = child_var % point + child_tmp % lb = child_var % lb + child_tmp % ub = child_var % ub + child_tmp % interpIndex = child_var % interpIndex + child_tmp % list_interp => child_var % list_interp + child_tmp % Interpolationshouldbemade = child_var % Interpolationshouldbemade +! + if ( torestore ) then + select case( nbdim ) + case(1) + parray1 = child_var % array1 + child_tmp % restore1D => child_var % restore1D + case(2) + parray2 = child_var % array2 + child_tmp % restore2D => child_var % restore2D + case(3) + parray3 = child_var % array3 + child_tmp % restore3D => child_var % restore3D + case(4) + parray4 = child_var % array4 + child_tmp % restore4D => child_var % restore4D + case(5) + parray5 = child_var % array5 + child_tmp % restore5D => child_var % restore5D + case(6) + parray6 = child_var % array6 + child_tmp % restore6D => child_var % restore6D + end select + endif +! + call Agrif_InterpVariable(parent_var, child_tmp, torestore, procname) +! + child_var % list_interp => child_tmp % list_interp +! + deallocate(child_tmp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_variable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_Variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_Variable ( tabvarsindic, procname, & + locupdate, locupdate1, locupdate2, locupdate3, locupdate4 ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic !< Indice of the variable in tabvars + procedure() :: procname !< Data recovery procedure + integer, dimension(2), intent(in), optional :: locupdate + integer, dimension(2), intent(in), optional :: locupdate1 + integer, dimension(2), intent(in), optional :: locupdate2 + integer, dimension(2), intent(in), optional :: locupdate3 + integer, dimension(2), intent(in), optional :: locupdate4 +!--------------------------------------------------------------------------------------------------- + integer :: indic + integer :: nbdim + integer, dimension(6) :: updateinf ! First positions where interpolations are calculated + integer, dimension(6) :: updatesup ! Last positions where interpolations are calculated + type(Agrif_Variable), pointer :: root_var + type(Agrif_Variable), pointer :: parent_var + type(Agrif_Variable), pointer :: child_var +! + if ( Agrif_Root() .AND. (.not.agrif_coarse) ) return + if (agrif_curgrid%grand_mother_grid) return +! + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 +! + if (indic <= 0) then + child_var => Agrif_Search_Variable(Agrif_Curgrid, -indic) + parent_var => child_var % parent_var + + if (.not.associated(parent_var)) then + ! can occur during the first update of Agrif_Coarsegrid (if any) + parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, -indic) + child_var % parent_var => parent_var + endif + + root_var => child_var % root_var + else + print*,"Agrif_Update_Variable : warning indic >= 0 !!!" + root_var => Agrif_Mygrid % tabvars(indic) + child_var => Agrif_Curgrid % tabvars(indic) + parent_var => Agrif_Curgrid % parent % tabvars(indic) + endif +! + nbdim = root_var % nbdim +! + updateinf = -99 + updatesup = -99 +! + if ( present(locupdate) ) then + updateinf(1:nbdim) = locupdate(1) + updatesup(1:nbdim) = locupdate(2) + endif +! + if ( present(locupdate1) ) then + updateinf(1) = locupdate1(1) + updatesup(1) = locupdate1(2) + endif +! + if ( present(locupdate2) ) then + updateinf(2) = locupdate2(1) + updatesup(2) = locupdate2(2) + endif + + if ( present(locupdate3) ) then + updateinf(3) = locupdate3(1) + updatesup(3) = locupdate3(2) + endif + + if ( present(locupdate4) ) then + updateinf(4) = locupdate4(1) + updatesup(4) = locupdate4(2) + endif +! + call Agrif_UpdateVariable( parent_var, child_var, updateinf, updatesup, procname ) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_Variable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Save_ForRestore0D +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Save_ForRestore0D ( tabvarsindic0, tabvarsindic ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: tabvarsindic0, tabvarsindic +! + type(Agrif_Variable), pointer :: root_var, save_var + integer :: nbdim +! + root_var => Agrif_Mygrid % tabvars(tabvarsindic0) + save_var => Agrif_Curgrid % tabvars(tabvarsindic0) + nbdim = root_var % nbdim +! + select case(nbdim) + case(2); call Agrif_Save_ForRestore2D(save_var % array2, tabvarsindic) + case(3); call Agrif_Save_ForRestore3D(save_var % array3, tabvarsindic) + case(4); call Agrif_Save_ForRestore4D(save_var % array4, tabvarsindic) + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Save_ForRestore0D +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Save_ForRestore2D +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Save_ForRestore2D ( q, tabvarsindic ) +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:), intent(in) :: q + integer, intent(in) :: tabvarsindic +! + type(Agrif_Variable), pointer :: root_var, save_var + integer :: indic +! + indic = tabvarsindic + if (tabvarsindic >= 0) then + if (Agrif_Curgrid%tabvars_i(tabvarsindic)%nbdim == 0) then + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 + endif + endif +! + if (indic <= 0) then + save_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + save_var => Agrif_Curgrid % tabvars(indic) + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + if ( .not.allocated(save_var%array2) ) then + allocate(save_var%array2(save_var%lb(1):save_var%ub(1), & + save_var%lb(2):save_var%ub(2))) + endif +! + save_var % array2 = q + root_var % restore = .true. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Save_ForRestore2D +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Save_ForRestore3D +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Save_ForRestore3D ( q, tabvarsindic ) +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:,:), intent(in) :: q + integer, intent(in) :: tabvarsindic +! + type(Agrif_Variable), pointer :: root_var, save_var + integer :: indic +! + indic = tabvarsindic + if (tabvarsindic >= 0) then + if (Agrif_Curgrid%tabvars_i(tabvarsindic)%nbdim == 0) then + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 + endif + endif +! + if (indic <= 0) then + save_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + save_var => Agrif_Curgrid % tabvars(indic) + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + if ( .not.allocated(save_var%array3) ) then + allocate(save_var%array3(save_var%lb(1):save_var%ub(1), & + save_var%lb(2):save_var%ub(2), & + save_var%lb(3):save_var%ub(3))) + endif +! + save_var % array3 = q + root_var % restore = .true. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Save_ForRestore3D +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Save_ForRestore4D +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Save_ForRestore4D ( q, tabvarsindic ) +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:,:,:), intent(in) :: q + integer, intent(in) :: tabvarsindic +! + type(Agrif_Variable), pointer :: root_var, save_var + integer :: indic +! + indic = tabvarsindic + if (tabvarsindic >= 0) then + if (Agrif_Curgrid%tabvars_i(tabvarsindic)%nbdim == 0) then + indic = Agrif_Curgrid%tabvars_i(tabvarsindic)%iarray0 + endif + endif +! + if (indic <= 0) then + save_var => Agrif_Search_Variable(Agrif_Curgrid,-indic) + root_var => Agrif_Search_Variable(Agrif_Mygrid,-indic) + else + save_var => Agrif_Curgrid % tabvars(indic) + root_var => Agrif_Mygrid % tabvars(indic) + endif +! + if (.not.allocated(save_var%array4)) then + allocate(save_var%array4(save_var%lb(1):save_var%ub(1),& + save_var%lb(2):save_var%ub(2),& + save_var%lb(3):save_var%ub(3),& + save_var%lb(4):save_var%ub(4))) + endif +! + save_var % array4 = q + root_var % restore = .true. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Save_ForRestore4D +!=================================================================================================== +! +end module Agrif_BcFunction diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcluster.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcluster.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a9e34b98a232d4537147bb06ff4ed15590886bc3 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcluster.F90 @@ -0,0 +1,1277 @@ +! +! $Id: modcluster.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Clustering +!> +!> Contains subroutines to create and initialize the grid hierarchy from the +!> AGRIF_FixedGrids.in file. +! +module Agrif_Clustering +! + use Agrif_CurgridFunctions + use Agrif_Init_Vars + use Agrif_Save +! + implicit none +! + abstract interface + subroutine init_proc() + end subroutine init_proc + end interface +! +contains +! +!=================================================================================================== +! subroutine Agrif_Cluster_All +! +!> Subroutine for the clustering. A temporary grid hierarchy, pointed by parent_rect, is created. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Cluster_All ( g, parent_rect ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid) , pointer :: g !< Pointer on the current grid + TYPE(Agrif_Rectangle), pointer :: parent_rect +! + TYPE(Agrif_LRectangle), pointer :: parcours + TYPE(Agrif_Grid) , pointer :: newgrid + REAL :: g_eps + INTEGER :: i +! + g_eps = huge(1.) + do i = 1,Agrif_Probdim + g_eps = min(g_eps, g % Agrif_dx(i)) + enddo +! + g_eps = g_eps / 100. +! +! Necessary condition for clustering + do i = 1,Agrif_Probdim + if ( g%Agrif_dx(i)/Agrif_coeffref(i) < (Agrif_mind(i)-g_eps)) return + enddo +! + nullify(parent_rect%childgrids) +! + call Agrif_ClusterGridnD(g,parent_rect) +! + parcours => parent_rect % childgrids +! + do while ( associated(parcours) ) +! +! Newgrid is created. It is a copy of a fine grid created previously by clustering. + allocate(newgrid) +! + do i = 1,Agrif_Probdim + newgrid % nb(i) = (parcours % r % imax(i) - parcours % r % imin(i)) * Agrif_Coeffref(i) + newgrid % Agrif_x(i) = g % Agrif_x(i) + (parcours % r % imin(i) -1) * g%Agrif_dx(i) + newgrid % Agrif_dx(i) = g % Agrif_dx(i) / Agrif_Coeffref(i) + enddo +! + if ( Agrif_Probdim == 1 ) then + allocate(newgrid%tabpoint1D(newgrid%nb(1)+1)) + newgrid%tabpoint1D = 0 + endif +! + if ( Agrif_Probdim == 2 ) then + allocate(newgrid%tabpoint2D(newgrid%nb(1)+1, newgrid%nb(2)+1)) + newgrid%tabpoint2D = 0 + endif +! + if ( Agrif_Probdim == 3 ) then + allocate(newgrid%tabpoint3D(newgrid%nb(1)+1, newgrid%nb(2)+1, newgrid%nb(3)+1)) + newgrid%tabpoint3D = 0 + endif +! +! Points detection on newgrid + call Agrif_TabpointsnD(Agrif_mygrid,newgrid) +! +! recursive call to Agrif_Cluster_All + call Agrif_Cluster_All(newgrid, parcours % r) +! + parcours => parcours % next +! + if ( Agrif_Probdim == 1 ) deallocate(newgrid%tabpoint1D) + if ( Agrif_Probdim == 2 ) deallocate(newgrid%tabpoint2D) + if ( Agrif_Probdim == 3 ) deallocate(newgrid%tabpoint3D) +! + deallocate(newgrid) +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Cluster_All +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_TabpointsnD +! +!> Copy on newgrid of points detected on the grid hierarchy pointed by g. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_TabpointsnD ( g, newgrid ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid), pointer :: g, newgrid +! + TYPE(Agrif_PGrid), pointer :: parcours +! + REAL :: g_eps, newgrid_eps, eps + REAL , DIMENSION(3) :: newmin, newmax + REAL , DIMENSION(3) :: gmin, gmax + REAL , DIMENSION(3) :: xmin + INTEGER, DIMENSION(3) :: igmin, inewmin + INTEGER, DIMENSION(3) :: inewmax + INTEGER :: i, j, k + INTEGER :: i0, j0, k0 +! + parcours => g % child_list % first +! + do while( associated(parcours) ) + call Agrif_TabpointsnD(parcours%gr,newgrid) + parcours => parcours % next + enddo +! + g_eps = 10. + newgrid_eps = 10. +! + do i = 1,Agrif_probdim + g_eps = min( g_eps , g % Agrif_dx(i) ) + newgrid_eps = min(newgrid_eps,newgrid%Agrif_dx(i)) + enddo +! + eps = min(g_eps,newgrid_eps)/100. +! + do i = 1,Agrif_probdim +! + if ( newgrid%Agrif_dx(i) < (g%Agrif_dx(i)-eps) ) return +! + gmin(i) = g%Agrif_x(i) + gmax(i) = g%Agrif_x(i) + g%nb(i) * g%Agrif_dx(i) +! + newmin(i) = newgrid%Agrif_x(i) + newmax(i) = newgrid%Agrif_x(i) + newgrid%nb(i) * newgrid%Agrif_dx(i) +! + if (gmax(i) < newmin(i)) return + if (gmin(i) > newmax(i)) return +! + inewmin(i) = 1 - floor(-(max(gmin(i),newmin(i))-newmin(i)) / newgrid%Agrif_dx(i)) +! + xmin(i) = newgrid%Agrif_x(i) + (inewmin(i)-1)*newgrid%Agrif_dx(i) +! + igmin(i) = 1 + nint((xmin(i)-gmin(i))/g%Agrif_dx(i)) +! + inewmax(i) = 1 + int( (min(gmax(i),newmax(i))-newmin(i)) / newgrid%Agrif_dx(i)) +! + enddo +! + if ( Agrif_probdim == 1 ) then + i0 = igmin(1) + do i = inewmin(1),inewmax(1) + newgrid%tabpoint1D(i) = max( newgrid%tabpoint1D(i), g%tabpoint1D(i0) ) + enddo + i0 = i0 + int(newgrid%Agrif_dx(1)/g%Agrif_dx(1)) + endif +! + if ( Agrif_probdim == 2 ) then + i0 = igmin(1) + do i = inewmin(1),inewmax(1) + j0 = igmin(2) + do j = inewmin(2),inewmax(2) + newgrid%tabpoint2D(i,j) = max( newgrid%tabpoint2D(i,j), g%tabpoint2D(i0,j0) ) + j0 = j0 + int(newgrid%Agrif_dx(2)/g%Agrif_dx(2)) + enddo + i0 = i0 + int(newgrid%Agrif_dx(1)/g%Agrif_dx(1)) + enddo + endif +! + if ( Agrif_probdim == 3 ) then + i0 = igmin(1) + do i = inewmin(1),inewmax(1) + j0 = igmin(2) + do j = inewmin(2),inewmax(2) + k0 = igmin(3) + do k = inewmin(3),inewmax(3) + newgrid%tabpoint3D(i,j,k) = max( newgrid%tabpoint3D(i,j,k), g%tabpoint3D(i0,j0,k0)) + k0 = k0 + int(newgrid%Agrif_dx(3)/g%Agrif_dx(3)) + enddo + j0 = j0 + int(newgrid%Agrif_dx(2)/g%Agrif_dx(2)) + enddo + i0 = i0 + int(newgrid%Agrif_dx(1)/g%Agrif_dx(1)) + enddo + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_TabpointsnD +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_ClusterGridnD +! +!> Clustering on the grid pointed by g. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_ClusterGridnD ( g, parent_rect ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid) , pointer :: g !< Pointer on the current grid + TYPE(Agrif_Rectangle), pointer :: parent_rect +! + TYPE(Agrif_Rectangle) :: newrect + TYPE(Agrif_Variable_i) :: newflag +! + INTEGER :: i,j,k + INTEGER, DIMENSION(3) :: sx + INTEGER :: bufferwidth,flagpoints + INTEGER :: n1,n2,m1,m2,o1,o2 +! + bufferwidth = int(Agrif_Minwidth/5.) +! + do i = 1,Agrif_probdim + sx(i) = g % nb(i) + 1 + enddo +! + if ( Agrif_probdim == 1 ) then + allocate(newflag%iarray1(sx(1))) + newflag%iarray1 = 0 + endif + if ( Agrif_probdim == 2 ) then + allocate(newflag%iarray2(sx(1),sx(2))) + newflag%iarray2 = 0 + endif + if ( Agrif_probdim == 3 ) then + allocate(newflag%iarray3(sx(1),sx(2),sx(3))) + newflag%iarray3 = 0 + endif +! + flagpoints = 0 +! + if ( bufferwidth>0 ) then +! + if ( Agrif_probdim == 1 ) then + do i = bufferwidth,sx(1)-bufferwidth+1 + if (g % tabpoint1D(i) == 1) then + m1 = i - bufferwidth + 1 + m2 = i + bufferwidth - 1 + flagpoints = flagpoints + 1 + newflag%iarray1(m1:m2) = 1 + endif + enddo + endif +! + if ( Agrif_probdim == 2 ) then + do i = bufferwidth,sx(1)-bufferwidth+1 + do j = bufferwidth,sx(2)-bufferwidth+1 + if (g % tabpoint2D(i,j) == 1) then + n1 = j - bufferwidth + 1 + n2 = j + bufferwidth - 1 + m1 = i - bufferwidth + 1 + m2 = i + bufferwidth - 1 + flagpoints = flagpoints + 1 + newflag%iarray2(m1:m2,n1:n2) = 1 + endif + enddo + enddo + endif +! + if ( Agrif_probdim == 3 ) then + do i = bufferwidth,sx(1)-bufferwidth+1 + do j = bufferwidth,sx(2)-bufferwidth+1 + do k = bufferwidth,sx(3)-bufferwidth+1 + if (g % tabpoint3D(i,j,k) == 1) then + o1 = k - bufferwidth + 1 + o2 = k + bufferwidth - 1 + n1 = j - bufferwidth + 1 + n2 = j + bufferwidth - 1 + m1 = i - bufferwidth + 1 + m2 = i + bufferwidth - 1 + flagpoints = flagpoints + 1 + newflag%iarray3(m1:m2,n1:n2,o1:o2) = 1 + endif + enddo + enddo + enddo + endif +! + else +! + flagpoints = 1 + if ( Agrif_probdim == 1 ) newflag%iarray1 = g % tabpoint1D + if ( Agrif_probdim == 2 ) newflag%iarray2 = g % tabpoint2D + if ( Agrif_probdim == 3 ) newflag%iarray3 = g % tabpoint3D +! + endif +! + if (flagpoints == 0) then + if ( Agrif_probdim == 1 ) deallocate(newflag%iarray1) + if ( Agrif_probdim == 2 ) deallocate(newflag%iarray2) + if ( Agrif_probdim == 3 ) deallocate(newflag%iarray3) + return + endif +! + do i = 1 , Agrif_probdim + newrect % imin(i) = 1 + newrect % imax(i) = sx(i) + enddo +! + call Agrif_Clusternd(newflag,parent_rect%childgrids,newrect) +! + if ( Agrif_probdim == 1 ) deallocate(newflag%iarray1) + if ( Agrif_probdim == 2 ) deallocate(newflag%iarray2) + if ( Agrif_probdim == 3 ) deallocate(newflag%iarray3) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_ClusterGridnD +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_ClusternD +! +!> Clustering on the grid pointed by oldB. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Clusternd ( flag, boxlib, oldB ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Variable_i) :: flag + TYPE(Agrif_LRectangle), pointer :: boxlib + TYPE(Agrif_Rectangle) :: oldB +! + TYPE(Agrif_LRectangle),pointer :: tempbox,parcbox,parcbox2 + TYPE(Agrif_Rectangle) :: newB,newB2 + INTEGER :: i,j,k + INTEGER, DIMENSION(:), allocatable :: i_sig, j_sig, k_sig + INTEGER, DIMENSION(3) :: ipu,ipl + INTEGER, DIMENSION(3) :: istr,islice + REAL :: cureff, neweff + INTEGER :: ValMax,ValSum,TailleTab + INTEGER :: nbpoints,nbpointsflag + LOGICAL :: test +! + allocate( i_sig(oldB%imin(1):oldB%imax(1)) ) + if ( Agrif_probdim >= 2 ) allocate( j_sig(oldB%imin(2):oldB%imax(2)) ) + if ( Agrif_probdim == 3 ) allocate( k_sig(oldB%imin(3):oldB%imax(3)) ) +! + test = .FALSE. + do i = 1,Agrif_probdim + test = test .OR. ( (oldB%imax(i)-oldB%imin(i)+1) < Agrif_Minwidth) + enddo + if ( test ) return +! + if ( Agrif_probdim == 1 ) i_sig = flag%iarray1 + if ( Agrif_probdim == 2 ) then + do i = oldB%imin(1),oldB%imax(1) + i_sig(i) = SUM(flag%iarray2(i, oldB%imin(2):oldB%imax(2))) + enddo + do j = oldB%imin(2),oldB%imax(2) + j_sig(j) = SUM(flag%iarray2(oldB%imin(1):oldB%imax(1),j)) + enddo + endif + if ( Agrif_probdim == 3 ) then + do i = oldB%imin(1),oldB%imax(1) + i_sig(i) = SUM(flag%iarray3(i,oldB%imin(2):oldB%imax(2), & + oldB%imin(3):oldB%imax(3))) + enddo + do j = oldB%imin(2),oldB%imax(2) + j_sig(j) = SUM(flag%iarray3( oldB%imin(1):oldB%imax(1), j, & + oldB%imin(3):oldB%imax(3))) + enddo + do k = oldB%imin(3),oldB%imax(3) + k_sig(k) = SUM(flag%iarray3( oldB%imin(1):oldB%imax(1), & + oldB%imin(2):oldB%imax(2), k) ) + enddo + endif +! + do i = 1,Agrif_probdim + ipl(i) = oldB%imin(i) + ipu(i) = oldB%imax(i) + enddo +! + call Agrif_Clusterprune(i_sig,ipl(1),ipu(1)) + if ( Agrif_probdim >= 2 ) call Agrif_Clusterprune(j_sig,ipl(2),ipu(2)) + if ( Agrif_probdim == 3 ) call Agrif_Clusterprune(k_sig,ipl(3),ipu(3)) +! + test = .TRUE. + do i = 1,Agrif_probdim + test = test .AND. (ipl(i) == oldB%imin(i)) + test = test .AND. (ipu(i) == oldB%imax(i)) + enddo + + if (.NOT. test) then + do i = 1 , Agrif_probdim + newB%imin(i) = ipl(i) + newB%imax(i) = ipu(i) + enddo +! + if ( Agrif_probdim == 1 ) nbpoints = SUM(flag%iarray1(newB%imin(1):newB%imax(1))) + if ( Agrif_probdim == 2 ) nbpoints = SUM(flag%iarray2(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2))) + if ( Agrif_probdim == 3 ) nbpoints = SUM(flag%iarray3(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2), & + newB%imin(3):newB%imax(3))) +! + if ( Agrif_probdim == 1 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) + if ( Agrif_probdim == 2 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) + if ( Agrif_probdim == 3 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) * & + (newB%imax(3)-newB%imin(3)+1) + neweff = REAL(nbpoints) / TailleTab +! + if (nbpoints > 0) then +! + if ((neweff > Agrif_efficiency)) then + call Agrif_Add_Rectangle(newB,boxlib) + return + else +! + tempbox => boxlib + newB2 = newB + call Agrif_Clusternd(flag,boxlib,newB) +! +! Compute new efficiency + cureff = neweff + parcbox2 => boxlib + nbpoints = 0 + nbpointsflag = 0 +! + do while (associated(parcbox2)) + if (associated(parcbox2,tempbox)) exit + newB = parcbox2%r +! + if ( Agrif_probdim == 1 ) Valsum = SUM(flag%iarray1(newB%imin(1):newB%imax(1))) + if ( Agrif_probdim == 2 ) Valsum = SUM(flag%iarray2(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2))) + if ( Agrif_probdim == 3 ) Valsum = SUM(flag%iarray3(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2), & + newB%imin(3):newB%imax(3))) + nbpointsflag = nbpointsflag + ValSum +! + if ( Agrif_probdim == 1 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) + if ( Agrif_probdim == 2 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) + if ( Agrif_probdim == 3 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) * & + (newB%imax(3)-newB%imin(3)+1) + nbpoints = nbpoints + TailleTab + parcbox2 => parcbox2%next + enddo +! +! coefficient 1.05 avant 1.15 possibilite de laisser choix a l utilisateur + if ( REAL(nbpointsflag)/REAL(nbpoints) < (1.0001*cureff)) then + parcbox2 => boxlib + do while (associated(parcbox2)) + if (associated(parcbox2,tempbox)) exit + deallocate(parcbox2%r) + parcbox2 => parcbox2%next + enddo + boxlib => tempbox + call Agrif_Add_Rectangle(newB2,boxlib) + return + endif + endif + endif + return + endif +! + do i = 1,Agrif_Probdim + istr(i) = oldB%imax(i) + islice(i) = oldB%imin(i) + enddo +! + call Agrif_Clusterslice(i_sig,islice(1),istr(1)) + if ( Agrif_probdim >= 2 ) call Agrif_Clusterslice(j_sig,islice(2),istr(2)) + if ( Agrif_probdim == 3 ) call Agrif_Clusterslice(k_sig,islice(3),istr(3)) +! + ValSum = 0 + do i = 1,Agrif_Probdim + Valsum = valSum + islice(i) + enddo +! + if ( Valsum == -Agrif_Probdim ) then + call Agrif_Add_Rectangle(oldB,boxlib) + return + endif +! + nullify(tempbox) + tempbox => boxlib + if ( Agrif_probdim == 1 ) cureff = (oldB%imax(1)-oldB%imin(1)+1) + if ( Agrif_probdim == 2 ) cureff = (oldB%imax(1)-oldB%imin(1)+1) * & + (oldB%imax(2)-oldB%imin(2)+1) + if ( Agrif_probdim == 3 ) cureff = (oldB%imax(1)-oldB%imin(1)+1) * & + (oldB%imax(2)-oldB%imin(2)+1) * & + (oldB%imax(3)-oldB%imin(3)+1) + nullify(parcbox) +! + do i = 1,Agrif_Probdim + newB%imax(i) = oldB%imax(i) + newB%imin(i) = oldB%imin(i) + enddo +! + ValMax = 0 + do i = 1 , Agrif_Probdim + ValMax = Max(ValMax,istr(i)) + enddo +! + if (istr(1) == ValMax ) then + newB%imax(1) = islice(1) + call Agrif_Add_Rectangle(newB,parcbox) + newB%imin(1) = islice(1)+1 + newB%imax(1) = oldB%imax(1) + call Agrif_Add_Rectangle(newB,parcbox) + else if ( Agrif_probdim >= 2 ) then + if (istr(2) == ValMax ) then + newB%imax(2) = islice(2) + call Agrif_Add_Rectangle(newB,parcbox) + newB%imin(2) = islice(2)+1 + newB%imax(2) = oldB%imax(2) + call Agrif_Add_Rectangle(newB,parcbox) + else if ( Agrif_probdim == 3 ) then + newB%imax(3) = islice(3) + call Agrif_Add_Rectangle(newB,parcbox) + newB%imin(3) = islice(3)+1 + newB%imax(3) = oldB%imax(3) + call Agrif_Add_Rectangle(newB,parcbox) + endif + endif +! + do while ( associated(parcbox) ) + newB = parcbox%r +! + if ( Agrif_probdim == 1 ) nbpoints = SUM(flag%iarray1(newB%imin(1):newB%imax(1))) + if ( Agrif_probdim == 2 ) nbpoints = SUM(flag%iarray2(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2))) + if ( Agrif_probdim == 3 ) nbpoints = SUM(flag%iarray3(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2), & + newB%imin(3):newB%imax(3))) +! + if ( Agrif_probdim == 1 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) + if ( Agrif_probdim == 2 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) + if ( Agrif_probdim == 3 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) * & + (newB%imax(3)-newB%imin(3)+1) + neweff = REAL(nbpoints) / TailleTab +! + if ( nbpoints > 0 ) then +! + if ( (neweff > Agrif_efficiency)) then + call Agrif_Add_Rectangle(newB,boxlib) + else + tempbox => boxlib + newB2 = newB + call Agrif_Clusternd(flag,boxlib,newB) +! +! Compute new efficiency + cureff = neweff + parcbox2 => boxlib + nbpoints = 0 + nbpointsflag = 0 +! + do while (associated(parcbox2)) + if (associated(parcbox2,tempbox)) exit + newB = parcbox2%r +! + if ( Agrif_probdim == 1 ) ValSum = SUM(flag%iarray1(newB%imin(1):newB%imax(1))) + if ( Agrif_probdim == 2 ) ValSum = SUM(flag%iarray2(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2))) + if ( Agrif_probdim == 3 ) ValSum = SUM(flag%iarray3(newB%imin(1):newB%imax(1), & + newB%imin(2):newB%imax(2), & + newB%imin(3):newB%imax(3))) + nbpointsflag = nbpointsflag + ValSum +! + if ( Agrif_probdim == 1 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) + if ( Agrif_probdim == 2 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) + if ( Agrif_probdim == 3 ) TailleTab = (newB%imax(1)-newB%imin(1)+1) * & + (newB%imax(2)-newB%imin(2)+1) * & + (newB%imax(3)-newB%imin(3)+1) + nbpoints = nbpoints + TailleTab + parcbox2 => parcbox2%next + enddo +! + if ( REAL(nbpointsflag)/REAL(nbpoints) < (1.15*cureff)) then + parcbox2 => boxlib + do while (associated(parcbox2)) + if (associated(parcbox2,tempbox)) exit + deallocate(parcbox2%r) + parcbox2 => parcbox2%next + enddo + boxlib => tempbox + call Agrif_Add_Rectangle(newB2,boxlib) + endif + endif + endif + parcbox => parcbox%next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Clusternd +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Clusterslice +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Clusterslice ( sig, slice, str ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(inout) :: slice + INTEGER, intent(inout) :: str + INTEGER, DIMENSION(slice:str), intent(in) :: sig +! + INTEGER :: ideb, ifin + INTEGER :: i, t, a, di, ts + INTEGER, DIMENSION(slice:str) :: lap +! + ideb = slice + ifin = str +! + if (SIZE(sig) <= 2*Agrif_Minwidth) then + str = -1 + slice = -1 + return + endif +! + t = -1 + a = -1 +! + do i = ideb+Agrif_Minwidth-1,ifin-Agrif_Minwidth + if (sig(i) == 0) then + if ((i-ideb) < (ifin-i)) then + di = i - ideb + else + di = ifin - i + endif +! + if (di > t) then + a = i + t = di + endif + endif + enddo +! + if (a /= -1) then + slice = a + str = t + return + endif +! + t = -1 + a = -1 +! + do i = ideb+1,ifin-1 + lap(i) = sig(i+1) + sig(i-1) - 2*sig(i) + enddo +! + do i = ideb + Agrif_Minwidth-1,ifin-Agrif_Minwidth + if ((lap(i+1)*lap(i)) <= 0) then + ts = ABS(lap(i+1) - lap(i)) + if (ts > t) then + t = ts + a = i + endif + endif + enddo +! + if (a == (ideb + Agrif_Minwidth - 1)) then + a = -1 + t = -1 + endif +! + slice = a + str = t +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Clusterslice +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Clusterprune +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Clusterprune ( sig, pl, pu ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(inout) :: pl, pu + INTEGER, DIMENSION(pl:pu), intent(in) :: sig +! + INTEGER :: ideb, ifin + INTEGER :: diff, addl, addu, udist, ldist +! + ideb = pl + ifin = pu +! + if (SIZE(sig) <= Agrif_Minwidth) return +! + do while ((sig(pl) == 0) .AND. (pl < ifin)) + pl = pl + 1 + enddo +! + do while ((sig(pu) == 0) .AND. (pu > ideb)) + pu = pu - 1 + enddo +! + if ( (pu-pl) < Agrif_Minwidth ) then + diff = Agrif_Minwidth - (pu - pl + 1) + udist = ifin - pu + ldist = pl - ideb + addl = diff / 2 + addu = diff - addl + if (addu > udist) then + addu = udist + addl = diff - addu + endif +! + if (addl > ldist) then + addl = ldist + addu = diff - addl + endif +! + pu = pu + addu + pl = pl - addl + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Clusterprune +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Add_Rectangle +! +!> Adds the Agrif_Rectangle R in a list managed by LR. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Add_Rectangle ( R, LR ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Rectangle) :: R + TYPE(Agrif_LRectangle), pointer :: LR +! + TYPE(Agrif_LRectangle), pointer :: newrect +! + integer :: i +! + allocate(newrect) + allocate(newrect % r) +! + newrect % r = R +! + do i = 1,Agrif_Probdim + newrect % r % spaceref(i) = Agrif_Coeffref(i) + newrect % r % timeref(i) = Agrif_Coeffreft(i) + enddo +! + newrect % r % number = -1 + newrect % next => LR + LR => newrect +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Add_Rectangle +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Copy_Rectangle +! +!> Creates and returns a copy of Agrif_Rectangle R. +!--------------------------------------------------------------------------------------------------- +function Agrif_Copy_Rectangle ( R, expand ) result( copy ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Rectangle), pointer, intent(in) :: R + integer, optional, intent(in) :: expand +! + TYPE(Agrif_Rectangle), pointer :: copy +! + allocate(copy) +! + copy = R + if ( present(expand) ) then + copy % imin = copy % imin - expand + copy % imax = copy % imax + expand + endif + copy % childgrids => R % childgrids +!--------------------------------------------------------------------------------------------------- +end function Agrif_Copy_Rectangle +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Read_Fix_Grd +! +!> Creates the grid hierarchy from the reading of the AGRIF_FixedGrids.in file. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Read_Fix_Grd ( parent_rect, j, nunit ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Rectangle), pointer :: parent_rect !< Pointer on the first grid of the grid hierarchy + INTEGER :: j !< Number of the new grid + INTEGER :: nunit !< unit associated with file +! + TYPE(Agrif_Rectangle) :: newrect ! Pointer on a new grid + TYPE(Agrif_LRectangle), pointer :: parcours ! Pointer for the recursive procedure + TYPE(Agrif_LRectangle), pointer :: newlrect + TYPE(Agrif_LRectangle), pointer :: end_list + INTEGER :: i,n ! for each child grid + INTEGER :: nb_grids ! Number of child grids +! +! Reading of the number of child grids + read(nunit,*,end=99) nb_grids +! + allocate(end_list) +! + parent_rect % childgrids => end_list +! +! Reading of imin(1),imax(1),imin(2),imax(2),imin(3),imax(3), and space and +! time refinement factors for each child grid. +! Creation and addition of the new grid to the grid hierarchy. +! + do n = 1,nb_grids +! + allocate(newlrect) + newrect % number = j ! Number of the grid +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then + if (Agrif_Probdim == 3) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % imin(2), newrect % imax(2), & + newrect % imin(3), newrect % imax(3), & + newrect % spaceref(1), newrect % spaceref(2), newrect % spaceref(3), & + newrect % timeref(1), newrect % timeref(2), newrect % timeref(3) + elseif (Agrif_Probdim == 2) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % imin(2), newrect % imax(2), & + newrect % spaceref(1), newrect % spaceref(2), & + newrect % timeref(1), newrect % timeref(2) + elseif (Agrif_Probdim == 1) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % spaceref(1), & + newrect % timeref(1) + endif + else + if (Agrif_Probdim == 3) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % imin(2), newrect % imax(2), & + newrect % imin(3), newrect % imax(3), & + newrect % spaceref(1), newrect % spaceref(2), newrect % spaceref(3), & + newrect % timeref(1) + elseif (Agrif_Probdim == 2) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % imin(2), newrect % imax(2), & + newrect % spaceref(1), newrect % spaceref(2), & + newrect % timeref(1) + elseif (Agrif_Probdim == 1) then + read(nunit,*) newrect % imin(1), newrect % imax(1), & + newrect % spaceref(1), & + newrect % timeref(1) + endif +! + if ( Agrif_probdim >= 2 ) then + do i = 2,Agrif_probdim + newrect % timeref(i) = newrect % timeref(1) + enddo + endif +! + endif +! +! Addition to the grid hierarchy +! + j = j + 1 + allocate(newlrect%r) + newlrect % r = newrect + end_list % next => newlrect + end_list => end_list % next +! + enddo +! + parent_rect % childgrids => parent_rect % childgrids % next + parcours => parent_rect % childgrids +! +! recursive operation to create the grid hierarchy branch by branch +! + do while ( associated(parcours) ) + call Agrif_Read_Fix_Grd(parcours % r, j, nunit) + parcours => parcours % next + enddo +99 continue +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Read_Fix_Grd +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Create_Grids +! +!> Creates the grid hierarchy (g) from the one created with the #Agrif_Read_Fix_Grd or +!! #Agrif_Cluster_All procedures (parent_rect). +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Create_Grids ( parent_grid, parent_rect ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid) , pointer :: parent_grid !< Pointer on the root coarse grid + TYPE(Agrif_Rectangle), pointer :: parent_rect !< Pointer on the root coarse grid of the grid hierarchy + !! created with the #Agrif_Read_Fix_Grd subroutine +! + TYPE(Agrif_Grid) , pointer :: child_grid ! Newly created child grid + TYPE(Agrif_PGrid) , pointer :: child_grid_p + TYPE(Agrif_LRectangle), pointer :: child_rect_p + type(Agrif_Rectangle), pointer :: child_rect +! + INTEGER :: i + INTEGER, save :: moving_grid_id = 0 +! + child_rect_p => parent_rect % childgrids +! +! Creation of the grid hierarchy from the one created by using the Agrif_Read_Fix_Grd subroutine +! + do while ( associated(child_rect_p) ) +! + child_rect => child_rect_p % r +! + allocate(child_grid) +! +! Pointer on the parent grid + child_grid % parent => parent_grid + child_grid % rect_in_parent => Agrif_Copy_Rectangle(child_rect_p % r, expand=Agrif_Extra_Boundary_Cells) +! + moving_grid_id = moving_grid_id+1 + child_grid % grid_id = moving_grid_id +! + do i = 1,Agrif_Probdim + child_grid % spaceref(i) = child_rect % spaceref(i) + child_grid % timeref(i) = child_rect % timeref(i) + child_grid % nb(i) = (child_rect % imax(i) - child_rect % imin(i)) * child_rect % spaceref(i) + child_grid % ix(i) = child_rect % imin(i) + child_grid % Agrif_dt(i) = parent_grid % Agrif_dt(i) / REAL(child_grid % timeref(i)) + child_grid % Agrif_dx(i) = parent_grid % Agrif_dx(i) / REAL(child_grid % spaceref(i)) + child_grid % Agrif_x(i) = parent_grid % Agrif_x(i) + & + (child_rect % imin(i) - 1) * parent_grid % Agrif_dx(i) + enddo +! +! Size of the grid in terms of cpu cost (nx*ny*timeref) + child_grid % size = product( child_grid % nb(1:Agrif_Probdim) ) * child_grid % timeref(1) +! +! Level of the current grid + child_grid % level = child_grid % parent % level + 1 + if (child_grid % level > Agrif_MaxLevelLoc) then + Agrif_MaxLevelLoc = child_grid%level + endif +! +! Number of the grid pointed by child_grid + child_grid % fixedrank = child_rect % number +! +! Grid pointed by child_grid is a fixed grid + child_grid % fixed = ( child_grid % fixedrank > 0 ) +! +! Update the total number of fixed grids + if (child_grid % fixed) then + Agrif_nbfixedgrids = Agrif_nbfixedgrids + 1 + endif +! +! Initialize integration counter + child_grid % ngridstep = 0 +! +! Test indicating if the current grid has a common border with the root +! coarse grid in the x direction + do i = 1 , Agrif_Probdim +! + child_grid % NearRootBorder(i) = ( & + (child_grid % parent % NearRootBorder(i)) .AND. & + (child_grid % ix(i) == 1) ) +! + child_grid % DistantRootBorder(i) = ( & + (child_grid % parent % DistantRootBorder(i)) .AND. & + (child_grid % ix(i) + (child_grid%nb(i)/child_grid%spaceref(i))-1 == child_grid % parent % nb(i)) ) + enddo +! +! Writing in output files + child_grid % oldgrid = .FALSE. +! +#if defined AGRIF_MPI + child_grid % communicator = parent_grid % communicator +#endif +! +! Definition of the characteristics of the variable of the grid pointed by child_grid + call Agrif_Create_Var(child_grid) +! +! Addition of this grid to the grid hierarchy + call Agrif_gl_append( parent_grid % child_list, child_grid ) +! + child_rect_p => child_rect_p % next +! + enddo +! +! Recursive call to the subroutine Agrif_Create_Fixed_Grids to create the grid hierarchy +! + child_grid_p => parent_grid % child_list % first + child_rect_p => parent_rect % childgrids +! + do while ( associated(child_rect_p) ) + call Agrif_Create_Grids( child_grid_p % gr, child_rect_p % r ) + child_grid_p => child_grid_p % next + child_rect_p => child_rect_p % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Create_Grids +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Init_Hierarchy +! +!> Initializes all the grids except the root coarse grid (this one, pointed by Agrif_Types::Agrif_Mygrid, is +!! initialized by the subroutine Agrif_Util#Agrif_Init_Grids defined in the module Agrif_Util and +!! called in the main program). +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Init_Hierarchy ( g, procname ) +!--------------------------------------------------------------------------------------------------- + use Agrif_seq +! + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(init_proc), optional :: procname !< Initialisation subroutine (Default: Agrif_InitValues) +! + TYPE(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive call + LOGICAL :: Init_Hierarchy +! +! Initialise the grand mother grid (if any) +! + if ( associated(g, Agrif_Mygrid) .and. agrif_coarse ) then + call Agrif_Instance(Agrif_Coarsegrid) + call Agrif_Allocation(Agrif_Coarsegrid) + call Agrif_initialisations(Agrif_Coarsegrid) + call Agrif_InitWorkspace() +! +! Initialization by interpolation (this routine is written by the user) + if (present(procname)) Then + call procname() + else + call Agrif_InitValues() + endif + call Agrif_Instance(Agrif_Mygrid) + endif + + parcours => g % child_list % first +! + do while ( associated(parcours) ) +! + Init_Hierarchy = .false. + if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then + if ( (parcours%gr%fixed) .AND. (Agrif_Mygrid%ngridstep == 0) ) then + Init_Hierarchy = .true. + endif + endif +! + if (.NOT. parcours % gr % fixed) Init_Hierarchy = .true. + if (parcours % gr % oldgrid) Init_Hierarchy = .false. +! + if (Init_Hierarchy) then +! +! Instanciation of the grid pointed by parcours%gr and its variables + call Agrif_Instance(parcours % gr) +! +! Allocation of the arrays containing values of the variables of the +! grid pointed by parcours%gr +! + call Agrif_Allocation(parcours % gr) + call Agrif_initialisations(parcours % gr) +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then +! Initialization by copy of the grids created by clustering + call Agrif_Allocate_Restore(parcours % gr) + call Agrif_CopyFromOld_All(parcours % gr, Agrif_oldmygrid) + endif +! +! Initialization by interpolation (this routine is written by the user) + call Agrif_InitWorkSpace() + if (present(procname)) Then + call procname() + else + call Agrif_InitValues() + endif +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then + call Agrif_Free_Restore(parcours % gr) + endif +! + endif +! + parcours => parcours % next +! + enddo +! + parcours => g % child_list % first +! +! recursive operation to initialize all the grids + do while ( associated(parcours) ) + call Agrif_Init_Hierarchy(parcours%gr,procname) + parcours => parcours%next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_Hierarchy +!=================================================================================================== +! +#if defined AGRIF_MPI +!=================================================================================================== +! subroutine Agrif_Init_Hierarchy_Parallel_1 +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Init_Hierarchy_Parallel_1 ( g ) +!--------------------------------------------------------------------------------------------------- + use Agrif_seq +! + type(Agrif_Grid), pointer :: g !< Pointer on the current grid +! + TYPE(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive call + LOGICAL :: Init_Hierarchy +! + parcours => g % child_list % first +! + do while ( associated(parcours) ) +! + Init_Hierarchy = .false. + if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then + if ( (parcours%gr%fixed) .AND. (Agrif_Mygrid%ngridstep == 0) ) then + Init_Hierarchy = .true. + endif + endif +! + if (.NOT. parcours % gr % fixed) Init_Hierarchy = .true. + if (parcours % gr % oldgrid) Init_Hierarchy = .false. +! + if (Init_Hierarchy) then +! +! Instanciation of the grid pointed by parcours%gr and its variables + call Agrif_Instance(parcours % gr) +! +! Allocation of the arrays containing values of the variables of the +! grid pointed by parcours%gr +! + call Agrif_Allocation(parcours % gr) + call Agrif_initialisations(parcours % gr) +! + endif +! + parcours => parcours % next +! + enddo +! + parcours => g % child_list % first +! +! recursive operation to initialize all the grids + do while ( associated(parcours) ) + call Agrif_Init_Hierarchy_Parallel_1(parcours%gr) + parcours => parcours%next + enddo +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_Hierarchy_Parallel_1 +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Init_Hierarchy_Parallel_2 +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Init_Hierarchy_Parallel_2 ( g, procname ) +!--------------------------------------------------------------------------------------------------- + use Agrif_seq +! + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(init_proc), optional :: procname !< Initialisation subroutine (Default: Agrif_InitValues) +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive call + integer :: is +! + call Agrif_Instance(g) + call Agrif_seq_init_sequences( g ) +! + if ( .not. associated(g % child_seq) ) return +! + do is = 1, g % child_seq % nb_seqs +! + parcours => Agrif_seq_select_child(g,is) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) +! +! Initialization by interpolation (this routine is written by the user) + if (present(procname)) Then + call procname() + else + call Agrif_InitValues() + endif +! + call Agrif_Init_ProcList(parcours % gr % proc_def_list, & + parcours % gr % proc_def_in_parent_list % nitems) +! + call Agrif_Init_Hierarchy_Parallel_2(parcours%gr,procname) +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_Hierarchy_Parallel_2 +!=================================================================================================== +#endif +! +!=================================================================================================== +! subroutine Agrif_Allocate_Restore +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Allocate_Restore ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the root coarse grid +! + integer :: i +! + do i = 1,Agrif_NbVariables(0) +! + if ( Agrif_Mygrid%tabvars(i) % restore ) then + if ( Agrif_Gr%tabvars(i) % nbdim == 1 ) then + allocate( Agrif_Gr%tabvars(i)%Restore1D( & + lbound(Agrif_Gr%tabvars(i)%array1,1):& + ubound(Agrif_Gr%tabvars(i)%array1,1))) + Agrif_Gr%tabvars(i)%Restore1D = 0 + endif + if ( Agrif_Gr%tabvars(i) % nbdim == 2 ) then + allocate( Agrif_Gr%tabvars(i)%Restore2D( & + lbound(Agrif_Gr%tabvars(i)%array2,1):& + ubound(Agrif_Gr%tabvars(i)%array2,1),& + lbound(Agrif_Gr%tabvars(i)%array2,2):& + ubound(Agrif_Gr%tabvars(i)%array2,2))) + Agrif_Gr%tabvars(i)%Restore2D = 0 + endif + if ( Agrif_Mygrid%tabvars(i) % nbdim == 3 ) then + allocate( Agrif_Gr%tabvars(i)%Restore3D( & + lbound(Agrif_Gr%tabvars(i)%array3,1):& + ubound(Agrif_Gr%tabvars(i)%array3,1),& + lbound(Agrif_Gr%tabvars(i)%array3,2):& + ubound(Agrif_Gr%tabvars(i)%array3,2),& + lbound(Agrif_Gr%tabvars(i)%array3,3):& + ubound(Agrif_Gr%tabvars(i)%array3,3))) + Agrif_Gr%tabvars(i)%Restore3D = 0 + endif + endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Allocate_Restore +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Free_Restore +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Free_Restore ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the root coarse grid +! + TYPE(Agrif_Variable), pointer :: var + integer :: i +! + do i = 1,Agrif_NbVariables(0) +! + if ( Agrif_Mygrid % tabvars(i) % restore ) then +! + var = Agrif_Gr % tabvars(i) +! + if (associated(var%Restore1D)) deallocate(var%Restore1D) + if (associated(var%Restore2D)) deallocate(var%Restore2D) + if (associated(var%Restore3D)) deallocate(var%Restore3D) + if (associated(var%Restore4D)) deallocate(var%Restore4D) + if (associated(var%Restore5D)) deallocate(var%Restore5D) + if (associated(var%Restore6D)) deallocate(var%Restore6D) +! + endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_Restore +!=================================================================================================== +! +end module Agrif_Clustering diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcurgridfunctions.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcurgridfunctions.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cba23e19b9d27f787d0798c34bd0f687369038e8 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modcurgridfunctions.F90 @@ -0,0 +1,765 @@ +! +! $Id: modcurgridfunctions.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +!> Module to define some procedures concerning the current grid +! +module Agrif_CurgridFunctions +! + use Agrif_Init +! + implicit none +! +contains +! +!=================================================================================================== +! function Agrif_rel_dt +! +!> Returns the time step of the current grid, relatively to the root grid (for which dt=1.). +!--------------------------------------------------------------------------------------------------- +function Agrif_rel_dt ( ) result( rel_dt ) +!--------------------------------------------------------------------------------------------------- + integer :: i + real :: rel_dt +! + rel_dt = 1. +! + do i = 1,Agrif_Probdim + rel_dt = min(rel_dt, Agrif_Curgrid % Agrif_dt(i)) + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_rel_dt +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_rel_idt +! +!> Returns the time refinement factor of the current grid, relatively to the root grid (for which idt=1). +!--------------------------------------------------------------------------------------------------- +function Agrif_rel_idt ( ) result( rel_idt ) +!--------------------------------------------------------------------------------------------------- + integer :: rel_idt +! + rel_idt = nint(1./Agrif_rel_dt()) +!--------------------------------------------------------------------------------------------------- +end function Agrif_rel_idt +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_IRhot +! +!> Returns the time refinement factor of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_IRhot ( ) result( irhot ) +!--------------------------------------------------------------------------------------------------- + integer :: i, irhot +! + irhot = 1 +! + do i = 1,Agrif_Probdim + irhot = max(irhot, Agrif_Curgrid % timeref(i)) + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_IRhot +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Rhot +! +!> Returns the time refinement factor of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Rhot ( ) result( rhot ) +!--------------------------------------------------------------------------------------------------- + real :: rhot +! + rhot = float(Agrif_IRhot()) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Rhot +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_IRhot +! +!> Returns the time refinement factor of the parent of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_IRhot ( ) result( irhot ) +!--------------------------------------------------------------------------------------------------- + integer :: i, irhot +! + irhot = 1 +! + do i = 1,Agrif_Probdim + irhot = max(irhot, Agrif_Curgrid % parent % timeref(i)) + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_IRhot +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Rhot +! +!> Returns the time refinement factor of the parent of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Rhot ( ) result( rhot ) +!--------------------------------------------------------------------------------------------------- + real :: rhot +! + rhot = float(Agrif_Parent_IRhot()) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Rhot +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Nbstepint +! +!> function for the calculation of the coefficients used for the time interpolation +!! (module #Agrif_Boundary). +!--------------------------------------------------------------------------------------------------- +function Agrif_Nbstepint ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_nbstepint ! result +! + Agrif_nbstepint = mod(Agrif_Curgrid % ngridstep, Agrif_iRhot()) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Nbstepint +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Nbstepint +! +!> function for the calculation of the coefficients used for the time interpolation +!! (module #Agrif_Boundary). +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Nbstepint ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Parent_Nbstepint ! result +! + Agrif_Parent_Nbstepint = mod(Agrif_Curgrid % parent % ngridstep, int(Agrif_Parent_Rhot())) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Nbstepint +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpNearBorderX +! +!> Allows to interpolate (in the x direction) on a near border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpNearBorderX ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % NearRootBorder(1) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpNearBorderX +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpDistantBorderX +! +!> Allows to interpolate (in the x direction) on a distant border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpDistantBorderX ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % DistantRootBorder(1) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpDistantBorderX +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpNearBorderY +! +!> Allows to interpolate (in the y direction) on a near border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpNearBorderY ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % NearRootBorder(2) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpNearBorderY +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpDistantBorderY +! +!> Allows to interpolate (in the y direction) on a distant border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpDistantBorderY ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % DistantRootBorder(2) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpDistantBorderY +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpNearBorderZ +! +!> Allows to interpolate (in the z direction) on a near border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpNearBorderZ ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % NearRootBorder(3) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpNearBorderZ +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpDistantBorderZ +! +!> Allows to interpolate (in the z direction) on a distant border of the current grid if this one +!! has a common border with the root coarse grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpDistantBorderZ() +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % DistantRootBorder(3) = .FALSE. +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpDistantBorderZ +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Nb_Step +! +!> Returns the number of time steps of the parent of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Nb_Step ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Parent_Nb_Step ! Result +! + if (Agrif_Root()) then + Agrif_Parent_Nb_Step = -1 + else + Agrif_Parent_Nb_Step = Agrif_Curgrid % parent % ngridstep + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Nb_Step +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Root +! +!> Indicates if the current grid is or not the root grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Root ( ) +!--------------------------------------------------------------------------------------------------- + logical :: Agrif_Root ! Result +! + Agrif_Root = (Agrif_Curgrid % fixedrank == 0) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Root +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_GrandMother +! +!> Indicates if the current grid is or not the root grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_GrandMother ( ) +!--------------------------------------------------------------------------------------------------- + logical :: Agrif_GrandMother ! Result +! + Agrif_GrandMother = Agrif_Curgrid % grand_mother_grid +!--------------------------------------------------------------------------------------------------- +end function Agrif_GrandMother +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Root +! +!> Indicates if the parent of the current grid is or not the root grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Root ( ) +!--------------------------------------------------------------------------------------------------- + logical :: Agrif_Parent_Root ! Result +! + Agrif_Parent_Root = (Agrif_Curgrid % parent % fixedrank == 0) +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Root +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Fixed +! +!> Returns the number of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Fixed ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Fixed ! Result +! + if (Agrif_Curgrid % fixed) then + Agrif_Fixed = Agrif_Curgrid % fixedrank + else + Agrif_Fixed = -1 + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_Fixed +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Fixed +! +!> Returns the number of the parent of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Fixed ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Parent_Fixed ! Result +! + if (Agrif_Curgrid % parent % fixed) then + Agrif_Parent_Fixed = Agrif_Curgrid % parent % fixedrank + else + Agrif_Parent_Fixed = 0 + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Fixed +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Is_Fixed +! +!> Returns .TRUE. if the current grid is fixed. +!--------------------------------------------------------------------------------------------------- +function Agrif_Is_Fixed ( ) +!--------------------------------------------------------------------------------------------------- + logical :: Agrif_Is_Fixed ! Result +! + Agrif_Is_Fixed = Agrif_Curgrid % fixed +!--------------------------------------------------------------------------------------------------- +end function Agrif_Is_Fixed +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Parent_Is_Fixed +! +!> Returns .TRUE. if the parent of the current grid is fixed. +!--------------------------------------------------------------------------------------------------- +function Agrif_Parent_Is_Fixed ( ) +!--------------------------------------------------------------------------------------------------- + logical :: Agrif_Parent_Is_Fixed ! Result +! + Agrif_Parent_Is_Fixed = Agrif_Curgrid % parent % fixed +!--------------------------------------------------------------------------------------------------- +end function Agrif_Parent_Is_Fixed +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_CFixed +! +!> Returns the number of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_CFixed ( ) +!--------------------------------------------------------------------------------------------------- + character(3) :: Agrif_CFixed ! Result +! + character(3) :: cfixed + integer :: fixed +! + fixed = Agrif_Fixed() +! + if (fixed /= -1) then +! + if (fixed <= 9) then + write(cfixed,'(i1)') fixed + else + write(cfixed,'(i2)') fixed + endif +! + Agrif_CFixed = cfixed + + if (associated(agrif_curgrid,agrif_coarsegrid)) then + Agrif_CFixed = 'gm' + endif +! + else + print*,'Call to Agrif_CFixed() on a moving grid' + stop + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_CFixed +!=================================================================================================== +! +!=================================================================================================== +! function Agrid_Parent_CFixed +! +!> Returns the number of the parent of the current grid. +!--------------------------------------------------------------------------------------------------- +function Agrid_Parent_CFixed ( ) +!--------------------------------------------------------------------------------------------------- + character(3) :: Agrid_Parent_CFixed ! Result +! + character(3) :: cfixed + integer :: fixed +! + fixed = Agrif_Parent_Fixed() +! + if(fixed /= -1) then +! + if (fixed <= 9) then + write(cfixed,'(i1)')fixed + else + write(cfixed,'(i2)')fixed + endif +! + Agrid_Parent_CFixed=cfixed +! + else + print*,'Illegal call to Agrid_Parent_CFixed()' + stop + endif +!--------------------------------------------------------------------------------------------------- +end function Agrid_Parent_CFixed +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_ChildGrid_to_ParentGrid +! +!> Make the pointer #Agrif_Curgrid point on the parent grid of the current grid. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_ChildGrid_to_ParentGrid ( ) +!--------------------------------------------------------------------------------------------------- + Agrif_Curgrid % parent % save_grid => Agrif_Curgrid + call Agrif_Instance(Agrif_Curgrid%parent) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_ChildGrid_to_ParentGrid +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_ParentGrid_to_ChildGrid +! +!> Make the pointer #Agrif_Curgrid point on the child grid after having called the +!! #Agrif_ChildGrid_to_ParentGrid subroutine. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_ParentGrid_to_ChildGrid ( ) +!--------------------------------------------------------------------------------------------------- + call Agrif_Instance(Agrif_Curgrid%save_grid) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_ParentGrid_to_ChildGrid +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Get_Unit +! +!> Returns a unit not connected to any file. +!--------------------------------------------------------------------------------------------------- +function Agrif_Get_Unit ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Get_Unit ! Result +! + integer :: n + logical :: op +! + integer :: nunit + integer :: iii, out, iiimax + logical :: bexist + integer,dimension(1:1000) :: forbiddenunit +! +! Load forbidden Unit if the file Agrif_forbidenUnit exist +! + INQUIRE(file='Agrif_forbiddenUnit.txt', exist=bexist) +! + if (.not. bexist) then +! File Agrif_forbiddenUnit.txt not found + else + nunit = 777 + OPEN(nunit,file='Agrif_forbiddenUnit.txt', form='formatted', status="old") + iii = 1 + do while ( .TRUE. ) + READ(nunit,*, end=99) forbiddenunit(iii) + iii = iii + 1 + enddo + 99 continue + iiimax = iii + close(nunit) + endif +! + do n = 7,1000 +! + INQUIRE(Unit=n,Opened=op) +! + out = 0 + if ( bexist .AND. (.NOT.op) ) then + do iii = 1,iiimax + if ( n == forbiddenunit(iii) ) out = 1 + enddo + endif +! + if ( (.NOT.op) .AND. (out == 0) ) exit +! + enddo +! + Agrif_Get_Unit = n +!--------------------------------------------------------------------------------------------------- +end function Agrif_Get_Unit +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_Extra_Boundary_Cells +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_Extra_Boundary_Cells ( nb_extra_cells ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: nb_extra_cells +! + Agrif_Extra_Boundary_Cells = nb_extra_cells +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_Extra_Boundary_Cells +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_Efficiency +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_Efficiency ( eff ) +!--------------------------------------------------------------------------------------------------- + real, intent(in) :: eff +! + if ( (eff < 0.) .OR. (eff > 1) ) then + write(*,*) 'Error Efficiency should be between 0 and 1' + stop + else + Agrif_Efficiency = eff + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_Efficiency +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_Regridding +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_Regridding ( regfreq ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: regfreq +! + if (regfreq < 0) then + write(*,*) 'Regridding frequency should be positive' + stop + else + Agrif_Regridding = regfreq + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_Regridding +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffref_x +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffref_x ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref + + if (coeffref < 0) then + write(*,*) 'Coefficient of raffinement should be positive' + stop + else + Agrif_coeffref(1) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffref_x +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffref_y +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffref_y ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref + + if (coeffref < 0) then + write(*,*) 'Coefficient of raffinement should be positive' + stop + else + Agrif_coeffref(2) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffref_y +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffref_z +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffref_z ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref +! + if (coeffref < 0) then + write(*,*) 'Coefficient of raffinement should be positive' + stop + else + Agrif_coeffref(3) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffref_z +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffreft_x +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffreft_x ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref + + if (coeffref < 0) then + write(*,*) 'Coefficient of time raffinement should be positive' + stop + else + Agrif_coeffreft(1) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffreft_x +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffreft_y +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffreft_y ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref +! + if (coeffref < 0) then + write(*,*) 'Coefficient of time raffinement should be positive' + stop + else + Agrif_coeffreft(2) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffreft_y +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_coeffreft_z +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_coeffreft_z ( coeffref ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coeffref + + if (coeffref < 0) then + write(*,*)'Coefficient of time raffinement should be positive' + stop + else + Agrif_coeffreft(3) = coeffref + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_coeffreft_z +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_Minwidth +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_Minwidth ( coefminwidth ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coefminwidth +! + if (coefminwidth < 0) then + write(*,*)'Coefficient of Minwidth should be positive' + stop + else + Agrif_Minwidth = coefminwidth + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_Minwidth +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_Rafmax +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_Rafmax ( coefrafmax ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: coefrafmax +! + integer :: i + real :: res +! + if (coefrafmax < 0) then + write(*,*)'Coefficient of should be positive' + stop + else + res = 1. + do i = 1,coefrafmax-1 + res = res * FLOAT(Agrif_coeffref(1)) + enddo + if ( res == 0 ) res = 1 + Agrif_Mind(1) = 1. / res +! + res = 1. + do i = 1,coefrafmax-1 + res = res * FLOAT(Agrif_coeffref(2)) + enddo + if ( res == 0 ) res = 1 + Agrif_Mind(2) = 1. / res +! + res = 1. + do i = 1,coefrafmax-1 + res = res * FLOAT(Agrif_coeffref(3)) + enddo + if ( res == 0 ) res = 1 + Agrif_Mind(3) = 1. / res +! + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_Rafmax +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Set_MaskMaxSearch +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Set_MaskMaxSearch ( mymaxsearch ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: mymaxsearch +! + MaxSearch = mymaxsearch +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Set_MaskMaxSearch +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Level +!--------------------------------------------------------------------------------------------------- +function Agrif_Level ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_Level ! Result +! + Agrif_Level = Agrif_Curgrid % level +!--------------------------------------------------------------------------------------------------- +end function Agrif_Level +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_MaxLevel +!--------------------------------------------------------------------------------------------------- +function Agrif_MaxLevel ( ) +!--------------------------------------------------------------------------------------------------- + integer :: Agrif_MaxLevel ! Result +! + Agrif_MaxLevel = Agrif_MaxLevelLoc +!--------------------------------------------------------------------------------------------------- +end function Agrif_MaxLevel +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_GridAllocation_is_done +!--------------------------------------------------------------------------------------------------- +function Agrif_GridAllocation_is_done ( ) result(isdone) +!--------------------------------------------------------------------------------------------------- + logical :: isdone +! + isdone = Agrif_Curgrid % allocation_is_done +!--------------------------------------------------------------------------------------------------- +end function Agrif_GridAllocation_is_done +!=================================================================================================== +! +end module Agrif_CurgridFunctions diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modgrids.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modgrids.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2dd4e3a409ae7de34eeff355c7092d89b218b3f3 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modgrids.F90 @@ -0,0 +1,478 @@ +module Agrif_Grids + + use Agrif_Types +! + implicit none +! +!=================================================================================================== +type Agrif_Grid_List +!--------------------------------------------------------------------------------------------------- +!< List of grids. +! + integer :: nitems = 0 !< Number of elements in the list + type(Agrif_PGrid), pointer :: first => NULL() !< Pointer to the first grid in the list + type(Agrif_PGrid), pointer :: last => NULL() !< Pointer to the last grid inserted in the list +!--------------------------------------------------------------------------------------------------- +end type Agrif_Grid_List +!=================================================================================================== +! +!=================================================================================================== +type Agrif_PGrid +!--------------------------------------------------------------------------------------------------- +!< Data type to go over the grid hierarchy (used for the creation of this grid hierarchy +!< and during the time integration). +! + type(Agrif_Grid) , pointer :: gr => NULL() !< Pointer to the actual grid data structure + type(Agrif_PGrid), pointer :: next => NULL() !< Next grid in the list +! +!--------------------------------------------------------------------------------------------------- +end type Agrif_PGrid +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Grid +!--------------------------------------------------------------------------------------------------- +!< Data type to define a grid (position, space and time refinement factors). +! + type(Agrif_Grid) , pointer :: parent => NULL() !< pointer on the parent grid + type(Agrif_Grid) , pointer :: save_grid => NULL() !< pointer on the save grid + type(Agrif_Grid_List) :: child_list !< List of child grids + type(Agrif_Variable), dimension(:), allocatable :: tabvars !< List of grid variables + type(Agrif_Variable_c), dimension(:), allocatable :: tabvars_c !< List of character grid variables + type(Agrif_Variable_r), dimension(:), allocatable :: tabvars_r !< List of real grid variables + type(Agrif_Variable_l), dimension(:), allocatable :: tabvars_l !< List of logical grid variables + type(Agrif_Variable_i), dimension(:), allocatable :: tabvars_i !< List of integer grid variables +! + real , dimension(3) :: Agrif_x !< global x, y and z position + real , dimension(3) :: Agrif_dx !< global space step in the x, y and z direction + real , dimension(3) :: Agrif_dt !< global time step in the x, y and z direction + integer, dimension(3) :: nb !< number of cells in the x, y and z direction + integer, dimension(3) :: ix !< minimal position in the x, y and z direction + integer, dimension(3) :: spaceref !< space refinement factor in the x, y and z direction + integer, dimension(3) :: timeref !< Time refinement factor in the x, y and z direction + integer :: ngridstep !< number of time steps + integer :: rank + integer :: grid_id !< moving grid id + integer :: fixedrank !< number of the grid + logical :: fixed !< fixed or moving grid ? + logical :: oldgrid +!> \name Logicals indicating if the current grid has a common border with the root coarse grid +!> @{ + logical, dimension(3) :: NearRootBorder + logical, dimension(3) :: DistantRootBorder +!> @} +!> \name Arrays for adaptive grid refinement +!> @{ + integer, dimension(:) , allocatable :: tabpoint1D + integer, dimension(:,:) , allocatable :: tabpoint2D + integer, dimension(:,:,:), allocatable :: tabpoint3D +!> @} +!> \name Members for parallel integration +!> @{ + type(Agrif_Rectangle), pointer :: rect_in_parent => NULL() + type(Agrif_Grid_List) :: neigh_list !< List of neighboring grids (ie. connected through a common proc) + type(Agrif_Proc_List) :: proc_def_list !< List of procs that will integrate this grid + type(Agrif_Proc_List) :: proc_def_in_parent_list !< List of procs that will integrate this grid (defined as in the parent grid) + type(Agrif_Proc_List) :: required_proc_list !< List of procs that are required for this grid + type(Agrif_Sequence_List), pointer :: child_seq => NULL() !< Sequence for childs + integer :: seq_num = 0 + integer :: size = 0 + integer :: dsat = 0 +#if defined AGRIF_MPI + integer :: communicator = -1 +#endif +!> @} + type(Agrif_Variables_List), pointer :: variables => NULL() + integer :: NbVariables = 0 + integer :: level !< level of the grid in the hierarchy + logical :: allocation_is_done = .false. + logical :: grand_mother_grid = .false. +!--------------------------------------------------------------------------------------------------- +end type Agrif_Grid +!=================================================================================================== +! +!> this pointer always points on the root grid of the grid hierarchy +type(Agrif_Grid) , pointer :: Agrif_Mygrid => NULL() + +!> this pointer always points on the grand mother grid of the grid hierarchy (if any) +type(Agrif_Grid) , pointer :: Agrif_Coarsegrid => NULL() + +!> Grid list used in the \link Agrif_Util::Agrif_Regrid() Agrif_regrid \endlink subroutine. +!> It contains the safeguard of the grid hierarchy. +type(Agrif_Grid_List), pointer :: Agrif_oldmygrid => NULL() + +!> Pointer to the current grid (the link is done by using the Agrif_Instance procedure (\see module Agrif_Init)) +type(Agrif_Grid) , pointer :: Agrif_Curgrid => NULL() +! +!=================================================================================================== +type Agrif_Sequence +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List) :: gridlist + type(Agrif_Proc_List) :: proclist +!--------------------------------------------------------------------------------------------------- +end type Agrif_Sequence +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Sequence_List +!--------------------------------------------------------------------------------------------------- + integer :: nb_seqs + type(Agrif_Sequence), dimension(:), allocatable :: sequences +!--------------------------------------------------------------------------------------------------- +end type Agrif_Sequence_List +!=================================================================================================== +! +interface + function compare_grids ( grid1, grid2 ) result( res ) + import Agrif_Grid + type(Agrif_Grid), intent(in) :: grid1 + type(Agrif_Grid), intent(in) :: grid2 + integer :: res !< Result of the comparison : + !! - res < 0 if grid1 < grid2 + !! - res == 0 if grid1 == grid2 + !! - res > 0 if grid1 > grid2 + end function compare_grids +end interface +! +contains +! +!=================================================================================================== +subroutine Agrif_gl_print ( gridlist ) +! +!< DEBUG : a virer à terme. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist +! + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Grid), pointer :: grid +! + gridp => gridlist % first + do while ( associated(gridp) ) + grid => gridp % gr + write(*,'("G",i0,", ")', advance='no') grid % fixedrank + gridp => gridp % next + enddo + write(*,*) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_print +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gl_print_debug ( gridlist ) +! +!< DEBUG : a virer à terme. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist +! + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Grid), pointer :: grid +! + write(*,'(" (nitems=",i2,"), (id,neighs,color,dsat,size) = ")', advance='no') gridlist % nitems + gridp => gridlist % first + do while ( associated(gridp) ) + grid => gridp % gr + write(*,'("(G",i0,4(",",i0),"), ")', advance='no') grid % fixedrank, & + grid % neigh_list % nitems, grid % seq_num, grid % dsat, grid % size + gridp => gridp % next + enddo + write(*,*) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_print_debug +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gl_append ( gridlist, grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(inout) :: gridlist + type(Agrif_Grid), pointer, intent(in) :: grid +! + type(Agrif_PGrid), pointer :: new_gp +! + allocate( new_gp ) +! + new_gp % gr => grid + new_gp % next => NULL() +! + if ( associated(gridlist % last) ) then + ! the list is not empty, append the new pointer at the end + gridlist % last % next => new_gp + else + ! the list is empty, the new pointer is the first one + gridlist % first => new_gp + endif + ! anyway, for next time 'grid' will be the last one. + gridlist % last => new_gp + gridlist % nitems = gridlist % nitems + 1 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_append +!=================================================================================================== +! +!=================================================================================================== +function Agrif_gl_popfirst ( gridlist ) result ( grid ) +! +!< Removes the first item of the list and returns it. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(inout) :: gridlist +! + type(Agrif_PGrid), pointer :: grid_p + type(Agrif_Grid), pointer :: grid +! + grid_p => gridlist % first +! + if ( .not. associated( grid_p ) ) then + grid => NULL() + return + endif +! + grid => grid_p % gr + gridlist % first => grid_p % next + gridlist % nitems = gridlist % nitems - 1 + if ( .not. associated(gridlist % first) ) then + nullify(gridlist % last) + endif + deallocate(grid_p) +!--------------------------------------------------------------------------------------------------- +end function Agrif_gl_popfirst +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gl_copy ( new_gl, model ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(out) :: new_gl + type(Agrif_Grid_List), intent(in) :: model +! + type(Agrif_PGrid), pointer :: gp +! + call Agrif_gl_clear(new_gl) + gp => model % first +! + do while( associated(gp) ) + call Agrif_gl_append( new_gl, gp % gr ) + gp => gp % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_copy +!=================================================================================================== +! +!=================================================================================================== +function Agrif_gl_build_from_gp ( gridp ) result ( gridlist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_PGrid), pointer, intent(in) :: gridp +! + type(Agrif_Grid_List), pointer :: gridlist + type(Agrif_PGrid), pointer :: gp +! + allocate(gridlist) +! + gp => gridp +! + do while ( associated( gp ) ) + call Agrif_gl_append( gridlist, gp % gr ) + gp => gp % next + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_gl_build_from_gp +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gp_delete ( gridp ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_PGrid), pointer, intent(inout) :: gridp +! + type(Agrif_PGrid), pointer :: gp, gpd +! + if ( .not. associated( gridp ) ) return +! + gp => gridp +! + do while( associated(gp) ) + gpd => gp + gp => gp % next + deallocate(gpd) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gp_delete +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gl_clear ( gridlist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(inout) :: gridlist +! + call Agrif_gp_delete(gridlist % first) + gridlist % first => NULL() + gridlist % last => NULL() + gridlist % nitems = 0 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_clear +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_gl_delete ( gridlist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), pointer, intent(inout) :: gridlist +! + if ( .not. associated( gridlist ) ) return +! + call Agrif_gp_delete(gridlist % first) + deallocate( gridlist ) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_gl_delete +!=================================================================================================== +! +!=================================================================================================== +recursive function Agrif_gl_merge_sort ( gridlist, compare_func, compare_func_opt ) result( gl_sorted ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist + procedure(compare_grids) :: compare_func + procedure(compare_grids), optional :: compare_func_opt +! + type(Agrif_Grid_List), pointer :: gl_sorted + type(Agrif_Grid_List), pointer :: gl_left, gl_sorted_left + type(Agrif_Grid_List), pointer :: gl_right, gl_sorted_right + type(Agrif_PGrid), pointer :: grid_p + integer :: n, middle +! +! if list size is 1, consider it sorted and return it + if ( (gridlist % nitems <= 1) ) then + gl_sorted => Agrif_gl_build_from_gp(gridlist % first) + return + endif +! +! else split the list into two sublists + n = 1 + middle = gridlist % nitems / 2 + grid_p => gridlist % first +! + allocate( gl_left, gl_right ) +! + do while ( associated(grid_p) ) + if ( n <= middle ) then + call Agrif_gl_append(gl_left, grid_p % gr) + else + call Agrif_gl_append(gl_right, grid_p % gr) + endif + grid_p => grid_p % next + n = n+1 + enddo +! +! recursively call Agrif_gl_merge_sort() to further split each sublist until sublist size is 1 + gl_sorted_left => Agrif_gl_merge_sort(gl_left, compare_func, compare_func_opt) + gl_sorted_right => Agrif_gl_merge_sort(gl_right, compare_func, compare_func_opt) +! +! merge the sublists returned from prior calls to gl_merge_sort() and return the resulting merged sublist + gl_sorted => Agrif_gl_merge(gl_sorted_left, gl_sorted_right, compare_func, compare_func_opt) +! + call Agrif_gl_delete( gl_left ) + call Agrif_gl_delete( gl_right ) + call Agrif_gl_delete( gl_sorted_left ) + call Agrif_gl_delete( gl_sorted_right ) +!--------------------------------------------------------------------------------------------------- +end function Agrif_gl_merge_sort +!=================================================================================================== +! +!=================================================================================================== +function Agrif_gl_merge ( gl_left, gl_right, compare_func, compare_func_opt ) result( gl_merged ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(inout) :: gl_left + type(Agrif_Grid_List), intent(inout) :: gl_right + procedure(compare_grids) :: compare_func + procedure(compare_grids), optional :: compare_func_opt +! + type(Agrif_Grid_List), pointer :: gl_merged + type(Agrif_Grid), pointer :: poped_grid + integer :: comp_value +! + allocate( gl_merged ) +! + do while ( gl_left % nitems > 0 .or. gl_right % nitems > 0 ) +! + if ( gl_left % nitems > 0 .and. gl_right % nitems > 0 ) then +! +! Let.s compare both items with the first compare function + comp_value = compare_func( gl_left % first % gr, gl_right % first % gr ) +! + if ( comp_value < 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left) + elseif ( comp_value > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_right) + else ! ( comp_value == 0 ) +! +! Both items are equal, let.s use the second criterion if the optional +! compare function is present. + if ( present(compare_func_opt) ) then +! + comp_value = compare_func_opt( gl_left % first % gr, gl_right % first % gr ) +! + if ( comp_value <= 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left) + else ; poped_grid => Agrif_gl_popfirst(gl_right) + endif + else +! If the second criterion is not present, let.s just pick the left item + poped_grid => Agrif_gl_popfirst(gl_left) + endif + endif +! +! If one of the lists is empty, we just have to pick in the other one. + elseif ( gl_left % nitems > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_left) + elseif ( gl_right % nitems > 0 ) then ; poped_grid => Agrif_gl_popfirst(gl_right) + endif +! + call Agrif_gl_append( gl_merged, poped_grid ) +! + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_gl_merge +!=================================================================================================== +! +!=================================================================================================== +function compare_grid_degrees ( grid1, grid2 ) result( res ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(in) :: grid1 + type(Agrif_Grid), intent(in) :: grid2 +! + integer :: res +! + res = grid2 % neigh_list % nitems - grid1 % neigh_list % nitems +!--------------------------------------------------------------------------------------------------- +end function compare_grid_degrees +!=================================================================================================== +! +!=================================================================================================== +function compare_colors ( grid1, grid2 ) result( res ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(in) :: grid1 + type(Agrif_Grid), intent(in) :: grid2 +! + integer :: res +! + res = grid1 % seq_num - grid2 % seq_num +!--------------------------------------------------------------------------------------------------- +end function compare_colors +!=================================================================================================== +! +!=================================================================================================== +function compare_dsat_values ( grid1, grid2 ) result( res ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(in) :: grid1 + type(Agrif_Grid), intent(in) :: grid2 +! + integer :: res +! + res = grid2 % dsat - grid1 % dsat +!--------------------------------------------------------------------------------------------------- +end function compare_dsat_values +!=================================================================================================== +! +!=================================================================================================== +function compare_size_values ( grid1, grid2 ) result( res ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(in) :: grid1 + type(Agrif_Grid), intent(in) :: grid2 +! + integer :: res +! + res = grid2 % size - grid1 % size +!--------------------------------------------------------------------------------------------------- +end function compare_size_values +!=================================================================================================== +! +end module Agrif_Grids diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinit.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinit.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e1c61a69efc38ae37c54b2d7149ad7f0b20c6af --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinit.F90 @@ -0,0 +1,209 @@ +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Init. +!> +!> Several operations on the variables of the current grid (creation, instanciation, ...) +!! used during the creation of the grid hierarchy and during the time integration. +! +module Agrif_Init +! + use Agrif_Grids + use Agrif_Link + use Agrif_Mpp +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_Allocation +! +!> Allocates the arrays containing the values of the variables of the current grd. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Allocation ( Agrif_Gr, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid + procedure(alloc_proc), optional :: procname !< Allocation procedure (Default: Agrif_Allocationcalls) +! + if ( present(procname) ) then + call procname(Agrif_Gr) + else + call Agrif_Allocationcalls(Agrif_Gr) + endif + Agrif_Gr % allocation_is_done = .true. +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then +! + if ( Agrif_Probdim == 1 ) allocate( Agrif_Gr%tabpoint1D(Agrif_Gr%nb(1)+1) ) + if ( Agrif_Probdim == 2 ) allocate( Agrif_Gr%tabpoint2D(Agrif_Gr%nb(1)+1, & + Agrif_Gr%nb(2)+1) ) + if ( Agrif_Probdim == 3 ) allocate( Agrif_Gr%tabpoint3D(Agrif_Gr%nb(1)+1, & + Agrif_Gr%nb(2)+1, & + Agrif_Gr%nb(3)+1) ) + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Allocation +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Instance +! +!> Make the pointer Agrif_Types::Agrif_Curgrid point to Agrif_Gr +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Instance ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid +! + Agrif_Curgrid => Agrif_Gr + Agrif_tabvars => Agrif_Curgrid % tabvars + Agrif_tabvars_c => Agrif_Curgrid % tabvars_c + Agrif_tabvars_r => Agrif_Curgrid % tabvars_r + Agrif_tabvars_l => Agrif_Curgrid % tabvars_l + Agrif_tabvars_i => Agrif_Curgrid % tabvars_i +! +#if defined AGRIF_MPI + if ( Agrif_Gr % communicator /= -1 ) then + call Agrif_MPI_switch_comm( Agrif_Gr % communicator ) + endif +#endif +! + call Agrif_Get_numberofcells(Agrif_Gr) + call Agrif_InitWorkSpace() +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Instance +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_initialisations +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_initialisations ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid +! + integer :: i + type(Agrif_Variable), pointer :: var => NULL() + type(Agrif_Variable_c), pointer :: var_c => NULL() + type(Agrif_Variable_r), pointer :: var_r => NULL() + type(Agrif_Variable_l), pointer :: var_l => NULL() + type(Agrif_Variable_i), pointer :: var_i => NULL() +! + do i = 1,Agrif_NbVariables(0) +! + var => Agrif_Gr % tabvars(i) + var % nbdim = 0 +! + if (allocated(var%array1)) then + var % nbdim = 1 + var % lb(1:1) = lbound(var%array1) + var % ub(1:1) = ubound(var%array1) + endif + if (allocated(var%array2)) then + var % nbdim = 2 + var % lb(1:2) = lbound(var%array2) + var % ub(1:2) = ubound(var%array2) + endif + if (allocated(var%array3)) then + var % nbdim = 3 + var % lb(1:3) = lbound(var%array3) + var % ub(1:3) = ubound(var%array3) + endif + if (allocated(var%array4)) then + var % nbdim = 4 + var % lb(1:4) = lbound(var%array4) + var % ub(1:4) = ubound(var%array4) + endif + if (allocated(var%array5)) then + var % nbdim = 5 + var % lb(1:5) = lbound(var%array5) + var % ub(1:5) = ubound(var%array5) + endif + if (allocated(var%array6)) then + var % nbdim = 6 + var % lb(1:6) = lbound(var%array6) + var % ub(1:6) = ubound(var%array6) + endif +! + if (allocated(var%darray1)) var % nbdim = 1 + if (allocated(var%darray2)) var % nbdim = 2 + if (allocated(var%darray3)) var % nbdim = 3 + if (allocated(var%darray4)) var % nbdim = 4 + if (allocated(var%darray5)) var % nbdim = 5 + if (allocated(var%darray6)) var % nbdim = 6 +! + if (allocated(var%sarray1)) var % nbdim = 1 + if (allocated(var%sarray2)) var % nbdim = 2 + if (allocated(var%sarray3)) var % nbdim = 3 + if (allocated(var%sarray4)) var % nbdim = 4 + if (allocated(var%sarray5)) var % nbdim = 5 + if (allocated(var%sarray6)) var % nbdim = 6 +! + enddo + + do i = 1,Agrif_NbVariables(1) +! + var_c => Agrif_Gr % tabvars_c(i) + var_c % nbdim = 0 +! + if (allocated(var_c%carray1)) var_c % nbdim = 1 + if (allocated(var_c%carray2)) var_c % nbdim = 2 +! + enddo + + do i = 1,Agrif_NbVariables(2) +! + var_r => Agrif_Gr % tabvars_r(i) + var_r % nbdim = 0 +! + enddo + + do i = 1,Agrif_NbVariables(3) +! + var_l => Agrif_Gr % tabvars_l(i) + var_l % nbdim = 0 +! + if (allocated(var_l%larray1)) var_l % nbdim = 1 + if (allocated(var_l%larray2)) var_l % nbdim = 2 + if (allocated(var_l%larray3)) var_l % nbdim = 3 + if (allocated(var_l%larray4)) var_l % nbdim = 4 + if (allocated(var_l%larray5)) var_l % nbdim = 5 + if (allocated(var_l%larray6)) var_l % nbdim = 6 +! + enddo + + do i = 1,Agrif_NbVariables(4) +! + var_i => Agrif_Gr % tabvars_i(i) + var_i % nbdim = 0 +! + if (allocated(var_i%iarray1)) var_i % nbdim = 1 + if (allocated(var_i%iarray2)) var_i % nbdim = 2 + if (allocated(var_i%iarray3)) var_i % nbdim = 3 + if (allocated(var_i%iarray4)) var_i % nbdim = 4 + if (allocated(var_i%iarray5)) var_i % nbdim = 5 + if (allocated(var_i%iarray6)) var_i % nbdim = 6 +! + enddo + +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_initialisations +!=================================================================================================== +! +end module Agrif_Init diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinitvars.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinitvars.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d7fdcf5e7de775901679400221e410df9da51194 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinitvars.F90 @@ -0,0 +1,86 @@ +! +! $Id: modinitvars.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! Agrif (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Init_Vars +!> +!> Initialization of the variables of the current grid. +! +module Agrif_Init_Vars +! + use Agrif_Types + use Agrif_Grids + use Agrif_Link +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_Create_Var +! +!> Allocation of the list of grid variables for grid Agrif_Gr. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Create_Var ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid +! + integer :: nb +! + if (Agrif_NbVariables(0) > 0) allocate(Agrif_Gr % tabvars (Agrif_NbVariables(0))) + if (Agrif_NbVariables(1) > 0) allocate(Agrif_Gr % tabvars_c(Agrif_NbVariables(1))) + if (Agrif_NbVariables(2) > 0) allocate(Agrif_Gr % tabvars_r(Agrif_NbVariables(2))) + if (Agrif_NbVariables(3) > 0) allocate(Agrif_Gr % tabvars_l(Agrif_NbVariables(3))) + if (Agrif_NbVariables(4) > 0) allocate(Agrif_Gr % tabvars_i(Agrif_NbVariables(4))) +! + if ( Agrif_Gr % fixedrank /= 0 ) then + do nb = 1, Agrif_NbVariables(0) + Agrif_Gr % tabvars(nb) % parent_var => Agrif_Gr % parent % tabvars(nb) + Agrif_Gr % tabvars(nb) % nbdim = Agrif_Mygrid % tabvars(nb) % nbdim + Agrif_Gr % tabvars(nb) % root_var => Agrif_Mygrid % tabvars(nb) + enddo + do nb = 1, Agrif_NbVariables(1) + Agrif_Gr % tabvars_c(nb) % parent_var => Agrif_Gr % parent % tabvars_c(nb) + Agrif_Gr % tabvars_c(nb) % nbdim = Agrif_Mygrid % tabvars_c(nb) % nbdim + Agrif_Gr % tabvars_c(nb) % root_var => Agrif_Mygrid % tabvars_c(nb) + enddo + do nb = 1, Agrif_NbVariables(2) + Agrif_Gr % tabvars_r(nb) % parent_var => Agrif_Gr % parent % tabvars_r(nb) + Agrif_Gr % tabvars_r(nb) % nbdim = Agrif_Mygrid % tabvars_r(nb) % nbdim + Agrif_Gr % tabvars_r(nb) % root_var => Agrif_Mygrid % tabvars_r(nb) + enddo + do nb = 1, Agrif_NbVariables(3) + Agrif_Gr % tabvars_l(nb) % parent_var => Agrif_Gr % parent % tabvars_l(nb) + Agrif_Gr % tabvars_l(nb) % nbdim = Agrif_Mygrid % tabvars_l(nb) % nbdim + Agrif_Gr % tabvars_l(nb) % root_var => Agrif_Mygrid % tabvars_l(nb) + enddo + do nb = 1, Agrif_NbVariables(4) + Agrif_Gr % tabvars_i(nb) % parent_var => Agrif_Gr % parent % tabvars_i(nb) + Agrif_Gr % tabvars_i(nb) % nbdim = Agrif_Mygrid % tabvars_i(nb) % nbdim + Agrif_Gr % tabvars_i(nb) % root_var => Agrif_Mygrid % tabvars_i(nb) + enddo + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Create_Var +!=================================================================================================== +! +end module Agrif_Init_Vars diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterp.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6c5e3dd086cbf19953998d37065f3c726881456e --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterp.F90 @@ -0,0 +1,1526 @@ +! +! $Id: modinterp.F90 7752 2017-03-02 12:58:45Z jchanut $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module to initialize a fine grid from its parent grid, by using a space interpolation +! +module Agrif_Interpolation +! + use Agrif_InterpBasic + use Agrif_Arrays + use Agrif_Mask + use Agrif_CurgridFunctions +#if defined AGRIF_MPI + use Agrif_Mpp +#endif +! + implicit none +! + logical, private:: precomputedone(7) = .FALSE. +! + private :: Agrif_Parentbounds + private :: Agrif_Interp_1D_recursive, Agrif_Interp_2D_recursive, Agrif_Interp_3D_recursive + private :: Agrif_Interp_4D_recursive, Agrif_Interp_5D_recursive, Agrif_Interp_6D_recursive + private :: Agrif_InterpBase + private :: Agrif_Find_list_interp, Agrif_AddTo_list_interp +! +contains +! +!=================================================================================================== +! subroutine Agrif_InterpVariable +! +!> Sets some arguments of subroutine Agrif_InterpnD, n being the dimension of the grid variable +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpVariable ( parent, child, torestore, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer :: child !< Variable on the child grid + logical, intent(in) :: torestore !< .false. indicates that the results of the + !! interpolation are applied on the whole current grid + procedure() :: procname !< Data recovery procedure +!--------------------------------------------------------------------------------------------------- + logical :: memberin + integer :: nbdim ! Number of dimensions of the current grid + integer, dimension(6) :: type_interp ! Type of interpolation (linear,spline,...) + integer, dimension(6) :: nb_child + integer, dimension(6) :: lb_child + integer, dimension(6) :: ub_child + integer, dimension(6) :: lb_parent + real , dimension(6) :: s_child, s_parent + real , dimension(6) :: ds_child, ds_parent + integer, dimension(child % root_var % nbdim,2,2) :: childarray +! + nbdim = child % root_var % nbdim + type_interp = child % root_var % type_interp +! + call PreProcessToInterpOrUpdate( parent, child, & + nb_child, ub_child, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, interp=.true.) +! +! Call to a procedure of interpolation against the number of dimensions of the grid variable +! + call Agrif_InterpnD(type_interp, parent, child, & + lb_child, ub_child, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, & + child, torestore, nbdim, & + childarray, memberin, & + .false., procname, 0, 0) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpVariable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpnD +! +!> Interpolates a nD grid variable from its parent grid, by using a space interpolation +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpnD ( type_interp, parent, child, pttab, petab, pttab_Child, pttab_Parent, & + s_Child, s_Parent, ds_Child, ds_Parent, restore, torestore, & + nbdim, childarray, memberin, in_bc, procname, nb, ndir ) +!--------------------------------------------------------------------------------------------------- +#if defined AGRIF_MPI + include 'mpif.h' +#endif +! + INTEGER, DIMENSION(6), INTENT(in) :: type_interp !< Type of interpolation ! (linear,...) + TYPE(Agrif_Variable), pointer :: parent !< Variable of the parent grid + TYPE(Agrif_Variable), pointer :: child !< Variable of the child grid + INTEGER, DIMENSION(nbdim), INTENT(in) :: pttab !< Index of the first point inside the domain + INTEGER, DIMENSION(nbdim), INTENT(in) :: petab !< Index of the first point inside the domain + INTEGER, DIMENSION(nbdim), INTENT(in) :: pttab_Child !< Index of the first point inside the domain + !< for the child grid variable + INTEGER, DIMENSION(nbdim), INTENT(in) :: pttab_Parent !< Index of the first point inside the domain + !< for the parent grid variable + REAL, DIMENSION(nbdim), INTENT(in) :: s_Child,s_Parent !< Positions of the parent and child grids + REAL, DIMENSION(nbdim), INTENT(in) :: ds_Child,ds_Parent !< Space steps of the parent and child grids + TYPE(Agrif_Variable), pointer :: restore !< Indicates points where interpolation + LOGICAL, INTENT(in) :: torestore !< Indicates if the array restore is used + INTEGER, INTENT(in) :: nbdim + LOGICAL, INTENT(out) :: memberin + LOGICAL, INTENT(in) :: in_bc !< .true. if called from Agrif_CorrectVariable \n + !! .false. if called from Agrif_InterpVariable + procedure() :: procname !< Data recovery procedure + INTEGER, INTENT(in) :: nb, ndir +! + INTEGER :: i,j,k,l,m,n + INTEGER, DIMENSION(nbdim) :: pttruetab,cetruetab + INTEGER, DIMENSION(nbdim) :: indmin, indmax + INTEGER, DIMENSION(nbdim) :: indminglob, indmaxglob +#if defined AGRIF_MPI + INTEGER, DIMENSION(nbdim) :: indminglob2,indmaxglob2 +#endif + LOGICAL, DIMENSION(nbdim) :: noraftab + REAL , DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp + INTEGER, DIMENSION(nbdim) :: lowerbound, upperbound, coords + INTEGER, DIMENSION(nbdim,2,2), INTENT(OUT) :: childarray + INTEGER, DIMENSION(nbdim,2,2) :: parentarray + LOGICAL :: member + LOGICAL :: find_list_interp +! +#if defined AGRIF_MPI +! + INTEGER, PARAMETER :: etiquette = 100 + INTEGER :: code, local_proc + INTEGER, DIMENSION(nbdim,4) :: tab3 + INTEGER, DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1, recvfromproc1 + LOGICAL, DIMENSION(1) :: memberin1 + LOGICAL :: memberout +! +#endif +! + type(Agrif_Variable), pointer, save :: tempC => NULL() ! Temporary child grid variable + type(Agrif_Variable), pointer, save :: tempP => NULL() ! Temporary parent grid variable + type(Agrif_Variable), pointer, save :: tempPextend => NULL() ! Temporary parent grid variable + type(Agrif_Variable), pointer, save :: parentvalues => NULL() +! + coords = child % root_var % coords +! +! Boundaries of the current grid where interpolation is done + find_list_interp = & + Agrif_Find_list_interp( & + child % list_interp, & + pttab, petab, pttab_Child, pttab_Parent, nbdim, & + indmin, indmax, indminglob, indmaxglob, & + pttruetab, cetruetab, memberin & +#if defined AGRIF_MPI + ,indminglob2, indmaxglob2, parentarray, & + member, tab4t,memberinall, sendtoproc1, recvfromproc1 & +#endif + ) +! + if (.not.find_list_interp) then +! + call Agrif_get_var_bounds_array(child, lowerbound, upperbound, nbdim) + call Agrif_Childbounds(nbdim, lowerbound, upperbound, & + pttab, petab, Agrif_Procrank, coords, & + pttruetab, cetruetab, memberin) + call Agrif_Parentbounds(type_interp,nbdim,indminglob,indmaxglob, & + s_Parent_temp,s_Child_temp, & + s_Child,ds_Child, & + s_Parent,ds_Parent, & + pttab,petab, & + pttab_Child,pttab_Parent, & + child%root_var % posvar, coords) +#if defined AGRIF_MPI + if (memberin) then + call Agrif_Parentbounds(type_interp,nbdim,indmin,indmax, & + s_Parent_temp,s_Child_temp, & + s_Child,ds_Child, & + s_Parent,ds_Parent, & + pttruetab,cetruetab, & + pttab_Child,pttab_Parent, & + child%root_var % posvar, coords) + endif + + local_proc = Agrif_Procrank + call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) + call Agrif_ChildGrid_to_ParentGrid() +! + call Agrif_Childbounds(nbdim,lowerbound,upperbound, & + indminglob,indmaxglob, local_proc, coords, & + indminglob2,indmaxglob2,member) +! + if (member) then + call Agrif_GlobalToLocalBounds(parentarray, & + lowerbound, upperbound, & + indminglob2, indmaxglob2, coords,& + nbdim, local_proc, member) + endif + + call Agrif_ParentGrid_to_ChildGrid() +#else + parentarray(:,1,1) = indminglob + parentarray(:,2,1) = indmaxglob + parentarray(:,1,2) = indminglob + parentarray(:,2,2) = indmaxglob + indmin = indminglob + indmax = indmaxglob + member = .TRUE. +#endif + + else + +#if defined AGRIF_MPI + s_Parent_temp = s_Parent + (indmin - pttab_Parent) * ds_Parent + s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child +#else + parentarray(:,1,1) = indminglob + parentarray(:,2,1) = indmaxglob + parentarray(:,1,2) = indminglob + parentarray(:,2,2) = indmaxglob + indmin = indminglob + indmax = indmaxglob + member = .TRUE. + s_Parent_temp = s_Parent + (indminglob - pttab_Parent) * ds_Parent + s_Child_temp = s_Child + (pttab - pttab_Child) * ds_Child +#endif + endif +! + if (member) then + if (.not.associated(tempP)) allocate(tempP) +! + call Agrif_array_allocate(tempP,parentarray(:,1,1),parentarray(:,2,1),nbdim) + call Agrif_var_set_array_tozero(tempP,nbdim) + + call Agrif_ChildGrid_to_ParentGrid() +! + select case (nbdim) + case(1) + call procname(tempP%array1, & + parentarray(1,1,2),parentarray(1,2,2),.TRUE.,nb,ndir) + case(2) + call procname(tempP%array2, & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2),.TRUE.,nb,ndir) + case(3) + call procname(tempP%array3, & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2),.TRUE.,nb,ndir) + case(4) + call procname(tempP%array4, & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2),.TRUE.,nb,ndir) + case(5) + call procname(tempP%array5, & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2), & + parentarray(5,1,2),parentarray(5,2,2),.TRUE.,nb,ndir) + case(6) + call procname(tempP%array6, & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2), & + parentarray(5,1,2),parentarray(5,2,2), & + parentarray(6,1,2),parentarray(6,2,2),.TRUE.,nb,ndir) + end select +! + call Agrif_ParentGrid_to_ChildGrid() +! + endif + +#if defined AGRIF_MPI + if (.not.find_list_interp) then +! + tab3(:,1) = indminglob2(:) + tab3(:,2) = indmaxglob2(:) + tab3(:,3) = indmin(:) + tab3(:,4) = indmax(:) +! + call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) + + if (.not.associated(tempPextend)) allocate(tempPextend) + + do k=0,Agrif_Nbprocs-1 + do j=1,4 + do i=1,nbdim + tab4t(i,k,j) = tab4(i,j,k) + enddo + enddo + enddo + + memberin1(1) = memberin + call MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,1,MPI_LOGICAL,Agrif_mpi_comm,code) + + call Get_External_Data_first(tab4t(:,:,1),tab4t(:,:,2), & + tab4t(:,:,3),tab4t(:,:,4), & + nbdim,memberinall, coords, & + sendtoproc1,recvfromproc1, & + tab4t(:,:,5),tab4t(:,:,6), & + tab4t(:,:,7),tab4t(:,:,8) ) + endif + + call ExchangeSameLevel(sendtoproc1,recvfromproc1,nbdim, & + tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6), & + tab4t(:,:,7),tab4t(:,:,8),memberin,tempP,tempPextend) +#else + tempPextend => tempP +#endif + + if (.not.find_list_interp) then + call Agrif_Addto_list_interp( & + child%list_interp,pttab,petab, & + pttab_Child,pttab_Parent,indmin,indmax, & + indminglob,indmaxglob, & + pttruetab,cetruetab, & + memberin,nbdim & +#if defined AGRIF_MPI + ,indminglob2,indmaxglob2, & + parentarray, & + member, & + tab4t,memberinall,sendtoproc1,recvfromproc1 & +#endif + ) + endif +! + if (memberin) then +! + if (.not.associated(tempC)) allocate(tempC) +! + call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) +! +! Special values on the parent grid + if (Agrif_UseSpecialValue) then +! + noraftab(1:nbdim) = child % root_var % interptab(1:nbdim) == 'N' +! + if (.not.associated(parentvalues)) allocate(parentvalues) +! + call Agrif_array_allocate(parentvalues,indmin,indmax,nbdim) + call Agrif_var_full_copy_array(parentvalues,tempPextend,nbdim) +! + call Agrif_CheckMasknD(tempPextend,parentvalues, & + indmin(1:nbdim),indmax(1:nbdim), & + indmin(1:nbdim),indmax(1:nbdim), & + noraftab(1:nbdim),nbdim) +! + call Agrif_array_deallocate(parentvalues,nbdim) +! + endif +! +! Interpolation of the current grid +! + if ( memberin ) then + select case(nbdim) + case(1) + call Agrif_Interp_1D_recursive( type_interp(1), & + tempPextend%array1, & + tempC%array1, & + indmin(1), indmax(1), & + pttruetab(1), cetruetab(1), & + s_Child_temp(1), s_Parent_temp(1), & + ds_Child(1), ds_Parent(1) ) + case(2) + call Agrif_Interp_2D_recursive( type_interp(1:2), & + tempPextend % array2, & + tempC % array2, & + indmin(1:2), indmax(1:2), & + pttruetab(1:2), cetruetab(1:2), & + s_Child_temp(1:2), s_Parent_temp(1:2), & + ds_Child(1:2), ds_Parent(1:2) ) + case(3) + call Agrif_Interp_3D_recursive( type_interp(1:3), & + tempPextend % array3, & + tempC % array3, & + indmin(1:3), indmax(1:3), & + pttruetab(1:3), cetruetab(1:3), & + s_Child_temp(1:3), s_Parent_temp(1:3), & + ds_Child(1:3), ds_Parent(1:3) ) + case(4) + call Agrif_Interp_4D_recursive( type_interp(1:4), & + tempPextend % array4, & + tempC % array4, & + indmin(1:4), indmax(1:4), & + pttruetab(1:4), cetruetab(1:4), & + s_Child_temp(1:4), s_Parent_temp(1:4), & + ds_Child(1:4), ds_Parent(1:4) ) + case(5) + call Agrif_Interp_5D_recursive( type_interp(1:5), & + tempPextend % array5, & + tempC % array5, & + indmin(1:5), indmax(1:5), & + pttruetab(1:5), cetruetab(1:5), & + s_Child_temp(1:5), s_Parent_temp(1:5), & + ds_Child(1:5), ds_Parent(1:5) ) + case(6) + call Agrif_Interp_6D_recursive( type_interp(1:6), & + tempPextend % array6, & + tempC % array6, & + indmin(1:6), indmax(1:6), & + pttruetab(1:6), cetruetab(1:6), & + s_Child_temp(1:6), s_Parent_temp(1:6), & + ds_Child(1:6), ds_Parent(1:6) ) + end select +! + call Agrif_get_var_bounds_array(child,lowerbound,upperbound,nbdim) + +#if defined AGRIF_MPI + call Agrif_GlobalToLocalBounds(childarray, lowerbound, upperbound, & + pttruetab, cetruetab, coords, & + nbdim, Agrif_Procrank, memberout) +#else + childarray(:,1,1) = pttruetab + childarray(:,2,1) = cetruetab + childarray(:,1,2) = pttruetab + childarray(:,2,2) = cetruetab +!cccccccccccccc memberout = .TRUE. +#endif +! +! Special values on the child grid + if (Agrif_UseSpecialValueFineGrid) then + call GiveAgrif_SpecialValueToTab_mpi( child, tempC, childarray, Agrif_SpecialValueFineGrid,nbdim ) + endif +! + endif ! ( memberin ) +! + if (torestore) then +! +#if defined AGRIF_MPI +! + SELECT CASE (nbdim) + CASE (1) + do i = pttruetab(1),cetruetab(1) +!hildarrayAModifier if (restore%restore1D(i) == 0) & +!hildarrayAModifier child%array1(childarray(i,1,2)) = tempC%array1(i) + enddo + CASE (2) + do i = pttruetab(1),cetruetab(1) + do j = pttruetab(2),cetruetab(2) +!hildarrayAModifier if (restore%restore2D(i,j) == 0) & +!hildarrayAModifier child%array2(childarray(i,1,2), & +!hildarrayAModifier childarray(j,2,2)) = tempC%array2(i,j) + enddo + enddo + CASE (3) + do i = pttruetab(1),cetruetab(1) + do j = pttruetab(2),cetruetab(2) + do k = pttruetab(3),cetruetab(3) +!hildarrayAModifier if (restore%restore3D(i,j,k) == 0) & +!hildarrayAModifier child%array3(childarray(i,1,2), & +!hildarrayAModifier childarray(j,2,2), & +!hildarrayAModifier childarray(k,3,2)) = tempC%array3(i,j,k) + enddo + enddo + enddo + CASE (4) + do i = pttruetab(1),cetruetab(1) + do j = pttruetab(2),cetruetab(2) + do k = pttruetab(3),cetruetab(3) + do l = pttruetab(4),cetruetab(4) +!hildarrayAModifier if (restore%restore4D(i,j,k,l) == 0) & +!hildarrayAModifier child%array4(childarray(i,1,2), & +!hildarrayAModifier childarray(j,2,2), & +!hildarrayAModifier childarray(k,3,2), & +!hildarrayAModifier childarray(l,4,2)) = tempC%array4(i,j,k,l) + enddo + enddo + enddo + enddo + CASE (5) + do i = pttruetab(1),cetruetab(1) + do j = pttruetab(2),cetruetab(2) + do k = pttruetab(3),cetruetab(3) + do l = pttruetab(4),cetruetab(4) + do m = pttruetab(5),cetruetab(5) +!hildarrayAModifier if (restore%restore5D(i,j,k,l,m) == 0) & +!hildarrayAModifier child%array5(childarray(i,1,2), & +!hildarrayAModifier childarray(j,2,2), & +!hildarrayAModifier childarray(k,3,2), & +!hildarrayAModifier childarray(l,4,2), & +!hildarrayAModifier childarray(m,5,2)) = tempC%array5(i,j,k,l,m) + enddo + enddo + enddo + enddo + enddo + CASE (6) + do i = pttruetab(1),cetruetab(1) + do j = pttruetab(2),cetruetab(2) + do k = pttruetab(3),cetruetab(3) + do l = pttruetab(4),cetruetab(4) + do m = pttruetab(5),cetruetab(5) + do n = pttruetab(6),cetruetab(6) +!hildarrayAModifier if (restore%restore6D(i,j,k,l,m,n) == 0) & +!hildarrayAModifier child%array6(childarray(i,1,2), & +!hildarrayAModifier childarray(j,2,2), & +!hildarrayAModifier childarray(k,3,2), & +!hildarrayAModifier childarray(l,4,2), & +!hildarrayAModifier childarray(m,5,2), & +!hildarrayAModifier childarray(n,6,2)) = tempC%array6(i,j,k,l,m,n) + enddo + enddo + enddo + enddo + enddo + enddo + END SELECT +! +#else + select case (nbdim) + case (1) + do i = pttruetab(1),cetruetab(1) + if (restore%restore1D(i) == 0) & + parray1(i) = tempC % array1(i) + enddo + case (2) + do j = pttruetab(2),cetruetab(2) + do i = pttruetab(1),cetruetab(1) + if (restore%restore2D(i,j) == 0) & + parray2(i,j) = tempC % array2(i,j) + enddo + enddo + case (3) + do k = pttruetab(3),cetruetab(3) + do j = pttruetab(2),cetruetab(2) + do i = pttruetab(1),cetruetab(1) + if (restore%restore3D(i,j,k) == 0) & + parray3(i,j,k) = tempC % array3(i,j,k) + enddo + enddo + enddo + case (4) + do l = pttruetab(4),cetruetab(4) + do k = pttruetab(3),cetruetab(3) + do j = pttruetab(2),cetruetab(2) + do i = pttruetab(1),cetruetab(1) + if (restore%restore4D(i,j,k,l) == 0) & + parray4(i,j,k,l) = tempC % array4(i,j,k,l) + enddo + enddo + enddo + enddo + case (5) + do m = pttruetab(5),cetruetab(5) + do l = pttruetab(4),cetruetab(4) + do k = pttruetab(3),cetruetab(3) + do j = pttruetab(2),cetruetab(2) + do i = pttruetab(1),cetruetab(1) + if (restore%restore5D(i,j,k,l,m) == 0) & + parray5(i,j,k,l,m) = tempC % array5(i,j,k,l,m) + enddo + enddo + enddo + enddo + enddo + case (6) + do n = pttruetab(6),cetruetab(6) + do m = pttruetab(5),cetruetab(5) + do l = pttruetab(4),cetruetab(4) + do k = pttruetab(3),cetruetab(3) + do j = pttruetab(2),cetruetab(2) + do i = pttruetab(1),cetruetab(1) + if (restore%restore6D(i,j,k,l,m,n) == 0) & + parray6(i,j,k,l,m,n) = tempC % array6(i,j,k,l,m,n) + enddo + enddo + enddo + enddo + enddo + enddo + end select +! +#endif +! + else ! .not.to_restore +! + if (memberin) then + ! + if ( .not.in_bc ) then + select case(nbdim) + case(1) + call procname(tempC % array1( & + childarray(1,1,1):childarray(1,2,1)), & + childarray(1,1,2),childarray(1,2,2),.FALSE.,nb,ndir) + case(2) + call procname( & + tempC % array2( & + childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1)), & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2),.FALSE.,nb,ndir) + case(3) + call procname( & + tempC % array3( & + childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1)), & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2),.FALSE.,nb,ndir) + case(4) + call procname( & + tempC % array4( & + childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1)), & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2),.FALSE.,nb,ndir) + case(5) + call procname( & + tempC % array5( & + childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1), & + childarray(5,1,1):childarray(5,2,1)), & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2), & + childarray(5,1,2),childarray(5,2,2),.FALSE.,nb,ndir) + case(6) + call procname( & + tempC % array6( & + childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1), & + childarray(5,1,1):childarray(5,2,1), & + childarray(6,1,1):childarray(6,2,1)), & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2), & + childarray(5,1,2),childarray(5,2,2), & + childarray(6,1,2),childarray(6,2,2),.FALSE.,nb,ndir) + end select + else ! we are in_bc + select case (nbdim) + case (1) + parray1(childarray(1,1,2):childarray(1,2,2)) = & + tempC%array1(childarray(1,1,1):childarray(1,2,1)) + case (2) + parray2(childarray(1,1,2):childarray(1,2,2), & + childarray(2,1,2):childarray(2,2,2)) = & + tempC%array2(childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1)) + case (3) + parray3(childarray(1,1,2):childarray(1,2,2), & + childarray(2,1,2):childarray(2,2,2), & + childarray(3,1,2):childarray(3,2,2)) = & + tempC%array3(childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1)) + case (4) + parray4(childarray(1,1,2):childarray(1,2,2), & + childarray(2,1,2):childarray(2,2,2), & + childarray(3,1,2):childarray(3,2,2), & + childarray(4,1,2):childarray(4,2,2)) = & + tempC%array4(childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1)) + case (5) + parray5(childarray(1,1,2):childarray(1,2,2), & + childarray(2,1,2):childarray(2,2,2), & + childarray(3,1,2):childarray(3,2,2), & + childarray(4,1,2):childarray(4,2,2), & + childarray(5,1,2):childarray(5,2,2)) = & + tempC%array5(childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1), & + childarray(5,1,1):childarray(5,2,1)) + case (6) + parray6(childarray(1,1,2):childarray(1,2,2), & + childarray(2,1,2):childarray(2,2,2), & + childarray(3,1,2):childarray(3,2,2), & + childarray(4,1,2):childarray(4,2,2), & + childarray(5,1,2):childarray(5,2,2), & + childarray(6,1,2):childarray(6,2,2)) = & + tempC%array6(childarray(1,1,1):childarray(1,2,1), & + childarray(2,1,1):childarray(2,2,1), & + childarray(3,1,1):childarray(3,2,1), & + childarray(4,1,1):childarray(4,2,1), & + childarray(5,1,1):childarray(5,2,1), & + childarray(6,1,1):childarray(6,2,1)) + end select + endif ! < (.not.in_bc) + endif ! < memberin +! + endif + + call Agrif_array_deallocate(tempPextend,nbdim) + call Agrif_array_deallocate(tempC,nbdim) + + endif +! +! Deallocations +#if defined AGRIF_MPI + if (member) then + call Agrif_array_deallocate(tempP,nbdim) + endif +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpnD +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Parentbounds +! +!> Calculates the bounds of the parent grid for the interpolation of the child grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Parentbounds ( type_interp, nbdim, indmin, indmax, & + s_Parent_temp, s_Child_temp, & + s_Child, ds_Child, & + s_Parent,ds_Parent, & + pttruetab, cetruetab, & + pttab_Child, pttab_Parent, posvar, coords ) +!--------------------------------------------------------------------------------------------------- + INTEGER, DIMENSION(6), intent(in) :: type_interp + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim), intent(out) :: indmin, indmax + REAL, DIMENSION(nbdim), intent(out) :: s_Parent_temp, s_child_temp + REAL, DIMENSION(nbdim), intent(in) :: s_Child, ds_child + REAL, DIMENSION(nbdim), intent(in) :: s_Parent,ds_Parent + INTEGER, DIMENSION(nbdim), intent(in) :: pttruetab, cetruetab + INTEGER, DIMENSION(nbdim), intent(in) :: pttab_Child, pttab_Parent + INTEGER, DIMENSION(nbdim), intent(in) :: posvar + INTEGER, DIMENSION(nbdim), intent(in) :: coords +! + INTEGER :: i + REAL,DIMENSION(nbdim) :: dim_newmin, dim_newmax +! + dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child + dim_newmax = s_Child + (cetruetab - pttab_Child) * ds_Child +! + do i = 1,nbdim +! + indmin(i) = pttab_Parent(i) + agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i)) + indmax(i) = pttab_Parent(i) + agrif_ceiling((dim_newmax(i)-s_Parent(i))/ds_Parent(i)) +! +! Necessary for the Quadratic interpolation +! + if ( (pttruetab(i) == cetruetab(i)) .and. (posvar(i) == 1) ) then + elseif ( coords(i) == 0 ) then ! (interptab == 'N') + elseif ( (type_interp(i) == Agrif_ppm) .or. & + (type_interp(i) == Agrif_eno) .or. & + (type_interp(i) == Agrif_ppm_lim) .or. & + (type_interp(i) == Agrif_weno) ) then + indmin(i) = indmin(i) - 2 + indmax(i) = indmax(i) + 2 + + if (Agrif_UseSpecialValue) then + indmin(i) = indmin(i)-MaxSearch + indmax(i) = indmax(i)+MaxSearch + endif + + elseif ( (type_interp(i) /= Agrif_constant) .and. & + (type_interp(i) /= Agrif_linear) ) then + indmin(i) = indmin(i) - 1 + indmax(i) = indmax(i) + 1 + + if (Agrif_UseSpecialValue) then + indmin(i) = indmin(i)-MaxSearch + indmax(i) = indmax(i)+MaxSearch + endif + + elseif ( (type_interp(i) == Agrif_constant) .or. & + (type_interp(i) == Agrif_linear) ) then + if (Agrif_UseSpecialValue) then + indmin(i) = indmin(i)-MaxSearch + indmax(i) = indmax(i)+MaxSearch + endif + + endif +! + enddo +! + s_Parent_temp = s_Parent + (indmin - pttab_Parent) * ds_Parent + s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Parentbounds +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_1D_Recursive +! +!> Subroutine for the interpolation of a 1D grid variable. +!> It calls Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_1D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: type_interp + integer, intent(in) :: indmin, indmax + integer, intent(in) :: pttab_child, petab_child + real, intent(in) :: s_child, s_parent + real, intent(in) :: ds_child, ds_parent + real, dimension( & + indmin:indmax & + ), intent(in) :: tabin + real, dimension( & + pttab_child:petab_child & + ), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + call Agrif_InterpBase(type_interp, & + tabin(indmin:indmax), & + tabout(pttab_child:petab_child), & + indmin, indmax, & + pttab_child, petab_child, & + s_parent, s_child, & + ds_parent, ds_child) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_1D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_2D_Recursive +! +!> Subroutine for the interpolation of a 2D grid variable. +!> It calls Agrif_Interp_1D_recursive and Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_2D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(2), intent(in) :: type_interp + integer, dimension(2), intent(in) :: indmin, indmax + integer, dimension(2), intent(in) :: pttab_child, petab_child + real, dimension(2), intent(in) :: s_child, s_parent + real, dimension(2), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2)), intent(in) :: tabin + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2)), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + real, dimension( & + pttab_child(1):petab_child(1), & + indmin(2):indmax(2)) :: tabtemp + real, dimension( & + pttab_child(2):petab_child(2), & + pttab_child(1):petab_child(1)) :: tabout_trsp + real, dimension( & + indmin(2):indmax(2), & + pttab_child(1):petab_child(1)) :: tabtemp_trsp + integer :: i, j, coeffraf +!--------------------------------------------------------------------------------------------------- +! + coeffraf = nint ( ds_parent(1) / ds_child(1) ) +! + if ((type_interp(1) == Agrif_Linear) .and. (coeffraf /= 1)) then +!---CDIR NEXPAND + if(.NOT. precomputedone(1)) & + call Linear1dPrecompute2d( & + indmax(2)-indmin(2)+1, & + indmax(1)-indmin(1)+1, & + petab_child(1)-pttab_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) +!---CDIR NEXPAND + call Linear1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1) +! + elseif ((type_interp(1) == Agrif_PPM) .and. (coeffraf /= 1)) then +!---CDIR NEXPAND + if(.NOT. precomputedone(1)) & + call PPM1dPrecompute2d( & + indmax(2)-indmin(2)+1, & + indmax(1)-indmin(1)+1, & + petab_child(1)-pttab_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) +!---CDIR NEXPAND + call PPM1dAfterCompute(tabin,tabtemp,size(tabin),size(tabtemp),1) + else + do j = indmin(2),indmax(2) +! +!---CDIR NEXPAND + call Agrif_Interp_1D_recursive(type_interp(1), & + tabin(indmin(1):indmax(1),j), & + tabtemp(pttab_child(1):petab_child(1),j), & + indmin(1),indmax(1), & + pttab_child(1),petab_child(1), & + s_child(1), s_parent(1), & + ds_child(1),ds_parent(1)) +! + enddo + endif + + coeffraf = nint(ds_parent(2)/ds_child(2)) + tabtemp_trsp = TRANSPOSE(tabtemp) + + if ((type_interp(2) == Agrif_Linear) .and. (coeffraf /= 1)) then +!---CDIR NEXPAND + if(.NOT. precomputedone(2)) & + call Linear1dPrecompute2d( & + petab_child(1)-pttab_child(1)+1, & + indmax(2)-indmin(2)+1, & + petab_child(2)-pttab_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) +!---CDIR NEXPAND + call Linear1dAfterCompute(tabtemp_trsp,tabout_trsp, & + size(tabtemp_trsp),size(tabout_trsp),2) + + elseif ((type_interp(2) == Agrif_PPM) .and. (coeffraf /= 1)) then +!---CDIR NEXPAND + if(.NOT. precomputedone(2)) & + call PPM1dPrecompute2d( & + petab_child(1)-pttab_child(1)+1, & + indmax(2)-indmin(2)+1, & + petab_child(2)-pttab_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) +!---CDIR NEXPAND + call PPM1dAfterCompute(tabtemp_trsp, tabout_trsp, & + size(tabtemp_trsp), size(tabout_trsp), 2) + else + do i = pttab_child(1), petab_child(1) +! +!---CDIR NEXPAND + call Agrif_InterpBase(type_interp(2), & + tabtemp_trsp(indmin(2):indmax(2), i), & + tabout_trsp(pttab_child(2):petab_child(2), i), & + indmin(2), indmax(2), & + pttab_child(2), petab_child(2), & + s_parent(2), s_child(2), & + ds_parent(2), ds_child(2) ) + enddo + endif +! + tabout = TRANSPOSE(tabout_trsp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_2D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_3D_Recursive +! +!> Subroutine for the interpolation of a 3D grid variable. +!> It calls #Agrif_Interp_2D_recursive and #Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_3D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(3), intent(in) :: type_interp + integer, dimension(3), intent(in) :: indmin, indmax + integer, dimension(3), intent(in) :: pttab_child, petab_child + real, dimension(3), intent(in) :: s_child, s_parent + real, dimension(3), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3)), intent(in) :: tabin + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3)), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + indmin(3):indmax(3)) :: tabtemp + integer :: i, j, k, coeffraf + integer :: locind_child_left, kdeb +! + coeffraf = nint ( ds_parent(1) / ds_child(1) ) + if ( (type_interp(1) == Agrif_Linear) .and. (coeffraf/=1) ) then + call Linear1dPrecompute2d(indmax(2)-indmin(2)+1, & + indmax(1)-indmin(1)+1, & + petab_child(1)-pttab_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) + precomputedone(1) = .TRUE. + elseif ( (type_interp(1) == Agrif_PPM) .and. (coeffraf/=1) ) then + call PPM1dPrecompute2d(indmax(2)-indmin(2)+1, & + indmax(1)-indmin(1)+1, & + petab_child(1)-pttab_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) + precomputedone(1) = .TRUE. + endif + + coeffraf = nint ( ds_parent(2) / ds_child(2) ) + if ( (type_interp(2) == Agrif_Linear) .and. (coeffraf/=1) ) then + call Linear1dPrecompute2d(petab_child(1)-pttab_child(1)+1, & + indmax(2)-indmin(2)+1, & + petab_child(2)-pttab_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) + precomputedone(2) = .TRUE. + elseif ( (type_interp(2) == Agrif_PPM) .and. (coeffraf/=1) ) then + call PPM1dPrecompute2d(petab_child(1)-pttab_child(1)+1, & + indmax(2)-indmin(2)+1, & + petab_child(2)-pttab_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) + precomputedone(2) = .TRUE. + endif +! + do k = indmin(3), indmax(3) + call Agrif_Interp_2D_recursive(type_interp(1:2), & + tabin(indmin(1):indmax(1), & + indmin(2):indmax(2), k), & + tabtemp(pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), k), & + indmin(1:2), indmax(1:2), & + pttab_child(1:2), petab_child(1:2), & + s_child(1:2), s_parent(1:2), & + ds_child(1:2), ds_parent(1:2) ) + enddo +! + precomputedone(1) = .FALSE. + precomputedone(2) = .FALSE. + coeffraf = nint(ds_parent(3)/ds_child(3)) +! + if ( coeffraf == 1 ) then + locind_child_left = 1 + agrif_int((s_child(3)-s_parent(3))/ds_parent(3)) + kdeb = indmin(3)+locind_child_left-2 + do k = pttab_child(3),petab_child(3) + kdeb = kdeb + 1 + do j = pttab_child(2), petab_child(2) + do i = pttab_child(1), petab_child(1) + tabout(i,j,k) = tabtemp(i,j,kdeb) + enddo + enddo + enddo + else + do j = pttab_child(2), petab_child(2) + do i = pttab_child(1), petab_child(1) + call Agrif_InterpBase(type_interp(3), & + tabtemp(i,j,indmin(3):indmax(3)), & + tabout(i,j,pttab_child(3):petab_child(3)), & + indmin(3), indmax(3), & + pttab_child(3), petab_child(3), & + s_parent(3), s_child(3), & + ds_parent(3), ds_child(3) ) + enddo + enddo + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_3D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_4D_Recursive +! +!> Subroutine for the interpolation of a 4D grid variable. +!> It calls #Agrif_Interp_3D_recursive and #Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_4D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(4), intent(in) :: type_interp + integer, dimension(4), intent(in) :: indmin, indmax + integer, dimension(4), intent(in) :: pttab_child, petab_child + real, dimension(4), intent(in) :: s_child, s_parent + real, dimension(4), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4)), intent(in) :: tabin + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4)), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + indmin(4):indmax(4)) :: tabtemp + integer :: i, j, k, l +! + do l = indmin(4), indmax(4) + call Agrif_Interp_3D_recursive(type_interp(1:3), & + tabin(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), l), & + tabtemp(pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), l), & + indmin(1:3), indmax(1:3), & + pttab_child(1:3), petab_child(1:3), & + s_child(1:3), s_parent(1:3), & + ds_child(1:3), ds_parent(1:3) ) + enddo +! + do k = pttab_child(3), petab_child(3) + do j = pttab_child(2), petab_child(2) + do i = pttab_child(1), petab_child(1) + call Agrif_InterpBase(type_interp(4), & + tabtemp(i,j,k,indmin(4):indmax(4)), & + tabout(i,j,k,pttab_child(4):petab_child(4)), & + indmin(4), indmax(4), & + pttab_child(4), petab_child(4), & + s_parent(4), s_child(4), & + ds_parent(4), ds_child(4) ) + enddo + enddo + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_4D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_5D_Recursive +! +!> Subroutine for the interpolation of a 5D grid variable. +!> It calls #Agrif_Interp_4D_recursive and #Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_5D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(5), intent(in) :: type_interp + integer, dimension(5), intent(in) :: indmin, indmax + integer, dimension(5), intent(in) :: pttab_child, petab_child + real, dimension(5), intent(in) :: s_child, s_parent + real, dimension(5), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5)), intent(in) :: tabin + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), & + pttab_child(5):petab_child(5)), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), & + indmin(5):indmax(5)) :: tabtemp + integer :: i, j, k, l, m +! + do m = indmin(5), indmax(5) + call Agrif_Interp_4D_recursive(type_interp(1:4), & + tabin(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4),m), & + tabtemp(pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), m), & + indmin(1:4),indmax(1:4), & + pttab_child(1:4), petab_child(1:4), & + s_child(1:4), s_parent(1:4), & + ds_child(1:4), ds_parent(1:4) ) + enddo +! + do l = pttab_child(4), petab_child(4) + do k = pttab_child(3), petab_child(3) + do j = pttab_child(2), petab_child(2) + do i = pttab_child(1), petab_child(1) + call Agrif_InterpBase(type_interp(5), & + tabtemp(i,j,k,l,indmin(5):indmax(5)), & + tabout(i,j,k,l,pttab_child(5):petab_child(5)), & + indmin(5), indmax(5), & + pttab_child(5), petab_child(5), & + s_parent(5), s_child(5), & + ds_parent(5), ds_child(5) ) + enddo + enddo + enddo + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_5D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Interp_6D_Recursive +! +!> Subroutine for the interpolation of a 6D grid variable. +!> It calls #Agrif_Interp_5D_recursive and Agrif_InterpBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Interp_6D_recursive ( type_interp, tabin, tabout, & + indmin, indmax, & + pttab_child, petab_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(6), intent(in) :: type_interp + integer, dimension(6), intent(in) :: indmin, indmax + integer, dimension(6), intent(in) :: pttab_child, petab_child + real, dimension(6), intent(in) :: s_child, s_parent + real, dimension(6), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5), & + indmin(6):indmax(6)), intent(in) :: tabin + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), & + pttab_child(5):petab_child(5), & + pttab_child(6):petab_child(6)), intent(out) :: tabout +!--------------------------------------------------------------------------------------------------- + real, dimension( & + pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), & + pttab_child(5):petab_child(5), & + indmin(6):indmax(6)) :: tabtemp + integer :: i, j, k, l, m, n +! + do n = indmin(6), indmax(6) + call Agrif_Interp_5D_recursive(type_interp(1:5), & + tabin(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5), n), & + tabtemp(pttab_child(1):petab_child(1), & + pttab_child(2):petab_child(2), & + pttab_child(3):petab_child(3), & + pttab_child(4):petab_child(4), & + pttab_child(5):petab_child(5), n), & + indmin(1:5),indmax(1:5), & + pttab_child(1:5), petab_child(1:5), & + s_child(1:5), s_parent(1:5), & + ds_child(1:5),ds_parent(1:5) ) + enddo +! + do m = pttab_child(5), petab_child(5) + do l = pttab_child(4), petab_child(4) + do k = pttab_child(3), petab_child(3) + do j = pttab_child(2), petab_child(2) + do i = pttab_child(1), petab_child(1) + call Agrif_InterpBase(type_interp(6), & + tabtemp(i,j,k,l,m,indmin(6):indmax(6)), & + tabout(i,j,k,l,m,pttab_child(6):petab_child(6)), & + indmin(6), indmax(6), & + pttab_child(6), petab_child(6), & + s_parent(6), s_child(6), & + ds_parent(6), ds_child(6) ) + enddo + enddo + enddo + enddo + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Interp_6D_recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_InterpBase +! +!> Calls the interpolation method chosen by the user (linear, lagrange, spline, etc.). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_InterpBase ( type_interp, parenttab, childtab, indmin, indmax, & + pttab_child, petab_child, & + s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + INTEGER :: type_interp + INTEGER :: indmin, indmax + INTEGER :: pttab_child, petab_child + REAL, DIMENSION(indmin:indmax), INTENT(IN) :: parenttab + REAL, DIMENSION(pttab_child:petab_child), INTENT(OUT) :: childtab + REAL :: s_parent, s_child + REAL :: ds_parent,ds_child +! + if ( (indmin == indmax) .and. (pttab_child == petab_child) ) then +! + childtab(pttab_child) = parenttab(indmin) +! + elseif (type_interp == Agrif_LINEAR) then ! Linear interpolation +! + call Agrif_basicinterp_linear1D(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif ( type_interp == Agrif_PPM ) then ! PPM interpolation + + call PPM1d(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif ( type_interp == Agrif_PPM_LIM ) then ! PPM interpolation + + call PPM1d_lim(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_LAGRANGE) then ! Lagrange interpolation +! + call lagrange1D(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_ENO) then ! Eno interpolation +! + call ENO1d(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_WENO) then ! Weno interpolation +! + call WENO1d(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_LINEARCONSERV) then ! Linear conservative interpolation +! + call Linear1dConserv(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_LINEARCONSERVLIM) then !Linear conservative interpolation +! + call Linear1dConservLim(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + elseif (type_interp == Agrif_CONSTANT) then +! + call Constant1d(parenttab,childtab, & + indmax-indmin+1,petab_child-pttab_child+1, & + s_parent,s_child,ds_parent,ds_child) +! + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_InterpBase +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Find_list_interp +!--------------------------------------------------------------------------------------------------- +function Agrif_Find_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & + nbdim, indmin, indmax, indminglob, indmaxglob, & + pttruetab, cetruetab, memberin & +#if defined AGRIF_MPI + ,indminglob2, indmaxglob2, parentarray, & + member, tab4t, memberinall, sendtoproc1, recvfromproc1 & +#endif + ) result(find_list_interp) +!--------------------------------------------------------------------------------------------------- + type(Agrif_List_Interp_Loc), pointer :: list_interp + integer, intent(in) :: nbdim + integer, dimension(nbdim), intent(in) :: pttab, petab, pttab_Child, pttab_Parent + integer, dimension(nbdim), intent(out) :: indmin, indmax + integer, dimension(nbdim), intent(out) :: indminglob, indmaxglob + integer, dimension(nbdim), intent(out) :: pttruetab, cetruetab + logical, intent(out) :: memberin +#if defined AGRIF_MPI + integer, dimension(nbdim), intent(out) :: indminglob2, indmaxglob2 + integer, dimension(nbdim,2,2), intent(out) :: parentarray + logical, intent(out) :: member + integer, dimension(nbdim,0:Agrif_Nbprocs-1,8), intent(out) :: tab4t + logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: memberinall + logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: sendtoproc1, recvfromproc1 +#endif + logical :: find_list_interp +! + integer :: i + type(Agrif_List_Interp_Loc), pointer :: parcours + type(Agrif_Interp_Loc), pointer :: pil + + find_list_interp = .false. + + if ( .not. associated(list_interp) ) return + + parcours => list_interp + find_loop : do while ( associated(parcours) ) + + pil => parcours % interp_loc + + do i = 1,nbdim + if ( (pttab(i) /= pil % pttab(i)) .or. & + (petab(i) /= pil % petab(i)) .or. & + (pttab_child(i) /= pil % pttab_child(i)) .or. & + (pttab_parent(i) /= pil % pttab_parent(i)) ) then + parcours => parcours % suiv + cycle find_loop + endif + enddo + + indmin = pil % indmin(1:nbdim) + indmax = pil % indmax(1:nbdim) + + pttruetab = pil % pttruetab(1:nbdim) + cetruetab = pil % cetruetab(1:nbdim) + +#if !defined AGRIF_MPI + indminglob = pil % indminglob(1:nbdim) + indmaxglob = pil % indmaxglob(1:nbdim) +#else + indminglob = pil % indminglob2(1:nbdim) + indmaxglob = pil % indmaxglob2(1:nbdim) + indminglob2 = pil % indminglob2(1:nbdim) + indmaxglob2 = pil % indmaxglob2(1:nbdim) + parentarray = pil % parentarray(1:nbdim,:,:) + member = pil % member + tab4t = pil % tab4t(1:nbdim, 0:Agrif_Nbprocs-1, 1:8) + memberinall = pil % memberinall(0:Agrif_Nbprocs-1) + sendtoproc1 = pil % sendtoproc1(0:Agrif_Nbprocs-1) + recvfromproc1 = pil % recvfromproc1(0:Agrif_Nbprocs-1) +#endif + memberin = pil % memberin + find_list_interp = .true. + exit find_loop + enddo find_loop +!--------------------------------------------------------------------------------------------------- +end function Agrif_Find_list_interp +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_AddTo_list_interp +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_AddTo_list_interp ( list_interp, pttab, petab, pttab_Child, pttab_Parent, & + indmin, indmax, indminglob, indmaxglob, & + pttruetab, cetruetab, & + memberin, nbdim & +#if defined AGRIF_MPI + ,indminglob2, indmaxglob2, & + parentarray, & + member, & + tab4t, memberinall, sendtoproc1, recvfromproc1 & +#endif + ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_List_Interp_Loc), pointer :: list_interp + integer :: nbdim + integer, dimension(nbdim) :: pttab, petab, pttab_Child, pttab_Parent + integer, dimension(nbdim) :: indmin,indmax + integer, dimension(nbdim) :: indminglob, indmaxglob + integer, dimension(nbdim) :: pttruetab, cetruetab + logical :: memberin +#if defined AGRIF_MPI + integer, dimension(nbdim,2,2) :: parentarray + logical :: member + integer, dimension(nbdim) :: indminglob2,indmaxglob2 + integer, dimension(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t + logical, dimension(0:Agrif_Nbprocs-1) :: memberinall + logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc1 + logical, dimension(0:Agrif_Nbprocs-1) :: recvfromproc1 +#endif +! + type(Agrif_List_Interp_Loc), pointer :: parcours + type(Agrif_Interp_Loc), pointer :: pil +! + allocate(parcours) + allocate(parcours % interp_loc) + + pil => parcours % interp_loc + + pil % pttab(1:nbdim) = pttab(1:nbdim) + pil % petab(1:nbdim) = petab(1:nbdim) + pil % pttab_child(1:nbdim) = pttab_child(1:nbdim) + pil % pttab_parent(1:nbdim) = pttab_parent(1:nbdim) + + pil % indmin(1:nbdim) = indmin(1:nbdim) + pil % indmax(1:nbdim) = indmax(1:nbdim) + + pil % memberin = memberin +#if !defined AGRIF_MPI + pil % indminglob(1:nbdim) = indminglob(1:nbdim) + pil % indmaxglob(1:nbdim) = indmaxglob(1:nbdim) +#else + pil % indminglob2(1:nbdim) = indminglob2(1:nbdim) + pil % indmaxglob2(1:nbdim) = indmaxglob2(1:nbdim) + pil % parentarray(1:nbdim,:,:) = parentarray(1:nbdim,:,:) + pil % member = member + allocate(pil % tab4t(nbdim, 0:Agrif_Nbprocs-1, 8)) + allocate(pil % memberinall(0:Agrif_Nbprocs-1)) + allocate(pil % sendtoproc1(0:Agrif_Nbprocs-1)) + allocate(pil % recvfromproc1(0:Agrif_Nbprocs-1)) + pil % tab4t = tab4t + pil % memberinall = memberinall + pil % sendtoproc1 = sendtoproc1 + pil % recvfromproc1 = recvfromproc1 +#endif + + pil % pttruetab(1:nbdim) = pttruetab(1:nbdim) + pil % cetruetab(1:nbdim) = cetruetab(1:nbdim) + + parcours % suiv => list_interp + list_interp => parcours +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Addto_list_interp +!=================================================================================================== +! +end module Agrif_Interpolation diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterpbasic.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterpbasic.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b5871c7e767bfde0c14b379bb46b11b6f482bc00 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modinterpbasic.F90 @@ -0,0 +1,1464 @@ +! +! $Id: modinterpbasic.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_InterpBasic +!> +!> Contains different procedures of interpolation (linear,lagrange, spline,...) used in +!! the Agrif_Interpolation module. +! +module Agrif_InterpBasic +! + use Agrif_Types +! + implicit none +! + real, dimension(5,Agrif_MaxRaff,3) :: tabppm + real, dimension(Agrif_MaxRaff) :: tabdiff2, tabdiff3 + real, dimension(:), allocatable :: tabtest4 + real, dimension(:,:), allocatable :: coeffparent + integer, dimension(:,:), allocatable :: indparent + integer, dimension(:,:), allocatable :: indparentppm, indchildppm + integer, dimension(:), allocatable :: indparentppm_1d, indchildppm_1d +! + private :: Agrif_limiter_vanleer +! +contains +! +!=================================================================================================== +! subroutine Agrif_basicinterp_linear1D +! +!> Linear 1D interpolation on a child grid (vector y) from its parent grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicinterp_linear1D ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + real, dimension(np), intent(in) :: x !< Coarse input data from parent + real, dimension(nc), intent(out) :: y !< Fine output data to child + integer, intent(in) :: np !< Length of input array + integer, intent(in) :: nc !< Length of output array + real, intent(in) :: s_parent !< Parent grid position (s_root = 0) + real, intent(in) :: s_child !< Child grid position (s_root = 0) + real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) + real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) +! + integer :: i, coeffraf, locind_parent_left + real :: globind_parent_left, globind_parent_right + real :: invds, invds2, ypos, ypos2, diff +! + coeffraf = nint(ds_parent/ds_child) +! + if ( coeffraf == 1 ) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + ypos = s_child + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent + globind_parent_right = globind_parent_left + ds_parent +! + invds = 1./ds_parent + invds2 = ds_child/ds_parent + ypos2 = ypos*invds + globind_parent_right = globind_parent_right*invds +! + do i = 1,nc-1 +! + if (ypos2 > globind_parent_right) then + locind_parent_left = locind_parent_left + 1 + globind_parent_right = globind_parent_right + 1. + ypos2 = ypos*invds+(i-1)*invds2 + endif +! + diff = globind_parent_right - ypos2 + y(i) = (diff*x(locind_parent_left) + (1.-diff)*x(locind_parent_left+1)) + ypos2 = ypos2 + invds2 +! + enddo +! + ypos = s_child + (nc-1)*ds_child + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) +! + if (locind_parent_left == np) then + y(nc) = x(np) + else + globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent + y(nc) = ((globind_parent_left + ds_parent - ypos)*x(locind_parent_left) & + + (ypos - globind_parent_left)*x(locind_parent_left+1))*invds + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicinterp_linear1D +!=================================================================================================== +! +!=================================================================================================== +! subroutine Linear1dPrecompute2d +! +!> Computes 2D coefficients and index for a linear 1D interpolation on a child grid (vector y) +!! from its parent grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Linear1dPrecompute2d ( np2, np, nc, s_parent, s_child, ds_parent, ds_child, dir ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np,nc,np2 + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child + integer, intent(in) :: dir +! + integer :: i,coeffraf,locind_parent_left,inc,inc1,inc2 + integer, dimension(:,:), allocatable :: indparent_tmp + real, dimension(:,:), allocatable :: coeffparent_tmp + real :: ypos,globind_parent_left,globind_parent_right + real :: invds, invds2, invds3 + real :: ypos2,diff +! + coeffraf = nint(ds_parent/ds_child) +! + ypos = s_child + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent + globind_parent_right = globind_parent_left + ds_parent +! + invds = 1./ds_parent + invds2 = ds_child/ds_parent + invds3 = 0.5/real(coeffraf) + ypos2 = ypos*invds + globind_parent_right=globind_parent_right*invds +! + if (.not.allocated(indparent)) then + allocate(indparent(nc*np2,3),coeffparent(nc*np2,3)) + else + if ( size(indparent,1) < nc*np2 ) then + allocate(coeffparent_tmp(size(indparent,1),size(indparent,2))) + allocate( indparent_tmp(size(indparent,1),size(indparent,2))) + coeffparent_tmp = coeffparent + indparent_tmp = indparent + deallocate(indparent,coeffparent) + allocate(indparent(nc*np2,3),coeffparent(nc*np2,3)) + coeffparent(1:size(coeffparent_tmp,1),1:size(coeffparent_tmp,2)) = coeffparent_tmp + indparent( 1:size(indparent_tmp, 1),1:size(indparent_tmp, 2)) = indparent_tmp + deallocate(indparent_tmp,coeffparent_tmp) + endif + endif +! + do i = 1,nc-1 +! + if (ypos2 > globind_parent_right) then + locind_parent_left = locind_parent_left + 1 + globind_parent_right = globind_parent_right + 1. + ypos2 = ypos*invds+(i-1)*invds2 + endif +! + diff = globind_parent_right - ypos2 + diff = invds3*nint(2*coeffraf*diff) + indparent(i,dir) = locind_parent_left + coeffparent(i,dir) = diff + ypos2 = ypos2 + invds2 +! + enddo +! + ypos = s_child + (nc-1)*ds_child + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + + if (locind_parent_left == np) then + indparent(nc,dir) = locind_parent_left-1 + coeffparent(nc,dir) = 0. + else + globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent + indparent(nc,dir) = locind_parent_left + diff = (globind_parent_left + ds_parent - ypos) * invds + diff = invds3*nint(2*coeffraf*diff) + coeffparent(nc,dir) = diff + endif + + do i=2, np2 + inc = i*nc + inc1 = (i-1)*nc + inc2 = (i-2)*nc +!CDIR ALTCODE + indparent(1+inc1:inc,dir) = indparent(1+inc2:inc1,dir)+np +!CDIR ALTCODE + coeffparent(1+inc1:inc,dir) =coeffparent(1:nc,dir) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Linear1dPrecompute2d +!=================================================================================================== +! +!=================================================================================================== +! subroutine Linear1dAfterCompute +! +!> Carries out a linear 1D interpolation on a child grid (vector y) from its parent grid (vector x) +!! using precomputed coefficient and index. +!--------------------------------------------------------------------------------------------------- +subroutine Linear1dAfterCompute ( x, y, np, nc, dir ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + integer, intent(in) :: dir +! + integer :: i +! +!CDIR ALTCODE +!CDIR NODEP + do i = 1,nc + y(i) = coeffparent(i,dir) * x(MAX(indparent(i,dir),1)) + & + (1.-coeffparent(i,dir)) * x(indparent(i,dir)+1) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Linear1dAfterCompute +!=================================================================================================== +! +!=================================================================================================== +! subroutine Lagrange1d +! +!> Carries out a lagrange 1D interpolation on a child grid (vector y) from its parent grid +!! (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Lagrange1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + integer :: i, coeffraf, locind_parent_left + real :: ypos,globind_parent_left + real :: deltax, invdsparent + real :: t2,t3,t4,t5,t6,t7,t8 +! + if (np <= 2) then + call Agrif_basicinterp_linear1D(x,y,np,nc,s_parent,s_child,ds_parent,ds_child) + return + endif +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + invdsparent = 1./ds_parent + ypos = s_child +! + do i = 1,nc +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + globind_parent_left = s_parent + (locind_parent_left - 1)*ds_parent + + deltax = invdsparent*(ypos-globind_parent_left) + deltax = nint(coeffraf*deltax)/real(coeffraf) + + ypos = ypos + ds_child + if (abs(deltax) <= 0.0001) then + y(i)=x(locind_parent_left) + cycle + endif +! + t2 = deltax - 2. + t3 = deltax - 1. + t4 = deltax + 1. + + t5 = -(1./6.)*deltax*t2*t3 + t6 = 0.5*t2*t3*t4 + t7 = -0.5*deltax*t2*t4 + t8 = (1./6.)*deltax*t3*t4 + + y(i) = t5*x(locind_parent_left-1) + t6*x(locind_parent_left) & + +t7*x(locind_parent_left+1) + t8*x(locind_parent_left+2) +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Lagrange1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine Constant1d +! +!> Carries out a constant 1D interpolation on a child grid (vector y) from its parent grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Constant1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + integer :: i, coeffraf, locind_parent + real :: ypos +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent:locind_parent+nc-1) + return + endif +! + ypos = s_child +! + do i = 1,nc +! + locind_parent = 1 + nint((ypos - s_parent)/ds_parent) + y(i) = x(locind_parent) + ypos = ypos + ds_child +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Constant1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine Linear1dConserv +! +!> Carries out a conservative linear 1D interpolation on a child grid (vector y) from its parent +!! grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Linear1dConserv ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + real, dimension(:), allocatable :: ytemp + integer :: i,coeffraf,locind_parent_left,locind_parent_last + real :: ypos,xdiffmod,xpmin,xpmax,slope + integer :: i1,i2,ii + integer :: diffmod +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 + + xdiffmod = real(diffmod)/2. + + allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) +! + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent) + + xpmin = s_parent + (locind_parent_left-1)*ds_parent + xpmax = s_parent + (locind_parent_last-1)*ds_parent + + i1 = 1+agrif_int((xpmin-s_child)/ds_child) + i2 = 1+agrif_int((xpmax-s_child)/ds_child) + + i = i1 + + if (locind_parent_left == 1) then + slope = (x(locind_parent_left+1)-x(locind_parent_left))/(coeffraf) + else + slope = (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf) + endif + + do ii = i-coeffraf/2+diffmod,i+coeffraf/2 + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo + + locind_parent_left = locind_parent_left + 1 + + do i = i1+coeffraf, i2-coeffraf,coeffraf + slope = (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf) + do ii = i-coeffraf/2+diffmod,i+coeffraf/2 + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo + locind_parent_left = locind_parent_left + 1 + enddo + + i = i2 + + if (locind_parent_left == np) then + slope = (x(locind_parent_left)-x(locind_parent_left-1))/(coeffraf) + else + slope = (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf) + endif + + do ii = i-coeffraf/2+diffmod,nc + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo +! + y(1:nc)=ytemp(1:nc) +! + deallocate(ytemp) +!--------------------------------------------------------------------------------------------------- +end subroutine Linear1dConserv +!=================================================================================================== +! +!=================================================================================================== +! subroutine Linear1dConservLim +! +!> Carries out a limited conservative linear 1D interpolation on a child grid (vector y) from +!! its parent grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine Linear1dConservLim ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + real, dimension(:), allocatable :: ytemp + integer :: i,coeffraf,locind_parent_left,locind_parent_last + real :: ypos,xdiffmod,xpmin,xpmax,slope + integer :: i1,i2,ii + integer :: diffmod +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + if (coeffraf /= 3) then + print *,'Linear1dConservLim not ready for refinement ratio = ', coeffraf + stop + endif +! + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 + + xdiffmod = real(diffmod)/2. + + allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) +! + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent) + + xpmin = s_parent + (locind_parent_left-1)*ds_parent + xpmax = s_parent + (locind_parent_last-1)*ds_parent + + i1 = 1+agrif_int((xpmin-s_child)/ds_child) + i2 = 1+agrif_int((xpmax-s_child)/ds_child) + + i = i1 + + if (locind_parent_left == 1) then + slope=0. + else + slope = Agrif_limiter_vanleer(x(locind_parent_left-1:locind_parent_left+1)) + slope = slope / coeffraf + endif + + do ii = i-coeffraf/2+diffmod,i+coeffraf/2 + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo + + locind_parent_left = locind_parent_left + 1 + + do i = i1+coeffraf, i2-coeffraf,coeffraf + slope = Agrif_limiter_vanleer(x(locind_parent_left-1:locind_parent_left+1)) + slope = slope / coeffraf + do ii=i-coeffraf/2+diffmod,i+coeffraf/2 + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo + locind_parent_left = locind_parent_left + 1 + enddo + + i = i2 + + if (locind_parent_left == np) then + slope=0. + else + slope = Agrif_limiter_vanleer(x(locind_parent_left-1:locind_parent_left+1)) + slope = slope / coeffraf + endif + + do ii=i-coeffraf/2+diffmod,nc + ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope + enddo +! + y(1:nc) = ytemp(1:nc) +! + deallocate(ytemp) +!--------------------------------------------------------------------------------------------------- +end subroutine Linear1dConservLim +!=================================================================================================== +! +!=================================================================================================== +! subroutine PPM1d +! +!> Carries out a 1D interpolation and apply monotonicity constraints using piecewise parabolic +!! method (PPM) on a child grid (vector y) from its parent grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine PPM1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + integer :: i,coeffraf,locind_parent_left,locind_parent_last + integer :: iparent,ipos,pos,nmin,nmax + real :: ypos + integer :: i1,jj + real :: xpmin,a +! + real, dimension(np) :: xl,delta,a6,slope + integer :: diffmod + real :: invcoeffraf +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) +!CDIR ALTCODE +!CDIR SHORTLOOP + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + invcoeffraf = ds_child/ds_parent +! + if( .not. allocated(tabtest4) ) then + allocate(tabtest4(-2*coeffraf:nc+2*coeffraf)) + else + if (size(tabtest4) < nc+4*coeffraf+1) then + deallocate( tabtest4 ) + allocate(tabtest4(-2*coeffraf:nc+2*coeffraf)) + endif + endif +! + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1)*ds_child - s_parent)/ds_parent) +! + xpmin = s_parent + (locind_parent_left-1)*ds_parent + i1 = 1+agrif_int((xpmin-s_child)/ds_child) +! +!CDIR NOVECTOR + do i=1,coeffraf + tabdiff2(i) = (real(i)-0.5)*invcoeffraf + enddo +! + a = invcoeffraf**2 + tabdiff3(1) = (1./3.)*a + a = 2.*a +!CDIR NOVECTOR + do i=2,coeffraf + tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a + enddo +! + if ( locind_parent_last+2 <= np ) then + nmax = locind_parent_last+2 + else if ( locind_parent_last+1 <= np ) then + nmax = locind_parent_last+1 + else + nmax = locind_parent_last + endif +! + if (locind_parent_left-1 >= 1) then + nmin = locind_parent_left-1 + else + nmin = locind_parent_left + endif +! +!CDIR ALTCODE +!CDIR SHORTLOOP + do i = nmin,nmax + slope(i) = x(i) - x(i-1) + enddo +! +!CDIR ALTCODE +!CDIR SHORTLOOP + do i = nmin+1,nmax-1 + xl(i)= 0.5*(x(i-1)+x(i))-0.08333333333333*(slope(i+1)-slope(i-1)) + enddo +! +! apply parabolic monotonicity +!CDIR ALTCODE +!CDIR SHORTLOOP + do i = locind_parent_left,locind_parent_last + delta(i) = xl(i+1) - xl(i) + a6(i) = 6.*x(i)-3.*(xl(i) +xl(i+1)) + enddo +! + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 +! + ipos = i1 +! + do iparent = locind_parent_left,locind_parent_last + pos=1 +!CDIR ALTCODE +!CDIR SHORTLOOP + do jj = ipos-coeffraf/2+diffmod,ipos+coeffraf/2 +! + tabtest4(jj) = xl(iparent) + tabdiff2(pos) * (delta(iparent)+a6(iparent)) & + - tabdiff3(pos) * a6(iparent) + pos = pos+1 + enddo + ipos = ipos + coeffraf + enddo +! +!CDIR ALTCODE +!CDIR SHORTLOOP + y(1:nc) = tabtest4(1:nc) +!--------------------------------------------------------------------------------------------------- +end subroutine PPM1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine PPM1dPrecompute2d +! +!> Computes 2D coefficients and index for a 1D interpolation using piecewise parabolic method +!--------------------------------------------------------------------------------------------------- +subroutine PPM1dPrecompute2d ( np2, np, nc, s_parent, s_child, ds_parent, ds_child, dir ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np2, np, nc + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child + integer, intent(in) :: dir +! + integer, dimension(:,:), allocatable :: indparent_tmp + integer, dimension(:,:), allocatable :: indchild_tmp + integer :: i,coeffraf,locind_parent_left,locind_parent_last + integer :: iparent,ipos,pos + real :: ypos + integer :: i1,jj + real :: xpmin,a +! + integer :: diffmod + real :: invcoeffraf +! + coeffraf = nint(ds_parent/ds_child) +! + invcoeffraf = ds_child/ds_parent +! + if (.not.allocated(indparentppm)) then + allocate(indparentppm(np2*nc,3),indchildppm(np2*nc,3)) + else + if (size(indparentppm,1) < np2*nc) then + allocate( & + indparent_tmp(size(indparentppm,1),size(indparentppm,2)), & + indchild_tmp( size(indparentppm,1),size(indparentppm,2))) + indparent_tmp = indparentppm + indchild_tmp = indchildppm + deallocate(indparentppm,indchildppm) + allocate(indparentppm(np2*nc,3),indchildppm(np2*nc,3)) + indparentppm(1:size(indparent_tmp,1),1:size(indparent_tmp,2)) = indparent_tmp + indchildppm( 1:size(indparent_tmp,1),1:size(indparent_tmp,2)) = indchild_tmp + deallocate(indparent_tmp,indchild_tmp) + endif + endif + + if (.not.allocated(indparentppm_1d)) then + allocate(indparentppm_1d(-2*coeffraf:nc+2*coeffraf), & + indchildppm_1d( -2*coeffraf:nc+2*coeffraf)) + else + if (size(indparentppm_1d) < nc+4*coeffraf+1) then + deallocate(indparentppm_1d,indchildppm_1d) + allocate(indparentppm_1d(-2*coeffraf:nc+2*coeffraf),& + indchildppm_1d( -2*coeffraf:nc+2*coeffraf)) + endif + endif +! + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1)*ds_child - s_parent)/ds_parent) +! + xpmin = s_parent + (locind_parent_left-1)*ds_parent + i1 = 1+agrif_int((xpmin-s_child)/ds_child) +! + do i = 1,coeffraf + tabdiff2(i)=(real(i)-0.5)*invcoeffraf + enddo +! + a = invcoeffraf**2 + tabdiff3(1) = (1./3.)*a + a = 2.*a +!CDIR ALTCODE + do i = 2,coeffraf + tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a + enddo + +!CDIR ALTCODE + do i = 1,coeffraf + tabppm(1,i,dir) = 0.08333333333333*(-1.+4*tabdiff2(i)-3*tabdiff3(i)) + tabppm(2,i,dir) = 0.08333333333333*(7.-26.*tabdiff2(i)+18.*tabdiff3(i)) + tabppm(3,i,dir) = 0.08333333333333*(7.+30*tabdiff2(i)-30*tabdiff3(i)) + tabppm(4,i,dir) = 0.08333333333333*(-1.-10.*tabdiff2(i)+18.*tabdiff3(i)) + tabppm(5,i,dir) = 0.08333333333333*(2*tabdiff2(i)-3*tabdiff3(i)) + enddo +! + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 +! + ipos = i1 +! + do iparent = locind_parent_left,locind_parent_last + pos=1 +!CDIR ALTCODE + do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 + indparentppm_1d(jj) = iparent-2 + indchildppm_1d(jj) = pos + pos = pos+1 + enddo + ipos = ipos + coeffraf + enddo +! + do i = 1,np2 + indparentppm(1+(i-1)*nc:i*nc,dir) = indparentppm_1d(1:nc) + (i-1)*np + indchildppm (1+(i-1)*nc:i*nc,dir) = indchildppm_1d (1:nc) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine PPM1dPrecompute2d +!=================================================================================================== +! +!=================================================================================================== +!subroutine PPM1dPrecompute(np,nc,& +! s_parent,s_child,ds_parent,ds_child) +!! +!!CC Description: +!!CC subroutine to compute coefficient and index for a 1D interpolation +!!CC using piecewise parabolic method +!!C Method: +!! +!! Declarations: +!! +! Implicit none +!! +!! Arguments +! Integer :: np,nc +!! Real, Dimension(:),Allocatable :: ytemp +! Real :: s_parent,s_child,ds_parent,ds_child +!! +!! Local scalars +! Integer :: i,coeffraf,locind_parent_left,locind_parent_last +! Integer :: iparent,ipos,pos,nmin,nmax +! Real :: ypos +! integer :: i1,jj +! Real :: xpmin,a +!! +! Real :: xrmin,xrmax,am3,s2,s1 +! Real, Dimension(np) :: xl,delta,a6,slope +!! Real, Dimension(:),Allocatable :: diff,diff2,diff3 +! INTEGER :: diffmod +! REAL :: invcoeffraf +!! +! coeffraf = nint(ds_parent/ds_child) +!! +! If (coeffraf == 1) Then +! return +! End If +! invcoeffraf = ds_child/ds_parent +!! +! +! if (.not.allocated(indparentppm)) then +! allocate(indparentppm(-2*coeffraf:nc+2*coeffraf,1),& +! indchildppm(-2*coeffraf:nc+2*coeffraf,1)) +! else +! if (size(indparentppm,1) 0) then +! etap = etap+1 +! else if (ak(k,i) < 0) then +! etan = etan + 1 +! endif +! enddo +! +! do k=0,1 +! if (ak(k,i) == 0) then +! Ck(k,i) = 1. +! else if (ak(k,i) > 0) then +! Ck(k,i) = 1./(etap * ak(k,i)) +! else +! Ck(k,i) = -1./(etan * ak(k,i)) +! endif +! enddo +! enddo +! +! +! a = 0. +! b = invcoeffraf +! Do i=1,coeffraf +! diff2(i) = 0.5*(b*b - a*a) +! diff3(i) = (1./3.)*(b*b*b - a*a*a) +! a = a + invcoeffraf +! b = b + invcoeffraf +! End do +! +! if( locind_parent_last+2 <= np ) then +! nmax = locind_parent_last+2 +! elseif( locind_parent_last+1 <= np ) then +! nmax = locind_parent_last+1 +! else +! nmax = locind_parent_last +! endif +! +! if(locind_parent_left-2 >= 1) then +! nmin = locind_parent_left-2 +! elseif(locind_parent_left-1 >= 1) then +! nmin = locind_parent_left-1 +! else +! nmin = locind_parent_left +! endif +! +! Do i = nmin+1,nmax +! slope(i) = (x(i) - x(i-1)) +! Enddo +! DO i=nmin+2,nmax +! smooth(i) = 0.5*(slope(i)**2+slope(i-1)**2)& +! +(slope(i)-slope(i-1))**2 +! enddo +! +! diffmod = 0 +! IF (mod(coeffraf,2) == 0) diffmod = 1 +! +! ipos = i1 +! +! Do iparent = locind_parent_left,locind_parent_last +! pos=1 +! +! delta0=1./(epsilon+smooth(iparent ))**3 +! delta1=1./(epsilon+smooth(iparent+1))**3 +! delta2=1./(epsilon+smooth(iparent+2))**3 +! +! Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 +! +! pos = pos+1 +! End do +! ipos = ipos + coeffraf +! +! End do +! +! +! y(1:nc)=ytemp(1:nc) +! deallocate(ytemp) +! deallocate(diff, diff2, diff3) +! +! deallocate(ak,ck) +! +! Return +! End subroutine weno1dnew +!=================================================================================================== +! +!=================================================================================================== +! subroutine WENO1d +! +!> Carries out a a 1D interpolation using WENO method on a child grid (vector y) from its parent +!! grid (vector x). +!--------------------------------------------------------------------------------------------------- +subroutine WENO1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + real, dimension(:), allocatable :: ytemp + integer :: i,coeffraf,locind_parent_left,locind_parent_last + integer :: iparent,ipos,pos,nmin,nmax + real :: ypos + integer :: i1,jj + real :: xpmin +! + real, dimension(np) :: slope + real, dimension(:), allocatable :: diff + integer :: diffmod + real :: invcoeffraf + real :: delta0, delta1, sumdelta + real, parameter :: epsilon = 1.d-8 +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + endif +! + invcoeffraf = ds_child/ds_parent +! + allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent) +! + xpmin = s_parent + (locind_parent_left-1)*ds_parent + i1 = 1+agrif_int((xpmin-s_child)/ds_child) +! + allocate(diff(coeffraf)) + diff(1) = 0.5*invcoeffraf + do i = 2,coeffraf + diff(i) = diff(i-1)+invcoeffraf + enddo +! + if ( locind_parent_last+2 <= np ) then + nmax = locind_parent_last+2 + else if ( locind_parent_last+1 <= np ) then + nmax = locind_parent_last+1 + else + nmax = locind_parent_last + endif +! + if(locind_parent_left-1 >= 1) then + nmin = locind_parent_left-1 + else + nmin = locind_parent_left + endif +! + do i = nmin+1,nmax + slope(i) = x(i) - x(i-1) + enddo +! + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 +! + ipos = i1 +! + do iparent = locind_parent_left,locind_parent_last + pos=1 + delta0 = 1./(epsilon+slope(iparent )**2)**2 + delta1 = 1./(epsilon+slope(iparent+1)**2)**2 + sumdelta = 1./(delta0+delta1) + do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 + ytemp(jj) = x(iparent)+(diff(pos)-0.5)*( delta0*slope(iparent) + & + delta1*slope(iparent+1))*sumdelta + pos = pos+1 + enddo + ipos = ipos + coeffraf + enddo +! + y(1:nc) = ytemp(1:nc) + deallocate(ytemp) + deallocate(diff) +!--------------------------------------------------------------------------------------------------- +end subroutine WENO1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine ENO1d +! +!> Carries out a 1D interpolation using piecewise polynomial ENO reconstruction technique +!! on a child grid (vector y) from its parent grid (vector x). +!! \see ---- p 163-164 Computational gasdynamics ---- +!--------------------------------------------------------------------------------------------------- +subroutine ENO1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: np, nc + real, dimension(np), intent(in) :: x + real, dimension(nc), intent(out) :: y + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +! + integer :: i,coeffraf,locind_parent_left,locind_parent_last + integer :: ipos, pos + real :: ypos,xi + integer :: i1,jj + real :: xpmin +! + real, dimension(:), allocatable :: ytemp + real, dimension(:,:), allocatable :: xbar + real, dimension(1:np+1) :: xhalf + real, dimension(3,np) :: dd, c + integer :: diffmod, left +! + coeffraf = nint(ds_parent/ds_child) +! + if (coeffraf == 1) then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + end if + + diffmod = 0 + if (mod(coeffraf,2) == 0) diffmod = 1 +! + allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent) +! + xpmin = s_parent + (locind_parent_left-1)*ds_parent + i1 = 1+agrif_int((xpmin-s_child)/ds_child) +! + do i = 1,np+1 + xhalf(i) = i - 0.5 + enddo +! +! Compute divided differences +! + dd(1,1:np) = x(1:np) + dd(2,1:np-1) = 0.5*( dd(1,2:np) - dd(1,1:np-1) ) + dd(3,1:np-2) = (1./3.)*( dd(2,2:np-1) - dd(2,1:np-2) ) +! + allocate( xbar( coeffraf,2 ) ) + xi = 0.5 + do i = 1,coeffraf + xbar(i,1) = (i-1)*ds_child/ds_parent - xi + xbar(i,2) = i *ds_child/ds_parent - xi + enddo +! + ipos = i1 +! + do i = locind_parent_left,locind_parent_last + left = i + do jj = 2,3 + if(abs(dd(jj,left)) > abs(dd(jj,left-1))) left = left-1 + enddo +! +! convert to Taylor series form + call taylor(i,xhalf(left:left+2),dd(1:3,left),c(1:3,i)) + enddo +! +! Evaluate the reconstruction on each cell +! + do i = locind_parent_left,locind_parent_last +! + pos = 1 +! + do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 + ytemp(jj) = ( c(1,i)*(xbar(pos,2)-xbar(pos,1)) & + + c(2,i)*(xbar(pos,2)*xbar(pos,2) - & + xbar(pos,1)*xbar(pos,1)) & + + c(3,i)*(xbar(pos,2)*xbar(pos,2)*xbar(pos,2) - & + xbar(pos,1)*xbar(pos,1)*xbar(pos,1)) & + ) * coeffraf + pos = pos+1 + enddo + ipos = ipos + coeffraf +! + enddo +! + y(1:nc) = ytemp(1:nc) + deallocate(ytemp,xbar) +!--------------------------------------------------------------------------------------------------- +end subroutine ENO1d +!=================================================================================================== +! +! ************************************************************************** +!CC Subroutine ppm1d_lim +! ************************************************************************** +! + Subroutine ppm1d_lim(x,y,np,nc,s_parent,s_child,ds_parent,ds_child) +! +!CC Description: +!CC Subroutine to do a 1D interpolation and apply monotonicity constraints +!CC using piecewise parabolic method +!CC on a child grid (vector y) from its parent grid (vector x). +!C Method: +! +! Declarations: +! + Implicit none +! +! Arguments + Integer :: np,nc + Real, Dimension(np) :: x + Real, Dimension(nc) :: y + Real, Dimension(:),Allocatable :: ytemp + Real :: s_parent,s_child,ds_parent,ds_child +! +! Local scalars + Integer :: i,coeffraf,locind_parent_left,locind_parent_last + Integer :: iparent,ipos,pos,nmin,nmax + Real :: ypos + integer :: i1,jj + Real :: xpmin,cavg,a,b +! + Real :: xrmin,xrmax,am3,s2,s1 + Real, Dimension(np) :: dela,xr,xl,delta,a6,slope,slope2 + Real, Dimension(:),Allocatable :: diff,diff2,diff3 + INTEGER :: diffmod +! + coeffraf = nint(ds_parent/ds_child) +! + If (coeffraf == 1) Then + locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent) + y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1) + return + End If +! + Allocate(ytemp(-2*coeffraf:nc+2*coeffraf)) + ypos = s_child +! + locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent) + locind_parent_last = 1 + & + agrif_ceiling((ypos +(nc - 1) & + *ds_child - s_parent)/ds_parent) +! + xpmin = s_parent + (locind_parent_left-1)*ds_parent + i1 = 1+agrif_int((xpmin-s_child)/ds_child) +! + Allocate( diff(coeffraf),diff2(coeffraf),diff3(coeffraf) ) +! + diff(:) = ds_child/ds_parent +! + Do i=1,coeffraf + a = real(i-1)*ds_child/ds_parent + b = real(i)*ds_child/ds_parent + diff2(i) = 0.5*(b*b - a*a) + diff3(i) = (1./3.)*(b*b*b - a*a*a) + End do +! + if( locind_parent_last+2 <= np ) then + nmax = locind_parent_last+2 + else if( locind_parent_last+1 <= np ) then + nmax = locind_parent_last+1 + else + nmax = locind_parent_last + endif +! + if(locind_parent_left-1 >= 1) then + nmin = locind_parent_left-1 + else + nmin = locind_parent_left + endif +! + Do i = nmin,nmax + slope(i) = x(i) - x(i-1) + slope2(i) = 2.*abs(slope(i)) + Enddo +! + Do i = nmin,nmax-1 + dela(i) = 0.5 * ( slope(i) + slope(i+1) ) +! Van Leer slope limiter + dela(i) = min( abs(dela(i)),slope2(i), & + slope2(i+1) )*sign(1.,dela(i)) + IF( slope(i)*slope(i+1) <= 0. ) dela(i) = 0. + Enddo +! + Do i = nmin,nmax-2 + xr(i) = x(i) + (1./2.)*slope(i+1) + (-1./6.)*dela(i+1) & + + ( 1./6. )*dela(i) + Enddo +! + Do i = nmin,nmax-2 + xrmin = min(x(i),x(i+1)) + xrmax = max(x(i),x(i+1)) + xr(i) = min(xr(i),xrmax) + xr(i) = max(xr(i),xrmin) + xl(i+1) = xr(i) + Enddo +! apply parabolic monotonicity + Do i = locind_parent_left,locind_parent_last + If( ( (xr(i)-x(i))* (x(i)-xl(i)) ) .le. 0. ) then + xl(i) = x(i) + xr(i) = x(i) + Endif + delta(i) = xr(i) - xl(i) + am3 = 3. * x(i) + s1 = am3 - 2. * xr(i) + s2 = am3 - 2. * xl(i) + IF( delta(i) * (xl(i) - s1) .le. 0. ) xl(i) = s1 + IF( delta(i) * (s2 - xr(i)) .le. 0. ) xr(i) = s2 + delta(i) = xr(i) - xl(i) + a6(i) = 6.*x(i)-3.*(xl(i) +xr(i)) +! + End do +! + diffmod = 0 + IF (mod(coeffraf,2) == 0) diffmod = 1 +! + ipos = i1 +! + Do iparent = locind_parent_left,locind_parent_last + pos=1 + cavg = 0. + Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2 +! + ytemp(jj) = (diff(pos)*xl(iparent) & + + diff2(pos) & + * (delta(iparent)+a6(iparent)) & + - diff3(pos)*a6(iparent))*coeffraf + + cavg = cavg + ytemp(jj) + pos = pos+1 + End do + ipos = ipos + coeffraf +! + End do +! +! + y(1:nc)=ytemp(1:nc) + deallocate(ytemp) + deallocate(diff, diff2, diff3) + Return + End Subroutine ppm1d_lim +!=================================================================================================== +! subroutine taylor +!--------------------------------------------------------------------------------------------------- +subroutine taylor ( ind, xhalf, dd, c ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: ind + real, dimension(3), intent(in) :: xhalf + real, dimension(3), intent(in) :: dd + real, dimension(3), intent(out) :: c +! + real, dimension(0:3,0:3) :: d + integer :: i, j +! + d(0,0:3) = 1.0 + do i = 1,3 + d(i,0) = (ind-xhalf(i))*d(i-1,0) + enddo +! + do i = 1,3 + do j = 1,3-i + d(i,j) = d(i,j-1) + (ind-xhalf(i+j))*d(i-1,j) + enddo + enddo +! + do j = 1,3 + c(j) = 0. + do i=0,3-j + c(j) = c(j) + d(i,j)*dd(i+j) + enddo + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine taylor +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_limiter_vanleer +!--------------------------------------------------------------------------------------------------- +real function Agrif_limiter_vanleer ( tab ) result(res) +!--------------------------------------------------------------------------------------------------- + real, dimension(3), intent(in) :: tab +! + real :: p1, p2, p3 + + p1 = (tab(3)-tab(1))/2. + p2 = 2.*(tab(2)-tab(1)) + p3 = 2.*(tab(3)-tab(2)) + + if ((p1>0.).AND.(p2>0.).AND.(p3>0)) then + res = minval((/p1,p2,p3/)) + elseif ((p1<0.).AND.(p2<0.).AND.(p3<0)) then + res = maxval((/p1,p2,p3/)) + else + res=0. + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_limiter_vanleer +!=================================================================================================== +! +end module Agrif_InterpBasic diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modlinktomodel.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modlinktomodel.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b208845627ff08ca853118ddcf20dbd8cda9574f --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modlinktomodel.F90 @@ -0,0 +1,181 @@ +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Link +!> +!> This module is used to link AGRIF files to the model. +! +module Agrif_Link +! + interface +! + subroutine Agrif_clustering_def ( ) +! + end subroutine Agrif_clustering_def +! + subroutine Agrif_Set_numberofcells ( Agrif_Gr ) + use Agrif_Grids, only : Agrif_Grid + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid + end subroutine Agrif_Set_numberofcells +! + subroutine Agrif_Get_numberofcells ( Agrif_Gr ) + use Agrif_Grids, only : Agrif_Grid + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid + end subroutine Agrif_Get_numberofcells +! + end interface +! + abstract interface +! + subroutine alloc_proc ( Agrif_Gr ) + use Agrif_Grids, only : Agrif_Grid + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid + end subroutine alloc_proc +! + subroutine typdef_proc ( ) + implicit none + end subroutine typdef_proc +! + end interface + + procedure(alloc_proc) :: Agrif_Allocationcalls + procedure(typdef_proc) :: Agrif_probdim_modtype_def +! +end module Agrif_Link +! +!=================================================================================================== +! function Agrif_parent +! modify by conv. To use : un_parent = Agrif_Parent(un) +!=================================================================================================== +! function Agrif_Get_Coarse_Grid +! modify by conv. To use : un_Mygrid = Agrif_Get_Coarse_grid(un) +!=================================================================================================== +! function Agrif_Rhox +! modify by conv. To use : var = Agrif_Rhox() +! REAL(Agrif_Curgrid % spaceref(1)) +!=================================================================================================== +! function Agrif_Parent_Rhox +! modify by conv. To use : var = Agrif_Parent_Rhox() +! REAL(Agrif_Curgrid % parent % spaceref(1)) +!=================================================================================================== +! function Agrif_Irhox +! modify by conv. To use : var = Agrif_Parent_IRhox() +! Agrif_Curgrid % spaceref(1) +!=================================================================================================== +! function Agrif_Parent_Irhox +! modify by conv. To use : var = Agrif_Parent_IRhox() +! Agrif_Curgrid % parent % spaceref(1) +!=================================================================================================== +! function Agrif_Rhoy +! modify by conv. To use : var = Agrif_Rhoy() +! REAL(Agrif_Curgrid % spaceref(2)) +!=================================================================================================== +! function Agrif_Parent_Rhoy +! modify by conv. To use : var = Agrif_Parent_Rhoy() +! REAL(Agrif_Curgrid % parent % spaceref(2)) +!=================================================================================================== +! function Agrif_Irhoy +! modify by conv. To use : var = Agrif_Parent_IRhoy() +! Agrif_Curgrid % spaceref(2) +!=================================================================================================== +! function Agrif_Parent_Irhoy +! modify by conv. To use : var = Agrif_Parent_IRhoy() +! Agrif_Curgrid % parent % spaceref(2) +!=================================================================================================== +! function Agrif_Rhoz +! modify by conv. To use : var = Agrif_Rhoz() +! REAL(Agrif_Curgrid % spaceref(3)) +!=================================================================================================== +! function Agrif_Parent_Rhoz +! modify by conv. To use : var = Agrif_Parent_Rhoz() +! REAL(Agrif_Curgrid % parent % spaceref(3)) +!=================================================================================================== +! function Agrif_Irhoz +! modify by conv. To use : var = Agrif_Parent_IRhoz() +! Agrif_Curgrid % spaceref(3) +!=================================================================================================== +! function Agrif_Parent_Irhoz +! modify by conv. To use : var = Agrif_Parent_IRhoz() +! Agrif_Curgrid % parent % spaceref(3) +!=================================================================================================== +! function Agrif_NearCommonBorderX +! modify by conv. To use : var = Agrif_NearCommonBorderX() +! Agrif_Curgrid % NearRootBorder(1) +!=================================================================================================== +! function Agrif_NearCommonBorderY +! modify by conv. To use : var = Agrif_NearCommonBorderY() +! Agrif_Curgrid % NearRootBorder(2) +!=================================================================================================== +! function Agrif_NearCommonBorderZ +! modify by conv. To use : var = Agrif_NearCommonBorderZ() +! Agrif_Curgrid % NearRootBorder(3) +!=================================================================================================== +! function Agrif_DistantCommonBorderX +! modify by conv. To use : var = Agrif_DistantCommonBorderX() +! Agrif_Curgrid % DistantRootBorder(1) +!=================================================================================================== +! function Agrif_DistantCommonBorderY +! modify by conv. To use : var = Agrif_DistantCommonBorderY() +! Agrif_Curgrid % DistantRootBorder(2) +!=================================================================================================== +! function Agrif_DistantCommonBorderZ +! modify by conv. To use : var = Agrif_DistantCommonBorderZ() +! Agrif_Curgrid % DistantRootBorder(3) +!=================================================================================================== +! function Agrif_Nb_Step +! modify by conv. To use : var = Agrif_Nb_Step() +! Agrif_Curgrid % ngridstep +!=================================================================================================== +! function Agrif_Nb_Fine_Grids +! modify by conv. To use : var = Agrif_Nb_Fine_Grids() +! Agrif_nbfixedgrids +!=================================================================================================== +! function Agrif_Ix +! modify by conv. To use : var = Agrif_Ix() +! Agrif_Curgrid % ix(1) +!=================================================================================================== +! function Agrif_Parent_Ix +! modify by conv. To use : var = Agrif_Parent_Ix() +! Agrif_Curgrid % parent % ix(1) +!=================================================================================================== +! function Agrif_Iy +! modify by conv. To use : var = Agrif_Iy() +! Agrif_Curgrid % ix(2) +!=================================================================================================== +! function Agrif_Parent_Iy +! modify by conv. To use : var = Agrif_Parent_Iy() +! Agrif_Curgrid % parent % ix(2) +!=================================================================================================== +! function Agrif_Iz +! modify by conv. To use : var = Agrif_Iz() +! Agrif_Curgrid % ix(3) +!=================================================================================================== +! function Agrif_Parent_Iz +! modify by conv. To use : var = Agrif_Parent_Iz() +! Agrif_Curgrid % parent % ix(3) +!=================================================================================================== +! function Agrif_Get_grid_id +! modify by conv. To use : var = Agrif_Get_grid_id() +! Agrif_Curgrid % grid_id +!=================================================================================================== +! function Agrif_Get_parent_id +! modify by conv. To use : var = Agrif_Get_parent_id() +! Agrif_Curgrid % parent % grid_id +!=================================================================================================== diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmask.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmask.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e9d8f999337d5678da2a9441d520c94a91f7d484 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmask.F90 @@ -0,0 +1,586 @@ +! +! $Id: modmask.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Mask. +!> +!> Module for masks. +! +module Agrif_Mask +! + use Agrif_Types +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_CheckMasknD +! +!> Called in the procedure #Agrif_InterpnD to recalculate the value of the parent grid variable +!! when this one is equal to Agrif_SpecialValue. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_CheckMasknD ( tempP, parent, pbtab, petab, ppbtab, ppetab, noraftab, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: tempP !< Part of the parent grid used for the interpolation of the child grid + type(Agrif_Variable), pointer :: parent !< The parent grid + integer, dimension(nbdim) :: pbtab !< limits of the parent grid used + integer, dimension(nbdim) :: petab !< interpolation of the child grid + integer, dimension(nbdim) :: ppbtab, ppetab + logical, dimension(nbdim) :: noraftab + integer :: nbdim +! + integer :: i0,j0,k0,l0,m0,n0 +! + select case (nbdim) + case (1) + do i0 = pbtab(1),petab(1) + if (tempP%array1(i0) == Agrif_SpecialValue) then + call CalculNewValTempP((/i0/),tempP,parent,ppbtab,ppetab,noraftab,nbdim) + endif + enddo + case (2) + do j0 = pbtab(2),petab(2) + do i0 = pbtab(1),petab(1) + if (tempP%array2(i0,j0) == Agrif_SpecialValue) then + call CalculNewValTempP((/i0,j0/),tempP,parent,ppbtab,ppetab, noraftab,nbdim) + endif + enddo + enddo + case (3) + do k0 = pbtab(3),petab(3) + do j0 = pbtab(2),petab(2) + do i0 = pbtab(1),petab(1) + if (tempP%array3(i0,j0,k0) == Agrif_SpecialValue) then +!------CDIR NEXPAND + call CalculNewValTempP3D((/i0,j0,k0/), & + tempP%array3(ppbtab(1),ppbtab(2),ppbtab(3)), & + parent%array3(ppbtab(1),ppbtab(2),ppbtab(3)), & + ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) + +! Call CalculNewValTempP((/i0,j0,k0/), +! & tempP,parent, +! & ppbtab,ppetab, +! & noraftab,nbdim) + + endif + enddo + enddo + enddo + case (4) + do l0 = pbtab(4),petab(4) + do k0 = pbtab(3),petab(3) + do j0 = pbtab(2),petab(2) + do i0 = pbtab(1),petab(1) + if (tempP%array4(i0,j0,k0,l0) == Agrif_SpecialValue) then + call CalculNewValTempP4D((/i0,j0,k0,l0/), & + tempP%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & + parent%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)), & + ppbtab,ppetab,noraftab,MaxSearch,Agrif_SpecialValue) + endif + enddo + enddo + enddo + enddo + case (5) + do m0 = pbtab(5),petab(5) + do l0 = pbtab(4),petab(4) + do k0 = pbtab(3),petab(3) + do j0 = pbtab(2),petab(2) + do i0 = pbtab(1),petab(1) + if (tempP%array5(i0,j0,k0,l0,m0) == Agrif_SpecialValue) then + call CalculNewValTempP((/i0,j0,k0,l0,m0/), & + tempP,parent,ppbtab,ppetab,noraftab,nbdim) + endif + enddo + enddo + enddo + enddo + enddo + case (6) + do n0 = pbtab(6),petab(6) + do m0 = pbtab(5),petab(5) + do l0 = pbtab(4),petab(4) + do k0 = pbtab(3),petab(3) + do j0 = pbtab(2),petab(2) + do i0 = pbtab(1),petab(1) + if (tempP%array6(i0,j0,k0,l0,m0,n0) == Agrif_SpecialValue) then + call CalculNewValTempP((/i0,j0,k0,l0,m0,n0/), & + tempP,parent,ppbtab,ppetab,noraftab,nbdim) + endif + enddo + enddo + enddo + enddo + enddo + enddo + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CheckMasknD +!=================================================================================================== +! +!=================================================================================================== +! subroutine CalculNewValTempP +! +!> Called in the procedure #Agrif_InterpnD to recalculate the value of the parent grid variable +!! when this one is equal to Agrif_SpecialValue. +!--------------------------------------------------------------------------------------------------- +subroutine CalculNewValTempP ( indic, tempP, parent, ppbtab, ppetab, noraftab, nbdim ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(nbdim) :: indic + type(Agrif_Variable), pointer :: tempP !< Part of the parent grid used for the interpolation of the child grid + type(Agrif_Variable), pointer :: parent !< The parent grid + integer, dimension(nbdim) :: ppbtab, ppetab + logical, dimension(nbdim) :: noraftab + integer :: nbdim +! + integer :: i,ii,iii,jj,kk,ll,mm,nn + integer, dimension(nbdim) :: imin,imax,idecal + integer :: nbvals + real :: res + real :: valparent + integer :: ValMax + logical :: firsttest +! + ValMax = 1 + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + ValMax = max(ValMax,ppetab(iii)-indic(iii)) + ValMax = max(ValMax,indic(iii)-ppbtab(iii)) + endif + enddo +! + Valmax = min(Valmax,MaxSearch) +! +!CDIR NOVECTOR + imin = indic +!CDIR NOVECTOR + imax = indic +! + i = 1 + firsttest = .TRUE. +! + do while (i <= ValMax) +! + if ( (i == 1).AND.(firsttest) ) i = Valmax +! + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + imin(iii) = max(indic(iii) - i,ppbtab(iii)) + imax(iii) = min(indic(iii) + i,ppetab(iii)) + if (firsttest) then + if (indic(iii) > ppbtab(iii)) then +!CDIR NOVECTOR + idecal = indic + idecal(iii) = idecal(iii)-1 + SELECT CASE(nbdim) + CASE (1) + if (tempP%array1(idecal(1) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + CASE (2) + if (tempP%array2(idecal(1), idecal(2) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + CASE (3) + if (tempP%array3(idecal(1), & + idecal(2), idecal(3) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + CASE (4) + if (tempP%array4(idecal(1), idecal(2), & + idecal(3), idecal(4) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + CASE (5) + if (tempP%array5(idecal(1), idecal(2), & + idecal(3), idecal(4), & + idecal(5) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + CASE (6) + if (tempP%array6(idecal(1), idecal(2), & + idecal(3), idecal(4), & + idecal(5), idecal(6) & + ) == Agrif_SpecialValue) imin(iii) = imax(iii) + END SELECT + endif + endif + endif + enddo +! + Res = 0. + Nbvals = 0 +! + SELECT CASE(nbdim) + CASE (1) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array1(ii) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo +! + CASE (2) + do jj = imin(2),imax(2) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array2(ii,jj) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + + CASE (3) + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array3(ii,jj,kk) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo + + CASE (4) + do ll = imin(4),imax(4) + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array4(ii,jj,kk,ll) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo + enddo + + CASE (5) + do mm = imin(5),imax(5) + do ll = imin(4),imax(4) + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array5(ii,jj,kk,ll,mm) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo + enddo + enddo + + CASE (6) + do nn = imin(6),imax(6) + do mm = imin(5),imax(5) + do ll = imin(4),imax(4) + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR ALTCODE +!CDIR SHORTLOOP + do ii = imin(1),imax(1) + ValParent = parent%array6(ii,jj,kk,ll,mm,nn) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo + enddo + enddo + enddo + + END SELECT +! + if (Nbvals > 0) then + if (firsttest) then + firsttest = .FALSE. + i=1 + cycle + endif + SELECT CASE(nbdim) + CASE (1) + tempP%array1(indic(1)) = Res/Nbvals + CASE (2) + tempP%array2(indic(1), indic(2)) = Res/Nbvals + CASE (3) + tempP%array3(indic(1), indic(2), & + indic(3)) = Res/Nbvals + CASE (4) + tempP%array4(indic(1), indic(2), & + indic(3), indic(4)) = Res/Nbvals + CASE (5) + tempP%array5(indic(1), indic(2), & + indic(3), indic(4), & + indic(5)) = Res/Nbvals + CASE (6) + tempP%array6(indic(1), indic(2), & + indic(3), indic(4), & + indic(5), indic(6)) = Res/Nbvals + END SELECT + exit + else + if (firsttest) exit + i = i + 1 + endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine CalculNewValTempP +!=================================================================================================== +! +!=================================================================================================== +! subroutine CalculNewValTempP3D +! +!> Called in the procedure #Agrif_InterpnD to recalculate the value of the parent grid variable +!! when this one is equal to Agrif_SpecialValue. +!--------------------------------------------------------------------------------------------------- +subroutine CalculNewValTempP3D ( indic, tempP, parent, ppbtab, ppetab, noraftab, & + MaxSearch, Agrif_SpecialValue ) +!--------------------------------------------------------------------------------------------------- + integer, parameter :: nbdim = 3 + integer, dimension(nbdim) :: indic + integer, dimension(nbdim) :: ppbtab, ppetab + logical, dimension(nbdim) :: noraftab + integer :: MaxSearch + real :: Agrif_SpecialValue + real, dimension(ppbtab(1):ppetab(1), & + ppbtab(2):ppetab(2), & + ppbtab(3):ppetab(3)) & + :: tempP, parent !< Part of the parent grid used for + !< the interpolation of the child grid +! + integer :: i,ii,iii,jj,kk + integer, dimension(nbdim) :: imin,imax,idecal + integer :: Nbvals + real :: Res + real :: ValParent + integer :: ValMax + logical :: Existunmasked +! + ValMax = 1 +!CDIR NOVECTOR + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + ValMax = max(ValMax,ppetab(iii)-indic(iii)) + ValMax = max(ValMax,indic(iii)-ppbtab(iii)) + endif + enddo +! + Valmax = min(Valmax,MaxSearch) +! +!CDIR NOVECTOR + imin = indic +!CDIR NOVECTOR + imax = indic + +!CDIR NOVECTOR + idecal = indic + i = Valmax +! + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + imin(iii) = max(indic(iii) - i,ppbtab(iii)) + imax(iii) = min(indic(iii) + i,ppetab(iii)) + + if (indic(iii) > ppbtab(iii)) then + idecal(iii) = idecal(iii)-1 + if (tempP(idecal(1),idecal(2),idecal(3)) == Agrif_SpecialValue) then + imin(iii) = imax(iii) + endif + idecal(iii) = idecal(iii)+1 + endif + endif + enddo +! + Existunmasked = .FALSE. +! + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR NOVECTOR + do ii = imin(1),imax(1) + if ( parent(ii,jj,kk) /= Agrif_SpecialValue) then + Existunmasked = .TRUE. + exit + endif + enddo + enddo + enddo +! + if (.Not.Existunmasked) return +! + i = 1 +! + do while(i <= ValMax) +! + do iii = 1 , nbdim + if (.NOT.noraftab(iii)) then + imin(iii) = max(indic(iii) - i,ppbtab(iii)) + imax(iii) = min(indic(iii) + i,ppetab(iii)) + endif + enddo +! + Res = 0. + Nbvals = 0 +! + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) +!CDIR NOVECTOR + do ii = imin(1),imax(1) + ValParent = parent(ii,jj,kk) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo +! + if (Nbvals > 0) then + tempP(indic(1),indic(2),indic(3)) = Res/Nbvals + exit + else + i = i + 1 + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine CalculNewValTempP3D +!=================================================================================================== +! +!=================================================================================================== +! subroutine CalculNewValTempP4D +! +!> Called in the procedure #Agrif_InterpnD to recalculate the value of the parent grid variable +!! when this one is equal to Agrif_SpecialValue. +!--------------------------------------------------------------------------------------------------- +subroutine CalculNewValTempP4D ( indic, tempP, parent, ppbtab, ppetab, noraftab, & + MaxSearch, Agrif_SpecialValue ) +!--------------------------------------------------------------------------------------------------- + integer, parameter :: nbdim = 4 + integer, dimension(nbdim) :: indic + integer, dimension(nbdim) :: ppbtab, ppetab + logical, dimension(nbdim) :: noraftab + integer :: MaxSearch + real :: Agrif_SpecialValue + real, dimension(ppbtab(1):ppetab(1), & + ppbtab(2):ppetab(2), & + ppbtab(3):ppetab(3), & + ppbtab(4):ppetab(4)) & + :: tempP, parent !< Part of the parent grid used for + !< the interpolation of the child grid +! + integer :: i,ii,iii,jj,kk,ll + integer, dimension(nbdim) :: imin,imax,idecal + integer :: Nbvals + real :: Res + real :: ValParent + integer :: ValMax +! + logical :: firsttest +! + ValMax = 1 + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + ValMax = max(ValMax,ppetab(iii)-indic(iii)) + ValMax = max(ValMax,indic(iii)-ppbtab(iii)) + endif + enddo +! + Valmax = min(Valmax,MaxSearch) +! + imin = indic + imax = indic +! + i = 1 + firsttest = .TRUE. + idecal = indic +! + do while (i <= ValMax) +! + if ((i == 1).AND.(firsttest)) i = Valmax + + do iii = 1,nbdim + if (.NOT.noraftab(iii)) then + imin(iii) = max(indic(iii) - i,ppbtab(iii)) + imax(iii) = min(indic(iii) + i,ppetab(iii)) + if (firsttest) then + if (indic(iii) > ppbtab(iii)) then + idecal(iii) = idecal(iii)-1 + if (tempP(idecal(1),idecal(2),idecal(3),idecal(4)) == Agrif_SpecialValue) then + imin(iii) = imax(iii) + endif + idecal(iii) = idecal(iii)+1 + endif + endif + endif + enddo +! + Res = 0. + Nbvals = 0 +! + do ll = imin(4),imax(4) + do kk = imin(3),imax(3) + do jj = imin(2),imax(2) + do ii = imin(1),imax(1) + ValParent = parent(ii,jj,kk,ll) + if ( ValParent /= Agrif_SpecialValue) then + Res = Res + ValParent + Nbvals = Nbvals + 1 + endif + enddo + enddo + enddo + enddo +! + if (Nbvals > 0) then + if (firsttest) then + firsttest = .FALSE. + i=1 + cycle + endif + + tempP(indic(1),indic(2),indic(3),indic(4)) = Res/Nbvals + exit + else + if (firsttest) exit + i = i + 1 + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine CalculNewValTempP4D +!=================================================================================================== +! +end module Agrif_Mask diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmpp.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmpp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3926bebadfc771f5ba8be729a40e4a8d0054714c --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modmpp.F90 @@ -0,0 +1,634 @@ +! +! $Id: modmpp.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +module Agrif_Mpp +! + use Agrif_Arrays + use Agrif_Grids +! + implicit none +! + interface + subroutine Agrif_get_proc_info ( imin, imax, jmin, jmax ) + integer, intent(out) :: imin, imax + integer, intent(out) :: jmin, jmax + end subroutine Agrif_get_proc_info + end interface +! + integer, private :: Agrif_MPI_prec +! + private :: Agrif_get_proc_info +! +contains +! +#if defined AGRIF_MPI +!=================================================================================================== +! subroutine Agrif_MPI_Init +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_MPI_Init ( comm ) +!--------------------------------------------------------------------------------------------------- + integer, optional, intent(in) :: comm !< MPI communicator to be attached to the root grid. +! + include 'mpif.h' + integer :: code, ierr + logical :: mpi_was_called + integer :: current_mpi_prec +! + call MPI_INITIALIZED( mpi_was_called, code ) + if( code /= MPI_SUCCESS ) then + write(*,*) ': Error in routine mpi_initialized' + call MPI_ABORT( MPI_COMM_WORLD, code, ierr ) + endif + if( .not. mpi_was_called ) then + write(*,*) '### AGRIF Error : you should call Agrif_MPI_Init *after* MPI_Init.' + stop + endif + + current_mpi_prec = KIND(1.0) + if (current_mpi_prec == 4) then + Agrif_MPI_prec = MPI_REAL4 + else + Agrif_MPI_prec = MPI_REAL8 + endif +! + if ( present(comm) ) then + call Agrif_MPI_switch_comm(comm) + else + call Agrif_MPI_switch_comm(MPI_COMM_WORLD) + endif +! + Agrif_Mygrid % communicator = Agrif_mpi_comm +! + if ( Agrif_Parallel_sisters ) then + call Agrif_Init_ProcList( Agrif_Mygrid % proc_def_list, Agrif_Nbprocs ) + call Agrif_pl_copy( Agrif_Mygrid % proc_def_list, Agrif_Mygrid % required_proc_list ) + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_MPI_Init +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_MPI_switch_comm ( comm ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: comm !< MPI communicator you want to switch to. +! + include 'mpif.h' + integer :: code + logical :: mpi_was_called +! + call MPI_INITIALIZED( mpi_was_called, code ) + if ( .not. mpi_was_called ) return +! + call MPI_COMM_SIZE(comm, Agrif_Nbprocs, code) + call MPI_COMM_RANK(comm, Agrif_ProcRank, code) + Agrif_mpi_comm = comm +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_MPI_switch_comm +!=================================================================================================== +! +!=================================================================================================== +function Agrif_MPI_get_grid_comm ( ) result ( comm ) +!--------------------------------------------------------------------------------------------------- + integer :: comm + comm = Agrif_Curgrid % communicator +!--------------------------------------------------------------------------------------------------- +end function Agrif_MPI_get_grid_comm +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_MPI_set_grid_comm ( comm ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: comm + Agrif_Curgrid % communicator = comm +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_MPI_set_grid_comm +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_Init_ProcList ( proclist, nbprocs ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(inout) :: proclist + integer, intent(in) :: nbprocs +! + include 'mpif.h' + type(Agrif_Proc), pointer :: new_proc + integer :: p, ierr + integer :: imin, imax, jmin, jmax + integer, dimension(5) :: local_proc_grid_info + integer, dimension(5,nbprocs) :: all_procs_grid_info +! + call Agrif_get_proc_info(imin, imax, jmin, jmax) +! + local_proc_grid_info(:) = (/Agrif_Procrank, imin, jmin, imax, jmax/) +! + call MPI_ALLGATHER(local_proc_grid_info, 5, MPI_INTEGER, & + all_procs_grid_info, 5, MPI_INTEGER, Agrif_mpi_comm, ierr) +! + do p = 1,nbprocs +! + allocate(new_proc) + new_proc % pn = all_procs_grid_info(1,p) + new_proc % imin(1) = all_procs_grid_info(2,p) + new_proc % imin(2) = all_procs_grid_info(3,p) + new_proc % imax(1) = all_procs_grid_info(4,p) + new_proc % imax(2) = all_procs_grid_info(5,p) + call Agrif_pl_append( proclist, new_proc ) +! + enddo +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_ProcList +!=================================================================================================== +! +!=================================================================================================== +! subroutine Get_External_Data_first +!--------------------------------------------------------------------------------------------------- +subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole, & + nbdim, memberoutall, coords, sendtoproc, recvfromproc, & + imin, imax, imin_recv, imax_recv ) +!--------------------------------------------------------------------------------------------------- + include 'mpif.h' +! + integer, intent(in) :: nbdim + integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: pttruetab, cetruetab + integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: pttruetabwhole,cetruetabwhole + logical, dimension(0:Agrif_Nbprocs-1), intent(in) :: memberoutall + integer, dimension(nbdim), intent(in) :: coords + logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: sendtoproc + logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: recvfromproc + integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax + integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv +! + integer :: imintmp, imaxtmp, i, j, k, i1 + integer :: imin1,imax1 + logical :: tochange,tochangebis + integer, dimension(nbdim,0:Agrif_NbProcs-1) :: pttruetab2,cetruetab2 +! +! pttruetab2 and cetruetab2 are modified arrays in order to always +! send the most inner points +! + pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank) + cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank) +! + do k = 0,Agrif_Nbprocs-1 + do i = 1,nbdim + tochangebis = .TRUE. + DO i1 = 1,nbdim + IF (i /= i1) THEN + IF ( (pttruetab(i1,Agrif_Procrank) /= pttruetab(i1,k)) .OR. & + (cetruetab(i1,Agrif_Procrank) /= cetruetab(i1,k))) THEN + tochangebis = .FALSE. + EXIT + ENDIF + ENDIF + ENDDO + IF (tochangebis) THEN + imin1 = max(pttruetab(i,Agrif_Procrank), pttruetab(i,k)) + imax1 = min(cetruetab(i,Agrif_Procrank), cetruetab(i,k)) +! Always send the most interior points + + tochange = .false. + IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN + DO j=imin1,imax1 + IF ((cetruetab(i,k)-j) > (j-pttruetab(i,Agrif_Procrank))) THEN + imintmp = j+1 + tochange = .TRUE. + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + if (tochange) then + pttruetab2(i,Agrif_Procrank) = imintmp + endif + + tochange = .FALSE. + imaxtmp=0 + IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN + DO j=imax1,imin1,-1 + IF ((j-pttruetab(i,k)) > (cetruetab(i,Agrif_Procrank)-j)) THEN + imaxtmp = j-1 + tochange = .TRUE. + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + if (tochange) then + cetruetab2(i,Agrif_Procrank) = imaxtmp + endif + ENDIF + enddo + enddo + + do k = 0,Agrif_NbProcs-1 +! + sendtoproc(k) = .true. +! +!CDIR SHORTLOOP + do i = 1,nbdim + imin(i,k) = max(pttruetab2(i,Agrif_Procrank), pttruetabwhole(i,k)) + imax(i,k) = min(cetruetab2(i,Agrif_Procrank), cetruetabwhole(i,k)) +! + if ( (imin(i,k) > imax(i,k)) .and. (coords(i) /= 0) ) then + sendtoproc(k) = .false. + endif + enddo + IF ( .not. memberoutall(k) ) THEN + sendtoproc(k) = .false. + ENDIF + enddo +! + call Exchangesamelevel_first(sendtoproc,nbdim,imin,imax,recvfromproc,imin_recv,imax_recv) +!--------------------------------------------------------------------------------------------------- +end subroutine Get_External_Data_first +!=================================================================================================== +! +!=================================================================================================== +! subroutine ExchangeSameLevel_first +!--------------------------------------------------------------------------------------------------- +subroutine ExchangeSameLevel_first ( sendtoproc, nbdim, imin, imax, recvfromproc, & + imin_recv, imax_recv ) +!--------------------------------------------------------------------------------------------------- + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imax + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(out) :: recvfromproc + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imin_recv + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imax_recv +! + include 'mpif.h' + INTEGER :: k + INTEGER :: etiquette = 100 + INTEGER :: code + LOGICAL :: res + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: statut + INTEGER, DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp + + do k = 0,Agrif_ProcRank-1 +! + call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code) +! + if (sendtoproc(k)) then + iminmax_temp(:,1,k) = imin(:,k) + iminmax_temp(:,2,k) = imax(:,k) + call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette,Agrif_mpi_comm,code) + endif +! + enddo +! +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank+1,Agrif_Nbprocs-1 +! + call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code) + recvfromproc(k) = res +! + if (recvfromproc(k)) then + call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, & + Agrif_mpi_comm,statut,code) + imin_recv(:,k) = iminmax_temp(:,1,k) + imax_recv(:,k) = iminmax_temp(:,2,k) + endif +! + enddo + +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank+1,Agrif_Nbprocs-1 +! + call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code) +! + if (sendtoproc(k)) then +! + iminmax_temp(:,1,k) = imin(:,k) + iminmax_temp(:,2,k) = imax(:,k) + + call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, & + Agrif_mpi_comm,code) + endif +! + enddo +! +! +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank-1,0,-1 +! + call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code) + recvfromproc(k) = res +! + if (recvfromproc(k)) then +! + call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, & + Agrif_mpi_comm,statut,code) + + imin_recv(:,k) = iminmax_temp(:,1,k) + imax_recv(:,k) = iminmax_temp(:,2,k) + endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine ExchangeSamelevel_first +!=================================================================================================== +! +!=================================================================================================== +! subroutine ExchangeSameLevel +!--------------------------------------------------------------------------------------------------- +subroutine ExchangeSameLevel ( sendtoproc, recvfromproc, nbdim, & + pttruetabwhole, cetruetabwhole, & + imin, imax, imin_recv, imax_recv, & + memberout, tempC, tempCextend ) +!--------------------------------------------------------------------------------------------------- + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: recvfromproc + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: pttruetabwhole + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: cetruetabwhole + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin, imax + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin_recv, imax_recv + LOGICAL, intent(in) :: memberout + TYPE(Agrif_Variable), pointer, intent(inout) :: tempC, tempCextend +! + include 'mpif.h' + INTEGER :: i,k + INTEGER :: etiquette = 100 + INTEGER :: code, datasize + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: statut + TYPE(Agrif_Variable), pointer, SAVE :: temprecv +! + IF (memberout) THEN + call Agrif_array_allocate(tempCextend, pttruetabwhole(:,Agrif_ProcRank), & + cetruetabwhole(:,Agrif_ProcRank),nbdim) + call Agrif_var_set_array_tozero(tempCextend,nbdim) + ENDIF +! + IF (sendtoproc(Agrif_ProcRank)) THEN + call Agrif_var_copy_array(tempCextend,imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), & + tempC, imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), & + nbdim) + ENDIF +! + do k = 0,Agrif_ProcRank-1 +! + if (sendtoproc(k)) then +! + datasize = 1 +! +!CDIR SHORTLOOP + do i = 1,nbdim + datasize = datasize * (imax(i,k)-imin(i,k)+1) + enddo +! + SELECT CASE(nbdim) + CASE(1) + call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(2) + call MPI_SEND(tempC%array2(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(3) + call Agrif_Send_3Darray(tempC%array3,lbound(tempC%array3),imin(:,k),imax(:,k),k) + CASE(4) + call MPI_SEND(tempC%array4(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(5) + call MPI_SEND(tempC%array5(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(6) + call MPI_SEND(tempC%array6(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k), & + imin(6,k):imax(6,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + END SELECT +! + endif + enddo +! +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank+1,Agrif_Nbprocs-1 +! + if (recvfromproc(k)) then +! + datasize = 1 +! +!CDIR SHORTLOOP + do i = 1,nbdim + datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1) + enddo + + if (.not.associated(temprecv)) allocate(temprecv) + call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim) + + SELECT CASE(nbdim) + CASE(1) + call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + CASE(2) + call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + CASE(3) + call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + CASE(4) + call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + CASE(5) + call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + CASE(6) + call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,statut,code) + END SELECT + + call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim) + call Agrif_array_deallocate(temprecv,nbdim) +! + endif + enddo + +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank+1,Agrif_Nbprocs-1 +! + if (sendtoproc(k)) then +! + SELECT CASE(nbdim) + CASE(1) + datasize=SIZE(tempC%array1(imin(1,k):imax(1,k))) + call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(2) + datasize=SIZE(tempC%array2(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k))) + call MPI_SEND(tempC%array2(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(3) + datasize=SIZE(tempC%array3(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k))) + call MPI_SEND(tempC%array3(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(4) + datasize=SIZE(tempC%array4(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k))) + call MPI_SEND(tempC%array4(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(5) + datasize=SIZE(tempC%array5(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k))) + call MPI_SEND(tempC%array5(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + CASE(6) + datasize=SIZE(tempC%array6(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k), & + imin(6,k):imax(6,k))) + call MPI_SEND(tempC%array6(imin(1,k):imax(1,k), & + imin(2,k):imax(2,k), & + imin(3,k):imax(3,k), & + imin(4,k):imax(4,k), & + imin(5,k):imax(5,k), & + imin(6,k):imax(6,k)), & + datasize,Agrif_MPI_prec,k,etiquette, & + Agrif_mpi_comm,code) + END SELECT +! + endif +! + enddo +! +! Reception from others processors of the necessary part of the parent grid + do k = Agrif_ProcRank-1,0,-1 +! + if (recvfromproc(k)) then +! + if (.not.associated(temprecv)) allocate(temprecv) + call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim) + + SELECT CASE(nbdim) + CASE(1) + datasize=SIZE(temprecv%array1) + call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + CASE(2) + datasize=SIZE(temprecv%array2) + call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + CASE(3) + datasize=SIZE(temprecv%array3) + call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + CASE(4) + datasize=SIZE(temprecv%array4) + call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + CASE(5) + datasize=SIZE(temprecv%array5) + call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + CASE(6) + datasize=SIZE(temprecv%array6) + call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette,& + Agrif_mpi_comm,statut,code) + END SELECT + + call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim) + call Agrif_array_deallocate(temprecv,nbdim) +! + endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine ExchangeSamelevel +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Send_3Darray +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Send_3Darray ( tab3D, bounds, imin, imax, k ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(3), intent(in) :: bounds + real, dimension(bounds(1):,bounds(2):,bounds(3):), target, intent(in) :: tab3D + integer, dimension(3), intent(in) :: imin, imax + integer, intent(in) :: k +! + integer :: etiquette = 100 + integer :: datasize, code + include 'mpif.h' + + datasize = SIZE(tab3D(imin(1):imax(1), & + imin(2):imax(2), & + imin(3):imax(3))) + + call MPI_SEND( tab3D( imin(1):imax(1), & + imin(2):imax(2), & + imin(3):imax(3)), & + datasize,Agrif_MPI_prec,k,etiquette,Agrif_mpi_comm,code) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Send_3Darray +!=================================================================================================== +! +#else + subroutine dummy_Agrif_Mpp () + end subroutine dummy_Agrif_Mpp +#endif +! +end Module Agrif_Mpp diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modprocs.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modprocs.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d9524d8ac3cf8a3ade7b740e1f56edf25040aa0e --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modprocs.F90 @@ -0,0 +1,208 @@ +module Agrif_Procs +! + implicit none +! + type Agrif_Proc + integer :: pn !< Proc index in coarse grid + integer :: pi !< Proc index in x-direction (informative only, could be removed) + integer :: pj !< Proc index in y-direction (informative only, could be removed) + integer, dimension(3) :: imin + integer, dimension(3) :: imax + integer :: nb_seqs = 0 !< Number of integration sequences the proc is attached to. + integer :: grid_id = 0 !< Grid id the proc is attached to. + end type Agrif_Proc +! + type Agrif_Proc_p + type(Agrif_Proc), pointer :: proc => NULL() !< Pointer to the actual proc structure + type(Agrif_Proc_p), pointer :: next => NULL() !< Next proc in the list + end type Agrif_Proc_p +! + type Agrif_Proc_List + integer :: nitems = 0 !< Number of elements in the list + type(Agrif_Proc_p), pointer :: first => NULL() !< First proc in the list + type(Agrif_Proc_p), pointer :: last => NULL() !< Last proc inserted in the list + end type Agrif_Proc_List +! +contains +! +!=================================================================================================== +subroutine Agrif_pl_append ( proclist, proc ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(inout) :: proclist + type(Agrif_Proc), pointer, intent(in) :: proc +! + type(Agrif_Proc_p), pointer :: new_pp +! + allocate( new_pp ) +! + new_pp % proc => proc + new_pp % next => NULL() +! + if ( associated(proclist % last) ) then + ! the list is not empty, let 'proc' be the next after the last (ie. the last one). + proclist % last % next => new_pp + else + ! the list has just been initialized. Let 'proc' be the first one. + proclist % first => new_pp + endif + ! anyway, for next time 'proc' will be the last one. + proclist % last => new_pp + proclist % nitems = proclist % nitems + 1 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_append +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_print_array ( proclist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist +! + type(Agrif_Proc_p), pointer :: pp + type(Agrif_Proc), pointer :: proc +! + pp => proclist % first +! + write(*,'("/-------+-----+-----+------+------+------+------+------\")') + write(*,'("| iproc | ipx | ipy | imin | imax | jmin | jmax | grid |")') + write(*,'("|-------+-----+-----+------+------+------+------+------|")') + do while ( associated(pp) ) + proc => pp % proc + write(*,'("|",i6," |",i4," |",i4," |",i5," :",i5," |",i5," :",i5," | ",i4," |")') & + proc % pn, proc % pi, proc % pj, proc % imin(1), proc % imax(1), proc % imin(2), proc % imax(2), & + proc % grid_id + pp => pp % next + enddo + write(*,'("\-------+-----+-----+------+------+------+------+------/")') +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_print_array +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_print ( proclist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist +! + type(Agrif_Proc_p), pointer :: pp +! + pp => proclist % first + do while ( associated(pp) ) + write(*,'(i0,",")',advance='no') pp % proc % pn + pp => pp % next + enddo + write(*,*) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_print +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_copy ( proclist, copy ) +! +!< Carries out a copy of 'proclist' into 'copy' +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist + type(Agrif_Proc_List), intent(out) :: copy +! + type(Agrif_Proc_p), pointer :: pp +! + call Agrif_pl_clear(copy) +! + pp => proclist % first + do while ( associated(pp) ) + call Agrif_pl_append( copy, pp % proc ) + pp => pp % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_copy +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_deep_copy ( proclist, copy ) +! +!< Carries out a deep copy of 'proclist' into 'copy' +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist + type(Agrif_Proc_List), intent(out) :: copy +! + type(Agrif_Proc_p), pointer :: pp + type(Agrif_Proc), pointer :: new_proc +! + call Agrif_pl_clear(copy) +! + pp => proclist % first + do while ( associated(pp) ) + allocate( new_proc ) + new_proc = pp % proc + call Agrif_pl_append( copy, new_proc ) + pp => pp % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_deep_copy +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_clear ( proclist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(inout) :: proclist +! + type(Agrif_Proc_p), pointer :: pp, ppd +! + pp => proclist % first +! + do while( associated(pp) ) + ppd => pp + pp => pp % next + deallocate(ppd) + enddo + + proclist % first => NULL() + proclist % last => NULL() + proclist % nitems = 0 +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_clear +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_pl_to_array ( proclist, procarray ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist + type(Agrif_Proc), dimension(:), allocatable, intent(out) :: procarray +! + type(Agrif_Proc_p), pointer :: pp +! + allocate( procarray(1:proclist % nitems) ) +! + pp => proclist % first + do while ( associated(pp) ) + procarray(pp%proc%pn+1) = pp % proc + pp => pp % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_pl_to_array +!=================================================================================================== +! +!=================================================================================================== +function Agrif_pl_search_proc ( proclist, rank ) result ( proc ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Proc_List), intent(in) :: proclist + integer, intent(in) :: rank +! + type(Agrif_Proc_p), pointer :: pp + type(Agrif_Proc), pointer :: proc + logical :: found +! + found = .false. + proc => NULL() + pp => proclist % first + do while ( .not.found .and. associated(pp) ) + if ( pp % proc % pn == rank ) then + proc => pp % proc + return + else + pp => pp % next + endif + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_pl_search_proc +!=================================================================================================== +! +end module Agrif_Procs diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modsauv.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modsauv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ebb0f1c0e48119e1b98291613f06a3a930ca8e6e --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modsauv.F90 @@ -0,0 +1,663 @@ +! +! $Id: modsauv.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +! +!> Module Agrif_Save +!! +!! Module for the initialization by copy of the grids created by clustering. +! +module Agrif_Save +! + use Agrif_Types + use Agrif_Link + use Agrif_Arrays + use Agrif_Variables +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_deallocate_Arrays +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_deallocate_Arrays ( var ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: var +! + if (allocated(var%array1)) deallocate(var%array1) + if (allocated(var%array2)) deallocate(var%array2) + if (allocated(var%array3)) deallocate(var%array3) + if (allocated(var%array4)) deallocate(var%array4) + if (allocated(var%array5)) deallocate(var%array5) + if (allocated(var%array6)) deallocate(var%array6) +! + if (allocated(var%darray1)) deallocate(var%darray1) + if (allocated(var%darray2)) deallocate(var%darray2) + if (allocated(var%darray3)) deallocate(var%darray3) + if (allocated(var%darray4)) deallocate(var%darray4) + if (allocated(var%darray5)) deallocate(var%darray5) + if (allocated(var%darray6)) deallocate(var%darray6) +! + if (allocated(var%sarray1)) deallocate(var%sarray1) + if (allocated(var%sarray2)) deallocate(var%sarray2) + if (allocated(var%sarray3)) deallocate(var%sarray3) + if (allocated(var%sarray4)) deallocate(var%sarray4) + if (allocated(var%sarray5)) deallocate(var%sarray5) + if (allocated(var%sarray6)) deallocate(var%sarray6) +! +! + if (associated(var%oldvalues2D)) deallocate(var%oldvalues2D) + if (allocated(var%posvar)) deallocate(var%posvar) + if (allocated(var%interptab)) deallocate(var%interptab) + if (allocated(var%coords)) deallocate(var%coords) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_deallocate_Arrays +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_deallocate_Arrays_c ( var_c ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable_c), pointer :: var_c +! + if (allocated(var_c%carray1)) deallocate(var_c%carray1) + if (allocated(var_C%carray2)) deallocate(var_c%carray2) +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_deallocate_Arrays_c +!=================================================================================================== +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_deallocate_Arrays_l ( var_l ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable_l), pointer :: var_l +! +! + if (allocated(var_l%larray1)) deallocate(var_l%larray1) + if (allocated(var_l%larray2)) deallocate(var_l%larray2) + if (allocated(var_l%larray3)) deallocate(var_l%larray3) + if (allocated(var_l%larray4)) deallocate(var_l%larray4) + if (allocated(var_l%larray5)) deallocate(var_l%larray5) + if (allocated(var_l%larray6)) deallocate(var_l%larray6) +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_deallocate_Arrays_l +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_deallocate_Arrays_i ( var_i ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable_i), pointer :: var_i +! +! + if (allocated(var_i%iarray1)) deallocate(var_i%iarray1) + if (allocated(var_i%iarray2)) deallocate(var_i%iarray2) + if (allocated(var_i%iarray3)) deallocate(var_i%iarray3) + if (allocated(var_i%iarray4)) deallocate(var_i%iarray4) + if (allocated(var_i%iarray5)) deallocate(var_i%iarray5) + if (allocated(var_i%iarray6)) deallocate(var_i%iarray6) +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_deallocate_Arrays_i +! +!=================================================================================================== +! subroutine Agrif_Free_data_before +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Free_data_before ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr ! Pointer on the current grid +! + integer :: i + type(Agrif_Variables_List), pointer :: parcours + type(Agrif_Variable), pointer :: var + type(Agrif_Variable_c), pointer :: var_c + type(Agrif_Variable_r), pointer :: var_r + type(Agrif_Variable_l), pointer :: var_l + type(Agrif_Variable_i), pointer :: var_i +! + do i = 1,Agrif_NbVariables(0) +! + var => Agrif_Gr % tabvars(i) +! + if ( .NOT. Agrif_Mygrid % tabvars(i) % restore ) then + call Agrif_deallocate_Arrays(var) + endif +! + if (associated(var%list_interp)) then + call Agrif_Free_list_interp(var%list_interp) + endif +! + enddo + do i=1,Agrif_NbVariables(1) + var_c => Agrif_Gr % tabvars_c(i) + call Agrif_deallocate_Arrays_c(var_c) + enddo + do i=1,Agrif_NbVariables(3) + var_l => Agrif_Gr % tabvars_l(i) + call Agrif_deallocate_Arrays_l(var_l) + enddo + do i=1,Agrif_NbVariables(4) + var_i => Agrif_Gr % tabvars_i(i) + call Agrif_deallocate_Arrays_i(var_i) + enddo + + parcours => Agrif_Gr % variables + + do i = 1,Agrif_Gr%NbVariables +! + if ( .NOT. parcours%var%root_var % restore ) then + call Agrif_deallocate_Arrays(parcours%var) + endif +! + if (associated(parcours%var%list_interp)) then + call Agrif_Free_list_interp(parcours%var%list_interp) + endif +! + if ( .NOT. parcours%var%root_var % restore ) then + deallocate(parcours%var) + endif +! + parcours => parcours % next +! + enddo +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then + if ( Agrif_Probdim == 1 ) deallocate(Agrif_Gr%tabpoint1D) + if ( Agrif_Probdim == 2 ) deallocate(Agrif_Gr%tabpoint2D) + if ( Agrif_Probdim == 3 ) deallocate(Agrif_Gr%tabpoint3D) + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_data_before +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Free_list_interp +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Free_list_interp ( list_interp ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_List_Interp_Loc), pointer :: list_interp +! + if (associated(list_interp%suiv)) call Agrif_Free_list_interp(list_interp%suiv) + +#if defined AGRIF_MPI + deallocate(list_interp%interp_loc%tab4t) + deallocate(list_interp%interp_loc%memberinall) + deallocate(list_interp%interp_loc%sendtoproc1) + deallocate(list_interp%interp_loc%recvfromproc1) +#endif + deallocate(list_interp%interp_loc) + deallocate(list_interp) + nullify(list_interp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_list_interp +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Free_data_after +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Free_data_after ( Agrif_Gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: Agrif_Gr !< Pointer on the current grid +! + integer :: i + type(Agrif_Variables_List), pointer :: parcours, rootparcours + type(Agrif_Variable), pointer :: var +! + do i = 1,Agrif_NbVariables(0) + if ( Agrif_Mygrid % tabvars(i) % restore ) then + var => Agrif_Gr%tabvars(i) + call Agrif_deallocate_Arrays(var) + endif + enddo +! + parcours => Agrif_Gr%variables + rootparcours => Agrif_Mygrid%variables +! + do i = 1,Agrif_Gr%NbVariables + if (rootparcours%var % restore ) then + call Agrif_deallocate_Arrays(parcours%var) + deallocate(parcours%var) + endif + parcours => parcours % next + rootparcours => rootparcours % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_data_after +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_CopyFromOld_All +! +!> Called in Agrif_Clustering#Agrif_Init_Hierarchy. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_CopyFromOld_All ( g, oldchildlist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(inout) :: g !< Pointer on the current grid + type(Agrif_Grid_List), intent(in) :: oldchildlist +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure + real :: g_eps, eps, oldgrid_eps + integer :: out + integer :: iii +! + out = 0 +! + parcours => oldchildlist % first +! + do while (associated(parcours)) +! + if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then +! + g_eps = huge(1.) + oldgrid_eps = huge(1.) + do iii = 1,Agrif_Probdim + g_eps = min(g_eps,g % Agrif_dx(iii)) + oldgrid_eps = min(oldgrid_eps, parcours % gr % Agrif_dx(iii)) + enddo +! + eps = min(g_eps,oldgrid_eps)/100. +! + do iii = 1,Agrif_Probdim + if (g % Agrif_dx(iii) < (parcours % gr % Agrif_dx(iii) - eps)) then + parcours => parcours % next + out = 1 + exit + endif + enddo +! + if ( out == 1 ) cycle +! + call Agrif_CopyFromOld(g,parcours%gr) +! + endif +! + call Agrif_CopyFromOld_All(g,parcours % gr % child_list) +! + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CopyFromOld_All +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_CopyFromOld +! +!> Call to the Agrif_Copy procedure. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_CopyFromOld ( new_gr, old_gr ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(inout) :: new_gr !< Pointer on the current grid + type(Agrif_Grid), pointer, intent(inout) :: old_gr !< Pointer on an old grid +! + type(Agrif_Variable), pointer :: new_var + type(Agrif_Variable), pointer :: old_var + integer :: i +! + do i = 1,Agrif_NbVariables(0) + if ( Agrif_Mygrid % tabvars(i) % restore ) then + old_var => old_gr % tabvars(i) + new_var => new_gr % tabvars(i) + call Agrif_Copy(new_gr, old_gr, new_var, old_var ) + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CopyFromOld +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_CopyFromOld_AllOneVar +! +!> Called in Agrif_Clustering#Agrif_Init_Hierarchy. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_CopyFromOld_AllOneVar ( g, oldchildlist, indic ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(inout) :: g !< Pointer on the current grid + type(Agrif_Grid_List), intent(in) :: oldchildlist + integer, intent(in) :: indic +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure + real :: g_eps,eps,oldgrid_eps + integer :: out + integer :: iii +! + out = 0 +! + parcours => oldchildlist % first +! + do while (associated(parcours)) +! + if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then +! + g_eps = huge(1.) + oldgrid_eps = huge(1.) + do iii = 1,Agrif_Probdim + g_eps = min(g_eps,g % Agrif_dx(iii)) + oldgrid_eps = min(oldgrid_eps,parcours % gr % Agrif_dx(iii)) + enddo +! + eps = min(g_eps,oldgrid_eps)/100. +! + do iii = 1,Agrif_Probdim + if (g % Agrif_dx(iii) < (parcours % gr % Agrif_dx(iii) - eps)) then + parcours => parcours % next + out = 1 + exit + endif + enddo + + if ( out == 1 ) cycle +! + call Agrif_CopyFromOldOneVar(g,parcours%gr,indic) +! + endif +! + call Agrif_CopyFromOld_AllOneVar(g,parcours%gr % child_list,indic) +! + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CopyFromOld_AllOneVar +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_CopyFromOldOneVar +! +!> Call to Agrif_Copy +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_CopyFromOldOneVar ( new_gr, old_gr, indic ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(inout) :: new_gr !< Pointer on the current grid + type(Agrif_Grid), pointer, intent(in) :: old_gr !< Pointer on an old grid + integer, intent(in) :: indic +! + type(Agrif_Variable), pointer :: new_var, old_var +! + new_var => Agrif_Search_Variable(new_gr, -indic) + old_var => Agrif_Search_Variable(old_gr, -indic) +! + call Agrif_array_allocate(new_var,new_var%lb,new_var%ub,new_var%nbdim) + call Agrif_Copy(new_gr, old_gr, new_var,old_var) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CopyFromOldOneVar +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Copy +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Copy ( new_gr, old_gr, new_var, old_var ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(in) :: new_gr !< Pointer on the current grid + type(Agrif_Grid), pointer, intent(in) :: old_gr !< Pointer on an old grid + type(Agrif_Variable), pointer, intent(inout) :: new_var + type(Agrif_Variable), pointer, intent(in) :: old_var +! + type(Agrif_Variable), pointer :: root ! Pointer on the variable of the root grid + integer :: nbdim ! Number of dimensions of the current grid + integer, dimension(6) :: pttabnew ! Indexes of the first point in the domain + integer, dimension(6) :: petabnew ! Indexes of the first point in the domain + integer, dimension(6) :: pttabold ! Indexes of the first point in the domain + integer, dimension(6) :: petabold ! Indexes of the first point in the domain + integer, dimension(6) :: nbtabold ! Number of cells in each direction + integer, dimension(6) :: nbtabnew ! Number of cells in each direction + real, dimension(6) :: snew,sold + real, dimension(6) :: dsnew,dsold + real :: eps + integer :: n +! + root => new_var % root_var + nbdim = root % nbdim +! + do n = 1,nbdim +! + select case(root % interptab(n)) +! + case('x') +! + pttabnew(n) = root % point(n) + pttabold(n) = root % point(n) + snew(n) = new_gr % Agrif_x(1) + sold(n) = old_gr % Agrif_x(1) + dsnew(n) = new_gr % Agrif_dx(1) + dsold(n) = old_gr % Agrif_dx(1) +! + if (root % posvar(n) == 1) then + petabnew(n) = pttabnew(n) + new_gr % nb(1) + petabold(n) = pttabold(n) + old_gr % nb(1) + else + petabnew(n) = pttabnew(n) + new_gr % nb(1) - 1 + petabold(n) = pttabold(n) + old_gr % nb(1) - 1 + snew(n) = snew(n) + dsnew(n)/2. + sold(n) = sold(n) + dsold(n)/2. + endif +! + case('y') +! + pttabnew(n) = root % point(n) + pttabold(n) = root % point(n) + snew(n) = new_gr % Agrif_x(2) + sold(n) = old_gr % Agrif_x(2) + dsnew(n) = new_gr % Agrif_dx(2) + dsold(n) = old_gr % Agrif_dx(2) +! + if (root % posvar(n) == 1) then + petabnew(n) = pttabnew(n) + new_gr % nb(2) + petabold(n) = pttabold(n) + old_gr % nb(2) + else + petabnew(n) = pttabnew(n) + new_gr % nb(2) - 1 + petabold(n) = pttabold(n) + old_gr % nb(2) - 1 + snew(n) = snew(n) + dsnew(n)/2. + sold(n) = sold(n) + dsold(n)/2. + endif +! + case('z') +! + pttabnew(n) = root % point(n) + pttabold(n) = root % point(n) + snew(n) = new_gr % Agrif_x(3) + sold(n) = old_gr % Agrif_x(3) + dsnew(n) = new_gr % Agrif_dx(3) + dsold(n) = old_gr % Agrif_dx(3) +! + if (root % posvar(n) == 1) then + petabnew(n) = pttabnew(n) + new_gr % nb(3) + petabold(n) = pttabold(n) + old_gr % nb(3) + else + petabnew(n) = pttabnew(n) + new_gr % nb(3) - 1 + petabold(n) = pttabold(n) + old_gr % nb(3) - 1 + snew(n) = snew(n) + dsnew(n)/2. + sold(n) = sold(n) + dsold(n)/2. + endif +! + case('N') +! + call Agrif_get_var_bounds(new_var,pttabnew(n),petabnew(n),n) +! + pttabold(n) = pttabnew(n) + petabold(n) = petabnew(n) + snew(n) = 0. + sold(n) = 0. + dsnew(n) = 1. + dsold(n) = 1. +! + end select +! + enddo +! + do n = 1,nbdim + nbtabnew(n) = petabnew(n) - pttabnew(n) + nbtabold(n) = petabold(n) - pttabold(n) + enddo +! + eps = min(minval(dsnew(1:nbdim)),minval(dsold(1:nbdim))) / 100. +! + do n = 1,nbdim + if (snew(n) > (sold(n)+dsold(n)*nbtabold(n)+eps)) return + if ((snew(n)+dsnew(n)*nbtabnew(n)-eps) < sold(n)) return + enddo +! + call Agrif_CopynD(new_var,old_var,pttabold,petabold,pttabnew,petabnew, & + sold,snew,dsold,dsnew,nbdim) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Copy +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_CopynD +! +!> Copy from the nD variable Old_Var the nD variable New_Var +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_CopynD ( new_var, old_var, pttabold, petabold, pttabnew, petabnew, & + sold, snew, dsold, dsnew, nbdim ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer, intent(inout) :: new_var + type(Agrif_Variable), pointer, intent(in) :: old_var + integer, dimension(nbdim), intent(in) :: pttabnew + integer, dimension(nbdim), intent(in) :: petabnew + integer, dimension(nbdim), intent(in) :: pttabold + integer, dimension(nbdim), intent(in) :: petabold + real, dimension(nbdim), intent(in) :: snew, sold + real, dimension(nbdim), intent(in) :: dsnew,dsold + integer, intent(in) :: nbdim +! + integer :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0 +! + real, dimension(nbdim) :: dim_gmin, dim_gmax + real, dimension(nbdim) :: dim_newmin, dim_newmax + real, dimension(nbdim) :: dim_min + integer, dimension(nbdim) :: ind_gmin,ind_newmin, ind_newmax +! + do i = 1,nbdim +! + dim_gmin(i) = sold(i) + dim_gmax(i) = sold(i) + (petabold(i)-pttabold(i)) * dsold(i) +! + dim_newmin(i) = snew(i) + dim_newmax(i) = snew(i) + (petabnew(i)-pttabnew(i)) * dsnew(i) +! + enddo +! + do i = 1,nbdim + if (dim_gmax(i) < dim_newmin(i)) return + if (dim_gmin(i) > dim_newmax(i)) return + enddo +! + do i = 1,nbdim +! + ind_newmin(i) = pttabnew(i) - floor(-(max(dim_gmin(i),dim_newmin(i))-dim_newmin(i))/dsnew(i)) + dim_min(i) = snew(i) + (ind_newmin(i)-pttabnew(i))*dsnew(i) + ind_gmin(i) = pttabold(i) + nint((dim_min(i)-dim_gmin(i))/dsold(i)) + ind_newmax(i) = pttabnew(i) + int((min(dim_gmax(i),dim_newmax(i))-dim_newmin(i))/dsnew(i)) +! + enddo +! + select case (nbdim) +! + case (1) + i0 = ind_gmin(1) + do i = ind_newmin(1),ind_newmax(1) + new_var % array1(i) = old_var % array1(i0) + new_var % restore1D(i) = 1 + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + case (2) + i0 = ind_gmin(1) ; do i = ind_newmin(1),ind_newmax(1) + j0 = ind_gmin(2) ; do j = ind_newmin(2),ind_newmax(2) + new_var % array2(i,j) = old_var % array2(i0,j0) + new_var % restore2D(i,j) = 1 + j0 = j0 + int(dsnew(2)/dsold(2)) + enddo + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + case (3) + i0 = ind_gmin(1) ; do i = ind_newmin(1),ind_newmax(1) + j0 = ind_gmin(2) ; do j = ind_newmin(2),ind_newmax(2) + k0 = ind_gmin(3) ; do k = ind_newmin(3),ind_newmax(3) + new_var % array3(i,j,k) = old_var % array3(i0,j0,k0) + new_var % restore3D(i,j,k) = 1 + k0 = k0 + int(dsnew(3)/dsold(3)) + enddo + j0 = j0 + int(dsnew(2)/dsold(2)) + enddo + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + case (4) + i0 = ind_gmin(1) ; do i = ind_newmin(1),ind_newmax(1) + j0 = ind_gmin(2) ; do j = ind_newmin(2),ind_newmax(2) + k0 = ind_gmin(3) ; do k = ind_newmin(3),ind_newmax(3) + l0 = ind_gmin(4) ; do l = ind_newmin(4),ind_newmax(4) + new_var % array4(i,j,k,l) = old_var % array4(i0,j0,k0,l0) + new_var % restore4D(i,j,k,l) = 1 + l0 = l0 + int(dsnew(4)/dsold(4)) + enddo + k0 = k0 + int(dsnew(3)/dsold(3)) + enddo + j0 = j0 + int(dsnew(2)/dsold(2)) + enddo + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + case (5) + i0 = ind_gmin(1) ; do i = ind_newmin(1),ind_newmax(1) + j0 = ind_gmin(2) ; do j = ind_newmin(2),ind_newmax(2) + k0 = ind_gmin(3) ; do k = ind_newmin(3),ind_newmax(3) + l0 = ind_gmin(4) ; do l = ind_newmin(4),ind_newmax(4) + m0 = ind_gmin(5) ; do m = ind_newmin(5),ind_newmax(5) + new_var % array5(i,j,k,l,m) = old_var % array5(i0,j0,k0,l0,m0) + new_var % restore5D(i,j,k,l,m) = 1 + m0 = m0 + int(dsnew(5)/dsold(5)) + enddo + l0 = l0 + int(dsnew(4)/dsold(4)) + enddo + k0 = k0 + int(dsnew(3)/dsold(3)) + enddo + j0 = j0 + int(dsnew(2)/dsold(2)) + enddo + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + case (6) + i0 = ind_gmin(1) ; do i = ind_newmin(1),ind_newmax(1) + j0 = ind_gmin(2) ; do j = ind_newmin(2),ind_newmax(2) + k0 = ind_gmin(3) ; do k = ind_newmin(3),ind_newmax(3) + l0 = ind_gmin(4) ; do l = ind_newmin(4),ind_newmax(4) + m0 = ind_gmin(5) ; do m = ind_newmin(5),ind_newmax(5) + n0 = ind_gmin(6) ; do n = ind_newmin(6),ind_newmax(6) + new_var % array6(i,j,k,l,m,n) = old_var % array6(i0,j0,k0,l0,m0,n0) + new_var % restore6D(i,j,k,l,m,n) = 1 + n0 = n0 + int(dsnew(6)/dsold(6)) + enddo + m0 = m0 + int(dsnew(5)/dsold(5)) + enddo + l0 = l0 + int(dsnew(4)/dsold(4)) + enddo + k0 = k0 + int(dsnew(3)/dsold(3)) + enddo + j0 = j0 + int(dsnew(2)/dsold(2)) + enddo + i0 = i0 + int(dsnew(1)/dsold(1)) + enddo +! + end select +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_CopynD +!=================================================================================================== +! +end module Agrif_Save diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modseq.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modseq.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c1136067d64a2a9fca26bd72bb8fb44284662dc2 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modseq.F90 @@ -0,0 +1,640 @@ +module Agrif_seq +! + use Agrif_Init + use Agrif_Procs + use Agrif_Arrays +! + implicit none +! +contains +! +#if defined AGRIF_MPI +!=================================================================================================== +function Agrif_seq_allocate_list ( nb_seqs ) result( seqlist ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: nb_seqs +! + type(Agrif_Sequence_List), pointer :: seqlist +! + allocate(seqlist) + seqlist % nb_seqs = nb_seqs + allocate(seqlist % sequences(1:nb_seqs)) +!--------------------------------------------------------------------------------------------------- +end function Agrif_seq_allocate_list +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_add_grid ( seqlist, seq_num, grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Sequence_List), intent(inout) :: seqlist + integer, intent(in) :: seq_num + type(Agrif_Grid), pointer, intent(in) :: grid +! + call Agrif_gl_append(seqlist % sequences(seq_num) % gridlist, grid ) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_add_grid +!=================================================================================================== +! +!=================================================================================================== +recursive subroutine Agrif_seq_init_sequences ( grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(inout) :: grid +! + type(Agrif_PGrid), pointer :: gp +! +#if defined AGRIF_MPI +! +! Build list of required procs for each child grid + gp => grid % child_list % first + do while ( associated( gp ) ) + call Agrif_seq_build_required_proclist( gp % gr ) + gp => gp % next + enddo +! +! Create integration sequences for the current grid + call Agrif_seq_create_proc_sequences( grid ) + call Agrif_seq_allocate_procs_to_childs( grid ) +! +! Create new communicators for sequences + call Agrif_seq_create_communicators( grid ) +! +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_init_sequences +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_build_required_proclist ( grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(inout) :: grid +! + type(Agrif_Grid), pointer :: parent_grid + type(Agrif_Rectangle), pointer :: grid_rect + type(Agrif_Proc_p), pointer :: proc_rect + type(Agrif_Proc), pointer :: proc + logical :: proc_is_required + integer :: i +! + if ( grid % fixedrank == 0 ) then +! grid is the Root + if ( grid % required_proc_list % nitems == 0 ) then + print*, "### Error Agrif_seq_build_required_proclist: empty proc list." + print*, "# -> You should check if Agrif_Init_ProcList() is actually working." + stop + endif + return + endif +! + parent_grid => grid % parent + grid_rect => grid % rect_in_parent + proc_rect => parent_grid % proc_def_list % first +! + + do while ( associated( proc_rect ) ) + +! + proc => proc_rect % proc +! + proc_is_required = .true. + do i = 1,Agrif_Probdim + proc_is_required = ( proc_is_required .and. & + ( grid_rect % imin(i) <= proc % imax(i) ) .and. & + ( grid_rect % imax(i) >= proc % imin(i) ) ) + enddo +! + if ( proc_is_required ) then + call Agrif_pl_append(grid % required_proc_list, proc) + endif + proc_rect => proc_rect % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_build_required_proclist +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_create_proc_sequences ( grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(inout) :: grid +! + type(Agrif_Grid_List), pointer :: sorted_child_list + type(Agrif_PGrid), pointer :: child_p + type(Agrif_PGrid), pointer :: g1p, g2p + type(Agrif_Proc_p), pointer :: pp1, pp2 + type(Agrif_Proc), pointer :: proc + integer :: nb_seq_max, nb_seqs, cur_seq +! + nb_seq_max = 0 +! + if ( grid % child_list % nitems == 0 ) return +! +! For each required proc... + pp1 => grid % required_proc_list % first + do while ( associated(pp1) ) + proc => pp1 % proc + proc % nb_seqs = 0 +! ..loop over all child grids... + child_p => grid % child_list % first + do while ( associated(child_p) ) +! ..and look for 'proc' in the list of procs required by 'child' + pp2 => child_p % gr % required_proc_list % first + do while ( associated(pp2) ) + if ( proc % pn == pp2 % proc % pn ) then +! 'proc' is required by this child grid, so we increment its number of sequences + proc % nb_seqs = proc % nb_seqs + 1 + pp2 => NULL() + else + pp2 => pp2 % next + endif + enddo + child_p => child_p % next + enddo + nb_seq_max = max(nb_seq_max, proc % nb_seqs) + pp1 => pp1 % next + enddo +! +! For each grid... + g1p => grid % child_list % first + do while ( associated(g1p) ) +! compare it with the following ones + g2p => g1p % next + do while ( associated(g2p) ) + if ( Agrif_seq_grids_are_connected( g1p % gr, g2p % gr ) ) then + call Agrif_gl_append( g1p % gr % neigh_list, g2p % gr ) + call Agrif_gl_append( g2p % gr % neigh_list, g1p % gr ) + endif + g2p => g2p % next + enddo + g1p => g1p % next + enddo +! +! Colorize graph nodes + nb_seqs = Agrif_seq_colorize_grid_list(grid % child_list) + sorted_child_list => Agrif_gl_merge_sort ( grid % child_list, compare_colors ) +! +! Create sequence structure + cur_seq = 0 + grid % child_seq => Agrif_seq_allocate_list(nb_seqs) + child_p => sorted_child_list % first + do while ( associated(child_p) ) + if ( cur_seq /= child_p % gr % seq_num ) then + cur_seq = child_p % gr % seq_num + endif + call Agrif_seq_add_grid(grid % child_seq,cur_seq,child_p% gr) + child_p => child_p % next + enddo +! + call Agrif_gl_delete(sorted_child_list) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_create_proc_sequences +!=================================================================================================== +! +!=================================================================================================== +function Agrif_seq_grids_are_connected( g1, g2 ) result( connection ) +! +!< Compare required_proc_list for g1 and g2. These are connected if they share a same proc. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(in) :: g1, g2 +! + logical :: connection + type(Agrif_Proc_p), pointer :: pp1, pp2 +! + connection = .false. +! + pp1 => g1 % required_proc_list % first +! + do while( associated(pp1) .and. (.not. connection) ) +! + pp2 => g2 % required_proc_list % first + do while ( associated(pp2) .and. (.not. connection) ) + if ( pp1 % proc % pn == pp2 % proc % pn ) then + ! if pp1 and pp2 are the same proc, it means that g1 and g2 are connected. We stop here. + connection = .true. + endif + pp2 => pp2 % next + enddo + pp1 => pp1 % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end function Agrif_seq_grids_are_connected +!=================================================================================================== +! +!=================================================================================================== +function Agrif_seq_colorize_grid_list ( gridlist ) result ( ncolors ) +! +!< 1. Sort nodes in decreasing order of degree. +!< 2. Color the node with highest degree with color 1. +!< 3. Choose the node with the largest DSAT value. In case of conflict, choose the one with the +!! highest degree. Then the one corresponding to the largest grid. +!< 4. Color this node with the smallest possible color. +!< 5. If all nodes are colored, then stop. Otherwise, go to 3. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist +! + type(Agrif_Grid_List), pointer :: X, Y + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Grid_List), pointer :: tmp_gl + integer :: ncolors + integer, dimension(1:gridlist%nitems) :: colors +! +! Be carefull... + nullify(Y) +! +! First initialize the color of each node + gridp => gridlist % first + do while ( associated(gridp) ) + gridp % gr % seq_num = 0 + gridp => gridp % next + enddo +! +! Then sort the grids by decreasing degree + X => Agrif_gl_merge_sort( gridlist, compare_grid_degrees ) + gridp => X % first +! +! Colorize the first grid in the list + gridp % gr % seq_num = 1 + gridp => gridp % next +! +! Then for each of its neighbors... + do while ( associated(gridp) ) +! + if ( gridp % gr % neigh_list % nitems == 0 ) then + ! this grid is alone... let.s attach it to an existing sequence + call Agrif_seq_attach_grid( X, gridp % gr ) + gridp => gridp % next + cycle + endif +! +! Compute dsat value of all non-colored grids + tmp_gl => Agrif_gl_build_from_gp(gridp) + call Agrif_seq_calc_dsat(tmp_gl) +! +! Sort non-colored grids by decreasing dsat value, then by size + call Agrif_gl_delete(Y) + Y => Agrif_gl_merge_sort( tmp_gl, compare_dsat_values, compare_size_values ) +! +! Next coloration is for the first grid in this list TODO : maybe we could find a better choice ..? + gridp => Y % first +! +! Assign a color to the chosen grid + gridp % gr % seq_num = Agrif_seq_smallest_available_color_in_neighborhood( gridp % gr % neigh_list ) +! + gridp => gridp % next + call Agrif_gl_delete(tmp_gl) +! + enddo +! + call Agrif_gl_delete(X) + call Agrif_seq_colors_in_neighborhood( gridlist, colors ) + ncolors = maxval(colors) +!--------------------------------------------------------------------------------------------------- +end function Agrif_seq_colorize_grid_list +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_attach_grid ( gridlist, grid ) +! +!< 'grid' is not connected to any neighbor. Therefore, we give an existing and well chosen color. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist + type(Agrif_Grid), intent(inout) :: grid +! + integer, dimension(gridlist%nitems) :: colors + integer, dimension(:), allocatable :: ngrids_by_color + integer :: i, color, ncolors +! + call Agrif_seq_colors_in_neighborhood( gridlist, colors ) + ncolors = maxval(colors) +! + allocate(ngrids_by_color(ncolors)) + ngrids_by_color = 0 +! + do i = 1,gridlist % nitems + if (colors(i) > 0) ngrids_by_color(colors(i)) = ngrids_by_color(colors(i)) + 1 + enddo +! + color = ncolors + do i = 1,ncolors + if ( ngrids_by_color(i) < color ) color = i + enddo +! + grid % seq_num = color + deallocate(ngrids_by_color) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_attach_grid +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_colors_in_neighborhood ( neigh_list, colors ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: neigh_list + integer, dimension(:), intent(out) :: colors +! + integer :: i + type(Agrif_PGrid), pointer :: gridp +! + i = lbound(colors,1) + colors = 0 + gridp => neigh_list % first +! + do while ( associated(gridp) ) +! + if ( i > ubound(colors,1) ) then + print*,'Error in Agrif_seq_colors_in_neighborhood : "colors" array is too small' + stop + endif + colors(i) = gridp % gr % seq_num + gridp => gridp % next + i = i+1 +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_colors_in_neighborhood +!=================================================================================================== +! +!=================================================================================================== +function Agrif_seq_smallest_available_color_in_neighborhood ( neigh_list ) result ( smallest ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: neigh_list +! + integer, dimension(:), allocatable :: color_is_met + integer :: colors_tab(1:neigh_list%nitems) + integer :: i, smallest, max_color +! + call Agrif_seq_colors_in_neighborhood( neigh_list, colors_tab ) + max_color = maxval(colors_tab) +! + allocate(color_is_met(1:max_color)) + color_is_met = 0 +! + do i = 1,neigh_list % nitems + if ( colors_tab(i) /= 0 ) then + color_is_met(colors_tab(i)) = 1 + endif + enddo +! + smallest = max_color+1 + do i = 1,max_color + if ( color_is_met(i) == 0 ) then + smallest = i + exit + endif + enddo +! + deallocate(color_is_met) +!--------------------------------------------------------------------------------------------------- +end function Agrif_seq_smallest_available_color_in_neighborhood +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_calc_dsat ( gridlist ) +!< For each node 'v' : +!< if none of its neighbors is colored then +!< DSAT(v) = degree(v) # degree(v) := number of neighbors +!< else +!< DSAT(v) = number of different colors used in the first neighborhood of v. +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(in) :: gridlist +! + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Grid), pointer :: grid + integer, dimension(:), allocatable :: colors, color_is_met + integer :: i, ncolors +! + gridp => gridlist % first +! + do while ( associated(gridp) ) +! + grid => gridp % gr +! + allocate(colors(grid % neigh_list % nitems)) + call Agrif_seq_colors_in_neighborhood( grid % neigh_list, colors ) + + allocate(color_is_met(1:maxval(colors))) + color_is_met = 0 +! + do i = 1,grid % neigh_list % nitems + if ( colors(i) /= 0 ) then + color_is_met(colors(i)) = 1 + endif + enddo + ncolors = sum(color_is_met) +! + if ( ncolors == 0 ) then + grid % dsat = grid % neigh_list % nitems + else + grid % dsat = ncolors + endif + deallocate(colors, color_is_met) + gridp => gridp % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_calc_dsat +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_allocate_procs_to_childs ( coarse_grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(inout) :: coarse_grid +! + integer :: is, ip, ig, ngrids + type(Agrif_Grid_List), pointer :: gridlist + type(Agrif_PGrid), pointer :: gp + type(Agrif_Grid), pointer :: grid + type(Agrif_Proc_List), pointer :: proclist + type(Agrif_Proc), pointer :: proc + type(Agrif_Proc_p), pointer :: pp + type(Agrif_Proc), dimension(:), allocatable, target :: procarray + type(Agrif_Grid), dimension(:), allocatable :: gridarray + type(Agrif_Sequence_List), pointer :: seqlist + real,dimension(:),allocatable :: grid_costs + integer,dimension(:), allocatable :: nbprocs_per_grid + integer :: i1, i2, j1, j2 + real :: max_cost + integer :: max_index +! + seqlist => coarse_grid % child_seq + if ( .not. associated(seqlist) ) return +! +! Initialize proc allocation + pp => coarse_grid % proc_def_list % first + do while ( associated(pp) ) + pp % proc % grid_id = 0 + pp => pp % next + enddo +! +! For each sequence... + do is = 1,seqlist % nb_seqs +! + proclist => seqlist % sequences(is) % proclist + gridlist => seqlist % sequences(is) % gridlist +! +! Copy coarse grid proc list and convert it to an array + call Agrif_pl_deep_copy( coarse_grid % proc_def_list, proclist ) + call Agrif_pl_to_array ( proclist, procarray ) +! +! Allocate a temporary array with concerned grid numbers + ngrids = gridlist % nitems + allocate(gridarray(1:ngrids)) + allocate(grid_costs(1:ngrids)) + allocate(nbprocs_per_grid(1:ngrids)) + + nbprocs_per_grid = 0 +! +! Allocate required procs to each grid + gp => gridlist % first + ig = 0 + do while ( associated(gp) ) + grid => gp % gr + ig = ig+1 ; gridarray(ig) = grid + pp => grid % required_proc_list % first + do while ( associated(pp) ) + procarray( pp % proc % pn+1 ) % grid_id = grid % fixedrank + nbprocs_per_grid(ig) = nbprocs_per_grid(ig) + 1 + pp => pp % next + enddo + gp => gp % next + enddo +! +! Add unused procs to the grids +! TODO FIXME: This is just a dummy allocation. You should take into account grid size and more +! information here... + +! Estimate current costs + + do ig = 1, ngrids + i1 = gridarray(ig)%ix(1) + i2 = gridarray(ig)%ix(1)+gridarray(ig)%nb(1)/gridarray(ig)%spaceref(1)-1 + j1 = gridarray(ig)%ix(2) + j2 = gridarray(ig)%ix(2)+gridarray(ig)%nb(2)/gridarray(ig)%spaceref(2)-1 + Call Agrif_estimate_parallel_cost(i1,i2,j1,j2,nbprocs_per_grid(ig),grid_costs(ig)) + grid_costs(ig) = grid_costs(ig) * gridarray(ig)%timeref(1) + enddo + + ig = 1 + do ip = 1,proclist%nitems + if ( procarray( ip ) % grid_id == 0 ) then +! this proc is unused + max_cost = 0. + max_index = 1 + do ig = 1,ngrids + if (grid_costs(ig) > max_cost) then + max_cost = grid_costs(ig) + max_index = ig + endif + enddo + + ig = max_index + procarray( ip ) % grid_id = gridarray(ig) % fixedrank + + nbprocs_per_grid(ig) = nbprocs_per_grid(ig) + 1 + i1 = gridarray(ig)%ix(1) + i2 = gridarray(ig)%ix(1)+gridarray(ig)%nb(1)/gridarray(ig)%spaceref(1)-1 + j1 = gridarray(ig)%ix(2) + j2 = gridarray(ig)%ix(2)+gridarray(ig)%nb(2)/gridarray(ig)%spaceref(2)-1 + Call Agrif_estimate_parallel_cost(i1,i2,j1,j2,nbprocs_per_grid(ig),grid_costs(ig)) + grid_costs(ig) = grid_costs(ig) * gridarray(ig)%timeref(1) + + endif + enddo +! +! Allocate proc nums to each grid + gp => gridlist % first + do while ( associated(gp) ) + do ip = 1,proclist%nitems + if ( procarray( ip ) % grid_id == gp % gr % fixedrank ) then + allocate(proc) + proc = procarray( ip ) + call Agrif_pl_append(gp % gr % proc_def_in_parent_list, proc) + endif + enddo + gp => gp % next + enddo +! +! Clean up + deallocate(procarray, gridarray, grid_costs, nbprocs_per_grid) +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_allocate_procs_to_childs +!=================================================================================================== +! +!=================================================================================================== +subroutine Agrif_seq_create_communicators ( grid ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), intent(inout) :: grid +! + include 'mpif.h' + type(Agrif_Sequence_List), pointer :: seqlist ! List of child sequences + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Proc), pointer :: proc + integer :: i, ierr + integer :: current_comm, comm_seq, color_seq +! + seqlist => grid % child_seq + if ( .not. associated(seqlist) ) return +! + current_comm = grid % communicator + color_seq = MPI_COMM_NULL +! +! For each sequence, split the current communicator into as many groups as needed. + do i = 1,seqlist % nb_seqs +! +! Loop over each proclist to give a color to the current process + gridp => seqlist % sequences(i) % gridlist % first + grid_loop : do while ( associated(gridp) ) + proc => Agrif_pl_search_proc( gridp % gr % proc_def_in_parent_list, Agrif_Procrank ) + if ( associated(proc) ) then + if ( gridp % gr % fixedrank /= proc % grid_id ) then + write(*,'("### Error Agrif_seq_create_communicators : ")') + write(*,'(" inconsitancy on proc ",i2,":")') Agrif_Procrank + write(*,'("gr % fixedrank = ",i0,", where proc % grid_id = ",i0)') & + gridp % gr % fixedrank, proc % grid_id + stop + endif + color_seq = gridp % gr % fixedrank + exit grid_loop + endif + gridp => gridp % next + enddo grid_loop +! + call MPI_COMM_SPLIT(current_comm, color_seq, Agrif_ProcRank, comm_seq, ierr) + gridp % gr % communicator = comm_seq +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_seq_create_communicators +!=================================================================================================== +! +!=================================================================================================== +function Agrif_seq_select_child ( g, is ) result ( gridp ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer, intent(in) :: g + integer, intent(in) :: is +! + type(Agrif_PGrid), pointer :: gridp + type(Agrif_Proc), pointer :: proc +! + call Agrif_Instance( g ) + gridp => g % child_seq % sequences(is) % gridlist % first +! + do while ( associated(gridp) ) + proc => Agrif_pl_search_proc( gridp % gr % proc_def_in_parent_list, Agrif_Procrank ) + if ( associated(proc) ) then + return + endif + gridp => gridp % next + enddo + write(*,'("### Error Agrif_seq_select_child : no grid found in sequence ",i0," (mother G",i0,") for P",i0)')& + is, g%fixedrank, Agrif_Procrank + stop +!--------------------------------------------------------------------------------------------------- +end function Agrif_seq_select_child +!=================================================================================================== +#else + subroutine dummy_Agrif_seq () + end subroutine dummy_Agrif_seq +#endif +! +end module Agrif_seq diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modtypes.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modtypes.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6fa23ed37a997c05e3de908c1927fc0cc62606db --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modtypes.F90 @@ -0,0 +1,425 @@ +! Agrif (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place-Suite 330, Boston, MA 02111-1307, USA. +! +! +! +! +!> Definition of data types used in AGRIF, of several variables and parameters +! +module Agrif_Types +! +use Agrif_Procs +! +implicit none +! +integer, parameter :: Agrif_MaxRaff = 7 !< Maximum refinement ratio +integer, parameter :: Agrif_NbMaxGrids = 10 !< Maximum number of grids of the hierarchy +! +!=================================================================================================== +type Agrif_LRectangle +!--------------------------------------------------------------------------------------------------- +!< Data type allowing a grid to reach a grid on the same level or its child grids +! + type(Agrif_Rectangle) , pointer :: r => NULL() !< to reach a child grid + type(Agrif_LRectangle), pointer :: next => NULL() !< to reach a grid on the same level +! +!--------------------------------------------------------------------------------------------------- +end type Agrif_LRectangle +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Rectangle +!--------------------------------------------------------------------------------------------------- +!< Data type to define several characteristics of a grid (number, position, time and space +!< refinement factors, etc). +! + integer :: number !< Number of the grid + integer, dimension(3) :: imin !< Minimal position in the x,y and z direction + integer, dimension(3) :: imax !< Maximal position in the x,y and z direction + integer, dimension(3) :: spaceref !< Space refinement factor in the x,y and z direction + integer, dimension(3) :: timeref !< Time refinement factor in the x,y and z direction + type(Agrif_LRectangle), pointer :: childgrids => NULL() !< Pointer to reach a grid on the same level or a child grid +! +!--------------------------------------------------------------------------------------------------- +end type Agrif_Rectangle +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Variable +!--------------------------------------------------------------------------------------------------- +!< Data type to characterize a grid variable. +! + type(Agrif_Variable), pointer :: root_var => NULL() !< pointer on the variable of the root grid + type(Agrif_Variable), pointer :: parent_var => NULL() !< pointer on the parent variable +! + integer, dimension(6) :: point !< index of the first point in the + !< real domain (x,y and z direction) + integer, dimension(:), allocatable :: posvar !< position of the variable on the cell + !< (1 for the boarder of the edge, 2 for the center) + integer :: interpIndex = -1 !< Indication for the space interpolation (module Agrif_Boundary) + integer :: nbdim = 0 !< number of dimensions of the grid variable + character(1), dimension(:), allocatable :: interptab !< Array indicating the type of dimension (space or not) + !! for each of them + integer, dimension(:), allocatable :: coords !< Array indicating the coordinate for each dimension + !! of the array that is refined : + !! 'x' -> 1 ; 'y' -> 2 ; 'z' -> 3 ; 'N' -> 0 + +!> @} +!> \name Arrays containing the values of the grid variables (real) +!> @{ + real, dimension(:) , allocatable :: array1 + real, dimension(:,:) , allocatable :: array2 + real, dimension(:,:,:) , allocatable :: array3 + real, dimension(:,:,:,:) , allocatable :: array4 + real, dimension(:,:,:,:,:) , allocatable :: array5 + real, dimension(:,:,:,:,:,:), allocatable :: array6 +!> @} +!> \name Arrays containing the values of the grid variables (real*8) +!> @{ + real(8), dimension(:) , allocatable :: darray1 + real(8), dimension(:,:) , allocatable :: darray2 + real(8), dimension(:,:,:) , allocatable :: darray3 + real(8), dimension(:,:,:,:) , allocatable :: darray4 + real(8), dimension(:,:,:,:,:) , allocatable :: darray5 + real(8), dimension(:,:,:,:,:,:), allocatable :: darray6 +!> @} +!> \name Arrays containing the values of the grid variables (real*4) +!> @{ + real(4), dimension(:) , allocatable :: sarray1 + real(4), dimension(:,:) , allocatable :: sarray2 + real(4), dimension(:,:,:) , allocatable :: sarray3 + real(4), dimension(:,:,:,:) , allocatable :: sarray4 + real(4), dimension(:,:,:,:,:) , allocatable :: sarray5 + real(4), dimension(:,:,:,:,:,:), allocatable :: sarray6 +!> @} +!> \name Arrays used to restore the values +!> @{ + integer, dimension(:) , pointer :: restore1D => NULL() + integer, dimension(:,:) , pointer :: restore2D => NULL() + integer, dimension(:,:,:) , pointer :: restore3D => NULL() + integer, dimension(:,:,:,:) , pointer :: restore4D => NULL() + integer, dimension(:,:,:,:,:) , pointer :: restore5D => NULL() + integer, dimension(:,:,:,:,:,:), pointer :: restore6D => NULL() +!> @} + + real, dimension(:,:), pointer :: oldvalues2D => NULL() !< Array used for the time interpolation + + logical :: restore = .FALSE. !< =1 if the variable should be restored + logical :: Interpolationshouldbemade = .FALSE. !< TRUE if the interpolation should be made in any case + integer :: bcinf !< option bc + integer :: bcsup !< option bc + integer, dimension(6) :: type_interp !< option interp + integer, dimension(6,6) :: type_interp_bc !< option bcinterp + integer, dimension(6) :: type_update !< option update + + integer, dimension(6) :: lb + integer, dimension(6) :: ub + + logical,dimension(6,2) :: memberin + integer,dimension(6,2,2,6,2) :: childarray + + type(Agrif_List_Interp_Loc), pointer :: list_interp => NULL() + type(Agrif_List_Interp_Loc), pointer :: list_update => NULL() +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variable +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Variable_c +!--------------------------------------------------------------------------------------------------- +!< Data type to characterize a grid variable. +! + type(Agrif_Variable_c), pointer :: root_var => NULL() !< pointer on the variable of the root grid + type(Agrif_Variable_c), pointer :: parent_var => NULL() !< pointer on the parent variable +! + integer :: nbdim = 0 !< number of dimensions of the grid variable +! +!> \name Arrays containing the values of the grid variables (character) +!> @{ + character(2400) :: carray0 + character(200), dimension(:) , allocatable :: carray1 + character(200), dimension(:,:), allocatable :: carray2 +!> @} +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variable_c +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Variable_r +!--------------------------------------------------------------------------------------------------- +!< Data type to characterize a grid variable. +! + type(Agrif_Variable_r), pointer :: root_var => NULL() !< pointer on the variable of the root grid + type(Agrif_Variable_r), pointer :: parent_var => NULL() !< pointer on the parent variable +! + integer :: nbdim = 0 !< number of dimensions of the grid variable +! +!> \name Arrays containing the values of the grid variables (real) +!> @{ + real :: array0 + real, dimension(:) , allocatable :: array1 + real, dimension(:,:) , allocatable :: array2 + real, dimension(:,:,:) , allocatable :: array3 + real, dimension(:,:,:,:) , allocatable :: array4 + real, dimension(:,:,:,:,:) , allocatable :: array5 + real, dimension(:,:,:,:,:,:), allocatable :: array6 +!> @} +!> \name Arrays containing the values of the grid variables (real*8) +!> @{ + real(8) :: darray0 + real(8), dimension(:) , allocatable :: darray1 + real(8), dimension(:,:) , allocatable :: darray2 + real(8), dimension(:,:,:) , allocatable :: darray3 + real(8), dimension(:,:,:,:) , allocatable :: darray4 + real(8), dimension(:,:,:,:,:) , allocatable :: darray5 + real(8), dimension(:,:,:,:,:,:), allocatable :: darray6 +!> @} +!> \name Arrays containing the values of the grid variables (real*4) +!> @{ + real(4) :: sarray0 + real(4), dimension(:) , allocatable :: sarray1 + real(4), dimension(:,:) , allocatable :: sarray2 + real(4), dimension(:,:,:) , allocatable :: sarray3 + real(4), dimension(:,:,:,:) , allocatable :: sarray4 + real(4), dimension(:,:,:,:,:) , allocatable :: sarray5 + real(4), dimension(:,:,:,:,:,:), allocatable :: sarray6 +!> @} +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variable_r +!=================================================================================================== +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Variable_l +!--------------------------------------------------------------------------------------------------- +!< Data type to characterize a grid variable. +! + type(Agrif_Variable_l), pointer :: root_var => NULL() !< pointer on the variable of the root grid + type(Agrif_Variable_l), pointer :: parent_var => NULL() !< pointer on the parent variable +! + integer :: nbdim = 0 !< number of dimensions of the grid variable +! +!> \name Arrays containing the values of the grid variables (logical) +!> @{ + logical :: larray0 + logical, dimension(:) , allocatable :: larray1 + logical, dimension(:,:) , allocatable :: larray2 + logical, dimension(:,:,:) , allocatable :: larray3 + logical, dimension(:,:,:,:) , allocatable :: larray4 + logical, dimension(:,:,:,:,:) , allocatable :: larray5 + logical, dimension(:,:,:,:,:,:), allocatable :: larray6 +!> @} +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variable_l +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Variable_i +!--------------------------------------------------------------------------------------------------- +!< Data type to characterize a grid variable. +! + type(Agrif_Variable_i), pointer :: root_var => NULL() !< pointer on the variable of the root grid + type(Agrif_Variable_i), pointer :: parent_var => NULL() !< pointer on the parent variable +! + integer :: nbdim = 0 !< number of dimensions of the grid variable +! +!> \name Arrays containing the values of the grid variables (integer) +!> @{ + integer :: iarray0 + integer, dimension(:) , allocatable :: iarray1 + integer, dimension(:,:) , allocatable :: iarray2 + integer, dimension(:,:,:) , allocatable :: iarray3 + integer, dimension(:,:,:,:) , allocatable :: iarray4 + integer, dimension(:,:,:,:,:) , allocatable :: iarray5 + integer, dimension(:,:,:,:,:,:), allocatable :: iarray6 +!> @} +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variable_i +!=================================================================================================== +! +!=================================================================================================== +type Agrif_Interp_Loc +!--------------------------------------------------------------------------------------------------- + integer,dimension(6) :: pttab, petab, pttab_Child, pttab_Parent = -99 + integer,dimension(6) :: indmin, indmax + integer,dimension(6) :: pttruetab,cetruetab + logical :: member, memberin +#if !defined AGRIF_MPI + integer,dimension(6) :: indminglob,indmaxglob +#else + integer,dimension(6) :: indminglob2,indmaxglob2 + integer,dimension(6,2,2) :: parentarray + integer,dimension(:,:,:), pointer :: tab4t => NULL() + integer,dimension(:,:,:), pointer :: tab5t => NULL() + logical, dimension(:), pointer :: memberinall => NULL() + logical, dimension(:), pointer :: memberinall2 => NULL() + logical, dimension(:), pointer :: sendtoproc1 => NULL() + logical, dimension(:), pointer :: sendtoproc2 => NULL() + logical, dimension(:), pointer :: recvfromproc1 => NULL() + logical, dimension(:), pointer :: recvfromproc2 => NULL() +#endif +!--------------------------------------------------------------------------------------------------- +end type Agrif_Interp_Loc +!=================================================================================================== + +!=================================================================================================== +type Agrif_List_Interp_Loc +!--------------------------------------------------------------------------------------------------- + type(Agrif_Interp_Loc), pointer :: interp_loc => NULL() + type(Agrif_List_Interp_Loc), pointer :: suiv => NULL() +!--------------------------------------------------------------------------------------------------- +end type Agrif_List_Interp_Loc +!=================================================================================================== + +!=================================================================================================== +type Agrif_Variables_List +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: var => NULL() + type(Agrif_Variables_List), pointer :: next => NULL() +!--------------------------------------------------------------------------------------------------- +end type Agrif_Variables_List +!=================================================================================================== +! +!=================================================================================================== +!> Different parameters +! + type(Agrif_Variable), dimension(:), pointer :: Agrif_tabvars => NULL() + type(Agrif_Variable_c), dimension(:), pointer :: Agrif_tabvars_c => NULL() + type(Agrif_Variable_r), dimension(:), pointer :: Agrif_tabvars_r => NULL() + type(Agrif_Variable_l), dimension(:), pointer :: Agrif_tabvars_l => NULL() + type(Agrif_Variable_i), dimension(:), pointer :: Agrif_tabvars_i => NULL() +! + integer :: Agrif_Probdim !< Problem dimension + integer,dimension(0:4):: Agrif_NbVariables !< Number of variables + integer :: Agrif_nbfixedgrids !< Number of fixed grids in the grid hierarchy + integer, dimension(3) :: Agrif_coeffref !< Space refinement factor + integer, dimension(3) :: Agrif_coeffreft !< Time refinement factor + logical :: Agrif_UseSpecialValue !< T if use special values on the parent grid + logical :: Agrif_UseSpecialValueInUpdate !< T if use special values on the parent grid + logical :: Agrif_Update_Weights = .FALSE. + logical :: Agrif_UseSpecialValueFineGrid !< T if use special values on the current grid + real :: Agrif_SpecialValue !< Special value on the parent grid + real :: Agrif_SpecialValueFineGrid !< Special value on the current grid +!> +!> \name Clustering parameters +!> @{ + integer :: Agrif_Regridding = 10 + integer :: Agrif_Minwidth + real :: Agrif_Efficiency = 0.7 + integer :: MaxSearch = 5 + real, dimension(3) :: Agrif_mind +!> @} +!> \name parameters for the interpolation of the child grids +!> @{ + integer, parameter :: Agrif_linear = 1 !< linear interpolation + integer, parameter :: Agrif_lagrange = 2 !< lagrange interpolation + integer, parameter :: Agrif_eno = 3 !< spline interpolation + integer, parameter :: Agrif_user_interp = 4 !< user defined interpolation + integer, parameter :: Agrif_constant = 5 !< constant interpolation + integer, parameter :: Agrif_linearconserv = 6 !< linear conservative interpolation + integer, parameter :: Agrif_linearconservlim = 7 !< linear conservative interpolation + integer, parameter :: Agrif_ppm = 8 !< PPM interpolation + integer, parameter :: Agrif_weno = 9 !< WENO5 interpolation + integer, parameter :: Agrif_ppm_lim = 10 !< PPM interpolation with monotonicity +!> @} +!> \name parameters for the update of the parent grids +!> @{ + integer, parameter :: Agrif_Update_Copy = 1 !< copy + integer, parameter :: Agrif_Update_Average = 2 !< average + integer, parameter :: Agrif_Update_Full_Weighting = 3 !< full-weighting +!> @} +!> \name Raffinement grid switches +!> @{ + integer :: Agrif_USE_ONLY_FIXED_GRIDS !< = 1 if fixed grid mode + integer :: Agrif_USE_FIXED_GRIDS !< = 1 if AMR mode + fixed grid else only AMR mode +!> @} + integer :: Agrif_Maxlevelloc +! +#if defined AGRIF_MPI + integer :: Agrif_Nbprocs !< Number of processors + integer :: Agrif_ProcRank !< Rank of the current processor + integer :: Agrif_Group !< Group associated to Agrif_mpi_comm + integer :: Agrif_mpi_comm +#else + integer :: Agrif_ProcRank = 0 +#endif +! + integer :: Agrif_Extra_Boundary_Cells = 3 !< When computing integration sequences, the grid rects + !! are expanded to this number of cells. + logical :: Agrif_Parallel_sisters = .FALSE. !< When TRUE, try to compute sister grids (which have the same parent) + !! in parallel rather than sequentially. + logical :: agrif_regrid_has_been_done = .FALSE. !< switch to skip Agrif_Regrid call +! + real, dimension(:) , allocatable :: parray1 + real, dimension(:,:) , allocatable :: parray2 + real, dimension(:,:,:) , allocatable :: parray3 + real, dimension(:,:,:,:) , allocatable :: parray4 + real, dimension(:,:,:,:,:) , allocatable :: parray5 + real, dimension(:,:,:,:,:,:), allocatable :: parray6 +! + logical :: agrif_debug = .false. ! may be activaded in users subroutine for debugging purposes + +! If a grand mother grid is present + logical :: agrif_coarse = .false. + integer, dimension(3) :: coarse_spaceref = (/1,1,1/) + integer, dimension(3) :: coarse_timeref = (/1,1,1/) +! +contains +! +!=================================================================================================== +! function Agrif_Ceiling +!--------------------------------------------------------------------------------------------------- +integer function Agrif_Ceiling ( x ) +!--------------------------------------------------------------------------------------------------- + real, intent(in) :: x +! + integer :: i +! + i = FLOOR(x) +! + if( ABS(x - i) <= 0.0001 )then + Agrif_Ceiling = i + else + Agrif_Ceiling = i+1 + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_Ceiling +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Int +!--------------------------------------------------------------------------------------------------- + integer function Agrif_Int(x) +!--------------------------------------------------------------------------------------------------- + real, intent(in) :: x +! + integer :: i +! + i = FLOOR(x) + 1 +! + if( ABS(x - i) <= 0.0001 )then + Agrif_Int = i + else + Agrif_Int = i-1 + endif +!--------------------------------------------------------------------------------------------------- +end function Agrif_Int +!=================================================================================================== +! +end module Agrif_Types diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdate.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e5ee1d412b09cf538daf65e91bbc58b1568b4110 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdate.F90 @@ -0,0 +1,2130 @@ +! +! $Id: modupdate.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +!> Module Agrif_Update +!> +!> This module contains procedures to update a parent grid from its child grids. +! +module Agrif_Update +! + use Agrif_UpdateBasic + use Agrif_Arrays + use Agrif_CurgridFunctions + use Agrif_Mask +#if defined AGRIF_MPI + use Agrif_Mpp +#endif +! + implicit none +! + logical, private :: precomputedone(7) = .FALSE. +! +contains +! +!=================================================================================================== +! subroutine Agrif_UpdateVariable +! +!> subroutine to set arguments for Agrif_UpdatenD +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_UpdateVariable ( parent, child, updateinf, updatesup, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variable), pointer :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer :: child !< Variable on the child grid + integer, dimension(6), intent(in) :: updateinf !< First positions where interpolations are calculated + integer, dimension(6), intent(in) :: updatesup !< Last positions where interpolations are calculated + procedure() :: procname !< Data recovery procedure +!--------------------------------------------------------------------------------------------------- + integer, dimension(6) :: nb_child ! Number of cells on the child grid + integer, dimension(6) :: lb_child + integer, dimension(6) :: ub_child + integer, dimension(6) :: lb_parent + real , dimension(6) :: s_child ! Child grid position (s_root = 0) + real , dimension(6) :: s_parent ! Parent grid position (s_root = 0) + real , dimension(6) :: ds_child ! Child grid dx (ds_root = 1) + real , dimension(6) :: ds_parent ! Parent grid dx (ds_root = 1) + logical, dimension(6) :: do_update ! Indicates if we perform update for each dimension + integer, dimension(6) :: posvar ! Position of the variable on the cell (1 or 2) + integer, dimension(6) :: oldparentlbound, oldparentubound + integer :: n, nbdim + logical :: wholeupdate + type(Agrif_Variable), pointer :: root ! Variable on the root grid +! + root => child % root_var + nbdim = root % nbdim +! + call PreProcessToInterpOrUpdate( parent, child, & + nb_child, ub_child, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, interp=.false. ) +! + do_update(:) = .true. + posvar(1:nbdim) = root % posvar(1:nbdim) +! + do n = 1,nbdim +! + if ( root % interptab(n) == 'N' ) then + posvar(n) = 1 + do_update(n) = .false. + oldparentlbound(n) = parent % lb(n) + oldparentubound(n) = parent % ub(n) + parent % lb(n) = child % lb(n) + parent % ub(n) = child % ub(n) + end if +! + enddo + + wholeupdate = .FALSE. +! + do n = 1,nbdim + if ( do_update(n) ) then + if ( (updateinf(n) > updatesup(n)) .OR. & + ((updateinf(n) == -99) .AND. (updatesup(n) == -99)) & + ) then + wholeupdate = .TRUE. + endif + endif + enddo +! + IF (wholeupdate) THEN + call Agrif_UpdateWhole(parent, child, & + updateinf(1:nbdim), updatesup(1:nbdim), & + lb_child(1:nbdim), lb_parent(1:nbdim), & + nb_child(1:nbdim), posvar(1:nbdim), & + do_update(1:nbdim), & + s_child(1:nbdim), s_parent(1:nbdim), & + ds_child(1:nbdim), ds_parent(1:nbdim), nbdim, procname) + ELSE + call Agrif_UpdateBcnD(parent, child, & + updateinf(1:nbdim), updatesup(1:nbdim), & + lb_child(1:nbdim), lb_parent(1:nbdim), & + nb_child(1:nbdim), posvar(1:nbdim), & + do_update(1:nbdim), & + s_child(1:nbdim), s_parent(1:nbdim), & + ds_child(1:nbdim), ds_parent(1:nbdim), nbdim, procname) + ENDIF +! + do n = 1,nbdim +! + if ( root % interptab(n) == 'N' ) then ! No space DIMENSION + parent % lb(n) = oldparentlbound(n) + parent % ub(n) = oldparentubound(n) + end if +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_UpdateVariable +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_UpdateWhole +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_UpdateWhole ( parent, child, uinf, usup, & + lb_child, lb_parent, & + nb_child, posvar, & + do_update, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, procname ) +!--------------------------------------------------------------------------------------------------- +#if defined AGRIF_MPI + include 'mpif.h' +#endif +! + type(Agrif_Variable), pointer :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer :: child !< Variable on the child grid + integer, dimension(nbdim), intent(in) :: uinf !< First positions where interpolations are calculated + integer, dimension(nbdim), intent(in) :: usup !< Last positions where interpolations are calculated + integer, intent(in) :: nbdim !< Number of dimensions of the grid variable + integer, dimension(nbdim), intent(in) :: lb_child !< Index of the first point inside the domain for the parent grid variable + integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for the child grid variable + integer, dimension(nbdim), intent(in) :: nb_child !< Number of cells of the child grid + integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) + logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension + real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid + real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid + real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid + real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid + procedure() :: procname !< Data recovery procedure +! + integer, dimension(nbdim) :: type_update ! Type of update (copy or average) + integer, dimension(nbdim,2) :: lubglob + integer, dimension(nbdim,2,2) :: indtab ! limits of the child grid that will be used in the update scheme + integer, dimension(nbdim,2,2) :: indtruetab ! grid variable where boundary conditions are + integer :: coeffraf, i + integer :: uinfloc, usuploc +! + type_update = child % root_var % type_update(1:nbdim) +! + do i = 1, nbdim +! + if ( do_update(i) ) then +! + coeffraf = nint(ds_parent(i)/ds_child(i)) + uinfloc = 0 + usuploc = nb_child(i)/coeffraf - 1 + + IF (posvar(i) == 1) THEN + usuploc = usuploc - 1 + ENDIF + + IF (uinf(i) > usup(i)) THEN + uinfloc = uinf(i) + usuploc = usuploc - uinf(i) + ENDIF + + indtab(i,1,1) = lb_child(i) + (uinfloc + 1) * coeffraf + indtab(i,1,2) = lb_child(i) + (usuploc + 1) * coeffraf + + IF ( posvar(i) == 1 ) THEN + IF ( type_update(i) == Agrif_Update_Full_Weighting ) THEN + indtab(i,1,1) = indtab(i,1,1) - (coeffraf - 1) + indtab(i,1,2) = indtab(i,1,2) + (coeffraf - 1) + ELSE IF ( type_update(i) /= Agrif_Update_Copy ) THEN + indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2 + indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2 + ENDIF + ELSE + indtab(i,1,1) = indtab(i,1,1) - coeffraf + indtab(i,1,2) = indtab(i,1,2) - 1 + ! at this point, indices are OK for an average + IF ( type_update(i) == Agrif_Update_Full_Weighting ) THEN + indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2 + indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2 + ENDIF + ENDIF +! + else ! IF ( .not.do_update(i) ) THEN +! + if ( posvar(i) == 1 ) then + indtab(i,1,1) = lb_child(i) + indtab(i,1,2) = lb_child(i) + nb_child(i) + else + indtab(i,1,1) = lb_child(i) + indtab(i,1,2) = lb_child(i) + nb_child(i) - 1 + endif +! + endif + enddo + +! lubglob contains the global lbound and ubound of the child array +! lubglob(:,1) : global lbound for each dimension +! lubglob(:,2) : global lbound for each dimension +! + call Agrif_get_var_global_bounds(child, lubglob, nbdim) +! + indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1), lubglob(1:nbdim,1)) + indtruetab(1:nbdim,1,2) = min(indtab(1:nbdim,1,2), lubglob(1:nbdim,2)) +! + call Agrif_UpdatenD(type_update, parent, child, & + indtruetab(1:nbdim,1,1), indtruetab(1:nbdim,1,2), & + lb_child(1:nbdim), lb_parent(1:nbdim), & + s_child(1:nbdim), s_parent(1:nbdim), & + ds_child(1:nbdim), ds_parent(1:nbdim), & +#if defined AGRIF_MPI + posvar, do_update, & +#endif + nbdim, procname) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_UpdateWhole +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_UpdateBcnd +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_UpdateBcnd ( parent, child, uinf, usup, & + lb_child, lb_parent, & + nb_child, posvar, & + do_update, & + s_child, s_parent, & + ds_child, ds_parent, nbdim, procname ) +!--------------------------------------------------------------------------------------------------- +#if defined AGRIF_MPI + include 'mpif.h' +#endif +! + type(Agrif_Variable), pointer :: parent !< Variable on the parent grid + type(Agrif_Variable), pointer :: child !< Variable on the child grid + integer, dimension(nbdim), intent(in) :: uinf !< First positions where interpolations are calculated + integer, dimension(nbdim), intent(in) :: usup !< Last positions where interpolations are calculated + integer :: nbdim !< Number of dimensions of the grid variable + integer, dimension(nbdim), intent(in) :: lb_child !< Index of the first point inside the domain for + !! the parent grid variable + integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for + !! the child grid variable + integer, dimension(nbdim), intent(in) :: nb_child !< Number of cells of the child grid + integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) + logical, dimension(nbdim), intent(in) :: do_update !< Indicates if we update for each dimension + real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid + real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid + real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid + real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid + procedure() :: procname !< Data recovery procedure +! + integer,dimension(nbdim) :: type_update ! Type of update (copy or average) + integer,dimension(nbdim,2) :: lubglob + integer :: i + integer,dimension(nbdim,2,2) :: indtab ! Arrays indicating the limits of the child + integer,dimension(nbdim,2,2) :: indtruetab ! grid variable where boundary conditions are + integer,dimension(nbdim,2,2,nbdim) :: ptres ! calculated + integer :: nb, ndir + integer :: coeffraf +! + type_update = child % root_var % type_update(1:nbdim) +! + DO i = 1, nbdim + coeffraf = nint(ds_parent(i)/ds_child(i)) + indtab(i,1,1) = lb_child(i) + (uinf(i) + 1) * coeffraf + indtab(i,1,2) = lb_child(i) + (usup(i) + 1) * coeffraf + + indtab(i,2,1) = lb_child(i) + nb_child(i) - (usup(i)+1) * coeffraf + indtab(i,2,2) = lb_child(i) + nb_child(i) - (uinf(i)+1) * coeffraf + + IF (posvar(i) == 1) THEN + IF (type_update(i) == Agrif_Update_Full_Weighting) THEN + indtab(i,:,1) = indtab(i,:,1) - (coeffraf - 1) + indtab(i,:,2) = indtab(i,:,2) + (coeffraf - 1) + ELSE IF (type_update(i) /= Agrif_Update_Copy) THEN + indtab(i,:,1) = indtab(i,:,1) - coeffraf / 2 + indtab(i,:,2) = indtab(i,:,2) + coeffraf / 2 + ENDIF + ELSE + indtab(i,1,1) = indtab(i,1,1) - coeffraf + indtab(i,1,2) = indtab(i,1,2) - 1 + indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1 + IF (type_update(i) == Agrif_Update_Full_Weighting) THEN + indtab(i,1,1) = indtab(i,1,1) - coeffraf/2 + indtab(i,1,2) = indtab(i,1,2) + coeffraf/2 + indtab(i,2,1) = indtab(i,2,1) - coeffraf/2 + indtab(i,2,2) = indtab(i,2,2) + coeffraf/2 + ENDIF + ENDIF + ENDDO +! + call Agrif_get_var_global_bounds(child,lubglob,nbdim) +! + indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),lubglob(1:nbdim,1)) + indtruetab(1:nbdim,1,2) = max(indtab(1:nbdim,1,2),lubglob(1:nbdim,1)) + indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1),lubglob(1:nbdim,2)) + indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2),lubglob(1:nbdim,2)) +! + do nb = 1,nbdim + if ( do_update(nb) ) then + do ndir = 1,2 + ptres(nb,1,ndir,nb) = indtruetab(nb,ndir,1) + ptres(nb,2,ndir,nb) = indtruetab(nb,ndir,2) + do i = 1,nbdim + if ( i /= nb ) then + if ( do_update(i) ) then + ptres(i,1,ndir,nb) = indtruetab(i,1,1) + ptres(i,2,ndir,nb) = indtruetab(i,2,2) + else + if (posvar(i) == 1) then + ptres(i,1,ndir,nb) = lb_child(i) + ptres(i,2,ndir,nb) = lb_child(i) + nb_child(i) + else + ptres(i,1,ndir,nb) = lb_child(i) + ptres(i,2,ndir,nb) = lb_child(i) + nb_child(i) - 1 + endif + endif + endif + enddo + enddo + endif + enddo +! + do nb = 1,nbdim + if ( do_update(nb) ) then + do ndir = 1,2 + call Agrif_UpdatenD(type_update, parent, child, & + ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb), & + lb_child(1:nbdim),lb_parent(1:nbdim), & + s_child(1:nbdim),s_parent(1:nbdim), & + ds_child(1:nbdim),ds_parent(1:nbdim), & +#if defined AGRIF_MPI + posvar,do_update, & +#endif + nbdim,procname,nb,ndir) + enddo + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_UpdateBcnd +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_UpdatenD +! +!> updates a 2D grid variable on the parent grid of the current grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_UpdatenD ( type_update, parent, child, & + pttab, petab, & + lb_child, lb_parent, & + s_child, s_parent, & + ds_child, ds_parent, & +#if defined AGRIF_MPI + posvar, do_update, & +#endif + nbdim, procname, nb, ndir ) +!--------------------------------------------------------------------------------------------------- +#if defined AGRIF_MPI + include 'mpif.h' +#endif +! + integer, dimension(6), intent(in) :: type_update !< Type of update (copy or average) + type(Agrif_Variable), pointer :: parent !< Variable of the parent grid + type(Agrif_Variable), pointer :: child !< Variable of the child grid + integer, intent(in) :: nbdim + integer, dimension(nbdim), intent(in) :: pttab !< Index of the first point inside the domain + integer, dimension(nbdim), intent(in) :: petab !< Index of the first point inside the domain + integer, dimension(nbdim), intent(in) :: lb_child !< Index of the first point inside the domain for the child + !! grid variable + integer, dimension(nbdim), intent(in) :: lb_parent !< Index of the first point inside the domain for the parent + !! grid variable + real, dimension(nbdim), intent(in) :: s_child !< Positions of the child grid + real, dimension(nbdim), intent(in) :: s_parent !< Positions of the parent grid + real, dimension(nbdim), intent(in) :: ds_child !< Space steps of the child grid + real, dimension(nbdim), intent(in) :: ds_parent !< Space steps of the parent grid + procedure() :: procname !< Data recovery procedure + integer, optional, intent(in) :: nb, ndir +!--------------------------------------------------------------------------------------------------- + integer, dimension(nbdim) :: pttruetab, cetruetab +#if defined AGRIF_MPI + integer, dimension(nbdim) :: posvar !< Position of the variable on the cell (1 or 2) + logical, dimension(nbdim) :: do_update +#endif + integer, dimension(nbdim) :: coords + integer, dimension(nbdim) :: indmin, indmax + integer, dimension(nbdim) :: indminglob, indmaxglob + real , dimension(nbdim) :: s_Child_temp, s_Parent_temp + integer, dimension(nbdim) :: lowerbound,upperbound + integer, dimension(nbdim) :: pttruetabwhole, cetruetabwhole + integer, dimension(nbdim,2,2) :: childarray + integer, dimension(nbdim,2,2) :: parentarray + integer,dimension(nbdim) :: type_update_temp + logical :: memberin, member + integer :: nbin, ndirin +! +#if defined AGRIF_MPI +! + integer,dimension(nbdim) :: indminglob2,indmaxglob2 + logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1 + logical, dimension(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2 + integer :: code, local_proc + integer :: i,j,k + integer, dimension(nbdim,4) :: tab3 + integer, dimension(nbdim,4,0:Agrif_Nbprocs-1) :: tab4 + integer, dimension(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t + integer, dimension(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t + logical :: find_list_update + logical, dimension(0:Agrif_Nbprocs-1) :: memberinall, memberinall2 + logical, dimension(1) :: memberin1 +! +#endif +! + type(Agrif_Variable), pointer, save :: tempC => NULL() ! Temporary child grid variable + type(Agrif_Variable), pointer, save :: tempP => NULL() ! Temporary parent grid variable + type(Agrif_Variable), pointer, save :: tempCextend => NULL() ! Temporary child + type(Agrif_Variable), pointer, save :: tempPextend => NULL() ! Temporary parent + type(Agrif_Variable), pointer :: tempP_indic, tempP_average + type(Agrif_Variable), pointer :: tempC_indic + logical :: compute_average + real :: coeff_multi + integer :: nb_dimensions +! +! Get local lower and upper bound of the child variable + call Agrif_get_var_bounds_array(child, lowerbound, upperbound, nbdim) + +! here pttab and petab corresponds to the (global) indices of the points needed in the update +! pttruetab and cetruetab contains only indices that are present on the local processor +! + coords = child % root_var % coords +! + call Agrif_Childbounds( nbdim, lowerbound, upperbound, pttab, petab, Agrif_Procrank, & + coords, pttruetab, cetruetab, memberin ) + call Agrif_Prtbounds( nbdim, indminglob, indmaxglob, s_Parent_temp, s_Child_temp, & + s_child, ds_child, s_parent, ds_parent, & + pttab, petab, lb_child, lb_parent & +#if defined AGRIF_MPI + , posvar, type_update, do_update, pttruetabwhole, cetruetabwhole & +#endif + ) + +#if defined AGRIF_MPI +! + IF (memberin) THEN + call Agrif_GlobalToLocalBounds(childarray,lowerbound,upperbound, & + pttruetab,cetruetab, coords, & + nbdim, Agrif_Procrank, member) + ENDIF + + call Agrif_Prtbounds(nbdim, indmin, indmax, & + s_Parent_temp, s_Child_temp, & + s_child, ds_child, s_parent, ds_parent, & + pttruetab, cetruetab, lb_child, lb_parent, & + posvar, type_update, do_update, & + pttruetabwhole, cetruetabwhole) +! +#else + indmin = indminglob + indmax = indmaxglob + pttruetabwhole = pttruetab + cetruetabwhole = cetruetab + childarray(:,1,2) = pttruetab + childarray(:,2,2) = cetruetab +#endif + + IF (.not.present(nb)) THEN + nbin=0 + ndirin=0 + ELSE + nbin = nb + ndirin = ndir + ENDIF + + IF (memberin) THEN +! + IF ( .not.associated(tempC) ) allocate(tempC) +! + call Agrif_array_allocate(tempC,pttruetab,cetruetab,nbdim) + call Agrif_var_set_array_tozero(tempC,nbdim) + + SELECT CASE (nbdim) + CASE(1) + CALL procname(tempC%array1, & + childarray(1,1,2),childarray(1,2,2),.TRUE.,nbin,ndirin) + CASE(2) + CALL procname(tempC%array2, & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2),.TRUE.,nbin,ndirin) + CASE(3) + CALL procname(tempC%array3, & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2),.TRUE.,nbin,ndirin) + CASE(4) + CALL procname(tempC%array4, & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2),.TRUE.,nbin,ndirin) + CASE(5) + CALL procname(tempC%array5, & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2), & + childarray(5,1,2),childarray(5,2,2),.TRUE.,nbin,ndirin) + CASE(6) + CALL procname(tempC%array6, & + childarray(1,1,2),childarray(1,2,2), & + childarray(2,1,2),childarray(2,2,2), & + childarray(3,1,2),childarray(3,2,2), & + childarray(4,1,2),childarray(4,2,2), & + childarray(5,1,2),childarray(5,2,2), & + childarray(6,1,2),childarray(6,2,2),.TRUE.,nbin,ndirin) + END SELECT +! + ENDIF +! +#if defined AGRIF_MPI +! +! tab2 contains the necessary limits of the parent grid for each processor + + if (Associated(child%list_update)) then + call Agrif_Find_list_update(child%list_update,pttab,petab, & + lb_child,lb_parent,nbdim, & + find_list_update,tab4t,tab5t,memberinall,memberinall2, & + sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2) + else + find_list_update = .FALSE. + endif + + if (.not.find_list_update) then + tab3(:,1) = pttruetab(:) + tab3(:,2) = cetruetab(:) + tab3(:,3) = pttruetabwhole(:) + tab3(:,4) = cetruetabwhole(:) +! + call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) + + if ( .not.associated(tempCextend) ) allocate(tempCextend) + do k=0,Agrif_Nbprocs-1 + do j=1,4 + do i=1,nbdim + tab4t(i,k,j) = tab4(i,j,k) + enddo + enddo + enddo + + memberin1(1) = memberin + call MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,1,MPI_LOGICAL,Agrif_mpi_comm,code) + + call Get_External_Data_first(tab4t(:,:,1),tab4t(:,:,2),tab4t(:,:,3),tab4t(:,:,4), & + nbdim, memberinall, coords, & + sendtoproc1,recvfromproc1, & + tab4t(:,:,5),tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8)) + endif + + call ExchangeSameLevel(sendtoproc1,recvfromproc1,nbdim, & + tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6), & + tab4t(:,:,7),tab4t(:,:,8),memberin,tempC,tempCextend) + +#else + tempCextend => tempC +#endif +! +! Update of the parent grid (tempP) from the child grid (tempC) +! + IF (memberin) THEN +! + IF ( .not.associated(tempP) ) allocate(tempP) +! + call Agrif_array_allocate(tempP,indmin,indmax,nbdim) +! + if ( nbdim == 1 ) then + tempP % array1 = 0. + call Agrif_Update_1D_Recursive( type_update(1), & + tempP%array1, & + tempCextend%array1, & + indmin(1), indmax(1), & + pttruetabwhole(1), cetruetabwhole(1), & + s_Child_temp(1), s_Parent_temp(1), & + ds_child(1), ds_parent(1) ) + + IF (Agrif_UseSpecialValueInUpdate) THEN + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array1),ubound(tempCextend%array1),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array1),ubound(tempP%array1),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update(1:nbdim) == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array1),ubound(tempP%array1),nbdim) + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_1D_Recursive( type_update_temp(1), & + tempP_average%array1, & + tempCextend%array1, & + indmin(1), indmax(1), & + pttruetabwhole(1), cetruetabwhole(1), & + s_Child_temp(1), s_Parent_temp(1), & + ds_child(1), ds_parent(1) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + WHERE (tempCextend%array1 == Agrif_SpecialValueFineGrid) + tempC_indic%array1 = 0. + ELSEWHERE + tempC_indic%array1 = 1. + END WHERE + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_1D_Recursive( type_update_temp(1), & + tempP_indic%array1, & + tempC_indic%array1, & + indmin(1), indmax(1), & + pttruetabwhole(1), cetruetabwhole(1), & + s_Child_temp(1), s_Parent_temp(1), & + ds_child(1), ds_parent(1) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + IF (compute_average) THEN + WHERE (tempP_indic%array1 == 0.) + tempP%array1 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array1 == coeff_multi).AND.(tempP%array1 /= Agrif_SpecialValueFineGrid)) + tempP%array1 = tempP%array1 /tempP_indic%array1 + ELSEWHERE + tempP%array1 = tempP_average%array1 /tempP_indic%array1 + END WHERE + + ELSE + WHERE (tempP_indic%array1 == 0.) + tempP%array1 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array1 = tempP%array1 /tempP_indic%array1 + END WHERE + ENDIF + + deallocate(tempP_indic%array1) + deallocate(tempC_indic%array1) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array1) + deallocate(tempP_average) + ENDIF + ENDIF + + endif + if ( nbdim == 2 ) then + call Agrif_Update_2D_Recursive( type_update(1:2), & + tempP%array2, & + tempCextend%array2, & + indmin(1:2), indmax(1:2), & + pttruetabwhole(1:2), cetruetabwhole(1:2), & + s_Child_temp(1:2), s_Parent_temp(1:2), & + ds_child(1:2), ds_parent(1:2) ) + + IF (Agrif_UseSpecialValueInUpdate) THEN + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array2),ubound(tempCextend%array2),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array2),ubound(tempP%array2),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array2),ubound(tempP%array2),nbdim) + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_2D_Recursive( type_update_temp(1:2), & + tempP_average%array2, & + tempCextend%array2, & + indmin(1:2), indmax(1:2), & + pttruetabwhole(1:2), cetruetabwhole(1:2), & + s_Child_temp(1:2), s_Parent_temp(1:2), & + ds_child(1:2), ds_parent(1:2) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + WHERE (tempCextend%array2 == Agrif_SpecialValueFineGrid) + tempC_indic%array2 = 0. + ELSEWHERE + tempC_indic%array2 = 1. + END WHERE + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_2D_Recursive( type_update_temp(1:2), & + tempP_indic%array2, & + tempC_indic%array2, & + indmin(1:2), indmax(1:2), & + pttruetabwhole(1:2), cetruetabwhole(1:2), & + s_Child_temp(1:2), s_Parent_temp(1:2), & + ds_child(1:2), ds_parent(1:2) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + IF (compute_average) THEN + WHERE (tempP_indic%array2 == 0.) + tempP%array2 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array2 == coeff_multi).AND.(tempP%array2 /= Agrif_SpecialValueFineGrid)) + tempP%array2 = tempP%array2 /tempP_indic%array2 + ELSEWHERE + tempP%array2 = tempP_average%array2 /tempP_indic%array2 + END WHERE + + ELSE + WHERE (tempP_indic%array2 == 0.) + tempP%array2 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array2 = tempP%array2 /tempP_indic%array2 + END WHERE + ENDIF + + deallocate(tempP_indic%array2) + deallocate(tempC_indic%array2) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array2) + deallocate(tempP_average) + ENDIF + ENDIF + + endif + if ( nbdim == 3 ) then + call Agrif_Update_3D_Recursive( type_update(1:3), & + tempP%array3, & + tempCextend%array3, & + indmin(1:3), indmax(1:3), & + pttruetabwhole(1:3), cetruetabwhole(1:3), & + s_Child_temp(1:3), s_Parent_temp(1:3), & + ds_child(1:3), ds_parent(1:3) ) + + IF (Agrif_UseSpecialValueInUpdate) THEN + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array3),ubound(tempCextend%array3),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array3),ubound(tempP%array3),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array3),ubound(tempP%array3),nbdim) + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_3D_Recursive( type_update_temp(1:3), & + tempP_average%array3, & + tempCextend%array3, & + indmin(1:3), indmax(1:3), & + pttruetabwhole(1:3), cetruetabwhole(1:3), & + s_Child_temp(1:3), s_Parent_temp(1:3), & + ds_child(1:3), ds_parent(1:3) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + WHERE (tempCextend%array3 == Agrif_SpecialValueFineGrid) + tempC_indic%array3 = 0. + ELSEWHERE + tempC_indic%array3 = 1. + END WHERE + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_3D_Recursive( type_update_temp(1:3), & + tempP_indic%array3, & + tempC_indic%array3, & + indmin(1:3), indmax(1:3), & + pttruetabwhole(1:3), cetruetabwhole(1:3), & + s_Child_temp(1:3), s_Parent_temp(1:3), & + ds_child(1:3), ds_parent(1:3) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + IF (compute_average) THEN + WHERE (tempP_indic%array3 == 0.) + tempP%array3 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array3 == coeff_multi).AND.(tempP%array3 /= Agrif_SpecialValueFineGrid)) + tempP%array3 = tempP%array3 /tempP_indic%array3 + ELSEWHERE + tempP%array3 = tempP_average%array3 /tempP_indic%array3 + END WHERE + + ELSE + WHERE (tempP_indic%array3 == 0.) + tempP%array3 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array3 = tempP%array3 /tempP_indic%array3 + END WHERE + ENDIF + + deallocate(tempP_indic%array3) + deallocate(tempC_indic%array3) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array3) + deallocate(tempP_average) + ENDIF + ENDIF + + endif + if ( nbdim == 4 ) then + call Agrif_Update_4D_Recursive( type_update(1:4), & + tempP%array4, & + tempCextend%array4, & + indmin(1:4), indmax(1:4), & + pttruetabwhole(1:4), cetruetabwhole(1:4), & + s_Child_temp(1:4), s_Parent_temp(1:4), & + ds_child(1:4), ds_parent(1:4) ) + + IF (Agrif_UseSpecialValueInUpdate) THEN + + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array4),ubound(tempCextend%array4),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array4),ubound(tempP%array4),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array4),ubound(tempP%array4),nbdim) + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_4D_Recursive( type_update_temp(1:4), & + tempP_average%array4, & + tempCextend%array4, & + indmin(1:4), indmax(1:4), & + pttruetabwhole(1:4), cetruetabwhole(1:4), & + s_Child_temp(1:4), s_Parent_temp(1:4), & + ds_child(1:4), ds_parent(1:4) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + WHERE (tempCextend%array4 == Agrif_SpecialValueFineGrid) + tempC_indic%array4 = 0. + ELSEWHERE + tempC_indic%array4 = 1. + END WHERE + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_4D_Recursive( type_update_temp(1:4), & + tempP_indic%array4, & + tempC_indic%array4, & + indmin(1:4), indmax(1:4), & + pttruetabwhole(1:4), cetruetabwhole(1:4), & + s_Child_temp(1:4), s_Parent_temp(1:4), & + ds_child(1:4), ds_parent(1:4) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + IF (compute_average) THEN + WHERE (tempP_indic%array4 == 0.) + tempP%array4 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array4 == coeff_multi).AND.(tempP%array4 /= Agrif_SpecialValueFineGrid)) + tempP%array4 = tempP%array4 /tempP_indic%array4 + ELSEWHERE + tempP%array4 = tempP_average%array4 /tempP_indic%array4 + END WHERE + + ELSE + WHERE (tempP_indic%array4 == 0.) + tempP%array4 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array4 = tempP%array4 /tempP_indic%array4 + END WHERE + ENDIF + deallocate(tempP_indic%array4) + deallocate(tempC_indic%array4) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array4) + deallocate(tempP_average) + ENDIF + ENDIF + + endif + if ( nbdim == 5 ) then + call Agrif_Update_5D_Recursive( type_update(1:5), & + tempP%array5, & + tempCextend%array5, & + indmin(1:5), indmax(1:5), & + pttruetabwhole(1:5), cetruetabwhole(1:5), & + s_Child_temp(1:5), s_Parent_temp(1:5), & + ds_child(1:5), ds_parent(1:5) ) + + IF (Agrif_UseSpecialValueInUpdate) THEN + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array5),ubound(tempCextend%array5),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array5),ubound(tempP%array5),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array5),ubound(tempP%array5),nbdim) + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_5D_Recursive( type_update_temp(1:5), & + tempP_average%array5, & + tempCextend%array5, & + indmin(1:5), indmax(1:5), & + pttruetabwhole(1:5), cetruetabwhole(1:5), & + s_Child_temp(1:5), s_Parent_temp(1:5), & + ds_child(1:5), ds_parent(1:5) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + WHERE (tempCextend%array5 == Agrif_SpecialValueFineGrid) + tempC_indic%array5 = 0. + ELSEWHERE + tempC_indic%array5 = 1. + END WHERE + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_5D_Recursive( type_update_temp(1:5), & + tempP_indic%array5, & + tempC_indic%array5, & + indmin(1:5), indmax(1:5), & + pttruetabwhole(1:5), cetruetabwhole(1:5), & + s_Child_temp(1:5), s_Parent_temp(1:5), & + ds_child(1:5), ds_parent(1:5) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + IF (compute_average) THEN + WHERE (tempP_indic%array5 == 0.) + tempP%array5 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array5 == coeff_multi).AND.(tempP%array5 /= Agrif_SpecialValueFineGrid)) + tempP%array5 = tempP%array5 /tempP_indic%array5 + ELSEWHERE + tempP%array5 = tempP_average%array5 /tempP_indic%array5 + END WHERE + + ELSE + WHERE (tempP_indic%array5 == 0.) + tempP%array5 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array5 = tempP%array5 /tempP_indic%array5 + END WHERE + ENDIF + + deallocate(tempP_indic%array5) + deallocate(tempC_indic%array5) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array5) + deallocate(tempP_average) + ENDIF + ENDIF + + endif + if ( nbdim == 6 ) then + call Agrif_Update_6D_Recursive( type_update(1:6), & + tempP%array6, & + tempCextend%array6, & + indmin(1:6), indmax(1:6), & + pttruetabwhole(1:6), cetruetabwhole(1:6), & + s_Child_temp(1:6), s_Parent_temp(1:6), & + ds_child(1:6), ds_parent(1:6) ) + IF (Agrif_UseSpecialValueInUpdate) THEN + allocate(tempC_indic) + allocate(tempP_indic) + call Agrif_array_allocate(tempC_indic,lbound(tempCextend%array6),ubound(tempCextend%array6),nbdim) + call Agrif_array_allocate(tempP_indic,lbound(tempP%array6),ubound(tempP%array6),nbdim) + + compute_average = .FALSE. + type_update_temp(1:nbdim) = type_update(1:nbdim) + IF (ANY(type_update == Agrif_Update_Full_Weighting)) THEN + compute_average = .TRUE. + allocate(tempP_average) + call Agrif_array_allocate(tempP_average,lbound(tempP%array6),ubound(tempP%array6),nbdim) + type_update_temp(1:nbdim) = type_update + WHERE (type_update(1:nbdim) == Agrif_Update_Full_Weighting) + type_update_temp(1:nbdim) = Agrif_Update_Average + END WHERE + call Agrif_Update_6D_Recursive( type_update_temp(1:6), & + tempP_average%array6, & + tempCextend%array6, & + indmin(1:6), indmax(1:6), & + pttruetabwhole(1:6), cetruetabwhole(1:6), & + s_Child_temp(1:6), s_Parent_temp(1:6), & + ds_child(1:6), ds_parent(1:6) ) + coeff_multi = 1. + do nb_dimensions=1,nbdim + coeff_multi = coeff_multi * nint(ds_parent(nb_dimensions)/ds_child(nb_dimensions)) + enddo + ENDIF + + IF (compute_average) THEN + WHERE (tempP_indic%array6 == 0.) + tempP%array6 = Agrif_SpecialValueFineGrid + ELSEWHERE ((tempP_indic%array6 == coeff_multi).AND.(tempP%array6 /= Agrif_SpecialValueFineGrid)) + tempP%array6 = tempP%array6 /tempP_indic%array6 + ELSEWHERE + tempP%array6 = tempP_average%array6 /tempP_indic%array6 + END WHERE + + ELSE + WHERE (tempP_indic%array6 == 0.) + tempP%array6 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array6 = tempP%array6 /tempP_indic%array6 + END WHERE + ENDIF + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_Update_Weights = .TRUE. + + call Agrif_Update_6D_Recursive( type_update_temp(1:6), & + tempP_indic%array6, & + tempC_indic%array6, & + indmin(1:6), indmax(1:6), & + pttruetabwhole(1:6), cetruetabwhole(1:6), & + s_Child_temp(1:6), s_Parent_temp(1:6), & + ds_child(1:6), ds_parent(1:6) ) + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_Update_Weights = .FALSE. + + WHERE (tempP_indic%array6 == 0.) + tempP%array6 = Agrif_SpecialValueFineGrid + ELSEWHERE + tempP%array6 = tempP%array6 /tempP_indic%array6 + END WHERE + + deallocate(tempP_indic%array6) + deallocate(tempC_indic%array6) + deallocate(tempC_indic) + deallocate(tempP_indic) + IF (compute_average) THEN + deallocate(tempP_average%array6) + deallocate(tempP_average) + ENDIF + ENDIF + endif +! + call Agrif_array_deallocate(tempCextend,nbdim) +! + ENDIF + +#if defined AGRIF_MPI + local_proc = Agrif_Procrank + call Agrif_get_var_bounds_array(parent,lowerbound,upperbound,nbdim) + call Agrif_ChildGrid_to_ParentGrid() + call Agrif_Childbounds(nbdim, lowerbound, upperbound, & + indminglob, indmaxglob, local_proc, coords, & + indminglob2, indmaxglob2, member) +! + IF (member) THEN + call Agrif_GlobalToLocalBounds(parentarray, lowerbound, upperbound, & + indminglob2, indmaxglob2, coords, & + nbdim, local_proc, member) + ENDIF + + call Agrif_ParentGrid_to_ChildGrid() + + if (.not.find_list_update) then + tab3(:,1) = indmin(:) + tab3(:,2) = indmax(:) + tab3(:,3) = indminglob2(:) + tab3(:,4) = indmaxglob2(:) +! + call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,MPI_INTEGER,Agrif_mpi_comm,code) + + IF ( .not.associated(tempPextend) ) allocate(tempPextend) + DO k=0,Agrif_Nbprocs-1 + do j=1,4 + do i=1,nbdim + tab5t(i,k,j) = tab4(i,j,k) + enddo + enddo + enddo + + memberin1(1) = member + call MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2,1,MPI_LOGICAL,Agrif_mpi_comm,code) + call Get_External_Data_first(tab5t(:,:,1),tab5t(:,:,2),tab5t(:,:,3),tab5t(:,:,4), & + nbdim, memberinall2, coords, & + sendtoproc2, recvfromproc2, & + tab5t(:,:,5),tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8)) + + call Agrif_Addto_list_update(child%list_update,pttab,petab,lb_child,lb_parent, & + nbdim,tab4t,tab5t,memberinall,memberinall2, & + sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2) + + endif + + call ExchangeSameLevel(sendtoproc2,recvfromproc2,nbdim, & + tab5t(:,:,3),tab5t(:,:,4),tab5t(:,:,5),tab5t(:,:,6),& + tab5t(:,:,7),tab5t(:,:,8),member,tempP,tempPextend) +#else + tempPextend => tempP + parentarray(:,1,1) = indmin + parentarray(:,2,1) = indmax + parentarray(:,1,2) = indmin + parentarray(:,2,2) = indmax + member = .TRUE. +#endif +! +! Special values on the child grid + if ( Agrif_UseSpecialValueFineGrid ) then +! +!cc noraftab(1:nbdim) = +!cc & child % root_var % interptab(1:nbdim) == 'N' +! +#if defined AGRIF_MPI +! +! allocate(childvalues% var) +! +! Call Agrif_array_allocate(childvalues%var, +! & pttruetab,cetruetab,nbdim) +! Call Agrif_var_full_copy_array(childvalues% var, +! & tempC, +! & nbdim) +! Call Agrif_CheckMasknD(tempC,childvalues, +! & pttruetab(1:nbdim),cetruetab(1:nbdim), +! & pttruetab(1:nbdim),cetruetab(1:nbdim), +! & noraftab(1:nbdim),nbdim) +! Call Agrif_array_deallocate(childvalues% var,nbdim) +! Deallocate(childvalues % var) +! +#else +! +! Call Agrif_get_var_bounds_array(child, +! & lowerbound,upperbound,nbdim) +! Call Agrif_CheckMasknD(tempC,child, +! & pttruetab(1:nbdim),cetruetab(1:nbdim), +! & lowerbound, +! & upperbound, +! & noraftab(1:nbdim),nbdim) +! +#endif +! + endif +! +! Special values on the parent grid + if (Agrif_UseSpecialValue) then +! +#if defined AGRIF_MPI +! +! Call GiveAgrif_SpecialValueToTab_mpi(parent,tempP, +! & parentarray, +! & Agrif_SpecialValue,nbdim) +! +! +#else +! +! Call GiveAgrif_SpecialValueToTab(parent,tempP, +! & indmin,indmax, +! & Agrif_SpecialValue,nbdim) +! +#endif +! + endif +! + IF (member) THEN + + call Agrif_ChildGrid_to_ParentGrid() +! + SELECT CASE(nbdim) + CASE(1) + call procname( tempPextend % array1( & + parentarray(1,1,1):parentarray(1,2,1)), & + parentarray(1,1,2),parentarray(1,2,2),.FALSE.,nbin,ndirin) + CASE(2) + call procname( tempPextend % array2( & + parentarray(1,1,1):parentarray(1,2,1), & + parentarray(2,1,1):parentarray(2,2,1)), & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2),.FALSE.,nbin,ndirin) + CASE(3) + call procname( tempPextend % array3( & + parentarray(1,1,1):parentarray(1,2,1), & + parentarray(2,1,1):parentarray(2,2,1), & + parentarray(3,1,1):parentarray(3,2,1)), & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2),.FALSE.,nbin,ndirin) + CASE(4) + call procname( tempPextend % array4( & + parentarray(1,1,1):parentarray(1,2,1), & + parentarray(2,1,1):parentarray(2,2,1), & + parentarray(3,1,1):parentarray(3,2,1), & + parentarray(4,1,1):parentarray(4,2,1)), & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2),.FALSE.,nbin,ndirin) + CASE(5) + call procname( tempPextend % array5( & + parentarray(1,1,1):parentarray(1,2,1), & + parentarray(2,1,1):parentarray(2,2,1), & + parentarray(3,1,1):parentarray(3,2,1), & + parentarray(4,1,1):parentarray(4,2,1), & + parentarray(5,1,1):parentarray(5,2,1)), & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2), & + parentarray(5,1,2),parentarray(5,2,2),.FALSE.,nbin,ndirin) + CASE(6) + call procname( tempPextend % array6( & + parentarray(1,1,1):parentarray(1,2,1), & + parentarray(2,1,1):parentarray(2,2,1), & + parentarray(3,1,1):parentarray(3,2,1), & + parentarray(4,1,1):parentarray(4,2,1), & + parentarray(5,1,1):parentarray(5,2,1), & + parentarray(6,1,1):parentarray(6,2,1)), & + parentarray(1,1,2),parentarray(1,2,2), & + parentarray(2,1,2),parentarray(2,2,2), & + parentarray(3,1,2),parentarray(3,2,2), & + parentarray(4,1,2),parentarray(4,2,2), & + parentarray(5,1,2),parentarray(5,2,2), & + parentarray(6,1,2),parentarray(6,2,2),.FALSE.,nbin,ndirin) + END SELECT +! + call Agrif_ParentGrid_to_ChildGrid() +! + call Agrif_array_deallocate(tempPextend,nbdim) +! + ENDIF +! +#if defined AGRIF_MPI + IF (memberin) THEN + call Agrif_array_deallocate(tempP,nbdim) + call Agrif_array_deallocate(tempC,nbdim) + ENDIF +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_UpdatenD +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Prtbounds +! +!> calculates the bounds of the parent grid to be updated by the child grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Prtbounds ( nbdim, indmin, indmax, s_Parent_temp, s_Child_temp, & + s_child, ds_child, s_parent, ds_parent, & + pttruetab, cetruetab, lb_child, lb_parent & +#if defined AGRIF_MPI + ,posvar, type_update, do_update, & + pttruetabwhole, cetruetabwhole & +#endif + ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: nbdim + integer, dimension(nbdim), intent(out) :: indmin, indmax + real, dimension(nbdim), intent(out) :: s_Parent_temp, s_Child_temp + real, dimension(nbdim), intent(in) :: s_child, ds_child + real, dimension(nbdim), intent(in) :: s_parent, ds_parent + integer, dimension(nbdim), intent(in) :: pttruetab, cetruetab + integer, dimension(nbdim), intent(in) :: lb_child, lb_parent +#if defined AGRIF_MPI + integer, dimension(nbdim), intent(in) :: posvar !< Position of the variable on the cell (1 or 2) + integer, dimension(nbdim), intent(in) :: type_update + logical, dimension(nbdim), intent(in) :: do_update + integer,dimension(nbdim), intent(out) :: pttruetabwhole, cetruetabwhole +#endif +! + real,dimension(nbdim) :: dim_newmin,dim_newmax + integer :: i +#if defined AGRIF_MPI + real :: positionmin, positionmax + integer :: imin, imax + integer :: coeffraf +#endif +! + do i = 1,nbdim +! + dim_newmin(i) = s_child(i) + (pttruetab(i) - lb_child(i)) * ds_child(i) + dim_newmax(i) = s_child(i) + (cetruetab(i) - lb_child(i)) * ds_child(i) +! + indmin(i) = lb_parent(i) + agrif_ceiling((dim_newmin(i)-s_parent(i))/ds_parent(i)) + indmax(i) = lb_parent(i) + agrif_int( (dim_newmax(i)-s_parent(i))/ds_parent(i)) +! +#if defined AGRIF_MPI + positionmin = s_parent(i) + (indmin(i)-lb_parent(i))*ds_parent(i) + IF ( do_update(i) ) THEN + IF (posvar(i) == 1) THEN + IF (type_update(i) == Agrif_Update_Average) THEN + positionmin = positionmin - ds_parent(i)/2. + ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN + positionmin = positionmin - (ds_parent(i)-ds_child(i)) + ENDIF + ELSE + IF (type_update(i) /= Agrif_Update_Full_Weighting) THEN + positionmin = positionmin - ds_parent(i)/2. + ELSE + coeffraf = nint(ds_parent(i)/ds_child(i)) + if (mod(coeffraf,2) == 1) then + positionmin = positionmin - (ds_parent(i)-ds_child(i)) + else + positionmin = positionmin - (ds_parent(i)-ds_child(i))-ds_child(i)/2. + endif + ENDIF + ENDIF + ENDIF +! + imin = lb_child(i) + agrif_ceiling((positionmin-s_child(i))/ds_child(i)) + positionmin = s_child(i) + (imin - lb_child(i)) * ds_child(i) + positionmax = s_parent(i) + (indmax(i)-lb_parent(i))*ds_parent(i) + pttruetabwhole(i) = imin + + IF ( do_update(i) ) THEN + IF (posvar(i) == 1) THEN + IF (type_update(i) == Agrif_Update_Average) THEN + positionmax = positionmax + ds_parent(i)/2. + ELSE IF (type_update(i) == Agrif_Update_Full_Weighting) THEN + positionmax = positionmax + (ds_parent(i)-ds_child(i)) + ENDIF + ELSE + IF (type_update(i) /= Agrif_Update_Full_Weighting) THEN + positionmax = positionmax + ds_parent(i)/2. + ELSE + coeffraf = nint(ds_parent(i)/ds_child(i)) + if (mod(coeffraf,2) == 1) then + positionmax = positionmax + (ds_parent(i)-ds_child(i)) + else + positionmax = positionmax + (ds_parent(i)-ds_child(i)) + ds_child(i)/2. + endif + ENDIF + ENDIF + ENDIF + + imax = lb_child(i) +agrif_int((positionmax-s_child(i))/ds_child(i)) + positionmax = s_child(i) + (imax - lb_child(i)) * ds_child(i) + cetruetabwhole(i) = imax +#endif +! + s_Parent_temp(i) = s_parent(i) + (indmin(i) - lb_parent(i)) * ds_parent(i) + s_Child_temp(i) = dim_newmin(i) + +#if defined AGRIF_MPI + s_Child_temp(i) = positionmin +#endif +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Prtbounds +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_1D_Recursive +! +!> Updates a 1D grid variable on the parent grid +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_1D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: type_update !< Type of update (copy or average) + integer, intent(in) :: indmin, indmax + integer, intent(in) :: lb_child, ub_child + real, intent(in) :: s_child, s_parent + real, intent(in) :: ds_child, ds_parent + real, dimension(indmin:indmax), intent(out) :: tempP + real, dimension(lb_child:ub_child), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + call Agrif_UpdateBase(type_update, & + tempP(indmin:indmax), & + tempC(lb_child:ub_child), & + indmin, indmax, & + lb_child, ub_child, & + s_parent, s_child, & + ds_parent, ds_child) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_1D_Recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_2D_Recursive +! +!> updates a 2D grid variable on the parent grid. +!! Calls #Agrif_Update_1D_Recursive and #Agrif_UpdateBase +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_2D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(2), intent(in) :: type_update !< Type of update (copy or average) + integer, dimension(2), intent(in) :: indmin, indmax + integer, dimension(2), intent(in) :: lb_child, ub_child + real, dimension(2), intent(in) :: s_child, s_parent + real, dimension(2), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2)), intent(out) :: tempP + real, dimension(:,:), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + real, dimension(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp + real, dimension(indmin(2):indmax(2), indmin(1):indmax(1)) :: tempP_trsp + real, dimension(lb_child(2):ub_child(2), indmin(1):indmax(1)) :: tabtemp_trsp + integer :: i, j + integer :: coeffraf +! + tabtemp = 0. + coeffraf = nint ( ds_parent(1) / ds_child(1) ) +! + IF((type_update(1) == Agrif_Update_Average) .AND. (coeffraf /= 1 )) THEN +!---CDIR NEXPAND + if ( .NOT. precomputedone(1) ) then + call Average1dPrecompute( ub_child(2)-lb_child(2)+1, & + indmax(1)-indmin(1)+1, & + ub_child(1)-lb_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) +! precomputedone(1) = .TRUE. + endif +!---CDIR NEXPAND + call Average1dAfterCompute( tabtemp, tempC, size(tabtemp), size(tempC), & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) +! + ELSE IF ((type_update(1) == Agrif_Update_Copy) .AND. (coeffraf /= 1 ))THEN +!---CDIR NEXPAND + if ( .NOT. precomputedone(1) ) then + call Agrif_basicupdate_copy1d_before( ub_child(2)-lb_child(2)+1, & + indmax(1)-indmin(1)+1, & + ub_child(1)-lb_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) +! precomputedone(1) = .TRUE. + endif +!---CDIR NEXPAND + call Agrif_basicupdate_copy1d_after(tabtemp,tempC,size(tabtemp),size(tempC),1) +! + ELSE + do j = lb_child(2),ub_child(2) +! +!---CDIR NEXPAND + call Agrif_Update_1D_Recursive( type_update(1), & + tabtemp(:,j), & + tempC(:,j-lb_child(2)+1), & + indmin(1), indmax(1), & + lb_child(1),ub_child(1), & + s_child(1), s_parent(1), & + ds_child(1),ds_parent(1)) + enddo + ENDIF +! + tabtemp_trsp = TRANSPOSE(tabtemp) + coeffraf = nint(ds_parent(2)/ds_child(2)) +! + tempP_trsp = 0. +! + IF((type_update(2) == Agrif_Update_Average) .AND. (coeffraf /= 1 )) THEN +!---CDIR NEXPAND + if ( .NOT. precomputedone(2) ) then + call Average1dPrecompute( indmax(1)-indmin(1)+1, & + indmax(2)-indmin(2)+1, & + ub_child(2)-lb_child(2)+1,& + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) +! precomputedone(2) = .TRUE. + endif +!---CDIR NEXPAND + call Average1dAfterCompute( tempP_trsp, tabtemp_trsp, size(tempP_trsp), size(tabtemp_trsp),& + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) +! + ELSE IF ((type_update(2) == Agrif_Update_Copy) .AND. (coeffraf /= 1 )) THEN +!---CDIR NEXPAND + if ( .NOT. precomputedone(2) ) then + call Agrif_basicupdate_copy1d_before( indmax(1)-indmin(1)+1, & + indmax(2)-indmin(2)+1, & + ub_child(2)-lb_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) +! precomputedone(2) = .TRUE. + endif +!---CDIR NEXPAND + call Agrif_basicupdate_copy1d_after( tempP_trsp, tabtemp_trsp, size(tempP_trsp), size(tabtemp_trsp),2) +! + ELSE + do i = indmin(1),indmax(1) +! +!---CDIR NEXPAND + call Agrif_UpdateBase(type_update(2), & + tempP_trsp(indmin(2):indmax(2),i), & + tabtemp_trsp(lb_child(2):ub_child(2),i),& + indmin(2),indmax(2), & + lb_child(2),ub_child(2), & + s_parent(2),s_child(2), & + ds_parent(2),ds_child(2)) +! + enddo + ENDIF +! + tempP = TRANSPOSE(tempP_trsp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_2D_Recursive +!=================================================================================================== +! +subroutine Agrif_Update_2D_Recursive_ok ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + INTEGER, DIMENSION(2), intent(in) :: type_update !< Type of update (copy or average) + INTEGER, DIMENSION(2), intent(in) :: indmin, indmax + INTEGER, DIMENSION(2), intent(in) :: lb_child, ub_child + REAL, DIMENSION(2), intent(in) :: s_child, s_parent + REAL, DIMENSION(2), intent(in) :: ds_child, ds_parent + REAL, DIMENSION( & + indmin(1):indmax(1), & + indmin(2):indmax(2)), intent(out) :: tempP + REAL, DIMENSION( & + lb_child(1):ub_child(1), & + lb_child(2):ub_child(2)), intent(in) :: tempC +! + REAL, DIMENSION(indmin(1):indmax(1), lb_child(2):ub_child(2)) :: tabtemp + INTEGER :: i +! + do i = lb_child(2),ub_child(2) + call Agrif_Update_1D_Recursive(type_update(1), & + tabtemp(:, i), & + tempC(:,i), & + indmin(1),indmax(1), & + lb_child(1),ub_child(1), & + s_child(1), s_parent(1), & + ds_child(1),ds_parent(1)) + enddo +! + tempP = 0. +! + do i = indmin(1),indmax(1) + call Agrif_UpdateBase(type_update(2), & + tempP(i,:), & + tabtemp(i,:), & + indmin(2),indmax(2), & + lb_child(2),ub_child(2), & + s_parent(2),s_child(2), & + ds_parent(2),ds_child(2)) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_2D_Recursive_ok +!=================================================================================================== + +! +!=================================================================================================== +! subroutine Agrif_Update_3D_Recursive +! +!> Updates a 3D grid variable on the parent grid. +!! Calls #Agrif_Update_2D_Recursive and #Agrif_UpdateBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_3D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(3), intent(in) :: type_update !< Type of update (copy or average) + integer, dimension(3), intent(in) :: indmin, indmax + integer, dimension(3), intent(in) :: lb_child, ub_child + real, dimension(3), intent(in) :: s_child, s_parent + real, dimension(3), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3)), intent(out) :: tempP + real, dimension( & + lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3)), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + lb_child(3):ub_child(3)) :: tabtemp + integer :: i,j,k + integer :: coeffraf,locind_child_left + integer :: kuinf +! + coeffraf = nint ( ds_parent(1) / ds_child(1) ) +! + if ((type_update(1) == Agrif_Update_Average) .AND. (coeffraf /= 1 )) then +!---CDIR NEXPAND + call Average1dPrecompute(ub_child(2)-lb_child(2)+1,& + indmax(1)-indmin(1)+1,& + ub_child(1)-lb_child(1)+1,& + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) + precomputedone(1) = .TRUE. + else if ((type_update(1) == Agrif_Update_Copy) .AND. (coeffraf /= 1 )) then +!---CDIR NEXPAND + call Agrif_basicupdate_copy1d_before(ub_child(2)-lb_child(2)+1, & + indmax(1)-indmin(1)+1, & + ub_child(1)-lb_child(1)+1, & + s_parent(1),s_child(1),ds_parent(1),ds_child(1),1) + precomputedone(1) = .TRUE. + endif +! + coeffraf = nint ( ds_parent(2) / ds_child(2) ) +! + if ((type_update(2) == Agrif_Update_Average) .AND. (coeffraf /= 1 )) then +!---CDIR NEXPAND + call Average1dPrecompute(indmax(1)-indmin(1)+1,& + indmax(2)-indmin(2)+1,& + ub_child(2)-lb_child(2)+1,& + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) + precomputedone(2) = .TRUE. + else if ((type_update(2) == Agrif_Update_Copy) .AND. (coeffraf /= 1 )) then +!---CDIR NEXPAND + call Agrif_basicupdate_copy1d_before( indmax(1)-indmin(1)+1, & + indmax(2)-indmin(2)+1, & + ub_child(2)-lb_child(2)+1, & + s_parent(2),s_child(2),ds_parent(2),ds_child(2),2) + precomputedone(2) = .TRUE. + endif +! + do k = lb_child(3),ub_child(3) + call Agrif_Update_2D_Recursive( type_update(1:2),tabtemp(:,:,k),tempC(:,:,k), & + indmin(1:2),indmax(1:2), & + lb_child(1:2),ub_child(1:2), & + s_child(1:2),s_parent(1:2), & + ds_child(1:2),ds_parent(1:2) ) + enddo +! + precomputedone(1) = .FALSE. + precomputedone(2) = .FALSE. +! + coeffraf = nint ( ds_parent(3) / ds_child(3) ) + locind_child_left = 1 + agrif_int((s_parent(3)-s_child(3))/ds_child(3)) +! + if (coeffraf == 1) then + kuinf = lb_child(3)+locind_child_left-2 + do k=indmin(3),indmax(3) + kuinf = kuinf + 1 + do j = indmin(2),indmax(2) + do i = indmin(1),indmax(1) + tempP(i,j,k) = tabtemp(i,j,kuinf) + enddo + enddo + enddo + else + tempP = 0. + do j = indmin(2),indmax(2) + do i = indmin(1),indmax(1) + call Agrif_UpdateBase(type_update(3),tempP(i,j,:),tabtemp(i,j,:), & + indmin(3),indmax(3), & + lb_child(3),ub_child(3), & + s_parent(3),s_child(3), & + ds_parent(3),ds_child(3)) +! + enddo + enddo + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_3D_Recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_4D_Recursive +! +!> Updates a 4D grid variable on the parent grid. +!! Calls #Agrif_Update_3D_Recursive and #Agrif_UpdateBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_4D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(4), intent(in) :: type_update !< Type of update (copy or average) + integer, dimension(4), intent(in) :: indmin, indmax + integer, dimension(4), intent(in) :: lb_child, ub_child + real, dimension(4), intent(in) :: s_child, s_parent + real, dimension(4), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4)), intent(out) :: tempP + real, dimension( & + lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), & + lb_child(4):ub_child(4)), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:,:,:), allocatable :: tabtemp + integer :: i,j,k,l +! + allocate(tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + lb_child(4):ub_child(4))) +! + do l = lb_child(4), ub_child(4) + call Agrif_Update_3D_Recursive(type_update(1:3), & + tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), l), & + tempC(lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), l), & + indmin(1:3), indmax(1:3), & + lb_child(1:3), ub_child(1:3), & + s_child(1:3), s_parent(1:3), & + ds_child(1:3), ds_parent(1:3)) + enddo +! + tempP = 0. +! + do k = indmin(3), indmax(3) + do j = indmin(2), indmax(2) + do i = indmin(1), indmax(1) + call Agrif_UpdateBase(type_update(4), & + tempP(i,j,k,indmin(4):indmax(4)), & + tabtemp(i,j,k,lb_child(4):ub_child(4)), & + indmin(4), indmax(4), & + lb_child(4), ub_child(4), & + s_parent(4), s_child(4), & + ds_parent(4),ds_child(4) ) + enddo + enddo + enddo +! + deallocate(tabtemp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_4D_Recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_5D_Recursive +! +!> Updates a 5D grid variable on the parent grid. +!! Calls #Agrif_Update_4D_Recursive and #Agrif_UpdateBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_5D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(5), intent(in) :: type_update !< Type of update (copy or average) + integer, dimension(5), intent(in) :: indmin, indmax + integer, dimension(5), intent(in) :: lb_child, ub_child + real, dimension(5), intent(in) :: s_child, s_parent + real, dimension(5), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5)), intent(out) :: tempP + real, dimension( & + lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), & + lb_child(4):ub_child(4), & + lb_child(5):ub_child(5)), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:,:,:,:), allocatable :: tabtemp + integer :: i,j,k,l,m +! + allocate(tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + lb_child(5):ub_child(5))) +! + do m = lb_child(5), ub_child(5) + call Agrif_Update_4D_Recursive(type_update(1:4), & + tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), m), & + tempC(lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), & + lb_child(4):ub_child(4), m), & + indmin(1:4),indmax(1:4), & + lb_child(1:4), ub_child(1:4), & + s_child(1:4), s_parent(1:4), & + ds_child(1:4), ds_parent(1:4)) + enddo +! + tempP = 0. +! + do l = indmin(4), indmax(4) + do k = indmin(3), indmax(3) + do j = indmin(2), indmax(2) + do i = indmin(1), indmax(1) + call Agrif_UpdateBase( type_update(5), & + tempP(i,j,k,l,indmin(5):indmax(5)), & + tabtemp(i,j,k,l,lb_child(5):ub_child(5)), & + indmin(5), indmax(5), & + lb_child(5), ub_child(5), & + s_parent(5), s_child(5), & + ds_parent(5),ds_child(5) ) + enddo + enddo + enddo + enddo +! + deallocate(tabtemp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_5D_Recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Update_6D_Recursive +! +!> Updates a 6D grid variable on the parent grid. +!! Calls #Agrif_Update_5D_Recursive and #Agrif_UpdateBase. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Update_6D_Recursive ( type_update, & + tempP, tempC, & + indmin, indmax, & + lb_child, ub_child, & + s_child, s_parent, & + ds_child, ds_parent ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(6), intent(in) :: type_update !< Type of update (copy or average) + integer, dimension(6), intent(in) :: indmin, indmax + integer, dimension(6), intent(in) :: lb_child, ub_child + real, dimension(6), intent(in) :: s_child, s_parent + real, dimension(6), intent(in) :: ds_child, ds_parent + real, dimension( & + indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5), & + indmin(6):indmax(6)), intent(out) :: tempP + real, dimension( & + lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), & + lb_child(4):ub_child(4), & + lb_child(5):ub_child(5), & + lb_child(6):ub_child(6)), intent(in) :: tempC +!--------------------------------------------------------------------------------------------------- + real, dimension(:,:,:,:,:,:), allocatable :: tabtemp + integer :: i,j,k,l,m,n +! + allocate(tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5), & + lb_child(6):ub_child(6))) +! + do n = lb_child(6),ub_child(6) + call Agrif_Update_5D_Recursive(type_update(1:5), & + tabtemp(indmin(1):indmax(1), & + indmin(2):indmax(2), & + indmin(3):indmax(3), & + indmin(4):indmax(4), & + indmin(5):indmax(5), n), & + tempC(lb_child(1):ub_child(1), & + lb_child(2):ub_child(2), & + lb_child(3):ub_child(3), & + lb_child(4):ub_child(4), & + lb_child(5):ub_child(5), n), & + indmin(1:5), indmax(1:5), & + lb_child(1:5),ub_child(1:5), & + s_child(1:5), s_parent(1:5), & + ds_child(1:5),ds_parent(1:5)) + enddo +! + tempP = 0. +! + do m = indmin(5), indmax(5) + do l = indmin(4), indmax(4) + do k = indmin(3), indmax(3) + do j = indmin(2), indmax(2) + do i = indmin(1), indmax(1) + call Agrif_UpdateBase( type_update(6), & + tempP(i,j,k,l,m,indmin(6):indmax(6)), & + tabtemp(i,j,k,l,m,lb_child(6):ub_child(6)), & + indmin(6), indmax(6), & + lb_child(6), ub_child(6), & + s_parent(6), s_child(6), & + ds_parent(6), ds_child(6) ) + enddo + enddo + enddo + enddo + enddo +! + deallocate(tabtemp) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Update_6D_Recursive +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_UpdateBase +! +!> Calls the updating method chosen by the user (copy, average or full-weighting). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_UpdateBase ( type_update, & + parent_tab, child_tab, & + indmin, indmax, & + lb_child, ub_child, & + s_parent, s_child, & + ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: type_update + integer, intent(in) :: indmin, indmax + integer, intent(in) :: lb_child, ub_child + real, dimension(indmin:indmax), intent(out):: parent_tab + real, dimension(lb_child:ub_child), intent(in) :: child_tab + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +!--------------------------------------------------------------------------------------------------- + integer :: np ! Length of parent array + integer :: nc ! Length of child array +! + np = indmax - indmin + 1 + nc = ub_child - lb_child + 1 +! + if ( type_update == Agrif_Update_Copy ) then +! + call Agrif_basicupdate_copy1d( & + parent_tab, child_tab, & + np, nc, & + s_parent, s_child, & + ds_parent, ds_child ) +! + elseif ( type_update == Agrif_Update_Average ) then +! + call Agrif_basicupdate_average1d( & + parent_tab, child_tab, & + np, nc, & + s_parent, s_child, & + ds_parent, ds_child ) +! + elseif ( type_update == Agrif_Update_Full_Weighting ) then +! + call Agrif_basicupdate_full_weighting1D( & + parent_tab, child_tab, & + np, nc, & + s_parent, s_child, & + ds_parent, ds_child ) +! + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_UpdateBase +!=================================================================================================== +! +#if defined AGRIF_MPI +!=================================================================================================== +! subroutine Agrif_Find_list_update +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Find_list_update ( list_update, pttab, petab, lb_child, lb_parent, nbdim, & + find_list_update, tab4t, tab5t, memberinall, memberinall2, & + sendtoproc1, recvfromproc1, sendtoproc2, recvfromproc2 ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_List_Interp_Loc), pointer :: list_update + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim), intent(in) :: pttab, petab + INTEGER, DIMENSION(nbdim), intent(in) :: lb_child, lb_parent + LOGICAL, intent(out) :: find_list_update + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8), intent(out) :: tab4t + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8), intent(out) :: tab5t + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(out) :: memberinall,memberinall2 + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(out) :: sendtoproc1,recvfromproc1 + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(out) :: sendtoproc2,recvfromproc2 +! + Type(Agrif_List_Interp_Loc), Pointer :: parcours + INTEGER :: i +! + find_list_update = .FALSE. +! + parcours => list_update + + Find_loop : do while ( associated(parcours) ) + do i = 1,nbdim + IF ((pttab(i) /= parcours%interp_loc%pttab(i)) .OR. & + (petab(i) /= parcours%interp_loc%petab(i)) .OR. & + (lb_child(i) /= parcours%interp_loc%pttab_child(i)) .OR. & + (lb_parent(i) /= parcours%interp_loc%pttab_parent(i))) THEN + parcours => parcours%suiv + cycle Find_loop + ENDIF + enddo +! + tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:8) + tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:8) + memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1) + memberinall2 = parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1) + sendtoproc1 = parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1) + sendtoproc2 = parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1) + recvfromproc1 = parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1) + recvfromproc2 = parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1) +! + find_list_update = .TRUE. + exit Find_loop +! + enddo Find_loop +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Find_list_update +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_AddTo_list_update +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_AddTo_list_update ( list_update, pttab, petab, lb_child, lb_parent, & + nbdim, tab4t, tab5t, memberinall, memberinall2, & + sendtoproc1, recvfromproc1, sendtoproc2, recvfromproc2 ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_List_Interp_Loc), pointer :: list_update + INTEGER, intent(in) :: nbdim + INTEGER, DIMENSION(nbdim), intent(in) :: pttab, petab + INTEGER, DIMENSION(nbdim), intent(in) :: lb_child, lb_parent + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8), intent(in) :: tab4t + INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1,8), intent(in) :: tab5t + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: memberinall, memberinall2 + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc1, recvfromproc1 + LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc2, recvfromproc2 +! + Type(Agrif_List_Interp_Loc), pointer :: parcours +! + allocate(parcours) + allocate(parcours%interp_loc) + + parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim) + parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim) + parcours%interp_loc%pttab_child(1:nbdim) = lb_child(1:nbdim) + parcours%interp_loc%pttab_parent(1:nbdim) = lb_parent(1:nbdim) + + allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,8)) + allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,8)) + + allocate(parcours%interp_loc%memberinall (0:Agrif_Nbprocs-1)) + allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)) + + allocate(parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1)) + allocate(parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1)) + allocate(parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1)) + allocate(parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1)) + + parcours%interp_loc%tab4t = tab4t + parcours%interp_loc%tab5t = tab5t + parcours%interp_loc%memberinall = memberinall + parcours%interp_loc%memberinall2 = memberinall2 + parcours%interp_loc%sendtoproc1 = sendtoproc1 + parcours%interp_loc%sendtoproc2 = sendtoproc2 + parcours%interp_loc%recvfromproc1 = recvfromproc1 + parcours%interp_loc%recvfromproc2 = recvfromproc2 + + parcours%suiv => list_update + list_update => parcours +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Addto_list_update +!=================================================================================================== +#endif +! +end module Agrif_Update diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdatebasic.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdatebasic.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c4844dd56b0fe4ccbf824df18f37ef30288a5d66 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modupdatebasic.F90 @@ -0,0 +1,434 @@ +! +! $Id: modupdatebasic.F90 5656 2015-07-31 08:55:56Z timgraham $ +! +! AGRIF (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! +! +!> Module containing different procedures of update (copy, average, full_weighting) +!! used in the #Agrif_Update module. +!=================================================================================================== +! +module Agrif_UpdateBasic +! + use Agrif_Types + + implicit none + + integer, dimension(:,:), allocatable :: indchildcopy + integer, dimension(:,:), allocatable :: indchildaverage +! +contains +! +!=================================================================================================== +! subroutine Agrif_basicupdate_copy1d +! +!> Carries out a copy on a parent grid (vector x) from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicupdate_copy1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + real, dimension(np), intent(out) :: x !< Coarse output data to parent + real, dimension(nc), intent(in) :: y !< Fine input data from child + integer, intent(in) :: np !< Length of parent array + integer, intent(in) :: nc !< Length of child array + real, intent(in) :: s_parent !< Parent grid position (s_root = 0) + real, intent(in) :: s_child !< Child grid position (s_root = 0) + real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) + real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) +!--------------------------------------------------------------------------------------------------- + integer :: i, locind_child_left, coeffraf +! + coeffraf = nint(ds_parent/ds_child) + locind_child_left = 1 + nint((s_parent - s_child)/ds_child) +! + if ( coeffraf == 1 ) then +!CDIR ALTCODE + x(1:np) = y(locind_child_left:locind_child_left+np-1) + return + endif +! +!CDIR ALTCODE + do i = 1,np + x(i) = y(locind_child_left) + locind_child_left = locind_child_left + coeffraf + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicupdate_copy1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_basicupdate_copy1d_before +! +!> Precomputes index for a copy on a parent grid (vector x) from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicupdate_copy1d_before ( nc2, np, nc, s_parent, s_child, ds_parent, ds_child, dir ) +!--------------------------------------------------------------------------------------------------- + integer, intent(in) :: nc2 !< Length of parent array + integer, intent(in) :: np !< Length of parent array + integer, intent(in) :: nc !< Length of child array + real, intent(in) :: s_parent !< Parent grid position (s_root = 0) + real, intent(in) :: s_child !< Child grid position (s_root = 0) + real, intent(in) :: ds_parent !< Parent grid dx (ds_root = 1) + real, intent(in) :: ds_child !< Child grid dx (ds_root = 1) + integer, intent(in) :: dir !< Direction +!--------------------------------------------------------------------------------------------------- + integer, dimension(:,:), allocatable :: indchildcopy_tmp + integer :: i, n_old, locind_child_left, coeffraf +! + coeffraf = nint(ds_parent/ds_child) +! + locind_child_left = 1 + nint((s_parent - s_child)/ds_child) + + if ( .not.allocated(indchildcopy) ) then + allocate(indchildcopy(np*nc2, 3)) + else + n_old = size(indchildcopy,1) + if ( n_old < np*nc2 ) then + allocate( indchildcopy_tmp(1:n_old, 3)) + indchildcopy_tmp = indchildcopy + deallocate(indchildcopy) + allocate(indchildcopy(np*nc2, 3)) + indchildcopy(1:n_old,:) = indchildcopy_tmp + deallocate(indchildcopy_tmp) + endif + endif +! + do i = 1,np + indchildcopy(i,dir) = locind_child_left + locind_child_left = locind_child_left + coeffraf + enddo +! + do i = 2,nc2 + indchildcopy(1+(i-1)*np:i*np,dir) = indchildcopy(1+(i-2)*np:(i-1)*np,dir) + nc + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicupdate_copy1d_before +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_basicupdate_copy1d_after +! +!> Carries out a copy on a parent grid (vector x) from its child grid (vector y) +!! using precomputed index. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicupdate_copy1d_after ( x, y, np, nc, dir ) +!--------------------------------------------------------------------------------------------------- + real, dimension(np), intent(out) :: x !< Coarse output data to parent + real, dimension(nc), intent(in) :: y !< Fine input data from child + integer, intent(in) :: np !< Length of parent array + integer, intent(in) :: nc !< Length of child array + integer, intent(in) :: dir !< Direction +!--------------------------------------------------------------------------------------------------- + integer :: i +! +!CDIR ALTCODE + do i = 1,np + x(i) = y(indchildcopy(i,dir)) + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicupdate_copy1d_after +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_basicupdate_average1d +! +!> Carries out an update by average on a parent grid (vector x)from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicupdate_average1d ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + REAL, DIMENSION(np), intent(out) :: x + REAL, DIMENSION(nc), intent(in) :: y + INTEGER, intent(in) :: np,nc + REAL, intent(in) :: s_parent, s_child + REAL, intent(in) :: ds_parent, ds_child +! + INTEGER :: i, ii, locind_child_left, coeffraf + REAL :: xpos, invcoeffraf + INTEGER :: nbnonnuls + INTEGER :: diffmod +! + coeffraf = nint(ds_parent/ds_child) + invcoeffraf = 1./coeffraf +! + if (coeffraf == 1) then + locind_child_left = 1 + nint((s_parent - s_child)/ds_child) + x(1:np) = y(locind_child_left:locind_child_left+np-1) + return + endif +! + xpos = s_parent + x = 0. +! + diffmod = 0 +! + IF ( mod(coeffraf,2) == 0 ) diffmod = 1 +! + locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) +! + IF (Agrif_UseSpecialValueInUpdate) THEN + do i = 1,np + nbnonnuls = 0 +!CDIR NOVECTOR + do ii = -coeffraf/2+locind_child_left+diffmod, & + coeffraf/2+locind_child_left + IF (y(ii) /= Agrif_SpecialValueFineGrid) THEN +! nbnonnuls = nbnonnuls + 1 + x(i) = x(i) + y(ii) + ENDIF + enddo +! IF (nbnonnuls /= 0) THEN +! x(i) = x(i)/nbnonnuls +! ELSE +! x(i) = Agrif_SpecialValueFineGrid +! ENDIF + locind_child_left = locind_child_left + coeffraf + enddo + ELSE +! +!CDIR ALTCODE + do i = 1,np +!CDIR NOVECTOR + do ii = -coeffraf/2+locind_child_left+diffmod, & + coeffraf/2+locind_child_left + x(i) = x(i) + y(ii) + enddo +! x(i) = x(i)*invcoeffraf + locind_child_left = locind_child_left + coeffraf + enddo + IF (.not.Agrif_Update_Weights) THEN + x = x * invcoeffraf + ENDIF + ENDIF +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicupdate_average1d +!=================================================================================================== +! +!=================================================================================================== +! subroutine Average1dPrecompute +! +!> Carries out an update by average on a parent grid (vector x)from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Average1dPrecompute ( nc2, np, nc, s_parent, s_child, ds_parent, ds_child, dir ) +!--------------------------------------------------------------------------------------------------- + INTEGER, intent(in) :: nc2, np, nc + REAL, intent(in) :: s_parent, s_child + REAL, intent(in) :: ds_parent, ds_child + INTEGER, intent(in) :: dir +! + INTEGER, DIMENSION(:,:), ALLOCATABLE :: indchildaverage_tmp + INTEGER :: i, locind_child_left, coeffraf + REAL :: xpos + INTEGER :: diffmod +! + coeffraf = nint(ds_parent/ds_child) + xpos = s_parent + diffmod = 0 +! + IF ( mod(coeffraf,2) == 0 ) diffmod = 1 +! + locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child) +! + if (.not.allocated(indchildaverage)) then + allocate(indchildaverage(np*nc2,3)) + else + if (size(indchildaverage,1) Carries out an update by average on a parent grid (vector x) from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Average1dAfterCompute ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child, dir ) +!--------------------------------------------------------------------------------------------------- + REAL, DIMENSION(np), intent(inout) :: x + REAL, DIMENSION(nc), intent(in) :: y + INTEGER, intent(in) :: np, nc + REAL, intent(in) :: s_parent, s_child + REAL, intent(in) :: ds_parent, ds_child + INTEGER, intent(in) :: dir +! + REAL :: invcoeffraf + INTEGER :: i, j, coeffraf + INTEGER, DIMENSION(np) :: nbnonnuls + REAL, DIMENSION(0:7), parameter :: invcoeff = (/1.,1.,0.5,1./3.,0.25,0.2,1./6.,1./7./) +! + coeffraf = nint(ds_parent/ds_child) + invcoeffraf = 1./coeffraf +! + IF (Agrif_UseSpecialValueInUpdate) THEN +! +! nbnonnuls = 0 + do j = 1,coeffraf + do i = 1,np + IF (y(indchildaverage(i,dir) + j -1) /= Agrif_SpecialValueFineGrid) THEN +! nbnonnuls(i) = nbnonnuls(i) + 1 + x(i) = x(i) + y(indchildaverage(i,dir) + j-1 ) + ENDIF + enddo + enddo + do i=1,np + ! x(i) = x(i)*invcoeff(nbnonnuls(i)) + ! if (nbnonnuls(i) == 0) x(i) = Agrif_SpecialValueFineGrid + enddo +! + ELSE +! +!CDIR NOLOOPCHG + do j = 1,coeffraf +!CDIR VECTOR + do i= 1,np + x(i) = x(i) + y(indchildaverage(i,dir) + j-1 ) + enddo + enddo + IF (.not.Agrif_Update_Weights) THEN + x = x * invcoeffraf + ENDIF +! + ENDIF + +!--------------------------------------------------------------------------------------------------- +end subroutine Average1dAfterCompute +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_basicupdate_full_weighting1D +! +!> Carries out an update by full_weighting on a parent grid (vector x) from its child grid (vector y). +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_basicupdate_full_weighting1D ( x, y, np, nc, s_parent, s_child, ds_parent, ds_child ) +!--------------------------------------------------------------------------------------------------- + real, dimension(np), intent(out) :: x + real, dimension(nc), intent(in) :: y + integer, intent(in) :: np, nc + real, intent(in) :: s_parent, s_child + real, intent(in) :: ds_parent, ds_child +!--------------------------------------------------------------------------------------------------- + REAL :: xpos, xposfin + INTEGER :: i, ii, diffmod + INTEGER :: it1, it2 + INTEGER :: i1, i2 + INTEGER :: coeffraf + INTEGER :: locind_child_left + REAL :: sumweight, invsumweight + REAL :: weights(-Agrif_MaxRaff:Agrif_MaxRaff) + + coeffraf = nint(ds_parent/ds_child) + locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child) +! + if (coeffraf == 1) then + x(1:np) = y(locind_child_left:locind_child_left+np-1) + return + endif +! + xpos = s_parent + x = 0. +! + xposfin = s_child + ds_child * (locind_child_left - 1) + IF (abs(xposfin - xpos) < 0.001) THEN + diffmod = 0 + ELSE + diffmod = 1 + ENDIF +! + if (diffmod == 1) THEN + invsumweight=1./(2.*coeffraf**2) + do i = -coeffraf,-1 + weights(i) = invsumweight*(2*(coeffraf+i)+1) + enddo + do i = 0,coeffraf-1 + weights(i) = weights(-(i+1)) + enddo + it1 = -coeffraf + i1 = -(coeffraf-1)+locind_child_left + i2 = 2*coeffraf - 1 + + else + invsumweight=1./coeffraf**2 + do i = -(coeffraf-1),0 + weights(i) = invsumweight*(coeffraf + i) + enddo + do i=1,coeffraf-1 + weights(i) = invsumweight*(coeffraf - i) + enddo + it1 = -(coeffraf-1) + i1 = -(coeffraf-1)+locind_child_left + i2 = 2*coeffraf - 2 + + endif +! + sumweight = 0. + MYLOOP : do i = 1,np +! + it2 = it1 + +! sumweight = 0. + + do ii = i1,i1+i2 +! + IF (Agrif_UseSpecialValueInUpdate) THEN + IF (y(ii) /= Agrif_SpecialValueFineGrid) THEN + x(i) = x(i) + weights(it2)*y(ii) +! sumweight = sumweight+weights(it2) + ELSE + x(i) = Agrif_SpecialValueFineGrid + i1=i1+coeffraf + CYCLE MYLOOP + ENDIF + ELSE + x(i) = x(i) + weights(it2)*y(ii) + ENDIF + + it2 = it2+1 +! + enddo +! + i1 = i1 + coeffraf +! + enddo MYLOOP + + IF (Agrif_UseSpecialValueInUpdate) THEN + x = x * coeffraf ! x will be divided by coeffraf later in modupdate.F90 + ENDIF + +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_basicupdate_full_weighting1D +!=================================================================================================== +! +end module Agrif_UpdateBasic diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modutil.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modutil.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2967db1beac10837191f35a31186e8f29352b98a --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modutil.F90 @@ -0,0 +1,1108 @@ +! +! $Id: modutil.F90 10586 2019-01-27 19:42:34Z nicolasmartin $ +! +! Agrif (Adaptive Grid Refinement In Fortran) +! +! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) +! Christophe Vouland (Christophe.Vouland@imag.fr) +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. +! +!> Module Agrif_Util +!! +!! This module contains the two procedures called in the main program : +!! - #Agrif_Init_Grids allows the initialization of the root coarse grid +!! - #Agrif_Step allows the creation of the grid hierarchy and the management of the time integration. +! +module Agrif_Util +! + use Agrif_Clustering + use Agrif_BcFunction + use Agrif_seq +! + implicit none +! + abstract interface + subroutine step_proc() + end subroutine step_proc + end interface +! +contains +! +!=================================================================================================== +! subroutine Agrif_Step +! +!> Creates the grid hierarchy and manages the time integration procedure. +!> It is called in the main program. +!> Calls subroutines #Agrif_Regrid and #Agrif_Integrate. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Step ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(step_proc) :: procname !< subroutine to call on each grid + type(agrif_grid), pointer :: ref_grid +! +! Set the clustering variables + call Agrif_clustering_def() +! +! Creation and initialization of the grid hierarchy + if ( Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then +! + if ( (Agrif_Mygrid % ngridstep == 0) .AND. (.not. Agrif_regrid_has_been_done) ) then + call Agrif_Regrid() + Agrif_regrid_has_been_done = .TRUE. + endif +! + else +! + if (mod(Agrif_Mygrid % ngridstep,Agrif_Regridding) == 0) then + call Agrif_Regrid() + endif +! + endif +! +! Time integration of the grid hierarchy + if (agrif_coarse) then + ref_grid => agrif_coarsegrid + else + ref_grid => agrif_mygrid + endif + if ( Agrif_Parallel_sisters ) then + call Agrif_Integrate_Parallel(ref_grid,procname) + else + call Agrif_Integrate(ref_grid,procname) + endif +! + if ( ref_grid%child_list%nitems > 0 ) call Agrif_Instance(ref_grid) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Step +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Step_Child +! +!> Apply 'procname' to each grid of the hierarchy +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Step_Child ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(step_proc) :: procname !< subroutine to call on each grid +! + if ( Agrif_Parallel_sisters ) then + call Agrif_Integrate_Child_Parallel(Agrif_Mygrid,procname) + else + call Agrif_Integrate_Child(Agrif_Mygrid,procname) + endif +! + if ( Agrif_Mygrid%child_list%nitems > 0 ) call Agrif_Instance(Agrif_Mygrid) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Step_Child +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Regrid +! +!> Creates the grid hierarchy from fixed grids and adaptive mesh refinement. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Regrid ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(init_proc), optional :: procname !< Initialisation subroutine (Default: Agrif_InitValues) +! + type(Agrif_Rectangle), pointer :: coarsegrid_fixed + type(Agrif_Rectangle), pointer :: coarsegrid_moving + integer :: i, j + integer :: nunit + logical :: BEXIST + TYPE(Agrif_Rectangle) :: newrect ! Pointer on a new grid + integer :: is_coarse, rhox, rhoy, rhoz, rhot +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & + call Agrif_detect_all(Agrif_Mygrid) ! Detection of areas to be refined +! + allocate(coarsegrid_fixed) + allocate(coarsegrid_moving) +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) & + call Agrif_Cluster_All(Agrif_Mygrid,coarsegrid_moving) ! Clustering +! + if ( Agrif_USE_FIXED_GRIDS == 1 .OR. Agrif_USE_ONLY_FIXED_GRIDS == 1 ) then +! + if (Agrif_Mygrid % ngridstep == 0) then +! + nunit = Agrif_Get_Unit() + open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=99) + if (agrif_coarse) then ! SKIP the coarse grid declaration + if (Agrif_Probdim == 3) then + read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot + elseif (Agrif_Probdim == 2) then + read(nunit,*) is_coarse, rhox, rhoy, rhot + elseif (Agrif_Probdim == 2) then + read(nunit,*) is_coarse, rhox, rhot + endif + endif +! Creation of the grid hierarchy from the Agrif_FixedGrids.in file + do i = 1,Agrif_Probdim + coarsegrid_fixed % imin(i) = 1 + coarsegrid_fixed % imax(i) = Agrif_Mygrid % nb(i) + 1 + enddo + j = 1 + call Agrif_Read_Fix_Grd(coarsegrid_fixed,j,nunit) + close(nunit) +! + call Agrif_gl_clear(Agrif_oldmygrid) +! +! Creation of the grid hierarchy from coarsegrid_fixed + call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_fixed) + + else + call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) + endif + else + call Agrif_gl_copy(Agrif_oldmygrid, Agrif_Mygrid % child_list) + call Agrif_gl_clear(Agrif_Mygrid % child_list) + endif +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) then +! + call Agrif_Save_All(Agrif_oldmygrid) + call Agrif_Free_before_All(Agrif_oldmygrid) +! +! Creation of the grid hierarchy from coarsegrid_moving + call Agrif_Create_Grids(Agrif_Mygrid,coarsegrid_moving) +! + endif +! +! Initialization of the grid hierarchy by copy or interpolation +! +#if defined AGRIF_MPI + if ( Agrif_Parallel_sisters ) then + call Agrif_Init_Hierarchy_Parallel_1(Agrif_Mygrid) + call Agrif_Init_Hierarchy_Parallel_2(Agrif_Mygrid,procname) + else + call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) + endif +#else + call Agrif_Init_Hierarchy(Agrif_Mygrid,procname) +#endif +! + if ( Agrif_USE_ONLY_FIXED_GRIDS == 0 ) call Agrif_Free_after_All(Agrif_oldmygrid) +! + Agrif_regrid_has_been_done = .TRUE. +! + call Agrif_Instance( Agrif_Mygrid ) +! + deallocate(coarsegrid_fixed) + deallocate(coarsegrid_moving) +! + return +! +! Opening error +! +99 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) + if (.not. BEXIST) then + print*,'ERROR : File AGRIF_FixedGrids.in not found.' + STOP + else + print*,'Error opening file AGRIF_FixedGrids.in' + STOP + endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Regrid +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_detect_All +! +!> Detects areas to be refined. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_detect_all ( g ) +!--------------------------------------------------------------------------------------------------- + TYPE(Agrif_Grid), pointer :: g !< Pointer on the current grid +! + Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure + integer, DIMENSION(3) :: size + integer :: i + real :: g_eps +! + parcours => g % child_list % first +! +! To be positioned on the finer grids of the grid hierarchy +! + do while (associated(parcours)) + call Agrif_detect_all(parcours % gr) + parcours => parcours % next + enddo +! + g_eps = huge(1.) + do i = 1,Agrif_Probdim + g_eps = min(g_eps, g % Agrif_dx(i)) + enddo +! + g_eps = g_eps / 100. +! + if ( Agrif_Probdim == 1 ) g%tabpoint1D = 0 + if ( Agrif_Probdim == 2 ) g%tabpoint2D = 0 + if ( Agrif_Probdim == 3 ) g%tabpoint3D = 0 +! + do i = 1,Agrif_Probdim + if ( g%Agrif_dx(i)/Agrif_coeffref(i) < (Agrif_mind(i)-g_eps) ) return + enddo +! + call Agrif_instance(g) +! +! Detection (Agrif_detect is a users routine) +! + do i = 1,Agrif_Probdim + size(i) = g % nb(i) + 1 + enddo +! + SELECT CASE (Agrif_Probdim) + CASE (1) + call Agrif_detect(g%tabpoint1D,size) + CASE (2) + call Agrif_detect(g%tabpoint2D,size) + CASE (3) + call Agrif_detect(g%tabpoint3D,size) + END SELECT +! +! Addition of the areas detected on the child grids +! + parcours => g % child_list % first +! + do while (associated(parcours)) + call Agrif_Add_detected_areas(g,parcours % gr) + parcours => parcours % next + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_detect_all +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Add_detected_areas +! +!> Adds on the parent grid the areas detected on its child grids +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Add_detected_areas ( parentgrid, childgrid ) +!--------------------------------------------------------------------------------------------------- + Type(Agrif_Grid), pointer :: parentgrid + Type(Agrif_Grid), pointer :: childgrid +! + integer :: i,j,k +! + do i = 1,childgrid%nb(1)+1 + if ( Agrif_Probdim == 1 ) then + if (childgrid%tabpoint1D(i)==1) then + parentgrid%tabpoint1D(childgrid%ix(1)+(i-1)/Agrif_Coeffref(1)) = 1 + endif + else + do j=1,childgrid%nb(2)+1 + if (Agrif_Probdim==2) then + if (childgrid%tabpoint2D(i,j)==1) then + parentgrid%tabpoint2D( & + childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & + childgrid%ix(2)+(j-1)/Agrif_Coeffref(2)) = 1 + endif + else + do k=1,childgrid%nb(3)+1 + if (childgrid%tabpoint3D(i,j,k)==1) then + parentgrid%tabpoint3D( & + childgrid%ix(1)+(i-1)/Agrif_Coeffref(1), & + childgrid%ix(2)+(j-1)/Agrif_Coeffref(2), & + childgrid%ix(3)+(k-1)/Agrif_Coeffref(3)) = 1 + endif + enddo + endif + enddo + endif + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Add_detected_areas +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Free_before_All +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Free_before_All ( gridlist ) +!--------------------------------------------------------------------------------------------------- + Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list +! + Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure +! + parcours => gridlist % first +! + do while (associated(parcours)) +! + if (.not. parcours%gr%fixed) then + call Agrif_Free_data_before(parcours%gr) + parcours % gr % oldgrid = .TRUE. + endif +! + call Agrif_Free_before_all (parcours % gr % child_list) +! + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_before_All +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Save_All +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Save_All ( gridlist ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure +! + parcours => gridlist % first +! + do while (associated(parcours)) +! + if (.not. parcours%gr%fixed) then + call Agrif_Instance(parcours%gr) + call Agrif_Before_Regridding() + parcours % gr % oldgrid = .TRUE. + endif +! + call Agrif_Save_All(parcours % gr % child_list) +! + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Save_All +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Free_after_All +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Free_after_All ( gridlist ) +!--------------------------------------------------------------------------------------------------- + Type(Agrif_Grid_List), intent(inout) :: gridlist !< Grid list to free +! + Type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive proced + Type(Agrif_PGrid), pointer :: preparcours + Type(Agrif_PGrid), pointer :: preparcoursini +! + allocate(preparcours) +! + preparcoursini => preparcours +! + nullify(preparcours % gr) +! + preparcours % next => gridlist % first + parcours => gridlist % first +! + do while (associated(parcours)) +! + if ( (.NOT. parcours%gr % fixed) .AND. (parcours%gr % oldgrid) ) then + call Agrif_Free_data_after(parcours%gr) + endif +! + call Agrif_Free_after_all( parcours%gr % child_list ) +! + if (parcours % gr % oldgrid) then + deallocate(parcours % gr) + preparcours % next => parcours % next + deallocate(parcours) + parcours => preparcours % next + else + preparcours => preparcours % next + parcours => parcours % next + endif +! + enddo +! + deallocate(preparcoursini) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Free_after_All +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Integrate +! +!> Manages the time integration of the grid hierarchy. +!! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure + integer :: nbt ! Number of time steps of the current grid + integer :: i, k +! +! Instanciation of the variables of the current grid +! if ( g % fixedrank /= 0 ) then + call Agrif_Instance(g) +! endif +! +! One step on the current grid +! + call procname () +! +! Number of time steps on the current grid +! + g%ngridstep = g % ngridstep + 1 + parcours => g % child_list % first +! +! Recursive procedure for the time integration of the grid hierarchy + do while (associated(parcours)) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) +! +! Number of time steps + nbt = 1 + do i = 1,Agrif_Probdim + nbt = max(nbt, parcours % gr % timeref(i)) + enddo +! + do k = 1,nbt + call Agrif_Integrate(parcours % gr, procname) + enddo +! + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Integrate_Parallel +! +!> Manages the time integration of the grid hierarchy in parallel +!! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_Parallel ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! +#if defined AGRIF_MPI + type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure + integer :: nbt ! Number of time steps of the current grid + integer :: i, k, is +! +! Instanciation of the variables of the current grid + if ( g % fixedrank /= 0 ) then + call Agrif_Instance(g) + endif +! +! One step on the current grid + call procname () +! +! Number of time steps on the current grid + g % ngridstep = g % ngridstep + 1 +! +! Continue only if the grid has defined sequences of child integrations. + if ( .not. associated(g % child_seq) ) return +! + do is = 1, g % child_seq % nb_seqs +! +! For each sequence, a given processor does integrate only on grid. + gridp => Agrif_seq_select_child(g,is) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(gridp % gr) +! +! Number of time steps + nbt = 1 + do i = 1,Agrif_Probdim + nbt = max(nbt, gridp % gr % timeref(i)) + enddo +! + do k = 1,nbt + call Agrif_Integrate_Parallel(gridp % gr, procname) + enddo +! + enddo +#else + call Agrif_Integrate( g, procname ) +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate_Parallel +!=================================================================================================== +! +! +!=================================================================================================== +! subroutine Agrif_Integrate_ChildGrids +! +!> Manages the time integration of the grid hierarchy. +!! Call the subroutine procname on each child grid of the current grid +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_ChildGrids ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure + integer :: nbt ! Number of time steps of the current grid + integer :: i, k, is + type(Agrif_Grid) , pointer :: save_grid + type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure + + save_grid => Agrif_Curgrid + +! Number of time steps on the current grid + save_grid % ngridstep = save_grid % ngridstep + 1 + +#ifdef AGRIF_MPI + if ( .not. Agrif_Parallel_sisters ) then +#endif + parcours => save_grid % child_list % first +! +! Recursive procedure for the time integration of the grid hierarchy + do while (associated(parcours)) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) +! +! Number of time steps + nbt = 1 + do i = 1,Agrif_Probdim + nbt = max(nbt, parcours % gr % timeref(i)) + enddo +! + do k = 1,nbt + call procname() + enddo +! + parcours => parcours % next +! + enddo + +#ifdef AGRIF_MPI + else +#endif +! Continue only if the grid has defined sequences of child integrations. + if ( .not. associated(save_grid % child_seq) ) return +! + do is = 1, save_grid % child_seq % nb_seqs +! +! For each sequence, a given processor does integrate only on grid. + gridp => Agrif_seq_select_child(save_grid,is) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(gridp % gr) +! +! Number of time steps + nbt = 1 + do i = 1,Agrif_Probdim + nbt = max(nbt, gridp % gr % timeref(i)) + enddo +! + do k = 1,nbt + call procname() + enddo +! + enddo +#ifdef AGRIF_MPI + endif +#endif + + call Agrif_Instance(save_grid) + +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate_ChildGrids +!=================================================================================================== +!=================================================================================================== +! subroutine Agrif_Integrate_Child +! +!> Manages the time integration of the grid hierarchy. +!! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_Child ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + type(Agrif_PGrid), pointer :: parcours ! Pointer for the recursive procedure +! +! One step on the current grid +! + call procname () +! +! Number of time steps on the current grid +! + parcours => g % child_list % first +! +! Recursive procedure for the time integration of the grid hierarchy + do while (associated(parcours)) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) + call Agrif_Integrate_Child (parcours % gr, procname) + parcours => parcours % next +! + enddo +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate_Child +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Integrate_Child_Parallel +! +!> Manages the time integration of the grid hierarchy. +!! Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_Child_Parallel ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! +#if defined AGRIF_MPI + type(Agrif_PGrid), pointer :: gridp ! Pointer for the recursive procedure + integer :: is +! +! Instanciation of the variables of the current grid + call Agrif_Instance(g) +! +! One step on the current grid + call procname () +! +! Continue only if the grid has defined sequences of child integrations. + if ( .not. associated(g % child_seq) ) return +! + do is = 1, g % child_seq % nb_seqs +! +! For each sequence, a given processor does integrate only on grid. + gridp => Agrif_seq_select_child(g,is) + call Agrif_Integrate_Child_Parallel(gridp % gr, procname) +! + enddo +! + call Agrif_Instance(g) +#else + call Agrif_Integrate_Child( g, procname ) +#endif +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate_Child_Parallel +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Init_Grids +! +!> Initializes the root coarse grid pointed by Agrif_Mygrid. It is called in the main program. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Init_Grids ( procname1, procname2 ) +!--------------------------------------------------------------------------------------------------- + procedure(typdef_proc), optional :: procname1 !< (Default: Agrif_probdim_modtype_def) + procedure(alloc_proc), optional :: procname2 !< (Default: Agrif_Allocationcalls) +! + integer :: i, ierr_allocate, nunit + integer :: is_coarse, rhox,rhoy,rhoz,rhot + logical :: BEXIST +! + if (present(procname1)) Then + call procname1() + else + call Agrif_probdim_modtype_def() + endif +! + +! TEST FOR COARSE GRID (GRAND MOTHER GRID) in AGRIF_FixedGrids.in + nunit = Agrif_Get_Unit() + open(nunit, file='AGRIF_FixedGrids.in', form='formatted', status="old", ERR=98) + if (Agrif_Probdim == 3) then + read(nunit,*) is_coarse, rhox, rhoy, rhoz, rhot + elseif (Agrif_Probdim == 2) then + read(nunit,*) is_coarse, rhox, rhoy, rhot + elseif (Agrif_Probdim == 2) then + read(nunit,*) is_coarse, rhox, rhot + endif + if (is_coarse == -1) then + agrif_coarse = .TRUE. + if (Agrif_Probdim == 3) then + coarse_spaceref(1:3)=(/rhox,rhoy,rhoz/) + elseif (Agrif_Probdim == 2) then + coarse_spaceref(1:2)=(/rhox,rhoy/) + elseif (Agrif_Probdim == 2) then + coarse_spaceref(1:1)=(/rhox/) + endif + coarse_timeref(1:Agrif_Probdim) = rhot + endif + close(nunit) + + Agrif_UseSpecialValue = .FALSE. + Agrif_UseSpecialValueFineGrid = .FALSE. + Agrif_SpecialValue = 0. + Agrif_SpecialValueFineGrid = 0. +! + allocate(Agrif_Mygrid) + allocate(Agrif_OldMygrid) +! +! Space and time refinement factors are set to 1 on the root grid +! + do i = 1,Agrif_Probdim + Agrif_Mygrid % spaceref(i) = coarse_spaceref(i) + Agrif_Mygrid % timeref(i) = coarse_timeref(i) + enddo +! +! Initialization of the number of time steps + Agrif_Mygrid % ngridstep = 0 + Agrif_Mygrid % grid_id = 0 +! +! No parent grid for the root coarse grid + nullify(Agrif_Mygrid % parent) +! +! Initialization of the minimum positions, global abscissa and space steps + do i = 1, Agrif_Probdim + Agrif_Mygrid % ix(i) = 1 + Agrif_Mygrid % Agrif_x(i) = 0. + Agrif_Mygrid % Agrif_dx(i) = 1./Agrif_Mygrid % spaceref(i) + Agrif_Mygrid % Agrif_dt(i) = 1./Agrif_Mygrid % timeref(i) +! Borders of the root coarse grid + Agrif_Mygrid % NearRootBorder(i) = .true. + Agrif_Mygrid % DistantRootBorder(i) = .true. + enddo +! +! The root coarse grid is a fixed grid + Agrif_Mygrid % fixed = .TRUE. +! Level of the root grid + Agrif_Mygrid % level = 0 +! Maximum level in the hierarchy + Agrif_MaxLevelLoc = 0 +! +! Number of the grid pointed by Agrif_Mygrid (root coarse grid) + Agrif_Mygrid % rank = 1 +! +! Number of the root grid as a fixed grid + Agrif_Mygrid % fixedrank = 0 +! +! Initialization of some fields of the root grid variables + ierr_allocate = 0 + if( Agrif_NbVariables(0) > 0 ) allocate(Agrif_Mygrid % tabvars(Agrif_NbVariables(0)),stat=ierr_allocate) + if( Agrif_NbVariables(1) > 0 ) allocate(Agrif_Mygrid % tabvars_c(Agrif_NbVariables(1)),stat=ierr_allocate) + if( Agrif_NbVariables(2) > 0 ) allocate(Agrif_Mygrid % tabvars_r(Agrif_NbVariables(2)),stat=ierr_allocate) + if( Agrif_NbVariables(3) > 0 ) allocate(Agrif_Mygrid % tabvars_l(Agrif_NbVariables(3)),stat=ierr_allocate) + if( Agrif_NbVariables(4) > 0 ) allocate(Agrif_Mygrid % tabvars_i(Agrif_NbVariables(4)),stat=ierr_allocate) + if (ierr_allocate /= 0) THEN + STOP "*** ERROR WHEN ALLOCATING TABVARS ***" + endif +! +! Initialization of the other fields of the root grid variables (number of +! cells, positions, number and type of its dimensions, ...) + call Agrif_Instance(Agrif_Mygrid) + call Agrif_Set_numberofcells(Agrif_Mygrid) +! +! Allocation of the array containing the values of the grid variables + call Agrif_Allocation(Agrif_Mygrid, procname2) + call Agrif_initialisations(Agrif_Mygrid) +! +! Total number of fixed grids + Agrif_nbfixedgrids = 0 + +! If a grand mother grid is declared + + if (agrif_coarse) then + allocate(Agrif_Coarsegrid) + + Agrif_Coarsegrid % ngridstep = 0 + Agrif_Coarsegrid % grid_id = -9999 + + do i = 1, Agrif_Probdim + Agrif_Coarsegrid%spaceref(i) = coarse_spaceref(i) + Agrif_Coarsegrid%timeref(i) = coarse_timeref(i) + Agrif_Coarsegrid % ix(i) = 1 + Agrif_Coarsegrid % Agrif_x(i) = 0. + Agrif_Coarsegrid % Agrif_dx(i) = 1. + Agrif_Coarsegrid % Agrif_dt(i) = 1. +! Borders of the root coarse grid + Agrif_Coarsegrid % NearRootBorder(i) = .true. + Agrif_Coarsegrid % DistantRootBorder(i) = .true. + Agrif_Coarsegrid % nb(i) =Agrif_mygrid%nb(i) / coarse_spaceref(i) + enddo + +! The root coarse grid is a fixed grid + Agrif_Coarsegrid % fixed = .TRUE. +! Level of the root grid + Agrif_Coarsegrid % level = -1 + + Agrif_Coarsegrid % grand_mother_grid = .true. + +! Number of the grid pointed by Agrif_Mygrid (root coarse grid) + Agrif_Coarsegrid % rank = -9999 +! +! Number of the root grid as a fixed grid + Agrif_Coarsegrid % fixedrank = -9999 + + Agrif_Mygrid%parent => Agrif_Coarsegrid + +! Not used but required to prevent seg fault + Agrif_Coarsegrid%parent => Agrif_Mygrid + + call Agrif_Create_Var(Agrif_Coarsegrid) + +! Reset to null + Nullify(Agrif_Coarsegrid%parent) + + Agrif_Coarsegrid%child_list%nitems = 1 + allocate(Agrif_Coarsegrid%child_list%first) + allocate(Agrif_Coarsegrid%child_list%last) + Agrif_Coarsegrid%child_list%first%gr => Agrif_Mygrid + Agrif_Coarsegrid%child_list%last%gr => Agrif_Mygrid + + endif + + return + +98 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST) + if (.not. BEXIST) then + print*,'ERROR : File AGRIF_FixedGrids.in not found.' + STOP + else + print*,'Error opening file AGRIF_FixedGrids.in' + STOP + endif + +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Init_Grids +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Deallocation +! +!> Deallocates all data arrays. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Deallocation +!--------------------------------------------------------------------------------------------------- + integer :: nb + type(Agrif_Variable), pointer :: var + type(Agrif_Variable_c), pointer :: var_c + type(Agrif_Variable_l), pointer :: var_l + type(Agrif_Variable_i), pointer :: var_i +! + do nb = 1,Agrif_NbVariables(0) +! + var => Agrif_Mygrid % tabvars(nb) +! + if ( allocated(var % array1) ) deallocate(var % array1) + if ( allocated(var % array2) ) deallocate(var % array2) + if ( allocated(var % array3) ) deallocate(var % array3) + if ( allocated(var % array4) ) deallocate(var % array4) + if ( allocated(var % array5) ) deallocate(var % array5) + if ( allocated(var % array6) ) deallocate(var % array6) +! + if ( allocated(var % sarray1) ) deallocate(var % sarray1) + if ( allocated(var % sarray2) ) deallocate(var % sarray2) + if ( allocated(var % sarray3) ) deallocate(var % sarray3) + if ( allocated(var % sarray4) ) deallocate(var % sarray4) + if ( allocated(var % sarray5) ) deallocate(var % sarray5) + if ( allocated(var % sarray6) ) deallocate(var % sarray6) +! + if ( allocated(var % darray1) ) deallocate(var % darray1) + if ( allocated(var % darray2) ) deallocate(var % darray2) + if ( allocated(var % darray3) ) deallocate(var % darray3) + if ( allocated(var % darray4) ) deallocate(var % darray4) + if ( allocated(var % darray5) ) deallocate(var % darray5) + if ( allocated(var % darray6) ) deallocate(var % darray6) +! + enddo +! + do nb = 1,Agrif_NbVariables(1) +! + var_c => Agrif_Mygrid % tabvars_c(nb) +! + if ( allocated(var_c % carray1) ) deallocate(var_c % carray1) + if ( allocated(var_c % carray2) ) deallocate(var_c % carray2) +! + enddo + + do nb = 1,Agrif_NbVariables(3) +! + var_l => Agrif_Mygrid % tabvars_l(nb) +! + if ( allocated(var_l % larray1) ) deallocate(var_l % larray1) + if ( allocated(var_l % larray2) ) deallocate(var_l % larray2) + if ( allocated(var_l % larray3) ) deallocate(var_l % larray3) + if ( allocated(var_l % larray4) ) deallocate(var_l % larray4) + if ( allocated(var_l % larray5) ) deallocate(var_l % larray5) + if ( allocated(var_l % larray6) ) deallocate(var_l % larray6) +! + enddo +! + do nb = 1,Agrif_NbVariables(4) +! + var_i => Agrif_Mygrid % tabvars_i(nb) +! + if ( allocated(var_i % iarray1) ) deallocate(var_i % iarray1) + if ( allocated(var_i % iarray2) ) deallocate(var_i % iarray2) + if ( allocated(var_i % iarray3) ) deallocate(var_i % iarray3) + if ( allocated(var_i % iarray4) ) deallocate(var_i % iarray4) + if ( allocated(var_i % iarray5) ) deallocate(var_i % iarray5) + if ( allocated(var_i % iarray6) ) deallocate(var_i % iarray6) +! + enddo +! + if ( allocated(Agrif_Mygrid % tabvars) ) deallocate(Agrif_Mygrid % tabvars) + if ( allocated(Agrif_Mygrid % tabvars_c) ) deallocate(Agrif_Mygrid % tabvars_c) + if ( allocated(Agrif_Mygrid % tabvars_r) ) deallocate(Agrif_Mygrid % tabvars_r) + if ( allocated(Agrif_Mygrid % tabvars_l) ) deallocate(Agrif_Mygrid % tabvars_l) + if ( allocated(Agrif_Mygrid % tabvars_i) ) deallocate(Agrif_Mygrid % tabvars_i) + deallocate(Agrif_Mygrid) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Deallocation +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Step_adj +! +!> creates the grid hierarchy and manages the backward time integration procedure. +!> It is called in the main program. +!> calls subroutines #Agrif_Regrid and #Agrif_Integrate_adj. +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Step_adj ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(step_proc) :: procname !< Subroutine to call on each grid +! +! Creation and initialization of the grid hierarchy +! +! Set the clustering variables + call Agrif_clustering_def() +! + if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 1 ) then +! + if (Agrif_Mygrid % ngridstep == 0) then + if (.not.Agrif_regrid_has_been_done ) then + call Agrif_Regrid() + endif + call Agrif_Instance(Agrif_Mygrid) + endif +! + else +! + if (mod(Agrif_Mygrid % ngridstep, Agrif_Regridding) == 0) then + call Agrif_Regrid() + call Agrif_Instance(Agrif_Mygrid) + endif +! + endif +! +! Time integration of the grid hierarchy +! + call Agrif_Integrate_adj (Agrif_Mygrid,procname) +! + if ( Agrif_Mygrid % child_list % nitems > 0 ) call Agrif_Instance(Agrif_Mygrid) +! +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Step_adj +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Integrate_adj +! +!> Manages the backward time integration of the grid hierarchy. +!! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance and #Agrif_Step_adj +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_adj ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + type(Agrif_pgrid), pointer :: parcours ! pointer for the recursive procedure + integer :: nbt ! Number of time steps of the current grid + integer :: k +! +! Instanciation of the variables of the current grid + if ( g%fixedrank /= 0 ) then + call Agrif_Instance(g) + endif +! +! Number of time steps on the current grid +! + g%ngridstep = g % ngridstep + 1 + parcours => g % child_list % first +! +! Recursive procedure for the time integration of the grid hierarchy + do while (associated(parcours)) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) +! +! Number of time steps + nbt = 1 + do k = 1,Agrif_Probdim + nbt = max(nbt, parcours % gr % timeref(k)) + enddo +! + do k = nbt,1,-1 + call Agrif_Integrate_adj(parcours % gr, procname) + enddo +! + parcours => parcours % next +! + enddo +! + if ( g % child_list % nitems > 0 ) call Agrif_Instance(g) +! +! One step on the current grid + call procname () +! +end subroutine Agrif_Integrate_adj +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Step_Child_adj +! +!> Apply 'procname' to each grid of the hierarchy from Child to Parent +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Step_Child_adj ( procname ) +!--------------------------------------------------------------------------------------------------- + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + call Agrif_Integrate_Child_adj(Agrif_Mygrid,procname) +! + if ( Agrif_Mygrid % child_list % nitems > 0 ) call Agrif_Instance(Agrif_Mygrid) +! +end subroutine Agrif_Step_Child_adj +!=================================================================================================== +! +!=================================================================================================== +! subroutine Agrif_Integrate_Child_adj +! +!> Manages the backward time integration of the grid hierarchy. +!! Recursive subroutine and call on subroutines Agrif_Init::Agrif_Instance & Agrif_Step_adj. +!--------------------------------------------------------------------------------------------------- +recursive subroutine Agrif_Integrate_Child_adj ( g, procname ) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid),pointer :: g !< Pointer on the current grid + procedure(step_proc) :: procname !< Subroutine to call on each grid +! + type(Agrif_PGrid),pointer :: parcours !< Pointer for the recursive procedure +! + parcours => g % child_list % first +! +! Recursive procedure for the time integration of the grid hierarchy + do while (associated(parcours)) +! +! Instanciation of the variables of the current grid + call Agrif_Instance(parcours % gr) + call Agrif_Integrate_Child_adj(parcours % gr, procname) +! + parcours => parcours % next +! + enddo + if ( g % child_list % nitems > 0 ) call Agrif_Instance(g) +! +! One step on the current grid + call procname() +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Integrate_Child_adj +!=================================================================================================== +! +!=================================================================================================== + +end module Agrif_Util diff --git a/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modvariables.F90 b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modvariables.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b3c2fa17df4c762c1fce208f1733420c31ec7800 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/AGRIF_FILES/modvariables.F90 @@ -0,0 +1,146 @@ +module Agrif_Variables +! + use Agrif_CurgridFunctions +! + implicit none +! +contains +! +!=================================================================================================== +! subroutine Agrif_Declare_Variable +! +!> Declare a new variable profile +!--------------------------------------------------------------------------------------------------- +subroutine Agrif_Declare_Variable ( posvar, firstpoint, raf, lb, ub, varid, torestore ) +!--------------------------------------------------------------------------------------------------- + integer, dimension(:), intent(in) :: posvar !< position of the variable on the cell + !! (1 for the border of the edge, 2 for the center) + integer, dimension(:), intent(in) :: firstpoint !< index of the first point in the real domain + character(1), dimension(:), intent(in) :: raf !< Array indicating the type of dimension (space or not) + !! for each of them + integer, dimension(:), intent(in) :: lb !< Lower bounds of the array + integer, dimension(:), intent(in) :: ub !< Upper bounds of the array + integer, intent(out) :: varid !< Id number of the newly created variable + logical, optional, intent(in) :: torestore !< Indicates if the array restore is used +!--------------------------------------------------------------------------------------------------- + type(Agrif_Variables_List), pointer :: new_varlist + type(Agrif_Variable), pointer :: var + integer :: nbdim, i + logical :: restore + + restore = .FALSE. + if ( Agrif_Mygrid % ngridstep /= 0 ) then + if (present(torestore)) restore = torestore + endif +! + nbdim = SIZE(posvar) +! + allocate(new_varlist) + allocate(new_varlist % var) + + var => new_varlist % var + + allocate(var % posvar(nbdim)) + allocate(var % interptab(nbdim)) + allocate(var % coords(nbdim)) +! + var % nbdim = nbdim + var % interptab = raf(1:nbdim) + var % posvar = posvar(1:nbdim) + var % point(1:nbdim) = firstpoint(1:nbdim) + var % restore = restore +! + do i = 1,nbdim + select case( raf(i) ) + case('x') ; var % coords(i) = 1 + case('y') ; var % coords(i) = 2 + case('z') ; var % coords(i) = 3 + case('N') ; var % coords(i) = 0 + case default ; var % coords(i) = 0 + end select + enddo +! + var % lb(1:nbdim) = lb(1:nbdim) + var % ub(1:nbdim) = ub(1:nbdim) + + if ( restore ) then + select case(nbdim) + case(1) + allocate(var % Restore1D(lb(1):ub(1))) + var % Restore1D = 0 + case(2) + allocate(var % Restore2D(lb(1):ub(1), & + lb(2):ub(2))) + var % Restore2D = 0 + case(3) + allocate(var % Restore3D(lb(1):ub(1), & + lb(2):ub(2), & + lb(3):ub(3))) + var % Restore3D = 0 + case(4) + allocate(var % Restore4D(lb(1):ub(1), & + lb(2):ub(2), & + lb(3):ub(3), & + lb(4):ub(4))) + var % Restore4D = 0 + case(5) + allocate(var % Restore5D(lb(1):ub(1), & + lb(2):ub(2), & + lb(3):ub(3), & + lb(4):ub(4), & + lb(5):ub(5))) + var % Restore5D = 0 + end select + endif + + new_varlist % next => Agrif_Curgrid % variables + + Agrif_Curgrid % variables => new_varlist + Agrif_Curgrid % Nbvariables = Agrif_Curgrid % Nbvariables + 1 + + varid = -Agrif_Curgrid % Nbvariables + + var % parent_var => Agrif_Search_Variable(Agrif_Curgrid % parent, Agrif_Curgrid % nbvariables) + var % root_var => Agrif_Search_Variable(Agrif_Mygrid, Agrif_Curgrid % nbvariables) +!--------------------------------------------------------------------------------------------------- +end subroutine Agrif_Declare_Variable +!=================================================================================================== +! +!=================================================================================================== +! function Agrif_Search_Variable +! +!> Returns a pointer to the variable varid for the grid grid. +!--------------------------------------------------------------------------------------------------- +function Agrif_Search_Variable ( grid, varid ) result(outvar) +!--------------------------------------------------------------------------------------------------- + type(Agrif_Grid), pointer :: grid !< Pointer on the current grid. + integer, intent(in) :: varid !< ID number of the variable we are looking for. +! + type(Agrif_Variable), pointer :: outvar + type(Agrif_Variables_List), pointer :: parcours + integer :: nb, varidinv +! + if ( .not.associated(grid) ) then + outvar => NULL() + return + endif +! + parcours => grid % variables + + if (.not. associated(parcours)) then ! can occur on the grand mother grid + outvar => NULL() ! during the first call by agrif_mygrid + return + endif + + varidinv = 1 + grid % nbvariables - varid + + do nb = 1,varidinv-1 + parcours => parcours % next + enddo + + outvar => parcours % var +!--------------------------------------------------------------------------------------------------- +end function Agrif_Search_variable +!=================================================================================================== +! +end module Agrif_Variables diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/Makefile.lex b/V4.0/nemo_sources/ext/AGRIF/LEX/Makefile.lex new file mode 100644 index 0000000000000000000000000000000000000000..bdb83c7e233086eed15e1efca73befe0656fe0c1 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/Makefile.lex @@ -0,0 +1,31 @@ +LEX = flex -i +YACC = bison -t -v -g + +all: main.c fortran.c + +main.c : convert.tab.c convert.yy.c + cat convert.tab.c convert.yy.c > ../LIB/main.c + $(RM) convert.tab.c convert.yy.c + +fortran.c : fortran.tab.c fortran.yy.c + cat fortran.tab.c fortran.yy.c > ../LIB/fortran.c + $(RM) fortran.tab.c fortran.yy.c + +convert.tab.c : convert.y decl.h + $(YACC) -p convert_ convert.y + +fortran.tab.c : fortran.y decl.h + $(YACC) -p fortran_ fortran.y + +convert.yy.c : convert.lex + $(LEX) -P convert_ -o convert.yy.c convert.lex + +fortran.yy.c : fortran.lex + $(LEX) -P fortran_ -o fortran.yy.c fortran.lex + +clean: + $(RM) convert.yy.c convert.tab.c convert.output convert.vcg convert.dot \ + fortran.yy.c fortran.tab.c fortran.output fortran.vcg fortran.dot + +clean-all: clean + $(RM) ../LIB/main.c ../LIB/fortran.c diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/convert.lex b/V4.0/nemo_sources/ext/AGRIF/LEX/convert.lex new file mode 100644 index 0000000000000000000000000000000000000000..25907d35f21d5fec18781de73ee5a7da34cb6bf6 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/convert.lex @@ -0,0 +1,69 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +%option warn +%option noyywrap + +%s character +%{ +#include +#include +#include + +#define YY_NO_INPUT +%} + +SEPARATEUR "::" +COMMENTS "%".*"%" +PROBTYPE "1D"|"2D"|"3D" +USEITEM "FIXED_GRIDS"|"ONLY_FIXED_GRIDS"|"F77" +NAME [a-zA-Z\_][a-zA-Z0-9\_]* +INTEGER [0-9]+ +NEXTLINE \n+[ \t]+"$"|\n+[ \t]+"&" +%% +parammodule { return TOK_MODULEMAIN; } /* name of the module */ +notgriddep { return TOK_NOTGRIDDEP; } /* variable which are not grid dependent */ +use { return TOK_USE; } +{COMMENTS} { } +{SEPARATEUR} { return TOK_SEP; } +KIND { return TOK_KIND; } +\= { return TOK_EQUAL; } +{USEITEM} { strcpy(yylval.na,yytext); return TOK_USEITEM; } +{PROBTYPE} { strcpy(yylval.na,yytext); return TOK_PROBTYPE; } /* dimension of the problem */ +{NAME} { strcpy(yylval.na,yytext); return TOK_NAME; } +{INTEGER} { strcpy(yylval.na,yytext); return TOK_CSTINT; } +;|\,|\(|\)|:|\[|\] { return (int) *yytext; } +\n { line_num++; return (int) *yytext; } +[ \t]+ ; +%% diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/convert.y b/V4.0/nemo_sources/ext/AGRIF/LEX/convert.y new file mode 100644 index 0000000000000000000000000000000000000000..d8ebb32eb2f356f23b2d720f0c1cff0f7a2e3573 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/convert.y @@ -0,0 +1,463 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +%{ +#include +#include +#include +#include "decl.h" + +int line_num=1; +extern FILE * convert_in; + +int convert_error(const char *s) +{ + printf("##\n## ERROR in conv: '%s' (line %d, file: %s)\n##\n", s, line_num, config_file); + exit(0); +} + +%} + +%union { + char na[LONG_M]; +} + +%token TOK_SEP +%token TOK_KIND +%token TOK_EQUAL +%token TOK_USE +%token TOK_MODULEMAIN /* name of the module */ +%token TOK_NOTGRIDDEP /* Variable which are not grid dependent */ +%token TOK_USEITEM +%token TOK_NAME +%token TOK_CSTINT +%token TOK_PROBTYPE /* dimension of the problem */ +%token ',' +%token ';' + +%% + +input : + | input line ; + +line : + '\n' + | TOK_PROBTYPE TOK_NAME ';' { initdimprob(1,$2,"0","0"); } + | TOK_PROBTYPE TOK_NAME ',' TOK_NAME ';' { initdimprob(2,$2, $4,"0"); } + | TOK_PROBTYPE TOK_NAME ',' TOK_NAME ',' TOK_NAME ';' { initdimprob(3,$2, $4, $6); } + | TOK_MODULEMAIN TOK_NAME ';' + { + listofmodules = Addtolistnom($2,listofmodules,0); + Addmoduletothelist($2); + } + | TOK_KIND TOK_NAME TOK_EQUAL TOK_CSTINT ';' + { + if (!strcasecmp($4,"4")) + { + listofkind = Addtolistnom($2,listofkind,4); + } + else if (!strcasecmp($4,"8")) + { + listofkind = Addtolistnom($2,listofkind,8); + } + else + { + printf("##\n## Unknown kind type : %s (must be 4 or 8)\n##",$4); + exit(0); + } + } + | TOK_NOTGRIDDEP TOK_SEP TOK_NAME ';' + { + Add_NotGridDepend_Var_1($3); + } + | TOK_USE TOK_USEITEM ';' + { + if (!strcasecmp($2,"FIXED_GRIDS")) fixedgrids = 1; + if (!strcasecmp($2,"ONLY_FIXED_GRIDS")) onlyfixedgrids = 1; + } + ; +%% + +void print_usage() +{ + printf("usage : conv -convfile \n"); + printf(" [-workdir ] [-incdir ]\n"); + printf(" [-comdirin ] [-comdirout ]\n"); + printf(" [-convfile ] [-SubloopScalar] [-SubloopScalar1] \n"); + printf(" [-free|-fixed]\n"); + exit(0); +} + +int main(int argc,char *argv[]) +{ + extern FILE * convert_in ; + FILE *dependglobaloutput; + int i; + listnom *parcours; + listvar *newvar; + int stylegiven = 0; + int infreegiven ; + int infixedgiven ; + int lengthmainfile; + + char filetoparse[LONG_FNAME]; + +/******************************************************************************/ +/* 1- Variables initialization */ +/******************************************************************************/ + List_Global_Var = (listvar *) NULL; + List_GlobalParameter_Var = (listvar *) NULL; + List_Common_Var = (listvar *) NULL; + List_Allocate_Var = (listallocate *) NULL; + List_SubroutineWhereAgrifUsed = (listnom *) NULL; + List_Subroutine_For_Alloc = (listnom *) NULL; + List_Include = (listusemodule *) NULL; + List_NameOfModuleUsed = (listusemodule *) NULL; + listofmoduletmp = (listusemodule *) NULL; + List_SubroutineDeclaration_Var = (listvar *) NULL; + List_UsedInSubroutine_Var = (listvar *) NULL; + List_NotGridDepend_Var = (listvar *) NULL; + Listofavailableindices = (listindice *) NULL; + Listofavailableindices_glob = (listindice **) calloc(NB_CAT_VARIABLES,sizeof(listindice *)); + List_CouplePointed_Var = (listvarpointtovar *) NULL; + List_ModuleUsed_Var = (listvar *) NULL; + List_ModuleUsedInModuleUsed_Var = (listvar *) NULL; + List_GlobParamModuleUsed_Var = (listparameter *) NULL; + List_GlobParamModuleUsedInModuleUsed_Var = (listparameter *) NULL; + List_SubroutineArgument_Var = (listvar *) NULL; + List_FunctionType_Var = (listvar *) NULL; + tmpuselocallist = (listusemodule *) NULL; + List_ContainsSubroutine = (listnom *) NULL; + oldfortran_out = (FILE *) NULL; + + if (argc < 2) print_usage(); + + strcpy(config_file, argv[1]); + strcpy(work_dir, "."); + strcpy(input_dir, "."); + strcpy(output_dir, "AGRIF_MODELFILES"); + strcpy(include_dir, "AGRIF_INC"); + strcpy(filetoparse, ""); + strcpy(subofagrifinitgrids, ""); + strcpy(meetagrifinitgrids, ""); + strcpy(mpiinitvar, ""); + + length_last = 0 ; + length_first = 0 ; + length_v_vallengspec = 0 ; + length_v_commoninfile = 0 ; + length_v_precision = 0 ; + length_v_IntentSpec = 0 ; + length_v_initialvalue = 0 ; + length_v_readedlistdimension = 0 ; + length_a_nomvar = 0 ; + length_toprintglob = 0 ; + length_tmpvargridname = 0 ; + length_ligne_Subloop = 0 ; + length_toprint_utilagrif = 0 ; + length_toprinttmp_utilchar = 0 ; + length_ligne_writedecl = 0 ; + length_newname_toamr = 0 ; + length_newname_writedecl = 0 ; + length_ligne_toamr = 0 ; + length_tmpligne_writedecl = 0 ; + value_char_size = 0 ; + value_char_size1 = 0 ; + value_char_size2 = 0 ; + value_char_size3 = 0 ; + inallocate = 0; + infixed = 1; + infree = 0; + + onlyfixedgrids=0; + fixedgrids=0; + InAgrifParentDef = 0; + IndicenbmaillesX=0; + IndicenbmaillesY=0; + IndicenbmaillesZ=0; + created_dimensionlist = 1; + /* current indice in the table tabvars */ + for ( i=0 ; i.in */ +/******************************************************************************/ + + if ( strstr(filetoparse, ".f90") || strstr(filetoparse, ".F90") ) retour77 = 0; + + convert_parse(); + +/******************************************************************************/ +/* 4- Preparation of the file parsing */ +/******************************************************************************/ + + sprintf(dependfilename, "%s/.dependglobal_agrif", work_dir); + /* */ + if ( (dependglobaloutput=fopen(dependfilename, "r")) != NULL ) + { + for (i=0;ivar->v_nomvar, + newvar->var->v_nbdim, + newvar->var->v_subroutinename, + newvar->var->v_modulename, + newvar->var->v_typevar); + newvar = newvar->suiv; + } + +/******************************************************************************/ +/* 6- Write informations in output files */ +/******************************************************************************/ + + /* Write the .dependglobal_agrif file which contain the max indice */ + /* of the tabvars table */ + sprintf(dependfilename, "%s/.dependglobal_agrif", work_dir); + dependglobaloutput = fopen(dependfilename, "w"); + for (i=0;i file which contain general informations */ + /* about variable of this file */ + parcours = List_NameOfModule; + while( parcours ) + { + Writethedependlistofmoduleused(parcours->o_nom); + WritedependParameterList(parcours->o_nom); + Writethedependfile(parcours->o_nom,List_Global_Var); + parcours=parcours->suiv; + } + parcours = List_NameOfCommon; + while( parcours ) + { + Writethedependfile(parcours->o_nom,List_Common_Var); + parcours=parcours->suiv; + } + Write_Subroutine_For_Alloc(); + +/******************************************************************************/ +/* 7- Create files in AGRIF_INC directory */ +/******************************************************************************/ + + creefichieramr(); + + Write_val_max(); + + if ( todebug == 1 ) printf("Out of CONV \n"); + return 0; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/decl.h b/V4.0/nemo_sources/ext/AGRIF/LEX/decl.h new file mode 120000 index 0000000000000000000000000000000000000000..ba9e585957ba2c228023e0eefd6227ffa4290ee7 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/decl.h @@ -0,0 +1 @@ +../LIB/decl.h \ No newline at end of file diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.lex b/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.lex new file mode 100644 index 0000000000000000000000000000000000000000..d7b7ab43efdd311ecd38e4fe0a435fa2ca712362 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.lex @@ -0,0 +1,294 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +%option warn +%option noyywrap + +%x parameter +%s character +%x donottreat +%s fortran77style +%s fortran90style +%{ +#include +#include +#include +extern FILE * yyin; +#define MAX_INCLUDE_DEPTH 30 +YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; +int line_num_input = 1; +int newlinef90 = 0; +char tmpc; +#define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } +#define INCREMENT_LINE_NUM() { line_num_input++; PRINT_LINE_NUM(); } + +/******************************************************************************/ +/**************PETITS PB NON PREVUS *******************************************/ +/******************************************************************************/ +/* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */ +/* a prevu seulement & a=b avec l'espace entre le symbole */ +/* de la 7eme et le debut de la ligne de commande */ +/* le ! est aussi interdit comme symbole de la 7 eme colonne */ +/* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */ +/******************************************************************************/ +#define YY_USER_ACTION if (firstpass == 0) ECHO; + +void out_of_donottreat(void); + +%} + +REAL8 "real*8"[ \t]*"(a-h,o-z)" + +SLASH "/" +DSLASH "/"[ \t]*"/" +HEXA Z\'[0-9a-fA-F]+\' +NAME [a-zA-Z\_][a-zA-Z0-9\_]* +INTEGER [0-9]+ + +EXPONENT [edq][-+]?{INTEGER} + +BEG_DNT ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]*\n +END_DNT ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]*\n + +BEG_INTERFACE ^[ \t]*interface +END_INTERFACE ^[ \t]*end[ \t]*interface.*\n + +ASSIGNTYPE "assignment"[ \t]*"("[ \t]*[-+=]+[ \t]*")" + +COMM_F77 ^([Cc*](([ \t]*\n)|([^AaHhOo\n].*\n))) +COMM_F90 ^[ \t]*!.*\n +COMM_F90_2 !.* +NEXTLINEF90 "&".*\n+ +NEXTLINEF77 [\n \t]*\n[ \t]{5}("&"|"+"|"$"|"*"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"|"."|"#") + +LABEL ^(((" "|[0-9]){1,5})|([ \t]{1,5}))[ &]+ + +%% + if (infixed) BEGIN(fortran77style) ; + if (infree) BEGIN(fortran90style) ; + +{REAL8} { return TOK_REAL8; } +subroutine { return TOK_SUBROUTINE; } +program { return TOK_PROGRAM; } +allocate { inallocate = 1; return TOK_ALLOCATE; } +nullify { return TOK_NULLIFY; } +null[ ]*\([ ]*\) { return TOK_NULL_PTR; } +deallocate { inallocate = 1; return TOK_DEALLOCATE; } +result { return TOK_RESULT; } +function { return TOK_FUNCTION; } +end[ \t]*program { strcpy(yylval.na,fortran_text); return TOK_ENDPROGRAM;} +end[ \t]*module { strcpy(yylval.na,fortran_text); return TOK_ENDMODULE; } +end[ \t]*subroutine { strcpy(yylval.na,fortran_text); return TOK_ENDSUBROUTINE;} +end[ \t]*function { strcpy(yylval.na,fortran_text); return TOK_ENDFUNCTION;} +end { strcpy(yylval.na,fortran_text); return TOK_ENDUNIT;} +include { pos_curinclude = setposcur()-9; return TOK_INCLUDE;} +^[ \t]*use[ ]+ { strcpy(yylval.na,fortran_text); + tmpc = (char) input(); unput(tmpc); + if ( ( tmpc >= 'a' && tmpc <= 'z' ) || + ( tmpc >= 'A' && tmpc <= 'Z' ) ) return TOK_USE; + else return TOK_NAME; + } +rewind { return TOK_REWIND; } +implicit { return TOK_IMPLICIT; } +none { return TOK_NONE; } +call { return TOK_CALL; } +.true. { return TOK_TRUE; } +.false. { return TOK_FALSE; } +\=\> { return TOK_POINT_TO; } +{ASSIGNTYPE} { strcpy(yylval.na,fortran_text); return TOK_ASSIGNTYPE;} +\*\* { strcpy(yylval.na,fortran_text); return TOK_DASTER; } +\.[ \t]*eqv\. { strcpy(yylval.na,fortran_text); return TOK_EQV; } +\.[ \t]*eq\. { strcpy(yylval.na,fortran_text); return TOK_EQ; } +\.[ \t]*gt\. { strcpy(yylval.na,fortran_text); return TOK_GT; } +\.[ \t]*ge\. { strcpy(yylval.na,fortran_text); return TOK_GE; } +\.[ \t]*lt\. { strcpy(yylval.na,fortran_text); return TOK_LT; } +\.[ \t]*le\. { strcpy(yylval.na,fortran_text); return TOK_LE; } +\.[ \t]*neqv\. { strcpy(yylval.na,fortran_text); return TOK_NEQV;} +\.[ \t]*ne\. { strcpy(yylval.na,fortran_text); return TOK_NE; } +\.[ \t]*not\. { strcpy(yylval.na,fortran_text); return TOK_NOT; } +\.[ \t]*or\. { strcpy(yylval.na,fortran_text); return TOK_OR; } +\.[ \t]*xor\. { strcpy(yylval.na,fortran_text); return TOK_XOR; } +\.[ \t]*and\. { strcpy(yylval.na,fortran_text); return TOK_AND; } +module { return TOK_MODULE; } +while { return TOK_WHILE; } +concurrent { return TOK_CONCURRENT; } +end[ \t]*do { return TOK_ENDDO; } +do { return TOK_PLAINDO;} +real { strcpy(yylval.na,fortran_text); return TOK_REAL; } +integer { strcpy(yylval.na,fortran_text); return TOK_INTEGER; } +logical { strcpy(yylval.na,fortran_text); return TOK_LOGICAL; } +character { strcpy(yylval.na,fortran_text); return TOK_CHARACTER; } +{HEXA} { strcpy(yylval.na,fortran_text); return TOK_HEXA;} +double[ \t]*precision { strcpy(yylval.na,fortran_text); return TOK_DOUBLEPRECISION; } +double[ \t]*complex { strcpy(yylval.na,fortran_text); return TOK_DOUBLECOMPLEX; } +complex { return TOK_COMPLEX; } +allocatable { return TOK_ALLOCATABLE; } +close { return TOK_CLOSE; } +inquire { return TOK_INQUIRE; } +dimension { return TOK_DIMENSION; } +pause { return TOK_PAUSE; } +equivalence { return TOK_EQUIVALENCE; } +stop { return TOK_STOP; } +where { return TOK_WHERE; } +end[ \t]*where { return TOK_ENDWHERE; } +else[ \t]*where[ \t]*\( { return TOK_ELSEWHEREPAR; } +else[ \t]*where { return TOK_ELSEWHERE; } +^[ \t]*contains { return TOK_CONTAINS; } +only { return TOK_ONLY; } +parameter { return TOK_PARAMETER; } +recursive { return TOK_RECURSIVE; } +common { return TOK_COMMON; } +^[ \t]*global[ \t]+ { return TOK_GLOBAL; } +external { return TOK_EXTERNAL; } +intent { return TOK_INTENT; } +pointer { return TOK_POINTER; } +optional { return TOK_OPTIONAL; } +save { return TOK_SAVE; } +^[ \t]*type[ \t]*\( { pos_cur_decl = setposcur()-5; return TOK_TYPEPAR; } +^[ \t]*type[ \t\,]+ { return TOK_TYPE; } +end[ \t]*type { return TOK_ENDTYPE; } +stat { if (inallocate == 1) return TOK_STAT; else { strcpy(yylval.na,fortran_text); return TOK_NAME; } } +open { return TOK_OPEN; } +return { return TOK_RETURN; } +exit[^(] { return TOK_EXIT; } +print { return TOK_PRINT; } +module[ \t]*procedure { return TOK_PROCEDURE; } +read { return TOK_READ; } +namelist { return TOK_NAMELIST; } +write { return TOK_WRITE; } +flush { return TOK_FLUSH; } +target { return TOK_TARGET; } +public { return TOK_PUBLIC; } +private { return TOK_PRIVATE; } +in { strcpy(yylval.na,fortran_text); return TOK_IN; } +^[ \t]*data[ \t]+ { pos_curdata = setposcur()-strlen(fortran_text); Init_List_Data_Var(); return TOK_DATA; } +continue { return TOK_CONTINUE; } +go[ \t]*to { return TOK_PLAINGOTO; } +out { strcpy(yylval.na,fortran_text); return TOK_OUT; } +inout { strcpy(yylval.na,fortran_text); return TOK_INOUT; } +intrinsic { return TOK_INTRINSIC; } +then { return TOK_THEN; } +else[ \t]*if { return TOK_ELSEIF; } +else { return TOK_ELSE; } +end[ \t]*if { return TOK_ENDIF; } +if { return TOK_LOGICALIF; } +sum[ \t]*\( { return TOK_SUM; } +max[ \t]*\( { return TOK_MAX; } +tanh { return TOK_TANH; } +maxval { return TOK_MAXVAL; } +trim { return TOK_TRIM; } +sqrt\( { return TOK_SQRT; } +select[ \t]*case { return TOK_SELECTCASE; } +^[ \t]*case[ \t]* { return TOK_CASE; } +default { return TOK_DEFAULT; } +end[ \t]*select { return TOK_ENDSELECT; } +file[ \t]*\= { return TOK_FILE; } +unit[ \t]*\= { return TOK_UNIT; } +fmt[ \t]*\= { return TOK_FMT; } +nml[ \t]*\= { return TOK_NML; } +end[ \t]*\= { return TOK_END; } +eor[ \t]*\= { return TOK_EOR; } +err[ \t]*\= { return TOK_ERR; } +exist[ \t]*\= { return TOK_EXIST; } +min[ \t]*\( { return TOK_MIN; } +nint { return TOK_NINT; } +float { return TOK_FLOAT; } +exp { return TOK_EXP; } +cos { return TOK_COS; } +cosh { return TOK_COSH; } +acos { return TOK_ACOS; } +sin { return TOK_SIN; } +sinh { return TOK_SINH; } +asin { return TOK_ASIN; } +log { return TOK_LOG; } +tan { return TOK_TAN; } +atan { return TOK_ATAN; } +cycle { return TOK_CYCLE; } +abs[ \t]*\( { return TOK_ABS; } +mod { return TOK_MOD; } +sign[ \t]*\( { return TOK_SIGN; } +minloc { return TOK_MINLOC; } +maxloc { return TOK_MAXLOC; } +minval { return TOK_MINVAL; } +backspace { return TOK_BACKSPACE; } +:: { return TOK_FOURDOTS; } +\({SLASH} { return TOK_LEFTAB; } +{SLASH}\) { return TOK_RIGHTAB; } +format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\) { + return TOK_FORMAT; } +{SLASH} { strcpy(yylval.na,fortran_text); return TOK_SLASH; } +DSLASH { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } +(\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\') { + strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } +(\')[^']*(\') { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } +(\")[^"]*(\") { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } +{BEG_INTERFACE} { BEGIN(donottreat); } +{END_INTERFACE} { out_of_donottreat(); return '\n'; } +{NAME} { strcpy(yylval.na,fortran_text); return TOK_NAME; } +({INTEGER}\.[0-9]*)/[^"and."|"false."|"true."|"eq."|"or."|"gt."|"ge."|"lt."|"le."|"not."|"ne."] { // REAL1 + strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } +(({INTEGER}\.[0-9]+|[0-9]*\.{INTEGER}){EXPONENT}?)|{INTEGER}(\.)?{EXPONENT} { // REAL2 + strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } +{INTEGER} { strcpy(yylval.na,fortran_text); return TOK_CSTINT; } +\$ {} +\. {} +\(|\)|:|\[|\]|\+|\-|\* { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } +\% { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } +\; { return TOK_SEMICOLON; } +\, { return (int) *fortran_text; } +\= { return (int) *fortran_text; } +\< { return (int) *fortran_text; } +\> { return (int) *fortran_text; } +\n { INCREMENT_LINE_NUM() ; return '\n'; } +^[ ]*$ {} +[ \t]+ {} +{LABEL} { if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0; } +{NEXTLINEF90} { INCREMENT_LINE_NUM() ; newlinef90=1; } +{NEXTLINEF77} { INCREMENT_LINE_NUM() ; } + +{BEG_DNT} { INCREMENT_LINE_NUM() ; BEGIN(donottreat); } +{END_DNT} { out_of_donottreat(); return '\n'; } +.*\n { INCREMENT_LINE_NUM() ; } +{COMM_F77} { INCREMENT_LINE_NUM() ; } +{COMM_F90} { INCREMENT_LINE_NUM() ; } +{COMM_F90_2} {} +%% + +void out_of_donottreat ( void ) +{ + BEGIN(INITIAL); + if (infixed) BEGIN(fortran77style) ; + if (infree) BEGIN(fortran90style) ; + INCREMENT_LINE_NUM() ; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.y b/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.y new file mode 100644 index 0000000000000000000000000000000000000000..9ebf9c086e7db48fad9ecba5d311a8375e7b1631 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LEX/fortran.y @@ -0,0 +1,2225 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ + +%{ +#define YYMAXDEPTH 1000 +#include +#include +#include +#include "decl.h" + +extern int line_num_input; +extern char *fortran_text; + +char c_selectorname[LONG_M]; +char ligne[LONG_M]; +char truename[LONG_VNAME]; +char identcopy[LONG_VNAME]; +int c_selectorgiven=0; +listvar *curlistvar; +typedim c_selectordim; +listcouple *coupletmp; +int removeline=0; +listvar *test; + +int fortran_error(const char *s) +{ + printf("%s line %d, file %s motclef = |%s|\n", s, line_num_input, cur_filename, fortran_text); + exit(1); +} + +%} + +%union { + char na[LONG_M]; + listdim *d; + listvar *l; + listcouple *lc; + listname *lnn; + typedim dim1; + variable *v; +} + +%left ',' +%nonassoc ':' +%right '=' +%left TOK_EQV TOK_NEQV +%left TOK_OR TOK_XOR +%left TOK_AND +%left TOK_NOT +%nonassoc TOK_LT TOK_GT TOK_LE TOK_GE TOK_EQ TOK_NE +%left TOK_DSLASH +%left '+' '-' +%left '*' TOK_SLASH +%right TOK_DASTER + +%token TOK_SEMICOLON +%token TOK_PARAMETER +%token TOK_RESULT +%token TOK_ONLY +%token TOK_INCLUDE +%token TOK_SUBROUTINE +%token TOK_PROGRAM +%token TOK_FUNCTION +%token TOK_FORMAT +%token TOK_MAX +%token TOK_TANH +%token TOK_WHERE +%token TOK_ELSEWHEREPAR +%token TOK_ELSEWHERE +%token TOK_ENDWHERE +%token TOK_MAXVAL +%token TOK_TRIM +%token TOK_NULL_PTR +%token TOK_SUM +%token TOK_SQRT +%token TOK_CASE +%token TOK_SELECTCASE +%token TOK_FILE +%token TOK_UNIT +%token TOK_FMT +%token TOK_NML +%token TOK_END +%token TOK_EOR +%token TOK_ERR +%token TOK_EXIST +%token TOK_MIN +%token TOK_FLOAT +%token TOK_EXP +%token TOK_COS +%token TOK_COSH +%token TOK_ACOS +%token TOK_NINT +%token TOK_CYCLE +%token TOK_SIN +%token TOK_SINH +%token TOK_ASIN +%token TOK_EQUIVALENCE +%token TOK_BACKSPACE +%token TOK_LOG +%token TOK_TAN +%token TOK_ATAN +%token TOK_RECURSIVE +%token TOK_ABS +%token TOK_MOD +%token TOK_SIGN +%token TOK_MINLOC +%token TOK_MAXLOC +%token TOK_EXIT +%token TOK_MINVAL +%token TOK_PUBLIC +%token TOK_PRIVATE +%token TOK_ALLOCATABLE +%token TOK_RETURN +%token TOK_THEN +%token TOK_ELSEIF +%token TOK_ELSE +%token TOK_ENDIF +%token TOK_PRINT +%token TOK_PLAINGOTO +%token TOK_LOGICALIF +%token TOK_PLAINDO +%token TOK_CONTAINS +%token TOK_ENDDO +%token TOK_MODULE +%token TOK_ENDMODULE +%token TOK_WHILE +%token TOK_CONCURRENT +%token TOK_ALLOCATE +%token TOK_OPEN +%token TOK_CLOSE +%token TOK_INQUIRE +%token TOK_WRITE +%token TOK_FLUSH +%token TOK_READ +%token TOK_REWIND +%token TOK_DEALLOCATE +%token TOK_NULLIFY +%token TOK_DIMENSION +%token TOK_ENDSELECT +%token TOK_EXTERNAL +%token TOK_INTENT +%token TOK_INTRINSIC +%token TOK_NAMELIST +%token TOK_DEFAULT +%token TOK_OPTIONAL +%token TOK_POINTER +%token TOK_CONTINUE +%token TOK_SAVE +%token TOK_TARGET +%token TOK_IMPLICIT +%token TOK_NONE +%token TOK_CALL +%token TOK_STAT +%token TOK_POINT_TO +%token TOK_COMMON +%token TOK_GLOBAL +%token TOK_LEFTAB +%token TOK_RIGHTAB +%token TOK_PAUSE +%token TOK_PROCEDURE +%token TOK_STOP +%token TOK_REAL8 +%token TOK_FOURDOTS +%token TOK_HEXA +%token TOK_ASSIGNTYPE +%token TOK_OUT +%token TOK_INOUT +%token TOK_IN +%token TOK_USE +%token TOK_DSLASH +%token TOK_DASTER +%token TOK_EQ +%token TOK_EQV +%token TOK_GT +%token TOK_LT +%token TOK_GE +%token TOK_NE +%token TOK_NEQV +%token TOK_LE +%token TOK_OR +%token TOK_XOR +%token TOK_NOT +%token TOK_AND +%token TOK_TRUE +%token TOK_FALSE +%token TOK_LABEL +%token TOK_TYPE +%token TOK_TYPEPAR +%token TOK_ENDTYPE +%token TOK_REAL +%token TOK_INTEGER +%token TOK_LOGICAL +%token TOK_DOUBLEPRECISION +%token TOK_ENDSUBROUTINE +%token TOK_ENDFUNCTION +%token TOK_ENDPROGRAM +%token TOK_ENDUNIT +%token TOK_CHARACTER +%token TOK_CHAR_CONSTANT +%token TOK_CHAR_CUT +%token TOK_DATA +%token TOK_CHAR_MESSAGE +%token TOK_CSTREAL +%token TOK_COMPLEX +%token TOK_DOUBLECOMPLEX +%token TOK_NAME +%token TOK_SLASH +%token TOK_CSTINT +%token ',' +%token ':' +%token '(' +%token ')' +%token '<' +%token '>' +%type dcl +%type after_type +%type dimension +%type paramlist +%type args +%type arglist +%type only_list +%type only_name +%type rename_list +%type rename_name +%type dims +%type dimlist +%type dim +%type paramitem +%type comblock +%type name_routine +%type opt_name +%type type +%type word_endsubroutine +%type word_endfunction +%type word_endprogram +%type word_endunit +%type typespec +%type string_constant +%type simple_const +%type ident +%type intent_spec +%type signe +%type opt_signe +%type filename +%type attribute +%type complex_const +%type begin_array +%type clause +%type arg +%type uexpr +%type minmaxlist +%type lhs +%type vec +%type outlist +%type other +%type dospec +%type expr_data +%type structure_component +%type array_ele_substring_func_ref +%type funarglist +%type funarg +%type funargs +%type triplet +%type substring +%type opt_substring +%type opt_expr +%type optexpr +%type data_stmt_value_list +%type datanamelist +%type after_slash +%type after_equal +%type predefinedfunction +%type expr +%type ubound +%type operation +%type proper_lengspec +%type use_name_list +%type public + +%% +input : + | input line + ; +line : line-break + | suite_line_list + | TOK_LABEL suite_line_list + | error {yyerrok;yyclearin;} + ; +line-break: + '\n' fin_line + | TOK_SEMICOLON + | line-break '\n' fin_line + | line-break TOK_SEMICOLON + | line-break TOK_LABEL + ; +suite_line_list : + suite_line + | suite_line_list TOK_SEMICOLON '\n' + | suite_line_list TOK_SEMICOLON suite_line + ; +suite_line : + entry fin_line /* subroutine, function, module */ + | spec fin_line /* declaration */ + | TOK_INCLUDE filename fin_line + { + if (inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); + } + } + | execution-part-construct + ; + +fin_line : { pos_cur = setposcur(); } + ; + +opt_recursive : { isrecursive = 0; } + | TOK_RECURSIVE { isrecursive = 1; } + ; + +opt_result : { is_result_present = 0; } + | TOK_RESULT arglist_after_result { is_result_present = 1; } + ; + +entry : opt_recursive TOK_SUBROUTINE name_routine arglist + { + insubroutinedeclare = 1; + if ( firstpass ) + Add_SubroutineArgument_Var_1($4); + else + WriteBeginof_SubLoop(); + } + | TOK_PROGRAM name_routine + { + insubroutinedeclare = 1; + inprogramdeclare = 1; + /* in the second step we should write the head of */ + /* the subroutine sub_loop_ */ + if ( ! firstpass ) + WriteBeginof_SubLoop(); + } + | opt_recursive TOK_FUNCTION name_routine arglist opt_result + { + insubroutinedeclare = 1; + strcpy(DeclType, ""); + /* we should to list of the subroutine argument the */ + /* name of the function which has to be defined */ + if ( firstpass ) + { + Add_SubroutineArgument_Var_1($4); + if ( ! is_result_present ) + Add_FunctionType_Var_1($3); + } + else + /* in the second step we should write the head of */ + /* the subroutine sub_loop_ */ + WriteBeginof_SubLoop(); + } + | TOK_MODULE TOK_NAME + { + GlobalDeclaration = 0; + strcpy(curmodulename,$2); + strcpy(subroutinename,""); + Add_NameOfModule_1($2); + if ( inmoduledeclare == 0 ) + { + /* To know if there are in the module declaration */ + inmoduledeclare = 1; + /* to know if a module has been met */ + inmodulemeet = 1; + /* to know if we are after the keyword contains */ + aftercontainsdeclare = 0 ; + } + } + ; + +/* R312 : label */ +label: TOK_CSTINT + | label TOK_CSTINT + ; + +name_routine : TOK_NAME { strcpy($$, $1); strcpy(subroutinename, $1); } + ; +filename : TOK_CHAR_CONSTANT { Add_Include_1($1); } + ; +arglist : { if ( firstpass ) $$=NULL; } + | '(' ')' { if ( firstpass ) $$=NULL; } + | '(' args ')' { if ( firstpass ) $$=$2; } + ; +arglist_after_result: + | '(' ')' + | '(' args ')' { if ( firstpass ) Add_SubroutineArgument_Var_1($2); } + ; +args : arg + { + if ( firstpass == 1 ) + { + strcpy(nameinttypenameback,nameinttypename); + strcpy(nameinttypename,""); + curvar = createvar($1,NULL); + strcpy(nameinttypename,nameinttypenameback); + curlistvar = insertvar(NULL,curvar); + $$ = settype("",curlistvar); + } + } + | args ',' arg + { + if ( firstpass == 1 ) + { + strcpy(nameinttypenameback,nameinttypename); + strcpy(nameinttypename,""); + curvar = createvar($3,NULL); + strcpy(nameinttypename,nameinttypenameback); + $$ = insertvar($1,curvar); + } + } + ; +arg : TOK_NAME { strcpy($$,$1); } + | '*' { strcpy($$,"*"); } + ; +spec : type after_type + | TOK_TYPE opt_spec opt_sep opt_name { inside_type_declare = 1; } + | TOK_ENDTYPE opt_name { inside_type_declare = 0; } + | TOK_POINTER list_couple + | before_parameter '(' paramlist ')' + { + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + if ( insubroutinedeclare ) Add_Parameter_Var_1($3); + else Add_GlobalParameter_Var_1($3); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out, pos_cur_decl, pos_end-pos_cur_decl); + } + } + VariableIsParameter = 0 ; + } + | before_parameter paramlist + { + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + if ( insubroutinedeclare ) Add_Parameter_Var_1($2); + else Add_GlobalParameter_Var_1($2); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); + } + } + VariableIsParameter = 0 ; + } + | common + | save + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); + } + | implicit + | dimension + { + /* if the variable is a parameter we can suppose that is */ + /* value is the same on each grid. It is not useless to */ + /* create a copy of it on each grid */ + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + Add_Globliste_1($1); + /* if variableparamlists has been declared in a subroutine */ + if ( insubroutinedeclare ) Add_Dimension_Var_1($1); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); + } + } + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + strcpy(NamePrecision,""); + c_star = 0; + InitialValueGiven = 0 ; + strcpy(IntentSpec,""); + VariableIsParameter = 0 ; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0 ; + dimsgiven=0; + c_selectorgiven=0; + strcpy(nameinttypename,""); + strcpy(c_selectorname,""); + } + | public + { + if (firstpass == 0) + { + if ($1) + { + removeglobfromlist(&($1)); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); + writelistpublic($1); + } + } + } + | private + | use_stat + | module_proc_stmt + | namelist + | TOK_BACKSPACE '(' expr ')' + | TOK_EXTERNAL opt_sep use_name_list + | TOK_INTRINSIC opt_sep use_intrinsic_list + | TOK_EQUIVALENCE list_expr_equi + | data_stmt '\n' + { + /* we should remove the data declaration */ + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); + + if ( aftercontainsdeclare == 1 && firstpass == 0 ) + { + ReWriteDataStatement_0(fortran_out); + pos_end = setposcur(); + } + } + ; +opt_spec : + | access_spec + { + PublicDeclare = 0 ; + PrivateDeclare = 0 ; + } + ; +name_intrinsic : + TOK_SUM + | TOK_TANH + | TOK_MAXVAL + | TOK_MIN + | TOK_MINVAL + | TOK_TRIM + | TOK_SQRT + | TOK_NINT + | TOK_FLOAT + | TOK_EXP + | TOK_COS + | TOK_COSH + | TOK_ACOS + | TOK_SIN + | TOK_SINH + | TOK_ASIN + | TOK_LOG + | TOK_TAN + | TOK_ATAN + | TOK_MOD + | TOK_SIGN + | TOK_MINLOC + | TOK_MAXLOC + | TOK_NAME + ; +use_intrinsic_list : + name_intrinsic + | use_intrinsic_list ',' name_intrinsic + ; +list_couple : + '(' list_expr ')' + | list_couple ',' '(' list_expr ')' + ; +list_expr_equi : + expr_equi + | list_expr_equi ',' expr_equi + ; +expr_equi : '(' list_expr_equi1 ')' + ; +list_expr_equi1 : + ident dims + | list_expr_equi1 ',' ident dims + ; +list_expr : + expr + | list_expr ',' expr + ; +opt_sep : + | TOK_FOURDOTS + ; +after_type : + dcl nodimsgiven + { + /* if the variable is a parameter we can suppose that is*/ + /* value is the same on each grid. It is not useless */ + /* to create a copy of it on each grid */ + if ( ! inside_type_declare ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); + ReWriteDeclarationAndAddTosubroutine_01($1); + pos_cur_decl = setposcur(); + if ( firstpass == 0 && GlobalDeclaration == 0 + && insubroutinedeclare == 0 ) + { + fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); + sprintf(ligne, "Module_Declar_%s.h", curmodulename); + module_declar = open_for_write(ligne); + GlobalDeclaration = 1 ; + pos_cur_decl = setposcur(); + } + $$ = $1; + + if ( firstpass ) + { + Add_Globliste_1($1); + if ( insubroutinedeclare ) + { + if ( pointerdeclare ) Add_Pointer_Var_From_List_1($1); + Add_Parameter_Var_1($1); + } + else + Add_GlobalParameter_Var_1($1); + + /* If there's a SAVE declaration in module's subroutines we should */ + /* remove it from the subroutines declaration and add it in the */ + /* global declarations */ + if ( aftercontainsdeclare && SaveDeclare ) + { + if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1($1); + else Add_Save_Var_dcl_1($1); + } + } + } + else + { + $$ = (listvar *) NULL; + } + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + strcpy(NamePrecision,""); + c_star = 0; + InitialValueGiven = 0 ; + strcpy(IntentSpec,""); + VariableIsParameter = 0 ; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0 ; + dimsgiven=0; + c_selectorgiven=0; + strcpy(nameinttypename,""); + strcpy(c_selectorname,""); + GlobalDeclarationType = 0; + } + | before_function name_routine arglist + { + insubroutinedeclare = 1; + + if ( firstpass ) + { + Add_SubroutineArgument_Var_1($3); + Add_FunctionType_Var_1($2); + } + else + WriteBeginof_SubLoop(); + + strcpy(nameinttypename,""); + } + ; +before_function : TOK_FUNCTION { functiondeclarationisdone = 1; } + ; +before_parameter : TOK_PARAMETER { VariableIsParameter = 1; pos_curparameter = setposcur()-9; } + ; + +data_stmt : /* R534 */ + TOK_DATA data_stmt_set_list + +data_stmt_set_list : + data_stmt_set + | data_stmt_set_list opt_comma data_stmt_set + +data_stmt_set : /* R535 */ + TOK_NAME TOK_SLASH data_stmt_value_list TOK_SLASH + { + createstringfromlistname(ligne,$3); + if (firstpass == 1) Add_Data_Var_1(&List_Data_Var,$1,ligne); + else Add_Data_Var_1(&List_Data_Var_Cur,$1,ligne); + } + | datanamelist TOK_SLASH data_stmt_value_list TOK_SLASH + { + if (firstpass == 1) Add_Data_Var_Names_01(&List_Data_Var,$1,$3); + else Add_Data_Var_Names_01(&List_Data_Var_Cur,$1,$3); + } + | '(' lhs ',' dospec ')' TOK_SLASH data_stmt_value_list TOK_SLASH + { + createstringfromlistname(ligne,$7); + printf("###################################################################################################################\n"); + printf("## CONV Error : data_implied_do statements (R537) are not yet supported. Please complain to the proper authorities.\n"); + printf("l.%4d -- data_stmt_set : ( lhs , dospec ) /data_stmt_value_list/ -- lhs=|%s| dospec=|%s| data_stmt_value_list=|%s|\n", + line_num_input,$2,$4,ligne); + printf("## But, are you SURE you NEED a DATA construct ?\n"); + printf("###################################################################################################################\n"); + exit(1); + } + ; + +data_stmt_value_list : + expr_data { $$ = Insertname(NULL,$1,0); } + | expr_data ',' data_stmt_value_list { $$ = Insertname($3,$1,1); } + ; + +save : before_save varsave + | before_save comblock varsave + | save opt_comma comblock opt_comma varsave + | save ',' varsave + ; +before_save : + TOK_SAVE { pos_cursave = setposcur()-4; } + ; +varsave : + | TOK_NAME dims { if ( ! inside_type_declare ) Add_Save_Var_1($1,$2); } + ; +datanamelist : + TOK_NAME { $$ = Insertname(NULL,$1,0); } + | TOK_NAME '(' expr ')' { printf("l.%4d -- INSTRUCTION NON TRAITEE : INITIALISATION DE DATA AVEC EXPRESSION\n",line_num_input); exit(0); } + | datanamelist ',' datanamelist { $$ = concat_listname($1,$3); } + ; +expr_data : + opt_signe simple_const { sprintf($$,"%s%s",$1,$2); } + | expr_data '+' expr_data { sprintf($$,"%s+%s",$1,$3); } + | expr_data '-' expr_data { sprintf($$,"%s-%s",$1,$3); } + | expr_data '*' expr_data { sprintf($$,"%s*%s",$1,$3); } + | expr_data '/' expr_data { sprintf($$,"%s/%s",$1,$3); } + ; +opt_signe : { strcpy($$,""); } + | signe { strcpy($$,$1); } + ; +namelist : + TOK_NAMELIST ident + | TOK_NAMELIST comblock ident + | namelist opt_comma comblock opt_comma ident + | namelist ',' ident + ; +before_dimension : + TOK_DIMENSION + { + positioninblock = 0; + pos_curdimension = setposcur()-9; + } + +dimension : + before_dimension opt_comma TOK_NAME dims lengspec + { + printf("l.%4d -- dimension : before_dimension opt_comma TOK_NAME = |%s| -- MHCHECK\n",line_num_input,$3); + if ( inside_type_declare ) break; + curvar = createvar($3,$4); + CreateAndFillin_Curvar("", curvar); + curlistvar=insertvar(NULL, curvar); + $$ = settype("",curlistvar); + strcpy(vallengspec,""); + } + | dimension ',' TOK_NAME dims lengspec + { + printf("l.%4d -- dimension : dimension ',' TOK_NAME dims lengspec = |%s| -- MHCHECK\n",line_num_input,$3); + if ( inside_type_declare ) break; + curvar = createvar($3,$4); + CreateAndFillin_Curvar("", curvar); + curlistvar = insertvar($1, curvar); + $$ = curlistvar; + strcpy(vallengspec,""); + } + ; +private : + TOK_PRIVATE '\n' + | TOK_PRIVATE opt_sep use_name_list + ; +public : + TOK_PUBLIC '\n' { $$ = (listname *) NULL; } + | TOK_PUBLIC opt_sep use_name_list { $$ = $3; } + ; +use_name_list : + TOK_NAME { $$ = Insertname(NULL,$1,0); } + | TOK_ASSIGNTYPE { $$ = Insertname(NULL,$1,0); } + | use_name_list ',' TOK_NAME { $$ = Insertname($1,$3,0); } + | use_name_list ',' TOK_ASSIGNTYPE { $$ = Insertname($1,$3,0); } + ; +common : + before_common var_common_list + { + if ( inside_type_declare ) break; + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + | before_common comblock var_common_list + { + if ( inside_type_declare ) break; + sprintf(charusemodule,"%s",$2); + Add_NameOfCommon_1($2,subroutinename); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + | common opt_comma comblock opt_comma var_common_list + { + if ( inside_type_declare ) break; + sprintf(charusemodule,"%s",$3); + Add_NameOfCommon_1($3,subroutinename); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + ; +before_common : + TOK_COMMON { positioninblock = 0; pos_curcommon = setposcur()-6; } + | TOK_GLOBAL TOK_COMMON { positioninblock = 0; pos_curcommon = setposcur()-6-7; } + ; +var_common_list : + var_common { if ( ! inside_type_declare ) Add_Common_var_1(); } + | var_common_list ',' var_common { if ( ! inside_type_declare ) Add_Common_var_1(); } + ; +var_common : + TOK_NAME dims + { + positioninblock = positioninblock + 1 ; + strcpy(commonvar,$1); + commondim = $2; + } + ; +comblock : + TOK_DSLASH + { + strcpy($$,""); + positioninblock=0; + strcpy(commonblockname,""); + } + | TOK_SLASH TOK_NAME TOK_SLASH + { + strcpy($$,$2); + positioninblock=0; + strcpy(commonblockname,$2); + } + ; +opt_comma : + | ',' + ; +paramlist : + paramitem { $$=insertvar(NULL,$1); } + | paramlist ',' paramitem { $$=insertvar($1,$3); } + ; +paramitem : + TOK_NAME '=' expr + { + if ( inside_type_declare ) break; + curvar=(variable *) calloc(1,sizeof(variable)); + Init_Variable(curvar); + curvar->v_VariableIsParameter = 1; + strcpy(curvar->v_nomvar,$1); + strcpy(curvar->v_subroutinename,subroutinename); + strcpy(curvar->v_modulename,curmodulename); + strcpy(curvar->v_initialvalue,$3); + strcpy(curvar->v_commoninfile,cur_filename); + Save_Length($3,14); + $$ = curvar; + } + ; +module_proc_stmt : + TOK_PROCEDURE proc_name_list + ; +proc_name_list : + TOK_NAME + | proc_name_list ',' TOK_NAME + ; +implicit : + TOK_IMPLICIT TOK_NONE + { + if ( insubroutinedeclare == 1 ) + { + Add_ImplicitNoneSubroutine_1(); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_end-13,13); + } + } + | TOK_IMPLICIT TOK_REAL8 + ; +dcl : options TOK_NAME dims lengspec initial_value + { + if ( ! inside_type_declare ) + { + if (dimsgiven == 1) curvar = createvar($2,curdim); + else curvar = createvar($2,$3); + CreateAndFillin_Curvar(DeclType, curvar); + curlistvar = insertvar(NULL, curvar); + if (!strcasecmp(DeclType,"character")) + { + if (c_selectorgiven == 1) + { + strcpy(c_selectordim.first,"1"); + strcpy(c_selectordim.last,c_selectorname); + Save_Length(c_selectorname,1); + change_dim_char(insertdim(NULL,c_selectordim),curlistvar); + } + } + $$=settype(DeclType,curlistvar); + } + strcpy(vallengspec,""); + } + | dcl ',' TOK_NAME dims lengspec initial_value + { + if ( ! inside_type_declare ) + { + if (dimsgiven == 1) curvar = createvar($3, curdim); + else curvar = createvar($3, $4); + CreateAndFillin_Curvar($1->var->v_typevar,curvar); + strcpy(curvar->v_typevar, $1->var->v_typevar); + curvar->v_catvar = get_cat_var(curvar); + curlistvar = insertvar($1, curvar); + if (!strcasecmp(DeclType,"character")) + { + if (c_selectorgiven == 1) + { + strcpy(c_selectordim.first,"1"); + strcpy(c_selectordim.last,c_selectorname); + Save_Length(c_selectorname,1); + change_dim_char(insertdim(NULL,c_selectordim),curlistvar); + } + } + $$=curlistvar; + } + strcpy(vallengspec,""); + } + ; +nodimsgiven : { dimsgiven = 0; } + ; +type : typespec selector { strcpy(DeclType,$1); } + | before_character c_selector { strcpy(DeclType,"character"); } + | typespec '*' TOK_CSTINT { strcpy(DeclType,$1); strcpy(nameinttypename,$3); } + | TOK_TYPEPAR attribute ')' { strcpy(DeclType,"type"); GlobalDeclarationType = 1; } + ; +c_selector : + | '*' TOK_CSTINT { c_selectorgiven = 1; strcpy(c_selectorname,$2); } + | '*' '(' c_attribute ')' { c_star = 1;} + | '(' c_attribute ')' + ; +c_attribute : + TOK_NAME clause opt_clause + | TOK_NAME '=' clause opt_clause + | clause opt_clause + ; +before_character : TOK_CHARACTER { pos_cur_decl = setposcur()-9; } + ; +typespec : + TOK_INTEGER { strcpy($$,"integer"); pos_cur_decl = setposcur()-7; } + | TOK_LOGICAL { strcpy($$,"logical"); pos_cur_decl = setposcur()-7; } + | TOK_REAL { strcpy($$,"real"); pos_cur_decl = setposcur()-4; } + | TOK_COMPLEX { strcpy($$,"complex"); pos_cur_decl = setposcur()-7; } + | TOK_DOUBLECOMPLEX { strcpy($$,"double complex"); pos_cur_decl = setposcur()-14; } + | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); } + ; +lengspec : + | '*' proper_lengspec {strcpy(vallengspec,$2);} + ; +proper_lengspec : + expr { sprintf($$,"*%s",$1); } + | '(' '*' ')' { strcpy($$,"*(*)"); } + ; +selector : + | '*' proper_selector + | '(' attribute ')' + ; +proper_selector : expr + | '(' '*' ')' + ; +attribute : + TOK_NAME clause + | TOK_NAME '=' clause + { + if ( strstr($3,"0.d0") ) + { + strcpy(nameinttypename,"8"); + strcpy(NamePrecision,""); + } + else + sprintf(NamePrecision,"%s = %s",$1,$3); + } + | TOK_NAME { strcpy(NamePrecision,$1); } + | TOK_CSTINT { strcpy(NamePrecision,$1); } + | TOK_ASSIGNTYPE { strcpy(NamePrecision,$1); } + ; +clause : + expr { strcpy(CharacterSize,$1); strcpy($$,$1); } + | '*' { strcpy(CharacterSize,"*"); strcpy($$,"*"); } + ; +opt_clause : + | ',' TOK_NAME clause + ; +options : + | TOK_FOURDOTS + | ',' attr_spec_list TOK_FOURDOTS + ; +attr_spec_list : attr_spec + | attr_spec_list ',' attr_spec + ; +attr_spec : + TOK_PARAMETER { VariableIsParameter = 1; } + | access_spec + | TOK_ALLOCATABLE { Allocatabledeclare = 1; } + | TOK_DIMENSION dims { dimsgiven = 1; curdim = $2; } + | TOK_EXTERNAL { ExternalDeclare = 1; } + | TOK_INTENT '(' intent_spec ')' + { strcpy(IntentSpec,$3); } + | TOK_INTRINSIC + | TOK_OPTIONAL { optionaldeclare = 1 ; } + | TOK_POINTER { pointerdeclare = 1 ; } + | TOK_SAVE { SaveDeclare = 1 ; } + | TOK_TARGET { Targetdeclare = 1; } + ; +intent_spec : + TOK_IN { strcpy($$,$1); } + | TOK_OUT { strcpy($$,$1); } + | TOK_INOUT { strcpy($$,$1); } + ; +access_spec : + TOK_PUBLIC { PublicDeclare = 1; } + | TOK_PRIVATE { PrivateDeclare = 1; } + ; +dims : { $$ = (listdim*) NULL; } + | '(' dimlist ')' + { + $$ = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=$2; + } + ; +dimlist : + dim + { + $$ = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=insertdim(NULL,$1); + } + | dimlist ',' dim + { + $$ = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( (!inside_type_declare) && created_dimensionlist == 1 ) $$=insertdim($1,$3); + } + ; +dim : ubound { strcpy($$.first,"1"); strcpy($$.last,$1); Save_Length($1,1); } + | ':' { strcpy($$.first,""); strcpy($$.last,""); } + | expr ':' { strcpy($$.first,$1); Save_Length($1,2); strcpy($$.last,""); } + | ':' expr { strcpy($$.first,""); strcpy($$.last,$2); Save_Length($2,1); } + | expr ':' ubound { strcpy($$.first,$1); Save_Length($1,2); strcpy($$.last,$3); Save_Length($3,1); } + ; +ubound : + '*' { strcpy($$,"*"); } + | expr { strcpy($$,$1); } + ; +expr : uexpr { strcpy($$,$1); } + | complex_const { strcpy($$,$1); } + | predefinedfunction { strcpy($$,$1); } + | '(' expr ')' { sprintf($$,"(%s)",$2); } + ; + +predefinedfunction : + TOK_SUM minmaxlist ')' { sprintf($$,"SUM(%s)",$2);} + | TOK_MAX minmaxlist ')' { sprintf($$,"MAX(%s)",$2);} + | TOK_TANH '(' minmaxlist ')' { sprintf($$,"TANH(%s)",$3);} + | TOK_MAXVAL '(' minmaxlist ')' { sprintf($$,"MAXVAL(%s)",$3);} + | TOK_MIN minmaxlist ')' { sprintf($$,"MIN(%s)",$2);} + | TOK_MINVAL '(' minmaxlist ')' { sprintf($$,"MINVAL(%s)",$3);} + | TOK_TRIM '(' expr ')' { sprintf($$,"TRIM(%s)",$3);} + | TOK_SQRT expr ')' { sprintf($$,"SQRT(%s)",$2);} + | TOK_REAL '(' minmaxlist ')' { sprintf($$,"REAL(%s)",$3);} + | TOK_NINT '(' expr ')' { sprintf($$,"NINT(%s)",$3);} + | TOK_FLOAT '(' expr ')' { sprintf($$,"FLOAT(%s)",$3);} + | TOK_EXP '(' expr ')' { sprintf($$,"EXP(%s)",$3);} + | TOK_COS '(' expr ')' { sprintf($$,"COS(%s)",$3);} + | TOK_COSH '(' expr ')' { sprintf($$,"COSH(%s)",$3);} + | TOK_ACOS '(' expr ')' { sprintf($$,"ACOS(%s)",$3);} + | TOK_SIN '(' expr ')' { sprintf($$,"SIN(%s)",$3);} + | TOK_SINH '(' expr ')' { sprintf($$,"SINH(%s)",$3);} + | TOK_ASIN '(' expr ')' { sprintf($$,"ASIN(%s)",$3);} + | TOK_LOG '(' expr ')' { sprintf($$,"LOG(%s)",$3);} + | TOK_TAN '(' expr ')' { sprintf($$,"TAN(%s)",$3);} + | TOK_ATAN '(' expr ')' { sprintf($$,"ATAN(%s)",$3);} + | TOK_ABS expr ')' { sprintf($$,"ABS(%s)",$2);} + | TOK_MOD '(' minmaxlist ')' { sprintf($$,"MOD(%s)",$3);} + | TOK_SIGN minmaxlist ')' { sprintf($$,"SIGN(%s)",$2);} + | TOK_MINLOC '(' minmaxlist ')' { sprintf($$,"MINLOC(%s)",$3);} + | TOK_MAXLOC '(' minmaxlist ')' { sprintf($$,"MAXLOC(%s)",$3);} + ; +minmaxlist : expr {strcpy($$,$1);} + | minmaxlist ',' expr { sprintf($$,"%s,%s",$1,$3); } + ; +uexpr : lhs { strcpy($$,$1); } + | simple_const { strcpy($$,$1); } + | vec { strcpy($$,$1); } + | expr operation { sprintf($$,"%s%s",$1,$2); } + | signe expr %prec '*' { sprintf($$,"%s%s",$1,$2); } + | TOK_NOT expr { sprintf($$,"%s%s",$1,$2); } + ; +signe : '+' { strcpy($$,"+"); } + | '-' { strcpy($$,"-"); } + ; + +operation : + '+' expr %prec '+' { sprintf($$,"+%s",$2); } + | '-' expr %prec '+' { sprintf($$,"-%s",$2); } + | '*' expr { sprintf($$,"*%s",$2); } + | TOK_DASTER expr { sprintf($$,"%s%s",$1,$2); } + | TOK_EQ expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | TOK_EQV expr %prec TOK_EQV { sprintf($$,"%s%s",$1,$2); } + | TOK_GT expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | '>' expr %prec TOK_EQ { sprintf($$," > %s",$2); } + | '<' expr %prec TOK_EQ { sprintf($$," < %s",$2); } + | '>''=' expr %prec TOK_EQ { sprintf($$," >= %s",$3); } + | '<''=' expr %prec TOK_EQ { sprintf($$," <= %s",$3); } + | TOK_LT expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | TOK_GE expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | TOK_LE expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | TOK_NE expr %prec TOK_EQ { sprintf($$,"%s%s",$1,$2); } + | TOK_NEQV expr %prec TOK_EQV { sprintf($$,"%s%s",$1,$2); } + | TOK_XOR expr { sprintf($$,"%s%s",$1,$2); } + | TOK_OR expr { sprintf($$,"%s%s",$1,$2); } + | TOK_AND expr { sprintf($$,"%s%s",$1,$2); } + | TOK_SLASH after_slash { sprintf($$,"%s",$2); } + | '=' after_equal { sprintf($$,"%s",$2); } + +after_slash : { strcpy($$,""); } + | expr { sprintf($$,"/%s",$1); } + | '=' expr %prec TOK_EQ { sprintf($$,"/= %s",$2);} + | TOK_SLASH expr { sprintf($$,"//%s",$2); } + ; +after_equal : + '=' expr %prec TOK_EQ { sprintf($$,"==%s",$2); } + | expr { sprintf($$,"= %s",$1); } + ; + +lhs : ident { strcpy($$,$1); } + | structure_component { strcpy($$,$1); } + | array_ele_substring_func_ref { strcpy($$,$1); } + ; + +beforefunctionuse : + { + agrif_parentcall = 0; + if ( !strcasecmp(identcopy, "Agrif_Parent") ) agrif_parentcall = 1; + if ( Agrif_in_Tok_NAME(identcopy) ) + { + inagrifcallargument = 1; + Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + } + } + ; +array_ele_substring_func_ref : + begin_array { strcpy($$,$1); if ( incalldeclare == 0 ) inagrifcallargument = 0; } + | begin_array substring { sprintf($$," %s %s ",$1,$2); } + | structure_component '(' funarglist ')' { sprintf($$," %s ( %s )",$1,$3); } + | structure_component '(' funarglist ')' substring { sprintf($$," %s ( %s ) %s ",$1,$3,$5); } + ; +begin_array : + ident '(' funarglist ')' + { + if ( inside_type_declare ) break; + sprintf($$," %s ( %s )",$1,$3); + ModifyTheAgrifFunction_0($3); + agrif_parentcall = 0; + } + ; +structure_component : + lhs '%' declare_after_percent lhs + { + sprintf($$," %s %% %s ",$1,$4); + if ( incalldeclare == 0 ) inagrifcallargument = 0; + } + ; +vec : + TOK_LEFTAB outlist TOK_RIGHTAB { sprintf($$,"(/%s/)",$2); } + ; +funarglist : + beforefunctionuse { strcpy($$," "); } + | beforefunctionuse funargs { strcpy($$,$2); } + ; +funargs : + funarg { strcpy($$,$1); } + | funargs ',' funarg { sprintf($$,"%s,%s",$1,$3); } + ; +funarg : + expr {strcpy($$,$1);} + | triplet {strcpy($$,$1);} + ; +triplet : + expr ':' expr { sprintf($$,"%s :%s",$1,$3);} + | expr ':' expr ':' expr { sprintf($$,"%s :%s :%s",$1,$3,$5);} + | ':' expr ':' expr { sprintf($$,":%s :%s",$2,$4);} + | ':' ':' expr { sprintf($$,": : %s",$3);} + | ':' expr { sprintf($$,":%s",$2);} + | expr ':' { sprintf($$,"%s :",$1);} + | ':' { sprintf($$,":");} + ; +ident : TOK_NAME + { + if ( afterpercent == 0 ) + { + if ( Agrif_in_Tok_NAME($1) ) Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + if ( !strcasecmp($1,"Agrif_Parent") ) agrif_parentcall = 1; + if ( VariableIsFunction($1) ) + { + if ( inagrifcallargument == 1 ) + { + if ( !strcasecmp($1,identcopy) ) + { + strcpy(sameagrifname,identcopy); + sameagrifargument = 1; + } + } + strcpy(identcopy,$1); + pointedvar = 0; + + if (variscoupled_0($1)) strcpy(truename, getcoupledname_0($1)); + else strcpy(truename, $1); + + if ( VarIsNonGridDepend(truename) == 0 && (! Variableshouldberemoved(truename)) ) + { + if ( inagrifcallargument == 1 || varispointer_0(truename) == 1 ) + { + if ( (IsinListe(List_UsedInSubroutine_Var,$1) == 1) || (inagrifcallargument == 1) ) + { + if (varistyped_0(truename) == 0) ModifyTheVariableName_0(truename,strlen($1)); + } + } + if ( inagrifcallargument != 1 || sameagrifargument ==1 ) + { + Add_UsedInSubroutine_Var_1(truename); + } + } + NotifyAgrifFunction_0(truename); + } + } + else + { + afterpercent = 0; + } + } + ; +simple_const : + TOK_TRUE { strcpy($$,".TRUE.");} + | TOK_FALSE { strcpy($$,".FALSE.");} + | TOK_NULL_PTR { strcpy($$,"NULL()"); } + | TOK_CSTINT { strcpy($$,$1); } + | TOK_CSTREAL { strcpy($$,$1); } + | TOK_HEXA { strcpy($$,$1); } + | simple_const TOK_NAME + { sprintf($$,"%s%s",$1,$2); } + | string_constant opt_substring + ; +string_constant : + TOK_CHAR_CONSTANT { strcpy($$,$1);} + | string_constant TOK_CHAR_CONSTANT + | TOK_CHAR_MESSAGE { strcpy($$,$1);} + | TOK_CHAR_CUT { strcpy($$,$1);} + ; +opt_substring : { strcpy($$," ");} + | substring { strcpy($$,$1);} + ; +substring : + '(' optexpr ':' optexpr ')' { sprintf($$,"(%s :%s)",$2,$4);} + ; +optexpr : { strcpy($$," ");} + | expr { strcpy($$,$1);} + ; +opt_expr : + '\n' { strcpy($$," ");} + | expr { strcpy($$,$1);} + ; +initial_value : { InitialValueGiven = 0; } + | '=' expr + { + if ( inside_type_declare ) break; + strcpy(InitValue,$2); + InitialValueGiven = 1; + } + | TOK_POINT_TO expr + { + if ( inside_type_declare ) break; + strcpy(InitValue,$2); + InitialValueGiven = 2; + } + ; +complex_const : + '(' uexpr ',' uexpr ')' {sprintf($$,"(%s,%s)",$2,$4); } + ; +use_stat : + word_use TOK_NAME + { + /* if variables has been declared in a subroutine */ + sprintf(charusemodule, "%s", $2); + if ( firstpass ) + { + Add_NameOfModuleUsed_1($2); + } + else + { + if ( insubroutinedeclare ) + copyuse_0($2); + + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + } + | word_use TOK_NAME ',' rename_list + { + if ( firstpass ) + { + if ( insubroutinedeclare ) + { + Add_CouplePointed_Var_1($2,$4); + coupletmp = $4; + strcpy(ligne,""); + while ( coupletmp ) + { + strcat(ligne, coupletmp->c_namevar); + strcat(ligne, " => "); + strcat(ligne, coupletmp->c_namepointedvar); + coupletmp = coupletmp->suiv; + if ( coupletmp ) strcat(ligne,","); + } + sprintf(charusemodule,"%s",$2); + } + Add_NameOfModuleUsed_1($2); + } + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + | word_use TOK_NAME ',' TOK_ONLY ':' '\n' + { + /* if variables has been declared in a subroutine */ + sprintf(charusemodule,"%s",$2); + if ( firstpass ) + { + Add_NameOfModuleUsed_1($2); + } + else + { + if ( insubroutinedeclare ) + copyuseonly_0($2); + + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + } + | word_use TOK_NAME ',' TOK_ONLY ':' only_list + { + /* if variables has been declared in a subroutine */ + if ( firstpass ) + { + if ( insubroutinedeclare ) + { + Add_CouplePointed_Var_1($2,$6); + coupletmp = $6; + strcpy(ligne,""); + while ( coupletmp ) + { + strcat(ligne,coupletmp->c_namevar); + if ( strcasecmp(coupletmp->c_namepointedvar,"") ) strcat(ligne," => "); + strcat(ligne,coupletmp->c_namepointedvar); + coupletmp = coupletmp->suiv; + if ( coupletmp ) strcat(ligne,","); + } + sprintf(charusemodule,"%s",$2); + } + Add_NameOfModuleUsed_1($2); + } + else /* if ( firstpass == 0 ) */ + { + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + if (oldfortran_out) variableisglobalinmodule($6,$2,oldfortran_out,pos_curuseold); + } + else + { + /* if we are in the module declare and if the */ + /* onlylist is a list of global variable */ + variableisglobalinmodule($6, $2, fortran_out,pos_curuse); + } + } + } + ; +word_use : + TOK_USE + { + pos_curuse = setposcur()-strlen($1); + if (firstpass == 0 && oldfortran_out) pos_curuseold = setposcurname(oldfortran_out); + } + ; +rename_list : + rename_name + { + $$ = $1; + } + | rename_list ',' rename_name + { + /* insert the variable in the list $1 */ + $3->suiv = $1; + $$ = $3; + } + ; +rename_name : TOK_NAME TOK_POINT_TO TOK_NAME + { + coupletmp = (listcouple *) calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,$1); + strcpy(coupletmp->c_namepointedvar,$3); + coupletmp->suiv = NULL; + $$ = coupletmp; + } + ; +only_list : + only_name { $$ = $1; } + | only_list ',' only_name + { + /* insert the variable in the list $1 */ + $3->suiv = $1; + $$ = $3; + } + ; +only_name : + TOK_NAME TOK_POINT_TO TOK_NAME + { + coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,$1); + strcpy(coupletmp->c_namepointedvar,$3); + coupletmp->suiv = NULL; + $$ = coupletmp; + pointedvar = 1; + Add_UsedInSubroutine_Var_1($1); + } + | TOK_NAME + { + coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,$1); + strcpy(coupletmp->c_namepointedvar,""); + coupletmp->suiv = NULL; + $$ = coupletmp; + } + ; + +/* R209 : execution-part-construct */ +execution-part-construct: + executable-construct + | format-stmt + ; + +/* R213 : executable-construct */ +executable-construct: + action-stmt + | do-construct + | case-construct + | if-construct + | where-construct + ; + +/* R214 : action-stmt */ +action-stmt : + TOK_CONTINUE + | ident_dims after_ident_dims + | goto + | call + | iofctl ioctl + | read option_read + | TOK_WRITE ioctl + | TOK_WRITE ioctl outlist + | TOK_REWIND after_rewind + | TOK_ALLOCATE '(' allocation_list opt_stat_spec ')' { inallocate = 0; } + | TOK_DEALLOCATE '(' allocate_object_list opt_stat_spec ')' { inallocate = 0; } + | TOK_EXIT optexpr + | TOK_RETURN opt_expr + | TOK_CYCLE opt_expr + | stop opt_expr + | int_list + | TOK_NULLIFY '(' pointer_name_list ')' + | word_endunit + { + GlobalDeclaration = 0 ; + if ( firstpass == 0 && strcasecmp(subroutinename,"") ) + { + if ( module_declar && insubroutinedeclare == 0 ) fclose(module_declar); + } + if ( strcasecmp(subroutinename,"") ) + { + if ( inmodulemeet == 1 ) + { + /* we are in a module */ + if ( insubroutinedeclare == 1 ) + { + /* it is like an end subroutine */ + insubroutinedeclare = 0 ; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(1); + functiondeclarationisdone = 0; + } + else + { + /* it is like an end module */ + inmoduledeclare = 0 ; + inmodulemeet = 0 ; + } + } + else + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(2); + functiondeclarationisdone = 0; + } + } + strcpy(subroutinename,""); + } + | word_endprogram opt_name + { + insubroutinedeclare = 0; + inprogramdeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(3); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + | word_endsubroutine opt_name + { + if ( strcasecmp(subroutinename,"") ) + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(1); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + } + | word_endfunction opt_name + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(0); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + | TOK_ENDMODULE opt_name + { + /* if we never meet the contains keyword */ + if ( firstpass == 0 ) + { + RemoveWordCUR_0(fortran_out, strlen($2)+11); // Remove word "end module" + if ( inmoduledeclare && ! aftercontainsdeclare ) + { + Write_Closing_Module(1); + } + fprintf(fortran_out,"\n end module %s\n", curmodulename); + if ( module_declar && insubroutinedeclare == 0 ) + { + fclose(module_declar); + } + } + inmoduledeclare = 0 ; + inmodulemeet = 0 ; + aftercontainsdeclare = 1; + strcpy(curmodulename, ""); + GlobalDeclaration = 0 ; + } + | if-stmt + | where-stmt + | TOK_CONTAINS + { + if ( inside_type_declare ) break; + if ( inmoduledeclare ) + { + if ( firstpass == 0 ) + { + RemoveWordCUR_0(fortran_out,9); // Remove word 'contains' + Write_Closing_Module(0); + } + inmoduledeclare = 0 ; + aftercontainsdeclare = 1; + } + else if ( insubroutinedeclare ) + { + incontainssubroutine = 1; + insubroutinedeclare = 0; + incontainssubroutine = 0; + functiondeclarationisdone = 0; + + if ( firstpass ) + List_ContainsSubroutine = Addtolistnom(subroutinename, List_ContainsSubroutine, 0); + else + closeandcallsubloop_contains_0(); + + strcpy(subroutinename, ""); + } + else printf("l.%4d -- TOK_CONTAINS -- MHCHECK\n",line_num_input); + } + ; + +/* R601 : variable */ +//variable : expr +// ; + +/* R734 : assignment-stmt */ +// assignment-stmt: variable '=' expr +// ; +assignment-stmt: expr + ; + +/* R741 : where-stmt */ +where-stmt: TOK_WHERE '(' mask-expr ')' where-assignment-stmt + ; + +/* R742 : where-construct */ +where-construct: where-construct-stmt line-break opt-where-body-construct opt-masked-elsewhere-construct opt-elsewhere-construct end-where-stmt + ; + +opt-where-body-construct: + | opt-where-body-construct where-body-construct line-break + ; + +opt-masked-elsewhere-construct : + | opt-masked-elsewhere-construct masked-elsewhere-stmt line-break opt-where-body-construct + ; + +opt-elsewhere-construct: + | opt-elsewhere-construct elsewhere-stmt line-break opt-where-body-construct + ; + +/* R743 : where-construct-stmt */ +where-construct-stmt: + TOK_WHERE '(' mask-expr ')' + ; + +/* R744 : where-body-construct */ +where-body-construct: where-assignment-stmt + | where-stmt + | where-construct + ; + +/* R745 : where-assignment-stmt */ +where-assignment-stmt: assignment-stmt + ; + +/* R746 : mask-expr */ +mask-expr: expr + ; + +/* R747 : masked-elsewhere-stmt */ +masked-elsewhere-stmt: + TOK_ELSEWHEREPAR mask-expr ')' + | TOK_ELSEWHEREPAR mask-expr ')' TOK_NAME + ; + +/* R748: elsewhere-stmt */ +elsewhere-stmt: + TOK_ELSEWHERE + | TOK_ELSEWHERE TOK_NAME + ; + +/* R749: end-where-stmt */ +end-where-stmt: + TOK_ENDWHERE + | TOK_ENDWHERE TOK_NAME + ; + +/* R752 : forall-header */ +forall-header : + ; + +/* R801 : block */ +block: + |block execution-part-construct + |block execution-part-construct line-break + ; + +/* R813 : do-construct */ +do-construct: + block-do-construct + ; + +/* R814 : block-do-construct */ +block-do-construct: + do-stmt line-break do-block end-do + ; + +/* R815 : do-stmt */ +do-stmt: + label-do-stmt + | nonlabel-do-stmt + ; + +/* R816 : label-do-stmt */ +label-do-stmt: + TOK_NAME ':' TOK_PLAINDO label + | TOK_PLAINDO label + | TOK_NAME ':' TOK_PLAINDO label loop-control + | TOK_PLAINDO label loop-control + ; + +/* R817 : nonlabel-do-stmt */ +nonlabel-do-stmt: + TOK_NAME ':' TOK_PLAINDO + | TOK_PLAINDO + | TOK_NAME ':' TOK_PLAINDO loop-control + | TOK_PLAINDO loop-control + ; + +/* R818 : loop-control */ +loop-control: + opt_comma do-variable '=' expr ',' expr + | opt_comma do-variable '=' expr ',' expr ',' expr + | opt_comma TOK_WHILE '(' expr ')' + | opt_comma TOK_CONCURRENT forall-header + ; + +/* R819 : do-variable */ +do-variable : ident + ; + +/* R820 : do-block */ +do-block: block + ; + +/* R821 : end-do */ +end-do: end-do-stmt + | continue-stmt + ; + +/* R822 : end-do-stmt */ +end-do-stmt: + TOK_ENDDO + | TOK_ENDDO TOK_NAME + ; + +/* R832 : if-construct */ +if-construct: if-then-stmt line-break block opt-else-if-stmt-block opt-else-stmt-block end-if-stmt + ; + +opt-else-if-stmt-block: + | else-if-stmt-block + | opt-else-if-stmt-block else-if-stmt-block + ; + +else-if-stmt-block: + else-if-stmt line-break block + ; + +opt-else-stmt-block: + | else-stmt-block + | opt-else-stmt-block else-if-stmt-block + ; + +else-stmt-block: else-stmt line-break block + ; + +/* R833 : if-then-stmt */ +if-then-stmt: + TOK_NAME ':' TOK_LOGICALIF '(' expr ')' TOK_THEN + | TOK_LOGICALIF '(' expr ')' TOK_THEN + ; + +/* R834 : else-if-stmt */ +else-if-stmt: + TOK_ELSEIF '(' expr ')' TOK_THEN + | TOK_ELSEIF '(' expr ')' TOK_THEN TOK_NAME + ; + +/* R835 : else-stmt */ +else-stmt: + TOK_ELSE + | TOK_ELSE TOK_NAME + ; + +/* R836 : end-if-stmt */ +end-if-stmt: + TOK_ENDIF + | TOK_ENDIF TOK_NAME + ; + +/* R837 : if-stmt */ +if-stmt: TOK_LOGICALIF '(' expr ')' action-stmt + ; + +/* R838 : case-construct */ +case-construct: select-case-stmt line-break opt_case-stmt-block end-select-stmt + ; + +opt_case-stmt-block: + | case-stmt-block + | opt_case-stmt-block case-stmt-block + ; + +case-stmt-block: case-stmt line-break block + ; + +/* R839 : select-case-stmt */ +select-case-stmt : + TOK_NAME ':' TOK_SELECTCASE '(' expr ')' + | TOK_SELECTCASE '(' expr ')' + ; + +/* R840 : case-stmt */ +case-stmt: + TOK_CASE case-selector + | TOK_CASE case-selector TOK_NAME + ; + +/* R840 : end-select-stmt */ +end-select-stmt: + TOK_ENDSELECT + | TOK_ENDSELECT TOK_NAME + ; + +/* R843 : case-selector */ +case-selector: + '(' case-value-range-list ')' + | TOK_DEFAULT + ; + +case-value-range-list: + case-value-range + | case-value-range-list ',' case-value-range + ; + +/* R844: case-value-range */ +case-value-range : + case-value + | case-value ':' + | ':' case-value + | case-value ':' case-value + ; + +/* R845 : case-value */ +case-value: expr + ; + +/* R854 : continue-stmt */ +continue-stmt: TOK_CONTINUE + ; + +/* R1001 : format-stmt */ +format-stmt: TOK_FORMAT + ; + +word_endsubroutine : + TOK_ENDSUBROUTINE + { + strcpy($$,$1); + pos_endsubroutine = setposcur()-strlen($1); + functiondeclarationisdone = 0; + } + ; +word_endunit : + TOK_ENDUNIT + { + strcpy($$,$1); + pos_endsubroutine = setposcur()-strlen($1); + } + ; +word_endprogram : + TOK_ENDPROGRAM + { + strcpy($$,$1); + pos_endsubroutine = setposcur()-strlen($1); + } + ; +word_endfunction : + TOK_ENDFUNCTION + { + strcpy($$,$1); + pos_endsubroutine = setposcur()-strlen($1); + } + ; + +opt_name : '\n' {strcpy($$,"");} + | TOK_NAME {strcpy($$,$1);} + ; + +before_dims : { created_dimensionlist = 0; } + ; +ident_dims : + ident before_dims dims dims + { + created_dimensionlist = 1; + if ( ($3 == NULL) || ($4 == NULL) ) break; + if ( agrif_parentcall == 1 ) + { + ModifyTheAgrifFunction_0($3->dim.last); + agrif_parentcall = 0; + fprintf(fortran_out," = "); + } + } + | ident_dims '%' declare_after_percent ident before_dims dims dims + { + created_dimensionlist = 1; + } + ; +int_list : + TOK_CSTINT + | int_list ',' TOK_CSTINT + ; +after_ident_dims : + '=' expr + | TOK_POINT_TO expr + ; +call : keywordcall opt_call + { + inagrifcallargument = 0 ; + incalldeclare=0; + if ( oldfortran_out && (callagrifinitgrids == 1) && (firstpass == 0) ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcall,pos_end-pos_curcall); + strcpy(subofagrifinitgrids,subroutinename); + } + Instanciation_0(sameagrifname); + } + ; +opt_call : + | '(' opt_callarglist ')' + ; +opt_callarglist : + | callarglist + ; +keywordcall : + before_call TOK_FLUSH + | before_call TOK_NAME + { + if (!strcasecmp($2,"MPI_Init") ) callmpiinit = 1; + else callmpiinit = 0; + + if (!strcasecmp($2,"Agrif_Init_Grids") ) + { + callagrifinitgrids = 1; + strcpy(meetagrifinitgrids,subroutinename); + } + else + { + callagrifinitgrids = 0; + } + if ( Vartonumber($2) == 1 ) + { + incalldeclare = 1; + inagrifcallargument = 1 ; + Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + } + } + ; +before_call : TOK_CALL { pos_curcall=setposcur()-4; } + ; +callarglist : + callarg + | callarglist ',' callarg + ; +callarg : + expr + { + if ( callmpiinit == 1 ) + { + strcpy(mpiinitvar,$1); + if ( firstpass == 1 ) Add_UsedInSubroutine_Var_1 (mpiinitvar); + } + } + | '*' TOK_CSTINT + ; + +stop : TOK_PAUSE + | TOK_STOP + ; + +option_inlist : + | inlist + ; +option_read : + ioctl option_inlist + | infmt opt_inlist + ; +opt_inlist : + | ',' inlist + ; +ioctl : '(' ctllist ')' + ; +after_rewind : + '(' ident ')' + | '(' TOK_CSTINT ')' + | TOK_CSTINT + | '(' uexpr ')' + | TOK_NAME + ; +ctllist : + ioclause + | ctllist ',' ioclause + ; +ioclause : + fexpr + | '*' + | TOK_DASTER + | ident expr dims + | ident expr '%' declare_after_percent ident_dims + | ident '(' triplet ')' + | ident '*' + | ident TOK_DASTER + ; + +declare_after_percent: { afterpercent = 1; } + ; +iofctl : + TOK_OPEN + | TOK_CLOSE + | TOK_FLUSH + ; +infmt : unpar_fexpr + | '*' + ; + +read : TOK_READ + | TOK_INQUIRE + | TOK_PRINT + ; + +fexpr : unpar_fexpr + | '(' fexpr ')' + ; +unpar_fexpr : + lhs + | simple_const + | fexpr addop fexpr %prec '+' + | fexpr '*' fexpr + | fexpr TOK_SLASH fexpr + | fexpr TOK_DASTER fexpr + | addop fexpr %prec '*' + | fexpr TOK_DSLASH fexpr + | TOK_FILE expr + | TOK_UNIT expr + | TOK_NML expr + | TOK_FMT expr + | TOK_EXIST expr + | TOK_ERR expr + | TOK_END expr + | TOK_NAME '=' expr + | predefinedfunction + ; +addop : '+' + | '-' + ; +inlist : inelt + | inlist ',' inelt + ; +// opt_lhs : +// | lhs +// ; +inelt : //opt_lhs opt_operation + lhs opt_operation + | '(' inlist ')' opt_operation + | predefinedfunction opt_operation + | simple_const opt_operation + | '(' inlist ',' dospec ')' + ; +opt_operation : + | operation + | opt_operation operation + ; +outlist : + complex_const { strcpy($$,$1); } + | predefinedfunction { strcpy($$,$1); } + | uexpr { strcpy($$,$1); } + | other { strcpy($$,$1); } + | uexpr ',' expr { sprintf($$,"%s,%s",$1,$3); } + | uexpr ',' other { sprintf($$,"%s,%s",$1,$3); } + | other ',' expr { sprintf($$,"%s,%s",$1,$3); } + | other ',' other { sprintf($$,"%s,%s",$1,$3); } + | outlist ',' expr { sprintf($$,"%s,%s",$1,$3); } + | outlist ',' other { sprintf($$,"%s,%s",$1,$3); } + ; +other : + '(' uexpr ',' dospec ')' { sprintf($$,"(%s,%s)",$2,$4); } + | '(' outlist ',' dospec ')' { sprintf($$,"(%s,%s)",$2,$4); } + | '(' other ',' dospec ')' { sprintf($$,"(%s,%s)",$2,$4); } +dospec : + TOK_NAME '=' expr ',' expr { sprintf($$,"%s=%s,%s)",$1,$3,$5);} + | TOK_NAME '=' expr ',' expr ',' expr { sprintf($$,"%s=%s,%s,%s)",$1,$3,$5,$7);} + ; +goto : TOK_PLAINGOTO '(' expr ',' expr ')' ',' expr + | TOK_PLAINGOTO TOK_CSTINT + ; +allocation_list : + allocate_object + | allocation_list ',' allocate_object + ; +allocate_object : + lhs { Add_Allocate_Var_1($1,curmodulename); } + ; +allocate_object_list : + allocate_object + | allocate_object_list ',' allocate_object + ; +opt_stat_spec : + | ',' TOK_STAT '=' lhs + ; +pointer_name_list : + ident + | pointer_name_list ',' ident + ; + +%% + +void process_fortran(const char *input_file) +{ + extern FILE *fortran_in; + extern FILE *fortran_out; + + char output_file[LONG_FNAME]; + char input_fullpath[LONG_FNAME]; + + if ( todebug == 1 ) printf("Firstpass == %d \n", firstpass); + + yydebug=0; +/******************************************************************************/ +/* 1- Open input file */ +/******************************************************************************/ + + strcpy(cur_filename, input_file); + sprintf(input_fullpath, "%s/%s", input_dir, input_file); + + fortran_in = fopen(input_fullpath, "r"); + if (! fortran_in) + { + printf("Error : File %s does not exist\n", input_fullpath); + exit(1); + } + +/******************************************************************************/ +/* 2- Variables initialization */ +/******************************************************************************/ + + line_num_input = 1; + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0; + incalldeclare = 0; + inside_type_declare = 0; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + VariableIsParameter = 0 ; + strcpy(NamePrecision,""); + c_star = 0 ; + functiondeclarationisdone = 0; + insubroutinedeclare = 0 ; + strcpy(subroutinename," "); + isrecursive = 0; + InitialValueGiven = 0 ; + GlobalDeclarationType = 0; + inmoduledeclare = 0; + incontainssubroutine = 0; + afterpercent = 0; + aftercontainsdeclare = 1; + strcpy(nameinttypename,""); + +/******************************************************************************/ +/* 3- Parsing of the input file (1 time) */ +/******************************************************************************/ + + sprintf(output_file, "%s/%s", output_dir, input_file); + + if (firstpass == 0) fortran_out = fopen(output_file,"w"); + + fortran_parse(); + + if (firstpass == 0) NewModule_Creation_0(); + if (firstpass == 0) fclose(fortran_out); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/DiversListe.c b/V4.0/nemo_sources/ext/AGRIF/LIB/DiversListe.c new file mode 100644 index 0000000000000000000000000000000000000000..e4080ca4a6a4b0c42a882f3fa5df2162386506b8 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/DiversListe.c @@ -0,0 +1,542 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_Common_var_1 */ +/******************************************************************************/ +/* This subroutines is used to add the variable defined in common in the */ +/* List_Common_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Common_var_1() +{ + listvar *newvar; + listvar *newvar2; + variable *newvariable; + listdim *dims; + char listdimension[LONG_M]; + char ligne[LONG_M]; + int out; + + if ( firstpass == 1 ) + { + newvar = (listvar *) calloc(1,sizeof(listvar)); + newvariable = (variable *) calloc(1,sizeof(variable)); + + Init_Variable(newvariable); + + strcpy(newvariable->v_nomvar,commonvar); + strcpy(newvariable->v_commonname,commonblockname); + strcpy(newvariable->v_modulename,curmodulename); + strcpy(newvariable->v_subroutinename,subroutinename); + strcpy(newvariable->v_commoninfile,cur_filename); + newvariable->v_positioninblock = positioninblock; + newvariable->v_common = 1; + newvar->var = newvariable; + + if ( commondim ) + { + newvariable->v_dimension = commondim; + newvariable->v_dimensiongiven = 1; + newvariable->v_nbdim = get_num_dims(commondim); + + /* Creation of the string for the dimension of this variable */ + dimsempty = 1; + strcpy(listdimension,""); + + dims = commondim; + while (dims) + { + if ( strcasecmp(dims->dim.first,"") || + strcasecmp(dims->dim.last,"")) dimsempty = 0; + sprintf(ligne,"%s:%s",dims->dim.first,dims->dim.last); + strcat(listdimension,ligne); + if ( dims->suiv ) strcat(listdimension,","); + dims = dims->suiv; + } + if ( dimsempty == 1 ) newvariable->v_dimsempty = 1; + + strcpy(newvariable->v_readedlistdimension,listdimension); + Save_Length(listdimension,15); + } + + newvar->suiv = NULL; + + if ( !List_Common_Var ) + { + List_Common_Var = newvar; + } + else + { + newvar2 = List_Common_Var; + out = 0 ; + while ( newvar2 && out == 0 ) + { + if ( !strcasecmp(newvar2->var->v_nomvar,commonvar) && + !strcasecmp(newvar2->var->v_commonname,commonblockname) && + !strcasecmp(newvar2->var->v_subroutinename,subroutinename) + ) out = 1 ; + else newvar2 = newvar2->suiv; + } + if ( out == 0 ) + { + newvar->suiv = List_Common_Var; + List_Common_Var = newvar; + } + else + { + free(newvar); + } + } + } +} + +/******************************************************************************/ +/* Addtolistnom */ +/******************************************************************************/ +/* This subroutine is used to add a variable to the list */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +listnom *Addtolistnom(const char *nom, listnom *listin, int value) +{ + listnom *newnom; + listnom *parcours; + int out; + + newnom = (listnom*) calloc(1, sizeof(listnom)); + strcpy(newnom->o_nom, nom); + newnom->o_val = value; + newnom->suiv = NULL; + + if ( listin == NULL ) + { + listin = newnom; + } + else + { + parcours = listin; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->o_nom, nom) ) out = 1 ; + else parcours = parcours->suiv; + } + if ( out == 0 ) + { + newnom->suiv = listin; + listin = newnom; + } + else + { + free(newnom); + } + } + return listin; +} + +/******************************************************************************/ +/* Addtolistname */ +/******************************************************************************/ +/* This subroutine is used to add a variable to the list */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ glob +--->+ glob +--->+ glob +--->+ glob + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* */ +/* */ +/******************************************************************************/ +listname *Addtolistname(const char *nom, listname *input) +{ + listname *newnom; + listname *parcours; + int out; + + if ( !input ) + { + newnom = (listname*) calloc(1, sizeof(listname)); + strcpy(newnom->n_name, nom); + newnom->suiv = NULL; + input = newnom; + } + else + { + parcours = input; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->n_name,nom) ) out = 1; + else parcours=parcours->suiv; + } + if ( out == 0 ) + { + newnom = (listname*) calloc(1,sizeof(listname)); + strcpy(newnom->n_name, nom); + newnom->suiv = input; + input = newnom; + } + } + return input; +} + +/******************************************************************************/ +/* ModuleIsDefineInInputFile */ +/******************************************************************************/ +/* This subroutine is used to know if the module is defined in the input file */ +/******************************************************************************/ +/* */ +/* */ +/******************************************************************************/ +int ModuleIsDefineInInputFile(const char *name) +{ + listnom *newnom; + int out; + + out = 0; + if ( listofmodules ) + { + newnom = listofmodules; + while( newnom && out == 0 ) + { + if ( !strcasecmp(newnom->o_nom,name) ) out = 1 ; + else newnom = newnom->suiv; + } + } + return out; +} + +/******************************************************************************/ +/* Addmoduletothelisttmp */ +/******************************************************************************/ +/* This subroutine is used to add a record to a list of struct */ +/* listusemodule */ +/******************************************************************************/ +/* */ +/* subroutine sub ... USE mod1 ===> insert in list */ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ list +--->+ list +--->+ list +--->+ list + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* list = listofmoduletmp */ +/* */ +/******************************************************************************/ +void Addmoduletothelisttmp(const char *name) +{ + listusemodule *newmodule; + listusemodule *parcours; + int out; + + if ( !listofmoduletmp ) + { + newmodule = (listusemodule*) calloc(1, sizeof(listusemodule)); + strcpy(newmodule->u_usemodule, name); + strcpy(newmodule->u_cursubroutine, subroutinename); + newmodule->suiv = NULL; + listofmoduletmp = newmodule ; + } + else + { + parcours = listofmoduletmp; + out = 0; + while( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->u_usemodule, name) ) out = 1; + else parcours = parcours->suiv; + } + if ( out == 0 ) + { + newmodule = (listusemodule*) calloc(1, sizeof(listusemodule)); + strcpy(newmodule->u_usemodule, name); + strcpy(newmodule->u_cursubroutine, subroutinename); + newmodule->suiv = listofmoduletmp; + listofmoduletmp = newmodule; + } + } +} + +/******************************************************************************/ +/* Add_NameOfModule_1 */ +/******************************************************************************/ +/* This subroutine is used to add a variable to the list */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ glob +--->+ glob +--->+ glob +--->+ glob + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* */ +/* */ +/******************************************************************************/ +void Add_NameOfModule_1(const char *nom) +{ + listnom *newnom; + + if ( firstpass == 1 ) + { + newnom = (listnom *) calloc(1,sizeof(listnom)); + strcpy(newnom->o_nom,nom); + newnom->suiv = List_NameOfModule; + List_NameOfModule = newnom; + } +} + +/******************************************************************************/ +/* Add_NameOfCommon_1 */ +/******************************************************************************/ +/* This subroutine is used to add a variable to the list */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ glob +--->+ glob +--->+ glob +--->+ glob + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* */ +/* */ +/******************************************************************************/ +void Add_NameOfCommon_1(const char *nom, const char *cursubroutinename) +{ + listnom *newnom; + listnom *parcours; + + if ( firstpass == 1 ) + { + parcours = List_NameOfCommon; + while ( parcours && strcasecmp(parcours->o_nom,nom) ) + parcours = parcours->suiv; + if ( !parcours ) + { + newnom = (listnom *) calloc(1,sizeof(listnom)); + strcpy(newnom->o_nom,nom); + strcpy(newnom->o_subroutinename,cursubroutinename); + newnom->suiv = List_NameOfCommon; + List_NameOfCommon = newnom; + } + } +} + +/******************************************************************************/ +/* Add_CouplePointed_Var_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/* We should complete the listvarpointtovar */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_CouplePointed_Var_1(const char *namemodule, listcouple *couple) +{ + listvarpointtovar *pointtmp; + + /* we should complete the List_CouplePointed_Var */ + pointtmp = (listvarpointtovar*) calloc(1, sizeof(listvarpointtovar)); + strcpy(pointtmp->t_usemodule, namemodule); + strcpy(pointtmp->t_cursubroutine, subroutinename); + pointtmp->t_couple = couple; + if ( List_CouplePointed_Var ) + { + pointtmp->suiv = List_CouplePointed_Var; + } + else + { + pointtmp->suiv = NULL; + } + List_CouplePointed_Var = pointtmp; +} + +/******************************************************************************/ +/* Add_Include_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to a list of struct */ +/* List_Include */ +/******************************************************************************/ +/* */ +/* subroutine sub ... include mod1 ===> insert in list */ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ list +--->+ list +--->+ list +--->+ list + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* list = List_Include */ +/* */ +/******************************************************************************/ +void Add_Include_1(const char *name) +{ + listusemodule *newinclude; + + if ( firstpass == 1 ) + { + newinclude = (listusemodule*) calloc(1, sizeof(listusemodule)); + strcpy(newinclude->u_usemodule,name); + strcpy(newinclude->u_cursubroutine,subroutinename); + + newinclude->suiv = List_Include; + List_Include = newinclude ; + } +} + +/******************************************************************************/ +/* Add_ImplicitNoneSubroutine_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to a list of struct */ +/******************************************************************************/ +/* */ +/* */ +/******************************************************************************/ +void Add_ImplicitNoneSubroutine_1() +{ + if ( firstpass == 1 ) + List_ImplicitNoneSubroutine = Addtolistname(subroutinename,List_ImplicitNoneSubroutine); +} + +/******************************************************************************/ +/* WriteIncludeDeclaration */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void WriteIncludeDeclaration(FILE* tofile) +{ + listusemodule *newinclude; + + newinclude = List_Include; + fprintf(tofile,"\n"); + while ( newinclude ) + { + if ( !strcasecmp(newinclude->u_cursubroutine,subroutinename) ) + { + fprintf(tofile, " include %s\n",newinclude->u_usemodule); + } + newinclude = newinclude ->suiv; + } +} + +/******************************************************************************/ +/* Add_Save_Var_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to List_Save_Var */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ Save +--->+ Save +--->+ Save +--->+ Save+ */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +void Add_Save_Var_1 (const char *name, listdim *d) +{ + listvar *newvar; + listdim *dims; + char ligne[LONG_M]; + char listdimension[LONG_M]; + + if ( firstpass == 1 ) + { + newvar = (listvar *) calloc(1,sizeof(listvar)); + newvar->var = (variable *) calloc(1,sizeof(variable)); + + Init_Variable(newvar->var); + + newvar->var->v_save = 1; + strcpy(newvar->var->v_nomvar,name); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_subroutinename,subroutinename); + strcpy(newvar->var->v_commoninfile,cur_filename); + + newvar->var->v_dimension = d; + + /* Creation of the string for the dimension of this variable */ + dimsempty = 1; + + if ( d ) + { + newvar->var->v_dimensiongiven = 1; + dims = d; + while (dims) + { + if ( strcasecmp(dims->dim.first,"") || strcasecmp(dims->dim.last,"")) + dimsempty = 0; + sprintf(ligne,"%s:%s",dims->dim.first,dims->dim.last); + strcat(listdimension,ligne); + if ( dims->suiv ) strcat(listdimension,","); + dims = dims->suiv; + } + if ( dimsempty == 1 ) newvar->var->v_dimsempty = 1; + } + + newvar->suiv = List_Save_Var; + List_Save_Var = newvar; + } +} + +void Add_Save_Var_dcl_1 (listvar *var) +{ + listvar *newvar; + listvar *parcours; + + if ( firstpass == 1 ) + { + parcours = var; + while ( parcours ) + { + newvar = (listvar *) calloc(1,sizeof(listvar)); + newvar->var = (variable *) calloc(1,sizeof(variable)); + + Init_Variable(newvar->var); + + newvar->var->v_save = 1; + strcpy(newvar->var->v_nomvar,parcours->var->v_nomvar); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_subroutinename,subroutinename); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_readedlistdimension,parcours->var->v_readedlistdimension); + + newvar->var->v_nbdim = parcours->var->v_nbdim; + newvar->var->v_catvar = parcours->var->v_catvar; + newvar->var->v_dimension = parcours->var->v_dimension; + newvar->var->v_dimensiongiven=parcours->var->v_dimensiongiven; + newvar->suiv = List_Save_Var; + List_Save_Var = newvar; + + parcours = parcours->suiv; + } + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/Makefile b/V4.0/nemo_sources/ext/AGRIF/LIB/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..38460f72296ad10ae28c04ae4cb82fc3ba59b644 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/Makefile @@ -0,0 +1,66 @@ +OBJS = main.o WriteInFile.o toamr.o fortran.o \ + dependfile.o SubLoopCreation.o WorkWithlistvarindoloop.o \ + WorkWithvarofsubroutineliste.o WorkWithParameterlist.o \ + Writedeclarations.o WorkWithglobliste.o UtilFortran.o \ + UtilNotGridDep.o WorkWithlistdatavariable.o \ + DiversListe.o UtilAgrif.o WorkWithAllocatelist.o \ + UtilCharacter.o UtilListe.o UtilFile.o \ + WorkWithlistofmodulebysubroutine.o WorkWithlistmoduleinfile.o \ + WorkWithlistofcoupled.o + +.SUFFIXES: +.SUFFIXES: .c .o + +all: conv + @echo + @echo =================================================== + @echo CONV is ok + @echo =================================================== + @echo + +#main.c: convert.y convert.lex +# @echo =================================================== +# @echo Rebuilding main.c ... +# @echo =================================================== +# $(MAKE) -f Makefile.lex main.c + +#fortran.c: fortran.y fortran.lex +# @echo =================================================== +# @echo Rebuilding fortran.c ... +# @echo =================================================== +# $(MAKE) -f Makefile.lex fortran.c + +conv: $(OBJS) + $(CC) $(CFLAGS) -g $(OBJS) -o ../$@ + +%.o: %.c + $(CC) $(CFLAGS) -g -c $< -o $@ + +main.o : main.c +fortran.o : fortran.c +toamr.o : toamr.c decl.h +WriteInFile.o : WriteInFile.c decl.h +dependfile.o : dependfile.c decl.h +SubLoopCreation.o : SubLoopCreation.c decl.h +WorkWithglobliste.o : WorkWithglobliste.c decl.h +WorkWithlistvarindoloop.o : WorkWithlistvarindoloop.c decl.h +WorkWithvarofsubroutineliste.o : WorkWithvarofsubroutineliste.c decl.h +Writedeclarations.o : Writedeclarations.c decl.h +UtilFortran.o : UtilFortran.c decl.h +WorkWithParameterlist.o : WorkWithParameterlist.c decl.h +UtilNotGridDep.o : UtilNotGridDep.c decl.h +WorkWithlistdatavariable.o : WorkWithlistdatavariable.c decl.h +DiversListe.o : DiversListe.c decl.h +UtilAgrif.o : UtilAgrif.c decl.h +WorkWithAllocatelist.o : WorkWithAllocatelist.c decl.h +UtilCharacter.o : UtilCharacter.c decl.h +UtilListe.o : UtilListe.c decl.h +UtilFile.o : UtilFile.c decl.h +WorkWithlistofmodulebysubroutine.o : WorkWithlistofmodulebysubroutine.c decl.h +WorkWithlistmoduleinfile.o : WorkWithlistmoduleinfile.c decl.h +WorkWithlistofcoupled.o : WorkWithlistofcoupled.c decl.h + +clean: +# $(MAKE) -f Makefile.lex clean + $(RM) *.o conv + diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/SubLoopCreation.c b/V4.0/nemo_sources/ext/AGRIF/LIB/SubLoopCreation.c new file mode 100644 index 0000000000000000000000000000000000000000..332f3ce371ee63cafb86c7f49edb82646677f7a7 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/SubLoopCreation.c @@ -0,0 +1,404 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + + +/******************************************************************************/ +/* preparation and write of the argument list of a subroutine */ +/******************************************************************************/ + + +/******************************************************************************/ +/* WriteBeginof_SubLoop */ +/******************************************************************************/ +/* We should write the head of the subroutine sub_loop_ */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void WriteBeginof_SubLoop() +{ + if (todebug == 1) printf("##\n## Enter in HEAD SUBLOOP for |%s|\n##\n", subroutinename); + if ( IsTabvarsUseInArgument_0() == 1 ) + { + if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 1\n"); + /* we should add the use agrif_uti l if it is necessary */ + WriteHeadofSubroutineLoop(); + WriteUsemoduleDeclaration(subroutinename); + if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n"); + WriteIncludeDeclaration(fortran_out); + /* */ + /* We should write once the declaration of tables (extract */ + /* from pointer) in the new subroutine */ + if ( SubInList_ContainsSubroutine() == 0 ) WriteLocalParamDeclaration(fortran_out); + + writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var,fortran_out); + writesub_loopdeclaration_tab(List_UsedInSubroutine_Var,fortran_out); + WriteArgumentDeclaration_Sort(fortran_out); + WriteFunctionDeclaration(fortran_out, 1); + } + else + { + if ( todebug == 1 ) printf("> enter in WriteBeginof_SubLoop : IsTabvarsUseInArgument_0() == 0\n"); + AddUseAgrifUtil_0(fortran_out); + WriteUsemoduleDeclaration(subroutinename); + WriteIncludeDeclaration(fortran_out); + if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n"); + WriteLocalParamDeclaration(fortran_out); + WriteArgumentDeclaration_beforecall(); + if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 1); +/* writesub_loopdeclaration_scalar(List_SubroutineArgument_Var,fortran_out); + writesub_loopdeclaration_tab(List_SubroutineArgument_Var,fortran_out);*/ + } + if ( todebug == 1 ) printf("< out of WriteBeginof_SubLoop\n"); + if ( todebug == 1 ) printf("## EXIT HEAD SUBLOOP (%s)\n\n", subroutinename); +} + +/******************************************************************************/ +/* WriteVariablelist_subloop */ +/******************************************************************************/ +/* This subroutine is used to write the list of the variable which */ +/* should be called by the sub_loop_ subroutine */ +/* The first part is composed by the list of the local variables */ +/******************************************************************************/ +/* */ +/* List_SubroutineDeclaration_Var a,b,c, & */ +/* d,e,f, & */ +/* a,b,c,d,e,f,g,h ========> g,h */ +/* */ +/******************************************************************************/ +void WriteVariablelist_subloop(char *ligne) +{ + listvar *parcours; + + if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop\n"); + parcours = List_SubroutineArgument_Var; + didvariableadded = 0; + + while ( parcours ) + { + /* if the readed variable is a variable of the subroutine */ + /* subroutinename we should write the name of this variable */ + /* in the output file */ + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) ) + { + if ( didvariableadded == 1 ) strcat(ligne,","); + strcat(ligne,parcours->var->v_nomvar); + didvariableadded = 1; + } + parcours = parcours -> suiv; + } + parcours = List_FunctionType_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) ) + { + if ( didvariableadded == 1 ) strcat(ligne,","); + strcat(ligne,parcours->var->v_nomvar); + didvariableadded = 1; + } + parcours = parcours -> suiv; + } + if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop\n"); +} + + +/******************************************************************************/ +/* WriteVariablelist_subloop_Call */ +/******************************************************************************/ +/* This subroutine is used to write the list of the variable which */ +/* should be called by the sub_loop_ subroutine into the called */ +/* The second part is composed by the list of the global table */ +/******************************************************************************/ +/* */ +/* List_UsedInSubroutine_Var SubloopScalar = 0 | SubloopScalar = 1 */ +/* a,b,c, & | a,b(1,1),c, & */ +/* a,b,c,d,e,f,g,h =====> d,e,f, & | d(1),e(1,1,1),f, & */ +/* g,h | g,h(1,1) */ +/* */ +/******************************************************************************/ +void WriteVariablelist_subloop_Call(char **ligne, size_t line_length) +{ + listvar *parcours; + char ligne2[LONG_M]; + int i; + size_t cur_length; + + cur_length = line_length; + + if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Call\n"); + parcours = List_UsedInSubroutine_Var; + + while ( parcours ) + { + /* if the readed variable is a variable of the subroutine */ + /* subroutinename we should write the name of this variable */ + /* in the output file */ + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && + (parcours->var->v_pointerdeclare == 0 || !strcasecmp(parcours->var->v_typevar,"type")) + ) + { + if ( didvariableadded == 1 ) strcat(*ligne,","); + const char *vres = vargridcurgridtabvars(parcours->var, 0); + if ( (strlen(*ligne)+strlen(vres)+100) > cur_length ) + { + cur_length += LONG_M; + *ligne = realloc( *ligne, cur_length*sizeof(char) ); + } + strcat(*ligne, vres); + /* if it is asked in the call of the conv we should give */ + /* scalar in argument, so we should put (1,1,1) after the */ + /* the name of the variable */ + if ( SubloopScalar != 0 && + ( + (parcours->var->v_pointerdeclare == 0 || !strcasecmp(parcours->var->v_typevar,"type"))) && + parcours->var->v_nbdim != 0 ) + { + i = 1; + while ( i <= parcours->var->v_nbdim ) + { + if ( i == 1 ) strcat(*ligne,"( "); + if ( SubloopScalar == 2 ) + { + strcat(*ligne,":"); + if ( i != parcours->var->v_nbdim ) strcat(*ligne,","); + } + else + { + sprintf(ligne2,"lbound(%s,%d",vargridcurgridtabvars(parcours->var,0),i); + strcat(*ligne,ligne2); + if ( i != parcours->var->v_nbdim ) strcat(*ligne,"),"); + } + if ( i == parcours->var->v_nbdim ) strcat(*ligne,"))"); + i++; + } + } + didvariableadded = 1; + } + parcours = parcours -> suiv; + } + if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Call\n"); +} + + +/******************************************************************************/ +/* WriteVariablelist_subloop_Def */ +/******************************************************************************/ +/* This subroutine is used to write the list of the variable which */ +/* should be called by the sub_loop_ subroutine into the def */ +/* The second part is composed by the list of the global table */ +/* _tmp */ +/******************************************************************************/ +/* */ +/* List_UsedInSubroutine_Var */ +/* a-tmp,b-tmp,c_tmp, & */ +/* a,b,c,d,e,f,g,h =====> d_tmp,e_tmp,f_tmp, & */ +/* g_tmp,h_tmp */ +/* */ +/******************************************************************************/ +void WriteVariablelist_subloop_Def(char *ligne) +{ + listvar *parcours; + + if ( todebug == 1 ) printf("> enter in WriteVariablelist_subloop_Def\n"); + parcours = List_UsedInSubroutine_Var; + + while ( parcours ) + { + /* if the readed variable is a variable of the subroutine */ + /* subrotinename we should write the name of this variable */ + /* in the output file */ + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && + (parcours->var->v_pointerdeclare == 0 || !strcasecmp(parcours->var->v_typevar,"type")) ) + { + if ( didvariableadded == 1 ) strcat(ligne,","); + strcat(ligne,parcours->var->v_nomvar); + didvariableadded = 1; + } + parcours = parcours -> suiv; + } + Save_Length(ligne,41); + if ( todebug == 1 ) printf("< out of WriteVariablelist_subloop_Def\n"); +} + +/******************************************************************************/ +/* WriteHeadofSubroutineLoop */ +/******************************************************************************/ +/* This subroutine is used to write the head of the subroutine */ +/* Sub_Loop_ */ +/******************************************************************************/ +/* Sub_loop_subroutine.h */ +/* */ +/* subroutine Sub_Loop_subroutine ( & */ +/* a,b,c, & */ +/* SubLoopScalar d,e(1,1),f(1,1,1), & */ +/* g,h & */ +/* ) */ +/******************************************************************************/ +void WriteHeadofSubroutineLoop() +{ + char ligne[LONG_M]; + FILE * subloop; + + if ( todebug == 1 ) printf("> enter in WriteHeadofSubroutineLoop\n"); + tofich(fortran_out,"\n",1); + /* Open this newfile */ + sprintf(ligne,"Sub_Loop_%s.h",subroutinename); + subloop = open_for_write(ligne); + /* */ + if (isrecursive) sprintf(ligne,"recursive subroutine Sub_Loop_%s(",subroutinename); + else sprintf(ligne,"subroutine Sub_Loop_%s(",subroutinename); + /* */ + WriteVariablelist_subloop(ligne); + WriteVariablelist_subloop_Def(ligne); + /* */ + strcat(ligne,")"); + tofich(subloop,ligne,1); + /* if USE agrif_Uti l should be add */ + AddUseAgrifUtil_0(subloop); + /* */ + oldfortran_out = fortran_out; + fortran_out = subloop; + if ( todebug == 1 ) printf("< out of WriteHeadofSubroutineLoop\n"); +} + +/******************************************************************************/ +/* closeandcallsubloopandincludeit_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/* We should close the sub_loop subroutine, call it and close the */ +/* function (suborfun = 0) */ +/* subroutine (suborfun = 1) */ +/* end (suborfun = 2) */ +/* end program (suborfun = 3) */ +/* and include the sub_loop subroutine after */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void closeandcallsubloopandincludeit_0(int suborfun) +{ + char *ligne; + + if ( firstpass == 1 ) return; + if ( todebug == 1 ) printf("> enter in closeandcallsubloopandincludeit_0\n"); + + ligne = (char*) calloc(LONG_M, sizeof(char)); + + if ( IsTabvarsUseInArgument_0() == 1 ) + { + /* We should remove the key word end subroutine */ + RemoveWordCUR_0(fortran_out,setposcur()-pos_endsubroutine); + /* We should close the loop subroutine */ + tofich(fortran_out,"\n",1); + sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename); + tofich(fortran_out,ligne,1); + fclose(fortran_out); + fortran_out = oldfortran_out; + + AddUseAgrifUtilBeforeCall_0(fortran_out); + WriteArgumentDeclaration_beforecall(); + if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0); + if ( !strcasecmp(subofagrifinitgrids,subroutinename) ) + fprintf(fortran_out," call Agrif_Init_Grids()\n"); + /* Now we add the call af the new subroutine */ + tofich(fortran_out,"\n",1); + sprintf(ligne," call Sub_Loop_%s(",subroutinename); + /* Write the list of the local variables used in this new subroutine */ + WriteVariablelist_subloop(ligne); + /* Write the list of the global tables used in this new subroutine */ + /* in doloop */ + WriteVariablelist_subloop_Call(&ligne, LONG_M); + /* Close the parenthesis of the new subroutine called */ + strcat(ligne,")\n"); + tofich(fortran_out,ligne,1); + /* we should include the above file in the original code */ + + /* We should close the original subroutine */ + if ( suborfun == 3 ) fprintf(fortran_out, " end program %s\n" , subroutinename); + if ( suborfun == 2 ) fprintf(fortran_out, " end\n"); + if ( suborfun == 1 ) fprintf(fortran_out, " end subroutine %s\n", subroutinename); + if ( suborfun == 0 ) fprintf(fortran_out, " end function %s\n" , subroutinename); + + fprintf(fortran_out,"\n\n#include \"Sub_Loop_%s.h\"\n",subroutinename); + } + oldfortran_out = (FILE *)NULL; + if ( todebug == 1 ) printf("< out of closeandcallsubloopandincludeit_0\n"); +} + +void closeandcallsubloop_contains_0() +{ + char *ligne; + + if ( todebug == 1 ) printf("> enter in closeandcallsubloop_contains_0\n"); + if ( IsTabvarsUseInArgument_0() == 1 ) + { + ligne = (char*) calloc(LONG_M, sizeof(char)); + RemoveWordCUR_0(fortran_out,9); // Remove word 'contains' + tofich(fortran_out,"\n",1); + sprintf(ligne,"end subroutine Sub_Loop_%s\n",subroutinename); + tofich(fortran_out,ligne,1); + fclose(fortran_out); + fortran_out = oldfortran_out; + + AddUseAgrifUtilBeforeCall_0(fortran_out); + + if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n"); + WriteLocalParamDeclaration(fortran_out); + WriteArgumentDeclaration_beforecall(); + if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0); +/* WriteSubroutineDeclaration(0);*/ + if ( !strcasecmp(subofagrifinitgrids,subroutinename) ) + fprintf(fortran_out," call Agrif_Init_Grids()\n"); + /* Now we add the call af the new subroutine */ + tofich(fortran_out,"\n",1); + sprintf(ligne," call Sub_Loop_%s(",subroutinename); + /* Write the list of the local variables used in this new subroutine */ + WriteVariablelist_subloop(ligne); + /* Write the list of the global tables used in this new subroutine */ + /* in doloop */ + WriteVariablelist_subloop_Call(&ligne, LONG_M); + /* Close the parenthesis of the new subroutine called */ + strcat(ligne,")\n"); + tofich(fortran_out,ligne,1); + /* We should close the original subroutine */ + fprintf(fortran_out, " contains\n"); + /* we should include the above file in the original code */ + fprintf(fortran_out,"#include \"Sub_Loop_%s.h\"\n",subroutinename); + } + oldfortran_out = (FILE *)NULL; + if ( todebug == 1 ) printf("< out of closeandcallsubloop_contains_0\n"); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilAgrif.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilAgrif.c new file mode 100644 index 0000000000000000000000000000000000000000..e6a0ffb7dc679fb1888599540a927ee6eee11c8d --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilAgrif.c @@ -0,0 +1,838 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" +/******************************************************************************/ +/* Vartonumber */ +/******************************************************************************/ +/* This subroutine is used to know if Agrif_ is locate in the char */ +/* tokname */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int Vartonumber(const char *tokname) +{ + int agrifintheword; + + agrifintheword = 0; + if ( !strcasecmp(tokname,"Agrif_parent") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_set_type") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_set_raf") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_set_bc") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_set_bcinterp") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Root") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_CFixed") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Fixed") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_bc_variable") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_set_parent") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_interp_variable")) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_init_variable") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_update_variable")) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Set_interp") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Set_Update") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Set_UpdateType") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Set_restore") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_Save_Forrestore")) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_init_grids") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_step") ) agrifintheword = 1; +/**************************************************/ +/* adding specific adjoint agrif subroutine names */ +/**************************************************/ + else if ( !strcasecmp(tokname,"Agrif_bc_variable_adj") ) agrifintheword = 1; + else if ( !strcasecmp(tokname,"Agrif_update_variable_adj")) agrifintheword = 1; + + return agrifintheword; +} + +/******************************************************************************/ +/* Agrif_in_Tok_NAME */ +/******************************************************************************/ +/* This subroutine is used to know if Agrif_ is locate in the char */ +/* tokname */ +/******************************************************************************/ +/* */ +/* Agrif_name --------------> Agrif_in_Tok_NAME = 1 */ +/* name --------------> Agrif_in_Tok_NAME = 0 */ +/* */ +/******************************************************************************/ +int Agrif_in_Tok_NAME(const char *tokname) +{ + return ( strncasecmp(tokname,"Agrif_",6) == 0 ); +} + +/******************************************************************************/ +/* ModifyTheVariableName_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +void ModifyTheVariableName_0(const char *ident, int lengthname) +{ + listvar *newvar; + int out; + + if ( firstpass ) return; + + newvar = List_Global_Var; + out = 0; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar, ident) ) out = 1; + else newvar = newvar->suiv; + } + if ( out == 0 ) + { + newvar = List_ModuleUsed_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + } + if ( out && !strcasecmp(newvar->var->v_typevar,"type")) return; + + if ( out == 0 ) + { + newvar = List_Common_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + } + if ( out == 0 ) + { + newvar = List_ModuleUsedInModuleUsed_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + } + if ( out == 1 && strcasecmp(newvar->var->v_typevar,"type")) + { + // remove the variable + RemoveWordCUR_0(fortran_out,lengthname); + // then write the new name + if ( inagrifcallargument == 1 && agrif_parentcall == 0 ) + fprintf(fortran_out,"%d",newvar->var->v_indicetabvars); + else + { + if ( retour77 == 0 ) + fprintf(fortran_out,"Agrif_%s & \n ", tabvarsname(newvar->var)); + else + { + fprintf(fortran_out,"Agrif_%s", tabvarsname(newvar->var)); + fprintf(fortran_out," \n & "); + } + fprintf(fortran_out,"%s",vargridcurgridtabvarswithoutAgrif_Gr(newvar->var)); + } + } + else + { + // we should look in the List_ModuleUsed_Var + if ( inagrifcallargument != 1 ) + { + newvar = List_ModuleUsed_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + if ( out == 1 && strcasecmp(newvar->var->v_typevar, "type")) + { + // remove the variable + RemoveWordCUR_0(fortran_out,lengthname); + // then write the new name + if ( retour77 == 0 ) + fprintf(fortran_out,"Agrif_%s & \n ",tabvarsname(newvar->var)); + else + { + fprintf(fortran_out," \n &Agrif_%s",tabvarsname(newvar->var)); + } + fprintf(fortran_out,"%s",vargridcurgridtabvarswithoutAgrif_Gr(newvar->var)); + } + } + } +} + +/******************************************************************************/ +/* Add_SubroutineWhereAgrifUsed_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to */ +/* List_SubroutineWhereAgrifUsed */ +/******************************************************************************/ +/* */ +/* subroutine sub ... Agrif_ */ +/* */ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + list +--->+ list +--->+ list +--->+ list +--->+ sub + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* list = List_SubroutineWhereAgrifUsed */ +/* */ +/******************************************************************************/ +void Add_SubroutineWhereAgrifUsed_1(const char *sub, const char *mod) +{ + listnom *listnomtmp; + listnom *parcours; + + if ( firstpass == 1 ) + { + if ( !List_SubroutineWhereAgrifUsed ) + { + listnomtmp = (listnom*) calloc(1, sizeof(listnom)); + strcpy(listnomtmp->o_nom, sub); + strcpy(listnomtmp->o_module, mod); + listnomtmp->suiv = NULL; + List_SubroutineWhereAgrifUsed = listnomtmp; + } + else + { + parcours = List_SubroutineWhereAgrifUsed; + while ( parcours && strcasecmp(parcours->o_nom,sub) ) + { + parcours = parcours->suiv; + } + if ( !parcours ) + { + listnomtmp = (listnom*) calloc(1, sizeof(listnom)); + strcpy(listnomtmp->o_nom, sub); + strcpy(listnomtmp->o_module, mod); + listnomtmp->suiv = List_SubroutineWhereAgrifUsed; + List_SubroutineWhereAgrifUsed = listnomtmp; + } + } + } +} + +/******************************************************************************/ +/* AddUseAgrifUtil_0 */ +/******************************************************************************/ +/* Add use Agrif_Util at the beginning of the subroutine definition */ +/* if it is necessary */ +/******************************************************************************/ +/* */ +/* subroutine sub | subroutine sub */ +/* | USE Agrif_Util */ +/* implicit none | implicit none */ +/* ... | ... */ +/* ... Agrif_ | ... Agrif_ */ +/* ... | ... */ +/* end | end */ +/* */ +/* */ +/******************************************************************************/ +void AddUseAgrifUtil_0(FILE *fileout) +{ + listnom *parcours; + + if ( firstpass == 0 ) + { + parcours = List_SubroutineWhereAgrifUsed; + while ( parcours && strcasecmp(parcours->o_nom,subroutinename) ) + { + parcours = parcours -> suiv; + } + if ( parcours && parcours->o_val != 0 ) + fprintf(fileout,"\n use Agrif_Util\n"); + else + fprintf(fileout,"\n use Agrif_Types, only : Agrif_tabvars\n"); + } +} + +void AddUseAgrifUtilBeforeCall_0(FILE *fileout) +{ + listusemodule *parcours; + + int out; + + if ( firstpass == 0 ) + { + parcours = List_NameOfModuleUsed; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->u_usemodule, "Agrif_Util") && + !strcasecmp(parcours->u_modulename, curmodulename) && + !strcasecmp(parcours->u_cursubroutine, subroutinename) ) + out = 1; + else + parcours = parcours->suiv; + } + if ( out == 0 ) + { + fprintf(fileout,"\n use Agrif_Util\n"); + } + } +} + +/******************************************************************************/ +/* NotifyAgrifFunction_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +void NotifyAgrifFunction_0(const char *ident) +{ + if ( firstpass == 1 ) return; + + if ( !strcasecmp(ident,"Agrif_parent") ) + { + InAgrifParentDef = 1; + pos_curagrifparent = setposcur()-12; + } + else if ( !strcasecmp(ident,"Agrif_Get_Coarse_grid") ) + { + InAgrifParentDef = 2; + pos_curagrifparent = setposcur()-21; + } + else if ( !strcasecmp(ident,"Agrif_Rhox") ) + { + InAgrifParentDef = 3; + pos_curagrifparent = setposcur()-10; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Rhox") ) + { + InAgrifParentDef = 4; + pos_curagrifparent = setposcur()-17; + } + else if ( !strcasecmp(ident,"Agrif_IRhox") ) + { + InAgrifParentDef = 5; + pos_curagrifparent = setposcur()-11; + } + else if ( !strcasecmp(ident,"Agrif_Parent_IRhox") ) + { + InAgrifParentDef = 6; + pos_curagrifparent = setposcur()-18; + } + else if ( !strcasecmp(ident,"Agrif_Rhoy") ) + { + InAgrifParentDef = 7; + pos_curagrifparent = setposcur()-10; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Rhoy") ) + { + InAgrifParentDef = 8; + pos_curagrifparent = setposcur()-17; + } + else if ( !strcasecmp(ident,"Agrif_IRhoy") ) + { + InAgrifParentDef = 9; + pos_curagrifparent = setposcur()-11; + } + else if ( !strcasecmp(ident,"Agrif_Parent_IRhoy") ) + { + InAgrifParentDef = 10; + pos_curagrifparent = setposcur()-18; + } + else if ( !strcasecmp(ident,"Agrif_Rhoz") ) + { + InAgrifParentDef = 11; + pos_curagrifparent = setposcur()-10; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Rhoz") ) + { + InAgrifParentDef = 12; + pos_curagrifparent = setposcur()-17; + } + else if ( !strcasecmp(ident,"Agrif_IRhoz") ) + { + InAgrifParentDef = 13; + pos_curagrifparent = setposcur()-11; + } + else if ( !strcasecmp(ident,"Agrif_Parent_IRhoz") ) + { + InAgrifParentDef = 14; + pos_curagrifparent = setposcur()-18; + } + else if ( !strcasecmp(ident,"Agrif_NearCommonBorderX") ) + { + InAgrifParentDef = 15; + pos_curagrifparent = setposcur()-23; + } + else if ( !strcasecmp(ident,"Agrif_NearCommonBorderY") ) + { + InAgrifParentDef = 16; + pos_curagrifparent = setposcur()-23; + } + else if ( !strcasecmp(ident,"Agrif_NearCommonBorderZ") ) + { + InAgrifParentDef = 17; + pos_curagrifparent = setposcur()-23; + } + else if ( !strcasecmp(ident,"Agrif_DistantCommonBorderX") ) + { + InAgrifParentDef = 18; + pos_curagrifparent = setposcur()-26; + } + else if ( !strcasecmp(ident,"Agrif_DistantCommonBorderY") ) + { + InAgrifParentDef = 19; + pos_curagrifparent = setposcur()-26; + } + else if ( !strcasecmp(ident,"Agrif_DistantCommonBorderZ") ) + { + InAgrifParentDef = 20; + pos_curagrifparent = setposcur()-26; + } + else if ( !strcasecmp(ident,"Agrif_Get_parent_id") ) + { + InAgrifParentDef = 21; + pos_curagrifparent = setposcur()-19; + } + else if ( !strcasecmp(ident,"Agrif_Get_grid_id") ) + { + InAgrifParentDef = 22; + pos_curagrifparent = setposcur()-17; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Iz") ) + { + InAgrifParentDef = 23; + pos_curagrifparent = setposcur()-15; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Iy") ) + { + InAgrifParentDef = 24; + pos_curagrifparent = setposcur()-15; + } + else if ( !strcasecmp(ident,"Agrif_Parent_Ix") ) + { + InAgrifParentDef = 25; + pos_curagrifparent = setposcur()-15; + } + else if ( !strcasecmp(ident,"Agrif_Iz") ) + { + InAgrifParentDef = 26; + pos_curagrifparent = setposcur()-8; + } + else if ( !strcasecmp(ident,"Agrif_Iy") ) + { + InAgrifParentDef = 27; + pos_curagrifparent = setposcur()-8; + } + else if ( !strcasecmp(ident,"Agrif_Ix") ) + { + InAgrifParentDef = 28; + pos_curagrifparent = setposcur()-8; + } + else if ( !strcasecmp(ident,"Agrif_Nb_Fixed_Grids") ) + { + InAgrifParentDef = 29; + pos_curagrifparent = setposcur()-20; + } + else if ( !strcasecmp(ident,"Agrif_Nb_Fine_Grids") ) + { + InAgrifParentDef = 29; + pos_curagrifparent = setposcur()-19; + } + else if ( !strcasecmp(ident,"AGRIF_Nb_Step") ) + { + InAgrifParentDef = 30; + pos_curagrifparent = setposcur()-13; + } +} + +/******************************************************************************/ +/* ModifyTheAgrifFunction_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +void ModifyTheAgrifFunction_0(const char *ident) +{ + if ( InAgrifParentDef != 0 ) + AgriffunctionModify_0(ident,InAgrifParentDef); + InAgrifParentDef = 0; +} + + +/******************************************************************************/ +/* AgriffunctionModify_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* if whichone = 1 Agrif_parent ===> */ +/* */ +/* if whichone = 2 Agrif_Get_coarse_grid ===> */ +/* */ +/* if whichone = 3 Agrif_Rhox ===> */ +/* */ +/* if whichone = 4 Agrif_Parent_Rhox ===> */ +/* */ +/* if whichone = 5 Agrif_IRhox ===> */ +/* */ +/* if whichone = 6 Agrif_Parent_IRhox ===> */ +/* */ +/* if whichone = 7 Agrif_Rhoy ===> */ +/* */ +/* if whichone = 8 Agrif_Parent_Rhoy ===> */ +/* */ +/* if whichone = 9 Agrif_IRhoy ===> */ +/* */ +/* if whichone = 10 Agrif_Parent_IRhoy ===> */ +/* */ +/* if whichone = 11 Agrif_Rhoz ===> */ +/* */ +/* if whichone = 12 Agrif_Parent_Rhoz ===> */ +/* */ +/* if whichone = 13 Agrif_IRhoz ===> */ +/* */ +/* if whichone = 14 Agrif_Parent_IRhoz ===> */ +/* */ +/* if whichone = 15 Agrif_NearCommonBorderX ===> */ +/* */ +/* if whichone = 16 Agrif_NearCommonBorderX ===> */ +/* */ +/* if whichone = 17 Agrif_NearCommonBorderX ===> */ +/* */ +/* if whichone = 18 Agrif_DistantCommonBorderX ===> */ +/* */ +/* if whichone = 19 Agrif_DistantCommonBorderY ===> */ +/* */ +/* if whichone = 20 Agrif_DistantCommonBorderZ ===> */ +/* */ +/* if whichone = 21 Agrif_Get_parent_id ===> */ +/* */ +/* if whichone = 22 Agrif_Get_grid_id ===> */ +/* */ +/* if whichone = 23 Agrif_Parent_Iz ===> */ +/* */ +/* if whichone = 24 Agrif_Parent_Iy ===> */ +/* */ +/* if whichone = 25 Agrif_Parent_Ix ===> */ +/* */ +/* if whichone = 26 Agrif_Iz ===> */ +/* */ +/* if whichone = 27 Agrif_Iy ===> */ +/* */ +/* if whichone = 28 Agrif_Ix ===> */ +/* */ +/* if whichone = 29 Agrif_Nb_Fixed_Grids ===> */ +/* */ +/* if whichone = 29 Agrif_Nb_Fine_Grids ===> */ +/* */ +/* if whichone = 30 AGRIF_Nb_Step ===> */ +/* */ +/* */ +/******************************************************************************/ +void AgriffunctionModify_0(const char *ident,int whichone) +{ + char toprint[LONG_M]; + if ( firstpass == 0 ) + { + strcpy(toprint,""); + pos_end = setposcur(); + fseek(fortran_out,pos_curagrifparent,SEEK_SET); + if ( whichone == 1 || whichone == 2 ) + { + FindAndChangeNameToTabvars(ident,toprint,List_Global_Var,1); + if ( !strcasecmp(ident,toprint) ) + { + /* la liste des use de cette subroutine */ + strcpy(toprint,""); + FindAndChangeNameToTabvars(ident,toprint,List_Common_Var,whichone); + } + if ( !strcasecmp(ident,toprint) ) + { + /* la liste des use de cette subroutine */ + strcpy(toprint,""); + FindAndChangeNameToTabvars(ident,toprint,List_ModuleUsed_Var,whichone); + } + } + else if ( whichone == 3 ) /* Agrif_Rhox */ + { + sprintf(toprint,"REAL("); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"Agrif_Curgrid % spaceref(1))"); + } + else if ( whichone == 4 ) /* Agrif_Parent_Rhox */ + { + sprintf(toprint,"REAL("); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"Agrif_Curgrid % parent % spaceref(1))"); + } + else if ( whichone == 5 ) /* Agrif_Rhox */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% spaceref(1)"); + } + else if ( whichone == 6 ) /* Agrif_Parent_Rhox */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % spaceref(1)"); + } + else if ( whichone == 7 ) /* Agrif_Rhoy */ + { + sprintf(toprint,"REAL(Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% spaceref(2))"); + } + else if ( whichone == 8 ) /* Agrif_Parent_Rhoy */ + { + sprintf(toprint,"REAL(Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % spaceref(2))"); + } + else if ( whichone == 9 ) /* Agrif_Rhoy */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% spaceref(2)"); + } + else if ( whichone == 10 ) /* Agrif_Parent_Rhoy */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % spaceref(2)"); + } + else if ( whichone == 11 ) /* Agrif_Rhoz */ + { + sprintf(toprint,"REAL(Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% spaceref(3))"); + } + else if ( whichone == 12 ) /* Agrif_Parent_Rhoz */ + { + sprintf(toprint,"REAL(Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % spaceref(3))"); + } + else if ( whichone == 13 ) /* Agrif_Rhoz */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% spaceref(3)"); + } + else if ( whichone == 14 ) /* Agrif_Parent_Rhoz */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % spaceref(3)"); + } + else if ( whichone == 15 ) /* Agrif_NearCommonBorderX */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% NearRootBorder(1)"); + } + else if ( whichone == 16 ) /* Agrif_NearCommonBorderY */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% NearRootBorder(2)"); + } + else if ( whichone == 17 ) /* Agrif_NearCommonBorderZ */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% NearRootBorder(3)"); + } + else if ( whichone == 18 ) /* Agrif_NearCommonBorderX */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% DistantRootBorder(1)"); + } + else if ( whichone == 19 ) /* Agrif_NearCommonBorderY */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% DistantRootBorder(2)"); + } + else if ( whichone == 20 ) /* Agrif_NearCommonBorderZ */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% DistantRootBorder(3)"); + } + else if ( whichone == 21 ) /* Agrif_Get_parent_id */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % grid_id"); + } + else if ( whichone == 22 ) /* Agrif_Get_grid_id */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% grid_id"); + } + else if ( whichone == 23 ) /* Agrif_Parent_Iz */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % ix(3)"); + } + else if ( whichone == 24 ) /* Agrif_Parent_Iy */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % ix(2)"); + } + else if ( whichone == 25 ) /* Agrif_Parent_Ix */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% parent % ix(1)"); + } + else if ( whichone == 26 ) /* Agrif_Iz */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint," % ix(3)"); + } + else if ( whichone == 27 ) /* Agrif_Iy */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% ix(2)"); + } + else if ( whichone == 28 ) /* Agrif_Ix */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% ix(1)"); + } + else if ( whichone == 29 ) /* Agrif_Nb_Fixed_Grids */ + { + sprintf(toprint,"Agrif_nbfixedgrids"); + } + else if ( whichone == 30 ) /* AGRIF_Nb_Step */ + { + sprintf(toprint,"Agrif_Curgrid"); + if( retour77 == 0 ) strcat(toprint," & \n"); + else strcat(toprint,"\n & "); + strcat(toprint,"% ngridstep"); + } + + Save_Length(toprint,43); + + if ( whichone == 1 || whichone == 2 ) tofich(fortran_out,toprint,0); + else fprintf(fortran_out,"%s",toprint); + } +} + +/******************************************************************************/ +/* Instanciation_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +void Instanciation_0(const char *ident) +{ + listvar *newvar; + int out; + + if ( firstpass == 0 && sameagrifargument == 1 ) + { + newvar = List_Global_Var; + out = 0; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + if ( out == 0 ) + { + newvar = List_Common_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + } + if ( out == 0 ) + { + newvar = List_ModuleUsed_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,ident) ) out = 1; + else newvar = newvar->suiv; + } + } +// if ( out == 1 ) +// { +// /* then write the instanciation */ +// fprintf(fortran_out,"\n %s = %s",ident,vargridcurgridtabvars(newvar->var,3)); +// printf("#\n# Instanciation_0: |%s = %s|\n#\n", ident,vargridcurgridtabvars(newvar->var,3)); +// } + } + sameagrifargument = 0; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilCharacter.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilCharacter.c new file mode 100644 index 0000000000000000000000000000000000000000..a6731b20efee95667eb852c6ef3cc6cf6b9378c2 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilCharacter.c @@ -0,0 +1,387 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + + + + +/******************************************************************************/ +/* FindAndChangeNameToTabvars */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +/* if whichone = 0 ----> Agrif_tabvars(i) % array2 */ +/* */ +/* if whichone = 1 ----> Agrif_tabvars(i) % parentvar % array2 */ +/* */ +/******************************************************************************/ +void FindAndChangeNameToTabvars(const char name[LONG_M],char toprint[LONG_M], + listvar * listtosee, int whichone) +{ + listvar *newvar; + int out; + + + if ( strcasecmp(name,"") ) + { + newvar=listtosee; + out=0; + while( newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,name) ) + { + + if ( LookingForVariableInListName( + List_SubroutineArgument_Var,name) == 0 ) + { + out = 1; + strcat(toprint,vargridcurgridtabvars(newvar->var, whichone)); + } + else newvar=newvar->suiv; + } + else newvar=newvar->suiv; + } + if ( out == 0 ) strcat(toprint,name); + } + Save_Length(toprint,44); +} + + +/******************************************************************************/ +/* ChangeTheInitalvaluebyTabvarsName */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +/* */ +/* */ +/* */ +/******************************************************************************/ +const char *ChangeTheInitalvaluebyTabvarsName(const char *nom, listvar *listtoread) +{ + char toprinttmp[LONG_M]; + char chartmp[2]; + size_t i = 0; + + strcpy(toprintglob, ""); + strcpy(toprinttmp, ""); + + while ( i < strlen(nom) ) + { + if ( (nom[i] == '+') || (nom[i] == '-') || (nom[i] == '*') || (nom[i] == '/') || + (nom[i] == '(') || (nom[i] == ')') || (nom[i] == ':') || (nom[i] == ',') ) + { + FindAndChangeNameToTabvars(toprinttmp,toprintglob,listtoread,0); + strcpy(toprinttmp, ""); + sprintf(chartmp, "%c", nom[i]); + strcat(toprintglob, chartmp); + } + else + { + sprintf(chartmp, "%c", nom[i]); + strcat(toprinttmp, chartmp); + } + i += 1; + } + FindAndChangeNameToTabvars(toprinttmp,toprintglob,listtoread,0); + strcpy(toprinttmp,""); + + Save_Length(toprinttmp,44); + Save_Length(toprintglob,39); + + return toprintglob; +} + +/******************************************************************************/ +/* IsVariableReal */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +/* */ +/* */ +/* */ +/******************************************************************************/ +int IsVariableReal(const char *nom) +{ + return ( ( nom[0] >= 'a' && nom[0] <= 'h' ) || + ( nom[0] >= 'A' && nom[0] <= 'H' ) || + ( nom[0] >= 'o' && nom[0] <= 'z' ) || + ( nom[0] >= 'O' && nom[0] <= 'Z' ) ); +} +/******************************************************************************/ +/* IsVarInUseFile */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +/* */ +/* */ +/* */ +/******************************************************************************/ +void IsVarInUseFile(const char *nom) +{ + listvar *parcours; + listparameter *parcoursparam; + int out; + + out = 0; + + parcours = List_Global_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(nom,parcours->var->v_nomvar) ) out = 1 ; + else parcours=parcours->suiv; + } + if ( out == 0 ) + { + parcours = List_Common_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(nom,parcours->var->v_nomvar) ) out = 1 ; + else parcours=parcours->suiv; + } + } + if ( out == 0 ) + { + parcours = List_GlobalParameter_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(nom,parcours->var->v_nomvar) ) out =1 ; + else parcours=parcours->suiv; + } + } + if ( out == 0 ) + { + parcours = List_Parameter_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(nom,parcours->var->v_nomvar) ) out = 1 ; + else parcours=parcours->suiv; + } + } + if ( out == 0 ) + { + parcoursparam = List_GlobParamModuleUsed_Var; + while( parcoursparam && out == 0 ) + { + if ( !strcasecmp(nom,parcoursparam->p_name) ) out = 2 ; + else parcoursparam=parcoursparam->suiv; + } + } + if ( out == 0 ) + { + parcours = List_ModuleUsed_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(nom,parcours->var->v_nomvar) ) out = 2 ; + else parcours=parcours->suiv; + } + } + if ( out == 0 || out == 2 ) + { + parcoursparam = List_GlobParamModuleUsedInModuleUsed_Var; + while( parcoursparam && out != 1 ) + { + if ( !strcasecmp(nom,parcoursparam->p_name) ) out = 1 ; + else parcoursparam=parcoursparam->suiv; + } + if ( out == 1 ) + { + strcpy(charusemodule,parcoursparam->p_modulename); + Addmoduletothelist(parcoursparam->p_modulename); + } + } + if ( out == 0 && + strcasecmp(nom,"MAX") && + strcasecmp(nom,"mpi_status_size") + ) + { + /* printf("--- in UtilCharacter we do not found the \n"); + printf("--- variable %s, the module where this \n",nom); + printf("--- variable has been defined has not been\n"); + printf("--- found.\n");*/ + } +} + +/******************************************************************************/ +/* DecomposeTheNameinlistnom */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* */ +/******************************************************************************/ +listnom *DecomposeTheNameinlistnom(const char *nom, listnom * listout) +{ + char toprinttmp[LONG_M]; + char chartmp[2]; + size_t i = 0; + + strcpy(toprinttmp,""); + + while ( i < strlen(nom) ) + { + if ( nom[i] == '+' || + nom[i] == '-' || + nom[i] == '*' || + nom[i] == '/' || + nom[i] == ')' || + nom[i] == '(' || + nom[i] == ',' || + nom[i] == ':' + ) + { + if (strcasecmp(toprinttmp,"") && ( toprinttmp[0] >= 'A' ) ) + { + listout = Addtolistnom(toprinttmp,listout,0); + } + strcpy(toprinttmp,""); + } + else + { + sprintf(chartmp,"%c",nom[i]); + strcat(toprinttmp,chartmp); + } + i=i+1; + } + if (strcasecmp(toprinttmp,"") && ( toprinttmp[0] >= 'A' ) ) + { + listout = Addtolistnom(toprinttmp,listout,0); + } + Save_Length(toprinttmp,44); + strcpy(toprinttmp,""); + + return listout; +} + + +/******************************************************************************/ +/* DecomposeTheName */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +void DecomposeTheName(const char *nom) +{ + char toprinttmp[LONG_M]; + char chartmp[2]; + size_t i = 0; + + strcpy(toprinttmp,""); + + while ( i < strlen(nom) ) + { + if ( nom[i] == '+' || + nom[i] == '-' || + nom[i] == '*' || + nom[i] == '/' || + nom[i] == ')' || + nom[i] == '(' || + nom[i] == ',' || + nom[i] == ':' + ) + { + if (strcasecmp(toprinttmp,"") && ( toprinttmp[0] >= 'A' ) ) + { + ajoutevarindoloop_definedimension (toprinttmp); + /* Is this variable present in globvarofusefile */ + IsVarInUseFile(toprinttmp); + } + strcpy(toprinttmp,""); + } + else + { + sprintf(chartmp,"%c",nom[i]); + strcat(toprinttmp,chartmp); + } + i=i+1; + } + if (strcasecmp(toprinttmp,"") && ( toprinttmp[0] >= 'A' ) ) + { + ajoutevarindoloop_definedimension (toprinttmp); + /* Is this variable present in globvarofusefile */ + IsVarInUseFile(toprinttmp); + } + Save_Length(toprinttmp,44); + strcpy(toprinttmp,""); + +} + +void convert2lower(char *lowername, const char* inputname) +{ + int i, l, caractere; + + strcpy(lowername, inputname); + l = strlen(lowername)-1; + + for ( i=0 ; i<=l ; i++) + { + caractere = lowername[i]; + if ( (caractere>=65 && caractere<=90) || (caractere>=192 && caractere<=221) ) + { + lowername[i] += 32; + } + } +} + +int convert2int(const char *name) +{ + int i; + int caractere; + int value; + int value_tmp; + int longueur; + + value = 0; + + longueur = strlen(name) - 1; + for (i=0;i<=longueur;i++) + { + caractere=name[i]; + value_tmp = caractere -'0'; + if ( value_tmp > 9 ) return 0; + if ( longueur+1-i == 6 ) value = value + value_tmp *100000; + else if ( longueur+1-i == 5 ) value = value + value_tmp *10000; + else if ( longueur+1-i == 4 ) value = value + value_tmp *1000; + else if ( longueur+1-i == 3 ) value = value + value_tmp *100; + else if ( longueur+1-i == 2 ) value = value + value_tmp *10; + else if ( longueur+1-i == 1 ) value = value + value_tmp *1; + } + return value; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFile.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFile.c new file mode 100644 index 0000000000000000000000000000000000000000..8bbd6dc7c46d01b40edd486560d5d67d15f802e4 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFile.c @@ -0,0 +1,128 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + + +/******************************************************************************/ +/* open_for_write */ +/******************************************************************************/ +/* This subroutine is used to open a file */ +/******************************************************************************/ +FILE* open_for_write (const char *filename) +{ + char filefich[LONG_FNAME]; + sprintf(filefich,"%s/%s",include_dir,filename); + return fopen(filefich, "w"); +} + +/******************************************************************************/ +/* open_for_append */ +/******************************************************************************/ +/* This subroutine is used to open a file with option a+ */ +/******************************************************************************/ +FILE* open_for_append (const char *filename) +{ + char filefich[LONG_M]; + sprintf(filefich,"%s/%s",include_dir,filename); + return fopen(filefich, "a+"); +} + +/******************************************************************************/ +/* setposcurname */ +/******************************************************************************/ +/* This subroutine is used to know the current position in the file in argument */ +/******************************************************************************/ +/* */ +/* setposcur ---------> position in file */ +/* */ +/******************************************************************************/ +long int setposcurname(FILE *fileout) +{ + fflush(fileout); + return ftell(fileout); +} + +/******************************************************************************/ +/* setposcur */ +/******************************************************************************/ +/* This subroutine is used to know the current position in the file */ +/******************************************************************************/ +/* */ +/* setposcur ---------> position in file */ +/* */ +/******************************************************************************/ +long int setposcur() +{ + return setposcurname(fortran_out); +} + +/******************************************************************************/ +/* copyuse_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/* We should write in the fortran_out the USE tok_name */ +/* read in the original file */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void copyuse_0(const char *namemodule) +{ + if ( IsTabvarsUseInArgument_0() == 1 ) + { + /* We should write this declaration into the original subroutine too */ + fprintf(oldfortran_out," use %s\n", namemodule); + } +} + +/******************************************************************************/ +/* copyuseonly_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/* We should write in the fortran_out the USE tok_name, only */ +/* read in the original file */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void copyuseonly_0(const char *namemodule) +{ + if (firstpass == 0 && IsTabvarsUseInArgument_0() == 1 ) + { + /* We should write this declaration into the original subroutine too */ + fprintf(oldfortran_out," use %s , only : \n", namemodule); + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFortran.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFortran.c new file mode 100644 index 0000000000000000000000000000000000000000..29f780295e7217f906a0c8f69a9a16238f060aaa --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilFortran.c @@ -0,0 +1,635 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* initdimprob */ +/******************************************************************************/ +/* This subroutine is used to initialized grid dimension variable */ +/******************************************************************************/ +void initdimprob(int dimprobmod, const char * nx, const char * ny, const char* nz) +{ + dimprob = dimprobmod; + + strcpy(nbmaillesX, nx); + strcpy(nbmaillesY, ny); + strcpy(nbmaillesZ, nz); +} + +/******************************************************************************/ +/* Variableshouldberemoved */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/* Agrif_(variable) ====> Agrif_(variable) */ +/* */ +/******************************************************************************/ +int Variableshouldberemoved(const char *nom) +{ + return Agrif_in_Tok_NAME(nom); +} + +/******************************************************************************/ +/* variableisglobal */ +/******************************************************************************/ +/* This subroutine is to know if a variable is global */ +/******************************************************************************/ +int variableisglobal(listvar *curvar, listvar *listin) +{ + int Globalite; + listvar *newvar; + + + Globalite = 0; + newvar = listin; + while ( newvar && Globalite == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) ) + { + Globalite = 1; + /* Now we should give the definition of the variable in the */ + /* table List_UsedInSubroutine_Var */ + strcpy(curvar->var->v_typevar, newvar->var->v_typevar); + strcpy(curvar->var->v_dimchar, newvar->var->v_dimchar); + curvar->var->v_nbdim = newvar->var->v_nbdim; + curvar->var->v_dimensiongiven = newvar->var->v_dimensiongiven; + curvar->var->v_allocatable = newvar->var->v_allocatable; + curvar->var->v_target = newvar->var->v_target; + curvar->var->v_catvar = newvar->var->v_catvar; + curvar->var->v_pointerdeclare = newvar->var->v_pointerdeclare; + curvar->var->v_indicetabvars = newvar->var->v_indicetabvars; + strcpy(curvar->var->v_nameinttypename, newvar->var->v_nameinttypename); + strcpy(curvar->var->v_precision, newvar->var->v_precision); + strcpy(curvar->var->v_readedlistdimension, newvar->var->v_readedlistdimension); + strcpy(curvar->var->v_commoninfile, newvar->var->v_commoninfile); + } + else + { + newvar = newvar->suiv; + } + } + + return Globalite ; +} + +int VariableIsInListCommon(listvar *curvar,listvar *listin) +{ + int present; + listvar *newvar; + + present = 0; + newvar = listin; + + while ( newvar && present == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) && + !strcasecmp(newvar->var->v_subroutinename, curvar->var->v_subroutinename) ) + { + strcpy(curvar->var->v_commoninfile,newvar->var->v_commoninfile); + Merge_Variables(curvar->var,newvar->var); + present = 1; + } + else newvar = newvar->suiv; + } + + return present; +} + +int VariableIsInList(listvar *curvar,listvar *listin) +{ + int present; + listvar *newvar; + + present = 0; + newvar = listin; + while ( newvar && present == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,curvar->var->v_nomvar) ) + { + Merge_Variables(curvar->var,newvar->var); + present = 1; + } + else newvar = newvar->suiv; + } + + return present; +} + +/******************************************************************************/ +/* variableisglobalinmodule */ +/******************************************************************************/ +/* This subroutine is to know if a variable is global */ +/******************************************************************************/ +void variableisglobalinmodule(listcouple *listin, const char *module, FILE *fileout, long int oldposcuruse) +{ + int Globalite; + listcouple *newvar; + listcouple *newvarprec; + listvar *tempo; + listvar *newvar2; + int out; + char truename[LONG_VNAME]; + + Globalite = 1; + newvarprec = (listcouple *)NULL; + tempo = (listvar *)NULL; + tempo = Readthedependfile(module,tempo); + newvar = listin; + + while ( newvar ) + { + if (!strcmp(newvar->c_namepointedvar,"")) { + strcpy(truename,newvar->c_namevar); + } + else + { + strcpy(truename,newvar->c_namepointedvar); + } + + out = 0; + newvar2 = tempo; + while ( newvar2 && out == 0 ) + { + if ( !strcasecmp(newvar2->var->v_nomvar,truename) ) out = 1; + else newvar2 = newvar2 ->suiv; + } + if ( out == 1 ) + { + /* remove from the listin */ + if ( newvar == listin ) + { + listin = listin->suiv; + newvar = listin; + } + else + { + newvarprec->suiv = newvar->suiv; + newvar = newvar->suiv; + } + } + else + { + newvarprec = newvar; + newvar = newvar->suiv; + Globalite = 0; + } + } + if ( Globalite == 0 || !newvar) + { + pos_end = setposcurname(fileout); + RemoveWordSET_0(fileout,oldposcuruse,pos_end-oldposcuruse); + + newvar = listin; + while ( newvar ) + { + fprintf(fileout," use %s, only : %s \n",module,newvar->c_namevar); + newvar = newvar->suiv; + } + } +} + +void Write_Word_end_module_0() +{ + if ( firstpass == 0 ) + { + fprintf(fortran_out,"\n end module %s",curmodulename); + } +} + +void Add_Subroutine_For_Alloc(const char *nom) +{ + listnom *parcours; + listnom *newvar; + int out; + + newvar = (listnom*) calloc(1, sizeof(listnom)); + strcpy(newvar->o_nom,nom); + newvar->suiv = NULL; + + if ( !List_Subroutine_For_Alloc ) + { + List_Subroutine_For_Alloc = newvar; + } + else + { + parcours = List_Subroutine_For_Alloc; + out = 0 ; + while ( parcours->suiv && out == 0 ) + { + if ( !strcasecmp(parcours->o_nom,nom) ) out = 1 ; + else parcours = parcours ->suiv; + } + /* */ + if ( out == 0 ) + { + if ( strcasecmp(parcours->o_nom,nom) ) parcours->suiv = newvar; + } + } +} + +void Write_Closing_Module(int forend) +{ + listvar *parcours; + listnom *parcours_nom; + listnom *parcours_nomprec; + variable *v; + int out = 0; + int headtypewritten = 0; + char ligne[LONG_M]; + int changeval; + + // Write Global Parameter Declaration + parcours = List_GlobalParameter_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename, curmodulename) ) + { + WriteVarDeclaration(parcours->var, module_declar, 0, 1); + } + parcours = parcours -> suiv; + } + + // Write Global Type declaration + parcours = List_Global_Var; + while( parcours ) + { + v = parcours->var; + if ( !strcasecmp(v->v_modulename, curmodulename) && + !strcasecmp(v->v_typevar, "type") ) + { + if ( headtypewritten == 0 ) + { + fprintf(fortran_out, "\n type Agrif_%s\n", curmodulename); + headtypewritten = 1; + } + changeval = 0; + if ( v->v_allocatable ) + { + changeval = 1; + v->v_allocatable = 0; + v->v_pointerdeclare = 1; + } + WriteVarDeclaration(v, fortran_out, 0, 0); + if ( changeval ) + { + v->v_allocatable = 1; + v->v_pointerdeclare = 0; + } + out = 1; + } + parcours = parcours -> suiv; + } + if (out == 1) + { + fprintf(fortran_out, " end type Agrif_%s\n", curmodulename); + sprintf(ligne, "type(Agrif_%s), dimension(:), allocatable :: Agrif_%s_var",curmodulename, curmodulename); + tofich(fortran_out,ligne,1); + fprintf(fortran_out, " public :: Agrif_%s\n", curmodulename); + fprintf(fortran_out, " public :: Agrif_%s_var\n", curmodulename); + } + + // Write NotGridDepend declaration + parcours = List_NotGridDepend_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename,curmodulename) ) + { + WriteVarDeclaration(parcours->var, fortran_out, 0, 1); + } + parcours = parcours -> suiv; + } + + // Write Alloc_agrif_'modulename' subroutine + parcours_nomprec = (listnom*) NULL; + parcours_nom = List_NameOfModule; + out = 0 ; + while ( parcours_nom && out == 0 ) + { + if ( !strcasecmp(curmodulename,parcours_nom->o_nom) ) out = 1; + else parcours_nom = parcours_nom -> suiv; + } + if ( ! out ) + { + printf("#\n# Write_Closing_Module : OUT == 0 *** /!\\ ***\n"); + printf("# FIXME: POSSIBLE BUG in CONV !!!\n#\n"); + } + if ( out ) + { + if ( parcours_nom->o_val == 1 ) + { + fprintf(fortran_out,"\n public :: Alloc_agrif_%s\n",curmodulename); + } + if ( (forend == 0) || (parcours_nom->o_val == 1) ) + { + fprintf(fortran_out,"\n contains\n"); + } + if ( parcours_nom->o_val == 1 ) + { + fprintf(fortran_out, " subroutine Alloc_agrif_%s(Agrif_Gr)\n", curmodulename); + fprintf(fortran_out, " use Agrif_Util\n"); + fprintf(fortran_out, " type(Agrif_grid), pointer :: Agrif_Gr\n"); + fprintf(fortran_out, " integer :: i\n"); + fprintf(fortran_out, "\n#include \"alloc_agrif_%s.h\"\n", curmodulename); + fprintf(fortran_out, " end subroutine Alloc_agrif_%s\n", curmodulename); + Add_Subroutine_For_Alloc(curmodulename); + } + else + { + parcours_nom = List_Subroutine_For_Alloc; + out = 0; + while ( parcours_nom && out == 0 ) + { + if ( !strcasecmp(parcours_nom->o_nom, curmodulename) ) out = 1; + else + { + parcours_nomprec = parcours_nom; + parcours_nom = parcours_nom->suiv; + } + } + if ( out ) + { + if ( parcours_nom == List_Subroutine_For_Alloc) + { + List_Subroutine_For_Alloc = List_Subroutine_For_Alloc->suiv; + } + else + { + parcours_nomprec->suiv = parcours_nom->suiv; + parcours_nom = parcours_nomprec->suiv ; + } + } + } + } +} + +/******************************************************************************/ +/* IsTabvarsUseInArgument_0 */ +/******************************************************************************/ +/* Firstpass 1 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int IsTabvarsUseInArgument_0() +{ + int out; + int doloopout; + listvar *parcours; + + out=1; + + if ( List_UsedInSubroutine_Var ) + { + doloopout = 0; + parcours = List_UsedInSubroutine_Var; + while ( parcours && doloopout == 0 ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) ) + doloopout = 1; + else parcours = parcours->suiv; + } + if ( doloopout == 0 ) out = 0; + else out = 1 ; + } + else out = 0; + + return out; +} + + +/******************************************************************************/ +/* ImplicitNoneInSubroutine */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int ImplicitNoneInSubroutine() +{ + listname *parcours; + int out; + + parcours= List_ImplicitNoneSubroutine; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->n_name,subroutinename) ) out = 1; + else parcours = parcours->suiv; + } + return out; +} + +/******************************************************************************/ +/* Add_Pointer_Var_From_List_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Pointer_Var_From_List_1(listvar *listin) +{ + listvar *parcours; + + if ( firstpass == 1 ) + { + parcours = listin; + while ( parcours ) + { + Add_Pointer_Var_1(parcours->var->v_nomvar); + parcours = parcours -> suiv ; + } + } +} + +/******************************************************************************/ +/* Add_Pointer_Var_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Pointer_Var_1(char *nom) +{ + listname *newvar; + listname *parcours; + int out; + + if ( firstpass == 1 ) + { + if ( !List_Pointer_Var ) + { + newvar = (listname*) calloc(1, sizeof(listname)); + strcpy(newvar->n_name, nom); + newvar->suiv = NULL; + List_Pointer_Var = newvar; + } + else + { + parcours = List_Pointer_Var; + out = 0 ; + while ( parcours->suiv && out == 0 ) + { + if ( !strcasecmp(parcours->n_name,nom) ) out = 1; + else + parcours=parcours->suiv; + } + if ( out == 0 ) + { + if ( !strcasecmp(parcours->n_name,nom) ) out = 1; + else + { + /* add the record */ + newvar = (listname*) calloc(1, sizeof(listname)); + strcpy(newvar->n_name,nom); + newvar->suiv = NULL; + parcours->suiv = newvar; + } + } + } + } +} + +/******************************************************************************/ +/* varispointer_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int varispointer_0(char *ident) +{ + listname *newname; + int out; + + out =0; + if ( firstpass == 0 ) + { + newname = List_Pointer_Var; + while( newname && out == 0 ) + { + if ( !strcasecmp(ident,newname->n_name) ) out = 1 ; + else newname = newname->suiv; + } + } + return out; +} + +/******************************************************************************/ +/* varistyped_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int varistyped_0(char *ident) +{ + listvar *parcours; + int out; + + out =0; + if ( firstpass == 0 ) + { + parcours = List_Global_Var; + while( parcours && out == 0 ) + { + if ( !strcasecmp(ident,parcours->var->v_nomvar) ) + { + if (!strcasecmp(parcours->var->v_typevar,"type")) out = 1; + } + parcours = parcours->suiv; + } + } + return out; +} + + +/******************************************************************************/ +/* VariableIsFunction */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int VariableIsFunction(const char *ident) +{ + int out; + listvar *newvar; + + out = 0; + + if ( !strcasecmp(ident,"size") || + !strcasecmp(ident,"if") || + !strcasecmp(ident,"max") || + !strcasecmp(ident,"min") ) + { + newvar = List_SubroutineDeclaration_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(subroutinename, newvar->var->v_subroutinename) && + !strcasecmp(ident, newvar->var->v_nomvar) ) + { + out = 1; + } + newvar = newvar -> suiv ; + } + if ( out == 0 ) /* if it has not been found */ + { + newvar = List_Global_Var; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(ident, newvar->var->v_nomvar) ) out = 1; + newvar = newvar -> suiv ; + } + } + } + return (out == 0); +} + +void dump_var(const variable* var) +{ + fprintf(stderr, " var->v_nomvar : %s\n",var->v_nomvar); + fprintf(stderr, " var->v_indice : %d\n",var->v_indicetabvars); + fprintf(stderr, " var->v_typevar: %s\n",var->v_typevar); + fprintf(stderr, " var->v_catvar : %d\n",var->v_catvar); + fprintf(stderr, " var->v_modulename: %s\n",var->v_modulename); + fprintf(stderr, " var->v_subroutinename: %s\n",var->v_subroutinename); + fprintf(stderr, " var->v_commonname: %s\n",var->v_commonname); + fprintf(stderr, " var->v_commoninfile: %s\n",var->v_commoninfile); + fprintf(stderr, " var->v_nbdim: %d\n",var->v_nbdim); + fprintf(stderr, " var->v_common: %d\n",var->v_common); + fprintf(stderr, " var->v_module: %d\n",var->v_module); + fprintf(stderr, " var->v_initialvalue: %s\n",var->v_initialvalue); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilListe.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilListe.c new file mode 100644 index 0000000000000000000000000000000000000000..12af4d6fffbf980823b0adbdbc36da649576b2c8 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilListe.c @@ -0,0 +1,706 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + + +void Init_Variable(variable *var) +{ + strcpy(var->v_typevar , ""); + strcpy(var->v_nomvar , ""); + strcpy(var->v_oldname , ""); + strcpy(var->v_dimchar , ""); + strcpy(var->v_modulename , ""); + strcpy(var->v_commonname , ""); + strcpy(var->v_vallengspec , ""); + strcpy(var->v_nameinttypename , ""); + strcpy(var->v_commoninfile , ""); + strcpy(var->v_subroutinename , ""); + strcpy(var->v_precision , ""); + strcpy(var->v_initialvalue , ""); + strcpy(var->v_IntentSpec , ""); + strcpy(var->v_readedlistdimension, ""); + var->v_nbdim = 0 ; + var->v_common = 0 ; + var->v_positioninblock = 0 ; + var->v_module = 0 ; + var->v_save = 0 ; + var->v_catvar = 0 ; + var->v_VariableIsParameter = 0 ; + var->v_PublicDeclare = 0 ; + var->v_PrivateDeclare = 0 ; + var->v_ExternalDeclare = 0 ; + var->v_pointedvar = 0 ; + var->v_notgrid = 0 ; + var->v_dimensiongiven = 0 ; + var->v_c_star = 0 ; + var->v_indicetabvars = 0 ; + var->v_pointerdeclare = 0 ; + var->v_optionaldeclare = 0 ; + var->v_allocatable = 0 ; + var->v_target = 0 ; + var->v_dimsempty = 0 ; + var->v_dimension = (listdim *) NULL; +} +/******************************************************************************/ +/* AddListvartolistvar */ +/******************************************************************************/ +/* This subroutine is used to add a listvar l at the end of a listvar */ +/* glob. */ +/* */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + glob +--->+ glob +--->+ glob +--->+ glob +--->+ l + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +listvar * AddListvarToListvar ( listvar *l, listvar *glob, int ValueFirstpass ) +{ + listvar *newvar; + if ( firstpass == ValueFirstpass ) + { + if ( !glob ) glob = l; + else + { + newvar = glob; + while (newvar->suiv) + newvar = newvar->suiv; + newvar->suiv = l; + } + } + return glob; +} + +/******************************************************************************/ +/* CreateAndFillin_Curvar */ +/******************************************************************************/ +/* This subroutine is used to create the record corresponding to the */ +/* list of declaration */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void CreateAndFillin_Curvar(const char *type, variable *curvar) +{ + if ( !strcasecmp(type, "character") && strcasecmp(CharacterSize, "") ) + { + strcpy(curvar->v_dimchar, CharacterSize); + } + + /* On donne la precision de la variable si elle a ete donnee */ + curvar->v_c_star = 0; + if ( c_star == 1 ) curvar->v_c_star = 1; + + strcpy(curvar->v_vallengspec,""); + if ( strcasecmp(vallengspec,"") ) + { + strcpy(curvar->v_vallengspec,vallengspec); + Save_Length(vallengspec,8); + } + + strcpy(curvar->v_precision,""); + if ( strcasecmp(NamePrecision,"") ) + { + strcpy(curvar->v_precision,NamePrecision); + addprecision_derivedfromkind(curvar); + Save_Length(NamePrecision,12); + } + /* Si cette variable a ete declaree dans un module on met curvar->module=1 */ + if ( inmoduledeclare == 1 || SaveDeclare == 1 ) + { + curvar->v_module = 1; + } + /* Puis on donne le nom du module dans curvar->v_modulename */ + strcpy(curvar->v_modulename,curmodulename); + /* Si cette variable a ete initialisee */ + if (InitialValueGiven == 1 ) + { + strcpy(curvar->v_initialvalue,InitValue); + Save_Length(InitValue,14); + } + /* Si cette variable est declaree en save */ + if (SaveDeclare == 1 && !strcasecmp(curvar->v_typevar,"type")) curvar->v_save = 1; + + /* Si cette variable est v_allocatable */ + if (Allocatabledeclare == 1 ) curvar->v_allocatable=1; + + /* Si cette variable est v_target */ + if (Targetdeclare == 1 ) curvar->v_target=1; + + /* if INTENT spec has been given */ + if ( strcasecmp(IntentSpec,"") ) + { + strcpy(curvar->v_IntentSpec,IntentSpec); + Save_Length(IntentSpec,13); + } +} + + +void addprecision_derivedfromkind(variable *curvar) +{ + listnom *parcours; + char kind[LONG_VNAME]; + char kind_val[LONG_C]; + + sscanf(curvar->v_precision, "%100s =", kind_val); + + if ( !strcasecmp(kind_val, "kind") ) + sscanf(curvar->v_precision, "%50s = %50s", kind, kind_val); + + parcours = listofkind; + while (parcours) + { + if ( !strcasecmp(parcours->o_nom, kind_val) ) + { + sprintf(curvar->v_nameinttypename, "%d", parcours->o_val); + } + parcours=parcours->suiv; + } +} + +/******************************************************************************/ +/* duplicatelistvar */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +// void duplicatelistvar(listvar *orig) +// { +// listvar *parcours; +// listvar *tmplistvar; +// listvar *tmplistvarprec; +// listdim *tmplistdim; +// variable *tmpvar; +// +// tmplistvarprec = (listvar *)NULL; +// parcours = orig; +// while ( parcours ) +// { +// tmplistvar = (listvar *)calloc(1,sizeof(listvar)); +// tmpvar = (variable *)calloc(1,sizeof(variable)); +// /* */ +// Init_Variable(tmpvar); +// /* */ +// strcpy(tmpvar->v_typevar, parcours->var->v_typevar); +// strcpy(tmpvar->v_nomvar, parcours->var->v_nomvar); +// strcpy(tmpvar->v_oldname, parcours->var->v_oldname); +// strcpy(tmpvar->v_dimchar, parcours->var->v_dimchar); +// if ( parcours->var->v_dimension ) +// { +// tmplistdim = (listdim*) calloc(1,sizeof(listdim)); +// tmplistdim = parcours->var->v_dimension; +// tmpvar->v_dimension = tmplistdim; +// } +// tmpvar->v_nbdim = parcours->var->v_nbdim; +// tmpvar->v_common = parcours->var->v_common; +// tmpvar->v_module = parcours->var->v_module; +// tmpvar->v_save = parcours->var->v_save; +// tmpvar->v_positioninblock = parcours->var->v_positioninblock; +// tmpvar->v_VariableIsParameter = parcours->var->v_VariableIsParameter; +// tmpvar->v_indicetabvars = parcours->var->v_indicetabvars; +// tmpvar->v_pointedvar = parcours->var->v_pointedvar; +// tmpvar->v_dimensiongiven = parcours->var->v_dimensiongiven; +// tmpvar->v_c_star = parcours->var->v_c_star; +// tmpvar->v_catvar = parcours->var->v_catvar; +// tmpvar->v_pointerdeclare = parcours->var->v_pointerdeclare; +// tmpvar->v_optionaldeclare = parcours->var->v_optionaldeclare; +// tmpvar->v_allocatable = parcours->var->v_allocatable; +// tmpvar->v_target = parcours->var->v_target; +// tmpvar->v_dimsempty = parcours->var->v_dimsempty; +// strcpy(tmpvar->v_modulename, parcours->var->v_modulename); +// strcpy(tmpvar->v_commonname, parcours->var->v_commonname); +// strcpy(tmpvar->v_vallengspec, parcours->var->v_vallengspec); +// strcpy(tmpvar->v_nameinttypename, parcours->var->v_nameinttypename); +// strcpy(tmpvar->v_commoninfile, cur_filename); +// strcpy(tmpvar->v_subroutinename, parcours->var->v_subroutinename); +// strcpy(tmpvar->v_precision, parcours->var->v_precision); +// strcpy(tmpvar->v_initialvalue, parcours->var->v_initialvalue); +// strcpy(tmpvar->v_IntentSpec, parcours->var->v_IntentSpec); +// strcpy(tmpvar->v_readedlistdimension, parcours->var->v_readedlistdimension); +// +// tmplistvar->var = tmpvar; +// tmplistvar->suiv = NULL; +// +// if ( !listduplicated ) +// { +// listduplicated = tmplistvar; +// tmplistvarprec = listduplicated; +// } +// else +// { +// tmplistvarprec->suiv = tmplistvar; +// tmplistvarprec = tmplistvar; +// } +// parcours = parcours->suiv; +// } +// } + +/******************************************************************************/ +/* insertdim */ +/******************************************************************************/ +/* This subroutine is used to insert a record in a list of */ +/* struct : listdim */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ lin +--->+ lin +--->+ lin +--->+ lin + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +listdim * insertdim(listdim *lin,typedim nom) +{ + listdim *newdim ; + listdim *parcours ; + + newdim=(listdim *) calloc(1,sizeof(listdim)); + newdim->dim=nom; + newdim->suiv=NULL; + + if ( ! lin ) + { + lin = newdim; + } + else + { + parcours = lin; + while ( parcours->suiv ) parcours=parcours->suiv; + parcours->suiv = newdim; + } + + return lin; +} + +/******************************************************************************/ +/* change_dim_char */ +/******************************************************************************/ +/* This subroutine is used to change the dimension in the list lin */ +/******************************************************************************/ +/* _______ _______ _______ _______ */ +/* + l + + l + + l + + l + */ +/* + old +--->+ old +--------------->+ lin +--->+ lin + */ +/* +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +void change_dim_char(listdim *lin,listvar * l) +{ + listvar *parcours_var; + variable *v; + + parcours_var=l; + while(parcours_var) + { + v = parcours_var->var; + strcpy(v->v_dimchar,(lin->dim).last); + parcours_var=parcours_var->suiv; + } +} + + +/******************************************************************************/ +/* get_num_dims */ +/******************************************************************************/ +/* This subroutine is used to know the dimension of a table */ +/******************************************************************************/ +/* */ +/* Dimension(jpi,jpj,jpk) ----------> get_num_dims = 3 */ +/* */ +/******************************************************************************/ +int get_num_dims ( const listdim *d ) +{ + listdim *parcours; + int compteur = 0; + + parcours = (listdim *) d; + while(parcours) + { + compteur++; + parcours = parcours->suiv; + } + return compteur; +} + + +/******************************************************************************/ +/* CREATEVAR */ +/******************************************************************************/ +/* This subroutine is used to create and initialized a record of the */ +/* struct : variable */ +/******************************************************************************/ +variable * createvar(const char *nom, listdim *d) +{ + variable *var; + listdim *dims; + char ligne[LONG_M]; + char listdimension[LONG_M]; + + var = (variable *) calloc(1,sizeof(variable)); + + Init_Variable(var); + + strcpy(listdimension,""); + strcpy(var->v_nomvar,nom); + strcpy(var->v_modulename,curmodulename); + strcpy(var->v_commoninfile,cur_filename); + strcpy(var->v_subroutinename,subroutinename); + + if ( strcasecmp(nameinttypename,"") ) + { + strcpy(var->v_nameinttypename,nameinttypename); + } + + if ( optionaldeclare == 1 ) var->v_optionaldeclare = 1; + if ( pointerdeclare == 1 ) var->v_pointerdeclare = 1; + if ( VariableIsParameter == 1 ) var->v_VariableIsParameter = 1 ; + if ( PublicDeclare == 1 ) var->v_PublicDeclare = 1 ; + if ( PrivateDeclare == 1 ) var->v_PrivateDeclare = 1; + if ( ExternalDeclare == 1 ) var->v_ExternalDeclare = 1; + + var->v_dimension = d; + + /* Creation of the string for the dimension of this variable */ + dimsempty = 1; + if ( d ) + { + var->v_dimensiongiven = 1; + dims = d; + while (dims) + { + if ( strcasecmp(dims->dim.first,"") || strcasecmp(dims->dim.last,"")) + { + dimsempty = 0; + } + sprintf(ligne,"%s:%s",dims->dim.first,dims->dim.last); + strcat(listdimension,ligne); + if ( dims->suiv ) + { + strcat(listdimension,","); + } + dims = dims->suiv; + } + if ( dimsempty == 1 || GlobalDeclarationType == 1 ) var->v_dimsempty = 1; + } + strcpy(var->v_readedlistdimension,listdimension); + Save_Length(listdimension,15); + var->v_nbdim = get_num_dims(d); + + return var; +} + +/******************************************************************************/ +/* INSERTVAR */ +/******************************************************************************/ +/* This subroutine is used to insert a record in a list of the */ +/* struct : listvar */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + lin +--->+ lin +--->+ lin +--->+ lin +--->+ NEW + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* */ +/******************************************************************************/ +listvar * insertvar(listvar *lin,variable *v) +{ + listvar *newvar ; + listvar *tmpvar ; + + newvar=(listvar *) calloc(1,sizeof(listvar)); + newvar->var=v; + newvar->suiv = NULL; + if (!lin) + { + newvar->suiv=NULL; + lin = newvar; + } + else + { + tmpvar = lin ; + while (tmpvar->suiv) + { + tmpvar = tmpvar ->suiv ; + } + tmpvar -> suiv = newvar; + } + return lin; +} + +/******************************************************************************/ +/* SETTYPE */ +/******************************************************************************/ +/* This subroutine is used to give the same variable type at each */ +/* record of the list of the struct : listvar */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + REAL + + REAL + + REAL + + REAL + + REAL + */ +/* + lin +--->+ lin +--->+ lin +--->+ lin +--->+ lin + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* */ +/******************************************************************************/ +listvar *settype(const char *nom, listvar *lin) +{ + listvar *newvar; + variable *v; + + newvar = lin; + while (newvar) + { + v = newvar->var; + strcpy(v->v_typevar,nom); + v->v_catvar = get_cat_var(v); + newvar = newvar->suiv; + } + newvar = lin; + return newvar ; +} + +/******************************************************************/ +/* printliste */ +/* print the list given in argulent */ +/******************************************************************/ + +void printliste(listvar * lin) +{ + listvar *newvar; + variable *v; + + newvar=lin; + while (newvar) + { + v=newvar->var; + printf("nom = %s, allocatable = %d dim = %s\n",v->v_nomvar,v->v_allocatable,(v->v_dimension)->dim.last); + newvar=newvar->suiv; + } +} + +/******************************************************************************/ +/* IsinListe : return 1 if name nom is in list lin */ +/* */ +/******************************************************************************/ + int IsinListe(listvar *lin,char *nom) +{ + listvar *newvar; + variable *v; + int out ; + + newvar=lin; + out = 0; + while (newvar && (out == 0)) + { + v=newvar->var; + if (!strcasecmp(v->v_nomvar,nom) && !strcasecmp(v->v_subroutinename,subroutinename)) { + out = 1; + } + newvar=newvar->suiv; + } + + return out ; +} + +listname *Insertname(listname *lin,char *nom, int sens) +{ + listname *newvar ; + listname *tmpvar; + + newvar=(listname *) calloc(1,sizeof(listname)); + strcpy(newvar->n_name,nom); + newvar->suiv = NULL; + if (!lin) + { + newvar->suiv=NULL; + lin = newvar; + } + else + { + if (sens == 0) + { + tmpvar = lin ; + while (tmpvar->suiv) + { + tmpvar = tmpvar ->suiv ; + } + tmpvar -> suiv = newvar; + } + else + { + newvar->suiv = lin; + lin = newvar; + } + } + return lin; +} + +listname *concat_listname(listname *l1, listname *l2) +{ + listname *tmpvar; + + tmpvar = l1; + while (tmpvar->suiv) + { + tmpvar = tmpvar->suiv; + } + + tmpvar->suiv = l2; + + return l1; +} + +void createstringfromlistname(char *ligne, listname *lin) +{ + listname *tmpvar; + + strcpy(ligne,""); + tmpvar = lin; + + while(tmpvar) + { + strcat(ligne,tmpvar->n_name); + if (tmpvar->suiv) strcat(ligne,","); + tmpvar=tmpvar->suiv; + } +} + +/******************************************************************/ +/* printname */ +/* print the list given in argulent */ +/******************************************************************/ + +void printname(listname * lin) +{ + listname *newvar; + + newvar=lin; + while (newvar) + { + printf("nom = %s \n",newvar->n_name); + newvar=newvar->suiv; + } +} + +void removeglobfromlist(listname **lin) +{ + listname *parcours1; + listvar *parcours2; + listname * parcourspres; + int out; + + parcours1 = *lin; + parcourspres = (listname *)NULL; + + while (parcours1) + { + parcours2 = List_Global_Var; + out = 0; + while (parcours2 && out == 0) + { + if (!strcasecmp(parcours2->var->v_nomvar,parcours1->n_name)) + { + out = 1; + } + parcours2 = parcours2->suiv; + } + if (out == 1) + { + if (parcours1 == *lin) + { + *lin = (*lin)->suiv; + parcours1 = *lin; + } + else + { + parcourspres->suiv = parcours1->suiv; + parcours1 = parcourspres->suiv; + } + } + else + { + parcourspres = parcours1; + parcours1 = parcours1->suiv; + } + } +} + +void writelistpublic(listname *lin) +{ + listname *parcours1; + char ligne[LONG_M]; + + if (lin) + { + sprintf(ligne,"public :: "); + parcours1 = lin; + + while ( parcours1 ) + { + strcat(ligne, parcours1->n_name); + if ( parcours1->suiv ) strcat(ligne,", "); + parcours1 = parcours1->suiv; + } + tofich(fortran_out,ligne,1); + } +} + +void Init_List_Data_Var() +{ + listvar *parcours; + + parcours = List_Data_Var_Cur; + + if (List_Data_Var_Cur) + { + while (parcours) + { + List_Data_Var_Cur = List_Data_Var_Cur->suiv; + free(parcours); + parcours = List_Data_Var_Cur; + } + } + List_Data_Var_Cur = NULL; +} + +int get_cat_var(variable *var) +{ + if (!strcasecmp(var->v_typevar, "CHARACTER")) + return 1; + else if ((var->v_nbdim == 0 ) && (!strcasecmp(var->v_typevar, "REAL"))) + return 2; + else if (!strcasecmp(var->v_typevar, "LOGICAL")) + return 3; + else if (!strcasecmp(var->v_typevar, "INTEGER")) + return 4; + else + return 0; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/UtilNotGridDep.c b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilNotGridDep.c new file mode 100644 index 0000000000000000000000000000000000000000..b836dd872d6ace9d96a182939fa765be2427cc43 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/UtilNotGridDep.c @@ -0,0 +1,107 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_NotGridDepend_Var_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record into List_NotGridDepend_Var */ +/* This variable is add only if it is not present in the list */ +/* This variable is add at the end of the list */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + not + + not + + not + + not + + + */ +/* + grid +--->+ grid +--->+ grid +--->+ grid +--->+ NEW + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +void Add_NotGridDepend_Var_1 (char *name) +{ + listvar *parcours; + listvar *newvar; + /* */ + /* look in the List_NotGridDepend_Var if this variable exist */ + parcours = List_NotGridDepend_Var; + while (parcours) + { + if (!strcasecmp(parcours->var->v_nomvar,name)) + { + /* if this variable exist -> exit of the program */ + printf(" The variable %s\n",name); + printf(" has been declared twice \n"); + printf(" as a non grid dependent variable \n"); + exit(1); + } + parcours= parcours->suiv; + } + /* if variable does not exist, we add it */ + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + strcpy(newvar->var->v_nomvar,name); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_subroutinename,subroutinename); + newvar->var->v_notgrid = 1 ; + newvar->suiv = List_NotGridDepend_Var; + List_NotGridDepend_Var = newvar; +} + +/******************************************************************************/ +/* VarIsNonGridDepend */ +/******************************************************************************/ +/* This subroutine is used to know if a variable has been declared as non */ +/* grid dependent */ +/******************************************************************************/ +/* */ +/* notgriddepend variable; -----------> VarIsNonGridDepend = 1 */ +/* */ +/* */ +/******************************************************************************/ +int VarIsNonGridDepend(char *name) +{ + listvar *newvar; + int out; + + newvar = List_NotGridDepend_Var; + out=0; + while (newvar && out == 0 ) + { + if ( !strcasecmp(newvar->var->v_nomvar,name) ) out = 1; + else newvar = newvar->suiv; + } + return out; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithAllocatelist.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithAllocatelist.c new file mode 100644 index 0000000000000000000000000000000000000000..3830e3f7cf972c2e3df2104a0086d28c40ed7fa6 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithAllocatelist.c @@ -0,0 +1,122 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_Allocate_Var_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Allocate_Var_1(const char *nom, const char *nommodule) +{ + listallocate *newvar; + listallocate *parcours; + int out; + + if ( firstpass == 1 ) + { + if ( !List_Allocate_Var ) + { + newvar = (listallocate *)calloc(1,sizeof(listallocate)); + strcpy(newvar->a_nomvar,nom); + strcpy(newvar->a_subroutine,subroutinename); + strcpy(newvar->a_module,nommodule); + Save_Length(nom,25); + newvar->suiv = NULL; + List_Allocate_Var = newvar; + } + else + { + parcours = List_Allocate_Var; + out = 0 ; + while ( parcours->suiv && out == 0 ) + { + if ( !strcasecmp(parcours->a_nomvar, nom) && + !strcasecmp(parcours->a_subroutine, subroutinename) && + !strcasecmp(parcours->a_module, nommodule) ) out = 1; + else + parcours=parcours->suiv; + } + if ( out == 0 ) + { + if ( !strcasecmp(parcours->a_nomvar,nom) && + !strcasecmp(parcours->a_subroutine,subroutinename) && + !strcasecmp(parcours->a_module,nommodule) ) out = 1; + else + { + /* add the record */ + newvar = (listallocate *)calloc(1,sizeof(listallocate)); + strcpy(newvar->a_nomvar, nom); + strcpy(newvar->a_subroutine, subroutinename); + strcpy(newvar->a_module, nommodule); + Save_Length(nom,25); + newvar->suiv = NULL; + parcours->suiv = newvar; + } + } + } + } +} + + +/******************************************************************************/ +/* IsVarAllocatable_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +// int IsVarAllocatable_0(const char *ident) +// { +// listallocate *parcours; +// int out; +// +// out = 0 ; +// if ( firstpass == 0 ) +// { +// parcours = List_Allocate_Var; +// while ( parcours && out == 0 ) +// { +// if ( !strcasecmp(parcours->a_nomvar,ident) ) out = 1 ; +// else parcours=parcours->suiv; +// } +// } +// return out; +// } diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithParameterlist.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithParameterlist.c new file mode 100644 index 0000000000000000000000000000000000000000..4753bee0c1f46e75a5f431ecd50ee3a8b3c56cf8 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithParameterlist.c @@ -0,0 +1,101 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_GlobalParameter_Var_1 */ +/******************************************************************************/ +/* This subroutines is used to add the variable defined in common in the */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_GlobalParameter_Var_1(listvar *listin) +{ + if ( VariableIsParameter ) + List_GlobalParameter_Var = AddListvarToListvar(listin, List_GlobalParameter_Var, 1); +} + +/******************************************************************************/ +/* Add_Parameter_Var_1 */ +/******************************************************************************/ +/* This subroutines is used to add the variable defined in common in the */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Parameter_Var_1(listvar *listin) +{ + listvar *parcours; + + if ( !VariableIsParameter ) return; + + if ( List_Parameter_Var == NULL ) + { + List_Parameter_Var = listin; + } + else + { + parcours = List_Parameter_Var; + while ( parcours->suiv ) + parcours = parcours->suiv; + parcours->suiv = listin; + } +} + +/******************************************************************************/ +/* Add_Dimension_Var_1 */ +/******************************************************************************/ +/* This subroutines is used to add the variable defined in common in the */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_Dimension_Var_1(listvar *listin) +{ + listvar *parcours; + + if ( List_Dimension_Var == NULL ) + { + List_Dimension_Var = listin; + } + else + { + parcours = List_Dimension_Var; + while (parcours->suiv) + parcours = parcours->suiv; + parcours->suiv = listin; + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithglobliste.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithglobliste.c new file mode 100644 index 0000000000000000000000000000000000000000..2337879c22e57f4633c4e174b7c67eb399064f5a --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithglobliste.c @@ -0,0 +1,107 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_Globliste_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/* We should add this declaration to the List_Global_Var */ +/******************************************************************************/ +void Add_Globliste_1(listvar *listtoadd) +{ + if ( aftercontainsdeclare == 0 && VariableIsParameter == 0 ) + { + List_Global_Var = AddListvarToListvar(listtoadd, List_Global_Var, 1); + } +} + +/******************************************************************************/ +/* Add_SubroutineDeclarationSave_Var_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/* We should add this declaration to the List_Global_Var. case SAVE */ +/******************************************************************************/ +void Add_SubroutineDeclarationSave_Var_1(listvar *listtoadd) +{ + if ( firstpass == 1 ) + { + if ( VariableIsParameter == 0 && + SaveDeclare == 1 ) + { + List_Global_Var = AddListvarToListvar(listtoadd,List_Global_Var,1); + } + } +} + +void checkandchangedims(listvar *listsecondpass) +{ +listvar *parcours; +listvar *parcours1; +variable * newvar; +variable * oldvar; + +int out ; + +printliste(List_Global_Var); +printliste(List_SubroutineDeclaration_Var); + +parcours = listsecondpass; +while (parcours) +{ +newvar = parcours->var; +parcours1 = List_SubroutineDeclaration_Var; +out = 0; +while (parcours1 && out == 0) +{ + oldvar = parcours1->var; + if (!strcasecmp(newvar->v_nomvar,oldvar->v_nomvar) && !strcasecmp(newvar->v_subroutinename,subroutinename)) + { + if (newvar->v_dimensiongiven == 1) + { + strcpy(oldvar->v_dimension->dim.last,newvar->v_dimension->dim.last); + strcpy(oldvar->v_dimension->dim.first,newvar->v_dimension->dim.first); + } + out = 1; + } + parcours1 = parcours1->suiv; +} +parcours = parcours->suiv; +} +printliste(List_SubroutineDeclaration_Var); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistdatavariable.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistdatavariable.c new file mode 100644 index 0000000000000000000000000000000000000000..7ac7c9aa6b5988c33359e4d8ef4c030865bbd674 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistdatavariable.c @@ -0,0 +1,145 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" +/******************************************************************************/ +/* Add_Data_Var_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to List_Data_Var */ +/******************************************************************************/ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ data +--->+ data +--->+ data +--->+ data+ */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/******************************************************************************/ +void Add_Data_Var_1 (listvar **curlist,char *name,char *values) +{ + listvar *newvar; + char ligne[LONG_M]; + +// if ( firstpass == 1 ) +// { + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + if ( inmoduledeclare == 1 ) newvar->var->v_module=1; + strcpy(newvar->var->v_nomvar,name); + strcpy(newvar->var->v_subroutinename,subroutinename); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_commoninfile,cur_filename); + if (strchr(values,',') && strncasecmp(values,"'",1)) + sprintf(ligne,"(/%s/)",values); + else + strcpy(ligne,values); + + strcpy(newvar->var->v_initialvalue,ligne); + Save_Length(ligne,14); + newvar->suiv = NULL; + if ( ! (*curlist) ) + { + *curlist = newvar ; + } + else + { + newvar->suiv = *curlist; + *curlist = newvar; + } +// } +} + +void Add_Data_Var_Names_01 (listvar **curlist,listname *l1,listname *l2) +{ + listvar *newvar; + listvar *tmpvar; + listname *tmpvar1; + listname *tmpvar2; + variable *found_var = NULL; + + tmpvar1 = l1; + tmpvar2 = l2; + + while (tmpvar1) + { + newvar = (listvar *) calloc(1,sizeof(listvar)); + newvar->var = (variable *) calloc(1,sizeof(variable)); + + Init_Variable(newvar->var); + + if ( inmoduledeclare == 1 ) newvar->var->v_module=1; + + found_var = get_variable_in_list_from_name(List_Common_Var, tmpvar1->n_name); + if ( ! found_var ) found_var = get_variable_in_list_from_name(List_Global_Var,tmpvar1->n_name); + if ( ! found_var ) found_var = get_variable_in_list_from_name(List_SubroutineDeclaration_Var,tmpvar1->n_name); + + if ( found_var && found_var->v_nbdim > 0 ) + { + printf("##############################################################################################################\n"); + printf("## CONV Error : arrays in data_stmt_object lists not yet supported. Please complain to the proper authorities.\n"); + printf("## variable name : %s (in %s:%s:%s)\n", found_var->v_nomvar, found_var->v_modulename, + found_var->v_subroutinename, found_var->v_commonname); + exit(1); + } + + strcpy(newvar->var->v_nomvar,tmpvar1->n_name); + strcpy(newvar->var->v_subroutinename,subroutinename); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_initialvalue,tmpvar2->n_name); + + Save_Length(tmpvar2->n_name,14); + + newvar->suiv = NULL; + + if ( *curlist != NULL ) + { + tmpvar = *curlist; + while (tmpvar->suiv) + tmpvar = tmpvar->suiv; + tmpvar->suiv = newvar; + } + else + { + *curlist = newvar ; + } + + tmpvar1 = tmpvar1->suiv; + tmpvar2 = tmpvar2->suiv; + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistmoduleinfile.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistmoduleinfile.c new file mode 100644 index 0000000000000000000000000000000000000000..e32038acb987061759bf8fdbfee1b4e4e40b780a --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistmoduleinfile.c @@ -0,0 +1,160 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +void Save_Length(const char *nom, int whichone) +{ + size_t len_nom = strlen(nom); + + if ( whichone == 1 && len_nom > length_last ) + { + length_last = len_nom; + if ( length_last > LONG_M ) + printf("WARNING 1 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_last+100); + } + if ( whichone == 2 && len_nom > length_first ) + { + length_first = len_nom; + if ( length_first > LONG_M ) + printf("WARNING 2 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_first+100); + } + if ( whichone == 8 && len_nom > length_v_vallengspec ) + { + length_v_vallengspec = len_nom; + if ( length_v_vallengspec > LONG_M ) + printf("WARNING 8 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_v_vallengspec+100); + } + if ( whichone == 12 && len_nom > length_v_precision ) + { + length_v_precision = len_nom; + if ( length_v_precision > LONG_M ) + printf("WARNING 12 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_v_precision+100); + } + if ( whichone == 13 && len_nom > length_v_IntentSpec ) + { + length_v_IntentSpec = len_nom; + if ( length_v_IntentSpec > LONG_M ) + printf("WARNING 13 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_v_IntentSpec+100); + } + if ( whichone == 14 && len_nom > length_v_initialvalue ) + { + length_v_initialvalue = len_nom; + if ( length_v_initialvalue > LONG_M ) + printf("WARNING 14 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_v_initialvalue+100); + } + if ( whichone == 15 && len_nom > length_v_readedlistdimension ) + { + length_v_readedlistdimension = len_nom; + if ( length_v_readedlistdimension > LONG_M ) + printf("WARNING 15 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_v_readedlistdimension+100); + } + if ( whichone == 25 && len_nom > length_a_nomvar ) + { + length_a_nomvar = len_nom; + if ( length_a_nomvar > LONG_C ) + printf("WARNING 25 : The value of LONG_C (defined in decl.h) should be upgrated to %lu\n", length_a_nomvar+100); + } + if ( whichone == 39 && len_nom > length_toprintglob ) + { + length_toprintglob = len_nom; + if ( length_toprintglob > LONG_M ) + printf("WARNING 39 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_toprintglob+100); + } + if ( whichone == 40 && len_nom > length_tmpvargridname ) + { + length_tmpvargridname = len_nom; + if ( length_tmpvargridname > LONG_M ) + printf("WARNING 40 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_tmpvargridname+100); + } + if ( whichone == 41 && len_nom > length_ligne_Subloop ) + { + length_ligne_Subloop = len_nom; + if ( length_ligne_Subloop > LONG_M ) + printf("WARNING 41 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n",length_ligne_Subloop+100); + } + if ( whichone == 43 && len_nom > length_toprint_utilagrif ) + { + length_toprint_utilagrif = len_nom; + if ( length_toprint_utilagrif > LONG_M ) + printf("WARNING 43 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_toprint_utilagrif+100); + } + if ( whichone == 44 && len_nom > length_toprinttmp_utilchar ) + { + length_toprinttmp_utilchar = len_nom; + if ( length_toprinttmp_utilchar > LONG_M) + printf("WARNING 44 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_toprinttmp_utilchar+100); + } + if ( whichone == 45 && len_nom > length_ligne_writedecl ) + { + length_ligne_writedecl = len_nom; + if ( length_ligne_writedecl > LONG_M ) + printf("WARNING 45 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_ligne_writedecl+100); + } + if ( whichone == 46 && len_nom > length_newname_toamr ) + { + length_newname_toamr = len_nom; + if ( length_newname_toamr > LONG_C ) + printf("WARNING 46 : The value of LONG_C (defined in decl.h) should be upgrated to %lu\n", length_newname_toamr+100); + } + if ( whichone == 47 && len_nom > length_newname_writedecl ) + { + length_newname_writedecl = len_nom; + if ( length_newname_writedecl > LONG_M ) + printf("WARNING 47 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_newname_writedecl +100); + } + if ( whichone == 48 && len_nom > length_ligne_toamr ) + { + length_ligne_toamr = len_nom; + if ( length_ligne_toamr > LONG_M ) + printf("WARNING 48 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_ligne_toamr +100); + } + if ( whichone == 49 && len_nom > length_tmpligne_writedecl ) + { + length_tmpligne_writedecl = len_nom; + if ( length_tmpligne_writedecl > LONG_M ) + printf("WARNING 49 : The value of LONG_M (defined in decl.h) should be upgrated to %lu\n", length_tmpligne_writedecl+100); + } +} + +void Save_Length_int(int val, int whichone) +{ + if ( whichone == 1 && val > value_char_size ) value_char_size = val; + if ( whichone == 2 && val > value_char_size1 ) value_char_size1 = val; + if ( whichone == 3 && val > value_char_size2 ) value_char_size2 = val; + if ( whichone == 4 && val > value_char_size3 ) value_char_size3 = val; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofcoupled.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofcoupled.c new file mode 100644 index 0000000000000000000000000000000000000000..aaf6f5e08167616b5b84f3aa2272d5191961f3b7 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofcoupled.c @@ -0,0 +1,105 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include + +#include "decl.h" + +/******************************************************************************/ +/* variscoupled_0 */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int variscoupled_0(const char *ident) +{ + listvarpointtovar *pointtmplist; + listcouple *coupletmp; + int out = 0; + + if (firstpass == 0 ) + { + pointtmplist = List_CouplePointed_Var; + while ( pointtmplist && out == 0) + { + coupletmp = pointtmplist->t_couple; + while ( coupletmp && out == 0) + { + /* we should find the same variable name in the same subroutine */ + if ( !strcasecmp(ident, coupletmp->c_namevar) && + !strcasecmp(subroutinename, pointtmplist->t_cursubroutine) && + strcasecmp(coupletmp->c_namepointedvar, "") ) + { + out = 1; + } + coupletmp = coupletmp->suiv; + } + pointtmplist = pointtmplist->suiv; + } + } + return out; +} + +const char * getcoupledname_0(const char *ident) +{ + listvarpointtovar *pointtmplist; + listcouple *coupletmp; + int out = 0; + + if (firstpass == 0 ) + { + pointtmplist = List_CouplePointed_Var; + while ( pointtmplist && out == 0) + { + coupletmp = pointtmplist->t_couple; + while ( coupletmp && out == 0) + { + /* we should find the same variable name in the same subroutine */ + if ( !strcasecmp(coupletmp->c_namevar,ident) && + !strcasecmp(pointtmplist->t_cursubroutine,subroutinename) && + strcasecmp(coupletmp->c_namepointedvar,"") ) + { + return coupletmp->c_namepointedvar; + } + coupletmp = coupletmp->suiv; + } + pointtmplist = pointtmplist->suiv; + } + } + printf("end of getcoupledname_0 -- you should not be there !!! \n"); + return NULL; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofmodulebysubroutine.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofmodulebysubroutine.c new file mode 100644 index 0000000000000000000000000000000000000000..89b17d1b12883bda0558fe642f2ee64bbf8d8f7a --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistofmodulebysubroutine.c @@ -0,0 +1,303 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include + +#include "decl.h" + + + +/******************************************************************************/ +/* RecordUseModulesVariables */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void RecordUseModulesVariables() +{ + listusemodule *tmplistmodule; + + /* we should record all variables defined in modules used in this file */ + if ( List_NameOfModuleUsed ) + { + tmplistmodule = List_NameOfModuleUsed; + while ( tmplistmodule ) + { + if ( tmplistmodule->u_firstuse == 1 ) + { + /* check if the file .depend exist */ + List_ModuleUsed_Var = Readthedependfile + (tmplistmodule->u_usemodule,List_ModuleUsed_Var); + List_GlobParamModuleUsed_Var = ReaddependParameterList + (tmplistmodule->u_usemodule,List_GlobParamModuleUsed_Var); + + } + + tmplistmodule = tmplistmodule->suiv; + } + } +} + +/******************************************************************************/ +/* RecordUseModulesUseModulesVariables */ +/******************************************************************************/ +/******************************************************************************/ +void RecordUseModulesUseModulesVariables() +{ + listusemodule *tmplistmodule; + listusemodule *save_list; + + if ( ! List_NameOfModuleUsed ) return; + + /* we should record all variables defined in modules used in this file */ + /* and we should read the .depend of the module used by the module used */ + tmplistmodule = List_NameOfModuleUsed; + while ( tmplistmodule ) + { + Readthedependlistofmoduleused(tmplistmodule->u_usemodule); + while( tmpuselocallist ) + { + Addmoduletothelisttmp(tmpuselocallist->u_usemodule); + save_list = tmpuselocallist->suiv; + free(tmpuselocallist); + tmpuselocallist = save_list; + } + tmplistmodule = tmplistmodule->suiv; + } + tmplistmodule = listofmoduletmp; + while ( tmplistmodule ) + { + Readthedependlistofmoduleused(tmplistmodule->u_usemodule); + while( tmpuselocallist ) + { + Addmoduletothelisttmp(tmpuselocallist->u_usemodule); + save_list = tmpuselocallist->suiv; + free(tmpuselocallist); + tmpuselocallist = save_list; + } + tmplistmodule = tmplistmodule->suiv; + } + tmplistmodule = listofmoduletmp; + while ( tmplistmodule ) + { + // check if the file .depend exists + List_ModuleUsedInModuleUsed_Var = + Readthedependfile(tmplistmodule->u_usemodule,List_ModuleUsedInModuleUsed_Var); + + List_GlobParamModuleUsedInModuleUsed_Var = + ReaddependParameterList(tmplistmodule->u_usemodule,List_GlobParamModuleUsedInModuleUsed_Var); + tmplistmodule = tmplistmodule->suiv; + } +} + +/******************************************************************************/ +/* Add_NameOfModuleUsed_1 */ +/******************************************************************************/ +/* This subroutine is used to add a record to a list of struct */ +/* listusemodule */ +/******************************************************************************/ +/* */ +/* subroutine sub ... USE mod1 ===> insert in list */ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ list +--->+ list +--->+ list +--->+ list + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* list = List_NameOfModuleUsed */ +/* */ +/******************************************************************************/ +void Add_NameOfModuleUsed_1(char *name) +{ + listusemodule *newmodule; + listusemodule *parcours; + int out; + + newmodule = (listusemodule*) calloc(1, sizeof(listusemodule)); + strcpy(newmodule->u_usemodule, name); + strcpy(newmodule->u_charusemodule, charusemodule); + strcpy(newmodule->u_modulename, curmodulename); + strcpy(newmodule->u_cursubroutine, subroutinename); + newmodule->u_firstuse = 1 ; + newmodule->suiv = NULL; + + if ( List_NameOfModuleUsed == NULL ) + { + List_NameOfModuleUsed = newmodule ; + } + else + { + parcours = List_NameOfModuleUsed; + while ( parcours && newmodule->u_firstuse ) + { + if ( !strcasecmp(name,parcours->u_usemodule) ) + { + newmodule->u_firstuse = 0 ; + } + parcours = parcours->suiv; + } + /* we can not add the same module twice for the same subroutine */ + parcours = List_NameOfModuleUsed; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(name,parcours->u_usemodule) && + !strcasecmp(subroutinename,parcours->u_cursubroutine) ) + { + out = 1 ; + free(newmodule); + } + else + parcours = parcours->suiv; + } + if ( out == 0 ) + { + newmodule->suiv = List_NameOfModuleUsed; + List_NameOfModuleUsed = newmodule; + } + } +} + +/******************************************************************************/ +/* Addmoduletothelist */ +/******************************************************************************/ +/* This subroutine is used to add a record to a list of struct */ +/* listusemodule */ +/******************************************************************************/ +/* */ +/* subroutine sub ... USE mod1 ===> insert in list */ +/* _______ _______ _______ _______ _______ */ +/* + + + + + + + + + + */ +/* + NEW +--->+ list +--->+ list +--->+ list +--->+ list + */ +/* +______+ +______+ +______+ +______+ +______+ */ +/* */ +/* list = List_NameOfModuleUsed */ +/* */ +/******************************************************************************/ +void Addmoduletothelist(const char *name) +{ + listusemodule *newmodule; + listusemodule *parcours; + int out; + + newmodule = (listusemodule*) calloc(1,sizeof(listusemodule)); + strcpy(newmodule->u_usemodule, name); + strcpy(newmodule->u_charusemodule, charusemodule); + strcpy(newmodule->u_cursubroutine, subroutinename); + newmodule->u_firstuse = 1 ; + newmodule->suiv = NULL; + + if ( !List_NameOfModuleUsed ) + { + List_NameOfModuleUsed = newmodule ; + } + else + { + parcours = List_NameOfModuleUsed; + while ( parcours && newmodule->u_firstuse == 1 ) + { + if ( !strcasecmp(name,parcours->u_usemodule) ) + { + newmodule->u_firstuse = 0 ; + } + parcours=parcours->suiv; + } + /* we can not add the same module twice for the same subroutine */ + parcours = List_NameOfModuleUsed; + out = 0 ; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(name,parcours->u_usemodule) && + !strcasecmp(subroutinename,parcours->u_cursubroutine) ) + { + out = 1 ; + free(newmodule); + } + else + parcours=parcours->suiv; + } + if ( out == 0 ) + { + newmodule->suiv = List_NameOfModuleUsed; + List_NameOfModuleUsed = newmodule; + } + } +} + + +/******************************************************************************/ +/* WriteUsemoduleDeclaration */ +/******************************************************************************/ +/* Firstpass 0 */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void WriteUsemoduleDeclaration(const char *cursubroutinename) +{ + listusemodule *newmodule; + listvarpointtovar *pointtmp; + long int fictifpos; + int findcoupled; + + fprintf(fortran_out,"\n"); + newmodule = List_NameOfModuleUsed; + + while ( newmodule ) + { + if ( !strcasecmp(newmodule->u_cursubroutine, cursubroutinename) ) + { + if (strcmp(newmodule->u_charusemodule,"")) + { +/* + findcoupled = 0; + pointtmp = List_CouplePointed_Var; + while(pointtmp) + { + if ((!strcasecmp(pointtmp->t_usemodule, newmodule->u_charusemodule)) && \ + (!strcasecmp(pointtmp->t_cursubroutine, cursubroutinename))) + { + fictifpos = setposcur(); + variableisglobalinmodule(pointtmp->t_couple,newmodule->u_charusemodule,fortran_out,fictifpos); + findcoupled = 1; + } + pointtmp=pointtmp->suiv; + } + if (findcoupled == 0) fprintf(fortran_out," use %s\n",newmodule->u_charusemodule); +*/ + fprintf(fortran_out," use %s\n", newmodule->u_charusemodule); + } + } + newmodule = newmodule ->suiv; + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistvarindoloop.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistvarindoloop.c new file mode 100644 index 0000000000000000000000000000000000000000..0472a90460e7404d75298b251fc9b4336694f318 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithlistvarindoloop.c @@ -0,0 +1,1870 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +//#include +//#include + +#include "decl.h" + +/******************************************************************************/ +/* Add_UsedInSubroutine_Var_1 */ +/******************************************************************************/ +/* Firstpass 1 */ +/* We should complete the List_UsedInSubroutine_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Add_UsedInSubroutine_Var_1 (const char *ident) +{ + listvar *newvar; + listvar *tmpvar; + int out; + + /* In the first pass we record all variables presents in the do loop */ + if (firstpass == 1 && insubroutinedeclare == 1 ) + { + + if ( !List_UsedInSubroutine_Var ) + { + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + newvar->suiv = NULL; + strcpy(newvar->var->v_nomvar,ident); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_subroutinename,subroutinename); + newvar->var->v_pointedvar=pointedvar; + List_UsedInSubroutine_Var = newvar ; + } + else + { + /* We should verify that this variable did not added */ + tmpvar = List_UsedInSubroutine_Var; + out = 0 ; + while (tmpvar && out == 0 ) + { + if ( !strcasecmp(tmpvar->var->v_nomvar,ident) && + !strcasecmp(tmpvar->var->v_subroutinename,subroutinename)) + out = 1 ; + else tmpvar = tmpvar->suiv; + } + if ( out == 0 ) + { + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + strcpy(newvar->var->v_nomvar,ident); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_subroutinename,subroutinename); + newvar->var->v_pointedvar=pointedvar; + newvar->suiv = List_UsedInSubroutine_Var; + List_UsedInSubroutine_Var = newvar; + } + } + + } +} + +/******************************************************************************/ +/* AJOUTEVARINDOLOOP_DEFINEDIMENSION */ +/******************************************************************************/ +/* This subroutine is used to add a listvar to List_UsedInSubroutine_Var */ +/******************************************************************************/ +void ajoutevarindoloop_definedimension (char *name) +{ + listvar *newvar; + listvar *tmpvar; + listvar *tmpvarprec; + int out; + int tablemeet; + + if ( !List_UsedInSubroutine_Var ) + { + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + newvar->suiv = NULL; + strcpy(newvar->var->v_nomvar,name); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_subroutinename,subroutinename); + newvar->var->v_pointedvar=pointedvar; + List_UsedInSubroutine_Var = newvar ; + } + else + { + /* We should verify that this variable did not added */ + tmpvarprec = (listvar *)NULL; + tmpvar = List_UsedInSubroutine_Var; + out = 0 ; + tablemeet = 0 ; + while (tmpvar && out == 0 ) + { + if ( tablemeet == 0 && tmpvar->var->v_nbdim != 0 ) tablemeet = 1 ; + /* */ + if ( !strcasecmp(tmpvar->var->v_nomvar,name) && + !strcasecmp(tmpvar->var->v_subroutinename,subroutinename)) + { + out = 1 ; + /* if this variable has been define before a table we do nothing */ + /* else we should remove it */ + if ( tablemeet == 1 ) + { + tmpvarprec->suiv = tmpvar -> suiv; + out = 2; + } + } + else + { + tmpvarprec = tmpvar; + tmpvar = tmpvar->suiv; + } + } + if ( out == 2 || out == 0 ) + { + newvar=(listvar *)calloc(1,sizeof(listvar)); + newvar->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + strcpy(newvar->var->v_nomvar,name); + strcpy(newvar->var->v_modulename,curmodulename); + strcpy(newvar->var->v_commoninfile,cur_filename); + strcpy(newvar->var->v_subroutinename,subroutinename); + newvar->var->v_pointedvar=pointedvar; + + /* we should find this new variable to know the tabvars indice */ + if ( variableisglobal(newvar, List_Global_Var) == 1 ) + { + newvar->suiv = List_UsedInSubroutine_Var; + List_UsedInSubroutine_Var = newvar; + } + else if ( variableisglobal(newvar, List_ModuleUsed_Var) == 1 ) + { + newvar->suiv = List_UsedInSubroutine_Var; + List_UsedInSubroutine_Var = newvar; + } + else if ( variableisglobal(newvar, List_Common_Var) == 1 ) + { + newvar->suiv = List_UsedInSubroutine_Var; + List_UsedInSubroutine_Var = newvar; + } + else + { + free(newvar); + } + } + } +} + +/******************************************************************************/ +/* ModifyThelistvarindoloop */ +/******************************************************************************/ +/* This subroutine is to give the old name to the which has been */ +/* declared as USE MOD, U => V in this case we should replace in the */ +/* name V by the old name U in the List_UsedInSubroutine_Var */ +/******************************************************************************/ +void ModifyThelistvarindoloop() +{ + listvar *newvar; + + newvar = List_UsedInSubroutine_Var; + while ( newvar ) + { + if ( strcasecmp(newvar->var->v_oldname,"") ) + { + strcpy(newvar->var->v_nomvar,newvar->var->v_oldname); + } + newvar = newvar->suiv; + } +} + +/******************************************************************************/ +/* CompleteThelistvarindoloop */ +/******************************************************************************/ +/* This subroutine is to add to the List_UsedInSubroutine_Var all variables */ +/* which has been declared as USE MOD, U => V in this case we should replace */ +/* in the List_UsedInSubroutine_Var the word U by the word V */ +/******************************************************************************/ +void CompleteThelistvarindoloop() +{ + listvar *newvar; + listvarpointtovar *pointtmplist; + listcouple *coupletmp; + int outvar; + + pointtmplist = List_CouplePointed_Var; + while ( pointtmplist ) + { + coupletmp = pointtmplist->t_couple; + while ( coupletmp ) + { + newvar = List_UsedInSubroutine_Var; + outvar = 0 ; + while ( newvar && outvar == 0) + { + /* we should find the same variable name in the same subroutine */ + if ( !strcasecmp(newvar->var->v_nomvar, coupletmp->c_namevar) && + !strcasecmp(newvar->var->v_subroutinename, pointtmplist->t_cursubroutine) && + strcasecmp(coupletmp->c_namepointedvar, "") ) + { + outvar = 1; + strcpy(newvar->var->v_oldname, newvar->var->v_nomvar); + strcpy(newvar->var->v_nomvar, coupletmp->c_namepointedvar); + } + else + { + newvar = newvar->suiv; + } + } + coupletmp = coupletmp->suiv; + } + pointtmplist = pointtmplist->suiv; + } +} + +/******************************************************************************/ +/* Merge_Variables */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Merge_Variables(variable *var1, variable *var2) +{ + if ( !strcasecmp(var1->v_typevar,"") ) + strcpy(var1->v_typevar,var2->v_typevar); + else + { + strcpy(var2->v_typevar,var1->v_typevar); + } + + if ( !strcasecmp(var1->v_oldname,"") ) + strcpy(var1->v_oldname,var2->v_oldname); + else strcpy(var2->v_oldname,var1->v_oldname); + + if ( !strcasecmp(var1->v_dimchar,"") ) + strcpy(var1->v_dimchar,var2->v_dimchar); + else strcpy(var2->v_dimchar,var1->v_dimchar); + + if ( !strcasecmp(var1->v_commonname,"") ) + strcpy(var1->v_commonname,var2->v_commonname); + else strcpy(var2->v_commonname,var1->v_commonname); + + if ( !strcasecmp(var1->v_modulename,"") || (var1->v_module ==0)) + strcpy(var1->v_modulename,var2->v_modulename); + else strcpy(var2->v_modulename,var1->v_modulename); + + if ( !strcasecmp(var1->v_vallengspec,"") ) + strcpy(var1->v_vallengspec,var2->v_vallengspec); + else strcpy(var2->v_vallengspec,var1->v_vallengspec); + + if ( !strcasecmp(var1->v_nameinttypename,"") ) + strcpy(var1->v_nameinttypename,var2->v_nameinttypename); + else strcpy(var2->v_nameinttypename,var1->v_nameinttypename); + + if ( !strcasecmp(var1->v_commoninfile,"") ) + strcpy(var1->v_commoninfile,var2->v_commoninfile); + else strcpy(var2->v_commoninfile,var1->v_commoninfile); + + if ( !strcasecmp(var1->v_precision,"") ) + strcpy(var1->v_precision,var2->v_precision); + else strcpy(var2->v_precision,var1->v_precision); + + if ( !strcasecmp(var1->v_initialvalue,"") ) + strcpy(var1->v_initialvalue,var2->v_initialvalue); + else strcpy(var2->v_initialvalue,var1->v_initialvalue); + + if ( !strcasecmp(var1->v_IntentSpec,"") ) + strcpy(var1->v_IntentSpec,var2->v_IntentSpec); + else strcpy(var2->v_IntentSpec,var1->v_IntentSpec); + + if ( !strcasecmp(var1->v_readedlistdimension,"") ) + strcpy(var1->v_readedlistdimension,var2->v_readedlistdimension); + else strcpy(var2->v_readedlistdimension,var1->v_readedlistdimension); + + if ( var1->v_dimension ) + var2->v_dimension = var1->v_dimension ; + else var1->v_dimension = var2->v_dimension ; + + if ( var1->v_nbdim == 0 ) + var1->v_nbdim = var2->v_nbdim ; + else var2->v_nbdim = var1->v_nbdim ; + + if ( var1->v_common == 0 ) + var1->v_common = var2->v_common ; + else var2->v_common = var1->v_common ; + + if ( var1->v_positioninblock == 0 ) + var1->v_positioninblock = var2->v_positioninblock ; + else var2->v_positioninblock = var1->v_positioninblock ; + + if ( var1->v_module == 0 ) + var1->v_module = var2->v_module ; + else var2->v_module = var1->v_module ; + + if ( var1->v_save == 0 ) + var1->v_save = var2->v_save ; + else var2->v_save = var1->v_save ; + + if ( var1->v_VariableIsParameter == 0 ) + var1->v_VariableIsParameter = var2->v_VariableIsParameter ; + else var2->v_VariableIsParameter = var1->v_VariableIsParameter ; + + if ( var1->v_indicetabvars == 0 ) + var1->v_indicetabvars = var2->v_indicetabvars ; + else var2->v_indicetabvars = var1->v_indicetabvars ; + + if ( var1->v_ExternalDeclare == 0 ) + var1->v_ExternalDeclare = var2->v_ExternalDeclare ; + else var2->v_ExternalDeclare = var1->v_ExternalDeclare ; + + if ( var1->v_pointedvar == 0 ) + var1->v_pointedvar = var2->v_pointedvar ; + else var2->v_pointedvar = var1->v_pointedvar ; + + if ( var1->v_dimensiongiven == 0 ) + var1->v_dimensiongiven = var2->v_dimensiongiven; + else var2->v_dimensiongiven = var1->v_dimensiongiven ; + + if ( var1->v_c_star == 0 ) + var1->v_c_star = var2->v_c_star; + else var2->v_c_star = var1->v_c_star ; + + if ( var1->v_catvar == 0 ) + var1->v_catvar = var2->v_catvar; + else var2->v_catvar = var1->v_catvar ; + + if ( var1->v_pointerdeclare == 0 ) + var1->v_pointerdeclare = var2->v_pointerdeclare ; + else var2->v_pointerdeclare = var1->v_pointerdeclare ; + + if ( var1->v_notgrid == 0 ) + var1->v_notgrid = var2->v_notgrid ; + else var2->v_notgrid = var1->v_notgrid; + + if ( var1->v_optionaldeclare == 0 ) + var1->v_optionaldeclare = var2->v_optionaldeclare; + else var2->v_optionaldeclare = var1->v_optionaldeclare ; + + if ( var1->v_allocatable == 0 ) + var1->v_allocatable = var2->v_allocatable ; + else var2->v_allocatable = var1->v_allocatable ; + + if ( var1->v_target == 0 ) + var1->v_target = var2->v_target ; + else var2->v_target = var1->v_target ; + + if ( var1->v_dimsempty == 0 ) + var1->v_dimsempty = var2->v_dimsempty ; + else var2->v_dimsempty = var1->v_dimsempty ; +} + + +/******************************************************************************/ +/* Update_List_Subroutine_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Update_List_Subroutine_Var(listvar *list_to_modify) +{ + listvar *parcours; + listvar *parcoursprec; + listvar *parcours1; + int out; + + parcoursprec = (listvar *)NULL; + parcours = list_to_modify; + while( parcours ) + { + /* looking in List_SubroutineDeclaration_Var */ + parcours1 = List_SubroutineDeclaration_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_modulename, parcours1->var->v_modulename) + ) out = 1; + else parcours1 = parcours1->suiv; + } + /* if variable has been found */ + + if ( out == 1 ) Merge_Variables(parcours->var,parcours1->var); + + /* looking in List_Dimension_Var */ + if (out == 0 ) + { + parcours1 = List_Dimension_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, + parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_modulename, + parcours1->var->v_modulename) + ) out = 1; + else + { + parcoursprec = parcours1; + parcours1 = parcours1->suiv; + } + } + /* if variable has been found */ + + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + /* we should remove this record from the List_Dimension_Var */ + if ( parcours1 == List_Dimension_Var ) + { + List_Dimension_Var = List_Dimension_Var -> suiv; + } + else + { + parcoursprec->suiv = parcours1 -> suiv; + } + } + } + /* */ + parcours = parcours->suiv; + } +} + +void Update_List_Global_Var_From_List_Save_Var() +{ + listvar *parcours; + listvar *newvar; + char tmpname[LONG_VNAME]; + + parcours = List_Save_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename,"") ) + /* Save in subroutine which is not defined in a module */ + { + newvar = (listvar *)calloc(1,sizeof(listvar)); + newvar->var = (variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + newvar->suiv = NULL; + Merge_Variables(parcours->var,newvar->var); + strcpy(newvar->var->v_subroutinename,parcours->var->v_subroutinename); + strcpy(newvar->var->v_nomvar,parcours->var->v_nomvar); + newvar->var->v_catvar=parcours->var->v_catvar; + sprintf(tmpname,"save_%s",parcours->var->v_subroutinename); + Add_NameOfCommon_1(tmpname,parcours->var->v_subroutinename); + strcpy(newvar->var->v_commonname,tmpname); + List_Common_Var = AddListvarToListvar(newvar,List_Common_Var,1); + } + else + /* Save in subroutine which is defined in a module */ + { + newvar = (listvar *)calloc(1,sizeof(listvar)); + newvar->var = (variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(newvar->var); + /* */ + newvar->suiv = NULL; + + Merge_Variables(parcours->var,newvar->var); + strcpy(newvar->var->v_subroutinename,parcours->var->v_subroutinename); + + strcpy(newvar->var->v_nomvar,parcours->var->v_nomvar); + + newvar->var->v_catvar=parcours->var->v_catvar; + strcpy(newvar->var->v_modulename,parcours->var->v_modulename); + List_Global_Var = AddListvarToListvar(newvar,List_Global_Var,1); + } + parcours = parcours->suiv; + } +} + +/******************************************************************************/ +/* Update_List_From_Common_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Update_List_From_Common_Var(listvar *list_to_modify) +{ + listvar *parcours; + listvar *parcours1; + int out; + parcours = list_to_modify; + while( parcours ) + { + /* looking in List_Global_Var */ + parcours1 = List_Common_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + + if ( !strcasecmp(parcours->var->v_nomvar, parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, parcours1->var->v_subroutinename) ) + { + out = 1; + } + else parcours1 = parcours1->suiv; + } + /* if variable has been found */ + if ( out == 1 ) + { + strcpy(parcours->var->v_commoninfile,parcours1->var->v_commoninfile); + + Merge_Variables(parcours->var,parcours1->var); + } + parcours = parcours->suiv; + } +} + +/******************************************************************************/ +/* Update_List_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Update_List_Var(listvar *list_to_modify) +{ + listvar *parcours; + listvar *parcours1; + int out; + + parcours = list_to_modify; + + while( parcours ) + { + /*printf("LE NOM EST %s\n",parcours->var->v_nomvar);*/ + /* looking in List_Global_Var */ + out = 0; + parcours1 = List_Global_Var; + + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_modulename, parcours1->var->v_modulename) ) + { + out = 1; + } + else parcours1 = parcours1->suiv; + } + + /* if variable has been found */ + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + } + /* looking in List_SubroutineDeclaration_Var */ + else + { + parcours1 = List_SubroutineDeclaration_Var ; + out = 0; + while ( parcours1 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_modulename, parcours1->var->v_modulename) ) + { + out = 1; + break; + } + else parcours1 = parcours1->suiv; + } + /* if variable has been found */ + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + } + else + { + parcours1 = List_Common_Var ; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_modulename, parcours1->var->v_modulename) ) + { + out = 1; + } + else parcours1 = parcours1->suiv; + } + /* if variable has been found */ + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + } + } + } + parcours = parcours->suiv; + } +} + + +void List_UsedInSubroutine_Var_Update_From_Module_Used() +{ + listvar *parcours; + listvar *parcours3; + listusemodule *parcours2; + int out; + + + parcours = List_UsedInSubroutine_Var; + while( parcours ) + { + out = 0 ; + if ( parcours->var->v_indicetabvars == 0 ) + { + parcours2 = List_NameOfModuleUsed; + while( parcours2 ) + { + if ( !strcasecmp(parcours2->u_cursubroutine, "") && + !strcasecmp(parcours2->u_modulename, parcours->var->v_modulename) ) + { + parcours3 = List_Global_Var; + out = 0 ; + while ( parcours3 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours3->var->v_nomvar) + ) out = 1 ; + else parcours3 = parcours3->suiv; + } + if ( out == 1 ) Merge_Variables(parcours->var,parcours3->var); + } + else if ( !strcasecmp(parcours2->u_cursubroutine, parcours->var->v_subroutinename) && + !strcasecmp(parcours2->u_modulename, parcours->var->v_modulename) ) + { + parcours3 = List_Global_Var; + out = 0 ; + while ( parcours3 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours3->var->v_nomvar) + ) out = 1 ; + else parcours3 = parcours3->suiv; + } + if ( out == 1 ) Merge_Variables(parcours->var,parcours3->var); + } + parcours2 = parcours2->suiv; + } + /* */ + if ( out == 0 ) + { + parcours3 = List_ModuleUsed_Var; + out = 0 ; + while ( parcours3 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours3->var->v_nomvar) + ) out = 1 ; + else parcours3 = parcours3->suiv; + } + if ( out == 1 ) Merge_Variables(parcours->var,parcours3->var); + } + /* */ + } + parcours = parcours->suiv; + } +} + + + +/******************************************************************************/ +/* Update_NotGridDepend_Var */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void Update_NotGridDepend_Var(listvar *list_to_modify) +{ + listvar *parcours; + listvar *parcours1; + int out; + + parcours = list_to_modify; + while( parcours ) + { + /* looking in List_Global_Var */ + parcours1 = List_Global_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours1->var->v_nomvar) + ) out = 1; + else parcours1 = parcours1->suiv; + } + /* if variable has been found */ + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + strcpy(parcours->var->v_subroutinename, + parcours1->var->v_subroutinename); + strcpy(parcours->var->v_modulename,parcours1->var->v_modulename); + } + parcours = parcours->suiv; + } +} + +int LookingForVariableInList(listvar *listin,variable *var) +{ + listvar *parcours1; + int out; + + parcours1 = listin; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(var->v_nomvar,parcours1->var->v_nomvar) && + !strcasecmp(var->v_subroutinename,parcours1->var->v_subroutinename)&& + !strcasecmp(var->v_modulename,parcours1->var->v_modulename) && + var->v_save == 0 && + var->v_common == 0 + ) out = 1 ; + else parcours1 = parcours1 -> suiv; + } + + return out; +} + +int LookingForVariableInListGlobal(listvar *listin,variable *var) +{ + listvar *parcours1; + int out; + + parcours1 = listin; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(var->v_nomvar,parcours1->var->v_nomvar) && + !strcasecmp(var->v_subroutinename,parcours1->var->v_subroutinename)&& + !strcasecmp(var->v_modulename,parcours1->var->v_modulename) + ) out = 1 ; + else parcours1 = parcours1 -> suiv; + } + + return out; +} + +int LookingForVariableInListName(listvar *listin,const char *name) +{ + listvar *parcours1; + int out; + + parcours1 = listin; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(name,parcours1->var->v_nomvar) && + ( !strcasecmp(subroutinename,parcours1->var->v_subroutinename) || + !strcasecmp(subroutinename,"") ) + ) out = 1 ; + else parcours1 = parcours1 -> suiv; + } + + return out; +} + +variable *get_variable_in_list_from_name( listvar *listin, const char *name ) +{ + listvar *parcours = listin; + variable *var = NULL; + + while ( parcours && (!var) ) + { + if ( !strcasecmp(name,parcours->var->v_nomvar) && + ( !strcasecmp(subroutinename,parcours->var->v_subroutinename) || + !strcasecmp(subroutinename,"") ) ) + { + var = parcours->var; + } + else parcours = parcours -> suiv; + } + return var; +} + +int LookingForVariableInListGlob(listvar *listin,variable *var) +{ + listvar *parcours1; + int out; + + parcours1 = listin; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(var->v_nomvar,parcours1->var->v_nomvar) && + !strcasecmp(var->v_modulename,parcours1->var->v_modulename) + ) out = 1 ; + else parcours1 = parcours1 -> suiv; + } + + return out; +} + +int LookingForVariableInListParamGlob(listparameter *listin,variable *var) +{ + listparameter *parcours1; + int out; + + parcours1 = listin; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(var->v_nomvar,parcours1->p_name) + ) out = 1 ; + else parcours1 = parcours1 -> suiv; + } + + return out; +} + +void UpdateListDeclarationWithDimensionList() +{ + List_SubroutineDeclaration_Var = AddListvarToListvar(List_Dimension_Var, List_SubroutineDeclaration_Var,1); +} + + +/* Remove from List_UsedInSubroutine_Var all variables comming from : */ +/* - List_SubroutineArgument_Var */ +/* - List_SubroutineDeclaration_Var */ +/* - List_Parameter_Var */ +/* - List_FunctionType_Var */ +/* - List_GlobalParameter_Var */ +/* - */ +/* - */ +void Clean_List_UsedInSubroutine_Var() +{ + listvar *parcours; + listvar *parcoursprec; + int remove; + + parcoursprec = (listvar *)NULL; + parcours = List_UsedInSubroutine_Var; + while ( parcours ) + { + remove = LookingForVariableInListGlobal(List_SubroutineArgument_Var, parcours->var); + if ( remove == 0 ) + remove = LookingForVariableInList(List_SubroutineDeclaration_Var, parcours->var); + if ( remove == 0 ) + remove = LookingForVariableInList(List_Parameter_Var, parcours->var); + if ( remove == 0 ) + remove = LookingForVariableInList(List_FunctionType_Var, parcours->var); + if ( remove == 0 ) + remove = LookingForVariableInListGlob(List_GlobalParameter_Var, parcours->var); + if ( remove == 0 ) + remove = LookingForVariableInListParamGlob(List_GlobParamModuleUsed_Var, parcours->var); + if ( remove == 0 ) + { + if ( VariableIsInList(parcours,List_Global_Var) == 1 || + VariableIsInListCommon(parcours,List_Common_Var) == 1 || + VariableIsInList(parcours,List_ModuleUsed_Var) == 1 || + VariableIsInList(parcours,List_ModuleUsedInModuleUsed_Var) == 1 + ) remove = 0; + else remove = 1; + } + + /************************************************************************/ + /* Remove */ + /************************************************************************/ + + if ( remove == 1 ) + { + if ( parcours == List_UsedInSubroutine_Var ) + { + List_UsedInSubroutine_Var = List_UsedInSubroutine_Var -> suiv; + parcours = List_UsedInSubroutine_Var; + } + else + { + parcoursprec->suiv = parcours->suiv; + parcours = parcoursprec -> suiv ; + } + } + else + { + parcoursprec = parcours; + parcours = parcours -> suiv ; + } + } +} + + +void Clean_List_ModuleUsed_Var() +{ + listvar *parcours; + listvar *parcours1; + listvar *parcoursprec; + int remove; + + parcoursprec = (listvar *)NULL; + parcours = List_ModuleUsed_Var; + while ( parcours ) + { + /* */ + parcours1 = List_GlobalParameter_Var; + remove = 0 ; + while ( parcours1 && remove == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,parcours1->var->v_nomvar) + ) remove = 1 ; + else parcours1 = parcours1 -> suiv; + } + /************************************************************************/ + /* Remove */ + /************************************************************************/ + if ( remove == 1 ) + { + if ( parcours == List_ModuleUsed_Var ) + { + List_ModuleUsed_Var = List_ModuleUsed_Var -> suiv; + parcours = List_ModuleUsed_Var; + } + else + { + parcoursprec->suiv = parcours->suiv; + parcours = parcoursprec -> suiv ; + } + } + else + { + parcoursprec = parcours; + parcours = parcours -> suiv ; + } + } +} + +void Clean_List_SubroutineDeclaration_Var() +{ + listvar *parcours; + listvar *parcours1; + listvar *parcoursprec; + int out ; + + parcoursprec = (listvar *)NULL; + parcours = List_SubroutineDeclaration_Var; + while ( parcours ) + { + parcours1 = List_FunctionType_Var; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_nomvar,parcours1->var->v_nomvar) + ) out = 1; + else parcours1 = parcours1->suiv; + } + if ( out == 0 ) + { + parcours1 = List_SubroutineArgument_Var; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,parcours1->var->v_subroutinename) && + !strcasecmp(parcours->var->v_nomvar,parcours1->var->v_nomvar) + ) out = 1; + else parcours1 = parcours1->suiv; + } + } + + if ( out == 1 ) + { + if ( parcours == List_SubroutineDeclaration_Var ) + { + List_SubroutineDeclaration_Var = + List_SubroutineDeclaration_Var -> suiv; + parcours = List_SubroutineDeclaration_Var; + } + else + { + parcoursprec->suiv = parcours->suiv; + parcours = parcoursprec->suiv; + } + } + else + { + parcoursprec = parcours; + parcours = parcours -> suiv; + } + } +} + +void Clean_List_Global_Var() +{ + listvar *parcours; + listvar *parcours2; + listvar *parcoursprec; + listvar *parcours2prec; + + parcoursprec = (listvar *)NULL; + parcours2prec = (listvar *)NULL; + parcours = List_Global_Var; + while ( parcours ) + { + if ( parcours->var->v_VariableIsParameter == 1 ) + { + /* remove */ + if ( parcours == List_Global_Var ) + { + List_Global_Var = List_Global_Var->suiv; + free(parcours); + parcours = List_Global_Var; + } + else + { + parcoursprec->suiv = parcours->suiv; + free(parcours); + parcours = parcoursprec->suiv; + } + } + else + { + parcoursprec = parcours; + parcours = parcours->suiv; + } + } + /* looking for sevral declaration of the same variable */ + parcours = List_Global_Var; + while ( parcours ) + { + parcours2prec = parcours; + parcours2 = parcours->suiv; + while ( parcours2 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours2->var->v_nomvar) && + !strcasecmp(parcours->var->v_modulename, + parcours2->var->v_modulename) ) + { + Merge_Variables(parcours->var,parcours2->var); + /* remove var from the parcours2 */ + parcours2prec ->suiv = parcours2->suiv; + free(parcours2); + parcours2 = parcours2prec ->suiv; + } + else + { + parcours2prec = parcours2; + parcours2 = parcours2->suiv; + } + } + parcours = parcours->suiv; + } +} +/******************************************************************************/ +/* ListClean */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void ListClean() +{ + listvar *newvar; + + Clean_List_ModuleUsed_Var(); + Clean_List_UsedInSubroutine_Var(); + Clean_List_SubroutineDeclaration_Var(); + + newvar = (listvar *)NULL; +/* newvar = List_Common_Var;*/ + while(newvar) + { + printf("----- %s --- %s ---%s---%s---\n",newvar->var->v_nomvar, + newvar->var->v_commonname, + newvar->var->v_readedlistdimension, + newvar->var->v_subroutinename + ); + newvar = newvar -> suiv; + printf("+++++++++++++++++++++++++\n"); + } + +} + + +/******************************************************************************/ +/* ListUpdate */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void ListUpdate() +{ + listvar *newvar; + + Update_List_Subroutine_Var(List_SubroutineArgument_Var); + Update_List_Subroutine_Var(List_FunctionType_Var); + Update_List_Var(List_Parameter_Var); + Update_List_Var(List_Dimension_Var); + Update_List_Var(List_Data_Var); + Update_List_Var(List_Save_Var); + Update_List_Var(List_GlobalParameter_Var); + Update_List_Var(List_Common_Var); + Update_List_Var(List_SubroutineDeclaration_Var); + Update_List_Var(List_UsedInSubroutine_Var); + Update_List_From_Common_Var(List_UsedInSubroutine_Var); + Update_List_From_Common_Var(List_SubroutineDeclaration_Var); + Update_NotGridDepend_Var(List_NotGridDepend_Var); + + newvar = (listvar * ) NULL; +// newvar = List_Common_Var; +// newvar = List_UsedInSubroutine_Var; +// newvar = List_Data_Var; + while ( newvar ) + { + printf("++++ %s - %s - %s - %d - %s - %s\n", + newvar->var->v_modulename, + newvar->var->v_subroutinename, + newvar->var->v_nomvar, + newvar->var->v_VariableIsParameter, + newvar->var->v_typevar, + newvar->var->v_initialvalue ); + newvar = newvar->suiv; + } +} + +void GiveTypeOfVariables() +{ + listvar *parcours; + + /* */ + parcours = List_Common_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_typevar,"") ) + { + if ( IsVariableReal(parcours->var->v_nomvar) == 1 ) + strcpy(parcours->var->v_typevar,"REAL"); + else strcpy(parcours->var->v_typevar,"INTEGER"); + } + parcours = parcours -> suiv ; + } + /* */ + parcours = List_UsedInSubroutine_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_typevar,"") ) + { + if ( IsVariableReal(parcours->var->v_nomvar) == 1 ) + strcpy(parcours->var->v_typevar,"REAL"); + else strcpy(parcours->var->v_typevar,"INTEGER"); + } + parcours = parcours -> suiv ; + } + /* */ + parcours = List_SubroutineArgument_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_typevar,"") ) + { + if ( IsVariableReal(parcours->var->v_nomvar) == 1 ) + strcpy(parcours->var->v_typevar,"REAL"); + else strcpy(parcours->var->v_typevar,"INTEGER"); + } + parcours = parcours -> suiv ; + } + /* */ + parcours = List_SubroutineDeclaration_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_typevar,"") ) + { + if ( IsVariableReal(parcours->var->v_nomvar) == 1 ) + strcpy(parcours->var->v_typevar,"REAL"); + else strcpy(parcours->var->v_typevar,"INTEGER"); + } + parcours = parcours -> suiv ; + } + +} + + + +void Sort_List_SubroutineArgument_Var() +{ + listvar *parcours; + listvar *parcours1; + int position; + int out; + char name_sub[LONG_M]; + + parcours = List_SubroutineArgument_Var; + position = 1; + while ( parcours ) + { + parcours1 = List_SubroutineDeclaration_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, + parcours1->var->v_subroutinename) + ) + { + parcours1->var->v_positioninblock = position; + position = position +1 ; + out = 1; + } + else parcours1 = parcours1->suiv; + } + parcours = parcours->suiv; + } + /* */ + parcours = List_SubroutineDeclaration_Var; + strcpy(name_sub,""); + while ( parcours ) + { + if ( !strcasecmp(name_sub,"") ) + { + strcpy(name_sub,parcours->var->v_subroutinename); + position = 1; + } + + if ( parcours->var->v_positioninblock != 0 ) + { + parcours1 = List_SubroutineArgument_Var; + out = 0; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours1->var->v_nomvar) && + !strcasecmp(parcours->var->v_subroutinename, + parcours1->var->v_subroutinename) + ) + { + parcours1->var->v_positioninblock = position; + position = position +1 ; + out = 1; + } + else parcours1 = parcours1->suiv; + } + } + if ( parcours->suiv ) + if ( strcasecmp(name_sub,parcours->suiv->var->v_subroutinename) ) + strcpy(name_sub,""); + parcours = parcours->suiv; + } + +} + + + +/******************************************************************************/ +/* IndiceTabvars_Global_Var_Treated */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void IndiceTabvars_Global_Var_Treated(char *nom) +{ + listvar *parcours; + listvar *parcoursprec; + listvar *parcours1; + listvar *List_ModuleUsed_Var; + listindice *newindice; + int out; + + parcoursprec = (listvar *)NULL; + + if ( todebug == 1 ) printf("MODULE Treated %s \n",nom); + + List_ModuleUsed_Var = (listvar *)NULL; + List_ModuleUsed_Var = Readthedependfile(nom,List_ModuleUsed_Var); + + parcours = List_Global_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename,nom) ) + { + parcours1 = List_ModuleUsed_Var; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,parcours1->var->v_nomvar) + ) out = 1; + else + { + parcoursprec = parcours1 ; + parcours1 = parcours1->suiv; + } + } + /* if we found the var Module name in the old list */ + if ( out == 1 ) + { + Merge_Variables(parcours->var,parcours1->var); + /* Remove this variable from the List_ModuleUsed_Var */ + if ( parcours1 == List_ModuleUsed_Var ) + { + List_ModuleUsed_Var = List_ModuleUsed_Var->suiv ; + } + else + { + parcoursprec->suiv = parcours1->suiv; + free(parcours1); + parcours1 = parcoursprec->suiv; + } + } + else + /* if we do not found the var Module name in the old list */ + { + // update_indicemaxtabvars(parcours->var,Listofavailableindices); + update_indicemaxtabvars(parcours->var,Listofavailableindices_glob); + // if ( Listofavailableindices ) + // { + // parcours->var->v_indicetabvars = Listofavailableindices -> + // i_indice; + // if ( Listofavailableindices->suiv ) + // Listofavailableindices = Listofavailableindices->suiv; + // else + // Listofavailableindices = (listindice *)NULL; + // } + // else + // { + // indicemaxtabvars = indicemaxtabvars + 1 ; + // parcours->var->v_indicetabvars = indicemaxtabvars; + // } + } + } + parcours = parcours->suiv; + } + /* if List_ModuleUsed_Var is not empty, some var have been removed from */ + /* the last treatement */ + parcours1 = List_ModuleUsed_Var; + while ( parcours1 ) + { + newindice=(listindice *) calloc(1,sizeof(listindice)); + newindice -> i_indice = parcours1 -> var -> v_indicetabvars; + newindice -> suiv = Listofavailableindices_glob[parcours1 -> var -> v_catvar]; + Listofavailableindices_glob[parcours1 -> var -> v_catvar] = newindice; + parcours1 = parcours1->suiv; + } +} +/******************************************************************************/ +/* IndiceTabvars_Global_Var_No_Treated */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void IndiceTabvars_Global_Var_No_Treated(char *nom) +{ + listvar *parcours; + + if ( todebug == 1 ) printf("MODULE No Treated %s \n",nom); + + parcours = List_Global_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename,nom) && + parcours->var->v_VariableIsParameter == 0 && + parcours->var->v_notgrid == 0 + ) + { + indicemaxtabvars[parcours->var->v_catvar] = indicemaxtabvars[parcours->var->v_catvar] + 1 ; + parcours->var->v_indicetabvars = indicemaxtabvars[parcours->var->v_catvar]; + } + parcours = parcours->suiv; + } +} + + +void UpdateTheRemainingList(listvar *record) +{ + listvar *parcours; + + parcours = record; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_nomvar,record->var->v_nomvar) && + !strcasecmp(parcours->var->v_commonname,record->var->v_commonname) + ) + { + strcpy(parcours->var->v_commoninfile,record->var->v_commoninfile); + Merge_Variables(parcours->var,record->var); + } + parcours = parcours -> suiv; + } +} + + + +/******************************************************************************/ +/* IndiceTabvars_Common_Var_Treated */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void IndiceTabvars_Common_Var_Treated(char *nom) +{ + listvar *parcours; + listvar *parcours1; + listvar *List_CommonUsed_Var; + listindice *newindice; + int out; + + if ( todebug == 1 ) printf("COMMON Treated %s \n",nom); + + List_CommonUsed_Var = (listvar *)NULL; + List_CommonUsed_Var = Readthedependfile(nom,List_CommonUsed_Var); + + parcours = List_Common_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_commonname,nom) ) + { + parcours1 = List_CommonUsed_Var; + out = 0 ; + while ( parcours1 && out == 0 ) + { + + if ( !strcasecmp(parcours1->var->v_commonname,nom) && + !strcasecmp(parcours->var->v_nomvar,parcours1->var->v_nomvar) + ) out = 1; + else + { + parcours1 = parcours1->suiv; + } + } + /* if we found the var common name in the old list */ + if ( out == 1 ) + { + strcpy(parcours->var->v_commoninfile, + parcours1->var->v_commoninfile); + Merge_Variables(parcours->var,parcours1->var); + } + else + /* if we do not found the var common name in the old list */ + { + // update_indicemaxtabvars(parcours->var,Listofavailableindices); + update_indicemaxtabvars(parcours->var,Listofavailableindices_glob); + // if ( Listofavailableindices ) + // { + // parcours->var->v_indicetabvars = Listofavailableindices -> + // i_indice; + // if ( Listofavailableindices->suiv ) + // Listofavailableindices = Listofavailableindices->suiv; + // else + // Listofavailableindices = (listindice *)NULL; + // } + // else + // { + // indicemaxtabvars = indicemaxtabvars + 1 ; + // parcours->var->v_indicetabvars = indicemaxtabvars; + // } + } + /* Look in the remaining list in the variable is define */ + UpdateTheRemainingList(parcours); + } + parcours = parcours->suiv; + } + /* if List_CommonUsed_Var is not empty, some var have been removed from */ + /* the last treatement */ + parcours1 = List_CommonUsed_Var; + while ( parcours1 ) + { + if ( parcours1 -> var -> v_indicetabvars == 0 ) + { + newindice=(listindice *) calloc(1,sizeof(listindice)); + newindice -> i_indice = parcours1 -> var -> v_indicetabvars; + newindice -> suiv = Listofavailableindices_glob[parcours1 -> var -> v_catvar]; + Listofavailableindices_glob[parcours1 -> var -> v_catvar] = newindice; + } + parcours1 = parcours1->suiv; + } +} + +void update_indicemaxtabvars(variable *var,listindice **Listofindices) +{ + + + if ( Listofindices[var->v_catvar] ) + { + var->v_indicetabvars = Listofindices[var->v_catvar] -> i_indice; + if ( Listofindices[var->v_catvar]->suiv ) + Listofindices[var->v_catvar] = Listofindices[var->v_catvar]->suiv; + else + Listofindices[var->v_catvar] = (listindice *)NULL; + } + else + { + indicemaxtabvars[var->v_catvar] = indicemaxtabvars[var->v_catvar] + 1 ; + var->v_indicetabvars = indicemaxtabvars[var->v_catvar]; + } + +} + +/******************************************************************************/ +/* IndiceTabvars_Common_Var_No_Treated */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void IndiceTabvars_Common_Var_No_Treated(char *nom) +{ + listvar *parcours; + listvar *parcours2; + + if ( todebug == 1 ) printf("COMMON No Treated %s \n",nom); + + parcours = List_Common_Var; + while( parcours ) + { + if ( !strcasecmp(parcours->var->v_commonname,nom) && + strcasecmp(parcours->var->v_subroutinename,"") && + parcours->var->v_indicetabvars == 0 + ) + { + indicemaxtabvars[parcours->var->v_catvar] = indicemaxtabvars[parcours->var->v_catvar] + 1 ; + parcours->var->v_indicetabvars = indicemaxtabvars[parcours->var->v_catvar]; + parcours2 = parcours; + while ( parcours2 ) + { + if ( !strcasecmp(parcours->var->v_nomvar, + parcours2->var->v_nomvar) && + !strcasecmp(parcours->var->v_commonname, + parcours2->var->v_commonname) + ) + parcours2->var->v_indicetabvars = parcours->var->v_indicetabvars; + parcours2 = parcours2->suiv; + } + } + parcours = parcours->suiv; + } +} + + +/******************************************************************************/ +/* IndiceTabvarsIdentification */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void IndiceTabvarsIdentification() +{ + listnom *parcours_nom; + + /* Identification of tabvars indices in List_Global_Var */ + parcours_nom = List_NameOfModule; + while ( parcours_nom ) + { + if ( is_dependfile_created(parcours_nom->o_nom) == 1 ) + { + IndiceTabvars_Global_Var_Treated(parcours_nom->o_nom); + } + else + { + IndiceTabvars_Global_Var_No_Treated(parcours_nom->o_nom); + } + parcours_nom = parcours_nom -> suiv; + } + /* Identification of tabvars indices in List_Common_Var */ + parcours_nom = List_NameOfCommon; + while ( parcours_nom ) + { + if ( is_dependfile_created(parcours_nom->o_nom) == 1 ) + { + IndiceTabvars_Common_Var_Treated(parcours_nom->o_nom); + } + else + { + IndiceTabvars_Common_Var_No_Treated(parcours_nom->o_nom); + } + parcours_nom = parcours_nom -> suiv; + } + +} + +void New_Allocate_Subroutine_Is_Necessary() +{ + listnom *parcours_nom; + listvar *parcours; + int out; + + parcours_nom = List_NameOfModule; + while ( parcours_nom ) + { + /* */ + parcours = List_Global_Var; + out = 0 ; + while( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) && + !strcasecmp(parcours->var->v_subroutinename,"") && + parcours->var->v_VariableIsParameter == 0 && + ( parcours->var->v_allocatable == 0 || !strcasecmp(parcours->var->v_typevar,"type")) && + parcours->var->v_notgrid == 0 && + ( ( parcours->var->v_nbdim != 0 || !strcasecmp(parcours->var->v_typevar,"type") ) + || strcasecmp(parcours->var->v_initialvalue,"") ) + ) + { + out = 1; + } + else parcours = parcours -> suiv; + } + if ( out ) + { + parcours_nom->o_val = 1 ; + } + parcours_nom = parcours_nom -> suiv; + } +} + +void New_Allocate_Subroutine_For_Common_Is_Necessary() +{ + listnom *parcours_nom; + listvar *parcours; + int out; + + parcours_nom = List_NameOfCommon; + while ( parcours_nom ) + { + parcours = List_Common_Var; + out = 0 ; + while( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_commonname,parcours_nom->o_nom) && + strcasecmp(parcours->var->v_subroutinename,"") && + !strcasecmp(parcours->var->v_commoninfile,cur_filename) && + ( ( parcours->var->v_nbdim != 0 || !strcasecmp(parcours->var->v_typevar,"type") ) + || strcasecmp(parcours->var->v_initialvalue,"") ) + ) + { + out = 1; + } + else parcours = parcours -> suiv; + } + if ( out == 1 ) + { + parcours_nom->o_val = 1 ; + } + parcours_nom = parcours_nom -> suiv; + } +} + +void NewModule_Creation_0() +{ + listnom *parcours_nom; + + parcours_nom = List_NameOfCommon; + while ( parcours_nom ) + { + if ( parcours_nom->o_val == 1 ) + { + fprintf(fortran_out, " module %s\n\n", parcours_nom->o_nom); + WriteUsemoduleDeclaration(parcours_nom->o_subroutinename); + fprintf(fortran_out, " implicit none\n"); + fprintf(fortran_out, " public :: Alloc_agrif_%s\n", parcours_nom->o_nom); + fprintf(fortran_out, " contains\n"); + fprintf(fortran_out, " subroutine Alloc_agrif_%s(Agrif_Gr)\n", parcours_nom->o_nom); + fprintf(fortran_out, " use Agrif_Util\n"); + fprintf(fortran_out, " type(Agrif_grid), pointer :: Agrif_Gr\n"); + fprintf(fortran_out, " integer :: i\n"); + fprintf(fortran_out, "#include \"alloc_agrif_%s.h\"\n", parcours_nom->o_nom); + fprintf(fortran_out, " end subroutine Alloc_agrif_%s\n", parcours_nom->o_nom); + fprintf(fortran_out, " end module %s\n", parcours_nom->o_nom); + /* List all Call Alloc_agrif */ + Add_Subroutine_For_Alloc(parcours_nom->o_nom); + } + parcours_nom = parcours_nom->suiv; + } +} + +void UpdateList_SubroutineWhereAgrifUsed() +{ + listnom *parcours; + listusemodule *parcours1; + listallocate *parcours2; + listname *parcours3; + listvar *parcours4; + int out; + char name_module[LONG_M]; + + /* We should integrate allocate and pointer variables */ +// parcours2 = List_Allocate_Var; +// while ( parcours2 ) +// { +// parcours4 = List_UsedInSubroutine_Var; +// out = 0 ; +// while ( parcours4 && out == 0 ) +// { +// if ( !strcasecmp(parcours2->a_nomvar,parcours4->var->v_nomvar) ) +// { +// Add_SubroutineWhereAgrifUsed_1(parcours4->var->v_subroutinename, parcours4->var->v_modulename); +// out = 1; +// } +// else parcours4 = parcours4 -> suiv ; +// } +// parcours2 = parcours2->suiv; +// } +// +// parcours3 = List_Pointer_Var; +// while ( parcours3 ) +// { +// parcours4 = List_UsedInSubroutine_Var; +// out = 0 ; +// while ( parcours4 && out == 0 ) +// { +// if ( !strcasecmp(parcours3->n_name, parcours4->var->v_nomvar) ) +// { +// Add_SubroutineWhereAgrifUsed_1(parcours4->var->v_subroutinename, parcours4->var->v_modulename); +// out = 1; +// } +// else parcours4 = parcours4 -> suiv ; +// } +// parcours3 = parcours3 -> suiv; +// } +// parcours4 = List_UsedInSubroutine_Var; +// while ( parcours4 ) +// { +// if ( parcours4->var->v_allocatable == 1 && strcasecmp(parcours4->var->v_typevar,"type")) +// { +// Add_SubroutineWhereAgrifUsed_1(parcours4->var->v_subroutinename, parcours4->var->v_modulename); +// } +// parcours4 = parcours4 -> suiv ; +// } + + parcours = List_SubroutineWhereAgrifUsed; + while ( parcours ) + { + parcours1 = List_NameOfModuleUsed; + out = 0 ; + strcpy(name_module,""); + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(parcours->o_nom,parcours1->u_cursubroutine) && + !strcasecmp(parcours1->u_usemodule,"Agrif_Util") + ) out = 1; + else + { + if ( !strcasecmp(parcours->o_nom,parcours1->u_cursubroutine) ) + { + strcpy(name_module, parcours->o_module); + } + parcours1 = parcours1->suiv; + } + } + if ( out == 0 ) /* we should look in the module declaration */ + { + parcours1 = List_NameOfModuleUsed; + out = 0 ; + while ( parcours1 && out == 0 ) + { + if ( !strcasecmp(name_module,parcours1->u_modulename) && + !strcasecmp(parcours1->u_cursubroutine,"")&& + !strcasecmp(parcours1->u_usemodule,"Agrif_Util") + ) out = 1; + else parcours1 = parcours1->suiv; + } + } + if ( out == 0 ) parcours->o_val = 1; + + parcours = parcours->suiv; + } +} + + +void UpdateList_UsedInSubroutine_With_dimension() +{ + listvar *parcours; + + parcours = List_UsedInSubroutine_Var; + while ( parcours ) + { + if ( parcours->var->v_nbdim != 0 ) + { + strcpy(subroutinename,parcours->var->v_subroutinename); + DecomposeTheName(parcours->var->v_readedlistdimension); + strcpy(subroutinename,""); + } + parcours = parcours -> suiv; + } +} + +void Affiche(listvar *in_parcours) +{ +/* parcours = List_Global_Var; */ +/* parcours = List_SubroutineDeclaration_Var; */ +/* parcours = List_SubroutineArgument_Var; */ +/* parcours = List_FunctionType_Var; */ +/* parcours = List_Data_Var; */ +/* parcours = List_Save_Var; */ +/* parcours = List_UsedInSubroutine_Var; */ +/* parcours = List_Parameter_Var; */ +/* parcours = List_GlobalParameter_Var; */ +/* parcours = List_NotGridDepend_Var; */ +/* parcours = List_Common_Var; */ + listvar *parcours = in_parcours; + + while( parcours ) + { + printf("modulename - %s \n", parcours->var->v_modulename); + printf("subroutinename - %s \n", parcours->var->v_subroutinename); + printf("nomvar - %s \n", parcours->var->v_nomvar); + printf("commonname - %s \n", parcours->var->v_commonname); + printf("commoninfile - %s \n", parcours->var->v_commoninfile); + printf("typevar - %s \n", parcours->var->v_typevar); + printf("catvar - %d \n", parcours->var->v_catvar); + printf("indicetabvars - %d \n", parcours->var->v_indicetabvars); + printf("isparameter - %d \n", parcours->var->v_VariableIsParameter); + printf("module - %d \n", parcours->var->v_module); + printf("save - %d \n", parcours->var->v_save); + printf("notgrid - %d \n", parcours->var->v_notgrid); + printf("nbdim - %d \n", parcours->var->v_nbdim); + printf("common - %d \n", parcours->var->v_common); + printf("dimensiongiven - %d \n", parcours->var->v_dimensiongiven); + printf("dimsempty - %d \n", parcours->var->v_dimsempty); + printf("initialvalue - %s \n", parcours->var->v_initialvalue); + printf("readedlistdim - %s \n", parcours->var->v_readedlistdimension); + printf("-------------------------------------\n"); + + parcours = parcours -> suiv ; + } + if ( todebug == 1 ) printf("Indicemaxtabvars = %d \n",indicemaxtabvars[0]); +} + +int SubInList_ContainsSubroutine() +{ + int out; + listnom *parcours; + + out = 0 ; + parcours = List_ContainsSubroutine; + while ( parcours && out == 0 ) + { + if ( !strcasecmp(parcours->o_nom,subroutinename) ) out = 1 ; + else parcours = parcours -> suiv; + } + + return out; +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithvarofsubroutineliste.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithvarofsubroutineliste.c new file mode 100644 index 0000000000000000000000000000000000000000..257f1c989d343794444f8966368d48a314dc174b --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WorkWithvarofsubroutineliste.c @@ -0,0 +1,78 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* Add_SubroutineArgument_Var_1 */ +/******************************************************************************/ +void Add_SubroutineArgument_Var_1(listvar *listtoadd) +{ + List_SubroutineArgument_Var = AddListvarToListvar(listtoadd, List_SubroutineArgument_Var, 1); +} + +/******************************************************************************/ +/* Add_FunctionType_Var_1 */ +/******************************************************************************/ +void Add_FunctionType_Var_1(const char *nom) +{ + listvar *newvar; + + curvar = createvar(nom, NULL); + strcpy(curvar->v_typevar, DeclType); + newvar = insertvar(NULL, curvar); + List_FunctionType_Var = AddListvarToListvar(newvar,List_FunctionType_Var,1); +} + +/******************************************************************************/ +/* Add_SubroutineDeclaration_Var_1 */ +/******************************************************************************/ +/* We should complete the listvarofsubroutine */ +/******************************************************************************/ +// void Add_SubroutineDeclaration_Var_1 (listvar *listtoadd) +// { +// if ( firstpass == 1 ) +// { +// if ( VariableIsParameter == 0 && +// SaveDeclare == 0 ) +// { +// listduplicated = (listvar *)NULL; +// duplicatelistvar(listtoadd); +// List_SubroutineDeclaration_Var = AddListvarToListvar(listduplicated,List_SubroutineDeclaration_Var,1); +// } +// } +// } diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/WriteInFile.c b/V4.0/nemo_sources/ext/AGRIF/LIB/WriteInFile.c new file mode 100644 index 0000000000000000000000000000000000000000..5e046f96e91402ba603cc6e5031be01eca52499e --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/WriteInFile.c @@ -0,0 +1,159 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +/******************************************************************************/ +/* tofich_reste */ +/******************************************************************************/ +/* This subroutine is used to write the string s into the fileout */ +/******************************************************************************/ +void tofich_reste (FILE * filout, const char *s, int do_returnline) +{ + const size_t line_length = 66; + char temp[line_length+1]; + size_t s_length; + + s_length = strlen(s); + + if ( !strcmp(&s[strlen(s)-1], "\n") ) + s_length = strlen(s)-1; + + if ( s_length <= line_length ) + { + if ( do_returnline ) fprintf(filout, " &%s\n", s); + else fprintf(filout, "&%s", s); + } + else + { + strncpy(temp, s, line_length); + temp[line_length] = '\0'; + if ( retour77 == 0 && (s_length-strlen(temp) > 0) ) + fprintf(filout, " &%s&\n", temp); + else fprintf(filout, " &%s\n", temp); + + if ( s_length-strlen(temp) > 0 ) + tofich_reste(filout, (char *) &s[line_length], do_returnline); + } +} + +/******************************************************************************/ +/* tofich */ +/******************************************************************************/ +/* This subroutine is used to write the string s into the fileout */ +/******************************************************************************/ +void tofich (FILE * filout, const char *s, int do_returnline) +{ + const size_t line_length = 66; + char temp[line_length+1]; + size_t s_length; + + s_length = strlen(s); + + if ( !strcmp(&s[strlen(s)-1], "\n") ) + s_length = strlen(s)-1; + + if ( s_length <= line_length ) + { + if ( do_returnline ) fprintf(filout, " %s\n", s); + else fprintf(filout, "%s", s); + } + else + { + strncpy(temp, s, line_length); + temp[line_length] = '\0'; + + if ( retour77 == 0 ) fprintf(filout, " %s&\n", temp); + else fprintf(filout, " %s\n", temp); + + tofich_reste(filout, (char *) &s[line_length], do_returnline); + } +} + +/******************************************************************************/ +/* tofich_blanc */ +/******************************************************************************/ +/* This subroutine is used to write size blank into the fileout */ +/******************************************************************************/ +void tofich_blanc (FILE * filout, int size) +{ + const char* empty_char = " "; + int i = 0; + + if (size <= 65) + fprintf(filout, "%*s\n", size, empty_char); + else + { + do + { + fprintf(filout, "%*s\n", 65, empty_char); + i++; + } + while ( i <= size / 65 ); + + fprintf(filout, "%*s\n", size%65, empty_char); + } +} + +/******************************************************************************/ +/* RemoveWordSET_0 */ +/******************************************************************************/ +/* This subroutine is used to remove a sentence in the file filout */ +/******************************************************************************/ +void RemoveWordSET_0(FILE * filout, long int position, int sizetoremove) +{ + if ( inside_type_declare || firstpass ) return; + + fseek(filout, position, SEEK_SET); + tofich_blanc(filout, sizetoremove); + fseek(filout, position, SEEK_SET); +} + +/******************************************************************************/ +/* RemoveWordCUR_0 */ +/******************************************************************************/ +/* This subroutine is used to remove a sentence in the file filout */ +/******************************************************************************/ +void RemoveWordCUR_0(FILE * filout, int sizetoremove) +{ + if ( inside_type_declare || firstpass ) return; + + fseek(filout, (long int)(-sizetoremove), SEEK_CUR); + tofich_blanc(filout, sizetoremove); + fseek(filout, (long int)(-sizetoremove), SEEK_CUR); + if ( strstr(fortran_text, "\n") ) fprintf(filout, "\n"); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/Writedeclarations.c b/V4.0/nemo_sources/ext/AGRIF/LIB/Writedeclarations.c new file mode 100644 index 0000000000000000000000000000000000000000..1d2eeca1afd99c7d3b5462c950455e6e315f1c4d --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/Writedeclarations.c @@ -0,0 +1,668 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include + +#include "decl.h" + +/******************************************************************************/ +/* WriteBeginDeclaration */ +/******************************************************************************/ +/* This subroutine is used to write the begin of a declaration */ +/* taken in a variable record */ +/* */ +/******************************************************************************/ +/* */ +/* integer variable -----------> INTEGER */ +/* */ +/******************************************************************************/ +void WriteBeginDeclaration(variable *v, char line[LONG_M], int visibility) +{ + char tmpligne[LONG_M]; + int precision_given ; + + if ( !strcasecmp(v->v_typevar,"") ) + { + printf("# WARNING : The type of the variable %s is unknown.\n", v->v_nomvar); + printf("# CONV should define a type\n"); + } + + sprintf(line, "%s", v->v_typevar); + if ( v->v_c_star == 1 ) strcat(line, "*"); + + /* We should give the precision of the variable if it has been given */ + precision_given = 0; + if ( strcasecmp(v->v_precision,"") ) + { + sprintf(tmpligne, "(%s)", v->v_precision); + Save_Length(tmpligne, 49); + strcat(line, tmpligne); + precision_given = 1; + } + + if (strcasecmp(v->v_dimchar,"")) + { + sprintf(tmpligne,"(%s)",v->v_dimchar); + Save_Length(tmpligne, 49); + strcat(line,tmpligne); + } + + if ((precision_given == 0) && ( strcasecmp(v->v_nameinttypename,"") )) + { + sprintf(tmpligne,"*%s",v->v_nameinttypename); + Save_Length(tmpligne, 49); + strcat(line,tmpligne); + } + if (strcasecmp (v->v_IntentSpec, "")) + { + sprintf(tmpligne,", intent(%s)", v->v_IntentSpec); + Save_Length(tmpligne, 49); + strcat(line,tmpligne); + } + if ( v->v_VariableIsParameter ) strcat(line, ", parameter"); + if ( visibility ) + { + if ( v->v_PublicDeclare ) strcat(line, ", public"); + if ( v->v_PrivateDeclare ) strcat(line, ", private"); + } + if ( v->v_ExternalDeclare ) strcat(line, ", external"); + if ( v->v_allocatable ) strcat(line, ", allocatable"); + if ( v->v_target ) strcat(line, ", target"); + if ( v->v_optionaldeclare ) strcat(line, ", optional"); + if ( v->v_pointerdeclare ) strcat(line, ", pointer"); + Save_Length(line, 45); +} + + +/******************************************************************************/ +/* WriteScalarDeclaration */ +/******************************************************************************/ +/* This subroutine is used to write a scalar declaration */ +/* taken in a variable record */ +/* */ +/******************************************************************************/ +/* */ +/* integer variable -----------> INTEGER :: VARIABLE */ +/* */ +/******************************************************************************/ +void WriteScalarDeclaration( variable *v, char line[LONG_M]) +{ + strcat(line, " :: "); + strcat(line, v->v_nomvar); + + if ( strcasecmp(v->v_vallengspec, "") ) strcat(line,v->v_vallengspec); + if ( v->v_VariableIsParameter ) + { + strcat(line," = "); + strcat(line, v->v_initialvalue); + } + Save_Length(line, 45); +} + +/******************************************************************************/ +/* WriteTableDeclaration */ +/******************************************************************************/ +/* This subroutine is used to write a Table declaration */ +/* taken in a variable record */ +/* */ +/******************************************************************************/ +/* */ +/* integer variable(nb) -----------> */ +/* INTEGER, DIMENSION(1:nb) :: variable */ +/* */ +/******************************************************************************/ +void WriteTableDeclaration(variable * v,char ligne[LONG_M],int tmpok) +{ + char newname[LONG_M]; + + strcat (ligne, ", dimension("); + + if ( v->v_dimensiongiven == 1 && tmpok == 1 ) strcat(ligne,v->v_readedlistdimension); + if ( v->v_dimensiongiven == 1 && tmpok == 0 ) + { + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(v->v_readedlistdimension,List_Global_Var)); + if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); + + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var)); + if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); + + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var)); + if ( !strcasecmp(newname,"") ) strcat(newname,v->v_readedlistdimension); + + Save_Length(newname,47); + strcat(ligne,newname); + } + strcat(ligne, ") :: "); + strcat(ligne, v->v_nomvar); + if ( strcasecmp(vallengspec,"") ) strcat(ligne,v->v_vallengspec); + + if ( v->v_VariableIsParameter == 1 ) + { + strcat(ligne," = "); + strcat(ligne,v->v_initialvalue); + } + Save_Length(ligne,45); +} + +/******************************************************************************/ +/* WriteVarDeclaration */ +/******************************************************************************/ +/* This subroutine is used to write the initial declaration in the file */ +/* fileout of a variable */ +/* */ +/******************************************************************************/ +/* */ +/* integer variable(nb) -----------> */ +/* INTEGER, DIMENSION(1:nb),Pointer :: variable */ +/* */ +/******************************************************************************/ +void WriteVarDeclaration( variable *v, FILE *fileout, int value, int visibility ) +{ + FILE *filecommon; + char ligne[LONG_M]; + + filecommon = fileout; + + if ( v->v_save == 0 || inmodulemeet == 0 ) + { + WriteBeginDeclaration(v, ligne, visibility); + + if ( v->v_nbdim == 0 ) + WriteScalarDeclaration(v, ligne); + else + WriteTableDeclaration(v, ligne, value); + + if ( v->v_VariableIsParameter != 1 && strcasecmp(v->v_initialvalue,"") ) + { + strcat(ligne," = "); + strcat(ligne,v->v_initialvalue); + } + tofich(filecommon, ligne, 1); + } + else + printf("-- in writevardeclaration : |%s| -- MHCHECK\n", v->v_nomvar); + Save_Length(ligne,45); +} + + +void WriteLocalParamDeclaration(FILE* tofile) +{ + listvar *parcours; + + parcours = List_Parameter_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) ) + { + WriteVarDeclaration(parcours->var, tofile, 0, 1); + } + parcours = parcours -> suiv; + } +} + +void WriteFunctionDeclaration(FILE* tofile, int value) +{ + listvar *parcours; + + parcours = List_FunctionType_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) && + strcasecmp(parcours->var->v_typevar, "") ) + { + WriteVarDeclaration(parcours->var, tofile, value, 1); + } + parcours = parcours -> suiv; + } +} + +void WriteSubroutineDeclaration(int value) +{ + listvar *parcours; + variable *v; + + parcours = List_SubroutineDeclaration_Var; + while ( parcours ) + { + v = parcours->var; + if ( !strcasecmp(v->v_subroutinename, subroutinename) && + (v->v_save == 0) && + (v->v_pointerdeclare == 0) && + (v->v_VariableIsParameter == 0) && + (v->v_common == 0) ) + { + WriteVarDeclaration(v, fortran_out, value, 1); + } + else if ( !strcasecmp(v->v_subroutinename, subroutinename) && + (v->v_save == 0) && + (v->v_VariableIsParameter == 0) && + (v->v_common == 0) ) + { + WriteVarDeclaration(v, fortran_out, value, 1); + } + parcours = parcours -> suiv; + } +} + +void WriteArgumentDeclaration_beforecall() +{ + int position; + listnom *neededparameter; + FILE *paramtoamr; + listvar *parcours; + variable *v; + char ligne[LONG_M]; + + fprintf(fortran_out,"#include \"Param_BeforeCall_%s.h\"\n",subroutinename); + + sprintf(ligne,"Param_BeforeCall_%s.h",subroutinename); + paramtoamr = open_for_write(ligne); + + neededparameter = (listnom * )NULL; + position = 1; + parcours = List_SubroutineArgument_Var; + + while ( parcours ) + { + v = parcours->var; + if ( !strcasecmp(v->v_subroutinename, subroutinename) && (v->v_positioninblock == position) ) + { + position++; + WriteVarDeclaration(v, fortran_out, 0, 1); + neededparameter = writedeclarationintoamr(List_Parameter_Var, paramtoamr, + v, v->v_subroutinename, neededparameter, subroutinename); + parcours = List_SubroutineArgument_Var; + } + else parcours = parcours -> suiv; + } + Save_Length(ligne,45); + + // Write interface for 'Sub_Loop_machin' in 'Param_BeforeCall_machin.h' when outside a module + if ( IsTabvarsUseInArgument_0() && (inmodulemeet == 0) && (inprogramdeclare == 0) ) + { + fprintf(paramtoamr, " interface\n"); + if (isrecursive) sprintf(ligne," recursive subroutine Sub_Loop_%s(", subroutinename); + else sprintf(ligne," subroutine Sub_Loop_%s(", subroutinename); + WriteVariablelist_subloop(ligne); + WriteVariablelist_subloop_Def(ligne); + strcat(ligne,")"); + Save_Length(ligne,45); + tofich(paramtoamr,ligne,1); + + listusemodule *parcours_mod; + parcours_mod = List_NameOfModuleUsed; + while ( parcours_mod ) + { + if ( !strcasecmp(parcours_mod->u_cursubroutine, subroutinename) ) + { + fprintf(paramtoamr, " use %s\n", parcours_mod->u_usemodule); + } + parcours_mod = parcours_mod->suiv; + } + fprintf(paramtoamr, " implicit none\n"); + WriteLocalParamDeclaration(paramtoamr); + writesub_loopdeclaration_scalar(List_UsedInSubroutine_Var, paramtoamr); + writesub_loopdeclaration_tab(List_UsedInSubroutine_Var, paramtoamr); + WriteArgumentDeclaration_Sort(paramtoamr); + WriteFunctionDeclaration(paramtoamr, 1); + + sprintf(ligne," end subroutine Sub_Loop_%s\n", subroutinename); + tofich(paramtoamr, ligne, 1); + fprintf(paramtoamr, " end interface\n"); + } + fclose(paramtoamr); +} + +void WriteArgumentDeclaration_Sort(FILE* tofile) +{ + int position = 1; + listvar *parcours; + + parcours = List_SubroutineArgument_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename, subroutinename) && + parcours->var->v_positioninblock == position ) + { + position = position + 1; + WriteVarDeclaration(parcours->var, tofile, 1, 1); + parcours = List_SubroutineArgument_Var; + } + else parcours = parcours -> suiv; + } + + parcours = List_SubroutineArgument_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && + parcours->var->v_positioninblock == 0 && + parcours->var->v_nbdim == 0 ) + { + WriteVarDeclaration(parcours->var,tofile,1,1); + } + parcours = parcours -> suiv; + } + + parcours = List_SubroutineArgument_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_subroutinename,subroutinename) && + parcours->var->v_positioninblock == 0 && + parcours->var->v_nbdim != 0 ) + { + WriteVarDeclaration(parcours->var, tofile, 1, 1); + } + parcours = parcours -> suiv; + } +} + +/******************************************************************************/ +/* writedeclarationintoamr */ +/******************************************************************************/ +/* This subroutine is used to write the declaration of parameters needed in */ +/* allocation subroutines creates in toamr.c */ +/******************************************************************************/ +/* */ +/* */ +/******************************************************************************/ +listnom *writedeclarationintoamr (listvar * deb_common, FILE *fileout, + variable *var , const char *commonname, + listnom *neededparameter, const char *name_common) +{ + listvar *newvar; + variable *v; + char ligne[LONG_M]; + int changeval; + int out; + int writeit; + listnom *parcours; + + /* we should list the needed parameter */ + if ( !strcasecmp(name_common,commonname) ) + neededparameter = DecomposeTheNameinlistnom(var->v_readedlistdimension,neededparameter); + /* */ + parcours = neededparameter; + while (parcours) + { + newvar = deb_common; + + out = 0 ; + while ( newvar && out == 0 ) + { + + if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename)) + { + out=1; + /* add the name to the list of needed parameter */ + neededparameter = DecomposeTheNameinlistnom( + newvar->var->v_initialvalue, + neededparameter ); + } + else newvar=newvar->suiv; + } + parcours=parcours->suiv; + } + /* */ + parcours = neededparameter; + while (parcours) + { + newvar = deb_common; + out = 0 ; + while ( newvar && out == 0 ) + { + if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename)) + { + out=1; + /* add the name to the list of needed parameter */ + neededparameter = DecomposeTheNameinlistnom( + newvar->var->v_initialvalue, + neededparameter ); + } + else newvar=newvar->suiv; + } + parcours=parcours->suiv; + } + parcours = neededparameter; + while (parcours) + { + writeit = 0; + newvar = deb_common; + while ( newvar && writeit == 0 ) + { + if ( !strcasecmp(parcours->o_nom,newvar->var->v_nomvar) && + !strcasecmp(var->v_subroutinename,newvar->var->v_subroutinename) && parcours->o_val == 0 ) + { + writeit=1; + parcours->o_val = 1; + } + else newvar = newvar->suiv; + } + + if ( writeit == 1 ) + { + changeval = 0; + v = newvar->var; +// if ( v->v_allocatable == 1 && strcasecmp(v->v_typevar,"type") ) +// { +// changeval = 1; +// v->v_allocatable = 0; +// } + WriteBeginDeclaration(v, ligne, 1); + if ( v->v_nbdim == 0 ) WriteScalarDeclaration(v,ligne); + else WriteTableDeclaration(v, ligne, 1); + + tofich(fileout, ligne, 1); + if ( changeval == 1 ) + { + v->v_allocatable = 1; + } + } + else + { + if ( strncasecmp(parcours->o_nom,"mpi_",4) == 0 && + shouldincludempif == 1 ) + { + shouldincludempif = 0; + fprintf(fileout," include \'mpif.h\'\n"); + } + } + parcours=parcours->suiv; + } + Save_Length(ligne,45); + return neededparameter; +} + + +/******************************************************************************/ +/* writesub_loopdeclaration_scalar */ +/******************************************************************************/ +/* This subroutine is used to write the declaration part of subloop */ +/* subroutines */ +/******************************************************************************/ +/* */ +/* integer variable(nb) -----------> */ +/* */ +/* INTEGER, DIMENSION(1:nb) :: variable */ +/* */ +/******************************************************************************/ +void writesub_loopdeclaration_scalar (listvar * deb_common, FILE *fileout) +{ + listvar *newvar; + variable *v; + char ligne[LONG_M]; + +// tofich (fileout, "",1); + newvar = deb_common; + + while (newvar) + { + if ( newvar->var->v_nbdim == 0 && + !strcasecmp(newvar->var->v_subroutinename,subroutinename) && + (newvar->var->v_pointerdeclare == 0 || !strcasecmp(newvar->var->v_typevar,"type")) ) + { + v = newvar->var; + + WriteBeginDeclaration(v,ligne,1); + WriteScalarDeclaration(v,ligne); + tofich (fileout, ligne,1); + } + newvar = newvar->suiv; + } + Save_Length(ligne,45); +} + +/******************************************************************************/ +/* writesub_loopdeclaration_tab */ +/******************************************************************************/ +/* This subroutine is used to write the declaration part of subloop */ +/* subroutines */ +/******************************************************************************/ +/* */ +/* integer variable(nb) -----------> */ +/* */ +/* INTEGER, DIMENSION(1:nb) :: variable */ +/* */ +/******************************************************************************/ +void writesub_loopdeclaration_tab (listvar * deb_common, FILE *fileout) +{ + listvar *newvar; + variable *v; + char ligne[LONG_M]; + int changeval; + + newvar = deb_common; + while (newvar) + { + v = newvar->var; +// printf("newvar = %s %d %s\n",newvar->var->v_nomvar,newvar->var->v_pointerdeclare,newvar->var->v_typevar); + if ( (v->v_nbdim != 0) && !strcasecmp(v->v_subroutinename, subroutinename) && + (v->v_pointerdeclare == 0 || !strcasecmp(v->v_typevar,"type")) ) + { + changeval = 0; + if ( v->v_allocatable == 1) + { + if (strcasecmp(v->v_typevar,"type")) + { + // changeval = 1; + // v->v_allocatable = 0; + } + else + { + changeval = 2; + v->v_allocatable = 0; + v->v_pointerdeclare = 1; + } + } + + WriteBeginDeclaration(v, ligne, 1); + WriteTableDeclaration(v, ligne, 1); + tofich (fileout, ligne,1); + if ( changeval >= 1 ) v->v_allocatable = 1; + if ( changeval == 2 ) v->v_pointerdeclare = 0; + } + newvar = newvar->suiv; + } + Save_Length(ligne,45); +} + +void ReWriteDeclarationAndAddTosubroutine_01(listvar *listdecl) +{ + listvar *parcours; + variable *v; + int out; + + if ( insubroutinedeclare ) + { + parcours = listdecl; + while ( parcours ) + { + v = parcours->var; + out = LookingForVariableInList(List_SubroutineArgument_Var, v); + if (out == 0) out = VariableIsInListCommon(parcours, List_Common_Var); + if (out == 0) out = LookingForVariableInList(List_Parameter_Var, v); + if (out == 0) out = LookingForVariableInList(List_FunctionType_Var, v); + if (out == 0) out = LookingForVariableInListGlobal(List_Global_Var, v); + + if (firstpass == 0 && out == 0 && VariableIsParameter == 0 && SaveDeclare == 0) + { + WriteVarDeclaration(v, fortran_out, 1, 1); + } + if (firstpass == 1) + { + if (VariableIsParameter == 0 && SaveDeclare == 0) + { + List_SubroutineDeclaration_Var = insertvar(List_SubroutineDeclaration_Var, v); + } + } + parcours = parcours->suiv; + } + } +} + +void ReWriteDataStatement_0(FILE * filout) +{ + listvar *parcours; + int out; + char ligne[LONG_M]; + char initialvalue[LONG_M]; + + if (insubroutinedeclare == 1) + { + parcours = List_Data_Var_Cur ; + while (parcours) + { + out = VariableIsInListCommon(parcours,List_Common_Var); + if (out) break; + + out = LookingForVariableInListGlobal(List_Global_Var,parcours->var); + if (out) break; + + if (strncasecmp(parcours->var->v_initialvalue,"(/",2)) + { + strcpy(initialvalue,parcours->var->v_initialvalue); + } + else + { + strncpy(initialvalue,&parcours->var->v_initialvalue[2],strlen(parcours->var->v_initialvalue)-4); + strcpy(&initialvalue[strlen(parcours->var->v_initialvalue)-4],"\0"); + } + sprintf(ligne,"data %s/%s/",parcours->var->v_nomvar,initialvalue); + tofich(filout,ligne,1); + + parcours = parcours->suiv; + } + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/decl.h b/V4.0/nemo_sources/ext/AGRIF/LIB/decl.h new file mode 100644 index 0000000000000000000000000000000000000000..8361abf8129727c32c3a717812aa11d4d7fa05c6 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/decl.h @@ -0,0 +1,662 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#define LONG_VNAME 80 // Max length for a variable name +#define LONG_FNAME 1000 // Max length for a file name +#define LONG_C 200 +#define LONG_M 2000 + +#define NB_CAT_VARIABLES 5 + +/******************************************************************************/ +/*********** Declaration of structures used in conv ***************************/ +/******************************************************************************/ + +typedef struct +{ + char first[LONG_M]; + char last[LONG_M]; +} typedim ; /* fortran dimension as 'ndeb:nfin' */ + +typedef struct listdim +{ + typedim dim; + struct listdim *suiv; +} listdim; /* list of the dimensions of a variable */ + +typedef struct variable +{ + char v_typevar[LONG_VNAME]; + char v_nomvar[LONG_VNAME] ; + char v_oldname[LONG_VNAME] ; + char v_dimchar[LONG_VNAME]; + char v_modulename[LONG_VNAME]; + char v_commonname[LONG_VNAME]; + char v_vallengspec[LONG_VNAME]; + char v_nameinttypename[LONG_VNAME]; + char v_commoninfile[LONG_FNAME]; + char v_subroutinename[LONG_VNAME]; + char v_precision[LONG_C]; + char v_initialvalue[LONG_M]; + char v_IntentSpec[LONG_M]; + char v_readedlistdimension[LONG_M]; + int v_nbdim; + int v_common; + int v_positioninblock; + int v_module; + int v_save; + int v_catvar; + int v_VariableIsParameter; + int v_PublicDeclare; + int v_PrivateDeclare; + int v_ExternalDeclare; + int v_pointedvar; + int v_notgrid; + int v_dimensiongiven; + int v_c_star; + int v_indicetabvars; + int v_pointerdeclare; + int v_optionaldeclare; + int v_allocatable; + int v_target; + int v_dimsempty; + listdim *v_dimension; +} variable ; /* type of a variable */ + /* v_typevar : type (integer, real, ...) */ + /* v_nomvar : name of the variable */ + /* v_dimension : list of dimensions of the variable*/ + /* v_nbdim: 1 if the variable is 1d, etc ... */ + /* precision : Name of the variable which */ + /* determine the precision. example : wp in the */ + /* case where REAL(wp) */ + +typedef struct listvar +{ + variable *var ; + struct listvar * suiv; +} listvar ; /* list of variables */ + + +typedef struct listusemodule +{ + char u_usemodule[LONG_VNAME]; + char u_charusemodule[LONG_VNAME]; + char u_cursubroutine[LONG_VNAME]; + char u_modulename[LONG_VNAME]; + int u_firstuse; + struct listusemodule * suiv; +} listusemodule; /* list of names */ + +typedef struct listparameter +{ + char p_name[LONG_M]; + char p_modulename[LONG_M]; + struct listparameter * suiv; +} listparameter ; /* list of names */ + +typedef struct listname +{ + char n_name[LONG_VNAME]; + struct listname* suiv; +} listname ; /* list of names */ + +typedef struct listcouple +{ + char c_namevar[LONG_VNAME]; + char c_namepointedvar[LONG_VNAME]; + struct listcouple * suiv; +} listcouple; /* list of names */ + + +typedef struct listnom +{ + char o_nom[LONG_C]; + char o_module[LONG_VNAME]; + char o_subroutinename[LONG_M]; + int o_val; + listcouple *couple; + struct listnom * suiv; +} listnom; /* list of names */ + + +typedef struct listallocate +{ + char a_nomvar[LONG_C]; + char a_subroutine[LONG_VNAME]; + char a_module[LONG_VNAME]; + struct listallocate * suiv; +} listallocate ; + + +typedef struct listvarpointtovar +{ + char t_usemodule[LONG_VNAME]; + char t_cursubroutine[LONG_VNAME]; + listcouple *t_couple; + struct listvarpointtovar* suiv; +}listvarpointtovar ; /* list of names */ + + +typedef struct listindice +{ + int i_indice; + struct listindice * suiv; +} listindice; /* list of indiced */ + + variable *curvar; + + listvar *List_ModuleUsedInModuleUsed_Var; + listvar *List_ModuleUsed_Var; + listvar *listduplicated; + + listvar *List_GlobalParameter_Var; + listvar *List_Global_Var; + listvar *List_Data_Var; + listvar *List_Data_Var_Cur; + listvar *List_Save_Var; + listvar *List_SubroutineArgument_Var; + listvar *List_SubroutineDeclaration_Var; + listvar *List_UsedInSubroutine_Var; + listvar *List_Parameter_Var; + listvar *List_Dimension_Var; + listvar *List_FunctionType_Var; + listvar *List_NotGridDepend_Var; + listvar *List_Common_Var; + + + listname *List_Pointer_Var; + listname *List_ImplicitNoneSubroutine; + + listusemodule *List_NameOfModuleUsed; + listusemodule *List_Include; + listusemodule *listofmoduletmp; + listusemodule *tmpuselocallist; + + listparameter *List_GlobParamModuleUsedInModuleUsed_Var; + listparameter *List_GlobParamModuleUsed_Var; + + listnom *List_ContainsSubroutine; + listnom *List_Subroutine_For_Alloc; + listnom *listofmodules; + listnom *listofkind; + listnom *List_NameOfModule; + listnom *List_NameOfCommon; + listnom *List_SubroutineWhereAgrifUsed; + + listallocate *List_Allocate_Var; + + listvarpointtovar *List_CouplePointed_Var; + /* variables which are pointed to an other one */ + + listindice *Listofavailableindices; + /* List of available indices in the tabvars table */ + listindice **Listofavailableindices_glob; + + listdim *curdim; + listdim *commondim; + +/******************************************************************************/ +/**************** *** COMMON Variables *** *********************************/ +/******************************************************************************/ + + int positioninblock; + char commonvar[LONG_VNAME]; + char commonblockname[LONG_VNAME]; + +/******************************************************************************/ +/**************** *** AGRIF Variables *** *********************************/ +/******************************************************************************/ + int inagrifcallargument; + int afterpercent; + int sameagrifargument; + int InAgrifParentDef; + char sameagrifname[LONG_VNAME]; +/******************************************************************************/ +/**************** *** VAR DEF Variables *** *******************************/ +/******************************************************************************/ + int indicemaxtabvars[NB_CAT_VARIABLES]; /* Number of variables in the model i.e. last */ + /* indice used in the tabvars table */ + int PublicDeclare; /* Variable has been declared as PUBLIC */ + int PrivateDeclare; /* Variable has been declared as PRIVATE */ + int ExternalDeclare; /* Variable has been declared as EXTERNAL */ + int InitialValueGiven; /* An initial value has been given */ + int Allocatabledeclare; + int Targetdeclare; + int SaveDeclare; + int functiondeclarationisdone; + int pointerdeclare; + int optionaldeclare; + int inside_type_declare; + int VariableIsParameter; + int dimsgiven; + int shouldincludempif; + int c_star; + char DeclType[LONG_VNAME]; + char nameinttypename[LONG_VNAME]; + char nameinttypenameback[LONG_VNAME]; + int GlobalDeclaration; + int GlobalDeclarationType; + char InitValue[LONG_M]; + char IntentSpec[LONG_M]; + char NamePrecision[LONG_C]; + char CharacterSize[LONG_VNAME]; + char vallengspec[LONG_VNAME]; + int isrecursive; + int is_result_present; + +/******************************************************************************/ +/**************** *** CONV Variables *** **********************************/ +/******************************************************************************/ + int dimprob ; /* dimension of the problem : 1 for 1D,2 for 2D, */ + /* 3 for 3D */ + int onlyfixedgrids; /* = 1 if onlyfixedgrids is true */ + int todebug; + int fixedgrids; /* = 1 if fixedgrids is true */ + char nbmaillesX[LONG_VNAME]; // number of cells in the x direction + char nbmaillesY[LONG_VNAME]; // number of cells in the y direction + char nbmaillesZ[LONG_VNAME]; // number of cells in the z direction + int IndicenbmaillesX; + int IndicenbmaillesY; + int IndicenbmaillesZ; + + int inmodulemeet; + int incalldeclare; + int aftercontainsdeclare; /* Signale si l'on vient d'un contains ou non */ + int retour77; + int callagrifinitgrids; + int callmpiinit; + int firstpass; + int pointedvar; + int NbMailleXDefined; + int agrif_parentcall; + int didvariableadded; + int SubloopScalar; /* = 1 we should put in argument of sub_loop */ + /* only */ + /* scalar and not table u(1,1,1) in place of u */ + int inprogramdeclare; + int insubroutinedeclare; + int inmoduledeclare; + int dimsempty; + int created_dimensionlist; + int incontainssubroutine; + + char meetagrifinitgrids[LONG_M]; + char mpiinitvar[LONG_M]; + char toprintglob[LONG_M]; + char tmpvargridname[LONG_M]; + char dependfilename[LONG_FNAME]; + char charusemodule[LONG_VNAME]; + char subofagrifinitgrids[LONG_M]; + char curmodulename[LONG_VNAME]; + char subroutinename[LONG_VNAME]; + char cur_filename[LONG_FNAME]; // Name of the current parsed Fortran file + char config_file[LONG_FNAME]; // Name of conv configuration file (ex: amr.in) + char work_dir[LONG_FNAME]; // Work directory (default: './') + char include_dir[LONG_FNAME]; // Include directory (default: './AGRIF_INC') + char output_dir[LONG_FNAME]; // output directory (default: './AGRIF_MODELFILES') + char input_dir[LONG_FNAME]; // source input directory (default: './') + + FILE *fortran_out; /* Output File */ + FILE *fortran_in; /* Input File */ + FILE *oldfortran_out; + FILE *subloop; + FILE *module_declar; + FILE *allocationagrif; + + long int pos_cur; /* current position in the output file */ + long int pos_curagrifparent; + /* current position in the output file */ + long int pos_curcall; /* current position in the output file */ + long int pos_curuse; /* current position in the output file */ + long int pos_curuseold; /* current position in the output file */ + long int pos_curfunction; /* current position in the output file */ + long int pos_cur_decl; /* current position in the output file */ + long int pos_curdata; /* current position in the output file */ + long int pos_curparameter;/* current position in the output file */ + long int pos_curcommon; /* current position in the output file */ + long int pos_cursave; /* current position in the output file */ + long int pos_curdimension;/* current position in the output file */ + long int pos_curinclude; /* final position of a line in file */ + long int pos_end; /* final position of a line in file */ + long int pos_endsubroutine; + /* final position of a line in file */ + +size_t length_last; +size_t length_first; +size_t length_v_vallengspec; +size_t length_v_commoninfile; +size_t length_v_precision; +size_t length_v_IntentSpec; +size_t length_v_initialvalue; +size_t length_v_readedlistdimension; +size_t length_a_nomvar; +size_t length_toprintglob; +size_t length_tmpvargridname; +size_t length_ligne_Subloop; +size_t length_toprint_utilagrif; +size_t length_toprinttmp_utilchar; +size_t length_ligne_writedecl; +size_t length_newname_toamr; +size_t length_newname_writedecl; +size_t length_ligne_toamr; +size_t length_tmpligne_writedecl; + int value_char_size; + int value_char_size1; + int value_char_size2; + int value_char_size3; + + + int inallocate; + int infixed; + int infree; +/******************************************************************************/ +/*********** Declaration of externals subroutines *****************************/ +/***************************************************** ************************/ +extern char *fortran_text; +/******************************************************************************/ +/*********** convert.y ********************************************************/ +/******************************************************************************/ +extern int main(int argc,char *argv[]); +extern int convert_error(const char *s); +/******************************************************************************/ +/*********** fortran.y ********************************************************/ +/******************************************************************************/ +extern void process_fortran(const char *input_file); +extern int fortran_error(const char *s); +/******************************************************************************/ +/*********** dependfile.c *****************************************************/ +/******************************************************************************/ +extern void Writethedependnbxnbyfile(); +extern void Readthedependnbxnbyfile(); +extern void Writethedependlistofmoduleused(const char *NameTampon ); +extern void Readthedependlistofmoduleused(const char *NameTampon); +extern void WritedependParameterList(const char *NameTampon ); +extern listparameter *ReaddependParameterList(const char *NameTampon, listparameter *listout); +extern void Writethedependfile(const char *NameTampon, listvar *input ); +extern listvar *Readthedependfile(const char *NameTampon , listvar *listout); +extern void Write_Subroutine_For_Alloc(); +extern void Read_Subroutine_For_Alloc(); +extern void Writethedependavailablefile(); +extern void Readthedependavailablefile(); +extern int is_dependfile_created(const char *NameTampon); +extern void Write_val_max(); +extern void Read_val_max(); +/******************************************************************************/ +/*********** DiversListe.c ****************************************************/ +/******************************************************************************/ +extern void Add_Common_var_1(); +extern listnom *Addtolistnom(const char *nom, listnom *listin, int value); +extern listname *Addtolistname(const char *nom, listname *input); +extern int ModuleIsDefineInInputFile(const char *name); +extern void Addmoduletothelisttmp(const char *name); +extern void Add_NameOfModule_1(const char *nom); +extern void Add_NameOfCommon_1(const char *nom, const char *cursubroutinename); +extern void Add_CouplePointed_Var_1(const char *namemodule, listcouple *couple); +extern void Add_Include_1(const char *name); +extern void Add_ImplicitNoneSubroutine_1(); +extern void WriteIncludeDeclaration(FILE* tofile); +extern void Add_Save_Var_1 (const char *name,listdim *d); +extern void Add_Save_Var_dcl_1 (listvar *var); +/******************************************************************************/ +/*********** SubLoopCreation.c ************************************************/ +/******************************************************************************/ +extern void WriteBeginof_SubLoop(); +extern void WriteVariablelist_subloop(char *ligne); +extern void WriteVariablelist_subloop_Call(char **ligne, size_t line_length); +extern void WriteVariablelist_subloop_Def(char *ligne); +extern void WriteHeadofSubroutineLoop(); +extern void closeandcallsubloopandincludeit_0(int suborfun); +extern void closeandcallsubloop_contains_0(); +/******************************************************************************/ +/*********** toamr.c **********************************************************/ +/******************************************************************************/ +extern void WARNING_CharSize(const variable *var); +extern const char * tabvarsname(const variable *var); +extern const char * variablecurgridtabvars(int which_grid); +extern const char * vargridnametabvars(const variable *var, int iorindice); +extern const char * vargridcurgridtabvars(const variable *var, int which_grid); +extern const char * vargridcurgridtabvarswithoutAgrif_Gr(const variable *var); +extern const char * vargridparam(const variable *var); +extern void write_probdimagrif_file(); +extern void write_keysagrif_file(); +extern void write_modtypeagrif_file(); +extern void write_createvarnameagrif_file(variable *v,FILE *createvarname,int *InitEmpty); +extern void write_initialisationsagrif_file(variable *v,FILE *initproc,int *VarnameEmpty); +extern void write_Setnumberofcells_file(); +extern void write_Getnumberofcells_file(); +extern void Write_Alloc_Agrif_Files(); +extern int IndiceInlist(int indic, listindice *listin); +extern void write_allocation_Common_0(); +extern void write_allocation_Global_0(); +extern void creefichieramr(); +/******************************************************************************/ +/*********** UtilAgrif.c ******************************************************/ +/******************************************************************************/ +extern int Vartonumber(const char *tokname); +extern int Agrif_in_Tok_NAME(const char *tokname); +extern void ModifyTheVariableName_0(const char *ident,int lengthname); +extern void Add_SubroutineWhereAgrifUsed_1(const char *sub, const char *mod); +extern void AddUseAgrifUtil_0(FILE *fileout); +extern void AddUseAgrifUtilBeforeCall_0(FILE *fileout); +extern void NotifyAgrifFunction_0(const char *ident); +extern void ModifyTheAgrifFunction_0(const char *ident); +extern void AgriffunctionModify_0(const char *ident,int whichone); +extern void Instanciation_0(const char *ident); +/******************************************************************************/ +/*********** UtilCharacter.c **************************************************/ +/******************************************************************************/ +extern void FindAndChangeNameToTabvars(const char name[LONG_M],char toprint[LONG_M], + listvar * listtosee, int whichone); +extern const char *ChangeTheInitalvaluebyTabvarsName(const char *nom,listvar *listtoread); +extern int IsVariableReal(const char *nom); +extern void IsVarInUseFile(const char *nom); +extern listnom *DecomposeTheNameinlistnom(const char *nom, listnom * listout); +extern void DecomposeTheName(const char *nom); +extern void convert2lower(char *lowername, const char* inputname); +extern int convert2int(const char *name); +/******************************************************************************/ +/*********** UtilFile.c *******************************************************/ +/******************************************************************************/ +extern FILE * open_for_write (const char *filename); +extern FILE * open_for_append (const char *filename); +extern long int setposcur(); +extern long int setposcurname(FILE *fileout); +extern void copyuse_0(const char *namemodule); +extern void copyuseonly_0(const char *namemodule); +/******************************************************************************/ +/*********** UtilFortran.c ****************************************************/ +/******************************************************************************/ +extern void initdimprob(int dimprobmod, const char *nx, const char *ny, const char *nz); +extern int Variableshouldberemoved(const char *nom); +extern int variableisglobal(listvar *curvar, listvar *listin); +extern int VariableIsInListCommon(listvar *curvar,listvar *listin); +extern int VariableIsInList(listvar *curvar,listvar *listin); +extern void variableisglobalinmodule(listcouple *listin, const char *module, + FILE *fileout,long int oldposcuruse); +extern void Write_Word_end_module_0(); +extern void Add_Subroutine_For_Alloc(const char *nom); +extern void Write_Closing_Module(); +extern int IsTabvarsUseInArgument_0(); +extern int ImplicitNoneInSubroutine(); +extern void Add_Pointer_Var_From_List_1(listvar *listin); +extern void Add_Pointer_Var_1(char *nom); +extern int varispointer_0(char *ident); +extern int VariableIsFunction(const char *ident); +extern int varistyped_0(char *ident); +extern void dump_var(const variable* var); +/******************************************************************************/ +/*********** UtilListe.c ******************************************************/ +/******************************************************************************/ +extern void Init_Variable(variable *var); +extern listvar * AddListvarToListvar(listvar *l,listvar *glob, int ValueFirstpass); +extern void CreateAndFillin_Curvar(const char *type, variable *curvar); +// extern void duplicatelistvar(listvar *orig); +extern listdim * insertdim(listdim *lin,typedim nom); +extern void change_dim_char(listdim *lin,listvar * l); +extern int get_num_dims(const listdim *d); +extern variable * createvar(const char *nom, listdim *d); +extern listvar * insertvar(listvar *lin,variable *v); +extern listvar * settype(const char *nom,listvar *lin); +extern void printliste(listvar * lin); +extern int IsinListe(listvar *lin,char *nom); +extern listname *Insertname(listname *lin,char *nom,int sens); +extern listname *concat_listname(listname *l1, listname *l2); +extern void createstringfromlistname(char *ligne, listname *lin); +extern void printname(listname * lin); +extern void removeglobfromlist(listname **lin); +extern void writelistpublic(listname *lin); +extern void Init_List_Data_Var(); +extern void addprecision_derivedfromkind(variable *curvar); +extern int get_cat_var(variable *var); +/******************************************************************************/ +/*********** UtilNotGridDep.c *************************************************/ +/******************************************************************************/ +extern void Add_NotGridDepend_Var_1 (char *name); +extern int VarIsNonGridDepend(char *name); +/******************************************************************************/ +/*********** WorkWithAllocatelist.c *******************************************/ +/******************************************************************************/ +extern void Add_Allocate_Var_1(const char *nom, const char *nommodule); +extern int IsVarAllocatable_0(const char *ident); +/******************************************************************************/ +/*********** WorkWithglobliste.c **********************************************/ +/******************************************************************************/ +extern void Add_Globliste_1(listvar *listtoadd); +extern void Add_SubroutineDeclarationSave_Var_1(listvar *listtoadd); +extern void checkandchangedims(listvar *listsecondpass); +/******************************************************************************/ +/*********** WorkWithlistdatavariable.c ***************************************/ +/******************************************************************************/ +extern void Add_Data_Var_1 (listvar **curlist,char *name,char *values); +extern void Add_Data_Var_Names_01 (listvar **curlist,listname *l1, listname *l2); +/******************************************************************************/ +/*********** WorkWithlistmoduleinfile.c ***************************************/ +/******************************************************************************/ +extern void Save_Length(const char *nom, int whichone); +extern void Save_Length_int(int val, int whichone); +/******************************************************************************/ +/*********** WorkWithlistofmodulebysubroutine.c *******************************/ +/******************************************************************************/ +extern void RecordUseModulesVariables(); +extern void RecordUseModulesUseModulesVariables(); +extern void Add_NameOfModuleUsed_1(char *name); +extern void Addmoduletothelist(const char *name); +extern void WriteUsemoduleDeclaration(const char *cursubroutinename); +/******************************************************************************/ +/*********** WorkWithlistvarindoloop.c ****************************************/ +/******************************************************************************/ +extern void Add_UsedInSubroutine_Var_1 (const char *ident); +extern void ajoutevarindoloop_definedimension (char *name); +extern void ModifyThelistvarindoloop(); +extern void CompleteThelistvarindoloop(); +extern void Merge_Variables(variable *var1,variable *var2); +extern void Update_List_Subroutine_Var(listvar *list_to_modify); +extern void Update_List_Global_Var_From_List_Save_Var(); +extern void Update_List_From_Common_Var(listvar *list_to_modify); +extern void Update_List_Var(listvar *list_to_modify); +extern void List_UsedInSubroutine_Var_Update_From_Module_Used(); +extern void Update_NotGridDepend_Var(listvar *list_to_modify); +extern int LookingForVariableInList(listvar *listin,variable *var); +extern int LookingForVariableInListGlobal(listvar *listin,variable *var); +extern int LookingForVariableInListName(listvar *listin,const char *var); +extern int LookingForVariableInListGlob(listvar *listin,variable *var); +extern int LookingForVariableInListParamGlob(listparameter *listin, variable *var); +extern variable *get_variable_in_list_from_name(listvar *listin, const char *name); +extern void UpdateListDeclarationWithDimensionList(); +extern void Clean_List_UsedInSubroutine_Var(); +extern void Clean_List_ModuleUsed_Var(); +extern void Clean_List_SubroutineDeclaration_Var(); +extern void Clean_List_Global_Var(); +extern void ListClean(); +extern void ListUpdate(); +extern void GiveTypeOfVariables(); +extern void Sort_List_SubroutineArgument_Var(); +extern void IndiceTabvars_Global_Var_Treated(char *nom); +extern void IndiceTabvars_Global_Var_No_Treated(char *nom); +extern void UpdateTheRemainingList(listvar *record); +extern void IndiceTabvars_Common_Var_Treated(char *nom); +extern void IndiceTabvars_Common_Var_No_Treated(char *nom); +extern void IndiceTabvarsIdentification(); +extern void New_Allocate_Subroutine_Is_Necessary(); +extern void New_Allocate_Subroutine_For_Common_Is_Necessary(); +extern void NewModule_Creation_0(); +extern void UpdateList_SubroutineWhereAgrifUsed(); +extern void UpdateList_UsedInSubroutine_With_dimension(); +extern void Affiche(listvar *parcours); +extern int SubInList_ContainsSubroutine(); +extern void update_indicemaxtabvars(variable *var,listindice **Listofindices); +/******************************************************************************/ +/*********** WorkWithParameterlist.c ******************************************/ +/******************************************************************************/ +extern void Add_GlobalParameter_Var_1(listvar *listin); +extern void Add_Parameter_Var_1(listvar *listin); +extern void Add_Dimension_Var_1(listvar *listin); +/******************************************************************************/ +/*********** WorkWithvarofsubroutineliste.c ***********************************/ +/******************************************************************************/ +extern void Add_SubroutineArgument_Var_1(listvar *listtoadd); +extern void Add_FunctionType_Var_1(const char *nom); +// extern void Add_SubroutineDeclaration_Var_1 (listvar *listtoadd); +/******************************************************************************/ +/*********** Writedeclarations.c **********************************************/ +/******************************************************************************/ +extern void WriteBeginDeclaration(variable *v,char ligne[LONG_M],int visibility); +extern void WriteScalarDeclaration(variable *v,char ligne[LONG_M]); +extern void WriteTableDeclaration(variable * v,char ligne[LONG_M],int tmpok); +extern void WriteVarDeclaration( variable *v, FILE *fileout, int value, int visibility ); +extern void WriteLocalParamDeclaration(FILE* tofile); +extern void WriteFunctionDeclaration(FILE* tofile, int value); +extern void WriteSubroutineDeclaration(int value); +extern void WriteArgumentDeclaration_beforecall(); +extern void WriteArgumentDeclaration_Sort(FILE* tofile); +extern listnom * writedeclarationintoamr(listvar *deb_common, FILE *fileout, variable *var, + const char *commonname, listnom *neededparameter, const char *name_common); +extern void writesub_loopdeclaration_scalar(listvar *deb_common, FILE *fileout); +extern void writesub_loopdeclaration_tab(listvar *deb_common, FILE *fileout); +extern void ReWriteDeclarationAndAddTosubroutine_01(listvar *listdecl); +extern void ReWriteDataStatement_0(FILE * filout); +/******************************************************************************/ +/*********** WriteInFile.c ****************************************************/ +/******************************************************************************/ +extern void tofich_reste (FILE * filout, const char *s, int do_returnline); +extern void tofich (FILE * filout, const char *s, int do_returnline); +extern void tofich_blanc (FILE * filout, int size); +extern void RemoveWordSET_0(FILE * filout, long int position, int sizetoremove); +extern void RemoveWordCUR_0(FILE * filout, int sizetoremove); + +/******************************************************************************/ +/*********** WorkWithlistofcoupled.c **********************************************/ +/******************************************************************************/ +extern int variscoupled_0(const char *ident) ; +extern const char * getcoupledname_0(const char *ident); diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/dependfile.c b/V4.0/nemo_sources/ext/AGRIF/LIB/dependfile.c new file mode 100644 index 0000000000000000000000000000000000000000..19d663583610abadd728afca1d0e26cf7d14522e --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/dependfile.c @@ -0,0 +1,974 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + + +/******************************************************************************/ +/* Creation and modification of .dependfile */ +/******************************************************************************/ +/* .dependnbxnby : this file contains tabvars indices of variables*/ +/* given in agrif.in as number of cells */ +/* .dependuse : this file contains all modules used in the */ +/* current file */ +/* .dependparameter : this file contains all parmeters defined in */ +/* the current file */ +/* .depend : this file contains all globals variables */ +/* informations (name, dim, etc ...) */ +/* .dependavailable : this file contains all tabvars indices which */ +/* are not used. */ +/******************************************************************************/ + + +/******************************************************************************/ +/* Writethedependnbxnbyfile */ +/******************************************************************************/ +/* This subroutine is used to create the .dependnbxnby */ +/******************************************************************************/ +/* */ +/* .dependnbxnby */ +/* */ +/* nbmaillesX */ +/* nbmaillesY */ +/* nbmaillesZ */ +/* */ +/******************************************************************************/ +void Writethedependnbxnbyfile() +{ + FILE *dependfileoutput; + listvar *parcours; + int out; + + // We look in 'List_Global_Var' for all the variables of the current file to parse + parcours = List_Global_Var; + out = 0; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesX) ) out = 1; + else parcours = parcours->suiv; + } + if ( out == 0 ) + { + parcours =List_Common_Var; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesX) ) out = 1; + else parcours = parcours->suiv; + } + } + NbMailleXDefined = 0; + if ( out == 1 ) + { + NbMailleXDefined = 1; + sprintf(dependfilename, "%s/.dependnbxnby", work_dir); + dependfileoutput = fopen(dependfilename, "w"); + + fprintf(dependfileoutput,"%d\n",parcours->var->v_indicetabvars); + IndicenbmaillesX = parcours->var->v_indicetabvars; + + if ( dimprob > 1 ) + { + parcours =List_Global_Var; + out = 0; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesY) ) out = 1; + else parcours = parcours->suiv; + } + if ( out == 0 ) + { + parcours =List_Common_Var; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesY) ) out = 1; + else parcours = parcours->suiv; + } + } + if ( out == 1 ) + { + fprintf(dependfileoutput,"%d\n",parcours->var->v_indicetabvars); + IndicenbmaillesY = parcours->var->v_indicetabvars; + } + } + + if ( dimprob > 2 ) + { + parcours =List_Global_Var; + out = 0; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesZ) ) out = 1; + else parcours = parcours->suiv; + } + if ( out == 0 ) + { + parcours =List_Common_Var; + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_nomvar,nbmaillesZ) ) out = 1; + else parcours = parcours->suiv; + } + } + if ( out == 1 ) + { + fprintf(dependfileoutput,"%d\n",parcours->var->v_indicetabvars); + IndicenbmaillesZ = parcours->var->v_indicetabvars; + } + } + + if ( out == 1 ) fclose(dependfileoutput); + } +} + +/******************************************************************************/ +/* Readthedependnbxnbyfile */ +/******************************************************************************/ +/* This subroutine is used to create the .dependnbxnby */ +/******************************************************************************/ +/* */ +/* .dependnbxnby */ +/* */ +/* nbmaillesX */ +/* nbmaillesY */ +/* nbmaillesZ */ +/* */ +/******************************************************************************/ +void Readthedependnbxnbyfile() +{ + FILE *dependfileoutput; + + sprintf(dependfilename, "%s/.dependnbxnby", work_dir); + if ((dependfileoutput = fopen(dependfilename, "r"))!=NULL) + { + fscanf(dependfileoutput,"%d\n",&IndicenbmaillesX); + if ( dimprob > 1 ) fscanf(dependfileoutput,"%d\n",&IndicenbmaillesY); + if ( dimprob > 2 ) fscanf(dependfileoutput,"%d\n",&IndicenbmaillesZ); + fclose(dependfileoutput); + } +} + +/******************************************************************************/ +/* Writethedependlistofmoduleused */ +/******************************************************************************/ +/* This subroutine is used to create the .dependuse */ +/******************************************************************************/ +/* */ +/* .dependuse */ +/* */ +/* mod1 */ +/* mod2 */ +/* */ +/******************************************************************************/ +void Writethedependlistofmoduleused(const char *NameTampon ) +{ + FILE *dependfileoutput; + listusemodule *parcours; + char lowername[LONG_VNAME]; + + if ( ! List_NameOfModuleUsed ) return; + + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_use%s", work_dir, lowername); + dependfileoutput = fopen(dependfilename, "w"); + + parcours = List_NameOfModuleUsed; + while (parcours) + { + if ( !strcasecmp(lowername,parcours->u_modulename) && + !strcasecmp(parcours->u_cursubroutine,"") ) + { + // We look in 'List_NameOfModuleUsed' for all the variables of the current file to parse + fprintf(dependfileoutput,"%s\n",parcours->u_usemodule); + } + parcours = parcours->suiv; + } + fclose(dependfileoutput); +} + +/******************************************************************************/ +/* Readthedependlistofmoduleused */ +/******************************************************************************/ +/* This subroutine is used to create the .dependuse */ +/******************************************************************************/ +/* */ +/* .dependuse */ +/* */ +/* mod1 */ +/* mod2 */ +/* */ +/******************************************************************************/ +void Readthedependlistofmoduleused(const char *NameTampon) +{ + FILE *dependfileoutput; + listusemodule *parcours; + char lowername[LONG_VNAME]; + + tmpuselocallist = (listusemodule *)NULL; + + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_use%s", work_dir, lowername); + + if ((dependfileoutput = fopen(dependfilename, "r"))!=NULL) + { + /* if the file exist we should verify that this file has changed */ + while (!feof(dependfileoutput)) + { + parcours=(listusemodule *)calloc(1,sizeof(listusemodule)); + fscanf(dependfileoutput,"%s\n",parcours->u_usemodule); + + parcours->suiv = tmpuselocallist; + tmpuselocallist = parcours; + + parcours = NULL; + } + fclose(dependfileoutput); + } +} + + +/******************************************************************************/ +/* WritedependParameterList */ +/******************************************************************************/ +/* This subroutine is used to create the .dependparameter */ +/******************************************************************************/ +/* */ +/* .dependparameter */ +/* */ +/* mod1 */ +/* mod2 */ +/* */ +/******************************************************************************/ +void WritedependParameterList(const char *NameTampon ) +{ + FILE *dependfileoutput; + listvar *parcours; + char lowername[LONG_VNAME]; + + if ( List_GlobalParameter_Var ) + { + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_paramater_%s", work_dir, lowername); + + dependfileoutput = fopen(dependfilename, "w"); + parcours = List_GlobalParameter_Var; + while (parcours) + { + if ( !strcasecmp(lowername, parcours->var->v_modulename) ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_nomvar); + fprintf(dependfileoutput,"%s\n",parcours->var->v_modulename); + } + parcours = parcours->suiv; + } + fclose(dependfileoutput); + } +} + + +/******************************************************************************/ +/* ReaddependParameterList */ +/******************************************************************************/ +/* This subroutine is used to create the .dependparameter */ +/******************************************************************************/ +/* */ +/* .dependparameter */ +/* */ +/* mod1 */ +/* mod2 */ +/* */ +/******************************************************************************/ +listparameter *ReaddependParameterList(const char *NameTampon,listparameter *listout) +{ + FILE *dependfileoutput; + listparameter *parcours; + char lowername[LONG_VNAME]; + + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_paramater_%s", work_dir, lowername); + + if ((dependfileoutput = fopen(dependfilename,"r"))!=NULL) + { + /* if the file exist we should verify that this file has changed */ + while (!feof(dependfileoutput)) + { + parcours=(listparameter *)calloc(1,sizeof(listparameter)); + fscanf(dependfileoutput,"%s\n",parcours->p_name); + fscanf(dependfileoutput,"%s\n",parcours->p_modulename); + + parcours->suiv = listout; + listout = parcours; + + parcours = NULL; + } + fclose(dependfileoutput); + } + return listout; +} + +/******************************************************************************/ +/* Writethedependfile */ +/******************************************************************************/ +/* This subroutine is used to create the .depend */ +/******************************************************************************/ +/* */ +/* .depend */ +/* */ +/* REAL */ +/* Variable */ +/* char dimension or T */ +/* table dimension */ +/* is type given */ +/* precision or T */ +/* initial value or T */ +/* indice in the tabvars */ +/* listdimension or T */ +/* ------------------------- */ +/* */ +/******************************************************************************/ +void Writethedependfile(const char *NameTampon, listvar *input ) +{ + FILE *dependfileoutput; + listvar *parcours; + listdim *dims; + char ligne[LONG_M]; + char listdimension[LONG_M]; + char curname[LONG_M]; + char lowername[LONG_VNAME]; + int out; + + if ( input ) + { + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_%s", work_dir, lowername); + + dependfileoutput = fopen(dependfilename,"w"); + // We look in 'input' for all the variables of the current file to parse + parcours =input; + out = 0; + strcpy(curname,""); + while (parcours && out == 0 ) + { + if ( !strcasecmp(parcours->var->v_modulename, lowername) || + !strcasecmp(parcours->var->v_commonname, lowername) ) + { + /* */ + if ( strcasecmp(curname,"") && + !strcasecmp(curname,parcours->var->v_nomvar) ) out = 1 ; + if ( !strcasecmp(curname,"") ) strcpy(curname,parcours->var->v_nomvar); + /* */ + if ( out == 0 ) + { + /********** TYPEVAR ************************************************/ + fprintf(dependfileoutput,"%s\n",parcours->var->v_typevar); + /********** CATVAR ************************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_catvar); + /********** NOMVAR *************************************************/ + fprintf(dependfileoutput,"%s\n",parcours->var->v_nomvar); + /********** DIMCHAR ************************************************/ + if ( strcasecmp(parcours->var->v_dimchar, "") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_dimchar); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** COMMONINFILE *******************************************/ + if ( strcasecmp(parcours->var->v_commoninfile,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_commoninfile); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** COMMONNAME *********************************************/ + if ( strcasecmp(parcours->var->v_commonname,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_commonname); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** MODULENAME *********************************************/ + if ( strcasecmp(parcours->var->v_modulename,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_modulename); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** NBDIM **************************************************/ +/* fprintf(dependfileoutput,"%d\n",parcours->var->v_nbdim);*/ + /********** DIMENSIONGIVEN *****************************************/ +/* fprintf(dependfileoutput,"%d\n",parcours->var->v_dimensiongiven);*/ + /********** ALLOCATABLE ********************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_allocatable); + /********** TARGET ********************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_target); + /********** POINTERDECLARE *****************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_pointerdeclare); + /********** PRECISION **********************************************/ + if ( strcasecmp(parcours->var->v_precision,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_precision); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** INITIALVALUE *******************************************/ +/* if ( strcasecmp(parcours->var->v_initialvalue,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_initialvalue); + } + else + { + fprintf(dependfileoutput,"T\n"); + }*/ + /********** NAMEINTYPENAME *****************************************/ + if ( strcasecmp(parcours->var->v_nameinttypename,"") ) + { + fprintf(dependfileoutput,"%s\n",parcours->var->v_nameinttypename); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /********** PRIVATE *****************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_PrivateDeclare); + + /********** INDICETABVARS ******************************************/ + fprintf(dependfileoutput,"%d\n",parcours->var->v_indicetabvars); + /********** READEDLISTDIMENSION ************************************/ + if ( parcours->var->v_dimensiongiven == 1 ) + { + dims = parcours->var->v_dimension; + strcpy(listdimension,""); + while (dims) + { + sprintf(ligne,"%s:%s",dims->dim.first,dims->dim.last); + strcat(listdimension,ligne); + if ( dims->suiv ) + { + strcat(listdimension,","); + } + dims = dims->suiv; + } + Save_Length(listdimension,15); + fprintf(dependfileoutput,"%s\n",listdimension); + } + else + { + fprintf(dependfileoutput,"T\n"); + } + /*******************************************************************/ + fprintf(dependfileoutput,"------------------------\n"); + } + } + parcours = parcours->suiv; + } + fclose(dependfileoutput); + } +} + +/******************************************************************************/ +/* Readthedependfile */ +/******************************************************************************/ +/* This subroutine is used to read the .dependfile and to insert new */ +/* information in the listout list. */ +/******************************************************************************/ +/* */ +/* .dependmodule --------> = list of var */ +/* */ +/* not.dependmodule --------> */ +/* */ +/******************************************************************************/ +listvar *Readthedependfile(const char *NameTampon , listvar *listout) +{ + FILE *dependfileoutput; + listvar *parcours0; + listvar *parcours; + listvar *parcoursprec; + char nothing[LONG_M]; + char lowername[LONG_VNAME]; + size_t i; + + parcoursprec = (listvar *)NULL; + + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_%s", work_dir, lowername); + + if ((dependfileoutput = fopen(dependfilename, "r"))==NULL) + { + /* if the file doesn't exist it means that it is the first time */ + /* we tried to parse this file */ + } + else + { + /* if the file exist we should verify that this file has changed */ + while (!feof(dependfileoutput)) + { + parcours=(listvar *)calloc(1,sizeof(listvar)); + parcours->var=(variable *)calloc(1,sizeof(variable)); + /* */ + Init_Variable(parcours->var); + /* */ + /********** TYPEVAR ************************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_typevar); + /********** CATVAR ************************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_catvar); + /********** NOMVAR *************************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_nomvar); + /********** DIMCHAR ************************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_dimchar); + if ( !strcasecmp(parcours->var->v_dimchar,"T") ) + { + strcpy(parcours->var->v_dimchar,""); + } + /********** COMMONINFILE *******************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_commoninfile); + if ( !strcasecmp(parcours->var->v_commoninfile,"T") ) + { + strcpy(parcours->var->v_commoninfile,""); + } + /********** COMMONNAME *********************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_commonname); + if ( !strcasecmp(parcours->var->v_commonname,"T") ) + { + strcpy(parcours->var->v_commonname,""); + } + /********** MODULENAME *********************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_modulename); + + if ( !strcasecmp(parcours->var->v_modulename,"T") ) + { + strcpy(parcours->var->v_modulename,""); + } + + + /********** NBDIM **************************************************/ +/* fscanf(dependfileoutput,"%d\n",&parcours->var->v_nbdim);*/ + /********** DIMENSIONGIVEN *****************************************/ +/* fscanf(dependfileoutput,"%d\n",&parcours->var->v_dimensiongiven);*/ + /********** ALLOCATABLE ********************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_allocatable); + if ( parcours->var->v_allocatable == 1 ) + { + Add_Allocate_Var_1(parcours->var->v_nomvar, parcours->var->v_commonname); + } + /********** TARGET ********************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_target); + + /********** POINTERDECLARE *****************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_pointerdeclare); + if ( parcours->var->v_pointerdeclare == 1 ) + { + Add_Pointer_Var_1(parcours->var->v_nomvar); + } + /********** PRECISION **********************************************/ + fscanf(dependfileoutput,"%[^\n] \n",parcours->var->v_precision); + if ( !strcasecmp(parcours->var->v_precision,"T") ) + { + strcpy(parcours->var->v_precision,""); + } + /********** INITIALVALUE *******************************************/ +/* fscanf(dependfileoutput,"%[^\n] \n",parcours->var->v_initialvalue); + if ( !strcasecmp(parcours->var->v_initialvalue,"T") ) + { + strcpy(parcours->var->v_initialvalue,""); + }*/ + /********** NAMEINTYPENAME *****************************************/ + fscanf(dependfileoutput,"%[^\n] \n",parcours->var->v_nameinttypename); + if ( !strcasecmp(parcours->var->v_nameinttypename,"T") ) + { + strcpy(parcours->var->v_nameinttypename,""); + } + /********** PRIVATE *****************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_PrivateDeclare); + + /********** INDICETABVARS ******************************************/ + fscanf(dependfileoutput,"%d\n",&parcours->var->v_indicetabvars); + /********** READEDLISTDIMENSION ************************************/ + fscanf(dependfileoutput,"%s\n",parcours->var->v_readedlistdimension); + if ( !strcasecmp(parcours->var->v_readedlistdimension,"T") ) + { + strcpy(parcours->var->v_readedlistdimension,""); + } + else + { + parcours->var->v_dimensiongiven = 1; + parcours->var->v_nbdim = 1; + i = 1; + /* */ + while ( i < strlen(parcours->var->v_readedlistdimension) ) + { + if ( parcours->var->v_readedlistdimension[i] == ',' ) + { + parcours->var->v_nbdim = parcours->var->v_nbdim + 1 ; + } + /* */ + i=i+1; + } + } + /*******************************************************************/ + fscanf(dependfileoutput,"%s\n",nothing); + parcours->suiv = NULL; + if (parcours->var->v_PrivateDeclare == 0) + { + if ( !listout ) + { + listout = parcours; + parcoursprec = parcours; + } + else + { + if ( parcoursprec ) + { + parcoursprec->suiv = parcours; + parcoursprec = parcours; + } + else + { + parcours0 = listout; + while ( parcours0->suiv ) parcours0=parcours0->suiv; + parcours0->suiv = parcours; + parcoursprec = parcours0->suiv; + } + } + } + parcours = NULL; + } + fclose(dependfileoutput); + } + return listout; +} + +void Write_Subroutine_For_Alloc() +{ + FILE *dependfileoutput; + listnom *parcours; + + if ( List_Subroutine_For_Alloc ) + { + sprintf(dependfilename, "%s/.dependAllocAgrif", work_dir); + + if ((dependfileoutput=fopen(dependfilename, "w"))!=NULL) + { + parcours = List_Subroutine_For_Alloc; + while (parcours) + { + fprintf(dependfileoutput,"%s\n",parcours->o_nom); + parcours = parcours->suiv; + } + fclose(dependfileoutput); + } + } +} + +void Read_Subroutine_For_Alloc() +{ + FILE *dependfileoutput; + listnom *parcours; + listnom *ref; + + ref = (listnom*) NULL; + sprintf(dependfilename, "%s/.dependAllocAgrif", work_dir); + + if ( (dependfileoutput=fopen(dependfilename, "r")) != NULL ) + { + List_Subroutine_For_Alloc = (listnom*) NULL; + while ( !feof(dependfileoutput) ) + { + parcours = (listnom*) calloc(1,sizeof(listnom)); + strcpy(parcours->o_nom,""); + + fscanf(dependfileoutput,"%s\n",parcours->o_nom); + parcours->suiv = NULL; + + if ( !List_Subroutine_For_Alloc ) + { + List_Subroutine_For_Alloc = parcours; + } + else + { + ref->suiv = parcours; + } + ref = parcours; + } + fclose(dependfileoutput); + } +} + +/******************************************************************************/ +/* Writethedependavailablefile */ +/******************************************************************************/ +/* This subroutine is used to write the .dependfileavailable file */ +/******************************************************************************/ +/* */ +/* .dependavailable */ +/* tabvars(1) = var1 */ +/* tabvars(3) = var1 2 */ +/* tabvars(4) = var1 =====> 5 */ +/* tabvars(6) = var1 */ +/* tabvars(7) = var1 */ +/* */ +/* */ +/* */ +/******************************************************************************/ +void Writethedependavailablefile() +{ + FILE *dependfileoutput; + listindice *parcours; + int i; + + sprintf(dependfilename, "%s/.dependavailable", work_dir); + + if ((dependfileoutput=fopen(dependfilename, "w"))!=NULL) + { + /* We are looking for all the indices of the Listofavailableindices */ + for (i=0;ii_indice != 0 ) + { + fprintf(dependfileoutput,"%d %d\n",i,parcours->i_indice); + } + parcours = parcours->suiv; + } + } + fclose(dependfileoutput); + } +} + +/******************************************************************************/ +/* Readthedependavailablefile */ +/******************************************************************************/ +/* This subroutine is used to read the .dependfileavailable file */ +/******************************************************************************/ +/* */ +/* .dependavailable */ +/* tabvars(1) = var1 */ +/* tabvars(3) = var1 2 */ +/* tabvars(4) = var1 =====> 5 ==> Listofavailableindices */ +/* tabvars(6) = var1 */ +/* tabvars(7) = var1 */ +/* */ +/* */ +/* */ +/******************************************************************************/ +void Readthedependavailablefile() +{ + FILE *dependfileoutput; + listindice *parcours; + int current_cat; + + sprintf(dependfilename, "%s/.dependavailable", work_dir); + + if ((dependfileoutput=fopen(dependfilename, "r"))!=NULL) + { + /* We are looking for all the indices of the Listofavailableindices */ + Listofavailableindices_glob = (listindice **) calloc(NB_CAT_VARIABLES,sizeof(listindice *)); + while (!feof(dependfileoutput)) + { + parcours=(listindice *)calloc(1,sizeof(listindice)); + fscanf(dependfileoutput,"%d %d\n",¤t_cat,&parcours->i_indice); + if ( parcours->i_indice != 0 && parcours->i_indice < 10000000 ) + { + parcours -> suiv = Listofavailableindices_glob[current_cat]; + Listofavailableindices_glob[current_cat] = parcours; + } + else + { + free(parcours); + } + } + fclose(dependfileoutput); + } +} + + +/******************************************************************************/ +/* is_dependfile_created */ +/******************************************************************************/ +/* This subroutine is used to know if the .depend exist */ +/* it means if the file has been ever parsed */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +int is_dependfile_created(const char *NameTampon) +{ + FILE *dependfileoutput; + char lowername[LONG_VNAME]; + + convert2lower(lowername, NameTampon); + sprintf(dependfilename, "%s/.depend_%s", work_dir, lowername); + + dependfileoutput = fopen(dependfilename, "r"); + + if ( (dependfileoutput = fopen(dependfilename, "r")) != NULL ) + { + fclose(dependfileoutput); + return 1; + } + else + return 0; +} + +void Write_val_max() +{ + FILE *dependfileoutput; + + sprintf(dependfilename, "%s/.dependvalmax", work_dir); + + if ((dependfileoutput=fopen(dependfilename, "w"))!=NULL) + { + fprintf(dependfileoutput,"length_last\n"); + fprintf(dependfileoutput,"%lu\n", length_last); + fprintf(dependfileoutput,"length_first\n"); + fprintf(dependfileoutput,"%lu\n", length_first); + fprintf(dependfileoutput,"length_v_vallengspec\n"); + fprintf(dependfileoutput,"%lu\n", length_v_vallengspec); + fprintf(dependfileoutput,"length_v_commoninfile\n"); + fprintf(dependfileoutput,"%lu\n", length_v_commoninfile); + fprintf(dependfileoutput,"length_v_precision\n"); + fprintf(dependfileoutput,"%lu\n", length_v_precision); + fprintf(dependfileoutput,"length_v_IntentSpec\n"); + fprintf(dependfileoutput,"%lu\n", length_v_IntentSpec); + fprintf(dependfileoutput,"length_v_initialvalue\n"); + fprintf(dependfileoutput,"%lu\n", length_v_initialvalue); + fprintf(dependfileoutput,"length_v_readedlistdimension\n"); + fprintf(dependfileoutput,"%lu\n", length_v_readedlistdimension); + fprintf(dependfileoutput,"length_a_nomvar\n"); + fprintf(dependfileoutput,"%lu\n", length_a_nomvar); + fprintf(dependfileoutput,"length_toprintglob\n"); + fprintf(dependfileoutput,"%lu\n", length_toprintglob); + fprintf(dependfileoutput,"Size_char0d\n"); + fprintf(dependfileoutput,"%d\n",value_char_size); + fprintf(dependfileoutput,"Size_char1d\n"); + fprintf(dependfileoutput,"%d\n",value_char_size1); + fprintf(dependfileoutput,"Size_char2d\n"); + fprintf(dependfileoutput,"%d\n",value_char_size2); + fprintf(dependfileoutput,"Size_char3d\n"); + fprintf(dependfileoutput,"%d\n",value_char_size3); + fprintf(dependfileoutput,"length_tmpvargridname\n"); + fprintf(dependfileoutput,"%lu\n", length_tmpvargridname); + fprintf(dependfileoutput,"length_ligne_Subloop\n"); + fprintf(dependfileoutput,"%lu\n", length_ligne_Subloop); + fprintf(dependfileoutput,"length_toprint_toamr\n"); + fprintf(dependfileoutput,"%lu\n", length_toprint_utilagrif); + fprintf(dependfileoutput,"length_toprinttmp_utilchar\n"); + fprintf(dependfileoutput,"%lu\n", length_toprinttmp_utilchar); + fprintf(dependfileoutput,"length_ligne_writedecl\n"); + fprintf(dependfileoutput,"%lu\n", length_ligne_writedecl); + fprintf(dependfileoutput,"length_newname_toamr\n"); + fprintf(dependfileoutput,"%lu\n", length_newname_toamr); + fprintf(dependfileoutput,"length_newname_writedecl\n"); + fprintf(dependfileoutput,"%lu\n", length_newname_writedecl); + fprintf(dependfileoutput,"length_ligne_toamr\n"); + fprintf(dependfileoutput,"%lu\n", length_ligne_toamr); + fprintf(dependfileoutput,"length_tmpligne_writedecl\n"); + fprintf(dependfileoutput,"%lu\n", length_tmpligne_writedecl); + + fclose(dependfileoutput); + } +} + + +void Read_val_max() +{ + char nothing[LONG_M]; + FILE *dependfileoutput; + + sprintf(dependfilename, "%s/.dependvalmax", work_dir); + + if ((dependfileoutput=fopen(".dependvalmax","r"))!=NULL) + { + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_last); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_first); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_vallengspec); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_commoninfile); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_precision); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_IntentSpec); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_initialvalue); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_v_readedlistdimension); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_a_nomvar); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_toprintglob); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%d\n", &value_char_size); + fscanf(dependfileoutput,"%s\n", nothing); + fscanf(dependfileoutput,"%d\n", &value_char_size1); + fscanf(dependfileoutput,"%s\n", nothing); + fscanf(dependfileoutput,"%d\n", &value_char_size2); + fscanf(dependfileoutput,"%s\n", nothing); + fscanf(dependfileoutput,"%d\n", &value_char_size3); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_tmpvargridname); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_ligne_Subloop); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_toprint_utilagrif); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_toprinttmp_utilchar); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_ligne_writedecl); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_newname_toamr); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_newname_writedecl); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_ligne_toamr); + fscanf(dependfileoutput,"%s\n",nothing); + fscanf(dependfileoutput,"%lu\n", &length_tmpligne_writedecl); + + fclose(dependfileoutput); + } +} diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/fortran.c b/V4.0/nemo_sources/ext/AGRIF/LIB/fortran.c new file mode 100644 index 0000000000000000000000000000000000000000..3b5f8c55567e351cbdb1e61a387f64aafe375856 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/fortran.c @@ -0,0 +1,10440 @@ +/* A Bison parser, made by GNU Bison 2.7. */ + +/* Bison implementation for Yacc-like parsers in C + + Copyright (C) 1984, 1989-1990, 2000-2012 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* C LALR(1) parser skeleton written by Richard Stallman, by + simplifying the original so-called "semantic" parser. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +/* Identify Bison output. */ +#define YYBISON 1 + +/* Bison version. */ + +/* Skeleton name. */ +#define YYSKELETON_NAME "yacc.c" + +/* Pure parsers. */ +#define YYPURE 0 + +/* Push parsers. */ +#define YYPUSH 0 + +/* Pull parsers. */ +#define YYPULL 1 + + +/* Substitute the variable and function names. */ +#define yyparse fortran_parse +#define yylex fortran_lex +#define yyerror fortran_error +#define yylval fortran_lval +#define yychar fortran_char +#define yydebug fortran_debug +#define yynerrs fortran_nerrs + +/* Copy the first part of user declarations. */ +/* Line 371 of yacc.c */ +#line 36 "fortran.y" + +#define YYMAXDEPTH 1000 +#include +#include +#include +#include "decl.h" + +extern int line_num_input; +extern char *fortran_text; + +char c_selectorname[LONG_M]; +char ligne[LONG_M]; +char truename[LONG_VNAME]; +char identcopy[LONG_VNAME]; +int c_selectorgiven=0; +listvar *curlistvar; +typedim c_selectordim; +listcouple *coupletmp; +int removeline=0; +listvar *test; + +int fortran_error(const char *s) +{ + printf("%s line %d, file %s motclef = |%s|\n", s, line_num_input, cur_filename, fortran_text); + exit(1); +} + + +/* Line 371 of yacc.c */ +#line 104 "fortran.tab.c" + +# ifndef YY_NULL +# if defined __cplusplus && 201103L <= __cplusplus +# define YY_NULL nullptr +# else +# define YY_NULL 0 +# endif +# endif + +/* Enabling verbose error messages. */ +#ifdef YYERROR_VERBOSE +# undef YYERROR_VERBOSE +# define YYERROR_VERBOSE 1 +#else +# define YYERROR_VERBOSE 0 +#endif + + +/* Enabling traces. */ +#ifndef YYDEBUG +# define YYDEBUG 1 +#endif +#if YYDEBUG +extern int fortran_debug; +#endif + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + TOK_NEQV = 258, + TOK_EQV = 259, + TOK_XOR = 260, + TOK_OR = 261, + TOK_AND = 262, + TOK_NOT = 263, + TOK_NE = 264, + TOK_EQ = 265, + TOK_GE = 266, + TOK_LE = 267, + TOK_GT = 268, + TOK_LT = 269, + TOK_DSLASH = 270, + TOK_SLASH = 271, + TOK_DASTER = 272, + TOK_SEMICOLON = 273, + TOK_PARAMETER = 274, + TOK_RESULT = 275, + TOK_ONLY = 276, + TOK_INCLUDE = 277, + TOK_SUBROUTINE = 278, + TOK_PROGRAM = 279, + TOK_FUNCTION = 280, + TOK_FORMAT = 281, + TOK_MAX = 282, + TOK_TANH = 283, + TOK_WHERE = 284, + TOK_ELSEWHEREPAR = 285, + TOK_ELSEWHERE = 286, + TOK_ENDWHERE = 287, + TOK_MAXVAL = 288, + TOK_TRIM = 289, + TOK_NULL_PTR = 290, + TOK_SUM = 291, + TOK_SQRT = 292, + TOK_CASE = 293, + TOK_SELECTCASE = 294, + TOK_FILE = 295, + TOK_UNIT = 296, + TOK_FMT = 297, + TOK_NML = 298, + TOK_END = 299, + TOK_EOR = 300, + TOK_ERR = 301, + TOK_EXIST = 302, + TOK_MIN = 303, + TOK_FLOAT = 304, + TOK_EXP = 305, + TOK_COS = 306, + TOK_COSH = 307, + TOK_ACOS = 308, + TOK_NINT = 309, + TOK_CYCLE = 310, + TOK_SIN = 311, + TOK_SINH = 312, + TOK_ASIN = 313, + TOK_EQUIVALENCE = 314, + TOK_BACKSPACE = 315, + TOK_LOG = 316, + TOK_TAN = 317, + TOK_ATAN = 318, + TOK_RECURSIVE = 319, + TOK_ABS = 320, + TOK_MOD = 321, + TOK_SIGN = 322, + TOK_MINLOC = 323, + TOK_MAXLOC = 324, + TOK_EXIT = 325, + TOK_MINVAL = 326, + TOK_PUBLIC = 327, + TOK_PRIVATE = 328, + TOK_ALLOCATABLE = 329, + TOK_RETURN = 330, + TOK_THEN = 331, + TOK_ELSEIF = 332, + TOK_ELSE = 333, + TOK_ENDIF = 334, + TOK_PRINT = 335, + TOK_PLAINGOTO = 336, + TOK_LOGICALIF = 337, + TOK_PLAINDO = 338, + TOK_CONTAINS = 339, + TOK_ENDDO = 340, + TOK_MODULE = 341, + TOK_ENDMODULE = 342, + TOK_WHILE = 343, + TOK_CONCURRENT = 344, + TOK_ALLOCATE = 345, + TOK_OPEN = 346, + TOK_CLOSE = 347, + TOK_INQUIRE = 348, + TOK_WRITE = 349, + TOK_FLUSH = 350, + TOK_READ = 351, + TOK_REWIND = 352, + TOK_DEALLOCATE = 353, + TOK_NULLIFY = 354, + TOK_DIMENSION = 355, + TOK_ENDSELECT = 356, + TOK_EXTERNAL = 357, + TOK_INTENT = 358, + TOK_INTRINSIC = 359, + TOK_NAMELIST = 360, + TOK_DEFAULT = 361, + TOK_OPTIONAL = 362, + TOK_POINTER = 363, + TOK_CONTINUE = 364, + TOK_SAVE = 365, + TOK_TARGET = 366, + TOK_IMPLICIT = 367, + TOK_NONE = 368, + TOK_CALL = 369, + TOK_STAT = 370, + TOK_POINT_TO = 371, + TOK_COMMON = 372, + TOK_GLOBAL = 373, + TOK_LEFTAB = 374, + TOK_RIGHTAB = 375, + TOK_PAUSE = 376, + TOK_PROCEDURE = 377, + TOK_STOP = 378, + TOK_REAL8 = 379, + TOK_FOURDOTS = 380, + TOK_HEXA = 381, + TOK_ASSIGNTYPE = 382, + TOK_OUT = 383, + TOK_INOUT = 384, + TOK_IN = 385, + TOK_USE = 386, + TOK_TRUE = 387, + TOK_FALSE = 388, + TOK_LABEL = 389, + TOK_TYPE = 390, + TOK_TYPEPAR = 391, + TOK_ENDTYPE = 392, + TOK_REAL = 393, + TOK_INTEGER = 394, + TOK_LOGICAL = 395, + TOK_DOUBLEPRECISION = 396, + TOK_ENDSUBROUTINE = 397, + TOK_ENDFUNCTION = 398, + TOK_ENDPROGRAM = 399, + TOK_ENDUNIT = 400, + TOK_CHARACTER = 401, + TOK_CHAR_CONSTANT = 402, + TOK_CHAR_CUT = 403, + TOK_DATA = 404, + TOK_CHAR_MESSAGE = 405, + TOK_CSTREAL = 406, + TOK_COMPLEX = 407, + TOK_DOUBLECOMPLEX = 408, + TOK_NAME = 409, + TOK_CSTINT = 410 + }; +#endif + + +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef union YYSTYPE +{ +/* Line 387 of yacc.c */ +#line 65 "fortran.y" + + char na[LONG_M]; + listdim *d; + listvar *l; + listcouple *lc; + listname *lnn; + typedim dim1; + variable *v; + + +/* Line 387 of yacc.c */ +#line 310 "fortran.tab.c" +} YYSTYPE; +# define YYSTYPE_IS_TRIVIAL 1 +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ +# define YYSTYPE_IS_DECLARED 1 +#endif + +extern YYSTYPE fortran_lval; + +#ifdef YYPARSE_PARAM +#if defined __STDC__ || defined __cplusplus +int fortran_parse (void *YYPARSE_PARAM); +#else +int fortran_parse (); +#endif +#else /* ! YYPARSE_PARAM */ +#if defined __STDC__ || defined __cplusplus +int fortran_parse (void); +#else +int fortran_parse (); +#endif +#endif /* ! YYPARSE_PARAM */ + + + +/* Copy the second part of user declarations. */ + +/* Line 390 of yacc.c */ +#line 338 "fortran.tab.c" + +#ifdef short +# undef short +#endif + +#ifdef YYTYPE_UINT8 +typedef YYTYPE_UINT8 yytype_uint8; +#else +typedef unsigned char yytype_uint8; +#endif + +#ifdef YYTYPE_INT8 +typedef YYTYPE_INT8 yytype_int8; +#elif (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +typedef signed char yytype_int8; +#else +typedef short int yytype_int8; +#endif + +#ifdef YYTYPE_UINT16 +typedef YYTYPE_UINT16 yytype_uint16; +#else +typedef unsigned short int yytype_uint16; +#endif + +#ifdef YYTYPE_INT16 +typedef YYTYPE_INT16 yytype_int16; +#else +typedef short int yytype_int16; +#endif + +#ifndef YYSIZE_T +# ifdef __SIZE_TYPE__ +# define YYSIZE_T __SIZE_TYPE__ +# elif defined size_t +# define YYSIZE_T size_t +# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned int +# endif +#endif + +#define YYSIZE_MAXIMUM ((YYSIZE_T) -1) + +#ifndef YY_ +# if defined YYENABLE_NLS && YYENABLE_NLS +# if ENABLE_NLS +# include /* INFRINGES ON USER NAME SPACE */ +# define YY_(Msgid) dgettext ("bison-runtime", Msgid) +# endif +# endif +# ifndef YY_ +# define YY_(Msgid) Msgid +# endif +#endif + +/* Suppress unused-variable warnings by "using" E. */ +#if ! defined lint || defined __GNUC__ +# define YYUSE(E) ((void) (E)) +#else +# define YYUSE(E) /* empty */ +#endif + +/* Identity function, used to suppress warnings about constant conditions. */ +#ifndef lint +# define YYID(N) (N) +#else +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static int +YYID (int yyi) +#else +static int +YYID (yyi) + int yyi; +#endif +{ + return yyi; +} +#endif + +#if ! defined yyoverflow || YYERROR_VERBOSE + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# ifdef YYSTACK_USE_ALLOCA +# if YYSTACK_USE_ALLOCA +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# elif defined __BUILTIN_VA_ARG_INCR +# include /* INFRINGES ON USER NAME SPACE */ +# elif defined _AIX +# define YYSTACK_ALLOC __alloca +# elif defined _MSC_VER +# include /* INFRINGES ON USER NAME SPACE */ +# define alloca _alloca +# else +# define YYSTACK_ALLOC alloca +# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ + /* Use EXIT_SUCCESS as a witness for stdlib.h. */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 +# endif +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) +# ifndef YYSTACK_ALLOC_MAXIMUM + /* The OS might guarantee only one guard page at the bottom of the stack, + and a page size can be as small as 4096 bytes. So we cannot safely + invoke alloca (N) if N exceeds 4096. Use a slightly smaller number + to allow for a few compiler-allocated temporary stack slots. */ +# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ +# endif +# else +# define YYSTACK_ALLOC YYMALLOC +# define YYSTACK_FREE YYFREE +# ifndef YYSTACK_ALLOC_MAXIMUM +# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM +# endif +# if (defined __cplusplus && ! defined EXIT_SUCCESS \ + && ! ((defined YYMALLOC || defined malloc) \ + && (defined YYFREE || defined free))) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 +# endif +# endif +# ifndef YYMALLOC +# define YYMALLOC malloc +# if ! defined malloc && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# ifndef YYFREE +# define YYFREE free +# if ! defined free && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void free (void *); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# endif +#endif /* ! defined yyoverflow || YYERROR_VERBOSE */ + + +#if (! defined yyoverflow \ + && (! defined __cplusplus \ + || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + yytype_int16 yyss_alloc; + YYSTYPE yyvs_alloc; +}; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAXIMUM) + +# define YYCOPY_NEEDED 1 + +/* Relocate STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Stack_alloc, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ + Stack = &yyptr->Stack_alloc; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (YYID (0)) + +#endif + +#if defined YYCOPY_NEEDED && YYCOPY_NEEDED +/* Copy COUNT objects from SRC to DST. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(Dst, Src, Count) \ + __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) +# else +# define YYCOPY(Dst, Src, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (Dst)[yyi] = (Src)[yyi]; \ + } \ + while (YYID (0)) +# endif +# endif +#endif /* !YYCOPY_NEEDED */ + +/* YYFINAL -- State number of the termination state. */ +#define YYFINAL 2 +/* YYLAST -- Last index in YYTABLE. */ +#define YYLAST 6268 + +/* YYNTOKENS -- Number of terminals. */ +#define YYNTOKENS 169 +/* YYNNTS -- Number of nonterminals. */ +#define YYNNTS 206 +/* YYNRULES -- Number of rules. */ +#define YYNRULES 597 +/* YYNRULES -- Number of states. */ +#define YYNSTATES 1051 + +/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ +#define YYUNDEFTOK 2 +#define YYMAXUTOK 410 + +#define YYTRANSLATE(YYX) \ + ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) + +/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ +static const yytype_uint8 yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 166, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 168, 2, 2, + 162, 163, 21, 19, 3, 20, 2, 167, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 4, 2, + 164, 5, 165, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 2, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 18, 22, 23, 24, 25, 26, 27, 28, 29, 30, + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, + 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, + 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, + 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, + 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, + 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, + 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, + 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, + 161 +}; + +#if YYDEBUG +/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in + YYRHS. */ +static const yytype_uint16 yyprhs[] = +{ + 0, 0, 3, 4, 7, 9, 11, 14, 16, 19, + 21, 25, 28, 31, 33, 37, 41, 44, 47, 51, + 53, 54, 55, 57, 58, 61, 66, 69, 75, 78, + 80, 83, 85, 87, 88, 91, 95, 96, 99, 103, + 105, 109, 111, 113, 116, 121, 124, 127, 132, 135, + 137, 139, 141, 143, 145, 147, 149, 151, 153, 158, + 162, 166, 169, 172, 173, 175, 177, 179, 181, 183, + 185, 187, 189, 191, 193, 195, 197, 199, 201, 203, + 205, 207, 209, 211, 213, 215, 217, 219, 221, 223, + 225, 229, 233, 239, 241, 245, 249, 252, 257, 259, + 263, 264, 266, 269, 273, 275, 277, 280, 282, 286, + 291, 296, 305, 307, 311, 314, 318, 324, 328, 330, + 331, 334, 336, 341, 345, 348, 352, 356, 360, 364, + 365, 367, 370, 374, 380, 384, 386, 392, 398, 401, + 405, 408, 412, 414, 416, 420, 424, 427, 431, 437, + 439, 442, 444, 448, 451, 453, 457, 458, 460, 462, + 466, 470, 473, 475, 479, 482, 485, 491, 498, 499, + 502, 505, 509, 513, 514, 517, 522, 526, 530, 535, + 538, 540, 542, 544, 546, 548, 550, 552, 553, 556, + 558, 562, 563, 566, 570, 572, 576, 579, 583, 585, + 587, 589, 591, 593, 594, 598, 599, 601, 605, 607, + 611, 613, 615, 617, 620, 622, 627, 629, 631, 633, + 635, 637, 639, 641, 643, 645, 647, 648, 652, 654, + 658, 660, 662, 665, 668, 672, 674, 676, 678, 680, + 682, 686, 690, 694, 699, 704, 708, 713, 718, 722, + 727, 732, 737, 742, 747, 752, 757, 762, 767, 772, + 777, 782, 787, 791, 796, 800, 805, 810, 812, 816, + 818, 820, 822, 825, 828, 831, 833, 835, 838, 841, + 844, 847, 850, 853, 856, 859, 862, 866, 870, 873, + 876, 879, 882, 885, 888, 891, 894, 897, 900, 901, + 903, 906, 909, 912, 914, 916, 918, 920, 921, 923, + 926, 931, 937, 942, 947, 951, 953, 956, 958, 962, + 964, 966, 970, 976, 981, 985, 988, 991, 993, 995, + 997, 999, 1001, 1003, 1005, 1007, 1010, 1013, 1015, 1018, + 1020, 1022, 1023, 1025, 1031, 1032, 1034, 1036, 1038, 1039, + 1042, 1045, 1051, 1054, 1059, 1066, 1073, 1075, 1077, 1081, + 1085, 1087, 1091, 1095, 1097, 1099, 1101, 1103, 1105, 1107, + 1109, 1111, 1113, 1116, 1118, 1120, 1123, 1126, 1129, 1133, + 1136, 1142, 1148, 1151, 1154, 1157, 1160, 1162, 1167, 1169, + 1172, 1175, 1178, 1181, 1183, 1185, 1187, 1189, 1195, 1202, + 1203, 1207, 1208, 1213, 1214, 1219, 1224, 1226, 1228, 1230, + 1232, 1234, 1238, 1243, 1245, 1248, 1250, 1253, 1254, 1255, + 1258, 1262, 1264, 1269, 1271, 1273, 1278, 1281, 1287, 1291, + 1295, 1297, 1302, 1305, 1312, 1321, 1327, 1331, 1333, 1335, + 1337, 1339, 1341, 1344, 1351, 1352, 1354, 1357, 1361, 1362, + 1364, 1367, 1371, 1379, 1385, 1391, 1398, 1400, 1403, 1405, + 1408, 1414, 1419, 1420, 1422, 1425, 1429, 1436, 1441, 1444, + 1448, 1450, 1453, 1457, 1459, 1461, 1465, 1467, 1470, 1473, + 1477, 1479, 1481, 1483, 1485, 1487, 1489, 1491, 1493, 1495, + 1496, 1501, 1509, 1511, 1515, 1518, 1521, 1524, 1525, 1529, + 1530, 1532, 1535, 1538, 1540, 1542, 1546, 1548, 1551, 1553, + 1555, 1556, 1558, 1561, 1564, 1565, 1568, 1572, 1576, 1580, + 1582, 1586, 1588, 1590, 1594, 1596, 1598, 1600, 1604, 1610, + 1615, 1618, 1621, 1622, 1624, 1626, 1628, 1630, 1632, 1634, + 1636, 1638, 1640, 1644, 1646, 1648, 1652, 1656, 1660, 1664, + 1667, 1671, 1674, 1677, 1680, 1683, 1686, 1689, 1692, 1696, + 1698, 1700, 1702, 1704, 1708, 1711, 1716, 1719, 1722, 1728, + 1729, 1731, 1734, 1736, 1738, 1740, 1742, 1746, 1750, 1754, + 1758, 1762, 1766, 1772, 1778, 1784, 1790, 1798, 1807, 1810, + 1812, 1816, 1818, 1820, 1824, 1825, 1830, 1832 +}; + +/* YYRHS -- A `-1'-separated list of the rules' RHS. */ +static const yytype_int16 yyrhs[] = +{ + 170, 0, -1, -1, 170, 171, -1, 172, -1, 173, + -1, 140, 173, -1, 1, -1, 166, 175, -1, 24, + -1, 172, 166, 175, -1, 172, 24, -1, 172, 140, + -1, 174, -1, 173, 24, 166, -1, 173, 24, 174, + -1, 178, 175, -1, 186, 175, -1, 28, 181, 175, + -1, 282, -1, -1, -1, 70, -1, -1, 26, 183, + -1, 176, 29, 180, 182, -1, 30, 180, -1, 176, + 31, 180, 182, 177, -1, 92, 160, -1, 161, -1, + 179, 161, -1, 160, -1, 153, -1, -1, 162, 163, + -1, 162, 184, 163, -1, -1, 162, 163, -1, 162, + 184, 163, -1, 185, -1, 184, 3, 185, -1, 160, + -1, 21, -1, 228, 196, -1, 141, 187, 195, 336, + -1, 143, 336, -1, 114, 190, -1, 198, 162, 221, + 163, -1, 198, 221, -1, 215, -1, 203, -1, 225, + -1, 211, -1, 213, -1, 212, -1, 276, -1, 223, + -1, 209, -1, 66, 162, 249, 163, -1, 108, 195, + 214, -1, 110, 195, 189, -1, 65, 191, -1, 199, + 166, -1, -1, 244, -1, 42, -1, 34, -1, 39, + -1, 54, -1, 77, -1, 40, -1, 43, -1, 60, + -1, 55, -1, 56, -1, 57, -1, 58, -1, 59, + -1, 62, -1, 63, -1, 64, -1, 67, -1, 68, + -1, 69, -1, 72, -1, 73, -1, 74, -1, 75, + -1, 160, -1, 188, -1, 189, 3, 188, -1, 162, + 194, 163, -1, 190, 3, 162, 194, 163, -1, 192, + -1, 191, 3, 192, -1, 162, 193, 163, -1, 267, + 245, -1, 193, 3, 267, 245, -1, 249, -1, 194, + 3, 249, -1, -1, 131, -1, 226, 227, -1, 197, + 180, 182, -1, 31, -1, 25, -1, 155, 200, -1, + 201, -1, 200, 220, 201, -1, 160, 22, 202, 22, + -1, 206, 22, 202, 22, -1, 162, 257, 3, 368, + 163, 22, 202, 22, -1, 207, -1, 207, 3, 202, + -1, 204, 205, -1, 204, 219, 205, -1, 203, 220, + 219, 220, 205, -1, 203, 3, 205, -1, 116, -1, + -1, 160, 245, -1, 160, -1, 160, 162, 249, 163, + -1, 206, 3, 206, -1, 208, 268, -1, 207, 19, + 207, -1, 207, 20, 207, -1, 207, 21, 207, -1, + 207, 167, 207, -1, -1, 253, -1, 111, 267, -1, + 111, 219, 267, -1, 209, 220, 219, 220, 267, -1, + 209, 3, 267, -1, 106, -1, 210, 220, 160, 245, + 233, -1, 211, 3, 160, 245, 233, -1, 79, 166, + -1, 79, 195, 214, -1, 78, 166, -1, 78, 195, + 214, -1, 160, -1, 133, -1, 214, 3, 160, -1, + 214, 3, 133, -1, 216, 217, -1, 216, 219, 217, + -1, 215, 220, 219, 220, 217, -1, 123, -1, 124, + 123, -1, 218, -1, 217, 3, 218, -1, 160, 245, + -1, 18, -1, 22, 160, 22, -1, -1, 3, -1, + 222, -1, 221, 3, 222, -1, 160, 5, 249, -1, + 128, 224, -1, 160, -1, 224, 3, 160, -1, 118, + 119, -1, 118, 130, -1, 240, 160, 245, 233, 274, + -1, 226, 3, 160, 245, 233, 274, -1, -1, 232, + 235, -1, 231, 229, -1, 232, 21, 161, -1, 142, + 237, 163, -1, -1, 21, 161, -1, 21, 162, 230, + 163, -1, 162, 230, 163, -1, 160, 238, 239, -1, + 160, 5, 238, 239, -1, 238, 239, -1, 152, -1, + 145, -1, 146, -1, 144, -1, 158, -1, 159, -1, + 147, -1, -1, 21, 234, -1, 249, -1, 162, 21, + 163, -1, -1, 21, 236, -1, 162, 237, 163, -1, + 249, -1, 162, 21, 163, -1, 160, 238, -1, 160, + 5, 238, -1, 160, -1, 161, -1, 133, -1, 249, + -1, 21, -1, -1, 3, 160, 238, -1, -1, 131, + -1, 3, 241, 131, -1, 242, -1, 241, 3, 242, + -1, 25, -1, 244, -1, 80, -1, 106, 245, -1, + 108, -1, 109, 162, 243, 163, -1, 110, -1, 113, + -1, 114, -1, 116, -1, 117, -1, 136, -1, 134, + -1, 135, -1, 78, -1, 79, -1, -1, 162, 246, + 163, -1, 247, -1, 246, 3, 247, -1, 248, -1, + 4, -1, 249, 4, -1, 4, 249, -1, 249, 4, + 248, -1, 21, -1, 249, -1, 252, -1, 275, -1, + 250, -1, 162, 249, 163, -1, 42, 251, 163, -1, + 33, 251, 163, -1, 34, 162, 251, 163, -1, 39, + 162, 251, 163, -1, 54, 251, 163, -1, 77, 162, + 251, 163, -1, 40, 162, 249, 163, -1, 43, 249, + 163, -1, 144, 162, 251, 163, -1, 60, 162, 249, + 163, -1, 55, 162, 249, 163, -1, 56, 162, 249, + 163, -1, 57, 162, 249, 163, -1, 58, 162, 249, + 163, -1, 59, 162, 249, 163, -1, 62, 162, 249, + 163, -1, 63, 162, 249, 163, -1, 64, 162, 249, + 163, -1, 67, 162, 249, 163, -1, 68, 162, 249, + 163, -1, 69, 162, 249, 163, -1, 71, 249, 163, + -1, 72, 162, 251, 163, -1, 73, 251, 163, -1, + 74, 162, 251, 163, -1, 75, 162, 251, 163, -1, + 249, -1, 251, 3, 249, -1, 257, -1, 268, -1, + 262, -1, 249, 254, -1, 253, 249, -1, 11, 249, + -1, 19, -1, 20, -1, 19, 249, -1, 20, 249, + -1, 21, 249, -1, 23, 249, -1, 13, 249, -1, + 7, 249, -1, 16, 249, -1, 165, 249, -1, 164, + 249, -1, 165, 5, 249, -1, 164, 5, 249, -1, + 17, 249, -1, 14, 249, -1, 15, 249, -1, 12, + 249, -1, 6, 249, -1, 8, 249, -1, 9, 249, + -1, 10, 249, -1, 22, 255, -1, 5, 256, -1, + -1, 249, -1, 5, 249, -1, 22, 249, -1, 5, + 249, -1, 249, -1, 267, -1, 261, -1, 259, -1, + -1, 260, -1, 260, 271, -1, 261, 162, 263, 163, + -1, 261, 162, 263, 163, 271, -1, 267, 162, 263, + 163, -1, 257, 168, 356, 257, -1, 125, 366, 126, + -1, 258, -1, 258, 264, -1, 265, -1, 264, 3, + 265, -1, 249, -1, 266, -1, 249, 4, 249, -1, + 249, 4, 249, 4, 249, -1, 4, 249, 4, 249, + -1, 4, 4, 249, -1, 4, 249, -1, 249, 4, + -1, 4, -1, 160, -1, 138, -1, 139, -1, 41, + -1, 161, -1, 157, -1, 132, -1, 268, 160, -1, + 269, 270, -1, 153, -1, 269, 153, -1, 156, -1, + 154, -1, -1, 271, -1, 162, 272, 4, 272, 163, + -1, -1, 249, -1, 166, -1, 249, -1, -1, 5, + 249, -1, 122, 249, -1, 162, 252, 3, 252, 163, + -1, 277, 160, -1, 277, 160, 3, 278, -1, 277, + 160, 3, 27, 4, 166, -1, 277, 160, 3, 27, + 4, 280, -1, 137, -1, 279, -1, 278, 3, 279, + -1, 160, 122, 160, -1, 281, -1, 280, 3, 281, + -1, 160, 122, 160, -1, 160, -1, 283, -1, 331, + -1, 284, -1, 300, -1, 320, -1, 310, -1, 287, + -1, 115, -1, 338, 340, -1, 369, -1, 341, -1, + 357, 352, -1, 359, 350, -1, 100, 352, -1, 100, + 352, 366, -1, 103, 353, -1, 96, 162, 370, 373, + 163, -1, 104, 162, 372, 373, 163, -1, 76, 272, + -1, 81, 273, -1, 61, 273, -1, 348, 273, -1, + 339, -1, 105, 162, 374, 163, -1, 333, -1, 334, + 336, -1, 332, 336, -1, 335, 336, -1, 93, 336, + -1, 319, -1, 286, -1, 90, -1, 249, -1, 35, + 162, 294, 163, 293, -1, 291, 172, 288, 289, 290, + 297, -1, -1, 288, 292, 172, -1, -1, 289, 295, + 172, 288, -1, -1, 290, 296, 172, 288, -1, 35, + 162, 294, 163, -1, 293, -1, 286, -1, 287, -1, + 285, -1, 249, -1, 36, 294, 163, -1, 36, 294, + 163, 160, -1, 37, -1, 37, 160, -1, 38, -1, + 38, 160, -1, -1, -1, 299, 282, -1, 299, 282, + 172, -1, 301, -1, 302, 172, 307, 308, -1, 303, + -1, 304, -1, 160, 4, 89, 179, -1, 89, 179, + -1, 160, 4, 89, 179, 305, -1, 89, 179, 305, + -1, 160, 4, 89, -1, 89, -1, 160, 4, 89, + 305, -1, 89, 305, -1, 220, 306, 5, 249, 3, + 249, -1, 220, 306, 5, 249, 3, 249, 3, 249, + -1, 220, 94, 162, 249, 163, -1, 220, 95, 298, + -1, 267, -1, 299, -1, 309, -1, 330, -1, 91, + -1, 91, 160, -1, 315, 172, 299, 311, 313, 318, + -1, -1, 312, -1, 311, 312, -1, 316, 172, 299, + -1, -1, 314, -1, 313, 312, -1, 317, 172, 299, + -1, 160, 4, 88, 162, 249, 163, 82, -1, 88, + 162, 249, 163, 82, -1, 83, 162, 249, 163, 82, + -1, 83, 162, 249, 163, 82, 160, -1, 84, -1, + 84, 160, -1, 85, -1, 85, 160, -1, 88, 162, + 249, 163, 284, -1, 323, 172, 321, 325, -1, -1, + 322, -1, 321, 322, -1, 324, 172, 299, -1, 160, + 4, 45, 162, 249, 163, -1, 45, 162, 249, 163, + -1, 44, 326, -1, 44, 326, 160, -1, 107, -1, + 107, 160, -1, 162, 327, 163, -1, 112, -1, 328, + -1, 327, 3, 328, -1, 329, -1, 329, 4, -1, + 4, 329, -1, 329, 4, 329, -1, 249, -1, 115, + -1, 32, -1, 148, -1, 151, -1, 150, -1, 149, + -1, 166, -1, 160, -1, -1, 267, 337, 245, 245, + -1, 338, 168, 356, 267, 337, 245, 245, -1, 161, + -1, 339, 3, 161, -1, 5, 249, -1, 122, 249, + -1, 344, 342, -1, -1, 162, 343, 163, -1, -1, + 346, -1, 345, 101, -1, 345, 160, -1, 120, -1, + 347, -1, 346, 3, 347, -1, 249, -1, 21, 161, + -1, 127, -1, 129, -1, -1, 363, -1, 352, 349, + -1, 358, 351, -1, -1, 3, 363, -1, 162, 354, + 163, -1, 162, 267, 163, -1, 162, 161, 163, -1, + 161, -1, 162, 252, 163, -1, 160, -1, 355, -1, + 354, 3, 355, -1, 360, -1, 21, -1, 23, -1, + 267, 249, 245, -1, 267, 249, 168, 356, 338, -1, + 267, 162, 266, 163, -1, 267, 21, -1, 267, 23, + -1, -1, 97, -1, 98, -1, 101, -1, 361, -1, + 21, -1, 102, -1, 99, -1, 86, -1, 361, -1, + 162, 360, 163, -1, 257, -1, 268, -1, 360, 362, + 360, -1, 360, 21, 360, -1, 360, 22, 360, -1, + 360, 23, 360, -1, 362, 360, -1, 360, 18, 360, + -1, 46, 249, -1, 47, 249, -1, 49, 249, -1, + 48, 249, -1, 53, 249, -1, 52, 249, -1, 50, + 249, -1, 160, 5, 249, -1, 250, -1, 19, -1, + 20, -1, 364, -1, 363, 3, 364, -1, 257, 365, + -1, 162, 363, 163, 365, -1, 250, 365, -1, 268, + 365, -1, 162, 363, 3, 368, 163, -1, -1, 254, + -1, 365, 254, -1, 275, -1, 250, -1, 252, -1, + 367, -1, 252, 3, 249, -1, 252, 3, 367, -1, + 367, 3, 249, -1, 367, 3, 367, -1, 366, 3, + 249, -1, 366, 3, 367, -1, 162, 252, 3, 368, + 163, -1, 162, 366, 3, 368, 163, -1, 162, 367, + 3, 368, 163, -1, 160, 5, 249, 3, 249, -1, + 160, 5, 249, 3, 249, 3, 249, -1, 87, 162, + 249, 3, 249, 163, 3, 249, -1, 87, 161, -1, + 371, -1, 370, 3, 371, -1, 257, -1, 371, -1, + 372, 3, 371, -1, -1, 3, 121, 5, 257, -1, + 267, -1, 374, 3, 267, -1 +}; + +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ +static const yytype_uint16 yyrline[] = +{ + 0, 313, 313, 314, 316, 317, 318, 319, 322, 323, + 324, 325, 326, 329, 330, 331, 334, 335, 336, 344, + 347, 350, 351, 354, 355, 358, 366, 375, 392, 411, + 412, 415, 417, 419, 420, 421, 423, 424, 425, 427, + 439, 451, 452, 454, 455, 456, 457, 458, 475, 492, + 493, 498, 499, 536, 549, 550, 551, 552, 553, 554, + 555, 556, 557, 570, 571, 578, 579, 580, 581, 582, + 583, 584, 585, 586, 587, 588, 589, 590, 591, 592, + 593, 594, 595, 596, 597, 598, 599, 600, 601, 604, + 605, 608, 609, 612, 613, 615, 618, 619, 622, 623, + 625, 626, 629, 695, 710, 712, 716, 719, 720, 723, + 729, 734, 748, 749, 752, 753, 754, 755, 758, 760, + 761, 764, 765, 766, 769, 770, 771, 772, 773, 775, + 776, 779, 780, 781, 782, 785, 792, 802, 814, 815, + 818, 819, 822, 823, 824, 825, 828, 834, 842, 852, + 853, 856, 857, 860, 868, 874, 881, 882, 885, 886, + 889, 905, 908, 909, 912, 921, 923, 945, 970, 972, + 973, 974, 975, 977, 978, 979, 980, 983, 984, 985, + 987, 990, 991, 992, 993, 994, 995, 997, 998, 1001, + 1002, 1004, 1005, 1006, 1008, 1009, 1012, 1013, 1023, 1024, + 1025, 1028, 1029, 1031, 1032, 1034, 1035, 1036, 1038, 1039, + 1042, 1043, 1044, 1045, 1046, 1047, 1049, 1050, 1051, 1052, + 1053, 1056, 1057, 1058, 1061, 1062, 1064, 1065, 1073, 1079, + 1086, 1087, 1088, 1089, 1090, 1093, 1094, 1096, 1097, 1098, + 1099, 1103, 1104, 1105, 1106, 1107, 1108, 1109, 1110, 1111, + 1112, 1113, 1114, 1115, 1116, 1117, 1118, 1119, 1120, 1121, + 1122, 1123, 1124, 1125, 1126, 1127, 1128, 1130, 1131, 1133, + 1134, 1135, 1136, 1137, 1138, 1140, 1141, 1145, 1146, 1147, + 1148, 1149, 1150, 1151, 1152, 1153, 1154, 1155, 1156, 1157, + 1158, 1159, 1160, 1161, 1162, 1163, 1164, 1165, 1167, 1168, + 1169, 1170, 1173, 1174, 1177, 1178, 1179, 1183, 1194, 1195, + 1196, 1197, 1200, 1209, 1216, 1219, 1220, 1223, 1224, 1227, + 1228, 1231, 1232, 1233, 1234, 1235, 1236, 1237, 1239, 1285, + 1286, 1287, 1288, 1289, 1290, 1291, 1293, 1296, 1297, 1298, + 1299, 1301, 1302, 1305, 1307, 1308, 1311, 1312, 1314, 1315, + 1321, 1329, 1332, 1352, 1379, 1399, 1439, 1446, 1450, 1457, + 1467, 1468, 1476, 1486, 1498, 1499, 1504, 1505, 1506, 1507, + 1508, 1513, 1514, 1515, 1516, 1517, 1518, 1519, 1520, 1521, + 1522, 1523, 1524, 1525, 1526, 1527, 1528, 1529, 1530, 1567, + 1576, 1587, 1595, 1617, 1618, 1619, 1657, 1661, 1665, 1668, + 1669, 1672, 1673, 1676, 1677, 1682, 1686, 1687, 1688, 1692, + 1696, 1701, 1702, 1707, 1708, 1713, 1714, 1718, 1722, 1723, + 1724, 1729, 1734, 1739, 1740, 1745, 1746, 1747, 1748, 1753, + 1754, 1755, 1756, 1761, 1762, 1763, 1764, 1768, 1772, 1776, + 1777, 1782, 1783, 1787, 1790, 1791, 1792, 1796, 1799, 1800, + 1801, 1804, 1809, 1810, 1815, 1816, 1821, 1822, 1827, 1828, + 1832, 1836, 1839, 1840, 1841, 1844, 1849, 1850, 1855, 1856, + 1861, 1862, 1867, 1868, 1872, 1873, 1878, 1879, 1880, 1881, + 1885, 1889, 1893, 1897, 1905, 1912, 1919, 1926, 1927, 1930, + 1933, 1944, 1950, 1951, 1954, 1955, 1957, 1970, 1971, 1973, + 1974, 1977, 1978, 2000, 2003, 2004, 2007, 2015, 2018, 2019, + 2022, 2023, 2026, 2027, 2029, 2030, 2032, 2035, 2036, 2037, + 2038, 2039, 2042, 2043, 2046, 2047, 2048, 2049, 2050, 2051, + 2052, 2053, 2056, 2059, 2060, 2061, 2063, 2064, 2067, 2068, + 2069, 2072, 2073, 2076, 2077, 2078, 2079, 2080, 2081, 2082, + 2083, 2084, 2085, 2086, 2087, 2088, 2089, 2090, 2091, 2092, + 2094, 2095, 2097, 2098, 2104, 2105, 2106, 2107, 2108, 2110, + 2111, 2112, 2115, 2116, 2117, 2118, 2119, 2120, 2121, 2122, + 2123, 2124, 2127, 2128, 2129, 2131, 2132, 2134, 2135, 2138, + 2139, 2142, 2145, 2146, 2148, 2149, 2152, 2153 +}; +#endif + +#if YYDEBUG || YYERROR_VERBOSE || 0 +/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. + First, the terminals, then, starting at YYNTOKENS, nonterminals. */ +static const char *const yytname[] = +{ + "$end", "error", "$undefined", "','", "':'", "'='", "TOK_NEQV", + "TOK_EQV", "TOK_XOR", "TOK_OR", "TOK_AND", "TOK_NOT", "TOK_NE", "TOK_EQ", + "TOK_GE", "TOK_LE", "TOK_GT", "TOK_LT", "TOK_DSLASH", "'+'", "'-'", + "'*'", "TOK_SLASH", "TOK_DASTER", "TOK_SEMICOLON", "TOK_PARAMETER", + "TOK_RESULT", "TOK_ONLY", "TOK_INCLUDE", "TOK_SUBROUTINE", "TOK_PROGRAM", + "TOK_FUNCTION", "TOK_FORMAT", "TOK_MAX", "TOK_TANH", "TOK_WHERE", + "TOK_ELSEWHEREPAR", "TOK_ELSEWHERE", "TOK_ENDWHERE", "TOK_MAXVAL", + "TOK_TRIM", "TOK_NULL_PTR", "TOK_SUM", "TOK_SQRT", "TOK_CASE", + "TOK_SELECTCASE", "TOK_FILE", "TOK_UNIT", "TOK_FMT", "TOK_NML", + "TOK_END", "TOK_EOR", "TOK_ERR", "TOK_EXIST", "TOK_MIN", "TOK_FLOAT", + "TOK_EXP", "TOK_COS", "TOK_COSH", "TOK_ACOS", "TOK_NINT", "TOK_CYCLE", + "TOK_SIN", "TOK_SINH", "TOK_ASIN", "TOK_EQUIVALENCE", "TOK_BACKSPACE", + "TOK_LOG", "TOK_TAN", "TOK_ATAN", "TOK_RECURSIVE", "TOK_ABS", "TOK_MOD", + "TOK_SIGN", "TOK_MINLOC", "TOK_MAXLOC", "TOK_EXIT", "TOK_MINVAL", + "TOK_PUBLIC", "TOK_PRIVATE", "TOK_ALLOCATABLE", "TOK_RETURN", "TOK_THEN", + "TOK_ELSEIF", "TOK_ELSE", "TOK_ENDIF", "TOK_PRINT", "TOK_PLAINGOTO", + "TOK_LOGICALIF", "TOK_PLAINDO", "TOK_CONTAINS", "TOK_ENDDO", + "TOK_MODULE", "TOK_ENDMODULE", "TOK_WHILE", "TOK_CONCURRENT", + "TOK_ALLOCATE", "TOK_OPEN", "TOK_CLOSE", "TOK_INQUIRE", "TOK_WRITE", + "TOK_FLUSH", "TOK_READ", "TOK_REWIND", "TOK_DEALLOCATE", "TOK_NULLIFY", + "TOK_DIMENSION", "TOK_ENDSELECT", "TOK_EXTERNAL", "TOK_INTENT", + "TOK_INTRINSIC", "TOK_NAMELIST", "TOK_DEFAULT", "TOK_OPTIONAL", + "TOK_POINTER", "TOK_CONTINUE", "TOK_SAVE", "TOK_TARGET", "TOK_IMPLICIT", + "TOK_NONE", "TOK_CALL", "TOK_STAT", "TOK_POINT_TO", "TOK_COMMON", + "TOK_GLOBAL", "TOK_LEFTAB", "TOK_RIGHTAB", "TOK_PAUSE", "TOK_PROCEDURE", + "TOK_STOP", "TOK_REAL8", "TOK_FOURDOTS", "TOK_HEXA", "TOK_ASSIGNTYPE", + "TOK_OUT", "TOK_INOUT", "TOK_IN", "TOK_USE", "TOK_TRUE", "TOK_FALSE", + "TOK_LABEL", "TOK_TYPE", "TOK_TYPEPAR", "TOK_ENDTYPE", "TOK_REAL", + "TOK_INTEGER", "TOK_LOGICAL", "TOK_DOUBLEPRECISION", "TOK_ENDSUBROUTINE", + "TOK_ENDFUNCTION", "TOK_ENDPROGRAM", "TOK_ENDUNIT", "TOK_CHARACTER", + "TOK_CHAR_CONSTANT", "TOK_CHAR_CUT", "TOK_DATA", "TOK_CHAR_MESSAGE", + "TOK_CSTREAL", "TOK_COMPLEX", "TOK_DOUBLECOMPLEX", "TOK_NAME", + "TOK_CSTINT", "'('", "')'", "'<'", "'>'", "'\\n'", "'/'", "'%'", + "$accept", "input", "line", "line-break", "suite_line_list", + "suite_line", "fin_line", "opt_recursive", "opt_result", "entry", + "label", "name_routine", "filename", "arglist", "arglist_after_result", + "args", "arg", "spec", "opt_spec", "name_intrinsic", + "use_intrinsic_list", "list_couple", "list_expr_equi", "expr_equi", + "list_expr_equi1", "list_expr", "opt_sep", "after_type", + "before_function", "before_parameter", "data_stmt", "data_stmt_set_list", + "data_stmt_set", "data_stmt_value_list", "save", "before_save", + "varsave", "datanamelist", "expr_data", "opt_signe", "namelist", + "before_dimension", "dimension", "private", "public", "use_name_list", + "common", "before_common", "var_common_list", "var_common", "comblock", + "opt_comma", "paramlist", "paramitem", "module_proc_stmt", + "proc_name_list", "implicit", "dcl", "nodimsgiven", "type", "c_selector", + "c_attribute", "before_character", "typespec", "lengspec", + "proper_lengspec", "selector", "proper_selector", "attribute", "clause", + "opt_clause", "options", "attr_spec_list", "attr_spec", "intent_spec", + "access_spec", "dims", "dimlist", "dim", "ubound", "expr", + "predefinedfunction", "minmaxlist", "uexpr", "signe", "operation", + "after_slash", "after_equal", "lhs", "beforefunctionuse", + "array_ele_substring_func_ref", "begin_array", "structure_component", + "vec", "funarglist", "funargs", "funarg", "triplet", "ident", + "simple_const", "string_constant", "opt_substring", "substring", + "optexpr", "opt_expr", "initial_value", "complex_const", "use_stat", + "word_use", "rename_list", "rename_name", "only_list", "only_name", + "execution-part-construct", "executable-construct", "action-stmt", + "assignment-stmt", "where-stmt", "where-construct", + "opt-where-body-construct", "opt-masked-elsewhere-construct", + "opt-elsewhere-construct", "where-construct-stmt", + "where-body-construct", "where-assignment-stmt", "mask-expr", + "masked-elsewhere-stmt", "elsewhere-stmt", "end-where-stmt", + "forall-header", "block", "do-construct", "block-do-construct", + "do-stmt", "label-do-stmt", "nonlabel-do-stmt", "loop-control", + "do-variable", "do-block", "end-do", "end-do-stmt", "if-construct", + "opt-else-if-stmt-block", "else-if-stmt-block", "opt-else-stmt-block", + "else-stmt-block", "if-then-stmt", "else-if-stmt", "else-stmt", + "end-if-stmt", "if-stmt", "case-construct", "opt_case-stmt-block", + "case-stmt-block", "select-case-stmt", "case-stmt", "end-select-stmt", + "case-selector", "case-value-range-list", "case-value-range", + "case-value", "continue-stmt", "format-stmt", "word_endsubroutine", + "word_endunit", "word_endprogram", "word_endfunction", "opt_name", + "before_dims", "ident_dims", "int_list", "after_ident_dims", "call", + "opt_call", "opt_callarglist", "keywordcall", "before_call", + "callarglist", "callarg", "stop", "option_inlist", "option_read", + "opt_inlist", "ioctl", "after_rewind", "ctllist", "ioclause", + "declare_after_percent", "iofctl", "infmt", "read", "fexpr", + "unpar_fexpr", "addop", "inlist", "inelt", "opt_operation", "outlist", + "other", "dospec", "goto", "allocation_list", "allocate_object", + "allocate_object_list", "opt_stat_spec", "pointer_name_list", YY_NULL +}; +#endif + +# ifdef YYPRINT +/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to + token YYLEX-NUM. */ +static const yytype_uint16 yytoknum[] = +{ + 0, 256, 257, 44, 58, 61, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 43, + 45, 42, 271, 272, 273, 274, 275, 276, 277, 278, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, + 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, + 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, + 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, + 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, + 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, + 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, + 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, + 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, + 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, + 399, 400, 401, 402, 403, 404, 405, 406, 407, 408, + 409, 410, 40, 41, 60, 62, 10, 47, 37 +}; +# endif + +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint16 yyr1[] = +{ + 0, 169, 170, 170, 171, 171, 171, 171, 172, 172, + 172, 172, 172, 173, 173, 173, 174, 174, 174, 174, + 175, 176, 176, 177, 177, 178, 178, 178, 178, 179, + 179, 180, 181, 182, 182, 182, 183, 183, 183, 184, + 184, 185, 185, 186, 186, 186, 186, 186, 186, 186, + 186, 186, 186, 186, 186, 186, 186, 186, 186, 186, + 186, 186, 186, 187, 187, 188, 188, 188, 188, 188, + 188, 188, 188, 188, 188, 188, 188, 188, 188, 188, + 188, 188, 188, 188, 188, 188, 188, 188, 188, 189, + 189, 190, 190, 191, 191, 192, 193, 193, 194, 194, + 195, 195, 196, 196, 197, 198, 199, 200, 200, 201, + 201, 201, 202, 202, 203, 203, 203, 203, 204, 205, + 205, 206, 206, 206, 207, 207, 207, 207, 207, 208, + 208, 209, 209, 209, 209, 210, 211, 211, 212, 212, + 213, 213, 214, 214, 214, 214, 215, 215, 215, 216, + 216, 217, 217, 218, 219, 219, 220, 220, 221, 221, + 222, 223, 224, 224, 225, 225, 226, 226, 227, 228, + 228, 228, 228, 229, 229, 229, 229, 230, 230, 230, + 231, 232, 232, 232, 232, 232, 232, 233, 233, 234, + 234, 235, 235, 235, 236, 236, 237, 237, 237, 237, + 237, 238, 238, 239, 239, 240, 240, 240, 241, 241, + 242, 242, 242, 242, 242, 242, 242, 242, 242, 242, + 242, 243, 243, 243, 244, 244, 245, 245, 246, 246, + 247, 247, 247, 247, 247, 248, 248, 249, 249, 249, + 249, 250, 250, 250, 250, 250, 250, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 251, 251, 252, + 252, 252, 252, 252, 252, 253, 253, 254, 254, 254, + 254, 254, 254, 254, 254, 254, 254, 254, 254, 254, + 254, 254, 254, 254, 254, 254, 254, 254, 255, 255, + 255, 255, 256, 256, 257, 257, 257, 258, 259, 259, + 259, 259, 260, 261, 262, 263, 263, 264, 264, 265, + 265, 266, 266, 266, 266, 266, 266, 266, 267, 268, + 268, 268, 268, 268, 268, 268, 268, 269, 269, 269, + 269, 270, 270, 271, 272, 272, 273, 273, 274, 274, + 274, 275, 276, 276, 276, 276, 277, 278, 278, 279, + 280, 280, 281, 281, 282, 282, 283, 283, 283, 283, + 283, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 285, 286, 287, 288, + 288, 289, 289, 290, 290, 291, 292, 292, 292, 293, + 294, 295, 295, 296, 296, 297, 297, 298, 299, 299, + 299, 300, 301, 302, 302, 303, 303, 303, 303, 304, + 304, 304, 304, 305, 305, 305, 305, 306, 307, 308, + 308, 309, 309, 310, 311, 311, 311, 312, 313, 313, + 313, 314, 315, 315, 316, 316, 317, 317, 318, 318, + 319, 320, 321, 321, 321, 322, 323, 323, 324, 324, + 325, 325, 326, 326, 327, 327, 328, 328, 328, 328, + 329, 330, 331, 332, 333, 334, 335, 336, 336, 337, + 338, 338, 339, 339, 340, 340, 341, 342, 342, 343, + 343, 344, 344, 345, 346, 346, 347, 347, 348, 348, + 349, 349, 350, 350, 351, 351, 352, 353, 353, 353, + 353, 353, 354, 354, 355, 355, 355, 355, 355, 355, + 355, 355, 356, 357, 357, 357, 358, 358, 359, 359, + 359, 360, 360, 361, 361, 361, 361, 361, 361, 361, + 361, 361, 361, 361, 361, 361, 361, 361, 361, 361, + 362, 362, 363, 363, 364, 364, 364, 364, 364, 365, + 365, 365, 366, 366, 366, 366, 366, 366, 366, 366, + 366, 366, 367, 367, 367, 368, 368, 369, 369, 370, + 370, 371, 372, 372, 373, 373, 374, 374 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 1, 1, 2, 1, 2, 1, + 3, 2, 2, 1, 3, 3, 2, 2, 3, 1, + 0, 0, 1, 0, 2, 4, 2, 5, 2, 1, + 2, 1, 1, 0, 2, 3, 0, 2, 3, 1, + 3, 1, 1, 2, 4, 2, 2, 4, 2, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 4, 3, + 3, 2, 2, 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, + 3, 3, 5, 1, 3, 3, 2, 4, 1, 3, + 0, 1, 2, 3, 1, 1, 2, 1, 3, 4, + 4, 8, 1, 3, 2, 3, 5, 3, 1, 0, + 2, 1, 4, 3, 2, 3, 3, 3, 3, 0, + 1, 2, 3, 5, 3, 1, 5, 5, 2, 3, + 2, 3, 1, 1, 3, 3, 2, 3, 5, 1, + 2, 1, 3, 2, 1, 3, 0, 1, 1, 3, + 3, 2, 1, 3, 2, 2, 5, 6, 0, 2, + 2, 3, 3, 0, 2, 4, 3, 3, 4, 2, + 1, 1, 1, 1, 1, 1, 1, 0, 2, 1, + 3, 0, 2, 3, 1, 3, 2, 3, 1, 1, + 1, 1, 1, 0, 3, 0, 1, 3, 1, 3, + 1, 1, 1, 2, 1, 4, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 0, 3, 1, 3, + 1, 1, 2, 2, 3, 1, 1, 1, 1, 1, + 3, 3, 3, 4, 4, 3, 4, 4, 3, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 3, 4, 3, 4, 4, 1, 3, 1, + 1, 1, 2, 2, 2, 1, 1, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 3, 3, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 0, 1, + 2, 2, 2, 1, 1, 1, 1, 0, 1, 2, + 4, 5, 4, 4, 3, 1, 2, 1, 3, 1, + 1, 3, 5, 4, 3, 2, 2, 1, 1, 1, + 1, 1, 1, 1, 1, 2, 2, 1, 2, 1, + 1, 0, 1, 5, 0, 1, 1, 1, 0, 2, + 2, 5, 2, 4, 6, 6, 1, 1, 3, 3, + 1, 3, 3, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 2, 1, 1, 2, 2, 2, 3, 2, + 5, 5, 2, 2, 2, 2, 1, 4, 1, 2, + 2, 2, 2, 1, 1, 1, 1, 5, 6, 0, + 3, 0, 4, 0, 4, 4, 1, 1, 1, 1, + 1, 3, 4, 1, 2, 1, 2, 0, 0, 2, + 3, 1, 4, 1, 1, 4, 2, 5, 3, 3, + 1, 4, 2, 6, 8, 5, 3, 1, 1, 1, + 1, 1, 2, 6, 0, 1, 2, 3, 0, 1, + 2, 3, 7, 5, 5, 6, 1, 2, 1, 2, + 5, 4, 0, 1, 2, 3, 6, 4, 2, 3, + 1, 2, 3, 1, 1, 3, 1, 2, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, + 4, 7, 1, 3, 2, 2, 2, 0, 3, 0, + 1, 2, 2, 1, 1, 3, 1, 2, 1, 1, + 0, 1, 2, 2, 0, 2, 3, 3, 3, 1, + 3, 1, 1, 3, 1, 1, 1, 3, 5, 4, + 2, 2, 0, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 3, 1, 1, 3, 3, 3, 3, 2, + 3, 2, 2, 2, 2, 2, 2, 2, 3, 1, + 1, 1, 1, 3, 2, 4, 2, 2, 5, 0, + 1, 2, 1, 1, 1, 1, 3, 3, 3, 3, + 3, 3, 5, 5, 5, 5, 7, 8, 2, 1, + 3, 1, 1, 3, 0, 4, 1, 3 +}; + +/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM. + Performed when YYTABLE doesn't specify something else to do. Zero + means the default is an error. */ +static const yytype_uint16 yydefact[] = +{ + 2, 0, 1, 7, 9, 105, 0, 0, 482, 0, + 0, 0, 0, 0, 22, 344, 100, 100, 0, 540, + 0, 0, 156, 395, 0, 0, 0, 533, 534, 539, + 0, 535, 538, 0, 0, 0, 135, 100, 100, 0, + 0, 371, 118, 0, 503, 149, 0, 508, 0, 509, + 356, 21, 63, 0, 0, 183, 181, 182, 186, 483, + 486, 485, 484, 180, 0, 184, 185, 328, 492, 20, + 3, 4, 5, 13, 0, 20, 20, 0, 0, 50, + 119, 57, 156, 52, 54, 53, 49, 0, 56, 51, + 205, 173, 191, 489, 55, 0, 19, 364, 366, 394, + 370, 0, 367, 421, 0, 423, 424, 369, 0, 393, + 368, 0, 365, 0, 388, 0, 0, 0, 386, 374, + 497, 0, 0, 0, 0, 373, 32, 20, 31, 26, + 0, 0, 0, 275, 276, 0, 0, 0, 0, 331, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 334, 329, 330, 0, 337, 340, 339, 333, + 328, 332, 0, 346, 347, 239, 237, 0, 269, 306, + 308, 305, 271, 304, 270, 341, 384, 238, 0, 61, + 93, 0, 345, 382, 101, 140, 0, 138, 0, 383, + 588, 0, 0, 157, 29, 156, 0, 432, 28, 488, + 487, 392, 0, 0, 377, 521, 519, 0, 379, 0, + 0, 0, 0, 154, 0, 0, 131, 0, 46, 164, + 165, 150, 162, 161, 6, 224, 225, 100, 64, 200, + 198, 199, 0, 45, 121, 0, 156, 107, 0, 0, + 8, 11, 12, 20, 21, 0, 0, 16, 17, 0, + 0, 48, 158, 62, 119, 0, 226, 114, 119, 157, + 0, 0, 0, 0, 226, 146, 151, 0, 0, 104, + 206, 43, 0, 168, 0, 0, 0, 170, 0, 0, + 169, 226, 352, 399, 418, 418, 462, 390, 389, 391, + 0, 0, 532, 372, 0, 499, 496, 501, 502, 385, + 375, 560, 561, 537, 0, 0, 0, 0, 0, 0, + 0, 328, 0, 559, 543, 544, 376, 510, 514, 0, + 536, 0, 18, 410, 0, 0, 274, 267, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 573, 574, 572, 0, 575, + 0, 0, 237, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 298, 0, + 0, 0, 272, 273, 532, 344, 309, 307, 307, 335, + 338, 336, 342, 0, 226, 0, 0, 143, 142, 141, + 139, 0, 0, 30, 428, 0, 417, 437, 0, 591, + 594, 589, 525, 526, 0, 304, 0, 522, 524, 541, + 378, 332, 237, 304, 592, 594, 596, 0, 59, 66, + 67, 70, 65, 71, 68, 73, 74, 75, 76, 77, + 72, 78, 79, 80, 81, 82, 83, 84, 85, 86, + 87, 69, 88, 89, 60, 0, 132, 0, 98, 0, + 0, 0, 0, 202, 196, 201, 172, 129, 0, 0, + 0, 0, 129, 0, 0, 156, 10, 14, 15, 33, + 33, 0, 0, 0, 117, 156, 0, 120, 115, 134, + 156, 226, 226, 156, 153, 0, 147, 210, 212, 226, + 214, 0, 216, 217, 218, 219, 220, 0, 208, 211, + 33, 0, 102, 226, 174, 0, 328, 0, 203, 332, + 0, 192, 194, 0, 226, 0, 401, 438, 0, 444, + 0, 0, 463, 0, 494, 495, 0, 493, 0, 506, + 0, 500, 504, 551, 552, 554, 553, 557, 556, 555, + 0, 524, 0, 569, 569, 569, 512, 511, 562, 0, + 513, 0, 0, 0, 0, 0, 549, 405, 467, 0, + 242, 0, 0, 0, 241, 248, 245, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 262, + 0, 264, 0, 0, 0, 237, 0, 0, 0, 0, + 314, 0, 0, 240, 0, 0, 303, 297, 292, 282, + 293, 294, 295, 291, 281, 289, 290, 283, 288, 277, + 278, 279, 0, 0, 299, 296, 280, 0, 285, 0, + 284, 0, 0, 315, 0, 0, 0, 95, 96, 94, + 58, 0, 0, 0, 0, 436, 0, 0, 0, 0, + 530, 531, 307, 226, 0, 516, 518, 520, 517, 0, + 0, 0, 387, 0, 155, 0, 91, 0, 163, 44, + 197, 0, 112, 0, 130, 0, 0, 108, 121, 123, + 0, 0, 0, 156, 431, 0, 25, 23, 160, 47, + 159, 119, 231, 235, 0, 228, 230, 236, 0, 187, + 187, 0, 152, 213, 0, 0, 207, 103, 226, 187, + 0, 0, 203, 176, 0, 179, 0, 193, 490, 0, + 0, 353, 357, 396, 409, 407, 408, 403, 0, 406, + 419, 441, 481, 422, 439, 440, 0, 448, 445, 0, + 473, 0, 468, 470, 464, 461, 418, 489, 507, 498, + 0, 558, 542, 0, 570, 566, 564, 567, 0, 515, + 550, 546, 547, 548, 545, 397, 268, 243, 244, 247, + 251, 252, 253, 254, 255, 250, 256, 257, 258, 259, + 260, 261, 263, 265, 266, 246, 0, 0, 0, 576, + 577, 580, 581, 578, 579, 249, 237, 302, 300, 301, + 287, 286, 313, 344, 327, 319, 316, 317, 320, 310, + 312, 226, 145, 144, 0, 0, 453, 0, 460, 0, + 0, 0, 590, 380, 0, 0, 532, 527, 523, 593, + 381, 597, 90, 99, 0, 109, 129, 129, 129, 129, + 129, 124, 122, 0, 0, 110, 0, 0, 427, 42, + 41, 34, 0, 39, 36, 27, 116, 233, 0, 227, + 232, 133, 0, 136, 137, 148, 222, 223, 221, 0, + 209, 187, 348, 175, 203, 177, 0, 195, 0, 0, + 0, 0, 0, 0, 400, 420, 442, 0, 456, 446, + 0, 449, 0, 418, 0, 480, 0, 474, 476, 469, + 471, 465, 226, 505, 0, 569, 571, 563, 328, 0, + 0, 0, 351, 0, 0, 325, 326, 0, 311, 97, + 0, 0, 0, 435, 0, 0, 529, 0, 92, 113, + 125, 126, 127, 128, 0, 0, 466, 0, 0, 35, + 0, 24, 229, 234, 236, 0, 188, 189, 215, 348, + 0, 0, 166, 178, 204, 363, 354, 355, 360, 359, + 358, 0, 413, 415, 0, 398, 399, 0, 457, 458, + 450, 443, 418, 447, 478, 0, 472, 477, 226, 0, + 565, 582, 583, 584, 343, 324, 0, 321, 318, 0, + 0, 0, 433, 595, 528, 0, 129, 452, 40, 37, + 0, 0, 167, 349, 350, 0, 0, 411, 414, 416, + 399, 402, 0, 459, 451, 475, 479, 491, 568, 323, + 0, 587, 0, 0, 0, 0, 0, 38, 190, 362, + 361, 412, 404, 454, 322, 434, 585, 111, 455, 0, + 586 +}; + +/* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int16 yydefgoto[] = +{ + -1, 1, 70, 71, 72, 73, 250, 74, 865, 75, + 205, 129, 127, 696, 951, 862, 863, 76, 237, 463, + 464, 228, 189, 190, 403, 467, 196, 281, 282, 77, + 78, 246, 247, 681, 79, 80, 267, 248, 682, 683, + 81, 82, 83, 84, 85, 409, 86, 87, 275, 276, + 225, 206, 261, 262, 88, 233, 89, 283, 522, 90, + 287, 527, 91, 92, 873, 956, 290, 531, 242, 528, + 725, 284, 517, 518, 879, 519, 497, 704, 705, 706, + 337, 175, 338, 176, 177, 392, 635, 617, 178, 643, + 179, 180, 181, 182, 645, 816, 817, 818, 183, 184, + 185, 401, 396, 193, 186, 962, 187, 94, 95, 731, + 732, 967, 968, 740, 97, 98, 734, 99, 100, 536, + 737, 892, 101, 738, 739, 334, 893, 974, 975, 655, + 537, 102, 103, 104, 105, 106, 207, 418, 538, 743, + 744, 107, 747, 748, 900, 901, 108, 749, 902, 981, + 109, 110, 541, 542, 111, 543, 755, 752, 906, 907, + 908, 745, 112, 113, 114, 115, 116, 211, 291, 117, + 118, 303, 119, 306, 550, 120, 121, 551, 552, 122, + 566, 326, 570, 214, 218, 426, 427, 546, 123, 328, + 124, 428, 429, 331, 567, 568, 765, 368, 369, 854, + 125, 420, 421, 435, 658, 437 +}; + +/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ +#define YYPACT_NINF -845 +static const yytype_int16 yypact[] = +{ + -845, 967, -845, -845, -845, -845, -22, 45, -845, 94, + 186, 3621, 199, 238, -845, 4658, 16, 36, 3621, -845, + 369, 256, 56, -845, 299, 280, 268, -845, -845, -845, + 306, -845, -845, 409, 311, 350, -845, 357, 357, 119, + 354, -845, -845, 53, -845, -845, 420, -845, 386, -845, + -845, 5758, 363, 274, 280, -845, -845, -845, -845, -845, + -845, -845, -845, -845, 237, -845, -845, 549, -845, -845, + -845, 122, 563, -845, 440, -845, -845, 319, 433, 436, + 159, 495, 622, 624, -845, -845, 523, 329, -845, -845, + 398, 102, 163, -845, -845, 471, -845, -845, -845, -845, + -845, 215, -845, -845, 215, -845, -845, -845, 215, -845, + -845, 215, -845, 280, -845, 280, 280, 20, 630, -845, + 472, 44, 3621, 306, 5477, -845, -845, -845, -845, -845, + 4658, 4658, 4658, -845, -845, 4658, 473, 474, 477, -845, + 4658, 4658, 4658, 478, 484, 486, 487, 488, 494, 496, + 497, 498, 499, 500, 501, 4658, 505, 4658, 507, 508, + 511, 4767, -845, -845, -845, 512, -845, -845, -845, -845, + -845, -845, 4658, -845, 2490, -845, -845, 4658, 470, -845, + 513, 515, -845, 516, 522, 270, -845, -845, 524, 654, + -845, 4658, 2490, -845, -845, -845, 277, -845, 277, -845, + -845, 4658, 4658, -845, -845, 110, 326, -845, -845, -845, + -845, -845, 524, 5347, 4767, -845, -845, 4876, -845, 524, + 524, 277, 2573, -845, 527, 524, -845, 4658, 665, -845, + -845, -845, -845, 680, 563, -845, -845, 357, -845, -845, + 2967, -845, 526, -845, 88, 524, 32, -845, 384, 82, + -845, -845, -845, -845, 5621, 45, 45, -845, -845, 687, + 533, 691, -845, -845, 535, 442, 534, -845, 535, 524, + 442, 537, 539, 442, 534, 699, -845, 545, 847, -845, + -845, -845, 45, 714, 564, 434, 3874, -845, 4985, 274, + -845, 534, 727, 122, 122, 122, 258, -845, -845, -845, + 4658, 4658, -845, -845, 571, 3983, -845, -845, -845, -845, + -845, -845, -845, -845, 4658, 4658, 4658, 4658, 4658, 4658, + 4658, 726, 5347, -845, 470, 522, -845, 1249, 730, 555, + 561, 5523, -845, 2490, 572, 1332, 875, 2490, 38, 4658, + 4658, 4658, 48, 1353, 61, 4658, 4658, 4658, 4658, 4658, + 4658, 4658, 4658, 4658, 4658, 4658, 4658, 1514, 4658, 68, + 4658, 4658, 4658, 4767, 2490, 1533, 753, 1552, 278, 731, + 4658, 1616, 733, 3294, 4658, 4658, 4658, 4658, 4658, 4658, + 4658, 4658, 4658, 4658, 4658, 4658, 4658, 4658, 3076, 4658, + 3403, 3512, -845, 185, -845, 4658, -845, -845, -845, -845, + -845, -845, -845, 69, 534, 199, 1635, -845, -845, 734, + 734, 1129, 1713, -845, -845, 576, -845, -845, 736, 470, + 739, -845, -845, -845, 5523, 3765, 79, -845, 555, -845, + 740, 581, 582, 439, -845, 743, -845, 105, 734, -845, + -845, -845, -845, -845, -845, -845, -845, -845, -845, -845, + -845, -845, -845, -845, -845, -845, -845, -845, -845, -845, + -845, -845, -845, -845, 744, 717, -845, 106, 2490, 588, + 591, 280, 4092, -845, -845, 2490, -845, 598, 4658, 31, + 237, 594, 598, 595, 602, 125, -845, -845, -845, 609, + 609, 4658, 109, 533, -845, 622, 2531, -845, -845, -845, + 622, 534, 534, 622, -845, 545, 699, -845, -845, 534, + -845, 615, -845, -845, -845, -845, -845, 123, -845, -845, + 609, 618, -845, 534, -845, 3874, 3185, 585, 750, 34, + 4201, -845, 2490, 592, 534, 80, 4331, 5955, 78, 5879, + 13, 85, -845, 215, 2490, 2490, 524, -845, 619, 2490, + 616, 778, -845, 2490, 2490, 2490, 2490, 2490, 2490, 2490, + 4658, 337, 1249, 2490, 706, 1732, -845, 779, -845, 1249, + -845, 5523, 5523, 5523, 5523, 5523, 760, 4658, -845, 4658, + -845, 111, 115, 1751, -845, -845, -845, 1796, 1815, 1834, + 1912, 1931, 1995, 2014, 2033, 2092, 2111, 2130, 2194, -845, + 121, -845, 130, 136, 149, 781, 785, 786, 4767, 4767, + -845, 4767, 150, -845, 4658, 4658, 2490, -845, 542, 542, + 806, 806, 875, 887, 887, 887, 887, 887, 887, 164, + 164, 185, 4658, 4658, 2490, -845, 185, 4658, 887, 4658, + 887, 524, 787, 2640, 627, 629, 524, -845, -845, -845, + -845, 295, 4658, 6031, 4658, -845, 4658, 19, 631, 337, + -845, -845, 2640, 83, 5347, -845, -845, -845, -845, 19, + 632, 524, -845, 2573, -845, 4658, -845, 4658, -845, -845, + -845, 771, 42, 547, -845, 2213, 636, -845, 637, -845, + 776, 4658, 4658, 135, -845, 242, -845, 774, 2490, -845, + -845, 535, 4658, -845, 151, -845, -845, 1253, 524, 780, + 780, 545, -845, -845, 476, 847, -845, -845, 534, 780, + 641, 4092, 750, -845, 645, -845, 644, -845, -845, 804, + 688, 809, -845, 2490, -845, -845, -845, 773, 215, -845, + 215, 653, -845, -845, -845, -845, 652, 536, -845, 215, + -845, 2749, 655, 664, -845, -845, 122, -845, -845, -845, + 3983, 2490, -845, 152, -845, 2490, 2490, 2490, 1249, 779, + 570, 760, 760, 760, 593, -845, 2490, -845, -845, -845, + -845, -845, -845, -845, -845, -845, -845, -845, -845, -845, + -845, -845, -845, -845, -845, -845, 5094, 5094, 5094, 2490, + -845, 2490, -845, 2490, -845, -845, 667, 887, 887, 185, + 887, 887, 470, 4658, 2858, 1415, 828, -845, -845, 513, + -845, 534, -845, -845, 2291, 670, -845, 671, -845, 2310, + 1150, 829, -845, -845, 1233, 672, -845, -845, -845, -845, + -845, -845, -845, 2490, 153, -845, 598, 598, 598, 598, + 598, 522, -845, 832, 676, -845, 2329, 2374, -845, -845, + -845, -845, 154, -845, 678, -845, -845, 2490, 2531, -845, + 4440, -845, 5203, -845, -845, 699, -845, -845, -845, 679, + -845, 780, 231, -845, 750, -845, 4092, -845, 291, 681, + 683, 4658, 586, 215, 122, 122, -845, 4658, 685, -845, + 454, -845, 215, 122, 4658, 2490, 155, -845, 842, -845, + -845, 5955, 534, -845, 1831, 2490, -845, -845, 832, 684, + 686, 689, -845, 690, 4658, 1435, 4658, 2640, -845, -845, + 845, 4658, 4658, -845, 4658, 524, -845, 524, -845, -845, + 66, 66, 693, 143, 4658, 833, -845, 768, 60, -845, + 259, -845, -845, -845, 2490, 4549, -845, 2490, -845, 231, + 4658, 4658, -845, -845, -845, 729, -845, 851, -845, -845, + -845, 695, 696, 702, 215, -845, 122, 2393, -845, 703, + -845, -845, 122, 5955, -845, 2749, -845, 4658, 534, 701, + 2490, -845, -845, -845, -845, 2490, 4658, 1455, -845, 4658, + 704, 2412, 1171, 470, 697, 1192, 598, -845, -845, -845, + 157, 705, -845, 2490, 2490, 709, 713, 716, -845, -845, + 122, 4331, 784, -845, 5955, -845, -845, -845, -845, 2490, + 4658, 2490, 4658, 6107, 4658, 4658, 855, -845, -845, -845, + -845, -845, 4331, 719, 2490, 2490, 1213, -845, -845, 4658, + 2490 +}; + +/* YYPGOTO[NTERM-NUM]. */ +static const yytype_int16 yypgoto[] = +{ + -845, -845, -845, -96, 830, 628, -26, -845, -845, -845, + 399, 156, -845, -94, -845, -67, -63, -845, -845, 232, + -845, -845, -845, 509, -845, 234, 30, -845, -845, -845, + -845, -845, 444, -464, -845, -845, -238, 438, -242, -845, + -845, -845, -845, -845, -845, -47, -845, -845, -263, 417, + -27, -50, 668, 437, -845, -845, -845, -845, -845, -845, + -845, 404, -845, -845, -671, -845, -845, -845, 642, -231, + -656, -845, -845, 217, -845, 882, -236, -845, 67, 70, + -11, -78, 55, -144, -458, -507, -845, -845, -97, -845, + -845, -845, -845, -845, 540, -845, 9, 279, 1, -70, + -845, -845, -182, -382, 365, -20, -128, -845, -845, -845, + 52, -845, -73, 43, -845, -630, -845, -515, -514, -844, + -845, -845, -845, -845, -566, -718, -845, -845, -845, -845, + -294, -845, -845, -845, -845, -845, -185, -845, -845, -845, + -845, -845, -845, -663, -845, -845, -845, -845, -845, -845, + -845, -845, -845, 405, -845, -845, -845, -845, -845, -40, + -787, -845, -845, -845, -845, -845, -845, -38, 190, 11, + -845, -845, -845, -845, -845, -845, -845, -845, 191, -845, + -845, -845, -845, 506, -845, -845, 288, -384, -845, -845, + -845, -39, 834, -250, -126, -699, -522, -140, -287, -465, + -845, -845, -213, -845, 519, -845 +}; + +/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule which + number is the opposite. If YYTABLE_NINF, syntax error. */ +#define YYTABLE_NINF -542 +static const yytype_int16 yytable[] = +{ + 174, 539, 93, 402, 192, 293, 434, 174, 294, 474, + 641, 775, 295, 642, 506, 296, 243, 366, 690, 684, + 414, 735, 736, 828, 684, 300, 494, 324, 372, 265, + 498, 270, 271, 367, 686, 203, 273, -171, 504, 874, + 226, 579, 766, 767, 96, 846, 323, 198, 882, 257, + 258, 579, 93, 268, 325, 534, 764, 764, 764, 203, + 277, 847, 848, 849, 579, -171, 885, 221, 222, 917, + 366, 579, 646, 432, 430, 297, 607, 298, 299, 575, + -430, 859, 664, 365, 899, 329, 367, 849, 373, 374, + 375, 376, 377, 378, 96, 379, 380, 381, 382, 383, + 384, 332, 385, 386, 387, 388, 389, 729, 671, 675, + 477, 174, 493, 203, 579, 419, 324, 984, 579, 333, + 335, 336, 419, 285, 579, 750, 715, 483, 203, 540, + 343, 126, 1021, 579, -426, 323, 365, 223, 203, 579, + 831, 224, 301, 325, 357, 307, 251, 194, 479, -429, + 364, 410, 579, 579, 868, 914, 675, 948, 985, -425, + 948, 371, 847, 848, 849, -171, 393, 194, 648, 741, + 484, 485, 229, 971, 438, 751, 1042, 223, 575, 170, + 406, 224, 195, 230, 288, 387, 388, 389, 302, 404, + 411, 412, 753, 742, -171, 342, 480, 344, -106, 394, + 1026, 580, 197, 364, 308, 128, 364, 417, 389, 850, + 959, 584, 359, 1000, 425, 917, 468, 204, 433, 605, + 860, 436, -430, 606, 586, 324, 466, 486, 963, 475, + 564, 601, 647, 850, 324, 367, 960, 980, 495, 4, + 730, 680, 665, 500, 323, 496, 503, 390, 391, 563, + 478, 836, 325, 323, 716, 93, 130, 565, 916, 916, + 916, 325, 252, 859, 286, 709, 710, 471, 672, 676, + 499, 413, 699, 713, 777, 475, -426, 532, 778, 170, + 859, 609, 251, 561, 792, 365, 204, 719, 253, 544, + 545, -429, 576, 793, 549, 722, 413, 96, 728, 794, + 694, -425, 540, 553, 554, 555, 556, 557, 558, 559, + 850, 575, 795, 805, 869, 915, 938, 949, 986, 266, + 1037, 800, 802, 425, 804, 289, 575, 324, 390, 391, + 583, 919, 920, 921, 587, 588, 589, 590, 591, 592, + 593, 594, 595, 596, 597, 598, 323, 223, 131, 390, + 391, 224, 371, 961, 325, 571, 311, 312, 572, 573, + 574, 188, 616, 618, 619, 620, 621, 622, 623, 624, + 625, 626, 627, 628, 629, 630, 631, 634, 636, 638, + 640, 69, 939, 199, 192, 659, 372, 481, 684, 684, + 684, 684, 684, 990, 581, 582, 697, 244, 252, 245, + 191, 278, 860, 828, 610, 861, 482, 239, 764, 575, + 407, 489, 490, 600, 663, 602, 603, 604, 202, 860, + 415, 416, 1009, 400, 253, 612, 717, 837, 822, 279, + 212, 923, 395, 679, 240, 241, 763, 408, 520, 264, + 209, 235, 236, 769, 832, 701, 210, 756, 875, 989, + 708, 965, 937, 711, -156, 823, 839, 966, -156, 208, + 223, 475, 911, 866, 224, 564, 775, 685, 213, 255, + 806, 256, 564, 219, 324, 324, 324, 324, 324, 259, + 698, 260, 881, 916, 563, 707, 170, 309, 194, 274, + 884, 563, 565, 323, 323, 323, 323, 323, 269, 565, + 762, 325, 325, 325, 325, 325, 735, 736, 858, 800, + 802, 804, 220, -156, 475, 475, 227, -156, 372, 371, + 575, 575, 575, 575, 575, 733, 203, 735, 736, 280, + 200, 201, 770, 771, 772, 773, 774, 746, 93, 979, + 93, -156, 1036, 231, 812, -156, 232, 757, 684, 761, + 376, 377, 378, 249, 379, 380, 381, 382, 383, 384, + 419, 385, 386, 387, 388, 389, 733, 324, 776, 215, + 216, 217, 419, 571, 311, 312, 572, 573, 574, -541, + -541, -541, -541, -541, -541, 929, 323, 254, 139, 311, + 312, 572, 573, 574, 325, 524, 525, 799, 801, 263, + 803, 398, 668, 364, 807, 940, 941, 942, 943, 983, + 876, 877, 878, 851, 572, 573, 574, 133, 134, 746, + 898, 808, 809, 972, 973, 203, 810, 272, 811, 310, + 327, 292, 815, 304, 305, 339, 340, 928, 394, 341, + 345, 824, 894, 829, 895, 830, 346, 821, 347, 348, + 349, 834, 806, 903, 93, 964, 350, 405, 351, 352, + 353, 354, 355, 356, 843, 425, 468, 358, 469, 360, + 361, 564, 841, 362, 370, 395, 988, 397, 398, 162, + 856, 857, 399, 470, 170, 163, 164, 465, 1024, 476, + 563, 867, 491, 259, 493, 266, 496, 501, 565, 502, + 166, 167, 505, 168, 169, 274, 390, 391, 171, 871, + 475, 373, 374, 375, 376, 377, 378, 521, 379, 380, + 381, 382, 383, 384, 523, 385, 386, 387, 388, 389, + 535, 560, 547, 569, 611, 577, 614, 651, 654, 674, + 905, 656, 657, 609, 666, 667, 669, 673, 723, 549, + 677, 678, 1027, 724, 688, 727, 608, 691, -237, -237, + -237, -237, -237, -237, 692, -237, -237, -237, -237, -237, + -237, 695, -237, -237, -237, -237, -237, 714, 718, 759, + 758, 760, 768, 574, 796, 799, 801, 803, 797, 798, + 819, 813, 820, 845, 833, 840, 853, 976, 855, 478, + 864, 872, 192, 925, 883, 886, 982, 887, 888, 891, + 889, 372, 890, 896, 897, 909, 378, 564, 379, 380, + 381, 382, 383, 384, 910, 385, 386, 387, 388, 389, + 922, 927, 931, 932, 935, 936, 563, 944, 1003, 945, + 950, 969, 958, 730, 565, 978, 987, 991, 999, 992, + 1007, 1015, 993, 994, 1016, 1006, 1018, 707, 1017, 954, + 850, 957, 1019, 1023, 1028, 302, 1043, 1032, 1038, 1039, + 390, 391, 507, 965, 394, 475, 1041, 1047, 1020, 1048, + 333, 234, 488, 1010, 693, 1008, 977, 379, 380, 381, + 382, 383, 384, 905, 385, 386, 387, 388, 389, -542, + -542, -542, -542, -542, -542, 842, 385, 386, 387, 388, + 389, 844, 93, 995, 649, 997, 815, -237, -237, 689, + 333, 1001, 712, 1002, 687, 235, 236, 508, 492, 720, + 700, 533, 880, 1005, 238, 952, 998, 644, 93, 1012, + 953, 835, 970, 1040, 371, 1025, 754, 912, 1004, 1013, + 1014, 913, 838, 509, 670, 510, 511, 512, 330, 0, + 513, 514, 0, 515, 516, 0, 0, 2, 3, 0, + 390, 391, 0, 0, 905, 0, 905, 0, 0, 0, + 0, 0, 0, 0, 93, 1029, 0, 0, 1031, 0, + 0, 4, 5, 0, 0, 6, -21, 7, -21, 8, + 0, 0, 9, 0, 0, 0, 0, 0, 0, 0, + 733, 0, 10, 0, 0, 0, 0, 0, 0, 1044, + 0, 733, 0, 1045, 1046, 93, 0, 0, 11, 0, + 0, 733, 12, 13, 93, 0, 0, 14, 1050, 390, + 391, 0, 0, 15, 0, 16, 17, 0, 18, 0, + 0, 390, 391, 19, 20, 21, 22, 23, 0, 24, + 25, 0, 0, 26, 27, 28, 29, 30, 31, 32, + 33, 34, 35, 36, 0, 37, 0, 38, 39, 0, + 0, 40, 41, 42, 0, 43, 0, 44, 0, 0, + 45, 46, 0, 0, 47, 48, 49, 0, 0, 0, + 0, 0, 0, 0, 50, 0, 0, 51, 52, 53, + 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, + 0, 0, 64, 0, 0, 65, 66, 67, 68, 0, + 0, 0, 652, 69, 373, 374, 375, 376, 377, 378, + 0, 379, 380, 381, 382, 383, 384, 0, 385, 386, + 387, 388, 389, 934, 0, 373, 374, 375, 376, 377, + 378, 0, 379, 380, 381, 382, 383, 384, 0, 385, + 386, 387, 388, 389, 1034, 0, 373, 374, 375, 376, + 377, 378, 0, 379, 380, 381, 382, 383, 384, 0, + 385, 386, 387, 388, 389, 1035, 0, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 1049, 0, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 926, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 870, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 0, 0, 0, + 0, 0, 135, 136, 0, 0, 0, 0, 137, 138, + 139, 140, 141, 390, 391, 0, 0, 0, 0, 0, + 0, 0, 0, 142, 143, 144, 145, 146, 147, 148, + 0, 149, 150, 151, 390, 391, 152, 153, 154, 0, + 155, 156, 157, 158, 159, 0, 160, 0, 0, 0, + 0, 0, 0, 0, 0, 390, 391, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 390, 391, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 390, 391, 0, + 0, 162, 0, 0, 0, 0, 0, 163, 164, 0, + 0, 0, 0, 165, 0, 0, 613, 390, 391, 0, + 0, 0, 166, 167, 0, 168, 169, 0, 0, 170, + 171, 562, 0, 0, 0, 0, 0, 390, 391, 926, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 996, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 1030, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 578, 390, 391, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 585, 390, 391, 373, + 374, 375, 376, 377, 378, 0, 379, 380, 381, 382, + 383, 384, 0, 385, 386, 387, 388, 389, -239, -239, + -239, -239, -239, -239, 0, -239, -239, -239, -239, -239, + -239, 0, -239, -239, -239, -239, -239, -238, -238, -238, + -238, -238, -238, 0, -238, -238, -238, -238, -238, -238, + 0, -238, -238, -238, -238, -238, 0, 0, 0, 390, + 391, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 390, + 391, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 390, + 391, 373, 374, 375, 376, 377, 378, 0, 379, 380, + 381, 382, 383, 384, 0, 385, 386, 387, 388, 389, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 599, 390, 391, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, -239, -239, -239, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, -238, -238, -238, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 373, 374, 375, 376, + 377, 378, 0, 379, 380, 381, 382, 383, 384, 0, + 385, 386, 387, 388, 389, 0, 0, 0, 0, 613, + 390, 391, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 650, 390, + 391, 373, 374, 375, 376, 377, 378, 0, 379, 380, + 381, 382, 383, 384, 0, 385, 386, 387, 388, 389, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 373, + 374, 375, 376, 377, 378, 0, 379, 380, 381, 382, + 383, 384, 0, 385, 386, 387, 388, 389, 0, 0, + 0, 0, 0, 0, 135, 136, 0, 0, 0, 0, + 137, 138, 139, 140, 141, 0, 653, 390, 391, 0, + 0, 0, 0, 0, 0, 142, 143, 144, 145, 146, + 147, 148, 399, 149, 150, 151, 390, 391, 152, 153, + 154, 0, 155, 156, 157, 158, 159, 0, 160, 0, + 0, 0, 0, 0, 779, 390, 391, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 373, 374, 375, 376, + 377, 378, 0, 379, 380, 381, 382, 383, 384, 0, + 385, 386, 387, 388, 389, 0, 0, 0, 0, 780, + 390, 391, 0, 162, 0, 0, 0, 0, 0, 163, + 164, 0, 0, 0, 0, 165, 0, 0, 781, 390, + 391, 0, 0, 0, 166, 167, 0, 168, 169, 0, + 0, 918, 171, 562, 0, 0, 0, 782, 390, 391, + 373, 374, 375, 376, 377, 378, 0, 379, 380, 381, + 382, 383, 384, 0, 385, 386, 387, 388, 389, 373, + 374, 375, 376, 377, 378, 0, 379, 380, 381, 382, + 383, 384, 0, 385, 386, 387, 388, 389, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 783, 390, 391, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 784, 390, 391, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 373, 374, 375, 376, + 377, 378, 0, 379, 380, 381, 382, 383, 384, 0, + 385, 386, 387, 388, 389, 373, 374, 375, 376, 377, + 378, 0, 379, 380, 381, 382, 383, 384, 0, 385, + 386, 387, 388, 389, 0, 0, 0, 0, 785, 390, + 391, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 786, 390, 391, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 787, 390, 391, 373, + 374, 375, 376, 377, 378, 0, 379, 380, 381, 382, + 383, 384, 0, 385, 386, 387, 388, 389, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 788, 390, 391, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 789, 390, 391, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 790, 390, 391, 373, 374, 375, 376, + 377, 378, 0, 379, 380, 381, 382, 383, 384, 0, + 385, 386, 387, 388, 389, 373, 374, 375, 376, 377, + 378, 0, 379, 380, 381, 382, 383, 384, 0, 385, + 386, 387, 388, 389, 373, 374, 375, 376, 377, 378, + 0, 379, 380, 381, 382, 383, 384, 0, 385, 386, + 387, 388, 389, 0, 0, 0, 0, 791, 390, 391, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 852, 390, 391, 373, + 374, 375, 376, 377, 378, 0, 379, 380, 381, 382, + 383, 384, 0, 385, 386, 387, 388, 389, 373, 374, + 375, 376, 377, 378, 0, 379, 380, 381, 382, 383, + 384, 0, 385, 386, 387, 388, 389, 373, 374, 375, + 376, 377, 378, 0, 379, 380, 381, 382, 383, 384, + 0, 385, 386, 387, 388, 389, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 930, 390, 391, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 933, 390, 391, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 946, 390, 391, 373, 374, 375, 376, 377, + 378, 0, 379, 380, 381, 382, 383, 384, 0, 385, + 386, 387, 388, 389, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 702, 0, 947, 390, 391, + 0, 0, 132, 0, 0, 0, 0, 0, 0, 0, + 133, 134, 703, 0, 0, 0, 1022, 390, 391, 0, + 0, 0, 0, 0, 135, 136, 0, 0, 0, 0, + 137, 138, 139, 140, 141, 1033, 390, 391, 0, 0, + 0, 0, 0, 0, 0, 142, 143, 144, 145, 146, + 147, 148, 0, 149, 150, 151, 0, 0, 152, 153, + 154, 0, 155, 156, 157, 158, 159, 439, 160, 0, + 0, 0, 440, 441, 0, 442, 443, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 444, 445, 446, + 447, 448, 449, 450, 0, 451, 452, 453, 0, 0, + 454, 455, 456, 0, 814, 457, 458, 459, 460, 0, + 461, 132, 0, 0, 390, 391, 161, 0, 0, 133, + 134, 0, 0, 162, 0, 0, 0, 0, 0, 163, + 164, 0, 0, 135, 136, 165, 0, 0, 0, 137, + 138, 139, 140, 141, 166, 167, 0, 168, 169, 0, + 0, 170, 171, 172, 142, 143, 144, 145, 146, 147, + 148, 0, 149, 150, 151, 0, 0, 152, 153, 154, + 0, 155, 156, 157, 158, 159, 0, 160, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 462, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 904, 0, 0, 0, 0, 0, 0, + 132, 0, 0, 0, 0, 161, 0, 0, 133, 134, + 0, 0, 162, 0, 0, 0, 0, 0, 163, 164, + 0, 0, 135, 136, 165, 0, 0, 0, 137, 138, + 139, 140, 141, 166, 167, 0, 168, 169, 0, 0, + 170, 171, 172, 142, 143, 144, 145, 146, 147, 148, + 0, 149, 150, 151, 0, 0, 152, 153, 154, 0, + 155, 156, 157, 158, 159, 0, 160, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 924, 0, 0, 0, 0, 0, 0, 132, + 0, 0, 0, 0, 161, 0, 0, 133, 134, 0, + 0, 162, 0, 0, 0, 0, 0, 163, 164, 0, + 0, 135, 136, 165, 0, 0, 0, 137, 138, 139, + 140, 141, 166, 167, 0, 168, 169, 0, 0, 170, + 171, 172, 142, 143, 144, 145, 146, 147, 148, 0, + 149, 150, 151, 0, 0, 152, 153, 154, 0, 155, + 156, 157, 158, 159, 0, 160, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 472, 0, 0, 0, 0, 0, 132, 0, + 0, 0, 0, 161, 0, 0, 133, 134, 473, 0, + 162, 0, 0, 0, 0, 0, 163, 164, 0, 0, + 135, 136, 165, 0, 0, 0, 137, 138, 139, 140, + 141, 166, 167, 0, 168, 169, 0, 0, 170, 171, + 172, 142, 143, 144, 145, 146, 147, 148, 0, 149, + 150, 151, 0, 0, 152, 153, 154, 0, 155, 156, + 157, 158, 159, 0, 160, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 632, 0, 0, 0, 0, 0, 132, 0, 0, + 0, 0, 161, 0, 0, 133, 134, 0, 633, 162, + 0, 0, 0, 0, 0, 163, 164, 0, 0, 135, + 136, 165, 0, 0, 0, 137, 138, 139, 140, 141, + 166, 167, 0, 168, 169, 0, 0, 170, 171, 172, + 142, 143, 144, 145, 146, 147, 148, 0, 149, 150, + 151, 0, 0, 152, 153, 154, 0, 155, 156, 157, + 158, 159, 0, 160, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 721, 0, 0, 0, 0, 0, 132, 0, 0, 0, + 0, 161, 0, 0, 133, 134, 473, 0, 162, 0, + 0, 0, 0, 0, 163, 164, 0, 0, 135, 136, + 165, 0, 0, 0, 137, 138, 139, 140, 141, 166, + 167, 0, 168, 169, 0, 0, 170, 171, 172, 142, + 143, 144, 145, 146, 147, 148, 0, 149, 150, 151, + 0, 0, 152, 153, 154, 0, 155, 156, 157, 158, + 159, 0, 160, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 615, + 0, 0, 0, 0, 0, 132, 0, 0, 0, 0, + 161, 0, 0, 133, 134, 0, 0, 162, 0, 0, + 0, 0, 0, 163, 164, 0, 0, 135, 136, 165, + 0, 0, 0, 137, 138, 139, 140, 141, 166, 167, + 0, 168, 169, 0, 0, 170, 171, 172, 142, 143, + 144, 145, 146, 147, 148, 0, 149, 150, 151, 0, + 0, 152, 153, 154, 0, 155, 156, 157, 158, 159, + 0, 160, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 637, 0, + 0, 0, 0, 0, 132, 0, 0, 0, 0, 161, + 0, 0, 133, 134, 0, 0, 162, 0, 0, 0, + 0, 0, 163, 164, 0, 0, 135, 136, 165, 0, + 0, 0, 137, 138, 139, 140, 141, 166, 167, 0, + 168, 169, 0, 0, 170, 171, 172, 142, 143, 144, + 145, 146, 147, 148, 0, 149, 150, 151, 0, 0, + 152, 153, 154, 0, 155, 156, 157, 158, 159, 0, + 160, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 639, 0, 0, + 0, 0, 0, 132, 0, 0, 0, 0, 161, 0, + 0, 133, 134, 0, 0, 162, 0, 0, 0, 0, + 0, 163, 164, 0, 0, 135, 136, 165, 0, 0, + 0, 137, 138, 139, 140, 141, 166, 167, 0, 168, + 169, 0, 0, 170, 171, 172, 142, 143, 144, 145, + 146, 147, 148, 0, 149, 150, 151, 0, 0, 152, + 153, 154, 0, 155, 156, 157, 158, 159, 0, 160, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 132, 0, 0, 0, 0, 161, 0, 0, + 133, 134, 0, 0, 162, 0, 0, 0, 0, 0, + 163, 164, 0, 0, 135, 136, 165, 0, 0, 0, + 137, 138, 139, 140, 141, 166, 167, 0, 168, 169, + 0, 0, 170, 171, 172, 142, 143, 144, 145, 146, + 147, 148, 0, 149, 150, 151, 0, 0, 152, 153, + 154, 0, 155, 156, 157, 158, 159, 0, 160, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 161, 0, 0, 0, + 0, 0, 0, 162, 0, 0, 0, 0, 0, 163, + 164, 0, 0, 0, 0, 165, 0, 0, 0, 0, + 0, 0, 0, 0, 166, 167, 132, 168, 169, 0, + 0, 170, 171, 172, 133, 134, 660, 173, 661, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 135, 136, + 0, 0, 0, 0, 137, 138, 139, 140, 141, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 142, + 143, 144, 145, 146, 147, 148, 0, 149, 150, 151, + 0, 0, 152, 153, 154, 0, 155, 156, 157, 158, + 159, 0, 160, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 132, 0, 0, 0, 0, + 161, 0, 0, 133, 134, 473, 0, 162, 0, 0, + 0, 0, 0, 163, 164, 0, 0, 135, 136, 165, + 0, 0, 0, 137, 138, 139, 140, 141, 166, 167, + 0, 168, 169, 0, 0, 170, 171, 662, 142, 143, + 144, 145, 146, 147, 148, 0, 149, 150, 151, 0, + 0, 152, 153, 154, 0, 155, 156, 157, 158, 159, + 0, 160, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 132, 0, 0, 0, 0, 161, + 0, 0, 133, 134, 548, 0, 162, 0, 0, 0, + 0, 0, 163, 164, 0, 0, 135, 136, 165, 0, + 0, 0, 137, 138, 139, 140, 141, 166, 167, 0, + 168, 169, 0, 0, 526, 171, 172, 142, 143, 144, + 145, 146, 147, 148, 0, 149, 150, 151, 0, 0, + 152, 153, 154, 0, 155, 156, 157, 158, 159, 0, + 160, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 132, 0, 0, 0, 0, 161, 0, + 0, 133, 134, 473, 0, 162, 0, 0, 0, 0, + 0, 163, 164, 0, 0, 135, 136, 165, 0, 0, + 0, 137, 138, 139, 140, 141, 166, 167, 0, 168, + 169, 0, 0, 170, 171, 172, 142, 143, 144, 145, + 146, 147, 148, 0, 149, 150, 151, 0, 0, 152, + 153, 154, 0, 155, 156, 157, 158, 159, 0, 160, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 132, 0, 0, 0, 0, 161, 0, 0, + 133, 134, 726, 0, 162, 0, 0, 0, 0, 0, + 163, 164, 0, 0, 135, 136, 165, 0, 0, 0, + 137, 138, 139, 140, 141, 166, 167, 0, 168, 169, + 0, 0, 170, 171, 172, 142, 143, 144, 145, 146, + 147, 148, 0, 149, 150, 151, 0, 0, 152, 153, + 154, 0, 155, 156, 157, 158, 159, 0, 160, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 161, 0, 0, 0, + 0, 0, 0, 162, 0, 0, 0, 0, 0, 163, + 164, 0, 132, 0, 0, 165, 0, 0, 0, 0, + 133, 134, 0, 0, 166, 167, 0, 168, 169, 0, + 0, 170, 171, 172, 135, 136, 9, 0, 0, 0, + 137, 138, 139, 140, 141, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 142, 143, 144, 145, 146, + 147, 148, 0, 149, 150, 151, 0, 0, 152, 153, + 154, 0, 155, 156, 157, 158, 159, 0, 160, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 132, 0, 0, 0, 0, 161, 0, 0, 133, + 134, 703, 0, 162, 0, 0, 0, 0, 0, 163, + 164, 0, 0, 135, 136, 165, 0, 0, 0, 137, + 138, 139, 140, 141, 166, 167, 0, 168, 169, 0, + 0, 170, 171, 172, 142, 143, 144, 145, 146, 147, + 148, 0, 149, 150, 151, 0, 0, 152, 153, 154, + 0, 155, 156, 157, 158, 159, 0, 160, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 132, 0, 0, 0, 0, 161, 0, 0, 133, 134, + 1011, 0, 162, 0, 0, 0, 0, 0, 163, 164, + 0, 0, 135, 136, 165, 0, 0, 0, 137, 138, + 139, 140, 141, 166, 167, 0, 168, 169, 0, 0, + 170, 171, 172, 142, 143, 144, 145, 146, 147, 148, + 0, 149, 150, 151, 0, 0, 152, 153, 154, 0, + 155, 156, 157, 158, 159, 0, 160, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 132, + 0, 0, 0, 0, 161, 0, 0, 133, 134, 0, + 0, 162, 0, 0, 0, 0, 0, 163, 164, 0, + 0, 135, 136, 165, 0, 0, 0, 137, 138, 139, + 140, 141, 166, 167, 0, 168, 169, 0, 0, 170, + 171, 172, 142, 143, 144, 145, 146, 147, 148, 0, + 149, 150, 151, 0, 0, 152, 153, 154, 0, 155, + 156, 157, 158, 159, 0, 160, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 132, 0, + 0, 0, 0, 161, 0, 0, 133, 134, 0, 0, + 162, 0, 0, 0, 0, 0, 163, 164, 0, 0, + 135, 136, 165, 0, 0, 0, 137, 138, 139, 140, + 141, 166, 167, 0, 168, 169, 0, 0, 170, 171, + 172, 142, 143, 144, 145, 146, 147, 148, 0, 149, + 150, 151, 0, 0, 152, 153, 154, 0, 155, 156, + 157, 158, 159, 0, 160, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 132, 0, 0, + 0, 0, 161, 0, 0, 133, 134, 0, 0, 162, + 0, 0, 0, 0, 0, 163, 164, 0, 0, 135, + 136, 165, 0, 0, 0, 137, 138, 139, 140, 141, + 166, 167, 0, 168, 169, 0, 0, 170, 171, 363, + 142, 143, 144, 145, 146, 147, 148, 0, 149, 150, + 151, 0, 0, 152, 153, 154, 0, 155, 156, 157, + 158, 159, 0, 160, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 132, 0, 0, 0, + 0, 161, 0, 0, 133, 134, 0, 0, 162, 0, + 0, 0, 0, 0, 163, 164, 0, 0, 135, 136, + 165, 0, 0, 0, 137, 138, 139, 140, 141, 166, + 167, 0, 168, 169, 0, 0, 170, 431, 172, 142, + 143, 144, 145, 146, 147, 148, 0, 149, 150, 151, + 0, 0, 152, 153, 154, 0, 155, 156, 157, 158, + 159, 0, 160, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 132, 0, 0, 0, 0, + 161, 0, 0, 133, 134, 0, 0, 162, 0, 0, + 0, 0, 0, 163, 164, 0, 0, 135, 136, 165, + 0, 0, 0, 137, 138, 139, 140, 141, 166, 167, + 0, 168, 169, 0, 0, 170, 529, 530, 142, 143, + 144, 145, 146, 147, 148, 0, 149, 150, 151, 0, + 0, 152, 153, 154, 0, 155, 156, 157, 158, 159, + 0, 160, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 132, 0, 0, 0, 0, 161, + 0, 0, 133, 134, 0, 0, 162, 0, 0, 0, + 0, 0, 163, 164, 0, 0, 135, 136, 165, 0, + 0, 0, 137, 138, 139, 140, 141, 166, 167, 0, + 168, 169, 0, 0, 918, 171, 363, 142, 143, 144, + 145, 146, 147, 148, 0, 149, 150, 151, 0, 0, + 152, 153, 154, 0, 155, 156, 157, 158, 159, 0, + 160, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 161, 0, + 0, 0, 0, 0, 0, 162, 0, 0, 0, 0, + 0, 163, 164, 0, 0, 0, 0, 165, 0, 0, + 0, 0, 0, 0, 0, 0, 166, 167, 0, 168, + 169, 0, 0, 170, 171, 955, 311, 312, 422, 0, + 423, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 135, 136, 0, 0, 0, 0, 137, 138, 139, 140, + 141, 0, 0, 314, 315, 316, 317, 318, 0, 319, + 320, 142, 143, 144, 145, 146, 147, 148, 0, 149, + 150, 151, 0, 0, 152, 153, 154, 0, 155, 156, + 157, 158, 159, 0, 160, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 162, + 0, 0, 0, 0, 0, 163, 164, 0, 0, 0, + 0, 165, 0, 0, 0, 0, 311, 312, 313, 0, + 166, 167, 0, 168, 169, 0, 0, 321, 171, 424, + 135, 136, 0, 0, 0, 0, 137, 138, 139, 140, + 141, 0, 0, 314, 315, 316, 317, 318, 0, 319, + 320, 142, 143, 144, 145, 146, 147, 148, 0, 149, + 150, 151, 311, 312, 152, 153, 154, 0, 155, 156, + 157, 158, 159, 0, 160, 0, 135, 136, 0, 0, + 0, 0, 137, 138, 139, 140, 141, 0, 0, 314, + 315, 316, 317, 318, 0, 319, 320, 142, 143, 144, + 145, 146, 147, 148, 0, 149, 150, 151, 0, 0, + 152, 153, 154, 0, 155, 156, 157, 158, 159, 0, + 160, 0, 0, 0, 0, 0, 0, 0, 0, 162, + 0, 0, 0, 0, 0, 163, 164, 0, 0, 0, + 0, 165, 0, 0, 0, 0, 0, 0, 0, 0, + 166, 167, 0, 168, 169, 0, 0, 321, 171, 322, + 0, 0, 0, 0, 0, 0, 5, 0, 0, 6, + 0, 7, 0, 8, 0, 162, 9, 0, 0, 0, + 0, 163, 164, 0, 0, 0, 10, 165, 0, 0, + 0, 0, 0, 0, 0, 0, 166, 167, 0, 168, + 169, 0, 11, 321, 171, 424, 12, 13, 0, 0, + 0, 14, 0, 0, 0, 0, 0, 15, 0, 16, + 17, 0, 18, 0, 0, 0, 0, 19, 20, 21, + 22, 23, 0, 24, 25, 0, 0, 26, 27, 28, + 29, 30, 31, 32, 33, 34, 35, 36, 0, 37, + 0, 38, 39, 0, 0, 40, 41, 42, 0, 43, + 0, 44, 0, 0, 45, 46, 0, 0, 47, 48, + 49, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 0, 52, 53, 54, 55, 56, 57, 58, 59, + 60, 61, 62, 63, 0, 0, 64, 0, 0, 65, + 66, 67, 68, 5, 0, 0, 6, 487, 7, 0, + 8, 0, 0, 9, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 10, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, + 0, 0, 0, 12, 13, 0, 0, 0, 14, 0, + 0, 0, 0, 0, 15, 0, 16, 17, 0, 18, + 0, 0, 0, 0, 19, 20, 21, 22, 23, 0, + 24, 25, 0, 0, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 0, 37, 0, 38, 39, + 0, 0, 40, 41, 42, 0, 43, 0, 44, 0, + 0, 45, 46, 0, 0, 47, 48, 49, 0, 0, + 0, 0, 0, 0, 0, 50, 0, 0, 0, 52, + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, + 63, 8, 0, 64, 9, 0, 65, 66, 67, 68, + 0, 0, 0, 0, 10, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 11, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, + 18, 0, 746, 0, 0, 19, 20, 21, 22, 23, + 0, 0, 25, 0, 0, 26, 27, 28, 29, 30, + 31, 32, 33, 34, 35, 0, 0, 8, 0, 0, + 9, 0, 0, 0, 41, 0, 0, 0, 0, 44, + 10, 0, 0, 0, 0, 0, 47, 0, 49, 0, + 0, 0, 0, 0, 0, 0, 11, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 59, 60, 61, + 62, 15, 0, 0, 0, 0, 18, 0, 0, 67, + 68, 19, 20, 21, 22, 23, 0, 0, 25, 0, + 0, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 0, 0, 0, 0, 0, 825, 0, 0, 0, + 41, 0, 0, 0, 0, 44, 0, 0, 0, 0, + 0, 0, 47, 0, 49, 0, 0, 0, 0, 0, + 0, 0, 11, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 59, 60, 61, 62, 15, 0, 0, + 0, 0, 18, 826, 0, 67, 68, 19, 20, 827, + 0, 23, 0, 0, 25, 0, 0, 26, 27, 28, + 29, 30, 31, 32, 33, 34, 35, 0, 0, 0, + 0, 0, 825, 0, 0, 0, 41, 0, 0, 0, + 0, 44, 0, 0, 0, 0, 0, 0, 47, 0, + 49, 0, 0, 0, 0, 0, 0, 0, 11, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, + 60, 61, 62, 15, 0, 0, 0, 0, 18, 0, + 0, 170, 68, 19, 20, 827, 0, 23, 0, 0, + 25, 0, 0, 26, 27, 28, 29, 30, 31, 32, + 33, 34, 35, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 41, 0, 0, 0, 0, 44, 0, 0, + 0, 0, 0, 0, 47, 0, 49, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 59, 60, 61, 62, 0, + 0, 0, 0, 0, 0, 0, 0, 170, 68 +}; + +#define yypact_value_is_default(Yystate) \ + (!!((Yystate) == (-845))) + +#define yytable_value_is_error(Yytable_value) \ + (!!((Yytable_value) == (-542))) + +static const yytype_int16 yycheck[] = +{ + 11, 295, 1, 185, 15, 101, 219, 18, 104, 240, + 394, 577, 108, 395, 277, 111, 54, 161, 482, 477, + 205, 536, 536, 653, 482, 5, 264, 124, 172, 79, + 268, 81, 82, 161, 3, 3, 86, 3, 274, 710, + 39, 3, 564, 565, 1, 3, 124, 17, 719, 75, + 76, 3, 51, 80, 124, 291, 563, 564, 565, 3, + 87, 19, 20, 21, 3, 31, 722, 37, 38, 768, + 214, 3, 3, 217, 214, 113, 363, 115, 116, 329, + 24, 21, 3, 161, 747, 124, 214, 21, 5, 6, + 7, 8, 9, 10, 51, 12, 13, 14, 15, 16, + 17, 127, 19, 20, 21, 22, 23, 27, 3, 3, + 22, 122, 3, 3, 3, 212, 213, 904, 3, 130, + 131, 132, 219, 21, 3, 112, 3, 45, 3, 44, + 141, 153, 976, 3, 24, 213, 214, 18, 3, 3, + 121, 22, 122, 213, 155, 101, 24, 131, 245, 24, + 161, 198, 3, 3, 3, 3, 3, 3, 3, 24, + 3, 172, 19, 20, 21, 131, 177, 131, 404, 91, + 88, 89, 119, 891, 221, 162, 1020, 18, 428, 160, + 191, 22, 166, 130, 21, 21, 22, 23, 168, 188, + 201, 202, 107, 115, 160, 140, 246, 142, 166, 168, + 987, 163, 166, 214, 160, 160, 217, 206, 23, 167, + 881, 163, 157, 931, 213, 914, 227, 161, 217, 363, + 160, 220, 166, 363, 163, 322, 225, 253, 884, 240, + 327, 163, 163, 167, 331, 363, 5, 900, 265, 24, + 160, 472, 163, 270, 322, 162, 273, 164, 165, 327, + 162, 168, 322, 331, 131, 254, 162, 327, 765, 766, + 767, 331, 140, 21, 162, 501, 502, 237, 163, 163, + 269, 161, 163, 509, 163, 286, 166, 288, 163, 160, + 21, 3, 24, 322, 163, 363, 161, 523, 166, 300, + 301, 166, 331, 163, 305, 526, 161, 254, 534, 163, + 485, 166, 44, 314, 315, 316, 317, 318, 319, 320, + 167, 561, 163, 163, 163, 163, 163, 163, 163, 160, + 163, 608, 609, 322, 611, 162, 576, 424, 164, 165, + 341, 796, 797, 798, 345, 346, 347, 348, 349, 350, + 351, 352, 353, 354, 355, 356, 424, 18, 162, 164, + 165, 22, 363, 122, 424, 18, 19, 20, 21, 22, + 23, 162, 373, 374, 375, 376, 377, 378, 379, 380, + 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, + 391, 166, 846, 18, 395, 424, 530, 3, 846, 847, + 848, 849, 850, 915, 339, 340, 490, 160, 140, 162, + 162, 3, 160, 1033, 126, 163, 22, 133, 915, 659, + 133, 255, 256, 358, 425, 360, 361, 362, 162, 160, + 94, 95, 163, 153, 166, 370, 520, 663, 133, 31, + 162, 813, 162, 471, 160, 161, 562, 160, 282, 3, + 160, 78, 79, 569, 657, 495, 166, 543, 711, 914, + 500, 160, 836, 503, 18, 160, 669, 166, 22, 160, + 18, 472, 756, 701, 22, 562, 1032, 478, 162, 29, + 614, 31, 569, 162, 571, 572, 573, 574, 575, 160, + 491, 162, 718, 990, 562, 496, 160, 122, 131, 160, + 721, 569, 562, 571, 572, 573, 574, 575, 3, 569, + 163, 571, 572, 573, 574, 575, 1021, 1021, 693, 796, + 797, 798, 162, 18, 525, 526, 162, 22, 662, 530, + 770, 771, 772, 773, 774, 536, 3, 1042, 1042, 131, + 161, 162, 571, 572, 573, 574, 575, 83, 537, 85, + 539, 18, 1006, 123, 641, 22, 160, 546, 1006, 560, + 8, 9, 10, 4, 12, 13, 14, 15, 16, 17, + 657, 19, 20, 21, 22, 23, 577, 664, 579, 160, + 161, 162, 669, 18, 19, 20, 21, 22, 23, 18, + 19, 20, 21, 22, 23, 821, 664, 24, 41, 19, + 20, 21, 22, 23, 664, 161, 162, 608, 609, 166, + 611, 162, 163, 614, 615, 847, 848, 849, 850, 903, + 134, 135, 136, 683, 21, 22, 23, 19, 20, 83, + 84, 632, 633, 37, 38, 3, 637, 3, 639, 123, + 124, 160, 643, 3, 162, 162, 162, 819, 168, 162, + 162, 652, 738, 654, 740, 656, 162, 646, 162, 162, + 162, 662, 796, 749, 653, 886, 162, 3, 162, 162, + 162, 162, 162, 162, 675, 664, 677, 162, 3, 162, + 162, 768, 671, 162, 162, 162, 912, 162, 162, 132, + 691, 692, 160, 3, 160, 138, 139, 160, 982, 163, + 768, 702, 5, 160, 3, 160, 162, 160, 768, 160, + 153, 154, 3, 156, 157, 160, 164, 165, 161, 708, + 721, 5, 6, 7, 8, 9, 10, 3, 12, 13, + 14, 15, 16, 17, 160, 19, 20, 21, 22, 23, + 3, 5, 161, 3, 3, 163, 3, 3, 162, 22, + 751, 5, 3, 3, 163, 163, 3, 3, 163, 760, + 162, 160, 988, 3, 160, 163, 3, 162, 5, 6, + 7, 8, 9, 10, 162, 12, 13, 14, 15, 16, + 17, 162, 19, 20, 21, 22, 23, 162, 160, 163, + 161, 3, 3, 23, 3, 796, 797, 798, 3, 3, + 163, 4, 163, 22, 163, 163, 160, 893, 22, 162, + 26, 21, 813, 814, 163, 160, 902, 163, 4, 36, + 122, 955, 3, 160, 162, 160, 10, 914, 12, 13, + 14, 15, 16, 17, 160, 19, 20, 21, 22, 23, + 163, 3, 162, 162, 5, 163, 914, 5, 935, 163, + 162, 160, 163, 160, 914, 160, 4, 163, 3, 163, + 82, 122, 163, 163, 3, 22, 160, 868, 163, 870, + 167, 872, 160, 160, 163, 168, 82, 163, 163, 160, + 164, 165, 25, 160, 168, 886, 160, 22, 974, 160, + 891, 51, 254, 950, 485, 948, 897, 12, 13, 14, + 15, 16, 17, 904, 19, 20, 21, 22, 23, 12, + 13, 14, 15, 16, 17, 673, 19, 20, 21, 22, + 23, 677, 911, 924, 405, 926, 927, 164, 165, 481, + 931, 932, 505, 934, 480, 78, 79, 80, 260, 525, + 493, 289, 715, 944, 52, 868, 927, 397, 937, 959, + 870, 662, 890, 1016, 955, 985, 541, 757, 937, 960, + 961, 760, 664, 106, 435, 108, 109, 110, 124, -1, + 113, 114, -1, 116, 117, -1, -1, 0, 1, -1, + 164, 165, -1, -1, 985, -1, 987, -1, -1, -1, + -1, -1, -1, -1, 983, 996, -1, -1, 999, -1, + -1, 24, 25, -1, -1, 28, 29, 30, 31, 32, + -1, -1, 35, -1, -1, -1, -1, -1, -1, -1, + 1021, -1, 45, -1, -1, -1, -1, -1, -1, 1030, + -1, 1032, -1, 1034, 1035, 1024, -1, -1, 61, -1, + -1, 1042, 65, 66, 1033, -1, -1, 70, 1049, 164, + 165, -1, -1, 76, -1, 78, 79, -1, 81, -1, + -1, 164, 165, 86, 87, 88, 89, 90, -1, 92, + 93, -1, -1, 96, 97, 98, 99, 100, 101, 102, + 103, 104, 105, 106, -1, 108, -1, 110, 111, -1, + -1, 114, 115, 116, -1, 118, -1, 120, -1, -1, + 123, 124, -1, -1, 127, 128, 129, -1, -1, -1, + -1, -1, -1, -1, 137, -1, -1, 140, 141, 142, + 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, + -1, -1, 155, -1, -1, 158, 159, 160, 161, -1, + -1, -1, 3, 166, 5, 6, 7, 8, 9, 10, + -1, 12, 13, 14, 15, 16, 17, -1, 19, 20, + 21, 22, 23, 3, -1, 5, 6, 7, 8, 9, + 10, -1, 12, 13, 14, 15, 16, 17, -1, 19, + 20, 21, 22, 23, 3, -1, 5, 6, 7, 8, + 9, 10, -1, 12, 13, 14, 15, 16, 17, -1, + 19, 20, 21, 22, 23, 3, -1, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, 3, -1, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 4, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 4, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, -1, -1, -1, + -1, -1, 33, 34, -1, -1, -1, -1, 39, 40, + 41, 42, 43, 164, 165, -1, -1, -1, -1, -1, + -1, -1, -1, 54, 55, 56, 57, 58, 59, 60, + -1, 62, 63, 64, 164, 165, 67, 68, 69, -1, + 71, 72, 73, 74, 75, -1, 77, -1, -1, -1, + -1, -1, -1, -1, -1, 164, 165, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, 164, 165, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 164, 165, -1, + -1, 132, -1, -1, -1, -1, -1, 138, 139, -1, + -1, -1, -1, 144, -1, -1, 163, 164, 165, -1, + -1, -1, 153, 154, -1, 156, 157, -1, -1, 160, + 161, 162, -1, -1, -1, -1, -1, 164, 165, 4, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, 4, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, 4, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 163, 164, 165, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 163, 164, 165, 5, + 6, 7, 8, 9, 10, -1, 12, 13, 14, 15, + 16, 17, -1, 19, 20, 21, 22, 23, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, -1, -1, -1, 164, + 165, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 164, + 165, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 164, + 165, 5, 6, 7, 8, 9, 10, -1, 12, 13, + 14, 15, 16, 17, -1, 19, 20, 21, 22, 23, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 163, 164, 165, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 163, 164, 165, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 163, 164, 165, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, 5, 6, 7, 8, + 9, 10, -1, 12, 13, 14, 15, 16, 17, -1, + 19, 20, 21, 22, 23, -1, -1, -1, -1, 163, + 164, 165, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 163, 164, + 165, 5, 6, 7, 8, 9, 10, -1, 12, 13, + 14, 15, 16, 17, -1, 19, 20, 21, 22, 23, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, 5, + 6, 7, 8, 9, 10, -1, 12, 13, 14, 15, + 16, 17, -1, 19, 20, 21, 22, 23, -1, -1, + -1, -1, -1, -1, 33, 34, -1, -1, -1, -1, + 39, 40, 41, 42, 43, -1, 163, 164, 165, -1, + -1, -1, -1, -1, -1, 54, 55, 56, 57, 58, + 59, 60, 160, 62, 63, 64, 164, 165, 67, 68, + 69, -1, 71, 72, 73, 74, 75, -1, 77, -1, + -1, -1, -1, -1, 163, 164, 165, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, 5, 6, 7, 8, + 9, 10, -1, 12, 13, 14, 15, 16, 17, -1, + 19, 20, 21, 22, 23, -1, -1, -1, -1, 163, + 164, 165, -1, 132, -1, -1, -1, -1, -1, 138, + 139, -1, -1, -1, -1, 144, -1, -1, 163, 164, + 165, -1, -1, -1, 153, 154, -1, 156, 157, -1, + -1, 160, 161, 162, -1, -1, -1, 163, 164, 165, + 5, 6, 7, 8, 9, 10, -1, 12, 13, 14, + 15, 16, 17, -1, 19, 20, 21, 22, 23, 5, + 6, 7, 8, 9, 10, -1, 12, 13, 14, 15, + 16, 17, -1, 19, 20, 21, 22, 23, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 163, 164, 165, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 163, 164, 165, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, 5, 6, 7, 8, + 9, 10, -1, 12, 13, 14, 15, 16, 17, -1, + 19, 20, 21, 22, 23, 5, 6, 7, 8, 9, + 10, -1, 12, 13, 14, 15, 16, 17, -1, 19, + 20, 21, 22, 23, -1, -1, -1, -1, 163, 164, + 165, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 163, 164, 165, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 163, 164, 165, 5, + 6, 7, 8, 9, 10, -1, 12, 13, 14, 15, + 16, 17, -1, 19, 20, 21, 22, 23, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 163, 164, 165, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 163, 164, 165, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 163, 164, 165, 5, 6, 7, 8, + 9, 10, -1, 12, 13, 14, 15, 16, 17, -1, + 19, 20, 21, 22, 23, 5, 6, 7, 8, 9, + 10, -1, 12, 13, 14, 15, 16, 17, -1, 19, + 20, 21, 22, 23, 5, 6, 7, 8, 9, 10, + -1, 12, 13, 14, 15, 16, 17, -1, 19, 20, + 21, 22, 23, -1, -1, -1, -1, 163, 164, 165, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 163, 164, 165, 5, + 6, 7, 8, 9, 10, -1, 12, 13, 14, 15, + 16, 17, -1, 19, 20, 21, 22, 23, 5, 6, + 7, 8, 9, 10, -1, 12, 13, 14, 15, 16, + 17, -1, 19, 20, 21, 22, 23, 5, 6, 7, + 8, 9, 10, -1, 12, 13, 14, 15, 16, 17, + -1, 19, 20, 21, 22, 23, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 163, 164, 165, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 163, 164, 165, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 163, 164, 165, 5, 6, 7, 8, 9, + 10, -1, 12, 13, 14, 15, 16, 17, -1, 19, + 20, 21, 22, 23, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 4, -1, 163, 164, 165, + -1, -1, 11, -1, -1, -1, -1, -1, -1, -1, + 19, 20, 21, -1, -1, -1, 163, 164, 165, -1, + -1, -1, -1, -1, 33, 34, -1, -1, -1, -1, + 39, 40, 41, 42, 43, 163, 164, 165, -1, -1, + -1, -1, -1, -1, -1, 54, 55, 56, 57, 58, + 59, 60, -1, 62, 63, 64, -1, -1, 67, 68, + 69, -1, 71, 72, 73, 74, 75, 34, 77, -1, + -1, -1, 39, 40, -1, 42, 43, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 54, 55, 56, + 57, 58, 59, 60, -1, 62, 63, 64, -1, -1, + 67, 68, 69, -1, 4, 72, 73, 74, 75, -1, + 77, 11, -1, -1, 164, 165, 125, -1, -1, 19, + 20, -1, -1, 132, -1, -1, -1, -1, -1, 138, + 139, -1, -1, 33, 34, 144, -1, -1, -1, 39, + 40, 41, 42, 43, 153, 154, -1, 156, 157, -1, + -1, 160, 161, 162, 54, 55, 56, 57, 58, 59, + 60, -1, 62, 63, 64, -1, -1, 67, 68, 69, + -1, 71, 72, 73, 74, 75, -1, 77, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 160, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, + 11, -1, -1, -1, -1, 125, -1, -1, 19, 20, + -1, -1, 132, -1, -1, -1, -1, -1, 138, 139, + -1, -1, 33, 34, 144, -1, -1, -1, 39, 40, + 41, 42, 43, 153, 154, -1, 156, 157, -1, -1, + 160, 161, 162, 54, 55, 56, 57, 58, 59, 60, + -1, 62, 63, 64, -1, -1, 67, 68, 69, -1, + 71, 72, 73, 74, 75, -1, 77, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 4, -1, -1, -1, -1, -1, -1, 11, + -1, -1, -1, -1, 125, -1, -1, 19, 20, -1, + -1, 132, -1, -1, -1, -1, -1, 138, 139, -1, + -1, 33, 34, 144, -1, -1, -1, 39, 40, 41, + 42, 43, 153, 154, -1, 156, 157, -1, -1, 160, + 161, 162, 54, 55, 56, 57, 58, 59, 60, -1, + 62, 63, 64, -1, -1, 67, 68, 69, -1, 71, + 72, 73, 74, 75, -1, 77, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 5, -1, -1, -1, -1, -1, 11, -1, + -1, -1, -1, 125, -1, -1, 19, 20, 21, -1, + 132, -1, -1, -1, -1, -1, 138, 139, -1, -1, + 33, 34, 144, -1, -1, -1, 39, 40, 41, 42, + 43, 153, 154, -1, 156, 157, -1, -1, 160, 161, + 162, 54, 55, 56, 57, 58, 59, 60, -1, 62, + 63, 64, -1, -1, 67, 68, 69, -1, 71, 72, + 73, 74, 75, -1, 77, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 5, -1, -1, -1, -1, -1, 11, -1, -1, + -1, -1, 125, -1, -1, 19, 20, -1, 22, 132, + -1, -1, -1, -1, -1, 138, 139, -1, -1, 33, + 34, 144, -1, -1, -1, 39, 40, 41, 42, 43, + 153, 154, -1, 156, 157, -1, -1, 160, 161, 162, + 54, 55, 56, 57, 58, 59, 60, -1, 62, 63, + 64, -1, -1, 67, 68, 69, -1, 71, 72, 73, + 74, 75, -1, 77, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 5, -1, -1, -1, -1, -1, 11, -1, -1, -1, + -1, 125, -1, -1, 19, 20, 21, -1, 132, -1, + -1, -1, -1, -1, 138, 139, -1, -1, 33, 34, + 144, -1, -1, -1, 39, 40, 41, 42, 43, 153, + 154, -1, 156, 157, -1, -1, 160, 161, 162, 54, + 55, 56, 57, 58, 59, 60, -1, 62, 63, 64, + -1, -1, 67, 68, 69, -1, 71, 72, 73, 74, + 75, -1, 77, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 5, + -1, -1, -1, -1, -1, 11, -1, -1, -1, -1, + 125, -1, -1, 19, 20, -1, -1, 132, -1, -1, + -1, -1, -1, 138, 139, -1, -1, 33, 34, 144, + -1, -1, -1, 39, 40, 41, 42, 43, 153, 154, + -1, 156, 157, -1, -1, 160, 161, 162, 54, 55, + 56, 57, 58, 59, 60, -1, 62, 63, 64, -1, + -1, 67, 68, 69, -1, 71, 72, 73, 74, 75, + -1, 77, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 5, -1, + -1, -1, -1, -1, 11, -1, -1, -1, -1, 125, + -1, -1, 19, 20, -1, -1, 132, -1, -1, -1, + -1, -1, 138, 139, -1, -1, 33, 34, 144, -1, + -1, -1, 39, 40, 41, 42, 43, 153, 154, -1, + 156, 157, -1, -1, 160, 161, 162, 54, 55, 56, + 57, 58, 59, 60, -1, 62, 63, 64, -1, -1, + 67, 68, 69, -1, 71, 72, 73, 74, 75, -1, + 77, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 5, -1, -1, + -1, -1, -1, 11, -1, -1, -1, -1, 125, -1, + -1, 19, 20, -1, -1, 132, -1, -1, -1, -1, + -1, 138, 139, -1, -1, 33, 34, 144, -1, -1, + -1, 39, 40, 41, 42, 43, 153, 154, -1, 156, + 157, -1, -1, 160, 161, 162, 54, 55, 56, 57, + 58, 59, 60, -1, 62, 63, 64, -1, -1, 67, + 68, 69, -1, 71, 72, 73, 74, 75, -1, 77, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 11, -1, -1, -1, -1, 125, -1, -1, + 19, 20, -1, -1, 132, -1, -1, -1, -1, -1, + 138, 139, -1, -1, 33, 34, 144, -1, -1, -1, + 39, 40, 41, 42, 43, 153, 154, -1, 156, 157, + -1, -1, 160, 161, 162, 54, 55, 56, 57, 58, + 59, 60, -1, 62, 63, 64, -1, -1, 67, 68, + 69, -1, 71, 72, 73, 74, 75, -1, 77, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 125, -1, -1, -1, + -1, -1, -1, 132, -1, -1, -1, -1, -1, 138, + 139, -1, -1, -1, -1, 144, -1, -1, -1, -1, + -1, -1, -1, -1, 153, 154, 11, 156, 157, -1, + -1, 160, 161, 162, 19, 20, 21, 166, 23, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 33, 34, + -1, -1, -1, -1, 39, 40, 41, 42, 43, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 54, + 55, 56, 57, 58, 59, 60, -1, 62, 63, 64, + -1, -1, 67, 68, 69, -1, 71, 72, 73, 74, + 75, -1, 77, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 11, -1, -1, -1, -1, + 125, -1, -1, 19, 20, 21, -1, 132, -1, -1, + -1, -1, -1, 138, 139, -1, -1, 33, 34, 144, + -1, -1, -1, 39, 40, 41, 42, 43, 153, 154, + -1, 156, 157, -1, -1, 160, 161, 162, 54, 55, + 56, 57, 58, 59, 60, -1, 62, 63, 64, -1, + -1, 67, 68, 69, -1, 71, 72, 73, 74, 75, + -1, 77, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 11, -1, -1, -1, -1, 125, + -1, -1, 19, 20, 21, -1, 132, -1, -1, -1, + -1, -1, 138, 139, -1, -1, 33, 34, 144, -1, + -1, -1, 39, 40, 41, 42, 43, 153, 154, -1, + 156, 157, -1, -1, 160, 161, 162, 54, 55, 56, + 57, 58, 59, 60, -1, 62, 63, 64, -1, -1, + 67, 68, 69, -1, 71, 72, 73, 74, 75, -1, + 77, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 11, -1, -1, -1, -1, 125, -1, + -1, 19, 20, 21, -1, 132, -1, -1, -1, -1, + -1, 138, 139, -1, -1, 33, 34, 144, -1, -1, + -1, 39, 40, 41, 42, 43, 153, 154, -1, 156, + 157, -1, -1, 160, 161, 162, 54, 55, 56, 57, + 58, 59, 60, -1, 62, 63, 64, -1, -1, 67, + 68, 69, -1, 71, 72, 73, 74, 75, -1, 77, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 11, -1, -1, -1, -1, 125, -1, -1, + 19, 20, 21, -1, 132, -1, -1, -1, -1, -1, + 138, 139, -1, -1, 33, 34, 144, -1, -1, -1, + 39, 40, 41, 42, 43, 153, 154, -1, 156, 157, + -1, -1, 160, 161, 162, 54, 55, 56, 57, 58, + 59, 60, -1, 62, 63, 64, -1, -1, 67, 68, + 69, -1, 71, 72, 73, 74, 75, -1, 77, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 125, -1, -1, -1, + -1, -1, -1, 132, -1, -1, -1, -1, -1, 138, + 139, -1, 11, -1, -1, 144, -1, -1, -1, -1, + 19, 20, -1, -1, 153, 154, -1, 156, 157, -1, + -1, 160, 161, 162, 33, 34, 35, -1, -1, -1, + 39, 40, 41, 42, 43, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 54, 55, 56, 57, 58, + 59, 60, -1, 62, 63, 64, -1, -1, 67, 68, + 69, -1, 71, 72, 73, 74, 75, -1, 77, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 11, -1, -1, -1, -1, 125, -1, -1, 19, + 20, 21, -1, 132, -1, -1, -1, -1, -1, 138, + 139, -1, -1, 33, 34, 144, -1, -1, -1, 39, + 40, 41, 42, 43, 153, 154, -1, 156, 157, -1, + -1, 160, 161, 162, 54, 55, 56, 57, 58, 59, + 60, -1, 62, 63, 64, -1, -1, 67, 68, 69, + -1, 71, 72, 73, 74, 75, -1, 77, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 11, -1, -1, -1, -1, 125, -1, -1, 19, 20, + 21, -1, 132, -1, -1, -1, -1, -1, 138, 139, + -1, -1, 33, 34, 144, -1, -1, -1, 39, 40, + 41, 42, 43, 153, 154, -1, 156, 157, -1, -1, + 160, 161, 162, 54, 55, 56, 57, 58, 59, 60, + -1, 62, 63, 64, -1, -1, 67, 68, 69, -1, + 71, 72, 73, 74, 75, -1, 77, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 11, + -1, -1, -1, -1, 125, -1, -1, 19, 20, -1, + -1, 132, -1, -1, -1, -1, -1, 138, 139, -1, + -1, 33, 34, 144, -1, -1, -1, 39, 40, 41, + 42, 43, 153, 154, -1, 156, 157, -1, -1, 160, + 161, 162, 54, 55, 56, 57, 58, 59, 60, -1, + 62, 63, 64, -1, -1, 67, 68, 69, -1, 71, + 72, 73, 74, 75, -1, 77, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 11, -1, + -1, -1, -1, 125, -1, -1, 19, 20, -1, -1, + 132, -1, -1, -1, -1, -1, 138, 139, -1, -1, + 33, 34, 144, -1, -1, -1, 39, 40, 41, 42, + 43, 153, 154, -1, 156, 157, -1, -1, 160, 161, + 162, 54, 55, 56, 57, 58, 59, 60, -1, 62, + 63, 64, -1, -1, 67, 68, 69, -1, 71, 72, + 73, 74, 75, -1, 77, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 11, -1, -1, + -1, -1, 125, -1, -1, 19, 20, -1, -1, 132, + -1, -1, -1, -1, -1, 138, 139, -1, -1, 33, + 34, 144, -1, -1, -1, 39, 40, 41, 42, 43, + 153, 154, -1, 156, 157, -1, -1, 160, 161, 162, + 54, 55, 56, 57, 58, 59, 60, -1, 62, 63, + 64, -1, -1, 67, 68, 69, -1, 71, 72, 73, + 74, 75, -1, 77, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 11, -1, -1, -1, + -1, 125, -1, -1, 19, 20, -1, -1, 132, -1, + -1, -1, -1, -1, 138, 139, -1, -1, 33, 34, + 144, -1, -1, -1, 39, 40, 41, 42, 43, 153, + 154, -1, 156, 157, -1, -1, 160, 161, 162, 54, + 55, 56, 57, 58, 59, 60, -1, 62, 63, 64, + -1, -1, 67, 68, 69, -1, 71, 72, 73, 74, + 75, -1, 77, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 11, -1, -1, -1, -1, + 125, -1, -1, 19, 20, -1, -1, 132, -1, -1, + -1, -1, -1, 138, 139, -1, -1, 33, 34, 144, + -1, -1, -1, 39, 40, 41, 42, 43, 153, 154, + -1, 156, 157, -1, -1, 160, 161, 162, 54, 55, + 56, 57, 58, 59, 60, -1, 62, 63, 64, -1, + -1, 67, 68, 69, -1, 71, 72, 73, 74, 75, + -1, 77, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 11, -1, -1, -1, -1, 125, + -1, -1, 19, 20, -1, -1, 132, -1, -1, -1, + -1, -1, 138, 139, -1, -1, 33, 34, 144, -1, + -1, -1, 39, 40, 41, 42, 43, 153, 154, -1, + 156, 157, -1, -1, 160, 161, 162, 54, 55, 56, + 57, 58, 59, 60, -1, 62, 63, 64, -1, -1, + 67, 68, 69, -1, 71, 72, 73, 74, 75, -1, + 77, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 125, -1, + -1, -1, -1, -1, -1, 132, -1, -1, -1, -1, + -1, 138, 139, -1, -1, -1, -1, 144, -1, -1, + -1, -1, -1, -1, -1, -1, 153, 154, -1, 156, + 157, -1, -1, 160, 161, 162, 19, 20, 21, -1, + 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 33, 34, -1, -1, -1, -1, 39, 40, 41, 42, + 43, -1, -1, 46, 47, 48, 49, 50, -1, 52, + 53, 54, 55, 56, 57, 58, 59, 60, -1, 62, + 63, 64, -1, -1, 67, 68, 69, -1, 71, 72, + 73, 74, 75, -1, 77, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 132, + -1, -1, -1, -1, -1, 138, 139, -1, -1, -1, + -1, 144, -1, -1, -1, -1, 19, 20, 21, -1, + 153, 154, -1, 156, 157, -1, -1, 160, 161, 162, + 33, 34, -1, -1, -1, -1, 39, 40, 41, 42, + 43, -1, -1, 46, 47, 48, 49, 50, -1, 52, + 53, 54, 55, 56, 57, 58, 59, 60, -1, 62, + 63, 64, 19, 20, 67, 68, 69, -1, 71, 72, + 73, 74, 75, -1, 77, -1, 33, 34, -1, -1, + -1, -1, 39, 40, 41, 42, 43, -1, -1, 46, + 47, 48, 49, 50, -1, 52, 53, 54, 55, 56, + 57, 58, 59, 60, -1, 62, 63, 64, -1, -1, + 67, 68, 69, -1, 71, 72, 73, 74, 75, -1, + 77, -1, -1, -1, -1, -1, -1, -1, -1, 132, + -1, -1, -1, -1, -1, 138, 139, -1, -1, -1, + -1, 144, -1, -1, -1, -1, -1, -1, -1, -1, + 153, 154, -1, 156, 157, -1, -1, 160, 161, 162, + -1, -1, -1, -1, -1, -1, 25, -1, -1, 28, + -1, 30, -1, 32, -1, 132, 35, -1, -1, -1, + -1, 138, 139, -1, -1, -1, 45, 144, -1, -1, + -1, -1, -1, -1, -1, -1, 153, 154, -1, 156, + 157, -1, 61, 160, 161, 162, 65, 66, -1, -1, + -1, 70, -1, -1, -1, -1, -1, 76, -1, 78, + 79, -1, 81, -1, -1, -1, -1, 86, 87, 88, + 89, 90, -1, 92, 93, -1, -1, 96, 97, 98, + 99, 100, 101, 102, 103, 104, 105, 106, -1, 108, + -1, 110, 111, -1, -1, 114, 115, 116, -1, 118, + -1, 120, -1, -1, 123, 124, -1, -1, 127, 128, + 129, -1, -1, -1, -1, -1, -1, -1, 137, -1, + -1, -1, 141, 142, 143, 144, 145, 146, 147, 148, + 149, 150, 151, 152, -1, -1, 155, -1, -1, 158, + 159, 160, 161, 25, -1, -1, 28, 166, 30, -1, + 32, -1, -1, 35, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, + -1, -1, -1, 65, 66, -1, -1, -1, 70, -1, + -1, -1, -1, -1, 76, -1, 78, 79, -1, 81, + -1, -1, -1, -1, 86, 87, 88, 89, 90, -1, + 92, 93, -1, -1, 96, 97, 98, 99, 100, 101, + 102, 103, 104, 105, 106, -1, 108, -1, 110, 111, + -1, -1, 114, 115, 116, -1, 118, -1, 120, -1, + -1, 123, 124, -1, -1, 127, 128, 129, -1, -1, + -1, -1, -1, -1, -1, 137, -1, -1, -1, 141, + 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, + 152, 32, -1, 155, 35, -1, 158, 159, 160, 161, + -1, -1, -1, -1, 45, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 61, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 76, -1, -1, -1, -1, + 81, -1, 83, -1, -1, 86, 87, 88, 89, 90, + -1, -1, 93, -1, -1, 96, 97, 98, 99, 100, + 101, 102, 103, 104, 105, -1, -1, 32, -1, -1, + 35, -1, -1, -1, 115, -1, -1, -1, -1, 120, + 45, -1, -1, -1, -1, -1, 127, -1, 129, -1, + -1, -1, -1, -1, -1, -1, 61, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 148, 149, 150, + 151, 76, -1, -1, -1, -1, 81, -1, -1, 160, + 161, 86, 87, 88, 89, 90, -1, -1, 93, -1, + -1, 96, 97, 98, 99, 100, 101, 102, 103, 104, + 105, -1, -1, -1, -1, -1, 35, -1, -1, -1, + 115, -1, -1, -1, -1, 120, -1, -1, -1, -1, + -1, -1, 127, -1, 129, -1, -1, -1, -1, -1, + -1, -1, 61, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 148, 149, 150, 151, 76, -1, -1, + -1, -1, 81, 82, -1, 160, 161, 86, 87, 88, + -1, 90, -1, -1, 93, -1, -1, 96, 97, 98, + 99, 100, 101, 102, 103, 104, 105, -1, -1, -1, + -1, -1, 35, -1, -1, -1, 115, -1, -1, -1, + -1, 120, -1, -1, -1, -1, -1, -1, 127, -1, + 129, -1, -1, -1, -1, -1, -1, -1, 61, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 148, + 149, 150, 151, 76, -1, -1, -1, -1, 81, -1, + -1, 160, 161, 86, 87, 88, -1, 90, -1, -1, + 93, -1, -1, 96, 97, 98, 99, 100, 101, 102, + 103, 104, 105, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 115, -1, -1, -1, -1, 120, -1, -1, + -1, -1, -1, -1, 127, -1, 129, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 148, 149, 150, 151, -1, + -1, -1, -1, -1, -1, -1, -1, 160, 161 +}; + +/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ +static const yytype_uint16 yystos[] = +{ + 0, 170, 0, 1, 24, 25, 28, 30, 32, 35, + 45, 61, 65, 66, 70, 76, 78, 79, 81, 86, + 87, 88, 89, 90, 92, 93, 96, 97, 98, 99, + 100, 101, 102, 103, 104, 105, 106, 108, 110, 111, + 114, 115, 116, 118, 120, 123, 124, 127, 128, 129, + 137, 140, 141, 142, 143, 144, 145, 146, 147, 148, + 149, 150, 151, 152, 155, 158, 159, 160, 161, 166, + 171, 172, 173, 174, 176, 178, 186, 198, 199, 203, + 204, 209, 210, 211, 212, 213, 215, 216, 223, 225, + 228, 231, 232, 267, 276, 277, 282, 283, 284, 286, + 287, 291, 300, 301, 302, 303, 304, 310, 315, 319, + 320, 323, 331, 332, 333, 334, 335, 338, 339, 341, + 344, 345, 348, 357, 359, 369, 153, 181, 160, 180, + 162, 162, 11, 19, 20, 33, 34, 39, 40, 41, + 42, 43, 54, 55, 56, 57, 58, 59, 60, 62, + 63, 64, 67, 68, 69, 71, 72, 73, 74, 75, + 77, 125, 132, 138, 139, 144, 153, 154, 156, 157, + 160, 161, 162, 166, 249, 250, 252, 253, 257, 259, + 260, 261, 262, 267, 268, 269, 273, 275, 162, 191, + 192, 162, 249, 272, 131, 166, 195, 166, 195, 273, + 161, 162, 162, 3, 161, 179, 220, 305, 160, 160, + 166, 336, 162, 162, 352, 160, 161, 162, 353, 162, + 162, 195, 195, 18, 22, 219, 267, 162, 190, 119, + 130, 123, 160, 224, 173, 78, 79, 187, 244, 133, + 160, 161, 237, 336, 160, 162, 200, 201, 206, 4, + 175, 24, 140, 166, 24, 29, 31, 175, 175, 160, + 162, 221, 222, 166, 3, 220, 160, 205, 219, 3, + 220, 220, 3, 220, 160, 217, 218, 219, 3, 31, + 131, 196, 197, 226, 240, 21, 162, 229, 21, 162, + 235, 337, 160, 172, 172, 172, 172, 336, 336, 336, + 5, 122, 168, 340, 3, 162, 342, 101, 160, 273, + 352, 19, 20, 21, 46, 47, 48, 49, 50, 52, + 53, 160, 162, 250, 257, 268, 350, 352, 358, 360, + 361, 362, 175, 249, 294, 249, 249, 249, 251, 162, + 162, 162, 251, 249, 251, 162, 162, 162, 162, 162, + 162, 162, 162, 162, 162, 162, 162, 249, 162, 251, + 162, 162, 162, 162, 249, 250, 252, 275, 366, 367, + 162, 249, 252, 5, 6, 7, 8, 9, 10, 12, + 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, + 164, 165, 254, 249, 168, 162, 271, 162, 162, 160, + 153, 270, 271, 193, 267, 3, 249, 133, 160, 214, + 214, 249, 249, 161, 305, 94, 95, 267, 306, 257, + 370, 371, 21, 23, 162, 267, 354, 355, 360, 361, + 366, 161, 252, 267, 371, 372, 267, 374, 214, 34, + 39, 40, 42, 43, 54, 55, 56, 57, 58, 59, + 60, 62, 63, 64, 67, 68, 69, 72, 73, 74, + 75, 77, 160, 188, 189, 160, 267, 194, 249, 3, + 3, 195, 5, 21, 238, 249, 163, 22, 162, 257, + 220, 3, 22, 45, 88, 89, 175, 166, 174, 180, + 180, 5, 221, 3, 205, 219, 162, 245, 205, 267, + 219, 160, 160, 219, 245, 3, 217, 25, 80, 106, + 108, 109, 110, 113, 114, 116, 117, 241, 242, 244, + 180, 3, 227, 160, 161, 162, 160, 230, 238, 161, + 162, 236, 249, 237, 245, 3, 288, 299, 307, 299, + 44, 321, 322, 324, 249, 249, 356, 161, 21, 249, + 343, 346, 347, 249, 249, 249, 249, 249, 249, 249, + 5, 360, 162, 250, 257, 268, 349, 363, 364, 3, + 351, 18, 21, 22, 23, 362, 360, 163, 163, 3, + 163, 251, 251, 249, 163, 163, 163, 249, 249, 249, + 249, 249, 249, 249, 249, 249, 249, 249, 249, 163, + 251, 163, 251, 251, 251, 252, 366, 367, 3, 3, + 126, 3, 251, 163, 3, 5, 249, 256, 249, 249, + 249, 249, 249, 249, 249, 249, 249, 249, 249, 249, + 249, 249, 5, 22, 249, 255, 249, 5, 249, 5, + 249, 356, 272, 258, 263, 263, 3, 163, 245, 192, + 163, 3, 3, 163, 162, 298, 5, 3, 373, 360, + 21, 23, 162, 249, 3, 163, 163, 163, 163, 3, + 373, 3, 163, 3, 22, 3, 163, 162, 160, 336, + 238, 202, 207, 208, 253, 249, 3, 201, 160, 206, + 202, 162, 162, 179, 305, 162, 182, 182, 249, 163, + 222, 220, 4, 21, 246, 247, 248, 249, 220, 245, + 245, 220, 218, 245, 162, 3, 131, 182, 160, 245, + 230, 5, 238, 163, 3, 239, 21, 163, 245, 27, + 160, 278, 279, 249, 285, 286, 287, 289, 292, 293, + 282, 91, 115, 308, 309, 330, 83, 311, 312, 316, + 112, 162, 326, 107, 322, 325, 172, 267, 161, 163, + 3, 249, 163, 363, 254, 365, 365, 365, 3, 363, + 360, 360, 360, 360, 360, 293, 249, 163, 163, 163, + 163, 163, 163, 163, 163, 163, 163, 163, 163, 163, + 163, 163, 163, 163, 163, 163, 3, 3, 3, 249, + 367, 249, 367, 249, 367, 163, 252, 249, 249, 249, + 249, 249, 257, 4, 4, 249, 264, 265, 266, 163, + 163, 267, 133, 160, 249, 35, 82, 88, 284, 249, + 249, 121, 371, 163, 249, 266, 168, 245, 355, 371, + 163, 267, 188, 249, 194, 22, 3, 19, 20, 21, + 167, 268, 163, 160, 368, 22, 249, 249, 305, 21, + 160, 163, 184, 185, 26, 177, 205, 249, 3, 163, + 4, 267, 21, 233, 233, 217, 134, 135, 136, 243, + 242, 245, 233, 163, 238, 239, 160, 163, 4, 122, + 3, 36, 290, 295, 172, 172, 160, 162, 84, 312, + 313, 314, 317, 172, 4, 249, 327, 328, 329, 160, + 160, 299, 337, 347, 3, 163, 254, 364, 160, 368, + 368, 368, 163, 272, 4, 249, 4, 3, 271, 245, + 163, 162, 162, 163, 3, 5, 163, 356, 163, 202, + 207, 207, 207, 207, 5, 163, 163, 163, 3, 163, + 162, 183, 247, 248, 249, 162, 234, 249, 163, 233, + 5, 122, 274, 239, 238, 160, 166, 280, 281, 160, + 279, 294, 37, 38, 296, 297, 172, 249, 160, 85, + 312, 318, 172, 299, 329, 3, 163, 4, 245, 368, + 365, 163, 163, 163, 163, 249, 4, 249, 265, 3, + 294, 249, 249, 257, 338, 249, 22, 82, 185, 163, + 184, 21, 274, 249, 249, 122, 3, 163, 160, 160, + 172, 288, 163, 160, 299, 328, 329, 245, 163, 249, + 4, 249, 163, 163, 3, 3, 202, 163, 163, 160, + 281, 160, 288, 82, 249, 249, 249, 22, 160, 3, + 249 +}; + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab + + +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. However, + YYFAIL appears to be in use. Nevertheless, it is formally deprecated + in Bison 2.4.2's NEWS entry, where a plan to phase it out is + discussed. */ + +#define YYFAIL goto yyerrlab +#if defined YYFAIL + /* This is here to suppress warnings from the GCC cpp's + -Wunused-macros. Normally we don't worry about that warning, but + some users do, and we want to make it easy for users to remove + YYFAIL uses, which will produce warnings from Bison 2.5. */ +#endif + +#define YYRECOVERING() (!!yyerrstatus) + +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + YYPOPSTACK (yylen); \ + yystate = *yyssp; \ + goto yybackup; \ + } \ + else \ + { \ + yyerror (YY_("syntax error: cannot back up")); \ + YYERROR; \ + } \ +while (YYID (0)) + +/* Error token number */ +#define YYTERROR 1 +#define YYERRCODE 256 + + +/* This macro is provided for backward compatibility. */ +#ifndef YY_LOCATION_PRINT +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +#endif + + +/* YYLEX -- calling `yylex' with the right arguments. */ +#ifdef YYLEX_PARAM +# define YYLEX yylex (YYLEX_PARAM) +#else +# define YYLEX yylex () +#endif + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (YYID (0)) + +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (YYID (0)) + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_value_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + FILE *yyo = yyoutput; + YYUSE (yyo); + if (!yyvaluep) + return; +# ifdef YYPRINT + if (yytype < YYNTOKENS) + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# else + YYUSE (yyoutput); +# endif + switch (yytype) + { + default: + break; + } +} + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + if (yytype < YYNTOKENS) + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + else + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + + yy_symbol_value_print (yyoutput, yytype, yyvaluep); + YYFPRINTF (yyoutput, ")"); +} + +/*------------------------------------------------------------------. +| yy_stack_print -- Print the state stack from its BOTTOM up to its | +| TOP (included). | +`------------------------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) +#else +static void +yy_stack_print (yybottom, yytop) + yytype_int16 *yybottom; + yytype_int16 *yytop; +#endif +{ + YYFPRINTF (stderr, "Stack now"); + for (; yybottom <= yytop; yybottom++) + { + int yybot = *yybottom; + YYFPRINTF (stderr, " %d", yybot); + } + YYFPRINTF (stderr, "\n"); +} + +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (YYID (0)) + + +/*------------------------------------------------. +| Report that the YYRULE is going to be reduced. | +`------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_reduce_print (YYSTYPE *yyvsp, int yyrule) +#else +static void +yy_reduce_print (yyvsp, yyrule) + YYSTYPE *yyvsp; + int yyrule; +#endif +{ + int yynrhs = yyr2[yyrule]; + int yyi; + unsigned long int yylno = yyrline[yyrule]; + YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", + yyrule - 1, yylno); + /* The symbols being reduced. */ + for (yyi = 0; yyi < yynrhs; yyi++) + { + YYFPRINTF (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], + &(yyvsp[(yyi + 1) - (yynrhs)]) + ); + YYFPRINTF (stderr, "\n"); + } +} + +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyvsp, Rule); \ +} while (YYID (0)) + +/* Nonzero means print parse trace. It is left uninitialized so that + multiple parsers can coexist. */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) +# define YY_STACK_PRINT(Bottom, Top) +# define YY_REDUCE_PRINT(Rule) +#endif /* !YYDEBUG */ + + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + + +#if YYERROR_VERBOSE + +# ifndef yystrlen +# if defined __GLIBC__ && defined _STRING_H +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static YYSIZE_T +yystrlen (const char *yystr) +#else +static YYSIZE_T +yystrlen (yystr) + const char *yystr; +#endif +{ + YYSIZE_T yylen; + for (yylen = 0; yystr[yylen]; yylen++) + continue; + return yylen; +} +# endif +# endif + +# ifndef yystpcpy +# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static char * +yystpcpy (char *yydest, const char *yysrc) +#else +static char * +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +#endif +{ + char *yyd = yydest; + const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif + +# ifndef yytnamerr +/* Copy to YYRES the contents of YYSTR after stripping away unnecessary + quotes and backslashes, so that it's suitable for yyerror. The + heuristic is that double-quoting is unnecessary unless the string + contains an apostrophe, a comma, or backslash (other than + backslash-backslash). YYSTR is taken from yytname. If YYRES is + null, do not copy; instead, return the length of what the result + would have been. */ +static YYSIZE_T +yytnamerr (char *yyres, const char *yystr) +{ + if (*yystr == '"') + { + YYSIZE_T yyn = 0; + char const *yyp = yystr; + + for (;;) + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } + do_not_strip_quotes: ; + } + + if (! yyres) + return yystrlen (yystr); + + return yystpcpy (yyres, yystr) - yyres; +} +# endif + +/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message + about the unexpected token YYTOKEN for the state stack whose top is + YYSSP. + + Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is + not large enough to hold the message. In that case, also set + *YYMSG_ALLOC to the required number of bytes. Return 2 if the + required number of bytes is too large to store. */ +static int +yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, + yytype_int16 *yyssp, int yytoken) +{ + YYSIZE_T yysize0 = yytnamerr (YY_NULL, yytname[yytoken]); + YYSIZE_T yysize = yysize0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + /* Internationalized format string. */ + const char *yyformat = YY_NULL; + /* Arguments of yyformat. */ + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + /* Number of reported tokens (one for the "unexpected", one per + "expected"). */ + int yycount = 0; + + /* There are many possibilities here to consider: + - Assume YYFAIL is not used. It's too flawed to consider. See + + for details. YYERROR is fine as it does not invoke this + function. + - If this state is a consistent state with a default action, then + the only way this function was invoked is if the default action + is an error action. In that case, don't check for expected + tokens because there are none. + - The only way there can be no lookahead present (in yychar) is if + this state is a consistent state with a default action. Thus, + detecting the absence of a lookahead is sufficient to determine + that there is no unexpected or expected token to report. In that + case, just report a simple "syntax error". + - Don't assume there isn't a lookahead just because this state is a + consistent state with a default action. There might have been a + previous inconsistent state, consistent state with a non-default + action, or user semantic action that manipulated yychar. + - Of course, the expected token list depends on states to have + correct lookahead information, and it depends on the parser not + to perform extra reductions after fetching a lookahead from the + scanner and before detecting a syntax error. Thus, state merging + (from LALR or IELR) and default reductions corrupt the expected + token list. However, the list is correct for canonical LR with + one exception: it will still contain any token that will not be + accepted due to an error action in a later state. + */ + if (yytoken != YYEMPTY) + { + int yyn = yypact[*yyssp]; + yyarg[yycount++] = yytname[yytoken]; + if (!yypact_value_is_default (yyn)) + { + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. In other words, skip the first -YYN actions for + this state because they are default actions. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yyx; + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR + && !yytable_value_is_error (yytable[yyx + yyn])) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + break; + } + yyarg[yycount++] = yytname[yyx]; + { + YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULL, yytname[yyx]); + if (! (yysize <= yysize1 + && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + } + } + } + + switch (yycount) + { +# define YYCASE_(N, S) \ + case N: \ + yyformat = S; \ + break + YYCASE_(0, YY_("syntax error")); + YYCASE_(1, YY_("syntax error, unexpected %s")); + YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); + YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); + YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); + YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); +# undef YYCASE_ + } + + { + YYSIZE_T yysize1 = yysize + yystrlen (yyformat); + if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + + if (*yymsg_alloc < yysize) + { + *yymsg_alloc = 2 * yysize; + if (! (yysize <= *yymsg_alloc + && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) + *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; + return 1; + } + + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + { + char *yyp = *yymsg; + int yyi = 0; + while ((*yyp = *yyformat) != '\0') + if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyformat += 2; + } + else + { + yyp++; + yyformat++; + } + } + return 0; +} +#endif /* YYERROR_VERBOSE */ + +/*-----------------------------------------------. +| Release the memory associated to this symbol. | +`-----------------------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) +#else +static void +yydestruct (yymsg, yytype, yyvaluep) + const char *yymsg; + int yytype; + YYSTYPE *yyvaluep; +#endif +{ + YYUSE (yyvaluep); + + if (!yymsg) + yymsg = "Deleting"; + YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); + + switch (yytype) + { + + default: + break; + } +} + + + + +/* The lookahead symbol. */ +int yychar; + + +#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_END +#endif +#ifndef YY_INITIAL_VALUE +# define YY_INITIAL_VALUE(Value) /* Nothing. */ +#endif + +/* The semantic value of the lookahead symbol. */ +YYSTYPE yylval YY_INITIAL_VALUE(yyval_default); + +/* Number of syntax errors so far. */ +int yynerrs; + + +/*----------. +| yyparse. | +`----------*/ + +#ifdef YYPARSE_PARAM +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void *YYPARSE_PARAM) +#else +int +yyparse (YYPARSE_PARAM) + void *YYPARSE_PARAM; +#endif +#else /* ! YYPARSE_PARAM */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void) +#else +int +yyparse () + +#endif +#endif +{ + int yystate; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + + /* The stacks and their tools: + `yyss': related to states. + `yyvs': related to semantic values. + + Refer to the stacks through separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss; + yytype_int16 *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs; + YYSTYPE *yyvsp; + + YYSIZE_T yystacksize; + + int yyn; + int yyresult; + /* Lookahead token as an internal (translated) token number. */ + int yytoken = 0; + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; + +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) + + /* The number of symbols on the RHS of the reduced rule. + Keep to zero when no symbol should be popped. */ + int yylen = 0; + + yyssp = yyss = yyssa; + yyvsp = yyvs = yyvsa; + yystacksize = YYINITDEPTH; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + goto yysetstate; + +/*------------------------------------------------------------. +| yynewstate -- Push a new state, which is found in yystate. | +`------------------------------------------------------------*/ + yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. So pushing a state here evens the stacks. */ + yyssp++; + + yysetstate: + *yyssp = yystate; + + if (yyss + yystacksize - 1 <= yyssp) + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = yyssp - yyss + 1; + +#ifdef yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yystacksize); + + yyss = yyss1; + yyvs = yyvs1; + } +#else /* no yyoverflow */ +# ifndef YYSTACK_RELOCATE + goto yyexhaustedlab; +# else + /* Extend the stack our own way. */ + if (YYMAXDEPTH <= yystacksize) + goto yyexhaustedlab; + yystacksize *= 2; + if (YYMAXDEPTH < yystacksize) + yystacksize = YYMAXDEPTH; + + { + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss_alloc, yyss); + YYSTACK_RELOCATE (yyvs_alloc, yyvs); +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +# endif +#endif /* no yyoverflow */ + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long int) yystacksize)); + + if (yyss + yystacksize - 1 <= yyssp) + YYABORT; + } + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + if (yystate == YYFINAL) + YYACCEPT; + + goto yybackup; + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + + /* Do appropriate processing given the current state. Read a + lookahead token if we need one and don't already have one. */ + + /* First try to decide what to do without reference to lookahead token. */ + yyn = yypact[yystate]; + if (yypact_value_is_default (yyn)) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = YYLEX; + } + + if (yychar <= YYEOF) + { + yychar = yytoken = YYEOF; + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yytoken = YYTRANSLATE (yychar); + YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); + } + + /* If the proper action on seeing token YYTOKEN is to reduce or to + detect an error, take that action. */ + yyn += yytoken; + if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) + goto yydefault; + yyn = yytable[yyn]; + if (yyn <= 0) + { + if (yytable_value_is_error (yyn)) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + /* Shift the lookahead token. */ + YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); + + /* Discard the shifted token. */ + yychar = YYEMPTY; + + yystate = yyn; + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END + + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- Do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + `$$ = $1'. + + Otherwise, the following line sets YYVAL to garbage. + This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + + + YY_REDUCE_PRINT (yyn); + switch (yyn) + { + case 7: +/* Line 1807 of yacc.c */ +#line 319 "fortran.y" + {yyerrok;yyclearin;} + break; + + case 18: +/* Line 1807 of yacc.c */ +#line 337 "fortran.y" + { + if (inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); + } + } + break; + + case 20: +/* Line 1807 of yacc.c */ +#line 347 "fortran.y" + { pos_cur = setposcur(); } + break; + + case 21: +/* Line 1807 of yacc.c */ +#line 350 "fortran.y" + { isrecursive = 0; } + break; + + case 22: +/* Line 1807 of yacc.c */ +#line 351 "fortran.y" + { isrecursive = 1; } + break; + + case 23: +/* Line 1807 of yacc.c */ +#line 354 "fortran.y" + { is_result_present = 0; } + break; + + case 24: +/* Line 1807 of yacc.c */ +#line 355 "fortran.y" + { is_result_present = 1; } + break; + + case 25: +/* Line 1807 of yacc.c */ +#line 359 "fortran.y" + { + insubroutinedeclare = 1; + if ( firstpass ) + Add_SubroutineArgument_Var_1((yyvsp[(4) - (4)].l)); + else + WriteBeginof_SubLoop(); + } + break; + + case 26: +/* Line 1807 of yacc.c */ +#line 367 "fortran.y" + { + insubroutinedeclare = 1; + inprogramdeclare = 1; + /* in the second step we should write the head of */ + /* the subroutine sub_loop_ */ + if ( ! firstpass ) + WriteBeginof_SubLoop(); + } + break; + + case 27: +/* Line 1807 of yacc.c */ +#line 376 "fortran.y" + { + insubroutinedeclare = 1; + strcpy(DeclType, ""); + /* we should to list of the subroutine argument the */ + /* name of the function which has to be defined */ + if ( firstpass ) + { + Add_SubroutineArgument_Var_1((yyvsp[(4) - (5)].l)); + if ( ! is_result_present ) + Add_FunctionType_Var_1((yyvsp[(3) - (5)].na)); + } + else + /* in the second step we should write the head of */ + /* the subroutine sub_loop_ */ + WriteBeginof_SubLoop(); + } + break; + + case 28: +/* Line 1807 of yacc.c */ +#line 393 "fortran.y" + { + GlobalDeclaration = 0; + strcpy(curmodulename,(yyvsp[(2) - (2)].na)); + strcpy(subroutinename,""); + Add_NameOfModule_1((yyvsp[(2) - (2)].na)); + if ( inmoduledeclare == 0 ) + { + /* To know if there are in the module declaration */ + inmoduledeclare = 1; + /* to know if a module has been met */ + inmodulemeet = 1; + /* to know if we are after the keyword contains */ + aftercontainsdeclare = 0 ; + } + } + break; + + case 31: +/* Line 1807 of yacc.c */ +#line 415 "fortran.y" + { strcpy((yyval.na), (yyvsp[(1) - (1)].na)); strcpy(subroutinename, (yyvsp[(1) - (1)].na)); } + break; + + case 32: +/* Line 1807 of yacc.c */ +#line 417 "fortran.y" + { Add_Include_1((yyvsp[(1) - (1)].na)); } + break; + + case 33: +/* Line 1807 of yacc.c */ +#line 419 "fortran.y" + { if ( firstpass ) (yyval.l)=NULL; } + break; + + case 34: +/* Line 1807 of yacc.c */ +#line 420 "fortran.y" + { if ( firstpass ) (yyval.l)=NULL; } + break; + + case 35: +/* Line 1807 of yacc.c */ +#line 421 "fortran.y" + { if ( firstpass ) (yyval.l)=(yyvsp[(2) - (3)].l); } + break; + + case 38: +/* Line 1807 of yacc.c */ +#line 425 "fortran.y" + { if ( firstpass ) Add_SubroutineArgument_Var_1((yyvsp[(2) - (3)].l)); } + break; + + case 39: +/* Line 1807 of yacc.c */ +#line 428 "fortran.y" + { + if ( firstpass == 1 ) + { + strcpy(nameinttypenameback,nameinttypename); + strcpy(nameinttypename,""); + curvar = createvar((yyvsp[(1) - (1)].na),NULL); + strcpy(nameinttypename,nameinttypenameback); + curlistvar = insertvar(NULL,curvar); + (yyval.l) = settype("",curlistvar); + } + } + break; + + case 40: +/* Line 1807 of yacc.c */ +#line 440 "fortran.y" + { + if ( firstpass == 1 ) + { + strcpy(nameinttypenameback,nameinttypename); + strcpy(nameinttypename,""); + curvar = createvar((yyvsp[(3) - (3)].na),NULL); + strcpy(nameinttypename,nameinttypenameback); + (yyval.l) = insertvar((yyvsp[(1) - (3)].l),curvar); + } + } + break; + + case 41: +/* Line 1807 of yacc.c */ +#line 451 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 42: +/* Line 1807 of yacc.c */ +#line 452 "fortran.y" + { strcpy((yyval.na),"*"); } + break; + + case 44: +/* Line 1807 of yacc.c */ +#line 455 "fortran.y" + { inside_type_declare = 1; } + break; + + case 45: +/* Line 1807 of yacc.c */ +#line 456 "fortran.y" + { inside_type_declare = 0; } + break; + + case 47: +/* Line 1807 of yacc.c */ +#line 459 "fortran.y" + { + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + if ( insubroutinedeclare ) Add_Parameter_Var_1((yyvsp[(3) - (4)].l)); + else Add_GlobalParameter_Var_1((yyvsp[(3) - (4)].l)); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out, pos_cur_decl, pos_end-pos_cur_decl); + } + } + VariableIsParameter = 0 ; + } + break; + + case 48: +/* Line 1807 of yacc.c */ +#line 476 "fortran.y" + { + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + if ( insubroutinedeclare ) Add_Parameter_Var_1((yyvsp[(2) - (2)].l)); + else Add_GlobalParameter_Var_1((yyvsp[(2) - (2)].l)); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); + } + } + VariableIsParameter = 0 ; + } + break; + + case 50: +/* Line 1807 of yacc.c */ +#line 494 "fortran.y" + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); + } + break; + + case 52: +/* Line 1807 of yacc.c */ +#line 500 "fortran.y" + { + /* if the variable is a parameter we can suppose that is */ + /* value is the same on each grid. It is not useless to */ + /* create a copy of it on each grid */ + if ( ! inside_type_declare ) + { + if ( firstpass ) + { + Add_Globliste_1((yyvsp[(1) - (1)].l)); + /* if variableparamlists has been declared in a subroutine */ + if ( insubroutinedeclare ) Add_Dimension_Var_1((yyvsp[(1) - (1)].l)); + } + else + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); + } + } + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + strcpy(NamePrecision,""); + c_star = 0; + InitialValueGiven = 0 ; + strcpy(IntentSpec,""); + VariableIsParameter = 0 ; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0 ; + dimsgiven=0; + c_selectorgiven=0; + strcpy(nameinttypename,""); + strcpy(c_selectorname,""); + } + break; + + case 53: +/* Line 1807 of yacc.c */ +#line 537 "fortran.y" + { + if (firstpass == 0) + { + if ((yyvsp[(1) - (1)].lnn)) + { + removeglobfromlist(&((yyvsp[(1) - (1)].lnn))); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); + writelistpublic((yyvsp[(1) - (1)].lnn)); + } + } + } + break; + + case 62: +/* Line 1807 of yacc.c */ +#line 558 "fortran.y" + { + /* we should remove the data declaration */ + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); + + if ( aftercontainsdeclare == 1 && firstpass == 0 ) + { + ReWriteDataStatement_0(fortran_out); + pos_end = setposcur(); + } + } + break; + + case 64: +/* Line 1807 of yacc.c */ +#line 572 "fortran.y" + { + PublicDeclare = 0 ; + PrivateDeclare = 0 ; + } + break; + + case 102: +/* Line 1807 of yacc.c */ +#line 630 "fortran.y" + { + /* if the variable is a parameter we can suppose that is*/ + /* value is the same on each grid. It is not useless */ + /* to create a copy of it on each grid */ + if ( ! inside_type_declare ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); + ReWriteDeclarationAndAddTosubroutine_01((yyvsp[(1) - (2)].l)); + pos_cur_decl = setposcur(); + if ( firstpass == 0 && GlobalDeclaration == 0 + && insubroutinedeclare == 0 ) + { + fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); + sprintf(ligne, "Module_Declar_%s.h", curmodulename); + module_declar = open_for_write(ligne); + GlobalDeclaration = 1 ; + pos_cur_decl = setposcur(); + } + (yyval.l) = (yyvsp[(1) - (2)].l); + + if ( firstpass ) + { + Add_Globliste_1((yyvsp[(1) - (2)].l)); + if ( insubroutinedeclare ) + { + if ( pointerdeclare ) Add_Pointer_Var_From_List_1((yyvsp[(1) - (2)].l)); + Add_Parameter_Var_1((yyvsp[(1) - (2)].l)); + } + else + Add_GlobalParameter_Var_1((yyvsp[(1) - (2)].l)); + + /* If there's a SAVE declaration in module's subroutines we should */ + /* remove it from the subroutines declaration and add it in the */ + /* global declarations */ + if ( aftercontainsdeclare && SaveDeclare ) + { + if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1((yyvsp[(1) - (2)].l)); + else Add_Save_Var_dcl_1((yyvsp[(1) - (2)].l)); + } + } + } + else + { + (yyval.l) = (listvar *) NULL; + } + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + strcpy(NamePrecision,""); + c_star = 0; + InitialValueGiven = 0 ; + strcpy(IntentSpec,""); + VariableIsParameter = 0 ; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0 ; + dimsgiven=0; + c_selectorgiven=0; + strcpy(nameinttypename,""); + strcpy(c_selectorname,""); + GlobalDeclarationType = 0; + } + break; + + case 103: +/* Line 1807 of yacc.c */ +#line 696 "fortran.y" + { + insubroutinedeclare = 1; + + if ( firstpass ) + { + Add_SubroutineArgument_Var_1((yyvsp[(3) - (3)].l)); + Add_FunctionType_Var_1((yyvsp[(2) - (3)].na)); + } + else + WriteBeginof_SubLoop(); + + strcpy(nameinttypename,""); + } + break; + + case 104: +/* Line 1807 of yacc.c */ +#line 710 "fortran.y" + { functiondeclarationisdone = 1; } + break; + + case 105: +/* Line 1807 of yacc.c */ +#line 712 "fortran.y" + { VariableIsParameter = 1; pos_curparameter = setposcur()-9; } + break; + + case 109: +/* Line 1807 of yacc.c */ +#line 724 "fortran.y" + { + createstringfromlistname(ligne,(yyvsp[(3) - (4)].lnn)); + if (firstpass == 1) Add_Data_Var_1(&List_Data_Var,(yyvsp[(1) - (4)].na),ligne); + else Add_Data_Var_1(&List_Data_Var_Cur,(yyvsp[(1) - (4)].na),ligne); + } + break; + + case 110: +/* Line 1807 of yacc.c */ +#line 730 "fortran.y" + { + if (firstpass == 1) Add_Data_Var_Names_01(&List_Data_Var,(yyvsp[(1) - (4)].lnn),(yyvsp[(3) - (4)].lnn)); + else Add_Data_Var_Names_01(&List_Data_Var_Cur,(yyvsp[(1) - (4)].lnn),(yyvsp[(3) - (4)].lnn)); + } + break; + + case 111: +/* Line 1807 of yacc.c */ +#line 735 "fortran.y" + { + createstringfromlistname(ligne,(yyvsp[(7) - (8)].lnn)); + printf("###################################################################################################################\n"); + printf("## CONV Error : data_implied_do statements (R537) are not yet supported. Please complain to the proper authorities.\n"); + printf("l.%4d -- data_stmt_set : ( lhs , dospec ) /data_stmt_value_list/ -- lhs=|%s| dospec=|%s| data_stmt_value_list=|%s|\n", + line_num_input,(yyvsp[(2) - (8)].na),(yyvsp[(4) - (8)].na),ligne); + printf("## But, are you SURE you NEED a DATA construct ?\n"); + printf("###################################################################################################################\n"); + exit(1); + } + break; + + case 112: +/* Line 1807 of yacc.c */ +#line 748 "fortran.y" + { (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].na),0); } + break; + + case 113: +/* Line 1807 of yacc.c */ +#line 749 "fortran.y" + { (yyval.lnn) = Insertname((yyvsp[(3) - (3)].lnn),(yyvsp[(1) - (3)].na),1); } + break; + + case 118: +/* Line 1807 of yacc.c */ +#line 758 "fortran.y" + { pos_cursave = setposcur()-4; } + break; + + case 120: +/* Line 1807 of yacc.c */ +#line 761 "fortran.y" + { if ( ! inside_type_declare ) Add_Save_Var_1((yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].d)); } + break; + + case 121: +/* Line 1807 of yacc.c */ +#line 764 "fortran.y" + { (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].na),0); } + break; + + case 122: +/* Line 1807 of yacc.c */ +#line 765 "fortran.y" + { printf("l.%4d -- INSTRUCTION NON TRAITEE : INITIALISATION DE DATA AVEC EXPRESSION\n",line_num_input); exit(0); } + break; + + case 123: +/* Line 1807 of yacc.c */ +#line 766 "fortran.y" + { (yyval.lnn) = concat_listname((yyvsp[(1) - (3)].lnn),(yyvsp[(3) - (3)].lnn)); } + break; + + case 124: +/* Line 1807 of yacc.c */ +#line 769 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 125: +/* Line 1807 of yacc.c */ +#line 770 "fortran.y" + { sprintf((yyval.na),"%s+%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 126: +/* Line 1807 of yacc.c */ +#line 771 "fortran.y" + { sprintf((yyval.na),"%s-%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 127: +/* Line 1807 of yacc.c */ +#line 772 "fortran.y" + { sprintf((yyval.na),"%s*%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 128: +/* Line 1807 of yacc.c */ +#line 773 "fortran.y" + { sprintf((yyval.na),"%s/%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 129: +/* Line 1807 of yacc.c */ +#line 775 "fortran.y" + { strcpy((yyval.na),""); } + break; + + case 130: +/* Line 1807 of yacc.c */ +#line 776 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 135: +/* Line 1807 of yacc.c */ +#line 786 "fortran.y" + { + positioninblock = 0; + pos_curdimension = setposcur()-9; + } + break; + + case 136: +/* Line 1807 of yacc.c */ +#line 793 "fortran.y" + { + printf("l.%4d -- dimension : before_dimension opt_comma TOK_NAME = |%s| -- MHCHECK\n",line_num_input,(yyvsp[(3) - (5)].na)); + if ( inside_type_declare ) break; + curvar = createvar((yyvsp[(3) - (5)].na),(yyvsp[(4) - (5)].d)); + CreateAndFillin_Curvar("", curvar); + curlistvar=insertvar(NULL, curvar); + (yyval.l) = settype("",curlistvar); + strcpy(vallengspec,""); + } + break; + + case 137: +/* Line 1807 of yacc.c */ +#line 803 "fortran.y" + { + printf("l.%4d -- dimension : dimension ',' TOK_NAME dims lengspec = |%s| -- MHCHECK\n",line_num_input,(yyvsp[(3) - (5)].na)); + if ( inside_type_declare ) break; + curvar = createvar((yyvsp[(3) - (5)].na),(yyvsp[(4) - (5)].d)); + CreateAndFillin_Curvar("", curvar); + curlistvar = insertvar((yyvsp[(1) - (5)].l), curvar); + (yyval.l) = curlistvar; + strcpy(vallengspec,""); + } + break; + + case 140: +/* Line 1807 of yacc.c */ +#line 818 "fortran.y" + { (yyval.lnn) = (listname *) NULL; } + break; + + case 141: +/* Line 1807 of yacc.c */ +#line 819 "fortran.y" + { (yyval.lnn) = (yyvsp[(3) - (3)].lnn); } + break; + + case 142: +/* Line 1807 of yacc.c */ +#line 822 "fortran.y" + { (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].na),0); } + break; + + case 143: +/* Line 1807 of yacc.c */ +#line 823 "fortran.y" + { (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].na),0); } + break; + + case 144: +/* Line 1807 of yacc.c */ +#line 824 "fortran.y" + { (yyval.lnn) = Insertname((yyvsp[(1) - (3)].lnn),(yyvsp[(3) - (3)].na),0); } + break; + + case 145: +/* Line 1807 of yacc.c */ +#line 825 "fortran.y" + { (yyval.lnn) = Insertname((yyvsp[(1) - (3)].lnn),(yyvsp[(3) - (3)].na),0); } + break; + + case 146: +/* Line 1807 of yacc.c */ +#line 829 "fortran.y" + { + if ( inside_type_declare ) break; + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + break; + + case 147: +/* Line 1807 of yacc.c */ +#line 835 "fortran.y" + { + if ( inside_type_declare ) break; + sprintf(charusemodule,"%s",(yyvsp[(2) - (3)].na)); + Add_NameOfCommon_1((yyvsp[(2) - (3)].na),subroutinename); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + break; + + case 148: +/* Line 1807 of yacc.c */ +#line 843 "fortran.y" + { + if ( inside_type_declare ) break; + sprintf(charusemodule,"%s",(yyvsp[(3) - (5)].na)); + Add_NameOfCommon_1((yyvsp[(3) - (5)].na),subroutinename); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); + } + break; + + case 149: +/* Line 1807 of yacc.c */ +#line 852 "fortran.y" + { positioninblock = 0; pos_curcommon = setposcur()-6; } + break; + + case 150: +/* Line 1807 of yacc.c */ +#line 853 "fortran.y" + { positioninblock = 0; pos_curcommon = setposcur()-6-7; } + break; + + case 151: +/* Line 1807 of yacc.c */ +#line 856 "fortran.y" + { if ( ! inside_type_declare ) Add_Common_var_1(); } + break; + + case 152: +/* Line 1807 of yacc.c */ +#line 857 "fortran.y" + { if ( ! inside_type_declare ) Add_Common_var_1(); } + break; + + case 153: +/* Line 1807 of yacc.c */ +#line 861 "fortran.y" + { + positioninblock = positioninblock + 1 ; + strcpy(commonvar,(yyvsp[(1) - (2)].na)); + commondim = (yyvsp[(2) - (2)].d); + } + break; + + case 154: +/* Line 1807 of yacc.c */ +#line 869 "fortran.y" + { + strcpy((yyval.na),""); + positioninblock=0; + strcpy(commonblockname,""); + } + break; + + case 155: +/* Line 1807 of yacc.c */ +#line 875 "fortran.y" + { + strcpy((yyval.na),(yyvsp[(2) - (3)].na)); + positioninblock=0; + strcpy(commonblockname,(yyvsp[(2) - (3)].na)); + } + break; + + case 158: +/* Line 1807 of yacc.c */ +#line 885 "fortran.y" + { (yyval.l)=insertvar(NULL,(yyvsp[(1) - (1)].v)); } + break; + + case 159: +/* Line 1807 of yacc.c */ +#line 886 "fortran.y" + { (yyval.l)=insertvar((yyvsp[(1) - (3)].l),(yyvsp[(3) - (3)].v)); } + break; + + case 160: +/* Line 1807 of yacc.c */ +#line 890 "fortran.y" + { + if ( inside_type_declare ) break; + curvar=(variable *) calloc(1,sizeof(variable)); + Init_Variable(curvar); + curvar->v_VariableIsParameter = 1; + strcpy(curvar->v_nomvar,(yyvsp[(1) - (3)].na)); + strcpy(curvar->v_subroutinename,subroutinename); + strcpy(curvar->v_modulename,curmodulename); + strcpy(curvar->v_initialvalue,(yyvsp[(3) - (3)].na)); + strcpy(curvar->v_commoninfile,cur_filename); + Save_Length((yyvsp[(3) - (3)].na),14); + (yyval.v) = curvar; + } + break; + + case 164: +/* Line 1807 of yacc.c */ +#line 913 "fortran.y" + { + if ( insubroutinedeclare == 1 ) + { + Add_ImplicitNoneSubroutine_1(); + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_end-13,13); + } + } + break; + + case 166: +/* Line 1807 of yacc.c */ +#line 924 "fortran.y" + { + if ( ! inside_type_declare ) + { + if (dimsgiven == 1) curvar = createvar((yyvsp[(2) - (5)].na),curdim); + else curvar = createvar((yyvsp[(2) - (5)].na),(yyvsp[(3) - (5)].d)); + CreateAndFillin_Curvar(DeclType, curvar); + curlistvar = insertvar(NULL, curvar); + if (!strcasecmp(DeclType,"character")) + { + if (c_selectorgiven == 1) + { + strcpy(c_selectordim.first,"1"); + strcpy(c_selectordim.last,c_selectorname); + Save_Length(c_selectorname,1); + change_dim_char(insertdim(NULL,c_selectordim),curlistvar); + } + } + (yyval.l)=settype(DeclType,curlistvar); + } + strcpy(vallengspec,""); + } + break; + + case 167: +/* Line 1807 of yacc.c */ +#line 946 "fortran.y" + { + if ( ! inside_type_declare ) + { + if (dimsgiven == 1) curvar = createvar((yyvsp[(3) - (6)].na), curdim); + else curvar = createvar((yyvsp[(3) - (6)].na), (yyvsp[(4) - (6)].d)); + CreateAndFillin_Curvar((yyvsp[(1) - (6)].l)->var->v_typevar,curvar); + strcpy(curvar->v_typevar, (yyvsp[(1) - (6)].l)->var->v_typevar); + curvar->v_catvar = get_cat_var(curvar); + curlistvar = insertvar((yyvsp[(1) - (6)].l), curvar); + if (!strcasecmp(DeclType,"character")) + { + if (c_selectorgiven == 1) + { + strcpy(c_selectordim.first,"1"); + strcpy(c_selectordim.last,c_selectorname); + Save_Length(c_selectorname,1); + change_dim_char(insertdim(NULL,c_selectordim),curlistvar); + } + } + (yyval.l)=curlistvar; + } + strcpy(vallengspec,""); + } + break; + + case 168: +/* Line 1807 of yacc.c */ +#line 970 "fortran.y" + { dimsgiven = 0; } + break; + + case 169: +/* Line 1807 of yacc.c */ +#line 972 "fortran.y" + { strcpy(DeclType,(yyvsp[(1) - (2)].na)); } + break; + + case 170: +/* Line 1807 of yacc.c */ +#line 973 "fortran.y" + { strcpy(DeclType,"character"); } + break; + + case 171: +/* Line 1807 of yacc.c */ +#line 974 "fortran.y" + { strcpy(DeclType,(yyvsp[(1) - (3)].na)); strcpy(nameinttypename,(yyvsp[(3) - (3)].na)); } + break; + + case 172: +/* Line 1807 of yacc.c */ +#line 975 "fortran.y" + { strcpy(DeclType,"type"); GlobalDeclarationType = 1; } + break; + + case 174: +/* Line 1807 of yacc.c */ +#line 978 "fortran.y" + { c_selectorgiven = 1; strcpy(c_selectorname,(yyvsp[(2) - (2)].na)); } + break; + + case 175: +/* Line 1807 of yacc.c */ +#line 979 "fortran.y" + { c_star = 1;} + break; + + case 180: +/* Line 1807 of yacc.c */ +#line 987 "fortran.y" + { pos_cur_decl = setposcur()-9; } + break; + + case 181: +/* Line 1807 of yacc.c */ +#line 990 "fortran.y" + { strcpy((yyval.na),"integer"); pos_cur_decl = setposcur()-7; } + break; + + case 182: +/* Line 1807 of yacc.c */ +#line 991 "fortran.y" + { strcpy((yyval.na),"logical"); pos_cur_decl = setposcur()-7; } + break; + + case 183: +/* Line 1807 of yacc.c */ +#line 992 "fortran.y" + { strcpy((yyval.na),"real"); pos_cur_decl = setposcur()-4; } + break; + + case 184: +/* Line 1807 of yacc.c */ +#line 993 "fortran.y" + { strcpy((yyval.na),"complex"); pos_cur_decl = setposcur()-7; } + break; + + case 185: +/* Line 1807 of yacc.c */ +#line 994 "fortran.y" + { strcpy((yyval.na),"double complex"); pos_cur_decl = setposcur()-14; } + break; + + case 186: +/* Line 1807 of yacc.c */ +#line 995 "fortran.y" + { pos_cur_decl = setposcur()-16; strcpy((yyval.na),"real"); strcpy(nameinttypename,"8"); } + break; + + case 188: +/* Line 1807 of yacc.c */ +#line 998 "fortran.y" + {strcpy(vallengspec,(yyvsp[(2) - (2)].na));} + break; + + case 189: +/* Line 1807 of yacc.c */ +#line 1001 "fortran.y" + { sprintf((yyval.na),"*%s",(yyvsp[(1) - (1)].na)); } + break; + + case 190: +/* Line 1807 of yacc.c */ +#line 1002 "fortran.y" + { strcpy((yyval.na),"*(*)"); } + break; + + case 197: +/* Line 1807 of yacc.c */ +#line 1014 "fortran.y" + { + if ( strstr((yyvsp[(3) - (3)].na),"0.d0") ) + { + strcpy(nameinttypename,"8"); + strcpy(NamePrecision,""); + } + else + sprintf(NamePrecision,"%s = %s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); + } + break; + + case 198: +/* Line 1807 of yacc.c */ +#line 1023 "fortran.y" + { strcpy(NamePrecision,(yyvsp[(1) - (1)].na)); } + break; + + case 199: +/* Line 1807 of yacc.c */ +#line 1024 "fortran.y" + { strcpy(NamePrecision,(yyvsp[(1) - (1)].na)); } + break; + + case 200: +/* Line 1807 of yacc.c */ +#line 1025 "fortran.y" + { strcpy(NamePrecision,(yyvsp[(1) - (1)].na)); } + break; + + case 201: +/* Line 1807 of yacc.c */ +#line 1028 "fortran.y" + { strcpy(CharacterSize,(yyvsp[(1) - (1)].na)); strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 202: +/* Line 1807 of yacc.c */ +#line 1029 "fortran.y" + { strcpy(CharacterSize,"*"); strcpy((yyval.na),"*"); } + break; + + case 210: +/* Line 1807 of yacc.c */ +#line 1042 "fortran.y" + { VariableIsParameter = 1; } + break; + + case 212: +/* Line 1807 of yacc.c */ +#line 1044 "fortran.y" + { Allocatabledeclare = 1; } + break; + + case 213: +/* Line 1807 of yacc.c */ +#line 1045 "fortran.y" + { dimsgiven = 1; curdim = (yyvsp[(2) - (2)].d); } + break; + + case 214: +/* Line 1807 of yacc.c */ +#line 1046 "fortran.y" + { ExternalDeclare = 1; } + break; + + case 215: +/* Line 1807 of yacc.c */ +#line 1048 "fortran.y" + { strcpy(IntentSpec,(yyvsp[(3) - (4)].na)); } + break; + + case 217: +/* Line 1807 of yacc.c */ +#line 1050 "fortran.y" + { optionaldeclare = 1 ; } + break; + + case 218: +/* Line 1807 of yacc.c */ +#line 1051 "fortran.y" + { pointerdeclare = 1 ; } + break; + + case 219: +/* Line 1807 of yacc.c */ +#line 1052 "fortran.y" + { SaveDeclare = 1 ; } + break; + + case 220: +/* Line 1807 of yacc.c */ +#line 1053 "fortran.y" + { Targetdeclare = 1; } + break; + + case 221: +/* Line 1807 of yacc.c */ +#line 1056 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 222: +/* Line 1807 of yacc.c */ +#line 1057 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 223: +/* Line 1807 of yacc.c */ +#line 1058 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 224: +/* Line 1807 of yacc.c */ +#line 1061 "fortran.y" + { PublicDeclare = 1; } + break; + + case 225: +/* Line 1807 of yacc.c */ +#line 1062 "fortran.y" + { PrivateDeclare = 1; } + break; + + case 226: +/* Line 1807 of yacc.c */ +#line 1064 "fortran.y" + { (yyval.d) = (listdim*) NULL; } + break; + + case 227: +/* Line 1807 of yacc.c */ +#line 1066 "fortran.y" + { + (yyval.d) = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) (yyval.d)=(yyvsp[(2) - (3)].d); + } + break; + + case 228: +/* Line 1807 of yacc.c */ +#line 1074 "fortran.y" + { + (yyval.d) = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) (yyval.d)=insertdim(NULL,(yyvsp[(1) - (1)].dim1)); + } + break; + + case 229: +/* Line 1807 of yacc.c */ +#line 1080 "fortran.y" + { + (yyval.d) = (listdim*) NULL; + if ( inside_type_declare ) break; + if ( (!inside_type_declare) && created_dimensionlist == 1 ) (yyval.d)=insertdim((yyvsp[(1) - (3)].d),(yyvsp[(3) - (3)].dim1)); + } + break; + + case 230: +/* Line 1807 of yacc.c */ +#line 1086 "fortran.y" + { strcpy((yyval.dim1).first,"1"); strcpy((yyval.dim1).last,(yyvsp[(1) - (1)].na)); Save_Length((yyvsp[(1) - (1)].na),1); } + break; + + case 231: +/* Line 1807 of yacc.c */ +#line 1087 "fortran.y" + { strcpy((yyval.dim1).first,""); strcpy((yyval.dim1).last,""); } + break; + + case 232: +/* Line 1807 of yacc.c */ +#line 1088 "fortran.y" + { strcpy((yyval.dim1).first,(yyvsp[(1) - (2)].na)); Save_Length((yyvsp[(1) - (2)].na),2); strcpy((yyval.dim1).last,""); } + break; + + case 233: +/* Line 1807 of yacc.c */ +#line 1089 "fortran.y" + { strcpy((yyval.dim1).first,""); strcpy((yyval.dim1).last,(yyvsp[(2) - (2)].na)); Save_Length((yyvsp[(2) - (2)].na),1); } + break; + + case 234: +/* Line 1807 of yacc.c */ +#line 1090 "fortran.y" + { strcpy((yyval.dim1).first,(yyvsp[(1) - (3)].na)); Save_Length((yyvsp[(1) - (3)].na),2); strcpy((yyval.dim1).last,(yyvsp[(3) - (3)].na)); Save_Length((yyvsp[(3) - (3)].na),1); } + break; + + case 235: +/* Line 1807 of yacc.c */ +#line 1093 "fortran.y" + { strcpy((yyval.na),"*"); } + break; + + case 236: +/* Line 1807 of yacc.c */ +#line 1094 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 237: +/* Line 1807 of yacc.c */ +#line 1096 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 238: +/* Line 1807 of yacc.c */ +#line 1097 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 239: +/* Line 1807 of yacc.c */ +#line 1098 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 240: +/* Line 1807 of yacc.c */ +#line 1099 "fortran.y" + { sprintf((yyval.na),"(%s)",(yyvsp[(2) - (3)].na)); } + break; + + case 241: +/* Line 1807 of yacc.c */ +#line 1103 "fortran.y" + { sprintf((yyval.na),"SUM(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 242: +/* Line 1807 of yacc.c */ +#line 1104 "fortran.y" + { sprintf((yyval.na),"MAX(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 243: +/* Line 1807 of yacc.c */ +#line 1105 "fortran.y" + { sprintf((yyval.na),"TANH(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 244: +/* Line 1807 of yacc.c */ +#line 1106 "fortran.y" + { sprintf((yyval.na),"MAXVAL(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 245: +/* Line 1807 of yacc.c */ +#line 1107 "fortran.y" + { sprintf((yyval.na),"MIN(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 246: +/* Line 1807 of yacc.c */ +#line 1108 "fortran.y" + { sprintf((yyval.na),"MINVAL(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 247: +/* Line 1807 of yacc.c */ +#line 1109 "fortran.y" + { sprintf((yyval.na),"TRIM(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 248: +/* Line 1807 of yacc.c */ +#line 1110 "fortran.y" + { sprintf((yyval.na),"SQRT(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 249: +/* Line 1807 of yacc.c */ +#line 1111 "fortran.y" + { sprintf((yyval.na),"REAL(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 250: +/* Line 1807 of yacc.c */ +#line 1112 "fortran.y" + { sprintf((yyval.na),"NINT(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 251: +/* Line 1807 of yacc.c */ +#line 1113 "fortran.y" + { sprintf((yyval.na),"FLOAT(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 252: +/* Line 1807 of yacc.c */ +#line 1114 "fortran.y" + { sprintf((yyval.na),"EXP(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 253: +/* Line 1807 of yacc.c */ +#line 1115 "fortran.y" + { sprintf((yyval.na),"COS(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 254: +/* Line 1807 of yacc.c */ +#line 1116 "fortran.y" + { sprintf((yyval.na),"COSH(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 255: +/* Line 1807 of yacc.c */ +#line 1117 "fortran.y" + { sprintf((yyval.na),"ACOS(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 256: +/* Line 1807 of yacc.c */ +#line 1118 "fortran.y" + { sprintf((yyval.na),"SIN(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 257: +/* Line 1807 of yacc.c */ +#line 1119 "fortran.y" + { sprintf((yyval.na),"SINH(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 258: +/* Line 1807 of yacc.c */ +#line 1120 "fortran.y" + { sprintf((yyval.na),"ASIN(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 259: +/* Line 1807 of yacc.c */ +#line 1121 "fortran.y" + { sprintf((yyval.na),"LOG(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 260: +/* Line 1807 of yacc.c */ +#line 1122 "fortran.y" + { sprintf((yyval.na),"TAN(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 261: +/* Line 1807 of yacc.c */ +#line 1123 "fortran.y" + { sprintf((yyval.na),"ATAN(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 262: +/* Line 1807 of yacc.c */ +#line 1124 "fortran.y" + { sprintf((yyval.na),"ABS(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 263: +/* Line 1807 of yacc.c */ +#line 1125 "fortran.y" + { sprintf((yyval.na),"MOD(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 264: +/* Line 1807 of yacc.c */ +#line 1126 "fortran.y" + { sprintf((yyval.na),"SIGN(%s)",(yyvsp[(2) - (3)].na));} + break; + + case 265: +/* Line 1807 of yacc.c */ +#line 1127 "fortran.y" + { sprintf((yyval.na),"MINLOC(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 266: +/* Line 1807 of yacc.c */ +#line 1128 "fortran.y" + { sprintf((yyval.na),"MAXLOC(%s)",(yyvsp[(3) - (4)].na));} + break; + + case 267: +/* Line 1807 of yacc.c */ +#line 1130 "fortran.y" + {strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 268: +/* Line 1807 of yacc.c */ +#line 1131 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 269: +/* Line 1807 of yacc.c */ +#line 1133 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 270: +/* Line 1807 of yacc.c */ +#line 1134 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 271: +/* Line 1807 of yacc.c */ +#line 1135 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 272: +/* Line 1807 of yacc.c */ +#line 1136 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 273: +/* Line 1807 of yacc.c */ +#line 1137 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 274: +/* Line 1807 of yacc.c */ +#line 1138 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 275: +/* Line 1807 of yacc.c */ +#line 1140 "fortran.y" + { strcpy((yyval.na),"+"); } + break; + + case 276: +/* Line 1807 of yacc.c */ +#line 1141 "fortran.y" + { strcpy((yyval.na),"-"); } + break; + + case 277: +/* Line 1807 of yacc.c */ +#line 1145 "fortran.y" + { sprintf((yyval.na),"+%s",(yyvsp[(2) - (2)].na)); } + break; + + case 278: +/* Line 1807 of yacc.c */ +#line 1146 "fortran.y" + { sprintf((yyval.na),"-%s",(yyvsp[(2) - (2)].na)); } + break; + + case 279: +/* Line 1807 of yacc.c */ +#line 1147 "fortran.y" + { sprintf((yyval.na),"*%s",(yyvsp[(2) - (2)].na)); } + break; + + case 280: +/* Line 1807 of yacc.c */ +#line 1148 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 281: +/* Line 1807 of yacc.c */ +#line 1149 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 282: +/* Line 1807 of yacc.c */ +#line 1150 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 283: +/* Line 1807 of yacc.c */ +#line 1151 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 284: +/* Line 1807 of yacc.c */ +#line 1152 "fortran.y" + { sprintf((yyval.na)," > %s",(yyvsp[(2) - (2)].na)); } + break; + + case 285: +/* Line 1807 of yacc.c */ +#line 1153 "fortran.y" + { sprintf((yyval.na)," < %s",(yyvsp[(2) - (2)].na)); } + break; + + case 286: +/* Line 1807 of yacc.c */ +#line 1154 "fortran.y" + { sprintf((yyval.na)," >= %s",(yyvsp[(3) - (3)].na)); } + break; + + case 287: +/* Line 1807 of yacc.c */ +#line 1155 "fortran.y" + { sprintf((yyval.na)," <= %s",(yyvsp[(3) - (3)].na)); } + break; + + case 288: +/* Line 1807 of yacc.c */ +#line 1156 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 289: +/* Line 1807 of yacc.c */ +#line 1157 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 290: +/* Line 1807 of yacc.c */ +#line 1158 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 291: +/* Line 1807 of yacc.c */ +#line 1159 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 292: +/* Line 1807 of yacc.c */ +#line 1160 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 293: +/* Line 1807 of yacc.c */ +#line 1161 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 294: +/* Line 1807 of yacc.c */ +#line 1162 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 295: +/* Line 1807 of yacc.c */ +#line 1163 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 296: +/* Line 1807 of yacc.c */ +#line 1164 "fortran.y" + { sprintf((yyval.na),"%s",(yyvsp[(2) - (2)].na)); } + break; + + case 297: +/* Line 1807 of yacc.c */ +#line 1165 "fortran.y" + { sprintf((yyval.na),"%s",(yyvsp[(2) - (2)].na)); } + break; + + case 298: +/* Line 1807 of yacc.c */ +#line 1167 "fortran.y" + { strcpy((yyval.na),""); } + break; + + case 299: +/* Line 1807 of yacc.c */ +#line 1168 "fortran.y" + { sprintf((yyval.na),"/%s",(yyvsp[(1) - (1)].na)); } + break; + + case 300: +/* Line 1807 of yacc.c */ +#line 1169 "fortran.y" + { sprintf((yyval.na),"/= %s",(yyvsp[(2) - (2)].na));} + break; + + case 301: +/* Line 1807 of yacc.c */ +#line 1170 "fortran.y" + { sprintf((yyval.na),"//%s",(yyvsp[(2) - (2)].na)); } + break; + + case 302: +/* Line 1807 of yacc.c */ +#line 1173 "fortran.y" + { sprintf((yyval.na),"==%s",(yyvsp[(2) - (2)].na)); } + break; + + case 303: +/* Line 1807 of yacc.c */ +#line 1174 "fortran.y" + { sprintf((yyval.na),"= %s",(yyvsp[(1) - (1)].na)); } + break; + + case 304: +/* Line 1807 of yacc.c */ +#line 1177 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 305: +/* Line 1807 of yacc.c */ +#line 1178 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 306: +/* Line 1807 of yacc.c */ +#line 1179 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 307: +/* Line 1807 of yacc.c */ +#line 1183 "fortran.y" + { + agrif_parentcall = 0; + if ( !strcasecmp(identcopy, "Agrif_Parent") ) agrif_parentcall = 1; + if ( Agrif_in_Tok_NAME(identcopy) ) + { + inagrifcallargument = 1; + Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + } + } + break; + + case 308: +/* Line 1807 of yacc.c */ +#line 1194 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); if ( incalldeclare == 0 ) inagrifcallargument = 0; } + break; + + case 309: +/* Line 1807 of yacc.c */ +#line 1195 "fortran.y" + { sprintf((yyval.na)," %s %s ",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 310: +/* Line 1807 of yacc.c */ +#line 1196 "fortran.y" + { sprintf((yyval.na)," %s ( %s )",(yyvsp[(1) - (4)].na),(yyvsp[(3) - (4)].na)); } + break; + + case 311: +/* Line 1807 of yacc.c */ +#line 1197 "fortran.y" + { sprintf((yyval.na)," %s ( %s ) %s ",(yyvsp[(1) - (5)].na),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na)); } + break; + + case 312: +/* Line 1807 of yacc.c */ +#line 1201 "fortran.y" + { + if ( inside_type_declare ) break; + sprintf((yyval.na)," %s ( %s )",(yyvsp[(1) - (4)].na),(yyvsp[(3) - (4)].na)); + ModifyTheAgrifFunction_0((yyvsp[(3) - (4)].na)); + agrif_parentcall = 0; + } + break; + + case 313: +/* Line 1807 of yacc.c */ +#line 1210 "fortran.y" + { + sprintf((yyval.na)," %s %% %s ",(yyvsp[(1) - (4)].na),(yyvsp[(4) - (4)].na)); + if ( incalldeclare == 0 ) inagrifcallargument = 0; + } + break; + + case 314: +/* Line 1807 of yacc.c */ +#line 1216 "fortran.y" + { sprintf((yyval.na),"(/%s/)",(yyvsp[(2) - (3)].na)); } + break; + + case 315: +/* Line 1807 of yacc.c */ +#line 1219 "fortran.y" + { strcpy((yyval.na)," "); } + break; + + case 316: +/* Line 1807 of yacc.c */ +#line 1220 "fortran.y" + { strcpy((yyval.na),(yyvsp[(2) - (2)].na)); } + break; + + case 317: +/* Line 1807 of yacc.c */ +#line 1223 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 318: +/* Line 1807 of yacc.c */ +#line 1224 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 319: +/* Line 1807 of yacc.c */ +#line 1227 "fortran.y" + {strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 320: +/* Line 1807 of yacc.c */ +#line 1228 "fortran.y" + {strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 321: +/* Line 1807 of yacc.c */ +#line 1231 "fortran.y" + { sprintf((yyval.na),"%s :%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));} + break; + + case 322: +/* Line 1807 of yacc.c */ +#line 1232 "fortran.y" + { sprintf((yyval.na),"%s :%s :%s",(yyvsp[(1) - (5)].na),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na));} + break; + + case 323: +/* Line 1807 of yacc.c */ +#line 1233 "fortran.y" + { sprintf((yyval.na),":%s :%s",(yyvsp[(2) - (4)].na),(yyvsp[(4) - (4)].na));} + break; + + case 324: +/* Line 1807 of yacc.c */ +#line 1234 "fortran.y" + { sprintf((yyval.na),": : %s",(yyvsp[(3) - (3)].na));} + break; + + case 325: +/* Line 1807 of yacc.c */ +#line 1235 "fortran.y" + { sprintf((yyval.na),":%s",(yyvsp[(2) - (2)].na));} + break; + + case 326: +/* Line 1807 of yacc.c */ +#line 1236 "fortran.y" + { sprintf((yyval.na),"%s :",(yyvsp[(1) - (2)].na));} + break; + + case 327: +/* Line 1807 of yacc.c */ +#line 1237 "fortran.y" + { sprintf((yyval.na),":");} + break; + + case 328: +/* Line 1807 of yacc.c */ +#line 1240 "fortran.y" + { + if ( afterpercent == 0 ) + { + if ( Agrif_in_Tok_NAME((yyvsp[(1) - (1)].na)) ) Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + if ( !strcasecmp((yyvsp[(1) - (1)].na),"Agrif_Parent") ) agrif_parentcall = 1; + if ( VariableIsFunction((yyvsp[(1) - (1)].na)) ) + { + if ( inagrifcallargument == 1 ) + { + if ( !strcasecmp((yyvsp[(1) - (1)].na),identcopy) ) + { + strcpy(sameagrifname,identcopy); + sameagrifargument = 1; + } + } + strcpy(identcopy,(yyvsp[(1) - (1)].na)); + pointedvar = 0; + + if (variscoupled_0((yyvsp[(1) - (1)].na))) strcpy(truename, getcoupledname_0((yyvsp[(1) - (1)].na))); + else strcpy(truename, (yyvsp[(1) - (1)].na)); + + if ( VarIsNonGridDepend(truename) == 0 && (! Variableshouldberemoved(truename)) ) + { + if ( inagrifcallargument == 1 || varispointer_0(truename) == 1 ) + { + if ( (IsinListe(List_UsedInSubroutine_Var,(yyvsp[(1) - (1)].na)) == 1) || (inagrifcallargument == 1) ) + { + if (varistyped_0(truename) == 0) ModifyTheVariableName_0(truename,strlen((yyvsp[(1) - (1)].na))); + } + } + if ( inagrifcallargument != 1 || sameagrifargument ==1 ) + { + Add_UsedInSubroutine_Var_1(truename); + } + } + NotifyAgrifFunction_0(truename); + } + } + else + { + afterpercent = 0; + } + } + break; + + case 329: +/* Line 1807 of yacc.c */ +#line 1285 "fortran.y" + { strcpy((yyval.na),".TRUE.");} + break; + + case 330: +/* Line 1807 of yacc.c */ +#line 1286 "fortran.y" + { strcpy((yyval.na),".FALSE.");} + break; + + case 331: +/* Line 1807 of yacc.c */ +#line 1287 "fortran.y" + { strcpy((yyval.na),"NULL()"); } + break; + + case 332: +/* Line 1807 of yacc.c */ +#line 1288 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 333: +/* Line 1807 of yacc.c */ +#line 1289 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 334: +/* Line 1807 of yacc.c */ +#line 1290 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 335: +/* Line 1807 of yacc.c */ +#line 1292 "fortran.y" + { sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na)); } + break; + + case 337: +/* Line 1807 of yacc.c */ +#line 1296 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 339: +/* Line 1807 of yacc.c */ +#line 1298 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 340: +/* Line 1807 of yacc.c */ +#line 1299 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 341: +/* Line 1807 of yacc.c */ +#line 1301 "fortran.y" + { strcpy((yyval.na)," ");} + break; + + case 342: +/* Line 1807 of yacc.c */ +#line 1302 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 343: +/* Line 1807 of yacc.c */ +#line 1305 "fortran.y" + { sprintf((yyval.na),"(%s :%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));} + break; + + case 344: +/* Line 1807 of yacc.c */ +#line 1307 "fortran.y" + { strcpy((yyval.na)," ");} + break; + + case 345: +/* Line 1807 of yacc.c */ +#line 1308 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 346: +/* Line 1807 of yacc.c */ +#line 1311 "fortran.y" + { strcpy((yyval.na)," ");} + break; + + case 347: +/* Line 1807 of yacc.c */ +#line 1312 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 348: +/* Line 1807 of yacc.c */ +#line 1314 "fortran.y" + { InitialValueGiven = 0; } + break; + + case 349: +/* Line 1807 of yacc.c */ +#line 1316 "fortran.y" + { + if ( inside_type_declare ) break; + strcpy(InitValue,(yyvsp[(2) - (2)].na)); + InitialValueGiven = 1; + } + break; + + case 350: +/* Line 1807 of yacc.c */ +#line 1322 "fortran.y" + { + if ( inside_type_declare ) break; + strcpy(InitValue,(yyvsp[(2) - (2)].na)); + InitialValueGiven = 2; + } + break; + + case 351: +/* Line 1807 of yacc.c */ +#line 1329 "fortran.y" + {sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na)); } + break; + + case 352: +/* Line 1807 of yacc.c */ +#line 1333 "fortran.y" + { + /* if variables has been declared in a subroutine */ + sprintf(charusemodule, "%s", (yyvsp[(2) - (2)].na)); + if ( firstpass ) + { + Add_NameOfModuleUsed_1((yyvsp[(2) - (2)].na)); + } + else + { + if ( insubroutinedeclare ) + copyuse_0((yyvsp[(2) - (2)].na)); + + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + } + break; + + case 353: +/* Line 1807 of yacc.c */ +#line 1353 "fortran.y" + { + if ( firstpass ) + { + if ( insubroutinedeclare ) + { + Add_CouplePointed_Var_1((yyvsp[(2) - (4)].na),(yyvsp[(4) - (4)].lc)); + coupletmp = (yyvsp[(4) - (4)].lc); + strcpy(ligne,""); + while ( coupletmp ) + { + strcat(ligne, coupletmp->c_namevar); + strcat(ligne, " => "); + strcat(ligne, coupletmp->c_namepointedvar); + coupletmp = coupletmp->suiv; + if ( coupletmp ) strcat(ligne,","); + } + sprintf(charusemodule,"%s",(yyvsp[(2) - (4)].na)); + } + Add_NameOfModuleUsed_1((yyvsp[(2) - (4)].na)); + } + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + break; + + case 354: +/* Line 1807 of yacc.c */ +#line 1380 "fortran.y" + { + /* if variables has been declared in a subroutine */ + sprintf(charusemodule,"%s",(yyvsp[(2) - (6)].na)); + if ( firstpass ) + { + Add_NameOfModuleUsed_1((yyvsp[(2) - (6)].na)); + } + else + { + if ( insubroutinedeclare ) + copyuseonly_0((yyvsp[(2) - (6)].na)); + + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + } + } + } + break; + + case 355: +/* Line 1807 of yacc.c */ +#line 1400 "fortran.y" + { + /* if variables has been declared in a subroutine */ + if ( firstpass ) + { + if ( insubroutinedeclare ) + { + Add_CouplePointed_Var_1((yyvsp[(2) - (6)].na),(yyvsp[(6) - (6)].lc)); + coupletmp = (yyvsp[(6) - (6)].lc); + strcpy(ligne,""); + while ( coupletmp ) + { + strcat(ligne,coupletmp->c_namevar); + if ( strcasecmp(coupletmp->c_namepointedvar,"") ) strcat(ligne," => "); + strcat(ligne,coupletmp->c_namepointedvar); + coupletmp = coupletmp->suiv; + if ( coupletmp ) strcat(ligne,","); + } + sprintf(charusemodule,"%s",(yyvsp[(2) - (6)].na)); + } + Add_NameOfModuleUsed_1((yyvsp[(2) - (6)].na)); + } + else /* if ( firstpass == 0 ) */ + { + if ( inmoduledeclare == 0 ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); + if (oldfortran_out) variableisglobalinmodule((yyvsp[(6) - (6)].lc),(yyvsp[(2) - (6)].na),oldfortran_out,pos_curuseold); + } + else + { + /* if we are in the module declare and if the */ + /* onlylist is a list of global variable */ + variableisglobalinmodule((yyvsp[(6) - (6)].lc), (yyvsp[(2) - (6)].na), fortran_out,pos_curuse); + } + } + } + break; + + case 356: +/* Line 1807 of yacc.c */ +#line 1440 "fortran.y" + { + pos_curuse = setposcur()-strlen((yyvsp[(1) - (1)].na)); + if (firstpass == 0 && oldfortran_out) pos_curuseold = setposcurname(oldfortran_out); + } + break; + + case 357: +/* Line 1807 of yacc.c */ +#line 1447 "fortran.y" + { + (yyval.lc) = (yyvsp[(1) - (1)].lc); + } + break; + + case 358: +/* Line 1807 of yacc.c */ +#line 1451 "fortran.y" + { + /* insert the variable in the list $1 */ + (yyvsp[(3) - (3)].lc)->suiv = (yyvsp[(1) - (3)].lc); + (yyval.lc) = (yyvsp[(3) - (3)].lc); + } + break; + + case 359: +/* Line 1807 of yacc.c */ +#line 1458 "fortran.y" + { + coupletmp = (listcouple *) calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,(yyvsp[(1) - (3)].na)); + strcpy(coupletmp->c_namepointedvar,(yyvsp[(3) - (3)].na)); + coupletmp->suiv = NULL; + (yyval.lc) = coupletmp; + } + break; + + case 360: +/* Line 1807 of yacc.c */ +#line 1467 "fortran.y" + { (yyval.lc) = (yyvsp[(1) - (1)].lc); } + break; + + case 361: +/* Line 1807 of yacc.c */ +#line 1469 "fortran.y" + { + /* insert the variable in the list $1 */ + (yyvsp[(3) - (3)].lc)->suiv = (yyvsp[(1) - (3)].lc); + (yyval.lc) = (yyvsp[(3) - (3)].lc); + } + break; + + case 362: +/* Line 1807 of yacc.c */ +#line 1477 "fortran.y" + { + coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,(yyvsp[(1) - (3)].na)); + strcpy(coupletmp->c_namepointedvar,(yyvsp[(3) - (3)].na)); + coupletmp->suiv = NULL; + (yyval.lc) = coupletmp; + pointedvar = 1; + Add_UsedInSubroutine_Var_1((yyvsp[(1) - (3)].na)); + } + break; + + case 363: +/* Line 1807 of yacc.c */ +#line 1487 "fortran.y" + { + coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); + strcpy(coupletmp->c_namevar,(yyvsp[(1) - (1)].na)); + strcpy(coupletmp->c_namepointedvar,""); + coupletmp->suiv = NULL; + (yyval.lc) = coupletmp; + } + break; + + case 380: +/* Line 1807 of yacc.c */ +#line 1522 "fortran.y" + { inallocate = 0; } + break; + + case 381: +/* Line 1807 of yacc.c */ +#line 1523 "fortran.y" + { inallocate = 0; } + break; + + case 388: +/* Line 1807 of yacc.c */ +#line 1531 "fortran.y" + { + GlobalDeclaration = 0 ; + if ( firstpass == 0 && strcasecmp(subroutinename,"") ) + { + if ( module_declar && insubroutinedeclare == 0 ) fclose(module_declar); + } + if ( strcasecmp(subroutinename,"") ) + { + if ( inmodulemeet == 1 ) + { + /* we are in a module */ + if ( insubroutinedeclare == 1 ) + { + /* it is like an end subroutine */ + insubroutinedeclare = 0 ; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(1); + functiondeclarationisdone = 0; + } + else + { + /* it is like an end module */ + inmoduledeclare = 0 ; + inmodulemeet = 0 ; + } + } + else + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(2); + functiondeclarationisdone = 0; + } + } + strcpy(subroutinename,""); + } + break; + + case 389: +/* Line 1807 of yacc.c */ +#line 1568 "fortran.y" + { + insubroutinedeclare = 0; + inprogramdeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(3); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + break; + + case 390: +/* Line 1807 of yacc.c */ +#line 1577 "fortran.y" + { + if ( strcasecmp(subroutinename,"") ) + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(1); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + } + break; + + case 391: +/* Line 1807 of yacc.c */ +#line 1588 "fortran.y" + { + insubroutinedeclare = 0; + pos_cur = setposcur(); + closeandcallsubloopandincludeit_0(0); + functiondeclarationisdone = 0; + strcpy(subroutinename,""); + } + break; + + case 392: +/* Line 1807 of yacc.c */ +#line 1596 "fortran.y" + { + /* if we never meet the contains keyword */ + if ( firstpass == 0 ) + { + RemoveWordCUR_0(fortran_out, strlen((yyvsp[(2) - (2)].na))+11); // Remove word "end module" + if ( inmoduledeclare && ! aftercontainsdeclare ) + { + Write_Closing_Module(1); + } + fprintf(fortran_out,"\n end module %s\n", curmodulename); + if ( module_declar && insubroutinedeclare == 0 ) + { + fclose(module_declar); + } + } + inmoduledeclare = 0 ; + inmodulemeet = 0 ; + aftercontainsdeclare = 1; + strcpy(curmodulename, ""); + GlobalDeclaration = 0 ; + } + break; + + case 395: +/* Line 1807 of yacc.c */ +#line 1620 "fortran.y" + { + if ( inside_type_declare ) break; + if ( inmoduledeclare ) + { + if ( firstpass == 0 ) + { + RemoveWordCUR_0(fortran_out,9); // Remove word 'contains' + Write_Closing_Module(0); + } + inmoduledeclare = 0 ; + aftercontainsdeclare = 1; + } + else if ( insubroutinedeclare ) + { + incontainssubroutine = 1; + insubroutinedeclare = 0; + incontainssubroutine = 0; + functiondeclarationisdone = 0; + + if ( firstpass ) + List_ContainsSubroutine = Addtolistnom(subroutinename, List_ContainsSubroutine, 0); + else + closeandcallsubloop_contains_0(); + + strcpy(subroutinename, ""); + } + else printf("l.%4d -- TOK_CONTAINS -- MHCHECK\n",line_num_input); + } + break; + + case 483: +/* Line 1807 of yacc.c */ +#line 1898 "fortran.y" + { + strcpy((yyval.na),(yyvsp[(1) - (1)].na)); + pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].na)); + functiondeclarationisdone = 0; + } + break; + + case 484: +/* Line 1807 of yacc.c */ +#line 1906 "fortran.y" + { + strcpy((yyval.na),(yyvsp[(1) - (1)].na)); + pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].na)); + } + break; + + case 485: +/* Line 1807 of yacc.c */ +#line 1913 "fortran.y" + { + strcpy((yyval.na),(yyvsp[(1) - (1)].na)); + pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].na)); + } + break; + + case 486: +/* Line 1807 of yacc.c */ +#line 1920 "fortran.y" + { + strcpy((yyval.na),(yyvsp[(1) - (1)].na)); + pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].na)); + } + break; + + case 487: +/* Line 1807 of yacc.c */ +#line 1926 "fortran.y" + {strcpy((yyval.na),"");} + break; + + case 488: +/* Line 1807 of yacc.c */ +#line 1927 "fortran.y" + {strcpy((yyval.na),(yyvsp[(1) - (1)].na));} + break; + + case 489: +/* Line 1807 of yacc.c */ +#line 1930 "fortran.y" + { created_dimensionlist = 0; } + break; + + case 490: +/* Line 1807 of yacc.c */ +#line 1934 "fortran.y" + { + created_dimensionlist = 1; + if ( ((yyvsp[(3) - (4)].d) == NULL) || ((yyvsp[(4) - (4)].d) == NULL) ) break; + if ( agrif_parentcall == 1 ) + { + ModifyTheAgrifFunction_0((yyvsp[(3) - (4)].d)->dim.last); + agrif_parentcall = 0; + fprintf(fortran_out," = "); + } + } + break; + + case 491: +/* Line 1807 of yacc.c */ +#line 1945 "fortran.y" + { + created_dimensionlist = 1; + } + break; + + case 496: +/* Line 1807 of yacc.c */ +#line 1958 "fortran.y" + { + inagrifcallargument = 0 ; + incalldeclare=0; + if ( oldfortran_out && (callagrifinitgrids == 1) && (firstpass == 0) ) + { + pos_end = setposcur(); + RemoveWordSET_0(fortran_out,pos_curcall,pos_end-pos_curcall); + strcpy(subofagrifinitgrids,subroutinename); + } + Instanciation_0(sameagrifname); + } + break; + + case 502: +/* Line 1807 of yacc.c */ +#line 1979 "fortran.y" + { + if (!strcasecmp((yyvsp[(2) - (2)].na),"MPI_Init") ) callmpiinit = 1; + else callmpiinit = 0; + + if (!strcasecmp((yyvsp[(2) - (2)].na),"Agrif_Init_Grids") ) + { + callagrifinitgrids = 1; + strcpy(meetagrifinitgrids,subroutinename); + } + else + { + callagrifinitgrids = 0; + } + if ( Vartonumber((yyvsp[(2) - (2)].na)) == 1 ) + { + incalldeclare = 1; + inagrifcallargument = 1 ; + Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); + } + } + break; + + case 503: +/* Line 1807 of yacc.c */ +#line 2000 "fortran.y" + { pos_curcall=setposcur()-4; } + break; + + case 506: +/* Line 1807 of yacc.c */ +#line 2008 "fortran.y" + { + if ( callmpiinit == 1 ) + { + strcpy(mpiinitvar,(yyvsp[(1) - (1)].na)); + if ( firstpass == 1 ) Add_UsedInSubroutine_Var_1 (mpiinitvar); + } + } + break; + + case 532: +/* Line 1807 of yacc.c */ +#line 2056 "fortran.y" + { afterpercent = 1; } + break; + + case 572: +/* Line 1807 of yacc.c */ +#line 2115 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 573: +/* Line 1807 of yacc.c */ +#line 2116 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 574: +/* Line 1807 of yacc.c */ +#line 2117 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 575: +/* Line 1807 of yacc.c */ +#line 2118 "fortran.y" + { strcpy((yyval.na),(yyvsp[(1) - (1)].na)); } + break; + + case 576: +/* Line 1807 of yacc.c */ +#line 2119 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 577: +/* Line 1807 of yacc.c */ +#line 2120 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 578: +/* Line 1807 of yacc.c */ +#line 2121 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 579: +/* Line 1807 of yacc.c */ +#line 2122 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 580: +/* Line 1807 of yacc.c */ +#line 2123 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 581: +/* Line 1807 of yacc.c */ +#line 2124 "fortran.y" + { sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na)); } + break; + + case 582: +/* Line 1807 of yacc.c */ +#line 2127 "fortran.y" + { sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na)); } + break; + + case 583: +/* Line 1807 of yacc.c */ +#line 2128 "fortran.y" + { sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na)); } + break; + + case 584: +/* Line 1807 of yacc.c */ +#line 2129 "fortran.y" + { sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na)); } + break; + + case 585: +/* Line 1807 of yacc.c */ +#line 2131 "fortran.y" + { sprintf((yyval.na),"%s=%s,%s)",(yyvsp[(1) - (5)].na),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na));} + break; + + case 586: +/* Line 1807 of yacc.c */ +#line 2132 "fortran.y" + { sprintf((yyval.na),"%s=%s,%s,%s)",(yyvsp[(1) - (7)].na),(yyvsp[(3) - (7)].na),(yyvsp[(5) - (7)].na),(yyvsp[(7) - (7)].na));} + break; + + case 591: +/* Line 1807 of yacc.c */ +#line 2142 "fortran.y" + { Add_Allocate_Var_1((yyvsp[(1) - (1)].na),curmodulename); } + break; + + +/* Line 1807 of yacc.c */ +#line 6110 "fortran.tab.c" + default: break; + } + /* User semantic actions sometimes alter yychar, and that requires + that yytoken be updated with the new translation. We take the + approach of translating immediately before every use of yytoken. + One alternative is translating here after every semantic action, + but that translation would be missed if the semantic action invokes + YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or + if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an + incorrect destructor might then be invoked immediately. In the + case of YYERROR or YYBACKUP, subsequent parser actions might lead + to an incorrect destructor call or verbose syntax error message + before the lookahead is translated. */ + YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); + + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + + *++yyvsp = yyval; + + /* Now `shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; + if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTOKENS]; + + goto yynewstate; + + +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ +yyerrlab: + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); + + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; +#if ! YYERROR_VERBOSE + yyerror (YY_("syntax error")); +#else +# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ + yyssp, yytoken) + { + char const *yymsgp = YY_("syntax error"); + int yysyntax_error_status; + yysyntax_error_status = YYSYNTAX_ERROR; + if (yysyntax_error_status == 0) + yymsgp = yymsg; + else if (yysyntax_error_status == 1) + { + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); + if (!yymsg) + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + yysyntax_error_status = 2; + } + else + { + yysyntax_error_status = YYSYNTAX_ERROR; + yymsgp = yymsg; + } + } + yyerror (yymsgp); + if (yysyntax_error_status == 2) + goto yyexhaustedlab; + } +# undef YYSYNTAX_ERROR +#endif + } + + + + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ + + if (yychar <= YYEOF) + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } + else + { + yydestruct ("Error: discarding", + yytoken, &yylval); + yychar = YYEMPTY; + } + } + + /* Else will try to reuse lookahead token after shifting the error + token. */ + goto yyerrlab1; + + +/*---------------------------------------------------. +| yyerrorlab -- error raised explicitly by YYERROR. | +`---------------------------------------------------*/ +yyerrorlab: + + /* Pacify compilers like GCC when the user code never invokes + YYERROR and the label yyerrorlab therefore never appears in user + code. */ + if (/*CONSTCOND*/ 0) + goto yyerrorlab; + + /* Do not reclaim the symbols of the rule which action triggered + this YYERROR. */ + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + yystate = *yyssp; + goto yyerrlab1; + + +/*-------------------------------------------------------------. +| yyerrlab1 -- common code for both syntax error and YYERROR. | +`-------------------------------------------------------------*/ +yyerrlab1: + yyerrstatus = 3; /* Each real token shifted decrements this. */ + + for (;;) + { + yyn = yypact[yystate]; + if (!yypact_value_is_default (yyn)) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } + + /* Pop the current state because it cannot handle the error token. */ + if (yyssp == yyss) + YYABORT; + + + yydestruct ("Error: popping", + yystos[yystate], yyvsp); + YYPOPSTACK (1); + yystate = *yyssp; + YY_STACK_PRINT (yyss, yyssp); + } + + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END + + + /* Shift the error token. */ + YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + +#if !defined yyoverflow || YYERROR_VERBOSE +/*-------------------------------------------------. +| yyexhaustedlab -- memory exhaustion comes here. | +`-------------------------------------------------*/ +yyexhaustedlab: + yyerror (YY_("memory exhausted")); + yyresult = 2; + /* Fall through. */ +#endif + +yyreturn: + if (yychar != YYEMPTY) + { + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = YYTRANSLATE (yychar); + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval); + } + /* Do not reclaim the symbols of the rule which action triggered + this YYABORT or YYACCEPT. */ + YYPOPSTACK (yylen); + YY_STACK_PRINT (yyss, yyssp); + while (yyssp != yyss) + { + yydestruct ("Cleanup: popping", + yystos[*yyssp], yyvsp); + YYPOPSTACK (1); + } +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif +#if YYERROR_VERBOSE + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); +#endif + /* Make sure YYID is used. */ + return YYID (yyresult); +} + + +/* Line 2055 of yacc.c */ +#line 2156 "fortran.y" + + +void process_fortran(const char *input_file) +{ + extern FILE *fortran_in; + extern FILE *fortran_out; + + char output_file[LONG_FNAME]; + char input_fullpath[LONG_FNAME]; + + if ( todebug == 1 ) printf("Firstpass == %d \n", firstpass); + + yydebug=0; +/******************************************************************************/ +/* 1- Open input file */ +/******************************************************************************/ + + strcpy(cur_filename, input_file); + sprintf(input_fullpath, "%s/%s", input_dir, input_file); + + fortran_in = fopen(input_fullpath, "r"); + if (! fortran_in) + { + printf("Error : File %s does not exist\n", input_fullpath); + exit(1); + } + +/******************************************************************************/ +/* 2- Variables initialization */ +/******************************************************************************/ + + line_num_input = 1; + PublicDeclare = 0; + PrivateDeclare = 0; + ExternalDeclare = 0; + SaveDeclare = 0; + pointerdeclare = 0; + optionaldeclare = 0; + incalldeclare = 0; + inside_type_declare = 0; + Allocatabledeclare = 0 ; + Targetdeclare = 0 ; + VariableIsParameter = 0 ; + strcpy(NamePrecision,""); + c_star = 0 ; + functiondeclarationisdone = 0; + insubroutinedeclare = 0 ; + strcpy(subroutinename," "); + isrecursive = 0; + InitialValueGiven = 0 ; + GlobalDeclarationType = 0; + inmoduledeclare = 0; + incontainssubroutine = 0; + afterpercent = 0; + aftercontainsdeclare = 1; + strcpy(nameinttypename,""); + +/******************************************************************************/ +/* 3- Parsing of the input file (1 time) */ +/******************************************************************************/ + + sprintf(output_file, "%s/%s", output_dir, input_file); + + if (firstpass == 0) fortran_out = fopen(output_file,"w"); + + fortran_parse(); + + if (firstpass == 0) NewModule_Creation_0(); + if (firstpass == 0) fclose(fortran_out); +} +#line 2 "fortran.yy.c" + +#line 4 "fortran.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define yy_create_buffer fortran__create_buffer +#define yy_delete_buffer fortran__delete_buffer +#define yy_flex_debug fortran__flex_debug +#define yy_init_buffer fortran__init_buffer +#define yy_flush_buffer fortran__flush_buffer +#define yy_load_buffer_state fortran__load_buffer_state +#define yy_switch_to_buffer fortran__switch_to_buffer +#define yyin fortran_in +#define yyleng fortran_leng +#define yylex fortran_lex +#define yylineno fortran_lineno +#define yyout fortran_out +#define yyrestart fortran_restart +#define yytext fortran_text +#define yywrap fortran_wrap +#define yyalloc fortran_alloc +#define yyrealloc fortran_realloc +#define yyfree fortran_free + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +typedef uint64_t flex_uint64_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; +#endif /* ! C99 */ + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE fortran_restart(fortran_in ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#define YY_BUF_SIZE 16384 +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern yy_size_t fortran_leng; + +extern FILE *fortran_in, *fortran_out; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + #define YY_LESS_LINENO(n) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up fortran_text. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up fortran_text again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + yy_size_t yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via fortran_restart()), so that the user can continue scanning by + * just pointing fortran_in at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when fortran_text is formed. */ +static char yy_hold_char; +static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ +yy_size_t fortran_leng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow fortran_wrap()'s to do buffer switches + * instead of setting up a fresh fortran_in. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void fortran_restart (FILE *input_file ); +void fortran__switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE fortran__create_buffer (FILE *file,int size ); +void fortran__delete_buffer (YY_BUFFER_STATE b ); +void fortran__flush_buffer (YY_BUFFER_STATE b ); +void fortran_push_buffer_state (YY_BUFFER_STATE new_buffer ); +void fortran_pop_buffer_state (void ); + +static void fortran_ensure_buffer_stack (void ); +static void fortran__load_buffer_state (void ); +static void fortran__init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER fortran__flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE fortran__scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE fortran__scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE fortran__scan_bytes (yyconst char *bytes,yy_size_t len ); + +void *fortran_alloc (yy_size_t ); +void *fortran_realloc (void *,yy_size_t ); +void fortran_free (void * ); + +#define yy_new_buffer fortran__create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + fortran_ensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + fortran__create_buffer(fortran_in,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + fortran_ensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + fortran__create_buffer(fortran_in,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ + +#define fortran_wrap(n) 1 +#define YY_SKIP_YYWRAP + +typedef unsigned char YY_CHAR; + +FILE *fortran_in = (FILE *) 0, *fortran_out = (FILE *) 0; + +typedef int yy_state_type; + +extern int fortran_lineno; + +int fortran_lineno = 1; + +extern char *fortran_text; +#define yytext_ptr fortran_text + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up fortran_text. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + fortran_leng = (yy_size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 176 +#define YY_END_OF_BUFFER 177 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_accept[1132] = + { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 177, 176, 166, 164, 175, 176, 155, 158, + 176, 176, 157, 157, 157, 160, 156, 144, 154, 157, + 159, 162, 161, 163, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 166, 164, 166, 175, 154, 151, + 151, 151, 151, 151, 151, 176, 176, 172, 176, 176, + 176, 157, 151, 0, 0, 166, 0, 0, 175, 175, + 175, 0, 148, 0, 0, 0, 168, 0, 0, 0, + 0, 0, 147, 0, 0, 141, 25, 0, 153, 0, + + 0, 0, 0, 0, 0, 0, 142, 0, 154, 0, + 140, 23, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 42, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 100, 151, 89, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 0, 166, 166, 0, 167, 0, + 0, 0, 0, 0, 0, 165, 166, 0, 175, 174, + 175, 175, 175, 167, 154, 0, 151, 151, 151, 151, + + 89, 151, 151, 0, 172, 0, 0, 0, 0, 0, + 0, 173, 25, 0, 0, 0, 151, 151, 151, 151, + 151, 0, 0, 0, 175, 175, 0, 0, 0, 0, + 0, 0, 0, 0, 146, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 152, 152, + 0, 153, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 123, 151, 151, 151, + 151, 151, 151, 151, 14, 151, 151, 151, 151, 122, + 151, 151, 151, 151, 151, 151, 151, 0, 151, 151, + 151, 151, 151, 151, 129, 151, 151, 134, 151, 151, + + 151, 151, 151, 151, 151, 151, 93, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 126, 151, 151, 151, 151, 151, 130, 151, 151, + 151, 151, 151, 151, 151, 0, 166, 166, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 166, 0, 167, + 175, 175, 175, 154, 0, 151, 151, 151, 151, 151, + 151, 151, 0, 0, 0, 0, 173, 0, 0, 0, + 151, 151, 151, 151, 151, 0, 0, 0, 175, 175, + 0, 0, 0, 0, 0, 0, 0, 0, 153, 0, + 27, 0, 29, 28, 31, 30, 33, 0, 0, 35, + + 0, 0, 133, 125, 151, 151, 128, 151, 131, 151, + 151, 20, 151, 151, 151, 151, 151, 151, 124, 151, + 151, 151, 151, 151, 151, 98, 0, 115, 151, 151, + 151, 151, 151, 151, 151, 151, 0, 116, 151, 0, + 117, 151, 151, 151, 151, 151, 151, 0, 113, 151, + 151, 0, 92, 151, 151, 151, 151, 151, 151, 151, + 0, 102, 151, 151, 0, 119, 151, 151, 151, 151, + 120, 0, 114, 19, 151, 63, 77, 151, 151, 151, + 151, 151, 151, 151, 151, 82, 43, 151, 151, 151, + 151, 72, 151, 151, 127, 151, 76, 57, 151, 0, + + 101, 103, 151, 96, 105, 151, 151, 151, 151, 47, + 166, 166, 0, 0, 0, 0, 0, 0, 0, 166, + 0, 167, 175, 175, 175, 154, 0, 108, 151, 151, + 151, 151, 151, 16, 0, 0, 0, 0, 0, 0, + 151, 151, 151, 151, 0, 0, 0, 175, 175, 0, + 0, 0, 0, 0, 0, 37, 26, 0, 34, 36, + 151, 151, 151, 151, 151, 151, 52, 151, 151, 151, + 151, 132, 151, 151, 151, 151, 151, 0, 151, 151, + 0, 0, 0, 0, 0, 0, 0, 0, 41, 151, + 99, 151, 151, 151, 151, 151, 151, 151, 151, 79, + + 79, 151, 0, 111, 121, 85, 151, 151, 92, 151, + 151, 94, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 0, 0, 151, 151, 151, 55, 151, + 80, 151, 151, 151, 0, 151, 151, 151, 151, 151, + 0, 135, 106, 151, 151, 0, 112, 58, 39, 84, + 166, 166, 108, 0, 0, 0, 0, 0, 166, 0, + 167, 175, 175, 175, 154, 0, 108, 151, 90, 151, + 151, 74, 73, 74, 0, 0, 0, 0, 0, 151, + 52, 151, 132, 0, 21, 0, 175, 21, 0, 21, + 21, 0, 21, 0, 21, 21, 21, 32, 151, 151, + + 151, 21, 151, 151, 66, 151, 151, 151, 151, 151, + 151, 151, 145, 0, 0, 97, 151, 41, 0, 99, + 0, 0, 0, 0, 0, 0, 151, 151, 151, 151, + 151, 151, 151, 151, 0, 118, 151, 151, 151, 151, + 151, 151, 151, 69, 151, 151, 137, 104, 136, 138, + 38, 151, 0, 6, 151, 151, 151, 151, 151, 151, + 87, 0, 151, 8, 78, 17, 151, 151, 86, 166, + 166, 0, 0, 0, 166, 175, 175, 21, 0, 151, + 151, 151, 0, 0, 0, 21, 0, 151, 21, 22, + 0, 169, 22, 22, 22, 22, 22, 22, 22, 22, + + 151, 151, 151, 151, 50, 151, 151, 151, 109, 151, + 0, 151, 151, 97, 0, 151, 0, 0, 0, 0, + 0, 0, 0, 151, 151, 151, 151, 151, 75, 151, + 151, 151, 0, 0, 151, 151, 15, 53, 44, 151, + 45, 0, 151, 151, 5, 151, 151, 70, 88, 3, + 0, 0, 151, 0, 151, 151, 0, 0, 0, 175, + 22, 0, 151, 67, 151, 0, 0, 22, 0, 22, + 151, 4, 151, 151, 151, 151, 91, 151, 151, 0, + 0, 151, 151, 0, 151, 0, 0, 0, 0, 0, + 75, 0, 151, 151, 151, 151, 151, 59, 151, 68, + + 0, 0, 0, 0, 143, 9, 18, 151, 0, 151, + 83, 71, 151, 0, 151, 0, 151, 151, 0, 0, + 175, 0, 62, 151, 0, 0, 0, 151, 151, 139, + 46, 151, 151, 54, 0, 0, 151, 151, 0, 61, + 0, 0, 0, 0, 0, 59, 151, 11, 151, 110, + 151, 151, 0, 0, 0, 0, 0, 143, 95, 0, + 151, 64, 0, 65, 0, 151, 151, 62, 0, 175, + 0, 149, 0, 0, 0, 151, 151, 40, 7, 0, + 0, 151, 151, 61, 0, 60, 0, 11, 0, 110, + 0, 151, 10, 151, 151, 0, 0, 0, 151, 0, + + 0, 107, 2, 149, 175, 0, 0, 0, 0, 51, + 0, 0, 0, 0, 151, 151, 0, 10, 0, 13, + 151, 56, 0, 0, 0, 151, 0, 107, 175, 0, + 0, 0, 0, 0, 0, 0, 0, 151, 151, 13, + 0, 151, 0, 0, 0, 151, 0, 175, 0, 0, + 0, 0, 0, 24, 0, 0, 49, 151, 0, 12, + 0, 0, 0, 151, 0, 175, 0, 0, 0, 150, + 0, 49, 0, 151, 12, 0, 0, 0, 0, 151, + 0, 175, 0, 0, 0, 0, 48, 0, 0, 0, + 81, 1, 175, 0, 0, 0, 48, 81, 175, 0, + + 0, 0, 175, 0, 0, 0, 175, 0, 0, 0, + 175, 0, 0, 0, 175, 0, 0, 0, 175, 170, + 0, 170, 0, 0, 170, 0, 0, 0, 0, 171, + 0 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, + 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, + 33, 34, 1, 1, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, + 61, 1, 62, 1, 63, 1, 64, 65, 66, 67, + + 68, 69, 70, 71, 72, 44, 73, 74, 75, 76, + 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, + 87, 88, 1, 89, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[90] = + { 0, + 1, 1, 2, 1, 1, 3, 1, 1, 1, 1, + 1, 4, 1, 1, 1, 1, 1, 3, 1, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 1, + 1, 1, 1, 1, 6, 7, 7, 5, 5, 8, + 9, 10, 11, 11, 11, 9, 11, 9, 12, 11, + 13, 9, 9, 9, 9, 11, 11, 11, 11, 11, + 1, 1, 11, 6, 7, 7, 5, 5, 8, 9, + 10, 11, 11, 9, 11, 9, 12, 11, 13, 9, + 9, 9, 9, 11, 11, 11, 11, 11, 3 + } ; + +static yyconst flex_int16_t yy_base[1171] = + { 0, + 0, 88, 0, 0, 0, 0, 984, 93, 0, 85, + 0, 0, 891, 64, 98, 103, 80, 129, 96, 99, + 134, 137, 145, 133, 168, 135, 249, 180, 318, 136, + 156, 172, 212, 239, 246, 297, 366, 341, 414, 461, + 247, 294, 398, 334, 407, 476, 506, 517, 459, 566, + 572, 522, 571, 367, 653, 226, 656, 658, 737, 638, + 785, 655, 698, 806, 652, 4012, 878, 4012, 241, 116, + 124, 455, 893, 59, 76, 229, 253, 256, 0, 122, + 127, 872, 4012, 157, 188, 869, 866, 327, 302, 349, + 740, 416, 4012, 768, 592, 4012, 4012, 981, 730, 147, + + 184, 438, 495, 328, 184, 190, 4012, 1048, 335, 969, + 4012, 4012, 0, 269, 315, 149, 319, 486, 462, 248, + 318, 325, 269, 426, 736, 336, 767, 470, 500, 518, + 512, 403, 516, 525, 535, 801, 544, 620, 565, 570, + 589, 768, 483, 589, 810, 592, 613, 638, 650, 664, + 678, 736, 737, 740, 741, 949, 736, 788, 646, 956, + 756, 999, 739, 753, 804, 749, 1043, 972, 962, 769, + 813, 963, 972, 969, 0, 1057, 0, 839, 238, 1044, + 986, 789, 956, 1030, 965, 429, 1109, 1136, 830, 4012, + 1061, 1087, 1091, 1162, 1188, 990, 1095, 1120, 1006, 1042, + + 1170, 1050, 1046, 823, 4012, 1201, 1099, 1115, 1190, 797, + 483, 4012, 790, 1167, 1100, 1194, 1269, 1358, 1255, 1254, + 1195, 1103, 1098, 625, 1148, 1163, 1217, 1237, 1222, 1238, + 1095, 1305, 1325, 1234, 4012, 1334, 1302, 1326, 1107, 1182, + 738, 735, 731, 730, 1244, 1166, 713, 1242, 4012, 1428, + 1374, 1389, 1419, 1244, 1252, 1261, 1263, 1192, 1266, 1301, + 1333, 1333, 1352, 1352, 1387, 1392, 1388, 1389, 1390, 1404, + 1401, 1405, 1407, 1404, 1506, 1471, 1417, 1476, 1430, 0, + 1422, 1437, 1442, 1432, 1484, 1440, 1454, 1497, 1444, 1448, + 1451, 1443, 1445, 1475, 1459, 1530, 1536, 1464, 1477, 1470, + + 1531, 1490, 1491, 1482, 1509, 1511, 0, 1526, 1513, 1519, + 1524, 1527, 1524, 1555, 1516, 1519, 1522, 1546, 1557, 1564, + 1558, 1565, 1555, 1557, 1562, 1561, 1615, 1573, 1575, 1573, + 1576, 1570, 1574, 1582, 1576, 719, 351, 666, 1572, 713, + 1580, 1587, 1584, 1593, 1589, 1596, 1608, 1658, 1684, 1710, + 1652, 1645, 1661, 1741, 1626, 1629, 1635, 1634, 1637, 1703, + 1653, 709, 1654, 1744, 707, 998, 4012, 1712, 1674, 1715, + 1664, 1708, 1725, 1738, 1749, 1622, 1684, 1379, 1672, 1735, + 1743, 1771, 1723, 1772, 1787, 1804, 1815, 1807, 1821, 656, + 4012, 646, 4012, 4012, 4012, 4012, 4012, 1735, 614, 4012, + + 613, 1849, 4012, 0, 1741, 1751, 0, 1796, 0, 1799, + 1799, 0, 1820, 1819, 1811, 1816, 1808, 1821, 0, 1826, + 1822, 1814, 1822, 1825, 1819, 1871, 1955, 4012, 1825, 1821, + 1837, 1830, 1829, 1850, 1823, 1844, 1899, 4012, 1836, 1909, + 4012, 1841, 2040, 1856, 1915, 1858, 1874, 1920, 4012, 1886, + 1872, 1878, 0, 1886, 1879, 1881, 1888, 1896, 1895, 1902, + 1967, 4012, 1897, 1906, 1971, 4012, 1900, 1912, 1906, 1915, + 0, 1980, 4012, 0, 1988, 0, 0, 1929, 1939, 1926, + 1933, 1936, 1946, 1939, 1953, 0, 602, 1949, 1958, 1955, + 1963, 0, 1960, 2063, 0, 598, 0, 0, 1985, 2064, + + 4012, 0, 1960, 0, 0, 2019, 2022, 2024, 2025, 4012, + 792, 880, 2030, 2023, 2043, 2043, 2041, 2042, 581, 2092, + 2118, 2144, 2079, 2080, 2084, 2170, 2045, 1005, 2060, 1022, + 2071, 2134, 2199, 574, 2082, 2174, 2108, 2147, 2148, 2101, + 2154, 2184, 2187, 2190, 2087, 0, 1422, 2144, 0, 2200, + 138, 2202, 571, 2221, 2233, 4012, 4012, 514, 4012, 4012, + 2174, 2192, 2051, 2289, 2080, 2193, 0, 2109, 2194, 2193, + 2199, 0, 2201, 2207, 2204, 2195, 2198, 2270, 2240, 2240, + 2215, 2229, 2246, 2239, 2258, 2275, 2258, 2276, 0, 2276, + 0, 2287, 2279, 2283, 2295, 2283, 2295, 2300, 2335, 4012, + + 0, 2293, 2342, 4012, 0, 0, 2294, 2293, 4012, 2316, + 2321, 0, 2297, 2323, 2312, 2319, 2335, 2334, 2327, 2337, + 2333, 2341, 2338, 197, 451, 2343, 2337, 2347, 0, 2348, + 0, 2335, 2355, 2355, 477, 2343, 2343, 2350, 2355, 2348, + 2275, 4012, 4012, 2349, 2351, 2404, 4012, 0, 0, 0, + 1140, 1249, 1797, 2376, 2082, 2379, 2366, 2432, 2263, 424, + 569, 2417, 2420, 499, 2486, 2384, 2087, 2385, 2427, 2389, + 2398, 2437, 4012, 2448, 2444, 2439, 2452, 479, 2451, 2431, + 2410, 2565, 2416, 0, 4012, 2653, 0, 0, 475, 445, + 4012, 441, 436, 2458, 2462, 2468, 4012, 4012, 2682, 2404, + + 2428, 0, 2441, 2444, 0, 2442, 2449, 2447, 2480, 2465, + 2479, 2553, 0, 2487, 2489, 0, 2493, 4012, 2486, 4012, + 2497, 2509, 2513, 2527, 2535, 2549, 2552, 2538, 2550, 2555, + 2548, 2562, 2552, 2559, 2604, 4012, 2572, 2480, 2561, 2568, + 2573, 2575, 2564, 0, 2569, 2578, 0, 0, 0, 0, + 2660, 2572, 508, 4012, 2583, 2594, 2591, 2650, 2664, 2658, + 0, 2536, 2663, 0, 0, 0, 2715, 2654, 0, 2539, + 2479, 2668, 2663, 2678, 2644, 2682, 426, 421, 2680, 2677, + 2540, 2686, 2701, 2720, 411, 365, 2721, 2790, 2691, 4012, + 2725, 4012, 0, 343, 4012, 307, 2753, 2755, 4012, 0, + + 2747, 2692, 2702, 2706, 0, 2707, 2709, 2719, 0, 2685, + 2776, 2708, 2732, 4012, 2748, 2737, 2773, 2763, 2773, 2780, + 2773, 2788, 2777, 2776, 2785, 2780, 2796, 2786, 0, 2797, + 2798, 2794, 2647, 2867, 2796, 2791, 0, 0, 0, 2795, + 0, 2845, 2798, 2801, 0, 2815, 2825, 0, 0, 0, + 2872, 2840, 2825, 2883, 2847, 2843, 2840, 2548, 2855, 827, + 303, 239, 2841, 2765, 2855, 1020, 2888, 288, 1687, 2861, + 2861, 0, 2851, 2861, 2850, 2855, 0, 2851, 2858, 2858, + 2856, 2863, 2873, 2862, 2878, 2870, 2882, 2880, 2881, 2888, + 4012, 2904, 2901, 2906, 2913, 2885, 2895, 0, 2903, 0, + + 2951, 2978, 2955, 2982, 2994, 0, 0, 2933, 2910, 2917, + 0, 0, 2923, 248, 2932, 2941, 2930, 2939, 2936, 2956, + 2998, 2964, 0, 2967, 3005, 3006, 3007, 2966, 2959, 0, + 0, 2960, 2979, 0, 2973, 2982, 2973, 2987, 2986, 3025, + 2983, 2989, 2995, 2978, 2978, 4012, 2985, 0, 2991, 0, + 2985, 3006, 3066, 3074, 3078, 3090, 3094, 3106, 0, 3009, + 3019, 0, 3041, 0, 3018, 3050, 3056, 4012, 3062, 3076, + 3056, 0, 3087, 3103, 3099, 3072, 3111, 0, 0, 3064, + 3080, 3075, 3079, 3124, 3125, 4012, 3082, 4012, 3085, 4012, + 3080, 3093, 0, 3096, 3104, 3152, 3171, 3113, 3118, 245, + + 3119, 0, 0, 4012, 1737, 184, 3142, 3141, 1922, 0, + 3181, 3186, 3115, 3122, 3127, 3111, 3122, 4012, 3128, 0, + 3129, 0, 3208, 3211, 3152, 3158, 3150, 4012, 3194, 3154, + 2097, 3179, 3201, 3224, 3231, 3169, 3153, 3159, 3179, 4012, + 3183, 3184, 3251, 3258, 3191, 3183, 207, 3229, 3207, 3237, + 194, 3233, 3261, 4012, 3209, 3200, 0, 3220, 3211, 0, + 3309, 3283, 3218, 3228, 3221, 3285, 3236, 3273, 142, 4012, + 3286, 4012, 3243, 3250, 4012, 3339, 3342, 3367, 3248, 3286, + 108, 2482, 40, 2606, 2838, 3273, 0, 3395, 3399, 3290, + 0, 4012, 3302, 3294, 3311, 3350, 4012, 4012, 3299, 3320, + + 3357, 3358, 3375, 3318, 3359, 3380, 3404, 3376, 3300, 3412, + 3362, 3363, 3370, 3415, 3418, 3423, 3420, 3426, 3433, 4012, + 3447, 4012, 3428, 3451, 4012, 3430, 3439, 3454, 3457, 4012, + 4012, 3521, 3534, 3547, 3560, 3573, 3586, 3595, 3608, 3621, + 3634, 3647, 3656, 3669, 3678, 3686, 3699, 3712, 3725, 3738, + 3751, 3764, 3777, 3790, 3803, 3816, 3829, 3842, 3855, 3868, + 3881, 3894, 3907, 3920, 3933, 3946, 3959, 3972, 3985, 3998 + } ; + +static yyconst flex_int16_t yy_def[1171] = + { 0, + 1131, 1, 1132, 1132, 1, 2, 1133, 1133, 1, 2, + 1, 2, 1131, 1131, 1131, 1131, 1134, 1135, 1131, 1131, + 1136, 1137, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 40, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1131, 1131, 55, 1139, 1131, 37, + 1138, 1138, 1138, 1138, 1138, 1131, 1140, 1131, 1140, 1140, + 1140, 1141, 1131, 1131, 1131, 1131, 1131, 1131, 1134, 1134, + 1134, 1135, 1131, 1135, 1135, 1136, 1131, 1136, 1136, 1137, + 1142, 1137, 1131, 1137, 1137, 1131, 1131, 1131, 1143, 1131, + + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1144, 29, 1131, + 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1145, 55, 176, 1146, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 176, 1131, 1139, 1131, + 1139, 1139, 1139, 1131, 1131, 1131, 1138, 1138, 1138, 1138, + + 1138, 1138, 1138, 1140, 1131, 1140, 1140, 1140, 1140, 1147, + 1147, 1131, 1147, 1147, 1147, 1147, 1148, 1148, 218, 218, + 218, 1131, 1131, 1131, 1134, 1134, 1135, 1135, 1136, 1136, + 1142, 1142, 1142, 1142, 1131, 1137, 1137, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1144, + 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1145, 176, 176, 1131, 1146, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 187, 1131, 1131, + 1139, 1139, 1139, 1131, 1131, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1140, 1140, 1147, 1147, 1131, 1147, 1147, 1147, + 218, 218, 218, 218, 218, 1131, 1131, 1131, 1134, 1134, + 1135, 1135, 1136, 1136, 1142, 1137, 1137, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + + 1131, 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1131, 1131, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1131, 1131, 1138, 1131, + 1131, 1138, 1149, 1138, 1138, 1138, 1138, 1131, 1131, 1138, + 1138, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1131, 1131, 1138, 1138, 1131, 1131, 1138, 1138, 1138, 1138, + 1138, 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, + + 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, + 176, 176, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 187, + 1131, 1131, 1139, 1139, 1139, 1131, 1131, 1138, 1138, 1138, + 1138, 1138, 1138, 1131, 1140, 1140, 1140, 1147, 1147, 1147, + 218, 218, 218, 218, 1131, 1150, 1131, 1134, 1151, 1135, + 1152, 1136, 1153, 1137, 1154, 1131, 1131, 1131, 1131, 1131, + 1138, 1138, 1138, 1155, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, 1138, 1138, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, + + 1138, 1138, 1131, 1131, 1138, 1138, 1138, 1138, 1131, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1131, 1131, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1131, 1138, 1138, 1138, 1138, 1138, + 1131, 1131, 1131, 1138, 1138, 1131, 1131, 1138, 1138, 1138, + 176, 176, 1131, 1131, 1131, 1131, 1131, 1131, 176, 1131, + 1131, 1139, 1139, 1156, 1131, 1131, 1131, 1138, 1131, 1138, + 1138, 1131, 1131, 1131, 1140, 1140, 1147, 1157, 1147, 218, + 218, 1158, 218, 1159, 1131, 1131, 1160, 1134, 1161, 1135, + 1131, 1162, 1136, 1163, 1137, 1137, 1131, 1131, 1164, 1138, + + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1131, 1131, 1138, 1138, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1131, 1131, 1138, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 176, + 176, 1131, 1131, 1131, 176, 1139, 1165, 1139, 1131, 1138, + 1138, 1138, 1140, 1140, 1166, 1147, 1147, 1167, 218, 1131, + 1131, 1131, 1134, 1135, 1131, 1136, 1137, 1137, 1131, 1138, + + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1131, 1138, 1138, 1131, 1131, 1138, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1138, 1131, 1168, 1138, 1138, 1138, 1138, 1138, 1138, + 1138, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + 1131, 1131, 1138, 1131, 1138, 1138, 1131, 1131, 1131, 1139, + 1139, 1131, 1138, 1131, 1138, 1140, 1140, 1147, 1147, 218, + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1131, + 1131, 1138, 1138, 1131, 1138, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, + + 1168, 1168, 1131, 1169, 1168, 1138, 1138, 1138, 1131, 1138, + 1138, 1138, 1138, 1131, 1138, 1131, 1138, 1138, 1131, 1131, + 1139, 1131, 1138, 1138, 1140, 1140, 1147, 1138, 1138, 1138, + 1138, 1138, 1138, 1138, 1131, 1131, 1138, 1138, 1131, 1138, + 1131, 1131, 1131, 1131, 1131, 1131, 1138, 1138, 1138, 1138, + 1138, 1138, 1131, 1169, 1169, 1168, 1169, 1169, 1138, 1131, + 1138, 1138, 1131, 1138, 1131, 1138, 1138, 1131, 1131, 1139, + 1131, 1138, 1140, 1140, 1147, 1138, 1138, 1138, 1138, 1131, + 1131, 1138, 1138, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1138, 1138, 1138, 1138, 1131, 1168, 1131, 1138, 1131, + + 1131, 1138, 1138, 1131, 1139, 1131, 1140, 1140, 1147, 1138, + 1131, 1131, 1131, 1131, 1138, 1138, 1131, 1131, 1131, 1138, + 1138, 1138, 1131, 1168, 1131, 1138, 1131, 1131, 1139, 1131, + 1140, 1140, 1147, 1131, 1131, 1131, 1131, 1138, 1138, 1131, + 1131, 1138, 1131, 1168, 1131, 1138, 1131, 1139, 1131, 1140, + 1170, 1147, 1131, 1131, 1131, 1131, 1138, 1138, 1131, 1138, + 1131, 1168, 1131, 1138, 1131, 1139, 1131, 1140, 1170, 1131, + 1147, 1131, 1131, 1138, 1131, 1131, 1168, 1168, 1131, 1138, + 1131, 1139, 1131, 1140, 1147, 1131, 1138, 1168, 1169, 1131, + 1138, 1131, 1139, 1131, 1140, 1147, 1131, 1131, 1139, 1131, + + 1140, 1147, 1139, 1131, 1140, 1147, 1139, 1131, 1140, 1147, + 1139, 1131, 1140, 1147, 1139, 1131, 1140, 1147, 1139, 1131, + 1131, 1131, 1140, 1147, 1131, 1140, 1140, 1140, 1140, 1131, + 0, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131 + } ; + +static yyconst flex_int16_t yy_nxt[4102] = + { 0, + 14, 15, 16, 15, 17, 18, 14, 19, 20, 21, + 22, 23, 24, 25, 24, 26, 24, 27, 28, 29, + 29, 29, 29, 29, 29, 29, 29, 29, 29, 30, + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 42, 42, 44, 45, 46, 47, 48, + 42, 49, 50, 51, 52, 42, 53, 42, 42, 54, + 24, 24, 42, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 42, 44, 45, 46, 47, 48, 42, 49, + 50, 51, 52, 42, 53, 42, 42, 54, 14, 55, + 56, 57, 58, 222, 69, 68, 69, 70, 72, 76, + + 77, 76, 1094, 74, 78, 77, 78, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 75, 205, 80, + 1092, 73, 222, 208, 60, 61, 205, 223, 62, 70, + 63, 71, 74, 81, 83, 74, 87, 74, 74, 91, + 82, 64, 65, 691, 1070, 75, 92, 93, 80, 75, + 73, 75, 75, 60, 61, 223, 225, 62, 70, 63, + 71, 81, 83, 96, 74, 111, 74, 74, 84, 64, + 65, 209, 74, 88, 74, 74, 94, 75, 226, 75, + 75, 97, 85, 255, 74, 225, 75, 89, 75, 75, + 95, 227, 107, 83, 239, 74, 1070, 84, 75, 209, + + 624, 74, 88, 74, 74, 94, 226, 74, 625, 75, + 85, 74, 255, 74, 75, 89, 75, 75, 95, 74, + 227, 75, 239, 1065, 74, 75, 75, 78, 77, 78, + 76, 77, 76, 75, 240, 247, 74, 75, 248, 228, + 74, 179, 206, 205, 206, 112, 1030, 179, 74, 75, + 98, 74, 98, 75, 78, 77, 78, 224, 77, 224, + 1027, 75, 240, 247, 963, 75, 248, 228, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 74, 207, + 74, 114, 115, 100, 261, 116, 116, 101, 74, 102, + 212, 117, 75, 75, 103, 142, 104, 105, 118, 119, + + 121, 922, 75, 263, 87, 190, 106, 74, 207, 87, + 114, 115, 100, 261, 116, 116, 101, 74, 102, 117, + 75, 253, 103, 142, 104, 105, 118, 119, 121, 87, + 75, 120, 263, 116, 106, 108, 116, 109, 109, 109, + 109, 109, 109, 109, 109, 109, 109, 121, 83, 253, + 121, 91, 511, 230, 512, 110, 110, 74, 92, 93, + 120, 229, 116, 254, 256, 116, 245, 212, 110, 260, + 262, 75, 268, 116, 1131, 121, 246, 175, 121, 127, + 116, 230, 146, 128, 110, 110, 74, 121, 1131, 129, + 229, 254, 256, 130, 121, 245, 110, 260, 262, 75, + + 122, 268, 116, 1131, 246, 116, 116, 123, 127, 116, + 146, 124, 128, 212, 125, 121, 1131, 129, 91, 121, + 121, 130, 121, 190, 126, 92, 93, 179, 190, 122, + 78, 77, 78, 179, 116, 116, 123, 143, 87, 124, + 275, 147, 125, 87, 144, 145, 116, 121, 121, 148, + 83, 121, 126, 116, 753, 149, 211, 212, 211, 131, + 121, 132, 133, 754, 134, 135, 143, 121, 213, 275, + 147, 136, 144, 145, 264, 116, 241, 82, 148, 121, + 795, 212, 116, 149, 366, 367, 366, 131, 121, 132, + 133, 242, 134, 135, 214, 121, 259, 162, 116, 136, + + 116, 190, 264, 137, 762, 241, 138, 139, 215, 140, + 150, 753, 121, 260, 121, 141, 271, 255, 151, 242, + 754, 113, 152, 214, 153, 259, 162, 116, 257, 116, + 154, 698, 137, 243, 138, 139, 215, 140, 258, 150, + 121, 260, 121, 141, 271, 116, 255, 151, 244, 113, + 152, 158, 153, 155, 272, 156, 116, 257, 154, 121, + 157, 116, 243, 273, 274, 159, 258, 276, 160, 172, + 121, 161, 179, 87, 116, 121, 244, 534, 179, 277, + 158, 155, 272, 156, 534, 116, 278, 121, 157, 282, + 116, 273, 274, 159, 91, 276, 160, 172, 121, 161, + + 163, 92, 93, 121, 164, 116, 169, 277, 165, 643, + 116, 116, 173, 170, 278, 635, 166, 282, 285, 167, + 168, 286, 174, 171, 121, 121, 378, 77, 378, 163, + 560, 559, 295, 164, 116, 169, 287, 165, 290, 116, + 116, 173, 170, 237, 166, 196, 285, 167, 168, 286, + 174, 171, 121, 121, 176, 77, 177, 178, 186, 187, + 190, 295, 179, 557, 287, 191, 290, 511, 283, 512, + 296, 237, 197, 556, 284, 188, 188, 188, 188, 188, + 188, 188, 188, 188, 188, 297, 198, 298, 310, 180, + 181, 116, 74, 182, 116, 183, 283, 192, 296, 172, + + 200, 197, 284, 142, 203, 121, 184, 185, 121, 212, + 299, 193, 534, 297, 198, 190, 298, 310, 180, 181, + 116, 74, 182, 116, 183, 300, 192, 172, 200, 510, + 400, 142, 203, 121, 184, 185, 121, 143, 299, 193, + 194, 232, 233, 232, 144, 201, 179, 396, 395, 234, + 235, 121, 394, 300, 108, 393, 195, 195, 195, 195, + 195, 195, 195, 195, 195, 195, 143, 238, 238, 288, + 91, 288, 144, 201, 110, 110, 74, 92, 93, 121, + 238, 301, 265, 266, 302, 303, 304, 110, 267, 307, + 75, 313, 212, 651, 319, 652, 238, 238, 320, 212, + + 323, 269, 236, 110, 110, 74, 270, 330, 238, 301, + 265, 266, 302, 303, 304, 110, 267, 307, 75, 199, + 313, 289, 319, 127, 116, 205, 320, 128, 323, 190, + 269, 236, 190, 129, 344, 270, 330, 130, 121, 308, + 169, 190, 309, 279, 321, 116, 291, 170, 199, 289, + 280, 322, 127, 116, 281, 331, 128, 171, 292, 121, + 293, 129, 344, 294, 202, 130, 121, 308, 87, 169, + 309, 87, 279, 321, 116, 291, 170, 83, 280, 322, + 205, 651, 281, 652, 331, 171, 292, 121, 293, 921, + 1131, 294, 202, 210, 211, 212, 211, 210, 210, 210, + + 216, 210, 210, 210, 210, 210, 210, 210, 210, 210, + 210, 210, 217, 217, 217, 217, 217, 217, 217, 217, + 217, 217, 210, 210, 210, 210, 210, 197, 217, 217, + 217, 217, 218, 217, 123, 217, 217, 217, 219, 217, + 217, 198, 217, 217, 217, 217, 220, 217, 217, 217, + 217, 221, 217, 210, 210, 217, 197, 217, 217, 217, + 217, 218, 217, 123, 217, 217, 219, 217, 217, 198, + 217, 217, 217, 217, 220, 217, 217, 217, 217, 221, + 217, 210, 98, 251, 98, 251, 68, 305, 252, 252, + 252, 252, 252, 252, 252, 252, 252, 252, 311, 366, + + 367, 366, 306, 345, 312, 332, 667, 326, 667, 328, + 333, 335, 1131, 329, 334, 100, 305, 347, 327, 101, + 343, 102, 205, 669, 355, 669, 103, 311, 104, 105, + 306, 345, 312, 314, 332, 315, 326, 328, 106, 333, + 335, 329, 1131, 334, 100, 347, 327, 1131, 101, 343, + 102, 316, 317, 355, 103, 318, 104, 105, 337, 358, + 338, 1131, 314, 190, 315, 1131, 106, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 324, 341, 316, + 317, 223, 925, 318, 362, 110, 110, 358, 346, 190, + 359, 325, 342, 190, 260, 351, 1131, 233, 110, 361, + + 1131, 205, 212, 1131, 385, 235, 324, 341, 1131, 223, + 339, 186, 348, 362, 110, 110, 346, 205, 359, 325, + 342, 352, 260, 1131, 351, 1131, 110, 361, 349, 349, + 349, 349, 349, 349, 349, 349, 349, 349, 339, 350, + 262, 770, 353, 771, 390, 179, 209, 356, 376, 363, + 352, 369, 377, 1131, 1131, 349, 349, 349, 349, 349, + 349, 349, 349, 349, 349, 350, 265, 357, 262, 212, + 353, 179, 267, 390, 209, 356, 376, 1131, 363, 369, + 377, 349, 349, 349, 349, 349, 349, 349, 349, 349, + 349, 350, 205, 379, 265, 357, 212, 179, 1131, 391, + + 267, 368, 206, 205, 206, 108, 291, 354, 354, 354, + 354, 354, 354, 354, 354, 354, 354, 380, 292, 399, + 293, 379, 83, 360, 87, 110, 110, 364, 370, 371, + 368, 375, 1131, 1131, 408, 291, 233, 392, 110, 207, + 87, 1131, 83, 385, 235, 380, 292, 399, 293, 1131, + 770, 360, 771, 1131, 110, 110, 364, 370, 371, 1131, + 375, 397, 381, 408, 1131, 392, 110, 383, 207, 365, + 365, 212, 365, 365, 365, 365, 365, 365, 365, 365, + 365, 365, 365, 365, 365, 365, 365, 365, 371, 371, + 381, 382, 384, 401, 398, 383, 404, 405, 365, 365, + + 365, 365, 365, 373, 91, 374, 232, 233, 232, 406, + 407, 92, 93, 409, 234, 235, 1131, 371, 371, 382, + 384, 401, 398, 1131, 404, 405, 232, 233, 232, 365, + 365, 373, 1131, 374, 234, 235, 91, 406, 407, 1131, + 388, 409, 388, 92, 93, 389, 389, 389, 389, 389, + 389, 389, 389, 389, 389, 410, 387, 365, 365, 365, + 212, 365, 365, 365, 365, 365, 365, 365, 365, 365, + 365, 365, 365, 365, 365, 365, 365, 411, 412, 386, + 547, 77, 547, 410, 387, 1131, 1131, 365, 365, 365, + 365, 365, 372, 252, 252, 252, 252, 252, 252, 252, + + 252, 252, 252, 413, 414, 411, 412, 386, 252, 252, + 252, 252, 252, 252, 252, 252, 252, 252, 365, 365, + 402, 372, 402, 686, 77, 686, 1131, 1131, 417, 419, + 403, 413, 414, 415, 420, 421, 416, 1131, 422, 423, + 424, 425, 426, 1131, 1131, 418, 365, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 417, 419, 439, + 444, 415, 420, 421, 416, 238, 238, 422, 423, 424, + 425, 426, 437, 418, 437, 445, 446, 440, 238, 440, + 1131, 1131, 442, 443, 447, 448, 450, 448, 439, 444, + 451, 1131, 453, 454, 238, 238, 455, 456, 288, 457, + + 288, 460, 1131, 438, 445, 446, 238, 427, 441, 427, + 442, 443, 447, 458, 450, 470, 449, 1131, 469, 451, + 453, 454, 1131, 471, 455, 456, 459, 457, 474, 1131, + 460, 461, 472, 461, 472, 1131, 475, 465, 428, 465, + 476, 462, 458, 429, 470, 430, 469, 466, 431, 1131, + 452, 471, 432, 478, 459, 433, 477, 474, 434, 435, + 479, 1131, 436, 473, 475, 480, 481, 484, 476, 485, + 488, 482, 429, 489, 430, 463, 490, 431, 452, 483, + 432, 467, 478, 433, 477, 464, 434, 435, 491, 479, + 436, 468, 486, 480, 481, 492, 484, 485, 488, 482, + + 487, 489, 493, 463, 490, 494, 495, 483, 496, 467, + 497, 498, 499, 464, 502, 503, 500, 491, 500, 468, + 504, 486, 505, 506, 492, 507, 501, 508, 487, 509, + 346, 493, 513, 494, 514, 495, 496, 515, 497, 498, + 499, 516, 517, 502, 503, 518, 519, 190, 504, 1131, + 505, 506, 1131, 507, 190, 508, 205, 509, 346, 511, + 513, 520, 514, 190, 1131, 515, 527, 528, 530, 516, + 517, 417, 531, 518, 545, 519, 212, 521, 521, 521, + 521, 521, 521, 521, 521, 521, 521, 522, 529, 212, + 524, 533, 523, 179, 535, 527, 528, 530, 371, 1131, + + 417, 531, 545, 521, 521, 521, 521, 521, 521, 521, + 521, 521, 521, 522, 212, 525, 529, 212, 524, 179, + 533, 523, 546, 535, 548, 87, 1131, 371, 539, 521, + 521, 521, 521, 521, 521, 521, 521, 521, 521, 190, + 1131, 532, 371, 525, 522, 536, 205, 536, 83, 927, + 179, 546, 548, 541, 459, 540, 539, 538, 108, 371, + 526, 526, 526, 526, 526, 526, 526, 526, 526, 526, + 532, 371, 371, 549, 87, 552, 83, 542, 110, 110, + 1131, 541, 459, 371, 540, 538, 537, 562, 371, 233, + 558, 110, 543, 561, 544, 550, 385, 235, 667, 1029, + + 667, 371, 549, 552, 1131, 542, 91, 110, 110, 551, + 553, 1131, 371, 92, 93, 537, 562, 91, 558, 110, + 543, 561, 544, 550, 92, 93, 389, 389, 389, 389, + 389, 389, 389, 389, 389, 389, 563, 564, 551, 553, + 389, 389, 389, 389, 389, 389, 389, 389, 389, 389, + 402, 565, 402, 555, 566, 1131, 554, 567, 1131, 568, + 403, 569, 570, 571, 572, 563, 564, 573, 574, 575, + 576, 577, 578, 589, 578, 590, 591, 1131, 592, 565, + 593, 596, 555, 566, 554, 597, 567, 568, 594, 569, + 570, 598, 571, 572, 599, 573, 574, 575, 576, 577, + + 437, 589, 437, 590, 595, 591, 592, 602, 593, 596, + 440, 605, 440, 579, 597, 606, 603, 594, 603, 598, + 607, 448, 599, 448, 212, 608, 609, 580, 610, 1131, + 613, 438, 595, 611, 612, 602, 614, 616, 617, 605, + 619, 441, 579, 615, 606, 618, 621, 604, 620, 607, + 1131, 622, 449, 608, 609, 580, 427, 610, 427, 613, + 623, 611, 612, 1131, 629, 614, 616, 617, 461, 619, + 461, 615, 465, 618, 465, 621, 620, 627, 462, 622, + 632, 472, 466, 472, 1033, 628, 630, 428, 623, 631, + 633, 624, 581, 629, 582, 634, 640, 583, 645, 625, + + 636, 584, 1131, 637, 585, 627, 638, 586, 587, 632, + 639, 588, 473, 628, 630, 1131, 1131, 631, 633, 1131, + 646, 581, 646, 582, 634, 640, 583, 645, 636, 584, + 626, 637, 585, 644, 638, 586, 587, 1131, 639, 588, + 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, + 600, 647, 600, 600, 600, 600, 600, 600, 600, 626, + 648, 644, 649, 650, 641, 500, 641, 500, 653, 600, + 600, 600, 600, 600, 642, 501, 654, 655, 656, 657, + 658, 190, 190, 669, 205, 669, 190, 1131, 667, 648, + 667, 649, 650, 651, 668, 659, 666, 653, 701, 205, + + 600, 600, 571, 212, 654, 670, 655, 656, 657, 658, + 205, 660, 660, 660, 660, 660, 660, 660, 660, 660, + 660, 661, 664, 668, 666, 684, 701, 179, 600, 703, + 662, 571, 663, 675, 670, 1131, 1131, 660, 660, 660, + 660, 660, 660, 660, 660, 660, 660, 661, 1131, 212, + 212, 664, 679, 179, 684, 676, 705, 703, 662, 1050, + 663, 675, 1131, 660, 660, 660, 660, 660, 660, 660, + 660, 660, 660, 661, 614, 536, 205, 536, 1131, 179, + 679, 615, 687, 676, 705, 671, 678, 108, 371, 665, + 665, 665, 665, 665, 665, 665, 665, 665, 665, 677, + + 672, 1131, 672, 614, 87, 83, 680, 110, 110, 615, + 673, 687, 699, 671, 674, 678, 537, 371, 371, 1131, + 110, 371, 681, 91, 371, 682, 700, 677, 683, 704, + 92, 93, 706, 712, 680, 91, 110, 110, 689, 713, + 692, 699, 696, 697, 707, 537, 708, 371, 110, 709, + 371, 681, 710, 371, 682, 700, 711, 683, 704, 694, + 1131, 706, 712, 718, 770, 186, 775, 689, 713, 692, + 1131, 578, 707, 578, 708, 1131, 641, 709, 641, 716, + 710, 717, 1131, 719, 711, 720, 642, 721, 694, 685, + 685, 718, 685, 685, 685, 685, 685, 685, 685, 685, + + 685, 685, 685, 685, 685, 685, 685, 685, 716, 722, + 717, 719, 714, 723, 720, 721, 725, 726, 685, 685, + 685, 685, 685, 727, 728, 1131, 715, 729, 730, 724, + 731, 1131, 732, 733, 734, 739, 735, 722, 735, 1131, + 737, 714, 723, 603, 725, 603, 726, 738, 742, 685, + 685, 727, 740, 728, 715, 729, 730, 724, 741, 731, + 732, 743, 733, 734, 739, 744, 745, 736, 737, 746, + 747, 1131, 748, 749, 604, 738, 742, 685, 750, 751, + 752, 740, 755, 1131, 756, 757, 758, 741, 759, 760, + 743, 761, 766, 744, 745, 763, 764, 765, 746, 747, + + 748, 767, 749, 768, 769, 646, 750, 646, 751, 752, + 772, 755, 756, 773, 757, 758, 759, 774, 760, 190, + 761, 766, 190, 763, 764, 765, 779, 780, 669, 767, + 669, 768, 769, 672, 781, 672, 647, 782, 672, 772, + 672, 205, 773, 673, 371, 774, 205, 674, 673, 674, + 371, 674, 674, 212, 212, 779, 780, 801, 777, 776, + 91, 1131, 781, 674, 91, 371, 782, 798, 799, 788, + 91, 92, 93, 371, 802, 803, 1131, 92, 93, 371, + 770, 833, 771, 833, 190, 801, 783, 777, 776, 179, + 785, 834, 784, 787, 371, 179, 1131, 804, 788, 805, + + 806, 807, 802, 108, 803, 109, 109, 109, 109, 109, + 109, 109, 109, 109, 109, 783, 808, 1131, 809, 785, + 784, 810, 787, 110, 110, 804, 814, 805, 806, 807, + 815, 816, 1131, 817, 818, 1131, 110, 851, 1131, 851, + 770, 864, 770, 864, 1093, 808, 809, 852, 1131, 864, + 810, 864, 110, 110, 811, 814, 811, 819, 820, 815, + 816, 817, 821, 818, 110, 786, 786, 212, 786, 786, + 786, 786, 786, 786, 786, 786, 786, 786, 786, 786, + 786, 786, 786, 786, 822, 819, 820, 823, 824, 812, + 826, 821, 825, 827, 786, 786, 786, 786, 786, 828, + + 829, 1131, 813, 830, 831, 735, 832, 735, 205, 835, + 836, 837, 822, 838, 1131, 839, 823, 824, 812, 826, + 825, 840, 827, 841, 844, 786, 786, 828, 846, 829, + 813, 830, 831, 1131, 1131, 832, 736, 835, 1131, 836, + 837, 845, 838, 839, 847, 770, 186, 775, 833, 840, + 833, 841, 844, 786, 791, 77, 791, 846, 834, 792, + 792, 842, 792, 842, 1131, 1131, 792, 792, 1095, 845, + 792, 1131, 847, 792, 792, 792, 792, 792, 792, 792, + 792, 792, 790, 790, 190, 790, 790, 790, 790, 790, + 790, 790, 790, 790, 790, 790, 790, 790, 790, 790, + + 790, 848, 849, 205, 850, 853, 1131, 856, 858, 843, + 857, 790, 790, 790, 790, 790, 854, 859, 854, 862, + 865, 860, 205, 212, 863, 371, 791, 77, 791, 848, + 873, 849, 850, 879, 853, 856, 858, 843, 874, 857, + 866, 1131, 790, 790, 875, 876, 859, 877, 862, 865, + 860, 855, 863, 878, 371, 91, 882, 91, 867, 873, + 869, 879, 92, 93, 92, 93, 864, 874, 864, 866, + 790, 1131, 1131, 875, 876, 1131, 877, 811, 1131, 811, + 855, 871, 878, 883, 882, 872, 884, 867, 885, 869, + 868, 868, 212, 868, 868, 868, 868, 868, 868, 868, + + 868, 868, 868, 868, 868, 868, 868, 868, 868, 886, + 871, 883, 880, 888, 872, 884, 885, 887, 889, 868, + 868, 868, 868, 868, 890, 881, 891, 1131, 892, 893, + 894, 895, 896, 1131, 897, 898, 899, 908, 886, 900, + 212, 880, 888, 906, 907, 887, 842, 889, 842, 910, + 868, 868, 890, 881, 911, 891, 892, 893, 894, 895, + 912, 896, 897, 913, 898, 899, 908, 900, 902, 903, + 902, 906, 907, 851, 914, 851, 904, 910, 868, 905, + 915, 917, 911, 852, 854, 918, 854, 919, 912, 920, + 205, 924, 913, 923, 909, 371, 928, 1131, 929, 930, + + 1096, 931, 932, 914, 933, 934, 935, 936, 915, 937, + 917, 938, 1131, 939, 918, 919, 940, 944, 920, 916, + 924, 923, 909, 941, 371, 928, 929, 942, 930, 931, + 932, 943, 933, 934, 935, 936, 945, 937, 950, 926, + 938, 939, 946, 947, 948, 940, 944, 949, 916, 951, + 952, 941, 902, 903, 902, 942, 953, 903, 953, 943, + 904, 960, 1131, 905, 945, 961, 950, 926, 1131, 959, + 964, 946, 947, 948, 962, 965, 949, 951, 952, 902, + 903, 902, 966, 955, 956, 955, 967, 904, 968, 960, + 905, 957, 969, 961, 958, 902, 903, 902, 959, 964, + + 190, 971, 962, 904, 965, 972, 905, 205, 205, 212, + 966, 976, 977, 978, 967, 1131, 968, 979, 1131, 980, + 981, 969, 982, 983, 984, 987, 985, 988, 985, 989, + 971, 990, 991, 992, 972, 970, 986, 993, 994, 976, + 977, 978, 995, 973, 975, 974, 979, 980, 1131, 981, + 982, 1131, 983, 984, 987, 999, 988, 998, 989, 990, + 991, 992, 1131, 1131, 970, 993, 994, 996, 903, 996, + 1001, 995, 973, 975, 974, 955, 956, 955, 190, 955, + 956, 955, 1000, 957, 999, 998, 958, 957, 1002, 205, + 958, 997, 956, 997, 1003, 955, 956, 955, 1001, 904, + + 1004, 212, 905, 957, 1006, 205, 958, 955, 956, 955, + 1010, 1000, 1011, 1013, 1011, 957, 1014, 1002, 958, 1131, + 1015, 1016, 1012, 1003, 1005, 985, 985, 985, 985, 1004, + 1017, 1018, 1006, 1019, 1007, 986, 986, 1008, 1021, 1010, + 1020, 1013, 1022, 205, 205, 1014, 1131, 1009, 1015, 1025, + 1016, 1131, 1005, 1023, 903, 1023, 1026, 1028, 1017, 1018, + 1036, 1019, 1007, 1039, 1037, 1038, 1008, 1021, 1020, 1040, + 1041, 1022, 1024, 903, 1024, 1009, 1042, 1032, 1025, 1031, + 904, 205, 1011, 905, 1011, 1026, 1028, 1034, 1036, 1034, + 1045, 1039, 1012, 1037, 1038, 1046, 190, 1040, 1047, 1041, + + 1035, 1049, 1035, 212, 1042, 1056, 1032, 1055, 1031, 1043, + 903, 1043, 1044, 903, 1044, 1131, 1057, 1051, 1035, 1045, + 904, 1058, 1060, 905, 1046, 1034, 1047, 1034, 1063, 1049, + 1059, 190, 1053, 1056, 1053, 212, 1055, 1064, 1035, 205, + 1035, 1048, 1073, 1054, 1057, 1035, 1051, 1035, 1052, 1075, + 1058, 1060, 1061, 903, 1061, 1067, 1035, 1063, 1059, 1062, + 903, 1062, 1053, 1035, 1053, 1064, 1072, 904, 1074, 1048, + 905, 1073, 1079, 1054, 1068, 205, 1052, 1066, 1075, 1080, + 1081, 1071, 1131, 1067, 1078, 903, 1078, 190, 212, 1083, + 1131, 1086, 904, 1131, 1072, 905, 1074, 1087, 1131, 1090, + + 1079, 190, 205, 1068, 190, 1066, 1131, 1080, 1081, 1071, + 1076, 903, 1076, 205, 1131, 1077, 1077, 1083, 1077, 1086, + 1097, 1084, 1077, 1077, 1091, 1087, 1077, 1090, 1098, 1077, + 1077, 1077, 1077, 1077, 1077, 1077, 1077, 1077, 1082, 1085, + 1076, 903, 1076, 902, 903, 902, 1131, 1100, 1097, 1084, + 1103, 904, 212, 1091, 905, 1099, 1108, 1098, 1101, 205, + 212, 205, 1113, 1131, 190, 1131, 1082, 1085, 902, 903, + 902, 1104, 205, 1088, 1088, 1100, 1089, 190, 1103, 905, + 1088, 1088, 212, 1099, 1088, 1108, 1101, 1088, 1088, 1088, + 1088, 1088, 1088, 1088, 1088, 1088, 902, 903, 902, 1104, + + 955, 956, 955, 1102, 904, 1105, 190, 905, 957, 1106, + 1112, 958, 1109, 1107, 212, 1115, 1116, 212, 1110, 1119, + 1120, 1119, 205, 1117, 1121, 1122, 1121, 1124, 1125, 1124, + 205, 1102, 205, 1105, 1119, 1120, 1119, 1106, 1111, 1112, + 1109, 205, 1107, 1115, 1116, 1131, 1114, 1110, 1121, 1122, + 1121, 1117, 1124, 1125, 1124, 1129, 1130, 1129, 1129, 1130, + 1129, 1131, 1131, 1131, 1127, 1131, 1126, 1111, 1118, 1131, + 1131, 1123, 1131, 1131, 1131, 1114, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1128, 1127, 1131, 1126, 1118, 1131, 1131, 1123, + + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1128, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 79, 1131, 79, + 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, + 82, 82, 82, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 113, + + 113, 113, 113, 113, 113, 113, 113, 113, 189, 189, + 189, 189, 189, 189, 189, 189, 189, 189, 189, 189, + 189, 204, 204, 204, 204, 204, 204, 204, 204, 204, + 204, 204, 204, 204, 210, 210, 210, 210, 210, 1131, + 210, 210, 210, 1131, 210, 1131, 210, 231, 231, 231, + 231, 231, 231, 231, 231, 231, 231, 231, 231, 231, + 99, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 99, 249, + 249, 1131, 249, 249, 1131, 249, 1131, 1131, 249, 249, + 1131, 249, 336, 336, 336, 336, 340, 340, 340, 340, + 340, 340, 340, 340, 340, 340, 340, 340, 340, 365, + + 365, 365, 365, 365, 365, 365, 365, 365, 365, 365, + 365, 365, 371, 371, 371, 371, 371, 371, 371, 371, + 371, 371, 371, 371, 371, 601, 601, 601, 1131, 601, + 601, 601, 601, 601, 601, 601, 601, 601, 685, 1131, + 685, 685, 685, 685, 685, 685, 685, 685, 685, 685, + 685, 688, 1131, 688, 688, 688, 688, 688, 688, 688, + 688, 688, 688, 688, 690, 690, 690, 690, 690, 690, + 690, 690, 690, 690, 690, 690, 690, 693, 693, 693, + 693, 693, 693, 693, 693, 693, 693, 693, 693, 693, + 695, 695, 695, 695, 695, 695, 695, 695, 695, 695, + + 695, 695, 695, 702, 1131, 702, 702, 702, 702, 702, + 702, 702, 702, 702, 702, 702, 778, 778, 778, 778, + 778, 778, 778, 778, 778, 778, 778, 778, 778, 786, + 786, 786, 786, 786, 786, 786, 786, 786, 786, 786, + 786, 786, 789, 789, 789, 789, 789, 789, 789, 789, + 789, 789, 789, 789, 789, 790, 1131, 790, 790, 790, + 790, 790, 790, 790, 790, 790, 790, 790, 793, 1131, + 793, 793, 793, 793, 793, 793, 793, 793, 793, 793, + 793, 794, 794, 794, 794, 794, 794, 794, 794, 794, + 794, 794, 794, 794, 796, 796, 796, 796, 796, 796, + + 796, 796, 796, 796, 796, 796, 796, 797, 797, 797, + 797, 797, 797, 797, 797, 797, 797, 797, 797, 797, + 800, 1131, 800, 800, 800, 800, 800, 800, 800, 800, + 800, 800, 800, 861, 861, 861, 861, 861, 861, 861, + 861, 861, 861, 861, 861, 861, 868, 868, 868, 868, + 868, 868, 868, 868, 868, 868, 868, 868, 868, 870, + 870, 870, 870, 870, 870, 870, 870, 870, 870, 870, + 870, 870, 901, 901, 901, 901, 901, 901, 901, 901, + 901, 901, 901, 901, 901, 954, 954, 954, 954, 954, + 954, 954, 954, 954, 954, 954, 954, 954, 1069, 1069, + + 1069, 1069, 1069, 1069, 1069, 1069, 1069, 1069, 1069, 1069, + 1069, 13, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + + 1131 + } ; + +static yyconst flex_int16_t yy_chk[4102] = + { 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, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, + 2, 2, 2, 74, 8, 8, 8, 8, 10, 15, + + 15, 15, 1083, 14, 16, 16, 16, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 14, 70, 17, + 1081, 10, 74, 70, 2, 2, 71, 75, 2, 8, + 2, 8, 14, 17, 18, 19, 21, 15, 20, 22, + 551, 2, 2, 551, 1069, 14, 22, 22, 17, 19, + 10, 15, 20, 2, 2, 75, 80, 2, 8, 2, + 8, 17, 84, 23, 19, 30, 15, 20, 18, 2, + 2, 71, 24, 21, 26, 30, 22, 19, 81, 15, + 20, 25, 18, 116, 23, 80, 24, 21, 26, 30, + 22, 84, 28, 85, 100, 31, 1051, 18, 23, 71, + + 624, 24, 21, 26, 30, 22, 81, 25, 624, 31, + 18, 32, 116, 23, 24, 21, 26, 30, 22, 28, + 84, 25, 100, 1047, 31, 32, 23, 56, 56, 56, + 76, 76, 76, 28, 101, 105, 25, 31, 106, 85, + 32, 179, 69, 69, 69, 33, 1006, 179, 28, 25, + 27, 33, 27, 32, 77, 77, 77, 78, 78, 78, + 1000, 28, 101, 105, 914, 33, 106, 85, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 34, 69, + 33, 35, 35, 27, 120, 35, 41, 27, 27, 27, + 868, 35, 34, 33, 27, 41, 27, 27, 35, 35, + + 41, 862, 27, 123, 89, 861, 27, 34, 69, 796, + 35, 35, 27, 120, 35, 41, 27, 27, 27, 35, + 34, 114, 27, 41, 27, 27, 35, 35, 41, 88, + 27, 36, 123, 42, 27, 29, 36, 29, 29, 29, + 29, 29, 29, 29, 29, 29, 29, 42, 794, 114, + 36, 90, 337, 89, 337, 29, 29, 29, 90, 90, + 36, 88, 42, 115, 117, 36, 104, 786, 29, 121, + 122, 29, 126, 44, 109, 42, 104, 54, 36, 38, + 38, 89, 44, 38, 29, 29, 29, 44, 109, 38, + 88, 115, 117, 38, 38, 104, 29, 121, 122, 29, + + 37, 126, 44, 109, 104, 37, 54, 37, 38, 38, + 44, 37, 38, 785, 37, 44, 109, 38, 92, 37, + 54, 38, 38, 778, 37, 92, 92, 660, 777, 37, + 186, 186, 186, 660, 37, 54, 37, 43, 693, 37, + 132, 45, 37, 692, 43, 43, 45, 37, 54, 45, + 690, 43, 37, 39, 625, 45, 72, 72, 72, 39, + 45, 39, 39, 625, 39, 39, 43, 39, 72, 132, + 45, 39, 43, 43, 124, 45, 102, 689, 45, 43, + 689, 678, 39, 45, 211, 211, 211, 39, 45, 39, + 39, 102, 39, 39, 72, 39, 119, 49, 49, 39, + + 40, 664, 124, 40, 635, 102, 40, 40, 72, 40, + 46, 753, 49, 119, 40, 40, 128, 143, 46, 102, + 753, 46, 46, 72, 46, 119, 49, 49, 118, 40, + 46, 558, 40, 103, 40, 40, 72, 40, 118, 46, + 49, 119, 40, 40, 128, 47, 143, 46, 103, 46, + 46, 48, 46, 47, 129, 47, 48, 118, 46, 47, + 47, 52, 103, 130, 131, 48, 118, 133, 48, 52, + 48, 48, 661, 553, 47, 52, 103, 534, 661, 134, + 48, 47, 129, 47, 519, 48, 135, 47, 47, 137, + 52, 130, 131, 48, 95, 133, 48, 52, 48, 48, + + 50, 95, 95, 52, 50, 50, 51, 134, 50, 496, + 53, 51, 53, 51, 135, 487, 50, 137, 139, 50, + 50, 140, 53, 51, 53, 51, 224, 224, 224, 50, + 401, 399, 146, 50, 50, 51, 141, 50, 144, 53, + 51, 53, 51, 95, 50, 60, 139, 50, 50, 140, + 53, 51, 53, 51, 55, 55, 55, 55, 57, 57, + 58, 146, 55, 392, 141, 58, 144, 338, 138, 338, + 147, 95, 60, 390, 138, 57, 57, 57, 57, 57, + 57, 57, 57, 57, 57, 148, 60, 149, 159, 55, + 55, 65, 55, 55, 62, 55, 138, 58, 147, 65, + + 62, 60, 138, 62, 65, 65, 55, 55, 62, 365, + 150, 58, 362, 148, 60, 340, 149, 159, 55, 55, + 65, 55, 55, 62, 55, 151, 58, 65, 62, 336, + 247, 62, 65, 65, 55, 55, 62, 63, 150, 58, + 59, 91, 91, 91, 63, 63, 59, 244, 243, 91, + 91, 63, 242, 151, 59, 241, 59, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 63, 99, 99, 142, + 94, 142, 63, 63, 59, 59, 59, 94, 94, 63, + 99, 152, 125, 125, 153, 154, 155, 59, 125, 157, + 59, 161, 213, 511, 163, 511, 99, 99, 164, 210, + + 166, 127, 94, 59, 59, 59, 127, 170, 99, 152, + 125, 125, 153, 154, 155, 59, 125, 157, 59, 61, + 161, 142, 163, 61, 61, 204, 164, 61, 166, 860, + 127, 94, 189, 61, 182, 127, 170, 61, 61, 158, + 64, 178, 158, 136, 165, 64, 145, 64, 61, 142, + 136, 165, 61, 61, 136, 171, 61, 64, 145, 64, + 145, 61, 182, 145, 64, 61, 61, 158, 87, 64, + 158, 86, 136, 165, 64, 145, 64, 82, 136, 165, + 67, 512, 136, 512, 171, 64, 145, 64, 145, 860, + 13, 145, 64, 73, 73, 73, 73, 73, 73, 73, + + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 98, 110, 98, 110, 7, 156, 110, 110, + 110, 110, 110, 110, 110, 110, 110, 110, 160, 366, + + 366, 366, 156, 183, 160, 172, 528, 168, 528, 169, + 173, 174, 0, 169, 173, 98, 156, 185, 168, 98, + 181, 98, 866, 530, 196, 530, 98, 160, 98, 98, + 156, 183, 160, 162, 172, 162, 168, 169, 98, 173, + 174, 169, 0, 173, 98, 185, 168, 0, 98, 181, + 98, 162, 162, 196, 98, 162, 98, 98, 176, 199, + 176, 0, 162, 191, 162, 0, 98, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 167, 180, 162, + 162, 184, 866, 162, 203, 108, 108, 199, 184, 192, + 200, 167, 180, 193, 167, 191, 176, 231, 108, 202, + + 0, 207, 215, 0, 231, 231, 167, 180, 0, 184, + 176, 187, 187, 203, 108, 108, 184, 208, 200, 167, + 180, 192, 167, 0, 191, 176, 108, 202, 187, 187, + 187, 187, 187, 187, 187, 187, 187, 187, 176, 188, + 197, 651, 193, 651, 239, 188, 207, 197, 222, 208, + 192, 215, 223, 0, 0, 188, 188, 188, 188, 188, + 188, 188, 188, 188, 188, 194, 198, 198, 197, 214, + 193, 194, 198, 239, 207, 197, 222, 0, 208, 215, + 223, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 195, 209, 225, 198, 198, 216, 195, 0, 240, + + 198, 214, 206, 206, 206, 195, 201, 195, 195, 195, + 195, 195, 195, 195, 195, 195, 195, 226, 201, 246, + 201, 225, 227, 201, 229, 195, 195, 209, 216, 221, + 214, 221, 0, 0, 258, 201, 234, 240, 195, 206, + 230, 0, 228, 234, 234, 226, 201, 246, 201, 0, + 652, 201, 652, 0, 195, 195, 209, 216, 221, 0, + 221, 245, 227, 258, 0, 240, 195, 229, 206, 217, + 217, 217, 217, 217, 217, 217, 217, 217, 217, 217, + 217, 217, 217, 217, 217, 217, 217, 217, 220, 219, + 227, 228, 230, 248, 245, 229, 254, 255, 217, 217, + + 217, 217, 217, 219, 237, 220, 232, 232, 232, 256, + 257, 237, 237, 259, 232, 232, 0, 220, 219, 228, + 230, 248, 245, 0, 254, 255, 233, 233, 233, 217, + 217, 219, 0, 220, 233, 233, 236, 256, 257, 0, + 238, 259, 238, 236, 236, 238, 238, 238, 238, 238, + 238, 238, 238, 238, 238, 260, 237, 217, 218, 218, + 218, 218, 218, 218, 218, 218, 218, 218, 218, 218, + 218, 218, 218, 218, 218, 218, 218, 261, 262, 236, + 378, 378, 378, 260, 237, 0, 0, 218, 218, 218, + 218, 218, 218, 251, 251, 251, 251, 251, 251, 251, + + 251, 251, 251, 263, 264, 261, 262, 236, 252, 252, + 252, 252, 252, 252, 252, 252, 252, 252, 218, 218, + 253, 218, 253, 547, 547, 547, 0, 0, 266, 267, + 253, 263, 264, 265, 268, 269, 265, 0, 270, 271, + 272, 273, 274, 0, 0, 266, 218, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 266, 267, 277, + 281, 265, 268, 269, 265, 250, 250, 270, 271, 272, + 273, 274, 276, 266, 276, 282, 283, 278, 250, 278, + 0, 0, 279, 279, 284, 285, 286, 285, 277, 281, + 287, 0, 289, 290, 250, 250, 291, 292, 288, 293, + + 288, 295, 0, 276, 282, 283, 250, 275, 278, 275, + 279, 279, 284, 294, 286, 299, 285, 0, 298, 287, + 289, 290, 0, 300, 291, 292, 294, 293, 302, 0, + 295, 296, 301, 296, 301, 0, 303, 297, 275, 297, + 304, 296, 294, 275, 299, 275, 298, 297, 275, 0, + 288, 300, 275, 306, 294, 275, 305, 302, 275, 275, + 308, 0, 275, 301, 303, 309, 310, 312, 304, 313, + 315, 311, 275, 316, 275, 296, 317, 275, 288, 311, + 275, 297, 306, 275, 305, 296, 275, 275, 318, 308, + 275, 297, 314, 309, 310, 319, 312, 313, 315, 311, + + 314, 316, 320, 296, 317, 321, 322, 311, 323, 297, + 324, 325, 326, 296, 328, 329, 327, 318, 327, 297, + 330, 314, 331, 332, 319, 333, 327, 334, 314, 335, + 339, 320, 341, 321, 342, 322, 323, 343, 324, 325, + 326, 344, 345, 328, 329, 346, 347, 352, 330, 0, + 331, 332, 0, 333, 351, 334, 363, 335, 339, 348, + 341, 348, 342, 353, 0, 343, 355, 356, 358, 344, + 345, 357, 359, 346, 376, 347, 369, 348, 348, 348, + 348, 348, 348, 348, 348, 348, 348, 349, 357, 869, + 352, 361, 351, 349, 363, 355, 356, 358, 371, 0, + + 357, 359, 376, 349, 349, 349, 349, 349, 349, 349, + 349, 349, 349, 350, 368, 353, 357, 370, 352, 350, + 361, 351, 377, 363, 379, 383, 0, 371, 369, 350, + 350, 350, 350, 350, 350, 350, 350, 350, 350, 1005, + 0, 360, 372, 353, 354, 364, 364, 364, 381, 869, + 354, 377, 379, 372, 360, 370, 369, 368, 354, 373, + 354, 354, 354, 354, 354, 354, 354, 354, 354, 354, + 360, 372, 374, 380, 384, 383, 382, 373, 354, 354, + 0, 372, 360, 375, 370, 368, 364, 406, 373, 385, + 398, 354, 374, 405, 375, 381, 385, 385, 653, 1005, + + 653, 374, 380, 383, 0, 373, 386, 354, 354, 382, + 384, 0, 375, 386, 386, 364, 406, 387, 398, 354, + 374, 405, 375, 381, 387, 387, 388, 388, 388, 388, + 388, 388, 388, 388, 388, 388, 408, 410, 382, 384, + 389, 389, 389, 389, 389, 389, 389, 389, 389, 389, + 402, 411, 402, 387, 413, 0, 386, 414, 0, 415, + 402, 416, 417, 418, 420, 408, 410, 421, 422, 423, + 424, 425, 426, 429, 426, 430, 431, 0, 432, 411, + 433, 435, 387, 413, 386, 436, 414, 415, 434, 416, + 417, 439, 418, 420, 442, 421, 422, 423, 424, 425, + + 437, 429, 437, 430, 434, 431, 432, 444, 433, 435, + 440, 446, 440, 426, 436, 447, 445, 434, 445, 439, + 450, 448, 442, 448, 1009, 451, 452, 426, 454, 0, + 457, 437, 434, 455, 456, 444, 458, 459, 460, 446, + 464, 440, 426, 458, 447, 463, 468, 445, 467, 450, + 0, 469, 448, 451, 452, 426, 427, 454, 427, 457, + 470, 455, 456, 0, 480, 458, 459, 460, 461, 464, + 461, 458, 465, 463, 465, 468, 467, 478, 461, 469, + 483, 472, 465, 472, 1009, 479, 481, 427, 470, 482, + 484, 475, 427, 480, 427, 485, 493, 427, 503, 475, + + 488, 427, 0, 489, 427, 478, 490, 427, 427, 483, + 491, 427, 472, 479, 481, 0, 0, 482, 484, 0, + 506, 427, 506, 427, 485, 493, 427, 503, 488, 427, + 475, 489, 427, 499, 490, 427, 427, 0, 491, 427, + 443, 443, 443, 443, 443, 443, 443, 443, 443, 443, + 443, 506, 443, 443, 443, 443, 443, 443, 443, 475, + 507, 499, 508, 509, 494, 500, 494, 500, 513, 443, + 443, 443, 443, 443, 494, 500, 514, 515, 516, 517, + 518, 523, 524, 655, 535, 655, 525, 0, 667, 507, + 667, 508, 509, 520, 529, 520, 527, 513, 563, 1031, + + 443, 443, 529, 540, 514, 531, 515, 516, 517, 518, + 537, 520, 520, 520, 520, 520, 520, 520, 520, 520, + 520, 521, 525, 529, 527, 545, 563, 521, 443, 565, + 523, 529, 524, 535, 531, 0, 0, 521, 521, 521, + 521, 521, 521, 521, 521, 521, 521, 522, 0, 538, + 539, 525, 540, 522, 545, 537, 568, 565, 523, 1031, + 524, 535, 0, 522, 522, 522, 522, 522, 522, 522, + 522, 522, 522, 526, 532, 536, 536, 536, 0, 526, + 540, 532, 548, 537, 568, 532, 539, 526, 541, 526, + 526, 526, 526, 526, 526, 526, 526, 526, 526, 538, + + 533, 0, 533, 532, 552, 550, 541, 526, 526, 532, + 533, 548, 561, 532, 533, 539, 536, 541, 542, 0, + 526, 543, 542, 554, 544, 543, 562, 538, 544, 566, + 554, 554, 569, 576, 541, 555, 526, 526, 550, 577, + 552, 561, 555, 555, 570, 536, 571, 542, 526, 573, + 543, 542, 574, 544, 543, 562, 575, 544, 566, 554, + 0, 569, 576, 581, 659, 659, 659, 550, 577, 552, + 0, 578, 570, 578, 571, 0, 641, 573, 641, 579, + 574, 580, 0, 582, 575, 583, 641, 584, 554, 564, + 564, 581, 564, 564, 564, 564, 564, 564, 564, 564, + + 564, 564, 564, 564, 564, 564, 564, 564, 579, 585, + 580, 582, 578, 586, 583, 584, 587, 588, 564, 564, + 564, 564, 564, 590, 592, 0, 578, 593, 594, 586, + 595, 0, 596, 597, 598, 608, 599, 585, 599, 0, + 602, 578, 586, 603, 587, 603, 588, 607, 613, 564, + 564, 590, 610, 592, 578, 593, 594, 586, 611, 595, + 596, 614, 597, 598, 608, 615, 616, 599, 602, 617, + 618, 0, 619, 620, 603, 607, 613, 564, 621, 622, + 623, 610, 626, 0, 627, 628, 630, 611, 632, 633, + 614, 634, 639, 615, 616, 636, 637, 638, 617, 618, + + 619, 640, 620, 644, 645, 646, 621, 646, 622, 623, + 654, 626, 627, 656, 628, 630, 632, 657, 633, 662, + 634, 639, 663, 636, 637, 638, 666, 668, 669, 640, + 669, 644, 645, 658, 670, 658, 646, 671, 672, 654, + 672, 676, 656, 658, 681, 657, 675, 658, 672, 674, + 683, 674, 672, 679, 677, 666, 668, 700, 663, 662, + 694, 0, 670, 674, 695, 680, 671, 694, 694, 680, + 696, 695, 695, 681, 701, 703, 0, 696, 696, 683, + 771, 738, 771, 738, 1082, 700, 675, 663, 662, 665, + 677, 738, 676, 679, 680, 665, 0, 704, 680, 706, + + 707, 708, 701, 665, 703, 665, 665, 665, 665, 665, + 665, 665, 665, 665, 665, 675, 709, 0, 710, 677, + 676, 711, 679, 665, 665, 704, 714, 706, 707, 708, + 715, 717, 0, 719, 721, 0, 665, 762, 0, 762, + 770, 781, 770, 781, 1082, 709, 710, 762, 770, 858, + 711, 858, 665, 665, 712, 714, 712, 722, 723, 715, + 717, 719, 724, 721, 665, 682, 682, 682, 682, 682, + 682, 682, 682, 682, 682, 682, 682, 682, 682, 682, + 682, 682, 682, 682, 725, 722, 723, 726, 727, 712, + 729, 724, 728, 730, 682, 682, 682, 682, 682, 731, + + 732, 0, 712, 733, 734, 735, 737, 735, 1084, 739, + 740, 741, 725, 742, 0, 743, 726, 727, 712, 729, + 728, 745, 730, 746, 752, 682, 682, 731, 756, 732, + 712, 733, 734, 0, 0, 737, 735, 739, 0, 740, + 741, 755, 742, 743, 757, 775, 775, 775, 833, 745, + 833, 746, 752, 682, 686, 686, 686, 756, 833, 686, + 686, 751, 686, 751, 0, 0, 686, 686, 1084, 755, + 686, 0, 757, 686, 686, 686, 686, 686, 686, 686, + 686, 686, 699, 699, 776, 699, 699, 699, 699, 699, + 699, 699, 699, 699, 699, 699, 699, 699, 699, 699, + + 699, 758, 759, 783, 760, 763, 0, 768, 773, 751, + 772, 699, 699, 699, 699, 699, 767, 774, 767, 779, + 782, 776, 784, 787, 780, 789, 791, 791, 791, 758, + 802, 759, 760, 810, 763, 768, 773, 751, 803, 772, + 783, 0, 699, 699, 804, 806, 774, 807, 779, 782, + 776, 767, 780, 808, 789, 797, 812, 798, 784, 802, + 787, 810, 797, 797, 798, 798, 864, 803, 864, 783, + 699, 0, 0, 804, 806, 0, 807, 811, 0, 811, + 767, 801, 808, 813, 812, 801, 815, 784, 816, 787, + 788, 788, 788, 788, 788, 788, 788, 788, 788, 788, + + 788, 788, 788, 788, 788, 788, 788, 788, 788, 817, + 801, 813, 811, 819, 801, 815, 816, 818, 820, 788, + 788, 788, 788, 788, 821, 811, 822, 0, 823, 824, + 825, 826, 827, 0, 828, 830, 831, 840, 817, 832, + 1085, 811, 819, 835, 836, 818, 842, 820, 842, 843, + 788, 788, 821, 811, 844, 822, 823, 824, 825, 826, + 846, 827, 828, 847, 830, 831, 840, 832, 834, 834, + 834, 835, 836, 851, 852, 851, 834, 843, 788, 834, + 853, 855, 844, 851, 854, 856, 854, 857, 846, 859, + 867, 865, 847, 863, 842, 870, 871, 0, 873, 874, + + 1085, 875, 876, 852, 878, 879, 880, 881, 853, 882, + 855, 883, 0, 884, 856, 857, 885, 889, 859, 854, + 865, 863, 842, 886, 870, 871, 873, 887, 874, 875, + 876, 888, 878, 879, 880, 881, 890, 882, 896, 867, + 883, 884, 892, 893, 894, 885, 889, 895, 854, 897, + 899, 886, 901, 901, 901, 887, 903, 903, 903, 888, + 901, 909, 0, 901, 890, 910, 896, 867, 0, 908, + 915, 892, 893, 894, 913, 916, 895, 897, 899, 902, + 902, 902, 917, 904, 904, 904, 918, 902, 919, 909, + 902, 904, 920, 910, 904, 905, 905, 905, 908, 915, + + 921, 922, 913, 905, 916, 924, 905, 925, 926, 927, + 917, 928, 929, 932, 918, 0, 919, 933, 0, 935, + 936, 920, 937, 938, 939, 941, 940, 942, 940, 943, + 922, 944, 945, 947, 924, 921, 940, 949, 951, 928, + 929, 932, 952, 925, 927, 926, 933, 935, 0, 936, + 937, 0, 938, 939, 941, 961, 942, 960, 943, 944, + 945, 947, 0, 0, 921, 949, 951, 953, 953, 953, + 965, 952, 925, 927, 926, 954, 954, 954, 970, 955, + 955, 955, 963, 954, 961, 960, 954, 955, 966, 973, + 955, 956, 956, 956, 967, 957, 957, 957, 965, 956, + + 969, 975, 956, 957, 971, 974, 957, 958, 958, 958, + 976, 963, 977, 980, 977, 958, 981, 966, 958, 0, + 982, 983, 977, 967, 970, 984, 985, 984, 985, 969, + 987, 989, 971, 991, 973, 984, 985, 974, 994, 976, + 992, 980, 995, 1008, 1007, 981, 0, 975, 982, 998, + 983, 0, 970, 996, 996, 996, 999, 1001, 987, 989, + 1013, 991, 973, 1016, 1014, 1015, 974, 994, 992, 1017, + 1019, 995, 997, 997, 997, 975, 1021, 1008, 998, 1007, + 997, 1032, 1011, 997, 1011, 999, 1001, 1012, 1013, 1012, + 1025, 1016, 1011, 1014, 1015, 1026, 1029, 1017, 1027, 1019, + + 1012, 1030, 1012, 1033, 1021, 1037, 1008, 1036, 1007, 1023, + 1023, 1023, 1024, 1024, 1024, 0, 1038, 1032, 1012, 1025, + 1024, 1039, 1042, 1024, 1026, 1034, 1027, 1034, 1045, 1030, + 1041, 1048, 1035, 1037, 1035, 1052, 1036, 1046, 1034, 1050, + 1034, 1029, 1056, 1035, 1038, 1035, 1032, 1035, 1033, 1059, + 1039, 1042, 1043, 1043, 1043, 1049, 1034, 1045, 1041, 1044, + 1044, 1044, 1053, 1035, 1053, 1046, 1055, 1044, 1058, 1029, + 1044, 1056, 1063, 1053, 1050, 1068, 1033, 1048, 1059, 1064, + 1065, 1052, 0, 1049, 1062, 1062, 1062, 1066, 1071, 1067, + 0, 1073, 1062, 0, 1055, 1062, 1058, 1074, 0, 1079, + + 1063, 1099, 1109, 1050, 1093, 1048, 0, 1064, 1065, 1052, + 1061, 1061, 1061, 1095, 0, 1061, 1061, 1067, 1061, 1073, + 1086, 1068, 1061, 1061, 1080, 1074, 1061, 1079, 1090, 1061, + 1061, 1061, 1061, 1061, 1061, 1061, 1061, 1061, 1066, 1071, + 1076, 1076, 1076, 1077, 1077, 1077, 0, 1094, 1086, 1068, + 1099, 1077, 1096, 1080, 1077, 1093, 1104, 1090, 1095, 1101, + 1102, 1105, 1109, 0, 1111, 0, 1066, 1071, 1078, 1078, + 1078, 1100, 1113, 1078, 1078, 1094, 1078, 1103, 1099, 1078, + 1078, 1078, 1106, 1093, 1078, 1104, 1095, 1078, 1078, 1078, + 1078, 1078, 1078, 1078, 1078, 1078, 1088, 1088, 1088, 1100, + + 1089, 1089, 1089, 1096, 1088, 1101, 1107, 1088, 1089, 1102, + 1108, 1089, 1105, 1103, 1110, 1111, 1112, 1114, 1106, 1115, + 1115, 1115, 1117, 1113, 1116, 1116, 1116, 1118, 1118, 1118, + 1123, 1096, 1126, 1101, 1119, 1119, 1119, 1102, 1107, 1108, + 1105, 1127, 1103, 1111, 1112, 0, 1110, 1106, 1121, 1121, + 1121, 1113, 1124, 1124, 1124, 1128, 1128, 1128, 1129, 1129, + 1129, 0, 0, 0, 1126, 0, 1123, 1107, 1114, 0, + 0, 1117, 0, 0, 0, 1110, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1127, 1126, 0, 1123, 1114, 0, 0, 1117, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1127, 1132, 1132, 1132, 1132, 1132, 1132, 1132, 1132, 1132, + 1132, 1132, 1132, 1132, 1133, 1133, 1133, 1133, 1133, 1133, + 1133, 1133, 1133, 1133, 1133, 1133, 1133, 1134, 0, 1134, + 1134, 1134, 1134, 1134, 1134, 1134, 1134, 1134, 1134, 1134, + 1135, 1135, 1135, 1135, 1135, 1135, 1135, 1135, 1135, 1135, + 1135, 1135, 1135, 1136, 1136, 1136, 1136, 1136, 1136, 1136, + 1136, 1136, 1136, 1136, 1136, 1136, 1137, 1137, 1137, 1137, + 1137, 1137, 1137, 1137, 1137, 1137, 1137, 1137, 1137, 1138, + + 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1138, 1139, 1139, + 1139, 1139, 1139, 1139, 1139, 1139, 1139, 1139, 1139, 1139, + 1139, 1140, 1140, 1140, 1140, 1140, 1140, 1140, 1140, 1140, + 1140, 1140, 1140, 1140, 1141, 1141, 1141, 1141, 1141, 0, + 1141, 1141, 1141, 0, 1141, 0, 1141, 1142, 1142, 1142, + 1142, 1142, 1142, 1142, 1142, 1142, 1142, 1142, 1142, 1142, + 1143, 0, 0, 0, 0, 0, 0, 0, 1143, 1144, + 1144, 0, 1144, 1144, 0, 1144, 0, 0, 1144, 1144, + 0, 1144, 1145, 1145, 1145, 1145, 1146, 1146, 1146, 1146, + 1146, 1146, 1146, 1146, 1146, 1146, 1146, 1146, 1146, 1147, + + 1147, 1147, 1147, 1147, 1147, 1147, 1147, 1147, 1147, 1147, + 1147, 1147, 1148, 1148, 1148, 1148, 1148, 1148, 1148, 1148, + 1148, 1148, 1148, 1148, 1148, 1149, 1149, 1149, 0, 1149, + 1149, 1149, 1149, 1149, 1149, 1149, 1149, 1149, 1150, 0, + 1150, 1150, 1150, 1150, 1150, 1150, 1150, 1150, 1150, 1150, + 1150, 1151, 0, 1151, 1151, 1151, 1151, 1151, 1151, 1151, + 1151, 1151, 1151, 1151, 1152, 1152, 1152, 1152, 1152, 1152, + 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1153, 1153, 1153, + 1153, 1153, 1153, 1153, 1153, 1153, 1153, 1153, 1153, 1153, + 1154, 1154, 1154, 1154, 1154, 1154, 1154, 1154, 1154, 1154, + + 1154, 1154, 1154, 1155, 0, 1155, 1155, 1155, 1155, 1155, + 1155, 1155, 1155, 1155, 1155, 1155, 1156, 1156, 1156, 1156, + 1156, 1156, 1156, 1156, 1156, 1156, 1156, 1156, 1156, 1157, + 1157, 1157, 1157, 1157, 1157, 1157, 1157, 1157, 1157, 1157, + 1157, 1157, 1158, 1158, 1158, 1158, 1158, 1158, 1158, 1158, + 1158, 1158, 1158, 1158, 1158, 1159, 0, 1159, 1159, 1159, + 1159, 1159, 1159, 1159, 1159, 1159, 1159, 1159, 1160, 0, + 1160, 1160, 1160, 1160, 1160, 1160, 1160, 1160, 1160, 1160, + 1160, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, + 1161, 1161, 1161, 1161, 1162, 1162, 1162, 1162, 1162, 1162, + + 1162, 1162, 1162, 1162, 1162, 1162, 1162, 1163, 1163, 1163, + 1163, 1163, 1163, 1163, 1163, 1163, 1163, 1163, 1163, 1163, + 1164, 0, 1164, 1164, 1164, 1164, 1164, 1164, 1164, 1164, + 1164, 1164, 1164, 1165, 1165, 1165, 1165, 1165, 1165, 1165, + 1165, 1165, 1165, 1165, 1165, 1165, 1166, 1166, 1166, 1166, + 1166, 1166, 1166, 1166, 1166, 1166, 1166, 1166, 1166, 1167, + 1167, 1167, 1167, 1167, 1167, 1167, 1167, 1167, 1167, 1167, + 1167, 1167, 1168, 1168, 1168, 1168, 1168, 1168, 1168, 1168, + 1168, 1168, 1168, 1168, 1168, 1169, 1169, 1169, 1169, 1169, + 1169, 1169, 1169, 1169, 1169, 1169, 1169, 1169, 1170, 1170, + + 1170, 1170, 1170, 1170, 1170, 1170, 1170, 1170, 1170, 1170, + 1170, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, 1131, + + 1131 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +extern int fortran__flex_debug; +int fortran__flex_debug = 0; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *fortran_text; +#line 1 "fortran.lex" +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ + + + + + +#line 44 "fortran.lex" +#include +#include +#include +extern FILE * fortran_in; +#define MAX_INCLUDE_DEPTH 30 +YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; +int line_num_input = 1; +int newlinef90 = 0; +char tmpc; +#define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } +#define INCREMENT_LINE_NUM() { line_num_input++; PRINT_LINE_NUM(); } + +/******************************************************************************/ +/**************PETITS PB NON PREVUS *******************************************/ +/******************************************************************************/ +/* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */ +/* a prevu seulement & a=b avec l'espace entre le symbole */ +/* de la 7eme et le debut de la ligne de commande */ +/* le ! est aussi interdit comme symbole de la 7 eme colonne */ +/* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */ +/******************************************************************************/ +#define YY_USER_ACTION if (firstpass == 0) ECHO; + +void out_of_donottreat(void); + +#line 1826 "fortran.yy.c" + +#define INITIAL 0 +#define parameter 1 +#define character 2 +#define donottreat 3 +#define fortran77style 4 +#define fortran90style 5 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int fortran_lex_destroy (void ); + +int fortran_get_debug (void ); + +void fortran_set_debug (int debug_flag ); + +YY_EXTRA_TYPE fortran_get_extra (void ); + +void fortran_set_extra (YY_EXTRA_TYPE user_defined ); + +FILE *fortran_get_in (void ); + +void fortran_set_in (FILE * in_str ); + +FILE *fortran_get_out (void ); + +void fortran_set_out (FILE * out_str ); + +yy_size_t fortran_get_leng (void ); + +char *fortran_get_text (void ); + +int fortran_get_lineno (void ); + +void fortran_set_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int fortran_wrap (void ); +#else +extern int fortran_wrap (void ); +#endif +#endif + + static void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +static int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO fwrite( fortran_text, fortran_leng, 1, fortran_out ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + yy_size_t n; \ + for ( n = 0; n < max_size && \ + (c = getc( fortran_in )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( fortran_in ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, fortran_in))==0 && ferror(fortran_in)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(fortran_in); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int fortran_lex (void); + +#define YY_DECL int fortran_lex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after fortran_text and fortran_leng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + if ( fortran_leng > 0 ) \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \ + (fortran_text[fortran_leng - 1] == '\n'); \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 97 "fortran.lex" + + if (infixed) BEGIN(fortran77style) ; + if (infree) BEGIN(fortran90style) ; + +#line 2021 "fortran.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! fortran_in ) + fortran_in = stdin; + + if ( ! fortran_out ) + fortran_out = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + fortran_ensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + fortran__create_buffer(fortran_in,YY_BUF_SIZE ); + } + + fortran__load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of fortran_text. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 1132 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 4012 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = (yy_hold_char); + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + goto yy_find_action; + +case 1: +YY_RULE_SETUP +#line 101 "fortran.lex" +{ return TOK_REAL8; } + YY_BREAK +case 2: +YY_RULE_SETUP +#line 102 "fortran.lex" +{ return TOK_SUBROUTINE; } + YY_BREAK +case 3: +YY_RULE_SETUP +#line 103 "fortran.lex" +{ return TOK_PROGRAM; } + YY_BREAK +case 4: +YY_RULE_SETUP +#line 104 "fortran.lex" +{ inallocate = 1; return TOK_ALLOCATE; } + YY_BREAK +case 5: +YY_RULE_SETUP +#line 105 "fortran.lex" +{ return TOK_NULLIFY; } + YY_BREAK +case 6: +YY_RULE_SETUP +#line 106 "fortran.lex" +{ return TOK_NULL_PTR; } + YY_BREAK +case 7: +YY_RULE_SETUP +#line 107 "fortran.lex" +{ inallocate = 1; return TOK_DEALLOCATE; } + YY_BREAK +case 8: +YY_RULE_SETUP +#line 108 "fortran.lex" +{ return TOK_RESULT; } + YY_BREAK +case 9: +YY_RULE_SETUP +#line 109 "fortran.lex" +{ return TOK_FUNCTION; } + YY_BREAK +case 10: +YY_RULE_SETUP +#line 110 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ENDPROGRAM;} + YY_BREAK +case 11: +YY_RULE_SETUP +#line 111 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ENDMODULE; } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 112 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ENDSUBROUTINE;} + YY_BREAK +case 13: +YY_RULE_SETUP +#line 113 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ENDFUNCTION;} + YY_BREAK +case 14: +YY_RULE_SETUP +#line 114 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ENDUNIT;} + YY_BREAK +case 15: +YY_RULE_SETUP +#line 115 "fortran.lex" +{ pos_curinclude = setposcur()-9; return TOK_INCLUDE;} + YY_BREAK +case 16: +YY_RULE_SETUP +#line 116 "fortran.lex" +{ strcpy(yylval.na,fortran_text); + tmpc = (char) input(); unput(tmpc); + if ( ( tmpc >= 'a' && tmpc <= 'z' ) || + ( tmpc >= 'A' && tmpc <= 'Z' ) ) return TOK_USE; + else return TOK_NAME; + } + YY_BREAK +case 17: +YY_RULE_SETUP +#line 122 "fortran.lex" +{ return TOK_REWIND; } + YY_BREAK +case 18: +YY_RULE_SETUP +#line 123 "fortran.lex" +{ return TOK_IMPLICIT; } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 124 "fortran.lex" +{ return TOK_NONE; } + YY_BREAK +case 20: +YY_RULE_SETUP +#line 125 "fortran.lex" +{ return TOK_CALL; } + YY_BREAK +case 21: +YY_RULE_SETUP +#line 126 "fortran.lex" +{ return TOK_TRUE; } + YY_BREAK +case 22: +YY_RULE_SETUP +#line 127 "fortran.lex" +{ return TOK_FALSE; } + YY_BREAK +case 23: +YY_RULE_SETUP +#line 128 "fortran.lex" +{ return TOK_POINT_TO; } + YY_BREAK +case 24: +YY_RULE_SETUP +#line 129 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_ASSIGNTYPE;} + YY_BREAK +case 25: +YY_RULE_SETUP +#line 130 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_DASTER; } + YY_BREAK +case 26: +YY_RULE_SETUP +#line 131 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_EQV; } + YY_BREAK +case 27: +YY_RULE_SETUP +#line 132 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_EQ; } + YY_BREAK +case 28: +YY_RULE_SETUP +#line 133 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_GT; } + YY_BREAK +case 29: +YY_RULE_SETUP +#line 134 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_GE; } + YY_BREAK +case 30: +YY_RULE_SETUP +#line 135 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_LT; } + YY_BREAK +case 31: +YY_RULE_SETUP +#line 136 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_LE; } + YY_BREAK +case 32: +YY_RULE_SETUP +#line 137 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_NEQV;} + YY_BREAK +case 33: +YY_RULE_SETUP +#line 138 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_NE; } + YY_BREAK +case 34: +YY_RULE_SETUP +#line 139 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_NOT; } + YY_BREAK +case 35: +YY_RULE_SETUP +#line 140 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_OR; } + YY_BREAK +case 36: +YY_RULE_SETUP +#line 141 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_XOR; } + YY_BREAK +case 37: +YY_RULE_SETUP +#line 142 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_AND; } + YY_BREAK +case 38: +YY_RULE_SETUP +#line 143 "fortran.lex" +{ return TOK_MODULE; } + YY_BREAK +case 39: +YY_RULE_SETUP +#line 144 "fortran.lex" +{ return TOK_WHILE; } + YY_BREAK +case 40: +YY_RULE_SETUP +#line 145 "fortran.lex" +{ return TOK_CONCURRENT; } + YY_BREAK +case 41: +YY_RULE_SETUP +#line 146 "fortran.lex" +{ return TOK_ENDDO; } + YY_BREAK +case 42: +YY_RULE_SETUP +#line 147 "fortran.lex" +{ return TOK_PLAINDO;} + YY_BREAK +case 43: +YY_RULE_SETUP +#line 148 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_REAL; } + YY_BREAK +case 44: +YY_RULE_SETUP +#line 149 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_INTEGER; } + YY_BREAK +case 45: +YY_RULE_SETUP +#line 150 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_LOGICAL; } + YY_BREAK +case 46: +YY_RULE_SETUP +#line 151 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_CHARACTER; } + YY_BREAK +case 47: +YY_RULE_SETUP +#line 152 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_HEXA;} + YY_BREAK +case 48: +YY_RULE_SETUP +#line 153 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_DOUBLEPRECISION; } + YY_BREAK +case 49: +YY_RULE_SETUP +#line 154 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_DOUBLECOMPLEX; } + YY_BREAK +case 50: +YY_RULE_SETUP +#line 155 "fortran.lex" +{ return TOK_COMPLEX; } + YY_BREAK +case 51: +YY_RULE_SETUP +#line 156 "fortran.lex" +{ return TOK_ALLOCATABLE; } + YY_BREAK +case 52: +YY_RULE_SETUP +#line 157 "fortran.lex" +{ return TOK_CLOSE; } + YY_BREAK +case 53: +YY_RULE_SETUP +#line 158 "fortran.lex" +{ return TOK_INQUIRE; } + YY_BREAK +case 54: +YY_RULE_SETUP +#line 159 "fortran.lex" +{ return TOK_DIMENSION; } + YY_BREAK +case 55: +YY_RULE_SETUP +#line 160 "fortran.lex" +{ return TOK_PAUSE; } + YY_BREAK +case 56: +YY_RULE_SETUP +#line 161 "fortran.lex" +{ return TOK_EQUIVALENCE; } + YY_BREAK +case 57: +YY_RULE_SETUP +#line 162 "fortran.lex" +{ return TOK_STOP; } + YY_BREAK +case 58: +YY_RULE_SETUP +#line 163 "fortran.lex" +{ return TOK_WHERE; } + YY_BREAK +case 59: +YY_RULE_SETUP +#line 164 "fortran.lex" +{ return TOK_ENDWHERE; } + YY_BREAK +case 60: +YY_RULE_SETUP +#line 165 "fortran.lex" +{ return TOK_ELSEWHEREPAR; } + YY_BREAK +case 61: +YY_RULE_SETUP +#line 166 "fortran.lex" +{ return TOK_ELSEWHERE; } + YY_BREAK +case 62: +YY_RULE_SETUP +#line 167 "fortran.lex" +{ return TOK_CONTAINS; } + YY_BREAK +case 63: +YY_RULE_SETUP +#line 168 "fortran.lex" +{ return TOK_ONLY; } + YY_BREAK +case 64: +YY_RULE_SETUP +#line 169 "fortran.lex" +{ return TOK_PARAMETER; } + YY_BREAK +case 65: +YY_RULE_SETUP +#line 170 "fortran.lex" +{ return TOK_RECURSIVE; } + YY_BREAK +case 66: +YY_RULE_SETUP +#line 171 "fortran.lex" +{ return TOK_COMMON; } + YY_BREAK +case 67: +YY_RULE_SETUP +#line 172 "fortran.lex" +{ return TOK_GLOBAL; } + YY_BREAK +case 68: +YY_RULE_SETUP +#line 173 "fortran.lex" +{ return TOK_EXTERNAL; } + YY_BREAK +case 69: +YY_RULE_SETUP +#line 174 "fortran.lex" +{ return TOK_INTENT; } + YY_BREAK +case 70: +YY_RULE_SETUP +#line 175 "fortran.lex" +{ return TOK_POINTER; } + YY_BREAK +case 71: +YY_RULE_SETUP +#line 176 "fortran.lex" +{ return TOK_OPTIONAL; } + YY_BREAK +case 72: +YY_RULE_SETUP +#line 177 "fortran.lex" +{ return TOK_SAVE; } + YY_BREAK +case 73: +YY_RULE_SETUP +#line 178 "fortran.lex" +{ pos_cur_decl = setposcur()-5; return TOK_TYPEPAR; } + YY_BREAK +case 74: +YY_RULE_SETUP +#line 179 "fortran.lex" +{ return TOK_TYPE; } + YY_BREAK +case 75: +YY_RULE_SETUP +#line 180 "fortran.lex" +{ return TOK_ENDTYPE; } + YY_BREAK +case 76: +YY_RULE_SETUP +#line 181 "fortran.lex" +{ if (inallocate == 1) return TOK_STAT; else { strcpy(yylval.na,fortran_text); return TOK_NAME; } } + YY_BREAK +case 77: +YY_RULE_SETUP +#line 182 "fortran.lex" +{ return TOK_OPEN; } + YY_BREAK +case 78: +YY_RULE_SETUP +#line 183 "fortran.lex" +{ return TOK_RETURN; } + YY_BREAK +case 79: +/* rule 79 can match eol */ +YY_RULE_SETUP +#line 184 "fortran.lex" +{ return TOK_EXIT; } + YY_BREAK +case 80: +YY_RULE_SETUP +#line 185 "fortran.lex" +{ return TOK_PRINT; } + YY_BREAK +case 81: +YY_RULE_SETUP +#line 186 "fortran.lex" +{ return TOK_PROCEDURE; } + YY_BREAK +case 82: +YY_RULE_SETUP +#line 187 "fortran.lex" +{ return TOK_READ; } + YY_BREAK +case 83: +YY_RULE_SETUP +#line 188 "fortran.lex" +{ return TOK_NAMELIST; } + YY_BREAK +case 84: +YY_RULE_SETUP +#line 189 "fortran.lex" +{ return TOK_WRITE; } + YY_BREAK +case 85: +YY_RULE_SETUP +#line 190 "fortran.lex" +{ return TOK_FLUSH; } + YY_BREAK +case 86: +YY_RULE_SETUP +#line 191 "fortran.lex" +{ return TOK_TARGET; } + YY_BREAK +case 87: +YY_RULE_SETUP +#line 192 "fortran.lex" +{ return TOK_PUBLIC; } + YY_BREAK +case 88: +YY_RULE_SETUP +#line 193 "fortran.lex" +{ return TOK_PRIVATE; } + YY_BREAK +case 89: +YY_RULE_SETUP +#line 194 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_IN; } + YY_BREAK +case 90: +YY_RULE_SETUP +#line 195 "fortran.lex" +{ pos_curdata = setposcur()-strlen(fortran_text); Init_List_Data_Var(); return TOK_DATA; } + YY_BREAK +case 91: +YY_RULE_SETUP +#line 196 "fortran.lex" +{ return TOK_CONTINUE; } + YY_BREAK +case 92: +YY_RULE_SETUP +#line 197 "fortran.lex" +{ return TOK_PLAINGOTO; } + YY_BREAK +case 93: +YY_RULE_SETUP +#line 198 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_OUT; } + YY_BREAK +case 94: +YY_RULE_SETUP +#line 199 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_INOUT; } + YY_BREAK +case 95: +YY_RULE_SETUP +#line 200 "fortran.lex" +{ return TOK_INTRINSIC; } + YY_BREAK +case 96: +YY_RULE_SETUP +#line 201 "fortran.lex" +{ return TOK_THEN; } + YY_BREAK +case 97: +YY_RULE_SETUP +#line 202 "fortran.lex" +{ return TOK_ELSEIF; } + YY_BREAK +case 98: +YY_RULE_SETUP +#line 203 "fortran.lex" +{ return TOK_ELSE; } + YY_BREAK +case 99: +YY_RULE_SETUP +#line 204 "fortran.lex" +{ return TOK_ENDIF; } + YY_BREAK +case 100: +YY_RULE_SETUP +#line 205 "fortran.lex" +{ return TOK_LOGICALIF; } + YY_BREAK +case 101: +YY_RULE_SETUP +#line 206 "fortran.lex" +{ return TOK_SUM; } + YY_BREAK +case 102: +YY_RULE_SETUP +#line 207 "fortran.lex" +{ return TOK_MAX; } + YY_BREAK +case 103: +YY_RULE_SETUP +#line 208 "fortran.lex" +{ return TOK_TANH; } + YY_BREAK +case 104: +YY_RULE_SETUP +#line 209 "fortran.lex" +{ return TOK_MAXVAL; } + YY_BREAK +case 105: +YY_RULE_SETUP +#line 210 "fortran.lex" +{ return TOK_TRIM; } + YY_BREAK +case 106: +YY_RULE_SETUP +#line 211 "fortran.lex" +{ return TOK_SQRT; } + YY_BREAK +case 107: +YY_RULE_SETUP +#line 212 "fortran.lex" +{ return TOK_SELECTCASE; } + YY_BREAK +case 108: +YY_RULE_SETUP +#line 213 "fortran.lex" +{ return TOK_CASE; } + YY_BREAK +case 109: +YY_RULE_SETUP +#line 214 "fortran.lex" +{ return TOK_DEFAULT; } + YY_BREAK +case 110: +YY_RULE_SETUP +#line 215 "fortran.lex" +{ return TOK_ENDSELECT; } + YY_BREAK +case 111: +YY_RULE_SETUP +#line 216 "fortran.lex" +{ return TOK_FILE; } + YY_BREAK +case 112: +YY_RULE_SETUP +#line 217 "fortran.lex" +{ return TOK_UNIT; } + YY_BREAK +case 113: +YY_RULE_SETUP +#line 218 "fortran.lex" +{ return TOK_FMT; } + YY_BREAK +case 114: +YY_RULE_SETUP +#line 219 "fortran.lex" +{ return TOK_NML; } + YY_BREAK +case 115: +YY_RULE_SETUP +#line 220 "fortran.lex" +{ return TOK_END; } + YY_BREAK +case 116: +YY_RULE_SETUP +#line 221 "fortran.lex" +{ return TOK_EOR; } + YY_BREAK +case 117: +YY_RULE_SETUP +#line 222 "fortran.lex" +{ return TOK_ERR; } + YY_BREAK +case 118: +YY_RULE_SETUP +#line 223 "fortran.lex" +{ return TOK_EXIST; } + YY_BREAK +case 119: +YY_RULE_SETUP +#line 224 "fortran.lex" +{ return TOK_MIN; } + YY_BREAK +case 120: +YY_RULE_SETUP +#line 225 "fortran.lex" +{ return TOK_NINT; } + YY_BREAK +case 121: +YY_RULE_SETUP +#line 226 "fortran.lex" +{ return TOK_FLOAT; } + YY_BREAK +case 122: +YY_RULE_SETUP +#line 227 "fortran.lex" +{ return TOK_EXP; } + YY_BREAK +case 123: +YY_RULE_SETUP +#line 228 "fortran.lex" +{ return TOK_COS; } + YY_BREAK +case 124: +YY_RULE_SETUP +#line 229 "fortran.lex" +{ return TOK_COSH; } + YY_BREAK +case 125: +YY_RULE_SETUP +#line 230 "fortran.lex" +{ return TOK_ACOS; } + YY_BREAK +case 126: +YY_RULE_SETUP +#line 231 "fortran.lex" +{ return TOK_SIN; } + YY_BREAK +case 127: +YY_RULE_SETUP +#line 232 "fortran.lex" +{ return TOK_SINH; } + YY_BREAK +case 128: +YY_RULE_SETUP +#line 233 "fortran.lex" +{ return TOK_ASIN; } + YY_BREAK +case 129: +YY_RULE_SETUP +#line 234 "fortran.lex" +{ return TOK_LOG; } + YY_BREAK +case 130: +YY_RULE_SETUP +#line 235 "fortran.lex" +{ return TOK_TAN; } + YY_BREAK +case 131: +YY_RULE_SETUP +#line 236 "fortran.lex" +{ return TOK_ATAN; } + YY_BREAK +case 132: +YY_RULE_SETUP +#line 237 "fortran.lex" +{ return TOK_CYCLE; } + YY_BREAK +case 133: +YY_RULE_SETUP +#line 238 "fortran.lex" +{ return TOK_ABS; } + YY_BREAK +case 134: +YY_RULE_SETUP +#line 239 "fortran.lex" +{ return TOK_MOD; } + YY_BREAK +case 135: +YY_RULE_SETUP +#line 240 "fortran.lex" +{ return TOK_SIGN; } + YY_BREAK +case 136: +YY_RULE_SETUP +#line 241 "fortran.lex" +{ return TOK_MINLOC; } + YY_BREAK +case 137: +YY_RULE_SETUP +#line 242 "fortran.lex" +{ return TOK_MAXLOC; } + YY_BREAK +case 138: +YY_RULE_SETUP +#line 243 "fortran.lex" +{ return TOK_MINVAL; } + YY_BREAK +case 139: +YY_RULE_SETUP +#line 244 "fortran.lex" +{ return TOK_BACKSPACE; } + YY_BREAK +case 140: +YY_RULE_SETUP +#line 245 "fortran.lex" +{ return TOK_FOURDOTS; } + YY_BREAK +case 141: +YY_RULE_SETUP +#line 246 "fortran.lex" +{ return TOK_LEFTAB; } + YY_BREAK +case 142: +YY_RULE_SETUP +#line 247 "fortran.lex" +{ return TOK_RIGHTAB; } + YY_BREAK +case 143: +/* rule 143 can match eol */ +YY_RULE_SETUP +#line 248 "fortran.lex" +{ + return TOK_FORMAT; } + YY_BREAK +case 144: +YY_RULE_SETUP +#line 250 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_SLASH; } + YY_BREAK +case 145: +YY_RULE_SETUP +#line 251 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_DSLASH; } + YY_BREAK +case 146: +/* rule 146 can match eol */ +YY_RULE_SETUP +#line 252 "fortran.lex" +{ + strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } + YY_BREAK +case 147: +/* rule 147 can match eol */ +YY_RULE_SETUP +#line 254 "fortran.lex" +{ strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } + YY_BREAK +case 148: +/* rule 148 can match eol */ +YY_RULE_SETUP +#line 255 "fortran.lex" +{ strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } + YY_BREAK +case 149: +YY_RULE_SETUP +#line 256 "fortran.lex" +{ BEGIN(donottreat); } + YY_BREAK +case 150: +/* rule 150 can match eol */ +YY_RULE_SETUP +#line 257 "fortran.lex" +{ out_of_donottreat(); return '\n'; } + YY_BREAK +case 151: +YY_RULE_SETUP +#line 258 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_NAME; } + YY_BREAK +case 152: +/* rule 152 can match eol */ +*yy_cp = (yy_hold_char); /* undo effects of setting up fortran_text */ +(yy_c_buf_p) = yy_cp -= 1; +YY_DO_BEFORE_ACTION; /* set up fortran_text again */ +YY_RULE_SETUP +#line 259 "fortran.lex" +{ // REAL1 + strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } + YY_BREAK +case 153: +YY_RULE_SETUP +#line 261 "fortran.lex" +{ // REAL2 + strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } + YY_BREAK +case 154: +YY_RULE_SETUP +#line 263 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return TOK_CSTINT; } + YY_BREAK +case 155: +YY_RULE_SETUP +#line 264 "fortran.lex" +{} + YY_BREAK +case 156: +YY_RULE_SETUP +#line 265 "fortran.lex" +{} + YY_BREAK +case 157: +YY_RULE_SETUP +#line 266 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return (int) *fortran_text; } + YY_BREAK +case 158: +YY_RULE_SETUP +#line 267 "fortran.lex" +{ strcpy(yylval.na,fortran_text); return (int) *fortran_text; } + YY_BREAK +case 159: +YY_RULE_SETUP +#line 268 "fortran.lex" +{ return TOK_SEMICOLON; } + YY_BREAK +case 160: +YY_RULE_SETUP +#line 269 "fortran.lex" +{ return (int) *fortran_text; } + YY_BREAK +case 161: +YY_RULE_SETUP +#line 270 "fortran.lex" +{ return (int) *fortran_text; } + YY_BREAK +case 162: +YY_RULE_SETUP +#line 271 "fortran.lex" +{ return (int) *fortran_text; } + YY_BREAK +case 163: +YY_RULE_SETUP +#line 272 "fortran.lex" +{ return (int) *fortran_text; } + YY_BREAK +case 164: +/* rule 164 can match eol */ +YY_RULE_SETUP +#line 273 "fortran.lex" +{ INCREMENT_LINE_NUM() ; return '\n'; } + YY_BREAK +case 165: +*yy_cp = (yy_hold_char); /* undo effects of setting up fortran_text */ +(yy_c_buf_p) = yy_cp -= 1; +YY_DO_BEFORE_ACTION; /* set up fortran_text again */ +YY_RULE_SETUP +#line 274 "fortran.lex" +{} + YY_BREAK +case 166: +YY_RULE_SETUP +#line 275 "fortran.lex" +{} + YY_BREAK +case 167: +YY_RULE_SETUP +#line 276 "fortran.lex" +{ if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0; } + YY_BREAK +case 168: +/* rule 168 can match eol */ +YY_RULE_SETUP +#line 277 "fortran.lex" +{ INCREMENT_LINE_NUM() ; newlinef90=1; } + YY_BREAK +case 169: +/* rule 169 can match eol */ +YY_RULE_SETUP +#line 278 "fortran.lex" +{ INCREMENT_LINE_NUM() ; } + YY_BREAK +case 170: +/* rule 170 can match eol */ +YY_RULE_SETUP +#line 280 "fortran.lex" +{ INCREMENT_LINE_NUM() ; BEGIN(donottreat); } + YY_BREAK +case 171: +/* rule 171 can match eol */ +YY_RULE_SETUP +#line 281 "fortran.lex" +{ out_of_donottreat(); return '\n'; } + YY_BREAK +case 172: +/* rule 172 can match eol */ +YY_RULE_SETUP +#line 282 "fortran.lex" +{ INCREMENT_LINE_NUM() ; } + YY_BREAK +case 173: +/* rule 173 can match eol */ +YY_RULE_SETUP +#line 283 "fortran.lex" +{ INCREMENT_LINE_NUM() ; } + YY_BREAK +case 174: +/* rule 174 can match eol */ +YY_RULE_SETUP +#line 284 "fortran.lex" +{ INCREMENT_LINE_NUM() ; } + YY_BREAK +case 175: +YY_RULE_SETUP +#line 285 "fortran.lex" +{} + YY_BREAK +case 176: +YY_RULE_SETUP +#line 286 "fortran.lex" +ECHO; + YY_BREAK +#line 3015 "fortran.yy.c" +case YY_STATE_EOF(INITIAL): +case YY_STATE_EOF(parameter): +case YY_STATE_EOF(character): +case YY_STATE_EOF(donottreat): +case YY_STATE_EOF(fortran77style): +case YY_STATE_EOF(fortran90style): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed fortran_in at a new source and called + * fortran_lex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = fortran_in; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( fortran_wrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * fortran_text, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of fortran_lex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + yy_size_t num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = YY_CURRENT_BUFFER; + + int yy_c_buf_p_offset = + (int) ((yy_c_buf_p) - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + yy_size_t new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + fortran_realloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - + number_to_move - 1; + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + fortran_restart(fortran_in ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) fortran_realloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 1132 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + register char *yy_cp = (yy_c_buf_p); + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 1132 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 1131); + + return yy_is_jam ? 0 : yy_current_state; +} + + static void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up fortran_text */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register yy_size_t number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + static int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + fortran_restart(fortran_in ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( fortran_wrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve fortran_text */ + (yy_hold_char) = *++(yy_c_buf_p); + + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n'); + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void fortran_restart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + fortran_ensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + fortran__create_buffer(fortran_in,YY_BUF_SIZE ); + } + + fortran__init_buffer(YY_CURRENT_BUFFER,input_file ); + fortran__load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void fortran__switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * fortran_pop_buffer_state(); + * fortran_push_buffer_state(new_buffer); + */ + fortran_ensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + fortran__load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (fortran_wrap()) processing, but the only time this flag + * is looked at is after fortran_wrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void fortran__load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + fortran_in = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE fortran__create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) fortran_alloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in fortran__create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) fortran_alloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in fortran__create_buffer()" ); + + b->yy_is_our_buffer = 1; + + fortran__init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with fortran__create_buffer() + * + */ + void fortran__delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + fortran_free((void *) b->yy_ch_buf ); + + fortran_free((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a fortran_restart() or at EOF. + */ + static void fortran__init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + fortran__flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then fortran__init_buffer was _probably_ + * called from fortran_restart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void fortran__flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + fortran__load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void fortran_push_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + fortran_ensure_buffer_stack(); + + /* This block is copied from fortran__switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from fortran__switch_to_buffer. */ + fortran__load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void fortran_pop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + fortran__delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + fortran__load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void fortran_ensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)fortran_alloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in fortran_ensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)fortran_realloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in fortran_ensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE fortran__scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) fortran_alloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in fortran__scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + fortran__switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to fortran_lex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * fortran__scan_bytes() instead. + */ +YY_BUFFER_STATE fortran__scan_string (yyconst char * yystr ) +{ + + return fortran__scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to fortran_lex() will + * scan from a @e copy of @a bytes. + * @param bytes the byte buffer to scan + * @param len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE fortran__scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n, i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) fortran_alloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in fortran__scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = fortran__scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in fortran__scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up fortran_text. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + fortran_text[fortran_leng] = (yy_hold_char); \ + (yy_c_buf_p) = fortran_text + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + fortran_leng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int fortran_get_lineno (void) +{ + + return fortran_lineno; +} + +/** Get the input stream. + * + */ +FILE *fortran_get_in (void) +{ + return fortran_in; +} + +/** Get the output stream. + * + */ +FILE *fortran_get_out (void) +{ + return fortran_out; +} + +/** Get the length of the current token. + * + */ +yy_size_t fortran_get_leng (void) +{ + return fortran_leng; +} + +/** Get the current token. + * + */ + +char *fortran_get_text (void) +{ + return fortran_text; +} + +/** Set the current line number. + * @param line_number + * + */ +void fortran_set_lineno (int line_number ) +{ + + fortran_lineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see fortran__switch_to_buffer + */ +void fortran_set_in (FILE * in_str ) +{ + fortran_in = in_str ; +} + +void fortran_set_out (FILE * out_str ) +{ + fortran_out = out_str ; +} + +int fortran_get_debug (void) +{ + return fortran__flex_debug; +} + +void fortran_set_debug (int bdebug ) +{ + fortran__flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from fortran_lex_destroy(), so don't allocate here. + */ + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + fortran_in = stdin; + fortran_out = stdout; +#else + fortran_in = (FILE *) 0; + fortran_out = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * fortran_lex_init() + */ + return 0; +} + +/* fortran_lex_destroy is for both reentrant and non-reentrant scanners. */ +int fortran_lex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + fortran__delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + fortran_pop_buffer_state(); + } + + /* Destroy the stack itself. */ + fortran_free((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * fortran_lex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *fortran_alloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *fortran_realloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void fortran_free (void * ptr ) +{ + free( (char *) ptr ); /* see fortran_realloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 286 "fortran.lex" + + + +void out_of_donottreat ( void ) +{ + BEGIN(INITIAL); + if (infixed) BEGIN(fortran77style) ; + if (infree) BEGIN(fortran90style) ; + INCREMENT_LINE_NUM() ; +} + diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/main.c b/V4.0/nemo_sources/ext/AGRIF/LIB/main.c new file mode 100644 index 0000000000000000000000000000000000000000..ae4afab5530fb9b67cffc95fec9bb70de4b40733 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/main.c @@ -0,0 +1,3927 @@ +/* A Bison parser, made by GNU Bison 2.3. */ + +/* Skeleton implementation for Bison's Yacc-like parsers in C + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* C LALR(1) parser skeleton written by Richard Stallman, by + simplifying the original so-called "semantic" parser. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +/* Identify Bison output. */ +#define YYBISON 1 + +/* Bison version. */ +#define YYBISON_VERSION "2.3" + +/* Skeleton name. */ +#define YYSKELETON_NAME "yacc.c" + +/* Pure parsers. */ +#define YYPURE 0 + +/* Using locations. */ +#define YYLSP_NEEDED 0 + +/* Substitute the variable and function names. */ +#define yyparse convert_parse +#define yylex convert_lex +#define yyerror convert_error +#define yylval convert_lval +#define yychar convert_char +#define yydebug convert_debug +#define yynerrs convert_nerrs + + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + TOK_SEP = 258, + TOK_KIND = 259, + TOK_EQUAL = 260, + TOK_USE = 261, + TOK_MODULEMAIN = 262, + TOK_NOTGRIDDEP = 263, + TOK_USEITEM = 264, + TOK_NAME = 265, + TOK_CSTINT = 266, + TOK_PROBTYPE = 267 + }; +#endif +/* Tokens. */ +#define TOK_SEP 258 +#define TOK_KIND 259 +#define TOK_EQUAL 260 +#define TOK_USE 261 +#define TOK_MODULEMAIN 262 +#define TOK_NOTGRIDDEP 263 +#define TOK_USEITEM 264 +#define TOK_NAME 265 +#define TOK_CSTINT 266 +#define TOK_PROBTYPE 267 + + + + +/* Copy the first part of user declarations. */ +#line 35 "convert.y" + +#include +#include +#include +#include "decl.h" + +int line_num=1; +extern FILE * convert_in; + +int convert_error(const char *s) +{ + printf("##\n## ERROR in conv: '%s' (line %d, file: %s)\n##\n", s, line_num, config_file); + exit(0); +} + + + +/* Enabling traces. */ +#ifndef YYDEBUG +# define YYDEBUG 1 +#endif + +/* Enabling verbose error messages. */ +#ifdef YYERROR_VERBOSE +# undef YYERROR_VERBOSE +# define YYERROR_VERBOSE 1 +#else +# define YYERROR_VERBOSE 0 +#endif + +/* Enabling the token table. */ +#ifndef YYTOKEN_TABLE +# define YYTOKEN_TABLE 0 +#endif + +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef union YYSTYPE +#line 52 "convert.y" +{ + char na[LONG_M]; +} +/* Line 193 of yacc.c. */ +#line 149 "convert.tab.c" + YYSTYPE; +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ +# define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 +#endif + + + +/* Copy the second part of user declarations. */ + + +/* Line 216 of yacc.c. */ +#line 162 "convert.tab.c" + +#ifdef short +# undef short +#endif + +#ifdef YYTYPE_UINT8 +typedef YYTYPE_UINT8 yytype_uint8; +#else +typedef unsigned char yytype_uint8; +#endif + +#ifdef YYTYPE_INT8 +typedef YYTYPE_INT8 yytype_int8; +#elif (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +typedef signed char yytype_int8; +#else +typedef short int yytype_int8; +#endif + +#ifdef YYTYPE_UINT16 +typedef YYTYPE_UINT16 yytype_uint16; +#else +typedef unsigned short int yytype_uint16; +#endif + +#ifdef YYTYPE_INT16 +typedef YYTYPE_INT16 yytype_int16; +#else +typedef short int yytype_int16; +#endif + +#ifndef YYSIZE_T +# ifdef __SIZE_TYPE__ +# define YYSIZE_T __SIZE_TYPE__ +# elif defined size_t +# define YYSIZE_T size_t +# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned int +# endif +#endif + +#define YYSIZE_MAXIMUM ((YYSIZE_T) -1) + +#ifndef YY_ +# if defined YYENABLE_NLS && YYENABLE_NLS +# if ENABLE_NLS +# include /* INFRINGES ON USER NAME SPACE */ +# define YY_(msgid) dgettext ("bison-runtime", msgid) +# endif +# endif +# ifndef YY_ +# define YY_(msgid) msgid +# endif +#endif + +/* Suppress unused-variable warnings by "using" E. */ +#if ! defined lint || defined __GNUC__ +# define YYUSE(e) ((void) (e)) +#else +# define YYUSE(e) /* empty */ +#endif + +/* Identity function, used to suppress warnings about constant conditions. */ +#ifndef lint +# define YYID(n) (n) +#else +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static int +YYID (int i) +#else +static int +YYID (i) + int i; +#endif +{ + return i; +} +#endif + +#if ! defined yyoverflow || YYERROR_VERBOSE + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# ifdef YYSTACK_USE_ALLOCA +# if YYSTACK_USE_ALLOCA +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# elif defined __BUILTIN_VA_ARG_INCR +# include /* INFRINGES ON USER NAME SPACE */ +# elif defined _AIX +# define YYSTACK_ALLOC __alloca +# elif defined _MSC_VER +# include /* INFRINGES ON USER NAME SPACE */ +# define alloca _alloca +# else +# define YYSTACK_ALLOC alloca +# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef _STDLIB_H +# define _STDLIB_H 1 +# endif +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) +# ifndef YYSTACK_ALLOC_MAXIMUM + /* The OS might guarantee only one guard page at the bottom of the stack, + and a page size can be as small as 4096 bytes. So we cannot safely + invoke alloca (N) if N exceeds 4096. Use a slightly smaller number + to allow for a few compiler-allocated temporary stack slots. */ +# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ +# endif +# else +# define YYSTACK_ALLOC YYMALLOC +# define YYSTACK_FREE YYFREE +# ifndef YYSTACK_ALLOC_MAXIMUM +# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM +# endif +# if (defined __cplusplus && ! defined _STDLIB_H \ + && ! ((defined YYMALLOC || defined malloc) \ + && (defined YYFREE || defined free))) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef _STDLIB_H +# define _STDLIB_H 1 +# endif +# endif +# ifndef YYMALLOC +# define YYMALLOC malloc +# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# ifndef YYFREE +# define YYFREE free +# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void free (void *); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# endif +#endif /* ! defined yyoverflow || YYERROR_VERBOSE */ + + +#if (! defined yyoverflow \ + && (! defined __cplusplus \ + || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + yytype_int16 yyss; + YYSTYPE yyvs; + }; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAXIMUM) + +/* Copy COUNT objects from FROM to TO. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(To, From, Count) \ + __builtin_memcpy (To, From, (Count) * sizeof (*(From))) +# else +# define YYCOPY(To, From, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (To)[yyi] = (From)[yyi]; \ + } \ + while (YYID (0)) +# endif +# endif + +/* Relocate STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack, Stack, yysize); \ + Stack = &yyptr->Stack; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (YYID (0)) + +#endif + +/* YYFINAL -- State number of the termination state. */ +#define YYFINAL 2 +/* YYLAST -- Last index in YYTABLE. */ +#define YYLAST 29 + +/* YYNTOKENS -- Number of terminals. */ +#define YYNTOKENS 16 +/* YYNNTS -- Number of nonterminals. */ +#define YYNNTS 3 +/* YYNRULES -- Number of rules. */ +#define YYNRULES 11 +/* YYNRULES -- Number of states. */ +#define YYNSTATES 29 + +/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ +#define YYUNDEFTOK 2 +#define YYMAXUTOK 267 + +#define YYTRANSLATE(YYX) \ + ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) + +/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ +static const yytype_uint8 yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 15, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 13, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 14, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, + 5, 6, 7, 8, 9, 10, 11, 12 +}; + +#if YYDEBUG +/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in + YYRHS. */ +static const yytype_uint8 yyprhs[] = +{ + 0, 0, 3, 4, 7, 9, 13, 19, 27, 31, + 37, 42 +}; + +/* YYRHS -- A `-1'-separated list of the rules' RHS. */ +static const yytype_int8 yyrhs[] = +{ + 17, 0, -1, -1, 17, 18, -1, 15, -1, 12, + 10, 14, -1, 12, 10, 13, 10, 14, -1, 12, + 10, 13, 10, 13, 10, 14, -1, 7, 10, 14, + -1, 4, 10, 5, 11, 14, -1, 8, 3, 10, + 14, -1, 6, 9, 14, -1 +}; + +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ +static const yytype_uint8 yyrline[] = +{ + 0, 71, 71, 72, 75, 76, 77, 78, 79, 84, + 100, 104 +}; +#endif + +#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE +/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. + First, the terminals, then, starting at YYNTOKENS, nonterminals. */ +static const char *const yytname[] = +{ + "$end", "error", "$undefined", "TOK_SEP", "TOK_KIND", "TOK_EQUAL", + "TOK_USE", "TOK_MODULEMAIN", "TOK_NOTGRIDDEP", "TOK_USEITEM", "TOK_NAME", + "TOK_CSTINT", "TOK_PROBTYPE", "','", "';'", "'\\n'", "$accept", "input", + "line", 0 +}; +#endif + +# ifdef YYPRINT +/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to + token YYLEX-NUM. */ +static const yytype_uint16 yytoknum[] = +{ + 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 44, 59, 10 +}; +# endif + +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 16, 17, 17, 18, 18, 18, 18, 18, 18, + 18, 18 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 1, 3, 5, 7, 3, 5, + 4, 3 +}; + +/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state + STATE-NUM when YYTABLE doesn't specify something else to do. Zero + means the default is an error. */ +static const yytype_uint8 yydefact[] = +{ + 2, 0, 1, 0, 0, 0, 0, 0, 4, 3, + 0, 0, 0, 0, 0, 0, 11, 8, 0, 0, + 5, 0, 10, 0, 9, 0, 6, 0, 7 +}; + +/* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int8 yydefgoto[] = +{ + -1, 1, 9 +}; + +/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ +#define YYPACT_NINF -13 +static const yytype_int8 yypact[] = +{ + -13, 0, -13, -7, 2, -5, 10, 4, -13, -13, + 11, 3, 5, 8, -12, 9, -13, -13, 7, 12, + -13, 13, -13, -4, -13, 14, -13, 15, -13 +}; + +/* YYPGOTO[NTERM-NUM]. */ +static const yytype_int8 yypgoto[] = +{ + -13, -13, -13 +}; + +/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule which + number is the opposite. If zero, do what YYDEFACT says. + If YYTABLE_NINF, syntax error. */ +#define YYTABLE_NINF -1 +static const yytype_uint8 yytable[] = +{ + 2, 19, 20, 10, 3, 12, 4, 5, 6, 25, + 26, 11, 7, 13, 14, 8, 15, 16, 18, 17, + 21, 22, 23, 0, 27, 0, 0, 24, 0, 28 +}; + +static const yytype_int8 yycheck[] = +{ + 0, 13, 14, 10, 4, 10, 6, 7, 8, 13, + 14, 9, 12, 3, 10, 15, 5, 14, 10, 14, + 11, 14, 10, -1, 10, -1, -1, 14, -1, 14 +}; + +/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ +static const yytype_uint8 yystos[] = +{ + 0, 17, 0, 4, 6, 7, 8, 12, 15, 18, + 10, 9, 10, 3, 10, 5, 14, 14, 10, 13, + 14, 11, 14, 10, 14, 13, 14, 10, 14 +}; + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab + + +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ + +#define YYFAIL goto yyerrlab + +#define YYRECOVERING() (!!yyerrstatus) + +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + yytoken = YYTRANSLATE (yychar); \ + YYPOPSTACK (1); \ + goto yybackup; \ + } \ + else \ + { \ + yyerror (YY_("syntax error: cannot back up")); \ + YYERROR; \ + } \ +while (YYID (0)) + + +#define YYTERROR 1 +#define YYERRCODE 256 + + +/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. + If N is 0, then set CURRENT to the empty location which ends + the previous symbol: RHS[0] (always defined). */ + +#define YYRHSLOC(Rhs, K) ((Rhs)[K]) +#ifndef YYLLOC_DEFAULT +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + do \ + if (YYID (N)) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = \ + YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = (Current).last_column = \ + YYRHSLOC (Rhs, 0).last_column; \ + } \ + while (YYID (0)) +#endif + + +/* YY_LOCATION_PRINT -- Print the location on the stream. + This macro was not mandated originally: define only if we know + we won't break user code: when these are the locations we know. */ + +#ifndef YY_LOCATION_PRINT +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL +# define YY_LOCATION_PRINT(File, Loc) \ + fprintf (File, "%d.%d-%d.%d", \ + (Loc).first_line, (Loc).first_column, \ + (Loc).last_line, (Loc).last_column) +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +# endif +#endif + + +/* YYLEX -- calling `yylex' with the right arguments. */ + +#ifdef YYLEX_PARAM +# define YYLEX yylex (YYLEX_PARAM) +#else +# define YYLEX yylex () +#endif + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (YYID (0)) + +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (YYID (0)) + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_value_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + if (!yyvaluep) + return; +# ifdef YYPRINT + if (yytype < YYNTOKENS) + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# else + YYUSE (yyoutput); +# endif + switch (yytype) + { + default: + break; + } +} + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + if (yytype < YYNTOKENS) + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + else + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + + yy_symbol_value_print (yyoutput, yytype, yyvaluep); + YYFPRINTF (yyoutput, ")"); +} + +/*------------------------------------------------------------------. +| yy_stack_print -- Print the state stack from its BOTTOM up to its | +| TOP (included). | +`------------------------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) +#else +static void +yy_stack_print (bottom, top) + yytype_int16 *bottom; + yytype_int16 *top; +#endif +{ + YYFPRINTF (stderr, "Stack now"); + for (; bottom <= top; ++bottom) + YYFPRINTF (stderr, " %d", *bottom); + YYFPRINTF (stderr, "\n"); +} + +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (YYID (0)) + + +/*------------------------------------------------. +| Report that the YYRULE is going to be reduced. | +`------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_reduce_print (YYSTYPE *yyvsp, int yyrule) +#else +static void +yy_reduce_print (yyvsp, yyrule) + YYSTYPE *yyvsp; + int yyrule; +#endif +{ + int yynrhs = yyr2[yyrule]; + int yyi; + unsigned long int yylno = yyrline[yyrule]; + YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", + yyrule - 1, yylno); + /* The symbols being reduced. */ + for (yyi = 0; yyi < yynrhs; yyi++) + { + fprintf (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], + &(yyvsp[(yyi + 1) - (yynrhs)]) + ); + fprintf (stderr, "\n"); + } +} + +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyvsp, Rule); \ +} while (YYID (0)) + +/* Nonzero means print parse trace. It is left uninitialized so that + multiple parsers can coexist. */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) +# define YY_STACK_PRINT(Bottom, Top) +# define YY_REDUCE_PRINT(Rule) +#endif /* !YYDEBUG */ + + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + + + +#if YYERROR_VERBOSE + +# ifndef yystrlen +# if defined __GLIBC__ && defined _STRING_H +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static YYSIZE_T +yystrlen (const char *yystr) +#else +static YYSIZE_T +yystrlen (yystr) + const char *yystr; +#endif +{ + YYSIZE_T yylen; + for (yylen = 0; yystr[yylen]; yylen++) + continue; + return yylen; +} +# endif +# endif + +# ifndef yystpcpy +# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static char * +yystpcpy (char *yydest, const char *yysrc) +#else +static char * +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +#endif +{ + char *yyd = yydest; + const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif + +# ifndef yytnamerr +/* Copy to YYRES the contents of YYSTR after stripping away unnecessary + quotes and backslashes, so that it's suitable for yyerror. The + heuristic is that double-quoting is unnecessary unless the string + contains an apostrophe, a comma, or backslash (other than + backslash-backslash). YYSTR is taken from yytname. If YYRES is + null, do not copy; instead, return the length of what the result + would have been. */ +static YYSIZE_T +yytnamerr (char *yyres, const char *yystr) +{ + if (*yystr == '"') + { + YYSIZE_T yyn = 0; + char const *yyp = yystr; + + for (;;) + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } + do_not_strip_quotes: ; + } + + if (! yyres) + return yystrlen (yystr); + + return yystpcpy (yyres, yystr) - yyres; +} +# endif + +/* Copy into YYRESULT an error message about the unexpected token + YYCHAR while in state YYSTATE. Return the number of bytes copied, + including the terminating null byte. If YYRESULT is null, do not + copy anything; just return the number of bytes that would be + copied. As a special case, return 0 if an ordinary "syntax error" + message will do. Return YYSIZE_MAXIMUM if overflow occurs during + size calculation. */ +static YYSIZE_T +yysyntax_error (char *yyresult, int yystate, int yychar) +{ + int yyn = yypact[yystate]; + + if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) + return 0; + else + { + int yytype = YYTRANSLATE (yychar); + YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); + YYSIZE_T yysize = yysize0; + YYSIZE_T yysize1; + int yysize_overflow = 0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + int yyx; + +# if 0 + /* This is so xgettext sees the translatable formats that are + constructed on the fly. */ + YY_("syntax error, unexpected %s"); + YY_("syntax error, unexpected %s, expecting %s"); + YY_("syntax error, unexpected %s, expecting %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); +# endif + char *yyfmt; + char const *yyf; + static char const yyunexpected[] = "syntax error, unexpected %s"; + static char const yyexpecting[] = ", expecting %s"; + static char const yyor[] = " or %s"; + char yyformat[sizeof yyunexpected + + sizeof yyexpecting - 1 + + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) + * (sizeof yyor - 1))]; + char const *yyprefix = yyexpecting; + + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yycount = 1; + + yyarg[0] = yytname[yytype]; + yyfmt = yystpcpy (yyformat, yyunexpected); + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + yyformat[sizeof yyunexpected - 1] = '\0'; + break; + } + yyarg[yycount++] = yytname[yyx]; + yysize1 = yysize + yytnamerr (0, yytname[yyx]); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + yyfmt = yystpcpy (yyfmt, yyprefix); + yyprefix = yyor; + } + + yyf = YY_(yyformat); + yysize1 = yysize + yystrlen (yyf); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + + if (yysize_overflow) + return YYSIZE_MAXIMUM; + + if (yyresult) + { + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + char *yyp = yyresult; + int yyi = 0; + while ((*yyp = *yyf) != '\0') + { + if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyf += 2; + } + else + { + yyp++; + yyf++; + } + } + } + return yysize; + } +} +#endif /* YYERROR_VERBOSE */ + + +/*-----------------------------------------------. +| Release the memory associated to this symbol. | +`-----------------------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) +#else +static void +yydestruct (yymsg, yytype, yyvaluep) + const char *yymsg; + int yytype; + YYSTYPE *yyvaluep; +#endif +{ + YYUSE (yyvaluep); + + if (!yymsg) + yymsg = "Deleting"; + YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); + + switch (yytype) + { + + default: + break; + } +} + + +/* Prevent warnings from -Wmissing-prototypes. */ + +#ifdef YYPARSE_PARAM +#if defined __STDC__ || defined __cplusplus +int yyparse (void *YYPARSE_PARAM); +#else +int yyparse (); +#endif +#else /* ! YYPARSE_PARAM */ +#if defined __STDC__ || defined __cplusplus +int yyparse (void); +#else +int yyparse (); +#endif +#endif /* ! YYPARSE_PARAM */ + + + +/* The look-ahead symbol. */ +int yychar; + +/* The semantic value of the look-ahead symbol. */ +YYSTYPE yylval; + +/* Number of syntax errors so far. */ +int yynerrs; + + + +/*----------. +| yyparse. | +`----------*/ + +#ifdef YYPARSE_PARAM +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void *YYPARSE_PARAM) +#else +int +yyparse (YYPARSE_PARAM) + void *YYPARSE_PARAM; +#endif +#else /* ! YYPARSE_PARAM */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void) +#else +int +yyparse () + +#endif +#endif +{ + + int yystate; + int yyn; + int yyresult; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + /* Look-ahead token as an internal (translated) token number. */ + int yytoken = 0; +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + + /* Three stacks and their tools: + `yyss': related to states, + `yyvs': related to semantic values, + `yyls': related to locations. + + Refer to the stacks thru separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss = yyssa; + yytype_int16 *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs = yyvsa; + YYSTYPE *yyvsp; + + + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) + + YYSIZE_T yystacksize = YYINITDEPTH; + + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; + + + /* The number of symbols on the RHS of the reduced rule. + Keep to zero when no symbol should be popped. */ + int yylen = 0; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss; + yyvsp = yyvs; + + goto yysetstate; + +/*------------------------------------------------------------. +| yynewstate -- Push a new state, which is found in yystate. | +`------------------------------------------------------------*/ + yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. So pushing a state here evens the stacks. */ + yyssp++; + + yysetstate: + *yyssp = yystate; + + if (yyss + yystacksize - 1 <= yyssp) + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = yyssp - yyss + 1; + +#ifdef yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + + &yystacksize); + + yyss = yyss1; + yyvs = yyvs1; + } +#else /* no yyoverflow */ +# ifndef YYSTACK_RELOCATE + goto yyexhaustedlab; +# else + /* Extend the stack our own way. */ + if (YYMAXDEPTH <= yystacksize) + goto yyexhaustedlab; + yystacksize *= 2; + if (YYMAXDEPTH < yystacksize) + yystacksize = YYMAXDEPTH; + + { + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss); + YYSTACK_RELOCATE (yyvs); + +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +# endif +#endif /* no yyoverflow */ + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; + + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long int) yystacksize)); + + if (yyss + yystacksize - 1 <= yyssp) + YYABORT; + } + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + goto yybackup; + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + + /* Do appropriate processing given the current state. Read a + look-ahead token if we need one and don't already have one. */ + + /* First try to decide what to do without reference to look-ahead token. */ + yyn = yypact[yystate]; + if (yyn == YYPACT_NINF) + goto yydefault; + + /* Not known => get a look-ahead token if don't already have one. */ + + /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = YYLEX; + } + + if (yychar <= YYEOF) + { + yychar = yytoken = YYEOF; + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yytoken = YYTRANSLATE (yychar); + YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); + } + + /* If the proper action on seeing token YYTOKEN is to reduce or to + detect an error, take that action. */ + yyn += yytoken; + if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) + goto yydefault; + yyn = yytable[yyn]; + if (yyn <= 0) + { + if (yyn == 0 || yyn == YYTABLE_NINF) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + + if (yyn == YYFINAL) + YYACCEPT; + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + /* Shift the look-ahead token. */ + YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); + + /* Discard the shifted token unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + yystate = yyn; + *++yyvsp = yylval; + + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- Do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + `$$ = $1'. + + Otherwise, the following line sets YYVAL to garbage. + This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + + + YY_REDUCE_PRINT (yyn); + switch (yyn) + { + case 5: +#line 76 "convert.y" + { initdimprob(1,(yyvsp[(2) - (3)].na),"0","0"); ;} + break; + + case 6: +#line 77 "convert.y" + { initdimprob(2,(yyvsp[(2) - (5)].na), (yyvsp[(4) - (5)].na),"0"); ;} + break; + + case 7: +#line 78 "convert.y" + { initdimprob(3,(yyvsp[(2) - (7)].na), (yyvsp[(4) - (7)].na), (yyvsp[(6) - (7)].na)); ;} + break; + + case 8: +#line 80 "convert.y" + { + listofmodules = Addtolistnom((yyvsp[(2) - (3)].na),listofmodules,0); + Addmoduletothelist((yyvsp[(2) - (3)].na)); + ;} + break; + + case 9: +#line 85 "convert.y" + { + if (!strcasecmp((yyvsp[(4) - (5)].na),"4")) + { + listofkind = Addtolistnom((yyvsp[(2) - (5)].na),listofkind,4); + } + else if (!strcasecmp((yyvsp[(4) - (5)].na),"8")) + { + listofkind = Addtolistnom((yyvsp[(2) - (5)].na),listofkind,8); + } + else + { + printf("##\n## Unknown kind type : %s (must be 4 or 8)\n##",(yyvsp[(4) - (5)].na)); + exit(0); + } + ;} + break; + + case 10: +#line 101 "convert.y" + { + Add_NotGridDepend_Var_1((yyvsp[(3) - (4)].na)); + ;} + break; + + case 11: +#line 105 "convert.y" + { + if (!strcasecmp((yyvsp[(2) - (3)].na),"FIXED_GRIDS")) fixedgrids = 1; + if (!strcasecmp((yyvsp[(2) - (3)].na),"ONLY_FIXED_GRIDS")) onlyfixedgrids = 1; + ;} + break; + + +/* Line 1267 of yacc.c. */ +#line 1420 "convert.tab.c" + default: break; + } + YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); + + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + + *++yyvsp = yyval; + + + /* Now `shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; + if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTOKENS]; + + goto yynewstate; + + +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ +yyerrlab: + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; +#if ! YYERROR_VERBOSE + yyerror (YY_("syntax error")); +#else + { + YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); + if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) + { + YYSIZE_T yyalloc = 2 * yysize; + if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) + yyalloc = YYSTACK_ALLOC_MAXIMUM; + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yyalloc); + if (yymsg) + yymsg_alloc = yyalloc; + else + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + } + } + + if (0 < yysize && yysize <= yymsg_alloc) + { + (void) yysyntax_error (yymsg, yystate, yychar); + yyerror (yymsg); + } + else + { + yyerror (YY_("syntax error")); + if (yysize != 0) + goto yyexhaustedlab; + } + } +#endif + } + + + + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse look-ahead token after an + error, discard it. */ + + if (yychar <= YYEOF) + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } + else + { + yydestruct ("Error: discarding", + yytoken, &yylval); + yychar = YYEMPTY; + } + } + + /* Else will try to reuse look-ahead token after shifting the error + token. */ + goto yyerrlab1; + + +/*---------------------------------------------------. +| yyerrorlab -- error raised explicitly by YYERROR. | +`---------------------------------------------------*/ +yyerrorlab: + + /* Pacify compilers like GCC when the user code never invokes + YYERROR and the label yyerrorlab therefore never appears in user + code. */ + if (/*CONSTCOND*/ 0) + goto yyerrorlab; + + /* Do not reclaim the symbols of the rule which action triggered + this YYERROR. */ + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + yystate = *yyssp; + goto yyerrlab1; + + +/*-------------------------------------------------------------. +| yyerrlab1 -- common code for both syntax error and YYERROR. | +`-------------------------------------------------------------*/ +yyerrlab1: + yyerrstatus = 3; /* Each real token shifted decrements this. */ + + for (;;) + { + yyn = yypact[yystate]; + if (yyn != YYPACT_NINF) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } + + /* Pop the current state because it cannot handle the error token. */ + if (yyssp == yyss) + YYABORT; + + + yydestruct ("Error: popping", + yystos[yystate], yyvsp); + YYPOPSTACK (1); + yystate = *yyssp; + YY_STACK_PRINT (yyss, yyssp); + } + + if (yyn == YYFINAL) + YYACCEPT; + + *++yyvsp = yylval; + + + /* Shift the error token. */ + YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + +#ifndef yyoverflow +/*-------------------------------------------------. +| yyexhaustedlab -- memory exhaustion comes here. | +`-------------------------------------------------*/ +yyexhaustedlab: + yyerror (YY_("memory exhausted")); + yyresult = 2; + /* Fall through. */ +#endif + +yyreturn: + if (yychar != YYEOF && yychar != YYEMPTY) + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval); + /* Do not reclaim the symbols of the rule which action triggered + this YYABORT or YYACCEPT. */ + YYPOPSTACK (yylen); + YY_STACK_PRINT (yyss, yyssp); + while (yyssp != yyss) + { + yydestruct ("Cleanup: popping", + yystos[*yyssp], yyvsp); + YYPOPSTACK (1); + } +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif +#if YYERROR_VERBOSE + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); +#endif + /* Make sure YYID is used. */ + return YYID (yyresult); +} + + +#line 110 "convert.y" + + +void print_usage() +{ + printf("usage : conv -convfile \n"); + printf(" [-workdir ] [-incdir ]\n"); + printf(" [-comdirin ] [-comdirout ]\n"); + printf(" [-convfile ] [-SubloopScalar] [-SubloopScalar1] \n"); + printf(" [-free|-fixed]\n"); + exit(0); +} + +int main(int argc,char *argv[]) +{ + extern FILE * convert_in ; + FILE *dependglobaloutput; + int i; + listnom *parcours; + listvar *newvar; + int stylegiven = 0; + int infreegiven ; + int infixedgiven ; + int lengthmainfile; + + char filetoparse[LONG_FNAME]; + +/******************************************************************************/ +/* 1- Variables initialization */ +/******************************************************************************/ + List_Global_Var = (listvar *) NULL; + List_GlobalParameter_Var = (listvar *) NULL; + List_Common_Var = (listvar *) NULL; + List_Allocate_Var = (listallocate *) NULL; + List_SubroutineWhereAgrifUsed = (listnom *) NULL; + List_Subroutine_For_Alloc = (listnom *) NULL; + List_Include = (listusemodule *) NULL; + List_NameOfModuleUsed = (listusemodule *) NULL; + listofmoduletmp = (listusemodule *) NULL; + List_SubroutineDeclaration_Var = (listvar *) NULL; + List_UsedInSubroutine_Var = (listvar *) NULL; + List_NotGridDepend_Var = (listvar *) NULL; + Listofavailableindices = (listindice *) NULL; + Listofavailableindices_glob = (listindice **) calloc(NB_CAT_VARIABLES,sizeof(listindice *)); + List_CouplePointed_Var = (listvarpointtovar *) NULL; + List_ModuleUsed_Var = (listvar *) NULL; + List_ModuleUsedInModuleUsed_Var = (listvar *) NULL; + List_GlobParamModuleUsed_Var = (listparameter *) NULL; + List_GlobParamModuleUsedInModuleUsed_Var = (listparameter *) NULL; + List_SubroutineArgument_Var = (listvar *) NULL; + List_FunctionType_Var = (listvar *) NULL; + tmpuselocallist = (listusemodule *) NULL; + List_ContainsSubroutine = (listnom *) NULL; + oldfortran_out = (FILE *) NULL; + + if (argc < 2) print_usage(); + + strcpy(config_file, argv[1]); + strcpy(work_dir, "."); + strcpy(input_dir, "."); + strcpy(output_dir, "AGRIF_MODELFILES"); + strcpy(include_dir, "AGRIF_INC"); + strcpy(filetoparse, ""); + strcpy(subofagrifinitgrids, ""); + strcpy(meetagrifinitgrids, ""); + strcpy(mpiinitvar, ""); + + length_last = 0 ; + length_first = 0 ; + length_v_vallengspec = 0 ; + length_v_commoninfile = 0 ; + length_v_precision = 0 ; + length_v_IntentSpec = 0 ; + length_v_initialvalue = 0 ; + length_v_readedlistdimension = 0 ; + length_a_nomvar = 0 ; + length_toprintglob = 0 ; + length_tmpvargridname = 0 ; + length_ligne_Subloop = 0 ; + length_toprint_utilagrif = 0 ; + length_toprinttmp_utilchar = 0 ; + length_ligne_writedecl = 0 ; + length_newname_toamr = 0 ; + length_newname_writedecl = 0 ; + length_ligne_toamr = 0 ; + length_tmpligne_writedecl = 0 ; + value_char_size = 0 ; + value_char_size1 = 0 ; + value_char_size2 = 0 ; + value_char_size3 = 0 ; + inallocate = 0; + infixed = 1; + infree = 0; + + onlyfixedgrids=0; + fixedgrids=0; + InAgrifParentDef = 0; + IndicenbmaillesX=0; + IndicenbmaillesY=0; + IndicenbmaillesZ=0; + created_dimensionlist = 1; + /* current indice in the table tabvars */ + for ( i=0 ; i.in */ +/******************************************************************************/ + + if ( strstr(filetoparse, ".f90") || strstr(filetoparse, ".F90") ) retour77 = 0; + + convert_parse(); + +/******************************************************************************/ +/* 4- Preparation of the file parsing */ +/******************************************************************************/ + + sprintf(dependfilename, "%s/.dependglobal_agrif", work_dir); + /* */ + if ( (dependglobaloutput=fopen(dependfilename, "r")) != NULL ) + { + for (i=0;ivar->v_nomvar, + newvar->var->v_nbdim, + newvar->var->v_subroutinename, + newvar->var->v_modulename, + newvar->var->v_typevar); + newvar = newvar->suiv; + } + +/******************************************************************************/ +/* 6- Write informations in output files */ +/******************************************************************************/ + + /* Write the .dependglobal_agrif file which contain the max indice */ + /* of the tabvars table */ + sprintf(dependfilename, "%s/.dependglobal_agrif", work_dir); + dependglobaloutput = fopen(dependfilename, "w"); + for (i=0;i file which contain general informations */ + /* about variable of this file */ + parcours = List_NameOfModule; + while( parcours ) + { + Writethedependlistofmoduleused(parcours->o_nom); + WritedependParameterList(parcours->o_nom); + Writethedependfile(parcours->o_nom,List_Global_Var); + parcours=parcours->suiv; + } + parcours = List_NameOfCommon; + while( parcours ) + { + Writethedependfile(parcours->o_nom,List_Common_Var); + parcours=parcours->suiv; + } + Write_Subroutine_For_Alloc(); + +/******************************************************************************/ +/* 7- Create files in AGRIF_INC directory */ +/******************************************************************************/ + + creefichieramr(); + + Write_val_max(); + + if ( todebug == 1 ) printf("Out of CONV \n"); + return 0; +} + +#line 2 "convert.yy.c" + +#line 4 "convert.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define yy_create_buffer convert__create_buffer +#define yy_delete_buffer convert__delete_buffer +#define yy_flex_debug convert__flex_debug +#define yy_init_buffer convert__init_buffer +#define yy_flush_buffer convert__flush_buffer +#define yy_load_buffer_state convert__load_buffer_state +#define yy_switch_to_buffer convert__switch_to_buffer +#define yyin convert_in +#define yyleng convert_leng +#define yylex convert_lex +#define yylineno convert_lineno +#define yyout convert_out +#define yyrestart convert_restart +#define yytext convert_text +#define yywrap convert_wrap +#define yyalloc convert_alloc +#define yyrealloc convert_realloc +#define yyfree convert_free + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +typedef uint64_t flex_uint64_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; +#endif /* ! C99 */ + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE convert_restart(convert_in ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#define YY_BUF_SIZE 16384 +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern yy_size_t convert_leng; + +extern FILE *convert_in, *convert_out; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + #define YY_LESS_LINENO(n) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up convert_text. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up convert_text again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + yy_size_t yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via convert_restart()), so that the user can continue scanning by + * just pointing convert_in at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when convert_text is formed. */ +static char yy_hold_char; +static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ +yy_size_t convert_leng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow convert_wrap()'s to do buffer switches + * instead of setting up a fresh convert_in. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void convert_restart (FILE *input_file ); +void convert__switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE convert__create_buffer (FILE *file,int size ); +void convert__delete_buffer (YY_BUFFER_STATE b ); +void convert__flush_buffer (YY_BUFFER_STATE b ); +void convert_push_buffer_state (YY_BUFFER_STATE new_buffer ); +void convert_pop_buffer_state (void ); + +static void convert_ensure_buffer_stack (void ); +static void convert__load_buffer_state (void ); +static void convert__init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER convert__flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE convert__scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE convert__scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE convert__scan_bytes (yyconst char *bytes,yy_size_t len ); + +void *convert_alloc (yy_size_t ); +void *convert_realloc (void *,yy_size_t ); +void convert_free (void * ); + +#define yy_new_buffer convert__create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + convert_ensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + convert__create_buffer(convert_in,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + convert_ensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + convert__create_buffer(convert_in,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ + +#define convert_wrap(n) 1 +#define YY_SKIP_YYWRAP + +typedef unsigned char YY_CHAR; + +FILE *convert_in = (FILE *) 0, *convert_out = (FILE *) 0; + +typedef int yy_state_type; + +extern int convert_lineno; + +int convert_lineno = 1; + +extern char *convert_text; +#define yytext_ptr convert_text + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up convert_text. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + convert_leng = (yy_size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 15 +#define YY_END_OF_BUFFER 16 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_accept[84] = + { 0, + 0, 0, 0, 0, 16, 15, 14, 13, 15, 12, + 11, 11, 11, 11, 12, 7, 10, 10, 10, 10, + 10, 10, 10, 14, 0, 4, 11, 9, 9, 9, + 5, 10, 10, 10, 10, 10, 10, 10, 10, 8, + 10, 10, 10, 10, 10, 3, 10, 6, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 2, 10, 10, 10, 1, 10, 10, 10, + 10, 8, 0 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 1, 1, 1, 4, 1, 1, 5, + 6, 1, 1, 7, 1, 1, 1, 8, 9, 10, + 11, 8, 8, 8, 12, 8, 8, 13, 14, 1, + 15, 1, 1, 1, 16, 17, 17, 18, 19, 20, + 21, 17, 22, 17, 23, 24, 25, 26, 27, 28, + 17, 29, 30, 31, 32, 17, 17, 33, 34, 17, + 35, 1, 36, 1, 37, 1, 38, 17, 17, 39, + + 40, 41, 42, 17, 43, 17, 44, 45, 46, 47, + 48, 49, 17, 50, 51, 52, 53, 17, 17, 54, + 55, 17, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[56] = + { 0, + 1, 1, 2, 1, 1, 1, 1, 3, 3, 3, + 3, 3, 1, 1, 1, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 1, 1, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3 + } ; + +static yyconst flex_int16_t yy_base[86] = + { 0, + 0, 0, 0, 0, 192, 194, 186, 194, 176, 194, + 48, 53, 58, 69, 164, 194, 0, 60, 51, 47, + 49, 67, 55, 173, 170, 169, 90, 194, 194, 194, + 194, 0, 160, 53, 62, 58, 66, 62, 74, 0, + 85, 95, 94, 82, 101, 0, 101, 0, 91, 134, + 96, 133, 100, 103, 99, 105, 109, 106, 102, 101, + 113, 99, 115, 113, 119, 127, 123, 139, 130, 142, + 137, 132, 0, 81, 144, 143, 0, 136, 144, 150, + 139, 0, 194, 190, 81 + } ; + +static yyconst flex_int16_t yy_def[86] = + { 0, + 83, 1, 1, 1, 83, 83, 83, 83, 84, 83, + 83, 83, 83, 83, 83, 83, 85, 85, 85, 85, + 85, 85, 85, 83, 84, 84, 83, 83, 83, 83, + 83, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 0, 83, 83 + } ; + +static yyconst flex_int16_t yy_nxt[250] = + { 0, + 6, 7, 8, 9, 10, 10, 10, 11, 12, 13, + 14, 11, 15, 10, 16, 17, 17, 17, 17, 18, + 17, 17, 19, 17, 17, 20, 21, 22, 17, 17, + 17, 23, 17, 17, 10, 10, 17, 17, 17, 17, + 18, 17, 17, 19, 17, 17, 20, 21, 22, 17, + 17, 17, 23, 17, 17, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 28, 33, 35, 36, 37, 29, 27, 27, 27, 27, + 27, 34, 38, 32, 39, 41, 30, 42, 43, 44, + 45, 28, 46, 35, 36, 37, 29, 27, 27, 27, + + 27, 27, 34, 47, 38, 39, 41, 30, 42, 43, + 44, 45, 48, 46, 49, 50, 51, 76, 52, 53, + 55, 57, 58, 59, 47, 60, 61, 62, 63, 64, + 65, 66, 67, 48, 68, 49, 50, 69, 51, 52, + 53, 55, 57, 58, 59, 70, 60, 61, 62, 63, + 64, 65, 66, 67, 71, 68, 72, 73, 69, 74, + 75, 40, 77, 78, 79, 80, 70, 81, 82, 56, + 54, 40, 26, 26, 24, 71, 31, 72, 73, 26, + 74, 75, 40, 77, 78, 79, 80, 24, 81, 82, + 25, 83, 25, 5, 83, 83, 83, 83, 83, 83, + + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83 + } ; + +static yyconst flex_int16_t yy_chk[250] = + { 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, 1, 1, + 1, 1, 1, 1, 1, 11, 11, 11, 11, 11, + 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, + 12, 18, 19, 20, 21, 13, 14, 14, 14, 14, + 14, 18, 22, 85, 23, 34, 14, 35, 36, 37, + 38, 12, 39, 19, 20, 21, 13, 27, 27, 27, + + 27, 27, 18, 41, 22, 23, 34, 14, 35, 36, + 37, 38, 42, 39, 43, 44, 45, 74, 47, 49, + 51, 53, 54, 55, 41, 56, 57, 58, 59, 60, + 61, 62, 63, 42, 64, 43, 44, 65, 45, 47, + 49, 51, 53, 54, 55, 66, 56, 57, 58, 59, + 60, 61, 62, 63, 67, 64, 68, 69, 65, 70, + 71, 72, 75, 76, 78, 79, 66, 80, 81, 52, + 50, 33, 26, 25, 24, 67, 15, 68, 69, 9, + 70, 71, 72, 75, 76, 78, 79, 7, 80, 81, + 84, 5, 84, 83, 83, 83, 83, 83, 83, 83, + + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, + 83, 83, 83, 83, 83, 83, 83, 83, 83 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +extern int convert__flex_debug; +int convert__flex_debug = 0; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *convert_text; +#line 1 "convert.lex" +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ + +#line 40 "convert.lex" +#include +#include +#include + +#define YY_NO_INPUT +#line 595 "convert.yy.c" + +#define INITIAL 0 +#define character 1 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int convert_lex_destroy (void ); + +int convert_get_debug (void ); + +void convert_set_debug (int debug_flag ); + +YY_EXTRA_TYPE convert_get_extra (void ); + +void convert_set_extra (YY_EXTRA_TYPE user_defined ); + +FILE *convert_get_in (void ); + +void convert_set_in (FILE * in_str ); + +FILE *convert_get_out (void ); + +void convert_set_out (FILE * out_str ); + +yy_size_t convert_get_leng (void ); + +char *convert_get_text (void ); + +int convert_get_lineno (void ); + +void convert_set_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int convert_wrap (void ); +#else +extern int convert_wrap (void ); +#endif +#endif + + static void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +static int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO fwrite( convert_text, convert_leng, 1, convert_out ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + yy_size_t n; \ + for ( n = 0; n < max_size && \ + (c = getc( convert_in )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( convert_in ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, convert_in))==0 && ferror(convert_in)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(convert_in); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int convert_lex (void); + +#define YY_DECL int convert_lex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after convert_text and convert_leng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 54 "convert.lex" + +#line 780 "convert.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! convert_in ) + convert_in = stdin; + + if ( ! convert_out ) + convert_out = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + convert_ensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + convert__create_buffer(convert_in,YY_BUF_SIZE ); + } + + convert__load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of convert_text. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 84 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 194 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = (yy_hold_char); + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + goto yy_find_action; + +case 1: +YY_RULE_SETUP +#line 55 "convert.lex" +{ return TOK_MODULEMAIN; } /* name of the module */ + YY_BREAK +case 2: +YY_RULE_SETUP +#line 56 "convert.lex" +{ return TOK_NOTGRIDDEP; } /* variable which are not grid dependent */ + YY_BREAK +case 3: +YY_RULE_SETUP +#line 57 "convert.lex" +{ return TOK_USE; } + YY_BREAK +case 4: +YY_RULE_SETUP +#line 58 "convert.lex" +{ } + YY_BREAK +case 5: +YY_RULE_SETUP +#line 59 "convert.lex" +{ return TOK_SEP; } + YY_BREAK +case 6: +YY_RULE_SETUP +#line 60 "convert.lex" +{ return TOK_KIND; } + YY_BREAK +case 7: +YY_RULE_SETUP +#line 61 "convert.lex" +{ return TOK_EQUAL; } + YY_BREAK +case 8: +YY_RULE_SETUP +#line 62 "convert.lex" +{ strcpy(yylval.na,convert_text); return TOK_USEITEM; } + YY_BREAK +case 9: +YY_RULE_SETUP +#line 63 "convert.lex" +{ strcpy(yylval.na,convert_text); return TOK_PROBTYPE; } /* dimension of the problem */ + YY_BREAK +case 10: +YY_RULE_SETUP +#line 64 "convert.lex" +{ strcpy(yylval.na,convert_text); return TOK_NAME; } + YY_BREAK +case 11: +YY_RULE_SETUP +#line 65 "convert.lex" +{ strcpy(yylval.na,convert_text); return TOK_CSTINT; } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 66 "convert.lex" +{ return (int) *convert_text; } + YY_BREAK +case 13: +/* rule 13 can match eol */ +YY_RULE_SETUP +#line 67 "convert.lex" +{ line_num++; return (int) *convert_text; } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 68 "convert.lex" +; + YY_BREAK +case 15: +YY_RULE_SETUP +#line 69 "convert.lex" +ECHO; + YY_BREAK +#line 939 "convert.yy.c" +case YY_STATE_EOF(INITIAL): +case YY_STATE_EOF(character): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed convert_in at a new source and called + * convert_lex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = convert_in; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( convert_wrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * convert_text, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of convert_lex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + yy_size_t num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = YY_CURRENT_BUFFER; + + int yy_c_buf_p_offset = + (int) ((yy_c_buf_p) - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + yy_size_t new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + convert_realloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - + number_to_move - 1; + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + convert_restart(convert_in ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) convert_realloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 84 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + register char *yy_cp = (yy_c_buf_p); + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 84 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 83); + + return yy_is_jam ? 0 : yy_current_state; +} + + static void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up convert_text */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register yy_size_t number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + static int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + convert_restart(convert_in ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( convert_wrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve convert_text */ + (yy_hold_char) = *++(yy_c_buf_p); + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void convert_restart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + convert_ensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + convert__create_buffer(convert_in,YY_BUF_SIZE ); + } + + convert__init_buffer(YY_CURRENT_BUFFER,input_file ); + convert__load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void convert__switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * convert_pop_buffer_state(); + * convert_push_buffer_state(new_buffer); + */ + convert_ensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + convert__load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (convert_wrap()) processing, but the only time this flag + * is looked at is after convert_wrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void convert__load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + convert_in = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE convert__create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) convert_alloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in convert__create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) convert_alloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in convert__create_buffer()" ); + + b->yy_is_our_buffer = 1; + + convert__init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with convert__create_buffer() + * + */ + void convert__delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + convert_free((void *) b->yy_ch_buf ); + + convert_free((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a convert_restart() or at EOF. + */ + static void convert__init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + convert__flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then convert__init_buffer was _probably_ + * called from convert_restart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void convert__flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + convert__load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void convert_push_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + convert_ensure_buffer_stack(); + + /* This block is copied from convert__switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from convert__switch_to_buffer. */ + convert__load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void convert_pop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + convert__delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + convert__load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void convert_ensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)convert_alloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in convert_ensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)convert_realloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in convert_ensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE convert__scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) convert_alloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in convert__scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + convert__switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to convert_lex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * convert__scan_bytes() instead. + */ +YY_BUFFER_STATE convert__scan_string (yyconst char * yystr ) +{ + + return convert__scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to convert_lex() will + * scan from a @e copy of @a bytes. + * @param bytes the byte buffer to scan + * @param len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE convert__scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n, i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) convert_alloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in convert__scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = convert__scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in convert__scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up convert_text. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + convert_text[convert_leng] = (yy_hold_char); \ + (yy_c_buf_p) = convert_text + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + convert_leng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int convert_get_lineno (void) +{ + + return convert_lineno; +} + +/** Get the input stream. + * + */ +FILE *convert_get_in (void) +{ + return convert_in; +} + +/** Get the output stream. + * + */ +FILE *convert_get_out (void) +{ + return convert_out; +} + +/** Get the length of the current token. + * + */ +yy_size_t convert_get_leng (void) +{ + return convert_leng; +} + +/** Get the current token. + * + */ + +char *convert_get_text (void) +{ + return convert_text; +} + +/** Set the current line number. + * @param line_number + * + */ +void convert_set_lineno (int line_number ) +{ + + convert_lineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see convert__switch_to_buffer + */ +void convert_set_in (FILE * in_str ) +{ + convert_in = in_str ; +} + +void convert_set_out (FILE * out_str ) +{ + convert_out = out_str ; +} + +int convert_get_debug (void) +{ + return convert__flex_debug; +} + +void convert_set_debug (int bdebug ) +{ + convert__flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from convert_lex_destroy(), so don't allocate here. + */ + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + convert_in = stdin; + convert_out = stdout; +#else + convert_in = (FILE *) 0; + convert_out = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * convert_lex_init() + */ + return 0; +} + +/* convert_lex_destroy is for both reentrant and non-reentrant scanners. */ +int convert_lex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + convert__delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + convert_pop_buffer_state(); + } + + /* Destroy the stack itself. */ + convert_free((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * convert_lex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *convert_alloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *convert_realloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void convert_free (void * ptr ) +{ + free( (char *) ptr ); /* see convert_realloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 69 "convert.lex" + + + diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/run b/V4.0/nemo_sources/ext/AGRIF/LIB/run new file mode 100755 index 0000000000000000000000000000000000000000..8e99818c4d6df9f0fa9dea1ae3a50ca132bbf600 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/run @@ -0,0 +1,2 @@ +make -f Makefile.lex clean +make -f Makefile.lex diff --git a/V4.0/nemo_sources/ext/AGRIF/LIB/toamr.c b/V4.0/nemo_sources/ext/AGRIF/LIB/toamr.c new file mode 100644 index 0000000000000000000000000000000000000000..288cdb82c396cc1e7903c3fd0bbd7ddc8d4a0fad --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/LIB/toamr.c @@ -0,0 +1,962 @@ +/******************************************************************************/ +/* */ +/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */ +/* */ +/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */ +/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */ +/* This software is governed by the CeCILL-C 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-C */ +/* 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-C license and that you accept its terms. */ +/******************************************************************************/ +/* version 1.7 */ +/******************************************************************************/ +#include +#include +#include +#include "decl.h" + +const char * tabvarsname(const variable *var) +{ + static char * tname[5] = { + "tabvars", // v_catvar == 0 + "tabvars_c", // v_catvar == 1 + "tabvars_r", // v_catvar == 2 + "tabvars_l", // v_catvar == 3 + "tabvars_i" // v_catvar == 4 + }; + return tname[var->v_catvar]; // v_catvar should never be ouside the range [0:4]. +} + +/******************************************************************************/ +/* variablecurgridtabvars */ +/******************************************************************************/ +/* This subroutine is used to create the string */ +/******************************************************************************/ +/* */ +/* -----------> Agrif_Curgrid % tabvars (i) */ +/* */ +/******************************************************************************/ +const char * variablecurgridtabvars(int which_grid) +{ + static char * varname[4] = { + " Agrif_%s(%d)", // which_grid == 0 + " Agrif_%s(%d) %% parent_var", // which_grid == 1 + " Agrif_Mygrid %% %s(%d)", // which_grid == 2 + " Agrif_Curgrid %% %s(%d)", // which_grid == 3 + }; + + return varname[which_grid]; +} + +void WARNING_CharSize(const variable *var) +{ + if ( var->v_nbdim == 0 ) + { + if ( convert2int(var->v_dimchar) > 2400 ) + { + printf("WARNING : The dimension of the character %s \n", var->v_nomvar); + printf(" is upper than 2400. You must change \n"); + printf(" the dimension of carray0 \n"); + printf(" in the file AGRIF/AGRIF_FILES/modtypes.F90 \n"); + printf(" line 161. Replace 2400 with %d. \n", convert2int(var->v_dimchar)+100); + } + Save_Length_int(convert2int(var->v_dimchar),1); + } + else if ( var->v_nbdim == 1 ) + { + if ( convert2int(var->v_dimchar) > 200 ) + { + printf("WARNING : The dimension of the character %s \n", var->v_nomvar); + printf(" is upper than 200. You must change \n"); + printf(" the dimension of carray1 \n"); + printf(" in the file AGRIF/AGRIF_FILES/modtypes.F90 \n"); + printf(" line 162. Replace 200 with %d. \n", convert2int(var->v_dimchar)+100); + } + Save_Length_int(convert2int(var->v_dimchar),2); + } + else if ( var->v_nbdim == 2 ) + { + if ( convert2int(var->v_dimchar) > 200 ) + { + printf("WARNING : The dimension of the character %s \n", var->v_nomvar); + printf(" is upper than 200. You must change \n"); + printf(" the dimension of carray2 \n"); + printf(" in the file AGRIF/AGRIF_FILES/modtypes.F90 \n"); + printf(" line 163. Replace 200 with %d. \n", convert2int(var->v_dimchar)+100); + } + Save_Length_int(convert2int(var->v_dimchar),3); + } + else if ( var->v_nbdim == 3 ) + { + if ( convert2int(var->v_dimchar) > 200 ) + { + printf("WARNING : The dimension of the character %s \n", var->v_nomvar); + printf(" is upper than 200. You must change \n"); + printf(" the dimension of carray3 \n"); + printf(" in the file AGRIF/AGRIF_FILES/modtypes.F90 \n"); + printf(" line 164. Replace 200 with %d. \n", convert2int(var->v_dimchar)+100); + } + Save_Length_int(convert2int(var->v_dimchar),4); + } +} +/******************************************************************************/ +/* vargridnametabvars */ +/******************************************************************************/ +/* This subroutine is used to create the string */ +/******************************************************************************/ +/* */ +/* if iorindice == 0 -----------> Agrif_Gr % tabvars (i) % array1 */ +/* */ +/* if iorindice == 1 -----------> Agrif_Gr % tabvars (12) % array1 */ +/* */ +/******************************************************************************/ +const char *vargridnametabvars (const variable * var, int iorindice) +{ + static char tname_1[LONG_C]; + static char tname_2[LONG_C]; + + if ( iorindice == 0 ) sprintf(tname_1, "Agrif_Gr %% %s(%d)", tabvarsname(var), var->v_indicetabvars); + else sprintf(tname_1, "Agrif_Gr %% %s(i)", tabvarsname(var)); + + if (!strcasecmp(var->v_typevar, "REAL")) + { + if ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim); + else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim); + else sprintf(tname_2, "%% array%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "integer")) + { + sprintf(tname_2, "%% iarray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "logical")) + { + sprintf(tname_2, "%% larray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "character")) + { + WARNING_CharSize(var); + sprintf (tname_2, "%% carray%d", var->v_nbdim); + } + + strcat(tname_1, tname_2); + Save_Length(tname_1, 46); + + return tname_1; +} + +/******************************************************************************/ +/* vargridcurgridtabvars */ +/******************************************************************************/ +/* This subroutine is used to create the string */ +/******************************************************************************/ +/* */ +/* if which_grid == 0 --> Agrif_Curgrid % tabvars (i) % array1 */ +/* */ +/* if which_grid == 1 --> Agrif_tabvars (i) % parent_var % array1 */ +/* */ +/* if which_grid == 2 --> Agrif_Gr % tabvars (i) % array1 */ +/* */ +/******************************************************************************/ +const char *vargridcurgridtabvars(const variable *var, int which_grid) +{ + static char tname_1[LONG_C]; + static char tname_2[LONG_C]; + + if (!strcasecmp(var->v_typevar,"type")) + { + sprintf(tname_1, "Agrif_%s_var(Agrif_Curgrid%%fixedrank)%%%s", var->v_modulename, var->v_nomvar); + } + else + { + sprintf(tname_1, variablecurgridtabvars(which_grid), tabvarsname(var), var->v_indicetabvars); + + if (!strcasecmp(var->v_typevar, "REAL")) + { + if ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim); + else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim); + else sprintf(tname_2, "%% array%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "INTEGER")) + { + sprintf(tname_2, "%% iarray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "LOGICAL")) + { + sprintf(tname_2, "%% larray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "CHARACTER")) + { + WARNING_CharSize(var); + sprintf(tname_2, "%% carray%d", var->v_nbdim); + } + strcat(tname_1, tname_2); + } + Save_Length(tname_1, 46); + + return tname_1; +} + +/******************************************************************************/ +/* vargridcurgridtabvarswithoutAgrif_Gr */ +/******************************************************************************/ +/* This subroutine is used to create the string */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +const char *vargridcurgridtabvarswithoutAgrif_Gr(const variable *var) +{ + static char tname_1[LONG_C]; + static char tname_2[LONG_C]; + + sprintf(tname_1, "(%d)", var->v_indicetabvars); + + if (!strcasecmp (var->v_typevar, "REAL")) + { + if ( !strcasecmp(var->v_nameinttypename,"8") ) sprintf(tname_2, "%% darray%d", var->v_nbdim); + else if ( !strcasecmp(var->v_nameinttypename,"4") ) sprintf(tname_2, "%% sarray%d", var->v_nbdim); + else sprintf(tname_2, "%% array%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "INTEGER")) + { + sprintf(tname_2, "%% iarray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "LOGICAL")) + { + sprintf(tname_2, "%% larray%d", var->v_nbdim); + } + else if (!strcasecmp(var->v_typevar, "CHARACTER")) + { + WARNING_CharSize(var); + sprintf(tname_2, "%% carray%d", var->v_nbdim); + } + + strcat(tname_1, tname_2); + Save_Length(tname_1, 46); + + return tname_1; +} + +/******************************************************************************/ +/* vargridparam */ +/******************************************************************************/ +/* This subroutine is used to create the string which contains */ +/* dimension list */ +/******************************************************************************/ +/* */ +/* DIMENSION(jpi,0:jpj) ----------->"1:jpi,0:jpj" */ +/* */ +/******************************************************************************/ +const char * vargridparam(const variable *var) +{ + typedim dim; + listdim *newdim; + char newname[LONG_M]; + + newdim = var->v_dimension; + if (!newdim) return ""; + + strcpy (tmpvargridname, "("); + while (newdim) + { + dim = newdim->dim; + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(dim.first,List_Global_Var)); + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_Common_Var)); + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname,List_ModuleUsed_Var)); + strcat(tmpvargridname, newname); + strcat(tmpvargridname, " : "); + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(dim.last,List_Global_Var)); + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname, List_Common_Var)); + strcpy(newname,ChangeTheInitalvaluebyTabvarsName(newname, List_ModuleUsed_Var)); + strcat(tmpvargridname, newname); + newdim = newdim->suiv; + if (newdim) strcat(tmpvargridname, ","); + } + strcat(tmpvargridname, ")\0"); + Save_Length(tmpvargridname,40); + return tmpvargridname; +} + +/******************************************************************************/ +/* write_probdimagrif_file */ +/******************************************************************************/ +/* This subroutine is used to create the file probdim_agrif.h */ +/******************************************************************************/ +/* */ +/* probdim_agrif.h */ +/* */ +/* Agrif_probdim = */ +/* */ +/******************************************************************************/ +void write_probdimagrif_file() +{ + FILE *probdim; + char ligne[LONG_M]; + + probdim = open_for_write("probdim_agrif.h"); + sprintf (ligne, "Agrif_Probdim = %d", dimprob); + tofich (probdim, ligne,1); + fclose (probdim); +} + +/******************************************************************************/ +/* write_keysagrif_file */ +/******************************************************************************/ +/* This subroutine is used to create the file keys_agrif.h */ +/******************************************************************************/ +/* */ +/* keys_agrif.h */ +/* */ +/* AGRIF_USE_FIXED_GRIDS = 0 */ +/* AGRIF_USE_ONLY_FIXED_GRIDS = 0 */ +/* AGRIF_USE_(ONLY)_FIXED_GRIDS = 1 */ +/* */ +/******************************************************************************/ +void write_keysagrif_file() +{ + FILE *keys; + + keys = open_for_write("keys_agrif.h"); + fprintf(keys," AGRIF_USE_FIXED_GRIDS = %d\n", fixedgrids); + fprintf(keys," AGRIF_USE_ONLY_FIXED_GRIDS = %d\n", onlyfixedgrids); + fclose(keys); +} + +/******************************************************************************/ +/* write_modtypeagrif_file */ +/******************************************************************************/ +/* This subroutine is used to create the file typedata */ +/******************************************************************************/ +/* */ +/* modtype_agrif.h */ +/* */ +/* Agrif_NbVariables = */ +/* */ +/******************************************************************************/ +void write_modtypeagrif_file() +{ + char ligne[LONG_M]; + FILE *typedata; + int i; + + typedata = open_for_write("modtype_agrif.h"); + /* AGRIF_NbVariables : number of variables */ + for (i=0;iv_indicetabvars,v->v_nomvar); + tofich(createvarname,ligne,1); +} + +/******************************************************************************/ +/* write_Setnumberofcells_file */ +/******************************************************************************/ +/* This subroutine is used to create the file setnumberofcells */ +/******************************************************************************/ +/* */ +/* Agrif_Gr % n(i) = nbmailles */ +/* */ +/******************************************************************************/ +void write_Setnumberofcells_file() +{ + char ligne[LONG_VNAME]; + char cformat[LONG_VNAME]; + FILE *setnumberofcells; + + if ( IndicenbmaillesX == 0 ) return; + + setnumberofcells = open_for_write("SetNumberofcells.h"); + + if ( onlyfixedgrids == 1 ) + strcpy(cformat, "Agrif_Gr %% nb(%d) = Agrif_Curgrid %% tabvars_i(%d) %% iarray0"); + else + strcpy(cformat, "Agrif_Gr %% nb(%d) = Agrif_Gr %% tabvars_i(%d) %% iarray0"); + + sprintf(ligne, cformat, 1, IndicenbmaillesX); + tofich(setnumberofcells, ligne, 1); + + if ( dimprob > 1 ) + { + sprintf(ligne, cformat, 2, IndicenbmaillesY); + tofich(setnumberofcells, ligne, 1); + } + if ( dimprob > 2 ) + { + sprintf(ligne, cformat, 3, IndicenbmaillesZ); + tofich(setnumberofcells, ligne, 1); + } + fclose(setnumberofcells); +} + +/******************************************************************************/ +/* write_Getnumberofcells_file */ +/******************************************************************************/ +/* This subroutine is used to create the file getnumberofcells */ +/******************************************************************************/ +/* */ +/* nbmailles = Agrif_Gr % n(i) */ +/* */ +/******************************************************************************/ +void write_Getnumberofcells_file() +{ + char ligne[LONG_VNAME]; + char cformat[LONG_VNAME]; + FILE *getnumberofcells; + + if ( IndicenbmaillesX == 0 ) return; + + strcpy(cformat, "Agrif_Curgrid %% tabvars_i(%d) %% iarray0 = Agrif_Gr %% nb(%d)"); + + getnumberofcells = open_for_write("GetNumberofcells.h"); + + sprintf(ligne, cformat, IndicenbmaillesX, 1); + tofich(getnumberofcells, ligne, 1); + + if (dimprob > 1) + { + sprintf(ligne, cformat, IndicenbmaillesY, 2); + tofich(getnumberofcells, ligne,1); + } + if (dimprob > 2) + { + sprintf(ligne, cformat, IndicenbmaillesZ, 3); + tofich(getnumberofcells, ligne,1); + } + fclose(getnumberofcells); +} + + +/******************************************************************************/ +/* write_initialisationsagrif_file */ +/******************************************************************************/ +/* This subroutine is used to create the file initproc */ +/******************************************************************************/ +/* */ +/* ! variable */ +/* Agrif_Gr % tabvars(i) % nbdim = 1 */ +/* */ +/******************************************************************************/ +void write_initialisationsagrif_file(variable *v,FILE *initproc,int *VarnameEmpty) +{ + char ligne[LONG_M]; + + if ( v->v_nbdim != 0 ) + { + *VarnameEmpty = 0 ; + sprintf(ligne,"Agrif_Mygrid %% %s(%d) %% nbdim = %d", tabvarsname(v), v->v_indicetabvars, v->v_nbdim); + tofich (initproc, ligne,1); + } +} + + +void Write_Alloc_Agrif_Files() +{ + listnom *parcours; + FILE *alloccalls; + FILE *AllocUSE; + + AllocUSE= open_for_write("include_use_Alloc_agrif.h"); + alloccalls = open_for_write("allocations_calls_agrif.h"); + + parcours = List_Subroutine_For_Alloc; + while ( parcours ) + { + fprintf(AllocUSE," use %s, only: Alloc_agrif_%s\n", parcours -> o_nom, parcours -> o_nom ); + fprintf (alloccalls," call Alloc_agrif_%s(Agrif_Gr)\n", parcours -> o_nom ); + parcours = parcours -> suiv; + } + + fclose (AllocUSE); + fclose (alloccalls); +} + +int IndiceInlist(int indic, listindice *listin) +{ + listindice *parcoursindic; + int out; + + out = 0 ; + + parcoursindic = listin; + while ( parcoursindic && out == 0 ) + { + if ( parcoursindic->i_indice == indic ) out = 1; + else parcoursindic = parcoursindic -> suiv; + } + + return out; +} + +void write_allocation_Common_0() +{ + listnom *parcours_nom; + listnom *neededparameter; + listvar *parcours; + listvar *parcoursprec; + listvar *parcours1; + FILE *allocationagrif; + FILE *paramtoamr; + char ligne[LONG_M]; + char ligne2[LONG_M]; + variable *v; + int IndiceMax; + int IndiceMin; + int compteur; + int out; + int indiceprec; + int ValeurMax; + char initialvalue[LONG_M]; + listindice **list_indic; + listindice *parcoursindic; + int i; + + parcoursprec = (listvar *) NULL; + parcours_nom = List_NameOfCommon; + ValeurMax = 2; + while ( parcours_nom ) + { + if ( parcours_nom->o_val == 1 ) + { + /* Open the file to create the Alloc_agrif subroutine */ + sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom); + allocationagrif = open_for_write(ligne); + fprintf(allocationagrif,"#include \"Param_toamr_%s.h\" \n", parcours_nom->o_nom); + + sprintf(ligne,"Param_toamr_%s.h",parcours_nom->o_nom); + paramtoamr = open_for_write(ligne); + neededparameter = (listnom *) NULL; + list_indic = (listindice **) calloc(NB_CAT_VARIABLES,sizeof(listindice *)); + +// shouldincludempif = 1 ; + parcours = List_Common_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_commonname,parcours_nom->o_nom) && + IndiceInlist(parcours->var->v_indicetabvars,list_indic[parcours->var->v_catvar]) == 0 ) + { + v = parcours->var; + IndiceMax = 0; + IndiceMin = indicemaxtabvars[v->v_catvar]; + /* body of the file */ + if ( !strcasecmp(v->v_commoninfile,cur_filename) ) + { + if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) ) + { + sprintf(ligne,"if (.not. allocated(%s)) then", vargridnametabvars(v,0)); + tofich(allocationagrif,ligne,1); + } + if ( (v->v_allocatable != 1) && (v->v_dimsempty != 1) ) + { + /* ALLOCATION */ + if ( v->v_dimension != 0 ) + { + if ( v->v_indicetabvars < IndiceMin || v->v_indicetabvars > IndiceMax ) + { + parcours1 = parcours; + compteur = -1; + out = 0; + indiceprec = parcours->var->v_indicetabvars -1 ; + while ( parcours1 && out == 0 + && !strcasecmp(parcours->var->v_readedlistdimension,parcours1->var->v_readedlistdimension) + && !strcasecmp(parcours->var->v_typevar, parcours1->var->v_typevar) + && (parcours1->var->v_indicetabvars == indiceprec+1) ) + { + if ( !strcasecmp(parcours1->var->v_modulename,parcours_nom->o_nom) || + !strcasecmp(parcours1->var->v_commonname,parcours_nom->o_nom) ) + { + compteur = compteur +1 ; + indiceprec = parcours1->var->v_indicetabvars; + parcoursprec = parcours1; + parcours1 = parcours1->suiv; + } + else out = 1; + } + sprintf(ligne,"!! ALLOCATION OF VARIABLE : %s",v->v_nomvar); + tofich(allocationagrif,ligne,1); + if ( compteur > ValeurMax ) + { + sprintf(ligne,"do i = %d,%d", parcours->var->v_indicetabvars, + parcours->var->v_indicetabvars+compteur); + tofich(allocationagrif,ligne,1); + IndiceMin = parcours->var->v_indicetabvars; + IndiceMax = parcours->var->v_indicetabvars+compteur; + sprintf(ligne," allocate(%s", vargridnametabvars(v,1)); + sprintf(ligne2,"%s)", vargridparam(v)); + strcat(ligne,ligne2); + tofich(allocationagrif,ligne,1); + tofich(allocationagrif,"enddo",1); + i = parcours->var->v_indicetabvars; + do + { + parcoursindic = (listindice *)calloc(1,sizeof(listindice)); + parcoursindic -> i_indice = i; + parcoursindic -> suiv = list_indic[parcours->var->v_catvar]; + list_indic[parcours->var->v_catvar] = parcoursindic; + i = i + 1; + } while ( i <= parcours->var->v_indicetabvars+compteur ); + parcours = parcoursprec; + } + else + { + sprintf(ligne,"allocate(%s", vargridnametabvars(v,0)); + sprintf(ligne2,"%s)", vargridparam(v)); + strcat(ligne,ligne2); + tofich(allocationagrif,ligne,1); + parcoursindic = (listindice *) calloc(1,sizeof(listindice)); + parcoursindic -> i_indice = parcours->var->v_indicetabvars; + parcoursindic -> suiv = list_indic[parcours->var->v_catvar]; + list_indic[parcours->var->v_catvar] = parcoursindic; + } + neededparameter = writedeclarationintoamr(List_Parameter_Var, + paramtoamr,v,parcours_nom->o_nom,neededparameter,v->v_commonname); + } + } /* end of the allocation part */ + /* INITIALISATION */ + if ( strcasecmp(v->v_initialvalue,"") ) + { + strcpy(ligne, vargridnametabvars(v,0)); + /* We should modify the initialvalue in the case of variable has been defined with others variables */ + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Global_Var)); + if ( !strcasecmp(initialvalue,v->v_initialvalue) ) + { + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Common_Var)); + } + if ( !strcasecmp(initialvalue,v->v_initialvalue) ) + { + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_ModuleUsed_Var)); + } + strcat (ligne," = "); + + if (v->v_nbdim == 0) + { + strcpy(ligne2,initialvalue); + } + else + { + sprintf(ligne2,"reshape(%s,shape(%s))",initialvalue,vargridnametabvars(v,0)); + } + strcat(ligne,ligne2); + tofich(allocationagrif,ligne,1); + } + } + if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) ) + { + tofich(allocationagrif,"endif",1); + } + } + } + parcours = parcours -> suiv; + } + /* Close the file Alloc_agrif */ + fclose(allocationagrif); + fclose(paramtoamr); + } + parcours_nom = parcours_nom -> suiv; + } +} + +void write_allocation_Global_0() +{ + listnom *parcours_nom; + listvar *parcours; + listvar *parcoursprec; + listvar *parcours1; + FILE *allocationagrif; + char ligne[LONG_M]; + char ligne2[LONG_M]; + variable *v; + int IndiceMax; + int IndiceMin; + int compteur; + int out; + int indiceprec; + int ValeurMax; + char initialvalue[LONG_M]; + int typeiswritten ; + + parcoursprec = (listvar *) NULL; + parcours_nom = List_NameOfModule; + ValeurMax = 2; + + while ( parcours_nom ) + { + if ( parcours_nom->o_val == 1 ) + { + IndiceMax = 0; + IndiceMin = indicemaxtabvars[0]; + /* Open the file to create the Alloc_agrif subroutine */ + sprintf(ligne,"alloc_agrif_%s.h",parcours_nom->o_nom); + allocationagrif = open_for_write(ligne); + +// if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 ) +// { +// /* add the call to initworkspace */ +// tofich(allocationagrif,"if (.not. Agrif_Root() ) then",1); +// tofich(allocationagrif,"#include \"GetNumberofcells.h\"\n",0); +// tofich(allocationagrif,"else",1); +// tofich(allocationagrif,"#include \"SetNumberofcells.h\"\n",0); +// tofich(allocationagrif,"endif",1); +// tofich(allocationagrif,"call Agrif_InitWorkspace",1); +// } + + typeiswritten = 0; + parcours = List_Global_Var; + while ( parcours ) + { + if ( !strcasecmp(parcours->var->v_modulename,parcours_nom->o_nom) && + parcours->var->v_VariableIsParameter == 0 && + parcours->var->v_notgrid == 0 ) + { + v = parcours->var; + IndiceMax = 0; + IndiceMin = indicemaxtabvars[v->v_catvar]; + /* body of the file */ + if ( !strcasecmp(v->v_commoninfile,cur_filename) ) + { + if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) ) + { + sprintf(ligne,"if (.not. allocated(%s)) then", vargridnametabvars(v,0)); + tofich(allocationagrif,ligne,1); + } + if ( (v->v_allocatable != 1) && (v->v_dimsempty != 1) ) + { + /* ALLOCATION */ + if ( v->v_dimension != 0 ) + { + if ( v->v_indicetabvars < IndiceMin || v->v_indicetabvars > IndiceMax ) + { + parcours1 = parcours; + compteur = -1; + out = 0; + indiceprec = parcours->var->v_indicetabvars -1 ; + while ( parcours1 && out == 0 + && !strcasecmp(parcours->var->v_readedlistdimension,parcours1->var->v_readedlistdimension) + && !strcasecmp(parcours->var->v_typevar, parcours1->var->v_typevar) + && (parcours1->var->v_indicetabvars == indiceprec+1) ) + { + if ( !strcasecmp(parcours1->var->v_modulename, parcours_nom->o_nom) || + !strcasecmp(parcours1->var->v_commonname, parcours_nom->o_nom) ) + { + compteur = compteur +1 ; + indiceprec = parcours1->var->v_indicetabvars; + parcoursprec = parcours1; + parcours1 = parcours1->suiv; + } + else out = 1; + } + sprintf(ligne,"!! ALLOCATION OF VARIABLE : %s",v->v_nomvar); + tofich(allocationagrif,ligne,1); + if ( compteur > ValeurMax ) + { + sprintf(ligne,"do i = %d,%d", parcours->var->v_indicetabvars, + parcours->var->v_indicetabvars+compteur); + tofich(allocationagrif,ligne,1); + IndiceMin = parcours->var->v_indicetabvars; + IndiceMax = parcours->var->v_indicetabvars+compteur; + sprintf(ligne," allocate(%s", vargridnametabvars(v,1)); + sprintf(ligne2,"%s)", vargridparam(v)); + strcat(ligne,ligne2); + tofich(allocationagrif,ligne,1); + tofich(allocationagrif,"enddo",1); + parcours = parcoursprec; + } + else + { + sprintf(ligne,"allocate(%s", vargridnametabvars(v,0)); + sprintf(ligne2,"%s)", vargridparam(v)); + strcat(ligne,ligne2); + tofich(allocationagrif,ligne,1); + } + } + } /* end of the allocation part */ + /* INITIALISATION */ + if ( strcasecmp(v->v_initialvalue,"") ) + { + strcpy(ligne, vargridnametabvars(v,0)); + /* We should modify the initialvalue in the case of variable has been defined with others variables */ + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Global_Var)); + if ( !strcasecmp(initialvalue,v->v_initialvalue) ) + { + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_Common_Var)); + } + if ( !strcasecmp(initialvalue,v->v_initialvalue) ) + { + strcpy(initialvalue,ChangeTheInitalvaluebyTabvarsName(v->v_initialvalue,List_ModuleUsed_Var)); + } + strcat (ligne," = "); + strcat (ligne,initialvalue); + Save_Length(ligne,48); + tofich(allocationagrif,ligne,1); + } + } + /* Case of structure types */ + if ( (typeiswritten == 0) && !strcasecmp(v->v_typevar,"type") ) + { + sprintf(ligne,"if (.not. allocated(Agrif_%s_var)) then",v->v_modulename); + tofich(allocationagrif, ligne, 1); + sprintf(ligne," allocate(Agrif_%s_var(0:Agrif_NbMaxGrids))",v->v_modulename); + tofich(allocationagrif, ligne, 1); + tofich(allocationagrif, "endif", 1); + typeiswritten = 1; + } + if ( (onlyfixedgrids != 1) && (v->v_nbdim != 0) ) + { + tofich(allocationagrif,"endif",1); + } + } + } + parcours = parcours -> suiv; + } + if ( ModuleIsDefineInInputFile(parcours_nom->o_nom) == 1 ) + { + fprintf(allocationagrif, " if ( .not.Agrif_Root() ) then\n"); + fprintf(allocationagrif, "#include \"GetNumberofcells.h\"\n"); + fprintf(allocationagrif, " else\n"); + fprintf(allocationagrif, "#include \"SetNumberofcells.h\"\n"); + fprintf(allocationagrif, " endif\n"); + fprintf(allocationagrif, " call Agrif_InitWorkspace\n"); + } + fclose(allocationagrif); + } + parcours_nom = parcours_nom -> suiv; + } +} + +/******************************************************************************/ +/* creefichieramr */ +/******************************************************************************/ +/* This subroutine is the main one to create AGRIF_INC files */ +/******************************************************************************/ +/* */ +/******************************************************************************/ +void creefichieramr () +{ + listvar *newvar; + variable *v; + int erreur; + char filefich[LONG_M]; + + int InitEmpty; + int VarnameEmpty; + int donotwrite; + + FILE *initproc; + FILE *initglobal; + FILE *createvarname; + FILE *createvarnameglobal; + + if ( todebug == 1 ) printf("Enter in creefichieramr\n"); + + sprintf(filefich, "cd %s", include_dir); + erreur = system (filefich); + if (erreur) + { + sprintf(filefich, "mkdir -p %s", include_dir); + system(filefich); + printf("%s: Directory created\n", include_dir); + } + +/******************************************************************************/ +/******************** Creation of AGRIF_INC files *****************************/ +/******************************************************************************/ + + if ( todebug == 1 ) + { + const char *NameTampon = "toto"; + sprintf(filefich,"initialisations_agrif_%s.h", NameTampon); + initproc = open_for_write(filefich); + + sprintf(filefich,"createvarname_agrif_%s.h", NameTampon); + createvarname = open_for_write(filefich); + + InitEmpty = 1 ; + VarnameEmpty = 1 ; + + newvar = List_Global_Var; + while ( newvar ) + { + donotwrite = 0; + v = newvar->var; + + if ( ( v->v_common == 1 || v->v_module == 1 ) && donotwrite == 0 ) + { + write_createvarnameagrif_file(v,createvarname,&VarnameEmpty); + write_initialisationsagrif_file(v,initproc,&InitEmpty); + } + newvar = newvar->suiv; + } + fclose (createvarname); + fclose (initproc); + + if ( is_dependfile_created(curmodulename) == 0 ) + { + if ( InitEmpty != 1 ) + { + initglobal = open_for_append("initialisations_agrif.h"); + fprintf(initglobal,"#include \"initialisations_agrif_%s.h\"\n", NameTampon); + fclose(initglobal); + } + if ( VarnameEmpty != 1 ) + { + createvarnameglobal= open_for_append("createvarname_agrif.h"); + fprintf(createvarnameglobal,"#include \"createvarname_agrif_%s.h\"\n", NameTampon); + fclose(createvarnameglobal); + } + } + } + write_allocation_Common_0(); + write_allocation_Global_0(); + + Write_Alloc_Agrif_Files(); + write_probdimagrif_file(); + write_keysagrif_file(); + write_modtypeagrif_file(); + + if ( NbMailleXDefined == 1 ) + { + write_Setnumberofcells_file(); + write_Getnumberofcells_file(); + } + + if ( todebug == 1 ) printf("Out of creefichieramr\n"); +} diff --git a/V4.0/nemo_sources/ext/AGRIF/agrif_oce.in b/V4.0/nemo_sources/ext/AGRIF/agrif_oce.in new file mode 100644 index 0000000000000000000000000000000000000000..0ec33ce2397cb5a8a18815dd826de6aff2d1b552 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/agrif_oce.in @@ -0,0 +1,12 @@ +% Number of cells in each direction % + 2D nbcellsx,nbcellsy; +% Name of the common file : an include file (paramfile) OR a module (parammodule) % + parammodule par_oce ; + +USE ONLY_FIXED_GRIDS; + +% Variables which are not grid dependent % +% notgriddep :: name of the variable; % +notgriddep :: nstop; + +%USE DEBUG;% diff --git a/V4.0/nemo_sources/ext/AGRIF/nemo_mpi.h b/V4.0/nemo_sources/ext/AGRIF/nemo_mpi.h new file mode 100644 index 0000000000000000000000000000000000000000..a7adffa3517c0a675d75dc87c78f2cccd65719d7 --- /dev/null +++ b/V4.0/nemo_sources/ext/AGRIF/nemo_mpi.h @@ -0,0 +1,3 @@ +#if defined key_mpp_mpi +#define AGRIF_MPI +#endif diff --git a/V4.0/nemo_sources/ext/FCM/COPYRIGHT.txt b/V4.0/nemo_sources/ext/FCM/COPYRIGHT.txt new file mode 100644 index 0000000000000000000000000000000000000000..2a74773b436f3152b0799375e209c4ae136a126e --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/LICENSE.html b/V4.0/nemo_sources/ext/FCM/LICENSE.html new file mode 100644 index 0000000000000000000000000000000000000000..f749f397a458318bce8822882936cbfc2b4c0ba7 --- /dev/null +++ b/V4.0/nemo_sources/ext/FCM/LICENSE.html @@ -0,0 +1,154 @@ + + + + + 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/V4.0/nemo_sources/ext/FCM/README b/V4.0/nemo_sources/ext/FCM/README new file mode 100644 index 0000000000000000000000000000000000000000..6a6213df2e1521542a20d98c07b26373e8a88c0a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm b/V4.0/nemo_sources/ext/FCM/bin/fcm new file mode 100755 index 0000000000000000000000000000000000000000..77226857df1050c5c00bbe481f288a25d7c10945 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_graphic_diff b/V4.0/nemo_sources/ext/FCM/bin/fcm_graphic_diff new file mode 100755 index 0000000000000000000000000000000000000000..b96d3d5d0d542a09e5e821e5162f18136f044b70 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_graphic_merge b/V4.0/nemo_sources/ext/FCM/bin/fcm_graphic_merge new file mode 100755 index 0000000000000000000000000000000000000000..992800955386f27b1064d9ade0a7c7de0fd11c43 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_gui b/V4.0/nemo_sources/ext/FCM/bin/fcm_gui new file mode 100755 index 0000000000000000000000000000000000000000..16440809864c80821f0014ac6241e6bfab7ce1d4 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_internal b/V4.0/nemo_sources/ext/FCM/bin/fcm_internal new file mode 100755 index 0000000000000000000000000000000000000000..c477b5d1571c46ff41add2f75e65904b87788bfe --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_setup_konqueror b/V4.0/nemo_sources/ext/FCM/bin/fcm_setup_konqueror new file mode 100755 index 0000000000000000000000000000000000000000..576022f0b191e2704c741b173b37ce8a668aa4de --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/bin/fcm_update_version_dir.pl b/V4.0/nemo_sources/ext/FCM/bin/fcm_update_version_dir.pl new file mode 100755 index 0000000000000000000000000000000000000000..4904295f2ffa6c90444f758380796481b6cb6cac --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/etc/fcm.cfg.eg b/V4.0/nemo_sources/ext/FCM/etc/fcm.cfg.eg new file mode 100644 index 0000000000000000000000000000000000000000..955091fc556cec262b1589d93971a578f51f0d33 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/etc/fcm_gui.desktop b/V4.0/nemo_sources/ext/FCM/etc/fcm_gui.desktop new file mode 100644 index 0000000000000000000000000000000000000000..69bf5fd0eceeb2a088f9087ee072353d8c760e75 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Base.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Base.pm new file mode 100644 index 0000000000000000000000000000000000000000..350e3aa30b4d8b1ac98cf04722bd6f28f3414c26 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Build.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Build.pm new file mode 100644 index 0000000000000000000000000000000000000000..41da76b3f665a27fdb4d64fb8d8eaaeefa6a5aef --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Build/Fortran.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Build/Fortran.pm new file mode 100644 index 0000000000000000000000000000000000000000..618dba8b34b45393300a78c9d538a2df4dc6d10b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/BuildSrc.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/BuildSrc.pm new file mode 100644 index 0000000000000000000000000000000000000000..7a2a0a7a0e45f06ef2d63c2b051e0f010a32e5bd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/BuildTask.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/BuildTask.pm new file mode 100644 index 0000000000000000000000000000000000000000..b5f886e53b741b6284f4d3c3611e3a52d66a32c2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI.pm new file mode 100644 index 0000000000000000000000000000000000000000..8e592d7de475630b595e959c108b93edb14cd28d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Config.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Config.pm new file mode 100644 index 0000000000000000000000000000000000000000..7813cdd24f58732cf900797066d41f254d47234a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Config/Default.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Config/Default.pm new file mode 100644 index 0000000000000000000000000000000000000000..526f54decc69bb6947f72b027662b86892407286 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Exception.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Exception.pm new file mode 100644 index 0000000000000000000000000000000000000000..db1dbc77841ba614b0ea2e433075d1bb22fbfa1c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker.pm new file mode 100644 index 0000000000000000000000000000000000000000..a83238a46a1454e3f6c60488eb4863042e54364c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm new file mode 100644 index 0000000000000000000000000000000000000000..24ca25d18f103cb26d9578fbfad33095315eb9d7 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm new file mode 100644 index 0000000000000000000000000000000000000000..5639705a16f779df2fbd382272f01b05ac99f7eb --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm new file mode 100644 index 0000000000000000000000000000000000000000..be22fcb2623e077e6b77653261cb7fd322cdda5f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/ConfigSystem.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/ConfigSystem.pm new file mode 100644 index 0000000000000000000000000000000000000000..334e39faa0049e4f52f8536b46a2695fccad1bbd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/ExtractConfigComparator.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/ExtractConfigComparator.pm new file mode 100644 index 0000000000000000000000000000000000000000..eebf529f50c66f65efe7ffcb212bd31c0f309f40 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/GUI.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/GUI.pm new file mode 100644 index 0000000000000000000000000000000000000000..e8ba467ad05127018b0b44de160d98d359a5df94 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/Help.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/Help.pm new file mode 100644 index 0000000000000000000000000000000000000000..f6f32346926c08247c5ff658f425c399c42f9d0c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/KeywordPrinter.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Invoker/KeywordPrinter.pm new file mode 100644 index 0000000000000000000000000000000000000000..5cfa544887ae1ceba9f7b266b57134996abf701c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Option.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Option.pm new file mode 100644 index 0000000000000000000000000000000000000000..5a03e447eae4379e0f68a6a21616c761b40d6bdc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Subcommand.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/Subcommand.pm new file mode 100644 index 0000000000000000000000000000000000000000..f54915607e2159a5f8674b74a22135edca57300c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-add.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-add.pod new file mode 100644 index 0000000000000000000000000000000000000000..acd2a125d5e4092f7cdbf97124bc77ca6ea65e4a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-branch.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-branch.pod new file mode 100644 index 0000000000000000000000000000000000000000..d11984b2f0d8c9933ef978b75424805fcba55a03 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-commit.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-commit.pod new file mode 100644 index 0000000000000000000000000000000000000000..6d19012e7fcb2484eb0081b2066a4e35268a0529 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-conflicts.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-conflicts.pod new file mode 100644 index 0000000000000000000000000000000000000000..d4a345373fe51dcf038c6876920946d0d7e9b6b1 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-delete.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-delete.pod new file mode 100644 index 0000000000000000000000000000000000000000..78523567e14559e607cb0a81197ef464b35d9c3b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-diff.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-diff.pod new file mode 100644 index 0000000000000000000000000000000000000000..29168d99c64c71e159abb9e15afe2351f4b638ab --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-merge.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-merge.pod new file mode 100644 index 0000000000000000000000000000000000000000..00a2d1888e512b5924d576f86be90fbb1869d876 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-mkpatch.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-mkpatch.pod new file mode 100644 index 0000000000000000000000000000000000000000..22c8b14c78e85c3ec31ccac0d05577a98e82a77c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-switch.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-switch.pod new file mode 100644 index 0000000000000000000000000000000000000000..18f741775eb589f7924852a4b6f716f9ed2dc47b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-update.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CLI/fcm-update.pod new file mode 100644 index 0000000000000000000000000000000000000000..7a20ad416ed6b9c083228950d1d8e7ee0ab53dac --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CfgFile.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CfgFile.pm new file mode 100644 index 0000000000000000000000000000000000000000..1eeee89dbb1c95107f7099ed8c64b271cda1ba0c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CfgLine.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CfgLine.pm new file mode 100644 index 0000000000000000000000000000000000000000..4a2f710a04b214ccd4ec3257d19c3a2a3c3db166 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Cm.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Cm.pm new file mode 100644 index 0000000000000000000000000000000000000000..55bd30cc1e3fa43dbf0754357670636aefcf4c20 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmBranch.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmBranch.pm new file mode 100644 index 0000000000000000000000000000000000000000..a8908d9acfd239ffeadfcfad64a4688670a98d17 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmCommitMessage.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmCommitMessage.pm new file mode 100644 index 0000000000000000000000000000000000000000..e0407ab15cec053458f6864fb3d7b93924cfb34f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmUrl.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/CmUrl.pm new file mode 100644 index 0000000000000000000000000000000000000000..810aadd80fccd30c6e36587db905f355b0d4f608 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Config.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Config.pm new file mode 100644 index 0000000000000000000000000000000000000000..aacdbf3edd87ee5d34d5670cbdffe3dfc902c416 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/ConfigSystem.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/ConfigSystem.pm new file mode 100644 index 0000000000000000000000000000000000000000..62314253d3b5f486f6644bcf8f7bcc588df68fe2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Dest.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Dest.pm new file mode 100644 index 0000000000000000000000000000000000000000..21e22a2f9c7a20db5d5a3aea4c2ab7a3898afab2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Exception.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Exception.pm new file mode 100644 index 0000000000000000000000000000000000000000..33203096840ffc660151cf045a02f3922314bb38 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Extract.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Extract.pm new file mode 100644 index 0000000000000000000000000000000000000000..f4665eb8e867a19eaf380d112e9bd387123d328c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractConfigComparator.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractConfigComparator.pm new file mode 100644 index 0000000000000000000000000000000000000000..c74ea59a3dd59c5c4e8e64f43e39ff0fb68d371c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractFile.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractFile.pm new file mode 100644 index 0000000000000000000000000000000000000000..7221812510dfaa65a3a39f03fabe9439aa8cddbc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractSrc.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/ExtractSrc.pm new file mode 100644 index 0000000000000000000000000000000000000000..e9b92fae8c8acc09a1c7b367c47264ef483d5851 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive.pm new file mode 100644 index 0000000000000000000000000000000000000000..395206ec8ceae3b9b8d3e4d174362b78adaa1582 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter.pm new file mode 100644 index 0000000000000000000000000000000000000000..3fd77b7c3e495f8d0ffd905c219eaa0fba66a151 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter/CLI.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter/CLI.pm new file mode 100644 index 0000000000000000000000000000000000000000..e7818db34731dcc651447023e2c8c1bc5e92bfba --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter/GUI.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Interactive/InputGetter/GUI.pm new file mode 100644 index 0000000000000000000000000000000000000000..5cd78e073dfa41b807b86d33571f2314c1907731 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword.pm new file mode 100644 index 0000000000000000000000000000000000000000..0a7c9cc6694dd8c8c90d5895c44ef2ec28a427b3 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Config.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Config.pm new file mode 100644 index 0000000000000000000000000000000000000000..23d018ccc97a55b1ed536547dbe08f2b47791b37 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entries.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entries.pm new file mode 100644 index 0000000000000000000000000000000000000000..9bbd0287189bc6f622acb010ace46d3eda4054ed --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entry.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entry.pm new file mode 100644 index 0000000000000000000000000000000000000000..cce065fa713ebb99d6729db6e7dd2e243f2213d0 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entry/Location.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Entry/Location.pm new file mode 100644 index 0000000000000000000000000000000000000000..c7f118f32594616ea7c21a4918b500b312e36497 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Exception.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Exception.pm new file mode 100644 index 0000000000000000000000000000000000000000..95585024ec132481c75bddcdef3f62f25ab3cf3a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entries.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entries.pm new file mode 100644 index 0000000000000000000000000000000000000000..19d6c85c1039305dfcf00aa78b60b8bef74decb9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entry.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entry.pm new file mode 100644 index 0000000000000000000000000000000000000000..55edafc3671ccd7e34c10f3a27c83e8e097fdc97 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entry/Location.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Formatter/Entry/Location.pm new file mode 100644 index 0000000000000000000000000000000000000000..025b88ee621d1b5ca510909990372193c09a44d5 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader.pod b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader.pod new file mode 100644 index 0000000000000000000000000000000000000000..bbdf321dbccb75de624ae64045dfa56b824399aa --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/Config/Location.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/Config/Location.pm new file mode 100644 index 0000000000000000000000000000000000000000..8dedac597a7f4baf48a8f8a16d50f5cb553bccfd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/Config/Revision.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/Config/Revision.pm new file mode 100644 index 0000000000000000000000000000000000000000..3c9d7d314cd20fd59ff17cc8c9b27fe42b8dc46d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/VC/Revision.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Keyword/Loader/VC/Revision.pm new file mode 100644 index 0000000000000000000000000000000000000000..9dfda07050621c6b855e48590d18e95a2c0d0b33 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/ReposBranch.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/ReposBranch.pm new file mode 100644 index 0000000000000000000000000000000000000000..c3a8e4cf680446ed226b6338ef9c300be36eb91e --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/SrcDirLayer.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/SrcDirLayer.pm new file mode 100644 index 0000000000000000000000000000000000000000..bc09fe793dc2a91515ae6968179f9d772437e86c --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Timer.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Timer.pm new file mode 100644 index 0000000000000000000000000000000000000000..3ee720218b0e37af0182cf455bca2cc89f97f1f5 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Util.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Util.pm new file mode 100644 index 0000000000000000000000000000000000000000..c833f496c740d5f53d955b8616d5e221d5fb140f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/lib/Fcm/Util/ClassLoader.pm b/V4.0/nemo_sources/ext/FCM/lib/Fcm/Util/ClassLoader.pm new file mode 100644 index 0000000000000000000000000000000000000000..c9b04702648164752fb7c27f1c9a23b5186caf9b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/man/man1/fcm.1 b/V4.0/nemo_sources/ext/FCM/man/man1/fcm.1 new file mode 100644 index 0000000000000000000000000000000000000000..ad5ecea73f1b5a14385c1eb9ee7e371679385159 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran-extract-interface-result.f90 b/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran-extract-interface-result.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0ca000634d4b2a21d1f0f2de6a43cf2295183c04 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran-extract-interface-source.f90 b/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran-extract-interface-source.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6f22252af8f68d1e9da97a89eab8ca13af77a887 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Build/Fortran.t new file mode 100644 index 0000000000000000000000000000000000000000..e91b51a4b2ffa297b81bbc66c64bfd1c36e41175 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI.t new file mode 100755 index 0000000000000000000000000000000000000000..ae28d0d12b7a4858a4a7c105efa4a4ef1d3753f7 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Config.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Config.t new file mode 100755 index 0000000000000000000000000000000000000000..0f79b001b632445e5b32ef537e7890fcdeddd93f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Config/Default.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Config/Default.t new file mode 100755 index 0000000000000000000000000000000000000000..e7ed087a92a53b02949d104ab907ad8ff84ef82b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Exception.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Exception.t new file mode 100755 index 0000000000000000000000000000000000000000..8e6131caf648def8c7af7b0ccdd4a9bfcff4a28a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker.t new file mode 100755 index 0000000000000000000000000000000000000000..ea7aba4a01fe05c88f1a3164661e6610f6787f8a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/Browser.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/Browser.t new file mode 100755 index 0000000000000000000000000000000000000000..7fa712a930a64414cf1978243701e419385b1a07 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/CM.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/CM.t new file mode 100755 index 0000000000000000000000000000000000000000..a514e551274cd2e65d16a4e6c0dba498275782f9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/CfgPrinter.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/CfgPrinter.t new file mode 100755 index 0000000000000000000000000000000000000000..064813723d13510e59d394e24a7ae907ca56204a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/ConfigSystem.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/ConfigSystem.t new file mode 100755 index 0000000000000000000000000000000000000000..cd2745ade5238a44e6aa7a046f24aed22804b2bd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/ExtractConfigComparator.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/ExtractConfigComparator.t new file mode 100755 index 0000000000000000000000000000000000000000..1eb40daeed21144a24fcc22de4593b8427140803 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/GUI.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/GUI.t new file mode 100755 index 0000000000000000000000000000000000000000..fd51538e0972ff22cc3395114ba4de8471986616 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/Help.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/Help.t new file mode 100755 index 0000000000000000000000000000000000000000..fdf22bc9c31dd9484d87b22fa209bae87e94cea5 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/KeywordPrinter.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Invoker/KeywordPrinter.t new file mode 100755 index 0000000000000000000000000000000000000000..c65afd2cd871c641553ccc6c0314d303043eb7ca --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Option.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Option.t new file mode 100755 index 0000000000000000000000000000000000000000..847263fe076cb312004a41b94caaa8c872608ec0 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Subcommand.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/CLI/Subcommand.t new file mode 100755 index 0000000000000000000000000000000000000000..22c6c885f194bc0b4675c7024af0b40c929f0f93 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/ConfigSystem.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/ConfigSystem.t new file mode 100644 index 0000000000000000000000000000000000000000..f02cf017b35701ff88fb4b554ecf388074c0fd32 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Exception.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Exception.t new file mode 100755 index 0000000000000000000000000000000000000000..5f3d7ffafecdb5fc555bb7de57fdc3a58eb23e2d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/ExtractConfigComparator.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/ExtractConfigComparator.t new file mode 100755 index 0000000000000000000000000000000000000000..ee3c0ba602ff0fb76d660a64f8f089537a77a30d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive.t new file mode 100755 index 0000000000000000000000000000000000000000..c845bb2f639171ba86896591e232bc559d5415b1 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter.t new file mode 100755 index 0000000000000000000000000000000000000000..9dc3dafb4090782f1eceda7043015df2d309556e --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter/CLI.pm b/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter/CLI.pm new file mode 100755 index 0000000000000000000000000000000000000000..069396a4b19a119a0a6eb0bab7859722af497b26 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter/GUI.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Interactive/InputGetter/GUI.t new file mode 100755 index 0000000000000000000000000000000000000000..1c8aae4f3a7c9354bca372bf7151c44f827da651 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword.t new file mode 100755 index 0000000000000000000000000000000000000000..cb069ddf03c70b736a57d3f93a6e4cd6611ea891 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Config.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Config.t new file mode 100755 index 0000000000000000000000000000000000000000..da3e1e05fc828c79d9ac1cf2003b7cdf9851f79e --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entries.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entries.t new file mode 100755 index 0000000000000000000000000000000000000000..d1c919f8effa37cc43baddbd42a376b1502eedb8 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entry.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entry.t new file mode 100644 index 0000000000000000000000000000000000000000..bccc5273c791f623128da93831f7d24f47ae5ff2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entry/Location.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Entry/Location.t new file mode 100755 index 0000000000000000000000000000000000000000..36976a264f663cad4726a9c73f60fb6e4318a83b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Exception.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Exception.t new file mode 100755 index 0000000000000000000000000000000000000000..5a64cf6a4bcc5b0bfbbe1e689101232aeafa03d9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entries.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entries.t new file mode 100755 index 0000000000000000000000000000000000000000..27470e2ae0bf81ac2d2c0f1f1d528041cf51df25 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entry.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entry.t new file mode 100755 index 0000000000000000000000000000000000000000..58b7dd25791e621a35b298dc3ca9a4658a517021 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entry/Location.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Formatter/Entry/Location.t new file mode 100755 index 0000000000000000000000000000000000000000..d263e3f88a834568e9436e00810e6b50c2c6f379 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/Config/Location.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/Config/Location.t new file mode 100755 index 0000000000000000000000000000000000000000..23332e3545c5746bfa59e467c3752ae0bc46d0fd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/Config/Revision.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/Config/Revision.t new file mode 100755 index 0000000000000000000000000000000000000000..d70cb91534388a325ec980b557344185101eee00 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.dump b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.dump new file mode 100644 index 0000000000000000000000000000000000000000..5439074896b783f0f748a61611ae29574b38a5ab --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.t new file mode 100755 index 0000000000000000000000000000000000000000..559f370978069be0da16dd8b60c1d08e87e72449 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Util.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Util.t new file mode 100755 index 0000000000000000000000000000000000000000..d32d2ffe3780183bab12ef556a7a2134e5746d01 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/FCM/t/Fcm/Util/ClassLoader.t b/V4.0/nemo_sources/ext/FCM/t/Fcm/Util/ClassLoader.t new file mode 100644 index 0000000000000000000000000000000000000000..0cb6514aa32d26e31ef352fbdc271ea1d6d98998 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/IOIPSL_License_CeCILL.txt b/V4.0/nemo_sources/ext/IOIPSL/IOIPSL_License_CeCILL.txt new file mode 100644 index 0000000000000000000000000000000000000000..784fc1a288a84b3913c0df97805199c98129fc86 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/calendar.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/calendar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4d6a880ad0f53c7bde7bd912d6b272e191457283 --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/calendar.f90 @@ -0,0 +1,1100 @@ +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 + USE ioipsl_par_kind, ONLY : wp, dp, sp +!- + 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 ymds2ju + MODULE PROCEDURE ymds2ju_dp, ymds2ju_sp + END INTERFACE +!- + INTERFACE ju2ymds + MODULE PROCEDURE ju2ymds_dp, ju2ymds_sp + END INTERFACE +!- + 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(wp),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(wp),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(wp),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_dp (year,month,day,sec,julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL(dp),INTENT(IN) :: sec +!- + REAL(dp),INTENT(OUT) :: julian +!- + INTEGER :: julian_day + REAL(sp) :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,REAL(sec,sp),julian_day,julian_sec) +!- + julian = julian_day+julian_sec/one_day +!--------------------- +END SUBROUTINE ymds2ju_dp +!- +!=== +!- +SUBROUTINE ymds2ju_sp (year,month,day,sec,julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL(sp),INTENT(IN) :: sec +!- + REAL(sp),INTENT(OUT) :: julian +!- + INTEGER :: julian_day + REAL(sp) :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!- + julian = julian_day+julian_sec/one_day +!--------------------- +END SUBROUTINE ymds2ju_sp +!- +!=== +!- +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(sp),INTENT(IN) :: sec +!- + INTEGER,INTENT(OUT) :: julian_day + REAL(sp),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_dp (julian,year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL(dp),INTENT(IN) :: julian +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL(dp),INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL(dp) :: julian_sec + REAL(sp) :: sec_sp +!--------------------------------------------------------------------- + julian_day = INT(julian) + julian_sec = (julian-julian_day)*one_day +!- + CALL ju2ymds_internal(julian_day,REAL(julian_sec,sp),year,month,day,sec_sp) + sec = sec_sp +!--------------------- +END SUBROUTINE ju2ymds_dp +!- +!=== +!- +SUBROUTINE ju2ymds_sp (julian,year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL(sp),INTENT(IN) :: julian +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL(sp),INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL(sp) :: 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_sp +!- +!=== +!- +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(sp),INTENT(IN) :: julian_sec +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL(sp),INTENT(OUT) :: sec +!- + INTEGER :: l,n,i,jd,j,d,m,y,ml + INTEGER :: add_day + REAL(sp) :: 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(wp),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(wp) :: 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(wp) 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(wp) :: date0,deltat +!--------------------------------------------------------------------- + itau2date = REAL(itau,wp)*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(wp),INTENT(IN) :: deltat +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL(wp),INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL(sp) :: julian_sec + REAL(sp) :: sec_sp +!--------------------------------------------------------------------- + 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,wp)*deltat + CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec_sp) + sec = sec_sp +!----------------------- +END SUBROUTINE itau2ymds +!- +!=== +!- +REAL(wp) 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(wp),INTENT(IN) :: date0,old_dt,new_dt +!- + REAL(wp) :: rtime +!--------------------------------------------------------------------- + rtime = itau2date (itau,date0,old_dt) + dtchdate = rtime-REAL(itau,wp)*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(wp),INTENT(IN) :: dt,freq + INTEGER,INTENT(IN) :: last_action,last_check + REAL(wp),INTENT(IN) :: date0 +!- + LOGICAL,INTENT(OUT) :: do_action +!- + REAL(wp) :: dt_action,dt_check + REAL(wp) :: 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(wp) :: 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(wp),INTENT(IN) :: julian +!- + INTEGER :: julian_day + REAL(wp) :: 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(wp),INTENT(IN) :: sec +!- + INTEGER :: julian_day + REAL(sp) :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,REAL(sec,sp),julian_day,julian_sec) +!- + CALL ioconf_startdate_internal (julian_day,REAL(julian_sec,wp)) +!----------------------------------- +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(wp),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(wp),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(wp),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(wp),INTENT(IN) :: sec_s +!- +! Time in seconds to be added to the date +!- + REAL(wp),INTENT(IN) :: sec_increment +!- + INTEGER,INTENT(OUT) :: year_e,month_e,day_e + REAL(wp),INTENT(OUT) :: sec_e +!- + INTEGER :: julian_day + REAL(sp) :: julian_sec + REAL(sp) :: sec_e_sp +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,REAL(sec_s,sp),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_sp) + sec_e = sec_e_sp +!---------------------- +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(wp),INTENT(IN) :: sec_s + INTEGER,INTENT(IN) :: year_e,month_e,day_e + REAL(wp),INTENT(IN) :: sec_e +!- +! Time in seconds between the two dates +!- + REAL(wp),INTENT(OUT) :: sec_diff +!- + INTEGER :: julian_day_s,julian_day_e,day_diff + REAL(sp) :: julian_sec_s,julian_sec_e +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,REAL(sec_s,sp),julian_day_s,julian_sec_s) + CALL ymds2ju_internal & + & (year_e,month_e,day_e,REAL(sec_e,sp),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/V4.0/nemo_sources/ext/IOIPSL/src/defprec.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/defprec.f90 new file mode 100644 index 0000000000000000000000000000000000000000..67cda8f784a9b279dc03e4e24ce26c1c9cdf45e0 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/errioipsl.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/errioipsl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d9ca60ea28b648969d36bb89612fa71c4fdaaf6f --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/flincom.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/flincom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..11fd96b7a79d1a52d3a62c836a3921d06efecfb0 --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/flincom.f90 @@ -0,0 +1,1940 @@ +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 + USE ioipsl_par_kind, ONLY : wp +!- + 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(wp) :: lon1(iim1,jjm1) + REAL(wp) :: lat1(iim1,jjm1) + REAL(wp) :: lev1(llm1) + INTEGER :: itaus(ttm1) + REAL(wp) :: time0 + REAL(wp) :: dt + INTEGER :: fid_out, zdimid1, nlonid1, nlatid1, tdimid1 +!- +! LOCAL +!- + INTEGER :: iret, lll, fid + INTEGER :: lonid, latid, levid, timeid + INTEGER :: year, month, day + REAL(wp) :: 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),wp)) +!- + 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(wp) :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL(wp) :: 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(wp) :: lon(iim,jjm), lat(iim,jjm), lev(llm) + INTEGER :: itaus(ttm) + REAL(wp) :: 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(wp) :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL(wp) :: date0, dt + INTEGER :: fid_out +!- +! LOCAL +!- + REAL(wp), 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(wp) :: x_first, x_last + INTEGER :: year, month, day + REAL(wp) :: r_year, r_month, r_day + INTEGER :: year0, month0, day0, hours0, minutes0, seci + REAL(wp) :: sec, sec0 + CHARACTER :: strc +!- + REAL(wp),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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: var(:) +!- + INTEGER :: jl, ji + REAL(wp),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(wp) :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL(wp),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(wp) :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL(wp),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(wp) :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL(wp),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(wp) :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL(wp),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(wp) :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL(wp),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(wp) :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL(wp),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(wp) :: 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(wp),SAVE :: mis_v=0. + REAL(wp) :: tmp_r + INTEGER :: ndims, x_typ, nb_atts + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids + INTEGER :: i, nvars, i2d, cnd + REAL(wp),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(wp) :: 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/V4.0/nemo_sources/ext/IOIPSL/src/fliocom.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/fliocom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ab89b01a51059af6d503244cf43a3e7b17b11c10 --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/fliocom.f90 @@ -0,0 +1,5186 @@ +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 +USE ioipsl_par_kind, ONLY : wp +!- +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(wp),DIMENSION(:),OPTIONAL,INTENT(IN) :: x_axis,y_axis + REAL(wp),DIMENSION(:,:),OPTIONAL,INTENT(IN) :: x_axis_2d,y_axis_2d + REAL(wp),DIMENSION(:),OPTIONAL,INTENT(IN) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: t_axis + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: t_calendar + REAL(wp),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(wp) :: 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(:),wp)) + 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(wp),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(wp),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(wp),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(wp),DIMENSION(:),OPTIONAL,INTENT(OUT) :: x_axis,y_axis + REAL(wp),DIMENSION(:,:),OPTIONAL,INTENT(OUT) :: x_axis_2d,y_axis_2d + REAL(wp),DIMENSION(:),OPTIONAL,INTENT(OUT) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: t_axis + REAL(wp),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(wp) :: 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(wp),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(wp) :: tmp_r + INTEGER,DIMENSION(:),ALLOCATABLE :: tma_i + REAL(wp),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,ip + CHARACTER(LEN=6) :: 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 + IF (d_n_t(iw)<10000) THEN + WRITE(str,'(I4.4)') d_n_c(iw) + ip=4 + ELSEIF (d_n_t(iw)<100000) THEN + WRITE(str,'(I5.5)') d_n_c(iw) + ip=5 + ELSEIF (d_n_t(iw)<1000000) THEN + WRITE(str,'(I6.6)') d_n_c(iw) + ip=6 + ELSE + WRITE(0,*)'Too many domains in flio_dom_file',d_d_n(iw) + CALL abort + ENDIF + il = INDEX(f_n,'.nc') + f_n = f_n(1:il-1)//'_'//str(1:ip)//'.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/V4.0/nemo_sources/ext/IOIPSL/src/getincom.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/getincom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7f8d6fcfac935b80ec63cee60af37a0e671ee48 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/histcom.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/histcom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a522cef2321a95a18d2eaa626bc948f45145e51d --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/histcom.f90 @@ -0,0 +1,2502 @@ +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 + USE ioipsl_par_kind, ONLY : wp +!- + 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(wp),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(wp),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(wp),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(wp) :: freq_opp,freq_wrt + INTEGER :: & + & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt +!- For future optimization + REAL(wp),POINTER,DIMENSION(:) :: t_bf +!# REAL(wp),ALLOCATABLE,DIMENSION(:) :: V_1_D +!# REAL(wp),ALLOCATABLE,DIMENSION(:,:) :: V_2_D +!# REAL(wp),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(wp) :: 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(wp),DIMENSION(pim),INTENT(IN) :: plon + REAL(wp),DIMENSION(pjm),INTENT(IN) :: plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL(wp),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(wp),DIMENSION(pim,pjm),INTENT(IN) :: plon,plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL(wp),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(wp),DIMENSION(pim),INTENT(IN) :: plon,plat + REAL(wp),DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds + INTEGER,INTENT(IN) :: pitau0 + REAL(wp),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(wp),INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + REAL(wp),DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL(wp),DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy + REAL(wp),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(wp),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(wp),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(wp),DIMENSION(:),INTENT(IN) :: plon,plat + REAL(wp),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(wp),DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL(wp),DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + REAL(wp),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(wp),ALLOCATABLE,DIMENSION(:,:) :: bounds_trans + REAL(wp) :: 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(wp),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(wp),INTENT(IN) :: pfreq_opp,pfreq_wrt + REAL(wp),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(wp) :: 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(wp) :: sec + REAL(wp) :: 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(wp),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(wp),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(wp),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(wp),DIMENSION(:),INTENT(IN),OPTIONAL :: pdata_1d + REAL(wp),DIMENSION(:,:),INTENT(IN),OPTIONAL :: pdata_2d + REAL(wp),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(wp),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(wp),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(wp) :: rtime + REAL(wp),DIMENSION(2) :: t_bnd + CHARACTER(LEN=7) :: tmp_opp + REAL(wp),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/V4.0/nemo_sources/ext/IOIPSL/src/ioipsl.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/ioipsl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99076239a3ec42767da20b274f35a3bc2dc3a2fc --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/ioipsl_par_kind.F90 b/V4.0/nemo_sources/ext/IOIPSL/src/ioipsl_par_kind.F90 new file mode 100644 index 0000000000000000000000000000000000000000..44e6c3ea5754a980bd211a0bc4c14c7b5007b2d8 --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/ioipsl_par_kind.F90 @@ -0,0 +1,26 @@ +MODULE ioipsl_par_kind +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- This file defines the working precision for the IOIPSL library. It +!- was copied from OCE/par_kind.F90 + IMPLICIT NONE + PRIVATE + + ! Number model from which the SELECTED_*_KIND are requested: + ! 4 byte REAL 8 byte REAL + ! CRAY: - precision = 13 + ! exponent = 2465 + ! IEEE: precision = 6 precision = 15 + ! exponent = 37 exponent = 307 + + ! !!** Floating point ** + INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4) + INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8) +# if defined key_single + INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision +# else + INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision +# endif +END MODULE ioipsl_par_kind diff --git a/V4.0/nemo_sources/ext/IOIPSL/src/mathelp.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/mathelp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ed7d1e9fd0658cacf9bfec15ccd2daa962469c4a --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/mathelp.f90 @@ -0,0 +1,3154 @@ +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 + USE ioipsl_par_kind, ONLY : wp +!- + 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(wp),INTENT(IN) :: fill_val + REAL(wp),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(wp),INTENT(IN) :: fill_val + CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps + REAL(wp),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,wp) + 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(wp) :: work_in(nb),scal,miss_val + REAL(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: work_in(nb(1),nb(2)),scal,miss_val + REAL(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: work_in(nb(1),nb(2),nb(3)),scal,miss_val + REAL(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp),DIMENSION(:) :: px,py + INTEGER :: pwx + INTEGER :: i + REAL(wp) :: invpwxp1 +!--------------------------------------------------------------------- + IF (pwx /= 0) THEN + IF (opp == 'ave') THEN + invpwxp1=1.0_wp/REAL(pwx+1,wp) +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=(px(i)*pwx+py(i))*invpwxp1 + END DO +!$OMP END PARALLEL DO + ELSE IF (opp == 't_sum') THEN +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=px(i)+py(i) + END DO +!$OMP END PARALLEL DO + ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=MIN(px(i),py(i)) + END DO +!$OMP END PARALLEL DO + ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=MAX(px(i),py(i)) + END DO +!$OMP END PARALLEL DO + ELSE + CALL ipslerr(3,"moycum",'Unknown time operation',opp,' ') + ENDIF + ELSE + IF (opp == 'l_min') THEN +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=MIN(px(i),py(i)) + END DO +!$OMP END PARALLEL DO + ELSE IF (opp == 'l_max') THEN +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=MAX(px(i),py(i)) + END DO +!$OMP END PARALLEL DO + ELSE +!$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i) + DO i=1, np + px(i)=py(i) + END DO +!$OMP END PARALLEL DO + ENDIF + ENDIF +!-------------------- +END SUBROUTINE moycum +!=== +!----------------- +END MODULE mathelp diff --git a/V4.0/nemo_sources/ext/IOIPSL/src/nc4interface.F90 b/V4.0/nemo_sources/ext/IOIPSL/src/nc4interface.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9f34d4870a9912202feb5532fba51616393e1c03 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/src/restcom.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/restcom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2ca06e5a0b0783e4c35adc84483f7362895f479a --- /dev/null +++ b/V4.0/nemo_sources/ext/IOIPSL/src/restcom.f90 @@ -0,0 +1,2547 @@ +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 +USE ioipsl_par_kind, ONLY : wp +!- +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(wp),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(wp),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(wp),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(wp),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(wp),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(wp) :: lon(iim,jjm),lat(iim,jjm),lev(llm) + REAL(wp) :: date0,dt + LOGICAL,OPTIONAL :: owrite_time_in + INTEGER,INTENT(IN),OPTIONAL :: domain_id +!- + INTEGER :: ncfid + REAL(wp) :: 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(wp) :: 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(wp) :: lon_read(iim,jjm),lat_read(iim,jjm) + REAL(wp) :: lev_read(llm) + REAL(wp) :: 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(wp) :: 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(wp) :: 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,wp) + 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,wp) + 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(wp) :: date,timestep + REAL(wp) :: 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(wp) :: 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(wp) :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL(wp) :: 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(wp) :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,var_sz,siz1 + REAL(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL(wp) :: 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(wp) :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,siz1 + REAL(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: 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(wp) :: var(:) +!- + INTEGER :: iret,vid,ncid,iv,vnb + INTEGER :: ierr + REAL(wp) :: 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(wp),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(wp) :: 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(wp) :: 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/V4.0/nemo_sources/ext/IOIPSL/src/stringop.f90 b/V4.0/nemo_sources/ext/IOIPSL/src/stringop.f90 new file mode 100644 index 0000000000000000000000000000000000000000..89be0ee43d79b3be753a9a14f8b3868b0b58bced --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/Fparser.f90 b/V4.0/nemo_sources/ext/IOIPSL/tools/Fparser.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d42469aae58c2e3fe212171bb6961a7c56bc7c66 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/flio_rbld.f90 b/V4.0/nemo_sources/ext/IOIPSL/tools/flio_rbld.f90 new file mode 100644 index 0000000000000000000000000000000000000000..39aabc879e89ef3ca92f4bfe13d5a8a8596f9efb --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/ncregular.f90 b/V4.0/nemo_sources/ext/IOIPSL/tools/ncregular.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1f53f959ce861b7e8f0f18cc9665c44a0f508562 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/ncunderflow.f90 b/V4.0/nemo_sources/ext/IOIPSL/tools/ncunderflow.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3d4655e00d203f4b1b84659fc262e2515894b564 --- /dev/null +++ b/V4.0/nemo_sources/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 coordonnes + 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/V4.0/nemo_sources/ext/IOIPSL/tools/rebuild b/V4.0/nemo_sources/ext/IOIPSL/tools/rebuild new file mode 100755 index 0000000000000000000000000000000000000000..f05d39a515b96a8df647bb82afc8de69436241cd --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/tkcond.c b/V4.0/nemo_sources/ext/IOIPSL/tools/tkcond.c new file mode 100644 index 0000000000000000000000000000000000000000..b7afe836af67c062ea69b3ecaa6ab1f336f1ef3a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/tkgen.c b/V4.0/nemo_sources/ext/IOIPSL/tools/tkgen.c new file mode 100644 index 0000000000000000000000000000000000000000..b42ea20b6db4dafabe6a13a0ff383430c9fde539 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/tkparse.c b/V4.0/nemo_sources/ext/IOIPSL/tools/tkparse.c new file mode 100644 index 0000000000000000000000000000000000000000..b84ae8eb66cb099af0f13dc277625d21336028fa --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/ext/IOIPSL/tools/tkparse.h b/V4.0/nemo_sources/ext/IOIPSL/tools/tkparse.h new file mode 100644 index 0000000000000000000000000000000000000000..911abdfbee438b024bc06d339eab4e8ccb5bc683 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/makenemo b/V4.0/nemo_sources/makenemo new file mode 100755 index 0000000000000000000000000000000000000000..e078235aea6db9c8766b8543a716f64e75db8b1a --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fadd_keys.sh b/V4.0/nemo_sources/mk/Fadd_keys.sh new file mode 100755 index 0000000000000000000000000000000000000000..0aa554c15df66e92120bcce861e7b966f3cbcffe --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fcheck_archfile.sh b/V4.0/nemo_sources/mk/Fcheck_archfile.sh new file mode 100755 index 0000000000000000000000000000000000000000..1768f1239128447183539080318bdc454ee3c2cb --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fcheck_config.sh b/V4.0/nemo_sources/mk/Fcheck_config.sh new file mode 100755 index 0000000000000000000000000000000000000000..996047f5989afaf7a2c4fa08f9b0384c01341c97 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fcheck_script.sh b/V4.0/nemo_sources/mk/Fcheck_script.sh new file mode 100755 index 0000000000000000000000000000000000000000..cd29beb4f58a4826b7dfa495abcc8264867018d2 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fclean_config.sh b/V4.0/nemo_sources/mk/Fclean_config.sh new file mode 100755 index 0000000000000000000000000000000000000000..6cb4a83a2661d43d48175cca0abe22d243f18758 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fclean_var.sh b/V4.0/nemo_sources/mk/Fclean_var.sh new file mode 100755 index 0000000000000000000000000000000000000000..eb624c7140dcd11cd8028d08e61ba993cb8aec9d --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fcopy_dir.sh b/V4.0/nemo_sources/mk/Fcopy_dir.sh new file mode 100755 index 0000000000000000000000000000000000000000..e807ef6364a2a0e7ec458e06ec81da90aa190f37 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fcopy_extdir.sh b/V4.0/nemo_sources/mk/Fcopy_extdir.sh new file mode 100755 index 0000000000000000000000000000000000000000..8ee08edefacfcb3f28f93c1bcd39f6c68d841243 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fdel_keys.sh b/V4.0/nemo_sources/mk/Fdel_keys.sh new file mode 100755 index 0000000000000000000000000000000000000000..88aafc23d7ec665292d2feb7782d2ef6a6539aed --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Ffetch_extdir.sh b/V4.0/nemo_sources/mk/Ffetch_extdir.sh new file mode 100755 index 0000000000000000000000000000000000000000..9726a5f4045c9fe2453f4d9288b2e7256ceaa914 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fgo_to_TOOLS.sh b/V4.0/nemo_sources/mk/Fgo_to_TOOLS.sh new file mode 100755 index 0000000000000000000000000000000000000000..33f070d83c77c3babcfaa21f2f8cc74f72d6ac2b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Flist_archfile.sh b/V4.0/nemo_sources/mk/Flist_archfile.sh new file mode 100755 index 0000000000000000000000000000000000000000..46c570beeeff3c51560b9e007bacaf5daf9a1f77 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Flist_cfgs.sh b/V4.0/nemo_sources/mk/Flist_cfgs.sh new file mode 100755 index 0000000000000000000000000000000000000000..8a19b67d80a34c40685971370b92c0251a5a5c67 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fmake_WORK.sh b/V4.0/nemo_sources/mk/Fmake_WORK.sh new file mode 100755 index 0000000000000000000000000000000000000000..a2b44d2215e5a849f0263de426c17a1d81ed7ce1 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fmake_bld.sh b/V4.0/nemo_sources/mk/Fmake_bld.sh new file mode 100755 index 0000000000000000000000000000000000000000..53d9f7e3c4805236d97bbf1c5ae6ddfaf8da41fb --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fmake_config.sh b/V4.0/nemo_sources/mk/Fmake_config.sh new file mode 100755 index 0000000000000000000000000000000000000000..12babc427d21473911ac6d2727e3f99eaf924b61 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fprep_agrif.sh b/V4.0/nemo_sources/mk/Fprep_agrif.sh new file mode 100755 index 0000000000000000000000000000000000000000..f37b17f0c9a1cdc028e617b75fc4ca651da0450b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/Fread_dir.sh b/V4.0/nemo_sources/mk/Fread_dir.sh new file mode 100755 index 0000000000000000000000000000000000000000..2e92921abff7c117ac525cb4eed4f1437c5774d6 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/README b/V4.0/nemo_sources/mk/README new file mode 100644 index 0000000000000000000000000000000000000000..b54b12daf77e46b58af9488588f8defd5a668104 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/agrifpp.sh b/V4.0/nemo_sources/mk/agrifpp.sh new file mode 100755 index 0000000000000000000000000000000000000000..ca8f40b4b968a1be8bffb00f426ad31ee7d3c924 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/arch.history b/V4.0/nemo_sources/mk/arch.history new file mode 100644 index 0000000000000000000000000000000000000000..88d10314093143e602ee17abd441eaa48c0f9059 --- /dev/null +++ b/V4.0/nemo_sources/mk/arch.history @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/model_sources_mixed/arch/arch-mn4.fcm diff --git a/V4.0/nemo_sources/mk/arch_nemo.fcm b/V4.0/nemo_sources/mk/arch_nemo.fcm new file mode 100644 index 0000000000000000000000000000000000000000..7eb596553d13f0fe10aa2aa3c315fa1d6b9223d0 --- /dev/null +++ b/V4.0/nemo_sources/mk/arch_nemo.fcm @@ -0,0 +1,43 @@ + +#========================================================== +# Automatically generated by Fcheck_archfile.sh from +# /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/model_sources_mixed/arch/arch-mn4.fcm +#========================================================== + +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/nemo_sources/mk/bld.cfg b/V4.0/nemo_sources/mk/bld.cfg new file mode 100644 index 0000000000000000000000000000000000000000..34a35d76fc0e0e39287908be2557741c6db93227 --- /dev/null +++ b/V4.0/nemo_sources/mk/bld.cfg @@ -0,0 +1,72 @@ +# ----------------------- 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 + +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + diff --git a/V4.0/nemo_sources/mk/bld_preproagr.cfg b/V4.0/nemo_sources/mk/bld_preproagr.cfg new file mode 100644 index 0000000000000000000000000000000000000000..f2a749eb98e2f1ce221b0d42f561ab3482d57675 --- /dev/null +++ b/V4.0/nemo_sources/mk/bld_preproagr.cfg @@ -0,0 +1,86 @@ +# ----------------------- 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 + +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + diff --git a/V4.0/nemo_sources/mk/bld_tools.cfg b/V4.0/nemo_sources/mk/bld_tools.cfg new file mode 100644 index 0000000000000000000000000000000000000000..3f4c876fad4da4998542c5fa782991b802a6a76d --- /dev/null +++ b/V4.0/nemo_sources/mk/bld_tools.cfg @@ -0,0 +1,52 @@ +# ----------------------- 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 + +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + diff --git a/V4.0/nemo_sources/mk/bldxag.cfg b/V4.0/nemo_sources/mk/bldxag.cfg new file mode 100644 index 0000000000000000000000000000000000000000..fb1ba9c204062c3ce9701791e62a4136ec0fe1a8 --- /dev/null +++ b/V4.0/nemo_sources/mk/bldxag.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::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 + + +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + diff --git a/V4.0/nemo_sources/mk/conv.cfg b/V4.0/nemo_sources/mk/conv.cfg new file mode 100644 index 0000000000000000000000000000000000000000..f281105e3f12148259696bada1bfec62308ed1b9 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/mk/cpp.fcm b/V4.0/nemo_sources/mk/cpp.fcm new file mode 120000 index 0000000000000000000000000000000000000000..e5741cbcc06091472f2e0c76de3d52b39be0c32f --- /dev/null +++ b/V4.0/nemo_sources/mk/cpp.fcm @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA1_OCE_ICE_MIXED_ORIGINAL/cpp_ORCA1_OCE_ICE_MIXED_ORIGINAL.fcm \ No newline at end of file diff --git a/V4.0/nemo_sources/mk/cpp.history b/V4.0/nemo_sources/mk/cpp.history new file mode 100644 index 0000000000000000000000000000000000000000..d4eedeef880f93cfe1435676a0fe3223ba2570f8 --- /dev/null +++ b/V4.0/nemo_sources/mk/cpp.history @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA1_OCE_ICE_MIXED_ORIGINAL/cpp_ORCA1_OCE_ICE_MIXED_ORIGINAL.fcm diff --git a/V4.0/nemo_sources/mk/full_key_list.txt b/V4.0/nemo_sources/mk/full_key_list.txt new file mode 100644 index 0000000000000000000000000000000000000000..8deb62da11af17b8e1e409d3f94fddad588575c4 --- /dev/null +++ b/V4.0/nemo_sources/mk/full_key_list.txt @@ -0,0 +1,30 @@ +key_agrif +key_asminc +key_c1d +key_cice +key_cice4 +key_cyclone +key_diahth_notworking +key_diainstant +key_dr_hook +key_iomput +key_iomput_sglexe +key_mpi2 +key_mpp_mpi +key_mpp_shmem +key_multio +key_nemocice_decomp +key_netcdf4 +key_nosignedzero +key_oa3mct_v1v2 +key_oasis3 +key_parinter_alloc +key_si3 +key_single +key_sms +key_top +key_tradmp +key_trdmxl_trc +key_trdtrc +key_vectopt_loop +key_xios2 diff --git a/V4.0/nemo_sources/mk/tools.txt b/V4.0/nemo_sources/mk/tools.txt new file mode 100644 index 0000000000000000000000000000000000000000..a6cb4ae56b20f855dbc4148c15c13a766f9114ea --- /dev/null +++ b/V4.0/nemo_sources/mk/tools.txt @@ -0,0 +1 @@ +DOMAINcfg diff --git a/V4.0/nemo_sources/src/ICE/ice.F90 b/V4.0/nemo_sources/src/ICE/ice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..380d6adce961815d22c255e5379dacfa302e3ff8 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/ice.F90 @@ -0,0 +1,533 @@ +MODULE ice + !!====================================================================== + !! *** MODULE ice *** + !! sea-ice: ice variables defined in memory + !!====================================================================== + !! History : 3.0 ! 2008-03 (M. Vancoppenolle) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_alloc ! called by icestp.F90 + + !!====================================================================== + !! | + !! I C E S T A T E V A R I A B L E S | + !! | + !! Introduction : | + !! -------------- | + !! Every ice-covered grid cell is characterized by a series of state | + !! variables. To account for unresolved spatial variability in ice | + !! thickness, the ice cover in divided in ice thickness categories. | + !! | + !! Sea ice state variables depend on the ice thickness category | + !! | + !! Those variables are divided into two groups | + !! * Extensive (or global) variables. | + !! These are the variables that are transported by all means | + !! * Intensive (or equivalent) variables. | + !! These are the variables that are either physically more | + !! meaningful and/or used in ice thermodynamics | + !! | + !! List of ice state variables : | + !! ----------------------------- | + !! | + !!-------------|-------------|---------------------------------|-------| + !! name in | name in | meaning | units | + !! 2D routines | 1D routines | | | + !!-------------|-------------|---------------------------------|-------| + !! | + !! ******************************************************************* | + !! *** Dynamical variables (prognostic) *** | + !! ******************************************************************* | + !! | + !! u_ice | - | ice velocity in i-direction | m/s | + !! v_ice | - | ice velocity in j-direction | m/s | + !! | + !! ******************************************************************* | + !! *** Category dependent state variables (prognostic) *** | + !! ******************************************************************* | + !! | + !! ** Global variables | + !!-------------|-------------|---------------------------------|-------| + !! a_i | a_i_1d | Ice concentration | | + !! v_i | - | Ice volume per unit area | m | + !! v_s | - | Snow volume per unit area | m | + !! sv_i | - | Sea ice salt content | pss.m | + !! oa_i | - | Sea ice areal age content | s | + !! e_i | | Ice enthalpy | J/m2 | + !! | e_i_1d | Ice enthalpy per unit vol. | J/m3 | + !! e_s | | Snow enthalpy | J/m2 | + !! | e_s_1d | Snow enthalpy per unit vol. | J/m3 | + !! a_ip | - | Ice pond concentration | | + !! v_ip | - | Ice pond volume per unit area| m | + !! v_il | v_il_1d | Ice pond lid volume per area | m | + !! | + !!-------------|-------------|---------------------------------|-------| + !! | + !! ** Equivalent variables | + !!-------------|-------------|---------------------------------|-------| + !! | + !! h_i | h_i_1d | Ice thickness | m | + !! h_s ! h_s_1d | Snow depth | m | + !! s_i ! s_i_1d | Sea ice bulk salinity ! pss | + !! sz_i ! sz_i_1d | Sea ice salinity profile ! pss | + !! o_i ! - | Sea ice Age ! s | + !! t_i ! t_i_1d | Sea ice temperature ! K | + !! t_s ! t_s_1d | Snow temperature ! K | + !! t_su ! t_su_1d | Sea ice surface temperature ! K | + !! h_ip | h_ip_1d | Ice pond thickness | m | + !! h_il | h_il_1d | Ice pond lid thickness | m | + !! | + !! notes: the ice model only sees a bulk (i.e., vertically averaged) | + !! salinity, except in thermodynamic computations, for which | + !! the salinity profile is computed as a function of bulk | + !! salinity | + !! | + !! the sea ice surface temperature is not associated to any | + !! heat content. Therefore, it is not a state variable and | + !! does not have to be advected. Nevertheless, it has to be | + !! computed to determine whether the ice is melting or not | + !! | + !! ******************************************************************* | + !! *** Category-summed state variables (diagnostic) *** | + !! ******************************************************************* | + !! at_i | at_i_1d | Total ice concentration | | + !! vt_i | - | Total ice vol. per unit area | m | + !! vt_s | - | Total snow vol. per unit ar. | m | + !! st_i | - | Total Sea ice salt content | pss.m | + !! sm_i | - | Mean sea ice salinity | pss | + !! tm_i | - | Mean sea ice temperature | K | + !! tm_s | - | Mean snow temperature | K | + !! et_i | - | Total ice enthalpy | J/m2 | + !! et_s | - | Total snow enthalpy | J/m2 | + !! bv_i | - | relative brine volume | ??? | + !! at_ip | - | Total ice pond concentration | | + !! hm_ip | - | Mean ice pond depth | m | + !! vt_ip | - | Total ice pond vol. per unit area| m | + !! hm_il | - | Mean ice pond lid depth | m | + !! vt_il | - | Total ice pond lid vol. per area | m | + !!===================================================================== + + !!---------------------------------------------------------------------- + !! * Share Module variables + !!---------------------------------------------------------------------- + ! !!** ice-generic parameters namelist (nampar) ** + INTEGER , PUBLIC :: jpl !: number of ice categories + INTEGER , PUBLIC :: nlay_i !: number of ice layers + INTEGER , PUBLIC :: nlay_s !: number of snow layers + LOGICAL , PUBLIC :: ln_virtual_itd !: virtual ITD mono-category parameterization (T) or not (F) + LOGICAL , PUBLIC :: ln_icedyn !: flag for ice dynamics (T) or not (F) + LOGICAL , PUBLIC :: ln_icethd !: flag for ice thermo (T) or not (F) + REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere + REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere + CHARACTER(len=256), PUBLIC :: cn_icerst_in !: suffix of ice restart name (input) + CHARACTER(len=256), PUBLIC :: cn_icerst_out !: suffix of ice restart name (output) + CHARACTER(len=256), PUBLIC :: cn_icerst_indir !: ice restart input directory + CHARACTER(len=256), PUBLIC :: cn_icerst_outdir !: ice restart output directory + + ! !!** ice-itd namelist (namitd) ** + REAL(wp), PUBLIC :: rn_himin !: minimum ice thickness + + ! !!** ice-dynamics namelist (namdyn) ** + REAL(wp), PUBLIC :: rn_ishlat !: lateral boundary condition for sea-ice + LOGICAL , PUBLIC :: ln_landfast_L16 !: landfast ice parameterizationfrom lemieux2016 + REAL(wp), PUBLIC :: rn_lf_depfra !: fraction of ocean depth that ice must reach to initiate landfast ice + REAL(wp), PUBLIC :: rn_lf_bfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home) + REAL(wp), PUBLIC :: rn_lf_relax !: relaxation time scale (s-1) to reach static friction + REAL(wp), PUBLIC :: rn_lf_tensile !: isotropic tensile strength + ! + ! !!** ice-ridging/rafting namelist (namdyn_rdgrft) ** + REAL(wp), PUBLIC :: rn_crhg !: determines changes in ice strength (also used for landfast param) + ! + ! !!** ice-rheology namelist (namdyn_rhg) ** + LOGICAL , PUBLIC :: ln_aEVP !: using adaptive EVP (T or F) + REAL(wp), PUBLIC :: rn_creepl !: creep limit : has to be under 1.0e-9 + REAL(wp), PUBLIC :: rn_ecc !: eccentricity of the elliptical yield curve + INTEGER , PUBLIC :: nn_nevp !: number of iterations for subcycling + REAL(wp), PUBLIC :: rn_relast !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp) + INTEGER , PUBLIC :: nn_rhg_chkcvg !: check ice rheology convergence + ! + ! !!** ice-advection namelist (namdyn_adv) ** + LOGICAL , PUBLIC :: ln_adv_Pra !: Prather advection scheme + LOGICAL , PUBLIC :: ln_adv_UMx !: Ultimate-Macho advection scheme + ! + ! !!** ice-surface boundary conditions namelist (namsbc) ** + ! -- icethd_dh -- ! + REAL(wp), PUBLIC :: rn_snwblow !: coef. for partitioning of snowfall between leads and sea ice + ! -- icethd_zdf and icealb -- ! + INTEGER , PUBLIC :: nn_snwfra !: calculate the fraction of ice covered by snow + ! ! = 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] + ! -- icethd -- ! + REAL(wp), PUBLIC :: rn_cio !: drag coefficient for oceanic stress + INTEGER , PUBLIC :: nn_flxdist !: 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 + ! -- icethd_zdf -- ! + LOGICAL , PUBLIC :: ln_cndflx !: use conduction flux as surface boundary condition (instead of qsr and qns) + LOGICAL , PUBLIC :: ln_cndemulate !: emulate conduction flux (if not provided) + ! ! Conduction flux as surface forcing or not + INTEGER, PUBLIC, PARAMETER :: np_cnd_OFF = 0 !: no forcing from conduction flux (ice thermodynamics forced via qsr and qns) + INTEGER, PUBLIC, PARAMETER :: np_cnd_ON = 1 !: forcing from conduction flux (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90) + INTEGER, PUBLIC, PARAMETER :: np_cnd_EMU = 2 !: emulate conduction flux via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it) + INTEGER, PUBLIC :: nn_qtrice !: 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) + ! + ! !!** ice-vertical diffusion namelist (namthd_zdf) ** + LOGICAL , PUBLIC :: ln_cndi_U64 !: thermal conductivity: Untersteiner (1964) + LOGICAL , PUBLIC :: ln_cndi_P07 !: thermal conductivity: Pringle et al (2007) + REAL(wp), PUBLIC :: rn_cnd_s !: thermal conductivity of the snow [W/m/K] + REAL(wp), PUBLIC :: rn_oiht !: ocean to ice heat transfer coefficient + REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation in sea ice, Grenfell et al. (2006) [1/m] + REAL(wp), PUBLIC :: rn_kappa_s !: coef. for the extinction of radiation in snw (nn_qtrice=0) [1/m] + REAL(wp), PUBLIC :: rn_kappa_smlt !: coef. for the extinction of radiation in melt snw (nn_qtrice=1) [1/m] + REAL(wp), PUBLIC :: rn_kappa_sdry !: coef. for the extinction of radiation in dry snw (nn_qtrice=1) [1/m] + LOGICAL , PUBLIC :: ln_zdf_chkcvg !: check convergence of heat diffusion scheme + + ! !!** ice-salinity namelist (namthd_sal) ** + INTEGER , PUBLIC :: nn_icesal !: salinity configuration used in the model + ! ! 1 - constant salinity in both space and time + ! ! 2 - prognostic salinity (s(z,t)) + ! ! 3 - salinity profile, constant in time + REAL(wp), PUBLIC :: rn_icesal !: bulk salinity (ppt) in case of constant salinity + REAL(wp), PUBLIC :: rn_simax !: maximum ice salinity [PSU] + REAL(wp), PUBLIC :: rn_simin !: minimum ice salinity [PSU] + + ! !!** ice-ponds namelist (namthd_pnd) + LOGICAL , PUBLIC :: ln_pnd !: Melt ponds (T) or not (F) + LOGICAL , PUBLIC :: ln_pnd_LEV !: Melt ponds scheme from Holland et al (2012), Flocco et al (2007, 2010) + REAL(wp), PUBLIC :: rn_apnd_min !: Minimum ice fraction that contributes to melt ponds + REAL(wp), PUBLIC :: rn_apnd_max !: Maximum ice fraction that contributes to melt ponds + REAL(wp), PUBLIC :: rn_pnd_flush !: Pond flushing efficiency (tuning parameter) + LOGICAL , PUBLIC :: ln_pnd_CST !: Melt ponds scheme with constant fraction and depth + REAL(wp), PUBLIC :: rn_apnd !: prescribed pond fraction (0<rn_apnd<1) + REAL(wp), PUBLIC :: rn_hpnd !: prescribed pond depth (0<rn_hpnd<1) + LOGICAL, PUBLIC :: ln_pnd_lids !: Allow ponds to have frozen lids + LOGICAL , PUBLIC :: ln_pnd_alb !: melt ponds affect albedo + + ! !!** ice-diagnostics namelist (namdia) ** + LOGICAL , PUBLIC :: ln_icediachk !: flag for ice diag (T) or not (F) + REAL(wp), PUBLIC :: rn_icechk_cel !: rate of ice spuriously gained/lost (at any gridcell) + REAL(wp), PUBLIC :: rn_icechk_glo !: rate of ice spuriously gained/lost (globally) + LOGICAL , PUBLIC :: ln_icediahsb !: flag for ice diag (T) or not (F) + LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F) + INTEGER , PUBLIC :: iiceprt !: debug i-point + INTEGER , PUBLIC :: jiceprt !: debug j-point + + ! !!** some other parameters + INTEGER , PUBLIC :: kt_ice !: iteration number + REAL(wp), PUBLIC :: rdt_ice !: ice time step + REAL(wp), PUBLIC :: r1_rdtice !: = 1. / rdt_ice + REAL(wp), PUBLIC :: r1_nlay_i !: 1 / nlay_i + REAL(wp), PUBLIC :: r1_nlay_s !: 1 / nlay_s + REAL(wp), PUBLIC :: rswitch !: switch for the presence of ice (1) or not (0) + REAL(wp), PUBLIC :: rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft !: conservation diagnostics + REAL(wp), PUBLIC, PARAMETER :: epsi06 = 1.e-06_wp !: small number + REAL(wp), PUBLIC, PARAMETER :: epsi08 = 1.e-08_wp !: small number + REAL(wp), PUBLIC, PARAMETER :: epsi10 = 1.e-10_wp !: small number + REAL(wp), PUBLIC, PARAMETER :: epsi20 = 1.e-20_wp !: small number + + ! !!** define arrays + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce,v_oce !: surface ocean velocity used in ice dynamics + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_i_new !: ice collection thickness accreted in leads + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strength !: ice strength + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: stress1_i, stress2_i, stress12_i !: 1st, 2nd & diagonal stress tensor element + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: delta_i !: ice rheology elta factor (Flato & Hibler 95) [s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: divu_i !: Divergence of the velocity field [s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1] + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsb_ice_bot !: net downward heat flux from the ice to the ocean + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: mass flux from snow-ocean mass exchange [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sni !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sum !: mass flux from surface melt component of wfx_snw [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_pnd !: mass flux from melt pond-ocean mass exchange [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: mass flux from snow precipitation on ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: mass flux from sublimation of snow/ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sub !: mass flux from snow sublimation [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice_sub !: mass flux from ice sublimation [kg.m-2.s-1] + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_dyn !: mass flux from dynamical component of wfx_snw [kg.m-2.s-1] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: mass flux from ice-ocean mass exchange [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: mass flux from snow ice growth component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: mass flux from lateral ice growth component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: mass flux from bottom ice growth component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: mass flux from bottom melt component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: mass flux from surface melt component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_lam !: mass flux from lateral melt component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: mass flux from residual component of wfx_ice [kg.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice bottom growth [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_lam !: salt flux due to ice lateral melt [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice surface melt [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to snow-ice growth [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to growth in open water [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation [pss.kg.m-2.s-1 => g.m-2.s-1] + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_atm_oi !: heat flux at the interface atm-[oce+ice] [W.m-2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_oce_ai !: heat flux at the interface oce-[atm+ice] [W.m-2] + + ! heat flux associated with ice-atmosphere mass exchange + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2] + + ! heat flux associated with ice-ocean mass exchange + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from ridging [W.m-2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: heat flux due to correction on ice thick. (residual) [W.m-2] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_bot !: transmitted solar radiation under ice + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer (ln_cndflx=T) [K] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity of the 1st layer (ln_cndflx=T) [W.m-2.K-1] + + !!---------------------------------------------------------------------- + !! * Ice global state variables + !!---------------------------------------------------------------------- + !! Variables defined for each ice category + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i !: Ice thickness (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: Ice fractional areas (concentration) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i !: Ice volume per unit area (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s !: Snow volume per unit area (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s !: Snow thickness (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su !: Sea-Ice Surface Temperature (K) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i !: Sea-Ice Bulk salinity (pss) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i !: Sea-Ice Bulk salinity * volume per area (pss.m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (s) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (s) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume + + !! Variables summed over all categories, or associated to all the ice in a single grid cell + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: et_i , et_s !: ice and snow total heat content (J/m2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories (K) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_s !: mean snw temperature over all categories (K) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories (pss) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories (K) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated) + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSS] + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond concentration + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond fraction (a_ip/a_i) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_eff !: melt pond effective fraction (not covered up by lid) (a_ip/a_i) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond depth [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_il !: melt pond lid volume [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_il !: melt pond lid thickness [m] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond concentration + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_ip !: mean melt pond depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per gridcell area [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_il !: mean melt pond lid depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_il !: total melt pond lid volume per gridcell area [m] + + !!---------------------------------------------------------------------- + !! * Global variables at before time step + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip_b, v_il_b !: ponds and lids volumes + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total) + + !!---------------------------------------------------------------------- + !! * Ice thickness distribution variables + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories + ! + !!---------------------------------------------------------------------- + !! * Ice diagnostics + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation [] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_aice !: ice conc. variation [s-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vpnd !: pond volume variation [m/s] + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_mass !: advection of mass (kg/m2/s) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_salt !: advection of salt (g/m2/s) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_heat !: advection of heat (W/m2) + ! + !!---------------------------------------------------------------------- + !! * Ice conservation + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_v !: conservation of ice volume + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s !: conservation of ice salt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_t !: conservation of ice heat + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fv !: conservation of ice volume + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fs !: conservation of ice salt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_ft !: conservation of ice heat + ! + !!---------------------------------------------------------------------- + !! * SIMIP extra diagnostics + !!---------------------------------------------------------------------- + ! Extra sea ice diagnostics to address the data request + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_bot !: Bottom conduction flux (W/m2) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_top !: Surface conduction flux (W/m2) + ! + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: ice.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION ice_alloc() + !!----------------------------------------------------------------- + !! *** Routine ice_alloc *** + !!----------------------------------------------------------------- + INTEGER :: ice_alloc + ! + INTEGER :: ierr(16), ii + !!----------------------------------------------------------------- + ierr(:) = 0 + + ii = 1 + ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , ht_i_new (jpi,jpj) , strength(jpi,jpj) , & + & stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , & + & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( t_bo (jpi,jpj) , wfx_snw_sni(jpi,jpj) , & + & wfx_snw (jpi,jpj) , wfx_snw_dyn(jpi,jpj) , wfx_snw_sum(jpi,jpj) , wfx_snw_sub(jpi,jpj) , & + & wfx_ice (jpi,jpj) , wfx_sub (jpi,jpj) , wfx_ice_sub(jpi,jpj) , wfx_lam (jpi,jpj) , & + & wfx_pnd (jpi,jpj) , & + & wfx_bog (jpi,jpj) , wfx_dyn (jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , & + & wfx_res (jpi,jpj) , wfx_sni (jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & + & rn_amax_2d (jpi,jpj) , & + & qsb_ice_bot(jpi,jpj) , qlead (jpi,jpj) , & + & sfx_res (jpi,jpj) , sfx_bri (jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) , & + & sfx_bog (jpi,jpj) , sfx_bom (jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & + & hfx_res (jpi,jpj) , hfx_snw (jpi,jpj) , hfx_sub(jpi,jpj) , & + & qt_atm_oi (jpi,jpj) , qt_oce_ai (jpi,jpj) , fhld (jpi,jpj) , & + & hfx_sum (jpi,jpj) , hfx_bom (jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , & + & hfx_opw (jpi,jpj) , hfx_thd (jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) , & + & hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) ) + + ! * Ice global state variables + ii = ii + 1 + ALLOCATE( qtr_ice_bot(jpi,jpj,jpl) , cnd_ice(jpi,jpj,jpl) , t1_ice(jpi,jpj,jpl) , & + & h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , & + & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) , & + & s_i (jpi,jpj,jpl) , sv_i (jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , & + & oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , & + & vt_i (jpi,jpj) , vt_s (jpi,jpj) , st_i(jpi,jpj) , at_i(jpi,jpj) , ato_i(jpi,jpj) , & + & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s(jpi,jpj) , & + & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s(jpi,jpj) , & + & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj), STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), & + & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , STAT = ierr(ii) ) + + ii = ii + 1 + ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , hm_il(jpi,jpj) , vt_il(jpi,jpj) , STAT = ierr(ii) ) + + ! * Old values of global variables + ii = ii + 1 + ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), & + & v_ip_b(jpi,jpj,jpl) , v_il_b(jpi,jpj,jpl) , & + & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & + & STAT=ierr(ii) ) + + ii = ii + 1 + ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , at_i_b(jpi,jpj) , STAT=ierr(ii) ) + + ! * Ice thickness distribution variables + ii = ii + 1 + ALLOCATE( hi_max(0:jpl), hi_mean(jpl), STAT=ierr(ii) ) + + ! * Ice diagnostics + ii = ii + 1 + ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & + & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & + & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), diag_vpnd(jpi,jpj), & + & diag_adv_mass(jpi,jpj), diag_adv_salt(jpi,jpj), diag_adv_heat(jpi,jpj), STAT=ierr(ii) ) + + ! * Ice conservation + ii = ii + 1 + ALLOCATE( diag_v (jpi,jpj) , diag_s (jpi,jpj) , diag_t (jpi,jpj), & + & diag_fv(jpi,jpj) , diag_fs(jpi,jpj) , diag_ft(jpi,jpj), STAT=ierr(ii) ) + + ! * SIMIP diagnostics + ii = ii + 1 + ALLOCATE( t_si(jpi,jpj,jpl) , tm_si(jpi,jpj) , qcn_ice_bot(jpi,jpj,jpl) , qcn_ice_top(jpi,jpj,jpl) , STAT = ierr(ii) ) + + ice_alloc = MAXVAL( ierr(:) ) + IF( ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' ) + ! + + END FUNCTION ice_alloc + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE ice \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/ice1d.F90 b/V4.0/nemo_sources/src/ICE/ice1d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3c9a010b4b691b21fc16edc0767f635dc073ab71 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/ice1d.F90 @@ -0,0 +1,254 @@ +MODULE ice1D + !!====================================================================== + !! *** MODULE ice1D *** + !! sea-ice : Ice thermodynamics variables in 1D + !!===================================================================== + !! History : 3.0 ! 2002-11 (C. Ethe) original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + USE ice , ONLY : nlay_i, nlay_s, jpl ! number of ice/snow layers and categories + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice1D_alloc ! called by icestp.F90 + + !!---------------------- + !! * 1D Module variables + !!---------------------- + !: In ice thermodynamics, to spare memory, the vectors are folded + !: from 1D to 2D vectors. The following variables, with ending _1d + !: are the variables corresponding to 2d vectors + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nptidx !: selected points for ice thermo + INTEGER , PUBLIC :: npti ! number of selected points + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qlead_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qtr_ice_bot_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qsr_ice_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qns_ice_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rn_amax_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qml_ice_1d !: heat available for snow / ice surface melting [W/m2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcn_ice_1d !: heat available for snow / ice surface sublimation [W/m2] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qtr_ice_top_1d !: solar flux transmitted below the ice surface [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t1_ice_1d !: temperature of the 1st layer (ln_cndflx=T) [K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: cnd_ice_1d !: conductivity at the top of ice/snow (ln_cndflx=T) [W/K/m2] + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sum_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_bom_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_bog_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dif_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_opw_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_snw_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dyn_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_dif_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qt_oce_ai_1d + + ! heat flux associated with ice-atmosphere mass exchange + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_spr_1d + + ! heat flux associated with ice-ocean mass exchange + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_thd_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_res_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_snw_sni_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_snw_sum_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_snw_dyn_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_snw_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_ice_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_err_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_lam_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_bog_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_bom_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sum_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sni_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_opw_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_res_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_spr_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_dyn_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_pnd_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bri_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bog_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bom_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sum_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sni_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_opw_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sub_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_lam_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_dyn_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: at_i_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ato_i_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qsb_ice_bot_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fhld_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dqns_ice_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: evap_ice_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qprec_ice_1d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_su_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_si_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_i_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ib_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_i_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_ib_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_s_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_sum !: Ice surface ablation [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_itm !: Ice internal ablation [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bom !: Ice bottom ablation [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bog !: Ice bottom accretion [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_sub !: Ice surface sublimation [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_mlt !: Snow melt [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_i_1d !: Ice bulk salinity [ppt] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_i_new !: Salinity of new ice at the bottom + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_i_1d !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_s_1d !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sv_i_1d !: + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: oa_i_1d !: + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: o_i_1d !: + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_1d !: ice ponds + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_ip_1d !: + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_ip_1d !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_il_1d !: Ice pond lid + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_il_1d !: + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_1d !: corresponding to the 2D var t_s + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_i_1d !: corresponding to the 2D var t_i + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sz_i_1d !: profiled ice salinity + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e_i_1d !: Ice enthalpy per unit volume + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e_s_1d !: Snow enthalpy per unit volume + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: eh_i_old !: ice heat content (q*h, J.m-2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_old !: ice thickness layer (m) + + ! Conduction flux diagnostics (SIMIP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcn_ice_bot_1d + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcn_ice_top_1d + + ! surface fields from the ocean + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sst_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sss_1d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frq_m_1d + + ! convergence check + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgerr_1d !: convergence of ice/snow temp (dT) [K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgstp_1d !: convergence of ice/snow temp (subtimestep) [-] + ! + !!---------------------- + !! * 2D Module variables + !!---------------------- + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_i_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_i_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_s_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: oa_i_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sv_i_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_ip_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_ip_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_il_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_su_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_2d + + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_ib_2d + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_ib_2d + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: ice1d.F90 13642 2020-10-19 22:58:34Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION ice1D_alloc() + !!---------------------------------------------------------------------! + !! *** ROUTINE ice1D_alloc *** + !!---------------------------------------------------------------------! + INTEGER :: ice1D_alloc ! return value + INTEGER :: ierr(8), ii + !!---------------------------------------------------------------------! + ierr(:) = 0 + + ii = 1 + ALLOCATE( nptidx (jpij) , & + & qlead_1d (jpij) , qtr_ice_bot_1d(jpij) , qsr_ice_1d(jpij) , & + & qns_ice_1d(jpij) , qml_ice_1d (jpij) , qcn_ice_1d(jpij) , qtr_ice_top_1d(jpij) , & + & cnd_ice_1d(jpij) , t1_ice_1d (jpij) , t_bo_1d (jpij) , & + & hfx_sum_1d(jpij) , hfx_bom_1d (jpij) , hfx_bog_1d(jpij) , & + & hfx_dif_1d(jpij) , hfx_opw_1d (jpij) , hfx_dyn_1d(jpij) , & + & rn_amax_1d(jpij) , & + & hfx_thd_1d(jpij) , hfx_spr_1d (jpij) , & + & hfx_snw_1d(jpij) , hfx_sub_1d (jpij) , & + & hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( sprecip_1d (jpij) , at_i_1d (jpij) , ato_i_1d (jpij) , & + & qsb_ice_bot_1d(jpij) , wfx_snw_sni_1d(jpij) , wfx_spr_1d (jpij) , wfx_snw_sum_1d(jpij) , & + & fhld_1d (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d (jpij) , & + & wfx_sum_1d (jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d (jpij) , & + & wfx_snw_sub_1d(jpij) , wfx_snw_dyn_1d(jpij) , wfx_ice_sub_1d(jpij) , wfx_err_sub_1d(jpij) , & + & wfx_lam_1d (jpij) , wfx_dyn_1d (jpij) , wfx_pnd_1d (jpij) , dqns_ice_1d (jpij) , evap_ice_1d (jpij) , & + & qprec_ice_1d (jpij) , & + & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), & + & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), & + & sfx_lam_1d (jpij) , sfx_dyn_1d(jpij) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( t_su_1d (jpij) , t_si_1d (jpij) , a_i_1d (jpij) , a_ib_1d (jpij) , & + & h_i_1d (jpij) , h_ib_1d (jpij) , h_s_1d (jpij) , & + & dh_s_tot(jpij) , dh_i_sum(jpij) , dh_i_itm (jpij) , dh_i_bom(jpij) , dh_i_bog(jpij) , & + & dh_i_sub(jpij) , dh_s_mlt(jpij) , dh_snowice(jpij) , s_i_1d (jpij) , s_i_new (jpij) , & + & a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d (jpij) , v_s_1d (jpij) , v_il_1d (jpij) , & + & h_il_1d (jpij) , h_ip_1d (jpij) , & + & sv_i_1d (jpij) , oa_i_1d (jpij) , o_i_1d (jpij) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( t_s_1d (jpij,nlay_s) , t_i_1d (jpij,nlay_i) , sz_i_1d(jpij,nlay_i) , & + & e_i_1d (jpij,nlay_i) , e_s_1d (jpij,nlay_s) , & + & eh_i_old(jpij,0:nlay_i+1) , h_i_old(jpij,0:nlay_i+1) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( qcn_ice_bot_1d(jpij) , qcn_ice_top_1d(jpij) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( sst_1d(jpij) , sss_1d(jpij) , frq_m_1d(jpij) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( tice_cvgerr_1d(jpij) , tice_cvgstp_1d(jpij) , STAT=ierr(ii) ) + ! + ii = ii + 1 + ALLOCATE( a_i_2d (jpij,jpl) , a_ib_2d(jpij,jpl) , h_i_2d (jpij,jpl) , h_ib_2d(jpij,jpl) , & + & v_i_2d (jpij,jpl) , v_s_2d (jpij,jpl) , oa_i_2d(jpij,jpl) , sv_i_2d(jpij,jpl) , & + & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) , & + & STAT=ierr(ii) ) + + ice1D_alloc = MAXVAL( ierr(:) ) + IF( ice1D_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice1D_alloc: failed to allocate arrays.' ) + ! + END FUNCTION ice1D_alloc + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE ice1D_alloc ! Empty routine + END SUBROUTINE ice1D_alloc +#endif + + !!====================================================================== +END MODULE ice1D \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icealb.F90 b/V4.0/nemo_sources/src/ICE/icealb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..111b51c8f49f900dc1c548cde3736512331df39b --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icealb.F90 @@ -0,0 +1,237 @@ +MODULE icealb + !!====================================================================== + !! *** MODULE icealb *** + !! Atmospheric forcing: Albedo over sea ice + !!===================================================================== + !! History : 4.0 ! 2017-07 (C. Rousset) Split ice and ocean albedos + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_alb : albedo for ice (clear and overcast skies) + !! ice_alb_init : initialisation of albedo computation + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE dom_oce ! domain: ocean + USE ice, ONLY: jpl ! sea-ice: number of categories + USE icevar ! sea-ice: operations + ! + 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 timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_alb_init ! called in icestp + PUBLIC ice_alb ! called in icesbc.F90 and iceupdate.F90 + + REAL(wp), PUBLIC, PARAMETER :: rn_alb_oce = 0.066 !: ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) + ! + ! !!* albedo namelist (namalb) + REAL(wp) :: rn_alb_sdry ! dry snow albedo + REAL(wp) :: rn_alb_smlt ! melting snow albedo + REAL(wp) :: rn_alb_idry ! dry ice albedo + REAL(wp) :: rn_alb_imlt ! bare puddled ice albedo + REAL(wp) :: rn_alb_dpnd ! ponded ice albedo + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icealb.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_alb *** + !! + !! ** Purpose : Computation of the albedo of the snow/ice system + !! + !! ** Method : The scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) + !! and Grenfell & Perovich (JGR 2004) + !! 1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) + !! which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 + !! 0-5cm : linear function of ice thickness + !! 5-150cm: log function of ice thickness + !! > 150cm: constant + !! 2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) + !! i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting + !! 3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) + !! i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law + !! 4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice + !! + !! compilation of values from literature (reference overcast sky values) + !! rn_alb_sdry = 0.85 ! dry snow + !! rn_alb_smlt = 0.75 ! melting snow + !! rn_alb_idry = 0.60 ! bare frozen ice + !! rn_alb_imlt = 0.50 ! bare puddled ice albedo + !! rn_alb_dpnd = 0.36 ! ponded-ice overcast albedo (Lecomte et al, 2015) + !! ! early melt pnds 0.27, late melt ponds 0.14 Grenfell & Perovich + !! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved + !! rn_alb_sdry = 0.85 ! dry snow + !! rn_alb_smlt = 0.72 ! melting snow + !! rn_alb_idry = 0.65 ! bare frozen ice + !! Brandt et al 2005 (East Antarctica) + !! rn_alb_sdry = 0.87 ! dry snow + !! rn_alb_smlt = 0.82 ! melting snow + !! rn_alb_idry = 0.54 ! bare frozen ice + !! + !! ** Note : The old parameterization from Shine & Henderson-Sellers (not here anymore) presented several misconstructions + !! 1) ice albedo when ice thick. tends to 0 is different than ocean albedo + !! 2) for small ice thick. covered with some snow (<3cm?), albedo is larger + !! under melting conditions than under freezing conditions + !! 3) the evolution of ice albedo as a function of ice thickness shows + !! 3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic + !! + !! References : Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. + !! Brandt et al. 2005, J. Climate, vol 18 + !! Grenfell & Perovich 2004, JGR, vol 109 + !!---------------------------------------------------------------------- + REAL(dp), INTENT(in ), DIMENSION(:,:,:) :: pt_su ! ice surface temperature (Kelvin) + REAL(dp), INTENT(in ), DIMENSION(:,:,:) :: ph_ice ! sea-ice thickness + REAL(dp), INTENT(in ), DIMENSION(:,:,:) :: ph_snw ! snow depth + LOGICAL , INTENT(in ) :: ld_pnd_alb ! effect of melt ponds on albedo + REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pafrac_pnd ! melt pond relative fraction (per unit ice area) + REAL(dp), INTENT(in ), DIMENSION(:,:,:) :: ph_pnd ! melt pond depth + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pcloud_fra ! cloud fraction + REAL(dp), INTENT( out), DIMENSION(:,:,:) :: palb_ice ! albedo of ice + ! + REAL(dp), DIMENSION(jpi,jpj,jpl) :: za_s_fra ! ice fraction covered by snow + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: jj1, jj2 ! OpenMP loop index + INTEGER :: itid, ithreads ! OpenMP variables + REAL(wp) :: z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar + REAL(wp) :: z1_href_pnd ! inverse of the characteristic length scale (Lecomte et al. 2015) + REAL(wp) :: zalb_pnd, zafrac_pnd ! ponded sea ice albedo & relative pound fraction + REAL(wp) :: zalb_ice, zafrac_ice ! bare sea ice albedo & relative ice fraction + REAL(wp) :: zalb_snw, zafrac_snw ! snow-covered sea ice albedo & relative snow fraction + REAL(wp) :: zalb_cs, zalb_os ! albedo of ice under clear/overcast sky + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icealb') + ! + !$omp parallel private(ji,jj1,jj2,itid,ithreads,& + !$omp& z1_c1,z1_c2,z1_c3,z1_c4,z1_href_pnd,zalb_pnd,zafrac_pnd, & + !$omp& zalb_ice,zafrac_ice,zalb_snw,zafrac_snw,zalb_cs,zalb_os) + ! + z1_href_pnd = 1. / 0.05 + z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) ) + z1_c2 = 1. / 0.05 + z1_c3 = 1. / 0.02 + z1_c4 = 1. / 0.03 + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + CALL ice_var_snwfra( jj1, jj2, ph_snw, za_s_fra ) ! calculate ice fraction covered by snow + ! + DO jl = 1, jpl + DO jj = jj1, jj2 + DO ji = 1, jpi + ! + !---------------------------------------------! + !--- Specific snow, ice and pond fractions ---! + !---------------------------------------------! + zafrac_snw = za_s_fra(ji,jj,jl) + IF( ld_pnd_alb ) THEN + zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 + ELSE + zafrac_pnd = 0._wp + ENDIF + zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors + ! + !---------------! + !--- Albedos ---! + !---------------! + ! !--- Bare ice albedo (for hi > 150cm) + IF( ld_pnd_alb ) THEN + zalb_ice = rn_alb_idry + ELSE + IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt + ELSE ; zalb_ice = rn_alb_idry ; ENDIF + ENDIF + ! !--- Bare ice albedo (for hi < 150cm) + IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN ! 5cm < hi < 150cm + zalb_ice = zalb_ice + ( 0.18 - zalb_ice ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) + ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN ! 0cm < hi < 5cm + zalb_ice = rn_alb_oce + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) + ENDIF + ! + ! !--- Snow-covered ice albedo (freezing, melting cases) + IF( pt_su(ji,jj,jl) < rt0 ) THEN + zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) + ELSE + zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) + ENDIF + ! !--- Ponded ice albedo + zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) + ! + ! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions + zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) + ! + zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os & + & + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) + ! + ! albedo depends on cloud fraction because of non-linear spectral effects + palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os + + END DO + END DO + END DO + ! + !$omp end parallel + ! + IF( ln_timing ) CALL timing_stop('icealb') + ! + END SUBROUTINE ice_alb + + + SUBROUTINE ice_alb_init + !!---------------------------------------------------------------------- + !! *** ROUTINE alb_init *** + !! + !! ** Purpose : initializations for the albedo parameters + !! + !! ** Method : Read the namelist namalb + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namalb/ rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt, rn_alb_dpnd + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namalb in reference namelist : Albedo parameters + READ ( numnam_ice_ref, namalb, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namalb in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namalb in configuration namelist : Albedo parameters + READ ( numnam_ice_cfg, namalb, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namalb in configuration namelist' ) + IF(lwm) WRITE( numoni, namalb ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'ice_alb_init: set albedo parameters' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namalb:' + WRITE(numout,*) ' albedo of dry snow rn_alb_sdry = ', rn_alb_sdry + WRITE(numout,*) ' albedo of melting snow rn_alb_smlt = ', rn_alb_smlt + WRITE(numout,*) ' albedo of dry ice rn_alb_idry = ', rn_alb_idry + WRITE(numout,*) ' albedo of bare puddled ice rn_alb_imlt = ', rn_alb_imlt + WRITE(numout,*) ' albedo of ponded ice rn_alb_dpnd = ', rn_alb_dpnd + ENDIF + ! + END SUBROUTINE ice_alb_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icealb \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icecor.F90 b/V4.0/nemo_sources/src/ICE/icecor.F90 new file mode 100644 index 0000000000000000000000000000000000000000..233d1ab3bf804ecfc2696482602a1b724caa0d1d --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icecor.F90 @@ -0,0 +1,163 @@ +MODULE icecor + !!====================================================================== + !! *** MODULE icecor *** + !! sea-ice: Corrections on sea-ice variables at the end of the time step + !!====================================================================== + !! History : 3.0 ! 2006-04 (M. Vancoppenolle) Original code + !! 3.5 ! 2014-06 (C. Rousset) Complete rewriting/cleaning + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_cor : corrections on sea-ice variables + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE phycst ! physical constants + USE ice ! sea-ice: variable + USE ice1D ! sea-ice: thermodynamic variables + USE iceitd ! sea-ice: rebining + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: control prints + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + USE nopenmp ! OpenMP library + ! + IMPLICIT NONE + PRIVATE + + PUBLIC ice_cor ! called by icestp.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icecor.F90 13640 2020-10-19 17:15:09Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_cor( kt, kn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_cor *** + !! + !! ** Purpose : Computes corrections on sea-ice global variables at + !! the end of the dynamics (kn=1) and thermodynamics (kn=2) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + INTEGER, INTENT(in) :: kn ! 1 = after dyn ; 2 = after thermo + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + REAL(wp) :: zsal, zzc + !!---------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('icecor') ! timing + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icecor', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (0, 'icecor', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + ! + IF( kt == nit000 .AND. lwp .AND. kn == 2 ) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_cor: correct sea ice variables if out of bounds ' + WRITE(numout,*) '~~~~~~~' + ENDIF + + !$omp parallel private(itid,ithreads,ji,jj,jk,jl,jj1,jj2,zzc,zsal) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! !----------------------------------------------------- + ! ! ice thickness must exceed himin (for temp. diff.) ! + ! !----------------------------------------------------- + WHERE( a_i(:,jj1:jj2,:) >= epsi20 ) ; h_i(:,jj1:jj2,:) = v_i(:,jj1:jj2,:) / a_i(:,jj1:jj2,:) + ELSEWHERE ; h_i(:,jj1:jj2,:) = 0._wp + END WHERE + WHERE( h_i(:,jj1:jj2,:) < rn_himin ) a_i(:,jj1:jj2,:) = a_i(:,jj1:jj2,:) * h_i(:,jj1:jj2,:) / rn_himin + ! + ! !----------------------------------------------------- + ! ! ice concentration should not exceed amax ! + ! !----------------------------------------------------- + at_i(:,jj1:jj2) = SUM( a_i(:,jj1:jj2,:), dim=3 ) + DO jl = 1, jpl + WHERE( at_i(:,jj1:jj2) > rn_amax_2d(:,jj1:jj2) ) a_i(:,jj1:jj2,jl) = a_i(:,jj1:jj2,jl) * rn_amax_2d(:,jj1:jj2) / at_i(:,jj1:jj2) + END DO + ! !----------------------------------------------------- + ! ! Rebin categories with thickness out of bounds ! + ! !----------------------------------------------------- + !$omp barrier + !$omp master + IF ( jpl > 1 ) CALL ice_itd_reb( kt ) + !$omp end master + !$omp barrier + ! + ! !----------------------------------------------------- + IF ( nn_icesal == 2 ) THEN ! salinity must stay in bounds [Simin,Simax] ! + ! !----------------------------------------------------- + zzc = rhoi * r1_rdtice + DO jl = 1, jpl + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zsal = sv_i(ji,jj,jl) + sv_i(ji,jj,jl) = MIN( MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl) ) + IF( kn /= 0 ) & ! no ice-ocean exchanges if kn=0 (for bdy for instance) otherwise conservation diags will fail + & sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc ! associated salt flux + END DO + END DO + END DO + ENDIF + + IF( kn /= 0 ) THEN ! no zapsmall if kn=0 (for bdy for instance) because we do not want ice-ocean exchanges (wfx,sfx,hfx) + ! otherwise conservation diags will fail + ! !----------------------------------------------------- + CALL ice_var_zapsmall(jj1,jj2) ! Zap small values ! + ! !----------------------------------------------------- + ENDIF + + ! + ! !----------------------------------------------------- + IF( kn == 2 ) THEN ! Ice drift case: Corrections to avoid wrong values ! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) !----------------------------------------------------- + DO ji = 2, jpim1 + IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice + IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side + IF ( at_i(ji-1,jj) == 0._wp ) u_ice(ji-1,jj) = 0._wp ! left side + IF ( at_i(ji,jj+1) == 0._wp ) v_ice(ji,jj ) = 0._wp ! upper side + IF ( at_i(ji,jj-1) == 0._wp ) v_ice(ji,jj-1) = 0._wp ! bottom side + ENDIF + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) + !$omp end master + !$omp barrier + ENDIF + ! + !$omp end parallel + ! + ! controls + IF( ln_ctl ) CALL ice_prt3D ('icecor') ! prints + IF( ln_icectl .AND. kn == 2 ) & + & CALL ice_prt ( kt, iiceprt, jiceprt, 2, ' - Final state - ' ) ! prints + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icecor', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (1, 'icecor', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + IF( ln_timing ) CALL timing_stop ('icecor') ! timing + ! + END SUBROUTINE ice_cor + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icecor \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icecor.mod b/V4.0/nemo_sources/src/ICE/icecor.mod new file mode 100644 index 0000000000000000000000000000000000000000..5168235bf658306f7f60b7f7a9302fca70d72193 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icecor.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icectl.F90 b/V4.0/nemo_sources/src/ICE/icectl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ee7ac2ad9879138c5976acb487764131bcad08a8 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icectl.F90 @@ -0,0 +1,905 @@ +MODULE icectl + !!====================================================================== + !! *** MODULE icectl *** + !! sea-ice : controls and prints + !!====================================================================== + !! History : 3.5 ! 2015-01 (M. Vancoppenolle) Original code + !! 3.7 ! 2016-10 (C. Rousset) Add routine ice_prt3D + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_cons_hsm : conservation tests on heat, salt and mass during a time step (global) + !! ice_cons_final : conservation tests on heat, salt and mass at end of time step (global) + !! ice_cons2D : conservation tests on heat, salt and mass at each gridcell + !! ice_ctl : control prints in case of crash + !! ice_prt : control prints at a given grid point + !! ice_prt3D : control prints of ice arrays + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + USE prtctl ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_cons_hsm + PUBLIC ice_cons_final + PUBLIC ice_cons2D + PUBLIC ice_ctl + PUBLIC ice_prt + PUBLIC ice_prt3D + PUBLIC ice_drift_wri + PUBLIC ice_drift_init + + ! thresold rates for conservation + ! these values are changed by the namelist parameter rn_icechk, so that threshold = zchk * rn_icechk + REAL(wp), PARAMETER :: zchk_m = 2.5e-7 ! kg/m2/s <=> 1e-6 m of ice per hour spuriously gained/lost + REAL(wp), PARAMETER :: zchk_s = 2.5e-6 ! g/m2/s <=> 1e-6 m of ice per hour spuriously gained/lost (considering s=10g/kg) + REAL(wp), PARAMETER :: zchk_t = 7.5e-2 ! W/m2 <=> 1e-6 m of ice per hour spuriously gained/lost (considering Lf=3e5J/kg) + + ! for drift outputs + CHARACTER(LEN=50) :: clname="icedrift_diagnostics.ascii" ! ascii filename + INTEGER :: numicedrift ! outfile unit + REAL(wp) :: rdiag_icemass, rdiag_icesalt, rdiag_iceheat + REAL(wp) :: rdiag_adv_icemass, rdiag_adv_icesalt, rdiag_adv_iceheat + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icectl.F90 14590 2021-03-05 13:21:05Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_cons_hsm( icount, cd_routine, pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_cons_hsm *** + !! + !! ** Purpose : Test the conservation of heat, salt and mass for each ice routine + !! + test if ice concentration and volume are > 0 + !! + !! ** Method : This is an online diagnostics which can be activated with ln_icediachk=true + !! It prints in ocean.output if there is a violation of conservation at each time-step + !! The thresholds (zchk_m, zchk_s, zchk_t) determine violations + !! For salt and heat thresholds, ice is considered to have a salinity of 10 + !! and a heat content of 3e5 J/kg (=latent heat of fusion) + !!------------------------------------------------------------------- + INTEGER , INTENT(in) :: icount ! called at: =0 the begining of the routine, =1 the end + CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine + REAL(wp) , INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft + !! + REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat, & + & zdiag_vimin, zdiag_vsmin, zdiag_vpmin, zdiag_vlmin, zdiag_aimin, zdiag_aimax, & + & zdiag_eimin, zdiag_esmin, zdiag_simin + REAL(wp) :: zvtrp, zetrp + REAL(wp) :: zarea + !!------------------------------------------------------------------- + ! + IF( icount == 0 ) THEN + + pdiag_v = glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ) + pdiag_s = glob_sum( 'icectl', SUM( sv_i * rhoi , dim=3 ) * e1e2t ) + pdiag_t = glob_sum( 'icectl', ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) ) * e1e2t ) + + ! mass flux + pdiag_fv = glob_sum( 'icectl', & + & ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) * e1e2t ) + ! salt flux + pdiag_fs = glob_sum( 'icectl', & + & ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) * e1e2t ) + ! heat flux + pdiag_ft = glob_sum( 'icectl', & + & ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t ) + + ELSEIF( icount == 1 ) THEN + + ! -- mass diag -- ! + zdiag_mass = ( glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ) & + & - pdiag_v ) * r1_rdtice & + & + glob_sum( 'icectl', ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) * e1e2t ) & + & - pdiag_fv + ! + ! -- salt diag -- ! + zdiag_salt = ( glob_sum( 'icectl', SUM( sv_i * rhoi , dim=3 ) * e1e2t ) - pdiag_s ) * r1_rdtice + glob_sum( 'icectl', ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) * e1e2t ) & + & - pdiag_fs + ! + ! -- heat diag -- ! + zdiag_heat = ( glob_sum( 'icectl', ( SUM(SUM(e_i, dim=4), dim=3) + SUM(SUM(e_s, dim=4), dim=3) ) * e1e2t ) - pdiag_t ) * r1_rdtice & + & + glob_sum( 'icectl', ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t ) & + & - pdiag_ft + + ! -- min/max diag -- ! + zdiag_aimax = glob_max( 'icectl', SUM( a_i, dim=3 ) ) + zdiag_vimin = glob_min( 'icectl', v_i ) + zdiag_vsmin = glob_min( 'icectl', v_s ) + zdiag_vpmin = glob_min( 'icectl', v_ip ) + zdiag_vlmin = glob_min( 'icectl', v_il ) + zdiag_aimin = glob_min( 'icectl', a_i ) + zdiag_simin = glob_min( 'icectl', sv_i ) + zdiag_eimin = glob_min( 'icectl', SUM( e_i, dim=3 ) ) + zdiag_esmin = glob_min( 'icectl', SUM( e_s, dim=3 ) ) + + ! -- advection scheme is conservative? -- ! + zvtrp = glob_sum( 'icectl', diag_adv_mass * e1e2t ) + zetrp = glob_sum( 'icectl', diag_adv_heat * e1e2t ) + + ! ice area (+epsi10 to set a threshold > 0 when there is no ice) + zarea = glob_sum( 'icectl', SUM( a_i + epsi10, dim=3 ) * e1e2t ) + + IF( lwp ) THEN + ! check conservation issues + IF( ABS(zdiag_mass) > zchk_m * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation mass cons. [kg] = ',zdiag_mass * rdt_ice + IF( ABS(zdiag_salt) > zchk_s * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation salt cons. [g] = ',zdiag_salt * rdt_ice + IF( ABS(zdiag_heat) > zchk_t * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation heat cons. [J] = ',zdiag_heat * rdt_ice + ! check negative values + IF( zdiag_vimin < 0. ) WRITE(numout,*) cd_routine,' : violation v_i < 0 = ',zdiag_vimin + IF( zdiag_vsmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_s < 0 = ',zdiag_vsmin + IF( zdiag_vpmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_ip < 0 = ',zdiag_vpmin + IF( zdiag_vlmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_il < 0 = ',zdiag_vlmin + IF( zdiag_aimin < 0. ) WRITE(numout,*) cd_routine,' : violation a_i < 0 = ',zdiag_aimin + IF( zdiag_simin < 0. ) WRITE(numout,*) cd_routine,' : violation s_i < 0 = ',zdiag_simin + IF( zdiag_eimin < 0. ) WRITE(numout,*) cd_routine,' : violation e_i < 0 = ',zdiag_eimin + IF( zdiag_esmin < 0. ) WRITE(numout,*) cd_routine,' : violation e_s < 0 = ',zdiag_esmin + ! check maximum ice concentration + IF( zdiag_aimax>MAX(rn_amax_n,rn_amax_s)+epsi10 .AND. cd_routine /= 'icedyn_adv' .AND. cd_routine /= 'icedyn_rdgrft' ) & + & WRITE(numout,*) cd_routine,' : violation a_i > amax = ',zdiag_aimax + ! check if advection scheme is conservative + IF( ABS(zvtrp) > zchk_m * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & + & WRITE(numout,*) cd_routine,' : violation adv scheme [kg] = ',zvtrp * rdt_ice + IF( ABS(zetrp) > zchk_t * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & + & WRITE(numout,*) cd_routine,' : violation adv scheme [J] = ',zetrp * rdt_ice + ENDIF + ! + ENDIF + + END SUBROUTINE ice_cons_hsm + + SUBROUTINE ice_cons_final( cd_routine ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_cons_final *** + !! + !! ** Purpose : Test the conservation of heat, salt and mass at the end of each ice time-step + !! + !! ** Method : This is an online diagnostics which can be activated with ln_icediachk=true + !! It prints in ocean.output if there is a violation of conservation at each time-step + !! The thresholds (zchk_m, zchk_s, zchk_t) determine the violations + !! For salt and heat thresholds, ice is considered to have a salinity of 10 + !! and a heat content of 3e5 J/kg (=latent heat of fusion) + !!------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine + REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat + REAL(wp) :: zarea + !!------------------------------------------------------------------- + + ! water flux + ! -- mass diag -- ! + zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + wfx_pnd + diag_vice + diag_vsnw + diag_vpnd - diag_adv_mass ) * e1e2t ) + + ! -- salt diag -- ! + zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) + + ! -- heat diag -- ! + zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ) + ! equivalent to this: + !!zdiag_heat = glob_sum( 'icectl', ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & + !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr & + !! & ) * e1e2t ) + + ! ice area (+epsi10 to set a threshold > 0 when there is no ice) + zarea = glob_sum( 'icectl', SUM( a_i + epsi10, dim=3 ) * e1e2t ) + + IF( lwp ) THEN + IF( ABS(zdiag_mass) > zchk_m * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation mass cons. [kg] = ',zdiag_mass * rdt_ice + IF( ABS(zdiag_salt) > zchk_s * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation salt cons. [g] = ',zdiag_salt * rdt_ice + IF( ABS(zdiag_heat) > zchk_t * rn_icechk_glo * zarea ) & + & WRITE(numout,*) cd_routine,' : violation heat cons. [J] = ',zdiag_heat * rdt_ice + ENDIF + ! + END SUBROUTINE ice_cons_final + + SUBROUTINE ice_cons2D( icount, cd_routine, pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_cons2D *** + !! + !! ** Purpose : Test the conservation of heat, salt and mass for each ice routine + !! + test if ice concentration and volume are > 0 + !! + !! ** Method : This is an online diagnostics which can be activated with ln_icediachk=true + !! It stops the code if there is a violation of conservation at any gridcell + !!------------------------------------------------------------------- + INTEGER , INTENT(in) :: icount ! called at: =0 the begining of the routine, =1 the end + CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine + REAL(wp) , DIMENSION(jpi,jpj), INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft + !! + REAL(wp), DIMENSION(jpi,jpj) :: zdiag_mass, zdiag_salt, zdiag_heat, & + & zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin !!, zdiag_amax + INTEGER :: jl, jk + LOGICAL :: ll_stop_m = .FALSE. + LOGICAL :: ll_stop_s = .FALSE. + LOGICAL :: ll_stop_t = .FALSE. + CHARACTER(len=120) :: clnam ! filename for the output + !!------------------------------------------------------------------- + ! + IF( icount == 0 ) THEN + + pdiag_v = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) + pdiag_s = SUM( sv_i * rhoi , dim=3 ) + pdiag_t = SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) + + ! mass flux + pdiag_fv = wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + & + & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr + ! salt flux + pdiag_fs = sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam + ! heat flux + pdiag_ft = hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & + & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr + + ELSEIF( icount == 1 ) THEN + + ! -- mass diag -- ! + zdiag_mass = ( SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) - pdiag_v ) * r1_rdtice & + & + ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + & + & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) & + & - pdiag_fv + IF( MAXVAL( ABS(zdiag_mass) ) > zchk_m * rn_icechk_cel ) ll_stop_m = .TRUE. + ! + ! -- salt diag -- ! + zdiag_salt = ( SUM( sv_i * rhoi , dim=3 ) - pdiag_s ) * r1_rdtice & + & + ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) & + & - pdiag_fs + IF( MAXVAL( ABS(zdiag_salt) ) > zchk_s * rn_icechk_cel ) ll_stop_s = .TRUE. + ! + ! -- heat diag -- ! + zdiag_heat = ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) - pdiag_t ) * r1_rdtice & + & + ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & + & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) & + & - pdiag_ft + IF( MAXVAL( ABS(zdiag_heat) ) > zchk_t * rn_icechk_cel ) ll_stop_t = .TRUE. + ! + ! -- other diags -- ! + ! a_i < 0 + zdiag_amin(:,:) = 0._wp + DO jl = 1, jpl + WHERE( a_i(:,:,jl) < 0._wp ) zdiag_amin(:,:) = 1._wp + ENDDO + ! v_i < 0 + zdiag_vmin(:,:) = 0._wp + DO jl = 1, jpl + WHERE( v_i(:,:,jl) < 0._wp ) zdiag_vmin(:,:) = 1._wp + ENDDO + ! s_i < 0 + zdiag_smin(:,:) = 0._wp + DO jl = 1, jpl + WHERE( s_i(:,:,jl) < 0._wp ) zdiag_smin(:,:) = 1._wp + ENDDO + ! e_i < 0 + zdiag_emin(:,:) = 0._wp + DO jl = 1, jpl + DO jk = 1, nlay_i + WHERE( e_i(:,:,jk,jl) < 0._wp ) zdiag_emin(:,:) = 1._wp + ENDDO + ENDDO + ! a_i > amax + !WHERE( SUM( a_i, dim=3 ) > ( MAX( rn_amax_n, rn_amax_s ) + epsi10 ) ; zdiag_amax(:,:) = 1._wp + !ELSEWHERE ; zdiag_amax(:,:) = 0._wp + !END WHERE + + IF( ll_stop_m .OR. ll_stop_s .OR. ll_stop_t ) THEN + clnam = 'diag_ice_conservation_'//cd_routine + CALL ice_cons_wri( clnam, zdiag_mass, zdiag_salt, zdiag_heat, zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin ) + ENDIF + + IF( ll_stop_m ) CALL ctl_stop( 'STOP', cd_routine//': ice mass conservation issue' ) + IF( ll_stop_s ) CALL ctl_stop( 'STOP', cd_routine//': ice salt conservation issue' ) + IF( ll_stop_t ) CALL ctl_stop( 'STOP', cd_routine//': ice heat conservation issue' ) + + ENDIF + + END SUBROUTINE ice_cons2D + + SUBROUTINE ice_cons_wri( cdfile_name, pdiag_mass, pdiag_salt, pdiag_heat, pdiag_amin, pdiag_vmin, pdiag_smin, pdiag_emin ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ice_cons_wri *** + !! + !! ** Purpose : create a NetCDF file named cdfile_name which contains + !! the instantaneous fields when conservation issue occurs + !! + !! ** Method : NetCDF files using ioipsl + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT( in ) :: cdfile_name ! name of the file created + REAL(wp), DIMENSION(:,:), INTENT( in ) :: pdiag_mass, pdiag_salt, pdiag_heat, & + & pdiag_amin, pdiag_vmin, pdiag_smin, pdiag_emin !!, pdiag_amax + !! + INTEGER :: inum + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_cons_wri : single instantaneous ice state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ named :', cdfile_name, '...nc' + IF(lwp) WRITE(numout,*) + + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) + + CALL iom_rstput( 0, 0, inum, 'cons_mass', pdiag_mass(:,:) , ktype = jp_r8 ) ! ice mass spurious lost/gain + CALL iom_rstput( 0, 0, inum, 'cons_salt', pdiag_salt(:,:) , ktype = jp_r8 ) ! ice salt spurious lost/gain + CALL iom_rstput( 0, 0, inum, 'cons_heat', pdiag_heat(:,:) , ktype = jp_r8 ) ! ice heat spurious lost/gain + ! other diags + CALL iom_rstput( 0, 0, inum, 'aneg_count', pdiag_amin(:,:) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'vneg_count', pdiag_vmin(:,:) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'sneg_count', pdiag_smin(:,:) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'eneg_count', pdiag_emin(:,:) , ktype = jp_r8 ) ! + ! mean state + CALL iom_rstput( 0, 0, inum, 'icecon' , SUM(a_i ,dim=3) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'icevol' , SUM(v_i ,dim=3) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'snwvol' , SUM(v_s ,dim=3) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'pndvol' , SUM(v_ip,dim=3) , ktype = jp_r8 ) ! + CALL iom_rstput( 0, 0, inum, 'lidvol' , SUM(v_il,dim=3) , ktype = jp_r8 ) ! + + CALL iom_close( inum ) + + END SUBROUTINE ice_cons_wri + + SUBROUTINE ice_ctl( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_ctl *** + !! + !! ** Purpose : control checks + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER :: ja, ji, jj, jk, jl ! dummy loop indices + INTEGER :: ialert_id ! number of the current alert + REAL(wp) :: ztmelts ! ice layer melting point + CHARACTER (len=30), DIMENSION(20) :: cl_alname ! name of alert + INTEGER , DIMENSION(20) :: inb_alp ! number of alerts positive + !!------------------------------------------------------------------- + inb_alp(:) = 0 + ialert_id = 0 + + ! Alert if very high salinity + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + IF( v_i(ji,jj,jl) > epsi10 ) THEN + IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN + WRITE(numout,*) ' ALERTE : Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) + WRITE(numout,*) ' at i,j,l = ',ji,jj,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + ENDIF + END DO + END DO + END DO + + ! Alert if very low salinity + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + IF( v_i(ji,jj,jl) > epsi10 ) THEN + IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN + WRITE(numout,*) ' ALERTE : Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) + WRITE(numout,*) ' at i,j,l = ',ji,jj,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + ENDIF + END DO + END DO + END DO + + ! Alert if very cold ice + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 + IF( t_i(ji,jj,jk,jl) < -50.+rt0 .AND. v_i(ji,jj,jl) > epsi10 ) THEN + WRITE(numout,*) ' ALERTE : Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) + WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + END DO + END DO + + ! Alert if very warm ice + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 + IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > epsi10 ) THEN + WRITE(numout,*) ' ALERTE : Very warm ice',(t_i(ji,jj,jk,jl)-rt0) + WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + END DO + END DO + + ! Alerte if very thick ice + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert + jl = jpl + DO jj = 1, jpj + DO ji = 1, jpi + IF( h_i(ji,jj,jl) > 50._wp ) THEN + WRITE(numout,*) ' ALERTE : Very thick ice ',h_i(ji,jj,jl) + WRITE(numout,*) ' at i,j,l = ',ji,jj,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + + ! Alerte if very thin ice + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert + jl = 1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( h_i(ji,jj,jl) < rn_himin ) THEN + WRITE(numout,*) ' ALERTE : Very thin ice ',h_i(ji,jj,jl) + WRITE(numout,*) ' at i,j,l = ',ji,jj,jl + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + + ! Alert if very fast ice + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert + DO jj = 1, jpj + DO ji = 1, jpi + IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN + WRITE(numout,*) ' ALERTE : Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) + WRITE(numout,*) ' at i,j = ',ji,jj + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + + ! Alert if there is ice on continents + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN + WRITE(numout,*) ' ALERTE : Ice on continents ',at_i(ji,jj),vt_i(ji,jj) + WRITE(numout,*) ' at i,j = ',ji,jj + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + + ! Alert if incompatible ice concentration and volume + ialert_id = ialert_id + 1 ! reference number of this alert + cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert + DO jj = 1, jpj + DO ji = 1, jpi + IF( ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. & + & ( vt_i(ji,jj) > 0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN + WRITE(numout,*) ' ALERTE : Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) + WRITE(numout,*) ' at i,j = ',ji,jj + inb_alp(ialert_id) = inb_alp(ialert_id) + 1 + ENDIF + END DO + END DO + + ! sum of the alerts on all processors + IF( lk_mpp ) THEN + DO ja = 1, ialert_id + CALL mpp_sum('icectl', inb_alp(ja)) + END DO + ENDIF + + ! print alerts + IF( lwp ) THEN + WRITE(numout,*) ' time step ',kt + WRITE(numout,*) ' All alerts at the end of ice model ' + DO ja = 1, ialert_id + WRITE(numout,*) ja, cl_alname(ja)//' : ', inb_alp(ja), ' times ! ' + END DO + ENDIF + ! + END SUBROUTINE ice_ctl + + SUBROUTINE ice_prt( kt, ki, kj, kn, cd1 ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_prt *** + !! + !! ** Purpose : Writes global ice state on the (i,j) point + !! in ocean.ouput + !! 3 possibilities exist + !! n = 1/-1 -> simple ice state + !! n = 2 -> exhaustive state + !! n = 3 -> ice/ocean salt fluxes + !! + !! ** input : point coordinates (i,j) + !! n : number of the option + !!------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time step + INTEGER , INTENT(in) :: ki, kj, kn ! ocean gridpoint indices + CHARACTER(len=*), INTENT(in) :: cd1 ! + !! + INTEGER :: jl, ji, jj + !!------------------------------------------------------------------- + + DO ji = mi0(ki), mi1(ki) + DO jj = mj0(kj), mj1(kj) + + WRITE(numout,*) ' time step ',kt,' ',cd1 ! print title + + !---------------- + ! Simple state + !---------------- + + IF ( kn == 1 .OR. kn == -1 ) THEN + WRITE(numout,*) ' ice_prt - Point : ',ji,jj + WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' + WRITE(numout,*) ' Simple state ' + WRITE(numout,*) ' masks s,u,v : ', tmask(ji,jj,1), umask(ji,jj,1), vmask(ji,jj,1) + WRITE(numout,*) ' lat - long : ', gphit(ji,jj), glamt(ji,jj) + WRITE(numout,*) ' - Ice drift ' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + WRITE(numout,*) ' u_ice(i-1,j) : ', u_ice(ji-1,jj) + WRITE(numout,*) ' u_ice(i ,j) : ', u_ice(ji,jj) + WRITE(numout,*) ' v_ice(i ,j-1): ', v_ice(ji,jj-1) + WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) + WRITE(numout,*) ' strength : ', strength(ji,jj) + WRITE(numout,*) ' - Cell values ' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + WRITE(numout,*) ' at_i : ', at_i(ji,jj) + WRITE(numout,*) ' ato_i : ', ato_i(ji,jj) + WRITE(numout,*) ' vt_i : ', vt_i(ji,jj) + WRITE(numout,*) ' vt_s : ', vt_s(ji,jj) + DO jl = 1, jpl + WRITE(numout,*) ' - Category (', jl,')' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) + WRITE(numout,*) ' h_i : ', h_i(ji,jj,jl) + WRITE(numout,*) ' h_s : ', h_s(ji,jj,jl) + WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) + WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) + WRITE(numout,*) ' e_s : ', e_s(ji,jj,1:nlay_s,jl) + WRITE(numout,*) ' e_i : ', e_i(ji,jj,1:nlay_i,jl) + WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) + WRITE(numout,*) ' t_snow : ', t_s(ji,jj,1:nlay_s,jl) + WRITE(numout,*) ' t_i : ', t_i(ji,jj,1:nlay_i,jl) + WRITE(numout,*) ' s_i : ', s_i(ji,jj,jl) + WRITE(numout,*) ' sv_i : ', sv_i(ji,jj,jl) + WRITE(numout,*) + END DO + ENDIF + + !-------------------- + ! Exhaustive state + !-------------------- + + IF ( kn .EQ. 2 ) THEN + WRITE(numout,*) ' ice_prt - Point : ',ji,jj + WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' + WRITE(numout,*) ' Exhaustive state ' + WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' - Cell values ' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + WRITE(numout,*) ' at_i : ', at_i(ji,jj) + WRITE(numout,*) ' vt_i : ', vt_i(ji,jj) + WRITE(numout,*) ' vt_s : ', vt_s(ji,jj) + WRITE(numout,*) ' u_ice(i-1,j) : ', u_ice(ji-1,jj) + WRITE(numout,*) ' u_ice(i ,j) : ', u_ice(ji,jj) + WRITE(numout,*) ' v_ice(i ,j-1): ', v_ice(ji,jj-1) + WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) + WRITE(numout,*) ' strength : ', strength(ji,jj) + WRITE(numout,*) + + DO jl = 1, jpl + WRITE(numout,*) ' - Category (',jl,')' + WRITE(numout,*) ' ~~~~~~~~ ' + WRITE(numout,*) ' h_i : ', h_i(ji,jj,jl) , ' h_s : ', h_s(ji,jj,jl) + WRITE(numout,*) ' t_i : ', t_i(ji,jj,1:nlay_i,jl) + WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) , ' t_s : ', t_s(ji,jj,1:nlay_s,jl) + WRITE(numout,*) ' s_i : ', s_i(ji,jj,jl) , ' o_i : ', o_i(ji,jj,jl) + WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) , ' a_i_b : ', a_i_b(ji,jj,jl) + WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) , ' v_i_b : ', v_i_b(ji,jj,jl) + WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) , ' v_s_b : ', v_s_b(ji,jj,jl) + WRITE(numout,*) ' e_i1 : ', e_i(ji,jj,1,jl) , ' ei1 : ', e_i_b(ji,jj,1,jl) + WRITE(numout,*) ' e_i2 : ', e_i(ji,jj,2,jl) , ' ei2_b : ', e_i_b(ji,jj,2,jl) + WRITE(numout,*) ' e_snow : ', e_s(ji,jj,1,jl) , ' e_snow_b : ', e_s_b(ji,jj,1,jl) + WRITE(numout,*) ' sv_i : ', sv_i(ji,jj,jl) , ' sv_i_b : ', sv_i_b(ji,jj,jl) + END DO !jl + + WRITE(numout,*) + WRITE(numout,*) ' - Heat / FW fluxes ' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~ ' + WRITE(numout,*) ' - Heat fluxes in and out the ice ***' + WRITE(numout,*) ' qsr_ini : ', (1._wp-at_i_b(ji,jj)) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) + WRITE(numout,*) ' qns_ini : ', (1._wp-at_i_b(ji,jj)) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) + WRITE(numout,*) + WRITE(numout,*) + WRITE(numout,*) ' sst : ', sst_m(ji,jj) + WRITE(numout,*) ' sss : ', sss_m(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' - Stresses ' + WRITE(numout,*) ' ~~~~~~~~ ' + WRITE(numout,*) ' utau_ice : ', utau_ice(ji,jj) + WRITE(numout,*) ' vtau_ice : ', vtau_ice(ji,jj) + WRITE(numout,*) ' utau : ', utau (ji,jj) + WRITE(numout,*) ' vtau : ', vtau (ji,jj) + ENDIF + + !--------------------- + ! Salt / heat fluxes + !--------------------- + + IF ( kn .EQ. 3 ) THEN + WRITE(numout,*) ' ice_prt - Point : ',ji,jj + WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' + WRITE(numout,*) ' - Salt / Heat Fluxes ' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~ ' + WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' - Heat fluxes at bottom interface ***' + WRITE(numout,*) ' qsr : ', qsr(ji,jj) + WRITE(numout,*) ' qns : ', qns(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' hfx_mass : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj) + WRITE(numout,*) ' qt_atm_oi : ', qt_atm_oi(ji,jj) + WRITE(numout,*) ' qt_oce_ai : ', qt_oce_ai(ji,jj) + WRITE(numout,*) ' dhc : ', diag_heat(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' hfx_dyn : ', hfx_dyn(ji,jj) + WRITE(numout,*) ' hfx_thd : ', hfx_thd(ji,jj) + WRITE(numout,*) ' hfx_res : ', hfx_res(ji,jj) + WRITE(numout,*) ' qsb_ice_bot : ', qsb_ice_bot(ji,jj) + WRITE(numout,*) ' qlead : ', qlead(ji,jj) * r1_rdtice + WRITE(numout,*) + WRITE(numout,*) ' - Salt fluxes at bottom interface ***' + WRITE(numout,*) ' emp : ', emp (ji,jj) + WRITE(numout,*) ' sfx : ', sfx (ji,jj) + WRITE(numout,*) ' sfx_res : ', sfx_res(ji,jj) + WRITE(numout,*) ' sfx_bri : ', sfx_bri(ji,jj) + WRITE(numout,*) ' sfx_dyn : ', sfx_dyn(ji,jj) + WRITE(numout,*) + WRITE(numout,*) ' - Momentum fluxes ' + WRITE(numout,*) ' utau : ', utau(ji,jj) + WRITE(numout,*) ' vtau : ', vtau(ji,jj) + ENDIF + WRITE(numout,*) ' ' + ! + END DO + END DO + ! + END SUBROUTINE ice_prt + + SUBROUTINE ice_prt3D( cd_routine ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_prt3D *** + !! + !! ** Purpose : CTL prints of ice arrays in case ln_ctl is activated + !! + !!------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine + INTEGER :: jk, jl ! dummy loop indices + + CALL prt_ctl_info(' ========== ') + CALL prt_ctl_info( cd_routine ) + CALL prt_ctl_info(' ========== ') + CALL prt_ctl_info(' - Cell values : ') + CALL prt_ctl_info(' ~~~~~~~~~~~~~ ') + CALL prt_ctl(tab2d_1=CASTSP(e1e2t) , clinfo1=' cell area :') + CALL prt_ctl(tab2d_1=CASTSP(at_i) , clinfo1=' at_i :') + CALL prt_ctl(tab2d_1=CASTSP(ato_i) , clinfo1=' ato_i :') + CALL prt_ctl(tab2d_1=vt_i , clinfo1=' vt_i :') + CALL prt_ctl(tab2d_1=vt_s , clinfo1=' vt_s :') + CALL prt_ctl(tab2d_1=CASTSP(divu_i) , clinfo1=' divu_i :') + CALL prt_ctl(tab2d_1=CASTSP(delta_i) , clinfo1=' delta_i :') + CALL prt_ctl(tab2d_1=CASTSP(stress1_i) , clinfo1=' stress1_i :') + CALL prt_ctl(tab2d_1=CASTSP(stress2_i) , clinfo1=' stress2_i :') + CALL prt_ctl(tab2d_1=CASTSP(stress12_i) , clinfo1=' stress12_i :') + CALL prt_ctl(tab2d_1=strength , clinfo1=' strength :') + CALL prt_ctl(tab2d_1=CASTSP(delta_i) , clinfo1=' delta_i :') + CALL prt_ctl(tab2d_1=u_ice , clinfo1=' u_ice :', tab2d_2=v_ice , clinfo2=' v_ice :') + + DO jl = 1, jpl + CALL prt_ctl_info(' ') + CALL prt_ctl_info(' - Category : ', ivar1=jl) + CALL prt_ctl_info(' ~~~~~~~~~~') + CALL prt_ctl(tab2d_1=CASTSP(h_i (:,:,jl) ) , clinfo1= ' h_i : ') + CALL prt_ctl(tab2d_1=CASTSP(h_s (:,:,jl) ) , clinfo1= ' h_s : ') + CALL prt_ctl(tab2d_1=CASTSP(t_su (:,:,jl) ) , clinfo1= ' t_su : ') + CALL prt_ctl(tab2d_1=CASTSP(t_s (:,:,1,jl) ) , clinfo1= ' t_snow : ') + CALL prt_ctl(tab2d_1=CASTSP(s_i (:,:,jl) ) , clinfo1= ' s_i : ') + CALL prt_ctl(tab2d_1=o_i (:,:,jl) , clinfo1= ' o_i : ') + CALL prt_ctl(tab2d_1=CASTSP(a_i (:,:,jl) ) , clinfo1= ' a_i : ') + CALL prt_ctl(tab2d_1=CASTSP(v_i (:,:,jl) ) , clinfo1= ' v_i : ') + CALL prt_ctl(tab2d_1=CASTSP(v_s (:,:,jl) ) , clinfo1= ' v_s : ') + CALL prt_ctl(tab2d_1=CASTSP(e_s (:,:,1,jl)) , clinfo1= ' e_snow : ') + CALL prt_ctl(tab2d_1=CASTSP(sv_i (:,:,jl) ) , clinfo1= ' sv_i : ') + CALL prt_ctl(tab2d_1=CASTSP(oa_i (:,:,jl) ) , clinfo1= ' oa_i : ') + + DO jk = 1, nlay_i + CALL prt_ctl_info(' - Layer : ', ivar1=jk) + CALL prt_ctl(tab2d_1=CASTSP(t_i(:,:,jk,jl)) , clinfo1= ' t_i : ') + CALL prt_ctl(tab2d_1=CASTSP(e_i(:,:,jk,jl)) , clinfo1= ' e_i : ') + END DO + END DO + + CALL prt_ctl_info(' ') + CALL prt_ctl_info(' - Stresses : ') + CALL prt_ctl_info(' ~~~~~~~~~~ ') + CALL prt_ctl(tab2d_1=utau , clinfo1= ' utau : ', tab2d_2=vtau , clinfo2= ' vtau : ') + CALL prt_ctl(tab2d_1=utau_ice , clinfo1= ' utau_ice : ', tab2d_2=vtau_ice , clinfo2= ' vtau_ice : ') + + END SUBROUTINE ice_prt3D + + + SUBROUTINE ice_drift_wri( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_drift_wri *** + !! + !! ** Purpose : conservation of mass, salt and heat + !! write the drift in a ascii file at each time step + !! and the total run drifts + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ice time-step index + ! + INTEGER :: ji, jj + REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat, zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat + !!REAL(wp), DIMENSION(jpi,jpj) :: zdiag_mass2D, zdiag_salt2D, zdiag_heat2D + !!------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_drift_wri: sea-ice drifts' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + !clem: the following lines check the ice drift in 2D. + ! to use this check, uncomment those lines and add the 3 fields in field_def_ice.xml + !!! 2D budgets (must be close to 0) + !!IF( iom_use('icedrift_mass') .OR. iom_use('icedrift_salt') .OR. iom_use('icedrift_heat') ) THEN + !! DO jj = 1, jpj + !! DO ji = 1, jpi + !! zdiag_mass2D(ji,jj) = wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_spr(ji,jj) + wfx_sub(ji,jj) + wfx_pnd(ji,jj) & + !! & + diag_vice(ji,jj) + diag_vsnw(ji,jj) + diag_vpnd(ji,jj) - diag_adv_mass(ji,jj) + !! zdiag_salt2D(ji,jj) = sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj) + !! zdiag_heat2D(ji,jj) = qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj) + !! END DO + !! END DO + !! ! + !! ! write outputs + !! CALL iom_put( 'icedrift_mass', zdiag_mass2D ) + !! CALL iom_put( 'icedrift_salt', zdiag_salt2D ) + !! CALL iom_put( 'icedrift_heat', zdiag_heat2D ) + !!ENDIF + + ! -- mass diag -- ! + zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + wfx_pnd + diag_vice + diag_vsnw + diag_vpnd - diag_adv_mass ) * e1e2t ) * rdt_ice + zdiag_adv_mass = glob_sum( 'icectl', diag_adv_mass * e1e2t ) * rdt_ice + + ! -- salt diag -- ! + zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) * rdt_ice * 1.e-3 + zdiag_adv_salt = glob_sum( 'icectl', diag_adv_salt * e1e2t ) * rdt_ice * 1.e-3 + + ! -- heat diag -- ! + zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ) + zdiag_adv_heat = glob_sum( 'icectl', diag_adv_heat * e1e2t ) + + ! ! write out to file + IF( lwp ) THEN + ! check global drift (must be close to 0) + WRITE(numicedrift,FMT='(2x,i6,3x,a19,4x,f25.5)') kt, 'mass drift [kg]', zdiag_mass + WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'salt drift [kg]', zdiag_salt + WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'heat drift [W] ', zdiag_heat + ! check drift from advection scheme (can be /=0 with bdy but not sure why) + WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'mass drift adv [kg]', zdiag_adv_mass + WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'salt drift adv [kg]', zdiag_adv_salt + WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'heat drift adv [W] ', zdiag_adv_heat + ENDIF + ! ! drifts + rdiag_icemass = rdiag_icemass + zdiag_mass + rdiag_icesalt = rdiag_icesalt + zdiag_salt + rdiag_iceheat = rdiag_iceheat + zdiag_heat + rdiag_adv_icemass = rdiag_adv_icemass + zdiag_adv_mass + rdiag_adv_icesalt = rdiag_adv_icesalt + zdiag_adv_salt + rdiag_adv_iceheat = rdiag_adv_iceheat + zdiag_adv_heat + ! + ! ! output drifts and close ascii file + IF( kt == nitend - nn_fsbc + 1 .AND. lwp ) THEN + ! to ascii file + WRITE(numicedrift,*) '******************************************' + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run mass drift [kg]', rdiag_icemass + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run mass drift adv [kg]', rdiag_adv_icemass + WRITE(numicedrift,*) '******************************************' + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run salt drift [kg]', rdiag_icesalt + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run salt drift adv [kg]', rdiag_adv_icesalt + WRITE(numicedrift,*) '******************************************' + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run heat drift [W] ', rdiag_iceheat + WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run heat drift adv [W] ', rdiag_adv_iceheat + CLOSE( numicedrift ) + ! + ! to ocean output + WRITE(numout,*) + WRITE(numout,*) 'ice_drift_wri: ice drifts information for the run ' + WRITE(numout,*) '~~~~~~~~~~~~~' + ! check global drift (must be close to 0) + WRITE(numout,*) ' sea-ice mass drift [kg] = ', rdiag_icemass + WRITE(numout,*) ' sea-ice salt drift [kg] = ', rdiag_icesalt + WRITE(numout,*) ' sea-ice heat drift [W] = ', rdiag_iceheat + ! check drift from advection scheme (can be /=0 with bdy but not sure why) + WRITE(numout,*) ' sea-ice mass drift adv [kg] = ', rdiag_adv_icemass + WRITE(numout,*) ' sea-ice salt drift adv [kg] = ', rdiag_adv_icesalt + WRITE(numout,*) ' sea-ice heat drift adv [W] = ', rdiag_adv_iceheat + ENDIF + ! + END SUBROUTINE ice_drift_wri + + SUBROUTINE ice_drift_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_drift_init *** + !! + !! ** Purpose : create output file, initialise arrays + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_icediachk ) RETURN ! exit + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_drift_init: Output ice drifts to ',TRIM(clname), ' file' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) + ! + ! create output ascii file + CALL ctl_opn( numicedrift, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, narea ) + WRITE(numicedrift,*) 'Timestep Drifts' + WRITE(numicedrift,*) '******************************************' + ENDIF + ! + rdiag_icemass = 0._wp + rdiag_icesalt = 0._wp + rdiag_iceheat = 0._wp + rdiag_adv_icemass = 0._wp + rdiag_adv_icesalt = 0._wp + rdiag_adv_iceheat = 0._wp + ! + END SUBROUTINE ice_drift_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty Module No SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icectl \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icectl.mod b/V4.0/nemo_sources/src/ICE/icectl.mod new file mode 100644 index 0000000000000000000000000000000000000000..bc6349fae400df487199e0c0db1bba7fe8495574 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icectl.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedia.F90 b/V4.0/nemo_sources/src/ICE/icedia.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d24b685f1ea62a879ca8935f9c6df0691e57137f --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedia.F90 @@ -0,0 +1,288 @@ +MODULE icedia + !!====================================================================== + !! *** MODULE icedia *** + !! Sea-Ice: global budgets + !!====================================================================== + !! History : 3.4 ! 2012-10 (C. Rousset) original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dia : diagnostic of the sea-ice global heat content, salt content and volume conservation + !! ice_dia_init : initialization of budget calculation + !! ice_dia_rst : read/write budgets restart + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE phycst ! physical constant + USE daymod ! model calendar + USE sbc_oce , ONLY : sfx, nn_fsbc ! surface boundary condition: ocean fields + USE ice ! sea-ice: variables + USE icerst ! sea-ice: restart + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dia ! called by icestp.F90 + PUBLIC ice_dia_init ! called in icestp.F90 + + REAL(wp), SAVE :: z1_e1e2 ! inverse of the ocean area + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents + REAL(wp) :: frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot ! global forcing trends + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedia.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION ice_dia_alloc() + !!---------------------------------------------------------------------! + !! *** ROUTINE ice_dia_alloc *** + !!---------------------------------------------------------------------! + ALLOCATE( vol_loc_ini(jpi,jpj), sal_loc_ini(jpi,jpj), tem_loc_ini(jpi,jpj), STAT=ice_dia_alloc ) + + CALL mpp_sum ( 'icedia', ice_dia_alloc ) + IF( ice_dia_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_dia_alloc: failed to allocate arrays' ) + ! + END FUNCTION ice_dia_alloc + + SUBROUTINE ice_dia( kt ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE ice_dia *** + !! + !! ** Purpose: Compute the sea-ice global heat content, salt content + !! and volume conservation + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !! + REAL(wp) :: zbg_ivol, zbg_item, zbg_area, zbg_isal + REAL(wp) :: zbg_svol, zbg_stem + REAL(wp) :: z_frc_voltop, z_frc_temtop, z_frc_sal + REAL(wp) :: z_frc_volbot, z_frc_tembot + REAL(wp) :: zdiff_vol, zdiff_sal, zdiff_tem + !!--------------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('ice_dia') + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'icedia: output ice diagnostics (integrated over the domain)' + WRITE(numout,*)'~~~~~~' + ENDIF + + IF( kt == nit000 ) THEN + z1_e1e2 = 1._wp / glob_sum( 'icedia', e1e2t(:,:)) + ENDIF + + ! ----------------------- ! + ! 1 - Contents ! + ! ----------------------- ! + IF( iom_use('ibgvol_tot' ) .OR. iom_use('sbgvol_tot' ) .OR. iom_use('ibgarea_tot') .OR. & + & iom_use('ibgsalt_tot') .OR. iom_use('ibgheat_tot') .OR. iom_use('sbgheat_tot') ) THEN + + zbg_ivol = glob_sum( 'icedia', vt_i(:,:) * e1e2t(:,:) ) * 1.e-9 ! ice volume (km3) + zbg_svol = glob_sum( 'icedia', vt_s(:,:) * e1e2t(:,:) ) * 1.e-9 ! snow volume (km3) + zbg_area = glob_sum( 'icedia', at_i(:,:) * e1e2t(:,:) ) * 1.e-6 ! area (km2) + zbg_isal = glob_sum( 'icedia', st_i(:,:) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3) + zbg_item = glob_sum( 'icedia', et_i(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J) + zbg_stem = glob_sum( 'icedia', et_s(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J) + + CALL iom_put( 'ibgvol_tot' , zbg_ivol ) + CALL iom_put( 'sbgvol_tot' , zbg_svol ) + CALL iom_put( 'ibgarea_tot' , zbg_area ) + CALL iom_put( 'ibgsalt_tot' , zbg_isal ) + CALL iom_put( 'ibgheat_tot' , zbg_item ) + CALL iom_put( 'sbgheat_tot' , zbg_stem ) + + ENDIF + + ! ---------------------------! + ! 2 - Trends due to forcing ! + ! ---------------------------! + ! they must be kept outside an IF(iom_use) because of the call to dia_rst below + z_frc_volbot = r1_rau0 * glob_sum( 'icedia', -( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater flux ice/snow-ocean + z_frc_voltop = r1_rau0 * glob_sum( 'icedia', -( wfx_sub(:,:) + wfx_spr(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater flux ice/snow-atm + z_frc_sal = r1_rau0 * glob_sum( 'icedia', - sfx(:,:) * e1e2t(:,:) ) * 1.e-9 ! salt fluxes ice/snow-ocean + z_frc_tembot = glob_sum( 'icedia', qt_oce_ai(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat on top of ocean (and below ice) + z_frc_temtop = glob_sum( 'icedia', qt_atm_oi(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat on top of ice-coean + ! + frc_voltop = frc_voltop + z_frc_voltop * rdt_ice ! km3 + frc_volbot = frc_volbot + z_frc_volbot * rdt_ice ! km3 + frc_sal = frc_sal + z_frc_sal * rdt_ice ! km3*pss + frc_temtop = frc_temtop + z_frc_temtop * rdt_ice ! 1.e20 J + frc_tembot = frc_tembot + z_frc_tembot * rdt_ice ! 1.e20 J + + CALL iom_put( 'ibgfrcvoltop' , frc_voltop ) ! vol forcing ice/snw-atm (km3 equivalent ocean water) + CALL iom_put( 'ibgfrcvolbot' , frc_volbot ) ! vol forcing ice/snw-ocean (km3 equivalent ocean water) + CALL iom_put( 'ibgfrcsal' , frc_sal ) ! sal - forcing (psu*km3 equivalent ocean water) + CALL iom_put( 'ibgfrctemtop' , frc_temtop ) ! heat on top of ice/snw/ocean (1.e20 J) + CALL iom_put( 'ibgfrctembot' , frc_tembot ) ! heat on top of ocean(below ice) (1.e20 J) + + IF( iom_use('ibgfrchfxtop') .OR. iom_use('ibgfrchfxbot') ) THEN + CALL iom_put( 'ibgfrchfxtop' , frc_temtop * z1_e1e2 * 1.e-20 * kt*rdt ) ! heat on top of ice/snw/ocean (W/m2) + CALL iom_put( 'ibgfrchfxbot' , frc_tembot * z1_e1e2 * 1.e-20 * kt*rdt ) ! heat on top of ocean(below ice) (W/m2) + ENDIF + + ! ---------------------------------- ! + ! 3 - Content variations and drifts ! + ! ---------------------------------- ! + IF( iom_use('ibgvolume') .OR. iom_use('ibgsaltco') .OR. iom_use('ibgheatco') .OR. iom_use('ibgheatfx') ) THEN + + zdiff_vol = r1_rau0 * glob_sum( 'icedia', ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater trend (km3) + zdiff_sal = r1_rau0 * glob_sum( 'icedia', ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! salt content trend (km3*pss) + zdiff_tem = glob_sum( 'icedia', ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20 ! heat content trend (1.e20 J) + ! + SUM( qevap_ice * a_i_b, dim=3 ) !! clem: I think this term should not be there (but needs a check) + + zdiff_vol = zdiff_vol - ( frc_voltop + frc_volbot ) + zdiff_sal = zdiff_sal - frc_sal + zdiff_tem = zdiff_tem - ( frc_tembot - frc_temtop ) + + CALL iom_put( 'ibgvolume' , zdiff_vol ) ! ice/snow volume drift (km3 equivalent ocean water) + CALL iom_put( 'ibgsaltco' , zdiff_sal ) ! ice salt content drift (psu*km3 equivalent ocean water) + CALL iom_put( 'ibgheatco' , zdiff_tem ) ! ice/snow heat content drift (1.e20 J) + ! + ENDIF + + IF( lrst_ice ) CALL ice_dia_rst( 'WRITE', kt_ice ) + ! + IF( ln_timing ) CALL timing_stop('ice_dia') + ! + END SUBROUTINE ice_dia + + + SUBROUTINE ice_dia_init + !!--------------------------------------------------------------------------- + !! *** ROUTINE ice_dia_init *** + !! + !! ** 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 :: ios, ierror ! local integer + !! + NAMELIST/namdia/ ln_icediachk, rn_icechk_cel, rn_icechk_glo, ln_icediahsb, ln_icectl, iiceprt, jiceprt + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namdia in reference namelist : Parameters for ice + READ ( numnam_ice_ref, namdia, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdia in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namdia in configuration namelist : Parameters for ice + READ ( numnam_ice_cfg, namdia, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdia in configuration namelist' ) + IF(lwm) WRITE ( numoni, namdia ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_dia_init: ice diagnostics' + WRITE(numout,*) ' ~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdia:' + WRITE(numout,*) ' Diagnose online heat/mass/salt conservation ln_icediachk = ', ln_icediachk + WRITE(numout,*) ' threshold for conservation (gridcell) rn_icechk_cel = ', rn_icechk_cel + WRITE(numout,*) ' threshold for conservation (global) rn_icechk_glo = ', rn_icechk_glo + WRITE(numout,*) ' Output heat/mass/salt budget ln_icediahsb = ', ln_icediahsb + WRITE(numout,*) ' control prints for a given grid point ln_icectl = ', ln_icectl + WRITE(numout,*) ' chosen grid point position (iiceprt,jiceprt) = (', iiceprt,',', jiceprt,')' + ENDIF + ! + IF( ln_icediahsb ) THEN + IF( ice_dia_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'ice_dia_init : unable to allocate arrays' ) ! allocate tke arrays + CALL ice_dia_rst( 'READ' ) ! read or initialize all required files + ENDIF + ! + END SUBROUTINE ice_dia_init + + + SUBROUTINE ice_dia_rst( cdrw, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE icedia_rst *** + !! + !! ** Purpose : Read or write DIA file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in) :: cdrw ! "READ"/"WRITE" flag + INTEGER, OPTIONAL, INTENT(in) :: kt ! ice time-step + ! + INTEGER :: iter ! local integer + REAL(wp) :: ziter ! local scalar + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + IF( ln_rstart ) THEN !* Read the restart file + ! + CALL iom_get( numrir, 'kt_ice' , ziter ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_dia_rst read at time step = ', ziter + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + CALL iom_get( numrir, 'frc_voltop' , frc_voltop ) + CALL iom_get( numrir, 'frc_volbot' , frc_volbot ) + CALL iom_get( numrir, 'frc_temtop' , frc_temtop ) + CALL iom_get( numrir, 'frc_tembot' , frc_tembot ) + CALL iom_get( numrir, 'frc_sal' , frc_sal ) + CALL iom_get( numrir, jpdom_autoglo, 'vol_loc_ini', vol_loc_ini ) + CALL iom_get( numrir, jpdom_autoglo, 'tem_loc_ini', tem_loc_ini ) + CALL iom_get( numrir, jpdom_autoglo, 'sal_loc_ini', sal_loc_ini ) + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ice_dia at initial state ' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ! set trends to 0 + frc_voltop = 0._wp + frc_volbot = 0._wp + frc_temtop = 0._wp + frc_tembot = 0._wp + frc_sal = 0._wp + ! record initial ice volume, salt and temp + vol_loc_ini(:,:) = rhoi * vt_i(:,:) + rhos * vt_s(:,:) ! ice/snow volume (kg/m2) + tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J) + sal_loc_ini(:,:) = rhoi * st_i(:,:) ! ice salt content (pss*kg/m2) + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 + ! + IF( iter == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_dia_rst write at time step = ', kt + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + ! Write in numriw (if iter == nitrst) + ! ------------------ + CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop ) + CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot ) + CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop ) + CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot ) + CALL iom_rstput( iter, nitrst, numriw, 'frc_sal' , frc_sal ) + CALL iom_rstput( iter, nitrst, numriw, 'vol_loc_ini', vol_loc_ini ) + CALL iom_rstput( iter, nitrst, numriw, 'tem_loc_ini', tem_loc_ini ) + CALL iom_rstput( iter, nitrst, numriw, 'sal_loc_ini', sal_loc_ini ) + ! + ENDIF + ! + END SUBROUTINE ice_dia_rst + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedia \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icedia.mod b/V4.0/nemo_sources/src/ICE/icedia.mod new file mode 100644 index 0000000000000000000000000000000000000000..327bb294fd42e1422e5b577b3c4e07b2779266f8 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedia.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn.F90 b/V4.0/nemo_sources/src/ICE/icedyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f2abcbe2722cb545d277b32dd28653f9b28f6b86 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn.F90 @@ -0,0 +1,289 @@ +MODULE icedyn + !!====================================================================== + !! *** MODULE icedyn *** + !! Sea-Ice dynamics : master routine for sea ice dynamics + !!====================================================================== + !! history : 4.0 ! 2018 (C. Rousset) original code SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn : dynamics of sea ice + !! ice_dyn_init : initialization and namelist read + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE ice ! sea-ice: variables + USE icedyn_rhg ! sea-ice: rheology + USE icedyn_adv ! sea-ice: advection + USE icedyn_rdgrft ! sea-ice: ridging/rafting + USE icecor ! sea-ice: corrections + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: control prints + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn ! called by icestp.F90 + PUBLIC ice_dyn_init ! called by icestp.F90 + + INTEGER :: nice_dyn ! choice of the type of dynamics + ! ! associated indices: + INTEGER, PARAMETER :: np_dynALL = 1 ! full ice dynamics (rheology + advection + ridging/rafting + correction) + INTEGER, PARAMETER :: np_dynRHGADV = 2 ! pure dynamics (rheology + advection) + INTEGER, PARAMETER :: np_dynADV1D = 3 ! only advection 1D - test case from Schar & Smolarkiewicz 1996 + INTEGER, PARAMETER :: np_dynADV2D = 4 ! only advection 2D w prescribed vel.(rn_uvice + advection) + ! + ! ** namelist (namdyn) ** + LOGICAL :: ln_dynALL ! full ice dynamics (rheology + advection + ridging/rafting + correction) + LOGICAL :: ln_dynRHGADV ! no ridge/raft & no corrections (rheology + advection) + LOGICAL :: ln_dynADV1D ! only advection in 1D w ice convergence (test case from Schar & Smolarkiewicz 1996) + LOGICAL :: ln_dynADV2D ! only advection in 2D w prescribed vel. (rn_uvice + advection) + REAL(wp) :: rn_uice ! prescribed u-vel (case np_dynADV1D & np_dynADV2D) + REAL(wp) :: rn_vice ! prescribed v-vel (case np_dynADV1D & np_dynADV2D) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn *** + !! + !! ** Purpose : this routine manages sea ice dynamics + !! + !! ** Action : - calculation of friction in case of landfast ice + !! - call ice_dyn_rhg = rheology + !! - call ice_dyn_adv = advection + !! - call ice_dyn_rdgrft = ridging/rafting + !! - call ice_cor = corrections if fields are out of bounds + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ice time step + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zcoefu, zcoefv + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdivu_i + !!-------------------------------------------------------------------- + ! + ! controls + IF( ln_timing ) CALL timing_start('ice_dyn') + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_dyn: sea-ice dynamics' + WRITE(numout,*)'~~~~~~~' + ENDIF + ! + ! retrieve thickness from volume for landfast param. and UMx advection scheme + WHERE( a_i(:,:,:) >= epsi20 ) + h_i(:,:,:) = v_i(:,:,:) / a_i_b(:,:,:) + h_s(:,:,:) = v_s(:,:,:) / a_i_b(:,:,:) + ELSEWHERE + h_i(:,:,:) = 0._wp + h_s(:,:,:) = 0._wp + END WHERE + ! + WHERE( a_ip(:,:,:) >= epsi20 ) + h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) + h_il(:,:,:) = v_il(:,:,:) / a_ip(:,:,:) + ELSEWHERE + h_ip(:,:,:) = 0._wp + h_il(:,:,:) = 0._wp + END WHERE + ! + ! + SELECT CASE( nice_dyn ) !-- Set which dynamics is running + + CASE ( np_dynALL ) !== all dynamical processes ==! + ! + CALL ice_dyn_rhg ( kt ) ! -- rheology + CALL ice_dyn_adv ( kt ) ! -- advection of ice + CALL ice_dyn_rdgrft( kt ) ! -- ridging/rafting + CALL ice_cor ( kt , 1 ) ! -- Corrections + ! + CASE ( np_dynRHGADV ) !== no ridge/raft & no corrections ==! + ! + CALL ice_dyn_rhg ( kt ) ! -- rheology + CALL ice_dyn_adv ( kt ) ! -- advection of ice + CALL Hpiling ! -- simple pile-up (replaces ridging/rafting) + CALL ice_var_zapsmall( 1, jpj ) ! -- zap small areas + ! + CASE ( np_dynADV1D ) !== pure advection ==! (1D) + ! + ! --- monotonicity test from Schar & Smolarkiewicz 1996 --- ! + ! CFL = 0.5 at a distance from the bound of 1/6 of the basin length + ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s + DO jj = 1, jpj + DO ji = 1, jpi + zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) + zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) + u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) + v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) + END DO + END DO + ! --- + CALL ice_dyn_adv ( kt ) ! -- advection of ice + ! + CASE ( np_dynADV2D ) !== pure advection ==! (2D w prescribed velocities) + ! + u_ice(:,:) = rn_uice * umask(:,:,1) + v_ice(:,:) = rn_vice * vmask(:,:,1) + !CALL RANDOM_NUMBER(u_ice(:,:)) ; u_ice(:,:) = u_ice(:,:) * 0.1 + rn_uice * 0.9 * umask(:,:,1) + !CALL RANDOM_NUMBER(v_ice(:,:)) ; v_ice(:,:) = v_ice(:,:) * 0.1 + rn_vice * 0.9 * vmask(:,:,1) + ! --- + CALL ice_dyn_adv ( kt ) ! -- advection of ice + + END SELECT + ! + ! + ! diagnostics: divergence at T points + IF( iom_use('icediv') ) THEN + ! + SELECT CASE( nice_dyn ) + + CASE ( np_dynADV1D , np_dynADV2D ) + + ALLOCATE( zdivu_i(jpi,jpj) ) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & + & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) + END DO + END DO + CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp ) + ! output + CALL iom_put( 'icediv' , zdivu_i ) + + DEALLOCATE( zdivu_i ) + + END SELECT + ! + ENDIF + ! + ! controls + IF( ln_timing ) CALL timing_stop ('ice_dyn') + ! + END SUBROUTINE ice_dyn + + + SUBROUTINE Hpiling + !!------------------------------------------------------------------- + !! *** ROUTINE Hpiling *** + !! + !! ** Purpose : Simple conservative piling comparable with 1-cat models + !! + !! ** Method : pile-up ice when no ridging/rafting + !! + !! ** input : a_i + !!------------------------------------------------------------------- + INTEGER :: jl ! dummy loop indices + !!------------------------------------------------------------------- + ! controls + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'Hpiling', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + ! + at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) + DO jl = 1, jpl + WHERE( at_i(:,:) > epsi20 ) + a_i(:,:,jl) = a_i(:,:,jl) * ( 1._wp + MIN( rn_amax_2d(:,:) - at_i(:,:) , 0._wp ) / at_i(:,:) ) + END WHERE + END DO + ! controls + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'Hpiling', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + ! + END SUBROUTINE Hpiling + + + SUBROUTINE ice_dyn_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_init *** + !! + !! ** Purpose : Physical constants and parameters linked to the ice + !! dynamics + !! + !! ** Method : Read the namdyn namelist and check the ice-dynamic + !! parameter values called at the first timestep (nit000) + !! + !! ** input : Namelist namdyn + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer output status for namelist read + !! + NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice, & + & rn_ishlat , & + & ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namdyn in reference namelist : Ice dynamics + READ ( numnam_ice_ref, namdyn, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namdyn in configuration namelist : Ice dynamics + READ ( numnam_ice_cfg, namdyn, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn in configuration namelist' ) + IF(lwm) WRITE( numoni, namdyn ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_dyn_init: ice parameters for ice dynamics ' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn:' + WRITE(numout,*) ' Full ice dynamics (rhg + adv + ridge/raft + corr) ln_dynALL = ', ln_dynALL + WRITE(numout,*) ' No ridge/raft & No cor (rhg + adv) ln_dynRHGADV = ', ln_dynRHGADV + WRITE(numout,*) ' Advection 1D only (Schar & Smolarkiewicz 1996) ln_dynADV1D = ', ln_dynADV1D + WRITE(numout,*) ' Advection 2D only (rn_uvice + adv) ln_dynADV2D = ', ln_dynADV2D + WRITE(numout,*) ' with prescribed velocity given by (u,v)_ice = (rn_uice,rn_vice) = (', rn_uice,',',rn_vice,')' + WRITE(numout,*) ' lateral boundary condition for sea ice dynamics rn_ishlat = ', rn_ishlat + WRITE(numout,*) ' Landfast: param from Lemieux 2016 ln_landfast_L16 = ', ln_landfast_L16 + WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_lf_depfra = ', rn_lf_depfra + WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_lf_bfr = ', rn_lf_bfr + WRITE(numout,*) ' relax time scale (s-1) to reach static friction rn_lf_relax = ', rn_lf_relax + WRITE(numout,*) ' isotropic tensile strength rn_lf_tensile = ', rn_lf_tensile + WRITE(numout,*) + ENDIF + ! !== set the choice of ice dynamics ==! + ioptio = 0 + ! !--- full dynamics (rheology + advection + ridging/rafting + correction) + IF( ln_dynALL ) THEN ; ioptio = ioptio + 1 ; nice_dyn = np_dynALL ; ENDIF + ! !--- dynamics without ridging/rafting and corr (rheology + advection) + IF( ln_dynRHGADV ) THEN ; ioptio = ioptio + 1 ; nice_dyn = np_dynRHGADV ; ENDIF + ! !--- advection 1D only - test case from Schar & Smolarkiewicz 1996 + IF( ln_dynADV1D ) THEN ; ioptio = ioptio + 1 ; nice_dyn = np_dynADV1D ; ENDIF + ! !--- advection 2D only with prescribed ice velocities (from namelist) + IF( ln_dynADV2D ) THEN ; ioptio = ioptio + 1 ; nice_dyn = np_dynADV2D ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_init: one and only one ice dynamics option has to be defined ' ) + ! + ! !--- Lateral boundary conditions + IF ( rn_ishlat == 0. ) THEN ; IF(lwp) WRITE(numout,*) ' ===>>> ice lateral free-slip' + ELSEIF ( rn_ishlat == 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ===>>> ice lateral no-slip' + ELSEIF ( 0. < rn_ishlat .AND. rn_ishlat < 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ===>>> ice lateral partial-slip' + ELSEIF ( 2. < rn_ishlat ) THEN ; IF(lwp) WRITE(numout,*) ' ===>>> ice lateral strong-slip' + ENDIF + ! !--- Landfast ice + IF( .NOT.ln_landfast_L16 ) tau_icebfr(:,:) = 0._wp + ! + CALL ice_dyn_rdgrft_init ! set ice ridging/rafting parameters + CALL ice_dyn_rhg_init ! set ice rheology parameters + CALL ice_dyn_adv_init ! set ice advection parameters + ! + END SUBROUTINE ice_dyn_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icedyn.mod b/V4.0/nemo_sources/src/ICE/icedyn.mod new file mode 100644 index 0000000000000000000000000000000000000000..cb11a3e82b74ee1d312d84057c0594802d2b80fd Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv.F90 b/V4.0/nemo_sources/src/ICE/icedyn_adv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0b7e6234948853e314cbc87af5a8237624254410 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_adv.F90 @@ -0,0 +1,215 @@ +MODULE icedyn_adv + !!====================================================================== + !! *** MODULE icedyn_adv *** + !! sea-ice: advection + !!====================================================================== + !! History : 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_adv : advection of sea ice variables + !!---------------------------------------------------------------------- + USE phycst ! physical constant + USE dom_oce ! ocean domain + USE sbc_oce , ONLY : nn_fsbc ! frequency of sea-ice call + USE ice ! sea-ice: variables + USE icevar ! sea-ice: operations + USE icedyn_adv_pra ! sea-ice: advection scheme (Prather) + USE icedyn_adv_umx ! sea-ice: advection scheme (ultimate-macho) + USE icectl ! sea-ice: control prints + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + USE prtctl ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_adv ! called by icestp + PUBLIC ice_dyn_adv_init ! called by icedyn + PUBLIC ice_dyn_rest ! called by asminc%seaice_asm_inc + PUBLIC ice_dyn_asm_init ! called by asminc%init + + INTEGER :: nice_adv ! choice of the type of advection scheme + ! ! associated indices: + INTEGER, PARAMETER :: np_advPRA = 1 ! Prather scheme + INTEGER, PARAMETER :: np_advUMx = 2 ! Ultimate-Macho scheme + ! + ! ** namelist (namdyn_adv) ** + INTEGER :: nn_UMx ! order of the UMx advection scheme + ! + !! * Substitution +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_adv.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn_adv( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_adv *** + !! + !! ** purpose : advection of sea ice + !! + !! ** method : One can choose between + !! a) an Ultimate-Macho scheme (with order defined by nn_UMx) => ln_adv_UMx + !! b) and a second order Prather scheme => ln_adv_Pra + !! + !! ** action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + !!--------------------------------------------------------------------- + ! + ! controls + IF( ln_timing ) CALL timing_start('icedyn_adv') ! timing + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icedyn_adv', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_dyn_adv: sea-ice advection' + WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + !---------------! + !== Advection ==! + !---------------! + SELECT CASE( nice_adv ) + ! !-----------------------! + CASE( np_advUMx ) ! ULTIMATE-MACHO scheme ! + ! !-----------------------! + CALL ice_dyn_adv_umx( nn_UMx, kt, u_ice, v_ice, h_i, h_s, h_ip, & + & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) + ! !-----------------------! + CASE( np_advPRA ) ! PRATHER scheme ! + ! !-----------------------! + CALL ice_dyn_adv_pra( kt, u_ice, v_ice, h_i, h_s, h_ip, & + & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) + END SELECT + + !------------ + ! diagnostics + !------------ + diag_trp_ei(:,:) = SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_rdtice + diag_trp_es(:,:) = SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_rdtice + diag_trp_sv(:,:) = SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_rdtice + diag_trp_vi(:,:) = SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_rdtice + diag_trp_vs(:,:) = SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_rdtice + IF( iom_use('icemtrp') ) CALL iom_put( 'icemtrp' , diag_trp_vi * rhoi ) ! ice mass transport + IF( iom_use('snwmtrp') ) CALL iom_put( 'snwmtrp' , diag_trp_vs * rhos ) ! snw mass transport + IF( iom_use('salmtrp') ) CALL iom_put( 'salmtrp' , diag_trp_sv * rhoi * 1.e-03 ) ! salt mass transport (kg/m2/s) + IF( iom_use('dihctrp') ) CALL iom_put( 'dihctrp' , -diag_trp_ei ) ! advected ice heat content (W/m2) + IF( iom_use('dshctrp') ) CALL iom_put( 'dshctrp' , -diag_trp_es ) ! advected snw heat content (W/m2) + + ! controls + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icedyn_adv', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt,-1, ' - ice dyn & trp - ') ! prints + IF( ln_timing ) CALL timing_stop ('icedyn_adv') ! timing + ! + END SUBROUTINE ice_dyn_adv + + + SUBROUTINE ice_dyn_adv_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_adv_init *** + !! + !! ** Purpose : Physical constants and parameters linked to the ice + !! dynamics + !! + !! ** Method : Read the namdyn_adv namelist and check the ice-dynamic + !! parameter values called at the first timestep (nit000) + !! + !! ** input : Namelist namdyn_adv + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer output status for namelist read + !! + NAMELIST/namdyn_adv/ ln_adv_Pra, ln_adv_UMx, nn_UMx + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namdyn_adv in reference namelist : Ice dynamics + READ ( numnam_ice_ref, namdyn_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namdyn_adv in configuration namelist : Ice dynamics + READ ( numnam_ice_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) + IF(lwm) WRITE( numoni, namdyn_adv ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_dyn_adv_init: ice parameters for ice dynamics ' + WRITE(numout,*) '~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_adv:' + WRITE(numout,*) ' type of advection scheme (Prather) ln_adv_Pra = ', ln_adv_Pra + WRITE(numout,*) ' type of advection scheme (Ulimate-Macho) ln_adv_UMx = ', ln_adv_UMx + WRITE(numout,*) ' order of the Ultimate-Macho scheme nn_UMx = ', nn_UMx + ENDIF + ! + ! !== set the choice of ice advection ==! + ioptio = 0 + IF( ln_adv_Pra ) THEN ; ioptio = ioptio + 1 ; nice_adv = np_advPRA ; ENDIF + IF( ln_adv_UMx ) THEN ; ioptio = ioptio + 1 ; nice_adv = np_advUMx ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_adv_init: choose one and only one ice adv. scheme (ln_adv_Pra or ln_adv_UMx)' ) + ! + IF( ln_adv_Pra ) CALL adv_pra_init !* read or initialize all required files + ! + END SUBROUTINE ice_dyn_adv_init + + SUBROUTINE ice_dyn_rest( nreset ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rest *** + !! + !! ** Purpose : Set higher order moments to 0 for given adv scheme + !! + !! ** Method : Call appropriate routine for the scheme + !! + !!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: nreset ! order moments to reset in advection schemes + + SELECT CASE( nice_adv ) + ! !-----------------------! + CASE( np_advPRA ) ! PRATHER scheme ! + ! !-----------------------! + CALL adv_pra_rest( nreset ) + CASE DEFAULT + CALL ctl_stop( 'ice_dyn_rest: only coded for PRATHER scheme. Not implemented (yet) for other advection schemes' ) + END SELECT + + END SUBROUTINE ice_dyn_rest + + SUBROUTINE ice_dyn_asm_init(ln_seaiceinc) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_asm_init *** + !! + !! ** Purpose : Pass assimilation info to advection schemes and avoid circular dependencies + !! + !! ** Method : Call appropriate routine for the scheme + !! + !!------------------------------------------------------------------- + LOGICAL, intent(in) :: ln_seaiceinc + + SELECT CASE( nice_adv ) + ! !-----------------------! + CASE( np_advPRA ) ! PRATHER scheme ! + ! !-----------------------! + CALL adv_pra_asm_init(ln_seaiceinc) + CASE DEFAULT + CALL ctl_stop( 'ice_dyn_asm_init: only coded for PRATHER scheme. Not implemented (yet) for other advection schemes' ) + END SELECT + + END SUBROUTINE ice_dyn_asm_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty Module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn_adv \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv.mod b/V4.0/nemo_sources/src/ICE/icedyn_adv.mod new file mode 100644 index 0000000000000000000000000000000000000000..f52443bcfba17959d7243920ddca2d6aec5d01f8 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_adv.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.F90 b/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.F90 new file mode 100644 index 0000000000000000000000000000000000000000..61ac0861fcd622379a9d7f76290e6987d36a78f9 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.F90 @@ -0,0 +1,1387 @@ +MODULE icedyn_adv_pra + !!====================================================================== + !! *** MODULE icedyn_adv_pra *** + !! sea-ice : advection => Prather scheme + !!====================================================================== + !! History : ! 2008-03 (M. Vancoppenolle) original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!-------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_adv_pra : advection of sea ice using Prather scheme + !! adv_x, adv_y : Prather scheme applied in i- and j-direction, resp. + !! adv_pra_init : initialisation of the Prather scheme + !! adv_pra_rst : read/write Prather field in ice restart file, or initialized to zero + !!---------------------------------------------------------------------- + USE phycst ! physical constant + USE dom_oce ! ocean domain + USE ice ! sea-ice variables + USE sbc_oce , ONLY : nn_fsbc ! frequency of sea-ice call + USE icevar ! sea-ice: operations + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_adv_pra ! called by icedyn_adv + PUBLIC adv_pra_init ! called by icedyn_adv + PUBLIC adv_pra_rest ! called by icedyn_adv + PUBLIC adv_pra_asm_init ! called by icedyn_adv + + ! Moments for advection + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxice, syice, sxxice, syyice, sxyice ! ice thickness + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxsn , sysn , sxxsn , syysn , sxysn ! snow thickness + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxa , sya , sxxa , syya , sxya ! ice concentration + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxsal, sysal, sxxsal, syysal, sxysal ! ice salinity + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxage, syage, sxxage, syyage, sxyage ! ice age + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sxc0 , syc0 , sxxc0 , syyc0 , sxyc0 ! snow layers heat content + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sxe , sye , sxxe , syye , sxye ! ice layers heat content + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxap , syap , sxxap , syyap , sxyap ! melt pond fraction + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvp , syvp , sxxvp , syyvp , sxyvp ! melt pond volume + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvl , syvl , sxxvl , syyvl , sxyvl ! melt pond lid volume + + LOGICAL :: LN_ASM_SEAICEINC = .false. + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_adv_pra.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn_adv_pra( kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, & + & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + !!---------------------------------------------------------------------- + !! ** routine ice_dyn_adv_pra ** + !! + !! ** purpose : Computes and adds the advection trend to sea-ice + !! + !! ** method : Uses Prather second order scheme that advects tracers + !! but also their quadratic forms. The method preserves + !! tracer structures by conserving second order moments. + !! + !! Reference: Prather, 1986, JGR, 91, D6. 6671-6681. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pu_ice ! ice i-velocity + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pv_ice ! ice j-velocity + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_i ! ice thickness + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_s ! snw thickness + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_ip ! ice pond thickness + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pato_i ! open water area + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i ! ice volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_s ! snw volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: psv_i ! salt content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: poa_i ! age content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_i ! ice concentration + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid thickness + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content + ! + INTEGER :: ji, jj, jk, jl, jt ! dummy loop indices + INTEGER :: icycle ! number of sub-timestep for the advection + REAL(wp) :: zdt, z1_dt ! - - + REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication + REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 + REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max + REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max + REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: ze_s, zes_max + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zarea + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ice, z0snw, z0ai, z0smi, z0oi + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ap , z0vp, z0vl + REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: z0es + REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: z0ei + !! diagnostics + REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat + REAL(wp), DIMENSION(jpi) :: poa_i_dipb + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra') + ! + IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme' + ! + ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! + ! thickness and salinity + WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) + ELSEWHERE ; zs_i(:,:,:) = 0._wp + END WHERE + CALL icemax3D( ph_i , zhi_max ) + CALL icemax3D( ph_s , zhs_max ) + CALL icemax3D( ph_ip, zhip_max) + CALL icemax3D( CASTDP(zs_i) , zsi_max ) + CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp, zsi_max, 'T', 1.0_wp ) + + ! enthalpies + DO jk = 1, nlay_i + WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) + ELSEWHERE ; ze_i(:,:,jk,:) = 0._wp + END WHERE + END DO + DO jk = 1, nlay_s + WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) + ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp + END WHERE + END DO + CALL icemax4D( ze_i , zei_max ) + CALL icemax4D( ze_s , zes_max ) + CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1.0_wp ) + CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1.0_wp ) + ! + ! + ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! + ! Note: the advection split is applied at the next time-step in order to avoid blocking global comm. + ! this should not affect too much the stability + zcflnow(1) = MAXVAL( ABS( pu_ice(:,:) ) * rdt_ice * r1_e1u(:,:) ) + zcflnow(1) = MAX( zcflnow(1), MAXVAL( ABS( pv_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) ) + + ! non-blocking global communication send zcflnow and receive zcflprv + CALL mpp_delay_max( 'icedyn_adv_pra', 'cflice', zcflnow(:), zcflprv(:), kt == nitend - nn_fsbc + 1 ) + + IF( zcflprv(1) > .5 ) THEN ; icycle = 2 + ELSE ; icycle = 1 + ENDIF + zdt = rdt_ice / REAL(icycle) + z1_dt = 1._wp / zdt + + ! --- transport --- ! + zudy(:,:) = pu_ice(:,:) * e2u(:,:) + zvdx(:,:) = pv_ice(:,:) * e1v(:,:) + + DO jt = 1, icycle + + !$omp parallel private(jj,jl,poa_i_dipb) + + !$omp do + DO jj = 1, jpj + + ! diagnostics + zdiag_adv_mass(:,jj) = SUM( pv_i (:,jj,:) , dim=2 ) * rhoi + SUM( pv_s (:,jj,:) , dim=2 ) * rhos & + & + SUM( pv_ip(:,jj,:) , dim=2 ) * rhow + SUM( pv_il(:,jj,:) , dim=2 ) * rhow + zdiag_adv_salt(:,jj) = SUM( psv_i(:,jj,:) , dim=2 ) * rhoi + zdiag_adv_heat(:,jj) = - SUM(SUM( pe_i(:,jj,1:nlay_i,:) , dim=3 ), dim=2 ) & + & - SUM(SUM( pe_s(:,jj,1:nlay_s,:) , dim=3 ), dim=2 ) + + ! record at_i before advection (for open water) + zati1(:,jj) = SUM( pa_i(:,jj,:), dim=2 ) + + END DO + !$omp end do + + ! --- transported fields --- ! + DO jl = 1, jpl + !$omp do + DO jj = 1, jpj + zarea(:,jj,jl) = e1e2t(:,jj) + z0snw(:,jj,jl) = pv_s (:,jj,jl) * e1e2t(:,jj) ! Snow volume + z0ice(:,jj,jl) = pv_i (:,jj,jl) * e1e2t(:,jj) ! Ice volume + z0ai (:,jj,jl) = pa_i (:,jj,jl) * e1e2t(:,jj) ! Ice area + z0smi(:,jj,jl) = psv_i(:,jj,jl) * e1e2t(:,jj) ! Salt content + poa_i_dipb(:) = poa_i(:,jj,jl) ! this stopped a Heisenbug... + z0oi (:,jj,jl) = poa_i(:,jj,jl) * e1e2t(:,jj) ! Age content + DO jk = 1, nlay_s + z0es(:,jj,jk,jl) = pe_s(:,jj,jk,jl) * e1e2t(:,jj) ! Snow heat content + END DO + DO jk = 1, nlay_i + z0ei(:,jj,jk,jl) = pe_i(:,jj,jk,jl) * e1e2t(:,jj) ! Ice heat content + END DO + IF ( ln_pnd_LEV ) THEN + z0ap(:,jj,jl) = pa_ip(:,jj,jl) * e1e2t(:,jj) ! Melt pond fraction + z0vp(:,jj,jl) = pv_ip(:,jj,jl) * e1e2t(:,jj) ! Melt pond volume + IF ( ln_pnd_lids ) THEN + z0vl(:,jj,jl) = pv_il(:,jj,jl) * e1e2t(:,jj) ! Melt pond lid volume + ENDIF + ENDIF + END DO + !$omp end do + END DO + + !$omp end parallel + + ! + ! !--------------------------------------------! + IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! + ! !--------------------------------------------! + CALL adv_x( zdt , zudy , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) + CALL adv_x( zdt , zudy , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) + CALL adv_x( zdt , zudy , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) + CALL adv_x( zdt , zudy , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) + CALL adv_x( zdt , zudy , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) + ! + DO jk = 1, nlay_s !--- snow heat content + CALL adv_x( zdt, zudy, 1._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), & + & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) ) + CALL adv_y( zdt, zvdx, 0._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), & + & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) ) + END DO + DO jk = 1, nlay_i !--- ice heat content + CALL adv_x( zdt, zudy, 1._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), & + & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) + CALL adv_y( zdt, zvdx, 0._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), & + & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) + END DO + ! + IF ( ln_pnd_LEV ) THEN + CALL adv_x( zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) + CALL adv_x( zdt , zudy , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) + IF ( ln_pnd_lids ) THEN + CALL adv_x( zdt , zudy , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume + CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) + ENDIF + ENDIF + ! !--------------------------------------------! + ELSE !== even ice time step: adv_y then adv_x ==! + ! !--------------------------------------------! + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume + CALL adv_x( zdt , zudy , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume + CALL adv_x( zdt , zudy , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity + CALL adv_x( zdt , zudy , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration + CALL adv_x( zdt , zudy , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age + CALL adv_x( zdt , zudy , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) + DO jk = 1, nlay_s !--- snow heat content + CALL adv_y( zdt, zvdx, 1._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), & + & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) ) + CALL adv_x( zdt, zudy, 0._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), & + & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) ) + END DO + DO jk = 1, nlay_i !--- ice heat content + CALL adv_y( zdt, zvdx, 1._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), & + & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) + CALL adv_x( zdt, zudy, 0._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), & + & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) + END DO + IF ( ln_pnd_LEV ) THEN + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction + CALL adv_x( zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume + CALL adv_x( zdt , zudy , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) + IF ( ln_pnd_lids ) THEN + CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume + CALL adv_x( zdt , zudy , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) + ENDIF + ENDIF + ! + ENDIF + + ! --- Lateral boundary conditions --- ! + ! caution: for gradients (sx and sy) the sign changes + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ice , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume + & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp & + & , z0snw , 'T', 1._wp, sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume + & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp ) + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity + & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp & + & , z0ai , 'T', 1._wp, sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration + & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp ) + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0oi , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age + & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp ) + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0es , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy + & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp ) + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy + & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp ) + IF ( ln_pnd_LEV ) THEN + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction + & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp & + & , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume + & , sxxvp, 'T', 1._wp, syyvp, 'T', 1._wp, sxyvp, 'T', 1._wp ) + IF ( ln_pnd_lids ) THEN + CALL lbc_lnk_multi( 'icedyn_adv_pra', z0vl ,'T', 1._wp, sxvl ,'T', -1._wp, syvl ,'T', -1._wp & ! melt pond lid volume + & , sxxvl,'T', 1._wp, syyvl,'T', 1._wp, sxyvl,'T', 1._wp ) + ENDIF + ENDIF + + !$omp parallel private(jj,jl) + + ! --- Recover the properties from their contents --- ! + DO jl = 1, jpl + !$omp do + DO jj = 1, jpj + pv_i (:,jj,jl) = z0ice(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + pv_s (:,jj,jl) = z0snw(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + psv_i(:,jj,jl) = z0smi(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + poa_i(:,jj,jl) = z0oi (:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + pa_i (:,jj,jl) = z0ai (:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + DO jk = 1, nlay_s + pe_s(:,jj,jk,jl) = z0es(:,jj,jk,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + END DO + DO jk = 1, nlay_i + pe_i(:,jj,jk,jl) = z0ei(:,jj,jk,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + END DO + IF ( ln_pnd_LEV ) THEN + pa_ip(:,jj,jl) = z0ap(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + pv_ip(:,jj,jl) = z0vp(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + IF ( ln_pnd_lids ) THEN + pv_il(:,jj,jl) = z0vl(:,jj,jl) * r1_e1e2t(:,jj) * tmask(:,jj,1) + ENDIF + ENDIF + END DO + !$omp end do + END DO + ! + ! derive open water from ice concentration + !$omp do + DO jj = 1, jpj + zati2(:,jj) = SUM( pa_i(:,jj,:), dim=2 ) + END DO + !$omp end do + !$omp do + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & !--- open water + & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt + END DO + END DO + !$omp end do + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + ! --- diagnostics --- ! + !$omp do + DO jj = 1, jpj + diag_adv_mass(:,jj) = diag_adv_mass(:,jj) + ( SUM( pv_i (:,jj,:) , dim=2 ) * rhoi + SUM( pv_s (:,jj,:) , dim=2 ) * rhos & + & + SUM( pv_ip(:,jj,:) , dim=2 ) * rhow + SUM( pv_il(:,jj,:) , dim=2 ) * rhow & + & - zdiag_adv_mass(:,jj) ) * z1_dt + diag_adv_salt(:,jj) = diag_adv_salt(:,jj) + ( SUM( psv_i(:,jj,:) , dim=2 ) * rhoi & + & - zdiag_adv_salt(:,jj) ) * z1_dt + diag_adv_heat(:,jj) = diag_adv_heat(:,jj) + ( - SUM(SUM( pe_i(:,jj,1:nlay_i,:) , dim=3 ), dim=2 ) & + & - SUM(SUM( pe_s(:,jj,1:nlay_s,:) , dim=3 ), dim=2 ) & + & - zdiag_adv_heat(:,jj) ) * z1_dt + ENDDO + !$omp end do + !$omp end parallel + ! + ! --- Ensure non-negative fields --- ! + ! Remove negative values (conservation is ensured) + ! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) + CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + ! + ! --- Make sure ice thickness is not too big --- ! + ! (because ice thickness can be too large where ice concentration is very small) + CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & + & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) + ! + ! --- Ensure snow load is not too big --- ! + !CALL Hsnow( zdt, pv_i, pv_s, pa_i, pa_ip, pe_s ) !Sarah this is done in Hbig at end of advection instead + ! + END DO + ! + IF( lrst_ice .and. .not. ln_asm_seaiceinc ) CALL adv_pra_rst( 'WRITE', kt ) !* write Prather fields in the restart file + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra') + ! + END SUBROUTINE ice_dyn_adv_pra + + + SUBROUTINE adv_x( pdt, put , pcrh, psm , ps0 , & + & psx, psxx, psy , psyy, psxy ) + !!---------------------------------------------------------------------- + !! ** routine adv_x ** + !! + !! ** purpose : Computes and adds the advection trend to sea-ice + !! variable on x axis + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! the time step + REAL(wp) , INTENT(in ) :: pcrh ! call adv_x then adv_y (=1) or the opposite (=0) + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: put ! i-direction ice velocity at U-point [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psm ! area + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ps0 ! field to be advected + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psx , psy ! 1st moments + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psxx, psyy, psxy ! 2nd moments + !! + INTEGER :: ji, jj, jl, jcat ! dummy loop indices + INTEGER :: jjmin, jjmax ! dummy loop indices + REAL(wp) :: zs1max, zslpmax, ztemp ! local scalars + REAL(wp) :: zs1new, zalf , zalfq , zbt ! - - + REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - - + REAL(wp) :: zpsm, zps0 + REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy + REAL(wp), DIMENSION(jpi,jpj) :: zf0 , zfx , zfy , zbet ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zfm , zfxx , zfyy , zfxy ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - - + !----------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_adv_x') + ! + ! in order to avoid lbc_lnk (communications): + ! jj loop must be 1:jpj if adv_x is called first + ! and 2:jpj-1 if adv_x is called second + jjmin = 2 - NINT(pcrh) ! 1 or 2 + jjmax = jpjm1 + NINT(pcrh) ! jpj or jpj-1 + ! + jcat = SIZE( ps0 , 3 ) ! size of input arrays + ! + !$omp parallel private(ji,jj,jl,zs1max,zslpmax,ztemp,zs1new,zalf,zalfq,zbt,& + !$omp& zs2new,zalf1,zalf1q,zbt1,zpsm,zps0,zpsx,zpsy,zpsxx,zpsyy,zpsxy,rswitch) + ! + DO jl = 1, jcat ! loop on categories + ! + ! Limitation of moments. + !$omp do + DO jj = jjmin, jjmax + + DO ji = 1, jpi + + zpsm = psm (ji,jj,jl) ! optimization + zps0 = ps0 (ji,jj,jl) + zpsx = psx (ji,jj,jl) + zpsxx = psxx(ji,jj,jl) + zpsy = psy (ji,jj,jl) + zpsyy = psyy(ji,jj,jl) + zpsxy = psxy(ji,jj,jl) + + ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) + zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 ) + ! + zslpmax = MAX( 0._wp, zps0 ) + zs1max = 1.5 * zslpmax + zs1new = MIN( zs1max, MAX( -zs1max, zpsx ) ) + zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), MAX( ABS( zs1new ) - zslpmax, zpsxx ) ) + rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask + + zps0 = zslpmax + zpsx = zs1new * rswitch + zpsxx = zs2new * rswitch + zpsy = zpsy * rswitch + zpsyy = zpsyy * rswitch + zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch + + ! Calculate fluxes and moments between boxes i<-->i+1 + ! ! Flux from i to i+1 WHEN u GT 0 + zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) + zalf = MAX( 0._wp, put(ji,jj) ) * pdt / zpsm + zalfq = zalf * zalf + zalf1 = 1.0 - zalf + zalf1q = zalf1 * zalf1 + ! + zfm (ji,jj) = zalf * zpsm + zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsx + (zalf1 - zalf) * zpsxx ) ) + zfx (ji,jj) = zalfq * ( zpsx + 3.0 * zalf1 * zpsxx ) + zfxx(ji,jj) = zalf * zpsxx * zalfq + zfy (ji,jj) = zalf * ( zpsy + zalf1 * zpsxy ) + zfxy(ji,jj) = zalfq * zpsxy + zfyy(ji,jj) = zalf * zpsyy + + ! ! Readjust moments remaining in the box. + zpsm = zpsm - zfm(ji,jj) + zps0 = zps0 - zf0(ji,jj) + zpsx = zalf1q * ( zpsx - 3.0 * zalf * zpsxx ) + zpsxx = zalf1 * zalf1q * zpsxx + zpsy = zpsy - zfy (ji,jj) + zpsyy = zpsyy - zfyy(ji,jj) + zpsxy = zalf1q * zpsxy + ! + psm (ji,jj,jl) = zpsm ! optimization + ps0 (ji,jj,jl) = zps0 + psx (ji,jj,jl) = zpsx + psxx(ji,jj,jl) = zpsxx + psy (ji,jj,jl) = zpsy + psyy(ji,jj,jl) = zpsyy + psxy(ji,jj,jl) = zpsxy + ! + END DO + + DO ji = 1, fs_jpim1 + ! ! Flux from i+1 to i when u LT 0. + zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl) + zalg (ji,jj) = zalf + zalfq = zalf * zalf + zalf1 = 1.0 - zalf + zalg1 (ji,jj) = zalf1 + zalf1q = zalf1 * zalf1 + zalg1q(ji,jj) = zalf1q + ! + zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl) + zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) & + & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) + zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) + zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq + zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) + zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl) + zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl) + END DO + + DO ji = fs_2, fs_jpim1 + ! + zpsm = psm (ji,jj,jl) ! optimization + zps0 = ps0 (ji,jj,jl) + zpsx = psx (ji,jj,jl) + zpsxx = psxx(ji,jj,jl) + zpsy = psy (ji,jj,jl) + zpsyy = psyy(ji,jj,jl) + zpsxy = psxy(ji,jj,jl) + ! ! Readjust moments remaining in the box. + zbt = zbet(ji-1,jj) + zbt1 = 1.0 - zbet(ji-1,jj) + ! + zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji-1,jj) ) + zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji-1,jj) ) + zpsx = zalg1q(ji-1,jj) * ( zpsx + 3.0 * zalg(ji-1,jj) * zpsxx ) + zpsxx = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * zpsxx + zpsy = zbt * zpsy + zbt1 * ( zpsy - zfy (ji-1,jj) ) + zpsyy = zbt * zpsyy + zbt1 * ( zpsyy - zfyy(ji-1,jj) ) + zpsxy = zalg1q(ji-1,jj) * zpsxy + + ! Put the temporary moments into appropriate neighboring boxes. + ! ! Flux from i to i+1 IF u GT 0. + zbt = zbet(ji-1,jj) + zbt1 = 1.0 - zbet(ji-1,jj) + zpsm = zbt * ( zpsm + zfm(ji-1,jj) ) + zbt1 * zpsm + zalf = zbt * zfm(ji-1,jj) / zpsm + zalf1 = 1.0 - zalf + ztemp = zalf * zps0 - zalf1 * zf0(ji-1,jj) + ! + zps0 = zbt * ( zps0 + zf0(ji-1,jj) ) + zbt1 * zps0 + zpsx = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * zpsx + 3.0 * ztemp ) + zbt1 * zpsx + zpsxx = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * zpsxx & + & + 5.0 * ( zalf * zalf1 * ( zpsx - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) & + & + zbt1 * zpsxx + zpsxy = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * zpsxy & + & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * zpsy ) ) & + & + zbt1 * zpsxy + zpsy = zbt * ( zpsy + zfy (ji-1,jj) ) + zbt1 * zpsy + zpsyy = zbt * ( zpsyy + zfyy(ji-1,jj) ) + zbt1 * zpsyy + + ! ! Flux from i+1 to i IF u LT 0. + zbt = zbet(ji,jj) + zbt1 = 1.0 - zbet(ji,jj) + zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) ) + zalf = zbt1 * zfm(ji,jj) / zpsm + zalf1 = 1.0 - zalf + ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj) + ! + zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) ) + zpsx = zbt * zpsx + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * zpsx + 3.0 * ztemp ) + zpsxx = zbt * zpsxx + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * zpsxx & + & + 5.0 * ( zalf * zalf1 * ( - zpsx + zfx(ji,jj) ) & + & + ( zalf1 - zalf ) * ztemp ) ) + zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy & + & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * zpsy ) ) + zpsy = zbt * zpsy + zbt1 * ( zpsy + zfy (ji,jj) ) + zpsyy = zbt * zpsyy + zbt1 * ( zpsyy + zfyy(ji,jj) ) + ! + psm (ji,jj,jl) = zpsm ! optimization + ps0 (ji,jj,jl) = zps0 + psx (ji,jj,jl) = zpsx + psxx(ji,jj,jl) = zpsxx + psy (ji,jj,jl) = zpsy + psyy(ji,jj,jl) = zpsyy + psxy(ji,jj,jl) = zpsxy + END DO + + END DO + !omp end do + END DO + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_adv_x') + ! + END SUBROUTINE adv_x + + + SUBROUTINE adv_y( pdt, pvt , pcrh, psm , ps0 , & + & psx, psxx, psy , psyy, psxy ) + !!--------------------------------------------------------------------- + !! ** routine adv_y ** + !! + !! ** purpose : Computes and adds the advection trend to sea-ice + !! variable on y axis + !!--------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! time step + REAL(wp) , INTENT(in ) :: pcrh ! call adv_x then adv_y (=1) or the opposite (=0) + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pvt ! j-direction ice velocity at V-point [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psm ! area + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ps0 ! field to be advected + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psx , psy ! 1st moments + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psxx, psyy, psxy ! 2nd moments + !! + INTEGER :: ji, jj, jl, jcat ! dummy loop indices + INTEGER :: jimin, jimax ! dummy loop indices + REAL(wp) :: zs1max, zslpmax, ztemp ! temporary scalars + REAL(wp) :: zs1new, zalf , zalfq , zbt ! - - + REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - - + REAL(wp) :: zpsm, zps0 + REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy + REAL(wp), DIMENSION(jpi,jpj) :: zf0, zfx , zfy , zbet ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zfm, zfxx, zfyy, zfxy ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - - + !--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_adv_y') + ! + ! in order to avoid lbc_lnk (communications): + ! ji loop must be 1:jpi if adv_y is called first + ! and 2:jpi-1 if adv_y is called second + jimin = 2 - NINT(pcrh) ! 1 or 2 + jimax = jpim1 + NINT(pcrh) ! jpi or jpi-1 + ! + jcat = SIZE( ps0 , 3 ) ! size of input arrays + ! + !$omp parallel private(ji,jj,jl,zs1max,zslpmax,ztemp,zs1new,zalf,zalfq,zbt,& + !$omp& zs2new,zalf1,zalf1q,zbt1,zpsm,zps0,zpsx,zpsy,zpsxx,zpsyy,zpsxy,rswitch) + + DO jl = 1, jcat ! loop on categories + ! + ! Limitation of moments. + !$omp do + DO jj = 1, jpj + DO ji = jimin, jimax + ! + zpsm = psm (ji,jj,jl) ! optimization + zps0 = ps0 (ji,jj,jl) + zpsx = psx (ji,jj,jl) + zpsxx = psxx(ji,jj,jl) + zpsy = psy (ji,jj,jl) + zpsyy = psyy(ji,jj,jl) + zpsxy = psxy(ji,jj,jl) + ! + ! Initialize volumes of boxes (=area if adv_y first called, =psm otherwise) + zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 ) + ! + zslpmax = MAX( 0._wp, zps0 ) + zs1max = 1.5 * zslpmax + zs1new = MIN( zs1max, MAX( -zs1max, zpsy ) ) + zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), MAX( ABS( zs1new )-zslpmax, zpsyy ) ) + rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask + ! + zps0 = zslpmax + zpsx = zpsx * rswitch + zpsxx = zpsxx * rswitch + zpsy = zs1new * rswitch + zpsyy = zs2new * rswitch + zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch + + ! Calculate fluxes and moments between boxes j<-->j+1 + ! ! Flux from j to j+1 WHEN v GT 0 + zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) + zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / zpsm + zalfq = zalf * zalf + zalf1 = 1.0 - zalf + zalf1q = zalf1 * zalf1 + ! + zfm (ji,jj) = zalf * zpsm + zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsy + (zalf1-zalf) * zpsyy ) ) + zfy (ji,jj) = zalfq *( zpsy + 3.0*zalf1*zpsyy ) + zfyy(ji,jj) = zalf * zalfq * zpsyy + zfx (ji,jj) = zalf * ( zpsx + zalf1 * zpsxy ) + zfxy(ji,jj) = zalfq * zpsxy + zfxx(ji,jj) = zalf * zpsxx + ! + ! ! Readjust moments remaining in the box. + zpsm = zpsm - zfm(ji,jj) + zps0 = zps0 - zf0(ji,jj) + zpsy = zalf1q * ( zpsy -3.0 * zalf * zpsyy ) + zpsyy = zalf1 * zalf1q * zpsyy + zpsx = zpsx - zfx(ji,jj) + zpsxx = zpsxx - zfxx(ji,jj) + zpsxy = zalf1q * zpsxy + ! + psm (ji,jj,jl) = zpsm ! optimization + ps0 (ji,jj,jl) = zps0 + psx (ji,jj,jl) = zpsx + psxx(ji,jj,jl) = zpsxx + psy (ji,jj,jl) = zpsy + psyy(ji,jj,jl) = zpsyy + psxy(ji,jj,jl) = zpsxy + END DO + END DO + !$omp enddo + ! + !$omp do + DO jj = 1, jpjm1 + DO ji = jimin, jimax + ! ! Flux from j+1 to j when v LT 0. + zalf = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl) + zalg (ji,jj) = zalf + zalfq = zalf * zalf + zalf1 = 1.0 - zalf + zalg1 (ji,jj) = zalf1 + zalf1q = zalf1 * zalf1 + zalg1q(ji,jj) = zalf1q + ! + zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji,jj+1,jl) + zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji,jj+1,jl) & + & - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) + zfy (ji,jj) = zfy (ji,jj) + zalfq * ( psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) + zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji,jj+1,jl) * zalfq + zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) + zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji,jj+1,jl) + zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1,jl) + END DO + END DO + !$omp end do + + !$omp do + DO jj = 2, jpjm1 + DO ji = jimin, jimax + ! ! Readjust moments remaining in the box. + zbt = zbet(ji,jj-1) + zbt1 = ( 1.0 - zbet(ji,jj-1) ) + ! + zpsm = psm (ji,jj,jl) ! optimization + zps0 = ps0 (ji,jj,jl) + zpsx = psx (ji,jj,jl) + zpsxx = psxx(ji,jj,jl) + zpsy = psy (ji,jj,jl) + zpsyy = psyy(ji,jj,jl) + zpsxy = psxy(ji,jj,jl) + ! + zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji,jj-1) ) + zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji,jj-1) ) + zpsy = zalg1q(ji,jj-1) * ( zpsy + 3.0 * zalg(ji,jj-1) * zpsyy ) + zpsyy = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * zpsyy + zpsx = zbt * zpsx + zbt1 * ( zpsx - zfx (ji,jj-1) ) + zpsxx = zbt * zpsxx + zbt1 * ( zpsxx - zfxx(ji,jj-1) ) + zpsxy = zalg1q(ji,jj-1) * zpsxy + + ! Put the temporary moments into appropriate neighboring boxes. + ! ! Flux from j to j+1 IF v GT 0. + zbt = zbet(ji,jj-1) + zbt1 = 1.0 - zbet(ji,jj-1) + zpsm = zbt * ( zpsm + zfm(ji,jj-1) ) + zbt1 * zpsm + zalf = zbt * zfm(ji,jj-1) / zpsm + zalf1 = 1.0 - zalf + ztemp = zalf * zps0 - zalf1 * zf0(ji,jj-1) + ! + zps0 = zbt * ( zps0 + zf0(ji,jj-1) ) + zbt1 * zps0 + zpsy = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * zpsy + 3.0 * ztemp ) & + & + zbt1 * zpsy + zpsyy = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * zpsyy & + & + 5.0 * ( zalf * zalf1 * ( zpsy - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & + & + zbt1 * zpsyy + zpsxy = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * zpsxy & + & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * zpsx ) ) & + & + zbt1 * zpsxy + zpsx = zbt * ( zpsx + zfx (ji,jj-1) ) + zbt1 * zpsx + zpsxx = zbt * ( zpsxx + zfxx(ji,jj-1) ) + zbt1 * zpsxx + + ! ! Flux from j+1 to j IF v LT 0. + zbt = zbet(ji,jj) + zbt1 = 1.0 - zbet(ji,jj) + zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) ) + zalf = zbt1 * zfm(ji,jj) / zpsm + zalf1 = 1.0 - zalf + ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj) + ! + zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) ) + zpsy = zbt * zpsy + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * zpsy + 3.0 * ztemp ) + zpsyy = zbt * zpsyy + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * zpsyy & + & + 5.0 * ( zalf * zalf1 * ( - zpsy + zfy(ji,jj) ) & + & + ( zalf1 - zalf ) * ztemp ) ) + zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy & + & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * zpsx ) ) + zpsx = zbt * zpsx + zbt1 * ( zpsx + zfx (ji,jj) ) + zpsxx = zbt * zpsxx + zbt1 * ( zpsxx + zfxx(ji,jj) ) + ! + psm (ji,jj,jl) = zpsm ! optimization + ps0 (ji,jj,jl) = zps0 + psx (ji,jj,jl) = zpsx + psxx(ji,jj,jl) = zpsxx + psy (ji,jj,jl) = zpsy + psyy(ji,jj,jl) = zpsyy + psxy(ji,jj,jl) = zpsxy + END DO + END DO + !$omp end do + + END DO + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_adv_y') + ! + END SUBROUTINE adv_y + + + SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & + & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) + !!------------------------------------------------------------------- + !! *** ROUTINE Hbig *** + !! + !! ** Purpose : Thickness correction in case advection scheme creates + !! abnormally tick ice or snow + !! + !! ** Method : 1- check whether ice thickness is larger than the surrounding 9-points + !! (before advection) and reduce it by adapting ice concentration + !! 2- check whether snow thickness is larger than the surrounding 9-points + !! (before advection) and reduce it by sending the excess in the ocean + !! + !! ** input : Max thickness of the surrounding 9-points + !!------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts + REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pes_max + REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pei_max + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra + !!------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_Hbig') + ! + z1_dt = 1._wp / pdt + ! + !$omp parallel private(ji,jj,jk,jl,zhip,zhi,zhs,zsi,zes,zei,zfra) + DO jl = 1, jpl + !$omp do + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! + ! ! -- check h_ip -- ! + ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip + IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN + zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) + IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN + pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) + ENDIF + ENDIF + ! + ! ! -- check h_i -- ! + ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i + zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) + IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) + ENDIF + ! + ! ! -- check h_s -- ! + ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean + zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) + IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) + ! + wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt + hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + ! + pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra + pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) + ENDIF + ! + ! ! -- check s_i -- ! + ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean + zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) + IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = psi_max(ji,jj,jl) / zsi + sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt + psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra + ENDIF + ! + ENDIF + END DO + END DO + !$omp end do + END DO + ! + ! ! -- check e_i/v_i -- ! + DO jl = 1, jpl + DO jk = 1, nlay_i + !$omp do + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean + zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) + IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = pei_max(ji,jj,jk,jl) / zei + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra + ENDIF + ENDIF + END DO + END DO + !$omp end do + END DO + END DO + ! ! -- check e_s/v_s -- ! + DO jl = 1, jpl + DO jk = 1, nlay_s + !$omp do + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_s(ji,jj,jl) > TINY(0._wp) ) THEN + ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean + zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) + IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = pes_max(ji,jj,jk,jl) / zes + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra + ENDIF + ENDIF + END DO + END DO + !$omp end do + END DO + END DO + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_Hbig') + ! + END SUBROUTINE Hbig + + + SUBROUTINE Hsnow( pdt, pv_i, pv_s, pa_i, pa_ip, pe_s ) + !!------------------------------------------------------------------- + !! *** ROUTINE Hsnow *** + !! + !! ** Purpose : 1- Check snow load after advection + !! 2- Correct pond concentration to avoid a_ip > a_i + !! + !! ** Method : If snow load makes snow-ice interface to deplet below the ocean surface + !! then put the snow excess in the ocean + !! + !! ** Notes : This correction is crucial because of the call to routine icecor afterwards + !! which imposes a mini of ice thick. (rn_himin). This imposed mini can artificially + !! make the snow very thick (if concentration decreases drastically) + !! This behavior has been seen in Ultimate-Macho and supposedly it can also be true for Prather + !!------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip + REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: z1_dt, zvs_excess, zfra + !!------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_Hsnow') + ! + z1_dt = 1._wp / pdt + ! + ! -- check snow load -- ! + !$omp parallel private(ji,jj,jl,zvs_excess,zfra) + DO jl = 1, jpl + !$omp do + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! + zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) + ! + IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface + ! put snow excess in the ocean + zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) + wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt + hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + ! correct snow volume and heat content + pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra + pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess + ENDIF + ! + ENDIF + END DO + END DO + !$omp end do + END DO + !$omp end parallel + ! + !-- correct pond concentration to avoid a_ip > a_i -- ! + WHERE( pa_ip(:,:,:) > pa_i(:,:,:) ) pa_ip(:,:,:) = pa_i(:,:,:) + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_Hsnow') + ! + END SUBROUTINE Hsnow + + + SUBROUTINE adv_pra_init + !!------------------------------------------------------------------- + !! *** ROUTINE adv_pra_init *** + !! + !! ** Purpose : allocate and initialize arrays for Prather advection + !!------------------------------------------------------------------- + INTEGER :: ierr + !!------------------------------------------------------------------- + ! + ! !* allocate prather fields + ALLOCATE( sxice(jpi,jpj,jpl) , syice(jpi,jpj,jpl) , sxxice(jpi,jpj,jpl) , syyice(jpi,jpj,jpl) , sxyice(jpi,jpj,jpl) , & + & sxsn (jpi,jpj,jpl) , sysn (jpi,jpj,jpl) , sxxsn (jpi,jpj,jpl) , syysn (jpi,jpj,jpl) , sxysn (jpi,jpj,jpl) , & + & sxa (jpi,jpj,jpl) , sya (jpi,jpj,jpl) , sxxa (jpi,jpj,jpl) , syya (jpi,jpj,jpl) , sxya (jpi,jpj,jpl) , & + & sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) , & + & sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) , & + & sxap (jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) , & + & sxvp (jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) , & + & sxvl (jpi,jpj,jpl) , syvl (jpi,jpj,jpl) , sxxvl (jpi,jpj,jpl) , syyvl (jpi,jpj,jpl) , sxyvl (jpi,jpj,jpl) , & + ! + & sxc0 (jpi,jpj,nlay_s,jpl) , syc0 (jpi,jpj,nlay_s,jpl) , sxxc0(jpi,jpj,nlay_s,jpl) , & + & syyc0(jpi,jpj,nlay_s,jpl) , sxyc0(jpi,jpj,nlay_s,jpl) , & + ! + & sxe (jpi,jpj,nlay_i,jpl) , sye (jpi,jpj,nlay_i,jpl) , sxxe (jpi,jpj,nlay_i,jpl) , & + & syye (jpi,jpj,nlay_i,jpl) , sxye (jpi,jpj,nlay_i,jpl) , & + & STAT = ierr ) + ! + CALL mpp_sum( 'icedyn_adv_pra', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'adv_pra_init : unable to allocate ice arrays for Prather advection scheme') + ! + CALL adv_pra_rst( 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE adv_pra_init + + + SUBROUTINE adv_pra_rst( cdrw, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE adv_pra_rst *** + !! + !! ** Purpose : Read or write file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in) :: cdrw ! "READ"/"WRITE" flag + INTEGER, OPTIONAL, INTENT(in) :: kt ! ice time-step + ! + INTEGER :: jk, jl ! dummy loop indices + INTEGER :: iter ! local integer + INTEGER :: id1 ! local integer + CHARACTER(len=25) :: znam + CHARACTER(len=2) :: zchar, zchar1 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace + !!---------------------------------------------------------------------- + ! + ! !==========================! + IF( TRIM(cdrw) == 'READ' ) THEN !== Read or initialize ==! + ! !==========================! + ! + IF( ln_rstart ) THEN ; id1 = iom_varid( numrir, 'sxice' , ldstop = .FALSE. ) ! file exist: id1>0 + ELSE ; id1 = 0 ! no restart: id1=0 + ENDIF + ! + IF( id1 > 0 ) THEN !** Read the restart file **! + ! + ! ! ice thickness + CALL iom_get( numrir, jpdom_autoglo, 'sxice' , sxice ) + CALL iom_get( numrir, jpdom_autoglo, 'syice' , syice ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxice', sxxice ) + CALL iom_get( numrir, jpdom_autoglo, 'syyice', syyice ) + CALL iom_get( numrir, jpdom_autoglo, 'sxyice', sxyice ) + ! ! snow thickness + CALL iom_get( numrir, jpdom_autoglo, 'sxsn' , sxsn ) + CALL iom_get( numrir, jpdom_autoglo, 'sysn' , sysn ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxsn' , sxxsn ) + CALL iom_get( numrir, jpdom_autoglo, 'syysn' , syysn ) + CALL iom_get( numrir, jpdom_autoglo, 'sxysn' , sxysn ) + ! ! ice concentration + CALL iom_get( numrir, jpdom_autoglo, 'sxa' , sxa ) + CALL iom_get( numrir, jpdom_autoglo, 'sya' , sya ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxa' , sxxa ) + CALL iom_get( numrir, jpdom_autoglo, 'syya' , syya ) + CALL iom_get( numrir, jpdom_autoglo, 'sxya' , sxya ) + ! ! ice salinity + CALL iom_get( numrir, jpdom_autoglo, 'sxsal' , sxsal ) + CALL iom_get( numrir, jpdom_autoglo, 'sysal' , sysal ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxsal', sxxsal ) + CALL iom_get( numrir, jpdom_autoglo, 'syysal', syysal ) + CALL iom_get( numrir, jpdom_autoglo, 'sxysal', sxysal ) + ! ! ice age + CALL iom_get( numrir, jpdom_autoglo, 'sxage' , sxage ) + CALL iom_get( numrir, jpdom_autoglo, 'syage' , syage ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxage', sxxage ) + CALL iom_get( numrir, jpdom_autoglo, 'syyage', syyage ) + CALL iom_get( numrir, jpdom_autoglo, 'sxyage', sxyage ) + ! ! snow layers heat content + DO jk = 1, nlay_s + WRITE(zchar1,'(I2.2)') jk + znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) + znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:) + znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) + znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) + znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) + END DO + ! ! ice layers heat content + DO jk = 1, nlay_i + WRITE(zchar1,'(I2.2)') jk + znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:) + znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:) + znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) + znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) + znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) + END DO + ! + IF( ln_pnd_LEV ) THEN ! melt pond fraction + IF( iom_varid( numrir, 'sxap', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrir, jpdom_autoglo, 'sxap' , sxap ) + CALL iom_get( numrir, jpdom_autoglo, 'syap' , syap ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxap', sxxap ) + CALL iom_get( numrir, jpdom_autoglo, 'syyap', syyap ) + CALL iom_get( numrir, jpdom_autoglo, 'sxyap', sxyap ) + ! ! melt pond volume + CALL iom_get( numrir, jpdom_autoglo, 'sxvp' , sxvp ) + CALL iom_get( numrir, jpdom_autoglo, 'syvp' , syvp ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxvp', sxxvp ) + CALL iom_get( numrir, jpdom_autoglo, 'syyvp', syyvp ) + CALL iom_get( numrir, jpdom_autoglo, 'sxyvp', sxyvp ) + ELSE + sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction + sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume + ENDIF + ! + IF ( ln_pnd_lids ) THEN ! melt pond lid volume + IF( iom_varid( numrir, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrir, jpdom_autoglo, 'sxvl' , sxvl ) + CALL iom_get( numrir, jpdom_autoglo, 'syvl' , syvl ) + CALL iom_get( numrir, jpdom_autoglo, 'sxxvl', sxxvl ) + CALL iom_get( numrir, jpdom_autoglo, 'syyvl', syyvl ) + CALL iom_get( numrir, jpdom_autoglo, 'sxyvl', sxyvl ) + ELSE + sxvl = 0._wp; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume + ENDIF + ENDIF + ENDIF + ! + ELSE !** start rheology from rest **! + ! + IF(lwp) WRITE(numout,*) ' ==>> start from rest OR previous run without Prather, set moments to 0' + ! + CALL adv_pra_rest(1) + + ENDIF + ! + ! !=====================================! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN !== write in the ice restart file ==! + ! !=====================================! + IF(lwp) WRITE(numout,*) '---- ice-adv-rst ----' + iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 + ! + ! + ! In case Prather scheme is used for advection, write second order moments + ! ------------------------------------------------------------------------ + ! + ! ! ice thickness + CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice ) + CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice ) + CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice ) + CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice ) + ! ! snow thickness + CALL iom_rstput( iter, nitrst, numriw, 'sxsn' , sxsn ) + CALL iom_rstput( iter, nitrst, numriw, 'sysn' , sysn ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn ) + CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn ) + CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn ) + ! ! ice concentration + CALL iom_rstput( iter, nitrst, numriw, 'sxa' , sxa ) + CALL iom_rstput( iter, nitrst, numriw, 'sya' , sya ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxa' , sxxa ) + CALL iom_rstput( iter, nitrst, numriw, 'syya' , syya ) + CALL iom_rstput( iter, nitrst, numriw, 'sxya' , sxya ) + ! ! ice salinity + CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal ) + CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal ) + CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal ) + CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal ) + ! ! ice age + CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage ) + CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage ) + CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage ) + CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage ) + ! ! snow layers heat content + DO jk = 1, nlay_s + WRITE(zchar1,'(I2.2)') jk + znam = 'sxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'syc0'//'_l'//zchar1 ; z3d(:,:,:) = syc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'sxxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxxc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'syyc0'//'_l'//zchar1 ; z3d(:,:,:) = syyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'sxyc0'//'_l'//zchar1 ; z3d(:,:,:) = sxyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + END DO + ! ! ice layers heat content + DO jk = 1, nlay_i + WRITE(zchar1,'(I2.2)') jk + znam = 'sxe'//'_l'//zchar1 ; z3d(:,:,:) = sxe (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'sye'//'_l'//zchar1 ; z3d(:,:,:) = sye (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'sxxe'//'_l'//zchar1 ; z3d(:,:,:) = sxxe(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'syye'//'_l'//zchar1 ; z3d(:,:,:) = syye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + znam = 'sxye'//'_l'//zchar1 ; z3d(:,:,:) = sxye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + END DO + ! + IF( ln_pnd_LEV ) THEN ! melt pond fraction + CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap ) + CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxap', sxxap ) + CALL iom_rstput( iter, nitrst, numriw, 'syyap', syyap ) + CALL iom_rstput( iter, nitrst, numriw, 'sxyap', sxyap ) + ! ! melt pond volume + CALL iom_rstput( iter, nitrst, numriw, 'sxvp' , sxvp ) + CALL iom_rstput( iter, nitrst, numriw, 'syvp' , syvp ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxvp', sxxvp ) + CALL iom_rstput( iter, nitrst, numriw, 'syyvp', syyvp ) + CALL iom_rstput( iter, nitrst, numriw, 'sxyvp', sxyvp ) + ! + IF ( ln_pnd_lids ) THEN ! melt pond lid volume + CALL iom_rstput( iter, nitrst, numriw, 'sxvl' , sxvl ) + CALL iom_rstput( iter, nitrst, numriw, 'syvl' , syvl ) + CALL iom_rstput( iter, nitrst, numriw, 'sxxvl', sxxvl ) + CALL iom_rstput( iter, nitrst, numriw, 'syyvl', syyvl ) + CALL iom_rstput( iter, nitrst, numriw, 'sxyvl', sxyvl ) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE adv_pra_rst + + SUBROUTINE adv_pra_rest( nreset ) + !!--------------------------------------------------------------------- + !! *** ROUTINE adv_pra_rest *** + !! + !! ** Purpose : Set moments needed for prather advection scheme to zero + !! + !! ** Method : + !!---------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: nreset ! which order moments (and higher) to reset + ! nreset = 1 : zero all first and second order moments + ! nreset = 2 : zero second order moments and not first + + IF ( nreset .le. 1 ) THEN + sxice = 0._wp ; syice = 0._wp ! ice thickness + sxsn = 0._wp ; sysn = 0._wp ! snow thickness + sxa = 0._wp ; sya = 0._wp ! ice concentration + sxsal = 0._wp ; sysal = 0._wp ! ice salinity + sxage = 0._wp ; syage = 0._wp ! ice age + sxc0 = 0._wp ; syc0 = 0._wp ! snow layers heat content + sxe = 0._wp ; sye = 0._wp ! ice layers heat content + IF( ln_pnd_LEV ) THEN + sxap = 0._wp ; syap = 0._wp ! melt pond fraction + sxvp = 0._wp ; syvp = 0._wp ! melt pond volume + IF ( ln_pnd_lids ) THEN + sxvl = 0._wp; syvl = 0._wp ! melt pond lid volume + ENDIF + ENDIF + + END IF + + IF ( nreset .le. 2 ) THEN + sxxice = 0._wp ; syyice = 0._wp ; sxyice = 0._wp ! ice thickness + sxxsn = 0._wp ; syysn = 0._wp ; sxysn = 0._wp ! snow thickness + sxxa = 0._wp ; syya = 0._wp ; sxya = 0._wp ! ice concentration + sxxsal = 0._wp ; syysal = 0._wp ; sxysal = 0._wp ! ice salinity + sxxage = 0._wp ; syyage = 0._wp ; sxyage = 0._wp ! ice age + sxxc0 = 0._wp ; syyc0 = 0._wp ; sxyc0 = 0._wp ! snow layers heat content + sxxe = 0._wp ; syye = 0._wp ; sxye = 0._wp ! ice layers heat content + IF( ln_pnd_LEV ) THEN + sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction + sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume + IF ( ln_pnd_lids ) THEN + sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume + ENDIF + ENDIF + + + END IF + + END SUBROUTINE adv_pra_rest + + SUBROUTINE icemax3D( pice , pmax ) + !!--------------------------------------------------------------------- + !! *** ROUTINE icemax3D *** + !! ** Purpose : compute the max of the 9 points around + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pice ! input + REAL(wp), DIMENSION(:,:,:) , INTENT(out) :: pmax ! output + REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array + INTEGER :: ji, jj, jl ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_icemax3D') + ! + !$omp parallel private(ji,jj,jl) + DO jl = 1, jpl + !$omp do + DO jj = 1, jpj + DO ji = 2, jpim1 + zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jl), pice(ji-1,jj,jl), pice(ji+1,jj,jl) ) + END DO + END DO + !$omp end do + !$omp do + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + pmax(ji,jj,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) + END DO + END DO + !$omp end do + END DO + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_icemax3D') + ! + END SUBROUTINE icemax3D + + SUBROUTINE icemax4D( pice , pmax ) + !!--------------------------------------------------------------------- + !! *** ROUTINE icemax4D *** + !! ** Purpose : compute the max of the 9 points around + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pice ! input + REAL(wp), DIMENSION(:,:,:,:) , INTENT(out) :: pmax ! output + REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array + INTEGER :: jlay, ji, jj, jk, jl ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ice_dyn_adv_pra_icemax4D') + ! + jlay = SIZE( pice , 3 ) ! size of input arrays + !$omp parallel private(ji,jj,jk,jl) + DO jl = 1, jpl + DO jk = 1, jlay + !$omp do + DO jj = 1, jpj + DO ji = 2, jpim1 + zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jk,jl), pice(ji-1,jj,jk,jl), pice(ji+1,jj,jk,jl) ) + END DO + END DO + !$omp end do + !$omp do + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + pmax(ji,jj,jk,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) + END DO + END DO + !$omp end do + END DO + END DO + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('ice_dyn_adv_pra_icemax4D') + ! + END SUBROUTINE icemax4D + + SUBROUTINE adv_pra_asm_init( ln_seaiceinc ) + LOGICAL, intent(in) :: ln_seaiceinc + ln_asm_seaiceinc = ln_seaiceinc + END SUBROUTINE adv_pra_asm_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn_adv_pra \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.mod b/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.mod new file mode 100644 index 0000000000000000000000000000000000000000..e198d8eb09060e15dc1f2e080eb2bd3a8d5fcf07 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_adv_pra.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.F90 b/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e9372e310ba6ac8addceff255ac3f99872e0b469 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.F90 @@ -0,0 +1,1811 @@ +MODULE icedyn_adv_umx + !!============================================================================== + !! *** MODULE icedyn_adv_umx *** + !! sea-ice : advection using the ULTIMATE-MACHO scheme + !!============================================================================== + !! History : 3.6 ! 2014-11 (C. Rousset, G. Madec) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_adv_umx : update the tracer fields + !! ultimate_x(_y) : compute a tracer value at velocity points using ULTIMATE scheme at various orders + !! macho : compute the fluxes + !! nonosc_ice : limit the fluxes using a non-oscillatory algorithm + !!---------------------------------------------------------------------- + USE phycst ! physical constant + USE dom_oce ! ocean domain + USE sbc_oce , ONLY : nn_fsbc ! update frequency of surface boundary condition + USE ice ! sea-ice variables + USE icevar ! sea-ice: operations + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_adv_umx ! called by icedyn_adv.F90 + ! + INTEGER, PARAMETER :: np_advS = 1 ! advection for S and T: dVS/dt = -div( uVS ) => np_advS = 1 + ! or dVS/dt = -div( uA * uHS / u ) => np_advS = 2 + ! or dVS/dt = -div( uV * uS / u ) => np_advS = 3 + INTEGER, PARAMETER :: np_limiter = 1 ! limiter: 1 = nonosc + ! 2 = superbee + ! 3 = h3 + LOGICAL :: ll_upsxy = .TRUE. ! alternate directions for upstream + LOGICAL :: ll_hoxy = .TRUE. ! alternate directions for high order + LOGICAL :: ll_neg = .TRUE. ! if T interpolated at u/v points is negative or v_i < 1.e-6 + ! then interpolate T at u/v points using the upstream scheme + LOGICAL :: ll_prelim = .FALSE. ! prelimiter from: Zalesak(1979) eq. 14 => not well defined in 2D + ! + REAL(wp) :: z1_6 = 1._wp / 6._wp ! =1/6 + REAL(wp) :: z1_120 = 1._wp / 120._wp ! =1/120 + ! + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: imsk_small, jmsk_small + ! + !! * Substitutions +# include "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_adv_umx.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn_adv_umx( kn_umx, kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, & + & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_adv_umx *** + !! + !! ** Purpose : Compute the now trend due to total advection of + !! tracers and add it to the general trend of tracer equations + !! using an "Ultimate-Macho" scheme + !! + !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kn_umx ! order of the scheme (1-5=UM or 20=CEN2) + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pu_ice ! ice i-velocity + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pv_ice ! ice j-velocity + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_i ! ice thickness + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_s ! snw thickness + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: ph_ip ! ice pond thickness + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pato_i ! open water area + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i ! ice volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_s ! snw volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: psv_i ! salt content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: poa_i ! age content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_i ! ice concentration + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond concentration + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content + ! + INTEGER :: ji, jj, jk, jl, jt ! dummy loop indices + INTEGER :: icycle ! number of sub-timestep for the advection + REAL(wp) :: zamsk ! 1 if advection of concentration, 0 if advection of other tracers + REAL(wp) :: zdt, z1_dt, zvi_cen + REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication + REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx, zcu_box, zcv_box + REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zu_cat, zv_cat + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zua_ho, zva_ho, zua_ups, zva_ups + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_ai, z1_aip + REAL(dp), DIMENSION(jpi,jpj,jpl) :: zhvar + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max + REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max + REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: ze_s, zes_max + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs + !! diagnostics + REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme' + ! + ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! + ! thickness and salinity + WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) + ELSEWHERE ; zs_i(:,:,:) = 0._wp + END WHERE + CALL icemax3D( ph_i , zhi_max ) + CALL icemax3D( ph_s , zhs_max ) + CALL icemax3D( ph_ip, zhip_max) + CALL icemax3D( CASTDP(zs_i) , zsi_max ) + CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp, zsi_max, 'T', 1.0_wp ) + + ! enthalpies + DO jk = 1, nlay_i + WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) + ELSEWHERE ; ze_i(:,:,jk,:) = 0._wp + END WHERE + END DO + DO jk = 1, nlay_s + WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) + ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp + END WHERE + END DO + CALL icemax4D( ze_i , zei_max ) + CALL icemax4D( ze_s , zes_max ) + CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1.0_wp ) + CALL lbc_lnk( 'icedyn_adv_umx', zes_max, 'T', 1.0_wp ) + ! + ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! + ! Note: the advection split is applied at the next time-step in order to avoid blocking global comm. + ! this should not affect too much the stability + zcflnow(1) = MAXVAL( ABS( pu_ice(:,:) ) * rdt_ice * r1_e1u(:,:) ) + zcflnow(1) = MAX( zcflnow(1), MAXVAL( ABS( pv_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) ) + + ! non-blocking global communication send zcflnow and receive zcflprv + CALL mpp_delay_max( 'icedyn_adv_umx', 'cflice', zcflnow(:), zcflprv(:), kt == nitend - nn_fsbc + 1 ) + + IF( zcflprv(1) > .5 ) THEN ; icycle = 2 + ELSE ; icycle = 1 + ENDIF + zdt = rdt_ice / REAL(icycle) + z1_dt = 1._wp / zdt + + ! --- transport --- ! + zudy(:,:) = pu_ice(:,:) * e2u(:,:) + zvdx(:,:) = pv_ice(:,:) * e1v(:,:) + ! + ! setup transport for each ice cat + DO jl = 1, jpl + zu_cat(:,:,jl) = zudy(:,:) + zv_cat(:,:,jl) = zvdx(:,:) + END DO + ! + ! --- define velocity for advection: u*grad(H) --- ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + IF ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN ; zcu_box(ji,jj) = 0._wp + ELSEIF( pu_ice(ji,jj) > 0._wp ) THEN ; zcu_box(ji,jj) = pu_ice(ji-1,jj) + ELSE ; zcu_box(ji,jj) = pu_ice(ji ,jj) + ENDIF + + IF ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN ; zcv_box(ji,jj) = 0._wp + ELSEIF( pv_ice(ji,jj) > 0._wp ) THEN ; zcv_box(ji,jj) = pv_ice(ji,jj-1) + ELSE ; zcv_box(ji,jj) = pv_ice(ji,jj ) + ENDIF + END DO + END DO + + !---------------! + !== advection ==! + !---------------! + DO jt = 1, icycle + + ! diagnostics + zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & + & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow + zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi + zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) + + ! record at_i before advection (for open water) + zati1(:,:) = SUM( pa_i(:,:,:), dim=3 ) + + ! inverse of A and Ap + WHERE( pa_i(:,:,:) >= epsi20 ) ; z1_ai(:,:,:) = 1._wp / pa_i(:,:,:) + ELSEWHERE ; z1_ai(:,:,:) = 0. + END WHERE + WHERE( pa_ip(:,:,:) >= epsi20 ) ; z1_aip(:,:,:) = 1._wp / pa_ip(:,:,:) + ELSEWHERE ; z1_aip(:,:,:) = 0. + END WHERE + ! + ! setup a mask where advection will be upstream + IF( ll_neg ) THEN + IF( .NOT. ALLOCATED(imsk_small) ) ALLOCATE( imsk_small(jpi,jpj,jpl) ) + IF( .NOT. ALLOCATED(jmsk_small) ) ALLOCATE( jmsk_small(jpi,jpj,jpl) ) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) + IF( zvi_cen < epsi06) THEN ; imsk_small(ji,jj,jl) = 0 + ELSE ; imsk_small(ji,jj,jl) = 1 ; ENDIF + zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) + IF( zvi_cen < epsi06) THEN ; jmsk_small(ji,jj,jl) = 0 + ELSE ; jmsk_small(ji,jj,jl) = 1 ; ENDIF + END DO + END DO + END DO + ENDIF + ! + ! ----------------------- ! + ! ==> start advection <== ! + ! ----------------------- ! + ! + !== Ice area ==! + zamsk = 1._wp + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy, zvdx, zu_cat , zv_cat , zcu_box, zcv_box, & + & pa_i, pa_i, zua_ups, zva_ups, zua_ho , zva_ho ) + ! + ! ! --------------------------------- ! + IF( np_advS == 1 ) THEN ! -- advection form: -div( uVS ) -- ! + ! ! --------------------------------- ! + zamsk = 0._wp + !== Ice volume ==! + zhvar(:,:,:) = pv_i(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_i, zua_ups, zva_ups ) + !== Snw volume ==! + zhvar(:,:,:) = pv_s(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_s, zua_ups, zva_ups ) + ! + zamsk = 1._wp + !== Salt content ==! + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zu_cat, zv_cat, zcu_box, zcv_box, & + & psv_i, psv_i ) + !== Ice heat content ==! + DO jk = 1, nlay_i + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zu_cat, zv_cat, zcu_box, zcv_box, & + & pe_i(:,:,jk,:), pe_i(:,:,jk,:) ) + END DO + !== Snw heat content ==! + DO jk = 1, nlay_s + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zu_cat, zv_cat, zcu_box, zcv_box, & + & pe_s(:,:,jk,:), pe_s(:,:,jk,:) ) + END DO + ! + ! ! ------------------------------------------ ! + ELSEIF( np_advS == 2 ) THEN ! -- advection form: -div( uA * uHS / u ) -- ! + ! ! ------------------------------------------ ! + zamsk = 0._wp + !== Ice volume ==! + zhvar(:,:,:) = pv_i(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_i, zua_ups, zva_ups ) + !== Snw volume ==! + zhvar(:,:,:) = pv_s(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_s, zua_ups, zva_ups ) + !== Salt content ==! + zhvar(:,:,:) = psv_i(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, psv_i, zua_ups, zva_ups ) + !== Ice heat content ==! + DO jk = 1, nlay_i + zhvar(:,:,:) = pe_i(:,:,jk,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho, zva_ho, zcu_box, zcv_box, & + & zhvar, pe_i(:,:,jk,:), zua_ups, zva_ups ) + END DO + !== Snw heat content ==! + DO jk = 1, nlay_s + zhvar(:,:,:) = pe_s(:,:,jk,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho, zva_ho, zcu_box, zcv_box, & + & zhvar, pe_s(:,:,jk,:), zua_ups, zva_ups ) + END DO + ! + ! ! ----------------------------------------- ! + ELSEIF( np_advS == 3 ) THEN ! -- advection form: -div( uV * uS / u ) -- ! + ! ! ----------------------------------------- ! + zamsk = 0._wp + ! + ALLOCATE( zuv_ho (jpi,jpj,jpl), zvv_ho (jpi,jpj,jpl), & + & zuv_ups(jpi,jpj,jpl), zvv_ups(jpi,jpj,jpl), z1_vi(jpi,jpj,jpl), z1_vs(jpi,jpj,jpl) ) + ! + ! inverse of Vi + WHERE( pv_i(:,:,:) >= epsi20 ) ; z1_vi(:,:,:) = 1._wp / pv_i(:,:,:) + ELSEWHERE ; z1_vi(:,:,:) = 0. + END WHERE + ! inverse of Vs + WHERE( pv_s(:,:,:) >= epsi20 ) ; z1_vs(:,:,:) = 1._wp / pv_s(:,:,:) + ELSEWHERE ; z1_vs(:,:,:) = 0. + END WHERE + ! + ! It is important to first calculate the ice fields and then the snow fields (because we use the same arrays) + ! + !== Ice volume ==! + zuv_ups = zua_ups + zvv_ups = zva_ups + zhvar(:,:,:) = pv_i(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_i, zuv_ups, zvv_ups, zuv_ho , zvv_ho ) + !== Salt content ==! + zhvar(:,:,:) = psv_i(:,:,:) * z1_vi(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zuv_ho , zvv_ho , zcu_box, zcv_box, & + & zhvar, psv_i, zuv_ups, zvv_ups ) + !== Ice heat content ==! + DO jk = 1, nlay_i + zhvar(:,:,:) = pe_i(:,:,jk,:) * z1_vi(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zuv_ho, zvv_ho, zcu_box, zcv_box, & + & zhvar, pe_i(:,:,jk,:), zuv_ups, zvv_ups ) + END DO + !== Snow volume ==! + zuv_ups = zua_ups + zvv_ups = zva_ups + zhvar(:,:,:) = pv_s(:,:,:) * z1_ai(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_s, zuv_ups, zvv_ups, zuv_ho , zvv_ho ) + !== Snw heat content ==! + DO jk = 1, nlay_s + zhvar(:,:,:) = pe_s(:,:,jk,:) * z1_vs(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx, zuv_ho, zvv_ho, zcu_box, zcv_box, & + & zhvar, pe_s(:,:,jk,:), zuv_ups, zvv_ups ) + END DO + ! + DEALLOCATE( zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs ) + ! + ENDIF + ! + !== Ice age ==! + zamsk = 1._wp + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zu_cat, zv_cat, zcu_box, zcv_box, & + & poa_i, poa_i ) + ! + !== melt ponds ==! + IF ( ln_pnd_LEV ) THEN + ! concentration + zamsk = 1._wp + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zu_cat , zv_cat , zcu_box, zcv_box, & + & pa_ip, pa_ip, zua_ups, zva_ups, zua_ho , zva_ho ) + ! volume + zamsk = 0._wp + zhvar(:,:,:) = pv_ip(:,:,:) * z1_aip(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_ip, zua_ups, zva_ups ) + ! lid + IF ( ln_pnd_lids ) THEN + zamsk = 0._wp + zhvar(:,:,:) = pv_il(:,:,:) * z1_aip(:,:,:) + CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & + & zhvar, pv_il, zua_ups, zva_ups ) + ENDIF + ENDIF + ! + ! --- Lateral boundary conditions --- ! + IF ( ln_pnd_LEV .AND. ln_pnd_lids ) THEN + CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & + & , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp ) + ELSEIF( ln_pnd_LEV .AND. .NOT.ln_pnd_lids ) THEN + CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & + & , pa_ip,'T',1._wp, pv_ip,'T',1._wp ) + ELSE + CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp ) + ENDIF + CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_adv_umx', pe_s, 'T', 1._wp ) + ! + !== Open water area ==! + zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & + & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1.0_wp ) + ! + ! --- diagnostics --- ! + diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & + & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow & + & - zdiag_adv_mass(:,:) ) * z1_dt + diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & + & - zdiag_adv_salt(:,:) ) * z1_dt + diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) & + & - zdiag_adv_heat(:,:) ) * z1_dt + ! + ! --- Ensure non-negative fields and in-bound thicknesses --- ! + ! Remove negative values (conservation is ensured) + ! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) + CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + ! + ! --- Make sure ice thickness is not too big --- ! + ! (because ice thickness can be too large where ice concentration is very small) + CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & + & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) + ! + ! --- Ensure snow load is not too big --- ! + CALL Hsnow( zdt, pv_i, pv_s, pa_i, pa_ip, pe_s ) + ! + END DO + ! + END SUBROUTINE ice_dyn_adv_umx + + + SUBROUTINE adv_umx( pamsk, kn_umx, jt, kt, pdt, pu, pv, puc, pvc, pubox, pvbox, & + & pt, ptc, pua_ups, pva_ups, pua_ho, pva_ho ) + !!---------------------------------------------------------------------- + !! *** ROUTINE adv_umx *** + !! + !! ** Purpose : Compute the now trend due to total advection of + !! tracers and add it to the general trend of tracer equations + !! + !! ** Method : - calculate upstream fluxes and upstream solution for tracers V/A(=H) etc + !! - calculate tracer H at u and v points (Ultimate) + !! - calculate the high order fluxes using alterning directions (Macho) + !! - apply a limiter on the fluxes (nonosc_ice) + !! - convert this tracer flux to a "volume" flux (uH -> uV) + !! - apply a limiter a second time on the volumes fluxes (nonosc_ice) + !! - calculate the high order solution for V + !! + !! ** Action : solve 3 equations => a) dA/dt = -div(uA) + !! b) dV/dt = -div(uV) using dH/dt = -u.grad(H) + !! c) dVS/dt = -div(uVS) using either dHS/dt = -u.grad(HS) or dS/dt = -u.grad(S) + !! + !! in eq. b), - fluxes uH are evaluated (with UMx) and limited with nonosc_ice. This step is necessary to get a good H. + !! - then we convert this flux to a "volume" flux this way => uH * uA / u + !! where uA is the flux from eq. a) + !! this "volume" flux is also limited with nonosc_ice (otherwise overshoots can occur) + !! - at last we estimate dV/dt = -div(uH * uA / u) + !! + !! in eq. c), one can solve the equation for S (ln_advS=T), then dVS/dt = -div(uV * uS / u) + !! or for HS (ln_advS=F), then dVS/dt = -div(uA * uHS / u) + !! + !! ** Note : - this method can lead to tiny negative V (-1.e-20) => set it to 0 while conserving mass etc. + !! - At the ice edge, Ultimate scheme can lead to: + !! 1) negative interpolated tracers at u-v points + !! 2) non-zero interpolated tracers at u-v points eventhough there is no ice and velocity is outward + !! Solution for 1): apply an upstream scheme when it occurs. A better solution would be to degrade the order of + !! the scheme automatically by applying a mask of the ice cover inside Ultimate (not done). + !! Solution for 2): we set it to 0 in this case + !! - Eventhough 1D tests give very good results (typically the one from Schar & Smolarkiewiecz), the 2D is less good. + !! Large values of H can appear for very small ice concentration, and when it does it messes the things up since we + !! work on H (and not V). It is partly related to the multi-category approach + !! Therefore, after advection we limit the thickness to the largest value of the 9-points around (only if ice + !! concentration is small). We also limit S and T. + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: kn_umx ! order of the scheme (1-5=UM or 20=CEN2) + INTEGER , INTENT(in ) :: jt ! number of sub-iteration + INTEGER , INTENT(in ) :: kt ! number of iteration + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pu , pv ! 2 ice velocity components => u*e2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: puc , pvc ! 2 ice velocity components => u*e2 or u*a*e2u + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pubox, pvbox ! upstream velocity + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pt ! tracer field + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: ptc ! tracer content field + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(inout), OPTIONAL :: pua_ups, pva_ups ! upstream u*a fluxes + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out), OPTIONAL :: pua_ho, pva_ho ! high order u*a fluxes + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zfu_ho , zfv_ho , zpt + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zfu_ups, zfv_ups, zt_ups + !!---------------------------------------------------------------------- + ! + ! Upstream (_ups) fluxes + ! ----------------------- + CALL upstream( pamsk, jt, kt, pdt, pt, pu, pv, zt_ups, zfu_ups, zfv_ups ) + + ! High order (_ho) fluxes + ! ----------------------- + SELECT CASE( kn_umx ) + ! + CASE ( 20 ) !== centered second order ==! + ! + CALL cen2( pamsk, jt, kt, pdt, pt, pu, pv, zt_ups, zfu_ups, zfv_ups, zfu_ho, zfv_ho ) + ! + CASE ( 1:5 ) !== 1st to 5th order ULTIMATE-MACHO scheme ==! + ! + CALL macho( pamsk, kn_umx, jt, kt, pdt, pt, pu, pv, pubox, pvbox, zt_ups, zfu_ups, zfv_ups, zfu_ho, zfv_ho ) + ! + END SELECT + ! + ! --ho --ho + ! new fluxes = u*H * u*a / u + ! ---------------------------- + IF( pamsk == 0._wp ) THEN + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 + IF( ABS( pu(ji,jj) ) > epsi10 ) THEN + zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc (ji,jj,jl) / pu(ji,jj) + zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) + ELSE + zfu_ho (ji,jj,jl) = 0._wp + zfu_ups(ji,jj,jl) = 0._wp + ENDIF + ! + END DO + END DO + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + IF( ABS( pv(ji,jj) ) > epsi10 ) THEN + zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc (ji,jj,jl) / pv(ji,jj) + zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) + ELSE + zfv_ho (ji,jj,jl) = 0._wp + zfv_ups(ji,jj,jl) = 0._wp + ENDIF + END DO + END DO + END DO + + ! the new "volume" fluxes must also be "flux corrected" + ! thus we calculate the upstream solution and apply a limiter again + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) + ! + zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1.0_wp ) + ! + IF ( np_limiter == 1 ) THEN + CALL nonosc_ice( 1._wp, pdt, pu, pv, ptc, zt_ups, zfu_ups, zfv_ups, zfu_ho, zfv_ho ) + ELSEIF( np_limiter == 2 .OR. np_limiter == 3 ) THEN + CALL limiter_x( pdt, pu, ptc, zfu_ups, zfu_ho ) + CALL limiter_y( pdt, pv, ptc, zfv_ups, zfv_ho ) + ENDIF + ! + ENDIF + ! --ho --ups + ! in case of advection of A: output u*a and u*a + ! ----------------------------------------------- + IF( PRESENT( pua_ho ) ) THEN + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 + pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) + pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) + END DO + END DO + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) + pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) + END DO + END DO + END DO + ENDIF + ! + ! final trend with corrected fluxes + ! --------------------------------- + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) ) + ! + ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) + END DO + END DO + END DO + ! + END SUBROUTINE adv_umx + + + SUBROUTINE upstream( pamsk, jt, kt, pdt, pt, pu, pv, pt_ups, pfu_ups, pfv_ups ) + !!--------------------------------------------------------------------- + !! *** ROUTINE upstream *** + !! + !! ** Purpose : compute the upstream fluxes and upstream guess of tracer + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: jt ! number of sub-iteration + INTEGER , INTENT(in ) :: kt ! number of iteration + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pt ! tracer fields + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pu, pv ! 2 ice velocity components + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pt_ups ! upstream guess of tracer + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pfu_ups, pfv_ups ! upstream fluxes + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zpt + !!---------------------------------------------------------------------- + + IF( .NOT. ll_upsxy ) THEN !** no alternate directions **! + ! + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) + pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) + END DO + END DO + END DO + ! + ELSE !** alternate directions **! + ! + IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! + ! + DO jl = 1, jpl !-- flux in x-direction + DO jj = 1, jpj + DO ji = 1, fs_jpim1 + pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) + END DO + END DO + END DO + ! + DO jl = 1, jpl !-- first guess of tracer from u-flux + DO jj = 1, jpj + DO ji = fs_2, fs_jpim1 + ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) ) & + & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) + ! + zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + ! + DO jl = 1, jpl !-- flux in y-direction + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) + END DO + END DO + END DO + ! + ELSE !== even ice time step: adv_y then adv_x ==! + ! + DO jl = 1, jpl !-- flux in y-direction + DO jj = 1, jpjm1 + DO ji = 1, jpi + pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) + END DO + END DO + END DO + ! + DO jl = 1, jpl !-- first guess of tracer from v-flux + DO jj = 2, jpjm1 + DO ji = 1, jpi + ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) ) & + & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) + ! + zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + ! + DO jl = 1, jpl !-- flux in x-direction + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 + pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) + END DO + END DO + END DO + ! + ENDIF + + ENDIF + ! + DO jl = 1, jpl !-- after tracer with upstream scheme + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) & + & + pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) & + & + ( pu (ji,jj ) - pu (ji-1,jj ) & + & + pv (ji,jj ) - pv (ji ,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) + ! + pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1.0_wp ) + + END SUBROUTINE upstream + + + SUBROUTINE cen2( pamsk, jt, kt, pdt, pt, pu, pv, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cen2 *** + !! + !! ** Purpose : compute the high order fluxes using a centered + !! second order scheme + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: jt ! number of sub-iteration + INTEGER , INTENT(in ) :: kt ! number of iteration + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pt ! tracer fields + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pu, pv ! 2 ice velocity components + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pt_ups ! upstream guess of tracer + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pfu_ups, pfv_ups ! upstream fluxes + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pfu_ho, pfv_ho ! high order fluxes + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zpt + !!---------------------------------------------------------------------- + ! + IF( .NOT.ll_hoxy ) THEN !** no alternate directions **! + ! + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, fs_jpim1 + pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj ,jl) ) + END DO + END DO + DO jj = 1, jpjm1 + DO ji = 1, jpi + pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji ,jj+1,jl) ) + END DO + END DO + END DO + ! + IF ( np_limiter == 1 ) THEN + CALL nonosc_ice( pamsk, pdt, pu, pv, pt, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + ELSEIF( np_limiter == 2 .OR. np_limiter == 3 ) THEN + CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) + CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) + ENDIF + ! + ELSE !** alternate directions **! + ! + IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! + ! + DO jl = 1, jpl !-- flux in x-direction + DO jj = 1, jpj + DO ji = 1, fs_jpim1 + pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) + END DO + END DO + END DO + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) + + DO jl = 1, jpl !-- first guess of tracer from u-flux + DO jj = 1, jpj + DO ji = fs_2, fs_jpim1 + ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) ) & + & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) + ! + zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + + DO jl = 1, jpl !-- flux in y-direction + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) + END DO + END DO + END DO + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) + + ELSE !== even ice time step: adv_y then adv_x ==! + ! + DO jl = 1, jpl !-- flux in y-direction + DO jj = 1, jpjm1 + DO ji = 1, jpi + pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) + END DO + END DO + END DO + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) + ! + DO jl = 1, jpl !-- first guess of tracer from v-flux + DO jj = 2, jpjm1 + DO ji = 1, jpi + ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) ) & + & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) + ! + zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + ! + DO jl = 1, jpl !-- flux in x-direction + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 + pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) + END DO + END DO + END DO + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) + + ENDIF + IF( np_limiter == 1 ) CALL nonosc_ice( pamsk, pdt, pu, pv, pt, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + + ENDIF + + END SUBROUTINE cen2 + + + SUBROUTINE macho( pamsk, kn_umx, jt, kt, pdt, pt, pu, pv, pubox, pvbox, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE macho *** + !! + !! ** Purpose : compute the high order fluxes using Ultimate-Macho scheme + !! + !! ** Method : ... + !! + !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: kn_umx ! order of the scheme (1-5=UM or 20=CEN2) + INTEGER , INTENT(in ) :: jt ! number of sub-iteration + INTEGER , INTENT(in ) :: kt ! number of iteration + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pt ! tracer fields + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pu, pv ! 2 ice velocity components + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pubox, pvbox ! upstream velocity + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pt_ups ! upstream guess of tracer + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pfu_ups, pfv_ups ! upstream fluxes + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pfu_ho, pfv_ho ! high order fluxes + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zt_u, zt_v, zpt + !!---------------------------------------------------------------------- + ! + IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! + ! + ! !-- ultimate interpolation of pt at u-point --! + CALL ultimate_x( pamsk, kn_umx, pdt, pt, pu, zt_u, pfu_ho ) + ! !-- limiter in x --! + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, CASTDP(pt), pfu_ups, pfu_ho ) + ! !-- advective form update in zpt --! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pubox(ji,jj ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t (ji,jj) & + & + pt (ji,jj,jl) * ( pu (ji,jj ) - pu (ji-1,jj ) ) * r1_e1e2t(ji,jj) & + & * pamsk & + & ) * pdt ) * tmask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) + ! + ! !-- ultimate interpolation of pt at v-point --! + IF( ll_hoxy ) THEN + CALL ultimate_y( pamsk, kn_umx, pdt, CASTDP(zpt), pv, zt_v, pfv_ho ) + ELSE + CALL ultimate_y( pamsk, kn_umx, pdt, pt , pv, zt_v, pfv_ho ) + ENDIF + ! !-- limiter in y --! + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, CASTDP(pt), pfv_ups, pfv_ho ) + ! + ! + ELSE !== even ice time step: adv_y then adv_x ==! + ! + ! !-- ultimate interpolation of pt at v-point --! + CALL ultimate_y( pamsk, kn_umx, pdt, pt, pv, zt_v, pfv_ho ) + ! !-- limiter in y --! + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, CASTDP(pt), pfv_ups, pfv_ho ) + ! !-- advective form update in zpt --! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pvbox(ji,jj ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t (ji,jj) & + & + pt (ji,jj,jl) * ( pv (ji,jj ) - pv (ji,jj-1 ) ) * r1_e1e2t(ji,jj) & + & * pamsk & + & ) * pdt ) * tmask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) + ! + ! !-- ultimate interpolation of pt at u-point --! + IF( ll_hoxy ) THEN + CALL ultimate_x( pamsk, kn_umx, pdt, CASTDP(zpt), pu, zt_u, pfu_ho ) + ELSE + CALL ultimate_x( pamsk, kn_umx, pdt, pt , pu, zt_u, pfu_ho ) + ENDIF + ! !-- limiter in x --! + IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, CASTDP(pt), pfu_ups, pfu_ho ) + ! + ENDIF + + IF( np_limiter == 1 ) CALL nonosc_ice( pamsk, pdt, pu, pv, pt, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + ! + END SUBROUTINE macho + + + SUBROUTINE ultimate_x( pamsk, kn_umx, pdt, pt, pu, pt_u, pfu_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ultimate_x *** + !! + !! ** Purpose : compute tracer at u-points + !! + !! ** Method : ... + !! + !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: kn_umx ! order of the scheme (1-5=UM or 20=CEN2) + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pu ! ice i-velocity component + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pt_u ! tracer at u-point + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pfu_ho ! high order flux + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: zcu, zdx2, zdx4 ! - - + REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztu1, ztu2, ztu3, ztu4 + !!---------------------------------------------------------------------- + ! + ! !-- Laplacian in i-direction --! + DO jl = 1, jpl + DO jj = 2, jpjm1 ! First derivative (gradient) + DO ji = 1, fs_jpim1 + ztu1(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * r1_e1u(ji,jj) * umask(ji,jj,1) + END DO + ! ! Second derivative (Laplacian) + DO ji = fs_2, fs_jpim1 + ztu2(ji,jj,jl) = ( ztu1(ji,jj,jl) - ztu1(ji-1,jj,jl) ) * r1_e1t(ji,jj) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1.0_wp ) + ! + ! !-- BiLaplacian in i-direction --! + DO jl = 1, jpl + DO jj = 2, jpjm1 ! Third derivative + DO ji = 1, fs_jpim1 + ztu3(ji,jj,jl) = ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) * r1_e1u(ji,jj) * umask(ji,jj,1) + END DO + ! ! Fourth derivative + DO ji = fs_2, fs_jpim1 + ztu4(ji,jj,jl) = ( ztu3(ji,jj,jl) - ztu3(ji-1,jj,jl) ) * r1_e1t(ji,jj) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1.0_wp ) + ! + ! + SELECT CASE (kn_umx ) + ! + CASE( 1 ) !== 1st order central TIM ==! (Eq. 21) + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & + & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) + END DO + END DO + END DO + ! + CASE( 2 ) !== 2nd order central TIM ==! (Eq. 23) + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & + & - zcu * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) + END DO + END DO + END DO + ! + CASE( 3 ) !== 3rd order central TIM ==! (Eq. 24) + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) + zdx2 = e1u(ji,jj) * e1u(ji,jj) +!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & + & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & + & - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + CASE( 4 ) !== 4th order central TIM ==! (Eq. 27) + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) + zdx2 = e1u(ji,jj) * e1u(ji,jj) +!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & + & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & + & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + CASE( 5 ) !== 5th order central TIM ==! (Eq. 29) + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) + zdx2 = e1u(ji,jj) * e1u(ji,jj) +!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) + zdx4 = zdx2 * zdx2 + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & + & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & + & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & + & + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl) & + & - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + END SELECT + ! + ! if pt at u-point is negative then use the upstream value + ! this should not be necessary if a proper sea-ice mask is set in Ultimate + ! to degrade the order of the scheme when necessary (for ex. at the ice edge) + IF( ll_neg ) THEN + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 + IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN + pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & + & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) + ENDIF + END DO + END DO + END DO + ENDIF + ! !-- High order flux in i-direction --! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) + END DO + END DO + END DO + ! + END SUBROUTINE ultimate_x + + + SUBROUTINE ultimate_y( pamsk, kn_umx, pdt, pt, pv, pt_v, pfv_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ultimate_y *** + !! + !! ** Purpose : compute tracer at v-points + !! + !! ** Method : ... + !! + !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + INTEGER , INTENT(in ) :: kn_umx ! order of the scheme (1-5=UM or 20=CEN2) + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,: ) , INTENT(in ) :: pv ! ice j-velocity component + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pt_v ! tracer at v-point + REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( out) :: pfv_ho ! high order flux + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: zcv, zdy2, zdy4 ! - - + REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztv1, ztv2, ztv3, ztv4 + !!---------------------------------------------------------------------- + ! + ! !-- Laplacian in j-direction --! + DO jl = 1, jpl + DO jj = 1, jpjm1 ! First derivative (gradient) + DO ji = fs_2, fs_jpim1 + ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) + END DO + END DO + DO jj = 2, jpjm1 ! Second derivative (Laplacian) + DO ji = fs_2, fs_jpim1 + ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1.0_wp ) + ! + ! !-- BiLaplacian in j-direction --! + DO jl = 1, jpl + DO jj = 1, jpjm1 ! First derivative + DO ji = fs_2, fs_jpim1 + ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) + END DO + END DO + DO jj = 2, jpjm1 ! Second derivative + DO ji = fs_2, fs_jpim1 + ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1.0_wp ) + ! + ! + SELECT CASE (kn_umx ) + ! + CASE( 1 ) !== 1st order central TIM ==! (Eq. 21) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & + & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) + END DO + END DO + END DO + ! + CASE( 2 ) !== 2nd order central TIM ==! (Eq. 23) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & + & - zcv * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) + END DO + END DO + END DO + ! + CASE( 3 ) !== 3rd order central TIM ==! (Eq. 24) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) + zdy2 = e2v(ji,jj) * e2v(ji,jj) +!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & + & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & + & - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + CASE( 4 ) !== 4th order central TIM ==! (Eq. 27) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) + zdy2 = e2v(ji,jj) * e2v(ji,jj) +!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & + & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & + & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + CASE( 5 ) !== 5th order central TIM ==! (Eq. 29) + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) + zdy2 = e2v(ji,jj) * e2v(ji,jj) +!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) + zdy4 = zdy2 * zdy2 + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & + & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & + & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & + & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & + & + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl) & + & - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) + END DO + END DO + END DO + ! + END SELECT + ! + ! if pt at v-point is negative then use the upstream value + ! this should not be necessary if a proper sea-ice mask is set in Ultimate + ! to degrade the order of the scheme when necessary (for ex. at the ice edge) + IF( ll_neg ) THEN + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN + pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) & + & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) + ENDIF + END DO + END DO + END DO + ENDIF + ! !-- High order flux in j-direction --! + DO jl = 1, jpl + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) + END DO + END DO + END DO + ! + END SUBROUTINE ultimate_y + + + SUBROUTINE nonosc_ice( pamsk, pdt, pu, pv, pt, pt_ups, pfu_ups, pfv_ups, pfu_ho, pfv_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc_ice *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a non-oscillatory algorithm + !! + !! ** Method : ... + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION (:,: ), INTENT(in ) :: pu ! ice i-velocity => u*e2 + REAL(wp), DIMENSION (:,: ), INTENT(in ) :: pv ! ice j-velocity => v*e1 + REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pt_ups! before field & upstream guess of after field + REAL(dp), DIMENSION (:,:,:), INTENT(in ) :: pt! before field & upstream guess of after field + REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pfv_ups, pfu_ups ! upstream flux + REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: pfv_ho, pfu_ho ! monotonic flux + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: zpos, zneg, zup, zdo, z1_dt ! local scalars + REAL(dp) :: zbig + REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zcoef, zzt ! - - + REAL(wp), DIMENSION(jpi,jpj ) :: zbup, zbdo + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zbetup, zbetdo, zti_ups, ztj_ups + !!---------------------------------------------------------------------- + zbig = 1.e+38_wp + + ! antidiffusive flux : high order minus low order + ! -------------------------------------------------- + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) + END DO + END DO + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) + END DO + END DO + END DO + + ! extreme case where pfu_ho has to be zero + ! ---------------------------------------- + ! pfu_ho + ! * ---> + ! | | * | | + ! | | | * | + ! | | | | * + ! t_ups : i-1 i i+1 i+2 + IF( ll_prelim ) THEN + + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zti_ups(ji,jj,jl)= pt_ups(ji+1,jj ,jl) + ztj_ups(ji,jj,jl)= pt_ups(ji ,jj+1,jl) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp ) + + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND. & + & pfv_ho(ji,jj,jl) * ( pt_ups(ji ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN + ! + IF( pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND. & + & pfv_ho(ji,jj,jl) * ( ztj_ups(ji ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN + pfu_ho(ji,jj,jl)=0._wp + pfv_ho(ji,jj,jl)=0._wp + ENDIF + ! + IF( pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj ,jl) ) <= 0._wp .AND. & + & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji ,jj-1,jl) ) <= 0._wp ) THEN + pfu_ho(ji,jj,jl)=0._wp + pfv_ho(ji,jj,jl)=0._wp + ENDIF + ! + ENDIF + END DO + END DO + END DO + CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp ) ! lateral boundary cond. + + ENDIF + + ! Search local extrema + ! -------------------- + ! max/min of pt & pt_ups with large negative/positive value (-/+zbig) outside ice cover + z1_dt = 1._wp / pdt + DO jl = 1, jpl + + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN + zbup(ji,jj) = -zbig + zbdo(ji,jj) = zbig + ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN + zbup(ji,jj) = pt_ups(ji,jj,jl) + zbdo(ji,jj) = pt_ups(ji,jj,jl) + ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN + zbup(ji,jj) = pt(ji,jj,jl) + zbdo(ji,jj) = pt(ji,jj,jl) + ELSE + zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) + zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) + ENDIF + END DO + END DO + + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! + zup = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) ) ! search max/min in neighbourhood + zdo = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) + ! + zpos = MAX( 0._wp, pfu_ho(ji-1,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji ,jj ,jl) ) & ! positive/negative part of the flux + & + MAX( 0._wp, pfv_ho(ji ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj ,jl) ) + zneg = MAX( 0._wp, pfu_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj ,jl) ) & + & + MAX( 0._wp, pfv_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj-1,jl) ) + ! + zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) & + & ) * ( 1. - pamsk ) + zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) & + & ) * ( 1. - pamsk ) + ! + ! ! up & down beta terms + ! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!) + IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt + ELSE ; zbetup(ji,jj,jl) = 0._wp ! zbig + ENDIF + ! + IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt + ELSE ; zbetdo(ji,jj,jl) = 0._wp ! zbig + ENDIF + ! + ! if all the points are outside ice cover + IF( zup == -zbig ) zbetup(ji,jj,jl) = 0._wp ! zbig + IF( zdo == zbig ) zbetdo(ji,jj,jl) = 0._wp ! zbig + ! + END DO + END DO + END DO + CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) + + + ! monotonic flux in the y direction + ! --------------------------------- + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) + zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) + zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) + ! + zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) + ! + pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) + ! + END DO + END DO + + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) + zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) + zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) + ! + zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) + ! + pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) + ! + END DO + END DO + + END DO + ! + END SUBROUTINE nonosc_ice + + + SUBROUTINE limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE limiter_x *** + !! + !! ** Purpose : compute flux limiter + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,: ), INTENT(in ) :: pu ! ice i-velocity => u*e2 + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pt ! ice tracer + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pfu_ups ! upstream flux + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pfu_ho ! high order flux + ! + REAL(wp) :: Cr, Rjm, Rj, Rjp, uCFL, zpsi, zh3, zlimiter, Rr + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION (jpi,jpj,jpl) :: zslpx ! tracer slopes + !!---------------------------------------------------------------------- + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.0_wp) ! lateral boundary cond. + + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) + + Rjm = zslpx(ji-1,jj,jl) + Rj = zslpx(ji ,jj,jl) + Rjp = zslpx(ji+1,jj,jl) + + IF( np_limiter == 3 ) THEN + + IF( pu(ji,jj) > 0. ) THEN ; Rr = Rjm + ELSE ; Rr = Rjp + ENDIF + + zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) + IF( Rj > 0. ) THEN + zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)), & + & MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) + ELSE + zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)), & + & MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) + ENDIF + pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter + + ELSEIF( np_limiter == 2 ) THEN + IF( Rj /= 0. ) THEN + IF( pu(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj + ELSE ; Cr = Rjp / Rj + ENDIF + ELSE + Cr = 0. + ENDIF + + ! -- superbee -- + zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) + ! -- van albada 2 -- + !!zpsi = 2.*Cr / (Cr*Cr+1.) + ! -- sweby (with beta=1) -- + !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) + ! -- van Leer -- + !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) + ! -- ospre -- + !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) + ! -- koren -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) + ! -- charm -- + !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) + !ELSE ; zpsi = 0. + !ENDIF + ! -- van albada 1 -- + !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) + ! -- smart -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) + ! -- umist -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) + + ! high order flux corrected by the limiter + pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 + + ENDIF + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp) ! lateral boundary cond. + ! + END SUBROUTINE limiter_x + + + SUBROUTINE limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) + !!--------------------------------------------------------------------- + !! *** ROUTINE limiter_y *** + !! + !! ** Purpose : compute flux limiter + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION (:,: ), INTENT(in ) :: pv ! ice i-velocity => u*e2 + REAL(dp), DIMENSION (:,:,:), INTENT(in ) :: pt ! ice tracer + REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pfv_ups ! upstream flux + REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: pfv_ho ! high order flux + ! + REAL(wp) :: Cr, Rjm, Rj, Rjp, vCFL, zpsi, zh3, zlimiter, Rr + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION (jpi,jpj,jpl) :: zslpy ! tracer slopes + !!---------------------------------------------------------------------- + ! + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.0_wp) ! lateral boundary cond. + + DO jl = 1, jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) + + Rjm = zslpy(ji,jj-1,jl) + Rj = zslpy(ji,jj ,jl) + Rjp = zslpy(ji,jj+1,jl) + + IF( np_limiter == 3 ) THEN + + IF( pv(ji,jj) > 0. ) THEN ; Rr = Rjm + ELSE ; Rr = Rjp + ENDIF + + zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) + IF( Rj > 0. ) THEN + zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)), & + & MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) + ELSE + zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)), & + & MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) + ENDIF + pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter + + ELSEIF( np_limiter == 2 ) THEN + + IF( Rj /= 0. ) THEN + IF( pv(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj + ELSE ; Cr = Rjp / Rj + ENDIF + ELSE + Cr = 0. + ENDIF + + ! -- superbee -- + zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) + ! -- van albada 2 -- + !!zpsi = 2.*Cr / (Cr*Cr+1.) + ! -- sweby (with beta=1) -- + !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) + ! -- van Leer -- + !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) + ! -- ospre -- + !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) + ! -- koren -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) + ! -- charm -- + !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) + !ELSE ; zpsi = 0. + !ENDIF + ! -- van albada 1 -- + !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) + ! -- smart -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) + ! -- umist -- + !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) + + ! high order flux corrected by the limiter + pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 + + ENDIF + END DO + END DO + END DO + CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.0_wp) ! lateral boundary cond. + ! + END SUBROUTINE limiter_y + + + SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & + & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) + !!------------------------------------------------------------------- + !! *** ROUTINE Hbig *** + !! + !! ** Purpose : Thickness correction in case advection scheme creates + !! abnormally tick ice or snow + !! + !! ** Method : 1- check whether ice thickness is larger than the surrounding 9-points + !! (before advection) and reduce it by adapting ice concentration + !! 2- check whether snow thickness is larger than the surrounding 9-points + !! (before advection) and reduce it by sending the excess in the ocean + !! + !! ** input : Max thickness of the surrounding 9-points + !!------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts + REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pes_max + REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pei_max + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra + !!------------------------------------------------------------------- + ! + z1_dt = 1._wp / pdt + ! + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! + ! ! -- check h_ip -- ! + ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip + IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN + zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) + IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN + pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) + ENDIF + ENDIF + ! + ! ! -- check h_i -- ! + ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i + zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) + IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) + ENDIF + ! + ! ! -- check h_s -- ! + ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean + zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) + IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) + ! + wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt + hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + ! + pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra + pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) + ENDIF + ! + ! ! -- check s_i -- ! + ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean + zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) + IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = psi_max(ji,jj,jl) / zsi + sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt + psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra + ENDIF + ! + ENDIF + END DO + END DO + END DO + ! + ! ! -- check e_i/v_i -- ! + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean + zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) + IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = pei_max(ji,jj,jk,jl) / zei + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra + ENDIF + ENDIF + END DO + END DO + END DO + END DO + ! ! -- check e_s/v_s -- ! + DO jl = 1, jpl + DO jk = 1, nlay_s + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_s(ji,jj,jl) > 0._wp ) THEN + ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean + zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) + IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN + zfra = pes_max(ji,jj,jk,jl) / zes + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra + ENDIF + ENDIF + END DO + END DO + END DO + END DO + ! + END SUBROUTINE Hbig + + + SUBROUTINE Hsnow( pdt, pv_i, pv_s, pa_i, pa_ip, pe_s ) + !!------------------------------------------------------------------- + !! *** ROUTINE Hsnow *** + !! + !! ** Purpose : 1- Check snow load after advection + !! 2- Correct pond concentration to avoid a_ip > a_i + !! + !! ** Method : If snow load makes snow-ice interface to deplet below the ocean surface + !! then put the snow excess in the ocean + !! + !! ** Notes : This correction is crucial because of the call to routine icecor afterwards + !! which imposes a mini of ice thick. (rn_himin). This imposed mini can artificially + !! make the snow very thick (if concentration decreases drastically) + !! This behavior has been seen in Ultimate-Macho and supposedly it can also be true for Prather + !!------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: z1_dt, zvs_excess, zfra + !!------------------------------------------------------------------- + ! + z1_dt = 1._wp / pdt + ! + ! -- check snow load -- ! + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + IF ( pv_i(ji,jj,jl) > 0._wp ) THEN + ! + zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) + ! + IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface + ! put snow excess in the ocean + zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) + wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt + hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 + ! correct snow volume and heat content + pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra + pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess + ENDIF + ! + ENDIF + END DO + END DO + END DO + ! + !-- correct pond concentration to avoid a_ip > a_i -- ! + WHERE( pa_ip(:,:,:) > pa_i(:,:,:) ) pa_ip(:,:,:) = pa_i(:,:,:) + ! + END SUBROUTINE Hsnow + + SUBROUTINE icemax3D( pice , pmax ) + !!--------------------------------------------------------------------- + !! *** ROUTINE icemax3D *** + !! ** Purpose : compute the max of the 9 points around + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pice ! input + REAL(wp), DIMENSION(:,:,:) , INTENT(out) :: pmax ! output + REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array + INTEGER :: ji, jj, jl ! dummy loop indices + !!---------------------------------------------------------------------- + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 2, jpim1 + zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jl), pice(ji-1,jj,jl), pice(ji+1,jj,jl) ) + END DO + END DO + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + pmax(ji,jj,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) + END DO + END DO + END DO + END SUBROUTINE icemax3D + + SUBROUTINE icemax4D( pice , pmax ) + !!--------------------------------------------------------------------- + !! *** ROUTINE icemax4D *** + !! ** Purpose : compute the max of the 9 points around + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pice ! input + REAL(wp), DIMENSION(:,:,:,:) , INTENT(out) :: pmax ! output + REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array + INTEGER :: jlay, ji, jj, jk, jl ! dummy loop indices + !!---------------------------------------------------------------------- + jlay = SIZE( pice , 3 ) ! size of input arrays + DO jl = 1, jpl + DO jk = 1, jlay + DO jj = 1, jpj + DO ji = 2, jpim1 + zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jk,jl), pice(ji-1,jj,jk,jl), pice(ji+1,jj,jk,jl) ) + END DO + END DO + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + pmax(ji,jj,jk,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) + END DO + END DO + END DO + END DO + END SUBROUTINE icemax4D + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn_adv_umx diff --git a/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.mod b/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.mod new file mode 100644 index 0000000000000000000000000000000000000000..610878b4ed31cbaa7df04057bf2df6a1a4eda279 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_adv_umx.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.F90 b/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e68e12be1eb7d2670f84d5206e88c4d4f38b10ac --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.F90 @@ -0,0 +1,1022 @@ +MODULE icedyn_rdgrft + !!====================================================================== + !! *** MODULE icedyn_rdgrft *** + !! sea-ice : Mechanical impact on ice thickness distribution + !!====================================================================== + !! History : ! 2006-02 (M. Vancoppenolle) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_rdgrft : ridging/rafting of sea ice + !! ice_dyn_rdgrft_init : initialization of ridging/rafting of sea ice + !! ice_strength : ice strength calculation + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE phycst ! physical constants (ocean directory) + USE sbc_oce , ONLY : sss_m, sst_m ! surface boundary condition: ocean fields + USE ice1D ! sea-ice: thermodynamics + USE ice ! sea-ice: variables + USE icetab ! sea-ice: 1D <==> 2D transformation + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: control prints + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_rdgrft ! called by icestp + PUBLIC ice_dyn_rdgrft_init ! called by icedyn + PUBLIC ice_strength ! called by icedyn_rhg_evp + + ! Variables shared among ridging subroutines + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: closing_net ! net rate at which area is removed (1/s) + ! ! (ridging ice area - area of new ridges) / dt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: opning ! rate of opening due to divergence/shear + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: closing_gross ! rate at which area removed, not counting area of new ridges + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: apartf ! participation function; fraction of ridging/closing associated w/ category n + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hrmin ! minimum ridge thickness + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hrmax ! maximum ridge thickness + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hraft ! thickness of rafted ice + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hi_hrdg ! thickness of ridging ice / mean ridge thickness + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: aridge ! participating ice ridging + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: araft ! participating ice rafting + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ze_i_2d + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ze_s_2d + ! + REAL(wp), PARAMETER :: hrdg_hi_min = 1.1_wp ! min ridge thickness multiplier: min(hrdg/hi) + REAL(wp), PARAMETER :: hi_hrft = 0.5_wp ! rafting multipliyer: (hi/hraft) + ! + ! ** namelist (namdyn_rdgrft) ** + LOGICAL :: ln_str_H79 ! ice strength parameterization (Hibler79) + REAL(wp) :: rn_pstar ! determines ice strength, Hibler JPO79 + REAL(wp) :: rn_csrdg ! fraction of shearing energy contributing to ridging + LOGICAL :: ln_partf_lin ! participation function linear (Thorndike et al. (1975)) + REAL(wp) :: rn_gstar ! fractional area of young ice contributing to ridging + LOGICAL :: ln_partf_exp ! participation function exponential (Lipscomb et al. (2007)) + REAL(wp) :: rn_astar ! equivalent of G* for an exponential participation function + LOGICAL :: ln_ridging ! ridging of ice or not + REAL(wp) :: rn_hstar ! thickness that determines the maximal thickness of ridged ice + REAL(wp) :: rn_porordg ! initial porosity of ridges (0.3 regular value) + REAL(wp) :: rn_fsnwrdg ! fractional snow loss to the ocean during ridging + REAL(wp) :: rn_fpndrdg ! fractional pond loss to the ocean during ridging + LOGICAL :: ln_rafting ! rafting of ice or not + REAL(wp) :: rn_hraft ! threshold thickness (m) for rafting / ridging + REAL(wp) :: rn_craft ! coefficient for smoothness of the hyperbolic tangent in rafting + REAL(wp) :: rn_fsnwrft ! fractional snow loss to the ocean during rafting + REAL(wp) :: rn_fpndrft ! fractional pond loss to the ocean during rafting + ! + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_rdgrft.F90 13617 2020-10-16 08:07:20Z clem $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +CONTAINS + + INTEGER FUNCTION ice_dyn_rdgrft_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rdgrft_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( closing_net(jpij) , opning(jpij) , closing_gross(jpij) , & + & apartf(jpij,0:jpl) , hrmin (jpij,jpl) , hraft(jpij,jpl) , aridge(jpij,jpl), & + & hrmax (jpij,jpl) , hi_hrdg(jpij,jpl) , araft(jpij,jpl) , & + & ze_i_2d(jpij,nlay_i,jpl), ze_s_2d(jpij,nlay_s,jpl), STAT=ice_dyn_rdgrft_alloc ) + + CALL mpp_sum ( 'icedyn_rdgrft', ice_dyn_rdgrft_alloc ) + IF( ice_dyn_rdgrft_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_dyn_rdgrft_alloc: failed to allocate arrays' ) + ! + END FUNCTION ice_dyn_rdgrft_alloc + + + SUBROUTINE ice_dyn_rdgrft( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rdgrft *** + !! + !! ** Purpose : computes the mechanical redistribution of ice thickness + !! + !! ** Method : Steps : + !! 0) Identify grid cells with ice + !! 1) Calculate closing rate, divergence and opening + !! 2) Identify grid cells with ridging + !! 3) Start ridging iterations + !! - prep = ridged and rafted ice + closing_gross + !! - shift = move ice from one category to another + !! + !! ** Details + !! step1: The net rate of closing is due to convergence and shear, based on Flato and Hibler (1995). + !! The energy dissipation rate is equal to the net closing rate times the ice strength. + !! + !! step3: The gross closing rate is equal to the first two terms (open + !! water closing and thin ice ridging) without the third term + !! (thick, newly ridged ice). + !! + !! References : Flato, G. M., and W. D. Hibler III, 1995, JGR, 100, 18,611-18,626. + !! Hibler, W. D. III, 1980, MWR, 108, 1943-1973, 1980. + !! Rothrock, D. A., 1975: JGR, 80, 4514-4519. + !! Thorndike et al., 1975, JGR, 80, 4501-4513. + !! Bitz et al., JGR, 2001 + !! Amundrud and Melling, JGR 2005 + !! Babko et al., JGR 2002 + !! + !! This routine is based on CICE code and authors William H. Lipscomb, + !! and Elizabeth C. Hunke, LANL are gratefully acknowledged + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + !! + INTEGER :: ji, jj, jk, jl ! dummy loop index + INTEGER :: ji1, ji2, jpti ! OpenMP loop index + INTEGER :: itid, ithreads ! OpenMP variables + INTEGER :: iter, iterate_ridging ! local integer + INTEGER :: ipti ! local integer + REAL(wp) :: zfac ! local scalar + INTEGER , DIMENSION(jpij) :: iptidx ! compute ridge/raft or not + REAL(dp), DIMENSION(jpij) :: zdivu, zdelt ! 1D divu_i & delta_i + ! + INTEGER, PARAMETER :: jp_itermax = 20 + !!------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('icedyn_rdgrft') ! timing + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (0, 'icedyn_rdgrft', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'ice_dyn_rdgrft: ice ridging and rafting' + IF(lwp) WRITE(numout,*)'~~~~~~~~~~~~~~' + ENDIF + + !-------------------------------- + ! 0) Identify grid cells with ice + !-------------------------------- + at_i(:,:) = SUM( a_i, dim=3 ) + ! + npti = 0 ; nptidx(:) = 0 + ipti = 0 ; iptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( at_i(ji,jj) > epsi10 ) THEN + npti = npti + 1 + nptidx( npti ) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + + !$omp parallel private(ji,ji1,ji2,jpti,itid,ithreads, & + !$omp& iter,iterate_ridging,zfac) + ! + ! Split npti loops for openmp parallelism + CALL nompinfo( itid, ithreads ) + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + ! + !-------------------------------------------------------- + ! 1) Dynamical inputs (closing rate, divergence, opening) + !-------------------------------------------------------- + IF( npti > 0 ) THEN + + ! just needed here + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), zdelt (ji1:ji2) , delta_i ) + ! needed here and in the iteration loop + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), zdivu (ji1:ji2) , divu_i) ! zdivu is used as a work array here (no change in divu_i) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), a_i_2d (ji1:ji2,1:jpl), a_i ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), v_i_2d (ji1:ji2,1:jpl), v_i ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), ato_i_1d(ji1:ji2) , ato_i ) + + DO ji = ji1, ji2 + ! closing_net = rate at which open water area is removed + ice area removed by ridging + ! - ice area added in new ridges + closing_net(ji) = rn_csrdg * 0.5_wp * ( zdelt(ji) - ABS( zdivu(ji) ) ) - MIN( zdivu(ji), 0._wp ) + ! + IF( zdivu(ji) < 0._wp ) closing_net(ji) = MAX( closing_net(ji), -zdivu(ji) ) ! make sure the closing rate is large enough + ! ! to give asum = 1.0 after ridging + ! Opening rate (non-negative) that will give asum = 1.0 after ridging. + opning(ji) = closing_net(ji) + zdivu(ji) + END DO + ! + !------------------------------------ + ! 2) Identify grid cells with ridging + !------------------------------------ + CALL rdgrft_prep( ji1, ji2, a_i_2d, v_i_2d, ato_i_1d, closing_net ) + + !$omp barrier + !$omp master + DO ji = 1, npti + IF( SUM( apartf(ji,1:jpl) ) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN + ipti = ipti + 1 + iptidx (ipti) = nptidx (ji) + ! adjust to new indices + a_i_2d (ipti,:) = a_i_2d (ji,:) + v_i_2d (ipti,:) = v_i_2d (ji,:) + ato_i_1d (ipti) = ato_i_1d (ji) + closing_net(ipti) = closing_net(ji) + zdivu (ipti) = zdivu (ji) + opning (ipti) = opning (ji) + ENDIF + END DO + !$omp end master + !$omp barrier + + ENDIF + ! + ! grid cells with ridging + !$omp master + nptidx(:) = iptidx(:) + npti = ipti + !$omp end master + !$omp barrier + ! + ! Split npti loops for openmp parallelism + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + !----------------- + ! 3) Start ridging + !----------------- + IF( npti > 0 ) THEN + + CALL ice_dyn_1d2d( 1, ji1, ji2, jpti ) ! --- Move to 1D arrays --- ! + + iter = 1 + iterate_ridging = 1 + ! !----------------------! + DO WHILE( iterate_ridging > 0 .AND. iter < jp_itermax ) ! ridging iterations ! + ! !----------------------! + ! Calculate participation function (apartf) + ! and transfer function + ! and closing_gross (+correction on opening) + CALL rdgrft_prep( ji1, ji2, a_i_2d, v_i_2d, ato_i_1d, closing_net ) + + ! Redistribute area, volume, and energy between categories + CALL rdgrft_shift( ji1, ji2, jpti ) + + ! Do we keep on iterating? + !------------------------- + ! Check whether a_i + ato_i = 0 + ! If not, because the closing and opening rates were reduced above, ridge again with new rates + iterate_ridging = 0 + DO ji = ji1, ji2 + zfac = 1._wp - ( ato_i_1d(ji) + SUM( a_i_2d(ji,:) ) ) + IF( ABS( zfac ) < epsi10 ) THEN + closing_net(ji) = 0._wp + opning (ji) = 0._wp + ato_i_1d (ji) = MAX( 0._wp, 1._wp - SUM( a_i_2d(ji,:) ) ) + ELSE + iterate_ridging = 1 + zdivu (ji) = zfac * r1_rdtice + closing_net(ji) = MAX( 0._wp, -zdivu(ji) ) + opning (ji) = MAX( 0._wp, zdivu(ji) ) + ENDIF + END DO + ! + iter = iter + 1 + IF( iter > jp_itermax ) CALL ctl_stop( 'STOP', 'icedyn_rdgrft: non-converging ridging scheme' ) + ! + END DO + + CALL ice_dyn_1d2d( 2, ji1, ji2, jpti ) ! --- Move to 2D arrays --- ! + + ENDIF + + !$omp end parallel + + CALL ice_var_agg( 1 ) + + ! controls + IF( ln_ctl ) CALL ice_prt3D ('icedyn_rdgrft') ! prints + IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt,-1, ' - ice dyn rdgrft - ') ! prints + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (1, 'icedyn_rdgrft', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + IF( ln_timing ) CALL timing_stop ('icedyn_rdgrft') ! timing + ! + END SUBROUTINE ice_dyn_rdgrft + + + SUBROUTINE rdgrft_prep( ji1, ji2, pa_i, pv_i, pato_i, pclosing_net ) + !!------------------------------------------------------------------- + !! *** ROUTINE rdgrft_prep *** + !! + !! ** Purpose : preparation for ridging calculations + !! + !! ** Method : Compute the thickness distribution of the ice and open water + !! participating in ridging and of the resulting ridges. + !!------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ji1, ji2 + REAL(wp), DIMENSION(:) , INTENT(in) :: pclosing_net + REAL(dp), DIMENSION(:) , INTENT(in) :: pato_i + REAL(dp), DIMENSION(:,:), INTENT(in) :: pa_i, pv_i + !! + INTEGER :: ji, jl ! dummy loop indices + REAL(wp) :: z1_gstar, z1_astar, zhmean, zfac ! local scalar + REAL(wp), DIMENSION(jpij) :: zasum, z1_asum, zaksum ! sum of a_i+ato_i and reverse + REAL(wp), DIMENSION(jpij,jpl) :: zhi ! ice thickness + REAL(wp), DIMENSION(jpij,-1:jpl) :: zGsum ! zGsum(n) = sum of areas in categories 0 to n + !-------------------------------------------------------------------- + + z1_gstar = 1._wp / rn_gstar + z1_astar = 1._wp / rn_astar + + ! ! Ice thickness needed for rafting + WHERE( pa_i(ji1:ji2,:) > epsi10 ) ; zhi(ji1:ji2,:) = pv_i(ji1:ji2,:) / pa_i(ji1:ji2,:) + ELSEWHERE ; zhi(ji1:ji2,:) = 0._wp + END WHERE + + ! 1) Participation function (apartf): a(h) = b(h).g(h) + !----------------------------------------------------------------- + ! Compute the participation function = total area lost due to ridging/closing + ! This is analogous to + ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). + ! assuming b(h) = (2/Gstar) * (1 - G(h)/Gstar). + ! + ! apartf = integrating b(h)g(h) between the category boundaries + ! apartf is always >= 0 and SUM(apartf(0:jpl))=1 + !----------------------------------------------------------------- + ! + ! Compute total area of ice plus open water. + ! This is in general not equal to one because of divergence during transport + zasum(ji1:ji2) = pato_i(ji1:ji2) + SUM( pa_i(ji1:ji2,:), dim=2 ) + ! + WHERE( zasum(ji1:ji2) > epsi10 ) ; z1_asum(ji1:ji2) = 1._wp / zasum(ji1:ji2) + ELSEWHERE ; z1_asum(ji1:ji2) = 0._wp + END WHERE + ! + ! Compute cumulative thickness distribution function + ! Compute the cumulative thickness distribution function zGsum, + ! where zGsum(n) is the fractional area in categories 0 to n. + ! initial value (in h = 0) = open water area + zGsum(ji1:ji2,-1) = 0._wp + zGsum(ji1:ji2,0 ) = pato_i(ji1:ji2) * z1_asum(ji1:ji2) + DO jl = 1, jpl + zGsum(ji1:ji2,jl) = ( pato_i(ji1:ji2) + SUM( pa_i(ji1:ji2,1:jl), dim=2 ) ) * z1_asum(ji1:ji2) ! sum(1:jl) is ok (and not jpl) + END DO + ! + IF( ln_partf_lin ) THEN !--- Linear formulation (Thorndike et al., 1975) + DO jl = 0, jpl + DO ji = ji1, ji2 + IF ( zGsum(ji,jl) < rn_gstar ) THEN + apartf(ji,jl) = z1_gstar * ( zGsum(ji,jl) - zGsum(ji,jl-1) ) * & + & ( 2._wp - ( zGsum(ji,jl-1) + zGsum(ji,jl) ) * z1_gstar ) + ELSEIF( zGsum(ji,jl-1) < rn_gstar ) THEN + apartf(ji,jl) = z1_gstar * ( rn_gstar - zGsum(ji,jl-1) ) * & + & ( 2._wp - ( zGsum(ji,jl-1) + rn_gstar ) * z1_gstar ) + ELSE + apartf(ji,jl) = 0._wp + ENDIF + END DO + END DO + ! + ELSEIF( ln_partf_exp ) THEN !--- Exponential, more stable formulation (Lipscomb et al, 2007) + ! + zfac = 1._wp / ( 1._wp - EXP(-z1_astar) ) + DO jl = -1, jpl + DO ji = ji1, ji2 + zGsum(ji,jl) = EXP( -zGsum(ji,jl) * z1_astar ) * zfac + END DO + END DO + DO jl = 0, jpl + DO ji = ji1, ji2 + apartf(ji,jl) = zGsum(ji,jl-1) - zGsum(ji,jl) + END DO + END DO + ! + ENDIF + + ! !--- Ridging and rafting participation concentrations + IF( ln_rafting .AND. ln_ridging ) THEN !- ridging & rafting + DO jl = 1, jpl + DO ji = ji1, ji2 + aridge(ji,jl) = ( 1._wp + TANH ( rn_craft * ( zhi(ji,jl) - rn_hraft ) ) ) * 0.5_wp * apartf(ji,jl) + araft (ji,jl) = apartf(ji,jl) - aridge(ji,jl) + END DO + END DO + ELSEIF( ln_ridging .AND. .NOT. ln_rafting ) THEN !- ridging alone + DO jl = 1, jpl + DO ji = ji1, ji2 + aridge(ji,jl) = apartf(ji,jl) + araft (ji,jl) = 0._wp + END DO + END DO + ELSEIF( ln_rafting .AND. .NOT. ln_ridging ) THEN !- rafting alone + DO jl = 1, jpl + DO ji = ji1, ji2 + aridge(ji,jl) = 0._wp + araft (ji,jl) = apartf(ji,jl) + END DO + END DO + ELSE !- no ridging & no rafting + DO jl = 1, jpl + DO ji = ji1, ji2 + aridge(ji,jl) = 0._wp + araft (ji,jl) = 0._wp + END DO + END DO + ENDIF + + ! 2) Transfer function + !----------------------------------------------------------------- + ! Compute max and min ridged ice thickness for each ridging category. + ! Assume ridged ice is uniformly distributed between hrmin and hrmax. + ! + ! This parameterization is a modified version of Hibler (1980). + ! The mean ridging thickness, zhmean, is proportional to hi^(0.5) + ! and for very thick ridging ice must be >= hrdg_hi_min*hi + ! + ! The minimum ridging thickness, hrmin, is equal to 2*hi + ! (i.e., rafting) and for very thick ridging ice is + ! constrained by hrmin <= (zhmean + hi)/2. + ! + ! The maximum ridging thickness, hrmax, is determined by zhmean and hrmin. + ! + ! These modifications have the effect of reducing the ice strength + ! (relative to the Hibler formulation) when very thick ice is ridging. + ! + ! zaksum = net area removed/ total area removed + ! where total area removed = area of ice that ridges + ! net area removed = total area removed - area of new ridges + !----------------------------------------------------------------- + zfac = 1._wp / hi_hrft + zaksum(ji1:ji2) = apartf(ji1:ji2,0) + ! + DO jl = 1, jpl + DO ji = ji1, ji2 + IF ( apartf(ji,jl) > 0._wp ) THEN + zhmean = MAX( SQRT ( ABS( rn_hstar * zhi(ji,jl) ) ), zhi(ji,jl) * hrdg_hi_min ) + hrmin (ji,jl) = MIN( 2._wp * zhi(ji,jl), 0.5_wp * ( zhmean + zhi(ji,jl) ) ) + hrmax (ji,jl) = 2._wp * zhmean - hrmin(ji,jl) + hraft (ji,jl) = zhi(ji,jl) * zfac + hi_hrdg(ji,jl) = zhi(ji,jl) / MAX( zhmean, epsi20 ) + ! + ! Normalization factor : zaksum, ensures mass conservation + zaksum(ji) = zaksum(ji) + aridge(ji,jl) * ( 1._wp - hi_hrdg(ji,jl) ) & + & + araft (ji,jl) * ( 1._wp - hi_hrft ) + ELSE + hrmin (ji,jl) = 0._wp + hrmax (ji,jl) = 0._wp + hraft (ji,jl) = 0._wp + hi_hrdg(ji,jl) = 1._wp + ENDIF + END DO + END DO + ! + ! 3) closing_gross + !----------------- + ! Based on the ITD of ridging and ridged ice, convert the net closing rate to a gross closing rate. + ! NOTE: 0 < aksum <= 1 + WHERE( zaksum(ji1:ji2) > epsi10 ) ; closing_gross(ji1:ji2) = pclosing_net(ji1:ji2) / zaksum(ji1:ji2) + ELSEWHERE ; closing_gross(ji1:ji2) = 0._wp + END WHERE + + ! correction to closing rate if excessive ice removal + !---------------------------------------------------- + ! Reduce the closing rate if more than 100% of any ice category would be removed + ! Reduce the opening rate in proportion + DO jl = 1, jpl + DO ji = ji1, ji2 + zfac = apartf(ji,jl) * closing_gross(ji) * rdt_ice + IF( zfac > pa_i(ji,jl) .AND. apartf(ji,jl) /= 0._wp ) THEN + closing_gross(ji) = pa_i(ji,jl) / apartf(ji,jl) * r1_rdtice + ENDIF + END DO + END DO + + ! 4) correction to opening if excessive open water removal + !--------------------------------------------------------- + ! Reduce the closing rate if more than 100% of the open water would be removed + ! Reduce the opening rate in proportion + DO ji = ji1, ji2 + zfac = pato_i(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rdt_ice + IF( zfac < 0._wp ) THEN ! would lead to negative ato_i + opning(ji) = apartf(ji,0) * closing_gross(ji) - pato_i(ji) * r1_rdtice + ELSEIF( zfac > zasum(ji) ) THEN ! would lead to ato_i > asum + opning(ji) = apartf(ji,0) * closing_gross(ji) + ( zasum(ji) - pato_i(ji) ) * r1_rdtice + ENDIF + END DO + ! + END SUBROUTINE rdgrft_prep + + + SUBROUTINE rdgrft_shift( ji1, ji2, jpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE rdgrft_shift *** + !! + !! ** Purpose : shift ridging ice among thickness categories of ice thickness + !! + !! ** Method : Remove area, volume, and energy from each ridging category + !! and add to thicker ice categories. + !!------------------------------------------------------------------- + ! + INTEGER ,INTENT(in) :: ji1, ji2, jpti ! loop indices + INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices + REAL(wp) :: hL, hR, farea ! left and right limits of integration and new area going to jl2 + REAL(wp) :: vsw ! vol of water trapped into ridges + REAL(wp) :: afrdg, afrft ! fraction of category area ridged/rafted + REAL(wp) :: airdg1, oirdg1, aprdg1, virdg1, sirdg1 + REAL(wp) :: airft1, oirft1, aprft1 + REAL(wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg, vlrdg ! area etc of new ridges + REAL(wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft , sirft , vsrft, vprft, vlrft ! area etc of rafted ice + ! + REAL(wp), DIMENSION(jpij) :: ersw ! enth of water trapped into ridges + REAL(wp), DIMENSION(jpij) :: zswitch, fvol ! new ridge volume going to jl2 + REAL(wp), DIMENSION(jpij) :: z1_ai ! 1 / a + REAL(wp), DIMENSION(jpij) :: zvti ! sum(v_i) + ! + REAL(wp), DIMENSION(jpij,nlay_s) :: esrft ! snow energy of rafting ice + REAL(wp), DIMENSION(jpij,nlay_i) :: eirft ! ice energy of rafting ice + REAL(wp), DIMENSION(jpij,nlay_s) :: esrdg ! enth*volume of new ridges + REAL(wp), DIMENSION(jpij,nlay_i) :: eirdg ! enth*volume of new ridges + ! + INTEGER , DIMENSION(jpij) :: itest_rdg, itest_rft ! test for conservation + !!------------------------------------------------------------------- + ! + zvti(ji1:ji2) = SUM( v_i_2d(ji1:ji2,:), dim=2 ) ! total ice volume + ! + ! 1) Change in open water area due to closing and opening + !-------------------------------------------------------- + DO ji = ji1, ji2 + ato_i_1d(ji) = MAX( 0._wp, ato_i_1d(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rdt_ice ) + END DO + + ! 2) compute categories in which ice is removed (jl1) + !---------------------------------------------------- + DO jl1 = 1, jpl + + IF( nn_icesal /= 2 ) THEN + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), s_i_1d(ji1:ji2), s_i(:,:,jl1) ) + ENDIF + + DO ji = ji1, ji2 + + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN ! only if ice is ridging + + IF( a_i_2d(ji,jl1) > epsi10 ) THEN ; z1_ai(ji) = 1._wp / a_i_2d(ji,jl1) + ELSE ; z1_ai(ji) = 0._wp + ENDIF + + ! area of ridging / rafting ice (airdg1) and of new ridge (airdg2) + airdg1 = aridge(ji,jl1) * closing_gross(ji) * rdt_ice + airft1 = araft (ji,jl1) * closing_gross(ji) * rdt_ice + + airdg2(ji) = airdg1 * hi_hrdg(ji,jl1) + airft2(ji) = airft1 * hi_hrft + + ! ridging /rafting fractions + afrdg = airdg1 * z1_ai(ji) + afrft = airft1 * z1_ai(ji) + + ! volume and enthalpy (J/m2, >0) of seawater trapped into ridges + IF ( zvti(ji) <= 10. ) THEN ; vsw = v_i_2d(ji,jl1) * afrdg * rn_porordg ! v <= 10m then porosity = rn_porordg + ELSEIF( zvti(ji) >= 20. ) THEN ; vsw = 0._wp ! v >= 20m then porosity = 0 + ELSE ; vsw = v_i_2d(ji,jl1) * afrdg * rn_porordg * MAX( 0._wp, 2._wp - 0.1_wp * zvti(ji) ) ! v > 10m and v < 20m then porosity = linear transition to 0 + ENDIF + ersw(ji) = -rhoi * vsw * rcp * sst_1d(ji) ! clem: if sst>0, then ersw <0 (is that possible?) + + ! volume etc of ridging / rafting ice and new ridges (vi, vs, sm, oi, es, ei) + virdg1 = v_i_2d (ji,jl1) * afrdg + virdg2(ji) = v_i_2d (ji,jl1) * afrdg + vsw + vsrdg(ji) = v_s_2d (ji,jl1) * afrdg + sirdg1 = sv_i_2d(ji,jl1) * afrdg + sirdg2(ji) = sv_i_2d(ji,jl1) * afrdg + vsw * sss_1d(ji) + oirdg1 = oa_i_2d(ji,jl1) * afrdg + oirdg2(ji) = oa_i_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1) + + virft(ji) = v_i_2d (ji,jl1) * afrft + vsrft(ji) = v_s_2d (ji,jl1) * afrft + sirft(ji) = sv_i_2d(ji,jl1) * afrft + oirft1 = oa_i_2d(ji,jl1) * afrft + oirft2(ji) = oa_i_2d(ji,jl1) * afrft * hi_hrft + + IF ( ln_pnd_LEV ) THEN + aprdg1 = a_ip_2d(ji,jl1) * afrdg + aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1) + vprdg (ji) = v_ip_2d(ji,jl1) * afrdg + aprft1 = a_ip_2d(ji,jl1) * afrft + aprft2(ji) = a_ip_2d(ji,jl1) * afrft * hi_hrft + vprft (ji) = v_ip_2d(ji,jl1) * afrft + IF ( ln_pnd_lids ) THEN + vlrdg (ji) = v_il_2d(ji,jl1) * afrdg + vlrft (ji) = v_il_2d(ji,jl1) * afrft + ENDIF + ENDIF + + ! Ice-ocean exchanges associated with ice porosity + wfx_dyn_1d(ji) = wfx_dyn_1d(ji) - vsw * rhoi * r1_rdtice ! increase in ice volume due to seawater frozen in voids + sfx_dyn_1d(ji) = sfx_dyn_1d(ji) - vsw * sss_1d(ji) * rhoi * r1_rdtice + hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ersw(ji) * r1_rdtice ! > 0 [W.m-2] + + ! Put the snow lost by ridging into the ocean + ! Note that esrdg > 0; the ocean must cool to melt snow. If the ocean temp = Tf already, new ice must grow. + wfx_snw_dyn_1d(ji) = wfx_snw_dyn_1d(ji) + ( rhos * vsrdg(ji) * ( 1._wp - rn_fsnwrdg ) & ! fresh water source for ocean + & + rhos * vsrft(ji) * ( 1._wp - rn_fsnwrft ) ) * r1_rdtice + + ! virtual salt flux to keep salinity constant + IF( nn_icesal /= 2 ) THEN + sirdg2(ji) = sirdg2(ji) - vsw * ( sss_1d(ji) - s_i_1d(ji) ) ! ridge salinity = s_i + sfx_bri_1d(ji) = sfx_bri_1d(ji) + sss_1d(ji) * vsw * rhoi * r1_rdtice & ! put back sss_m into the ocean + & - s_i_1d(ji) * vsw * rhoi * r1_rdtice ! and get s_i from the ocean + ENDIF + + ! Remove area, volume of new ridge to each category jl1 + !------------------------------------------------------ + a_i_2d (ji,jl1) = a_i_2d (ji,jl1) - airdg1 - airft1 + v_i_2d (ji,jl1) = v_i_2d (ji,jl1) - virdg1 - virft(ji) + v_s_2d (ji,jl1) = v_s_2d (ji,jl1) - vsrdg(ji) - vsrft(ji) + sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1 - sirft(ji) + oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1 - oirft1 + IF ( ln_pnd_LEV ) THEN + a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1 - aprft1 + v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji) + IF ( ln_pnd_lids ) THEN + v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - vlrdg(ji) - vlrft(ji) + ENDIF + ENDIF + ENDIF + + END DO ! ji + + ! special loop for e_s because of layers jk + DO jk = 1, nlay_s + DO ji = ji1, ji2 + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN + ! Compute ridging /rafting fractions + afrdg = aridge(ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji) + afrft = araft (ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji) + ! Compute ridging /rafting ice and new ridges for es + esrdg(ji,jk) = ze_s_2d (ji,jk,jl1) * afrdg + esrft(ji,jk) = ze_s_2d (ji,jk,jl1) * afrft + ! Put the snow lost by ridging into the ocean + hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ( - esrdg(ji,jk) * ( 1._wp - rn_fsnwrdg ) & ! heat sink for ocean (<0, W.m-2) + & - esrft(ji,jk) * ( 1._wp - rn_fsnwrft ) ) * r1_rdtice + ! + ! Remove energy of new ridge to each category jl1 + !------------------------------------------------- + ze_s_2d(ji,jk,jl1) = ze_s_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft ) + ENDIF + END DO + END DO + + ! special loop for e_i because of layers jk + DO jk = 1, nlay_i + DO ji = ji1, ji2 + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN + ! Compute ridging /rafting fractions + afrdg = aridge(ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji) + afrft = araft (ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji) + ! Compute ridging ice and new ridges for ei + eirdg(ji,jk) = ze_i_2d (ji,jk,jl1) * afrdg + ersw(ji) * r1_nlay_i + eirft(ji,jk) = ze_i_2d (ji,jk,jl1) * afrft + ! + ! Remove energy of new ridge to each category jl1 + !------------------------------------------------- + ze_i_2d(ji,jk,jl1) = ze_i_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft ) + ENDIF + END DO + END DO + + ! 3) compute categories in which ice is added (jl2) + !-------------------------------------------------- + itest_rdg(ji1:ji2) = 0 + itest_rft(ji1:ji2) = 0 + DO jl2 = 1, jpl + ! + DO ji = ji1, ji2 + + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN + + ! Compute the fraction of ridged ice area and volume going to thickness category jl2 + IF( hrmin(ji,jl1) <= hi_max(jl2) .AND. hrmax(ji,jl1) > hi_max(jl2-1) ) THEN + hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) ) + hR = MIN( hrmax(ji,jl1), hi_max(jl2) ) + farea = ( hR - hL ) / ( hrmax(ji,jl1) - hrmin(ji,jl1) ) + fvol(ji) = ( hR * hR - hL * hL ) / ( hrmax(ji,jl1) * hrmax(ji,jl1) - hrmin(ji,jl1) * hrmin(ji,jl1) ) + ! + itest_rdg(ji) = 1 ! test for conservation + ELSE + farea = 0._wp + fvol(ji) = 0._wp + ENDIF + + ! Compute the fraction of rafted ice area and volume going to thickness category jl2 + IF( hraft(ji,jl1) <= hi_max(jl2) .AND. hraft(ji,jl1) > hi_max(jl2-1) ) THEN + zswitch(ji) = 1._wp + ! + itest_rft(ji) = 1 ! test for conservation + ELSE + zswitch(ji) = 0._wp + ENDIF + ! + ! Patch to ensure perfect conservation if ice thickness goes mad + ! Sometimes thickness is larger than hi_max(jpl) because of advection scheme (for very small areas) + ! Then ice volume is removed from one category but the ridging/rafting scheme + ! does not know where to move it, leading to a conservation issue. + IF( itest_rdg(ji) == 0 .AND. jl2 == jpl ) THEN ; farea = 1._wp ; fvol(ji) = 1._wp ; ENDIF + IF( itest_rft(ji) == 0 .AND. jl2 == jpl ) zswitch(ji) = 1._wp + ! + ! Add area, volume of new ridge to category jl2 + !---------------------------------------------- + a_i_2d (ji,jl2) = a_i_2d (ji,jl2) + ( airdg2(ji) * farea + airft2(ji) * zswitch(ji) ) + oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ( oirdg2(ji) * farea + oirft2(ji) * zswitch(ji) ) + v_i_2d (ji,jl2) = v_i_2d (ji,jl2) + ( virdg2(ji) * fvol(ji) + virft (ji) * zswitch(ji) ) + sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ( sirdg2(ji) * fvol(ji) + sirft (ji) * zswitch(ji) ) + v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji) + & + & vsrft (ji) * rn_fsnwrft * zswitch(ji) ) + IF ( ln_pnd_LEV ) THEN + v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + ( vprdg (ji) * rn_fpndrdg * fvol (ji) & + & + vprft (ji) * rn_fpndrft * zswitch(ji) ) + a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + ( aprdg2(ji) * rn_fpndrdg * farea & + & + aprft2(ji) * rn_fpndrft * zswitch(ji) ) + IF ( ln_pnd_lids ) THEN + v_il_2d (ji,jl2) = v_il_2d(ji,jl2) + ( vlrdg(ji) * rn_fpndrdg * fvol (ji) & + & + vlrft(ji) * rn_fpndrft * zswitch(ji) ) + ENDIF + ENDIF + + ENDIF + + END DO + ! Add snow energy of new ridge to category jl2 + !--------------------------------------------- + DO jk = 1, nlay_s + DO ji = ji1, ji2 + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) & + & ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ( esrdg(ji,jk) * rn_fsnwrdg * fvol(ji) + & + & esrft(ji,jk) * rn_fsnwrft * zswitch(ji) ) + END DO + END DO + ! Add ice energy of new ridge to category jl2 + !-------------------------------------------- + DO jk = 1, nlay_i + DO ji = ji1, ji2 + IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) & + & ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + eirdg(ji,jk) * fvol(ji) + eirft(ji,jk) * zswitch(ji) + END DO + END DO + ! + END DO ! jl2 + ! + END DO ! jl1 + ! + ! roundoff errors + !---------------- + ! In case ridging/rafting lead to very small negative values (sometimes it happens) + CALL ice_var_roundoff( ji1, ji2, a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) + ! + END SUBROUTINE rdgrft_shift + + + SUBROUTINE ice_strength + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_strength *** + !! + !! ** Purpose : computes ice strength used in dynamics routines of ice thickness + !! + !! ** Method : Compute the strength of the ice pack, defined as the energy (J m-2) + !! dissipated per unit area removed from the ice pack under compression, + !! and assumed proportional to the change in potential energy caused + !! by ridging. Note that only Hibler's formulation is stable and that + !! ice strength has to be smoothed + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: ismooth ! smoothing the resistance to deformation + INTEGER :: itframe ! number of time steps for the P smoothing + REAL(wp) :: zp, z1_3 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zworka ! temporary array used here + REAL(wp), DIMENSION(jpi,jpj) :: zstrp1, zstrp2 ! strength at previous time steps + !!---------------------------------------------------------------------- + ! !--------------------------------------------------! + IF( ln_timing_detail ) CALL timing_start('ice_strengh') ! timing + ! + IF( ln_str_H79 ) THEN ! Ice strength => Hibler (1979) method ! + ! !--------------------------------------------------! + strength(:,:) = rn_pstar * SUM( v_i(:,:,:), dim=3 ) * EXP( -rn_crhg * ( 1._wp - SUM( a_i(:,:,:), dim=3 ) ) ) + ismooth = 1 + ! !--------------------------------------------------! + ELSE ! Zero strength ! + ! !--------------------------------------------------! + strength(:,:) = 0._wp + ismooth = 0 + ENDIF + ! !--------------------------------------------------! + SELECT CASE( ismooth ) ! Smoothing ice strength ! + ! !--------------------------------------------------! + CASE( 1 ) !--- Spatial smoothing + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN + zworka(ji,jj) = ( 4.0 * strength(ji,jj) & + & + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) & + & + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & + & ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) + ELSE + zworka(ji,jj) = 0._wp + ENDIF + END DO + END DO + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + strength(ji,jj) = zworka(ji,jj) + END DO + END DO + CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) + ! + CASE( 2 ) !--- Temporal smoothing + IF ( kt_ice == nit000 ) THEN + zstrp1(:,:) = 0._wp + zstrp2(:,:) = 0._wp + ENDIF + ! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN + itframe = 1 ! number of time steps for the running mean + IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 + IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 + zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe + zstrp2 (ji,jj) = zstrp1 (ji,jj) + zstrp1 (ji,jj) = strength(ji,jj) + strength(ji,jj) = zp + ENDIF + END DO + END DO + CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) + ! + END SELECT + ! + IF( ln_timing_detail ) CALL timing_stop('ice_strengh') ! timing + ! + END SUBROUTINE ice_strength + + + SUBROUTINE ice_dyn_1d2d( kn, kj1, kj2, kpti ) + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_1d2d *** + !! + !! ** Purpose : move arrays from 1d to 2d and the reverse + !!----------------------------------------------------------------------- + INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D + INTEGER, INTENT(in) :: kj1, kj2, kpti + ! + INTEGER :: jl, jk ! dummy loop indices + !!----------------------------------------------------------------------- + ! + ! + SELECT CASE( kn ) + ! !---------------------! + CASE( 1 ) !== from 2D to 1D ==! + ! !---------------------! + ! fields used but not modified + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), sss_1d(kj1:kj2), CASTDP(sss_m(:,:) )) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), sst_1d(kj1:kj2), CASTDP(sst_m(:,:) )) + ! the following fields are modified in this routine + !!CALL tab_2d_1d( kpti, nptidx(kj1:kj2), ato_i_1d(kj1:kj2), ato_i(:,:) ) + !!CALL tab_3d_2d( kpti, nptidx(kj1:kj2), a_i_2d(kj1:kj2,1:jpl), a_i(:,:,:) ) + !!CALL tab_3d_2d( kpti, nptidx(kj1:kj2), v_i_2d (kj1:kj2,1:jpl), v_i (:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), v_s_2d (kj1:kj2,1:jpl), v_s (:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), sv_i_2d(kj1:kj2,1:jpl), sv_i(:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), oa_i_2d(kj1:kj2,1:jpl), oa_i(:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), a_ip_2d(kj1:kj2,1:jpl), a_ip(:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), v_ip_2d(kj1:kj2,1:jpl), v_ip(:,:,:) ) + CALL tab_3d_2d( kpti, nptidx(kj1:kj2), v_il_2d(kj1:kj2,1:jpl), v_il(:,:,:) ) + DO jl = 1, jpl + DO jk = 1, nlay_s + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), ze_s_2d(kj1:kj2,jk,jl), e_s(:,:,jk,jl) ) + END DO + DO jk = 1, nlay_i + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), ze_i_2d(kj1:kj2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), sfx_dyn_1d (kj1:kj2), sfx_dyn (:,:) ) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), sfx_bri_1d (kj1:kj2), sfx_bri (:,:) ) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), wfx_dyn_1d (kj1:kj2), wfx_dyn (:,:) ) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), hfx_dyn_1d (kj1:kj2), hfx_dyn (:,:) ) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), wfx_snw_dyn_1d(kj1:kj2), wfx_snw_dyn(:,:) ) + CALL tab_2d_1d( kpti, nptidx(kj1:kj2), wfx_pnd_1d (kj1:kj2), wfx_pnd (:,:) ) + ! + ! !---------------------! + CASE( 2 ) !== from 1D to 2D ==! + ! !---------------------! + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), ato_i_1d(kj1:kj2), ato_i(:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), a_i_2d (kj1:kj2,1:jpl), a_i (:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), v_i_2d (kj1:kj2,1:jpl), v_i (:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), v_s_2d (kj1:kj2,1:jpl), v_s (:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), sv_i_2d(kj1:kj2,1:jpl), sv_i(:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), oa_i_2d(kj1:kj2,1:jpl), oa_i(:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), a_ip_2d(kj1:kj2,1:jpl), a_ip(:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), v_ip_2d(kj1:kj2,1:jpl), v_ip(:,:,:) ) + CALL tab_2d_3d( kpti, nptidx(kj1:kj2), v_il_2d(kj1:kj2,1:jpl), v_il(:,:,:) ) + DO jl = 1, jpl + DO jk = 1, nlay_s + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), ze_s_2d(kj1:kj2,jk,jl), e_s(:,:,jk,jl) ) + END DO + DO jk = 1, nlay_i + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), ze_i_2d(kj1:kj2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), sfx_dyn_1d (kj1:kj2), sfx_dyn (:,:) ) + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), sfx_bri_1d (kj1:kj2), sfx_bri (:,:) ) + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), wfx_dyn_1d (kj1:kj2), wfx_dyn (:,:) ) + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), hfx_dyn_1d (kj1:kj2), hfx_dyn (:,:) ) + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), wfx_snw_dyn_1d(kj1:kj2), wfx_snw_dyn(:,:) ) + CALL tab_1d_2d( kpti, nptidx(kj1:kj2), wfx_pnd_1d (kj1:kj2), wfx_pnd (:,:) ) + ! + END SELECT + ! + END SUBROUTINE ice_dyn_1d2d + + + SUBROUTINE ice_dyn_rdgrft_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rdgrft_init *** + !! + !! ** Purpose : Physical constants and parameters linked + !! to the mechanical ice redistribution + !! + !! ** Method : Read the namdyn_rdgrft namelist + !! and check the parameters values + !! called at the first timestep (nit000) + !! + !! ** input : Namelist namdyn_rdgrft + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namdyn_rdgrft/ ln_str_H79, rn_pstar, rn_crhg, & + & rn_csrdg , & + & ln_partf_lin, rn_gstar, & + & ln_partf_exp, rn_astar, & + & ln_ridging, rn_hstar, rn_porordg, rn_fsnwrdg, rn_fpndrdg, & + & ln_rafting, rn_hraft, rn_craft , rn_fsnwrft, rn_fpndrft + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namicetdme in reference namelist : Ice mechanical ice redistribution + READ ( numnam_ice_ref, namdyn_rdgrft, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_rdgrft in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namdyn_rdgrft in configuration namelist : Ice mechanical ice redistribution + READ ( numnam_ice_cfg, namdyn_rdgrft, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_rdgrft in configuration namelist' ) + IF(lwm) WRITE ( numoni, namdyn_rdgrft ) + ! + IF (lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_dyn_rdgrft_init: ice parameters for ridging/rafting ' + WRITE(numout,*) '~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_rdgrft:' + WRITE(numout,*) ' ice strength parameterization Hibler (1979) ln_str_H79 = ', ln_str_H79 + WRITE(numout,*) ' 1st bulk-rheology parameter rn_pstar = ', rn_pstar + WRITE(numout,*) ' 2nd bulk-rhelogy parameter rn_crhg = ', rn_crhg + WRITE(numout,*) ' Fraction of shear energy contributing to ridging rn_csrdg = ', rn_csrdg + WRITE(numout,*) ' linear ridging participation function ln_partf_lin = ', ln_partf_lin + WRITE(numout,*) ' Fraction of ice coverage contributing to ridging rn_gstar = ', rn_gstar + WRITE(numout,*) ' Exponential ridging participation function ln_partf_exp = ', ln_partf_exp + WRITE(numout,*) ' Equivalent to G* for an exponential function rn_astar = ', rn_astar + WRITE(numout,*) ' Ridging of ice sheets or not ln_ridging = ', ln_ridging + WRITE(numout,*) ' max ridged ice thickness rn_hstar = ', rn_hstar + WRITE(numout,*) ' Initial porosity of ridges rn_porordg = ', rn_porordg + WRITE(numout,*) ' Fraction of snow volume conserved during ridging rn_fsnwrdg = ', rn_fsnwrdg + WRITE(numout,*) ' Fraction of pond volume conserved during ridging rn_fpndrdg = ', rn_fpndrdg + WRITE(numout,*) ' Rafting of ice sheets or not ln_rafting = ', ln_rafting + WRITE(numout,*) ' Parmeter thickness (threshold between ridge-raft) rn_hraft = ', rn_hraft + WRITE(numout,*) ' Rafting hyperbolic tangent coefficient rn_craft = ', rn_craft + WRITE(numout,*) ' Fraction of snow volume conserved during rafting rn_fsnwrft = ', rn_fsnwrft + WRITE(numout,*) ' Fraction of pond volume conserved during rafting rn_fpndrft = ', rn_fpndrft + ENDIF + ! + IF ( ( ln_partf_lin .AND. ln_partf_exp ) .OR. ( .NOT.ln_partf_lin .AND. .NOT.ln_partf_exp ) ) THEN + CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)' ) + ENDIF + ! + IF( .NOT. ln_icethd ) THEN + rn_porordg = 0._wp + rn_fsnwrdg = 1._wp ; rn_fsnwrft = 1._wp + rn_fpndrdg = 1._wp ; rn_fpndrft = 1._wp + IF( lwp ) THEN + WRITE(numout,*) ' ==> only ice dynamics is activated, thus some parameters must be changed' + WRITE(numout,*) ' rn_porordg = ', rn_porordg + WRITE(numout,*) ' rn_fsnwrdg = ', rn_fsnwrdg + WRITE(numout,*) ' rn_fpndrdg = ', rn_fpndrdg + WRITE(numout,*) ' rn_fsnwrft = ', rn_fsnwrft + WRITE(numout,*) ' rn_fpndrft = ', rn_fpndrft + ENDIF + ENDIF + ! ! allocate arrays + IF( ice_dyn_rdgrft_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'ice_dyn_rdgrft_init: unable to allocate arrays' ) + ! + END SUBROUTINE ice_dyn_rdgrft_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn_rdgrft diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.mod b/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.mod new file mode 100644 index 0000000000000000000000000000000000000000..e2f6bcd1e0a2e88e5630852ab7fd75cda441434b Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_rdgrft.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rhg.F90 b/V4.0/nemo_sources/src/ICE/icedyn_rhg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6f2141d487f55ebd0cc0528e0d12e74b98df701d --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_rhg.F90 @@ -0,0 +1,158 @@ +MODULE icedyn_rhg + !!====================================================================== + !! *** MODULE icedyn_rhg *** + !! Sea-Ice dynamics : master routine for rheology + !!====================================================================== + !! history : 4.0 ! 2018 (C. Rousset) Original code + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_rhg : computes ice velocities + !! ice_dyn_rhg_init : initialization and namelist read + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE ice ! sea-ice: variables + USE icedyn_rhg_evp ! sea-ice: EVP rheology + USE icectl ! sea-ice: control prints + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_rhg ! called by icestp.F90 + PUBLIC ice_dyn_rhg_init ! called by icestp.F90 + + INTEGER :: nice_rhg ! choice of the type of rheology + ! ! associated indices: + INTEGER, PARAMETER :: np_rhgEVP = 1 ! EVP rheology +!! INTEGER, PARAMETER :: np_rhgEAP = 2 ! EAP rheology + + ! ** namelist (namrhg) ** + LOGICAL :: ln_rhg_EVP ! EVP rheology + ! + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_rhg.F90 13346 2020-07-27 12:52:36Z clem $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn_rhg( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rhg *** + !! + !! ** Purpose : compute ice velocity + !! + !! ** Action : comupte - ice velocity (u_ice, v_ice) + !! - 3 components of the stress tensor (stress1_i, stress2_i, stress12_i) + !! - shear, divergence and delta (shear_i, divu_i, delta_i) + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ice time step + ! + INTEGER :: jl ! dummy loop indices + !!-------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('icedyn_rhg') ! timing + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icedyn_rhg', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (0, 'icedyn_rhg', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_dyn_rhg: sea-ice rheology' + WRITE(numout,*)'~~~~~~~~~~~' + ENDIF + ! + !--------------! + !== Rheology ==! + !--------------! + SELECT CASE( nice_rhg ) + ! !------------------------! + CASE( np_rhgEVP ) ! Elasto-Viscous-Plastic ! + ! !------------------------! + CALL ice_dyn_rhg_evp( kt, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i ) + ! + END SELECT + ! + IF( lrst_ice ) THEN !* write EVP fields in the restart file + IF( ln_rhg_EVP ) CALL rhg_evp_rst( 'WRITE', kt ) + ENDIF + ! + ! controls + IF( ln_ctl ) CALL ice_prt3D ('icedyn_rhg') ! prints + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icedyn_rhg', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + IF( ln_icediachk ) CALL ice_cons2D (1, 'icedyn_rhg', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + IF( ln_timing ) CALL timing_stop ('icedyn_rhg') ! timing + ! + END SUBROUTINE ice_dyn_rhg + + + SUBROUTINE ice_dyn_rhg_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_dyn_rhg_init *** + !! + !! ** Purpose : Physical constants and parameters linked to the ice + !! dynamics + !! + !! ** Method : Read the namdyn_rhg namelist and check the ice-dynamic + !! parameter values called at the first timestep (nit000) + !! + !! ** input : Namelist namdyn_rhg + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer output status for namelist read + !! + NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namdyn_rhg in reference namelist : Ice dynamics + READ ( numnam_ice_ref, namdyn_rhg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_rhg in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namdyn_rhg in configuration namelist : Ice dynamics + READ ( numnam_ice_cfg, namdyn_rhg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_rhg in configuration namelist' ) + IF(lwm) WRITE ( numoni, namdyn_rhg ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_dyn_rhg_init: ice parameters for ice dynamics ' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist : namdyn_rhg:' + WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP + WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP + WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl + WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc + WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp + WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast + WRITE(numout,*) ' check convergence of rheology nn_rhg_chkcvg = ', nn_rhg_chkcvg + IF ( nn_rhg_chkcvg == 0 ) THEN ; WRITE(numout,*) ' no check' + ELSEIF( nn_rhg_chkcvg == 1 ) THEN ; WRITE(numout,*) ' check cvg at the main time step' + ELSEIF( nn_rhg_chkcvg == 2 ) THEN ; WRITE(numout,*) ' check cvg at both main and rheology time steps' + ENDIF + ENDIF + ! + ! !== set the choice of ice advection ==! + ioptio = 0 + IF( ln_rhg_EVP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgEVP ; ENDIF +!! IF( ln_rhg_EAP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgEAP ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rhg_init: choose one and only one ice rheology' ) + ! + IF( ln_rhg_EVP ) CALL rhg_evp_rst( 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE ice_dyn_rhg_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icedyn_rhg \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rhg.mod b/V4.0/nemo_sources/src/ICE/icedyn_rhg.mod new file mode 100644 index 0000000000000000000000000000000000000000..1f9fe7979e2bb6a8652c90171dd84162f0ae8147 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_rhg.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.F90 b/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e3687662682ae8e581e1841224a78d7c4ed95c1 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.F90 @@ -0,0 +1,1205 @@ +MODULE icedyn_rhg_evp + !!====================================================================== + !! *** MODULE icedyn_rhg_evp *** + !! Sea-Ice dynamics : rheology Elasto-Viscous-Plastic + !!====================================================================== + !! History : - ! 2007-03 (M.A. Morales Maqueda, S. Bouillon) Original code + !! 3.0 ! 2008-03 (M. Vancoppenolle) adaptation to new model + !! - ! 2008-11 (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy + !! 3.3 ! 2009-05 (G.Garric) addition of the evp case + !! 3.4 ! 2011-01 (A. Porter) dynamical allocation + !! 3.5 ! 2012-08 (R. Benshila) AGRIF + !! 3.6 ! 2016-06 (C. Rousset) Rewriting + landfast ice + mEVP (Bouillon 2013) + !! 3.7 ! 2017 (C. Rousset) add aEVP (Kimmritz 2016-2017) + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_dyn_rhg_evp : computes ice velocities from EVP rheology + !! rhg_evp_rst : read/write EVP fields in ice restart + !!---------------------------------------------------------------------- + USE phycst ! Physical constant + USE dom_oce ! Ocean domain + USE sbc_oce , ONLY : ln_ice_embd, nn_fsbc, ssh_m + USE sbc_ice , ONLY : utau_ice, vtau_ice, snwice_mass, snwice_mass_b + USE ice ! sea-ice: ice variables + USE icevar ! ice_var_sshdyn + USE icedyn_rdgrft ! sea-ice: ice strength + USE bdy_oce , ONLY : ln_bdy + USE bdyice +#if defined key_agrif + USE agrif_ice_interp +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE prtctl ! Print control + USE nopenmp ! OpenMP library + + USE netcdf ! NetCDF library for convergence test + IMPLICIT NONE + PRIVATE + + PUBLIC ice_dyn_rhg_evp ! called by icedyn_rhg.F90 + PUBLIC rhg_evp_rst ! called by icedyn_rhg.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + + !! for convergence tests + INTEGER :: ncvgid ! netcdf file id + INTEGER :: nvarid ! netcdf variable id + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zmsk00, zmsk15 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zfmask ! mask at F points for the ice + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icedyn_rhg_evp.F90 13646 2020-10-20 15:33:01Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_dyn_rhg_evp( kt, pstress1_i, pstress2_i, pstress12_i, pshear_i, pdivu_i, pdelta_i ) + !!------------------------------------------------------------------- + !! *** SUBROUTINE ice_dyn_rhg_evp *** + !! EVP-C-grid + !! + !! ** purpose : determines sea ice drift from wind stress, ice-ocean + !! stress and sea-surface slope. Ice-ice interaction is described by + !! a non-linear elasto-viscous-plastic (EVP) law including shear + !! strength and a bulk rheology (Hunke and Dukowicz, 2002). + !! + !! The points in the C-grid look like this, dear reader + !! + !! (ji,jj) + !! | + !! | + !! (ji-1,jj) | (ji,jj) + !! --------- + !! | | + !! | (ji,jj) |------(ji,jj) + !! | | + !! --------- + !! (ji-1,jj-1) (ji,jj-1) + !! + !! ** Inputs : - wind forcing (stress), oceanic currents + !! ice total volume (vt_i) per unit area + !! snow total volume (vt_s) per unit area + !! + !! ** Action : - compute u_ice, v_ice : the components of the + !! sea-ice velocity vector + !! - compute delta_i, shear_i, divu_i, which are inputs + !! of the ice thickness distribution + !! + !! ** Steps : 0) compute mask at F point + !! 1) Compute ice snow mass, ice strength + !! 2) Compute wind, oceanic stresses, mass terms and + !! coriolis terms of the momentum equation + !! 3) Solve the momentum equation (iterative procedure) + !! 4) Recompute delta, shear and divergence + !! (which are inputs of the ITD) & store stress + !! for the next time step + !! 5) Diagnostics including charge ellipse + !! + !! ** Notes : There is the possibility to use aEVP from the nice work of Kimmritz et al. (2016 & 2017) + !! by setting up ln_aEVP=T (i.e. changing alpha and beta parameters). + !! This is an upgraded version of mEVP from Bouillon et al. 2013 + !! (i.e. more stable and better convergence) + !! + !! References : Hunke and Dukowicz, JPO97 + !! Bouillon et al., Ocean Modelling 2009 + !! Bouillon et al., Ocean Modelling 2013 + !! Kimmritz et al., Ocean Modelling 2016 & 2017 + !!------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + REAL(dp), DIMENSION(:,:), INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i ! + REAL(dp), DIMENSION(:,:), INTENT( out) :: pshear_i , pdivu_i , pdelta_i ! + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + INTEGER :: jter ! local integers + ! + REAL(wp) :: zrhoco ! rau0 * rn_cio + REAL(wp) :: zdtevp, z1_dtevp ! time step for subcycling + REAL(wp) :: ecc2, z1_ecc2 ! square of yield ellipse eccenticity + REAL(wp) :: zalph1, z1_alph1, zalph2, z1_alph2 ! alpha coef from Bouillon 2009 or Kimmritz 2017 + REAL(wp) :: zalph1o, z1_alph1o, zalph2o, z1_alph2o ! openmp private versions + REAl(wp) :: zbetau, zbetav + REAL(wp) :: zm1, zm2, zm3, zmassU, zmassV, zvU, zvV ! ice/snow mass and volume + REAL(wp) :: zp_delf, zds2, zdt, zdt2, zdiv, zdiv2 ! temporary scalars + REAL(wp) :: zTauO, zTauB, zRHS, zvel ! temporary scalars + REAL(wp) :: zkt ! isotropic tensile strength for landfast ice + REAL(wp) :: zvCr ! critical ice volume above which ice is landfast + ! + REAL(wp) :: zintb, zintn ! dummy argument + REAL(wp) :: zfac_x, zfac_y + REAL(wp) :: zshear, zdum1, zdum2 + ! + REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta and P/delta at T points + REAL(wp), DIMENSION(jpi,jpj) :: zten_i ! tension + REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017 + ! + REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points + REAL(wp), DIMENSION(jpi,jpj) :: zaU , zaV ! ice fraction on U/V points + REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points + REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points + REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points + ! + REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear + REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components + REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope: + ! ! ocean surface (ssh_m) if ice is not embedded + ! ! ice bottom surface if ice is embedded + REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses + REAL(wp), DIMENSION(jpi,jpj) :: zspgU, zspgV ! surface pressure gradient at U/V points + REAL(wp), DIMENSION(jpi,jpj) :: zCorU, zCorV ! Coriolis stress array + REAL(wp), DIMENSION(jpi,jpj) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points + REAL(wp), DIMENSION(jpi,jpj) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points + REAL(wp), DIMENSION(jpi,jpj) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast) + REAL(wp), DIMENSION(jpi,jpj) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast) + ! + REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays + REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence + + REAL(wp), PARAMETER :: zepsi = 1.0e-20_wp ! tolerance parameter + REAL(wp), PARAMETER :: zmmin = 1._wp ! ice mass (kg/m2) below which ice velocity becomes very small + REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small + !! --- check convergence + REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice + !! --- diags + REAL(wp) :: zsig1, zsig2, zsig12, zfac, z1_strength + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig_I, zsig_II, zsig1_p, zsig2_p + !! --- SIMIP diags + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_ymtrp_ice ! Y-component of ice mass transport (kg/s) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xmtrp_snw ! X-component of snow mass transport (kg/s) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_ymtrp_snw ! Y-component of snow mass transport (kg/s) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xatrp ! X-component of area transport (m2/s) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_yatrp ! Y-component of area transport (m2/s) + !!------------------------------------------------------------------- + + IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology' + + !$omp parallel default(shared) & + !$omp& private(ji,jj,jter,jj1,jj2,itid,ithreads,& + !$omp& zrhoco,zdtevp,z1_dtevp,ecc2,z1_ecc2,zalph1,z1_alph1,zalph2,z1_alph2,& + !$omp& zalph1o,z1_alph1o,zalph2o,z1_alph2o,zbetau,zbetav,& + !$omp& zm1,zm2,zm3,zmassU,zmassV,zvU,zvV,zp_delf,zds2,zdt,zdt2,zdiv,zdiv2,& + !$omp& zTauO,zTauB,zRHS,zvel,zkt,zvCr,zintb,zintn,zfac_x,zfac_y,& + !$omp& zshear,zdum1,zdum2,l_full_nf_update,rswitch,& + !$omp& zsig1,zsig2,zsig12,zfac,z1_strength) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! for diagnostics and convergence tests + !$omp master + ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) + !$omp end master + !$omp barrier + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice + zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less + END DO + END DO + ! + !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... + !------------------------------------------------------------------------------! + ! 0) mask at F points for the ice + !------------------------------------------------------------------------------! + ! ocean/land mask + IF ( kt == nit000 ) THEN + + !$omp barrier + !$omp master + + ALLOCATE( zfmask(jpi,jpj) ) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! NO vector opt. + zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) + END DO + END DO + CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) + + ! Lateral boundary conditions on velocity (modify zfmask) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( zfmask(ji,jj) == 0._wp ) THEN + zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & + & vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) + ENDIF + END DO + END DO + DO jj = 2, jpjm1 + IF( zfmask(1,jj) == 0._wp ) THEN + zfmask(1 ,jj) = rn_ishlat * MIN( 1._wp , MAX( vmask(2,jj,1), umask(1,jj+1,1), umask(1,jj,1) ) ) + ENDIF + IF( zfmask(jpi,jj) == 0._wp ) THEN + zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(jpi,jj+1,1), vmask(jpim1,jj,1), umask(jpi,jj-1,1) ) ) + ENDIF + END DO + DO ji = 2, jpim1 + IF( zfmask(ji,1) == 0._wp ) THEN + zfmask(ji, 1 ) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,1,1), umask(ji,2,1), vmask(ji,1,1) ) ) + ENDIF + IF( zfmask(ji,jpj) == 0._wp ) THEN + zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,1), vmask(ji-1,jpj,1), umask(ji,jpjm1,1) ) ) + ENDIF + END DO + CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) + + !$omp end master + !$omp barrier + + ENDIF + !------------------------------------------------------------------------------! + ! 1) define some variables and initialize arrays + !------------------------------------------------------------------------------! + zrhoco = rau0 * rn_cio + + ! ecc2: square of yield ellipse eccenticrity + ecc2 = rn_ecc * rn_ecc + z1_ecc2 = 1._wp / ecc2 + + ! alpha parameters (Bouillon 2009) + IF( .NOT. ln_aEVP ) THEN + zdtevp = rdt_ice / REAL( nn_nevp ) + zalph1 = 2._wp * rn_relast * REAL( nn_nevp ) + zalph2 = zalph1 * z1_ecc2 + + z1_alph1 = 1._wp / ( zalph1 + 1._wp ) + z1_alph2 = 1._wp / ( zalph2 + 1._wp ) + ELSE + zdtevp = rdt_ice + ! zalpha parameters set later on adaptatively + ENDIF + z1_dtevp = 1._wp / zdtevp + + ! Initialise stress tensor + zs1 (:,jj1:jj2) = pstress1_i (:,jj1:jj2) + zs2 (:,jj1:jj2) = pstress2_i (:,jj1:jj2) + zs12(:,jj1:jj2) = pstress12_i(:,jj1:jj2) + + ! Ice strength + !$omp barrier + !$omp master + CALL ice_strength + !$omp end master + !$omp barrier + + ! landfast param from Lemieux(2016): add isotropic tensile strength (following Konig Beatty and Holland, 2010) + IF( ln_landfast_L16 ) THEN ; zkt = rn_lf_tensile + ELSE ; zkt = 0._wp + ENDIF + ! + !------------------------------------------------------------------------------! + ! 2) Wind / ocean stress, mass terms, coriolis terms + !------------------------------------------------------------------------------! + ! sea surface height + ! embedded sea ice: compute representative ice top surface + ! non-embedded sea ice: use ocean surface for slope calculation + !$omp barrier + !$omp master + zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b) + !$omp end master + !$omp barrier + + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + + ! ice fraction at U-V points + zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) + zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) + + ! Ice/snow mass at U-V points + zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) ) + zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) ) + zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) ) + zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) + zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) + + ! Ocean currents at U-V points + v_oceU(ji,jj) = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) + u_oceV(ji,jj) = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) + + ! Coriolis at T points (m*f) + zmf(ji,jj) = zm1 * ff_t(ji,jj) + + ! dt/m at T points (for alpha and beta coefficients) + zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) + + ! m/dt + zmU_t(ji,jj) = zmassU * z1_dtevp + zmV_t(ji,jj) = zmassV * z1_dtevp + + ! Drag ice-atm. + ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) + ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) + + ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points + zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) + zspgV(ji,jj) = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) + + ! masks + zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice + zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice + + ! switches + IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; zmsk01x(ji,jj) = 0._wp + ELSE ; zmsk01x(ji,jj) = 1._wp ; ENDIF + IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN ; zmsk01y(ji,jj) = 0._wp + ELSE ; zmsk01y(ji,jj) = 1._wp ; ENDIF + + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + ! !== Landfast ice parameterization ==! + ! + IF( ln_landfast_L16 ) THEN !-- Lemieux 2016 + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! ice thickness at U-V points + zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) + zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) + ! ice-bottom stress at U points + zvCr = zaU(ji,jj) * rn_lf_depfra * hu_n(ji,jj) + ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) + ! ice-bottom stress at V points + zvCr = zaV(ji,jj) * rn_lf_depfra * hv_n(ji,jj) + ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) + ! ice_bottom stress at T points + zvCr = at_i(ji,jj) * rn_lf_depfra * ht_n(ji,jj) + tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + ELSE !-- no landfast + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ztaux_base(ji,jj) = 0._wp + ztauy_base(ji,jj) = 0._wp + END DO + END DO + !$omp barrier + ENDIF + + !------------------------------------------------------------------------------! + ! 3) Solution of the momentum equation, iterative procedure + !------------------------------------------------------------------------------! + ! + ! ! ==================== ! + DO jter = 1 , nn_nevp ! loop over jter ! + ! ! ==================== ! + l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1 + ! + ! + + ! convergence test + IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step + zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) + END DO + END DO + ENDIF + + ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! + DO jj = MAX(1,jj1), MIN(jj2,jpjm1) + DO ji = 1, jpim1 + + ! shear at F points + zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & + & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & + & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) + + END DO + END DO + !$omp barrier + + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = 2, jpim1 ! no vector loop + + ! shear**2 at T points (doc eq. A16) + zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & + & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & + & ) * 0.25_wp * r1_e1e2t(ji,jj) + + ! divergence at T points + zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & + & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & + & ) * r1_e1e2t(ji,jj) + zdiv2 = zdiv * zdiv + + ! tension at T points + zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & + & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & + & ) * r1_e1e2t(ji,jj) + zdt2 = zdt * zdt + + ! delta at T points + zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) + + END DO + END DO + + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', zdelta, 'T', 1._wp ) + !$omp end master + !$omp barrier + + ! P/delta at T points + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zp_delt(ji,jj) = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl ) + END DO + END DO + !$omp barrier + + DO jj = MAX(2,jj1), MIN(jj2,jpj) ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 + DO ji = 2, jpi ! no vector loop + + ! divergence at T points (duplication to avoid communications) + zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & + & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & + & ) * r1_e1e2t(ji,jj) + + ! tension at T points (duplication to avoid communications) + zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & + & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & + & ) * r1_e1e2t(ji,jj) + + ! alpha for aEVP + ! gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m + ! alpha = beta = sqrt(4*gamma) + IF( ln_aEVP ) THEN + zalph1o = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) + z1_alph1o = 1._wp / ( zalph1o + 1._wp ) + zalph2o = zalph1o + z1_alph2o = z1_alph1o + ! explicit: + ! z1_alph1o = 1._wp / zalph1o + ! z1_alph2o = 1._wp / zalph1o + ! zalph1o = zalph1o - 1._wp + ! zalph2o = zalph1o + ELSE + zalph1o = zalph1 + zalph2o = zalph2 + z1_alph1o = z1_alph1 + z1_alph2o = z1_alph2 + ENDIF + + ! stress at T points (zkt/=0 if landfast) + zs1(ji,jj) = ( zs1(ji,jj)*zalph1o + zp_delt(ji,jj) * ( zdiv*(1._wp + zkt) - zdelta(ji,jj)*(1._wp - zkt) ) ) * z1_alph1o + zs2(ji,jj) = ( zs2(ji,jj)*zalph2o + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2o + + END DO + END DO + !$omp barrier + + ! Save beta at T-points for further computations + IF( ln_aEVP ) THEN + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) + END DO + END DO + ENDIF + !$omp barrier + + DO jj = MAX(1,jj1), MIN(jj2,jpjm1) + DO ji = 1, jpim1 + + ! alpha for aEVP + IF( ln_aEVP ) THEN + zalph2o = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) + z1_alph2o = 1._wp / ( zalph2o + 1._wp ) + ! explicit: + ! z1_alph2o = 1._wp / zalph2o + ! zalph2o = zalph2o - 1._wp + ELSE + zalph2o = zalph2 + z1_alph2o = z1_alph2 + ENDIF + + ! P/delta at F points + zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) + + ! stress at F points (zkt/=0 if landfast) + zs12(ji,jj)= ( zs12(ji,jj) * zalph2o + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2o + + END DO + END DO + !$omp barrier + + ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! !--- U points + zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) & + & + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) & + & ) * r1_e2u(ji,jj) & + & + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1) & + & ) * 2._wp * r1_e1u(ji,jj) & + & ) * r1_e1e2u(ji,jj) + ! + ! !--- V points + zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj) & + & - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj) & + & ) * r1_e1v(ji,jj) & + & + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj) & + & ) * 2._wp * r1_e2v(ji,jj) & + & ) * r1_e1e2v(ji,jj) + ! + ! !--- ice currents at U-V point + v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) + u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) + ! + END DO + END DO + !$omp barrier + ! + ! --- Computation of ice velocity --- ! + ! Bouillon et al. 2013 (eq 47-48) => unstable unless alpha, beta vary as in Kimmritz 2016 & 2017 + ! Bouillon et al. 2009 (eq 34-35) => stable + IF( MOD(jter,2) == 0 ) THEN ! even iterations + ! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! !--- tau_io/(v_oce - v_ice) + zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & + & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) + ! !--- Ocean-to-Ice stress + ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) + ! + ! !--- tau_bottom/v_ice + zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) + zTauB = ztauy_base(ji,jj) / zvel + ! !--- OceanBottom-to-Ice stress + ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) + ! + ! !--- Coriolis at V-points (energy conserving formulation) + zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & + & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & + & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) + ! + ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io + zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) + ! + ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) + ! 1 = sliding friction : TauB < RHS + rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) + ! + IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) + zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) + v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity + & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & + & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) / ( zbetav + 1._wp ) & + & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00y(ji,jj) + ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) + v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity + & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00y(ji,jj) + ENDIF + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) + ! +#if defined key_agrif +!! CALL agrif_interp_ice( 'V', jter, nn_nevp ) + CALL agrif_interp_ice( 'V' ) +#endif + IF( ln_bdy ) CALL bdy_ice_dyn( 'V' ) + !$omp end master + !$omp barrier + !! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! !--- tau_io/(u_oce - u_ice) + zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & + & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) + ! !--- Ocean-to-Ice stress + ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) + ! + ! !--- tau_bottom/u_ice + zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) + zTauB = ztaux_base(ji,jj) / zvel + ! !--- OceanBottom-to-Ice stress + ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) + ! + ! !--- Coriolis at U-points (energy conserving formulation) + zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & + & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & + & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) + ! + ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io + zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) + ! + ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) + ! 1 = sliding friction : TauB < RHS + rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) + ! + IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) + zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) + u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity + & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & + & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) / ( zbetau + 1._wp ) & + & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00x(ji,jj) + ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) + u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity + & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00x(ji,jj) + ENDIF + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) + ! +#if defined key_agrif +!! CALL agrif_interp_ice( 'U', jter, nn_nevp ) + CALL agrif_interp_ice( 'U' ) +#endif + IF( ln_bdy ) CALL bdy_ice_dyn( 'U' ) + !$omp end master + !$omp barrier + ! + ELSE ! odd iterations + ! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! !--- tau_io/(u_oce - u_ice) + zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & + & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) + ! !--- Ocean-to-Ice stress + ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) + ! + ! !--- tau_bottom/u_ice + zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) + zTauB = ztaux_base(ji,jj) / zvel + ! !--- OceanBottom-to-Ice stress + ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) + ! + ! !--- Coriolis at U-points (energy conserving formulation) + zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & + & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & + & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) + ! + ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io + zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) + ! + ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) + ! 1 = sliding friction : TauB < RHS + rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) + ! + IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) + zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) + u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity + & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & + & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) / ( zbetau + 1._wp ) & + & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00x(ji,jj) + ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) + u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity + & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00x(ji,jj) + ENDIF + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) + ! +#if defined key_agrif +!! CALL agrif_interp_ice( 'U', jter, nn_nevp ) + CALL agrif_interp_ice( 'U' ) +#endif + IF( ln_bdy ) CALL bdy_ice_dyn( 'U' ) + !$omp end master + !$omp barrier + !! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + ! !--- tau_io/(v_oce - v_ice) + zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & + & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) + ! !--- Ocean-to-Ice stress + ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) + ! + ! !--- tau_bottom/v_ice + zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) + zTauB = ztauy_base(ji,jj) / zvel + ! !--- OceanBottom-to-Ice stress + ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) + ! + ! !--- Coriolis at v-points (energy conserving formulation) + zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & + & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & + & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) + ! + ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io + zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) + ! + ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) + ! 1 = sliding friction : TauB < RHS + rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) + ! + IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) + zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) + v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity + & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & + & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) / ( zbetav + 1._wp ) & + & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00y(ji,jj) + ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) + v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity + & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) + & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast + & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 + & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin + & ) * zmsk00y(ji,jj) + ENDIF + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) + ! +#if defined key_agrif +!! CALL agrif_interp_ice( 'V', jter, nn_nevp ) + CALL agrif_interp_ice( 'V' ) +#endif + IF( ln_bdy ) CALL bdy_ice_dyn( 'V' ) + !$omp end master + !$omp barrier + ! + ENDIF + + ! convergence test + IF( nn_rhg_chkcvg == 2 ) THEN + !$omp barrier + !$omp master + CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) + !$omp end master + !$omp barrier + ENDIF + ! + ! ! ==================== ! + END DO ! end loop over jter ! + ! ! ==================== ! + IF( ln_aEVP ) THEN + !$omp barrier + !$omp master + CALL iom_put( 'beta_evp' , zbeta ) + !$omp end master + !$omp barrier + ENDIF + ! + !------------------------------------------------------------------------------! + ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) + !------------------------------------------------------------------------------! + DO jj = MAX(1,jj1), MIN(jj2,jpjm1) + DO ji = 1, jpim1 + + ! shear at F points + zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & + & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & + & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) + + END DO + END DO + !$omp barrier + + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = 2, jpim1 ! no vector loop + + ! tension**2 at T points + zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & + & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & + & ) * r1_e1e2t(ji,jj) + zdt2 = zdt * zdt + + zten_i(ji,jj) = zdt + + ! shear**2 at T points (doc eq. A16) + zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & + & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & + & ) * 0.25_wp * r1_e1e2t(ji,jj) + + ! shear at T points + pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) + + ! divergence at T points + pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & + & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & + & ) * r1_e1e2t(ji,jj) + + ! delta at T points + zfac = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta + rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0 + pdelta_i(ji,jj) = zfac + rn_creepl * rswitch ! delta+creepl + + END DO + END DO + + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp ) + CALL lbc_lnk_multi( 'icedyn_rhg_evp', zten_i, 'T', 1.0_wp, zs1 , 'T', 1.0_wp, zs2 , 'T', 1.0_wp, zs12 , 'F', 1.0_wp ) + !$omp end master + !$omp barrier + + ! --- Store the stress tensor for the next time step --- ! + pstress1_i (:,jj1:jj2) = zs1 (:,jj1:jj2) + pstress2_i (:,jj1:jj2) = zs2 (:,jj1:jj2) + pstress12_i(:,jj1:jj2) = zs12(:,jj1:jj2) + ! + + !$omp end parallel + !------------------------------------------------------------------------------! + ! 5) diagnostics + !------------------------------------------------------------------------------! + ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- ! + IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. & + & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN + ! + CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & + & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) + ! + CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) + CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 ) + CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 ) + CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 ) + CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 ) + CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 ) + ENDIF + + ! --- divergence, shear and strength --- ! + IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence + IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear + IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength + + ! --- Stress tensor invariants (SIMIP diags) --- ! + IF( iom_use('normstr') .OR. iom_use('sheastr') ) THEN + ! + ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) + ! + !$omp parallel do default(shared) & + !$omp& private(ji,jj,zfac,zsig1,zsig2,zsig12) + DO jj = 1, jpj + DO ji = 1, jpi + + ! Ice stresses + ! sigma1, sigma2, sigma12 are some useful recombination of the stresses (Hunke and Dukowicz MWR 2002, Bouillon et al., OM2013) + ! These are NOT stress tensor components, neither stress invariants, neither stress principal components + ! I know, this can be confusing... + zfac = strength(ji,jj) / ( pdelta_i(ji,jj) + rn_creepl ) + zsig1 = zfac * ( pdivu_i(ji,jj) - pdelta_i(ji,jj) ) + zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) + zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) + + ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008) + zsig_I (ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure + zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress + + END DO + END DO + !$omp end parallel do + ! + ! Stress tensor invariants (normal and shear stress N/m) - SIMIP diags - definitions following Coon (1974) and Feltham (2008) + IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress + IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress + + DEALLOCATE ( zsig_I, zsig_II ) + + ENDIF + + ! --- Normalized stress tensor principal components --- ! + ! This are used to plot the normalized yield curve, see Lemieux & Dupont, 2020 + ! Recommendation 1 : we use ice strength, not replacement pressure + ! Recommendation 2 : need to use deformations at PREVIOUS iterate for viscosities +!!$ IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN +!!$ ! +!!$ ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) +!!$ ! +!!$ DO jj = 1, jpj +!!$ DO ji = 1, jpi +!!$ +!!$ ! Ice stresses computed with **viscosities** (delta, p/delta) at **previous** iterates +!!$ ! and **deformations** at current iterates +!!$ ! following Lemieux & Dupont (2020) +!!$ zfac = zp_delt(ji,jj) +!!$ zsig1 = zfac * ( pdivu_i(ji,jj) - ( zdelta(ji,jj) + rn_creepl ) ) +!!$ zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) +!!$ zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) +!!$ +!!$ ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008), T-point +!!$ zsig_I(ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure +!!$ zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress +!!$ +!!$ ! Normalized principal stresses (used to display the ellipse) +!!$ z1_strength = 1._wp / MAX( 1._wp, strength(ji,jj) ) +!!$ zsig1_p(ji,jj) = ( zsig_I(ji,jj) + zsig_II(ji,jj) ) * z1_strength +!!$ zsig2_p(ji,jj) = ( zsig_I(ji,jj) - zsig_II(ji,jj) ) * z1_strength +!!$ END DO +!!$ END DO +!!$ ! +!!$ CALL iom_put( 'sig1_pnorm' , zsig1_p ) +!!$ CALL iom_put( 'sig2_pnorm' , zsig2_p ) +!!$ +!!$ DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II ) +!!$ +!!$ ENDIF + + ! --- SIMIP --- ! + IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & + & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN + ! + CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & + & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) + + CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) + CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y) + CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x) + CALL iom_put( 'corstry' , zCorV * zmsk00 ) ! Coriolis force term in force balance (y) + CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x) + CALL iom_put( 'intstry' , zfV * zmsk00 ) ! Internal force term in force balance (y) + ENDIF + + IF( iom_use('xmtrpice') .OR. iom_use('ymtrpice') .OR. & + & iom_use('xmtrpsnw') .OR. iom_use('ymtrpsnw') .OR. iom_use('xatrp') .OR. iom_use('yatrp') ) THEN + ! + ALLOCATE( zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , & + & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) + ! + !$omp parallel do default(shared) & + !$omp& private(ji,jj,zfac_x,zfac_y) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! 2D ice mass, snow mass, area transport arrays (X, Y) + zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) + zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) + + zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component + zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) ! '' Y- '' + + zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component + zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) ! '' Y- '' + + zdiag_xatrp(ji,jj) = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) ) ! area transport, X-component + zdiag_yatrp(ji,jj) = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) ) ! '' Y- '' + + END DO + END DO + !$omp end parallel do + + CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & + & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & + & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) + + CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) + CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport + CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s) + CALL iom_put( 'ymtrpsnw' , zdiag_ymtrp_snw ) ! Y-component of snow mass transport + CALL iom_put( 'xatrp' , zdiag_xatrp ) ! X-component of ice area transport + CALL iom_put( 'yatrp' , zdiag_yatrp ) ! Y-component of ice area transport + + DEALLOCATE( zdiag_xmtrp_ice , zdiag_ymtrp_ice , & + & zdiag_xmtrp_snw , zdiag_ymtrp_snw , zdiag_xatrp , zdiag_yatrp ) + + ENDIF + ! + ! --- convergence tests --- ! + IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN + IF( iom_use('uice_cvg') ) THEN + IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) + CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & + & ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) + ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) + CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & + & ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) + ENDIF + ENDIF + ENDIF + ! + DEALLOCATE( zmsk00, zmsk15 ) + ! + END SUBROUTINE ice_dyn_rhg_evp + + + SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rhg_cvg *** + !! + !! ** Purpose : check convergence of oce rheology + !! + !! ** Method : create a file ice_cvg.nc containing the convergence of ice velocity + !! during the sub timestepping of rheology so as: + !! uice_cvg = MAX( u(t+1) - u(t) , v(t+1) - v(t) ) + !! This routine is called every sub-iteration, so it is cpu expensive + !! + !! ** Note : for the first sub-iteration, uice_cvg is set to 0 (too large otherwise) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index + REAL(wp), DIMENSION(:,:), INTENT(in) :: pu, pv, pub, pvb ! now and before velocities + !! + INTEGER :: it, idtime, istatus + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zresm ! local real + CHARACTER(len=20) :: clname + REAL(wp), DIMENSION(jpi,jpj) :: zres ! check convergence + !!---------------------------------------------------------------------- + + ! create file + IF( kt == nit000 .AND. kiter == 1 ) THEN + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'rhg_cvg : ice rheology convergence control' + WRITE(numout,*) '~~~~~~~' + ENDIF + ! + IF( lwm ) THEN + clname = 'ice_cvg.nc' + IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, ncvgid ) + istatus = NF90_DEF_DIM( ncvgid, 'time' , NF90_UNLIMITED, idtime ) + istatus = NF90_DEF_VAR( ncvgid, 'uice_cvg', NF90_DOUBLE , (/ idtime /), nvarid ) + istatus = NF90_ENDDEF(ncvgid) + ENDIF + ! + ENDIF + + ! time + it = ( kt - 1 ) * kitermax + kiter + + ! convergence + IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large) + zresm = 0._wp + ELSE + DO jj = 1, jpj + DO ji = 1, jpi + zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & + & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) + END DO + END DO + zresm = MAXVAL( zres ) + CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain + ENDIF + + IF( lwm ) THEN + ! write variables + istatus = NF90_PUT_VAR( ncvgid, nvarid, (/zresm/), (/it/), (/1/) ) + ! close file + IF( kt == nitend - nn_fsbc + 1 ) istatus = NF90_CLOSE(ncvgid) + ENDIF + + END SUBROUTINE rhg_cvg + + + SUBROUTINE rhg_evp_rst( cdrw, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rhg_evp_rst *** + !! + !! ** Purpose : Read or write RHG file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in) :: cdrw ! "READ"/"WRITE" flag + INTEGER, OPTIONAL, INTENT(in) :: kt ! ice time-step + ! + INTEGER :: iter ! local integer + INTEGER :: id1, id2, id3 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialize + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + ! + id1 = iom_varid( numrir, 'stress1_i' , ldstop = .FALSE. ) + id2 = iom_varid( numrir, 'stress2_i' , ldstop = .FALSE. ) + id3 = iom_varid( numrir, 'stress12_i', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2, id3 ) > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'stress1_i' , stress1_i ) + CALL iom_get( numrir, jpdom_autoglo, 'stress2_i' , stress2_i ) + CALL iom_get( numrir, jpdom_autoglo, 'stress12_i', stress12_i ) + ELSE ! start rheology from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> previous run without rheology, set stresses to 0' + stress1_i (:,:) = 0._wp + stress2_i (:,:) = 0._wp + stress12_i(:,:) = 0._wp + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set stresses to 0' + stress1_i (:,:) = 0._wp + stress2_i (:,:) = 0._wp + stress12_i(:,:) = 0._wp + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- rhg-rst ----' + iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 + ! + CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i ) + CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i ) + CALL iom_rstput( iter, nitrst, numriw, 'stress12_i', stress12_i ) + ! + ENDIF + ! + END SUBROUTINE rhg_evp_rst + + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!============================================================================== +END MODULE icedyn_rhg_evp diff --git a/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.mod b/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.mod new file mode 100644 index 0000000000000000000000000000000000000000..fa8d57a22910c98096acff871566648b0b3e5070 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icedyn_rhg_evp.mod differ diff --git a/V4.0/nemo_sources/src/ICE/iceistate.F90 b/V4.0/nemo_sources/src/ICE/iceistate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2ddaadcf266fe31cc0262fb8ed56789d8b849f41 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/iceistate.F90 @@ -0,0 +1,570 @@ +MODULE iceistate + !!====================================================================== + !! *** MODULE iceistate *** + !! sea-ice : Initialization of ice variables + !!====================================================================== + !! History : 2.0 ! 2004-01 (C. Ethe, G. Madec) Original code + !! 3.0 ! 2007 (M. Vancoppenolle) Rewrite for ice cats + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_istate : initialization of diagnostics ice variables + !! ice_istate_init : initialization of ice state and namelist read + !!---------------------------------------------------------------------- + USE phycst ! physical constant + USE oce ! dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd + USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b + USE eosbn2 ! equation of state + USE domvvl ! Variable volume + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE icetab ! sea-ice: 1D <==> 2D transformation + USE icevar ! sea-ice: operations + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE fldread ! read input fields + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_istate ! called by icestp.F90 + PUBLIC ice_istate_init ! called by icestp.F90 + ! + ! !! ** namelist (namini) ** + LOGICAL, PUBLIC :: ln_iceini !: Ice initialization or not + INTEGER, PUBLIC :: nn_iceinicor !: Workaround for problematic SI3 initial conditions + LOGICAL, PUBLIC :: ln_iceageign = .FALSE. !: Ignore ice age from restart + INTEGER, PUBLIC :: nn_iceini_file !: Ice initialization: + ! 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 + REAL(wp) :: rn_thres_sst + REAL(wp) :: rn_hti_ini_n, rn_hts_ini_n, rn_ati_ini_n, rn_smi_ini_n, rn_tmi_ini_n, rn_tsu_ini_n, rn_tms_ini_n + REAL(wp) :: rn_hti_ini_s, rn_hts_ini_s, rn_ati_ini_s, rn_smi_ini_s, rn_tmi_ini_s, rn_tsu_ini_s, rn_tms_ini_s + REAL(wp) :: rn_apd_ini_n, rn_hpd_ini_n, rn_hld_ini_n + REAL(wp) :: rn_apd_ini_s, rn_hpd_ini_s, rn_hld_ini_s + ! + ! ! if nn_iceini_file = 1 + INTEGER , PARAMETER :: jpfldi = 10 ! maximum number of files to read + INTEGER , PARAMETER :: jp_hti = 1 ! index of ice thickness (m) + INTEGER , PARAMETER :: jp_hts = 2 ! index of snw thickness (m) + INTEGER , PARAMETER :: jp_ati = 3 ! index of ice fraction (-) + INTEGER , PARAMETER :: jp_smi = 4 ! index of ice salinity (g/kg) + INTEGER , PARAMETER :: jp_tmi = 5 ! index of ice temperature (K) + INTEGER , PARAMETER :: jp_tsu = 6 ! index of ice surface temp (K) + INTEGER , PARAMETER :: jp_tms = 7 ! index of snw temperature (K) + INTEGER , PARAMETER :: jp_apd = 8 ! index of pnd fraction (-) + INTEGER , PARAMETER :: jp_hpd = 9 ! index of pnd depth (m) + INTEGER , PARAMETER :: jp_hld = 10 ! index of pnd lid depth (m) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: si ! structure of input fields (file informations, fields read) + ! + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: iceistate.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +CONTAINS + + SUBROUTINE ice_istate( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_istate *** + !! + !! ** Purpose : defined the sea-ice initial state + !! + !! ** Method : This routine will put some ice where ocean + !! is at the freezing point, then fill in ice + !! state variables using prescribed initial + !! values in the namelist + !! + !! ** Steps : 1) Set initial surface and basal temperatures + !! 2) Recompute or read sea ice state variables + !! 3) Fill in space-dependent arrays for state variables + !! 4) snow-ice mass computation + !! + !! ** Notes : o_i, t_su, t_s, t_i, sz_i must be filled everywhere, even + !! where there is no ice + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + !! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: ztmelts + INTEGER , DIMENSION(4) :: itest + REAL(wp), DIMENSION(jpi,jpj) :: z2d + REAL(wp), DIMENSION(jpi,jpj) :: zswitch ! ice indicator + REAL(wp), DIMENSION(jpi,jpj) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file + REAL(wp), DIMENSION(jpi,jpj) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file + REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file + REAL(dp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d !temporary arrays + !! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d + !-------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_istate: sea-ice initialization ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + + !--------------------------- + ! 1) 1st init. of the fields + !--------------------------- + ! + ! basal temperature (considered at freezing point) [Kelvin] + CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) + t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + ! + ! surface temperature and conductivity + DO jl = 1, jpl + t_su (:,:,jl) = rt0 * tmask(:,:,1) ! temp at the surface + cnd_ice(:,:,jl) = 0._wp ! initialisation of the effective conductivity at the top of ice/snow (ln_cndflx=T) + END DO + ! + ! ice and snw temperatures + DO jl = 1, jpl + DO jk = 1, nlay_i + t_i(:,:,jk,jl) = rt0 * tmask(:,:,1) + END DO + DO jk = 1, nlay_s + t_s(:,:,jk,jl) = rt0 * tmask(:,:,1) + END DO + END DO + ! + ! specific temperatures for coupled runs + tn_ice (:,:,:) = t_i (:,:,1,:) + t1_ice (:,:,:) = t_i (:,:,1,:) + + ! heat contents + e_i (:,:,:,:) = 0._wp + e_s (:,:,:,:) = 0._wp + + ! general fields + a_i (:,:,:) = 0._wp + v_i (:,:,:) = 0._wp + v_s (:,:,:) = 0._wp + sv_i(:,:,:) = 0._wp + oa_i(:,:,:) = 0._wp + ! + h_i (:,:,:) = 0._wp + h_s (:,:,:) = 0._wp + s_i (:,:,:) = 0._wp + o_i (:,:,:) = 0._wp + ! + ! melt ponds + a_ip (:,:,:) = 0._wp + v_ip (:,:,:) = 0._wp + v_il (:,:,:) = 0._wp + a_ip_eff (:,:,:) = 0._wp + h_ip (:,:,:) = 0._wp + h_il (:,:,:) = 0._wp + ! + ! ice velocities + u_ice (:,:) = 0._wp + v_ice (:,:) = 0._wp + ! + !------------------------------------------------------------------------ + ! 2) overwrite some of the fields with namelist parameters or netcdf file + !------------------------------------------------------------------------ + IF( ln_iceini ) THEN + ! !---------------! + IF( nn_iceini_file == 1 )THEN ! Read a file ! + ! !---------------! + WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp + ELSEWHERE ; zswitch(:,:) = 0._wp + END WHERE + ! + CALL fld_read( kt, 1, si ) ! input fields provided at the current time-step + ! + ! -- mandatory fields -- ! + zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1) * tmask(:,:,1) + zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1) * tmask(:,:,1) + zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1) * tmask(:,:,1) + + ! -- optional fields -- ! + ! if fields do not exist then set them to the values present in the namelist (except for temperatures) + ! + ! ice salinity + IF( TRIM(si(jp_smi)%clrootname) == 'NOT USED' ) & + & si(jp_smi)%fnow(:,:,1) = ( rn_smi_ini_n * zswitch + rn_smi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + ! + ! temperatures + IF ( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. & + & TRIM(si(jp_tms)%clrootname) == 'NOT USED' ) THEN + si(jp_tmi)%fnow(:,:,1) = ( rn_tmi_ini_n * zswitch + rn_tmi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zswitch + rn_tsu_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zswitch + rn_tms_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + ENDIF + IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 + & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 ) + IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 + & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 ) + IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_su, set T_su = T_s + & si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1) + IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_su, set T_su = T_i + & si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) + IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_s, set T_s = T_su + & si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1) + IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_s, set T_s = T_i + & si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) + ! + ! pond concentration + IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) & + & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. + & * si(jp_ati)%fnow(:,:,1) + ! + ! pond depth + IF( TRIM(si(jp_hpd)%clrootname) == 'NOT USED' ) & + & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zswitch + rn_hpd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + ! + ! pond lid depth + IF( TRIM(si(jp_hld)%clrootname) == 'NOT USED' ) & + & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zswitch + rn_hld_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + ! + zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * tmask(:,:,1) + ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1) * tmask(:,:,1) + zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1) * tmask(:,:,1) + ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1) * tmask(:,:,1) + zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * tmask(:,:,1) + zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * tmask(:,:,1) + zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * tmask(:,:,1) + ! + ! change the switch for the following + WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) + ELSEWHERE ; zswitch(:,:) = 0._wp + END WHERE + ! !---------------! + ELSE ! Read namelist ! + ! !---------------! + ! no ice if (sst - Tfreez) >= thresold + WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp + ELSEWHERE ; zswitch(:,:) = tmask(:,:,1) + END WHERE + ! + ! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array + WHERE( ff_t(:,:) >= 0._wp ) + zht_i_ini(:,:) = rn_hti_ini_n * zswitch(:,:) + zht_s_ini(:,:) = rn_hts_ini_n * zswitch(:,:) + zat_i_ini(:,:) = rn_ati_ini_n * zswitch(:,:) + zsm_i_ini(:,:) = rn_smi_ini_n * zswitch(:,:) + ztm_i_ini(:,:) = rn_tmi_ini_n * zswitch(:,:) + zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:) + ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:) + zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. + zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) + zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:) + ELSEWHERE + zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:) + zht_s_ini(:,:) = rn_hts_ini_s * zswitch(:,:) + zat_i_ini(:,:) = rn_ati_ini_s * zswitch(:,:) + zsm_i_ini(:,:) = rn_smi_ini_s * zswitch(:,:) + ztm_i_ini(:,:) = rn_tmi_ini_s * zswitch(:,:) + zt_su_ini(:,:) = rn_tsu_ini_s * zswitch(:,:) + ztm_s_ini(:,:) = rn_tms_ini_s * zswitch(:,:) + zapnd_ini(:,:) = rn_apd_ini_s * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. + zhpnd_ini(:,:) = rn_hpd_ini_s * zswitch(:,:) + zhlid_ini(:,:) = rn_hld_ini_s * zswitch(:,:) + END WHERE + ! + ENDIF + + ! make sure ponds = 0 if no ponds scheme + IF ( .NOT.ln_pnd ) THEN + zapnd_ini(:,:) = 0._wp + zhpnd_ini(:,:) = 0._wp + zhlid_ini(:,:) = 0._wp + ENDIF + + IF ( .NOT.ln_pnd_lids ) THEN + zhlid_ini(:,:) = 0._wp + ENDIF + + !----------------! + ! 3) fill fields ! + !----------------! + ! select ice covered grid points + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( zht_i_ini(ji,jj) > 0._wp ) THEN + npti = npti + 1 + nptidx(npti) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + + ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj) + CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti) , CASTDP(zht_i_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti) , CASTDP(zht_s_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , CASTDP(zat_i_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,1), CASTDP(ztm_i_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d (1:npti,1), CASTDP(ztm_s_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti) , CASTDP(zt_su_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti) , CASTDP(zsm_i_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti) , CASTDP(zapnd_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti) , CASTDP(zhpnd_ini) ) + CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d(1:npti) , CASTDP(zhlid_ini) ) + + ! allocate temporary arrays + ALLOCATE( zhi_2d (npti,jpl), zhs_2d (npti,jpl), zai_2d (npti,jpl), & + & zti_2d (npti,jpl), zts_2d (npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), & + & zaip_2d(npti,jpl), zhip_2d(npti,jpl), zhil_2d(npti,jpl) ) + + ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl) + CALL ice_var_itd( CASTSP(h_i_1d(1:npti)) , CASTSP(h_s_1d(1:npti)) , CASTSP(at_i_1d(1:npti)), & + & zhi_2d , zhs_2d , zai_2d , & + & CASTSP(t_i_1d(1:npti,1)), CASTSP(t_s_1d(1:npti,1)), CASTSP(t_su_1d(1:npti)), & + & CASTSP(s_i_1d(1:npti)) , CASTSP(a_ip_1d(1:npti)) , CASTSP(h_ip_1d(1:npti)), CASTSP(h_il_1d(1:npti)), & + & zti_2d , zts_2d , ztsu_2d , & + & zsi_2d , zaip_2d , zhip_2d , zhil_2d ) + + ! move to 3D arrays: (jpi*jpj,jpl) -> (jpi,jpj,jpl) + DO jl = 1, jpl + zti_3d(:,:,jl) = rt0 * tmask(:,:,1) + zts_3d(:,:,jl) = rt0 * tmask(:,:,1) + END DO + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zhi_2d) , h_i ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zhs_2d) , h_s ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zai_2d) , a_i ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zti_2d) , zti_3d ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zts_2d) , zts_3d ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(ztsu_2d) , t_su ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zsi_2d) , s_i ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zaip_2d) , a_ip ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zhip_2d) , h_ip ) + CALL tab_2d_3d( npti, nptidx(1:npti), CASTDP(zhil_2d) , h_il ) + + ! deallocate temporary arrays + DEALLOCATE( zhi_2d, zhs_2d, zai_2d , & + & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d ) + + ! calculate extensive and intensive variables + CALL ice_var_salprof ! for sz_i + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) + v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) + sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) + END DO + END DO + END DO + ! + DO jl = 1, jpl + DO jk = 1, nlay_s + DO jj = 1, jpj + DO ji = 1, jpi + t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) + e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & + & rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) + END DO + END DO + END DO + END DO + ! + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) + ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K + e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & + & rhoi * ( rcpi * ( ztmelts - t_i(ji,jj,jk,jl) ) + & + & rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & + & - rcp * ( ztmelts - rt0 ) ) + END DO + END DO + END DO + END DO + + ! Melt ponds + WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) + ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp + END WHERE + v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) + v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) + + ! specific temperatures for coupled runs + tn_ice(:,:,:) = t_su(:,:,:) + t1_ice(:,:,:) = t_i (:,:,1,:) + ! + ! ice concentration should not exceed amax + at_i(:,:) = SUM( a_i, dim=3 ) + DO jl = 1, jpl + WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) + END DO + at_i(:,:) = SUM( a_i, dim=3 ) + ! + ENDIF ! ln_iceini + ! + !---------------------------------------------- + ! 4) Snow-ice mass (case ice is fully embedded) + !---------------------------------------------- + snwice_mass (:,:) = tmask(:,:,1) * SUM( rhos * v_s + rhoi * v_i + rhow * ( v_ip + v_il ), dim=3 ) ! snow+ice mass + snwice_mass_b(:,:) = snwice_mass(:,:) + ! + 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 + ! + IF( .NOT.ln_linssh ) THEN + ! + WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + sshn(:,:)*tmask(:,:,1) / ht_0(:,:) + ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE + ! + DO jk = 1,jpkm1 ! adjust initial vertical scale factors + e3t_n(:,:,jk) = e3t_0(:,:,jk) * z2d(:,:) + e3t_b(:,:,jk) = e3t_n(:,:,jk) + e3t_a(:,:,jk) = e3t_n(:,:,jk) + END DO + ! + ! 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 + ! ---------------------- + !!gm not sure of that.... + 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 + +!!clem: output of initial state should be written here but it is impossible because +!! the ocean and ice are in the same file +!! CALL dia_wri_state( 'output.init' ) + ! + END SUBROUTINE ice_istate + + + SUBROUTINE ice_istate_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_istate_init *** + !! + !! ** Purpose : Definition of initial state of the ice + !! + !! ** Method : Read the namini namelist and check the parameter + !! values called at the first timestep (nit000) + !! + !! ** input : Namelist namini + !! + !!----------------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ifpr, ierror + ! + CHARACTER(len=256) :: cn_dir ! Root directory for location of ice files + TYPE(FLD_N) :: sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd, sn_hld + TYPE(FLD_N), DIMENSION(jpfldi) :: slf_i ! array of namelist informations on the fields to read + ! + NAMELIST/namini/ ln_iceini, nn_iceinicor, nn_iceini_file, rn_thres_sst, & + & rn_hti_ini_n, rn_hti_ini_s, rn_hts_ini_n, rn_hts_ini_s, & + & rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, & + & rn_tmi_ini_n, rn_tmi_ini_s, rn_tsu_ini_n, rn_tsu_ini_s, rn_tms_ini_n, rn_tms_ini_s, & + & rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, rn_hld_ini_n, rn_hld_ini_s, & + & sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, sn_hld, cn_dir, & + & ln_iceageign + + !!----------------------------------------------------------------------------- + ! + nn_iceinicor = 0 + REWIND( numnam_ice_ref ) ! Namelist namini in reference namelist : Ice initial state + READ ( numnam_ice_ref, namini, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namini in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namini in configuration namelist : Ice initial state + READ ( numnam_ice_cfg, namini, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namini in configuration namelist' ) + IF(lwm) WRITE ( numoni, namini ) + ! + slf_i(jp_hti) = sn_hti ; slf_i(jp_hts) = sn_hts + slf_i(jp_ati) = sn_ati ; slf_i(jp_smi) = sn_smi + slf_i(jp_tmi) = sn_tmi ; slf_i(jp_tsu) = sn_tsu ; slf_i(jp_tms) = sn_tms + slf_i(jp_apd) = sn_apd ; slf_i(jp_hpd) = sn_hpd ; slf_i(jp_hld) = sn_hld + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_istate_init: ice parameters inititialisation ' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namini:' + WRITE(numout,*) ' ice initialization (T) or not (F) ln_iceini = ', ln_iceini + WRITE(numout,*) ' ice initialization call to ice_cor in icestp nn_iceinicor = ', nn_iceinicor + WRITE(numout,*) ' ignore ice age from restart file ln_iceageign = ', ln_iceageign + + WRITE(numout,*) ' ice initialization from a netcdf file nn_iceini_file = ', nn_iceini_file + WRITE(numout,*) ' max ocean temp. above Tfreeze with initial ice rn_thres_sst = ', rn_thres_sst + IF( ln_iceini .AND. nn_iceini_file == 0 ) THEN + WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s + WRITE(numout,*) ' initial ice thickness in the north-south rn_hti_ini = ', rn_hti_ini_n,rn_hti_ini_s + WRITE(numout,*) ' initial ice concentr in the north-south rn_ati_ini = ', rn_ati_ini_n,rn_ati_ini_s + WRITE(numout,*) ' initial ice salinity in the north-south rn_smi_ini = ', rn_smi_ini_n,rn_smi_ini_s + WRITE(numout,*) ' initial surf temperat in the north-south rn_tsu_ini = ', rn_tsu_ini_n,rn_tsu_ini_s + WRITE(numout,*) ' initial ice temperat in the north-south rn_tmi_ini = ', rn_tmi_ini_n,rn_tmi_ini_s + WRITE(numout,*) ' initial snw temperat in the north-south rn_tms_ini = ', rn_tms_ini_n,rn_tms_ini_s + WRITE(numout,*) ' initial pnd fraction in the north-south rn_apd_ini = ', rn_apd_ini_n,rn_apd_ini_s + WRITE(numout,*) ' initial pnd depth in the north-south rn_hpd_ini = ', rn_hpd_ini_n,rn_hpd_ini_s + WRITE(numout,*) ' initial pnd lid depth in the north-south rn_hld_ini = ', rn_hld_ini_n,rn_hld_ini_s + ENDIF + ENDIF + ! + IF( nn_iceini_file == 1 ) THEN ! Ice initialization using input file + ! + ! set si structure + ALLOCATE( si(jpfldi), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'ice_istate_ini in iceistate: unable to allocate si structure' ) ; RETURN + ENDIF + ! + DO ifpr = 1, jpfldi + ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) ) + IF( slf_i(ifpr)%ln_tint ) ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + ! + ! fill si with slf_i and control print + CALL fld_fill( si, slf_i, cn_dir, 'ice_istate_ini', 'initialization of sea ice fields', 'numnam_ice' ) + ! + ENDIF + ! + IF( .NOT.ln_pnd ) THEN + rn_apd_ini_n = 0. ; rn_apd_ini_s = 0. + rn_hpd_ini_n = 0. ; rn_hpd_ini_s = 0. + rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. + CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 & rn_hld_ini = 0 when no ponds' ) + ENDIF + ! + IF( .NOT.ln_pnd_lids ) THEN + rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. + ENDIF + ! + END SUBROUTINE ice_istate_init + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE iceistate \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/iceistate.mod b/V4.0/nemo_sources/src/ICE/iceistate.mod new file mode 100644 index 0000000000000000000000000000000000000000..47c2a43eb462869bdea920066f68b269d643464a Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/iceistate.mod differ diff --git a/V4.0/nemo_sources/src/ICE/iceitd.F90 b/V4.0/nemo_sources/src/ICE/iceitd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..72eafa31141848be307d749f4417f943da1364a0 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/iceitd.F90 @@ -0,0 +1,814 @@ +MODULE iceitd + !!====================================================================== + !! *** MODULE iceitd *** + !! sea-ice : ice thickness distribution + !!====================================================================== + !! History : 3.0 ! 2005-12 (M. Vancoppenolle) original code (based on CICE) + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_itd_rem : redistribute ice thicknesses after thermo growth and melt + !! itd_glinear : build g(h) satisfying area and volume constraints + !! itd_shiftice : shift ice across category boundaries, conserving everything + !! ice_itd_reb : rebin ice thicknesses into bounded categories + !! ice_itd_init : read ice thicknesses mean and min from namelist + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE phycst ! physical constants + USE ice1D ! sea-ice: thermodynamic variables + USE ice ! sea-ice: variables + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: conservation tests + USE icetab ! sea-ice: convert 1D<=>2D + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE prtctl ! Print control + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_itd_init ! called in icestp + PUBLIC ice_itd_rem ! called in icethd + PUBLIC ice_itd_reb ! called in icecor + + INTEGER :: nice_catbnd ! choice of the type of ice category function + ! ! associated indices: + INTEGER, PARAMETER :: np_cathfn = 1 ! categories defined by a function + INTEGER, PARAMETER :: np_catusr = 2 ! categories defined by the user + ! + ! !! ** namelist (namitd) ** + LOGICAL :: ln_cat_hfn ! ice categories are defined by function like rn_himean**(-0.05) + REAL(wp) :: rn_himean ! mean thickness of the domain + LOGICAL :: ln_cat_usr ! ice categories are defined by rn_catbnd + REAL(wp), DIMENSION(0:100) :: rn_catbnd ! ice categories bounds + REAL(wp) :: rn_himax ! maximum ice thickness allowed + ! + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: iceitd.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +CONTAINS + + SUBROUTINE ice_itd_rem( kt ) + !!------------------------------------------------------------------ + !! *** ROUTINE ice_itd_rem *** + !! + !! ** Purpose : computes the redistribution of ice thickness + !! after thermodynamic growth of ice thickness + !! + !! ** Method : Linear remapping + !! + !! References : W.H. Lipscomb, JGR 2001 + !!------------------------------------------------------------------ + INTEGER , INTENT (in) :: kt ! Ocean time step + ! + INTEGER :: ji, jj, jl, jcat ! dummy loop index + INTEGER :: ipti ! local integer + INTEGER :: ji1, ji2, jpti ! OpenMP loop index + INTEGER :: itid, ithreads ! OpenMP variables + REAL(wp) :: zwk1, zdh0, zetamin, zdamax! local scalars + REAL(dp) :: zx1! local scalars + REAL(wp) :: zwk2, zda0, zetamax! - - + REAL(dp) :: zx2! - - + REAL(wp) :: zx3 + REAL(wp) :: zslope ! used to compute local thermodynamic "speeds" + ! + INTEGER , DIMENSION(jpij) :: iptidx ! compute remapping or not + INTEGER , DIMENSION(jpij,jpl-1) :: jdonor ! donor category index + REAL(wp), DIMENSION(jpij,jpl) :: zdhice ! ice thickness increment + REAL(wp), DIMENSION(jpij,jpl) :: g0! coefficients for fitting the line of the ITD + REAL(dp), DIMENSION(jpij,jpl) :: g1! coefficients for fitting the line of the ITD + REAL(wp), DIMENSION(jpij,jpl) :: hL, hR ! left and right boundary for the ITD for each thickness + REAL(wp), DIMENSION(jpij,jpl-1) :: zdvice! local increment of ice area and volume + REAL(dp), DIMENSION(jpij,jpl-1) :: zdaice! local increment of ice area and volume + REAL(wp), DIMENSION(jpij) :: zhb0, zhb1 ! category boundaries for thinnes categories + REAL(wp), DIMENSION(jpij,0:jpl) :: zhbnew ! new boundaries of ice categories + !!------------------------------------------------------------------ + IF( ln_timing ) CALL timing_start('iceitd_rem') + + IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_itd_rem: remapping ice thickness distribution' + + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + IF( ln_icediachk ) CALL ice_cons2D (0, 'iceitd_rem', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + + !----------------------------------------------------------------------------------------------- + ! 1) Identify grid cells with ice + !----------------------------------------------------------------------------------------------- + at_i(:,:) = SUM( a_i, dim=3 ) + ! + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( at_i(ji,jj) > epsi10 ) THEN + npti = npti + 1 + nptidx( npti ) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + ! + !$omp parallel private(ji,ji1,ji2,jpti,itid,ithreads,jcat, & + !$omp& zx1,zwk1,zdh0,zetamin, zdamax,zx2,zwk2,zda0,zetamax,zx3,zslope) + ! + ! Split npti loops for openmp parallelism + CALL nompinfo( itid, ithreads ) + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + ! + !----------------------------------------------------------------------------------------------- + ! 2) Compute new category boundaries + !----------------------------------------------------------------------------------------------- + IF( npti > 0 ) THEN + ! + zdhice(ji1:ji2,:) = 0._wp + zhbnew(ji1:ji2,:) = 0._wp + ! + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), h_i_2d (ji1:ji2,1:jpl), h_i ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), h_ib_2d(ji1:ji2,1:jpl), CASTDP(h_i_b) ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), a_i_2d (ji1:ji2,1:jpl), a_i ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), a_ib_2d(ji1:ji2,1:jpl), CASTDP(a_i_b) ) + ! + DO jl = 1, jpl + ! Compute thickness change in each ice category + DO ji = ji1, ji2 + IF( a_i_2d(ji,jl) > epsi10 ) zdhice(ji,jl) = h_i_2d(ji,jl) - h_ib_2d(ji,jl) + END DO + END DO + ! + ! --- New boundaries for category 1:jpl-1 --- ! + DO jl = 1, jpl - 1 + ! + DO ji = ji1, ji2 + ! + ! --- New boundary: Hn* = Hn + Fn*dt --- ! + ! Fn*dt = ( fn + (fn+1 - fn)/(hn+1 - hn) * (Hn - hn) ) * dt = zdhice + zslope * (Hmax - h_i_b) + ! + IF ( a_ib_2d(ji,jl) > epsi10 .AND. a_ib_2d(ji,jl+1) > epsi10 ) THEN ! a(jl+1) & a(jl) /= 0 + zslope = ( zdhice(ji,jl+1) - zdhice(ji,jl) ) / ( h_ib_2d(ji,jl+1) - h_ib_2d(ji,jl) ) + zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl) + zslope * ( hi_max(jl) - h_ib_2d(ji,jl) ) + ELSEIF( a_ib_2d(ji,jl) > epsi10 .AND. a_ib_2d(ji,jl+1) <= epsi10 ) THEN ! a(jl+1)=0 => Hn* = Hn + fn*dt + zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl) + ELSEIF( a_ib_2d(ji,jl) <= epsi10 .AND. a_ib_2d(ji,jl+1) > epsi10 ) THEN ! a(jl)=0 => Hn* = Hn + fn+1*dt + zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl+1) + ELSE ! a(jl+1) & a(jl) = 0 + zhbnew(ji,jl) = hi_max(jl) + ENDIF + ! + ! --- 2 conditions for remapping --- ! + ! 1) hn(t+1)+espi < Hn* < hn+1(t+1)-epsi + ! Note: hn(t+1) must not be too close to either HR or HL otherwise a division by nearly 0 is possible + ! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) + IF( a_i_2d(ji,jl ) > epsi10 .AND. h_i_2d(ji,jl ) > ( zhbnew(ji,jl) - epsi06 ) ) nptidx(ji) = 0 + IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi06 ) ) nptidx(ji) = 0 + ! + ! 2) Hn-1 < Hn* < Hn+1 + IF( zhbnew(ji,jl) < hi_max(jl-1) ) nptidx(ji) = 0 + IF( zhbnew(ji,jl) > hi_max(jl+1) ) nptidx(ji) = 0 + ! + END DO + END DO + ! + ! --- New boundaries for category jpl --- ! + DO ji = ji1, ji2 + IF( a_i_2d(ji,jpl) > epsi10 ) THEN + zhbnew(ji,jpl) = MAX( hi_max(jpl-1), 3._wp * h_i_2d(ji,jpl) - 2._wp * zhbnew(ji,jpl-1) ) + ELSE + zhbnew(ji,jpl) = hi_max(jpl) + ENDIF + ! + ! --- 1 additional condition for remapping (1st category) --- ! + ! H0+epsi < h1(t) < H1-epsi + ! h1(t) must not be too close to either HR or HL otherwise a division by nearly 0 is possible + ! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) + IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi06 ) ) nptidx(ji) = 0 + IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi06 ) ) nptidx(ji) = 0 + END DO + + ! + !----------------------------------------------------------------------------------------------- + ! 3) Identify cells where remapping + !----------------------------------------------------------------------------------------------- + !$omp barrier + !$omp master + ipti = 0 ; iptidx(:) = 0 + DO ji = 1, npti + IF( nptidx(ji) /= 0 ) THEN + ipti = ipti + 1 + iptidx(ipti) = nptidx(ji) + zhbnew(ipti,:) = zhbnew(ji,:) ! adjust zhbnew to new indices + ENDIF + END DO + nptidx(:) = iptidx(:) + npti = ipti + !$omp end master + !$omp barrier + ! + ENDIF + ! + ! Split npti loops for openmp parallelism + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + ! + !----------------------------------------------------------------------------------------------- + ! 4) Compute g(h) + !----------------------------------------------------------------------------------------------- + IF( npti > 0 ) THEN + ! + zhb0(ji1:ji2) = hi_max(0) ; zhb1(ji1:ji2) = hi_max(1) + g0(ji1:ji2,:) = 0._wp ; g1(ji1:ji2,:) = 0._wp + hL(ji1:ji2,:) = 0._wp ; hR(ji1:ji2,:) = 0._wp + ! + DO jl = 1, jpl + ! + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), h_ib_1d(ji1:ji2), CASTDP(h_i_b(:,:,jl)) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), h_i_1d (ji1:ji2), h_i (:,:,jl) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), a_i_1d (ji1:ji2), a_i (:,:,jl) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), v_i_1d (ji1:ji2), v_i (:,:,jl) ) + ! + IF( jl == 1 ) THEN + ! + ! --- g(h) for category 1 --- ! + CALL itd_glinear( jpti, zhb0(ji1:ji2) , zhb1(ji1:ji2) , h_ib_1d(ji1:ji2) , a_i_1d(ji1:ji2) , & ! in + & g0 (ji1:ji2,1), g1 (ji1:ji2,1), hL (ji1:ji2,1), hR (ji1:ji2,1) ) ! out + ! + ! Area lost due to melting of thin ice + DO ji = ji1, ji2 + ! + IF( a_i_1d(ji) > epsi10 ) THEN + ! + zdh0 = h_i_1d(ji) - h_ib_1d(ji) + IF( zdh0 < 0.0 ) THEN ! remove area from category 1 + zdh0 = MIN( -zdh0, hi_max(1) ) + !Integrate g(1) from 0 to dh0 to estimate area melted + zetamax = MIN( zdh0, hR(ji,1) ) - hL(ji,1) + ! + IF( zetamax > 0.0 ) THEN + zx1 = zetamax + zx2 = 0.5 * zetamax * zetamax + zda0 = g1(ji,1) * zx2 + g0(ji,1) * zx1 ! ice area removed + zdamax = a_i_1d(ji) * (1.0 - h_i_1d(ji) / h_ib_1d(ji) ) ! Constrain new thickness <= h_i + zda0 = MIN( zda0, zdamax ) ! ice area lost due to melting of thin ice (zdamax > 0) + ! Remove area, conserving volume + h_i_1d(ji) = h_i_1d(ji) * a_i_1d(ji) / ( a_i_1d(ji) - zda0 ) + a_i_1d(ji) = a_i_1d(ji) - zda0 + v_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) ! useless ? + ENDIF + ! + ELSE ! if ice accretion zdh0 > 0 + ! zhbnew was 0, and is shifted to the right to account for thin ice growth in openwater (F0 = f1) + zhbnew(ji,0) = MIN( zdh0, hi_max(1) ) + ENDIF + ! + ENDIF + ! + END DO + ! + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), h_i_1d(ji1:ji2), h_i(:,:,jl) ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), a_i_1d(ji1:ji2), a_i(:,:,jl) ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), v_i_1d(ji1:ji2), v_i(:,:,jl) ) + ! + ENDIF ! jl=1 + ! + ! --- g(h) for each thickness category --- ! + CALL itd_glinear( jpti, zhbnew(ji1:ji2,jl-1), zhbnew(ji1:ji2,jl), h_i_1d(ji1:ji2) , a_i_1d(ji1:ji2) , & ! in + & g0 (ji1:ji2,jl ), g1 (ji1:ji2,jl), hL (ji1:ji2,jl), hR (ji1:ji2,jl) ) ! out + ! + END DO + + !----------------------------------------------------------------------------------------------- + ! 5) Compute area and volume to be shifted across each boundary (Eq. 18) + !----------------------------------------------------------------------------------------------- + DO jl = 1, jpl - 1 + ! + DO ji = ji1, ji2 + ! + ! left and right integration limits in eta space + IF (zhbnew(ji,jl) > hi_max(jl)) THEN ! Hn* > Hn => transfer from jl to jl+1 + zetamin = MAX( hi_max(jl) , hL(ji,jl) ) - hL(ji,jl) ! hi_max(jl) - hL + zetamax = MIN( zhbnew(ji,jl), hR(ji,jl) ) - hL(ji,jl) ! hR - hL + jdonor(ji,jl) = jl + ELSE ! Hn* <= Hn => transfer from jl+1 to jl + zetamin = 0.0 + zetamax = MIN( hi_max(jl), hR(ji,jl+1) ) - hL(ji,jl+1) ! hi_max(jl) - hL + jdonor(ji,jl) = jl + 1 + ENDIF + zetamax = MAX( zetamax, zetamin ) ! no transfer if etamax < etamin + ! + zx1 = zetamax - zetamin + zwk1 = zetamin * zetamin + zwk2 = zetamax * zetamax + zx2 = 0.5 * ( zwk2 - zwk1 ) + zwk1 = zwk1 * zetamin + zwk2 = zwk2 * zetamax + zx3 = 1.0 / 3.0 * ( zwk2 - zwk1 ) + jcat = jdonor(ji,jl) + zdaice(ji,jl) = g1(ji,jcat)*zx2 + g0(ji,jcat)*zx1 + zdvice(ji,jl) = g1(ji,jcat)*zx3 + g0(ji,jcat)*zx2 + zdaice(ji,jl)*hL(ji,jcat) + ! + END DO + END DO + + !---------------------------------------------------------------------------------------------- + ! 6) Shift ice between categories + !---------------------------------------------------------------------------------------------- + CALL itd_shiftice ( ji1, ji2, jpti, jdonor, zdaice, zdvice ) + + !---------------------------------------------------------------------------------------------- + ! 7) Make sure h_i >= minimum ice thickness hi_min + !---------------------------------------------------------------------------------------------- + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), h_i_1d (ji1:ji2), h_i (:,:,1) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), a_i_1d (ji1:ji2), a_i (:,:,1) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), a_ip_1d(ji1:ji2), a_ip(:,:,1) ) + ! + DO ji = ji1, ji2 + IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN + a_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin + IF( ln_pnd_LEV ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin + h_i_1d(ji) = rn_himin + ENDIF + END DO + ! + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), h_i_1d (ji1:ji2), h_i (:,:,1) ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), a_i_1d (ji1:ji2), a_i (:,:,1) ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), a_ip_1d(ji1:ji2), a_ip(:,:,1) ) + ! + ENDIF + ! + !$omp end parallel + ! + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_rem', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + IF( ln_timing ) CALL timing_stop ('iceitd_rem') + ! + END SUBROUTINE ice_itd_rem + + + SUBROUTINE itd_glinear( jpti, HbL, HbR, phice, paice, pg0, pg1, phL, phR ) + !!------------------------------------------------------------------ + !! *** ROUTINE itd_glinear *** + !! + !! ** Purpose : build g(h) satisfying area and volume constraints (Eq. 6 and 9) + !! + !! ** Method : g(h) is linear and written as: g(eta) = g1(eta) + g0 + !! with eta = h - HL + !!------------------------------------------------------------------ + INTEGER, INTENT(in) :: jpti ! loop length + REAL(wp), DIMENSION(:), INTENT(in ) :: HbL, HbR ! left and right category boundaries + REAL(dp), DIMENSION(:), INTENT(in ) :: phice, paice ! ice thickness and concentration + REAL(wp), DIMENSION(:), INTENT(inout) :: pg0! coefficients in linear equation for g(eta) + REAL(dp), DIMENSION(:), INTENT(inout) :: pg1! coefficients in linear equation for g(eta) + REAL(wp), DIMENSION(:), INTENT(inout) :: phL, phR ! min and max value of range over which g(h) > 0 + ! + INTEGER :: ji ! horizontal indices + REAL(wp) :: z1_3 , z2_3 ! 1/3 , 2/3 + REAL(wp) :: zh13 ! HbL + 1/3 * (HbR - HbL) + REAL(wp) :: zh23 ! HbL + 2/3 * (HbR - HbL) + REAL(wp) :: zdhr ! 1 / (hR - hL) + REAL(wp) :: zwk1, zwk2 ! temporary variables + !!------------------------------------------------------------------ + ! + z1_3 = 1._wp / 3._wp + z2_3 = 2._wp / 3._wp + ! + DO ji = 1, jpti + ! + IF( paice(ji) > epsi10 .AND. phice(ji) > epsi10 ) THEN + ! + ! Initialize hL and hR + phL(ji) = HbL(ji) + phR(ji) = HbR(ji) + ! + ! Change hL or hR if hice falls outside central third of range, + ! so that hice is in the central third of the range [HL HR] + zh13 = z1_3 * ( 2._wp * phL(ji) + phR(ji) ) + zh23 = z1_3 * ( phL(ji) + 2._wp * phR(ji) ) + ! + IF ( phice(ji) < zh13 ) THEN ; phR(ji) = 3._wp * phice(ji) - 2._wp * phL(ji) ! move HR to the left + ELSEIF( phice(ji) > zh23 ) THEN ; phL(ji) = 3._wp * phice(ji) - 2._wp * phR(ji) ! move HL to the right + ENDIF + ! + ! Compute coefficients of g(eta) = g0 + g1*eta + + ! Check whether rounding errors have broken the constraint of phR(ji) > phL(ji) + ! This is particularly important in case phR(ji) = phL(ji), in which case a divide-by-0 + ! would occur when computing zdhr + ! If phR(ji) is not > phL(ji) then we simply skip remapping for this grid point + IF (phR(ji) > phL(ji)) THEN + zdhr = 1._wp / (phR(ji) - phL(ji)) + ELSE + zdhr = 0._wp + ENDIF + zwk1 = 6._wp * paice(ji) * zdhr + zwk2 = ( phice(ji) - phL(ji) ) * zdhr + pg0(ji) = zwk1 * ( z2_3 - zwk2 ) ! Eq. 14 + pg1(ji) = 2._wp * zdhr * zwk1 * ( zwk2 - 0.5_wp ) ! Eq. 14 + ! + ELSE ! remap_flag = .false. or a_i < epsi10 + phL(ji) = 0._wp + phR(ji) = 0._wp + pg0(ji) = 0._wp + pg1(ji) = 0._wp + ENDIF + ! + END DO + ! + END SUBROUTINE itd_glinear + + + SUBROUTINE itd_shiftice( ki1, ki2, kpti, kdonor, pdaice, pdvice ) + !!------------------------------------------------------------------ + !! *** ROUTINE itd_shiftice *** + !! + !! ** Purpose : shift ice across category boundaries, conserving everything + !! ( area, volume, energy, age*vol, and mass of salt ) + !!------------------------------------------------------------------ + INTEGER, INTENT(in) :: ki1, ki2, kpti ! indices + INTEGER , DIMENSION(:,:), INTENT(in) :: kdonor ! donor category index + REAL(dp), DIMENSION(:,:), INTENT(in) :: pdaice ! ice area transferred across boundary + REAL(wp), DIMENSION(:,:), INTENT(in) :: pdvice ! ice volume transferred across boundary + ! + INTEGER :: ji, jl, jk ! dummy loop indices + INTEGER :: jl2, jl1 ! local integers + REAL(wp) :: ztrans ! ice/snow transferred + REAL(wp), DIMENSION(jpij) :: zworka, zworkv ! workspace + REAL(wp), DIMENSION(jpij,jpl) :: zaTsfn ! - - + REAL(dp), DIMENSION(jpij,nlay_i,jpl) :: ze_i_2d + REAL(dp), DIMENSION(jpij,nlay_s,jpl) :: ze_s_2d + !!------------------------------------------------------------------ + + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), h_i_2d (ki1:ki2,1:jpl), h_i ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), a_i_2d (ki1:ki2,1:jpl), a_i ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), v_i_2d (ki1:ki2,1:jpl), v_i ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), v_s_2d (ki1:ki2,1:jpl), v_s ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), oa_i_2d(ki1:ki2,1:jpl), oa_i ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), sv_i_2d(ki1:ki2,1:jpl), sv_i ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), a_ip_2d(ki1:ki2,1:jpl), a_ip ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), v_ip_2d(ki1:ki2,1:jpl), v_ip ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), v_il_2d(ki1:ki2,1:jpl), v_il ) + CALL tab_3d_2d( kpti, nptidx(ki1:ki2), t_su_2d(ki1:ki2,1:jpl), t_su ) + DO jl = 1, jpl + DO jk = 1, nlay_s + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), ze_s_2d(ki1:ki2,jk,jl), e_s(:,:,jk,jl) ) + END DO + DO jk = 1, nlay_i + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), ze_i_2d(ki1:ki2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + ! to correct roundoff errors on a_i + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), rn_amax_1d(ki1:ki2), CASTDP(rn_amax_2d )) + + !---------------------------------------------------------------------------------------------- + ! 1) Define a variable equal to a_i*T_su + !---------------------------------------------------------------------------------------------- + DO jl = 1, jpl + DO ji = ki1, ki2 + zaTsfn(ji,jl) = a_i_2d(ji,jl) * t_su_2d(ji,jl) + END DO + END DO + + !------------------------------------------------------------------------------- + ! 2) Transfer volume and energy between categories + !------------------------------------------------------------------------------- + DO jl = 1, jpl - 1 + DO ji = ki1, ki2 + ! + jl1 = kdonor(ji,jl) + ! + IF( jl1 > 0 ) THEN + ! + IF ( jl1 == jl ) THEN ; jl2 = jl1+1 + ELSE ; jl2 = jl + ENDIF + ! + IF( v_i_2d(ji,jl1) >= epsi10 ) THEN ; zworkv(ji) = pdvice(ji,jl) / v_i_2d(ji,jl1) + ELSE ; zworkv(ji) = 0._wp + ENDIF + IF( a_i_2d(ji,jl1) >= epsi10 ) THEN ; zworka(ji) = pdaice(ji,jl) / a_i_2d(ji,jl1) + ELSE ; zworka(ji) = 0._wp + ENDIF + ! + a_i_2d(ji,jl1) = a_i_2d(ji,jl1) - pdaice(ji,jl) ! Ice areas + a_i_2d(ji,jl2) = a_i_2d(ji,jl2) + pdaice(ji,jl) + ! + v_i_2d(ji,jl1) = v_i_2d(ji,jl1) - pdvice(ji,jl) ! Ice volumes + v_i_2d(ji,jl2) = v_i_2d(ji,jl2) + pdvice(ji,jl) + ! + ztrans = v_s_2d(ji,jl1) * zworkv(ji) ! Snow volumes + v_s_2d(ji,jl1) = v_s_2d(ji,jl1) - ztrans + v_s_2d(ji,jl2) = v_s_2d(ji,jl2) + ztrans + ! + ztrans = oa_i_2d(ji,jl1) * zworka(ji) ! Ice age + oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - ztrans + oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ztrans + ! + ztrans = sv_i_2d(ji,jl1) * zworkv(ji) ! Ice salinity + sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - ztrans + sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ztrans + ! + ztrans = zaTsfn(ji,jl1) * zworka(ji) ! Surface temperature + zaTsfn(ji,jl1) = zaTsfn(ji,jl1) - ztrans + zaTsfn(ji,jl2) = zaTsfn(ji,jl2) + ztrans + ! + IF ( ln_pnd_LEV ) THEN + ztrans = a_ip_2d(ji,jl1) * zworka(ji) ! Pond fraction + a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans + a_ip_2d(ji,jl2) = a_ip_2d(ji,jl2) + ztrans + ! +!!$ ztrans = v_ip_2d(ji,jl1) * zworka(ji) ! Pond volume (also proportional to da/a) + ztrans = v_ip_2d(ji,jl1) * zworkv(ji) ! Pond volume + v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans + v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans + ! + IF ( ln_pnd_lids ) THEN ! Pond lid volume +!!$ ztrans = v_il_2d(ji,jl1) * zworka(ji) + ztrans = v_il_2d(ji,jl1) * zworkv(ji) + v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans + v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans + ENDIF + ENDIF + ! + ENDIF ! jl1 >0 + END DO + ! + DO jk = 1, nlay_s !--- Snow heat content + DO ji = ki1, ki2 + ! + jl1 = kdonor(ji,jl) + ! + IF( jl1 > 0 ) THEN + IF(jl1 == jl) THEN ; jl2 = jl+1 + ELSE ; jl2 = jl + ENDIF + ztrans = ze_s_2d(ji,jk,jl1) * zworkv(ji) + ze_s_2d(ji,jk,jl1) = ze_s_2d(ji,jk,jl1) - ztrans + ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ztrans + ENDIF + END DO + END DO + ! + DO jk = 1, nlay_i !--- Ice heat content + DO ji = ki1, ki2 + ! + jl1 = kdonor(ji,jl) + ! + IF( jl1 > 0 ) THEN + IF(jl1 == jl) THEN ; jl2 = jl+1 + ELSE ; jl2 = jl + ENDIF + ztrans = ze_i_2d(ji,jk,jl1) * zworkv(ji) + ze_i_2d(ji,jk,jl1) = ze_i_2d(ji,jk,jl1) - ztrans + ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + ztrans + ENDIF + END DO + END DO + ! + END DO ! boundaries, 1 to jpl-1 + + !------------------- + ! 3) roundoff errors + !------------------- + ! clem: The transfer between one category to another can lead to very small negative values (-1.e-20) + ! because of truncation error ( i.e. 1. - 1. /= 0 ) + CALL ice_var_roundoff( ki1, ki2, a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) + + ! at_i must be <= rn_amax + zworka(ki1:ki2) = SUM( a_i_2d(ki1:ki2,:), dim=2 ) + DO jl = 1, jpl + WHERE( zworka(ki1:ki2) > rn_amax_1d(ki1:ki2) ) & + & a_i_2d(ki1:ki2,jl) = a_i_2d(ki1:ki2,jl) * rn_amax_1d(ki1:ki2) / zworka(ki1:ki2) + END DO + + !------------------------------------------------------------------------------- + ! 4) Update ice thickness and temperature + !------------------------------------------------------------------------------- + WHERE( a_i_2d(ki1:ki2,:) >= epsi08 ) + h_i_2d (ki1:ki2,:) = v_i_2d(ki1:ki2,:) / a_i_2d(ki1:ki2,:) + t_su_2d(ki1:ki2,:) = zaTsfn(ki1:ki2,:) / a_i_2d(ki1:ki2,:) + ELSEWHERE + h_i_2d (ki1:ki2,:) = 0._wp + t_su_2d(ki1:ki2,:) = rt0 + END WHERE + ! + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), h_i_2d (ki1:ki2,1:jpl), h_i ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), a_i_2d (ki1:ki2,1:jpl), a_i ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), v_i_2d (ki1:ki2,1:jpl), v_i ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), v_s_2d (ki1:ki2,1:jpl), v_s ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), oa_i_2d(ki1:ki2,1:jpl), oa_i ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), sv_i_2d(ki1:ki2,1:jpl), sv_i ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), a_ip_2d(ki1:ki2,1:jpl), a_ip ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), v_ip_2d(ki1:ki2,1:jpl), v_ip ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), v_il_2d(ki1:ki2,1:jpl), v_il ) + CALL tab_2d_3d( kpti, nptidx(ki1:ki2), t_su_2d(ki1:ki2,1:jpl), t_su ) + DO jl = 1, jpl + DO jk = 1, nlay_s + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), ze_s_2d(ki1:ki2,jk,jl), e_s(:,:,jk,jl) ) + END DO + DO jk = 1, nlay_i + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), ze_i_2d(ki1:ki2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + ! + END SUBROUTINE itd_shiftice + + + SUBROUTINE ice_itd_reb( kt ) + !!------------------------------------------------------------------ + !! *** ROUTINE ice_itd_reb *** + !! + !! ** Purpose : rebin - rebins thicknesses into defined categories + !! + !! ** Method : If a category thickness is out of bounds, shift part (for down to top) + !! or entire (for top to down) area, volume, and energy + !! to the neighboring category + !!------------------------------------------------------------------ + INTEGER , INTENT (in) :: kt ! Ocean time step + INTEGER :: ji, jj, jl ! dummy loop indices + ! + INTEGER , DIMENSION(jpij,jpl-1) :: jdonor ! donor category index + REAL(wp), DIMENSION(jpij,jpl-1) :: zdaice, zdvice ! ice area and volume transferred + !!------------------------------------------------------------------ + IF( ln_timing ) CALL timing_start('iceitd_reb') + ! + IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_itd_reb: rebining ice thickness distribution' + ! + IF( ln_icediachk ) CALL ice_cons_hsm(0, 'iceitd_reb', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + IF( ln_icediachk ) CALL ice_cons2D (0, 'iceitd_reb', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + ! + jdonor(:,:) = 0 + zdaice(:,:) = 0._wp + zdvice(:,:) = 0._wp + ! + ! !--------------------------------------- + DO jl = 1, jpl-1 ! identify thicknesses that are too big + ! !--------------------------------------- + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN + npti = npti + 1 + nptidx( npti ) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + ! + IF( npti > 0 ) THEN + !!clem CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) + CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl) ) + CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl) ) + ! + DO ji = 1, npti + jdonor(ji,jl) = jl + ! how much of a_i you send in cat sup is somewhat arbitrary + ! these are from CICE => transfer everything + !!zdaice(ji,jl) = a_i_1d(ji) + !!zdvice(ji,jl) = v_i_1d(ji) + ! these are from LLN => transfer only half of the category + zdaice(ji,jl) = 0.5_wp * a_i_1d(ji) + zdvice(ji,jl) = v_i_1d(ji) - (1._wp - 0.5_wp) * a_i_1d(ji) * hi_mean(jl) + END DO + ! + CALL itd_shiftice( 1, npti, npti, jdonor(1:npti,:), CASTDP(zdaice(1:npti,:)), zdvice(1:npti,:) ) ! Shift jl=>jl+1 + ! Reset shift parameters + jdonor(1:npti,jl) = 0 + zdaice(1:npti,jl) = 0._wp + zdvice(1:npti,jl) = 0._wp + ENDIF + ! + END DO + + ! !----------------------------------------- + DO jl = jpl-1, 1, -1 ! Identify thicknesses that are too small + ! !----------------------------------------- + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN + npti = npti + 1 + nptidx( npti ) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + ! + IF( npti > 0 ) THEN + CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok + CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl+1) ) ! jl+1 is ok + ! + DO ji = 1, npti + jdonor(ji,jl) = jl + 1 + zdaice(ji,jl) = a_i_1d(ji) + zdvice(ji,jl) = v_i_1d(ji) + END DO + ! + CALL itd_shiftice( 1, npti, npti, jdonor(1:npti,:), CASTDP(zdaice(1:npti,:)), zdvice(1:npti,:) ) ! Shift jl+1=>jl + ! Reset shift parameters + jdonor(1:npti,jl) = 0 + zdaice(1:npti,jl) = 0._wp + zdvice(1:npti,jl) = 0._wp + ENDIF + ! + END DO + ! + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_reb', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_reb', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + IF( ln_timing ) CALL timing_stop ('iceitd_reb') + ! + END SUBROUTINE ice_itd_reb + + + SUBROUTINE ice_itd_init + !!------------------------------------------------------------------ + !! *** ROUTINE ice_itd_init *** + !! + !! ** Purpose : Initializes the ice thickness distribution + !! ** Method : ... + !! ** input : Namelist namitd + !!------------------------------------------------------------------- + INTEGER :: jl ! dummy loop index + INTEGER :: ios, ioptio ! Local integer output status for namelist read + REAL(wp) :: zhmax, znum, zden, zalpha ! - - + ! + NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin, rn_himax + !!------------------------------------------------------------------ + ! + REWIND( numnam_ice_ref ) ! Namelist namitd in reference namelist : Parameters for ice + READ ( numnam_ice_ref, namitd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namitd in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namitd in configuration namelist : Parameters for ice + READ ( numnam_ice_cfg, namitd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namitd in configuration namelist' ) + IF(lwm) WRITE( numoni, namitd ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_itd_init: Initialization of ice cat distribution ' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namitd: ' + WRITE(numout,*) ' Ice categories are defined by a function of rn_himean**(-0.05) ln_cat_hfn = ', ln_cat_hfn + WRITE(numout,*) ' mean ice thickness in the domain rn_himean = ', rn_himean + WRITE(numout,*) ' Ice categories are defined by rn_catbnd ln_cat_usr = ', ln_cat_usr + WRITE(numout,*) ' minimum ice thickness allowed rn_himin = ', rn_himin + WRITE(numout,*) ' maximum ice thickness allowed rn_himax = ', rn_himax + ENDIF + ! + !-----------------------------------! + ! Thickness categories boundaries ! + !-----------------------------------! + ! !== set the choice of ice categories ==! + ioptio = 0 + IF( ln_cat_hfn ) THEN ; ioptio = ioptio + 1 ; nice_catbnd = np_cathfn ; ENDIF + IF( ln_cat_usr ) THEN ; ioptio = ioptio + 1 ; nice_catbnd = np_catusr ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ice_itd_init: choose one and only one ice categories boundaries' ) + ! + SELECT CASE( nice_catbnd ) + ! !------------------------! + CASE( np_cathfn ) ! h^(-alpha) function + ! !------------------------! + zalpha = 0.05_wp + zhmax = 3._wp * rn_himean + hi_max(0) = 0._wp + DO jl = 1, jpl + znum = jpl * ( zhmax+1 )**zalpha + zden = REAL( jpl-jl , wp ) * ( zhmax + 1._wp )**zalpha + REAL( jl , wp ) + hi_max(jl) = ( znum / zden )**(1./zalpha) - 1 + END DO + ! !------------------------! + CASE( np_catusr ) ! user defined + ! !------------------------! + DO jl = 0, jpl + hi_max(jl) = rn_catbnd(jl) + END DO + ! + END SELECT + ! + DO jl = 1, jpl ! mean thickness by category + hi_mean(jl) = ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp + END DO + ! + hi_max(jpl) = rn_himax ! set to a big value to ensure that all ice is thinner than hi_max(jpl) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ===>>> resulting thickness category boundaries :' + IF(lwp) WRITE(numout,*) ' hi_max(:)= ', hi_max(0:jpl) + ! + IF( hi_max(1) < rn_himin ) CALL ctl_stop('ice_itd_init: the upper bound of the 1st category must be bigger than rn_himin') + ! + END SUBROUTINE ice_itd_init + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE iceitd diff --git a/V4.0/nemo_sources/src/ICE/iceitd.mod b/V4.0/nemo_sources/src/ICE/iceitd.mod new file mode 100644 index 0000000000000000000000000000000000000000..cf4161aed2a1def37d763c06c5e5c64fff9fa5ae Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/iceitd.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icerst.F90 b/V4.0/nemo_sources/src/ICE/icerst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4bd5d17c8cd03d1c4367777334028537f64410c6 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icerst.F90 @@ -0,0 +1,359 @@ +MODULE icerst + !!====================================================================== + !! *** MODULE icerst *** + !! sea-ice : write/read the ice restart file + !!====================================================================== + !! History: 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_rst_opn : open restart file + !! ice_rst_write : write restart file + !! ice_rst_read : read restart file + !!---------------------------------------------------------------------- + USE ice ! sea-ice: variables + USE dom_oce ! ocean domain + USE phycst , ONLY : rt0 + USE sbc_oce , ONLY : nn_fsbc, ln_cpl, ln_sglexe + USE sbc_ice , ONLY : alb_ice + USE sbc_oce , ONLY : nn_components, jp_iam_sas ! SAS ss[st]_m init + USE sbc_oce , ONLY : sst_m, sss_m ! SAS ss[st]_m init + USE oce , ONLY : tsn ! SAS ss[st]_m init + USE eosbn2 , ONLY : l_useCT, eos_pt_from_ct ! SAS ss[st]_m init + USE iceistate ! sea-ice: initial state + USE icectl ! sea-ice: control + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE ioipsl, ONLY : ju2ymds, ymds2ju ! for calendar + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE phycst ! Physical constants + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_rst_opn ! called by icestp + PUBLIC ice_rst_write ! called by icestp + PUBLIC ice_rst_read ! called by ice_init + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icerst.F90 13449 2020-09-03 14:40:10Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_rst_opn( kt ) + !!---------------------------------------------------------------------- + !! *** ice_rst_opn *** + !! + !! ** purpose : open restart file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + ! + INTEGER :: iyear, imonth, iday + REAL (wp) :: zsec + REAL (wp) :: zfjulday + CHARACTER(len=20) :: clkt ! ocean time-step define as a character + CHARACTER(len=128) :: clname ! ice output restart file name + CHARACTER(len=256) :: clpath ! full path to ice output restart file + INTEGER :: inyear, inmonth, inday, inhour, inmin, insec, idt05 + REAL(wp) :: zjulnow, zjul1st, zjuldif, zjulrst, znsec + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) lrst_ice = .FALSE. ! default definition + + IF( ln_rst_list .OR. nn_stock /= -1 ) THEN + ! in order to get better performances with NetCDF format, we open and define the ice restart file + ! one ice time step before writing the data (-> at nitrst - 2*nn_fsbc + 1), except if we write ice + ! restart files every ice time step or if an ice restart file was writen at nitend - 2*nn_fsbc + 1 + IF( kt == nitrst - 2*nn_fsbc + 1 .OR. nn_stock == nn_fsbc & + & .OR. ( kt == nitend - nn_fsbc + 1 .AND. .NOT. lrst_ice ) ) 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_rsttime ) THEN + inyear = ndate0 / 10000 + inmonth = ( ndate0 - (inyear * 10000) ) / 100 + inday = ndate0 - (inyear * 10000) - ( inmonth * 100 ) + + inhour = ntime0 / 100 + inmin = ( ntime0 - nhour * 100 ) + + CALL ymds2ju( inyear, inmonth, inday, inhour*3600._wp+inmin*60._wp, zjulrst ) + zjulrst = zjulrst + nitrst * rn_rdt / 86400.0_wp + CALL ju2ymds( zjulrst, inyear, inmonth, inday, znsec ) + inhour = INT( znsec / 3600_wp ) + inmin = INT( ( znsec - inhour * 3600_wp ) / 60.0_wp ) + insec = INT( znsec - inhour * 3600_wp - inmin * 60.0_wp ) + WRITE(clkt,'(I4.4,I2.2,I2.2,A,3I2.2)') inyear, inmonth, inday, & + & '_', inhour, inmin, insec + ELSEIF ( ln_rstdate ) THEN + zfjulday = fjulday + (2*nn_fsbc+1)*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 > 99999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_icerst_out) + clpath = TRIM(cn_icerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath)//'/' + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' open ice restart NetCDF file: ',TRIM(clpath)//clname + IF( kt == nitrst - 2*nn_fsbc + 1 ) THEN + WRITE(numout,*) ' kt = nitrst - 2*nn_fsbc + 1 = ', kt,' date= ', ndastp + ELSE + WRITE(numout,*) ' kt = ' , kt,' date= ', ndastp + ENDIF + ENDIF + ! + CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl ) + lrst_ice = .TRUE. + ENDIF + ENDIF + ENDIF + ! + IF( ln_icectl ) CALL ice_prt( kt, iiceprt, jiceprt, 1, ' - Beginning the time step - ' ) ! control print + ! + END SUBROUTINE ice_rst_opn + + + SUBROUTINE ice_rst_write( kt ) + !!---------------------------------------------------------------------- + !! *** ice_rst_write *** + !! + !! ** purpose : write restart file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + !! + INTEGER :: jk ! dummy loop indices + INTEGER :: iter + CHARACTER(len=25) :: znam + CHARACTER(len=2) :: zchar, zchar1 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace + !!---------------------------------------------------------------------- + + iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 + + IF( iter == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_rst_write : write ice restart file kt =', kt + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' + ENDIF + + ! Write in numriw (if iter == nitrst) + ! ------------------ + ! ! calendar control + CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) ) ! time-step + CALL iom_rstput( iter, nitrst, numriw, 'kt_ice' , REAL( iter , wp ) ) ! date + CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables + + ! Prognostic variables + CALL iom_rstput( iter, nitrst, numriw, 'v_i' , v_i ) + CALL iom_rstput( iter, nitrst, numriw, 'v_s' , v_s ) + CALL iom_rstput( iter, nitrst, numriw, 'sv_i' , sv_i ) + CALL iom_rstput( iter, nitrst, numriw, 'a_i' , a_i ) + CALL iom_rstput( iter, nitrst, numriw, 't_su' , t_su ) + CALL iom_rstput( iter, nitrst, numriw, 'u_ice', u_ice ) + CALL iom_rstput( iter, nitrst, numriw, 'v_ice', v_ice ) + CALL iom_rstput( iter, nitrst, numriw, 'oa_i' , oa_i ) + CALL iom_rstput( iter, nitrst, numriw, 'a_ip' , a_ip ) + CALL iom_rstput( iter, nitrst, numriw, 'v_ip' , v_ip ) + CALL iom_rstput( iter, nitrst, numriw, 'v_il' , v_il ) + ! Snow enthalpy + DO jk = 1, nlay_s + WRITE(zchar1,'(I2.2)') jk + znam = 'e_s'//'_l'//zchar1 + z3d(:,:,:) = e_s(:,:,jk,:) + CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + END DO + ! Ice enthalpy + DO jk = 1, nlay_i + WRITE(zchar1,'(I2.2)') jk + znam = 'e_i'//'_l'//zchar1 + z3d(:,:,:) = e_i(:,:,jk,:) + CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) + END DO + ! fields needed for Met Office (Jules) coupling + IF( ln_cpl ) THEN + CALL iom_rstput( iter, nitrst, numriw, 'cnd_ice', cnd_ice ) + CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice ) + ENDIF + ! Ice albedo to for initial coupling step + CALL iom_rstput( iter, nitrst, numriw, 'alb_ice' , alb_ice ) + ! + + ! close restart file + ! ------------------ + IF( iter == nitrst ) THEN + CALL iom_close( numriw ) + lrst_ice = .FALSE. + ENDIF + ! + END SUBROUTINE ice_rst_write + + + SUBROUTINE ice_rst_read + !!---------------------------------------------------------------------- + !! *** ice_rst_read *** + !! + !! ** purpose : read restart file + !!---------------------------------------------------------------------- + INTEGER :: jk + LOGICAL :: llok + INTEGER :: id0, id1, id2, id3, id4, id5 ! local integer + CHARACTER(len=25) :: znam + CHARACTER(len=2) :: zchar, zchar1 + REAL(wp) :: zfice, ziter + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_rst_read: read ice NetCDF restart file' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir, kdlev = jpl ) + + ! test if v_i exists + id0 = iom_varid( numrir, 'v_i' , ldstop = .FALSE. ) + + ! ! ------------------------------ ! + IF( id0 > 0 ) THEN ! == case of a normal restart == ! + ! ! ------------------------------ ! + + ! Time info + CALL iom_get( numrir, 'nn_fsbc', zfice ) + CALL iom_get( numrir, 'kt_ice' , ziter ) + IF(lwp) WRITE(numout,*) ' read ice restart file at time step : ', ziter + IF(lwp) WRITE(numout,*) ' in any case we force it to nit000 - 1 : ', nit000 - 1 + + ! Control of date + IF( ( nit000 - NINT(ziter) ) /= 1 .AND. ABS( nrstdt ) == 1 ) & + & CALL ctl_stop( 'ice_rst_read ===>>>> : problem with nit000 in ice restart', & + & ' verify the file or rerun with the value 0 for the', & + & ' control of time parameter nrstdt' ) + IF( NINT(zfice) /= nn_fsbc .AND. ABS( nrstdt ) == 1 ) & + & CALL ctl_stop( 'ice_rst_read ===>>>> : problem with nn_fsbc in ice restart', & + & ' verify the file or rerun with the value 0 for the', & + & ' control of time parameter nrstdt' ) + + ! --- mandatory fields --- ! + CALL iom_get( numrir, jpdom_autoglo, 'v_i' , v_i ) + CALL iom_get( numrir, jpdom_autoglo, 'v_s' , v_s ) + CALL iom_get( numrir, jpdom_autoglo, 'sv_i' , sv_i ) + CALL iom_get( numrir, jpdom_autoglo, 'a_i' , a_i ) + CALL iom_get( numrir, jpdom_autoglo, 't_su' , t_su ) + CALL iom_get( numrir, jpdom_autoglo, 'u_ice', u_ice ) + CALL iom_get( numrir, jpdom_autoglo, 'v_ice', v_ice ) + ! Snow enthalpy + DO jk = 1, nlay_s + WRITE(zchar1,'(I2.2)') jk + znam = 'e_s'//'_l'//zchar1 + CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) + e_s(:,:,jk,:) = z3d(:,:,:) + END DO + ! Ice enthalpy + DO jk = 1, nlay_i + WRITE(zchar1,'(I2.2)') jk + znam = 'e_i'//'_l'//zchar1 + CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) + e_i(:,:,jk,:) = z3d(:,:,:) + END DO + ! -- optional fields -- ! + ! ice age + IF (ln_iceageign) THEN + IF(lwp) WRITE(numout,*) ' ==>> ignoring previous run ice age output and set it to zero' + oa_i(:,:,:) = 0._wp + ELSE + id1 = iom_varid( numrir, 'oa_i' , ldstop = .FALSE. ) + IF( id1 > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'oa_i', oa_i ) + ELSE ! start from rest + IF(lwp) WRITE(numout,*) ' ==>> previous run without ice age output then set it to zero' + oa_i(:,:,:) = 0._wp + ENDIF + ENDIF + ! melt ponds + id2 = iom_varid( numrir, 'a_ip' , ldstop = .FALSE. ) + IF( id2 > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'a_ip' , a_ip ) + CALL iom_get( numrir, jpdom_autoglo, 'v_ip' , v_ip ) + ELSE ! start from rest + IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds output then set it to zero' + a_ip(:,:,:) = 0._wp + v_ip(:,:,:) = 0._wp + ENDIF + ! melt pond lids + id3 = iom_varid( numrir, 'v_il' , ldstop = .FALSE. ) + IF( id3 > 0 ) THEN + CALL iom_get( numrir, jpdom_autoglo, 'v_il', v_il) + ELSE + IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds lids output then set it to zero' + v_il(:,:,:) = 0._wp + ENDIF + ! fields needed for Met Office (Jules) coupling + IF( ln_cpl ) THEN + id4 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. ) + id5 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. ) + IF( id4 > 0 .AND. id5 > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'cnd_ice', cnd_ice ) + CALL iom_get( numrir, jpdom_autoglo, 't1_ice' , t1_ice ) + ELSE ! start from rest + IF(lwp) WRITE(numout,*) ' ==>> previous run without conductivity output then set it to zero' + cnd_ice(:,:,:) = 0._wp + t1_ice (:,:,:) = rt0 + ENDIF + ENDIF + id1 = iom_varid( numrir, 'alb_ice' , ldstop = .FALSE. ) + IF( id1 > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'alb_ice', alb_ice ) + ELSE ! start from rest + IF(lwp) WRITE(numout,*) ' ==>> previous run without ice albede output then set it to 0.0' + alb_ice(:,:,:) = 0.0_wp + ENDIF + + CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables + + ! ! ---------------------------------- ! + ELSE ! == case of a simplified restart == ! + ! ! ---------------------------------- ! + CALL ctl_warn('ice_rst_read: you are attempting to use an unsuitable ice restart') + ! + IF( .NOT. ln_iceini .OR. nn_iceini_file == 2 ) THEN + CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and nn_iceini_file=0 or 1') + ELSE + CALL ctl_warn('ice_rst_read: using ice_istate to set initial conditions instead') + ENDIF + ! + IF( nn_components == jp_iam_sas ) THEN ! SAS case: ss[st]_m were not initialized by sbc_ssm_init + ! + IF(lwp) WRITE(numout,*) ' SAS: default initialisation of ss[st]_m arrays used in ice_istate' + 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) + ENDIF + ! + CALL ice_istate( nit000 ) + ! + ENDIF + + END SUBROUTINE ice_rst_read + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icerst \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icerst.mod b/V4.0/nemo_sources/src/ICE/icerst.mod new file mode 100644 index 0000000000000000000000000000000000000000..4c2908b4d6d1eb5ec221a67514efce1367d7960b Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icerst.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icesbc.F90 b/V4.0/nemo_sources/src/ICE/icesbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b551fd660f6d0813b137a8a15dec02efd842ce16 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icesbc.F90 @@ -0,0 +1,345 @@ +MODULE icesbc + !!====================================================================== + !! *** MODULE icesbc *** + !! Sea-Ice : air-ice sbc fields + !!===================================================================== + !! History : 4.0 ! 2017-08 (C. Rousset) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' : SI3 sea-ice model + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE ice ! sea-ice: variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + USE usrdef_sbc ! Surface boundary condition: user defined + USE sbcblk ! Surface boundary condition: bulk + USE sbccpl ! Surface boundary condition: coupled interface + USE sbcsglcpl ! Surface boundary condition: sglexe coupling + USE icealb ! sea-ice: albedo + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_sbc_tau ! called by icestp.F90 + PUBLIC ice_sbc_flx ! called by icestp.F90 + PUBLIC ice_sbc_init ! called by icestp.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icesbc.F90 14590 2021-03-05 13:21:05Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_sbc_tau *** + !! + !! ** Purpose : provide surface boundary condition for sea ice (momentum) + !! + !! ** Action : It provides the following fields: + !! utau_ice, vtau_ice : surface ice stress (U- & V-points) [N/m2] + !!------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: ksbc ! type of sbc flux + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: utau_ice, vtau_ice ! air-ice stress [N/m2] + !REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: cld_fra ! cloud fraction - lcc or tcc depending on switch + !! + INTEGER :: ji, jj ! dummy loop index + REAL(wp), DIMENSION(jpi,jpj) :: zutau_ice, zvtau_ice + !!------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icesbc') + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_sbc_tau: Surface boundary condition for sea ice (momentum)' + WRITE(numout,*)'~~~~~~~~~~~~~~~' + ENDIF + ! + SELECT CASE( ksbc ) + CASE( jp_usr ) ; CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation + CASE( jp_blk ) ; CALL blk_ice_tau ! Bulk formulation + CASE( jp_purecpl ) ; CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation + CASE( jp_sglexe ) + CALL sbc_sglcpl_ice_tau( utau_ice, vtau_ice ) + !SARAH - removed for time being think this can be updated in sbc_sglspl_ice_flux + !IF (ln_limcplcld) THEN + ! CALL sbc_sglcpl_ice_cldcov(cld_fra, ln_limcpllcc ) + !ENDIF + END SELECT + ! + IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation + CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) + vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) + END DO + END DO + CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('icesbc') + ! + END SUBROUTINE ice_sbc_tau + + + SUBROUTINE ice_sbc_flx( kt, ksbc ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_sbc_flx *** + !! + !! ** Purpose : provide surface boundary condition for sea ice (flux) + !! + !! ** Action : It provides the following fields used in sea ice model: + !! emp_oce , emp_ice = E-P over ocean and sea ice [Kg/m2/s] + !! sprecip = solid precipitation [Kg/m2/s] + !! evap_ice = sublimation [Kg/m2/s] + !! qsr_tot , qns_tot = solar & non solar heat flux (total) [W/m2] + !! qsr_ice , qns_ice = solar & non solar heat flux over ice [W/m2] + !! dqns_ice = non solar heat sensistivity [W/m2] + !! qemp_oce, qemp_ice, qprec_ice, qevap_ice = sensible heat (associated with evap & precip) [W/m2] + !! + some fields that are not used outside this module: + !! qla_ice = latent heat flux over ice [W/m2] + !! dqla_ice = latent heat sensistivity [W/m2] + !! tprecip = total precipitation [Kg/m2/s] + !! alb_ice = albedo above sea ice + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk or Pure Coupled) + ! + INTEGER :: ji, jj, jl ! dummy loop index + REAL(wp) :: zmiss_val ! missing value retrieved from xios + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zalb, zmsk00 ! 2D workspace + !!-------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icesbc') + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_sbc_flx: Surface boundary condition for sea ice (flux)' + WRITE(numout,*)'~~~~~~~~~~~~~~~' + ENDIF + + ! get missing value from xml + CALL iom_miss_val( "icetemp", zmiss_val ) + + ! --- ice albedo --- ! + + CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) + + ! + SELECT CASE( ksbc ) !== fluxes over sea ice ==! + ! + CASE( jp_usr ) !--- user defined formulation + CALL usrdef_sbc_ice_flx( kt, h_s, h_i ) + CASE( jp_blk ) !--- bulk formulation + CALL blk_ice_flx ( t_su, h_s, h_i, alb_ice ) ! + IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) + IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) + ! ! compute conduction flux and surface temperature (as in Jules surface module) + IF( ln_cndflx .AND. .NOT.ln_cndemulate ) & + & CALL blk_ice_qcn ( ln_virtual_itd, t_su, t_bo, h_s, h_i ) + CASE ( jp_purecpl ) !--- coupled formulation + CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) + IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) + CASE ( jp_sglexe ) ! Single executable coupled + CALL sbc_sglcpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) + IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) + END SELECT + + !--- output ice albedo and surface albedo ---! + IF( iom_use('icealb') .OR. iom_use('albedo') .OR. & + & iom_use('icealbnm') .OR. iom_use('icealbmsk') ) THEN + + ALLOCATE( zalb(jpi,jpj), zmsk00(jpi,jpj) ) + + WHERE( at_i_b < 1.e-03 ) + zmsk00(:,:) = 0._wp + zalb (:,:) = rn_alb_oce + ELSEWHERE + zmsk00(:,:) = 1._wp + zalb (:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b + END WHERE + ! ice albedo + CALL iom_put( 'icealb' , zalb * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) + CALL iom_put( 'icealbnm' , zalb * zmsk00 ) + CALL iom_put( 'icealbmsk', zmsk00 ) + ! ice+ocean albedo + zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b ) + CALL iom_put( 'albedo' , zalb ) + + DEALLOCATE( zalb, zmsk00 ) + + ENDIF + ! + IF( ln_timing ) CALL timing_stop('icesbc') + ! + END SUBROUTINE ice_sbc_flx + + + SUBROUTINE ice_flx_dist( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_flxdist ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_flx_dist *** + !! + !! ** Purpose : update the ice surface boundary condition by averaging + !! and/or redistributing fluxes on ice categories + !! + !! ** Method : average then redistribute + !! + !! ** Action : depends on k_flxdist + !! = -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 + !!------------------------------------------------------------------- + INTEGER , INTENT(in ) :: k_flxdist ! redistributor + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: ptn_ice ! ice surface temperature + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: palb_ice ! ice albedo + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: pqns_ice ! non solar flux + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqsr_ice ! net solar flux + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pevap_ice ! sublimation + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdevap_ice ! sublimation sensitivity + ! + INTEGER :: jl ! dummy loop index + ! + REAL(wp), DIMENSION(jpi,jpj) :: z1_at_i ! inverse of concentration + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qsr_m ! Mean solar heat flux over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qns_m ! Mean non solar heat flux over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_evap_m ! Mean sublimation over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_dqn_m ! Mean d(qns)/dT over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_devap_m ! Mean d(evap)/dT over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zalb_m ! Mean albedo over all categories + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztem_m ! Mean temperature over all categories + !!---------------------------------------------------------------------- + ! + WHERE ( at_i (:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / at_i (:,:) + ELSEWHERE ; z1_at_i(:,:) = 0._wp + END WHERE + + SELECT CASE( k_flxdist ) !== averaged on all ice categories ==! + ! + CASE( 0 , 1 ) + ! + ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) ) + ! + z_qns_m (:,:) = SUM( a_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_qsr_m (:,:) = SUM( a_i(:,:,:) * pqsr_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_dqn_m (:,:) = SUM( a_i(:,:,:) * pdqn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_evap_m (:,:) = SUM( a_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_devap_m(:,:) = SUM( a_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) + DO jl = 1, jpl + pqns_ice (:,:,jl) = z_qns_m (:,:) + pqsr_ice (:,:,jl) = z_qsr_m (:,:) + pdqn_ice (:,:,jl) = z_dqn_m (:,:) + pevap_ice (:,:,jl) = z_evap_m(:,:) + pdevap_ice(:,:,jl) = z_devap_m(:,:) + END DO + ! + DEALLOCATE( z_qns_m, z_qsr_m, z_dqn_m, z_evap_m, z_devap_m ) + ! + END SELECT + ! + SELECT CASE( k_flxdist ) !== redistribution on all ice categories ==! + ! + CASE( 1 , 2 ) + ! + ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) ) + ! + zalb_m(:,:) = SUM( a_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) + ztem_m(:,:) = SUM( a_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + DO jl = 1, jpl + pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) + pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) + pqsr_ice (:,:,jl) = pqsr_ice (:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) ) + END DO + ! + DEALLOCATE( zalb_m, ztem_m ) + ! + END SELECT + ! + END SUBROUTINE ice_flx_dist + + + SUBROUTINE ice_sbc_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_sbc_init *** + !! + !! ** Purpose : Physical constants and parameters linked to the ice dynamics + !! + !! ** Method : Read the namsbc namelist and check the ice-dynamic + !! parameter values called at the first timestep (nit000) + !! + !! ** input : Namelist namsbc + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer + !! + NAMELIST/namsbc/ rn_cio, nn_snwfra, rn_snwblow, nn_flxdist, ln_cndflx, ln_cndemulate, nn_qtrice + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namsbc in reference namelist : Ice dynamics + READ ( numnam_ice_ref, namsbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namsbc in configuration namelist : Ice dynamics + READ ( numnam_ice_cfg, namsbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) + IF(lwm) WRITE( numoni, namsbc ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_sbc_init: ice parameters for ice dynamics/thermodynamics ' + WRITE(numout,*) '~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namsbc:' + WRITE(numout,*) ' drag coefficient for oceanic stress rn_cio = ', rn_cio + WRITE(numout,*) ' fraction of ice covered by snow (options 0,1,2) nn_snwfra = ', nn_snwfra + WRITE(numout,*) ' coefficient for ice-lead partition of snowfall rn_snwblow = ', rn_snwblow + WRITE(numout,*) ' Multicategory heat flux formulation nn_flxdist = ', nn_flxdist + WRITE(numout,*) ' Use conduction flux as surface condition ln_cndflx = ', ln_cndflx + WRITE(numout,*) ' emulate conduction flux ln_cndemulate = ', ln_cndemulate + WRITE(numout,*) ' solar flux transmitted thru the surface scattering layer nn_qtrice = ', nn_qtrice + WRITE(numout,*) ' = 0 Grenfell and Maykut 1977' + WRITE(numout,*) ' = 1 Lebrun 2019' + ENDIF + ! + IF(lwp) WRITE(numout,*) + SELECT CASE( nn_flxdist ) ! SI3 Multi-category heat flux formulation + CASE( -1 ) + IF(lwp) WRITE(numout,*) ' SI3: use per-category fluxes (nn_flxdist = -1) ' + CASE( 0 ) + IF(lwp) WRITE(numout,*) ' SI3: use average per-category fluxes (nn_flxdist = 0) ' + CASE( 1 ) + IF(lwp) WRITE(numout,*) ' SI3: use average then redistribute per-category fluxes (nn_flxdist = 1) ' + IF( ln_cpl ) CALL ctl_stop( 'ice_thd_init: the chosen nn_flxdist for SI3 in coupled mode must be /=1' ) + CASE( 2 ) + IF(lwp) WRITE(numout,*) ' SI3: Redistribute a single flux over categories (nn_flxdist = 2) ' + IF( .NOT. ln_cpl ) CALL ctl_stop( 'ice_thd_init: the chosen nn_flxdist for SI3 in forced mode must be /=2' ) + CASE DEFAULT + CALL ctl_stop( 'ice_thd_init: SI3 option, nn_flxdist, should be between -1 and 2' ) + END SELECT + ! + END SUBROUTINE ice_sbc_init + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icesbc \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icesbc.mod b/V4.0/nemo_sources/src/ICE/icesbc.mod new file mode 100644 index 0000000000000000000000000000000000000000..fb8a501716372090d233ab4dd9cf18b20ba00549 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icesbc.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icestp.F90 b/V4.0/nemo_sources/src/ICE/icestp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c722686d6bb3f054e533c42fbc9c42530c73fa43 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icestp.F90 @@ -0,0 +1,552 @@ +MODULE icestp + !!====================================================================== + !! *** MODULE icestp *** + !! sea ice : Master routine for all the sea ice model + !!===================================================================== + !! + !! The sea ice model SI3 (Sea Ice modelling Integrated Initiative), + !! aka Sea Ice cube for its nickname + !! + !! is originally based on LIM3, developed in Louvain-la-Neuve by: + !! * Martin Vancoppenolle (UCL-ASTR, Belgium) + !! * Sylvain Bouillon (UCL-ASTR, Belgium) + !! * Miguel Angel Morales Maqueda (NOC-L, UK) + !! thanks to valuable earlier work by + !! * Thierry Fichefet + !! * Hugues Goosse + !! thanks also to the following persons who contributed + !! * Gurvan Madec, Claude Talandier, Christian Ethe (LOCEAN, France) + !! * Xavier Fettweis (UCL-ASTR), Ralph Timmermann (AWI, Germany) + !! * Bill Lipscomb (LANL), Cecilia Bitz (UWa) and Elisabeth Hunke (LANL), USA. + !! + !! SI3 has been made possible by a handful of persons who met as working group + !! (from France, Belgium, UK and Italy) + !! * Clement Rousset, Martin Vancoppenolle & Gurvan Madec (LOCEAN, France) + !! * Matthieu Chevalier & David Salas (Meteo France, France) + !! * Gilles Garric (Mercator Ocean, France) + !! * Thierry Fichefet & Francois Massonnet (UCL, Belgium) + !! * Ed Blockley & Jeff Ridley (Met Office, UK) + !! * Danny Feltham & David Schroeder (CPOM, UK) + !! * Yevgeny Aksenov (NOC, UK) + !! * Paul Holland (BAS, UK) + !! * Dorotea Iovino (CMCC, Italy) + !!====================================================================== + !! History : 4.0 ! 2018 (C. Rousset) Original code SI3 + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_stp : sea-ice model time-stepping and update ocean SBC over ice-covered area + !! ice_init : initialize sea-ice + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE c1d ! 1D vertical configuration + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamical 1D variables + ! + USE phycst ! Define parameters for the routines + USE eosbn2 ! equation of state + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + ! + USE icesbc ! sea-ice: Surface boundary conditions + USE icedyn ! sea-ice: dynamics + USE icethd ! sea-ice: thermodynamics + USE icecor ! sea-ice: corrections + USE iceupdate ! sea-ice: sea surface boundary condition update + USE icedia ! sea-ice: budget diagnostics + USE icewri ! sea-ice: outputs + USE icerst ! sea-ice: restarts + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: control + USE iceistate ! sea-ice: initial state + USE iceitd ! sea-ice: remapping thickness distribution + USE icealb ! sea-ice: albedo + ! + USE bdy_oce , ONLY : ln_bdy ! flag for bdy + USE bdyice ! unstructured open boundary data for sea-ice +# if defined key_agrif + USE agrif_ice + USE agrif_ice_interp +# endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + USE prtctl ! Print control + use asminc + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_stp ! called by sbcmod.F90 + PUBLIC ice_init ! called by sbcmod.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icestp.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_stp( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ice_stp *** + !! + !! ** Purpose : sea-ice model time-stepping and update ocean surface + !! boundary condition over ice-covered area + !! + !! ** Method : ice model time stepping + !! - call the ice dynamics routine + !! - call the ice advection/diffusion routine + !! - call the ice thermodynamics routine + !! - call the routine that computes mass and + !! heat fluxes at the ice/ocean interface + !! - save the outputs + !! - save the outputs for restart when necessary + !! + !! ** Action : - time evolution of the LIM sea-ice model + !! - update all sbc variables below sea-ice: + !! utau, vtau, taum, wndm, qns , qsr, emp , sfx + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk, or Pure Coupled) + ! + INTEGER :: jl ! dummy loop index + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icestp') + ! + ! !-----------------------! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! --- Ice time step --- ! + ! !-----------------------! + ! + kt_ice = kt ! -- Ice model time step + ! + u_oce(:,:) = ssu_m(:,:) ! -- mean surface ocean current + v_oce(:,:) = ssv_m(:,:) + ! + CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) ! -- freezing temperature [Kelvin] (set to rt0 over land) + t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) + ! + ! !== AGRIF Parent to Child ==! +#if defined key_agrif + ! ! nbstep_ice ranges from 1 to the nb of child ocean steps inside one parent ice step + IF( .NOT. Agrif_Root() ) nbstep_ice = MOD( nbstep_ice, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) + 1 + ! ! these calls must remain here for restartability purposes + CALL agrif_interp_ice( 'T' ) + CALL agrif_interp_ice( 'U' ) + CALL agrif_interp_ice( 'V' ) +#endif + CALL store_fields ! Store now ice values + ! + !------------------------------------------------! + ! --- Dynamical coupling with the atmosphere --- ! + !------------------------------------------------! + ! It provides the following fields used in sea ice model: + ! utau_ice, vtau_ice = surface ice stress [N/m2] + !------------------------------------------------! + CALL ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice ) + !-------------------------------------! + ! --- ice dynamics and advection --- ! + !-------------------------------------! + CALL diag_set0 ! set diag of mass, heat and salt fluxes to 0 + CALL ice_rst_opn( kt ) ! Open Ice restart file (if necessary) + ! + IF( ln_icedyn .AND. .NOT.lk_c1d ) & + & CALL ice_dyn( kt ) ! -- Ice dynamics + ! + + IF ( ln_seaiceinc) THEN + CALL seaice_asm_inc( kt ) ! apply sea ice concentration increment + CALL ice_cor( kt , 2 ) ! -- Corrections + ENDIF + + CALL diag_trends( 1 ) ! record dyn trends + ! + ! !== lateral boundary conditions ==! + IF( ln_icethd .AND. ln_bdy ) CALL bdy_ice( kt ) ! -- bdy ice thermo + ! + ! !== previous lead fraction and ice volume for flux calculations + CALL ice_var_glo2eqv ! h_i and h_s for ice albedo calculation + CALL ice_var_agg(1) ! at_i for coupling + ! !== Optionally call ice_cor at nit000 or all steps + IF ( ( kt == nit000 .AND. nn_iceinicor == 1 ) .OR. ( nn_iceinicor == 2 ) ) THEN + IF(lwp) THEN + IF ( kt == nit000) THEN + WRITE(numout,*)'Calling ice_cor 1st time at kt = nit000' + ELSE + WRITE(numout,*)'Calling ice_cor 1st time at kt = ',kt + ENDIF + ENDIF + CALL ice_cor( kt, 0 ) + ENDIF + CALL store_fields ! Store now ice values + ! + !------------------------------------------------------! + ! --- Thermodynamical coupling with the atmosphere --- ! + !------------------------------------------------------! + ! It provides the following fields used in sea ice model: + ! emp_oce , emp_ice = E-P over ocean and sea ice [Kg/m2/s] + ! sprecip = solid precipitation [Kg/m2/s] + ! evap_ice = sublimation [Kg/m2/s] + ! qsr_tot , qns_tot = solar & non solar heat flux (total) [W/m2] + ! qsr_ice , qns_ice = solar & non solar heat flux over ice [W/m2] + ! dqns_ice = non solar heat sensistivity [W/m2] + ! qemp_oce, qemp_ice, = sensible heat (associated with evap & precip) [W/m2] + ! qprec_ice, qevap_ice + !------------------------------------------------------! + CALL ice_sbc_flx( kt, ksbc ) + !----------------------------! + ! --- ice thermodynamics --- ! + !----------------------------! + ! !== Optionally call ice_cor at nit000 or all steps + IF ( ( kt == nit000 .AND. nn_iceinicor == 1 ) .OR. ( nn_iceinicor == 2 ) ) THEN + IF(lwp) THEN + IF ( kt == nit000) THEN + WRITE(numout,*)'Calling ice_cor 2nd time at kt = nit000' + ELSE + WRITE(numout,*)'Calling ice_cor 2nd time at kt = ',kt + ENDIF + ENDIF + CALL ice_cor( kt, 0 ) + ENDIF + IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics + ! + CALL diag_trends( 2 ) ! record thermo trends + ! + CALL ice_var_glo2eqv ! necessary calls (at least for coupling) + CALL ice_var_agg( 2 ) ! necessary calls (at least for coupling) + ! + CALL ice_update_flx( kt ) ! -- Update ocean surface mass, heat and salt fluxes + ! + IF( ln_icediahsb ) CALL ice_dia( kt ) ! -- Diagnostics outputs + ! + IF( ln_icediachk ) CALL ice_drift_wri( kt ) ! -- Diagnostics outputs for conservation + ! + CALL ice_wri( kt ) ! -- Ice outputs + ! + IF( lrst_ice ) CALL ice_rst_write( kt ) ! -- Ice restart file + ! + IF( ln_icectl ) CALL ice_ctl( kt ) ! -- Control checks + ! + ENDIF ! End sea-ice time step only + + !-------------------------! + ! --- Ocean time step --- ! + !-------------------------! + CALL ice_update_tau( kt, ub(:,:,1), vb(:,:,1) ) ! -- update surface ocean stresses +!!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! + ! + IF( ln_timing ) CALL timing_stop('icestp') + ! + END SUBROUTINE ice_stp + + + SUBROUTINE ice_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ice_init *** + !! + !! ** purpose : Initialize sea-ice parameters + !!---------------------------------------------------------------------- + INTEGER :: jl, ierr + !!---------------------------------------------------------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'Sea Ice Model: SI3 (Sea Ice modelling Integrated Initiative)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_init: Arrays allocation & Initialization of all routines & init state' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + ! ! Open the reference and configuration namelist files and namelist output file + CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) + ! + CALL par_init ! set some ice run parameters + ! + ! ! Allocate the ice arrays (sbc_ice already allocated in sbc_init) + ierr = ice_alloc () ! ice variables + ierr = ierr + sbc_ice_alloc () ! surface boundary conditions + ierr = ierr + ice1D_alloc () ! thermodynamics + ! + CALL mpp_sum( 'icestp', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'ice_init : unable to allocate ice arrays') + ! + ! ! set max concentration in both hemispheres + WHERE( gphit(:,:) > 0._wp ) ; rn_amax_2d(:,:) = rn_amax_n ! NH + ELSEWHERE ; rn_amax_2d(:,:) = rn_amax_s ! SH + END WHERE + ! + CALL diag_set0 ! set diag of mass, heat and salt fluxes to 0: needed for Agrif child grids + ! + CALL ice_itd_init ! ice thickness distribution initialization + ! + CALL ice_thd_init ! set ice thermodynics parameters (clem: important to call it first for melt ponds) + ! + CALL ice_sbc_init ! set ice-ocean and ice-atm. coupling parameters + ! + CALL ice_istate_init ! Initial sea-ice state + IF ( ln_rstart .OR. nn_iceini_file == 2 ) THEN + CALL ice_rst_read ! start from a restart file + ELSE + CALL ice_istate( nit000 ) ! start from rest or read a file + ENDIF + CALL ice_var_glo2eqv + CALL ice_var_agg(1) + ! + CALL ice_dyn_init ! set ice dynamics parameters + ! + CALL ice_update_init ! ice surface boundary condition + ! + CALL ice_alb_init ! ice surface albedo + ! + CALL ice_dia_init ! initialization for diags + ! + CALL ice_drift_init ! initialization for diags of conservation + ! + fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction + tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu + ! + IF( ln_rstart ) CALL iom_close( numrir ) ! close input ice restart file + ! + END SUBROUTINE ice_init + + + SUBROUTINE par_init + !!------------------------------------------------------------------- + !! *** ROUTINE par_init *** + !! + !! ** Purpose : Definition generic parameters for ice model + !! + !! ** Method : Read namelist and check the parameter + !! values called at the first timestep (nit000) + !! + !! ** input : Namelist nampar + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/nampar/ jpl, nlay_i, nlay_s, ln_virtual_itd, ln_icedyn, ln_icethd, rn_amax_n, rn_amax_s, & + & cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist nampar in reference namelist : Parameters for ice + READ ( numnam_ice_ref, nampar, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampar in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist nampar in configuration namelist : Parameters for ice + READ ( numnam_ice_cfg, nampar, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampar in configuration namelist' ) + IF(lwm) WRITE( numoni, nampar ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' par_init: ice parameters shared among all the routines' + WRITE(numout,*) ' ~~~~~~~~' + WRITE(numout,*) ' Namelist nampar: ' + WRITE(numout,*) ' number of ice categories jpl = ', jpl + WRITE(numout,*) ' number of ice layers nlay_i = ', nlay_i + WRITE(numout,*) ' number of snow layers nlay_s = ', nlay_s + WRITE(numout,*) ' virtual ITD param for jpl=1 (T) or not (F) ln_virtual_itd = ', ln_virtual_itd + WRITE(numout,*) ' Ice dynamics (T) or not (F) ln_icedyn = ', ln_icedyn + WRITE(numout,*) ' Ice thermodynamics (T) or not (F) ln_icethd = ', ln_icethd + WRITE(numout,*) ' maximum ice concentration for NH = ', rn_amax_n + WRITE(numout,*) ' maximum ice concentration for SH = ', rn_amax_s + ENDIF + ! !--- change max ice concentration for roundoff errors + rn_amax_n = MIN( rn_amax_n, 1._wp - epsi10 ) + rn_amax_s = MIN( rn_amax_s, 1._wp - epsi10 ) + ! !--- check consistency + IF ( jpl > 1 .AND. ln_virtual_itd ) THEN + ln_virtual_itd = .FALSE. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ln_virtual_itd forced to false as jpl>1, no need with multiple categories to emulate them' + ENDIF + ! + IF(ln_sglexe) nn_cats_cpl=jpl + IF( ln_cpl .AND. nn_cats_cpl /= 1 .AND. nn_cats_cpl /= jpl ) THEN + CALL ctl_stop( 'STOP', 'par_init: in coupled mode, nn_cats_cpl should be either 1 or jpl' ) + ENDIF + ! + rdt_ice = REAL(nn_fsbc) * rdt !--- sea-ice timestep and its inverse + r1_rdtice = 1._wp / rdt_ice + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ice timestep rdt_ice = nn_fsbc*rdt = ', rdt_ice + ! + r1_nlay_i = 1._wp / REAL( nlay_i, wp ) !--- inverse of nlay_i and nlay_s + r1_nlay_s = 1._wp / REAL( nlay_s, wp ) + ! + END SUBROUTINE par_init + + + SUBROUTINE store_fields + !!---------------------------------------------------------------------- + !! *** ROUTINE store_fields *** + !! + !! ** purpose : store ice variables at "before" time step + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl ! dummy loop index + !!---------------------------------------------------------------------- + ! + a_i_b (:,:,:) = a_i (:,:,:) ! ice area + v_i_b (:,:,:) = v_i (:,:,:) ! ice volume + v_s_b (:,:,:) = v_s (:,:,:) ! snow volume + v_ip_b(:,:,:) = v_ip(:,:,:) ! pond volume + v_il_b(:,:,:) = v_il(:,:,:) ! pond lid volume + sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content + e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy + e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy + WHERE( a_i_b(:,:,:) >= epsi20 ) + h_i_b(:,:,:) = v_i_b(:,:,:) / a_i_b(:,:,:) ! ice thickness + h_s_b(:,:,:) = v_s_b(:,:,:) / a_i_b(:,:,:) ! snw thickness + ELSEWHERE + h_i_b(:,:,:) = 0._wp + h_s_b(:,:,:) = 0._wp + END WHERE + ! + ! ice velocities & total concentration + at_i_b(:,:) = SUM( a_i_b(:,:,:), dim=3 ) + u_ice_b(:,:) = u_ice(:,:) + v_ice_b(:,:) = v_ice(:,:) + ! + END SUBROUTINE store_fields + + + SUBROUTINE diag_set0 + !!---------------------------------------------------------------------- + !! *** ROUTINE diag_set0 *** + !! + !! ** purpose : set ice-ocean and ice-atm. fluxes to zeros at the beggining + !! of the time step + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl ! dummy loop index + !!---------------------------------------------------------------------- + + DO jj = 1, jpj + DO ji = 1, jpi + sfx (ji,jj) = 0._wp ; + sfx_bri(ji,jj) = 0._wp ; sfx_lam(ji,jj) = 0._wp + sfx_sni(ji,jj) = 0._wp ; sfx_opw(ji,jj) = 0._wp + sfx_bog(ji,jj) = 0._wp ; sfx_dyn(ji,jj) = 0._wp + sfx_bom(ji,jj) = 0._wp ; sfx_sum(ji,jj) = 0._wp + sfx_res(ji,jj) = 0._wp ; sfx_sub(ji,jj) = 0._wp + ! + wfx_snw(ji,jj) = 0._wp ; wfx_ice(ji,jj) = 0._wp + wfx_sni(ji,jj) = 0._wp ; wfx_opw(ji,jj) = 0._wp + wfx_bog(ji,jj) = 0._wp ; wfx_dyn(ji,jj) = 0._wp + wfx_bom(ji,jj) = 0._wp ; wfx_sum(ji,jj) = 0._wp + wfx_res(ji,jj) = 0._wp ; wfx_sub(ji,jj) = 0._wp + wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp + wfx_snw_dyn(ji,jj) = 0._wp ; wfx_snw_sum(ji,jj) = 0._wp + wfx_snw_sub(ji,jj) = 0._wp ; wfx_ice_sub(ji,jj) = 0._wp + wfx_snw_sni(ji,jj) = 0._wp + wfx_pnd(ji,jj) = 0._wp + + hfx_thd(ji,jj) = 0._wp ; + hfx_snw(ji,jj) = 0._wp ; hfx_opw(ji,jj) = 0._wp + hfx_bog(ji,jj) = 0._wp ; hfx_dyn(ji,jj) = 0._wp + hfx_bom(ji,jj) = 0._wp ; hfx_sum(ji,jj) = 0._wp + hfx_res(ji,jj) = 0._wp ; hfx_sub(ji,jj) = 0._wp + hfx_spr(ji,jj) = 0._wp ; hfx_dif(ji,jj) = 0._wp + hfx_err_dif(ji,jj) = 0._wp + wfx_err_sub(ji,jj) = 0._wp + ! + diag_heat(ji,jj) = 0._wp ; diag_sice(ji,jj) = 0._wp + diag_vice(ji,jj) = 0._wp ; diag_vsnw(ji,jj) = 0._wp + diag_aice(ji,jj) = 0._wp ; diag_vpnd(ji,jj) = 0._wp + + tau_icebfr (ji,jj) = 0._wp ! landfast ice param only (clem: important to keep the init here) + qsb_ice_bot(ji,jj) = 0._wp ! (needed if ln_icethd=F) + + fhld(ji,jj) = 0._wp ! needed if ln_icethd=F + + ! for control checks (ln_icediachk) + diag_trp_vi(ji,jj) = 0._wp ; diag_trp_vs(ji,jj) = 0._wp + diag_trp_ei(ji,jj) = 0._wp ; diag_trp_es(ji,jj) = 0._wp + diag_trp_sv(ji,jj) = 0._wp + ! + diag_adv_mass(ji,jj) = 0._wp + diag_adv_salt(ji,jj) = 0._wp + diag_adv_heat(ji,jj) = 0._wp + END DO + END DO + + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + ! SIMIP diagnostics + t_si (ji,jj,jl) = rt0 ! temp at the ice-snow interface + qcn_ice_bot(ji,jj,jl) = 0._wp + qcn_ice_top(ji,jj,jl) = 0._wp ! conductive fluxes + cnd_ice (ji,jj,jl) = 0._wp ! effective conductivity at the top of ice/snow (ln_cndflx=T) + qcn_ice (ji,jj,jl) = 0._wp ! conductive flux (ln_cndflx=T & ln_cndemule=T) + qtr_ice_bot(ji,jj,jl) = 0._wp ! part of solar radiation transmitted through the ice needed at least for outputs + END DO + END DO + END DO + + END SUBROUTINE diag_set0 + + + SUBROUTINE diag_trends( kn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE diag_trends *** + !! + !! ** purpose : diagnostics of the trends. Used for conservation purposes + !! and outputs + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kn ! 1 = after dyn ; 2 = after thermo + !!---------------------------------------------------------------------- + ! + ! --- trends of heat, salt, mass (used for conservation controls) + IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN + ! + diag_heat(:,:) = diag_heat(:,:) & + & - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_rdtice & + & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_rdtice + diag_sice(:,:) = diag_sice(:,:) & + & + SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_rdtice * rhoi + diag_vice(:,:) = diag_vice(:,:) & + & + SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_rdtice * rhoi + diag_vsnw(:,:) = diag_vsnw(:,:) & + & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_rdtice * rhos + diag_vpnd(:,:) = diag_vpnd(:,:) & + & + SUM( v_ip + v_il - v_ip_b - v_il_b , dim=3 ) * r1_rdtice * rhow + ! + IF( kn == 2 ) CALL iom_put ( 'hfxdhc' , diag_heat ) ! output of heat trend + ! + ENDIF + ! + ! --- trends of concentration (used for simip outputs) + IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN + ! + diag_aice(:,:) = diag_aice(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice + ! + IF( kn == 1 ) CALL iom_put( 'afxdyn' , diag_aice ) ! dyn trend + IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice ) ! thermo trend + IF( kn == 2 ) CALL iom_put( 'afxtot' , diag_aice ) ! total trend + ! + ENDIF + ! + END SUBROUTINE diag_trends + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE ice_stp ( kt, ksbc ) ! Dummy routine + INTEGER, INTENT(in) :: kt, ksbc + WRITE(*,*) 'ice_stp: You should not have seen this print! error?', kt + END SUBROUTINE ice_stp + SUBROUTINE ice_init ! Dummy routine + END SUBROUTINE ice_init +#endif + + !!====================================================================== +END MODULE icestp \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icestp.mod b/V4.0/nemo_sources/src/ICE/icestp.mod new file mode 100644 index 0000000000000000000000000000000000000000..6169a359e51e360e66f5857fb2e1a36696183507 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icestp.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icetab.F90 b/V4.0/nemo_sources/src/ICE/icetab.F90 new file mode 100644 index 0000000000000000000000000000000000000000..11527f0b851bfc7cba909e13177662316782338b --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icetab.F90 @@ -0,0 +1,121 @@ +MODULE icetab + !!====================================================================== + !! *** MODULE icetab *** + !! sea-ice : transform 1D (2D) array to a 2D (1D) table + !!====================================================================== + !! History : 4.0 ! 2018 (C. Rousset) Original code SI3 + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! tab_3d_2d : 3-D <==> 2-D + !! tab_2d_3d : 2-D <==> 3-D + !! tab_2d_1d : 2-D <==> 1-D + !! tab_1d_2d : 1-D <==> 2-D + !!---------------------------------------------------------------------- + USE par_oce + USE ice, ONLY : jpl + + IMPLICIT NONE + PRIVATE + + PUBLIC tab_3d_2d + PUBLIC tab_2d_1d + PUBLIC tab_2d_3d + PUBLIC tab_1d_2d + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icetab.F90 13714 2020-11-02 15:59:55Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tab_3d_2d( ndim1d, tab_ind, tab1d, tab2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tab_2d_1d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ndim1d ! 1d size + INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index + REAL(dp), DIMENSION(jpi,jpj,jpl), INTENT(in ) :: tab2d ! input 2D field + REAL(dp), DIMENSION(ndim1d,jpl) , INTENT(inout) :: tab1d ! output 1D field + ! + INTEGER :: jl, jn, jid, jjd + !!---------------------------------------------------------------------- + DO jl = 1, jpl + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab1d(jn,jl) = tab2d(jid,jjd,jl) + END DO + END DO + END SUBROUTINE tab_3d_2d + + + SUBROUTINE tab_2d_1d( ndim1d, tab_ind, tab1d, tab2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tab_2d_1d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ndim1d ! 1d size + INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: tab2d ! input 2D field + REAL(dp), DIMENSION(ndim1d) , INTENT(inout) :: tab1d ! output 1D field + ! + INTEGER :: jn , jid, jjd + !!---------------------------------------------------------------------- + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab1d( jn) = tab2d( jid, jjd) + END DO + END SUBROUTINE tab_2d_1d + + + SUBROUTINE tab_2d_3d( ndim1d, tab_ind, tab1d, tab2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tab_2d_1d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ndim1d ! 1D size + INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index + REAL(dp), DIMENSION(ndim1d,jpl) , INTENT(in ) :: tab1d ! input 1D field + REAL(dp), DIMENSION(jpi,jpj,jpl), INTENT(inout) :: tab2d ! output 2D field + ! + INTEGER :: jl, jn, jid, jjd + !!---------------------------------------------------------------------- + DO jl = 1, jpl + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab2d(jid,jjd,jl) = tab1d(jn,jl) + END DO + END DO + END SUBROUTINE tab_2d_3d + + + SUBROUTINE tab_1d_2d( ndim1d, tab_ind, tab1d, tab2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tab_2d_1d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ndim1d ! 1D size + INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index + REAL(dp), DIMENSION(ndim1d) , INTENT(in ) :: tab1d ! input 1D field + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: tab2d ! output 2D field + ! + INTEGER :: jn , jid, jjd + !!---------------------------------------------------------------------- + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab2d(jid, jjd) = tab1d( jn) + END DO + END SUBROUTINE tab_1d_2d + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icetab \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd.F90 b/V4.0/nemo_sources/src/ICE/icethd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3c21d9d58fabf41816e9ada523257c476b75ced4 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd.F90 @@ -0,0 +1,747 @@ +MODULE icethd + !!====================================================================== + !! *** MODULE icethd *** + !! sea-ice : master routine for thermodynamics + !!====================================================================== + !! History : 1.0 ! 2000-01 (M.A. Morales Maqueda, H. Goosse, T. Fichefet) original code 1D + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd : thermodynamics of sea ice + !! ice_thd_init : initialisation of sea-ice thermodynamics + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain variables + USE ice ! sea-ice: variables +!!gm list trop longue ==>>> why not passage en argument d'appel ? + USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, sprecip, ln_cpl + USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, & + & qml_ice, qcn_ice, qtr_ice_top + USE ice1D ! sea-ice: thermodynamics variables + USE icethd_zdf ! sea-ice: vertical heat diffusion + USE icethd_dh ! sea-ice: ice-snow growth and melt + USE icethd_da ! sea-ice: lateral melting + USE icethd_sal ! sea-ice: salinity + USE icethd_ent ! sea-ice: enthalpy redistribution + USE icethd_do ! sea-ice: growth in open water + USE icethd_pnd ! sea-ice: melt ponds + USE iceitd ! sea-ice: remapping thickness distribution + USE icecor ! sea-ice: corrections + USE icetab ! sea-ice: 1D <==> 2D transformation + USE icevar ! sea-ice: operations + USE icectl ! sea-ice: control print + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd ! called by limstp module + PUBLIC ice_thd_init ! called by ice_init + PUBLIC ice_thd_temp_2d ! called by asminc%seaice_asm_inc + + !!** namelist (namthd) ** + LOGICAL :: ln_icedH ! activate ice thickness change from growing/melting (T) or not (F) + LOGICAL :: ln_icedA ! activate lateral melting param. (T) or not (F) + LOGICAL :: ln_icedO ! activate ice growth in open-water (T) or not (F) + LOGICAL :: ln_icedS ! activate gravity drainage and flushing (T) or not (F) + LOGICAL :: ln_leadhfx ! heat in the leads is used to melt sea-ice before warming the ocean + + !! for convergence tests + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztice_cvgerr, ztice_cvgstp + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd *** + !! + !! ** Purpose : This routine manages ice thermodynamics + !! + !! ** Action : - computation of oceanic sensible heat flux at the ice base + !! energy budget in the leads + !! net fluxes on top of ice and of ocean + !! - selection of grid cells with ice + !! - call ice_thd_zdf for vertical heat diffusion + !! - call ice_thd_dh for vertical ice growth and melt + !! - call ice_thd_pnd for melt ponds + !! - call ice_thd_ent for enthalpy remapping + !! - call ice_thd_sal for ice desalination + !! - call ice_thd_temp to retrieve temperature from ice enthalpy + !! - call ice_thd_mono for extra lateral ice melt if active virtual thickness distribution + !! - call ice_thd_da for lateral ice melt + !! - back to the geographic grid + !! - call ice_thd_rem for remapping thickness distribution + !! - call ice_thd_do for ice growth in leads + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: jj1, jj2 ! OpenMP loop index (grid points) + INTEGER :: ji1, ji2, jpti ! OpenMP loop index (1d points) + INTEGER :: itid, ithreads ! OpenMP environment + REAL(wp) :: zqfr_neg, zqfr_pos + REAL(dp) :: zfric_u, zqld, zqfr + REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04) + REAL(dp) :: zch ! heat transfer coefficient + REAL(wp), DIMENSION(jpi,jpj) :: zvel! ice-ocean velocity (m/s) and frictional velocity (m2/s2) + REAL(dp), DIMENSION(jpi,jpj) :: zu_io, zv_io, zfric! ice-ocean velocity (m/s) and frictional velocity (m2/s2) + REAL(wp) :: zswitch + ! + !!------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('icethd') ! timing +!SARAH 1 degtesting + zch = rn_oiht +!SARAH + IF( ln_icediachk ) THEN + CALL ice_cons_hsm(0, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation + CALL ice_cons2D (0, 'icethd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation + ENDIF + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'ice_thd: sea-ice thermodynamics' + WRITE(numout,*) 'Using ocean-ice heat transfer coefficent:', zch + WRITE(numout,*) '~~~~~~~' + ENDIF + + ! convergence tests + IF( ln_zdf_chkcvg ) THEN + ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) ) + ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp + ENDIF + + !$omp parallel private(ji,jj1,jj2,itid,ithreads, & + !$omp& ji1,ji2,jpti,zfric_u,zqld,zqfr,zqfr_neg,zqfr_pos,zswitch) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + IF( ln_timing_detail ) THEN + !$omp barrier + !$omp master + CALL timing_start('ice_thd_main') + !$omp end master + !$omp barrier + ENDIF + ! + !---------------------------------------------! + ! computation of friction velocity at T points + !---------------------------------------------! + IF( ln_icedyn ) THEN + zu_io(:,jj1:jj2) = u_ice(:,jj1:jj2) - ssu_m(:,jj1:jj2) + zv_io(:,jj1:jj2) = v_ice(:,jj1:jj2) - ssv_m(:,jj1:jj2) + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zfric(ji,jj) = rn_cio * ( 0.5_wp * & + & ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) & + & + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) + zvel(ji,jj) = 0.5_wp * SQRT( ( u_ice(ji-1,jj) + u_ice(ji,jj) ) * ( u_ice(ji-1,jj) + u_ice(ji,jj) ) + & + & ( v_ice(ji,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji,jj-1) + v_ice(ji,jj) ) ) + END DO + END DO + ELSE ! if no ice dynamics => transfer directly the atmospheric stress to the ocean + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp * & + & ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) & + & + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) + zvel(ji,jj) = 0._wp + END DO + END DO + ENDIF + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'icethd', zvel, 'T', 1.0_wp ) + CALL lbc_lnk_multi( 'icethd', zfric, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + !--------------------------------------------------------------------! + ! Partial computation of forcing for the thermodynamic sea ice model + !--------------------------------------------------------------------! + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice + ! + ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! + zqld = tmask(ji,jj,1) * rdt_ice * & + & ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + & + & ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) + + ! --- Energy needed to bring ocean surface layer until its freezing, zqfr is defined everywhere (J.m-2) --- ! + ! (mostly<0 but >0 if supercooling) + zqfr = rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) + zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 + zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0 + + ! --- Sensible ocean-to-ice heat flux (W/m2) --- ! + ! (mostly>0 but <0 if supercooling) + zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin ) + qsb_ice_bot(ji,jj) = zswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) + + ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach + ! the freezing point, so that we do not have SST < T_freeze + ! This implies: qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice <= - zqfr_neg + ! The following formulation is ok for both normal conditions and supercooling + qsb_ice_bot(ji,jj) = zswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) + + ! If conditions are always supercooled (such as at the mouth of ice-shelves), then ice grows continuously + ! ==> stop ice formation by artificially setting up the turbulent fluxes to 0 when volume > 20m (arbitrary) + IF( ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) > 0._wp .AND. vt_i(ji,jj) >= 20._wp ) THEN + zqfr = 0._wp + zqfr_pos = 0._wp + qsb_ice_bot(ji,jj) = 0._wp + ENDIF + ! + ! --- Energy Budget of the leads (qlead, J.m-2) --- ! + ! qlead is the energy received from the atm. in the leads. + ! If warming (zqld >= 0), then the energy in the leads is used to melt ice (bottom melting) => fhld (W/m2) + ! If cooling (zqld < 0), then the energy in the leads is used to grow ice in open water => qlead (J.m-2) + IF( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN + ! upper bound for fhld: fhld should be equal to zqld + ! but we have to make sure that this heat will not make the sst drop below the freezing point + ! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr_pos + ! The following formulation is ok for both normal conditions and supercooling + fhld (ji,jj) = zswitch * MAX( 0._wp, ( zqld - zqfr_pos ) * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) & ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 + & - qsb_ice_bot(ji,jj) ) + qlead(ji,jj) = 0._wp + ELSE + fhld (ji,jj) = 0._wp + ! upper bound for qlead: qlead should be equal to zqld + ! but before using this heat for ice formation, we suppose that the ocean cools down till the freezing point. + ! The energy for this cooling down is zqfr. Also some heat will be removed from the ocean from turbulent fluxes (qsb) + ! and freezing point is reached if zqfr = zqld - qsb*a/dt + ! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr + ! The following formulation is ok for both normal conditions and supercooling + qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) + ENDIF + ! + ! If ice is landfast and ice concentration reaches its max + ! => stop ice formation in open water + IF( zvel(ji,jj) <= 5.e-04_wp .AND. at_i(ji,jj) >= rn_amax_2d(ji,jj)-epsi06 ) qlead(ji,jj) = 0._wp + ! + ! If the grid cell is almost fully covered by ice (no leads) + ! => stop ice formation in open water + IF( at_i(ji,jj) >= (1._wp - epsi10) ) qlead(ji,jj) = 0._wp + ! + ! If ln_leadhfx is false + ! => do not use energy of the leads to melt sea-ice + IF( .NOT.ln_leadhfx ) fhld(ji,jj) = 0._wp + ! + END DO + END DO + + ! In case we bypass open-water ice formation + IF( .NOT. ln_icedO ) qlead(:,jj1:jj2) = 0._wp + ! In case we bypass growing/melting from top and bottom + IF( .NOT. ln_icedH ) THEN + qsb_ice_bot(:,jj1:jj2) = 0._wp + fhld (:,jj1:jj2) = 0._wp + ENDIF + + IF( ln_timing_detail ) THEN + !$omp barrier + !$omp master + CALL timing_stop('ice_thd_main') + !$omp end master + !$omp barrier + ENDIF + !$omp barrier + + !-------------------------------------------------------------------------------------------! + ! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories + !-------------------------------------------------------------------------------------------! + + IF( ln_timing_detail ) THEN + !$omp barrier + !$omp master + CALL timing_start('ice_thd_jllopp') + !$omp end master + !$omp barrier + ENDIF + + DO jl = 1, jpl + ! select ice covered grid points + !$omp barrier + !$omp master + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( a_i(ji,jj,jl) > epsi10 ) THEN + npti = npti + 1 + nptidx(npti) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + !$omp end master + !$omp barrier + + ! Split npti loops for openmp parallelism + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + + IF( npti > 0 ) THEN ! If there is no ice, do nothing. + ! + CALL ice_thd_1d2d( itid, ji1, ji2, jpti, jl, 1 ) ! --- Move to 1D arrays --- ! + ! ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- ! + ! + s_i_new (ji1:ji2) = 0._wp ; dh_s_tot(ji1:ji2) = 0._wp ! --- some init --- ! (important to have them here) + dh_i_sum (ji1:ji2) = 0._wp ; dh_i_bom(ji1:ji2) = 0._wp ; dh_i_itm (ji1:ji2) = 0._wp + dh_i_sub (ji1:ji2) = 0._wp ; dh_i_bog(ji1:ji2) = 0._wp + dh_snowice(ji1:ji2) = 0._wp ; dh_s_mlt(ji1:ji2) = 0._wp + ! + CALL ice_thd_zdf( itid, ji1, ji2, jpti ) ! --- Ice-Snow temperature --- ! + ! + IF( ln_icedH ) THEN ! --- Growing/Melting --- ! + CALL ice_thd_dh( itid, ji1, ji2, jpti ) ! Ice-Snow thickness + CALL ice_thd_ent( itid, ji1, ji2, jpti, e_i_1d, .TRUE. ) ! Ice enthalpy remapping + ENDIF + CALL ice_thd_sal( itid, ji1, ji2, jpti, ln_icedS ) ! --- Ice salinity --- ! + ! + CALL ice_thd_temp( itid, ji1, ji2, jpti ) ! --- Temperature update --- ! + ! + IF( ln_icedH .AND. ln_virtual_itd ) & + & CALL ice_thd_mono( itid, ji1, ji2, jpti ) ! --- Extra lateral melting if virtual_itd --- ! + ! + IF( ln_icedA ) CALL ice_thd_da( itid, ji1, ji2, jpti ) ! --- Lateral melting --- ! + ! + IF( ln_pnd .AND. ln_icedH ) & + & CALL ice_thd_pnd( itid, ji1, ji2, jpti ) ! --- Melt ponds formation --- ! + ! + CALL ice_thd_1d2d( itid, ji1, ji2, jpti, jl, 2 ) ! --- Change units of e_i, e_s from J/m3 to J/m2 --- ! + ! ! --- & Move to 2D arrays --- ! + ENDIF + ! + END DO + ! + IF( ln_timing_detail ) THEN + !$omp barrier + !$omp master + CALL timing_stop('ice_thd_jllopp') + !$omp end master + !$omp barrier + ENDIF + ! + !$omp end parallel + ! + IF( ln_icediachk ) THEN + CALL ice_cons_hsm(1, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + CALL ice_cons2D (1, 'icethd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + ENDIF + ! + IF( jpl > 1 ) CALL ice_itd_rem( kt ) ! --- Transport ice between thickness categories --- ! + ! + IF( ln_icedO ) CALL ice_thd_do ! --- Frazil ice growth in leads --- ! + ! + CALL ice_cor( kt , 2 ) ! --- Corrections --- ! + ! + oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rdt_ice ! ice natural aging incrementation + ! + ! convergence tests + IF( ln_zdf_chkcvg ) THEN + CALL iom_put( 'tice_cvgerr', ztice_cvgerr ) ; DEALLOCATE( ztice_cvgerr ) + CALL iom_put( 'tice_cvgstp', ztice_cvgstp ) ; DEALLOCATE( ztice_cvgstp ) + ENDIF + ! + ! controls + IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ') ! prints + IF( ln_ctl ) CALL ice_prt3D ('icethd') ! prints + IF( ln_timing ) CALL timing_stop('icethd') ! timing + ! + END SUBROUTINE ice_thd + + SUBROUTINE ice_thd_temp_2d( ) + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_temp_2d *** + !! + !! ** Purpose : Computes sea ice temperature (Kelvin) from enthalpy + !! + !! ** Method : Formula (Bitz and Lipscomb, 1999) + !!------------------------------------------------------------------- + + INTEGER :: jk ! dummy loop indices + REAL(wp), dimension (jpi,jpj,jpl) :: ztmelts, zbbb, zccc + + !!------------------------------------------------------------------- + ! + ! Recover ice temperature + + DO jk = 1, nlay_i + ztmelts = -rTmlt * sz_i(:,:,jk,:) + zbbb = (rcp - rcpi) * ztmelts + e_i(:,:,jk,:) * r1_rhoi - rLfus + zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp ) ) + t_i(:,:,jk,:) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_rcpi + + where (h_i > 0.0_wp) + t_i(:,:,jk,:) = t_i(:,:,jk,:) + elsewhere + t_i(:,:,jk,:) = rt0 + end where + END DO + + END SUBROUTINE ice_thd_temp_2d + + + SUBROUTINE ice_thd_temp( ktid, ki1, ki2, kpti ) + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_temp *** + !! + !! ** Purpose : Computes sea ice temperature (Kelvin) from enthalpy + !! + !! ** Method : Formula (Bitz and Lipscomb, 1999) + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER :: ji, jk ! dummy loop indices + REAL(wp) :: ztmelts, zbbb, zccc, zswitch ! local scalar + !!------------------------------------------------------------------- + ! + ! Recover ice temperature + DO jk = 1, nlay_i + DO ji = ki1, ki2 + ztmelts = -rTmlt * sz_i_1d(ji,jk) + ! Conversion q(S,T) -> T (second order equation) + zbbb = ( rcp - rcpi ) * ztmelts + e_i_1d(ji,jk) * r1_rhoi - rLfus + zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp ) ) + t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_rcpi + + ! mask temperature + zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) ) + t_i_1d(ji,jk) = zswitch * t_i_1d(ji,jk) + ( 1._wp - zswitch ) * rt0 + END DO + END DO + ! + END SUBROUTINE ice_thd_temp + + + SUBROUTINE ice_thd_mono( ktid, ki1, ki2, kpti ) + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_mono *** + !! + !! ** Purpose : Lateral melting in case virtual_itd + !! ( dA = A/2h dh ) + !!----------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER :: ji ! dummy loop indices + REAL(wp) :: zhi_bef ! ice thickness before thermo + REAL(wp) :: zdh_mel, zda_mel ! net melting + REAL(wp) :: zvi, zvs ! ice/snow volumes + real(wp) :: zswitch + !!----------------------------------------------------------------------- + ! + DO ji = ki1, ki2 + zdh_mel = MIN( 0._wp, dh_i_itm(ji) + dh_i_sum(ji) + dh_i_bom(ji) + dh_snowice(ji) + dh_i_sub(ji) ) + IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN + zvi = a_i_1d(ji) * h_i_1d(ji) + zvs = a_i_1d(ji) * h_s_1d(ji) + ! lateral melting = concentration change + zhi_bef = h_i_1d(ji) - zdh_mel + zswitch = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) ) + zda_mel = zswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) + a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel ) + ! adjust thickness + h_i_1d(ji) = zvi / a_i_1d(ji) + h_s_1d(ji) = zvs / a_i_1d(ji) + ! retrieve total concentration + at_i_1d(ji) = a_i_1d(ji) + END IF + END DO + ! + END SUBROUTINE ice_thd_mono + + + SUBROUTINE ice_thd_1d2d( ktid, ki1, ki2, kpti, kl, kn ) + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_1d2d *** + !! + !! ** Purpose : move arrays from 1d to 2d and the reverse + !!----------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid ! thread number + INTEGER, INTENT(in) :: ki1 ! start index + INTEGER, INTENT(in) :: ki2 ! end index + INTEGER, INTENT(in) :: kpti ! chunk size + INTEGER, INTENT(in) :: kl ! index of the ice category + INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D + ! + INTEGER :: jk ! dummy loop indices + !!----------------------------------------------------------------------- + ! + + SELECT CASE( kn ) + ! !---------------------! + CASE( 1 ) !== from 2D to 1D ==! + ! !---------------------! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), at_i_1d(ki1:ki2), at_i ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), a_i_1d (ki1:ki2), a_i (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), h_i_1d (ki1:ki2), h_i (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), h_s_1d (ki1:ki2), h_s (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), t_su_1d(ki1:ki2), t_su(:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), s_i_1d (ki1:ki2), s_i (:,:,kl) ) + DO jk = 1, nlay_s + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), t_s_1d(ki1:ki2,jk), t_s(:,:,jk,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), e_s_1d(ki1:ki2,jk), e_s(:,:,jk,kl) ) + END DO + DO jk = 1, nlay_i + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), t_i_1d (ki1:ki2,jk), t_i (:,:,jk,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), e_i_1d (ki1:ki2,jk), e_i (:,:,jk,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sz_i_1d(ki1:ki2,jk), sz_i(:,:,jk,kl) ) + END DO + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), a_ip_1d (ki1:ki2), a_ip (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), h_ip_1d (ki1:ki2), h_ip (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), h_il_1d (ki1:ki2), h_il (:,:,kl) ) + ! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qprec_ice_1d (ki1:ki2), CASTDP(qprec_ice) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qsr_ice_1d (ki1:ki2), CASTDP(qsr_ice (:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qns_ice_1d (ki1:ki2), qns_ice (:,:,kl) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), evap_ice_1d (ki1:ki2), CASTDP(evap_ice(:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), dqns_ice_1d (ki1:ki2), CASTDP(dqns_ice(:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), t_bo_1d (ki1:ki2), CASTDP(t_bo ) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sprecip_1d (ki1:ki2), CASTDP(sprecip ) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qsb_ice_bot_1d(ki1:ki2), CASTDP(qsb_ice_bot ) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), fhld_1d (ki1:ki2), CASTDP(fhld ) ) + + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qml_ice_1d (ki1:ki2), CASTDP(qml_ice (:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qcn_ice_1d (ki1:ki2), CASTDP(qcn_ice (:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), qtr_ice_top_1d(ki1:ki2), CASTDP(qtr_ice_top(:,:,kl)) ) + ! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_snw_sni_1d(ki1:ki2), wfx_snw_sni ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_snw_sum_1d(ki1:ki2), wfx_snw_sum ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_sub_1d (ki1:ki2), wfx_sub ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_snw_sub_1d(ki1:ki2), wfx_snw_sub ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_ice_sub_1d(ki1:ki2), wfx_ice_sub ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_err_sub_1d(ki1:ki2), wfx_err_sub ) + ! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_bog_1d (ki1:ki2), wfx_bog ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_bom_1d (ki1:ki2), wfx_bom ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_sum_1d (ki1:ki2), wfx_sum ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_sni_1d (ki1:ki2), wfx_sni ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_res_1d (ki1:ki2), wfx_res ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_spr_1d (ki1:ki2), wfx_spr ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_lam_1d (ki1:ki2), wfx_lam ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), wfx_pnd_1d (ki1:ki2), wfx_pnd ) + ! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_bog_1d (ki1:ki2), sfx_bog ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_bom_1d (ki1:ki2), sfx_bom ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_sum_1d (ki1:ki2), sfx_sum ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_sni_1d (ki1:ki2), sfx_sni ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_bri_1d (ki1:ki2), sfx_bri ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_res_1d (ki1:ki2), sfx_res ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_sub_1d (ki1:ki2), sfx_sub ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sfx_lam_1d (ki1:ki2), sfx_lam ) + ! + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_thd_1d (ki1:ki2), hfx_thd ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_spr_1d (ki1:ki2), hfx_spr ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_sum_1d (ki1:ki2), hfx_sum ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_bom_1d (ki1:ki2), hfx_bom ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_bog_1d (ki1:ki2), hfx_bog ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_dif_1d (ki1:ki2), hfx_dif ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_opw_1d (ki1:ki2), hfx_opw ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_snw_1d (ki1:ki2), hfx_snw ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_sub_1d (ki1:ki2), hfx_sub ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_res_1d (ki1:ki2), hfx_res ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), hfx_err_dif_1d(ki1:ki2), hfx_err_dif ) + ! + ! ocean surface fields + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sst_1d(ki1:ki2), CASTDP(sst_m) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), sss_1d(ki1:ki2), CASTDP(sss_m) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), frq_m_1d(ki1:ki2), frq_m ) + ! + ! to update ice age + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), o_i_1d (ki1:ki2), CASTDP(o_i (:,:,kl)) ) + CALL tab_2d_1d( kpti, nptidx(ki1:ki2), oa_i_1d(ki1:ki2), oa_i(:,:,kl) ) + ! + ! --- Change units of e_i, e_s from J/m2 to J/m3 --- ! + ! Here we make sure that we don't divide by very small, but physically + ! meaningless, products of sea ice thicknesses/snow depths and sea ice + ! concentration + DO jk = 1, nlay_i + WHERE( (h_i_1d(ki1:ki2) * a_i_1d(ki1:ki2)) > epsi20 ) + e_i_1d(ki1:ki2,jk) = e_i_1d(ki1:ki2,jk) / (h_i_1d(ki1:ki2) * a_i_1d(ki1:ki2)) * nlay_i + ELSEWHERE + e_i_1d(ki1:ki2,jk) = 0._wp + ENDWHERE + END DO + DO jk = 1, nlay_s + WHERE( (h_s_1d(ki1:ki2) * a_i_1d(ki1:ki2)) > epsi20 ) + e_s_1d(ki1:ki2,jk) = e_s_1d(ki1:ki2,jk) / (h_s_1d(ki1:ki2) * a_i_1d(ki1:ki2)) * nlay_s + ELSEWHERE + e_s_1d(ki1:ki2,jk) = 0._wp + ENDWHERE + END DO + ! + ! !---------------------! + CASE( 2 ) !== from 1D to 2D ==! + ! !---------------------! + ! --- Change units of e_i, e_s from J/m3 to J/m2 --- ! + DO jk = 1, nlay_i + e_i_1d(ki1:ki2,jk) = e_i_1d(ki1:ki2,jk) * h_i_1d(ki1:ki2) * a_i_1d(ki1:ki2) * r1_nlay_i + END DO + DO jk = 1, nlay_s + e_s_1d(ki1:ki2,jk) = e_s_1d(ki1:ki2,jk) * h_s_1d(ki1:ki2) * a_i_1d(ki1:ki2) * r1_nlay_s + END DO + ! + ! Change thickness to volume (replaces routine ice_var_eqv2glo) + v_i_1d (ki1:ki2) = h_i_1d (ki1:ki2) * a_i_1d (ki1:ki2) + v_s_1d (ki1:ki2) = h_s_1d (ki1:ki2) * a_i_1d (ki1:ki2) + sv_i_1d(ki1:ki2) = s_i_1d (ki1:ki2) * v_i_1d (ki1:ki2) + v_ip_1d(ki1:ki2) = h_ip_1d(ki1:ki2) * a_ip_1d(ki1:ki2) + v_il_1d(ki1:ki2) = h_il_1d(ki1:ki2) * a_ip_1d(ki1:ki2) + oa_i_1d(ki1:ki2) = o_i_1d (ki1:ki2) * a_i_1d (ki1:ki2) + + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), at_i_1d(ki1:ki2), at_i ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), a_i_1d (ki1:ki2), a_i (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), h_i_1d (ki1:ki2), h_i (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), h_s_1d (ki1:ki2), h_s (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), t_su_1d(ki1:ki2), t_su(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), s_i_1d (ki1:ki2), s_i (:,:,kl) ) + DO jk = 1, nlay_s + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), t_s_1d(ki1:ki2,jk), t_s(:,:,jk,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), e_s_1d(ki1:ki2,jk), e_s(:,:,jk,kl) ) + END DO + DO jk = 1, nlay_i + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), t_i_1d (ki1:ki2,jk), t_i (:,:,jk,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), e_i_1d (ki1:ki2,jk), e_i (:,:,jk,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sz_i_1d(ki1:ki2,jk), sz_i(:,:,jk,kl) ) + END DO + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), a_ip_1d (ki1:ki2), a_ip (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), h_ip_1d (ki1:ki2), h_ip (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), h_il_1d (ki1:ki2), h_il (:,:,kl) ) + ! + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_snw_sni_1d(ki1:ki2), wfx_snw_sni ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_snw_sum_1d(ki1:ki2), wfx_snw_sum ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_sub_1d (ki1:ki2), wfx_sub ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_snw_sub_1d(ki1:ki2), wfx_snw_sub ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_ice_sub_1d(ki1:ki2), wfx_ice_sub ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_err_sub_1d(ki1:ki2), wfx_err_sub ) + ! + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_bog_1d (ki1:ki2), wfx_bog ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_bom_1d (ki1:ki2), wfx_bom ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_sum_1d (ki1:ki2), wfx_sum ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_sni_1d (ki1:ki2), wfx_sni ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_res_1d (ki1:ki2), wfx_res ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_spr_1d (ki1:ki2), wfx_spr ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_lam_1d (ki1:ki2), wfx_lam ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), wfx_pnd_1d (ki1:ki2), wfx_pnd ) + ! + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_bog_1d (ki1:ki2), sfx_bog ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_bom_1d (ki1:ki2), sfx_bom ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_sum_1d (ki1:ki2), sfx_sum ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_sni_1d (ki1:ki2), sfx_sni ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_bri_1d (ki1:ki2), sfx_bri ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_res_1d (ki1:ki2), sfx_res ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_sub_1d (ki1:ki2), sfx_sub ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), sfx_lam_1d (ki1:ki2), sfx_lam ) + ! + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_thd_1d (ki1:ki2), hfx_thd ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_spr_1d (ki1:ki2), hfx_spr ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_sum_1d (ki1:ki2), hfx_sum ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_bom_1d (ki1:ki2), hfx_bom ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_bog_1d (ki1:ki2), hfx_bog ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_dif_1d (ki1:ki2), hfx_dif ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_opw_1d (ki1:ki2), hfx_opw ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_snw_1d (ki1:ki2), hfx_snw ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_sub_1d (ki1:ki2), hfx_sub ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_res_1d (ki1:ki2), hfx_res ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), hfx_err_dif_1d(ki1:ki2), hfx_err_dif ) + ! + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), qns_ice_1d (ki1:ki2), qns_ice (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(qtr_ice_bot_1d(ki1:ki2)), qtr_ice_bot(:,:,kl) ) + ! effective conductivity and 1st layer temperature (ln_cndflx=T) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(cnd_ice_1d(ki1:ki2)), cnd_ice(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(t1_ice_1d (ki1:ki2)), t1_ice (:,:,kl) ) + ! SIMIP diagnostics + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(t_si_1d (ki1:ki2)), t_si (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(qcn_ice_bot_1d(ki1:ki2)), qcn_ice_bot(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(qcn_ice_top_1d(ki1:ki2)), qcn_ice_top(:,:,kl) ) + ! extensive variables + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), v_i_1d (ki1:ki2), v_i (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(v_s_1d (ki1:ki2)), v_s (:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(sv_i_1d(ki1:ki2)), sv_i(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(v_ip_1d(ki1:ki2)), v_ip(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(v_il_1d(ki1:ki2)), v_il(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), oa_i_1d(ki1:ki2), oa_i(:,:,kl) ) + ! check convergence of heat diffusion scheme + IF( ln_zdf_chkcvg ) THEN + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(tice_cvgerr_1d(ki1:ki2)), ztice_cvgerr(:,:,kl) ) + CALL tab_1d_2d( kpti, nptidx(ki1:ki2), CASTDP(tice_cvgstp_1d(ki1:ki2)), ztice_cvgstp(:,:,kl) ) + ENDIF + ! + END SELECT + ! + END SUBROUTINE ice_thd_1d2d + + + SUBROUTINE ice_thd_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_init *** + !! + !! ** Purpose : Physical constants and parameters associated with + !! ice thermodynamics + !! + !! ** Method : Read the namthd namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namelist namthd + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS, ln_leadhfx + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd in reference namelist : Ice thermodynamics + READ ( numnam_ice_ref, namthd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd in configuration namelist : Ice thermodynamics + READ ( numnam_ice_cfg, namthd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd in configuration namelist' ) + IF(lwm) WRITE( numoni, namthd ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_init: Ice Thermodynamics' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namthd:' + WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH + WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA + WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO + WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS + WRITE(numout,*) ' heat in the leads is used to melt sea-ice before warming the ocean ln_leadhfx = ', ln_leadhfx + ENDIF + ! + CALL ice_thd_zdf_init ! set ice heat diffusion parameters + IF( ln_icedA ) CALL ice_thd_da_init ! set ice lateral melting parameters + IF( ln_icedO ) CALL ice_thd_do_init ! set ice growth in open water parameters + CALL ice_thd_sal_init ! set ice salinity parameters + CALL ice_thd_pnd_init ! set melt ponds parameters + ! + END SUBROUTINE ice_thd_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd.mod b/V4.0/nemo_sources/src/ICE/icethd.mod new file mode 100644 index 0000000000000000000000000000000000000000..5f45f3f4ff98661a7b873ac4d929bf1b0e686173 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_da.F90 b/V4.0/nemo_sources/src/ICE/icethd_da.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7cafaa4eb07103d32bd05f8517c20aa48bcacefd --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_da.F90 @@ -0,0 +1,206 @@ +MODULE icethd_da + !!====================================================================== + !! *** MODULE icethd_da *** + !! sea-ice : lateral melting + !!====================================================================== + !! History : 3.7 ! 2016-03 (C. Rousset) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!--------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_da : sea ice lateral melting + !! ice_thd_da_init : sea ice lateral melting initialization + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE phycst ! physical constants (ocean directory) + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamic 1D variables + ! + 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 ice_thd_da ! called by icethd.F90 + PUBLIC ice_thd_da_init ! called by icestp.F90 + + ! !!** namelist (namthd_da) ** + REAL(wp) :: rn_beta ! coef. beta for lateral melting param. + REAL(wp) :: rn_dmin ! minimum floe diameter for lateral melting param. + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_da.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_da( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_da *** + !! + !! ** Purpose : computes sea ice lateral melting + !! + !! ** Method : dA/dt = - P * W [s-1] + !! W = melting velocity [m.s-1] + !! P = perimeter of ice-ocean lateral interface normalized by grid cell area [m.m-2] + !! + !! W = m1 * (Tw -Tf)**m2 --- originally from Josberger 1979 --- + !! (Tw - Tf) = elevation of water temp above freezing + !! m1 and m2 = (1.6e-6 , 1.36) best fit from field experiment near the coast of Prince Patrick Island + !! (Perovich 1983) => static ice + !! m1 and m2 = (3.0e-6 , 1.36) best fit from MIZEX 84 experiment + !! (Maykut and Perovich 1987) => moving ice + !! + !! P = N * pi * D --- from Rothrock and Thorndike 1984 --- + !! D = mean floe caliper diameter + !! N = number of floes = ice area / floe area(average) = A / (Cs * D**2) + !! A = ice concentration + !! Cs = deviation from a square (square:Cs=1 ; circle:Cs=pi/4 ; floe:Cs=0.66) + !! + !! D = Dmin * ( Astar / (Astar-A) )**beta --- from Lupkes et al., 2012 (eq. 26-27) --- + !! + !! Astar = 1 / ( 1 - (Dmin/Dmax)**(1/beta) ) + !! Dmin = minimum floe diameter (recommended to be 8m +- 20%) + !! Dmax = maximum floe diameter (recommended to be 300m, + !! but it does not impact melting much except for Dmax<100m) + !! beta = 1.0 +-20% (recommended value) + !! = 0.3 best fit for western Fram Strait and Antarctica + !! = 1.4 best fit for eastern Fram Strait + !! + !! ** Tunable parameters : We propose to tune the lateral melting via 2 parameters + !! Dmin [6-10m] => 6 vs 8m = +40% melting at the peak (A~0.5) + !! 10 vs 8m = -20% melting + !! beta [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 + !! + !! ** Note : Former and more simple formulations for floe diameters can be found in Mai (1995), + !! Birnbaum and Lupkes (2002), Lupkes and Birnbaum (2005). They are reviewed in Lupkes et al 2012 + !! A simpler implementation for CICE can be found in Bitz et al (2001) and Tsamados et al (2015) + !! + !! ** References + !! Bitz, C. M., Holland, M. M., Weaver, A. J., & Eby, M. (2001). + !! Simulating the ice‐thickness distribution in a coupled climate model. + !! Journal of Geophysical Research: Oceans, 106(C2), 2441-2463. + !! Josberger, E. G. (1979). + !! Laminar and turbulent boundary layers adjacent to melting vertical ice walls in salt water + !! (No. SCIENTIFIC-16). WASHINGTON UNIV SEATTLE DEPT OF ATMOSPHERIC SCIENCES. + !! Lüpkes, C., Gryanik, V. M., Hartmann, J., & Andreas, E. L. (2012). + !! A parametrization, based on sea ice morphology, of the neutral atmospheric drag coefficients + !! for weather prediction and climate models. + !! Journal of Geophysical Research: Atmospheres, 117(D13). + !! Maykut, G. A., & Perovich, D. K. (1987). + !! The role of shortwave radiation in the summer decay of a sea ice cover. + !! Journal of Geophysical Research: Oceans, 92(C7), 7032-7044. + !! Perovich, D. K. (1983). + !! On the summer decay of a sea ice cover. (Doctoral dissertation, University of Washington). + !! Rothrock, D. A., & Thorndike, A. S. (1984). + !! Measuring the sea ice floe size distribution. + !! Journal of Geophysical Research: Oceans, 89(C4), 6477-6486. + !! Tsamados, M., Feltham, D., Petty, A., Schroeder, D., & Flocco, D. (2015). + !! Processes controlling surface, bottom and lateral melt of Arctic sea ice in a state of the art sea ice model. + !! Phil. Trans. R. Soc. A, 373(2052), 20140167. + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER :: ji ! dummy loop indices + REAL(wp) :: zastar, zdfloe, zperi, zwlat, zda + REAL(wp), PARAMETER :: zdmax = 300._wp + REAL(wp), PARAMETER :: zcs = 0.66_wp + REAL(wp), PARAMETER :: zm1 = 3.e-6_wp + REAL(wp), PARAMETER :: zm2 = 1.36_wp + ! + REAL(wp), DIMENSION(jpij) :: zda_tot + !!--------------------------------------------------------------------- + ! + zastar = 1._wp / ( 1._wp - (rn_dmin / zdmax)**(1._wp/rn_beta) ) + ! + DO ji = ki1, ki2 + ! --- Calculate reduction of total sea ice concentration --- ! + zdfloe = rn_dmin * ( zastar / ( zastar - at_i_1d(ji) ) )**rn_beta ! Mean floe caliper diameter [m] + ! + zperi = at_i_1d(ji) * rpi / ( zcs * zdfloe ) ! Mean perimeter of the floe [m.m-2] + ! ! = N*pi*D = (A/cs*D^2)*pi*D + zwlat = zm1 * ( MAX( 0._wp, sst_1d(ji) - ( t_bo_1d(ji) - rt0 ) ) )**zm2 ! Melt speed rate [m/s] + ! + zda_tot(ji) = MIN( zwlat * zperi * rdt_ice, at_i_1d(ji) ) ! sea ice concentration decrease (>0) + + ! --- Distribute reduction among ice categories and calculate associated ice-ocean fluxes --- ! + IF( a_i_1d(ji) > 0._wp ) THEN + ! decrease of concentration for the category jl + ! each category contributes to melting in proportion to its concentration + zda = MIN( a_i_1d(ji), zda_tot(ji) * a_i_1d(ji) / at_i_1d(ji) ) + + ! Contribution to salt flux + sfx_lam_1d(ji) = sfx_lam_1d(ji) + rhoi * h_i_1d(ji) * zda * s_i_1d(ji) * r1_rdtice + + ! Contribution to heat flux into the ocean [W.m-2], (<0) + hfx_thd_1d(ji) = hfx_thd_1d(ji) - zda * r1_rdtice * ( h_i_1d(ji) * r1_nlay_i * SUM( e_i_1d(ji,1:nlay_i) ) & + + h_s_1d(ji) * r1_nlay_s * SUM( e_s_1d(ji,1:nlay_s) ) ) + + ! Contribution to mass flux + wfx_lam_1d(ji) = wfx_lam_1d(ji) + zda * r1_rdtice * ( rhoi * h_i_1d(ji) + rhos * h_s_1d(ji) ) + + ! new concentration + a_i_1d(ji) = a_i_1d(ji) - zda + + ! ensure that h_i = 0 where a_i = 0 + IF( a_i_1d(ji) == 0._wp ) THEN + h_i_1d(ji) = 0._wp + h_s_1d(ji) = 0._wp + ENDIF + ENDIF + END DO + ! + END SUBROUTINE ice_thd_da + + + SUBROUTINE ice_thd_da_init + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_da_init *** + !! + !! ** Purpose : Physical constants and parameters associated with + !! ice thermodynamics + !! + !! ** Method : Read the namthd_da namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namelist namthd_da + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namthd_da/ rn_beta, rn_dmin + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd_da in reference namelist : Ice thermodynamics + READ ( numnam_ice_ref, namthd_da, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd_da in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd_da in configuration namelist : Ice thermodynamics + READ ( numnam_ice_cfg, namthd_da, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd_da in configuration namelist' ) + IF(lwm) WRITE( numoni, namthd_da ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_da_init: Ice lateral melting' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namthd_da:' + WRITE(numout,*) ' Coef. beta for lateral melting param. rn_beta = ', rn_beta + WRITE(numout,*) ' Minimum floe diameter for lateral melting param. rn_dmin = ', rn_dmin + ENDIF + ! + END SUBROUTINE ice_thd_da_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy Module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_da \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_dh.F90 b/V4.0/nemo_sources/src/ICE/icethd_dh.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4c23206991cbb84eaf4e62bb86fa16c2069a21ce --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_dh.F90 @@ -0,0 +1,699 @@ +MODULE icethd_dh + !!====================================================================== + !! *** MODULE icethd_dh *** + !! seaice : thermodynamic growth and melt + !!====================================================================== + !! History : ! 2003-05 (M. Vancoppenolle) Original code in 1D + !! ! 2005-06 (M. Vancoppenolle) 3D version + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_dh : vertical sea-ice growth and melt + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE icethd_sal ! sea-ice: salinity profiles + USE icevar ! for CALL ice_var_snwblow + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_dh ! called by ice_thd + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_dh.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_dh( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------ + !! *** ROUTINE ice_thd_dh *** + !! + !! ** Purpose : compute ice and snow thickness changes due to growth/melting + !! + !! ** Method : Ice/Snow surface melting arises from imbalance in surface fluxes + !! Bottom accretion/ablation arises from flux budget + !! Snow thickness can increase by precipitation and decrease by sublimation + !! If snow load excesses Archmiede limit, snow-ice is formed by + !! the flooding of sea-water in the snow + !! + !! - Compute available flux of heat for surface ablation + !! - Compute snow and sea ice enthalpies + !! - Surface ablation and sublimation + !! - Bottom accretion/ablation + !! - Snow ice formation + !! + !! ** Note : h=max(0,h+dh) are often used to ensure positivity of h. + !! very small negative values can occur otherwise (e.g. -1.e-20) + !! + !! References : Bitz and Lipscomb, 1999, J. Geophys. Res. + !! Fichefet T. and M. Maqueda 1997, J. Geophys. Res., 102(C6), 12609-12646 + !! Vancoppenolle, Fichefet and Bitz, 2005, Geophys. Res. Let. + !! Vancoppenolle et al.,2009, Ocean Modelling + !!------------------------------------------------------------------ + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER :: ji, jk ! dummy loop indices + INTEGER :: iter ! local integer + + REAL(wp) :: ztmelts ! local scalar + REAL(wp) :: zdum + REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment + REAL(wp) :: zswi1 ! switch for computation of bottom salinity + REAL(wp) :: zswi12 ! switch for computation of bottom salinity + REAL(wp) :: zswi2 ! switch for computation of bottom salinity + REAL(wp) :: zgrr ! bottom growth rate + REAL(wp) :: zt_i_new ! bottom formation temperature + REAL(wp) :: z1_rho ! 1/(rhos+rau0-rhoi) + + REAL(wp) :: zQm ! enthalpy exchanged with the ocean (J/m2), >0 towards the ocean + REAL(wp) :: zEi ! specific enthalpy of sea ice (J/kg) + REAL(wp) :: zEw ! specific enthalpy of exchanged water (J/kg) + REAL(wp) :: zdE ! specific enthalpy difference (J/kg) + REAL(wp) :: zfmdt ! exchange mass flux x time step (J/m2), >0 towards the ocean + + REAL(wp), DIMENSION(jpij) :: zq_top ! heat for surface ablation (J.m-2) + REAL(wp), DIMENSION(jpij) :: zq_bot ! heat for bottom ablation (J.m-2) + REAL(wp), DIMENSION(jpij) :: zq_rema ! remaining heat at the end of the routine (J.m-2) + REAL(wp), DIMENSION(jpij) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) + REAL(wp), DIMENSION(jpij) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2) + REAL(wp), DIMENSION(jpij) :: zdeltah + REAL(wp), DIMENSION(jpij) :: zsnw ! distribution of snow after wind blowing + + INTEGER , DIMENSION(jpij,nlay_i) :: icount ! number of layers vanishing by melting + REAL(wp), DIMENSION(jpij,0:nlay_i+1) :: zh_i ! ice layer thickness (m) + REAL(wp), DIMENSION(jpij,0:nlay_s ) :: zh_s ! snw layer thickness (m) + REAL(wp), DIMENSION(jpij,0:nlay_s ) :: ze_s ! snw layer enthalpy (J.m-3) + + REAL(wp) :: zswitch_sal, zswitch + + INTEGER :: num_iter_max ! Heat conservation + !!------------------------------------------------------------------ + ! + ! Discriminate between time varying salinity and constant + SELECT CASE( nn_icesal ) ! varying salinity or not + CASE( 1 , 3 ) ; zswitch_sal = 0._wp ! prescribed salinity profile + CASE( 2 ) ; zswitch_sal = 1._wp ! varying salinity profile + END SELECT + + ! initialize ice layer thicknesses and enthalpies + eh_i_old(ki1:ki2,0:nlay_i+1) = 0._wp + h_i_old (ki1:ki2,0:nlay_i+1) = 0._wp + zh_i (ki1:ki2,0:nlay_i+1) = 0._wp + DO jk = 1, nlay_i + DO ji = ki1, ki2 + eh_i_old(ji,jk) = h_i_1d(ji) * r1_nlay_i * e_i_1d(ji,jk) + h_i_old (ji,jk) = h_i_1d(ji) * r1_nlay_i + zh_i (ji,jk) = h_i_1d(ji) * r1_nlay_i + END DO + END DO + ! + ! initialize snw layer thicknesses and enthalpies + zh_s(ki1:ki2,0) = 0._wp + ze_s(ki1:ki2,0) = 0._wp + DO jk = 1, nlay_s + DO ji = ki1, ki2 + zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s + ze_s(ji,jk) = e_s_1d(ji,jk) + END DO + END DO + ! + ! ! ============================================== ! + ! ! Available heat for surface and bottom ablation ! + ! ! ============================================== ! + ! + IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN + ! + DO ji = ki1, ki2 + zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rdt_ice ) + END DO + ! + ELSE + ! + DO ji = ki1, ki2 + zdum = qns_ice_1d(ji) + qsr_ice_1d(ji) - qtr_ice_top_1d(ji) - qcn_ice_top_1d(ji) + qml_ice_1d(ji) = zdum * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) + zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rdt_ice ) + END DO + ! + ENDIF + ! + DO ji = ki1, ki2 + zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) + qtr_ice_bot_1d(ji) * frq_m_1d(ji) + zq_bot(ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) + END DO + + ! ! ============ ! + ! ! Snow ! + ! ! ============ ! + ! + ! Internal melting + ! ---------------- + ! IF snow temperature is above freezing point, THEN snow melts (should not happen but sometimes it does) + DO jk = 1, nlay_s + DO ji = ki1, ki2 + IF( t_s_1d(ji,jk) > rt0 ) THEN + hfx_res_1d (ji) = hfx_res_1d (ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice ! heat flux to the ocean [W.m-2], < 0 + wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice ! mass flux + ! updates + dh_s_mlt(ji) = dh_s_mlt(ji) - zh_s(ji,jk) + h_s_1d (ji) = MAX( 0._wp, h_s_1d (ji) - zh_s(ji,jk) ) + zh_s (ji,jk) = 0._wp + ze_s (ji,jk) = 0._wp + END IF + END DO + END DO + + ! Snow precipitation + !------------------- + CALL ice_var_snwblow( 1.0_wp - at_i_1d(ki1:ki2), zsnw(ki1:ki2) ) ! snow distribution over ice after wind blowing + + DO ji = ki1, ki2 + IF( sprecip_1d(ji) > 0._wp ) THEN + zh_s(ji,0) = zsnw(ji) * sprecip_1d(ji) * rdt_ice * r1_rhos / at_i_1d(ji) ! thickness of precip + ze_s(ji,0) = MAX( 0._wp, - qprec_ice_1d(ji) ) ! enthalpy of the precip (>0, J.m-3) + ! + hfx_spr_1d(ji) = hfx_spr_1d(ji) + ze_s(ji,0) * zh_s(ji,0) * a_i_1d(ji) * r1_rdtice ! heat flux from snow precip (>0, W.m-2) + wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhos * zh_s(ji,0) * a_i_1d(ji) * r1_rdtice ! mass flux, <0 + ! + ! update thickness + h_s_1d(ji) = h_s_1d(ji) + zh_s(ji,0) + ENDIF + END DO + + ! Snow melting + ! ------------ + ! If heat still available (zq_top > 0) + ! then all snw precip has been melted and we need to melt more snow + DO jk = 0, nlay_s + DO ji = ki1, ki2 + IF( zh_s(ji,jk) > 0._wp .AND. zq_top(ji) > 0._wp ) THEN + ! + zswitch = MAX( 0._wp , SIGN( 1._wp , ze_s(ji,jk) - epsi20 ) ) + zdum = - zswitch * zq_top(ji) / MAX( ze_s(ji,jk), epsi20 ) ! thickness change + zdum = MAX( zdum , - zh_s(ji,jk) ) ! bound melting + + hfx_snw_1d (ji) = hfx_snw_1d (ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_rdtice ! heat used to melt snow(W.m-2, >0) + wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_rdtice ! snow melting only = water into the ocean + + ! updates available heat + thickness + dh_s_mlt(ji) = dh_s_mlt(ji) + zdum + zq_top (ji) = MAX( 0._wp , zq_top (ji) + zdum * ze_s(ji,jk) ) + h_s_1d (ji) = MAX( 0._wp , h_s_1d (ji) + zdum ) + zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum ) +!!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp + ! + ENDIF + END DO + END DO + + ! Snow sublimation + !----------------- + ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates + ! comment: not counted in mass/heat exchange in iceupdate.F90 since this is an exchange with atm. (not ocean) + zdeltah (ki1:ki2) = 0._wp ! total snow thickness that sublimates, < 0 + zevap_rema(ki1:ki2) = 0._wp + DO ji = ki1, ki2 + zdeltah (ji) = MAX( - evap_ice_1d(ji) * r1_rhos * rdt_ice, - h_s_1d(ji) ) ! amount of snw that sublimates, < 0 + zevap_rema(ji) = MAX( 0._wp, evap_ice_1d(ji) * rdt_ice + zdeltah(ji) * rhos ) ! remaining evap in kg.m-2 (used for ice sublimation later on) + END DO + + DO jk = 0, nlay_s + DO ji = ki1, ki2 + zdum = MAX( -zh_s(ji,jk), zdeltah(ji) ) ! snow layer thickness that sublimates, < 0 + ! + hfx_sub_1d (ji) = hfx_sub_1d (ji) + ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_rdtice ! Heat flux of snw that sublimates [W.m-2], < 0 + wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux by sublimation + + ! update thickness + h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdum ) + zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum ) +!!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp + + ! update sublimation left + zdeltah(ji) = MIN( zdeltah(ji) - zdum, 0._wp ) + END DO + END DO + + ! + ! ! ============ ! + ! ! Ice ! + ! ! ============ ! + + ! Surface ice melting + !-------------------- + DO jk = 1, nlay_i + DO ji = ki1, ki2 + ztmelts = - rTmlt * sz_i_1d(ji,jk) ! Melting point of layer k [C] + + IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN !-- Internal melting + + zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of layer k [J/kg, <0] + zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) + ! set up at 0 since no energy is needed to melt water...(it is already melted) + zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing + ! this should normally not happen, but sometimes, heat diffusion leads to this + zfmdt = - zdum * rhoi ! Recompute mass flux [kg/m2, >0] + ! + dh_i_itm(ji) = dh_i_itm(ji) + zdum ! Cumulate internal melting + ! + hfx_res_1d(ji) = hfx_res_1d(ji) + zEi * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux to the ocean [W.m-2], <0 + ! ice enthalpy zEi is "sent" to the ocean + wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux + sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux + ! using s_i_1d and not sz_i_1d(jk) is ok + ELSE !-- Surface melting + + zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of layer k [J/kg, <0] + zEw = rcp * ztmelts ! Specific enthalpy of resulting meltwater [J/kg, <0] + zdE = zEi - zEw ! Specific enthalpy difference < 0 + + zfmdt = - zq_top(ji) / zdE ! Mass flux to the ocean [kg/m2, >0] + + zdum = - zfmdt * r1_rhoi ! Melt of layer jk [m, <0] + + zdum = MIN( 0._wp , MAX( zdum , - zh_i(ji,jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0] + + zq_top(ji) = MAX( 0._wp , zq_top(ji) - zdum * rhoi * zdE ) ! update available heat + + dh_i_sum(ji) = dh_i_sum(ji) + zdum ! Cumulate surface melt + + zfmdt = - rhoi * zdum ! Recompute mass flux [kg/m2, >0] + + zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] + + hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux [W.m-2], < 0 + hfx_sum_1d(ji) = hfx_sum_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux used in this process [W.m-2], > 0 + wfx_sum_1d(ji) = wfx_sum_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux + sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux >0 + ! using s_i_1d and not sz_i_1d(jk) is ok) + END IF + ! update thickness + zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) + h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) + ! + ! update heat content (J.m-2) and layer thickness + eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) + h_i_old (ji,jk) = h_i_old (ji,jk) + zdum + ! + ! + ! Ice sublimation + ! --------------- + zdum = MAX( - zh_i(ji,jk) , - zevap_rema(ji) * r1_rhoi ) + ! + hfx_sub_1d(ji) = hfx_sub_1d(ji) + e_i_1d(ji,jk) * zdum * a_i_1d(ji) * r1_rdtice ! Heat flux [W.m-2], < 0 + wfx_ice_sub_1d(ji) = wfx_ice_sub_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux > 0 + sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux >0 + ! clem: flux is sent to the ocean for simplicity + ! but salt should remain in the ice except + ! if all ice is melted. => must be corrected + ! update remaining mass flux and thickness + zevap_rema(ji) = zevap_rema(ji) + zdum * rhoi + zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) + h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) + dh_i_sub(ji) = dh_i_sub(ji) + zdum + + ! update heat content (J.m-2) and layer thickness + eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) + h_i_old (ji,jk) = h_i_old (ji,jk) + zdum + + ! record which layers have disappeared (for bottom melting) + ! => icount=0 : no layer has vanished + ! => icount=5 : 5 layers have vanished + zswitch = MAX( 0._wp , SIGN( 1._wp , - zh_i(ji,jk) ) ) + icount(ji,jk) = NINT( zswitch ) + + END DO + END DO + + ! remaining "potential" evap is sent to ocean + DO ji = ki1, ki2 + wfx_err_sub_1d(ji) = wfx_err_sub_1d(ji) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice ! <=0 (net evap for the ocean in kg.m-2.s-1) + END DO + + + ! Ice Basal growth + !------------------ + ! Basal growth is driven by heat imbalance at the ice-ocean interface, + ! between the inner conductive flux (qcn_ice_bot), from the open water heat flux + ! (fhld) and the sensible ice-ocean flux (qsb_ice_bot). + ! qcn_ice_bot is positive downwards. qsb_ice_bot and fhld are positive to the ice + + ! If salinity varies in time, an iterative procedure is required, because + ! the involved quantities are inter-dependent. + ! Basal growth (dh_i_bog) depends upon new ice specific enthalpy (zEi), + ! which depends on forming ice salinity (s_i_new), which depends on dh/dt (dh_i_bog) + ! -> need for an iterative procedure, which converges quickly + + num_iter_max = 1 + IF( nn_icesal == 2 ) num_iter_max = 5 ! salinity varying in time + + DO ji = ki1, ki2 + IF( zf_tt(ji) < 0._wp ) THEN + DO iter = 1, num_iter_max ! iterations + + ! New bottom ice salinity (Cox & Weeks, JGR88 ) + !--- zswi1 if dh/dt < 2.0e-8 + !--- zswi12 if 2.0e-8 < dh/dt < 3.6e-7 + !--- zswi2 if dh/dt > 3.6e-7 + zgrr = MIN( 1.0e-3_wp, MAX ( dh_i_bog(ji) * r1_rdtice , epsi10 ) ) + zswi2 = MAX( 0._wp , SIGN( 1._wp , zgrr - 3.6e-7_wp ) ) + zswi12 = MAX( 0._wp , SIGN( 1._wp , zgrr - 2.0e-8_wp ) ) * ( 1.0_wp - zswi2 ) + zswi1 = 1. - zswi2 * zswi12 + zfracs = MIN( zswi1 * 0.12 + zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) ) & + & + zswi2 * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) , 0.5 ) + + s_i_new(ji) = zswitch_sal * zfracs * sss_1d(ji) + ( 1. - zswitch_sal ) * s_i_1d(ji) ! New ice salinity + + ztmelts = - rTmlt * s_i_new(ji) ! New ice melting point (C) + + zt_i_new = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) + + zEi = rcpi * ( zt_i_new - (ztmelts+rt0) ) & ! Specific enthalpy of forming ice (J/kg, <0) + & - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp * ztmelts + + zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0) + + zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) + + dh_i_bog(ji) = rdt_ice * MAX( 0._wp , zf_tt(ji) / ( zdE * rhoi ) ) + + END DO + ! Contribution to Energy and Salt Fluxes + zfmdt = - rhoi * dh_i_bog(ji) ! Mass flux x time step (kg/m2, < 0) + + hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux to the ocean [W.m-2], >0 + hfx_bog_1d(ji) = hfx_bog_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux used in this process [W.m-2], <0 + wfx_bog_1d(ji) = wfx_bog_1d(ji) - rhoi * dh_i_bog(ji) * a_i_1d(ji) * r1_rdtice ! Mass flux, <0 + sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoi * dh_i_bog(ji) * s_i_new(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux, <0 + + ! update thickness + zh_i(ji,nlay_i+1) = zh_i(ji,nlay_i+1) + dh_i_bog(ji) + h_i_1d(ji) = h_i_1d(ji) + dh_i_bog(ji) + + ! update heat content (J.m-2) and layer thickness + eh_i_old(ji,nlay_i+1) = eh_i_old(ji,nlay_i+1) + dh_i_bog(ji) * (-zEi * rhoi) + h_i_old (ji,nlay_i+1) = h_i_old (ji,nlay_i+1) + dh_i_bog(ji) + + ENDIF + + END DO + + ! Ice Basal melt + !--------------- + DO jk = nlay_i, 1, -1 + DO ji = ki1, ki2 + IF( zf_tt(ji) > 0._wp .AND. jk > icount(ji,jk) ) THEN ! do not calculate where layer has already disappeared by surface melting + + ztmelts = - rTmlt * sz_i_1d(ji,jk) ! Melting point of layer jk (C) + + IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN !-- Internal melting + + zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0) + zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) + ! set up at 0 since no energy is needed to melt water...(it is already melted) + zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing + ! this should normally not happen, but sometimes, heat diffusion leads to this + dh_i_itm (ji) = dh_i_itm(ji) + zdum + ! + zfmdt = - zdum * rhoi ! Mass flux x time step > 0 + ! + hfx_res_1d(ji) = hfx_res_1d(ji) + zEi * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux to the ocean [W.m-2], <0 + ! ice enthalpy zEi is "sent" to the ocean + wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux + sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux + ! using s_i_1d and not sz_i_1d(jk) is ok + ELSE !-- Basal melting + + zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0) + zEw = rcp * ztmelts ! Specific enthalpy of meltwater (J/kg, <0) + zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) + + zfmdt = - zq_bot(ji) / zdE ! Mass flux x time step (kg/m2, >0) + + zdum = - zfmdt * r1_rhoi ! Gross thickness change + + zdum = MIN( 0._wp , MAX( zdum, - zh_i(ji,jk) ) ) ! bound thickness change + + zq_bot(ji) = MAX( 0._wp , zq_bot(ji) - zdum * rhoi * zdE ) ! update available heat. MAX is necessary for roundup errors + + dh_i_bom(ji) = dh_i_bom(ji) + zdum ! Update basal melt + + zfmdt = - zdum * rhoi ! Mass flux x time step > 0 + + zQm = zfmdt * zEw ! Heat exchanged with ocean + + hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux to the ocean [W.m-2], <0 + hfx_bom_1d(ji) = hfx_bom_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat used in this process [W.m-2], >0 + wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_rdtice ! Mass flux + sfx_bom_1d(ji) = sfx_bom_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_rdtice ! Salt flux + ! using s_i_1d and not sz_i_1d(jk) is ok + ENDIF + ! update thickness + zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) + h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) + ! + ! update heat content (J.m-2) and layer thickness + eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) + h_i_old (ji,jk) = h_i_old (ji,jk) + zdum + ENDIF + END DO + END DO + + ! Remove snow if ice has melted entirely + ! -------------------------------------- + DO jk = 0, nlay_s + DO ji = ki1, ki2 + IF( h_i_1d(ji) == 0._wp ) THEN + ! mass & energy loss to the ocean + hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice ! heat flux to the ocean [W.m-2], < 0 + wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice ! mass flux + + ! update thickness and energy + h_s_1d(ji) = 0._wp + ze_s (ji,jk) = 0._wp + zh_s (ji,jk) = 0._wp + ENDIF + END DO + END DO + + ! Snow load on ice + ! ----------------- + ! When snow load exceeds Archimede's limit and sst is positive, + ! snow-ice formation (next bloc) can lead to negative ice enthalpy. + ! Therefore we consider here that this excess of snow falls into the ocean + zdeltah(ki1:ki2) = h_s_1d(ki1:ki2) + h_i_1d(ki1:ki2) * (rhoi-rau0) * r1_rhos + DO jk = 0, nlay_s + DO ji = ki1, ki2 + IF( zdeltah(ji) > 0._wp .AND. sst_1d(ji) > 0._wp ) THEN + ! snow layer thickness that falls into the ocean + zdum = MIN( zdeltah(ji) , zh_s(ji,jk) ) + ! mass & energy loss to the ocean + hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_rdtice ! heat flux to the ocean [W.m-2], < 0 + wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zdum * a_i_1d(ji) * r1_rdtice ! mass flux + ! update thickness and energy + h_s_1d(ji) = MAX( 0._wp, h_s_1d(ji) - zdum ) + zh_s (ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum ) + ! update snow thickness that still has to fall + zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum ) + ENDIF + END DO + END DO + + ! Snow-Ice formation + ! ------------------ + ! When snow load exceeds Archimede's limit, snow-ice interface goes down under sea-level, + ! flooding of seawater transforms snow into ice. Thickness that is transformed is dh_snowice (positive for the ice) + z1_rho = 1._wp / ( rhos+rau0-rhoi ) + zdeltah(ki1:ki2) = 0._wp + DO ji = ki1, ki2 + ! + dh_snowice(ji) = MAX( 0._wp , ( rhos * h_s_1d(ji) + (rhoi-rau0) * h_i_1d(ji) ) * z1_rho ) + + h_i_1d(ji) = h_i_1d(ji) + dh_snowice(ji) + h_s_1d(ji) = h_s_1d(ji) - dh_snowice(ji) + + ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) + zfmdt = ( rhos - rhoi ) * dh_snowice(ji) ! <0 + zEw = rcp * sst_1d(ji) + zQm = zfmdt * zEw + + hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_rdtice ! Heat flux + sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_1d(ji) * zfmdt * a_i_1d(ji) * r1_rdtice ! Salt flux + + ! Case constant salinity in time: virtual salt flux to keep salinity constant + IF( nn_icesal /= 2 ) THEN + sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_1d(ji) * zfmdt * a_i_1d(ji) * r1_rdtice & ! put back sss_m into the ocean + & - s_i_1d(ji) * dh_snowice(ji) * rhoi * a_i_1d(ji) * r1_rdtice ! and get rn_icesal from the ocean + ENDIF + + ! Mass flux: All snow is thrown in the ocean, and seawater is taken to replace the volume + wfx_sni_1d (ji) = wfx_sni_1d (ji) - dh_snowice(ji) * rhoi * a_i_1d(ji) * r1_rdtice + wfx_snw_sni_1d(ji) = wfx_snw_sni_1d(ji) + dh_snowice(ji) * rhos * a_i_1d(ji) * r1_rdtice + + ! update thickness + zh_i(ji,0) = zh_i(ji,0) + dh_snowice(ji) + zdeltah(ji) = dh_snowice(ji) + + ! update heat content (J.m-2) and layer thickness + h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji) + eh_i_old(ji,0) = eh_i_old(ji,0) + zfmdt * zEw ! 1st part (sea water enthalpy) + + END DO + ! + DO jk = nlay_s, 0, -1 ! flooding of snow starts from the base + DO ji = ki1, ki2 + zdum = MIN( zdeltah(ji), zh_s(ji,jk) ) ! amount of snw that floods, > 0 + zh_s(ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum ) ! remove some snow thickness + eh_i_old(ji,0) = eh_i_old(ji,0) + zdum * ze_s(ji,jk) ! 2nd part (snow enthalpy) + ! update dh_snowice + zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum ) + END DO + END DO + ! + ! +!!$ ! --- Update snow diags --- ! +!!$ !!clem: this is wrong. dh_s_tot is not used anyway +!!$ DO ji = ki1, ki2 +!!$ dh_s_tot(ji) = dh_s_tot(ji) + dh_s_mlt(ji) + zdeltah(ji) + zdh_s_sub(ji) - dh_snowice(ji) +!!$ END DO + ! + ! + ! Remapping of snw enthalpy on a regular grid + !-------------------------------------------- + CALL snw_ent( ki1, ki2, zh_s, ze_s, e_s_1d ) + + ! recalculate t_s_1d from e_s_1d + DO jk = 1, nlay_s + DO ji = ki1, ki2 + IF( h_s_1d(ji) > 0._wp ) THEN + t_s_1d(ji,jk) = rt0 + ( - e_s_1d(ji,jk) * r1_rhos * r1_rcpi + rLfus * r1_rcpi ) + ELSE + t_s_1d(ji,jk) = rt0 + ENDIF + END DO + END DO + + ! Note: remapping of ice enthalpy is done in icethd.F90 + + ! --- ensure that a_i = 0 & h_s = 0 where h_i = 0 --- + WHERE( h_i_1d(ki1:ki2) == 0._wp ) + a_i_1d (ki1:ki2) = 0._wp + h_s_1d (ki1:ki2) = 0._wp + t_su_1d(ki1:ki2) = rt0 + END WHERE + ! + END SUBROUTINE ice_thd_dh + + SUBROUTINE snw_ent( ki1, ki2, ph_old, pe_old, pe_new ) + !!------------------------------------------------------------------- + !! *** ROUTINE snw_ent *** + !! + !! ** Purpose : + !! This routine computes new vertical grids in the snow, + !! and consistently redistributes temperatures. + !! Redistribution is made so as to ensure to energy conservation + !! + !! + !! ** Method : linear conservative remapping + !! + !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses + !! 2) linear remapping on the new layers + !! + !! ------------ cum0(0) ------------- cum1(0) + !! NEW ------------- + !! ------------ cum0(1) ==> ------------- + !! ... ------------- + !! ------------ ------------- + !! ------------ cum0(nlay_s+1) ------------- cum1(nlay_s) + !! + !! + !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ki1, ki2 ! Loop start and stop + REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: ph_old ! old thicknesses (m) + REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: pe_old ! old enthlapies (J.m-3) + REAL(dp), DIMENSION(jpij,1:nlay_s), INTENT(inout) :: pe_new ! new enthlapies (J.m-3, remapped) + ! + INTEGER :: ji ! dummy loop indices + INTEGER :: jk0, jk1 ! old/new layer indices + REAL(wp) :: zswitch + ! + REAL(wp), DIMENSION(jpij,0:nlay_s+1) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces + REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces + REAL(wp), DIMENSION(jpij) :: zhnew ! new layers thicknesses + !!------------------------------------------------------------------- + + !-------------------------------------------------------------------------- + ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces + !-------------------------------------------------------------------------- + zeh_cum0(ki1:ki2,0) = 0._wp + zh_cum0 (ki1:ki2,0) = 0._wp + DO jk0 = 1, nlay_s+1 + DO ji = ki1, ki2 + zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + pe_old(ji,jk0-1) * ph_old(ji,jk0-1) + zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + ph_old(ji,jk0-1) + END DO + END DO + + !------------------------------------ + ! 2) Interpolation on the new layers + !------------------------------------ + ! new layer thickesses + DO ji = ki1, ki2 + zhnew(ji) = SUM( ph_old(ji,0:nlay_s) ) * r1_nlay_s + END DO + + ! new layers interfaces + zh_cum1(ki1:ki2,0) = 0._wp + DO jk1 = 1, nlay_s + DO ji = ki1, ki2 + zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji) + END DO + END DO + + zeh_cum1(ki1:ki2,0:nlay_s) = 0._wp + ! new cumulative q*h => linear interpolation + DO jk0 = 1, nlay_s+1 + DO jk1 = 1, nlay_s-1 + DO ji = ki1, ki2 + IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN + zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + & + & zeh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) & + & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) ) + ENDIF + END DO + END DO + END DO + ! to ensure that total heat content is strictly conserved, set: + zeh_cum1(ki1:ki2,nlay_s) = zeh_cum0(ki1:ki2,nlay_s+1) + + ! new enthalpies + DO jk1 = 1, nlay_s + DO ji = ki1, ki2 + zswitch = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) ) + pe_new(ji,jk1) = zswitch * ( zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 ) + END DO + END DO + + END SUBROUTINE snw_ent + + +#else + !!---------------------------------------------------------------------- + !! Default option NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_dh \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_dh.mod b/V4.0/nemo_sources/src/ICE/icethd_dh.mod new file mode 100644 index 0000000000000000000000000000000000000000..e3d693d7e22bcf98dec595a9df5316b25bcbe58b Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_dh.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_do.F90 b/V4.0/nemo_sources/src/ICE/icethd_do.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f75451279d8c607acf852b4c9e17c5db3f0d36ee --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_do.F90 @@ -0,0 +1,515 @@ +MODULE icethd_do + !!====================================================================== + !! *** MODULE icethd_do *** + !! sea-ice: sea ice growth in the leads (open water) + !!====================================================================== + !! History : ! 2005-12 (M. Vancoppenolle) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_do : ice growth in open water (=lateral accretion of ice) + !! ice_thd_do_init : initialization + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce , ONLY : sss_m + USE sbc_ice , ONLY : utau_ice, vtau_ice + USE ice1D ! sea-ice: thermodynamics variables + USE ice ! sea-ice: variables + USE icetab ! sea-ice: 2D <==> 1D + USE icectl ! sea-ice: conservation + USE icethd_ent ! sea-ice: thermodynamics, enthalpy + USE icevar ! sea-ice: operations + USE icethd_sal ! sea-ice: salinity profiles + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + USE nopenmp ! OpenMP + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_do ! called by ice_thd + PUBLIC ice_thd_do_init ! called by ice_stp + + ! !!** namelist (namthd_do) ** + REAL(wp), PUBLIC :: rn_hinew ! thickness for new ice formation (m) + LOGICAL :: ln_frazil ! use of frazil ice collection as function of wind (T) or not (F) + REAL(wp) :: rn_maxfraz ! maximum portion of frazil ice collecting at the ice bottom + REAL(wp) :: rn_vfraz ! threshold drift speed for collection of bottom frazil ice + REAL(wp) :: rn_Cfraz ! squeezing coefficient for collection of bottom frazil ice + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_do.F90 13589 2020-10-14 13:35:49Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_do + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_do *** + !! + !! ** Purpose : Computation of the evolution of the ice thickness and + !! concentration as a function of the heat balance in the leads + !! + !! ** Method : Ice is formed in the open water when ocean looses heat + !! (heat budget of open water is negative) following + !! + !! (dA/dt)acc = F[ (1-A)/(1-a) ] * [ Bl / (Li*h0) ] + !! where - h0 is the thickness of ice created in the lead + !! - a is a minimum fraction for leads + !! - F is a monotonic non-increasing function defined as: + !! F(X)=( 1 - X**exld )**(1.0/exld) + !! - exld is the exponent closure rate (=2 default val.) + !! + !! ** Action : - Adjustment of snow and ice thicknesses and heat + !! content in brine pockets + !! - Updating ice internal temperature + !! - Computation of variation of ice volume and mass + !! - Computation of a_i after lateral accretion and + !! update h_s_1d, h_i_1d + !!------------------------------------------------------------------------ + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: jj1, jj2 ! OpenMP loop index (grid points) + INTEGER :: ji1, ji2, jpti ! OpenMP loop index (1d points) + INTEGER :: itid, ithreads ! OpenMP environment + INTEGER :: iter ! - - + REAL(wp) :: ztmelts, zfrazb, zweight, zde ! local scalars + REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf ! - - + REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - + ! + REAL(wp) :: zQm ! enthalpy exchanged with the ocean (J/m2, >0 towards ocean) + REAL(wp) :: zEi ! sea ice specific enthalpy (J/kg) + REAL(wp) :: zEw ! seawater specific enthalpy (J/kg) + REAL(wp) :: zfmdt ! mass flux x time step (kg/m2, >0 towards ocean) + REAL(wp) :: zswitch ! local rswitch + ! + REAL(wp) :: zv_newfra + ! + INTEGER , DIMENSION(jpij) :: jcat ! indexes of categories where new ice grows + REAL(wp), DIMENSION(jpij) :: zswinew ! switch for new ice or not + ! + REAL(wp), DIMENSION(jpij) :: zv_newice ! volume of accreted ice + REAL(wp), DIMENSION(jpij) :: za_newice ! fractional area of accreted ice + REAL(dp), DIMENSION(jpij) :: zh_newice ! thickness of accreted ice + REAL(wp), DIMENSION(jpij) :: ze_newice ! heat content of accreted ice + REAL(wp), DIMENSION(jpij) :: zs_newice ! salinity of accreted ice + REAL(wp), DIMENSION(jpij) :: zo_newice ! age of accreted ice + REAL(wp), DIMENSION(jpij) :: zdv_res ! residual volume in case of excessive heat budget + REAL(wp), DIMENSION(jpij) :: zda_res ! residual area in case of excessive heat budget + REAL(wp), DIMENSION(jpij) :: zv_frazb ! accretion of frazil ice at the ice bottom + REAL(dp), DIMENSION(jpij) :: zvrel_1d ! relative ice / frazil velocity (1D vector) + ! + REAL(wp), DIMENSION(jpij,jpl) :: zv_b ! old volume of ice in category jl + REAL(wp), DIMENSION(jpij,jpl) :: za_b ! old area of ice in category jl + ! + REAL(dp), DIMENSION(jpij,nlay_i,jpl) :: ze_i_2d !: 1-D version of e_i + ! + REAL(wp), DIMENSION(jpi,jpj) :: zvrel ! relative ice / frazil velocity + ! + REAL(wp) :: zcai = 1.4e-3_wp ! ice-air drag (clem: should be dependent on coupling/forcing used) + !!-----------------------------------------------------------------------! + IF( ln_timing_detail ) CALL timing_start('ice_thd_do') + ! + IF( ln_icediachk ) CALL ice_cons_hsm( 0, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft ) + IF( ln_icediachk ) CALL ice_cons2D ( 0, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft ) + + + !$omp parallel private(ji,jj,jk,jl,jj1,jj2,itid,ithreads, & + !$omp& ji1,ji2,jpti,iter,ztmelts,zfrazb,zweight,zde, & + !$omp& zgamafr,zvfrx,zvgx,ztaux,ztwogp,zf, & + !$omp& ztenagm,zvfry,zvgy,ztauy,zvrel2,zfp,zsqcd,zhicrit, & + !$omp& zQm,zEi,zEw,zfmdt,zv_newfra,zswitch) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + at_i(:,jj1:jj2) = SUM( a_i(:,jj1:jj2,:), dim=3 ) + !------------------------------------------------------------------------------! + ! 1) Collection thickness of ice formed in leads and polynyas + !------------------------------------------------------------------------------! + ! ht_i_new is the thickness of new ice formed in open water + ! ht_i_new can be either prescribed (ln_frazil=F) or computed (ln_frazil=T) + ! Frazil ice forms in open water, is transported by wind + ! accumulates at the edge of the consolidated ice edge + ! where it forms aggregates of a specific thickness called + ! collection thickness. + + zvrel(:,jj1:jj2) = 0._wp + + ! Default new ice thickness + WHERE( qlead(:,jj1:jj2) < 0._wp ) ! cooling + ht_i_new(:,jj1:jj2) = rn_hinew + ELSEWHERE + ht_i_new(:,jj1:jj2) = 0._wp + END WHERE + + IF( ln_frazil ) THEN + ! + ht_i_new(:,jj1:jj2) = 0._wp + ! + ! Physical constants + zhicrit = 0.04 ! frazil ice thickness + ztwogp = 2. * rau0 / ( grav * 0.3 * ( rau0 - rhoi ) ) ! reduced grav + zsqcd = 1.0 / SQRT( 1.3 * zcai ) ! 1/SQRT(airdensity*drag) + zgamafr = 0.03 + ! + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = 2, jpim1 + IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling + ! -- Wind stress -- ! + ztaux = ( utau_ice(ji-1,jj ) * umask(ji-1,jj ,1) & + & + utau_ice(ji ,jj ) * umask(ji ,jj ,1) ) * 0.5_wp + ztauy = ( vtau_ice(ji ,jj-1) * vmask(ji ,jj-1,1) & + & + vtau_ice(ji ,jj ) * vmask(ji ,jj ,1) ) * 0.5_wp + ! Square root of wind stress + ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) + + ! -- Frazil ice velocity -- ! + zswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) + zvfrx = zswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) + zvfry = zswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) + + ! -- Pack ice velocity -- ! + zvgx = ( u_ice(ji-1,jj ) * umask(ji-1,jj ,1) + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp + zvgy = ( v_ice(ji ,jj-1) * vmask(ji ,jj-1,1) + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp + + ! -- Relative frazil/pack ice velocity -- ! + zswitch = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) + zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) & + & + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) * zswitch + zvrel(ji,jj) = SQRT( zvrel2 ) + + ! -- new ice thickness (iterative loop) -- ! + ht_i_new(ji,jj) = zhicrit + ( zhicrit + 0.1 ) & + & / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) - zhicrit * zhicrit ) * ztwogp * zvrel2 + + iter = 1 + DO WHILE ( iter < 20 ) + zf = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) - & + & ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2 + zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0 * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 + + ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 ) + iter = iter + 1 + END DO + ! + ! bound ht_i_new (though I don't see why it should be necessary) + ht_i_new(ji,jj) = MAX( 0.01_wp, MIN( ht_i_new(ji,jj), hi_max(jpl) ) ) + ! + ENDIF + ! + END DO + END DO + ! + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + ENDIF + !$omp barrier + + !------------------------------------------------------------------------------! + ! 2) Compute thickness, salinity, enthalpy, age, area and volume of new ice + !------------------------------------------------------------------------------! + ! it occurs if cooling + + !$omp barrier + !$omp master + ! Identify grid points where new ice forms + npti = 0 ; nptidx(:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( qlead(ji,jj) < 0._wp ) THEN + npti = npti + 1 + nptidx( npti ) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + !$omp end master + !$omp barrier + + ! Split npti loops for openmp parallelism + ji1 = nompstas(itid,npti) + ji2 = nompends(itid,npti) + jpti = ji2 - ji1 + 1 + + ! Move from 2-D to 1-D vectors + IF ( npti > 0 ) THEN + + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), at_i_1d(ji1:ji2) , at_i ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), a_i_2d (ji1:ji2,1:jpl), a_i (:,:,:) ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), v_i_2d (ji1:ji2,1:jpl), v_i (:,:,:) ) + CALL tab_3d_2d( jpti, nptidx(ji1:ji2), sv_i_2d(ji1:ji2,1:jpl), sv_i(:,:,:) ) + DO jl = 1, jpl + DO jk = 1, nlay_i + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), ze_i_2d(ji1:ji2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), qlead_1d (ji1:ji2) , CASTDP(qlead) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), t_bo_1d (ji1:ji2) , CASTDP(t_bo) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), sfx_opw_1d(ji1:ji2) , sfx_opw ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), wfx_opw_1d(ji1:ji2) , wfx_opw ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), zh_newice (ji1:ji2) , CASTDP(ht_i_new) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), zvrel_1d (ji1:ji2) , CASTDP(zvrel) ) + + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), hfx_thd_1d(ji1:ji2) , hfx_thd ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), hfx_opw_1d(ji1:ji2) , hfx_opw ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), rn_amax_1d(ji1:ji2) , CASTDP(rn_amax_2d) ) + CALL tab_2d_1d( jpti, nptidx(ji1:ji2), sss_1d (ji1:ji2) , CASTDP(sss_m) ) + + ! Convert units for ice internal energy + DO jl = 1, jpl + DO jk = 1, nlay_i + WHERE( v_i_2d(ji1:ji2,jl) > 0._wp ) + ze_i_2d(ji1:ji2,jk,jl) = ze_i_2d(ji1:ji2,jk,jl) / v_i_2d(ji1:ji2,jl) * REAL( nlay_i ) + ELSEWHERE + ze_i_2d(ji1:ji2,jk,jl) = 0._wp + END WHERE + END DO + END DO + + ! Keep old ice areas and volume in memory + zv_b(ji1:ji2,:) = v_i_2d(ji1:ji2,:) + za_b(ji1:ji2,:) = a_i_2d(ji1:ji2,:) + + ! --- Salinity of new ice --- ! + SELECT CASE ( nn_icesal ) + CASE ( 1 ) ! Sice = constant + zs_newice(ji1:ji2) = rn_icesal + CASE ( 2 ) ! Sice = F(z,t) [Vancoppenolle et al (2005)] + DO ji = ji1, ji2 + zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_1d(ji) ) + END DO + CASE ( 3 ) ! Sice = F(z) [multiyear ice] + zs_newice(ji1:ji2) = 2.3 + END SELECT + + ! --- Heat content of new ice --- ! + ! We assume that new ice is formed at the seawater freezing point + DO ji = ji1, ji2 + ztmelts = - rTmlt * zs_newice(ji) ! Melting point (C) + ze_newice(ji) = rhoi * ( rcpi * ( ztmelts - ( t_bo_1d(ji) - rt0 ) ) & + & + rLfus * ( 1.0 - ztmelts / MIN( t_bo_1d(ji) - rt0, -epsi10 ) ) & + & - rcp * ztmelts ) + END DO + + ! --- Age of new ice --- ! + zo_newice(ji1:ji2) = 0._wp + + ! --- Volume of new ice --- ! + DO ji = ji1, ji2 + + zEi = - ze_newice(ji) * r1_rhoi ! specific enthalpy of forming ice [J/kg] + + zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! specific enthalpy of seawater at t_bo_1d [J/kg] + ! clem: we suppose we are already at the freezing point (condition qlead<0 is satisfyied) + + zdE = zEi - zEw ! specific enthalpy difference [J/kg] + + zfmdt = - qlead_1d(ji) / zdE ! Fm.dt [kg/m2] (<0) + ! clem: we use qlead instead of zqld (icethd) because we suppose we are at the freezing point + zv_newice(ji) = - zfmdt * r1_rhoi + + zQm = zfmdt * zEw ! heat to the ocean >0 associated with mass flux + + ! Contribution to heat flux to the ocean [W.m-2], >0 + hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * zEw * r1_rdtice + ! Total heat flux used in this process [W.m-2] + hfx_opw_1d(ji) = hfx_opw_1d(ji) - zfmdt * zdE * r1_rdtice + ! mass flux + wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice(ji) * rhoi * r1_rdtice + ! salt flux + sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoi * zs_newice(ji) * r1_rdtice + END DO + + zv_frazb(ji1:ji2) = 0._wp + IF( ln_frazil ) THEN + ! A fraction zfrazb of frazil ice is accreted at the ice bottom + DO ji = ji1, ji2 + zswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) ) + zfrazb = zswitch * ( TANH( rn_Cfraz * ( zvrel_1d(ji) - rn_vfraz ) ) + 1.0 ) * 0.5 * rn_maxfraz + zv_frazb(ji) = zfrazb * zv_newice(ji) + zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) + END DO + END IF + + ! --- Area of new ice --- ! + DO ji = ji1, ji2 + za_newice(ji) = zv_newice(ji) / zh_newice(ji) + END DO + + !------------------------------------------------------------------------------! + ! 3) Redistribute new ice area and volume into ice categories ! + !------------------------------------------------------------------------------! + + ! --- lateral ice growth --- ! + ! If lateral ice growth gives an ice concentration > amax, then + ! we keep the excessive volume in memory and attribute it later to bottom accretion + DO ji = ji1, ji2 + IF ( za_newice(ji) > MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN ! max is for roundoff error + zda_res(ji) = za_newice(ji) - MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) ) + zdv_res(ji) = zda_res (ji) * zh_newice(ji) + za_newice(ji) = MAX( 0._wp, za_newice(ji) - zda_res (ji) ) + zv_newice(ji) = MAX( 0._wp, zv_newice(ji) - zdv_res (ji) ) + ELSE + zda_res(ji) = 0._wp + zdv_res(ji) = 0._wp + ENDIF + END DO + + ! find which category to fill + DO jl = 1, jpl + DO ji = ji1, ji2 + IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN + a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice(ji) + v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newice(ji) + jcat(ji) = jl + ENDIF + END DO + END DO + at_i_1d(ji1:ji2) = SUM( a_i_2d(ji1:ji2,:), dim=2 ) + + ! Heat content + DO ji = ji1, ji2 + jl = jcat(ji) ! categroy in which new ice is put + zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) ) ! 0 if old ice + END DO + + DO jk = 1, nlay_i + DO ji = ji1, ji2 + jl = jcat(ji) + zswitch = MAX( 0._wp, SIGN( 1._wp , v_i_2d(ji,jl) - epsi20 ) ) + ze_i_2d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + & + & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_2d(ji,jk,jl) * zv_b(ji,jl) ) & + & * zswitch / MAX( v_i_2d(ji,jl), epsi20 ) + END DO + END DO + + ! --- bottom ice growth + ice enthalpy remapping --- ! + DO jl = 1, jpl + + ! for remapping + h_i_old (ji1:ji2,0:nlay_i+1) = 0._wp + eh_i_old(ji1:ji2,0:nlay_i+1) = 0._wp + DO jk = 1, nlay_i + DO ji = ji1, ji2 + h_i_old (ji,jk) = v_i_2d(ji,jl) * r1_nlay_i + eh_i_old(ji,jk) = ze_i_2d(ji,jk,jl) * h_i_old(ji,jk) + END DO + END DO + + ! new volumes including lateral/bottom accretion + residual + DO ji = ji1, ji2 + zswitch = MAX( 0._wp, SIGN( 1._wp , at_i_1d(ji) - epsi20 ) ) + zv_newfra = zswitch * ( zdv_res(ji) + zv_frazb(ji) ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 ) + a_i_2d(ji,jl) = zswitch * a_i_2d(ji,jl) + v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newfra + ! for remapping + h_i_old (ji,nlay_i+1) = zv_newfra + eh_i_old(ji,nlay_i+1) = ze_newice(ji) * zv_newfra + END DO + ! --- Ice enthalpy remapping --- ! + CALL ice_thd_ent( itid, ji1, ji2, jpti, ze_i_2d(:,:,jl) , .FALSE. ) + END DO + + ! --- Update salinity --- ! + DO jl = 1, jpl + DO ji = ji1, ji2 + sv_i_2d(ji,jl) = sv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(ji,jl) ) + END DO + END DO + + ! Change units for e_i + DO jl = 1, jpl + DO jk = 1, nlay_i + ze_i_2d(ji1:ji2,jk,jl) = ze_i_2d(ji1:ji2,jk,jl) * v_i_2d(ji1:ji2,jl) * r1_nlay_i + END DO + END DO + + ! Move 2D vectors to 1D vectors + CALL tab_2d_3d( jpti, nptidx(ji1:ji2), a_i_2d (ji1:ji2,1:jpl), a_i (:,:,:) ) + CALL tab_2d_3d( jpti, nptidx(ji1:ji2), v_i_2d (ji1:ji2,1:jpl), v_i (:,:,:) ) + CALL tab_2d_3d( jpti, nptidx(ji1:ji2), sv_i_2d(ji1:ji2,1:jpl), sv_i(:,:,:) ) + DO jl = 1, jpl + DO jk = 1, nlay_i + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), ze_i_2d(ji1:ji2,jk,jl), e_i(:,:,jk,jl) ) + END DO + END DO + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), sfx_opw_1d(ji1:ji2), sfx_opw ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), wfx_opw_1d(ji1:ji2), wfx_opw ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), hfx_thd_1d(ji1:ji2), hfx_thd ) + CALL tab_1d_2d( jpti, nptidx(ji1:ji2), hfx_opw_1d(ji1:ji2), hfx_opw ) + ! + ENDIF ! npti > 0 + ! + !$omp end parallel + ! + IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) + IF( ln_icediachk ) CALL ice_cons2D (1, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) + ! + IF( ln_timing_detail ) CALL timing_stop('ice_thd_do') + ! + END SUBROUTINE ice_thd_do + + + SUBROUTINE ice_thd_do_init + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_do_init *** + !! + !! ** Purpose : Physical constants and parameters associated with + !! ice growth in the leads + !! + !! ** Method : Read the namthd_do namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namelist namthd_do + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namthd_do/ rn_hinew, ln_frazil, rn_maxfraz, rn_vfraz, rn_Cfraz + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd_do in reference namelist : Ice thermodynamics + READ ( numnam_ice_ref, namthd_do, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd_do in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd_do in configuration namelist : Ice thermodynamics + READ ( numnam_ice_cfg, namthd_do, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd_do in configuration namelist' ) + IF(lwm) WRITE( numoni, namthd_do ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_do_init: Ice growth in open water' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namthd_do:' + WRITE(numout,*) ' ice thickness for lateral accretion rn_hinew = ', rn_hinew + WRITE(numout,*) ' Frazil ice thickness as a function of wind or not ln_frazil = ', ln_frazil + WRITE(numout,*) ' Maximum proportion of frazil ice collecting at bottom rn_maxfraz = ', rn_maxfraz + WRITE(numout,*) ' Threshold relative drift speed for collection of frazil rn_vfraz = ', rn_vfraz + WRITE(numout,*) ' Squeezing coefficient for collection of frazil rn_Cfraz = ', rn_Cfraz + ENDIF + ! + IF ( rn_hinew < rn_himin ) CALL ctl_stop( 'ice_thd_do_init : rn_hinew should be >= rn_himin' ) + ! + END SUBROUTINE ice_thd_do_init + +#else + !!---------------------------------------------------------------------- + !! Default option NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_do diff --git a/V4.0/nemo_sources/src/ICE/icethd_do.mod b/V4.0/nemo_sources/src/ICE/icethd_do.mod new file mode 100644 index 0000000000000000000000000000000000000000..46bc87b80cc6e3866efd76b932e237d030bd6453 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_do.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_ent.F90 b/V4.0/nemo_sources/src/ICE/icethd_ent.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7afc8fd4b567519e4f827af73fee35c57c277ded --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_ent.F90 @@ -0,0 +1,150 @@ +MODULE icethd_ent + !!====================================================================== + !! *** MODULE icethd_ent *** + !! sea-ice: redistribution of enthalpy in the ice on the new vertical grid + !! after vertical growth/melt + !!====================================================================== + !! History : ! 2003-05 (M. Vancoppenolle) Original code in 1D + !! ! 2005-07 (M. Vancoppenolle) 3D version + !! 3.6 ! 2014-05 (C. Rousset) New version + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_ent : ice redistribution of enthalpy + !!---------------------------------------------------------------------- + USE dom_oce ! domain variables + USE domain ! + USE phycst ! physical constants + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + ! + 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 ice_thd_ent ! called by icethd and icethd_do + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_ent.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_ent( ktid, ki1, ki2, kpti, qnew, compute_hfx_err ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_ent *** + !! + !! ** Purpose : + !! This routine computes new vertical grids in the ice, + !! and consistently redistributes temperatures. + !! Redistribution is made so as to ensure to energy conservation + !! + !! + !! ** Method : linear conservative remapping + !! + !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses + !! 2) linear remapping on the new layers + !! + !! ------------ cum0(0) ------------- cum1(0) + !! NEW ------------- + !! ------------ cum0(1) ==> ------------- + !! ... ------------- + !! ------------ ------------- + !! ------------ cum0(nlay_i+2) ------------- cum1(nlay_i) + !! + !! + !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + REAL(dp), DIMENSION(jpij,nlay_i), INTENT(inout) :: qnew ! new enthlapies (J.m-3, remapped) + LOGICAL, INTENT(in) :: compute_hfx_err ! determines whether to compute diag. + ! error or not + ! + INTEGER :: ji ! dummy loop indices + INTEGER :: jk0, jk1 ! old/new layer indices + REAL(wp) :: zswitch ! local rswitch + ! + REAL(wp), DIMENSION(jpij,0:nlay_i+2) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces + REAL(wp), DIMENSION(jpij,0:nlay_i) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces + REAL(wp), DIMENSION(jpij) :: zhnew ! new layers thicknesses + !!------------------------------------------------------------------- + ! + !-------------------------------------------------------------------------- + ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces + !-------------------------------------------------------------------------- + zeh_cum0(ki1:ki2,0) = 0._wp + zh_cum0 (ki1:ki2,0) = 0._wp + DO jk0 = 1, nlay_i+2 + DO ji = ki1, ki2 + zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + eh_i_old(ji,jk0-1) + zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + h_i_old (ji,jk0-1) + END DO + END DO + + !------------------------------------ + ! 2) Interpolation on the new layers + !------------------------------------ + ! new layer thickesses + DO ji = ki1, ki2 + zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) * r1_nlay_i + END DO + + ! new layers interfaces + zh_cum1(ki1:ki2,0) = 0._wp + DO jk1 = 1, nlay_i + DO ji = ki1, ki2 + zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji) + END DO + END DO + + zeh_cum1(ki1:ki2,0:nlay_i) = 0._wp + ! new cumulative q*h => linear interpolation + DO jk0 = 1, nlay_i+2 + DO jk1 = 1, nlay_i-1 + DO ji = ki1, ki2 + IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN + zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + & + & zeh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) & + & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) ) + ENDIF + END DO + END DO + END DO + ! to ensure that total heat content is strictly conserved, set: + zeh_cum1(ki1:ki2,nlay_i) = zeh_cum0(ki1:ki2,nlay_i+2) + + ! new enthalpies + DO jk1 = 1, nlay_i + DO ji = ki1, ki2 + zswitch = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) ) + qnew(ji,jk1) = zswitch * ( zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 ) + END DO + END DO + + ! --- diag error on heat remapping --- ! + ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do), + ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 + !IF( compute_hfx_err ) THEN + ! DO ji = ki1, ki2 + ! hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_rdtice * & + ! & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) + ! END DO + !END IF + ! + END SUBROUTINE ice_thd_ent + +#else + !!---------------------------------------------------------------------- + !! Default option NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_ent \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_pnd.F90 b/V4.0/nemo_sources/src/ICE/icethd_pnd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3228459d2f3472d831e4a888cc90ba389b4e377d --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_pnd.F90 @@ -0,0 +1,397 @@ +MODULE icethd_pnd + !!====================================================================== + !! *** MODULE icethd_pnd *** + !! sea-ice: Melt ponds on top of sea ice + !!====================================================================== + !! history : ! 2012 (O. Lecomte) Adaptation from Flocco and Turner + !! ! 2017 (M. Vancoppenolle, O. Lecomte, C. Rousset) Implementation + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' : SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_pnd_init : some initialization and namelist read + !! ice_thd_pnd : main calling routine + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE icetab ! sea-ice: 1D <==> 2D transformation + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_pnd_init ! routine called by icestp.F90 + PUBLIC ice_thd_pnd ! routine called by icestp.F90 + PUBLIC nice_pnd, np_pndCST, np_pndLEV ! for timing in icethd + + INTEGER :: nice_pnd ! choice of the type of pond scheme + ! ! associated indices: + INTEGER, PARAMETER :: np_pndNO = 0 ! No pond scheme + INTEGER, PARAMETER :: np_pndCST = 1 ! Constant ice pond scheme + INTEGER, PARAMETER :: np_pndLEV = 2 ! Level ice pond scheme + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_pnd.F90 14246 2020-12-23 13:33:55Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_pnd( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_pnd *** + !! + !! ** Purpose : change melt pond fraction and thickness + !! + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + ! + SELECT CASE ( nice_pnd ) + ! + CASE (np_pndCST) ; CALL pnd_CST( ktid, ki1, ki2, kpti ) !== Constant melt ponds ==! + ! + CASE (np_pndLEV) ; CALL pnd_LEV( ktid, ki1, ki2, kpti ) !== Level ice melt ponds ==! + ! + END SELECT + ! + END SUBROUTINE ice_thd_pnd + + + SUBROUTINE pnd_CST( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE pnd_CST *** + !! + !! ** Purpose : Compute melt pond evolution + !! + !! ** Method : Melt pond fraction and thickness are prescribed + !! to non-zero values when t_su = 0C + !! + !! ** Tunable parameters : pond fraction (rn_apnd), pond depth (rn_hpnd) + !! + !! ** Note : Coupling with such melt ponds is only radiative + !! Advection, ridging, rafting... are bypassed + !! + !! ** References : Bush, G.W., and Trump, D.J. (2017) + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER :: ji ! loop indices + REAL(wp) :: zdv_pnd ! Amount of water going into the ponds & lids + !!------------------------------------------------------------------- + ! + DO ji = ki1, ki2 + ! + zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) + ! + IF( a_i_1d(ji) >= 0.01_wp .AND. t_su_1d(ji) >= rt0 ) THEN + h_ip_1d(ji) = rn_hpnd + a_ip_1d(ji) = rn_apnd * a_i_1d(ji) + h_il_1d(ji) = 0._wp ! no pond lids whatsoever + ELSE + h_ip_1d(ji) = 0._wp + a_ip_1d(ji) = 0._wp + h_il_1d(ji) = 0._wp + ENDIF + ! + zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) - zdv_pnd + wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zdv_pnd * rhow * r1_rdtice + ! + END DO + ! + END SUBROUTINE pnd_CST + + + SUBROUTINE pnd_LEV( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE pnd_LEV *** + !! + !! ** Purpose : Compute melt pond evolution + !! + !! ** Method : A fraction of meltwater is accumulated in ponds and sent to ocean when surface is freezing + !! We work with volumes and then redistribute changes into thickness and concentration + !! assuming linear relationship between the two. + !! + !! ** Action : - pond growth: Vp = Vp + dVmelt --- from Holland et al 2012 --- + !! dVmelt = (1-r)/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i + !! dh_i = meltwater from ice surface melt + !! dh_s = meltwater from snow melt + !! (1-r) = fraction of melt water that is not flushed + !! + !! - limtations: a_ip must not exceed (1-r)*a_i + !! h_ip must not exceed 0.5*h_i + !! + !! - pond shrinking: + !! if lids: Vp = Vp -dH * a_ip + !! dH = lid thickness change. Retrieved from this eq.: --- from Flocco et al 2010 --- + !! + !! rhoi * Lf * dH/dt = ki * MAX(Tp-Tsu,0) / H + !! H = lid thickness + !! Lf = latent heat of fusion + !! Tp = -2C + !! + !! And solved implicitely as: + !! H(t+dt)**2 -H(t) * H(t+dt) -ki * (Tp-Tsu) * dt / (rhoi*Lf) = 0 + !! + !! if no lids: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) --- from Holland et al 2012 --- + !! + !! - Flushing: w = -perm/visc * rho_oce * grav * Hp / Hi * flush --- from Flocco et al 2007 --- + !! perm = permability of sea-ice + correction from Hunke et al 2012 (flush) + !! visc = water viscosity + !! Hp = height of top of the pond above sea-level + !! Hi = ice thickness thru which there is flushing + !! flush= correction otherwise flushing is excessive + !! + !! - Corrections: remove melt ponds when lid thickness is 10 times the pond thickness + !! + !! - pond thickness and area is retrieved from pond volume assuming a linear relationship between h_ip and a_ip: + !! a_ip/a_i = a_ip_frac = h_ip / zaspect + !! + !! ** Tunable parameters : ln_pnd_lids, rn_apnd_max, rn_apnd_min, rn_pnd_flush + !! + !! ** Note : mostly stolen from CICE but not only. These are between level-ice ponds and CESM ponds. + !! + !! ** References : Flocco and Feltham (JGR, 2007) + !! Flocco et al (JGR, 2010) + !! Holland et al (J. Clim, 2012) + !! Hunke et al (OM 2012) + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + REAL(wp), DIMENSION(nlay_i) :: ztmp ! temporary array + !! + REAL(wp), PARAMETER :: zaspect = 0.8_wp ! pond aspect ratio + REAL(wp), PARAMETER :: zTp = -2._wp ! reference temperature + REAL(wp), PARAMETER :: zvisc = 1.79e-3_wp ! water viscosity + !! + REAL(wp) :: zfr_mlt, zdv_mlt, zdv_avail ! fraction and volume of available meltwater retained for melt ponding + REAL(wp) :: zdv_frz, zdv_flush ! Amount of melt pond that freezes, flushes + REAL(wp) :: zdv_pnd ! Amount of water going into the ponds & lids + REAL(wp) :: zhp ! heigh of top of pond lid wrt ssh + REAL(wp) :: zv_ip_max ! max pond volume allowed + REAL(wp) :: zdT ! zTp-t_su + REAL(wp) :: zsbr, ztmelts ! Brine salinity + REAL(wp) :: zperm ! permeability of sea ice + REAL(wp) :: zfac, zdum ! temporary arrays + REAL(wp) :: z1_rhow, z1_aspect, z1_Tp ! inverse + !! + INTEGER :: ji, jk ! loop indices + !!------------------------------------------------------------------- + ! + z1_rhow = 1._wp / rhow + z1_aspect = 1._wp / zaspect + z1_Tp = 1._wp / zTp + + DO ji = ki1, ki2 + ! + zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) + ! !----------------------------------------------------! + IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < 0.01_wp ) THEN ! Case ice thickness < rn_himin or tiny ice fraction ! + ! !----------------------------------------------------! + !--- Remove ponds on thin ice or tiny ice fractions + a_ip_1d(ji) = 0._wp + h_ip_1d(ji) = 0._wp + h_il_1d(ji) = 0._wp + ! !--------------------------------! + ELSE ! Case ice thickness >= rn_himin ! + ! !--------------------------------! + v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! retrieve volume from thickness + v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) + ! + !------------------! + ! case ice melting ! + !------------------! + ! + !--- available meltwater for melt ponding (zdv_avail) ---! + zdv_avail = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) ! > 0 + zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) ! = ( 1 - r ) = fraction of melt water that is not flushed + zdv_mlt = MAX( 0._wp, zfr_mlt * zdv_avail ) ! max for roundoff errors? + ! + !--- overflow ---! + ! + ! area driven overflow + ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume + ! a_ip_max = zfr_mlt * a_i + ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: + zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect + zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) + + ! depth driven overflow + ! If pond depth exceeds half the ice thickness then reduce the pond volume + ! h_ip_max = 0.5 * h_i + ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: + zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji) + zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) + + !--- Pond growing ---! + v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt + ! + !--- Lid melting ---! + IF( ln_pnd_lids ) v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0 + ! + !-------------------! + ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0) + !-------------------! + ! + zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) + ! + !--- Pond contraction (due to refreezing) ---! + IF( ln_pnd_lids ) THEN + ! + !--- Lid growing and subsequent pond shrinking ---! + zdv_frz = - 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0 + & SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rdt_ice / (rLfus * rhow) ) ) ! max for roundoff errors + + ! Lid growing + v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_frz ) + + ! Pond shrinking + v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zdv_frz ) + + ELSE + zdv_frz = v_ip_1d(ji) * ( EXP( 0.01_wp * zdT * z1_Tp ) - 1._wp ) ! Holland 2012 (eq. 6) + ! Pond shrinking + v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zdv_frz ) + ENDIF + ! + !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac + ! v_ip = h_ip * a_ip + ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip) + a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i + h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) + + !------------------------------------------------! + ! Pond drainage through brine network (flushing) ! + !------------------------------------------------! + ! height of top of the pond above sea-level + zhp = ( h_i_1d(ji) * ( rau0 - rhoi ) + h_ip_1d(ji) * ( rau0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rau0 + + ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010) + DO jk = 1, nlay_i + ! MV Assur is inconsistent with SI3 + !!zsbr = - 1.2_wp & + !! & - 21.8_wp * ( t_i_1d(ji,jk) - rt0 ) & + !! & - 0.919_wp * ( t_i_1d(ji,jk) - rt0 )**2 & + !! & - 0.0178_wp * ( t_i_1d(ji,jk) - rt0 )**3 + !!ztmp(jk) = sz_i_1d(ji,jk) / zsbr + ! MV linear expression more consistent & simpler: zsbr = - ( t_i_1d(ji,jk) - rt0 ) / rTmlt + ztmelts = -rTmlt * sz_i_1d(ji,jk) + ztmp(jk) = ztmelts / MIN( ztmelts, t_i_1d(ji,jk) - rt0 ) + END DO + zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 ) + + ! Do the drainage using Darcy's law + zdv_flush = -zperm * rau0 * grav * zhp * rdt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji) * rn_pnd_flush ! tunable rn_pnd_flush from hunke et al. (2013) + zdv_flush = MAX( zdv_flush, -v_ip_1d(ji) ) + v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush + + !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac + a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i + h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) + + !--- Corrections and lid thickness ---! + IF( ln_pnd_lids ) THEN + !--- retrieve lid thickness from volume ---! + IF( a_ip_1d(ji) > 0.01_wp ) THEN ; h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji) + ELSE ; h_il_1d(ji) = 0._wp + ENDIF + !--- remove ponds if lids are much larger than ponds ---! + IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN + a_ip_1d(ji) = 0._wp + h_ip_1d(ji) = 0._wp + h_il_1d(ji) = 0._wp + ENDIF + ENDIF + +!!$ ! diagnostics: dvpnd = mlt+rnf+frz+drn +!!$ diag_dvpn_mlt_1d(ji) = diag_dvpn_mlt_1d(ji) + rhow * zdv_avail * r1_rdtice ! > 0, surface melt input +!!$ diag_dvpn_rnf_1d(ji) = diag_dvpn_rnf_1d(ji) + rhow * ( zdv_mlt - zdv_avail ) * r1_rdtice ! < 0, runoff +!!$ diag_dvpn_frz_1d(ji) = diag_dvpn_frz_1d(ji) + rhow * zdv_frz * r1_rdtice ! < 0, shrinking +!!$ diag_dvpn_drn_1d(ji) = diag_dvpn_drn_1d(ji) + rhow * zdv_flush * r1_rdtice ! < 0, drainage + ! + ENDIF + ! + zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) - zdv_pnd + wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zdv_pnd * rhow * r1_rdtice + ! + END DO + ! + END SUBROUTINE pnd_LEV + + + SUBROUTINE ice_thd_pnd_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_pnd_init *** + !! + !! ** Purpose : Physical constants and parameters linked to melt ponds + !! over sea ice + !! + !! ** Method : Read the namthd_pnd namelist and check the melt pond + !! parameter values called at the first timestep (nit000) + !! + !! ** input : Namelist namthd_pnd + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer + !! + NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, rn_pnd_flush, & + & ln_pnd_CST , rn_apnd, rn_hpnd, & + & ln_pnd_lids, ln_pnd_alb + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd_pnd in reference namelist : Melt Ponds + READ ( numnam_ice_ref, namthd_pnd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd_pnd in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd_pnd in configuration namelist : Melt Ponds + READ ( numnam_ice_cfg, namthd_pnd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd_pnd in configuration namelist' ) + IF(lwm) WRITE ( numoni, namthd_pnd ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_pnd_init: ice parameters for melt ponds' + WRITE(numout,*) '~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namicethd_pnd:' + WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd + WRITE(numout,*) ' Level ice melt pond scheme ln_pnd_LEV = ', ln_pnd_LEV + WRITE(numout,*) ' Minimum ice fraction that contributes to melt ponds rn_apnd_min = ', rn_apnd_min + WRITE(numout,*) ' Maximum ice fraction that contributes to melt ponds rn_apnd_max = ', rn_apnd_max + WRITE(numout,*) ' Pond flushing efficiency rn_pnd_flush = ', rn_pnd_flush + WRITE(numout,*) ' Constant ice melt pond scheme ln_pnd_CST = ', ln_pnd_CST + WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd + WRITE(numout,*) ' Prescribed pond depth rn_hpnd = ', rn_hpnd + WRITE(numout,*) ' Frozen lids on top of melt ponds ln_pnd_lids = ', ln_pnd_lids + WRITE(numout,*) ' Melt ponds affect albedo or not ln_pnd_alb = ', ln_pnd_alb + ENDIF + ! + ! !== set the choice of ice pond scheme ==! + ioptio = 0 + IF( .NOT.ln_pnd ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndNO ; ENDIF + IF( ln_pnd_CST ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndCST ; ENDIF + IF( ln_pnd_LEV ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndLEV ; ENDIF + IF( ioptio /= 1 ) & + & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV or ln_pnd_CST)' ) + ! + SELECT CASE( nice_pnd ) + CASE( np_pndNO ) + IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF + IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when no ponds' ) ; ENDIF + CASE( np_pndCST ) + IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when constant ponds' ) ; ENDIF + END SELECT + ! + END SUBROUTINE ice_thd_pnd_init + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_pnd \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_pnd.mod b/V4.0/nemo_sources/src/ICE/icethd_pnd.mod new file mode 100644 index 0000000000000000000000000000000000000000..4777650e9bcd3189c75d8390289ba00ff9130439 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_pnd.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_sal.F90 b/V4.0/nemo_sources/src/ICE/icethd_sal.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8d5f8f9fad89249726c33d140610cc38e024f544 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_sal.F90 @@ -0,0 +1,173 @@ +MODULE icethd_sal + !!====================================================================== + !! *** MODULE icethd_sal *** + !! sea-ice : computation of salinity variations in the ice + !!====================================================================== + !! History : - ! 2003-05 (M. Vancoppenolle) original code 1-D + !! 3.0 ! 2005-12 (M. Vancoppenolle) adapted to the 3-D version + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!--------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_sal : salinity variations in the ice + !! ice_thd_sal_init : initialization + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE icevar ! sea-ice: operations + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_sal ! called by icethd + PUBLIC ice_thd_sal_init ! called by ice_init + + ! ** namelist (namthd_sal) ** + REAL(wp) :: rn_sal_gd ! restoring salinity for gravity drainage [PSU] + REAL(wp) :: rn_time_gd ! restoring time constant for gravity drainage (= 20 days) [s] + REAL(wp) :: rn_sal_fl ! restoring salinity for flushing [PSU] + REAL(wp) :: rn_time_fl ! restoring time constant for gravity drainage (= 10 days) [s] + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_sal.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_sal( ktid, ki1, ki2, kpti, ld_sal ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_sal *** + !! + !! ** Purpose : computes new salinities in the ice + !! + !! ** Method : 3 possibilities + !! -> nn_icesal = 1 -> Sice = cst [ice salinity constant in both time & space] + !! -> nn_icesal = 2 -> Sice = S(z,t) [Vancoppenolle et al. 2005] + !! -> nn_icesal = 3 -> Sice = S(z) [multiyear ice] + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + LOGICAL, INTENT(in) :: ld_sal ! gravity drainage and flushing or not + ! + INTEGER :: ji ! dummy loop indices + REAL(wp) :: zs_sni, zds ! local scalars + REAL(wp) :: z1_time_gd, z1_time_fl + !!--------------------------------------------------------------------- + ! + SELECT CASE ( nn_icesal ) + ! + ! !---------------------------------------------! + CASE( 2 ) ! time varying salinity with linear profile ! + ! !---------------------------------------------! + z1_time_gd = rdt_ice / rn_time_gd + z1_time_fl = rdt_ice / rn_time_fl + ! + DO ji = ki1, ki2 + ! + IF( h_i_1d(ji) > 0._wp ) THEN + ! + ! --- Update ice salinity from snow-ice and bottom growth --- ! + zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi ! salinity of snow ice + zds = ( zs_sni - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice + zds = zds + ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog (ji) / h_i_1d(ji) ! bottom growth + ! update salinity (nb: salt flux already included in icethd_dh) + s_i_1d(ji) = s_i_1d(ji) + zds + ! + ! --- Update ice salinity from brine drainage and flushing --- ! + IF( ld_sal ) THEN + IF( t_su_1d(ji) >= rt0 ) THEN ! flushing (summer time) + zds = - MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl + ELSEIF( t_su_1d(ji) <= t_bo_1d(ji) ) THEN ! gravity drainage + zds = - MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd + ELSE + zds = 0._wp + ENDIF + ! update salinity + s_i_1d(ji) = s_i_1d(ji) + zds + ! salt flux + sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_rdtice + ENDIF + ! + ! --- salinity must stay inbounds --- ! + zds = MAX( 0._wp, rn_simin - s_i_1d(ji) ) ! > 0 if s_i < simin + zds = zds + MIN( 0._wp, rn_simax - s_i_1d(ji) ) ! < 0 if s_i > simax + ! update salinity + s_i_1d(ji) = s_i_1d(ji) + zds + ! salt flux + sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_rdtice + ! + ENDIF + ! + END DO + ! + ! Salinity profile + CALL ice_var_salprof1d( ki1, ki2 ) + ! + ! !----------------------------------------! + CASE( 3 ) ! constant salinity with a fixed profile ! (Schwarzacher (1959) multiyear salinity profile (mean = 2.30) + ! !----------------------------------------! + CALL ice_var_salprof1d( ki1, ki2 ) + ! + END SELECT + ! + END SUBROUTINE ice_thd_sal + + + SUBROUTINE ice_thd_sal_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_sal_init *** + !! + !! ** Purpose : initialization of ice salinity parameters + !! + !! ** Method : Read the namthd_sal namelist and check the parameter + !! values called at the first timestep (nit000) + !! + !! ** input : Namelist namthd_sal + !!------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namthd_sal/ nn_icesal, rn_icesal, rn_sal_gd, rn_time_gd, & + & rn_sal_fl, rn_time_fl, rn_simax , rn_simin + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd_sal in reference namelist : Ice salinity + READ ( numnam_ice_ref, namthd_sal, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd_sal in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd_sal in configuration namelist : Ice salinity + READ ( numnam_ice_cfg, namthd_sal, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd_sal in configuration namelist' ) + IF(lwm) WRITE ( numoni, namthd_sal ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_sal_init : Ice parameters for salinity ' + WRITE(numout,*) '~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namthd_sal:' + WRITE(numout,*) ' switch for salinity nn_icesal = ', nn_icesal + WRITE(numout,*) ' bulk salinity value if nn_icesal = 1 rn_icesal = ', rn_icesal + WRITE(numout,*) ' restoring salinity for gravity drainage rn_sal_gd = ', rn_sal_gd + WRITE(numout,*) ' restoring time for for gravity drainage rn_time_gd = ', rn_time_gd + WRITE(numout,*) ' restoring salinity for flushing rn_sal_fl = ', rn_sal_fl + WRITE(numout,*) ' restoring time for flushing rn_time_fl = ', rn_time_fl + WRITE(numout,*) ' Maximum tolerated ice salinity rn_simax = ', rn_simax + WRITE(numout,*) ' Minimum tolerated ice salinity rn_simin = ', rn_simin + ENDIF + ! + END SUBROUTINE ice_thd_sal_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy Module No SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_sal \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_sal.mod b/V4.0/nemo_sources/src/ICE/icethd_sal.mod new file mode 100644 index 0000000000000000000000000000000000000000..403598d62ba14689c9e395e7f389df4a2f72bc96 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_sal.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_zdf.F90 b/V4.0/nemo_sources/src/ICE/icethd_zdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9ab2e7555b876edadd5dd0ddeb10473534082c2b --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_zdf.F90 @@ -0,0 +1,135 @@ +MODULE icethd_zdf + !!====================================================================== + !! *** MODULE icethd_zdf *** + !! sea-ice: master routine for vertical heat diffusion in sea ice + !!====================================================================== + !! History : 4.0 ! 2018 (C. Rousset) Original code SI3 + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_zdf : select the appropriate routine for vertical heat diffusion calculation + !! ice_thd_zdf_BL99 : heat diffusion from Bitz and Lipscomb 1999 + !! ice_thd_zdf_init : initialization + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants (ocean directory) + USE ice ! sea-ice: variables + USE icethd_zdf_BL99 ! sea-ice: vertical diffusion (Bitz and Lipscomb, 1999) + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_zdf ! called by icethd + PUBLIC ice_thd_zdf_init ! called by icestp + + INTEGER :: nice_zdf ! Choice of the type of vertical heat diffusion formulation + ! ! associated indices: + INTEGER, PARAMETER :: np_BL99 = 1 ! Bitz and Lipscomb (1999) +!! INTEGER, PARAMETER :: np_XXXX = 2 + + !!** namelist (namthd_zdf) ** + LOGICAL :: ln_zdf_BL99 ! Heat diffusion follows Bitz and Lipscomb (1999) + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_zdf.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_zdf( ktid, ki1, ki2, kpti ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_zdf *** + !! + !! ** Purpose : select the appropriate routine for the computation + !! of vertical diffusion + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + ! + SELECT CASE ( nice_zdf ) ! Choose the vertical heat diffusion solver + ! + ! !-------------! + CASE( np_BL99 ) ! BL99 solver ! + ! !-------------! + IF( .NOT.ln_cndflx ) THEN ! No conduction flux ==> default option + CALL ice_thd_zdf_BL99( ktid, ki1, ki2, kpti, np_cnd_OFF ) + ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN ! Conduction flux as surface boundary condition ==> Met Office default option + CALL ice_thd_zdf_BL99( ktid, ki1, ki2, kpti, np_cnd_ON ) + ELSEIF( ln_cndflx .AND. ln_cndemulate ) THEN ! Conduction flux is emulated + CALL ice_thd_zdf_BL99( ktid, ki1, ki2, kpti, np_cnd_EMU ) + CALL ice_thd_zdf_BL99( ktid, ki1, ki2, kpti, np_cnd_ON ) + ENDIF + ! + END SELECT + ! + END SUBROUTINE ice_thd_zdf + + + SUBROUTINE ice_thd_zdf_init + !!----------------------------------------------------------------------- + !! *** ROUTINE ice_thd_zdf_init *** + !! + !! ** Purpose : Physical constants and parameters associated with + !! ice thermodynamics + !! + !! ** Method : Read the namthd_zdf namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namelist namthd_zdf + !!------------------------------------------------------------------- + INTEGER :: ios, ioptio ! Local integer + !! + NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, & + & rn_kappa_i, rn_kappa_s, rn_kappa_smlt, rn_kappa_sdry, ln_zdf_chkcvg, rn_oiht + !!------------------------------------------------------------------- + ! + REWIND( numnam_ice_ref ) ! Namelist namthd_zdf in reference namelist : Ice thermodynamics + READ ( numnam_ice_ref, namthd_zdf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd_zdf in reference namelist' ) + REWIND( numnam_ice_cfg ) ! Namelist namthd_zdf in configuration namelist : Ice thermodynamics + READ ( numnam_ice_cfg, namthd_zdf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd_zdf in configuration namelist' ) + IF(lwm) WRITE( numoni, namthd_zdf ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ice_thd_zdf_init: Ice vertical heat diffusion' + WRITE(numout,*) '~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namthd_zdf:' + WRITE(numout,*) ' Bitz and Lipscomb (1999) formulation ln_zdf_BL99 = ', ln_zdf_BL99 + WRITE(numout,*) ' thermal conductivity in the ice (Untersteiner 1964) ln_cndi_U64 = ', ln_cndi_U64 + WRITE(numout,*) ' thermal conductivity in the ice (Pringle et al 2007) ln_cndi_P07 = ', ln_cndi_P07 + WRITE(numout,*) ' thermal conductivity in the snow rn_cnd_s = ', rn_cnd_s + WRITE(numout,*) ' heat flux from ocean to sea ice rn_oiht = ', rn_oiht + WRITE(numout,*) ' extinction radiation parameter in sea ice rn_kappa_i = ', rn_kappa_i + WRITE(numout,*) ' extinction radiation parameter in snw (nn_qtrice=0) rn_kappa_s = ', rn_kappa_s + WRITE(numout,*) ' extinction radiation parameter in melt snw (nn_qtrice=1) rn_kappa_smlt = ', rn_kappa_smlt + WRITE(numout,*) ' extinction radiation parameter in dry snw (nn_qtrice=1) rn_kappa_sdry = ', rn_kappa_sdry + WRITE(numout,*) ' check convergence of heat diffusion scheme ln_zdf_chkcvg = ', ln_zdf_chkcvg + ENDIF + ! + IF ( ( ln_cndi_U64 .AND. ln_cndi_P07 ) .OR. ( .NOT. ln_cndi_U64 .AND. .NOT. ln_cndi_P07 ) ) THEN + CALL ctl_stop( 'ice_thd_zdf_init: choose 1 and only 1 formulation for thermal conduction (ln_cndi_U64 or ln_cndi_P07)' ) + ENDIF + ! !== set the choice of ice vertical thermodynamic formulation ==! + ioptio = 0 + IF( ln_zdf_BL99 ) THEN ; ioptio = ioptio + 1 ; nice_zdf = np_BL99 ; ENDIF ! BL99 thermodynamics (linear liquidus + constant thermal properties) +!! IF( ln_zdf_XXXX ) THEN ; ioptio = ioptio + 1 ; nice_zdf = np_XXXX ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ice_thd_init: one and only one ice thermo option has to be defined ' ) + ! + END SUBROUTINE ice_thd_zdf_init + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy Module No SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_zdf \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_zdf.mod b/V4.0/nemo_sources/src/ICE/icethd_zdf.mod new file mode 100644 index 0000000000000000000000000000000000000000..90664b2a983e465d9a65a1f8056fe9135e9967c1 Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_zdf.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.F90 b/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ea31f3e22566ae6b32089e445df7125a7fee9b83 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.F90 @@ -0,0 +1,976 @@ +MODULE icethd_zdf_BL99 + !!====================================================================== + !! *** MODULE icethd_zdf_BL99 *** + !! sea-ice: vertical heat diffusion in sea ice (computation of temperatures) + !!====================================================================== + !! History : ! 2003-02 (M. Vancoppenolle) original 1D code + !! ! 2005-06 (M. Vancoppenolle) 3d version + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_thd_zdf_BL99 : vertical diffusion computation + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants (ocean directory) + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + USE icevar ! sea-ice: operations + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_thd_zdf_BL99 ! called by icethd_zdf + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icethd_zdf_bl99.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_thd_zdf_BL99( ktid, ki1, ki2, kpti, k_cnd ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_thd_zdf_BL99 *** + !! + !! ** Purpose : computes the time evolution of snow and sea-ice temperature + !! profiles, using the original Bitz and Lipscomb (1999) algorithm + !! + !! ** Method : solves the heat equation diffusion with a Neumann boundary + !! condition at the surface and a Dirichlet one at the bottom. + !! Solar radiation is partially absorbed into the ice. + !! The specific heat and thermal conductivities depend on ice + !! salinity and temperature to take into account brine pocket + !! melting. The numerical scheme is an iterative Crank-Nicolson + !! on a non-uniform multilayer grid in the ice and snow system. + !! + !! The successive steps of this routine are + !! 1. initialization of ice-snow layers thicknesses + !! 2. Internal absorbed and transmitted radiation + !! Then iterative procedure begins + !! 3. Thermal conductivity + !! 4. Kappa factors + !! 5. specific heat in the ice + !! 6. eta factors + !! 7. surface flux computation + !! 8. tridiagonal system terms + !! 9. solving the tridiagonal system with Gauss elimination + !! Iterative procedure ends according to a criterion on evolution + !! of temperature + !! 10. Fluxes at the interfaces + !! + !! ** Inputs / Ouputs : (global commons) + !! surface temperature : t_su_1d + !! ice/snow temperatures : t_i_1d, t_s_1d + !! ice salinities : sz_i_1d + !! number of layers in the ice/snow : nlay_i, nlay_s + !! total ice/snow thickness : h_i_1d, h_s_1d + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, ki1, ki2, kpti ! OpenMP variables + INTEGER, INTENT(in) :: k_cnd ! conduction flux (off, on, emulated) + ! + INTEGER :: ji, jk ! spatial loop index + INTEGER :: jm ! current reference number of equation + INTEGER :: jm_mint, jm_maxt + INTEGER :: iconv ! number of iterations in iterative procedure + INTEGER :: iconv_max = 50 ! max number of iterations in iterative procedure + ! + INTEGER, DIMENSION(jpij) :: jm_min ! reference number of top equation + INTEGER, DIMENSION(jpij) :: jm_max ! reference number of bottom equation + + LOGICAL, DIMENSION(jpij) :: l_T_converged ! true when T converges (per grid point) + ! + REAL(wp) :: zg1s = 2._wp ! for the tridiagonal system + REAL(wp) :: zg1 = 2._wp ! + REAL(wp) :: zgamma = 18009._wp ! for specific heat + REAL(wp) :: zbeta = 0.117_wp ! for thermal conductivity (could be 0.13) + REAL(wp) :: zkimin = 0.10_wp ! minimum ice thermal conductivity + REAL(wp) :: ztsu_err = 1.e-5_wp ! range around which t_su is considered at 0C + REAL(wp) :: zdti_bnd = 1.e-4_wp ! maximal authorized error on temperature + REAL(wp) :: zhs_ssl = 0.03_wp ! surface scattering layer in the snow + REAL(wp) :: zhi_ssl = 0.10_wp ! surface scattering layer in the ice + REAL(wp) :: zh_min = 1.e-3_wp ! minimum ice/snow thickness for conduction + REAL(wp) :: ztmelts ! ice melting temperature + REAL(wp) :: zdti_max ! current maximal error on temperature + REAL(wp) :: zcpi ! Ice specific heat + REAL(wp) :: zhfx_err, zdq ! diag errors on heat + ! + REAL(wp), DIMENSION(jpij) :: zraext_s ! extinction coefficient of radiation in the snow + REAL(wp), DIMENSION(jpij) :: ztsub ! surface temperature at previous iteration + REAL(wp), DIMENSION(jpij) :: zh_i, z1_h_i ! ice layer thickness + REAL(wp), DIMENSION(jpij) :: zh_s, z1_h_s ! snow layer thickness + REAL(wp), DIMENSION(jpij) :: zqns_ice_b ! solar radiation absorbed at the surface + REAL(wp), DIMENSION(jpij) :: zfnet ! surface flux function + REAL(wp), DIMENSION(jpij) :: zdqns_ice_b ! derivative of the surface flux function + ! + REAL(wp), DIMENSION(jpij ) :: ztsuold ! Old surface temperature in the ice + REAL(wp), DIMENSION(jpij,nlay_i) :: ztiold ! Old temperature in the ice + REAL(wp), DIMENSION(jpij,nlay_s) :: ztsold ! Old temperature in the snow + REAL(wp), DIMENSION(jpij,nlay_i) :: ztib ! Temporary temperature in the ice to check the convergence + REAL(wp), DIMENSION(jpij,nlay_s) :: ztsb ! Temporary temperature in the snow to check the convergence + REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i ! Ice thermal conductivity + REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i_cp ! copy + REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradtr_i ! Radiation transmitted through the ice + REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradab_i ! Radiation absorbed in the ice + REAL(wp), DIMENSION(jpij,0:nlay_i) :: zkappa_i ! Kappa factor in the ice + REAL(wp), DIMENSION(jpij,0:nlay_i) :: zeta_i ! Eta factor in the ice + REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradtr_s ! Radiation transmited through the snow + REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradab_s ! Radiation absorbed in the snow + REAL(wp), DIMENSION(jpij,0:nlay_s) :: zkappa_s ! Kappa factor in the snow + REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeta_s ! Eta factor in the snow + REAL(wp), DIMENSION(jpij) :: zkappa_comb ! Combined snow and ice surface conductivity + REAL(wp), DIMENSION(jpij) :: zq_ini ! diag errors on heat + REAL(wp), DIMENSION(jpij) :: zghe ! G(he), th. conduct enhancement factor, mono-cat + REAL(wp), DIMENSION(jpij) :: za_s_fra ! ice fraction covered by snow + REAL(wp), DIMENSION(jpij) :: isnow ! snow presence (1) or not (0) + REAL(wp), DIMENSION(jpij) :: isnow_comb ! snow presence for met-office + REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindterm ! 'Ind'ependent term + REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindtbis ! Temporary 'ind'ependent term + REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zdiagbis ! Temporary 'dia'gonal term + REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1,3) :: ztrid ! Tridiagonal system terms + ! + ! Mono-category + REAL(wp) :: zepsilon ! determines thres. above which computation of G(h) is done + REAL(wp) :: zhe ! dummy factor + REAL(wp) :: zcnd_i ! mean sea ice thermal conductivity + !!------------------------------------------------------------------ + ! + ! --- diag error on heat diffusion - PART 1 --- ! + DO ji = ki1, ki2 + zq_ini(ji) = ( SUM( e_i_1d(ji,1:nlay_i) ) * h_i_1d(ji) * r1_nlay_i + & + & SUM( e_s_1d(ji,1:nlay_s) ) * h_s_1d(ji) * r1_nlay_s ) + END DO + + ! calculate ice fraction covered by snow for radiation + CALL ice_var_snwfra( h_s_1d(ki1:ki2), za_s_fra(ki1:ki2) ) + + !------------------ + ! 1) Initialization + !------------------ + ! + ! extinction radiation in the snow + IF ( nn_qtrice == 0 ) THEN ! constant + zraext_s(ki1:ki2) = rn_kappa_s + ELSEIF( nn_qtrice == 1 ) THEN ! depends on melting/freezing conditions + WHERE( t_su_1d(ki1:ki2) < rt0 ) ; zraext_s(ki1:ki2) = rn_kappa_sdry ! no surface melting + ELSEWHERE ; zraext_s(ki1:ki2) = rn_kappa_smlt ! surface melting + END WHERE + ENDIF + ! + ! thicknesses + DO ji = ki1, ki2 + ! ice thickness + IF( h_i_1d(ji) > 0._wp ) THEN + zh_i (ji) = MAX( zh_min , h_i_1d(ji) ) * r1_nlay_i ! set a minimum thickness for conduction + z1_h_i(ji) = 1._wp / zh_i(ji) ! it must be very small + ELSE + zh_i (ji) = 0._wp + z1_h_i(ji) = 0._wp + ENDIF + ! snow thickness + IF( h_s_1d(ji) > 0._wp ) THEN + zh_s (ji) = MAX( zh_min , h_s_1d(ji) ) * r1_nlay_s ! set a minimum thickness for conduction + z1_h_s(ji) = 1._wp / zh_s(ji) ! it must be very small + isnow (ji) = 1._wp + ELSE + zh_s (ji) = 0._wp + z1_h_s(ji) = 0._wp + isnow (ji) = 0._wp + ENDIF + ! for Met-Office + IF( h_s_1d(ji) < zh_min ) THEN + isnow_comb(ji) = h_s_1d(ji) / zh_min + ELSE + isnow_comb(ji) = 1._wp + ENDIF + END DO + ! clem: we should apply correction on snow thickness to take into account snow fraction + ! it must be a distribution, so it is a bit complicated + ! + ! Store initial temperatures and non solar heat fluxes + IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN + ztsub (ki1:ki2) = t_su_1d(ki1:ki2) ! surface temperature at iteration n-1 + ztsuold (ki1:ki2) = t_su_1d(ki1:ki2) ! surface temperature initial value + t_su_1d (ki1:ki2) = MIN( t_su_1d(ki1:ki2), rt0 - ztsu_err ) ! required to leave the choice between melting or not + zdqns_ice_b(ki1:ki2) = dqns_ice_1d(ki1:ki2) ! derivative of incoming nonsolar flux + zqns_ice_b (ki1:ki2) = qns_ice_1d(ki1:ki2) ! store previous qns_ice_1d value + ! + ENDIF + ! + ztsold (ki1:ki2,:) = t_s_1d(ki1:ki2,:) ! Old snow temperature + ztiold (ki1:ki2,:) = t_i_1d(ki1:ki2,:) ! Old ice temperature + + !------------- + ! 2) Radiation + !------------- + ! --- Transmission/absorption of solar radiation in the ice --- ! + zradtr_s(ki1:ki2,0) = qtr_ice_top_1d(ki1:ki2) + DO jk = 1, nlay_s + DO ji = ki1, ki2 + ! ! radiation transmitted below the layer-th snow layer + zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s(ji) * MAX( 0._wp, zh_s(ji) * REAL(jk) - zhs_ssl ) ) + ! ! radiation absorbed by the layer-th snow layer + zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk) + END DO + END DO + ! + zradtr_i(ki1:ki2,0) = zradtr_s(ki1:ki2,nlay_s) * za_s_fra(ki1:ki2) + qtr_ice_top_1d(ki1:ki2) * ( 1._wp - za_s_fra(ki1:ki2) ) + DO jk = 1, nlay_i + DO ji = ki1, ki2 + ! ! radiation transmitted below the layer-th ice layer + zradtr_i(ji,jk) = za_s_fra(ji) * zradtr_s(ji,nlay_s) & ! part covered by snow + & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zh_min ) ) & + & + ( 1._wp - za_s_fra(ji) ) * qtr_ice_top_1d(ji) & ! part snow free + & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zhi_ssl ) ) + ! ! radiation absorbed by the layer-th ice layer + zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk) + END DO + END DO + ! + qtr_ice_bot_1d(ki1:ki2) = zradtr_i(ki1:ki2,nlay_i) ! record radiation transmitted below the ice + ! + iconv = 0 ! number of iterations + ! + l_T_converged(:) = .FALSE. + ! Convergence calculated until all sub-domain grid points have converged + ! Calculations keep going for all grid points until sub-domain convergence (vectorisation optimisation) + ! but values are not taken into account (results independant of MPI partitioning) + ! + ! !============================! + DO WHILE ( ( .NOT. ALL (l_T_converged(ki1:ki2)) ) .AND. iconv < iconv_max ) ! Iterative procedure begins ! + ! !============================! + iconv = iconv + 1 + ! + ztib(ki1:ki2,:) = t_i_1d(ki1:ki2,:) + ztsb(ki1:ki2,:) = t_s_1d(ki1:ki2,:) + ! + !-------------------------------- + ! 3) Sea ice thermal conductivity + !-------------------------------- + IF( ln_cndi_U64 ) THEN !-- Untersteiner (1964) formula: k = k0 + beta.S/T + ! + DO ji = ki1, ki2 + ztcond_i_cp(ji,0) = rcnd_i + zbeta * sz_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 ) + ztcond_i_cp(ji,nlay_i) = rcnd_i + zbeta * sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji) - rt0 ) + END DO + DO jk = 1, nlay_i-1 + DO ji = ki1, ki2 + ztcond_i_cp(ji,jk) = rcnd_i + zbeta * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / & + & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) + END DO + END DO + ! + ELSEIF( ln_cndi_P07 ) THEN !-- Pringle et al formula: k = k0 + beta1.S/T - beta2.T + ! + DO ji = ki1, ki2 + ztcond_i_cp(ji,0) = rcnd_i + 0.09_wp * sz_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 ) & + & - 0.011_wp * ( t_i_1d(ji,1) - rt0 ) + ztcond_i_cp(ji,nlay_i) = rcnd_i + 0.09_wp * sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji) - rt0 ) & + & - 0.011_wp * ( t_bo_1d(ji) - rt0 ) + END DO + DO jk = 1, nlay_i-1 + DO ji = ki1, ki2 + ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / & + & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) & + & - 0.011_wp * ( 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) + END DO + END DO + ! + ENDIF + + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + DO ji = ki1, ki2 + IF ( .NOT. l_T_converged(ji) ) & + ztcond_i(ji,:) = MAX( zkimin, ztcond_i_cp(ji,:) ) + END DO + ! + !--- G(he) : enhancement of thermal conductivity in mono-category case + ! Computation of effective thermal conductivity G(h) + ! Used in mono-category case only to simulate an ITD implicitly + ! Fichefet and Morales Maqueda, JGR 1997 + zghe(ki1:ki2) = 1._wp + ! + IF( ln_virtual_itd ) THEN + ! + zepsilon = 0.1_wp + DO ji = ki1, ki2 + zcnd_i = SUM( ztcond_i(ji,:) ) / REAL( nlay_i+1, wp ) ! Mean sea ice thermal conductivity + zhe = ( rn_cnd_s * h_i_1d(ji) + zcnd_i * h_s_1d(ji) ) / ( rn_cnd_s + zcnd_i ) ! Effective thickness he (zhe) + IF( zhe >= zepsilon * 0.5_wp * EXP(1._wp) ) & + & zghe(ji) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( 2._wp * zhe / zepsilon ) ) ) ! G(he) + END DO + ! + ENDIF + ! + !----------------- + ! 4) kappa factors + !----------------- + !--- Snow + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + DO jk = 0, nlay_s-1 + DO ji = ki1, ki2 + IF ( .NOT. l_T_converged(ji) ) & + zkappa_s(ji,jk) = zghe(ji) * rn_cnd_s * z1_h_s(ji) + END DO + END DO + DO ji = ki1, ki2 ! Snow-ice interface + IF ( .NOT. l_T_converged(ji) ) & + zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) & + & / ( 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) ) + END DO + + !--- Ice + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + DO jk = 0, nlay_i + DO ji = ki1, ki2 + IF ( .NOT. l_T_converged(ji) ) & + zkappa_i(ji,jk) = zghe(ji) * ztcond_i(ji,jk) * z1_h_i(ji) + END DO + END DO + DO ji = ki1, ki2 ! Snow-ice interface + IF ( .NOT. l_T_converged(ji) ) THEN + ! Calculate combined surface snow and ice conductivity to pass through the coupler (met-office) + zkappa_comb(ji) = isnow_comb(ji) * zkappa_s(ji,0) + ( 1._wp - isnow_comb(ji) ) * zkappa_i(ji,0) + ! If there is snow then use the same snow-ice interface conductivity for the top layer of ice + IF( h_s_1d(ji) > 0._wp ) zkappa_i(ji,0) = zkappa_s(ji,nlay_s) + ENDIF + END DO + ! + !-------------------------------------- + ! 5) Sea ice specific heat, eta factors + !-------------------------------------- + DO jk = 1, nlay_i + DO ji = ki1, ki2 + zcpi = rcpi + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 ) + zeta_i(ji,jk) = rdt_ice * r1_rhoi * z1_h_i(ji) / zcpi + END DO + END DO + + DO jk = 1, nlay_s + DO ji = ki1, ki2 + zeta_s(ji,jk) = rdt_ice * r1_rhos * r1_rcpi * z1_h_s(ji) + END DO + END DO + ! + !----------------------------------------! + ! ! + ! Conduction flux is off or emulated ! + ! ! + !----------------------------------------! + ! + IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN + ! + ! ==> The original BL99 temperature computation is used + ! (with qsr_ice, qns_ice and dqns_ice as inputs) + ! + !---------------------------- + ! 6) surface flux computation + !---------------------------- + ! update of the non solar flux according to the update in T_su + DO ji = ki1, ki2 + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + IF ( .NOT. l_T_converged(ji) ) & + qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) ) + END DO + + DO ji = ki1, ki2 + zfnet(ji) = qsr_ice_1d(ji) - qtr_ice_top_1d(ji) + qns_ice_1d(ji) ! net heat flux = net - transmitted solar + non solar + END DO + ! + !---------------------------- + ! 7) tridiagonal system terms + !---------------------------- + ! layer denotes the number of the layer in the snow or in the ice + ! jm denotes the reference number of the equation in the tridiagonal + ! system, terms of tridiagonal system are indexed as following : + ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one + + ! ice interior terms (top equation has the same form as the others) + ztrid (ki1:ki2,:,:) = 0._wp + zindterm(ki1:ki2,:) = 0._wp + zindtbis(ki1:ki2,:) = 0._wp + zdiagbis(ki1:ki2,:) = 0._wp + + DO jm = nlay_s + 2, nlay_s + nlay_i + DO ji = ki1, ki2 + jk = jm - nlay_s - 1 + ztrid (ji,jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1) + ztrid (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) ) + ztrid (ji,jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk) + zindterm(ji,jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk) + END DO + END DO + + jm = nlay_s + nlay_i + 1 + DO ji = ki1, ki2 + ! ice bottom term + ztrid (ji,jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1) + ztrid (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 ) + ztrid (ji,jm,3) = 0._wp + zindterm(ji,jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * & + & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) ) + END DO + + DO ji = ki1, ki2 + ! !---------------------! + IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells ! + ! !---------------------! + ! snow interior terms (bottom equation has the same form as the others) + DO jm = 3, nlay_s + 1 + jk = jm - 1 + ztrid (ji,jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1) + ztrid (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) ) + ztrid (ji,jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk) + zindterm(ji,jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk) + END DO + + ! case of only one layer in the ice (ice equation is altered) + IF( nlay_i == 1 ) THEN + ztrid (ji,nlay_s+2,3) = 0._wp + zindterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji) + ENDIF + + IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting + + jm_min(ji) = 1 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! surface equation + ztrid (ji,1,1) = 0._wp + ztrid (ji,1,2) = zdqns_ice_b(ji) - zg1s * zkappa_s(ji,0) + ztrid (ji,1,3) = zg1s * zkappa_s(ji,0) + zindterm(ji,1) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji) + + ! first layer of snow equation + ztrid (ji,2,1) = - zeta_s(ji,1) * zkappa_s(ji,0) * zg1s + ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s ) + ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1) + zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * zradab_s(ji,1) + + ELSE !-- case 2 : surface is melting + ! + jm_min(ji) = 2 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! first layer of snow equation + ztrid (ji,2,1) = 0._wp + ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s ) + ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1) + zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + zkappa_s(ji,0) * zg1s * t_su_1d(ji) ) + ENDIF + ! !---------------------! + ELSE ! cells without snow ! + ! !---------------------! + ! + IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting + ! + jm_min(ji) = nlay_s + 1 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! surface equation + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * zg1 + ztrid (ji,jm_min(ji),3) = zkappa_i(ji,0) * zg1 + zindterm(ji,jm_min(ji)) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji) + + ! first layer of ice equation + ztrid (ji,jm_min(ji)+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * zg1 + ztrid (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 ) + ztrid (ji,jm_min(ji)+1,3) = - zeta_i(ji,1) * zkappa_i(ji,1) + zindterm(ji,jm_min(ji)+1) = ztiold(ji,1) + zeta_i(ji,1) * zradab_i(ji,1) + + ! case of only one layer in the ice (surface & ice equations are altered) + IF( nlay_i == 1 ) THEN + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * 2._wp + ztrid (ji,jm_min(ji),3) = zkappa_i(ji,0) * 2._wp + ztrid (ji,jm_min(ji)+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp + ztrid (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) ) + ztrid (ji,jm_min(ji)+1,3) = 0._wp + zindterm(ji,jm_min(ji)+1) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji)) + ENDIF + + ELSE !-- case 2 : surface is melting + + jm_min(ji) = nlay_s + 2 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! first layer of ice equation + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 ) + ztrid (ji,jm_min(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1) + zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,0) * zg1 * t_su_1d(ji)) + + ! case of only one layer in the ice (surface & ice equations are altered) + IF( nlay_i == 1 ) THEN + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) ) + ztrid (ji,jm_min(ji),3) = 0._wp + zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) ) & + & + t_su_1d(ji) * zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp + ENDIF + + ENDIF + ENDIF + ! + zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji)) + zdiagbis(ji,jm_min(ji)) = ztrid (ji,jm_min(ji),2) + ! + END DO + ! + !------------------------------ + ! 8) tridiagonal system solving + !------------------------------ + ! Solve the tridiagonal system with Gauss elimination method. + ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984 +!!$ jm_maxt = 0 +!!$ jm_mint = nlay_i+5 +!!$ DO ji = ki1, ki2 +!!$ jm_mint = MIN(jm_min(ji),jm_mint) +!!$ jm_maxt = MAX(jm_max(ji),jm_maxt) +!!$ END DO +!!$ !!clem SNWLAY => check why LIM1D does not get this loop. Is nlay_i+5 correct? +!!$ +!!$ DO jk = jm_mint+1, jm_maxt +!!$ DO ji = ki1, ki2 +!!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) +!!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) +!!$ zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) +!!$ END DO +!!$ END DO + ! clem: maybe one should find a way to reverse this loop for mpi performance + DO ji = ki1, ki2 + jm_mint = jm_min(ji) + jm_maxt = jm_max(ji) + DO jm = jm_mint+1, jm_maxt + zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) + zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) + END DO + END DO + + ! ice temperatures + DO ji = ki1, ki2 + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + IF ( .NOT. l_T_converged(ji) ) & + t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji)) + END DO + + DO jm = nlay_i + nlay_s, nlay_s + 2, -1 + DO ji = ki1, ki2 + jk = jm - nlay_s - 1 + IF ( .NOT. l_T_converged(ji) ) & + t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm) + END DO + END DO + + ! snow temperatures + DO ji = ki1, ki2 + ! Variables used after iterations + ! Value must be frozen after convergence for MPP independance reason + IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & + & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) + END DO + !!clem SNWLAY + DO jm = nlay_s, 2, -1 + DO ji = ki1, ki2 + jk = jm - 1 + IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & + & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm) + END DO + END DO + + ! surface temperature + DO ji = ki1, ki2 + IF( .NOT. l_T_converged(ji) ) THEN + ztsub(ji) = t_su_1d(ji) + IF( t_su_1d(ji) < rt0 ) THEN + t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) * & + & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji)) + ENDIF + ENDIF + END DO + ! + !-------------------------------------------------------------- + ! 9) Has the scheme converged?, end of the iterative procedure + !-------------------------------------------------------------- + ! check that nowhere it has started to melt + ! zdti_max is a measure of error, it has to be under zdti_bnd + + DO ji = ki1, ki2 + + zdti_max = 0._wp + + IF ( .NOT. l_T_converged(ji) ) THEN + + t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , rt0 ) , rt0 - 100._wp ) + zdti_max = MAX( zdti_max, ABS( t_su_1d(ji) - ztsub(ji) ) ) + + IF( h_s_1d(ji) > 0._wp ) THEN + DO jk = 1, nlay_s + t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) + zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) + END DO + ENDIF + + DO jk = 1, nlay_i + ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0 + t_i_1d(ji,jk) = MAX( MIN( t_i_1d(ji,jk), ztmelts ), rt0 - 100._wp ) + zdti_max = MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) ) + END DO + + ! convergence test + IF( ln_zdf_chkcvg ) THEN + tice_cvgerr_1d(ji) = zdti_max + tice_cvgstp_1d(ji) = REAL(iconv) + ENDIF + + IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. + + ENDIF + + END DO + + !----------------------------------------! + ! ! + ! Conduction flux is on ! + ! ! + !----------------------------------------! + ! + ELSEIF( k_cnd == np_cnd_ON ) THEN + ! + ! ==> we use a modified BL99 solver with conduction flux (qcn_ice) as forcing term + ! + !---------------------------- + ! 7) tridiagonal system terms + !---------------------------- + ! layer denotes the number of the layer in the snow or in the ice + ! jm denotes the reference number of the equation in the tridiagonal + ! system, terms of tridiagonal system are indexed as following : + ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one + + ! ice interior terms (top equation has the same form as the others) + ztrid (ki1:ki2,:,:) = 0._wp + zindterm(ki1:ki2,:) = 0._wp + zindtbis(ki1:ki2,:) = 0._wp + zdiagbis(ki1:ki2,:) = 0._wp + + DO jm = nlay_s + 2, nlay_s + nlay_i + DO ji = ki1, ki2 + jk = jm - nlay_s - 1 + ztrid (ji,jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1) + ztrid (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) ) + ztrid (ji,jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk) + zindterm(ji,jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk) + END DO + ENDDO + + jm = nlay_s + nlay_i + 1 + DO ji = ki1, ki2 + ! ice bottom term + ztrid (ji,jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1) + ztrid (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 ) + ztrid (ji,jm,3) = 0._wp + zindterm(ji,jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * & + & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) ) + ENDDO + + DO ji = ki1, ki2 + ! !---------------------! + IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells ! + ! !---------------------! + ! snow interior terms (bottom equation has the same form as the others) + DO jm = 3, nlay_s + 1 + jk = jm - 1 + ztrid (ji,jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1) + ztrid (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) ) + ztrid (ji,jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk) + zindterm(ji,jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk) + END DO + + ! case of only one layer in the ice (ice equation is altered) + IF ( nlay_i == 1 ) THEN + ztrid (ji,nlay_s+2,3) = 0._wp + zindterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji) + ENDIF + + jm_min(ji) = 2 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! first layer of snow equation + ztrid (ji,2,1) = 0._wp + ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * zkappa_s(ji,1) + ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1) + zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + qcn_ice_1d(ji) ) + + ! !---------------------! + ELSE ! cells without snow ! + ! !---------------------! + jm_min(ji) = nlay_s + 2 + jm_max(ji) = nlay_i + nlay_s + 1 + + ! first layer of ice equation + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1) + ztrid (ji,jm_min(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1) + zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + qcn_ice_1d(ji) ) + + ! case of only one layer in the ice (surface & ice equations are altered) + IF( nlay_i == 1 ) THEN + ztrid (ji,jm_min(ji),1) = 0._wp + ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1) + ztrid (ji,jm_min(ji),3) = 0._wp + zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * & + & ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) + qcn_ice_1d(ji) ) + ENDIF + + ENDIF + ! + zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji)) + zdiagbis(ji,jm_min(ji)) = ztrid (ji,jm_min(ji),2) + ! + END DO + ! + !------------------------------ + ! 8) tridiagonal system solving + !------------------------------ + ! Solve the tridiagonal system with Gauss elimination method. + ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984 +!!$ jm_maxt = 0 +!!$ jm_mint = nlay_i+5 +!!$ DO ji = ki1, ki2 +!!$ jm_mint = MIN(jm_min(ji),jm_mint) +!!$ jm_maxt = MAX(jm_max(ji),jm_maxt) +!!$ END DO +!!$ +!!$ DO jk = jm_mint+1, jm_maxt +!!$ DO ji = ki1, ki2 +!!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) +!!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) +!!$ zindtbis(ji,jm) = zindterm(ji,jm) - ztrid(ji,jm,1) * zindtbis(ji,jm-1) / zdiagbis(ji,jm-1) +!!$ END DO +!!$ END DO + ! clem: maybe one should find a way to reverse this loop for mpi performance + DO ji = ki1, ki2 + jm_mint = jm_min(ji) + jm_maxt = jm_max(ji) + DO jm = jm_mint+1, jm_maxt + zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) + zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) + END DO + END DO + + ! ice temperatures + DO ji = ki1, ki2 + ! Variable used after iterations + ! Value must be frozen after convergence for MPP independance reason + IF ( .NOT. l_T_converged(ji) ) & + t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji)) + END DO + + DO jm = nlay_i + nlay_s, nlay_s + 2, -1 + DO ji = ki1, ki2 + IF ( .NOT. l_T_converged(ji) ) THEN + jk = jm - nlay_s - 1 + t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm) + ENDIF + END DO + END DO + + ! snow temperatures + DO ji = ki1, ki2 + ! Variables used after iterations + ! Value must be frozen after convergence for MPP independance reason + IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & + & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) + END DO + !!clem SNWLAY + DO jm = nlay_s, 2, -1 + DO ji = ki1, ki2 + jk = jm - 1 + IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & + & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm) + END DO + END DO + ! + !-------------------------------------------------------------- + ! 9) Has the scheme converged?, end of the iterative procedure + !-------------------------------------------------------------- + ! check that nowhere it has started to melt + ! zdti_max is a measure of error, it has to be under zdti_bnd + + DO ji = ki1, ki2 + + zdti_max = 0._wp + + IF ( .NOT. l_T_converged(ji) ) THEN + + IF( h_s_1d(ji) > 0._wp ) THEN + DO jk = 1, nlay_s + t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) + zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) + END DO + ENDIF + + DO jk = 1, nlay_i + ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0 + t_i_1d(ji,jk) = MAX( MIN( t_i_1d(ji,jk), ztmelts ), rt0 - 100._wp ) + zdti_max = MAX ( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) ) + END DO + + ! convergence test + IF( ln_zdf_chkcvg ) THEN + tice_cvgerr_1d(ji) = zdti_max + tice_cvgstp_1d(ji) = REAL(iconv) + ENDIF + + IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. + + ENDIF + + END DO + + ENDIF ! k_cnd + + END DO ! End of the do while iterative procedure + ! + !----------------------------- + ! 10) Fluxes at the interfaces + !----------------------------- + ! + ! --- calculate conduction fluxes (positive downward) + ! bottom ice conduction flux + DO ji = ki1, ki2 + qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) + END DO + ! surface ice conduction flux + IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN + ! + DO ji = ki1, ki2 + qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) & + & - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * ( t_i_1d(ji,1) - t_su_1d(ji) ) + END DO + ! + ELSEIF( k_cnd == np_cnd_ON ) THEN + ! + DO ji = ki1, ki2 + qcn_ice_top_1d(ji) = qcn_ice_1d(ji) + END DO + ! + ENDIF + ! surface ice temperature + IF( k_cnd == np_cnd_ON .AND. ln_cndemulate ) THEN + ! + DO ji = ki1, ki2 + t_su_1d(ji) = ( qcn_ice_top_1d(ji) + isnow(ji) * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) + & + & ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * t_i_1d(ji,1) ) & + & / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 ) + t_su_1d(ji) = MAX( MIN( t_su_1d(ji), rt0 ), rt0 - 100._wp ) ! cap t_su + END DO + ! + ENDIF + ! + ! --- Diagnose the heat loss due to changing non-solar / conduction flux --- ! + ! + IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN + ! + DO ji = ki1, ki2 + hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( qns_ice_1d(ji) - zqns_ice_b(ji) ) * a_i_1d(ji) + END DO + ! + ENDIF + ! + ! --- Diagnose the heat loss due to non-fully converged temperature solution (should not be above 10-4 W-m2) --- ! + ! + IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_ON ) THEN + + CALL ice_var_enthalpy( ki1, ki2 ) + + ! zhfx_err = correction on the diagnosed heat flux due to non-convergence of the algorithm used to solve heat equation + DO ji = ki1, ki2 + zdq = - zq_ini(ji) + ( SUM( e_i_1d(ji,1:nlay_i) ) * h_i_1d(ji) * r1_nlay_i + & + & SUM( e_s_1d(ji,1:nlay_s) ) * h_s_1d(ji) * r1_nlay_s ) + + IF( k_cnd == np_cnd_OFF ) THEN + + IF( t_su_1d(ji) < rt0 ) THEN ! case T_su < 0degC + zhfx_err = ( qns_ice_1d(ji) + qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - qcn_ice_bot_1d(ji) & + & + zdq * r1_rdtice ) * a_i_1d(ji) + ELSE ! case T_su = 0degC + zhfx_err = ( qcn_ice_top_1d(ji) + qtr_ice_top_1d(ji) - zradtr_i(ji,nlay_i) - qcn_ice_bot_1d(ji) & + & + zdq * r1_rdtice ) * a_i_1d(ji) + ENDIF + + ELSEIF( k_cnd == np_cnd_ON ) THEN + + zhfx_err = ( qcn_ice_top_1d(ji) + qtr_ice_top_1d(ji) - zradtr_i(ji,nlay_i) - qcn_ice_bot_1d(ji) & + & + zdq * r1_rdtice ) * a_i_1d(ji) + + ENDIF + ! + ! total heat sink to be sent to the ocean + hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) + zhfx_err + ! + ! hfx_dif = Heat flux diagnostic of sensible heat used to warm/cool ice in W.m-2 + hfx_dif_1d(ji) = hfx_dif_1d(ji) - zdq * r1_rdtice * a_i_1d(ji) + ! + END DO + ! + ENDIF + ! + !-------------------------------------------------------------------- + ! 11) reset inner snow and ice temperatures, update conduction fluxes + !-------------------------------------------------------------------- + ! effective conductivity and 1st layer temperature (needed by Met Office) + ! this is a conductivity at mid-layer, hence the factor 2 + DO ji = ki1, ki2 + IF( h_i_1d(ji) >= zhi_ssl ) THEN + cnd_ice_1d(ji) = 2._wp * zkappa_comb(ji) + !!cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0) + ELSE + cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) / zhi_ssl ! cnd_ice is capped by: cond_i/zhi_ssl + ENDIF + t1_ice_1d(ji) = isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) + END DO + ! + IF( k_cnd == np_cnd_EMU ) THEN + ! Restore temperatures to their initial values + t_s_1d (ki1:ki2,:) = ztsold (ki1:ki2,:) + t_i_1d (ki1:ki2,:) = ztiold (ki1:ki2,:) + qcn_ice_1d(ki1:ki2) = qcn_ice_top_1d(ki1:ki2) + ENDIF + ! + ! --- SIMIP diagnostics + ! + DO ji = ki1, ki2 + !--- Snow-ice interfacial temperature (diagnostic SIMIP) + IF( h_s_1d(ji) >= zhs_ssl ) THEN + t_si_1d(ji) = ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji,nlay_s) & + & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) & + & / ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i & + & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s ) + ELSE + t_si_1d(ji) = t_su_1d(ji) + ENDIF + END DO + ! + END SUBROUTINE ice_thd_zdf_BL99 + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy Module No SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icethd_zdf_BL99 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.mod b/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.mod new file mode 100644 index 0000000000000000000000000000000000000000..b0c92ca258d571751858ac150bfb4d862cf3307b Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icethd_zdf_bl99.mod differ diff --git a/V4.0/nemo_sources/src/ICE/iceupdate.F90 b/V4.0/nemo_sources/src/ICE/iceupdate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..269822301ccd55fb9e1dc0e07de1125e93b07f03 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/iceupdate.F90 @@ -0,0 +1,515 @@ +MODULE iceupdate + !!====================================================================== + !! *** MODULE iceupdate *** + !! Sea-ice : computation of the flux at the sea ice/ocean interface + !!====================================================================== + !! History : 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_update_alloc : allocate the iceupdate arrays + !! ice_update_init : initialisation + !! ice_update_flx : updates mass, heat and salt fluxes at the ocean surface + !! ice_update_tau : update i- and j-stresses, and its modulus at the ocean surface + !!---------------------------------------------------------------------- + USE oce , ONLY : sshn, sshb + USE phycst ! physical constants + USE dom_oce ! ocean domain + USE ice ! sea-ice: variables + USE sbc_ice ! Surface boundary condition: ice fields + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbccpl ! Surface boundary condition: coupled interface + USE icealb ! sea-ice: albedo parameters + USE traqsr ! add penetration of solar flux in the calculation of heat budget + USE icectl ! sea-ice: control prints + USE zdfdrg , ONLY : ln_drgice_imp + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_update_init ! called by ice_init + PUBLIC ice_update_flx ! called by ice_stp + PUBLIC ice_update_tau ! called by ice_stp + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_oce, vtau_oce ! air-ocean surface i- & j-stress [N/m2] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmod_io ! modulus of the ice-ocean velocity [m/s] + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: iceupdate.F90 14590 2021-03-05 13:21:05Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION ice_update_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE ice_update_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( utau_oce(jpi,jpj), vtau_oce(jpi,jpj), tmod_io(jpi,jpj), STAT=ice_update_alloc ) + ! + CALL mpp_sum( 'iceupdate', ice_update_alloc ) + IF( ice_update_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_update_alloc: failed to allocate arrays' ) + ! + END FUNCTION ice_update_alloc + + + SUBROUTINE ice_update_flx( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_update_flx *** + !! + !! ** Purpose : Update the surface ocean boundary condition for heat + !! salt and mass over areas where sea-ice is non-zero + !! + !! ** Action : - computes the heat and freshwater/salt fluxes + !! at the ice-ocean interface. + !! - Update the ocean sbc + !! + !! ** Outputs : - qsr : sea heat flux: solar + !! - qns : sea heat flux: non solar + !! - emp : freshwater budget: volume flux + !! - sfx : salt flux + !! - fr_i : ice fraction + !! - tn_ice : sea-ice surface temperature + !! - alb_ice : sea-ice albedo (recomputed only for coupled mode) + !! + !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. + !! Tartinville et al. 2001 Ocean Modelling, 3, 95-108. + !! These refs are now obsolete since everything has been revised + !! The ref should be Rousset et al., 2015 + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + ! + INTEGER :: ji, jj, jl, jk ! dummy loop indices + INTEGER :: jj1, jj2 ! OpenMP loop index + INTEGER :: itid, ithreads ! OpenMP variables + REAL(wp) :: zqsr ! New solar flux received by the ocean + REAL(wp) :: ztf + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + !!--------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('iceupdate_flx') + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_update_flx: update fluxes (mass, salt and heat) at the ice-ocean interface' + WRITE(numout,*)'~~~~~~~~~~~~~~' + ENDIF + + !$omp parallel private(ji,jj1,jj2,itid,ithreads,zqsr,ztf) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! Net heat flux on top of the ice-ocean (W.m-2) + !---------------------------------------------- + IF( ln_cndflx ) THEN ! ice-atm interface = conduction (and melting) fluxes + qt_atm_oi(:,jj1:jj2) = ( 1._wp - at_i_b(:,jj1:jj2) ) * ( qns_oce(:,jj1:jj2) + qsr_oce(:,jj1:jj2) ) + qemp_oce(:,jj1:jj2) + & + & SUM( a_i_b * ( qcn_ice + qml_ice + qtr_ice_top ), dim=3 ) + qemp_ice(:,jj1:jj2) + ELSE ! ice-atm interface = solar and non-solar fluxes + qt_atm_oi(:,jj1:jj2) = qns_tot(:,jj1:jj2) + qsr_tot(:,jj1:jj2) + ENDIF + + ! --- case we bypass ice thermodynamics --- ! + IF( .NOT. ln_icethd ) THEN ! we suppose ice is impermeable => ocean is isolated from atmosphere + qt_atm_oi (:,jj1:jj2) = ( 1._wp - at_i_b(:,jj1:jj2) ) * ( qns_oce(:,jj1:jj2) + qsr_oce(:,jj1:jj2) ) + qemp_oce(:,jj1:jj2) + qt_oce_ai (:,jj1:jj2) = ( 1._wp - at_i_b(:,jj1:jj2) ) * qns_oce(:,jj1:jj2) + qemp_oce(:,jj1:jj2) + emp_ice (:,jj1:jj2) = 0._wp + qemp_ice (:,jj1:jj2) = 0._wp + qevap_ice (:,jj1:jj2,:) = 0._wp + ENDIF + + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + + ! Solar heat flux reaching the ocean (max) = zqsr (W.m-2) + !--------------------------------------------------- + IF( ln_cndflx ) THEN ! ice-atm interface = conduction (and melting) fluxes + zqsr = ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) + SUM( a_i_b (ji,jj,:) * qtr_ice_bot(ji,jj,:) ) + ELSE ! ice-atm interface = solar and non-solar fluxes + zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) + ENDIF + + ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2) + !--------------------------------------------------- + IF( ln_icethd ) THEN + qt_oce_ai(ji,jj) = qt_atm_oi(ji,jj) - hfx_sum(ji,jj) - hfx_bom(ji,jj) - hfx_bog(ji,jj) & + & - hfx_dif(ji,jj) - hfx_opw(ji,jj) - hfx_snw(ji,jj) & + & + hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) & + & + hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) + hfx_spr(ji,jj) + ENDIF + + ! New qsr and qns used to compute the oceanic heat flux at the next time step + !---------------------------------------------------------------------------- + ! if warming and some ice remains, then we suppose that the whole solar flux has been consumed to melt the ice + ! else ( cooling or no ice left ), then we suppose that no solar flux has been consumed + ! + IF( fhld(ji,jj) > 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN !-- warming and some ice remains + ! solar flux transmitted thru the 1st level of the ocean (i.e. not used by sea-ice) + qsr(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * ( 1._wp - frq_m(ji,jj) ) & + ! + solar flux transmitted thru ice and the 1st ocean level (also not used by sea-ice) + & + SUM( a_i_b(ji,jj,:) * qtr_ice_bot(ji,jj,:) ) * ( 1._wp - frq_m(ji,jj) ) + ! + ELSE !-- cooling or no ice left + qsr(ji,jj) = zqsr + ENDIF + ! + ! the non-solar is simply derived from the solar flux + !!!! Jean Bidlot: over the open ocean qns was already determined in sbc_blk + !!!! use it instead because it already contains the corrections for the cool skin and the warm layer + !!!! qns(ji,jj) = qt_oce_ai(ji,jj) - qsr(ji,jj) + IF (ll_blkecmwf) THEN + ztf = 0.5_wp + SIGN(0.5_wp, at_i_b(ji,jj)-0.001_wp) + qns(ji,jj) = (1._wp-ztf)*qns(ji,jj) + ztf*(qt_oce_ai(ji,jj) - qsr(ji,jj)) + ELSE + qns(ji,jj) = qt_oce_ai(ji,jj) - qsr(ji,jj) + ENDIF + ! + ! Mass flux at the atm. surface + !----------------------------------- + wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) + + ! Mass flux at the ocean surface + !------------------------------------ + ! ice-ocean mass flux + wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & + & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + + ! snw-ocean mass flux + wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) + + ! total mass flux at the ocean/ice interface + fmmflx(ji,jj) = - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model + emp (ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! atm-ocean + ice-ocean mass flux + + ! Salt flux at the ocean surface + !------------------------------------------ + sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) & + & + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) + + ! Mass of snow and ice per unit area + !---------------------------------------- + snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step + ! ! new mass per unit area + snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * ( vt_ip(ji,jj) + vt_il(ji,jj) ) ) + ! ! time evolution of snow+ice mass + snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice + + END DO + END DO + + ! Storing the transmitted variables + !---------------------------------- + fr_i (:,jj1:jj2) = at_i(:,jj1:jj2) ! Sea-ice fraction + tn_ice(:,jj1:jj2,:) = t_su(:,jj1:jj2,:) ! Ice surface temperature + !$omp end parallel + ! Snow/ice albedo (only if sent to coupler, useless in forced mode) + !------------------------------------------------------------------ + CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo + + ! + IF( lrst_ice ) THEN !* write snwice_mass fields in the restart file + CALL update_rst( 'WRITE', kt ) + ENDIF + ! + ! output all fluxes + !------------------ + ! + ! --- salt fluxes [kg/m2/s] --- ! + ! ! sfxice = sfxbog + sfxbom + sfxsum + sfxsni + sfxopw + sfxres + sfxdyn + sfxbri + sfxsub + sfxlam + IF( iom_use('sfxice' ) ) CALL iom_put( 'sfxice', sfx * 1.e-03 ) ! salt flux from total ice growth/melt + IF( iom_use('sfxbog' ) ) CALL iom_put( 'sfxbog', sfx_bog * 1.e-03 ) ! salt flux from bottom growth + IF( iom_use('sfxbom' ) ) CALL iom_put( 'sfxbom', sfx_bom * 1.e-03 ) ! salt flux from bottom melting + IF( iom_use('sfxsum' ) ) CALL iom_put( 'sfxsum', sfx_sum * 1.e-03 ) ! salt flux from surface melting + IF( iom_use('sfxlam' ) ) CALL iom_put( 'sfxlam', sfx_lam * 1.e-03 ) ! salt flux from lateral melting + IF( iom_use('sfxsni' ) ) CALL iom_put( 'sfxsni', sfx_sni * 1.e-03 ) ! salt flux from snow ice formation + IF( iom_use('sfxopw' ) ) CALL iom_put( 'sfxopw', sfx_opw * 1.e-03 ) ! salt flux from open water formation + IF( iom_use('sfxdyn' ) ) CALL iom_put( 'sfxdyn', sfx_dyn * 1.e-03 ) ! salt flux from ridging rafting + IF( iom_use('sfxbri' ) ) CALL iom_put( 'sfxbri', sfx_bri * 1.e-03 ) ! salt flux from brines + IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes + IF( iom_use('sfxsub' ) ) CALL iom_put( 'sfxsub', sfx_sub * 1.e-03 ) ! salt flux from sublimation + + ! --- mass fluxes [kg/m2/s] --- ! + CALL iom_put( 'emp_oce', emp_oce ) ! emp over ocean (taking into account the snow blown away from the ice) + CALL iom_put( 'emp_ice', emp_ice ) ! emp over ice (taking into account the snow blown away from the ice) + + ! ! vfxice = vfxbog + vfxbom + vfxsum + vfxsni + vfxopw + vfxdyn + vfxres + vfxlam + vfxpnd + CALL iom_put( 'vfxice' , wfx_ice ) ! mass flux from total ice growth/melt + CALL iom_put( 'vfxbog' , wfx_bog ) ! mass flux from bottom growth + CALL iom_put( 'vfxbom' , wfx_bom ) ! mass flux from bottom melt + CALL iom_put( 'vfxsum' , wfx_sum ) ! mass flux from surface melt + CALL iom_put( 'vfxlam' , wfx_lam ) ! mass flux from lateral melt + CALL iom_put( 'vfxsni' , wfx_sni ) ! mass flux from snow-ice formation + CALL iom_put( 'vfxopw' , wfx_opw ) ! mass flux from growth in open water + CALL iom_put( 'vfxdyn' , wfx_dyn ) ! mass flux from dynamics (ridging) + CALL iom_put( 'vfxres' , wfx_res ) ! mass flux from undiagnosed processes + CALL iom_put( 'vfxpnd' , wfx_pnd ) ! mass flux from melt ponds + CALL iom_put( 'vfxsub' , wfx_ice_sub ) ! mass flux from ice sublimation (ice-atm.) + CALL iom_put( 'vfxsub_err', wfx_err_sub ) ! "excess" of sublimation sent to ocean + + IF ( iom_use( 'vfxthin' ) ) THEN ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations + WHERE( hm_i(:,:) < 0.2 .AND. hm_i(:,:) > 0. ) ; z2d = wfx_bog + ELSEWHERE ; z2d = 0._wp + END WHERE + CALL iom_put( 'vfxthin', wfx_opw + z2d ) + ENDIF + + ! ! vfxsnw = vfxsnw_sni + vfxsnw_dyn + vfxsnw_sum + CALL iom_put( 'vfxsnw' , wfx_snw ) ! mass flux from total snow growth/melt + CALL iom_put( 'vfxsnw_sum' , wfx_snw_sum ) ! mass flux from snow melt at the surface + CALL iom_put( 'vfxsnw_sni' , wfx_snw_sni ) ! mass flux from snow melt during snow-ice formation + CALL iom_put( 'vfxsnw_dyn' , wfx_snw_dyn ) ! mass flux from dynamics (ridging) + CALL iom_put( 'vfxsnw_sub' , wfx_snw_sub ) ! mass flux from snow sublimation (ice-atm.) + CALL iom_put( 'vfxsnw_pre' , wfx_spr ) ! snow precip + + ! --- heat fluxes [W/m2] --- ! + ! ! qt_atm_oi - qt_oce_ai = hfxdhc - ( dihctrp + dshctrp ) + IF( iom_use('qsr_oce' ) ) CALL iom_put( 'qsr_oce' , qsr_oce * ( 1._wp - at_i_b ) ) ! solar flux at ocean surface + IF( iom_use('qns_oce' ) ) CALL iom_put( 'qns_oce' , qns_oce * ( 1._wp - at_i_b ) + qemp_oce ) ! non-solar flux at ocean surface + IF( iom_use('qsr_ice' ) ) CALL iom_put( 'qsr_ice' , SUM( qsr_ice * a_i_b, dim=3 ) ) ! solar flux at ice surface + IF( iom_use('qns_ice' ) ) CALL iom_put( 'qns_ice' , SUM( qns_ice * a_i_b, dim=3 ) + qemp_ice ) ! non-solar flux at ice surface + IF( iom_use('qtr_ice_bot') ) CALL iom_put( 'qtr_ice_bot', SUM( qtr_ice_bot * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice + IF( iom_use('qtr_ice_top') ) CALL iom_put( 'qtr_ice_top', SUM( qtr_ice_top * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice surface + IF( iom_use('qt_oce' ) ) CALL iom_put( 'qt_oce' , ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce ) + IF( iom_use('qt_ice' ) ) CALL iom_put( 'qt_ice' , SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 ) + qemp_ice ) + IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai' , qt_oce_ai * tmask(:,:,1) ) ! total heat flux at the ocean surface: interface oce-(ice+atm) + IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi' , qt_atm_oi * tmask(:,:,1) ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce) + IF( iom_use('qemp_oce' ) ) CALL iom_put( 'qemp_oce' , qemp_oce ) ! Downward Heat Flux from E-P over ocean + IF( iom_use('qemp_ice' ) ) CALL iom_put( 'qemp_ice' , qemp_ice ) ! Downward Heat Flux from E-P over ice + + ! heat fluxes from ice transformations + ! ! hfxdhc = hfxbog + hfxbom + hfxsum + hfxopw + hfxdif + hfxsnw - ( hfxthd + hfxdyn + hfxres + hfxsub + hfxspr ) + CALL iom_put ('hfxbog' , hfx_bog ) ! heat flux used for ice bottom growth + CALL iom_put ('hfxbom' , hfx_bom ) ! heat flux used for ice bottom melt + CALL iom_put ('hfxsum' , hfx_sum ) ! heat flux used for ice surface melt + CALL iom_put ('hfxopw' , hfx_opw ) ! heat flux used for ice formation in open water + CALL iom_put ('hfxdif' , hfx_dif ) ! heat flux used for ice temperature change + CALL iom_put ('hfxsnw' , hfx_snw ) ! heat flux used for snow melt + CALL iom_put ('hfxerr' , hfx_err_dif ) ! heat flux error after heat diffusion + + ! heat fluxes associated with mass exchange (freeze/melt/precip...) + CALL iom_put ('hfxthd' , hfx_thd ) ! + CALL iom_put ('hfxdyn' , hfx_dyn ) ! + CALL iom_put ('hfxres' , hfx_res ) ! + CALL iom_put ('hfxsub' , hfx_sub ) ! + CALL iom_put ('hfxspr' , hfx_spr ) ! Heat flux from snow precip heat content + + ! other heat fluxes + IF( iom_use('hfxsensib' ) ) CALL iom_put( 'hfxsensib' , qsb_ice_bot * at_i_b ) ! Sensible oceanic heat flux + IF( iom_use('hfxcndbot' ) ) CALL iom_put( 'hfxcndbot' , SUM( qcn_ice_bot * a_i_b, dim=3 ) ) ! Bottom conduction flux + IF( iom_use('hfxcndtop' ) ) CALL iom_put( 'hfxcndtop' , SUM( qcn_ice_top * a_i_b, dim=3 ) ) ! Surface conduction flux +!! IF( iom_use('hfxmelt' ) ) CALL iom_put( 'hfxmelt' , SUM( qml_ice * a_i_b, dim=3 ) ) ! Surface melt flux +!! IF( iom_use('hfxldmelt' ) ) CALL iom_put( 'hfxldmelt' , fhld * at_i_b ) ! Heat in lead for ice melting +!! IF( iom_use('hfxldgrow' ) ) CALL iom_put( 'hfxldgrow' , qlead * r1_rdtice ) ! Heat in lead for ice growth + + ! controls + !--------- +#if ! defined key_agrif + IF( ln_icediachk ) CALL ice_cons_final('iceupdate') ! conservation +#endif + IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 3, 'Final state ice_update') ! prints + IF( ln_ctl ) CALL ice_prt3D ('iceupdate') ! prints + IF( ln_timing ) CALL timing_stop ('iceupdate_flx') ! timing + ! + END SUBROUTINE ice_update_flx + + + SUBROUTINE ice_update_tau( kt, pu_oce, pv_oce ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_update_tau *** + !! + !! ** Purpose : Update the ocean surface stresses due to the ice + !! + !! ** Action : * at each ice time step (every nn_fsbc time step): + !! - compute the modulus of ice-ocean relative velocity + !! (*rho*Cd) at T-point (C-grid) or I-point (B-grid) + !! tmod_io = rhoco * | U_ice-U_oce | + !! - update the modulus of stress at ocean surface + !! taum = (1-a) * taum + a * tmod_io * | U_ice-U_oce | + !! * at each ocean time step (every kt): + !! compute linearized ice-ocean stresses as + !! Utau = tmod_io * | U_ice - pU_oce | + !! using instantaneous current ocean velocity (usually before) + !! + !! NB: - ice-ocean rotation angle no more allowed + !! - here we make an approximation: taum is only computed every ice time step + !! This avoids mutiple average to pass from T -> U,V grids and next from U,V grids + !! to T grid. taum is used in TKE and GLS, which should not be too sensitive to this approximaton... + !! + !! ** Outputs : - utau, vtau : surface ocean i- and j-stress (u- & v-pts) updated with ice-ocean fluxes + !! - taum : modulus of the surface ocean stress (T-point) updated with ice-ocean fluxes + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pu_oce, pv_oce ! surface ocean currents + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: jj1, jj2 ! OpenMP loop index + INTEGER :: itid, ithreads ! OpenMP variables + REAL(wp) :: zat_u, zutau_ice, zu_t, zmodt ! local scalar + REAL(wp) :: zat_v, zvtau_ice, zv_t, zrhoco ! - - + REAL(wp) :: zflagi ! - - + !!--------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('iceupdate_tau') + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'ice_update_tau: update stress at the ice-ocean interface' + WRITE(numout,*)'~~~~~~~~~~~~~~' + ENDIF + + !$omp parallel private(ji,jj1,jj2,itid,ithreads,& + !$omp & zat_u,zutau_ice,zu_t,zmodt,zat_v,zvtau_ice,zv_t,zrhoco) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + zrhoco = rau0 * rn_cio + ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step) + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) !* update the modulus of stress at ocean surface (T-point) + DO ji = fs_2, fs_jpim1 + ! ! 2*(U_ice-U_oce) at T-point + zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) + zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) + ! ! |U_ice-U_oce|^2 + zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t ) + ! ! update the ocean stress modulus + taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt + tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + utau_oce(:,jj1:jj2) = utau(:,jj1:jj2) !* save the air-ocean stresses at ice time-step + vtau_oce(:,jj1:jj2) = vtau(:,jj1:jj2) + ! + ENDIF + ! + ! !== every ocean time-step ==! + IF ( ln_drgice_imp ) THEN + ! Save drag with right sign to update top drag in the ocean implicit friction + rCdU_ice(:,jj1:jj2) = -r1_rau0 * tmod_io(:,jj1:jj2) * at_i(:,jj1:jj2) * tmask(:,:,1) + zflagi = 0._wp + ELSE + zflagi = 1._wp + ENDIF + ! + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,jpjm1) !* update the stress WITHOUT an ice-ocean rotation angle + DO ji = fs_2, fs_jpim1 ! Vect. Opt. + ! ice area at u and v-points + zat_u = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj ) * tmask(ji+1,jj ,1) ) & + & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj ,1) ) + zat_v = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji ,jj+1 ) * tmask(ji ,jj+1,1) ) & + & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji ,jj+1,1) ) + ! ! linearized quadratic drag formulation + zutau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - zflagi * pu_oce(ji,jj) ) + zvtau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - zflagi * pv_oce(ji,jj) ) + ! ! stresses at the ocean surface + utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice + vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice + END DO + END DO + !$omp end parallel + CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition + ! + IF( ln_timing ) CALL timing_stop('iceupdate_tau') + ! + END SUBROUTINE ice_update_tau + + + SUBROUTINE ice_update_init + !!------------------------------------------------------------------- + !! *** ROUTINE ice_update_init *** + !! + !! ** Purpose : allocate ice-ocean stress fields and read restarts + !! containing the snow & ice mass + !! + !!------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar + !!------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ice_update_init: ice-ocean stress init' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~' + ! + ! ! allocate ice_update array + IF( ice_update_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'ice_update_init : unable to allocate standard arrays' ) + ! + CALL update_rst( 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE ice_update_init + + + SUBROUTINE update_rst( cdrw, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rhg_evp_rst *** + !! + !! ** Purpose : Read or write RHG file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in) :: cdrw ! 'READ'/'WRITE' flag + INTEGER, OPTIONAL, INTENT(in) :: kt ! ice time-step + ! + INTEGER :: iter ! local integer + INTEGER :: id1 ! local integer + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialize + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + ! + id1 = iom_varid( numrir, 'snwice_mass' , ldstop = .FALSE. ) + ! + IF( id1 > 0 ) THEN ! fields exist + CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass' , snwice_mass ) + CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass_b', snwice_mass_b ) + ELSE ! start from rest + IF(lwp) WRITE(numout,*) ' ==>> previous run without snow-ice mass output then set it' + snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) ' ==>> start from rest: set the snow-ice mass' + snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- update-rst ----' + iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 + ! + CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass' , snwice_mass ) + CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass_b', snwice_mass_b ) + ! + ENDIF + ! + END SUBROUTINE update_rst + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE iceupdate \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/iceupdate.mod b/V4.0/nemo_sources/src/ICE/iceupdate.mod new file mode 100644 index 0000000000000000000000000000000000000000..af3d34791fa0a8c7a6f36acd072a115250a8bb8e Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/iceupdate.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icevar.F90 b/V4.0/nemo_sources/src/ICE/icevar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c0157c4b88396cebbd503cd790facd7bc8582aa8 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icevar.F90 @@ -0,0 +1,1422 @@ +MODULE icevar + !!====================================================================== + !! *** MODULE icevar *** + !! sea-ice: series of functions to transform or compute ice variables + !!====================================================================== + !! History : - ! 2006-01 (M. Vancoppenolle) Original code + !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! + !! There are three sets of variables + !! VGLO : global variables of the model + !! - v_i (jpi,jpj,jpl) + !! - v_s (jpi,jpj,jpl) + !! - a_i (jpi,jpj,jpl) + !! - t_s (jpi,jpj,jpl) + !! - e_i (jpi,jpj,nlay_i,jpl) + !! - e_s (jpi,jpj,nlay_s,jpl) + !! - sv_i(jpi,jpj,jpl) + !! - oa_i(jpi,jpj,jpl) + !! VEQV : equivalent variables sometimes used in the model + !! - h_i(jpi,jpj,jpl) + !! - h_s(jpi,jpj,jpl) + !! - t_i(jpi,jpj,nlay_i,jpl) + !! ... + !! VAGG : aggregate variables, averaged/summed over all + !! thickness categories + !! - vt_i(jpi,jpj) + !! - vt_s(jpi,jpj) + !! - at_i(jpi,jpj) + !! - st_i(jpi,jpj) + !! - et_s(jpi,jpj) total snow heat content + !! - et_i(jpi,jpj) total ice thermal content + !! - sm_i(jpi,jpj) mean ice salinity + !! - tm_i(jpi,jpj) mean ice temperature + !! - tm_s(jpi,jpj) mean snw temperature + !!---------------------------------------------------------------------- + !! ice_var_agg : integrate variables over layers and categories + !! ice_var_glo2eqv : transform from VGLO to VEQV + !! ice_var_eqv2glo : transform from VEQV to VGLO + !! ice_var_salprof : salinity profile in the ice + !! ice_var_salprof1d : salinity profile in the ice 1D + !! ice_var_zapsmall : remove very small area and volume + !! ice_var_zapneg : remove negative ice fields + !! ice_var_roundoff : remove negative values arising from roundoff erros + !! ice_var_bv : brine volume + !! ice_var_enthalpy : compute ice and snow enthalpies from temperature + !! ice_var_sshdyn : compute equivalent ssh in lead + !! ice_var_itd : convert N-cat to M-cat + !! ice_var_snwfra : fraction of ice covered by snow + !! ice_var_snwblow : distribute snow fall between ice and ocean + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants (ocean directory) + USE sbc_oce , ONLY : sss_m, ln_ice_embd, nn_fsbc + USE ice ! sea-ice: variables + USE ice1D ! sea-ice: thermodynamics variables + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_var_agg + PUBLIC ice_var_glo2eqv + PUBLIC ice_var_eqv2glo + PUBLIC ice_var_salprof + PUBLIC ice_var_salprof1d + PUBLIC ice_var_zapsmall + PUBLIC ice_var_zapneg + PUBLIC ice_var_roundoff + PUBLIC ice_var_bv + PUBLIC ice_var_enthalpy + PUBLIC ice_var_sshdyn + PUBLIC ice_var_itd + PUBLIC ice_var_snwfra + PUBLIC ice_var_snwblow + + INTERFACE ice_var_itd + MODULE PROCEDURE ice_var_itd_1c1c, ice_var_itd_Nc1c, ice_var_itd_1cMc, ice_var_itd_NcMc + END INTERFACE + + INTERFACE ice_var_snwfra + MODULE PROCEDURE ice_var_snwfra_1d, ice_var_snwfra_2d, ice_var_snwfra_3d, & + & ice_var_snwfra_2d_omp, ice_var_snwfra_3d_omp + + END INTERFACE + + INTERFACE ice_var_snwblow + MODULE PROCEDURE ice_var_snwblow_1d, ice_var_snwblow_2d + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icevar.F90 14026 2020-12-03 08:48:10Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_var_agg( kn ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_agg *** + !! + !! ** Purpose : aggregates ice-thickness-category variables to + !! all-ice variables, i.e. it turns VGLO into VAGG + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kn ! =1 state variables only + ! ! >1 state variables + others + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z1_vt_i, z1_vt_s + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: z1_at_i + !!------------------------------------------------------------------- + ! + ! ! integrated values + vt_i(:,:) = SUM( v_i (:,:,:) , dim=3 ) + vt_s(:,:) = SUM( v_s (:,:,:) , dim=3 ) + st_i(:,:) = SUM( sv_i(:,:,:) , dim=3 ) + at_i(:,:) = SUM( a_i (:,:,:) , dim=3 ) + et_s(:,:) = SUM( SUM( e_s (:,:,:,:), dim=4 ), dim=3 ) + et_i(:,:) = SUM( SUM( e_i (:,:,:,:), dim=4 ), dim=3 ) + ! + at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds + vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 ) + vt_il(:,:) = SUM( v_il(:,:,:), dim=3 ) + ! + ato_i(:,:) = 1._wp - at_i(:,:) ! open water fraction + + ! The following fields are calculated for diagnostics and outputs only + ! ==> Do not use them for other purposes + IF( kn > 1 ) THEN + ! + ALLOCATE( z1_at_i(jpi,jpj) , z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) ) + WHERE( at_i(:,:) > epsi20 ) ; z1_at_i(:,:) = 1._wp / at_i(:,:) + ELSEWHERE ; z1_at_i(:,:) = 0._wp + END WHERE + WHERE( vt_i(:,:) > epsi20 ) ; z1_vt_i(:,:) = 1._wp / vt_i(:,:) + ELSEWHERE ; z1_vt_i(:,:) = 0._wp + END WHERE + WHERE( vt_s(:,:) > epsi20 ) ; z1_vt_s(:,:) = 1._wp / vt_s(:,:) + ELSEWHERE ; z1_vt_s(:,:) = 0._wp + END WHERE + ! + ! ! mean ice/snow thickness + hm_i(:,:) = vt_i(:,:) * z1_at_i(:,:) + hm_s(:,:) = vt_s(:,:) * z1_at_i(:,:) + ! + ! ! mean temperature (K), salinity and age + tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) + tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) + om_i (:,:) = SUM( oa_i(:,:,:) , dim=3 ) * z1_at_i(:,:) + sm_i (:,:) = st_i(:,:) * z1_vt_i(:,:) + ! + tm_i(:,:) = 0._wp + tm_s(:,:) = 0._wp + DO jl = 1, jpl + DO jk = 1, nlay_i + tm_i(:,:) = tm_i(:,:) + r1_nlay_i * t_i (:,:,jk,jl) * v_i(:,:,jl) * z1_vt_i(:,:) + END DO + DO jk = 1, nlay_s + tm_s(:,:) = tm_s(:,:) + r1_nlay_s * t_s (:,:,jk,jl) * v_s(:,:,jl) * z1_vt_s(:,:) + END DO + END DO + ! + ! ! put rt0 where there is no ice + WHERE( at_i(:,:)<=epsi20 ) + tm_su(:,:) = rt0 + tm_si(:,:) = rt0 + tm_i (:,:) = rt0 + tm_s (:,:) = rt0 + END WHERE + ! + ! ! mean melt pond depth + WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) ; hm_il(:,:) = vt_il(:,:) / at_ip(:,:) + ELSEWHERE ; hm_ip(:,:) = 0._wp ; hm_il(:,:) = 0._wp + END WHERE + ! + DEALLOCATE( z1_at_i , z1_vt_i , z1_vt_s ) + ! + ENDIF + ! + END SUBROUTINE ice_var_agg + + + SUBROUTINE ice_var_glo2eqv + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_glo2eqv *** + !! + !! ** Purpose : computes equivalent variables as function of + !! global variables, i.e. it turns VGLO into VEQV + !!------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: ze_i ! local scalars + REAL(wp) :: ze_s! - - + REAL(dp) :: ztmelts, zbbb, zccc! - - + REAL(wp) :: zhmax! - - + REAL(dp) :: z1_zhmax! - - + REAL(wp) :: zlay_i, zlay_s ! - - + REAL(wp), PARAMETER :: zhl_max = 0.015_wp ! pond lid thickness above which the ponds disappear from the albedo calculation + REAL(wp), PARAMETER :: zhl_min = 0.005_wp ! pond lid thickness below which the full pond area is used in the albedo calculation + REAL(dp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i, z1_a_ip, za_s_fra + !!------------------------------------------------------------------- + +!!gm Question 2: It is possible to define existence of sea-ice in a common way between +!! ice area and ice volume ? +!! the idea is to be able to define one for all at the begining of this routine +!! a criteria for icy area (i.e. a_i > epsi20 and v_i > epsi20 ) + + !--------------------------------------------------------------- + ! Ice thickness, snow thickness, ice salinity, ice age and ponds + !--------------------------------------------------------------- + ! !--- inverse of the ice area + WHERE( a_i(:,:,:) > epsi20 ) ; z1_a_i(:,:,:) = 1._wp / a_i(:,:,:) + ELSEWHERE ; z1_a_i(:,:,:) = 0._wp + END WHERE + ! + WHERE( v_i(:,:,:) > epsi20 ) ; z1_v_i(:,:,:) = 1._wp / v_i(:,:,:) + ELSEWHERE ; z1_v_i(:,:,:) = 0._wp + END WHERE + ! + WHERE( a_ip(:,:,:) > epsi20 ) ; z1_a_ip(:,:,:) = 1._wp / a_ip(:,:,:) + ELSEWHERE ; z1_a_ip(:,:,:) = 0._wp + END WHERE + ! !--- ice thickness + h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:) + + zhmax = hi_max(jpl) + z1_zhmax = 1._wp / hi_max(jpl) + WHERE( h_i(:,:,jpl) > zhmax ) ! bound h_i by hi_max (i.e. 99 m) with associated update of ice area + h_i (:,:,jpl) = zhmax + a_i (:,:,jpl) = v_i(:,:,jpl) * z1_zhmax + z1_a_i(:,:,jpl) = zhmax * z1_v_i(:,:,jpl) + END WHERE + ! !--- snow thickness + h_s(:,:,:) = v_s (:,:,:) * z1_a_i(:,:,:) + ! !--- ice age + o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:) + ! !--- pond and lid thickness + h_ip(:,:,:) = v_ip(:,:,:) * z1_a_ip(:,:,:) + h_il(:,:,:) = v_il(:,:,:) * z1_a_ip(:,:,:) + ! !--- melt pond effective area (used for albedo) + a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:) + WHERE ( h_il(:,:,:) <= zhl_min ) ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) ! lid is very thin. Expose all the pond + ELSEWHERE( h_il(:,:,:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow + ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond + & ( zhl_max - h_il(:,:,:) ) / ( zhl_max - zhl_min ) + END WHERE + ! + CALL ice_var_snwfra( h_s, za_s_fra ) ! calculate ice fraction covered by snow + a_ip_eff = MIN( a_ip_eff, 1._wp - za_s_fra ) ! make sure (a_ip_eff + a_s_fra) <= 1 + ! + ! !--- salinity (with a minimum value imposed everywhere) + IF( nn_icesal == 2 ) THEN + WHERE( v_i(:,:,:) > epsi20 ) ; s_i(:,:,:) = MAX( rn_simin , MIN( rn_simax, sv_i(:,:,:) * z1_v_i(:,:,:) ) ) + ELSEWHERE ; s_i(:,:,:) = rn_simin + END WHERE + ENDIF + CALL ice_var_salprof ! salinity profile + + !------------------- + ! Ice temperature [K] (with a minimum value (rt0 - 100.)) + !------------------- + zlay_i = REAL( nlay_i , wp ) ! number of layers + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area + ! + ze_i = e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i ! Energy of melting e(S,T) [J.m-3] + ztmelts = - sz_i(ji,jj,jk,jl) * rTmlt ! Ice layer melt temperature [C] + ! Conversion q(S,T) -> T (second order equation) + zbbb = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus + zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) + t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0 ! [K] with bounds: -100 < t_i < ztmelts + ! + ELSE !--- no ice + t_i(ji,jj,jk,jl) = rt0 + ENDIF + END DO + END DO + END DO + END DO + + !-------------------- + ! Snow temperature [K] (with a minimum value (rt0 - 100.)) + !-------------------- + zlay_s = REAL( nlay_s , wp ) + DO jk = 1, nlay_s + WHERE( v_s(:,:,:) > epsi20 ) !--- icy area + t_s(:,:,jk,:) = rt0 + MAX( -100._wp , & + & MIN( r1_rcpi * ( -r1_rhos * ( e_s(:,:,jk,:) / v_s(:,:,:) * zlay_s ) + rLfus ) , 0._wp ) ) + ELSEWHERE !--- no ice + t_s(:,:,jk,:) = rt0 + END WHERE + END DO + ! + ! integrated values + vt_i (:,:) = SUM( v_i , dim=3 ) + vt_s (:,:) = SUM( v_s , dim=3 ) + at_i (:,:) = SUM( a_i , dim=3 ) + ! + END SUBROUTINE ice_var_glo2eqv + + + SUBROUTINE ice_var_eqv2glo + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_eqv2glo *** + !! + !! ** Purpose : computes global variables as function of + !! equivalent variables, i.e. it turns VEQV into VGLO + !!------------------------------------------------------------------- + ! + v_i (:,:,:) = h_i (:,:,:) * a_i (:,:,:) + v_s (:,:,:) = h_s (:,:,:) * a_i (:,:,:) + sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:) + v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) + v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) + ! + END SUBROUTINE ice_var_eqv2glo + + + SUBROUTINE ice_var_salprof + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_salprof *** + !! + !! ** Purpose : computes salinity profile in function of bulk salinity + !! + !! ** Method : If bulk salinity greater than zsi1, + !! the profile is assumed to be constant (S_inf) + !! If bulk salinity lower than zsi0, + !! the profile is linear with 0 at the surface (S_zero) + !! If it is between zsi0 and zsi1, it is a + !! alpha-weighted linear combination of s_inf and s_zero + !! + !! ** References : Vancoppenolle et al., 2007 + !!------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jl ! dummy loop index + REAL(wp) :: zsal, z1_dS + REAL(wp) :: zargtemp + REAL(dp) :: zs0, zs + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z_slope_s, zalpha ! case 2 only + REAL(wp), PARAMETER :: zsi0 = 3.5_wp + REAL(wp), PARAMETER :: zsi1 = 4.5_wp + !!------------------------------------------------------------------- + +!!gm Question: Remove the option 3 ? How many years since it last use ? + + SELECT CASE ( nn_icesal ) + ! + ! !---------------------------------------! + CASE( 1 ) ! constant salinity in time and space ! + ! !---------------------------------------! + sz_i(:,:,:,:) = rn_icesal + s_i (:,:,:) = rn_icesal + ! + ! !---------------------------------------------! + CASE( 2 ) ! time varying salinity with linear profile ! + ! !---------------------------------------------! + ! + ALLOCATE( z_slope_s(jpi,jpj,jpl) , zalpha(jpi,jpj,jpl) ) + ! + DO jl = 1, jpl + DO jk = 1, nlay_i + sz_i(:,:,jk,jl) = s_i(:,:,jl) + END DO + END DO + ! ! Slope of the linear profile + WHERE( h_i(:,:,:) > epsi20 ) ; z_slope_s(:,:,:) = 2._wp * s_i(:,:,:) / h_i(:,:,:) + ELSEWHERE ; z_slope_s(:,:,:) = 0._wp + END WHERE + ! + z1_dS = 1._wp / ( zsi1 - zsi0 ) + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + zalpha(ji,jj,jl) = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) ) + ! ! force a constant profile when SSS too low (Baltic Sea) + IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) ) zalpha(ji,jj,jl) = 0._wp + END DO + END DO + END DO + ! + ! Computation of the profile + DO jl = 1, jpl + DO jk = 1, nlay_i + DO jj = 1, jpj + DO ji = 1, jpi + ! ! linear profile with 0 surface value + zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i + zs = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl) ! weighting the profile + sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) + END DO + END DO + END DO + END DO + ! + DEALLOCATE( z_slope_s , zalpha ) + ! + ! !-------------------------------------------! + CASE( 3 ) ! constant salinity with a fix profile ! (Schwarzacher (1959) multiyear salinity profile + ! !-------------------------------------------! (mean = 2.30) + ! + s_i(:,:,:) = 2.30_wp +!!gm Remark: if we keep the case 3, then compute an store one for all time-step +!! a array S_prof(1:nlay_i) containing the calculation and just do: +! DO jk = 1, nlay_i +! sz_i(:,:,jk,:) = S_prof(jk) +! END DO +!!gm end + ! + DO jl = 1, jpl + DO jk = 1, nlay_i + zargtemp = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i + sz_i(:,:,jk,jl) = 1.6_wp * ( 1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) ) ) + END DO + END DO + ! + END SELECT + ! + END SUBROUTINE ice_var_salprof + + + SUBROUTINE ice_var_salprof1d( ki1, ki2 ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_salprof1d *** + !! + !! ** Purpose : 1d computation of the sea ice salinity profile + !! Works with 1d vectors and is used by thermodynamic modules + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ki1, ki2 + INTEGER :: ji, jk ! dummy loop indices + REAL(wp) :: zargtemp, zsal, z1_dS ! local scalars + REAL(wp) :: zs, zs0 ! - - + ! + REAL(wp), DIMENSION(ki1:ki2) :: z_slope_s, zalpha ! + REAL(wp), PARAMETER :: zsi0 = 3.5_wp + REAL(wp), PARAMETER :: zsi1 = 4.5_wp + !!------------------------------------------------------------------- + ! + SELECT CASE ( nn_icesal ) + ! + ! !---------------------------------------! + CASE( 1 ) ! constant salinity in time and space ! + ! !---------------------------------------! + sz_i_1d(ki1:ki2,:) = rn_icesal + ! + ! !---------------------------------------------! + CASE( 2 ) ! time varying salinity with linear profile ! + ! !---------------------------------------------! + ! + ! ! Slope of the linear profile + WHERE( h_i_1d(ki1:ki2) > epsi20 ) ; z_slope_s(ki1:ki2) = 2._wp * s_i_1d(ki1:ki2) / h_i_1d(ki1:ki2) + ELSEWHERE ; z_slope_s(ki1:ki2) = 0._wp + END WHERE + + z1_dS = 1._wp / ( zsi1 - zsi0 ) + DO ji = ki1, ki2 + zalpha(ji) = MAX( 0._wp , MIN( ( zsi1 - s_i_1d(ji) ) * z1_dS , 1._wp ) ) + ! ! force a constant profile when SSS too low (Baltic Sea) + IF( 2._wp * s_i_1d(ji) >= sss_1d(ji) ) zalpha(ji) = 0._wp + END DO + ! + ! Computation of the profile + DO jk = 1, nlay_i + DO ji = ki1, ki2 + ! ! linear profile with 0 surface value + zs0 = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * h_i_1d(ji) * r1_nlay_i + zs = zalpha(ji) * zs0 + ( 1._wp - zalpha(ji) ) * s_i_1d(ji) + sz_i_1d(ji,jk) = MIN( rn_simax , MAX( zs , rn_simin ) ) + END DO + END DO + ! + ! !-------------------------------------------! + CASE( 3 ) ! constant salinity with a fix profile ! (Schwarzacher (1959) multiyear salinity profile + ! !-------------------------------------------! (mean = 2.30) + ! + s_i_1d(ki1:ki2) = 2.30_wp + ! +!!gm cf remark in ice_var_salprof routine, CASE( 3 ) + DO jk = 1, nlay_i + zargtemp = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i + zsal = 1.6_wp * ( 1._wp - COS( rpi * zargtemp**( 0.407_wp / ( 0.573_wp + zargtemp ) ) ) ) + DO ji = ki1, ki2 + sz_i_1d(ji,jk) = zsal + END DO + END DO + ! + END SELECT + ! + END SUBROUTINE ice_var_salprof1d + + + SUBROUTINE ice_var_zapsmall( jj1, jj2 ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_zapsmall *** + !! + !! ** Purpose : Remove too small sea ice areas and correct fluxes + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: jj1, jj2 ! jj start indices + INTEGER :: ji, jj, jl, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zswitch + !!------------------------------------------------------------------- + ! + DO jl = 1, jpl !== loop over the categories ==! + ! + WHERE( a_i(:,jj1:jj2,jl) > epsi10 ) ; h_i(:,jj1:jj2,jl) = v_i(:,jj1:jj2,jl) / a_i(:,jj1:jj2,jl) + ELSEWHERE ; h_i(:,jj1:jj2,jl) = 0._wp + END WHERE + ! + WHERE( a_i(:,jj1:jj2,jl) < epsi10 .OR. v_i(:,jj1:jj2,jl) < epsi10 .OR. h_i(:,jj1:jj2,jl) < epsi10 ) ; zswitch(:,jj1:jj2) = 0._wp + ELSEWHERE ; zswitch(:,jj1:jj2) = 1._wp + END WHERE + ! + !----------------------------------------------------------------- + ! Zap ice energy and use ocean heat to melt ice + !----------------------------------------------------------------- + DO jk = 1, nlay_i + DO jj = jj1, jj2 + DO ji = 1 , jpi + ! update exchanges with ocean + hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 + e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) + t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) + END DO + END DO + END DO + ! + DO jk = 1, nlay_s + DO jj = jj1, jj2 + DO ji = 1 , jpi + ! update exchanges with ocean + hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 + e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) + t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) + END DO + END DO + END DO + ! + !----------------------------------------------------------------- + ! zap ice and snow volume, add water and salt to ocean + !----------------------------------------------------------------- + DO jj = jj1, jj2 + DO ji = 1 , jpi + ! update exchanges with ocean + sfx_res(ji,jj) = sfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_rdtice + wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_rdtice + wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_rdtice + wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_rdtice + ! + a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) + v_i (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) + v_s (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) + t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) + oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) + sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) + ! + h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) + h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) + ! + a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) + v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) + v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) + h_ip (ji,jj,jl) = h_ip (ji,jj,jl) * zswitch(ji,jj) + h_il (ji,jj,jl) = h_il (ji,jj,jl) * zswitch(ji,jj) + ! + END DO + END DO + ! + END DO + + ! to be sure that at_i is the sum of a_i(jl) + at_i (:,jj1:jj2) = SUM( a_i (:,jj1:jj2,:), dim=3 ) + vt_i (:,jj1:jj2) = SUM( v_i (:,jj1:jj2,:), dim=3 ) +!!clem add? +! vt_s (:,jj1:jj2) = SUM( v_s (:,jj1:jj2,:), dim=3 ) +! st_i (:,jj1:jj2) = SUM( sv_i(:,jj1:jj2,:), dim=3 ) +! et_s(:,jj1:jj2) = SUM( SUM( e_s (:,jj1:jj2,:,jj1:jj2), dim=4 ), dim=3 ) +! et_i(:,jj1:jj2) = SUM( SUM( e_i (:,jj1:jj2,:,jj1:jj2), dim=4 ), dim=3 ) +!!clem + + ! open water = 1 if at_i=0 + WHERE( at_i(:,jj1:jj2) == 0._wp ) ato_i(:,jj1:jj2) = 1._wp + ! + END SUBROUTINE ice_var_zapsmall + + + SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_zapneg *** + !! + !! ** Purpose : Remove negative sea ice fields and correct fluxes + !!------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: pdt ! tracer time-step + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pato_i ! open water area + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i ! ice volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_s ! snw volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: psv_i ! salt content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: poa_i ! age content + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_i ! ice concentration + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content + ! + INTEGER :: ji, jj, jl, jk ! dummy loop indices + REAL(wp) :: z1_dt + !!------------------------------------------------------------------- + ! + z1_dt = 1._wp / pdt + ! + DO jl = 1, jpl !== loop over the categories ==! + ! + ! make sure a_i=0 where v_i<=0 + WHERE( pv_i(:,:,:) <= 0._wp ) pa_i(:,:,:) = 0._wp + + !---------------------------------------- + ! zap ice energy and send it to the ocean + !---------------------------------------- + DO jk = 1, nlay_i + DO jj = 1 , jpj + DO ji = 1 , jpi + IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 + pe_i(ji,jj,jk,jl) = 0._wp + ENDIF + END DO + END DO + END DO + ! + DO jk = 1, nlay_s + DO jj = 1 , jpj + DO ji = 1 , jpi + IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN + hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 + pe_s(ji,jj,jk,jl) = 0._wp + ENDIF + END DO + END DO + END DO + ! + !----------------------------------------------------- + ! zap ice and snow volume, add water and salt to ocean + !----------------------------------------------------- + DO jj = 1 , jpj + DO ji = 1 , jpi + IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN + wfx_res(ji,jj) = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt + pv_i (ji,jj,jl) = 0._wp + ENDIF + IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN + wfx_res(ji,jj) = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt + pv_s (ji,jj,jl) = 0._wp + ENDIF + IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN + sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt + psv_i (ji,jj,jl) = 0._wp + ENDIF + IF( pv_ip(ji,jj,jl) < 0._wp .OR. pv_il(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN + wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt + pv_il (ji,jj,jl) = 0._wp + ENDIF + IF( pv_ip(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN + wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt + pv_ip (ji,jj,jl) = 0._wp + ENDIF + END DO + END DO + ! + END DO + ! + WHERE( pato_i(:,:) < 0._wp ) pato_i(:,:) = 0._wp + WHERE( poa_i (:,:,:) < 0._wp ) poa_i (:,:,:) = 0._wp + WHERE( pa_i (:,:,:) < 0._wp ) pa_i (:,:,:) = 0._wp + WHERE( pa_ip (:,:,:) < 0._wp ) pa_ip (:,:,:) = 0._wp + ! + END SUBROUTINE ice_var_zapneg + + + SUBROUTINE ice_var_roundoff( jj1, jj2, pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_roundoff *** + !! + !! ** Purpose : Remove negative sea ice values arising from roundoff errors + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: jj1, jj2 ! indices + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pa_i ! ice concentration + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pv_i ! ice volume + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pv_s ! snw volume + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: psv_i ! salt content + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: poa_i ! age content + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pa_ip ! melt pond fraction + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pv_ip ! melt pond volume + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: pv_il ! melt pond lid volume + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: pe_s ! snw heat content + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: pe_i ! ice heat content + !!------------------------------------------------------------------- + ! + WHERE( pa_i (jj1:jj2,:) < 0._wp ) pa_i (jj1:jj2,:) = 0._wp ! a_i must be >= 0 + WHERE( pv_i (jj1:jj2,:) < 0._wp ) pv_i (jj1:jj2,:) = 0._wp ! v_i must be >= 0 + WHERE( pv_s (jj1:jj2,:) < 0._wp ) pv_s (jj1:jj2,:) = 0._wp ! v_s must be >= 0 + WHERE( psv_i(jj1:jj2,:) < 0._wp ) psv_i(jj1:jj2,:) = 0._wp ! sv_i must be >= 0 + WHERE( poa_i(jj1:jj2,:) < 0._wp ) poa_i(jj1:jj2,:) = 0._wp ! oa_i must be >= 0 + WHERE( pe_i (jj1:jj2,:,:) < 0._wp ) pe_i (jj1:jj2,:,:) = 0._wp ! e_i must be >= 0 + WHERE( pe_s (jj1:jj2,:,:) < 0._wp ) pe_s (jj1:jj2,:,:) = 0._wp ! e_s must be >= 0 + IF( ln_pnd_LEV ) THEN + WHERE( pa_ip(jj1:jj2,:) < 0._wp ) pa_ip(jj1:jj2,:) = 0._wp ! a_ip must be >= 0 + WHERE( pv_ip(jj1:jj2,:) < 0._wp ) pv_ip(jj1:jj2,:) = 0._wp ! v_ip must be >= 0 + IF( ln_pnd_lids ) THEN + WHERE( pv_il(jj1:jj2,:) < 0._wp ) pv_il(jj1:jj2,:) = 0._wp ! v_il must be >= 0 + ENDIF + ENDIF + ! + END SUBROUTINE ice_var_roundoff + + SUBROUTINE ice_var_bv + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_bv *** + !! + !! ** Purpose : computes mean brine volume (%) in sea ice + !! + !! ** Method : e = - 0.054 * S (ppt) / T (C) + !! + !! References : Vancoppenolle et al., JGR, 2007 + !!------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jl ! dummy loop indices + !!------------------------------------------------------------------- + ! +!!gm I prefere to use WHERE / ELSEWHERE to set it to zero only where needed <<<=== to be done +!! instead of setting everything to zero as just below + bv_i (:,:,:) = 0._wp + DO jl = 1, jpl + DO jk = 1, nlay_i + WHERE( t_i(:,:,jk,jl) < rt0 - epsi10 ) + bv_i(:,:,jl) = bv_i(:,:,jl) - rTmlt * sz_i(:,:,jk,jl) * r1_nlay_i / ( t_i(:,:,jk,jl) - rt0 ) + END WHERE + END DO + END DO + WHERE( vt_i(:,:) > epsi20 ) ; bvm_i(:,:) = SUM( bv_i(:,:,:) * v_i(:,:,:) , dim=3 ) / vt_i(:,:) + ELSEWHERE ; bvm_i(:,:) = 0._wp + END WHERE + ! + END SUBROUTINE ice_var_bv + + + SUBROUTINE ice_var_enthalpy( ki1, ki2 ) + !!------------------------------------------------------------------- + !! *** ROUTINE ice_var_enthalpy *** + !! + !! ** Purpose : Computes sea ice energy of melting q_i (J.m-3) from temperature + !! + !! ** Method : Formula (Bitz and Lipscomb, 1999) + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: ki1, ki2 ! Loop start and end + INTEGER :: ji, jk ! dummy loop indices + REAL(wp) :: ztmelts ! local scalar + !!------------------------------------------------------------------- + ! + DO jk = 1, nlay_i ! Sea ice energy of melting + DO ji = ki1, ki2 + ztmelts = - rTmlt * sz_i_1d(ji,jk) + t_i_1d(ji,jk) = MIN( t_i_1d(ji,jk), ztmelts + rt0 ) ! Force t_i_1d to be lower than melting point => likely conservation issue + ! (sometimes zdf scheme produces abnormally high temperatures) + e_i_1d(ji,jk) = rhoi * ( rcpi * ( ztmelts - ( t_i_1d(ji,jk) - rt0 ) ) & + & + rLfus * ( 1._wp - ztmelts / ( t_i_1d(ji,jk) - rt0 ) ) & + & - rcp * ztmelts ) + END DO + END DO + DO jk = 1, nlay_s ! Snow energy of melting + DO ji = ki1, ki2 + e_s_1d(ji,jk) = rhos * ( rcpi * ( rt0 - t_s_1d(ji,jk) ) + rLfus ) + END DO + END DO + ! + END SUBROUTINE ice_var_enthalpy + + + FUNCTION ice_var_sshdyn(pssh, psnwice_mass, psnwice_mass_b) + !!--------------------------------------------------------------------- + !! *** ROUTINE ice_var_sshdyn *** + !! + !! ** Purpose : compute the equivalent ssh in lead when sea ice is embedded + !! + !! ** Method : ssh_lead = ssh + (Mice + Msnow) / rau0 + !! + !! ** Reference : Jean-Michel Campin, John Marshall, David Ferreira, + !! Sea ice-ocean coupling using a rescaled vertical coordinate z*, + !! Ocean Modelling, Volume 24, Issues 1-2, 2008 + !!---------------------------------------------------------------------- + ! + ! input + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh !: ssh [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psnwice_mass !: mass of snow and ice at current ice time step [Kg/m2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psnwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] + ! + ! output + REAL(dp), DIMENSION(jpi,jpj) :: ice_var_sshdyn ! equivalent ssh in lead [m] + ! + ! temporary + REAL(wp) :: zintn! time interpolation weights [] + REAL(dp) :: zintb! time interpolation weights [] + REAL(wp), DIMENSION(jpi,jpj) :: zsnwiceload ! snow and ice load [m] + ! + ! compute ice load used to define the equivalent ssh in lead + IF( ln_ice_embd ) THEN + ! + ! 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 + ! + zsnwiceload(:,:) = ( zintn * psnwice_mass(:,:) + zintb * psnwice_mass_b(:,:) ) * r1_rau0 + ! + ELSE + zsnwiceload(:,:) = 0.0_wp + ENDIF + ! compute equivalent ssh in lead + ice_var_sshdyn(:,:) = pssh(:,:) + zsnwiceload(:,:) + ! + END FUNCTION ice_var_sshdyn + + + !!------------------------------------------------------------------- + !! *** INTERFACE ice_var_itd *** + !! + !! ** Purpose : converting N-cat ice to jpl ice categories + !!------------------------------------------------------------------- + SUBROUTINE ice_var_itd_1c1c( phti, phts, pati , ph_i, ph_s, pa_i, & + & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) + !!------------------------------------------------------------------- + !! ** Purpose : converting 1-cat ice to 1 ice category + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables + REAL(wp), DIMENSION(:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables + REAL(wp), DIMENSION(:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds + REAL(wp), DIMENSION(:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds + !!------------------------------------------------------------------- + ! == thickness and concentration == ! + ph_i(:) = phti(:) + ph_s(:) = phts(:) + pa_i(:) = pati(:) + ! + ! == temperature and salinity and ponds == ! + pt_i (:) = ptmi (:) + pt_s (:) = ptms (:) + pt_su(:) = ptmsu(:) + ps_i (:) = psmi (:) + pa_ip(:) = patip(:) + ph_ip(:) = phtip(:) + ph_il(:) = phtil(:) + + END SUBROUTINE ice_var_itd_1c1c + + SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati , ph_i, ph_s, pa_i, & + & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) + !!------------------------------------------------------------------- + !! ** Purpose : converting N-cat ice to 1 ice category + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables + REAL(wp), DIMENSION(:) , INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables + REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds + REAL(wp), DIMENSION(:) , INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds + ! + REAL(wp), ALLOCATABLE, DIMENSION(:) :: z1_ai, z1_vi, z1_vs + ! + INTEGER :: idim + !!------------------------------------------------------------------- + ! + idim = SIZE( phti, 1 ) + ! + ! == thickness and concentration == ! + ALLOCATE( z1_ai(idim), z1_vi(idim), z1_vs(idim) ) + ! + pa_i(:) = SUM( pati(:,:), dim=2 ) + + WHERE( ( pa_i(:) ) /= 0._wp ) ; z1_ai(:) = 1._wp / pa_i(:) + ELSEWHERE ; z1_ai(:) = 0._wp + END WHERE + + ph_i(:) = SUM( phti(:,:) * pati(:,:), dim=2 ) * z1_ai(:) + ph_s(:) = SUM( phts(:,:) * pati(:,:), dim=2 ) * z1_ai(:) + ! + ! == temperature and salinity == ! + WHERE( ( pa_i(:) * ph_i(:) ) /= 0._wp ) ; z1_vi(:) = 1._wp / ( pa_i(:) * ph_i(:) ) + ELSEWHERE ; z1_vi(:) = 0._wp + END WHERE + WHERE( ( pa_i(:) * ph_s(:) ) /= 0._wp ) ; z1_vs(:) = 1._wp / ( pa_i(:) * ph_s(:) ) + ELSEWHERE ; z1_vs(:) = 0._wp + END WHERE + pt_i (:) = SUM( ptmi (:,:) * pati(:,:) * phti(:,:), dim=2 ) * z1_vi(:) + pt_s (:) = SUM( ptms (:,:) * pati(:,:) * phts(:,:), dim=2 ) * z1_vs(:) + pt_su(:) = SUM( ptmsu(:,:) * pati(:,:) , dim=2 ) * z1_ai(:) + ps_i (:) = SUM( psmi (:,:) * pati(:,:) * phti(:,:), dim=2 ) * z1_vi(:) + + ! == ponds == ! + pa_ip(:) = SUM( patip(:,:), dim=2 ) + WHERE( pa_ip(:) /= 0._wp ) + ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:) + ph_il(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / pa_ip(:) + ELSEWHERE + ph_ip(:) = 0._wp + ph_il(:) = 0._wp + END WHERE + ! + DEALLOCATE( z1_ai, z1_vi, z1_vs ) + ! + END SUBROUTINE ice_var_itd_Nc1c + + SUBROUTINE ice_var_itd_1cMc( phti, phts, pati , ph_i, ph_s, pa_i, & + & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) + !!------------------------------------------------------------------- + !! + !! ** Purpose : converting 1-cat ice to jpl ice categories + !! + !! + !! ** Method: ice thickness distribution follows a gamma function from Abraham et al. (2015) + !! it has the property of conserving total concentration and volume + !! + !! + !! ** Arguments : phti: 1-cat ice thickness + !! phts: 1-cat snow depth + !! pati: 1-cat ice concentration + !! + !! ** Output : jpl-cat + !! + !! Abraham, C., Steiner, N., Monahan, A. and Michel, C., 2015. + !! Effects of subgrid‐scale snow thickness variability on radiative transfer in sea ice. + !! Journal of Geophysical Research: Oceans, 120(8), pp.5597-5614 + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables + REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables + REAL(wp), DIMENSION(:) , INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds + ! + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zfra, z1_hti + INTEGER :: ji, jk, jl + INTEGER :: idim + REAL(wp) :: zv, zdh + !!------------------------------------------------------------------- + ! + idim = SIZE( phti , 1 ) + ! + ph_i(1:idim,1:jpl) = 0._wp + ph_s(1:idim,1:jpl) = 0._wp + pa_i(1:idim,1:jpl) = 0._wp + ! + ALLOCATE( z1_hti(idim) ) + WHERE( phti(:) /= 0._wp ) ; z1_hti(:) = 1._wp / phti(:) + ELSEWHERE ; z1_hti(:) = 0._wp + END WHERE + ! + ! == thickness and concentration == ! + ! for categories 1:jpl-1, integrate the gamma function from hi_max(jl-1) to hi_max(jl) + DO jl = 1, jpl-1 + DO ji = 1, idim + ! + IF( phti(ji) > 0._wp ) THEN + ! concentration : integrate ((4A/H^2)xexp(-2x/H))dx from x=hi_max(jl-1) to hi_max(jl) + pa_i(ji,jl) = pati(ji) * z1_hti(ji) * ( ( phti(ji) + 2.*hi_max(jl-1) ) * EXP( -2.*hi_max(jl-1)*z1_hti(ji) ) & + & - ( phti(ji) + 2.*hi_max(jl ) ) * EXP( -2.*hi_max(jl )*z1_hti(ji) ) ) + ! + ! volume : integrate ((4A/H^2)x^2exp(-2x/H))dx from x=hi_max(jl-1) to hi_max(jl) + zv = pati(ji) * z1_hti(ji) * ( ( phti(ji)*phti(ji) + 2.*phti(ji)*hi_max(jl-1) + 2.*hi_max(jl-1)*hi_max(jl-1) ) & + & * EXP( -2.*hi_max(jl-1)*z1_hti(ji) ) & + & - ( phti(ji)*phti(ji) + 2.*phti(ji)*hi_max(jl) + 2.*hi_max(jl)*hi_max(jl) ) & + & * EXP(-2.*hi_max(jl)*z1_hti(ji)) ) + ! thickness + IF( pa_i(ji,jl) > epsi06 ) THEN + ph_i(ji,jl) = zv / pa_i(ji,jl) + ELSE + ph_i(ji,jl) = 0. + pa_i(ji,jl) = 0. + ENDIF + ENDIF + ! + ENDDO + ENDDO + ! + ! for the last category (jpl), integrate the gamma function from hi_max(jpl-1) to infinity + DO ji = 1, idim + ! + IF( phti(ji) > 0._wp ) THEN + ! concentration : integrate ((4A/H^2)xexp(-2x/H))dx from x=hi_max(jpl-1) to infinity + pa_i(ji,jpl) = pati(ji) * z1_hti(ji) * ( phti(ji) + 2.*hi_max(jpl-1) ) * EXP( -2.*hi_max(jpl-1)*z1_hti(ji) ) + + ! volume : integrate ((4A/H^2)x^2exp(-2x/H))dx from x=hi_max(jpl-1) to infinity + zv = pati(ji) * z1_hti(ji) * ( phti(ji)*phti(ji) + 2.*phti(ji)*hi_max(jpl-1) + 2.*hi_max(jpl-1)*hi_max(jpl-1) ) & + & * EXP( -2.*hi_max(jpl-1)*z1_hti(ji) ) + ! thickness + IF( pa_i(ji,jpl) > epsi06 ) THEN + ph_i(ji,jpl) = zv / pa_i(ji,jpl) + else + ph_i(ji,jpl) = 0. + pa_i(ji,jpl) = 0. + ENDIF + ENDIF + ! + ENDDO + ! + ! Add Snow in each category where pa_i is not 0 + DO jl = 1, jpl + DO ji = 1, idim + IF( pa_i(ji,jl) > 0._wp ) THEN + ph_s(ji,jl) = ph_i(ji,jl) * phts(ji) * z1_hti(ji) + ! In case snow load is in excess that would lead to transformation from snow to ice + ! Then, transfer the snow excess into the ice (different from icethd_dh) + zdh = MAX( 0._wp, ( rhos * ph_s(ji,jl) + ( rhoi - rau0 ) * ph_i(ji,jl) ) * r1_rau0 ) + ! recompute h_i, h_s avoiding out of bounds values + ph_i(ji,jl) = MIN( hi_max(jl), ph_i(ji,jl) + zdh ) + ph_s(ji,jl) = MAX( 0._wp, ph_s(ji,jl) - zdh * rhoi * r1_rhos ) + ENDIF + END DO + END DO + ! + DEALLOCATE( z1_hti ) + ! + ! == temperature and salinity == ! + DO jl = 1, jpl + pt_i (:,jl) = ptmi (:) + pt_s (:,jl) = ptms (:) + pt_su(:,jl) = ptmsu(:) + ps_i (:,jl) = psmi (:) + END DO + ! + ! == ponds == ! + ALLOCATE( zfra(idim) ) + ! keep the same pond fraction atip/ati for each category + WHERE( pati(:) /= 0._wp ) ; zfra(:) = patip(:) / pati(:) + ELSEWHERE ; zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + pa_ip(:,jl) = zfra(:) * pa_i(:,jl) + END DO + ! keep the same v_ip/v_i ratio for each category + WHERE( ( phti(:) * pati(:) ) /= 0._wp ) ; zfra(:) = ( phtip(:) * patip(:) ) / ( phti(:) * pati(:) ) + ELSEWHERE ; zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_ip(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) + ELSEWHERE ; ph_ip(:,jl) = 0._wp + END WHERE + END DO + ! keep the same v_il/v_i ratio for each category + WHERE( ( phti(:) * pati(:) ) /= 0._wp ) ; zfra(:) = ( phtil(:) * patip(:) ) / ( phti(:) * pati(:) ) + ELSEWHERE ; zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) + ELSEWHERE ; ph_il(:,jl) = 0._wp + END WHERE + END DO + DEALLOCATE( zfra ) + ! + END SUBROUTINE ice_var_itd_1cMc + + SUBROUTINE ice_var_itd_NcMc( phti, phts, pati , ph_i, ph_s, pa_i, & + & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) + !!------------------------------------------------------------------- + !! + !! ** Purpose : converting N-cat ice to jpl ice categories + !! + !! ice thickness distribution follows a gaussian law + !! around the concentration of the most likely ice thickness + !! (similar as iceistate.F90) + !! + !! ** Method: Iterative procedure + !! + !! 1) Fill ice cat that correspond to input thicknesses + !! Find the lowest(jlmin) and highest(jlmax) cat that are filled + !! + !! 2) Expand the filling to the cat jlmin-1 and jlmax+1 + !! by removing 25% ice area from jlmin and jlmax (resp.) + !! + !! 3) Expand the filling to the empty cat between jlmin and jlmax + !! by a) removing 25% ice area from the lower cat (ascendant loop jlmin=>jlmax) + !! b) removing 25% ice area from the higher cat (descendant loop jlmax=>jlmin) + !! + !! ** Arguments : phti: N-cat ice thickness + !! phts: N-cat snow depth + !! pati: N-cat ice concentration + !! + !! ** Output : jpl-cat + !! + !! (Example of application: BDY forcings when inputs have N-cat /= jpl) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables + REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables + REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds + ! + INTEGER , ALLOCATABLE, DIMENSION(:,:) :: jlfil, jlfil2 + INTEGER , ALLOCATABLE, DIMENSION(:) :: jlmax, jlmin + REAL(wp), ALLOCATABLE, DIMENSION(:) :: z1_ai, z1_vi, z1_vs, ztmp, zfra + ! + REAL(wp), PARAMETER :: ztrans = 0.25_wp + INTEGER :: ji, jl, jl1, jl2 + INTEGER :: idim, icat + !!------------------------------------------------------------------- + ! + idim = SIZE( phti, 1 ) + icat = SIZE( phti, 2 ) + ! + ! == thickness and concentration == ! + ! ! ---------------------- ! + IF( icat == jpl ) THEN ! input cat = output cat ! + ! ! ---------------------- ! + ph_i(:,:) = phti(:,:) + ph_s(:,:) = phts(:,:) + pa_i(:,:) = pati(:,:) + ! + ! == temperature and salinity and ponds == ! + pt_i (:,:) = ptmi (:,:) + pt_s (:,:) = ptms (:,:) + pt_su(:,:) = ptmsu(:,:) + ps_i (:,:) = psmi (:,:) + pa_ip(:,:) = patip(:,:) + ph_ip(:,:) = phtip(:,:) + ph_il(:,:) = phtil(:,:) + ! ! ---------------------- ! + ELSEIF( icat == 1 ) THEN ! input cat = 1 ! + ! ! ---------------------- ! + CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), & + & ph_i(:,:), ph_s(:,:), pa_i (:,:), & + & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), phtil(:,1), & + & pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:), ph_il(:,:) ) + ! ! ---------------------- ! + ELSEIF( jpl == 1 ) THEN ! output cat = 1 ! + ! ! ---------------------- ! + CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), & + & ph_i(:,1), ph_s(:,1), pa_i (:,1), & + & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), phtil(:,:), & + & pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1), ph_il(:,1) ) + ! ! ----------------------- ! + ELSE ! input cat /= output cat ! + ! ! ----------------------- ! + + ALLOCATE( jlfil(idim,jpl), jlfil2(idim,jpl) ) ! allocate arrays + ALLOCATE( jlmin(idim), jlmax(idim) ) + + ! --- initialize output fields to 0 --- ! + ph_i(1:idim,1:jpl) = 0._wp + ph_s(1:idim,1:jpl) = 0._wp + pa_i(1:idim,1:jpl) = 0._wp + ! + ! --- fill the categories --- ! + ! find where cat-input = cat-output and fill cat-output fields + jlmax(:) = 0 + jlmin(:) = 999 + jlfil(:,:) = 0 + DO jl1 = 1, jpl + DO jl2 = 1, icat + DO ji = 1, idim + IF( hi_max(jl1-1) <= phti(ji,jl2) .AND. hi_max(jl1) > phti(ji,jl2) ) THEN + ! fill the right category + ph_i(ji,jl1) = phti(ji,jl2) + ph_s(ji,jl1) = phts(ji,jl2) + pa_i(ji,jl1) = pati(ji,jl2) + ! record categories that are filled + jlmax(ji) = MAX( jlmax(ji), jl1 ) + jlmin(ji) = MIN( jlmin(ji), jl1 ) + jlfil(ji,jl1) = jl1 + ENDIF + END DO + END DO + END DO + ! + ! --- fill the gaps between categories --- ! + ! transfer from categories filled at the previous step to the empty ones in between + DO ji = 1, idim + jl1 = jlmin(ji) + jl2 = jlmax(ji) + IF( jl1 > 1 ) THEN + ! fill the lower cat (jl1-1) + pa_i(ji,jl1-1) = ztrans * pa_i(ji,jl1) + ph_i(ji,jl1-1) = hi_mean(jl1-1) + ! remove from cat jl1 + pa_i(ji,jl1 ) = ( 1._wp - ztrans ) * pa_i(ji,jl1) + ENDIF + IF( jl2 < jpl ) THEN + ! fill the upper cat (jl2+1) + pa_i(ji,jl2+1) = ztrans * pa_i(ji,jl2) + ph_i(ji,jl2+1) = hi_mean(jl2+1) + ! remove from cat jl2 + pa_i(ji,jl2 ) = ( 1._wp - ztrans ) * pa_i(ji,jl2) + ENDIF + END DO + ! + jlfil2(:,:) = jlfil(:,:) + ! fill categories from low to high + DO jl = 2, jpl-1 + DO ji = 1, idim + IF( jlfil(ji,jl-1) /= 0 .AND. jlfil(ji,jl) == 0 ) THEN + ! fill high + pa_i(ji,jl) = ztrans * pa_i(ji,jl-1) + ph_i(ji,jl) = hi_mean(jl) + jlfil(ji,jl) = jl + ! remove low + pa_i(ji,jl-1) = ( 1._wp - ztrans ) * pa_i(ji,jl-1) + ENDIF + END DO + END DO + ! + ! fill categories from high to low + DO jl = jpl-1, 2, -1 + DO ji = 1, idim + IF( jlfil2(ji,jl+1) /= 0 .AND. jlfil2(ji,jl) == 0 ) THEN + ! fill low + pa_i(ji,jl) = pa_i(ji,jl) + ztrans * pa_i(ji,jl+1) + ph_i(ji,jl) = hi_mean(jl) + jlfil2(ji,jl) = jl + ! remove high + pa_i(ji,jl+1) = ( 1._wp - ztrans ) * pa_i(ji,jl+1) + ENDIF + END DO + END DO + ! + DEALLOCATE( jlfil, jlfil2 ) ! deallocate arrays + DEALLOCATE( jlmin, jlmax ) + ! + ! == temperature and salinity == ! + ! + ALLOCATE( z1_ai(idim), z1_vi(idim), z1_vs(idim), ztmp(idim) ) + ! + WHERE( SUM( pa_i(:,:), dim=2 ) /= 0._wp ) ; z1_ai(:) = 1._wp / SUM( pa_i(:,:), dim=2 ) + ELSEWHERE ; z1_ai(:) = 0._wp + END WHERE + WHERE( SUM( pa_i(:,:) * ph_i(:,:), dim=2 ) /= 0._wp ) ; z1_vi(:) = 1._wp / SUM( pa_i(:,:) * ph_i(:,:), dim=2 ) + ELSEWHERE ; z1_vi(:) = 0._wp + END WHERE + WHERE( SUM( pa_i(:,:) * ph_s(:,:), dim=2 ) /= 0._wp ) ; z1_vs(:) = 1._wp / SUM( pa_i(:,:) * ph_s(:,:), dim=2 ) + ELSEWHERE ; z1_vs(:) = 0._wp + END WHERE + ! + ! fill all the categories with the same value + ztmp(:) = SUM( ptmi (:,:) * pati(:,:) * phti(:,:), dim=2 ) * z1_vi(:) + DO jl = 1, jpl + pt_i (:,jl) = ztmp(:) + END DO + ztmp(:) = SUM( ptms (:,:) * pati(:,:) * phts(:,:), dim=2 ) * z1_vs(:) + DO jl = 1, jpl + pt_s (:,jl) = ztmp(:) + END DO + ztmp(:) = SUM( ptmsu(:,:) * pati(:,:) , dim=2 ) * z1_ai(:) + DO jl = 1, jpl + pt_su(:,jl) = ztmp(:) + END DO + ztmp(:) = SUM( psmi (:,:) * pati(:,:) * phti(:,:), dim=2 ) * z1_vi(:) + DO jl = 1, jpl + ps_i (:,jl) = ztmp(:) + END DO + ! + DEALLOCATE( z1_ai, z1_vi, z1_vs, ztmp ) + ! + ! == ponds == ! + ALLOCATE( zfra(idim) ) + ! keep the same pond fraction atip/ati for each category + WHERE( SUM( pati(:,:), dim=2 ) /= 0._wp ) ; zfra(:) = SUM( patip(:,:), dim=2 ) / SUM( pati(:,:), dim=2 ) + ELSEWHERE ; zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + pa_ip(:,jl) = zfra(:) * pa_i(:,jl) + END DO + ! keep the same v_ip/v_i ratio for each category + WHERE( SUM( phti(:,:) * pati(:,:), dim=2 ) /= 0._wp ) + zfra(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / SUM( phti(:,:) * pati(:,:), dim=2 ) + ELSEWHERE + zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_ip(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) + ELSEWHERE ; ph_ip(:,jl) = 0._wp + END WHERE + END DO + ! keep the same v_il/v_i ratio for each category + WHERE( SUM( phti(:,:) * pati(:,:), dim=2 ) /= 0._wp ) + zfra(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / SUM( phti(:,:) * pati(:,:), dim=2 ) + ELSEWHERE + zfra(:) = 0._wp + END WHERE + DO jl = 1, jpl + WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) + ELSEWHERE ; ph_il(:,jl) = 0._wp + END WHERE + END DO + DEALLOCATE( zfra ) + ! + ENDIF + ! + END SUBROUTINE ice_var_itd_NcMc + + !!------------------------------------------------------------------- + !! INTERFACE ice_var_snwfra + !! + !! ** Purpose : fraction of ice covered by snow + !! + !! ** Method : In absence of proper snow model on top of sea ice, + !! we argue that snow does not cover the whole ice because + !! of wind blowing... + !! + !! ** Arguments : ph_s: snow thickness + !! + !! ** Output : pa_s_fra: fraction of ice covered by snow + !! + !!------------------------------------------------------------------- + SUBROUTINE ice_var_snwfra_3d( ph_s, pa_s_fra ) + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: ph_s ! snow thickness + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover + WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp + ELSEWHERE ; pa_s_fra = 0._wp + END WHERE + ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) + pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) + ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) + pa_s_fra = ph_s / ( ph_s + 0.02_wp ) + ENDIF + END SUBROUTINE ice_var_snwfra_3d + + SUBROUTINE ice_var_snwfra_3d_omp( kj1, kj2, ph_s, pa_s_fra ) + INTEGER, INTENT(in ) :: kj1, kj2 ! j indices + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: ph_s ! snow thickness + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover + WHERE( ph_s(:,kj1:kj2,:) > 0._wp ) ; pa_s_fra(:,kj1:kj2,:) = 1._wp + ELSEWHERE ; pa_s_fra(:,kj1:kj2,:) = 0._wp + END WHERE + ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) + pa_s_fra(:,kj1:kj2,:) = 1._wp - EXP( -0.2_wp * rhos * ph_s(:,kj1:kj2,:) ) + ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) + pa_s_fra(:,kj1:kj2,:) = ph_s(:,kj1:kj2,:) / ( ph_s(:,kj1:kj2,:) + 0.02_wp ) + ENDIF + END SUBROUTINE ice_var_snwfra_3d_omp + + SUBROUTINE ice_var_snwfra_2d( ph_s, pa_s_fra ) + REAL(wp), DIMENSION(:,:), INTENT(in ) :: ph_s ! snow thickness + REAL(wp), DIMENSION(:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover + WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp + ELSEWHERE ; pa_s_fra = 0._wp + END WHERE + ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) + pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) + ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) + pa_s_fra = ph_s / ( ph_s + 0.02_wp ) + ENDIF + END SUBROUTINE ice_var_snwfra_2d + + SUBROUTINE ice_var_snwfra_2d_omp( kj1, kj2, ph_s, pa_s_fra ) + INTEGER, INTENT(in ) :: kj1, kj2 ! j indices + REAL(wp), DIMENSION(:,:), INTENT(in ) :: ph_s ! snow thickness + REAL(wp), DIMENSION(:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover + WHERE( ph_s(:,kj1:kj2) > 0._wp ) ; pa_s_fra(:,kj1:kj2) = 1._wp + ELSEWHERE ; pa_s_fra(:,kj1:kj2) = 0._wp + END WHERE + ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) + pa_s_fra(:,kj1:kj2) = 1._wp - EXP( -0.2_wp * rhos * ph_s(:,kj1:kj2) ) + ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) + pa_s_fra(:,kj1:kj2) = ph_s(:,kj1:kj2) / ( ph_s(:,kj1:kj2) + 0.02_wp ) + ENDIF + END SUBROUTINE ice_var_snwfra_2d_omp + + SUBROUTINE ice_var_snwfra_1d( ph_s, pa_s_fra ) + REAL(dp), DIMENSION(:), INTENT(in ) :: ph_s ! snow thickness + REAL(wp), DIMENSION(:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover + WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp + ELSEWHERE ; pa_s_fra = 0._wp + END WHERE + ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) + pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) + ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) + pa_s_fra = ph_s / ( ph_s + 0.02_wp ) + ENDIF + END SUBROUTINE ice_var_snwfra_1d + + !!-------------------------------------------------------------------------- + !! INTERFACE ice_var_snwblow + !! + !! ** Purpose : Compute distribution of precip over the ice + !! + !! Snow accumulation in one thermodynamic time step + !! snowfall is partitionned between leads and ice. + !! If snow fall was uniform, a fraction (1-at_i) would fall into leads + !! but because of the winds, more snow falls on leads than on sea ice + !! and a greater fraction (1-at_i)^beta of the total mass of snow + !! (beta < 1) falls in leads. + !! In reality, beta depends on wind speed, + !! and should decrease with increasing wind speed but here, it is + !! considered as a constant. an average value is 0.66 + !!-------------------------------------------------------------------------- +!!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE.... + SUBROUTINE ice_var_snwblow_2d( pin, pout ) + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b ) + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout + pout = ( 1._wp - ( pin )**rn_snwblow ) + END SUBROUTINE ice_var_snwblow_2d + + SUBROUTINE ice_var_snwblow_1d( pin, pout ) + REAL(dp), DIMENSION(:), INTENT(in ) :: pin + REAL(wp), DIMENSION(:), INTENT(inout) :: pout + pout = ( 1._wp - ( pin )**rn_snwblow ) + END SUBROUTINE ice_var_snwblow_1d + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icevar \ No newline at end of file diff --git a/V4.0/nemo_sources/src/ICE/icevar.mod b/V4.0/nemo_sources/src/ICE/icevar.mod new file mode 100644 index 0000000000000000000000000000000000000000..d58a04d57551cd41aadf5d12b93eccdda8a703ae Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icevar.mod differ diff --git a/V4.0/nemo_sources/src/ICE/icewri.F90 b/V4.0/nemo_sources/src/ICE/icewri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..967bbcc5f9bb8a1b973dd8a1d44f7cb647a6b7a8 --- /dev/null +++ b/V4.0/nemo_sources/src/ICE/icewri.F90 @@ -0,0 +1,308 @@ +MODULE icewri + !!====================================================================== + !! *** MODULE icewri *** + !! sea-ice : output ice variables + !!====================================================================== + !! History : 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube] + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! ice_wri : write of the diagnostics variables in ouput file + !! ice_wri_state : write for initial state or/and abandon + !!---------------------------------------------------------------------- + USE dianam ! build name of file (routine) + USE phycst ! physical constant + USE dom_oce ! domain: ocean + USE sbc_oce ! surf. boundary cond.: ocean + USE sbc_ice ! Surface boundary condition: ice fields + USE ice ! sea-ice: variables + USE icevar ! sea-ice: operations + ! + USE ioipsl ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lib_fortran ! fortran utilities (glob_sum + no signed zero) + USE lbclnk ! lateral boundary conditions (or mpp links) + USE geo2ocean ! For rotation. + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ice_wri ! called by ice_stp + PUBLIC ice_wri_state ! called by dia_wri_state + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/ICE 4.0 , NEMO Consortium (2018) + !! $Id: icewri.F90 14588 2021-03-05 07:42:07Z clem $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ice_wri( kt ) + !!------------------------------------------------------------------- + !! This routine ouputs some (most?) of the sea ice fields + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time-step + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: z2da, z2db, zrho1, zrho2 + REAL(wp) :: zmiss_val ! missing value retrieved from xios + REAL(wp), DIMENSION(jpi,jpj) :: z2d, zfast ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zmsk00l, zmsksnl ! cat masks + REAL(wp), DIMENSION(jpi,jpj) :: zu, zv, zur, zvr ! 2D workspace + ! + ! Global ice diagnostics (SIMIP) + REAL(wp) :: zdiag_area_nh, zdiag_extt_nh, zdiag_volu_nh ! area, extent, volume + REAL(wp) :: zdiag_area_sh, zdiag_extt_sh, zdiag_volu_sh + !!------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icewri') + + ! get missing value from xml + ! CALL iom_miss_val( 'icetemp', zmiss_val ) + zmiss_val = 0 + + ! brine volume + CALL ice_var_bv + + ! tresholds for outputs + DO jj = 1, jpj + DO ji = 1, jpi + zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice + zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less + zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less + zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06 ) ) ! 1 if snow , 0 if no snow + END DO + END DO + DO jl = 1, jpl + DO jj = 1, jpj + DO ji = 1, jpi + zmsk00l(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) + zmsksnl(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) + END DO + END DO + END DO + + !----------------- + ! Standard outputs + !----------------- + zrho1 = ( rau0 - rhoi ) * r1_rau0 ; zrho2 = rhos * r1_rau0 + ! masks + CALL iom_put( 'icemask' , zmsk00 ) ! ice mask 0% + CALL iom_put( 'icemask05', zmsk05 ) ! ice mask 5% + CALL iom_put( 'icemask15', zmsk15 ) ! ice mask 15% + CALL iom_put( 'icepres' , zmsk00 ) ! Ice presence (1 or 0) + ! + ! general fields + IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i * rhoi * zmsk00 ) ! Ice mass per cell area + IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s * rhos * zmsksn ) ! Snow mass per cell area + IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i * zmsk00 ) ! ice concentration + IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i * zmsk00 ) ! ice volume = mean ice thickness over the cell + IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i * zmsk00 ) ! ice thickness + IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s * zmsk00 ) ! snw thickness + IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i* 100. * zmsk00 ) ! brine volume + IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age + IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new ) ! new ice thickness formed in the leads + IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s * zmsksn ) ! snow volume + IF( iom_use('icefrb' ) ) THEN ! Ice freeboard + z2d(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) ) + WHERE( z2d < 0._wp ) z2d = 0._wp + CALL iom_put( 'icefrb' , z2d * zmsk00 ) + ENDIF + ! melt ponds + IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip * zmsk00 ) ! melt pond total fraction + IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip * zmsk00 ) ! melt pond depth + IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip * zmsk00 ) ! melt pond total volume per unit area + IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il * zmsk00 ) ! melt pond lid depth + IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il * zmsk00 ) ! melt pond lid total volume per unit area + ! salt + IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity + IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area + ! heat + IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature + IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature + IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface + IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom + IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface + IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i * zmsk00 ) ! ice heat content + IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s * zmsksn ) ! snow heat content + ! momentum + IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice ) ! ice velocity u + IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice ) ! ice velocity v + ! + IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity + DO jj = 2 , jpjm1 + DO ji = 2 , jpim1 + z2da = u_ice(ji,jj) + u_ice(ji-1,jj) + z2db = v_ice(ji,jj) + v_ice(ji,jj-1) + z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) + END DO + END DO + CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp ) + CALL iom_put( 'icevel', z2d ) + + WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice + ELSEWHERE ; zfast(:,:) = 0._wp + END WHERE + CALL iom_put( 'fasticepres', zfast ) + ENDIF + + ! geographic velocity + IF ( iom_use( "iicevelur" ) .OR. iom_use( "iicevelvr" ) ) THEN + DO jj = 2 , jpjm1 + DO ji = 2 , jpim1 + zu(ji,jj) = ( u_ice(ji,jj) * umask(ji,jj,1) + u_ice(ji-1,jj) * umask(ji-1,jj,1) ) * 0.5_wp + zv(ji,jj) = ( v_ice(ji,jj) * vmask(ji,jj,1) + v_ice(ji,jj-1) * vmask(ji,jj-1,1) ) * 0.5_wp + END DO + END DO + CALL lbc_lnk( 'icewri', zu, 'T', -1.0_wp ) + CALL lbc_lnk( 'icewri', zv, 'T', -1.0_wp ) + CALL rot_rep( zu, zv, 'T', 'ij->e', zur ) + CALL rot_rep( zu, zv, 'T', 'ij->n', zvr ) + CALL iom_put( "iicevelur" , zur ) ! ice velocity u component + CALL iom_put( "iicevelvr" , zvr ) ! ice velocity v component + ENDIF + + ! geographic stress + IF ( iom_use( "iocestrur" ) .OR. iom_use( "iocestrvr" ) ) THEN + DO jj = 2 , jpjm1 + DO ji = 2 , jpim1 + zu(ji,jj) = ( utau_ice(ji,jj) + utau_ice(ji-1,jj) ) * 0.5_wp + zv(ji,jj) = ( vtau_ice(ji,jj) + vtau_ice(ji,jj-1) ) * 0.5_wp + END DO + END DO + CALL lbc_lnk( 'icewri', zu, 'T', -1.0_wp ) + CALL lbc_lnk( 'icewri', zv, 'T', -1.0_wp ) + CALL rot_rep( zu, zv, 'T', 'ij->e', zur ) + CALL rot_rep( zu, zv, 'T', 'ij->n', zvr ) + CALL iom_put( "iocestrur" , zur ) ! ice velocity u component + CALL iom_put( "iocestrvr" , zvr ) ! ice velocity v component + ENDIF + + ! --- category-dependent fields --- ! + IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0% + IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i * zmsk00l ) ! area for categories + IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! thickness for categories + IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow depth for categories + IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! salinity for categories + IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i / rday * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice age + IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i, dim=3 ) * r1_nlay_i - rt0 ) & + & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature + IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s, dim=3 ) * r1_nlay_s - rt0 ) & + & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature + IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su - rt0 ) * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! surface temperature + IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume + IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories + IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories + IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories + IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac for categories + IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff * zmsk00l ) ! melt pond effective frac for categories + IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories + + !------------------ + ! Add-ons for SIMIP + !------------------ + ! trends + IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics + IF( iom_use('dmidyn') ) CALL iom_put( 'dmidyn', - wfx_dyn + rhoi * diag_trp_vi ) ! Sea-ice mass change from dynamics(kg/m2/s) + IF( iom_use('dmiopw') ) CALL iom_put( 'dmiopw', - wfx_opw ) ! Sea-ice mass change through growth in open water + IF( iom_use('dmibog') ) CALL iom_put( 'dmibog', - wfx_bog ) ! Sea-ice mass change through basal growth + IF( iom_use('dmisni') ) CALL iom_put( 'dmisni', - wfx_sni ) ! Sea-ice mass change through snow-to-ice conversion + IF( iom_use('dmisum') ) CALL iom_put( 'dmisum', - wfx_sum ) ! Sea-ice mass change through surface melting + IF( iom_use('dmibom') ) CALL iom_put( 'dmibom', - wfx_bom ) ! Sea-ice mass change through bottom melting + IF( iom_use('dmilam') ) CALL iom_put( 'dmilam', - wfx_lam ) ! Sea-ice mass change through lateral melting + IF( iom_use('dmtsub') ) CALL iom_put( 'dmtsub', - wfx_sub ) ! Sea-ice mass change through evaporation and sublimation + IF( iom_use('dmssub') ) CALL iom_put( 'dmssub', - wfx_snw_sub ) ! Snow mass change through sublimation + IF( iom_use('dmisub') ) CALL iom_put( 'dmisub', - wfx_ice_sub ) ! Sea-ice mass change through sublimation + IF( iom_use('dmsspr') ) CALL iom_put( 'dmsspr', - wfx_spr ) ! Snow mass change through snow fall + IF( iom_use('dmsssi') ) CALL iom_put( 'dmsssi', wfx_sni*rhos*r1_rhoi ) ! Snow mass change through snow-to-ice conversion + IF( iom_use('dmsmel') ) CALL iom_put( 'dmsmel', - wfx_snw_sum ) ! Snow mass change through melt + IF( iom_use('dmsdyn') ) CALL iom_put( 'dmsdyn', - wfx_snw_dyn + rhos * diag_trp_vs ) ! Snow mass change through dynamics(kg/m2/s) + + ! Global ice diagnostics + IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') .OR. & + & iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') ) THEN + ! + WHERE( ff_t(:,:) > 0._wp ) ; z2d(:,:) = 1._wp + ELSEWHERE ; z2d(:,:) = 0. + END WHERE + ! + IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i * z2d * e1e2t * 1.e-12_wp ) + IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i * z2d * e1e2t * 1.e-12_wp ) + IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t * 1.e-12_wp * zmsk15 ) + ! + IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i * ( 1._wp - z2d ) * e1e2t * 1.e-12_wp ) + IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i * ( 1._wp - z2d ) * e1e2t * 1.e-12_wp ) + IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t * 1.e-12_wp * zmsk15 ) + ! + CALL iom_put( 'NH_icearea' , zdiag_area_nh ) + CALL iom_put( 'NH_icevolu' , zdiag_volu_nh ) + CALL iom_put( 'NH_iceextt' , zdiag_extt_nh ) + CALL iom_put( 'SH_icearea' , zdiag_area_sh ) + CALL iom_put( 'SH_icevolu' , zdiag_volu_sh ) + CALL iom_put( 'SH_iceextt' , zdiag_extt_sh ) + ! + ENDIF + ! +!!CR ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s +!!CR ! IF( kindic < 0 ) CALL ice_wri_state( 'output.abort' ) +!!CR ! not yet implemented +!!gm idem for the ocean... Ask Seb how to get rid of ioipsl.... + ! + IF( ln_timing ) CALL timing_stop('icewri') + ! + END SUBROUTINE ice_wri + + + SUBROUTINE ice_wri_state( kid ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ice_wri_state *** + !! + !! ** Purpose : create a NetCDF file named cdfile_name which contains + !! the instantaneous ice state and forcing fields for ice model + !! Used to find errors in the initial state or save the last + !! ocean state in case of abnormal end of a simulation + !! + !! History : 4.0 ! 2013-06 (C. Rousset) + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kid + !!---------------------------------------------------------------------- + ! + !! The file is open in dia_wri_state (ocean routine) + + CALL iom_rstput( 0, 0, kid, 'sithic', hm_i ) ! Ice thickness + CALL iom_rstput( 0, 0, kid, 'siconc', at_i ) ! Ice concentration + CALL iom_rstput( 0, 0, kid, 'sitemp', tm_i - rt0 ) ! Ice temperature + CALL iom_rstput( 0, 0, kid, 'sivelu', u_ice ) ! i-Ice speed + CALL iom_rstput( 0, 0, kid, 'sivelv', v_ice ) ! j-Ice speed + CALL iom_rstput( 0, 0, kid, 'sistru', utau_ice ) ! i-Wind stress over ice + CALL iom_rstput( 0, 0, kid, 'sistrv', vtau_ice ) ! i-Wind stress over ice + CALL iom_rstput( 0, 0, kid, 'sisflx', qsr ) ! Solar flx over ocean + CALL iom_rstput( 0, 0, kid, 'sinflx', qns ) ! NonSolar flx over ocean + CALL iom_rstput( 0, 0, kid, 'snwpre', sprecip ) ! Snow precipitation + CALL iom_rstput( 0, 0, kid, 'sisali', sm_i ) ! Ice salinity + CALL iom_rstput( 0, 0, kid, 'sivolu', vt_i ) ! Ice volume + CALL iom_rstput( 0, 0, kid, 'si_amp', at_ip ) ! Melt pond fraction + CALL iom_rstput( 0, 0, kid, 'si_vmp', vt_ip ) ! Melt pond volume + CALL iom_rstput( 0, 0, kid, 'sithicat', h_i ) ! Ice thickness + CALL iom_rstput( 0, 0, kid, 'siconcat', a_i ) ! Ice concentration + CALL iom_rstput( 0, 0, kid, 'sisalcat', s_i ) ! Ice salinity + CALL iom_rstput( 0, 0, kid, 'snthicat', h_s ) ! Snw thickness + IF ( ln_icedyn ) CALL iom_rstput( 0, 0, kid, 'sidive', divu_i*1.0e8 ) ! Ice divergence + + END SUBROUTINE ice_wri_state + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module NO SI3 sea-ice model + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE icewri diff --git a/V4.0/nemo_sources/src/ICE/icewri.mod b/V4.0/nemo_sources/src/ICE/icewri.mod new file mode 100644 index 0000000000000000000000000000000000000000..f85c67780c4128091dc7048345f53d833ae435bc Binary files /dev/null and b/V4.0/nemo_sources/src/ICE/icewri.mod differ diff --git a/V4.0/nemo_sources/src/NST/agrif2model.F90 b/V4.0/nemo_sources/src/NST/agrif2model.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d3b20cbb9b7599e875eccd7687e4cc932043684b --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif2model.F90 @@ -0,0 +1,89 @@ +#if defined key_agrif + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif2model.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +SUBROUTINE Agrif2Model + !!--------------------------------------------- + !! *** ROUTINE Agrif2Model *** + !!--------------------------------------------- +END SUBROUTINE Agrif2model + +SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Set_numberofcells *** + !!--------------------------------------------- + USE Agrif_Grids + IMPLICIT NONE + + TYPE(Agrif_Grid), POINTER :: Agrif_Gr + + IF ( ASSOCIATED(Agrif_Curgrid) )THEN +#include "SetNumberofcells.h" + ENDIF + +END SUBROUTINE Agrif_Set_numberofcells + +SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Get_numberofcells *** + !!--------------------------------------------- + USE Agrif_Grids + IMPLICIT NONE + + TYPE(Agrif_Grid), POINTER :: Agrif_Gr + + IF ( ASSOCIATED(Agrif_Curgrid) ) THEN +#include "GetNumberofcells.h" + ENDIF + +END SUBROUTINE Agrif_Get_numberofcells + +SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Allocationscalls *** + !!--------------------------------------------- + USE Agrif_Grids +#include "include_use_Alloc_agrif.h" + IMPLICIT NONE + + TYPE(Agrif_Grid), POINTER :: Agrif_Gr + +#include "allocations_calls_agrif.h" + +END SUBROUTINE Agrif_Allocationcalls + +SUBROUTINE Agrif_probdim_modtype_def() + !!--------------------------------------------- + !! *** ROUTINE Agrif_probdim_modtype_def *** + !!--------------------------------------------- + USE Agrif_Types + IMPLICIT NONE + +#include "modtype_agrif.h" +#include "probdim_agrif.h" +#include "keys_agrif.h" + + RETURN + +END SUBROUTINE Agrif_probdim_modtype_def + +SUBROUTINE Agrif_clustering_def() + !!--------------------------------------------- + !! *** ROUTINE Agrif_clustering_def *** + !!--------------------------------------------- + IMPLICIT NONE + + RETURN + +END SUBROUTINE Agrif_clustering_def + +#else +SUBROUTINE Agrif2Model + !!--------------------------------------------- + !! *** ROUTINE Agrif2Model *** + !!--------------------------------------------- + WRITE(*,*) 'Impossible to bet here' +END SUBROUTINE Agrif2model +#endif diff --git a/V4.0/nemo_sources/src/NST/agrif_all_update.F90 b/V4.0/nemo_sources/src/NST/agrif_all_update.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a50355e61964a359217ad29f81f0dae565b18d85 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_all_update.F90 @@ -0,0 +1,84 @@ +#define TWO_WAY + + MODULE agrif_all_update + !!====================================================================== + !! *** MODULE agrif_all_update *** + !! AGRIF: Main update driver for ocean, ice and passive tracers + !!====================================================================== + !! History : 4.0 ! 2018-06 (J. Chanut) Original code + !!---------------------------------------------------------------------- +#if defined key_agrif + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !!---------------------------------------------------------------------- + USE dom_oce + USE agrif_oce + USE agrif_oce_update +#if defined key_top + USE agrif_top_update +#endif +#if defined key_si3 + USE agrif_ice_update +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_Update_All + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_all_update.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_Update_All( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Update_All *** + !! + !! ** Purpose :: Update nested grids for all components (Ocean, Sea Ice, TOP) + !! Order of update matters here ! + !!---------------------------------------------------------------------- +# if defined TWO_WAY + IF (Agrif_Root()) RETURN + ! + IF (lwp.AND.lk_agrif_debug) Write(*,*) ' --> START AGRIF UPDATE from grid Number',Agrif_Fixed() + ! + CALL Agrif_Update_ssh() ! Update sea level + ! + IF (.NOT.ln_linssh) CALL Agrif_Update_vvl() ! Update scale factors + ! + CALL Agrif_Update_tra() ! Update temperature/salinity + ! +#if defined key_top + CALL Agrif_Update_Trc() ! Update passive tracers +#endif + ! + CALL Agrif_Update_dyn() ! Update dynamics + ! +! JC remove update because this precludes from perfect restartability +!! CALL Agrif_Update_tke() ! Update tke + +#if defined key_si3 + CALL agrif_update_ice() ! Update sea ice +#endif + IF (lwp.AND.lk_agrif_debug) Write(*,*) ' <-- END AGRIF UPDATE from grid Number',Agrif_Fixed() + ! + Agrif_UseSpecialValueInUpdate = .FALSE. +#endif + END SUBROUTINE agrif_Update_All + +#else + !!---------------------------------------------------------------------- + !! Empty module no AGRIF zoom + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE Agrif_Update_all( ) + WRITE(*,*) 'Agrif_Update_All : You should not have seen this print! error?' + END SUBROUTINE Agrif_Update_all +#endif + + !!====================================================================== +END MODULE agrif_all_update + diff --git a/V4.0/nemo_sources/src/NST/agrif_ice.F90 b/V4.0/nemo_sources/src/NST/agrif_ice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..41be2d100f27d6f2f9d0d5072cfb84daabdd5db1 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_ice.F90 @@ -0,0 +1,28 @@ +MODULE agrif_ice + !!====================================================================== + !! *** MODULE agrif_ice *** + !! AGRIF : define in memory AGRIF variables for sea-ice + !!---------------------------------------------------------------------- + !! History : 3.4 ! 2012-08 (R. Benshila) Original code + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + IMPLICIT NONE + PRIVATE + + INTEGER, PUBLIC :: u_ice_id, v_ice_id, tra_ice_id + INTEGER, PUBLIC :: nbstep_ice = 0 ! child time position in sea-ice model + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_ice.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +#endif + !!====================================================================== +END MODULE agrif_ice diff --git a/V4.0/nemo_sources/src/NST/agrif_ice_interp.F90 b/V4.0/nemo_sources/src/NST/agrif_ice_interp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..422fe5d3c89301f968b3e40175a80577814e4456 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_ice_interp.F90 @@ -0,0 +1,382 @@ +MODULE agrif_ice_interp + !!===================================================================================== + !! *** MODULE agrif_ice_interp *** + !! Nesting module : interp surface ice boundary condition from a parent grid + !!===================================================================================== + !! History : 2.0 ! 04-2008 (F. Dupont) initial version + !! 3.4 ! 09-2012 (R. Benshila, C. Herbaut) update and EVP + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !! 'key_agrif' AGRIF library + !!---------------------------------------------------------------------- + !! agrif_interp_ice : interpolation of ice at "after" sea-ice time step + !! agrif_interp_u_ice : atomic routine to interpolate u_ice + !! agrif_interp_v_ice : atomic routine to interpolate v_ice + !! agrif_interp_tra_ice : atomic routine to interpolate ice properties + !!---------------------------------------------------------------------- + USE par_oce + USE dom_oce + USE sbc_oce + USE ice + USE agrif_ice + USE phycst , ONLY: rt0 + + IMPLICIT NONE + PRIVATE + + PUBLIC agrif_interp_ice ! called by agrif_user.F90 + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_ice_interp.F90 13479 2020-09-16 16:56:46Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE agrif_interp_ice( cd_type, kiter, kitermax ) + !!----------------------------------------------------------------------- + !! *** ROUTINE agrif_interp_ice *** + !! + !! ** Method : simple call to atomic routines using stored values to + !! fill the boundaries depending of the position of the point and + !! computing factor for time interpolation + !!----------------------------------------------------------------------- + CHARACTER(len=1), INTENT(in ) :: cd_type + INTEGER , INTENT(in ), OPTIONAL :: kiter, kitermax + !! + REAL(wp) :: zbeta ! local scalar + !!----------------------------------------------------------------------- + ! + IF( Agrif_Root() .OR. nn_ice==0 ) RETURN ! do not interpolate if inside Parent Grid or if child domain does not have ice + ! + SELECT CASE( cd_type ) + CASE('U','V') + IF( PRESENT( kiter ) ) THEN ! interpolation at the child ice sub-time step (only for ice rheology) + zbeta = ( REAL(nbstep_ice) - REAL(kitermax - kiter) / REAL(kitermax) ) / & + & ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) ) + ELSE ! interpolation at the child ice time step + zbeta = REAL(nbstep_ice) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) ) + ENDIF + CASE('T') + zbeta = REAL(nbstep_ice) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) ) + END SELECT + ! + Agrif_SpecialValue = -9999. + Agrif_UseSpecialValue = .TRUE. + SELECT CASE( cd_type ) + CASE('U') ; CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) + CASE('V') ; CALL Agrif_Bc_variable( v_ice_id , procname=interp_v_ice , calledweight=zbeta ) + CASE('T') ; CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta ) + END SELECT + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .FALSE. + ! + END SUBROUTINE agrif_interp_ice + + + SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before ) + !!----------------------------------------------------------------------- + !! *** ROUTINE interp_u_ice *** + !! + !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) + !! To solve issues when parent grid is "land" masked but not all the corresponding child + !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. + !! The child solution will be found in the 9(?) points around + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !! + REAL(wp) :: zrhoy ! local scalar + !!----------------------------------------------------------------------- + ! + IF( before ) THEN ! parent grid + ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) + WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue + ELSE ! child grid + zrhoy = Agrif_Rhoy() + u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1) + ENDIF + ! + END SUBROUTINE interp_u_ice + + + SUBROUTINE interp_v_ice( ptab, i1, i2, j1, j2, before ) + !!----------------------------------------------------------------------- + !! *** ROUTINE interp_v_ice *** + !! + !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) + !! To solve issues when parent grid is "land" masked but not all the corresponding child + !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. + !! The child solution will be found in the 9(?) points around + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !! + REAL(wp) :: zrhox ! local scalar + !!----------------------------------------------------------------------- + ! + IF( before ) THEN ! parent grid + ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) + WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue + ELSE ! child grid + zrhox = Agrif_Rhox() + v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1) + ENDIF + ! + END SUBROUTINE interp_v_ice + + + SUBROUTINE interp_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) + !!----------------------------------------------------------------------- + !! *** ROUTINE interp_tra_ice *** + !! + !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) + !! To solve issues when parent grid is "land" masked but not all the corresponding child + !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. + !! The child solution will be found in the 9(?) points around + !!----------------------------------------------------------------------- + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb, ndir + !! + INTEGER :: ji, jj, jk, jl, jm + INTEGER :: imin, imax, jmin, jmax + LOGICAL :: western_side, eastern_side, northern_side, southern_side + REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab + !!----------------------------------------------------------------------- + ! tracers are not multiplied by grid cell here => before: * e1e2t ; after: * r1_e1e2t / rhox / rhoy + ! and it is ok since we conserve tracers (same as in the ocean). + ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) ) + + IF( before ) THEN ! parent grid + jm = 1 + DO jl = 1, jpl + ptab(i1:i2,j1:j2,jm ) = a_i (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) + jm = jm + 9 + DO jk = 1, nlay_s + ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 + END DO + DO jk = 1, nlay_i + ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 + END DO + END DO + + DO jk = k1, k2 + WHERE( tmask(i1:i2,j1:j2,1) == 0._wp ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue + END DO + ! + ELSE ! child grid + ! +! IF( nbghostcells > 1 ) THEN ! ==> The easiest interpolation is used + ! + jm = 1 + DO jl = 1, jpl + ! + DO jj = j1, j2 + DO ji = i1, i2 + a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) + v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) + v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) + sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) + oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) + a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) + v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) + v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) + t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) + END DO + END DO + jm = jm + 9 + ! + DO jk = 1, nlay_s + e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) + jm = jm + 1 + END DO + ! + DO jk = 1, nlay_i + e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) + jm = jm + 1 + END DO + ! + END DO + ! +!!==> clem: this interpolation does not work because it creates negative values, due +!! to negative coefficients when mixing points (for ex. z7) +!! +! ELSE ! ==> complex interpolation (only one ghost cell available) +! !! Use a more complex interpolation since we mix solutions over a couple of grid points +! !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) +! ! record ztab +! jm = 1 +! DO jl = 1, jpl +! ztab(:,:,jm ) = a_i (:,:,jl) +! ztab(:,:,jm+1) = v_i (:,:,jl) +! ztab(:,:,jm+2) = v_s (:,:,jl) +! ztab(:,:,jm+3) = sv_i(:,:,jl) +! ztab(:,:,jm+4) = oa_i(:,:,jl) +! ztab(:,:,jm+5) = a_ip(:,:,jl) +! ztab(:,:,jm+6) = v_ip(:,:,jl) +! ztab(:,:,jm+7) = v_il(:,:,jl) +! ztab(:,:,jm+8) = t_su(:,:,jl) +! jm = jm + 9 +! DO jk = 1, nlay_s +! ztab(:,:,jm) = e_s(:,:,jk,jl) +! jm = jm + 1 +! END DO +! DO jk = 1, nlay_i +! ztab(:,:,jm) = e_i(:,:,jk,jl) +! jm = jm + 1 +! END DO +! ! +! END DO +! ! +! ! borders of the domain +! western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) +! southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) +! ! +! ! spatial smoothing +! zrhox = Agrif_Rhox() +! z1 = ( zrhox - 1. ) * 0.5 +! z3 = ( zrhox - 1. ) / ( zrhox + 1. ) +! z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) +! z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) +! z2 = 1. - z1 +! z4 = 1. - z3 +! z5 = 1. - z6 - z7 +! ! +! ! Remove corners +! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 +! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 +! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2 +! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 +! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2 +! +! ! smoothed fields +! IF( eastern_side ) THEN +! ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) +! DO jj = jmin, jmax +! rswitch = 0. +! IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. +! ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) & +! & + umask(nlci-2,jj,1) * & +! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) & +! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) +! ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) +! END DO +! ENDIF +! ! +! IF( northern_side ) THEN +! ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) +! DO ji = imin, imax +! rswitch = 0. +! IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. +! ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) & +! & + vmask(ji,nlcj-2,1) * & +! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) & +! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) +! ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) +! END DO +! END IF +! ! +! IF( western_side) THEN +! ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) +! DO jj = jmin, jmax +! rswitch = 0. +! IF( u_ice(2,jj) < 0._wp ) rswitch = 1. +! ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:) & +! & + umask(2,jj,1) * & +! & ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & +! & + rswitch * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) +! ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) +! END DO +! ENDIF +! ! +! IF( southern_side ) THEN +! ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) +! DO ji = imin, imax +! rswitch = 0. +! IF( v_ice(ji,2) < 0._wp ) rswitch = 1. +! ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:) & +! & + vmask(ji,2,1) * & +! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & +! & + rswitch * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) +! ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) +! END DO +! END IF +! ! +! ! Treatment of corners +! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south +! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north +! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south +! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north +! +! ! retrieve ice tracers +! jm = 1 +! DO jl = 1, jpl +! ! +! DO jj = j1, j2 +! DO ji = i1, i2 +! a_i (ji,jj,jl) = ztab(ji,jj,jm ) * tmask(ji,jj,1) +! v_i (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1) +! v_s (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1) +! sv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1) +! oa_i(ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1) +! a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1) +! v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1) +! v_il(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) +! t_su(ji,jj,jl) = ztab(ji,jj,jm+8) * tmask(ji,jj,1) +! END DO +! END DO +! jm = jm + 9 +! ! +! DO jk = 1, nlay_s +! e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) +! jm = jm + 1 +! END DO +! ! +! DO jk = 1, nlay_i +! e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) +! jm = jm + 1 +! END DO +! ! +! END DO +! +! ENDIF ! nbghostcells=1 + + DO jl = 1, jpl + WHERE( tmask(i1:i2,j1:j2,1) == 0._wp ) t_su(i1:i2,j1:j2,jl) = rt0 ! to avoid a division by 0 in sbcblk.F90 + END DO + ! + ENDIF + + DEALLOCATE( ztab ) + ! + END SUBROUTINE interp_tra_ice + +#else + !!---------------------------------------------------------------------- + !! Empty module no sea-ice + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_ice_interp_empty + WRITE(*,*) 'agrif_ice_interp : You should not have seen this print! error?' + END SUBROUTINE agrif_ice_interp_empty +#endif + + !!====================================================================== +END MODULE agrif_ice_interp diff --git a/V4.0/nemo_sources/src/NST/agrif_ice_update.F90 b/V4.0/nemo_sources/src/NST/agrif_ice_update.F90 new file mode 100644 index 0000000000000000000000000000000000000000..797b44f64faee8feae57e5c4c304eb69672ca25e --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_ice_update.F90 @@ -0,0 +1,233 @@ +#define TWO_WAY +!!#undef TWO_WAY +#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ + +MODULE agrif_ice_update + !!===================================================================================== + !! *** MODULE agrif_ice_update *** + !! Nesting module : update surface ocean boundary condition over ice from a child grid + !!===================================================================================== + !! History : 2.0 ! 04-2008 (F. Dupont) initial version + !! 3.4 ! 08-2012 (R. Benshila, C. Herbaut) update and EVP + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' : SI3 sea-ice model + !! 'key_agrif' : AGRIF library + !!---------------------------------------------------------------------- + !! agrif_update_ice : update sea-ice on boundaries or total + !! child domain for velocities and ice properties + !! update_tra_ice : sea-ice properties + !! update_u_ice : zonal ice velocity + !! update_v_ice : meridional ice velocity + !!---------------------------------------------------------------------- + USE dom_oce + USE sbc_oce + USE agrif_oce + USE ice + USE agrif_ice + USE phycst , ONLY: rt0 + + IMPLICIT NONE + PRIVATE + + PUBLIC agrif_update_ice ! called by agrif_user.F90 and icestp.F90 + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_ice_update.F90 13479 2020-09-16 16:56:46Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE agrif_update_ice( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_update_ice *** + !! ** Method : Call the hydrostaticupdate pressure at the boundary or the entire domain + !! + !! ** Action : - Update (u_ice,v_ice) and ice tracers + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() .OR. nn_ice == 0 ) RETURN ! do not update if inside Parent Grid or if child domain does not have ice + ! +! IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc)/nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN ! update only at the parent ice time step + IF ( MOD(Agrif_parent_nb_step(), Agrif_Parent(nn_fsbc)) /=0 ) RETURN ! Update only at the parent ice time step + ! It is assumed that at such a time, there is a child ice step which is true + ! as long as MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc )==0. + ! (This condition is checked in agrif_user, Agrif_InitValues_cont_ice subroutine) + IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update sea ice from grid Number',Agrif_Fixed(), agrif_nb_step() + ! + ! + Agrif_SpecialValueFineGrid = -9999. + Agrif_UseSpecialValueInUpdate = .TRUE. + +# if defined TWO_WAY +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable( tra_ice_id , procname = update_tra_ice ) +#else + CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/1,0/), procname = update_tra_ice ) +#endif +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable( u_ice_id , procname = update_u_ice ) + CALL Agrif_Update_Variable( v_ice_id , procname = update_v_ice ) +#else + CALL Agrif_Update_Variable( u_ice_id , locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname=update_u_ice) + CALL Agrif_Update_Variable( v_ice_id , locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname=update_v_ice) +#endif +! CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/0,2/), procname = update_tra_ice ) +! CALL Agrif_Update_Variable( u_ice_id , locupdate=(/0,1/), procname = update_u_ice ) +! CALL Agrif_Update_Variable( v_ice_id , locupdate=(/0,1/), procname = update_v_ice ) +# endif + Agrif_SpecialValueFineGrid = 0. + Agrif_UseSpecialValueInUpdate = .FALSE. + ! + END SUBROUTINE agrif_update_ice + + + SUBROUTINE update_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before ) + !!----------------------------------------------------------------------- + !! *** ROUTINE update_tra_ice *** + !! ** Method : Compute the mass properties on the fine grid and recover + !! the properties per mass on the coarse grid + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji, jj, jk, jl, jm + !!----------------------------------------------------------------------- + ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean). + IF( before ) THEN + jm = 1 + DO jl = 1, jpl + ptab(i1:i2,j1:j2,jm ) = a_i (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) + ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) + jm = jm + 9 + DO jk = 1, nlay_s + ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 + END DO + DO jk = 1, nlay_i + ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 + END DO + END DO + ! + DO jk = k1, k2 + WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid + END DO + ! + ELSE + ! + jm = 1 + DO jl = 1, jpl + ! + DO jj = j1, j2 + DO ji = i1, i2 + IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN + a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) + v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) + v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) + sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) + oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) + a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) + v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) + v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) + t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) + ENDIF + END DO + END DO + jm = jm + 9 + ! + DO jk = 1, nlay_s + WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) + e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) + ENDWHERE + jm = jm + 1 + END DO + ! + DO jk = 1, nlay_i + WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) + e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) + ENDWHERE + jm = jm + 1 + END DO + ! + END DO + ! + DO jl = 1, jpl + WHERE( tmask(i1:i2,j1:j2,1) == 0._wp ) t_su(i1:i2,j1:j2,jl) = rt0 ! to avoid a division by 0 in sbcblk.F90 + END DO + + ENDIF + ! + END SUBROUTINE update_tra_ice + + + SUBROUTINE update_u_ice( ptab, i1, i2, j1, j2, before ) + !!----------------------------------------------------------------------- + !! *** ROUTINE update_u_ice *** + !! ** Method : Update the fluxes and recover the properties (C-grid) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !! + REAL(wp) :: zrhoy ! local scalar + !!----------------------------------------------------------------------- + ! + IF( before ) THEN + zrhoy = Agrif_Rhoy() + ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy + WHERE( umask(i1:i2,j1:j2,1) == 0._wp ) ptab(:,:) = Agrif_SpecialValueFineGrid + ELSE + WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) + u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) + ENDWHERE + ENDIF + ! + END SUBROUTINE update_u_ice + + + SUBROUTINE update_v_ice( ptab, i1, i2, j1, j2, before ) + !!----------------------------------------------------------------------- + !! *** ROUTINE update_v_ice *** + !! ** Method : Update the fluxes and recover the properties (C-grid) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !! + REAL(wp) :: zrhox ! local scalar + !!----------------------------------------------------------------------- + ! + IF( before ) THEN + zrhox = Agrif_Rhox() + ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox + WHERE( vmask(i1:i2,j1:j2,1) == 0._wp ) ptab(:,:) = Agrif_SpecialValueFineGrid + ELSE + WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) + v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) + ENDWHERE + ENDIF + ! + END SUBROUTINE update_v_ice + +#else + !!---------------------------------------------------------------------- + !! Empty module no sea-ice + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_ice_update_empty + WRITE(*,*) 'agrif_ice_update : You should not have seen this print! error?' + END SUBROUTINE agrif_ice_update_empty +#endif + + !!====================================================================== +END MODULE agrif_ice_update diff --git a/V4.0/nemo_sources/src/NST/agrif_oce.F90 b/V4.0/nemo_sources/src/NST/agrif_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3953614303fd57224370170e989d142ff9a57f61 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_oce.F90 @@ -0,0 +1,322 @@ +MODULE agrif_oce + !!====================================================================== + !! *** MODULE agrif_oce *** + !! AGRIF : define in memory AGRIF variables + !!---------------------------------------------------------------------- + !! History : 2.0 ! 2007-12 (R. Benshila) Original code + !!---------------------------------------------------------------------- +#if defined key_agrif + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! domain parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC agrif_oce_alloc ! routine called by nemo_init in nemogcm.F90 +#if defined key_vertical + PUBLIC reconstructandremap ! remapping routine +#endif + ! !!* Namelist namagrif: AGRIF parameters + LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: + INTEGER , PUBLIC, PARAMETER :: nn_sponge_len = 2 !: Sponge width (in number of parent grid points) + REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers + REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics + LOGICAL , PUBLIC :: ln_chk_bathy = .FALSE. !: check of parent bathymetry + LOGICAL , PUBLIC :: lk_agrif_clp = .FALSE. !: Force clamped bcs + ! !!! OLD namelist names + REAL(wp), PUBLIC :: visc_tra !: sponge coeff. for tracers + REAL(wp), PUBLIC :: visc_dyn !: sponge coeff. for dynamics + + LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator + LOGICAL , PUBLIC :: spongedoneU = .FALSE. !: dynamics sponge layer indicator + LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step + LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE. !: if true: print debugging info + + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn +# if defined key_top + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn +# endif + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities + + ! Barotropic arrays used to store open boundary data during time-splitting loop: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubdy_w, vbdy_w, hbdy_w + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubdy_e, vbdy_e, hbdy_e + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubdy_n, vbdy_n, hbdy_n + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubdy_s, vbdy_s, hbdy_s + + + INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update + INTEGER, PUBLIC :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations + INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates + INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers +# if defined key_top + INTEGER, PUBLIC :: trn_id, trn_sponge_id +# endif + INTEGER, PUBLIC :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id + INTEGER, PUBLIC :: ub2b_update_id, vb2b_update_id + INTEGER, PUBLIC :: e3t_id, e1u_id, e2v_id, sshn_id + INTEGER, PUBLIC :: scales_t_id + INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators + INTEGER, PUBLIC :: umsk_id, vmsk_id + INTEGER, PUBLIC :: kindic_agr + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION agrif_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION agrif_oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj), & + & fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj), & + & tabspongedone_tsn(jpi,jpj), & +# if defined key_top + & tabspongedone_trn(jpi,jpj), & +# endif + & tabspongedone_u (jpi,jpj), & + & tabspongedone_v (jpi,jpj), STAT = ierr(1) ) + + ALLOCATE( ubdy_w(nbghostcells,jpj), vbdy_w(nbghostcells,jpj), hbdy_w(nbghostcells,jpj), & + & ubdy_e(nbghostcells,jpj), vbdy_e(nbghostcells,jpj), hbdy_e(nbghostcells,jpj), & + & ubdy_n(jpi,nbghostcells), vbdy_n(jpi,nbghostcells), hbdy_n(jpi,nbghostcells), & + & ubdy_s(jpi,nbghostcells), vbdy_s(jpi,nbghostcells), hbdy_s(jpi,nbghostcells), STAT = ierr(2) ) + + agrif_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION agrif_oce_alloc + +#if defined key_vertical + SUBROUTINE reconstructandremap(tabin,hin,tabout,hout,N,Nout) + !!---------------------------------------------------------------------- + !! *** FUNCTION reconstructandremap *** + !!---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER N, Nout + REAL(wp) tabin(N), tabout(Nout) + REAL(wp) hin(N), hout(Nout) + REAL(wp) coeffremap(N,3),zwork(N,3) + REAL(wp) zwork2(N+1,3) + INTEGER jk + DOUBLE PRECISION, PARAMETER :: dsmll=1.0d-8 + REAL(wp) q,q01,q02,q001,q002,q0 + REAL(wp) z_win(1:N+1), z_wout(1:Nout+1) + REAL(wp),PARAMETER :: dpthin = 1.D-3 + INTEGER :: k1, kbox, ktop, ka, kbot + REAL(wp) :: tsum, qbot, rpsum, zbox, ztop, zthk, zbot, offset, qtop + + z_win(1)=0.; z_wout(1)= 0. + DO jk=1,N + z_win(jk+1)=z_win(jk)+hin(jk) + ENDDO + + DO jk=1,Nout + z_wout(jk+1)=z_wout(jk)+hout(jk) + ENDDO + + DO jk=2,N + zwork(jk,1)=1./(hin(jk-1)+hin(jk)) + ENDDO + + DO jk=2,N-1 + q0 = 1./(hin(jk-1)+hin(jk)+hin(jk+1)) + zwork(jk,2)=hin(jk-1)+2.*hin(jk)+hin(jk+1) + zwork(jk,3)=q0 + ENDDO + + DO jk= 2,N + zwork2(jk,1)=zwork(jk,1)*(tabin(jk)-tabin(jk-1)) + ENDDO + + coeffremap(:,1) = tabin(:) + + DO jk=2,N-1 + q001 = hin(jk)*zwork2(jk+1,1) + q002 = hin(jk)*zwork2(jk,1) + IF (q001*q002 < 0) then + q001 = 0. + q002 = 0. + ENDIF + q=zwork(jk,2) + q01=q*zwork2(jk+1,1) + q02=q*zwork2(jk,1) + IF (abs(q001) > abs(q02)) q001 = q02 + IF (abs(q002) > abs(q01)) q002 = q01 + + q=(q001-q002)*zwork(jk,3) + q001=q001-q*hin(jk+1) + q002=q002+q*hin(jk-1) + + coeffremap(jk,3)=coeffremap(jk,1)+q001 + coeffremap(jk,2)=coeffremap(jk,1)-q002 + + zwork2(jk,1)=(2.*q001-q002)**2 + zwork2(jk,2)=(2.*q002-q001)**2 + ENDDO + + DO jk=1,N + IF(jk.EQ.1 .OR. jk.EQ.N .OR. hin(jk).LE.dpthin) THEN + coeffremap(jk,3) = coeffremap(jk,1) + coeffremap(jk,2) = coeffremap(jk,1) + zwork2(jk,1) = 0. + zwork2(jk,2) = 0. + ENDIF + ENDDO + + DO jk=2,N + q002=max(zwork2(jk-1,2),dsmll) + q001=max(zwork2(jk,1),dsmll) + zwork2(jk,3)=(q001*coeffremap(jk-1,3)+q002*coeffremap(jk,2))/(q001+q002) + ENDDO + + zwork2(1,3) = 2*coeffremap(1,1)-zwork2(2,3) + zwork2(N+1,3)=2*coeffremap(N,1)-zwork2(N,3) + + DO jk=1,N + q01=zwork2(jk+1,3)-coeffremap(jk,1) + q02=coeffremap(jk,1)-zwork2(jk,3) + q001=2.*q01 + q002=2.*q02 + IF (q01*q02<0) then + q01=0. + q02=0. + ELSEIF (abs(q01)>abs(q002)) then + q01=q002 + ELSEIF (abs(q02)>abs(q001)) then + q02=q001 + ENDIF + coeffremap(jk,2)=coeffremap(jk,1)-q02 + coeffremap(jk,3)=coeffremap(jk,1)+q01 + ENDDO + + zbot=0.0 + kbot=1 + DO jk=1,Nout + ztop=zbot !top is bottom of previous layer + ktop=kbot + IF (ztop.GE.z_win(ktop+1)) then + ktop=ktop+1 + ENDIF + + zbot=z_wout(jk+1) + zthk=zbot-ztop + + IF(zthk.GT.dpthin .AND. ztop.LT.z_wout(Nout+1)) THEN + + kbot=ktop + DO while (z_win(kbot+1).lt.zbot.and.kbot.lt.N) + kbot=kbot+1 + ENDDO + zbox=zbot + DO k1= jk+1,Nout + IF (z_wout(k1+1)-z_wout(k1).GT.dpthin) THEN + exit !thick layer + ELSE + zbox=z_wout(k1+1) !include thin adjacent layers + IF(zbox.EQ.z_wout(Nout+1)) THEN + exit !at bottom + ENDIF + ENDIF + ENDDO + zthk=zbox-ztop + + kbox=ktop + DO while (z_win(kbox+1).lt.zbox.and.kbox.lt.N) + kbox=kbox+1 + ENDDO + + IF(ktop.EQ.kbox) THEN + IF(z_wout(jk).NE.z_win(kbox).OR.z_wout(jk+1).NE.z_win(kbox+1)) THEN + IF(hin(kbox).GT.dpthin) THEN + q001 = (zbox-z_win(kbox))/hin(kbox) + q002 = (ztop-z_win(kbox))/hin(kbox) + q01=q001**2+q002**2+q001*q002+1.-2.*(q001+q002) + q02=q01-1.+(q001+q002) + q0=1.-q01-q02 + ELSE + q0 = 1.0 + q01 = 0. + q02 = 0. + ENDIF + tabout(jk)=q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3) + ELSE + tabout(jk) = tabin(kbox) + ENDIF + ELSE + IF(ktop.LE.jk .AND. kbox.GE.jk) THEN + ka = jk + ELSEIF (kbox-ktop.GE.3) THEN + ka = (kbox+ktop)/2 + ELSEIF (hin(ktop).GE.hin(kbox)) THEN + ka = ktop + ELSE + ka = kbox + ENDIF !choose ka + + offset=coeffremap(ka,1) + + qtop = z_win(ktop+1)-ztop !partial layer thickness + IF(hin(ktop).GT.dpthin) THEN + q=(ztop-z_win(ktop))/hin(ktop) + q01=q*(q-1.) + q02=q01+q + q0=1-q01-q02 + ELSE + q0 = 1. + q01 = 0. + q02 = 0. + ENDIF + + tsum =((q0*coeffremap(ktop,1)+q01*coeffremap(ktop,2)+q02*coeffremap(ktop,3))-offset)*qtop + + DO k1= ktop+1,kbox-1 + tsum =tsum +(coeffremap(k1,1)-offset)*hin(k1) + ENDDO !k1 + + qbot = zbox-z_win(kbox) !partial layer thickness + IF(hin(kbox).GT.dpthin) THEN + q=qbot/hin(kbox) + q01=(q-1.)**2 + q02=q01-1.+q + q0=1-q01-q02 + ELSE + q0 = 1.0 + q01 = 0. + q02 = 0. + ENDIF + + tsum = tsum +((q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3))-offset)*qbot + + rpsum=1.0d0/zthk + tabout(jk)=offset+tsum*rpsum + + ENDIF !single or multiple layers + ELSE + IF (jk==1) THEN + write(*,'(a7,i4,i4,3f12.5)')'problem = ',N,Nout,zthk,z_wout(jk+1),hout(1) + ENDIF + tabout(jk) = tabout(jk-1) + + ENDIF !normal:thin layer + ENDDO !jk + + return + end subroutine reconstructandremap +#endif + +#endif + !!====================================================================== +END MODULE agrif_oce diff --git a/V4.0/nemo_sources/src/NST/agrif_oce_interp.F90 b/V4.0/nemo_sources/src/NST/agrif_oce_interp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..adfcb3bb2d7f66d2d37ec2e3002d65b94f38f4b6 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_oce_interp.F90 @@ -0,0 +1,1442 @@ +MODULE agrif_oce_interp + !!====================================================================== + !! *** MODULE agrif_oce_interp *** + !! AGRIF: interpolation package for the ocean dynamics (OPA) + !!====================================================================== + !! History : 2.0 ! 2002-06 (L. Debreu) Original cade + !! 3.2 ! 2009-04 (R. Benshila) + !! 3.6 ! 2014-09 (R. Benshila) + !!---------------------------------------------------------------------- +#if defined key_agrif + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !!---------------------------------------------------------------------- + !! Agrif_tra : + !! Agrif_dyn : + !! Agrif_ssh : + !! Agrif_dyn_ts : + !! Agrif_dta_ts : + !! Agrif_ssh_ts : + !! Agrif_avm : + !! interpu : + !! interpv : + !!---------------------------------------------------------------------- + USE par_oce + USE oce + USE dom_oce + USE zdf_oce + USE agrif_oce + USE phycst + USE dynspg_ts, ONLY: un_adv, vn_adv + ! + USE in_out_manager + USE agrif_oce_sponge + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts + PUBLIC Agrif_tra, Agrif_avm + PUBLIC interpun , interpvn + PUBLIC interptsn, interpsshn, interpavm + PUBLIC interpunb, interpvnb , interpub2b, interpvb2b + PUBLIC interpe3t, interpumsk, interpvmsk + + INTEGER :: bdy_tinterp = 0 + +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_oce_interp.F90 12857 2020-05-02 16:06:55Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_tra + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_tra *** + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + ! + CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) + ! + Agrif_UseSpecialValue = .FALSE. + ! + END SUBROUTINE Agrif_tra + + + SUBROUTINE Agrif_dyn( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_DYN *** + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: j1, j2, i1, i2 + INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2 + REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = ln_spc_dyn + ! + CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) + CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) + ! + Agrif_UseSpecialValue = .FALSE. + ! + ! prevent smoothing in ghost cells + i1 = 1 ; i2 = nlci + j1 = 1 ; j2 = nlcj + IF( l_Southedge ) j1 = 2 + nbghostcells + IF( l_Northedge ) j2 = nlcj - nbghostcells - 1 + IF( l_Westedge ) i1 = 2 + nbghostcells + IF( l_Eastedge ) i2 = nlci - nbghostcells - 1 + + ! --- West --- ! + IF( l_Westedge ) THEN + ibdy1 = 2 + ibdy2 = 1+nbghostcells + ! + IF( .NOT.ln_dynspg_ts ) THEN ! Store transport + ua_b(ibdy1:ibdy2,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & + & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj = 1, jpj + ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) + END DO + ENDIF + ! + IF( .NOT.lk_agrif_clp ) THEN + DO jk=1,jpkm1 ! Smooth + DO jj=j1,j2 + ua(ibdy2,jj,jk) = 0.25_wp*(ua(ibdy2-1,jj,jk)+2._wp*ua(ibdy2,jj,jk)+ua(ibdy2+1,jj,jk)) + END DO + END DO + ENDIF + ! + zub(ibdy1:ibdy2,:) = 0._wp ! Correct transport + DO jk = 1, jpkm1 + DO jj = 1, jpj + zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & + & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk)*umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj=1,jpj + zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) + END DO + + DO jk = 1, jpkm1 + DO jj = 1, jpj + ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) & + & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj)) * umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + + IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate + zvb(ibdy1:ibdy2,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) & + & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj = 1, jpj + zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj) + END DO + DO jk = 1, jpkm1 + DO jj = 1, jpj + va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & + & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj))*vmask(ibdy1:ibdy2,jj,jk) + END DO + END DO + ENDIF + ! + DO jk = 1, jpkm1 ! Mask domain edges + DO jj = 1, jpj + ua(1,jj,jk) = 0._wp + va(1,jj,jk) = 0._wp + END DO + END DO + ENDIF + + ! --- East --- ! + IF( l_Eastedge ) THEN + ibdy1 = nlci-1-nbghostcells + ibdy2 = nlci-2 + ! + IF( .NOT.ln_dynspg_ts ) THEN ! Store transport + ua_b(ibdy1:ibdy2,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & + & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj = 1, jpj + ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) + END DO + ENDIF + ! + IF( .NOT.lk_agrif_clp ) THEN + DO jk=1,jpkm1 ! Smooth + DO jj=j1,j2 + ua(ibdy1,jj,jk) = 0.25_wp*(ua(ibdy1-1,jj,jk)+2._wp*ua(ibdy1,jj,jk)+ua(ibdy1+1,jj,jk)) + END DO + END DO + ENDIF + ! + zub(ibdy1:ibdy2,:) = 0._wp ! Correct transport + DO jk = 1, jpkm1 + DO jj = 1, jpj + zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & + & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj=1,jpj + zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) + END DO + + DO jk = 1, jpkm1 + DO jj = 1, jpj + ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) & + & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj))*umask(ibdy1:ibdy2,jj,jk) + END DO + END DO + + IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate + ibdy1 = ibdy1 + 1 + ibdy2 = ibdy2 + 1 + zvb(ibdy1:ibdy2,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) & + & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk) + END DO + END DO + DO jj = 1, jpj + zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj) + END DO + DO jk = 1, jpkm1 + DO jj = 1, jpj + va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & + & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj)) * vmask(ibdy1:ibdy2,jj,jk) + END DO + END DO + ENDIF + ! + DO jk = 1, jpkm1 ! Mask domain edges + DO jj = 1, jpj + ua(nlci-1,jj,jk) = 0._wp + va(nlci ,jj,jk) = 0._wp + END DO + END DO + ENDIF + + ! --- South --- ! + IF ( l_Southedge ) THEN + jbdy1 = 2 + jbdy2 = 1+nbghostcells + ! + IF( .NOT.ln_dynspg_ts ) THEN ! Store transport + va_b(:,jbdy1:jbdy2) = 0._wp + DO jk = 1, jpkm1 + DO ji = 1, jpi + va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & + & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji=1,jpi + va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) + END DO + ENDIF + ! + IF ( .NOT.lk_agrif_clp ) THEN + DO jk = 1, jpkm1 ! Smooth + DO ji = i1, i2 + va(ji,jbdy2,jk) = 0.25_wp*(va(ji,jbdy2-1,jk)+2._wp*va(ji,jbdy2,jk)+va(ji,jbdy2+1,jk)) + END DO + END DO + ENDIF + ! + zvb(:,jbdy1:jbdy2) = 0._wp ! Correct transport + DO jk=1,jpkm1 + DO ji=1,jpi + zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & + & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji = 1, jpi + zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) + END DO + + DO jk = 1, jpkm1 + DO ji = 1, jpi + va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & + & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + + IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate + zub(:,jbdy1:jbdy2) = 0._wp + DO jk = 1, jpkm1 + DO ji = 1, jpi + zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & + & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji = 1, jpi + zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2) + END DO + + DO jk = 1, jpkm1 + DO ji = 1, jpi + ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & + & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk) + END DO + END DO + ENDIF + ! + DO jk = 1, jpkm1 ! Mask domain edges + DO ji = 1, jpi + ua(ji,1,jk) = 0._wp + va(ji,1,jk) = 0._wp + END DO + END DO + ENDIF + + ! --- North --- ! + IF( l_Northedge ) THEN + jbdy1 = nlcj-1-nbghostcells + jbdy2 = nlcj-2 + ! + IF( .NOT.ln_dynspg_ts ) THEN ! Store transport + va_b(:,jbdy1:jbdy2) = 0._wp + DO jk = 1, jpkm1 + DO ji = 1, jpi + va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & + & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji=1,jpi + va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) + END DO + ENDIF + ! + IF ( .NOT.lk_agrif_clp ) THEN + DO jk = 1, jpkm1 ! Smooth + DO ji = i1, i2 + va(ji,jbdy1,jk) = 0.25_wp*(va(ji,jbdy1-1,jk)+2._wp*va(ji,jbdy1,jk)+va(ji,jbdy1+1,jk)) + END DO + END DO + ENDIF + ! + zvb(:,jbdy1:jbdy2) = 0._wp ! Correct transport + DO jk=1,jpkm1 + DO ji=1,jpi + zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & + & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji = 1, jpi + zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) + END DO + + DO jk = 1, jpkm1 + DO ji = 1, jpi + va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & + & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk) + END DO + END DO + + IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate + jbdy1 = jbdy1 + 1 + jbdy2 = jbdy2 + 1 + zub(:,jbdy1:jbdy2) = 0._wp + DO jk = 1, jpkm1 + DO ji = 1, jpi + zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & + & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk) + END DO + END DO + DO ji = 1, jpi + zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2) + END DO + + DO jk = 1, jpkm1 + DO ji = 1, jpi + ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & + & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk) + END DO + END DO + ENDIF + ! + DO jk = 1, jpkm1 ! Mask domain edges + DO ji = 1, jpi + ua(ji,nlcj ,jk) = 0._wp + va(ji,nlcj-1,jk) = 0._wp + END DO + END DO + ENDIF + ! + END SUBROUTINE Agrif_dyn + + + SUBROUTINE Agrif_dyn_ts( jn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_dyn_ts *** + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: jn + !! + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + IF( l_Westedge ) THEN + DO jj=1,jpj + va_e(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * hvr_e(2:nbghostcells+1,jj) + ! Specified fluxes: + ua_e(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * hur_e(2:nbghostcells+1,jj) + ! Characteristics method (only if ghostcells=1): + !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & + !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) + END DO + ENDIF + ! + IF( l_Eastedge ) THEN + DO jj=1,jpj + va_e(nlci-nbghostcells:nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) + ! Specified fluxes: + ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) + ! Characteristics method (only if ghostcells=1): + !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & + !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) + END DO + ENDIF + ! + IF ( l_Southedge ) THEN + DO ji=1,jpi + ua_e(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * hur_e(ji,2:nbghostcells+1) + ! Specified fluxes: + va_e(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * hvr_e(ji,2:nbghostcells+1) + ! Characteristics method (only if ghostcells=1): + !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & + !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) + END DO + ENDIF + ! + IF ( l_Northedge ) THEN + DO ji=1,jpi + ua_e(ji,nlcj-nbghostcells:nlcj-1) = ubdy_n(ji,1:nbghostcells) * hur_e(ji,nlcj-nbghostcells:nlcj-1) + ! Specified fluxes: + va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) + ! Characteristics method (only if ghostcells=1): + !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & + !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) + END DO + ENDIF + ! + END SUBROUTINE Agrif_dyn_ts + + + SUBROUTINE Agrif_dta_ts( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_dta_ts *** + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + !! + INTEGER :: ji, jj + LOGICAL :: ll_int_cons + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only + ! + ! Enforce volume conservation if no time refinement: + IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE. + ! + ! Interpolate barotropic fluxes + Agrif_SpecialValue=0._wp + Agrif_UseSpecialValue = ln_spc_dyn + ! + IF( ll_int_cons ) THEN ! Conservative interpolation + ! order matters here !!!!!! + CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated + CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) + bdy_tinterp = 1 + CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After + CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb ) + bdy_tinterp = 2 + CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before + CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb ) + ELSE ! Linear interpolation + bdy_tinterp = 0 + ubdy_w(:,:) = 0._wp ; vbdy_w(:,:) = 0._wp + ubdy_e(:,:) = 0._wp ; vbdy_e(:,:) = 0._wp + ubdy_n(:,:) = 0._wp ; vbdy_n(:,:) = 0._wp + ubdy_s(:,:) = 0._wp ; vbdy_s(:,:) = 0._wp + CALL Agrif_Bc_variable( unb_id, procname=interpunb ) + CALL Agrif_Bc_variable( vnb_id, procname=interpvnb ) + ENDIF + Agrif_UseSpecialValue = .FALSE. + ! + END SUBROUTINE Agrif_dta_ts + + + SUBROUTINE Agrif_ssh( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_ssh *** + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + ! + INTEGER :: ji, jj, indx, indy + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + ! Linear time interpolation of sea level + ! + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + CALL Agrif_Bc_variable(sshn_id, procname=interpsshn ) + Agrif_UseSpecialValue = .FALSE. + ! + ! --- West --- ! + IF( l_Westedge ) THEN + indx = 1+nbghostcells + DO jj = 1, jpj + DO ji = 2, indx + ssha(ji,jj) = hbdy_w(ji-1,jj) + ENDDO + ENDDO + ENDIF + ! + ! --- East --- ! + IF( l_Eastedge ) THEN + indx = nlci-nbghostcells + DO jj = 1, jpj + DO ji = indx, nlci-1 + ssha(ji,jj) = hbdy_e(ji-indx+1,jj) + ENDDO + ENDDO + ENDIF + ! + ! --- South --- ! + IF ( l_Southedge ) THEN + indy = 1+nbghostcells + DO jj = 2, indy + DO ji = 1, jpi + ssha(ji,jj) = hbdy_s(ji,jj-1) + ENDDO + ENDDO + ENDIF + ! + ! --- North --- ! + IF ( l_Northedge ) THEN + indy = nlcj-nbghostcells + DO jj = indy, nlcj-1 + DO ji = 1, jpi + ssha(ji,jj) = hbdy_n(ji,jj-indy+1) + ENDDO + ENDDO + ENDIF + ! + END SUBROUTINE Agrif_ssh + + + SUBROUTINE Agrif_ssh_ts( jn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_ssh_ts *** + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: jn + !! + INTEGER :: ji, jj, indx, indy + !!---------------------------------------------------------------------- + !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) + ! + IF( Agrif_Root() ) RETURN + ! + ! --- West --- ! + IF( l_Westedge ) THEN + indx = 1+nbghostcells + DO jj = 1, jpj + DO ji = 2, indx + ssha_e(ji,jj) = hbdy_w(ji-1,jj) + ENDDO + ENDDO + ENDIF + ! + ! --- East --- ! + IF( l_Eastedge ) THEN + indx = nlci-nbghostcells + DO jj = 1, jpj + DO ji = indx, nlci-1 + ssha_e(ji,jj) = hbdy_e(ji-indx+1,jj) + ENDDO + ENDDO + ENDIF + ! + ! --- South --- ! + IF( l_Southedge ) THEN + indy = 1+nbghostcells + DO jj = 2, indy + DO ji = 1, jpi + ssha_e(ji,jj) = hbdy_s(ji,jj-1) + ENDDO + ENDDO + ENDIF + ! + ! --- North --- ! + IF( l_Northedge ) THEN + indy = nlcj-nbghostcells + DO jj = indy, nlcj-1 + DO ji = 1, jpi + ssha_e(ji,jj) = hbdy_n(ji,jj-indy+1) + ENDDO + ENDDO + ENDIF + ! + END SUBROUTINE Agrif_ssh_ts + + SUBROUTINE Agrif_avm + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_avm *** + !!---------------------------------------------------------------------- + REAL(wp) :: zalpha + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + zalpha = 1._wp ! JC: proper time interpolation impossible + ! => use last available value from parent + ! + Agrif_SpecialValue = 0.e0 + Agrif_UseSpecialValue = .TRUE. + ! + CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) + ! + Agrif_UseSpecialValue = .FALSE. + ! + END SUBROUTINE Agrif_avm + + + SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interptsn *** + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj, jk, jn, iref, jref, ibdy, jbdy ! dummy loop indices + INTEGER :: imin, imax, jmin, jmax, N_in, N_out + REAL(wp) :: zrho, z1, z2, z3, z4, z5, z6, z7 + LOGICAL :: western_side, eastern_side,northern_side,southern_side + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child + REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin + REAL(wp), DIMENSION(k1:k2) :: h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + REAL(wp) :: h_diff + + IF( before ) THEN + DO jn = 1,jpts + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) + END DO + END DO + END DO + END DO + +# if defined key_vertical + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) + END DO + END DO + END DO +# endif + ELSE + + western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) + +# if defined key_vertical + DO jj=j1,j2 + DO ji=i1,i2 + iref = ji + jref = jj + if(western_side) iref=MAX(2,ji) + if(eastern_side) iref=MIN(nlci-1,ji) + if(southern_side) jref=MAX(2,jj) + if(northern_side) jref=MIN(nlcj-1,jj) + N_in = 0 + DO jk=k1,k2 !k2 = jpk of parent grid + IF (ptab(ji,jj,jk,n2) == 0) EXIT + N_in = N_in + 1 + tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) + h_in(N_in) = ptab(ji,jj,jk,n2) + END DO + N_out = 0 + DO jk=1,jpk ! jpk of child grid + IF (tmask(iref,jref,jk) == 0) EXIT + N_out = N_out + 1 + h_out(jk) = e3t_n(iref,jref,jk) + ENDDO + IF (N_in > 0) THEN + DO jn=1,jpts + call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO +# else + ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts) +# endif + ! + DO jn=1, jpts + tsa(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) + END DO + + IF ( .NOT.lk_agrif_clp ) THEN + ! + imin = i1 ; imax = i2 + jmin = j1 ; jmax = j2 + ! + ! Remove CORNERS + IF( l_Southedge ) jmin = 2 + nbghostcells + IF( l_Northedge ) jmax = nlcj - nbghostcells - 1 + IF( l_Westedge ) imin = 2 + nbghostcells + IF( l_Eastedge ) imax = nlci - nbghostcells - 1 + ! + IF( eastern_side ) THEN + zrho = Agrif_Rhox() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + ibdy = nlci-nbghostcells + DO jn = 1, jpts + tsa(ibdy+1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO jj = jmin,jmax + IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN + tsa(ibdy,jj,jk,jn) = tsa(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk) + ELSE + tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy+1,jj,jk,jn)+z3*tsa(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk) + IF( un(ibdy-1,jj,jk) > 0._wp ) THEN + tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy-1,jj,jk,jn)+z5*tsa(ibdy+1,jj,jk,jn) & + + z7*tsa(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tsa(ibdy+1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy+1,jmin:jmax,1:jpkm1) + END DO + ENDIF + ! + IF( northern_side ) THEN + zrho = Agrif_Rhoy() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + jbdy = nlcj-nbghostcells + DO jn = 1, jpts + tsa(imin:imax,jbdy+1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO ji = imin,imax + IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN + tsa(ji,jbdy,jk,jn) = tsa(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk) + ELSE + tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy+1,jk,jn)+z3*tsa(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk) + IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN + tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy-1,jk,jn)+z5*tsa(ji,jbdy+1,jk,jn) & + + z7*tsa(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tsa(imin:imax,jbdy+1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) * tmask(imin:imax,jbdy+1,1:jpkm1) + END DO + ENDIF + ! + IF( western_side ) THEN + zrho = Agrif_Rhox() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + ibdy = 1+nbghostcells + DO jn = 1, jpts + tsa(ibdy-1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO jj = jmin,jmax + IF( umask(ibdy,jj,jk) == 0._wp ) THEN + tsa(ibdy,jj,jk,jn) = tsa(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk) + ELSE + tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy-1,jj,jk,jn)+z3*tsa(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk) + IF( un(ibdy,jj,jk) < 0._wp ) THEN + tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy+1,jj,jk,jn)+z5*tsa(ibdy-1,jj,jk,jn) & + + z7*tsa(ibdy+2,jj,jk,jn) ) * tmask(ibdy,jj,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tsa(ibdy-1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy-1,jmin:jmax,1:jpkm1) + END DO + ENDIF + ! + IF( southern_side ) THEN + zrho = Agrif_Rhoy() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + jbdy=1+nbghostcells + DO jn = 1, jpts + tsa(imin:imax,jbdy-1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO ji = imin,imax + IF( vmask(ji,jbdy,jk) == 0._wp ) THEN + tsa(ji,jbdy,jk,jn)=tsa(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk) + ELSE + tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy-1,jk,jn)+z3*tsa(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk) + IF( vn(ji,jbdy,jk) < 0._wp ) THEN + tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy+1,jk,jn)+z5*tsa(ji,jbdy-1,jk,jn) & + + z7*tsa(ji,jbdy+2,jk,jn) ) * tmask(ji,jbdy,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tsa(imin:imax,jbdy-1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) * tmask(imin:imax,jbdy-1,1:jpkm1) + END DO + ENDIF + ! + ENDIF + ENDIF + ! + END SUBROUTINE interptsn + + SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpsshn *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + LOGICAL :: western_side, eastern_side,northern_side,southern_side + !!---------------------------------------------------------------------- + ! + IF( before) THEN + ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + !! clem ghost + IF(western_side) hbdy_w(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) + IF(eastern_side) hbdy_e(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) + IF(southern_side) hbdy_s(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) + IF(northern_side) hbdy_n(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) + ENDIF + ! + END SUBROUTINE interpsshn + + SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpun *** + !!--------------------------------------------- + !! + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab + LOGICAL, INTENT(in) :: before + INTEGER, INTENT(in) :: nb , ndir + !! + INTEGER :: ji,jj,jk + REAL(wp) :: zrhoy + ! vertical interpolation: + REAL(wp), DIMENSION(k1:k2) :: tabin, h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out, iref + REAL(wp) :: h_diff + LOGICAL :: western_side, eastern_side + !!--------------------------------------------- + ! + IF (before) THEN + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk)) +# if defined key_vertical + ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)) +# endif + END DO + END DO + END DO + ELSE + zrhoy = Agrif_rhoy() +# if defined key_vertical +! VERTICAL REFINEMENT BEGIN + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + + DO ji=i1,i2 + iref = ji + IF (western_side) iref = MAX(2,ji) + IF (eastern_side) iref = MIN(nlci-2,ji) + DO jj=j1,j2 + N_in = 0 + DO jk=k1,k2 + IF (ptab(ji,jj,jk,2) == 0) EXIT + N_in = N_in + 1 + tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) + h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) + ENDDO + + IF (N_in == 0) THEN + ua(ji,jj,:) = 0._wp + CYCLE + ENDIF + + N_out = 0 + DO jk=1,jpk + if (umask(iref,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3u_a(iref,jj,jk) + ENDDO + + IF (N_out == 0) THEN + ua(ji,jj,:) = 0._wp + CYCLE + ENDIF + + IF (N_in * N_out > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) +! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly + if (h_diff < -1.e4) then + print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) +! stop + endif + ENDIF + call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + ENDDO + ENDDO + +# else + DO jk = 1, jpkm1 + DO jj=j1,j2 + ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) ) + END DO + END DO +# endif + + ENDIF + ! + END SUBROUTINE interpun + + SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpvn *** + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab + LOGICAL, INTENT(in) :: before + INTEGER, INTENT(in) :: nb , ndir + ! + INTEGER :: ji,jj,jk + REAL(wp) :: zrhox + ! vertical interpolation: + REAL(wp), DIMENSION(k1:k2) :: tabin, h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out, jref + REAL(wp) :: h_diff + LOGICAL :: northern_side,southern_side + !!--------------------------------------------- + ! + IF (before) THEN + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk)) +# if defined key_vertical + ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk) +# endif + END DO + END DO + END DO + ELSE + zrhox = Agrif_rhox() +# if defined key_vertical + + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + + DO jj=j1,j2 + jref = jj + IF (southern_side) jref = MAX(2,jj) + IF (northern_side) jref = MIN(nlcj-2,jj) + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 + if (ptab(ji,jj,jk,2) == 0) EXIT + N_in = N_in + 1 + tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) + h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) + END DO + IF (N_in == 0) THEN + va(ji,jj,:) = 0._wp + CYCLE + ENDIF + + N_out = 0 + DO jk=1,jpk + if (vmask(ji,jref,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3v_a(ji,jref,jk) + END DO + IF (N_out == 0) THEN + va(ji,jj,:) = 0._wp + CYCLE + ENDIF + call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + END DO + END DO +# else + DO jk = 1, jpkm1 + va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) ) + END DO +# endif + ENDIF + ! + END SUBROUTINE interpvn + + SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpunb *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj + REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff + LOGICAL :: western_side, eastern_side,northern_side,southern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2) + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + zrhoy = Agrif_Rhoy() + zrhot = Agrif_rhot() + ! Time indexes bounds for integration + zt0 = REAL(Agrif_NbStepint() , wp) / zrhot + zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot + ! Polynomial interpolation coefficients: + IF( bdy_tinterp == 1 ) THEN + ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & + & - zt0**2._wp * ( zt0 - 1._wp) ) + ELSEIF( bdy_tinterp == 2 ) THEN + ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & + & - zt0 * ( zt0 - 1._wp)**2._wp ) + ELSE + ztcoeff = 1 + ENDIF + ! + IF(western_side) ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2) + IF(eastern_side) ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2) + IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) + IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) + ! + IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN + IF(western_side) ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) + IF(eastern_side) ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) + IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) + IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) + ENDIF + ENDIF + ! + END SUBROUTINE interpunb + + + SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpvnb *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji,jj + REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff + LOGICAL :: western_side, eastern_side,northern_side,southern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2) + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + zrhox = Agrif_Rhox() + zrhot = Agrif_rhot() + ! Time indexes bounds for integration + zt0 = REAL(Agrif_NbStepint() , wp) / zrhot + zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot + IF( bdy_tinterp == 1 ) THEN + ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & + & - zt0**2._wp * ( zt0 - 1._wp) ) + ELSEIF( bdy_tinterp == 2 ) THEN + ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & + & - zt0 * ( zt0 - 1._wp)**2._wp ) + ELSE + ztcoeff = 1 + ENDIF + !! clem ghost + IF(western_side) vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2) + IF(eastern_side) vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2) + IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) + IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) + ! + IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN + IF(western_side) vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) + IF(eastern_side) vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) + IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) + IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) + ENDIF + ENDIF + ! + END SUBROUTINE interpvnb + + + SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpub2b *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji,jj + REAL(wp) :: zrhot, zt0, zt1,zat + LOGICAL :: western_side, eastern_side,northern_side,southern_side + !!---------------------------------------------------------------------- + IF( before ) THEN + IF ( ln_bt_fw ) THEN + ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) + ELSE + ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) + ENDIF + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + zrhot = Agrif_rhot() + ! Time indexes bounds for integration + zt0 = REAL(Agrif_NbStepint() , wp) / zrhot + zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot + ! Polynomial interpolation coefficients: + zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & + & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) + !! clem ghost + IF(western_side ) ubdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2) + IF(eastern_side ) ubdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2) + IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) + IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) + ENDIF + ! + END SUBROUTINE interpub2b + + + SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpvb2b *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji,jj + REAL(wp) :: zrhot, zt0, zt1,zat + LOGICAL :: western_side, eastern_side,northern_side,southern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + IF ( ln_bt_fw ) THEN + ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) + ELSE + ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) + ENDIF + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + zrhot = Agrif_rhot() + ! Time indexes bounds for integration + zt0 = REAL(Agrif_NbStepint() , wp) / zrhot + zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot + ! Polynomial interpolation coefficients: + zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & + & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) + ! + IF(western_side ) vbdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2) + IF(eastern_side ) vbdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2) + IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) + IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) + ENDIF + ! + END SUBROUTINE interpvb2b + + + SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpe3t *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj, jk + LOGICAL :: western_side, eastern_side, northern_side, southern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2) + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + ! + DO jk = k1, k2 + DO jj = j1, j2 + DO ji = i1, i2 + ! + IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN + IF (western_side.AND.(ptab(i1+nbghostcells-1,jj,jk)>0._wp)) THEN + WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ELSEIF (eastern_side.AND.(ptab(i2-nbghostcells+1,jj,jk)>0._wp)) THEN + WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ELSEIF (southern_side.AND.(ptab(ji,j1+nbghostcells-1,jk)>0._wp)) THEN + WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ELSEIF (northern_side.AND.(ptab(ji,j2-nbghostcells+1,jk)>0._wp)) THEN + WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ENDIF + ENDIF + END DO + END DO + END DO + ! + ENDIF + ! + END SUBROUTINE interpe3t + + + SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpumsk *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj, jk + LOGICAL :: western_side, eastern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2) + ELSE + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + DO jk = k1, k2 + DO jj = j1, j2 + DO ji = i1, i2 + ! Velocity mask at boundary edge points: + IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN + IF (western_side) THEN + WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ELSEIF (eastern_side) THEN + WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ENDIF + ENDIF + END DO + END DO + END DO + ! + ENDIF + ! + END SUBROUTINE interpumsk + + + SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interpvmsk *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj, jk + LOGICAL :: northern_side, southern_side + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2) + ELSE + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + DO jk = k1, k2 + DO jj = j1, j2 + DO ji = i1, i2 + ! Velocity mask at boundary edge points: + IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN + IF (southern_side) THEN + WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ELSEIF (northern_side) THEN + WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk + WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) + kindic_agr = kindic_agr + 1 + ENDIF + ENDIF + END DO + END DO + END DO + ! + ENDIF + ! + END SUBROUTINE interpvmsk + + + SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interavm *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + REAL(wp), DIMENSION(k1:k2) :: tabin, h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out, ji, jj, jk + !!---------------------------------------------------------------------- + ! + IF (before) THEN + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,1) = avm_k(ji,jj,jk) + END DO + END DO + END DO +#ifdef key_vertical + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,2) = wmask(ji,jj,jk) * e3w_n(ji,jj,jk) + END DO + END DO + END DO +#endif + ELSE +#ifdef key_vertical + avm_k(i1:i2,j1:j2,1:jpk) = 0. + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 !k2 = jpk of parent grid + IF (ptab(ji,jj,jk,2) == 0) EXIT + N_in = N_in + 1 + tabin(jk) = ptab(ji,jj,jk,1) + h_in(N_in) = ptab(ji,jj,jk,2) + END DO + N_out = 0 + DO jk=1,jpk ! jpk of child grid + IF (wmask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(jk) = e3t_n(ji,jj,jk) + ENDDO + IF (N_in > 0) THEN + CALL reconstructandremap(tabin(1:N_in),h_in,avm_k(ji,jj,1:N_out),h_out,N_in,N_out) + ENDIF + ENDDO + ENDDO +#else + avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) +#endif + ENDIF + ! + END SUBROUTINE interpavm + +#else + !!---------------------------------------------------------------------- + !! Empty module no AGRIF zoom + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE Agrif_OCE_Interp_empty + WRITE(*,*) 'agrif_oce_interp : You should not have seen this print! error?' + END SUBROUTINE Agrif_OCE_Interp_empty +#endif + + !!====================================================================== +END MODULE agrif_oce_interp diff --git a/V4.0/nemo_sources/src/NST/agrif_oce_sponge.F90 b/V4.0/nemo_sources/src/NST/agrif_oce_sponge.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8c4a3cebcfc8dcdc05e2f36ae048b8ef4a5ef8eb --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_oce_sponge.F90 @@ -0,0 +1,625 @@ +#define SPONGE && define SPONGE_TOP + +MODULE agrif_oce_sponge + !!====================================================================== + !! *** MODULE agrif_oce_interp *** + !! AGRIF: sponge package for the ocean dynamics (OPA) + !!====================================================================== + !! History : 2.0 ! 2002-06 (XXX) Original cade + !! - ! 2005-11 (XXX) + !! 3.2 ! 2009-04 (R. Benshila) + !! 3.6 ! 2014-09 (R. Benshila) + !!---------------------------------------------------------------------- +#if defined key_agrif + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !!---------------------------------------------------------------------- + USE par_oce + USE oce + USE dom_oce + ! + USE in_out_manager + USE agrif_oce + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn + PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_oce_sponge.F90 12737 2020-04-10 17:55:11Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_Sponge_Tra + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Sponge_Tra *** + !!---------------------------------------------------------------------- + REAL(wp) :: zcoef ! local scalar + + !!---------------------------------------------------------------------- + ! +#if defined SPONGE + !! Assume persistence: + zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) + + CALL Agrif_Sponge + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + tabspongedone_tsn = .FALSE. + ! + CALL Agrif_Bc_Variable( tsn_sponge_id, calledweight=zcoef, procname=interptsn_sponge ) + ! + Agrif_UseSpecialValue = .FALSE. +#endif + ! + END SUBROUTINE Agrif_Sponge_Tra + + + SUBROUTINE Agrif_Sponge_dyn + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Sponge_dyn *** + !!---------------------------------------------------------------------- + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! +#if defined SPONGE + zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) + + Agrif_SpecialValue=0. + Agrif_UseSpecialValue = ln_spc_dyn + ! + tabspongedone_u = .FALSE. + tabspongedone_v = .FALSE. + CALL Agrif_Bc_Variable( un_sponge_id, calledweight=zcoef, procname=interpun_sponge ) + ! + tabspongedone_u = .FALSE. + tabspongedone_v = .FALSE. + CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge ) + ! + Agrif_UseSpecialValue = .FALSE. +#endif + ! + END SUBROUTINE Agrif_Sponge_dyn + + + SUBROUTINE Agrif_Sponge + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Sponge *** + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, ind1, ind2 + INTEGER :: ispongearea + REAL(wp) :: z1_spongearea + REAL(wp), DIMENSION(jpi,jpj) :: ztabramp + !!---------------------------------------------------------------------- + ! +#if defined SPONGE || defined SPONGE_TOP + IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN + ! Define ramp from boundaries towards domain interior at T-points + ! Store it in ztabramp + + ispongearea = 1 + nn_sponge_len * Agrif_irhox() + z1_spongearea = 1._wp / REAL( ispongearea ) + + ztabramp(:,:) = 0._wp + + ! --- West --- ! + IF( l_Westedge ) THEN + ind1 = 1+nbghostcells + ind2 = 1+nbghostcells + ispongearea + DO jj = 1, jpj + DO ji = ind1, ind2 + ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) + END DO + ENDDO + ENDIF + + ! --- East --- ! + IF( l_Eastedge ) THEN + ind1 = nlci - nbghostcells - ispongearea + ind2 = nlci - nbghostcells + DO jj = 1, jpj + DO ji = ind1, ind2 + ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind1 ) * z1_spongearea * umask(ind2-1,jj,1) ) + ENDDO + ENDDO + ENDIF + + ! --- South --- ! + IF( l_Southedge ) THEN + ind1 = 1+nbghostcells + ind2 = 1+nbghostcells + ispongearea + DO jj = ind1, ind2 + DO ji = 1, jpi + ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) + END DO + ENDDO + ENDIF + + ! --- North --- ! + IF( l_Northedge ) THEN + ind1 = nlcj - nbghostcells - ispongearea + ind2 = nlcj - nbghostcells + DO jj = ind1, ind2 + DO ji = 1, jpi + ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) ) + END DO + ENDDO + ENDIF + + ENDIF + + ! Tracers + IF( .NOT. spongedoneT ) THEN + fsaht_spu(:,:) = 0._wp + fsaht_spv(:,:) = 0._wp + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) + fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) + END DO + END DO + CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spu, 'U', 1. ) ! Lateral boundary conditions + CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spv, 'V', 1. ) + + spongedoneT = .TRUE. + ENDIF + + ! Dynamics + IF( .NOT. spongedoneU ) THEN + fsahm_spt(:,:) = 0._wp + fsahm_spf(:,:) = 0._wp + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) + fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji ,jj ) + ztabramp(ji ,jj+1) & + & +ztabramp(ji+1,jj+1) + ztabramp(ji+1,jj ) ) + END DO + END DO + CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spt, 'T', 1. ) ! Lateral boundary conditions + CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spf, 'F', 1. ) + + spongedoneU = .TRUE. + ENDIF + ! +#endif + ! + END SUBROUTINE Agrif_Sponge + + SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interptsn_sponge *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: iku, ikv + REAL(wp) :: ztsa, zabe1, zabe2, zbtr + REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv + REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child + REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin + REAL(wp), DIMENSION(k1:k2) :: h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out + REAL(wp) :: h_diff + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + DO jn = 1, jpts + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) + END DO + END DO + END DO + END DO + +# if defined key_vertical + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) + END DO + END DO + END DO +# endif + + ELSE + ! +# if defined key_vertical + tabres_child(:,:,:,:) = 0. + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 !k2 = jpk of parent grid + IF (tabres(ji,jj,jk,n2) == 0) EXIT + N_in = N_in + 1 + tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) + h_in(N_in) = tabres(ji,jj,jk,n2) + END DO + N_out = 0 + DO jk=1,jpk ! jpk of child grid + IF (tmask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above + ENDDO + IF (N_in > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for????? + DO jn=1,jpts + call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO +# endif + + DO jj=j1,j2 + DO ji=i1,i2 + DO jk=1,jpkm1 +# if defined key_vertical + tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts) +# else + tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts) +# endif + ENDDO + ENDDO + ENDDO + + DO jn = 1, jpts + DO jk = 1, jpkm1 + ztu(i1:i2,j1:j2,jk) = 0._wp + DO jj = j1,j2 + DO ji = i1,i2-1 + zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) + ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) + END DO + END DO + ztv(i1:i2,j1:j2,jk) = 0._wp + DO ji = i1,i2 + DO jj = j1,j2-1 + zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) + ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) + END DO + END DO + ! + IF( ln_zps ) THEN ! set gradient at partial step level + DO jj = j1,j2 + DO ji = i1,i2 + ! last level + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + IF( iku == jk ) ztu(ji,jj,jk) = 0._wp + IF( ikv == jk ) ztv(ji,jj,jk) = 0._wp + END DO + END DO + ENDIF + END DO + ! + DO jk = 1, jpkm1 + DO jj = j1+1,j2-1 + DO ji = i1+1,i2-1 + IF (.NOT. tabspongedone_tsn(ji,jj)) THEN + zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + ! horizontal diffusive trends + ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) + ! add it to the general tracer trends + tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa + ENDIF + END DO + END DO + END DO + ! + END DO + ! + tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. + ! + ENDIF + ! + END SUBROUTINE interptsn_sponge + + SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) + !!--------------------------------------------- + !! *** ROUTINE interpun_sponge *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + + INTEGER :: ji,jj,jk,jmax + + ! sponge parameters + REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child + REAL(wp), DIMENSION(k1:k2) :: tabin, h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER ::N_in,N_out + !!--------------------------------------------- + ! + IF( before ) THEN + DO jk=1,jpkm1 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,m1) = ub(ji,jj,jk) +# if defined key_vertical + tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk) +# endif + END DO + END DO + END DO + + ELSE + +# if defined key_vertical + tabres_child(:,:,:) = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 + IF (tabres(ji,jj,jk,m2) == 0) EXIT + N_in = N_in + 1 + tabin(jk) = tabres(ji,jj,jk,m1) + h_in(N_in) = tabres(ji,jj,jk,m2) + ENDDO + ! + IF (N_in == 0) THEN + tabres_child(ji,jj,:) = 0. + CYCLE + ENDIF + + N_out = 0 + DO jk=1,jpk + if (umask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3u_n(ji,jj,jk) + ENDDO + + IF (N_out == 0) THEN + tabres_child(ji,jj,:) = 0. + CYCLE + ENDIF + + IF (N_in * N_out > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + if (h_diff < -1.e4) then + print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) + endif + ENDIF + call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + + ENDDO + ENDDO + + ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) +#else + ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) +#endif + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + ! ! -------- + ! Horizontal divergence ! div + ! ! -------- + DO jj = j1,j2 + DO ji = i1+1,i2 ! vector opt. + zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj) + hdivdiff(ji,jj,jk) = ( e2u(ji ,jj)*e3u_n(ji ,jj,jk) * ubdiff(ji ,jj,jk) & + & -e2u(ji-1,jj)*e3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr + END DO + END DO + + DO jj = j1,j2-1 + DO ji = i1,i2 ! vector opt. + zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj) + rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & + & +e1u(ji,jj ) * ubdiff(ji,jj ,jk) ) * fmask(ji,jj,jk) * zbtr + END DO + END DO + END DO + ! + DO jj = j1+1, j2-1 + DO ji = i1+1, i2-1 ! vector opt. + + IF (.NOT. tabspongedone_u(ji,jj)) THEN + DO jk = 1, jpkm1 ! Horizontal slab + ze2u = rotdiff (ji,jj,jk) + ze1v = hdivdiff(ji,jj,jk) + ! horizontal diffusive trends + zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) ) & + + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) + + ! add it to the general momentum trends + ua(ji,jj,jk) = ua(ji,jj,jk) + zua + + END DO + ENDIF + + END DO + END DO + + tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. + + jmax = j2-1 + IF ( l_Northedge ) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North + + DO jj = j1+1, jmax + DO ji = i1+1, i2 ! vector opt. + + IF (.NOT. tabspongedone_v(ji,jj)) THEN + DO jk = 1, jpkm1 ! Horizontal slab + ze2u = rotdiff (ji,jj,jk) + ze1v = hdivdiff(ji,jj,jk) + + ! horizontal diffusive trends + zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) ) & + + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj) + + ! add it to the general momentum trends + va(ji,jj,jk) = va(ji,jj,jk) + zva + END DO + ENDIF + ! + END DO + END DO + ! + tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. + ! + ENDIF + ! + END SUBROUTINE interpun_sponge + + SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir) + !!--------------------------------------------- + !! *** ROUTINE interpvn_sponge *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + INTEGER, INTENT(in) :: nb , ndir + ! + INTEGER :: ji, jj, jk, imax + REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child + REAL(wp), DIMENSION(k1:k2) :: tabin, h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out + !!--------------------------------------------- + + IF( before ) THEN + DO jk=1,jpkm1 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,m1) = vb(ji,jj,jk) +# if defined key_vertical + tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk) +# endif + END DO + END DO + END DO + ELSE + +# if defined key_vertical + tabres_child(:,:,:) = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 + IF (tabres(ji,jj,jk,m2) == 0) EXIT + N_in = N_in + 1 + tabin(jk) = tabres(ji,jj,jk,m1) + h_in(N_in) = tabres(ji,jj,jk,m2) + ENDDO + + IF (N_in == 0) THEN + tabres_child(ji,jj,:) = 0. + CYCLE + ENDIF + + N_out = 0 + DO jk=1,jpk + if (vmask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3v_n(ji,jj,jk) + ENDDO + + IF (N_in * N_out > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + if (h_diff < -1.e4) then + print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) + endif + ENDIF + call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + ENDDO + ENDDO + + vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) +# else + vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) +# endif + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + ! ! -------- + ! Horizontal divergence ! div + ! ! -------- + DO jj = j1+1,j2 + DO ji = i1,i2 ! vector opt. + zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj) + hdivdiff(ji,jj,jk) = ( e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vbdiff(ji,jj ,jk) & + & -e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vbdiff(ji,jj-1,jk) ) * zbtr + END DO + END DO + DO jj = j1,j2 + DO ji = i1,i2-1 ! vector opt. + zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj) + rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & + & -e2v(ji ,jj) * vbdiff(ji ,jj,jk) ) * fmask(ji,jj,jk) * zbtr + END DO + END DO + END DO + + ! ! =============== + ! + + imax = i2 - 1 + IF ( l_Eastedge ) imax = MIN(imax,nlci-nbghostcells-2) ! East + + DO jj = j1+1, j2 + DO ji = i1+1, imax ! vector opt. + IF( .NOT. tabspongedone_u(ji,jj) ) THEN + DO jk = 1, jpkm1 + ua(ji,jj,jk) = ua(ji,jj,jk) & + & - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) ) & + & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk)) * r1_e1u(ji,jj) + END DO + ENDIF + END DO + END DO + ! + tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. + ! + DO jj = j1+1, j2-1 + DO ji = i1+1, i2-1 ! vector opt. + IF( .NOT. tabspongedone_v(ji,jj) ) THEN + DO jk = 1, jpkm1 + va(ji,jj,jk) = va(ji,jj,jk) & + & + ( rotdiff (ji,jj ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) ) & + & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) + END DO + ENDIF + END DO + END DO + tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. + ENDIF + ! + END SUBROUTINE interpvn_sponge + +#else + !!---------------------------------------------------------------------- + !! Empty module no AGRIF zoom + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_oce_sponge_empty + WRITE(*,*) 'agrif_oce_sponge : You should not have seen this print! error?' + END SUBROUTINE agrif_oce_sponge_empty +#endif + + !!====================================================================== +END MODULE agrif_oce_sponge diff --git a/V4.0/nemo_sources/src/NST/agrif_oce_update.F90 b/V4.0/nemo_sources/src/NST/agrif_oce_update.F90 new file mode 100644 index 0000000000000000000000000000000000000000..afe01a5980f32c591b5582f4379396bb68551a31 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_oce_update.F90 @@ -0,0 +1,1424 @@ +#define TWO_WAY /* TWO WAY NESTING */ +#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ +#undef VOL_REFLUX /* VOLUME REFLUXING*/ + +MODULE agrif_oce_update + !!====================================================================== + !! *** MODULE agrif_oce_interp *** + !! AGRIF: update package for the ocean dynamics (OPA) + !!====================================================================== + !! History : 2.0 ! 2002-06 (L. Debreu) Original code + !! 3.2 ! 2009-04 (R. Benshila) + !! 3.6 ! 2014-09 (R. Benshila) + !!---------------------------------------------------------------------- +#if defined key_agrif + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !!---------------------------------------------------------------------- + USE par_oce + USE oce + USE dom_oce + USE zdf_oce ! vertical physics: ocean variables + USE agrif_oce + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE domvvl ! Need interpolation routines + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Agrif_Update_vvl, Agrif_Update_ssh + PUBLIC Update_Scales + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_oce_update.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_Update_Tra( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Update_Tra *** + !!---------------------------------------------------------------------- + ! + IF (Agrif_Root()) RETURN + ! +#if defined TWO_WAY + IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed() + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_SpecialValueFineGrid = 0._wp + ! +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(tsn_id, procname=updateTS) +! near boundary update: +! CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) +# else + CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) +! near boundary update: +! CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) +# endif + ! + Agrif_UseSpecialValueInUpdate = .FALSE. + ! +#endif + ! + END SUBROUTINE Agrif_Update_Tra + + SUBROUTINE Agrif_Update_Dyn( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Update_Dyn *** + !!---------------------------------------------------------------------- + ! + IF (Agrif_Root()) RETURN + ! +#if defined TWO_WAY + IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed() + + Agrif_UseSpecialValueInUpdate = .FALSE. + Agrif_SpecialValueFineGrid = 0. + ! +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(un_update_id,procname = updateU) + CALL Agrif_Update_Variable(vn_update_id,procname = updateV) +! near boundary update: +! CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) +! CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV) +# else + CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) + CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) +! near boundary update: +! CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) +! CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) +# endif + +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) + CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) +# else + CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) + CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) +# endif + ! +# if ! defined DECAL_FEEDBACK + ! Account for updated thicknesses at boundary edges + IF (.NOT.ln_linssh) THEN +! CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy) +! CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy) + ENDIF +# endif + ! + IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN + ! Update time integrated transports +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) + CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) +# else + CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) + CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) +# endif + END IF +#endif + ! + END SUBROUTINE Agrif_Update_Dyn + + SUBROUTINE Agrif_Update_ssh( ) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Update_ssh *** + !!--------------------------------------------- + ! + IF (Agrif_Root()) RETURN + ! +#if defined TWO_WAY + ! + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_SpecialValueFineGrid = 0. +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) +# else + CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) +# endif + ! + Agrif_UseSpecialValueInUpdate = .FALSE. + ! +# if defined VOL_REFLUX + IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN + ! Refluxing on ssh: +# if defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu) + CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv) +# else + CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/-1,-1/),locupdate2=(/ 0, 0/),procname = reflux_sshu) + CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/-1,-1/),procname = reflux_sshv) +# endif + END IF +# endif + ! +#endif + ! + END SUBROUTINE Agrif_Update_ssh + + + SUBROUTINE Agrif_Update_Tke( ) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Update_Tke *** + !!--------------------------------------------- + !! + ! + IF (Agrif_Root()) RETURN + ! +# if defined TWO_WAY + + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_SpecialValueFineGrid = 0. + + CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) + CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) + CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) + + Agrif_UseSpecialValueInUpdate = .FALSE. + +# endif + + END SUBROUTINE Agrif_Update_Tke + + + SUBROUTINE Agrif_Update_vvl( ) + !!--------------------------------------------- + !! *** ROUTINE Agrif_Update_vvl *** + !!--------------------------------------------- + ! + IF (Agrif_Root()) RETURN + ! +#if defined TWO_WAY + ! + IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() + ! + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_SpecialValueFineGrid = 0. + ! + ! No interface separation here, update vertical grid at T points + ! everywhere over the overlapping regions (one account for refluxing in that case): + CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) + ! + Agrif_UseSpecialValueInUpdate = .FALSE. + ! + CALL Agrif_ChildGrid_To_ParentGrid() + CALL dom_vvl_update_UVF + CALL Agrif_ParentGrid_To_ChildGrid() + ! +#endif + ! + END SUBROUTINE Agrif_Update_vvl + + SUBROUTINE dom_vvl_update_UVF + !!--------------------------------------------- + !! *** ROUTINE dom_vvl_update_UVF *** + !!--------------------------------------------- + !! + INTEGER :: jk + REAL(wp):: zcoef + !!--------------------------------------------- + + IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & + & Agrif_Fixed(), 'Step', Agrif_Nb_Step() + + ! Save "old" scale factor (prior update) for subsequent asselin correction + ! of prognostic variables + ! ----------------------- + ! + e3u_a(:,:,:) = e3u_n(:,:,:) + e3v_a(:,:,:) = e3v_n(:,:,:) +! ua(:,:,:) = e3u_b(:,:,:) +! va(:,:,:) = e3v_b(:,:,:) + hu_a(:,:) = hu_n(:,:) + hv_a(:,:) = hv_n(:,:) + + ! 1) NOW fields + !-------------- + + ! Vertical scale factor interpolations + ! ------------------------------------ + 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' ) + + CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) + + ! Update total depths: + ! -------------------- + hu_n(:,:) = 0._wp ! Ocean depth at U-points + hv_n(:,:) = 0._wp ! Ocean depth at V-points + DO jk = 1, jpkm1 + hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk) + hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk) + END DO + ! ! Inverse of the local depth + r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) + + + ! 2) BEFORE fields: + !------------------ + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN + ! + ! Vertical 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( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) + + ! Update total depths: + ! -------------------- + hu_b(:,:) = 0._wp ! Ocean depth at U-points + hv_b(:,:) = 0._wp ! Ocean depth at V-points + DO jk = 1, jpkm1 + hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk) + hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk) + END DO + ! ! Inverse of the local depth + r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) + ENDIF + ! + END SUBROUTINE dom_vvl_update_UVF + +#if defined key_vertical + + SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateT *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + !! + INTEGER :: ji,jj,jk,jn + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child + REAL(wp) :: h_in(k1:k2) + REAL(wp) :: h_out(1:jpk) + INTEGER :: N_in, N_out + REAL(wp) :: zrho_xy, h_diff + REAL(wp) :: tabin(k1:k2,n1:n2) + !!--------------------------------------------- + ! + IF (before) THEN + AGRIF_SpecialValue = -999._wp + zrho_xy = Agrif_rhox() * Agrif_rhoy() + DO jn = n1,n2-1 + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & + * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + END DO + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & + + (tmask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + ELSE + tabres_child(:,:,:,:) = 0. + AGRIF_SpecialValue = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 !k2 = jpk of child grid + IF (tabres(ji,jj,jk,n2) == 0 ) EXIT + N_in = N_in + 1 + tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) + h_in(N_in) = tabres(ji,jj,jk,n2) + ENDDO + N_out = 0 + DO jk=1,jpk ! jpk of parent grid + IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF + N_out = N_out + 1 + h_out(N_out) = e3t_n(ji,jj,jk) + ENDDO + IF (N_in > 0) THEN !Remove this? + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + IF (h_diff < -1.e-4) THEN + print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) + print *,h_in(1:N_in) + print *,h_out(1:N_out) + STOP + ENDIF + DO jn=n1,n2-1 + CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO + + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN + ! Add asselin part + DO jn = n1,n2-1 + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN + tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & + & + atfp * ( tabres_child(ji,jj,jk,jn) & + & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + DO jn = n1,n2-1 + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN + tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) + END IF + END DO + END DO + END DO + END DO + ENDIF + ! + END SUBROUTINE updateTS + +# else + + SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!--------------------------------------------- + !! *** ROUTINE updateT *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + !! + INTEGER :: ji,jj,jk,jn + REAL(wp) :: ztb, ztnu, ztno + !!--------------------------------------------- + ! + IF (before) THEN + DO jn = 1,jpts + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 +!> jc tmp + tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk) +! tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) +!< jc tmp + END DO + END DO + END DO + END DO + ELSE +!> jc tmp + DO jn = 1,jpts + tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & + & * tmask(i1:i2,j1:j2,k1:k2) + ENDDO +!< jc tmp + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN + ! Add asselin part + DO jn = 1,jpts + DO jk = k1, k2 + DO jj = j1, j2 + DO ji = i1, i2 + IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN + ztb = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used + ztnu = tabres(ji,jj,jk,jn) + ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) + tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) ) & + & * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) + ENDIF + END DO + END DO + END DO + END DO + ENDIF + DO jn = 1,jpts + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN + tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk) + END IF + END DO + END DO + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + tsb(i1:i2,j1:j2,k1:k2,1:jpts) = tsn(i1:i2,j1:j2,k1:k2,1:jpts) + ENDIF + ! + ENDIF + ! + END SUBROUTINE updateTS + +# endif + +# if defined key_vertical + + SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!--------------------------------------------- + !! *** ROUTINE updateu *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk + REAL(wp):: zrhoy +! VERTICAL REFINEMENT BEGIN + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child + REAL(wp) :: h_in(k1:k2) + REAL(wp) :: h_out(1:jpk) + INTEGER :: N_in, N_out + REAL(wp) :: h_diff, excess, thick + REAL(wp) :: tabin(k1:k2) +! VERTICAL REFINEMENT END + !!--------------------------------------------- + ! + IF( before ) THEN + zrhoy = Agrif_Rhoy() + AGRIF_SpecialValue = -999._wp + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk) & + + (umask(ji,jj,jk)-1)*999._wp + tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk) & + + (umask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + ELSE + tabres_child(:,:,:) = 0. + AGRIF_SpecialValue = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + h_in(:) = 0._wp + tabin(:) = 0._wp + DO jk=k1,k2 !k2=jpk of child grid + IF( tabres(ji,jj,jk,2) < -900) EXIT + N_in = N_in + 1 + tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) + h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj) + ENDDO + N_out = 0 + DO jk=1,jpk + IF (umask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3u_n(ji,jj,jk) + ENDDO + IF (N_in * N_out > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + IF (h_diff < -1.e-4) THEN +!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. +!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. + excess = 0._wp + DO jk=N_in,1,-1 + thick = MIN(-1*h_diff, h_in(jk)) + excess = excess + tabin(jk)*thick*e2u(ji,jj) + tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) + h_diff = h_diff + thick + IF ( h_diff == 0) THEN + N_in = jk + h_in(jk) = h_in(jk) - thick + EXIT + ENDIF + ENDDO + ENDIF + CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) + ENDIF + ENDDO + ENDDO + + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part + ub(ji,jj,jk) = ub(ji,jj,jk) & + & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) + ENDIF + ! + un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk) + END DO + END DO + END DO + ENDIF + ! + END SUBROUTINE updateu + +#else + + SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!--------------------------------------------- + !! *** ROUTINE updateu *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrhoy, zub, zunu, zuno + !!--------------------------------------------- + ! + IF( before ) THEN + zrhoy = Agrif_Rhoy() + DO jk = k1, k2 + tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) + END DO + ELSE + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) + ! + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part + zub = ub(ji,jj,jk) * e3u_b(ji,jj,jk) ! fse3t_b prior update should be used + zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk) + zunu = tabres(ji,jj,jk,1) + ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) & + & * umask(ji,jj,jk) / e3u_b(ji,jj,jk) + ENDIF + ! + un(ji,jj,jk) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + ub(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) + ENDIF + ! + ENDIF + ! + END SUBROUTINE updateu + +# endif + + SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) + !!--------------------------------------------- + !! *** ROUTINE correct_u_bdy *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in) :: nb, ndir + !! + LOGICAL :: western_side, eastern_side + ! + INTEGER :: jj, jk + REAL(wp) :: zcor + !!--------------------------------------------- + ! + IF( .NOT.before ) THEN + ! + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + ! + IF (western_side) THEN + DO jj=j1,j2 + zcor = un_b(i1-1,jj) * hu_a(i1-1,jj) * r1_hu_n(i1-1,jj) - un_b(i1-1,jj) + un_b(i1-1,jj) = un_b(i1-1,jj) + zcor + DO jk=1,jpkm1 + un(i1-1,jj,jk) = un(i1-1,jj,jk) + zcor * umask(i1-1,jj,jk) + END DO + END DO + ENDIF + ! + IF (eastern_side) THEN + DO jj=j1,j2 + zcor = un_b(i2+1,jj) * hu_a(i2+1,jj) * r1_hu_n(i2+1,jj) - un_b(i2+1,jj) + un_b(i2+1,jj) = un_b(i2+1,jj) + zcor + DO jk=1,jpkm1 + un(i2+1,jj,jk) = un(i2+1,jj,jk) + zcor * umask(i2+1,jj,jk) + END DO + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE correct_u_bdy + +# if defined key_vertical + + SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!--------------------------------------------- + !! *** ROUTINE updatev *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrhox +! VERTICAL REFINEMENT BEGIN + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child + REAL(wp) :: h_in(k1:k2) + REAL(wp) :: h_out(1:jpk) + INTEGER :: N_in, N_out + REAL(wp) :: h_diff, excess, thick + REAL(wp) :: tabin(k1:k2) +! VERTICAL REFINEMENT END + !!--------------------------------------------- + ! + IF( before ) THEN + zrhox = Agrif_Rhox() + AGRIF_SpecialValue = -999._wp + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) & + + (vmask(ji,jj,jk)-1)*999._wp + tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) & + + (vmask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + ELSE + tabres_child(:,:,:) = 0. + AGRIF_SpecialValue = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 + IF (tabres(ji,jj,jk,2) < -900) EXIT + N_in = N_in + 1 + tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) + h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj) + ENDDO + N_out = 0 + DO jk=1,jpk + IF (vmask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(N_out) = e3v_n(ji,jj,jk) + ENDDO + IF (N_in * N_out > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + IF (h_diff < -1.e-4) then +!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. +!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. + excess = 0._wp + DO jk=N_in,1,-1 + thick = MIN(-1*h_diff, h_in(jk)) + excess = excess + tabin(jk)*thick*e2u(ji,jj) + tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) + h_diff = h_diff + thick + IF ( h_diff == 0) THEN + N_in = jk + h_in(jk) = h_in(jk) - thick + EXIT + ENDIF + ENDDO + ENDIF + CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) + tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) + ENDIF + ENDDO + ENDDO + + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + ! + IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part + vb(ji,jj,jk) = vb(ji,jj,jk) & + & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) + ENDIF + ! + vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk) + END DO + END DO + END DO + ENDIF + ! + END SUBROUTINE updatev + +# else + + SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) + !!--------------------------------------------- + !! *** ROUTINE updatev *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrhox, zvb, zvnu, zvno + !!--------------------------------------------- + ! + IF (before) THEN + zrhox = Agrif_Rhox() + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) + END DO + END DO + END DO + ELSE + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj) + ! + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part + zvb = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used + zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk) + zvnu = tabres(ji,jj,jk,1) + vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) & + & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk) + ENDIF + ! + vn(ji,jj,jk) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + vb(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) + ENDIF + ! + ENDIF + ! + END SUBROUTINE updatev + +# endif + + SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) + !!--------------------------------------------- + !! *** ROUTINE correct_u_bdy *** + !!--------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in) :: nb, ndir + !! + LOGICAL :: southern_side, northern_side + ! + INTEGER :: ji, jk + REAL(wp) :: zcor + !!--------------------------------------------- + ! + IF( .NOT.before ) THEN + ! + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + ! + IF (southern_side) THEN + DO ji=i1,i2 + zcor = vn_b(ji,j1-1) * hv_a(ji,j1-1) * r1_hv_n(ji,j1-1) - vn_b(ji,j1-1) + vn_b(ji,j1-1) = vn_b(ji,j1-1) + zcor + DO jk=1,jpkm1 + vn(ji,j1-1,jk) = vn(ji,j1-1,jk) + zcor * vmask(ji,j1-1,jk) + END DO + END DO + ENDIF + ! + IF (northern_side) THEN + DO ji=i1,i2 + zcor = vn_b(ji,j2+1) * hv_a(ji,j2+1) * r1_hv_n(ji,j2+1) - vn_b(ji,j2+1) + vn_b(ji,j2+1) = vn_b(ji,j2+1) + zcor + DO jk=1,jpkm1 + vn(ji,j2+1,jk) = vn(ji,j2+1,jk) + zcor * vmask(ji,j2+1,jk) + END DO + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE correct_v_bdy + + + SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateu2d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji, jj, jk + REAL(wp) :: zrhoy + REAL(wp) :: zcorr + !!--------------------------------------------- + ! + IF( before ) THEN + zrhoy = Agrif_Rhoy() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj) + END DO + END DO + ELSE + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = tabres(ji,jj) * r1_e2u(ji,jj) + ! + ! Update "now" 3d velocities: + spgu(ji,jj) = 0._wp + DO jk=1,jpkm1 + spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) + END DO + ! + zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu_n(ji,jj) + DO jk=1,jpkm1 + un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk) + END DO + ! + ! Update barotropic velocities: + IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part + zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj) + ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) + END IF + ENDIF + un_b(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * umask(ji,jj,1) + ! + ! Correct "before" velocities to hold correct bt component: + spgu(ji,jj) = 0.e0 + DO jk=1,jpkm1 + spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) + END DO + ! + zcorr = ub_b(ji,jj) - spgu(ji,jj) * r1_hu_b(ji,jj) + DO jk=1,jpkm1 + ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk) + END DO + ! + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + ub_b(i1:i2,j1:j2) = un_b(i1:i2,j1:j2) + ENDIF + ENDIF + ! + END SUBROUTINE updateu2d + + + SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updatev2d *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrhox, zcorr + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + zrhox = Agrif_Rhox() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj) + END DO + END DO + ELSE + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = tabres(ji,jj) * r1_e1v(ji,jj) + ! + ! Update "now" 3d velocities: + spgv(ji,jj) = 0.e0 + DO jk=1,jpkm1 + spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) + END DO + ! + zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv_n(ji,jj) + DO jk=1,jpkm1 + vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk) + END DO + ! + ! Update barotropic velocities: + IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part + zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj) + vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) + END IF + ENDIF + vn_b(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * vmask(ji,jj,1) + ! + ! Correct "before" velocities to hold correct bt component: + spgv(ji,jj) = 0.e0 + DO jk=1,jpkm1 + spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) + END DO + ! + zcorr = vb_b(ji,jj) - spgv(ji,jj) * r1_hv_b(ji,jj) + DO jk=1,jpkm1 + vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk) + END DO + ! + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + vb_b(i1:i2,j1:j2) = vn_b(i1:i2,j1:j2) + ENDIF + ! + ENDIF + ! + END SUBROUTINE updatev2d + + + SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateSSH *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = sshn(ji,jj) + END DO + END DO + ELSE + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN + DO jj=j1,j2 + DO ji=i1,i2 + sshb(ji,jj) = sshb(ji,jj) & + & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + ENDIF + ! + DO jj=j1,j2 + DO ji=i1,i2 + sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + sshb(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) + ENDIF + ! + + ENDIF + ! + END SUBROUTINE updateSSH + + + SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateub2b *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL , INTENT(in) :: before + !! + INTEGER :: ji, jj + REAL(wp) :: zrhoy, za1, zcor + !!--------------------------------------------- + ! + IF (before) THEN + zrhoy = Agrif_Rhoy() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) + END DO + END DO + tabres = zrhoy * tabres + ELSE + ! + tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2) + ! + za1 = 1._wp / REAL(Agrif_rhot(), wp) + DO jj=j1,j2 + DO ji=i1,i2 + zcor=tabres(ji,jj) - ub2_b(ji,jj) + ! Update time integrated fluxes also in case of multiply nested grids: + ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor + ! Update corrective fluxes: + un_bf(ji,jj) = un_bf(ji,jj) + zcor + ! Update half step back fluxes: + ub2_b(ji,jj) = tabres(ji,jj) + END DO + END DO + ENDIF + ! + END SUBROUTINE updateub2b + + SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir ) + !!--------------------------------------------- + !! *** ROUTINE reflux_sshu *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + INTEGER, INTENT(in) :: nb, ndir + !! + LOGICAL :: western_side, eastern_side + INTEGER :: ji, jj + REAL(wp) :: zrhoy, za1, zcor + !!--------------------------------------------- + ! + IF (before) THEN + zrhoy = Agrif_Rhoy() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) + END DO + END DO + tabres = zrhoy * tabres + ELSE + ! + tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2) + ! + western_side = (nb == 1).AND.(ndir == 1) + eastern_side = (nb == 1).AND.(ndir == 2) + ! + IF (western_side) THEN + DO jj=j1,j2 + zcor = rdt * r1_e1e2t(i1 ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) + sshn(i1 ,jj) = sshn(i1 ,jj) + zcor + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1 ,jj) = sshb(i1 ,jj) + atfp * zcor + END DO + ENDIF + IF (eastern_side) THEN + DO jj=j1,j2 + zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj)) + sshn(i2+1,jj) = sshn(i2+1,jj) + zcor + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE reflux_sshu + + SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updatevb2b *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji, jj + REAL(wp) :: zrhox, za1, zcor + !!--------------------------------------------- + ! + IF( before ) THEN + zrhox = Agrif_Rhox() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) + END DO + END DO + tabres = zrhox * tabres + ELSE + ! + tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2) + ! + za1 = 1._wp / REAL(Agrif_rhot(), wp) + DO jj=j1,j2 + DO ji=i1,i2 + zcor=tabres(ji,jj) - vb2_b(ji,jj) + ! Update time integrated fluxes also in case of multiply nested grids: + vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor + ! Update corrective fluxes: + vn_bf(ji,jj) = vn_bf(ji,jj) + zcor + ! Update half step back fluxes: + vb2_b(ji,jj) = tabres(ji,jj) + END DO + END DO + ENDIF + ! + END SUBROUTINE updatevb2b + + SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir ) + !!--------------------------------------------- + !! *** ROUTINE reflux_sshv *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1, i2, j1, j2 + REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + INTEGER, INTENT(in) :: nb, ndir + !! + LOGICAL :: southern_side, northern_side + INTEGER :: ji, jj + REAL(wp) :: zrhox, za1, zcor + !!--------------------------------------------- + ! + IF (before) THEN + zrhox = Agrif_Rhox() + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) + END DO + END DO + tabres = zrhox * tabres + ELSE + ! + tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2) + ! + southern_side = (nb == 2).AND.(ndir == 1) + northern_side = (nb == 2).AND.(ndir == 2) + ! + IF (southern_side) THEN + DO ji=i1,i2 + zcor = rdt * r1_e1e2t(ji,j1 ) * e1v(ji,j1 ) * (vb2_b(ji,j1)-tabres(ji,j1)) + sshn(ji,j1 ) = sshn(ji,j1 ) + zcor + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1 ) = sshb(ji,j1) + atfp * zcor + END DO + ENDIF + IF (northern_side) THEN + DO ji=i1,i2 + zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2 ) * (vb2_b(ji,j2)-tabres(ji,j2)) + sshn(ji,j2+1) = sshn(ji,j2+1) + zcor + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE reflux_sshv + + SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) + ! + ! ====>>>>>>>>>> currently not used + ! + !!---------------------------------------------------------------------- + !! *** ROUTINE updateT *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji,jj,jk + REAL(wp) :: ztemp + !!---------------------------------------------------------------------- + + IF (before) THEN + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) + tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) + tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) + END DO + END DO + END DO + tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() + tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() + tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() + ELSE + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN + print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) + print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) + print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) + ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) + print *,'CORR = ',ztemp-1. + print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & + tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp + e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp + e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp + END IF + END DO + END DO + END DO + ENDIF + ! + END SUBROUTINE update_scales + + + SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateen *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) + ELSE + en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) + ENDIF + ! + END SUBROUTINE updateEN + + + SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateavt *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !!---------------------------------------------------------------------- + ! + IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) + ELSE ; avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) + ENDIF + ! + END SUBROUTINE updateAVT + + + SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) + !!--------------------------------------------- + !! *** ROUTINE updateavm *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab + LOGICAL , INTENT(in ) :: before + !!---------------------------------------------------------------------- + ! + IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) + ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) + ENDIF + ! + END SUBROUTINE updateAVM + + SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) + !!--------------------------------------------- + !! *** ROUTINE updatee3t *** + !!--------------------------------------------- + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum + INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 + LOGICAL, INTENT(in) :: before + ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptab + INTEGER :: ji,jj,jk + REAL(wp) :: zcoef + !!--------------------------------------------- + ! + IF (.NOT.before) THEN + ! + ALLOCATE(ptab(i1:i2,j1:j2,1:jpk)) + ! + ! Update e3t from ssh (z* case only) + DO jk = 1, jpkm1 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + sshn(ji,jj) & + & *ssmask(ji,jj)/(ht_0(ji,jj)-1._wp + ssmask(ji,jj))) + END DO + END DO + END DO + ! + ! 1) Updates at BEFORE time step: + ! ------------------------------- + ! + ! Save "old" scale factor (prior update) for subsequent asselin correction + ! of prognostic variables + e3t_a(i1:i2,j1:j2,1:jpkm1) = e3t_n(i1:i2,j1:j2,1:jpkm1) + + ! One should also save e3t_b, but lacking of workspace... +! hdivn(i1:i2,j1:j2,1:jpkm1) = e3t_b(i1:i2,j1:j2,1:jpkm1) + + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN + DO jk = 1, jpkm1 + DO jj=j1,j2 + DO ji=i1,i2 + e3t_b(ji,jj,jk) = e3t_b(ji,jj,jk) & + & + atfp * ( ptab(ji,jj,jk) - e3t_n(ji,jj,jk) ) + END DO + END DO + END DO + ! + e3w_b (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_b(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1) + gdepw_b(i1:i2,j1:j2,1) = 0.0_wp + gdept_b(i1:i2,j1:j2,1) = 0.5_wp * e3w_b(i1:i2,j1:j2,1) + ! + DO jk = 2, jpk + DO jj = j1,j2 + DO ji = i1,i2 + zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) + e3w_b(ji,jj,jk) = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * & + & ( e3t_b(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) ) & + & + 0.5_wp * tmask(ji,jj,jk) * & + & ( e3t_b(ji,jj,jk ) - e3t_0(ji,jj,jk ) ) + 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 + ! + ENDIF + ! + ! 2) Updates at NOW time step: + ! ---------------------------- + ! + ! Update vertical scale factor at T-points: + e3t_n(i1:i2,j1:j2,1:jpkm1) = ptab(i1:i2,j1:j2,1:jpkm1) + ! + ! Update total depth: + ht_n(i1:i2,j1:j2) = 0._wp + DO jk = 1, jpkm1 + ht_n(i1:i2,j1:j2) = ht_n(i1:i2,j1:j2) + e3t_n(i1:i2,j1:j2,jk) * tmask(i1:i2,j1:j2,jk) + END DO + ! + ! Update vertical scale factor at W-points and depths: + e3w_n (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_n(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1) + gdept_n(i1:i2,j1:j2,1) = 0.5_wp * e3w_n(i1:i2,j1:j2,1) + gdepw_n(i1:i2,j1:j2,1) = 0.0_wp + gde3w_n(i1:i2,j1:j2,1) = gdept_n(i1:i2,j1:j2,1) - (ht_n(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh + ! + DO jk = 2, jpk + DO jj = j1,j2 + DO ji = i1,i2 + zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) + e3w_n(ji,jj,jk) = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t_n(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) ) & + & + 0.5_wp * tmask(ji,jj,jk) * ( e3t_n(ji,jj,jk ) - e3t_0(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) - (ht_n(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh + END DO + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + e3t_b (i1:i2,j1:j2,1:jpk) = e3t_n (i1:i2,j1:j2,1:jpk) + e3w_b (i1:i2,j1:j2,1:jpk) = e3w_n (i1:i2,j1:j2,1:jpk) + gdepw_b(i1:i2,j1:j2,1:jpk) = gdepw_n(i1:i2,j1:j2,1:jpk) + gdept_b(i1:i2,j1:j2,1:jpk) = gdept_n(i1:i2,j1:j2,1:jpk) + ENDIF + ! + DEALLOCATE(ptab) + ENDIF + ! + END SUBROUTINE updatee3t + +#else + !!---------------------------------------------------------------------- + !! Empty module no AGRIF zoom + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_oce_update_empty + WRITE(*,*) 'agrif_oce_update : You should not have seen this print! error?' + END SUBROUTINE agrif_oce_update_empty +#endif + + !!====================================================================== +END MODULE agrif_oce_update + diff --git a/V4.0/nemo_sources/src/NST/agrif_top_interp.F90 b/V4.0/nemo_sources/src/NST/agrif_top_interp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b2e40b08166c002806c8124f754f693ff00068e2 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_top_interp.F90 @@ -0,0 +1,279 @@ +MODULE agrif_top_interp + !!====================================================================== + !! *** MODULE agrif_top_interp *** + !! AGRIF: interpolation package for TOP + !!====================================================================== + !! History : 2.0 ! ??? + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_top + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !! 'key_top' on-line tracers + !!---------------------------------------------------------------------- + USE par_oce + USE oce + USE dom_oce + USE agrif_oce + USE agrif_top_sponge + USE par_trc + USE trc + ! + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_trc, interptrn + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_top_interp.F90 12737 2020-04-10 17:55:11Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_trc + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_trc *** + !!---------------------------------------------------------------------- + ! + IF( Agrif_Root() ) RETURN + ! + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + ! + CALL Agrif_Bc_variable( trn_id, procname=interptrn ) + Agrif_UseSpecialValue = .FALSE. + ! + END SUBROUTINE Agrif_trc + + SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interptrn *** + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + LOGICAL , INTENT(in ) :: before + INTEGER , INTENT(in ) :: nb , ndir + ! + INTEGER :: ji, jj, jk, jn, iref, jref, ibdy, jbdy ! dummy loop indices + INTEGER :: imin, imax, jmin, jmax, N_in, N_out + REAL(wp) :: zrho, z1, z2, z3, z4, z5, z6, z7 + LOGICAL :: western_side, eastern_side,northern_side,southern_side + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child + REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin + REAL(wp), DIMENSION(k1:k2) :: h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + REAL(wp) :: h_diff + + IF( before ) THEN + DO jn = 1,jptra + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) + END DO + END DO + END DO + END DO + +# if defined key_vertical + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) + END DO + END DO + END DO +# endif + ELSE + + western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) + southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) + +# if defined key_vertical + DO jj=j1,j2 + DO ji=i1,i2 + iref = ji + jref = jj + if(western_side) iref=MAX(2,ji) + if(eastern_side) iref=MIN(nlci-1,ji) + if(southern_side) jref=MAX(2,jj) + if(northern_side) jref=MIN(nlcj-1,jj) + N_in = 0 + DO jk=k1,k2 !k2 = jpk of parent grid + IF (ptab(ji,jj,jk,n2) == 0) EXIT + N_in = N_in + 1 + tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) + h_in(N_in) = ptab(ji,jj,jk,n2) + END DO + N_out = 0 + DO jk=1,jpk ! jpk of child grid + IF (tmask(iref,jref,jk) == 0) EXIT + N_out = N_out + 1 + h_out(jk) = e3t_n(iref,jref,jk) + ENDDO + IF (N_in > 0) THEN + DO jn=1,jptra + call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO +# else + ptab_child(i1:i2,j1:j2,1:jpk,1:jptra) = ptab(i1:i2,j1:j2,1:jpk,1:jptra) +# endif + ! + DO jn=1, jptra + tra(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) + END DO + + IF ( .NOT.lk_agrif_clp ) THEN + ! + imin = i1 ; imax = i2 + jmin = j1 ; jmax = j2 + ! + ! Remove CORNERS + IF( l_Southedge ) jmin = 2 + nbghostcells + IF( l_Northedge ) jmax = nlcj - nbghostcells - 1 + IF( l_Westedge ) imin = 2 + nbghostcells + IF( l_Eastedge ) imax = nlci - nbghostcells - 1 + ! + IF( eastern_side ) THEN + zrho = Agrif_Rhox() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + ibdy = nlci-nbghostcells + DO jn = 1, jptra + tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO jj = jmin,jmax + IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN + tra(ibdy,jj,jk,jn) = tra(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk) + ELSE + tra(ibdy,jj,jk,jn)=(z4*tra(ibdy+1,jj,jk,jn)+z3*tra(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk) + IF( un(ibdy-1,jj,jk) > 0._wp ) THEN + tra(ibdy,jj,jk,jn)=( z6*tra(ibdy-1,jj,jk,jn)+z5*tra(ibdy+1,jj,jk,jn) & + + z7*tra(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy+1,jmin:jmax,1:jpkm1) + END DO + ENDIF + ! + IF( northern_side ) THEN + zrho = Agrif_Rhoy() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + jbdy = nlcj-nbghostcells + DO jn = 1, jptra + tra(imin:imax,jbdy+1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO ji = imin,imax + IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN + tra(ji,jbdy,jk,jn) = tra(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk) + ELSE + tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy+1,jk,jn)+z3*tra(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk) + IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN + tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy-1,jk,jn)+z5*tra(ji,jbdy+1,jk,jn) & + + z7*tra(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tra(imin:imax,jbdy+1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) * tmask(imin:imax,jbdy+1,1:jpkm1) + END DO + ENDIF + ! + IF( western_side ) THEN + zrho = Agrif_Rhox() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + ibdy = 1+nbghostcells + DO jn = 1, jptra + tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO jj = jmin,jmax + IF( umask(ibdy,jj,jk) == 0._wp ) THEN + tra(ibdy,jj,jk,jn) = tra(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk) + ELSE + tra(ibdy,jj,jk,jn)=(z4*tra(ibdy-1,jj,jk,jn)+z3*tra(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk) + IF( un(ibdy,jj,jk) < 0._wp ) THEN + tra(ibdy,jj,jk,jn)=( z6*tra(ibdy+1,jj,jk,jn)+z5*tra(ibdy-1,jj,jk,jn) & + + z7*tra(ibdy+2,jj,jk,jn) ) * tmask(ibdy,jj,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy-1,jmin:jmax,1:jpkm1) + END DO + ENDIF + ! + IF( southern_side ) THEN + zrho = Agrif_Rhoy() + z1 = ( zrho - 1._wp ) * 0.5_wp + z3 = ( zrho - 1._wp ) / ( zrho + 1._wp ) + z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) + z7 = - ( zrho - 1._wp ) / ( zrho + 3._wp ) + z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 + ! + jbdy=1+nbghostcells + DO jn = 1, jptra + tra(imin:imax,jbdy-1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) + DO jk = 1, jpkm1 + DO ji = imin,imax + IF( vmask(ji,jbdy,jk) == 0._wp ) THEN + tra(ji,jbdy,jk,jn)=tra(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk) + ELSE + tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy-1,jk,jn)+z3*tra(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk) + IF( vn(ji,jbdy,jk) < 0._wp ) THEN + tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy+1,jk,jn)+z5*tra(ji,jbdy-1,jk,jn) & + + z7*tra(ji,jbdy+2,jk,jn) ) * tmask(ji,jbdy,jk) + ENDIF + ENDIF + END DO + END DO + ! Restore ghost points: + tra(imin:imax,jbdy-1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) * tmask(imin:imax,jbdy-1,1:jpkm1) + END DO + ENDIF + ! + ENDIF + + ENDIF + ! + END SUBROUTINE interptrn + +#else + !!---------------------------------------------------------------------- + !! Empty module no TOP AGRIF + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE Agrif_TOP_Interp_empty + !!--------------------------------------------- + !! *** ROUTINE agrif_Top_Interp_empty *** + !!--------------------------------------------- + WRITE(*,*) 'agrif_top_interp : You should not have seen this print! error?' + END SUBROUTINE Agrif_TOP_Interp_empty +#endif + + !!====================================================================== +END MODULE agrif_top_interp diff --git a/V4.0/nemo_sources/src/NST/agrif_top_sponge.F90 b/V4.0/nemo_sources/src/NST/agrif_top_sponge.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cd9fadf4717ed68eee4198563d3ae482f21e28c4 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_top_sponge.F90 @@ -0,0 +1,181 @@ +#define SPONGE_TOP + +MODULE agrif_top_sponge + !!====================================================================== + !! *** MODULE agrif_top_sponge *** + !! AGRIF : sponge layer pakage for passive tracers (TOP) + !!====================================================================== + !! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_top + !!---------------------------------------------------------------------- + !! Agrif_Sponge_trc : + !! interptrn_sponge : + !!---------------------------------------------------------------------- + USE par_oce + USE par_trc + USE oce + USE trc + USE dom_oce + USE agrif_oce + USE agrif_oce_sponge + ! + USE in_out_manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_Sponge_trc, interptrn_sponge + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_top_sponge.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_Sponge_trc + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Sponge_Trc *** + !!---------------------------------------------------------------------- + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! +#if defined SPONGE_TOP +!! Assume persistence + zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) + CALL Agrif_sponge + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + tabspongedone_trn = .FALSE. + CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge ) + Agrif_UseSpecialValue = .FALSE. +#endif + ! + END SUBROUTINE Agrif_Sponge_Trc + + + SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interptrn_sponge *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zabe1, zabe2 + REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv + REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) :: trbdiff + ! vertical interpolation: + REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child + REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin + REAL(wp), DIMENSION(k1:k2) :: h_in + REAL(wp), DIMENSION(1:jpk) :: h_out + INTEGER :: N_in, N_out + REAL(wp) :: h_diff + !!---------------------------------------------------------------------- + ! + IF( before ) THEN + DO jn = 1, jptra + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jn) = trb(ji,jj,jk,jn) + END DO + END DO + END DO + END DO + +# if defined key_vertical + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) + END DO + END DO + END DO +# endif + ELSE +# if defined key_vertical + tabres_child(:,:,:,:) = 0. + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 !k2 = jpk of parent grid + IF (tabres(ji,jj,jk,n2) == 0) EXIT + N_in = N_in + 1 + tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) + h_in(N_in) = tabres(ji,jj,jk,n2) + END DO + N_out = 0 + DO jk=1,jpk ! jpk of child grid + IF (tmask(ji,jj,jk) == 0) EXIT + N_out = N_out + 1 + h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above + ENDDO + IF (N_in > 0) THEN + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for????? + DO jn=1,jptra + call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO +# endif + + DO jj=j1,j2 + DO ji=i1,i2 + DO jk=1,jpkm1 +# if defined key_vertical + trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres_child(ji,jj,jk,1:jptra) +# else + trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres(ji,jj,jk,1:jptra) +# endif + ENDDO + ENDDO + ENDDO + + DO jn = 1, jptra + DO jk = 1, jpkm1 + DO jj = j1,j2-1 + DO ji = i1,i2-1 + zabe1 = fsaht_spu(ji,jj) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) + zabe2 = fsaht_spv(ji,jj) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) + ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) ) + ztv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) + END DO + END DO + ! + DO jj = j1+1,j2-1 + DO ji = i1+1,i2-1 + IF( .NOT. tabspongedone_trn(ji,jj) ) THEN + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ( ztu(ji,jj) - ztu(ji-1,jj ) & + & + ztv(ji,jj) - ztv(ji ,jj-1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + ENDIF + END DO + END DO + END DO + ! + END DO + ! + tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. + ENDIF + ! + END SUBROUTINE interptrn_sponge + +#else + !!---------------------------------------------------------------------- + !! Empty module no TOP AGRIF + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_top_sponge_empty + WRITE(*,*) 'agrif_top_sponge : You should not have seen this print! error?' + END SUBROUTINE agrif_top_sponge_empty +#endif + + !!====================================================================== +END MODULE agrif_top_sponge diff --git a/V4.0/nemo_sources/src/NST/agrif_top_update.F90 b/V4.0/nemo_sources/src/NST/agrif_top_update.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9d2a74ef34639a45f84cbd4830b4674afd6543f7 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_top_update.F90 @@ -0,0 +1,249 @@ +#define TWO_WAY +#undef DECAL_FEEDBACK + +MODULE agrif_top_update + !!====================================================================== + !! *** MODULE agrif_top_update *** + !! AGRIF : update package for passive tracers (TOP) + !!====================================================================== + !! History : + !!---------------------------------------------------------------------- +#if defined key_agrif && defined key_top + !!---------------------------------------------------------------------- + !! 'key_agrif' AGRIF zoom + !! 'key_TOP' on-line tracers + !!---------------------------------------------------------------------- + USE par_oce + USE oce + USE dom_oce + USE agrif_oce + USE par_trc + USE trc + + IMPLICIT NONE + PRIVATE + + PUBLIC Agrif_Update_Trc + + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_top_update.F90 11078 2019-06-05 14:17:09Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE Agrif_Update_Trc( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_Update_Trc *** + !!---------------------------------------------------------------------- + ! + IF (Agrif_Root()) RETURN + ! +#if defined TWO_WAY + Agrif_UseSpecialValueInUpdate = .TRUE. + Agrif_SpecialValueFineGrid = 0._wp + ! +# if ! defined DECAL_FEEDBACK + CALL Agrif_Update_Variable(trn_id, procname=updateTRC ) +! CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC ) +# else + CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC ) +! CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC ) +# endif + ! + Agrif_UseSpecialValueInUpdate = .FALSE. + ! +#endif + ! + END SUBROUTINE Agrif_Update_Trc + +#ifdef key_vertical + SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!--------------------------------------------- + !! *** ROUTINE updateT *** + !!--------------------------------------------- + INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL, INTENT(in) :: before + !! + INTEGER :: ji,jj,jk,jn + REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child + REAL(wp) :: h_in(k1:k2) + REAL(wp) :: h_out(1:jpk) + INTEGER :: N_in, N_out + REAL(wp) :: h_diff + REAL(wp) :: zrho_xy + REAL(wp) :: tabin(k1:k2,n1:n2) + !!--------------------------------------------- + ! + IF (before) THEN + AGRIF_SpecialValue = -999._wp + zrho_xy = Agrif_rhox() * Agrif_rhoy() + DO jn = n1,n2-1 + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,jn) = (trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & + * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + END DO + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & + + (tmask(ji,jj,jk)-1)*999._wp + END DO + END DO + END DO + ELSE + tabres_child(:,:,:,:) = 0. + AGRIF_SpecialValue = 0._wp + DO jj=j1,j2 + DO ji=i1,i2 + N_in = 0 + DO jk=k1,k2 !k2 = jpk of child grid + IF (tabres(ji,jj,jk,n2) == 0 ) EXIT + N_in = N_in + 1 + tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) + h_in(N_in) = tabres(ji,jj,jk,n2) + ENDDO + N_out = 0 + DO jk=1,jpk ! jpk of parent grid + IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF + N_out = N_out + 1 + h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above + ENDDO + IF (N_in > 0) THEN !Remove this? + h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) + IF (h_diff < -1.e-4) THEN + print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) + print *,h_in(1:N_in) + print *,h_out(1:N_out) + STOP + ENDIF + DO jn=1,jptra + CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) + ENDDO + ENDIF + ENDDO + ENDDO + + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN + ! Add asselin part + DO jn = 1,jptra + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN + trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & + & + atfp * ( tabres_child(ji,jj,jk,jn) & + & - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + DO jn = 1,jptra + DO jk=1,jpk + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN + trn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) + END IF + END DO + END DO + END DO + END DO + ENDIF + ! + END SUBROUTINE updateTRC + + +#else + SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) + !!---------------------------------------------------------------------- + !! *** ROUTINE updateTRC *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 + REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres + LOGICAL , INTENT(in ) :: before + !! + INTEGER :: ji,jj,jk,jn + REAL(wp) :: ztb, ztnu, ztno + !!---------------------------------------------------------------------- + ! + ! + IF (before) THEN + DO jn = n1,n2 + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 +!> jc tmp + tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk) +! tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) +!< jc tmp + END DO + END DO + END DO + END DO + ELSE +!> jc tmp + DO jn = n1,n2 + tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & + & * tmask(i1:i2,j1:j2,k1:k2) + ENDDO +!< jc tmp + IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN + ! Add asselin part + DO jn = n1,n2 + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN + ztb = trb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used + ztnu = tabres(ji,jj,jk,jn) + ztno = trn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) + trb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) ) & + & * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + DO jn = n1,n2 + DO jk=k1,k2 + DO jj=j1,j2 + DO ji=i1,i2 + IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN + trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk) + END IF + END DO + END DO + END DO + END DO + ! + IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN + trb(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) + ENDIF + ! + ENDIF + ! + END SUBROUTINE updateTRC +#endif + +#else + !!---------------------------------------------------------------------- + !! Empty module no TOP AGRIF + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE agrif_top_update_empty + WRITE(*,*) 'agrif_top_update : You should not have seen this print! error?' + END SUBROUTINE agrif_top_update_empty +#endif + + !!====================================================================== +END MODULE agrif_top_update diff --git a/V4.0/nemo_sources/src/NST/agrif_user.F90 b/V4.0/nemo_sources/src/NST/agrif_user.F90 new file mode 100644 index 0000000000000000000000000000000000000000..51c4b1ae861c8dc46a9ec14a1d5e1e276bddc5f7 --- /dev/null +++ b/V4.0/nemo_sources/src/NST/agrif_user.F90 @@ -0,0 +1,816 @@ +#undef UPD_HIGH /* MIX HIGH UPDATE */ +#if defined key_agrif + !!---------------------------------------------------------------------- + !! NEMO/NST 4.0 , NEMO Consortium (2018) + !! $Id: agrif_user.F90 13479 2020-09-16 16:56:46Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +SUBROUTINE agrif_user +END SUBROUTINE agrif_user + +SUBROUTINE agrif_before_regridding +END SUBROUTINE agrif_before_regridding + +SUBROUTINE Agrif_InitWorkspace + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitWorkspace *** + !!---------------------------------------------------------------------- + USE par_oce + USE dom_oce + USE nemogcm + USE mppini + !! + IMPLICIT NONE + !!---------------------------------------------------------------------- + ! + IF( .NOT. Agrif_Root() ) THEN + ! no more static variables +!!$! JC: change to allow for different vertical levels +!!$! jpk is already set +!!$! keep it jpk possibly different from jpkglo which +!!$! hold parent grid vertical levels number (set earlier) +!!$! jpk = jpkglo + ENDIF + ! +END SUBROUTINE Agrif_InitWorkspace + + +SUBROUTINE Agrif_InitValues + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitValues *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE Agrif_Util + USE oce + USE dom_oce + USE nemogcm + USE tradmp + USE bdy_oce , ONLY: ln_bdy + !! + IMPLICIT NONE + !!---------------------------------------------------------------------- + ! + CALL nemo_init !* Initializations of each fine grid + + ! !* Agrif initialization + CALL agrif_nemo_init + CALL Agrif_InitValues_cont_dom + CALL Agrif_InitValues_cont +# if defined key_top + CALL Agrif_InitValues_cont_top +# endif +# if defined key_si3 + CALL Agrif_InitValues_cont_ice +# endif + ! +END SUBROUTINE Agrif_initvalues + + +SUBROUTINE Agrif_InitValues_cont_dom + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitValues_cont *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE Agrif_Util + USE oce + USE dom_oce + USE nemogcm + USE in_out_manager + USE agrif_oce_update + USE agrif_oce_interp + USE agrif_oce_sponge + ! + IMPLICIT NONE + !!---------------------------------------------------------------------- + ! + ! Declaration of the type of variable which have to be interpolated + ! + CALL agrif_declare_var_dom + ! +END SUBROUTINE Agrif_InitValues_cont_dom + + +SUBROUTINE agrif_declare_var_dom + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_declare_var *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE agrif_util + USE par_oce + USE oce + ! + IMPLICIT NONE + ! + INTEGER :: ind1, ind2, ind3 + !!---------------------------------------------------------------------- + + ! 1. Declaration of the type of variable which have to be interpolated + !--------------------------------------------------------------------- + ind1 = nbghostcells + ind2 = 1 + nbghostcells + ind3 = 2 + nbghostcells + CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) + CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) + + ! 2. Type of interpolation + !------------------------- + CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm ) + CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm , interp2=Agrif_linear ) + + ! 3. Location of interpolation + !----------------------------- + CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) + CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) + + ! 4. Update type + !--------------- +# if defined UPD_HIGH + CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average) +#else + CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) + CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) +#endif + +END SUBROUTINE agrif_declare_var_dom + + +SUBROUTINE Agrif_InitValues_cont + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitValues_cont *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE agrif_oce_update + USE agrif_oce_interp + USE agrif_oce_sponge + USE Agrif_Util + USE oce + USE dom_oce + USE zdf_oce + USE nemogcm + ! + USE lib_mpp + USE in_out_manager + ! + IMPLICIT NONE + ! + LOGICAL :: check_namelist + CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 + !!---------------------------------------------------------------------- + + ! 1. Declaration of the type of variable which have to be interpolated + !--------------------------------------------------------------------- + CALL agrif_declare_var + + ! 2. First interpolations of potentially non zero fields + !------------------------------------------------------- + Agrif_SpecialValue = 0._wp + Agrif_UseSpecialValue = .TRUE. + CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) + CALL Agrif_Sponge + tabspongedone_tsn = .FALSE. + CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) + ! reset tsa to zero + tsa(:,:,:,:) = 0. + + Agrif_UseSpecialValue = ln_spc_dyn + CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) + CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) + tabspongedone_u = .FALSE. + tabspongedone_v = .FALSE. + CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) + tabspongedone_u = .FALSE. + tabspongedone_v = .FALSE. + CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) + + Agrif_UseSpecialValue = .TRUE. + CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) + hbdy_w(:,:) = 0.e0 ; hbdy_e(:,:) = 0.e0 ; hbdy_n(:,:) = 0.e0 ; hbdy_s(:,:) = 0.e0 + ssha(:,:) = 0.e0 + + IF ( ln_dynspg_ts ) THEN + Agrif_UseSpecialValue = ln_spc_dyn + CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) + CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) + CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) + CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) + ubdy_w(:,:) = 0.e0 ; vbdy_w(:,:) = 0.e0 + ubdy_e(:,:) = 0.e0 ; vbdy_e(:,:) = 0.e0 + ubdy_n(:,:) = 0.e0 ; vbdy_n(:,:) = 0.e0 + ubdy_s(:,:) = 0.e0 ; vbdy_s(:,:) = 0.e0 + ENDIF + + Agrif_UseSpecialValue = .FALSE. + ! reset velocities to zero + ua(:,:,:) = 0. + va(:,:,:) = 0. + + ! 3. Some controls + !----------------- + check_namelist = .TRUE. + + IF( check_namelist ) THEN + + ! Check time steps + IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN + WRITE(cl_check1,*) NINT(Agrif_Parent(rdt)) + WRITE(cl_check2,*) NINT(rdt) + WRITE(cl_check3,*) NINT(Agrif_Parent(rdt)/Agrif_Rhot()) + CALL ctl_stop( 'Incompatible time step between ocean grids', & + & 'parent grid value : '//cl_check1 , & + & 'child grid value : '//cl_check2 , & + & 'value on child grid should be changed to : '//cl_check3 ) + ENDIF + + ! Check run length + IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & + Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN + WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 + WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() + CALL ctl_warn( 'Incompatible run length between grids' , & + & 'nit000 on fine grid will be changed to : '//cl_check1, & + & 'nitend on fine grid will be changed to : '//cl_check2 ) + nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 + nitend = Agrif_Parent(nitend) *Agrif_IRhot() + ENDIF + + ! Check free surface scheme + IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& + & ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN + WRITE(cl_check1,*) Agrif_Parent( ln_dynspg_ts ) + WRITE(cl_check2,*) ln_dynspg_ts + WRITE(cl_check3,*) Agrif_Parent( ln_dynspg_exp ) + WRITE(cl_check4,*) ln_dynspg_exp + CALL ctl_stop( 'Incompatible free surface scheme between grids' , & + & 'parent grid ln_dynspg_ts :'//cl_check1 , & + & 'child grid ln_dynspg_ts :'//cl_check2 , & + & 'parent grid ln_dynspg_exp :'//cl_check3 , & + & 'child grid ln_dynspg_exp :'//cl_check4 , & + & 'those logicals should be identical' ) + STOP + ENDIF + + ! Check if identical linear free surface option + IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.& + & ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN + WRITE(cl_check1,*) Agrif_Parent(ln_linssh ) + WRITE(cl_check2,*) ln_linssh + CALL ctl_stop( 'Incompatible linearized fs option between grids', & + & 'parent grid ln_linssh :'//cl_check1 , & + & 'child grid ln_linssh :'//cl_check2 , & + & 'those logicals should be identical' ) + STOP + ENDIF + + ! check if masks and bathymetries match + IF(ln_chk_bathy) THEN + ! + IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() + ! + kindic_agr = 0 + ! check if umask agree with parent along western and eastern boundaries: + CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) + ! check if vmask agree with parent along northern and southern boundaries: + CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) + ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: + CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) + ! + CALL mpp_sum( 'agrif_user', kindic_agr ) + IF( kindic_agr /= 0 ) THEN + CALL ctl_stop('Child Bathymetry is not correct near boundaries.') + ELSE + IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' + END IF + ENDIF + ! + ENDIF + ! +END SUBROUTINE Agrif_InitValues_cont + +SUBROUTINE agrif_declare_var + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_declarE_var *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE agrif_util + USE agrif_oce + USE par_oce ! ocean parameters + USE zdf_oce ! vertical physics + USE oce + ! + IMPLICIT NONE + ! + INTEGER :: ind1, ind2, ind3 + !!---------------------------------------------------------------------- + + ! 1. Declaration of the type of variable which have to be interpolated + !--------------------------------------------------------------------- + ind1 = nbghostcells + ind2 = 1 + nbghostcells + ind3 = 2 + nbghostcells +# if defined key_vertical + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) + + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) +# else + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) + + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) + CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) + CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) +# endif + + CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) + CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) + CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) + + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) + + CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) + CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) + CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) + CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) + CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) + CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) + + CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) + + IF( ln_zdftke.OR.ln_zdfgls ) THEN +! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) +! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) +# if defined key_vertical + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id) +# else + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id) +# endif + ENDIF + + ! 2. Type of interpolation + !------------------------- + CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) + + CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) + CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) + + CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) + + CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) + CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) + CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) + CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) + CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) + + + CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) + CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) + + CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) + CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) + CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) + + IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) + + ! 3. Location of interpolation + !----------------------------- + CALL Agrif_Set_bc( tsn_id, (/0,ind1/) ) + CALL Agrif_Set_bc( un_interp_id, (/0,ind1/) ) + CALL Agrif_Set_bc( vn_interp_id, (/0,ind1/) ) + + CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! if west and rhox=3 and sponge=2 and ghost=1: columns 2 to 9 + CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) + CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) + + CALL Agrif_Set_bc( sshn_id, (/0,ind1-1/) ) + CALL Agrif_Set_bc( unb_id, (/0,ind1-1/) ) + CALL Agrif_Set_bc( vnb_id, (/0,ind1-1/) ) + CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) ) + CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) + + CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) ) ! if west and rhox=3 and ghost=1: column 2 to 6 + CALL Agrif_Set_bc( umsk_id, (/0,0/) ) + CALL Agrif_Set_bc( vmsk_id, (/0,0/) ) + + + IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) + + ! 4. Update type + !--------------- + CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) + +# if defined UPD_HIGH + CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) + + CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) + CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(e3t_id, update = Agrif_Update_Full_Weighting) + + IF( ln_zdftke.OR.ln_zdfgls ) THEN +! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting) +! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting) +! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting) + ENDIF + +#else + CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) + CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) + CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) + + CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) + CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) + CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) + CALL Agrif_Set_Updatetype(e3t_id, update = AGRIF_Update_Average) + + IF( ln_zdftke.OR.ln_zdfgls ) THEN +! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) +! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) +! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) + ENDIF + +#endif + ! +END SUBROUTINE agrif_declare_var + +#if defined key_si3 +SUBROUTINE Agrif_InitValues_cont_ice + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitValues_cont_ice *** + !! + !! ** Purpose :: Initialisation of variables to be interpolated for ice + !!---------------------------------------------------------------------- + USE Agrif_Util + USE sbc_oce, ONLY : nn_fsbc ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc + USE ice + USE agrif_ice + USE in_out_manager + USE agrif_ice_interp + USE lib_mpp + ! + IMPLICIT NONE + !!---------------------------------------------------------------------- + ! + ! Declaration of the type of variable which have to be interpolated (parent=>child) + !---------------------------------------------------------------------------------- + CALL agrif_declare_var_ice + + ! Controls + + ! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom) + ! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child) + ! therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable + ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account + IF( nn_fsbc > 1 ) CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly') + + ! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer + IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 ) THEN + CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)') + ENDIF + ! First Interpolations (using "after" ice subtime step => nbstep_ice=1) + !---------------------------------------------------------------------- + nbstep_ice = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong) + CALL agrif_interp_ice('U') ! interpolation of ice velocities + CALL agrif_interp_ice('V') ! interpolation of ice velocities + CALL agrif_interp_ice('T') ! interpolation of ice tracers + nbstep_ice = 0 + + ! +END SUBROUTINE Agrif_InitValues_cont_ice + +SUBROUTINE agrif_declare_var_ice + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_declare_var_ice *** + !! + !! ** Purpose :: Declaration of variables to be interpolated for ice + !!---------------------------------------------------------------------- + USE Agrif_Util + USE ice + USE par_oce, ONLY : nbghostcells + ! + IMPLICIT NONE + ! + INTEGER :: ind1, ind2, ind3 + !!---------------------------------------------------------------------- + ! + ! 1. Declaration of the type of variable which have to be interpolated (parent=>child) + ! agrif_declare_variable(position,1st point index,--,--,dimensions,name) + ! ex.: position=> 1,1 = not-centered (in i and j) + ! 2,2 = centered ( - ) + ! index => 1,1 = one ghost line + ! 2,2 = two ghost lines + !------------------------------------------------------------------------------------- + ind1 = nbghostcells + ind2 = 1 + nbghostcells + ind3 = 2 + nbghostcells + CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(9+nlay_s+nlay_i)/),tra_ice_id) + CALL agrif_declare_variable((/1,2/) ,(/ind2,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) + CALL agrif_declare_variable((/2,1/) ,(/ind3,ind2/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) + + ! 2. Set interpolations (normal & tangent to the grid cell for velocities) + !----------------------------------- + CALL Agrif_Set_bcinterp(tra_ice_id, interp = AGRIF_linear) + CALL Agrif_Set_bcinterp(u_ice_id , interp1 = Agrif_linear,interp2 = AGRIF_ppm ) + CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear) + + ! 3. Set location of interpolations + !---------------------------------- + CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) + CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/)) + CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/)) + + ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) + !-------------------------------------------------- +# if defined UPD_HIGH + CALL Agrif_Set_Updatetype(tra_ice_id, update = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) + CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) +#else + CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average) + CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) + CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) +#endif + +END SUBROUTINE agrif_declare_var_ice +#endif + + +# if defined key_top +SUBROUTINE Agrif_InitValues_cont_top + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InitValues_cont_top *** + !! + !! ** Purpose :: Declaration of variables to be interpolated + !!---------------------------------------------------------------------- + USE Agrif_Util + USE oce + USE dom_oce + USE nemogcm + USE par_trc + USE lib_mpp + USE trc + USE in_out_manager + USE agrif_oce_sponge + USE agrif_top_update + USE agrif_top_interp + USE agrif_top_sponge + !! + IMPLICIT NONE + ! + CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 + LOGICAL :: check_namelist + !!---------------------------------------------------------------------- + + + ! 1. Declaration of the type of variable which have to be interpolated + !--------------------------------------------------------------------- + CALL agrif_declare_var_top + + ! 2. First interpolations of potentially non zero fields + !------------------------------------------------------- + Agrif_SpecialValue=0. + Agrif_UseSpecialValue = .TRUE. + CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) + Agrif_UseSpecialValue = .FALSE. + CALL Agrif_Sponge + tabspongedone_trn = .FALSE. + CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) + ! reset tsa to zero + tra(:,:,:,:) = 0. + + + ! 3. Some controls + !----------------- + check_namelist = .TRUE. + + IF( check_namelist ) THEN + ! Check time steps + IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN + WRITE(cl_check1,*) Agrif_Parent(rdt) + WRITE(cl_check2,*) rdt + WRITE(cl_check3,*) rdt*Agrif_Rhot() + CALL ctl_stop( 'incompatible time step between grids', & + & 'parent grid value : '//cl_check1 , & + & 'child grid value : '//cl_check2 , & + & 'value on child grid should be changed to & + & :'//cl_check3 ) + ENDIF + + ! Check run length + IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & + Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN + WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 + WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() + CALL ctl_warn( 'incompatible run length between grids' , & + & ' nit000 on fine grid will be change to : '//cl_check1, & + & ' nitend on fine grid will be change to : '//cl_check2 ) + nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 + nitend = Agrif_Parent(nitend) *Agrif_IRhot() + ENDIF + + ! Check passive tracer cell + IF( nn_dttrc .NE. 1 ) THEN + WRITE(*,*) 'nn_dttrc should be equal to 1' + ENDIF + ENDIF + ! +END SUBROUTINE Agrif_InitValues_cont_top + + +SUBROUTINE agrif_declare_var_top + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_declare_var_top *** + !! + !! ** Purpose :: Declaration of TOP variables to be interpolated + !!---------------------------------------------------------------------- + USE agrif_util + USE agrif_oce + USE dom_oce + USE trc + !! + IMPLICIT NONE + ! + INTEGER :: ind1, ind2, ind3 + !!---------------------------------------------------------------------- + + ! 1. Declaration of the type of variable which have to be interpolated + !--------------------------------------------------------------------- + ind1 = nbghostcells + ind2 = 1 + nbghostcells + ind3 = 2 + nbghostcells +# if defined key_vertical + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id) + CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id) +# else + CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) + CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) +# endif + + ! 2. Type of interpolation + !------------------------- + CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) + CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) + + ! 3. Location of interpolation + !----------------------------- + CALL Agrif_Set_bc(trn_id,(/0,ind1/)) + CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) + + ! 4. Update type + !--------------- +# if defined UPD_HIGH + CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting) +#else + CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) +#endif + ! +END SUBROUTINE agrif_declare_var_top +# endif + +SUBROUTINE Agrif_detect( kg, ksizex ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_detect *** + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: ksizex + INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg + !!---------------------------------------------------------------------- + ! + RETURN + ! +END SUBROUTINE Agrif_detect + + +SUBROUTINE agrif_nemo_init + !!---------------------------------------------------------------------- + !! *** ROUTINE agrif_init *** + !!---------------------------------------------------------------------- + USE agrif_oce + USE agrif_ice + USE in_out_manager + USE lib_mpp + !! + IMPLICIT NONE + ! + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: iminspon + NAMELIST/namagrif/ rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy + !!-------------------------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : AGRIF zoom + READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namagrif in configuration namelist : AGRIF zoom + READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist' ) + IF(lwm) WRITE ( numond, namagrif ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters' + WRITE(numout,*) ' sponge coefficient for tracers rn_sponge_tra = ', rn_sponge_tra, ' s' + WRITE(numout,*) ' sponge coefficient for dynamics rn_sponge_tra = ', rn_sponge_dyn, ' s' + WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn + WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy + ENDIF + ! + ! convert DOCTOR namelist name into OLD names + visc_tra = rn_sponge_tra + visc_dyn = rn_sponge_dyn + ! + ! Check sponge length: + IF( MIN(jpi ,jpj ) <= 1 + nbghostcells + (nn_sponge_len * Agrif_irhox() + 1) & + .OR. MIN(jpiglo,jpjglo) <= 2* (1 + nbghostcells + (nn_sponge_len * Agrif_irhox() + 1) ) ) & + & CALL ctl_stop('STOP','agrif sponge length is too large') + ! + IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') + ! +END SUBROUTINE agrif_nemo_init + +# if defined key_mpp_mpi + +SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_InvLoc *** + !!---------------------------------------------------------------------- + USE dom_oce + !! + IMPLICIT NONE + ! + INTEGER :: indglob, indloc, nprocloc, i + !!---------------------------------------------------------------------- + ! + SELECT CASE( i ) + CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 + CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 + CASE DEFAULT + indglob = indloc + END SELECT + ! +END SUBROUTINE Agrif_InvLoc + + +SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_get_proc_info *** + !!---------------------------------------------------------------------- + USE par_oce + !! + IMPLICIT NONE + ! + INTEGER, INTENT(out) :: imin, imax + INTEGER, INTENT(out) :: jmin, jmax + !!---------------------------------------------------------------------- + ! + imin = nimppt(Agrif_Procrank+1) ! ????? + jmin = njmppt(Agrif_Procrank+1) ! ????? + imax = imin + jpi - 1 + jmax = jmin + jpj - 1 + ! +END SUBROUTINE Agrif_get_proc_info + + +SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) + !!---------------------------------------------------------------------- + !! *** ROUTINE Agrif_estimate_parallel_cost *** + !!---------------------------------------------------------------------- + USE par_oce + !! + IMPLICIT NONE + ! + INTEGER, INTENT(in) :: imin, imax + INTEGER, INTENT(in) :: jmin, jmax + INTEGER, INTENT(in) :: nbprocs + REAL(wp), INTENT(out) :: grid_cost + !!---------------------------------------------------------------------- + ! + grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) + ! +END SUBROUTINE Agrif_estimate_parallel_cost + +# endif + +#else +SUBROUTINE Subcalledbyagrif + !!---------------------------------------------------------------------- + !! *** ROUTINE Subcalledbyagrif *** + !!---------------------------------------------------------------------- + WRITE(*,*) 'Impossible to be here' +END SUBROUTINE Subcalledbyagrif +#endif diff --git a/V4.0/nemo_sources/src/OCE/ASM/asmbkg.F90 b/V4.0/nemo_sources/src/OCE/ASM/asmbkg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0a00b00b2ebd1f5768cd9588dd59ed58e7f38d9f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ASM/asmbkg.F90 @@ -0,0 +1,268 @@ +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 + !! ! 2012-11 (A. Weaver) Save avt_bkg for mixing layer computation, remove en_bkg + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 sbc_ice ! Ice model + 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: asmbkg.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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 = TRIM(cn_ocerst_outdir)//cl_asmbkg, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// & + & TRIM(cn_ocerst_outdir)//TRIM( c_asmbkg ) + ! + ! ! Define the output file +#if defined key_si3 + CALL iom_open( TRIM(cn_ocerst_outdir)//c_asmbkg, inum, ldwrt = .TRUE., kdlev = jpl) +#else + CALL iom_open( TRIM(cn_ocerst_outdir)//c_asmbkg, inum, ldwrt = .TRUE.) +#endif + ! + 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 + ! + ! ! Define netCDF the information + CALL iom_rstput( -1, nitbkg_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( -1, nitbkg_r, inum, 'un' , un ) + CALL iom_rstput( -1, nitbkg_r, inum, 'vn' , vn ) + CALL iom_rstput( -1, nitbkg_r, inum, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_rstput( -1, nitbkg_r, inum, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_rstput( -1, nitbkg_r, inum, 'sshn' , sshn ) +#if defined key_si3 + IF( lk_si3 ) THEN + IF( ALLOCATED(at_i) ) THEN + CALL iom_rstput( -1, 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 + CALL iom_rstput( -1, nitdin_r, inum, 'a_i', a_i(:,:,:) ) + ENDIF +#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 defined key_si3 + ! MC: make sure nn_ice is 2 for si3 + ! : make sure at_i corresponds to 1.0 -frld in v34 + IF( lk_si3 ) 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 + CALL iom_rstput( kt, nitdin_r, inum, 'a_i', a_i(:,:,:) ) + ENDIF +#endif + ! + CALL iom_close( inum ) + + IF( nitbkg_r > nitdin_r ) THEN + call ctl_event( 'asm_bkg_wri' ) + ENDIF + + 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 = TRIM(cn_ocerst_outdir)//cl_asmdin, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// & + & TRIM(cn_ocerst_outdir)//TRIM( c_asmdin ) + ! + ! ! Define the output file +#if defined key_si3 + CALL iom_open( TRIM(cn_ocerst_outdir)//c_asmdin, inum, ldwrt = .TRUE., kdlev = jpl) +#else + CALL iom_open( TRIM(cn_ocerst_outdir)//c_asmdin, inum, ldwrt = .TRUE.) +#endif + + ! + IF( nitdin_r == nit000 - 1 ) THEN ! Treat special case when nitbkg = 0 + + zdate = REAL( ndastp ) + ELSE + zdate = REAL( ndastp ) + ENDIF + ! + ! ! Define netCDF the information + CALL iom_rstput( -1, nitdin_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( -1, nitdin_r, inum, 'un' , un ) + CALL iom_rstput( -1, nitdin_r, inum, 'vn' , vn ) + CALL iom_rstput( -1, nitdin_r, inum, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_rstput( -1, nitdin_r, inum, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_rstput( -1, nitdin_r, inum, 'sshn' , sshn ) +#if defined key_si3 + IF( lk_si3 ) THEN + IF( ALLOCATED(at_i) ) THEN + CALL iom_rstput( -1, 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 + CALL iom_rstput( -1, nitdin_r, inum, 'a_i', a_i(:,:,:) ) + ENDIF +#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 + ! MC: make sure nn_ice is 2 for si3 + ! : make sure at_i corresponds to 1.0 -frld in v34 + IF( lk_si3 ) 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 + CALL iom_rstput( kt, nitdin_r, inum, 'a_i', a_i(:,:,:) ) + ENDIF +#endif + ! + CALL iom_close( inum ) + + IF( nitbkg_r <= nitdin_r ) THEN + call ctl_event( 'asm_bkg_wri' ) + ENDIF + + ENDIF + ! + ENDIF + ! + END SUBROUTINE asm_bkg_wri + + SUBROUTINE ctl_event( event_name ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ctl_event *** + !! + !! ** Purpose : set ecFlow event + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: event_name + !!---------------------------------------------------------------------- + ! + +#if defined key_sms + + CHARACTER(LEN=160) :: & + & cl_ecfcmd ! Command to ecf + INTEGER :: cmdstat ! needed if asyncronous system calls not supported + + IF ( lwp .AND. ln_smslabel ) THEN + + WRITE(cl_ecfcmd,'(A,x,A)') TRIM( cn_smsevent ), TRIM( event_name ) + + WRITE(numout,*) + WRITE(numout,*) ' ctrl_event: Setting ecFlow event ', event_name + WRITE(numout,*) ' : ', TRIM( cl_ecfcmd ) + WRITE(numout,*) ' ------' + + CALL EXECUTE_COMMAND_LINE( TRIM(cl_ecfcmd), WAIT=.FALSE., CMDSTAT=cmdstat ) + + END IF + +#endif + + END SUBROUTINE ctl_event + + !!====================================================================== +END MODULE asmbkg \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ASM/asminc.F90 b/V4.0/nemo_sources/src/OCE/ASM/asminc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6fb01c2790ac964fff6d40d32400e3a7a0f9f401 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ASM/asminc.F90 @@ -0,0 +1,1278 @@ +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 phycst ! physical constants + USE ice1D ! sea-ice: thermodynamics variables + USE icetab ! sea-ice: 2D <==> 1D + USE icethd_do + USE ice + USE icedyn_adv, only : ice_dyn_rest, ice_dyn_asm_init + USE icevar, only : ice_var_salprof + USE icethd, only : ice_thd_temp_2d +#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_icedin !: No ice 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_a_iinc !: No sea ice concentration increment to each thickness category + 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_si3 + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: a_i_bkginc ! Increment to the background sea ice conc categories +#endif + REAL(wp) :: zinctotwgt = 0.0_wp !: TEMPORARY variable to print sea ice weights + REAL(wp) :: zhi_damin = 0.5_wp !: ice thickness for new sea ice from da increment + INTEGER :: na_iincr_split = 0 !: methodology for splitting a_i increment + INTEGER :: nh_iincr_min = 0 !: methodology for setting minimum ice thickness with DA + INTEGER :: nhi_damin = 1 !: thickness category corresponding to zhi_damin + REAL(wp) :: zopenwater_lim + LOGICAL, PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: incr_newice !: mask .TRUE.=DA positive ice increment to open water +#if defined key_cice && defined key_asminc + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ndaice_da ! ice increment tendency into CICE +#endif + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asminc.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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=wp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step + REAL(KIND=wp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term + REAL(KIND=wp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI + REAL(KIND=wp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step + REAL(KIND=wp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step + + REAL(wp) :: znorm ! Normalization factor for IAU weights + REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) + REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid + REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid + REAL(wp) :: zdate_bkg ! Date in background state file for DI + REAL(wp) :: zdate_inc ! Time axis in increments file + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace + REAL(wp) :: zremaining_increment + +#if defined key_si3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z1_hti + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hm_i_loc + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z1_at_i + integer ::nice_temp_max_levels + real(wp) :: zice_temp_strength ! K/(m^2/m^2) + logical :: lice_temp_increment + INTEGER :: jl +#endif + + !! + NAMELIST/nam_asminc/ ln_bkgwri, & + & ln_trainc, ln_dyninc, ln_sshinc, & + & ln_seaiceinc, ln_a_iinc, & + & ln_asmdin, ln_icedin, ln_asmiau, & + & nitbkg, nitdin, nitiaustr, nitiaufin, niaufn, & + & ln_salfix, salfixmin, nn_divdmp, na_iincr_split,& + & nh_iincr_min, zhi_damin, zopenwater_lim, & + & lice_temp_increment, nice_temp_max_levels, & + & zice_temp_strength + !!---------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! Read Namelist nam_asminc : assimilation increment interface + !----------------------------------------------------------------------- + + ! Set default values + ln_bkgwri = .FALSE. + ln_trainc = .FALSE. + ln_dyninc = .FALSE. + ln_sshinc = .FALSE. + ln_seaiceinc = .FALSE. + ln_a_iinc = .FALSE. + ln_asmdin = .FALSE. + ln_icedin = .FALSE. + ln_asmiau = .TRUE. + ln_salfix = .FALSE. + ln_temnofreeze = .FALSE. + salfixmin = -9999 + nitbkg = 0 + nitdin = 0 + nitiaustr = 1 + nitiaufin = 150 ! = 10 days with ORCA2 + niaufn = 0 + nn_divdmp = 0 + na_iincr_split = 0 + nh_iincr_min = 0 + zhi_damin = 0.5_wp + zopenwater_lim = 1.0e-2_wp + lice_temp_increment = .true. + nice_temp_max_levels = 12 + zice_temp_strength = 0.0_wp + + 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 Direct Initialization (DI) of ice ln_icedin = ', ln_icedin + WRITE(numout,*) ' Logical switch for applying sea ice increments ln_seaiceinc = ', ln_seaiceinc + WRITE(numout,*) ' Logical switch for applying sea ice conc increments a_i ln_a_iinc = ', ln_a_iinc + 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 + WRITE(numout,*) ' Divergence damping iterations nn_divdmp = ', nn_divdmp + WRITE(numout,*) ' Ice splitting option na_iincr_split = ', na_iincr_split + WRITE(numout,*) ' Ice thickness for new ice from da option nh_iincr_min = ', nh_iincr_min + WRITE(numout,*) ' Minimum ice thickness for new ice from da zhi_damin = ', zhi_damin + WRITE(numout,*) ' Limit for open water detection for ice da zopenwater_lim = ', zopenwater_lim + WRITE(numout,*) ' Ice increment induces temperature increment lice_temp_increment = ', lice_temp_increment + WRITE(numout,*) ' Maximum depth level for ice-temp increment nice_temp_max_levels = ', nice_temp_max_levels + WRITE(numout,*) ' Weighting of ice-temp increment (K/(m^2/m^2)) zice_temp_strength = ', zice_temp_strength + 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 ( ( ln_bkgwri ).AND.( ( ln_asmdin ).OR.( ln_asmiau ) ) ) & + & CALL ctl_stop( ' ln_bkgwri and either ln_asmdin or ln_asmiau are set to .true.:', & + & ' The background state must be written before applying the increments') + + 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_warn( ' 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_si3 + ALLOCATE( a_i_bkginc (jpi,jpj,jpl) ) ; a_i_bkginc (:,:,:) = 0._wp + ALLOCATE( incr_newice(jpi,jpj,jpl) ) ; incr_newice(:,:,:) = .FALSE. +#endif +#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 + + IF ( ln_a_iinc ) THEN + IF ( iom_varid ( inum, 'bckina_i', ldstop = .false. ) > 0 ) THEN + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Reading bckina_i from file' + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + !multi category increment for sea ice conc + CALL iom_get(inum, jpdom_autoglo, 'bckina_i', a_i_bkginc, 1 ) + DO jk = 1, jpl + a_i_bkginc(:,:,jk) = a_i_bkginc(:,:,jk) * tmask(:,:,1) + ENDDO + WHERE( ABS( a_i_bkginc(:,:,:) ) > 1.0e+10 ) a_i_bkginc(:,:,:) = 0.0 + ELSE + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Converting seaice_bkginc to a_i_bkginc' + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + !single category increment for sea ice conc + !convert single category increment to multi category + a_i_bkginc = 0.0_wp + + ! hm_i seems to be inaccurate in areas of low ice conc + ! so compute our own estimate less prone to numerical issues + + !ensure total volume and conc are up-to-date + vt_i = sum(v_i(:,:,:), dim=3) + at_i = sum(a_i(:,:,:), dim=3) + + ALLOCATE( z1_hti , MOLD=vt_i ) + ALLOCATE( hm_i_loc, MOLD=vt_i ) + ALLOCATE( z1_at_i , MOLD=vt_i ) + + ! Calculate which category corresponds to zhi_damin + ! find which category to fill + nhi_damin=1 + DO jl = 1, jpl + IF( zhi_damin > hi_max(jl-1) .AND. zhi_damin <= hi_max(jl) ) THEN + nhi_damin = jl + END IF + END DO + + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Category corresponding to zhi_damin:', zhi_damin, ' is nhi_damin:',nhi_damin + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + + + select case(na_iincr_split) + case (2) ! background profile + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Converting seaice_bkginc to a_i_bkginc using background profile' + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + DO jj = 1, jpj + DO ji = 1, jpi + if (at_i(ji,jj) > 0.1_wp) then + do jl = 1, jpl + a_i_bkginc(ji,jj,jl) = a_i(ji,jj,jl) * seaice_bkginc(ji,jj) / at_i(ji,jj) + end do + else + a_i_bkginc(ji,jj,:) = 0.0_wp + a_i_bkginc(ji,jj,nhi_damin) = seaice_bkginc(ji,jj) + end if + end do + end do + case (3) ! UK MO scheme based on Peterson et al. 2015 + ! https://doi.org/10.1007/s00382-014-2190-9 + ! but implemented by PB at ECMWF + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Converting seaice_bkginc to a_i_bkginc using Peterson splitting' + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + DO jj = 1, jpj + DO ji = 1, jpi + IF ( seaice_bkginc(ji,jj) > 0.0_wp) THEN + !Positive ice concentration increments are always + !added to the thinnest category of ice + a_i_bkginc(ji,jj,nhi_damin) = seaice_bkginc(ji,jj) + ELSE + !negative increments are first removed from the thinnest + !available category until it reaches zero concentration + !and then progressively removed from thicker categories + zremaining_increment = seaice_bkginc(ji,jj) + DO jl = 1, jpl + ! assign as much increment as possible to current category + a_i_bkginc(ji,jj,jl) = -min(a_i(ji,jj,jl), -zremaining_increment) + ! update remaining amount of increment + zremaining_increment = zremaining_increment - a_i_bkginc(ji,jj,jl) + END DO + END IF + END DO + END DO + case default + CALL ctl_stop('Bad choice of na_iincr_split') + end select + + do jl = 1,jpl + where (at_i(:,:) < zopenwater_lim .and. seaice_bkginc(:,:) > 0.0_wp) + incr_newice(:,:,jl) = .true. + end where + end do + + deallocate(z1_hti) + deallocate(z1_at_i) + deallocate(hm_i_loc) + + ENDIF + ENDIF + + IF (lice_temp_increment) then ! check on if we want ice induced sst increment + + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : sea ice increment induces temperature increment with' + WRITE(numout,*) 'asm_inc_init : strength ',zice_temp_strength,' and max depth ',nice_temp_max_levels + WRITE(numout,*) '~~~~~~~~~~~~' + END IF + + do jk = 1,jpk + DO jj = 1, jpj + DO ji = 1, jpi + t_bkginc(ji,jj,jk) = t_bkginc(ji,jj,jk) - zice_temp_strength*ice_temp_vert_weight(jk,nice_temp_max_levels)*seaice_bkginc(ji,jj) + end do + end DO + end do + end if + + 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.0_wp ) ! 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 + + CALL ice_dyn_asm_init( ln_seaiceinc ) + ! + 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 + !IF( ln_seaiceinc ) CALL seaice_asm_inc( nit000 - 1 ) ! Sea ice + ENDIF + ENDIF + ! + END SUBROUTINE asm_inc_init + + FUNCTION ice_temp_vert_weight(level,maxlevels) + REAL(wp) :: ice_temp_vert_weight + INTEGER, INTENT(IN) :: level + INTEGER, INTENT(IN) :: maxlevels + + ! start with linear function + ice_temp_vert_weight = max(0.0_wp, (1.0_wp/(1.0_wp-maxlevels))*(level-maxlevels)) + END FUNCTION ice_temp_vert_weight + + 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( CASTSP(tsn(:,:,jk,jp_sal)), fzptnz(:,:,jk), CASTSP(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 + 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) + t_bkginc(:,:,jk) > fzptnz(:,:,jk) ) + tsn(:,:,jk,jp_tem) = t_bkg(:,:,jk) + t_bkginc(:,:,jk) + END WHERE + ELSE + tsn(:,:,jk,jp_tem) = t_bkg(:,:,jk) + t_bkginc(:,:,jk) + 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) + s_bkginc(:,:,jk) > salfixmin ) + tsn(:,:,jk,jp_sal) = s_bkg(:,:,jk) + s_bkginc(:,:,jk) + END WHERE + ELSE + tsn(:,:,jk,jp_sal) = s_bkg(:,:,jk) + s_bkginc(:,:,jk) + ENDIF + END DO + + tsb(:,:,:,:) = tsn(:,:,:,:) ! Update before fields + + CALL eos( tsb, rhd, rhop, CASTDP(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 + + ELSEIF ( kt == nitdin_r + 1 ) THEN ! For bias crcn to work + + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + DEALLOCATE( t_bkg ) + DEALLOCATE( s_bkg ) + ENDIF + ! + ENDIF + 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 + DO jk = 1, jpkm1 + un(:,:,jk) = u_bkg(:,:,jk) + u_bkginc(:,:,jk) + vn(:,:,jk) = v_bkg(:,:,jk) + v_bkginc(:,:,jk) + END DO + ! + ub(:,:,:) = un(:,:,:) ! Update before fields + vb(:,:,:) = vn(:,:,:) + ! + ELSEIF ( kt == nitdin_r + 1 ) THEN ! For bias crcn to work + 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 ???? + ! + ELSEIF ( kt == nitdin_r + 1 ) THEN ! For bias crcn to work + 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(dp), 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, jl, jk, ji, jj + REAL(wp) :: zincwgt ! IAU weight for current time step + REAL(wp), DIMENSION(jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i ! inverse of old ice concentration + REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres + REAL(wp) :: rn_hinew_save + LOGICAL, SAVE :: initial_step=.TRUE. + LOGICAL :: add_increment + REAL(wp) :: zincwgt_remaining + REAL(wp), DIMENSION(jpi,jpj) :: at_i_bkginc ! sum of conc increment over categories + REAL(wp) :: ztmp + REAL(wp), PARAMETER :: zsice_multiyr = 2.3_wp ! salinity of ice = F(z) [multiyear ice] + !!---------------------------------------------------------------------- + ! + add_increment = .FALSE. + ! !----------------------------------------- + IF ( ln_asmiau .and. .not. ln_icedin ) THEN ! Incremental Analysis Updating + ! !----------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = sum(wgtiau(it+1-nn_fsbc:it)) ! IAU weight for the current time step + zinctotwgt = zinctotwgt + zincwgt + + zincwgt_remaining = sum( wgtiau(it:UBOUND(wgtiau,dim=1)) ) + ! 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 = ', zincwgt + WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' DEBUGGING: cummulative weight = ', zinctotwgt + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + add_increment = .TRUE. + + END IF + + ELSEIF ( ln_asmdin .or. ln_icedin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + neuler = 0 ! Force Euler forward step + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'seaice_asm_inc : sea ice direct initialization at time step = ', kt + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + + zincwgt = 1.0_wp + zincwgt_remaining = 1.0_wp + + add_increment = .true. + + END IF + + END IF + + + if ( add_increment ) THEN + ! + ! Sea-ice : SI3 case + ! + if (ln_a_iinc) THEN + + ! ensure total sum of categories hasnt already exceeded rn_amax_2d - might not be necessary + at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) + DO jl = 1, jpl + WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) + END DO + + ! compute reciprocal of concentration + where( a_i(:,:,:) > epsi10 ) + z1_a_i(:,:,:) = 1.0_wp/a_i(:,:,:) + elsewhere + z1_a_i(:,:,:) = 0.0_wp + end where + + ! compute thickness before doing anything + h_i(:,:,:) = v_i(:,:,:) * z1_a_i(:,:,:) + + ! find which gridpoints are new ice gridpoints + incr_newice(:,:,:) = .false. + where (at_i(:,:) < zopenwater_lim .and. a_i_bkginc(:,:,nhi_damin) > epsi10) + incr_newice(:,:,nhi_damin) = .true. + end where + + ! add concentration increments and bound above zero + where (incr_newice) + a_i(:,:,:) = MAX(a_i(:,:,:) + a_i_bkginc(:,:,:) * zincwgt_remaining, 0.0_wp) + elsewhere + a_i(:,:,:) = MAX(a_i(:,:,:) + a_i_bkginc(:,:,:) * zincwgt, 0.0_wp) + end where + + ! ensure total sum of categories doesn't exceed rn_amax_2d + at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) + DO jl = 1, jpl + WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) + END DO + + !if (initial_step) then + select case(nh_iincr_min) + case (3) + ! compute heat balance that adds specified ice thickness + ! to open water + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' grow from open water' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + DO jl=1,jpl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + IF( incr_newice(ji,jj,jl) ) THEN + + a_i_bkginc(ji,jj,jl) = 0.0_wp + + ! Volume + h_i(ji,jj,jl) = zhi_damin + v_i(ji,jj,jl) = zhi_damin * a_i(ji,jj,jl) + + ! Salinity - suboptimal but readable code + SELECT CASE ( nn_icesal ) + CASE ( 1 ) ! Sice = constant + s_i(ji,jj,jl) = rn_icesal + CASE ( 2 ) ! Sice = F(z,t) [Vancoppenolle et al (2005)] + s_i(ji,jj,jl) = MIN( 4.606_wp + 0.91_wp / zhi_damin , rn_simax , 0.5_wp * sss_m(ji,jj) ) + CASE( 3 ) + s_i(ji,jj,jl) = zsice_multiyr + END SELECT + sv_i(ji,jj,jl) = s_i(ji,jj,jl) * v_i(ji,jj,jl) + + ! Internal sea-ice enthalpy - same in every layer, at freezing point + ztmp = rhoi * ( rcpi * ( (- rTmlt * s_i(ji,jj,jl)) - ( t_bo(ji,jj) - rt0 ) ) & + & + rLfus * ( 1.0_wp - (- rTmlt * s_i(ji,jj,jl)) / MIN( t_bo(ji,jj) - rt0, -epsi10 ) ) & + & - rcp * (- rTmlt * s_i(ji,jj,jl)) ) + e_i(ji,jj,:,jl) = ztmp * v_i(ji,jj,jl) * r1_nlay_i + + ! Snow + e_s(ji,jj,:,jl) = 0.0_wp + h_s(ji,jj,jl) = 0.0_wp + v_s(ji,jj,jl) = 0.0_wp + + ! Melt ponds + a_ip(ji,jj,jl) = 0.0_wp + h_ip(ji,jj,jl) = 0.0_wp + v_ip(ji,jj,jl) = 0.0_wp + + ! Melt pond lids + h_il(ji,jj,jl) = 0.0_wp + v_il(ji,jj,jl) = 0.0_wp + + ! Age + o_i(ji,jj,jl) = 0.0_wp + oa_i(ji,jj,jl) = 0.0_wp + + ELSE ! no new ice - ice update/disappears/nothing happens + + ! ztmp = a_i ratio post/pre DA if ice update + ! ztmp = 0 if ice disappears, or is just not there as per both the model and DA + ztmp = a_i(ji,jj,jl) * z1_a_i(ji,jj,jl) + + v_i(ji,jj,jl) = v_i(ji,jj,jl) * ztmp + DO jk = 1, nlay_i + e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ztmp + END DO + + v_s(ji,jj,jl) = v_s(ji,jj,jl) * ztmp + DO jk = 1, nlay_s + e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * ztmp + END DO + + sv_i (ji,jj,jl) = sv_i (ji,jj,jl) * ztmp + + a_ip (ji,jj,jl) = a_ip(ji,jj,jl) * ztmp + v_ip (ji,jj,jl) = v_ip(ji,jj,jl) * ztmp + v_il(ji,jj,jl) = v_il(ji,jj,jl) * ztmp + + !oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ztmp ! commented out as currently oa_i gets too large leading to FP overflow + + ENDIF ! newice or not + + END DO ! ji + END DO ! jj + END DO ! jl + + case default + CALL ctl_stop('Bad choice of nh_iincr_min') + end select + !initial_step = .false. + !end if ! initial_step + + END IF ! ln_a_iinc + + call ice_dyn_rest(1) ! reset all moments in ice advection scheme + call ice_var_salprof ! recompute sz_i salinity profile of ice through layers + call ice_thd_temp_2d ! set ice temperatures throughout the layers + + ENDIF ! add_increment + + + IF ( ln_asmiau .and. .not. ln_icedin ) THEN ! Incremental Analysis Updating + + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( seaice_bkginc ) + ENDIF + + ELSEIF ( ln_asmdin .or. ln_icedin ) THEN ! Direct Initialization + + IF ( kt == nitdin_r + 1 .and. .NOT. PRESENT(kindic) ) THEN + DEALLOCATE( seaice_bkginc ) + END IF + + END IF + + END SUBROUTINE seaice_asm_inc + + + !!====================================================================== +END MODULE asminc \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ASM/asmpar.F90 b/V4.0/nemo_sources/src/OCE/ASM/asmpar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8b8de1833e1f63f4365ccc771ddeb6e9934fafd4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ASM/asmpar.F90 @@ -0,0 +1,37 @@ +MODULE asmpar + !!====================================================================== + !! *** MODULE asmpar *** + !! Assimilation increment : Parameters for assimilation interface + !!====================================================================== + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + !! * Shared Modules variables + CHARACTER (LEN=40), PUBLIC, PARAMETER :: & + & c_asmbkg = 'assim_background_state_Jb', & !: Filename for storing the + !: background state for use + !: in the Jb term + & c_asmdin = 'assim_background_state_DI', & !: Filename for storing the + !: background state for direct + !: initialization + & c_asmtrj = 'assim_trj', & !: Filename for storing the + !: reference trajectory + & c_asminc = 'assim_background_increments' !: Filename for storing the + !: increments to the background + !: state + + INTEGER, PUBLIC :: nitbkg_r !: Background time step referenced to nit000 + INTEGER, PUBLIC :: nitdin_r !: Direct Initialization time step referenced to nit000 + INTEGER, PUBLIC :: nitiaustr_r !: IAU starting time step referenced to nit000 + INTEGER, PUBLIC :: nitiaufin_r !: IAU final time step referenced to nit000 + INTEGER, PUBLIC :: nittrjfrq !: Frequency of trajectory output for 4D-VAR + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asmpar.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE asmpar \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ASM/bias.F90 b/V4.0/nemo_sources/src/OCE/ASM/bias.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3ac2a17d475a7d3a7f054e0fa1374010bee9b95b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ASM/bias.F90 @@ -0,0 +1,941 @@ +MODULE bias + !! Is used by OPA and STEP + !!====================================================================== + !! *** Module bias *** + !! Code to estimate and apply bias correction. + !! The bias is in T/S and Pressure. It follows the generalized + !! bias algorithm presented in Balmaseda et al 2007. + !! + !! It can be read from a file offline, estimated online from relaxation + !! terms or from assimilation increments (this latter estimtd in inner loop) + !! + !! The parameters for the time evolution of the bias can be different + !! from the relaxation terms and for the assim increments. Only the + !! parameter for the relaxtion terms are considered here. + !! + !! The offline bias term can contain the seasonal cycle. + !! + !! The time evolution of the bias for relaxtion is estimated as followed + !! bias_rlx(t+1)=t_rlx_mem*bias_rlx(t)+t_rlx_upd*(t/s)trdmp. + !! + !! The total bias in T/S is partion between the correction to T/S only + !! (fb_t) and the correction applied to the pressure gradient (fb_p). + !! We impose that (fb_p=1.-fb_t). These factors can be different for the + !! different terms(fb_t_rxl,fb_t_asm,fb_t_ofl) + !! + !! (t/s)bias = fb_t_ofl * (t/s)bias_ofl + + !! fb_t_rlx * (t/s)bias_rlx + + !! fb_t_asm * (t/s)bias_asm + !! (t/s)bias_p =fb_p_ofl * (t/s)bias_ofl+ + !! fb_p_rlx * (t/s)bias_rlx_p + + !! fb_p_asm * (t/s)bias_asm_p + !! (t/s)bias is applied directely to correct T and S + !! (t/s)bias_p is used to compute rhd_pc and gru/v_pc + !! + !! Note: the above is an adhoc /simple way of making the partition + !! between bias in pressure and bias in T/S. It would be better + !! if the partition is done at the time of estimating the time + !! evolution of the bias. That would mean doubling the number of + !! 3D arrays. + !! + !! New addtion: (not in Balmaseda et al 2007): + !! A more physical alternative to the partition of the bias can be + !! done in terms of the inertial frequency: when the time scales of + !! adjustment are shorter that >1/f (Equator), the bias correction should + !! be in the the pressure term. Otherwise, it can act directly in T/S. + !! NOTE that the bias correction in the pressure term here (following + !! (Bell et al 2007) is just the "opposite" as the semi-prognostic method + !! in Greatbatch et al 2004. + !! The use of this partition is controlled by ln_inertial=.true. + !! + !! + !! 2009-03 (M.A. Balmaseda ECMWF) + !! + !! May 2022 (Hao Zuo) + !! Implement bias correction scheme in NEMOv40 + !! Add XIOS support + !! Update BC scheme in NEMOv4 + !! + !!====================================================================== + + !!---------------------------------------------------------------------- + !! bias_init : Read in the bias namelist and the bias arrays + !! tra_bias : Apply the bias fields on T/S directly + !! dyn_bias : Compute density correction for dynamic hpg + !! bias_opn : open bias files for restart capabilities + !! bias_wrt : write bias fies " " " + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY: & ! Precision variables + & wp + USE par_oce, ONLY: & ! ocean parameters + & jpi, & + & jpj, & + & jpk + USE dom_oce ! ocean space and time domain variables + USE phycst, ONLY: & ! physical constants + & rday, & + & rad , & + & grav + USE oce, ONLY: & ! ocean dynamics and tracers variables + & tsb, tsn, tsa, & + & rhop, rhd, & + & gtsu, gtsv, & + & rn2 + USE tradmp ! ocean: internal damping + USE dtatsd, ONLY: & ! data temperature and salinity + & ln_tsd_dmp + USE in_out_manager, ONLY: & ! I/O manager + & lwp, & + & numnam_cfg, & + & numnam_ref, & + & numout, & + & nit000, & + & cn_ocerst_outdir, & + & cn_ocerst_indir, & + & ln_rsttime, & + & ln_rstdate + USE restart, ONLY: & + & ln_writerst + USE iom + USE eosbn2 + USE zpshde ! partial step: hor. derivative (zps_hde routine) + USE biaspar + USE fldread ! read input fields + USE lbclnk ! lateral boundary conditions (or mpp link) + USE asmpar + USE asminc + USE lib_mpp, ONLY: & + & ctl_stop + USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC bias_init, & !: Read in the bias namelist and the bias arrays + & bias_upd, & !: Estimate bias on traces + & tra_bias, & !: Apply bias on traces + & dyn_bias, & !: " density correction for pressure gradient. + & bias_opn, & + & bias_wrt + + !! * Shared variables + !! * Private module variables + REAL(wp), PRIVATE :: & + & bias_time_unit_asm, & !: bias_asm units in s ( per day = 86400 s) + & bias_time_unit_rlx, & !: bias_rlx units in s ( 1 second) + & bias_time_unit_ofl, & !: bias_ofl units in s ( 1 second) + & t_rlx_mem, & !: time param for mem in bias_rlx model + & t_rlx_upd, & !: time param for update in bias_rlx model + !: (pct of incr for computation of bias) + & t_asm_mem, & !: time param for mem in bias_asm model + & t_asm_upd, & !: time param for update in bias_asm model + !: (pct of incr for computation of bias) + & fb_t_rlx, & !: parition of bias in T for rlx bias term + & fb_t_asm, & !: parition of bias in T for asm bias term + & fb_t_ofl, & !: parition of bias in T for ofl bias term + & fb_p_rlx, & !: parition of bias in P for rlx bias term + & fb_p_asm, & !: parition of bias in P for asm bias term + & fb_p_ofl, & !: parition of bias in P for ofl bias term + & fctamp, & !: amplification factor for T if inertial + & gphit0, & !: decay length for gaussian tappering + & capN2val !: value of N2 to where to cap Sbias + + LOGICAL, PRIVATE :: lalloc + REAL(wp), PRIVATE, DIMENSION(:,:,:), ALLOCATABLE :: & + & tbias_asm, & !: Temperature bias field + & sbias_asm, & !: Salinity bias field + & tbias_rlx, & !: Temperature bias field + & sbias_rlx !: Salinity bias field + + INTEGER, PRIVATE :: nn_inertial ! spatial partion of bias into + ! adiabatic/diabatic corrections + LOGICAL, PRIVATE :: ln_bsyncro ! syncronous or assincrous bias correction + + + REAL(wp), PRIVATE, DIMENSION(:,:), ALLOCATABLE :: fbcoef + + INTEGER, PRIVATE :: & + & numbias_asm, & ! netcdf id of bias file from assim + & numbias_tot ! netcdf id of bias file with total bias + + CHARACTER(LEN=128), PRIVATE :: & + & cn_bias_asm, & ! name of bias file from assim + & cn_bias_tot ! name of bias with total/rlx bias + + ! Structure of input T and S bias offline (file informations, fields read) + TYPE(FLD), PRIVATE, ALLOCATABLE, DIMENSION(:) :: sf_tbias_ofl + TYPE(FLD), PRIVATE, ALLOCATABLE, DIMENSION(:) :: sf_sbias_ofl + + TYPE(FLD_N), PRIVATE ::& ! information about the fields to be read + & sn_tbias_ofl, sn_sbias_ofl + INTEGER :: ios ! Local integer output status for namelist read + CHARACTER(LEN=40) :: err_msg + + REAL(wp) :: epsln = 1.0e-20_wp ! a small positive number + +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +CONTAINS + + SUBROUTINE bias_init + !!---------------------------------------------------------------------- + !! *** ROUTINE bias_init *** + !! + !! ** Purpose : Read in the bias namelist and read in the bias fields. + !! + !! ** Method : Read in the bias namelist and read in the bias fields. + !! + !! ** Action : + !! + !! History : + !! ! 08-05 (D. Lea) Initial version + !! ! 08-10 (M. Martin) Tidy + !! ! 09-03 (M. Balmaseda). Generalize to estimate the bias + !! from relax and offline bias term. + !! Introduce parameters to control the + !! model for the bias + !! (variables and time evolution) + !! ! 05-2022 (Hao Zuo) Tidy up and update for NEMOv40 + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Local declarations + + CHARACTER(len=100) :: cn_dir ! dir for location ofline bias + INTEGER :: ierror + REAL(wp) :: eft_rlx, & ! efolding time (bias memory) in days + & eft_asm, & ! " " + & log2, & + & minlat_bias, & !latitude, poleward of which the pressure bias begins to decay. + & maxlat_bias, & !latitude, poleward of which the pressure bias is zero. + & lenscl_bias !lengthscale of the pressure bias decay between minlat and maxlat. + + NAMELIST/nambias/ ln_bias, ln_bias_asm, ln_bias_rlx, ln_bias_ofl, & + & ln_bias_ts_app, ln_bias_pc_app, & + & fb_t_asm, fb_t_rlx, fb_t_ofl, fb_p_asm, fb_p_rlx, fb_p_ofl, & + & eft_rlx, t_rlx_upd, eft_asm, t_asm_upd, nn_inertial, & + & bias_time_unit_asm, bias_time_unit_rlx, bias_time_unit_ofl, & + & cn_bias_tot, cn_bias_asm, cn_dir, sn_tbias_ofl, sn_sbias_ofl, & + & ln_bsyncro, fctamp, lrst_biasr, gphit0, capN2val + + + !----------------------------------------------------------------------- + ! Read Namelist nam_bias : bias interface + !----------------------------------------------------------------------- + + ! Set default values + log2 = LOG( 2.0_wp ) + ln_bias = .FALSE. + ln_bias_asm = .FALSE. + ln_bias_rlx = .FALSE. + ln_bias_ofl = .FALSE. + ln_bias_ts_app = .FALSE. + ln_bias_pc_app = .FALSE. + + bias_time_unit_asm = 10.*86400.0_wp ! time unit for bias term in sec (default=per 10 days) + bias_time_unit_rlx = 1.0_wp ! same as rlx terms, i.e. seconds. + bias_time_unit_ofl = 1.0_wp ! same as ofl terms, i.e. seconds. + + eft_rlx = 365.0_wp !efolding time for bias estimation + eft_asm = 365.0_wp !efolding time for bias estimation + t_rlx_upd = 0.1_wp + t_asm_upd = 0.1_wp + fctamp = 1. + fb_t_rlx = 0.0_wp + fb_t_asm = 0.0_wp + fb_t_ofl = 1.0_wp + fb_p_rlx = 1.0_wp + fb_p_asm = 1.0_wp + fb_p_ofl = 0.0_wp + nn_inertial = 0 + ln_bsyncro = .FALSE. + gphit0 = 10. + capN2val = -1 !negative means no capping ; 1.e-12 is typical + + cn_bias_asm = "bias_asm.nc" + cn_bias_tot = "bias_tot.nc" + cn_dir = './' ! directory in which the model is executed + lrst_biasw = .FALSE. + lrst_biasr = .FALSE. + + !! ... default values from ref namelist + REWIND ( numnam_ref ) + READ ( numnam_ref, nambias, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambias in reference namelist' ) + + REWIND ( numnam_cfg ) + READ ( numnam_cfg, nambias, IOSTAT = ios, ERR = 902) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambias in configuration namelist' ) + IF(lwm) WRITE ( numond, nambias ) + + IF ( ( .NOT. ln_bias_asm ) .AND. ( .NOT. ln_bias_ofl ) .AND. ( .NOT. ln_bias_rlx ) ) THEN + ln_bias_ts_app = .FALSE. + ln_bias_pc_app = .FALSE. + ln_bias = .FALSE. + ENDIF + +! t_rlx_mem = 1. - log2 * rdt / (eft_rlx * rday) + t_rlx_mem = EXP( - log2 * rdt / ( eft_rlx * rday ) ) + t_asm_mem = EXP( - log2 * bias_time_unit_asm/ ( eft_asm * rday ) ) + + ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'bias_init : ' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist nambias : ' + + WRITE(numout,*) ' Bias switches/options/variables ' + WRITE(numout,*) ' bias main switch ln_bias = ',ln_bias + WRITE(numout,*) ' bias from assim ln_bias_asm = ',ln_bias_asm + WRITE(numout,*) ' bias from relax ln_bias_rlx = ',ln_bias_rlx + WRITE(numout,*) ' bias from offln ln_bias_ofl = ',ln_bias_ofl + WRITE(numout,*) ' bias T and S apply ln_bias_ts_app = ',ln_bias_ts_app + WRITE(numout,*) ' bias pressure correctn apply ln_bias_pc_app = ',ln_bias_pc_app + WRITE(numout,*) ' Parameters for parition of bias term ' + WRITE(numout,*) ' fb_t_rlx = ',fb_t_rlx + WRITE(numout,*) ' fb_t_asm = ',fb_t_asm + WRITE(numout,*) ' fb_t_ofl = ',fb_t_ofl + WRITE(numout,*) ' fb_p_rlx = ',fb_p_rlx + WRITE(numout,*) ' fb_p_asm = ',fb_p_asm + WRITE(numout,*) ' fb_p_ofl = ',fb_p_ofl + + WRITE(numout,*) ' Parameters for time evolution of bias ' + WRITE(numout,*) ' Rlx efolding time (mem) eft_rlx,t_rlx_mem = ', & + & eft_rlx, t_rlx_mem, 1. - log2 * rdt / (eft_rlx * rday) + WRITE(numout,*) ' uptdate factor t_rlx_upd = ',t_rlx_upd + WRITE(numout,*) ' Asm efolding time (mem) eft_asm,t_asm_mem = ', & + & eft_asm, t_asm_mem, 1. - log2 * rdt / (eft_asm * rday) + WRITE(numout,*) ' uptdate factor t_asm_upd = ',t_asm_upd + WRITE(numout,*) ' Filenames and input structures' + WRITE(numout,*) ' bias_tot filename cn_bias_to = ',cn_bias_tot + WRITE(numout,*) ' bias_asm filename cn_bias_asm = ',cn_bias_asm + WRITE(numout,*) ' bias_asm time unit (secs) bias_time_unit_asm = ',bias_time_unit_asm + WRITE(numout,*) ' structure Tem bias ofl sn_tbias_ofl = ',sn_tbias_ofl + WRITE(numout,*) ' structure Sal bias ofl sn_sbias_ofl = ',sn_sbias_ofl + WRITE(numout,*) ' Read bias at start of exp lrst_biasr = ',lrst_biasr + + IF ( ( (.NOT. ln_tsd_dmp) .OR. (.NOT. ln_tradmp) ) .AND. ln_bias_rlx ) & + & CALL ctl_stop (' lk_dtatem, lk_dtasal and lk_tradmp need to be true with ln_bias_rlx' ) + + ENDIF + IF( .NOT. ln_bias ) RETURN + + IF( .NOT. lalloc ) THEN + + ALLOCATE( bias_d(jpi,jpj,jpk,jpts) , & + & bias_p(jpi,jpj,jpk,jpts) , & + & rhd_pc(jpi,jpj,jpk) , & + & gru_pc(jpi,jpj) , & + & grv_pc(jpi,jpj) ) + + ALLOCATE( fbcoef(jpi,jpj) ) + + IF( ln_bias_asm ) ALLOCATE( tbias_asm(jpi,jpj,jpk), & + & sbias_asm(jpi,jpj,jpk) ) + + IF( ln_bias_rlx ) ALLOCATE( tbias_rlx(jpi,jpj,jpk), & + & sbias_rlx(jpi,jpj,jpk) ) + + lalloc = .TRUE. + + ENDIF + + IF( ln_bias_ofl ) THEN ! set sf_tbias_ofl and sf_sbias_ofl strctrs + ! + ! tbias + ! + ALLOCATE( sf_tbias_ofl(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'bias_init: unable to allocate sf_tbias_ofl structure' ) ; RETURN + ENDIF + ALLOCATE( sf_tbias_ofl(1)%fnow(jpi,jpj,jpk) ) + ALLOCATE( sf_tbias_ofl(1)%fdta(jpi,jpj,jpk,2) ) + + ! fill structure with values and control print + CALL fld_fill( sf_tbias_ofl, (/ sn_tbias_ofl /), cn_dir, 'bias_init', 'Offline T bias term ', 'nam_tbias_ofl' ) + ! + ! salinity bias + ! + ALLOCATE( sf_sbias_ofl(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'bias_init: unable to allocate sf_sbias_ofl structure' ) ; RETURN + ENDIF + ALLOCATE( sf_sbias_ofl(1)%fnow(jpi,jpj,jpk) ) + ALLOCATE( sf_sbias_ofl(1)%fdta(jpi,jpj,jpk,2) ) + + ! fill structure with values and control print + CALL fld_fill( sf_sbias_ofl, (/ sn_sbias_ofl /), cn_dir, 'bias_init', 'Offline S bias term ', 'nam_sbias_ofl' ) + + ENDIF + + ! Read total bias + IF ( ln_bias ) THEN + bias_d(:,:,:,:) = 0.0_wp + bias_p(:,:,:,:) = 0.0_wp + rhd_pc(:,:,:) = rhd(:,:,:) + gru_pc(:,:) = 0.0_wp + grv_pc(:,:) = 0.0_wp + IF ( ln_bias_rlx ) THEN + tbias_rlx(:,:,:) = 0.0_wp + sbias_rlx(:,:,:) = 0.0_wp + ENDIF + IF ( ln_bias_asm ) THEN !now rlx and asm bias in same file + tbias_asm(:,:,:) = 0.0_wp + sbias_asm(:,:,:) = 0.0_wp + ENDIF + numbias_tot = 0 + ! Get bias from file and prevent fail if the file does not exist + IF(lwp) WRITE(numout,*) 'Opening ',TRIM(cn_ocerst_indir)//'/'//TRIM( cn_bias_tot ) + CALL iom_open( TRIM(cn_ocerst_indir)//'/'//cn_bias_tot, numbias_tot, ldstop= lrst_biasr) + + IF ( numbias_tot > 0 ) THEN + ! Could check validity time of bias fields here... + ! Get the T and S bias data + IF(lwp) WRITE(numout,*) 'Reading bias fields from tot...' + + IF(lwp) WRITE(numout,*) 'Reading pressure bias from file ',cn_bias_tot + IF( iom_varid( numbias_tot, 'tbias_p', ldstop = .FALSE. ) > 0 ) THEN + ! Get the T and S bias data for pressur + CALL iom_get( numbias_tot, jpdom_autoglo, 'tbias_p', bias_p(:,:,:,jp_tem) ) + CALL iom_get( numbias_tot, jpdom_autoglo, 'sbias_p', bias_p(:,:,:,jp_sal) ) + CALL iom_get( numbias_tot, jpdom_autoglo, 'rhd_pc', rhd_pc ) + ELSE + CALL ctl_stop( 'Bias Pressure correction variables not found in ',cn_bias_tot ) + ENDIF + + !Search for bias from relaxation term if needed. Use same file + IF ( ln_bias_rlx ) THEN + IF(lwp) WRITE(numout,*) 'Reading bias fields for bias rlx from file ',cn_bias_tot + IF( iom_varid( numbias_tot, 'tbias_rlx', ldstop = .FALSE. ) > 0 ) THEN + ! Get the T and S bias data + CALL iom_get( numbias_tot, jpdom_autoglo, 'tbias_rlx', tbias_rlx ) + CALL iom_get( numbias_tot, jpdom_autoglo, 'sbias_rlx', sbias_rlx ) + ELSE + CALL ctl_stop( 'Bias relaxation variables not found in ',cn_bias_tot ) + ENDIF + ENDIF + + + !Search for bias from assim term if needed. Use same file + IF ( ln_bias_asm .and. .not.ln_bsyncro ) THEN + IF(lwp) WRITE(numout,*) 'Reading a-syncro bias fields for bias asm from file ',cn_bias_tot + IF( iom_varid( numbias_tot, 'tbias_asm', ldstop = .FALSE. ) > 0 ) THEN + ! Get the T and S bias data + CALL iom_get( numbias_tot, jpdom_autoglo, 'tbias_asm', tbias_asm ) + CALL iom_get( numbias_tot, jpdom_autoglo, 'sbias_asm', sbias_asm ) + ELSE + CALL ctl_stop( 'Bias assim variables not found in ',cn_bias_tot ) + ENDIF + ENDIF + + ! Close the file + CALL iom_close(numbias_tot) + + ELSE + IF(lwp) WRITE(numout,*) 'No bias file found so T and S bias fields are set to zero' + ENDIF + + ENDIF + + ! for the time being, the bias_asm is read in the same file from bias_tot + ! Following code should never be used + ! + ! Implications: bias_asm is estimated/evolved in time in the second outer + ! loop only, when the assimilation increments are ready. + ! bias_asm is kept constant during the first outer loop. + ! => Assyncronous bias correction. + ! Alternative: Syncronous bias correction: + ! bias_asm estimated/evolved in the first outer loop + ! with the asm incrments of the previous cycle. + ! bias_asm kept cte during the second outer loop. + ! Implication: bias_asm should be estimated really in the + ! inner loop. + IF ( ln_bsyncro ) THEN ! ln_bsyncro default = False, not defined via namelist input at moment + ! Read bias from assimilation from a separate file + IF ( ln_bias_asm ) THEN + tbias_asm(:,:,:) = 0.0_wp + sbias_asm(:,:,:) = 0.0_wp + numbias_asm = 0 + ! Get bias from file and prevent fail if the file does not exist + IF(lwp) WRITE(numout,*) 'Opening file for syncro assim bias ',TRIM( cn_bias_asm ) + CALL iom_open( cn_bias_asm, numbias_asm, ldstop=.FALSE. ) + + IF ( numbias_asm > 0 ) THEN + ! Could check validity time of bias fields here... + + ! Get the T and S bias data + IF(lwp) WRITE(numout,*) 'Reading syncro bias fields from asm from file ',cn_bias_asm + CALL iom_get( numbias_asm, jpdom_autoglo, 'tbias_asm', tbias_asm ) + CALL iom_get( numbias_asm, jpdom_autoglo, 'sbias_asm', sbias_asm ) + +! this is only applicable if tbias_asm were to be calculated in the inner loop + tbias_asm(:,:,:) = tbias_asm(:,:,:) * rdt / bias_time_unit_asm + sbias_asm(:,:,:) = sbias_asm(:,:,:) * rdt / bias_time_unit_asm + + ! Close the file + CALL iom_close(numbias_asm) + + ELSE + IF(lwp) WRITE(numout,*) 'No bias file found from asm so T and S bias fields are set to zero' + ENDIF + + ENDIF + + ENDIF + + !latitudinal dependence of partition coeficients. Adhoc + ! nn_inertial=0 no latitudinal dependence + ! nn_inertial=1 sin *2 + ! nn_inertial=2 for gaussian confinement (beta plane) + ! nn_inertial=3 for exponential minlat-maxlat (MetOffice) + SELECT CASE (nn_inertial) + CASE (0) + fbcoef(:,:) = 0.0_wp + fctamp = 0.0_wp + CASE (1) + fbcoef(:,:) = SIN( rad * gphit(:,:) )**2 !increases with latitude + CASE (2) + fbcoef(:,:) = ( 1. - exp (-( gphit(:,:)/gphit0 )**2) ) + CASE (3) + !!! FOAM parameterisation for latitudinal dependence. + !!! This should be added as a different namelist option later. MM. 08/2011. + minlat_bias = 10._wp + maxlat_bias = 23._wp + lenscl_bias = ( maxlat_bias - minlat_bias )*2._wp + WHERE ( abs( gphit(:,:) ) <= minlat_bias ) + fbcoef(:,:) = 0._wp + ELSEWHERE ( abs( gphit(:,:) ) >= maxlat_bias ) + fbcoef(:,:) = 1._wp + ELSEWHERE + fbcoef(:,:) = 1._wp - exp( -( abs( gphit(:,:) ) - minlat_bias ) & + * ( abs( gphit(:,:) ) - minlat_bias ) / lenscl_bias ) + ENDWHERE + CASE default + CALL ctl_stop(' bias_init: wrong option for nn_inertial ') + END SELECT + + END SUBROUTINE bias_init + + SUBROUTINE bias_upd ( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bias_upd *** + !! + !! ** Purpose : Update bias field every time step + !! + !! ** Method : add contributions to bias from 3 terms + !! + !! ** Action : Bias from assimilation (read in bias_init) + !! Bias from relaxation term is estimated according to + !! the prescribed time evolution of the bias + !! Bias from ofl term is read from external file + !! The difference contributions are added and the partition + !! into direct bias in T/S and pressure perfomed. + !! + !! History : 09-03 (M. Balmaseda) + !! Updated : 13-08 (M. Balmaseda) + !! : 05-2022 (Hao Zuo) update for NEMOv40 + !!---------------------------------------------------------------------- + !! called every timestep after dta_sst if ln_bias true. + + IMPLICIT NONE + + !! * Arguments + INTEGER, INTENT(IN) :: kt ! ocean time-step index + !! * Local variables + INTEGER :: ji,jj,jk, it ! local loop index + INTEGER :: icounter + REAL(wp) :: tsclf ! time saling factor + REAL(wp) :: fb_t_asm_max, fb_t_rlx_max, fb_t_ofl_max + REAL(wp), DIMENSION(jpi,jpj) :: zcof1, zcof2 + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: zwsa,zwsb + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zws, zalpbet + REAL(wp) :: deltan2, dtk, dsmin + + IF ( .NOT. ln_bias ) RETURN + fb_t_rlx_max = MIN(fb_t_rlx*fctamp,1.0_wp) + fb_t_asm_max = MIN(fb_t_asm*fctamp,1.0_wp) + fb_t_ofl_max = MIN(fb_t_ofl*fctamp,1.0_wp) + + bias_d(:,:,:,:) = 0.0_wp + bias_p(:,:,:,:) = 0.0_wp + IF ( ln_bias_asm ) THEN + tsclf = 1 + IF ( .NOT.ln_bsyncro ) tsclf = rdt / bias_time_unit_asm + zcof1(:,:) = tsclf * ( ( 1.0_wp - fbcoef(:,:) ) * fb_t_asm + & + & fbcoef(:,:) * fb_t_asm_max ) + zcof2(:,:) = ( 1.0_wp - fbcoef(:,:) ) * fb_p_asm + DO jk = 1, jpkm1 + bias_d(:,:,jk,jp_tem) = bias_d(:,:,jk,jp_tem) + & + & tbias_asm(:,:,jk) * zcof1(:,:) + bias_d(:,:,jk,jp_sal) = bias_d(:,:,jk,jp_sal) + & + & sbias_asm(:,:,jk) * zcof1(:,:) + bias_p(:,:,jk,jp_tem) = bias_p(:,:,jk,jp_tem) + & + & tbias_asm(:,:,jk) * zcof2(:,:) + bias_p(:,:,jk,jp_sal) = bias_p(:,:,jk,jp_sal) + & + & sbias_asm(:,:,jk) * zcof2(:,:) + END DO + IF( lk_asminc .and. ln_trainc .and. .not.ln_bsyncro ) THEN + ! if last outer loop (lk_asminc=true and ln_trainc=true). t/sbias_asm + ! is updated, only once (end of run) taking into account units. + IF ( (kt == nitend) .and. lrst_biasw) THEN + IF(lwp) WRITE(numout,*)' estimating asm bias at last timestep: ',kt + DO jk = 1, jpkm1 + tbias_asm(:,:,jk) = t_asm_mem * tbias_asm(:,:,jk) + & + & t_asm_upd * t_bkginc(:,:,jk) * tmask(:,:,jk) + sbias_asm(:,:,jk) = t_asm_mem * sbias_asm(:,:,jk) + & + & t_asm_upd * s_bkginc(:,:,jk) * tmask(:,:,jk) + END DO + ENDIF + ENDIF + ENDIF + + +#if defined key_tradmp + ! Time evolution of bias from relaxation + ! WATCH OUT! ttrdmp needs to be defined + ! this means that bias_upd can only be called after the tracer dumping + IF ( ln_bias_rlx ) THEN + tbias_rlx(:,:,:) = t_rlx_mem * tbias_rlx(:,:,:) + & + & t_rlx_upd * ttrdmp(:,:,:) * rdt + sbias_rlx(:,:,:) = t_rlx_mem * sbias_rlx(:,:,:) + & + & t_rlx_upd * strdmp(:,:,:) * rdt + zcof1(:,:) = ( 1.0_wp - fbcoef(:,:) ) * fb_t_rlx + & + & fbcoef(:,:) * fb_t_rlx_max + zcof2(:,:) = ( 1.0_wp - fbcoef(:,:) ) * fb_p_rlx + DO jk = 1, jpkm1 + bias_d(:,:,jk,jp_tem) = bias_d(:,:,jk,jp_tem) + & + & tbias_rlx(:,:,jk) * zcof1(:,:) + bias_d(:,:,jk,jp_sal) = bias_d(:,:,jk,jp_sal) + & + & sbias_rlx(:,:,jk) * zcof1(:,:) + bias_p(:,:,jk,jp_tem) = bias_p(:,:,jk,jp_tem) + & + & tbias_rlx(:,:,jk) * zcof2(:,:) + bias_p(:,:,jk,jp_sal) = bias_p(:,:,jk,jp_sal) + & + & sbias_rlx(:,:,jk) * zcof2(:,:) + ENDDO + ENDIF +#else + IF ( ln_bias_rlx ) THEN + CALL ctl_stop(' bias_upd: bias_rlx needs key_tradmp ') + ENDIF +#endif + ! offline bias + IF ( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) ' tra_bias: ln_bias_ofl = ',ln_bias_ofl + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~' + ENDIF + IF ( ln_bias_ofl ) THEN + IF(lwp) WRITE(numout,*) 'reading offline bias' + CALL fld_read( kt, 1, sf_tbias_ofl ) + CALL fld_read( kt, 1, sf_sbias_ofl ) + + zcof1(:,:) = ( 1.0_wp - fbcoef(:,:) ) * fb_t_ofl + & + & fbcoef(:,:) * fb_t_ofl_max + zcof2(:,:) = ( 1.0_wp - fbcoef(:,:) ) * fb_p_ofl + DO jk = 1, jpkm1 + bias_d(:,:,jk,jp_tem) = bias_d(:,:,jk,jp_tem) + & + & sf_tbias_ofl(1)%fnow(:,:,jk) * zcof1(:,:) + bias_d(:,:,jk,jp_sal) = bias_d(:,:,jk,jp_sal) + & + & sf_sbias_ofl(1)%fnow(:,:,jk) * zcof1(:,:) + bias_p(:,:,jk,jp_tem) = bias_p(:,:,jk,jp_tem) + & + & sf_tbias_ofl(1)%fnow(:,:,jk) * zcof2(:,:) + bias_p(:,:,jk,jp_sal) = bias_p(:,:,jk,jp_sal) + & + & sf_sbias_ofl(1)%fnow(:,:,jk) * zcof2(:,:) + ENDDO + ENDIF + +! mask direct bias terms + DO jk = 1, jpkm1 + bias_d(:,:,jk,jp_tem) = bias_d(:,:,jk,jp_tem) * tmask (:,:,jk) + bias_d(:,:,jk,jp_sal) = bias_d(:,:,jk,jp_sal) * tmask (:,:,jk) + END DO + + ! cap values of bias_S to prevent static instability + ! If current rn2 is close to static instability (capN2val) then + ! the bias in salinity is such that the incremental N2 (deltaN2) due to direct T/S bias corr + ! must be >= deltaN2min, where deltaN2min=0. This is achieved by imposing a cap to the salinity bias vertical gradient + ! dBs/dk=Bs(k-1)-Bs(k) ; dBt/dk = Bt(k-1)-Bt(k) + ! incremental deltaN2 = grav*beta/dz*[alpha/beta(Bt(k-1) - Bt(k)) - (Bs(k-1) -Bs(k))] + ! alpha = thermal expansion coefficient + ! beta = haline contraction coefficient + ! We impose that inc deltaN2 >= deltaN2min. Therefore + ! dsmin = Bs(k-1)+deltaN2min*dz/(beta*grav) - (alpha/beta)(Bt(k-1)-Bt(k)) + ! Bs(k) = max( Bs(k), dsmin ) + ! + ! Update for NEMOv40: + ! i) use tsn instead of tsb to compute alpha and beta ratio + ! ii) use new eos_rab function + ! iii) to do: introduce fraction variable (-0.2 hardcoded) for deltaN2min when rn2 > capN2val + ! + ! Warning!!! + ! eos function changed in NEMOv40, capN2val function is not working at moment + IF ( capN2val > 0. ) THEN + ALLOCATE( zws(jpi,jpj,2), zalpbet(jpi,jpj,2), zwsa(jpi,jpj), zwsb(jpi,jpj) ) + + DO jk = 2, jpkm1 + icounter=0 + zws(:,:,jp_tem) = 0.5*(tsn(:,:,jk,jp_tem) + tsn(:,:,jk-1,jp_tem) ) + zws(:,:,jp_sal) = 0.5*(tsn(:,:,jk,jp_sal) + tsn(:,:,jk-1,jp_sal) ) + CALL eos_rab( zws, gdepw_n(:,:,jk), zalpbet ) ! new EOS function in NEMOv40 + ! fsdepw replaced by gdepw_n + + !!eos_rab function changed in NEMOv40, code below may be incorrect + zwsa(:,:) = zalpbet(:,:,jp_tem)/(zalpbet(:,:,jp_sal)+epsln) ! zwsa is alpha/beta + zwsb(:,:) = zalpbet(:,:,jp_sal)+epsln ! zwsb is beta (add epsln to ensure beta > 0) + !! + + DO jj = 1, jpj + DO ji = 1, jpi + IF (rn2(ji,jj,jk) > capN2val ) THEN ! if current N2 > threshold N2 + deltan2=-0.2*rn2(ji,jj,jk) ! min(deltaN2) = 20% of current N2 + ! BC introdued N2 change can be negative but not exceed -20% + ELSE ! if water column is close to unstable + deltan2=0. ! min(deltaN2) = 0 + ! BC introduced N2 change can not be negative (positive change is allowed) + + ENDIF + dtk = bias_d(ji,jj,jk-1,jp_tem) - bias_d(ji,jj,jk,jp_tem) + + dsmin = ( bias_d(ji,jj,jk-1,jp_sal) - & + & zwsa(ji,jj) * dtk + & + & deltan2 * e3w_n(ji,jj,jk) /(zwsb(ji,jj)*grav) & + & ) * tmask(ji,jj,jk) + + + if (dsmin > bias_d(ji,jj,jk,jp_sal) ) then + icounter= icounter + 1 + !!debug + !if ( MOD( icounter, 1000 ) == 0 .AND. jk == 2 ) then + ! if (lwp) WRITE(numout,*) 'applying instability criteria: ',ji,jj,jk, dsmin, bias_d(ji,jj,jk,jp_sal), rn2(ji,jj,jk), capN2val + !endif + endif + bias_d(ji,jj,jk,jp_sal) = max (bias_d(ji,jj,jk,jp_sal), dsmin) + ENDDO + ENDDO + if (lwp) WRITE(numout,*)'Level k ', jk,' Number of capped Sbias values ',icounter + ENDDO + DEALLOCATE(zws, zalpbet, zwsa, zwsb) + ENDIF + + END SUBROUTINE bias_upd + + + SUBROUTINE tra_bias (kt) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bias *** + !! + !! ** Purpose : Apply bias to tracers tendencies + !! + !! + !! History : 13-08 (M. Balmaseda) + !! 05-2022 (H. Zuo) add xios output support + !!---------------------------------------------------------------------- + !! called every timestep after dta_sst if ln_bias true. + IMPLICIT NONE + !! * Arguments + INTEGER, INTENT(IN) :: kt ! ocean time-step index + + !apply bias on tracers if needed + IF ( ln_bias_ts_app ) THEN + ! Add the bias directely to T/s + tsa(:,:,:,jp_tem) = tsa(:,:,:,jp_tem) + & + & tmask(:,:,:) * bias_d(:,:,:,jp_tem) / rdt + tsa(:,:,:,jp_sal) = tsa(:,:,:,jp_sal) + & + & tmask(:,:,:) * bias_d(:,:,:,jp_sal) / rdt + + ! + ! XIOS output + ! + IF( iom_use('votbiasd') ) THEN + CALL lbc_lnk( 'tra_bias', bias_d(:,:,:,jp_tem), 'T', 1.0_wp ) + CALL iom_put( 'votbiasd', bias_d(:,:,:,jp_tem) ) + ENDIF + IF( iom_use('vosbiasd') ) THEN + CALL lbc_lnk( 'tra_bias', bias_d(:,:,:,jp_sal), 'T', 1.0_wp ) + CALL iom_put( 'vosbiasd', bias_d(:,:,:,jp_sal) ) + ENDIF + ! + + ! lateral boundary conditions (is this needed?) + !CALL lbc_lnk( 'tra_bias', tsa(:,:,:,jp_tem), 'T', 1.0_wp ) + !CALL lbc_lnk( 'tra_bias', tsa(:,:,:,jp_sal), 'T', 1.0_wp ) + + ENDIF + + END SUBROUTINE tra_bias + + SUBROUTINE dyn_bias( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_bias *** + !! + !! ** Purpose : Computes rhd_pc, gru/v_pc bias corrected + !! for hydrostatic pressure gradient + !! depending on time step (semi-implicit/centered) + !! If partial steps computes bottom pressure gradient. + !! These correction terms will affect only the dynamical + !! component (pressure gradient calculation), but not + !! the isopycnal calculation for the lateral mixing. + !! + !! ** Method : At this stage of the computation, ta and sa are the + !! after temperature and salinity. If semi-implicit, these + !! are used to compute rho and bottom pressure gradient. + !! If centered, tb,sb are used instead. + !! + !! ** Update : 16 May 2022 (Hao Zuo) + !! i) NEMOv4 uses leapfrog scheme for advection/pressure gradient + !! we only use tsn to compute bias corrected density and + !! hydrostatic bottom pressure gradients + !! + !! ii) Beware that NEMOv4 has changed the order of updating t/s/u/v tendency in steps + !! + !! + !! ** Action : - rhd_pc ready. rhop will be overwriten later + !! - if ln_zps, bottom density gradients gru/v_pc ready. + !!---------------------------------------------------------------------- + !! + !! * Arguments + INTEGER, INTENT(IN) :: kt ! ocean time-step index + !! * Local variables + REAL(wp) :: tsw(jpi,jpj,jpk,jpts) + !! + !!---------------------------------------------------------------------- + ! + ! gtu,gsu,gtv,gsv rhop will be overwritten later in step. + ! + tsw(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) - bias_p(:,:,:,jp_tem) + tsw(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) - bias_p(:,:,:,jp_sal) + + CALL eos( CASTDP(tsw), rhd_pc, rhop, CASTDP(gdepw_n(:,:,:)) ) + + ! is this needed? + !CALL lbc_lnk( rhd_pc, 'T', 1.0_wp ) + + ! + ! XIOS output + ! + IF( iom_use('votbiasp') ) THEN + CALL lbc_lnk( 'dyn_bias', bias_p(:,:,:,jp_tem), 'T', 1.0_wp ) + CALL iom_put( 'votbiasp', bias_p(:,:,:,jp_tem) ) + ENDIF + IF( iom_use('vosbiasp') ) THEN + CALL lbc_lnk( 'dyn_bias', bias_p(:,:,:,jp_sal), 'T', 1.0_wp ) + CALL iom_put( 'vosbiasp', bias_p(:,:,:,jp_sal) ) + ENDIF + ! + + ! Partial steps: now horizontal gradient of t,s,rd + ! at the bottom ocean level + IF( ln_zps ) THEN + CALL zps_hde( kt, jpts, CASTDP(tsw), gtsu, gtsv, & + & rhd_pc, gru_pc , grv_pc ) + ENDIF + + END SUBROUTINE dyn_bias + + SUBROUTINE bias_opn( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE bias_opn *** + !! + !! ** Purpose : open bias restart file following the same logic as the + !! standard restarts. + !! update : + !! May 2022, updated for NEMOV40 by Hao Zuo + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kt ! ocean time-step + !! * Local variables + CHARACTER(LEN=20) :: clbkt ! ocean time-step deine as a character + CHARACTER(LEN=80) :: clbias_tot ! total bias restart file name + CHARACTER(lc) :: clbiaspath ! full path to bias restart file + CHARACTER(LEN=256) :: clbiasinfo ! info character + INTEGER :: inyear, inmonth, inday, inhour, inmin, insec + REAL(wp) :: zjul, znsec + !!---------------------------------------------------------------------- + ! + IF( ( kt == nitend ) .AND. .NOT.lrst_biasw .AND. ln_writerst ) THEN ! create bias file + IF (ln_rsttime) THEN + inyear = ndate0 / 10000 + inmonth = ( ndate0 - (inyear * 10000) ) / 100 + inday = ndate0 - (inyear * 10000) - ( inmonth * 100 ) + CALL ymds2ju( inyear, inmonth, inday, 0.0_wp, zjul ) + zjul = zjul + kt * rn_rdt / 86400.0_wp + CALL ju2ymds( zjul, inyear, inmonth, inday, znsec ) + inhour = INT( znsec / 3600_wp ) + inmin = INT( ( znsec - inhour * 3600_wp ) / 60.0_wp ) + insec = INT( znsec - inhour * 3600_wp - inmin * 60.0_wp ) + WRITE(clbkt,'(I4.4,I2.2,I2.2,A,3I2.2)') inyear, inmonth, inday, & + & '_', inhour, inmin, insec + ELSE + IF( nitend > 999999999 ) THEN ; WRITE(clbkt, * ) kt + ELSE ; WRITE(clbkt, '(i8.8)') kt + ENDIF + ENDIF + clbias_tot = TRIM(cexper)//"_"//TRIM(ADJUSTL(clbkt))//"_"//TRIM(cn_bias_tot) + clbiaspath = TRIM(cn_ocerst_outdir) + IF( clbiaspath(LEN_TRIM(clbiaspath):) /= '/' ) clbiaspath = TRIM(clbiaspath) // '/' + IF(lwp) THEN + WRITE(numout,*) + IF(.NOT.lrxios) THEN + WRITE(numout,*) ' open tot bias restart NetCDF file: '//clbias_tot + ENDIF + ENDIF + IF(.NOT.lrxios) THEN + CALL iom_open( TRIM(clbiaspath)//clbias_tot, numbias_tot , ldwrt = .TRUE. ) + ELSE !! not coded for xios read + clbiasinfo = 'Can not use XIOS in bias restart file yet' + CALL ctl_stop(TRIM(clbiasinfo)) + ENDIF + lrst_biasw=.TRUE. + ENDIF + ! + END SUBROUTINE bias_opn + + SUBROUTINE bias_wrt( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE bias_wrt *** + !! + !! ** Purpose : Write bias restart fields in NetCDF format + !! + !! ** Method : Write in numbias_tot when kt == nitend (or nitrst) + !! in output file, save fields which are necessary for + !! restart. + !! + !! ** update : + !! May 2022, updated for NEMOV40 by Hao Zuo + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kt ! ocean time-step + !!---------------------------------------------------------------------- + ! ! the begining of the run [s] + IF(lwxios) CALL iom_swap( cwxios_context ) + IF ( ln_bias_rlx ) THEN + CALL iom_rstput( kt, kt, numbias_tot, 'tbias_rlx' , tbias_rlx, ldxios = lwxios ) + CALL iom_rstput( kt, kt, numbias_tot, 'sbias_rlx' , sbias_rlx, ldxios = lwxios ) + ENDIF + + IF ( ln_bias_asm ) THEN + CALL iom_rstput( kt, kt, numbias_tot, 'tbias_asm' , tbias_asm, ldxios = lwxios ) + CALL iom_rstput( kt, kt, numbias_tot, 'sbias_asm' , sbias_asm, ldxios = lwxios ) + ENDIF + + !CALL iom_rstput( kt, kt, numbias_tot, 'tbias_d' , bias_d(:,:,:,jp_tem), ldxios = lwxios ) + !CALL iom_rstput( kt, kt, numbias_tot, 'sbias_d' , bias_d(:,:,:,jp_sal), ldxios = lwxios ) + CALL iom_rstput( kt, kt, numbias_tot, 'tbias_p' , bias_p(:,:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, kt, numbias_tot, 'sbias_p' , bias_p(:,:,:,jp_sal), ldxios = lwxios ) + CALL iom_rstput( kt, kt, numbias_tot, 'rhd_pc' , rhd_pc, ldxios = lwxios ) + + IF(lwxios) CALL iom_swap( cxios_context ) + + IF(.NOT.lwxios) THEN + CALL iom_close( numbias_tot ) ! close the restart file (only at last time step) + ELSE + CALL iom_context_finalize( cwxios_context ) + ENDIF + + lrst_biasw = .FALSE. + ! + END SUBROUTINE bias_wrt + +END MODULE bias \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ASM/biaspar.F90 b/V4.0/nemo_sources/src/OCE/ASM/biaspar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..99d58ae0f1abc0dc840c111fcfafaaa9843203f6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ASM/biaspar.F90 @@ -0,0 +1,49 @@ +MODULE biaspar + !! Variables relevant to bias module + !!====================================================================== + !! *** Module biaspar *** + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY: & + & wp, dp + USE par_oce, ONLY: & + & jpi, & + & jpj, & + & jpk, & + & jpts,& + & jp_tem, jp_sal + + IMPLICIT NONE + PUBLIC + + !! * Shared module variables + LOGICAL, PUBLIC :: & + & ln_bias, & !: estimate (apply) bias arrays + & ln_bias_asm , & !: estimate bias from assim incr + & ln_bias_rlx , & !: estimate bias from relaxation + & ln_bias_ofl , & !: bias estimated offline + & ln_bias_ts_app, & !: apply T and S bias + & ln_bias_pc_app, & !: apply bias through the pres crtn. + & lrst_biasw , & !: flag for WRITING bias restart files + & lrst_biasr !: flag to enforce READING bias restart files + + + + + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: & + & bias_d, & !: T/S bias field for direct correction + & bias_p !: T/S " " P correction + + REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: rhd_pc + + + + + REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: gru_pc, grv_pc + + + + + + +END MODULE biaspar diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdy_oce.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdy_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7f1d91111e3f30b30ad275bd200f6c6c234f83a9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdy_oce.F90 @@ -0,0 +1,173 @@ +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: bdy_oce.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION bdy_oce_alloc() + !!---------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop, mpp_sum + ! + INTEGER :: bdy_oce_alloc + !!---------------------------------------------------------------------- + ! + ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj), & + & STAT=bdy_oce_alloc ) + ! + ! Initialize masks + bdytmask(:,:) = 1._wp + bdyumask(:,:) = 1._wp + bdyvmask(:,:) = 1._wp + ! + CALL mpp_sum ( 'bdy_oce', bdy_oce_alloc ) + IF( bdy_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'bdy_oce_alloc: failed to allocate arrays.' ) + ! + END FUNCTION bdy_oce_alloc + + !!====================================================================== +END MODULE bdy_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdydta.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdydta.F90 new file mode 100644 index 0000000000000000000000000000000000000000..65e519091716bb9dae2c631d9a817b591484f65f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdydta.F90 @@ -0,0 +1,719 @@ +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: bdydta.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 + 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 .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is used only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) + END DO + ENDIF + +#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( ASSOCIATED(dta_bdy(jbdy)%ssh) ) dta_bdy_s(jbdy)%ssh(:) = dta_bdy(jbdy)%ssh(:) + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) dta_bdy_s(jbdy)%u2d(:) = dta_bdy(jbdy)%u2d(:) + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) dta_bdy_s(jbdy)%v2d(:) = dta_bdy(jbdy)%v2d(:) + ENDIF + END DO + ELSE ! Add tides if not split-explicit free surface else this is done in ts loop + ! + CALL bdy_dta_tides( kt=kt, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdydyn.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdydyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1972f4ece88e9a4a89048319a8cc5ec8b03e78de --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdydyn.F90 @@ -0,0 +1,123 @@ +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: bdydyn.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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, CASTSP(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdydyn2d.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdydyn2d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..99a6e212873a9cf997bc70e33239b57486ac7e7b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdydyn2d.F90 @@ -0,0 +1,338 @@ +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: bdydyn2d.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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 + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pvb2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phur + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: phvr + REAL(dp), 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.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + ! + END DO ! ir + ! + END SUBROUTINE bdy_dyn2d + + SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_frs *** + !! + !! ** Purpose : - Apply the Flow Relaxation Scheme for barotropic velocities + !! at open boundaries. + !! + !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in + !! a three-dimensional baroclinic ocean model with realistic + !! topography. Tellus, 365-382. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + !! + INTEGER :: jb ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1) + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) + END DO + ! + END SUBROUTINE bdy_dyn2d_frs + + + SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_fla *** + !! + !! - Apply Flather boundary conditions on normal barotropic velocities + !! + !! ** WARNINGS about FLATHER implementation: + !!1. According to Palma and Matano, 1998 "after ssh" is used. + !! In ROMS and POM implementations, it is "now ssh". In the current + !! implementation (tested only in the EEL-R5 conf.), both cases were unstable. + !! So I use "before ssh" in the following. + !! + !!2. We assume that the normal ssh gradient at the bdy is zero. As a matter of + !! fact, the model ssh just inside the dynamical boundary is used (the outside + !! ssh in the code is not updated). + !! + !! References: Flather, R. A., 1976: A tidal model of the northwest European + !! continental shelf. Mem. Soc. R. Sci. Liege, Ser. 6,10, 141-164. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phur + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, 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 + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: 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, CASTSP(pvb2d), pva2d, dta%v2d, llrim0, ll_npo ) + ! + END SUBROUTINE bdy_dyn2d_orlanski + + + SUBROUTINE bdy_ssh( zssh ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_ssh *** + !! + !! ** Purpose : Duplicate sea level across open boundaries + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn + !! + INTEGER :: ib_bdy, ir ! bdy index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(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.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO + ! + END SUBROUTINE bdy_ssh + + !!====================================================================== +END MODULE bdydyn2d \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdydyn3d.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdydyn3d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..13e4a6f3508e1641f5eba48b8c48d7c31d004fcd --- /dev/null +++ b/V4.0/nemo_sources/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: bdydyn3d.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', va, 'V', -1.0_wp, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdyice.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdyice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fe67068247ed216bac6c5a20fe1ec55277a5765f --- /dev/null +++ b/V4.0/nemo_sources/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: bdyice.F90 13589 2020-10-14 13:35:49Z clem $ + !! 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.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp & + & , s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp, v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp & + & , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, v_il, 'T', 1.0_wp & + & , 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.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, 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.0_wp, 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.0_wp, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdyini.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdyini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..25381af8e90aa223c99cdf9858587068c4f35fef --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdyini.F90 @@ -0,0 +1,1793 @@ +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: bdyini.F90 12142 2019-12-10 11:50:13Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_init + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields with + !! unstructured open boundaries. + !! + !! ** Method : Read initialization arrays (mask, indices) to identify + !! an unstructured open boundary + !! + !! ** Input : bdy_init.nc, input file for unstructured open boundaries + !!---------------------------------------------------------------------- + NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + ! + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + + ! ------------------------ + ! Read namelist parameters + ! ------------------------ + 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) = (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.0_wp ) + + ! 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.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond. + + ! bdy masks are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 + + ! ------------------------------------ + ! handle rim1, do as if rim 0 was land + ! ------------------------------------ + + ! z[tuv]mask are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + ! Recompute zfmask + DO 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.0_wp ) + + ! bdy masks are now set to zero on rim1 points: + DO ib_bdy = 1, nb_bdy + DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 + ! + ! Check which boundaries might need communication + ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,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.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) + END DO + 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.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) + END DO + 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.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) + END DO + END DO + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdylib.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdylib.F90 new file mode 100644 index 0000000000000000000000000000000000000000..96f3c863a633bfed5a18cad01dcbf4c840488349 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdylib.F90 @@ -0,0 +1,528 @@ +MODULE bdylib + !!====================================================================== + !! *** MODULE bdylib *** + !! Unstructured Open Boundary Cond. : Library module of generic boundary algorithms. + !!====================================================================== + !! History : 3.6 ! 2013 (D. Storkey) original code + !! 4.0 ! 2014 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! bdy_orlanski_2d + !! bdy_orlanski_3d + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE phycst ! physical constants + USE bdyini + ! + USE in_out_manager ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp, ONLY: ctl_stop + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_frs, bdy_spe, bdy_nmn, bdy_orl + PUBLIC bdy_orlanski_2d + PUBLIC bdy_orlanski_3d + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdylib.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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(dp), 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(dp), 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptb ! before tracer field + REAL(dp), 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, CASTSP(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(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,1) + zmask_xdif => umask(:,:,1) + zmask_ydif => vmask(:,:,1) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,1) + zmask_xdif => tmask(:,:,1) + zmask_ydif => fmask(:,:,1) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,1) + zmask_xdif => fmask(:,:,1) + zmask_ydif => tmask(:,:,1) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( 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.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*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.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) & + & + zout * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1) & + & - zsign_ups * zry * ( phib(ii ,ij ) - phib(iijm1,ijjm1 ) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) & + & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) + 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(dp), 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(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + ! + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,:) + zmask_xdif => umask(:,:,:) + zmask_ydif => vmask(:,:,:) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,:) + zmask_xdif => tmask(:,:,:) + zmask_ydif => fmask(:,:,:) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,:) + zmask_xdif => fmask(:,:,:) + zmask_ydif => tmask(:,:,:) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( 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.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + ! update boundary value: + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*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.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) & + & + zout * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk) & + & - zsign_ups * zry * ( phib(ii ,ij ,jk) - phib(iijm1,ijjm1,jk) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) & + & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) + 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdytides.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdytides.F90 new file mode 100644 index 0000000000000000000000000000000000000000..edc3f7f1aec69b39d38692a65b379f5d99bae199 --- /dev/null +++ b/V4.0/nemo_sources/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: bdytides.F90 14168 2020-12-14 18:32:04Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdytide_init + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdytide_init *** + !! + !! ** Purpose : - Read in namelist for tides and initialise external + !! tidal harmonics data + !! + !!---------------------------------------------------------------------- + !! namelist variables + !!------------------- + CHARACTER(len=80) :: filtide ! Filename root for tidal input files + LOGICAL :: ln_bdytide_2ddta ! If true, read 2d harmonic data + 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 :: isz ! bdy data size + 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,*) ' ' + + ! Allocate space for tidal harmonics data - get size from BDY data arrays + ! Allocate also slow varying data in the case of time splitting: + ! Do it anyway because at this stage knowledge of free surface scheme is unknown + ! ----------------------------------------------------------------------- + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + ALLOCATE( td%ssh0( isz, nb_harmo, 2 ), td%ssh( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%ssh( isz ) ) + dta_bdy_s(ib_bdy)%ssh(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + ALLOCATE( td%u0 ( isz, nb_harmo, 2 ), td%u ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%u2d( isz ) ) + dta_bdy_s(ib_bdy)%u2d(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + ALLOCATE( td%v0 ( isz, nb_harmo, 2 ), td%v ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%v2d( isz ) ) + dta_bdy_s(ib_bdy)%v2d(:) = 0._wp ! needed? + ENDIF + + ! fill td%ssh0, td%u0, td%v0 + ! ----------------------------------------------------------------------- + IF( ln_bdytide_2ddta ) THEN + ! + ! It is assumed that each data file contains all complex harmonic amplitudes + ! given on the global domain (ie global, jpiglo x jpjglo) + ! + ALLOCATE( zti(jpi,jpj), ztr(jpi,jpj) ) + ! + ! SSH fields + clfile = TRIM(filtide)//'_grid_T.nc' + CALL iom_open( clfile , inum ) + igrd = 1 ! Everything is at T-points here + DO itide = 1, nb_harmo + CALL iom_get( inum, jpdom_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 + ENDIF + END DO + CALL iom_close( inum ) + ! + ! V fields + clfile = TRIM(filtide)//'_grid_V.nc' + CALL iom_open( clfile , inum ) + igrd = 3 ! Everything is at V-points here + DO itide = 1, nb_harmo + CALL iom_get ( inum, jpdom_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 + ENDIF + END DO + CALL iom_close( inum ) + ! + DEALLOCATE( ztr, zti ) + ! + ELSE + ! + ! Read tidal data only on bdy segments + ! + ALLOCATE( dta_read( MAXVAL( idx_bdy(ib_bdy)%nblen(:) ), 1, 1 ) ) + ! + ! Open files and read in tidal forcing data + ! ----------------------------------------- + + DO itide = 1, nb_harmo + ! ! SSH fields + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'z1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'z2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! U fields + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'u1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'u2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! V fields + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'v1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'v2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! + END DO ! end loop on tidal components + ! + DEALLOCATE( dta_read ) + ! + ENDIF ! ln_bdytide_2ddta=.true. + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdytra.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdytra.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1f84098e20c653034297818bef8ddffcc5cb15d8 --- /dev/null +++ b/V4.0/nemo_sources/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: bdytra.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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.0_wp, 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/BDY/bdyvol.F90 b/V4.0/nemo_sources/src/OCE/BDY/bdyvol.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8ea026c64df530064547a0d254cbd8999a7a28d8 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/BDY/bdyvol.F90 @@ -0,0 +1,230 @@ +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 + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyvol.F90 12148 2019-12-10 13:59:27Z smasson $ + !! 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/V4.0/nemo_sources/src/OCE/C1D/c1d.F90 b/V4.0/nemo_sources/src/OCE/C1D/c1d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b3558dded6aa33f0ed39fc4aa36f3777d8332da0 --- /dev/null +++ b/V4.0/nemo_sources/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: c1d.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/C1D/dtauvd.F90 b/V4.0/nemo_sources/src/OCE/C1D/dtauvd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5902a4810ee31c118393545d6ffe898b0cdc8116 --- /dev/null +++ b/V4.0/nemo_sources/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: dtauvd.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/C1D/dyncor_c1d.F90 b/V4.0/nemo_sources/src/OCE/C1D/dyncor_c1d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..661c29099706ac18f2376fcc15391f8730fbd86b --- /dev/null +++ b/V4.0/nemo_sources/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: dyncor_c1d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/C1D/dyndmp.F90 b/V4.0/nemo_sources/src/OCE/C1D/dyndmp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d344a1dd8a4761ba22a1bc340cae81599c43939f --- /dev/null +++ b/V4.0/nemo_sources/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: dyndmp.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/C1D/step_c1d.F90 b/V4.0/nemo_sources/src/OCE/C1D/step_c1d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f3d5511b54ba2dd92f09fbc6855d415bfaa9c91a --- /dev/null +++ b/V4.0/nemo_sources/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: step_c1d.F90 13093 2020-06-10 15:35:50Z gsamson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/README.rst b/V4.0/nemo_sources/src/OCE/CRS/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..8633dbeb339fd6d61d4f191a6d453c7936d430f8 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/src/OCE/CRS/crs.F90 b/V4.0/nemo_sources/src/OCE/CRS/crs.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8ed79804bc23d1337cf825e3c9d0d854273d36ac --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/CRS/crs.F90 @@ -0,0 +1,345 @@ +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: crs.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/crsdom.F90 b/V4.0/nemo_sources/src/OCE/CRS/crsdom.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4780aaa78f94e1b29a401beef5fd215070d49e5b --- /dev/null +++ b/V4.0/nemo_sources/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: crsdom.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_msk + + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 + REAL(wp) :: zmask + + ! Initialize + + tmask_crs(:,:,:) = 0.0 + vmask_crs(:,:,:) = 0.0 + umask_crs(:,:,:) = 0.0 + fmask_crs(:,:,:) = 0.0 + + + IF( 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_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM(umask(ijie,ij:je_2,jk)) + IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp + + fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) + ENDDO + ENDDO + ! + DO jk = 1, jpkm1 + DO ji = 2, 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_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp + + fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) + ENDDO + ENDDO + ENDDO + + ! + CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) + CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) + CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) + CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) + ! + END SUBROUTINE crs_dom_msk + + + SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_coordinates *** + !! ** Purpose : Determine the coordinates for the coarse grid + !! + !! ** Method : From the parent grid subset, search for the central + !! point. For an odd-numbered reduction factor, + !! the coordinate will be that of the central T-cell. + !! For an even-numbered reduction factor, of a non-square + !! coarse grid box, the coordinate will be that of + !! the east or north face or more likely. For a square + !! coarse grid box, the coordinate will be that of + !! the central f-corner. + !! + !! ** Input : p_gphi = parent grid gphi[t|u|v|f] + !! p_glam = parent grid glam[t|u|v|f] + !! cd_type = grid type (T,U,V,F) + !! ** Output : p_gphi_crs = coarse grid gphi[t|u|v|f] + !! p_glam_crs = coarse grid glam[t|u|v|f] + !! + !! History. 1 Jun. + !!---------------------------------------------------------------- + !! Arguments + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F) + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijis, ijjs + + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + DO jj = 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_wp ) + CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) + + ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd + SELECT CASE ( cd_type ) + CASE ( 'T', 'V' ) + DO ji = 2, 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(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) + CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type U,V + + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijje,ijrs + + !!---------------------------------------------------------------- + ! Initialize + + DO jk = 1, jpk + DO ji = 2, 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_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_hgr + + + SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_wgt *** + !! ** Purpose : Three applications. + !! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction + !! 2) VOL. Get coarse grid box volumes + !! 3) WGT. Weighting multiplier for volume-weighted and/or + !! area-weighted averages. + !! Weights (i.e. the denominator) calculated here + !! to avoid IF-tests and division. + !! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of + !! the coarse grid are the sum of the east or north faces of the + !! parent grid subset comprising the coarse grid box. + !! The fractions of masked:total surface (3D) on the east, + !! north and top faces is, optionally, also output. + !! - Top face area sum + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - Top face ocean surface fraction + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - e1,e2 Scale factors + !! Valid arguments: + !! 2) VOL. For grid types W and T, the coarse grid box + !! volumes are output. Also optionally, the fraction of + !! masked:total volume of the parent grid subset is output (i.e. facvol). + !! 3) WGT. Based on the grid type, the denominator is pre-determined here to + !! perform area- or volume- weighted averages, + !! to avoid IF-tests and divisions. + !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) + !! p_pmask = parent grid mask (T,U,V,F) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! cd_op = applied operation (SUM, VOL, WGT) + !! p_e3 = (Optional) parent grid vertical level thickness (e3u or e3v) + !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid + !! p_cfield2d_2 = (Optional) 2D field on coarse grid + !! p_cfield3d_1 = (Optional) 3D field on coarse grid + !! p_cfield3d_2 = (Optional) 3D field on coarse grid + !! + !! History. 4 Jun. Write for WGT and scale factors only + !!---------------------------------------------------------------- + CHARACTER(len=1), INTENT(in ) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_mask ! Parent grid U,V mask + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e2 ! Parent grid U,V scale factors (e2) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk , ii, ij, je_2 + REAL(wp) :: zdAm + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol, zmask + !!---------------------------------------------------------------- + ! + ! + p_fld1_crs(:,:,:) = 0._wp + p_fld2_crs(:,:,:) = 0._wp + + DO jk = 1, jpk + zvol(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + END DO + + zmask(:,:,:) = 0._wp + IF( cd_type == 'W' ) THEN + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + ELSE + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + ENDIF + + IF( 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_wp ) + CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_facvol + + + SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_UV *** + !! ** Purpose : Average, area-weighted, of U or V on the east and north faces + !! + !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages + !! on the east and north faces, respectively, + !! of the parent grid subset comprising the coarse grid box. + !! In the case of the V and F grid, the last jrow minus 1 is spurious. + !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! psgn = sign change over north fold (See lbclnk.F90) + !! p_pmask = parent grid mask (T,U,V,F) for scale factors; + !! for velocities (U or V) + !! p_e3 = parent grid vertical level thickness (e3u or e3v) + !! p_pfield = U or V on the parent grid + !! p_surf_crs = (Optional) Coarse grid weight for averaging + !! ** Outputs : p_cfield3d = 3D field on coarse grid + !! + !! History. 29 May. completed draft. + !! 4 Jun. Revision for WGT + !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid + CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask + REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska + REAL(wp), INTENT(in) :: psgn ! sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk + INTEGER :: ii, ij, ijie, ijje, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zsurf, zsurfmsk, zmask + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + ! + CASE ( 'VOL' ) + ! + ALLOCATE( zsurf(jpi,jpj,jpk), zsurfmsk(jpi,jpj,jpk) ) + ! + SELECT CASE ( cd_type ) + ! + CASE( 'T', 'W' ) + IF( cd_type == 'T' ) THEN + DO jk = 1, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) + ENDDO + ELSE + zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + ENDIF + + IF( 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(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask + REAL(wp), INTENT(in) :: psgn + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + + CASE ( 'VOL' ) + + ALLOCATE( zsurfmsk(jpi,jpj) ) + zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + + IF( 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(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: ze3crs + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf + + !!---------------------------------------------------------------- + + p_e3_crs (:,:,:) = 0. + p_e3_max_crs(:,:,:) = 1. + + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE DEFAULT + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + ENDDO + + IF( 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_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_e3 + + SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 ) + + !! Arguments + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, je_2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk + !!---------------------------------------------------------------- + ! Initialize + + ! + SELECT CASE ( cd_type ) + + CASE ('W') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + + CASE ('V') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE ('U') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE DEFAULT + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + END SELECT + + IF( 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_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_sfc + + SUBROUTINE crs_dom_def + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_def *** + !! ** Purpose : Three applications. + !! 1) Define global domain indice of the croasening grid + !! 2) Define local domain indice of the croasening grid + !! 3) Define the processor domain indice for a croasening grid + !!---------------------------------------------------------------- + !! + !! local variables + + INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices + INTEGER :: ierr ! allocation error status + + + ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points + jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 + ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj + ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 + jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 + jpiglo_crsm1 = jpiglo_crs - 1 + jpjglo_crsm1 = jpjglo_crs - 1 + + jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls + jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls + + IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors + + jpi_crsm1 = jpi_crs - 1 + jpj_crsm1 = jpj_crs - 1 + nperio_crs = jperio + npolj_crs = npolj + + ierr = crs_dom_alloc() ! allocate most coarse grid arrays + + ! 2.a Define processor domain + IF( .NOT. lk_mpp ) THEN + nimpp_crs = 1 + njmpp_crs = 1 + 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_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) + + + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' + ! + mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) + ! ! bottom k-index of W-level = mbkt+1 + + DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level + DO ji = 1, jpi_crsm1 + mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) ) + mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) ) + END DO + END DO + + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zmbk(:,:) = 1.e0; + zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + ! + END SUBROUTINE crs_dom_bat + + +END MODULE crsdom \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/crsdomwri.F90 b/V4.0/nemo_sources/src/OCE/CRS/crsdomwri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fafd7ad3a661dce05e28aa9bd7e578e8b7c7926a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/CRS/crsdomwri.F90 @@ -0,0 +1,235 @@ +MODULE crsdomwri + !!====================================================================== + !! Coarse Ocean initialization : write the coarse ocean domain mesh and mask files + !!====================================================================== + !! History : 3.6 ! 2012-06 (J. Simeon, C. Calone, C Ethe ) from domwri, reduced and modified for coarse grid + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_dom_wri : create and write mesh and mask file(s) + !!---------------------------------------------------------------------- + USE timing ! Timing + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE par_kind, ONLY: wp + USE lib_mpp ! MPP library + USE iom_def + USE iom + USE crs ! coarse grid domain + USE crsdom ! coarse grid domain + USE crslbclnk ! crs mediator to lbclnk + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_dom_wri ! routine called by crsini.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsdomwri.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : Write in a file all the arrays generated in routines + !! crsini for meshes and mask. In three separate files: + !! domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !! + !! ** Output files : mesh_hgr_crs.nc, mesh_zgr_crs.nc, mesh_mask.nc + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local units for 'mesh_mask.nc' file + 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.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) + ! + CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d ) ! ! reference z-coord. + CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d ) + CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d ) + CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d ) + ! + CALL iom_rstput( 0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_t' , facvol_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_w' , facvol_w ) + CALL iom_rstput( 0, 0, inum, 'facsurfu' , facsurfu ) + CALL iom_rstput( 0, 0, inum, 'facsurfv' , facsurfv ) + CALL iom_rstput( 0, 0, inum, 'e1e2w_msk', e1e2w_msk ) + CALL iom_rstput( 0, 0, inum, 'e2e3u_msk', e2e3u_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e3v_msk', e1e3v_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e2w' , e1e2w_crs ) + CALL iom_rstput( 0, 0, inum, 'e2e3u' , e2e3u_crs ) + CALL iom_rstput( 0, 0, inum, 'e1e3v' , e1e3v_crs ) + CALL iom_rstput( 0, 0, inum, 'bt' , bt_crs ) + CALL iom_rstput( 0, 0, inum, 'r1_bt' , r1_bt_crs ) + ! + CALL iom_rstput( 0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt ) + ! ! ============================ + ! ! close the files + ! ! ============================ + CALL iom_close( inum ) + ! + END SUBROUTINE crs_dom_wri + + + SUBROUTINE dom_uniq_crs( puniq, cdgrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_uniq_crs *** + !! + !! ** Purpose : identify unique point of a grid (TUVF) + !! + !! ** Method : 1) apply crs_lbc_lnk on an array with different values for each element + !! 2) check which elements have been changed + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cdgrd ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! + ! + REAL(wp) :: zshift ! shift value link to the process number + INTEGER :: ji ! dummy loop indices + LOGICAL, DIMENSION(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.0_wp ) ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/crsfld.F90 b/V4.0/nemo_sources/src/OCE/CRS/crsfld.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ff5984323cede5470d36fd7838b050111e963390 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/CRS/crsfld.F90 @@ -0,0 +1,251 @@ +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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsfld.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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_wp ) + tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) + + CALL iom_put( "toce", tsn_crs(:,:,:,jp_tem) ) ! temp + CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) ) ! sst + + + ! Salinity + zs(:,:,:) = 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_wp ) + tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) + + CALL iom_put( "soce" , tsn_crs(:,:,:,jp_sal) ) ! sal + CALL iom_put( "sss" , tsn_crs(:,:,1,jp_sal) ) ! sss + + ! U-velocity + CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO 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=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + + CALL iom_put( "uoce" , un_crs ) ! i-current + CALL iom_put( "uocet" , zt_crs ) ! uT + CALL iom_put( "uoces" , zs_crs ) ! uS + + ! V-velocity + CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO 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=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + + CALL iom_put( "voce" , vn_crs ) ! i-current + CALL iom_put( "vocet" , zt_crs ) ! vT + 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.0_wp ) + ! + CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + CALL iom_put( "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_wp ) + ! + CALL iom_put( "hdiv", hdivn_crs ) + + + ! W-velocity + IF( ln_crs_wn ) THEN + CALL crs_dom_ope( CASTSP(wn), 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) + ! 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_wp ) + CALL crs_dom_ope( CASTSP(avs), 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 1 ) + CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( CASTSP(avs), 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 2 ) + CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( CASTSP(avs), 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + END SELECT + ! + CALL iom_put( "avt", avt_crs ) ! Kz on T + CALL iom_put( "avs", avs_crs ) ! Kz on S + + ! sbc fields + CALL crs_dom_ope( CASTSP(sshn) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) + CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=CASTDP(e2u) , p_surf_crs=e2u_crs , psgn=1.0_wp ) + CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=CASTDP(e1v) , p_surf_crs=e1v_crs , psgn=1.0_wp ) + CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) + CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( CASTSP(emp_b), 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( CASTSP(emp) , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + + CALL iom_put( "ssh" , sshn_crs ) ! ssh output + CALL iom_put( "utau" , utau_crs ) ! i-tau output + CALL iom_put( "vtau" , vtau_crs ) ! j-tau output + CALL iom_put( "wspd" , wndm_crs ) ! wind speed output + CALL iom_put( "runoffs" , rnf_crs ) ! runoff output + CALL iom_put( "qsr" , qsr_crs ) ! qsr output + CALL iom_put( "empmr" , emp_crs ) ! water flux output + CALL iom_put( "saltflx" , sfx_crs ) ! salt flux output + CALL iom_put( "ice_cover", fr_i_crs ) ! ice cover output + + ! + CALL iom_swap( "nemo" ) ! return back on high-resolution grid + ! + IF( ln_timing ) CALL timing_stop('crs_fld') + ! + END SUBROUTINE crs_fld + + !!====================================================================== +END MODULE crsfld \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/crsini.F90 b/V4.0/nemo_sources/src/OCE/CRS/crsini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..870813d870770af2c60f4f005e6cf95532817195 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/CRS/crsini.F90 @@ -0,0 +1,254 @@ +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: crsini.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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( CASTSP(gphiu), CASTSP(glamu), 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( CASTSP(gphiv), CASTSP(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( CASTSP(gphiu), CASTSP(glamu), 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( CASTSP(gphiu), CASTSP(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( CASTSP(gphiv), CASTSP(glamv), 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( CASTSP(gphiv), CASTSP(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, CASTDP(e2u), 'U', e1u_crs, e2u_crs ) + CALL crs_dom_hgr( CASTDP(e1v), e2v, 'V', e1v_crs, e2v_crs ) + CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) + + e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) + + + ! 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=CASTSP(e1t), p_e2=CASTSP(e2t) ) + CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u ) + CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v ) + + 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, CASTDP(e2u), ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) + CALL crs_dom_e3( CASTDP(e1v), e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) + CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) + + ! Replace 0 by e3t_0 or e3w_0 + DO jk = 1, jpk + DO ji = 1, jpi_crs + DO jj = 1, jpj_crs + IF( e3t_crs(ji,jj,jk) == 0._wp ) e3t_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3w_crs(ji,jj,jk) == 0._wp ) e3w_crs(ji,jj,jk) = e3w_1d(jk) + IF( e3u_crs(ji,jj,jk) == 0._wp ) e3u_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3v_crs(ji,jj,jk) == 0._wp ) e3v_crs(ji,jj,jk) = e3t_1d(jk) + ENDDO + ENDDO + ENDDO + + ! 3.d.3 Vertical depth (meters) + CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp ) + CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) + + + !--------------------------------------------------------- + ! 4. Coarse grid ocean volume and averaging weights + !--------------------------------------------------------- + ! 4.a. Ocean volume or area unmasked and masked + CALL crs_dom_facvol( tmask, 'T', e1t, e2t, ze3t, ocean_volume_crs_t, facvol_t ) + ! + bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:) + ! + r1_bt_crs(:,:,:) = 0._wp + WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) + + CALL crs_dom_facvol( tmask, 'W', e1t, e2t, ze3w, ocean_volume_crs_w, facvol_w ) + ! + !--------------------------------------------------------- + ! 5. Write out coarse meshmask (see OCE/DOM/domwri.F90 for ideas later) + !--------------------------------------------------------- + + IF( ln_msh_crs ) THEN + CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + CALL crs_dom_wri + CALL dom_grid_glo ! Return to parent grid domain + ENDIF + + !--------------------------------------------------------- + ! 7. Finish and clean-up + !--------------------------------------------------------- + ! + END SUBROUTINE crs_init + + !!====================================================================== +END MODULE crsini \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/CRS/crslbclnk.F90 b/V4.0/nemo_sources/src/OCE/CRS/crslbclnk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9ee132a1ff450ea69ee367f0fbc01ee2659e34fa --- /dev/null +++ b/V4.0/nemo_sources/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: crslbclnk.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE crs_lbc_lnk *** + !! + !! ** Purpose : set lateral boundary conditions for coarsened grid + !! + !! ** Method : Swap domain indices from full to coarse domain + !! before arguments are passed directly to lbc_lnk. + !! Upon exiting, switch back to full domain indices. + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + ! + LOGICAL :: ll_grid_crs + !!---------------------------------------------------------------------- + ! + ll_grid_crs = ( jpi == jpi_crs ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/dia25h.F90 b/V4.0/nemo_sources/src/OCE/DIA/dia25h.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d90b97063b916dfbc4880ab34ee738dc6bfd978c --- /dev/null +++ b/V4.0/nemo_sources/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: dia25h.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diaar5.F90 b/V4.0/nemo_sources/src/OCE/DIA/diaar5.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a27724c094a4de7d5a0286e3cabbca494d96abf9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diaar5.F90 @@ -0,0 +1,446 @@ +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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaar5.F90 13087 2020-06-10 10:16:00Z davestorkey $ + !! 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(:,:,:) :: ztpot! 3D workspace + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zrhd! 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', CASTDP(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( CASTDP(ztsn), zrhd, CASTSP(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', CASTDP(ztsn(:,:,1,jp_tem)) ) + zsal = glob_sum( 'diaar5', CASTDP(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', CASTDP(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.0_wp ) + 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.0_wp ) + 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', CASTDP(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/V4.0/nemo_sources/src/OCE/DIA/diacfl.F90 b/V4.0/nemo_sources/src/OCE/DIA/diacfl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4c3408835151694c9e4dcc192d658b9e96b38c79 --- /dev/null +++ b/V4.0/nemo_sources/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: diacfl.F90 11532 2019-09-11 13:30:16Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diadct.F90 b/V4.0/nemo_sources/src/OCE/DIA/diadct.F90 new file mode 100644 index 0000000000000000000000000000000000000000..230836cc4233302e66d22e5f83413ddc7a1cdd4d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diadct.F90 @@ -0,0 +1,1259 @@ +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: diadct.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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',CASTDP(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',CASTDP(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',CASTDP(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',CASTDP(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(dp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: ptab ! variable to compute at (ki, kj, kk ) + REAL(wp) :: interp ! interpolated variable + + !*local declations + INTEGER :: ii1, ij1, ii2, ij2 ! local integer + REAL(wp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu ! local real + REAL(wp):: zet1, zet2 ! weight for interpolation + REAL(wp):: zdep1,zdep2 ! differences of depth + REAL(wp):: zmsk ! mask value + !!---------------------------------------------------------------------- + + IF( cd_point=='U' )THEN + ii1 = ki ; ij1 = kj + ii2 = ki+1 ; ij2 = kj + + zet1=e1t(ii1,ij1) + zet2=e1t(ii2,ij2) + zmsk=umask(ii1,ij1,kk) + + + ELSE ! cd_point=='V' + ii1 = ki ; ij1 = kj + ii2 = ki ; ij2 = kj+1 + + zet1=e2t(ii1,ij1) + zet2=e2t(ii2,ij2) + zmsk=vmask(ii1,ij1,kk) + + ENDIF + + IF( ln_sco )THEN ! s-coordinate case + + zdepu = ( gdept_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diaharm.F90 b/V4.0/nemo_sources/src/OCE/DIA/diaharm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..93d23a4e169ee8201cdf8b4ad43c83f0dd3fa252 --- /dev/null +++ b/V4.0/nemo_sources/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: diaharm.F90 12523 2020-03-09 10:59:47Z clem $ + !! 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.0_wp, out_u, 'U', -1.0_wp , out_v, 'V', -1.0_wp ) + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diahsb.F90 b/V4.0/nemo_sources/src/OCE/DIA/diahsb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c77636d12b5f35000e8e989c68bbf7c429fe6973 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diahsb.F90 @@ -0,0 +1,428 @@ +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_s! global forcing trends + REAL(dp) :: frc_t, frc_v! global forcing trends + REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends + ! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_ini! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini! + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: sc_loc_ini, e3t_ini! + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahsb.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp) :: zdiff_hc , zdiff_sc ! heat and salt content variations + REAL(dp) :: zdiff_hc1 , zdiff_sc1 ! - - - - + REAL(dp) :: zdiff_v1 , zdiff_v2 ! volume variation + REAL(dp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit + REAL(dp) :: zvol_tot ! volume + REAL(dp) :: z_frc_trd_t , z_frc_trd_s ! - - + REAL(dp) :: z_frc_trd_v ! - - + REAL(dp) :: z_wn_trd_t , z_wn_trd_s ! - - + REAL(dp) :: z_ssh_hc , z_ssh_sc ! - - + REAL(dp), DIMENSION(jpi,jpj) :: z2d0, z2d1 ! 2D workspace + REAL(dp), 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', CASTDP(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diahth.F90 b/V4.0/nemo_sources/src/OCE/DIA/diahth.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e3b4c6e7760bbea3e508e60f444414ddbf661762 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diahth.F90 @@ -0,0 +1,574 @@ +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 + !! 3.4 ! 2013-08 (M. Balmaseda) hc700,hcbtm + !! hd20,hd14,hd17,hd26 + !!---------------------------------------------------------------------- + !! 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 + LOGICAL, SAVE :: ln_diahth_compat = .true. !: Old behavior for compatibility + ! 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(:,:) :: hd14 !: depth of 14 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd17 !: depth of 17 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(:,:) :: htcb !: heat content of whole columnn [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sal3 !: salt content of first 300 m [PSU*m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sal7 !: salt content of first 700 m [PSU*m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: salb !: salt content of whole columnn [PSU*m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc26c !: heat content above the 26 deg isotherm [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc26cd !: heat content above the 26 deg isotherm (T-26) [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sal20 !: heat content of first 2000 m [PSU*m] + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahth.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! 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), & + & hd14(jpi,jpj), hd17(jpi,jpj), & + & htc3(jpi,jpj), htc7(jpi,jpj), htcb(jpi,jpj), & + & sal3(jpi,jpj), sal7(jpi,jpj), salb(jpi,jpj), & + & htc26c(jpi,jpj), htc26cd(jpi,jpj), & + & htc20(jpi,jpj), sal20(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) :: zavt5 = 5.e-4_wp ! Kz criterion for the turbocline depth + 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( '14d' ) .OR. iom_use( '17d' ) .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( 'sal300' ) .OR. iom_use( 'sal700' ) .OR. iom_use( 'sal2000' ) .OR. & + & iom_use( 'hcbtm' ) .OR. iom_use( 'salbtm' ) .OR. & + & iom_use( 'hc26c' ) .OR. iom_use( 'hc26cd' ) .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 14C/17C/20C/26C/28C isotherm ! + ! --------------------------------------- ! + IF( iom_use ('14d') ) THEN ! depth of the 14 isotherm + ztem2 = 14. + CALL dia_hth_dep( ztem2, hd14 ) + CALL iom_put( '14d', hd14 ) + ENDIF + ! + IF( iom_use ('17d') ) THEN ! depth of the 17 isotherm + ztem2 = 17. + CALL dia_hth_dep( ztem2, hd17 ) + CALL iom_put( '17d', hd17 ) + ENDIF + ! + 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') .OR. iom_use('hc26c') .OR. iom_use('hc26cd') ) 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') .OR. iom_use ('sal300') ) THEN + zzdep = 300. + CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), htc3, sal3 ) + htc3(:,:) = rau0_rcp * htc3(:,:) + CALL iom_put( 'hc300', htc3 ) ! vertically integrated heat content (J/m2) + CALL iom_put( 'sal300', sal3 ) ! vertically integrated salinity (PSU*m) + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 700 m ! + ! ----------------------------- ! + IF( iom_use ('hc700') .OR. iom_use ('sal700') ) THEN + zzdep = 700. + CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), htc7, sal7 ) + htc7(:,:) = rau0_rcp * htc7(:,:) + CALL iom_put( 'hc700', htc7 ) ! vertically integrated heat content (J/m2) + CALL iom_put( 'sal700', sal7 ) ! vertically integrated salinity (PSU*m) + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 2000 m ! + ! ----------------------------- ! + IF( iom_use ('hc2000') .OR. iom_use ('sal2000') ) THEN + zzdep = 2000. + CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), htc20, sal20 ) + htc20(:,:) = rau0_rcp * htc20(:,:) + CALL iom_put( 'hc2000', htc20 ) ! vertically integrated heat content (J/m2) + CALL iom_put( 'sal2000', sal20 ) ! vertically integrated salinity (PSU*m) + ENDIF + ! + ! ----------------------------------- ! + ! Heat/salt content of whole coloumn ! + ! ----------------------------------- ! + IF( iom_use ('hcbtm') .OR. iom_use ('salbtm') ) THEN + CALL dia_hth_btm + ENDIF + ! + ! ----------------------------- ! + ! Heat content to 26 degrees ! + ! ----------------------------- ! + IF ( iom_use('hc26c') .OR. iom_use('hc26cd') ) THEN + CALL dia_hth_d26() + END IF + ! + 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) ) & + & * ( ptem*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, psn, phtc, psal ) + ! + REAL(wp), INTENT(in) :: pdep ! depth over the heat content + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptn, psn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc, psal + ! + INTEGER :: ji, jj, jk, ik + REAL(wp), DIMENSION(jpi,jpj) :: zthick + INTEGER , DIMENSION(jpi,jpj) :: ilevel + REAL(wp) :: zthick_0 + INTEGER :: ilevel_0 + + + ! surface boundary condition + + IF( .NOT. ln_linssh ) THEN + zthick(:,:) = 0._wp + phtc(:,:) = 0._wp + psal(:,:) = 0._wp + ELSE + zthick(:,:) = sshn(:,:) + phtc(:,:) = ptn(:,:,1) * sshn(:,:) * tmask(:,:,1) + psal(:,:) = psn(:,:,1) * sshn(:,:) * tmask(:,:,1) + ENDIF + ! + IF ( ln_diahth_compat ) THEN + ilevel_0 = 0 + zthick_0 = 0._wp + DO jk = 1, jpkm1 + zthick_0 = zthick_0 + e3t_1d(jk) + IF( zthick_0 < pdep ) ilevel_0 = jk + END DO + ilevel(:,:) = ilevel_0 + DO jk = 1, ilevel_0 + DO jj = 1, jpj + DO ji = 1, jpi + zthick(ji,jj) = zthick(ji,jj) + e3t_n(ji,jj,jk) * tmask(ji,jj,jk) + phtc (ji,jj) = phtc (ji,jj) + e3t_n(ji,jj,jk) * ptn(ji,jj,jk) * tmask(ji,jj,jk) + psal (ji,jj) = psal (ji,jj) + e3t_n(ji,jj,jk) * psn(ji,jj,jk) * tmask(ji,jj,jk) + ENDDO + ENDDO + ENDDO + ELSE + ilevel(:,:) = 1 + DO jk = 1, 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) + psal (ji,jj) = psal (ji,jj) + e3t_n(ji,jj,jk) * psn(ji,jj,jk) + ENDIF + ENDDO + ENDDO + ENDDO + END IF + ! + 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) + psal(ji,jj) = psal(ji,jj) + psn(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 + + SUBROUTINE dia_hth_btm + + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(jpi,jpj) :: zthick + INTEGER , DIMENSION(jpi,jpj) :: ilevel + + ! -------------------------------- ! + ! Heat/Salt content whole comumn ! + ! -------------------------------- ! + + ! surface boundary condition + IF( ln_linssh ) THEN + htcb(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1) + salb(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:) * tmask(:,:,1) + ELSE + htcb(:,:) = 0._wp + salb(:,:) = 0._wp + ENDIF + ! integration down to jpkm1 + DO jk = 1, jpkm1 + htcb (:,:) = htcb (:,:) + e3t_n(:,:,jk) * tsn(:,:,jk,jp_tem) * tmask(:,:,jk) + salb (:,:) = salb (:,:) + e3t_n(:,:,jk) * tsn(:,:,jk,jp_sal) * tmask(:,:,jk) + END DO + ! from temperature to heat contain + htcb(:,:) = rau0_rcp * htcb(:,:) + CALL iom_put( "hcbtm", htcb ) ! first 300m heat content + CALL iom_put( "salbtm", salb ) ! first 300m salt content + + END SUBROUTINE dia_hth_btm + + SUBROUTINE dia_hth_d26 + ! + ! + INTEGER :: ji, jj, jk, iid + REAL(wp) :: zztmp, zcoef + INTEGER, DIMENSION(jpi,jpj) :: iktem + REAL(wp), DIMENSION(jpi,jpj) :: zthick + INTEGER , DIMENSION(jpi,jpj) :: ilevel + + ! --------------------------------- ! + ! Heat content to the 26 isotherm ! + ! --------------------------------- ! + + 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 >= 26.0_wp ) iktem(ji,jj) = jk + END DO + END DO + END DO + + ! surface boundary condition + DO jj = 1, jpj + DO ji = 1, jpi + iid = iktem(ji,jj) + IF( iid /= 1 ) THEN + IF( ln_linssh ) THEN + zthick(ji,jj) = sshn(ji,jj) + htc26c (ji,jj) = tsn(ji,jj,1,jp_tem) * sshn(ji,jj) * tmask(ji,jj,1) + htc26cd(ji,jj) = ( tsn(ji,jj,1,jp_tem) - 26.0_wp ) * sshn(ji,jj) * tmask(ji,jj,1) + ELSE + htc26c(ji,jj) = 0.0_wp + htc26cd(ji,jj) = 0.0_wp + zthick(ji,jj) = 0.0_wp + ENDIF + DO jk = 1, iid + zthick (ji,jj) = zthick(ji,jj) + e3t_n(ji,jj,jk) + htc26c (ji,jj) = htc26c(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) + htc26cd(ji,jj) = htc26cd(ji,jj) + & + & e3t_n(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) - 26.0_wp ) * tmask(ji,jj,jk) + END DO + zthick(ji,jj) = hd26(ji,jj) - zthick(ji,jj) ! remaining thickness to reach 26degc + ! If zthick<0 then the level is close to the previous T point and we need to subtract the contribution + ! from the previous level. Otherwise add it from the next level. + IF ( zthick(ji,jj) < 0.0_wp ) THEN + htc26c(ji,jj) = htc26c(ji,jj) + tsn(ji,jj,iid,jp_tem) * & + & zthick(ji,jj) * tmask(ji,jj,iid) + htc26cd(ji,jj) = htc26cd(ji,jj) + ( tsn(ji,jj,iid,jp_tem) - 26.0_wp ) * & + & zthick(ji,jj) * tmask(ji,jj,iid) + ELSE + htc26c(ji,jj) = htc26c(ji,jj) + tsn(ji,jj,iid+1,jp_tem) * & + & MIN( e3t_n(ji,jj,iid+1), zthick(ji,jj) ) * tmask(ji,jj,iid+1) + htc26cd(ji,jj) = htc26cd(ji,jj) + ( tsn(ji,jj,iid+1,jp_tem) - 26.0_wp ) * & + & MIN( e3t_n(ji,jj,iid+1), zthick(ji,jj) ) * tmask(ji,jj,iid+1) + ENDIF + ELSE + htc26c(ji,jj) = 0.0_wp + htc26cd(ji,jj) = 0.0_wp + ENDIF + ENDDO + ENDDO + zcoef = rau0 * rcp + htc26c(:,:) = zcoef * htc26c(:,:) + htc26cd(:,:) = zcoef * htc26cd(:,:) + CALL iom_put( "hc26c" , htc26c ) ! heat content to the depth of the 26 isotherm + CALL iom_put( "hc26cd", htc26cd ) ! heat content relative to 26 to the depth of the 26 isotherm + + END SUBROUTINE dia_hth_d26 + + !!====================================================================== +END MODULE diahth \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/dianam.F90 b/V4.0/nemo_sources/src/OCE/DIA/dianam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c037a5a37ae246f78fda649422b99d41e94d05ed --- /dev/null +++ b/V4.0/nemo_sources/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: dianam.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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,3i2.2)" ! format used to write the date + ELSE ; WRITE(clfmt, "('(i',i1,',3i2.2)')") INT(LOG10(REAL(iyear2,wp))) + 1 + ENDIF + + WRITE(cldate1, clfmt) iyear1, imonth1, iday1, NINT(zsec1/3600.0) ! date of the beginning of run + WRITE(cldate2, clfmt) iyear2, imonth2, iday2, NINT(zsec2/3600.0) ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIA/diaptr.F90 b/V4.0/nemo_sources/src/OCE/DIA/diaptr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6c0d2c5a22f321c1f3a2fb14d256bb753a1ce1c0 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diaptr.F90 @@ -0,0 +1,748 @@ +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_dp, ptr_sj_3d_sp, ptr_sj_2d + END INTERFACE + + INTERFACE dia_ptr_hst + MODULE PROCEDURE dia_ptr_hst_dp, dia_ptr_hst_sp + END INTERFACE dia_ptr_hst + + 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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaptr.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_ptr( pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr *** + !!---------------------------------------------------------------------- + REAL(dp), 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( CASTSP(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( CASTSP(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( CASTSP(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_sp( 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(sp), 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_sp + + SUBROUTINE dia_ptr_hst_dp( 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(dp), 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_dp + + + 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_dp( 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(dp), 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_dp + + FUNCTION ptr_sj_3d_sp( 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(sp), 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_sp + + + 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.0_wp ) + 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/V4.0/nemo_sources/src/OCE/DIA/diawri.F90 b/V4.0/nemo_sources/src/OCE/DIA/diawri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ecfd0e2cc25b3d3f1c2dcb296672468439db27c7 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DIA/diawri.F90 @@ -0,0 +1,1270 @@ +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 geo2ocean ! For rotation. + USE iom ! + USE ioipsl ! + +#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: diawri.F90 14580 2021-03-04 09:32:30Z clem $ + !! 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 + REAL(wp), DIMENSION(jpi,jpj) :: zut2d, zvt2d, zur2d, zvr2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zut3d, zvt3d, zur3d, zvr3d ! 3D workspace + !!---------------------------------------------------------------------- + ! + 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", tsn(:,:,:,jp_tem) ) ! 3D temperature + CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature + IF ( iom_use("sbt") ) 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", z2d ) ! bottom temperature + ENDIF + + CALL iom_put( "soce", tsn(:,:,:,jp_sal) ) ! 3D salinity + CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity + IF ( iom_use("sbs") ) 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", 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.0_wp ) + CALL iom_put( "taubot", z2d ) + ENDIF + + 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 + + ! ! vertical velocity + IF( ln_zad_Aimp ) THEN ; CALL iom_put( "woce", wn + wi ) ! explicit plus implicit parts + ELSE ; CALL iom_put( "woce", wn ) + ENDIF + + IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value + ! ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. + DO jk = 1, jpk + IF( ln_zad_Aimp ) THEN + z3d(:,:,jk) = rau0 * e1e2t(:,:) * ( wn(:,:,jk) + wi(:,:,jk) ) + ELSE + z3d(:,:,jk) = rau0 * e1e2t(:,:) * wn(:,:,jk) + ENDIF + END DO + CALL iom_put( "w_masstr" , z3d ) + IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d * z3d ) + ENDIF + + CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. + CALL iom_put( "avs" , avs ) ! S vert. eddy diff. coef. + CALL iom_put( "avm" , avm ) ! T vert. eddy visc. coef. + + IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt(:,:,:) ) ) ) + IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) + + IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) 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.0_wp ) + CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient + z2d(:,:) = SQRT( z2d(:,:) ) + CALL iom_put( "sstgrad" , 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.0_wp ) + 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.0_wp ) + 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.0_wp ) + 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.0_wp ) + 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.0_wp ) + CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction + ENDIF + + IF( iom_use("tosmint") ) 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.0_wp ) + CALL iom_put( "tosmint", rau0 * z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint") ) 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.0_wp ) + CALL iom_put( "somint", rau0 * z2d ) ! Vertical integral of salinity + ENDIF + + CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2) + ! + ! ECMWF fields + ! + CALL iom_put( "div", hdivn ) ! hdivn + ! + ! Unrotated currents on T-grid + ! + ! Destagger to T-grid + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 2, jpi + zut3d(ji,jj,jk) = 0.5*(un(ji-1,jj,jk) + un(ji,jj,jk)) + ENDDO + ENDDO + DO jj = 2,jpj + DO ji = 1,jpi + zvt3d(ji,jj,jk) = 0.5*(vn(ji,jj-1,jk) + vn(ji,jj,jk)) + ENDDO + ENDDO + ENDDO + CALL lbc_lnk( 'diawri', zut3d, 'T', -1.0_wp ) + CALL lbc_lnk( 'diawri', zvt3d, 'T', -1.0_wp ) + ! + ! Rotate to true north + ! + DO jk = 1, jpk + CALL rot_rep( zut3d(:,:,jk), zvt3d(:,:,jk), 'T', 'ij->e', zur3d(:,:,jk) ) + CALL rot_rep( zut3d(:,:,jk), zvt3d(:,:,jk), 'T', 'ij->n', zvr3d(:,:,jk) ) + ENDDO + CALL iom_put( "uocee", zur3d ) + CALL iom_put( "uocees", zur3d(:,:,1) ) + CALL iom_put( "vocen", zvr3d ) + CALL iom_put( "vocens", zvr3d(:,:,1) ) + ! + ! Unrotated stress on T-grid + ! + ! Destagger to T-grid + ! + DO jj = 1, jpj + DO ji = 2, jpi + zut2d(ji,jj) = 0.5*(utau(ji-1,jj) + utau(ji,jj)) + ENDDO + ENDDO + DO jj = 2,jpj + DO ji = 1,jpi + zvt2d(ji,jj) = 0.5*(vtau(ji,jj-1) + vtau(ji,jj)) + ENDDO + ENDDO + CALL lbc_lnk( 'diawri', zut2d, 'T', -1.0_wp ) + CALL lbc_lnk( 'diawri', zvt2d, 'T', -1.0_wp ) + ! + ! Rotate to true north + ! + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->e', zur2d(:,:) ) + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->n', zvr2d(:,:) ) + ! + CALL iom_put( "utaue", zur2d ) + CALL iom_put( "vtaun", zvr2d ) + ! + CALL iom_put( "sigmat", (rhop-rau0)/rau0 ) + + 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 + + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'dia_wri options:' + WRITE(numout,*)'ln_diawri_full = ',ln_diawri_full + WRITE(numout,*)'ln_diawri_instant = ',ln_diawri_instant + ENDIF + IF (ln_diawri_full) THEN + CALL dia_wri_full ( kt ) + ELSE + CALL dia_wri_reduced( kt ) + ENDIF + + END SUBROUTINE dia_wri + + SUBROUTINE dia_wri_full( 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=lc) :: clhstnam ! local names + CHARACTER (len=120) :: 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 (ln_diawri_instant) THEN + 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' ) + clhstnam = TRIM(cn_diawri_outdir)//'/'//clhstnam + 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.0_wp, ndex_T , ndim_T ) ! volume + CALL wheneq( jpi*jpj , tmask, 1, 1.0_wp, 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' ) + clhstnam = TRIM(cn_diawri_outdir)//'/'//clhstnam + 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.0_wp, ndex_U , ndim_U ) ! volume + CALL wheneq( jpi*jpj , umask, 1, 1.0_wp, ndex_hU, ndim_hU ) ! surface + + ! Define the V grid FILE ( nid_V ) + + CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename + clhstnam = TRIM(cn_diawri_outdir)//'/'//clhstnam + 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.0_wp, ndex_V , ndim_V ) ! volume + CALL wheneq( jpi*jpj , vmask, 1, 1.0_wp, ndex_hV, ndim_hV ) ! surface + + ! Define the W grid FILE ( nid_W ) + + CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename + clhstnam = TRIM(cn_diawri_outdir)//'/'//clhstnam + 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 ) +! diahth only works with XIOS +#if defined key_diahth_notworking + 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 ) ! ??? + + ! diahth only works with XIOS +#if defined key_diahth_notworking + 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_full + + SUBROUTINE dia_wri_reduced( 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=lc) :: clhstnam ! local names + CHARACTER (len=120) :: 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 + REAL(wp), DIMENSION(jpi,jpj) :: zut2d, zvt2d, zur2d, zvr2d ! 2D 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 (ln_diawri_instant) THEN + 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' ) + clhstnam = TRIM(cn_diawri_outdir)//'/'//clhstnam + 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.0_wp, ndex_T , ndim_T ) ! volume + CALL wheneq( jpi*jpj , tmask, 1, 1.0_wp, ndex_hT, ndim_hT ) ! surface + ! + + ! Declare all the output fields as NETCDF variables + + ! !!! nid_T : 3D + 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 ) + 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 ) + ! Un-rotated surface currents + stress on T-grid + CALL histdef( nid_T, "sozocrte", "Surface zonal Current" , "m/s" , & ! un + & jpi, jpj, nh_T, 1 , 1, 1 , -99, 32, clop, zsto, zout ) + CALL histdef( nid_T, "somecrtn", "Surface meridional Current", "m/s" , & ! vn + & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + CALL histdef( nid_T, "sozotaue", "Wind Stress along i-axis" , "N/m2" , & ! utau + & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + CALL histdef( nid_T, "sometaun", "Wind Stress along j-axis" , "N/m2" , & ! vtau + & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + ! + CALL histend( nid_T, 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 + + 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 + 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 + 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 + + ! Surface current + ! Destagger to T-grid + DO jj = 1, jpj + DO ji = 2, jpi + zut2d(ji,jj) = 0.5_wp*(un(ji-1,jj,1) + un(ji,jj,1)) + ENDDO + ENDDO + DO jj = 2,jpj + DO ji = 1,jpi + zvt2d(ji,jj) = 0.5_wp*(vn(ji,jj-1,1) + vn(ji,jj,1)) + ENDDO + ENDDO + CALL lbc_lnk( 'diawri', zut2d, 'T', -1.0_wp ) + CALL lbc_lnk( 'diawri', zvt2d, 'T', -1.0_wp ) + ! Rotate to true north + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->e', zur2d(:,:) ) + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->n', zvr2d(:,:) ) + CALL histwrite( nid_T, "sozocrte", it, zur2d , ndim_hT, ndex_hT ) ! u-wind stress + CALL histwrite( nid_T, "somecrtn", it, zvr2d , ndim_hT, ndex_hT ) ! v-wind stress + + ! Surface stress + ! Destagger to T-grid + DO jj = 1, jpj + DO ji = 2, jpi + zut2d(ji,jj) = 0.5_wp*(utau(ji-1,jj) + utau(ji,jj)) + ENDDO + ENDDO + DO jj = 2,jpj + DO ji = 1,jpi + zvt2d(ji,jj) = 0.5_wp*(vtau(ji,jj-1) + vtau(ji,jj)) + ENDDO + ENDDO + CALL lbc_lnk( 'diawri', zut2d, 'T', -1.0_wp ) + CALL lbc_lnk( 'diawri', zvt2d, 'T', -1.0_wp ) + ! Rotate to true north + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->e', zur2d(:,:) ) + CALL rot_rep( zut2d(:,:), zvt2d(:,:), 'T', 'ij->n', zvr2d(:,:) ) + CALL histwrite( nid_T, "sozotaue", it, zur2d , ndim_hT, ndex_hT ) ! u-wind stress + CALL histwrite( nid_T, "sometaun", it, zvr2d , ndim_hT, ndex_hT ) ! v-wind stress + + ! 3. Close all files + ! --------------------------------------- + IF( kt == nitend ) THEN + CALL histclo( nid_T ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri_reduced + +#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., ldsgl = .FALSE., kdlev = jpl ) +#else + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., ldsgl = .FALSE. ) +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIU/cool_skin.F90 b/V4.0/nemo_sources/src/OCE/DIU/cool_skin.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bf32ec55e70f781e5e384ff90d7db6dd833a179d --- /dev/null +++ b/V4.0/nemo_sources/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: cool_skin.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIU/diurnal_bulk.F90 b/V4.0/nemo_sources/src/OCE/DIU/diurnal_bulk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e62f214e5a57bddf0f0c0a624bd562755a410915 --- /dev/null +++ b/V4.0/nemo_sources/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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIU/solfrac_mod.F90 b/V4.0/nemo_sources/src/OCE/DIU/solfrac_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d6f034f4075e09d1f036beda7b0f3822fb037918 --- /dev/null +++ b/V4.0/nemo_sources/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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DIU/step_diu.F90 b/V4.0/nemo_sources/src/OCE/DIU/step_diu.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0756c082335c101e8b785e044a44beed437ec232 --- /dev/null +++ b/V4.0/nemo_sources/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: step_diu.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/closea.F90 b/V4.0/nemo_sources/src/OCE/DOM/closea.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f2e169358aa99cdd975783d1fb3fcb6d0d3de511 --- /dev/null +++ b/V4.0/nemo_sources/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" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: closea.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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', CASTDP(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', CASTDP(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', CASTDP(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', CASTDP(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', CASTDP(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', CASTDP(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/V4.0/nemo_sources/src/OCE/DOM/daymod.F90 b/V4.0/nemo_sources/src/OCE/DOM/daymod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5ab941078e6a27aaa4aac2bfbdc173074e6da2c6 --- /dev/null +++ b/V4.0/nemo_sources/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: daymod.F90 12158 2019-12-10 15:33:19Z jchanut $ + !! 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_wp, 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 day_mth + + + SUBROUTINE day( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE day *** + !! + !! ** Purpose : Compute the date with a day iteration IF necessary. + !! + !! ** Method : - ??? + !! + !! ** Action : - nyear : current year + !! - nmonth : current month of the year nyear + !! - nday : current day of the month nmonth + !! - nday_year : current day of the year nyear + !! - ndastp : = nyear*10000 + nmonth*100 + nday + !! - adatrj : date in days since the beginning of the run + !! - nsec_year : current time of the year (in second since 00h, jan 1st) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step indices + ! + CHARACTER (len=25) :: charout + REAL(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_wp, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/depth_e3.F90 b/V4.0/nemo_sources/src/OCE/DOM/depth_e3.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8a688641fb487c5ef0160ef72cc8057ae65c0692 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/depth_e3.F90 @@ -0,0 +1,166 @@ +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: depth_e3.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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! depths [m] + REAL(dp), DIMENSION(:), INTENT(in ) :: pdepw_1d! depths [m] + REAL(dp), 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(dp), DIMENSION(:), INTENT(in ) :: pe3t_1d , pe3w_1d ! vert. scale factors [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pdept_1d! depth = SUM( e3 ) [m] + REAL(dp), DIMENSION(:), INTENT( out) :: 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/dom_oce.F90 b/V4.0/nemo_sources/src/OCE/DOM/dom_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ed6b138751847b5d953744c7e2c797d81dbe418e --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/dom_oce.F90 @@ -0,0 +1,320 @@ +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 + + !! 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, glamf!: longitude at t, u, v, f-points [degree] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamu, glamv!: longitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit, gphif!: latitude at t, u, v, f-points [degree] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphiu, gphiv!: latitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1t, r1_e2t!: t-point horizontal scale factors [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t!: t-point horizontal scale factors [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2u!: horizontal scale factors at u-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u, r1_e1u, r1_e2u!: horizontal scale factors at u-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v!: horizontal scale factors at v-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1v, e2v, r1_e2v!: horizontal scale factors at v-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1f, r1_e2f!: horizontal scale factors at f-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f!: horizontal scale factors at f-point [m] + ! + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: r1_e1e2f!: associated metrics at f-point + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 , e3t_b , e3t_n , e3t_a !: t- vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 , e3u_b , e3u_n , e3u_a !: u- vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 , e3v_b , e3v_n , e3v_a !: v- vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 , e3f_n !: f- vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 , e3w_b , e3w_n !: w- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0!: uw-vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_b, e3uw_n!: uw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0!: vw-vert. scale factor [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_b, e3vw_n!: vw-vert. scale factor [m] + + ! ! ref. ! before ! now ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0, gdept_b!: t- depth [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: 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!: w- depth (sum of e3w) [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_n!: w- depth (sum of e3w) [m] + + ! ! ref. ! before ! now ! after ! + REAL(dp), 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hu_b , r1_hu_n , r1_hu_a !: inverse of u-depth [1/m] + REAL(dp), 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!: reference depth of t- and w-points (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdepw_1d!: reference depth of t- and w-points (m) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) + + + !!---------------------------------------------------------------------- + !! 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: dom_oce.F90 12859 2020-05-03 09:33:32Z smasson $ + !! 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) ) + ! + ! Init some variables to avoid fp errors. + vmask(:,:,:) = 0._wp + umask(:,:,:) = 0._wp + tmask(:,:,:) = 0._wp + fmask(:,:,:) = 0._wp + ! --------------------------------------- + dom_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION dom_oce_alloc + + !!====================================================================== +END MODULE dom_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/domain.F90 b/V4.0/nemo_sources/src/OCE/DOM/domain.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d1a3a824064c6c6e545b202021d2e58f1901733a --- /dev/null +++ b/V4.0/nemo_sources/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 + USE restart ! For ln_writerst, ln_rsttime + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_init ! called by nemogcm.F90 + PUBLIC domain_cfg ! called by nemogcm.F90 + +# include "single_precision_substitute.h90" + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domain.F90 13436 2020-08-25 15:11:29Z acc $ + !! 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(dp), 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_writerst, ln_rsttime, & + & nn_slimrst, nn_slimrstin + NAMELIST/namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask +#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,*) ' slim restart output option nn_slimrst = ', nn_slimrst + WRITE(numout,*) ' slim restart input option nn_slimrstin = ', nn_slimrstin + 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,*) ' 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 + 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 + ntime0 = nn_time0 + 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 + 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(dp) :: ze1min, ze1max, ze2min, ze2max + !!---------------------------------------------------------------------- + ! + IF(lk_mpp) THEN + CALL mpp_minloc( 'domain', e1t(:,:), CASTDP(tmask_i(:,:)), ze1min, imi1 ) + CALL mpp_minloc( 'domain', e2t(:,:), CASTDP(tmask_i(:,:)), ze2min, imi2 ) + CALL mpp_maxloc( 'domain', e1t(:,:), CASTDP(tmask_i(:,:)), ze1max, ima1 ) + CALL mpp_maxloc( 'domain', e2t(:,:), CASTDP(tmask_i(:,:)), ze2max, ima2 ) + ELSE + ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + ! + iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + imi1(1) = iloc(1) + nimpp - 1 + imi1(2) = iloc(2) + njmpp - 1 + iloc = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + imi2(1) = iloc(1) + nimpp - 1 + imi2(2) = iloc(2) + njmpp - 1 + iloc = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + ima1(1) = iloc(1) + nimpp - 1 + ima1(2) = iloc(2) + njmpp - 1 + iloc = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + 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(dp) :: zorca_res ! local scalars + REAL(dp) :: 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(dp), 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/V4.0/nemo_sources/src/OCE/DOM/domhgr.F90 b/V4.0/nemo_sources/src/OCE/DOM/domhgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9ff3cff3ab11113528416316fc9e1105fb6de1bb --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/domhgr.F90 @@ -0,0 +1,239 @@ +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: domhgr.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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, plamf! longitude outputs + REAL(dp), DIMENSION(:,:), INTENT(out) :: plamu, plamv! longitude outputs + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphif! latitude outputs + REAL(dp), DIMENSION(:,:), INTENT(out) :: pphiu, pphiv! latitude outputs + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) + ! + INTEGER :: inum ! logical unit + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' hgr_read : read the horizontal coordinates in mesh_mask' + WRITE(numout,*) ' ~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + CALL iom_get( inum, jpdom_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/dommsk.F90 b/V4.0/nemo_sources/src/OCE/DOM/dommsk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..be6ded1c6bff7715f1dc1935f417071754639ae4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/dommsk.F90 @@ -0,0 +1,321 @@ +MODULE dommsk + !!====================================================================== + !! *** MODULE dommsk *** + !! Ocean initialization : domain land/sea mask + !!====================================================================== + !! History : OPA ! 1987-07 (G. Madec) Original code + !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon) + !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays + !! - ! 1996-05 (G. Madec) mask computed from tmask + !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F + !! 8.1 ! 1997-07 (G. Madec) modification of kbat and fmask + !! - ! 1998-05 (G. Roullet) free surface + !! 8.2 ! 2000-03 (G. Madec) no slip accurate + !! - ! 2001-09 (J.-M. Molines) Open boundaries + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask + !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_msk : compute land/ocean mask + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE usrdef_fmask ! user defined fmask + USE bdy_oce ! open boundary + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! Massively Parallel Processing library + USE iom ! For shlat2d + USE fldread ! for sn_shlat2d + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_msk ! routine called by inidom.F90 + + ! !!* Namelist namlbc : lateral boundary condition * + REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity + LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition + ! with analytical eqs. + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dommsk.F90 13270 2020-07-08 14:41:20Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_msk( k_top, k_bot ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori- + !! zontal velocity points (u & v), vorticity points (f) points. + !! + !! ** Method : The ocean/land mask at t-point is deduced from ko_top + !! and ko_bot, the indices of the fist and last ocean t-levels which + !! are either defined in usrdef_zgr or read in zgr_read. + !! The velocity masks (umask, vmask, wmask, wumask, wvmask) + !! are deduced from a product of the two neighboring tmask. + !! The vorticity mask (fmask) is deduced from tmask taking + !! into account the choice of lateral boundary condition (rn_shlat) : + !! rn_shlat = 0, free slip (no shear along the coast) + !! rn_shlat = 2, no slip (specified zero velocity at the coast) + !! 0 < rn_shlat < 2, partial slip | non-linear velocity profile + !! 2 < rn_shlat, strong slip | in the lateral boundary layer + !! + !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated + !! rows/lines due to cyclic or North Fold boundaries as well + !! as MPP halos. + !! tmask_h : halo mask at t-point, i.e. excluding duplicated rows/lines + !! due to cyclic or North Fold boundaries as well as MPP halos. + !! + !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask + !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) + !! fmask : land/ocean mask at f-point (=0., or =1., or + !! =rn_shlat along lateral boundaries) + !! tmask_i : interior ocean mask + !! tmask_h : halo mask + !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iif, iil ! local integers + INTEGER :: ijf, ijl ! - - + INTEGER :: iktop, ikbot ! - - + INTEGER :: ios, inum + !! + 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, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + !!--------------------------------------------------------------------- + ! + 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' ) + 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' ) + IF(lwm) WRITE ( numond, namlbc ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dommsk : ocean mask ' + WRITE(numout,*) '~~~~~~' + WRITE(numout,*) ' Namelist namlbc' + WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat + WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat + ENDIF + ! + IF(lwp) WRITE(numout,*) + IF ( rn_shlat == 0. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral free-slip' + ELSEIF ( rn_shlat == 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral no-slip' + ELSEIF ( 0. < rn_shlat .AND. rn_shlat < 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral partial-slip' + ELSEIF ( 2. < rn_shlat ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral strong-slip' + ELSE + CALL ctl_stop( 'dom_msk: wrong value for rn_shlat (i.e. a negalive value). We stop.' ) + ENDIF + + 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) + ENDIF + + ! Ocean/land mask at t-point (computed from ko_top and ko_bot) + ! ---------------------------- + ! + tmask(:,:,:) = 0._wp + DO jj = 1, jpj + DO ji = 1, jpi + iktop = k_top(ji,jj) + ikbot = k_bot(ji,jj) + IF( iktop /= 0 ) THEN ! water in the column + tmask(ji,jj,iktop:ikbot ) = 1._wp + ENDIF + END DO + END DO + ! + ! 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' ) + 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' ) + ! ------------------------ + IF ( ln_bdy .AND. ln_mask_file ) THEN + CALL iom_open( cn_mask_file, inum ) + CALL iom_get ( inum, jpdom_data, 'bdy_msk', bdytmask(:,:) ) + CALL iom_close( inum ) + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj) + END DO + END DO + END DO + ENDIF + + ! Ocean/land mask at u-, v-, and f-points (computed from tmask) + ! ---------------------------------------- + ! NB: at this point, fmask is designed for free slip lateral boundary condition + DO jk = 1, jpk + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector loop + umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) + vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) + END DO + DO ji = 1, jpim1 ! NO vector opt. + fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & + & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions + + ! Ocean/land mask at wu-, wv- and w points (computed from tmask) + !----------------------------------------- + wmask (:,:,1) = tmask(:,:,1) ! surface + wumask(:,:,1) = umask(:,:,1) + wvmask(:,:,1) = vmask(:,:,1) + DO jk = 2, jpk ! interior values + wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) + wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) + wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) + END DO + + + ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical) + ! ---------------------------------------------- + ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 ) + ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) + ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) + + + ! Interior domain mask (used for global sum) + ! -------------------- + ! + 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 + tmask_h( 1 :iif, : ) = 0._wp ! first columns + tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) + tmask_h( : , 1 :ijf) = 0._wp ! first rows + tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) + ! + ! ! north fold mask + tpol(1:jpiglo) = 1._wp + fpol(1:jpiglo) = 1._wp + IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot + tpol(jpiglo/2+1:jpiglo) = 0._wp + fpol( 1 :jpiglo) = 0._wp + IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h + DO ji = iif+1, iil-1 + tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) + END DO + ENDIF + ENDIF + ! + IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot + tpol( 1 :jpiglo) = 0._wp + fpol(jpiglo/2+1:jpiglo) = 0._wp + ENDIF + ! + ! ! interior mask : 2D ocean mask x halo mask + tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:) + + + ! Lateral boundary conditions on velocity (modify fmask) + ! --------------------------------------- + IF( rn_shlat /= 0 .OR. ln_shlat2d ) THEN ! Not free-slip lateral boundary condition + ! + DO jk = 1, jpk + 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 + 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( 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( 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( 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( 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 + ! + IF( ln_shlat2d ) DEALLOCATE( zshlat2d ) + ! + CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat + ! + ENDIF + + ! User defined alteration of fmask (use to reduce ocean transport in specified straits) + ! -------------------------------- + ! + CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) + ! + END SUBROUTINE dom_msk + + !!====================================================================== +END MODULE dommsk \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/domngb.F90 b/V4.0/nemo_sources/src/OCE/DOM/domngb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e6cdd9434cde0a6312cd8d8ff68df54d88abc6b --- /dev/null +++ b/V4.0/nemo_sources/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: domngb.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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 + iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) + kii = iloc(1) + nimpp - 1 + kjj = iloc(2) + njmpp - 1 + ENDIF + ! + END SUBROUTINE dom_ngb + + !!====================================================================== +END MODULE domngb diff --git a/V4.0/nemo_sources/src/OCE/DOM/domvvl.F90 b/V4.0/nemo_sources/src/OCE/DOM/domvvl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..930e53892180868667ce5223a8d2ab86dd4a65d6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/domvvl.F90 @@ -0,0 +1,1161 @@ +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 + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + INTERFACE dom_vvl_interpol + MODULE PROCEDURE dom_vvl_interpol_noopenmp, dom_vvl_interpol_openmp + END INTERFACE + + 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: domvvl.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 :: jj1, jj2, itid, ithreads ! openmp variables + 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, zwu, zwv, zhdiv + REAL(dp), DIMENSION(jpi,jpj) :: z_scale + 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 + + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2,& + !$omp& ijk_max,ijk_min,z2dt,z_tmin,z_tmax) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! ******************************* ! + ! After acale factors at t-points ! + ! ******************************* ! + ! ! --------------------------------------------- ! + ! ! z_star coordinate and barotropic z-tilde part ! + ! ! --------------------------------------------- ! + ! + z_scale(:,jj1:jj2) = ( ssha(:,jj1:jj2) - sshb(:,jj1:jj2) ) * ssmask(:,jj1:jj2) / ( ht_0(:,jj1:jj2) + sshn(:,jj1:jj2) + 1. - ssmask(:,jj1:jj2) ) + DO jk = 1, jpkm1 + ! formally this is the same as e3t_a = e3t_0*(1+ssha/ht_0) + e3t_a(:,jj1:jj2,jk) = e3t_b(:,jj1:jj2,jk) + e3t_n(:,jj1:jj2,jk) * z_scale(:,jj1:jj2) * tmask(:,jj1:jj2,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(:,jj1:jj2) = 0._wp + zht(:,jj1:jj2) = 0._wp + DO jk = 1, jpkm1 + zhdiv(:,jj1:jj2) = zhdiv(:,jj1:jj2) + e3t_n(:,jj1:jj2,jk) * hdivn(:,jj1:jj2,jk) + zht (:,jj1:jj2) = zht (:,jj1:jj2) + e3t_n(:,jj1:jj2,jk) * tmask(:,jj1:jj2,jk) + END DO + zhdiv(:,jj1:jj2) = zhdiv(:,jj1:jj2) / ( zht(:,jj1:jj2) + 1. - tmask_i(:,jj1:jj2) ) + + ! 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(:,jj1:jj2,jk) = hdiv_lf(:,jj1:jj2,jk) - rdt * frq_rst_hdv(:,jj1:jj2) & + & * ( hdiv_lf(:,jj1:jj2,jk) - e3t_n(:,jj1:jj2,jk) * ( hdivn(:,jj1:jj2,jk) - zhdiv(:,jj1:jj2) ) ) + END DO + ENDIF + ENDIF + + ! II - after z_tilde increments of vertical scale factors + ! ======================================================= + tilde_e3t_a(:,jj1:jj2,:) = 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(:,jj1:jj2,jk) = tilde_e3t_a(:,jj1:jj2,jk) - ( e3t_n(:,jj1:jj2,jk) * ( hdivn(:,jj1:jj2,jk) - zhdiv(:,jj1:jj2) ) - hdiv_lf(:,jj1:jj2,jk) ) + END DO + ELSE ! layer case + DO jk = 1, jpkm1 + tilde_e3t_a(:,jj1:jj2,jk) = tilde_e3t_a(:,jj1:jj2,jk) - e3t_n(:,jj1:jj2,jk) * ( hdivn(:,jj1:jj2,jk) - zhdiv(:,jj1:jj2) ) * tmask(:,jj1:jj2,jk) + END DO + ENDIF + + ! 2 - Restoring term (z-tilde case only) + ! ------------------ + IF( ln_vvl_ztilde ) THEN + DO jk = 1, jpk + tilde_e3t_a(:,jj1:jj2,jk) = tilde_e3t_a(:,jj1:jj2,jk) - frq_rst_e3t(:,jj1:jj2) * tilde_e3t_b(:,jj1:jj2,jk) + END DO + ENDIF + !$omp barrier + + ! 3 - Thickness diffusion term + ! ---------------------------- + zwu(:,jj1:jj2) = 0._wp + zwv(:,jj1:jj2) = 0._wp + DO jk = 1, jpkm1 ! a - first derivative: diffusive fluxes + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 + !$omp barrier + DO jk = 1, jpkm1 ! c - second derivative: divergence of diffusive fluxes + DO jj = MAX(2,jj1), MIN(jj2,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) + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) + !$omp end master + !$omp barrier + + ! 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 + !$omp barrier + !$omp master + CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,jj1:jj2,:), 'T', 1._wp ) + !$omp end master + !$omp barrier + tilde_e3t_a(:,jj1:jj2,:) = tilde_e3t_b(:,jj1:jj2,:) + z2dt * tmask(:,jj1:jj2,:) * tilde_e3t_a(:,jj1:jj2,:) + + ! Maximum deformation control + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ze3t(:,jj1:jj2,jpk) = 0._wp + DO jk = 1, jpkm1 + ze3t(:,jj1:jj2,jk) = tilde_e3t_a(:,jj1:jj2,jk) / e3t_0(:,jj1:jj2,jk) * tmask(:,jj1:jj2,jk) * tmask_i(:,jj1:jj2) + END DO + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier + ! - ML - end test + ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below + tilde_e3t_a(:,jj1:jj2,:) = MIN( tilde_e3t_a(:,jj1:jj2,:), rn_zdef_max * e3t_0(:,jj1:jj2,:) ) + tilde_e3t_a(:,jj1:jj2,:) = MAX( tilde_e3t_a(:,jj1:jj2,:), - rn_zdef_max * e3t_0(:,jj1:jj2,:) ) + + ! + ! "tilda" change in the after scale factor + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO jk = 1, jpkm1 + dtilde_e3t_a(:,jj1:jj2,jk) = tilde_e3t_a(:,jj1:jj2,jk) - tilde_e3t_b(:,jj1:jj2,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(:,jj1:jj2) = 0. + DO jk = 1, jpkm1 + zht(:,jj1:jj2) = zht(:,jj1:jj2) + tilde_e3t_a(:,jj1:jj2,jk) * tmask(:,jj1:jj2,jk) + END DO + z_scale(:,jj1:jj2) = - zht(:,jj1:jj2) / ( ht_0(:,jj1:jj2) + sshn(:,jj1:jj2) + 1. - ssmask(:,jj1:jj2) ) + DO jk = 1, jpkm1 + dtilde_e3t_a(:,jj1:jj2,jk) = dtilde_e3t_a(:,jj1:jj2,jk) + e3t_n(:,jj1:jj2,jk) * z_scale(:,jj1:jj2) * tmask(:,jj1:jj2,jk) + END DO + !$omp barrier + ENDIF + + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate ! + ! ! ---baroclinic part--------- ! + DO jk = 1, jpkm1 + e3t_a(:,jj1:jj2,jk) = e3t_a(:,jj1:jj2,jk) + dtilde_e3t_a(:,jj1:jj2,jk) * tmask(:,jj1:jj2,jk) + END DO + ENDIF + + IF( ln_vvl_dbg .AND. .NOT. ll_do_bclinic ) THEN ! - ML - test: control prints for debuging + ! + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier + END IF + + ! *********************************** ! + ! After scale factors at u- v- points ! + ! *********************************** ! + + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_a(:,:,:), e3u_a(:,:,:), 'U' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_a(:,:,:), e3v_a(:,:,:), 'V' ) + + ! *********************************** ! + ! After depths at u- v points ! + ! *********************************** ! + + hu_a(:,jj1:jj2) = e3u_a(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + hv_a(:,jj1:jj2) = e3v_a(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + hu_a(:,jj1:jj2) = hu_a(:,jj1:jj2) + e3u_a(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + hv_a(:,jj1:jj2) = hv_a(:,jj1:jj2) + e3v_a(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + END DO + ! ! Inverse of the local depth +!!gm BUG ? don't understand the use of umask_i here ..... + r1_hu_a(:,jj1:jj2) = ssumask(:,jj1:jj2) / ( hu_a(:,jj1:jj2) + 1._wp - ssumask(:,jj1:jj2) ) + r1_hv_a(:,jj1:jj2) = ssvmask(:,jj1:jj2) / ( hv_a(:,jj1:jj2) + 1._wp - ssvmask(:,jj1:jj2) ) + ! + !$omp end parallel + ! + 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + 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 + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2,zcoef) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! + ! 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(:,jj1:jj2,:) = tilde_e3t_n(:,jj1:jj2,:) + ELSE + tilde_e3t_b(:,jj1:jj2,:) = tilde_e3t_n(:,jj1:jj2,:) & + & + atfp * ( tilde_e3t_b(:,jj1:jj2,:) - 2.0_wp * tilde_e3t_n(:,jj1:jj2,:) + tilde_e3t_a(:,jj1:jj2,:) ) + ENDIF + tilde_e3t_n(:,jj1:jj2,:) = tilde_e3t_a(:,jj1:jj2,:) + ENDIF + gdept_b(:,jj1:jj2,:) = gdept_n(:,jj1:jj2,:) + gdepw_b(:,jj1:jj2,:) = gdepw_n(:,jj1:jj2,:) + + e3t_n(:,jj1:jj2,:) = e3t_a(:,jj1:jj2,:) + e3u_n(:,jj1:jj2,:) = e3u_a(:,jj1:jj2,:) + e3v_n(:,jj1:jj2,:) = e3v_a(:,jj1:jj2,:) + + ! 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( jj1, jj2, .TRUE., e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) + + ! Vertical scale factor interpolations + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_n(:,:,:), e3w_n(:,:,:), 'W' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_b(:,:,:), e3w_b(:,:,:), 'W' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) + + ! t- and w- points depth (set the isf depth as it is in the initial step) + gdept_n(:,jj1:jj2,1) = 0.5_wp * e3w_n(:,jj1:jj2,1) + gdepw_n(:,jj1:jj2,1) = 0.0_wp + gde3w_n(:,jj1:jj2,1) = gdept_n(:,jj1:jj2,1) - sshn(:,jj1:jj2) + !$omp barrier + DO jk = 2, jpk + DO jj = MAX(1,jj1),MIN(jj2,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 + !$omp barrier + END DO + + ! Local depth and Inverse of the local depth of the water + ! ------------------------------------------------------- + hu_n(:,jj1:jj2) = hu_a(:,jj1:jj2) ; r1_hu_n(:,jj1:jj2) = r1_hu_a(:,jj1:jj2) + hv_n(:,jj1:jj2) = hv_a(:,jj1:jj2) ; r1_hv_n(:,jj1:jj2) = r1_hv_a(:,jj1:jj2) + ! + ht_n(:,jj1:jj2) = e3t_n(:,jj1:jj2,1) * tmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + ht_n(:,jj1:jj2) = ht_n(:,jj1:jj2) + e3t_n(:,jj1:jj2,jk) * tmask(:,jj1:jj2,jk) + END DO + + !$omp end parallel + + ! 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_noopenmp( 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3 + CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors + + CALL dom_vvl_interpol_openmp( 1, jpj, .FALSE., pe3_in, pe3_out, pout ) + + END SUBROUTINE dom_vvl_interpol_noopenmp + + SUBROUTINE dom_vvl_interpol_openmp( jj1, jj2, llomp, 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 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: jj1, jj2 ! OpenMP loop + LOGICAL, INTENT(in) :: llomp ! + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated + REAL(dp), 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 + ! + !$ IF (llomp) THEN + !$omp barrier + !$ ENDIF + ! + SELECT CASE ( pout ) !== type of interpolation ==! + ! + CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = MAX(1,jj1), MIN(jj2,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 + IF (llomp) THEN + !$omp barrier + !$omp master + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp ) + !$omp end master + !$omp barrier + ELSE + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp ) + ENDIF + pe3_out(:,jj1:jj2,:) = pe3_out(:,jj1:jj2,:) + e3u_0(:,jj1:jj2,:) + ! + CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = MAX(1,jj1), MIN(jj2,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 + IF (llomp) THEN + !$omp barrier + !$omp master + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp ) + !$omp end master + !$omp barrier + ELSE + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp ) + ENDIF + pe3_out(:,jj1:jj2,:) = pe3_out(:,jj1:jj2,:) + e3v_0(:,jj1:jj2,:) + ! + CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = MAX(1,jj1), MIN(jj2,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 + IF (llomp) THEN + !$omp barrier + !$omp master + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp ) + !$omp end master + !$omp barrier + ELSE + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp ) + ENDIF + pe3_out(:,jj1:jj2,:) = pe3_out(:,jj1:jj2,:) + e3f_0(:,jj1:jj2,:) + ! + CASE( 'W' ) !* from T- to W-point : vertical simple mean + ! + pe3_out(:,jj1:jj2,1) = e3w_0(:,jj1:jj2,1) + pe3_in(:,jj1:jj2,1) - e3t_0(:,jj1:jj2,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(:,jj1:jj2,jk) = e3w_0(:,jj1:jj2,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,jj1:jj2,jk-1) - e3t_0(:,jj1:jj2,jk-1) ) & + & + 0.5_wp * ( tmask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,jj1:jj2,jk ) - e3t_0(:,jj1:jj2,jk ) ) + END DO + ! + CASE( 'UW' ) !* from U- to UW-point : vertical simple mean + ! + pe3_out(:,jj1:jj2,1) = e3uw_0(:,jj1:jj2,1) + pe3_in(:,jj1:jj2,1) - e3u_0(:,jj1:jj2,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(:,jj1:jj2,jk) = e3uw_0(:,jj1:jj2,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,jj1:jj2,jk-1) - e3u_0(:,jj1:jj2,jk-1) ) & + & + 0.5_wp * ( umask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,jj1:jj2,jk ) - e3u_0(:,jj1:jj2,jk ) ) + END DO + ! + CASE( 'VW' ) !* from V- to VW-point : vertical simple mean + ! + pe3_out(:,jj1:jj2,1) = e3vw_0(:,jj1:jj2,1) + pe3_in(:,jj1:jj2,1) - e3v_0(:,jj1:jj2,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(:,jj1:jj2,jk) = e3vw_0(:,jj1:jj2,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,jj1:jj2,jk-1) - e3v_0(:,jj1:jj2,jk-1) ) & + & + 0.5_wp * ( vmask(:,jj1:jj2,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,jj1:jj2,jk ) - e3v_0(:,jj1:jj2,jk ) ) + END DO + END SELECT + ! + !$ IF (llomp) THEN + !$omp barrier + !$ ENDIF + ! + END SUBROUTINE dom_vvl_interpol_openmp + + + 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 ) + ! + IF ( nn_slimrstin < 2 .OR. kt >= nitend - nn_fsbc ) THEN + 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. ) + ELSE + id1 = 0 + id2 = 0 + id3 = 0 + id4 = 0 + id5 = 0 + ENDIF + ! ! --------- ! + ! ! 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 ! + ! ! --------- ! + IF ( nn_slimrst < 2 .OR. kt >= nitend - nn_fsbc ) THEN + ! + 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 + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/domwri.F90 b/V4.0/nemo_sources/src/OCE/DOM/domwri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..166e6df5803540b688ad7c06d731c7cb9b72b051 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/domwri.F90 @@ -0,0 +1,302 @@ +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 + PUBLIC dom_uniq ! called by sglexe couplinb + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domwri.F90 11532 2019-09-11 13:30:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : create a file with all domain related arrays + !! + !! ** output file : meshmask.nc : domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !!---------------------------------------------------------------------- + INTEGER :: inum ! temprary units for 'mesh_mask.nc' file + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: izco, izps, isco, icav + ! + REAL(dp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace + REAL(dp), 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., ldnoov = .FALSE. ) + ! + ! ! 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', pval = 0.0_wp ) + 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', pval = 0.0_wp ) + 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', pval = 0.0_wp ) + 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, pval ) + !!---------------------------------------------------------------------- + !! *** 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(dp), DIMENSION(:,:), INTENT(inout) :: puniq ! + REAL(wp), OPTIONAL, INTENT(in ) :: pval + ! + REAL(dp) :: 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(dp), 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.0_wp ) ! apply boundary conditions + lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed + ! + IF (PRESENT(pval)) THEN + puniq(:,:) = pval ! user definition + ELSE + puniq(:,:) = 1. ! default definition + ENDIF + ! 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(dp), 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.0_wp ) + ! + IF( PRESENT( px1 ) ) px1 = zx1 + ! + zrxmax = MAXVAL( zx1 ) + ! + CALL mpp_max( 'domwri', zrxmax ) ! max over the global domain + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax + WRITE(numout,*) '~~~~~~~~~' + ENDIF + ! + END SUBROUTINE dom_stiff + + !!====================================================================== +END MODULE domwri \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/domzgr.F90 b/V4.0/nemo_sources/src/OCE/DOM/domzgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bae5f77aa13d630f3b323aa7c0a5a0c58ab90075 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/domzgr.F90 @@ -0,0 +1,321 @@ +MODULE domzgr + !!============================================================================== + !! *** MODULE domzgr *** + !! Ocean domain : definition of the vertical coordinate system + !!============================================================================== + !! History : OPA ! 1995-12 (G. Madec) Original code : s vertical coordinate + !! ! 1997-07 (G. Madec) lbc_lnk call + !! ! 1997-04 (J.-O. Beismann) + !! 8.5 ! 2002-09 (A. Bozec, G. Madec) F90: Free form and module + !! - ! 2002-09 (A. de Miranda) rigid-lid + islands + !! NEMO 1.0 ! 2003-08 (G. Madec) F90: Free form and module + !! - ! 2005-10 (A. Beckmann) modifications for hybrid s-ccordinates & new stretching function + !! 2.0 ! 2006-04 (R. Benshila, G. Madec) add zgr_zco + !! 3.0 ! 2008-06 (G. Madec) insertion of domzgr_zps.h90 & conding style + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case + !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye + !! 3.? ! 2015-11 (H. Liu) Modifications for Wetting/Drying + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_zgr : read or set the ocean vertical coordinate system + !! zgr_read : read the vertical information in the domain configuration file + !! zgr_top_bot : ocean top and bottom level for t-, u, and v-points with 1 as minimum value + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE usrdef_zgr ! user defined vertical coordinate system + USE closea ! closed seas + USE depth_e3 ! depth <=> e3 + USE wet_dry, ONLY: ll_wd, ssh_ref ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_zgr ! called by dom_init.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domzgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_zgr( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_zgr *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) + !! - read/set ocean depth and ocean levels (bathy, mbathy) + !! - vertical coordinate (gdep., e3.) depending on the + !! coordinate chosen : + !! ln_zco=T z-coordinate + !! ln_zps=T z-coordinate with partial steps + !! ln_zco=T s-coordinate + !! + !! ** Action : define gdep., e3., mbathy and bathy + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices + ! + INTEGER :: jk ! dummy loop index + INTEGER :: ioptio, ibat, ios ! local integer + REAL(dp) :: 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' ) + + + ! ! 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! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(out) :: pdepw_1d! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3uw, pe3vw! - - - + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3w! - - - + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + ! + INTEGER :: jk ! dummy loop index + INTEGER :: inum ! local logical unit + REAL(dp) :: z_zco, z_zps, z_sco, z_cav + REAL(dp), 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(dp), 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.0_wp ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + END SUBROUTINE zgr_top_bot + + !!====================================================================== +END MODULE domzgr \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/dtatsd.F90 b/V4.0/nemo_sources/src/OCE/DOM/dtatsd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b644855b174480795f42720a0af2227e517f7f68 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/dtatsd.F90 @@ -0,0 +1,271 @@ +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: dtatsd.F90 14185 2020-12-16 10:32:22Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_tsd_init( ld_tradmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_tsd_init *** + !! + !! ** Purpose : initialisation of T & S input data + !! + !! ** Method : - Read namtsd namelist + !! - allocates T & S data structure + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ld_tradmp ! force the initialization when tradp is used + ! + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N), DIMENSION( jpts) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_tem, sn_sal + !! + NAMELIST/namtsd/ ln_tsd_init, ln_tsd_dmp, cn_dir, sn_tem, sn_sal + !!---------------------------------------------------------------------- + ! + ! Initialisation + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + ! + 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 + 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(dp), 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 + INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n + 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 + irec_n(jp_tem) = sf_tsd(jp_tem)%nrec_a(2) ! Determine if there is new data (ln_tint = F) + irec_n(jp_sal) = sf_tsd(jp_sal)%nrec_a(2) ! If not, then do not apply the increments + IF( kt == nit000 ) irec_b(:) = -1 + ! + ij0 = 101 ; ij1 = 109 ! Reduced T & S in the Alboran Sea + ii0 = 141 ; ii1 = 155 + IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp + sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp + sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp + END DO + END DO + irec_b(jp_tem) = irec_n(jp_tem) + ENDIF + ! + IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp + sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp + sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp + sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp + END DO + END DO + irec_b(jp_sal) = irec_n(jp_sal) + ENDIF + ! + ij0 = 87 ; 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/iscplhsb.F90 b/V4.0/nemo_sources/src/OCE/DOM/iscplhsb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bb6f7282ee09863b20ad9d42636d3163ca51de61 --- /dev/null +++ b/V4.0/nemo_sources/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: iscplhsb.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/iscplini.F90 b/V4.0/nemo_sources/src/OCE/DOM/iscplini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e14ae49a640bccdd82448e949e2094635c6e11e --- /dev/null +++ b/V4.0/nemo_sources/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: iscplini.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/iscplrst.F90 b/V4.0/nemo_sources/src/OCE/DOM/iscplrst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ab8588cafa37cfdd6b39ae41eefbde867610303c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/iscplrst.F90 @@ -0,0 +1,409 @@ +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: iscplrst.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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', zsmask1, 'T', 1.0_wp ) + CALL lbc_lnk_multi( 'iscplrst', sshn, 'T', 1.0_wp ) + 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.0_wp, tsn(:,:,:,jp_sal), 'T', 1.0_wp ) + CALL lbc_lnk_multi( 'iscplrst', ztmask1, 'T', 1.0_wp) + + ! 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/V4.0/nemo_sources/src/OCE/DOM/istate.F90 b/V4.0/nemo_sources/src/OCE/DOM/istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0b17a967af094fed558939e34bff878667b88ced --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/istate.F90 @@ -0,0 +1,180 @@ +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: istate.F90 13101 2020-06-12 11:10:44Z rblod $ + !! 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_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DOM/phycst.F90 b/V4.0/nemo_sources/src/OCE/DOM/phycst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dfecbe426a1bc2f66732ce00b0fd7a08efbd2fe0 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DOM/phycst.F90 @@ -0,0 +1,140 @@ +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 :: rauw = 1000._wp !: volumic mass of pure water (kg/m3) + 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: phycst.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/divhor.F90 b/V4.0/nemo_sources/src/OCE/DYN/divhor.F90 new file mode 100644 index 0000000000000000000000000000000000000000..55a9cd58b74a08ceb80a131dc475b922f0935eae --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/divhor.F90 @@ -0,0 +1,141 @@ +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 + USE nopenmp ! OpenMP library + + 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: divhor.F90 12737 2020-04-10 17:55:11Z jchanut $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + !!---------------------------------------------------------------------- + ! + 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 + ! + ! + !$omp parallel private(ji,jj,jk,itid,ithreads,jj1,jj2,zraur,zdep) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + DO jk = 1, jpkm1 !== Horizontal divergence ==! + DO jj = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier +#endif + ! + IF( ln_rnf ) CALL sbc_rnf_div( itid, jj1, jj2 ,hdivn ) !== runoffs ==! (update hdivn field) + ! +#if defined key_asminc + IF( ln_sshinc .AND. ln_asmiau ) THEN + !$omp barrier + !$omp master + CALL ssh_asm_div( kt, hdivn ) !== SSH assimilation ==! (update hdivn field) + !$omp end master + !$omp barrier + ENDIF + ! +#endif + IF( ln_isf ) CALL sbc_isf_div( itid, jj1, jj2, hdivn ) !== ice shelf ==! (update hdivn field) + ! + IF( ln_iscpl .AND. ln_hsb ) THEN + !$omp barrier + !$omp master + CALL iscpl_div( hdivn ) !== ice sheet ==! (update hdivn field) + !$omp end master + !$omp barrier + ENDIF + ! + !$omp end parallel + ! + CALL lbc_lnk( 'divhor', hdivn, 'T', 1.0_wp ) ! (no sign change) + ! + IF( ln_timing ) CALL timing_stop('div_hor') + ! + END SUBROUTINE div_hor + + !!====================================================================== +END MODULE divhor \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynadv.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynadv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..85a37b05bd46ffb5e878ab8a5f5d349ef2587d4e --- /dev/null +++ b/V4.0/nemo_sources/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: dynadv.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynadv_cen2.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynadv_cen2.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ce04a53614a381a6931a3680b386e656c93aca29 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynadv_cen2.F90 @@ -0,0 +1,149 @@ +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: dynadv_cen2.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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_f, zfu + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_vw + !!---------------------------------------------------------------------- + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynadv_ubs.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynadv_ubs.F90 new file mode 100644 index 0000000000000000000000000000000000000000..83627aa0e305da0ef2ea58d3f80d0f8370570cf3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynadv_ubs.F90 @@ -0,0 +1,242 @@ +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: dynadv_ubs.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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_f, zfu + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_vw + 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.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp, & + & zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp, & + & zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp, & + & zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp ) + ! + ! ! ====================== ! + ! ! Horizontal advection ! + DO jk = 1, jpkm1 ! ====================== ! + ! ! horizontal volume fluxes + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynhpg.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynhpg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6b93a5e028f9b7c42fd213357ab788575469f337 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynhpg.F90 @@ -0,0 +1,1492 @@ +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 biaspar ! bias correction variables + 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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynhpg.F90 13095 2020-06-11 12:08:55Z jamesharle $ + !! 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(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + REAL(dp), DIMENSION(jpi,jpj,jpk) :: z_rhd_st ! for pressure correction + REAL(dp), DIMENSION(jpi,jpj) :: z_gru_st ! for pressure correction + REAL(dp), DIMENSION(jpi,jpj) :: z_grv_st ! for pressure correction + !!---------------------------------------------------------------------- + ! + 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 + ! + IF ( ln_bias .AND. ln_bias_pc_app ) THEN + z_rhd_st(:,:,:) = rhd(:,:,:) ! store orig density + rhd(:,:,:) = rhd_pc(:,:,:) ! use pressure corrected density + z_gru_st(:,:) = gru(:,:) + gru(:,:) = gru_pc(:,:) + z_grv_st(:,:) = grv(:,:) + grv(:,:) = grv_pc(:,:) + 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_bias .AND. ln_bias_pc_app ) THEN + rhd(:,:,:) = z_rhd_st(:,:,:) ! restore original density + gru(:,:) = z_gru_st(:,:) + grv(:,:) = z_grv_st(:,:) + ENDIF + + 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(dp) :: 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(:,:,:), CASTSP(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 + REAL(dp), DIMENSION(jpi,jpj) :: 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(dp) :: zcoef0, zuap, zvap, znad, ztmp ! temporary scalars + LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj + REAL(dp), 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.0_wp, zcpy, 'V', 1.0_wp ) + END IF + + ! 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 + ! + 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.0_wp, zcpy, 'V', 1.0_wp ) + 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.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) + + ! --------------- + ! 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.0_wp, zcpy, 'V', 1.0_wp ) + 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.0_wp, zsshv_n, 'V', 1.0_wp ) + + 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) :: fl, fr + REAL(dp), INTENT(in) :: x, xl, xr + REAL(wp) :: f ! result of the interpolation (extrapolation) + REAL(wp) :: zdeltx + !!---------------------------------------------------------------------- + ! + zdeltx = xr - xl + IF( abs(zdeltx) <= 10._wp * EPSILON(x) ) THEN + f = 0.5_wp * (fl + fr) + ELSE + f = ( (x - xl ) * fr - ( x - xr ) * fl ) / zdeltx + ENDIF + ! + END FUNCTION interp1 + + + FUNCTION interp2( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline interpolation + !! + !! ** Method : cubic spline interpolation + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = a + x* ( b + x * ( c + d * x ) ) + ! + END FUNCTION interp2 + + + FUNCTION interp3( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : Calculate the first order of derivative of + !! a cubic spline function y=a+b*x+c*x^2+d*x^3 + !! + !! ** Method : f=dy/dx=b+2*c*x+3*d*x^2 + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = b + x * ( 2._wp * c + 3._wp * d * x) + ! + END FUNCTION interp3 + + + FUNCTION integ_spline( xl, xr, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline integration + !! + !! ** Method : integrate polynomial a+bx+cx^2+dx^3 from xl to xr + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: xl, xr, a, b, c, d + REAL(wp) :: za1, za2, za3 + REAL(wp) :: f ! integration result + !!---------------------------------------------------------------------- + ! + za1 = 0.5_wp * b + za2 = c / 3.0_wp + za3 = 0.25_wp * d + ! + f = xr * ( a + xr * ( za1 + xr * ( za2 + za3 * xr ) ) ) - & + & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) ) + ! + END FUNCTION integ_spline + + !!====================================================================== +END MODULE dynhpg \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynkeg.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynkeg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c9092e07b893a7113b4de9ce62200f805f7822d1 --- /dev/null +++ b/V4.0/nemo_sources/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: dynkeg.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp), 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.0_wp ) + ! + 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) + va(ji,jj,jk) = va(ji,jj,jk) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic + ztrdu(:,:,:) = 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynldf.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynldf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e8d6caa31ea9fd86628ec989a29bf6c3394c3b5e --- /dev/null +++ b/V4.0/nemo_sources/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: dynldf.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_ldf') + ! + IF( l_trddyn ) THEN ! temporary save of momentum trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynldf_iso.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynldf_iso.F90 new file mode 100644 index 0000000000000000000000000000000000000000..09ed1d88599aaa983f042727ed7037807c778a57 --- /dev/null +++ b/V4.0/nemo_sources/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: dynldf_iso.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + ! + ENDIF + + zaht_0 = 0.5_wp * rn_Ud * rn_Ld ! aht_0 from namtra_ldf = zaht_max + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + ! Vertical u- and v-shears at level jk and jk+1 + ! --------------------------------------------- + ! surface boundary condition: zdku(jk=1)=zdku(jk=2) + ! zdkv(jk=1)=zdkv(jk=2) + + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynldf_lap_blp.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynldf_lap_blp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..064ea5fb2505fb3963858ade3be68d66850b62e9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynldf_lap_blp.F90 @@ -0,0 +1,143 @@ +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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf_lap_blp.F90 12791 2020-04-21 20:41:25Z smasson $ + !! 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(dp), 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! momentum trend + ! + REAL(dp), 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.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + CALL dyn_ldf_lap( kt, CASTSP(zulap), CASTSP(zvlap), pua, pva, 2 ) ! rotated laplacian applied to zlap (output in pta) + ! + END SUBROUTINE dyn_ldf_blp + + !!====================================================================== +END MODULE dynldf_lap_blp \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynnxt.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynnxt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ef04c41e36ce21256dfae1f0436fad4f4e60a532 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynnxt.F90 @@ -0,0 +1,423 @@ +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 + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_nxt ! routine called by step.F90 + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynnxt.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 :: jj1, jj2, itid, ithreads ! openmp variables + INTEGER :: ikt ! local integers + REAL(wp) :: zue3a, zue3n, zue3b, zuf! local scalars + REAL(dp) :: zcoef! local scalars + REAL(wp) :: zve3a, zve3n, zve3b, zvf, z1_2dt ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + REAL(dp), 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( .NOT.ln_dynadv_vec ) ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) ) + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_nxt : time stepping' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2, & + !$omp& zue3a,zue3n,zue3b,zuf,zcoef,zve3a,zve3n,zve3b,zvf,z1_2dt) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + 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(:,jj1:jj2) = e3u_a(:,jj1:jj2,1) * ua(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + zve(:,jj1:jj2) = e3v_a(:,jj1:jj2,1) * va(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + zue(:,jj1:jj2) = zue(:,jj1:jj2) + e3u_a(:,jj1:jj2,jk) * ua(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + zve(:,jj1:jj2) = zve(:,jj1:jj2) + e3v_a(:,jj1:jj2,jk) * va(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + END DO + DO jk = 1, jpkm1 + ua(:,jj1:jj2,jk) = ( ua(:,jj1:jj2,jk) - zue(:,jj1:jj2) * r1_hu_a(:,jj1:jj2) + ua_b(:,jj1:jj2) ) * umask(:,jj1:jj2,jk) + va(:,jj1:jj2,jk) = ( va(:,jj1:jj2,jk) - zve(:,jj1:jj2) * r1_hv_a(:,jj1:jj2) + va_b(:,jj1:jj2) ) * vmask(:,jj1:jj2,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(:,jj1:jj2,jk) = ( un(:,jj1:jj2,jk) - un_adv(:,jj1:jj2)*r1_hu_n(:,jj1:jj2) + un_b(:,jj1:jj2) )*umask(:,jj1:jj2,jk) + vn(:,jj1:jj2,jk) = ( vn(:,jj1:jj2,jk) - vn_adv(:,jj1:jj2)*r1_hv_n(:,jj1:jj2) + vn_b(:,jj1:jj2) )*vmask(:,jj1:jj2,jk) + END DO + ENDIF + ENDIF + + !$omp barrier + !$omp master + + ! 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.0_wp, va, 'V', -1.0_wp ) !* 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 + + !$omp end master + !$omp barrier + + ! 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(:,jj1:jj2,jk) = un(:,jj1:jj2,jk) ! ub <-- un + vb(:,jj1:jj2,jk) = vn(:,jj1:jj2,jk) + un(:,jj1:jj2,jk) = ua(:,jj1:jj2,jk) ! un <-- ua + vn(:,jj1:jj2,jk) = va(:,jj1:jj2,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(:,jj1:jj2,jk) = e3t_n(:,jj1:jj2,jk) +! e3u_b(:,jj1:jj2,jk) = e3u_n(:,jj1:jj2,jk) +! e3v_b(:,jj1:jj2,jk) = e3v_n(:,jj1:jj2,jk) + ! + e3t_n(:,jj1:jj2,jk) = e3t_a(:,jj1:jj2,jk) + e3u_n(:,jj1:jj2,jk) = e3u_a(:,jj1:jj2,jk) + e3v_n(:,jj1:jj2,jk) = e3v_a(:,jj1:jj2,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(:,jj1:jj2,jk) = e3t_n(:,jj1:jj2,jk) + atfp * ( e3t_b(:,jj1:jj2,jk) - 2._wp * e3t_n(:,jj1:jj2,jk) + e3t_a(:,jj1:jj2,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(:,jj1:jj2,jk) = e3t_b(:,jj1:jj2,jk) - zcoef * ( emp_b(:,jj1:jj2) - emp(:,jj1:jj2) ) * tmask(:,jj1:jj2,jk) & + & * e3t_n(:,jj1:jj2,jk) / ( ht_n(:,jj1:jj2) + 1._wp - ssmask(:,jj1:jj2) ) + END DO + + IF ( ln_rnf ) THEN + DO jk = 1, jpkm1 + e3t_b(:,jj1:jj2,jk) = e3t_b(:,jj1:jj2,jk) + zcoef * ( rnf_b(:,jj1:jj2) - rnf(:,jj1:jj2) ) * tmask(:,jj1:jj2,jk) & + & * e3t_n(:,jj1:jj2,jk) / ( ht_n(:,jj1:jj2) + 1._wp - ssmask(:,jj1:jj2) ) + END DO + ENDIF + + IF ( ln_isf ) THEN + DO jk = 1, jpkm1 + e3t_b(:,jj1:jj2,jk) = e3t_b(:,jj1:jj2,jk) - zcoef * ( fwfisf_b(:,jj1:jj2) - fwfisf(:,jj1:jj2) ) * tmask(:,jj1:jj2,jk) & + & * e3t_n(:,jj1:jj2,jk) / ( ht_n(:,jj1:jj2) + 1._wp - ssmask(:,jj1:jj2) ) + 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( jj1, jj2, .TRUE., e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) + DO jk = 1, jpkm1 + DO jj = MAX(1,jj1), MIN(jj2,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 + ! + ! Before filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_b(:,:,:), ze3u_f, 'U' ) + CALL dom_vvl_interpol( jj1, jj2, .TRUE., e3t_b(:,:,:), ze3v_f, 'V' ) + DO jk = 1, jpkm1 + DO jj = MAX(1,jj1), MIN(jj2,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(:,jj1:jj2,1:jpkm1) = ze3u_f(:,jj1:jj2,1:jpkm1) ! e3u_b <-- filtered scale factor + e3v_b(:,jj1:jj2,1:jpkm1) = ze3v_f(:,jj1:jj2,1:jpkm1) + ! + 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(:,jj1:jj2) = e3u_b(:,jj1:jj2,1) * ub(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + zve(:,jj1:jj2) = e3v_b(:,jj1:jj2,1) * vb(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + zue(:,jj1:jj2) = zue(:,jj1:jj2) + e3u_b(:,jj1:jj2,jk) * ub(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + zve(:,jj1:jj2) = zve(:,jj1:jj2) + e3v_b(:,jj1:jj2,jk) * vb(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + END DO + DO jk = 1, jpkm1 + ub(:,jj1:jj2,jk) = ub(:,jj1:jj2,jk) - (zue(:,jj1:jj2) * r1_hu_n(:,jj1:jj2) - un_b(:,jj1:jj2)) * umask(:,jj1:jj2,jk) + vb(:,jj1:jj2,jk) = vb(:,jj1:jj2,jk) - (zve(:,jj1:jj2) * r1_hv_n(:,jj1:jj2) - vn_b(:,jj1:jj2)) * vmask(:,jj1:jj2,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(:,jj1:jj2) = e3u_b(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + hv_b(:,jj1:jj2) = e3v_b(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + hu_b(:,jj1:jj2) = hu_b(:,jj1:jj2) + e3u_b(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + hv_b(:,jj1:jj2) = hv_b(:,jj1:jj2) + e3v_b(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + END DO + r1_hu_b(:,jj1:jj2) = ssumask(:,jj1:jj2) / ( hu_b(:,jj1:jj2) + 1._wp - ssumask(:,jj1:jj2) ) + r1_hv_b(:,jj1:jj2) = ssvmask(:,jj1:jj2) / ( hv_b(:,jj1:jj2) + 1._wp - ssvmask(:,jj1:jj2) ) + ENDIF + ! + un_b(:,jj1:jj2) = e3u_a(:,jj1:jj2,1) * un(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + ub_b(:,jj1:jj2) = e3u_b(:,jj1:jj2,1) * ub(:,jj1:jj2,1) * umask(:,jj1:jj2,1) + vn_b(:,jj1:jj2) = e3v_a(:,jj1:jj2,1) * vn(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + vb_b(:,jj1:jj2) = e3v_b(:,jj1:jj2,1) * vb(:,jj1:jj2,1) * vmask(:,jj1:jj2,1) + DO jk = 2, jpkm1 + un_b(:,jj1:jj2) = un_b(:,jj1:jj2) + e3u_a(:,jj1:jj2,jk) * un(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + ub_b(:,jj1:jj2) = ub_b(:,jj1:jj2) + e3u_b(:,jj1:jj2,jk) * ub(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + vn_b(:,jj1:jj2) = vn_b(:,jj1:jj2) + e3v_a(:,jj1:jj2,jk) * vn(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + vb_b(:,jj1:jj2) = vb_b(:,jj1:jj2) + e3v_b(:,jj1:jj2,jk) * vb(:,jj1:jj2,jk) * vmask(:,jj1:jj2,jk) + END DO + un_b(:,jj1:jj2) = un_b(:,jj1:jj2) * r1_hu_a(:,jj1:jj2) + vn_b(:,jj1:jj2) = vn_b(:,jj1:jj2) * r1_hv_a(:,jj1:jj2) + ub_b(:,jj1:jj2) = ub_b(:,jj1:jj2) * r1_hu_b(:,jj1:jj2) + vb_b(:,jj1:jj2) = vb_b(:,jj1:jj2) * r1_hv_b(:,jj1:jj2) + ! + !$omp end parallel + ! + 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.0_wp) + 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.0_wp) + CALL iom_put( "vtau", zvtau(:,:) ) + DEALLOCATE(zvtau) + ELSE + CALL iom_put( "vtau", vtau(:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=CASTDP(un), clinfo1=' nxt - Un: ', mask1=umask, & + & tab3d_2=CASTDP(vn), clinfo2=' Vn: ' , mask2=vmask ) + ! + IF( .NOT.ln_dynadv_vec ) DEALLOCATE( ze3u_f, ze3v_f ) + 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/V4.0/nemo_sources/src/OCE/DYN/dynspg.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynspg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c2996ca1a80a892b2ff6bc82b36bacf94fd465bb --- /dev/null +++ b/V4.0/nemo_sources/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: dynspg.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_spg') + ! + IF( l_trddyn ) THEN ! temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = 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) + va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) + END DO + END DO + END DO + ! +!!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ???? + ! + ENDIF + ! + SELECT CASE ( nspg ) !== surface pressure gradient computed and add to the general trend ==! + CASE ( np_EXP ) ; CALL dyn_spg_exp( kt ) ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynspg_exp.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynspg_exp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4ad7107f4a66ec8f4265725393facff752520fb9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynspg_exp.F90 @@ -0,0 +1,100 @@ +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 + USE timing ! Timing + + 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: dynspg_exp.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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( ln_timing_detail ) CALL timing_start('dyn_spg_exp') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('dyn_spg_exp') + ! + END SUBROUTINE dyn_spg_exp + + !!====================================================================== +END MODULE dynspg_exp \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynspg_ts.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynspg_ts.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b0bfdada2b3cc7b3af1ccb0c57ace6150b60d289 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynspg_ts.F90 @@ -0,0 +1,1704 @@ +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 timing ! Timing + USE nopenmp ! OpenMP library + + 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv , vn_adv !: Advection vel. at C@7FU barocl. step + ! + INTEGER, SAVE :: icycle ! Number of barotropic sub-steps for each internal step nn_baro <= 2.5 nn_baro + REAL(dp),SAVE :: rdtbt ! Barotropic time step + ! + REAL(dp), 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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg_ts.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + 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(dp) :: za0, za1, za2, za3 ! - - + REAL(wp) :: zztmp, zldg ! - - + REAL(wp) :: zhu_bck, zhv_bck! - - + REAL(dp) :: zhdiv! - - + REAL(wp) :: zun_save, zvn_save ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zu_spg + REAL(dp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zssh_frc + REAL(wp), DIMENSION(jpi,jpj) :: zv_spg + REAL(dp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc + REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e + REAL(dp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points + REAL(wp), DIMENSION(jpi,jpj) :: zhV! fluxes + REAL(dp), DIMENSION(jpi,jpj) :: zhU! 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_timing_detail ) CALL timing_start('dyn_spg_ts') + ! + 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 + ! + + !$omp parallel private(itid,ithreads,ji,jj,jk,jn,jj1,jj2,za0,za1,za2,za3,& + !$omp & l_full_nf_update,zldg,zhu_bck,zhv_bck,z1_hu,z1_hv,zhdiv,zztmp,& + !$omp & zun_save,zvn_save) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! ----------------------------------------------------------------------------- + ! 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(:,jj1:jj2) = SUM( e3u_n(:,jj1:jj2,:) * ua(:,jj1:jj2,:) * umask(:,jj1:jj2,:) , DIM=3 ) * r1_hu_n(:,jj1:jj2) + zv_frc(:,jj1:jj2) = SUM( e3v_n(:,jj1:jj2,:) * va(:,jj1:jj2,:) * vmask(:,jj1:jj2,:) , DIM=3 ) * r1_hv_n(:,jj1:jj2) + ! + ! + ! != Ua => baroclinic trend =! (remove its vertical mean) + DO jk = 1, jpkm1 ! ------------------------ ! + ua(:,jj1:jj2,jk) = ( ua(:,jj1:jj2,jk) - zu_frc(:,jj1:jj2) ) * umask(:,jj1:jj2,jk) + va(:,jj1:jj2,jk) = ( va(:,jj1:jj2,jk) - zv_frc(:,jj1:jj2) ) * vmask(:,jj1:jj2,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 =! + ! ! ------------------------------------------------- ! + ! + !$omp master + IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2d_init ! Set zwz, the barotropic Coriolis force coefficient + !$omp end master + !$omp barrier + ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes + ! + ! !* 2D Coriolis trends + zhU(:,jj1:jj2) = un_b(:,jj1:jj2) * hu_n(:,jj1:jj2) * e2u(:,jj1:jj2) ! now fluxes + zhV(:,jj1:jj2) = vn_b(:,jj1:jj2) * hv_n(:,jj1:jj2) * e1v(:,jj1:jj2) ! NB: FULL domain : put a value in last row and column + ! + !$omp barrier + CALL dyn_cor_2d( jj1, jj2, 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( jj1, jj2, CASTSP(sshn), zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 =! + ! ! ----------------------------------------------------------- ! + !$omp barrier + CALL dyn_drg_init( jj1, jj2, zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients + !$omp barrier + ! + ! != 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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2) = r1_rau0 * ( emp(:,jj1:jj2) - rnf(:,jj1:jj2) + fwfisf(:,jj1:jj2) ) + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) + zztmp = r1_rau0 * r1_2 + zssh_frc(:,jj1:jj2) = zztmp * ( emp(:,jj1:jj2) + emp_b(:,jj1:jj2) - rnf(:,jj1:jj2) - rnf_b(:,jj1:jj2) + fwfisf(:,jj1:jj2) + fwfisf_b(:,jj1:jj2) ) + ENDIF + ! != Add Stokes drift divergence =! (if exist) + IF( ln_sdw ) THEN ! ----------------------------- ! + zssh_frc(:,jj1:jj2) = zssh_frc(:,jj1:jj2) + div_sd(:,jj1:jj2) + ENDIF + ! +#if defined key_asminc + ! != Add the IAU weighted SSH increment =! + ! ! ------------------------------------ ! + IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN + zssh_frc(:,jj1:jj2) = zssh_frc(:,jj1:jj2) - ssh_iau(:,jj1:jj2) + 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(:,jj1:jj2) = 0._wp + ubb_e (:,jj1:jj2) = 0._wp + vbb_e (:,jj1:jj2) = 0._wp + sshb_e (:,jj1:jj2) = 0._wp + ub_e (:,jj1:jj2) = 0._wp + vb_e (:,jj1:jj2) = 0._wp + ENDIF + ! + IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) + zhup2_e(:,jj1:jj2) = hu_n(:,jj1:jj2) + zhvp2_e(:,jj1:jj2) = hv_n(:,jj1:jj2) + zhtp2_e(:,jj1:jj2) = ht_n(:,jj1:jj2) + ENDIF + ! + IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields + sshn_e(:,jj1:jj2) = sshn(:,jj1:jj2) + un_e (:,jj1:jj2) = un_b(:,jj1:jj2) + vn_e (:,jj1:jj2) = vn_b(:,jj1:jj2) + ! + hu_e (:,jj1:jj2) = hu_n(:,jj1:jj2) + hv_e (:,jj1:jj2) = hv_n(:,jj1:jj2) + hur_e (:,jj1:jj2) = r1_hu_n(:,jj1:jj2) + hvr_e (:,jj1:jj2) = r1_hv_n(:,jj1:jj2) + ELSE ! CENTRED integration: start from BEFORE fields + sshn_e(:,jj1:jj2) = sshb(:,jj1:jj2) + un_e (:,jj1:jj2) = ub_b(:,jj1:jj2) + vn_e (:,jj1:jj2) = vb_b(:,jj1:jj2) + ! + hu_e (:,jj1:jj2) = hu_b(:,jj1:jj2) + hv_e (:,jj1:jj2) = hv_b(:,jj1:jj2) + hur_e (:,jj1:jj2) = r1_hu_b(:,jj1:jj2) + hvr_e (:,jj1:jj2) = r1_hv_b(:,jj1:jj2) + ENDIF + ! + ! Initialize sums: + ua_b (:,jj1:jj2) = 0._wp ! After barotropic velocities (or transport if flux form) + va_b (:,jj1:jj2) = 0._wp + ssha (:,jj1:jj2) = 0._wp ! Sum for after averaged sea level + un_adv(:,jj1:jj2) = 0._wp ! Sum for now transport issued from ts loop + vn_adv(:,jj1:jj2) = 0._wp + ! + IF( ln_wd_dl ) THEN + zuwdmask(:,jj1:jj2) = 0._wp ! set to zero for definiteness (not sure this is necessary) + zvwdmask(:,jj1:jj2) = 0._wp ! + zuwdav2 (:,jj1:jj2) = 0._wp + zvwdav2 (:,jj1:jj2) = 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) + ! + !$omp barrier + !$omp master + 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 ) + !$omp end master + !$omp barrier + ! + ! !== 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(:,jj1:jj2) = za1 * un_e(:,jj1:jj2) + za2 * ub_e(:,jj1:jj2) + za3 * ubb_e(:,jj1:jj2) + va_e(:,jj1:jj2) = za1 * vn_e(:,jj1:jj2) + za2 * vb_e(:,jj1:jj2) + za3 * vbb_e(:,jj1:jj2) + + 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(:,jj1:jj2) = za1 * sshn_e(:,jj1:jj2) + za2 * sshb_e(:,jj1:jj2) + za3 * sshbb_e(:,jj1:jj2) + + ! set wetting & drying mask at tracer points for this barotropic mid-step + !$omp barrier + IF( ln_wd_dl ) CALL wad_tmsk( jj1, jj2, zsshp2_e, ztwdmask ) + !$omp barrier + ! + ! ! ocean t-depth at mid-step + zhtp2_e(:,jj1:jj2) = ht_0(:,jj1:jj2) + zsshp2_e(:,jj1:jj2) + ! + ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) + !$omp barrier + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) + !$omp end master + !$omp barrier + ! + ! ! resulting flux at mid-step (not over the full domain) + zhU(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) = e2u(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) * ua_e(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) * zhup2_e(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) ! not jpi-column + zhV(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) = e1v(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) * va_e(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) * zhvp2_e(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) ! not jpj-row + ! +#if defined key_agrif + ! Set fluxes during predictor step to ensure volume conservation + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier +#endif + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier + + 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( jj1, jj2, ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask ) ! not jpi colomn for U, not jpj row for V + !$omp barrier + ! + ENDIF + ! + ! + ! Compute Sea Level at step jit+1 + !-- m+1 m m+1/2 --! + !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! + !-------------------------------------------------------------------------! + DO jj = MAX(2,jj1), MIN(jj2,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 + ! + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp ) + CALL lbc_lnk_multi( 'dynspg_ts', zhV, 'V', -1._wp ) + !$omp end master + !$omp barrier + ! + ! ! Sum over sub-time-steps to compute advective velocities + za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5 + un_adv(:,jj1:jj2) = un_adv(:,jj1:jj2) + za2 * zhU(:,jj1:jj2) * r1_e2u(:,jj1:jj2) + vn_adv(:,jj1:jj2) = vn_adv(:,jj1:jj2) + za2 * zhV(:,jj1:jj2) * r1_e1v(:,jj1:jj2) + ! 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,MAX(1,jj1):MIN(jj2,jpj) ) = zuwdav2(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) + za2 * zuwdmask(1:jpim1,MAX(1,jj1):MIN(jj2,jpj) ) ! not jpi-column + zvwdav2(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) = zvwdav2(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) + za2 * zvwdmask(1:jpi ,MAX(1,jj1):MIN(jj2,jpjm1)) ! not jpj-row + END IF + ! + ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) + !$omp barrier + !$omp master + IF( ln_bdy ) CALL bdy_ssh( ssha_e ) + !$omp end master + !$omp barrier +#if defined key_agrif + !$omp barrier + !$omp master + IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn ) + !$omp end master + !$omp barrier +#endif + ! + ! Sea Surface Height at u-,v-points (vvl case only) + IF( .NOT.ln_linssh ) THEN + DO jj = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2) = za0 * ssha_e(:,jj1:jj2) + za1 * sshn_e (:,jj1:jj2) & + & + za2 * sshb_e(:,jj1:jj2) + za3 * sshbb_e(:,jj1:jj2) + !$omp barrier + ! + ! ! Surface pressure gradient + zldg = ( 1._wp - rn_scal_load ) * grav ! local factor + DO jj = MAX(2,jj1), MIN(jj2,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( jj1, jj2, 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( jj1, jj2, 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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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,MAX(2,jj1):MIN(jj2,jpjm1)) = hu_0(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + zsshu_a(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + hur_e(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) = ssumask(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) / ( hu_e(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + 1._wp - ssumask(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) ) + hv_e (2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) = hv_0(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + zsshv_a(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + hvr_e(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) = ssvmask(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) / ( hv_e(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) + 1._wp - ssvmask(2:jpim1,MAX(2,jj1):MIN(jj2,jpjm1)) ) + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp , hu_e , 'U', 1._wp, hur_e, 'U', 1._wp) + CALL lbc_lnk_multi( 'dynspg_ts', hv_e , 'V', 1._wp, hvr_e, 'V', 1._wp ) + !$omp end master + !$omp barrier + ELSE + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) + !$omp end master + !$omp barrier + ENDIF + ! + ! + ! ! open boundaries + !$omp master + 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 + !$omp end master + !$omp barrier + ! !* Swap + ! ! ---- + ubb_e (:,MAX(1,jj1):MIN(jj2,jpj)) = ub_e (:,MAX(1,jj1):MIN(jj2,jpj)) + ub_e (:,MAX(1,jj1):MIN(jj2,jpj)) = un_e (:,MAX(1,jj1):MIN(jj2,jpj)) + un_e (:,MAX(1,jj1):MIN(jj2,jpj)) = ua_e (:,MAX(1,jj1):MIN(jj2,jpj)) + ! + vbb_e (:,MAX(1,jj1):MIN(jj2,jpj)) = vb_e (:,MAX(1,jj1):MIN(jj2,jpj)) + vb_e (:,MAX(1,jj1):MIN(jj2,jpj)) = vn_e (:,MAX(1,jj1):MIN(jj2,jpj)) + vn_e (:,MAX(1,jj1):MIN(jj2,jpj)) = va_e (:,MAX(1,jj1):MIN(jj2,jpj)) + ! + sshbb_e(:,MAX(1,jj1):MIN(jj2,jpj)) = sshb_e(:,MAX(1,jj1):MIN(jj2,jpj)) + sshb_e (:,MAX(1,jj1):MIN(jj2,jpj)) = sshn_e(:,MAX(1,jj1):MIN(jj2,jpj)) + sshn_e (:,MAX(1,jj1):MIN(jj2,jpj)) = ssha_e(:,MAX(1,jj1):MIN(jj2,jpj)) + + ! !* Sum over whole bt loop + ! ! ---------------------- + za1 = wgtbtp1(jn) + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! Sum velocities + ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) = ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * ua_e (:,MAX(1,jj1):MIN(jj2,jpj)) + va_b (:,MAX(1,jj1):MIN(jj2,jpj)) = va_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * va_e (:,MAX(1,jj1):MIN(jj2,jpj)) + ELSE ! Sum transports + IF ( .NOT.ln_wd_dl ) THEN + ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) = ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * ua_e (:,MAX(1,jj1):MIN(jj2,jpj)) * hu_e (:,MAX(1,jj1):MIN(jj2,jpj)) + va_b (:,MAX(1,jj1):MIN(jj2,jpj)) = va_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * va_e (:,MAX(1,jj1):MIN(jj2,jpj)) * hv_e (:,MAX(1,jj1):MIN(jj2,jpj)) + ELSE + ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) = ua_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * ua_e (:,MAX(1,jj1):MIN(jj2,jpj)) * hu_e (:,MAX(1,jj1):MIN(jj2,jpj)) * zuwdmask(:,MAX(1,jj1):MIN(jj2,jpj)) + va_b (:,MAX(1,jj1):MIN(jj2,jpj)) = va_b (:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * va_e (:,MAX(1,jj1):MIN(jj2,jpj)) * hv_e (:,MAX(1,jj1):MIN(jj2,jpj)) * zvwdmask(:,MAX(1,jj1):MIN(jj2,jpj)) + END IF + ENDIF + ! ! Sum sea level + ssha(:,MAX(1,jj1):MIN(jj2,jpj)) = ssha(:,MAX(1,jj1):MIN(jj2,jpj)) + za1 * ssha_e(:,MAX(1,jj1):MIN(jj2,jpj)) + + ! ! ==================== ! + END DO ! end loop ! + ! ! ==================== ! + ! ----------------------------------------------------------------------------- + ! Phase 3. update the general trend with the barotropic trend + ! ----------------------------------------------------------------------------- + ! + ! Set advection velocity correction: + !$omp barrier + IF (ln_bt_fw) THEN + IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN + DO jj = MAX(1,jj1), MIN(jj2,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(:,jj1:jj2) = 0._wp ! corrective fluxes for next time step set to zero + vn_bf(:,jj1:jj2) = 0._wp + ub2_b(:,jj1:jj2) = un_adv(:,jj1:jj2) ! Save integrated transport for next computation + vb2_b(:,jj1:jj2) = vn_adv(:,jj1:jj2) + END IF + ENDIF + + + ! + ! Update barotropic trend: + IF( ln_dynadv_vec .OR. ln_linssh ) THEN + DO jk=1,jpkm1 + ua(:,jj1:jj2,jk) = ua(:,jj1:jj2,jk) + ( ua_b(:,jj1:jj2) - ub_b(:,jj1:jj2) ) * r1_2dt_b + va(:,jj1:jj2,jk) = va(:,jj1:jj2,jk) + ( va_b(:,jj1:jj2) - vb_b(:,jj1:jj2) ) * 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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions + !$omp end master + !$omp barrier + ! + DO jk=1,jpkm1 + ua(:,jj1:jj2,jk) = ua(:,jj1:jj2,jk) + r1_hu_n(:,jj1:jj2) * ( ua_b(:,jj1:jj2) - ub_b(:,jj1:jj2) * hu_b(:,jj1:jj2) ) * r1_2dt_b + va(:,jj1:jj2,jk) = va(:,jj1:jj2,jk) + r1_hv_n(:,jj1:jj2) * ( va_b(:,jj1:jj2) - vb_b(:,jj1:jj2) * hv_b(:,jj1:jj2) ) * r1_2dt_b + END DO + ! Save barotropic velocities not transport: + ua_b(:,jj1:jj2) = ua_b(:,jj1:jj2) / ( hu_0(:,jj1:jj2) + zsshu_a(:,jj1:jj2) + 1._wp - ssumask(:,jj1:jj2) ) + va_b(:,jj1:jj2) = va_b(:,jj1:jj2) / ( hv_0(:,jj1:jj2) + zsshv_a(:,jj1:jj2) + 1._wp - ssvmask(:,jj1:jj2) ) + ENDIF + + + ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases) + DO jk = 1, jpkm1 + un(:,jj1:jj2,jk) = ( un(:,jj1:jj2,jk) + un_adv(:,jj1:jj2)*r1_hu_n(:,jj1:jj2) - un_b(:,jj1:jj2) ) * umask(:,jj1:jj2,jk) + vn(:,jj1:jj2,jk) = ( vn(:,jj1:jj2,jk) + vn_adv(:,jj1:jj2)*r1_hv_n(:,jj1:jj2) - vn_b(:,jj1:jj2) ) * vmask(:,jj1:jj2,jk) + END DO + + IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN + ! need to set lbc here because not done prior time averaging + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) + !$omp end master + !$omp barrier + DO jk = 1, jpkm1 + un(:,jj1:jj2,jk) = ( un_adv(:,jj1:jj2)*r1_hu_n(:,jj1:jj2) & + & + zuwdav2(:,jj1:jj2)*(un(:,jj1:jj2,jk) - un_adv(:,jj1:jj2)*r1_hu_n(:,jj1:jj2)) ) * umask(:,jj1:jj2,jk) + vn(:,jj1:jj2,jk) = ( vn_adv(:,jj1:jj2)*r1_hv_n(:,jj1:jj2) & + & + zvwdav2(:,jj1:jj2)*(vn(:,jj1:jj2,jk) - vn_adv(:,jj1:jj2)*r1_hv_n(:,jj1:jj2)) ) * vmask(:,jj1:jj2,jk) + END DO + END IF + + !$omp end parallel + + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('dyn_spg_ts') + ! + 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(dp), DIMENSION(3*nn_baro), INTENT(inout) :: zwgt1, zwgt2 + + + INTEGER :: jic, jn, ji ! temporary integers + REAL(wp) :: za2 + REAL(dp) :: za1 + !!---------------------------------------------------------------------- + + IF( ln_timing_detail ) CALL timing_start('dyn_spg_ts_wgt') + + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('dyn_spg_ts_wgt') + + 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 ) + IF ( nn_slimrstin == 0 .OR. kt >= nitend - nn_fsbc ) THEN + 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 + 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 , dp ) + 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( jj1, jj2, 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 ! - - + INTEGER, INTENT(in) :: jj1, jj2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: hu_n, hv_n, un_b, vn_b, zhV + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: zhU + REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd + !!---------------------------------------------------------------------- + ! + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ! enstrophy conserving scheme (f-point) + DO jj = MAX(2,jj1), MIN(jpjm1,jj2) + 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 = MAX(2,jj1), MIN(jpjm1,jj2) + 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 = MAX(2,jj1), MIN(jpjm1,jj2) + 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 = MAX(2,jj1), MIN(jpjm1,jj2) + 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( jj1, jj2, 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 + !!---------------------------------------------------------------------- + INTEGER :: jj1, jj2 + 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 = MIN(1,jj1), MAX(jj2,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 = MIN(1,jj1), MAX(jj2,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( jj1, jj2, 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 + !!---------------------------------------------------------------------- + INTEGER :: jj1, jj2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phV, pu! ocean velocities and transports + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phU, 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 = MIN(1,jj1), MAX(jj2,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 = MIN(1,jj1), MAX(jj2,jpjm1) + 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( jj1, jj2, sshn, zcpx, zcpy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wad_sp *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + LOGICAL :: ll_tmp1, ll_tmp2 + INTEGER :: jj1,jj2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: sshn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy + !!---------------------------------------------------------------------- + ! + DO jj = MAX(2,jj1), MIN(jj2,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( jj1, jj2,pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_drg_init *** + !! + !! ** Purpose : - add the baroclinic top/bottom drag contribution to + !! the baroclinic part of the barotropic RHS + !! - compute the barotropic drag coefficients + !! + !! ** Method : computation done over the INNER domain only + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: jj1, jj2 + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS + REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients + ! + 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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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(dp),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/V4.0/nemo_sources/src/OCE/DYN/dynvor.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynvor.F90 new file mode 100644 index 0000000000000000000000000000000000000000..461cab0b116089abe2f72f971f3ea515298bc336 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynvor.F90 @@ -0,0 +1,1059 @@ +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 + USE nopenmp ! OpenMP library + + 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 + + ! Workspace in static memory for OpenMP + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwx, zwy, zwt ! 2D workspace (3D for OpenMP) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z1_e3f, ztnw, ztne, ztsw, ztse !workspace for ln_dynvor_een=T + ! or ln_dynvor_eeT + ! + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynvor.F90 14596 2021-03-08 08:17:56Z clem $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_vor') + ! + !$omp parallel private(itid,ithreads,jj1,jj2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==! + ! + !$omp barrier + !$omp master + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + !$omp end master + !$omp barrier + ! + ztrdu(:,jj1:jj2,:) = ua(:,jj1:jj2,:) !* planetary vorticity trend (including Stokes-Coriolis force) + ztrdv(:,jj1:jj2,:) = va(:,jj1:jj2,:) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; CALL vor_ens( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! enstrophy conserving scheme + IF( ln_stcor ) CALL vor_ens( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENE, np_MIX ) ; CALL vor_ene( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! energy conserving scheme + IF( ln_stcor ) CALL vor_ene( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENT ) ; CALL vor_enT( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! energy conserving scheme (T-pts) + IF( ln_stcor ) CALL vor_enT( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EET ) ; CALL vor_eeT( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! energy conserving scheme (een with e3t) + IF( ln_stcor ) CALL vor_eeT( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EEN ) ; CALL vor_een( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! energy & enstrophy scheme + IF( ln_stcor ) CALL vor_een( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + END SELECT + ztrdu(:,jj1:jj2,:) = ua(:,jj1:jj2,:) - ztrdu(:,jj1:jj2,:) + ztrdv(:,jj1:jj2,:) = va(:,jj1:jj2,:) - ztrdv(:,jj1:jj2,:) + !$omp barrier + !$omp master + CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) + !$omp end master + !$omp barrier + ! + IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) + ztrdu(:,jj1:jj2,:) = ua(:,jj1:jj2,:) + ztrdv(:,jj1:jj2,:) = va(:,jj1:jj2,:) + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ; CALL vor_enT( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! energy conserving scheme (een with e3t) + CASE( np_ENE ) ; CALL vor_ene( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! energy conserving scheme + CASE( np_ENS, np_MIX ) ; CALL vor_ens( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! enstrophy conserving scheme + CASE( np_EEN ) ; CALL vor_een( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,jj1:jj2,:) = ua(:,jj1:jj2,:) - ztrdu(:,jj1:jj2,:) + ztrdv(:,jj1:jj2,:) = va(:,jj1:jj2,:) - ztrdv(:,jj1:jj2,:) + !$omp barrier + !$omp master + CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) + !$omp end master + !$omp barrier + ENDIF + ! + !$omp barrier + !$omp master + DEALLOCATE( ztrdu, ztrdv ) + !$omp end master + !$omp barrier + ! + 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( itid, jj1, jj2, kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_enT( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EET ) !* energy conserving scheme (een scheme using e3t) + CALL vor_eeT( itid, jj1, jj2, kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_eeT( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENE ) !* energy conserving scheme + CALL vor_ene( itid, jj1, jj2, kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_ene( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENS ) !* enstrophy conserving scheme + CALL vor_ens( itid, jj1, jj2, kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_ens( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_MIX ) !* mixed ene-ens scheme + CALL vor_ens( itid, jj1, jj2, kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) + CALL vor_ene( itid, jj1, jj2, kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) + IF( ln_stcor ) CALL vor_ene( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EEN ) !* energy and enstrophy conserving scheme + CALL vor_een( itid, jj1, jj2, kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_een( itid, jj1, jj2, kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + END SELECT + ! + ENDIF + ! + !$omp end parallel + ! + ! ! 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( ktid, kj1, kj2, 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 ) :: ktid, kj1, kj2 ! OpenMP variables + 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars + !!---------------------------------------------------------------------- + ! + !$omp barrier + ! + ! Init to 0 to avoid fp errors. + zwz(:,kj1:kj2,:) = 0._wp + + + IF( kt == nit000 .AND. ktid == 0 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_enT : vorticity term: t-point energy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + zwz(:,kj1:kj2,jpk) = 0._wp + ! + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + CASE ( np_RVO ) !* relative vorticity + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,jpjm1) + DO ji = 1, jpim1 + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + END DO + + !$omp barrier + !$omp master + CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + !$omp end master + !$omp barrier + + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(1,kj1), MIN(kj2,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 + + !$omp barrier + !$omp master + CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + !$omp end master + !$omp barrier + + END SELECT + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + zwt(:,kj1:kj2,jk) = ff_t(:,kj1:kj2) * e1e2t(:,kj1:kj2)*e3t_n(:,kj1:kj2,jk) + CASE ( np_RVO ) !* relative vorticity + DO jj = MAX(2,kj1), MIN(kj2,jpj) + DO ji = 2, jpi ! vector opt. + zwt(ji,jj,jk) = 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 = MAX(2,kj1), MIN(kj2,jpj) + DO ji = 2, jpi + zwt(ji,jj,jk) = ( ( 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 = MAX(2,kj1), MIN(kj2,jpj) + DO ji = 2, jpi ! vector opt. + zwt(ji,jj,jk) = ( 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 = MAX(2,kj1), MIN(kj2,jpj) + DO ji = 2, jpi ! vector opt. + zwt(ji,jj,jk) = ( 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 + ! + END DO + !$omp barrier + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! !== compute and add the vorticity term trend =! + DO jj = MAX(2,kj1), MIN(kj2,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,jk) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) ) & + & + zwt(ji ,jj,jk) * ( 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,jk) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) & + & + zwt(ji,jj ,jk) * ( 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( ktid, kj1, kj2, 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 ) :: ktid, kj1, kj2 ! OpenMP variables + 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(dp), 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 + !!---------------------------------------------------------------------- + ! + !$omp barrier + ! + IF( kt == nit000 .and. ktid == 0 ) 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(:,kj1:kj2,jk) = ff_f(:,kj1:kj2) + CASE ( np_RVO ) !* relative vorticity + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 + + IF( ln_sco ) THEN + zwz(:,kj1:kj2,jk) = zwz(:,kj1:kj2,jk) / e3f_n(:,kj1:kj2,jk) + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * e3u_n(:,kj1:kj2,jk) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * e3v_n(:,kj1:kj2,jk) * pvn(:,kj1:kj2,jk) + ELSE + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * pvn(:,kj1:kj2,jk) + ENDIF + + END DO + !$omp barrier + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! !== compute and add the vorticity term trend =! + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 ! vector opt. + zy1 = zwy(ji,jj-1,jk) + zwy(ji+1,jj-1,jk) + zy2 = zwy(ji,jj ,jk) + zwy(ji+1,jj ,jk) + zx1 = zwx(ji-1,jj,jk) + zwx(ji-1,jj+1,jk) + zx2 = zwx(ji ,jj,jk) + zwx(ji ,jj+1,jk) + pua(ji,jj,jk) = pua(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1,jk) * zy1 + zwz(ji,jj,jk) * zy2 ) + pva(ji,jj,jk) = pva(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ,jk) * zx1 + zwz(ji,jj,jk) * zx2 ) + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ene + + + SUBROUTINE vor_ens( ktid, kj1, kj2, 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 ) :: ktid, kj1, kj2 ! OpenMP variables + 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuav, zvau ! local scalars + !!---------------------------------------------------------------------- + ! + !$omp barrier + ! + IF( kt == nit000 .AND. ktid == 0 ) 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(:,kj1:kj2,jk) = ff_f(:,kj1:kj2) + CASE ( np_RVO ) !* relative vorticity + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 + ! + IF( ln_sco ) THEN !== horizontal fluxes ==! + zwz(:,kj1:kj2,jk) = zwz(:,kj1:kj2,jk) / e3f_n(:,kj1:kj2,jk) + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * e3u_n(:,kj1:kj2,jk) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * e3v_n(:,kj1:kj2,jk) * pvn(:,kj1:kj2,jk) + ELSE + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * pvn(:,kj1:kj2,jk) + ENDIF + END DO + !$omp barrier + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! !== compute and add the vorticity term trend =! + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 ! vector opt. + zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1,jk) + zwy(ji+1,jj-1,jk) & + & + zwy(ji ,jj ,jk) + zwy(ji+1,jj ,jk) ) + zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ,jk) + zwx(ji-1,jj+1,jk) & + & + zwx(ji ,jj ,jk) + zwx(ji ,jj+1,jk) ) + pua(ji,jj,jk) = pua(ji,jj,jk) + zuav * ( zwz(ji ,jj-1,jk) + zwz(ji,jj,jk) ) + pva(ji,jj,jk) = pva(ji,jj,jk) + zvau * ( zwz(ji-1,jj ,jk) + zwz(ji,jj,jk) ) + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ens + + + SUBROUTINE vor_een( ktid, kj1, kj2, 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 ) :: ktid, kj1, kj2 ! OpenMP variables + 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(dp), 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 + !!---------------------------------------------------------------------- + ! + !$omp barrier + ! + ! Init to 0 to avoid fp errors. + zwz(:,kj1:kj2,:) = 0._wp + + IF( kt == nit000 .and. ktid == 0 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + zwz(:,kj1:kj2,jpk) = 0._wp + ! ! =============== + 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 = MAX(1,kj1), MIN(kj2,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,jk) = 4._wp / ze3f + ELSE ; z1_e3f(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO jj = MAX(1,kj1), MIN(kj2,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,jk) = zmsk / ze3f + ELSE ; z1_e3f(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END SELECT + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = MAX(1,kj1), MIN(kj2,jpjm1) + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj,jk) + END DO + END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = MAX(1,kj1), MIN(kj2,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,jk) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = MAX(1,kj1), MIN(kj2,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,jk) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = MAX(1,kj1), MIN(kj2,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,jk) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = MAX(1,kj1), MIN(kj2,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,jk) + 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 = MAX(1,kj1), MIN(kj2,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 + ! + !$omp barrier + !$omp master + CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + !$omp end master + !$omp barrier + + DO jk = 1, jpkm1 ! Horizontal slab + ! + ! !== horizontal fluxes ==! + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * e3u_n(:,kj1:kj2,jk) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * e3v_n(:,kj1:kj2,jk) * pvn(:,kj1:kj2,jk) + + ! !== compute and add the vorticity term trend =! + ztne(1,kj1:kj2,jk) = 0 ; ztnw(1,kj1:kj2,jk) = 0 ; ztse(1,kj1:kj2,jk) = 0 ; ztsw(1,kj1:kj2,jk) = 0 + IF ( (kj1<=2) .AND. (kj2>=2) ) THEN + jj = 2 + DO ji = 2, jpi ! split in 2 parts due to vector opt. + ztne(ji,jj,jk) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + ztnw(ji,jj,jk) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + ztse(ji,jj,jk) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + ztsw(ji,jj,jk) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + END DO + ENDIF + DO jj = MAX(3,kj1), MIN(kj2,jpj) + DO ji = fs_2, jpi ! vector opt. ok because we start at jj = 3 + ztne(ji,jj,jk) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + ztnw(ji,jj,jk) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + ztse(ji,jj,jk) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + ztsw(ji,jj,jk) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + END DO + END DO + END DO + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 ! vector opt. + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ,jk) * zwy(ji ,jj ,jk) + ztnw(ji+1,jj,jk) * zwy(ji+1,jj ,jk) & + & + ztse(ji,jj ,jk) * zwy(ji ,jj-1,jk) + ztsw(ji+1,jj,jk) * zwy(ji+1,jj-1,jk) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1,jk) * zwx(ji-1,jj+1,jk) + ztse(ji,jj+1,jk) * zwx(ji ,jj+1,jk) & + & + ztnw(ji,jj ,jk) * zwx(ji-1,jj ,jk) + ztne(ji,jj ,jk) * zwx(ji ,jj ,jk) ) + 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( ktid, kj1, kj2, 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 ) :: ktid, kj1, kj2 ! OpenMP variables + 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(dp), 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 + !!---------------------------------------------------------------------- + ! + !$omp barrier + ! + 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 + ! + zwz(:,kj1:kj2,jpk) = 0._wp + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 + ! + !$omp barrier + !$omp master + CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + !$omp end master + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal slab + + ! !== horizontal fluxes ==! + zwx(:,kj1:kj2,jk) = e2u(:,kj1:kj2) * e3u_n(:,kj1:kj2,jk) * pun(:,kj1:kj2,jk) + zwy(:,kj1:kj2,jk) = e1v(:,kj1:kj2) * e3v_n(:,kj1:kj2,jk) * pvn(:,kj1:kj2,jk) + + ! !== compute and add the vorticity term trend =! + jj = 2 + ztne(1,:,jk) = 0 ; ztnw(1,:,jk) = 0 ; ztse(1,:,jk) = 0 ; ztsw(1,:,jk) = 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,jk) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t + ztnw(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t + ztse(ji,jj,jk) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t + ztsw(ji,jj,jk) = ( 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,jk) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t + ztnw(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t + ztse(ji,jj,jk) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t + ztsw(ji,jj,jk) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t + END DO + END DO + END DO + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 ! vector opt. + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ,jk) * zwy(ji ,jj ,jk) + ztnw(ji+1,jj,jk) * zwy(ji+1,jj ,jk) & + & + ztse(ji,jj ,jk) * zwy(ji ,jj-1,jk) + ztsw(ji+1,jj,jk) * zwy(ji+1,jj-1,jk) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1,jk) * zwx(ji-1,jj+1,jk) + ztse(ji,jj+1,jk) * zwx(ji ,jj+1,jk) & + & + ztnw(ji,jj ,jk) * zwx(ji-1,jj ,jk) + ztne(ji,jj ,jk) * zwx(ji ,jj ,jk) ) + 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.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions + ! + CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) + ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) ) + DO jj = 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.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! 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 + ! + ! Allocate workspace + ! + ALLOCATE( zwx(jpi,jpj,jpk), zwy(jpi,jpj,jpk), zwt(jpi,jpj,jpk), & + & zwz(jpi,jpj,jpk) ) + IF ( ln_dynvor_een .OR. ln_dynvor_eeT ) THEN + ALLOCATE( z1_e3f(jpi,jpj,jpk), ztnw(jpi,jpj,jpk), & + & ztne(jpi,jpj,jpk), ztsw(jpi,jpj,jpk), ztse(jpi,jpj,jpk) ) + ENDIF + ! + END SUBROUTINE dyn_vor_init + + !!============================================================================== +END MODULE dynvor \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynzad.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynzad.F90 new file mode 100644 index 0000000000000000000000000000000000000000..aa96853a7ba5230016a968e322513810f488b59b --- /dev/null +++ b/V4.0/nemo_sources/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: dynzad.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/dynzdf.F90 b/V4.0/nemo_sources/src/OCE/DYN/dynzdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ee35a2e8b53920280dad0908f88b382c14f8a012 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/dynzdf.F90 @@ -0,0 +1,523 @@ +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 + use nopenmp ! OpenMP library + + 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: dynzdf.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 :: jj1, jj2, itid, ithreads ! openmp variables + 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(dp), DIMENSION(jpi,jpj,jpk) :: zwi, zwd, zws ! 3D workspace + REAL(dp), 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 + ! + ! + !$omp parallel private(ji,jj,jk,itid,ithreads,jj1,jj2,iku,ikv,& + !$omp& zzwi,ze3ua,zdt,zzws,ze3va,z1_e3ua,z1_e3va,zWu,zWv,zWui,zWvi,zWus,zWvs) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! !* explicit top/bottom drag case + IF( .NOT.ln_drgimp ) CALL zdf_drg_exp( itid, jj1, jj2, kt, ub, vb, ua, va ) ! add top/bottom friction trend to (ua,va) + ! + ! + IF( l_trddyn ) THEN !* temporary save of ta and sa trends + !$omp barrier + !$omp master + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + !$omp end master + !$omp barrier + ztrdu(:,jj1:jj2,:) = ua(:,jj1:jj2,:) + ztrdv(:,jj1:jj2,:) = va(:,jj1:jj2,:) + 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(:,jj1:jj2,jk) = ( ub(:,jj1:jj2,jk) + r2dt * ua(:,jj1:jj2,jk) ) * umask(:,jj1:jj2,jk) + va(:,jj1:jj2,jk) = ( vb(:,jj1:jj2,jk) + r2dt * va(:,jj1:jj2,jk) ) * vmask(:,jj1:jj2,jk) + END DO + ELSE ! applied on thickness weighted velocity + DO jk = 1, jpkm1 + ua(:,jj1:jj2,jk) = ( e3u_b(:,jj1:jj2,jk) * ub(:,jj1:jj2,jk) & + & + r2dt * e3u_n(:,jj1:jj2,jk) * ua(:,jj1:jj2,jk) ) / e3u_a(:,jj1:jj2,jk) * umask(:,jj1:jj2,jk) + va(:,jj1:jj2,jk) = ( e3v_b(:,jj1:jj2,jk) * vb(:,jj1:jj2,jk) & + & + r2dt * e3v_n(:,jj1:jj2,jk) * va(:,jj1:jj2,jk) ) / e3v_a(:,jj1:jj2,jk) * vmask(:,jj1:jj2,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(:,jj1:jj2,jk) = ( ua(:,jj1:jj2,jk) - ua_b(:,jj1:jj2) ) * umask(:,jj1:jj2,jk) + va(:,jj1:jj2,jk) = ( va(:,jj1:jj2,jk) - va_b(:,jj1:jj2) ) * vmask(:,jj1:jj2,jk) + END DO + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2,:) = ( ua(:,jj1:jj2,:) - ub(:,jj1:jj2,:) ) / r2dt - ztrdu(:,jj1:jj2,:) + ztrdv(:,jj1:jj2,:) = ( va(:,jj1:jj2,:) - vb(:,jj1:jj2,:) ) / r2dt - ztrdv(:,jj1:jj2,:) + !$omp barrier + !$omp master + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) + DEALLOCATE( ztrdu, ztrdv ) + !$omp end master + !$omp barrier + ENDIF + ! + !$omp end parallel + ! + ! ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/DYN/sshwzv.F90 b/V4.0/nemo_sources/src/OCE/DYN/sshwzv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..35242f24a6da3dd9f055546fd67660ff474d0707 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/sshwzv.F90 @@ -0,0 +1,390 @@ +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" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sshwzv.F90 12737 2020-04-10 17:55:11Z jchanut $ + !! 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.0_wp ) ! 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=CASTSP(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.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" + ! ! Is it problematic to have a wrong vertical velocity in boundary cells? + ! ! Same question holds for 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(dp) :: 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=CASTSP(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.0_wp ) + ! + 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/V4.0/nemo_sources/src/OCE/DYN/wet_dry.F90 b/V4.0/nemo_sources/src/OCE/DYN/wet_dry.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f32d1cbd66bbbc9d898bee32084c7b1e892e1a73 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/DYN/wet_dry.F90 @@ -0,0 +1,403 @@ +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(dp), DIMENSION(:,:), INTENT(inout) :: sshb1 !!gm DOCTOR names: should start with p ! + REAL(dp), 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.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF( jflag == 0 ) EXIT + ! + END DO ! jk1 loop + ! + DO jk = 1, jpkm1 + 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.0_wp, vn , 'V', -1.0_wp ) + CALL lbc_lnk_multi( 'wet_dry', un_b, 'U', -1.0_wp, vn_b, 'V', -1.0_wp ) +!!gm + ! + IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( 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(dp) , INTENT(in ) :: rdtbt ! ocean time-step index + REAL(wp), DIMENSION(:,:), INTENT(inout) :: zflxv + REAL(dp), DIMENSION(:,:), INTENT(inout) :: zflxu, sshn_e, zssh_frc + ! + INTEGER :: ji, jj, jk, jk1 ! dummy loop indices + INTEGER :: jflag ! local integer + REAL(wp) :: z2dt + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('wad_lmt_bt') ! + ! + jflag = 0 + zdepwd = 50._wp ! maximum depth that ocean cells can have W/D processes + ! + z2dt = 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.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF(jflag == 0) EXIT + ! + END DO ! jk1 loop + ! + zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) + zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) + ! +!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop + CALL lbc_lnk_multi( 'wet_dry', zflxv, 'V', -1.0_wp ) + CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp ) +!!gm end + ! + IF( jflag == 1 .AND. lwp ) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( 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/V4.0/nemo_sources/src/OCE/ECM/interinfo.F90 b/V4.0/nemo_sources/src/OCE/ECM/interinfo.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6dc8788e219500caa71f22def1d4ab4e50360892 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/interinfo.F90 @@ -0,0 +1,45 @@ +MODULE interinfo + + ! Parallel regridding information + + USE par_kind + USE parinter + + IMPLICIT NONE + + SAVE + + ! IFS to NEMO + + TYPE(parinterinfo) :: gausstoT,gausstoU,gausstoV + + ! NEMO to IFS + + TYPE(parinterinfo) :: Ttogauss + + ! WAM to NEMO + + TYPE(parinterinfo) :: wamtoT,wamtoU,wamtoV + + ! NEMO to WAM + + TYPE(parinterinfo) :: Ttowam + + ! Temperature levels for atmospherics SST + + INTEGER, DIMENSION(2) :: nsstlvl + + ! Read parinterinfo on task 0 only and broadcast. + + LOGICAL :: lparbcast = .FALSE. + + ! Wam stress capping + + LOGICAL :: lwamstresscap = .TRUE. + REAL(wp) :: rmaxstress = 10.0_wp + + ! Use parinterfld_mult or not + LOGICAL :: lparintmultatm = .TRUE. + LOGICAL :: lparintmultwam = .TRUE. + +END MODULE interinfo \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/modhookdummy.F90 b/V4.0/nemo_sources/src/OCE/ECM/modhookdummy.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0006acaa42872f2be3ecb9c87730a4823a8a1c70 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/modhookdummy.F90 @@ -0,0 +1,34 @@ +MODULE modhookdummy + !!======================================================================== + !! *** MODULE modhookdummy *** + !!======================================================================== + !! History : 1.0 ! 2015-05 K Mogensen + !! Dr Hook dummys: Dummies for when Dr Hook is not available. + !!------------------------------------------------------------------------ + + !!------------------------------------------------------------------------ + !! lhook : logical for Dr Hook (false always) + !! dr_hook : Dr Hook dummy subroutine + !!------------------------------------------------------------------------ + USE par_kind + USE lib_mpp, ONLY: ctl_stop + IMPLICIT NONE + PRIVATE + + LOGICAL, PUBLIC, PARAMETER :: lhook = .FALSE. + INTEGER, PUBLIC, PARAMETER :: jphook = SELECTED_REAL_KIND(13,300) + PUBLIC dr_hook + +CONTAINS + + SUBROUTINE dr_hook( cdstr, kcall, phand ) + + CHARACTER(len=*), INTENT(IN):: cdstr + INTEGER, INTENT(IN) :: kcall + REAL(dp) :: phand + + CALL ctl_stop('dummy dr_hook should never be call') + + END SUBROUTINE dr_hook + +END MODULE modhookdummy \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/mpp_io.F90 b/V4.0/nemo_sources/src/OCE/ECM/mpp_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ed992ebb57f7c18c913a4cf6a43bb6cfdb538e91 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/mpp_io.F90 @@ -0,0 +1,220 @@ +MODULE mpp_io + +#if defined key_iomput_sglexe + + USE iom + IMPLICIT NONE + PRIVATE + + PUBLIC & + & mpp_io_init, & + & mpp_io_init_2, & + & mpp_server_stop + + INTEGER :: ntask_multio = 0 + INTEGER :: ntask_xios = 0 + LOGICAL, PUBLIC :: lioserver, lxiosserver, lmultioserver, & + & lxiosproc, lmultiproc + INTEGER :: ntask_notio + INTEGER, SAVE :: mppallrank, mppallsize, mppiorank, mppiosize + INTEGER, SAVE :: mppxiosrank, mppxiossize, mppmultiorank, mppmultiosize + INTEGER, SAVE :: mppcomprank, mppcompsize + INTEGER, SAVE :: pcommworld, pcommworldxios, pcommworldmultio + +CONTAINS + + SUBROUTINE mpp_io_init( iicomm, lio, irequired, iprovided, lmpi1 ) + + INCLUDE "mpif.h" + INTEGER, INTENT(INOUT) :: iicomm + LOGICAL, INTENT(INOUT) :: lio + INTEGER, INTENT(INOUT) :: irequired, iprovided + LOGICAL, INTENT(IN) :: lmpi1 + + INTEGER :: icode, ierr, icolor + LOGICAL :: mpi_called + CHARACTER(len=128) :: cdlogfile + INTEGER :: ji + NAMELIST/namio/ntask_multio,ntask_xios + + CALL mpi_initialized( mpi_called, icode ) + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init: Error in routine mpi_initialized' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + IF( mpi_called ) THEN + WRITE(*,*)' mpi_io_init assumes that it is initialising MPI' + CALL mpi_abort( mpi_comm_world, 1, ierr ) + ENDIF + IF (lmpi1) THEN + CALL mpi_init( icode ) + ELSE +#ifdef MPI1 + WRITE(0,*)'mpp_io_init:' + WRITE(0,*)'MPI1 defined but lmpi1 is false' + CALL abort +#else + CALL mpi_init_thread(irequired,iprovided,icode) +#endif + ENDIF + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init: Error in routine mpi_init' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + CALL mpi_comm_rank( mpi_comm_world, mppallrank, ierr ) + CALL mpi_comm_size( mpi_comm_world, mppallsize, ierr ) + + OPEN(10,file='namio.in') + READ(10,namio) + WRITE(*,namio) + CLOSE(10) + + IF ( ntask_xios + ntask_multio == 0 ) THEN + iicomm = mpi_comm_world + lio=.FALSE. + RETURN + ENDIF + + ntask_notio = mppallsize - ntask_xios - ntask_multio + IF ((mppallrank+1)<=ntask_notio) THEN + icolor=1 + lioserver=.FALSE. + lxiosserver=.FALSE. + lmultioserver=.FALSE. + ELSEIF ((mppallrank+1)<=ntask_notio+ntask_xios) THEN + icolor=2 + lioserver=.TRUE. + lxiosserver=.TRUE. + lmultioserver=.FALSE. + ELSE + icolor=3 + lioserver=.TRUE. + lxiosserver=.FALSE. + lmultioserver=.TRUE. + ENDIF + lio=lioserver + + CALL mpi_comm_split( mpi_comm_world, icolor, 0, iicomm, icode ) + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init: Error in routine mpi_comm_split' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + IF (lioserver) THEN + CALL mpi_comm_rank( iicomm, mppiorank, ierr ) + CALL mpi_comm_size( iicomm, mppiosize, ierr ) + WRITE(cdlogfile,'(A,I4.4,A)')'nemo_io_server.',mppiorank,'.log' + ELSE + mppiorank=0 + mppiosize=0 + ENDIF + lio=lioserver + + END SUBROUTINE mpp_io_init + + SUBROUTINE mpp_io_init_2( iicomm ) + + INTEGER, INTENT(INOUT) :: iicomm + + INTEGER :: icode, ierr, icolor, iicommx, iicommm, iicommo + INTEGER :: ji,inum + LOGICAL :: lxiosp,lmultiop,lcompp + INCLUDE "mpif.h" + + ! Construct XIOS server communicator + + IF (lxiosserver.OR..NOT.lioserver) THEN + icolor=10 + lxiosp=.TRUE. + ELSE + icolor=11 + lxiosp=.FALSE. + ENDIF + CALL mpi_comm_split( iicomm, icolor, 0, pcommworldxios, icode ) + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init2: Error in routine mpi_comm_split' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + CALL mpi_comm_rank( pcommworldxios, mppxiosrank, ierr ) + CALL mpi_comm_size( pcommworldxios, mppxiossize, ierr ) + + ! Construct multio server communicator + + IF (lmultioserver.OR..NOT.lioserver) THEN + icolor=12 + lmultiop=.TRUE. + ELSE + icolor=13 + lmultiop=.FALSE. + ENDIF + CALL mpi_comm_split( iicomm, icolor, 0, pcommworldmultio, icode ) + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init2: Error in routine mpi_comm_split' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + CALL mpi_comm_rank( pcommworldmultio, mppmultiorank, ierr ) + CALL mpi_comm_size( pcommworldmultio, mppmultiosize, ierr ) + + ! Construct compute communicator + + IF (.NOT.lioserver) THEN + icolor=14 + lcompp=.TRUE. + ELSE + icolor=15 + lcompp=.FALSE. + ENDIF + CALL mpi_comm_split( iicomm, icolor, 0, iicommo, icode ) + IF ( icode /= MPI_SUCCESS ) THEN + WRITE(*,*)' mpp_io_init2: Error in routine mpi_comm_split' + CALL mpi_abort( mpi_comm_world, icode, ierr ) + ENDIF + CALL mpi_comm_rank( iicommo, mppcomprank, ierr ) + CALL mpi_comm_size( iicommo, mppcompsize, ierr ) + + IF (.NOT.lioserver) THEN + + ! For non io-server tasks initialize the XIOS/MULTIO through iom + + IF (lxiosp) THEN + CALL iom_initialize( "for_xios_mpi_id",return_comm=iicommx, global_comm = pcommworldxios, lxios=.TRUE., lmultio=.FALSE. ) ! nemo local communicator given by xios + ENDIF + IF (lmultiop) THEN + CALL iom_initialize( "for_xios_mpi_id",return_comm=iicommm, global_comm = pcommworldmultio, lxios=.FALSE., lmultio=.TRUE. ) ! nemo local communicator given by xios + ENDIF + + ELSE + + ! For io-server tasks start an run the right server + + IF (lxiosp) THEN + CALL iom_init_server( server_comm = pcommworldxios, lxios=.TRUE., lmultio=.FALSE. ) + ENDIF + IF (lmultiop) THEN + CALL iom_init_server( server_comm = pcommworldmultio, lxios=.FALSE., lmultio=.TRUE. ) + ENDIF + + ENDIF + + ! Return to the model with iicomm being compute only tasks + + iicomm = iicommo + + END SUBROUTINE mpp_io_init_2 + + SUBROUTINE mpp_server_stop + INTEGER :: ierr + CALL mpi_finalize( ierr ) + END SUBROUTINE mpp_server_stop + +#else + +CONTAINS + + SUBROUTINE mpp_io_dummy + WRITE(*,*)'In mpp_io_dummy' + CALL abort + END SUBROUTINE mpp_io_dummy + +#endif + +END MODULE mpp_io \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/nctools.F90 b/V4.0/nemo_sources/src/OCE/ECM/nctools.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bca331879599c64763bc2732eec2d0a621d754f3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/nctools.F90 @@ -0,0 +1,40 @@ +#define __MYFILE__ 'nctools.F90' +MODULE nctools + + ! Utility subroutines for netCDF access + ! Modified : MAB (nf90, handle_error, LINE&FILE) + ! Modifled : KSM (new shorter name) + + USE netcdf + + PUBLIC ldebug_netcdf, nchdlerr + LOGICAL :: ldebug_netcdf = .FALSE. ! Debug switch for netcdf + +CONTAINS + + SUBROUTINE nchdlerr(status,lineno,filename) + + ! Error handler for netCDF access + IMPLICIT NONE + + + INTEGER :: status ! netCDF return status + INTEGER, INTENT(IN) :: lineno ! Line number (usually obtained from + ! preprocessing __LINE__,__MYFILE__) + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: filename + + IF (status/=nf90_noerr) THEN + WRITE(*,*)'Netcdf error, code ',status + IF (PRESENT(filename)) THEN + WRITE(*,*)'In file ',filename,' in line ',lineno + ELSE + WRITE(*,*)'In line ',lineno + END IF + WRITE(*,'(2A)')' Error message : ',nf90_strerror(status) + CALL abort + ENDIF + + END SUBROUTINE nchdlerr + +!---------------------------------------------------------------------- +END MODULE nctools \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/parinter.F90 b/V4.0/nemo_sources/src/OCE/ECM/parinter.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3aba0202e23123dd0aaf5a03db1d7a92ce230b1f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/parinter.F90 @@ -0,0 +1,1122 @@ +#define __MYFILE__ 'parinter.F90' +MODULE parinter + +#if defined key_mpp_mpi + USE mpi +#endif + USE scripremap + USE scrippar + USE timing +#if defined key_dr_hook + USE yomhook, ONLY : lhook, dr_hook, jphook ! IFS Dr_Hook +#else + USE modhookdummy, ONLY : lhook, dr_hook, jphook ! Dummy Dr_Hook +#endif + USE in_out_manager + USE nctools + + IMPLICIT NONE + + ! Type to contains interpolation information + ! (like what is in scripremaptype) and message + ! passing information + + TYPE parinterinfo + ! Number of local links + INTEGER :: num_links + ! Destination side + INTEGER, POINTER, DIMENSION(:) :: dst_address + ! Source addresses and work array + INTEGER, POINTER, DIMENSION(:) :: src_address + ! Local remap matrix + REAL(scripdp), POINTER, DIMENSION(:,:) :: remap_matrix + ! Message passing information + ! Array of local addresses for send buffer + ! packing + INTEGER, POINTER, DIMENSION(:) :: send_address + ! Sending bookkeeping + INTEGER :: nsendtot + INTEGER, POINTER, DIMENSION(:) :: nsend,nsdisp + ! Receiving bookkeeping + INTEGER :: nrecvtot + INTEGER, POINTER, DIMENSION(:) :: nrecv,nrdisp + END TYPE parinterinfo + + PRIVATE :: allocmem_errchk + + LOGICAL, PUBLIC :: lparinterp2p = .TRUE. + +CONTAINS + + SUBROUTINE allocmem_errchk(kunit, kstatus, CLfile, klineno, CLmsg, ksize, kerr) + INTEGER, INTENT(in) :: kunit, kstatus, klineno, ksize + INTEGER, INTENT(inout) :: kerr + CHARACTER(len=*), INTENT(in) :: CLfile, CLmsg + IF (kstatus /= 0) THEN + WRITE(kunit,'(1x,a,i0,a,i0,a,i0)') & + & 'Unable to allocate '//CLmsg//'(', & + & ksize,') at '//CLfile//':',& + & klineno-1,': stat=',kstatus + kerr = kerr + 1 + ENDIF + END SUBROUTINE allocmem_errchk + + SUBROUTINE parinter_init( mype, nproc, mpi_comm, & + & nsrclocpoints, nsrcglopoints, srcmask, srcgloind, & + & ndstlocpoints, ndstglopoints, dstmask, dstgloind, & + & remap, pinfo, lcommout, commoutprefix, iunit ) + + ! Setup interpolation based on SCRIP format weights in + ! remap and the source/destination grids information. + + ! Procedure: + + ! 1) A global SCRIP remapping file is read on all processors. + ! 2) Find local destination points in the global grid. + ! 3) Find which processor needs source data and setup buffer + ! information for sending data. + ! 4) Construct new src remapping for buffer received + + ! All information is stored in the TYPE(parinterinfo) output + ! data type + + ! Input arguments. + + ! Message passing information + INTEGER, INTENT(IN) :: mype, nproc, mpi_comm + ! Source grid local and global number of grid points + INTEGER, INTENT(IN) :: nsrclocpoints, nsrcglopoints + ! Source integer mask (0/1) for SCRIP compliance + INTEGER, INTENT(IN), DIMENSION(nsrclocpoints) :: srcmask + ! Source global addresses of each local grid point + INTEGER, INTENT(IN), DIMENSION(nsrclocpoints) :: srcgloind + ! Destination grid local and global number of grid points + INTEGER, INTENT(IN) :: ndstlocpoints, ndstglopoints + ! Destination integer mask (0/1) for SCRIP compliance + INTEGER, INTENT(IN), DIMENSION(ndstlocpoints) :: dstmask + ! Destination global addresses of each local grid point + INTEGER, INTENT(IN), DIMENSION(ndstlocpoints) :: dstgloind + ! SCRIP remapping data + TYPE(scripremaptype) :: remap + ! Switch for output communication patterns + LOGICAL :: lcommout + CHARACTER(len=*) :: commoutprefix + ! Unit to use for output + INTEGER :: iunit + + ! Output arguments + + ! Interpolation and message passing information + TYPE(parinterinfo), INTENT(OUT) :: pinfo + + ! Local variable + + ! Variable for global <-> local address/pe information + INTEGER, DIMENSION(:), ALLOCATABLE :: ilsrcmppmap, ilsrclocind ! nsrcglopoints + INTEGER, DIMENSION(:), ALLOCATABLE :: igsrcmppmap, igsrclocind ! nsrcglopoints + INTEGER, DIMENSION(:), ALLOCATABLE :: ildstmppmap, ildstlocind ! ndstglopoints + INTEGER, DIMENSION(:), ALLOCATABLE :: igdstmppmap, igdstlocind ! ndstglopoints + INTEGER, DIMENSION(:), ALLOCATABLE :: isrcpe,isrcpetmp ! nsrcglopoints + INTEGER, DIMENSION(:), ALLOCATABLE :: isrcaddtmp ! nsrcglopoints + + INTEGER, DIMENSION(0:nproc-1) :: isrcoffset + INTEGER, DIMENSION(nproc) :: isrcno, isrcoff, isrccur + INTEGER, DIMENSION(nproc) :: ircvoff, ircvcur + INTEGER, DIMENSION(:), ALLOCATABLE :: isrctot, ircvtot + + ! Misc variable + INTEGER :: i,n,pe + INTEGER :: istatus, ierr + CHARACTER(len=256) :: cdfile + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('parinter_init',0,zhook_handle) + IF(ln_timing) CALL timing_start('parinter_init') + + ! Allocate arrays from HEAP to reduce STACK pressure + + ierr = 0 ! Gets incremented in 'allocmem_errchk' if istatus was non-zero + + ALLOCATE(ilsrcmppmap(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'ilsrcmppmap',nsrcglopoints,ierr) + + ALLOCATE(ilsrclocind(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'ilsrclocind',nsrcglopoints,ierr) + + ALLOCATE(igsrcmppmap(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'igsrcmppmap',nsrcglopoints,ierr) + + ALLOCATE(igsrclocind(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'igsrclocind',nsrcglopoints,ierr) + + ALLOCATE(ildstmppmap(ndstglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'ildstmppmap',nsrcglopoints,ierr) + + ALLOCATE(ildstlocind(ndstglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'ildstlocind',nsrcglopoints,ierr) + + ALLOCATE(igdstmppmap(ndstglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'igdstmppmap',nsrcglopoints,ierr) + + ALLOCATE(igdstlocind(ndstglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'igdstlocind',nsrcglopoints,ierr) + + ALLOCATE(isrcpe(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'isrcpe',nsrcglopoints,ierr) + + ALLOCATE(isrcpetmp(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'isrcpetmp',nsrcglopoints,ierr) + + ALLOCATE(isrcaddtmp(nsrcglopoints),stat=istatus) + CALL allocmem_errchk(iunit,istatus,__MYFILE__,__LINE__,'isrcaddtmp',nsrcglopoints,ierr) + + IF (ierr > 0) THEN + WRITE(iunit,*) 'PARINTER_INIT: Could not allocate memory: ierr=',ierr + WRITE(iunit,*) 'nsrcglopoints, ndstglopoints=',nsrcglopoints, ndstglopoints + WRITE(iunit,*) 'nsrclocpoints, ndstlocpoints=',nsrclocpoints, ndstlocpoints + CALL flush(iunit) + CALL abort + ENDIF + + ! Check that masks are consistent. + + ! Remark: More consistency tests between remapping information + ! and input argument could be code, but for now we settle + ! for checking the masks. + + ! Source grid + + DO i=1,nsrclocpoints + IF (srcmask(i)/=remap%src%grid_imask(srcgloind(i))) THEN + WRITE(iunit,*)'PARINTER_INIT: Source imask is inconsistent at ' + WRITE(iunit,*)'global index = ',srcgloind(i) + WRITE(iunit,*)'Source mask = ',srcmask(i) + WRITE(iunit,*)'Remap mask = ',remap%src%grid_imask(srcgloind(i)) +#if defined REMAP_FULL + WRITE(iunit,*)'Latitude = ',remap%src%grid_center_lat(srcgloind(i)) + WRITE(iunit,*)'Longitude = ',remap%src%grid_center_lon(srcgloind(i)) +#endif + CALL flush(iunit) + CALL abort + ENDIF + ENDDO + + ! Destination grid + + DO i=1,ndstlocpoints + IF (dstmask(i)/=remap%dst%grid_imask(dstgloind(i))) THEN + WRITE(iunit,*)'PARINTER_INIT: Destination imask is inconsistent at ' + WRITE(iunit,*)'global index = ',dstgloind(i) + WRITE(iunit,*)'Destin mask = ',dstmask(i) + WRITE(iunit,*)'Remap mask = ',remap%dst%grid_imask(dstgloind(i)) +#if defined REMAP_FULL + WRITE(iunit,*)'Latitude = ',remap%dst%grid_center_lat(dstgloind(i)) + WRITE(iunit,*)'Longitude = ',remap%dst%grid_center_lon(dstgloind(i)) +#endif + CALL flush(iunit) + CALL abort + ENDIF + ENDDO + + ! Setup global to local and vice versa mappings. + + ilsrcmppmap(:)=-1 + ilsrclocind(:)=0 + ildstmppmap(:)=-1 + ildstlocind(:)=0 + + DO i=1,nsrclocpoints + ilsrcmppmap(srcgloind(i))=mype + ilsrclocind(srcgloind(i))=i + ENDDO + + DO i=1,ndstlocpoints + ildstmppmap(dstgloind(i))=mype + ildstlocind(dstgloind(i))=i + ENDDO + +#if defined key_mpp_mpi + CALL mpi_allreduce(ilsrcmppmap,igsrcmppmap,nsrcglopoints, & + & mpi_integer,mpi_max,mpi_comm,istatus) + CALL mpi_allreduce(ilsrclocind,igsrclocind,nsrcglopoints, & + & mpi_integer,mpi_max,mpi_comm,istatus) + CALL mpi_allreduce(ildstmppmap,igdstmppmap,ndstglopoints, & + & mpi_integer,mpi_max,mpi_comm,istatus) + CALL mpi_allreduce(ildstlocind,igdstlocind,ndstglopoints, & + & mpi_integer,mpi_max,mpi_comm,istatus) +#else + igsrcmppmap(:)=ilsrcmppmap(:) + igsrclocind(:)=ilsrclocind(:) + igdstmppmap(:)=ildstmppmap(:) + igdstlocind(:)=ildstlocind(:) +#endif + + ! Optionally construct an ascii file listing what src and + ! dest points belongs to which task + + ! Since igsrcmppmap and igdstmppmap are global data only do + ! this for mype==0. + +#if defined REMAP_FULL + + IF (lcommout.AND.(mype==0)) THEN + WRITE(cdfile,'(A,I6.6,A)')commoutprefix//'_srcmppmap_',mype+1,'.dat' + OPEN(9,file=cdfile) + DO i=1,nsrcglopoints + WRITE(9,*)remap%src%grid_center_lat(i),& + & remap%src%grid_center_lon(i), & + & igsrcmppmap(i)+1,remap%src%grid_imask(i) + ENDDO + CLOSE(9) + WRITE(cdfile,'(A,I6.6,A)')commoutprefix//'_dstmppmap_',mype+1,'.dat' + OPEN(9,file=cdfile) + DO i=1,ndstglopoints + WRITE(9,*)remap%dst%grid_center_lat(i),& + & remap%dst%grid_center_lon(i), & + & igdstmppmap(i)+1,remap%dst%grid_imask(i) + ENDDO + CLOSE(9) + ENDIF +#endif + ! + ! Standard interpolation in serial case is + ! + ! DO n=1,remap%num_links + ! zdst(remap%dst_address(n)) = zdst(remap%dst_address(n)) + & + ! & remap%remap_matrix(1,n)*zsrc(remap%src_address(n)) + ! END DO + ! + + ! In parallel we need to first find local number of links + + pinfo%num_links=0 + DO i=1,remap%num_links + IF (igdstmppmap(remap%dst_address(i))==mype) & + & pinfo%num_links=pinfo%num_links+1 + ENDDO + ALLOCATE(pinfo%dst_address(pinfo%num_links),& + & pinfo%src_address(pinfo%num_links),& + & pinfo%remap_matrix(1,pinfo%num_links)) + + ! Get local destination addresses + + n=0 + DO i=1,remap%num_links + IF (igdstmppmap(remap%dst_address(i))==mype) THEN + n=n+1 + pinfo%dst_address(n)=& + & igdstlocind(remap%dst_address(i)) + pinfo%remap_matrix(:,n)=& + & remap%remap_matrix(:,i) + ENDIF + ENDDO + + ! Get sending processors maps. + + ! The same data point might need to be sent to many processors + ! so first construct a map for processors needing the data + + isrcpe(:)=-1 + DO i=1,remap%num_links + IF (igdstmppmap(remap%dst_address(i))==mype) THEN + isrcpe(remap%src_address(i))=& + & igsrcmppmap(remap%src_address(i)) + ENDIF + ENDDO + + ! Optionally write a set if ascii file listing which tasks + ! mype needs to send to communicate with + +#if defined REMAP_FULL + + IF (lcommout) THEN + ! Destination processors + WRITE(cdfile,'(A,I6.6,A)')commoutprefix//'_dsts_',mype+1,'.dat' + OPEN(9,file=cdfile) + DO pe=0,nproc-1 + IF (pe==mype) THEN + isrcpetmp(:)=isrcpe(:) + ENDIF +#if defined key_mpp_mpi + CALL mpi_bcast(isrcpetmp,nsrcglopoints,mpi_integer,pe,mpi_comm,istatus) +#endif + DO i=1,nsrcglopoints + IF (isrcpetmp(i)==mype) THEN + WRITE(9,*)remap%src%grid_center_lat(i),& + & remap%src%grid_center_lon(i), & + & pe+1,mype+1 + ENDIF + ENDDO + ENDDO + CLOSE(9) + ENDIF + +#endif + + ! Get number of points to send to each processor + + ALLOCATE(pinfo%nsend(0:nproc-1)) + isrcno(:)=0 + DO i=1,nsrcglopoints + IF (isrcpe(i)>=0) THEN + isrcno(isrcpe(i)+1)=isrcno(isrcpe(i)+1)+1 + ENDIF + ENDDO +#if defined key_mpp_mpi + CALL mpi_alltoall(isrcno,1,mpi_integer, & + & pinfo%nsend(0:nproc-1),1,mpi_integer, & + & mpi_comm,istatus) +#else + pinfo%nsend(0:nproc-1) = isrcno(1:nproc) +#endif + pinfo%nsendtot=SUM(pinfo%nsend(0:nproc-1)) + + ! Construct sending buffer mapping. Data is mapping in + ! processor order. + + ALLOCATE(pinfo%send_address(pinfo%nsendtot)) + + ! Temporary arrays for mpi all to all. + + ALLOCATE(isrctot(SUM(isrcno(1:nproc)))) + ALLOCATE(ircvtot(SUM(pinfo%nsend(0:nproc-1)))) + + ! Offset for message parsing + + isrcoff(1)=0 + ircvoff(1)=0 + DO i=1,nproc-1 + isrcoff(i+1) = isrcoff(i) + isrcno(i) + ircvoff(i+1) = pinfo%nsend(i-1) + ircvoff(i) + ENDDO + + ! Pack indices i into a buffer + + isrccur(:)=0 + DO i=1,nsrcglopoints + IF (isrcpe(i)>=0) THEN + isrccur(isrcpe(i)+1)=isrccur(isrcpe(i)+1)+1 + isrctot(isrccur(isrcpe(i)+1)+isrcoff(isrcpe(i)+1)) = i + ENDIF + ENDDO + + ! Send the data + +#if defined key_mpp_mpi + CALL mpi_alltoallv(& + & isrctot,isrccur,isrcoff,mpi_integer, & + & ircvtot,pinfo%nsend(0:nproc-1),ircvoff,mpi_integer, & + & mpi_comm,istatus) +#else + ircvtot(:)=isrctot(:) +#endif + + ! Get the send address. ircvtot will at this point contain the + ! addresses in the global index needed for message passing + + DO i=1,pinfo%nsendtot + pinfo%send_address(i)=igsrclocind(ircvtot(i)) + ENDDO + + ! Deallocate the mpi all to all arrays + + DEALLOCATE(ircvtot,isrctot) + + ! Get number of points to receive to each processor + + ALLOCATE(pinfo%nrecv(0:nproc-1)) + pinfo%nrecv(0:nproc-1)=0 + DO i=1,nsrcglopoints + IF (isrcpe(i)>=0 .AND. isrcpe(i)<nproc) THEN + pinfo%nrecv(isrcpe(i))=pinfo%nrecv(isrcpe(i))+1 + ENDIF + ENDDO + pinfo%nrecvtot=SUM(pinfo%nrecv(0:nproc-1)) + + ! Find new src address mapping + + ! Setup local positions in the global array in a temporary array + ! taking into accound the processor ordering + + isrcaddtmp(:)=-1 + isrcoffset(0)=0 + DO pe=1,nproc-1 + isrcoffset(pe)=isrcoffset(pe-1)+pinfo%nrecv(pe-1) + ENDDO + + DO i=1,nsrcglopoints + IF (isrcpe(i)>=0 .AND. isrcpe(i)<nproc) THEN + isrcoffset(isrcpe(i))=isrcoffset(isrcpe(i))+1 + isrcaddtmp(i)=isrcoffset(isrcpe(i)) + ENDIF + ENDDO + + ! Find the local positions in the temporary array. + + n=0 + DO i=1,remap%num_links + IF (igdstmppmap(remap%dst_address(i))==mype) THEN + n=n+1 + pinfo%src_address(n)=isrcaddtmp(remap%src_address(i)) + ENDIF + ENDDO + + ! MPI displacements for mpi_alltoallv + + ALLOCATE(pinfo%nsdisp(0:nproc-1),pinfo%nrdisp(0:nproc-1)) + pinfo%nsdisp(0)=0 + pinfo%nrdisp(0)=0 + DO pe=1,nproc-1 + pinfo%nsdisp(pe)=pinfo%nsdisp(pe-1)+pinfo%nsend(pe-1) + pinfo%nrdisp(pe)=pinfo%nrdisp(pe-1)+pinfo%nrecv(pe-1) + ENDDO + + ! Optionally construct an ascii file listing number of + ! data to send and receive from which processor. + + IF (lcommout) THEN + WRITE(cdfile,'(A,I6.6,A)')commoutprefix//'_nsend_',mype+1,'.dat' + OPEN(9,file=cdfile) + DO pe=0,nproc-1 + WRITE(9,*)pe+1,pinfo%nsend(pe) + ENDDO + CLOSE(9) + WRITE(cdfile,'(A,I6.6,A)')commoutprefix//'_nrecv_',mype+1,'.dat' + OPEN(9,file=cdfile) + DO pe=0,nproc-1 + WRITE(9,*)pe+1,pinfo%nrecv(pe) + ENDDO + CLOSE(9) + ENDIF + + ! Deallocate HEAP arrays + + DEALLOCATE(isrcaddtmp) + DEALLOCATE(isrcpe,isrcpetmp) + DEALLOCATE(igdstmppmap,igdstlocind) + DEALLOCATE(ildstmppmap,ildstlocind) + DEALLOCATE(igsrcmppmap,igsrclocind) + DEALLOCATE(ilsrcmppmap,ilsrclocind) + + IF(ln_timing) CALL timing_stop('parinter_init') + IF(lhook) CALL dr_hook('parinter_init',1,zhook_handle) + + END SUBROUTINE parinter_init + + SUBROUTINE parinter_fld( mype, nproc, mpi_comm, & + & pinfo, nsrclocpoints, zsrc, ndstlocpoints, zdst ) + + ! Perform a single interpolation from the zsrc field + ! to zdst field based on the information in pinfk + + ! Input arguments + + ! Message passing information + INTEGER, INTENT(IN) :: mype, nproc, mpi_comm + ! Interpolation setup + TYPE(parinterinfo), INTENT(IN) :: pinfo + ! Source data/ + INTEGER, INTENT(IN) :: nsrclocpoints + REAL(wp), INTENT(IN), DIMENSION(nsrclocpoints) :: zsrc + + ! Output arguments + + ! Destination data + INTEGER , INTENT(IN):: ndstlocpoints + REAL(wp), DIMENSION(ndstlocpoints) :: zdst + + ! Local variables + + ! MPI send/recv buffers +#if defined key_parinter_alloc + REAL(scripdp) , ALLOCATABLE :: zsend(:),zrecv(:) +#else + REAL(scripdp) :: zsend(pinfo%nsendtot),zrecv(pinfo%nrecvtot) +#endif + ! Misc variables + INTEGER :: i,iproc,istatus,ierr,off,itag,irq,nreqs + INTEGER :: reqs(0:2*(nproc-1)) + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('parinter_fld',0,zhook_handle) + IF(ln_timing) CALL timing_start('parinter_fld') + +#if defined key_parinter_alloc + ALLOCATE(zsend(pinfo%nsendtot),zrecv(pinfo%nrecvtot)) +#endif + + ! Pack the sending buffer + + DO i=1,pinfo%nsendtot + zsend(i)=zsrc(pinfo%send_address(i)) + ENDDO + + ! Do the message passing + +#if defined key_mpp_mpi + + IF (lparinterp2p) THEN + + ! total num of reqs ( recv + send ) + nreqs = 2*(nproc-1) + ! post irecvs first + irq = 0 + DO iproc=0,nproc-1 + IF( pinfo%nrecv(iproc) > 0 .AND. iproc /= mype ) THEN + off = pinfo%nrdisp(iproc) + itag=100 + CALL mpi_irecv(zrecv(off+1),pinfo%nrecv(iproc),mpi_double_precision, & + & iproc,itag,mpi_comm,reqs(irq),ierr) + irq = irq + 1 + IF( irq > nreqs ) THEN + WRITE(0,*)'parinter_fld_mult: exceeded number of reqs when posting recvs',mype + CALL abort + ENDIF + ENDIF + ENDDO + ! post isends + DO iproc=0,nproc-1 + IF( pinfo%nsend(iproc) > 0 ) THEN + IF( iproc == mype ) THEN + zrecv( pinfo%nrdisp(iproc)+1:pinfo%nrdisp(iproc)+pinfo%nsend(iproc) ) = & + & zsend( pinfo%nsdisp(iproc)+1:pinfo%nsdisp(iproc)+pinfo%nsend(iproc) ) + ELSE + off = pinfo%nsdisp(iproc) + itag=100 + CALL mpi_isend(zsend(off+1),pinfo%nsend(iproc),mpi_double_precision, & + & iproc,itag,mpi_comm,reqs(irq),ierr) + irq = irq + 1 + IF( irq > nreqs ) THEN + WRITE(0,*)'parinter_fld_mult: exceeded number of reqs when posting sends',mype + CALL abort + ENDIF + ENDIF + ENDIF + ENDDO + ! wait on requests + CALL mpi_waitall(irq,reqs,MPI_STATUSES_IGNORE,ierr) + + ELSE + + CALL mpi_alltoallv(& + & zsend,pinfo%nsend(0:nproc-1),& + & pinfo%nsdisp(0:nproc-1),mpi_double_precision, & + & zrecv,pinfo%nrecv(0:nproc-1), & + & pinfo%nrdisp(0:nproc-1),mpi_double_precision, & + & mpi_comm,istatus) + + ENDIF +#else + + zrecv(:)=zsend(:) + +#endif + + ! Do the interpolation + + zdst(:)=0.0 + DO i=1,pinfo%num_links + zdst(pinfo%dst_address(i)) = zdst(pinfo%dst_address(i)) + & + & pinfo%remap_matrix(1,i)*zrecv(pinfo%src_address(i)) + END DO + +#if defined key_parinter_alloc + DEALLOCATE(zsend,zrecv) +#endif + + IF(ln_timing) CALL timing_stop('parinter_fld') + IF(lhook) CALL dr_hook('parinter_fld',1,zhook_handle) + + END SUBROUTINE parinter_fld + + SUBROUTINE parinter_fld_mult( nfield, & + & mype, nproc, mpi_comm, & + & pinfo, nsrclocpoints, zsrc, ndstlocpoints, zdst ) + + ! Perform a single interpolation from the zsrc field + ! to zdst field based on the information in pinfk + + ! Input arguments + + ! Message passing information + INTEGER, INTENT(IN) :: mype, nproc, mpi_comm, nfield + ! Interpolation setup + TYPE(parinterinfo), INTENT(IN) :: pinfo + ! Source data/ + INTEGER, INTENT(IN) :: nsrclocpoints + REAL(wp), INTENT(IN), DIMENSION(nsrclocpoints,nfield) :: zsrc + + ! Output arguments + + ! Destination data + INTEGER, INTENT(IN):: ndstlocpoints + REAL(wp), DIMENSION(ndstlocpoints,nfield) :: zdst + + INTEGER :: nsend(0:nproc-1), nrecv(0:nproc-1),nrdisp(0:nproc-1), nsdisp(0:nproc-1) + + ! Local variables + + ! MPI send/recv buffers +#if defined key_parinter_alloc + REAL(scripdp), ALLOCATABLE, DIMENSION(:,:) :: zrecvnf + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: zsend, zrecv +#else + REAL(scripdp) :: zrecvnf(pinfo%nrecvtot,nfield) + REAL(scripdp) :: zsend(pinfo%nsendtot*nfield), & + & zrecv(pinfo%nrecvtot*nfield) +#endif + ! Misc variables + INTEGER :: i,istatus,ierr + INTEGER :: nf, ibases, ibaser, np, iproc, off, itag, irq, nreqs + INTEGER :: reqs(0:2*(nproc-1)) + REAL(jphook) :: zhook_handle ! Dr Hook handle + INTEGER, DIMENSION(nfield,0:nproc-1) :: ibaseps, ibasepr + + IF(lhook) CALL dr_hook('parinter_fld_mult',0,zhook_handle) + IF(ln_timing) CALL timing_start('parinter_fld_mult') + + ! Allocate temporary arrays on heap + +#if defined key_parinter_alloc + ALLOCATE(zrecvnf(pinfo%nrecvtot,nfield),& + & zsend(pinfo%nsendtot*nfield),zrecv(pinfo%nrecvtot*nfield)) +#endif + + ! Compute starts for packing + + ibases=0 + ibaser=0 + DO np=0,nproc-1 + DO nf=1,nfield + ibaseps(nf,np) = ibases + ibasepr(nf,np) = ibaser + ibases = ibases + pinfo%nsend(np) + ibaser = ibaser + pinfo%nrecv(np) + ENDDO + ENDDO + + ! Pack the sending buffer + + !$omp parallel default(shared) private(nf,np,i) + !$omp do schedule(dynamic) + DO np=0,nproc-1 + DO nf=1,nfield + DO i=1,pinfo%nsend(np) + zsend(i+ibaseps(nf,np))=& + & zsrc(pinfo%send_address(i+pinfo%nsdisp(np)),nf) + ENDDO + ENDDO + nsend(np)=pinfo%nsend(np)*nfield + nrecv(np)=pinfo%nrecv(np)*nfield + nrdisp(np)=pinfo%nrdisp(np)*nfield + nsdisp(np)=pinfo%nsdisp(np)*nfield + ENDDO + !$omp end do + !$omp end parallel + + ! Do the message passing + +#if defined key_mpp_mpi + + IF (lparinterp2p) THEN + + ! total num of reqs ( recv + send ) + nreqs = 2*(nproc-1) + ! post irecvs first + irq = 0 + DO iproc=0,nproc-1 + IF( nrecv(iproc) > 0 .AND. iproc /= mype ) THEN + off = nrdisp(iproc) + itag=100 + CALL mpi_irecv(zrecv(off+1),nrecv(iproc),mpi_double_precision, & + & iproc,itag,mpi_comm,reqs(irq),ierr) + irq = irq + 1 + IF( irq > nreqs ) THEN + WRITE(0,*)'parinter_fld_mult: exceeded number of reqs when posting recvs',mype + CALL abort + ENDIF + ENDIF + ENDDO + ! post isends + DO iproc=0,nproc-1 + IF( nsend(iproc) > 0 ) THEN + IF( iproc == mype ) THEN + zrecv( nrdisp(iproc)+1:nrdisp(iproc)+nsend(iproc) ) = & + & zsend( nsdisp(iproc)+1:nsdisp(iproc)+nsend(iproc) ) + ELSE + off = nsdisp(iproc) + itag=100 + CALL mpi_isend(zsend(off+1),nsend(iproc),mpi_double_precision, & + & iproc,itag,mpi_comm,reqs(irq),ierr) + irq = irq + 1 + IF( irq > nreqs ) THEN + WRITE(0,*)'parinter_fld_mult: exceeded number of reqs when posting sends',mype + CALL abort + ENDIF + ENDIF + ENDIF + ENDDO + ! wait on requests + CALL mpi_waitall(irq,reqs,MPI_STATUSES_IGNORE,ierr) + + ELSE + + IF(mype==0)WRITE(0,*)'lparinterp2p off' + CALL mpi_alltoallv(& + & zsend,nsend(0:nproc-1),& + & nsdisp(0:nproc-1),mpi_double_precision, & + & zrecv,nrecv(0:nproc-1), & + & nrdisp(0:nproc-1),mpi_double_precision, & + & mpi_comm,istatus) + + ENDIF +#else + + zrecv(:)=zsend(:) + +#endif + + ! Unpack individual fields + + !$omp parallel default(shared) private(nf,np,i) + + !$omp do schedule (dynamic) + DO np=0,nproc-1 + DO nf=1,nfield + DO i=1,pinfo%nrecv(np) + zrecvnf(i+pinfo%nrdisp(np),nf)=zrecv(i+ibasepr(nf,np)) + ENDDO + ENDDO + ENDDO + !omp end do + + ! Do the interpolation + + !$omp do + DO nf=1,nfield + zdst(:,nf)=0.0 + DO i=1,pinfo%num_links + zdst(pinfo%dst_address(i),nf) = zdst(pinfo%dst_address(i),nf) + & + & pinfo%remap_matrix(1,i)*zrecvnf(pinfo%src_address(i),nf) + END DO + END DO + !$omp end do + + !$omp end parallel + +#if defined key_parinter_alloc + DEALLOCATE( zrecvnf, zsend, zrecv ) +#endif + + IF(ln_timing) CALL timing_stop('parinter_fld_mult') + IF(lhook) CALL dr_hook('parinter_fld_mult',1,zhook_handle) + + END SUBROUTINE parinter_fld_mult + + SUBROUTINE parinter_write( mype, nproc, nprocx, nprocy, & + & nsrcglopoints, ndstglopoints, & + & pinfo, cdpath, cdprefix ) + + ! Write pinfo information in a netCDF file in order to + ! be able to read it rather than calling parinter_init + + ! Input arguments. + + ! Message passing information + INTEGER, INTENT(IN) :: mype, nproc, nprocx, nprocy + ! Source grid local global number of grid points + INTEGER, INTENT(IN) :: nsrcglopoints + ! Destination grid global number of grid points + INTEGER, INTENT(IN) :: ndstglopoints + ! Interpolation and message passing information + TYPE(parinterinfo), INTENT(IN) :: pinfo + ! Path and file prefix + CHARACTER(len=*) :: cdpath, cdprefix + + ! Local variable + + ! Misc variable + CHARACTER(len=1024) :: cdfile + INTEGER :: ncid, dimnl, dimnw, dimnst, dimnrt, dimnpr + INTEGER :: dims1(1), dims2(2) + INTEGER :: idda, idsa, idrm, idns, idsaa, idnr, idnrp, idnsp + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('parinter_write',0,zhook_handle) + IF(ln_timing) CALL timing_start('parinter_write') + + WRITE(cdfile,'(A,2(i10.10,A),4(I6.6,A),A)') & + & TRIM(cdpath)//'/'//TRIM(cdprefix)//'_', & + & nsrcglopoints,'_',ndstglopoints,'_',mype,& + & '_',nproc,'_',nprocx,'x',nprocy,'.nc' + + CALL nchdlerr(nf90_create(TRIM(cdfile),nf90_clobber,ncid), & + & __LINE__, __MYFILE__ ) + + ! To avoid problems with multiple unlimited netCDF dimensions + ! we don't write num_links, nsendtot and nrecvtot if + ! they are 0. If they are not there we assume they are 0 + ! in parinter_read. + + IF (pinfo%num_links>0) THEN + CALL nchdlerr(nf90_def_dim(ncid,'num_links',& + & pinfo%num_links,dimnl),& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr(nf90_def_dim(ncid,'num_wgts',& + & 1,dimnw),& + & __LINE__,__MYFILE__) + + IF (pinfo%nsendtot>0) THEN + CALL nchdlerr(nf90_def_dim(ncid,'nsendtot',& + & pinfo%nsendtot,dimnst),& + & __LINE__,__MYFILE__) + ENDIF + + IF (pinfo%nrecvtot>0) THEN + CALL nchdlerr(nf90_def_dim(ncid,'nrecvtot',& + & pinfo%nrecvtot,dimnrt),& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr(nf90_def_dim(ncid,'nproc',& + & nproc,dimnpr),& + & __LINE__,__MYFILE__) + + IF (pinfo%num_links>0) THEN + + dims1(1)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'dst_address',& + & nf90_int,dims1,idda),& + & __LINE__,__MYFILE__) + + dims1(1)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'src_address',& + & nf90_int,dims1,idsa),& + & __LINE__,__MYFILE__) + + dims2(1)=dimnw + dims2(2)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'remap_matrix',& + & nf90_double,dims2,idrm),& + & __LINE__,__MYFILE__) + + ENDIF + + dims1(1)=dimnpr + CALL nchdlerr(nf90_def_var(ncid,'nsend',& + & nf90_int,dims1,idns),& + & __LINE__,__MYFILE__) + + IF (pinfo%nsendtot>0) THEN + + dims1(1)=dimnst + CALL nchdlerr(nf90_def_var(ncid,'send_address',& + & nf90_int,dims1,idsaa),& + & __LINE__,__MYFILE__) + + ENDIF + + dims1(1)=dimnpr + CALL nchdlerr(nf90_def_var(ncid,'nrecv',& + & nf90_int,dims1,idnr),& + & __LINE__,__MYFILE__) + + dims1(1)=dimnpr + CALL nchdlerr(nf90_def_var(ncid,'nsdisp',& + & nf90_int,dims1,idnsp),& + & __LINE__,__MYFILE__) + + dims1(1)=dimnpr + CALL nchdlerr(nf90_def_var(ncid,'nrdisp',& + & nf90_int,dims1,idnrp),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_enddef(ncid),__LINE__,__MYFILE__) + + + IF (pinfo%num_links>0) THEN + + CALL nchdlerr(nf90_put_var(ncid,idda,pinfo%dst_address),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idsa,pinfo%src_address),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idrm,pinfo%remap_matrix),& + & __LINE__,__MYFILE__) + + ENDIF + + CALL nchdlerr(nf90_put_var(ncid,idns,pinfo%nsend(0:nproc-1)),& + & __LINE__,__MYFILE__) + + IF (pinfo%nsendtot>0) THEN + + CALL nchdlerr(nf90_put_var(ncid,idsaa,pinfo%send_address),& + & __LINE__,__MYFILE__) + + ENDIF + + CALL nchdlerr(nf90_put_var(ncid,idnr,pinfo%nrecv(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idnsp,pinfo%nsdisp(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idnrp,pinfo%nrdisp(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_close(ncid),__LINE__, __MYFILE__ ) + + IF(ln_timing) CALL timing_stop('parinter_write') + IF(lhook) CALL dr_hook('parinter_write',1,zhook_handle) + + END SUBROUTINE parinter_write + + SUBROUTINE parinter_read( mype, nproc, nprocx, nprocy, & + & nsrcglopoints, ndstglopoints, & + & pinfo, cdpath, cdprefix, lexists ) + + ! Write pinfo information in a netCDF file in order to + ! be able to read it rather than calling parinter_init + + ! Input arguments. + + ! Message passing information + INTEGER, INTENT(IN) :: mype, nproc, nprocx, nprocy + ! Source grid local global number of grid points + INTEGER, INTENT(IN) :: nsrcglopoints + ! Destination grid global number of grid points + INTEGER, INTENT(IN) :: ndstglopoints + ! Interpolation and message passing information + TYPE(parinterinfo), INTENT(OUT) :: pinfo + ! Does the information exists + LOGICAL :: lexists + ! Path and file prefix + CHARACTER(len=*) :: cdpath, cdprefix + + ! Local variable + + ! Misc variable + CHARACTER(len=1024) :: cdfile + INTEGER :: ncid, dimid, varid, num_wgts + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('parinter_read',0,zhook_handle) + IF(ln_timing) CALL timing_start('parinter_read') + + WRITE(cdfile,'(A,2(i10.10,A),4(I6.6,A),A)') & + & TRIM(cdpath)//'/'//TRIM(cdprefix)//'_', & + & nsrcglopoints,'_',ndstglopoints,'_',mype,& + & '_',nproc,'_',nprocx,'x',nprocy,'.nc' + + + lexists=nf90_open(TRIM(cdfile),nf90_nowrite,ncid)==nf90_noerr + + IF (lexists) THEN + + ! If num_links is not present we assume it to be zero. + + IF (nf90_inq_dimid(ncid,'num_links',dimid)==nf90_noerr) THEN + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=pinfo%num_links),& + & __LINE__,__MYFILE__) + ELSE + pinfo%num_links=0 + ENDIF + + CALL nchdlerr(nf90_inq_dimid(ncid,'num_wgts',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=num_wgts),& + & __LINE__,__MYFILE__) + IF (num_wgts/=1) THEN + WRITE(0,*)'parinter_read: num_wgts has to be 1 for now' + CALL abort + ENDIF + + ! If nsendtot is not present we assume it to be zero. + + IF (nf90_inq_dimid(ncid,'nsendtot',dimid)==nf90_noerr) THEN + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=pinfo%nsendtot),& + & __LINE__,__MYFILE__) + ELSE + pinfo%nsendtot=0 + ENDIF + + IF(nf90_inq_dimid(ncid,'nrecvtot',dimid)==nf90_noerr) THEN + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=pinfo%nrecvtot),& + & __LINE__,__MYFILE__) + ELSE + pinfo%nrecvtot=0 + ENDIF + + ALLOCATE(pinfo%dst_address(pinfo%num_links),& + & pinfo%src_address(pinfo%num_links),& + & pinfo%remap_matrix(num_wgts,pinfo%num_links),& + & pinfo%nsend(0:nproc-1),& + & pinfo%send_address(pinfo%nsendtot),& + & pinfo%nrecv(0:nproc-1),& + & pinfo%nsdisp(0:nproc-1),& + & pinfo%nrdisp(0:nproc-1)) + + IF (pinfo%num_links>0) THEN + CALL nchdlerr(nf90_inq_varid(ncid,'dst_address',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%dst_address),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'src_address',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%src_address),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'remap_matrix',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%remap_matrix),& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr(nf90_inq_varid(ncid,'nsend',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%nsend(0:nproc-1)),& + & __LINE__,__MYFILE__) + + IF (pinfo%nsendtot>0) THEN + + CALL nchdlerr(nf90_inq_varid(ncid,'send_address',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%send_address),& + & __LINE__,__MYFILE__) + + ENDIF + + CALL nchdlerr(nf90_inq_varid(ncid,'nrecv',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%nrecv(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'nsdisp',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%nsdisp(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'nrdisp',varid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,pinfo%nrdisp(0:nproc-1)),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_close(ncid),__LINE__, __MYFILE__ ) + + ENDIF + + IF(ln_timing) CALL timing_stop('parinter_read') + IF(lhook) CALL dr_hook('parinter_read',1,zhook_handle) + + END SUBROUTINE parinter_read + +END MODULE parinter \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/scripgrid.F90 b/V4.0/nemo_sources/src/OCE/ECM/scripgrid.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bc3a46ff47a9960a8f0aa208620cdafa8083f67f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/scripgrid.F90 @@ -0,0 +1,357 @@ +#define __MYFILE__ 'scripgrid.F90' +MODULE scripgrid + + USE nctools + USE scrippar + USE timing +#if defined key_dr_hook + USE yomhook, ONLY : lhook, dr_hook, jphook ! IFS Dr_Hook +#else + USE modhookdummy, ONLY : lhook, dr_hook, jphook ! Dummy Dr_Hook +#endif + USE in_out_manager + + IMPLICIT NONE + + TYPE scripgridtype + INTEGER :: grid_size + INTEGER :: grid_corners + INTEGER :: grid_rank + INTEGER, ALLOCATABLE, DIMENSION(:) :: grid_dims +#if defined REMAP_FULL + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: grid_center_lat + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: grid_center_lon +#endif + INTEGER, ALLOCATABLE, DIMENSION(:) :: grid_imask +#if defined REMAP_FULL + REAL(scripdp), ALLOCATABLE, DIMENSION(:,:) :: grid_corner_lat + REAL(scripdp), ALLOCATABLE, DIMENSION(:,:) :: grid_corner_lon + CHARACTER(len=scriplen) :: grid_center_lat_units + CHARACTER(len=scriplen) :: grid_center_lon_units +#endif + CHARACTER(len=scriplen) :: grid_imask_units +#if defined REMAP_FULL + CHARACTER(len=scriplen) :: grid_corner_lat_units + CHARACTER(len=scriplen) :: grid_corner_lon_units + CHARACTER(len=scriplen) :: title +#endif + END TYPE scripgridtype + +CONTAINS + + SUBROUTINE scripgrid_read( cdfilename, grid ) + + CHARACTER(len=*) :: cdfilename + TYPE(scripgridtype) :: grid + + INTEGER :: ncid, dimid, varid + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripgrid_read',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripgrid_read') + + CALL scripgrid_init(grid) + + CALL nchdlerr(nf90_open(TRIM(cdfilename),nf90_nowrite,ncid),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'grid_size',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=grid%grid_size),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'grid_corners',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=grid%grid_corners),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'grid_rank',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=grid%grid_rank),& + & __LINE__,__MYFILE__) + + CALL scripgrid_alloc(grid) + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_dims',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_dims),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_center_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',grid%grid_center_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_center_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',grid%grid_center_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_center_lon),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_corner_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',grid%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_corner_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_corner_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',grid%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_corner_lon),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_inq_varid(ncid,'grid_imask',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',grid%grid_imask_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,grid%grid_imask),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'title',grid%title),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_close(ncid),__LINE__,__MYFILE__) + + IF(ln_timing) CALL timing_stop('scripgrid_read') + IF(lhook) CALL dr_hook('scripgrid_read',1,zhook_handle) + + END SUBROUTINE scripgrid_read + + SUBROUTINE scripgrid_write( cdgridfile, grid ) + + CHARACTER(len=*) :: cdgridfile + TYPE(scripgridtype) :: grid + + INTEGER :: ncid + INTEGER :: ioldfill + INTEGER :: idimsize,idimxsize,idimysize,idimcorners,idimrank + INTEGER :: idims1rank(1),idims1size(1),idims2(2) + INTEGER :: iddims,idcentlat,idcentlon,idimask,idcornlat,idcornlon + INTEGER :: igriddims(2) + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripgrid_write',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripgrid_write') + + ! Setup netcdf file + + CALL nchdlerr(nf90_create(TRIM(cdgridfile),nf90_clobber,ncid),& + & __LINE__,__MYFILE__) + + ! Define dimensions + + CALL nchdlerr(nf90_def_dim(ncid,'grid_size',& + & grid%grid_size,idimsize),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_def_dim(ncid,'grid_corners',& + & grid%grid_corners,idimcorners),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_def_dim(ncid,'grid_rank',& + & grid%grid_rank,idimrank),& + & __LINE__,__MYFILE__) + + idims1rank(1) = idimrank + + idims1size(1) = idimsize + + idims2(1) = idimcorners + idims2(2) = idimsize + + ! Define variables + + CALL nchdlerr(nf90_def_var(ncid,'grid_dims',& + & nf90_int,idims1rank,iddims),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_def_var(ncid,'grid_center_lat',& + & nf90_double,idims1size,idcentlat),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idcentlat,'units',& + & grid%grid_center_lat_units),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_var(ncid,'grid_center_lon',& + & nf90_double,idims1size,idcentlon),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idcentlon,'units',& + & grid%grid_center_lon_units),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_def_var(ncid,'grid_imask',& + & nf90_int,idims1size,idimask),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idimask,'units',& + & grid%grid_imask_units),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_def_var(ncid,'grid_corner_lat',& + & nf90_double,idims2,idcornlat),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idcornlat,'units',& + & grid%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_var(ncid,'grid_corner_lon',& + & nf90_double,idims2,idcornlon),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idcornlon,'units',& + & grid%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'title',& + & TRIM(grid%title)),& + & __LINE__,__MYFILE__) + +#endif + + ! End of netCDF definition phase + + CALL nchdlerr(nf90_enddef(ncid),__LINE__,__MYFILE__) + + ! Write variables + + + CALL nchdlerr(nf90_put_var(ncid,iddims,grid%grid_dims),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_put_var(ncid,idcentlat,& + & grid%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idcentlon,& + & grid%grid_center_lon),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_put_var(ncid,idimask,& + & grid%grid_imask), & + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_put_var(ncid,idcornlat,& + & grid%grid_corner_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idcornlon,& + & grid%grid_corner_lon),& + & __LINE__,__MYFILE__) + +#endif + + ! Close file + + CALL nchdlerr(nf90_close(ncid),__LINE__,__MYFILE__) + + IF(ln_timing) CALL timing_stop('scripgrid_write') + IF(lhook) CALL dr_hook('scripgrid_write',1,zhook_handle) + + END SUBROUTINE scripgrid_write + + SUBROUTINE scripgrid_init( grid ) + + TYPE(scripgridtype) :: grid + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripgrid_init',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripgrid_init') + + grid%grid_size=0 + grid%grid_corners=0 + grid%grid_rank=0 +#if defined REMAP_FULL + grid%grid_center_lat_units='' + grid%grid_center_lon_units='' +#endif + grid%grid_imask_units='' +#if defined REMAP_FULL + grid%grid_corner_lat_units='' + grid%grid_corner_lon_units='' + grid%title='' +#endif + IF(ln_timing) CALL timing_stop('scripgrid_init') + IF(lhook) CALL dr_hook('scripgrid_init',1,zhook_handle) + + END SUBROUTINE scripgrid_init + + SUBROUTINE scripgrid_alloc( grid ) + + TYPE(scripgridtype) :: grid + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripgrid_alloc',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripgrid_alloc') + + IF ( (grid%grid_size == 0) .OR. & + & (grid%grid_corners == 0) .OR. & + & (grid%grid_rank == 0) ) THEN + WRITE(*,*)'scripgridtype not initialized' + CALL abort + ENDIF + + ALLOCATE( & + & grid%grid_dims(grid%grid_rank), & +#if defined REMAP_FULL + & grid%grid_center_lat(grid%grid_size), & + & grid%grid_center_lon(grid%grid_size), & + & grid%grid_corner_lat(grid%grid_corners, grid%grid_size), & + & grid%grid_corner_lon(grid%grid_corners, grid%grid_size), & +#endif + & grid%grid_imask(grid%grid_size) & + & ) + + IF(ln_timing) CALL timing_stop('scripgrid_alloc') + IF(lhook) CALL dr_hook('scripgrid_alloc',1,zhook_handle) + + END SUBROUTINE scripgrid_alloc + + SUBROUTINE scripgrid_dealloc( grid ) + + TYPE(scripgridtype) :: grid + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripgrid_dealloc',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripgrid_dealloc') + + DEALLOCATE( & + & grid%grid_dims, & +#if defined REMAP_FULL + & grid%grid_center_lat, & + & grid%grid_center_lon, & + & grid%grid_corner_lat, & + & grid%grid_corner_lon, & +#endif + & grid%grid_imask & + & ) + + IF(ln_timing) CALL timing_stop('scripgrid_dealloc') + IF(lhook) CALL dr_hook('scripgrid_dealloc',1,zhook_handle) + + END SUBROUTINE scripgrid_dealloc + +END MODULE scripgrid \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/scrippar.F90 b/V4.0/nemo_sources/src/OCE/ECM/scrippar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b7fc3db80393e24ba199d0811eb04501dada514b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/scrippar.F90 @@ -0,0 +1,4 @@ +MODULE scrippar + INTEGER, PARAMETER :: scripdp = SELECTED_REAL_KIND(12,307) + INTEGER, PARAMETER :: scriplen = 80 +END MODULE scrippar \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ECM/scripremap.F90 b/V4.0/nemo_sources/src/OCE/ECM/scripremap.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0c5f96c4bcbfd9cc51c20f64ebe3254f13f99ce9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ECM/scripremap.F90 @@ -0,0 +1,903 @@ +#define __MYFILE__ 'scripremap.F90' +MODULE scripremap + +#if defined key_mpp_mpi + USE mpi +#endif + USE nctools + USE scrippar + USE scripgrid + USE timing +#if defined key_dr_hook + USE yomhook, ONLY : lhook, dr_hook, jphook ! IFS Dr_Hook +#else + USE modhookdummy, ONLY : lhook, dr_hook, jphook ! Dummy Dr_Hook +#endif + USE in_out_manager + USE dom_oce + + IMPLICIT NONE + + TYPE scripremaptype + INTEGER :: num_links + INTEGER :: num_wgts + TYPE(scripgridtype) :: src + TYPE(scripgridtype) :: dst +#if defined REMAP_FULL + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: src_grid_area + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: dst_grid_area + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: src_grid_frac + REAL(scripdp), ALLOCATABLE, DIMENSION(:) :: dst_grid_frac +#endif + INTEGER, ALLOCATABLE, DIMENSION(:) :: src_address + INTEGER, ALLOCATABLE, DIMENSION(:) :: dst_address + REAL(scripdp), ALLOCATABLE, DIMENSION(:,:) :: remap_matrix +#if defined REMAP_FULL + CHARACTER(len=scriplen) :: src_grid_area_units + CHARACTER(len=scriplen) :: dst_grid_area_units + CHARACTER(len=scriplen) :: src_grid_frac_units + CHARACTER(len=scriplen) :: dst_grid_frac_units + CHARACTER(len=scriplen) :: title + CHARACTER(len=scriplen) :: normalization + CHARACTER(len=scriplen) :: map_method + CHARACTER(len=scriplen) :: history + CHARACTER(len=scriplen) :: conventions +#endif + END TYPE scripremaptype + + INTEGER, PUBLIC :: nremapbcstchunk = 2048**2 + INTEGER, PUBLIC :: nremapreadchunk = -1 + +CONTAINS + + SUBROUTINE scripremap_read_work(cdfilename,remap) + + CHARACTER(len=*) :: cdfilename + TYPE(scripremaptype) :: remap + + INTEGER :: ncid, dimid, varid + LOGICAL :: lcorners + INTEGER :: jjj,jj_count + + lcorners=.TRUE. + + CALL scripremap_init(remap) + + CALL nchdlerr(nf90_open(TRIM(cdfilename),nf90_nowrite,ncid),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'src_grid_size',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%src%grid_size),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'dst_grid_size',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%dst%grid_size),& + & __LINE__,__MYFILE__) + + + IF (nf90_inq_dimid(ncid,'src_grid_corners',dimid)==nf90_noerr) THEN + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%src%grid_corners),& + & __LINE__,__MYFILE__) + ELSE + lcorners=.FALSE. + remap%src%grid_corners=1 + ENDIF + + IF (lcorners) THEN + CALL nchdlerr(nf90_inq_dimid(ncid,'dst_grid_corners',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%dst%grid_corners),& + & __LINE__,__MYFILE__) + ELSE + remap%dst%grid_corners=1 + ENDIF + + CALL nchdlerr(nf90_inq_dimid(ncid,'src_grid_rank',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%src%grid_rank),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'dst_grid_rank',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%dst%grid_rank),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'num_links',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%num_links),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_dimid(ncid,'num_wgts',dimid),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=remap%num_wgts),& + & __LINE__,__MYFILE__) + + CALL scripremap_alloc(remap) + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_dims',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_dims),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_dims',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_dims),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_center_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src%grid_center_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_center_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst%grid_center_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_center_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src%grid_center_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_center_lon),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_center_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst%grid_center_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_center_lon),& + & __LINE__,__MYFILE__) + + IF (lcorners) THEN + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_corner_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_corner_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_corner_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_corner_lon),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_corner_lat',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_corner_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_corner_lon',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_corner_lon),& + & __LINE__,__MYFILE__) + + ELSE + + remap%src%grid_corner_lat(:,:) = 0.0 + remap%src%grid_corner_lon(:,:) = 0.0 + remap%dst%grid_corner_lat(:,:) = 0.0 + remap%dst%grid_corner_lon(:,:) = 0.0 + remap%src%grid_corner_lat_units = '' + remap%src%grid_corner_lon_units = '' + remap%dst%grid_corner_lat_units = '' + remap%dst%grid_corner_lon_units = '' + + ENDIF + +#endif + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_imask',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src%grid_imask_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src%grid_imask),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_imask',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst%grid_imask_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst%grid_imask),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_area',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src_grid_area_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src_grid_area),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_area',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst_grid_area_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst_grid_area),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'src_grid_frac',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%src_grid_frac_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src_grid_frac),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_grid_frac',varid), & + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,varid,'units',remap%dst_grid_frac_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst_grid_frac),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_inq_varid(ncid,'src_address',varid), & + & __LINE__,__MYFILE__) + IF (nremapreadchunk<=0) THEN + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src_address),& + & __LINE__,__MYFILE__) + ELSE + DO jjj=1,remap%num_links,nremapreadchunk + jj_count=MIN(nremapreadchunk,remap%num_links-jjj+1) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%src_address(jjj:jjj+jj_count-1),& + & start=(/jjj/),count=(/jj_count/)),& + & __LINE__,__MYFILE__) + ENDDO + ENDIF + + CALL nchdlerr(nf90_inq_varid(ncid,'dst_address',varid), & + & __LINE__,__MYFILE__) + IF (nremapreadchunk<=0) THEN + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst_address),& + & __LINE__,__MYFILE__) + ELSE + DO jjj=1,remap%num_links,nremapreadchunk + jj_count=MIN(nremapreadchunk,remap%num_links-jjj+1) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%dst_address(jjj:jjj+jj_count-1),& + & start=(/jjj/),count=(/jj_count/)),& + & __LINE__,__MYFILE__) + ENDDO + ENDIF + + CALL nchdlerr(nf90_inq_varid(ncid,'remap_matrix',varid), & + & __LINE__,__MYFILE__) + IF (nremapreadchunk<0) THEN + CALL nchdlerr(nf90_get_var(ncid,varid,remap%remap_matrix),& + & __LINE__,__MYFILE__) + ELSE + DO jjj=1,remap%num_links,nremapreadchunk + jj_count=MIN(nremapreadchunk,remap%num_links-jjj+1) + CALL nchdlerr(nf90_get_var(ncid,varid,remap%remap_matrix(:,jjj:jjj+jj_count-1),& + & start=(/1,jjj/),count=(/1,jj_count/)),& + & __LINE__,__MYFILE__) + ENDDO + ENDIF + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'title',remap%title),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'normalization',remap%normalization),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'map_method',remap%map_method),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'history',remap%history),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'conventions',remap%conventions),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'dest_grid',remap%dst%title),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_get_att(ncid,nf90_global,'source_grid',remap%src%title),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_close(ncid),__LINE__,__MYFILE__) + + END SUBROUTINE scripremap_read_work + + SUBROUTINE scripremap_read(cdfilename,remap) + + CHARACTER(len=*) :: cdfilename + TYPE(scripremaptype) :: remap + + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_read',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_read') + + CALL scripremap_read_work(cdfilename,remap) + + IF(ln_timing) CALL timing_stop('scripremap_read') + IF(lhook) CALL dr_hook('scripremap_read',1,zhook_handle) + + END SUBROUTINE scripremap_read + + + SUBROUTINE scripremap_read_sgl(cdfilename,remap,& + & mype,nproc,mycomm,linteronly) + + CHARACTER(len=*) :: cdfilename + TYPE(scripremaptype) :: remap + INTEGER :: mype,nproc,mycomm + LOGICAL :: linteronly + + INTEGER, DIMENSION(8) :: isizes + INTEGER :: ierr, ip + INTEGER :: ichunk, iii, jjj, jj_count + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_read_sgl',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_read_sgl') + + IF (mype==0) THEN + CALL scripremap_read_work(cdfilename,remap) +#if defined key_mpp_mpi + isizes(1)=remap%src%grid_size + isizes(2)=remap%dst%grid_size + isizes(3)=remap%src%grid_corners + isizes(4)=remap%dst%grid_corners + isizes(5)=remap%src%grid_rank + isizes(6)=remap%dst%grid_rank + isizes(7)=remap%num_links + isizes(8)=remap%num_wgts + CALL mpi_bcast( isizes, 8, mpi_integer, 0, mycomm, ierr) + ELSE + CALL mpi_bcast( isizes, 8, mpi_integer, 0, mycomm, ierr) + CALL scripremap_init(remap) + remap%src%grid_size=isizes(1) + remap%dst%grid_size=isizes(2) + remap%src%grid_corners=isizes(3) + remap%dst%grid_corners=isizes(4) + remap%src%grid_rank=isizes(5) + remap%dst%grid_rank=isizes(6) + remap%num_links=isizes(7) + remap%num_wgts=isizes(8) + CALL scripremap_alloc(remap) +#endif + ENDIF + +#if defined key_mpp_mpi + + IF (.NOT.linteronly) THEN + + CALL mpi_bcast( remap%src%grid_dims, remap%src%grid_rank, & + & mpi_integer, 0, mycomm, ierr ) + +#if defined REMAP_FULL + + CALL mpi_bcast( remap%src%grid_center_lat, remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_center_lon, remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_corner_lat, remap%src%grid_corners*remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_corner_lon, remap%src%grid_corners*remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + +#endif + + CALL mpi_bcast( remap%dst%grid_dims, remap%dst%grid_rank, & + & mpi_integer, 0, mycomm, ierr ) + +#if defined REMAP_FULL + + CALL mpi_bcast( remap%dst%grid_center_lat, remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_center_lon, remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_corner_lat, remap%dst%grid_corners*remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_corner_lon, remap%dst%grid_corners*remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + + CALL mpi_bcast( remap%src_grid_area, remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_grid_area, remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src_grid_frac, remap%src%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_grid_frac, remap%dst%grid_size, & + & mpi_double_precision, 0, mycomm, ierr ) + + CALL mpi_bcast( remap%src%grid_center_lat_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_center_lat_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_center_lon_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_center_lon_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_corner_lat_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_corner_lon_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_corner_lat_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_corner_lon_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src%grid_imask_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_imask_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src_grid_area_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_grid_area_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%src_grid_frac_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_grid_frac_units, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%title, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%normalization, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%map_method, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%history, scriplen, & + & mpi_character, 0, mycomm, ierr ) + CALL mpi_bcast( remap%conventions, scriplen, & + & mpi_character, 0, mycomm, ierr ) + +#endif + + ENDIF + + IF ( nremapbcstchunk > 0 ) THEN + + ! replace very large bcasts with multiple bcasts of 4MB size + + ichunk = nremapbcstchunk + + DO jjj=1,remap%num_links,ichunk + jj_count=MIN(ichunk,remap%num_links-jjj+1) + CALL mpi_bcast( remap%src_address(jjj), jj_count, & + & mpi_integer, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_address(jjj), jj_count, & + & mpi_integer, 0, mycomm, ierr ) + ENDDO + + DO iii=1,remap%num_wgts + DO jjj=1,remap%num_links,ichunk + jj_count=MIN(ichunk,remap%num_links-jjj+1) + CALL mpi_bcast( remap%remap_matrix(jjj,iii), jj_count, & + & mpi_double_precision, 0, mycomm, ierr ) + END DO + END DO + + ELSE + + CALL mpi_bcast( remap%src_address, remap%num_links, & + & mpi_integer, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst_address, remap%num_links, & + & mpi_integer, 0, mycomm, ierr ) + + CALL mpi_bcast( remap%remap_matrix, remap%num_wgts*remap%num_links, & + & mpi_double_precision, 0, mycomm, ierr ) + + ENDIF + + CALL mpi_bcast( remap%src%grid_imask, remap%src%grid_size, & + & mpi_integer, 0, mycomm, ierr ) + CALL mpi_bcast( remap%dst%grid_imask, remap%dst%grid_size, & + & mpi_integer, 0, mycomm, ierr ) + +#endif + + IF(ln_timing) CALL timing_stop('scripremap_read_sgl') + IF(lhook) CALL dr_hook('scripremap_read_sgl',1,zhook_handle) + + END SUBROUTINE scripremap_read_sgl + + SUBROUTINE scripremap_write(cdfilename,remap) + + CHARACTER(len=*) :: cdfilename + TYPE(scripremaptype) :: remap + + INTEGER :: ncid + INTEGER :: dimsgs,dimdgs,dimsgc,dimdgc,dimsgr,dimdgr,dimnl,dimnw + INTEGER :: dims1(1),dims2(2) + INTEGER :: idsgd,iddgd,idsgea,iddgea,idsgeo,iddgeo + INTEGER :: idsgoa,idsgoo,iddgoa,iddgoo,idsgim,iddgim,idsgar,iddgar + INTEGER :: idsgf,iddgf,idsga,iddga,idsa,idda,idrm + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_write',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_write') + + CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid), & + & __LINE__, __MYFILE__ ) + + CALL nchdlerr(nf90_def_dim(ncid,'src_grid_size',& + & remap%src%grid_size,dimsgs),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'dst_grid_size',& + & remap%dst%grid_size,dimdgs),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'src_grid_corners',& + & remap%src%grid_corners,dimsgc),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'dst_grid_corners',& + & remap%dst%grid_corners,dimdgc),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'src_grid_rank',& + & remap%src%grid_rank,dimsgr),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'dst_grid_rank',& + & remap%dst%grid_rank,dimdgr),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'num_links',& + & remap%num_links,dimnl),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_def_dim(ncid,'num_wgts',& + & remap%num_wgts,dimnw),& + & __LINE__,__MYFILE__) + + dims1(1)=dimsgr + CALL nchdlerr(nf90_def_var(ncid,'src_grid_dims',& + & nf90_int,dims1,idsgd),& + & __LINE__,__MYFILE__) + + dims1(1)=dimdgr + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_dims',& + & nf90_int,dims1,iddgd), & + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + dims1(1)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_center_lat',& + & nf90_double,dims1,idsgea), & + & __LINE__,__MYFILE__) + + dims1(1)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_center_lat',& + & nf90_double,dims1,iddgea), & + & __LINE__,__MYFILE__) + + dims1(1)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_center_lon',& + & nf90_double,dims1,idsgeo), & + & __LINE__,__MYFILE__) + + dims1(1)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_center_lon',& + & nf90_double,dims1,iddgeo), & + & __LINE__,__MYFILE__) + + dims2(1)=dimsgc + dims2(2)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_corner_lat',& + & nf90_double,dims2,idsgoa), & + & __LINE__,__MYFILE__) + + dims2(1)=dimsgc + dims2(2)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_corner_lon',& + & nf90_double,dims2,idsgoo), & + & __LINE__,__MYFILE__) + + dims2(1)=dimdgc + dims2(2)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_corner_lat',& + & nf90_double,dims2,iddgoa), & + & __LINE__,__MYFILE__) + + dims2(1)=dimdgc + dims2(2)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_corner_lon',& + & nf90_double,dims2,iddgoo), & + & __LINE__,__MYFILE__) + +#endif + + dims1(1)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_imask',& + & nf90_int,dims1,idsgim), & + & __LINE__,__MYFILE__) + + dims1(1)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_imask',& + & nf90_int,dims1,iddgim), & + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + dims1(1)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_area',& + & nf90_double,dims1,idsga), & + & __LINE__,__MYFILE__) + + dims1(1)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_area',& + & nf90_double,dims1,iddga), & + & __LINE__,__MYFILE__) + + dims1(1)=dimsgs + CALL nchdlerr(nf90_def_var(ncid,'src_grid_frac',& + & nf90_double,dims1,idsgf), & + & __LINE__,__MYFILE__) + + dims1(1)=dimdgs + CALL nchdlerr(nf90_def_var(ncid,'dst_grid_frac',& + & nf90_double,dims1,iddgf), & + & __LINE__,__MYFILE__) + +#endif + + dims1(1)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'src_address',& + & nf90_int,dims1,idsa), & + & __LINE__,__MYFILE__) + + dims1(1)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'dst_address',& + & nf90_int,dims1,idda), & + & __LINE__,__MYFILE__) + + dims2(1)=dimnw + dims2(2)=dimnl + CALL nchdlerr(nf90_def_var(ncid,'remap_matrix',& + & nf90_double,dims2,idrm), & + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_put_att(ncid,idsgea,'units',& + & remap%src%grid_center_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgea,'units',& + & remap%dst%grid_center_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsgeo,'units',& + & remap%src%grid_center_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgeo,'units',& + & remap%dst%grid_center_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsgoa,'units',& + & remap%src%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsgoo,'units',& + & remap%src%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgoa,'units',& + & remap%dst%grid_corner_lat_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgoo,'units',& + & remap%dst%grid_corner_lon_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsgim,'units',& + & remap%src%grid_imask_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgim,'units',& + & remap%dst%grid_imask_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsga,'units',& + & remap%src_grid_area_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddga,'units',& + & remap%dst_grid_area_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,idsgf,'units',& + & remap%src_grid_frac_units),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,iddgf,'units',& + & remap%dst_grid_frac_units),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'title',& + & remap%title),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'normalization',& + & remap%normalization),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'map_method',& + & remap%map_method),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'history',& + & remap%history),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'conventions',& + & remap%conventions),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'dest_grid',& + & remap%dst%title),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_att(ncid,nf90_global,'source_grid',& + & remap%src%title),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_enddef(ncid),__LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idsgd,remap%src%grid_dims),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,iddgd,remap%dst%grid_dims),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_put_var(ncid,idsgea,remap%src%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,iddgea,remap%dst%grid_center_lat),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idsgeo,remap%src%grid_center_lon),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,iddgeo,remap%dst%grid_center_lon),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_put_var(ncid,idsgoa,remap%src%grid_corner_lat),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,idsgoo,remap%src%grid_corner_lon),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,iddgoa,remap%dst%grid_corner_lat),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,iddgoo,remap%dst%grid_corner_lon),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_put_var(ncid,idsgim,remap%src%grid_imask),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,iddgim,remap%dst%grid_imask),& + & __LINE__,__MYFILE__) + +#if defined REMAP_FULL + + CALL nchdlerr(nf90_put_var(ncid,idsga,remap%src_grid_area),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,iddga,remap%dst_grid_area),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,idsgf,remap%src_grid_frac),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,iddgf,remap%dst_grid_frac),& + & __LINE__,__MYFILE__) + +#endif + + CALL nchdlerr(nf90_put_var(ncid,idsa,remap%src_address),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,idda,remap%dst_address),& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_put_var(ncid,idrm,remap%remap_matrix),& + & __LINE__,__MYFILE__) + + CALL nchdlerr(nf90_close(ncid),__LINE__, __MYFILE__ ) + + IF(ln_timing) CALL timing_stop('scripremap_write') + IF(lhook) CALL dr_hook('scripremap_write',1,zhook_handle) + + END SUBROUTINE scripremap_write + + SUBROUTINE scripremap_init(remap) + + TYPE(scripremaptype) :: remap + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_init',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_init') + + CALL scripgrid_init(remap%src) + CALL scripgrid_init(remap%dst) + remap%num_links = 0 + remap%num_wgts = 0 +#if defined REMAP_FULL + remap%title='' + remap%normalization='' + remap%map_method='' + remap%history='' + remap%conventions='' + remap%src_grid_area_units='' + remap%dst_grid_area_units='' + remap%src_grid_frac_units='' + remap%dst_grid_frac_units='' +#endif + + IF(ln_timing) CALL timing_stop('scripremap_init') + IF(lhook) CALL dr_hook('scripremap_init',1,zhook_handle) + + END SUBROUTINE scripremap_init + + SUBROUTINE scripremap_alloc(remap) + + TYPE(scripremaptype) :: remap + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_alloc',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_alloc') + + IF ( (remap%num_links == 0) .OR. & + & (remap%num_wgts == 0) ) THEN + WRITE(*,*)'scripremaptype not initialized' + CALL abort + ENDIF + + CALL scripgrid_alloc(remap%src) + CALL scripgrid_alloc(remap%dst) + + ALLOCATE( & +#if defined REMAP_FULL + & remap%src_grid_area(remap%src%grid_size), & + & remap%dst_grid_area(remap%dst%grid_size), & + & remap%src_grid_frac(remap%src%grid_size), & + & remap%dst_grid_frac(remap%dst%grid_size), & +#endif + & remap%src_address(remap%num_links), & + & remap%dst_address(remap%num_links), & + & remap%remap_matrix(remap%num_wgts, remap%num_links) & + & ) + + IF(ln_timing) CALL timing_stop('scripremap_alloc') + IF(lhook) CALL dr_hook('scripremap_alloc',1,zhook_handle) + + END SUBROUTINE scripremap_alloc + + SUBROUTINE scripremap_dealloc(remap) + + TYPE(scripremaptype) :: remap + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('scripremap_dealloc',0,zhook_handle) + IF(ln_timing) CALL timing_start('scripremap_dealloc') + + DEALLOCATE( & +#if defined REMAP_FULL + & remap%src_grid_area, & + & remap%dst_grid_area, & + & remap%src_grid_frac, & + & remap%dst_grid_frac, & +#endif + & remap%src_address, & + & remap%dst_address, & + & remap%remap_matrix & + & ) + + CALL scripgrid_dealloc(remap%src) + CALL scripgrid_dealloc(remap%dst) + + CALL scripremap_init(remap) + + IF(ln_timing) CALL timing_stop('scripremap_dealloc') + IF(lhook) CALL dr_hook('scripremap_dealloc',1,zhook_handle) + + END SUBROUTINE scripremap_dealloc + +END MODULE scripremap \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/flo4rk.F90 b/V4.0/nemo_sources/src/OCE/FLO/flo4rk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3b287171db789cd1460638178a7df17ac5313a73 --- /dev/null +++ b/V4.0/nemo_sources/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: flo4rk.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/flo_oce.F90 b/V4.0/nemo_sources/src/OCE/FLO/flo_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6b58fa20a6e05e2bb70ffa6a9945719e8ed324ff --- /dev/null +++ b/V4.0/nemo_sources/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: flo_oce.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION flo_oce_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( wb(jpi,jpj,jpk) , nfloat(jpnfl) , nisobfl(jpnfl) , ngrpfl(jpnfl) , & + & flxx(jpnfl) , flyy(jpnfl) , flzz(jpnfl) , & + & tpifl(jpnfl) , tpjfl(jpnfl) , tpkfl(jpnfl) , STAT=flo_oce_alloc ) + ! + CALL mpp_sum ( 'flo_oce', flo_oce_alloc ) + IF( flo_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_oce_alloc: failed to allocate arrays' ) + END FUNCTION flo_oce_alloc + + !!====================================================================== +END MODULE flo_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/floats.F90 b/V4.0/nemo_sources/src/OCE/FLO/floats.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6e628170a5ba749fe3b3c77d7b673bfa754807ef --- /dev/null +++ b/V4.0/nemo_sources/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: floats.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/floblk.F90 b/V4.0/nemo_sources/src/OCE/FLO/floblk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..458d199cb675ede8fcc9fc48d48e45964fe450df --- /dev/null +++ b/V4.0/nemo_sources/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: floblk.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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) = HUGE(0.0_wp) + ELSE + IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN + ztxfl(jfl)= zgidfl(jfl)/zudfl(jfl) * LOG(zuoutfl/zufl (jfl)) + ELSE + ztxfl(jfl)=(float(iioutfl(jfl))-zgifl(jfl))/zufl(jfl) + ENDIF + IF( (ABS(zgifl(jfl)-float(iiinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgifl(jfl)-float(iioutfl(jfl))) <= 1.E-7) ) THEN + ztxfl(jfl)=(zgidfl(jfl))/zufl(jfl) + ENDIF + ENDIF + ! v-direction + zvdfl (jfl) = zvoutfl - zvinfl + zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) + IF( zvfl(jfl)*zvoutfl <= 0. ) THEN + ztyfl(jfl) = HUGE(0.0_wp) + ELSE + IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN + ztyfl(jfl) = zgjdfl(jfl)/zvdfl(jfl) * LOG(zvoutfl/zvfl (jfl)) + ELSE + ztyfl(jfl) = (float(ijoutfl(jfl)) - zgjfl(jfl))/zvfl(jfl) + ENDIF + IF( (ABS(zgjfl(jfl)-float(ijinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgjfl(jfl)-float(ijoutfl(jfl))) <= 1.E-7) ) THEN + ztyfl(jfl) = (zgjdfl(jfl)) / zvfl(jfl) + ENDIF + ENDIF + ! w-direction + IF( nisobfl(jfl) == 1. ) THEN + zwdfl (jfl) = zwoutfl - zwinfl + zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) + IF( zwfl(jfl)*zwoutfl <= 0. ) THEN + ztzfl(jfl) = HUGE(0.0_wp) + ELSE + IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN + ztzfl(jfl) = zgkdfl(jfl)/zwdfl(jfl) * LOG(zwoutfl/zwfl (jfl)) + ELSE + ztzfl(jfl) = (float(ikoutfl(jfl)) - zgkfl(jfl))/zwfl(jfl) + ENDIF + IF( (ABS(zgkfl(jfl)-float(ikinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgkfl(jfl)-float(ikoutfl(jfl))) <= 1.E-7) ) THEN + ztzfl(jfl) = (zgkdfl(jfl)) / zwfl(jfl) + ENDIF + ENDIF + ENDIF + + ! the time to go leave the mesh is the smallest time + + IF( nisobfl(jfl) == 1. ) THEN + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl)) + ELSE + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl)) + ENDIF + ! new age of the FLOAT + zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol + ! test to know if the "age" of the float is not bigger than the + ! time step + IF( zagenewfl(jfl) > 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/flodom.F90 b/V4.0/nemo_sources/src/OCE/FLO/flodom.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1c60f2aac1e195c76914d1c776bccaeb4065baa5 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/FLO/flodom.F90 @@ -0,0 +1,456 @@ +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: flodom.F90 11818 2019-10-29 09:23:50Z jchanut $ + !! 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 + + FUNCTION fsline(psax, psay, psbx, psby, psx, psy) + REAL(wp) :: fsline + REAL(wp), INTENT(IN) :: psax, psay, psbx, psby, psx, psy + fsline = psy * ( psbx - psax ) & + & - psx * ( psby - psay ) & + & + psax * psby - psay * psbx + END FUNCTION fsline + + 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 + !!--------------------------------------------------------------------- + + ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/florst.F90 b/V4.0/nemo_sources/src/OCE/FLO/florst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d67b283541d88f9c23e4c9523ab1bcb622051e0a --- /dev/null +++ b/V4.0/nemo_sources/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: florst.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_rst_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_rst_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( iperproc(jpnij), STAT=flo_rst_alloc ) + ! + CALL mpp_sum ( 'florst', flo_rst_alloc ) + IF( flo_rst_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst_alloc: failed to allocate arrays.' ) + END FUNCTION flo_rst_alloc + + + SUBROUTINE flo_rst( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_rst *** + !! + !! ** Purpose : + !! + !! + !! ** Method : The frequency of ??? is nwritefl + !! + !!---------------------------------------------------------------------- + INTEGER :: kt ! time step + ! + CHARACTER (len=80) :: clname ! restart filename + INTEGER :: ic , jc , jpn ,jfl ! temporary integer + INTEGER :: inum ! temporary logical unit for restart file + !!---------------------------------------------------------------------- + + IF( ( MOD(kt,nn_stockfl) == 0 ) .OR. ( kt == nitend ) )THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'flo_rst : write in restart_float file ' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! file is opened and closed every time it is used. + + clname = 'restart.float.' + ic = 1 + DO jc = 1, 16 + IF( cexper(jc:jc) /= ' ' ) ic = jc + END DO + clname = clname(1:14)//cexper(1:ic) + ic = 1 + DO jc = 1, 48 + IF( clname(jc:jc) /= ' ' ) ic = jc + END DO + + inum=0 + IF( lwp )THEN + CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND inum + ENDIF + ! + DO jpn = 1, jpnij + iperproc(jpn) = 0 + END DO + ! + IF(lwp) THEN + REWIND(inum) + WRITE (inum,*) tpifl,tpjfl,tpkfl,nisobfl,ngrpfl + CLOSE (inum) + ENDIF + ! + ! Compute the number of trajectories for each processor + ! + IF( lk_mpp ) THEN + DO jfl = 1, jpnfl + IF( (INT(tpifl(jfl)) >= mig(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/FLO/flowri.F90 b/V4.0/nemo_sources/src/OCE/FLO/flowri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8fa38b0013ed39951e7ef50867166ab1caf02b47 --- /dev/null +++ b/V4.0/nemo_sources/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: flowri.F90 11818 2019-10-29 09:23:50Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_wri_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_wri_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( ztem(jpnfl) , zsal(jpnfl) , zrho(jpnfl) , & + zlon(jpnfl) , zlat(jpnfl) , zdep(jpnfl) , STAT=flo_wri_alloc) + ! + CALL mpp_sum ( 'flowri', flo_wri_alloc ) + IF( flo_wri_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri_alloc: failed to allocate arrays.' ) + END FUNCTION flo_wri_alloc + + SUBROUTINE flo_wri( kt ) + !!--------------------------------------------------------------------- + !! *** 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icb_oce.F90 b/V4.0/nemo_sources/src/OCE/ICB/icb_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e7dd0b7afb2127ccb64eddea3f4ab699643276ba --- /dev/null +++ b/V4.0/nemo_sources/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: icb_oce.F90 13263 2020-07-08 07:55:54Z ayoung $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbclv.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbclv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0f0f9739c094d5e48854442dde24e9569f965b03 --- /dev/null +++ b/V4.0/nemo_sources/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: icbclv.F90 10714 2019-02-22 15:13:22Z mathiot $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbdia.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbdia.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b12b3ffeeca412625d4e1e18980e082b4607ba85 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ICB/icbdia.F90 @@ -0,0 +1,621 @@ +MODULE icbdia + !!====================================================================== + !! *** MODULE icbdia *** + !! Icebergs: initialise variables for iceberg budgets and diagnostics + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin, Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Budgets are now all here with lots + !! - ! of silly routines to call to get values in + !! - ! from the right points in the code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_dia_init : initialise iceberg budgeting + !! icb_dia : global iceberg diagnostics + !! icb_dia_step : reset at the beginning of each timestep + !! icb_dia_put : output (via iom_put) iceberg fields + !! icb_dia_calve : + !! icb_dia_income: + !! icb_dia_size : + !! icb_dia_speed : + !! icb_dia_melt : + !! report_state : + !! report_consistant : + !! report_budget : + !! report_istate : + !! report_ibudget: + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean domain + USE in_out_manager ! nemo IO + USE lib_mpp ! MPP library + USE iom ! I/O library + USE icb_oce ! iceberg variables + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dia_init ! routine called in icbini.F90 module + PUBLIC icb_dia ! routine called in icbstp.F90 module + PUBLIC icb_dia_step ! routine called in icbstp.F90 module + PUBLIC icb_dia_put ! routine called in icbstp.F90 module + PUBLIC icb_dia_melt ! routine called in icbthm.F90 module + PUBLIC icb_dia_size ! routine called in icbthm.F90 module + PUBLIC icb_dia_speed ! routine called in icbdyn.F90 module + PUBLIC icb_dia_calve ! routine called in icbclv.F90 module + PUBLIC icb_dia_income ! routine called in icbclv.F90 module + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt ! Melting+erosion rate of icebergs [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_hcflx ! Heat flux to ocean due to heat content of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_qlat ! Heat flux to ocean due to latent heat of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: buoy_melt ! Buoyancy component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: eros_melt ! Erosion component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: conv_melt ! Convective component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_src ! Mass flux from berg erosion into bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_melt ! Melting rate of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_mass ! Mass distribution of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: virtual_area ! Virtual surface coverage by icebergs [m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_mass ! Mass distribution [kg/m2] + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PUBLIC :: real_calving ! Calving rate into iceberg class at + ! ! calving locations [kg/s] + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmpc ! Temporary work space + REAL(wp), DIMENSION(:) , ALLOCATABLE :: rsumbuf ! Temporary work space to reduce mpp exchanges + INTEGER , DIMENSION(:) , ALLOCATABLE :: nsumbuf ! Temporary work space to reduce mpp exchanges + + REAL(wp) :: berg_melt_net + REAL(wp) :: bits_src_net + REAL(wp) :: bits_melt_net + REAL(wp) :: bits_mass_start , bits_mass_end + REAL(wp) :: floating_heat_start , floating_heat_end + REAL(wp) :: floating_mass_start , floating_mass_end + REAL(wp) :: bergs_mass_start , bergs_mass_end + REAL(wp) :: stored_start , stored_heat_start + REAL(wp) :: stored_end , stored_heat_end + REAL(wp) :: calving_src_net , calving_out_net + REAL(wp) :: calving_src_heat_net, calving_out_heat_net + REAL(wp) :: calving_src_heat_used_net + REAL(wp) :: calving_rcv_net , calving_ret_net , calving_used_net + REAL(wp) :: heat_to_bergs_net, heat_to_ocean_net, melt_net + REAL(wp) :: calving_to_bergs_net + + INTEGER :: nbergs_start, nbergs_end, nbergs_calved + INTEGER :: nbergs_melted + INTEGER :: nspeeding_tickets, nspeeding_tickets_all + INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdia.F90 14372 2021-02-02 17:42:36Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dia_init( ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + ALLOCATE( berg_melt (jpi,jpj) ) ; berg_melt (:,:) = 0._wp + ALLOCATE( berg_melt_hcflx(jpi,jpj) ) ; berg_melt_hcflx(:,:) = 0._wp + ALLOCATE( berg_melt_qlat(jpi,jpj) ) ; berg_melt_qlat(:,:) = 0._wp + ALLOCATE( buoy_melt (jpi,jpj) ) ; buoy_melt (:,:) = 0._wp + ALLOCATE( eros_melt (jpi,jpj) ) ; eros_melt (:,:) = 0._wp + ALLOCATE( conv_melt (jpi,jpj) ) ; conv_melt (:,:) = 0._wp + ALLOCATE( bits_src (jpi,jpj) ) ; bits_src (:,:) = 0._wp + ALLOCATE( bits_melt (jpi,jpj) ) ; bits_melt (:,:) = 0._wp + ALLOCATE( bits_mass (jpi,jpj) ) ; bits_mass (:,:) = 0._wp + ALLOCATE( virtual_area (jpi,jpj) ) ; virtual_area(:,:) = 0._wp + ALLOCATE( berg_mass (jpi,jpj) ) ; berg_mass (:,:) = 0._wp + ALLOCATE( real_calving (jpi,jpj,nclasses) ) ; real_calving(:,:,:) = 0._wp + ALLOCATE( tmpc(jpi,jpj) ) ; tmpc (:,:) = 0._wp + + nbergs_start = 0 + nbergs_end = 0 + stored_end = 0._wp + nbergs_start = 0._wp + stored_start = 0._wp + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_end = 0._wp + floating_heat_end = 0._wp + floating_mass_end = 0._wp + bergs_mass_end = 0._wp + bits_mass_end = 0._wp + stored_heat_start = 0._wp + floating_heat_start = 0._wp + floating_mass_start = 0._wp + bergs_mass_start = 0._wp + bits_mass_start = 0._wp + bits_mass_end = 0._wp + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + + floating_mass_start = icb_utl_mass( first_berg ) + bergs_mass_start = icb_utl_mass( first_berg, justbergs=.TRUE. ) + bits_mass_start = icb_utl_mass( first_berg, justbits =.TRUE. ) + IF( lk_mpp ) THEN + ALLOCATE( rsumbuf(23) ) ; rsumbuf(:) = 0._wp + ALLOCATE( nsumbuf(4+nclasses) ) ; nsumbuf(:) = 0 + rsumbuf(1) = floating_mass_start + rsumbuf(2) = bergs_mass_start + rsumbuf(3) = bits_mass_start + CALL mpp_sum( 'icbdia', rsumbuf(1:3), 3 ) + floating_mass_start = rsumbuf(1) + bergs_mass_start = rsumbuf(2) + bits_mass_start = rsumbuf(3) + ENDIF + ! + END SUBROUTINE icb_dia_init + + + SUBROUTINE icb_dia( ld_budge ) + !!---------------------------------------------------------------------- + !! sum all the things we've accumulated so far in the current processor + !! in MPP case then add these sums across all processors + !! for this we pack variables into buffer so we only need one mpp_sum + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in) :: ld_budge ! + ! + INTEGER :: ik + REAL(wp):: zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + zunused_calving = SUM( berg_grid%calving(:,:) ) + ztmpsum = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + melt_net = melt_net + ztmpsum * berg_dt + calving_out_net = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt + ztmpsum = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + berg_melt_net = berg_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_src_net = bits_src_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_melt_net = bits_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( src_calving(:,:) * tmask_i(:,:) ) + calving_ret_net = calving_ret_net + ztmpsum * berg_dt + ztmpsum = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt ! Units of J + ! + IF( ld_budge ) THEN + stored_end = SUM( berg_grid%stored_ice(:,:,:) ) + stored_heat_end = SUM( berg_grid%stored_heat(:,:) ) + floating_mass_end = icb_utl_mass( first_berg ) + bergs_mass_end = icb_utl_mass( first_berg,justbergs=.TRUE. ) + bits_mass_end = icb_utl_mass( first_berg,justbits =.TRUE. ) + floating_heat_end = icb_utl_heat( first_berg ) + ! + nbergs_end = icb_utl_count() + zgrdd_berg_mass = SUM( berg_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + zgrdd_bits_mass = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + ! + IF( lk_mpp ) THEN + rsumbuf( 1) = stored_end + rsumbuf( 2) = stored_heat_end + rsumbuf( 3) = floating_mass_end + rsumbuf( 4) = bergs_mass_end + rsumbuf( 5) = bits_mass_end + rsumbuf( 6) = floating_heat_end + rsumbuf( 7) = calving_ret_net + rsumbuf( 8) = calving_out_net + rsumbuf( 9) = calving_rcv_net + rsumbuf(10) = calving_src_net + rsumbuf(11) = calving_src_heat_net + rsumbuf(12) = calving_src_heat_used_net + rsumbuf(13) = calving_out_heat_net + rsumbuf(14) = calving_used_net + rsumbuf(15) = calving_to_bergs_net + rsumbuf(16) = heat_to_bergs_net + rsumbuf(17) = heat_to_ocean_net + rsumbuf(18) = melt_net + rsumbuf(19) = berg_melt_net + rsumbuf(20) = bits_src_net + rsumbuf(21) = bits_melt_net + rsumbuf(22) = zgrdd_berg_mass + rsumbuf(23) = zgrdd_bits_mass + ! + CALL mpp_sum( 'icbdia', rsumbuf(1:23), 23) + ! + stored_end = rsumbuf( 1) + stored_heat_end = rsumbuf( 2) + floating_mass_end = rsumbuf( 3) + bergs_mass_end = rsumbuf( 4) + bits_mass_end = rsumbuf( 5) + floating_heat_end = rsumbuf( 6) + calving_ret_net = rsumbuf( 7) + calving_out_net = rsumbuf( 8) + calving_rcv_net = rsumbuf( 9) + calving_src_net = rsumbuf(10) + calving_src_heat_net = rsumbuf(11) + calving_src_heat_used_net = rsumbuf(12) + calving_out_heat_net = rsumbuf(13) + calving_used_net = rsumbuf(14) + calving_to_bergs_net = rsumbuf(15) + heat_to_bergs_net = rsumbuf(16) + heat_to_ocean_net = rsumbuf(17) + melt_net = rsumbuf(18) + berg_melt_net = rsumbuf(19) + bits_src_net = rsumbuf(20) + bits_melt_net = rsumbuf(21) + zgrdd_berg_mass = rsumbuf(22) + zgrdd_bits_mass = rsumbuf(23) + ! + nsumbuf(1) = nbergs_end + nsumbuf(2) = nbergs_calved + nsumbuf(3) = nbergs_melted + nsumbuf(4) = nspeeding_tickets + DO ik = 1, nclasses + nsumbuf(4+ik) = nbergs_calved_by_class(ik) + END DO + CALL mpp_sum( 'icbdia', nsumbuf(1:nclasses+4), nclasses+4 ) + ! + nbergs_end = nsumbuf(1) + nbergs_calved = nsumbuf(2) + nbergs_melted = nsumbuf(3) + nspeeding_tickets_all = nsumbuf(4) + DO ik = 1,nclasses + nbergs_calved_by_class(ik)= nsumbuf(4+ik) + END DO + ! + ENDIF + ! + CALL report_state ( 'stored ice','kg','',stored_start,'',stored_end,'') + CALL report_state ( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end ) + CALL report_state ( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'') + CALL report_state ( 'bits','kg','',bits_mass_start,'',bits_mass_end,'') + CALL report_istate ( 'berg #','',nbergs_start,'',nbergs_end,'') + CALL report_ibudget( 'berg #','calved',nbergs_calved, & + & 'melted',nbergs_melted, & + & '#',nbergs_start,nbergs_end) + CALL report_budget( 'stored mass','kg','calving used',calving_used_net, & + & 'bergs',calving_to_bergs_net, & + & 'stored mass',stored_start,stored_end) + CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, & + & 'bergs',melt_net, & + & 'stored mass',floating_mass_start,floating_mass_end) + CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, & + & 'melt+eros',berg_melt_net, & + & 'berg mass',bergs_mass_start,bergs_mass_end) + CALL report_budget( 'bits mass','kg','eros used',bits_src_net, & + & 'bergs',bits_melt_net, & + & 'stored mass',bits_mass_start,bits_mass_end) + CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, & + & 'rtrnd',calving_ret_net, & + & 'net mass',stored_start+floating_mass_start, & + & stored_end+floating_mass_end) + CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end) + CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end) + CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', & + & stored_heat_end+floating_heat_end,'') + CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'') + CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'') + CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, & + & 'net heat',calving_out_heat_net, & + & 'net heat',stored_heat_start+floating_heat_start, & + & stored_heat_end+floating_heat_end) + CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, & + & 'bergs',heat_to_bergs_net, & + & 'net heat',stored_heat_start,stored_heat_end) + CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, & + & 'melt',heat_to_ocean_net, & + & 'net heat',floating_heat_start,floating_heat_end) + IF (nn_verbose_level >= 1) THEN + CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, & + & 'received',calving_rcv_net) + CALL report_consistant( 'bot interface','kg','sent',calving_out_net, & + & 'returned',calving_ret_net) + ENDIF + IF (nn_verbose_level > 0) THEN + WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) + IF( nspeeding_tickets_all > 0 ) THEN + WRITE( numicb, '("speeding tickets issued (this domain) = ",i6)') nspeeding_tickets + WRITE( numicb, '("speeding tickets issued (all domains) = ",i6)') nspeeding_tickets_all + END IF + ENDIF + ! + nbergs_start = nbergs_end + stored_start = stored_end + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_start = stored_heat_end + floating_heat_start = floating_heat_end + floating_mass_start = floating_mass_end + bergs_mass_start = bergs_mass_end + bits_mass_start = bits_mass_end + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + ENDIF + ! + END SUBROUTINE icb_dia + + + SUBROUTINE icb_dia_step + !!---------------------------------------------------------------------- + !! things to reset at the beginning of each timestep + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + berg_melt (:,:) = 0._wp + berg_melt_hcflx(:,:) = 0._wp + berg_melt_qlat(:,:) = 0._wp + buoy_melt (:,:) = 0._wp + eros_melt (:,:) = 0._wp + conv_melt (:,:) = 0._wp + bits_src (:,:) = 0._wp + bits_melt (:,:) = 0._wp + bits_mass (:,:) = 0._wp + berg_mass (:,:) = 0._wp + virtual_area(:,:) = 0._wp + real_calving(:,:,:) = 0._wp + ! + END SUBROUTINE icb_dia_step + + + SUBROUTINE icb_dia_put + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN !!gm useless iom will control whether it is output or not + ! + CALL iom_put( "berg_melt" , berg_melt (:,:) ) ! Melt rate of icebergs [kg/m2/s] + !! NB. The berg_melt_hcflx field is currently always zero - see comment in icbthm.F90 + CALL iom_put( "berg_melt_hcflx" , berg_melt_hcflx(:,:)) ! Heat flux to ocean due to heat content of melting icebergs [J/m2/s] + CALL iom_put( "berg_melt_qlat" , berg_melt_qlat(:,:) ) ! Heat flux to ocean due to latent heat of melting icebergs [J/m2/s] + CALL iom_put( "berg_buoy_melt" , buoy_melt (:,:) ) ! Buoyancy component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_eros_melt" , eros_melt (:,:) ) ! Erosion component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_conv_melt" , conv_melt (:,:) ) ! Convective component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_virtual_area", virtual_area(:,:) ) ! Virtual coverage by icebergs [m2] + CALL iom_put( "bits_src" , bits_src (:,:) ) ! Mass source of bergy bits [kg/m2/s] + CALL iom_put( "bits_melt" , bits_melt (:,:) ) ! Melt rate of bergy bits [kg/m2/s] + CALL iom_put( "bits_mass" , bits_mass (:,:) ) ! Bergy bit density field [kg/m2] + CALL iom_put( "berg_mass" , berg_mass (:,:) ) ! Iceberg density field [kg/m2] + CALL iom_put( "berg_real_calving", real_calving(:,:,:) ) ! Calving into iceberg class [kg/s] + ! + END SUBROUTINE icb_dia_put + + + SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj, kn + REAL(wp), INTENT(in) :: pcalved + REAL(wp), INTENT(in) :: pheated + !!---------------------------------------------------------------------- + ! + IF( .NOT. ln_bergdia ) RETURN + real_calving(ki,kj,kn) = real_calving(ki,kj,kn) + pcalved / berg_dt + nbergs_calved = nbergs_calved + 1 + nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1 + calving_to_bergs_net = calving_to_bergs_net + pcalved + heat_to_bergs_net = heat_to_bergs_net + pheated + ! + END SUBROUTINE icb_dia_calve + + + SUBROUTINE icb_dia_income( kt, pcalving_used, pheat_used ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + REAL(wp), INTENT(in) :: pcalving_used + REAL(wp), DIMENSION(:,:), INTENT(in) :: pheat_used + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + ! + IF( kt == nit000 ) THEN + stored_start = SUM( berg_grid%stored_ice(:,:,:) ) + CALL mpp_sum( 'icbdia', stored_start ) + ! + stored_heat_start = SUM( berg_grid%stored_heat(:,:) ) + CALL mpp_sum( 'icbdia', stored_heat_start ) + IF (nn_verbose_level > 0) THEN + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored mass=',stored_start,' kg' + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored heat=',stored_heat_start,' J' + ENDIF + ENDIF + ! + calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt + calving_src_net = calving_rcv_net + calving_src_heat_net = calving_src_heat_net + & + & SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt ! Units of J + calving_used_net = calving_used_net + pcalving_used * berg_dt + calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) ) + ! + END SUBROUTINE icb_dia_income + + + SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits, & + & pmass_scale, pMnew, pnMbits, pz1_e1e2) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj + REAL(wp), INTENT(in) :: pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2 + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale ! m^2 + berg_mass(ki,kj) = berg_mass(ki,kj) + pMnew * pz1_e1e2 ! kg/m2 + bits_mass(ki,kj) = bits_mass(ki,kj) + pnMbits * pz1_e1e2 ! kg/m2 + ! + END SUBROUTINE icb_dia_size + + + SUBROUTINE icb_dia_speed() + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + nspeeding_tickets = nspeeding_tickets + 1 + ! + END SUBROUTINE icb_dia_speed + + + SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat_hcflux, pheat_latent, pmass_scale, & + & pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, & + & pdMv, pz1_dt_e1e2 ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbdyn.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbdyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fcbcf2693593541c3c600d5ee92b1426ad81cad3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ICB/icbdyn.F90 @@ -0,0 +1,397 @@ +MODULE icbdyn + !!====================================================================== + !! *** MODULE icbdyn *** + !! Iceberg: time stepping routine for iceberg tracking + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Replace broken grounding routine with one of + !! - ! Gurvan's suggestions (just like the broken one) + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE in_out_manager ! IO parameters + ! + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dyn ! routine called in icbstp.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdyn.F90 14372 2021-02-02 17:42:36Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dyn( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_dyn *** + !! + !! ** Purpose : iceberg evolution. + !! + !! ** Method : - See Martin & Adcroft, Ocean Modelling 34, 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! + ! + LOGICAL :: ll_bounced + REAL(wp) :: zuvel1 , zvvel1 , zu1, zv1, zax1, zay1, zxi1 , zyj1 + REAL(wp) :: zuvel2 , zvvel2 , zu2, zv2, zax2, zay2, zxi2 , zyj2 + REAL(wp) :: zuvel3 , zvvel3 , zu3, zv3, zax3, zay3, zxi3 , zyj3 + REAL(wp) :: zuvel4 , zvvel4 , zu4, zv4, zax4, zay4, zxi4 , zyj4 + REAL(wp) :: zuvel_n, zvvel_n, zxi_n , zyj_n + REAL(wp) :: zdt, zdt_2, zdt_6, ze1, ze2 + TYPE(iceberg), POINTER :: berg + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + ! + ! 4th order Runge-Kutta to solve: d/dt X = V, d/dt V = A + ! with I.C.'s: X=X1 and V=V1 + ! + ! ; A1=A(X1,V1) + ! X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 ; A2=A(X2,V2) + ! X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2 ; A3=A(X3,V3) + ! X4 = X1+ dt*V3 ; V4 = V1+ dt*A3 ; A4=A(X4,V4) + ! + ! Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + + ! time steps + zdt = berg_dt + zdt_2 = zdt * 0.5_wp + zdt_6 = zdt / 6._wp + + berg => first_berg ! start from the first berg + ! + DO WHILE ( ASSOCIATED(berg) ) !== loop over all bergs ==! + ! + pt => berg%current_point + + ll_bounced = .FALSE. + + + ! STEP 1 ! + ! ====== ! + zxi1 = pt%xi ; zuvel1 = pt%uvel !** X1 in (i,j) ; V1 in m/s + zyj1 = pt%yj ; zvvel1 = pt%vvel + + + ! !** A1 = A(X1,V1) + CALL icb_accel( kt, berg , zxi1, ze1, zuvel1, zuvel1, zax1, & + & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2, 0.5_wp ) + ! + zu1 = zuvel1 / ze1 !** V1 in d(i,j)/dt + zv1 = zvvel1 / ze2 + + ! STEP 2 ! + ! ====== ! + ! !** X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 + ! position using di/dt & djdt ! V2 in m/s + zxi2 = zxi1 + zdt_2 * zu1 ; zuvel2 = zuvel1 + zdt_2 * zax1 + zyj2 = zyj1 + zdt_2 * zv1 ; zvvel2 = zvvel1 + zdt_2 * zay1 + ! + CALL icb_ground( zxi2, zxi1, zu1, & + & zyj2, zyj1, zv1, ll_bounced ) + + ! !** A2 = A(X2,V2) + CALL icb_accel( kt, berg , zxi2, ze1, zuvel2, zuvel1, zax2, & + & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2, 0.5_wp ) + ! + zu2 = zuvel2 / ze1 !** V2 in d(i,j)/dt + zv2 = zvvel2 / ze2 + ! + ! STEP 3 ! + ! ====== ! + ! !** X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2; A3=A(X3) + zxi3 = zxi1 + zdt_2 * zu2 ; zuvel3 = zuvel1 + zdt_2 * zax2 + zyj3 = zyj1 + zdt_2 * zv2 ; zvvel3 = zvvel1 + zdt_2 * zay2 + ! + CALL icb_ground( zxi3, zxi1, zu2, & + & zyj3, zyj1, zv2, ll_bounced ) + + ! !** A3 = A(X3,V3) + CALL icb_accel( kt, berg , zxi3, ze1, zuvel3, zuvel1, zax3, & + & zyj3, ze2, zvvel3, zvvel1, zay3, zdt, 1._wp ) + ! + zu3 = zuvel3 / ze1 !** V3 in d(i,j)/dt + zv3 = zvvel3 / ze2 + + ! STEP 4 ! + ! ====== ! + ! !** X4 = X1+dt*V3 ; V4 = V1+dt*A3 + zxi4 = zxi1 + zdt * zu3 ; zuvel4 = zuvel1 + zdt * zax3 + zyj4 = zyj1 + zdt * zv3 ; zvvel4 = zvvel1 + zdt * zay3 + + CALL icb_ground( zxi4, zxi1, zu3, & + & zyj4, zyj1, zv3, ll_bounced ) + + ! !** A4 = A(X4,V4) + CALL icb_accel( kt, berg , zxi4, ze1, zuvel4, zuvel1, zax4, & + & zyj4, ze2, zvvel4, zvvel1, zay4, zdt, 1._wp ) + + zu4 = zuvel4 / ze1 !** V4 in d(i,j)/dt + zv4 = zvvel4 / ze2 + + ! FINAL STEP ! + ! ========== ! + ! !** Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! !** Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + zxi_n = pt%xi + zdt_6 * ( zu1 + 2.*(zu2 + zu3 ) + zu4 ) + zyj_n = pt%yj + zdt_6 * ( zv1 + 2.*(zv2 + zv3 ) + zv4 ) + zuvel_n = pt%uvel + zdt_6 * ( zax1 + 2.*(zax2 + zax3) + zax4 ) + zvvel_n = pt%vvel + zdt_6 * ( zay1 + 2.*(zay2 + zay3) + zay4 ) + + CALL icb_ground( 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( kt, berg , pxi, pe1, puvel, puvel0, pax, & + & pyj, pe2, pvvel, pvvel0, pay, pdt, pcfl_scale ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_accel *** + !! + !! ** Purpose : compute the iceberg acceleration. + !! + !! ** Method : - sum the terms in the momentum budget + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp) , INTENT(in ) :: pcfl_scale + REAL(wp) , INTENT(in ) :: pxi , pyj ! berg position in (i,j) referential + REAL(wp) , INTENT(in ) :: puvel , pvvel ! berg velocity [m/s] + REAL(wp) , INTENT(in ) :: puvel0, pvvel0 ! initial berg velocity [m/s] + REAL(wp) , INTENT( out) :: pe1, pe2 ! horizontal scale factor at (xi,yj) + REAL(wp) , INTENT(inout) :: pax, pay ! berg acceleration + REAL(wp) , INTENT(in ) :: pdt ! berg time step + ! + REAL(wp), PARAMETER :: pp_alpha = 0._wp ! + REAL(wp), PARAMETER :: pp_beta = 1._wp ! + REAL(wp), PARAMETER :: pp_vel_lim =15._wp ! max allowed berg speed + REAL(wp), PARAMETER :: pp_accel_lim = 1.e-2_wp ! max allowed berg acceleration + REAL(wp), PARAMETER :: pp_Cr0 = 0.06_wp ! + ! + INTEGER :: itloop + 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 + ! cfl scale is function of the RK4 step + zspeed_new = zloc_dx / pdt * rn_speed_limit * pcfl_scale ! Speed limit as a factor of dx / dt + IF( zspeed_new < zspeed ) THEN + zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed + zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction + pax = (zuveln - puvel0)/pdt + pay = (zvveln - pvvel0)/pdt + ! + ! print speeding ticket + IF (nn_verbose_level > 0) THEN + WRITE(numicb, 9200) 'icb speeding : ',kt, nknberg, zspeed, & + & pxi, pyj, zuo, zvo, zua, zva, zui, zvi + 9200 FORMAT(a,i9,i6,f9.2,1x,4(1x,2f9.2)) + END IF + ! + CALL icb_dia_speed() + ENDIF + ENDIF + ENDIF + ! ! check the speed and acceleration limits + IF (nn_verbose_level > 0) THEN + IF( ABS( zuveln ) > pp_vel_lim .OR. ABS( zvveln ) > pp_vel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive velocity' + IF( ABS( pax ) > pp_accel_lim .OR. ABS( pay ) > pp_accel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive acceleration' + ENDIF + ! + END SUBROUTINE icb_accel + + !!====================================================================== +END MODULE icbdyn \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbini.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..056f07e68a85ee13d8bfc6340980fe29fd755d1a --- /dev/null +++ b/V4.0/nemo_sources/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: icbini.F90 13350 2020-07-28 12:28:29Z smueller $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icblbc.F90 b/V4.0/nemo_sources/src/OCE/ICB/icblbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b72bd6f430e8ca3bd6d6db1461bdac648679638b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ICB/icblbc.F90 @@ -0,0 +1,918 @@ +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: icblbc.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_lbc() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc *** + !! + !! ** Purpose : in non-mpp case need to deal with cyclic conditions + !! including north-fold + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + !! periodic east/west boundaries + !! ============================= + + IF( l_Iperio ) THEN + + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN + pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp + ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN + pt%xi = ricb_left + MOD(pt%xi, 1._wp ) + ENDIF + this => this%next + END DO + ! + ENDIF + + !! north/south boundaries + !! ====================== + IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') + ! north fold + IF( 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( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN + ! + iine = INT( pt%xi + 0.5 ) + ipts = nicbfldpts (mi1(iine)) + ! + ! moving across the cut line means both position and + ! velocity must change + ijglo = INT( ipts/nicbpack ) + iiglo = ipts - nicbpack*ijglo + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) + pt%uvel = -1._wp * pt%uvel + pt%vvel = -1._wp * pt%vvel + ENDIF + this => this%next + END DO + ! + END SUBROUTINE icb_lbc_nfld + +#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 :: 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 + IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN + tmpberg => this + this => this%next + ibergs_to_send_e = ibergs_to_send_e + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' + CALL flush( numicb ) + ENDIF + ! deal with periodic case + tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp + ! now pack it into buffer and delete from list + CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) 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 + IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN + tmpberg => this + this => this%next + ibergs_to_send_n = ibergs_to_send_n + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp ) 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 + IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp .OR. & + pt%xi > REAL(mig(nicbei),wp) + 0.5_wp .OR. & + pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp .OR. & + pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN + i = i + 1 + WRITE(numicb,*) 'berg lost in halo: ', this%number(:) + WRITE(numicb,*) ' ', nimpp, njmpp + WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej + CALL flush( numicb ) + ENDIF + this => this%next + ENDDO ! WHILE + CALL mpp_sum('icblbc', i) + IF( i .GT. 0 ) THEN + WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i + CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') + ENDIF ! root_pe + ENDIF ! debug + ! + CALL mppsync() + ! + END SUBROUTINE icb_lbc_mpp + + + SUBROUTINE icb_lbc_mpp_nfld() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_mpp_nfld *** + !! + !! ** Purpose : north fold treatment in multi processor exchange + !! + !! ** Method : + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: tmpberg, this + TYPE(point) , POINTER :: pt + INTEGER :: ibergs_to_send + INTEGER :: ibergs_to_rcv + INTEGER :: iiglo, ijglo, jk, jn + INTEGER :: ifldproc, iproc, ipts + INTEGER :: iine, ijne + INTEGER :: jjn + REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs + INTEGER :: iml_req1, iml_req2, iml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat + + ! set up indices of neighbouring processors + + ! nicbfldproc is a list of unique processor numbers that this processor + ! exchanges with (including itself), so we loop over this array; since + ! its of fixed size, the first -1 marks end of list of processors + ! + nicbfldnsend(:) = 0 + nicbfldexpect(:) = 0 + nicbfldreq(:) = 0 + ! + ! Since each processor may be communicating with more than one northern + ! neighbour, cycle through the sends so that the receive order can be + ! controlled. + ! + ! First compute how many icebergs each active neighbour should expect + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + nicbfldnsend(jn) = 0 + + ! Find number of bergs that need to be exchanged + ! Pick out exchanges with processor ifldproc + ! if ifldproc is this processor then don't send + ! + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + iproc = nicbflddest(mi1(iine)) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) 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( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbrst.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbrst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7fbaa1cf07dd6bf338c750a0fd7f33d83ee936dd --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ICB/icbrst.F90 @@ -0,0 +1,507 @@ +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, ymds2ju ! for calendar + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE phycst ! Physical constants + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_rst_read ! routine called in icbini.F90 module + PUBLIC icb_rst_write ! routine called in icbstp.F90 module + + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid + INTEGER :: nmassid, nthicknessid, nwidthid, nlengthid + INTEGER :: nyearid, ndayid + INTEGER :: nscaling_id, nmass_of_bits_id, nheat_density_id, numberid + INTEGER :: nsiceid, nsheatid, ncalvid, ncalvhid, nkountid + INTEGER :: nret, ncid, nc_dim + + INTEGER, DIMENSION(3) :: nstrt3, nlngth3 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbrst.F90 13061 2020-06-08 13:20:11Z smasson $ + !! 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 + REAL(dp) :: xi_dp, yj_dp ! Double-precision variables for checking + ! iceberg location roundoff groundings + !!---------------------------------------------------------------------- + + ! 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, ldsgl = .FALSE. ) + + 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' ,xi_dp , ktime=jn ) + CALL iom_get( ncid, 'yj' ,yj_dp , ktime=jn ) + + ii = INT( xi_dp + 0.5_dp ) + ij = INT( yj_dp + 0.5_dp ) + ! 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 + +# if defined key_single + ! Check for single-precision roundoff-induced iceberg groundings + CALL fix_roundoff_groundings(xi_dp, yj_dp, localpt%xi, localpt%yj) +# else + localpt%xi = xi_dp + localpt%yj = yj_dp +# endif + + 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 fix_roundoff_groundings(xi_dp, yj_dp, xi_sp, yj_sp) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE fix_roundoff_groundings *** + !! + !! ** Purpose : check for roundoff-induced iceberg groundings + !! When using single-precision and reading in a restart file generated by a + !! double-precision run, the location of an iceberg can be rounded up or + !! down. E.g. 254.499999 will be rounded up to 254.5. This can change the + !! grid point the iceberg belongs to and sometimes move it to a land point + !! i.e. ground the iceberg. All we do here is perturb the single-precision + !! position of the iceberg until double and single-precision "agree" on the + !! integer grid point of the iceberg. We do this by adding or subtracting + !! very small numbers based on the machine epsilon. + !!---------------------------------------------------------------------- + REAL(dp), INTENT(in) :: xi_dp, yj_dp + REAL(sp), INTENT(out) :: xi_sp, yj_sp + !!---------------------------------------------------------------------- + + xi_sp = xi_dp + yj_sp = yj_dp + + ! If x locations differ between single and double-precision + DO WHILE( INT( xi_dp + 0.5_dp) /= INT (xi_sp + 0.5_sp) ) + ! If rounding moves it to the right + IF ( INT( xi_dp + 0.5_dp ) < INT (xi_sp + 0.5_sp ) ) THEN + xi_sp = xi_sp - EPSILON(0.0_sp)*xi_sp + ! If rounding moves it to the left + ELSE + xi_sp = xi_sp + EPSILON(0.0_sp)*xi_sp + END IF + END DO + + ! If y locations differ between single and double-precision + DO WHILE( INT( yj_dp + 0.5_dp) /= INT (yj_sp + 0.5_sp) ) + ! If rounding moves it up + IF ( INT( yj_dp + 0.5_dp ) < INT (yj_sp + 0.5_sp ) ) THEN + yj_sp = yj_sp - EPSILON(0.0_sp)*yj_sp + ! If rounding moves it down + ELSE + yj_sp = yj_sp + EPSILON(0.0_sp)*yj_sp + END IF + END DO + END SUBROUTINE fix_roundoff_groundings + + + 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=64 ) :: clfmt ! writing format + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + INTEGER :: inyear, inmonth, inday, inhour, inmin, insec, idt05 + REAL(wp) :: zjulnow, zjul1st, zjuldif, zjulrst, znsec + !!---------------------------------------------------------------------- + + ! 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_rsttime ) THEN + inyear = ndate0 / 10000 + inmonth = ( ndate0 - (inyear * 10000) ) / 100 + inday = ndate0 - (inyear * 10000) - ( inmonth * 100 ) + CALL ymds2ju( inyear, inmonth, inday, 0.0_wp, zjulrst ) + zjulrst = zjulrst + nitrst * rn_rdt / 86400.0_wp + CALL ju2ymds( zjulrst, inyear, inmonth, inday, znsec ) + inhour = INT( znsec / 3600_wp ) + inmin = INT( ( znsec - inhour * 3600_wp ) / 60.0_wp ) + insec = INT( znsec - inhour * 3600_wp - inmin * 60.0_wp ) + WRITE(clkt,'(I4.4,I2.2,I2.2,A,3I2.2)') inyear, inmonth, inday, & + & '_', inhour, inmin, insec + ELSEIF ( 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 + 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,i1,A,i1,A)') '(A,"_icebergs_",A,"_restart_",I',& + & idg,'.',idg,',".nc")' + WRITE(cl_filename,clfmt) TRIM(cexper), TRIM(ADJUSTL(clkt)), narea-1 + ELSE + WRITE(cl_filename,'(A,"_icebergs_",A,"_restart.nc")') TRIM(cexper), TRIM(ADJUSTL(clkt)) + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbstp.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbstp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..80a589a6590384fb86972323da18db75e11734cb --- /dev/null +++ b/V4.0/nemo_sources/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: icbstp.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbthm.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbthm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..92a1eea92c7ab222b5000d7edfb13263828259d8 --- /dev/null +++ b/V4.0/nemo_sources/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: icbthm.F90 13263 2020-07-08 07:55:54Z ayoung $ + !! 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(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx + !!---------------------------------------------------------------------- + ! + !! initialiaze cicb_melt and cicb_heat + cicb_melt = CMPLX( 0.d0, 0.d0, dp ) + cicb_hflx = CMPLX( 0.d0, 0.d0, dp ) + ! + z1_rday = 1._wp / rday + z1_12 = 1._wp / 12._wp + zdt = berg_dt + z1_dt = 1._wp / zdt + ! + ! we're either going to ignore berg fresh water melt flux and associated heat + ! or we pass it into the ocean, so at this point we set them both to zero, + ! accumulate the contributions to them from each iceberg in the while loop following + ! and then pass them (or not) to the ocean + ! + berg_grid%floating_melt(:,:) = 0._wp + ! calving_hflx re-used here as temporary workspace for the heat flux associated with melting + berg_grid%calving_hflx(:,:) = 0._wp + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + ! + pt => this%current_point + nknberg = this%number(1) + CALL icb_utl_interp( pt%xi, pt%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, dp ), cicb_melt(ii,ij) ) + ! + ! iceberg heat flux + !! the use of DDPDD function for the cumulative sum is needed for reproducibility + !! NB. The src_calving_hflx field is currently hardwired to zero in icb_stp, which means that the + !! heat density of the icebergs is zero and the heat content flux to the ocean from iceberg + !! melting is always zero. Leaving the term in the code until such a time as this is fixed. DS. + zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s + zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s + CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) ) + ! + ! diagnostics + CALL icb_dia_melt( ii, ij, zMnew, zheat_hcflux, zheat_latent, this%mass_scaling, & + & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, & + & zdMv, z1_dt_e1e2 ) + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbtrj.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbtrj.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9d87918c185004950e908e655c03044c86bc5cfc --- /dev/null +++ b/V4.0/nemo_sources/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: icbtrj.F90 13061 2020-06-08 13:20:11Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ICB/icbutl.F90 b/V4.0/nemo_sources/src/OCE/ICB/icbutl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..28af24308e1904c88d3f45d8e058fbf462c9d976 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ICB/icbutl.F90 @@ -0,0 +1,834 @@ +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: icbutl.F90 14372 2021-02-02 17:42:36Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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, CASTSP(e1u), e1v, e1f, pi, pj ) ! scale factors + pe2 =icb_utl_bilin_e( e2t, e2u, CASTSP(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) :: peu, pev! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(dp), DIMENSION(:,:), INTENT(in) :: pet, pef! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(wp) , INTENT(in) :: pi, pj ! 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 ) THEN + CALL FLUSH(numicb) + CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , & + & 'This can be fixed using rn_speed_limit=0.4 in &namberg.' , & + & 'More details in the corresponding iceberg.stat file (nn_verbose_level > 0).' ) + END IF + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/IOM/in_out_manager.F90 b/V4.0/nemo_sources/src/OCE/IOM/in_out_manager.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1e317f59c75a425586dffacb34c5892d0fe236c6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/IOM/in_out_manager.F90 @@ -0,0 +1,205 @@ +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 + INTEGER :: nn_slimrst = 0 !: slim restart output option + INTEGER :: nn_slimrstin= 0 !: slim restart input option + LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) + INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) + INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) + INTEGER :: nn_it000 !: index of the first time step + INTEGER :: nn_itend !: index of the last time step + INTEGER :: nn_date0 !: initial calendar date aammjj + INTEGER :: nn_time0 !: initial time of day in hhmm + INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: nn_istate !: initial state output flag (0/1) + INTEGER :: nn_write !: model standard output frequency + INTEGER :: nn_stock !: restart file frequency + INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times + LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) + LOGICAL :: ln_rstdate !: T=> stamp output restart files with date instead of timestep + LOGICAL :: ln_rsttime !: T=> stamp output restart files with date/time 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 + LOGICAL :: ln_sglread = .FALSE. !: IOM nf90 read on master task only + LOGICAL :: ln_sglwrite = .FALSE. !: IOM nf90 write on master task only + LOGICAL :: ln_diawri_instant = .FALSE. !: diawri instantanious output + LOGICAL :: ln_diawri_full = .TRUE. !: diawri standard NEMO output or reduced output + CHARACTER(lc) :: cn_diawri_outdir = './' !: diawri output directory + LOGICAL :: ln_mppwrite = .FALSE. !: Write out MPP information to file + LOGICAL :: ln_mppwrite_abt = .FALSE. !: Syncronize and abort for mppwrite +#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 :: ntime0 !: initial time hhmm + 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_timing_detail = .FALSE. !: run control for additonal detailed timing + LOGICAL :: ln_timing_onefile = .TRUE. !: Multiple output for timing. + LOGICAL :: ln_timing_barrier = .FALSE. !: Multiple output for timing. + LOGICAL :: ln_timing_check = .FALSE. !: Check for mismatched names in 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 + INTEGER :: numstat = -1 !: logical unit for nemo.stat file + + !!---------------------------------------------------------------------- + !! 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 + LOGICAL :: ln_nemostat !: Create nemo.stat files for reproducibility testing + !!---------------------------------------------------------------------- + !! ecflow/SMS control + !!---------------------------------------------------------------------- + LOGICAL :: ln_smslabel = .FALSE. !: Communicate progress with sms + INTEGER :: nn_smsfrq = 0 !: Timestep frequency for sms comm. + CHARACTER(LEN=64) :: cn_smslabel = "ecflow_client --label" !: command line for flow control (sms or ecflow) + CHARACTER(LEN=64) :: cn_smsevent = "ecflow_client --event" !: command line for flow control (sms or ecflow) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: in_out_manager.F90 12859 2020-05-03 09:33:32Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!===================================================================== +END MODULE in_out_manager \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/IOM/iom.F90 b/V4.0/nemo_sources/src/OCE/IOM/iom.F90 new file mode 100644 index 0000000000000000000000000000000000000000..df123136a289952a2ba516e04aca2f3fbeb4c45f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/IOM/iom.F90 @@ -0,0 +1,3556 @@ +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 + !! 4.0 ! 2019-10 (D. Sarmany) Wrap every XIOS call into an IOM call + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 +#if defined key_xios2 + USE xios +#endif +#if defined key_multio + USE multio_api + USE mpi +#endif + 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 +# 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 + USE mppbroadcast + + 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 +#if defined key_multio + type(multio_handle), PRIVATE :: mio_handle + INTEGER(8), PRIVATE :: mio_parent_comm = mpi_comm_world + INTEGER, PRIVATE :: mio_current_step, start_date, start_time +#endif + PUBLIC iom_initialize, iom_finalize + 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_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + PRIVATE iom_get_123d + PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp +#if defined key_iomput + PRIVATE set_grid +#if defined key_xios2 + 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_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 +#if defined key_multio + PRIVATE set_grid_multio + PRIVATE iom_use_multio +# endif +# endif + PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars + + INTERFACE iom_get + MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + END INTERFACE + INTERFACE iom_getatt + MODULE PROCEDURE iom_g0d_iatt, iom_g1d_iatt, iom_g0d_ratt, iom_g1d_ratt, iom_g0d_catt + END INTERFACE + INTERFACE iom_putatt + MODULE PROCEDURE iom_p0d_iatt, iom_p1d_iatt, iom_p0d_ratt, iom_p1d_ratt, iom_p0d_catt + END INTERFACE + INTERFACE iom_rstput + MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + END INTERFACE + INTERFACE iom_put + MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp + END INTERFACE iom_put + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom.F90 13297 2020-07-13 08:01:58Z andmirek $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +CONTAINS + +#if defined key_multio + SUBROUTINE multio_custom_error_handler(context, err) + integer(8), intent(inout) :: context ! Use mpi communicator as context + integer, intent(in) :: err + integer :: mpierr + + IF (err /= MULTIO_SUCCESS) THEN + CALL ctl_stop( 'MULTIO ERROR: ', multio_error_string(err)) + IF (context /= MPI_UNDEFINED) THEN + call MPI_ABORT(int(context), MPI_ERR_OTHER, mpierr) + context = MPI_UNDEFINED + ENDIF + ENDIF + END SUBROUTINE multio_custom_error_handler +#endif + + + SUBROUTINE iom_initialize(client_id, local_comm, return_comm, global_comm, & + & lxios, lmultio ) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: client_id + INTEGER,INTENT(IN), OPTIONAL :: local_comm + INTEGER,INTENT(OUT), OPTIONAL :: return_comm + INTEGER,INTENT(IN), OPTIONAL :: global_comm + LOGICAL,INTENT(IN), OPTIONAL :: lxios,lmultio +#if defined key_multio + type(multio_configuration) :: conf_ctx + INTEGER :: err + CHARACTER(len=16) :: err_str +#endif + LOGICAL :: llxios,llmultio + + llxios=.TRUE. + IF (PRESENT(lxios)) llxios=lxios + llmultio=.TRUE. + IF (PRESENT(lmultio)) llmultio=lmultio + +#if defined key_xios2 + IF (llxios) THEN +#if key_iomput_sglexe + CALL xios_initialize(client_id, local_comm, return_comm, global_comm) +#else + CALL xios_initialize(client_id, local_comm, return_comm) +#endif + ENDIF +#endif +#if defined key_multio + IF (llmultio) THEN + err = multio_initialise() + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'Initializing multio failed: ', multio_error_string(err)) + end if + + IF (PRESENT(global_comm)) THEN; mio_parent_comm = global_comm; ENDIF + + ! Prepare context and check errors explicitly until everything is set up - then failure handler is used + + BLOCK + CHARACTER(:), allocatable :: config_file + INTEGER :: config_file_length + + CALL get_environment_variable('MULTIO_NEMO_CONFIG_FILE', length=config_file_length) + IF (config_file_length == 0) THEN + err = conf_ctx%new() + ELSE + ALLOCATE(character(len=config_file_length + 1) :: config_file) + + CALL get_environment_variable('MULTIO_NEMO_CONFIG_FILE', config_file) + err = conf_ctx%new(config_file) + + DEALLOCATE(config_file) + ENDIF + END BLOCK + + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'Creating multio configuration context failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_allow_world_default_comm(.FALSE._1) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'conf_ctx%mpi_allow_world_default_comm(.FALSE._1) failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_client_id(client_id) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'conf_ctx%mpi_client_id(', TRIM(client_id),') failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_return_client_comm(return_comm) + if (err /= MULTIO_SUCCESS) then + WRITE (err_str, "(I)") return_comm + CALL ctl_stop( 'conf_ctx%mpi_return_client_comm(', err_str,') failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_parent_comm(int(mio_parent_comm)) + if (err /= MULTIO_SUCCESS) then + WRITE (err_str, "(I)") mio_parent_comm + CALL ctl_stop( 'conf_ctx%mpi_parent_comm(', err_str,') failed: ', multio_error_string(err)) + end if + + err = mio_handle%new(conf_ctx) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'mio_handle%new(conf_ctx) failed: ', multio_error_string(err)) + end if + + err = conf_ctx%delete() + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'conf_ctx%delete() failed: ', multio_error_string(err)) + end if + + ! Setting a failure handler that reacts on interface problems or exceptions that are not handled within the interface + err = multio_set_failure_handler(multio_custom_error_handler, mio_parent_comm) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'setting multio failure handler failed: ', multio_error_string(err)) + end if + + ENDIF +#endif + + END SUBROUTINE iom_initialize + + SUBROUTINE iom_finalize() + IMPLICIT NONE + INTEGER :: err + +#if defined key_xios2 + CALL xios_finalize() +#endif +#if defined key_multio + err = mio_handle%close_connections(); + err = mio_handle%delete(); +#endif + + END SUBROUTINE iom_finalize + + SUBROUTINE iom_init_server(server_comm,lxios,lmultio) + IMPLICIT NONE + INTEGER, INTENT(IN) :: server_comm + LOGICAL,INTENT(IN), OPTIONAL :: lxios,lmultio + LOGICAL :: llxios,llmultio +#if defined key_multio + type(multio_configuration) :: conf_ctx + INTEGER :: err + CHARACTER(len=16) :: err_str +#endif + + llxios=.TRUE. + IF (PRESENT(lxios)) llxios=lxios + llmultio=.TRUE. + IF (PRESENT(lmultio)) llmultio=lmultio + +#if defined key_xios2 +#if key_iomput_sglexe + IF (llxios) THEN + CALL xios_init_server(global_comm = server_comm) + ENDIF +#endif +#endif +#if defined key_multio + IF (llmultio) THEN + mio_parent_comm = server_comm + + err = multio_initialise() + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'Initializing multio failed: ', multio_error_string(err)) + end if + + ! Prepare context and check errors explicitly until everything is set up - then failure handler is used + + BLOCK + CHARACTER(:), allocatable :: config_file + INTEGER :: config_file_length + + CALL get_environment_variable('MULTIO_NEMO_CONFIG_FILE', length=config_file_length) + IF (config_file_length == 0) THEN + err = conf_ctx%new() + ELSE + ALLOCATE(character(len=config_file_length + 1) :: config_file) + + CALL get_environment_variable('MULTIO_NEMO_CONFIG_FILE', config_file) + err = conf_ctx%new(config_file) + + DEALLOCATE(config_file) + ENDIF + END BLOCK + + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'Creating multio server configuration context failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_allow_world_default_comm(.FALSE._1) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'conf_ctx%mpi_allow_world_default_comm(.FALSE._1) failed: ', multio_error_string(err)) + end if + err = conf_ctx%mpi_parent_comm(int(mio_parent_comm)) + if (err /= MULTIO_SUCCESS) then + WRITE (err_str, "(I)") mio_parent_comm + CALL ctl_stop( 'conf_ctx%mpi_parent_comm(', err_str,') failed: ', multio_error_string(err)) + end if + + ! Setting a failure handler that reacts on interface problems or exceptions that are not handled within the interface + ! Set handler before invoking blocking start server call + err = multio_set_failure_handler(multio_custom_error_handler, mio_parent_comm) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'setting multio failure handler failed: ', multio_error_string(err)) + end if + + ! Blocking call + err = multio_start_server(conf_ctx) + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'multio_start_server(conf_ctx) failed: ', multio_error_string(err)) + end if + + err = conf_ctx%delete() + if (err /= MULTIO_SUCCESS) then + CALL ctl_stop( 'conf_ctx%delete() failed: ', multio_error_string(err)) + end if + + ENDIF +#endif + + END SUBROUTINE iom_init_server + + 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 + 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 !: +#if defined key_xios2 + ! + 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 +#endif +#if defined key_multio + INTEGER :: gl_size, err +#endif + !!---------------------------------------------------------------------- + ! + ! 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 + ! +#if defined key_xios2 + 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,0,0,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,0,0,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,0,0,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", CASTSP(glamu), CASTSP(gphiu), .FALSE., .FALSE. ) + CALL set_grid( "V", CASTSP(glamv), CASTSP(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 = real( e1e2t(nldi:nlei, nldj:nlej), dp)) + CALL iom_set_domain_attr("grid_U", area = real( e1e2u(nldi:nlei, nldj:nlej), dp)) + CALL iom_set_domain_attr("grid_V", area = real( e1e2v(nldi:nlei, nldj:nlej), dp)) + CALL iom_set_domain_attr("grid_W", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) + CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) + CALL set_grid_bounds( "U", CASTSP(glamv), CASTSP(gphiv), CASTSP(glamu), CASTSP(gphiu) ) + CALL set_grid_bounds( "V", CASTSP(glamu), CASTSP(gphiu), CASTSP(glamv), CASTSP(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 = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp)) + CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej), dp) ) + CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej), dp) ) + CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp ) ) + CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) + CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) + CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + ENDIF + ENDIF + ! + ! vertical grid definition + IF(.NOT.llrst_context) THEN + CALL iom_set_axis_attr( "deptht", paxis = real(gdept_1d, dp) ) + CALL iom_set_axis_attr( "depthu", paxis = real(gdept_1d, dp) ) + CALL iom_set_axis_attr( "depthv", paxis = real(gdept_1d, dp) ) + CALL iom_set_axis_attr( "depthw", paxis = real(gdepw_1d, dp) ) + + ! 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=real(zw_bnds, dp) ) + CALL iom_set_axis_attr( "depthu", bounds=real(zw_bnds, dp) ) + CALL iom_set_axis_attr( "depthv", bounds=real(zw_bnds, dp) ) + CALL iom_set_axis_attr( "depthw", bounds=real(zt_bnds, dp) ) + CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,dp), ji=1,jpnfl) /) ) +# if defined key_si3 + CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,dp), ji=1,jpl) /) ) + ! SIMIP diagnostics (4 main arctic straits) + CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,dp), ji=1,4) /) ) +# endif +#if defined key_top + IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = real(profsed, dp) ) +#endif + CALL iom_set_axis_attr( "icbcla", REAL(class_num,dp) ) + CALL iom_set_axis_attr( "iax_14C", (/ REAL(14,dp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_17C", (/ REAL(17,dp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,dp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,dp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,dp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,dp), 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 ) + ! +#endif + ! +#if defined key_multio + + err = mio_handle%open_connections() + gl_size = jpiglo * jpjglo + + CALL set_grid_multio(gl_size, "T", glamt, gphit ) + CALL set_grid_multio(gl_size, "U", glamu, gphiu ) + CALL set_grid_multio(gl_size, "V", glamv, gphiv ) + CALL set_grid_multio(gl_size, "W", glamt, gphit ) + + ! ! TODO where are these important? Before they have been set to global metadata, but all IO has been done before + ! err = mio_md%set_int("timeStep", int(rdt)) + ! err = mio_md%set_int("date", 10000*nyear + 100*nmonth + nday) + +#endif + ! + IF ( ll_tmppatch ) THEN + nldi = nldi_save ; nlei = nlei_save + nldj = nldj_save ; nlej = nlej_save + 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 +#if defined key_xios2 + 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 +#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") + 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="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 +#if defined key_xios2 + 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 +#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 +#if defined key_xios2 + 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 = real(gdept_1d, dp) ) + + CALL xios_get_handle("scalar_definition", scalargroup_hdl) + CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") +#endif +#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 +#if defined key_xios2 + 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 +#endif + ! + END SUBROUTINE iom_swap + + + SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev, ldnoov, ldsgl ) + !!--------------------------------------------------------------------- + !! *** 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 + LOGICAL , INTENT(in ), OPTIONAL :: ldnoov ! No overlap override + LOGICAL , INTENT(in ), OPTIONAL :: ldsgl ! Overwrite ln_sglread/ln_sglwrite + ! + 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 :: llsgl ! local definition to ldsgl + 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: + LOGICAL, DIMENSION(1) :: lltmp + LOGICAL :: llchk + ! 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 + ! are we overriding ln_readsgl/ln_writesgl + IF( PRESENT(ldsgl) ) THEN ; llsgl = ldsgl + ELSE ; llsgl = .TRUE. + ENDIF + IF (lliof) llsgl=.FALSE. ! Does not work for interpolation on the fly + ! do we read the overlap + ! ugly patch SM+JMM+RB to overwrite global definition in some cases + IF( PRESENT(ldnoov) ) THEN + llnoov = ldnoov + ELSE + llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif + ENDIF + ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) + ! ============= + clname = trim(cdname) + IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN +!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 + ! ============= + IF( llwrt ) THEN + llchk = ln_sglwrite + ELSE + llchk = ln_sglread + ENDIF + IF( llchk .AND. llsgl ) THEN + IF (nproc==0) THEN + INQUIRE( FILE = clname, EXIST = lltmp(1) ) + ENDIF + CALL mpp_broadcast( lltmp, 1, 0) + llok = lltmp(1) + ELSE + 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 + 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 + IF ( ( ln_sglwrite .AND. ( nproc == 0 ) .AND. llsgl ).OR. ( .NOT.(ln_sglwrite.and.llsgl) )) THEN + 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 + ENDIF + 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 + IF ( ( ln_sglread .OR. ln_sglwrite ) .AND. ( jpnij > 1 ) .AND. llsgl ) THEN + CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, & + & kdlev = kdlev, ldsglread = ln_sglread, ldsglwrite = ln_sglwrite ) + ELSE + CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev ) + ENDIF + ENDIF + ! + END SUBROUTINE iom_open + + + SUBROUTINE iom_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_close *** + !! + !! ** Purpose : close an input file, or all files opened by iom + !!-------------------------------------------------------------------- + INTEGER, INTENT(inout), OPTIONAL :: kiomid ! iom identifier of the file to be closed + ! ! return 0 when file is properly closed + ! ! No argument: all files opened by iom are closed + + INTEGER :: jf ! dummy loop indices + INTEGER :: i_s, i_e ! temporary integer + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + IF( iom_open_init == 0 ) RETURN ! avoid to use iom_file(jf)%nfid that us not yet initialized + ! + clinfo = ' iom_close ~~~ ' + IF( PRESENT(kiomid) ) THEN + i_s = kiomid + i_e = kiomid + ELSE + i_s = 1 + i_e = jpmax_files + ENDIF + + IF( i_s > 0 ) THEN + DO jf = i_s, i_e + IF( iom_file(jf)%nfid > 0 ) THEN + CALL iom_nf90_close( jf ) + iom_file(jf)%nfid = 0 ! free the id + IF( PRESENT(kiomid) ) kiomid = 0 ! return 0 as id to specify that the file was closed + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok' + ELSEIF( PRESENT(kiomid) ) THEN + WRITE(ctmp1,*) '--->', kiomid + CALL ctl_stop( TRIM(clinfo)//' Invalid file identifier', ctmp1 ) + ENDIF + END DO + ENDIF + ! + END SUBROUTINE iom_close + + + FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_varid *** + !! + !! ** Purpose : get the id of a variable in a file (return 0 if not found) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable + INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension + INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions + LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) + LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) + ! + INTEGER :: iom_varid, iiv, i_nvd + LOGICAL :: ll_fnd + CHARACTER(LEN=100) :: clinfo ! info character + LOGICAL :: llstop ! local definition of ldstop + !!----------------------------------------------------------------------- + iom_varid = 0 ! default definition + ! do we call ctl_stop if we look for non-existing variable? + IF( PRESENT(ldstop) ) THEN ; llstop = ldstop + ELSE ; llstop = .TRUE. + ENDIF + ! + IF( kiomid > 0 ) THEN + clinfo = 'iom_varid, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(cdvar) + IF( iom_file(kiomid)%nfid == 0 ) THEN + CALL ctl_stop( trim(clinfo), 'the file is not open' ) + ELSE + ll_fnd = .FALSE. + iiv = 0 + ! + DO WHILE ( .NOT.ll_fnd .AND. iiv < iom_file(kiomid)%nvars ) + iiv = iiv + 1 + ll_fnd = ( TRIM(cdvar) == TRIM(iom_file(kiomid)%cn_var(iiv)) ) + END DO + ! + IF( .NOT.ll_fnd ) THEN + iiv = iiv + 1 + IF( iiv <= jpmax_vars ) THEN + iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) + ELSE + CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & + & 'increase the parameter jpmax_vars') + ENDIF + IF( llstop .AND. iom_varid == -1 ) CALL ctl_stop( TRIM(clinfo)//' not found' ) + ELSE + iom_varid = iiv + IF( PRESENT(kdimsz) ) THEN + i_nvd = iom_file(kiomid)%ndims(iiv) + IF( i_nvd <= size(kdimsz) ) THEN + kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,iiv) + ELSE + WRITE(ctmp1,*) i_nvd, size(kdimsz) + CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) ) + ENDIF + ENDIF + IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) + IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) + ENDIF + ENDIF + ENDIF + ! + END FUNCTION iom_varid + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_get + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out) :: pvar ! read field + REAL(dp) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + 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' ) + IF ( iom_file (kiomid)%lsgl .AND. ( jpnij > 1 )) THEN + CALL iom_nf90_get_sgl( kiomid, idvar, ztmp_pvar, itime ) + ELSE + CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) + ENDIF + pvar = ztmp_pvar + ENDIF + ENDIF + ELSE +#if defined key_iomput +#if defined key_xios2 + 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) ) +#endif +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_sp + + SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out) :: pvar ! read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + 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' ) + IF ( iom_file (kiomid)%lsgl .AND. ( jpnij > 1 )) THEN + CALL iom_nf90_get_sgl( kiomid, idvar, pvar, itime ) + ELSE + CALL iom_nf90_get( kiomid, idvar, pvar, itime ) + ENDIF + ENDIF + ENDIF + ELSE +#if defined key_iomput +#if defined key_xios2 + 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) ) +#endif +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_dp + + SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, 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(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1))) + CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount, & + & ldxios=ldxios ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g1d_sp + + + SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, 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(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + 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_dp + + SUBROUTINE iom_g2d_sp( 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(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(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 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) + CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=ztmp_pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount, & + & lrowattr=lrowattr, ldxios=ldxios) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g2d_sp + + + SUBROUTINE iom_g2d_dp( 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(dp) , 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_dp + + SUBROUTINE iom_g3d_sp( 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(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(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 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) + CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=ztmp_pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount, & + & lrowattr=lrowattr, ldxios=ldxios ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g3d_sp + + SUBROUTINE iom_g3d_dp( 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(dp) , 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_dp + + + + !!---------------------------------------------------------------------- + + 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(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + 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(dp) :: 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(dp) :: 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 + + IF ( iom_file(kiomid)%lsgl .AND. ( jpnij > 1 )) THEN + CALL iom_nf90_get_sgl( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) + ELSE + CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) + ENDIF + 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.0_wp, 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.0_wp, 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 +#if defined key_xios2 +!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.0_wp, 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.0_wp, 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) ) +#endif +#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.0_wp ) + IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) + + !--- 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 defined key_xios2 + IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN + z2d(:,:) = 0._wp + CALL xios_recv_field( cdname, z2d) + ENDIF +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_get_var + + + FUNCTION iom_getszuld ( kiomid ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_getszuld *** + !! + !! ** Purpose : get the size of the unlimited dimension in a file + !! (return -1 if not found) + !!----------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiomid ! file Identifier + ! + INTEGER :: iom_getszuld + !!----------------------------------------------------------------------- + iom_getszuld = -1 + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%iduld > 0 ) iom_getszuld = iom_file(kiomid)%lenuld + ENDIF + END FUNCTION iom_getszuld + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_chkatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! Name of the attribute + LOGICAL , INTENT( out) :: llok ! Error code + INTEGER , INTENT( out), OPTIONAL :: ksize ! Size of the attribute array + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_chkatt( kiomid, cdatt, llok, ksize=ksize, cdvar=cdvar ) + ENDIF + ! + END SUBROUTINE iom_chkatt + + !!---------------------------------------------------------------------- + !! INTERFACE iom_getatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT( out) :: katt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_iatt + + SUBROUTINE iom_g1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT( out) :: katt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_iatt + + SUBROUTINE iom_g0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT( out) :: patt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_ratt + + SUBROUTINE iom_g1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT( out) :: patt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_ratt + + SUBROUTINE iom_g0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT( out) :: cdatt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_putatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT(in ) :: katt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_iatt + + SUBROUTINE iom_p1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT(in ) :: katt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_iatt + + SUBROUTINE iom_p0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT(in ) :: patt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_ratt + + SUBROUTINE iom_p1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT(in ) :: patt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_ratt + + SUBROUTINE iom_p0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT(in ) :: cdatt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_rstput + !!---------------------------------------------------------------------- + SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, 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(sp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_sp + + SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, 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(dp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + IF (iom_file(kiomid)%lsgl) THEN + CALL iom_nf90_rstput_sgl( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + ELSE + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + ENDIF + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_dp + + + SUBROUTINE iom_rp1d_sp( 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(sp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_sp + + SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, 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(dp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + IF (iom_file(kiomid)%lsgl) THEN + CALL iom_nf90_rstput_sgl( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + ELSE + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + ENDIF + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_dp + + + SUBROUTINE iom_rp2d_sp( 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(sp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_sp + + SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, 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(dp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + IF (iom_file(kiomid)%lsgl) THEN + CALL iom_nf90_rstput_sgl( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + ELSE + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + ENDIF + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_dp + + + SUBROUTINE iom_rp3d_sp( 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(sp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_sp + + SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, 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(dp) , 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 +#ifdef key_xios2 + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + IF (iom_file(kiomid)%lsgl) THEN + CALL iom_nf90_rstput_sgl( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + ELSE + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + ENDIF + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_dp + + + + SUBROUTINE iom_delay_rst( cdaction, cdcpnt, kncid ) + !!--------------------------------------------------------------------- + !! Routine iom_delay_rst: used read/write restart related to mpp_delay + !! + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdaction ! + CHARACTER(len=*), INTENT(in ) :: cdcpnt + INTEGER , INTENT(in ) :: kncid + ! + INTEGER :: ji + INTEGER :: indim + LOGICAL :: llattexist + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zreal1d + !!--------------------------------------------------------------------- + ! + ! =================================== + IF( TRIM(cdaction) == 'READ' ) THEN ! read restart related to mpp_delay ! + ! =================================== + DO ji = 1, nbdelay + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + CALL iom_chkatt( kncid, 'DELAY_'//c_delaylist(ji), llattexist, indim ) + IF( llattexist ) THEN + ALLOCATE( todelay(ji)%z1d(indim) ) + CALL iom_getatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ndelayid(ji) = 0 ! set to 0 to specify that the value was read in the restart + ENDIF + ENDIF + END DO + ! ==================================== + ELSE ! write restart related to mpp_delay ! + ! ==================================== + DO ji = 1, nbdelay ! save only ocean delayed global communication variables + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + IF( ASSOCIATED(todelay(ji)%z1d) ) THEN + CALL mpp_delay_rcv(ji) ! make sure %z1d is received + CALL iom_putatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ENDIF + ENDIF + END DO + ! + ENDIF + + END SUBROUTINE iom_delay_rst + + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_put + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_sp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(sp) , INTENT(in) :: pfield0d +!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_iomput +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) +#if defined key_xios2 + CALL xios_send_field(cdname, (/pfield0d/)) +#endif +#if defined key_multio + IF ( iom_use_multio(cdname) ) THEN + CALL ctl_stop("MULTIO Not implemented: Writing scalar field "//TRIM(cdname)) + END IF +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_sp + + SUBROUTINE iom_p0d_dp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(dp) , INTENT(in) :: pfield0d +!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_iomput +#if defined key_xios2 +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#endif +#if defined key_multio + IF ( iom_use_multio(cdname) ) THEN + CALL ctl_stop("MULTIO Not implemented: Writing scalar field "//TRIM(cdname)) + END IF +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_dp + + + SUBROUTINE iom_p1d_sp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#endif +#if defined key_multio + call ctl_stop('key_multio not implemented for iom_p1d_sp') +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_sp + + SUBROUTINE iom_p1d_dp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#endif +#if defined key_multio + CALL ctl_stop("MULTIO Not implemented: Writing one-dimensional field "//TRIM(cdname)) +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_dp + + SUBROUTINE iom_p2d_sp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d +#if defined key_iomput +#if defined key_multio + TYPE(multio_metadata) :: mio_md + INTEGER :: err, gl_size +#endif +#if defined key_xios2 + CALL xios_send_field(cdname, pfield2d) +#endif +#if defined key_multio + IF (.NOT. iom_use_multio(cdname, category="ocean-2d")) RETURN + + err = mio_md%new() + + gl_size = jpiglo * jpjglo + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_string("category", "ocean-2d") + err = mio_md%set_int("level", 1); + + err = mio_md%set_int("step", mio_current_step) + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("timeStep", int(rdt)) + err = mio_md%set_int("startDate", start_date) + err = mio_md%set_int("startTime", start_time) + + ! write field + err = mio_md%set_string("name", cdname) + err = mio_md%set_string("nemoParam", cdname) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_float("missingValue", 0.0_sp) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .FALSE._1) + err = mio_handle%write_field(mio_md, REAL(pfield2d,dp)) + + err = mio_md%delete() +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p2d_sp + + SUBROUTINE iom_p2d_dp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d +#if defined key_iomput +#if defined key_multio + TYPE(multio_metadata) :: mio_md + INTEGER :: err, gl_size +#endif +#if defined key_xios2 + CALL xios_send_field(cdname, pfield2d) +#endif +#if defined key_multio + IF (.NOT. iom_use_multio(cdname, category="ocean-2d")) RETURN + + err = mio_md%new() + + gl_size = jpiglo * jpjglo + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_string("category", "ocean-2d") + err = mio_md%set_int("level", 1); + + err = mio_md%set_int("step", mio_current_step) + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("timeStep", int(rdt)) + err = mio_md%set_int("startDate", start_date) + err = mio_md%set_int("startTime", start_time) + + ! write field + err = mio_md%set_string("name", cdname) + err = mio_md%set_string("nemoParam", cdname) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_double("missingValue", 0.0_8) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .FALSE._1) + err = mio_handle%write_field(mio_md, pfield2d) + + err = mio_md%delete() +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p2d_dp + + SUBROUTINE iom_p3d_sp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d +#if defined key_multio + INTEGER, DIMENSION(3) :: field_shape + INTEGER :: ii + TYPE(multio_metadata) :: mio_md + INTEGER :: err, gl_size +#endif +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field( cdname, pfield3d ) +#endif +#if defined key_multio + + IF (.NOT. iom_use_multio(cdname, category="ocean-3d")) RETURN + + err = mio_md%new() + + field_shape = SHAPE(pfield3d) + + gl_size = jpiglo * jpjglo + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_string("category", "ocean-3d") + err = mio_md%set_int("step", mio_current_step); + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("timeStep", int(rdt)) + err = mio_md%set_int("startDate", start_date) + err = mio_md%set_int("startTime", start_time) + + DO ii = 1, field_shape(3) + err = mio_md%set_int("level", ii) + + err = mio_md%set_string("name", cdname) + err = mio_md%set_string("nemoParam", cdname) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_float("missingValue", 0.0_4) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .FALSE._1) + + err = mio_handle%write_field(mio_md, REAL(pfield3d(:, :, ii),dp)) + END DO + + err = mio_md%delete() +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p3d_sp + + SUBROUTINE iom_p3d_dp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d +#if defined key_multio + INTEGER, DIMENSION(3) :: field_shape + INTEGER :: ii + TYPE(multio_metadata) :: mio_md + INTEGER :: err, gl_size +#endif + +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field( cdname, pfield3d ) +#endif +#if defined key_multio + + IF (.NOT. iom_use_multio(cdname, category="ocean-3d")) RETURN + + err = mio_md%new() + + field_shape = SHAPE(pfield3d) + + gl_size = jpiglo * jpjglo + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_string("category", "ocean-3d") + err = mio_md%set_int("step", mio_current_step); + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("timeStep", int(rdt)) + err = mio_md%set_int("startDate", start_date) + err = mio_md%set_int("startTime", start_time) + + DO ii = 1, field_shape(3) + err = mio_md%set_int("level", ii) + + err = mio_md%set_string("name", cdname) + err = mio_md%set_string("nemoParam", cdname) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_double("missingValue", 0.0_8) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .FALSE._1) + + err = mio_handle%write_field(mio_md, pfield3d(:, :, ii)) + END DO + + err = mio_md%delete() +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p3d_dp + + SUBROUTINE iom_p4d_sp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field(cdname, pfield4d) +#endif +#if defined key_multio + call ctl_stop('key_multio not implemented for iom_p4d_sp') +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p4d_sp + + SUBROUTINE iom_p4d_dp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d +#if defined key_iomput +#if defined key_xios2 + CALL xios_send_field(cdname, pfield4d) +#endif +#if defined key_multio + call ctl_stop('key_multio not implemented for iom_p4d_sp') +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p4d_dp + +#if defined key_iomput + !!---------------------------------------------------------------------------- + !! 'key_iomput' I/O-server interface + !!---------------------------------------------------------------------------- + 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!, data_sz + INTEGER, DIMENSION(11) :: grid_data + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask + LOGICAL, INTENT(IN) :: ldxios, ldrxios + !!---------------------------------------------------------------------- + ! + ni = nlei-nldi+1 + nj = nlej-nldj+1 + ! +#if defined key_xios2 + + 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 = REAL(RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp), & + & latvalue = REAL(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp)) + ! + IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN + ! mask land points, keep values on coast line -> specific mask for U, V and W points + SELECT CASE ( cdgrd ) + CASE('T') ; zmask(:,:,:) = tmask(:,:,:) + CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1.0_wp ) + CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp ) + 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 +#endif + END SUBROUTINE set_grid + +#if defined key_multio + SUBROUTINE set_grid_multio(gl_size, cdgrd, plon, plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid *** + !! + !! ** Purpose : define horizontal grids + !!---------------------------------------------------------------------- + INTEGER , INTENT(IN) :: gl_size + 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!, data_sz + INTEGER, DIMENSION(11) :: grid_data + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask + INTEGER, DIMENSION(3) :: mask_shape + INTEGER :: err, ii + TYPE(MULTIO_METADATA) :: mio_md + !!---------------------------------------------------------------------- + ! + ni = nlei-nldi+1 + nj = nlej-nldj+1 + ! + grid_data(1) = jpiglo + grid_data(2) = jpjglo + grid_data(3) = nimpp+nldi-2 + grid_data(4) = ni + grid_data(5) = njmpp+nldj-2 + grid_data(6) = nj + grid_data(7) = 2 + grid_data(8) = 1-nldi + grid_data(9) = jpi + grid_data(10) = 1-nldj + grid_data(11) = jpj + + err = mio_md%new() + err = mio_md%set_int("globalSize", gl_size) + + ! write domain + err = mio_md%set_string("name", cdgrd//" grid") + err = mio_md%set_string("category", "ocean-domain-map") + err = mio_md%set_string("representation", "structured") + err = mio_md%set_bool("toAllServers", .TRUE._1) + err = mio_handle%write_domain(mio_md, grid_data) + + err = mio_md%delete() + + ! Set land-sea mask first + ! 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.0_wp ) + CASE('V') + zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) + CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp ) + CASE('W') + zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) + zmask(:,:,1) = tmask(:,:,1) + END SELECT + + mask_shape = SHAPE(zmask) + DO ii = 1, mask_shape(3) + err = mio_md%new() + err = mio_md%set_int("globalSize", gl_size) + err = mio_md%set_string("name", cdgrd//" mask") + err = mio_md%set_int("level", ii) + err = mio_md%set_string("category", "ocean-mask") + err = mio_md%set_string("domain", cdgrd//" grid") + err = mio_md%set_bool("toAllServers", .TRUE._1) + IF (sp==wp) THEN + err = mio_handle%write_mask(mio_md, REAL(zmask(:, :, ii),dp)) + ELSE + err = mio_handle%write_mask(mio_md, zmask(:, :, ii)) + ENDIF + err = mio_md%delete() + END DO + + ! Write out co-ordinates as fields -- start with latitude + err = mio_md%new() + + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_int("step", 0); + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("level", 0); + err = mio_md%set_int("timeStep", int(rdt)) + err = mio_md%set_int("startDate", 10000*nyear + 100*nmonth + nday) + err = mio_md%set_int("startTime", 10000*nhour + 100*nminute) + err = mio_md%set_string("category", "ocean-grid-coordinate") + + ! write field lat + err = mio_md%set_string("name", "lat_"//cdgrd) + err = mio_md%set_string("nemoParam", "lat_"//cdgrd) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_double("missingValue", 0.0_8) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .TRUE._1) + IF (sp==wp) THEN + err = mio_handle%write_field(mio_md, REAL(plat,dp)) + ELSE + err = mio_handle%write_field(mio_md, plat) + ENDIF + + err = mio_md%delete() + + + ! Duplicate everything for longitude + err = mio_md%new() + + err = mio_md%set_int("globalSize", gl_size) + + err = mio_md%set_int("step", 0); + err = mio_md%set_int("step-frequency", 1) + err = mio_md%set_int("level", 0); + err = mio_md%set_int("startDate", 10000*nyear + 100*nmonth + nday) + err = mio_md%set_int("startTime", 10000*nhour + 100*nminute) + err = mio_md%set_string("category", "ocean-grid-coordinate") + + ! write field lat + err = mio_md%set_string("name", "lon_"//cdgrd) + err = mio_md%set_string("nemoParam", "lon_"//cdgrd) + + ! TODO: May not need to be a field's metadata + err = mio_md%set_double("missingValue", 0.0_8) + err = mio_md%set_bool("bitmapPresent", .FALSE._1) + err = mio_md%set_int("bitsPerValue", 16) + + err = mio_md%set_bool("toAllServers", .TRUE._1) + IF (sp==wp) THEN + err = mio_handle%write_field(mio_md, REAL(plon,dp)) + ELSE + err = mio_handle%write_field(mio_md, plon) + ENDIF + + ! Clean up + err = mio_md%delete() + + END SUBROUTINE set_grid_multio +#endif + +#if defined key_xios2 + !!---------------------------------------------------------------------- + !! '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(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue + REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area + LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask + !!---------------------------------------------------------------------- + ! + IF( xios_is_valid_domain (cdid) ) THEN + CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & + & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & + & 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(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis + REAL(dp), 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 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.0_wp ) ! 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.0_wp, pfillval=999._wp ) + CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1.0_wp, 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 =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp), & + & bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) + ! + DEALLOCATE( z_bnds, z_fld, z_rot ) + ! + END SUBROUTINE set_grid_bounds + + + SUBROUTINE set_grid_znl( plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid_znl *** + !! + !! ** Purpose : define grids for zonal mean + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat + ! + INTEGER :: 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_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) + CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) + CALL iom_set_domain_attr("gznl", ni_glo=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 = REAL(zlon,dp), & + & latvalue = REAL(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp)) + 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(dp), DIMENSION(1) :: zz = 1. + !!---------------------------------------------------------------------- + ! + CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) + CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) + ! + zz = REAL( narea, wp ) + CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) + ! + END SUBROUTINE set_scalar + + + SUBROUTINE set_xmlatt + !!---------------------------------------------------------------------- + !! *** ROUTINE set_xmlatt *** + !! + !! ** Purpose : automatic definitions of some of the xml attributs... + !! + !!---------------------------------------------------------------------- + CHARACTER(len=1),DIMENSION( 3) :: clgrd ! suffix name + CHARACTER(len=256) :: clsuff ! suffix name + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=2) :: cl2 ! 2 characters + CHARACTER(len=3) :: cl3 ! 3 characters + INTEGER :: ji, jg ! loop counters + INTEGER :: ix, iy ! i-,j- index + REAL(wp) ,DIMENSION(11) :: zlontao ! longitudes of tao moorings + REAL(wp) ,DIMENSION( 7) :: zlattao ! latitudes of tao moorings + REAL(wp) ,DIMENSION( 4) :: zlonrama ! longitudes of rama moorings + REAL(wp) ,DIMENSION(11) :: zlatrama ! latitudes of rama moorings + REAL(wp) ,DIMENSION( 3) :: zlonpira ! longitudes of pirata moorings + REAL(wp) ,DIMENSION( 9) :: zlatpira ! latitudes of pirata moorings + TYPE(xios_duration) :: f_op, f_of + !!---------------------------------------------------------------------- + ! + ! frequency of the call of iom_put (attribut: freq_op) + f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = 0 ; CALL iom_set_field_attr('trendT_even' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_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_wp, 0.0_wp, 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.0_wp, iyear, imonth, iday, zsec ) + isec = 86400 + ENDIF + ! + IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date + ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 + ENDIF + ! +!$AGRIF_DO_NOT_TREAT + ! needed in the conv + IF( llfull ) THEN + clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" + ihour = isec / 3600 + isec = MOD(isec, 3600) + iminute = isec / 60 + isec = MOD(isec, 60) + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec ! date of the end of run + ELSE + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run + ENDIF +!$AGRIF_END_DO_NOT_TREAT + ! + END FUNCTION iom_sdate + +#endif +#endif + + SUBROUTINE iom_setkt( kt, cdname ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + CHARACTER(LEN=*), INTENT(in) :: cdname +#if defined key_iomput +#if defined key_xios2 + 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 +#endif +#if defined key_multio + ! CALL multio_metadata_set_int_value( "step", kt ) + mio_current_step = kt + IF( mio_current_step == 1) THEN + start_date = 10000*nyear + 100*nmonth + nday + start_time = 10000*nhour + 100*nminute + ENDIF + +#endif +#else + IF( .FALSE. ) WRITE(numout,*) kt, cdname ! useless test to avoid compilation warnings +#endif + + 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 defined key_iomput +#if defined key_xios2 + 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 +#endif +#else + IF( .FALSE. ) WRITE(numout,*) cdname ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_context_finalize + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + LOGICAL :: lusex +#if defined key_multio + TYPE(multio_metadata) :: mio_md + LOGICAL(1) :: lusem + INTEGER :: err +#else + LOGICAL :: lusem +#endif + + lusex=.FALSE. + lusem=.FALSE. +#if defined key_iomput +#if defined key_xios2 + lusex = xios_field_is_active( cdname ) +#endif +#if defined key_multio + err = mio_md%new() + err = mio_md%set_string("name", cdname) + err = mio_handle%field_accepted(mio_md, lusem) + err = mio_md%delete() +#endif + iom_use = lusex.OR.lusem +#else + iom_use = .FALSE. +#endif + + END FUNCTION iom_use + +#if defined key_iomput +#if defined key_multio + LOGICAL FUNCTION iom_use_multio(cdname, category) + CHARACTER(LEN=*), INTENT(in) :: cdname + CHARACTER(LEN=*), INTENT(in), OPTIONAL :: category + TYPE(multio_metadata) :: mio_md + LOGICAL(1) :: field_active + LOGICAL(1) :: category_active + INTEGER :: err + + + IF (PRESENT(CATEGORY)) THEN + err = mio_md%new() + err = mio_md%set_string("category", cdname) + err = mio_handle%field_accepted(mio_md, category_active) + err = mio_md%delete() + ELSE + category_active = .FALSE. + ENDIF + + err = mio_md%new() + err = mio_md%set_string("name", cdname) + err = mio_handle%field_accepted(mio_md, field_active) + err = mio_md%delete() + + iom_use_multio = category_active .or. field_active + END FUNCTION iom_use_multio +#endif +#endif + + SUBROUTINE iom_miss_val( cdname, pmiss_val ) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp) , INTENT(out) :: pmiss_val + REAL(dp) :: ztmp_pmiss_val +#if defined key_iomput +#if defined key_xios2 + ! get missing value + CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) + pmiss_val = ztmp_pmiss_val +#endif +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/IOM/iom_def.F90 b/V4.0/nemo_sources/src/OCE/IOM/iom_def.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cf2232a578da0d82ddf55499cb084c8956aadab3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/IOM/iom_def.F90 @@ -0,0 +1,85 @@ +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 + LOGICAL :: lsgl !: Single process or access + 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: iom_def.F90 13280 2020-07-09 11:53:42Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE iom_def \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/IOM/iom_nf90.F90 b/V4.0/nemo_sources/src/OCE/IOM/iom_nf90.F90 new file mode 100644 index 0000000000000000000000000000000000000000..637396a0dc353dfb6dcc925fd9778b9598c776b0 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/IOM/iom_nf90.F90 @@ -0,0 +1,1649 @@ +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_gettime : read the time axis kvid in the file + !! 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 + USE mppbroadcast ! For broadcast of integers + + IMPLICIT NONE + PRIVATE + + PUBLIC iom_nf90_open , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_gettime, iom_nf90_rstput + PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt + PUBLIC iom_nf90_get_sgl, iom_nf90_rstput_sgl + + INTERFACE iom_nf90_get + MODULE PROCEDURE iom_nf90_g0d_sp + MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp + END INTERFACE + INTERFACE iom_nf90_get_sgl + MODULE PROCEDURE iom_nf90_g0d_sgl_sp + MODULE PROCEDURE iom_nf90_g0d_sgl_dp, iom_nf90_g123d_sgl_dp + END INTERFACE + INTERFACE iom_nf90_rstput +! MODULE PROCEDURE iom_nf90_rp0123d + MODULE PROCEDURE iom_nf90_rp0123d_dp + END INTERFACE + INTERFACE iom_nf90_rstput_sgl + MODULE PROCEDURE iom_nf90_rp0123d_sgl_dp + END INTERFACE + + LOGICAL :: lcommnotset2d = .TRUE. + INTEGER, DIMENSION(:), ALLOCATABLE :: icnt2d, idisp2d + LOGICAL :: lcommnotset3d = .TRUE. + INTEGER, DIMENSION(:), ALLOCATABLE :: icnt3d, idisp3d + LOGICAL :: lcommnotsetice = .TRUE. + INTEGER, DIMENSION(:), ALLOCATABLE :: icntice, idispice + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_nf90.F90 13061 2020-06-08 13:20:11Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev, ldsglread, ldsglwrite ) + !!--------------------------------------------------------------------- + !! *** 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 + LOGICAL , OPTIONAL :: ldsglread ! read on proc 0 only + LOGICAL , OPTIONAL :: ldsglwrite ! write on proc 0 only + + 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 + LOGICAL :: llopen ! control if we want to open the file depending on sglread + LOGICAL :: llsgl ! Broadcast kiomid and + INTEGER, DIMENSION(2) :: ibc ! Information to broadcast kiomid and if90id + !--------------------------------------------------------------------- + ! + 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 + ! + llopen = .TRUE. + llsgl = .FALSE. + IF (PRESENT(ldsglread).AND.(.NOT.ldwrt)) THEN + llsgl = ldsglread + IF (ldsglread) THEN + llopen=(nproc == 0) + ENDIF + ENDIF + IF (PRESENT(ldsglwrite).AND.(ldwrt)) THEN + llsgl = ldsglwrite + IF (ldsglwrite) THEN + llopen=(nproc == 0) + ENDIF + ENDIF + llclobber = ldwrt .AND. ln_clobber + IF( llopen ) THEN + 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 .AND. ( .NOT. llsgl ) ) 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) + IF (llsgl) THEN + ! define dimensions + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', jpiglo, idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', jpjglo, 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) + ELSE + ! 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) + ENDIF + 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 + ELSE + ! For the sglread/sgiwrite case we set kiomid a large number to force errors on file access + kiomid = 10012121 + ENDIF + ! + ! For single task reading/writing we need to fool the rest of the code to assume that + ! the file was opened on all tasks even though it wasn't + ! + IF (llsgl) THEN + IF ( nproc == 0 ) THEN + ibc(1) = kiomid + ibc(2) = if90id + ENDIF + CALL mpp_broadcast( ibc, 2, 0 ) + IF ( nproc /= 0 ) THEN + kiomid = ibc(1) + iom_file(kiomid)%name = TRIM(cdname) + iom_file(kiomid)%nfid = ibc(2) + iom_file(kiomid)%nvars = 0 + iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode + ENDIF + iom_file(kiomid)%lsgl = .TRUE. + ELSE + iom_file(kiomid)%lsgl = .FALSE. + 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) + IF (( .NOT.iom_file(kiomid)%lsgl ).OR. ( nproc == 0 )) THEN + CALL iom_nf90_check(NF90_CLOSE(iom_file(kiomid)%nfid), clinfo) + ENDIF + 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 + INTEGER, DIMENSION(3) :: ibc ! For sglread communication + REAL(wp), DIMENSION(2) :: zbc ! For sglread communication + !!----------------------------------------------------------------------- + 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 + ! + IF ( iom_file(kiomid)%lsgl ) THEN + IF ( nproc == 0 ) THEN + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! does the variable exist in the file + ELSE + llok = .FALSE. + ENDIF + ELSE + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! does the variable exist in the file + ENDIF + 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 + ! + ! + IF ( iom_file(kiomid)%lsgl ) THEN + IF ( nproc == 0 ) THEN + ibc(1) = iom_nf90_varid + ENDIF + CALL mpp_broadcast( ibc, 1, 0 ) + iom_nf90_varid = ibc(1) + IF ( ibc(1) /= -1 ) THEN + IF ( nproc == 0 ) THEN + ibc(1) = ivarid + ibc(2) = i_nvd + IF (iom_file(kiomid)%luld(kiv)) THEN + ibc(3) = 1 + ELSE + ibc(3) = 0 + ENDIF + zbc(1) = iom_file(kiomid)%scf(kiv) + zbc(2) = iom_file(kiomid)%ofs(kiv) + ENDIF + CALL mpp_broadcast( ibc, 3, 0 ) + CALL mpp_broadcast( zbc, 2, 0 ) + IF ( nproc /= 0 ) THEN + iom_file(kiomid)%nvars = kiv + iom_file(kiomid)%nvid(kiv) = ibc(1) + iom_file(kiomid)%ndims(kiv) = ibc(2) + iom_file(kiomid)%cn_var(kiv) = TRIM(cdvar) + i_nvd = ibc(2) + iom_file(kiomid)%luld(kiv) = (ibc(3) == 1) + iom_file(kiomid)%scf(kiv) = zbc(1) + iom_file(kiomid)%ofs(kiv) = zbc(2) + ENDIF + CALL mpp_broadcast( iom_file(kiomid)%dimsz(1:i_nvd,kiv), i_nvd, 0 ) + IF ( nproc /= 0 ) THEN + IF( PRESENT(kdimsz) ) THEN + IF( i_nvd == SIZE(kdimsz) ) THEN + kdimsz(:) = 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 + ENDIF + ENDIF + ENDIF + ! + END FUNCTION iom_nf90_varid + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_get + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(sp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_sp + + SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(dp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_dp + + SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & + & pv_r1d, pv_r2d, pv_r3d ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g123d *** + !! + !! ** Purpose : read a 1D/2D/3D variable with NF90 + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! iom identifier of the file + INTEGER , INTENT(in ) :: kvid ! Name of the variable + INTEGER , INTENT(in ) :: knbdim ! number of dimensions of the variable + INTEGER , DIMENSION(:) , INTENT(in ) :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis + INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + ! + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: ivid ! nf90 variable id + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g123d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + if90id = iom_file(kiomid)%nfid ! get back NetCDF file id + ivid = iom_file(kiomid)%nvid(kvid) ! get back NetCDF var id + ! + IF( PRESENT(pv_r1d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r1d(: ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r2d(kx1:kx2,ky1:ky2 ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r3d(kx1:kx2,ky1:ky2,:), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ENDIF + ! + END SUBROUTINE iom_nf90_g123d_dp + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_get_sgl + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_g0d_sgl_sp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d_sgl *** + !! + !! ** Purpose : read a scalar with NF90 + !! read on nproc=0 and broadcast data + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(sp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + REAL(dp), DIMENSION(1) :: zvar + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d_sgl , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + IF ( nproc == 0 ) THEN + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), zvar, start=kstart), clinfo ) + ENDIF + CALL mpp_broadcast(zvar,1,0) + pvar = zvar(1) + ! + END SUBROUTINE iom_nf90_g0d_sgl_sp + + SUBROUTINE iom_nf90_g0d_sgl_dp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d_sgl *** + !! + !! ** Purpose : read a scalar with NF90 + !! read on nproc=0 and broadcast data + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(dp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + REAL(dp), DIMENSION(1) :: zvar + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d_sgl , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + IF ( nproc == 0 ) THEN + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), zvar, start=kstart), clinfo ) + ENDIF + CALL mpp_broadcast(zvar,1,0) + pvar = zvar(1) + ! + END SUBROUTINE iom_nf90_g0d_sgl_dp + + SUBROUTINE iom_nf90_g123d_sgl_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & + & pv_r1d, pv_r2d, pv_r3d ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g123d_sgl_dp *** + !! + !! ** Purpose : read a 1D/2D/3D variable with NF90 + !! read on nproc=0 and scatter data + !! this subroutine reads and returns double-precision + !! variables + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- +#if defined key_mpp_mpi +include "mpif.h" +#endif + INTEGER , INTENT(in ) :: kiomid ! iom identifier of the file + INTEGER , INTENT(in ) :: kvid ! Name of the variable + INTEGER , INTENT(in ) :: knbdim ! number of dimensions of the variable + INTEGER , DIMENSION(:) , INTENT(in ) :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis + INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + ! + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: ivid ! nf90 variable id + REAL(dp), DIMENSION(:) , ALLOCATABLE :: zv_r1d ! global read field (1D case) + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: zv_r2d ! global read field (2D case) + REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: zv_r3d ! global read field (3D case) + REAL(dp), DIMENSION(:) , ALLOCATABLE :: zsend ! MPP send buffer + INTEGER, DIMENSION(4) :: istacntloc + INTEGER, DIMENSION(4*jpnij) :: istacntglo + INTEGER, DIMENSION(2:jpnij) :: ml_req + INTEGER, DIMENSION(:), ALLOCATABLE :: istart, icount + INTEGER :: jp, ist, ji, jj, jk, jpkl, isize, ip +#if defined key_mpp_mpi + INTEGER :: ml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend +#endif + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g123d_sgl , 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 + IF (nproc==0) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r1d, start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ENDIF + CALL mpp_broadcast( pv_r1d, SIZE(pv_r1d), 0 ) + ELSEIF( PRESENT(pv_r2d) ) THEN + istacntloc(1) = kstart(1) + istacntloc(2) = kcount(1) + istacntloc(3) = kstart(2) + istacntloc(4) = kcount(2) + istacntglo(:) = 0 + CALL mppgatherint( 0, 4, istacntloc, istacntglo ) + IF ( nproc == 0 ) THEN + ALLOCATE( istart(3), icount(3), zv_r2d(jpiglo,jpjglo) ) + istart(1) = 1 + istart(2) = 1 + istart(3) = kstart(3) + icount(1) = jpiglo + icount(2) = jpjglo + icount(3) = kcount(3) + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, zv_r2d, start = istart(1:knbdim), & + & count = icount(1:knbdim)), clinfo ) + isize = 0 + DO jp = 2, jpnij + ist = ( jp - 1 ) * 4 + isize = isize + istacntglo(ist+2) * istacntglo(ist+4) + ENDDO + ALLOCATE( zsend(isize) ) + isize=0 + ip = 0 + DO jp = 2, jpnij + ist = ( jp - 1 ) * 4 + DO jj = istacntglo(ist+3), istacntglo(ist+3)+istacntglo(ist+4)-1 + DO ji = istacntglo(ist+1), istacntglo(ist+1)+istacntglo(ist+2)-1 + ip = ip + 1 + zsend(ip) = zv_r2d(ji,jj) + ENDDO + ENDDO + ENDDO + isize = 0 + DO jp = 2, jpnij + ist = ( jp - 1 ) * 4 + CALL mppsend_dp( 11, zsend(isize+1), istacntglo(ist+2) * istacntglo(ist+4), jp - 1, ml_req(jp) ) + isize = isize + istacntglo(ist+2) * istacntglo(ist+4) + ENDDO + pv_r2d(kx1:kx2,ky1:ky2) = zv_r2d( kstart(1):(kstart(1)+kcount(1)-1), kstart(2):(kstart(2)+kcount(2)-1) ) +#if defined key_mpp_mpi + DO jp = 2, jpnij + CALL mpi_wait(ml_req(jp), ml_stat, ml_err) + ENDDO +#endif + DEALLOCATE( istart, icount, zv_r2d, zsend ) + ELSE + CALL mpprecv_dp( 11, pv_r2d(kx1:kx2,ky1:ky2), kcount(1) * kcount(2), 0 ) + ENDIF + ELSEIF( PRESENT(pv_r3d) ) THEN + istacntloc(1) = kstart(1) + istacntloc(2) = kcount(1) + istacntloc(3) = kstart(2) + istacntloc(4) = kcount(2) + istacntglo(:) = 0 + jpkl = SIZE(pv_r3d,3) + CALL mppgatherint( 0, 4, istacntloc, istacntglo ) + IF ( nproc == 0 ) THEN + ALLOCATE( istart(4), icount(4), zv_r3d(jpiglo,jpjglo,jpkl) ) + istart(1) = 1 + istart(2) = 1 + istart(3) = 1 + istart(4) = kstart(4) + icount(1) = jpiglo + icount(2) = jpjglo + icount(3) = jpkl + icount(4) = kcount(4) + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, zv_r3d, start = istart(1:knbdim), & + & count = icount(1:knbdim)), clinfo ) + isize = 0 + DO jp = 2, jpnij + ist = ( jp - 1 ) * 4 + isize = isize + istacntglo(ist+2) * istacntglo(ist+4) * jpkl + ENDDO + ALLOCATE( zsend(isize) ) + isize=0 + ip = 0 + DO jp = 2, jpnij + ist = ( jp - 1 ) * 4 + DO jk = 1, jpkl + DO jj = istacntglo(ist+3), istacntglo(ist+3)+istacntglo(ist+4)-1 + DO ji = istacntglo(ist+1), istacntglo(ist+1)+istacntglo(ist+2)-1 + ip = ip + 1 + zsend(ip) = zv_r3d(ji,jj,jk) + ENDDO + ENDDO + ENDDO + ENDDO + isize = 0 + DO jp = 2, jpnij + ist = (jp - 1 ) * 4 + CALL mppsend_dp( 12, zsend(isize+1), istacntglo(ist+2) * istacntglo(ist+4) * jpkl , jp - 1, ml_req(jp) ) + isize = isize + istacntglo(ist+2) * istacntglo(ist+4) * jpkl + ENDDO + pv_r3d(kx1:kx2,ky1:ky2,1:jpkl) = zv_r3d( kstart(1):kstart(1)+kcount(1)-1, kstart(2):kstart(2)+kcount(2)-1,1:jpkl) +#if defined key_mpp_mpi + DO jp = 2, jpnij + CALL mpi_wait(ml_req(jp), ml_stat, ml_err) + ENDDO +#endif + DEALLOCATE( istart, icount, zv_r3d, zsend ) + ELSE + CALL mpprecv_dp( 12, pv_r3d(kx1:kx2,ky1:ky2,1:jpkl), kcount(1) * kcount(2) * jpkl, 0 ) + ENDIF + ENDIF + ! + END SUBROUTINE iom_nf90_g123d_sgl_dp + + SUBROUTINE iom_nf90_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_chkatt *** + !! + !! ** Purpose : check existence of attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! attribute name + LOGICAL , INTENT( out) :: llok ! error code + INTEGER , INTENT( out), OPTIONAL & + & :: ksize ! attribute size + CHARACTER(len=*), INTENT(in ), OPTIONAL & + & :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: isize ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + ! check the variable exists in the file + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr + IF( llok ) & + ! check the variable has the attribute required + llok = NF90_Inquire_attribute(if90id, ivarid, cdatt, len=isize ) == nf90_noerr + ELSE + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt, len=isize ) == nf90_noerr + ENDIF + ! + IF( PRESENT(ksize) ) ksize = isize + ! + IF( .not. llok) & + CALL ctl_warn('iom_nf90_chkatt: no attribute '//cdatt//' found') + ! + END SUBROUTINE iom_nf90_chkatt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_getatt + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_getatt( kiomid, cdatt, katt0d, katt1d, patt0d, patt1d, cdatt0d, cdvar) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_getatt *** + !! + !! ** Purpose : read an attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT( out), OPTIONAL :: katt0d ! read scalar integer + INTEGER, DIMENSION(:) , INTENT( out), OPTIONAL :: katt1d ! read 1d array integer + REAL(wp) , INTENT( out), OPTIONAL :: patt0d ! read scalar real + REAL(wp), DIMENSION(:), INTENT( out), OPTIONAL :: patt1d ! read 1d array real + CHARACTER(len=*) , INTENT( out), OPTIONAL :: cdatt0d ! read character + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + LOGICAL :: llok ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + + IF ((.NOT.iom_file(kiomid)%lsgl).OR.(nproc==0)) THEN + + 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 + ! + + ENDIF + + IF (iom_file(kiomid)%lsgl) THEN + WRITE(0,*)'sgl in iom_nf90_getatt' +! CALL abort + 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 + !--------------------------------------------------------------------- + ! + IF (iom_file(kiomid)%lsgl.AND.(nproc/=0)) RETURN + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! is the variable in the file? + IF( .NOT. llok ) THEN + CALL ctl_warn('iom_nf90_putatt: no variable '//TRIM(cdvar)//' found' & + & , ' no attribute '//cdatt//' written' ) + RETURN + ENDIF + ELSE + ivarid = NF90_GLOBAL + ENDIF + llatt = NF90_Inquire_attribute(if90id, ivarid, cdatt, len = isize, xtype = itype ) == nf90_noerr + ! + ! trick: irec used to know if the file is in define mode or not + lldata = iom_file(kiomid)%irec /= -1 ! default: go back in define mode if in data mode + IF( lldata .AND. llatt ) THEN ! attribute already there. Do we really need to go back in define mode? + ! do we have the appropriate type? + IF(PRESENT( katt0d) .OR. PRESENT( katt1d)) llok = itype == NF90_INT + IF(PRESENT( patt0d) .OR. PRESENT( patt1d)) llok = itype == NF90_DOUBLE + IF(PRESENT(cdatt0d) ) llok = itype == NF90_CHAR + ! and do we have the appropriate size? + IF(PRESENT( katt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( katt1d)) llok = llok .AND. isize == SIZE(katt1d) + IF(PRESENT( patt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( patt1d)) llok = llok .AND. isize == SIZE(patt1d) + IF(PRESENT(cdatt0d)) llok = llok .AND. isize == LEN_TRIM(cdatt0d) + ! + lldata = .NOT. llok + ENDIF + ! + clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + IF(lldata) CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ! leave data mode to define mode + ! + IF(PRESENT( katt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt0d) , clinfo) + IF(PRESENT( katt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt1d) , clinfo) + IF(PRESENT( patt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt0d) , clinfo) + IF(PRESENT( patt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt1d) , clinfo) + IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = trim(cdatt0d)), clinfo) + ! + IF(lldata) CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo) ! leave define mode to data mode + ! + END SUBROUTINE iom_nf90_putatt + + SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & + & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rstput *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in) :: cdvar ! variable name + INTEGER , INTENT(in) :: kvid ! variable id + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) + REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field + REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field + REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field + REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field + ! + INTEGER :: idims ! number of dimension + INTEGER :: idvar ! variable id + INTEGER :: jd ! dimension loop counter + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER, DIMENSION(4) :: idimsz ! dimensions size + INTEGER, DIMENSION(4) :: idimid ! dimensions id + CHARACTER(LEN=256) :: clinfo ! info character + 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_dp + + SUBROUTINE iom_nf90_rp0123d_sgl_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & + & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rp0123d_sgl_dp *** + !! + !! ** Purpose : write data on a single process + !!-------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in) :: cdvar ! variable name + INTEGER , INTENT(in) :: kvid ! variable id + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) + REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field + REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field + REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field + REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field + ! + INTEGER :: idims ! number of dimension + INTEGER :: idvar ! variable id + INTEGER :: jd ! dimension loop counter + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER, DIMENSION(4) :: idimsz ! dimensions size + INTEGER, DIMENSION(4) :: idimid ! dimensions id + CHARACTER(LEN=100) :: clinfo ! info character + CHARACTER(LEN= 12), DIMENSION(5) :: cltmp ! temporary character + INTEGER :: if90id ! nf90 file identifier + INTEGER :: idmy, idlv ! 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, DIMENSION(3) :: ibc ! For mpp broadcast + INTEGER :: idim3 ! vertical dim (numcat,jpk) + + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_rp0123d_sgl, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + if90id = iom_file(kiomid)%nfid + IF ( nproc == 0 ) THEN + ! + ! 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 + 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 + ! 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.EQ.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 + + ELSE + + IF( iom_file(kiomid)%nvars == 0 ) THEN + cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter', 'numcat ' /) + 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 /) + iom_file(kiomid)%dimsz(1, 1) = 0 + ENDIF + + IF( kvid <= 0 ) THEN + ! + IF( PRESENT(pv_r0d) ) THEN ; idims = 0 + ELSEIF( PRESENT(pv_r1d) ) THEN ; idims = 2 + ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 + ELSEIF( PRESENT(pv_r3d) ) THEN ; idims = 4 + ENDIF + idvar = iom_file(kiomid)%nvars + 1 + 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 + ELSE + idvar = kvid + ENDIF + + ENDIF + + + ! time step kwrite : write the variable + IF( kt == kwrite ) THEN + ! are we in write mode? + IF( iom_file(kiomid)%irec == -1 .and. ( nproc == 0 )) 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 + + ! 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 + IF (nproc==0) CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'nav_lon' , idmy ), clinfo) + CALL iom_nf90_rp0123d_sgl_2d ( if90id, idmy, REAL(glamt,dp) ) + IF (nproc==0) CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'nav_lat' , idmy ), clinfo) + CALL iom_nf90_rp0123d_sgl_2d ( if90id, idmy, REAL(gphit,dp) ) + IF ( nproc == 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) + !here + 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 + ibc(1:2) = iom_file(kiomid)%dimsz(1:2,1) + IF( SIZE(pv_r3d,3) == jpk ) THEN ; idim3 = 3 + ELSE ; idim3 = 5 + ENDIF + ibc(3) = iom_file(kiomid)%dimsz(1,idim3) + CALL mpp_broadcast( ibc, 3, 0) + ELSE + CALL mpp_broadcast( ibc, 3, 0) + iom_file(kiomid)%dimsz(1:2,1) = ibc(1:2) + iom_file(kiomid)%dimsz(1,3) = ibc(3) + iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1) + iom_file(kiomid)%dimsz(1 , 4) = 1 ! unlimited dimension + ENDIF + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' + ENDIF + ENDIF + + ! write the data + ! ============= + IF( PRESENT(pv_r0d) ) THEN + IF( nproc == 0 ) CALL iom_nf90_check(NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo) + ELSEIF( PRESENT(pv_r1d) ) THEN + IF( nproc == 0 ) CALL iom_nf90_check(NF90_PUT_VAR( if90id, idvar, pv_r1d( :) ), clinfo) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_rp0123d_sgl_2d ( if90id, idvar, pv_r2d ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_rp0123d_sgl_3d ( if90id, idvar, pv_r3d ) + 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_sgl_dp + + SUBROUTINE iom_nf90_rp0123d_sgl_2d( kdfile, kdvar, pfld2d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rstput *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- +#if defined key_mpp_mpi +include "mpif.h" +#endif + INTEGER , INTENT(in) :: kdfile ! netCDF id + INTEGER , INTENT(in) :: kdvar ! variable id + REAL(dp), DIMENSION(:,:) , INTENT(in) :: pfld2d ! written 2d field + ! + REAL(dp), ALLOCATABLE, DIMENSION(:) :: zsend, zrecv + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zrecv2d + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: jj, ji, jn, idx ! loop variables + INTEGER :: ierr, ip +#if defined key_mpp_mpi + INTEGER :: ml_reqs, ml_errs + INTEGER, DIMENSION(jpnij) :: ml_reqr + INTEGER :: ml_errr + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat +#endif + + clinfo = ' iom_nf90_rp0123d_sgl_2d' + + IF (lcommnotset2d) CALL iom_nf90_commset2d + +#if defined key_mpp_mpi + IF ( nproc == 0 ) THEN + ALLOCATE( zrecv( jpiglo * jpjglo ) ) + ALLOCATE( zrecv2d( jpiglo, jpjglo ) ) + zrecv2d(:,:) = 0.0_wp + DO jn = 1, jpnij + CALL mppirecv_dp( & + & 13, zrecv(idisp2d(jn)+1), icnt2d(jn), jn -1, ml_reqr(jn) ) + ENDDO + ENDIF + ALLOCATE( zsend( icnt2d(nproc+1) )) + ip = 0 + DO jj = nldj, nlej + DO ji = nldi, nlei + ip = ip + 1 + zsend(ip) = pfld2d(ji,jj) + ENDDO + ENDDO + CALL mppsend_dp( 13, zsend, icnt2d(nproc+1), 0, ml_reqs ) +#else + zrecv(:) = zsend(:) +#endif + IF (nproc==0) THEN + idx = 0 + DO jn = 1, jpnij +#if defined key_mpp_mpi + CALL mpi_waitany( jpnij, ml_reqr, ip, MPI_STATUS_IGNORE, ml_errr ) +#else + ip = 1 +#endif + idx = idisp2d(ip) + DO jj = nldjt(ip), nlejt(ip) + DO ji = nldit(ip), nleit(ip) + idx=idx+1 + zrecv2d( ji + nimppt(ip) - 1, jj + njmppt(ip) -1 ) = zrecv(idx) + ENDDO + ENDDO + ENDDO + ENDIF + +#if defined key_mpp_mpi + CALL mpi_wait(ml_reqs, ml_stat, ml_errs) +#endif + DEALLOCATE( zsend ) + + IF ( nproc == 0 ) THEN + CALL iom_nf90_check(NF90_PUT_VAR( kdfile, kdvar, zrecv2d ), clinfo) + DEALLOCATE( zrecv2d ) + DEALLOCATE( zrecv ) + ENDIF + + END SUBROUTINE iom_nf90_rp0123d_sgl_2d + + SUBROUTINE iom_nf90_rp0123d_sgl_3d( kdfile, kdvar, pfld3d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rstput *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- +#if defined key_mpp_mpi +include "mpif.h" +#endif + INTEGER , INTENT(in) :: kdfile ! netCDF id + INTEGER , INTENT(in) :: kdvar ! variable id + REAL(dp), DIMENSION(:,:,:) , INTENT(in) :: pfld3d ! written 3d field + ! + REAL(dp), ALLOCATABLE, DIMENSION(:) :: zsend, zrecv + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zrecv3d + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: jj, ji, jk, jn, idx ! loop variables + INTEGER :: ierr, ip + INTEGER :: jpkl + INTEGER, DIMENSION(jpnij) :: ildisp3d, ilcnt3d +#if defined key_mpp_mpi + INTEGER :: ml_reqs, ml_errs + INTEGER, DIMENSION(jpnij) :: ml_reqr + INTEGER :: ml_errr + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat +#endif + + clinfo = ' iom_nf90_rp0123d_sgl_3d' + + jpkl = SIZE(pfld3d,3) + IF (jpkl==jpk) THEN + IF (lcommnotset3d) CALL iom_nf90_commset3d + ildisp3d(:)=idisp3d(:) + ilcnt3d(:)=icnt3d(:) + ELSE + IF (lcommnotsetice) CALL iom_nf90_commsetice(jpkl) + ildisp3d(:)=idispice(:) + ilcnt3d(:)=icntice(:) + ENDIF + +#if defined key_mpp_mpi + IF ( nproc == 0 ) THEN + ALLOCATE( zrecv( jpiglo * jpjglo * jpkl) ) + ALLOCATE( zrecv3d( jpiglo, jpjglo, jpkl ) ) + zrecv3d(:,:,:) = 0.0_wp + DO jn = 1, jpnij + CALL mppirecv_dp( & + & 13, zrecv(ildisp3d(jn)+1), ilcnt3d(jn), jn -1, ml_reqr(jn) ) + ENDDO + ENDIF + ALLOCATE( zsend( ilcnt3d(nproc+1) )) + ip = 0 + DO jk = 1, jpkl + DO jj = nldj, nlej + DO ji = nldi, nlei + ip = ip + 1 + zsend(ip) = pfld3d(ji,jj,jk) + ENDDO + ENDDO + ENDDO + CALL mppsend_dp( 13, zsend, ilcnt3d(nproc+1), 0, ml_reqs ) +#else + zrecv(:) = zsend(:) +#endif + IF (nproc==0) THEN + idx = 0 + DO jn = 1, jpnij +#if defined key_mpp_mpi + CALL mpi_waitany( jpnij, ml_reqr, ip, MPI_STATUS_IGNORE, ml_errr ) +#else + ip = 1 +#endif + idx = ildisp3d(ip) + DO jk = 1, jpkl + DO jj = nldjt(ip), nlejt(ip) + DO ji = nldit(ip), nleit(ip) + idx=idx+1 + zrecv3d( ji + nimppt(ip) - 1, jj + njmppt(ip) -1, jk ) = zrecv(idx) + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + +#if defined key_mpp_mpi + CALL mpi_wait(ml_reqs, ml_stat, ml_errs) +#endif + DEALLOCATE( zsend ) + + IF ( nproc == 0 ) THEN + CALL iom_nf90_check(NF90_PUT_VAR( kdfile, kdvar, zrecv3d ), clinfo) + DEALLOCATE( zrecv3d ) + DEALLOCATE( zrecv ) + ENDIF + + END SUBROUTINE iom_nf90_rp0123d_sgl_3d + + SUBROUTINE iom_nf90_commset2d + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_commset2d *** + !! + !! ** Purpose : Setup communcation + !!-------------------------------------------------------------------- + INTEGER :: jn, n2d + + ALLOCATE(icnt2d(jpnij),idisp2d(jpnij)) + + icnt2d(:)=0 + + DO jn = 1, jpnij + n2d = ( nleit(jn) - nldit(jn) + 1 ) * ( nlejt(jn) - nldjt(jn) + 1 ) + icnt2d(jn) = n2d + ENDDO + + idisp2d(1) = 0 + DO jn = 2, jpnij + idisp2d(jn) = icnt2d(jn-1) + idisp2d(jn-1) + ENDDO + + lcommnotset2d = .FALSE. + + END SUBROUTINE iom_nf90_commset2d + + SUBROUTINE iom_nf90_commset3d + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_commset3d *** + !! + !! ** Purpose : Setup communcation + !!-------------------------------------------------------------------- + INTEGER :: jn, n2d + + ALLOCATE(icnt3d(jpnij),idisp3d(jpnij)) + + icnt3d(:)=0 + + DO jn = 1, jpnij + n2d = ( nleit(jn) - nldit(jn) + 1 ) * ( nlejt(jn) - nldjt(jn) + 1 ) + icnt3d(jn) = n2d * jpk + ENDDO + + idisp3d(1) = 0 + DO jn = 2, jpnij + idisp3d(jn) = icnt3d(jn-1) + idisp3d(jn-1) + ENDDO + + lcommnotset3d = .FALSE. + + END SUBROUTINE iom_nf90_commset3d + + SUBROUTINE iom_nf90_commsetice(jpkl) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_commsetice *** + !! + !! ** Purpose : Setup communcation + !!-------------------------------------------------------------------- + INTEGER, INTENT(IN) :: jpkl + INTEGER :: jn, n2d + + ALLOCATE(icntice(jpnij),idispice(jpnij)) + + icntice(:)=0 + + DO jn = 1, jpnij + n2d = ( nleit(jn) - nldit(jn) + 1 ) * ( nlejt(jn) - nldjt(jn) + 1 ) + icntice(jn) = n2d * jpkl + ENDDO + + idispice(1) = 0 + DO jn = 2, jpnij + idispice(jn) = icntice(jn-1) + idispice(jn-1) + ENDDO + + lcommnotsetice = .FALSE. + + END SUBROUTINE iom_nf90_commsetice + + 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 + + SUBROUTINE iom_nf90_gettime( kiomid, kvid, ptime, cdunits, cdcalendar ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_gettime *** + !! + !! ** Purpose : read the time axis kvid in the file with NF90 + !!-------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(wp), DIMENSION(:) , INTENT( out) :: ptime ! the time axis + CHARACTER(len=*), OPTIONAL, INTENT( out) :: cdunits ! units attribute + CHARACTER(len=*), OPTIONAL, INTENT( out) :: cdcalendar ! calendar attribute + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_gettime, 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), ptime(:), & + & start=(/ 1 /), count=(/ iom_file(kiomid)%dimsz(1, kvid) /)), clinfo) + IF ( PRESENT(cdunits) ) THEN + CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "units", & + & values=cdunits), clinfo) + ENDIF + IF ( PRESENT(cdcalendar) ) THEN + CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "calendar", & + & values=cdcalendar), clinfo) + ENDIF + ! + END SUBROUTINE iom_nf90_gettime + + + !!====================================================================== +END MODULE iom_nf90 diff --git a/V4.0/nemo_sources/src/OCE/IOM/prtctl.F90 b/V4.0/nemo_sources/src/OCE/IOM/prtctl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bd96dc649186107f20f3895170cd6e55f81812c9 --- /dev/null +++ b/V4.0/nemo_sources/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: prtctl.F90 13412 2020-08-19 08:20:28Z gsamson $ + !! 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(dp), 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(dp), 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/IOM/restart.F90 b/V4.0/nemo_sources/src/OCE/IOM/restart.F90 new file mode 100644 index 0000000000000000000000000000000000000000..03ae96472ad577ae9e8e37da1c0077fc210b2fdf --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/IOM/restart.F90 @@ -0,0 +1,350 @@ +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 sbc_oce ! only nn_fsbc + 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, ymds2ju ! 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 + + LOGICAL, PUBLIC :: ln_writerst = .TRUE. + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: restart.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rst_opn( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_opn *** + !! + !! ** Purpose : + initialization (should be read in the namelist) of nitrst + !! + open the restart when we are one time step before nitrst + !! - restart header is defined when kt = nitrst-1 + !! - restart data are written when kt = nitrst + !! + define lrst_oce to .TRUE. when we need to define or write the restart + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + INTEGER :: iyear, imonth, iday + REAL (wp) :: zsec + REAL (wp) :: zfjulday + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=128) :: 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 + INTEGER :: inyear, inmonth, inday, inhour, inmin, insec, idt05 + REAL(wp) :: zjulnow, zjul1st, zjuldif, zjulrst, znsec + !!---------------------------------------------------------------------- + ! + 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_rsttime ) THEN + inyear = ndate0 / 10000 + inmonth = ( ndate0 - (inyear * 10000) ) / 100 + inday = ndate0 - (inyear * 10000) - ( inmonth * 100 ) + + inhour = ntime0 / 100 + inmin = ( ntime0 - nhour * 100 ) + + CALL ymds2ju( inyear, inmonth, inday, inhour*3600._wp+inmin*60._wp, zjulrst ) + zjulrst = zjulrst + nitrst * rn_rdt / 86400.0_wp + CALL ju2ymds( zjulrst, inyear, inmonth, inday, znsec ) + inhour = INT( znsec / 3600_wp ) + inmin = INT( ( znsec - inhour * 3600_wp ) / 60.0_wp ) + insec = INT( znsec - inhour * 3600_wp - inmin * 60.0_wp ) + WRITE(clkt,'(I4.4,I2.2,I2.2,A,3I2.2)') inyear, inmonth, inday, & + & '_', inhour, inmin, insec + ELSEIF ( 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 +#if defined key_xios2 + 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 ) +#endif +#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 + IF ( nn_slimrst == 0 .OR. kt >= nitend - nn_fsbc ) 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 ) + ENDIF + ! + 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 + + 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 + INTEGER :: jk + REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d + !!---------------------------------------------------------------------- + + CALL rst_read_open ! open restart for reading (if not already opened) + + ! 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( nn_slimrstin == 0 .AND. 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbc_lnk_multi_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/lbc_lnk_multi_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c7400c4cdde4968d3970cd7b40fd5a0b2083f662 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbc_lnk_multi_generic.h90 @@ -0,0 +1,112 @@ +#if defined SINGLE_PRECISION +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j) +# define PTR_TYPE TYPE(PTR_2D_sp) +# define PTR_ptab pt2d +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k) +# define PTR_TYPE TYPE(PTR_3D_sp) +# define PTR_ptab pt3d +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k,l) +# define PTR_TYPE TYPE(PTR_4D_sp) +# define PTR_ptab pt4d +# endif +# define PRECISION sp +#else +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j) +# define PTR_TYPE TYPE(PTR_2D_dp) +# define PTR_ptab pt2d +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k) +# define PTR_TYPE TYPE(PTR_3D_dp) +# define PTR_ptab pt3d +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k,l) +# define PTR_TYPE TYPE(PTR_4D_dp) +# define PTR_ptab pt4d +# endif +# define PRECISION dp +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_ext_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_ext_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..4740ff2562cb2402ff02d570ddb4d3f088b423ab --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_ext_generic.h90 @@ -0,0 +1,164 @@ +! !== 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 SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# define PRECISION sp +#else +# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# define PRECISION dp +#endif + + 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 PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef NAT_IN +#undef SGN_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..348ae2fea19bedbc2241f742652a75038458afd6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_generic.h90 @@ -0,0 +1,198 @@ +#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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# else +# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# endif +#endif + +# if defined SINGLE_PRECISION +# define PRECISION sp +# else +# define PRECISION dp +# 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 PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef NAT_IN +#undef SGN_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_nogather_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_nogather_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..70bdc0408a7d98cfdd517775ec8039c8027e4fe1 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @@ -0,0 +1,382 @@ +#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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) +# else +# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) +# endif +# 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) +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) +# else +# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) +# endif +# endif +# ifdef SINGLE_PRECISION +# define PRECISION sp +# else +# define PRECISION dp +# 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 PRECISION +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbclnk.F90 b/V4.0/nemo_sources/src/OCE/LBC/lbclnk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0307b23652e4c2c1177c9297a66d612080cbdda7 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbclnk.F90 @@ -0,0 +1,407 @@ +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_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp + MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp + END INTERFACE + INTERFACE lbc_lnk_ptr + MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp + MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp + END INTERFACE + INTERFACE lbc_lnk_multi + MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp + MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp + END INTERFACE + ! + INTERFACE lbc_lnk_icb + MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp + END INTERFACE + + INTERFACE mpp_nfd + MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp + MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp + MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp + MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp + + 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: lbclnk.F90 13350 2020-07-28 12:28:29Z smueller $ + !! 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 + !! + !!---------------------------------------------------------------------- + + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define DIM_2d +# define ROUTINE_LOAD load_ptr_2d_sp +# define ROUTINE_MULTI lbc_lnk_2d_multi_sp +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_2d + +# define DIM_3d +# define ROUTINE_LOAD load_ptr_3d_sp +# define ROUTINE_MULTI lbc_lnk_3d_multi_sp +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_3d + +# define DIM_4d +# define ROUTINE_LOAD load_ptr_4d_sp +# define ROUTINE_MULTI lbc_lnk_4d_multi_sp +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_4d +# undef SINGLE_PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + +# define DIM_2d +# define ROUTINE_LOAD load_ptr_2d_dp +# define ROUTINE_MULTI lbc_lnk_2d_multi_dp +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_2d + +# define DIM_3d +# define ROUTINE_LOAD load_ptr_3d_dp +# define ROUTINE_MULTI lbc_lnk_3d_multi_dp +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_3d + +# define DIM_4d +# define ROUTINE_LOAD load_ptr_4d_dp +# define ROUTINE_MULTI lbc_lnk_4d_multi_dp +# 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 ==! + ! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define DIM_2d +# define ROUTINE_LNK mpp_lnk_2d_sp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_2d_ptr_sp +# 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_sp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_3d_ptr_sp +# 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_sp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_4d_ptr_sp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# undef MULTI +# undef DIM_4d +# undef SINGLE_PRECISION + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define DIM_2d +# define ROUTINE_LNK mpp_lnk_2d_dp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_2d_ptr_dp +# 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_dp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_3d_ptr_dp +# 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_dp +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_4d_ptr_dp +# 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 ==! + ! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define DIM_2d +# define ROUTINE_NFD mpp_nfd_2d_sp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_2d_ptr_sp +# 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_sp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_3d_ptr_sp +# 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_sp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_4d_ptr_sp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_4d +# undef SINGLE_PRECISION + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define DIM_2d +# define ROUTINE_NFD mpp_nfd_2d_dp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_2d_ptr_dp +# 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_dp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_3d_ptr_dp +# 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_dp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_4d_ptr_dp +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_4d + + + + !!====================================================================== + !!--------------------------------------------------------------------- + !! *** 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. + !! + !!---------------------------------------------------------------------- +# define SINGLE_PRECISION +# define ROUTINE_LNK mpp_lbc_north_icb_sp +# include "mpp_lbc_north_icb_generic.h90" +# undef ROUTINE_LNK +# undef SINGLE_PRECISION +# define ROUTINE_LNK mpp_lbc_north_icb_dp +# include "mpp_lbc_north_icb_generic.h90" +# undef ROUTINE_LNK + + + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + +# define SINGLE_PRECISION +# define ROUTINE_LNK mpp_lnk_2d_icb_sp +# include "mpp_lnk_icb_generic.h90" +# undef ROUTINE_LNK +# undef SINGLE_PRECISION +# define ROUTINE_LNK mpp_lnk_2d_icb_dp +# include "mpp_lnk_icb_generic.h90" +# undef ROUTINE_LNK + +END MODULE lbclnk \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lbcnfd.F90 b/V4.0/nemo_sources/src/OCE/LBC/lbcnfd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..726fc80aa00c029d8809396231847b3d159a9b20 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lbcnfd.F90 @@ -0,0 +1,285 @@ +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_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp + MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp + MODULE PROCEDURE lbc_nfd_2d_ext_sp + MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp + MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp + MODULE PROCEDURE lbc_nfd_2d_ext_dp + END INTERFACE + ! + INTERFACE lbc_nfd_nogather +! ! Currently only 4d array version is needed + MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp + MODULE PROCEDURE lbc_nfd_nogather_4d_sp + MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp + MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp + MODULE PROCEDURE lbc_nfd_nogather_4d_dp + MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp +! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr + END INTERFACE + + TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) + REAL(dp), DIMENSION (:,:) , POINTER :: pt2d + END TYPE PTR_2D_dp + TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) + REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d + END TYPE PTR_3D_dp + TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) + REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_dp + + TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) + REAL(sp), DIMENSION (:,:) , POINTER :: pt2d + END TYPE PTR_2D_sp + TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) + REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d + END TYPE PTR_3D_sp + TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) + REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_sp + + + 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: lbcnfd.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 + !!---------------------------------------------------------------------- + ! + ! !== SINGLE PRECISION VERSIONS + ! + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define SINGLE_PRECISION +# define DIM_2d +# define ROUTINE_NFD lbc_nfd_2d_sp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_2d_ptr_sp +# 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_sp +# 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_sp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_3d_ptr_sp +# 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_sp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_4d_ptr_sp +# 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_sp +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp +# 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_sp +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp +# 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_sp +# 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 +# undef SINGLE_PRECISION + + !!---------------------------------------------------------------------- + ! + ! !== DOUBLE PRECISION VERSIONS + ! + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define DIM_2d +# define ROUTINE_NFD lbc_nfd_2d_dp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_2d_ptr_dp +# 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_dp +# 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_dp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_3d_ptr_dp +# 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_dp +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_4d_ptr_dp +# 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_dp +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp +# 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_dp +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp +# 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_dp +# 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/lib_mpp.F90 b/V4.0/nemo_sources/src/OCE/LBC/lib_mpp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..512bd8d36222c5ad0d728144ba49057240e3b3ac --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/lib_mpp.F90 @@ -0,0 +1,1655 @@ +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 + !! mppgatherint : gather integers on a single task + !!---------------------------------------------------------------------- + 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 mppsend_sp, mpprecv_sp + PUBLIC mppsend_dp, mpprecv_dp + PUBLIC mpp_report + PUBLIC tic_tac + PUBLIC mppgatherint + PUBLIC mppintbcast + PUBLIC mppirecv_dp +#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 + MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp + MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp + END INTERFACE + INTERFACE mpp_max + MODULE PROCEDURE mppmax_a_int, mppmax_int + MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp + MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp + END INTERFACE + INTERFACE mpp_sum + MODULE PROCEDURE mppsum_a_int, mppsum_int + MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd + MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp + MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp + END INTERFACE + INTERFACE mpp_minloc + MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp + MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp + END INTERFACE + INTERFACE mpp_maxloc + MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp + MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp + END INTERFACE + + !! ========================= !! + !! 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(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp + REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp + + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend + + LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms + LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_mpp.F90 13635 2020-10-19 14:14:38Z mathiot $ + !! 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 (precision agnostic) + !! + !!---------------------------------------------------------------------- + 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 + IF (wp == dp) THEN + CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) + ELSE + CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) + END IF +#endif + ! + END SUBROUTINE mppsend + + + SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend_dp *** + !! + !! ** Purpose : Send messag passing array (double-precision) + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(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_dp + + + SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend_sp *** + !! + !! ** Purpose : Send messag passing array (single-precision) + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(in ) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) +#endif + ! + END SUBROUTINE mppsend_sp + + + SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array (precision agnostic) + !! + !!---------------------------------------------------------------------- + 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 + ! + IF (wp == dp) THEN + CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) + ELSE + CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) + END IF +#endif + ! + END SUBROUTINE mpprecv + + + SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array (double-precision) + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! +#if 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_dp + + + SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv_sp *** + !! + !! ** Purpose : Receive messag passing array (single-precision) + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! +#if 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_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) +#endif + ! + END SUBROUTINE mpprecv_sp + + + SUBROUTINE mppirecv_dp( ktyp, pmess, kbytes, ksource, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppirecv *** + !! + !! ** Purpose : Receive messag passing array (double-precision) + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + INTEGER , INTENT( out) :: md_req ! argument for isend + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! + + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source=mpi_any_source + IF(PRESENT(ksource)) THEN + use_source=ksource + END IF + + CALL mpi_irecv( pmess, kbytes, mpi_double_precision, use_source, ktyp, & + & mpi_comm_oce, md_req, iflag ) + ! + END SUBROUTINE mppirecv_dp + + 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 + IF (wp == dp) THEN + CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) + ELSE + CALL mpi_gather( ptab, itaille, mpi_real, pio, itaille , & + & mpi_real, kp , mpi_comm_oce, ierror ) + END IF +#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 + IF (wp == dp) THEN + CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) + ELSE + CALL mpi_scatter( pio, itaille, mpi_real, ptab, itaille , & + & mpi_real, kp , mpi_comm_oce, ierror ) + END IF +#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(dp), INTENT(in ), DIMENSION(:) :: y_in + REAL(wp), INTENT( out), DIMENSION(:) :: pout + LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine + INTEGER, INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ji, isz + INTEGER :: idvar + INTEGER :: ierr, ilocalcomm + COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp + !!---------------------------------------------------------------------- +#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 + INTEGER :: MPI_TYPE + !!---------------------------------------------------------------------- + +#if defined key_mpp_mpi + if( wp == dp ) then + MPI_TYPE = MPI_DOUBLE_PRECISION + else if ( wp == sp ) then + MPI_TYPE = MPI_REAL + else + CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) + + end if + + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + + isz = SIZE(p_in) + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. ) + + idvar = -1 + DO ji = 1, nbdelay + IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji + END DO + IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) ) + + IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst + ! -------------------------- + IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence + IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one' + DEALLOCATE(todelay(idvar)%z1d) + ndelayid(idvar) = -1 ! do as if we had no restart + ELSE + ndelayid(idvar) = MPI_REQUEST_NULL + END IF + ENDIF + + IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce + ! -------------------------- + ALLOCATE(todelay(idvar)%z1d(isz)) + CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, 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_TYPE, 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_TYPE, 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 +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef SINGLE_PRECISION + !! + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +! +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_real_dp +# 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 +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef SINGLE_PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_real_dp +# 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 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 + + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define OPERATION_SUM +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_SUM + +# undef SINGLE_PRECISION + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define OPERATION_SUM +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_SUM + + !!---------------------------------------------------------------------- + !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d + !! + !!---------------------------------------------------------------------- + !! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define OPERATION_MINLOC +# define DIM_2d +# define ROUTINE_LOC mpp_minloc2d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_minloc3d_sp +# 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_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_maxloc3d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MAXLOC +# undef SINGLE_PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define OPERATION_MINLOC +# define DIM_2d +# define ROUTINE_LOC mpp_minloc2d_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_minloc3d_dp +# 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_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_maxloc3d_dp +# 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(dp), DIMENSION(ilen), INTENT(in) :: ydda + COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + INTEGER :: ji, ztmp ! local scalar + !!--------------------------------------------------------------------- + ! + ztmp = itype ! avoid compilation warning + ! + DO ji=1,ilen + ! Compute ydda + yddb using Knuth's trick. + zt1 = real(ydda(ji)) + real(yddb(ji)) + zerr = zt1 - real(ydda(ji)) + zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) & + + aimag(ydda(ji)) + aimag(yddb(ji)) + + ! The result is zt1 + zt2, after normalization. + yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),dp ) + END DO + ! + END SUBROUTINE DDPDD_MPI + + SUBROUTINE mppgatherint( kroot, kp, ktab, ktabglo ) + !!---------------------------------------------------------------------- + !! *** routine mppgatherint *** + !! + !! ** Purpose : Gather elements on kroot + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kroot ! Processor to receive the data. + INTEGER, INTENT(in ) :: kp ! Number of elements on each pe. + INTEGER, DIMENSION(kp), INTENT(in ) :: ktab ! Local array + INTEGER, DIMENSION(kp*jpnij), INTENT( out) :: ktabglo ! Global array (valid on kroot only). + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + CALL mpi_gather( ktab, kp, mpi_integer, ktabglo, kp, mpi_integer, kroot, mpi_comm_oce, ierror ) + ! + END SUBROUTINE mppgatherint + + SUBROUTINE mppintbcast( kroot, kp, ktab) + !!---------------------------------------------------------------------- + !! *** routine mppintbcast *** + !! + !! ** Purpose : Broadcast an integer array + !! + !!---------------------------------------------------------------------- + INTEGER :: kroot ! Processor to broadcast the data. + INTEGER :: kp ! Number of elements on each pe. + INTEGER, DIMENSION(kp), INTENT(inout) :: ktab ! Local array + INTEGER :: ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + CALL mpi_bcast (ktab, kp, mpi_integer, kroot, mpi_comm_oce, ierror ) + ! + END SUBROUTINE mppintbcast + + 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(dp), DIMENSION(2), SAVE :: tic_wt + REAL(dp), SAVE :: tic_ct = 0._dp + 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_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic + ELSE + waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac + tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) + ENDIF +#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 + + SUBROUTINE mppintbcast( kroot, kp, ktab) + INTEGER :: kroot ! Processor to receive the data. + INTEGER :: kp ! Number of elements on each pe. + INTEGER, DIMENSION(kp), INTENT(in ) :: ktab ! Local array + WRITE(*,*) 'mppintbcast: You should not have seen this print! error?' + END SUBROUTINE mppintbcast + + SUBROUTINE mppgatherint( kroot, kp, ktab, ktabglo ) + INTEGER :: kroot ! Processor to receive the data. + INTEGER :: kp ! Number of elements on each pe. + INTEGER, DIMENSION(kp), INTENT(in ) :: ktab ! Local array + INTEGER, DIMENSION(kp*jpnij), INTENT( out) :: ktabglo ! Global array (valid on kroot only). + WRITE(*,*) 'mppgatherint: You should not have seen this print! error?' + END SUBROUTINE mppgatherint + +#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) + ! +! ECMWF begin +! 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 +! ECMWF end + + ! + 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, cdact ) + !!---------------------------------------------------------------------- + !! *** 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=*),OPTIONAL,INTENT(in) :: cdact ! action specifier + ! + CHARACTER(len=80) :: clfile + CHARACTER(LEN=10) :: clfmt ! writing format + INTEGER :: iost + INTEGER :: idg ! number of digits + CHARACTER(len=10) :: ioact + !!---------------------------------------------------------------------- + ! + ! 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 + + ioact = 'READWRITE' + IF( PRESENT( cdact ) ) THEN + IF( cdact == 'READ' ) THEN + ioact = 'READ' + ELSEIF( cdact == 'WRITE' ) THEN + ioact = 'WRITE' + ELSEIF( cdact == 'READWRITE' ) THEN + ioact = 'READWRITE' + ELSE + WRITE(*, *) 'lib_mpp: Error in ctl_opn. Expected READ, WRITE or READWRITE instead of ', TRIM(cdact) + CALL mpi_abort( mpi_comm_world, 99 ) + 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, ACTION=ioact ) + 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, ACTION=ioact ) + ELSE + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost, ACTION=ioact ) + 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, ACTION=ioact ) + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_allreduce_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_allreduce_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..51bdd126d413e740761ac79805067b654b59ecf1 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_allreduce_generic.h90 @@ -0,0 +1,88 @@ +! !== IN: ptab is an array ==! +# if defined REAL_TYPE +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_real +# else +# define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_precision +# endif +# endif +# if defined INTEGER_TYPE +# define ARRAY_TYPE(i) INTEGER , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) INTEGER , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_integer +# endif +# if defined COMPLEX_TYPE +# define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_complex +# endif +# if defined DIM_0d +# define ARRAY_IN(i) ptab +# define I_SIZE(ptab) 1 +# endif +# if defined DIM_1d +# define ARRAY_IN(i) ptab(i) +# define I_SIZE(ptab) SIZE(ptab,1) +# endif +# if defined OPERATION_MAX +# define MPI_OPERATION mpi_max +# endif +# if defined OPERATION_MIN +# define MPI_OPERATION mpi_min +# endif +# if defined OPERATION_SUM +# define MPI_OPERATION mpi_sum +# endif +# if defined OPERATION_SUM_DD +# define MPI_OPERATION mpi_sumdd +# endif + + SUBROUTINE ROUTINE_ALLREDUCE( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator +#if defined key_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..6f2953301072f7343a6ccb6b18b9d58d182f811b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 @@ -0,0 +1,103 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define MPI_TYPE MPI_REAL +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# endif + + SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W -points + REAL(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(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(PRECISION), 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.0_wp + znorthloc_e(:,:) = 0.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_TYPE, & + & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & + & 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 ROUTINE_LNK + +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE +# undef MPI_TYPE \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..106f298bd52b25bc68d1771749f827eac50688b7 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_generic.h90 @@ -0,0 +1,420 @@ +#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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# else +# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# endif +# 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 SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# 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(PRECISION) :: zland + INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend + REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos + REAL(PRECISION), 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 SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) + IF( llsend_ea ) CALL SENDROUTINE( 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 RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) + IF( llrecv_ea ) CALL RECVROUTINE( 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 SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) + IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) + ! blocking receive of the southern/northern halo + IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) + IF( llrecv_no ) CALL RECVROUTINE( 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_icb_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_icb_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..187abec82fc2353814c8838cca82a09f309d2e40 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_lnk_icb_generic.h90 @@ -0,0 +1,213 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define LBCNORTH mpp_lbc_north_icb_sp +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define LBCNORTH mpp_lbc_north_icb_dp +# endif + + SUBROUTINE ROUTINE_LNK( cdname, pt2d, cd_type, psgn, kexti, kextj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! 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(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + REAL(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(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew + !!---------------------------------------------------------------------- + ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area + iprecj = nn_hls + kextj + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( l_Iperio ) THEN + pt2d(1-kexti: 1 ,:) = pt2d(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.0_wp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0.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.0_wp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0.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 LBCNORTH ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + END SELECT + ! + ENDIF + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + 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 ) + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) + CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) + CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) + CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) + CALL RECVROUTINE( 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 SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) + CALL RECVROUTINE( 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 SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) + CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) + CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) + CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) + CALL RECVROUTINE( 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 SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) + CALL RECVROUTINE( 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 ROUTINE_LNK + +# undef LBCNORTH +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_loc_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_loc_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..2cb22f8e227ea73bd6439dc1f9c688eb25b2a896 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_loc_generic.h90 @@ -0,0 +1,118 @@ +!== IN: ptab is an array ==! +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define MASK_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: MASK_IN(i,j,k) +# define PRECISION sp +# else +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define MASK_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: MASK_IN(i,j,k) +# define PRECISION dp +# endif + +# 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(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab + INDEX_TYPE(:) ! index of minimum in global frame + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + REAL(PRECISION) :: zmin ! local minimum + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(dp), 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 PRECISION +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mpp_nfd_generic.h90 b/V4.0/nemo_sources/src/OCE/LBC/mpp_nfd_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..2021c4f025e33c03830d3fb775194472c3169f58 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mpp_nfd_generic.h90 @@ -0,0 +1,339 @@ +#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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) +# else +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) +# endif +# 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 ==! +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# else +# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# endif +# 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 + +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define MPI_TYPE MPI_REAL +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# endif + + SUBROUTINE ROUTINE_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(PRECISION), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk + REAL(PRECISION), 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 SENDROUTINE( 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 RECVROUTINE(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_TYPE, & + & znorthgloio, ibuffsize, MPI_TYPE, 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 PRECISION +#undef MPI_TYPE +#undef SENDROUTINE +#undef RECVROUTINE +#undef ARRAY_TYPE +#undef NAT_IN +#undef SGN_IN +#undef ARRAY_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE +#undef LBC_ARG \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mppbroadcast.F90 b/V4.0/nemo_sources/src/OCE/LBC/mppbroadcast.F90 new file mode 100644 index 0000000000000000000000000000000000000000..830efc3c439abc1adeb69457d943ed6bd65695bf --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mppbroadcast.F90 @@ -0,0 +1,265 @@ +MODULE mppbroadcast + !!====================================================================== + !! *** MODULE mppbroadcast *** + !! NEMO: MPP broadcast routines + !!====================================================================== + + !!---------------------------------------------------------------------- + !! mpp_broadcast : Gather a real array on all processors + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & sp, dp, wp + USE par_oce, ONLY : & ! Ocean parameters + & jpnij +#if defined key_mpp_mpi + USE lib_mpp, ONLY : & ! MPP library + & mpi_comm_oce +#endif + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC & + & mpp_broadcast + + INTERFACE mpp_broadcast + MODULE PROCEDURE mpp_broadcast_real_sp, mpp_broadcast_real_dp, mpp_broadcast_int, & + & mpp_broadcast_char, mpp_broadcast_logical + END INTERFACE + +CONTAINS + + SUBROUTINE mpp_broadcast_real_sp( pvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_broadcast_real_sp *** + !! + !! ** Purpose : Broadcast a single-precision real array + !! + !! ** Method : MPI bcast + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !! + !! History : + !! ! 14-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kno + REAL(sp), DIMENSION(kno), INTENT(INOUT) :: & + & pvals + INTEGER, INTENT(IN) :: & + & kroot + + !! * Local declarations + INTEGER :: & + & ierr +#if defined key_mpp_mpi +include 'mpif.h' + + !----------------------------------------------------------------------- + ! Call the MPI library to do the gathering of the data + !----------------------------------------------------------------------- + CALL mpi_bcast( pvals, kno, mpi_real, kroot, & + & mpi_comm_oce, ierr ) +#elif defined key_mpp_shmem + error "Only MPI support for MPP in NEMOVAR" +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- +#endif + + END SUBROUTINE mpp_broadcast_real_sp + + SUBROUTINE mpp_broadcast_real_dp( pvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_broadcast_real_dp *** + !! + !! ** Purpose : Broadcast a double-precision real array + !! + !! ** Method : MPI bcast + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !! + !! History : + !! ! 14-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kno + REAL(dp), DIMENSION(kno), INTENT(INOUT) :: & + & pvals + INTEGER, INTENT(IN) :: & + & kroot + + !! * Local declarations + INTEGER :: & + & ierr +#if defined key_mpp_mpi +include 'mpif.h' + + !----------------------------------------------------------------------- + ! Call the MPI library to do the gathering of the data + !----------------------------------------------------------------------- + CALL mpi_bcast( pvals, kno, mpi_double_precision, kroot, & + & mpi_comm_oce, ierr ) +#elif defined key_mpp_shmem + error "Only MPI support for MPP in NEMOVAR" +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- +#endif + + END SUBROUTINE mpp_broadcast_real_dp + + SUBROUTINE mpp_broadcast_int( kvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_broadcast_int *** + !! + !! ** Purpose : Broadcast an integer array + !! + !! ** Method : MPI bcast + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !! + !! History : + !! ! 14-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kno + INTEGER, DIMENSION(kno), INTENT(INOUT) :: & + & kvals + INTEGER, INTENT(IN) :: & + & kroot + + !! * Local declarations + INTEGER :: & + & ierr +#if defined key_mpp_mpi +include 'mpif.h' + + !----------------------------------------------------------------------- + ! Call the MPI library to do the gathering of the data + !----------------------------------------------------------------------- + CALL mpi_bcast( kvals, kno, mpi_integer, kroot, & + & mpi_comm_oce, ierr ) +#elif defined key_mpp_shmem + error "Only MPI support for MPP in NEMOVAR" +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- +#endif + + END SUBROUTINE mpp_broadcast_int + + SUBROUTINE mpp_broadcast_char( cvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_broadcast_char *** + !! + !! ** Purpose : Broadcast an character array + !! + !! ** Method : MPI bcast + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !! + !! History : + !! ! 14-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kno + CHARACTER, DIMENSION(kno), INTENT(INOUT) :: & + & cvals + INTEGER, INTENT(IN) :: & + & kroot + + !! * Local declarations + INTEGER :: & + & ierr +#if defined key_mpp_mpi +include 'mpif.h' + + !----------------------------------------------------------------------- + ! Call the MPI library to do the gathering of the data + !----------------------------------------------------------------------- + CALL mpi_bcast( cvals, kno, mpi_character, kroot, & + & mpi_comm_oce, ierr ) +#elif defined key_mpp_shmem + error "Only MPI support for MPP in NEMOVAR" +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- +#endif + + END SUBROUTINE mpp_broadcast_char + + SUBROUTINE mpp_broadcast_logical( lvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_broadcast_logical *** + !! + !! ** Purpose : Broadcast an logical array + !! + !! ** Method : MPI bcast + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !! + !! History : + !! ! 14-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kno + LOGICAL, DIMENSION(kno), INTENT(INOUT) :: & + & lvals + INTEGER, INTENT(IN) :: & + & kroot + + !! * Local declarations + INTEGER :: & + & ierr +#if defined key_mpp_mpi +include 'mpif.h' + + !----------------------------------------------------------------------- + ! Call the MPI library to do the gathering of the data + !----------------------------------------------------------------------- + CALL mpi_bcast( lvals, kno, mpi_logical, kroot, & + & mpi_comm_oce, ierr ) +#elif defined key_mpp_shmem + error "Only MPI support for MPP in NEMOVAR" +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- +#endif + + END SUBROUTINE mpp_broadcast_logical + +END MODULE mppbroadcast \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mppini.F90 b/V4.0/nemo_sources/src/OCE/LBC/mppini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..df055c20017d7d1af7879ce423520bf6ea17d94c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mppini.F90 @@ -0,0 +1,1319 @@ +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: mppini.F90 12737 2020-04-10 17:55:11Z jchanut $ + !! 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' ) + ! + ! Save jpni,jpnj input values + jpni_inp = jpni + jpnj_inp = jpnj + ! + 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(dp):: 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(dp), 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, jj, 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 + ! +#if defined key_xios2 + ! Only when using XIOS: XIOS does a domain decomposition only in bands (for IO performances). + ! XIOS is crashing if one of these bands contains only land-domains which have been suppressed. + ! -> solution (before a fix of xios): force to keep at least one land-domain by band of mpi domains + DO jj = 1, knbj + IF( COUNT( ldisoce(:,jj) ) == 0 ) ldisoce(1,jj) = .TRUE. ! for to keep 1st MPI domain in the row of domains + END DO +#endif + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LBC/mppwrite.F90 b/V4.0/nemo_sources/src/OCE/LBC/mppwrite.F90 new file mode 100644 index 0000000000000000000000000000000000000000..305e0518526eaefcaa45b72e260a51eedabe2a6c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LBC/mppwrite.F90 @@ -0,0 +1,143 @@ +MODULE mppwrite + !!====================================================================== + !! *** MODULE mppwrite *** + !! Ocean initialization : Optionally write out some infomation about the + !! parallel distribution + !!====================================================================== + !! History : 4.0 ! 2022-02 (K. Mogensen) initial vesion + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! mpp_write : Write out MPP information + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE iom ! nemo I/O library + USE in_out_manager ! I/O Manager + USE domwri ! For dom_uniq + USE nopenmp ! jj for openmp threads + USE lib_mpp ! for mppsync and mppstop + ! + IMPLICIT NONE + PRIVATE + + PUBLIC mpp_write ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2022) + !! $Id: $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE mpp_write + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_write *** + !! + !! ** Purpose : Write out MPP information + !! + !! ** Method : IOM + !! + !!---------------------------------------------------------------------- + ! + REAL(wp), DIMENSION(jpi,jpj) :: znum, znumi, znumj + REAL(dp), DIMENSION(jpi,jpj) :: zmsk + INTEGER :: inum, ji, jj, jk, itid, ithreads, jj1, jj2 + ! + ! Initialize arrays + znum(:,:) = 0 + znumi(:,:) = 0 + znumj(:,:) = 0 + zmsk(:,:) = 0 + ! + ! Open file + CALL iom_open ( 'nemo_model_mpi_decomposition', inum, ldwrt = .TRUE. ) + ! + ! MPP task numbers + CALL iom_rstput( 0, 0, inum, 'mpitasks', REAL(jpnij,wp) ) + CALL iom_rstput( 0, 0, inum, 'mpitasksi', REAL(jpni,wp) ) + CALL iom_rstput( 0, 0, inum, 'mpitasksj', REAL(jpnj,wp) ) + CALL iom_rstput( 0, 0, inum, 'mpitasksi_inp', REAL(jpni_inp,wp) ) + CALL iom_rstput( 0, 0, inum, 'mpitasksj_inp', REAL(jpnj_inp,wp) ) + ! + ! Area number (interior points only) + znum(nldi:nlei,nldj:nlej) = narea + CALL iom_rstput( 0, 0, inum, 'mpip1', znum ) + ! + ! Global index (for interior points only) + DO jj = nldj, nlej + DO ji = nldi, nlei + znum(ji,jj) = mig(ji) + ( mjg(jj) - 1 ) *jpiglo + znumi(ji,jj) = mig(ji) + znumj(ji,jj) = mjg(jj) + ENDDO + ENDDO + CALL iom_rstput( 0, 0, inum, 'gloind' , znum ) + CALL iom_rstput( 0, 0, inum, 'gloindi', znumi ) + CALL iom_rstput( 0, 0, inum, 'gloindj', znumj ) + ! + ! Local index (for interior points only) + jk = 0 + znum(:,:) = 0.0 + znumi(:,:) = 0.0 + znumj(:,:) = 0.0 + DO jj = nldj, nlej + DO ji = nldi, nlei + jk = jk + 1 + znum(ji,jj) = jk + znumi(ji,jj) = ji - nldi + 1 + znumj(ji,jj) = jj - nldj + 1 + ENDDO + ENDDO + CALL iom_rstput( 0, 0, inum, 'locind' , znum ) + CALL iom_rstput( 0, 0, inum, 'locindi', znumi ) + CALL iom_rstput( 0, 0, inum, 'locindj', znumj ) + ! + ! U mask inner + CALL dom_uniq( zmsk, 'T', pval = 0.0_wp ) + DO jj = nldj, nlej + DO ji = nldi, nlei + zmsk(ji,jj) = zmsk(ji,jj) * tmask(ji,jj,1) + ENDDO + ENDDO + CALL iom_rstput( 0, 0, inum, 'tmask_i', zmsk ) + ! + ! U mask inner + CALL dom_uniq( zmsk, 'U', pval = 0.0_wp ) + DO jj = nldj, nlej + DO ji = nldi, nlei + zmsk(ji,jj) = zmsk(ji,jj) * umask(ji,jj,1) + ENDDO + ENDDO + CALL iom_rstput( 0, 0, inum, 'umask_i', zmsk) + ! + ! V mask inner + CALL dom_uniq( zmsk, 'V', pval = 0.0_wp ) + DO jj = nldj, nlej + DO ji = nldi, nlei + zmsk(ji,jj) = zmsk(ji,jj) * vmask(ji,jj,1) + ENDDO + ENDDO + CALL iom_rstput( 0, 0, inum, 'vmask_i', zmsk ) + ! + ! Thread number + !$omp parallel private(itid,ithreads,jj1,jj2) + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + znum(:,jj1:jj2) = itid + !$omp end parallel + CALL iom_rstput( 0, 0, inum, 'thread', znum ) + ! + ! Close file + CALL iom_close ( inum ) + ! + IF (ln_mppwrite_abt) THEN + CALL mppsync() + CALL mppstop(.TRUE.) + ENDIF + ! + END SUBROUTINE mpp_write + + !!====================================================================== + +END MODULE mppwrite \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LDF/ldfc1d_c2d.F90 b/V4.0/nemo_sources/src/OCE/LDF/ldfc1d_c2d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e24acd1f4308810fabf8607b01f5addadf8a7ea8 --- /dev/null +++ b/V4.0/nemo_sources/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: ldfc1d_c2d.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_c1d( cd_type, pahs1, pahs2, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c1d *** + !! + !! ** Purpose : 1D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 1D eddy diffusivity coefficients F( depth ) + !! Reduction by zratio from surface to bottom + !! hyperbolic tangent profile with inflection point + !! at zh=500m and a width of zw=200m + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pahs1, pahs2 ! surface value of eddy coefficient [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pah1 , pah2 ! eddy coefficient [m2/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zh, zc, zdep1 ! local scalars + REAL(wp) :: zw , zdep2 ! - - + REAL(wp) :: zratio ! - - + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c1d : set a given profile to eddy mixing coefficients' + ! + ! initialization of the profile + zratio = 0.25_wp ! surface/bottom ratio + zh = 500._wp ! depth of the inflection point [m] + zw = 1._wp / 200._wp ! width^-1 - - - [1/m] + ! ! associated coefficient [-] + zc = ( 1._wp - zratio ) / ( 1._wp + TANH( zh * zw) ) + ! + ! + SELECT CASE( cd_type ) ! point of calculation + ! + CASE( 'DYN' ) ! T- and F-points + DO jk = jpkm1, 1, -1 ! pah1 at T-point + pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) ) + END DO + DO jk = jpkm1, 1, -1 ! 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.0_wp ) ! Lateral boundary conditions + ! + CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) + DO jk = jpkm1, 1, -1 + DO jj = 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.0_wp , pah2, 'V', 1.0_wp ) + ! + CASE DEFAULT ! error + CALL ctl_stop( 'ldf_c1d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) + END SELECT + ! + END SUBROUTINE ldf_c1d + + + SUBROUTINE ldf_c2d( cd_type, pUfac, knn, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c2d *** + !! + !! ** Purpose : 2D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 2D eddy diffusivity coefficients F( e1 , e2 ) + !! laplacian operator : ah proportional to the scale factor [m2/s] + !! bilaplacian operator : ah proportional to the (scale factor)^3 [m4/s] + !! In both cases, pah0 is the maximum value reached by the coefficient + !! at the Equator in case of e1=ra*rad= ~111km, not over the whole domain. + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp) , INTENT(in ) :: pUfac ! =1/2*Uc LAPlacian BiLaPlacian + INTEGER , INTENT(in ) :: knn ! characteristic velocity [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pah1, pah2 ! eddy coefficients [m2/s or m4/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inn ! local integer + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c2d : aht = Ufac * max(e1,e2) with Ufac = ', pUfac, ' m/s' + ! + ! + SELECT CASE( cd_type ) !== surface values ==! (chosen grid point function of DYN or TRA) + ! + CASE( 'DYN' ) ! T- and F-points + DO jj = 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LDF/ldfdyn.F90 b/V4.0/nemo_sources/src/OCE/LDF/ldfdyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9cfc18c57cc3680179de5e44a925d0a7c6b85251 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LDF/ldfdyn.F90 @@ -0,0 +1,543 @@ +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 ldfv34 ! V34 options for testing + ! + 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] + LOGICAL :: ln_outfile = .FALSE. !: Write ahmt, ahmf to ldfdyn.F90 + ! !!* 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 + ! + ! V36 import variables + REAL(wp) :: rn_ahm_0_lap = 10000.0_wp !: lateral laplacian eddy viscosity (m2/s) + REAL(wp) :: rn_ahm_0_lap_eq = 2000.0_wp !: lateral laplacian eddy viscosity (m2/s) equator + REAL(wp) :: rn_aht_0 = 1000.0_wp !: lateral eddy diffusivity (m2/s) + + 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: ldfdyn.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! 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 + & ln_outfile , & ! Write ahmt,ahmf to a dynldf file + & rn_ahm_0_lap , rn_ahm_0_lap_eq, rn_aht_0 ! V36 import variables + !!---------------------------------------------------------------------- + ! + 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 + ! + WRITE(numout,*) ' V34/V36 like settings : ' + WRITE(numout,*) ' lateral laplacian eddy viscosity rn_ahm_0_lap = ', rn_ahm_0_lap + WRITE(numout,*) ' lateral laplacian eddy visco. equ. rn_ahm_0_lap_eq = ', rn_ahm_0_lap_eq + WRITE(numout,*) ' lateral eddy diffusivity rn_aht_0 = ', rn_aht_0 + ! + WRITE(numout,*) ' Output fields used ln_outfile = ', ln_outfile + + 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( -31 ) !== ORCA1 V3.4 like + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = V34 like for ORCA1' + CALL ldf_dyn_c3d_orca1( rn_aht_0, rn_ahm_0_lap , rn_ahm_0_lap_eq, ahmt, ahmf ) + ! + 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 + ! + IF (ln_outfile) THEN + CALL iom_open ( 'ldfdyn', inum, ldwrt = .TRUE. ) + CALL iom_rstput( 0, 0, inum, 'ahmt', ahmt ) + CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) + CALL iom_close ( inum ) + 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.0_wp, ahmf, 'F', 1.0_wp ) + ! + ! + CASE( 32 ) !== time varying 3D field ==! = F( local deformation rate and gridscale ) (Smagorinsky) + ! + IF( ln_dynldf_lap .OR. ln_dynldf_blp ) THEN ! laplacian operator : (C_smag/pi)^2 L^2 |D| + ! + zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2 + zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 12._wp * 12._wp * zcmsmag ) ! lower limit stability factor scaling + zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * 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.0_wp ) ! 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.0_wp , ahmf, 'F', 1.0_wp ) + ! + END SELECT + ! + CALL iom_put( "ahmt_2d", ahmt(:,:,1) ) ! surface u-eddy diffusivity coeff. + CALL iom_put( "ahmf_2d", ahmf(:,:,1) ) ! surface v-eddy diffusivity coeff. + CALL iom_put( "ahmt_3d", ahmt(:,:,:) ) ! 3D u-eddy diffusivity coeff. + CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff. + ! + IF( ln_timing ) CALL timing_stop('ldf_dyn') + ! + END SUBROUTINE ldf_dyn + + !!====================================================================== +END MODULE ldfdyn \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LDF/ldfslp.F90 b/V4.0/nemo_sources/src/OCE/LDF/ldfslp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fe76268529e69370211153b0abc78b92f44588d3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LDF/ldfslp.F90 @@ -0,0 +1,839 @@ +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 + USE nopenmp ! OpenMP library + + 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" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfslp.F90 12198 2019-12-12 08:16:14Z smasson $ + !! 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(dp), 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 + INTEGER :: jj1, jj2, ithreads, itid ! OpenMP 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 + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2,& + !$omp& zau,zav,zbu,zbv,zfi,zfj,zdepu,zdepv,zbw,zci,zcj,zai,zaj,& + !$omp& zbi,zbj,zfk,zck,zcofw) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + zww(:,jj1:jj2,:) = 0._wp + zwz(:,jj1:jj2,:) = 0._wp + ! + DO jk = 1, jpk !== i- & j-gradient of density ==! + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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(:,jj1:jj2,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(:,jj1:jj2,jk) = zm1_g * ( prd(:,jj1:jj2,jk) + 1._wp ) & + & * ( pn2(:,jj1:jj2,jk) + pn2(:,jj1:jj2,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,jj1:jj2,jk+1) ) + END DO + ! + ! !== Slopes just below the mixed layer ==! + !$omp barrier + CALL ldf_slp_mxl( jj1, jj2, prd, pn2, zgru, zgrv, zdzr ) ! output: uslpml, vslpml, wslpiml, wslpjml + !!gm this lbc_lnk should be useless.... + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) + !$omp end master + !$omp barrier + + + ! 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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions + !$omp end master + !$omp barrier + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + !$omp master + 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 + !$omp end master + DO jj = MAX(3,jj1), MIN(jj2,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 + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions + !$omp end master + !$omp barrier + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + !$omp master + 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 + !$omp end master + DO jj = MAX(3,jj1), MIN(jj2,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 + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,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 + + !$omp end parallel + + ! IV. Lateral boundary conditions + ! =============================== + CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + + IF(ln_ctl) THEN + CALL prt_ctl(tab3d_1=CASTDP(uslp), clinfo1=' slp - u : ', tab3d_2=CASTDP(vslp), clinfo2=' v : ', kdim=jpk) + CALL prt_ctl(tab3d_1=CASTDP(wslpi), clinfo1=' slp - wi: ', tab3d_2=CASTDP(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.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked + ! + IF( ln_timing ) CALL timing_stop('ldf_slp_triad') + ! + END SUBROUTINE ldf_slp_triad + + + SUBROUTINE ldf_slp_mxl( jj1, jj2, 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 + !!---------------------------------------------------------------------- + INTEGER :: jj1, jj2 ! jj start stop + REAL(dp), 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,jj1:jj2) = 0._wp ; uslpml (jpi,jj1:jj2) = 0._wp + vslpml (1,jj1:jj2) = 0._wp ; vslpml (jpi,jj1:jj2) = 0._wp + wslpiml(1,jj1:jj2) = 0._wp ; wslpiml(jpi,jj1:jj2) = 0._wp + wslpjml(1,jj1:jj2) = 0._wp ; wslpjml(jpi,jj1:jj2) = 0._wp + ! + ! !== surface mixed layer mask ! + DO jk = 1, jpk ! =1 inside the mixed layer, =0 otherwise + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 + ! + 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/V4.0/nemo_sources/src/OCE/LDF/ldftra.F90 b/V4.0/nemo_sources/src/OCE/LDF/ldftra.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6993c410a14891cc9c6eb7e88f3d8754b9b64e92 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LDF/ldftra.F90 @@ -0,0 +1,982 @@ +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) + USE timing ! timing + + 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] + LOGICAL :: ln_outfile = .FALSE. !: Write ahtu, ahtv to ldfdyn.F90 + + ! ! 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: ldftra.F90 12296 2019-12-30 19:34:01Z mathiot $ + !! 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 + & ln_outfile ! write ahtu,ahtv to a ldftra file + !!---------------------------------------------------------------------- + ! + 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 + ! + IF (ln_outfile) THEN + CALL iom_open ( 'ldftra', inum, ldwrt = .TRUE. ) + CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) + CALL iom_rstput( 0, 0, inum, 'ahtv', ahtv ) + CALL iom_close ( inum ) + 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_timing_detail ) CALL timing_start('ldf_tra') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('ldf_tra') + ! + 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ldf_eiv') + ! + 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 +! ECMWF +! zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn2 = ABS( 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 +! ECMWF +! zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn2 = ABS( 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.0_wp ) ! 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.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition + + DO jk = 2, jpkm1 !== deeper values equal the surface one ==! + paeiu(:,:,jk) = paeiu(:,:,1) * umask(:,:,jk) + paeiv(:,:,jk) = paeiv(:,:,1) * vmask(:,:,jk) + END DO + ! + IF( ln_timing_detail ) CALL timing_stop('ldf_eiv') + ! + 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun ! in : 3 ocean transport components [m3/s] + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pvn ! out: 3 ocean transport components [m3/s] + REAL(dp), 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( ln_timing_detail ) CALL timing_start('ldf_eiv_trp') + ! + 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 ) + ! + IF( ln_timing_detail ) CALL timing_stop('ldf_eiv_trp') + ! + 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('ldf_eiv_dia') + ! +!!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.0_wp , psi_vw, 'V', -1.0_wp ) + ! +!!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.0_wp ) ! 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.0_wp ) + CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) + 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.0_wp ) + 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_wp * zw3d ) + ! + zztmp = 0.5_wp * 0.5 + IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 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.0_wp ) + CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) + 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.0_wp ) + 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_wp * zw3d ) + ! + IF( ln_timing_detail ) CALL timing_stop('ldf_eiv_dia') + ! + END SUBROUTINE ldf_eiv_dia + + !!====================================================================== +END MODULE ldftra \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/LDF/ldfv34.F90 b/V4.0/nemo_sources/src/OCE/LDF/ldfv34.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fa8744ed536f64e43f20cab74ad691e867a5eba9 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/LDF/ldfv34.F90 @@ -0,0 +1,183 @@ +MODULE ldfv34 + !!====================================================================== + !! *** MODULE ldfv34 *** + !! Ocean physics: profile and horizontal shape of lateral eddy coefficients based on V34/V36 + !!===================================================================== + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_dyn_c3d_orca : import of old code from V34/V36 + !!---------------------------------------------------------------------- + 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) + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_dyn_c3d_orca1 ! called by ldfdyn modules + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfv34.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_dyn_c3d_orca1( paht0, pahm0, pahm0eq, pahmt, pahmf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_dyn_c3d *** + !! + !! ** Purpose : ORCA R1 only + !! + !! ** Method : blah blah blah .... + !!---------------------------------------------------------------------- + !! + REAL(wp), INTENT(IN) :: paht0, pahm0, pahm0eq + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: pahmt, pahmf + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ii0, ii1, ij0, ij1 ! local integers + INTEGER :: inum, iim, ijm ! + INTEGER :: ifreq, il1, il2, ij, ii + REAL(wp) :: zahmeq, zcoff, zcoft, zmsk ! local scalars + REAL(wp) :: zemax , zemin, zeref, zahmm + INTEGER , DIMENSION(jpi,jpj) :: icof + REAL(wp), DIMENSION(jpk) :: zcoef + REAL(wp), DIMENSION(jpi,jpj) :: zahm0 + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d ! temporary array to read ahmcoef file + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ldfdyn_c3d_orca1 : 3D eddy viscosity coefficient' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) ' orca R1: reduced in the surface Eq. strip ' + + ! Read 2d integer array to specify western boundary increase in the + ! ===================== equatorial strip (20N-20S) defined at t-points + ALLOCATE( ztemp2d(jpi,jpj) ) + ztemp2d(:,:) = 0. + CALL iom_open ( 'ahmcoef.nc', inum ) + CALL iom_get ( inum, jpdom_data, 'icof', ztemp2d) + icof(:,:) = NINT(ztemp2d(:,:)) + CALL iom_close( inum ) + DEALLOCATE(ztemp2d) + + ! Set pahmt and pahmf + ! =================== + + ! define pahmt and pahmf at the right grid point position + ! (USER: modify pahmt and pahmf following your desiderata) + ! biharmonic : pahmt (pahmf) defined at u- (v-) point + ! harmonic : pahmt (pahmf) defined at t- (f-) point + + ! first level : as for 2D coefficients + + ! Decrease ahm to zahmeq m2/s in the tropics + ! (from 90 to 20 degre: ahm = constant + ! from 20 to 2.5 degre: ahm = decrease in (1-cos)/2 + ! from 2.5 to 0 degre: ahm = constant + ! symmetric in the south hemisphere) + + zahmeq = MAX(paht0,pahm0eq) ! reduced to aht0 on equator; set to ahm0 if no tropical reduction is required + zahmm = pahm0 + zahm0(:,:) = pahm0 + + DO jj = 1, jpj + DO ji = 1, jpi + IF( ABS(gphif(ji,jj)) >= 20.) THEN + pahmf(ji,jj,1) = zahm0(ji,jj) + ELSEIF( ABS(gphif(ji,jj)) <= 2.5) THEN + pahmf(ji,jj,1) = zahmeq + ELSE + pahmf(ji,jj,1) = zahmeq + (zahm0(ji,jj)-zahmeq)/2. & + & *(1.-COS( rad*(ABS(gphif(ji,jj))-2.5)*180./17.5 ) ) + ENDIF + IF( ABS(gphit(ji,jj)) >= 20.) THEN + pahmt(ji,jj,1) = zahm0(ji,jj) + ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN + pahmt(ji,jj,1) = zahmeq + ELSE + pahmt(ji,jj,1) = zahmeq + (zahm0(ji,jj)-zahmeq)/2. & + & *(1.-COS( rad*(ABS(gphit(ji,jj))-2.5)*180./17.5 ) ) + ENDIF + END DO + END DO + + ! increase along western boundaries of equatorial strip + ! t-point + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zcoft = REAL( icof(ji,jj) ) / 100. + pahmt(ji,jj,1) = zcoft * zahm0(ji,jj) + (1.-zcoft) * pahmt(ji,jj,1) + END DO + END DO + ! f-point + icof(:,:) = icof(:,:) * tmask(:,:,1) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! NO vector opt. + zmsk = tmask(ji,jj+1,1) + tmask(ji+1,jj+1,1) + tmask(ji,jj,1) + tmask(ji+1,jj,1) + IF( zmsk == 0. ) THEN + zcoff = 1. + ELSE + zcoff = REAL( icof(ji,jj+1) + icof(ji+1,jj+1) + icof(ji,jj) + icof(ji+1,jj) ) & + / (zmsk * 100.) + ENDIF + pahmf(ji,jj,1) = zcoff * zahm0(ji,jj) + (1.-zcoff) * pahmf(ji,jj,1) + END DO + END DO + + ! other level: re-increase the coef in the deep ocean + !================================================================== + ! Prior to v3.3, zcoeff was hardwired according to k-index jk. + ! + ! From v3.3 onwards this has been generalised to a function of + ! depth so that it can be used with any number of levels. + ! + ! The function has been chosen to match the original values (shown + ! in the following comments) when using the standard 31 ORCA levels. + ! DO jk = 1, 21 + ! zcoef(jk) = 1._wp + ! END DO + ! zcoef(22) = 2._wp + ! zcoef(23) = 3._wp + ! zcoef(24) = 5._wp + ! zcoef(25) = 7._wp + ! zcoef(26) = 9._wp + ! DO jk = 27, jpk + ! zcoef(jk) = 10._wp + ! END DO + !================================================================== + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' 1D zcoef array ' + WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' + WRITE(numout,*) + WRITE(numout,*) ' jk zcoef ' + ENDIF + + DO jk=1, jpk + zcoef(jk) = 1.0_wp + NINT(9.0_wp*(gdept_1d(jk)-800.0_wp)/(3000.0_wp-800.0_wp)) + zcoef(jk) = MIN(10.0_wp, MAX(1.0_wp, zcoef(jk))) + IF(lwp) WRITE(numout,'(4x,i3,6x,f7.3)') jk,zcoef(jk) + END DO + + DO jk = 2, jpk + pahmt(:,:,jk) = MIN( zahm0(:,:), zcoef(jk) * pahmt(:,:,1) ) + pahmf(:,:,jk) = MIN( zahm0(:,:), zcoef(jk) * pahmf(:,:,1) ) + END DO + + CALL lbc_lnk( 'ldf_dyn_c3d_orca', pahmt, 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign) + CALL lbc_lnk( 'ldf_dyn_c3d_orca', pahmf, 'F', 1.0_wp ) + + END SUBROUTINE ldf_dyn_c3d_orca1 + + +END MODULE ldfv34 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/ddatetoymdhms.h90 b/V4.0/nemo_sources/src/OCE/OBS/ddatetoymdhms.h90 new file mode 100644 index 0000000000000000000000000000000000000000..77de08123015bd35da45f88f3ee8a579cc210e07 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/ddatetoymdhms.h90 @@ -0,0 +1,43 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ddatetoymdhms.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE ddatetoymdhms( ddate, kyea, kmon, kday, khou, kmin, ksec ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE ddatetoymdhms *** + !! + !! ** Purpose : Convert YYYYMMDD.hhmmss to components + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + real(wp), INTENT(IN) :: ddate + INTEGER, INTENT(OUT) :: kyea + INTEGER, INTENT(OUT) :: kmon + INTEGER, INTENT(OUT) :: kday + INTEGER, INTENT(OUT) :: khou + INTEGER, INTENT(OUT) :: kmin + INTEGER, INTENT(OUT) :: ksec + !! * Local declarations + INTEGER :: iyymmdd + INTEGER :: ihhmmss + + iyymmdd = INT( ddate ) + ihhmmss = INT( ( ddate - iyymmdd ) * 1000000 ) + kyea = iyymmdd/10000 + kmon = iyymmdd / 100 - 100 * kyea + kday = MOD( iyymmdd, 100 ) + khou = ihhmmss/10000 + kmin = ihhmmss / 100 - 100 * khou + ksec = MOD( ihhmmss, 100 ) + + END SUBROUTINE ddatetoymdhms \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/diaobs.F90 b/V4.0/nemo_sources/src/OCE/OBS/diaobs.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e80781a468fc4688b43d9681bd78e4527a716e53 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/diaobs.F90 @@ -0,0 +1,1070 @@ +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 + USE timing ! Timing + ! + 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 + LOGICAL :: ln_split_output ! Logical switch for splitting of output files accourding to input file number + LOGICAL :: ln_sic_meltpond ! T=> SIC obs operator includes meltponds + + 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) + REAL(wp) :: rn_sit_minsic ! Minimum sic for use in SIT obs operator + + 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 + INTEGER, DIMENSION(:), ALLOCATABLE :: ifilesprof, ifilessurf ! Number of profile & surface files + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaobs.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 :: 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(wp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS + REAL(wp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS + REAL(dp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 + REAL(dp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 + REAL(dp), 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, ln_split_output, & + & ln_sic_meltpond, & + & cn_feedback_outdir + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! 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 + ln_sic_meltpond = .false. + + + 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 + WRITE(numout,*) ' Logical switch for SIC meltponds in obs oper. ln_sic_meltpond = ', ln_sic_meltpond + WRITE(numout,*) ' Output directory for feedback files cn_feedback_outdir = ', TRIM(cn_feedback_outdir) + WRITE(numout,*) ' splitof output files as input file number ln_split_output = ', ln_split_output + 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( 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( 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, rau0, r1_rau0, rhoi, rhos ! Physical constants + USE oce , ONLY : tsn, un, vn, sshn ! Ocean dynamics and tracers variables +#if defined key_si3 + USE ice , ONLY : a_i, a_ip_eff, v_i, vt_i, at_i, v_s, vt_s, hm_i, hm_s ! 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 + REAL(wp) :: zrho1, zrho2 + + !----------------------------------------------------------------------- + + IF (ln_timing) CALL timing_start('dia_obs') + 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 + zsurfvar(:,:) = fr_i(:,:) +#elif defined key_si3 + IF ( ln_sic_meltpond ) THEN + zsurfvar(:,:) = SUM( a_i(:,:,:) * (1.0_wp-a_ip_eff(:,:,:)) ,dim=3) + ELSE + zsurfvar(:,:) = SUM(a_i(:,:,:), dim=3) + ENDIF +#else + CALL ctl_stop( ' Trying to run sea-ice observation operator', & + & ' but no sea-ice model appears to have been defined' ) +#endif + ENDIF +#if defined key_si3 + CASE('sit','ifb','sfb') + ! compute the inverse of total conc (cautiously) + vt_i = SUM(v_i(:,:,:), dim=3) + at_i = SUM(a_i(:,:,:), dim=3) + vt_s = SUM(v_s(:,:,:), dim=3) + rn_sit_minsic = 0.01_wp + WHERE( at_i(:,:) > rn_sit_minsic ) + hm_i(:,:) = vt_i(:,:)/at_i(:,:) + ELSEWHERE + hm_i(:,:) = 0.0_wp + END WHERE + + IF (TRIM(cobstypessurf(jtype)) == 'sit') THEN + zsurfvar(:,:) = hm_i(:,:) + ELSE ! 'ifb' or 'sfb' + + ! compute snow thickness + WHERE( at_i(:,:) > rn_sit_minsic ) + hm_s(:,:) = vt_s(:,:)/at_i(:,:) + ELSEWHERE + hm_s(:,:) = 0.0_wp + END WHERE + + ! compute freeboard from Archimedes' Principle + zrho1 = ( rau0 - rhoi ) * r1_rau0 ; zrho2 = rhos * r1_rau0 + zsurfvar(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) ) + WHERE( zsurfvar(:,:) < 0._wp ) zsurfvar = 0._wp + + IF( TRIM(cobstypessurf(jtype)) == 'sfb') THEN + zsurfvar(:,:) = zsurfvar(:,:) + hm_s(:,:) + END IF + END IF +#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 + + IF (ln_timing) CALL timing_stop('dia_obs') + + 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), ln_split_output, ifilesprof(jtype) ) + + END DO + + DEALLOCATE( ifilesprof ) + + 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), ln_split_output, ifilessurf(jtype) ) + + END DO + + DEALLOCATE( ifilessurf ) + + 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=wp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS + INTEGER ,INTENT(IN) :: kstp + + !! * Local declarations + INTEGER :: iyea ! date - (year, month, day, hour, minute) + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: imday ! Number of days in month. + REAL(dp) :: 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=wp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS + + CALL calc_date( nit000 - 1, ddobsini ) + + END SUBROUTINE ini_date + + SUBROUTINE fin_date( ddobsfin ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fin_date *** + !! + !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) Change to call generic routine calc_date + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Arguments + REAL(wp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS + + CALL calc_date( nitend, ddobsfin ) + + END SUBROUTINE fin_date + + SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/find_obs_proc.h90 b/V4.0/nemo_sources/src/OCE/OBS/find_obs_proc.h90 new file mode 100644 index 0000000000000000000000000000000000000000..ae385bd5dc7105096f6ce0452f548b1ebd452216 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/find_obs_proc.h90 @@ -0,0 +1,60 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: find_obs_proc.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/greg2jul.h90 b/V4.0/nemo_sources/src/OCE/OBS/greg2jul.h90 new file mode 100644 index 0000000000000000000000000000000000000000..84e48629d2af6139c18bc01e7afa6893e656230a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/greg2jul.h90 @@ -0,0 +1,93 @@ +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 + & jpiref = 2443510, & ! Julian reference date: 19780101 + & 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( 19780101 ) + iref = jpiref + WRITE(*,*)'reference data: ', krefdate + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'greg2jul: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + END IF + + ! 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 + END IF + ijultmp = INT( 365.25_dp * ijy ) + INT( 30.6001_dp * ijm ) + kday + 1720995 + IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN + ija = INT( 0.01_dp * ijy ) + ijultmp = ijultmp + 2 - ija + INT( 0.25_dp * ija ) + END IF + pjulian = ( ijultmp - iref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400.0_dp + + END SUBROUTINE greg2jul \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis.h90 b/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c8e7f8c21a37b12bd468f9ac43b55ec11a01468e --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) + !! + !! ** Method : Geometry. + !! + !! History : + !! ! 1995-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 2006-03 (A. Vidard) Migration to NEMOVAR + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa1 ! sin(lat1) + REAL(KIND=wp) :: pa2 ! sin(lat2) + REAL(KIND=wp) :: pb1 ! cos(lat1) * cos(lon1) + REAL(KIND=wp) :: pb2 ! cos(lat2) * cos(lon2) + REAL(KIND=wp) :: pc1 ! cos(lat1) * sin(lon1) + REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) + + REAL(KIND=wp) :: cosdist ! cosine of great circle distance + + ! Compute cosine of great circle distance, constraining it to be between + ! -1 and 1 (rounding errors can take it slightly outside this range + cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) + + grt_cir_dis = & + & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) + + END FUNCTION grt_cir_dis \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis_saa.h90 b/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis_saa.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c76484a0a7c0ca91ff6b5bcdc89d2c2f3c6023ef --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/grt_cir_dis_saa.h90 @@ -0,0 +1,31 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis_saa.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis_saa *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) with a small-angle approximation + !! + !! ** Method : Geometry + !! + !! ** Action : + !! + !! History + !! ! 95-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 06-03 (A. Vidard) Migration to NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa ! lon1 - lon2 + REAL(KIND=wp) :: pb ! lat1 - lat2 + REAL(KIND=wp) :: pc ! cos(lat2) + + grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 ) + + END FUNCTION grt_cir_dis_saa \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/jul2greg.h90 b/V4.0/nemo_sources/src/OCE/OBS/jul2greg.h90 new file mode 100644 index 0000000000000000000000000000000000000000..56c5b8ee428f6219f958feca6ab453d436028dd5 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/jul2greg.h90 @@ -0,0 +1,121 @@ +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, & + & jpiref = 2443510, & ! Julian reference date: 19780101 + & jporef = 2433283, & + & jparef = 2415021 + INTEGER :: & + & ijulian, & + & ij1, & + & ija, & + & ijb, & + & ijc, & + & ijd, & + & ije, & + & isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & iref + REAL(KIND=dp) :: & + & 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( 19780101 ) + iref = jpiref + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + END IF + + zday = prelday + ksec = NINT( 86400.0_dp * MOD( zday, 1.0_dp ) ) + + IF ( ksec < 0.0_dp ) ksec = 86400.0_dp + ksec + + khour = ksec / 3600 + kminut = ( ksec - 3600 * khour ) / 60 + ksec = MOD( ksec , 60 ) + + ijulian = iref + INT( zday ) + IF ( zday < 0.0_dp ) ijulian = ijulian - 1 + + ! If input date after 10/15/1582 : + IF ( ijulian >= jpgreg ) THEN + ij1 = INT( ( REAL(ijulian,KIND=dp) - REAL(1867216,KIND=dp) - 0.25_dp ) & + & / 36524.25_dp ) + ija = ijulian + 1 + ij1 - INT( ( 0.25_dp * ij1 ) ) + ELSE + ija = ijulian + END IF + + ijb = ija + 1524 + ijc = INT( 6680.0_dp + ( REAL(ijb,KIND=dp) - REAL(2439870,KIND=dp) - 122.1_dp ) & + & / 365.25_dp ) + ijd = 365 * ijc + INT( 0.25_dp * ijc ) + ije = INT( ( ijb - ijd ) / 30.6001_dp ) + kday = ijb - ijd - INT( 30.6001_dp * ije ) + kmonth = ije - 1 + IF ( kmonth > 12 ) kmonth = kmonth - 12 + kyear = ijc - 4715 + IF ( kmonth > 2 ) kyear = kyear - 1 + IF ( kyear <= 0 ) kyear = kyear - 1 + + END SUBROUTINE jul2greg \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/julian.F90 b/V4.0/nemo_sources/src/OCE/OBS/julian.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7e3274b431bb2a2f29d4709889057a857a362d4c --- /dev/null +++ b/V4.0/nemo_sources/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: julian.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + +#include "jul2greg.h90" + +#include "greg2jul.h90" + +END MODULE julian \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/linquad.h90 b/V4.0/nemo_sources/src/OCE/OBS/linquad.h90 new file mode 100644 index 0000000000000000000000000000000000000000..b6d1e1730fdb7a99686f8834bd3afdc7e2b057ab --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/linquad.h90 @@ -0,0 +1,58 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: linquad.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + LOGICAL FUNCTION linquad( px, py, pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION linquad *** + !! + !! ** Purpose : Determine whether a point P(x,y) lies within or on the + !! boundary of a quadrangle (ABCD) of any shape on a plane. + !! + !! ** Method : Check if the vectorial products PA x PC, PB x PA, + !! PC x PD, and PD x PB are all negative. + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: px ! (lon) of the point P(x,y) + REAL(KIND=wp), INTENT(IN) :: py ! (lat) of the point P(x,y) + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp) :: zst1 + REAL(KIND=wp) :: zst2 + REAL(KIND=wp) :: zst3 + REAL(KIND=wp) :: zst4 + + !----------------------------------------------------------------------- + ! Test to see if the point is within the cell + !----------------------------------------------------------------------- + linquad = .FALSE. + zst1 = ( px - pxv(1) ) * ( py - pyv(4) ) & + & - ( py - pyv(1) ) * ( px - pxv(4) ) + IF ( zst1 <= 0.0 ) THEN + zst2 = ( px - pxv(4) ) * ( py - pyv(3) ) & + & - ( py - pyv(4) ) * ( px - pxv(3) ) + IF ( zst2 <= 0.0 ) THEN + zst3 = ( px - pxv(3) ) * ( py - pyv(2) ) & + & - ( py - pyv(3) ) * ( px - pxv(2) ) + IF ( zst3 <= 0.0) THEN + zst4 = ( px - pxv(2) ) * ( py - pyv(1) ) & + & - ( py - pyv(2) ) * ( px - pxv(1) ) + IF ( zst4 <= 0.0 ) linquad = .TRUE. + ENDIF + ENDIF + ENDIF + + END FUNCTION linquad \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/maxdist.h90 b/V4.0/nemo_sources/src/OCE/OBS/maxdist.h90 new file mode 100644 index 0000000000000000000000000000000000000000..48bfdbe245ac370b7575d7c8daa93d617d1a190c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/maxdist.h90 @@ -0,0 +1,76 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: maxdist.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(wp) FUNCTION maxdist( pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION maxdist *** + !! + !! ** Purpose : Compute the maximum distance between any points within + !! a cell + !! + !! ** Method : Call to grt_cir_dis + !! + !! ** Action : + !! + !! History : + !! ! 2006-08 (K. Mogensen) + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp), DIMENSION(4) :: & + & zxv, & + & zyv, & + & za, & + & zb, & + & zc + REAL(KIND=wp) :: zdist + + INTEGER :: ji + INTEGER :: jj + + !----------------------------------------------------------------------- + ! Convert data to radians + !----------------------------------------------------------------------- + DO ji = 1, 4 + zxv(ji) = pxv(ji) * rad + zyv(ji) = pyv(ji) * rad + END DO + + !----------------------------------------------------------------------- + ! Prepare input to grt_cir_dis + !----------------------------------------------------------------------- + DO ji = 1, 4 + za(ji) = SIN( zyv(ji) ) + zb(ji) = COS( zyv(ji) ) * COS( zxv(ji) ) + zc(ji) = COS( zyv(ji) ) * SIN( zxv(ji) ) + END DO + + !----------------------------------------------------------------------- + ! Get max distance between any points in the area + !----------------------------------------------------------------------- + maxdist = 0.0 + DO jj = 1, 4 + DO ji = jj+1, 4 + zdist = grt_cir_dis( za(jj), za(ji), zb(jj), & + & zb(ji), zc(jj), zc(ji)) + IF ( zdist > maxdist ) THEN + maxdist = zdist + ENDIF + END DO + END DO + + !----------------------------------------------------------------------- + ! Convert to degrees. + !----------------------------------------------------------------------- + maxdist = maxdist / rad + + END FUNCTION maxdist \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/mpp_map.F90 b/V4.0/nemo_sources/src/OCE/OBS/mpp_map.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3025e61245d21bba846f65b55e8735f5b9654c87 --- /dev/null +++ b/V4.0/nemo_sources/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: mpp_map.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_averg_h2d.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_averg_h2d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f84245193a90ff2269900354ec3fad29c3ff9cec --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_averg_h2d.F90 @@ -0,0 +1,824 @@ +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: obs_averg_h2d.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + SUBROUTINE obs_avg_h2d_init( kpk, kpk2, kmaxifp, kmaxjfp, k2dint, plam, pphi, & + & pglam, pgphi, pglamf, pgphif, pmask, plamscl, pphiscl, lindegrees, & + & pweig, 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 = MINVAL( e1t(:,:), mask = pmask(:,:) == 1._wp ) + ze2min = MINVAL( e2t(:,:), mask = pmask(:,:) == 1._wp ) + + IF(lk_mpp) THEN + CALL mpp_min( 'obs_averg_h2d', ze1min ) + CALL mpp_min( 'obs_averg_h2d', ze2min ) + ENDIF + + kmaxifp = ceiling(zlamscl_m/ze1min) + 1 + kmaxjfp = ceiling(zphiscl_m/ze2min) + 1 + + !Ensure that these numbers are even + kmaxifp = kmaxifp + MOD(kmaxifp,2) + kmaxjfp = kmaxjfp + MOD(kmaxjfp,2) + + + ENDIF + + END SUBROUTINE obs_max_fpsize + + SUBROUTINE obs_deg2dist( ki, kj, pglam, pgphi, plamscl_deg, pphiscl_deg, & + & plamscl_max, pphiscl_max ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_deg2dist *** + !! + !! ** Purpose : Calculate the maximum distance in m of the length scale + !! in degrees. + !! + !! ** Method : At each lon/lat point, work out the distances in the + !! zonal and meridional directions. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER , INTENT(IN) :: & + & ki, kj !x/y dimensions of input lat/lon variables + REAL(KIND=wp), INTENT(IN), DIMENSION(ki,kj) :: & + & pglam, pgphi !Longitude and latitudes of grid points + REAL(KIND=wp), INTENT(IN) :: & + & plamscl_deg, & !Size in degrees of the observation footprint + & pphiscl_deg ! + REAL(KIND=wp), INTENT(OUT) :: & + & plamscl_max, & !Maximum size of obs footprint in metres + & pphiscl_max + + !! * Local declarations + INTEGER :: & + & ji, jj !Counters + REAL(KIND=wp) :: & + & zlon1, zlon2, & !Lon values surrounding centre of grid point + & zlat1, zlat2, & !Lat values surrounding centre of grid point + & zdlat, zdlon !Distance in radians in lat/lon directions + REAL(KIND=wp) :: & + & za1, za2, za, zc, zd + + plamscl_max = -1.0_wp + pphiscl_max = -1.0_wp + + DO ji = 1, ki + DO jj = 1, kj + + !Calculate distance in metres in zonal(x) direction + + zlon1 = rad * ( pglam(ji,jj) + ( 0.5_wp * plamscl_deg ) ) + zlon2 = rad * ( pglam(ji,jj) - ( 0.5_wp * plamscl_deg ) ) + zlat1 = rad * pgphi(ji,jj) + zlat2 = rad * pgphi(ji,jj) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > plamscl_max ) plamscl_max = zd + + !Calculate distance in metres in meridional(y) direction + + zlon1 = rad * pglam(ji,jj) + zlon2 = rad * pglam(ji,jj) + zlat1 = rad * ( pgphi(ji,jj) + ( 0.5_wp * pphiscl_deg ) ) + zlat2 = rad * ( pgphi(ji,jj) - ( 0.5_wp * pphiscl_deg ) ) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > pphiscl_max ) pphiscl_max = zd + + END DO + END DO + + END SUBROUTINE obs_deg2dist + + SUBROUTINE obs_dist2corners(pglam_bl, pglam_br, pglam_tl, pglam_tr, & + & pgphi_bl, pgphi_br, pgphi_tl, pgphi_tr, & + & plam, pphi, pxvert, pyvert, pdist) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_dist2corners *** + !! + !! ** Purpose : Calculate distance from centre of obs footprint to the corners of a grid box + !! + !! ** Method : Use great circle distance formulae. + !! Order of corners is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pglam_bl, pglam_br, & !lon at corners of grid box + & pglam_tl, pglam_tr + REAL(KIND=wp), INTENT(IN) :: & + & pgphi_bl, pgphi_br, & !lat at corners of grid box + & pgphi_tl, pgphi_tr + REAL(KIND=wp), INTENT(IN) :: & + & pphi, plam !lat/lon of centre of obs footprint + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pxvert, pyvert !x/y location (in metres relative to centre of obs footprint) of corners + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pdist !distance (in metres) of each corner relative to centre of obs footprint + + !! * Local variables + INTEGER :: & + & jvert !Counter for corners + REAL(KIND=wp) :: & + & zphi, zlam !Local values for lon/lat of corners + REAL(KIND=wp) :: & + & za1, za2, & !For great circle distance calculations + & zb1, zb2, & + & zc1, zc2 + REAL(KIND=wp) :: & + & zdist_centre_lat, & !Distances in lat/lon directions (in metres) + & zdist_centre_lon + + !!----------------------------------------------------------------------- + + ! Work out latitudinal and longitudinal distance from centre of + ! obs fp to corners of grid box + DO jvert = 1, 4 + SELECT CASE(jvert) + CASE(1) + zphi = pgphi_tl + zlam = pglam_tl + CASE(2) + zphi = pgphi_tr + zlam = pglam_tr + CASE(3) + zphi = pgphi_br + zlam = pglam_br + CASE(4) + zphi = pgphi_bl + zlam = pglam_bl + END SELECT + + IF (zlam == plam ) THEN + pxvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( zphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( zphi * rad ) * COS( plam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( zphi * rad ) * SIN( plam * rad ) + pxvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pxvert(jvert) = ra * pxvert(jvert) + IF ( zlam < plam ) pxvert(jvert) = - pxvert(jvert) + ENDIF + + IF ( zphi == pphi ) THEN + pyvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( pphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( pphi * rad ) * COS( zlam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( pphi * rad ) * SIN( zlam * rad ) + pyvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pyvert(jvert) = ra * pyvert(jvert) + IF ( zphi < pphi ) pyvert(jvert) = - pyvert(jvert) + ENDIF + + !Calculate the distance of each vertex relative to centre of obs footprint + pdist(jvert) = SQRT( ( pxvert(jvert) * pxvert(jvert) ) + & + & ( pyvert(jvert) * pyvert(jvert) ) ) + + END DO + + END SUBROUTINE obs_dist2corners + +END MODULE obs_averg_h2d \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_const.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_const.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2058726c07b27002b9e532000c595850f1389db3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_const.F90 @@ -0,0 +1,22 @@ +MODULE obs_const + !!===================================================================== + !! *** MODULE obs_const *** + !! Observation diagnostics: Constants used by many modules + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_const.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & sp + IMPLICIT NONE + + !! * Routine/type accessibility + PUBLIC + + REAL(kind=sp), PARAMETER :: obfillflt=99999. + +END MODULE obs_const \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_conv.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_conv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..df6964121b6cda79d10af784784aba80e92296a6 --- /dev/null +++ b/V4.0/nemo_sources/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: obs_conv.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obs_conv_functions.h90" + +END MODULE obs_conv \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_conv_functions.h90 b/V4.0/nemo_sources/src/OCE/OBS/obs_conv_functions.h90 new file mode 100644 index 0000000000000000000000000000000000000000..8fc5ee99c9d5e21528edb2464c8e77316d186e21 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_conv_functions.h90 @@ -0,0 +1,294 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv_functions.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION potemp *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: potemp(35,20,2000,0) = 19.621967 + !! + !! References : T. J. Mcdougall, D. R. Jackett, D. G. Wright + !! and R. Feistel + !! Accurate and computationally efficient algoritms for + !! potential temperatures and density of seawater + !! Journal of atmospheric and oceanic technology + !! Vol 20, 2003, pp 730-741 + !! + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: ps + REAL(KIND=wp), INTENT(IN) :: pt + REAL(KIND=wp), INTENT(IN) :: pp + REAL(KIND=wp), INTENT(IN) :: ppr + + !! * Local declarations + REAL(KIND=wp) :: zpol + REAL(KIND=wp), PARAMETER :: a1 = 1.067610e-05 + REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06 + REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09 + REAL(KIND=wp), PARAMETER :: a4 = -8.535585e-06 + REAL(KIND=wp), PARAMETER :: a5 = 3.074672e-08 + REAL(KIND=wp), PARAMETER :: a6 = 1.918639e-08 + REAL(KIND=wp), PARAMETER :: a7 = 1.788718e-10 + + zpol = a1 + a2 * ps + a3 * ( pp + ppr ) + a4 * pt & + & + a5 * ps * pt + a6 * pt * pt + a7 * pt * ( pp + ppr ) + + potemp = pt + ( pp - ppr ) * zpol + + END FUNCTION potemp + + REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp ) + !!---------------------------------------------------------------------- + !! *** FUNCTION fspott *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : Check value: fspott(10,25,1000) = 8.4678516 + !! + !! References : A. E. Gill + !! Atmosphere-Ocean Dynamics + !! Volume 30 (International Geophysics) + !! + !! History : + !! ! 07-05 (K. Mogensen) NEMO adopting of OPAVAR code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pft ! in situ temperature in degrees Celsius + REAL(KIND=wp) :: pfs ! salinity in psu + REAL(KIND=wp) :: pfp ! pressure in bars + + fspott = & + & pft - pfp * ( ( 3.6504e-4 & + & + pft * ( 8.3198e-5 & + & + pft * ( -5.4065e-7 & + & + pft * 4.0274e-9 ) ) ) & + & + ( pfs - 35.0 ) * ( 1.7439e-5 & + & - pft * 2.9778e-7 ) & + & + pfp * ( 8.9309e-7 & + & + pft * ( -3.1628e-8 & + & + pft * 2.1987e-10 ) & + & - ( pfs - 35.0 ) * 4.1057e-9 & + & + pfp * ( -1.6056e-10 & + & + pft * 5.0484e-12 ) ) ) + + END FUNCTION fspott + + REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p ) + !!---------------------------------------------------------------------- + !! *** FUNCTION atg *** + !! + !! ** Purpose : Compute adiabatic temperature gradient deg c per decibar + !! + !! ** Method : A regression formula is used + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: atg(40,40,10000) = 3.255974e-4 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: p_s ! Salinity in PSU + REAL(KIND=wp), INTENT(IN) :: p_t ! Temperature in centigrades + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars. + + !! * Local declarations + + REAL(KIND=wp) :: z_ds + + z_ds = p_s - 35.0 + atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p & + & + (( 2.7759e-12 * p_t - 1.1351e-10 ) * z_ds + (( - 5.4481e-14 * p_t & + & + 8.733e-12 ) * p_t - 6.7795e-10 ) * p_t + 1.8741e-8)) * p_p & + & + ( -4.2393e-8 * p_t + 1.8932e-6 ) * z_ds & + & + (( 6.6228e-10 * p_t - 6.836e-8 ) * p_t + 8.5258e-6 ) * p_t + 3.5803e-5 + + END FUNCTION atg + + REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION theta *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: theta(40,40,10000,0) = 36.89073 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_s + REAL(KIND=wp), INTENT(IN) :: p_t0 + REAL(KIND=wp), INTENT(IN) :: p_p0 + REAL(KIND=wp), INTENT(IN) :: p_pr + + !! * Local declarations + REAL(KIND=wp) :: z_p + REAL(KIND=wp) :: z_t + REAL(KIND=wp) :: z_h + REAL(KIND=wp) :: z_xk + REAL(KIND=wp) :: z_q + + z_p = p_p0 + z_t = p_t0 + z_h = p_pr - z_p + z_xk = z_h * atg( p_s, z_t, z_p ) + Z_t = z_t + 0.5 * z_xk + z_q = z_xk + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 0.29289322 * ( z_xk - z_q ) + z_q = 0.58578644 * z_xk + 0.121320344 * z_q + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 1.707106781 * ( z_xk - z_q ) + z_q = 3.414213562 * z_xk - 4.121320244 * z_q + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + theta = z_t + ( z_xk - 2.0 * z_q ) / 6.0 + + END FUNCTION theta + + REAL(KIND=wp) FUNCTION depth( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION depth *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: depth(10000,30) = 9712.653 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_gr + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_gr = 9.780318 * ( 1.0 + ( 5.2788e-3 + 2.36e-5 * z_x ) * z_x ) + 1.092e-6 * p_p + depth = ((( -1.82e-15 * p_p + 2.279e-10 ) * p_p - 2.2512e-5 ) * p_p + 9.72659 ) * p_p + depth = depth / z_gr + + END FUNCTION depth + + REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION p_to_dep *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. This version is less + !! accurate the "depth" but invertible. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + p_to_dep = (1 - z_c1) * p_p - z_c2 * p_p * p_p + + END FUNCTION p_to_dep + + REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dep_to_p *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : The expression used in p_to_dep is inverted. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_dep ! Depth in meters + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + REAL(KIND=wp) :: z_d + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + z_d = ( z_c1 - 1 ) * ( z_c1 - 1 ) - 4 * z_c2 * p_dep + dep_to_p = (( 1 - z_c1 ) - SQRT( z_d )) / ( 2 * z_c2 ) + + END FUNCTION dep_to_p \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_fbm.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_fbm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..aaa893572db9b2a0d3b96c4a94e13e123b444a2c --- /dev/null +++ b/V4.0/nemo_sources/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._fbsp !: Reals + + ! Main data structure for observation feedback data. + + TYPE obfbdata + LOGICAL :: lalloc !: Allocation status for data + LOGICAL :: lgrid !: Include grid search info + INTEGER :: nvar !: Number of variables + INTEGER :: nobs !: Number of observations + INTEGER :: nlev !: Number of levels + INTEGER :: nadd !: Number of additional entries + INTEGER :: next !: Number of extra variables + INTEGER :: nqcf !: Number of words per qc flag + CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: & + & cdwmo !: Identifier + CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: & + & cdtyp !: Instrument type + CHARACTER(LEN=ilenjuld) :: & + & cdjuldref !: Julian date reference + INTEGER, DIMENSION(:), POINTER :: & + & kindex !: Index of observations in the original file + INTEGER, DIMENSION(:), POINTER :: & + & ioqc, & !: Observation QC + & ipqc, & !: Position QC + & itqc !: Time QC + INTEGER, DIMENSION(:,:), POINTER :: & + & ioqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & idqc !: Depth QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & idqcf !: Depth QC flags + REAL(KIND=fbdp), DIMENSION(:), POINTER :: & + & plam, & !: Longitude + & pphi, & !: Latitude + & ptim !: Time + REAL(KIND=fbsp), DIMENSION(:,:), POINTER :: & + & pdep !: Depth + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cname !: Name of variable + REAL(fbsp), DIMENSION(:,:,:), POINTER :: & + & pob !: Observation + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & coblong !: Observation long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cobunit !: Observation units (for output) + INTEGER, DIMENSION(:,:), POINTER :: & + & ivqc !: Variable QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivqcf !: Variable QC flags + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivlqc !: Variable level QC + INTEGER, DIMENSION(:,:,:,:), POINTER :: & + & ivlqcf !: Variable level QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & iproc, & !: Processor of obs (no I/O for this variable). + & iobsi, & !: Global i index + & iobsj !: Global j index + INTEGER, DIMENSION(:,:,:), POINTER :: & + & iobsk !: k index + CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER :: & + & cgrid !: Grid for this variable + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & caddname !: Additional entries names + CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: & + & caddlong !: Additional entries long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: & + & caddunit !: Additional entries units (for output) + REAL(fbsp), DIMENSION(:,:,:,:) , POINTER :: & + & padd !: Additional entries + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cextname !: Extra variables names + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & cextlong !: Extra variables long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cextunit !: Extra variables units (for output) + REAL(fbsp), DIMENSION(:,:,:) , POINTER :: & + & pext !: Extra variables + END TYPE obfbdata + + PRIVATE putvaratt_obfbdata + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_fbm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE init_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_obfbdata *** + !! + !! ** Purpose : Initialize sizes in obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + fbdata%nqcf = idefnqcf + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + + END SUBROUTINE init_obfbdata + + SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, & + & kqcf) + !!---------------------------------------------------------------------- + !! *** ROUTINE alloc_obfbdata *** + !! + !! ** Purpose : Allocate data in an obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kobs ! Number of observations + INTEGER, INTENT(IN) :: klev ! Number of levels + INTEGER, INTENT(IN) :: kadd ! Number of additional entries + INTEGER, INTENT(IN) :: kext ! Number of extra variables + LOGICAL, INTENT(IN) :: lgrid ! Include grid search information + INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags + !! * Local variables + INTEGER :: ji + INTEGER :: jv + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Set dimensions + + fbdata%lalloc = .TRUE. + fbdata%nvar = kvar + fbdata%nobs = kobs + fbdata%nlev = MAX( klev, 1 ) + fbdata%nadd = kadd + fbdata%next = kext + IF ( PRESENT(kqcf) ) THEN + fbdata%nqcf = kqcf + ELSE + fbdata%nqcf = idefnqcf + ENDIF + + ! Set data not depending on number of observations + + fbdata%cdjuldref = REPEAT( 'X', ilenjuld ) + + ! Allocate and initialize standard data + + ALLOCATE( & + & fbdata%cname(fbdata%nvar), & + & fbdata%coblong(fbdata%nvar), & + & fbdata%cobunit(fbdata%nvar) & + & ) + DO ji = 1, fbdata%nvar + WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji + fbdata%coblong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cobunit(ji) = REPEAT( ' ', ilenunit ) + END DO + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%cgrid(fbdata%nvar) & + & ) + fbdata%cgrid(:) = REPEAT( 'X', ilengrid ) + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%caddname(fbdata%nadd), & + & fbdata%caddlong(fbdata%nadd, fbdata%nvar), & + & fbdata%caddunit(fbdata%nadd, fbdata%nvar) & + & ) + DO ji = 1, fbdata%nadd + WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji + END DO + DO jv = 1, fbdata%nvar + DO ji = 1, fbdata%nadd + fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong ) + fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit ) + END DO + END DO + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%cextname(fbdata%next), & + & fbdata%cextlong(fbdata%next), & + & fbdata%cextunit(fbdata%next) & + & ) + DO ji = 1, fbdata%next + WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji + fbdata%cextlong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cextunit(ji) = REPEAT( ' ', ilenunit ) + END DO + ENDIF + + ! Data depending on number of observations is only allocated if nobs>0 + + IF ( fbdata%nobs > 0 ) THEN + + ALLOCATE( & + & fbdata%cdwmo(fbdata%nobs), & + & fbdata%cdtyp(fbdata%nobs), & + & fbdata%ioqc(fbdata%nobs), & + & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%ipqc(fbdata%nobs), & + & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%itqc(fbdata%nobs), & + & fbdata%itqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%idqc(fbdata%nlev,fbdata%nobs), & + & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), & + & fbdata%plam(fbdata%nobs), & + & fbdata%pphi(fbdata%nobs), & + & fbdata%pdep(fbdata%nlev,fbdata%nobs), & + & fbdata%ptim(fbdata%nobs), & + & fbdata%kindex(fbdata%nobs), & + & fbdata%ivqc(fbdata%nobs,fbdata%nvar), & + & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%kindex(:) = fbimdi + fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo ) + fbdata%cdtyp(:) = REPEAT( 'X', ilentyp ) + fbdata%ioqc(:) = fbimdi + fbdata%ioqcf(:,:) = fbimdi + fbdata%ipqc(:) = fbimdi + fbdata%ipqcf(:,:) = fbimdi + fbdata%itqc(:) = fbimdi + fbdata%itqcf(:,:) = fbimdi + fbdata%idqc(:,:) = fbimdi + fbdata%idqcf(:,:,:) = fbimdi + fbdata%plam(:) = fbrmdi + fbdata%pphi(:) = fbrmdi + fbdata%pdep(:,:) = fbrmdi + fbdata%ptim(:) = fbrmdi + fbdata%ivqc(:,:) = fbimdi + fbdata%ivqcf(:,:,:) = fbimdi + fbdata%ivlqc(:,:,:) = fbimdi + fbdata%ivlqcf(:,:,:,:) = fbimdi + fbdata%pob(:,:,:) = fbrmdi + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%iproc(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsi(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsj(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%iproc(:,:) = fbimdi + fbdata%iobsi(:,:) = fbimdi + fbdata%iobsj(:,:) = fbimdi + fbdata%iobsk(:,:,:) = fbimdi + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) & + & ) + fbdata%padd(:,:,:,:) = fbrmdi + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) & + & ) + fbdata%pext(:,:,:) = fbrmdi + ENDIF + + ENDIF + + END SUBROUTINE alloc_obfbdata + + SUBROUTINE dealloc_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dealloc_obfbdata *** + !! + !! ** Purpose : Deallocate data in an obfbdata strucure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + ! Deallocate data + + DEALLOCATE( & + & fbdata%cname, & + & fbdata%coblong,& + & fbdata%cobunit & + & ) + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%cgrid & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%caddname, & + & fbdata%caddlong, & + & fbdata%caddunit & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%cextname, & + & fbdata%cextlong, & + & fbdata%cextunit & + & ) + ENDIF + + ! Deallocate arrays depending on number of obs (if nobs>0 only). + + IF ( fbdata%nobs > 0 ) THEN + + DEALLOCATE( & + & fbdata%cdwmo, & + & fbdata%cdtyp, & + & fbdata%ioqc, & + & fbdata%ioqcf, & + & fbdata%ipqc, & + & fbdata%ipqcf, & + & fbdata%itqc, & + & fbdata%itqcf, & + & fbdata%idqc, & + & fbdata%idqcf, & + & fbdata%plam, & + & fbdata%pphi, & + & fbdata%pdep, & + & fbdata%ptim, & + & fbdata%kindex, & + & fbdata%ivqc, & + & fbdata%ivqcf, & + & fbdata%ivlqc, & + & fbdata%ivlqcf, & + & fbdata%pob & + & ) + + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%iproc, & + & fbdata%iobsi, & + & fbdata%iobsj, & + & fbdata%iobsk & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%padd & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%pext & + & ) + ENDIF + + ENDIF + + ! Reset arrays sizes + + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + + END SUBROUTINE dealloc_obfbdata + + SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE copy_obfbdata *** + !! + !! ** Purpose : Copy an obfbdata structure + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 + !! If fbdata2 is allocated it needs to be compliant + !! with fbdata1. + !! Additional entries can be added by setting nadd + !! Additional extra fields can be added by setting next + !! Grid information can be included with lgrid=.true. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries + INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables + INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags + LOGICAL, OPTIONAL :: lgrid ! Grid info on output file + + !! * Local variables + INTEGER :: nadd + INTEGER :: next + INTEGER :: nqcf + LOGICAL :: llgrid + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & __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=*) , INTENT(IN) :: 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=*), INTENT(IN) :: cdlongname ! Long name for variable + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdunits ! Units for variable + CHARACTER(len=*), OPTIONAL :: cfillvalue ! Fill value for character variables + INTEGER, OPTIONAL, INTENT(IN) :: ifillvalue ! Fill value for integer variables + REAL(kind=fbsp), OPTIONAL :: rfillvalue ! Fill value for real variables + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: 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=*), INTENT(IN) :: cdfilename ! Input filename + TYPE(obfbdata) :: fbdata ! obsfbdata structure + LOGICAL, OPTIONAL, INTENT(IN) :: ldgrid ! Allow forcing of grid info + !! * Local variables + CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata' + INTEGER :: idfile + INTEGER :: idodim + INTEGER :: idldim + INTEGER :: idvdim + INTEGER :: idadim + INTEGER :: idedim + INTEGER :: idgdim + INTEGER :: idvard + INTEGER :: idaddd + INTEGER :: idextd + INTEGER :: idcdwmo + INTEGER :: idcdtyp + INTEGER :: idplam + INTEGER :: idpphi + INTEGER :: idpdep + INTEGER :: idptim + INTEGER :: idptimr + INTEGER :: idioqc + INTEGER :: idioqcf + INTEGER :: idipqc + INTEGER :: idipqcf + INTEGER :: ididqc + INTEGER :: ididqcf + INTEGER :: iditqc + INTEGER :: iditqcf + INTEGER :: idkindex + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & idpob, & + & idivqc, & + & idivqcf, & + & idivlqc, & + & idivlqcf, & + & idiobsi, & + & idiobsj, & + & idiobsk, & + & idcgrid, & + & idpext + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & idpadd + INTEGER :: jv + INTEGER :: je + INTEGER :: nvar + INTEGER :: nobs + INTEGER :: nlev + INTEGER :: nadd + INTEGER :: next + LOGICAL :: lgrid + CHARACTER(len=NF90_MAX_NAME) :: cdtmp + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Open input filename + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), & + & cpname, __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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_grd_bruteforce.h90 b/V4.0/nemo_sources/src/OCE/OBS/obs_grd_bruteforce.h90 new file mode 100644 index 0000000000000000000000000000000000000000..e15bbbe419ebba5164f98d06e711c0e76cfcf469 --- /dev/null +++ b/V4.0/nemo_sources/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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_grid.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_grid.F90 new file mode 100644 index 0000000000000000000000000000000000000000..91ccdcd34d39eb21b94770574a96af8431e52389 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_grid.F90 @@ -0,0 +1,1183 @@ +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: obs_grid.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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), INTENT(IN) :: & + & 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, & + & CASTSP(glamu), CASTSP(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, & + & CASTSP(glamv), CASTSP(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(wp), DIMENSION(histsize) :: & + & fhistx1, fhistx2, fhisty1, fhisty2 + REAL(wp) :: histtol + + IF (ln_grid_search_lookup) THEN + + IF(lwp) 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) + + IF(lwp) 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_inter_h2d.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_inter_h2d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8550aa6d971790fab6e5c1427965d9738a783327 --- /dev/null +++ b/V4.0/nemo_sources/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, mpprank + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE obs_int_h2d_ds1, & ! Distance-weighted interpolation + & obs_int_h2d_ds2, & ! Distance-weighted interpolation (small angle) + & obs_int_h2d_bil, & ! Bilinear interpolation (geographical grid) + & obs_int_h2d_bir, & ! Bilinear remapping interpolation (general grid) + & obs_int_h2d_pol, & ! Polynomial interpolation + & lu_invmat, & ! Invert a matrix using LU decomposition + & lu_decomp, & ! LU decomposition + & lu_backsb, & ! LU decomposition - back substitution + & bil_wgt ! Compute weights for bilinear remapping + PUBLIC obs_int_h2d, & ! Horizontal interpolation to the observation point + & obs_int_h2d_init ! Set up weights and vertical mask + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_h2d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_h2d.h90" + +END MODULE obs_inter_h2d \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_inter_sup.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_inter_sup.F90 new file mode 100644 index 0000000000000000000000000000000000000000..79274d9d6e40761bcbe3436a722a33b5abcddffe --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_inter_sup.F90 @@ -0,0 +1,398 @@ +MODULE obs_inter_sup + !!===================================================================== + !! *** MODULE obs_inter_sup *** + !! Observation diagnostics: Support for interpolation + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_comm_3d : Get 3D interpolation stencil + !! obs_int_comm_2d : Get 2D interpolation stencil + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE dom_oce ! Domain variables + USE mpp_map ! Map of processor points + USE lib_mpp ! MPP stuff + USE obs_mpp ! MPP stuff for observations + USE obs_grid ! Grid tools + USE in_out_manager ! I/O stuff + USE timing ! timing + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_int_comm_3d, & ! Get 3D interpolation stencil + & obs_int_comm_2d ! Get 2D interpolation stencil + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_sup.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d *** + !! + !! ** Purpose : Get 3D interpolation stencil + !! + !! ** Method : Either on-demand communication with + !! obs_int_comm_3d_global + !! or local memory with + !! obs_int_comm_3D_local + !! depending on ln_global_grid + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + + IF (ln_grid_global) THEN + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval, kproc=kproc ) + + ELSE + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval ) + + ENDIF + + ELSE + + CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval ) + + ENDIF + + END SUBROUTINE obs_int_comm_3d + + SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & + & kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_2d *** + !! + !! ** Purpose : Get 2D interpolation stencil + !! + !! ** Method : Call to obs_int_comm_3d + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& + & pval ! Local 3D array to extra data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(jpi,jpj,1) :: zval + REAL(KIND=wp), DIMENSION(kptsi,kptsj,1,kobs) ::& + & zgval + + ! Set up local "3D" buffer + + zval(:,:,1) = pval(:,:) + + ! Call the 3D version + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval, kproc=kproc ) + ELSE + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval ) + + ENDIF + + ! Copy "3D" data back to 2D + + pgval(:,:,:) = zgval(:,:,1,:) + + END SUBROUTINE obs_int_comm_2d + + SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d_global *** + !! + !! ** Purpose : Get 3D interpolation stencil (global version) + !! + !! ** Method : On-demand communication where each processor send its + !! list of (i,j) of points to all processors and receive + !! the corresponding values + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zsend, & + & zrecv + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & igrdij_send, & + & igrdij_recv + INTEGER, DIMENSION(kptsi,kptsj,kobs) :: & + & iorder, & + & iproc + INTEGER :: nplocal(jpnij) + INTEGER :: npglobal(jpnij) + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jp + INTEGER :: jobs + INTEGER :: it + INTEGER :: itot + INTEGER :: ii + INTEGER :: ij + + ! Check valid points + + IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & + & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN + + CALL ctl_stop( 'Error in obs_int_comm_3d_global', & + & 'Point outside global domain' ) + + ENDIF + + ! Count number of points on each processors + + nplocal(:) = 0 + IF (PRESENT(kproc)) THEN + iproc(:,:,:) = kproc(:,:,:) + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ELSE + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + iproc(ji,jj,jobs) = mppmap(kgrdi(ji,jj,jobs),& + & kgrdj(ji,jj,jobs)) + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ENDIF + + ! Send local number of points and receive points on current domain + + IF (ln_timing_detail) CALL timing_start('mpp_alltoall_int_3d') + + CALL mpp_alltoall_int( 1, nplocal, npglobal ) + + IF (ln_timing_detail) CALL timing_stop('mpp_alltoall_int_3d') + + ! 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 + + IF (ln_timing_detail) CALL timing_start('mpp_alltoallv_int_3d') + + CALL mpp_alltoallv_int( igrdij_send, kptsi*kptsj*kobs*2, nplocal(:)*2, & + & igrdij_recv, itot*2, npglobal(:)*2 ) + + IF (ln_timing_detail) CALL timing_stop('mpp_alltoallv_int_3d') + + ! 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 + + IF (ln_timing_detail) CALL timing_start('mpp_alltoallv_real_3d') + + CALL mpp_alltoallv_real( zsend, kpk*itot, npglobal, & + & zrecv, kpk*kptsi*kptsj*kobs, nplocal ) + + IF (ln_timing_detail) CALL timing_stop('mpp_alltoallv_real_3d') + + ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_inter_z1d.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_inter_z1d.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5080b987c5b418a134d09895cb2b283001abac03 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_inter_z1d.F90 @@ -0,0 +1,36 @@ +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: obs_inter_z1d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_z1d.h90" + +END MODULE obs_inter_z1d \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_level_search.h90 b/V4.0/nemo_sources/src/OCE/OBS/obs_level_search.h90 new file mode 100644 index 0000000000000000000000000000000000000000..6e503bc5b2cfcd93444fb28babd2e0cf9ba08e58 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_level_search.h90 @@ -0,0 +1,51 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_level_search.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_level_search( kgrd, pgrddep, kobs, pobsdep, kobsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_level_search *** + !! + !! ** Purpose : Search levels to find matching level to observed depth + !! + !! ** Method : Straightforward search + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2008-10 (K. Mogensen) Remove assumptions on grid. + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kgrd ! Number of gridpoints + REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: & + & pgrddep ! Depths of gridpoints + INTEGER, INTENT(IN) :: & + & kobs ! Number of observations + REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: & + & pobsdep ! Depths of observations + INTEGER ,DIMENSION(kobs), INTENT(OUT) :: & + & kobsk ! Level indices of observations + + !! * Local declarations + INTEGER :: ji + INTEGER :: jk + + !------------------------------------------------------------------------ + ! Search levels for each observations to find matching level + !------------------------------------------------------------------------ + DO ji = 1, kobs + kobsk(ji) = 1 + depk: DO jk = 2, kgrd + IF ( pgrddep(jk) > pobsdep(ji) ) EXIT depk + END DO depk + kobsk(ji) = jk + END DO + + END SUBROUTINE obs_level_search \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_mpp.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_mpp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fcecffbe298989812a42f188c09cfb483d1882d1 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_mpp.F90 @@ -0,0 +1,451 @@ +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 + !!---------------------------------------------------------------------- +# if defined key_single +# define mpivar mpi_real +# else +# define mpivar mpi_double_precision +# endif + + !!---------------------------------------------------------------------- + !! 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 + USE timing +#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: obs_mpp.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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) , INTENT(in) :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_oper.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_oper.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1ed7c18be71b95668d274f27cca8ab55bfccaf86 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_oper.F90 @@ -0,0 +1,1007 @@ +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 + USE timing ! Timing + + 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: obs_oper.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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) :: pgdepw! depth of T and W levels + REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept! 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 + + IF (ln_timing) CALL timing_start('obs_prof_opt') + !------------------------------------------------------------------------ + ! 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 + + IF (ln_timing_detail) CALL timing_start('obs_prof_opt_mpp') + + 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, CASTSP(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 + + IF (ln_timing_detail) CALL timing_stop('obs_prof_opt_mpp') + + IF (ln_timing_detail) CALL timing_start('obs_prof_opt_inter') + + ! Return if no observations to process + ! Has to be done after comm commands to ensure processors + ! stay in sync + IF ( ipro == 0 ) THEN + IF (ln_timing_detail) CALL timing_stop('obs_prof_opt_inter') + IF (ln_timing) CALL timing_stop('obs_prof_opt') + RETURN + ENDIF + + 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 + + IF (ln_timing_detail) CALL timing_stop('obs_prof_opt_inter') + + ! 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 + + IF (ln_timing) CALL timing_stop('obs_prof_opt') + + 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) + + IF (ln_timing) CALL timing_start('obs_surf_opt') + !------------------------------------------------------------------------ + ! 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 ) + + + ! 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 ) + + 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 + + + ! 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 + + IF (ln_timing_detail) CALL timing_start('obs_surf_opt_mpp') + + 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 + + IF (ln_timing_detail) CALL timing_stop('obs_surf_opt_mpp') + + IF (ln_timing_detail) CALL timing_start('obs_surf_opt_inter') + + ! 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 + + IF (ln_timing_detail) CALL timing_stop('obs_surf_opt_inter') + + ! 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 + ! + IF (ln_timing) CALL timing_stop('obs_surf_opt') + ! + END SUBROUTINE obs_surf_opt + + !!====================================================================== +END MODULE obs_oper \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_prep.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_prep.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c7035c3a34727839cd658a538e48387e8108f604 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_prep.F90 @@ -0,0 +1,1458 @@ +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: obs_prep.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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(dp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: zmask1, zmask2 + + + + REAL(dp), 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 calc_month_len + + SUBROUTINE obs_coo_tim_prof( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_tim *** + !! + !! ** Purpose : Compute the number of time steps to the observation time. + !! + !! ** Method : For time coordinates ( yea_obs, mon_obs, day_obs, + !! hou_obs, min_obs ), this routine locates the time step + !! that is closest to this time. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 1997-07 (A. Weaver) Original + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2007-01 (K. Mogensen) Rewritten with loop + !!---------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: kcycle ! Current cycle + INTEGER, INTENT(IN) :: kyea0 ! Initial date coordinates + INTEGER, INTENT(IN) :: kmon0 + INTEGER, INTENT(IN) :: kday0 + INTEGER, INTENT(IN) :: khou0 + INTEGER, INTENT(IN) :: kmin0 + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, INTENT(INOUT) :: kotdobs ! Number of observations failing time check + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsyea, & ! Observation time coordinates + & kobsmon, & + & kobsday, & + & kobshou, & + & kobsmin, & + & ktyp ! Observation type. + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + INTEGER, DIMENSION(kobsno), INTENT(OUT) :: & + & kobsstp ! Number of time steps up to the + ! observation time + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value + + !! * Local declarations + INTEGER :: jobs + INTEGER :: iqc_cutoff=255 + + !----------------------------------------------------------------------- + ! Call standard obs_coo_tim + !----------------------------------------------------------------------- + + CALL obs_coo_tim( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & kobsqc, kobsstp, kotdobs ) + + !------------------------------------------------------------------------ + ! Always reject daily averaged data (e.g. MRB data (820)) at initial time + !------------------------------------------------------------------------ + + IF ( PRESENT(kdailyavtypes) ) THEN + DO jobs = 1, kobsno + + IF ( kobsqc(jobs) <= iqc_cutoff ) THEN + + IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& + & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + ENDIF + END DO + ENDIF + + + END SUBROUTINE obs_coo_tim_prof + + SUBROUTINE obs_coo_grd( kobsno, kobsi, kobsj, kobsqc, kgrdobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_grd *** + !! + !! ** Purpose : Verify that the grid search has not failed + !! + !! ** Method : The previously computed i,j indeces are checked + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 2007-01 (K. Mogensen) Original + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsi, & ! i,j indeces previously computed + & kobsj + INTEGER, INTENT(INOUT) :: kgrdobs ! Number of observations failing the check + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + + !! * Local declarations + INTEGER :: jobs ! Loop variable + + ! Flag if the grid search failed + + DO jobs = 1, kobsno + IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),12) + kgrdobs = kgrdobs + 1 + ENDIF + END DO + + END SUBROUTINE obs_coo_grd + + SUBROUTINE obs_coo_spc_2d( kobsno, kpi, kpj, & + & kobsi, kobsj, pobslam, pobsphi, & + & plam, pphi, pmask, & + & kobsqc, kosdobs, klanobs, & + & knlaobs,ld_nea, & + & kbdyobs,ld_bound_reject, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_spc_2d *** + !! + !! ** Purpose : Check for points outside the domain and land points + !! + !! ** Method : Remove the observations that are outside the model space + !! and time domain or located within model land cells. + !! + !! ** Action : + !! + !! History : 2007-03 (A. Weaver, K. Mogensen) Original + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kobsno ! Total number of observations + INTEGER , INTENT(in ) :: kpi , kpj ! Number of grid points in (i,j) + INTEGER , INTENT(in ), DIMENSION(kobsno) :: kobsi , kobsj ! Observation (i,j) coordinates + REAL(wp), INTENT(in ), DIMENSION(kobsno) :: pobslam, pobsphi ! Observation (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: plam , pphi ! Model (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: pmask ! Land mask array + INTEGER , INTENT(inout), DIMENSION(kobsno) :: kobsqc ! Observation quality control + INTEGER , INTENT(inout) :: kosdobs ! Observations outside space domain + INTEGER , INTENT(inout) :: klanobs ! Observations within a model land cell + INTEGER , INTENT(inout) :: knlaobs ! Observations near land + INTEGER , INTENT(inout) :: kbdyobs ! Observations near boundary + LOGICAL , INTENT(in ) :: ld_nea ! Flag observations near land + LOGICAL , INTENT(in ) :: ld_bound_reject ! Flag observations near open boundary + INTEGER , INTENT(in ) :: kqc_cutoff ! Cutoff QC value + ! + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zglam, zgphi ! Model Lon/lat at grid points + INTEGER , DIMENSION(2,2,kobsno) :: igrdi, igrdj ! Grid i,j + LOGICAL :: lgridobs ! Is observation on a model grid point. + INTEGER :: iig, ijg ! i,j of observation on model grid point. + INTEGER :: jobs, ji, jj + !!---------------------------------------------------------------------- + + ! Get grid point indices + + DO jobs = 1, kobsno + + ! For invalid points use 2,2 + + IF ( kobsqc(jobs) >= kqc_cutoff ) THEN + + igrdi(1,1,jobs) = 1 + igrdj(1,1,jobs) = 1 + igrdi(1,2,jobs) = 1 + igrdj(1,2,jobs) = 2 + igrdi(2,1,jobs) = 2 + igrdj(2,1,jobs) = 1 + igrdi(2,2,jobs) = 2 + igrdj(2,2,jobs) = 2 + + ELSE + + igrdi(1,1,jobs) = kobsi(jobs)-1 + igrdj(1,1,jobs) = kobsj(jobs)-1 + igrdi(1,2,jobs) = kobsi(jobs)-1 + igrdj(1,2,jobs) = kobsj(jobs) + igrdi(2,1,jobs) = kobsi(jobs) + igrdj(2,1,jobs) = kobsj(jobs)-1 + igrdi(2,2,jobs) = kobsi(jobs) + igrdj(2,2,jobs) = kobsj(jobs) + + ENDIF + + END DO + + IF (ln_bdy) THEN + ! Create a mask grid points in boundary rim + IF (ld_bound_reject) THEN + zbdymask(:,:) = 1.0_wp + DO ji = 1, nb_bdy + DO jj = 1, idx_bdy(ji)%nblen(1) + zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp + ENDDO + ENDDO + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) + ENDIF + ENDIF + + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + + DO jobs = 1, kobsno + + ! Skip bad observations + IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE + + ! Flag if the observation falls outside the model spatial domain + IF ( ( pobslam(jobs) < -180. ) & + & .OR. ( pobslam(jobs) > 180. ) & + & .OR. ( pobsphi(jobs) < -90. ) & + & .OR. ( pobsphi(jobs) > 90. ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),11) + kosdobs = kosdobs + 1 + CYCLE + ENDIF + + ! Flag if the observation falls with a model land cell + IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + + ! Check if this observation is on a grid point + + lgridobs = .FALSE. + iig = -1 + ijg = -1 + DO jj = 1, 2 + DO ji = 1, 2 + IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & + & .AND. & + & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & + & < 1.0e-6_wp ) ) THEN + lgridobs = .TRUE. + iig = ji + ijg = jj + ENDIF + END DO + END DO + + ! For observations on the grid reject them if their are at + ! a masked point + + IF (lgridobs) THEN + IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + ENDIF + + ! Flag if the observation falls is close to land + IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN + knlaobs = knlaobs + 1 + IF (ld_nea) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),9) + CYCLE + ENDIF + ENDIF + + IF (ln_bdy) THEN + ! Flag if the observation falls close to the boundary rim + IF (ld_bound_reject) THEN + IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ! for observations on the grid... + IF (lgridobs) THEN + IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ENDIF + ENDIF + ENDIF + ! + END DO + ! + END SUBROUTINE obs_coo_spc_2d + + + SUBROUTINE obs_coo_spc_3d( kprofno, kobsno, kpstart, kpend, & + & kpi, kpj, kpk, & + & kobsi, kobsj, kobsk, & + & pobslam, pobsphi, pobsdep, & + & plam, pphi, pdep, pmask, & + & kpobsqc, kobsqc, kosdobs, & + & klanobs, knlaobs, ld_nea, & + & kbdyobs, ld_bound_reject, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** 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=dp), DIMENSION(kpi,kpj), INTENT(IN) :: plam, pphi + + + REAL(KIND=wp), DIMENSION(kpk), INTENT(IN) :: & + & pdep ! Model depth coordinates + REAL(KIND=dp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: pmask + + + 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, CASTSP(pmask), zgmsk ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, CASTSP(plam), zglam ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, CASTSP(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_profiles.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_profiles.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7246820c3dbb514f17d0c178a63341ee05f63f40 --- /dev/null +++ b/V4.0/nemo_sources/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: obs_profiles.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + + !! * Modules used + USE obs_profiles_def ! Definition of profile data types and tools + + IMPLICIT NONE + + SAVE + + !! * Routine accessibility + PRIVATE + + PUBLIC nprofsets, nprofvars, nprofextr, profdata, prodatqc + PUBLIC nvelosets, nvelovars, nveloextr, velodata, veldatqc + + !! * Shared Module variables + INTEGER :: nprofsets ! Total number of profile data sets + INTEGER :: nprofvars ! Total number of variables for profiles + INTEGER :: nprofextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: profdata(:) ! Initial profile data + TYPE(obs_prof), POINTER :: prodatqc(:) ! Profile data after quality control + + INTEGER :: nvelosets ! Total number of velocity profile data sets + INTEGER :: nvelovars ! Total number of variables for profiles + INTEGER :: nveloextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: velodata(:) ! Initial velocity profile data + TYPE(obs_prof), POINTER :: veldatqc(:) ! Velocity profile data after quality control +END MODULE obs_profiles \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_profiles_def.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_profiles_def.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cfc2398b7ab6da9792b5f3c7c4acf12eca83fd80 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_profiles_def.F90 @@ -0,0 +1,932 @@ +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(:) :: & + & nfile,& !: File number + & npidx,& !: Profile number + & npfil,& !: Profile number in file + & nyea, & !: Year of profile + & nmon, & !: Month of profile + & nday, & !: Day of profile + & nhou, & !: Hour of profile + & nmin, & !: Minute of profile + & mstp, & !: Time step nearest to profile + & nqc, & !: Profile QC + & ntyp, & !: Type of profile product (WMO table 1770) + & ipqc, & !: Position QC + & itqc !: Time QC + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of profile data + & rphi !: Latitude coordinate of profile data + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: Profile WMO indentifier + + ! Arrays with size equal to the number of profiles times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & npvsta, & !: Start of each variable profile in full arrays + & npvend, & !: End of each variable profile in full arrays + & mi, & !: i-th grid coord. for interpolating to profile T data + & mj, & !: j-th grid coord. for interpolating to profile T data + & ivqc !: QC flags for all levels for a variable + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:) :: & + & nqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:,:) :: & + & ivqcf + + ! Arrays of variables + + TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & npstp, & !: Total number of profiles + & npstpmpp !: Total number of profiles + + ! Arrays with size equal to the number of time steps in the window times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & nvstp, & !: Local total num. of profile data each time step + & nvstpmpp !: Global total num. of profile data each time step + + ! Arrays with size equal to the number of grid points times number of + ! variables + + REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: & + & vdmean !: Daily averaged model field + + ! Arrays used to store source indices when + ! compressing obs_prof derived types + + ! Array with size nprof + + INTEGER, POINTER, DIMENSION(:) :: & + & npind !: Source indices of profile data in compressed data + + END TYPE obs_prof + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_profiles_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_prof_alloc( prof, kvar, kext, kprof, & + & ko3dt, kstp, kpi, kpj, kpk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc *** + !! + !! ** Purpose : - Allocate data for profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !! ! 07-03 (K. Mogensen) Generalized profiles + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kprof ! Number of profiles + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN), DIMENSION(kvar) :: & + & ko3dt ! Number of observations per variables + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kpk + + !!* Local variables + INTEGER :: jvar + INTEGER :: ji + + ! Set bookkeeping variables + + prof%nvar = kvar + prof%next = kext + prof%nprof = kprof + + prof%nstp = kstp + prof%npi = kpi + prof%npj = kpj + prof%npk = kpk + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & prof%cvars(kvar), & + & prof%nvprot(kvar), & + & prof%nvprotmpp(kvar) & + ) + + DO jvar = 1, kvar + prof%cvars (jvar) = "NotSet" + prof%nvprot (jvar) = ko3dt(jvar) + prof%nvprotmpp(jvar) = 0 + END DO + + ! Allocate arrays of size number of profiles + ! times number of variables + + ALLOCATE( & + & prof%npvsta(kprof,kvar), & + & prof%npvend(kprof,kvar), & + & prof%mi(kprof,kvar), & + & prof%mj(kprof,kvar), & + & prof%ivqc(kprof,kvar) & + ) + + ! Allocate arrays of size iqcfdef times number of profiles + ! times number of variables + + ALLOCATE( & + & prof%ivqcf(idefnqcf,kprof,kvar) & + & ) + + ! Allocate arrays of size number of profiles + + ALLOCATE( & + & prof%nfile(kprof), & + & 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%nfile, & + & prof%npidx, & + & prof%npfil, & + & prof%nyea, & + & prof%nmon, & + & prof%nday, & + & prof%nhou, & + & prof%nmin, & + & prof%mstp, & + & prof%nqc, & + & prof%ipqc, & + & prof%itqc, & + & prof%nqcf, & + & prof%ipqcf, & + & prof%itqcf, & + & prof%ntyp, & + & prof%rlam, & + & prof%rphi, & + & prof%cwmo, & + & prof%npind & + & ) + + ! For each variables allocate arrays of size number of observations + + DO jvar = 1, prof%nvar + + IF ( prof%nvprot(jvar) >= 0 ) THEN + + CALL obs_prof_dealloc_var( prof, jvar ) + + ENDIF + + END DO + + ! Dellocate obs_prof_var type + DEALLOCATE( & + & prof%var & + & ) + + ! Deallocate arrays of size number of time step size + + DEALLOCATE( & + & prof%npstp, & + & prof%npstpmpp & + & ) + + ! Deallocate arrays of size number of time step size times + ! number of variables + + DEALLOCATE( & + & prof%nvstp, & + & prof%nvstpmpp & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & prof%vdmean & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & prof%cvars, & + & prof%nvprot, & + & prof%nvprotmpp & + ) + + + END SUBROUTINE obs_prof_dealloc + + + SUBROUTINE obs_prof_alloc_var( prof, kvar, kext, kobs ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN) :: kobs ! Number of observations + + ALLOCATE( & + & prof%var(kvar)%mvk(kobs), & + & prof%var(kvar)%nvpidx(kobs), & + & prof%var(kvar)%nvlidx(kobs), & + & prof%var(kvar)%nvqc(kobs), & + & prof%var(kvar)%idqc(kobs), & + & prof%var(kvar)%vdep(kobs), & + & prof%var(kvar)%vobs(kobs), & + & prof%var(kvar)%vmod(kobs), & + & prof%var(kvar)%nvind(kobs) & + & ) + ALLOCATE( & + & prof%var(kvar)%idqcf(idefnqcf,kobs), & + & prof%var(kvar)%nvqcf(idefnqcf,kobs) & + & ) + IF (kext>0) THEN + ALLOCATE( & + & prof%var(kvar)%vext(kobs,kext) & + & ) + ENDIF + + END SUBROUTINE obs_prof_alloc_var + + SUBROUTINE obs_prof_dealloc_var( prof, kvar ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + + DEALLOCATE( & + & prof%var(kvar)%mvk, & + & prof%var(kvar)%nvpidx, & + & prof%var(kvar)%nvlidx, & + & prof%var(kvar)%nvqc, & + & prof%var(kvar)%idqc, & + & prof%var(kvar)%vdep, & + & prof%var(kvar)%vobs, & + & prof%var(kvar)%vmod, & + & prof%var(kvar)%nvind, & + & prof%var(kvar)%idqcf, & + & prof%var(kvar)%nvqcf & + & ) + IF (prof%next>0) THEN + DEALLOCATE( & + & prof%var(kvar)%vext & + & ) + ENDIF + + END SUBROUTINE obs_prof_dealloc_var + + SUBROUTINE obs_prof_compress( prof, newprof, lallocate, & + & kumout, lvalid, lvvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_prof type + !! into a new obs_prof type + !! + !! ** Method : - The data is copied from prof to new prof. + !! In the case of lvalid and lvvalid both being + !! present only the selected data will be copied. + !! If lallocate is true the data in the newprof is + !! allocated either with the same number of elements + !! as prof or with only the subset of elements defined + !! by the optional selection in lvalid and lvvalid + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(IN) :: prof ! Original profile + TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data + LOGICAL,INTENT(in) :: lallocate ! Allocate newprof data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & + & lvalid ! Valid profiles + TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: & + & lvvalid ! Valid data within the profiles + + !!* Local variables + INTEGER :: inprof + INTEGER, DIMENSION(prof%nvar) :: & + & invpro + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + LOGICAL :: lfirst + TYPE(obs_prof_valid) :: & + & llvalid + TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: & + & llvvalid + LOGICAL :: lallpresent + LOGICAL :: lnonepresent + + ! Check that either all or none of the masks are persent. + + lallpresent = .FALSE. + lnonepresent = .FALSE. + IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN + lallpresent = .TRUE. + ELSEIF ( ( .NOT. PRESENT(lvalid) ) .AND. & + & ( .NOT. PRESENT(lvvalid) ) ) THEN + lnonepresent = .TRUE. + ELSE + CALL ctl_stop('Error in obs_prof_compress:', & + & 'Either all selection variables should be set', & + & 'or no selection variable should be set' ) + ENDIF + + ! Count how many elements there should be in the new data structure + + IF ( lallpresent ) THEN + inprof = 0 + invpro(:) = 0 + DO ji = 1, prof%nprof + IF ( lvalid%luse(ji) ) THEN + inprof=inprof+1 + DO jvar = 1, prof%nvar + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + IF ( lvvalid(jvar)%luse(jj) ) & + & invpro(jvar) = invpro(jvar) +1 + END DO + END DO + ENDIF + END DO + ELSE + inprof = prof%nprof + invpro(:) = prof%nvprot(:) + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_prof_alloc( newprof, prof%nvar, & + & prof%next, & + & inprof, invpro, & + & prof%nstp, prof%npi, & + & prof%npj, prof%npk ) + ENDIF + + ! Allocate temporary mask array to unify the code for both cases + + ALLOCATE( llvalid%luse(prof%nprof) ) + DO jvar = 1, prof%nvar + ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) ) + END DO + IF ( lallpresent ) THEN + llvalid%luse(:) = lvalid%luse(:) + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:) + END DO + ELSE + llvalid%luse(:) = .TRUE. + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = .TRUE. + END DO + ENDIF + + ! Setup bookkeeping variables + + inprof = 0 + invpro(:) = 0 + + newprof%npvsta(:,:) = 0 + newprof%npvend(:,:) = -1 + + ! Loop over source profiles + + DO ji = 1, prof%nprof + + IF ( llvalid%luse(ji) ) THEN + + ! Copy the header information + + inprof = inprof + 1 + + newprof%mi(inprof,:) = prof%mi(ji,:) + newprof%mj(inprof,:) = prof%mj(ji,:) + newprof%nfile(inprof) = prof%nfile(ji) + newprof%npidx(inprof) = prof%npidx(ji) + newprof%npfil(inprof) = prof%npfil(ji) + newprof%nyea(inprof) = prof%nyea(ji) + newprof%nmon(inprof) = prof%nmon(ji) + newprof%nday(inprof) = prof%nday(ji) + newprof%nhou(inprof) = prof%nhou(ji) + newprof%nmin(inprof) = prof%nmin(ji) + newprof%mstp(inprof) = prof%mstp(ji) + newprof%nqc(inprof) = prof%nqc(ji) + newprof%ipqc(inprof) = prof%ipqc(ji) + newprof%itqc(inprof) = prof%itqc(ji) + newprof%ivqc(inprof,:)= prof%ivqc(ji,:) + newprof%ntyp(inprof) = prof%ntyp(ji) + newprof%rlam(inprof) = prof%rlam(ji) + newprof%rphi(inprof) = prof%rphi(ji) + newprof%cwmo(inprof) = prof%cwmo(ji) + + ! QC info + + newprof%nqcf(:,inprof) = prof%nqcf(:,ji) + newprof%ipqcf(:,inprof) = prof%ipqcf(:,ji) + newprof%itqcf(:,inprof) = prof%itqcf(:,ji) + newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:) + + ! npind is the index of the original profile + + newprof%npind(inprof) = ji + + ! Copy the variable information + + DO jvar = 1, prof%nvar + + lfirst = .TRUE. + + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + + IF ( llvvalid(jvar)%luse(jj) ) THEN + + invpro(jvar) = invpro(jvar) + 1 + + ! Book keeping information + + IF ( lfirst ) THEN + lfirst = .FALSE. + newprof%npvsta(inprof,jvar) = invpro(jvar) + ENDIF + newprof%npvend(inprof,jvar) = invpro(jvar) + + ! Variable data + + newprof%var(jvar)%mvk(invpro(jvar)) = & + & prof%var(jvar)%mvk(jj) + newprof%var(jvar)%nvpidx(invpro(jvar)) = & + & prof%var(jvar)%nvpidx(jj) + newprof%var(jvar)%nvlidx(invpro(jvar)) = & + & prof%var(jvar)%nvlidx(jj) + newprof%var(jvar)%nvqc(invpro(jvar)) = & + & prof%var(jvar)%nvqc(jj) + newprof%var(jvar)%idqc(invpro(jvar)) = & + & prof%var(jvar)%idqc(jj) + newprof%var(jvar)%idqcf(:,invpro(jvar))= & + & prof%var(jvar)%idqcf(:,jj) + newprof%var(jvar)%nvqcf(:,invpro(jvar))= & + & prof%var(jvar)%nvqcf(:,jj) + newprof%var(jvar)%vdep(invpro(jvar)) = & + & prof%var(jvar)%vdep(jj) + newprof%var(jvar)%vobs(invpro(jvar)) = & + & prof%var(jvar)%vobs(jj) + newprof%var(jvar)%vmod(invpro(jvar)) = & + & prof%var(jvar)%vmod(jj) + DO jext = 1, prof%next + newprof%var(jvar)%vext(invpro(jvar),jext) = & + & prof%var(jvar)%vext(jj,jext) + END DO + + ! nvind is the index of the original variable data + + newprof%var(jvar)%nvind(invpro(jvar)) = jj + + ENDIF + + END DO + + END DO + + ENDIF + + END DO + + ! Update MPP counters + + DO jvar = 1, prof%nvar + newprof%nvprot(jvar) = invpro(jvar) + END DO + CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& + & prof%nvar ) + + ! Set book keeping variables which do not depend on number of obs. + + newprof%nvar = prof%nvar + newprof%next = prof%next + newprof%nstp = prof%nstp + newprof%npi = prof%npi + newprof%npj = prof%npj + newprof%npk = prof%npk + newprof%cvars(:) = prof%cvars(:) + + ! Deallocate temporary data + + DO jvar = 1, prof%nvar + DEALLOCATE( llvvalid(jvar)%luse ) + END DO + + DEALLOCATE( llvalid%luse ) + + END SUBROUTINE obs_prof_compress + + SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_decompress *** + !! + !! ** Purpose : - Copy back information to original profile type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed profile type into the original + !! profile data and optionally deallocate the prof + !! data input + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof),INTENT(INOUT) :: prof ! Updated profile data + TYPE(obs_prof),INTENT(INOUT) :: oldprof ! Original profile data + LOGICAL,INTENT(in) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jl + + DO ji = 1, prof%nprof + + ! Copy header information + + jk = prof%npind(ji) + + oldprof%mi(jk,:) = prof%mi(ji,:) + oldprof%mj(jk,:) = prof%mj(ji,:) + oldprof%nfile(jk) = prof%nfile(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_read_altbias.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_read_altbias.F90 new file mode 100644 index 0000000000000000000000000000000000000000..57a8432c051ff9c194f574741eec96ae8d8e8713 --- /dev/null +++ b/V4.0/nemo_sources/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: obs_read_altbias.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_read_prof.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_read_prof.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a58f7df33189c97720a1106f209e06d90f8b928c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_read_prof.F90 @@ -0,0 +1,867 @@ +MODULE obs_read_prof + !!====================================================================== + !! *** MODULE obs_read_prof *** + !! Observation diagnostics: Read the T and S profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_pro_dri : Driver for reading profile obs + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_prep ! Prepare observation arrays + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_profiles_def ! Profile definitions + USE obs_conv ! Various conversion routines + USE obs_types ! Observation type definitions + USE netcdf ! NetCDF library + USE obs_oper ! Observation operators + USE lib_mpp ! For ctl_warn/stop + USE obs_fbm ! Feedback routines + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_prof ! Read the profile observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_prof.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), 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(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), 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%nfile(iprof) = jj + profdata%npfil(iprof) = ji + + ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_read_surf.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_read_surf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1102996b23aa1e3b36976f2e4d804c27927feb23 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_read_surf.F90 @@ -0,0 +1,497 @@ +MODULE obs_read_surf + !!====================================================================== + !! *** MODULE obs_read_surf *** + !! Observation diagnostics: Read the surface data from feedback files + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_surf : Driver for reading surface data from feedback files + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_surf_def ! Surface observation definitions + USE obs_types ! Observation type definitions + USE obs_fbm ! Feedback routines + USE netcdf ! NetCDF library + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_surf ! Read the surface observations from the point data + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_surf.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), 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(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iobs = 0 + + !----------------------------------------------------------------------- + ! Count the number of files needed and allocate the obfbdata type + !----------------------------------------------------------------------- + + inobf = knumfiles + + ALLOCATE( inpfiles(inobf) ) + + surf_files : DO jj = 1, inobf + + !--------------------------------------------------------------------- + ! Prints + !--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_rea_surf : Reading from file = ', & + & TRIM( TRIM( cdfilenames(jj) ) ) + WRITE(numout,*) ' ~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + !--------------------------------------------------------------------- + ! Initialization: Open file and get dimensions only + !--------------------------------------------------------------------- + + iflag = nf90_open( TRIM( TRIM( cdfilenames(jj) ) ), nf90_nowrite, & + & i_file_id ) + + IF ( iflag /= nf90_noerr ) THEN + + IF ( ldignmis ) THEN + inpfiles(jj)%nobs = 0 + CALL ctl_warn( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ELSE + CALL ctl_stop( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ENDIF + + ELSE + + !------------------------------------------------------------------ + ! Close the file since it is opened in read_obfbdata + !------------------------------------------------------------------ + + iflag = nf90_close( i_file_id ) + + !------------------------------------------------------------------ + ! Read the surface file into inpfiles + !------------------------------------------------------------------ + CALL init_obfbdata( inpfiles(jj) ) + CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & + & ldgrid = .TRUE. ) + + IF ( 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%nfile(iobs) = jj + surfdata%nsfil(iobs) = ji + + ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_readmdt.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_readmdt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c932b212812f4b92a564b93327130532b0ba7c92 --- /dev/null +++ b/V4.0/nemo_sources/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: obs_readmdt.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_rot_vel.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_rot_vel.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c1312e3ffa5c0e3ca793dcec07f54a9a4fb209e3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_rot_vel.F90 @@ -0,0 +1,232 @@ +MODULE obs_rot_vel + !!====================================================================== + !! *** MODULE obs_rot_vel *** + !! Observation diagnostics: Read the velocity profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rotvel : Rotate velocity data into N-S,E-W directorions + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_grid ! Grid search + USE obs_utils ! For error handling + USE obs_profiles_def ! Profile definitions + USE obs_inter_h2d ! Horizontal interpolation + USE obs_inter_sup ! MPP support routines for interpolation + USE geo2ocean ! Rotation of vectors + USE obs_fbm ! Feedback definitions + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rotvel ! Rotate the observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_rot_vel.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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, & + & CASTSP(glamu), zglamu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & CASTSP(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, & + & CASTSP(glamv), zglamv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & CASTSP(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_sort.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_sort.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5cfbaf252319e2ef832b9f152bd24eab254afebd --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_sort.F90 @@ -0,0 +1,146 @@ +MODULE obs_sort + !!===================================================================== + !! *** MODULE obs_sort *** + !! Observation diagnostics: Various tools for sorting etc. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sort_dp_indx : Get indicies for ascending order for a double prec. array + !! index_sort : Get indicies for ascending order for a double prec. array + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & dp + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE index_sort ! Get indicies for ascending order for a double prec. array + + PUBLIC sort_dp_indx ! Get indicies for ascending order for a double prec. array + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sort.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE sort_dp_indx( kvals, pvals, kindx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sort_dp_indx *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Call index_sort routine + !! + !! ** Action : + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of elements to be sorted + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pvals ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(OUT) :: & + & kindx ! Indices for ordering of array + + !! * Local declarations + + !----------------------------------------------------------------------- + ! Call qsort routine + !----------------------------------------------------------------------- + IF (kvals>=1) THEN + + CALL index_sort( pvals, kindx, kvals ) + + ENDIF + + END SUBROUTINE sort_dp_indx + + SUBROUTINE index_sort( pval, kindx, kvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Heapsort + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of values + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pval ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(INOUT) :: & + & kindx ! Indicies for ordering + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jt + INTEGER :: jn + INTEGER :: jparent + INTEGER :: jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + ji = kvals/2 + 1 + jn = kvals + + main_loop : DO + + IF ( ji > 1 ) THEN + ji = ji-1 + jt = kindx(ji) + ELSE + jt = kindx(jn) + kindx(jn) = kindx(1) + jn = jn-1 + IF ( jn <= 1 ) THEN + kindx(1) = jt + EXIT main_loop + ENDIF + ENDIF + + jparent = ji + jchild = 2 * ji + + inner_loop : DO + + IF ( jchild > jn ) EXIT inner_loop + IF ( jchild < jn ) THEN + IF ( pval(kindx(jchild)) < pval(kindx(jchild+1)) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( pval(jt) < pval(kindx(jchild))) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + + END DO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + END SUBROUTINE index_sort + +END MODULE obs_sort \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_sstbias.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_sstbias.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e91a16871911d0994ef68d8d3b5689aedebb2762 --- /dev/null +++ b/V4.0/nemo_sources/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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_surf_def.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_surf_def.F90 new file mode 100644 index 0000000000000000000000000000000000000000..29fcb5162ce07e1b6e3fc45f5664a3f84b459de0 --- /dev/null +++ b/V4.0/nemo_sources/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 + & nfile,& !: File number + & nsidx,& !: Surface observation number + & nsfil,& !: Surface observation number in file + & nyea, & !: Year of surface observation + & nmon, & !: Month of surface observation + & nday, & !: Day of surface observation + & nhou, & !: Hour of surface observation + & nmin, & !: Minute of surface observation + & mstp, & !: Time step nearest to surface observation + & nqc, & !: Surface observation qc flag + & ntyp !: Type of surface observation product + + CHARACTER(len=8), POINTER, DIMENSION(:) :: & + & cvars !: Variable names + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: WMO indentifier + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of surface observation + & rphi !: Latitude coordinate of surface observation + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & robs, & !: Surface observation + & rmod !: Model counterpart of the surface observation vector + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & rext !: Extra fields interpolated to observation points + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & vdmean !: Time averaged of model field + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & nsstp, & !: Local number of surface observations per time step + & nsstpmpp !: Global number of surface observations per time step + + ! Arrays with size equal to the number of observation records in the window + INTEGER, POINTER, DIMENSION(:) :: & + & mrecstp ! Time step of the records + + ! Arrays used to store source indices when + ! compressing obs_surf derived types + + ! Array with size nsurf + + INTEGER, POINTER, DIMENSION(:) :: & + & nsind !: Source indices of surface data in compressed data + + ! Is this a gridded product? + + LOGICAL :: lgrid + + END TYPE obs_surf + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_surf_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_alloc *** + !! + !! ** Purpose : - Allocate data for surface data arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surf ! Surface data to be allocated + INTEGER, INTENT(IN) :: ksurf ! Number of surface observations + INTEGER, INTENT(IN) :: kvar ! Number of surface variables + INTEGER, INTENT(IN) :: kextra ! Number of extra fields at observation points + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + + !!* Local variables + INTEGER :: ji + INTEGER :: jvar + + ! Set bookkeeping variables + + surf%nsurf = ksurf + surf%nsurfmpp = 0 + surf%nextra = kextra + surf%nvar = kvar + surf%nstp = kstp + surf%npi = kpi + surf%npj = kpj + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & surf%cvars(kvar) & + & ) + + DO jvar = 1, kvar + surf%cvars(jvar) = "NotSet" + END DO + + ! Allocate arrays of number of surface data size + + ALLOCATE( & + & surf%mi(ksurf), & + & surf%mj(ksurf), & + & surf%mt(ksurf), & + & surf%nfile(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%nfile, & + & surf%nsidx, & + & surf%nsfil, & + & surf%nyea, & + & surf%nmon, & + & surf%nday, & + & surf%nhou, & + & surf%nmin, & + & surf%mstp, & + & surf%nqc, & + & surf%ntyp, & + & surf%cwmo, & + & surf%rlam, & + & surf%rphi, & + & surf%nsind & + & ) + + ! Allocate arrays of number of surface data size * number of variables + + DEALLOCATE( & + & surf%robs, & + & surf%rmod & + & ) + + ! Deallocate arrays of number of extra fields at observation points + + DEALLOCATE( & + & surf%rext & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & surf%vdmean & + & ) + + ! Deallocate arrays of number of time step size + + DEALLOCATE( & + & surf%nsstp, & + & surf%nsstpmpp & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & surf%cvars & + & ) + + END SUBROUTINE obs_surf_dealloc + + SUBROUTINE obs_surf_compress( surf, newsurf, lallocate, kumout, lvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_surf type + !! into a new obs_surf type + !! + !! ** Method : - The data is copied from surf to new surf. + !! In the case of lvalid being present only the + !! selected data will be copied. + !! If lallocate is true the data in the newsurf is + !! allocated either with the same number of elements + !! as surf or with only the subset of elements defined + !! by the optional selection. + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(IN) :: surf ! Original surface data + TYPE(obs_surf), INTENT(INOUT) :: newsurf ! New surface data with a subset of the original data + LOGICAL,INTENT(IN) :: lallocate ! Allocate newsurf data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + LOGICAL, OPTIONAL, INTENT(in), DIMENSION(:) :: & + & lvalid ! Valid of surface observations + + !!* Local variables + INTEGER :: insurf + INTEGER :: ji + INTEGER :: jk + LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid + + ! Count how many elements there should be in the new data structure + + IF ( PRESENT(lvalid) ) THEN + insurf = 0 + DO ji = 1, surf%nsurf + IF ( lvalid(ji) ) THEN + insurf = insurf + 1 + ENDIF + END DO + ELSE + insurf = surf%nsurf + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_surf_alloc( newsurf, insurf, surf%nvar, & + & surf%nextra, surf%nstp, surf%npi, surf%npj ) + ENDIF + + ! Allocate temporary valid array to unify the code for both cases + + ALLOCATE( llvalid(surf%nsurf) ) + IF ( PRESENT(lvalid) ) THEN + llvalid(:) = lvalid(:) + ELSE + llvalid(:) = .TRUE. + ENDIF + + ! Setup bookkeeping variables + + insurf = 0 + + ! Loop over source surface data + + DO ji = 1, surf%nsurf + + IF ( llvalid(ji) ) THEN + + ! Copy the header information + + insurf = insurf + 1 + + newsurf%mi(insurf) = surf%mi(ji) + newsurf%mj(insurf) = surf%mj(ji) + newsurf%mt(insurf) = surf%mt(ji) + newsurf%nfile(insurf) = surf%nfile(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(:) + + ! Deallocate temporary data + + DEALLOCATE( llvalid ) + + END SUBROUTINE obs_surf_compress + + SUBROUTINE obs_surf_decompress( surf, oldsurf, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_decompress *** + !! + !! ** Purpose : - Copy back information to original surface data type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed surface data type into the original + !! surface data and optionally deallocate the surface + !! data input + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf),INTENT(INOUT) :: surf ! Updated surface data + TYPE(obs_surf),INTENT(INOUT) :: oldsurf ! Original surface data + LOGICAL,INTENT(IN) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + + ! Copy data from surf to old surf + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%mi(jj) = surf%mi(ji) + oldsurf%mj(jj) = surf%mj(ji) + oldsurf%mt(jj) = surf%mt(ji) + oldsurf%nfile(jj) = surf%nfile(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_types.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_types.F90 new file mode 100644 index 0000000000000000000000000000000000000000..45f3bab1486af47db2e19a60f64b9239a7f5c628 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_types.F90 @@ -0,0 +1,294 @@ +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 = 27 + CHARACTER(LEN=40), PUBLIC, DIMENSION(0:ntypalt) :: calttyp + + PUBLIC obs_typ_init + PUBLIC obs_wmo_init + PUBLIC obs_alt_typ_init + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_types.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize code tables + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + + CALL obs_wmo_init + + CALL obs_alt_typ_init + + END SUBROUTINE obs_typ_init + + SUBROUTINE obs_wmo_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize WMO code 1770 code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : WORLD METEOROLOGICAL ORGANIZATION + !! Manual on Codes + !! International Codes + !! VOLUME I.1 (Annex II to WMO Technical Regulations) + !! Part A -- Alphanumeric Codes + !! 1995 edition + !! WMO-No. 306 + !! Secretariat of the World Meteorological Organization + !! Geneva, Switzerland + !! + !! History : + !! ! : 2007-04 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + INTEGER :: ji + + DO ji = 0, ntyp1770 + + cwmonam1770(ji) = 'Not defined' + ctypshort(ji) = '---' + +! IF ( ji < 1000 ) THEN +! WRITE(cwmotyp1770(ji),'(1X,I3.3)') ji +! ELSE +! WRITE(cwmotyp1770(ji),'(I4.4)') ji +! ENDIF + + END DO + + cwmonam1770( 1) = 'Sippican T-4' + cwmonam1770( 2) = 'Sippican T-4' + cwmonam1770( 11) = 'Sippican T-5' + cwmonam1770( 21) = 'Sippican Fast Deep' + cwmonam1770( 31) = 'Sippican T-6' + cwmonam1770( 32) = 'Sippican T-6' + cwmonam1770( 41) = 'Sippican T-7' + cwmonam1770( 42) = 'Sippican T-7' + cwmonam1770( 51) = 'Sippican Deep Blue' + cwmonam1770( 52) = 'Sippican Deep Blue' + cwmonam1770( 61) = 'Sippican T-10' + cwmonam1770( 71) = 'Sippican T-11' + cwmonam1770( 201) = 'TSK T-4' + cwmonam1770( 202) = 'TSK T-4' + cwmonam1770( 211) = 'TSK T-6' + cwmonam1770( 212) = 'TSK T-6' + cwmonam1770( 221) = 'TSK T-7' + cwmonam1770( 222) = 'TSK T-7' + cwmonam1770( 231) = 'TSK T-5' + cwmonam1770( 241) = 'TSK T-10' + cwmonam1770( 251) = 'TSK Deep Blue' + cwmonam1770( 252) = 'TSK Deep Blue' + cwmonam1770( 261) = 'TSK AXBT ' + cwmonam1770( 401) = 'Sparton XBT-1' + cwmonam1770( 411) = 'Sparton XBT-3' + cwmonam1770( 421) = 'Sparton XBT-4' + cwmonam1770( 431) = 'Sparton XBT-5' + cwmonam1770( 441) = 'Sparton XBT-5DB' + cwmonam1770( 451) = 'Sparton XBT-6' + cwmonam1770( 461) = 'Sparton XBT-7' + cwmonam1770( 462) = 'Sparton XBT-7' + cwmonam1770( 471) = 'Sparton XBT-7DB' + cwmonam1770( 481) = 'Sparton XBT-10' + cwmonam1770( 491) = 'Sparton XBT-20' + cwmonam1770( 501) = 'Sparton XBT-20DB' + cwmonam1770( 510) = 'Sparton 536 AXBT' + cwmonam1770( 700) = 'Sippican XCTD standard' + cwmonam1770( 710) = 'Sippican XCTD deep' + cwmonam1770( 720) = 'Sippican AXCTD' + cwmonam1770( 730) = 'Sippican SXCTD' + cwmonam1770( 741) = 'TSK XCTD' + cwmonam1770( 742) = 'TSK XCTD-2 ' + cwmonam1770( 743) = 'TSK XCTD-2F ' + cwmonam1770( 751) = 'TSK AXCTD ' + cwmonam1770( 800) = 'Mechanical BT' + cwmonam1770( 810) = 'Hydrocast' + cwmonam1770( 820) = 'Thermistor Chain' + cwmonam1770( 825) = 'Temperature (sonic) and pressure probes' + cwmonam1770( 830) = 'CTD' + cwmonam1770( 831) = 'CTD-P-ALACE float' + cwmonam1770( 840) = 'PROVOR, No conductivity sensor ' + cwmonam1770( 841) = 'PROVOR, Seabird conductivity sensor ' + cwmonam1770( 842) = 'PROVOR, FSI conductivity sensor ' + cwmonam1770( 845) = 'Web Research, No conductivity sensor ' + cwmonam1770( 846) = 'Web Research, Seabird conductivity sensor ' + cwmonam1770( 847) = 'Web Research. FSI conductivity sensor' + cwmonam1770( 850) = 'SOLO, No conductivity sensor ' + cwmonam1770( 851) = 'SOLO, Seabird conductivity sensor ' + cwmonam1770( 852) = 'SOLO, FSI conductivity sensor' + cwmonam1770( 855) = 'Profiling float, NINJA, no conductivity sensor' + cwmonam1770( 856) = 'Profiling float, NINJA, SBE conductivity sensor' + cwmonam1770( 857) = 'Profiling float, NINJA, FSI conductivity sensor' + cwmonam1770( 858) = 'Profiling float, NINJA, TSK conductivity sensor' + cwmonam1770( 900) = 'Sippican T-12 XBT' + cwmonam1770(1023) = 'Missing value' + + DO ji = 853, 854 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 859, 899 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 901, 999 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 1000, 1022 + cwmonam1770(ji) = 'Reserved' + END DO + + ctypshort(800) = 'MBT' + ctypshort(401) = 'XBT' + ctypshort(830) = 'CTD' + ctypshort(820) = 'MRB' + ctypshort(831) = 'PFL' + ctypshort(995) = 'DRB' + ctypshort(997) = 'APB' + ctypshort(996) = 'UOR' + ctypshort(700:799) = 'OSD' + + END SUBROUTINE obs_wmo_init + + SUBROUTINE obs_alt_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_alt_typ_init *** + !! + !! ** Purpose : Initialize CLS altimeter code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : CLS + !1 SSALTO/DUACS User Handbook + !! (M)SLA and (M)ADT Near-Real Time and + !! Delayed time products + !! CLS-DOS-NT-06-034 + !! 2006 + !! CLS + !! 8-10 Rue Hermes + !! Parc Technologique du Canal + !! 31526 Ramonville St-Agne + !! France + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !! ! : 2017-05 (H. Zuo) Add support for more altimeter missions + !! ! : 2019-06 (H. Zuo) Add support for S3B and J2G + !! ! : 2019-10 (H. Zuo) Add support for E1G + !! ! : 2020-06 (H. Zuo) Add support for H2B + !! ! : 2020-11 (H. Zuo) Add support for C2N + !! ! : 2022-04 (H. Zuo) Add support for S6A + !! ! : 2022-06 (E. de Boisseson) updated to + !! DT2021 naming (H2A/H2AG) + !!---------------------------------------------------------------------- + !! * 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' + calttyp(9) = 'Jason-1 new' + calttyp(10) = 'Jason-1 geodetic' + calttyp(11) = 'Envisat new' + calttyp(12) = 'Saral/AltiKa' + calttyp(13) = 'Cryosat-2' + calttyp(14) = 'HY-2A' + calttyp(15) = 'Jason-3' + calttyp(16) = 'Jason-2 new' + calttyp(17) = 'Sentinel-3A' + calttyp(18) = 'AltiKa drifting' + calttyp(19) = 'HY-2A geodetic' + calttyp(20) = 'Jason-2 g' + calttyp(21) = 'Sentinel-3B' + calttyp(22) = 'ERS-1 g' + calttyp(23) = 'HY-2B' + calttyp(24) = 'Cryosat-2 N' + calttyp(25) = 'Sentinel-6A' + calttyp(26) = 'HY-2A new' + calttyp(27) = 'HY-2A geodetic new' + + END SUBROUTINE obs_alt_typ_init + +END MODULE obs_types \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_utils.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_utils.F90 new file mode 100644 index 0000000000000000000000000000000000000000..18da9ac3fc8d8833ad3e3d2dcb302b6764b14fb1 --- /dev/null +++ b/V4.0/nemo_sources/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: obs_utils.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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, INTENT(IN) :: 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, INTENT(IN) :: kndim ! Expected number of dimensions + INTEGER, DIMENSION(kndim) :: kdim ! Expected dimensions + CHARACTER(LEN=*) :: cd_name ! Calling routine name + INTEGER, INTENT(IN) :: klineno ! Calling line number + + !! * Local declarations + INTEGER :: indim + INTEGER, ALLOCATABLE, DIMENSION(:) :: & + & idim,ilendim + INTEGER :: ji + LOGICAL :: llerr + CHARACTER(len=200) :: clineno + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, ndims=indim ), & + & cd_name, klineno ) + + ALLOCATE(idim(indim),ilendim(indim)) + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, dimids=idim ), & + & cd_name, klineno ) + + DO ji = 1, indim + CALL chkerr( nf90_inquire_dimension( kfileid, idim(ji), & + & len=ilendim(ji) ), & + & cd_name, klineno ) + END DO + + IF ( indim /= kndim ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf no dim error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + + DO ji = 1, indim + IF ( ilendim(ji) /= kdim(ji) ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf dim len error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + END DO + + DEALLOCATE(idim,ilendim) + + END SUBROUTINE chkdim + + SUBROUTINE fatal_error( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE fatal_error *** + !! + !! ** Purpose : Fatal error handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*), INTENT(IN) :: cd_name + !! * Local declarations + CHARACTER(len=200) :: clineno + + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' fatal_error', ' Error in ' // TRIM( cd_name ), & + & clineno) + + END SUBROUTINE fatal_error + + SUBROUTINE warning( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE warning *** + !! + !! ** Purpose : Warning handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*), INTENT(IN) :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obs_write.F90 b/V4.0/nemo_sources/src/OCE/OBS/obs_write.F90 new file mode 100644 index 0000000000000000000000000000000000000000..12a334ea2c24df5ca6c9d029afde51b8c6ca5e49 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obs_write.F90 @@ -0,0 +1,713 @@ +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 + USE lib_fortran ! For global sum + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC obs_wri_prof, & ! Write profile observation files + & obs_wri_surf, & ! Write surface observation files + & obswriinfo, & + & cn_feedback_outdir ! Output directory + + 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 + CHARACTER(len=lc) :: cn_feedback_outdir = './' + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_write.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_wri_prof( profdata, ld_split, nf, 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 + LOGICAL, INTENT(IN) :: ld_split ! Split output files according to input files + INTEGER :: nf ! Number of input files + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata,fbsplit + 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 + INTEGER :: jf,jfmax + REAL(wp) :: zpres + LOGICAL, DIMENSION(MAX(profdata%nprof,1)) :: lvalid + + 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' + + IF (.NOT.ld_split) THEN + + 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 + + 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 + + IF (.NOT.ld_split) THEN + + ! Write the obfbdata structure + CALL write_obfbdata( TRIM(cn_feedback_outdir)//'/'//clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + ELSE + + ! Split files according to input file number + + DO jf = 1, nf + + CALL init_obfbdata( fbsplit ) + + ! Construct new data structure + IF( profdata%nprof > 0 ) THEN + lvalid(:) = ( profdata%nfile(:) == jf ) + ELSE + lvalid(:) = .FALSE. + ENDIF + CALL subsamp_obfbdata( fbdata, fbsplit, lvalid ) + + ! Write data + + WRITE(clfname, FMT="(A,I2.2,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype)//'_', jf, nproc + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*)'obs_wri_prof :' + WRITE(numout,*)'~~~~~~~~~~~~~' + WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) + ENDIF + + ! Write the obfbdata structure + CALL write_obfbdata( TRIM(cn_feedback_outdir)//'/'//clfname, fbsplit) + + ! Output some basic statistics + CALL obs_wri_stats( fbsplit ) + + CALL dealloc_obfbdata( fbsplit ) + + + ENDDO + + ENDIF + + CALL dealloc_obfbdata( fbdata ) + + END SUBROUTINE obs_wri_prof + + SUBROUTINE obs_wri_surf( surfdata, ld_split, nf, 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 + LOGICAL, INTENT(IN) :: ld_split ! Split output files according to input files + INTEGER :: nf ! Number of input files + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata, fbsplit + 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 :: jf,jfmax + INTEGER :: iadd + INTEGER :: iext + LOGICAL, DIMENSION(MAX(surfdata%nsurf,1)) :: lvalid + + 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' + + IF (.NOT.ld_split) THEN + + 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 + + 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 + + IF (.NOT.ld_split) THEN + + ! Write the obfbdata structure + CALL write_obfbdata( TRIM(cn_feedback_outdir)//'/'//clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + ELSE + + ! Split files according to input file number + + DO jf = 1, nf + + CALL init_obfbdata( fbsplit ) + + ! Construct new data structure + IF ( surfdata%nsurf > 0 ) THEN + lvalid(:) = ( surfdata%nfile(:) == jf ) + ELSE + lvalid(:) = .FALSE. + ENDIF + CALL subsamp_obfbdata( fbdata, fbsplit, lvalid ) + + ! Write data + + WRITE(clfname, FMT="(A,I2.2,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype)//'_', jf, 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 + + ! Write the obfbdata structure + CALL write_obfbdata( TRIM(cn_feedback_outdir)//'/'//clfname, fbsplit) + + ! Output some basic statistics + CALL obs_wri_stats( fbsplit ) + + CALL dealloc_obfbdata( fbsplit ) + + + ENDDO + + ENDIF + + 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), DIMENSION(fbdata%nlev*fbdata%nobs) :: ztmpx + REAL(wp), DIMENSION(fbdata%nlev*fbdata%nobs) :: ztmpx2 + 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 + 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 + inumgoodobs=inumgoodobs+1 + zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) + ztmpx(inumgoodobs)=zomb + ztmpx2(inumgoodobs)=zomb*zomb + ENDIF + ENDDO + ENDDO + + CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) + zsumx = glob_sum( 'obs_wri_stats', CASTDP(ztmpx (1:inumgoodobs)) ) + zsumx2 = glob_sum( 'obs_wri_stats', CASTDP(ztmpx2(1:inumgoodobs)) ) + + IF (lwp) THEN + WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp + IF (inumgoodobsmpp /= 0) THEN + 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 ) + ENDIF + WRITE(numout,*) '' + ENDIF + + ENDDO + + END SUBROUTINE obs_wri_stats + +END MODULE obs_write diff --git a/V4.0/nemo_sources/src/OCE/OBS/obsinter_h2d.h90 b/V4.0/nemo_sources/src/OCE/OBS/obsinter_h2d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..6f6408c5b7b1c31e89f495e557fba63d6c482e8a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obsinter_h2d.h90 @@ -0,0 +1,1390 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_h2d.h90 10353 2018-11-21 16:04:47Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_h2d_init( kpk, kpk2, k2dint, plam, pphi, & + & pglam, pgphi, pmask, pweig, pobsmask, & + & iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Computes weights for horizontal interpolation to the + !! observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! Interpolation Schemes : + !! + !! 1) k2dint = 0: Distance-weighted interpolation scheme 1 + !! + !! The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). Distance (s) is computed + !! using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) + !! x cos( lamB - lamA ) ) + !! + !! 2) k2dint = 1: Distance-weighted interpolation scheme 2 + !! + !! As k2dint = 0 but with distance (ds) computed using + !! a small-angle approximation to the great-circle formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! 3) k2dint = 2: Bilinear interpolation on a geographical grid + !! + !! The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! 4) k2dint = 3: General bilinear remapping interpolation + !! + !! An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! 5) k2dint = 4: Polynomial interpolation + !! + !! The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + !! + a4(i) * phi * plam + !! + !! through the model values at the four surrounding grid points. + !! + !! ** Action : + !! + !! References : Jones, P.: A users guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alomos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & k2dint ! Interpolation scheme options + ! = 0 distance-weighted (great circle) + ! = 1 distance-weighted (small angle) + ! = 2 bilinear (geographical grid) + ! = 3 bilinear (quadrilateral grid) + ! = 4 polynomial (quadrilateral grid) + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: & + & pglam, & ! Model variable lat + & pgphi ! Model variable lon + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsmask ! Vertical mask for observations + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax, & + & iamb1, & + & iamb2 + REAL(KIND=wp) :: & + & zphimm, & + & zphimp, & + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zphimin, & + & zphimax, & + & zlammin, & + & zlammax + REAL(KIND=wp), DIMENSION(kpk2) :: & + & z2dmm, & + & z2dmp, & + & z2dpm, & + & z2dpp, & + & z2dmmt, & + & z2dmpt, & + & z2dpmt, & + & z2dppt, & + & zsum + LOGICAL :: & + & ll_ds1, & + & ll_skip, & + & ll_fail + + INTEGER :: i, j + + !------------------------------------------------------------------------ + ! 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) + IF (ISNAN(z2dpm(jk))) THEN + WRITE(mpprank+1000,*) "NaNs in z2dpm(jk) OUTSIDE IF at", jk + CALL FLUSH(mpprank+1000) + CALL ctl_stop( 'obs_int_h2d_init: NaNs encountered in z2dpm' ) + ENDIF + IF (ISNAN(z2dpp(jk))) THEN + WRITE(mpprank+1000,*) "NaNs in z2dpp(jk) OUTSIDE IF at", jk + CALL FLUSH(mpprank+1000) + CALL ctl_stop( 'obs_int_h2d_init: NaNs encountered in z2dpp' ) + ENDIF + ! 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) + + IF (ISNAN(z2dpmt(jk))) THEN + WRITE(mpprank+1000,*) "NaNs in z2dpmt(jk) INSIDE IF at", jk + CALL FLUSH(mpprank+1000) + CALL ctl_stop( 'obs_int_h2d_init: NaNs encountered in z2dpmt' ) + ENDIF + IF (ISNAN(z2dppt(jk))) THEN + WRITE(mpprank+1000,*) "NaNs in z2dppt(jk) INSIDE IF at", jk + CALL FLUSH(mpprank+1000) + CALL ctl_stop( 'obs_int_h2d_init: NaNs encountered in z2dppt' ) + ENDIF + + ! 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 + + REAL(KIND=dp) :: test + + !---------------------------------------------------------------------- + ! 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 + test = REAL(zbiwmm,dp) * REAL(pmask(1,1,jk),dp) + IF (test > 10.0**38.0_dp) THEN + WRITE(mpprank+1000,*) 'overflow', jk, test, zbiwmm, pmask(1,1,jk) + CALL FLUSH(mpprank+1000) + ENDIF + p2dmm(jk) = zbiwmm * pmask(1,1,jk) + p2dmp(jk) = zbiwmp * pmask(1,2,jk) + p2dpm(jk) = zbiwpm * pmask(2,1,jk) + p2dpp(jk) = zbiwpp * pmask(2,2,jk) + END DO + ENDIF + + END SUBROUTINE obs_int_h2d_bir + + SUBROUTINE obs_int_h2d_pol( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_pol *** + !! + !! ** Purpose : Polynomial interpolation (k2dint = 4) + !! + !! ** Method : The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + a4(i) * phi * plam + !! + !! through the model values at four surrounding grid pts (i=1,4). + !! As k2dint = 0 but with distance (ds) computed using a small- + !! angle approximation to the great-circle distance formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zplp + REAL(KIND=wp), DIMENSION(4,4) :: & + & zmat, & + & zmati + + !------------------------------------------------------------------------ + ! Polynomial interpolation + !------------------------------------------------------------------------ + zmat(1,1) = 1.0_wp + zmat(1,2) = 1.0_wp + zmat(1,3) = 1.0_wp + zmat(1,4) = 1.0_wp + zmat(2,1) = plammm + zmat(2,2) = plammp + zmat(2,3) = plampm + zmat(2,4) = plampp + zmat(3,1) = pphimm + zmat(3,2) = pphimp + zmat(3,3) = pphipm + zmat(3,4) = pphipp + zmat(4,1) = plammm * pphimm + zmat(4,2) = plammp * pphimp + zmat(4,3) = plampm * pphipm + zmat(4,4) = plampp * pphipp + + CALL lu_invmat( zmat, 4, zmati ) + + zplp = plam * pphi + DO jk = 1, kmax + p2dmm(jk) = ABS( zmati(1,1) + zmati(1,2) * plam & + & + zmati(1,3) * pphi + zmati(1,4) * zplp ) & + & * pmask(1,1,jk) + p2dmp(jk) = ABS( zmati(2,1) + zmati(2,2) * plam & + & + zmati(2,3) * pphi + zmati(2,4) * zplp ) & + & * pmask(1,2,jk) + p2dpm(jk) = ABS( zmati(3,1) + zmati(3,2) * plam & + & + zmati(3,3) * pphi + zmati(3,4) * zplp ) & + & * pmask(2,1,jk) + p2dpp(jk) = ABS( zmati(4,1) + zmati(4,2) * plam & + & + zmati(4,3) * pphi + zmati(4,4) * zplp ) & + & * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_pol + + SUBROUTINE bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & pbiwmm, pbiwmp, pbiwpm, pbiwpp, & + & pphi , plam, ldfail ) + !!------------------------------------------------------------------- + !! + !! *** ROUTINE bil_wgt *** + !! + !! ** Purpose : Compute the weights for a bilinear remapping + !! interpolation scheme. + !! + !! ** Method : This scheme is appropriate for bilinear interpolation + !! on a general quadrilateral grid. + !! This scheme is also used in OASIS. + !! + !! This routine is a derivative of the SCRIP software. + !! Copyright 1997, 1998 the Regents of the University + !! of California. See SCRIP_Copyright.txt. + !! + !! ** Action : + !! + !! References : Jones, P.: A user's guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alamos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), INTENT(OUT) :: & + & pbiwmm, & ! Interpolation weights + & pbiwmp, & + & pbiwpm, & + & pbiwpp + LOGICAL, INTENT(out) :: & + & ldfail + + !! * Local declarations + INTEGER :: & + & jiter + INTEGER :: & + & itermax + REAL(KIND=wp) :: & + & zphi, & ! Geographical location of observation + & zlam, & + & zphimm, & ! Geographical location of surrounding + & zphimp, & ! model grid points + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zdth1, & + & zdth2, & + & zdth3, & + & zdthp, & + & zdph1, & + & zdph2, & + & zdph3, & + & zdphp, & + & zmat1, & + & zmat2, & + & zmat3, & + & zmat4, & + & zdeli, & + & zdelj, & + & ziguess, & + & zjguess, & + & zeps, & + & zdeterm, & + & z2pi, & + & zhpi + + ! Initialization + + ! Conversion to radians + + zphi = pphi * rad + zlam = plam * rad + zphimm = pphimm * rad + zphimp = pphimp * rad + zphipm = pphipm * rad + zphipp = pphipp * rad + zlammm = plammm * rad + zlammp = plammp * rad + zlampm = plampm * rad + zlampp = plampp * rad + + ldfail = .FALSE. + + zdth1 = zphipm - zphimm + zdth2 = zphimp - zphimm + zdth3 = zphipp - zphipm - zdth2 + + zdph1 = zlampm - zlammm + zdph2 = zlammp - zlammm + zdph3 = zlampp - zlampm + + z2pi = 2.0_wp * rpi + + IF ( zdph1 > 3.0_wp * rpi ) zdph1 = zdph1 - z2pi + IF ( zdph2 > 3.0_wp * rpi ) zdph2 = zdph2 - z2pi + IF ( zdph3 > 3.0_wp * rpi ) zdph3 = zdph3 - z2pi + IF ( zdph1 < -3.0_wp * rpi ) zdph1 = zdph1 + z2pi + IF ( zdph2 < -3.0_wp * rpi ) zdph2 = zdph2 + z2pi + IF ( zdph3 < -3.0_wp * rpi ) zdph3 = zdph3 + z2pi + + zdph3 = zdph3 - zdph2 + + ziguess = 0.5_wp + zjguess = 0.5_wp + + itermax = 100 + + IF ( wp == sp ) THEN + zeps = 1.0e-6_wp ! Single precision + ELSE + zeps = 1.0e-10_wp ! Double precision + ENDIF + + !------------------------------------------------------------------------ + ! Iterate to determine (i,j) in new coordinate system + !------------------------------------------------------------------------ + jiter_loop: DO jiter = 1, itermax + + zdthp = zphi - zphimm - zdth1 * ziguess - zdth2 * zjguess & + & - zdth3 * ziguess * zjguess + zdphp = zlam - zlammm + + zhpi = 0.5_wp * rpi + IF ( zdphp > 3.0_wp * zhpi ) zdphp = zdphp - z2pi + IF ( zdphp < -3.0_wp * zhpi ) zdphp = zdphp + z2pi + + zdphp = zdphp - zdph1 * ziguess - zdph2 * zjguess & + & - zdph3 * ziguess * zjguess + + zmat1 = zdth1 + zdth3 * zjguess + zmat2 = zdth2 + zdth3 * ziguess + zmat3 = zdph1 + zdph3 * zjguess + zmat4 = zdph2 + zdph3 * ziguess + + ! Matrix determinant + zdeterm = zmat1 * zmat4 - zmat2 * zmat3 + + zdeli = ( zdthp * zmat4 - zmat2 * zdphp) / zdeterm + zdelj = ( zmat1 * zdphp - zdthp * zmat3) / zdeterm + + IF ( ABS( zdeli ) < zeps .AND. ABS( zdelj ) < zeps ) EXIT jiter_loop + + ziguess = ziguess + zdeli + zjguess = zjguess + zdelj + + ! DJL prevent ziguess and zjguess from going outside the range + ! 0 to 1 + ! prevents interpolated value going wrong + ! for example sea ice concentration gt 1 + + IF ( ziguess < 0 ) ziguess = 0.0_wp + IF ( zjguess < 0 ) zjguess = 0.0_wp + IF ( ziguess > 1 ) ziguess = 1.0_wp + IF ( zjguess > 1 ) zjguess = 1.0_wp + + END DO jiter_loop + + IF ( jiter <= itermax ) THEN + + ! Successfully found i,j, now compute the weights + + pbiwmm = ( 1.0_wp - ziguess ) * ( 1.0_wp - zjguess ) + pbiwmp = ( 1.0_wp - ziguess ) * zjguess + pbiwpm = ziguess * ( 1.0_wp - zjguess ) + pbiwpp = ziguess * zjguess + + ELSEIF ( jiter > itermax ) THEN + + IF(lwp) THEN + + WRITE(numout,*)'Obs lat/lon : ',pphi, plam + WRITE(numout,*)'Grid lats : ',pphimm, pphimp, pphipm, pphipp + WRITE(numout,*)'Grid lons : ',plammm, plammp, plampm, plampp + WRITE(numout,*)'Current i,j : ',ziguess, zjguess + WRITE(numout,*)'jiter = ',jiter + WRITE(numout,*)'zeps = ',zeps + WRITE(numout,*)'zdeli, zdelj = ',zdeli, zdelj + WRITE(numout,*)' Iterations for i,j exceed max iteration count!' + WRITE(numout,*) + + ldfail = .TRUE. + + ENDIF + + ENDIF + + END SUBROUTINE bil_wgt + + SUBROUTINE lu_invmat( pmatin, kdim, pmatou ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_invmat *** + !! + !! ** Purpose : Invert a matrix using LU decomposition. + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !! ! 06-11 (NEMOVAR task force) Fix declaration of zd. + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim ! Array dimension + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: & + & pmatin + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: & + & pmatou + + !! * Local declarations + INTEGER :: & + & ji, & + & jj + INTEGER, DIMENSION(kdim) :: & + & indx + REAL(KIND=wp), DIMENSION(kdim,kdim) :: & + & zmat + REAL(KIND=wp) :: & + & zd + + ! Invert the matrix + DO jj = 1, kdim + DO ji = 1, kdim + pmatou(ji,jj) = 0.0_wp + zmat(ji,jj) = pmatin(ji,jj) + END DO + pmatou(jj,jj) = 1.0_wp + END DO + CALL lu_decomp( zmat, kdim, kdim, indx, zd ) + DO jj = 1, kdim + CALL lu_backsb( zmat, kdim, kdim, indx, pmatou(1,jj) ) + END DO + + END SUBROUTINE lu_invmat + + SUBROUTINE lu_decomp( pmatin, kdim1, kdim2, kindex, pflt ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_decomp *** + !! + !! ** Purpose : Compute the LU decomposition of a matrix + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(OUT) :: & + & kindex + REAL(KIND=wp), INTENT(OUT) :: & + & pflt + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: & + & pmatin + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpmax = 100 + REAL(KIND=wp), PARAMETER :: & + & pptiny = 1.0e-20_wp + REAL(KIND=wp), DIMENSION(jpmax) :: & + & zvv + INTEGER :: & + & ji, & + & jj, & + & jk + INTEGER :: & + & imax + REAL(KIND=wp) :: & + & zsum, & + & zdum, & + & zaamax + + imax = -1 + ! Main computation + pflt = 1.0_wp + DO ji = 1, kdim1 + zaamax = 0.0_wp + DO jj = 1, kdim1 + IF ( ABS( pmatin(ji,jj) ) > zaamax ) zaamax = ABS( pmatin(ji,jj) ) + END DO + IF ( zaamax == 0.0_wp ) THEN + CALL ctl_stop( 'singular matrix' ) + ENDIF + zvv(ji) = 1.0_wp / zaamax + END DO + DO jj = 1, kdim1 + DO ji = 1, jj-1 + zsum = pmatin(ji,jj) + DO jk = 1, ji-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + END DO + zaamax = 0.0_wp + DO ji = jj, kdim1 + zsum = pmatin(ji,jj) + DO jk = 1, jj-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + zdum = zvv(ji) * ABS( zsum ) + IF ( zdum >= zaamax ) THEN + imax = ji + zaamax = zdum + ENDIF + END DO + IF ( jj /= imax ) THEN + DO jk = 1, kdim1 + zdum = pmatin(imax,jk) + pmatin(imax,jk) = pmatin(jj,jk) + pmatin(jj,jk) = zdum + END DO + pflt = -pflt + zvv(imax) = zvv(jj) + ENDIF + kindex(jj) = imax + IF ( pmatin(jj,jj) == 0.0_wp ) pmatin(jj,jj) = pptiny + IF ( jj /= kdim1 ) THEN + zdum = 1.0_wp / pmatin(jj,jj) + DO ji = jj+1, kdim1 + pmatin(ji,jj) = pmatin(ji,jj) * zdum + END DO + ENDIF + END DO + + END SUBROUTINE lu_decomp + + SUBROUTINE lu_backsb( pmat, kdim1, kdim2, kindex, pvect ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_backsb *** + !! + !! ** Purpose : Back substitution + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(IN) :: & + & kindex + REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: & + & pvect + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: & + & pmat + + !! * Local declarations + INTEGER :: & + & ji, & + & jii, & + & jj, & + & jll + REAL(KIND=wp) :: & + & zsum + + ! Main computation + jii = 0 + DO ji = 1, kdim1 + jll = kindex(ji) + zsum = pvect(jll) + pvect(jll) = pvect(ji) + IF ( jii /= 0 ) THEN + DO jj = jii, ji-1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + ELSEIF ( zsum /= 0.0_wp ) THEN + jii = ji + ENDIF + pvect(ji) = zsum + END DO + DO ji = kdim1, 1, -1 + zsum = pvect(ji) + DO jj = ji+1, kdim1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + pvect(ji) = zsum / pmat(ji,ji) + END DO + + END SUBROUTINE lu_backsb \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/obsinter_z1d.h90 b/V4.0/nemo_sources/src/OCE/OBS/obsinter_z1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..009774f90f564fe7b71241c59b9d97b3b5f71b07 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/obsinter_z1d.h90 @@ -0,0 +1,235 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_z1d.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 + & k1dint, & ! 0 = linear; 1 = cubic spline interpolation + & 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) ) + + ! Where both levels are masked, return a fill value + + IF ( ( pobsmask(kkco(jdep)-1) == 0.0_wp ) .AND. (pobsmask(kkco(jdep)) == 0.0_wp) ) THEN + + pobs(jdep) = 0.0_wp + + ELSE + + ! Where upper level is masked (e.g., under ice cavity), only use deeper level + ! otherwise where obs is at or above upper level model T-point, + ! use upper model level rather than extrapolate + + IF ( pobsmask(kkco(jdep)-1) == 0.0_wp ) THEN + z1dm = 0.0_wp + ELSE IF ( pobsdep(jdep) <= pdep(kkco(jdep)-1) ) THEN + z1dp = 0.0_wp + END IF + + ! Where deeper level is masked (e.g., near sea bed), only use upper level + ! otherwise where ob is at or below deeper level model T-point, + ! use deeper model level rather than extrapolate + + IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN + z1dp = 0.0_wp + ELSE IF ( pobsdep(jdep) >= pdep(kkco(jdep) ) ) THEN + z1dm = 0.0_wp + END IF + + zsum = z1dm + z1dp + + IF ( k1dint == 0 ) THEN + + !----------------------------------------------------------------- + ! Linear interpolation + !----------------------------------------------------------------- + + pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) & + & + z1dp * pobsk(kkco(jdep) ) ) / zsum + + ELSE IF ( 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 + + END IF + + END IF + + END DO + + END SUBROUTINE obs_int_z1d + + SUBROUTINE obs_int_z1d_spl( & + & kpk, & + & pobsk, & + & pobs2k, & + & pdep, & + & pobsmask ) + !!-------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d_spl *** + !! + !! ** Purpose : Compute the local vector of vertical second-derivatives + !! of the interpolating function used with a cubic spline. + !! + !! ** Method : + !! + !! Top and bottom boundary conditions on the 2nd derivative are + !! set to zero. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 01-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: & + & pobs2k ! 2nd derivative of the interpolating function + + !! * Local declarations + INTEGER :: jk + REAL(KIND=wp) :: za + REAL(KIND=wp) :: zb + REAL(KIND=wp) :: zc + REAL(KIND=wp) :: zpa + REAL(KIND=wp) :: zkm + REAL(KIND=wp) :: zkp + REAL(KIND=wp) :: zk + REAL(KIND=wp), DIMENSION(kpk-1) :: & + & zs, & + & zp, & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Matrix initialisation + !----------------------------------------------------------------------- + zs(1) = 0.0_wp + zp(1) = 0.0_wp + zv(1) = -0.5_wp + DO jk = 2, kpk-1 + zs(jk) = ( pdep(jk ) - pdep(jk-1) ) & + & / ( pdep(jk+1) - pdep(jk-1) ) + zp(jk) = zs(jk) * zv(jk-1) + 2.0_wp + zv(jk) = ( zs(jk) - 1.0_wp ) / zp(jk) + END DO + + !----------------------------------------------------------------------- + ! Solution of the tridiagonal system + !----------------------------------------------------------------------- + + ! Top boundary condition + zu(1) = 0.0_wp + + DO jk = 2, kpk-1 + za = pdep(jk+1) - pdep(jk-1) + zb = pdep(jk+1) - pdep(jk ) + zc = pdep(jk ) - pdep(jk-1) + + zpa = 6.0_wp / ( zp(jk) * za ) + zkm = zpa / zc + zkp = zpa / zb + zk = - ( zkm + zkp ) + + zu(jk) = pobsk(jk+1) * zkp & + & + pobsk(jk ) * zk & + & + pobsk(jk-1) * zkm & + & + zu(jk-1) * ( -zs(jk) / zp(jk) ) + END DO + + !----------------------------------------------------------------------- + ! Second derivative + !----------------------------------------------------------------------- + pobs2k(kpk) = 0.0_wp + + ! Bottom boundary condition + DO jk = kpk-1, 1, -1 + pobs2k(jk) = zv(jk) * pobs2k(jk+1) + zu(jk) + IF ( pobsmask(jk+1) == 0.0_wp ) pobs2k(jk) = 0.0_wp + END DO + + END SUBROUTINE obs_int_z1d_spl \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/OBS/str_c_to_for.h90 b/V4.0/nemo_sources/src/OCE/OBS/str_c_to_for.h90 new file mode 100644 index 0000000000000000000000000000000000000000..97f8ef1f17e4b340aefa7a9995de95b2f553e901 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/OBS/str_c_to_for.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: str_c_to_for.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE str_c_to_for( cd_str ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE str_c_to_for *** + !! + !! ** Purpose : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Method : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Action : + !! + !! History : + !! ! : 06-05 (K. Mogensen) Original + !! ! : 06-05 (A. Vidard) Cleaning up + !! ! : 06-10 (A. Weaver) More cleaning + !!--------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: cd_str + + !! * Local declarations + INTEGER :: & + & ji + + DO ji = 1, LEN( cd_str ) + IF ( ( IACHAR( cd_str(ji:ji) ) > 128 ) & + & .OR.( IACHAR( cd_str(ji:ji) ) < 32 ) ) cd_str(ji:ji) = ' ' + END DO + + END SUBROUTINE str_c_to_for \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/cpl_oasis3.F90 b/V4.0/nemo_sources/src/OCE/SBC/cpl_oasis3.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3837dcc9032dcb683e9da401e38b81e1eab11039 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/cpl_oasis3.F90 @@ -0,0 +1,625 @@ +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 + 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: cpl_oasis3.F90 14435 2021-02-11 08:30:20Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE cpl_init( cd_modname, kl_comm ) + !!------------------------------------------------------------------- + !! *** ROUTINE cpl_init *** + !! + !! ** Purpose : Initialize coupled mode communication for ocean + !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) + !! + !! ** Method : OASIS3 MPI communication + !!-------------------------------------------------------------------- + CHARACTER(len = *), INTENT(in ) :: cd_modname ! model name as set in namcouple file + INTEGER , INTENT( out) :: kl_comm ! local communicator of the model + !!-------------------------------------------------------------------- + + ! WARNING: No write in numout in this routine + !============================================ + + !------------------------------------------------------------------ + ! 1st Initialize the OASIS system for the application + !------------------------------------------------------------------ + CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) + IF ( nerror /= OASIS_Ok ) & + CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') + + !------------------------------------------------------------------ + ! 3rd Get an MPI communicator for 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() .AND. .NOT. Agrif_Root() ) THEN +#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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/cyclone.F90 b/V4.0/nemo_sources/src/OCE/SBC/cyclone.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8e1eb0e6216cb2df7ac1fed37221755e1863c457 --- /dev/null +++ b/V4.0/nemo_sources/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: cyclone.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/fldread.F90 b/V4.0/nemo_sources/src/OCE/SBC/fldread.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d512ad69000b718c786e202bd46d7c4fc1e2df2e --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/fldread.F90 @@ -0,0 +1,1867 @@ +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 + PUBLIC lfldread_sgl + + 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(dp) , ALLOCATABLE, DIMENSION(:,:,: ) :: fnow_dp + 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 + + LOGICAL :: lfldread_sgl = .FALSE. + +!$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 + LOGICAL :: altformat ! use alternative format + INTEGER, DIMENSION(:,:), POINTER :: altnum ! array of numbers for alternative format + 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: fldread.F90 12367 2020-02-11 18:37:34Z clem $ + !! 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 + !!--------------------------------------------------------------------- + ! + IF ( ( SIZE( sdjf%fnow, 1 ) == 1 ) .AND. ( SIZE( sdjf%fnow, 2 ) == 1 ) ) THEN + ! Only time dimension + IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(1,1,1,2), sdjf%nrec_a(1) ) + ELSE ; CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(1,1,1 ), sdjf%nrec_a(1) ) + ENDIF + ELSE + 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.0_wp ) + 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.0_wp ) + 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.0_wp ) + 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.0_wp ) + 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 + 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., ldsgl = lfldread_sgl ) + ! + ! 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 + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: data_itmp,data_jtmp + !!---------------------------------------------------------------------- + ! + 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, ldsgl = .FALSE. ) ! interpolation weights + + id = iom_varid(inum, 'num', ldstop=.FALSE.) + + IF (inum > 0 .AND. id > 0 ) THEN + + IF(lwp) WRITE(numout,*)'Alternative weights format',ddims + + ref_wgts(nxt_wgt)%altformat = .TRUE. + 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)%jpiwgt = ddims(1) + ref_wgts(nxt_wgt)%jpjwgt = ddims(2) + ref_wgts(nxt_wgt)%nestid = 0 +#if defined key_agrif + ref_wgts(nxt_wgt)%nestid = Agrif_Fixed() +#endif + DEALLOCATE(ddims) + ALLOCATE( ddims(3) ) + id = iom_varid(inum, 'srci', ddims ) + ref_wgts(nxt_wgt)%numwgt = ddims(3) + IF(lwp)THEN + WRITE(numout,*)'Num weights =',ref_wgts(nxt_wgt)%numwgt + CALL flush(numout) + ENDIF + ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + ALLOCATE( ref_wgts(nxt_wgt)%altnum(jpi,jpj) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + ALLOCATE( data_itmp(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + ALLOCATE( data_jtmp(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + CALL iom_get ( inum, jpdom_data, 'srci', data_itmp ) + CALL iom_get ( inum, jpdom_data, 'srcj', data_jtmp ) + CALL iom_get ( inum, jpdom_data, 'num', data_tmp ) + ref_wgts(nxt_wgt)%data_jpi(:,:,:) = INT( data_itmp(:,:,:) ) + ref_wgts(nxt_wgt)%data_jpj(:,:,:) = int( data_jtmp(:,:,:) ) + ref_wgts(nxt_wgt)%altnum(:,:) = INT( data_tmp(:,:) ) + CALL iom_get ( inum, jpdom_data, 'wgt', ref_wgts(nxt_wgt)%data_wgt ) + DEALLOCATE( data_itmp, data_jtmp ) + ipk = SIZE(sd%fnow, 3) + ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt, ref_wgts(nxt_wgt)%jpjwgt ,ipk) ) + CALL iom_close (inum) + ! + nxt_wgt = nxt_wgt + 1 + ! + ELSEIF ( inum > 0 ) THEN + + ref_wgts(nxt_wgt)%altformat =.FALSE. + + !! 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(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points + REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field + ! + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - + REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - + REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - + LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection + LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection + !!---------------------------------------------------------------------- + zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) + zmat1 = eoshift( zmat8 , SHIFT=-1 , BOUNDARY = (/zmat8(1,:)/) , DIM=1 ) + zmat2 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(1,:)/) , DIM=1 ) + zmat4 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(:,ilenj)/) , DIM=2 ) + zmat3 = eoshift( zmat4 , SHIFT=-1 , BOUNDARY = (/zmat4(1,:)/) , DIM=1 ) + zmat5 = eoshift( zmat4 , SHIFT= 1 , BOUNDARY = (/zmat4(ileni,:)/) , DIM=1 ) + zmat6 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(ileni,:)/) , DIM=1 ) + zmat7 = eoshift( zmat8 , SHIFT= 1 , BOUNDARY = (/zmat8(ileni,:)/) , DIM=1 ) + ! + zlsm3d = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /)) + ll_msknan3d = .NOT.( zlsm3d == undeff_lsm ) + ll_msknan2d = .NOT.( zfieldn == undeff_lsm ) ! FALSE where is Undeff (land) + zlsm2d = SUM( zlsm3d, 3 , ll_msknan3d ) / MAX( 1 , COUNT( ll_msknan3d , 3 ) ) + WHERE( COUNT( ll_msknan3d , 3 ) == 0._wp ) zlsm2d = undeff_lsm + zfield = MERGE( zfieldn, zlsm2d, ll_msknan2d ) + ! + END SUBROUTINE seaoverland + + + SUBROUTINE fld_interp( num, clvar, kw, kk, dta, & + & nrec, lsmfile) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_interp *** + !! + !! ** Purpose : apply weights to input gridded data to create data + !! on model grid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: num ! stream number + CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name + INTEGER , INTENT(in ) :: kw ! weights number + INTEGER , INTENT(in ) :: kk ! vertical dimension of kk + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid + INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) + CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name + ! + INTEGER, DIMENSION(3) :: rec1, recn ! temporary arrays for start and length + INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland + INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices + INTEGER :: 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 + !!---------------------------------------------------------------------- + ! + IF (ref_wgts(kw)%altformat) THEN + + IF( LEN( TRIM(lsmfile) ) > 0 ) THEN + CALL ctl_stop('fldinter with altformat = true and lsmfile does not work yet') + ENDIF + rec1(1) = 1 + rec1(2) = 1 + rec1(3) = 1 + recn(1) = ref_wgts(kw)%jpiwgt + recn(2) = ref_wgts(kw)%jpjwgt + recn(3) = kk + ref_wgts(kw)%fly_dta(:,:,:) = 0.0 + SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(:,:,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(:,:,1), nrec, rec1, recn) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(:,:,:), nrec, rec1, recn) + END SELECT + IF(lwp) THEN + WRITE(numout,*)'fld_interp with altformat' + WRITE(numout,*)'variable ',TRIM(clvar) , & + & MAXVAL(ref_wgts(kw)%fly_dta(:,:,1)),MINVAL(ref_wgts(kw)%fly_dta(:,:,1)),SUM(ref_wgts(kw)%fly_dta(:,:,1)) + ENDIF + dta(:,:,:) = 0.0 + DO jk = 1,ref_wgts(kw)%numwgt + 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) + IF (jk <= ref_wgts(kw)%altnum(jm,jn) ) THEN + dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni,nj,:) + ENDIF + END DO + END DO + END DO + IF(lwp) THEN + WRITE(numout,*)'Interpolated ',TRIM(clvar), & + & MAXVAL(dta(:,:,1)),MINVAL(dta(:,:,1)),SUM(dta(:,:,1)) + ENDIF + + ELSE + + !! 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 + ! + ENDIF + ! + 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/V4.0/nemo_sources/src/OCE/SBC/geo2ocean.F90 b/V4.0/nemo_sources/src/OCE/SBC/geo2ocean.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0ffa601ad2f270510e4738864ac46eae64d4eb91 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/geo2ocean.F90 @@ -0,0 +1,476 @@ +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: geo2ocean.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rot_rep *** + !! + !! ** Purpose : Rotate the Repere: Change vector componantes between + !! geographic grid <--> stretched coordinates grid. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes + CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points + CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: + ! ! 'en->i' = east-north to i-component + ! ! 'en->j' = east-north to j-component + ! ! 'ij->e' = (i,j) components to east + ! ! 'ij->n' = (i,j) components to north + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot + !!---------------------------------------------------------------------- + ! + IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' rot_rep: coordinate transformation : geographic <==> model (i,j)-components' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~ ' + ! + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + SELECT CASE( cdtodo ) ! type of rotation + ! + CASE( 'en->i' ) ! east-north to i-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('en->j') ! east-north to j-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->e') ! (i,j)-components to east + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->n') ! (i,j)-components to north + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) + ! + END SELECT + ! + END SUBROUTINE rot_rep + + + SUBROUTINE angle( plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif ) + !!---------------------------------------------------------------------- + !! *** ROUTINE angle *** + !! + !! ** Purpose : Compute angles between model grid lines and the North direction + !! + !! ** Method : sinus and cosinus of the angle between the north-south axe + !! and the j-direction at t, u, v and f-points + !! dot and cross products are used to obtain cos and sin, resp. + !! + !! ** Action : - gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf + !!---------------------------------------------------------------------- + ! WARNING: for an unexplained reason, we need to pass all glam, gphi arrays as input parameters in + ! order to get AGRIF working with -03 compilation option + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: plamt, pphit, plamf, pphif + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: plamu, pphiu, plamv, pphiv + ! + 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' ) + gsint(:,:) = 0.0_wp + gcost(:,:) = 0.0_wp + gsinu(:,:) = 0.0_wp + gcosu(:,:) = 0.0_wp + gsinv(:,:) = 0.0_wp + gcosv(:,:) = 0.0_wp + gsinf(:,:) = 0.0_wp + gcosf(:,:) = 0.0_wp + ! + ! ============================= ! + ! 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.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & + & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) + ! + END SUBROUTINE angle + + + SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, pte, ptn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE geo2oce *** + !! + !! ** Purpose : + !! + !! ** Method : Change a vector from geocentric to east/north + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz + CHARACTER(len=1) , INTENT(in ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn + ! + REAL(wp), PARAMETER :: rpi = 3.141592653e0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('geo2oce: unable to allocate arrays' ) + ENDIF + ! + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy + ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & + & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & + & + gcoslat(:,:,ig) * pzz + ! + END SUBROUTINE geo2oce + + + SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce2geo *** + !! + !! ** Purpose : + !! + !! ** Method : Change vector from east/north to geocentric + !! + !! History : ! (A. Caubel) oce2geo - Original code + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn + CHARACTER(len=1) , INTENT( IN ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz + !! + REAL(wp), PARAMETER :: rpi = 3.141592653E0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('oce2geo: unable to allocate arrays' ) + ENDIF + + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn + pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn + pzz = gcoslat(:,:,ig) * ptn + ! + END SUBROUTINE oce2geo + + + SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_rot *** + !! + !! ** Purpose : Copy gsinu, gcosu, gsinv and gsinv + !! to input data for rotations of + !! current at observation points + !! + !! History : 9.2 ! 09-02 (K. Mogensen) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data + !!---------------------------------------------------------------------- + ! + ! Initialization of gsin* and gcos* at first call + ! ----------------------------------------------- + IF( lmust_init ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched' + IF(lwp) WRITE(numout,*) ' ~~~~~~~ coordinate transformation' + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + psinu(:,:) = gsinu(:,:) + pcosu(:,:) = gcosu(:,:) + psinv(:,:) = gsinv(:,:) + pcosv(:,:) = gcosv(:,:) + ! + END SUBROUTINE obs_rot + + !!====================================================================== +END MODULE geo2ocean \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/ocealb.F90 b/V4.0/nemo_sources/src/OCE/SBC/ocealb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..74d55aa6f28ec4809d656155eb104acb49fc1b91 --- /dev/null +++ b/V4.0/nemo_sources/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: ocealb.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE oce_alb( palb_os , palb_cs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce_alb *** + !! + !! ** Purpose : Computation of the albedo of the ocean + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky + !! + REAL(wp) :: zcoef + REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude + !!---------------------------------------------------------------------- + ! + zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 + palb_cs(:,:) = zcoef + palb_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 + ! + END SUBROUTINE oce_alb + + !!====================================================================== +END MODULE ocealb \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbc_ice.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbc_ice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b6a2ae3d3b4829d8d5c0aa5f4d99b08825d550b4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbc_ice.F90 @@ -0,0 +1,207 @@ +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 + USE sbc_phy +# 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 + LOGICAL , PUBLIC :: ln_icecplcat = .FALSE. !: not ice cat coupling + REAL(dp), 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(dp), 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] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cld_fra !:cloud cover fraction (lcc(ln_limcpllcc) or tcc) [-] +#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 + + !! 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: sbc_ice.F90 13444 2020-08-31 08:58:55Z gsamson $ + !! 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) ) + ! Set albedo over ice to 0.0 so the coupled model can test that + ! it has been computed or ignore it otherwise + alb_ice(:,:,:) = 0.0_wp +#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 + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbc_oce.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbc_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8978479e6130c08a059e9caca34246af6f9f628a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbc_oce.F90 @@ -0,0 +1,247 @@ +MODULE sbc_oce + !!====================================================================== + !! *** MODULE sbc_oce *** + !! Surface module : variables defined in core memory + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !! - ! 2008-08 (G. Madec) namsbc moved from sbcmod + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! 3.3 ! 2010-10 (J. Chanut, C. Bricaud) add the surface pressure forcing + !! 4.0 ! 2012-05 (C. Rousset) add attenuation coef for use in ice model + !! 4.0 ! 2016-06 (L. Brodeau) new unified bulk routine (based on AeroBulk) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_oce_alloc : allocation of sbc arrays + !! sbc_tau2wnd : wind speed estimated from wind stress + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_oce_alloc ! routine called in sbcmod.F90 + PUBLIC sbc_tau2wnd ! routine called in several sbc modules + + !!---------------------------------------------------------------------- + !! Namelist for the Ocean Surface Boundary Condition + !!---------------------------------------------------------------------- + ! !!* namsbc namelist * + LOGICAL , PUBLIC :: ln_usr !: user defined formulation + LOGICAL , PUBLIC :: ln_flx !: flux formulation + LOGICAL , PUBLIC :: ln_blk !: bulk formulation + LOGICAL , PUBLIC :: ln_pert = .FALSE. !: read and add surface forcing perturbations +#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_sglexe = .FALSE. !: Single executable + LOGICAL , PUBLIC :: ln_sglwam = .FALSE. !: Single executable (WAM-NEMO) + LOGICAL , PUBLIC :: ln_limcplcld = .FALSE. !: Single executable cloud coupling + LOGICAL , PUBLIC :: ln_limcpllcc = .FALSE. !: Single executable low cloud cover coupling + 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 is used + !: except if ln_charnock is true and the ECMWF AEROBULK is used. + LOGICAL , PUBLIC :: ln_charnock !: true if Charnock coefficient from wave model is used + 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 + LOGICAL , PUBLIC :: ln_wavephioc !: true if wave TKE flux is read (ln_wavetke in sdftke controls its use) + LOGICAL , PUBLIC :: ln_wvinice = .FALSE. !: true if sea ice mask for the wave forcing is to be used + ! fields currently only used in sbcwave + LOGICAL , PUBLIC :: ln_wspd = .FALSE. !: true if 10m wind speed used by the wave model is used. + LOGICAL , PUBLIC :: ln_rhoaw = .FALSE. !: true if suface air density it used. + ! + INTEGER , PUBLIC :: nn_sdrift ! type of parameterization to calculate vertical Stokes drift + INTEGER , PUBLIC :: nn_sdtrans ! type of parameterization to calculate Stokes transport + ! + 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 + INTEGER , PUBLIC :: nn_hbp = 0 !: steric height and Bress + INTEGER , PUBLIC :: nn_hst = 0 !: method to compute st height + ! + + !!---------------------------------------------------------------------- + !! 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 + INTEGER , PUBLIC, PARAMETER :: jp_sglexe = 6 !: Single executable coupling + !!---------------------------------------------------------------------- + !! 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] + !! 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(dp), 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!: river runoff [Kg/m2/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: 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_b !: iceberg melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb + + !! + 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(:,:) :: tsk_m !: mean (nn_fsbc time-step) SKIN surface sea temp. [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] + ! Are we using the ECMWF bluk formula in iceupdate? + LOGICAL , PUBLIC :: ll_blkecmwf = .FALSE. + ! + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbc_oce.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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) , 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) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj) , & + & ssu_m (jpi,jpj) , sst_m (jpi,jpj) , frq_m(jpi,jpj) , & + & ssv_m (jpi,jpj) , sss_m (jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) + ! Initializing fr_i to avoid fp exceptions + fr_i(:,:) = 0 + ! + 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.0_wp ) + ! + END SUBROUTINE sbc_tau2wnd + + !!====================================================================== +END MODULE sbc_oce diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbc_phy.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbc_phy.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5a97bdf157dc281afb9bc1df5a808f65f5f8245c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbc_phy.F90 @@ -0,0 +1,1112 @@ +MODULE sbc_phy + !!====================================================================== + !! *** MODULE sbc_phy *** + !! A set of functions to compute air themodynamics parameters + !! needed by Aerodynamic Bulk Formulas + !!===================================================================== + !! 4.x ! 2020 L. Brodeau from AeroBulk package (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------- + !! virt_temp : virtual (aka sensible) temperature (potential or absolute) + !! rho_air : density of (moist) air (depends on T_air, q_air and SLP + !! visc_air : kinematic viscosity (aka Nu_air) of air from temperature + !! L_vap : latent heat of vaporization of water as a function of temperature + !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) + !! gamma_moist : adiabatic lapse-rate of moist air + !! One_on_L : 1. / ( Obukhov length ) + !! Ri_bulk : bulk Richardson number aka BRN + !! q_sat : saturation humidity as a function of SLP and temperature + !! q_air_rh : specific humidity as a function of RH (fraction, not %), t_air and SLP + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + IMPLICIT NONE + !PRIVATE + PUBLIC !! Haleluja that was the solution + INTEGER , PARAMETER, PUBLIC :: nb_iter0 = 4 ! Default number of iterations in bulk-param algorithms (can be overriden b.m.o `nb_iter` optional argument) + !! (mainly removed from sbcblk.F90) + REAL(wp), PARAMETER, PUBLIC :: rCp_dry = 1005.0_wp !: Specic heat of dry air, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: rCp_vap = 1860.0_wp !: Specic heat of water vapor, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_dry = 287.05_wp !: Specific gas constant for dry air [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622 + REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 + REAL(wp), PARAMETER, PUBLIC :: rCp_air = 1000.5_wp !: specific heat of air (only used for ice fluxes now...) + REAL(wp), PARAMETER, PUBLIC :: albo = 0.066_wp !: ocean albedo assumed to be constant + ! + REAL(wp), PARAMETER, PUBLIC :: rho0_a = 1.2_wp !: Approx. of density of air [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: rho0_w = 1025._wp !: Density of sea-water (ECMWF->1025) [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: radrw = rho0_a/rho0_w !: Density ratio + REAL(wp), PARAMETER, PUBLIC :: sq_radrw = SQRT(rho0_a/rho0_w) + REAL(wp), PARAMETER, PUBLIC :: rCp0_w = 4190._wp !: Specific heat capacity of seawater (ECMWF 4190) [J/K/kg] + ! + REAL(wp), PARAMETER, PUBLIC :: rcsa = 3._wp !: Saunders coefficient adapted from Fairall et al. 1996 + REAL(wp), PARAMETER, PUBLIC :: rcra = 0.23_wp !: Empirical convection coefficient from Fairall et al. 1996 + ! + REAL(wp), PARAMETER, PUBLIC :: rk0_w = 0.6_wp !: thermal conductivity of water (at 20C) [W/m/K] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_w = 0.98_wp !: Long-wave (thermal) emissivity of sea-water [] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_i = 0.996_wp !: " for ice and snow => but Rees 1993 suggests can be lower in winter on fresh snow... 0.72 ... + REAL(wp), PARAMETER, PUBLIC :: wspd_thrshld_ice = 0.2_wp !: minimum scalar wind speed accepted over sea-ice... [m/s] + ! + REAL(wp), PARAMETER, PUBLIC :: rdct_qsat_salt = 0.98_wp !: reduction factor on specific humidity at saturation (q_sat(T_s)) due to salt + REAL(wp), PARAMETER, PUBLIC :: rtt0 = 273.16_wp !: triple point of temperature [K] + ! + REAL(wp), PARAMETER, PUBLIC :: rcst_cs = -rcsa*rcsa*rcsa*rcsa*rcra*rcra*rcra*9.80665_wp*rho0_w*rCp0_w/(rk0_w*rk0_w) !: for cool-skin parameterizations... + ! (grav = 9.80665_wp) + ! => see eq.(14) in Fairall et al. 1996 (eq.(6) of Zeng and Beljaars is WRONG! (typo?) + REAL(wp), PARAMETER, PUBLIC :: z0_sea_max = 0.0025_wp !: maximum realistic value for roughness length of sea-surface... [m] + REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + REAL(wp), PARAMETER, PUBLIC :: Cx_min = 0.01E-3_wp ! smallest value allowed for bulk transfer coefficients (usually in stable conditions with now wind) + REAL(wp), PARAMETER :: & + !! Constants for Goff formula in the presence of ice: + & rAg_i = -9.09718_wp, & + & rBg_i = -3.56654_wp, & + & rCg_i = 0.876793_wp, & + & rDg_i = LOG10(6.1071_wp) + REAL(wp), PARAMETER :: rc_louis = 5._wp + REAL(wp), PARAMETER :: rc2_louis = rc_louis * rc_louis + REAL(wp), PARAMETER :: ram_louis = 2._wp * rc_louis + REAL(wp), PARAMETER :: rah_louis = 3._wp * rc_louis + INTERFACE virt_temp + MODULE PROCEDURE virt_temp_vctr, virt_temp_sclr + END INTERFACE virt_temp + INTERFACE visc_air + MODULE PROCEDURE visc_air_vctr, visc_air_sclr + END INTERFACE visc_air + INTERFACE gamma_moist + MODULE PROCEDURE gamma_moist_vctr, gamma_moist_sclr + END INTERFACE gamma_moist + INTERFACE e_sat + MODULE PROCEDURE e_sat_vctr, e_sat_sclr + END INTERFACE e_sat + INTERFACE e_sat_ice + MODULE PROCEDURE e_sat_ice_vctr, e_sat_ice_sclr + END INTERFACE e_sat_ice + INTERFACE de_sat_dt_ice + MODULE PROCEDURE de_sat_dt_ice_vctr, de_sat_dt_ice_sclr + END INTERFACE de_sat_dt_ice + INTERFACE Ri_bulk + MODULE PROCEDURE Ri_bulk_vctr, Ri_bulk_sclr + END INTERFACE Ri_bulk + INTERFACE q_sat + MODULE PROCEDURE q_sat_vctr, q_sat_sclr + END INTERFACE q_sat + INTERFACE dq_sat_dt_ice + MODULE PROCEDURE dq_sat_dt_ice_vctr, dq_sat_dt_ice_sclr + END INTERFACE dq_sat_dt_ice + INTERFACE L_vap + MODULE PROCEDURE L_vap_vctr, L_vap_sclr + END INTERFACE L_vap + INTERFACE rho_air + MODULE PROCEDURE rho_air_vctr, rho_air_sclr + END INTERFACE rho_air + INTERFACE cp_air + MODULE PROCEDURE cp_air_vctr, cp_air_sclr + END INTERFACE cp_air + INTERFACE alpha_sw + MODULE PROCEDURE alpha_sw_vctr, alpha_sw_sclr + END INTERFACE alpha_sw + INTERFACE kinvis_sw + MODULE PROCEDURE kinvis_sw_vctr, kinvis_sw_sclr + END INTERFACE kinvis_sw + INTERFACE BULK_FORMULA + MODULE PROCEDURE BULK_FORMULA_VCTR, BULK_FORMULA_SCLR + END INTERFACE BULK_FORMULA + INTERFACE qlw_net + MODULE PROCEDURE qlw_net_vctr, qlw_net_sclr + END INTERFACE qlw_net + INTERFACE f_m_louis + MODULE PROCEDURE f_m_louis_vctr, f_m_louis_sclr + END INTERFACE f_m_louis + INTERFACE f_h_louis + MODULE PROCEDURE f_h_louis_vctr, f_h_louis_sclr + END INTERFACE f_h_louis + PUBLIC virt_temp + PUBLIC rho_air + PUBLIC visc_air + PUBLIC L_vap + PUBLIC cp_air + PUBLIC gamma_moist + PUBLIC One_on_L + PUBLIC Ri_bulk + PUBLIC q_sat + PUBLIC q_air_rh + PUBLIC dq_sat_dt_ice + !: + PUBLIC update_qnsol_tau + PUBLIC alpha_sw + PUBLIC kinvis_sw + PUBLIC bulk_formula + PUBLIC qlw_net + ! + PUBLIC f_m_louis, f_h_louis + PUBLIC z0_from_Cd + PUBLIC Cd_from_z0 + PUBLIC UN10_from_ustar + PUBLIC UN10_from_CD + PUBLIC z0tq_LKB + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 10535 2019-01-16 17:36:47Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +CONTAINS + FUNCTION virt_temp_sclr( pta, pqa ) + !!------------------------------------------------------------------------ + !! + !! Compute the (absolute/potential) VIRTUAL temperature, based on the + !! (absolute/potential) temperature and specific humidity + !! + !! If input temperature is absolute then output virtual temperature is absolute + !! If input temperature is potential then output virtual temperature is potential + !! + !! Author: L. Brodeau, June 2019 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------ + REAL(wp) :: virt_temp_sclr !: virtual temperature [K] + REAL(wp), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + !!------------------------------------------------------------------- + ! + virt_temp_sclr = pta * (1._wp + rctv0*pqa) + !! + !! This is exactly the same thing as: + !! virt_temp_sclr = pta * ( pwa + reps0) / (reps0*(1.+pwa)) + !! with wpa (mixing ration) defined as : pwa = pqa/(1.-pqa) + ! + END FUNCTION virt_temp_sclr + !! + FUNCTION virt_temp_vctr( pta, pqa, kj1, kj2 ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: virt_temp_vctr !: virtual temperature [K] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) + END FUNCTION virt_temp_vctr + !=============================================================================================== + FUNCTION rho_air_vctr( ptak, pqa, ppa, kj1, kj2 ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_vctr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak ! air temperature [K] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp), DIMENSION(jpi,kj1:kj2) :: rho_air_vctr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + END FUNCTION rho_air_vctr + FUNCTION rho_air_sclr( ptak, pqa, ppa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_sclr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp) :: rho_air_sclr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + rho_air_sclr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + END FUNCTION rho_air_sclr + FUNCTION visc_air_sclr(ptak) + !!---------------------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from air temperature in Kelvin + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: visc_air_sclr ! kinetic viscosity (m^2/s) + REAL(wp), INTENT(in) :: ptak ! air temperature in (K) + ! + REAL(wp) :: ztc, ztc2 ! local scalar + !!---------------------------------------------------------------------------------- + ! + ztc = ptak - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air_sclr = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) + ! + END FUNCTION visc_air_sclr + FUNCTION visc_air_vctr(ptak, kj1, kj2) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: visc_air_vctr ! kinetic viscosity (m^2/s) + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak ! air temperature in (K) + INTEGER :: ji, jj ! dummy loop indices + DO jj = kj1, kj2 + DO ji = 1, jpi + visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) ) + END DO + END DO + END FUNCTION visc_air_vctr + FUNCTION L_vap_vctr( psst, kj1, kj2 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_vctr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: L_vap_vctr ! latent heat of vaporization [J/kg] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_vctr = ( 2.501_wp - 0.00237_wp * ( psst(:,:) - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_vctr + FUNCTION L_vap_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_sclr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: L_vap_sclr ! latent heat of vaporization [J/kg] + REAL(wp), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_sclr = ( 2.501_wp - 0.00237_wp * ( psst - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_sclr + FUNCTION cp_air_vctr( pqa, kj1, kj2 ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_vctr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa ! air specific humidity [kg/kg] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2) :: cp_air_vctr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + cp_air_vctr = rCp_dry + rCp_vap * pqa + END FUNCTION cp_air_vctr + FUNCTION cp_air_sclr( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_sclr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp) :: cp_air_sclr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + cp_air_sclr = rCp_dry + rCp_vap * pqa + END FUNCTION cp_air_sclr + !=============================================================================================== + FUNCTION gamma_moist_sclr( ptak, pqa ) + !!---------------------------------------------------------------------------------- + !! ** Purpose : Compute the moist adiabatic lapse-rate. + !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate + !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: gamma_moist_sclr ! [K/m] + REAL(wp), INTENT(in) :: ptak ! absolute air temperature [K] !#LB: double check it's absolute !!! + REAL(wp), INTENT(in) :: pqa ! specific humidity [kg/kg] + ! + REAL(wp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars + !!---------------------------------------------------------------------------------- + zta = MAX( ptak, 180._wp) ! prevents screw-up over masked regions where field == 0. + zqa = MAX( pqa, 1.E-6_wp) ! " " " + !! + zwa = zqa / (1._wp - zqa) ! w is mixing ratio w = q/(1-q) | q = w/(1+w) + ziRT = 1._wp / (R_dry*zta) ! 1/RT + zLvap = L_vap_sclr( ptak ) + !! + gamma_moist_sclr = grav * ( 1._wp + zLvap*zwa*ziRT ) / ( rCp_dry + zLvap*zLvap*zwa*reps0*ziRT/zta ) + !! + END FUNCTION gamma_moist_sclr + !! + FUNCTION gamma_moist_vctr( ptak, pqa, kj1, kj2 ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: gamma_moist_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa + INTEGER :: ji, jj + DO jj = kj1, kj2 + DO ji = 1, jpi + gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) + END DO + END DO + END FUNCTION gamma_moist_vctr + !=============================================================================================== + FUNCTION One_on_L( ptha, pqa, pus, pts, pqs, kj1, kj2 ) + !!------------------------------------------------------------------------ + !! + !! 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,kj1:kj2) :: One_on_L !: 1./(Obukhov length) [m^-1] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pus !: u*: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), 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 = kj1, kj2 + 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 ) + ! + One_on_L(ji,jj) = SIGN( MIN(ABS(One_on_L(ji,jj)),200._wp), One_on_L(ji,jj) ) ! (prevent FPE from stupid values over masked regions...) + END DO + END DO + ! + END FUNCTION One_on_L + !=============================================================================================== + FUNCTION Ri_bulk_sclr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) + !!---------------------------------------------------------------------------------- + !! Bulk Richardson number according to "wide-spread equation"... + !! + !! Reminder: the Richardson number is the ratio "buoyancy" / "shear" + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: Ri_bulk_sclr + REAL(wp), INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), INTENT(in) :: psst ! SST [K] + REAL(dp), INTENT(in) :: ptha ! pot. air temp. at height 8@Z4 [K] + REAL(wp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(dp), INTENT(in) :: pqa ! air spec. hum. at height T@MH [kg/kg] + REAL(wp), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + REAL(wp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars + !!------------------------------------------------------------------- + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd=.TRUE. + ! + zsstv = virt_temp_sclr( psst, pssq ) ! virtual SST (absolute==potential because z=0!) + ! + zdthv =virt_temp_sclr( CASTSP(ptha), CASTSP(pqa) ) - zsstv ! air-sea delta of "virtual potential temperature" + ! + !! ztv: estimate of the ABSOLUTE virtual temp. within the layer + IF( l_ptqa_l_prvd ) THEN + ztv = virt_temp_sclr( pta_layer, pqa_layer ) + ELSE + zqa = 0.5_wp*( pqa + pssq ) ! ~ mean q within the layer... + zta =0.5_wp*( psst + CASTSP(ptha) - gamma_moist(CASTSP(ptha), zqa)*pz ) ! ~ mean absolute temperature of air within the layer + zta = 0.5_wp*( psst + ptha - gamma_moist( zta, zqa)*pz ) ! ~ mean absolute temperature of air within the layer + zgamma = gamma_moist(zta, zqa) ! Adiabatic lapse-rate for moist air within the layer + ztv =0.5_wp*( zsstv + virt_temp_sclr( CASTSP(ptha-zgamma*pz), CASTSP(pqa) ) ) + END IF + ! + Ri_bulk_sclr = grav*zdthv*pz / ( ztv*pub*pub ) ! the usual definition of Ri_bulk_sclr + ! + END FUNCTION Ri_bulk_sclr + !! + FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, kj1, kj2, pta_layer, pqa_layer ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: Ri_bulk_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: psst ! SST [K] + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptha ! pot. air temp. at height 6@5C [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa ! air spec. hum. at height 0@GG [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + INTEGER :: ji, jj + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd=.TRUE. + IF( l_ptqa_l_prvd ) THEN + DO jj = kj1, kj2 + DO ji = 1, jpi + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), & + & pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) ) + END DO + END DO + ELSE + DO jj = kj1, kj2 + DO ji = 1, jpi + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) ) + END DO + END DO + END IF + END FUNCTION Ri_bulk_vctr + !=============================================================================================== + !=============================================================================================== + FUNCTION e_sat_sclr( ptak ) + !!---------------------------------------------------------------------------------- + !! *** FUNCTION e_sat_sclr *** + !! < SCALAR argument version > + !! ** Purpose : water vapor at saturation in [Pa] + !! Based on accurate estimate by Goff, 1957 + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !! + !! Note: what rt0 should be here, is 273.16 (triple point of water) and not 273.15 like here + !!---------------------------------------------------------------------------------- + REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg] + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp) :: zta, ztmp ! local scalar + !!---------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rt0 / zta !#LB: rt0 or rtt0 ???? (273.15 vs 273.16 ) + ! + ! Vapour pressure at saturation [Pa] : WMO, (Goff, 1957) + e_sat_sclr = 100.*( 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(zta/rt0) & + & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(zta/rt0 - 1.)) ) & + & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614) ) + ! + END FUNCTION e_sat_sclr + !! + FUNCTION e_sat_vctr(ptak, kj1, kj2) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: e_sat_vctr !: vapour pressure at saturation [Pa] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak !: temperature (K) + INTEGER :: ji, jj ! dummy loop indices + DO jj = kj1, kj2 + DO ji = 1, jpi + e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) + END DO + END DO + END FUNCTION e_sat_vctr + !=============================================================================================== + !=============================================================================================== + FUNCTION e_sat_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! Same as "e_sat" but over ice rather than water! + !!--------------------------------------------------------------------------------- + REAL(wp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zle, ztmp + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rtt0/zta + !! + zle = rAg_i*(ztmp - 1._wp) + rBg_i*LOG10(ztmp) + rCg_i*(1._wp - zta/rtt0) + rDg_i + !! + e_sat_ice_sclr = 100._wp * 10._wp**zle + END FUNCTION e_sat_ice_sclr + !! + FUNCTION e_sat_ice_vctr(ptak, kj1, kj2) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,kj1:kj2) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = kj1, kj2 + DO ji = 1, jpi + e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) ) + END DO + END DO + END FUNCTION e_sat_ice_vctr + !! + FUNCTION de_sat_dt_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! d [ e_sat_ice ] / dT (derivative / temperature) + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!--------------------------------------------------------------------------------- + REAL(wp) :: de_sat_dt_ice_sclr !: [Pa/K] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zde + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + !! + zde = -(rAg_i*rtt0)/(zta*zta) - rBg_i/(zta*LOG(10._wp)) - rCg_i/rtt0 + !! + de_sat_dt_ice_sclr = LOG(10._wp) * zde * e_sat_ice_sclr(zta) + END FUNCTION de_sat_dt_ice_sclr + !! + FUNCTION de_sat_dt_ice_vctr(ptak, kj1, kj2) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,kj1:kj2) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = kj1, kj2 + DO ji = 1, jpi + de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) ) + END DO + END DO + END FUNCTION de_sat_dt_ice_vctr + !=============================================================================================== + !=============================================================================================== + FUNCTION q_sat_sclr( pta, ppa, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION q_sat_sclr *** + !! + !! ** Purpose : Conputes specific humidity of air at saturation + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: q_sat_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: ze_s + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + ze_s = e_sat_ice( pta ) + ELSE + ze_s = e_sat( pta ) ! Vapour pressure at saturation (Goff) : + END IF + q_sat_sclr = reps0*ze_s/(ppa - (1._wp - reps0)*ze_s) + END FUNCTION q_sat_sclr + !! + FUNCTION q_sat_vctr( pta, ppa, kj1, kj2, l_ice ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: q_sat_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO jj = kj1, kj2 + DO ji = 1, jpi + q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice ) + END DO + END DO + + END FUNCTION q_sat_vctr + !=============================================================================================== + !=============================================================================================== + FUNCTION dq_sat_dt_ice_sclr( pta, ppa ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION dq_sat_dt_ice_sclr *** + !! => d [ q_sat_ice(T) ] / dT + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!---------------------------------------------------------------------------------- + REAL(wp) :: dq_sat_dt_ice_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp) :: ze_s, zde_s_dt, ztmp + !!---------------------------------------------------------------------------------- + ze_s = e_sat_ice_sclr( pta ) ! Vapour pressure at saturation in presence of ice (Goff) + zde_s_dt = de_sat_dt_ice( pta ) + ! + ztmp = (reps0 - 1._wp)*ze_s + ppa + ! + dq_sat_dt_ice_sclr = reps0*ppa*zde_s_dt / ( ztmp*ztmp ) + ! + END FUNCTION dq_sat_dt_ice_sclr + !! + FUNCTION dq_sat_dt_ice_vctr( pta, ppa, kj1, kj2 ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: dq_sat_dt_ice_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa !: atmospheric pressure [Pa] + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = kj1, kj2 + DO ji = 1, jpi + dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) ) + END DO + END DO + END FUNCTION dq_sat_dt_ice_vctr + !=============================================================================================== + !=============================================================================================== + FUNCTION q_air_rh(prha, ptak, ppa, kj1, kj2) + !!---------------------------------------------------------------------------------- + !! Specific humidity of air out of Relative Humidity + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: q_air_rh + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptak !: air temperature [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa !: atmospheric pressure [Pa] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ze ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO jj = kj1, kj2 + DO ji = 1, jpi + ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) + q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1._wp - reps0)*ze) + END DO + END DO + ! + END FUNCTION q_air_rh + SUBROUTINE UPDATE_QNSOL_TAU( kj1, kj2, pzu, pTs, pqs, pTa, pqa, pust, ptst, pqst, pwnd, pUb, ppa, prlw, & + & pQns, pTau, & + & Qlat) + !!---------------------------------------------------------------------------------- + !! Purpose: returns the non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" + !! and the module of the wind stress => pTau = Tau + !! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(dp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pust ! u* + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ptst ! t* + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqst ! q* + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] + ! + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + ! + REAL(wp), DIMENSION(jpi,kj1:kj2), OPTIONAL, INTENT(out) :: Qlat + ! + REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------------------- + DO jj = kj1, kj2 + DO ji = 1, jpi + zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) + zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) + zz0 = pust(ji,jj)/pUb(ji,jj) + zCd = zz0*zz0 + zCh = zz0*ptst(ji,jj)/zdt + zCe = zz0*pqst(ji,jj)/zdq + CALL BULK_FORMULA( pzu, pTs(ji,jj), pqs(ji,jj), CASTSP(pTa(ji,jj)), CASTSP(pqa(ji,jj)), zCd, zCh, zCe, & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), & + & pTau(ji,jj), zQsen, zQlat ) + zQlw = qlw_net_sclr( prlw(ji,jj), pTs(ji,jj) ) ! Net longwave flux + pQns(ji,jj) = zQlat + zQsen + zQlw + IF( PRESENT(Qlat) ) Qlat(ji,jj) = zQlat + END DO + END DO + END SUBROUTINE UPDATE_QNSOL_TAU + SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, & + & pTau, pQsen, pQlat, & + & pEvap, prhoa, pfact_evap ) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), INTENT(in) :: pCd + REAL(wp), INTENT(in) :: pCh + REAL(wp), INTENT(in) :: pCe + REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + !! + REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), INTENT(out) :: pQsen ! [W/m^2] !!!!!!!!! defined positive when inti the ocean (see blk_oce_2 where it is used) + REAL(wp), INTENT(out) :: pQlat ! [W/m^2] !!!!!!!!! defined positive when into the ocean see blk_oce_2 where it is used) + !! + REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: jq + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") + ztaa = pTa ! first guess... + DO jq = 1, 4 + zgamma = gamma_moist( 0.5_wp*(ztaa+pTs) , pqa ) !#LB: why not "0.5*(pqs+pqa)" rather then "pqa" ??? + ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder... + END DO + zrho = rho_air(ztaa, pqa, ppa) + zrho = rho_air(ztaa, pqa, ppa-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! + zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10 + pTau = zUrho * pCd * pwnd ! Wind stress module + zevap = zUrho * pCe * (pqa - pqs) + pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) + pQlat = L_vap(pTs) * zevap + IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap + IF( PRESENT(prhoa) ) prhoa = zrho + END SUBROUTINE BULK_FORMULA_SCLR + !! + SUBROUTINE BULK_FORMULA_VCTR( kj1, kj2, pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, & + & pTau, pQsen, pQlat, & + & pEvap, prhoa, pfact_evap ) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pCd + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pCh + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pCe + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + !! + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out) :: pQlat ! [W/m^2] + !! + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + DO jj = kj1, kj2 + DO ji = 1, jpi + CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & + & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), & + & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & + & pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap ) + IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap + IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho + END DO + END DO + END SUBROUTINE BULK_FORMULA_VCTR + FUNCTION alpha_sw_vctr( psst, kj1, kj2 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_vctr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79_wp + END FUNCTION alpha_sw_vctr + FUNCTION alpha_sw_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_sclr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: alpha_sw_sclr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), INTENT(in) :: psst ! sea-water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_sclr = 2.1e-5_wp * MAX(psst-rt0 + 3.2_wp, 0._wp)**0.79_wp + END FUNCTION alpha_sw_sclr + !=============================================================================================== + FUNCTION kinvis_sw_vctr( psst, kj1, kj2 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION kinvis_sw_vctr *** + !! + !! ** Purpose : ROUGH estimate of the kinematic viscosity of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: kinvis_sw_vctr ! inematic viscosity of sea-water [m^2/s] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + kinvis_sw_vctr = 1.7588e-6_wp - 5.1029e-8_wp*(psst(:,:)-rt0) + 6.4864e-10_wp*(psst(:,:)-rt0)*(psst(:,:)-rt0) + END FUNCTION kinvis_sw_vctr + FUNCTION kinvis_sw_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION kinvis_sw_sclr *** + !! + !! ** Purpose : ROUGH estimate of the kinematic viscosity of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: kinvis_sw_sclr ! kinematic viscosity of sea-water [m^2/s] + REAL(wp), INTENT(in) :: psst ! sea-water temperature [K] + !!---------------------------------------------------------------------------------- + kinvis_sw_sclr = 1.7588e-6_wp - 5.1029e-8_wp*(psst-rt0) + 6.4864e-10_wp*(psst-rt0)*(psst-rt0) + END FUNCTION kinvis_sw_sclr + !=============================================================================================== + FUNCTION qlw_net_sclr( pdwlw, pts, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION qlw_net_sclr *** + !! + !! ** Purpose : Estimate of the net longwave flux at the surface + !!---------------------------------------------------------------------------------- + REAL(wp) :: qlw_net_sclr + REAL(wp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: zemiss, zt2 + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + zemiss = emiss_i + ELSE + zemiss = emiss_w + END IF + zt2 = pts*pts + qlw_net_sclr = zemiss*( pdwlw - stefan*zt2*zt2) ! zemiss used both as the IR albedo and IR emissivity... + END FUNCTION qlw_net_sclr + !! + FUNCTION qlw_net_vctr( pdwlw, pts, kj1, kj2, l_ice ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: qlw_net_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO jj = kj1, kj2 + DO ji = 1, jpi + qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice ) + END DO + END DO + END FUNCTION qlw_net_vctr + !=============================================================================================== + FUNCTION z0_from_Cd( pzu, pCd, ppsi ) + REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! Cd provided is the actual Cd (not the neutral-stability CdN) : + z0_from_Cd = pzu * EXP( - ( vkarmn/SQRT(pCd(:,:)) + ppsi(:,:) ) ) !LB: ok, double-checked! + ELSE + !! Cd provided is the neutral-stability Cd, aka CdN : + z0_from_Cd = pzu * EXP( - vkarmn/SQRT(pCd(:,:)) ) !LB: ok, double-checked! + END IF + END FUNCTION z0_from_Cd + FUNCTION Cd_from_z0( pzu, pz0, ppsi ) + REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! The Cd we return is the actual Cd (not the neutral-stability CdN) : + Cd_from_z0 = 1._wp / ( LOG( pzu / pz0(:,:) ) - ppsi(:,:) ) + ELSE + !! The Cd we return is the neutral-stability Cd, aka CdN : + Cd_from_z0 = 1._wp / LOG( pzu / pz0(:,:) ) + END IF + Cd_from_z0 = vkarmn*vkarmn * Cd_from_z0 * Cd_from_z0 + END FUNCTION Cd_from_z0 + FUNCTION f_m_louis_sclr( pzu, pRib, pCdn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for MOMENTUM + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_m_louis_sclr ! term "f_m" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pCdn ! neutral drag coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pCdn * SQRT( ABS( -pRib * ( pzu / pz0 + 1._wp) ) ) ) ! ABS is just here for when it's stable conditions and ztu is not used anyways + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) ! ABS is just here for when it's UNstable conditions and zts is not used anyways + ! + f_m_louis_sclr = (1._wp - zstab) * ( 1._wp - ram_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + ram_louis * zts ) ! Stable Eq.(A7) + ! + END FUNCTION f_m_louis_sclr + !! + FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0, kj1, kj2 ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: f_m_louis_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pCdn + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pz0 + INTEGER :: ji, jj + DO jj = kj1, kj2 + DO ji = 1, jpi + f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) ) + END DO + END DO + END FUNCTION f_m_louis_vctr + FUNCTION f_h_louis_sclr( pzu, pRib, pChn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for HEAT + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_h_louis_sclr ! term "f_h" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pChn ! neutral heat transfer coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pChn * SQRT( ABS(-pRib * ( pzu / pz0 + 1._wp) ) ) ) + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) + ! + f_h_louis_sclr = (1._wp - zstab) * ( 1._wp - rah_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + rah_louis * zts ) ! Stable Eq.(A7) !#LB: in paper it's "ram_louis" and not "rah_louis" typo or what???? + ! + END FUNCTION f_h_louis_sclr + !! + FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0, kj1, kj2 ) + REAL(wp), DIMENSION(jpi,kj1:kj2) :: f_h_louis_vctr + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pChn + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pz0 + INTEGER :: ji, jj + DO jj = kj1, kj2 + DO ji = 1, jpi + f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) ) + END DO + END DO + END FUNCTION f_h_louis_vctr + FUNCTION UN10_from_ustar( pzu, pUzu, pus, ppsi, kj1, kj2 ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pus !: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) + !! + END FUNCTION UN10_from_ustar + FUNCTION UN10_from_CD( pzu, pUb, pCd, ppsi, kj1, kj2 ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: UN10_from_CD !: [m/s] + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pCd !: drag coefficient + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + !! Reminder: UN10 = u*/vkarmn * log(10/z0) + !! and: u* = sqrt(Cd) * Ub + !! u*/vkarmn * log( 10 / z0 ) + UN10_from_CD(:,:) = SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( pzu, pCd(:,:), ppsi=ppsi(:,:) ) ) + !! + END FUNCTION UN10_from_CD + FUNCTION z0tq_LKB( iflag, pRer, pz0, kj1, kj2 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION z0tq_LKB *** + !! + !! ** Purpose : returns the "temperature/humidity roughness lengths" + !! * iflag==1 => temperature => returns: z_{0t} + !! * iflag==2 => humidity => returns: z_{0q} + !! from roughness reynold number "pRer" (i.e. [z_0 u*]/Nu_{air}) + !! between 0 and 1000. Out of range "pRer" indicated by prt=-999. + !! and roughness length (for momentum) + !! + !! Based on Liu et al. (1979) JAS 36 1722-1723s + !! + !! Note: this is what is used into COARE 2.5 to estimate z_{0t} and z_{0q} + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: z0tq_LKB + INTEGER, INTENT(in) :: kj1, kj2 + INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pz0 !: roughness length (for momentum) [m] + !------------------------------------------------------------------- + ! Scalar Re_r relation from Liu et al. + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XA = RESHAPE( (/ 0.177, 1.376, 1.026, 1.625, 4.661, 34.904, 1667.19, 5.88e5, & + & 0.292, 1.808, 1.393, 1.956, 4.994, 30.709, 1448.68, 2.98e5 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XB = RESHAPE( (/ 0., 0.929, -0.599, -1.018, -1.475, -2.067, -2.907, -3.935, & + & 0., 0.826, -0.528, -0.870, -1.297, -1.845, -2.682, -3.616 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(0:8), PARAMETER :: & + & XRAN = (/ 0., 0.11, 0.825, 3.0, 10.0, 30.0, 100., 300., 1000. /) + !------------------------------------------------------------------- + ! + !------------------------------------------------------------------- + ! Scalar Re_r relation from Moana Wave data. + ! + ! real*8 A(9,2),B(9,2),RAN(9),pRer,prt + ! integer iflag + ! DATA A/0.177,2.7e3,1.03,1.026,1.625,4.661,34.904,1667.19,5.88E5, + ! & 0.292,3.7e3,1.4,1.393,1.956,4.994,30.709,1448.68,2.98E5/ + ! DATA B/0.,4.28,0,-0.599,-1.018,-1.475,-2.067,-2.907,-3.935, + ! & 0.,4.28,0,-0.528,-0.870,-1.297,-1.845,-2.682,-3.616/ + ! DATA RAN/0.11,.16,1.00,3.0,10.0,30.0,100.,300.,1000./ + !------------------------------------------------------------------- + LOGICAL :: lfound=.FALSE. + REAL(wp) :: zrr + INTEGER :: ji, jj, jm + z0tq_LKB(:,:) = -999._wp + DO jj = kj1, kj2 + DO ji = 1, jpi + zrr = pRer(ji,jj) + lfound = .FALSE. + IF( (zrr > 0._wp).AND.(zrr < 1000._wp) ) THEN + jm = 0 + DO WHILE ( .NOT. lfound ) + jm = jm + 1 + lfound = ( (zrr > XRAN(jm-1)) .AND. (zrr <= XRAN(jm)) ) + END DO + z0tq_LKB(ji,jj) = XA(jm,iflag)*zrr**XB(jm,iflag) * pz0(ji,jj)/zrr + END IF + END DO + END DO + z0tq_LKB(:,:) = MIN( MAX(ABS(z0tq_LKB(:,:)), 1.E-9_wp) , 0.05_wp ) + END FUNCTION z0tq_LKB + !!====================================================================== +END MODULE sbc_phy \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcapr.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcapr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3fd1bf06453469c8933d047c3482e43a364e7dcb --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcapr.F90 @@ -0,0 +1,180 @@ +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) + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcapr.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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/V4.0/nemo_sources/src/OCE/SBC/sbcblk.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d8b4cfdbb75ba4d3f4322d290363284417c11144 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk.F90 @@ -0,0 +1,1221 @@ +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 + !! 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 zdftke, ONLY : ln_wavetke ! Wave TKE activation + USE cyclone ! Cyclone 10m wind form trac of cyclone centres + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave , ONLY : uspd_atm, vspd_atm ! 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 45r1) + ! + USE iom ! I/O manager library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE timing ! Timing + + 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 + + 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 (for sea ice) + REAL(wp), PARAMETER :: Ls = 2.839e6 ! latent heat of sublimation + REAL(wp), PARAMETER :: Cd_ice = 1.4e-3 ! transfer coefficient over ice + ! + ! !!* 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 40r1) + ! + LOGICAL :: ln_skin_cs ! use the cool-skin (only available in ECMWF) ! back-ported from nemo4.2 as implement by LB + LOGICAL :: ln_skin_wl ! use the warm-layer parameterization (only available in ECMWF) ! back-ported from nemo4.2 as implement by LB + ! + 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(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ch_atm ! transfer coefficient for sensible heat (Q_sens) + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ce_atm ! tansfert coefficient for evaporation (Q_lat) + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_zu ! air temperature at wind speed height (needed by Lupkes 2015 bulk scheme) + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_zu ! air spec. hum. at wind speed height (needed by Lupkes 2015 bulk scheme) + REAL(dp), 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 40r1) + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 13348 2020-07-27 16:55:57Z acc $ + !! 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 + & ln_skin_cs, ln_skin_wl, & ! only apply to ln_ECMWF + & 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 (.NOT. ln_ECMWF .AND. (ln_skin_cs .OR. ln_skin_wl) ) THEN + CALL ctl_stop( 'STOP', 'sbc_blk_init: skin temperature parameterisation only available for ECMWF bulk' ) + ENDIF + ! Do something different in iceupdate for the ln_ECMWF case + IF( ln_ECMWF ) ll_blkecmwf = .TRUE. + ! + IF( ln_skin_wl ) THEN + !! Check if the frequency of downwelling solar flux input makes sense and if ln_dm2dc=T if it is daily! + IF( (sn_qsr%freqh < 0.).OR.(sn_qsr%freqh > 24.) ) & + & CALL ctl_stop( 'sbc_blk_init: Warm-layer param. (ln_skin_wl) not compatible with freq. of solar flux > daily' ) + IF( (sn_qsr%freqh == 24.).AND.(.NOT. ln_dm2dc) ) & + & CALL ctl_stop( 'sbc_blk_init: Please set ln_dm2dc=T for warm-layer param. (ln_skin_wl) to work properly' ) + END IF + ! + 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, Charnock, wave TKE nor stokes drift activated + IF ( .NOT.(ln_cdgw .OR. ln_charnock .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor .OR. ln_wavetke ) ) THEN + CALL ctl_stop( 'STOP', 'Ask for wave coupling but ln_cdgw=F, ln_charnock=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F, ln_wavetke=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 currently only with NCAR and CORE bulk formulae') + ELSEIF (ln_charnock .AND. .NOT. ln_ECMWF ) THEN + CALL ctl_stop( 'Charnock coefficient read from wave model definable currently only with ECMWF 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_charnock .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) ' , & + & 'with Charnock coefficient (ln_charnock =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 40r1) 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 40r1)' + END SELECT + ! + WRITE(numout,*) + WRITE(numout,*) ' use cool-skin parameterization (SSST) ln_skin_cs = ', ln_skin_cs + WRITE(numout,*) ' use warm-layer parameterization (SSST) ln_skin_wl = ', ln_skin_wl + ! + 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 + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk') + ! + 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 ( ln_wave ) THEN ! global atmospheric 10m winds might be needed to define wave quantities where the input did not + uspd_atm(:,:) = sf(jp_wndi)%fnow(:,:,1) + vspd_atm(:,:) = sf(jp_wndj)%fnow(:,:,1) + ENDIF + +#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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk') + ! + 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 + ! skin temperature if ECMWF skin temperature is used + ! otherwise "bulk SST" + 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] + REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 + + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_oce') + ! + ! local scalars ( place there for vector optimisation purposes) + ! ! Temporary conversion from Celcius to Kelvin (and set minimum value far above 0 K) + zst(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if ECMWF algorithm are not used!) + + ! --- 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.0_wp, zwnd_j, 'T', -1.0_wp ) + ! ... 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 + + ! ----------------------------------------------------------------------------- ! + ! II Turbulent FLUXES ! + ! ----------------------------------------------------------------------------- ! + + ! ... specific humidity at SST and IST tmask( + zsq(:,:) = rdct_qsat_salt * q_sat( zst(:,:), sf(jp_slp)%fnow(:,:,1), 1, jpj ) + !! + !! 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), 1, jpj ) * rn_zqt + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! Backup "bulk SST" and associated spec. hum. + zztmp1(:,:) = zst(:,:) + zztmp2(:,:) = zsq(:,:) + ENDIF + + + 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 ) + !!! Jean Bidlot: back ported turb_ecmwf from nemo4.2 + CALL turb_ecmwf ( kt, rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & + & ln_skin_cs, ln_skin_wl, & + & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, & + & CdN=cdn_oce(:,:), ChN=chn_oce(:,:), CeN=cen_oce(:,:), & + & Qsw=qsr(:,:), rad_lw=sf(jp_qlw )%fnow(:,:,1), slp=sf(jp_slp)%fnow(:,:,1) ) + ! + + CASE DEFAULT + CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' ) + END SELECT + + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! zst and zsq have been updated!!! + !! + !! In the presence of sea-ice we forget about the cool-skin/warm-layer update of zst and zsq: + WHERE ( fr_i(:,:) > 0.001_wp ) + ! sea-ice present, we forget about the update, using what we backed up before call to turb_*() + zst(:,:) = zztmp1(:,:) + zsq(:,:) = zztmp2(:,:) + END WHERE + !! surface temperature used for the calculation of the exchange coefficients in degree C + tsk_m(:,:) = zst(:,:) - rt0 + ELSE + tsk_m(:,:) = pst(:,:) + END IF + + + ! ! 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( CASTSP(t_zu(:,:)) , CASTSP(q_zu(:,:)) , sf(jp_slp)%fnow(:,:,1), 1, jpj ) + ELSE ! At zt: + zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1), 1, jpj ) + 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.0_wp, vtau, 'V', -1.0_wp ) + + ! 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), 1, jpj)*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), 1, jpj)*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - t_zu(:,:) ) ! Sensible Heat, using bulk wind speed + ENDIF + + zqla(:,:) = L_vap(zst(:,:), 1, jpj) * zevap(:,:) ! Latent Heat flux + + + ! ----------------------------------------------------------------------------- ! + ! III Net longwave radiative FLUX ! + ! ----------------------------------------------------------------------------- ! + !! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST + !! (zst is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) + + zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - stefan * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave + + + IF(ln_ctl) THEN + CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=CASTSP(Ce_atm) , clinfo2=' Ce_oce : ' ) + CALL prt_ctl( tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=CASTSP(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 + + ! ----------------------------------------------------------------------------- ! + ! IV 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(:,:) * (zst(:,:) - rt0) * rcp & ! remove evap heat content at skin temperature (in Celsius) + & + ( 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=CASTSP(emp) , clinfo2=' emp : ') + CALL prt_ctl(tab2d_1=utau , clinfo1=' blk_oce: utau : ', mask1=umask, & + & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) + ENDIF + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_oce') + ! + END SUBROUTINE blk_oce + +#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) + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_ice_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.0_wp ) + ! + ! 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), 1, jpj) + + ! ------------------------------------------------------------ ! + ! 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.0_wp, vtau_ice, 'V', -1.0_wp ) + ! + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_ice_tau') + ! + 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(dp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + REAL(dp), 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 + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_ice_flx') + ! + zcoef_dqlw = 4.0 * 0.95 * stefan ! 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), 1, jpj ) + ! + 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) - stefan * 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) * rCp_air * 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) * rCp_air * 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.0_wp-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(:,:) * tsk_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(:,:) * tsk_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 ) + tsk_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 * tsk_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=CASTDP(qla_ice) , clinfo1=' blk_ice: qla_ice : ', tab3d_2=CASTDP(z_qsb) , clinfo2=' z_qsb : ', kdim=jpl) + CALL prt_ctl(tab3d_1=CASTDP(z_qlw) , clinfo1=' blk_ice: z_qlw : ', tab3d_2=CASTDP(dqla_ice), clinfo2=' dqla_ice : ', kdim=jpl) + CALL prt_ctl(tab3d_1=CASTDP(z_dqsb) , clinfo1=' blk_ice: z_dqsb : ', tab3d_2=CASTDP(z_dqlw) , clinfo2=' z_dqlw : ', kdim=jpl) + CALL prt_ctl(tab3d_1=CASTDP(dqns_ice), clinfo1=' blk_ice: dqns_ice : ', tab3d_2=CASTDP(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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_ice_flx') + ! + 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(dp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness + REAL(dp), 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 + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_ice_qcn') + ! + ! -------------------------------------! + ! 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_ice_qcn') + ! + 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_Cdn10_Lubkes2012') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_Cdn10_Lubkes2012') + ! + 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(dp), 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_Cdn10_Lubkes2015') + ! + ! 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), 1, jpj ) ! saturation humidity over ocean [kg/kg] + zqi_sat(:,:) = 0.98_wp * q_sat( ztm_su(:,:), sf(jp_slp)%fnow(:,:,1), 1, jpj ) ! 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.0_wp ) + CALL lbc_lnk_multi( 'sbcblk', Ch, 'T', 1.0_wp ) + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_Cdn10_Lubkes2015') + ! + END SUBROUTINE Cdn10_Lupkes2015 + +#endif + + !!====================================================================== +END MODULE sbcblk \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bc6b657ce89f55d6873b549f34478199d480bc87 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare.F90 @@ -0,0 +1,449 @@ +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(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] + REAL(dp), 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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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_wp , 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_wp,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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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_wp), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 ; zeta_t = sign( min(abs(zeta_t),50.0_wp), zeta_t ) + END IF + + !! 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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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_wp,(zw - 10.0_wp)) ! If zw<10. --> 0, else --> 1 + zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.0_wp)) ! 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) :: pus, pts, pqs + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptha, pqa + + + ! + 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_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + ! + END DO + END DO + ! + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://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_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + ! + END DO + END DO + ! + END FUNCTION psi_h_coare + + + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare3p5.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare3p5.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d8f690a0382da1d1a54b45961f3397def44e4eb8 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_coare3p5.F90 @@ -0,0 +1,418 @@ +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(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] + REAL(dp), 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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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_wp , 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_wp,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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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_wp), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 ; zeta_t = sign( min(abs(zeta_t),50.0_wp), zeta_t ) + END IF + + !! 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_wp), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), 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) :: pus, pts, pqs + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptha, pqa + + + ! + 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_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + ! + END DO + END DO + ! + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://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_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + ! + END DO + END DO + ! + END FUNCTION psi_h_coare + + + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ecmwf.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ecmwf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ac794456737beef1c7059ea8ab63711b18a66bf0 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ecmwf.F90 @@ -0,0 +1,520 @@ +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 Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of IFS of ECMWF (cycle 40r1) + !! based on IFS doc (avaible online on the ECMWF's website) + !! + !! + !! Routine turb_ecmwf maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !! 4.0 ! 2022-03 (J. Bidlot) back porting to nemo4.0 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! turb_ecmwf : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE iom ! I/O manager library + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE in_out_manager, ONLY: nit000 ! I/O manager + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_ecmwf ! cool-skin/warm layer scheme !LB + USE sbcwave, ONLY : charn_wave ! wave module + USE sbc_oce, ONLY : ln_charnock ! wave module + + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + PUBLIC :: SBCBLK_ALGO_ECMWF_INIT, TURB_ECMWF + !! ECMWF own values for given constants, taken form IFS documentation... + REAL(wp), PARAMETER, PUBLIC :: charn0_ecmwf = 0.018_wp ! Charnock constant (pretty high value here !!! + ! ! => Usually 0.011 for moderate winds) + REAL(wp), PARAMETER :: zi0 = 1000. ! scale height of the atmospheric boundary layer...1 + REAL(wp), PARAMETER :: Beta0 = 1. ! gustiness parameter ( = 1.25 in COAREv3) + REAL(wp), PARAMETER :: alpha_M = 0.11 ! For roughness length (smooth surface term) + REAL(wp), PARAMETER :: alpha_H = 0.40 ! (Chapter 3, p.34, IFS doc Cy31r1) + REAL(wp), PARAMETER :: alpha_Q = 0.62 ! + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_ecmwf_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_wl & Hz_wl failed!' ) + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = rd0 ! (rd0, constant, = 3m is default for Zeng & Beljaars) + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE SBCBLK_ALGO_ECMWF_INIT + + SUBROUTINE turb_ecmwf( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, & + & l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, & + & CdN, ChN, CeN, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ecmwf *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to IFS doc. (cycle 45r1) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !! J. Bidlot, February 2022, back porting of version 4.2 into 4.0 + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nb_itt, j_itt + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... + REAL(wp), DIMENSION(jpi,jpj) :: zcharnock !: Charnock coefficient + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' + !!---------------------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_turb_ecmwf') + ! + IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) + nb_itt = nb_iter0 + IF( PRESENT(nb_iter) ) nb_itt = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + ENDIF + ! + !$omp parallel private(itid,ithreads,jj1,jj2,j_itt) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + + IF( l_use_cs .OR. l_use_wl ) THEN + zsst(:,jj1:jj2) = T_s(:,jj1:jj2) ! backing up the bulk SST + IF( l_use_cs ) T_s(:,jj1:jj2) = T_s(:,jj1:jj2) - 0.25_wp ! First guess of correction + q_s(:,jj1:jj2) = rdct_qsat_salt*q_sat(MAX(T_s(:,jj1:jj2), 200._wp), slp(:,jj1:jj2), jj1, jj2 ) ! First guess of q_s + ENDIF + + ! + ! Identical first guess as in COARE, with IFS parameter values though... + ! + + IF( ln_charnock ) THEN + zcharnock(:,jj1:jj2) = charn_wave(:,jj1:jj2) + charn0_ecmwf * ( 1._wp - tmask(:,jj1:jj2,1) ) + ELSE + zcharnock(:,jj1:jj2) = charn0_ecmwf + ENDIF + + !! First guess of temperature and humidity at height zu: + t_zu(:,jj1:jj2) = MAX( t_zt(:,jj1:jj2) , 0.0_wp ) ! who knows what's given on masked-continental regions... + q_zu(:,jj1:jj2) = MAX( q_zt(:,jj1:jj2) , 1.e-6_wp) ! + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu(:,jj1:jj2) = t_zu(:,jj1:jj2) - T_s(:,jj1:jj2) ; dt_zu(:,jj1:jj2) = SIGN( MAX(ABS(dt_zu(:,jj1:jj2)),1.e-6_wp), dt_zu(:,jj1:jj2) ) + dq_zu(:,jj1:jj2) = q_zu(:,jj1:jj2) - q_s(:,jj1:jj2) ; dq_zu(:,jj1:jj2) = SIGN( MAX(ABS(dq_zu(:,jj1:jj2)),1.e-9_wp), dq_zu(:,jj1:jj2) ) + + znu_a(:,jj1:jj2) = visc_air(t_zt(:,jj1:jj2),jj1,jj2) ! Air viscosity (m^2/s) at zt(:,jj1:jj2) given from temperature in (K) + + ztmp2(:,jj1:jj2) = 0.5_wp * 0.5_wp ! initial guess for wind gustiness contribution + Ubzu(:,jj1:jj2) = SQRT(U_zu(:,jj1:jj2)*U_zu(:,jj1:jj2) + ztmp2(:,jj1:jj2)) + + ztmp2(:,jj1:jj2) = 10000._wp ! optimization: ztmp2(:,jj1:jj2) == 1/z0(:,jj1:jj2) + ztmp0(:,jj1:jj2) = LOG( zu*ztmp2(:,jj1:jj2)) + ztmp1(:,jj1:jj2) = LOG(10._wp*ztmp2(:,jj1:jj2)) + u_star(:,jj1:jj2) = 0.035_wp*Ubzu(:,jj1:jj2)*ztmp1(:,jj1:jj2)/ztmp0(:,jj1:jj2) ! (u* = 0.035*Un10) + + z0(:,jj1:jj2) = zcharnock(:,jj1:jj2)*u_star(:,jj1:jj2)*u_star(:,jj1:jj2)/grav + alpha_M*znu_a(:,jj1:jj2)/u_star(:,jj1:jj2) + z0(:,jj1:jj2) = MIN( MAX(ABS(z0(:,jj1:jj2)), 1.E-9_wp) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t(:,jj1:jj2) = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115_wp/(vkarmn/ztmp1(:,jj1:jj2)))) ) + z0t(:,jj1:jj2) = MIN( MAX(ABS(z0t(:,jj1:jj2)), 1.E-9_wp) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd(:,jj1:jj2) = MAX( (vkarmn/ztmp0(:,jj1:jj2))**2 , Cx_min ) ! first guess of Cd + + ztmp0(:,jj1:jj2) = vkarmn*vkarmn/LOG(zt/z0t(:,jj1:jj2))/Cd(:,jj1:jj2) + + ztmp2(:,jj1:jj2) = Ri_bulk( zu, T_s(:,jj1:jj2), t_zu(:,jj1:jj2), q_s(:,jj1:jj2), q_zu(:,jj1:jj2), Ubzu(:,jj1:jj2), jj1, jj2 ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + WHERE (ztmp2(:,jj1:jj2) < 0) ! BRN < 0 + func_h(:,jj1:jj2) = ztmp0(:,jj1:jj2)*ztmp2(:,jj1:jj2) / (1._wp - ztmp2(:,jj1:jj2)*zi0*0.004_wp*Beta0**3/zu) + ELSEWHERE ! BRN >= 0 + func_h(:,jj1:jj2) = ztmp0(:,jj1:jj2)*ztmp2(:,jj1:jj2) + 27._wp/9._wp*ztmp2(:,jj1:jj2)*ztmp2(:,jj1:jj2) + ENDWHERE + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0(:,jj1:jj2) = vkarmn/(LOG(zu/z0t(:,jj1:jj2)) - psi_h_ecmwf(func_h(:,jj1:jj2), jj1, jj2)) + + ! (MAX => prevents FPE from stupid values from masked region later on) + u_star(:,jj1:jj2) = MAX ( Ubzu(:,jj1:jj2)*vkarmn/(LOG(zu) - LOG(z0(:,jj1:jj2)) - psi_m_ecmwf(func_h(:,jj1:jj2),jj1,jj2)) , 1.E-9 ) + t_star(:,jj1:jj2) = dt_zu(:,jj1:jj2)*ztmp0(:,jj1:jj2) + q_star(:,jj1:jj2) = dq_zu(:,jj1:jj2)*ztmp0(:,jj1:jj2) + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + ! + !! First update of values at zu (or zt for wind) + ztmp0(:,jj1:jj2) = psi_h_ecmwf(func_h(:,jj1:jj2), jj1, jj2) - psi_h_ecmwf(zt*func_h(:,jj1:jj2)/zu, jj1, jj2) ! zt*func_h(:,jj1:jj2)/zu == zeta_t + ztmp1(:,jj1:jj2) = log(zt/zu) + ztmp0(:,jj1:jj2) + t_zu(:,jj1:jj2) = t_zt(:,jj1:jj2) - t_star(:,jj1:jj2)/vkarmn*ztmp1(:,jj1:jj2) + q_zu(:,jj1:jj2) = q_zt(:,jj1:jj2) - q_star(:,jj1:jj2)/vkarmn*ztmp1(:,jj1:jj2) + q_zu(:,jj1:jj2) = (0.5_wp + SIGN(0.5_wp,q_zu(:,jj1:jj2)))*q_zu(:,jj1:jj2) !Makes it impossible to have negative humidity : + ! + dt_zu(:,jj1:jj2) = t_zu(:,jj1:jj2) - T_s(:,jj1:jj2) ; dt_zu(:,jj1:jj2) = SIGN( MAX(ABS(dt_zu(:,jj1:jj2)),1.E-6_wp), dt_zu(:,jj1:jj2) ) + dq_zu(:,jj1:jj2) = q_zu(:,jj1:jj2) - q_s(:,jj1:jj2) ; dq_zu(:,jj1:jj2) = SIGN( MAX(ABS(dq_zu(:,jj1:jj2)),1.E-9_wp), dq_zu(:,jj1:jj2) ) + ! + ENDIF + + !! => that was same first guess as in COARE... + + !! First guess of inverse of Obukov length (1/L) : + Linv(:,jj1:jj2) = One_on_L( t_zu(:,jj1:jj2), q_zu(:,jj1:jj2), u_star(:,jj1:jj2), t_star(:,jj1:jj2), q_star(:,jj1:jj2), jj1, jj2 ) + + !! Functions such as u* = Ubzu*vkarmn/func_m + ztmp1(:,jj1:jj2) = zu + z0(:,jj1:jj2) + ztmp0(:,jj1:jj2) = ztmp1(:,jj1:jj2)*Linv(:,jj1:jj2) + func_m(:,jj1:jj2) = LOG(ztmp1(:,jj1:jj2)) -LOG( z0(:,jj1:jj2)) - psi_m_ecmwf(ztmp0(:,jj1:jj2),jj1,jj2) + psi_m_ecmwf( z0(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + func_h(:,jj1:jj2) = LOG(ztmp1(:,jj1:jj2)) -LOG(z0t(:,jj1:jj2)) - psi_h_ecmwf(ztmp0(:,jj1:jj2),jj1,jj2) + psi_h_ecmwf(z0t(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + + + + !! ITERATION BLOCK + DO j_itt = 1, nb_itt + !! Bulk Richardson Number at z=zu (Eq. 3.25) + ztmp0(:,jj1:jj2) = Ri_bulk( zu, T_s(:,jj1:jj2), t_zu(:,jj1:jj2), q_s(:,jj1:jj2), q_zu(:,jj1:jj2), Ubzu(:,jj1:jj2), jj1, jj2 ) ! Bulk Richardson Number (BRN) + + !! New estimate of the inverse of the Obukhov length (Linv == zeta/zu) : + Linv(:,jj1:jj2) = ztmp0(:,jj1:jj2)*func_m(:,jj1:jj2)*func_m(:,jj1:jj2)/func_h(:,jj1:jj2) / zu ! From Eq. 3.23, Chap.3.2.3, IFS doc - Cy40r1 + !! Note: it is slightly different that the L we would get with the usual + Linv(:,jj1:jj2) = SIGN( MIN(ABS(Linv(:,jj1:jj2)),200._wp), Linv(:,jj1:jj2) ) ! (prevent FPE from stupid values from masked region later on...) + + !! Update func_m with new Linv: + ztmp1(:,jj1:jj2) = zu + z0(:,jj1:jj2) + func_m(:,jj1:jj2) = LOG(ztmp1(:,jj1:jj2)) -LOG(z0(:,jj1:jj2)) - psi_m_ecmwf(ztmp1(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + psi_m_ecmwf(z0(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + + !! Need to update roughness lengthes: + u_star(:,jj1:jj2) = Ubzu(:,jj1:jj2)*vkarmn/func_m(:,jj1:jj2) + ztmp2(:,jj1:jj2) = u_star(:,jj1:jj2)*u_star(:,jj1:jj2) + ztmp1(:,jj1:jj2) = znu_a(:,jj1:jj2)/u_star(:,jj1:jj2) + !!! Jean Bidlot 0.001 might be too low for typical z0, z0t and z0q under strong winds + !!! so change to 0.1 for z0 and 0.01 for z0t and z0q + z0(:,jj1:jj2) = MIN( ABS(alpha_M*ztmp1(:,jj1:jj2) + zcharnock(:,jj1:jj2)*ztmp2(:,jj1:jj2)/grav ) , 0.1_wp) + z0t(:,jj1:jj2) = MIN( ABS( alpha_H*ztmp1(:,jj1:jj2) ) , 0.01_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 + z0q(:,jj1:jj2) = MIN( ABS( alpha_Q*ztmp1(:,jj1:jj2) ) , 0.01_wp) + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Chap. 3.2, IFS doc - Cy40r1, Eq.3.17 and Eq.3.18 + Eq.3.8) + ! square of wind gustiness contribution (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1) + ztmp2(:,jj1:jj2) = Beta0*Beta0*ztmp2(:,jj1:jj2)*(MAX(-zi0*Linv(:,jj1:jj2)/vkarmn,0._wp))**(2._wp/3._wp) + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu(:,jj1:jj2) = MAX(SQRT(U_zu(:,jj1:jj2)*U_zu(:,jj1:jj2) + ztmp2(:,jj1:jj2) ), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + !! Need to update "theta" and "q" at zu in case they are given at different heights + !! as well the air-sea differences: + IF( .NOT. l_zt_equal_zu ) THEN + !! Arrays func_m and func_h are free for a while so using them as temporary arrays... + func_h(:,jj1:jj2) = psi_h_ecmwf((zu+z0(:,jj1:jj2))*Linv(:,jj1:jj2),jj1,jj2) ! temporary array !!! + func_m(:,jj1:jj2) = psi_h_ecmwf((zt+z0(:,jj1:jj2))*Linv(:,jj1:jj2),jj1,jj2) ! temporary array !!! + + ztmp2(:,jj1:jj2) = psi_h_ecmwf(z0t(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + ztmp0(:,jj1:jj2) = func_h(:,jj1:jj2) - ztmp2(:,jj1:jj2) + ztmp1(:,jj1:jj2) = vkarmn/(LOG(zu+z0(:,jj1:jj2)) - LOG(z0t(:,jj1:jj2)) - ztmp0(:,jj1:jj2)) + t_star(:,jj1:jj2) = dt_zu(:,jj1:jj2)*ztmp1(:,jj1:jj2) + ztmp2(:,jj1:jj2) = ztmp0(:,jj1:jj2) - func_m(:,jj1:jj2) + ztmp2(:,jj1:jj2) + ztmp1(:,jj1:jj2) = LOG(zt/zu) + ztmp2(:,jj1:jj2) + t_zu(:,jj1:jj2) = t_zt(:,jj1:jj2) - t_star(:,jj1:jj2)/vkarmn*ztmp1(:,jj1:jj2) + + ztmp2(:,jj1:jj2) = psi_h_ecmwf(z0q(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + ztmp0(:,jj1:jj2) = func_h(:,jj1:jj2) - ztmp2(:,jj1:jj2) + ztmp1(:,jj1:jj2) = vkarmn/(LOG(zu+z0(:,jj1:jj2)) - LOG(z0q(:,jj1:jj2)) - ztmp0(:,jj1:jj2)) + q_star(:,jj1:jj2) = dq_zu(:,jj1:jj2)*ztmp1(:,jj1:jj2) + ztmp2(:,jj1:jj2) = ztmp0(:,jj1:jj2) - func_m(:,jj1:jj2) + ztmp2(:,jj1:jj2) + ztmp1(:,jj1:jj2) = log(zt/zu) + ztmp2(:,jj1:jj2) + q_zu(:,jj1:jj2) = q_zt(:,jj1:jj2) - q_star(:,jj1:jj2)/vkarmn*ztmp1(:,jj1:jj2) + + ENDIF + !! Updating because of updated z0 and z0t and new Linv... + ztmp1(:,jj1:jj2) = zu + z0(:,jj1:jj2) + ztmp0(:,jj1:jj2) = ztmp1(:,jj1:jj2)*Linv(:,jj1:jj2) + func_m(:,jj1:jj2) = LOG(ztmp1(:,jj1:jj2)) - LOG(z0(:,jj1:jj2) ) - psi_m_ecmwf(ztmp0(:,jj1:jj2),jj1,jj2) + psi_m_ecmwf( z0(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + func_h(:,jj1:jj2) = LOG(ztmp1(:,jj1:jj2)) - LOG(z0t(:,jj1:jj2)) - psi_h_ecmwf(ztmp0(:,jj1:jj2),jj1,jj2) + psi_h_ecmwf(z0t(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) + + IF( l_use_cs ) THEN + !! Cool-skin contribution + CALL UPDATE_QNSOL_TAU( jj1, jj2, zu, T_s(:,jj1:jj2), q_s(:,jj1:jj2), t_zu(:,jj1:jj2), q_zu(:,jj1:jj2), u_star(:,jj1:jj2), & + & t_star(:,jj1:jj2), q_star(:,jj1:jj2), U_zu(:,jj1:jj2), Ubzu(:,jj1:jj2), slp(:,jj1:jj2), rad_lw(:,jj1:jj2), & + & ztmp1(:,jj1:jj2), ztmp0(:,jj1:jj2), Qlat=ztmp2(:,jj1:jj2)) ! Qnsol -> ztmp1 / Tau -> ztmp0 + CALL CS_ECMWF( jj1, jj2, Qsw(:,jj1:jj2), ztmp1(:,jj1:jj2), u_star(:,jj1:jj2), zsst(:,jj1:jj2) ) ! Qnsol -> ztmp1 + + T_s(:,jj1:jj2) = zsst(:,jj1:jj2) + dT_cs(:,jj1:jj2)*tmask(:,jj1:jj2,1) + IF( l_use_wl ) T_s(:,jj1:jj2) = T_s(:,jj1:jj2) + dT_wl(:,jj1:jj2)*tmask(:,jj1:jj2,1) + q_s(:,jj1:jj2) = rdct_qsat_salt*q_sat(MAX(T_s(:,jj1:jj2), 200._wp), slp(:,jj1:jj2), jj1, jj2 ) + ENDIF + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( jj1, jj2, zu, T_s(:,jj1:jj2), q_s(:,jj1:jj2), t_zu(:,jj1:jj2), q_zu(:,jj1:jj2), u_star(:,jj1:jj2), & + & t_star(:,jj1:jj2), q_star(:,jj1:jj2), U_zu(:,jj1:jj2), Ubzu(:,jj1:jj2), slp(:,jj1:jj2), rad_lw(:,jj1:jj2), & + & ztmp1(:,jj1:jj2), ztmp2(:,jj1:jj2) ) ! Qnsol -> ztmp1 / Tau -> ztmp2 + CALL WL_ECMWF( jj1, jj2, Qsw(:,jj1:jj2), ztmp1(:,jj1:jj2), u_star(:,jj1:jj2), zsst(:,jj1:jj2) ) + !! Updating T_s and q_s !!! + T_s(:,jj1:jj2) = zsst(:,jj1:jj2) + dT_wl(:,jj1:jj2)*tmask(:,jj1:jj2,1) + IF( l_use_cs ) T_s(:,jj1:jj2) = T_s(:,jj1:jj2) + dT_cs(:,jj1:jj2)*tmask(:,jj1:jj2,1) + q_s(:,jj1:jj2) = rdct_qsat_salt*q_sat(MAX(T_s(:,jj1:jj2), 200._wp), slp(:,jj1:jj2), jj1, jj2 ) + ENDIF + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu(:,jj1:jj2) = t_zu(:,jj1:jj2) - T_s(:,jj1:jj2) ; dt_zu(:,jj1:jj2) = SIGN( MAX(ABS(dt_zu(:,jj1:jj2)),1.E-6_wp), dt_zu(:,jj1:jj2) ) + dq_zu(:,jj1:jj2) = q_zu(:,jj1:jj2) - q_s(:,jj1:jj2) ; dq_zu(:,jj1:jj2) = SIGN( MAX(ABS(dq_zu(:,jj1:jj2)),1.E-9_wp), dq_zu(:,jj1:jj2) ) + ENDIF + END DO !DO j_itt = 1, nb_itt + + Cd(:,jj1:jj2) = MAX( vkarmn*vkarmn/(func_m(:,jj1:jj2)*func_m(:,jj1:jj2)) , Cx_min ) + Ch(:,jj1:jj2) = MAX( vkarmn*vkarmn/(func_m(:,jj1:jj2)*func_h(:,jj1:jj2)) , Cx_min ) + ztmp2(:,jj1:jj2) = LOG((zu + z0(:,jj1:jj2))/z0q(:,jj1:jj2)) - psi_h_ecmwf((zu + z0(:,jj1:jj2))*Linv(:,jj1:jj2),jj1,jj2) + psi_h_ecmwf(z0q(:,jj1:jj2)*Linv(:,jj1:jj2),jj1,jj2) ! func_q + Ce(:,jj1:jj2) = MAX( vkarmn*vkarmn/(func_m(:,jj1:jj2)*ztmp2(:,jj1:jj2)) , Cx_min ) + + ztmp1(:,jj1:jj2) = zu + z0(:,jj1:jj2) + IF(PRESENT(Cdn)) Cdn(:,jj1:jj2) = MAX( vkarmn*vkarmn / (LOG(ztmp1(:,jj1:jj2)/z0(:,jj1:jj2) )*LOG(ztmp1(:,jj1:jj2)/z0(:,jj1:jj2) )) , Cx_min ) + IF(PRESENT(Chn)) Chn(:,jj1:jj2) = MAX( vkarmn*vkarmn / (LOG(ztmp1(:,jj1:jj2)/z0t(:,jj1:jj2))*LOG(ztmp1(:,jj1:jj2)/z0t(:,jj1:jj2))) , Cx_min ) + IF(PRESENT(Cen)) Cen(:,jj1:jj2) = MAX( vkarmn*vkarmn / (LOG(ztmp1(:,jj1:jj2)/z0q(:,jj1:jj2))*LOG(ztmp1(:,jj1:jj2)/z0q(:,jj1:jj2))) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs(:,jj1:jj2) = dT_cs(:,jj1:jj2) + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl(:,jj1:jj2) = dT_wl(:,jj1:jj2) + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl(:,jj1:jj2) = Hz_wl(:,jj1:jj2) + + ! + !$omp end parallel + ! + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_turb_ecmwf') + ! + END SUBROUTINE turb_ecmwf + + FUNCTION psi_m_ecmwf( pzeta, kj1, kj2 ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: psi_m_ecmwf + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc, z2o3 + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + z2o3 = 2._wp/3._wp + ! + DO jj = kj1, kj2 + DO ji = 1, jpi + ! + zta = MIN( pzeta(ji,jj) , 5._wp ) !! `zeta` plateaus at 5 in very stable conditions (L>0 and small!) + + !#fixme: Jean Bidlot & Sam Hatfield @ ECMWF, complain that + ! `EXP(-0.35_wp*zta)` later blows up in single precision when unstable with big `zta` + !#fixme: LB suggests: + zta = MAX( zta , -50._wp ) !! `zeta` plateaus at -50 in very unstable conditions (L<0 and small!) + + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx = SQRT(zx2) ! (1 - 16z)^0.25 + ztmp = 1._wp + zx + zpsi_unst = LOG( 0.125_wp*ztmp*ztmp*(1._wp + zx2) ) - 2._wp*ATAN( zx ) + 0.5_wp*rpi + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -z2o3*(zta - zc)*EXP(-0.35_wp*zta) - zta - z2o3*zc + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO + END DO + ! + END FUNCTION psi_m_ecmwf + FUNCTION psi_h_ecmwf( pzeta, kj1, kj2 ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,kj1:kj2) :: psi_h_ecmwf + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc, z2o3 + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + z2o3 = 2._wp/3._wp + ! + DO jj = kj1, kj2 + DO ji = 1, jpi + ! + zta = MIN( pzeta(ji,jj) , 5._wp ) !! `zeta` plateaus at 5 in very stable conditions (L>0 and small!) + + !#fixme: Jean Bidlot & Sam Hatfield @ ECMWF, complain that + ! `EXP(-0.35_wp*zta)` later blows up in single precision when unstable with big `zta` + !#fixme: LB suggests: + zta = MAX( zta , -50._wp ) !! `zeta` plateaus at -50 in very unstable conditions (L<0 and small!) + + ! + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -z2o3*(zta - zc)*EXP(-0.35_wp*zta) & + & - ABS(1._wp + z2o3*zta)**1.5_wp - z2o3*zc + 1._wp + ! + ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO + END DO + ! + END FUNCTION psi_h_ecmwf + !!====================================================================== +END MODULE sbcblk_algo_ecmwf \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ncar.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ncar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c23d8eb47570b66d53a6fa99483e491dc7d5137f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_algo_ncar.F90 @@ -0,0 +1,436 @@ +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 + USE timing ! Timing + + + 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(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ub ! bulk wind speed at zu [m/s] + REAL(dp), 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 + !!---------------------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_blk_turb_ncar') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_blk_turb_ncar') + ! + 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(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcblk_skin_ecmwf.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_skin_ecmwf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c497e9dc6b0f53ae66a48fe52a3f5ae8b9c9c1d8 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcblk_skin_ecmwf.F90 @@ -0,0 +1,268 @@ +MODULE sbcblk_skin_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_skin_ecmwf *** + !! + !! Module that gathers the cool-skin and warm-layer parameterization used + !! by the IFS at ECMWF (recoded from scratch => + !! https://github.com/brodeau/aerobulk) + !! + !! Mainly based on Zeng & Beljaars, 2005 with the more recent add-up from + !! Takaya et al., 2010 when it comes to the warm-layer parameterization + !! (contribution of extra mixing due to Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bidlot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! Most of the formula are taken from the documentation of IFS of ECMWF + !! (cycle 40r1) (avaible online on the ECMWF's website) + !! + !! Routine 'sbcblk_skin_ecmwf' also maintained and developed in AeroBulk (as + !! 'mod_skin_ecmwf') + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, November 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2019-11 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE lib_fortran ! to use key_nosignedzero + IMPLICIT NONE + PRIVATE + PUBLIC :: CS_ECMWF, WL_ECMWF + !! Cool-skin related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + ! ! => temperature difference between air-sea interface (z=0) + ! ! and right below viscous layer (z=delta) + !! Warm-layer related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + ! ! => difference between "almost surface (right below + ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + ! + REAL(wp), PARAMETER, PUBLIC :: rd0 = 3._wp !: Depth scale [m] of warm layer, "d" in Eq.11 (Zeng & Beljaars 2005) + REAL(wp), PARAMETER :: zRhoCp_w = rho0_w*rCp0_w + ! + REAL(wp), PARAMETER :: rNuwl0 = 0.5_wp !: Nu (exponent of temperature profile) Eq.11 + ! !: (Zeng & Beljaars 2005) !: set to 0.5 instead of + ! !: 0.3 to respect a warming of +3 K in calm + ! !: condition for the insolation peak of +1000W/m^2 + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE CS_ECMWF( kj1, kj2, pQsw, pQnsol, pustar, pSST ) + !!--------------------------------------------------------------------- + !! + !! Cool-skin parameterization, based on Fairall et al., 1996: + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface + !! skin temperature for modeling and data assimilation. Geophysical + !! Research Letters, 32 (14) , pp. 1-4. + !! + !!------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pSST ! bulk SST [K] + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jc + REAL(wp) :: zQabs, zdlt, zfr, zalfa, znu, zus + !!--------------------------------------------------------------------- + DO jj = kj1, kj2 + DO ji = 1, jpi + zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, + ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... + zalfa = alpha_sw(pSST(ji,jj)) ! (crude) thermal expansion coefficient of sea-water [1/K] + znu = kinvis_sw(pSST(ji,jj)) ! (crude) kinematic viscosity of sea-water [m^2/s] + zus = pustar(ji,jj) + zdlt = delta_skin_layer( zalfa, znu, zQabs, zus ) + DO jc = 1, 4 ! because implicit in terms of zdlt... + zfr = MAX( 0.065_wp + 11._wp*zdlt & + & - 6.6E-5_wp/zdlt*(1._wp - EXP(-zdlt/8.E-4_wp)) & + & , 0.01_wp ) ! Solar absorption, Eq.(5) Zeng & Beljaars, 2005 + ! ! => (WARNING: 0.065 rather than 0.137 in Fairal et al. 1996) + zQabs = pQnsol(ji,jj) + zfr*pQsw(ji,jj) + zdlt = delta_skin_layer( zalfa, znu, zQabs, zus ) + END DO + dT_cs(ji,jj) = zQabs*zdlt/rk0_w ! temperature increment, yes dT_cs can actually > 0, if Qabs > 0 (rare but possible!) + END DO + END DO + END SUBROUTINE CS_ECMWF + SUBROUTINE WL_ECMWF( kj1, kj2, pQsw, pQnsol, pustar, pSST, pustk ) + !!--------------------------------------------------------------------- + !! + !! Warm-Layer scheme according to Zeng & Beljaars, 2005 (GRL) with the + !! more recent add-up from Takaya et al., 2010 when it comes to the + !! warm-layer parameterization (contribution of extra mixing due to + !! Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bildot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! STIL NO PROGNOSTIC EQUATION FOR THE DEPTH OF THE WARM-LAYER! + !! + !! ------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + INTEGER, INTENT(in) :: kj1, kj2 + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pustar ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,kj1:kj2), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + !! + REAL(wp), DIMENSION(jpi,kj1:kj2), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] + ! + INTEGER :: ji, jj, jc + ! + REAL(wp) :: zHwl !: thickness of the warm-layer [m] + REAL(wp) :: ztcorr !: correction of dT w.r.t measurement depth of bulk SST (first T-point) + REAL(wp) :: zalfa !: thermal expansion coefficient of sea-water [1/K] + REAL(wp) :: zdTwl_b, zdTwl_n !: temp. diff. between "almost surface (right below viscous layer) and bottom of WL + REAL(wp) :: zfr, zeta + REAL(wp) :: zusw, zusw2 + REAL(wp) :: zLa, zfLa + REAL(wp) :: flg, zwf, zQabs + REAL(wp) :: ZA, ZB, zL1, zL2 + REAL(wp) :: zcst0, zcst1, zcst2, zcst3 + ! + LOGICAL :: l_pustk_known + !!--------------------------------------------------------------------- + l_pustk_known = .FALSE. + IF( PRESENT(pustk) ) l_pustk_known = .TRUE. + DO jj = kj1, kj2 + DO ji = 1, jpi + zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) + ! it is = rd0 (3m) in default Zeng & Beljaars case... + !! Previous value of dT / warm-layer, adapted to depth: + flg = 0.5_wp + SIGN( 0.5_wp , gdept_1d(1)-zHwl ) ! => 1 when gdept_1d(1)>zHwl (dT_wl(ji,jj) = zdTwl) | 0 when z_s$ + ztcorr = flg + (1._wp - flg)*gdept_1d(1)/zHwl + zdTwl_b = MAX ( dT_wl(ji,jj) / ztcorr , 0._wp ) + ! zdTwl is the difference between "almost surface (right below viscous layer) and bottom of WL (here zHwl) + ! pdT " " and depth of bulk SST (here gdept_1d(1))! + !! => but of course in general the bulk SST is taken shallower than zHwl !!! So correction less pronounced! + !! => so here since pdT is difference between surface and gdept_1d(1), need to increase fof zdTwl ! + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + ! *** zfr = Fraction of solar radiation absorbed in warm layer (-) + zfr = 1._wp - 0.28_wp*EXP(-71.5_wp*zHwl) - 0.27_wp*EXP(-2.8_wp*zHwl) - 0.45_wp*EXP(-0.07_wp*zHwl) !: Eq. 8.157 + zQabs = zfr*pQsw(ji,jj) + pQnsol(ji,jj) ! tot heat absorbed in warm layer + zusw = MAX( pustar(ji,jj), 1.E-4_wp ) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! Langmuir: + IF( l_pustk_known ) THEN + zLa = SQRT(zusw/MAX(pustk(ji,jj),1.E-6_wp)) + ELSE + zLa = 0.3_wp + ENDIF + zfLa = MAX( zLa**(-2._wp/3._wp) , 1._wp ) ! Eq.(6) + zwf = 0.5_wp + SIGN(0.5_wp, zQabs) ! zQabs > 0. => 1. / zQabs < 0. => 0. + zcst1 = vkarmn*grav*zalfa + ! 1/L when zQabs > 0 : + zL2 = zcst1*zQabs / (zRhoCp_w*zusw2*zusw) + zcst2 = zcst1 / ( 5._wp*zHwl*zusw2 ) !OR: zcst2 = zcst1*rNuwl0 / ( 5._wp*zHwl*zusw2 ) ??? + zcst0 = rdt * (rNuwl0 + 1._wp) / zHwl + ZA = zcst0 * zQabs / ( rNuwl0 * zRhoCp_w ) + zcst3 = -zcst0 * vkarmn * zusw * zfLa + !! Sorry about all these constants ( constant w.r.t zdTwl), it's for + !! the sake of optimizations... So all these operations are not done + !! over and over within the iteration loop... + !! T R U L L Y I M P L I C I T => needs itteration + !! => have to itterate just because the 1/(Monin-Obukhov length), zL1, uses zdTwl when zQabs < 0.. + !! (without this term otherwize the implicit analytical solution is straightforward...) + zdTwl_n = zdTwl_b + DO jc = 1, 10 + zdTwl_n = 0.5_wp * ( zdTwl_n + zdTwl_b ) ! semi implicit, for faster convergence + ! 1/L when zdTwl > 0 .AND. zQabs < 0 : + zL1 = SQRT( zdTwl_n * zcst2 ) ! / zusw !!! Or??? => vkarmn * SQRT( zdTwl_n*grav*zalfa/( 5._wp*zHwl ) ) / zusw + ! Stability parameter (z/L): + zeta = (1._wp - zwf) * zHwl*zL1 + zwf * zHwl*zL2 + ZB = zcst3 / PHI(zeta) + zdTwl_n = MAX ( zdTwl_b + ZA + ZB*zdTwl_n , 0._wp ) ! Eq.(6) + END DO + !! Update: + dT_wl(ji,jj) = zdTwl_n * ztcorr + END DO + END DO + + END SUBROUTINE WL_ECMWF + FUNCTION delta_skin_layer( palpha, pnu, pQd, pustar_a ) + !!--------------------------------------------------------------------- + !! Computes the thickness (m) of the viscous skin layer. + !! Based on Fairall et al., 1996 + !! + !! Fairall, C. W., Bradley, E. F., Godfrey, J. S., Wick, G. A., + !! Edson, J. B., and Young, G. S. ( 1996), Cool‐skin and warm‐layer + !! effects on sea surface temperature, J. Geophys. Res., 101( C1), 1295-1308, + !! doi:10.1029/95JC03190. + !! + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: delta_skin_layer + REAL(wp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pnu ! kinematic viscosity of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] + ! ! => term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + !!--------------------------------------------------------------------- + REAL(wp) :: zusw, zusw2, zlamb, ztf, ztmp + !!--------------------------------------------------------------------- + ztf = 0.5_wp + SIGN(0.5_wp, pQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) + ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 + ! ! (ex: weak evaporation and strong positive sensible heat flux) + zusw = MAX(pustar_a, 1.E-4_wp) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! + zlamb = rcsa*( 1._wp + MAX(palpha*rcst_cs*pnu*pnu*pnu/(zusw2*zusw2)*pQd, 0._wp)**0.75 )**(-1./3.) ! see Eq.(14) in Fairall et al., 1996 + ! => zlamb is not used when Qd > 0, and since rcst_cs < 0, we just use this "MAX" to prevent FPE errors (something_negative)**0.75 + ! + ztmp = pnu/zusw + delta_skin_layer = (1._wp-ztf) * zlamb*ztmp & ! regular case, Qd < 0, see Eq.(12) in Fairall et al., 1996 + & + ztf * MIN(rcsa*ztmp , 0.007_wp) ! when Qd > 0 + END FUNCTION delta_skin_layer + FUNCTION PHI( pzeta) + !!--------------------------------------------------------------------- + !! + !! Takaya et al., 2010 + !! Eq.(5) + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: PHI + REAL(wp), INTENT(in) :: pzeta ! stability parameter + !!--------------------------------------------------------------------- + REAL(wp) :: ztf, zzt2 + !!--------------------------------------------------------------------- + zzt2 = pzeta*pzeta + ztf = 0.5_wp + SIGN(0.5_wp, pzeta) ! zeta > 0 => ztf = 1 + ! ! zeta < 0 => ztf = 0 + PHI = ztf * ( 1._wp + (5._wp*pzeta + 4._wp*zzt2)/(1._wp + 3._wp*pzeta + 0.25_wp*zzt2) ) & ! zeta > 0 + & + (1._wp - ztf) * 1._wp/SQRT( 1._wp - 16._wp*(-ABS(pzeta)) ) ! zeta < 0 + END FUNCTION PHI + !!====================================================================== +END MODULE sbcblk_skin_ecmwf \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbccpl.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbccpl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..11758fc4fc2e0f3cab3468ae02fae3504dc6b6fd --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbccpl.F90 @@ -0,0 +1,2733 @@ +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_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + 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 :: jpr_qtrice = 58 ! Transmitted solar thru sea-ice + + 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 +!! TYPE(FLD_C) :: sn_rcv_qtrice +!! ! ! 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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbccpl.F90 14590 2021-03-05 13:21:05Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_cpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_cpl_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(4) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) + +#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( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) + + sbc_cpl_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbccpl', sbc_cpl_alloc ) + IF( sbc_cpl_alloc > 0 ) CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed') + ! + END FUNCTION sbc_cpl_alloc + + + SUBROUTINE sbc_cpl_init( k_ice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_init *** + !! + !! ** Purpose : Initialisation of send and received information from + !! the atmospheric component + !! + !! ** Method : * Read namsbc_cpl namelist + !! * define the receive interface + !! * define the send interface + !! * initialise the OASIS coupler + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) + ! + INTEGER :: jn ! dummy loop index + INTEGER :: ios, inum ! Local integer + REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos + !! + NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & + & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & + & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & + & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & + & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & + & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_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 !!, sn_rcv_qtrice + !!--------------------------------------------------------------------- + ! + ! ================================ ! + ! 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,*)' transmitted solar thru sea-ice = ', TRIM(sn_rcv_qtrice%cldes), ' (', TRIM(sn_rcv_qtrice%clcat), ')' + WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' + WRITE(numout,*)' 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 conduction flux ! + ! ! --------------------------------- ! + srcv(jpr_topm )%clname = 'OTopMlt' + srcv(jpr_botm )%clname = 'OBotMlt' + IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN + IF ( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN + srcv(jpr_topm:jpr_botm)%nct = nn_cats_cpl + ELSE + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' ) + ENDIF + srcv(jpr_topm:jpr_botm)%laction = .TRUE. + ENDIF +!! ! ! --------------------------- ! +!! ! ! transmitted solar thru ice ! +!! ! ! --------------------------- ! +!! srcv(jpr_qtrice)%clname = 'OQtr' +!! IF( TRIM(sn_rcv_qtrice%cldes) == 'coupled' ) THEN +!! IF ( TRIM( sn_rcv_qtrice%clcat ) == 'yes' ) THEN +!! srcv(jpr_qtrice)%nct = nn_cats_cpl +!! ELSE +!! CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qtrice%clcat should always be set to yes currently' ) +!! ENDIF +!! srcv(jpr_qtrice)%laction = .TRUE. +!! ENDIF + + ! ! ------------------------- ! + ! ! ice skin temperature ! + ! ! ------------------------- ! + srcv(jpr_ts_ice)%clname = 'OTsfIce' ! needed by Met Office + IF ( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' ) srcv(jpr_ts_ice)%laction = .TRUE. + IF ( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' ) srcv(jpr_ts_ice)%nct = nn_cats_cpl + IF ( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = nn_cats_cpl + +#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 + + ! ! ------------------------- ! + ! ! 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.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) + ENDIF + llnewtx = .TRUE. + ELSE + llnewtx = .FALSE. + ENDIF + ! ! ========================= ! + ELSE ! No dynamical coupling ! + ! ! ========================= ! + frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero + frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead + llnewtx = .TRUE. + ! + ENDIF + ! ! ========================= ! + ! ! wind stress module ! (taum) + ! ! ========================= ! + IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received + ! => need to be done only when otx1 was changed + IF( llnewtx ) THEN + DO jj = 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.0_wp ) + llnewtau = .TRUE. + ELSE + llnewtau = .FALSE. + ENDIF + ELSE + llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv + ! Stress module can be negative when received (interpolation problem) + IF( llnewtau ) THEN + frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) ) + ENDIF + ENDIF + ! + ! ! ========================= ! + ! ! 10 m wind speed ! (wndm) + ! ! ========================= ! + IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received + ! => need to be done only when taumod was changed + IF( llnewtau ) THEN + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = 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( CASTDP(sst_m(:,:)), CASTDP(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(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: itx ! index of taux over ice + REAL(wp) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty + !!---------------------------------------------------------------------- + ! +#if defined key_si3 || defined key_cice + ! + 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.0_wp, p_tauj, 'V', -1.0_wp ) + END SELECT + + ENDIF + ! +#endif + ! + END SUBROUTINE sbc_cpl_ice_tau + + + SUBROUTINE sbc_cpl_ice_flx( kt, picefr, palbi, psst, pist, phs, phi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_ice_flx *** + !! + !! ** Purpose : provide the heat and freshwater fluxes of the ocean-ice system + !! + !! ** Method : transform the fields received from the atmosphere into + !! surface heat and fresh water boundary condition for the + !! ice-ocean system. The following fields are provided: + !! * total non solar, solar and freshwater fluxes (qns_tot, + !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) + !! NB: emp_tot include runoffs and calving. + !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where + !! emp_ice = sublimation - solid precipitation as liquid + !! precipitation are re-routed directly to the ocean and + !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) + !! * solid precipitation (sprecip), used to add to qns_tot + !! the heat lost associated to melting solid precipitation + !! over the ocean fraction. + !! * heat content of rain, snow and evap can also be provided, + !! otherwise heat flux associated with these mass flux are + !! guessed (qemp_oce, qemp_ice) + !! + !! - the fluxes have been separated from the stress as + !! (a) they are updated at each ice time step compare to + !! an update at each coupled time step for the stress, and + !! (b) the conservative computation of the fluxes over the + !! sea-ice area requires the knowledge of the ice fraction + !! after the ice advection and before the ice thermodynamics, + !! so that the stress is updated before the ice dynamics + !! while the fluxes are updated after it. + !! + !! ** Details + !! qns_tot = (1-a) * qns_oce + a * qns_ice => provided + !! + qemp_oce + qemp_ice => recalculated and added up to qns + !! + !! qsr_tot = (1-a) * qsr_oce + a * qsr_ice => provided + !! + !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce). + !! runoff (which includes rivers+icebergs) and iceshelf + !! are provided but not included in emp here. Only runoff will + !! be included in emp in other parts of NEMO code + !! + !! ** Note : In case of the ice-atm coupling with conduction fluxes (such as Jules interface for the Met-Office), + !! qsr_ice and qns_ice are not provided and they are not supposed to be used in the ice code. + !! However, by precaution we also "fake" qns_ice and qsr_ice this way: + !! qns_ice = qml_ice + qcn_ice ?? + !! qsr_ice = qtr_ice_top ?? + !! + !! ** Action : update at each nf_ice time step: + !! qns_tot, qsr_tot non-solar and solar total heat fluxes + !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice + !! emp_tot total evaporation - precipitation(liquid and solid) (-calving) + !! emp_ice ice sublimation - solid precipitation over the ice + !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice + !! sprecip solid precipitation over the ocean + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple) + REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] + ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling + REAL(dp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo + REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] + REAL(dp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office + REAL(dp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] + REAL(dp), 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 defined key_si3 || defined key_cice + ! + IF( kt == nit000 ) THEN + ! allocate ice fractions from last coupling time here and not in sbc_cpl_init because of jpl + IF( .NOT.ALLOCATED(a_i_last_couple) ) ALLOCATE( a_i_last_couple(jpi,jpj,jpl) ) + ! initialize to a_i for the 1st time step + a_i_last_couple(:,:,:) = a_i(:,:,:) + ENDIF + ! + 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 + + ! --- 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 + +!! for CICE ?? +!!$ 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 + ! + ! outputs + 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' , zevap_ice_total(:,:) * 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) & + & - zevap_ice_total(:,:) * 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 + !!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 + ! + ! ! ================================= ! + SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! ice topmelt and conductive flux ! + ! ! ================================= ! + 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 + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) + ! ! ========================= ! + CASE( 'oce only' ) ! the required field is directly provided + ! Get the sea ice non solar heat flux from conductive, melting and sublimation fluxes + IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN + zqns_ice(:,:,:) = qml_ice(:,:,:) + qcn_ice(:,:,:) + ELSE + zqns_ice(:,:,:) = 0._wp + ENDIF + ! Calculate the total non solar heat flux. The ocean only non solar heat flux (zqns_oce) will be recalculated after this CASE + ! statement to be consistent with other coupling methods even though .zqns_oce = frcv(jpr_qnsoce)%z3(:,:,1) + zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(:,:,:), dim=3 ) + 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 + + ! --- 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 + +!! for CICE ?? +!!$ ! --- non solar flux over ocean --- ! +!!$ 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 +!!$ + ! 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') ) & ! heat flux from rain (cell average) + & CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF ( iom_use('hflx_evap_cea') ) & ! heat flux from evap (cell average) + & CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) ) & + & * zcptn(:,:) * tmask(:,:,1) ) + IF ( iom_use('hflx_prec_cea') ) & ! heat flux from all precip (cell avg) + & CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF ( iom_use('hflx_snow_cea') ) & ! heat flux from snow (cell average) + & CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) + IF ( iom_use('hflx_snow_ao_cea') ) & ! heat flux from snow (over ocean) + & CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) + IF ( iom_use('hflx_snow_ai_cea') ) & ! heat flux from snow (over ice) + & CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) + ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. + ! + ! ! ========================= ! + 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 + ! + ! ! ========================= ! + 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 the Met Office the only sea ice solar flux is the transmitted qsr which is added onto zqsr_ice + ! further down. Therefore start zqsr_ice off at zero. + 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 + ! ! ========================= ! + ! ! 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 ==! + ! +!! SELECT CASE( TRIM( sn_rcv_qtrice%cldes ) ) +!! ! +!! ! ! ===> here we receive the qtr_ice_top array from the coupler +!! CASE ('coupled') +!! IF (ln_scale_ice_flux) THEN +!! WHERE( a_i(:,:,:) > 1.e-10_wp ) +!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) +!! ELSEWHERE +!! zqtr_ice_top(:,:,:) = 0.0_wp +!! ENDWHERE +!! ELSE +!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) +!! ENDIF +!! +!! ! Add retrieved transmitted solar radiation onto the ice and total solar radiation +!! zqsr_ice(:,:,:) = zqsr_ice(:,:,:) + zqtr_ice_top(:,:,:) +!! zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(:,:,:), dim=3 ) +!! +!! ! if we are not getting this data from the coupler then assume zero (fully opaque ice) +!! CASE ('none') + zqtr_ice_top(:,:,:) = 0._wp +!! END SELECT + ! + 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(:,:) + qtr_ice_top(:,:,jl) = qtr_ice_top(:,:,jl) * xcplmask(:,:,0) + zqtr_ice_top(:,:,jl) * zmsk(:,:) + END DO + ELSE + qsr_tot (:,: ) = zqsr_tot (:,: ) + qsr_ice (:,:,:) = zqsr_ice (:,:,:) + qtr_ice_top(:,:,:) = zqtr_ice_top(:,:,:) + ENDIF + + ! --- 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 + + ! ! ================== ! + ! ! 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.0_wp, zity1, 'T', -1.0_wp ) + 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.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) + ! + ENDIF + ! + ! + IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! + ! spherical coordinates to cartesian -> 2 components to 3 components + IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN + ztmp1(:,:) = zotx1(:,:) ! ocean currents + ztmp2(:,:) = zoty1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) + ! + IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities + ztmp1(:,:) = zitx1(:,:) + ztmp1(:,:) = zity1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) + ENDIF + ENDIF + ! + IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid + ! + IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid + IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid + IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid + ! + ENDIF + ! + ! ! ------------------------- ! + ! ! Surface current to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN + ! + ! j+1 j -----V---F + ! surface velocity always sent from T point ! | + ! j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO jj = 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.0_wp, zity1, 'T', -1.0_wp ) + 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.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) + ! + ! + IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! +! ! spherical coordinates to cartesian -> 2 components to 3 components +! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN +! ztmp1(:,:) = zotx1(:,:) ! ocean currents +! ztmp2(:,:) = zoty1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) +! ! +! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities +! ztmp1(:,:) = zitx1(:,:) +! ztmp1(:,:) = zity1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) +! ENDIF +! ENDIF + ! + IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + ! + ENDIF + ! + IF( ssnd(jps_ficet)%laction ) THEN + CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) + 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, CASTSP(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, CASTSP(RESHAPE ( e3t_n(:,:,1) , (/jpi,jpj,1/) )), info ) + ENDIF + ! ! Qsr fraction + IF( ssnd(jps_fraqsr)%laction ) THEN + CALL cpl_snd( jps_fraqsr, isec, CASTSP(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, CASTSP(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(CASTSP(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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcdcy.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcdcy.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bfcf1f0232254c5e31201df5b0f49dd3e9ec7580 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcdcy.F90 @@ -0,0 +1,254 @@ +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: sbcdcy.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_dcy_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_dcy_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( raa (jpi,jpj) , rbb (jpi,jpj) , rcc (jpi,jpj) , rab (jpi,jpj) , & + & rtmd(jpi,jpj) , rdawn(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------------------------ + !!--------------------------------------------------------------------- + ! + ! 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 + + CONTAINS + + FUNCTION fintegral(pt1, pt2, paaa, pbbb, pccc) + REAL(wp), INTENT(IN) :: pt1, pt2, paaa, pbbb, pccc ! dummy statement function arguments + REAL(wp) :: fintegral ! return value + fintegral = & + & paaa * pt2 + zinvtwopi * pbbb * SIN(pccc + ztwopi * pt2) & + & - paaa * pt1 - zinvtwopi * pbbb * SIN(pccc + ztwopi * pt1) + END FUNCTION fintegral + ! + END FUNCTION sbc_dcy + + !!====================================================================== +END MODULE sbcdcy \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcflx.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcflx.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e4b431c2791ad0a9aa856065e4eae4c0f97457d2 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcflx.F90 @@ -0,0 +1,188 @@ +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) + USE timing ! Timing + + 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: sbcflx.F90 13484 2020-09-17 12:45:07Z clem $ + !! 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( ln_timing_detail ) CALL timing_start('sbc_flx') + ! + 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, qsr, 'T', 1._wp ) + CALL lbc_lnk_multi( 'sbcflx', emp , '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 = 0.5_wp * 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 ) + ! + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_flx') + ! + END SUBROUTINE sbc_flx + + !!====================================================================== +END MODULE sbcflx diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcfwb.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcfwb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..39f9e3aef58e80ccf1bcb6116b032086b084e77a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcfwb.F90 @@ -0,0 +1,823 @@ +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 + !! 4.0 ! 2021-10 (H. Zuo) bug-fix and improvement on nn_fwb=4 + !! update flx_m instead of flx_t when using GRACE data + !! add sfx update + !! add different methods for distributing emp adjustment + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 sbchbp ! steric height and bottom pressure + ! + 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 ! + USE fldread ! read input fields + USE restart ! for lrst_oce + USE iom ! IOM library + USE asminc + USE asmpar + USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar + + 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) + + ! Variables for nn_fwb==4 option + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssh ! structure of input SSH (file informations, fields read) + REAL(wp) :: flx_v, flx_vn, flx_vb ! volume flux global correction + REAL(wp) :: flx_m, flx_mn, flx_mb ! mass flux global correction + REAL(wp) :: flx_t, flx_tn, flx_tb ! total sea level correction + REAL(wp) :: sl0 ! now value of prescribed sea level + REAL(wp) :: sl00 ! Initial offset in external global sea level + REAL(wp) :: om0 ! now value of prescribe ocean mass + REAL(wp) :: om00 ! Initial offset in external ocean mass + REAL(wp) :: rd_fwb ! time scale to apply fwb correction (days), smaller value = strong corr + REAL(wp) :: rd_emp ! time scale to apply emp correction (days), smaller value = strong corr + REAL(wp) :: rcap ! maximum allowed value for global fwb correction (mm) + REAL(wp) :: fct_fwb ! relaxation factor + REAL(wp) :: fct_fwb0 ! normalization factor + REAL(wp) :: fct_emp ! relaxation factor for emp correction + INTEGER :: ikt_fwb ! freq (time steps) to estimate fwb + INTEGER :: nr_ssh ! =1 if the global mean sea level is provided by an input file + INTEGER :: aj_ssh ! =0 constant adjustment in nn_fwb=4 + + INTEGER :: numfwb ! number for output PME record + LOGICAL :: lforce_fwb ! force flx_t balance after capping + LOGICAL :: lfwbr ! read EMP file at start of exp + + ! Use restarts to get information on FWB + + LOGICAL :: ln_fwbinrst = .TRUE. ! Put EMP info in restart file + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcfwb.F90 13581 2020-10-09 11:49:08Z mathiot $ + !! 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 :: ierror + INTEGER :: nr_sshprv ! previous information file + TYPE(FLD_N) :: sn_ssh ! informations about the fields to be read + CHARACTER (len=100) :: cn_dir ! Root directory for location of global ssh data files + NAMELIST/namsbc_fwb/ rd_fwb, rd_emp, ikt_fwb, nr_ssh, aj_ssh, cn_dir, sn_ssh, rcap, lfwbr, lforce_fwb, ln_fwbinrst + CHARACTER (len=128) :: clname + REAL(wp) :: z_emp, empm ! temporary scalars + !REAL(wp) :: empold ! empold to be suppressed + REAL(wp) :: resi ! estimated residual from adjustment + REAL(wp) :: ssh_trd ! model ssh tendency + REAL(wp) :: hst_trd ! model steric height tendency + REAL(wp) :: hbp_trd ! model bottom pressure tendency + REAL(wp) :: sl0_trd ! prescribed sl tendency + REAL(wp) :: om0_trd ! prescribed ocean mass tendency + REAL(wp) :: emp_ext ! target emp value from external product + REAL(wp) :: asm0 ! total assimilation increment + INTEGER :: ikt_flag + INTEGER :: inum, ikty, iyear ! local integers + REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_flxm, zsum_flxv, zsum_erp, zsum_emp, zsum_empb, zsum_empn ! 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, zsshm_cor, zsshv_cor ! - - + INTEGER :: inyear, inmonth, inday, inhour, inmin, insec + REAL(wp) :: zjul, znsec + LOGICAL :: lok + REAL(wp) :: ztmp + INTEGER :: ios + REAL(wp) ,DIMENSION(1) :: z_fwfprv + COMPLEX(dp),DIMENSION(1) :: y_fwfnow + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_fwb') + ! + ikt_flag = 1 + 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' + IF( kn_fwb == 4 ) WRITE(numout,*) ' fwf from file (i)residual of SL minus steric height (ii) Grace' + 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 ' ) + IF( kn_fwb == 4 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 4 with ln_isfcav = .TRUE. not working, we stop ' ) + ! + IF( kn_fwb == 4 ) THEN + nr_ssh = 0 + aj_ssh = 0 + nr_sshprv=0 + cn_dir = './' + rd_fwb = 1. + rd_emp = 1 ! if rd_emp=0.04 which is equivalent to ~1/24 day, then hourly correction + ikt_fwb = 1 + sl0 = 0._wp + sl00 = 0._wp + rcap=0.1_wp + lfwbr=.FALSE. + lforce_fwb=.FALSE. + ! ... default values of SSH structure. DEFAULT value of none if no file is needed + ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! land/sea mask ! + ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs + sn_ssh = FLD_N( 'ssh' , -1. , 'ssh' , .TRUE. , .TRUE. , 'yearly', '', '', '') + ! + REWIND( numnam_ref ) ! Namelist namsbc_fwb in reference namelist : Surface boundary + READ ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_fwb in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_fwb in configuration namelist : Parameters of the run + READ ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_fwb in configuration namelist' ) + IF ( nit000 > 1 ) lfwbr=.true. + + IF(lwp) THEN + WRITE(numout,*) ' time scale to apply fwb correction (days) = ',& + & rd_fwb + WRITE(numout,*) ' time scale to apply emp correction (days) = ',& + & rd_emp + WRITE(numout,*) ' freq (time steps) to estimate fwb = ',& + & ikt_fwb + WRITE(numout,*) ' maximum allowed correction (mm) = ',& + & rcap + + WRITE(numout,*) ' force to read PME file at start = ',& + & lfwbr + IF( nr_ssh >= 1 ) THEN + WRITE(numout,*) ' Reading global mean sea level from file = ',& + & sn_ssh%clname + + WRITE(numout,*) ' method of adjusting surface fluxes = ',& + & aj_ssh + + WRITE(numout,*) ' write PME in restart file = ',& + & ln_fwbinrst + ENDIF + ENDIF + ENDIF + ! + IF( kn_fwb == 4 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 4 requires nn_sssr = 2, 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) + lok = .FALSE. + IF (ln_fwbinrst) THEN + IF( iom_varid( numror, 'nn_fwb', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, 'nn_fwb', ztmp ) + lok=.TRUE. + ELSE + ztmp=0 + ENDIF + lok = lok.AND.(kn_fwb==INT(ztmp)) + IF (lok) THEN + IF (lwp ) WRITE(numout, *) 'Reading EMPave_old data from restart.' + CALL iom_get( numror, 'fwb_nyear', ztmp ) + iyear = INT(ztmp) + CALL iom_get( numror, 'fwb_a_fwb_b', a_fwb_b ) + CALL iom_get( numror, 'fwb_a_fwb', a_fwb ) + ELSE + IF(lwp) WRITE(numout,*)'FWB information not found in restart.' + IF(lwp) WRITE(numout,*)'Reverting to try to read the text file.' + ENDIF + ENDIF + IF (.NOT.lok) THEN + 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 ) + ENDIF + 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 ( ln_fwbinrst .AND. lrst_oce ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'nn_fwb', REAL(kn_fwb) ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_nyear', REAL(nyear) ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_a_fwb_b', a_fwb_b ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_a_fwb', a_fwb ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ELSEIF( kt == nitend .AND. lwm ) THEN ! save fwfold value in a file + 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.0_wp ) + ! + emp(:,:) = emp(:,:) + zerp_cor(:,:) + qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction + erp(:,:) = erp(:,:) + zerp_cor(:,:) + ! + 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 ( 4 ) ! emp budget adjusted with variable time scale + ! options for case 4: + ! nr_ssh =0 the target sea level (sl0 ) is zero + ! nr_ssh =1 the target sea level (sl0 ) is read from file. + ! nr_ssh =2 the target ocean mass (om0 ) is read from file. + ! nr_ssh =3 new: apply emp corretion (BC of E from bulk formula) instead of fwb correction + ! the target emp value is read from external file + ! nn_hbp =0 the steric height (hst) changes are ignored. flx_v=0. + ! Nudging with time scale rd_fwb + ! =1 trends in sl and ssh are respect a fix reference + ! Nudging with time scale rd_fwb. The flux volume tendency + ! is diagnosed, with hst00 updated every ikt_fwb steps + ! =2 trends in sl and hst are from the previous + ! time step (ikt_fwb). The model ssh trends are ignored, + ! the tendency is specified with time scale ikt_fwb*rdt. + ! It is important to smoothe the flx_v=flx_vn+flx_vb to + ! avoid instabilities. + ! =3 the nudging is + ! initialisation + IF( kt == nit000 ) THEN + ! Read the corrective factor on precipitations (empold) + IF ( lfwbr ) THEN + ! Read the corrective factor on precipitations (empold) + lok=.FALSE. + IF (ln_fwbinrst) THEN + IF( iom_varid( numror, 'nn_fwb', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, 'nn_fwb', ztmp ) + lok=.TRUE. + ELSE + ztmp=0 + ENDIF + lok = lok.AND.(kn_fwb==INT(ztmp)) + IF (lok) THEN + IF (lwp ) WRITE(numout, *) 'Reading EMPave_old data from restart.' + CALL iom_get( numror, 'fwb_kt', ztmp ) + ikt_flag = INT(ztmp) + CALL iom_get( numror, 'fwb_nr_ssh', ztmp ) + nr_sshprv = INT(ztmp) + CALL iom_get( numror, 'fwb_flx_m', flx_m ) + CALL iom_get( numror, 'fwb_flx_mn', flx_mn ) + CALL iom_get( numror, 'fwb_flx_mb', flx_mb ) + CALL iom_get( numror, 'fwb_flx_v', flx_v ) + CALL iom_get( numror, 'fwb_flx_vn', flx_vn ) + CALL iom_get( numror, 'fwb_flx_vb', flx_vb ) + CALL iom_get( numror, 'fwb_sl0', sl0 ) + CALL iom_get( numror, 'fwb_sl00', sl00 ) + CALL iom_get( numror, 'fwb_om0', om0 ) + CALL iom_get( numror, 'fwb_om00', om00 ) + CALL iom_get( numror, 'fwb_ssh0', ssh0 ) + CALL iom_get( numror, 'fwb_ssh00', ssh00 ) + CALL iom_get( numror, 'fwb_hst0', hst0 ) + CALL iom_get( numror, 'fwb_hst00', hst00 ) + CALL iom_get( numror, 'fwb_hbp0', hbp0 ) + CALL iom_get( numror, 'fwb_hbp00', hbp00 ) + IF (lwp ) WRITE(numout, "(24X,2I8,16ES24.16)") & + & ikt_flag, nr_sshprv, & + & flx_m, flx_mn, flx_mb, flx_v, flx_vn, flx_vb, & + & sl0, sl00, om0, om00, ssh0, ssh00, hst0, hst00, hbp0, hbp00 + ikt_flag=1 + ELSE + IF(lwp) WRITE(numout,*)'FWB information not found in restart.' + IF(lwp) WRITE(numout,*)'Reverting to try to read the text file.' + ENDIF + ENDIF + IF (.NOT.lok) THEN + IF (lwp ) WRITE(numout, *) ' opening EMPave_old.dat ' + clname = 'EMPave_old.dat' + IF (lwp ) WRITE(numout, *) ' reading EMPdat ' + CALL ctl_opn( inum, clname, 'OLD', 'FORMATTED','SEQUENTIAL', & + & 1, numout, .FALSE., 1 ) + READ (inum, "(24X,2I8,16ES24.16)" ) & + & ikt_flag, nr_sshprv, & + & flx_m, flx_mn, flx_mb, flx_v, flx_vn,flx_vb, & + & sl0, sl00, om0, om00, ssh0, ssh00, hst0, hst00, hbp0, hbp00 + IF (lwp ) WRITE(numout, "(24X,2I8,16ES24.16)") & + & ikt_flag, nr_sshprv, & + & flx_m, flx_mn, flx_mb, flx_v, flx_vn, flx_vb, & + & sl0, sl00, om0, om00, ssh0, ssh00, hst0, hst00, hbp0, hbp00 + CLOSE( inum ) + ikt_flag=1 + ENDIF + ELSE + ! Begining of experiments with values of zeros. + IF (lwp ) WRITE(numout, *) ' fresh budget reset to zero ' + ikt_flag = -1 + nr_sshprv=nr_ssh + flx_m = 0. + flx_mb = 0. + flx_mn = 0. + flx_v = 0. + flx_vn = 0. + flx_vb = 0. + sl0 = 0. + sl00 = 0. + om0 = 0. + om00 = 0. + emp_ext = 0. + ENDIF + !open file for fwb statistics + IF ( narea == 1 ) THEN + CALL ctl_opn( numfwb,'FWB.stat', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', & + 1, numout, lwp, 1 ) + + WRITE (numfwb, *)' timestep ', ikt_flag + WRITE (numfwb, *)' flx_m,(n,b) ', flx_m, flx_mn, flx_mb + WRITE (numfwb, *)' flx_v,(n,b) ', flx_v, flx_vn, flx_vb + WRITE (numfwb, *)' sl0 , sl00 ', sl0,sl00 + WRITE (numfwb, *)' om0 , om00 ', om0,om00 + WRITE (numfwb, *)' ssh0 ,ssh00 ', ssh0,ssh00 + WRITE (numfwb, *)' hst0, hst00 ', hst0,hst00 + WRITE (numfwb, *)' hbp0, hbp00 ', hbp0,hbp00 + WRITE (numfwb, *)' timestep sl0-sl00 om0-om00 ssh0-ssh00 hst0-hst00 hbp0-hbp00 flx_t flx_m flx_v residual' + ENDIF + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*)'sbc_fwb : timestep = ',ikt_flag ,' freshwater budget correction = ', flx_m,flx_v + + ! + IF( nr_ssh > 0 ) THEN + ALLOCATE( sf_ssh(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_ssr: unable to allocate sf_ssh structure' ) ; RETURN + ENDIF + ! fill sf_ssh and control print + CALL fld_fill( sf_ssh, (/ sn_ssh /), cn_dir, 'sbc_fwb', 'GLOBAL SSH data to close FWB', 'namsbc_fwb' ) + ALLOCATE( sf_ssh(1)%fnow(1,1,1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_ssr: unable to allocate sf_ssh structure' ) ; RETURN + ENDIF + IF( sf_ssh(1)%ln_tint ) THEN + ALLOCATE( sf_ssh(1)%fdta(1,1,1,2), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_ssr: unable to allocate sf_ssh structure' ) ; RETURN + ENDIF + ENDIF + ENDIF + !relaxation factor + fct_fwb0 = 1./( ikt_fwb*rdt ) ! volume flux relaxation factor + IF ( nn_hbp /= 2 ) fct_fwb = 1./( rday * rd_fwb ) + IF ( nn_hbp == 2 ) fct_fwb = fct_fwb0 + IF ( nr_ssh == 3 ) fct_emp = rdt/(rday * rd_emp + rsmall ) ! this is used only for emp correction when nr_ssh=3 + ELSE !kt /= nit000 + nr_sshprv=nr_ssh + ENDIF + ! + ! update values of global sea level + ! + IF( nr_ssh > 0 ) THEN + CALL fld_read( kt, ikt_fwb, sf_ssh ) !read SSH or GRACE data + IF ( nr_ssh == 1 ) THEN + IF (lwp) WRITE (numout,*)' sbc_fwb reading sl0 from file ' + sl0=sf_ssh(1)%fnow(1,1,1) !SSH + ELSEIF ( nr_ssh == 2 ) THEN + IF (lwp) WRITE (numout,*)' sbc_fwb reading om0 from file ' + om0=sf_ssh(1)%fnow(1,1,1) !Ocean mass + ELSEIF ( nr_ssh == 3 ) THEN + IF (lwp) WRITE (numout,*)' sbc_fwb reading emp_ext target from file ' + emp_ext=sf_ssh(1)%fnow(1,1,1) !target emp from external file + ENDIF + ENDIF + + IF ( nr_ssh /= 3 ) THEN + IF ( ikt_flag < 0 ) THEN + ikt_flag=1 + IF ( nr_ssh == 1) THEN + IF (lwp) WRITE(numout,*)'CHANGING SL00 ',sl00,sl0 + sl00=sl0 + ENDIF + IF ( nr_ssh == 2) THEN + IF (lwp) WRITE(numout,*)'CHANGING OM00 ',om00,om0 + om00=om0 + ENDIF + ELSE + IF ( nr_sshprv /= nr_ssh ) THEN + IF (lwp) WRITE(numout,*)'CHANGING INFORMATION METHOD ', & + & 'from ',nr_sshprv,' to ',nr_ssh + ! change reference values to ensure coninuity. + ! Effectively we reset to origin. + sl00=sl0 + om00=om0 + IF (nr_sshprv == 2 ) ssh00 = ssh0 !we reset to model origin + IF (nr_sshprv == 1 ) hbp00 = hbp0 + ENDIF + ENDIF + IF (lwp) WRITE (numout,*)' sbc_fwb kt, sl0, sl00',kt, sl0,sl00 + IF (lwp) WRITE (numout,*)' sbc_fwb kt, om0, om00',kt, om0,om00 + IF (lwp) WRITE (numout,*)' ~~~~~~~~' + ELSE + IF (lwp) WRITE (numout,*)' sbc_fwb kt, emp_ext',kt, emp_ext + IF (lwp) WRITE (numout,*)' ~~~~~~~~' + ENDIF + ! + ! Update empold if at ikt_fwb time step + ! + IF( MOD( kt, ikt_fwb ) == 0 ) THEN + + asm0=0. + ssh0 = glob_sum( 'sbcfwb', e1e2t(:,:) * sshb(:,:) ) + hst0 = glob_sum( 'sbcfwb', e1e2t(:,:) * hst(:,:) ) + z_emp = glob_sum( 'sbcfwb', e1e2t(:,:) * emp(:,:) ) +#if defined key_asminc + IF ( lk_asminc .AND. ln_asmiau .AND. ln_sshinc) & + & asm0 = glob_sum( 'sbcfwb', e1e2t(:,:) * ssh_iau(:,:) ) +#endif + + ssh0 = ssh0 / area + hst0 = hst0 / area + z_emp = z_emp/ area + empm = z_emp + asm0 = asm0 / area + hbp0 = ssh0 - hst0 + ssh_trd = ssh0 - ssh00 + hst_trd = hst0 - hst00 + hbp_trd = hbp0 - hbp00 + ! Salt fluxes in Kg/m3/s (~ mm/s). 1.e3 factor from m/s to mm/s + IF ( nn_hbp == 0 ) THEN + flx_vn = 0. + ELSE + flx_vn = -1.*( hst_trd )* rauw * fct_fwb0 + ENDIF + IF ( nn_hbp /= 2 ) THEN + z_emp=0. + asm0 =0. + ELSE + ssh_trd=0. + ENDIF + IF (( nr_ssh == 0 ) .OR. (nr_ssh == 1 )) THEN + sl0_trd = sl0 -sl00 + ! ssh used here to compute ssh_trd will be updated by emp and asm in the ssh_nxt step + ! + flx_tn = (( ssh_trd - sl0_trd )* rauw * fct_fwb - z_emp + asm0) !global mean total FW adjustment + flx_mn = flx_tn - flx_vn !global mean FW_mass adjustment + ELSEIF ( nr_ssh == 2 ) THEN + om0_trd = om0 - om00 + flx_mn = (( hbp_trd - om0_trd )* rauw * fct_fwb - z_emp + asm0) + flx_tn = flx_mn + flx_vn + ELSEIF ( nr_ssh == 3 ) THEN + flx_mn = ( emp_ext - empm )* fct_emp + flx_tn = flx_mn + flx_vn + ENDIF + + !debug 1 + !IF (lwp) WRITE(numout,*) 'sbc_fwb kt,ssh_trd, hbp_trd, hst_trd, exp_ext, empm :',kt,ssh_trd,hbp_trd,hst_trd,emp_ext,empm + !IF (lwp) WRITE(numout,*) 'sbc_fwb kt,flx_tn, flx_mn, flx_vn:',kt,flx_tn,flx_mn,flx_vn + + ! additional: step 1 + ! smooth flx_v, may not be necessary + flx_v = (flx_vb + flx_vn ) *.5 !average volume flux + flx_t = flx_tn + flx_m = flx_t - flx_v + + ! additional: step 2 + ! cap flx_m value if too large. + flx_m = MIN( flx_m, rcap/rday ) + flx_m = MAX( flx_m, -rcap/rday ) + IF ( ABS(flx_t - (flx_m + flx_v) ) .GT. 1.e-10) THEN + IF (lwp) THEN + WRITE(numout,*)' capping values of flx_m for flx_t',flx_t + WRITE(numout,*)' after, flx_mn, flx_vn : ',flx_m, flx_v + WRITE(numout,*)' before, flx_mn, flx_vn : ',flx_t-flx_v,flx_v + ENDIF + IF (( nn_hbp == 2 ) .AND. (lforce_fwb)) THEN + flx_v = flx_t - flx_m + ELSE + flx_t = flx_v + flx_m + ENDIF + ENDIF + IF (lwp) WRITE(numout,*) 'sbc_fwb kt,asm0,ssh_trd,z_emp :',kt,asm0,ssh_trd,z_emp + ! + + !!debug 2 + !IF (lwp) WRITE(numout,*) 'sbc_fwb kt,flx_t, flx_m, flx_v:',kt,flx_t,flx_m,flx_v + + + IF( narea == 1 ) THEN + resi=sl0-sl00 - (ssh_trd - (flx_t + z_emp - asm0)/(rauw*fct_fwb)) + WRITE(numfwb,"(I8,9ES12.4)") kt, sl0-sl00, om0-om00, & + & ssh0-ssh00, hst0-hst00, hbp0-hbp00, & + & flx_t, flx_m, flx_v, resi + ENDIF + + flx_vb=flx_vn + flx_mb=flx_mn + flx_tb=flx_tn + IF ( nn_hbp == 2 ) THEN !all trnds over ikt_fwb timesteps + sl00=sl0 + om00=om0 + ssh00=ssh0 + hst00=hst0 + ENDIF + IF ( nn_hbp == 1 ) THEN + hst00=hst0 ! the hst trend is only over ikt_fwb time steps + ! all other 00_quantities from begining of the run + ENDIF + ENDIF + + !debug 3 + !IF (lwp) WRITE(numout,*) 'sbc_fwb kt,ssh0, hbp0, hst0:',kt,ssh0,hbp0,hst0 + + + ! + ! correct the freshwater, heat and salinity fluxes + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN + + zsum_flxv = flx_v * area + zsum_flxm = flx_m * area + zsum_fwf = zsum_flxv + zsum_flxm ! total emp adjustment needed to track GMSL + zsum_empb = glob_sum( 'sbcfwb', tmask_i(:,:) * emp(:,:) * e1e2t(:,:)) ! global sum of emp in Kg/s + + ! aj_ssh = 0 apply emp adjustment homogeneously in global ocean: r=constant + ! = 1 apply emp adjustment propotional to local emp value: r= emp_loc/emp_tot + ! = 2 apply emp adjustment propotionally but only in part of sea surface (depends on sign of flx_m) + ! = 3 (to do) use different weight to distribute flx_v and flx_m adjustments + IF ( aj_ssh == 0 ) THEN ! adjusting all fluxes using global mean constant value + + emp (:,:) = emp (:,:) + flx_m + flx_v ! both EBP and steric terms add a layer of water in the surface + qns(:,:) = qns(:,:) - ( flx_m + flx_v) * rcp * sst_m(:,:) ! both EBP and steric water layer take temperature from SST + sfx (:,:) = sfx (:,:) - flx_v * sss_m(:,:) ! EBP water layer is FW PSU=0; steric water layer take salinity = SSS + + ELSE ! adjusting flx_m fluxes proportional to local emp value + + ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zsshm_cor(jpi,jpj) , zsshv_cor(jpi,jpj) ) + ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of emp + WHERE( emp > 0._wp ) ztmsk_pos = 0._wp + ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) + + ! + IF ( aj_ssh == 1 ) THEN + zsurf_tospread = area + ztmsk_tospread(:,:) = tmask_i(:,:) + ELSEIF ( aj_ssh == 2 ) THEN + IF( zsum_flxm > 0._wp ) THEN ! spread out over emp < 0 area to reduce precipitation + zsurf_pos = glob_sum( 'sbcfwb', CASTDP(e1e2t(:,:)*ztmsk_pos(:,:)) ) + zsurf_tospread = zsurf_pos + ztmsk_tospread(:,:) = ztmsk_pos(:,:) + ELSE ! spread out over emp > 0 area to reduce evaporation + zsurf_neg = glob_sum( 'sbcfwb', CASTDP(e1e2t(:,:)*ztmsk_neg(:,:)) ) ! Area filled by <0 and >0 erp + zsurf_tospread = zsurf_neg + ztmsk_tospread(:,:) = ztmsk_neg(:,:) + ENDIF + ENDIF + + ! update ztmsk_tospread to exclude regions affected by Antarctic ice-sheet/iceberg/iceshelf melt water + ! use sf_t_rnf (iceberg temperature) as a mask + WHERE( icbmsk == 1._wp ) ztmsk_tospread = 0._wp + + ! ! weight to respect emp field 2D structure + zsum_emp = glob_sum( 'sbcfwb', CASTDP(ztmsk_tospread(:,:) * ABS( emp(:,:) )* e1e2t(:,:) )) + z_wgt(:,:) = ztmsk_tospread(:,:) * ABS( emp(:,:) ) / ( zsum_emp + rsmall ) + + ! z_wgt should be seperated for mass and volume adjustments + ! at moment we use the same z_wgt for both flx_m and flx_v adjustment + zsshm_cor(:,:) = zsum_flxm * z_wgt(:,:) + zsshv_cor(:,:) = zsum_flxv * z_wgt(:,:) + !zsshv_cor(:,:) = flx_v ! use constant volume adjustment everywhere + ! because steric height change is not correlated with local emp value? + ! Comment out becuase results is worser in the Med sea than using z_wgt in both aj_ssh=1/2 + + ! + CALL lbc_lnk( 'sbcfwb', zsshm_cor, 'T', 1.0_wp ) + CALL lbc_lnk( 'sbcfwb', zsshv_cor, 'T', 1.0_wp ) + ! + + IF( lwp ) THEN ! FWB adjustment diagnostics + WRITE(numout,*)' MIN(emp_adj) = ', MINVAL(zsshv_cor+zsshm_cor) ,' Kg/m2/s' + WRITE(numout,*)' MAX(emp_adj) = ', MAXVAL(zsshv_cor+zsshm_cor) ,' Kg/m2/s' + WRITE(numout,*)' MIN(emp) = ', MINVAL(emp) + WRITE(numout,*)' MAX(emp) = ', MAXVAL(emp) + ENDIF + + emp(:,:) = emp(:,:) + zsshm_cor(:,:) + zsshv_cor(:,:) + qns(:,:) = qns(:,:) - (zsshm_cor(:,:) + zsshv_cor(:,:)) * rcp * sst_m(:,:) + sfx(:,:) = sfx (:,:) - zsshv_cor(:,:) * sss_m(:,:) + + ! + DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zsshm_cor , zsshv_cor ) + + ENDIF + + zsum_empn = glob_sum( 'sbcfwb', tmask_i(:,:) * emp(:,:) * e1e2t(:,:) ) ! global sum of emp after adjustment + + IF( lwp ) THEN ! FWB adjustment diagnostics + WRITE(numout,*)' SUM(emp before) = ', zsum_empb *1.e-9,' Sv' + WRITE(numout,*)' SUM(emp after) = ', zsum_empn *1.e-9,' Sv' + WRITE(numout,*)' SUM(emp after - before) = ', (zsum_empn - zsum_empb) *1.e-9,' Sv' + WRITE(numout,*)' SUM(emp_adj_tot) = ', zsum_fwf *1.e-9,' Sv' + WRITE(numout,*)' SUM(emp_adj_m) = ', zsum_flxm *1.e-9,' Sv' + WRITE(numout,*)' SUM(emp_adj_v) = ', zsum_flxv *1.e-9,' Sv' + !WRITE(numout,*)' SUM(emp_adj) < 0 is downwards into the ocean' + !WRITE(numout,*)' SUM(emp_adj) >= 0 is upwards' + ENDIF + + ENDIF + ! + ! save empold value in a file + IF( ( ( kt == nitend ) .OR. & + & ( ( nn_stock > 0 ) .AND. ( MOD( kt, nn_stock ) == 0 ) ) .OR. & + & ( ( nn_stock < 0 ) .AND. lrst_oce .AND. ( MOD( kt, NINT(rday/rdt) ) == 0 ) ) ) ) THEN + IF ( ln_fwbinrst ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'nn_fwb', REAL(kn_fwb) ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_kt', REAL(kt) ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_nr_ssh', REAL(nr_ssh) ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_m', flx_m ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_mn', flx_mn ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_mb', flx_mb ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_v', flx_v ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_vn', flx_vn ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_flx_vb', flx_vb ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_sl0', sl0 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_sl00', sl00 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_om0', om0 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_om00', om00 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_ssh0', ssh0 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_ssh00', ssh00 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_hst0', hst0 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_hst00', hst00 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_hbp0', hbp0 ) + CALL iom_rstput( kt, nitrst, numrow, 'fwb_hbp00', hbp00 ) + ELSE + IF ( narea == 1 ) THEN + IF (ln_rsttime) THEN + inyear = ndate0 / 10000 + inmonth = ( ndate0 - (inyear * 10000) ) / 100 + inday = ndate0 - (inyear * 10000) - ( inmonth * 100 ) + ! CALL ymds2ju( inyear, inmonth, inday, ntime0*3600.0_wp, zjul ) + CALL ymds2ju( inyear, inmonth, inday, 0.0_wp, zjul ) + zjul = zjul + kt * rn_rdt / 86400.0_wp + CALL ju2ymds( zjul, inyear, inmonth, inday, znsec ) + inhour = INT( znsec / 3600_wp ) + inmin = INT( ( znsec - inhour * 3600_wp ) / 60.0_wp ) + insec = INT( znsec - inhour * 3600_wp - inmin * 60.0_wp ) + WRITE(clname,'(2A,I4.4,I2.2,I2.2,A,3I2.2,A)') TRIM(cexper),'_',& + & inyear, inmonth, inday, '_', inhour, inmin, insec, & + &'_EMPave.dat' + ELSE + WRITE(clname,'(2A,I8.8,A,I8.8,A)') TRIM(cexper),'_',ndastp,'_',kt,& + &'_EMPave.dat' + ENDIF + CALL ctl_opn( inum, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', & + & 1, numout, .FALSE., 0 ) + WRITE(inum, "(24X,2I8,16ES24.16)") & + & kt, nr_ssh, & + & flx_m, flx_mn, flx_mb, flx_v, flx_vn, flx_vb, & + & sl0, sl00, om0, om00, ssh0, ssh00, hst0, hst00, hbp0, hbp00 + CLOSE( inum ) + ENDIF + ENDIF + ENDIF + ! Close numfwb + IF( ( kt == nitend ) .AND. ( narea== 1 ) ) THEN + CLOSE( numfwb ) + ENDIF + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_fwb') + ! + END SUBROUTINE sbc_fwb + + !!====================================================================== +END MODULE sbcfwb diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbchbp.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbchbp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..09e7b91f740ea3708bf8388b3f164918cb929870 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbchbp.F90 @@ -0,0 +1,165 @@ +MODULE sbchbp + !!====================================================================== + !! *** MODULE sbchbp *** + !! Budgets closure : computation the steric height and bottom pressure + !!====================================================================== + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! sbc_hbp : steric height and bottomp pressure computation + !!---------------------------------------------------------------------- + !! * Modules used + 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 ocean boundary condition + USE iom ! I/O manager + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lib_fortran ! for global sum + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sbc_hbp ! called in sbc_fwb module + + !! * Module variables + REAL(wp), PUBLIC :: hst00 !Initial offset in global steric height + REAL(wp), PUBLIC :: ssh00 !Initial offset in model global sea level + REAL(wp), PUBLIC :: hbp00 !Initial value of global bpress + REAL(wp), PUBLIC :: ssh0 !current value of model global sea level + REAL(wp), PUBLIC :: hst0 !current value of global steric height + REAL(wp), PUBLIC :: hbp0 !current value of global bottom pressure + + + REAL(wp), PUBLIC, DIMENSION(:,:), SAVE, ALLOCATABLE :: & + hst, & ! steric heigh + hbp ! bottom pressure + +# include "single_precision_substitute.h90" + !! * Substitutions + !!---------------------------------------------------------------------- + !! OPA 9.0 , LOCEAN-IPSL (2005) + !! $Id: diahbp.F90 1152 2008-06-26 14:11:13Z rblod $ + !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE sbc_hbp ( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_hbp *** + !! + !! ** Purpose : Computes the steric heigh and bottom pressure in order + !! to close the fresh water budget + !! + !! Method : Vertical integration of insitu density anomaly. + !! + !! References : + !! A. E. Gill, atmosphere-ocean dynamics 7.7 pp 215 + !! + !! History : + !! ! 03-09 (M. Balmaseda). Takes into account partial steps + !! Notes : Important to use before fields for calculation and to + !! use rhoref(k) + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT( in ) :: kt ! ocean time-step index + + !! * Local declarations + INTEGER :: ji, jj, jk + INTEGER :: ik + REAL(wp) :: zhd, zarea + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhopb + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zrhdb + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_hbp') + ! + ! 1. steric height and bottom pressure + ! -------------------------------------- + + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_hbp : computation of steric heigh and bottom pressure' + IF(lwp) WRITE(numout,*) '~~~~~~~' + IF( ln_sco ) & + & CALL ctl_stop( ' ln_sco, Steric height calculation not yet implemented' ) + + ALLOCATE( & + & hst(jpi,jpj), & + & hbp(jpi,jpj) & + & ) + + ! Compute the reference insitu density profile + + CALL eos_rprof + + IF(lwp) THEN + DO jk = 1, jpk + WRITE(numout,*)' level, rhoref ',jk,rhoref(jk) + END DO + ENDIF + ENDIF + + ! Specific volume anomaly (zhd) with the before fields. + + CALL eos( tsb, zrhdb, zrhopb, gdept_n(:,:,:) ) !rhdb=(rhop-rau0)/rau0) + + ! Steric height (hst): Vertical integral of zhd from top to bottom *-1 + ! different definitions attempted. + ! h1(:,:)=h1(:,:) - e3t(:,:,jk) * rhdb(:,:,jk) + ! h2(:,:)=h2(:,:) - e3t(:,:,jk) * (rhopb(:,:,jk)/rauw -1.) + ! h3(:,:)=h3(:,:) - 0.5* e3w_n(:,:,jk) *(rhdb(:,:,jk) + rhdb(:,:,jk-1)) + ! hst (below) + hst(:,:)=0. + IF ( nn_hst == 1 ) THEN + hst(:,:)=zrhdb(:,:,1) * 0.5 * e3w_n(:,:,1) * tmask(:,:,1) + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zhd = (zrhdb(ji,jj,jk) + zrhdb(ji,jj,jk-1) )* 0.5 + hst(ji, jj) = hst(ji,jj) - zhd * e3w_n(ji,jj,jk) * & + & tmask(ji,jj,jk) * tmask(ji,jj,jk-1) + END DO + END DO + END DO + ELSE + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zhd = ( rau0*zrhdb(ji,jj,jk)+rau0 -rhoref(jk) ) / rhoref(jk) + hst(ji, jj) = hst(ji,jj) - e3t_n(ji,jj,jk) * zhd * & + & tmask(ji,jj,jk) + END DO + END DO + END DO + ENDIF + + ! bottom pressure is integral+ssh + hbp(:,:) = sshb(:,:) - hst(:,:) + + CALL iom_put( 'hst', hst ) + CALL iom_put( 'hbp', hbp ) + + IF (( kt == 1 ) .OR. ( kt == nit000 ) ) THEN + IF ( kt == 1 ) THEN + hst00 = glob_sum( 'sbchbp', e1e2t(:,:) * hst(:,:) ) + hbp00 = glob_sum( 'sbchbp', e1e2t(:,:) * hbp(:,:) ) + zarea = glob_sum( 'sbchbp', e1e2t(:,:) ) + hst00 = hst00 / zarea + hbp00 = hbp00 / zarea + ssh00 = hbp00 + hst00 + ENDIF + IF (lwp) WRITE(numout,*)' initial offset hst00 hbp00 ssh00 ' , hst00, hbp00, ssh00 + ENDIF + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_hbp') + ! + END SUBROUTINE sbc_hbp + + !!====================================================================== +END MODULE sbchbp diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcice_cice.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcice_cice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..997b89f3c5fad3d21c525f2896b749ebb34dd5b6 --- /dev/null +++ b/V4.0/nemo_sources/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: sbcice_cice.F90 14590 2021-03-05 13:21:05Z clem $ + !! 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( kt, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcice_if.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcice_if.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e4d68a50b22cd5f492d20230632a1857042284c2 --- /dev/null +++ b/V4.0/nemo_sources/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: sbcice_if.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcisf.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcisf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3503033860ce3b482ad168a93db9019a82081796 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcisf.F90 @@ -0,0 +1,920 @@ +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 + USE timing ! Timing + + 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(dp), 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: sbcisf.F90 12294 2019-12-30 18:46:59Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +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(CASTSP(tsn(:,:,:,jp_tem)),ttbl(:,:),'T') + CALL sbc_isf_tbl(CASTSP(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( CASTSP(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.0_wp, risf_tsc(:,:,jp_sal), 'T', 1.0_wp, fwfisf,'T', 1.0_wp, qisf, 'T', 1.0_wp) + ! 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(CASTSP(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( CASTSP(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.0_wp, pgs, 'T', 1.0_wp) + 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(dp), 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.0_wp) + + 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.0_wp) + + 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( ktid, kj1, kj2, 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 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! openmp variables + REAL(dp), DIMENSION(:,:,:), INTENT( inout ) :: phdivn ! horizontal divergence + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikt, ikb + REAL(wp) :: zhk + REAL(wp) :: zfact ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('sbc_isf_div') + ! + zfact = 0.5_wp + ! + IF(.NOT.ln_linssh ) THEN ! need to re compute level distribution of isf fresh water + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('sbc_isf_div') + ! + END SUBROUTINE sbc_isf_div + + !!====================================================================== +END MODULE sbcisf \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcmod.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcmod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..82f7f12ab00efaccceb55b3789bdfddbe4f331e3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcmod.F90 @@ -0,0 +1,665 @@ +MODULE sbcmod + !!====================================================================== + !! *** MODULE sbcmod *** + !! Surface module : provide to the ocean its surface boundary condition + !!====================================================================== + !! History : 3.0 ! 2006-07 (G. Madec) Original code + !! 3.1 ! 2008-08 (S. Masson, A. Caubel, E. Maisonnave, G. Madec) coupled interface + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions (BDY) + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! - ! 2010-10 (J. Chanut, C. Bricaud, G. Madec) add the surface pressure forcing + !! 3.4 ! 2011-11 (C. Harris) CICE added as an option + !! 3.5 ! 2012-11 (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes + !! 3.6 ! 2014-11 (P. Mathiot, C. Harris) add ice shelves melting + !! 4.0 ! 2016-06 (L. Brodeau) new general bulk formulation + !! 4.0 ! 2022-10 (H. Zuo) add surface forcing perturbations + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 sbcsglcpl ! Single executable coupling + 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 sbcprt ! pertubations to surface fields + USE sbchbp ! steric height and bottom pressure + USE icbstp ! Icebergs + USE icb_oce , ONLY : ln_passive_mode ! iceberg interaction mode + USE traqsr ! active tracers: light penetration + USE sbcwave ! Wave module + USE zdftke, ONLY : ln_wavetke, ln_namzdf_tke + 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 + USE fldread, ONLY : lfldread_sgl + + 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: sbcmod.F90 13481 2020-09-16 17:14:51Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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 + LOGICAL :: ln_sglread_sbc ! local logical + !! + NAMELIST/namsbc/ nn_fsbc , & + & ln_usr , ln_flx , ln_blk , ln_pert , & + & 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, nn_hbp, nn_hst, & + & ln_wspd , ln_rhoaw, & + & nn_sdtrans, ln_wvinice, ln_charnock, ln_sglread_sbc, & + & ln_limcplcld, ln_limcpllcc, ln_icecplcat + !!---------------------------------------------------------------------- + ! + ln_sglread_sbc = ln_sglread + 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,*) ' coupled formulation (single exe) ln_sglexe = ', ln_sglexe + WRITE(numout,*) ' coupled formulation (sgl exe wam only) ln_sglwam = ', ln_sglwam + 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,*) ' Steric Height and Bottom pressure = ', nn_hbp + WRITE(numout,*) ' Steric Height Calculation method = ', nn_hst + WRITE(numout,*) ' Surface Waves: ln_wave = ', ln_wave + WRITE(numout,*) ' Charnock coefficient ln_charnock = ', ln_charnock + WRITE(numout,*) ' neutral drag coefficient ln_cdgw = ', ln_cdgw + WRITE(numout,*) ' wave modified ocean stress ln_tauwoc = ', ln_tauwoc + WRITE(numout,*) ' wave modified ocean stress component ln_tauw = ', ln_tauw + WRITE(numout,*) ' Stokes drift divergence and tracer adv ln_sdw = ', ln_sdw + WRITE(numout,*) ' Stokes Coriolis term ln_stcor = ', ln_stcor + WRITE(numout,*) ' vertical parametrization nn_sdrift = ', nn_sdrift + WRITE(numout,*) ' Stokes transport calculation nn_sdtrans = ', nn_sdtrans + WRITE(numout,*) ' mask waves if sea ice was present ln_wvinice = ', ln_wvinice + WRITE(numout,*) ' neutral 10m winds speed ln_wspd = ', ln_wspd + WRITE(numout,*) ' surface air density ln_rhoaw = ', ln_rhoaw + WRITE(numout,*) ' wave modified TKE (from zdftke module) ln_wavetke = ', ln_wavetke + WRITE(numout,*) ' Read forcing fields on master processr ln_sglread_sbc= ', ln_sglread_sbc + WRITE(numout,*) ' Couple cloud cover from atmos in sbcsglcpl ln_limcplcld = ', ln_limcplcld + WRITE(numout,*) ' Use low cloud cover(ln_limcplcld must be T)ln_limcpllcc = ', ln_limcpllcc + WRITE(numout,*) ' Use ice category coupling (not supported!) ln_icecplcat = ', ln_icecplcat + WRITE(numout,*) ' Read Surface forcing perturbations ln_pert = ', ln_pert + ENDIF + ! + ! Sgl read option for fldread + lfldread_sgl = ln_sglread_sbc + ! + IF( ln_wave .AND. .NOT. ln_namzdf_tke ) THEN + CALL ctl_stop( 'Wave effects requested but namzdf_tke was not read to determine ln_wavetke' ) + ENDIF + IF( .NOT.ln_wave ) THEN + ln_sdw = .false. ; ln_cdgw = .false. ; ln_tauwoc = .false. ; ln_tauw = .false. ; ln_stcor = .false. ; ln_wavetke = .false. + ln_wspd = .false. ; ln_rhoaw = .false. + ln_wvinice = .false. ; ln_charnock = .false. + ENDIF + + ! ln_wavetke implies the reading of wave phioc + ln_wavephioc=ln_wavetke + + 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' ) + IF( .NOT.(nn_sdtrans==-1 .OR. nn_sdtrans==1 ) ) & + CALL ctl_stop( 'The chosen nn_sdtrans for Stokes drift transport must be -1 or 1' ) + 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 + ! For ln_cpl to true for single executable coupling. + IF (ln_sglexe) THEN + ln_cpl = .TRUE. + 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 .AND. .NOT.ln_sglexe + 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( ln_sglexe ) THEN ; nsbc = jp_sglexe ; icpt = icpt + 1 ; ENDIF ! Sglexe Coupled formulation + ! + 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' + case( jp_sglexe ) ; WRITE(numout,*) ' ==>>> sglexe 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_sglexe) THEN + IF ( nn_ice == 2 ) CALL sbc_sglcpl_ice_init + ENDIF + ! + 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 ) THEN + IF ( nsbc == jp_sglexe .OR. ln_sglwam ) THEN + CALL sbc_wave_sglexe( kt ) ! surface waves (sglexe version) + ELSE + CALL sbc_wave( kt ) ! surface waves + ENDIF + ENDIF + ! + ! !== 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_sglexe ) ; CALL sbc_sglcpl_rcv( kt, nn_fsbc, nn_ice ) ! single exe 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( ) ! ocean momentum flux modified by waves + ! + + ! !== Misc. Options ==! + IF( ln_pert ) CALL sbc_prt( kt ) ! add forcing perturbations + + ! !== 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.0_wp ) ! 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 + + CALL sbc_hbp( kt ) + + 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.0_wp ) + IF ( ll_wd ) THEN ! If near WAD point limit the flux for now + zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 + zwdht(:,:) = 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=CASTSP((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=CASTDP(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/V4.0/nemo_sources/src/OCE/SBC/sbcprt.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcprt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ca741f023f3094a2575fa6e5cde4084d9dca9d37 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcprt.F90 @@ -0,0 +1,213 @@ +MODULE sbcprt + !!====================================================================== + !! *** MODULE sbcprt *** + !! Forcing Perturbations: momentum, heat, solar, freshwater fluxes and sst + !! and seaice + !!===================================================================== + !! History : 1.0 ! 2014-08 (M. A. Balmaseda) + !! ! 2022-10 (Hao Zuo) port to NEMOv4.0 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! namsbc_prt : which perturbations to read + !! nn_pXXXX : Option to determine what to do with perturbation XXXX + !! nothing/read & add prt/read & replace field (0,1,2). + !! currently only options 0/1 are coded + !!---------------------------------------------------------------------- + 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_prt ! routine called by sbcmod.F90 + INTEGER, PARAMETER :: jpfldp_max=5 + INTEGER :: jpfldp ! maximum number of files to read + INTEGER :: jp_putau ! index of wind stress (i-component) file + INTEGER :: jp_pvtau ! index of wind stress (j-component) file + INTEGER :: jp_pqns ! index of total (non solar+solar) heat file + INTEGER :: jp_pqsr ! index of solar heat file + INTEGER :: jp_pemp ! index of evaporation-precipation file + INTEGER :: nn_putau, nn_pvtau, nn_pqsr, nn_pqns, nn_pemp ! 1 to read/add pert. 0 does nothing + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sfp ! structure of input fields (file informations, fields read) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.3 , NEMO-consortium (2010) + !! $Id: sbcprt.F90 + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_prt( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_prt *** + !! + !! ** Purpose : Read pre-interpolated forcing perturbation patterns + !! (momentum, heat, solar heat, emp) + !! add them to forcing fluxes computed after sbcflx and wave stress + !! !! + !! ** Method : - READ perturbation of fluxes in NetCDF files: + !! i-component of the stress utau (N/m2) + !! j-component of the stress vtau (N/m2) + !! net total surface flux qtot (N/m2) + !! net downward radiative flux qsr (watt/m2) + !! net upward freshwater (evapo - precip) emp (kg/m2/s) + !! + !! ** Action : update and add at each time-step (fsbc) the forcing pertur. + !! and add + !! - utau, vtau i- and j-component of the wind stress + !! - taum wind stress module at T-point. Derived + !! - wndm 10m wind module at T-point. Derived + !! - qns, qsr non-slor and solar heat flux + !! - emp, emps evaporation minus precipitation + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !! + INTEGER :: ji, jj, jf ! dummy indices + INTEGER :: ierror ! return error code + 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 + INTEGER :: ios + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files + TYPE(FLD_N) :: slf_i (jpfldp_max) ! array of namelist information structures + TYPE(FLD_N) :: sn_putau, sn_pvtau, sn_pqns, sn_pqsr, sn_pemp ! information about the fields to be read + NAMELIST/namsbc_prt/ cn_dir, sn_putau, sn_pvtau, sn_pqns, sn_pqsr, sn_pemp, & + & nn_putau, nn_pvtau, nn_pqns, nn_pqsr, nn_pemp + + + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! First call kt=nit000 + ! set file information + cn_dir = './' ! directory in which the model is executed + + !! ... default values from ref namelist + REWIND ( numnam_ref ) ! read in namlist namflx + READ ( numnam_ref, namsbc_prt, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_prt in reference namelist' ) + + REWIND ( numnam_cfg ) ! read in namlist namflx + READ ( numnam_cfg, namsbc_prt, IOSTAT = ios, ERR = 902) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_prt in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_prt ) + ! + ! ! store namelist information in an array + IF (lwp) THEN + WRITE ( numout,*)' sbc_prt : setting pert parameters ' + WRITE ( numout,*)' ~~~~~~~~' + ENDIF + + jpfldp = 0 + IF(lwp) WRITE ( numout,*)' nn_putau = ',nn_putau + IF ( nn_putau > 0 ) THEN + jpfldp=jpfldp+1 + jp_putau=jpfldp + slf_i(jp_putau) = sn_putau + IF(lwp) WRITE ( numout,*)' -------jpfldp = ',jpfldp + IF(lwp) WRITE ( numout,*)' -------jp_putau = ',jp_putau + ENDIF + IF(lwp) WRITE ( numout,*)' nn_pvtau = ',nn_pvtau + IF ( nn_pvtau > 0 ) THEN + jpfldp=jpfldp+1 + jp_pvtau=jpfldp + slf_i(jp_pvtau) = sn_pvtau + IF(lwp) WRITE ( numout,*)' -------jpfldp = ',jpfldp + IF(lwp) WRITE ( numout,*)' -------jp_pvtau = ',jp_pvtau + ENDIF + IF(lwp) WRITE ( numout,*)' nn_pqns = ',nn_pqns + IF ( nn_pqns > 0 ) THEN + jpfldp=jpfldp+1 + jp_pqns=jpfldp + slf_i(jp_pqns) = sn_pqns + IF(lwp) WRITE ( numout,*)' -------jpfldp = ',jpfldp + IF(lwp) WRITE ( numout,*)' -------jp_pqns = ',jp_pqns + ENDIF + IF(lwp) WRITE ( numout,*)' nn_pqsr = ',nn_pqsr + IF ( nn_pqsr > 0 ) THEN + jpfldp=jpfldp+1 + jp_pqsr=jpfldp + slf_i(jp_pqsr) = sn_pqsr + IF(lwp) WRITE ( numout,*)' -------jpfldp = ',jpfldp + IF(lwp) WRITE ( numout,*)' -------jp_pqns = ',jp_pqsr + ENDIF + IF(lwp) WRITE ( numout,*)' nn_pemp = ',nn_pemp + IF ( nn_pemp > 0 ) THEN + jpfldp=jpfldp+1 + jp_pemp=jpfldp + slf_i(jp_pemp) = sn_pemp + IF(lwp) WRITE ( numout,*)' -------jpfldp = ',jpfldp + IF(lwp) WRITE ( numout,*)' -------jp_pqns = ',jp_pemp + ENDIF + ! + ALLOCATE( sfp(jpfldp), STAT=ierror ) ! set sf structure + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_prt: unable to allocate sfp structure' ) ; RETURN + ENDIF + DO ji= 1, jpfldp + ALLOCATE( sfp(ji)%fnow(jpi,jpj,1) ) + IF( slf_i(ji)%ln_tint ) ALLOCATE( sfp(ji)%fdta(jpi,jpj,1,2) ) + END DO + ! ! fill sf with slf_i and control print + CALL fld_fill( sfp, slf_i, cn_dir, 'sbc_prt', 'flux perturbations for ocean surface boundary condition', 'namsbc_prt' ) + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sfp ) ! input fields provided at the current time-step + + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! add flux pert at each SBC frequency + IF (lwp) WRITE(numout,*)'Applying perturbations kt ',kt + IF( nn_putau > 0 ) utau(:,:) = utau(:,:) + sfp(jp_putau)%fnow(:,:,1) + IF( nn_pvtau > 0 ) vtau(:,:) = vtau(:,:) + sfp(jp_pvtau)%fnow(:,:,1) + IF( nn_pqns > 0 ) qns (:,:) = qns (:,:) + sfp(jp_pqns )%fnow(:,:,1) + IF( nn_pqsr > 0 ) qsr (:,:) = qsr (:,:) + sfp(jp_pqsr )%fnow(:,:,1) + IF( nn_pemp > 0 ) emp (:,:) = emp (:,:) + sfp(jp_pemp )%fnow(:,:,1) + ! module of wind stress and wind speed at T-point + zcoef = 1. / ( zrhoa * zcdrag ) +!CDIR NOVERRCHK + DO jj = 2, jpjm1 +!CDIR NOVERRCHK + DO ji = fs_2, fs_jpim1 ! vect. opt. + ztx = utau(ji-1,jj ) + utau(ji,jj) + zty = vtau(ji ,jj-1) + vtau(ji,jj) + zmod = 0.5 * SQRT( ztx * ztx + zty * zty ) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) + END DO + END DO + + CALL lbc_lnk( 'sbcprt', taum(:,:), 'T', 1.0_wp ) + CALL lbc_lnk( 'sbcprt', wndm(:,:), 'T', 1.0_wp ) + + + !following may not needed anymore + 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 perturbations OK' + DO jf = 1, jpfldp + IF( jf == jp_putau .OR. jf == jp_pvtau ) zfact = 1. + IF( jf == jp_pqns .OR. jf == jp_pqsr ) zfact = 0.1 + IF( jf == jp_pemp ) zfact = 86400. + WRITE(numout,*) + WRITE(numout,*) ' day: ', ndastp , TRIM(sfp(jf)%clvar), ' * ', zfact + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE sbc_prt + + !!====================================================================== +END MODULE sbcprt \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcrnf.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcrnf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4053ca47bb06bc8c2fab548b22bb4a6b0e28544d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcrnf.F90 @@ -0,0 +1,585 @@ +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 + USE sbcisf ! For rLfusisf + USE timing ! Timing + + 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 , PUBLIC :: ln_rnf_tem !: temperature river runoffs attribute specified in a file + LOGICAL :: ln_rnf_tem_mask !: temperature river runoffs file is a mask + 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(:,:) :: icbmsk !: iceberg 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) + +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 13255 2020-07-06 15:41:29Z acc $ + !! 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) , & + & icbmsk(jpi,jpj) , & + & 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 + ! + ! + IF( ln_timing_detail ) CALL timing_start('sbc_rnf') + ! + ! !-------------------! + ! ! 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' , CASTDP(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(:,:) ) + DO jj=1,jpj + DO ji=1,jpi + IF ( sf_t_rnf(1)%fnow(ji,jj,1) == -999._wp ) THEN + rnf_tsc(ji,jj,jp_tem) = MAX( sst_m(ji,jj), 0.0_wp ) * rnf(ji,jj) * r1_rau0 + ELSEIF( sf_t_rnf(1)%fnow(ji,jj,1) == -222._wp ) THEN + rnf_tsc(ji,jj,jp_tem) = ztfrz(ji,jj) * rnf(ji,jj) * r1_rau0 - rnf(ji,jj) * rLfusisf * r1_rau0_rcp + icbmsk(ji,jj)=1._wp + ELSEIF (ln_rnf_tem_mask) THEN + WRITE(0,*)'rnf_tsc mask issue',kt,sf_t_rnf(1)%fnow(ji,jj,1),sst_m(ji,jj),ztfrz(ji,jj),rnf_tsc(ji,jj,jp_tem) + CALL ctl_stop( 'STOP', 'sbc_rnf : rnf_tsc mask issue' ) + ENDIF + ENDDO + ENDDO + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_rnf') + ! + END SUBROUTINE sbc_rnf + + + SUBROUTINE sbc_rnf_div( ktid, kj1, kj2, 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 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! openmp variables + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zfact ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('sbc_rnf_div') + ! + 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 = MAX(1,kj1),MIN(kj2,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 = MAX(1,kj1),MIN(kj2,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 ==! + DO jj = MAX(1,kj1),MIN(kj2,jpj) + DO ji = 1, jpi + h_rnf (ji,jj) = e3t_n (ji,jj,1) ! update h_rnf to be depth of top box + phdivn(ji,jj,1) = phdivn(ji,jj,1) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / e3t_n(ji,jj,1) + END DO + END DO + ENDIF + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('sbc_rnf_div') + ! + 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, & + & ln_rnf_tem_mask + !!---------------------------------------------------------------------- + ! + ! !== 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 + icbmsk (:,:) = 0.0_wp + ! + ! ! ============ + ! ! 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' + IF(lwp) WRITE(numout,*) ' ==>>> runoffs temperatures file is a mask ',ln_rnf_tem_mask + 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/V4.0/nemo_sources/src/OCE/SBC/sbcsglcpl.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcsglcpl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4d620f71ed2de45b5b525c81538f3a5a626b95a4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcsglcpl.F90 @@ -0,0 +1,737 @@ +MODULE sbcsglcpl + !!====================================================================== + !! *** MODULE sbcsglcpl *** + !! Surface Boundary Condition : momentum, heat and freshwater fluxes in single executable coupled mode + !!====================================================================== + !! History : 1.0 ! 2011-11 (K. Mogensen, S. Keeley) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! For lwp and numout + USE lib_mpp ! For ctl_stop + USE sbcdcy ! Diurnal cycle + USE sbc_oce ! For ln_dm2dc + USE lbclnk ! Lateral boundary conditions + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer +#if defined key_si3 + USE sbc_ice ! ICE variables + USE ice ! ICE variables + USE icevar ! for CALL ice_var_snwblow +#endif + USE iom ! For iom_put + USE timing +#if defined key_si3 + USE icealb + USE ocealb +#endif + USE phycst ! Physical constants +#if defined key_dr_hook + USE yomhook, ONLY : lhook, dr_hook, jphook ! IFS Dr_Hook +#else + USE modhookdummy, ONLY : lhook, dr_hook, jphook ! Dummy Dr_Hook +#endif + + IMPLICIT NONE + + PUBLIC sbc_sglcpl_ice_flx ! routine called by sbc_ice_ice(_2).F90 + PUBLIC sbc_sglcpl_ice_tau ! routine called by sbc_ice_ice(_2).F90 + PUBLIC sbc_sglcpl_rcv ! routine called by sbcmod.F90 + PUBLIC sbc_sglcpl_ice_init ! routine called by sbcmod.F90 + PUBLIC sbc_sglcpl_ice_cldcov ! routine called by sbcmod.F90 + PUBLIC sbc_sglcpl_get_wam ! routine called by sbcmod.F90 + + PRIVATE + + LOGICAL, PUBLIC :: lallociceflx = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqns_tot + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqns_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqsr_tot + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqsr_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsemp_tot + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsemp_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsdqdns_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zssprecip + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zstprecip + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsevap_tot + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsevap_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zstcc + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zslcc + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsatmist + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqns_ice_add + LOGICAL, PUBLIC :: lallocstress = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsutau + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsvtau + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsutau_ice + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsvtau_ice + LOGICAL, PUBLIC :: lallocflx = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqns + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsqsr + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsemp + LOGICAL, PUBLIC :: lallocwam = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsswh + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsmwp + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsphioc + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zstauoc + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsustokes + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsvstokes + LOGICAL, PUBLIC :: lallocstresswam = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsutauwam + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsvtauwam + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zswndmwam + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsphifwam + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsstrn + LOGICAL, PUBLIC :: lallocatm = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsatmsst + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zsatmtsk + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: zscplsst + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: albedo_oce_mix + LOGICAL, PUBLIC :: lfluxupdated = .FALSE. + +CONTAINS + + SUBROUTINE sbc_sglcpl_ice_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_sglcpl_ice_init *** + !! + !! ** Purpose : Initialisation of ICE variables + !! + !! ** Method : + !!---------------------------------------------------------------------- + !!--------------------------------------------------------------------- + ! + REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_init',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_ice_init') + ! ! ------------------------- ! + ! ! Ice Qsr penetration ! + ! ! ------------------------- ! + ! fraction of net shortwave radiation which is not absorbed in the thin surface layer + ! and penetrates inside the ice cover ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 ) + ! Coupled case: since cloud cover is not received from atmosphere + ! ===> defined as constant value -> definition done in sbc_cpl_init +#if defined key_si3 +! fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) +! fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) +#endif +#if defined key_si3 + IF (ln_limcplcld) THEN + cloud_fra(:,:) = 999 + ELSE + cloud_fra(:,:) = pp_cldf + ENDIF + ALLOCATE( albedo_oce_mix(jpi,jpj) ) + CALL oce_alb( zaos, zacs ) + ! Due to lack of information on nebulosity : mean clear/overcast sky + albedo_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5 +#endif + ! + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_ice_init') + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_init',1,zhook_handle) + ! + END SUBROUTINE sbc_sglcpl_ice_init + + SUBROUTINE sbc_sglcpl_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) + !!---------------------------------------------------------------------- + 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) + !! + 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 + INTEGER :: ji,jj + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('sbc_sglcpl_rcv',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_rcv') + + IF(lwp) WRITE(numout,*)'Retrieving data in sbc_sglcpl_rcv' + + IF ( k_ice <= 1 ) THEN + + ! Update NEMO fluxes (non ice model case). + + IF (.NOT.lallocflx) THEN + CALL ctl_stop('sbc_sglcpl_flx_get called before sbc_sglcpl_flx_put') + ENDIF + qns(:,:) = zsqns(:,:) + qsr(:,:) = zsqsr(:,:) + emp(:,:) = zsemp(:,:) + + ! Modify qsr to include the diurnal cycle + + IF( ln_dm2dc ) qsr(:,:) = sbc_dcy( qsr ) + + ENDIF + + IF (.NOT.lallocstress) THEN + CALL ctl_stop('sbc_sglcpl_recv called before sbc_sglcpl_stress_put') + ENDIF + + utau(:,:) = zsutau(:,:) + vtau(:,:) = zsvtau(:,:) + + ! Compute taum and wndm as in NEMO + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zzx = zsutau(ji-1,jj ) + zsutau(ji,jj) + zzy = zsvtau(ji ,jj-1) + zsvtau(ji,jj) + taum(ji,jj) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + END DO + END DO + CALL lbc_lnk( 'sbc_sglcpl_rcv', taum, 'T', 1.0_wp ) + + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = 1, jpj + DO ji = 1, jpi + wndm(ji,jj) = SQRT( taum(ji,jj) * zcoef ) + END DO + END DO + + CALL iom_put( "taum_oce", taum ) ! output wind stress module + + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_rcv') + IF(lhook) CALL dr_hook('sbc_sglcpl_rcv',1,zhook_handle) + + END SUBROUTINE sbc_sglcpl_rcv + + SUBROUTINE sbc_sglcpl_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 + !! runoffs and calving directly enter the ocean. + !! * solid precipitation (sprecip), used to add to qns_tot + !! the heat lost associated to melting solid precipitation + !! over the ocean fraction. + !! * total precipitation (tprecip), + !! ===>> CAUTION here this changes the net heat flux received from + !! the atmosphere + !! + !! - 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. + !! + !! ** 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) (-runoff)(-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 grid box) + !! tprecip total precipitation over the ocean + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ), DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] + ! optional arguments, used only in 'mixed oce-ice' case + REAL(dp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo + REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] + REAL(dp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] + REAL(dp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] + REAL(dp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] + INTEGER :: ji, jj, jl + REAL(jphook) :: zhook_handle ! Dr Hook handle + REAL(wp), DIMENSION(jpi,jpj ) :: zcptn,zcptrain, zcptsnw, ziceld, zmsk, zsnw, ztmp + 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 +#if defined key_si3 + 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 +#endif + REAL(wp), DIMENSION(jpi,jpj ) :: zevap, ztri ! for SI3 + + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_flx',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_ice_flx') + +#if defined key_si3 + + IF(lwp) WRITE(numout,*)'Retrieving data in sbc_sglcpl_ice_flx ',lfluxupdated + + IF (lfluxupdated) THEN + + IF (.NOT.lallociceflx) THEN + call ctl_stop('sbc_sglcpl_ice_flx_get called before sbc_sglcpl_ice_flx_put') + ENDIF + + +! compute ice lead (open water) fraction + ziceld(:,:) = 1.0_wp - picefr(:,:) +!compute CpT + zcptn(:,:) = rcp * sst_m(:,:) + + ! check routine nemogcmcoup_lim2_update for what we do before fluxes get here + + ! + ! ! ========================= ! + ! ! freshwater budget ! (emp_tot) + ! ! ========================= ! + ! + ! ! solid Precipitation (sprecip) + ! ! liquid + solid Precipitation (tprecip) + ! ! total Evaporation - total Precipitation (emp_tot) + ! ! sublimation - solid Precipitation (emp_ice) + ! + + ! --- precip --- ! + zsprecip(:,:) = zssprecip(:,:) ! May need to ensure positive here - solid precip over ocean - this is defined in nemogcmcoup_lim2_update + ztprecip(:,:) = zstprecip(:,:) ! May need to ensure positive here + + ! --- evaporation over ice (kg/m2/s) --- ! + !copy the same number into all categories for the time being + zevap_ice(:,:,1) = zsevap_ice(:,:) + zevap_ice_total(:,:) = zevap_ice(:,:,1) + DO jl=2, jpl + zevap_ice(:,:,jl) = zevap_ice(:,:,1) + ENDDO + + ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) + zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) ! snow distribution over ice after wind blowing + + ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! + zemp_tot(:,:) = zsemp_tot(:,:) !Sarah - in routine sglcpl this assumed to be total evap- total precip (we also subtract runoff before fields are coupled) + zemp_ice(:,:) = zsevap_ice(:,:) * picefr(:,:) - zsprecip(:,:) * zsnw(:,:) ! emp_ice to correct for snow blown into ocean + zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce & emp_ice are grid box fraction weighted + + ! --- evaporation over ocean (used later for qemp) --- ! + zevap_oce(:,:) = (zsevap_tot(:,:) - zevap_ice_total(:,:) * picefr(:,:)) / ziceld(:,:) + ! gives weighting of leadfrac to evap_oce if not divided by ziceld + + + ! 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 + !SARAH - to do - check if this is true in IFS + + ! --- Continental fluxes --- ! + !Sarah ignore icebergs, runoff, calving and iceshelfs here runoffs (currently 0) already subtracted in iceupdate + + emp_tot (:,:) = zemp_tot (:,:) + emp_ice (:,:) = zemp_ice (:,:) !weighted by ice fra + emp_oce (:,:) = zemp_oce (:,:) !weighted by lead fra + sprecip (:,:) = zsprecip (:,:) !over whole box + tprecip (:,:) = ztprecip (:,:) !over whole box + evap_ice(:,:,:) = zevap_ice(:,:,:) !just over ice bit + DO jl = 1, jpl + devap_ice(:,:,jl) = zdevap_ice(:,:) + END DO + ! ! ================================= ! + ! ! ice topmelt and conductive flux ! + ! ! ================================= ! + ! do nothing we don't have conductivity coupling + ! set the following to zero as not using UKMO style coupling + qml_ice(:,:,:) = 0.0_wp + qcn_ice(:,:,:) = 0.0_wp + ! ! ========================= ! + ! ! non solar heat fluxes ! (qns) ! + ! ! ========================= ! + zqns_tot(:,:) = zsqns_tot(:,:) + IF (.NOT.ln_icecplcat) THEN ! Set all category values equal for the moment + DO jl = 1, jpl + zqns_ice(:,:,jl) = zsqns_ice(:,:) + END DO + ELSE + CALL ctl_stop('STOP', 'sbcsglcpl/sbc_cpl_ice_flx: Not coded single exec si3 coupling for ice cats') + !zdqns_ice(:,:,:)=zsdqns_ice(:,:.:) + ENDIF + ! + ! --- 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 + + ! --- 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) ! Sarah -change to epsi value? + 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(:,:) * ziceld(:,:) * 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. doesnt take it into account) + + ! --- total non solar flux x (including evap/precip) --- ! + zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) + + qns_tot(:,:) = zqns_tot(:,:) + qns_oce(:,:) = zqns_oce(:,:) ! just over ocean bit + qns_ice(:,:,:) = zqns_ice(:,:,:) !just over ice bit + qevap_ice(:,:,:) = zqevap_ice(:,:,:) ! = 0 + qprec_ice(:,:) = zqprec_ice(:,:) + qemp_oce (:,:) = zqemp_oce (:,:) !weighted by lead fra + qemp_ice (:,: ) = zqemp_ice (:,: )!weighted by ice fra + + ! 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 + CALL iom_put( 'precip' , tprecip ) ! Total precip + CALL iom_put( 'snowpre' , sprecip ) ! Snow + 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(:,:) * ziceld(:,:) ) ! Snow over ice-free ocean (cell average) + IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * 1.- ziceld(:,:) ) ! 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' , zevap_ice_total(:,:) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) + IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , (zsevap_tot(:,:) & + & - zevap_ice_total(:,:) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + IF (iom_use('hflx_rain_cea') ) & ! heat flux from rain (cell average) + & CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF (iom_use('hflx_evap_cea') ) & ! heat flux from evap (cell average) + & CALL iom_put('hflx_evap_cea' , (zsevap_tot(:,:) - zevap_ice_total(:,:) * picefr(:,:) ) & + & * zcptn(:,:) * tmask(:,:,1) ) + IF (iom_use('hflx_prec_cea') ) & ! heat flux from all precip (cell avg) + & CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF (iom_use('hflx_snow_cea') ) & ! heat flux from snow (cell average) + & CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) + IF (iom_use('hflx_snow_ao_cea') ) & ! heat flux from snow (over ocean) + & CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) + IF (iom_use('hflx_snow_ai_cea') ) & ! heat flux from snow (over ice) + & CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) + + ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. + ! + ! ! ========================= ! + ! ! d(qns)/dt ! + ! ! ========================= ! + + IF (.NOT.ln_icecplcat) THEN ! Set all category values equal for the moment + DO jl=1,jpl + zdqns_ice(:,:,jl) = zsdqdns_ice(:,: )! check correct no of dimensions + END DO + ELSE + CALL ctl_stop('STOP', 'sbcsglcpl/sbc_cpl_ice_flx: Not coded single exec si3 coupling for ice cats') + !zdqns_ice(:,:,:)=zsdqns_ice(:,:.:) + ENDIF + + dqns_ice(:,:,:) = zdqns_ice(:,:,:) + + ! ! ========================= ! + ! ! solar heat fluxes (qsr) ! + ! ! ========================= ! + zqsr_tot(:,:) = zsqsr_tot(:,:) + IF (.NOT.ln_icecplcat) THEN ! Set all category values equal for the moment + DO jl=1,jpl + zqsr_ice(:,:,jl) = zsqsr_ice(:,:) + END DO + ELSE + CALL ctl_stop('STOP', 'sbcsglcpl/sbc_cpl_ice_flx: Not coded single exec si3 coupling for ice cats') + !zdqns_ice(:,:,:)=zsdqns_ice(:,:.:) + ENDIF + ! ==================================================================== ! + ! Determine cloudiness from coupled system or set to constant value ! + ! ==================================================================== ! + ! Sarah+Kristian: The following needs to be sorted out since cloud_fra + ! should be received from the IFS. It is needed for coupling albedo + ! back to the IFS but if not doesn't change the results + + IF (ln_limcplcld) THEN + IF (ln_limcpllcc) THEN + cloud_fra(:,:) = zslcc(:,:) + ELSE + cloud_fra(:,:) = zstcc(:,:) + ENDIF + ELSE + cloud_fra(:,:) = pp_cldf !not equivalent to lim2 settingas cloud fra is then =0 as ztri=0.18 + ENDIF + ! ! ========================= ! + ! ! Transmitted Qsr ! [W/m2] + ! ! ========================= ! + + !== No conduction flux as surface forcing ==! IF( .NOT.ln_cndflx ) THEN ... as not coded for cndflx yet + IF (.NOT.ln_icecplcat) THEN + DO jl = 1, jpl + zqsr_ice(:,:,jl)=zsqsr_ice(:,:) + END DO + ELSE + CALL ctl_stop('STOP', 'sbcsglcpl/sbc_cpl_ice_flx: Not coded single exec si3 coupling for ice cats') + !zqsr_ice(:,:,:)=zqsr_ice(:,:.:) + ENDIF + + 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 + END DO + 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 + + ! use flag ln_dm2dc in nemogcmcoup_lim2_update to modify flux if needed for the diurnal cycle + qsr_tot(:,:) = zqsr_tot(:,:) + qsr_ice(:,:,:) = zqsr_ice(:,:,:) + qtr_ice_top(:,:,:) = zqtr_ice_top(:,:,:) + + ! ======================== ! + ! solar flux over ocean ! + ! ======================== ! + ! use flag ln_dm2dc in nemogcmcoup_lim2_update to modify flux if needed + ! 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 + CALL ctl_stop('STOP', 'sbcsglcpl/sbc_cpl_ice_flx: Not coded single exec si3 coupling for ln_mixcpl') + !qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) + ELSE + qsr_oce(:,:) = zqsr_oce(:,:) + ENDIF + + ! ! ================== ! + ! ! ice skin temp. ! Sarah Nothing done as yet. + ! ! ================== ! +#endif + lfluxupdated=.FALSE. + ENDIF + + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_ice_flx') + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_flx',1,zhook_handle) + + END SUBROUTINE sbc_sglcpl_ice_flx + + SUBROUTINE sbc_sglcpl_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 (cp_ice_msh): + !! 'C'-grid : i- (j-) components given at U- (V-) point + !! 'I'-grid : B-grid lower-left corner: both components given at I-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 cp_ice_msh 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. Therefore, only the third + !! transformation is done and only if the ice-grid is a 'I'-grid. + !! + !! ** Action : return ptau_i, ptau_j, the stress over the ice at cp_ice_msh point + !!---------------------------------------------------------------------- + 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) + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_tau',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_ice_tau') + + p_taui(:,:) = zsutau_ice(:,:) + p_tauj(:,:) = zsvtau_ice(:,:) + + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_ice_tau') + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_tau',1,zhook_handle) + + END SUBROUTINE sbc_sglcpl_ice_tau + + SUBROUTINE sbc_sglcpl_ice_cldcov (p_cld_fra, llcc) + + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_sglcpl_ice_cldcov *** + !! + !! ** Purpose : return cloudfra depending on switch + !! lcc or tcc + !! + !! ** Method : + !!---------------------------------------------------------------------- + !!--------------------------------------------------------------------- + ! + + REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_cld_fra ! return cloud fraction depending on switch + LOGICAL, INTENT(in) :: llcc + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_cldcov',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_ice_cldcov') + + IF (.NOT.lallociceflx) THEN + call ctl_stop('sbc_sglcpl_ice_cldcov called before sbc_sglcpl_ice_flx_put') + ENDIF + IF (llcc) THEN + p_cld_fra(:,:) = zslcc(:,:) + ELSE + p_cld_fra(:,:) = zstcc(:,:) + ENDIF + + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_ice_cldcov') + IF(lhook) CALL dr_hook('sbc_sglcpl_ice_cldcov',1,zhook_handle) + + END SUBROUTINE sbc_sglcpl_ice_cldcov + + SUBROUTINE sbc_sglcpl_get_wam( pfrimax, pfri, putau, pvtau, ptaum, pwndm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_sglcpl_stress_get *** + !! + !! ** Purpose : retrieve private data from sbcmod (WAM version) + !! + !! ** Method : memory copy + !! + !! ** Action : update at each coupling time step of. + !! putau, pvtau wind stress at u and v grid + !! ptaum magnitude of stress + !! pwndm wind speed (from stress) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pfrimax ! Maximum fraction of ice to use WAM stresses + REAL(wp), INTENT(in) , DIMENSION(:,:) :: pfri ! Current ice fraction + REAL(wp), INTENT(inout), DIMENSION(:,:) :: putau ! u stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: pvtau ! v stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: ptaum ! stress magnitude [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: pwndm ! wind [m/s] + ! Variables used to compute taum and wndm + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zzx, zzy, zcoef, zfact ! temporary variables + ! Loop variables + INTEGER :: ji, jj + + REAL(jphook) :: zhook_handle ! Dr Hook handle + + IF(lhook) CALL dr_hook('sbc_sglcpl_get_wam',0,zhook_handle) + IF( ln_timing ) CALL timing_start('sbc_sglcpl_get_wam') + + IF(lwp) WRITE(numout,*)'Retrieving data in sbc_sglcpl_get_wam' + + IF (.NOT.lallocstresswam) THEN + call ctl_stop('sbc_sglcpl_get_wam called before data allocated') + ENDIF + + WHERE(pfri(:,:)<pfrimax) + putau(:,:) = zsutauwam(:,:) + pvtau(:,:) = zsvtauwam(:,:) + END WHERE + + ! Compute taum and wndm as in NEMO + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zzx = putau(ji-1,jj ) + putau(ji,jj) + zzy = pvtau(ji ,jj-1) + pvtau(ji,jj) + ptaum(ji,jj) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + END DO + END DO + CALL lbc_lnk( 'sbc_sglcpl_get_wam', ptaum, 'T', 1.0_wp ) + + zcoef = 1. / ( zrhoa * zcdrag ) + WHERE(pfri(:,:)<pfrimax) + pwndm(:,:) = zswndmwam(:,:) + ELSE WHERE + pwndm(:,:) = SQRT( ptaum(:,:) * zcoef ) + END WHERE + + IF( ln_timing ) CALL timing_stop('sbc_sglcpl_get_wam') + IF(lhook) CALL dr_hook('sbc_sglcpl_get_wam',1,zhook_handle) + + END SUBROUTINE sbc_sglcpl_get_wam + + !!====================================================================== +END MODULE sbcsglcpl \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcssm.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcssm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..38bb273ac63b24e388fe84b5a40ee12a89ff1ecf --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcssm.F90 @@ -0,0 +1,277 @@ +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 + USE timing ! Timing + + 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: sbcssm.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), DIMENSION(jpi,jpj,jpts) :: zts + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_ssm') + ! + ! !* 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', sst_m ) + CALL iom_put( 'sss_m', sss_m ) + CALL iom_put( 'ssh_m', ssh_m ) + CALL iom_put( 'e3t_m', e3t_m ) + CALL iom_put( 'frq_m', frq_m ) + ENDIF + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_ssm') + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcssr.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcssr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..caebf1f28da3f93a2412f9cdf88a11becfea96d4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcssr.F90 @@ -0,0 +1,316 @@ +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) + USE zdfmxl ! For mixed layer depth + USE timing ! Timing + + 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 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_2decv_inc !: increment from 2D ECV + + ! !!* 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 + + INTEGER, PUBLIC :: nn_sstr_bnd = 0 ! Method for capping SST restoring heat flux + REAL(wp), PUBLIC :: rn_sstr_bnd = 0.e0 ! Max and/or Min value of the SST damping heat fluxes [W/m2] + LOGICAL, PUBLIC :: ln_sstr_mxl = .true. ! flag for activate mxl depth dependent SST capping + REAL(wp), PUBLIC :: rn_sstr_mxl = 1000.e0 ! SST capping only when local mld (hmlp) > rn_sstr_mxl [m] + LOGICAL, PUBLIC :: l2decv2nemo = .false. ! flag ot apply increment from 2DECV as non solar heat flux + + REAL(wp), PUBLIC :: rn_dqdt_limice = 1.0 ! restoring term factors under ice [ratio] + REAL(wp), PUBLIC :: rn_dqdt_limice_thres = 0.005 ! Minimum for apply rn_dqdt_limice + + 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: sbcssr.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! 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 + REAL(wp) :: zdff ! Difference or target for relaxation + LOGICAL :: ll_sstr_cap ! flag to apply capping SST nudging + 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( ln_timing_detail ) CALL timing_start('sbc_ssr') + ! + IF( nn_sstr + nn_sssr /= 0 ) THEN + ! + IF( nn_sstr >= 1 .and. .not. l2decv2nemo) 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 + + if (l2decv2nemo) then + zdff = -rn_2decv_inc(ji,jj) + else + zdff = sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) + end if + + zqrp = rn_dqdt * zdff * tmask(ji,jj,1) + ! Apply capping for SST nudging heat fluxes (zqrp) + ! zqri and zqrj (under sea-ice) would not be changed + ll_sstr_cap = .true. + IF(( ln_sstr_mxl ) .AND. ( hmlp(ji,jj) < rn_sstr_mxl )) ll_sstr_cap = .false. + IF(( nn_sstr_bnd >= 1 ) .AND. ( ll_sstr_cap )) THEN + IF( nn_sstr_bnd == 1 ) THEN ! capping only maximum value of zqrp + zqrp = MIN( ABS(rn_sstr_bnd), zqrp ) + ELSEIF ( nn_sstr_bnd == 2 ) THEN ! capping only minimum value of zqrp + zqrp = MAX( -1.0_wp * ABS(rn_sstr_bnd), zqrp ) + ELSEIF ( nn_sstr_bnd == 3 ) THEN ! capping both MAX/MIN of zqrp + zqrp = SIGN( 1.0_wp, zqrp ) * MIN( ABS(rn_sstr_bnd), ABS(zqrp) ) + ENDIF + ENDIF + IF( fr_i(ji,jj) >= rn_dqdt_limice_thres ) & + & zqrp = rn_dqdt_limice * zqrp + 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.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) + emp(ji,jj) = emp (ji,jj) + zerp + qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) + erp(ji,jj) = zerp + END DO + END DO + ENDIF + ! + ENDIF + ! + ENDIF + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_ssr') + ! + 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, & + & nn_sstr_bnd, rn_sstr_bnd, ln_sstr_mxl, rn_sstr_mxl, & + & rn_dqdt_limice, rn_dqdt_limice_thres, l2decv2nemo + 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,*) ' method for capping SST heat flux nn_sstr_bnd = ', nn_sstr_bnd + WRITE(numout,*) ' capping value of the SST restoring rn_sstr_bnd = ', rn_sstr_bnd, ' W/m2' + WRITE(numout,*) ' activate mxl dependent SST capping ln_sstr_mxl = ', ln_sstr_mxl + WRITE(numout,*) ' minimum value of mld (0.01 kg/m3) rn_sstr_mxl = ', rn_sstr_mxl, ' m' + WRITE(numout,*) ' restoring term under ice [ratio] rn_dqdt_limice = ',rn_dqdt_limice + WRITE(numout,*) ' ice threshold for rn_dqdt_limice rn_dqdt_limice_thres = ',rn_dqdt_limice_thres + 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 )' + WRITE(numout,*) ' Apply 2DECV increment as nonsolar heat flux l2decv2nemo = ',l2decv2nemo + ENDIF + ! + ! obtain mld (hmlp value) information at beginning + ! hmlp value is updated in step.F90, but after calling of sbc_ssr subroutine + IF( ln_sstr_mxl ) CALL zdf_mxl( nit000, ld_iomput = .FALSE. ) + ! + 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 + + if ( L2DECV2NEMO ) THEN + ALLOCATE( rn_2decv_inc(jpi,jpj), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate rn_2decv_inc array' ) + rn_2decv_inc(:,:) = -999999. + end if + ! + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbctide.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbctide.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4482aff100af93d6c5dbc87fa4d2bac330d0c767 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbctide.F90 @@ -0,0 +1,168 @@ +MODULE sbctide + !!====================================================================== + !! *** MODULE sbctide *** + !! Initialization of tidal forcing + !!====================================================================== + !! History : 9.0 ! 2007 (O. Le Galloudec) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE daymod ! calandar + USE tideini ! + ! + USE in_out_manager ! I/O units + USE iom ! xIOs server + USE ioipsl ! NetCDF IPSL library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PUBLIC + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro ! + + !!---------------------------------------------------------------------- + !! tidal potential + !!---------------------------------------------------------------------- + !! sbc_tide : + !! tide_init_potential : + !!---------------------------------------------------------------------- + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbctide.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_tide( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_tide *** + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step + INTEGER :: jk ! dummy loop index + INTEGER :: nsec_day_orig ! Temporary variable + !!---------------------------------------------------------------------- + + IF( nsec_day == NINT(0.5_wp * rdt) .OR. kt == nit000 ) THEN ! start a new day + ! + 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 + ! + 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 + ! at the start of the current day (only occurs when kt==nit000) + ! Temporarily set nsec_day to beginning of day. + nsec_day_orig = nsec_day + IF ( nsec_day /= NINT(0.5_wp * rdt) ) THEN + kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt + nsec_day = NINT(0.5_wp * rdt) + ELSE + kt_tide = kt + ENDIF + CALL tide_harmo( omega_tide, v0tide, utide, ftide, ntide, nb_harmo ) + ! + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_tide : Update of the components and (re)Init. the potential at kt=', kt + WRITE(numout,*) '~~~~~~~~ ' + DO jk = 1, nb_harmo + WRITE(numout,*) Wave(ntide(jk))%cname_tide, utide(jk), ftide(jk), v0tide(jk), omega_tide(jk) + END DO + ENDIF + ! + IF( ln_tide_pot ) CALL tide_init_potential + ! + ! Reset nsec_day + nsec_day = nsec_day_orig + ENDIF + ! + END SUBROUTINE sbc_tide + + + SUBROUTINE tide_init_potential + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_potential *** + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar + !!---------------------------------------------------------------------- + + DO jk = 1, nb_harmo + zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk) + DO ji = 1, jpi + DO jj = 1, jpj + 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 + ELSE ; zcs = 0._wp + ENDIF + ztmp1 = ztmp1 + zcs * COS( ztmp ) + ztmp2 = ztmp2 - zcs * SIN( ztmp ) + zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 ) + amp_pot(ji,jj,jk) = zamp + phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) , & + & ztmp1 / MAX( 1.e-10_wp, zamp ) ) + END DO + END DO + END DO + ! + END SUBROUTINE tide_init_potential + + SUBROUTINE tide_init_load + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_load *** + !!---------------------------------------------------------------------- + INTEGER :: inum ! Logical unit of input file + INTEGER :: ji, jj, itide ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztr, zti !: workspace to read in tidal harmonics data + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init_load : Initialization of load potential from file' + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL iom_open ( cn_tide_load , inum ) + ! + DO itide = 1, nb_harmo + CALL iom_get ( inum, jpdom_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/sbcwave.F90 b/V4.0/nemo_sources/src/OCE/SBC/sbcwave.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6639d4380889aedfbe1c3f9b719b074a72425e7a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/sbcwave.F90 @@ -0,0 +1,902 @@ +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 + USE sbcsglcpl ! single exectutable coupling + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_stokes ! routine also called in sbccpl + PUBLIC sbc_wstress ! routine called in sbcmod + PUBLIC sbc_wave ! routine called in sbcmod + PUBLIC sbc_wave_sglexe ! 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. + LOGICAL, PUBLIC :: cpl_wspd = .FALSE. + LOGICAL, PUBLIC :: cpl_rhoaw = .FALSE. + LOGICAL, PUBLIC :: cpl_chnk = .FALSE. + LOGICAL, PUBLIC :: cpl_inice = .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, PUBLIC :: jp_hsw ! index of significant wave height (m) at T-point + INTEGER :: jp_wmp ! index of energy mean wave period (s) at T-point + INTEGER :: jp_mp1 ! index of reciprocal of mean wave frequency (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_wspd ! structure of input fields (file informations, fields read) Wind speed associated with sf_cd + 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 + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_phioc ! structure of input fields (file informations, fields read) wave input to TKE + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_hsw ! structure of input fields (file informations, fields read) hsw (if not Stokes Drift) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_inice ! structure of input fields (file informations, fields read) wave in sea ice mask + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rhoa ! structure of input fields (file informations, fields read) Surface air density + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_charnock! structure of input fields (file informations, fields read) Charnock Coefficient + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wspd_wave !: 10m wind speed used by wave model to produce cdn_wave + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: uspd_atm !: u-component of 10m wind speed from the atmospheric model + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: vspd_atm !: v-component of 10m wind speed from the atmospheric model + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: rhoa_wave !: Surface air density + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn_wave !: Charnock coefficient + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw, wnum !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Mean wave period as set by nn_sdtrans + 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(:,:) :: phioc_wave !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wave_inice !: flag whether the wave forcing was over its sea ice:: + !: 0. not in sea ice, > 0. in sea ice + 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: sbcwave.F90 14588 2021-03-05 07:42:07Z clem $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + 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(jpi,jpj) :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zstokes_psi_u_top, zstokes_psi_v_top ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3divh ! 3D workspace + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_stokes') + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2, & + !$omp& ztransp,zfac,zsp0,& + !$omp& zdepth,zsqrt_depth,zexp_depth,z_two_thirds,zsqrtpi, & + !$omp& zbot_u,zbot_v,zkb_u,zkb_v,zke3_u,zke3_v,zda_u,zda_v, & + !$omp& zstokes_psi_u_bot,zstokes_psi_v_bot, & + !$omp& zdep_u, zdep_v,zkh_u,zkh_v ) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! select parameterization for the calculation of vertical Stokes drift + ! representative wave number at t-point + IF( ll_st_bv_li ) THEN ! (Eq. (19) in Breivik et al. (2014) also used by Li et al. 2017) + zfac = 2.0_wp * rpi / 16.0_wp + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + ! Stokes drift transport 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 + ELSE IF( ll_st_peakfr ) THEN ! peak wave number calculated from the peak frequency received by the wave model + DO jj = MAX(1,jj1), MIN(jj2,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 + ENDIF + + !$omp barrier + + ! representative wave number & surface Stokes drift velocity at u- & v-points + DO jj = MAX(1,jj1), MIN(jj2,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 + + ! + ! !== horizontal Stokes Drift 3D velocity ==! + IF( ll_st_bv2014 ) THEN + DO jk = 1, jpkm1 + DO jj = MAX(2,jj1), MIN(jj2,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 + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 + ENDIF + + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) + !$omp end master + !$omp barrier + + ! + ! !== vertical Stokes Drift 3D velocity ==! + ! + ze3divh(:,jj1:jj2,:) = 0.0_wp + DO jk = 1, jpkm1 ! Horizontal e3*divergence + DO jj = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier +#endif + ! + !$omp barrier + !$omp master + CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ! + 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(:,jj1:jj2,jk) = wsd(:,jj1:jj2,jk+1) - ze3divh(:,jj1:jj2,jk) + END DO + ! + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + wsd(:,jj1:jj2,jk) = wsd(:,jj1:jj2,jk) * bdytmask(:,jj1:jj2) + END DO + ENDIF + ! !== Horizontal divergence of barotropic Stokes transport ==! + div_sd(:,jj1:jj2) = 0._wp + DO jk = 1, jpkm1 ! + div_sd(:,jj1:jj2) = div_sd(:,jj1:jj2) + ze3divh(:,jj1:jj2,jk) + END DO + ! + !$omp end parallel + ! + CALL iom_put( "ustokes", usd ) + CALL iom_put( "vstokes", vsd ) + CALL iom_put( "wstokes", wsd ) + ! + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_stokes') + ! + 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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + + LOGICAL :: lwavestresscap = .TRUE. ! insure that the stress is not larger than zmaxstress + REAL(wp), PARAMETER :: zmaxstress = 10.0_wp + ! + IF( ln_timing_detail ) CALL timing_start('sbc_wstress') + ! + !$omp parallel private(itid,ithreads,ji,jj,jj1,jj2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + IF( ln_tauwoc ) THEN + utau(:,jj1:jj2) = utau(:,jj1:jj2)*tauoc_wave(:,jj1:jj2) + vtau(:,jj1:jj2) = vtau(:,jj1:jj2)*tauoc_wave(:,jj1:jj2) + taum(:,jj1:jj2) = taum(:,jj1:jj2)*tauoc_wave(:,jj1:jj2) + ENDIF + ! + IF( ln_tauw ) THEN + DO jj = MAX(1,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', 1.0_wp ) + !$omp end master + !$omp barrier + ENDIF + ! + IF( lwavestresscap ) THEN + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + IF (taum(ji,jj) > zmaxstress) THEN + WRITE(0,*)'Resetting stress at point : ',mig(ji),mjg(jj),gphit(ji,jj),glamt(ji,jj) + WRITE(0,*)'Old values : ',mig(ji),mjg(jj),taum(ji,jj) + utau(ji,jj) = utau(ji,jj)*zmaxstress/taum(ji,jj) + vtau(ji,jj) = vtau(ji,jj)*zmaxstress/taum(ji,jj) + taum(ji,jj) = zmaxstress + IF( ln_tauwoc ) tauoc_wave(ji,jj) = 1._wp + WRITE(0,*)'New values : ',mig(ji),mjg(jj),taum(ji,jj) + ENDIF + END DO + END DO + ENDIF + ! + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('sbc_wstress') + ! + 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 + INTEGER :: jj, ji ! dummy loop argument + + + REAL(wp), PARAMETER :: zchrnk_min = 0.011_wp ! minimum value of Charnock allowed + REAL(wp), PARAMETER :: zchrnk_max = 0.080_wp ! maximum value of Charnock allowed + REAL(wp), PARAMETER :: zchrnk_mean = 0.018_wp ! mean value of Charnock (if no wave model info) + + REAL(wp), PARAMETER :: zphioc_nd = 3.75_wp ! non dimensional value of phioc in the absence of information from the wave model + REAL(wp), PARAMETER :: zhswinf_nd = 0.24_wp ! non dimensional value of fully developped significant wave height value + REAL(wp), PARAMETER :: zrhoa_ci = 1.40_wp ! Air density kg/m3 over sea ice + + REAL(wp), PARAMETER :: ztauoc_min = 0.90_wp ! minimum value of normalised tauoc + REAL(wp), PARAMETER :: ztauoc_max = 3.00_wp ! maximum value of normalised tauoc + + REAL(wp), PARAMETER :: zu10_atm_max = 40.00_wp ! Maximum value for the 10m winds from the atmosphere used to compute fluxes when no waves + + REAL(wp) :: zu10_atm, zu10, zcdw, zustar + + + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_wave') + + IF( ln_wspd .AND. .NOT. cpl_wspd ) THEN !== Neutral 10m wind from the wave model ==! + CALL fld_read( kt, nn_fsbc, sf_wspd ) ! read from external forcing + wspd_wave(:,:) = sf_wspd(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==! + CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing + cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_rhoaw .AND. .NOT. cpl_rhoaw ) THEN !== Surface air density ==! + CALL fld_read( kt, nn_fsbc, sf_rhoa ) ! read from external forcing + rhoa_wave(:,:) = sf_rhoa(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_charnock .AND. .NOT. cpl_chnk ) THEN !== Charnock Coefficient ==! + CALL fld_read( kt, nn_fsbc, sf_charnock ) ! read from external forcing + charn_wave(:,:) = sf_charnock(1)%fnow(:,:,1) * tmask(:,:,1) + zchrnk_mean*( 1._wp - tmask(:,:,1) ) + + ! Protect Charnock values + charn_wave(:,:) = MIN( MAX(charn_wave(:,:),zchrnk_min) , zchrnk_max ) + + 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 +! insure realistic values: + tauoc_wave(:,:) = MAX(MIN(sf_tauwoc(1)%fnow(:,:,1),ztauoc_max),ztauoc_min) * tmask(:,:,1) + (1.0_wp-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 + !! array wmp to contain the mean wave period that is needed to estimate the Stokes dritf transport + IF(nn_sdtrans == -1 ) THEN + IF( jp_wmp > 0 ) wmp (:,:) = sf_sd(jp_wmp)%fnow(:,:,1) * tmask(:,:,1) ! wave mean period (-1) + ELSE IF(nn_sdtrans == 1 ) THEN + IF( jp_mp1 > 0 ) wmp (:,:) = sf_sd(jp_mp1)%fnow(:,:,1) * tmask(:,:,1) ! wave mean period (1) + ENDIF + 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 .OR. jp_mp1>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 + ! + IF( ln_wavephioc .AND. .NOT. cpl_phioc ) THEN !== Wave input to TKE ==! + CALL fld_read( kt, nn_fsbc, sf_phioc ) ! read wave norm stress from external forcing + phioc_wave(:,:) = sf_phioc(1)%fnow(:,:,1) * tmask(:,:,1) + IF ( jp_hsw == 0 ) THEN + CALL fld_read( kt, nn_fsbc, sf_hsw ) ! read wave norm stress from external forcing + hsw(:,:) = sf_hsw(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + ENDIF + + IF( ln_wvinice .AND. .NOT. cpl_inice ) THEN !== Wave input mask for when it was in sea ice ==! + CALL fld_read( kt, nn_fsbc, sf_inice ) ! read waves in sea ice mask + wave_inice(:,:) = sf_inice(1)%fnow(:,:,1) * tmask(:,:,1) + ELSE + wave_inice(:,:) = 0._wp + ENDIF + + +!!! Resetting wave forcing fields when wave height is 0 since it indicates that the wave model has not really +!!! provided meaningful values or when wave_inice is > 0 (i.e waves were in sea ice) +!!! providing meaningful values, then reset wave height using the wind speed. +!!! Can be programed a bit better + IF( jp_hsw > 0 .AND. .NOT. ln_wvinice ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ! flag to indicate that forcing was over its sea ice + if ( hsw(ji,jj) == 0._wp ) wave_inice(ji,jj)=1._wp + END DO + END DO + ENDIF + + DO jj = 1, jpj + DO ji = 1, jpi + IF ( wave_inice(ji,jj) > 0._wp ) THEN + ! 10m wind speed from the atmospheric system will be used as well (in case the wind from the wave data was set to 0.) + zu10_atm = MAX( SQRT( uspd_atm(ji,jj)**2 + vspd_atm(ji,jj)**2 ), 1._wp) + zu10 = MIN(zu10_atm, zu10_atm_max) + zu10 = MAX(zu10, wspd_wave(ji,jj)) + wspd_wave(ji,jj) = zu10 + ! Cd(U10) according to Edson et al. (2013) (capped at 0.003): + zcdw = MIN((1.03e-3_wp + 0.04e-3_wp * zu10**1.48_wp) * zu10**(-0.21_wp),0.003_wp) + zustar = SQRT(zcdw) * zu10 + IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN + cdn_wave(ji,jj) = zcdw + ENDIF + ! reset Charnock + IF( ln_charnock .AND. .NOT. cpl_chnk ) THEN + charn_wave(ji,jj) = MAX(charn_wave(ji,jj), zchrnk_mean) + ENDIF + ! tauoc_wave should be 1 if no waves effect + IF( ln_tauwoc .AND. .NOT. cpl_tauwoc ) tauoc_wave(ji,jj) = 1._wp + ! phioc = m * air_density * ustar**3, with m ~ zphioc_nd + IF( ln_wavephioc .AND. .NOT. cpl_phioc ) THEN + IF( ln_rhoaw .AND. .NOT. cpl_rhoaw ) THEN + phioc_wave(ji,jj) = MAX(phioc_wave(ji,jj), rhoa_wave(ji,jj)*zphioc_nd*zustar**3) + ELSE + phioc_wave(ji,jj) = MAX(phioc_wave(ji,jj), zrhoa_ci*zphioc_nd*zustar**3) + ENDIF + ENDIF + ! finally update hsw with fully developed significant wave height (1. < hsw < 10m) + IF( jp_hsw > 0 ) hsw(ji,jj) = MAX( MAX(MIN(zhswinf_nd*zu10**2/grav, 10._wp),1.0_wp), hsw(ji,jj) ) + IF( jp_wmp > 0 ) wmp(ji,jj) = MAX( wmp(ji,jj), 5.0_wp) + + ! reset surface Stokes drift at T-point as 0.016 the atmospheric winds + IF( ln_sdw ) THEN + ut0sd(ji,jj) = 0.016_wp * uspd_atm(ji,jj) * (MIN(zu10_atm,zu10_atm_max)/zu10_atm) + vt0sd(ji,jj) = 0.016_wp * vspd_atm(ji,jj) * (MIN(zu10_atm,zu10_atm_max)/zu10_atm) + ENDIF + + ENDIF + END DO + END DO + + IF( ln_timing_detail ) CALL timing_stop('sbc_wave') + + END SUBROUTINE sbc_wave + + SUBROUTINE sbc_wave_sglexe( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave_sglexe *** + !! + !! ** Purpose : copy information from the single executable coupling + !! to nemo data + !! + !! ** Method : + !! + !! ** action + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + INTEGER :: jj, ji ! dummy loop argument + REAL(wp), PARAMETER :: ztauoc_min = 0.90_wp ! minimum value of normalised tauoc + REAL(wp), PARAMETER :: ztauoc_max = 3.00_wp ! maximum value of normalised tauoc + + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('sbc_wave_sglexe') + + IF(lwp) WRITE(numout,*)'sbc_wave_sglexe kt = ',kt + + IF( ln_tauwoc ) THEN !== Wave induced stress ==! + CALL ctl_stop('sbc_wave_sglexe: ln_tauwoc = true not supported. Did you mean ln_tauw?') + ENDIF + + IF( ln_tauw ) THEN !== Wave induced stress ==! + tauw_x(:,:) = zsutauwam(:,:) * tmask(:,:,1) + tauw_y(:,:) = zsvtauwam(:,:) * tmask(:,:,1) +! insure realistic values of tauoc + tauoc_wave(:,:) = MAX(MIN(zstauoc,ztauoc_max),ztauoc_min) * tmask(:,:,1) + (1.0_wp-tmask(:,:,1)) + + ENDIF + + IF( ln_sdw ) THEN !== Computation of the 3d Stokes Drift ==! + ! + hsw (:,:) = zsswh(:,:) * tmask(:,:,1) ! significant wave height + wmp (:,:) = zsmwp(:,:) * tmask(:,:,1) ! wave mean period + ut0sd(:,:) = zsustokes(:,:) * tmask(:,:,1) ! 2D zonal Stokes Drift at T point + vt0sd(:,:) = zsvstokes(:,:) * tmask(:,:,1) ! 2D meridional Stokes Drift at T point + ! + ! Read also wave number if needed, so that it is available in coupling routines + IF( ln_zdfswm ) THEN + CALL ctl_stop('sbc_wave_sglexe: ln_zdfswm = true not supported.') + 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 ) CALL sbc_stokes() + IF( ll_st_peakfr ) & + & CALL ctl_stop('sbc_wave_sglexe: ll_st_peakfr = true not supported') + ! + ENDIF + ! + IF( ln_wavephioc ) THEN !== Wave input to TKE ==! + phioc_wave(:,:) = -zsphifwam(:,:) * tmask(:,:,1) + IF ( .NOT. ln_sdw ) THEN + hsw(:,:) = zsswh(:,:) * tmask(:,:,1) ! significant wave height + ENDIF + ENDIF + + wave_inice(:,:) = 0._wp + + IF( ln_timing_detail ) CALL timing_stop('sbc_wave_sglexe') + + END SUBROUTINE sbc_wave_sglexe + + 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 + !! + REAL(wp), PARAMETER :: zrhoa = 1.25_wp ! Air density kg/m3 + 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_wspd, sn_usd, sn_vsd, & + & sn_hsw, sn_wmp, sn_mp1, sn_wfr, sn_wnum, & + & sn_tauwoc, sn_tauwx, sn_tauwy, sn_phioc, & + & sn_inice, sn_rhoa, sn_charnock ! informations about the fields to be read + ! + NAMELIST/namsbc_wave/ sn_cdg, sn_wspd, cn_dir, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_mp1, sn_wfr, & + & sn_wnum, sn_tauwoc, sn_tauwx, sn_tauwy, sn_phioc, & + & sn_inice, sn_rhoa, sn_charnock + !!--------------------------------------------------------------------- + ! + 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 ) + ! + ! Force all coupled option to be true for sglexe + IF( ln_sglexe .OR. ln_sglwam ) THEN + cpl_hsig = .TRUE. + cpl_phioc = .TRUE. + cpl_sdrftx = .TRUE. + cpl_sdrfty = .TRUE. + cpl_wper = .TRUE. + cpl_wfreq = .TRUE. + cpl_wnum = .TRUE. + cpl_tauwoc = .TRUE. + cpl_tauw = .TRUE. + cpl_wdrag = .TRUE. + cpl_wspd = .TRUE. + cpl_rhoaw = .TRUE. + cpl_chnk = .TRUE. + cpl_inice = .TRUE. + ENDIF + + ALLOCATE( wave_inice(jpi,jpj) ) + IF( ln_wvinice ) THEN + ALLOCATE( sf_inice(1), STAT=ierror ) !* allocate and fill sf_wave with sn_inice + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure sf_inice' ) + ! + ALLOCATE( sf_inice(1)%fnow(jpi,jpj,1) ) + IF( sn_inice%ln_tint ) ALLOCATE( sf_inice(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_inice, (/ sn_inice /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ELSE + wave_inice(:,:)=0._wp + ENDIF + + ! uspd_atm and vspdd_atm updated in sbcblk + ALLOCATE( uspd_atm(jpi,jpj) ) + uspd_atm(:,:) = 0._wp + ALLOCATE( vspd_atm(jpi,jpj) ) + vspd_atm(:,:) = 0._wp + + ALLOCATE( wspd_wave(jpi,jpj) ) + wspd_wave(:,:) = 0._wp + IF( ln_wspd ) THEN + IF( .NOT. cpl_wspd ) THEN + ALLOCATE( sf_wspd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wspd + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure sf_wspd' ) + ! + ALLOCATE( sf_wspd(1)%fnow(jpi,jpj,1) ) + IF( sn_wspd%ln_tint ) ALLOCATE( sf_wspd(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_wspd, (/ sn_wspd /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ENDIF + ENDIF + + 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 sf_cd' ) + ! + 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_rhoaw ) THEN + IF( .NOT. cpl_rhoaw ) THEN + ALLOCATE( sf_rhoa(1), STAT=ierror ) !* allocate and fill sf_wave with sn_rhoa + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure sf_rhoa' ) + ! + ALLOCATE( sf_rhoa(1)%fnow(jpi,jpj,1) ) + IF( sn_rhoa%ln_tint ) ALLOCATE( sf_rhoa(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_rhoa, (/ sn_rhoa /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ENDIF + ALLOCATE( rhoa_wave(jpi,jpj) ) + rhoa_wave(:,:) = zrhoa + ENDIF + + IF( ln_charnock ) THEN + IF( .NOT. cpl_chnk ) THEN + ALLOCATE( sf_charnock(1), STAT=ierror ) !* allocate and fill sf_wave with sn_charnock + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure sf_charnock' ) + ! + ALLOCATE( sf_charnock(1)%fnow(jpi,jpj,1) ) + IF( sn_charnock%ln_tint ) ALLOCATE( sf_charnock(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_charnock, (/ sn_charnock /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ENDIF + ALLOCATE( charn_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) ) + IF( ln_sglexe .OR. ln_sglwam ) THEN + IF (.NOT.ALLOCATED(tauoc_wave)) THEN + ALLOCATE( tauoc_wave(jpi,jpj) ) + ENDIF + ENDIF + ENDIF + + jp_hsw=0 + 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_wmp=0 ; jp_mp1=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 + IF(nn_sdtrans == -1 ) THEN + jp_wmp = jpfld + ELSE IF(nn_sdtrans == 1 ) THEN + jp_mp1 = jpfld + ENDIF + 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_mp1 > 0 ) slf_i(jp_mp1) = sn_mp1 + 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 sf_sd' ) + ! + 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) ) + ALLOCATE( 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 + + IF( ln_wavephioc ) THEN + IF( .NOT. cpl_phioc ) THEN + ALLOCATE( sf_phioc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_phioc + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure sf_phioc' ) + ! + ALLOCATE( sf_phioc(1)%fnow(jpi,jpj,1) ) + IF( sn_phioc%ln_tint ) ALLOCATE( sf_phioc(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_phioc, (/ sn_phioc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) + ENDIF + ALLOCATE( phioc_wave(jpi,jpj) ) + phioc_wave(:,:) = 0._wp + IF ( jp_hsw == 0 ) THEN + ALLOCATE( sf_hsw(1), STAT=ierror ) !* allocate and fill sf_wave with sn_hsw + ALLOCATE( sf_hsw(1)%fnow(jpi,jpj,1) ) + IF( sn_hsw%ln_tint ) ALLOCATE( sf_hsw(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_hsw, (/ sn_hsw /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) + IF (.NOT.ALLOCATED(hsw)) THEN + ALLOCATE( hsw(jpi,jpj) ) + hsw(:,:) = 0._wp + ENDIF + ENDIF + ENDIF + ! + END SUBROUTINE sbc_wave_init + + + !!====================================================================== +END MODULE sbcwave \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/tide.h90 b/V4.0/nemo_sources/src/OCE/SBC/tide.h90 new file mode 100644 index 0000000000000000000000000000000000000000..f59ff289ceeb369d0abf098611bdd6c481529def --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/tide.h90 @@ -0,0 +1,29 @@ +!!---------------------------------------------------------------------- + !! 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 ) \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/tide_mod.F90 b/V4.0/nemo_sources/src/OCE/SBC/tide_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5529298c954f51df4b17f5d0ca4867d249ef1502 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/tide_mod.F90 @@ -0,0 +1,411 @@ +MODULE tide_mod + !!====================================================================== + !! *** MODULE tide_mod *** + !! Compute nodal modulations corrections and pulsations + !!====================================================================== + !! History : 1.0 ! 2007 (O. Le Galloudec) Original code + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE daymod ! calendar + + IMPLICIT NONE + PRIVATE + + PUBLIC tide_harmo ! called by tideini and diaharm modules + PUBLIC tide_init_Wave ! called by tideini and diaharm modules + + INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 19 !: maximum number of harmonic + + TYPE, PUBLIC :: tide + CHARACTER(LEN=4) :: cname_tide + REAL(wp) :: equitide + INTEGER :: nutide + INTEGER :: nt, ns, nh, np, np1, shift + INTEGER :: nksi, nnu0, nnu1, nnu2, R + INTEGER :: nformula + END TYPE tide + + TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) :: Wave !: + + REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles + REAL(wp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! + REAL(wp) :: sh_I, sh_x1ra, sh_N ! + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tide_mod.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tide_init_Wave +# include "tide.h90" + END SUBROUTINE tide_init_Wave + + + SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents + INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents + REAL(wp), DIMENSION(kc), INTENT(out) :: pomega ! pulsation in radians/s + REAL(wp), DIMENSION(kc), INTENT(out) :: pvt, put, pcor ! + !!---------------------------------------------------------------------- + ! + CALL astronomic_angle + CALL tide_pulse( pomega, ktide ,kc ) + CALL tide_vuf ( pvt, put, pcor, ktide ,kc ) + ! + END SUBROUTINE tide_harmo + + + SUBROUTINE astronomic_angle + !!---------------------------------------------------------------------- + !! tj is time elapsed since 1st January 1900, 0 hour, counted in julian + !! century (e.g. time in days divide by 36525) + !!---------------------------------------------------------------------- + REAL(wp) :: cosI, p, q, t2, t4, sin2I, s2, tgI2, P1, sh_tgn2, at1, at2 + REAL(wp) :: zqy , zsy, zday, zdj, zhfrac + !!---------------------------------------------------------------------- + ! + zqy = AINT( (nyear-1901.)/4. ) + zsy = nyear - 1900. + ! + zdj = dayjul( nyear, nmonth, nday ) + zday = zdj + zqy - 1. + ! + zhfrac = nsec_day / 3600. + ! + !---------------------------------------------------------------------- + ! Sh_n Longitude of ascending lunar node + !---------------------------------------------------------------------- + sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad + !---------------------------------------------------------------------- + ! T mean solar angle (Greenwhich time) + !---------------------------------------------------------------------- + sh_T=(180.+zhfrac*(360./24.))*rad + !---------------------------------------------------------------------- + ! h mean solar Longitude + !---------------------------------------------------------------------- + sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad + !---------------------------------------------------------------------- + ! s mean lunar Longitude + !---------------------------------------------------------------------- + sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad + !---------------------------------------------------------------------- + ! p1 Longitude of solar perigee + !---------------------------------------------------------------------- + sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad + !---------------------------------------------------------------------- + ! p Longitude of lunar perigee + !---------------------------------------------------------------------- + sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad + + sh_N = MOD( sh_N ,2*rpi ) + sh_s = MOD( sh_s ,2*rpi ) + sh_h = MOD( sh_h, 2*rpi ) + sh_p = MOD( sh_p, 2*rpi ) + sh_p1= MOD( sh_p1,2*rpi ) + + cosI = 0.913694997 -0.035692561 *cos(sh_N) + + sh_I = ACOS( cosI ) + + sin2I = sin(sh_I) + sh_tgn2 = tan(sh_N/2.0) + + at1=atan(1.01883*sh_tgn2) + at2=atan(0.64412*sh_tgn2) + + sh_xi=-at1-at2+sh_N + + IF( sh_N > rpi ) sh_xi=sh_xi-2.0*rpi + + sh_nu = at1 - at2 + + !---------------------------------------------------------------------- + ! For constituents l2 k1 k2 + !---------------------------------------------------------------------- + + tgI2 = tan(sh_I/2.0) + P1 = sh_p-sh_xi + + t2 = tgI2*tgI2 + t4 = t2*t2 + sh_x1ra = sqrt( 1.0-12.0*t2*cos(2.0*P1)+36.0*t4 ) + + p = sin(2.0*P1) + q = 1.0/(6.0*t2)-cos(2.0*P1) + sh_R = atan(p/q) + + p = sin(2.0*sh_I)*sin(sh_nu) + q = sin(2.0*sh_I)*cos(sh_nu)+0.3347 + sh_nuprim = atan(p/q) + + s2 = sin(sh_I)*sin(sh_I) + p = s2*sin(2.0*sh_nu) + q = s2*cos(2.0*sh_nu)+0.0727 + sh_nusec = 0.5*atan(p/q) + ! + END SUBROUTINE astronomic_angle + + + SUBROUTINE tide_pulse( pomega, ktide ,kc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_pulse *** + !! + !! ** Purpose : Compute tidal frequencies + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents + INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents + REAL(wp), DIMENSION(kc), INTENT(out) :: pomega ! pulsation in radians/s + ! + INTEGER :: jh + REAL(wp) :: zscale + REAL(wp) :: zomega_T = 13149000.0_wp + REAL(wp) :: zomega_s = 481267.892_wp + REAL(wp) :: zomega_h = 36000.76892_wp + REAL(wp) :: zomega_p = 4069.0322056_wp + REAL(wp) :: zomega_n = 1934.1423972_wp + REAL(wp) :: zomega_p1= 1.719175_wp + !!---------------------------------------------------------------------- + ! + zscale = rad / ( 36525._wp * 86400._wp ) + ! + DO jh = 1, kc + pomega(jh) = ( zomega_T * Wave( ktide(jh) )%nT & + & + zomega_s * Wave( ktide(jh) )%ns & + & + zomega_h * Wave( ktide(jh) )%nh & + & + zomega_p * Wave( ktide(jh) )%np & + & + zomega_p1* Wave( ktide(jh) )%np1 ) * zscale + END DO + ! + END SUBROUTINE tide_pulse + + + SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_vuf *** + !! + !! ** Purpose : Compute nodal modulation corrections + !! + !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians) + !! ut: Phase correction u due to nodal motion (radians) + !! ft: Nodal correction factor + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents + INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents + REAL(wp), DIMENSION(kc), INTENT(out) :: pvt, put, pcor ! + ! + INTEGER :: jh ! dummy loop index + !!---------------------------------------------------------------------- + ! + DO jh = 1, kc + ! Phase of the tidal potential relative to the Greenwhich + ! meridian (e.g. the position of the fictuous celestial body). Units are radian: + pvt(jh) = sh_T * Wave( ktide(jh) )%nT & + & + sh_s * Wave( ktide(jh) )%ns & + & + sh_h * Wave( ktide(jh) )%nh & + & + sh_p * Wave( ktide(jh) )%np & + & + sh_p1* Wave( ktide(jh) )%np1 & + & + Wave( ktide(jh) )%shift * rad + ! + ! Phase correction u due to nodal motion. Units are radian: + put(jh) = sh_xi * Wave( ktide(jh) )%nksi & + & + sh_nu * Wave( ktide(jh) )%nnu0 & + & + sh_nuprim * Wave( ktide(jh) )%nnu1 & + & + sh_nusec * Wave( ktide(jh) )%nnu2 & + & + sh_R * Wave( ktide(jh) )%R + + ! Nodal correction factor: + pcor(jh) = nodal_factort( Wave( ktide(jh) )%nformula ) + END DO + ! + END SUBROUTINE tide_vuf + + + RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kformula + ! + REAL(wp) :: zf + REAL(wp) :: zs, zf1, zf2 + !!---------------------------------------------------------------------- + ! + SELECT CASE( kformula ) + ! + CASE( 0 ) !== formule 0, solar waves + zf = 1.0 + ! + CASE( 1 ) !== formule 1, compound waves (78 x 78) + zf=nodal_factort(78) + zf = zf * zf + ! + CASE ( 2 ) !== formule 2, compound waves (78 x 0) === (78) + zf1= nodal_factort(78) + zf = nodal_factort( 0) + zf = zf1 * zf + ! + CASE ( 4 ) !== formule 4, compound waves (78 x 235) + zf1 = nodal_factort( 78) + zf = nodal_factort(235) + zf = zf1 * zf + ! + CASE ( 5 ) !== formule 5, compound waves (78 *78 x 235) + zf1 = nodal_factort( 78) + zf = nodal_factort(235) + zf = zf * zf1 * zf1 + ! + CASE ( 6 ) !== formule 6, compound waves (78 *78 x 0) + zf1 = nodal_factort(78) + zf = nodal_factort( 0) + zf = zf * zf1 * zf1 + ! + CASE( 7 ) !== formule 7, compound waves (75 x 75) + zf = nodal_factort(75) + zf = zf * zf + ! + CASE( 8 ) !== formule 8, compound waves (78 x 0 x 235) + zf = nodal_factort( 78) + zf1 = nodal_factort( 0) + zf2 = nodal_factort(235) + zf = zf * zf1 * zf2 + ! + CASE( 9 ) !== formule 9, compound waves (78 x 0 x 227) + zf = nodal_factort( 78) + zf1 = nodal_factort( 0) + zf2 = nodal_factort(227) + zf = zf * zf1 * zf2 + ! + CASE( 10 ) !== formule 10, compound waves (78 x 227) + zf = nodal_factort( 78) + zf1 = nodal_factort(227) + zf = zf * zf1 + ! + CASE( 11 ) !== formule 11, compound waves (75 x 0) +!!gm bug???? zf 2 fois ! + zf = nodal_factort(75) + zf1 = nodal_factort( 0) + zf = zf * zf1 + ! + CASE( 12 ) !== formule 12, compound waves (78 x 78 x 78 x 0) + zf1 = nodal_factort(78) + zf = nodal_factort( 0) + zf = zf * zf1 * zf1 * zf1 + ! + CASE( 13 ) !== formule 13, compound waves (78 x 75) + zf1 = nodal_factort(78) + zf = nodal_factort(75) + zf = zf * zf1 + ! + CASE( 14 ) !== formule 14, compound waves (235 x 0) === (235) + zf = nodal_factort(235) + zf1 = nodal_factort( 0) + zf = zf * zf1 + ! + CASE( 15 ) !== formule 15, compound waves (235 x 75) + zf = nodal_factort(235) + zf1 = nodal_factort( 75) + zf = zf * zf1 + ! + CASE( 16 ) !== formule 16, compound waves (78 x 0 x 0) === (78) + zf = nodal_factort(78) + zf1 = nodal_factort( 0) + zf = zf * zf1 * zf1 + ! + CASE( 17 ) !== formule 17, compound waves (227 x 0) + zf1 = nodal_factort(227) + zf = nodal_factort( 0) + zf = zf * zf1 + ! + CASE( 18 ) !== formule 18, compound waves (78 x 78 x 78 ) + zf1 = nodal_factort(78) + zf = zf1 * zf1 * zf1 + ! + CASE( 19 ) !== formule 19, compound waves (78 x 0 x 0 x 0) === (78) +!!gm bug2 ==>>> here identical to formule 16, a third multiplication by zf1 is missing + zf = nodal_factort(78) + zf1 = nodal_factort( 0) + zf = zf * zf1 * zf1 + ! + CASE( 73 ) !== formule 73 + zs = sin(sh_I) + zf = (2./3.-zs*zs)/0.5021 + ! + CASE( 74 ) !== formule 74 + zs = sin(sh_I) + zf = zs * zs / 0.1578 + ! + CASE( 75 ) !== formule 75 + zs = cos(sh_I/2) + zf = sin(sh_I) * zs * zs / 0.3800 + ! + CASE( 76 ) !== formule 76 + zf = sin(2*sh_I) / 0.7214 + ! + CASE( 77 ) !== formule 77 + zs = sin(sh_I/2) + zf = sin(sh_I) * zs * zs / 0.0164 + ! + CASE( 78 ) !== formule 78 + zs = cos(sh_I/2) + zf = zs * zs * zs * zs / 0.9154 + ! + CASE( 79 ) !== formule 79 + zs = sin(sh_I) + zf = zs * zs / 0.1565 + ! + CASE( 144 ) !== formule 144 + zs = sin(sh_I/2) + zf = ( 1-10*zs*zs+15*zs*zs*zs*zs ) * cos(sh_I/2) / 0.5873 + ! + CASE( 149 ) !== formule 149 + zs = cos(sh_I/2) + zf = zs*zs*zs*zs*zs*zs / 0.8758 + ! + CASE( 215 ) !== formule 215 + zs = cos(sh_I/2) + zf = zs*zs*zs*zs / 0.9154 * sh_x1ra + ! + CASE( 227 ) !== formule 227 + zs = sin(2*sh_I) + zf = sqrt( 0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006 ) + ! + CASE ( 235 ) !== formule 235 + zs = sin(sh_I) + zf = sqrt( 19.0444*zs*zs*zs*zs + 2.7702*zs*zs*cos(2*sh_nu) + .0981 ) + ! + END SELECT + ! + END FUNCTION nodal_factort + + + FUNCTION dayjul( kyr, kmonth, kday ) + !!---------------------------------------------------------------------- + !! *** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE) + !!---------------------------------------------------------------------- + INTEGER,INTENT(in) :: kyr, kmonth, kday + ! + INTEGER,DIMENSION(12) :: idayt, idays + INTEGER :: inc, ji + REAL(wp) :: dayjul, zyq + ! + DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ + !!---------------------------------------------------------------------- + ! + idays(1) = 0. + idays(2) = 31. + inc = 0. + zyq = MOD( kyr-1900. , 4. ) + IF( zyq == 0.) inc = 1. + DO ji = 3, 12 + idays(ji)=idayt(ji)+inc + END DO + dayjul = idays(kmonth) + kday + ! + END FUNCTION dayjul + + !!====================================================================== +END MODULE tide_mod \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/tideini.F90 b/V4.0/nemo_sources/src/OCE/SBC/tideini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..053159dc52307c95d7ffce63b95840b35647c460 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/SBC/tideini.F90 @@ -0,0 +1,134 @@ +MODULE tideini + !!====================================================================== + !! *** MODULE tideini *** + !! Initialization of tidal forcing + !!====================================================================== + !! History : 1.0 ! 2007 (O. Le Galloudec) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE daymod ! calendar + USE tide_mod ! + ! + USE in_out_manager ! I/O units + USE iom ! xIOs server + USE ioipsl ! NetCDF IPSL library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PUBLIC + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: omega_tide !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: v0tide !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: utide !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: ftide !: + + 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 !: + REAL(wp), PUBLIC :: rn_scal_load !: + CHARACTER(lc), PUBLIC :: cn_tide_load !: + + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntide !: + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tideini.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tide_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init *** + !!---------------------------------------------------------------------- + INTEGER :: ji, jk + CHARACTER(LEN=4), DIMENSION(jpmax_harmo) :: clname + INTEGER :: ios ! Local integer output status for namelist read + ! + 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' ) + ! + 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' ) + IF(lwm) WRITE ( numond, nam_tide ) + ! + IF( ln_tide ) THEN + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init : Initialization of the tidal components' + WRITE(numout,*) '~~~~~~~~~ ' + WRITE(numout,*) ' Namelist nam_tide' + WRITE(numout,*) ' Use tidal components ln_tide = ', ln_tide + WRITE(numout,*) ' 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,*) '~~~~~~~~~ ' + RETURN + ENDIF + ! + CALL tide_init_Wave + ! + nb_harmo=0 + DO jk = 1, jpmax_harmo + DO ji = 1,jpmax_harmo + IF( TRIM(clname(jk)) == Wave(ji)%cname_tide ) nb_harmo = nb_harmo + 1 + END DO + END DO + ! + ! 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.) ) & + & CALL ctl_stop('rdttideramp must be positive') + ! + ALLOCATE( ntide(nb_harmo) ) + DO jk = 1, nb_harmo + DO ji = 1, jpmax_harmo + IF( TRIM(clname(jk)) == Wave(ji)%cname_tide ) THEN + ntide(jk) = ji + EXIT + ENDIF + END DO + END DO + ! + ALLOCATE( omega_tide(nb_harmo), v0tide (nb_harmo), & + & utide (nb_harmo), ftide (nb_harmo) ) + kt_tide = nit000 + ! + IF (.NOT.ln_scal_load ) rn_scal_load = 0._wp + ! + END SUBROUTINE tide_init + + !!====================================================================== +END MODULE tideini \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/SBC/updtide.F90 b/V4.0/nemo_sources/src/OCE/SBC/updtide.F90 new file mode 100644 index 0000000000000000000000000000000000000000..53aff0470330f50dfc8d2897fef2e97813dceb1f --- /dev/null +++ b/V4.0/nemo_sources/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: updtide.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/STO/stopar.F90 b/V4.0/nemo_sources/src/OCE/STO/stopar.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0f67db131671e43ff0ab3c19150b6b83431d53e5 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/STO/stopar.F90 @@ -0,0 +1,914 @@ +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: stopar.F90 13255 2020-07-06 15:41:29Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_par( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par *** + !! + !! ** Purpose : update the stochastic parameters + !! + !! ** Method : model basic stochastic parameters + !! as a first order autoregressive process AR(1), + !! governed by the equation: + !! X(t) = a * X(t-1) + b * w + c + !! where the parameters a, b and c are related + !! to expected value, standard deviation + !! and time correlation (all stationary in time) by: + !! E [X(t)] = c / ( 1 - a ) + !! STD [X(t)] = b / SQRT( 1 - a * a ) + !! COR [X(t),X(t-k)] = a ** k + !! and w is a Gaussian white noise. + !! + !! Higher order autoregressive proces can be optionally generated + !! by replacing the white noise by a lower order process. + !! + !! 1) The statistics of the stochastic parameters (X) are assumed + !! constant in space (homogeneous) and time (stationary). + !! This could be generalized by replacing the constant + !! a, b, c parameters by functions of space and time. + !! + !! 2) The computation is performed independently for every model + !! grid point, which corresponds to assume that the stochastic + !! parameters are uncorrelated in space. + !! This could be generalized by including a spatial filter: Y = Filt[ X ] + !! (possibly non-homgeneous and non-stationary) in the computation, + !! or by solving an elliptic equation: L[ Y ] = X. + !! + !! 3) The stochastic model for the parameters could also + !! be generalized to depend on the current state of the ocean (not done here). + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jsto, jflt + REAL(wp) :: stomax + !!---------------------------------------------------------------------- + ! + ! Update 2D stochastic arrays + ! + DO jsto = 1, jpsto2d + ! Store array from previous time step + sto_tmp(:,:) = sto2d(:,:,jsto) + + IF ( sto2d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto2d(:,:,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto2d_flt(jsto) + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + CALL sto_par_flt( sto2d(:,:,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto2d(:,:,jsto) = sto2d(:,:,jsto-1) + ENDIF + + ! Multiply white noise (or lower order process) by b --> b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto_tmp(:,:) * sto2d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_abc(jsto,3) + ! Limit random parameter anomalies to std times the limitation factor + stomax = sto2d_std(jsto) * sto2d_lim(jsto) + sto2d(:,:,jsto) = sto2d(:,:,jsto) - sto2d_ave(jsto) + sto2d(:,:,jsto) = SIGN(MIN(stomax,ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto)) + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_ave(jsto) + + ! Lateral boundary conditions on sto2d + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + END DO + ! + ! Update 3D stochastic arrays + ! + DO jsto = 1, jpsto3d + DO jk = 1, jpk + ! Store array from previous time step + sto_tmp(:,:) = sto3d(:,:,jk,jsto) + + IF ( sto3d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto3d(:,:,jk,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto3d_flt(jsto) + CALL lbc_lnk( 'stopar', sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + CALL sto_par_flt( sto3d(:,:,jk,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto-1) + ENDIF + + ! Multiply white noise by b --> b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto_tmp(:,:) * sto3d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_abc(jsto,3) + ! Limit random parameters anomalies to std times the limitation factor + stomax = sto3d_std(jsto) * sto3d_lim(jsto) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) - sto3d_ave(jsto) + sto3d(:,:,jk,jsto) = SIGN(MIN(stomax,ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto)) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_ave(jsto) + END DO + ! Lateral boundary conditions on sto3d + CALL lbc_lnk( 'stopar', sto3d(:,:,:,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + END DO + ! + END SUBROUTINE sto_par + + + SUBROUTINE sto_par_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_init *** + !! + !! ** Purpose : define the stochastic parameterization + !!---------------------------------------------------------------------- + ! 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=wp) :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/STO/stopts.F90 b/V4.0/nemo_sources/src/OCE/STO/stopts.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b0a0d5bbc56463142d78be3d8456e61f776ad562 --- /dev/null +++ b/V4.0/nemo_sources/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: stopts.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_pts( pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_pts *** + !! + !! ** Purpose : Compute current stochastic tracer fluctuations + !! + !! ** Method : Compute tracer differences from a random walk + !! around every model grid point + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + INTEGER :: ji, jj, jk, jts, jdof ! dummy loop indices + INTEGER :: jim1, jjm1, jkm1 ! incremented indices + INTEGER :: jip1, jjp1, jkp1 ! - - + REAL(wp) :: zdtsim, zdtsjm, zdtskm ! temporary scalars + REAL(wp) :: zdtsip, zdtsjp, zdtskp, zdts ! - - + !!---------------------------------------------------------------------- + + DO jts = 1, jpts + CALL lbc_lnk( 'stopts', pts(:,:,:,jts), 'T' , 1._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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/STO/storng.F90 b/V4.0/nemo_sources/src/OCE/STO/storng.F90 new file mode 100644 index 0000000000000000000000000000000000000000..82a58fa41a9c42f296f508d587dbeb45c58d2d6d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/STO/storng.F90 @@ -0,0 +1,409 @@ +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: storng.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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 + INTEGER(KIND=i8), INTENT(IN) :: k + s = ISHFT(k,-63) + END FUNCTION s + + FUNCTION m(k, n) + INTEGER(KIND=i8) :: m + INTEGER(KIND=i8), INTENT(IN) :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/eosbn2.F90 b/V4.0/nemo_sources/src/OCE/TRA/eosbn2.F90 new file mode 100644 index 0000000000000000000000000000000000000000..acd5b2ed4451831f4d43a4d7cbb219daae94c4c4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/eosbn2.F90 @@ -0,0 +1,1894 @@ +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) + !! eos_rprof : Compute the in situ density of a reference profile + !!---------------------------------------------------------------------- + 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 + PUBLIC eos_rprof ! called by sbc 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 + + REAL(wp), PUBLIC, DIMENSION(:), SAVE, ALLOCATABLE :: rhoref + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: eosbn2.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(dp), 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, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2! - - + REAL(dp) :: zn, zn0, zn3! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-insitu') + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! + CASE( np_seos ) !== simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel 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(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) + REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] + ! + INTEGER :: ji, jj, jk, jsmp ! dummy loop indices + INTEGER :: jdof + REAL(wp) :: zt, zstemp, ztm! local scalars + REAL(dp) :: zh, zs! local scalars + REAL(wp) :: zn1, zn2, zn3! - - + REAL(dp) :: zn, zn0! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-pot') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + ! Stochastic equation of state + IF ( ln_sto_eos ) THEN + ALLOCATE(zn0_sto(1:2*nn_sto_eos)) + ALLOCATE(zn_sto(1:2*nn_sto_eos)) + ALLOCATE(zsign(1:2*nn_sto_eos)) + DO jsmp = 1, 2*nn_sto_eos, 2 + zsign(jsmp) = 1._wp + zsign(jsmp+1) = -1._wp + END DO + ! + DO jk = 1, jpkm1 + DO jj = 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 + !$omp parallel do private(ji,jj,jk,jsmp,jdof, & + !$omp & zt,zh,zstemp,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ENDIF + + CASE( np_seos ) !== simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,jsmp,jdof, & + !$omp & zt,zh,zstemp,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! + END SELECT + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=CASTDP(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! local scalars + REAL(dp) :: zh, zs! local scalars + REAL(dp) :: 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 ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! + CALL lbc_lnk( 'eosbn2', prd, 'T', 1.0_wp ) ! Lateral boundary conditions + ! + CASE( np_seos ) !== simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! + CALL lbc_lnk( 'eosbn2', prd, 'T', 1.0_wp ) ! 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(dp), 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 ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! + CASE( np_seos ) !== simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel 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=CASTDP(pab(:,:,:,jp_tem)), clinfo1=' rab_3d_t: ', & + & tab3d_2=CASTDP(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 ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! ! Lateral boundary conditions + CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1.0_wp , pab(:,:,jp_sal), 'T', 1.0_wp ) + ! + CASE( np_seos ) !== simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,zn,zn0,zn1,zn2,zn3) + 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 + !$omp end parallel do + ! ! Lateral boundary conditions + CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1.0_wp , pab(:,:,jp_sal), 'T', 1.0_wp ) + ! + 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(dp), 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(dp) :: zaw, zbw, zrw ! local scalars + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('bn2') + ! + !$omp parallel do private(ji,jj,jk,zaw,zbw,zrw) + 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 + !$omp end parallel do + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=CASTDP(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(dp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] + REAL(dp), 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 + ! + !$omp parallel do private(ji,jj,zt,zs,zn,zd) + 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 + !$omp end parallel 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 + !$omp parallel private(ji,jj,zt,zs) + !$omp do + 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 + ptf(:,jj) = ptf(:,jj) * psal(:,jj) + END DO + !$omp end do + ! + IF( PRESENT( pdep ) ) THEN + !$omp do + DO jj = 1, jpj + ptf(:,jj) = ptf(:,jj) - 7.53e-4 * pdep(:,jj) + END DO + !$omp end do + ENDIF + !$omp end parallel + ! + CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! + ! + !$omp parallel do private(ji,jj,zt,zs) + DO jj = 1, jpj + ptf(:,jj) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,jj) ) & + & - 2.154996e-4_wp * psal(:,jj) ) * psal(:,jj) + END DO + !$omp end parallel do + ! + 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(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos_pen') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2) + 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 + !$omp end parallel do + ! + CASE( np_seos ) !== Vallis (2006) simplified EOS ==! + ! + !$omp parallel do private(ji,jj,jk,zt,zh,zs,ztm,zn,zn0,zn1,zn2) + 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 + !$omp end parallel 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 + + FUNCTION fsatg(pfps,pfpt,pfphp) + REAL(dp) :: pfps, pfpt, pfphp + REAL(wp) :: fsatg + + fsatg = & + & (((-2.1687e-16*pfpt+1.8676e-14)*pfpt-4.6206e-13)*pfphp & + & +((2.7759e-12*pfpt-1.1351e-10)*(pfps-35.)+((-5.4481e-14*pfpt & + & +8.733e-12)*pfpt-6.7795e-10)*pfpt+1.8741e-8))*pfphp & + & +(-4.2393e-8*pfpt+1.8932e-6)*(pfps-35.) & + & +((6.6228e-10*pfpt-6.836e-8)*pfpt+8.5258e-6)*pfpt+3.5803e-5 + END FUNCTION fsatg + + SUBROUTINE eos_rprof + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_rprof *** + !! + !! ** Purpose : Compute the in situ density of a reference profile + !! with uniform temperature and salinity. The density is + !! only a function of pressure. + !! + !! ** Method : Only neos=0 is coded + !! neos = 0 : Jackett and McDougall (1994) equation of state. + !! the in situ density is computed directly as a function of + !! potential temperature relative to the surface (the opa t + !! variable), salt and pressure (assuming no pressure variation + !! along geopotential surfaces, i.e. the pressure p in decibars + !! is approximated by the depth in meters. + !! rhoref(k) = rho(t0,s0,p(k)) + !! with pressure p decibars + !! potential temperature t deg celsius + !! salinity s psu + !! reference volumic mass rau0 kg/m**3 + !! in situ volumic mass rhor kg/m**3 + !! + !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, + !! t = 40 deg celcius, s=40 psu + !! + !! + !! ** Action : - rhor , the reference in situ density (Kg/m3) + !! + !! References : A. E. Gill, atmosphere-ocean dynamics 7.7 pp 215 + !!---------------------------------------------------------------------- + + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zh, zxk, zq, zsr, zr1, zr2, zr3, zr4 + REAL(dp) :: zp, zt, zs + REAL(wp) :: ze, zbw, zc, zd, zaw, za, zb, zb1, za1, zkw, zk0 + REAL(wp), DIMENSION(jpk) :: zwkx, zwky, zwkz + !!---------------------------------------------------------------------- + + ! Adiabatic laspse rate fsatg, defined as the change of temperature + ! per unit pressure for adiabatic change of pressure of an element + ! of seawater (bryden,h.,1973,deep-sea res.,20,401-408). + ! units: + ! pressure pfphp decibars + ! temperature pfpt deg celsius (ipts-68) + ! salinity pfps (ipss-78) + ! adiabatic fsatg deg. c/decibar + ! checkvalue: atg=3.255976e-4 c/dbar for pfps=40 (ipss-78), + ! pfpt=40 deg c, pfphp=10000 decibars + + ALLOCATE(rhoref(jpk)) + ! +!CDIR NOVERRCHK + ! + ! Computes the specific volume reference in situ temperature + + DO jk = 1, jpk + zp = 0._wp + zh = gdept_1d(jk) + zt = 0._wp + zs = 35. + zxk = zh * fsatg( zs, zt, zp ) + zt = zt + 0.5 * zxk + zq = zxk + zp = zp + 0.5 * zh + zxk = zh * fsatg( zs, zt, zp ) + zt = zt + 0.29289322 * ( zxk - zq ) + zq = 0.58578644 * zxk + 0.121320344 * zq + zxk = zh * fsatg( zs, zt, zp ) + zt = zt + 1.707106781 * ( zxk - zq ) + zq = 3.414213562 * zxk - 4.121320344 * zq + zp = zp + 0.5 * zh + zxk = zh * fsatg( zs, zt, zp ) + zwkx(jk) = zt + ( zxk - 2.0 * zq ) / 6.0 + END DO + + ! In situ density (add the compression terms) + + DO jk = 1, jpk + zt = zwkx(jk) + zs = 35. + ! square root salinity + zsr = SQRT( ABS( zs ) ) + zwky(jk) = zsr + ! compute density pure water at atm pressure + zr1 = ( ( ( ( 6.536332e-9 * zt - 1.120083e-6 ) * zt + 1.001685e-4 ) * zt & + & - 9.095290e-3 ) * zt + 6.793952e-2 ) * zt + 999.842594 + ! seawater density atm pressure + zr2 = ( ( ( 5.3875e-9 * zt - 8.2467e-7 ) * zt + 7.6438e-5 ) * zt & + & - 4.0899e-3 ) * zt + 8.24493e-1 + zr3 = ( - 1.6546e-6*zt + 1.0227e-4 ) * zt - 5.72466e-3 + zr4 = 4.8314e-4 + zwkz(jk) = ( zr4 * zs + zr3 * zsr + zr2 ) * zs + zr1 + END DO + + DO jk = 1, jpk + zt = zwkx(jk) + zs = 35. + zsr = zwky(jk) + zh = gdept_1d(jk) + + ze = ( 9.1697e-11 * zt + 2.0816e-9 ) * zt - 9.9348e-8 + zbw = ( 5.2787e-9 * zt - 6.12293e-7 ) * zt + 8.50935e-6 + zb = zbw + ze * zs + + zd = 1.91075e-4 + zc = ( -1.6078e-6 * zt - 1.0981e-5 ) * zt + 2.2838e-3 + zaw = ( ( -5.77905e-7 * zt + 1.16092e-4 ) * zt + 1.43713e-3 ) * zt + 3.239908 + za = ( zd * zsr + zc ) * zs + zaw + + zb1 = ( - 5.3009e-3 * zt + 1.6483e-1 ) * zt + 7.944e-1 + za1 = ( ( - 6.1670e-4 * zt + 1.09987e-1 ) * zt - 6.03459 ) * zt + 546.746 + zkw = ( ( ( - 5.155288e-4 * zt + 1.360477e-1 ) * zt - 23.27105 ) * zt & + & + 1484.206 ) * zt + 196522.1 + zk0 = ( zb1 * zsr + za1 ) * zs + zkw + ! evaluate pressure polynomial + zwkz(jk) = zwkz(jk) / ( 1.0 - zh / ( zk0 + zh * ( za + zb * zh ) ) ) + END DO + + DO jk = 1, jpk + rhoref(jk) = zwkz(jk) + END DO + + ! + END SUBROUTINE eos_rprof + + !!====================================================================== +END MODULE eosbn2 diff --git a/V4.0/nemo_sources/src/OCE/TRA/traadv.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8424b88344e4030c166e5e332cb896a32c8218c0 --- /dev/null +++ b/V4.0/nemo_sources/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: traadv.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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(dp), 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/V4.0/nemo_sources/src/OCE/TRA/traadv_cen.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv_cen.F90 new file mode 100644 index 0000000000000000000000000000000000000000..10738421476242855327d08d2af570a5a9c73ebb --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traadv_cen.F90 @@ -0,0 +1,214 @@ +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 + USE timing ! Timing + + 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: traadv_cen.F90 13456 2020-09-10 15:42:42Z francesca $ + !! 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptn ! now tracer fields + REAL(dp), 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 + REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztw + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_cen') + ! + 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.0_wp , ztv, 'V', -1.0_wp ) ! 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.0_wp , zwy, 'V', -1.0_wp ) + ! + CASE DEFAULT + CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) + END SELECT + ! + SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) + ! + CASE( 2 ) !* 2nd order centered + DO jk = 2, jpk + DO jj = 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( 0, 1, jpj, 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_cen') + ! + END SUBROUTINE tra_adv_cen + + !!====================================================================== +END MODULE traadv_cen \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traadv_fct.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv_fct.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f45aa25a9e416b1d77bac6cfba749d597daf8583 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traadv_fct.F90 @@ -0,0 +1,912 @@ +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) + USE timing ! Timing + USE nopenmp ! OpenMP library + + 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 + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zbetup, zbup, zbdo + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zbetdo + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_fct.F90 12055 2019-12-04 16:20:14Z jchanut $ + !! 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! OpenMP variables + REAL(dp) :: ztra ! local scalar + REAL(wp) :: zfp_ui, zfp_vj, zC2t_u, zC4t_u! - - + REAL(dp) :: zfp_wk! - - + REAL(wp) :: zC2t_v! - - + REAL(dp) :: zfm_ui, zfm_vj, zfm_wk, zC4t_v! - - + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zptry + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup + LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_fct') + ! + 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 + IF( ln_zad_Aimp ) THEN + ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) + ENDIF + ALLOCATE( zbetup(jpi,jpj,jpk), zbetdo(jpi,jpj,jpk), zbup(jpi,jpj,jpk), & + & zbdo(jpi,jpj,jpk) ) + ! + IF( ln_zad_Aimp ) THEN + IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. + END IF + ! + !$omp parallel private(ji,jj,jk,jj1,jj2,itid,ithreads,ztra, & + !$omp& zfp_ui,zfp_vj,zfp_wk,zC2t_u,zC4t_u,zfm_ui,zfm_vj,zfm_wk,zC2t_v,zC4t_v) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! ! surface & bottom value : flux set to zero one for all + zwz(:,jj1:jj2, 1 ) = 0._wp + zwx(:,jj1:jj2,jpk) = 0._wp ; zwy(:,jj1:jj2,jpk) = 0._wp ; zwz(:,jj1:jj2,jpk) = 0._wp + ! + zwi(:,jj1:jj2,:) = 0._wp + ! + ! If adaptive vertical advection, check if it is needed on this PE at this time + ! If active adaptive vertical advection, build tridiagonal matrix + IF( ll_zAimp ) THEN + DO jk = 1, jpkm1 + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zwz(ji,jj,1) = pwn(ji,jj,1) * ptb(ji,jj,1,jn) + END DO + END DO + ENDIF + ENDIF + ! + !$omp barrier + ! + DO jk = 1, jpkm1 !* trend and after field with monotonic scheme + DO jj = MAX(2,jj1), MIN(jj2,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( itid, jj1, jj2, zwdia, zwsup, zwinf, zwi, zwi , 0 ) + ! + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + ztw(ji,jj,1) = 0._wp ; ztw(ji,jj,jpk) = 0._wp ; + END DO + END DO + DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 + ! + !$omp barrier + ! + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) + ztrdx(:,jj1:jj2,:) = zwx(:,jj1:jj2,:) ; ztrdy(:,jj1:jj2,:) = zwy(:,jj1:jj2,:) ; ztrdz(:,jj1:jj2,:) = zwz(:,jj1:jj2,:) + END IF + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) zptry(:,jj1:jj2,:) = zwy(:,jj1:jj2,:) + ! + ! !== 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 = MAX(1,jj1), MIN(jj2,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 + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + zltu(ji,jj,jpk) = 0._wp ! Bottom value : flux set to zero + zltv(ji,jj,jpk) = 0._wp + END DO + END DO + DO jk = 1, jpkm1 ! Laplacian + DO jj = MAX(1,jj1), MIN(jj2,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 + !$omp barrier + DO jj = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) + !$omp end master + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal advective fluxes + DO jj = MAX(1,jj1), MIN(jj2,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 + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + ztu(ji,jj,jpk) = 0._wp ! Bottom value : flux set to zero + ztv(ji,jj,jpk) = 0._wp + END DO + END DO + DO jk = 1, jpkm1 ! 1st derivative (gradient) + DO jj = MAX(1,jj1), MIN(jj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) + !$omp end master + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal advective fluxes + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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( itid, jj1, jj2, ptn(:,jj1:jj2,:,jn) , ztw ) ! zwt = COMPACT interpolation of T at w-point + DO jk = 2, jpkm1 + DO jj = MAX(2,jj1), MIN(jj2,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 + !$omp barrier + IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0 + zwz(:,jj1:jj2,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 = MAX(2,jj1), MIN(jj2,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( itid, jj1, jj2, zwdia, zwsup, zwinf, ztw, ztw , 0 ) + ! + DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) + DO jj = MAX(2,jj1), MIN(jj2,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 + ! + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'W', 1.0_wp ) + !$omp end master + !$omp barrier + ! + ! !== monotonicity algorithm ==! + ! + CALL nonosc( itid, jj1, jj2, ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) + ! + ! !== final trend with corrected fluxes ==! + ! + DO jk = 1, jpkm1 + DO jj = MAX(2,jj1), MIN(jj2,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 + ! + DO jj = MAX(1,jj1), MIN(jj2,jpj) + DO ji = 1, jpi + ztw(ji,jj,1) = 0._wp ; ztw(ji,jj,jpk) = 0._wp + END DO + END DO + DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MAX(jj2,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 + !$omp barrier + !$omp master + 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(:,:,:) ) + ! + !$omp end master + !$omp barrier + ENDIF + IF( l_ptr ) THEN ! "Poleward" transports + !$omp barrier + !$omp master + zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes + CALL dia_ptr_hst( jn, 'adv', CASTSP(zptry(:,:,:)) ) + !$omp end master + !$omp barrier + ENDIF + ! + !$omp barrier + ! + END DO ! end of tracer loop + ! + !$omp end parallel + ! + DEALLOCATE( zbetup, zbetdo, zbup, zbdo) + IF ( ln_zad_Aimp ) 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_fct') + ! + END SUBROUTINE tra_adv_fct + + + SUBROUTINE nonosc( ktid, kj1, kj2, pbef, paa, pbb, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktid ! Thread id + INTEGER , INTENT(in ) :: kj1, kj2 ! OpenMP indicies + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field + REAL(dp), 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(dp) :: zbt, za, zb! local scalars + REAL(wp) :: zc, zpos, zneg, zrtrn! local scalars + REAL(dp) :: zbig + REAL(dp) :: zau, zbu, zav, zup, zdo! - - + REAL(wp) :: zcu, zcv! - - + REAL(dp) :: zbv + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('nonosc') + ! + zbig = 1.e+40_dp + zrtrn = 1.e-15_dp + + DO jk = 1, jpk + DO jj= MAX(1,kj1), MIN(kj2,jpj) + DO ji = 1,jpi + zbetup(ji,jj,jk) = 0._dp ; zbetdo(ji,jj,jk) = 0._dp + + ! Search local extrema + ! -------------------- + ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land + zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + ENDDO + END DO + END DO + !$omp barrier + + DO jk = 1, jpkm1 + ikm1 = MAX(jk-1,1) + DO jj = MAX(2,kj1), MIN(kj2,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 + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) + CALL lbc_lnk_multi( 'traadv_fct', zbetdo, 'T', 1.0_wp ) + !$omp end master + !$omp barrier + + ! 3. monotonic flux in the i & j direction (paa & pbb) + ! ---------------------------------------- + DO jk = 1, jpkm1 + DO jj = MAX(2,kj1), MIN(kj2,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_wp , paa(ji,jj,jk) ) ) + paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) + + zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) + zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) + zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) + pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) + + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + za = MIN( 1.0_wp, zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) + zb = MIN( 1.0_wp, zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) + zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) + pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) + END DO + END DO + END DO + !$omp barrier + !$omp master + CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign) + !$omp end master + !$omp barrier + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('nonosc') + ! + 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('interp_4th_cpt_org') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('interp_4th_cpt_org') + ! + END SUBROUTINE interp_4th_cpt_org + + + SUBROUTINE interp_4th_cpt( ktid, kj1, kj2, pt_in, pt_out ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp_4th_cpt *** + !! + !! ** Purpose : Compute the interpolation of tracer at w-point + !! + !! ** Method : 4th order compact interpolation + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! OpenMP variables + REAL(dp),DIMENSION(jpi,kj1:kj2,jpk), INTENT(in ) :: pt_in ! field at t-point + REAL(dp),DIMENSION(jpi,kj1:kj2,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,kj1:kj2,jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + ! + ! !== build the three diagonal matrix & the RHS ==! + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('interp_4th_cpt') + ! + DO jk = 3, jpkm1 ! interior (from jk=3 to jpk-1) + DO jj = MAX(2,kj1), MIN(kj2,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(:,kj1:kj2,2) = 1._wp ; zwi(:,kj1:kj2,2) = 0._wp ; zws(:,kj1:kj2,2) = 0._wp ; zwrm(:,kj1:kj2,2) = 0._wp + END IF + ! + DO jj = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('interp_4th_cpt') + ! + END SUBROUTINE interp_4th_cpt + + + SUBROUTINE tridia_solver( ktid, kj1, kj2, 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. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! OpenMP variables + REAL(wp),DIMENSION(:,:,:), INTENT(in ) :: pD, pU, pL ! 3-diagonal matrix + REAL(dp),DIMENSION(:,:,:), INTENT(in ) :: pRHS ! Right-Hand-Side + REAL(dp),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,kj1:kj2,jpk) :: zwt ! 3D work array + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('tridia_solver') + ! + kstart = 1 + klev + ! + DO jj = MAX(2,kj1), MIN(kj1,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 = MAX(2,kj1), MIN(kj1,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 = MAX(2,kj1), MIN(kj1,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 = MAX(2,kj1), MIN(kj1,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 = MAX(2,kj1), MIN(kj1,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 = MAX(2,kj1), MIN(kj1,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 + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('tridia_solver') + ! + END SUBROUTINE tridia_solver + + !!====================================================================== +END MODULE traadv_fct diff --git a/V4.0/nemo_sources/src/OCE/TRA/traadv_mus.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv_mus.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1a80898bd49d123cb7283a5bfa5a3f3bb73bab2c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traadv_mus.F90 @@ -0,0 +1,282 @@ +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) + USE timing ! Timing + + 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: traadv_mus.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before tracer field + REAL(dp), 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( ln_timing_detail ) CALL timing_start('tra_adv_mus') + ! + 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.0_wp , zwy, 'V', -1.0_wp ) + ! !-- 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_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) + zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) + END DO + END DO + END DO + ! + DO jk = 1, jpkm1 !-- Slopes limitation + DO jj = 2, jpj + DO ji = fs_2, jpi ! vector opt. + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & + & 2.*ABS( zwx (ji-1,jj,jk) ), & + & 2.*ABS( zwx (ji ,jj,jk) ) ) + zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & + & 2.*ABS( zwy (ji,jj-1,jk) ), & + & 2.*ABS( zwy (ji,jj ,jk) ) ) + END DO + END DO + END DO + ! + 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_wp, 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_wp, 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.0_wp , zwy, 'V', -1.0_wp ) ! 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_wp, 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.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & + & 2.*ABS( zwx (ji,jj,jk+1) ), & + & 2.*ABS( zwx (ji,jj,jk ) ) ) + END DO + END DO + END DO + DO jk = 1, jpk-2 !-- vertical advective flux + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z0w = SIGN( 0.5_wp, 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_mus') + ! + END SUBROUTINE tra_adv_mus + + !!====================================================================== +END MODULE traadv_mus \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traadv_qck.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv_qck.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a43db9a0798eb23b18f20d984fb5e69ea06b739b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traadv_qck.F90 @@ -0,0 +1,479 @@ +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) + USE timing ! Timing + + 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: traadv_qck.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_qck') + ! + 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 ) + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_qck') + ! + 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun ! i-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(dp), 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 + !---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_qck_i') + ! + ! ! =========== + 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.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! 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_wp, 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_wp, 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.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) + + !--- QUICKEST scheme + CALL quickest( zfu, zfd, zfc, zwx ) + ! + ! 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.0_wp ) ! 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_wp, 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.0_wp ) ! 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_qck_i') + ! + 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pvn ! j-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(dp), 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 + !---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_qck_j') + ! + ! ! =========== + 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.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! 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_wp, 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_wp, 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.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) + + !--- QUICKEST scheme + CALL quickest( zfu, zfd, zfc, zwy ) + ! + ! 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.0_wp ) !--- 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_wp, 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.0_wp ) ! 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_qck_j') + ! + 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pwn ! vertical velocity + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptn ! before and now tracer fields + REAL(dp), 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_cen2_k') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_cen2_k') + ! + 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 ! - - + !---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('quickest') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('quickest') + ! + END SUBROUTINE quickest + + !!====================================================================== +END MODULE traadv_qck \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traadv_ubs.F90 b/V4.0/nemo_sources/src/OCE/TRA/traadv_ubs.F90 new file mode 100644 index 0000000000000000000000000000000000000000..efced78eb4f8b39d52e1f3b1c7a0b2e4cf3f839f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traadv_ubs.F90 @@ -0,0 +1,389 @@ +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) + USE timing ! Timing + + 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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_ubs.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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, 1731D1741. + !!---------------------------------------------------------------------- + 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean transport components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(dp), 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! 3D workspace + REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztw! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_adv_ubs') + ! + 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.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! 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.0_wp ) ! 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( CASTSP(ptb(:,:,:,jn)), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( 0, 1, jpj, CASTDP(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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_adv_ubs') + ! + 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(dp), 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, zrtrn ! local scalars + REAL(dp) :: zbig + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('nonosc_z') + ! + zbig = 1.e+38_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.0_wp, pcc(ji,jj,jk) ) ) + pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) + END DO + END DO + END DO + ! + IF( ln_timing_detail ) CALL timing_stop('nonosc_z') + ! + END SUBROUTINE nonosc_z + + !!====================================================================== +END MODULE traadv_ubs diff --git a/V4.0/nemo_sources/src/OCE/TRA/trabbc.F90 b/V4.0/nemo_sources/src/OCE/TRA/trabbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6cea1b4a556418595b35e5dcb0b00ce33bd9d6b8 --- /dev/null +++ b/V4.0/nemo_sources/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: trabbc.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! 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.0_wp ) + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/trabbl.F90 b/V4.0/nemo_sources/src/OCE/TRA/trabbl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8153da8109d3cd6707a0c05314a1883cd65fe099 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/trabbl.F90 @@ -0,0 +1,563 @@ +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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trabbl.F90 13646 2020-10-20 15:33:01Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION tra_bbl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION tra_bbl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( utr_bbl (jpi,jpj) , ahu_bbl (jpi,jpj) , mbku_d(jpi,jpj) , mgrhu(jpi,jpj) , & + & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d(jpi,jpj) , mgrhv(jpi,jpj) , & + & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & + & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) + ! + CALL mpp_sum ( 'trabbl', tra_bbl_alloc ) + IF( tra_bbl_alloc > 0 ) CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.') + END FUNCTION tra_bbl_alloc + + + SUBROUTINE tra_bbl( kt ) + !!---------------------------------------------------------------------- + !! *** 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.0_wp , ahv_bbl, 'V', 1.0_wp ) + 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.0_wp , vtr_bbl, 'V', 1.0_wp ) + 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(dp), 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(dp), 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) :: zab! 3D workspace + REAL(dp), DIMENSION(jpi,jpj,jpts) :: zts! 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( CASTSP(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_wp, -zgdrho * REAL( mgrhu(ji,jj), wp ) ) ! sign of ( i-gradient * i-slope ) + ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhv(ji,jj), wp ) ) ! 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_wp, - zgdrho * REAL( mgrhu(ji,jj), wp ) ) ! sign of i-gradient * i-slope + zsigna= SIGN( 0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj), wp ) ) ! sign of u * i-slope + ! + ! ! bbl velocity + utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhv(ji,jj), wp ) ) ! sign of j-gradient * j-slope + zsigna= SIGN( 0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj), wp ) ) ! 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.0_wp, zmbkv,'V',1.0_wp) + mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) + ! + ! !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 + mgrhu(:,:) = 0 ; mgrhv(:,:) = 0 + DO jj = 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.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + ! + IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN + mgrhv(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + END DO + END DO + ! + DO jj = 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.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions + ! + ! !* masked diffusive flux coefficients + ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) + ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) + ! + END SUBROUTINE tra_bbl_init + + !!====================================================================== +END MODULE trabbl \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/tradmp.F90 b/V4.0/nemo_sources/src/OCE/TRA/tradmp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c1daf3e8c0550180f7b2c58b5747b01600fc47d0 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/tradmp.F90 @@ -0,0 +1,246 @@ +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 + USE lbclnk ! For halo exchange + + 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: tradmp.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp), DIMENSION(jpi,jpj,jpk,jpts) :: zts_dta + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: ztsrdmp + 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 + ! + ! Initialize array to output restoration terms + ! + ztsrdmp(:,:,:,:) = 0.0_wp + ! + 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. + ztsrdmp(ji,jj,jk,jn) = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - tsb(ji,jj,jk,jn) ) + tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsrdmp(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 + ztsrdmp(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_tem) = tsa(ji,jj,jk,jp_tem) + ztsrdmp(ji,jj,jk,jp_tem) + ztsrdmp(ji,jj,jk,jp_sal) = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + ztsrdmp(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 + ztsrdmp(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_tem) = tsa(ji,jj,jk,jp_tem) + ztsrdmp(ji,jj,jk,jp_tem) + ztsrdmp(ji,jj,jk,jp_sal) = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + ztsrdmp(ji,jj,jk,jp_sal) + ENDIF + END DO + END DO + END DO + ! + END SELECT + ! + ! XIOS output + ! + IF( iom_use('thetaodmp') ) THEN + CALL lbc_lnk( 'tra_dmp', ztsrdmp(:,:,:,jp_tem), 'T', 1.0_wp ) + CALL iom_put( 'thetaodmp', ztsrdmp(:,:,:,jp_tem) ) + ENDIF + IF( iom_use('sodmp') ) THEN + CALL lbc_lnk( 'tra_dmp', ztsrdmp(:,:,:,jp_sal), 'T', 1.0_wp ) + CALL iom_put( 'sodmp', ztsrdmp(:,:,:,jp_sal) ) + ENDIF + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traldf.F90 b/V4.0/nemo_sources/src/OCE/TRA/traldf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c0b226ed0446619f8ff2eadbc8edd5051576a1ee --- /dev/null +++ b/V4.0/nemo_sources/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: traldf.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traldf_iso.F90 b/V4.0/nemo_sources/src/OCE/TRA/traldf_iso.F90 new file mode 100644 index 0000000000000000000000000000000000000000..25611d3b431c8f1659ed6b423db8acc477422bdc --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traldf_iso.F90 @@ -0,0 +1,427 @@ +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) + USE timing ! Timing + USE nopenmp ! OpenMP library + + 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: traldf_iso.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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! tracer gradient at pstep levels + REAL(dp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgv! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptbb ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! OpenMP variables + 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,jpk) :: zdkt, zdk1t + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('tra_ldf_iso') + ! + 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. + ! + !$omp parallel private(ji,jj,jk,jn,ikt,ierr,jj1,jj2,itid,ithreads, & + !$omp& zmsku,zahu_w,zabe1,zcof1,zcoef3,zmskv,zahv_w,zabe2,zcof2,zcoef4, & + !$omp& zcoef0,ze3w_2,zsign,z2dt,z1_2dt) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! + ! ! 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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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(:,jj1:jj2,:) = ah_wslp2(:,jj1:jj2,:) + ENDIF + ENDIF + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + !$omp barrier + ! + !!---------------------------------------------------------------------- + !! I - masked horizontal derivative + !!---------------------------------------------------------------------- +!! Var has not been initialized +! REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw + zdit(:,jj1:jj2,:) = 0._wp + zdjt(:,jj1:jj2,:) = 0._wp + zftu(:,jj1:jj2,:) = 0._wp + zftv(:,jj1:jj2,:) = 0._wp + ztfw(:,jj1:jj2,:) = 0._wp + +!!gm : bug.... why (x,:,:)? (1,jpj,:) and (jpi,1,:) should be sufficient.... + zdit (1,jj1:jj2,:) = 0._wp ; zdit (jpi,jj1:jj2,:) = 0._wp + zdjt (1,jj1:jj2,:) = 0._wp ; zdjt (jpi,jj1:jj2,:) = 0._wp + !!end + + ! Horizontal tracer gradient + DO jk = 1, jpkm1 + DO jj = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MAX(jj2,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(:,jj1:jj2,jk) = ( ptb(:,jj1:jj2,jk,jn) - ptb(:,jj1:jj2,jk+1,jn) ) * wmask(:,jj1:jj2,jk+1) ! level jk+1 + ! + IF( jk == 1 ) THEN ; zdkt(:,jj1:jj2,jk) = zdk1t(:,jj1:jj2,jk) ! surface: zdkt(jk=1)=zdkt(jk=2) + ELSE ; zdkt(:,jj1:jj2,jk) = ( ptb(:,jj1:jj2,jk-1,jn) - ptb(:,jj1:jj2,jk,jn) ) * wmask(:,jj1:jj2,jk) + ENDIF + END DO + ! + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(1,jj1), MIN(jj2,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,jk) + zdk1t(ji,jj,jk) & + & + zdk1t(ji+1,jj,jk) + zdkt (ji,jj,jk) ) ) * umask(ji,jj,jk) + zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & + & + zcof2 * ( zdkt (ji,jj+1,jk) + zdk1t(ji,jj,jk) & + & + zdk1t(ji,jj+1,jk) + zdkt (ji,jj,jk) ) ) * vmask(ji,jj,jk) + END DO + END DO + ENDDO + ! + !$omp barrier + ! + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = MAX(2,jj1) , MIN(jj2,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,jj1:jj2,:) = 0._wp ; ztfw(jpi:fs_jpim1,jj1:jj2,:) = 0._wp ! avoid to potentially manipulate NaN values + ! + ! Vertical fluxes + ! --------------- + ! ! Surface and bottom vertical fluxes set to zero + ztfw(:,jj1:jj2, 1 ) = 0._wp ; ztfw(:,jj1:jj2,jpk) = 0._wp + ! + DO jk = 2, jpkm1 ! interior (2=<jk=<jpk-1) + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 ) THEN + !$omp barrier + !$omp master + CALL dia_ptr_hst( jn, 'ldf', -zftv(:,:,:) ) + !$omp end master + !$omp barrier + ENDIF + ! ! Diffusive heat transports + ! + ENDIF !== end pass selection ==! + ! + ! ! =============== + ! + END DO ! end tracer loop + ! + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('tra_ldf_iso') + ! + END SUBROUTINE tra_ldf_iso + + !!============================================================================== +END MODULE traldf_iso \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traldf_lap_blp.F90 b/V4.0/nemo_sources/src/OCE/TRA/traldf_lap_blp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..195f52cc8b4875fdbc55f34a320ccd119a876d42 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traldf_lap_blp.F90 @@ -0,0 +1,245 @@ +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: traldf_lap_blp.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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! tracer gradient at pstep levels + REAL(dp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgv! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(dp), 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( ln_timing_detail ) CALL timing_start('tra_ldf_lap') + ! + 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 + ! ! ================== + ! + IF( ln_timing_detail ) CALL timing_stop('tra_ldf_lap') + ! + 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! tracer gradient at pstep levels + REAL(dp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgv! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point + REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zglu! bottom GRADh of the laplacian (u- and v-points) + REAL(dp), DIMENSION(jpi,jpj, kjpt) :: 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( ln_timing_detail ) CALL timing_start('tra_ldf_blp') + ! + 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.0_wp ) ! 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 + ! + IF( ln_timing_detail ) CALL timing_stop('tra_ldf_blp') + ! + END SUBROUTINE tra_ldf_blp + + !!============================================================================== +END MODULE traldf_lap_blp \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traldf_triad.F90 b/V4.0/nemo_sources/src/OCE/TRA/traldf_triad.F90 new file mode 100644 index 0000000000000000000000000000000000000000..17adf2f5a81e03eb07465a00b5cb476fb54bb913 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traldf_triad.F90 @@ -0,0 +1,439 @@ +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 + USE timing ! Timing + + 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: traldf_triad.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! 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! tracer gradient at pstep levels + REAL(dp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgv! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptbb ! tracer (only used in kpass=2) + REAL(dp), 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( ln_timing_detail ) CALL timing_start('tra_ldf_triad') + ! + 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 + ! ! =============== + ! + IF( ln_timing_detail ) CALL timing_stop('tra_ldf_triad') + ! + END SUBROUTINE tra_ldf_triad + + !!============================================================================== +END MODULE traldf_triad \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/tramle.F90 b/V4.0/nemo_sources/src/OCE/TRA/tramle.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dcabd06e16a9b690375c79e1a7c3fdd3ae4ffb97 --- /dev/null +++ b/V4.0/nemo_sources/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: tramle.F90 14211 2020-12-18 10:04:16Z mathiot $ + !! 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport + ! + 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 * wumask(ji,jj,jk) * wumask(ji,jj,1) + zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * wvmask(ji,jj,jk) * wvmask(ji,jj,1) + END DO + END DO + END DO + ! + ! !== transport increased by the MLE induced transport ==! + DO jk = 1, ikmax + DO jj = 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) ) * wmask(ji,jj,1) + 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.0_wp , rfv, 'V', 1.0_wp ) + ! + ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation + rc_f = rn_ce / ( 5.e3_wp * 2._wp * omega * SIN( rad * rn_lat ) ) + ! + ENDIF + ! + ! ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_mle case) + ALLOCATE( r1_ft(jpi,jpj) , STAT= ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate r1_ft array' ) + ! + z1_t2 = 1._wp / ( rn_time * rn_time ) + r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) + ! + ENDIF + ! + END SUBROUTINE tra_mle_init + + !!============================================================================== +END MODULE tramle \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/tranpc.F90 b/V4.0/nemo_sources/src/OCE/TRA/tranpc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..40d08aa4187f4211d6821ed79c68b2c53d3dd936 --- /dev/null +++ b/V4.0/nemo_sources/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: tranpc.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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.0_wp, tsa(:,:,:,jp_sal), 'T', 1.0_wp ) + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/tranxt.F90 b/V4.0/nemo_sources/src/OCE/TRA/tranxt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..aae313b15716a8dcb5a2d3dcb93e3344eb7b4b58 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/tranxt.F90 @@ -0,0 +1,401 @@ +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 + USE nopenmp ! OpenMP library +#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 + + ! trddyn variables needs to be here to make them visible to all + ! OpenMP threads + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tranxt.F90 12366 2020-02-11 11:17:24Z jchanut $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! OpenMP variables + 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.0_wp, tsa(:,:,:,jp_sal), 'T', 1.0_wp ) + ! + 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(:,:,:) = 0._wp + ztrds(:,:,:) = 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 + ! + !$omp parallel private(jj1,jj2,itid,ithreads) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + IF( ln_linssh ) THEN ; CALL tra_nxt_fix( itid, jj1, jj2, kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! linear free surface + ELSE ; CALL tra_nxt_vvl( itid, jj1, jj2, kt, nit000, rdt, 'TRA', tsb, tsn, tsa, & + & sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + !$omp end parallel + ! + CALL lbc_lnk_multi( 'tranxt', tsb(:,:,:,jp_tem), 'T', 1.0_wp, tsb(:,:,:,jp_sal), 'T', 1.0_wp, & + & tsn(:,:,:,jp_tem), 'T', 1.0_wp, tsn(:,:,:,jp_sal), 'T', 1.0_wp, & + & tsa(:,:,:,jp_tem), 'T', 1.0_wp, tsa(:,:,:,jp_sal), 'T', 1.0_wp ) + ! + 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( ktid, kj1, kj2, 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 ) :: ktid ! thread id + INTEGER , INTENT(in ) :: kj1, kj2 ! openmp indices + 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptb ! before tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptn ! now tracer fields + REAL(dp), 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 .and. ktid == 1 ) 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 = MAX(2,kj1), MIN(kj2,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( ktid, kj1, kj2, 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 ) :: ktid ! thread id + INTEGER , INTENT(in ) :: kj1, kj2 ! openmp indices + 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptb ! before tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptn ! now tracer fields + REAL(dp), 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_d! local scalar + REAL(dp) :: ztc_a, ztc_n, ztc_b, ztc_f! local scalar + REAL(wp) :: zfact2, ze3t_b, ze3t_a, ze3t_d, zscale! - - + REAL(dp) :: ze3t_f, ze3t_n! - - + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 .AND. ktid == 0 ) 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 + !$omp barrier + !$omp master + ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) + !$omp end master + !$omp barrier + ztrd_atf(:,kj1:kj2,:,:) = 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 = MAX(2,kj1), MIN(kj2,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 + !$omp barrier + !$omp master + 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 ) + !$omp end master + !$omp barrier + ENDIF + ! + END SUBROUTINE tra_nxt_vvl + + !!====================================================================== +END MODULE tranxt \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/traqsr.F90 b/V4.0/nemo_sources/src/OCE/TRA/traqsr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..12e676b4c4f7f5a745b12b701fa9db2e56a1cdff --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/traqsr.F90 @@ -0,0 +1,458 @@ +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 + USE nopenmp ! OpenMP library + + 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: traqsr.F90 13331 2020-07-22 14:00:04Z cetlod $ + !! 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 :: jj1, jj2, itid, ithreads ! openmp variables + 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) :: zekb, zekg, zekr + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, zchl3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot + !!---------------------------------------------------------------------- + ! + 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,*) '~~~~~~~' + ALLOCATE( ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , & + & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) + 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 + ! + zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B + zz0 = rn_abs * r1_rau0_rcp ! surface equi-partition in 2-bands + zz1 = ( 1. - rn_abs ) * r1_rau0_rcp + ! + !$omp parallel private(ji,jj,jk,jj1,jj2,itid,ithreads, & + !$omp& zchl,zCtot,zze,zpsi,zlogc,zlogc2,zlogc3,zCb,ZCmax,zpsimax, & + !$omp& zdelpsi,zCze,irgb,zc0,zc1,zc2,zc3,zekb,zekg,zekr) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! !--------------------------------! + SELECT CASE( nqsr ) ! now qsr induced heat content ! + ! !--------------------------------! + ! + CASE( np_BIO ) !== bio-model fluxes ==! + ! + DO jk = 1, nksr + qsr_hc(:,jj1:jj2,jk) = r1_rau0_rcp * ( etot3(:,jj1:jj2,jk) - etot3(:,jj1:jj2,jk+1) ) + END DO + ! + CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! + ! + ! + IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll + !$omp barrier + !$omp master + CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step + !$omp end master + !$omp barrier + DO jk = 1, nksr + 1 + DO jj = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2,jk) = 0.05 + ENDDO + ENDIF + ! + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = rkrgb(1,irgb) + zekg = rkrgb(2,irgb) + zekr = rkrgb(3,irgb) + 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 ) + zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg ) + zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr ) + 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 = MAX(2,jj1), MIN(jj2,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 + ! + CASE( np_2BD ) !== 2-bands fluxes ==! + ! + DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m + DO jj = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,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 = MAX(2,jj1), MIN(jj2,jpjm1) + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( (r1_rau0_rcp * 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 + ! + !$omp end parallel + ! + 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( kt == nitend ) THEN + DEALLOCATE( ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) + ENDIF + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/trasbc.F90 b/V4.0/nemo_sources/src/OCE/TRA/trasbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..39b653787fd00f4850145ff07a46cb31e1668636 --- /dev/null +++ b/V4.0/nemo_sources/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: trasbc.F90 10499 2019-01-10 15:12:24Z deazer $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/trazdf.F90 b/V4.0/nemo_sources/src/OCE/TRA/trazdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ac52fdc537273222055bf7db87d95c89557a02f6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/trazdf.F90 @@ -0,0 +1,292 @@ +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 + USE nopenmp ! OpenMP library + + 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: trazdf.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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 + INTEGER :: jj1, jj2, itid, ithreads ! OpenMP variables + 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 + ! + !$omp parallel private(jk,jj1,jj2,itid,ithreads) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! !* compute lateral mixing trend and add it to the general trend + CALL tra_zdf_imp( itid, jj1, jj2, 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(:,jj1:jj2,:,jp_sal) < 0._wp ) tsa(:,jj1:jj2,:,jp_sal) = 0.1_wp +!!gm + ! + !$omp end parallel + ! + 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.0_wp , ztrds, 'T', 1.0_wp ) +!!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 +# if ! defined key_single + ! ! 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' ) +# endif + ! + IF( ln_timing ) CALL timing_stop('tra_zdf') + ! + END SUBROUTINE tra_zdf + + + SUBROUTINE tra_zdf_imp( ktid, kj1, kj2, 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 ) :: ktid ! Thread id + INTEGER , INTENT(in ) :: kj1, kj2 ! OpenMP indicies + 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(dp), 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) :: zzwi, zzws! local scalars + REAL(dp) :: zrhs! local scalars + REAL(dp), DIMENSION(jpi,kj1:kj2,jpk) :: zwi, zwt, zwd + REAL(wp), DIMENSION(jpi,kj1:kj2,jpk) :: zws + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('tra_zdf_imp') + ! + ! ! ============= ! + 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(:,kj1:kj2,2:jpk) = avt(:,kj1:kj2,2:jpk) + ELSE ; zwt(:,kj1:kj2,2:jpk) = avs(:,kj1:kj2,2:jpk) + ENDIF + zwt(:,kj1:kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 ! + ! ! ================= ! + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('tra_zdf_imp') + ! + END SUBROUTINE tra_zdf_imp + + !!============================================================================== +END MODULE trazdf \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRA/zpshde.F90 b/V4.0/nemo_sources/src/OCE/TRA/zpshde.F90 new file mode 100644 index 0000000000000000000000000000000000000000..da5b0d4f77271a8bc3e11e4be381a46ccdb048e4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRA/zpshde.F90 @@ -0,0 +1,466 @@ +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 "single_precision_substitute.h90" +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zpshde.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu! hor. grad. of ptra at u- & v-pts + REAL(dp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtv! hor. grad. of ptra at u- & v-pts + REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(dp), 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) :: ze3wv, zmaxu! local scalars + REAL(dp) :: ze3wu, zmaxv! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(dp), 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', pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp ) + ! + 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( CASTSP(zti), zhi, zri ) ! interpolated density from CASTSP(zti), ztj + CALL eos( CASTSP(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.0_wp , pgrv , 'V', -1.0_wp ) ! 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu! hor. grad. of ptra at u- & v-pts + REAL(dp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(dp), 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', pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp ) + + ! 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.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + ! !== (ISH) compute grui and gruvi ==! + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! + DO jj = 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.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + ! + pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; + DO jj = 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.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf + + !!====================================================================== +END MODULE zpshde diff --git a/V4.0/nemo_sources/src/OCE/TRD/trd_oce.F90 b/V4.0/nemo_sources/src/OCE/TRD/trd_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e759158d7647b5684df1caf45c17fbd6c79abe29 --- /dev/null +++ b/V4.0/nemo_sources/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: trd_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trd_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trddyn.F90 b/V4.0/nemo_sources/src/OCE/TRD/trddyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..938c4c3243c64af441b5e955a1af210dd14f38b6 --- /dev/null +++ b/V4.0/nemo_sources/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: trddyn.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), 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(dp), 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.0_wp, z3dy, 'V', -1.0_wp ) + CALL iom_put( "utrd_udx", z3dx ) + CALL iom_put( "vtrd_vdy", z3dy ) + DEALLOCATE( z3dx , z3dy ) + CASE( jpdyn_zad ) ; CALL iom_put( "utrd_zad", putrd ) ! vertical advection + CALL iom_put( "vtrd_zad", pvtrd ) + CASE( jpdyn_ldf ) ; CALL iom_put( "utrd_ldf", putrd ) ! lateral diffusion + CALL iom_put( "vtrd_ldf", pvtrd ) + CASE( jpdyn_zdf ) ; CALL iom_put( "utrd_zdf", putrd ) ! vertical diffusion + CALL iom_put( "vtrd_zdf", pvtrd ) + ! + ! ! wind stress trends + ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) ) + z2dx(:,:) = ( utau_b(:,:) + utau(:,:) ) / ( e3u_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.0_wp, z3dy, 'V', -1.0_wp ) +! CALL iom_put( "utrd_bfr", z3dx ) +! CALL iom_put( "vtrd_bfr", z3dy ) +! DEALLOCATE( z3dx , z3dy ) +! ENDIF +!!gm end + CASE( jpdyn_bfr ) ! called if ln_drgimp=F + CALL iom_put( "utrd_bfr", putrd ) ! bottom friction (explicit case) + CALL iom_put( "vtrd_bfr", pvtrd ) + CASE( jpdyn_atf ) ; CALL iom_put( "utrd_atf", putrd ) ! asselin filter trends + CALL iom_put( "vtrd_atf", pvtrd ) + END SELECT + ! + END SUBROUTINE trd_dyn_iom + + !!====================================================================== +END MODULE trddyn \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdglo.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdglo.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b1633205b969abea5a141112eb18825976f8aeca --- /dev/null +++ b/V4.0/nemo_sources/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: trdglo.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + CHARACTER(len=3) , INTENT(in ) :: ctype ! momentum or tracers trends type (='DYN'/'TRA') + INTEGER , INTENT(in ) :: kt ! time step + !! + INTEGER :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdini.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..31d4909fe75bba05bcc6378729610a1812bcb6fe --- /dev/null +++ b/V4.0/nemo_sources/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: trdini.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdken.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdken.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5c9f1bc7b1a7bdfe3994bc2bcb520c6a9d91b848 --- /dev/null +++ b/V4.0/nemo_sources/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: trdken.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), 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.0_wp , pvtrd, 'V', -1.0_wp ) ! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdmxl.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdmxl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..72367e219e2a5f6531c7f76b0cd7cfe11bf5f797 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRD/trdmxl.F90 @@ -0,0 +1,872 @@ +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 + + !! * Substitutions +# include "single_precision_substitute.h90" + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) +!!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(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pttrdmxl ! temperature trend + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pstrdmxl ! salinity trend + ! + INTEGER :: ji, jj, jk, isum + REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk + !!---------------------------------------------------------------------- + + ! I. Definition of control surface and associated fields + ! ------------------------------------------------------ + ! ==> only once per time step <== + + IF( icount == 1 ) THEN + ! + +!!gm BUG? +!!gm CAUTION: double check the definition of nmln it is the nb of w-level, not t-level I guess + + + ! ... Set nmxl(ji,jj) = index of first T point below control surf. or outside mixed-layer + IF( nn_ctls == 0 ) THEN ! * control surface = mixed-layer with density criterion + nmxl(:,:) = nmln(:,:) ! array nmln computed in zdfmxl.F90 + ELSEIF( nn_ctls == 1 ) THEN ! * control surface = read index from file + nmxl(:,:) = nbol(:,:) + ELSEIF( nn_ctls >= 2 ) THEN ! * control surface = model level + nn_ctls = MIN( nn_ctls, jpktrd - 1 ) + nmxl(:,:) = nn_ctls + 1 + ENDIF + + END IF + ! + END SUBROUTINE trd_mxl_zint + + + SUBROUTINE trd_mxl( kt, p2dt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl *** + !! + !! ** Purpose : Compute and cumulate the mixed layer trends over an analysis + !! period, and write NetCDF outputs. + !! + !! ** Method/usage : + !! The stored trends can be chosen twofold (according to the ln_trdmxl_instant + !! logical namelist variable) : + !! 1) to explain the difference between initial and final + !! mixed-layer T & S (where initial and final relate to the + !! current analysis window, defined by nn_trd in the namelist) + !! 2) to explain the difference between the current and previous + !! TIME-AVERAGED mixed-layer T & S (where time-averaging is + !! performed over each analysis window). + !! + !! ** Consistency check : + !! If the control surface is fixed ( nn_ctls > 1 ), the residual term (dh/dt + !! entrainment) should be zero, at machine accuracy. Note that in the case + !! of time-averaged mixed-layer fields, this residual WILL NOT BE ZERO + !! over the first two analysis windows (except if restart). + !! N.B. For ORCA2_ICE, use e.g. nn_trd=5, rn_ucf=1., nn_ctls=8 + !! for checking residuals. + !! On a NEC-SX5 computer, this typically leads to: + !! O(1.e-20) temp. residuals (tml_res) when ln_trdmxl_instant=.false. + !! O(1.e-21) temp. residuals (tml_res) when ln_trdmxl_instant=.true. + !! + !! ** Action : + !! At each time step, mixed-layer averaged trends are stored in the + !! tmltrd(:,:,jpmxl_xxx) array (see trdmxl_oce.F90 for definitions of jpmxl_xxx). + !! This array is known when trd_mxl is called, at the end of the stp subroutine, + !! except for the purely vertical K_z diffusion term, which is embedded in the + !! lateral diffusion trend. + !! + !! In I), this K_z term is diagnosed and stored, thus its contribution is removed + !! from the lateral diffusion trend. + !! In II), the instantaneous mixed-layer T & S are computed, and misc. cumulative + !! arrays are updated. + !! In III), called only once per analysis window, we compute the total trends, + !! along with the residuals and the Asselin correction terms. + !! In IV), the appropriate trends are written in the trends NetCDF file. + !! + !! References : Vialard et al.,2001, JPO. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + REAL(wp), INTENT(in ) :: p2dt ! time step [s] + ! + INTEGER :: ji, jj, jk, jl, ik, it, itmod + LOGICAL :: lldebug = .TRUE. + REAL(wp) :: zavt, zfn, zfn2 + ! ! z(ts)mltot : dT/dt over the anlysis window (including Asselin) + ! ! z(ts)mlres : residual = dh/dt entrainment term + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics + !!---------------------------------------------------------------------- + + ! ====================================================================== + ! II. Cumulate the trends over the analysis window + ! ====================================================================== + + ztmltrd2(:,:,:) = 0.e0 ; zsmltrd2(:,:,:) = 0.e0 ! <<< reset arrays to zero + ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 + ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 + ztmlatf2(:,:) = 0.e0 ; zsmlatf2(:,:) = 0.e0 + + ! II.1 Set before values of vertically average T and S + ! ---------------------------------------------------- + IF( kt > nit000 ) THEN + ! ... temperature ... ... salinity ... + tmlb (:,:) = tml (:,:) ; smlb (:,:) = sml (:,:) + tmlatfn(:,:) = tmltrd(:,:,jpmxl_atf) ; smlatfn(:,:) = smltrd(:,:,jpmxl_atf) + END IF + + + ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window + ! ------------------------------------------------------------------------ + IF( kt == 2 ) THEN ! i.e. ( .NOT. ln_rstart ).AND.( kt == nit000 + 1) + ! + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + tmltrd_csum_ub (:,:,:) = 0.e0 ; smltrd_csum_ub (:,:,:) = 0.e0 + tmltrd_atf_sumb(:,:) = 0.e0 ; smltrd_atf_sumb(:,:) = 0.e0 + + hmxlbn(:,:) = hmxl(:,:) + + IF( 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=CASTDP(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.0_wp, zsmltot , 'T', 1.0_wp, & + & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & + & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) + + + ! III.2 Prepare fields for output ("mean" diagnostics) + ! ---------------------------------------------------- + + !-- Update the ML depth time sum (to build the Leap-Frog time mean) + hmxl_sum(:,:) = hmxlbn(:,:) + 2 * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:) + + !-- Compute temperature total trends + tml_sum (:,:) = tmlbn(:,:) + 2 * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:) + ztmltot2(:,:) = ( tml_sum(:,:) - tml_sumb(:,:) ) / p2dt ! now in degC/s + + !-- Compute salinity total trends + sml_sum (:,:) = smlbn(:,:) + 2 * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:) + zsmltot2(:,:) = ( sml_sum(:,:) - sml_sumb(:,:) ) / p2dt ! now in psu/s + + !-- Compute temperature residuals + DO jl = 1, jpltrd + ztmltrd2(:,:,jl) = tmltrd_csum_ub(:,:,jl) + tmltrd_csum_ln(:,:,jl) + END DO + + ztmltrdm2(:,:) = 0.e0 + DO jl = 1, jpltrd + ztmltrdm2(:,:) = ztmltrdm2(:,:) + ztmltrd2(:,:,jl) + END DO + + ztmlres2(:,:) = ztmltot2(:,:) - & + ( ztmltrdm2(:,:) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) ) + + !-- Compute salinity residuals + DO jl = 1, jpltrd + zsmltrd2(:,:,jl) = smltrd_csum_ub(:,:,jl) + smltrd_csum_ln(:,:,jl) + END DO + + zsmltrdm2(:,:) = 0. + DO jl = 1, jpltrd + zsmltrdm2(:,:) = zsmltrdm2(:,:) + zsmltrd2(:,:,jl) + END DO + + zsmlres2(:,:) = zsmltot2(:,:) - & + ( zsmltrdm2(:,:) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf2(:,:) = ztmltrd2(:,:,jpmxl_atf) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) + zsmlatf2(:,:) = zsmltrd2(:,:,jpmxl_atf) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) + + !-- Lateral boundary conditions + ! ... temperature ... ... salinity ... + CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & + & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) + ! + CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file + + ! III.3 Time evolution array swap + ! ------------------------------- + + ! For T/S instantaneous diagnostics + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + ! For T mean diagnostics + tmltrd_csum_ub (:,:,:) = zfn * tmltrd_sum(:,:,:) - tmltrd_csum_ln(:,:,:) + tml_sumb (:,:) = tml_sum(:,:) + tmltrd_atf_sumb(:,:) = tmltrd_sum(:,:,jpmxl_atf) + + ! For S mean diagnostics + smltrd_csum_ub (:,:,:) = zfn * smltrd_sum(:,:,:) - smltrd_csum_ln(:,:,:) + sml_sumb (:,:) = sml_sum(:,:) + smltrd_atf_sumb(:,:) = smltrd_sum(:,:,jpmxl_atf) + + ! ML depth + hmxlbn (:,:) = hmxl (:,:) + + IF( 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=CASTDP(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/V4.0/nemo_sources/src/OCE/TRD/trdmxl_oce.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdmxl_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e19659eae902a0bad44be00eda6050793257d474 --- /dev/null +++ b/V4.0/nemo_sources/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: trdmxl_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trdmxl_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION trdmxl_oce_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp + INTEGER :: ierr(5) + !!---------------------------------------------------------------------- + + ! Initialise jpktrd here as can no longer do it in MODULE body since + ! jpk is now a variable. + jpktrd = jpk !: max level for mixed-layer trends diag. + + ierr(:) = 0 + + ALLOCATE( nmxl (jpi,jpj) , nbol (jpi,jpj), & + & wkx (jpi,jpj,jpk), hmxl (jpi,jpj), & + & tml (jpi,jpj) , sml (jpi,jpj), & + & tmlb (jpi,jpj) , smlb (jpi,jpj), & + & tmlbb(jpi,jpj) , smlbb(jpi,jpj), STAT = ierr(1) ) + + ALLOCATE( tmlbn(jpi,jpj) , smlbn(jpi,jpj), & + & tmltrdm(jpi,jpj), smltrdm(jpi,jpj), & + & tml_sum(jpi,jpj), tml_sumb(jpi,jpj),& + & tmltrd_atf_sumb(jpi,jpj) , STAT=ierr(2) ) + + ALLOCATE( sml_sum(jpi,jpj), sml_sumb(jpi,jpj), & + & smltrd_atf_sumb(jpi,jpj), & + & hmxl_sum(jpi,jpj), hmxlbn(jpi,jpj), & + & tmlatfb(jpi,jpj), tmlatfn(jpi,jpj), STAT = ierr(3) ) + + ALLOCATE( smlatfb(jpi,jpj), smlatfn(jpi,jpj), & + & tmlatfm(jpi,jpj), smlatfm(jpi,jpj), & + & tmltrd(jpi,jpj,jpltrd), smltrd(jpi,jpj,jpltrd), STAT=ierr(4)) + + ALLOCATE( tmltrd_sum(jpi,jpj,jpltrd),tmltrd_csum_ln(jpi,jpj,jpltrd), & + & tmltrd_csum_ub(jpi,jpj,jpltrd), smltrd_sum(jpi,jpj,jpltrd), & + & smltrd_csum_ln(jpi,jpj,jpltrd), smltrd_csum_ub(jpi,jpj,jpltrd), STAT=ierr(5) ) + ! + trdmxl_oce_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'trdmxl_oce', trdmxl_oce_alloc ) + IF( trdmxl_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trdmxl_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION trdmxl_oce_alloc + + !!====================================================================== +END MODULE trdmxl_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdmxl_rst.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdmxl_rst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..01ab608c92d425f0d141436b84c6d61ef32868ff --- /dev/null +++ b/V4.0/nemo_sources/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: trdmxl_rst.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!--------------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_mxl_rst_write( kt ) + !!-------------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_wri *** + !! + !! ** Purpose : Write mixed-layer diagnostics restart fields. + !!-------------------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! output restart file name + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!-------------------------------------------------------------------------------- + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + ! to get better performances with NetCDF format: + ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) + ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' open ocean restart_mxl NetCDF file: '//clname + IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt,' date= ', ndastp + ELSE ; WRITE(numout,*) ' kt = ' , kt,' date= ', ndastp + ENDIF + ENDIF + + CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE. ) + ENDIF + + IF( kt == nitrst .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trdmxl_rst: output for ML diags. restart, with trd_mxl_rst_write routine kt =', kt + WRITE(numout,*) '~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbb' , tmlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlatfb' , tmlatfb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbb' , smlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlatfb' , smlatfb ) + ELSE + CALL iom_rstput( kt, nitrst, nummxlw, 'hmxlbn' , hmxlbn ) + + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tml_sumb' , tml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout, tmltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'tmltrd_atf_sumb' , tmltrd_atf_sumb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'sml_sumb' , sml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout , smltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'smltrd_atf_sumb' , smltrd_atf_sumb ) + ENDIF + ! + IF( kt == nitrst ) THEN + CALL iom_close( nummxlw ) ! close the restart file (only at last time step) + lrst_oce = .FALSE. + ENDIF + ! + END SUBROUTINE trd_mxl_rst_write + + + SUBROUTINE trd_mxl_rst_read + !!---------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_lec *** + !! + !! ** Purpose : Read file for mixed-layer diagnostics restart. + !!---------------------------------------------------------------------------- + INTEGER :: inum ! temporary logical unit + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + LOGICAL :: llok + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!----------------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_rst_read : read the NetCDF mixed layer trend restart file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + ENDIF + + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum ) + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_get( inum, jpdom_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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdpen.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdpen.F90 new file mode 100644 index 0000000000000000000000000000000000000000..463beb8b0f0f25e0109bdc6b6c9e18584bae3187 --- /dev/null +++ b/V4.0/nemo_sources/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: trdpen.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_pen_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( rab_pe(jpi,jpj,jpk,jpts) , STAT= trd_pen_alloc ) + ! + CALL mpp_sum ( 'trdpen', trd_pen_alloc ) + IF( trd_pen_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_pen_alloc: failed to allocate arrays' ) + END FUNCTION trd_pen_alloc + + + SUBROUTINE trd_pen( ptrdx, ptrdy, ktrd, kt, pdt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all trends computation, e.g. 3D output, integral + !! constraints, barotropic vorticity, kinetic enrgy, + !! potential energy, and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptrdx, ptrdy ! Temperature & Salinity trends + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: kt ! time step index + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdtra.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdtra.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9d97d65ceead437e01c994c2c6dcfb95d9e12b3c --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRD/trdtra.F90 @@ -0,0 +1,372 @@ +MODULE trdtra + !!====================================================================== + !! *** MODULE trdtra *** + !! Ocean diagnostics: ocean tracers trends pre-processing + !!===================================================================== + !! History : 3.3 ! 2010-06 (C. Ethe) creation for the TRA/TRC merge + !! 3.5 ! 2012-02 (G. Madec) update the comments + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_tra : pre-process the tracer trends + !! trd_tra_adv : transform a div(U.T) trend into a U.grad(T) trend + !! trd_tra_mng : tracer trend manager: dispatch to the diagnostic modules + !! trd_tra_iom : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics + USE trd_oce ! trends: ocean variables + USE trdtrc ! ocean passive mixed layer tracers trends + USE trdglo ! trends: global domain averaged + USE trdpen ! trends: Potential ENergy + USE trdmxl ! ocean active mixed layer tracers trends + USE ldftra ! ocean active tracers lateral physics + USE ldfslp + USE zdfddm ! vertical physics: double diffusion + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_tra ! called by all tra_... modules + + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtra.F90 14175 2020-12-15 18:25:24Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_tra_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) + ! + CALL mpp_sum ( 'trdtra', trd_tra_alloc ) + IF( trd_tra_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra_alloc: failed to allocate arrays' ) + END FUNCTION trd_tra_alloc + + + SUBROUTINE trd_tra( kt, 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pun ! now velocity + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable + ! + INTEGER :: jk ! loop indices + INTEGER :: i01 ! 0 or 1 + REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws! 3D workspace + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays + IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) + avt_evd(:,:,:) = 0._wp + ENDIF + ! + i01 = COUNT( (/ PRESENT(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(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pun ! now velocity in one direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: ptn ! now or before tracer + CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction + ! + INTEGER :: 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(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + !!---------------------------------------------------------------------- + + 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(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + !! + INTEGER :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdtrc.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdtrc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..51c9c84e6950acf33ead4b8c31a4dfaf85f0ec49 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/TRD/trdtrc.F90 @@ -0,0 +1,26 @@ +MODULE trdtrc + !!====================================================================== + !! *** MODULE trdtrc *** + !! Dummy module + !!====================================================================== + !!---------------------------------------------------------------------- + !! Dummy module NO TOP use + !!---------------------------------------------------------------------- + + USE par_kind, only: dp + +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt ) + INTEGER :: kt, kjn, ktrd + REAL(dp) :: ptrtrd(:,:,:) + WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) + WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt + END SUBROUTINE trd_trc + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtrc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdtrc diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdvor.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdvor.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cc6e2d209b4e20239e618e5269ce31f66d52ebe0 --- /dev/null +++ b/V4.0/nemo_sources/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: trdvor.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_vor_alloc() + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_alloc *** + !!---------------------------------------------------------------------------- + ALLOCATE( vor_avr (jpi,jpj) , vor_avrb(jpi,jpj) , vor_avrbb (jpi,jpj) , & + & vor_avrbn (jpi,jpj) , rotot (jpi,jpj) , vor_avrtot(jpi,jpj) , & + & vor_avrres(jpi,jpj) , vortrd (jpi,jpj,jpltot_vor) , & + & ndexvor1 (jpi*jpj) , STAT= trd_vor_alloc ) + ! + CALL mpp_sum ( 'trdvor', trd_vor_alloc ) + IF( trd_vor_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_vor_alloc: failed to allocate arrays' ) + END FUNCTION trd_vor_alloc + + + SUBROUTINE trd_vor( putrd, pvtrd, ktrd, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + ! + INTEGER :: 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.0_wp , pvtrdvor, 'V', -1.0_wp ) ! 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: putrdvor ! u vorticity trend + REAL(dp), 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.0_wp , pvtrdvor, 'V', -1.0_wp ) + + ! ===================================== + ! 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.0_wp , vor_avrres, 'F', 1.0_wp ) + + + ! III.3 time evolution array swap + ! ------------------------------ + vor_avrbb(:,:) = vor_avrb(:,:) + vor_avrbn(:,:) = vor_avr (:,:) + ! + nmoydpvor = 0 + ! + ENDIF + + ! III.4 write trends to output + ! --------------------------- + + IF( kt >= nit000+1 ) THEN + + IF( lwp .AND. MOD( itmod, nn_trd ) == 0 ) THEN + WRITE(numout,*) '' + WRITE(numout,*) 'trd_vor : write trends in the NetCDF file at kt = ', kt + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + CALL histwrite( nidvor,"sovortPh",it,vortrd(:,:,jpvor_prg),ndimvor1,ndexvor1) ! grad Ph + CALL histwrite( nidvor,"sovortEk",it,vortrd(:,:,jpvor_keg),ndimvor1,ndexvor1) ! Energy + CALL histwrite( nidvor,"sovozeta",it,vortrd(:,:,jpvor_rvo),ndimvor1,ndexvor1) ! rel vorticity + CALL histwrite( nidvor,"sovortif",it,vortrd(:,:,jpvor_pvo),ndimvor1,ndexvor1) ! coriolis + CALL histwrite( nidvor,"sovodifl",it,vortrd(:,:,jpvor_ldf),ndimvor1,ndexvor1) ! lat diff + CALL histwrite( nidvor,"sovoadvv",it,vortrd(:,:,jpvor_zad),ndimvor1,ndexvor1) ! vert adv + CALL histwrite( nidvor,"sovodifv",it,vortrd(:,:,jpvor_zdf),ndimvor1,ndexvor1) ! vert diff + CALL histwrite( nidvor,"sovortPs",it,vortrd(:,:,jpvor_spg),ndimvor1,ndexvor1) ! grad Ps + CALL histwrite( nidvor,"sovortbv",it,vortrd(:,:,jpvor_bev),ndimvor1,ndexvor1) ! beta.V + CALL histwrite( nidvor,"sovowind",it,vortrd(:,:,jpvor_swf),ndimvor1,ndexvor1) ! wind stress + CALL histwrite( nidvor,"sovobfri",it,vortrd(:,:,jpvor_bfr),ndimvor1,ndexvor1) ! bottom friction + CALL histwrite( nidvor,"1st_mbre",it,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.0_wp, 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/TRD/trdvor_oce.F90 b/V4.0/nemo_sources/src/OCE/TRD/trdvor_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..273c09cf853ccd2cd6ad477af2e3bdff5196666d --- /dev/null +++ b/V4.0/nemo_sources/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: trdvor_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdvor_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/USR/README.rst b/V4.0/nemo_sources/src/OCE/USR/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..79b86b7a33f370867c88f0391129874efac72368 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/USR/README.rst @@ -0,0 +1,285 @@ +****************************** +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 + +Option 4: Use the nesting tools to create embedded zooms or regional configurations from an existing grid +--------------------------------------------------------------------------------------------------------- +(see :download:`NESTING README <../../../tools/NESTING/README>`). + + +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/V4.0/nemo_sources/src/OCE/USR/usrdef_fmask.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_fmask.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8a639202ea992b34a185ac0c57aeb22b02b42136 --- /dev/null +++ b/V4.0/nemo_sources/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: usrdef_fmask.F90 13436 2020-08-25 15:11:29Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_fmask( cd_cfg, kcfg, pfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : User defined alteration of the lateral boundary + !! condition on velocity. + !! + !! ** Method : Local change of the value of fmask at lateral ocean/land + !! boundary in straits in order to increase the viscous + !! boundary layer and thus reduce the transport through the + !! corresponding straits. + !! Here only alterations in ORCA R2 and R1 cases + !! + !! ** Action : fmask : land/ocean mask at f-point with increased value + !! in some user defined straits + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cd_cfg ! configuration name + INTEGER , INTENT(in ) :: kcfg ! configuration identifier + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pfmsk ! Ocean/Land f-point mask including lateral boundary cond. + ! + INTEGER :: iif, iil, ii0, ii1, ii ! local integers + INTEGER :: ijf, ijl, ij0, ij1 ! - - + INTEGER :: isrow ! index for ORCA1 starting row + !!---------------------------------------------------------------------- + ! + IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==! + ! + SELECT CASE ( kcfg ) + ! + CASE( 2 ) ! R2 case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R2: increase lateral friction near the following straits:' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ij0 = 101 ; 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/USR/usrdef_hgr.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..868829418c66a7f3dfbb42d66ce1c17997efbbda --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/USR/usrdef_hgr.F90 @@ -0,0 +1,176 @@ +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: usrdef_hgr.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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, plamf! longitude outputs [degrees] + REAL(dp), DIMENSION(:,:), INTENT(out) :: plamu, plamv! longitude outputs [degrees] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphif! latitude outputs [degrees] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pphiu, pphiv! latitude outputs [degrees] + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors [m] + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1 , ze1deg, zf0 ! local scalars + REAL(wp) :: zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme ! - - + !!------------------------------------------------------------------------------- + ! + ! !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : GYRE configuration (beta-plane with rotated regular grid-spacing)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! !== grid point position ==! + ! + zlam1 = -85._wp ! position of gridpoint (i,j) = (1,jpjglo) + zphi1 = 29._wp + ! + ze1 = 106000._wp / REAL( nn_GYRE , wp ) ! gridspacing in meters + ! + zsin_alpha = - SQRT( 2._wp ) * 0.5_wp ! angle: 45 degrees + zcos_alpha = SQRT( 2._wp ) * 0.5_wp + ze1deg = ze1 / (ra * rad) + zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/USR/usrdef_istate.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ddb8dafa278b5f05a053a5969a1c944c58496c97 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/USR/usrdef_istate.F90 @@ -0,0 +1,85 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === GYRE configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called in istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here GYRE configuration example : (double gyre with rotated domain) + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] + REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : analytical definition of initial state ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' + ! + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + pssh(:,:) = 0._wp + ! + 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 + + !!====================================================================== +END MODULE usrdef_istate \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/USR/usrdef_nam.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..638a21d08ddee9fe465ce854a28c3a6341a20baf --- /dev/null +++ b/V4.0/nemo_sources/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: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/USR/usrdef_sbc.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..aafd2d2b28b540d60ba97dbbf404c704e9cdb3fe --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/USR/usrdef_sbc.F90 @@ -0,0 +1,241 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === GYRE configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usrdef_sbc : user defined surface bounday conditions in GYRE case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called in sbcmod module + PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics + PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_sbc.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usrdef_sbc_oce( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc *** + !! + !! ** Purpose : provide at each time-step the GYRE surface boundary + !! condition, i.e. the momentum, heat and freshwater fluxes. + !! + !! ** Method : analytical seasonal cycle for GYRE configuration. + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !! Reference : Hazeleger, W., and S. Drijfhout, JPO, 30, 677-695, 2000. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: zyear0 ! initial year + INTEGER :: zmonth0 ! initial month + INTEGER :: zday0 ! initial day + INTEGER :: zday_year0 ! initial day since january 1st + REAL(wp) :: ztau , ztau_sais ! wind intensity and of the seasonal cycle + REAL(wp) :: ztime ! time in hour + REAL(wp) :: ztimemax , ztimemin ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax1, ztimemin1 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax2, ztimemin2 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztaun ! intensity + REAL(wp) :: zemp_S, zemp_N, zemp_sais, zTstar + REAL(wp) :: zcos_sais1, zcos_sais2, ztrp, zconv, t_star + REAL(wp) :: zsumemp, zsurf + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + REAL(wp) :: zyydd ! number of days in one year + !!--------------------------------------------------------------------- + zyydd = REAL(nyear_len(1),wp) + + ! ---------------------------- ! + ! heat and freshwater fluxes ! + ! ---------------------------- ! + !same temperature, E-P as in HAZELEGER 2000 + + zyear0 = ndate0 / 10000 ! initial year + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 ! initial month + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 ! initial day betwen 1 and 30 + zday_year0 = ( zmonth0 - 1 ) * 30.+zday0 ! initial day betwen 1 and 360 + + ! current day (in hours) since january the 1st of the current year + ztime = REAL( kt ) * rdt / (rmmss * rhhmm) & ! total incrementation (in hours) + & - (nyear - 1) * rjjhh * zyydd ! minus years since beginning of experiment (in hours) + + ztimemax1 = ((5.*30.)+21.)* 24. ! 21th june at 24h in hours + ztimemin1 = ztimemax1 + rjjhh * zyydd / 2 ! 21th december in hours + ztimemax2 = ((6.*30.)+21.)* 24. ! 21th july at 24h in hours + ztimemin2 = ztimemax2 - rjjhh * zyydd / 2 ! 21th january in hours + ! ! NB: rjjhh * zyydd / 4 = one seasonal cycle in hours + + ! amplitudes + zemp_S = 0.7 ! intensity of COS in the South + zemp_N = 0.8 ! intensity of COS in the North + zemp_sais = 0.1 + zTstar = 28.3 ! intemsity from 28.3 a -5 deg + + ! 1/2 period between 21th June and 21th December and between 21th July and 21th January + zcos_sais1 = COS( (ztime - ztimemax1) / (ztimemin1 - ztimemax1) * rpi ) + zcos_sais2 = COS( (ztime - ztimemax2) / (ztimemax2 - ztimemin2) * rpi ) + + ztrp= - 40.e0 ! retroaction term on heat fluxes (W/m2/K) + zconv = 3.16e-5 ! convertion factor: 1 m/yr => 3.16e-5 mm/s + DO jj = 1, jpj + DO ji = 1, jpi + ! domain from 15 deg to 50 deg between 27 and 28 degC at 15N, -3 + ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period : + ! 64.5 in summer, 42.5 in winter + t_star = zTstar * ( 1. + 1. / 50. * zcos_sais2 ) & + & * COS( rpi * (gphit(ji,jj) - 5.) & + & / ( 53.5 * ( 1 + 11 / 53.5 * zcos_sais2 ) * 2.) ) + ! 23.5 deg : tropics + qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) ) + qns (ji,jj) = ztrp * ( tsb(ji,jj,1,jp_tem) - t_star ) - qsr(ji,jj) + IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg + emp (ji,jj) = zemp_S * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_S * zcos_sais1) + ELSE + emp (ji,jj) = - zemp_N * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (46.8 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_N * zcos_sais1 ) + ENDIF + END DO + END DO + + zsumemp = glob_sum( 'usrdef_sbc', emp (:,:)) + zsurf = glob_sum( 'usrdef_sbc', CASTDP(tmask(:,:,1)) ) + zsumemp = zsumemp / zsurf ! Default GYRE configuration + + ! freshwater (mass flux) and update of qns with heat content of emp + emp (:,:) = emp(:,:) - zsumemp * tmask(:,:,1) ! freshwater flux (=0 in domain average) + sfx (:,:) = 0.0_wp ! no salt flux + qns (:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! evap and precip are at SST + + + ! ---------------------------- ! + ! momentum fluxes ! + ! ---------------------------- ! + ! same wind as in Wico + !test date0 : ndate0 = 010203 + zyear0 = ndate0 / 10000 + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 + !Calculates nday_year, day since january 1st + zday_year0 = (zmonth0-1)*30.+zday0 + + !accumulates days of previous months of this year + ! day (in hours) since january the 1st + ztime = FLOAT( kt ) * rdt / (rmmss * rhhmm) & ! incrementation in hour + & - (nyear - 1) * rjjhh * zyydd ! - nber of hours the precedent years + ztimemax = ((5.*30.)+21.)* 24. ! 21th june in hours + ztimemin = ztimemax + rjjhh * zyydd / 2 ! 21th december in hours + ! ! NB: rjjhh * zyydd / 4 = 1 seasonal cycle in hours + + ! mean intensity at 0.105 ; srqt(2) because projected with 45deg angle + ztau = 0.105 / SQRT( 2. ) + ! seasonal oscillation intensity + ztau_sais = 0.015 + ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi ) + DO jj = 1, jpj + DO ji = 1, jpi + ! domain from 15deg to 50deg and 1/2 period along 14deg + ! so 5/4 of half period with seasonal cycle + utau(ji,jj) = - ztaun * SIN( rpi * (gphiu(ji,jj) - 15.) / (29.-15.) ) + vtau(ji,jj) = ztaun * SIN( rpi * (gphiv(ji,jj) - 15.) / (29.-15.) ) + END DO + END DO + + ! module of wind stress and wind speed at T-point + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = 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) + zmod = 0.5 * SQRT( ztx * ztx + zty * zty ) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) + END DO + END DO + CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) + + ! ---------------------------------- ! + ! control print at first time-step ! + ! ---------------------------------- ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'usrdef_sbc_oce : analytical surface fluxes for GYRE configuration' + WRITE(numout,*)'~~~~~~~~~~~ ' + WRITE(numout,*)' nyear = ', nyear + WRITE(numout,*)' nmonth = ', nmonth + WRITE(numout,*)' nday = ', nday + WRITE(numout,*)' nday_year = ', nday_year + WRITE(numout,*)' ztime = ', ztime + WRITE(numout,*)' ztimemax = ', ztimemax + WRITE(numout,*)' ztimemin = ', ztimemin + WRITE(numout,*)' ztimemax1 = ', ztimemax1 + WRITE(numout,*)' ztimemin1 = ', ztimemin1 + WRITE(numout,*)' ztimemax2 = ', ztimemax2 + WRITE(numout,*)' ztimemin2 = ', ztimemin2 + WRITE(numout,*)' zyear0 = ', zyear0 + WRITE(numout,*)' zmonth0 = ', zmonth0 + WRITE(numout,*)' zday0 = ', zday0 + WRITE(numout,*)' zday_year0 = ', zday_year0 + WRITE(numout,*)' zyydd = ', zyydd + WRITE(numout,*)' zemp_S = ', zemp_S + WRITE(numout,*)' zemp_N = ', zemp_N + WRITE(numout,*)' zemp_sais = ', zemp_sais + WRITE(numout,*)' zTstar = ', zTstar + WRITE(numout,*)' zsumemp = ', zsumemp + WRITE(numout,*)' zsurf = ', zsurf + WRITE(numout,*)' ztrp = ', ztrp + WRITE(numout,*)' zconv = ', zconv + WRITE(numout,*)' ndastp = ', ndastp + WRITE(numout,*)' adatrj = ', adatrj + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_tau + + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/src/OCE/USR/usrdef_zgr.F90 b/V4.0/nemo_sources/src/OCE/USR/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e2ad764fea3db651d3b99f66bb754253889ec1a3 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/USR/usrdef_zgr.F90 @@ -0,0 +1,253 @@ +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: usrdef_zgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(out) :: pdepw_1d! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3uw, pe3vw! i-scale factors + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3w! 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! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(out) :: pdepw_1d! 1D grid-point depth [m] + REAL(dp), 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.0_wp ) ! 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! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(in ) :: pdepw_1d! 1D grid-point depth [m] + REAL(dp), DIMENSION(:) , INTENT(in ) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m] + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3uw, pe3vw! - - - + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3w! - - - + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdf_oce.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdf_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..66a616954ef0b0c6c9c527c9b36e3ed99026c24e --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdf_oce.F90 @@ -0,0 +1,79 @@ +MODULE zdf_oce + !!====================================================================== + !! *** MODULE zdf_oce *** + !! Ocean physics : define vertical mixing variables + !!===================================================================== + !! history : 1.0 ! 2002-06 (G. Madec) Original code + !! 3.2 ! 2009-07 (G. Madec) addition of avm + !! 4.0 ! 2017-05 (G. Madec) avm and drag coef. defined at t-point + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_oce_alloc ! Called in nemogcm.F90 + + ! !!* namelist namzdf: vertical physics * + ! ! Adaptive-implicit vertical advection flag + LOGICAL , PUBLIC :: ln_zad_Aimp !: adaptive (Courant number-based) implicit vertical advection + ! ! vertical closure scheme flags + LOGICAL , PUBLIC :: ln_zdfcst !: constant coefficients + LOGICAL , PUBLIC :: ln_zdfric !: Richardson depend coefficients + LOGICAL , PUBLIC :: ln_zdftke !: Turbulent Kinetic Energy closure + LOGICAL , PUBLIC :: ln_zdfgls !: Generic Length Scale closure + LOGICAL , PUBLIC :: ln_zdfosm !: OSMOSIS BL closure + ! ! convection + LOGICAL , PUBLIC :: ln_zdfevd !: convection: enhanced vertical diffusion flag + INTEGER , PUBLIC :: nn_evdm !: =0/1 flag to apply enhanced avm or not + REAL(wp), PUBLIC :: rn_evd !: vertical eddy coeff. for enhanced vert. diff. (m2/s) + LOGICAL , PUBLIC :: ln_zdfnpc !: convection: non-penetrative convection flag + INTEGER , PUBLIC :: nn_npc !: non penetrative convective scheme call frequency + INTEGER , PUBLIC :: nn_npcp !: non penetrative convective scheme print frequency + ! ! double diffusion + LOGICAL , PUBLIC :: ln_zdfddm !: double diffusive mixing flag + REAL(wp), PUBLIC :: rn_avts !: maximum value of avs for salt fingering + REAL(wp), PUBLIC :: rn_hsbfr !: heat/salt buoyancy flux ratio + ! ! gravity wave-induced vertical mixing + LOGICAL , PUBLIC :: ln_zdfswm !: surface wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdfiwm !: internal wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdftmx !: old tidal mixing scheme (Simmons et al 2004) + ! ! 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!: vertical mixing coefficients (w-point) [m2/s] + REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avs!: vertical mixing coefficients (w-point) [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avt_k!: Kz computed by turbulent closure alone [m2/s] + REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k!: Kz computed by turbulent closure alone [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdf_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfddm.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfddm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..92fc48f75c5749863fe5413138d2904758a8b7e6 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfddm.F90 @@ -0,0 +1,191 @@ +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 + USE timing ! Timing + USE nopenmp ! OpenMP + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_ddm ! called by step.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfddm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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(dp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) + ! + INTEGER :: ji, jj , jk ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + REAL(wp) :: zaw, zbw, zrw ! local scalars + REAL(wp) :: zdt, zds + REAL(wp) :: zinr ! - - + REAL(wp) :: zrr ! - - + REAL(wp) :: zavft ! - - + REAL(dp) :: zavfs ! - - + REAL(wp) :: zavdt, zavds ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_ddm') + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2,& + !$omp& zaw,zbw,zrw,zdt,zds,zinr,zrr,zavft,zavfs,zavdt,zavds) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! ! =============== + 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 = MAX(1,jj1), MIN(jj2,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 = MAX(1,jj1), MIN(jj2,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(:,jj1:jj2) = zmsks(:,jj1:jj2) * wmask(:,jj1:jj2,jk) + + + ! Update avt and avs + ! ------------------ + ! Constant eddy coefficient: reset to the background value + DO jj = MAX(1,jj1), MIN(jj2,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 + ! ! =============== + ! + !$omp end parallel + ! + IF(ln_ctl) THEN + CALL prt_ctl(tab3d_1=CASTDP(avt) , clinfo1=' ddm - t: ', tab3d_2=avs , clinfo2=' s: ', kdim=jpk) + ENDIF + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_ddm') + ! + END SUBROUTINE zdf_ddm + + !!====================================================================== +END MODULE zdfddm diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfdrg.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfdrg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e664c36dbb491a9c6d0fb5710110f7e6dcdce7ae --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfdrg.F90 @@ -0,0 +1,494 @@ +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 + USE timing ! Timing + + 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(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCdU_top, rCdU_bot !: top/bottom drag coeff. at t-point (<0) [m/s] + + ! trddyn variables needs to be here to make them visible to all + ! OpenMP threads + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfdrg.F90 13481 2020-09-16 17:14:51Z clem $ + !! 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(dp), 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( ln_timing_detail ) CALL timing_start('zdf_drg') + ! + 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=CASTSP(pCdU), clinfo1=' Cd*U ') + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_drg') + ! + END SUBROUTINE zdf_drg + + + SUBROUTINE zdf_drg_exp( ktid, kj1, kj2, 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) :: ktid, kj1, kj2 ! openmp variables + 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! the two components of the velocity tendency + !! + INTEGER :: ji, jj ! dummy loop indexes + INTEGER :: ikbu, ikbv ! local integers + REAL(wp) :: zm1_2dt ! local scalar + REAL(wp) :: zCdu, zCdv ! - - + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail .and. ktid == 0 ) CALL timing_start('zdf_drg_exp') + ! +!!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 + !$omp barrier + !$omp master + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + !$omp end master + !$omp barrier + ztrdu(:,kj1:kj2,:) = pua(:,kj1:kj2,:) + ztrdv(:,kj1:kj2,:) = pva(:,kj1:kj2,:) + ENDIF + + DO jj = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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(:,kj1:kj2,:) = pua(:,kj1:kj2,:) - ztrdu(:,kj1:kj2,:) + ztrdv(:,kj1:kj2,:) = pva(:,kj1:kj2,:) - ztrdv(:,kj1:kj2,:) + !$omp barrier + !$omp master + CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt ) + DEALLOCATE( ztrdu, ztrdv ) + !$omp end master + !$omp barrier + ENDIF + ! ! print mean trends (used for debugging) + IF( ln_ctl .AND. ktid==0 ) THEN + !$omp barrier + !$omp master + CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr - Ua: ', mask1=umask, & + & tab3d_2=pva, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + !$omp end master + !$omp barrier + ENDIF + ! + IF( ln_timing_detail .and. ktid == 0 ) CALL timing_stop('zdf_drg_exp') + ! + 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(dp), 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/V4.0/nemo_sources/src/OCE/ZDF/zdfevd.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfevd.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1848766fafda2dac25801b21bad4e638ff9ffc12 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfevd.F90 @@ -0,0 +1,142 @@ +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 + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_evd ! called by step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfevd.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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 + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zavt_evd, zavm_evd + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_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 + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + zavt_evd(:,jj1:jj2,:) = p_avt(:,jj1:jj2,:) ! set avt prior to evd application + ! + SELECT CASE ( nn_evdm ) + ! + CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12) + ! + zavm_evd(:,jj1:jj2,:) = p_avm(:,jj1:jj2,:) ! 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 = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2,:) = p_avm(:,jj1:jj2,:) - zavm_evd(:,jj1:jj2,:) ! change in avm due to evd + !$omp barrier + !$omp master + CALL iom_put( "avm_evd", zavm_evd ) ! output this change + !$omp end master + !$omp barrier + ! + 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 = MAX(2,jj1), MIN(jj2,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(:,jj1:jj2,:) = p_avt(:,jj1:jj2,:) - zavt_evd(:,jj1:jj2,:) ! change in avt due to evd + ! + !$omp end parallel + CALL iom_put( "avt_evd", zavt_evd ) ! output this change + IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, CASTSP(zavt_evd) ) + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_evd') + ! + END SUBROUTINE zdf_evd + + !!====================================================================== +END MODULE zdfevd \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfgls.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfgls.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2c049f4086b64471fd87adc9b1e1bc7a531c2c4d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfgls.F90 @@ -0,0 +1,1241 @@ +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" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfgls.F90 14157 2020-12-11 10:36:52Z jchanut $ + !! 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(dp), DIMENSION(:,:,:), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt! momentum and tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm! 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_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) + ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( 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 = 0.5_wp * ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = 0.5_wp * ( 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 ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,ibot) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) + zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp + en (ji,jj,ibot) = z_en + END DO + END DO + 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 + en (ji,jj,itop) = z_en + END DO + END DO + ENDIF + ! + END SELECT + + ! Matrix inversion (en prescribed at surface and the bottom) + ! ---------------------------------------------------------- + ! + DO jk = 2, jpkm1 ! 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=CASTDP(en) , clinfo1=' gls - e: ', tab3d_2=CASTDP(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/V4.0/nemo_sources/src/OCE/ZDF/zdfiwm.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfiwm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b3d732b89a3fc8034088bb339f297ff1210e918a --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfiwm.F90 @@ -0,0 +1,507 @@ +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) + USE timing ! Timing + + 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" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfiwm.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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! tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: 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 - - - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_iwm') + ! + ! !* 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 +! ECMWF +! zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) + zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( ABS ( 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 +! ECMWF + zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT( ABS( 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 +! ECMWF + zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( ABS( 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=CASTDP(zav_wave) , clinfo1=' iwm - av_wave: ', tab3d_2=CASTDP(avt), clinfo2=' avt: ', kdim=jpk) + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_iwm') + ! + 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/V4.0/nemo_sources/src/OCE/ZDF/zdfmxl.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfmxl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5cddc106b322d35f0fcdfd522b7e51af760367bd --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfmxl.F90 @@ -0,0 +1,647 @@ +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 + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_mxl ! called by zdfphy.F90 + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlt !: mld(T=T-dTcrit)(m). Diags only. MAB, ECMWF + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp1 !: mld(T=T-dTcrit)(m). Diags only. + !: GSOP convention zdcrit=0.125 MAB, ECMWF + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp3 !: mld(T=T-dTcrit)(m). Diags only. + !: GSOP convention zdcrit=0.03 MAB, ECMWF + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlt2 !: mld(T=T-dTcrit)(m). Diags only. + !: GSOP convention ztcrit=0.2 C based on Boyer Motegut et al 2004, MAB, ECMWF + 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 + + !! * Substitutions +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfmxl.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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), & + & hmlt(jpi,jpj), hmlp1(jpi,jpj), hmlp3(jpi,jpj), hmlt2(jpi,jpj), & + & htc_mld(jpi,jpj), ll_found(jpi,jpj), ll_belowml(jpi,jpj,jpk), STAT= zdf_mxl_alloc ) + ! + CALL mpp_sum ( 'zdfmxl', zdf_mxl_alloc ) + IF( zdf_mxl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_alloc: failed to allocate arrays.' ) + ! + ENDIF + END FUNCTION zdf_mxl_alloc + + + SUBROUTINE zdf_mxl( kt, ld_iomput ) + !!---------------------------------------------------------------------- + !! *** 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 + LOGICAL, OPTIONAL, INTENT(in) :: ld_iomput ! Call iom_put + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + INTEGER :: iikn, iiki, ikt ! local integer + INTEGER :: iiki1, iiki2, iiki3 ! " + REAL(wp) :: zN2_c ! local scalar + INTEGER, DIMENSION(jpi,jpj) :: imld ! 2D workspace + INTEGER, DIMENSION(jpi,jpj) :: imld1,imld2,imld3 ! 2D workspace + REAL(wp) :: zrho_c = 0.01_wp ! density criterion for mixed layer depth + REAL(wp) :: zavt_c = 5.e-4_wp ! Kz criterion for the turbocline depth + REAL(wp) :: ztmp_c = 0.5_wp ! temperature criteria for traditiona mld comparison + REAL(wp) :: zrho_c1 = 0.125_wp ! density criterion for mixed layer depth for tropics + REAL(wp) :: zrho_c3 = 0.03_wp ! density criterion for mixed layer depth + REAL(wp) :: ztmp_c2 = 0.2_wp ! temperature criteria for Boyer Montegut + INTEGER :: ik,ik2 + LOGICAL :: ll_iomput ! Call iom_put + + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_mxl') + ! + IF (PRESENT(ld_iomput)) THEN + ll_iomput = ld_iomput + ELSE + ll_iomput = .TRUE. + ENDIF + 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 + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2, & + !$omp& iikn,iiki,ikt,iiki1,iiki2,iiki3,zN2_c,ik,ik2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! w-level of the mixing and mixed layers + nmln(:,jj1:jj2) = nlb10 ! Initialization to the number of w ocean point + hmlp(:,jj1:jj2) = 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 = jj1, jj2 ! 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(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 ! Initialization to the number of w ocean point + DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 + DO jj = jj1, jj2 + 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 = jj1, jj2 + 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 .AND. ll_iomput ) THEN + !$omp barrier + !$omp master + 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 + !$omp end master + !$omp barrier + ENDIF + ! + ! Extra ECMWF mixed layer computations. Needs to be checked + ! w-level of the mixing and mixed layers + nmln(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 ! Initialization to the number of w ocean point + imld(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 + imld1(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 + imld3(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 + DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 + DO jj = jj1, jj2 + DO ji = 1, jpi + IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + zrho_c ) nmln(ji,jj) = jk ! Mixed layer + IF( avt (ji,jj,jk) < zavt_c ) imld(ji,jj) = jk ! Turbocline + IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + zrho_c1 ) imld1(ji,jj) = jk ! Mixed layer 0.125 criteria + IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + zrho_c3 ) imld3(ji,jj) = jk ! Mixed layer 0.03 criteria + + END DO + END DO + END DO + ! depth of the mixing and mixed layers + DO jj = jj1, jj2 + DO ji = 1, jpi + iiki = imld (ji,jj) + iiki1 = imld1(ji,jj) + iiki3 = imld3(ji,jj) + iikn = nmln (ji,jj) + hmlp1(ji,jj) = gdepw_n(ji,jj,iiki1 ) * tmask(ji,jj,1) ! Turbocline depth + hmlp3(ji,jj) = gdepw_n(ji,jj,iiki3 ) * tmask(ji,jj,1) ! Turbocline depth + END DO + END DO + IF( .NOT.l_offline .AND. ll_iomput ) THEN ! no need to output in offline mode + !$omp barrier + !$omp master + IF ( iom_use("mldkr125") ) THEN ! mld rhoc=.125 + IF( ln_isfcav ) THEN + CALL iom_put( "mldkr125", hmlp1 - risfdep) ! mixed layer thickness + ELSE + CALL iom_put( "mldkr125", hmlp1 ) ! mixed layer depth + END IF + END IF + IF ( iom_use("mldkr03") ) THEN ! mld rhoc=.03 + IF( ln_isfcav ) THEN + CALL iom_put( "mldkr03", hmlp3 - risfdep) ! mixed layer thickness + ELSE + CALL iom_put( "mldkr03", hmlp3 ) ! mixed layer depth + END IF + END IF + !$omp end master + !$omp barrier + ENDIF + + ! Initialization to the number of w ocean point mbathy + ! To avoid out of bounds memory references make sure it + ! it is at least 1. + imld(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 + imld2(:,jj1:jj2) = mbkt(:,jj1:jj2) + 1 + + ! Last w-level at which rhop>=rho surf+rho_c (starting from jpk-1) + ! (rhop defined at t-point, thus jk-1 for w-level just above) + DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 + DO jj = jj1, jj2 + DO ji = 1, jpi + IF( tsn(ji,jj,jk,jp_tem) < tsn(ji,jj,nla10,jp_tem) - ztmp_c ) imld(ji,jj) = jk + IF( tsn(ji,jj,jk,jp_tem) < tsn(ji,jj,nla10,jp_tem) - ztmp_c2 ) imld2(ji,jj) = jk + END DO + END DO + END DO + + ! Mixed layer depth + DO jj = jj1, jj2 + DO ji = 1, jpi + ik = imld(ji,jj) + ik2 = imld2(ji,jj) + hmlt (ji,jj) = gdepw_n(ji,jj,ik) * tmask(ji,jj,1) + hmlt2 (ji,jj) = gdepw_n(ji,jj,ik2) * tmask(ji,jj,1) + END DO + END DO + IF( .NOT.l_offline .AND. ll_iomput ) THEN ! no need to output in offline mode + !$omp barrier + !$omp master + IF ( iom_use("mldt05") ) THEN ! mld rhoc=.125 + IF( ln_isfcav ) THEN + CALL iom_put( "mldt05", hmlt - risfdep) ! mixed layer thickness + ELSE + CALL iom_put( "mldt05", hmlt ) ! mixed layer depth + END IF + END IF + IF ( iom_use("mldt02") ) THEN ! mld rhoc=.03 + IF( ln_isfcav ) THEN + CALL iom_put( "mldt02", hmlt2 - risfdep) ! mixed layer thickness + ELSE + CALL iom_put( "mldt02", hmlt2 ) ! mixed layer depth + END IF + END IF + !$omp end master + !$omp barrier + ENDIF + ! + !$omp end parallel + ! + ! Vertically-interpolated mixed-layer depth diagnostic + CALL zdf_mxl_zint( kt, ll_iomput ) + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' ) + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_mxl') + ! + 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), 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(wp), DIMENSION(jpi,jpj,jpk) :: zT ! Temperature or density + REAL(wp), DIMENSION(jpi,jpj) :: ppzdep ! depth for use in calculating d(rho) + REAL(wp), DIMENSION(jpi,jpj) :: zT_ref ! reference temperature + REAL(wp) :: zT_b ! base temperature + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdTdz ! gradient of zT + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmoddT ! Absolute temperature difference + REAL(wp) :: zdz ! depth difference + REAL(wp) :: zdT ! temperature difference + REAL(wp), DIMENSION(jpi,jpj) :: zdelta_T ! difference critereon + REAL(wp), DIMENSION(jpi,jpj) :: zRHO1, zRHO2 ! Densities + INTEGER :: ji, jj, jk ! loop counter + + !!------------------------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_mxl_zint_mld') + ! + ! Unpack structure + nn_mld_type = sf%mld_type + rn_zref = sf%zref + rn_dT_crit = sf%dT_crit + rn_iso_frac = sf%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( CASTSP(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.0_wp ) + 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(:,:) = 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) = 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) = 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_wp, zdTdz(ji,jj,jk-1) ) + zdT = zT_b - zT(ji,jj,jk-1) + zdz = zdT / zdTdz(ji,jj,jk-1) + hmld_zint(ji,jj) = gdept_n(ji,jj,jk-1) + zdz + EXIT + END IF + END DO + END DO + END DO + + hmld_zint(:,:) = hmld_zint(:,:)*tmask(:,:,1) + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_mxl_zint_mld') + ! + 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 + INTEGER :: ikmax + REAL(wp) :: zc, zcoef + ! + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilevel + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zthick_0, zthick + + !!---------------------------------------------------------------------- + + IF( ln_timing_detail ) CALL timing_start('zdf_mxl_zint_htc') + + 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 + + ! 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) ) 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(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1) + ELSE ; zthick(:,:) = 0._wp ; htc_mld(:,:) = 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 ) , wp ) ! 0 below ilevel + zthick(ji,jj) = zthick(ji,jj) + zc + htc_mld(ji,jj) = htc_mld(ji,jj) + zc * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) + END DO + END DO + END DO + + ! Subsequent partial T level + zthick(:,:) = hmld_zint(:,:) - zthick(:,:) ! remaining thickness to reach MLD + + DO jj = 1, jpj + DO ji = 1, jpi + htc_mld(ji,jj) = htc_mld(ji,jj) + 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) + + ! Convert to heat content + zcoef = rau0 * rcp + htc_mld(:,:) = zcoef * htc_mld(:,:) + + IF( ln_timing_detail ) CALL timing_stop('zdf_mxl_zint_htc') + + END SUBROUTINE zdf_mxl_zint_htc + + SUBROUTINE zdf_mxl_zint( kt, ld_iomput ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_zint *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt ! ocean time-step index + LOGICAL, INTENT(in) :: ld_iomput ! Write output + + INTEGER :: ios + INTEGER :: jn + + INTEGER :: nn_mld_diag = 0 ! number of diagnostics + + CHARACTER(len=1) :: cmld + + TYPE(MXL_ZINT) :: sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 + TYPE(MXL_ZINT), SAVE, DIMENSION(5) :: mld_diags + + NAMELIST/namzdf_mldzint/ nn_mld_diag, sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 + + !!---------------------------------------------------------------------- + + IF( ln_timing_detail ) CALL timing_start('zdf_mxl_zint') + + 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 ) + + IF( nn_mld_diag > 5 ) CALL ctl_stop( 'STOP', 'zdf_mxl_ini: Specify no more than 5 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 + + IF( lwp .AND. (nn_mld_diag > 0) ) THEN + WRITE(numout,*) '=============== Vertically-interpolated mixed layer ================' + WRITE(numout,*) '(Diagnostic number, nn_mld_type, rn_zref, rn_dT_crit, rn_iso_frac)' + DO jn = 1, nn_mld_diag + 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 DO + WRITE(numout,*) '====================================================================' + ENDIF + ENDIF + + IF( ( nn_mld_diag > 0 ) .AND. ld_iomput ) THEN + DO jn = 1, nn_mld_diag + WRITE(cmld,'(I1)') jn + IF( iom_use( "mldzint_"//cmld ) .OR. iom_use( "mldhtc_"//cmld ) ) THEN + CALL zdf_mxl_zint_mld( mld_diags(jn) ) + + IF( iom_use( "mldzint_"//cmld ) ) THEN + CALL iom_put( "mldzint_"//cmld, hmld_zint(:,:) ) + ENDIF + + IF( iom_use( "mldhtc_"//cmld ) ) THEN + CALL zdf_mxl_zint_htc( kt ) + CALL iom_put( "mldhtc_"//cmld , htc_mld(:,:) ) + ENDIF + ENDIF + END DO + ENDIF + + IF( ln_timing_detail ) CALL timing_stop('zdf_mxl_zint') + + END SUBROUTINE zdf_mxl_zint + + !!====================================================================== +END MODULE zdfmxl diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfosm.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfosm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f76ef693007061ec695f793049675809d64b584b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfosm.F90 @@ -0,0 +1,1734 @@ +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: zdfosm.F90 13260 2020-07-07 12:35:05Z ayoung $ + !! 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_avt! momentum and tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm! 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.0_wp ) + + ! 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.0_wp , ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) + CALL lbc_lnk_multi( 'zdfosm', p_avm, 'W', 1.0_wp ) + 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.0_wp , ghams, 'W', 1.0_wp, & + & ghamu, 'U', 1.0_wp , ghamv, 'V', 1.0_wp ) + + 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.0_wp ) + ! + 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/V4.0/nemo_sources/src/OCE/ZDF/zdfphy.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfphy.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d9a07cee9a55aaf308d398c59a208bd71521b436 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfphy.F90 @@ -0,0 +1,354 @@ +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 zdftmx ! vertical physics: old tidal mixing scheme (Simmons et al 2004) + 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: zdfphy.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 + & ln_zdftmx, & ! old tidal mixing scheme (Simmons et al 2004) + & rn_avm0, rn_avt0, nn_avb, nn_havtb ! coefficients + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_phy_init: ocean vertical physics' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! !== Namelist ==! + 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_zdftmx ) CALL zdf_tmx_init ! old tidal mixing scheme (Simmons et al) + IF( ln_zdfswm ) CALL zdf_swm_init ! surface wave-driven mixing + + ! !== top/bottom friction ==! + CALL zdf_drg_init + ! + ! !== time-stepping ==! + ! Check/update of time stepping done in dynzdf_init/trazdf_init + !!gm move it here ? + ! + END SUBROUTINE zdf_phy_init + + + SUBROUTINE zdf_phy( kt ) + !!---------------------------------------------------------------------- + !! *** 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(dp), 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 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( ln_zdftmx ) CALL zdf_tmx( kt, avm, avt, avs ) ! old tidal mixing scheme (Simmons et al 2004) + +#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', avt_k, 'W', 1.0_wp, avm , 'W', 1.0_wp , avt , 'W', 1.0_wp ) + CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1.0_wp , avs , 'W', 1.0_wp ) + ELSE + CALL lbc_lnk_multi( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp ) + CALL lbc_lnk_multi( 'zdfphy', avs , 'W', 1.0_wp ) + 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.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag + ELSE ; CALL lbc_lnk ( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only + ENDIF + ENDIF + ! + 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 + ! + 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/V4.0/nemo_sources/src/OCE/ZDF/zdfric.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfric.F90 new file mode 100644 index 0000000000000000000000000000000000000000..45d2f6f6faea5d0b57be0f869919c5edc9223052 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfric.F90 @@ -0,0 +1,253 @@ +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) + USE timing ! Timing + + + 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: zdfric.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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(dp), DIMENSION(:,:,:), INTENT(in ) :: pdept ! depth of t-point [m] + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt! momentum and tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm! 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_ric') + ! + ! !== 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 + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_ric') + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfsh2.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfsh2.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ad432e14b4ae16d42e7463293cbb2ca9b27b0a6d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfsh2.F90 @@ -0,0 +1,97 @@ +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 + USE timing ! Timing + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_sh2 ! called by zdftke, zdfglf, and zdfric + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfsh2.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsh2u, zsh2v ! 2D workspace + !!-------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_sh2') + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + DO jk = 2, jpkm1 + DO jj = MAX(1,jj1), MIN(jj2,jpjm1) !* 2 x shear production at uw- and vw-points (energy conserving form) + DO ji = 1, jpim1 + zsh2u(ji,jj,jk) = ( 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,jk) = ( 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 + ENDDO + !$omp barrier + DO jk = 2, jpkm1 + DO jj = MAX(2,jj1), MIN(jj2,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,jk) + zsh2u(ji,jj,jk) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & + & + ( zsh2v(ji,jj-1,jk) + zsh2v(ji,jj,jk) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) + END DO + END DO + END DO + ! + !$omp end parallel + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_sh2') + ! + END SUBROUTINE zdf_sh2 + + !!====================================================================== +END MODULE zdfsh2 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdfswm.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdfswm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4f699d10068173c7604a1fea2a65339d7ae590bd --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdfswm.F90 @@ -0,0 +1,103 @@ +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 + USE timing ! Timing + + 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: zdfswm.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! 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! tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avs! tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp):: zcoef, zqb ! local scalar + !!--------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_swm') + ! + 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 + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_swm') + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdftke.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdftke.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8380b8494e69b51dc59287dc02e500316c4cdbcb --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdftke.F90 @@ -0,0 +1,1105 @@ +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 sbcwave ! surface boundary condition: waves + 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) + USE timing ! Timing + USE nopenmp ! OpenMP + + 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) + LOGICAL , PUBLIC :: ln_wavetke = .FALSE. !: true if wave TKE is used (it is needed in sbcmod) + ! + LOGICAL , PUBLIC :: ln_namzdf_tke = .FALSE. !: true if namzdf_tke has been read + ! + LOGICAL :: ln_ebbavg ! True means TKE surface input is averaged over first top layer + REAL(wp) :: rn_swhfr ! Fraction of the significant wave height used to scale the TKE flux penetration in the top layer + + 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 + + ! ECMWF customization + REAL(wp) :: rn_whtauscl = 2.0_wp ! htau scale factor to wave height (nn_htau=6) + REAL(wp) :: rn_whtaumin = 1.0_wp ! minimum htau (nn_htau=6) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdftke.F90 13310 2020-07-16 09:13:15Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_tke_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_tke_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: iexalloc + 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(dp), DIMENSION(:,:,:), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt! momentum and tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm! momentum and tracer Kz (w-points) + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + !!---------------------------------------------------------------------- + ! + !$omp parallel private(itid,ithreads,jj1,jj2) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + CALL tke_tke( itid, jj1, jj2, gdepw_n, e3t_n, e3w_n, p_sh2, p_avm, p_avt ) ! now tke (en) + ! + CALL tke_avn( itid, jj1, jj2, gdepw_n, e3t_n, e3w_n, p_avm, p_avt ) ! now avt, avm, dissl + ! + !$omp end parallel + ! + END SUBROUTINE zdf_tke + + + SUBROUTINE tke_tke( ktid, kj1, kj2, 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 + !! + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! openmp variables + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdepw ! depth of w-points + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_e3t, p_e3w ! level thickness (t- & w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avt! vertical eddy viscosity & diffusivity (w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), PARAMETER :: ztwothird = 2._wp/3._wp + REAL(wp), PARAMETER :: zb_my = 16.6_wp ! parameter from Mellor-Yamada closure model + REAL(wp), PARAMETER :: zs_my = 0.2_wp ! parameter from Mellor-Yamada closure model + REAL(wp), PARAMETER :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp), PARAMETER :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars + REAL(wp) :: zbbirau! local scalars + REAL(dp) :: zbbrau, zri! local scalars + REAL(wp) :: zfact1, zfact2! - - + REAL(dp) :: zfact3! - - + REAL(wp) :: ztx2, zty2! - - + REAL(dp) :: zcof! - - + REAL(wp) :: ztau , zdif ! - - + REAL(wp) :: zind! - - + REAL(dp) :: zus, zwlc! - - + REAL(wp) :: zzd_up, zzd_lw ! - - + REAL(wp) :: zlamb , zz0 ! - - + REAL(wp) :: zlam , zphi ! - - + REAL(wp) :: zdfac , zfr ! - - + REAL(wp) :: zfrwv , zfrnowv ! - - + REAL(wp) :: zphio_flux ! - - + REAL(wp) :: zensfc ! - - + REAL(wp) :: zdiv + INTEGER , DIMENSION(jpi,jpj) :: imlc + REAL(wp), DIMENSION(jpi,jpj) :: zice_fra + REAL(dp), DIMENSION(jpi,jpj) :: zhlc, zus3 + REAL(wp), DIMENSION(jpi,jpj) :: zreduc + REAL(wp), DIMENSION(jpi,jpj) :: zbbrau_min ! minimum value for zbbrau + REAL(wp), DIMENSION(jpi,jpj) :: zus2 ! square of the surface Stokes drift magnitude + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zd_up + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zdiag, zd_lw + + !!-------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('zdf_tke_tke') + ! + ! Local constant initialisation + zbbrau = rn_ebb / rau0 + zbbirau = 3.75_wp / rau0 + + zfact1 = -.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(:,kj1:kj2) = 0._wp + CASE( 1 ) ; zice_fra(:,kj1:kj2) = TANH( fr_i(:,kj1:kj2) * 10._wp ) + CASE( 2 ) ; zice_fra(:,kj1:kj2) = fr_i(:,kj1:kj2) + CASE( 3 ) ; zice_fra(:,kj1:kj2) = MIN( 4._wp * fr_i(:,kj1:kj2) , 1._wp ) + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface/top/bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Wave parameters read? + IF ( ln_wavetke ) THEN + + zlam=(3._wp/(zs_my*zb_my*vkarmn**2))**0.5_wp + + IF ( ln_ebbavg ) THEN + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) + DO ji = fs_2, fs_jpim1 ! vector opt. + ! Roughness length proportional to wave height, capped at Hs = 0.5 m + zz0 = rn_swhfr*MAX(hsw(ji,jj), 0.5_wp) + zlamb = zlam/zz0 + ! Reducing the surface TKE by scaling with T-depth of first vertical level + ! except where sea ice is present, + zfr = MIN(1.0_wp, 4.0_wp*fr_i(ji,jj)) + zfrwv = MIN(1.0_wp, 100.0_wp*fr_i(ji,jj)) + zfr = zfrwv*zfr + (1.0_wp - zfrwv )*wave_inice(ji,jj) + zdfac = MAX( ztwothird*zlamb*gdept_n(ji,jj,1) , 0.00001_wp ) + zreduc(ji,jj) = (1.0_wp - zfr) * ( 1.0_wp - EXP(-zdfac) ) / zdfac + zfr + ! Minimum value for TKE flux is increased under sea ice + zfrnowv = MIN(1.0_wp, 10.0_wp*zfr) + zbbrau_min(ji,jj) = (0.65_wp + 0.35_wp*zfrnowv)*zbbrau + ENDDO + ENDDO + ELSE + zreduc(:,kj1:kj2) = 1.0_wp + zbbrau_min(:,kj1:kj2) = 0.65_wp*zbbrau + ENDIF + + ! Breaking-wave TKE injection as flux + + zphi=(3._wp*zb_my/(8._wp*zs_my))**0.5_wp/rau0 + + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) + DO ji = fs_2, fs_jpim1 ! vector opt. + ! The energy flux from the wave model in physical units + zphio_flux = MAX(phioc_wave(ji,jj), 0.0_wp) + ! TKE at surface 0.5*q0**2 (Mellor and Blumberg, 2004) + zensfc = (zphi*zphio_flux )**ztwothird + + ! TKE surface boundary condition weighted by the thickness of the first level, + ! and reducing the surface TKE by scaling with T-depth of first vertical level + en(ji,jj,1) = MAX( zensfc * zreduc(ji,jj), zbbrau_min(ji,jj) * taum(ji,jj) ) + en(ji,jj,1) = MAX( rn_emin0, en(ji,jj,1) ) * tmask(ji,jj,1) + ENDDO + ENDDO + ! If wave parameters are not read, use rn_ebb, corresponding to alpha = 100.0 + ELSE + ! + DO jj = MAX(2,kj1), MIN(kj2,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 + ENDIF + IF ( ln_isfcav ) THEN + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) ! en(mikt(ji,jj)) = rn_emin + DO ji = fs_2, fs_jpim1 ! vector opt. + en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1) + END DO + END DO + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! 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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 + DO jj= MAX(1,kj1), MIN(kj2,jpj) + zpelc(:,jj,1) = MAX( rn2b(:,jj,1), 0._wp ) * pdepw(:,jj,1) * p_e3w(:,jj,1) + END DO + DO jk = 2, jpk + DO jj = MAX(1,kj1), MIN(kj2,jpj) + zpelc(:,jj,jk) = zpelc(:,jj,jk-1) + MAX( rn2b(:,jj,jk), 0._wp ) * pdepw(:,jj,jk) * p_e3w(:,jj,jk) + END DO + END DO + ! !* finite Langmuir Circulation depth + zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) + DO jj = MAX(1,kj1), MIN(kj2,jpj) + imlc(:,jj) = mbkt(:,jj) + 1 ! Initialization to the number of w ocean point (=2 over land) + END DO + DO jk = jpkm1, 2, -1 + DO jj = MAX(1,kj1), MIN(kj2,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 = MAX(1,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = 2, jpim1 + ! ! local Richardson number + IF (rn2b(ji,jj,jk) <= 0.0_wp) then + zri = 0.0_wp + ELSE + ! This logic is to avoid divide-by-zero errors which can occur for single-precision + ! The actual value you choose for the denominator instead of zero doesn't really + ! matter, as long as it is very small and so triggers the same logic below with the + ! inverse Prandtl number + zdiv = p_sh2(ji,jj,jk) + rn_bshear + IF (zdiv == 0.0_wp) THEN + zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / rn_bshear + ELSE + zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / zdiv + ENDIF + ENDIF + + ! ! inverse of Prandtl number + apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) + END DO + END DO + END DO + ENDIF + ! + DO jk = 2, jpkm1 !* Matrix and right hand side in en + DO jj = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 /= 0 ) .AND. ( nn_htau == 6 )) THEN ! htau from wave height + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) + DO ji = fs_2, fs_jpim1 ! vector opt. + htau(ji,jj) = MAX( rn_whtauscl * hsw(ji,jj), rn_whtaumin ) + END DO + END DO + ENDIF + 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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('zdf_tke_tke') + ! + END SUBROUTINE tke_tke + + + SUBROUTINE tke_avn( ktid, kj1, kj2, 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 + !! + INTEGER, INTENT(in) :: ktid, kj1, kj2 ! openmp variables + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdepw ! depth (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: p_e3t, p_e3w ! level thickness (t- & w-points) + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avt! vertical eddy viscosity & diffusivity (w-points) + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: p_avm! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef! local scalars + REAL(dp) :: zrn2, zraug, zav! local scalars + REAL(wp) :: zdku, zdkv! - - + REAL(dp) :: zsqen! - - + REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zmxlm, zmxld ! 3D workspace + REAL(wp), PARAMETER :: zcharnock_oc = 2.e5_wp ! mean value of ocean side Charnock parameter + REAL(wp), PARAMETER :: zcharnock_mean_inv = 1._wp/0.018_wp ! inverse of the mean value of atmospheric side Charnock parameter + REAL(dp), DIMENSION(jpi,jpj) :: ztaum ! argument used in loops + !!-------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('zdf_tke_avn') + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Mixing length + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! !* Buoyancy length scale: l=sqrt(2*e/n**2) + ! + ! + ! initialisation of interior minimum value (avoid a 2d loop with mikt) + DO jk = 1, jpk + zmxlm(:,kj1:kj2,jk) = rmxl_min + zmxld(:,kj1:kj2,jk) = rmxl_min + END DO + ! + IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) + ! + zraug = vkarmn * zcharnock_oc / ( rau0 * grav ) + + IF (ln_charnock) THEN + ztaum(:,kj1:kj2) = charn_wave(:,kj1:kj2) * zcharnock_mean_inv * taum(:,kj1:kj2) + ELSE + ztaum(:,kj1:kj2) = taum(:,kj1:kj2) + ENDIF + +#if ! defined key_si3 && ! defined key_cice + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * ztaum(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 = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = zraug * ztaum(ji,jj) * tmask(ji,jj,1) + END DO + END DO + ! + CASE( 1 ) ! scaling with constant sea-ice thickness + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * ztaum(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 = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 +#if defined key_si3 + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * ztaum(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 * ztaum(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 = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zmaxice = MAXVAL( h_i(ji,jj,:) ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * ztaum(ji,jj) + & + & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) + END DO + END DO + ! + END SELECT +#endif + ! + DO jj = MAX(2,kj1), MIN(kj2,jpjm1) + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) + END DO + END DO + ! + ELSE + zmxlm(:,kj1:kj2,1) = rn_mxl0 + ENDIF + ! + DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) + DO jj = MAX(2,kj1), MIN(kj2,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(:,kj1:kj2, 1 ) = zmxlm(:,kj1:kj2,1) ! surface set to the minimum value + zmxld(:,kj1:kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 = MAX(2,kj1), MIN(kj2,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 + !$omp barrier + !$omp master + CALL prt_ctl( tab3d_1=CASTDP(en) , clinfo1=' tke - e: ', tab3d_2=CASTDP(p_avt), clinfo2=' t: ', kdim=jpk) + CALL prt_ctl( tab3d_1=p_avm, clinfo1=' tke - m: ', kdim=jpk ) + !$omp end master + !$omp barrier + ENDIF + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('zdf_tke_avn') + ! + 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 , & + & rn_whtauscl, rn_whtaumin, & + & ln_wavetke, ln_ebbavg, rn_swhfr + !!---------------------------------------------------------------------- + ! + 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 ) + ln_namzdf_tke = .true. + ! + 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 ( ln_wavetke ) THEN + WRITE(numout,*) + WRITE(numout,*) ' Ocean wave effects in the TKE are activated :' + WRITE(numout,*) ' average out the surface value over first layer ln_ebbavg = ', ln_ebbavg + WRITE(numout,*) ' Fraction of swh to scale the TKE flux penetration rn_swhfr = ', rn_swhfr + WRITE(numout,*) + ENDIF + 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 + IF ( nn_htau == 6 ) THEN + WRITE(numout,*) ' htau scale factor to wave height rn_whtauscl=', rn_whtauscl + WRITE(numout,*) ' htau minum when using wave height rn_whtaumin=', rn_whtaumin + 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 ) .AND. ( nn_htau .NE. 4 ) .AND. ( nn_htau .NE. 6 ) ) CALL ctl_stop( 'bad flag: nn_htau is 0, 1, 4 and 6' ) + 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(:,:) ) ) ) ) + CASE( 4 ) ! F(latitude) : 0.5m to 10m/30m poleward of 13/40 degrees north/south + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( gphit(ji,jj) <= 0._wp ) THEN + htau(ji,jj) = MAX( 0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(ji,jj) ) ) ) ) + ELSE + htau(ji,jj) = MAX( 0.5_wp, MIN( 10._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(ji,jj) ) ) ) ) + ENDIF + END DO + END DO + CASE( 6 ) ! F(latitude) : wave height dependent + htau(:,:) = 0.0 + IF(lwp) WRITE(numout,*) ' using htau from wave height' + IF ( jp_hsw == 0 ) THEN + CALL ctl_stop( 'nn_htau = 6 requires SWH forcings' ) + ENDIF + 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 + IF ( nn_slimrstin < 3 ) THEN + id1 = iom_varid( numror, 'en' , ldstop = .FALSE. ) + ELSE + id1 = 0 + ENDIF + IF( id1 > 0 ) THEN ! fields exist + CALL iom_get( numror, jpdom_autoglo, 'en' , en , ldxios = lrxios ) + ELSE + en (:,:,:) = rn_emin * wmask(:,:,:) + ENDIF + IF ( nn_slimrstin < 2 ) THEN + id2 = iom_varid( numror, 'avt_k', ldstop = .FALSE. ) + id3 = iom_varid( numror, 'avm_k', ldstop = .FALSE. ) + id4 = iom_varid( numror, 'dissl', ldstop = .FALSE. ) + ELSE + id2 = 0 + id3 = 0 + id4 = 0 + ENDIF + ! + IF( MIN( id2, id3, id4 ) > 0 ) THEN ! fields exist + 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' + 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 ) + IF ( nn_slimrst < 3 .OR. kt >= nitend - nn_fsbc )THEN + CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) + ENDIF + IF ( nn_slimrst < 2 .OR. kt >= nitend - nn_fsbc ) THEN + 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 ) + ENDIF + IF( lwxios ) CALL iom_swap( cxios_context ) + ! + ENDIF + ! + END SUBROUTINE tke_rst + + !!====================================================================== +END MODULE zdftke diff --git a/V4.0/nemo_sources/src/OCE/ZDF/zdftmx.F90 b/V4.0/nemo_sources/src/OCE/ZDF/zdftmx.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b28ec91bc960a45cca168d2e0902fd7a6b57ea3d --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/ZDF/zdftmx.F90 @@ -0,0 +1,559 @@ +MODULE zdftmx + !!======================================================================== + !! *** MODULE zdftmx *** + !! Ocean physics: vertical tidal mixing coefficient + !!======================================================================== + !! 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 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! 'key_zdftmx' Tidal vertical mixing + !!---------------------------------------------------------------------- + !! zdf_tmx : global momentum & tracer Kz with tidal induced Kz + !! tmx_itf : Indonesian momentum & tracer Kz with tidal 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 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 timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE nopenmp ! OpenMP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_tmx ! called in step module + PUBLIC zdf_tmx_init ! called in opa module + PUBLIC zdf_tmx_alloc ! called in nemogcm module + + LOGICAL, PUBLIC, PARAMETER :: lk_zdftmx = .TRUE. !: tidal mixing flag + + ! !!* Namelist namzdf_tmx : tidal mixing * + REAL(wp) :: rn_htmx ! vertical decay scale for turbulence (meters) + REAL(wp) :: rn_n2min ! threshold of the Brunt-Vaisala frequency (s-1) + REAL(wp) :: rn_tfe ! tidal dissipation efficiency (St Laurent et al. 2002) + REAL(wp) :: rn_me ! mixing efficiency (Osborn 1980) + LOGICAL :: ln_tmx_itf ! Indonesian Through Flow (ITF): Koch-Larrouy et al. (2007) parameterization + REAL(wp) :: rn_tfe_itf ! ITF tidal dissipation efficiency (St Laurent et al. 2002) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: en_tmx ! energy available for tidal mixing (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: mask_itf ! mask to use over Indonesian area + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: az_tmx ! coefficient used to evaluate the tidal induced Kz + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zavt_itf ! To allow zdf_tmp_itf to produce domain sums + + !! * Substitutions +# include "vectopt_loop_substitute.h90" +# include "single_precision_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2011) + !! $Id: zdftmx.F90 8788 2017-11-22 18:01:02Z davestorkey $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_tmx_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_tmx_alloc *** + !!---------------------------------------------------------------------- + IF ( ln_tmx_itf ) THEN + ALLOCATE(en_tmx(jpi,jpj), mask_itf(jpi,jpj), az_tmx(jpi,jpj,jpk), & + & zavt_itf(jpi,jpj,jpk), STAT=zdf_tmx_alloc ) + ELSE + ALLOCATE(en_tmx(jpi,jpj), mask_itf(jpi,jpj), az_tmx(jpi,jpj,jpk), STAT=zdf_tmx_alloc ) + ENDIF + ! + IF( lk_mpp ) CALL mpp_sum ( 'zdftmx', zdf_tmx_alloc ) + IF( zdf_tmx_alloc /= 0 ) CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') + END FUNCTION zdf_tmx_alloc + + + SUBROUTINE zdf_tmx( kt, p_avm, p_avt, p_avs) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tmx *** + !! + !! ** Purpose : add to the vertical mixing coefficients the effect of + !! tidal mixing (Simmons et al 2004). + !! + !! ** Method : - tidal-induced vertical mixing is given by: + !! Kz_tides = az_tmx / max( rn_n2min, N^2 ) + !! where az_tmx is a coefficient that specified the 3D space + !! distribution of the faction of tidal energy taht is used + !! for mixing. Its expression is set in zdf_tmx_init routine, + !! following Simmons et al. 2004. + !! NB: a specific bounding procedure is performed on av_tide + !! so that the input tidal energy is actually almost used. The + !! basic maximum value is 60 cm2/s, but values of 300 cm2/s + !! can be reached in area where bottom stratification is too + !! weak. + !! + !! - update av_tide in the Indonesian Through Flow area + !! following Koch-Larrouy et al. (2007) parameterisation + !! (see tmx_itf routine). + !! + !! - update the model vertical eddy viscosity and diffusivity: + !! avt = avt + av_tides + !! avm = avm + av_tides + !! + !! ** Action : avt, avm increased by tidal mixing + !! + !! References : Simmons et al. 2004, Ocean Modelling, 6, 3-4, 245-263. + !! Koch-Larrouy et al. 2007, GRL. + !!---------------------------------------------------------------------- + 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! tracer Kz (w-points) + REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avs! tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: jj1, jj2, itid, ithreads ! openmp variables + REAL(wp) :: ztpc ! scalar workspace + REAL(wp), DIMENSION(jpi,jpj) :: zkz + REAL(dp), DIMENSION(jpi,jpj,jpk) :: zav_tide, ztpc3d + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail ) CALL timing_start('zdf_tmx') + ! + !$omp parallel private(itid,ithreads,ji,jj,jk,jj1,jj2,ztpc) + ! + CALL nompinfo( itid, ithreads ) + jj1 = nompstas(itid,jpj) + jj2 = nompends(itid,jpj) + ! + ! ! ----------------------- ! + ! ! Standard tidal mixing ! (compute zav_tide) + ! ! ----------------------- ! + ! !* First estimation (with n2 bound by rn_n2min) bounded by 60 cm2/s + zav_tide(:,jj1:jj2,:) = MIN( 60.e-4, az_tmx(:,jj1:jj2,:) / MAX( rn_n2min, rn2(:,jj1:jj2,:) ) ) + + zkz(:,jj1:jj2) = 0.e0 !* Associated potential energy consummed over the whole water column + DO jk = 2, jpkm1 + zkz(:,jj1:jj2) = zkz(:,jj1:jj2) + e3w_n(:,jj1:jj2,jk) * MAX( 0.e0, rn2(:,jj1:jj2,jk) ) * rau0 * zav_tide(:,jj1:jj2,jk) * wmask(:,jj1:jj2,jk) + END DO + + DO jj = jj1, jj2 !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx + DO ji = 1, jpi + IF( zkz(ji,jj) /= 0.e0 ) zkz(ji,jj) = en_tmx(ji,jj) / zkz(ji,jj) + END DO + END DO + + DO jk = 2, jpkm1 !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s + DO jj = jj1, jj2 !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx + DO ji = 1, jpi + zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk) !kz max = 300 cm2/s + END DO + END DO + END DO + + IF( kt == nit000 ) THEN !* check at first time-step: diagnose the energy consumed by zav_tide + DO jk = 1, jpk + DO jj= jj1, jj2 + DO ji= 1, jpi + ztpc3d(ji,jj,jk) = e3w_n(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) & + & * MAX( 0.e0, rn2(ji,jj,jk) ) * zav_tide(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) + END DO + END DO + END DO + !$omp barrier + !$omp master + ztpc = glob_sum( 'zdf_tmx', ztpc3d ) + ztpc = rau0 / ( rn_tfe * rn_me ) * ztpc + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' N Total power consumption by av_tide : ztpc = ', ztpc * 1.e-12 ,'TW' + !$omp end master + !$omp barrier + ENDIF + + ! ! ----------------------- ! + ! ! ITF tidal mixing ! (update zav_tide) + ! ! ----------------------- ! + IF( ln_tmx_itf ) CALL tmx_itf( kt, itid, jj1, jj2, zav_tide, ztpc3d ) + + ! ! ----------------------- ! + ! ! Update mixing coefs ! + ! ! ----------------------- ! + DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with tidal mixing + DO jj = jj1, jj2 !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx + DO ji = 1, jpi + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) + p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + !$omp end parallel + ! !* output tidal mixing coefficient + CALL iom_put( "av_tmx", zav_tide ) + + IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_tide , clinfo1=' tmx - av_tide: ', tab3d_2=CASTDP(p_avt), clinfo2=' p_avt: ', kdim=jpk) + ! + IF( ln_timing_detail ) CALL timing_stop('zdf_tmx') + ! + END SUBROUTINE zdf_tmx + + + SUBROUTINE tmx_itf( kt, ktid, kj1, kj2, pav, ptpc3d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tmx_itf *** + !! + !! ** Purpose : modify the vertical eddy diffusivity coefficients + !! (pav) in the Indonesian Through Flow area (ITF). + !! + !! ** Method : - Following Koch-Larrouy et al. (2007), in the ITF defined + !! by msk_itf (read in a file, see tmx_init), the tidal + !! mixing coefficient is computed with : + !! * q=1 (i.e. all the tidal energy remains trapped in + !! the area and thus is used for mixing) + !! * the vertical distribution of the tifal energy is a + !! proportional to N above the thermocline (d(N^2)/dz > 0) + !! and to N^2 below the thermocline (d(N^2)/dz < 0) + !! + !! ** Action : av_tide updated in the ITF area (msk_itf) + !! + !! References : Koch-Larrouy et al. 2007, GRL + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: ktid, kj1, kj2 ! OpenMP + REAL(dp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pav ! Tidal mixing coef. + REAL(dp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: ptpc3d ! For summation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef, ztpc ! temporary scalar + REAL(wp), DIMENSION(jpi,kj1:kj2) :: zkz ! 2D workspace + REAL(wp), DIMENSION(jpi,kj1:kj2) :: zsum1 , zsum2 , zsum ! - - + REAL(wp), DIMENSION(jpi,kj1:kj2,jpk) :: zempba_3d_1, zempba_3d_2 ! 3D workspace + REAL(wp), DIMENSION(jpi,kj1:kj2,jpk) :: zempba_3d , zdn2dz ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_start('tmx_itf') + ! + ! ! compute the form function using N2 at each time step + zdn2dz (:,kj1:kj2,jpk) = 0.e0 + zempba_3d_1(:,kj1:kj2,jpk) = 0.e0 + zempba_3d_2(:,kj1:kj2,jpk) = 0.e0 + DO jk = 1, jpkm1 + zdn2dz (:,kj1:kj2,jk) = rn2(:,kj1:kj2,jk) - rn2(:,kj1:kj2,jk+1) ! Vertical profile of dN2/dz +!CDIR NOVERRCHK + zempba_3d_1(:,kj1:kj2,jk) = SQRT( ABS( MAX( 0.e0, rn2(:,kj1:kj2,jk) ) ) ) ! - - of N + zempba_3d_2(:,kj1:kj2,jk) = ABS( MAX( 0.e0, rn2(:,kj1:kj2,jk) ) ) ! - - of N^2 + END DO + ! + zsum (:,kj1:kj2) = 0.e0 + zsum1(:,kj1:kj2) = 0.e0 + zsum2(:,kj1:kj2) = 0.e0 + DO jk= 2, jpk + zsum1(:,kj1:kj2) = zsum1(:,kj1:kj2) + zempba_3d_1(:,kj1:kj2,jk) * e3w_n(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk-1) + zsum2(:,kj1:kj2) = zsum2(:,kj1:kj2) + zempba_3d_2(:,kj1:kj2,jk) * e3w_n(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk-1) + END DO + DO jj = kj1, kj2 + DO ji = 1, jpi + IF( zsum1(ji,jj) /= 0.e0 ) zsum1(ji,jj) = 1.e0 / zsum1(ji,jj) + IF( zsum2(ji,jj) /= 0.e0 ) zsum2(ji,jj) = 1.e0 / zsum2(ji,jj) + END DO + END DO + + DO jk= 1, jpk + DO jj = kj1, kj2 + DO ji = 1, jpi + zcoef = 0.5 - SIGN( 0.5_wp, zdn2dz(ji,jj,jk) ) ! =0 if dN2/dz > 0, =1 otherwise + ztpc = zempba_3d_1(ji,jj,jk) * zsum1(ji,jj) * zcoef & + & + zempba_3d_2(ji,jj,jk) * zsum2(ji,jj) * ( 1. - zcoef ) + ! + zempba_3d(ji,jj,jk) = ztpc + zsum (ji,jj) = zsum(ji,jj) + ztpc * e3w_n(ji,jj,jk) + END DO + END DO + END DO + DO jj = kj1, kj2 + DO ji = 1, jpi + IF( zsum(ji,jj) > 0.e0 ) zsum(ji,jj) = 1.e0 / zsum(ji,jj) + END DO + END DO + + ! ! first estimation bounded by 10 cm2/s (with n2 bounded by rn_n2min) + zcoef = rn_tfe_itf / ( rn_tfe * rau0 ) + DO jk = 1, jpk + zavt_itf(:,kj1:kj2,jk) = MIN( 10.e-4, zcoef * en_tmx(:,kj1:kj2) * zsum(:,kj1:kj2) * zempba_3d(:,kj1:kj2,jk) & + & / MAX( rn_n2min, rn2(:,kj1:kj2,jk) ) * tmask(:,kj1:kj2,jk) ) + END DO + + zkz(:,kj1:kj2) = 0.e0 ! Associated potential energy consummed over the whole water column + DO jk = 2, jpkm1 + zkz(:,kj1:kj2) = zkz(:,kj1:kj2) + e3w_n(:,kj1:kj2,jk) * MAX( 0.e0, rn2(:,kj1:kj2,jk) ) * rau0 * zavt_itf(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk-1) + END DO + + DO jj = kj1, kj2 ! Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx + DO ji = 1, jpi + IF( zkz(ji,jj) /= 0.e0 ) zkz(ji,jj) = en_tmx(ji,jj) * rn_tfe_itf / rn_tfe / zkz(ji,jj) + END DO + END DO + + DO jk = 2, jpkm1 ! Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zavt_itf bound by 300 cm2/s + zavt_itf(:,kj1:kj2,jk) = zavt_itf(:,kj1:kj2,jk) * MIN( zkz(:,kj1:kj2), 120./10. ) * tmask(:,kj1:kj2,jk) * tmask(:,kj1:kj2,jk-1) ! kz max = 120 cm2/s + END DO + + IF( kt == nit000 ) THEN ! diagnose the nergy consumed by zavt_itf + !$omp barrier + !$omp master + DO jk= 1, jpk + DO jj= 1, jpj + DO ji= 1, jpi + ptpc3d(ji,jj,jk) = e1t(ji,jj) * e2t(ji,jj) * e3w_n(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) ) & + & * zavt_itf(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) + END DO + END DO + END DO + ztpc = glob_sum( 'zdf_tmx', ptpc3d ) + ztpc = rau0 * ztpc / ( rn_me * rn_tfe_itf ) + IF(lwp) WRITE(numout,*) ' N Total power consumption by zavt_itf: ztpc = ', ztpc * 1.e-12 ,'TW' + !$omp end master + !$omp barrier + ENDIF + + ! ! Update pav with the ITF mixing coefficient + DO jk = 2, jpkm1 + pav(:,kj1:kj2,jk) = pav (:,kj1:kj2,jk) * ( 1.e0 - mask_itf(:,kj1:kj2) ) & + & + zavt_itf(:,kj1:kj2,jk) * mask_itf(:,kj1:kj2) + END DO + ! + IF( ln_timing_detail .AND. ktid == 0 ) CALL timing_stop('tmx_itf') + ! + END SUBROUTINE tmx_itf + + + SUBROUTINE zdf_tmx_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tmx_init *** + !! + !! ** Purpose : Initialization of the vertical tidal mixing, Reading + !! of M2 and K1 tidal energy in nc files + !! + !! ** Method : - Read the namtmx namelist and check the parameters + !! + !! - Read the input data in NetCDF files : + !! M2 and K1 tidal energy. The total tidal energy, en_tmx, + !! is the sum of M2, K1 and S2 energy where S2 is assumed + !! to be: S2=(1/2)^2 * M2 + !! mask_itf, a mask array that determine where substituing + !! the standard Simmons et al. (2005) formulation with the + !! one of Koch_Larrouy et al. (2007). + !! + !! - Compute az_tmx, a 3D coefficient that allows to compute + !! the standard tidal-induced vertical mixing as follows: + !! Kz_tides = az_tmx / max( rn_n2min, N^2 ) + !! with az_tmx a bottom intensified coefficient is given by: + !! az_tmx(z) = en_tmx / ( rau0 * rn_htmx ) * EXP( -(H-z)/rn_htmx ) + !! / ( 1. - EXP( - H /rn_htmx ) ) + !! where rn_htmx the characteristic length scale of the bottom + !! intensification, en_tmx the tidal energy, and H the ocean depth + !! + !! ** input : - Namlist namtmx + !! - NetCDF file : M2_ORCA2.nc, K1_ORCA2.nc, and mask_itf.nc + !! + !! ** Action : - Increase by 1 the nstop flag is setting problem encounter + !! - defined az_tmx used to compute tidal-induced mixing + !! + !! References : Simmons et al. 2004, Ocean Modelling, 6, 3-4, 245-263. + !! Koch-Larrouy et al. 2007, GRL. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local integer + INTEGER :: ios + REAL(wp) :: ztpc, ze_z ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zem2, zek1 ! read M2 and K1 tidal energy + REAL(wp), DIMENSION(jpi,jpj) :: zkz ! total M2, K1 and S2 tidal energy + REAL(wp), DIMENSION(jpi,jpj) :: zfact ! used for vertical structure function + REAL(wp), DIMENSION(jpi,jpj) :: zhdep ! Ocean depth + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpc ! power consumption + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zav_tide ! tidal mixing coefficient + !! + NAMELIST/namzdf_tmx/ rn_htmx, rn_n2min, rn_tfe, rn_me, ln_tmx_itf, rn_tfe_itf + !!---------------------------------------------------------------------- + ! + + REWIND( numnam_ref ) ! Namelist namzdf_tmx in reference namelist : Tidal Mixing + READ ( numnam_ref, namzdf_tmx, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_tmx in configuration namelist : Tidal Mixing + READ ( numnam_cfg, namzdf_tmx, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_tmx ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_tmx_init : tidal mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_tmx : set tidal mixing parameters' + WRITE(numout,*) ' Vertical decay scale for turbulence = ', rn_htmx + WRITE(numout,*) ' Brunt-Vaisala frequency threshold = ', rn_n2min + WRITE(numout,*) ' Tidal dissipation efficiency = ', rn_tfe + WRITE(numout,*) ' Mixing efficiency = ', rn_me + WRITE(numout,*) ' ITF specific parameterisation = ', ln_tmx_itf + WRITE(numout,*) ' ITF tidal dissipation efficiency = ', rn_tfe_itf + ENDIF + + ! ! allocate tmx arrays + IF( zdf_tmx_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) + + IF( ln_tmx_itf ) THEN ! read the Indonesian Through Flow mask + CALL iom_open('mask_itf',inum) + CALL iom_get (inum, jpdom_data, 'tmaskitf',mask_itf,1) ! + CALL iom_close(inum) + ENDIF + + ! read M2 tidal energy flux : W/m2 ( zem2 < 0 ) + CALL iom_open('M2rowdrg',inum) + CALL iom_get (inum, jpdom_data, 'field',zem2,1) ! + CALL iom_close(inum) + + ! read K1 tidal energy flux : W/m2 ( zek1 < 0 ) + CALL iom_open('K1rowdrg',inum) + CALL iom_get (inum, jpdom_data, 'field',zek1,1) ! + CALL iom_close(inum) + + ! Total tidal energy ( M2, S2 and K1 with S2=(1/2)^2 * M2 ) + ! only the energy available for mixing is taken into account, + ! (mixing efficiency tidal dissipation efficiency) + en_tmx(:,:) = - rn_tfe * rn_me * ( zem2(:,:) * 1.25 + zek1(:,:) ) * ssmask(:,:) + +!============ +!TG: Bug for VVL? Should this section be moved out of _init and be updated at every timestep? + ! Vertical structure (az_tmx) + 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 * rn_htmx * ( 1. - EXP( -zhdep(ji,jj) / rn_htmx ) ) + IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = en_tmx(ji,jj) / zfact(ji,jj) + END DO + END DO + DO jk= 1, jpk ! complete with the level-dependent part + DO jj = 1, jpj + DO ji = 1, jpi + az_tmx(ji,jj,jk) = zfact(ji,jj) * EXP( -( zhdep(ji,jj)-gdepw_0(ji,jj,jk) ) / rn_htmx ) * tmask(ji,jj,jk) + END DO + END DO + END DO +!=========== + + IF( nprint == 1 .AND. lwp ) THEN + ! Control print + ! Total power consumption due to vertical mixing + ! zpc = rau0 * 1/rn_me * rn2 * zav_tide + zav_tide(:,:,:) = 0.e0 + DO jk = 2, jpkm1 + zav_tide(:,:,jk) = az_tmx(:,:,jk) / MAX( rn_n2min, rn2(:,:,jk) ) + END DO + + ztpc = 0.e0 + zpc(:,:,:) = MAX(rn_n2min,rn2(:,:,:)) * zav_tide(:,:,:) + DO jk= 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ztpc = ztpc + e3w_0(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) + END DO + END DO + END DO + ztpc= rau0 * 1/(rn_tfe * rn_me) * ztpc + + WRITE(numout,*) + WRITE(numout,*) ' Total power consumption of the tidally driven part of Kz : ztpc = ', ztpc * 1.e-12 ,'TW' + + + ! control print 2 + zav_tide(:,:,:) = MIN( zav_tide(:,:,:), 60.e-4 ) + zkz(:,:) = 0.e0 + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zkz(ji,jj) = zkz(ji,jj) + e3w_0(ji,jj,jk) * MAX(0.e0, rn2(ji,jj,jk)) * rau0 * zav_tide(ji,jj,jk) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz + DO jj = 1, jpj + DO ji = 1, jpi + IF( zkz(ji,jj) /= 0.e0 ) THEN + zkz(ji,jj) = en_tmx(ji,jj) / zkz(ji,jj) + ENDIF + END DO + END DO + ztpc = HUGE(ztpc) + DO jj = 1, jpj + DO ji = 1, jpi + IF( zkz(ji,jj) /= 0.e0 ) THEN + ztpc = Min( zkz(ji,jj), ztpc) + ENDIF + END DO + END DO + WRITE(numout,*) ' Min de zkz ', ztpc, ' Max = ', maxval(zkz(:,:) ) + + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk) !kz max = 300 cm2/s + END DO + END DO + END DO + ztpc = 0.e0 + zpc(:,:,:) = Max(0.e0,rn2(:,:,:)) * zav_tide(:,:,:) + DO jk= 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + ztpc = ztpc + e3w_0(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) + END DO + END DO + END DO + ztpc= rau0 * 1/(rn_tfe * rn_me) * ztpc + WRITE(numout,*) ' 2 Total power consumption of the tidally driven part of Kz : ztpc = ', ztpc * 1.e-12 ,'TW' + + DO jk = 1, jpk + ze_z = SUM( e1t(:,:) * e2t(:,:) * zav_tide(:,:,jk) * tmask_i(:,:) ) & + & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) + ztpc = HUGE(ztpc) + DO jj = 1, jpj + DO ji = 1, jpi + IF( zav_tide(ji,jj,jk) /= 0.e0 ) ztpc =Min( ztpc, zav_tide(ji,jj,jk) ) + END DO + END DO + WRITE(numout,*) ' N2 min - jk= ', jk,' ', ze_z * 1.e4,' cm2/s min= ',ztpc*1.e4, & + & 'max= ', MAXVAL(zav_tide(:,:,jk) )*1.e4, ' cm2/s' + END DO + + WRITE(numout,*) ' e_tide : ', SUM( e1t*e2t*en_tmx ) / ( rn_tfe * rn_me ) * 1.e-12, 'TW' + WRITE(numout,*) + WRITE(numout,*) ' Initial profile of tidal vertical mixing' + DO jk = 1, jpk + DO jj = 1,jpj + DO ji = 1,jpi + zkz(ji,jj) = az_tmx(ji,jj,jk) /MAX( rn_n2min, rn2(ji,jj,jk) ) + END DO + END DO + ze_z = SUM( e1t(:,:) * e2t(:,:) * zkz(:,:) * tmask_i(:,:) ) & + & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) + WRITE(numout,*) ' jk= ', jk,' ', ze_z * 1.e4,' cm2/s' + END DO + DO jk = 1, jpk + zkz(:,:) = az_tmx(:,:,jk) /rn_n2min + ze_z = SUM( e1t(:,:) * e2t(:,:) * zkz(:,:) * tmask_i(:,:) ) & + & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) + WRITE(numout,*) + WRITE(numout,*) ' N2 min - jk= ', jk,' ', ze_z * 1.e4,' cm2/s min= ',MINVAL(zkz)*1.e4, & + & 'max= ', MAXVAL(zkz)*1.e4, ' cm2/s' + END DO + ! + ENDIF + ! + END SUBROUTINE zdf_tmx_init + + !!====================================================================== +END MODULE zdftmx diff --git a/V4.0/nemo_sources/src/OCE/lib_cray.f90 b/V4.0/nemo_sources/src/OCE/lib_cray.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9d01cf7f671ce030e2a3abfc7b5ca706fd2d5d29 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/lib_cray.f90 @@ -0,0 +1,36 @@ +! 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: lib_cray.f90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! 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 ) + USE par_kind, ONLY : dp, wp + + IMPLICIT NONE + + INTEGER , INTENT ( in ) :: i, j + INTEGER , INTENT ( out ) :: nn + REAL(wp) , INTENT ( in ), DIMENSION (1+(i-1)*j) :: x + REAL(wp) , 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/lib_fortran.F90 b/V4.0/nemo_sources/src/OCE/lib_fortran.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4a2eabe8a16f833108f6cb05c92563865b9a8f68 --- /dev/null +++ b/V4.0/nemo_sources/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: lib_fortran.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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(dp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied + COMPLEX(dp) :: local_sum_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ipi, ipj ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + ! + local_sum_2d = ctmp + + END FUNCTION local_sum_2d + + FUNCTION local_sum_3d( ptab ) + !!---------------------------------------------------------------------- + REAL(dp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied + COMPLEX(dp) :: local_sum_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + ! + local_sum_3d = ctmp + + END FUNCTION local_sum_3d + +! ! FUNCTION sum3x3 ! + + SUBROUTINE sum3x3_2d( p2d ) + !!----------------------------------------------------------------------- + !! *** routine sum3x3_2d *** + !! + !! ** Purpose : sum over 3x3 boxes + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION (:,:), INTENT(inout) :: p2d + ! + INTEGER :: ji, ji2, jj, jj2 ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) + IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) + ! + 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.0_wp ) + 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.0_wp ) + + 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.0_wp ) + 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.0_wp ) + + 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(dp), INTENT(in ) :: ydda + COMPLEX(dp), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + !!----------------------------------------------------------------------- + ! + ! Compute ydda + yddb using Knuth's trick. + zt1 = REAL(ydda) + REAL(yddb) + zerr = zt1 - REAL(ydda) + zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) & + & + AIMAG(ydda) + AIMAG(yddb) + ! + ! The result is t1 + t2, after normalization. + yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), dp ) + ! + END SUBROUTINE DDPDD + +#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/V4.0/nemo_sources/src/OCE/lib_fortran_generic.h90 b/V4.0/nemo_sources/src/OCE/lib_fortran_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..416d9ae604482533f160af0402d05eb0c5c5e70b --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/lib_fortran_generic.h90 @@ -0,0 +1,163 @@ +#if defined GLOBSUM_CODE +! ! FUNCTION FUNCTION_GLOBSUM ! +# if defined DIM_1d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i) +# define ARRAY2_IN(i,j,k) ptab2(i) +# define J_SIZE(ptab) 1 +# define K_SIZE(ptab) 1 +# define MASK_ARRAY(i,j) 1. +# endif +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) SIZE(ptab,3) +# 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(dp) :: FUNCTION_GLOBSUM + ! + !!----------------------------------------------------------------------- + ! + REAL(dp) :: FUNCTION_GLOB_OP ! global sum + !! + COMPLEX(dp):: ctmp + COMPLEX(dp), DIMENSION(:,:), ALLOCATABLE :: ctmp2d + COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp1d + REAL(dp) :: 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 + ! + ALLOCATE( ctmp2d(ipj,ipk), ctmp1d(ipk) ) + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + ! Phase 1: compute sum over each columns/levels (in parallel threads) + !$omp parallel private(jk,jj,ji,ztmp) + DO jk = 1, ipk + !$omp do + DO jj = 1, ipj + ctmp2d(jj,jk) = CMPLX(0e0,0e0,dp) + DO ji = 1, ipi + ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp2d(jj,jk) ) + END DO + END DO + !$omp end do + END DO + ! Phase 2: compute sum of levels sums + !$omp do + DO jk = 1, ipk + ctmp1d(jk) = CMPLX(0e0,0e0,dp) + DO jj = 1, ipj + CALL DDPDD( ctmp2d(jj,jk), ctmp1d(jk) ) + END DO + END DO + !$omp end do + !$omp end parallel + ! Phase 3: compute sum of levels sums serial + DO jk = 1, ipk + CALL DDPDD( ctmp1d(jk), ctmp ) + END DO + + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + DEALLOCATE( ctmp2d, ctmp1d ) + FUNCTION_GLOBSUM = REAL(ctmp,dp) + + 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(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# endif +# if defined OPERATION_GLOBMIN +# define 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(dp) :: FUNCTION_GLOBMINMAX + ! + !!----------------------------------------------------------------------- + ! + REAL(dp) :: FUNCTION_GLOB_OP ! global sum + !! + COMPLEX(dp):: ctmp + REAL(dp) :: 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/V4.0/nemo_sources/src/OCE/module_example b/V4.0/nemo_sources/src/OCE/module_example new file mode 100644 index 0000000000000000000000000000000000000000..b4d3d73e9e2d5875310362c3449c7045daf3772b --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/src/OCE/nemo.f90 b/V4.0/nemo_sources/src/OCE/nemo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a28f804cfe707c9c5781506185fb867bc06c63f8 --- /dev/null +++ b/V4.0/nemo_sources/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: nemo.f90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + ! + CALL nemo_gcm ! NEMO direct code + ! + !!====================================================================== +END PROGRAM nemo \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/nemogcm.F90 b/V4.0/nemo_sources/src/OCE/nemogcm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c0ce954c31563e2101ebfb422a384890e7465ec8 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/nemogcm.F90 @@ -0,0 +1,815 @@ +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 bias ! bias (T,S,SSH) (bias_init routine) + USE biaspar ! bias parameters + 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, ln_sglexe + USE wet_dry ! Wetting and drying setting (wad_init routine) + USE par_kind, ONLY : dp, wp +#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 iom ! xIOserver +#endif +#if defined key_agrif + USE agrif_all_update ! Master Agrif update +#endif +#if defined key_mpp_mpi + USE mpi +#endif +#if defined key_iomput_sglexe + USE mpp_io +#endif + USE nopenmp + USE mppwrite + + IMPLICIT NONE + PRIVATE + + PUBLIC nemo_gcm ! called by model.F90 + PUBLIC nemo_init ! needed by AGRIF + PUBLIC nemo_alloc ! needed by TAM + PUBLIC nemo_closefile ! needed by TAM + + CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 13013 2020-06-03 08:33:06Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE nemo_gcm + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_gcm *** + !! + !! ** Purpose : NEMO solves the primitive equations on an orthogonal + !! curvilinear mesh on the sphere. + !! + !! ** Method : - model general initialization + !! - launch the time-stepping (stp routine) + !! - finalize the run by closing files and communications + !! + !! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL. + !! Madec, 2008, internal report, IPSL. + !!---------------------------------------------------------------------- + INTEGER :: istp ! time step index +#if defined key_iomput_sglexe + INTEGER :: mycomm, irequired, iprovided + LOGICAL :: lioserver +#endif + REAL(wp):: zstptiming ! elapsed time for 1 time step + !!---------------------------------------------------------------------- + ! +#if defined key_agrif + CALL Agrif_Init_Grids() ! AGRIF: set the meshes +#endif +#if defined key_iomput_sglexe + irequired=-1 + iprovided=-1 + CALL mpp_io_init( mycomm, lioserver, irequired, iprovided, .TRUE. ) + mycomm = mpi_comm_world + CALL mpp_io_init_2( mycomm ) + IF (lioserver) THEN + CALL mpp_server_stop() + RETURN + ENDIF + CALL nemo_init( mycomm ) +#else + ! !-----------------------! + CALL nemo_init !== Initialisations ==! + ! !-----------------------! +#endif + IF (ln_mppwrite) THEN + CALL mpp_write + ENDIF +#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_stop( 'nemogcm') + ! + IF( ln_timing ) CALL timing_finalize + ! + CALL nemo_closefile + ! +#if defined key_iomput + CALL iom_finalize ! end mpp communications with xios + IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS +#if defined key_iomput_sglexe + IF( lk_mpp ) CALL mppstop ! end mpp communications +#endif +#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( mycomm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_init *** + !! + !! ** Purpose : initialization of the NEMO GCM + !!---------------------------------------------------------------------- + INTEGER, OPTIONAL :: mycomm + INTEGER :: ios, ilocal_comm ! local integers + INTEGER :: ithreads, itid + INTEGER :: nn_ompopt = 0 + INTEGER :: nn_ompht = 2 + INTEGER :: nomplats + LOGICAL :: ln_write_domains = .FALSE. + INTEGER :: inum + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: rdom ! 2D workspace + !! + NAMELIST/namctl/ ln_ctl , sn_cfctl, nn_print, nn_ictls, nn_ictle, & + & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & + & ln_timing, ln_diacfl, ln_timing_detail, & + & ln_smslabel, cn_smslabel, cn_smsevent, nn_smsfrq, & + & ln_sglread, ln_sglwrite, ln_timing_onefile, & + & ln_timing_barrier, ln_timing_check, nn_ompopt, & + & nn_ompht, ln_write_domains, ln_diawri_instant, & + & ln_diawri_full, cn_diawri_outdir, ln_mppwrite, & + & ln_mppwrite_abt, ln_nemostat + 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 defined key_iomput_sglexe + IF (PRESENT(mycomm)) THEN + ilocal_comm = mycomm + CALL mpp_start( ilocal_comm ) + ELSE + WRITE(0,*)'Communicator mycomm missing' + CALL abort + ENDIF +#else + IF( Agrif_Root() ) THEN + IF( lk_oasis ) THEN + CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis + CALL iom_initialize( "not used" ,local_comm= ilocal_comm ) ! send nemo communicator to xios + ELSE + CALL iom_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) ! nemo local communicator given by xios + ENDIF + ENDIF + CALL mpp_start( ilocal_comm ) +#endif +#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 + IF ( PRESENT( mycomm ) ) THEN + ilocal_comm = mycomm + CALL mpp_start( ilocal_comm ) + ELSE + CALL mpp_start( ) + ENDIF + 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., cdact='READ' ) + CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., cdact='READ' ) + 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( ln_sglexe ) THEN + numnul = 0 + ELSEIF( 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,*) + + ! Print the working precision to ocean.output + IF (wp == dp) THEN + WRITE(numout,*) "Working precision = double-precision" + ELSE + WRITE(numout,*) "Working precision = single-precision" + ENDIF + 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 + ! + nompopt = nn_ompopt + nompht = MAX( nn_ompht, 1 ) + !$omp parallel private(ithreads,itid,nomplats) + CALL nompinfo( itid, ithreads ) + !$omp master + CALL nompsetstaend( ithreads, 0, jpi*jpj ) + !$omp end master + !$omp barrier + nomplats = nompends(itid,jpj) - nompstas(itid,jpj) + 1 + IF (lwp) WRITE(numout,*)'thread ',itid,' of ',ithreads,& + & ' nompstas(itid,jpj) = ',nompstas(itid,jpj),& + & ' nompends(itid,jpj) ',nompends(itid,jpj),' nlats = ', nomplats + IF ( nomplats < 0 ) THEN + WRITE(0,*)'thread ',itid,' of ',ithreads,& + & ' nompstas(itid,jpj) = ',nompstas(itid,jpj),& + & ' nompends(itid,jpj) ',nompends(itid,jpj),' nlats = ', nomplats + CALL ctl_stop('Too few latitudes per OpenMP thread') + ENDIF + !$omp end parallel + ! + ! 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( 'nemogcm') + 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) + + ! ! Ocean physics 1 + CALL zdf_phy_init ! Vertical physics + ! ! external forcing + CALL tide_init ! tidal harmonics + CALL sbc_init ! surface boundary conditions (including sea-ice) + CALL bdy_init ! Open boundaries initialisation + + ! ! Ocean physics 2 + ! ! Lateral physics + 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( ln_traqsr ) CALL tra_qsr_init ! penetrative solar radiation qsr + CALL tra_bbc_init ! bottom heat flux + CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme + CALL tra_dmp_init ! internal tracer damping + CALL tra_adv_init ! horizontal & vertical advection + CALL tra_ldf_init ! lateral mixing + + ! ! Dynamics + IF( 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 + CALL bias_init ! Initialize bias options + ! + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + ! Write domain information using IOM + ! + IF (ln_write_domains) THEN + ALLOCATE( rdom(jpi,jpj) ) + CALL iom_open ( 'domains', inum, ldwrt = .TRUE. ) + rdom(:,:) = REAL(narea,wp) + CALL iom_rstput( 0, 0, inum, 'narea', rdom ) + rdom(:,:) = REAL(nproc,wp) + CALL iom_rstput( 0, 0, inum, 'nproc', rdom ) + CALL iom_close ( inum ) + DEALLOCATE( rdom ) + ENDIF + ! + ! Write mpp output + ! + IF (ln_mppwrite) THEN + CALL mpp_write + ENDIF + ! + 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 + WRITE(numout,*) ' Create nemo.stat file ln_nemostat= ', ln_nemostat + 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( numstat /= -1 ) CLOSE( numstat ) ! nemo.stat 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, INTENT(IN) :: 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/nopenmp.F90 b/V4.0/nemo_sources/src/OCE/nopenmp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..69354cb092ff58a70633ad00d8a4c23f321fa3ea --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/nopenmp.F90 @@ -0,0 +1,102 @@ +MODULE nopenmp + + !$ USE omp_lib + IMPLICIT NONE + PUBLIC + INTEGER, SAVE :: nompthreads + INTEGER, SAVE :: nompminval + INTEGER, SAVE :: nompmaxval + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:,:) :: nompstas + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:,:) :: nompends + INTEGER, SAVE :: nompopt = 0 + INTEGER, SAVE :: nompht = 2 +CONTAINS + + SUBROUTINE nompinfo( ktid, kthreads ) + + INTEGER, INTENT(out) :: ktid, kthreads + + ktid = 0 + kthreads = 1 + !$ ktid = omp_get_thread_num() + !$ kthreads = omp_get_num_threads() + + END SUBROUTINE nompinfo + + SUBROUTINE nompsetstaend( kthreads, kminval, kmaxval ) + + INTEGER, INTENT(in) :: kthreads, kminval, kmaxval + INTEGER :: jk, jt, jh, jjsize, jjmiss + INTEGER, DIMENSION(kthreads) :: jjsizes + + nompthreads = kthreads + nompminval = kminval + nompmaxval = kmaxval + + ALLOCATE( & + & nompstas(0:nompthreads-1,nompminval:nompmaxval), & + & nompends(0:nompthreads-1,nompminval:nompmaxval) & + & ) + + IF ( nompopt == 0 ) THEN + DO jk = kminval, kmaxval + jjsize = jk/nompthreads + IF ( jjsize * nompthreads < jk ) jjsize = jjsize + 1 + DO jt = 1, nompthreads + nompstas(jt-1,jk) = ( jt -1 ) * jjsize + 1 + nompends(jt-1,jk) = MIN( jt * jjsize, jk ) + ENDDO + ENDDO + ELSEIF ( nompopt == 1 ) THEN + DO jk = kminval, kmaxval + jjsize = jk/nompthreads + jjmiss = jk - jjsize * nompthreads + DO jt = 1, nompthreads + IF ( jt <= jjmiss ) THEN + jjsizes(jt) = jjsize + 1 + ELSE + jjsizes(jt) = jjsize + ENDIF + ENDDO + DO jt = 1, nompthreads + IF (jt==1) THEN + nompstas(jt-1,jk) = 1 + nompends(jt-1,jk) = jjsizes(jt) + ELSE + nompstas(jt-1,jk) = nompends(jt-2,jk)+1 + nompends(jt-1,jk) = nompends(jt-2,jk)+jjsizes(jt) + ENDIF + ENDDO + ENDDO + ELSEIF ( nompopt == 2 ) THEN + DO jk = kminval, kmaxval + jjsize = jk/nompthreads + jjmiss = jk - jjsize * nompthreads + DO jh = 1, nompht + DO jt = jh, nompthreads, nompht + IF ( jjmiss > 0 ) THEN + jjsizes(jt) = jjsize + 1 + jjmiss = jjmiss - 1 + ELSE + jjsizes(jt) = jjsize + ENDIF + ENDDO + ENDDO + DO jt = 1, nompthreads + IF (jt==1) THEN + nompstas(jt-1,jk) = 1 + nompends(jt-1,jk) = jjsizes(jt) + ELSE + nompstas(jt-1,jk) = nompends(jt-2,jk)+1 + nompends(jt-1,jk) = nompends(jt-2,jk)+jjsizes(jt) + ENDIF + ENDDO + ENDDO + ELSE + WRITE(0,*)'Unknown option in nompsetstaend' + CALL abort + ENDIF + + END SUBROUTINE nompsetstaend + +END MODULE nopenmp \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/oce.F90 b/V4.0/nemo_sources/src/OCE/oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..03153d190f69d2c2ae86cf66fc18ccde0ddbbc3f --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/oce.F90 @@ -0,0 +1,129 @@ +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!: i-horizontal velocity [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ua!: i-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vb, vn!: j-horizontal velocity [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: va!: j-horizontal velocity [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn !: vertical velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivn !: horizontal divergence [s-1] + REAL(dp), 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(dp), 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(:,:) :: vn_b!: Barotropic velocities at v-point [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vb_b, va_b!: Barotropic velocities at v-point [m/s] + REAL(dp), 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, va_e!: v-external velocity + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vb_e, vn_e!: v-external velocity + REAL(dp), 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b!: Half step fluxes (ln_bt_fw=T) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spgu, spgv !: horizontal surface pressure gradient + + !! interpolated gradient (only used in zps case) + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu!: horizontal gradient of T, S bottom u-point + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsv!: horizontal gradient of T, S bottom u-point + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point + + !! (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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload + + !! Energy budget of the leads (open water embedded in sea ice) + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! 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) ) + hdivn(:,:,:) = 0.0_wp + ! + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/par_kind.F90 b/V4.0/nemo_sources/src/OCE/par_kind.F90 new file mode 100644 index 0000000000000000000000000000000000000000..20ee96d12e53234ba6eee2944b2b09abbe84fb4e --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/par_kind.F90 @@ -0,0 +1,44 @@ +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) +# if defined key_single + INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision +# else + INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision +# endif + + ! !!** 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: par_kind.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +END MODULE par_kind \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/par_oce.F90 b/V4.0/nemo_sources/src/OCE/par_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..97ad7ba5f2af12585808332265187ec0f44f5aee --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/par_oce.F90 @@ -0,0 +1,85 @@ +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 :: jpni_inp = 0 !: input number of processors following i + INTEGER, PUBLIC :: jpnj_inp = 0 !: input 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: par_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE par_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/single_precision_substitute.h90 b/V4.0/nemo_sources/src/OCE/single_precision_substitute.h90 new file mode 100644 index 0000000000000000000000000000000000000000..2c4ce4558d4fe604c64f9524154365fb97722e61 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/single_precision_substitute.h90 @@ -0,0 +1,7 @@ +#if defined key_single +# define CASTSP(x) REAL(x,sp) +# define CASTDP(x) REAL(x,dp) +#else +# define CASTSP(x) x +# define CASTDP(x) x +#endif \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/step.F90 b/V4.0/nemo_sources/src/OCE/step.F90 new file mode 100644 index 0000000000000000000000000000000000000000..348e03afbb9216977d3d01cc56fedc77893cb963 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/step.F90 @@ -0,0 +1,376 @@ +MODULE step + !!====================================================================== + !! *** MODULE step *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! - ! 1991-11 (G. Madec) + !! - ! 1992-06 (M. Imbard) add a first output record + !! - ! 1996-04 (G. Madec) introduction of dynspg + !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer + !! 8.0 ! 1997-06 (G. Madec) new architecture of call + !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface + !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit + !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions + !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme + !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls + !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-07 (S. Masson) restart using iom + !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate + !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs + !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state + !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves + !! 3.7 ! 2014-10 (G. Madec) LDF simplication + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) + !! 4.0 ! 2022-05 (H. Zuo) reintroducing ECMWF bias correction from V3.4 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! stp : OPA system time-stepping + !!---------------------------------------------------------------------- + USE step_oce ! time stepping definition modules + USE biaspar ! bias param + USE bias ! bias routines (tra_bias routine) + ! + USE iom ! xIOs server + + IMPLICIT NONE + PRIVATE + + PUBLIC stp ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step.F90 12859 2020-05-03 09:33:32Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_agrif + RECURSIVE SUBROUTINE stp( ) + INTEGER :: kstp ! ocean time-step index +#else + SUBROUTINE stp( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index +#endif + !!---------------------------------------------------------------------- + !! *** ROUTINE stp *** + !! + !! ** 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 + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, hdiv,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indice +!!gm kcall can be removed, I guess + INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) + CHARACTER(len=2048) :: clsmscmd ! Command to sms + CHARACTER(len=12) :: clstp, clend + INTEGER :: cmdstat ! needed if asyncronous system calls not supported + !! --------------------------------------------------------------------- +#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(*,*) '---' + IF(lwp) WRITE(*,*) 'Grid Number', Agrif_Fixed(),' time step ', kstp, 'int tstep', Agrif_NbStepint() + ENDIF + IF( kstp == nit000 + 1 ) lk_agrif_fstep = .FALSE. +# if defined key_iomput + IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) +# endif +#endif +#if defined key_sms + ! SMS/ecflow updating status + IF (ln_smslabel) THEN + IF ( narea == 1 ) THEN + IF ( MOD(kstp,nn_smsfrq) == 0 ) THEN + WRITE(clstp,'(I12)') kstp - nit000 + 1 + WRITE(clend,'(I12)') nitend - nit000 + 1 + WRITE(clsmscmd,'(A)')TRIM(cn_smslabel)//' step '// & + & TRIM(ADJUSTL(clstp))//'/'//& + & TRIM(ADJUSTL(clend)) + CALL EXECUTE_COMMAND_LINE( TRIM(clsmscmd) , WAIT=.FALSE., CMDSTAT=cmdstat ) + ENDIF + ENDIF + ENDIF +#endif + ! + IF( ln_timing ) CALL timing_start('stp') + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! update I/O and calendar + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS) + CALL iom_init( cxios_context ) ! for model grid (including passible AGRIF zoom) + IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid + ENDIF + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp + IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell IOM we are at time step kstp + + IF( ln_bias ) CALL bias_opn( kstp ) ! Open output bias restart file + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update external forcing (tides, open boundaries, and surface boundary condition (including sea-ice) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_timing_detail ) CALL timing_start('stp_sbc') + 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, kt_offset = +1 ) ! update dynamic & tracer data at open boundaries + CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) + IF( ln_timing_detail ) CALL timing_stop('stp_sbc') + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update stochastic parameters and random T/S fluctuations + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters + IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean physics update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! THERMODYNAMICS + IF( ln_timing_detail ) CALL timing_start('stp_thermodyn') + 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 + IF( ln_timing_detail ) CALL timing_stop('stp_thermodyn') + + ! VERTICAL PHYSICS + IF( ln_timing_detail ) CALL timing_start('stp_vertical') + CALL zdf_phy( kstp ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD) + IF( ln_timing_detail ) CALL timing_stop('stp_vertical') + + ! LATERAL PHYSICS + IF( ln_timing_detail ) CALL timing_start('stp_lateral') + ! + IF( l_ldfslp ) THEN ! slope of lateral mixing + CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density + + IF( ln_zps .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kstp, 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. ln_isfcav) & + & CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level + IF( ln_traldf_triad ) THEN + CALL ldf_slp_triad( kstp ) ! before slope for triad operator + ELSE + CALL ldf_slp ( kstp, rhd, rn2b ) ! before slope for standard operator + ENDIF + ENDIF + ! ! 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. + IF( ln_timing_detail ) CALL timing_stop('stp_lateral') + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean dynamics : hdiv, ssh, e3, u, v, w + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + IF( ln_timing_detail ) CALL timing_start('stp_oceandyn') + 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 + CALL wzv ( kstp ) ! now cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp ) ! Adaptive-implicit vertical advection partitioning + IF( ln_bias ) CALL bias_upd ( kstp ) ! estimate bias terms on tracers + IF( ln_bias ) CALL dyn_bias ( kstp ) ! bias terms for pressure correction + + CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation + + + ua(:,:,:) = 0._wp ! set dynamics trends to zero + va(:,:,:) = 0._wp + + IF( lk_asminc .AND. ln_asmiau .AND. ln_dyninc ) & + & CALL dyn_asm_inc ( kstp ) ! apply dynamics assimilation increment + IF( ln_bkgwri ) CALL asm_bkg_wri( kstp ) ! output background fields + IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp ) ! bdy damping trends +#if defined key_agrif + IF(.NOT. Agrif_Root()) & + & CALL Agrif_Sponge_dyn ! momentum sponge +#endif + 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 + + ! With split-explicit free surface, since now transports have been updated and ssha as well + 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 + 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 + IF( ln_timing_detail ) CALL timing_stop('stp_oceandyn') + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! cool skin + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF ( ln_diurnal ) CALL stp_diurnal( kstp ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! diagnostics and outputs + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_timing_detail ) CALL timing_start('stp_diag') + 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_wri ( kstp ) ! ocean model: outputs + ! + IF( ln_crs ) CALL crs_fld ( kstp ) ! ocean model: online field coarsening & output + IF( ln_timing_detail ) CALL timing_stop('stp_diag') + + IF( ln_timing_detail ) CALL timing_start('stp_tracers') +#if defined key_top + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Passive Tracer Model + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL trc_stp ( kstp ) ! time-stepping +#endif + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + tsa(:,:,:,:) = 0._wp ! set tracer trends to zero + + IF( lk_asminc .AND. ln_asmiau .AND. & + & ln_trainc ) CALL tra_asm_inc ( kstp ) ! apply tracer assimilation increment + 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( 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( ln_bias ) CALL tra_bias ( kstp ) ! apply bias terms on tracers +#if defined key_agrif + IF(.NOT. Agrif_Root()) & + & 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 + + CALL tra_zdf ( kstp ) ! vertical mixing and after tracer fields + IF( ln_zdfnpc ) CALL tra_npc ( kstp ) ! update after fields by non-penetrative convection + IF( ln_timing_detail ) CALL timing_stop('stp_tracers') + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Set boundary conditions and Swap + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap +!! (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields. +!! If so: +!! (i) no need to call agrif update at initialization time +!! (ii) no need to update "before" fields +!! +!! Apart from creating new tra_swp/dyn_swp routines, this however: +!! (i) makes boundary conditions at initialization time computed from updated fields which is not the case between +!! two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation", +!! e.g. a shift of the feedback interface inside child domain. +!! (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same +!! place. +!! + IF( ln_timing_detail ) CALL timing_start('stp_nxt') +!!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 (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_timing_detail ) CALL timing_stop('stp_nxt') + +!!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( lrst_biasw ) CALL bias_wrt ( kstp ) ! write output for bias restart + IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF recursive integration + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL Agrif_Integrate_ChildGrids( stp ) ! allows to finish all the Child Grids before updating +#endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + 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 +#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 .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges + ! +#if defined key_iomput + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! 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( ln_timing ) CALL timing_stop('stp') + ! + END SUBROUTINE stp + ! + !!====================================================================== +END MODULE step \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/step_oce.F90 b/V4.0/nemo_sources/src/OCE/step_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0e76d7d842dca2e329e4966b2158460016e81120 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/step_oce.F90 @@ -0,0 +1,113 @@ +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 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_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: step_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE step_oce \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/stpctl.F90 b/V4.0/nemo_sources/src/OCE/stpctl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..27058f56391e0f3f4a788b725af72a143dc3bde4 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/stpctl.F90 @@ -0,0 +1,308 @@ +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 timing + USE netcdf ! NetCDF library + USE lib_fortran ! For glob_sum for nemo.stat + 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: stpctl.F90 13137 2020-06-22 06:29:57Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +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(dp) :: zzz ! local real + REAL(dp), 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 + ! + IF( ln_timing ) CALL timing_start('stp_ctl') + 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 + ! ! Optionally create nemo.stat file + IF( lwm .and. ln_nemostat ) CALL ctl_opn( numstat, 'nemo.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! + ENDIF + ! + IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file) + WRITE ( numstp, '(1x, i8)' ) kt +! REWIND( numstp ) + CALL FLUSH( 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(3) = MAXVAL( -tsn(:,:,:,jp_sal) , mask = llmsk ) ! minus salinity max + zmax(4) = MAXVAL( tsn(:,:,:,jp_sal) , mask = llmsk ) ! salinity max + IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file + zmax(5) = MAXVAL( -tsn(:,:,:,jp_tem) , mask = llmsk ) ! minus temperature max + zmax(6) = MAXVAL( tsn(:,:,:,jp_tem) , mask = llmsk ) ! temperature max + IF( ln_zad_Aimp ) THEN + zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! 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(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! 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) , CASTDP(ssmask(:,:)) , zzz, ih(1:2) ) ; ih(3) = 0 + CALL mpp_maxloc( 'stpctl', CASTDP(ABS(un)) , CASTDP(umask (:,:,:)), zzz, iu ) + CALL mpp_minloc( 'stpctl', tsn(:,:,:,jp_sal), CASTDP(tmask (:,:,:)), zzz, is1 ) + CALL mpp_maxloc( 'stpctl', tsn(:,:,:,jp_sal), CASTDP(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(:) = MINLOC( tsn(:,:,:,jp_sal), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) + is2(:) = MAXLOC( tsn(:,:,:,jp_sal), mask = tmask(:,:,:) == 1._wp ) + (/ 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 + ! + ! nemo.stat file + ! + IF( ln_nemostat ) THEN + zzz = glob_sum( 'stp_ctl', sshn(:,:) * tmask_i(:,:) ) / REAL(jpiglo*jpjglo,wp) + IF (lwm) THEN + WRITE(numstat,'(I10,2X,E23.16)') kt, zzz + CALL FLUSH(numstat) + ENDIF + ENDIF + ! +9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) + ! + IF( ln_timing ) CALL timing_stop('stp_ctl') + 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(dp), 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/V4.0/nemo_sources/src/OCE/timing.F90 b/V4.0/nemo_sources/src/OCE/timing.F90 new file mode 100644 index 0000000000000000000000000000000000000000..98caca1ac1680c0ba9f619ef20c06c2617678250 --- /dev/null +++ b/V4.0/nemo_sources/src/OCE/timing.F90 @@ -0,0 +1,1273 @@ +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=60) :: cname + CHARACTER(LEN=60) :: surname + INTEGER :: rank + REAL(dp) :: t_cpu, t_clock, tsum_cpu, tsum_clock, tinc_cpu, tinc_clock, tmax_cpu, tmax_clock, tmin_cpu, tmin_clock, tsub_cpu, tsub_clock + INTEGER :: ncount, ncount_max, ncount_rate + INTEGER :: niter + INTEGER :: maxloc + 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=60), DIMENSION(:), POINTER :: cname => NULL() + REAL(dp), DIMENSION(:), POINTER :: tsum_cpu => NULL() + REAL(dp), DIMENSION(:), POINTER :: tsum_clock => NULL() + REAL(dp), DIMENSION(:), POINTER :: tinc_cpu => NULL() + REAL(dp), DIMENSION(:), POINTER :: tinc_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(dp) :: t_overclock, t_overcpu + LOGICAL :: l_initdone = .FALSE. + INTEGER :: nsize + + ! Variables for coarse grain timing + REAL(dp) :: tot_etime, tot_ctime + REAL(kind=dp), DIMENSION(2) :: t_elaps, t_cpu + REAL(dp), ALLOCATABLE, DIMENSION(:) :: all_etime, all_ctime + INTEGER :: nfinal_count, ncount, ncount_rate, ncount_max + INTEGER, DIMENSION(8) :: nvalues + CHARACTER(LEN=8), DIMENSION(2) :: cdate + CHARACTER(LEN=10), DIMENSION(2) :: ctime + CHARACTER(LEN=5) :: czone + + ! From of ouput file (1/proc or one global) !RB to put in nammpp or namctl + LOGICAL :: ln_onefile = .TRUE. + LOGICAL :: lwriter + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: timing.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 (ln_timing_barrier) THEN + !Uncomment for debugging + !WRITE(1000+nproc,*)'start : ',TRIM(cdinfo) + !CALL flush(1000+nproc) + CALL mppsync() + END IF + 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(dp) :: zcpu_end, zmpitime,zcpu_raw,zclock_raw + ! + IF (ln_timing_barrier) THEN + !Uncomment for debugging + !WRITE(1000+nproc,*)'stop : ',TRIM(cdinfo) + !CALL flush(1000+nproc) + CALL mppsync() + END IF + 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 + ! Optionally check that this is true to catch mismatch start/stop + IF ( ln_timing_check ) THEN + IF (TRIM(s_timer%cname)/=TRIM(cdinfo)) THEN + CALL ctl_stop( 'Timing name mismatch:', & + & 'cname = '//TRIM(s_timer%cname), & + & 'cdinfo = '//TRIM(cdinfo) ) + ENDIF + ENDIF + + ! 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 + s_timer%tinc_clock = s_timer%tinc_clock + zclock_raw + s_timer%tinc_cpu = s_timer%tinc_cpu + zcpu_raw + +!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(dp) :: zdum + LOGICAL :: ll_f + + ln_onefile = ln_timing_onefile + 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(dp), DIMENSION(:), ALLOCATABLE :: timing_glob + REAL(dp) :: zsypd ! simulated years per day (Balaji 2017) + REAL(dp) :: 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 + IF ( timing_glob(4*ji) > 1.0e-6_wp ) THEN + zsypd = rn_rdt * REAL(nitend-nit000-1, dp) / (timing_glob(4*ji) * 365.) + ELSE + zsypd = 0.0_wp + ENDIF + 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 + INTEGER :: ii + REAL(dp) :: zbase + + ! 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,a24,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + ! Supress very small numbers + IF (s_timer%tsum_clock>1.0e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tsum_clock,s_timer%tsum_clock*100./MAX(t_elaps(2),1.0e-8_dp), & + & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./MAX(t_cpu(2),1.0e-8_dp) , & + & s_timer%tsum_cpu/MAX(s_timer%tsum_clock,1.0e-8_dp), s_timer%niter + ENDIF + s_timer => s_timer%next + + END DO + WRITE(numtime,*) + + ! reorder the current list by cpu 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_cpu < s_timer%next%tsum_cpu ) 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 CPU timing for proc :', narea-1 + WRITE(numtime,*) '------------------------------' + WRITE(numtime,*) 'Section ', & + & 'CPU Time (s) ','CPU Time (%) ', & + & 'Elapsed (s) ','ELapsed (%) ','CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a24,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + ! Supress very small numbers + IF (s_timer%tsum_clock>1.0e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./MAX(t_cpu(2),1.0e-8_dp) , & + & s_timer%tsum_clock,s_timer%tsum_clock*100./MAX(t_elaps(2),1.0e-8_dp), & + & s_timer%tsum_cpu/MAX(s_timer%tsum_clock,1.0e-8_dp), s_timer%niter + ENDIF + s_timer => s_timer%next + + END DO + WRITE(numtime,*) + + ! reorder the current list by inclusive 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%tinc_clock < s_timer%next%tinc_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 + + ii=0 + ! write current info + WRITE(numtime,*) 'Inclusive timing for proc :', narea-1 + WRITE(numtime,*) '---------------------------' + WRITE(numtime,*) 'Section ', & + & 'Elapsed Time (s) ','% of total ', & + & 'CPU Time (s) ', 'CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a24,4x,f12.3,6x,f12.3,6x,f12.3,6x,F12.3,6x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + ii=ii+1 + IF (ii==1) zbase=s_timer%tinc_clock + ! Supress very small numbers + IF (s_timer%tinc_clock>1.0e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tinc_clock, & + & s_timer%tinc_clock*100.0_dp/zbase, & + & s_timer%tinc_cpu, & + & s_timer%tinc_cpu/s_timer%tinc_clock, & + & s_timer%niter + ENDIF + s_timer => s_timer%next + END DO + WRITE(numtime,*) + + ii=0 + ! write current info + WRITE(numtime,*) 'Inclusive timing for proc :', narea-1 + WRITE(numtime,*) '---------------------------' + WRITE(numtime,*) 'Section ', & + & 'Elapsed Time (s) ','% of total ', & + & 'CPU Time (s) ', 'CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a24,4x,f12.3,6x,f12.3,6x,f12.3,6x,F12.3,6x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + ii=ii+1 + IF (ii==1) zbase=s_timer%tinc_clock + ! Supress very small numbers + IF (s_timer%tinc_clock>1.0e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tinc_clock, & + & s_timer%tinc_clock*100.0_dp/zbase, & + & s_timer%tinc_cpu, & + & s_timer%tinc_cpu/s_timer%tinc_clock, & + & s_timer%niter + ENDIF + s_timer => s_timer%next + END DO + WRITE(numtime,*) + + ! reorder the current list by inclusive 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%tinc_cpu < s_timer%next%tinc_cpu ) 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 + + ii=0 + ! write current info + WRITE(numtime,*) 'Inclusive CPU time for proc :', narea-1 + WRITE(numtime,*) '-----------------------------' + WRITE(numtime,*) 'Section ', & + & 'CPU time (s) ','% of total ', & + & 'Elapsed Time (s) ', 'CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a24,4x,f12.3,6x,f12.3,6x,f12.3,6x,F12.3,6x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + ii=ii+1 + IF (ii==1) zbase=s_timer%tinc_cpu + ! Supress very small numbers + IF (s_timer%tinc_clock>1.0e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tinc_cpu, & + & s_timer%tinc_cpu*100.0_dp/zbase, & + & s_timer%tinc_clock, & + & s_timer%tinc_cpu/s_timer%tinc_clock , & + & s_timer%niter + ENDIF + 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 + INTEGER :: iloc(1) + + ! 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%tinc_cpu (jpnij), & + sl_timer_glob_root%tinc_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._dp + sl_timer_glob_root%tsum_clock(:) = 0._dp + sl_timer_glob_root%tinc_cpu(:) = 0._dp + sl_timer_glob_root%tinc_clock(:) = 0._dp + 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._dp + sl_timer_ave_root%t_clock = 0._dp + sl_timer_ave_root%tsum_cpu = 0._dp + sl_timer_ave_root%tsum_cpu = 0._dp + sl_timer_ave_root%tinc_clock = 0._dp + sl_timer_ave_root%tinc_clock = 0._dp + sl_timer_ave_root%tmax_cpu = 0._dp + sl_timer_ave_root%tmax_clock = 0._dp + sl_timer_ave_root%tmin_cpu = 0._dp + sl_timer_ave_root%tmin_clock = 0._dp + sl_timer_ave_root%tsub_cpu = 0._dp + sl_timer_ave_root%tsub_clock = 0._dp + 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%maxloc = 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 , 27, MPI_CHARACTER, & + sl_timer_glob%cname, 28, 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%tinc_clock , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tinc_clock, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%tinc_cpu , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tinc_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%tinc_cpu (jpnij)) + ALLOCATE(sl_timer_glob%next%tinc_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%tinc_cpu = SUM (sl_timer_glob%tinc_cpu (:)) / jpnij + sl_timer_ave%tinc_clock = SUM (sl_timer_glob%tinc_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 (:)) + iloc = MAXLOC(sl_timer_glob%tsum_clock(:)) + sl_timer_ave%maxloc = iloc(1) + ! + 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 wall clock 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',19x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & + & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x, & + & 'Max elap(%)',2x,'Min elap(%)',2x, & + & 'Freq ', 2x, 'Max time task')") + 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,2x,i9)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF (sl_timer_ave%tsum_clock>1e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:24), & + & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/MAX(tot_ctime,1.0e-8_dp) , & + & sl_timer_ave%tsum_cpu/MAX(sl_timer_ave%tsum_clock,1.0e-8_dp), & + & sl_timer_ave%tmax_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tmin_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%niter/REAL(jpnij),sl_timer_ave%maxloc-1 + ENDIF + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + + ! reorder the averaged list by maximum wall clock 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%tmax_clock < sl_timer_ave%next%tmax_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(numtime,"('Maximum timing over all MPI tasks :')") + WRITE(numtime,"('-----------------------------------')") + WRITE(numtime,"('Section',19x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & + & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap ',1x, & + & 'Freq ', 2x, 'Max time task')") + 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,2x,i9)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF (sl_timer_ave%tmax_clock>1e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:24), & + & sl_timer_ave%tmax_clock,sl_timer_ave%tmax_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/MAX(tot_ctime,1.0e-8_dp) , & + & sl_timer_ave%tsum_cpu/MAX(sl_timer_ave%tsum_clock,1.0e-8_dp), & + & sl_timer_ave%niter/REAL(jpnij),sl_timer_ave%maxloc-1 + ENDIF + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + ! + ! 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_cpu < sl_timer_ave%next%tsum_cpu ) 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 CPU time on all processors :')") + WRITE(numtime,"('-------------------------------------')") + WRITE(numtime,"('Section',19x,'CPU Time(s)',2x,'CPU Time(%)',4x,'Elap. Time(s)',1x,'Elap. Time(%)',1x,'CPU/Elap')") + 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,2x,i9)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF (sl_timer_ave%tsum_clock>1e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:24), & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/MAX(tot_ctime,1.0e-8_dp) , & + & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tsum_cpu/MAX(sl_timer_ave%tsum_clock,1.0e-8_dp) + ENDIF + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + ! + ! reorder the averaged list by inclusive wall clock 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%tinc_clock < sl_timer_ave%next%tinc_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 inclusive timing on all processors :')") + WRITE(numtime,"('---------------------------------------------')") + WRITE(numtime,"('Section',19x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & + & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x, & + & 'Max elap(%)',2x,'Min elap(%)',2x, & + & 'Freq ', 2x, 'Max time task')") + 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,2x,i9)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF (sl_timer_ave%tsum_clock>1e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:24), & + & sl_timer_ave%tinc_clock,sl_timer_ave%tinc_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tinc_cpu ,sl_timer_ave%tinc_cpu*100.*jpnij/MAX(tot_ctime,1.0e-8_dp) , & + & sl_timer_ave%tinc_cpu/MAX(sl_timer_ave%tinc_clock,1.0e-8_dp), & + & sl_timer_ave%tmax_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tmin_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%niter/REAL(jpnij),sl_timer_ave%maxloc-1 + ENDIF + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + ! + ! reorder the averaged list by inclusive 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%tinc_cpu < sl_timer_ave%next%tinc_cpu ) 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 inclusive CPU time on all processors :')") + WRITE(numtime,"('-----------------------------------------------')") + WRITE(numtime,"('Section',19x,'CPU Time(s)',2x,'CPU Time(%)',4x,'Elap. Time(s)',1x,'Elap. Time(%)',1x,'CPU/Elap')") + 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,2x,i9)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF (sl_timer_ave%tsum_clock>1e-3_dp) THEN + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:24), & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/MAX(tot_ctime,1.0e-8_dp) , & + & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/MAX(tot_etime,1.0e-8_dp), & + & sl_timer_ave%tsum_cpu/MAX(sl_timer_ave%tsum_clock,1.0e-8_dp) + ENDIF + 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(dp) :: ztot_ratio + REAL(dp) :: zmax_etime, zmax_ctime, zmax_ratio, zmin_etime, zmin_ctime, zmin_ratio + REAL(dp) :: zavg_etime, zavg_ctime, zavg_ratio + REAL(dp), 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,dp) + zmax_etime = MAXVAL(all_etime(:)) + zmin_etime = MINVAL(all_etime(:)) + + ! Compute CPU user time + zavg_ctime = tot_ctime/REAL(jpnij,dp) + zmax_ctime = MAXVAL(all_ctime(:)) + zmin_ctime = MINVAL(all_ctime(:)) + + ! Compute cpu/elapsed ratio + zall_ratio(:) = all_ctime(:) / all_etime(:) + ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) + zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,dp) + 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._dp + s_timer_root%t_clock = 0._dp + s_timer_root%tsum_cpu = 0._dp + s_timer_root%tsum_clock = 0._dp + s_timer_root%tinc_cpu = 0._dp + s_timer_root%tinc_clock = 0._dp + s_timer_root%tmax_cpu = 0._dp + s_timer_root%tmax_clock = 0._dp + s_timer_root%tmin_cpu = 0._dp + s_timer_root%tmin_clock = 0._dp + s_timer_root%tsub_cpu = 0._dp + s_timer_root%tsub_clock = 0._dp + 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._dp + s_timer_old%t_clock = 0._dp + s_timer_old%tsum_cpu = 0._dp + s_timer_old%tsum_clock = 0._dp + s_timer_old%tinc_cpu = 0._dp + s_timer_old%tinc_clock = 0._dp + s_timer_old%tmax_cpu = 0._dp + s_timer_old%tmax_clock = 0._dp + s_timer_old%tmin_cpu = 0._dp + s_timer_old%tmin_clock = 0._dp + s_timer_old%tsub_cpu = 0._dp + s_timer_old%tsub_clock = 0._dp + 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._dp + s_timer%next%t_clock = 0._dp + s_timer%next%tsum_cpu = 0._dp + s_timer%next%tsum_clock = 0._dp + s_timer%next%tinc_cpu = 0._dp + s_timer%next%tinc_clock = 0._dp + s_timer%next%tmax_cpu = 0._dp + s_timer%next%tmax_clock = 0._dp + s_timer%next%tmin_cpu = 0._dp + s_timer%next%tmin_clock = 0._dp + s_timer%next%tsub_cpu = 0._dp + s_timer%next%tsub_clock = 0._dp + 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/trc_oce.F90 b/V4.0/nemo_sources/src/OCE/trc_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b59b42084cd604a9f2f2b93b8d87e28a8a848481 --- /dev/null +++ b/V4.0/nemo_sources/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: trc_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OCE/vectopt_loop_substitute.h90 b/V4.0/nemo_sources/src/OCE/vectopt_loop_substitute.h90 new file mode 100644 index 0000000000000000000000000000000000000000..2884f75579c06b69f548d0785d17ab36a9d61c1b --- /dev/null +++ b/V4.0/nemo_sources/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: vectopt_loop_substitute.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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 \ No newline at end of file diff --git a/V4.0/nemo_sources/src/OFF/dtadyn.F90 b/V4.0/nemo_sources/src/OFF/dtadyn.F90 new file mode 100644 index 0000000000000000000000000000000000000000..00ed47ad83fb941916df588f00ea7c4748235891 --- /dev/null +++ b/V4.0/nemo_sources/src/OFF/dtadyn.F90 @@ -0,0 +1,804 @@ +MODULE dtadyn + !!====================================================================== + !! *** MODULE dtadyn *** + !! Off-line : interpolation of the physical fields + !!====================================================================== + !! History : OPA ! 1992-01 (M. Imbard) Original code + !! 8.0 ! 1998-04 (L.Bopp MA Foujols) slopes for isopyc. + !! - ! 1998-05 (L. Bopp) read output of coupled run + !! 8.2 ! 2001-01 (M. Levy et M. Benjelloul) add netcdf FORMAT + !! NEMO 1.0 ! 2005-03 (O. Aumont and A. El Moussaoui) F90 + !! - ! 2005-12 (C. Ethe) Adapted for DEGINT + !! 3.0 ! 2007-06 (C. Ethe) use of iom module + !! 3.3 ! 2010-11 (C. Ethe) Full reorganization of the off-line: phasing with the on-line + !! 3.4 ! 2011-05 (C. Ethe) Use of fldread + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_dyn_init : initialization, namelist read, and SAVEs control + !! dta_dyn : Interpolation of the fields + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE c1d ! 1D configuration: lk_c1d + USE dom_oce ! ocean domain: variables + USE domvvl ! variable volume + USE zdf_oce ! ocean vertical physics: variables + USE sbc_oce ! surface module: variables + USE trc_oce ! share ocean/biogeo variables + USE phycst ! physical constants + USE trabbl ! active tracer: bottom boundary layer + USE ldfslp ! lateral diffusion: iso-neutral slopes + USE sbcrnf ! river runoffs + USE ldftra ! ocean tracer lateral physics + USE zdfmxl ! vertical physics: mixed layer depth + USE eosbn2 ! equation of state - Brunt Vaisala frequency + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE zpshde ! z-coord. with partial steps: horizontal derivatives + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! distributed memory computing library + USE prtctl ! print control + USE fldread ! read input fields + USE timing ! Timing + USE trc, ONLY : ln_rsttr, numrtr, numrtw, lrst_trc + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_dyn_init ! called by opa.F90 + PUBLIC dta_dyn ! called by step.F90 + PUBLIC dta_dyn_sed_init ! called by opa.F90 + PUBLIC dta_dyn_sed ! called by step.F90 + PUBLIC dta_dyn_swp ! called by step.F90 + + CHARACTER(len=100) :: cn_dir !: Root directory for location of ssr files + LOGICAL :: ln_dynrnf !: read runoff data in file (T) or set to zero (F) + LOGICAL :: ln_dynrnf_depth !: read runoff data in file (T) or set to zero (F) + REAL(wp) :: fwbcorr + + + INTEGER , PARAMETER :: jpfld = 20 ! maximum number of fields to read + INTEGER , SAVE :: jf_tem ! index of temperature + INTEGER , SAVE :: jf_sal ! index of salinity + INTEGER , SAVE :: jf_uwd ! index of u-transport + INTEGER , SAVE :: jf_vwd ! index of v-transport + INTEGER , SAVE :: jf_wwd ! index of v-transport + INTEGER , SAVE :: jf_avt ! index of Kz + INTEGER , SAVE :: jf_mld ! index of mixed layer deptht + INTEGER , SAVE :: jf_emp ! index of water flux + INTEGER , SAVE :: jf_empb ! index of water flux + INTEGER , SAVE :: jf_qsr ! index of solar radiation + INTEGER , SAVE :: jf_wnd ! index of wind speed + INTEGER , SAVE :: jf_ice ! index of sea ice cover + INTEGER , SAVE :: jf_rnf ! index of river runoff + INTEGER , SAVE :: jf_fmf ! index of downward salt flux + INTEGER , SAVE :: jf_ubl ! index of u-bbl coef + INTEGER , SAVE :: jf_vbl ! index of v-bbl coef + INTEGER , SAVE :: jf_div ! index of e3t + + + TYPE(FLD), ALLOCATABLE, SAVE, DIMENSION(:) :: sf_dyn ! structure of input fields (file informations, fields read) + ! ! + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uslpdta ! zonal isopycnal slopes + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: vslpdta ! meridional isopycnal slopes + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpidta ! zonal diapycnal slopes + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpjdta ! meridional diapycnal slopes + + INTEGER, SAVE :: nprevrec, nsecdyn + + !!---------------------------------------------------------------------- + !! NEMO/OFF 4.0 , NEMO Consortium (2018) + !! $Id: dtadyn.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_dyn( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_dyn *** + !! + !! ** Purpose : Prepares dynamics and physics fields from a NEMO run + !! for an off-line simulation of passive tracers + !! + !! ** Method : calculates the position of data + !! - computes slopes if needed + !! - interpolates data if needed + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zemp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdivtr + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dta_dyn') + ! + nsecdyn = nsec_year + nsec1jan000 ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step + ! + IF( kt == nit000 ) THEN ; nprevrec = 0 + ELSE ; nprevrec = sf_dyn(jf_tem)%nrec_a(2) + ENDIF + CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==! + ! + IF( l_ldfslp .AND. .NOT.lk_c1d ) CALL dta_dyn_slp( kt ) ! Computation of slopes + ! + tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature + tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity + wndm(:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1) ! wind speed - needed for gas exchange + fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1) ! downward salt flux (v3.5+) + fr_i(:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1) ! Sea-ice fraction + qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1) ! solar radiation + emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1) ! E-P + IF( ln_dynrnf ) THEN + rnf (:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! E-P + IF( ln_dynrnf_depth .AND. .NOT. ln_linssh ) CALL dta_dyn_hrnf + ENDIF + ! + un(:,:,:) = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:) ! effective u-transport + vn(:,:,:) = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:) ! effective v-transport + wn(:,:,:) = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:) ! effective v-transport + ! + IF( .NOT.ln_linssh ) THEN + ALLOCATE( zemp(jpi,jpj) , zhdivtr(jpi,jpj,jpk) ) + zhdivtr(:,:,:) = sf_dyn(jf_div)%fnow(:,:,:) * tmask(:,:,:) ! effective u-transport + emp_b (:,:) = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1) ! E-P + zemp (:,:) = ( 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr ) * tmask(:,:,1) + CALL dta_dyn_ssh( kt, zhdivtr, sshb, zemp, ssha, e3t_a(:,:,:) ) != ssh, vertical scale factor & vertical transport + DEALLOCATE( zemp , zhdivtr ) + ! Write in the tracer restart file + ! ********************************* + IF( lrst_trc ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dta_dyn_ssh : ssh field written in tracer restart file at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + CALL iom_rstput( kt, nitrst, numrtw, 'sshn', ssha ) + CALL iom_rstput( kt, nitrst, numrtw, 'sshb', sshn ) + ENDIF + ENDIF + ! + CALL eos ( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop + CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points + CALL bn2 ( tsn, rab_n, rn2 ) ! before Brunt-Vaisala frequency need for zdfmxl + + rn2b(:,:,:) = rn2(:,:,:) ! need for zdfmxl + CALL zdf_mxl( kt ) ! In any case, we need mxl + ! + hmld(:,:) = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1) ! mixed layer depht + avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coefficient + avs(:,:,:) = avt(:,:,:) + ! + IF( ln_trabbl .AND. .NOT.lk_c1d ) THEN ! diffusive Bottom boundary layer param + ahu_bbl(:,:) = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1) ! bbl diffusive coef + ahv_bbl(:,:) = sf_dyn(jf_vbl)%fnow(:,:,1) * vmask(:,:,1) + ENDIF + ! + ! + CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop + ! + IF(ln_ctl) THEN ! print control + CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' tn - : ', mask1=tmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_sal), clinfo1=' sn - : ', mask1=tmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=un , clinfo1=' un - : ', mask1=umask, kdim=jpk ) + CALL prt_ctl(tab3d_1=vn , clinfo1=' vn - : ', mask1=vmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=wn , clinfo1=' wn - : ', mask1=tmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=avt , clinfo1=' kz - : ', mask1=tmask, kdim=jpk ) + 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( 'dta_dyn') + ! + END SUBROUTINE dta_dyn + + + SUBROUTINE dta_dyn_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_init *** + !! + !! ** Purpose : Initialisation of the dynamical data + !! ** Method : - read the data namdta_dyn namelist + !!---------------------------------------------------------------------- + INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code + INTEGER :: ifpr ! dummy loop indice + INTEGER :: jfld ! dummy loop arguments + INTEGER :: inum, idv, idimv ! local integer + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ji, jj, jk + REAL(wp) :: zcoef + INTEGER :: nkrnf_max + REAL(wp) :: hrnf_max + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of core files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_d ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_empb, sn_emp ! informations about the fields to be read + TYPE(FLD_N) :: sn_tem , sn_sal , sn_avt ! " " + TYPE(FLD_N) :: sn_mld, sn_qsr, sn_wnd , sn_ice , sn_fmf ! " " + TYPE(FLD_N) :: sn_ubl, sn_vbl, sn_rnf ! " " + TYPE(FLD_N) :: sn_div ! informations about the fields to be read + !! + NAMELIST/namdta_dyn/cn_dir, ln_dynrnf, ln_dynrnf_depth, fwbcorr, & + & sn_uwd, sn_vwd, sn_wwd, sn_emp, & + & sn_avt, sn_tem, sn_sal, sn_mld , sn_qsr , & + & sn_wnd, sn_ice, sn_fmf, & + & sn_ubl, sn_vbl, sn_rnf, & + & sn_empb, sn_div + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namdta_dyn in reference namelist : Offline: init. of dynamical data + READ ( numnam_ref, namdta_dyn, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdta_dyn in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdta_dyn in configuration namelist : Offline: init. of dynamical data + READ ( numnam_cfg, namdta_dyn, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdta_dyn in configuration namelist' ) + IF(lwm) WRITE ( numond, namdta_dyn ) + ! ! store namelist information in an array + ! ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_dyn : offline dynamics ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namdta_dyn' + WRITE(numout,*) ' runoffs option enabled (T) or not (F) ln_dynrnf = ', ln_dynrnf + WRITE(numout,*) ' runoffs is spread in vertical ln_dynrnf_depth = ', ln_dynrnf_depth + WRITE(numout,*) ' annual global mean of empmr for ssh correction fwbcorr = ', fwbcorr + WRITE(numout,*) + ENDIF + ! + jf_uwd = 1 ; jf_vwd = 2 ; jf_wwd = 3 ; jf_emp = 4 ; jf_avt = 5 + jf_tem = 6 ; jf_sal = 7 ; jf_mld = 8 ; jf_qsr = 9 + jf_wnd = 10 ; jf_ice = 11 ; jf_fmf = 12 ; jfld = jf_fmf + ! + slf_d(jf_uwd) = sn_uwd ; slf_d(jf_vwd) = sn_vwd ; slf_d(jf_wwd) = sn_wwd + slf_d(jf_emp) = sn_emp ; slf_d(jf_avt) = sn_avt + slf_d(jf_tem) = sn_tem ; slf_d(jf_sal) = sn_sal ; slf_d(jf_mld) = sn_mld + slf_d(jf_qsr) = sn_qsr ; slf_d(jf_wnd) = sn_wnd ; slf_d(jf_ice) = sn_ice + slf_d(jf_fmf) = sn_fmf + ! + IF( .NOT.ln_linssh ) THEN + jf_div = jfld + 1 ; jf_empb = jfld + 2 ; jfld = jf_empb + slf_d(jf_div) = sn_div ; slf_d(jf_empb) = sn_empb + ENDIF + ! + IF( ln_trabbl ) THEN + jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; jfld = jf_vbl + slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl + ENDIF + ! + IF( ln_dynrnf ) THEN + jf_rnf = jfld + 1 ; jfld = jf_rnf + slf_d(jf_rnf) = sn_rnf + ELSE + rnf(:,:) = 0._wp + ENDIF + + ALLOCATE( sf_dyn(jfld), STAT=ierr ) ! set sf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' ) ; RETURN + ENDIF + ! ! fill sf with slf_i and control print + CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) + ! + ! Open file for each variable to get his number of dimension + DO ifpr = 1, jfld + CALL fld_clopn( sf_dyn(ifpr), nyear, nmonth, nday ) + idv = iom_varid( sf_dyn(ifpr)%num , slf_d(ifpr)%clvar ) ! id of the variable sdjf%clvar + idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv) ! number of dimension for variable sdjf%clvar + IF( sf_dyn(ifpr)%num /= 0 ) CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open + ierr1=0 + IF( idimv == 3 ) THEN ! 2D variable + ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) + IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) + ELSE ! 3D variable + ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,jpk,2), STAT=ierr1 ) + ENDIF + IF( ierr0 + ierr1 > 0 ) THEN + CALL ctl_stop( 'dta_dyn_init : unable to allocate sf_dyn array structure' ) ; RETURN + ENDIF + END DO + ! + IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! slopes + IF( sf_dyn(jf_tem)%ln_tint ) THEN ! time interpolation + ALLOCATE( uslpdta (jpi,jpj,jpk,2), vslpdta (jpi,jpj,jpk,2), & + & wslpidta(jpi,jpj,jpk,2), wslpjdta(jpi,jpj,jpk,2), STAT=ierr2 ) + ! + IF( ierr2 > 0 ) THEN + CALL ctl_stop( 'dta_dyn_init : unable to allocate slope arrays' ) ; RETURN + ENDIF + ENDIF + ENDIF + ! + IF( .NOT.ln_linssh ) THEN + IF( .NOT. sf_dyn(jf_uwd)%ln_clim .AND. ln_rsttr .AND. & ! Restart: read in restart file + iom_varid( numrtr, 'sshn', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' sshn forcing fields read in the restart file for initialisation' + CALL iom_get( numrtr, jpdom_autoglo, 'sshn', sshn(:,:) ) + CALL iom_get( numrtr, jpdom_autoglo, 'sshb', sshb(:,:) ) + ELSE + IF(lwp) WRITE(numout,*) ' sshn forcing fields read in the restart file for initialisation' + CALL iom_open( 'restart', inum ) + CALL iom_get( inum, jpdom_autoglo, 'sshn', sshn(:,:) ) + CALL iom_get( inum, jpdom_autoglo, 'sshb', sshb(:,:) ) + CALL iom_close( inum ) ! close file + ENDIF + ! + DO jk = 1, jpkm1 + e3t_n(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + sshn(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) + ENDDO + e3t_a(:,:,jpk) = e3t_0(:,:,jpk) + + ! Horizontal scale factor interpolations + ! -------------------------------------- + CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) + + ! Vertical scale factor interpolations + ! ------------------------------------ + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n(:,:,:), 'W' ) + + e3t_b(:,:,:) = e3t_n(:,:,:) + e3u_b(:,:,:) = e3u_n(:,:,:) + e3v_b(:,:,:) = e3v_n(:,:,:) + + ! t- and w- points depth + ! ---------------------- + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) + gdepw_n(:,:,1) = 0.0_wp + + 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)) + END DO + END DO + END DO + + gdept_b(:,:,:) = gdept_n(:,:,:) + gdepw_b(:,:,:) = gdepw_n(:,:,:) + ! + ENDIF + ! + IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' read in the file depht over which runoffs are distributed' + CALL iom_open ( "runoffs", inum ) ! open file + CALL iom_get ( inum, jpdom_data, 'rodepth', 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 ! runoffs applied at the surface + nk_rnf(:,:) = 1 + h_rnf (:,:) = e3t_n(:,:,1) + ENDIF + nkrnf_max = MAXVAL( nk_rnf(:,:) ) + hrnf_max = MAXVAL( h_rnf(:,:) ) + IF( lk_mpp ) THEN + CALL mpp_max( 'dtadyn', nkrnf_max ) ! max over the global domain + CALL mpp_max( 'dtadyn', hrnf_max ) ! max over the global domain + ENDIF + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' max depht of runoff : ', hrnf_max,' max level : ', nkrnf_max + IF(lwp) WRITE(numout,*) ' ' + ! + CALL dta_dyn( nit000 ) + ! + END SUBROUTINE dta_dyn_init + + SUBROUTINE dta_dyn_sed( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_dyn *** + !! + !! ** Purpose : Prepares dynamics and physics fields from a NEMO run + !! for an off-line simulation of passive tracers + !! + !! ** Method : calculates the position of data + !! - computes slopes if needed + !! - interpolates data if needed + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dta_dyn_sed') + ! + nsecdyn = nsec_year + nsec1jan000 ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step + ! + IF( kt == nit000 ) THEN ; nprevrec = 0 + ELSE ; nprevrec = sf_dyn(jf_tem)%nrec_a(2) + ENDIF + CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==! + ! + tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature + tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity + ! + CALL eos ( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop + + IF(ln_ctl) THEN ! print control + CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' tn - : ', mask1=tmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_sal), clinfo1=' sn - : ', mask1=tmask, kdim=jpk ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'dta_dyn_sed') + ! + END SUBROUTINE dta_dyn_sed + + + SUBROUTINE dta_dyn_sed_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_init *** + !! + !! ** Purpose : Initialisation of the dynamical data + !! ** Method : - read the data namdta_dyn namelist + !!---------------------------------------------------------------------- + INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code + INTEGER :: ifpr ! dummy loop indice + INTEGER :: jfld ! dummy loop arguments + INTEGER :: inum, idv, idimv ! local integer + INTEGER :: ios ! Local integer output status for namelist read + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of core files + TYPE(FLD_N), DIMENSION(2) :: slf_d ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_tem , sn_sal ! " " + !! + NAMELIST/namdta_dyn/cn_dir, ln_dynrnf, ln_dynrnf_depth, fwbcorr, & + & sn_tem, sn_sal + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namdta_dyn in reference namelist : Offline: init. of dynamical data + READ ( numnam_ref, namdta_dyn, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdta_dyn in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdta_dyn in configuration namelist : Offline: init. of dynamical data + READ ( numnam_cfg, namdta_dyn, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdta_dyn in configuration namelist' ) + IF(lwm) WRITE ( numond, namdta_dyn ) + ! ! store namelist information in an array + ! ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_dyn : offline dynamics ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namdta_dyn' + WRITE(numout,*) ' runoffs option enabled (T) or not (F) ln_dynrnf = ', ln_dynrnf + WRITE(numout,*) ' runoffs is spread in vertical ln_dynrnf_depth = ', ln_dynrnf_depth + WRITE(numout,*) ' annual global mean of empmr for ssh correction fwbcorr = ', fwbcorr + WRITE(numout,*) + ENDIF + ! + jf_tem = 1 ; jf_sal = 2 ; jfld = jf_sal + ! + slf_d(jf_tem) = sn_tem ; slf_d(jf_sal) = sn_sal + ! + ALLOCATE( sf_dyn(jfld), STAT=ierr ) ! set sf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' ) ; RETURN + ENDIF + ! ! fill sf with slf_i and control print + CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) + ! + ! Open file for each variable to get his number of dimension + DO ifpr = 1, jfld + CALL fld_clopn( sf_dyn(ifpr), nyear, nmonth, nday ) + idv = iom_varid( sf_dyn(ifpr)%num , slf_d(ifpr)%clvar ) ! id of the variable sdjf%clvar + idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv) ! number of dimension for variable sdjf%clvar + IF( sf_dyn(ifpr)%num /= 0 ) CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open + ierr1=0 + IF( idimv == 3 ) THEN ! 2D variable + ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) + IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) + ELSE ! 3D variable + ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,jpk,2), STAT=ierr1 ) + ENDIF + IF( ierr0 + ierr1 > 0 ) THEN + CALL ctl_stop( 'dta_dyn_init : unable to allocate sf_dyn array structure' ) ; RETURN + ENDIF + END DO + ! + CALL dta_dyn_sed( nit000 ) + ! + END SUBROUTINE dta_dyn_sed_init + + SUBROUTINE dta_dyn_swp( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_swp *** + !! + !! ** Purpose : Swap and the data and compute the vertical scale factor + !! at U/V/W pointand the depht + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zcoef + !!--------------------------------------------------------------------- + + 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 + + sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:)) ! before <-- now filtered + sshn(:,:) = ssha(:,:) + + e3t_n(:,:,:) = e3t_a(:,:,:) + + ! Reconstruction of all vertical scale factors at now and before time steps + ! ============================================================================= + + ! Horizontal scale factor interpolations + ! -------------------------------------- + CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) + + ! Vertical scale factor interpolations + ! ------------------------------------ + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) + + e3t_b(:,:,:) = e3t_n(:,:,:) + e3u_b(:,:,:) = e3u_n(:,:,:) + e3v_b(:,:,:) = e3v_n(:,:,:) + + ! t- and w- points depth + ! ---------------------- + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) + gdepw_n(:,:,1) = 0.0_wp + ! + DO jk = 2, jpk + DO jj = 1,jpj + DO ji = 1,jpi + 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)) + END DO + END DO + END DO + ! + gdept_b(:,:,:) = gdept_n(:,:,:) + gdepw_b(:,:,:) = gdepw_n(:,:,:) + ! + END SUBROUTINE dta_dyn_swp + + + SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb, pemp, pssha, pe3ta ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_wzv *** + !! + !! ** Purpose : compute the after ssh (ssha) and the now vertical velocity + !! + !! ** Method : Using the incompressibility hypothesis, + !! - the ssh increment is computed by integrating the horizontal divergence + !! and multiply by the time step. + !! + !! - compute the after scale factor : repartition of ssh INCREMENT proportionnaly + !! to the level thickness ( z-star case ) + !! + !! - 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) + !! + !! ** action : ssha / e3t_a / wn + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! time-step + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: phdivtr ! horizontal divergence transport + REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(in ) :: psshb ! now ssh + REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(in ) :: pemp ! evaporation minus precipitation + REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(inout) :: pssha ! after ssh + REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(out) :: pe3ta ! after vertical scale factor + ! + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj) :: zhdiv + REAL(wp) :: z2dt + !!---------------------------------------------------------------------- + ! + z2dt = 2._wp * rdt + ! + zhdiv(:,:) = 0._wp + DO jk = 1, jpkm1 + zhdiv(:,:) = zhdiv(:,:) + phdivtr(:,:,jk) * tmask(:,:,jk) + END DO + ! ! Sea surface elevation time-stepping + pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rau0 * pemp(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) + ! ! + ! ! After acale factors at t-points ( z_star coordinate ) + DO jk = 1, jpkm1 + pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) + END DO + ! + END SUBROUTINE dta_dyn_ssh + + + SUBROUTINE dta_dyn_hrnf + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf *** + !! + !! ** Purpose : update the horizontal divergence with the runoff inflow + !! + !! ** Method : + !! CAUTION : rnf is positive (inflow) decreasing the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the runoff inflow + !!---------------------------------------------------------------------- + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + 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 + END DO + END DO + ! + END SUBROUTINE dta_dyn_hrnf + + + + SUBROUTINE dta_dyn_slp( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_slp *** + !! + !! ** Purpose : Computation of slope + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation + REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation + INTEGER :: iswap + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zuslp, zvslp, zwslpi, zwslpj + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts + !!--------------------------------------------------------------------- + ! + IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace) + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt + zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:) ! temperature + zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:) ! salinity + avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:) ! vertical diffusive coef. + CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) + uslpdta (:,:,:,1) = zuslp (:,:,:) + vslpdta (:,:,:,1) = zvslp (:,:,:) + wslpidta(:,:,:,1) = zwslpi(:,:,:) + wslpjdta(:,:,:,1) = zwslpj(:,:,:) + ! + zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature + zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity + avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef. + CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) + uslpdta (:,:,:,2) = zuslp (:,:,:) + vslpdta (:,:,:,2) = zvslp (:,:,:) + wslpidta(:,:,:,2) = zwslpi(:,:,:) + wslpjdta(:,:,:,2) = zwslpj(:,:,:) + ELSE + ! + iswap = 0 + IF( sf_dyn(jf_tem)%nrec_a(2) - nprevrec /= 0 ) iswap = 1 + IF( nsecdyn > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap == 1 ) THEN ! read/update the after data + IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt + uslpdta (:,:,:,1) = uslpdta (:,:,:,2) ! swap the data + vslpdta (:,:,:,1) = vslpdta (:,:,:,2) + wslpidta(:,:,:,1) = wslpidta(:,:,:,2) + wslpjdta(:,:,:,1) = wslpjdta(:,:,:,2) + ! + zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature + zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity + avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef. + CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) + ! + uslpdta (:,:,:,2) = zuslp (:,:,:) + vslpdta (:,:,:,2) = zvslp (:,:,:) + wslpidta(:,:,:,2) = zwslpi(:,:,:) + wslpjdta(:,:,:,2) = zwslpj(:,:,:) + ENDIF + ENDIF + ENDIF + ! + IF( sf_dyn(jf_tem)%ln_tint ) THEN + ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec_b(2), wp ) & + & / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp ) + ztintb = 1. - ztinta + IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace) + uslp (:,:,:) = ztintb * uslpdta (:,:,:,1) + ztinta * uslpdta (:,:,:,2) + vslp (:,:,:) = ztintb * vslpdta (:,:,:,1) + ztinta * vslpdta (:,:,:,2) + wslpi(:,:,:) = ztintb * wslpidta(:,:,:,1) + ztinta * wslpidta(:,:,:,2) + wslpj(:,:,:) = ztintb * wslpjdta(:,:,:,1) + ztinta * wslpjdta(:,:,:,2) + ENDIF + ELSE + zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature + zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity + avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coef. + CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) + ! + IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace) + uslp (:,:,:) = zuslp (:,:,:) + vslp (:,:,:) = zvslp (:,:,:) + wslpi(:,:,:) = zwslpi(:,:,:) + wslpj(:,:,:) = zwslpj(:,:,:) + ENDIF + ENDIF + ! + END SUBROUTINE dta_dyn_slp + + + SUBROUTINE compute_slopes( kt, pts, puslp, pvslp, pwslpi, pwslpj ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dta_dyn_slp *** + !! + !! ** Purpose : Computation of slope + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! temperature/salinity + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: puslp ! zonal isopycnal slopes + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: pvslp ! meridional isopycnal slopes + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: pwslpi ! zonal diapycnal slopes + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: pwslpj ! meridional diapycnal slopes + !!--------------------------------------------------------------------- + ! + IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace) + CALL eos ( pts, rhd, rhop, gdept_0(:,:,:) ) + CALL eos_rab( pts, rab_n ) ! now local thermal/haline expension ratio at T-points + CALL bn2 ( pts, rab_n, rn2 ) ! now Brunt-Vaisala + + ! Partial steps: before Horizontal DErivative + IF( ln_zps .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kt, jpts, pts, 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( kt, jpts, pts, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level + + rn2b(:,:,:) = rn2(:,:,:) ! need for zdfmxl + CALL zdf_mxl( kt ) ! mixed layer depth + CALL ldf_slp( kt, rhd, rn2 ) ! slopes + puslp (:,:,:) = uslp (:,:,:) + pvslp (:,:,:) = vslp (:,:,:) + pwslpi(:,:,:) = wslpi(:,:,:) + pwslpj(:,:,:) = wslpj(:,:,:) + ELSE + puslp (:,:,:) = 0. ! to avoid warning when compiling + pvslp (:,:,:) = 0. + pwslpi(:,:,:) = 0. + pwslpj(:,:,:) = 0. + ENDIF + ! + END SUBROUTINE compute_slopes + + !!====================================================================== +END MODULE dtadyn diff --git a/V4.0/nemo_sources/src/OFF/nemogcm.F90 b/V4.0/nemo_sources/src/OFF/nemogcm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6716255f3bde6967c720913b67df4a805658e0d9 --- /dev/null +++ b/V4.0/nemo_sources/src/OFF/nemogcm.F90 @@ -0,0 +1,573 @@ +MODULE nemogcm + !!====================================================================== + !! *** MODULE nemogcm *** + !! Off-line Ocean : passive tracer evolution, dynamics read in files + !!====================================================================== + !! History : 3.3 ! 2010-05 (C. Ethe) Full reorganization of the off-line: phasing with the on-line + !! 3.4 ! 2011-01 (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation + !! 4.0 ! 2016-10 (C. Ethe, G. Madec, S. Flavoni) domain configuration / user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! nemo_gcm : off-line: solve ocean tracer only + !! 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 + !! istate_init : simple initialization to zero of ocean fields + !! stp_ctl : reduced step control (no dynamics in off-line) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space domain variables + USE oce ! dynamics and tracers variables + USE trc_oce ! Shared ocean/passive tracers variables + USE c1d ! 1D configuration + USE domain ! domain initialization from coordinate & bathymetry (dom_init routine) + USE closea ! treatment of closed seas (for ln_closea) + USE usrdef_nam ! user defined configuration + USE eosbn2 ! equation of state (eos bn2 routine) + ! ! ocean physics + USE bdy_oce, ONLY : ln_bdy + USE bdyini ! open boundary cond. setting (bdy_init routine) + USE ldftra ! lateral diffusivity setting (ldf_tra_init routine) + USE ldfslp ! slopes of neutral surfaces (ldf_slp_init routine) + USE traqsr ! solar radiation penetration (tra_qsr_init routine) + USE trabbl ! bottom boundary layer (tra_bbl_init routine) + USE traldf ! lateral physics (tra_ldf_init routine) + USE sbcmod ! surface boundary condition (sbc_init routine) + USE phycst ! physical constant (par_cst routine) + USE dtadyn ! Lecture and Interpolation of the dynamical fields + USE trcini ! Initilization of the passive tracers + USE daymod ! calendar (day routine) + USE trcstp ! passive tracer time-stepping (trc_stp routine) + USE dtadyn ! Lecture and interpolation of the dynamical fields + ! ! Passive tracers needs + USE trc ! passive tracer : variables + USE trcnam ! passive tracer : namelist + USE trcrst ! passive tracer restart + USE diaptr ! Need to initialise this as some variables are used in if statements later + USE sbc_oce , ONLY : ln_rnf + USE sbcrnf ! surface boundary condition : runoffs + ! ! I/O & MPP + USE iom ! I/O library + USE in_out_manager ! I/O manager + USE mppini ! shared/distributed memory setting (mpp_init routine) + USE lib_mpp ! distributed memory computing + + USE prtctl ! Print control (prt_ctl_init routine) + USE timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges + + IMPLICIT NONE + PRIVATE + + PUBLIC nemo_gcm ! called by nemo.F90 + + CHARACTER (len=64) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing + + !!---------------------------------------------------------------------- + !! NEMO/OFF 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 13013 2020-06-03 08:33:06Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE nemo_gcm + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_gcm *** + !! + !! ** Purpose : NEMO solves the primitive equations on an orthogonal + !! curvilinear mesh on the sphere. + !! + !! ** Method : - model general initialization + !! - launch the time-stepping (dta_dyn and trc_stp) + !! - 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, indic ! time step index + !!---------------------------------------------------------------------- + + CALL nemo_init ! Initializations + + ! 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 ) + + ! !-----------------------! + ! !== time stepping ==! + ! !-----------------------! + istp = nit000 + ! + IF( ln_rnf ) CALL sbc_rnf(istp) ! runoffs initialization + ! + CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) + ! + DO WHILE ( istp <= nitend .AND. nstop == 0 ) !== OFF time-stepping ==! + ! + IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt ( istp - nit000 + 1, cxios_context ) ! say to iom that we are at time step kstp +#if defined key_sed_off + CALL dta_dyn_sed( istp ) ! Interpolation of the dynamical fields +#else + CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields +#endif + CALL trc_stp ( istp ) ! time-stepping +#if ! defined key_sed_off + IF( .NOT.ln_linssh ) CALL dta_dyn_swp( istp ) ! swap of sea surface height and vertical scale factors +#endif + CALL stp_ctl ( istp, indic ) ! Time loop: control and print + istp = istp + 1 + END DO + ! +#if defined key_iomput + CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF +#endif + + ! !------------------------! + ! !== 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' + WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) + ENDIF + ! + IF( ln_timing ) CALL timing_finalize + ! + CALL nemo_closefile + ! +#if defined key_iomput + CALL iom_finalize ! end mpp communications with xios +#else + IF( lk_mpp ) CALL mppstop ! end mpp communications +#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 model in off-line mode + !!---------------------------------------------------------------------- + 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 + CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios + CALL mpp_start( ilocal_comm ) +#else + CALL mpp_start( ) +#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,*) ' Off-line TOP 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,*) " ) ) ` ( ( " + 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 ) + l_offline = .true. ! passive tracers are run offline + ! + ! !-----------------------------------------! + ! ! 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 + 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 dom_init("OPA") ! Domain + IF( ln_ctl ) CALL prt_ctl_init ! Print control + + CALL istate_init ! ocean initial state (Dynamics and tracers) + + CALL sbc_init ! Forcings : surface module + CALL bdy_init ! Open boundaries initialisation + + ! ! Tracer physics + CALL ldf_tra_init ! Lateral ocean tracer physics + CALL ldf_eiv_init ! Eddy induced velocity param + CALL tra_ldf_init ! lateral mixing + IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing + IF( ln_traqsr ) CALL tra_qsr_init ! penetrative solar radiation + IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme + + ! ! Passive tracers + CALL trc_nam_run ! Needed to get restart parameters for passive tracers + CALL trc_rst_cal( nit000, 'READ' ) ! calendar +#if defined key_sed_off + CALL dta_dyn_sed_init ! Initialization for the dynamics +#else + CALL dta_dyn_init ! Initialization for the dynamics +#endif + + CALL trc_init ! Passive tracers initialization + CALL dia_ptr_init ! Poleward TRansports initialization + + 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 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' ) + ! + 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( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist + IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist + IF( numout /= 6 ) CLOSE( numout ) ! standard model output file + IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist + ! + 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 zdf_oce, ONLY : zdf_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 + + SUBROUTINE istate_init + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_init *** + !! + !! ** Purpose : Initialization to zero of the dynamics and tracers. + !!---------------------------------------------------------------------- + ! + ! now fields ! after fields ! + un (:,:,:) = 0._wp ; ua(:,:,:) = 0._wp ! + vn (:,:,:) = 0._wp ; va(:,:,:) = 0._wp ! + wn (:,:,:) = 0._wp ! ! + hdivn(:,:,:) = 0._wp ! ! + tsn (:,:,:,:) = 0._wp ! ! + ! + rhd (:,:,:) = 0.e0 + rhop (:,:,:) = 0.e0 + rn2 (:,:,:) = 0.e0 + ! + END SUBROUTINE istate_init + + + SUBROUTINE stp_ctl( kt, kindic ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_ctl *** + !! + !! ** Purpose : Control the run + !! + !! ** Method : - Save the time step in numstp + !! + !! ** Actions : 'time.step' file containing the last ocean time-step + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(inout) :: kindic ! indicator of solver convergence + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwm ) 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(lwm) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp + IF(lwm) REWIND( numstp ) ! -------------------------- + ! + END SUBROUTINE stp_ctl + !!====================================================================== +END MODULE nemogcm diff --git a/V4.0/nemo_sources/src/README.rst b/V4.0/nemo_sources/src/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..4ea8114d03b3688ffee7fdda1f82a76942756356 --- /dev/null +++ b/V4.0/nemo_sources/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/V4.0/nemo_sources/src/SAO/nemogcm.F90 b/V4.0/nemo_sources/src/SAO/nemogcm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..396faad318989ea67f0d5055f72615fb502dd4d7 --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/nemogcm.F90 @@ -0,0 +1,441 @@ +MODULE nemogcm + !!====================================================================== + !! *** MODULE nemogcm *** + !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) + !!====================================================================== + !! History : 3.6 ! 2015-12 (A. Ryan) Original code (from OCE/) + !! 4.0 ! 2016-11 (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 domain ! domain initialization (dom_init & dom_cfg routines) + USE istate ! initial state setting (istate_init routine) + USE phycst ! physical constant (par_cst routine) + USE step ! NEMO time-stepping (stp routine) + USE cpl_oasis3 ! OASIS3 coupling + USE diaobs ! Observation diagnostics (dia_obs_init routine) +#if defined key_nemocice_decomp + USE ice_domain_size, only: nx_global, ny_global +#endif + ! ! Stand Alone Observation operator modules + USE sao_data + USE sao_intp + ! + 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 iom ! I/O server +#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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 12640 2020-04-01 12:27:05Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE nemo_gcm + !!---------------------------------------------------------------------- + !! *** SUBROUTINE offline_obs_oper *** + !! + !! ** Purpose : To use NEMO components to interpolate model fields + !! to observation space. + !! + !! ** Method : 1. Initialise NEMO + !! 2. Initialise offline obs_oper + !! 3. Cycle through match ups + !! 4. Write results to file + !!---------------------------------------------------------------------- + ! + CALL nemo_init ! Initialise NEMO + ! + CALL sao_data_init ! Initialise Stand Alone Observation operator data + ! + CALL dia_obs_init ! Initialise obs_operator + ! + CALL sao_interp ! Interpolate to observation space + ! + CALL dia_obs_wri ! Pipe to output files + ! + CALL dia_obs_dealloc ! Reset the obs_oper between + ! + IF(lk_mpp) CALL mppstop ! Safely stop MPI (end mpp communications) + ! + END SUBROUTINE nemo_gcm + + + SUBROUTINE nemo_init + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_init *** + !! + !! ** Purpose : initialization of the NEMO GCM + !!---------------------------------------------------------------------- + INTEGER :: ios, ilocal_comm ! local integer + ! + 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 iom_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios + ELSE + CALL iom_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,*) ' Stand Alone Observation operator' + 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 + CALL dom_init('SAO') ! Domain + + + IF( ln_ctl ) CALL prt_ctl_init ! Print control + + CALL istate_init ! ocean initial state (Dynamics and tracers) + END SUBROUTINE nemo_init + + + SUBROUTINE nemo_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_ctl *** + !! + !! ** Purpose : control print setting + !! + !! ** Method : - print namctl 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' ) + ! + 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 + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ierr = oce_alloc () ! ocean + ierr = ierr + dia_wri_alloc () + ierr = ierr + dom_oce_alloc () ! ocean domain + ! + 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/V4.0/nemo_sources/src/SAO/obs_fbm.F90 b/V4.0/nemo_sources/src/SAO/obs_fbm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e591bf56c7898cae0f0ef4b46f80993f2675f8c --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/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: obs_fbm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE init_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_obfbdata *** + !! + !! ** Purpose : Initialize sizes in obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + fbdata%nqcf = idefnqcf + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + + END SUBROUTINE init_obfbdata + + SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, & + & kqcf) + !!---------------------------------------------------------------------- + !! *** ROUTINE alloc_obfbdata *** + !! + !! ** Purpose : Allocate data in an obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kobs ! Number of observations + INTEGER, INTENT(IN) :: klev ! Number of levels + INTEGER, INTENT(IN) :: kadd ! Number of additional entries + INTEGER, INTENT(IN) :: kext ! Number of extra variables + LOGICAL, INTENT(IN) :: lgrid ! Include grid search information + INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags + !! * Local variables + INTEGER :: ji + INTEGER :: jv + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Set dimensions + + fbdata%lalloc = .TRUE. + fbdata%nvar = kvar + fbdata%nobs = kobs + fbdata%nlev = MAX( klev, 1 ) + fbdata%nadd = kadd + fbdata%next = kext + IF ( PRESENT(kqcf) ) THEN + fbdata%nqcf = kqcf + ELSE + fbdata%nqcf = idefnqcf + ENDIF + + ! Set data not depending on number of observations + + fbdata%cdjuldref = REPEAT( 'X', ilenjuld ) + + ! Allocate and initialize standard data + + ALLOCATE( & + & fbdata%cname(fbdata%nvar), & + & fbdata%coblong(fbdata%nvar), & + & fbdata%cobunit(fbdata%nvar) & + & ) + DO ji = 1, fbdata%nvar + WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji + fbdata%coblong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cobunit(ji) = REPEAT( ' ', ilenunit ) + END DO + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%cgrid(fbdata%nvar) & + & ) + fbdata%cgrid(:) = REPEAT( 'X', ilengrid ) + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%caddname(fbdata%nadd), & + & fbdata%caddlong(fbdata%nadd, fbdata%nvar), & + & fbdata%caddunit(fbdata%nadd, fbdata%nvar) & + & ) + DO ji = 1, fbdata%nadd + WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji + END DO + DO jv = 1, fbdata%nvar + DO ji = 1, fbdata%nadd + fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong ) + fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit ) + END DO + END DO + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%cextname(fbdata%next), & + & fbdata%cextlong(fbdata%next), & + & fbdata%cextunit(fbdata%next) & + & ) + DO ji = 1, fbdata%next + WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji + fbdata%cextlong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cextunit(ji) = REPEAT( ' ', ilenunit ) + END DO + ENDIF + + ! Data depending on number of observations is only allocated if nobs>0 + + IF ( fbdata%nobs > 0 ) THEN + + ALLOCATE( & + & fbdata%cdwmo(fbdata%nobs), & + & fbdata%cdtyp(fbdata%nobs), & + & fbdata%ioqc(fbdata%nobs), & + & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%ipqc(fbdata%nobs), & + & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%itqc(fbdata%nobs), & + & fbdata%itqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%idqc(fbdata%nlev,fbdata%nobs), & + & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), & + & fbdata%plam(fbdata%nobs), & + & fbdata%pphi(fbdata%nobs), & + & fbdata%pdep(fbdata%nlev,fbdata%nobs), & + & fbdata%ptim(fbdata%nobs), & + & fbdata%kindex(fbdata%nobs), & + & fbdata%ivqc(fbdata%nobs,fbdata%nvar), & + & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%kindex(:) = fbimdi + fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo ) + fbdata%cdtyp(:) = REPEAT( 'X', ilentyp ) + fbdata%ioqc(:) = fbimdi + fbdata%ioqcf(:,:) = fbimdi + fbdata%ipqc(:) = fbimdi + fbdata%ipqcf(:,:) = fbimdi + fbdata%itqc(:) = fbimdi + fbdata%itqcf(:,:) = fbimdi + fbdata%idqc(:,:) = fbimdi + fbdata%idqcf(:,:,:) = fbimdi + fbdata%plam(:) = fbrmdi + fbdata%pphi(:) = fbrmdi + fbdata%pdep(:,:) = fbrmdi + fbdata%ptim(:) = fbrmdi + fbdata%ivqc(:,:) = fbimdi + fbdata%ivqcf(:,:,:) = fbimdi + fbdata%ivlqc(:,:,:) = fbimdi + fbdata%ivlqcf(:,:,:,:) = fbimdi + fbdata%pob(:,:,:) = fbrmdi + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%iproc(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsi(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsj(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%iproc(:,:) = fbimdi + fbdata%iobsi(:,:) = fbimdi + fbdata%iobsj(:,:) = fbimdi + fbdata%iobsk(:,:,:) = fbimdi + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) & + & ) + fbdata%padd(:,:,:,:) = fbrmdi + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) & + & ) + fbdata%pext(:,:,:) = fbrmdi + ENDIF + + ENDIF + + END SUBROUTINE alloc_obfbdata + + SUBROUTINE dealloc_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dealloc_obfbdata *** + !! + !! ** Purpose : Deallocate data in an obfbdata strucure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + ! Deallocate data + + DEALLOCATE( & + & fbdata%cname, & + & fbdata%coblong,& + & fbdata%cobunit & + & ) + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%cgrid & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%caddname, & + & fbdata%caddlong, & + & fbdata%caddunit & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%cextname, & + & fbdata%cextlong, & + & fbdata%cextunit & + & ) + ENDIF + + ! Deallocate arrays depending on number of obs (if nobs>0 only). + + IF ( fbdata%nobs > 0 ) THEN + + DEALLOCATE( & + & fbdata%cdwmo, & + & fbdata%cdtyp, & + & fbdata%ioqc, & + & fbdata%ioqcf, & + & fbdata%ipqc, & + & fbdata%ipqcf, & + & fbdata%itqc, & + & fbdata%itqcf, & + & fbdata%idqc, & + & fbdata%idqcf, & + & fbdata%plam, & + & fbdata%pphi, & + & fbdata%pdep, & + & fbdata%ptim, & + & fbdata%kindex, & + & fbdata%ivqc, & + & fbdata%ivqcf, & + & fbdata%ivlqc, & + & fbdata%ivlqcf, & + & fbdata%pob & + & ) + + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%iproc, & + & fbdata%iobsi, & + & fbdata%iobsj, & + & fbdata%iobsk & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%padd & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%pext & + & ) + ENDIF + + ENDIF + + ! Reset arrays sizes + + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + + END SUBROUTINE dealloc_obfbdata + + SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE copy_obfbdata *** + !! + !! ** Purpose : Copy an obfbdata structure + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 + !! If fbdata2 is allocated it needs to be compliant + !! with fbdata1. + !! Additional entries can be added by setting nadd + !! Additional extra fields can be added by setting next + !! Grid information can be included with lgrid=.true. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries + INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables + INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags + LOGICAL, OPTIONAL :: lgrid ! Grid info on output file + + !! * Local variables + INTEGER :: nadd + INTEGER :: next + INTEGER :: nqcf + LOGICAL :: llgrid + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & __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/V4.0/nemo_sources/src/SAO/sao.nml b/V4.0/nemo_sources/src/SAO/sao.nml new file mode 100644 index 0000000000000000000000000000000000000000..cebd5c20861483440e21de4a74d4da0e10a8462c --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/sao.nml @@ -0,0 +1,10 @@ +!---------------------------------------------------------------------- +! namsao Stand Alone Observation operator namelist +!---------------------------------------------------------------------- +! sao_files specifies the files containing the model counterpart +! nn_sao_idx specifies the index within the model file +! nn_sao_freq specifies the number of timesteps between file reads +&namsao + sao_files = 'fcst.0.nc' + nn_sao_idx = 1 +/ diff --git a/V4.0/nemo_sources/src/SAO/sao_data.F90 b/V4.0/nemo_sources/src/SAO/sao_data.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8772079b90a76a4602e36eedc82c3cbea8673f73 --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/sao_data.F90 @@ -0,0 +1,81 @@ +MODULE sao_data + !!====================================================================== + !! *** MODULE sao_data *** + !!====================================================================== + !! History : 3.6 ! 2015-12 (A. Ryan) Original code + !!---------------------------------------------------------------------- + USE par_kind, ONLY: lc + USE lib_mpp ! distributed memory computing + USE in_out_manager + + IMPLICIT NONE + + INTEGER, PARAMETER :: MaxNumFiles = 1000 + + !! Stand Alone Observation operator settings + CHARACTER(len=lc) :: sao_files(MaxNumFiles) !: model files + INTEGER :: n_files !: number of files + INTEGER :: nn_sao_idx(MaxNumFiles) !: time_counter indices + INTEGER :: nn_sao_freq !: read frequency in time steps + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sao_data.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sao_data_init() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sao_data_init *** + !! + !! ** Purpose : To read namelists and initialise offline_oper run. + !! + !!---------------------------------------------------------------------- + INTEGER :: jf ! file dummy loop index + LOGICAL :: lmask(MaxNumFiles) ! Logical mask used for counting + INTEGER :: ios + !! + NAMELIST/namsao/sao_files, nn_sao_idx, nn_sao_freq + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sao_data_init : offline obs operator initialization' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + + ! Standard offline obs_oper initialisation + n_files = 0 ! number of files to cycle through + sao_files(:) = '' ! list of files to read in + nn_sao_idx(:) = 0 ! list of indices inside each file + nn_sao_freq = -1 ! input frequency in time steps + + ! Standard offline obs_oper settings + REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark + READ ( numnam_ref, namsao, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsao in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark + READ ( numnam_cfg, namsao, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsao in configuration namelist' ) + + lmask(:) = .FALSE. ! count input files + WHERE( sao_files(:) /= '' ) lmask(:) = .TRUE. + n_files = COUNT(lmask) + ! + IF(nn_sao_freq == -1) THEN ! Initialise sub obs window frequency + nn_sao_freq = nitend - nit000 + 1 ! Run length + ENDIF + ! + IF(lwp) THEN ! Print summary of settings + WRITE(numout,*) ' Namelist namsao : set stand alone obs_oper parameters' + DO jf = 1, n_files + WRITE(numout,'(1X,2A)') ' Input forecast file name forecastfile = ', TRIM(sao_files(jf)) + WRITE(numout,*) ' Input forecast file index forecastindex = ', nn_sao_idx(jf) + END DO + END IF + ! + END SUBROUTINE sao_data_init + + !!====================================================================== +END MODULE sao_data + diff --git a/V4.0/nemo_sources/src/SAO/sao_intp.F90 b/V4.0/nemo_sources/src/SAO/sao_intp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..86d01c6c70015b0d0e1c55e5d3ee8afc37818a15 --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/sao_intp.F90 @@ -0,0 +1,58 @@ +MODULE sao_intp + !!====================================================================== + !! *** MODULE sao_intp *** + !! ** Purpose : Run NEMO observation operator in offline mode + !!====================================================================== + !! History : 3.6 ! 2015-12 (A. Ryan) Original code + !!---------------------------------------------------------------------- + ! ! NEMO modules + USE in_out_manager + USE diaobs + ! ! Stand Alone Observation operator modules + USE sao_read + USE sao_data + + IMPLICIT NONE + PRIVATE + + PUBLIC sao_interp + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sao_intp.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sao_interp + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sao_interp *** + !! + !! ** Purpose : To interpolate the model as if it were running online. + !! + !! ** Method : 1. Populate model counterparts + !! 2. Call dia_obs at appropriate time steps + !!---------------------------------------------------------------------- + INTEGER :: istp ! time step index + INTEGER :: ifile ! file index + !!---------------------------------------------------------------------- + istp = nit000 - 1 + nstop = 0 + ifile = 1 + CALL sao_rea_dri(ifile) + ! + DO WHILE ( istp <= nitend .AND. nstop == 0 ) + IF (ifile <= n_files + 1) THEN + IF ( MOD(istp, nn_sao_freq) == nit000 ) THEN + CALL sao_rea_dri(ifile) + ifile = ifile + 1 + ENDIF + CALL dia_obs(istp) + ENDIF + istp = istp + 1 + END DO + ! + END SUBROUTINE sao_interp + + !!====================================================================== +END MODULE sao_intp diff --git a/V4.0/nemo_sources/src/SAO/sao_read.F90 b/V4.0/nemo_sources/src/SAO/sao_read.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b08531672955448df256e4d651da07e60dcc0991 --- /dev/null +++ b/V4.0/nemo_sources/src/SAO/sao_read.F90 @@ -0,0 +1,173 @@ +MODULE sao_read + !!====================================================================== + !! *** MODULE sao_read *** + !! Read routines : I/O for Stand Alone Observation operator + !!====================================================================== + USE mppini + USE lib_mpp + USE in_out_manager + USE par_kind, ONLY: lc + USE netcdf + USE oce, ONLY: tsn, sshn + USE dom_oce, ONLY: nlci, nlcj, nimpp, njmpp, tmask + USE par_oce, ONLY: jpi, jpj, jpk + ! + USE obs_fbm, ONLY: fbimdi, fbrmdi, fbsp, fbdp + USE sao_data + + IMPLICIT NONE + PRIVATE + + PUBLIC sao_rea_dri + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sao_read.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sao_rea_dri( kfile ) + !!------------------------------------------------------------------------ + !! *** sao_rea_dri *** + !! + !! Purpose : To choose appropriate read method + !! Method : + !! + !! Author : A. Ryan Oct 2013 + !! + !!------------------------------------------------------------------------ + INTEGER, INTENT(in) :: kfile ! File number + ! + CHARACTER(len=lc) :: cdfilename ! File name + INTEGER :: kindex ! File index to read + !!------------------------------------------------------------------------ + ! + cdfilename = TRIM( sao_files(kfile) ) + kindex = nn_sao_idx(kfile) + CALL sao_read_file( TRIM( cdfilename ), kindex ) + ! + END SUBROUTINE sao_rea_dri + + + SUBROUTINE sao_read_file( filename, ifcst ) + !!------------------------------------------------------------------------ + !! *** sao_read_file *** + !! + !! Purpose : To fill tn and sn with dailymean field from netcdf files + !! Method : Use subdomain indices to create start and count matrices + !! for netcdf read. + !! + !! Author : A. Ryan Oct 2010 + !!------------------------------------------------------------------------ + INTEGER, INTENT(in) :: ifcst + CHARACTER(len=*), INTENT(in) :: filename + INTEGER :: ncid, varid, istat, ntimes + INTEGER :: tdim, xdim, ydim, zdim + INTEGER :: ii, ij, ik + INTEGER, DIMENSION(4) :: start_n, count_n + INTEGER, DIMENSION(3) :: start_s, count_s + REAL(fbdp) :: fill_val + REAL(fbdp), DIMENSION(:,:,:), ALLOCATABLE :: temp_tn, temp_sn + REAL(fbdp), DIMENSION(:,:) , ALLOCATABLE :: temp_sshn + + ! DEBUG + INTEGER :: istage + !!------------------------------------------------------------------------ + + IF (TRIM(filename) == 'nofile') THEN + tsn (:,:,:,:) = fbrmdi + sshn(:,:) = fbrmdi + ELSE + WRITE(numout,*) "Opening :", TRIM(filename) + ! Open Netcdf file to find dimension id + istat = nf90_open(path=TRIM(filename), mode=nf90_nowrite, ncid=ncid) + IF ( istat /= nf90_noerr ) THEN + WRITE(numout,*) "WARNING: Could not open ", trim(filename) + WRITE(numout,*) "ERROR: ", nf90_strerror(istat) + ENDIF + istat = nf90_inq_dimid(ncid,'x',xdim) + istat = nf90_inq_dimid(ncid,'y',ydim) + istat = nf90_inq_dimid(ncid,'deptht',zdim) + istat = nf90_inq_dimid(ncid,'time_counter',tdim) + istat = nf90_inquire_dimension(ncid, tdim, len=ntimes) + IF (ifcst .LE. ntimes) THEN + ! Allocate temporary temperature array + ALLOCATE(temp_tn(nlci,nlcj,jpk)) + ALLOCATE(temp_sn(nlci,nlcj,jpk)) + ALLOCATE(temp_sshn(nlci,nlcj)) + + ! Set temp_tn, temp_sn to 0. + temp_tn(:,:,:) = fbrmdi + temp_sn(:,:,:) = fbrmdi + temp_sshn(:,:) = fbrmdi + + ! Create start and count arrays + start_n = (/ nimpp, njmpp, 1, ifcst /) + count_n = (/ nlci, nlcj, jpk, 1 /) + start_s = (/ nimpp, njmpp, ifcst /) + count_s = (/ nlci, nlcj, 1 /) + + ! Read information into temporary arrays + ! retrieve varid and read in temperature + istat = nf90_inq_varid(ncid,'votemper',varid) + istat = nf90_get_att(ncid, varid, '_FillValue', fill_val) + istat = nf90_get_var(ncid, varid, temp_tn, start_n, count_n) + WHERE(temp_tn(:,:,:) == fill_val) temp_tn(:,:,:) = fbrmdi + + ! retrieve varid and read in salinity + istat = nf90_inq_varid(ncid,'vosaline',varid) + istat = nf90_get_att(ncid, varid, '_FillValue', fill_val) + istat = nf90_get_var(ncid, varid, temp_sn, start_n, count_n) + WHERE(temp_sn(:,:,:) == fill_val) temp_sn(:,:,:) = fbrmdi + + ! retrieve varid and read in SSH + istat = nf90_inq_varid(ncid,'sossheig',varid) + IF (istat /= nf90_noerr) THEN + ! Altimeter bias + istat = nf90_inq_varid(ncid,'altbias',varid) + END IF + + istat = nf90_get_att(ncid, varid, '_FillValue', fill_val) + istat = nf90_get_var(ncid, varid, temp_sshn, start_s, count_s) + WHERE(temp_sshn(:,:) == fill_val) temp_sshn(:,:) = fbrmdi + + ! Initialise tsn, sshn to fbrmdi + tsn(:,:,:,:) = fbrmdi + sshn(:,:) = fbrmdi + + ! Mask out missing data index + tsn(1:nlci,1:nlcj,1:jpk,1) = temp_tn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk) + tsn(1:nlci,1:nlcj,1:jpk,2) = temp_sn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk) + sshn(1:nlci,1:nlcj) = temp_sshn(:,:) * tmask(1:nlci,1:nlcj,1) + + ! Remove halo from tmask, tsn, sshn to prevent double obs counting + IF (jpi > nlci) THEN + tmask(nlci+1:,:,:) = 0 + tsn(nlci+1:,:,:,1) = 0 + tsn(nlci+1:,:,:,2) = 0 + sshn(nlci+1:,:) = 0 + END IF + IF (jpj > nlcj) THEN + tmask(:,nlcj+1:,:) = 0 + tsn(:,nlcj+1:,:,1) = 0 + tsn(:,nlcj+1:,:,2) = 0 + sshn(:,nlcj+1:) = 0 + END IF + + ! Deallocate arrays + DEALLOCATE(temp_tn, temp_sn, temp_sshn) + ELSE + ! Mark all as missing data + tsn(:,:,:,:) = fbrmdi + sshn(:,:) = fbrmdi + ENDIF + ! Close netcdf file + WRITE(numout,*) "Closing :", TRIM(filename) + istat = nf90_close(ncid) + END IF + ! + END SUBROUTINE sao_read_file + + !!------------------------------------------------------------------------ +END MODULE sao_read diff --git a/V4.0/nemo_sources/src/SAS/README.rst b/V4.0/nemo_sources/src/SAS/README.rst new file mode 120000 index 0000000000000000000000000000000000000000..01aa82b07482fe30592052ebf40c6bee1ba3218c --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/README.rst @@ -0,0 +1 @@ +../../doc/rst/source/coupling.rst \ No newline at end of file diff --git a/V4.0/nemo_sources/src/SAS/daymod.F90 b/V4.0/nemo_sources/src/SAS/daymod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3835be2bdfac3c836778315d540665727afcca33 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/daymod.F90 @@ -0,0 +1,419 @@ +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 ! I/O manager + 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/SAS 4.0 , NEMO Consortium (2018) + !! $Id: daymod.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! 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( nn_time0*3600 - 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 + 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 ts_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/V4.0/nemo_sources/src/SAS/diawri.F90 b/V4.0/nemo_sources/src/SAS/diawri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..94ea4d905d63592e96eab81220b7be20b9f047a2 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/diawri.F90 @@ -0,0 +1,387 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 zdf_oce ! ocean vertical physics + 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 phycst ! physical constants + USE zdfmxl ! mixed layer + USE dianam ! build name of file (routine) + USE zdfddm ! vertical physics: double diffusion + USE diahth ! thermocline diagnostics + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE iom + USE ioipsl +#if defined key_si3 + USE ice + USE icewri +#endif + USE lib_mpp ! MPP library + USE timing ! preformance summary + + 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 :: 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 :: ndex(1) ! ??? + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/SAS 4.0 , NEMO Consortium (2018) + !! $Id: diawri.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 + !! Standalone surface scheme + !! + !! ** Method : use iom_put + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !!---------------------------------------------------------------------- + ! + ! Output the initial state and forcings + IF( ninist == 1 ) THEN + CALL dia_wri_state( 'output.init' ) + ninist = 0 + ENDIF + ! + END SUBROUTINE dia_wri + +#else + !!---------------------------------------------------------------------- + !! Default option use IOIPSL library + !!---------------------------------------------------------------------- + INTEGER FUNCTION dia_wri_alloc() + !!---------------------------------------------------------------------- + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ALLOCATE( ndex_hT(jpi*jpj), ndex_hU(jpi*jpj), ndex_hV(jpi*jpj), STAT=dia_wri_alloc ) + CALL mpp_sum( 'diawri', dia_wri_alloc ) + ! + 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 + REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars + !!---------------------------------------------------------------------- + ! + ! Output the initial state and forcings + IF( ninist == 1 ) THEN + 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 + ! ----------------- + + ! local variable for debugging + ll_print = .FALSE. + ll_print = ll_print .AND. lwp + + ! 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_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 , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface + + ! 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 , 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 , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface + + ! No W grid FILE + + ! Declare all the output fields as NETCDF variables + + ! !!! nid_T : 3D + CALL histdef( nid_T, "sst_m", "Sea Surface temperature" , "C" , & ! sst + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sss_m", "Sea Surface Salinity" , "PSU" , & ! sss + & 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, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! (sfx) + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + 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, "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 ) + + CALL histend( nid_T, snc4chunks=snc4set ) + + ! !!! nid_U : 3D + CALL histdef( nid_U, "ssu_m", "Velocity component in x-direction", "m/s" , & ! ssu + & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + 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, "ssv_m", "Velocity component in y-direction", "m/s", & ! ssv_m + & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + 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 ) + + 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 diffferent 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 + + ! Write fields on T grid + CALL histwrite( nid_T, "sst_m", it, sst_m, ndim_hT, ndex_hT ) ! sea surface temperature + CALL histwrite( nid_T, "sss_m", it, sss_m, ndim_hT, ndex_hT ) ! sea surface salinity + CALL histwrite( nid_T, "sowaflup", it, (emp - rnf ) , ndim_hT, ndex_hT ) ! upward water flux + 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) + + 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, "soicecov", it, fr_i , ndim_hT, ndex_hT ) ! ice fraction + CALL histwrite( nid_T, "sowindsp", it, wndm , ndim_hT, ndex_hT ) ! wind speed + + ! Write fields on U grid + CALL histwrite( nid_U, "ssu_m" , it, ssu_m , ndim_hU, ndex_hU ) ! i-current speed + CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress + + ! Write fields on V grid + CALL histwrite( nid_V, "ssv_m" , it, ssv_m , ndim_hV, ndex_hV ) ! j-current speed + CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress + + ! 3. Close all files + ! --------------------------------------- + IF( kt == nitend ) THEN + CALL histclo( nid_T ) + CALL histclo( nid_U ) + CALL histclo( nid_V ) + 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 + CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity + 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 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/V4.0/nemo_sources/src/SAS/nemogcm.F90 b/V4.0/nemo_sources/src/SAS/nemogcm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3829e371a8c7791dd6b31714ddfa5e63adccab92 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/nemogcm.F90 @@ -0,0 +1,584 @@ +MODULE nemogcm + !!====================================================================== + !! *** MODULE nemogcm *** + !! StandAlone Surface module : surface fluxes + sea-ice + iceberg floats + !!====================================================================== + !! History : 3.6 ! 2011-11 (S. Alderson, G. Madec) original code + !! - ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) nemo_northcomms: setup avoiding MPI communication + !! - ! 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 + USE sbc_oce ! surface boundary condition: ocean + 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 daymod ! calendar + USE restart ! open restart file + USE step ! NEMO time-stepping (stp routine) + USE cpl_oasis3 ! + USE sbcssm ! + USE icbini ! handle bergs, initialisation + USE icbstp ! handle bergs, calving, themodynamics and transport + USE bdyini ! open boundary cond. setting (bdy_init routine). mandatory for sea-ice + USE bdydta ! open boundary cond. setting (bdy_dta_init routine). mandatory for sea-ice + ! + 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 iom ! I/O server +#endif +#if defined key_agrif && defined key_si3 + USE agrif_ice_update ! ice update +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC nemo_gcm ! called by model.F90 + PUBLIC nemo_init ! needed by AGRIF + + CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing + +#if defined key_mpp_mpi + ! need MPI_Wtime + INCLUDE 'mpif.h' +#endif + + !!---------------------------------------------------------------------- + !! NEMO/SAS 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 13849 2020-11-23 10:21:34Z clem $ + !! 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_agrif + ! !== AGRIF time-stepping ==! + CALL Agrif_Regrid() + ! +#if defined key_si3 + ! Recursive update from highest nested level to lowest: + CALL Agrif_step_child_adj(Agrif_update_ice) +#endif + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + CALL stp + istp = istp + 1 + END DO + ! + IF( .NOT. Agrif_Root() ) THEN + CALL Agrif_ParentGrid_To_ChildGrid() + IF( ln_timing ) CALL timing_finalize + CALL Agrif_ChildGrid_To_ParentGrid() + ENDIF + ! +#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 + ! + 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' + WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) + ENDIF + ! + IF( ln_timing ) CALL timing_finalize + ! + CALL nemo_closefile + ! +#if defined key_iomput + CALL iom_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 + !!---------------------------------------------------------------------- + ! + IF( lk_oasis ) THEN ; cxios_context = 'sas' + ELSE ; cxios_context = 'nemo' + ENDIF + ! + ! !-------------------------------------------------! + ! ! 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( "sas", ilocal_comm ) ! nemo local communicator given by oasis + CALL iom_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios + ELSE + CALL iom_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( "sas", 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( lk_oasis ) THEN + IF( lwm ) CALL ctl_opn( numout, 'sas.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ! open reference and configuration namelist files + CALL ctl_opn( numnam_ref, 'namelist_sas_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + CALL ctl_opn( numnam_cfg, 'namelist_sas_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + IF( lwm ) CALL ctl_opn( numond, 'output.namelist_sas.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ELSE + 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. ) + ENDIF + ! 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 ) THEN ! alreay opened for narea == 1 + IF(lk_oasis) THEN ; CALL ctl_opn( numout, 'sas.output','REPLACE','FORMATTED','SEQUENTIAL',-1,-1, .FALSE., narea ) + ELSE ; CALL ctl_opn( numout, 'ocean.output','REPLACE','FORMATTED','SEQUENTIAL',-1,-1, .FALSE., narea ) + ENDIF + ENDIF + ! + 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,*) ' StandAlone Surface version (SAS) ' + 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,*) + ! + 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 seawater + CALL dom_init('SAS') ! Domain + IF( ln_ctl ) CALL prt_ctl_init ! Print control + + CALL day_init ! model calendar (using both namelist and restart infos) + IF( ln_rstart ) CALL rst_read_open + + ! ! external forcing + CALL sbc_init ! Forcings : surface module + + ! ==> clem: open boundaries init. is mandatory for sea-ice because ice BDY is not decoupled from + ! the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules. + ! This is not clean and should be changed in the future. + CALL bdy_init + ! ==> + CALL icb_init( rdt, nit000) ! initialise icebergs instance + ! + 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 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 + ! + 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 bdy_oce , ONLY : ln_bdy, bdy_oce_alloc + USE oce ! mandatory for sea-ice because needed for bdy arrays + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ierr = dia_wri_alloc() + ierr = ierr + dom_oce_alloc() ! ocean domain + ierr = ierr + oce_alloc () ! (tsn...) needed for agrif and/or SI3 and bdy + 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/V4.0/nemo_sources/src/SAS/sbcssm.F90 b/V4.0/nemo_sources/src/SAS/sbcssm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..398cf010bdf6f83e3a9f1dfd4938d6f52ab7eb08 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/sbcssm.F90 @@ -0,0 +1,319 @@ +MODULE sbcssm + !!====================================================================== + !! *** MODULE sbcssm *** + !! Off-line : interpolation of the physical fields + !!====================================================================== + !! History : 3.4 ! 2012-03 (S. Alderson) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ssm_init : initialization, namelist read, and SAVEs control + !! sbc_ssm : Interpolation of the fields + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE c1d ! 1D configuration: lk_c1d + USE dom_oce ! ocean domain: variables + USE zdf_oce ! ocean vertical physics: variables + USE sbc_oce ! surface module: variables + USE phycst ! physical constants + USE eosbn2 ! equation of state - Brunt Vaisala frequency + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE zpshde ! z-coord. with partial steps: horizontal derivatives + USE closea ! for ln_closea + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! distributed memory computing library + USE prtctl ! print control + USE fldread ! read input fields + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ssm_init ! called by sbc_init + PUBLIC sbc_ssm ! called by sbc + + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssm files + LOGICAL :: ln_3d_uve ! specify whether input velocity data is 3D + LOGICAL :: ln_read_frq ! specify whether we must read frq or not + + LOGICAL :: l_sasread ! Ice intilisation: =T read a file ; =F anaytical initilaistion + LOGICAL :: l_initdone = .false. + INTEGER :: nfld_3d + INTEGER :: nfld_2d + + INTEGER :: jf_tem ! index of temperature + INTEGER :: jf_sal ! index of salinity + INTEGER :: jf_usp ! index of u velocity component + INTEGER :: jf_vsp ! index of v velocity component + INTEGER :: jf_ssh ! index of sea surface height + INTEGER :: jf_e3t ! index of first T level thickness + INTEGER :: jf_frq ! index of fraction of qsr absorbed in the 1st T level + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_3d ! structure of input fields (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_2d ! structure of input fields (file information, fields read) + + !!---------------------------------------------------------------------- + !! NEMO/SAS 4.0 , NEMO Consortium (2018) + !! $Id: sbcssm.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_ssm *** + !! + !! ** Purpose : Prepares dynamics and physics fields from a NEMO run + !! for an off-line simulation using surface processes only + !! + !! ** Method : calculates the position of data + !! - interpolates data if needed + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation + REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'sbc_ssm') + + IF ( l_sasread ) THEN + IF( nfld_3d > 0 ) CALL fld_read( kt, 1, sf_ssm_3d ) !== read data at kt time step ==! + IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d ) !== read data at kt time step ==! + ! + IF( ln_3d_uve ) THEN + IF( .NOT. ln_linssh ) THEN + e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor + ELSE + e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor + ENDIF + ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity + ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity + ELSE + IF( .NOT. ln_linssh ) THEN + e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor + ELSE + e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor + ENDIF + ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity + ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity + ENDIF + ! + sst_m(:,:) = sf_ssm_2d(jf_tem)%fnow(:,:,1) * tmask(:,:,1) ! temperature + sss_m(:,:) = sf_ssm_2d(jf_sal)%fnow(:,:,1) * tmask(:,:,1) ! salinity + ssh_m(:,:) = sf_ssm_2d(jf_ssh)%fnow(:,:,1) * tmask(:,:,1) ! sea surface height + IF( ln_read_frq ) THEN + frq_m(:,:) = sf_ssm_2d(jf_frq)%fnow(:,:,1) * tmask(:,:,1) ! solar penetration + ELSE + frq_m(:,:) = 1._wp + ENDIF + ELSE + sss_m(:,:) = 35._wp ! =35. to obtain a physical value for the freezing point + CALL eos_fzp( sss_m(:,:), sst_m(:,:) ) ! sst_m is set at the freezing point + ssu_m(:,:) = 0._wp + ssv_m(:,:) = 0._wp + ssh_m(:,:) = 0._wp + IF( .NOT. ln_linssh ) e3t_m(:,:) = e3t_0(:,:,1) !clem: necessary at least for sas2D + frq_m(:,:) = 1._wp ! - - + sshn (:,:) = 0._wp ! - - + ENDIF + + IF ( nn_ice == 1 ) THEN + tsn(:,:,1,jp_tem) = sst_m(:,:) + tsn(:,:,1,jp_sal) = sss_m(:,:) + tsb(:,:,1,jp_tem) = sst_m(:,:) + tsb(:,:,1,jp_sal) = sss_m(:,:) + ENDIF + ub (:,:,1) = ssu_m(:,:) + vb (:,:,1) = ssv_m(:,:) + + IF(ln_ctl) THEN ! print control + CALL prt_ctl(tab2d_1=sst_m, clinfo1=' sst_m - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=sss_m, clinfo1=' sss_m - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=ssu_m, clinfo1=' ssu_m - : ', mask1=umask ) + CALL prt_ctl(tab2d_1=ssv_m, clinfo1=' ssv_m - : ', mask1=vmask ) + CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' ssh_m - : ', mask1=tmask ) + IF( .NOT.ln_linssh ) CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' e3t_m - : ', mask1=tmask ) + IF( ln_read_frq ) CALL prt_ctl(tab2d_1=frq_m, clinfo1=' frq_m - : ', mask1=tmask ) + ENDIF + ! + IF( l_initdone ) THEN ! Mean value at each nn_fsbc time-step ! + CALL iom_put( 'ssu_m', ssu_m ) + CALL iom_put( 'ssv_m', ssv_m ) + CALL iom_put( 'sst_m', sst_m ) + CALL iom_put( 'sss_m', sss_m ) + CALL iom_put( 'ssh_m', ssh_m ) + IF( .NOT.ln_linssh ) CALL iom_put( 'e3t_m', e3t_m ) + IF( ln_read_frq ) CALL iom_put( 'frq_m', frq_m ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'sbc_ssm') + ! + END SUBROUTINE sbc_ssm + + + SUBROUTINE sbc_ssm_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_ssm_init *** + !! + !! ** Purpose : Initialisation of sea surface mean data + !!---------------------------------------------------------------------- + INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code + INTEGER :: ifpr ! dummy loop indice + INTEGER :: inum, idv, idimv, jpm ! local integer + INTEGER :: ios ! Local integer output status for namelist read + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of core files + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_3d ! array of namelist information on the fields to read + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_2d ! array of namelist information on the fields to read + TYPE(FLD_N) :: sn_tem, sn_sal ! information about the fields to be read + TYPE(FLD_N) :: sn_usp, sn_vsp + TYPE(FLD_N) :: sn_ssh, sn_e3t, sn_frq + !! + NAMELIST/namsbc_sas/ l_sasread, cn_dir, ln_3d_uve, ln_read_frq, & + & sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq + !!---------------------------------------------------------------------- + ! + IF( ln_rstart .AND. nn_components == jp_iam_sas ) RETURN + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_ssm_init : sea surface mean data initialisation ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + REWIND( numnam_ref ) ! Namelist namsbc_sas in reference namelist : Input fields + READ ( numnam_ref, namsbc_sas, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_sas in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namsbc_sas in configuration namelist : Input fields + READ ( numnam_cfg, namsbc_sas, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_sas ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) ' Namelist namsbc_sas' + WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread + WRITE(numout,*) ' Are we supplying a 3D u,v and e3 field ln_3d_uve = ', ln_3d_uve + WRITE(numout,*) ' Are we reading frq (fraction of qsr absorbed in the 1st T level) ln_read_frq = ', ln_read_frq + ENDIF + ! + !! switch off stuff that isn't sensible with a standalone module + !! note that we need sbc_ssm called first in sbc + ! + IF( ln_apr_dyn ) THEN + IF( lwp ) WRITE(numout,*) ' ==>>> No atmospheric gradient needed with StandAlone Surface scheme' + ln_apr_dyn = .FALSE. + ENDIF + IF( ln_rnf ) THEN + IF( lwp ) WRITE(numout,*) ' ==>>> No runoff needed with StandAlone Surface scheme' + ln_rnf = .FALSE. + ENDIF + IF( ln_ssr ) THEN + IF( lwp ) WRITE(numout,*) ' ==>>> No surface relaxation needed with StandAlone Surface scheme' + ln_ssr = .FALSE. + ENDIF + IF( nn_fwb > 0 ) THEN + IF( lwp ) WRITE(numout,*) ' ==>>> No freshwater budget adjustment needed with StandAlone Surface scheme' + nn_fwb = 0 + ENDIF + IF( ln_closea ) THEN + IF( lwp ) WRITE(numout,*) ' ==>>> No closed seas adjustment needed with StandAlone Surface scheme' + ln_closea = .false. + ENDIF + + ! + IF( l_sasread ) THEN ! store namelist information in an array + ! + !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and + !! when we have other 3d arrays that we need to read in + !! so if a new field is added i.e. jf_new, just give it the next integer in sequence + !! for the corresponding dimension (currently if ln_3d_uve is true, 4 for 2d and 3 for 3d, + !! alternatively if ln_3d_uve is false, 6 for 2d and 1 for 3d), reset nfld_3d, nfld_2d, + !! and the rest of the logic should still work + ! + jf_tem = 1 ; jf_ssh = 3 ! default 2D fields index + jf_sal = 2 ; jf_frq = 4 ! + ! + IF( ln_3d_uve ) THEN + jf_usp = 1 ; jf_vsp = 2 ; jf_e3t = 3 ! define 3D fields index + nfld_3d = 2 + COUNT( (/.NOT.ln_linssh/) ) ! number of 3D fields to read + nfld_2d = 3 + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read + ELSE + jf_usp = 4 ; jf_e3t = 6 ! update 2D fields index + jf_vsp = 5 ; jf_frq = 6 + COUNT( (/.NOT.ln_linssh/) ) + ! + nfld_3d = 0 ! no 3D fields to read + nfld_2d = 5 + COUNT( (/.NOT.ln_linssh/) ) + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read + ENDIF + ! + IF( nfld_3d > 0 ) THEN + ALLOCATE( slf_3d(nfld_3d), STAT=ierr ) ! set slf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 3d structure' ) ; RETURN + ENDIF + slf_3d(jf_usp) = sn_usp + slf_3d(jf_vsp) = sn_vsp + IF( .NOT.ln_linssh ) slf_3d(jf_e3t) = sn_e3t + ENDIF + ! + IF( nfld_2d > 0 ) THEN + ALLOCATE( slf_2d(nfld_2d), STAT=ierr ) ! set slf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init: unable to allocate slf 2d structure' ) ; RETURN + ENDIF + slf_2d(jf_tem) = sn_tem ; slf_2d(jf_sal) = sn_sal ; slf_2d(jf_ssh) = sn_ssh + IF( ln_read_frq ) slf_2d(jf_frq) = sn_frq + IF( .NOT. ln_3d_uve ) THEN + slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp + IF( .NOT.ln_linssh ) slf_2d(jf_e3t) = sn_e3t + ENDIF + ENDIF + ! + ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. + IF( nfld_3d > 0 ) THEN + ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr ) ! set sf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf structure' ) ; RETURN + ENDIF + DO ifpr = 1, nfld_3d + ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( slf_3d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + IF( ierr0 + ierr1 > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_3d array structure' ) ; RETURN + ENDIF + END DO + ! ! fill sf with slf_i and control print + CALL fld_fill( sf_ssm_3d, slf_3d, cn_dir, 'sbc_ssm_init', '3D Data in file', 'namsbc_ssm' ) + ENDIF + ! + IF( nfld_2d > 0 ) THEN + ALLOCATE( sf_ssm_2d(nfld_2d), STAT=ierr ) ! set sf structure + IF( ierr > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init: unable to allocate sf 2d structure' ) ; RETURN + ENDIF + DO ifpr = 1, nfld_2d + ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) + IF( slf_2d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) + IF( ierr0 + ierr1 > 0 ) THEN + CALL ctl_stop( 'sbc_ssm_init : unable to allocate sf_ssm_2d array structure' ) ; RETURN + ENDIF + END DO + ! + CALL fld_fill( sf_ssm_2d, slf_2d, cn_dir, 'sbc_ssm_init', '2D Data in file', 'namsbc_ssm' ) + ENDIF + ! + IF( nfld_3d > 0 ) DEALLOCATE( slf_3d, STAT=ierr ) + IF( nfld_2d > 0 ) DEALLOCATE( slf_2d, STAT=ierr ) + ! + ENDIF + ! + CALL sbc_ssm( nit000 ) ! need to define ss?_m arrays used in iceistate + l_initdone = .TRUE. + ! + END SUBROUTINE sbc_ssm_init + + !!====================================================================== +END MODULE sbcssm diff --git a/V4.0/nemo_sources/src/SAS/step.F90 b/V4.0/nemo_sources/src/SAS/step.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2036e0b1dffe36c540dc879fc3cf235a3c9e6288 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/step.F90 @@ -0,0 +1,155 @@ +MODULE step + !!====================================================================== + !! *** MODULE step *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !! version for standalone surface scheme + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! . ! . + !! . ! . + !! NEMO 3.5 ! 2012-03 (S. Alderson) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! stp : OPA system time-stepping + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE daymod ! calendar (day routine) + USE sbc_oce ! surface boundary condition: fields + USE sbcmod ! surface boundary condition (sbc routine) + USE sbcrnf ! surface boundary condition: runoff variables + USE sbccpl ! surface boundary condition: coupled interface + USE eosbn2 ! equation of state (eos_bn2 routine) + USE diawri ! Standard run outputs (dia_wri routine) + USE bdy_oce , ONLY: ln_bdy + USE bdydta ! mandatory for sea-ice + USE stpctl ! time stepping control (stp_ctl routine) + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control (prt_ctl routine) + USE iom ! + USE lbclnk ! + USE timing ! Timing + +#if defined key_agrif + USE agrif_oce, ONLY: lk_agrif_debug +#if defined key_si3 + USE agrif_ice_update +#endif +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC stp ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/SAS 4.0 , NEMO Consortium (2018) + !! $Id: step.F90 12651 2020-04-03 07:51:14Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_agrif + RECURSIVE SUBROUTINE stp( ) + INTEGER :: kstp ! ocean time-step index +#else + SUBROUTINE stp( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index +#endif + !!---------------------------------------------------------------------- + !! *** ROUTINE stp *** + !! + !! ** Purpose : - Time stepping of SBC (surface boundary) + !! + !! ** Method : -1- Update forcings and data + !! -2- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: indic ! error indicator if < 0 + !! --------------------------------------------------------------------- + +#if defined key_agrif + IF( nstop > 0 ) return ! avoid to go further if an error was detected during previous time step + kstp = nit000 + Agrif_Nb_Step() + IF ( lk_agrif_debug ) THEN + IF ( Agrif_Root() .and. lwp) Write(*,*) '---' + IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() + ENDIF + + IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. + +# if defined key_iomput + IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) +# endif +#endif + indic = 0 ! although indic is not changed in stp_ctl + ! need to keep the same interface + IF( kstp == nit000 ) CALL iom_init( cxios_context ) ! 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, cxios_context ) ! tell iom we are at time step kstp + + ! ==> clem: open boundaries is mandatory for sea-ice because ice BDY is not decoupled from + ! the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules. + ! From SAS: ocean bdy data are wrong (but we do not care) and ice bdy data are OK. + ! This is not clean and should be changed in the future. + 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) + + CALL dia_wri( kstp ) ! ocean model: outputs + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF recursive integration + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL Agrif_Integrate_ChildGrids( stp ) +#endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL stp_ctl( kstp, indic ) + IF( indic < 0 ) THEN + CALL ctl_stop( 'step: indic < 0' ) + CALL dia_wri_state( 'output.abort' ) + ENDIF +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN ! AGRIF Update from zoom N to zoom 1 then to Parent +#if defined key_si3 + CALL Agrif_Update_ice( ) ! update sea-ice +#endif + ENDIF +#endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! File manipulation at the end of the first time step + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Coupled mode + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( lk_oasis ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges if OASIS-coupled ice + +#if defined key_iomput + IF( kstp == nitrst ) THEN + IF(.NOT.lwxios) THEN + CALL iom_close( numrow ) + ELSE + CALL iom_context_finalize( cwxios_context ) + ENDIF + lrst_oce = .FALSE. + ENDIF + IF( kstp == nitend .OR. indic < 0 ) THEN + CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF + ENDIF +#endif + ! + IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset + ! + END SUBROUTINE stp + + !!====================================================================== +END MODULE step diff --git a/V4.0/nemo_sources/src/SAS/stpctl.F90 b/V4.0/nemo_sources/src/SAS/stpctl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1247d2592a0d47f0e405d1786db4419b171ff963 --- /dev/null +++ b/V4.0/nemo_sources/src/SAS/stpctl.F90 @@ -0,0 +1,117 @@ +MODULE stpctl + !!====================================================================== + !! *** MODULE stpctl *** + !! Ocean run control : gross check of the ocean time stepping + !! version for standalone surface scheme + !!====================================================================== + !! 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.5 ! 2012-03 (S. Alderson) + !! 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 ice , ONLY : vt_i, u_ice, tm_i + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing + + USE netcdf ! NetCDF library + IMPLICIT NONE + PRIVATE + + PUBLIC stp_ctl ! routine called by step.F90 + + INTEGER :: idrun, idtime, idssh, idu, ids, istatus + !!---------------------------------------------------------------------- + !! NEMO/SAS 4.0 , NEMO Consortium (2018) + !! $Id: stpctl.F90 12859 2020-05-03 09:33:32Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +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 + !! + !! ** Actions : "time.step" file = last ocean time-step + !! "run.stat" file = run statistics + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( inout ) :: kindic ! indicator of solver convergence + !! + REAL(wp), DIMENSION(3) :: zmax + LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns + CHARACTER(len=20) :: clname + !!---------------------------------------------------------------------- + ! + 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( 'run.stat.nc', NF90_CLOBBER, idrun ) + istatus = NF90_DEF_DIM( idrun, 'time' , NF90_UNLIMITED, idtime ) + istatus = NF90_DEF_VAR( idrun, 'vt_i_max' , NF90_DOUBLE, (/ idtime /), idssh ) + istatus = NF90_DEF_VAR( idrun, 'abs_u_max', NF90_DOUBLE, (/ idtime /), idu ) + istatus = NF90_DEF_VAR( idrun, 'tm_i_min' , NF90_DOUBLE, (/ idtime /), ids ) + 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 ==! + IF( ll_colruns .OR. jpnij == 1 ) THEN + zmax(1) = MAXVAL( vt_i (:,:) ) ! max ice thickness + zmax(2) = MAXVAL( ABS( u_ice(:,:) ) ) ! max ice velocity (zonal only) + zmax(3) = MAXVAL( -tm_i (:,:)+273.15_wp , mask = ssmask(:,:) == 1._wp ) ! min ice temperature + IF( ll_colruns ) CALL mpp_max( "stpctl", zmax ) ! max over the global domain + END IF + ! !== run statistics ==! ("run.stat" file) + IF( ll_wrtruns ) THEN + WRITE(numrun,9500) kt, zmax(1), zmax(2), - zmax(3) + 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, ids, (/-zmax(3)/), (/kt/), (/1/) ) + IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun) + IF( kt == nitend ) istatus = NF90_CLOSE(idrun) + END IF + ! +9500 FORMAT(' it :', i8, ' vt_i_max: ', D23.16, ' |u|_max: ', D23.16,' tm_i_min: ', D23.16) + ! + END SUBROUTINE stp_ctl + + !!====================================================================== +END MODULE stpctl diff --git a/V4.0/nemo_sources/src/TOP/AGE/par_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/par_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..053a9fc3f922de6e7362f96ef491d75cc05dc9e6 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/par_age.F90 @@ -0,0 +1,17 @@ +MODULE par_age + !!====================================================================== + !! *** par_age *** + !! TOP : set the AGE parameters + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: par_age.F90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, PUBLIC :: jp_age !: number of passive tracers in PISCES + + !!====================================================================== +END MODULE par_age diff --git a/V4.0/nemo_sources/src/TOP/AGE/trcice_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/trcice_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..257bef86eda3693c09a072b477e6fed3df9ef393 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/trcice_age.F90 @@ -0,0 +1,31 @@ +MODULE trcice_age + !!====================================================================== + !! *** MODULE trcice_age *** + !!====================================================================== + USE par_trc ! TOP parameters + USE oce_trc ! Ocean variables + USE trc ! TOP variables + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini_age ! called by trcice.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice_age.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini_age + !!---------------------------------------------------------------------- + !! *** trc_ice_ageb *** + !! + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE trc_ice_ini_age + + !!====================================================================== +END MODULE trcice_age diff --git a/V4.0/nemo_sources/src/TOP/AGE/trcini_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/trcini_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2aac18d80f19ae05a06d73b0c725b549d7f3b8af --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/trcini_age.F90 @@ -0,0 +1,64 @@ +MODULE trcini_age + !!====================================================================== + !! *** MODULE trcini_age *** + !! TOP : initialisation of the AGE tracer + !!====================================================================== + !! History : 2.0 ! 2007-12 (G. Nurser, G. Madec, C. Ethe ) Original code + !!---------------------------------------------------------------------- + !! trc_ini_age : MY_TRC model initialisation + !!---------------------------------------------------------------------- + USE oce_trc + USE trc + USE trcnam_age + USE trcsms_age + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ini_age ! called by trcini.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini_age.F90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ini_age + !!---------------------------------------------------------------------- + !! *** trc_ini_age *** + !! + !! ** Purpose : initialization for AGE model + !! + !!---------------------------------------------------------------------- + INTEGER :: jn + CHARACTER(len = 20) :: cltra + !!---------------------------------------------------------------------- + ! + CALL trc_nam_age + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_ini_age: passive tracer age' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + + rryear = 1._wp / ( nyear_len(1) * rday ) ! recip number of seconds in one year + + !! BUG in s-coordinate this does not work! + nlb_age = MINLOC( gdepw_1d, mask = gdepw_1d > rn_age_depth, dim = 1 ) ! shallowest W level Below age_depth + ! = shallowest T level wholly below age_depth + nl_age = nlb_age - 1 ! deepest W level Above age_depth + ! = T level surrounding age_depth + + nla_age = nl_age - 1 ! deepest T level wholly above age_depth + + frac_kill_age = ( rn_age_depth - gdepw_1d(nl_age) ) / e3t_1d(nl_age) ! fraction of level nl_age above age_depth + frac_add_age = 1._wp - frac_kill_age ! fraction of level nl_age below age_depth + + + IF( .NOT. ln_rsttr ) trn(:,:,:,jp_age) = 0. + ! + END SUBROUTINE trc_ini_age + + !!====================================================================== +END MODULE trcini_age diff --git a/V4.0/nemo_sources/src/TOP/AGE/trcnam_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/trcnam_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5bda095c312042192835ebdf601f046d05c2139e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/trcnam_age.F90 @@ -0,0 +1,74 @@ +MODULE trcnam_age + !!====================================================================== + !! *** MODULE trcnam_age *** + !! TOP : initialisation of some run parameters for Age tracer + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) + !!---------------------------------------------------------------------- + !! trc_nam_age : AGE tracer initialisation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE trc ! Ocean variables + USE trcsms_age ! AGE specific variable + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_nam_age ! called by trcnam.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam_age.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_nam_age + !!------------------------------------------------------------------- + !! *** ROUTINE trc_nam_age *** + !! + !! ** Purpose : Definition some run parameter for AGE model + !! + !! ** input : Namelist namage + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namage/ rn_age_depth, rn_age_kill_rate + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Sea Age Tracer' + WRITE(numout,*) + WRITE(numout,*) 'trc_nam_age : Read namage namelist for Age passive tracer' + WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + + ! Variable setting + ctrcnm (jp_age) = 'Age' + ctrcln (jp_age) = 'Sea water age since surface contact' + ctrcun (jp_age) = 'year' + ln_trc_ini(jp_age) = .false. + ln_trc_sbc(jp_age) = .false. + ln_trc_cbc(jp_age) = .false. + ln_trc_obc(jp_age) = .false. + ! + REWIND( numnat_ref ) ! Namelist namagedate in reference namelist : AGE parameters + READ ( numnat_ref, namage, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namage in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namagedate in configuration namelist : AGE parameters + READ ( numnat_cfg, namage, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namage in configuration namelist' ) + IF(lwm) WRITE ( numont, namage ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namage' + WRITE(numout,*) ' depth over which age tracer reset to zero rn_age_depth = ', rn_age_depth + WRITE(numout,*) ' recip of relaxation timescale rn_age_kill_rate = ', rn_age_kill_rate, '[s]' + WRITE(numout,*) ' (for age tracer shallower than age_depth) ' + ENDIF + ! + END SUBROUTINE trc_nam_age + + !!====================================================================== +END MODULE trcnam_age diff --git a/V4.0/nemo_sources/src/TOP/AGE/trcsms_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/trcsms_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bc3e29b0aef2ca1898171877f4999b59c24bc438 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/trcsms_age.F90 @@ -0,0 +1,76 @@ +MODULE trcsms_age + !!====================================================================== + !! *** MODULE trcsms_age *** + !! TOP : Main module of the AGE tracers + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code + !!---------------------------------------------------------------------- + !! trc_sms_age : AGE model main routine + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE trc ! TOP variables + USE trd_oce + USE trdtrc + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms_age ! called by trcsms.F90 module + + INTEGER , PUBLIC :: nl_age ! T level surrounding age_depth + INTEGER , PUBLIC :: nla_age ! T level wholly above age_depth + INTEGER , PUBLIC :: nlb_age ! T level wholly below age_depth + + REAL(wp), PUBLIC :: rn_age_depth ! = 10 depth over which age tracer reset to zero + REAL(wp), PUBLIC :: rn_age_kill_rate ! = -1./7200 recip of relaxation timescale (s) for age tracer shallower than age_depth + + REAL(wp), PUBLIC :: rryear !: recip number of seconds in one year + REAL(wp), PUBLIC :: frac_kill_age !: fraction of level nl_age above age_depth where it is relaxed towards zero + REAL(wp), PUBLIC :: frac_add_age !: fraction of level nl_age below age_depth where it is incremented + + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms_age.F90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms_age( kt ) + !!---------------------------------------------------------------------- + !! *** trc_sms_age *** + !! + !! ** Purpose : main routine of AGE model + !! + !! ** Method : - + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER :: jn, jk ! dummy loop index + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sms_age') + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_sms_age: AGE model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + + + DO jk = 1, nla_age + tra(:,:,jk,jp_age) = rn_age_kill_rate * trb(:,:,jk,jp_age) + END DO + ! + tra(:,:,nl_age,jp_age) = frac_kill_age * rn_age_kill_rate * trb(:,:,nl_age,jp_age) & + & + frac_add_age * rryear * tmask(:,:,nl_age) + ! + DO jk = nlb_age, jpk + tra(:,:,jk,jp_age) = tmask(:,:,jk) * rryear + END DO + ! + IF( l_trdtrc ) CALL trd_trc( tra(:,:,:,jp_age), jn, jptra_sms, kt ) ! save trends + ! + IF( ln_timing ) CALL timing_stop('trc_sms_age') + ! + END SUBROUTINE trc_sms_age + + !!====================================================================== +END MODULE trcsms_age diff --git a/V4.0/nemo_sources/src/TOP/AGE/trcwri_age.F90 b/V4.0/nemo_sources/src/TOP/AGE/trcwri_age.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0d82e1aad1b9250d40155b553087741e558a0bfd --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/AGE/trcwri_age.F90 @@ -0,0 +1,56 @@ +MODULE trcwri_age + !!====================================================================== + !! *** MODULE trcwri *** + !! age : Output of age tracers + !!====================================================================== + !! History : 1.0 ! 2009-05 (C. Ethe) Original code + !!---------------------------------------------------------------------- +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! trc_wri_age : outputs of concentration fields + !!---------------------------------------------------------------------- + USE par_age + USE trc + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri_age + +CONTAINS + + SUBROUTINE trc_wri_age + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri_trc *** + !! + !! ** Purpose : output passive tracers fields + !!--------------------------------------------------------------------- + CHARACTER (len=20) :: cltra + INTEGER :: jn + !!--------------------------------------------------------------------- + + ! write the tracer concentrations in the file + + cltra = TRIM( ctrcnm(jp_age) ) ! short title for tracer + CALL iom_put( cltra, trn(:,:,:,jp_age) ) + + ! + END SUBROUTINE trc_wri_age + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- + PUBLIC trc_wri_age +CONTAINS + SUBROUTINE trc_wri_age ! Empty routine + END SUBROUTINE trc_wri_age +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_age.F90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcwri_age diff --git a/V4.0/nemo_sources/src/TOP/C14/par_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/par_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a4b0c2a3337a4553f21fdd84524c2e2f10304b54 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/par_c14.F90 @@ -0,0 +1,13 @@ +MODULE par_c14 + !!====================================================================== + !! *** par_c14 *** + !! TOP : set the C14 parameters + !!====================================================================== + !! History : 2.0 ! 2008-12 (C. Ethe, G. Madec) revised architecture + !! History : ! 2015 (A.Mouchet) equilibrium + transient C14 + !!---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER, PUBLIC :: jp_c14 !: number of c14 tracer + +END MODULE par_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/sms_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/sms_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bdea777651132bc10a238c54f572e344b5614de7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/sms_c14.F90 @@ -0,0 +1,75 @@ +MODULE sms_c14 + !!====================================================================== + !! *** MODULE trcsms_c14 *** + !! TOP : C14 main module + !!====================================================================== + !! History - ! 1994-05 ( J. Orr ) original code + !! 1.0 ! 2006-02 ( J.M. Molines ) Free form + modularity + !! 2.0 ! 2008-12 ( C. Ethe ) reorganisation + !! 4.0 ! 2011-02 ( A.R. Porter, STFC Daresbury ) Dynamic memory + !! ! 2015 (A. Mouchet) general C14 + update formulas + !!---------------------------------------------------------------------- + !! sms_c14 : compute and add C14 suface forcing to C14 trends + !!---------------------------------------------------------------------- + USE par_oce + USE par_trc + + + IMPLICIT NONE + PUBLIC + + + LOGICAL :: ln_chemh ! Chemical enhancement (yes/no) + INTEGER :: kc14typ ! C14 tracer type + REAL(wp) :: tyrc14_beg ! year start atmospheric scenario !! See below + REAL(wp) :: pco2at, rc14at ! atm co2, atm 14C ratio (global, reference) + REAL(wp) :: rc14init ! ocean 14C ratio for initialization + REAL(wp) :: xkwind, xdicsur ! wind coeff, ref DIC + REAL(wp) :: rlam14 ! C14 decay rate + + ! + CHARACTER (len=20) :: cfileco2, cfilec14 ! Name of atmospheric forcing files + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: c14sbc ! atmospheric c14 ratio + REAL(wp) :: co2sbc ! atmospheric co2 pressure + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: exch_c14 ! exch. vel. for C14/C + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: exch_co2 ! CO2 invasion rate + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: qtr_c14 ! flux at surface + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: qint_c14 ! cumulative flux + + INTEGER , PARAMETER :: nc14zon = 3 ! number of zones for bomb c14 + ! + INTEGER :: nrecco2, nrecc14 ! nb record atm co2 & cc14 + REAL(wp) :: tyrc14_now ! current yr for transient experiment relative to tyrc14_beg + INTEGER :: m1_co2, m1_c14 ! index of first co2 and c14 records to consider + INTEGER :: m2_co2, m2_c14 ! index of second co2 and c14 records to consider + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: bomb ! C14 atm data (bomb - 3 zones) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: atmc14 ! C14 atm data (paleo - 1 zone) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: tyrc14 ! Time (yr) atmospheric C14 data + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fareaz ! Spatial Interpolation Factors + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: spco2 ! Atmospheric CO2 + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: tyrco2 ! Time (yr) atmospheric CO2 data + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: sms_c14.F90 10071 2018-08-28 14:49:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + INTEGER FUNCTION sms_c14_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sms_c14_alloc *** + !!---------------------------------------------------------------------- + sms_c14_alloc = 0 + ALLOCATE( exch_c14(jpi,jpj) , exch_co2(jpi,jpj) , & + & qtr_c14(jpi,jpj) , qint_c14(jpi,jpj) , & + & c14sbc(jpi,jpj) , STAT = sms_c14_alloc ) + ! + ! + END FUNCTION sms_c14_alloc + + !!====================================================================== +END MODULE sms_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcatm_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcatm_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6efa3db5d3e63528129286299cf7b2115be6f23a --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcatm_c14.F90 @@ -0,0 +1,302 @@ +MODULE trcatm_c14 + !!====================================================================== + !! *** MODULE trcatm_c14 *** + !! TOP : read and manages atmospheric values for radiocarbon model + !!===================================================================== + !! History: Based on trcini_c14b & trcsms_c14b : + !! Anne Mouchet + !!---------------------------------------------------------------------- + !! trc_atm_c14_ini : initialize c14atm & pco2atm + !! trc_atm_c14 : read and time interpolate c14atm & pco2atm + !!---------------------------------------------------------------------- + USE par_trc ! passive tracers parameters + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_c14 ! c14 simulation type, atm default values... + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_atm_c14 ! called in trcsms_c14.F90 + PUBLIC trc_atm_c14_ini ! called in trcini_c14.F90 + ! + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcatm_c14.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_atm_c14_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_c14_ini *** + !! + !! ** Purpose : initialisation of sbc for radiocarbon + !! + !! ** Method : + !!---------------------------------------------------------------------- + ! + CHARACTER (len=20) :: clfile ! forcing file name + INTEGER :: ji,jj,jn ! dummy loop indice + INTEGER :: ierr1,ierr2,ierr3,izco2 ! temporary integers + INTEGER :: inum1,inum2,incom,iyear ! temporary integers + REAL(wp) :: ys40 = -40. ! 40 degrees south + REAL(wp) :: ys20 = -20. ! 20 degrees south + REAL(wp) :: yn20 = 20. ! 20 degrees north + REAL(wp) :: yn40 = 40. ! 40 degrees north + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zco2, zyrco2 ! temporary arrays for swap + ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_atm_c14_ini') + ! + + IF( lwp ) WRITE(numout,*) ' ' + IF( lwp ) WRITE(numout,*) ' trc_atm_c14_ini : initialize atm CO2 & C14-ratio ' + IF( lwp ) WRITE(numout,*) ' ' + ! + tyrc14_now = 0._wp ! initialize + ! + IF(kc14typ >= 1) THEN ! Transient atmospheric forcing: CO2 + ! + clfile = TRIM( cfileco2 ) + IF(lwp) WRITE(numout,*) 'Read CO2 atmospheric concentrations file ',clfile + CALL ctl_opn( inum1, clfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND(inum1) + + READ(inum1,*) nrecco2,incom + DO jn = 1, incom ! Skip over descriptor lines + READ(inum1,'(1x)') + END DO + ALLOCATE( spco2(nrecco2), tyrco2(nrecco2) , STAT=ierr1 ) + IF( ierr1 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate co2 arrays' ) + ! get CO2 data + DO jn = 1, nrecco2 + READ(inum1, *) tyrco2(jn), spco2(jn) + END DO + CLOSE(inum1) + ! + IF(kc14typ==2) THEN + ALLOCATE( zco2(nrecco2), zyrco2(nrecco2) ) + zco2(:)=spco2(:) + zyrco2(:)=tyrco2(:) + ! Set CO2 times on AD time scale & swap records : In CO2 file : youngest first + DO jn = 1, nrecco2 + izco2=nrecco2-jn+1 + spco2(izco2)=zco2(jn) + tyrco2(izco2)=1950._wp-zyrco2(jn) ! BP to AD dates + END DO + DEALLOCATE( zco2,zyrco2 ) + ENDIF + ! + ! ! Transient atmospheric forcing: Bomb C14 & Paleo C14 : open file + ! + clfile = TRIM( cfilec14 ) + IF (lwp) WRITE(numout,*) 'Read C-14 atmospheric concentrations file ',clfile + CALL ctl_opn( inum2, clfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND(inum2) + ! + ! Bomb C14: 3 zones for atm C14 ! + IF(kc14typ == 1) THEN ! Transient atmospheric forcing: Bomb C14 + ! + READ(inum2,*) nrecc14,incom + DO jn = 1, incom ! Skip over descriptor lines + READ(inum2,'(1x)') + END DO + ALLOCATE( bomb(nrecc14,nc14zon), tyrc14(nrecc14) , STAT=ierr2 ) + IF( ierr2 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate c14 arrays' ) + ! get bomb c14 data + DO jn = 1, nrecc14 + READ(inum2,*) tyrc14(jn), bomb(jn,1), bomb(jn,2), bomb(jn,3) + END DO + CLOSE(inum2) + + ! Linear interpolation of the C-14 source fonction + ! in linear latitude bands (20N,40N) and (20S,40S) + !------------------------------------------------------ + ALLOCATE( fareaz (jpi,jpj ,nc14zon) , STAT=ierr3 ) + IF( ierr3 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate fareaz' ) + ! + DO jj = 1 , jpj ! from C14b package + DO ji = 1 , jpi + IF( gphit(ji,jj) >= yn40 ) THEN + fareaz(ji,jj,1) = 0. + fareaz(ji,jj,2) = 0. + fareaz(ji,jj,3) = 1. + ELSE IF( gphit(ji,jj ) <= ys40) THEN + fareaz(ji,jj,1) = 1. + fareaz(ji,jj,2) = 0. + fareaz(ji,jj,3) = 0. + ELSE IF( gphit(ji,jj) >= yn20 ) THEN + fareaz(ji,jj,1) = 0. + fareaz(ji,jj,2) = 2. * ( 1. - gphit(ji,jj) / yn40 ) + fareaz(ji,jj,3) = 2. * gphit(ji,jj) / yn40 - 1. + ELSE IF( gphit(ji,jj) <= ys20 ) THEN + fareaz(ji,jj,1) = 2. * gphit(ji,jj) / ys40 - 1. + fareaz(ji,jj,2) = 2. * ( 1. - gphit(ji,jj) / ys40 ) + fareaz(ji,jj,3) = 0. + ELSE + fareaz(ji,jj,1) = 0. + fareaz(ji,jj,2) = 1. + fareaz(ji,jj,3) = 0. + ENDIF + END DO + END DO + ! + ENDIF + ! + ! Paleo C14: 1 zone for atm C14 ! + IF(kc14typ == 2) THEN ! Transient atmospheric forcing: Paleo C14 + ! + READ(inum2,*) nrecc14,incom + DO jn = 1, incom ! Skip over descriptor lines + READ(inum2,'(1x)') + END DO + ALLOCATE( atmc14(nrecc14), tyrc14(nrecc14) , STAT=ierr2 ) + IF( ierr2 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate c14 arrays' ) + ! get past c14 data + DO jn = 1, nrecc14 + READ(inum2,*) iyear,incom,incom,atmc14(jn) + tyrc14(jn)=1950._wp-REAL(iyear,wp) ! BP to AD dates + END DO + CLOSE(inum2) + ! + ENDIF + ! + ! Note on dates: + ! In files dates have dimension yr; either AD or BP; if BP date is changed into AD here + ! When dealing with dates previous to 0. AD one needs to set tyrc14_beg to the actual starting year + ! Do not forget to appropriately set nn_date0 and nn_rstctl in namelist + ! AND nn_rsttr in namelist_top if offline run + ! All details are given in NEMO-C14.pdf report + ! + tyrc14_now=nyear ! actual initial yr - Bomb + if(kc14typ == 2) tyrc14_now=nyear+tyrc14_beg-1 ! actual initial yr - Paleo + ! ! we suppose we start on tyrc14_now/01/01 @ 0h + m1_c14= 1 + m1_co2= 1 + DO jn = 1,nrecco2 + IF ( tyrc14_now >= tyrco2(jn) ) m1_co2 = jn ! index of first co2 record to consider + END DO + DO jn = 1,nrecc14 + IF ( tyrc14_now >= tyrc14(jn) ) m1_c14 = jn ! index of first c14 record to consider + END DO + IF (lwp) WRITE(numout,*) 'Initial yr for experiment', tyrc14_now + IF (lwp) WRITE(numout,*) ' CO2 & C14 start years:', tyrco2(m1_co2),tyrc14(m1_c14) + ! + m2_c14= m1_c14 + m2_co2= m1_co2 + ! + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_atm_c14_ini') + ! + END SUBROUTINE trc_atm_c14_ini + + + SUBROUTINE trc_atm_c14( kt, co2sbc, c14sbc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_flx *** + !! + !! ** Purpose : provides sbc for co2 & c14 at kt + !! + !! ** Method : read files + !! + !! ** Action : atmospheric values interpolated at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(wp), DIMENSION(:,:), INTENT( out) :: c14sbc ! atm c14 ratio + REAL(wp), INTENT( out) :: co2sbc ! atm co2 p + INTEGER :: jz ! dummy loop indice + REAL(wp) :: zdint,zint ! work + REAL(wp), DIMENSION(nc14zon) :: zonbc14 ! work + ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_atm_c14') + ! + IF( kc14typ == 0) THEN + co2sbc=pco2at + c14sbc(:,:)=rc14at + ENDIF + ! + IF(kc14typ >= 1) THEN ! Transient C14 & CO2 + ! + tyrc14_now = tyrc14_now + ( rdt / ( rday * nyear_len(1)) ) ! current time step in yr relative to tyrc14_beg + ! + ! CO2 -------------------------------------------------------- + ! + ! time interpolation of CO2 concentrations ! if out of record keeps first/last value + IF( tyrc14_now > tyrco2(m2_co2) ) THEN ! next interval + m1_co2 = m2_co2 + m2_co2 = MIN ( m2_co2 + 1 , nrecco2 ) + ENDIF + ! + zdint = tyrco2(m2_co2) - tyrco2(m1_co2) + co2sbc = spco2(m2_co2) ! if out of record keeps first/last value + zint = 0._wp + IF ( zdint > 0._wp ) THEN ! if within record interpolate: + zint = ( tyrco2(m2_co2) - tyrc14_now ) / zdint + co2sbc = spco2(m2_co2) + zint * ( spco2(m1_co2) - spco2(m2_co2) ) + ENDIF + ! + IF( lwp .AND. kt == nitend ) THEN + WRITE(numout, '(3(A,F12.4))') 't1/tn/t2:',tyrco2(m1_co2),'/', tyrc14_now,'/',tyrco2(m2_co2) + WRITE(numout, *) 'CO2:',spco2(m1_co2),co2sbc ,spco2(m2_co2) + ENDIF + ! + ! C14 -------------------------------------------------------- + ! + ! time interpolation of C14 concentrations + IF ( tyrc14_now > tyrc14(m2_c14) ) THEN ! next interval + m1_c14 = m2_c14 + m2_c14 = MIN ( m2_c14 + 1 , nrecc14 ) + ENDIF + zdint = tyrc14(m2_c14) - tyrc14(m1_c14) + zint=0._wp + IF ( zdint > 0._wp ) zint = ( tyrc14(m2_c14) - tyrc14_now ) / zdint ! if within record + IF( lwp .AND. kt == nitend ) & + & WRITE(numout,'(3(A,F12.4))') 't1/tn/t2:',tyrc14(m1_c14),'/', tyrc14_now,'/',tyrc14(m2_c14) + ! + ! ------- Bomb C14 ------------------------------------------ + ! + IF( kc14typ == 1) THEN + ! ! time interpolation + zonbc14(:) = bomb(m2_c14,:) ! if out of record keeps first/last value + ! ! if within record interpolate: + IF ( zdint > 0._wp ) zonbc14(:) = bomb(m2_c14,:) + zint * ( bomb(m1_c14,:) - bomb(m2_c14,:) ) + ! + IF(lwp .AND. kt == nitend ) & + & WRITE(numout, *) 'C14:',bomb(m1_c14,1),zonbc14(1),bomb(m2_c14,1) + ! Transform DeltaC14 --> C14 ratio + zonbc14(:) = 1._wp + zonbc14(:)/1.d03 + ! + ! For each (i,j)-box, with information from the fractional area + ! (zonmean), computes area-weighted mean to give the atmospheric C-14 + ! ---------------------------------------------------------------- + c14sbc(:,:) = zonbc14(1) * fareaz(:,:,1) & + & + zonbc14(2) * fareaz(:,:,2) & + & + zonbc14(3) * fareaz(:,:,3) + ENDIF + ! + ! ------- Paleo C14 ----------------------------------------- + ! + IF( kc14typ == 2 ) THEN + ! ! time interpolation + zonbc14(1) = atmc14(m2_c14) ! if out of record keeps first/last value + ! ! if within record interpolate: + IF ( zdint > 0._wp ) zonbc14(1) = atmc14(m2_c14) + zint * ( atmc14(m1_c14) - atmc14(m2_c14) ) + IF(lwp .AND. kt == nitend ) & + & WRITE(numout, *) 'C14: ',atmc14(m1_c14),zonbc14(1),atmc14(m2_c14) + ! Transform DeltaC14 --> C14 ratio + c14sbc(:,:) = 1._wp + zonbc14(1)/1.d03 + ENDIF + ! + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_atm_c14') + ! + END SUBROUTINE trc_atm_c14 + + !!====================================================================== +END MODULE trcatm_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcice_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcice_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d3566b193d6ee0c0813c0c900409ec89e8084fc3 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcice_c14.F90 @@ -0,0 +1,31 @@ +MODULE trcice_c14 + !!====================================================================== + !! *** MODULE trcice_c14 *** + !!====================================================================== + USE par_trc ! TOP parameters + USE oce_trc ! Ocean variables + USE trc ! TOP variables + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini_c14 ! called by trcice.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice_c14.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini_c14 + !!---------------------------------------------------------------------- + !! *** trc_ice_c14b *** + !! + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE trc_ice_ini_c14 + + !!====================================================================== +END MODULE trcice_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcini_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcini_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b1d4de23f1194aa614fa0761133084dbb4999a53 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcini_c14.F90 @@ -0,0 +1,97 @@ +MODULE trcini_c14 + !!====================================================================== + !! *** MODULE trcini_c14 *** + !! TOP : initialisation of the C14 tracers + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code + !! History : 3.0 ! 2015 (A. Mouchet) C14 Code + !!---------------------------------------------------------------------- + !! trc_ini_c14 : C14 model initialisation + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc + USE trc + USE sms_c14 + USE trcatm_c14 + USE trcnam_c14 + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ini_c14 ! called by trcini.F90 module + + ! + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini_c14.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ini_c14 + !!---------------------------------------------------------------------- + !! *** trc_ini_c14 *** + !! + !! ** Purpose : initialization for C14 model + !! + !! ** Method : + !!---------------------------------------------------------------------- + ! + REAL(wp) :: ztrai + INTEGER :: jn + CHARACTER(len = 20) :: cltra + !!---------------------------------------------------------------------- + ! + CALL trc_nam_c14 + ! ! Allocate c14 arrays + IF( sms_c14_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_ini_c14: unable to allocate C14 arrays' ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_ini_c14: initialisation of C14 model' + ! + IF( .NOT. ln_rsttr ) THEN + ! + IF(lwp) WRITE(numout,*) ' ==> PRESCRIBED initial VALUES' + IF(lwp) WRITE(numout,*) ' ==> Ocean C14/C :', rc14init + ! + trn(:,:,:,jp_c14) = rc14init * tmask(:,:,:) + ! + qtr_c14(:,:) = 0._wp ! Init of air-sea BC + ! + ELSE + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_rst_read_c14 : Read specific variables for c14 model ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ! + CALL iom_get( numrtr, 'co2sbc', co2sbc ) + CALL iom_get( numrtr, jpdom_autoglo, 'c14sbc', c14sbc ) + CALL iom_get( numrtr, jpdom_autoglo, 'exch_co2', exch_co2 ) + CALL iom_get( numrtr, jpdom_autoglo, 'exch_c14', exch_c14 ) + CALL iom_get( numrtr, jpdom_autoglo, 'qtr_c14', qtr_c14 ) + ! + END IF + ! + IF( ( nn_rsttr == 0 ) .OR. ( .NOT. ln_rsttr ) ) THEN + ! + ! ! qint set to zero <=== Initial of transient + ! ! <=== Restart=false + IF(lwp) WRITE(numout,*) ' ==> qint reset to ZERO ' + qint_c14(:,:) = 0._wp + ! + ELSE + ! + CALL iom_get( numrtr, jpdom_autoglo, 'qint_c14', qint_c14 ) + ! + ENDIF + ! + CALL trc_atm_c14_ini ! Init atm values + ! + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ! + END SUBROUTINE trc_ini_c14 + + !!====================================================================== +END MODULE trcini_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcnam_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcnam_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c242d194d46acf486248902abb4dacfc35b4a458 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcnam_c14.F90 @@ -0,0 +1,119 @@ +MODULE trcnam_c14 + !!====================================================================== + !! *** MODULE trcnam_c14 *** + !! TOP : initialisation of some run parameters for C14 chemical model + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcnam.cfc.h90 + !! History : ! 2015 (A.Mouchet) equilibrium + transient C14 + !!---------------------------------------------------------------------- + !! trc_nam_c14 : C14 model initialisation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE trc ! TOP variables + USE sms_c14 + + IMPLICIT NONE + PRIVATE + !! + PUBLIC trc_nam_c14 ! called by trcnam.F90 module + !! + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam_c14.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE trc_nam_c14 + !!------------------------------------------------------------------- + !! *** ROUTINE trc_nam_c14 *** + !! + !! ** Purpose : Definition some run parameter for C14 model + !! + !! ** Method : Read the namc14 namelist and check the parameter + !! values called at the first timestep (nittrc000) + !! + !! ** input : Namelist namelist_c14 + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namc14_typ/ kc14typ,rc14at, pco2at, rc14init ! type of C14 tracer, default values of C14/C, pco2, & ocean r14 + NAMELIST/namc14_sbc/ ln_chemh, xkwind, xdicsur ! chem enh, wind coeff, ref DIC + NAMELIST/namc14_fcg/ cfileco2, cfilec14, tyrc14_beg ! for transient exps; atm forcing + !!------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) ' Radiocarbon C14' + WRITE(numout,*) ' ' + WRITE(numout,*) ' trc_nam_c14 : Read C14 namelists' + WRITE(numout,*) ' ~~~~~~~~~~~' + ENDIF + ! + ! Variable setting + ctrcnm (jp_c14) = 'RC14' + ctrcln (jp_c14) = 'Radiocarbon ratio' + ctrcun (jp_c14) = '-' + ln_trc_ini(jp_c14) = .false. + ln_trc_sbc(jp_c14) = .false. + ln_trc_cbc(jp_c14) = .false. + ln_trc_obc(jp_c14) = .false. + ! + REWIND( numtrc_ref ) ! Namelist namc14_typ in reference namelist : + READ ( numtrc_ref, namc14_typ, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc14_typ in reference namelist' ) + REWIND( numtrc_cfg ) ! Namelist namcfcdate in configuration namelist + READ ( numtrc_cfg, namc14_typ, IOSTAT = ios, ERR = 902) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc14_typ in configuration namelist' ) + IF(lwm) WRITE ( numonr, namc14_typ ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namc14_typ' + WRITE(numout,*) ' Type of C14 tracer (0=equilibrium; 1=bomb transient; 2=past transient) kc14typ = ', kc14typ + WRITE(numout,*) ' Default value for atmospheric C14/C (used for equil run) rc14at = ', rc14at + WRITE(numout,*) ' Default value for atmospheric pcO2 [atm] (used for equil run) pco2at = ', pco2at + WRITE(numout,*) ' Default value for initial C14/C in the ocean (used for equil run) rc14init= ', rc14init + WRITE(numout,*) + ENDIF + + REWIND( numtrc_ref ) ! Namelist namc14_typ in reference namelist : + READ ( numtrc_ref, namc14_sbc, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc14_sbc in reference namelist' ) + REWIND( numtrc_cfg ) ! Namelist namcfcdate in configuration namelist + READ ( numtrc_cfg, namc14_sbc, IOSTAT = ios, ERR = 904) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc14_sbc in configuration namelist' ) + IF(lwm) WRITE( numonr, namc14_sbc ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist namc14_sbc' + WRITE(numout,*) ' Chemical enhancement in piston velocity ln_chemh = ', ln_chemh + WRITE(numout,*) ' Coefficient for gas exchange velocity xkwind = ', xkwind + WRITE(numout,*) ' Reference DIC concentration (mol/m3) xdicsur = ', xdicsur + WRITE(numout,*) + ENDIF + + REWIND( numtrc_ref ) ! Namelist namc14_typ in reference namelist : + READ ( numtrc_ref, namc14_fcg, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc14_fcg in reference namelist' ) + REWIND( numtrc_cfg ) ! Namelist namcfcdate in configuration namelist + READ ( numtrc_cfg, namc14_fcg, IOSTAT = ios, ERR = 906) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc14_fcg in configuration namelist' ) + IF(lwm) WRITE ( numonr, namc14_fcg ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist namc14_fcg' + WRITE(numout,*) ' Atmospheric co2 file ( bomb ) cfileco2 = ', TRIM( cfileco2 ) + WRITE(numout,*) ' Atmospheric c14 file ( bomb ) cfilec14 = ', TRIM( cfilec14 ) + WRITE(numout,*) ' Starting year of experiment tyrc14_beg = ', tyrc14_beg + ENDIF + + ! + IF( kc14typ == 2 ) tyrc14_beg = 1950._wp - tyrc14_beg ! BP to AD dates + ! set units + rlam14 = LOG(2._wp) / 5730._wp / rsiyea ! C14 decay rate: yr^-1 --> s^-1 + ! ! radiocarbon half-life is 5730 yr + END SUBROUTINE trc_nam_c14 + + !!====================================================================== +END MODULE trcnam_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcsms_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcsms_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..baffe00de1aab9d94ee04df959af9cce8bde16c9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcsms_c14.F90 @@ -0,0 +1,166 @@ +MODULE trcsms_c14 + !!====================================================================== + !! *** MODULE trcsms_c14 *** + !! TOP : Bomb C14 main module + !!====================================================================== + !! History - ! 1994-05 ( J. Orr ) original code + !! 1.0 ! 2006-02 ( J.M. Molines ) Free form + modularity + !! 2.0 ! 2008-12 ( C. Ethe ) reorganisation + !! 4.0 ! 2011-02 ( A.R. Porter, STFC Daresbury ) Dynamic memory + !! ! 2015 (A. Mouchet) general C14 + update formulas + !!---------------------------------------------------------------------- + !! trc_sms_c14 : compute and add C14 suface forcing to C14 trends + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE par_trc ! TOP parameters + USE trc ! TOP variables + USE trd_oce ! trends + USE trdtrc ! trends + USE sms_c14 ! atmospheric forcing + USE trcatm_c14 ! atmospheric forcing + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms_c14 ! called in trcsms.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms_c14.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms_c14( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sms_c14 *** + !! + !! ** Purpose : Compute the surface boundary contition on C14 + !! passive tracer associated with air-sea fluxes and add it to + !! the general trend of tracers equations. + ! + ! Method: + ! - transport the ratio C14/C as in Toggweiler et al. (JGR,1989) + ! - if on-line a passive tracer (jpcref; NO sms) allows compensating for + ! freshwater fluxes which should not impact the C14/C ratio + ! + ! => Delta-C14= ( trn(...jp_c14) -1)*1000. + !! + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt, ztp, zsk ! dummy variables + REAL(wp) :: zsol ! solubility + REAL(wp) :: zsch ! schmidt number + REAL(wp) :: zv2 ! wind speed ( square) + REAL(wp) :: zpv ! piston velocity + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sms_c14') + ! + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_sms_c14: C14 model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ENDIF + ! + ! Get co2sbc & c14sbc(ji,jj): at 1st iter for all, at each time step for transient + IF( kc14typ >= 1 .OR. kt == nittrc000 ) CALL trc_atm_c14( kt, co2sbc, c14sbc ) + + ! ------------------------------------------------------------------- + ! Gas exchange coefficient (Wanninkhof, 1992, JGR, 97,7373-7382) + ! Schmidt number of CO2 in seawater (Wanninkhof, 1992 & 2014) + ! CO2 solubility (Weiss, 1974; Wanninkhof, 2014) + ! ------------------------------------------------------------------- + + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,1) > 0. ) THEN + ! + zt = MIN( 40. , tsn(ji,jj,1,jp_tem) ) + ! + ! Computation of solubility zsol in [mol/(L * atm)] + ! after Wanninkhof (2014) referencing Weiss (1974) + ztp = ( zt + 273.16 ) * 0.01 + zsk = 0.027766 + ztp * ( -0.025888 + 0.0050578 * ztp ) ! [mol/(L * atm)] + zsol = EXP( -58.0931 + 90.5069 / ztp + 22.2940 * LOG( ztp ) + zsk * tsn(ji,jj,1,jp_sal) ) + ! convert solubilities [mol/(L * atm)] -> [mol/(m^3 * ppm)] + zsol = zsol * 1.e-03 + + ! Computes the Schmidt number of CO2 in seawater + ! Wanninkhof-2014 + zsch = 2116.8 + zt * ( -136.25 + zt * (4.7353 + zt * (-0.092307 + 0.0007555 * zt ) ) ) + + ! Wanninkhof Piston velocity: zpv in units [m/s] + zv2 = xkwind * (wndm(ji,jj) * wndm(ji,jj)) ! wind speed module at T points + ! chemical enhancement (Wanninkhof & Knox, 1996) + IF( ln_chemh ) zv2 = zv2 + 2.5 * ( 0.5246 + zt * (0.016256 + 0.00049946 * zt ) ) + zv2 = zv2/360000._wp ! conversion cm/h -> m/s + ! + zpv = ( zv2 * SQRT( 660./ zsch ) ) * ( 1. - fr_i(ji,jj) ) * tmask(ji,jj,1) + + ! CO2 piston velocity (m/s) + exch_co2(ji,jj)= zpv + ! CO2 invasion rate (mol/ppm/m2/s) = 1st part of 14C/C exchange velocity + exch_c14(ji,jj)= zpv * zsol + ELSE + exch_co2(ji,jj) = 0._wp + exch_c14(ji,jj) = 0._wp + ENDIF + END DO + END DO + + ! Exchange velocity for 14C/C ratio (m/s) + zt = co2sbc / xdicsur + exch_c14(:,:) = zt * exch_c14(:,:) + ! + ! Flux of C-14 from air-to-sea; units: (C14/C ratio) x m/s + ! already masked + qtr_c14(:,:) = exch_c14(:,:) * ( c14sbc(:,:) - trb(:,:,1,jp_c14) ) + + ! cumulation of air-to-sea flux at each time step + qint_c14(:,:) = qint_c14(:,:) + qtr_c14(:,:) * rdttrc + ! + ! Add the surface flux to the trend of jp_c14 + DO jj = 1, jpj + DO ji = 1, jpi + tra(ji,jj,1,jp_c14) = tra(ji,jj,1,jp_c14) + qtr_c14(ji,jj) / e3t_n(ji,jj,1) + END DO + END DO + ! + ! Computation of decay effects on jp_c14 + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + ! + tra(ji,jj,jk,jp_c14) = tra(ji,jj,jk,jp_c14) - rlam14 * trb(ji,jj,jk,jp_c14) * tmask(ji,jj,jk) + ! + END DO + END DO + END DO + ! + IF( lrst_trc ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_rst_wri_c14 : Write specific variables from c14 model ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ! + CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) ! These five need & + CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) ! & to be written & + CALL iom_rstput( kt, nitrst, numrtw, 'exch_co2', exch_co2 ) ! & for temporal & + CALL iom_rstput( kt, nitrst, numrtw, 'exch_c14', exch_c14 ) ! & averages & + CALL iom_rstput( kt, nitrst, numrtw, 'qtr_c14', qtr_c14 ) ! & to be coherent. + CALL iom_rstput( kt, nitrst, numrtw, 'qint_c14', qint_c14 ) ! Cumulative + ! + ENDIF + + IF( l_trdtrc ) CALL trd_trc( tra(:,:,:,jp_c14), 1, jptra_sms, kt ) ! save trends + ! + IF( ln_timing ) CALL timing_stop('trc_sms_c14') + ! + END SUBROUTINE trc_sms_c14 + + !!====================================================================== +END MODULE trcsms_c14 diff --git a/V4.0/nemo_sources/src/TOP/C14/trcwri_c14.F90 b/V4.0/nemo_sources/src/TOP/C14/trcwri_c14.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3a235dfb8d4e7e23884c3cd8cfcca60b512e1e62 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/C14/trcwri_c14.F90 @@ -0,0 +1,137 @@ +MODULE trcwri_c14 + !!====================================================================== + !! *** MODULE trcwri *** + !! MY_SRC : Additional outputs for C14 tracers + !!====================================================================== + !! History : 1.0 ! 2009-05 (C. Ethe) Original code + !! History : 2.0 ! 2015 (A. Mouchet) adapted code for C14 + !!---------------------------------------------------------------------- +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! trc_wri_c14 : outputs of ventilation fields + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE trc ! passive tracers common variables + USE iom ! I/O manager + USE sms_c14 + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri_c14 + ! + ! Standard ratio: 1.176E-12 ; Avogadro's nbr = 6.022E+23 at/mol ; bomb C14 traditionally reported as 1.E+26 atoms + REAL(wp), PARAMETER :: atomc14 = 1.176 * 6.022E-15 ! conversion factor + + +CONTAINS + + SUBROUTINE trc_wri_c14 + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri_c14 *** + !! + !! ** Purpose : output additional C14 tracers fields + !!--------------------------------------------------------------------- + CHARACTER (len=20) :: cltra ! short title for tracer + INTEGER :: ji,jj,jk,jn ! dummy loop indexes + REAL(wp) :: zage,zarea,ztemp ! temporary + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zres, z2d ! temporary storage 2D + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d , zz3d ! temporary storage 3D + !!--------------------------------------------------------------------- + + ! write the tracer concentrations in the file + ! --------------------------------------- + cltra = TRIM( ctrcnm(jp_c14) ) ! short title for tracer + CALL iom_put( cltra, trn(:,:,:,jp_c14) ) + + ! compute and write the tracer diagnostic in the file + ! --------------------------------------- + + IF( iom_use("DeltaC14") .OR. iom_use("C14Age") .OR. iom_use("RAge") ) THEN + ! + ALLOCATE( z2d(jpi,jpj), zres(jpi,jpj) ) + ALLOCATE( z3d(jpi,jpj,jpk), zz3d(jpi,jpj,jpk) ) + ! + zage = -1._wp / rlam14 / rsiyea ! factor for radioages in year + z3d(:,:,:) = 1._wp + zz3d(:,:,:) = 0._wp + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,jk) > 0._wp) THEN + z3d (ji,jj,jk) = trn(ji,jj,jk,jp_c14) + zz3d(ji,jj,jk) = LOG( z3d(ji,jj,jk) ) + ENDIF + ENDDO + ENDDO + ENDDO + zres(:,:) = z3d(:,:,1) + + ! Reservoir age [yr] + z2d(:,:) =0._wp + jk = 1 + DO jj = 1, jpj + DO ji = 1, jpi + ztemp = zres(ji,jj) / c14sbc(ji,jj) + IF( ztemp > 0._wp .AND. tmask(ji,jj,jk) > 0._wp ) z2d(ji,jj) = LOG( ztemp ) + ENDDO + ENDDO + ! + z3d(:,:,:) = 1.d03 * ( z3d(:,:,:) - 1._wp ) + CALL iom_put( "DeltaC14" , z3d(:,:,:) ) ! Delta C14 [permil] + CALL iom_put( "C14Age" , zage * zz3d(:,:,:) ) ! Radiocarbon age [yr] + + CALL iom_put( "qtr_c14", rsiyea * qtr_c14(:,:) ) ! Radiocarbon surf flux [./m2/yr] + CALL iom_put( "qint_c14" , qint_c14 ) ! cumulative flux [./m2] + CALL iom_put( "RAge" , zage * z2d(:,:) ) ! Reservoir age [yr] + ! + DEALLOCATE( z2d, zres, z3d, zz3d ) + ! + ENDIF + ! + ! 0-D fields + ! + CALL iom_put( "AtmCO2", co2sbc ) ! global atmospheric CO2 [ppm] + + IF( iom_use("AtmC14") ) THEN + zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) ) ! global ocean surface + ztemp = glob_sum( 'trcwri_c14', c14sbc(:,:) * e1e2t(:,:) ) + ztemp = ( ztemp / zarea - 1._wp ) * 1000._wp + CALL iom_put( "AtmC14" , ztemp ) ! Global atmospheric DeltaC14 [permil] + ENDIF + IF( iom_use("K_C14") ) THEN + ztemp = glob_sum ( 'trcwri_c14', exch_c14(:,:) * e1e2t(:,:) ) + ztemp = rsiyea * ztemp / zarea + CALL iom_put( "K_C14" , ztemp ) ! global mean exchange velocity for C14/C ratio [m/yr] + ENDIF + IF( iom_use("K_CO2") ) THEN + zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) ) ! global ocean surface + ztemp = glob_sum ( 'trcwri_c14', exch_co2(:,:) * e1e2t(:,:) ) + ztemp = 360000._wp * ztemp / zarea ! cm/h units: directly comparable with literature + CALL iom_put( "K_CO2", ztemp ) ! global mean CO2 piston velocity [cm/hr] + ENDIF + IF( iom_use("C14Inv") ) THEN + ztemp = glob_sum( 'trcwri_c14', trn(:,:,:,jp_c14) * cvol(:,:,:) ) + ztemp = atomc14 * xdicsur * ztemp + CALL iom_put( "C14Inv", ztemp ) ! Radiocarbon ocean inventory [10^26 atoms] + END IF + ! + END SUBROUTINE trc_wri_c14 + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No C14 tracer + !!---------------------------------------------------------------------- + PUBLIC trc_wri_c14 +CONTAINS + SUBROUTINE trc_wri_c14 ! Empty routine + END SUBROUTINE trc_wri_c14 +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_c14.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcwri_c14 diff --git a/V4.0/nemo_sources/src/TOP/CFC/par_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/par_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2e7c28415fc35ecbc15b13929d6541ee7cf7fc0e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/par_cfc.F90 @@ -0,0 +1,17 @@ +MODULE par_cfc + !!====================================================================== + !! *** par_cfc *** + !! TOP : set the CFC parameters + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: par_cfc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER, PUBLIC :: jp_cfc0, jp_cfc1 !: First/last index of CFC tracers + + !!====================================================================== +END MODULE par_cfc diff --git a/V4.0/nemo_sources/src/TOP/CFC/trcice_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/trcice_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..07a05610bca16378e44c48ff9dbdbca1ef89d297 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/trcice_cfc.F90 @@ -0,0 +1,39 @@ +MODULE trcice_cfc + !!====================================================================== + !! *** MODULE trcice_cfc *** + !! TOP : Main module of the MY_TRC tracers + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code + !!---------------------------------------------------------------------- + !! trc_ice_cfc : MY_TRC model main routine + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc ! Ocean variables + USE trc ! TOP variables + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini_cfc ! called by trcice.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice_cfc.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini_cfc + !!---------------------------------------------------------------------- + !! *** trc_ice_cfc *** + !! + !! ** Purpose : main routine of MY_TRC model + !! + !! ** Method : - + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE trc_ice_ini_cfc + + !!====================================================================== +END MODULE trcice_cfc diff --git a/V4.0/nemo_sources/src/TOP/CFC/trcini_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/trcini_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a87f20394902452724dc325f78a5957c7e75da46 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/trcini_cfc.F90 @@ -0,0 +1,146 @@ +MODULE trcini_cfc + !!====================================================================== + !! *** MODULE trcini_cfc *** + !! TOP : initialisation of the CFC tracers + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! trc_ini_cfc : CFC model initialisation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE par_trc ! TOP parameters + USE trc ! TOP variables + USE trcnam_cfc ! CFC SMS namelist + USE trcsms_cfc ! CFC sms trends + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ini_cfc ! called by trcini.F90 module + + INTEGER :: inum ! unit number + REAL(wp) :: ylats = -10. ! 10 degrees south + REAL(wp) :: ylatn = 10. ! 10 degrees north + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini_cfc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ini_cfc + !!---------------------------------------------------------------------- + !! *** trc_ini_cfc *** + !! + !! ** Purpose : initialization for cfc model + !! + !! ** Method : - Read the namcfc namelist and check the parameter values + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn, jl, jm, js, io, ierr + INTEGER :: iskip = 6 ! number of 1st descriptor lines + REAL(wp) :: zyy, zyd + CHARACTER(len = 20) :: cltra + !!---------------------------------------------------------------------- + ! + CALL trc_nam_cfc + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_ini_cfc: initialisation of CFC chemical model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) 'Read annual atmospheric concentratioins from formatted file : ' // TRIM(clname) + + CALL ctl_opn( inum, clname, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND(inum) + + ! compute the number of year in the file + ! file starts in 1931 do jn represent the year in the century + jn = 31 + DO + READ(inum,'(1x)',END=100) + jn = jn + 1 + END DO + 100 jpyear = jn - 1 - iskip + IF ( lwp) WRITE(numout,*) ' ---> ', jpyear ,' years read' + ! ! Allocate CFC arrays + + ALLOCATE( p_cfc(jpyear,jphem,3), STAT=ierr ) + IF( ierr > 0 ) THEN + CALL ctl_stop( 'trc_ini_cfc: unable to allocate p_cfc array' ) ; RETURN + ENDIF + IF( trc_sms_cfc_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_ini_cfc: unable to allocate CFC arrays' ) + + + ! Initialization of boundaries conditions + ! --------------------------------------- + xphem (:,:) = 0._wp + p_cfc(:,:,:) = 0._wp + + ! Initialization of qint in case of no restart + !---------------------------------------------- + qtr_cfc(:,:,:) = 0._wp + IF( .NOT. ln_rsttr ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'Initialisation of qint ; No restart : qint equal zero ' + ENDIF + qint_cfc(:,:,:) = 0._wp + DO jl = 1, jp_cfc + jn = jp_cfc0 + jl - 1 + trn(:,:,:,jn) = 0._wp + END DO + ENDIF + + REWIND(inum) + + DO jm = 1, iskip ! Skip over 1st six descriptor lines + READ(inum,'(1x)') + END DO + ! file starts in 1931 do jn represent the year in the century.jhh + ! Read file till the end + jn = 31 + DO + READ(inum,*, IOSTAT=io) zyy, p_cfc(jn,1:2,1), p_cfc(jn,1:2,2), p_cfc(jn,1:2,3) + IF( io < 0 ) exit + jn = jn + 1 + END DO + + !p_cfc(32,1:2,1) = 5.e-4 ! modify the values of the first years + !p_cfc(33,1:2,1) = 8.e-4 + !p_cfc(34,1:2,1) = 1.e-6 + !p_cfc(35,1:2,1) = 2.e-3 + !p_cfc(36,1:2,1) = 4.e-3 + !p_cfc(37,1:2,1) = 6.e-3 + !p_cfc(38,1:2,1) = 8.e-3 + !p_cfc(39,1:2,1) = 1.e-2 + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Year c11NH c11SH c12NH c12SH SF6NH SF6SH' + DO jn = 30, jpyear + WRITE(numout, '( 1I4, 6F10.4)') jn, p_cfc(jn,1:2,1), p_cfc(jn,1:2,2), p_cfc(jn,1:2,3) + END DO + ENDIF + + + ! Interpolation factor of atmospheric partial pressure + ! Linear interpolation between 2 hemispheric function of latitud between ylats and ylatn + !--------------------------------------------------------------------------------------- + zyd = ylatn - ylats + DO jj = 1 , jpj + DO ji = 1 , jpi + IF( gphit(ji,jj) >= ylatn ) THEN ; xphem(ji,jj) = 1.e0 + ELSEIF( gphit(ji,jj) <= ylats ) THEN ; xphem(ji,jj) = 0.e0 + ELSE ; xphem(ji,jj) = ( gphit(ji,jj) - ylats) / zyd + ENDIF + END DO + END DO + ! + IF(lwp) WRITE(numout,*) 'Initialization of CFC tracers done' + IF(lwp) WRITE(numout,*) ' ' + ! + END SUBROUTINE trc_ini_cfc + + !!====================================================================== +END MODULE trcini_cfc diff --git a/V4.0/nemo_sources/src/TOP/CFC/trcnam_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/trcnam_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f98d9e7e507c0f650e024fbcb70b538245568819 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/trcnam_cfc.F90 @@ -0,0 +1,108 @@ +MODULE trcnam_cfc + !!====================================================================== + !! *** MODULE trcnam_cfc *** + !! TOP : initialisation of some run parameters for CFC chemical model + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcnam.cfc.h90 + !!---------------------------------------------------------------------- + !! trc_nam_cfc : CFC model initialisation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE trc ! TOP variables + USE trcsms_cfc ! CFC specific variable + + IMPLICIT NONE + PRIVATE + + CHARACTER(len=34), PUBLIC :: clname ! Input filename of CFCs atm. concentrations + + PUBLIC trc_nam_cfc ! called by trcnam.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam_cfc.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_nam_cfc + !!------------------------------------------------------------------- + !! *** ROUTINE trc_nam_cfc *** + !! + !! ** Purpose : Definition some run parameter for CFC model + !! + !! ** Method : Read the namcfc namelist and check the parameter + !! values called at the first timestep (nittrc000) + !! + !! ** input : Namelist namcfc + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + INTEGER :: jl, jn + !! + NAMELIST/namcfc/ ndate_beg, nyear_res, clname + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) ' CFCs' + WRITE(numout,*) ' ' + WRITE(numout,*) ' trc_nam_cfc : Read namcfc namelist for CFC chemical model' + WRITE(numout,*) ' ~~~~~~~~~~~' + ENDIF + ! + REWIND( numtrc_ref ) ! Namelist namcfcdate in reference namelist : CFC parameters + READ ( numtrc_ref, namcfc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfc in reference namelist' ) + REWIND( numtrc_cfg ) ! Namelist namcfcdate in configuration namelist : CFC parameters + READ ( numtrc_cfg, namcfc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfc in configuration namelist' ) + IF(lwm) WRITE( numonr, namcfc ) + IF(lwm) CALL FLUSH ( numonr ) ! flush output namelist CFC + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namcfc' + WRITE(numout,*) ' initial calendar date (aammjj) for CFC ndate_beg = ', ndate_beg, '[yymmdd]' + WRITE(numout,*) ' restoring time constant (year) nyear_res = ', nyear_res + ENDIF + nyear_beg = ndate_beg / 10000 + IF(lwp) WRITE(numout,*) ' associated initial year (aa) nyear_beg = ', nyear_beg, '[yy]' + ! + jn = jp_cfc0 - 1 + ! Variables setting + IF( ln_cfc11 ) THEN + jn = jn + 1 + ctrcnm (jn) = 'CFC11' + ctrcln (jn) = 'Chlorofluoro carbon 11 Concentration' + ctrcun (jn) = 'umolC/L' + ln_trc_ini(jn) = .false. + ln_trc_sbc(jn) = .false. + ln_trc_cbc(jn) = .false. + ln_trc_obc(jn) = .false. + ENDIF + ! + IF( ln_cfc12 ) THEN + jn = jn + 1 + ctrcnm (jn) = 'CFC12' + ctrcln (jn) = 'Chlorofluoro carbon 12 Concentration' + ctrcun (jn) = 'umolC/L' + ln_trc_ini(jn) = .false. + ln_trc_sbc(jn) = .false. + ln_trc_cbc(jn) = .false. + ln_trc_obc(jn) = .false. + ENDIF + ! + IF( ln_sf6 ) THEN + jn = jn + 1 + ctrcnm (jn) = 'SF6' + ctrcln (jn) = 'Sulfur hexafluoride Concentration' + ctrcun (jn) = 'umol/L' + ln_trc_ini(jn) = .false. + ln_trc_sbc(jn) = .false. + ln_trc_cbc(jn) = .false. + ln_trc_obc(jn) = .false. + ENDIF + ! + END SUBROUTINE trc_nam_cfc + + !!====================================================================== +END MODULE trcnam_cfc diff --git a/V4.0/nemo_sources/src/TOP/CFC/trcsms_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/trcsms_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..513a92be4ab47af55b72056ddb5e1593096aa566 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/trcsms_cfc.F90 @@ -0,0 +1,321 @@ +MODULE trcsms_cfc + !!====================================================================== + !! *** MODULE trcsms_cfc *** + !! TOP : CFC main model + !!====================================================================== + !! History : OPA ! 1999-10 (JC. Dutay) original code + !! NEMO 1.0 ! 2004-03 (C. Ethe) free form + modularity + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) reorganisation + !! 4.0 ! 2016-11 (T. Lovato) Add SF6, Update Schmidt number + !!---------------------------------------------------------------------- + !! trc_sms_cfc : compute and add CFC suface forcing to CFC trends + !! cfc_init : sets constants for CFC surface forcing computation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE par_trc ! TOP parameters + USE trc ! TOP variables + USE trd_oce + USE trdtrc + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms_cfc ! called in ??? + PUBLIC trc_sms_cfc_alloc ! called in trcini_cfc.F90 + + INTEGER , PUBLIC, PARAMETER :: jphem = 2 ! parameter for the 2 hemispheres + INTEGER , PUBLIC :: jpyear ! Number of years read in input data file (in trcini_cfc) + INTEGER , PUBLIC :: ndate_beg ! initial calendar date (aammjj) for CFC + INTEGER , PUBLIC :: nyear_res ! restoring time constant (year) + INTEGER , PUBLIC :: nyear_beg ! initial year (aa) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: p_cfc ! partial hemispheric pressure for all CFC + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: xphem ! spatial interpolation factor for patm + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_cfc ! flux at surface + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qint_cfc ! cumulative flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: atm_cfc ! partial hemispheric pressure for used CFC + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: patm ! atmospheric function + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: soa ! coefficient for solubility of CFC [mol/l/atm] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sob ! " " + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sca ! coefficients for schmidt number in degrees Celsius + ! ! coefficients for conversion + REAL(wp) :: xconv1 = 1.0 ! conversion from to + REAL(wp) :: xconv2 = 0.01/3600. ! conversion from cm/h to m/s: + REAL(wp) :: xconv3 = 1.0e+3 ! conversion from mol/l/atm to mol/m3/atm + REAL(wp) :: xconv4 = 1.0e-12 ! conversion from mol/m3/atm to mol/m3/pptv + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms_cfc.F90 12300 2020-01-06 08:31:02Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms_cfc( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sms_cfc *** + !! + !! ** Purpose : Compute the surface boundary contition on CFC 11 + !! passive tracer associated with air-mer fluxes and add it + !! to the general trend of tracers equations. + !! + !! ** Method : - get the atmospheric partial pressure - given in pico - + !! - computation of solubility ( in 1.e-12 mol/l then in 1.e-9 mol/m3) + !! - computation of transfert speed ( given in cm/hour ----> cm/s ) + !! - the input function is given by : + !! speed * ( concentration at equilibrium - concentration at surface ) + !! - the input function is in pico-mol/m3/s and the + !! CFC concentration in pico-mol/m3 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jn, jl, jm + INTEGER :: iyear_beg, iyear_end + INTEGER :: im1, im2, ierr + REAL(wp) :: ztap, zdtap + REAL(wp) :: zt1, zt2, zt3, zt4, zv2 + REAL(wp) :: zsol ! solubility + REAL(wp) :: zsch ! schmidt number + REAL(wp) :: zpp_cfc ! atmospheric partial pressure of CFC + REAL(wp) :: zca_cfc ! concentration at equilibrium + REAL(wp) :: zak_cfc ! transfert coefficients + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpatm ! atmospheric function + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sms_cfc') + ! + ALLOCATE( zpatm(jphem,jp_cfc), STAT=ierr ) + IF( ierr > 0 ) THEN + CALL ctl_stop( 'trc_sms_cfc: unable to allocate zpatm array' ) ; RETURN + ENDIF + + IF( kt == nittrc000 ) CALL cfc_init + + ! Temporal interpolation + ! ---------------------- + iyear_beg = nyear - 1900 + IF ( nmonth <= 6 ) THEN + iyear_beg = iyear_beg - 1 + im1 = 6 - nmonth + 1 + im2 = 6 + nmonth - 1 + ELSE + im1 = 12 - nmonth + 7 + im2 = nmonth - 7 + ENDIF + ! Avoid bad interpolation if starting date is =< 1900 + IF( iyear_beg .LE. 0 ) iyear_beg = 1 + IF( iyear_beg .GE. jpyear ) iyear_beg = jpyear - 1 + ! + iyear_end = iyear_beg + 1 + + ! !------------! + DO jl = 1, jp_cfc ! CFC loop ! + ! !------------! + jn = jp_cfc0 + jl - 1 + ! time interpolation at time kt + DO jm = 1, jphem + zpatm(jm,jl) = ( atm_cfc(iyear_beg, jm, jl) * REAL(im1, wp) & + & + atm_cfc(iyear_end, jm, jl) * REAL(im2, wp) ) / 12. + END DO + + ! !------------! + DO jj = 1, jpj ! i-j loop ! + DO ji = 1, jpi !------------! + + ! space interpolation + zpp_cfc = xphem(ji,jj) * zpatm(1,jl) & + & + ( 1.- xphem(ji,jj) ) * zpatm(2,jl) + + ! Computation of concentration at equilibrium : in picomol/l + ! coefficient for solubility for CFC-11/12 in mol/l/atm + IF( tmask(ji,jj,1) .GE. 0.5 ) THEN + ztap = ( tsn(ji,jj,1,jp_tem) + 273.16 ) * 0.01 + zdtap = sob(1,jl) + ztap * ( sob(2,jl) + ztap * sob(3,jl) ) + zsol = EXP( soa(1,jl) + soa(2,jl) / ztap + soa(3,jl) * LOG( ztap ) & + & + soa(4,jl) * ztap * ztap + tsn(ji,jj,1,jp_sal) * zdtap ) + ELSE + zsol = 0.e0 + ENDIF + ! conversion from mol/l/atm to mol/m3/atm and from mol/m3/atm to mol/m3/pptv + zsol = xconv4 * xconv3 * zsol * tmask(ji,jj,1) + ! concentration at equilibrium + zca_cfc = xconv1 * zpp_cfc * zsol * tmask(ji,jj,1) + + ! Computation of speed transfert + ! Schmidt number revised in Wanninkhof (2014) + zt1 = tsn(ji,jj,1,jp_tem) + zt2 = zt1 * zt1 + zt3 = zt1 * zt2 + zt4 = zt2 * zt2 + zsch = sca(1,jl) + sca(2,jl) * zt1 + sca(3,jl) * zt2 + sca(4,jl) * zt3 + sca(5,jl) * zt4 + + ! speed transfert : formulae revised in Wanninkhof (2014) + zv2 = wndm(ji,jj) * wndm(ji,jj) + zsch = zsch / 660. + zak_cfc = ( 0.251 * xconv2 * zv2 / SQRT(zsch) ) * tmask(ji,jj,1) + + ! Input function : speed *( conc. at equil - concen at surface ) + ! trn in pico-mol/l idem qtr; ak in en m/a + qtr_cfc(ji,jj,jl) = -zak_cfc * ( trb(ji,jj,1,jn) - zca_cfc ) & + & * tmask(ji,jj,1) * ( 1. - fr_i(ji,jj) ) + ! Add the surface flux to the trend + tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + qtr_cfc(ji,jj,jl) / e3t_n(ji,jj,1) + + ! cumulation of surface flux at each time step + qint_cfc(ji,jj,jl) = qint_cfc(ji,jj,jl) + qtr_cfc(ji,jj,jl) * rdt + ! !----------------! + END DO ! end i-j loop ! + END DO !----------------! + ! !----------------! + END DO ! end CFC loop ! + ! + IF( lrst_trc ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_sms_cfc : cumulated input function fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + jl = 0 + DO jn = jp_cfc0, jp_cfc1 + jl = jl + 1 + CALL iom_rstput( kt, nitrst, numrtw, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) ) + END DO + ENDIF + ! + IF( lk_iomput ) THEN + jl = 0 + DO jn = jp_cfc0, jp_cfc1 + jl = jl + 1 + CALL iom_put( 'qtr_'//TRIM(ctrcnm(jn)) , qtr_cfc (:,:,jl) ) + CALL iom_put( 'qint_'//TRIM(ctrcnm(jn)), qint_cfc(:,:,jl) ) + ENDDO + END IF + ! + IF( l_trdtrc ) THEN + DO jn = jp_cfc0, jp_cfc1 + CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends + END DO + END IF + ! + IF( ln_timing ) CALL timing_stop('trc_sms_cfc') + ! + END SUBROUTINE trc_sms_cfc + + + SUBROUTINE cfc_init + !!--------------------------------------------------------------------- + !! *** cfc_init *** + !! + !! ** Purpose : sets constants for CFC model + !!--------------------------------------------------------------------- + INTEGER :: jn, jl ! + !!---------------------------------------------------------------------- + ! + jn = 0 + ! coefficient for CFC11 + !---------------------- + if ( ln_cfc11 ) then + jn = jn + 1 + ! Solubility + soa(1,jn) = -229.9261 + soa(2,jn) = 319.6552 + soa(3,jn) = 119.4471 + soa(4,jn) = -1.39165 + + sob(1,jn) = -0.142382 + sob(2,jn) = 0.091459 + sob(3,jn) = -0.0157274 + + ! Schmidt number + sca(1,jn) = 3579.2 + sca(2,jn) = -222.63 + sca(3,jn) = 7.5749 + sca(4,jn) = -0.14595 + sca(5,jn) = 0.0011874 + + ! atm. concentration + atm_cfc(:,:,jn) = p_cfc(:,:,1) + endif + + ! coefficient for CFC12 + !---------------------- + if ( ln_cfc12 ) then + jn = jn + 1 + ! Solubility + soa(1,jn) = -218.0971 + soa(2,jn) = 298.9702 + soa(3,jn) = 113.8049 + soa(4,jn) = -1.39165 + + sob(1,jn) = -0.143566 + sob(2,jn) = 0.091015 + sob(3,jn) = -0.0153924 + + ! schmidt number + sca(1,jn) = 3828.1 + sca(2,jn) = -249.86 + sca(3,jn) = 8.7603 + sca(4,jn) = -0.1716 + sca(5,jn) = 0.001408 + + ! atm. concentration + atm_cfc(:,:,jn) = p_cfc(:,:,2) + endif + + ! coefficient for SF6 + !---------------------- + if ( ln_sf6 ) then + jn = jn + 1 + ! Solubility + soa(1,jn) = -80.0343 + soa(2,jn) = 117.232 + soa(3,jn) = 29.5817 + soa(4,jn) = 0.0 + + sob(1,jn) = 0.0335183 + sob(2,jn) = -0.0373942 + sob(3,jn) = 0.00774862 + + ! schmidt number + sca(1,jn) = 3177.5 + sca(2,jn) = -200.57 + sca(3,jn) = 6.8865 + sca(4,jn) = -0.13335 + sca(5,jn) = 0.0010877 + + ! atm. concentration + atm_cfc(:,:,jn) = p_cfc(:,:,3) + endif + + IF( ln_rsttr ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Read specific variables from CFC model ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ! + jl = 0 + DO jn = jp_cfc0, jp_cfc1 + jl = jl + 1 + CALL iom_get( numrtr, jpdom_autoglo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) ) + END DO + ENDIF + IF(lwp) WRITE(numout,*) + ! + END SUBROUTINE cfc_init + + + INTEGER FUNCTION trc_sms_cfc_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sms_cfc_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( xphem (jpi,jpj) , atm_cfc(jpyear,jphem,jp_cfc) , & + & qtr_cfc (jpi,jpj,jp_cfc) , qint_cfc(jpi,jpj,jp_cfc) , & + & soa(4,jp_cfc) , sob(3,jp_cfc) , sca(5,jp_cfc) , & + & STAT=trc_sms_cfc_alloc ) + ! + IF( trc_sms_cfc_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_sms_cfc_alloc : failed to allocate arrays.' ) + ! + END FUNCTION trc_sms_cfc_alloc + + !!====================================================================== +END MODULE trcsms_cfc diff --git a/V4.0/nemo_sources/src/TOP/CFC/trcwri_cfc.F90 b/V4.0/nemo_sources/src/TOP/CFC/trcwri_cfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3894ead8fb3819ec01794c5005bcd1647e2ea48e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/CFC/trcwri_cfc.F90 @@ -0,0 +1,56 @@ +MODULE trcwri_cfc + !!====================================================================== + !! *** MODULE trcwri *** + !! cfc : Output of cfc tracers + !!====================================================================== + !! History : 1.0 ! 2009-05 (C. Ethe) Original code + !!---------------------------------------------------------------------- +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! trc_wri_cfc : outputs of concentration fields + !!---------------------------------------------------------------------- + USE trc ! passive tracers common variables + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri_cfc + +CONTAINS + + SUBROUTINE trc_wri_cfc + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri_trc *** + !! + !! ** Purpose : output passive tracers fields + !!--------------------------------------------------------------------- + CHARACTER (len=20) :: cltra + INTEGER :: jn + !!--------------------------------------------------------------------- + + ! write the tracer concentrations in the file + ! --------------------------------------- + DO jn = jp_cfc0, jp_cfc1 + cltra = TRIM( ctrcnm(jn) ) ! short title for tracer + CALL iom_put( cltra, trn(:,:,:,jn) ) + END DO + ! + END SUBROUTINE trc_wri_cfc + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- + PUBLIC trc_wri_cfc +CONTAINS + SUBROUTINE trc_wri_cfc ! Empty routine + END SUBROUTINE trc_wri_cfc +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_cfc.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcwri_cfc diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/par_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/par_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..eb997610553773474eb6e95da9564b636f326273 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/par_my_trc.F90 @@ -0,0 +1,19 @@ +MODULE par_my_trc + !!====================================================================== + !! *** par_my_trc *** + !! TOP : set the MY_TRC parameters + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: par_my_trc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! Starting/ending PISCES do-loop indices (N.B. no PISCES : jpl_pcs < jpf_pcs the do-loop are never done) + INTEGER, PUBLIC :: jp_myt0 !: First index of MY_TRC passive tracers + INTEGER, PUBLIC :: jp_myt1 !: Last index of MY_TRC passive tracers + !!====================================================================== +END MODULE par_my_trc \ No newline at end of file diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/trcice_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/trcice_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8994c15e9bdad8191354cc98eda822b5d9cdf364 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/trcice_my_trc.F90 @@ -0,0 +1,35 @@ +MODULE trcice_my_trc + !!====================================================================== + !! *** MODULE trcice_my_trc *** + !!---------------------------------------------------------------------- + !! trc_ice_my_trc : MY_TRC model seaice coupling routine + !!---------------------------------------------------------------------- + !! History : ! 2016 (C. Ethe, T. Lovato) Revised architecture + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc ! Ocean variables + USE trc ! TOP variables + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini_my_trc ! called by trcice.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice_my_trc.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini_my_trc + !!---------------------------------------------------------------------- + !! *** trc_ice_my_trc *** + !! + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE trc_ice_ini_my_trc + + !!====================================================================== +END MODULE trcice_my_trc diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/trcini_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/trcini_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..93d8a8949a53a4a03c711e1815abd6ac32009c46 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/trcini_my_trc.F90 @@ -0,0 +1,57 @@ +MODULE trcini_my_trc + !!====================================================================== + !! *** MODULE trcini_my_trc *** + !! TOP : initialisation of the MY_TRC tracers + !!====================================================================== + !! History : ! 2007 (C. Ethe, G. Madec) Original code + !! ! 2016 (C. Ethe, T. Lovato) Revised architecture + !!---------------------------------------------------------------------- + !! trc_ini_my_trc : MY_TRC model initialisation + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc + USE trc + USE par_my_trc + USE trcnam_my_trc ! MY_TRC SMS namelist + USE trcsms_my_trc + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ini_my_trc ! called by trcini.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini_my_trc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ini_my_trc + !!---------------------------------------------------------------------- + !! *** trc_ini_my_trc *** + !! + !! ** Purpose : initialization for MY_TRC model + !! + !! ** Method : - Read the namcfc namelist and check the parameter values + !!---------------------------------------------------------------------- + ! + CALL trc_nam_my_trc + ! + ! ! Allocate MY_TRC arrays + IF( trc_sms_my_trc_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_ini_my_trc: unable to allocate MY_TRC arrays' ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_ini_my_trc: passive tracer unit vector' + IF(lwp) WRITE(numout,*) ' To check conservation : ' + IF(lwp) WRITE(numout,*) ' 1 - No sea-ice model ' + IF(lwp) WRITE(numout,*) ' 2 - No runoff ' + IF(lwp) WRITE(numout,*) ' 3 - precipitation and evaporation equal to 1 : E=P=1 ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + + IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 1. + ! + END SUBROUTINE trc_ini_my_trc + + !!====================================================================== +END MODULE trcini_my_trc diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/trcnam_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/trcnam_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..af4cbb2038fd43f386430ffbc7310e48605e79b9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/trcnam_my_trc.F90 @@ -0,0 +1,43 @@ +MODULE trcnam_my_trc + !!====================================================================== + !! *** MODULE trcnam_my_trc *** + !! TOP : initialisation of some run parameters for MY_TRC bio-model + !!====================================================================== + !! History : ! 2007 (C. Ethe, G. Madec) Original code + !! ! 2016 (C. Ethe, T. Lovato) Revised architecture + !!---------------------------------------------------------------------- + !! trc_nam_my_trc : MY_TRC model initialisation + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE par_trc ! TOP parameters + USE trc ! TOP variables + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_nam_my_trc ! called by trcnam.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam_my_trc.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE trc_nam_my_trc + !!---------------------------------------------------------------------- + !! *** trc_nam_my_trc *** + !! + !! ** Purpose : read MY_TRC namelist + !! + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_nam_my_trc : read MY_TRC namelists' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~' + ! + END SUBROUTINE trc_nam_my_trc + + !!====================================================================== +END MODULE trcnam_my_trc diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/trcsms_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/trcsms_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..670b6741f9a6678c42c6e8de80dd841ead638d24 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/trcsms_my_trc.F90 @@ -0,0 +1,85 @@ +MODULE trcsms_my_trc + !!====================================================================== + !! *** MODULE trcsms_my_trc *** + !! TOP : Main module of the MY_TRC tracers + !!====================================================================== + !! History : ! 2007 (C. Ethe, G. Madec) Original code + !! ! 2016 (C. Ethe, T. Lovato) Revised architecture + !!---------------------------------------------------------------------- + !! trc_sms_my_trc : MY_TRC model main routine + !! trc_sms_my_trc_alloc : allocate arrays specific to MY_TRC sms + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc ! Ocean variables + USE trc ! TOP variables + USE trd_oce + USE trdtrc + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms_my_trc ! called by trcsms.F90 module + PUBLIC trc_sms_my_trc_alloc ! called by trcini_my_trc.F90 module + + ! Defined HERE the arrays specific to MY_TRC sms and ALLOCATE them in trc_sms_my_trc_alloc + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms_my_trc.F90 12841 2020-05-01 10:52:40Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms_my_trc( kt ) + !!---------------------------------------------------------------------- + !! *** trc_sms_my_trc *** + !! + !! ** Purpose : main routine of MY_TRC model + !! + !! ** Method : - + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER :: jn ! dummy loop index + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrmyt + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sms_my_trc') + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_sms_my_trc: MY_TRC model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + + IF( l_trdtrc ) ALLOCATE( ztrmyt(jpi,jpj,jpk) ) + + ! add here the call to BGC model + + ! Save the trends in the mixed layer + IF( l_trdtrc ) THEN + DO jn = jp_myt0, jp_myt1 + ztrmyt(:,:,:) = tra(:,:,:,jn) + CALL trd_trc( ztrmyt, jn, jptra_sms, kt ) ! save trends + END DO + DEALLOCATE( ztrmyt ) + END IF + ! + IF( ln_timing ) CALL timing_stop('trc_sms_my_trc') + ! + END SUBROUTINE trc_sms_my_trc + + + INTEGER FUNCTION trc_sms_my_trc_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sms_my_trc_alloc *** + !!---------------------------------------------------------------------- + ! + ! ALLOCATE here the arrays specific to MY_TRC + ! ALLOCATE( tab(...) , STAT=trc_sms_my_trc_alloc ) + trc_sms_my_trc_alloc = 0 ! set to zero if no array to be allocated + ! + IF( trc_sms_my_trc_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_sms_my_trc_alloc : failed to allocate arrays' ) + ! + END FUNCTION trc_sms_my_trc_alloc + + !!====================================================================== +END MODULE trcsms_my_trc diff --git a/V4.0/nemo_sources/src/TOP/MY_TRC/trcwri_my_trc.F90 b/V4.0/nemo_sources/src/TOP/MY_TRC/trcwri_my_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..346c2270240c4b48e70e8484b95bfe871798e8b0 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/MY_TRC/trcwri_my_trc.F90 @@ -0,0 +1,56 @@ +MODULE trcwri_my_trc + !!====================================================================== + !! *** MODULE trcwri *** + !! trc_wri_my_trc : outputs of concentration fields + !!====================================================================== +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! History : ! 2007 (C. Ethe, G. Madec) Original code + !! ! 2016 (C. Ethe, T. Lovato) Revised architecture + !!---------------------------------------------------------------------- + USE par_trc ! passive tracers common variables + USE trc ! passive tracers common variables + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri_my_trc + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_my_trc.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_wri_my_trc + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri_trc *** + !! + !! ** Purpose : output passive tracers fields + !!--------------------------------------------------------------------- + CHARACTER (len=20) :: cltra + INTEGER :: jn + !!--------------------------------------------------------------------- + + ! write the tracer concentrations in the file + ! --------------------------------------- + DO jn = jp_myt0, jp_myt1 + cltra = TRIM( ctrcnm(jn) ) ! short title for tracer + CALL iom_put( cltra, trn(:,:,:,jn) ) + END DO + ! + END SUBROUTINE trc_wri_my_trc + +#else + +CONTAINS + + SUBROUTINE trc_wri_my_trc + ! + END SUBROUTINE trc_wri_my_trc + +#endif + +END MODULE trcwri_my_trc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zbio.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zbio.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c0546d46578904978dbd1c42e5ee1dfd00650df3 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zbio.F90 @@ -0,0 +1,492 @@ +MODULE p2zbio + !!====================================================================== + !! *** MODULE p2zbio *** + !! TOP : LOBSTER + !!====================================================================== + !! History : - ! 1999-07 (M. Levy) Original code + !! - ! 2000-12 (E. Kestenare) assign a parameter to name individual tracers + !! - ! 2001-03 (M. Levy) LNO3 + dia2d + !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 + !!---------------------------------------------------------------------- + !! p2z_bio : + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trc ! + USE sms_pisces ! + USE p2zopt ! + USE trd_oce ! + USE trdtrc ! + ! + USE lbclnk ! + USE prtctl_trc ! Print control for debbuging + USE iom ! + + IMPLICIT NONE + PRIVATE + + PUBLIC p2z_bio ! called in ??? + PUBLIC p2z_bio_init ! called in ??? + + REAL(wp) :: tmumax ! maximal phytoplankton growth rate [s-1] + REAL(wp) :: rgamma ! phytoplankton exudation fraction [%] + REAL(wp) :: fphylab ! NH4 fraction of phytoplankton exsudation + REAL(wp) :: tmminp ! minimal phytoplancton mortality rate [0.05/86400 s-1=20 days] + REAL(wp) :: aki ! light photosynthesis half saturation constant[W/m2] + ! + REAL(wp) :: akno3 ! nitrate limitation half-saturation value [mmol/m3] + REAL(wp) :: aknh4 ! ammonium limitation half-saturation value [mmol/m3] + REAL(wp) :: taunn ! nitrification rate [s-1] + REAL(wp) :: psinut ! inhibition of nitrate uptake by ammonium + ! + REAL(wp) :: taudn ! detritus breakdown rate [0.1/86400 s-1=10 days] + REAL(wp) :: fdetlab ! NH4 fraction of detritus dissolution + ! + REAL(wp) :: taudomn ! DOM breakdown rate [s-1] + ! ! slow remineralization rate of semi-labile dom to nh4 (1 month) + ! + REAL(wp) :: rppz ! ivlev coeff for zoo mortality + REAL(wp) :: taus ! specific zooplankton maximal grazing rate [s-1] + ! ! 0.75/86400 s-1=8.680555E-6 1/86400 = 1.15e-5 + REAL(wp) :: aks ! half-saturation constant for total zooplankton grazing [mmolN.m-3] + REAL(wp) :: rpnaz ! non-assimilated phytoplankton by zooplancton [%] + REAL(wp) :: rdnaz ! non-assimilated detritus by zooplankton [%] + REAL(wp) :: tauzn ! zooplancton specific excretion rate [0.1/86400 s-1=10 days] + REAL(wp) :: tmminz ! minimal zooplankton mortality rate [(mmolN/m3)-1 d-1] + REAL(wp) :: fzoolab ! NH4 fraction of zooplankton excretion + REAL(wp) :: fdbod ! zooplankton mortality fraction that goes to detritus + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p2zbio.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p2z_bio( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p2z_bio *** + !! + !! ** Purpose : compute the now trend due to biogeochemical processes + !! and add it to the general trend of passive tracers equations + !! + !! ** Method : each now biological flux is calculated in function of now + !! concentrations of tracers. + !! depending on the tracer, these fluxes are sources or sinks. + !! the total of the sources and sinks for each tracer + !! is added to the general trend. + !! + !! tra = tra + zf...tra - zftra... + !! | | + !! | | + !! source sink + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jl + REAL(wp) :: zdet, zzoo, zphy, zno3, znh4, zdom ! now concentrations + REAL(wp) :: zlno3, zlnh4, zle, zlt ! limitation terms for phyto + REAL(wp) :: zno3phy, znh4phy, zphynh4, zphydom + REAL(wp) :: zphydet, zphyzoo, zdetzoo + REAL(wp) :: zzoonh4, zzoodom, zzoodet, zdetnh4, zdetdom + REAL(wp) :: znh4no3, zdomnh4, zppz, zpdz, zpppz, zppdz, zfood + REAL(wp) :: zfilpz, zfildz, zphya, zzooa, zno3a + REAL(wp) :: znh4a, zdeta, zdoma, zzoobod, zboddet, zdomaju + REAL(wp) :: ze3t + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw2d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zw3d + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p2z_bio') + ! + IF( lk_iomput ) ALLOCATE( zw2d(jpi,jpj,17), zw3d(jpi,jpj,jpk,3) ) + + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p2z_bio: LOBSTER bio-model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~' + ENDIF + + xksi(:,:) = 0.e0 ! zooplakton closure ( fbod) + IF( lk_iomput ) THEN + zw2d (:,:,:) = 0._wp + zw3d(:,:,:,:) = 0._wp + ENDIF + + ! ! -------------------------- ! + DO jk = 1, jpkbm1 ! Upper ocean (bio-layers) ! + ! ! -------------------------- ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ! trophic variables( det, zoo, phy, no3, nh4, dom) + ! ------------------------------------------------ + + ! negative trophic variables DO not contribute to the fluxes + zdet = MAX( 0.e0, trn(ji,jj,jk,jpdet) ) + zzoo = MAX( 0.e0, trn(ji,jj,jk,jpzoo) ) + zphy = MAX( 0.e0, trn(ji,jj,jk,jpphy) ) + zno3 = MAX( 0.e0, trn(ji,jj,jk,jpno3) ) + znh4 = MAX( 0.e0, trn(ji,jj,jk,jpnh4) ) + zdom = MAX( 0.e0, trn(ji,jj,jk,jpdom) ) + + ! Limitations + zlt = 1. + zle = 1. - EXP( -etot(ji,jj,jk) / aki / zlt ) + ! psinut,akno3,aknh4 added by asklod AS Kremeur 2005-03 + zlno3 = zno3 * EXP( -psinut * znh4 ) / ( akno3 + zno3 ) + zlnh4 = znh4 / (znh4+aknh4) + + ! sinks and sources + ! phytoplankton production and exsudation + zno3phy = tmumax * zle * zlt * zlno3 * zphy + znh4phy = tmumax * zle * zlt * zlnh4 * zphy + + ! fphylab added by asklod AS Kremeur 2005-03 + zphydom = rgamma * (1 - fphylab) * (zno3phy + znh4phy) + zphynh4 = rgamma * fphylab * (zno3phy + znh4phy) + ! zooplankton production + ! preferences + zppz = rppz + zpdz = 1. - rppz + zpppz = ( zppz * zphy ) / ( ( zppz * zphy + zpdz * zdet ) + 1.e-13 ) + zppdz = ( zpdz * zdet ) / ( ( zppz * zphy + zpdz * zdet ) + 1.e-13 ) + zfood = zpppz * zphy + zppdz * zdet + ! filtration + zfilpz = taus * zpppz / (aks + zfood) + zfildz = taus * zppdz / (aks + zfood) + ! grazing + zphyzoo = zfilpz * zphy * zzoo + zdetzoo = zfildz * zdet * zzoo + + ! fecal pellets production + zzoodet = rpnaz * zphyzoo + rdnaz * zdetzoo + + ! zooplankton liquide excretion + zzoonh4 = tauzn * fzoolab * zzoo + zzoodom = tauzn * (1 - fzoolab) * zzoo + + ! mortality + ! phytoplankton mortality + zphydet = tmminp * zphy + + ! zooplankton mortality + ! closure : flux grazing is redistributed below level jpkbio + zzoobod = tmminz * zzoo * zzoo + xksi(ji,jj) = xksi(ji,jj) + (1-fdbod) * zzoobod * e3t_n(ji,jj,jk) + zboddet = fdbod * zzoobod + + ! detritus and dom breakdown + zdetnh4 = taudn * fdetlab * zdet + zdetdom = taudn * (1 - fdetlab) * zdet + + zdomnh4 = taudomn * zdom + + ! flux added to express how the excess of nitrogen from + ! PHY, ZOO and DET to DOM goes directly to NH4 (flux of ajustment) + zdomaju = (1 - redf/reddom) * (zphydom + zzoodom + zdetdom) + + ! Nitrification + znh4no3 = taunn * znh4 + + ! determination of trends + ! total trend for each biological tracer + zphya = zno3phy + znh4phy - zphynh4 - zphydom - zphyzoo - zphydet + zzooa = zphyzoo + zdetzoo - zzoodet - zzoodom - zzoonh4 - zzoobod + zno3a = - zno3phy + znh4no3 + znh4a = - znh4phy - znh4no3 + zphynh4 + zzoonh4 + zdomnh4 + zdetnh4 + zdomaju + zdeta = zphydet + zzoodet - zdetzoo - zdetnh4 - zdetdom + zboddet + zdoma = zphydom + zzoodom + zdetdom - zdomnh4 - zdomaju + + ! tracer flux at totox-point added to the general trend + tra(ji,jj,jk,jpdet) = tra(ji,jj,jk,jpdet) + zdeta + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) + zzooa + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) + zphya + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + zno3a + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + znh4a + tra(ji,jj,jk,jpdom) = tra(ji,jj,jk,jpdom) + zdoma + + IF( lk_iomput ) THEN + ! convert fluxes in per day + ze3t = e3t_n(ji,jj,jk) * 86400._wp + zw2d(ji,jj,1) = zw2d(ji,jj,1) + zno3phy * ze3t + zw2d(ji,jj,2) = zw2d(ji,jj,2) + znh4phy * ze3t + zw2d(ji,jj,3) = zw2d(ji,jj,3) + zphydom * ze3t + zw2d(ji,jj,4) = zw2d(ji,jj,4) + zphynh4 * ze3t + zw2d(ji,jj,5) = zw2d(ji,jj,5) + zphyzoo * ze3t + zw2d(ji,jj,6) = zw2d(ji,jj,6) + zphydet * ze3t + zw2d(ji,jj,7) = zw2d(ji,jj,7) + zdetzoo * ze3t + zw2d(ji,jj,8) = zw2d(ji,jj,8) + zzoodet * ze3t + zw2d(ji,jj,9) = zw2d(ji,jj,9) + zzoobod * ze3t + zw2d(ji,jj,10) = zw2d(ji,jj,10) + zzoonh4 * ze3t + zw2d(ji,jj,11) = zw2d(ji,jj,11) + zzoodom * ze3t + zw2d(ji,jj,12) = zw2d(ji,jj,12) + znh4no3 * ze3t + zw2d(ji,jj,13) = zw2d(ji,jj,13) + zdomnh4 * ze3t + zw2d(ji,jj,14) = zw2d(ji,jj,14) + zdetnh4 * ze3t + zw2d(ji,jj,15) = zw2d(ji,jj,15) + ( zno3phy + znh4phy - zphynh4 - zphydom - zphyzoo - zphydet ) * ze3t + zw2d(ji,jj,16) = zw2d(ji,jj,16) + ( zphyzoo + zdetzoo - zzoodet - zzoobod - zzoonh4 - zzoodom ) * ze3t + zw2d(ji,jj,17) = zw2d(ji,jj,17) + zdetdom * ze3t + ! + zw3d(ji,jj,jk,1) = zno3phy * 86400 + zw3d(ji,jj,jk,2) = znh4phy * 86400 + zw3d(ji,jj,jk,3) = znh4no3 * 86400 + ! + ENDIF + END DO + END DO + END DO + + ! ! -------------------------- ! + DO jk = jpkb, jpkm1 ! Upper ocean (bio-layers) ! + ! ! -------------------------- ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ! remineralisation of all quantities towards nitrate + + ! trophic variables( det, zoo, phy, no3, nh4, dom) + ! negative trophic variables DO not contribute to the fluxes + zdet = MAX( 0.e0, trn(ji,jj,jk,jpdet) ) + zzoo = MAX( 0.e0, trn(ji,jj,jk,jpzoo) ) + zphy = MAX( 0.e0, trn(ji,jj,jk,jpphy) ) + zno3 = MAX( 0.e0, trn(ji,jj,jk,jpno3) ) + znh4 = MAX( 0.e0, trn(ji,jj,jk,jpnh4) ) + zdom = MAX( 0.e0, trn(ji,jj,jk,jpdom) ) + + ! Limitations + zlt = 0.e0 + zle = 0.e0 + zlno3 = 0.e0 + zlnh4 = 0.e0 + + ! sinks and sources + ! phytoplankton production and exsudation + zno3phy = 0.e0 + znh4phy = 0.e0 + zphydom = 0.e0 + zphynh4 = 0.e0 + + ! zooplankton production + zphyzoo = 0.e0 ! grazing + zdetzoo = 0.e0 + + zzoodet = 0.e0 ! fecal pellets production + + zzoonh4 = tauzn * fzoolab * zzoo ! zooplankton liquide excretion + zzoodom = tauzn * (1 - fzoolab) * zzoo + + ! mortality + zphydet = tmminp * zphy ! phytoplankton mortality + + zzoobod = 0.e0 ! zooplankton mortality + zboddet = 0.e0 ! closure : flux fbod is redistributed below level jpkbio + + ! detritus and dom breakdown + zdetnh4 = taudn * fdetlab * zdet + zdetdom = taudn * (1 - fdetlab) * zdet + + zdomnh4 = taudomn * zdom + zdomaju = (1 - redf/reddom) * (zphydom + zzoodom + zdetdom) + + ! Nitrification + znh4no3 = taunn * znh4 + + + ! determination of trends + ! total trend for each biological tracer + zphya = zno3phy + znh4phy - zphynh4 - zphydom - zphyzoo - zphydet + zzooa = zphyzoo + zdetzoo - zzoodet - zzoodom - zzoonh4 - zzoobod + zno3a = - zno3phy + znh4no3 + znh4a = - znh4phy - znh4no3 + zphynh4 + zzoonh4 + zdomnh4 + zdetnh4 + zdomaju + zdeta = zphydet + zzoodet - zdetzoo - zdetnh4 - zdetdom + zboddet + zdoma = zphydom + zzoodom + zdetdom - zdomnh4 - zdomaju + + ! tracer flux at totox-point added to the general trend + tra(ji,jj,jk,jpdet) = tra(ji,jj,jk,jpdet) + zdeta + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) + zzooa + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) + zphya + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + zno3a + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + znh4a + tra(ji,jj,jk,jpdom) = tra(ji,jj,jk,jpdom) + zdoma + ! + IF( lk_iomput ) THEN ! convert fluxes in per day + ze3t = e3t_n(ji,jj,jk) * 86400._wp + zw2d(ji,jj,1) = zw2d(ji,jj,1) + zno3phy * ze3t + zw2d(ji,jj,2) = zw2d(ji,jj,2) + znh4phy * ze3t + zw2d(ji,jj,3) = zw2d(ji,jj,3) + zphydom * ze3t + zw2d(ji,jj,4) = zw2d(ji,jj,4) + zphynh4 * ze3t + zw2d(ji,jj,5) = zw2d(ji,jj,5) + zphyzoo * ze3t + zw2d(ji,jj,6) = zw2d(ji,jj,6) + zphydet * ze3t + zw2d(ji,jj,7) = zw2d(ji,jj,7) + zdetzoo * ze3t + zw2d(ji,jj,8) = zw2d(ji,jj,8) + zzoodet * ze3t + zw2d(ji,jj,9) = zw2d(ji,jj,9) + zzoobod * ze3t + zw2d(ji,jj,10) = zw2d(ji,jj,10) + zzoonh4 * ze3t + zw2d(ji,jj,11) = zw2d(ji,jj,11) + zzoodom * ze3t + zw2d(ji,jj,12) = zw2d(ji,jj,12) + znh4no3 * ze3t + zw2d(ji,jj,13) = zw2d(ji,jj,13) + zdomnh4 * ze3t + zw2d(ji,jj,14) = zw2d(ji,jj,14) + zdetnh4 * ze3t + zw2d(ji,jj,15) = zw2d(ji,jj,15) + ( zno3phy + znh4phy - zphynh4 - zphydom - zphyzoo - zphydet ) * ze3t + zw2d(ji,jj,16) = zw2d(ji,jj,16) + ( zphyzoo + zdetzoo - zzoodet - zzoobod - zzoonh4 - zzoodom ) * ze3t + zw2d(ji,jj,17) = zw2d(ji,jj,17) + zdetdom * ze3t + ! + zw3d(ji,jj,jk,1) = zno3phy * 86400._wp + zw3d(ji,jj,jk,2) = znh4phy * 86400._wp + zw3d(ji,jj,jk,3) = znh4no3 * 86400._wp + ! + ENDIF + END DO + END DO + END DO + ! + IF( lk_iomput ) THEN + CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp ) + CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp ) + ! Save diagnostics + CALL iom_put( "TNO3PHY", zw2d(:,:,1) ) + CALL iom_put( "TNH4PHY", zw2d(:,:,2) ) + CALL iom_put( "TPHYDOM", zw2d(:,:,3) ) + CALL iom_put( "TPHYNH4", zw2d(:,:,4) ) + CALL iom_put( "TPHYZOO", zw2d(:,:,5) ) + CALL iom_put( "TPHYDET", zw2d(:,:,6) ) + CALL iom_put( "TDETZOO", zw2d(:,:,7) ) + CALL iom_put( "TZOODET", zw2d(:,:,8) ) + CALL iom_put( "TZOOBOD", zw2d(:,:,9) ) + CALL iom_put( "TZOONH4", zw2d(:,:,10) ) + CALL iom_put( "TZOODOM", zw2d(:,:,11) ) + CALL iom_put( "TNH4NO3", zw2d(:,:,12) ) + CALL iom_put( "TDOMNH4", zw2d(:,:,13) ) + CALL iom_put( "TDETNH4", zw2d(:,:,14) ) + CALL iom_put( "TPHYTOT", zw2d(:,:,15) ) + CALL iom_put( "TZOOTOT", zw2d(:,:,16) ) + ! + CALL iom_put( "FNO3PHY", zw3d(:,:,:,1) ) + CALL iom_put( "FNH4PHY", zw3d(:,:,:,2) ) + CALL iom_put( "FNH4NO3", zw3d(:,:,:,3) ) + ! + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('bio')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( lk_iomput ) DEALLOCATE( zw2d, zw3d ) + ! + IF( ln_timing ) CALL timing_stop('p2z_bio') + ! + END SUBROUTINE p2z_bio + + + SUBROUTINE p2z_bio_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_bio_init *** + !! + !! ** Purpose : biological parameters + !! + !! ** Method : Read namelist and check the parameters + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namlobphy/ tmumax, rgamma, fphylab, tmminp, aki + NAMELIST/namlobnut/ akno3, aknh4, taunn, psinut + NAMELIST/namlobzoo/ rppz, taus, aks, rpnaz, rdnaz, tauzn, fzoolab, fdbod, tmminz + NAMELIST/namlobdet/ taudn, fdetlab + NAMELIST/namlobdom/ taudomn + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p2z_bio_init : LOBSTER bio-model initialization' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~' + ! + REWIND( numnatp_ref ) ! Namelist namlobphy in reference namelist : Lobster biological parameters + READ ( numnatp_ref, namlobphy, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobphy in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobphy in configuration namelist : Lobster biological parameters + READ ( numnatp_cfg, namlobphy, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobphy in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobphy ) + ! + IF(lwp) THEN + WRITE(numout,*) ' Namelist namlobphy' + WRITE(numout,*) ' phyto max growth rate tmumax =', 86400 * tmumax, ' d' + WRITE(numout,*) ' phytoplankton exudation fraction rgamma =', rgamma + WRITE(numout,*) ' NH4 fraction of phytoplankton exsudation fphylab =', fphylab + WRITE(numout,*) ' minimal phyto mortality rate tmminp =', 86400 * tmminp + WRITE(numout,*) ' light hlaf saturation constant aki =', aki + ENDIF + + REWIND( numnatp_ref ) ! Namelist namlobnut in reference namelist : Lobster nutriments parameters + READ ( numnatp_ref, namlobnut, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobnut in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobnut in configuration namelist : Lobster nutriments parameters + READ ( numnatp_cfg, namlobnut, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobnut in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobnut ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namlobnut' + WRITE(numout,*) ' half-saturation nutrient for no3 uptake akno3 =', akno3 + WRITE(numout,*) ' half-saturation nutrient for nh4 uptake aknh4 =', aknh4 + WRITE(numout,*) ' nitrification rate taunn =', taunn + WRITE(numout,*) ' inhibition of no3 uptake by nh4 psinut =', psinut + ENDIF + + REWIND( numnatp_ref ) ! Namelist namlobzoo in reference namelist : Lobster zooplankton parameters + READ ( numnatp_ref, namlobzoo, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobzoo in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobzoo in configuration namelist : Lobster zooplankton parameters + READ ( numnatp_cfg, namlobzoo, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobzoo in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobzoo ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namlobzoo' + WRITE(numout,*) ' zoo preference for phyto rppz =', rppz + WRITE(numout,*) ' maximal zoo grazing rate taus =', 86400 * taus, ' d' + WRITE(numout,*) ' half saturation constant for zoo food aks =', aks + WRITE(numout,*) ' non-assimilated phyto by zoo rpnaz =', rpnaz + WRITE(numout,*) ' non-assimilated detritus by zoo rdnaz =', rdnaz + WRITE(numout,*) ' zoo specific excretion rate tauzn =', 86400 * tauzn + WRITE(numout,*) ' minimal zoo mortality rate tmminz =', 86400 * tmminz + WRITE(numout,*) ' NH4 fraction of zooplankton excretion fzoolab =', fzoolab + WRITE(numout,*) ' Zooplankton mortality fraction that goes to detritus fdbod =', fdbod + ENDIF + + REWIND( numnatp_ref ) ! Namelist namlobdet in reference namelist : Lobster detritus parameters + READ ( numnatp_ref, namlobdet, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobdet in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobdet in configuration namelist : Lobster detritus parameters + READ ( numnatp_cfg, namlobdet, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobdet in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobdet ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namlobdet' + WRITE(numout,*) ' detrital breakdown rate taudn =', 86400 * taudn , ' d' + WRITE(numout,*) ' NH4 fraction of detritus dissolution fdetlab =', fdetlab + ENDIF + + REWIND( numnatp_ref ) ! Namelist namlobdom in reference namelist : Lobster DOM breakdown rate + READ ( numnatp_ref, namlobdom, IOSTAT = ios, ERR = 909) +909 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobdom in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobdom in configuration namelist : Lobster DOM breakdown rate + READ ( numnatp_cfg, namlobdom, IOSTAT = ios, ERR = 910 ) +910 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobdom in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobdom ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namlobdom' + WRITE(numout,*) ' DOM breakdown rate taudomn =', 86400 * taudn , ' d' + ENDIF + ! + END SUBROUTINE p2z_bio_init + + !!====================================================================== +END MODULE p2zbio diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zexp.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zexp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ea308323969fff4662047a85308b3dd11da9a01e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zexp.F90 @@ -0,0 +1,255 @@ +MODULE p2zexp + !!====================================================================== + !! *** MODULE p2zsed *** + !! TOP : LOBSTER Compute loss of organic matter in the sediments + !!====================================================================== + !! History : - ! 1999 (O. Aumont, C. Le Quere) original code + !! - ! 2001-05 (O. Aumont, E. Kestenare) add sediment computations + !! 1.0 ! 2005-06 (A.-S. Kremeur) new temporal integration for sedpoc + !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 + !! 3.5 ! 2012-03 (C. Ethe) Merge PISCES-LOBSTER + !!---------------------------------------------------------------------- + !! p2z_exp : Compute loss of organic matter in the sediments + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trc + USE sms_pisces + USE p2zsed + USE lbclnk + USE prtctl_trc ! Print control for debbuging + USE trd_oce + USE trdtrc + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC p2z_exp + PUBLIC p2z_exp_init + PUBLIC p2z_exp_alloc + + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dminl !: fraction of sinking POC released in sediments + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: dmin3 !: fraction of sinking POC released at each level + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: sedpocb !: mass of POC in sediments + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: sedpocn !: mass of POC in sediments + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: cmask !: Coastal mask area + REAL(wp) :: areacot !: surface coastal area + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p2zexp.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p2z_exp( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p2z_exp *** + !! + !! ** Purpose : MODELS EXPORT OF BIOGENIC MATTER (POC ''SOFT + !! TISSUE'') AND ITS DISTRIBUTION IN WATER COLUMN + !! + !! ** Method : - IN THE SURFACE LAYER POC IS PRODUCED ACCORDING TO + !! NURTRIENTS AVAILABLE AND GROWTH CONDITIONS. NUTRIENT UPTAKE + !! KINETICS FOLLOW MICHAELIS-MENTON FORMULATION. + !! THE TOTAL PARTICLE AMOUNT PRODUCED, IS DISTRIBUTED IN THE WATER + !! COLUMN BELOW THE SURFACE LAYER. + !!--------------------------------------------------------------------- + !! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jl, ikt + REAL(wp) :: zgeolpoc, zfact, zwork, ze3t, zsedpocd, zmaskt + REAL(wp), DIMENSION(jpi,jpj) :: zsedpoca + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p2z_exp') + ! + IF( kt == nittrc000 ) CALL p2z_exp_init + + zsedpoca(:,:) = 0. + + + ! VERTICAL DISTRIBUTION OF NEWLY PRODUCED BIOGENIC + ! POC IN THE WATER COLUMN + ! (PARTS OF NEWLY FORMED MATTER REMAINING IN THE DIFFERENT + ! LAYERS IS DETERMINED BY DMIN3 DEFINED IN sms_p2z.F90 + ! ---------------------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ze3t = 1. / e3t_n(ji,jj,jk) + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + ze3t * dmin3(ji,jj,jk) * xksi(ji,jj) + END DO + END DO + END DO + + ! Find the last level of the water column + ! Compute fluxes due to sinking particles (slow) + + + zgeolpoc = 0.e0 ! Initialization + ! Release of nutrients from the "simple" sediment + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ikt = mbkt(ji,jj) + tra(ji,jj,ikt,jpno3) = tra(ji,jj,ikt,jpno3) + sedlam * sedpocn(ji,jj) / e3t_n(ji,jj,ikt) + ! Deposition of organic matter in the sediment + zwork = vsed * trn(ji,jj,ikt,jpdet) + zsedpoca(ji,jj) = ( zwork + dminl(ji,jj) * xksi(ji,jj) & + & - sedlam * sedpocn(ji,jj) - sedlostpoc * sedpocn(ji,jj) ) * rdt + zgeolpoc = zgeolpoc + sedlostpoc * sedpocn(ji,jj) * e1e2t(ji,jj) + END DO + END DO + + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + tra(ji,jj,1,jpno3) = tra(ji,jj,1,jpno3) + zgeolpoc * cmask(ji,jj) / areacot / e3t_n(ji,jj,1) + END DO + END DO + + CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp ) + + ! Oa & Ek: diagnostics depending on jpdia2d ! left as example + IF( lk_iomput ) CALL iom_put( "SEDPOC" , sedpocn ) + + + ! Time filter and swap of arrays + ! ------------------------------ + IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! Euler time-stepping at first time-step + ! ! (only swap) + sedpocn(:,:) = zsedpoca(:,:) + ! + ELSE + ! + DO jj = 1, jpj + DO ji = 1, jpi + zsedpocd = zsedpoca(ji,jj) - 2. * sedpocn(ji,jj) + sedpocb(ji,jj) ! time laplacian on tracers + sedpocb(ji,jj) = sedpocn(ji,jj) + atfp * zsedpocd ! sedpocb <-- filtered sedpocn + sedpocn(ji,jj) = zsedpoca(ji,jj) ! sedpocn <-- sedpoca + END DO + END DO + ! + ENDIF + ! + IF( lrst_trc ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'p2z_exp : POC in sediment fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrtw, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) ) + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('exp')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p2z_exp') + ! + END SUBROUTINE p2z_exp + + + SUBROUTINE p2z_exp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_exp_init *** + !! ** purpose : specific initialisation for export + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zmaskt, zfluo, zfluu + REAL(wp), DIMENSION(jpi,jpj ) :: zrro + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdm0 + !!--------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' p2z_exp: LOBSTER export' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' compute remineralisation-damping arrays for tracers' + ENDIF + ! + + ! Calculate vertical distribution of newly formed biogenic poc + ! in the water column in the case of max. possible bottom depth + ! ------------------------------------------------------------ + zdm0 = 0._wp + zrro = 1._wp + DO jk = jpkb, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zfluo = ( gdepw_n(ji,jj,jk ) / gdepw_n(ji,jj,jpkb) )**xhr + zfluu = ( gdepw_n(ji,jj,jk+1) / gdepw_n(ji,jj,jpkb) )**xhr + IF( zfluo.GT.1. ) zfluo = 1._wp + zdm0(ji,jj,jk) = zfluo - zfluu + IF( jk <= jpkb-1 ) zdm0(ji,jj,jk) = 0._wp + zrro(ji,jj) = zrro(ji,jj) - zdm0(ji,jj,jk) + END DO + END DO + END DO + ! + zdm0(:,:,jpk) = zrro(:,:) + + ! Calculate vertical distribution of newly formed biogenic poc + ! in the water column with realistic topography (first "dry" layer + ! contains total fraction, which has passed to the upper layers) + ! ---------------------------------------------------------------------- + dminl(:,:) = 0._wp + dmin3(:,:,:) = zdm0 + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,jk) == 0._wp ) THEN + dminl(ji,jj) = dminl(ji,jj) + dmin3(ji,jj,jk) + dmin3(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END DO + + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,1) == 0 ) dmin3(ji,jj,1) = 0._wp + END DO + END DO + + ! Coastal mask + cmask(:,:) = 0._wp + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + IF( tmask(ji,jj,1) /= 0. ) THEN + zmaskt = tmask(ji+1,jj,1) * tmask(ji-1,jj,1) * tmask(ji,jj+1,1) * tmask(ji,jj-1,1) + IF( zmaskt == 0. ) cmask(ji,jj) = 1._wp + END IF + END DO + END DO + CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged) + areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) ) + ! + IF( ln_rsttr ) THEN + CALL iom_get( numrtr, jpdom_autoglo, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) ) + CALL iom_get( numrtr, jpdom_autoglo, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) ) + ELSE + sedpocb(:,:) = 0._wp + sedpocn(:,:) = 0._wp + ENDIF + ! + END SUBROUTINE p2z_exp_init + + INTEGER FUNCTION p2z_exp_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_exp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( cmask(jpi,jpj) , dminl(jpi,jpj) , dmin3(jpi,jpj,jpk), & + & sedpocb(jpi,jpj) , sedpocn(jpi,jpj), STAT=p2z_exp_alloc ) + IF( p2z_exp_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p2z_exp_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p2z_exp_alloc + + !!====================================================================== +END MODULE p2zexp diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zopt.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zopt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e2796360dfcced875a5a35a33e2f86a00543f984 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zopt.F90 @@ -0,0 +1,203 @@ +MODULE p2zopt + !!====================================================================== + !! *** MODULE p2zopt *** + !! TOP : LOBSTER Compute the light availability in the water column + !!====================================================================== + !! History : - ! 1995-05 (M. Levy) Original code + !! - ! 1999-09 (J.-M. Andre, M. Levy) + !! - ! 1999-11 (C. Menkes, M.-A. Foujols) itabe initial + !! - ! 2000-02 (M.A. Foujols) change x**y par exp(y*log(x)) + !! NEMO 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 + !! 3.2 ! 2009-04 (C. Ethe, G. Madec) minor optimisation + style + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! p2z_opt : Compute the light availability in the water column + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trc + USE sms_pisces + USE prtctl_trc ! Print control for debbuging + + IMPLICIT NONE + PRIVATE + + PUBLIC p2z_opt ! + PUBLIC p2z_opt_init ! + + REAL(wp), PUBLIC :: xkr0 !: water coefficient absorption in red + REAL(wp), PUBLIC :: xkg0 !: water coefficient absorption in green + REAL(wp), PUBLIC :: xkrp !: pigment coefficient absorption in red + REAL(wp), PUBLIC :: xkgp !: pigment coefficient absorption in green + REAL(wp), PUBLIC :: xlr !: exposant for pigment absorption in red + REAL(wp), PUBLIC :: xlg !: exposant for pigment absorption in green + REAL(wp), PUBLIC :: rpig !: chla/chla+phea ratio + ! + REAL(wp), PUBLIC :: rcchl ! Carbone/Chlorophyl ratio [mgC.mgChla-1] + REAL(wp), PUBLIC :: redf ! redfield ratio (C:N) for phyto + REAL(wp), PUBLIC :: reddom ! redfield ratio (C:N) for DOM + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p2zopt.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p2z_opt( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p2z_opt *** + !! + !! ** Purpose : computes the light propagation in the water column + !! and the euphotic layer depth + !! + !! ** Method : local par is computed in w layers using light propagation + !! mean par in t layers are computed by integration + !! +!!gm please remplace the '???' by true comments + !! ** Action : etot ??? + !! neln ??? + !!--------------------------------------------------------------------- + !! + INTEGER, INTENT( in ) :: kt ! index of the time stepping + !! + INTEGER :: ji, jj, jk ! dummy loop indices + CHARACTER (len=25) :: charout ! temporary character + REAL(wp) :: zpig ! log of the total pigment + REAL(wp) :: zkr, zkg ! total absorption coefficient in red and green + REAL(wp) :: zcoef ! temporary scalar + REAL(wp), DIMENSION(jpi,jpj ) :: zpar100, zpar0m + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zparr, zparg + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p2z_opt') + ! + + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p2z_opt : LOBSTER optic-model' + IF(lwp) WRITE(numout,*) ' ~~~~~~~ ' + ENDIF + + ! ! surface irradiance + ! ! ------------------ + IF( ln_dm2dc ) THEN ; zpar0m(:,:) = qsr_mean(:,:) * 0.43 + ELSE ; zpar0m(:,:) = qsr (:,:) * 0.43 + ENDIF + zpar100(:,:) = zpar0m(:,:) * 0.01 + zparr (:,:,1) = zpar0m(:,:) * 0.5 + zparg (:,:,1) = zpar0m(:,:) * 0.5 + + ! ! Photosynthetically Available Radiation (PAR) + zcoef = 12 * redf / rcchl / rpig ! -------------------------------------- + DO jk = 2, jpk ! local par at w-levels + DO jj = 1, jpj + DO ji = 1, jpi + zpig = LOG( MAX( TINY(0.), trn(ji,jj,jk-1,jpphy) ) * zcoef ) + zkr = xkr0 + xkrp * EXP( xlr * zpig ) + zkg = xkg0 + xkgp * EXP( xlg * zpig ) + zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * e3t_n(ji,jj,jk-1) ) + zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t_n(ji,jj,jk-1) ) + END DO + END DO + END DO + DO jk = 1, jpkm1 ! mean par at t-levels + DO jj = 1, jpj + DO ji = 1, jpi + zpig = LOG( MAX( TINY(0.), trn(ji,jj,jk,jpphy) ) * zcoef ) + zkr = xkr0 + xkrp * EXP( xlr * zpig ) + zkg = xkg0 + xkgp * EXP( xlg * zpig ) + zparr(ji,jj,jk) = zparr(ji,jj,jk) / ( zkr * e3t_n(ji,jj,jk) ) * ( 1 - EXP( -zkr * e3t_n(ji,jj,jk) ) ) + zparg(ji,jj,jk) = zparg(ji,jj,jk) / ( zkg * e3t_n(ji,jj,jk) ) * ( 1 - EXP( -zkg * e3t_n(ji,jj,jk) ) ) + etot (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 ) + END DO + END DO + END DO + + ! ! Euphotic layer + ! ! -------------- + neln(:,:) = 1 ! euphotic layer level + DO jk = 1, jpkm1 ! (i.e. 1rst T-level strictly below EL bottom) + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot(ji,jj,jk) >= zpar100(ji,jj) ) neln(ji,jj) = jk + 1 + END DO + END DO + END DO + ! ! Euphotic layer depth + DO jj = 1, jpj + DO ji = 1, jpi + heup(ji,jj) = gdepw_n(ji,jj,neln(ji,jj)) + END DO + END DO + + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('opt')") + CALL prt_ctl_trc_info( charout ) + CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p2z_opt') + ! + END SUBROUTINE p2z_opt + + + SUBROUTINE p2z_opt_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_opt_init *** + !! + !! ** Purpose : optical parameters + !! + !! ** Method : Read the namlobopt namelist and check the parameters + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namlobopt/ xkg0, xkr0, xkgp, xkrp, xlg, xlr, rpig + NAMELIST/namlobrat/ rcchl, redf, reddom + !!---------------------------------------------------------------------- + + REWIND( numnatp_ref ) ! Namelist namlobopt in reference namelist : Lobster options + READ ( numnatp_ref, namlobopt, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobopt in reference namelist' ) + + REWIND( numnatp_cfg ) ! Namelist namlobopt in configuration namelist : Lobster options + READ ( numnatp_cfg, namlobopt, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobopt in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobopt ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namlobopt' + WRITE(numout,*) ' green water absorption coeff xkg0 = ', xkg0 + WRITE(numout,*) ' red water absorption coeff xkr0 = ', xkr0 + WRITE(numout,*) ' pigment red absorption coeff xkrp = ', xkrp + WRITE(numout,*) ' pigment green absorption coeff xkgp = ', xkgp + WRITE(numout,*) ' green chl exposant xlg = ', xlg + WRITE(numout,*) ' red chl exposant xlr = ', xlr + WRITE(numout,*) ' chla/chla+phea ratio rpig = ', rpig + WRITE(numout,*) ' ' + ENDIF + ! + REWIND( numnatp_ref ) ! Namelist namlobrat in reference namelist : Lobster ratios + READ ( numnatp_ref, namlobrat, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobrat in reference namelist' ) + + REWIND( numnatp_cfg ) ! Namelist namlobrat in configuration namelist : Lobster ratios + READ ( numnatp_cfg, namlobrat, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobrat in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobrat ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist namlobrat' + WRITE(numout,*) ' carbone/chlorophyl ratio rcchl = ', rcchl + WRITE(numout,*) ' redfield ratio c:n for phyto redf =', redf + WRITE(numout,*) ' redfield ratio c:n for DOM reddom =', reddom + WRITE(numout,*) ' ' + ENDIF + ! + END SUBROUTINE p2z_opt_init + + !!====================================================================== +END MODULE p2zopt diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..34633da061d2933c2edbb786c5702d08af76250a --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsed.F90 @@ -0,0 +1,154 @@ +MODULE p2zsed + !!====================================================================== + !! *** MODULE p2zsed *** + !! TOP : PISCES Compute loss of organic matter in the sediments + !!====================================================================== + !! History : - ! 1995-06 (M. Levy) original code + !! - ! 2000-12 (E. Kestenare) clean up + !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 + simplifications + !!---------------------------------------------------------------------- + !! p2z_sed : Compute loss of organic matter in the sediments + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trd_oce ! + USE trdtrc ! + USE trc ! + USE sms_pisces ! + ! + USE lbclnk ! + USE iom ! + USE prtctl_trc ! Print control for debbuging + + IMPLICIT NONE + PRIVATE + + PUBLIC p2z_sed ! called in ??? + PUBLIC p2z_sed_init ! called in ??? + + REAL(wp), PUBLIC :: sedlam !: time coefficient of POC remineralization in sediments + REAL(wp), PUBLIC :: sedlostpoc !: mass of POC lost in sediments + REAL(wp), PUBLIC :: vsed !: detritus sedimentation speed [m/s] + REAL(wp), PUBLIC :: xhr !: coeff for martin''s remineralisation profile + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p2zsed.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p2z_sed( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p2z_sed *** + !! + !! ** Purpose : compute the now trend due to the vertical sedimentation of + !! detritus and add it to the general trend of detritus equations + !! + !! ** Method : this ROUTINE compute not exactly the advection but the + !! transport term, i.e. dz(wt) and dz(ws)., dz(wtr) + !! using an upstream scheme + !! the now vertical advection of tracers is given by: + !! dz(trn wn) = 1/bt dk+1( e1t e2t vsed (trn) ) + !! add this trend now to the general trend of tracer (ta,sa,tra): + !! tra = tra + dz(trn wn) + !! + !! IF 'key_diabio' is defined, the now vertical advection + !! trend of passive tracers is saved for futher diagnostics. + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jl, ierr + CHARACTER (len=25) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zw2d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwork, ztra + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p2z_sed') + ! + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p2z_sed: LOBSTER sedimentation' + IF(lwp) WRITE(numout,*) ' ~~~~~~~' + ENDIF + + ! sedimentation of detritus : upstream scheme + ! -------------------------------------------- + + ! for detritus sedimentation only - jpdet + zwork(:,:,1 ) = 0.e0 ! surface value set to zero + zwork(:,:,jpk) = 0.e0 ! bottom value set to zero + + ! tracer flux at w-point: we use -vsed (downward flux) with simplification : no e1*e2 + DO jk = 2, jpkm1 + zwork(:,:,jk) = -vsed * trn(:,:,jk-1,jpdet) + END DO + + ! tracer flux divergence at t-point added to the general trend + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ztra(ji,jj,jk) = - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) + tra(ji,jj,jk,jpdet) = tra(ji,jj,jk,jpdet) + ztra(ji,jj,jk) + END DO + END DO + END DO + + IF( lk_iomput ) THEN + IF( iom_use( "TDETSED" ) ) THEN + ALLOCATE( zw2d(jpi,jpj) ) + zw2d(:,:) = ztra(:,:,1) * e3t_n(:,:,1) * 86400._wp + DO jk = 2, jpkm1 + zw2d(:,:) = zw2d(:,:) + ztra(:,:,jk) * e3t_n(:,:,jk) * 86400._wp + END DO + CALL iom_put( "TDETSED", zw2d ) + DEALLOCATE( zw2d ) + ENDIF + ENDIF + ! + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('sed')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p2z_sed') + ! + END SUBROUTINE p2z_sed + + + SUBROUTINE p2z_sed_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_sed_init *** + !! + !! ** Purpose : Parameters from aphotic layers to sediment + !! + !! ** Method : Read the namlobsed namelist and check the parameters + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namlobsed/ sedlam, sedlostpoc, vsed, xhr + !!---------------------------------------------------------------------- + ! + REWIND( numnatp_ref ) ! Namelist namlobsed in reference namelist : Lobster sediments + READ ( numnatp_ref, namlobsed, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlosed in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist namlobsed in configuration namelist : Lobster sediments + READ ( numnatp_cfg, namlobsed, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlobsed in configuration namelist' ) + IF(lwm) WRITE ( numonp, namlobsed ) + ! + IF(lwp) THEN + WRITE(numout,*) ' Namelist namlobsed' + WRITE(numout,*) ' time coeff of POC in sediments sedlam =', sedlam + WRITE(numout,*) ' Sediment geol loss for POC sedlostpoc=', sedlostpoc + WRITE(numout,*) ' detritus sedimentation speed vsed =', 86400 * vsed , ' d' + WRITE(numout,*) ' coeff for martin''s remineralistion xhr =', xhr + WRITE(numout,*) ' ' + ENDIF + ! + END SUBROUTINE p2z_sed_init + + !!====================================================================== +END MODULE p2zsed diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsms.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsms.F90 new file mode 100644 index 0000000000000000000000000000000000000000..de779c1c9460bdac5c6f8b4fbb03e202d914b951 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P2Z/p2zsms.F90 @@ -0,0 +1,70 @@ +MODULE p2zsms + !!====================================================================== + !! *** MODULE p2zsms *** + !! TOP : Time loop of LOBSTER model + !!====================================================================== + !! History : 1.0 ! M. Levy + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! p2zsms : Time loop of passive tracers sms + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trc + USE sms_pisces + USE p2zbio + USE p2zopt + USE p2zsed + USE p2zexp + USE trd_oce + USE trdtrc_oce + USE trdtrc + USE trdmxl_trc + + IMPLICIT NONE + PRIVATE + + PUBLIC p2z_sms ! called in p2zsms.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p2zsms.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p2z_sms( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p2z_sms *** + !! + !! ** Purpose : Managment of the call to Biological sources and sinks + !! routines of LOBSTER bio-model + !! + !! ** Method : - ??? + !! -------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: jn ! dummy loop index + !! -------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p2z_sms') + ! + CALL p2z_opt( kt ) ! optical model + CALL p2z_bio( kt ) ! biological model + CALL p2z_sed( kt ) ! sedimentation model + CALL p2z_exp( kt ) ! export + ! + IF( l_trdtrc ) THEN + DO jn = jp_pcs0, jp_pcs1 + CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends + END DO + END IF + ! + IF ( lwm .AND. kt == nittrc000 ) CALL FLUSH ( numonp ) ! flush output namelist PISCES + IF( ln_timing ) CALL timing_stop('p2z_sms') + ! + END SUBROUTINE p2z_sms + + !!====================================================================== +END MODULE p2zsms diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zagg.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zagg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..536250e6afb47f5b0688fa999c900c209cf1650d --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zagg.F90 @@ -0,0 +1,186 @@ +MODULE p4zagg + !!====================================================================== + !! *** MODULE p4zagg *** + !! TOP : PISCES aggregation of particles + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Change aggregation formula + !! 3.5 ! 2012-07 (O. Aumont) Introduce potential time-splitting + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! p4z_agg : Compute aggregation of particles + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_agg ! called in p4zbio.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zagg.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_agg ( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_agg *** + !! + !! ** Purpose : Compute aggregation of particles + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zagg, zagg1, zagg2, zagg3, zagg4 + REAL(wp) :: zaggpoc1, zaggpoc2, zaggpoc3, zaggpoc4 + REAL(wp) :: zaggpoc , zaggfe, zaggdoc, zaggdoc2, zaggdoc3 + REAL(wp) :: zaggpon , zaggdon, zaggdon2, zaggdon3 + REAL(wp) :: zaggpop, zaggdop, zaggdop2, zaggdop3 + REAL(wp) :: zaggtmp, zfact, zmax + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_agg') + ! + ! Exchange between organic matter compartments due to coagulation/disaggregation + ! --------------------------------------------------- + IF( ln_p4z ) THEN + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! + zfact = xstep * xdiss(ji,jj,jk) + ! Part I : Coagulation dependent on turbulence + zagg1 = 25.9 * zfact * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jppoc) + zagg2 = 4452. * zfact * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpgoc) + + ! Part II : Differential settling + + ! Aggregation of small into large particles + zagg3 = 47.1 * xstep * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpgoc) + zagg4 = 3.3 * xstep * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jppoc) + + zagg = zagg1 + zagg2 + zagg3 + zagg4 + zaggfe = zagg * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn ) + + ! Aggregation of DOC to POC : + ! 1st term is shear aggregation of DOC-DOC + ! 2nd term is shear aggregation of DOC-POC + ! 3rd term is differential settling of DOC-POC + zaggdoc = ( ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * zfact & + & + 2.4 * xstep * trb(ji,jj,jk,jppoc) ) * 0.3 * trb(ji,jj,jk,jpdoc) + ! transfer of DOC to GOC : + ! 1st term is shear aggregation + ! 2nd term is differential settling + zaggdoc2 = ( 3.53E3 * zfact + 0.1 * xstep ) * trb(ji,jj,jk,jpgoc) * 0.3 * trb(ji,jj,jk,jpdoc) + ! tranfer of DOC to POC due to brownian motion + zaggdoc3 = 114. * 0.3 * trb(ji,jj,jk,jpdoc) *xstep * 0.3 * trb(ji,jj,jk,jpdoc) + + ! Update the trends + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zagg + zaggdoc + zaggdoc3 + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zagg + zaggdoc2 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zaggfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zaggfe + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) - zaggdoc - zaggdoc2 - zaggdoc3 + ! + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zagg + zaggdoc + zaggdoc3 + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zagg + zaggdoc2 + ! + END DO + END DO + END DO + ELSE ! ln_p5z + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! + zfact = xstep * xdiss(ji,jj,jk) + ! Part I : Coagulation dependent on turbulence + zaggtmp = 25.9 * zfact * trb(ji,jj,jk,jppoc) + zaggpoc1 = zaggtmp * trb(ji,jj,jk,jppoc) + zaggtmp = 4452. * zfact * trb(ji,jj,jk,jpgoc) + zaggpoc2 = zaggtmp * trb(ji,jj,jk,jppoc) + + ! Part II : Differential settling + + ! Aggregation of small into large particles + zaggtmp = 47.1 * xstep * trb(ji,jj,jk,jpgoc) + zaggpoc3 = zaggtmp * trb(ji,jj,jk,jppoc) + zaggtmp = 3.3 * xstep * trb(ji,jj,jk,jppoc) + zaggpoc4 = zaggtmp * trb(ji,jj,jk,jppoc) + + zaggpoc = zaggpoc1 + zaggpoc2 + zaggpoc3 + zaggpoc4 + zaggpon = zaggpoc * trb(ji,jj,jk,jppon) / ( trb(ji,jj,jk,jppoc) + rtrn) + zaggpop = zaggpoc * trb(ji,jj,jk,jppop) / ( trb(ji,jj,jk,jppoc) + rtrn) + zaggfe = zaggpoc * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn ) + + ! Aggregation of DOC to POC : + ! 1st term is shear aggregation of DOC-DOC + ! 2nd term is shear aggregation of DOC-POC + ! 3rd term is differential settling of DOC-POC + zaggtmp = ( ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * zfact & + & + 2.4 * xstep * trb(ji,jj,jk,jppoc) ) + zaggdoc = zaggtmp * 0.3 * trb(ji,jj,jk,jpdoc) + zaggdon = zaggtmp * 0.3 * trb(ji,jj,jk,jpdon) + zaggdop = zaggtmp * 0.3 * trb(ji,jj,jk,jpdop) + + ! transfer of DOC to GOC : + ! 1st term is shear aggregation + ! 2nd term is differential settling + zaggtmp = ( 3.53E3 * zfact + 0.1 * xstep ) * trb(ji,jj,jk,jpgoc) + zaggdoc2 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdoc) + zaggdon2 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdon) + zaggdop2 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdop) + + ! tranfer of DOC to POC due to brownian motion + zaggtmp = ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) * xstep + zaggdoc3 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdoc) + zaggdon3 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdon) + zaggdop3 = zaggtmp * 0.3 * trb(ji,jj,jk,jpdop) + + ! Update the trends + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zaggpoc + zaggdoc + zaggdoc3 + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) - zaggpon + zaggdon + zaggdon3 + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) - zaggpop + zaggdop + zaggdop3 + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zaggpoc + zaggdoc2 + tra(ji,jj,jk,jpgon) = tra(ji,jj,jk,jpgon) + zaggpon + zaggdon2 + tra(ji,jj,jk,jpgop) = tra(ji,jj,jk,jpgop) + zaggpop + zaggdop2 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zaggfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zaggfe + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) - zaggdoc - zaggdoc2 - zaggdoc3 + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) - zaggdon - zaggdon2 - zaggdon3 + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) - zaggdop - zaggdop2 - zaggdop3 + ! + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zaggpoc + zaggdoc + zaggdoc3 + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zaggpoc + zaggdoc2 + ! + END DO + END DO + END DO + ! + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('agg')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_agg') + ! + END SUBROUTINE p4z_agg + + !!====================================================================== +END MODULE p4zagg diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zbio.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zbio.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6acc25715adeb56145bd63980d09f2f48c71a2d2 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zbio.F90 @@ -0,0 +1,119 @@ +MODULE p4zbio + !!====================================================================== + !! *** MODULE p4zbio *** + !! TOP : PISCES bio-model + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !!---------------------------------------------------------------------- + !! p4z_bio : computes the interactions between the different + !! compartments of PISCES + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zsink ! vertical flux of particulate matter due to sinking + USE p4zopt ! optical model + USE p4zlim ! Co-limitations of differents nutrients + USE p4zprod ! Growth rate of the 2 phyto groups + USE p4zmort ! Mortality terms for phytoplankton + USE p4zmicro ! Sources and sinks of microzooplankton + USE p4zmeso ! Sources and sinks of mesozooplankton + USE p5zlim ! Co-limitations of differents nutrients + USE p5zprod ! Growth rate of the 2 phyto groups + USE p5zmort ! Mortality terms for phytoplankton + USE p5zmicro ! Sources and sinks of microzooplankton + USE p5zmeso ! Sources and sinks of mesozooplankton + USE p4zrem ! Remineralisation of organic matter + USE p4zpoc ! Remineralization of organic particles + USE p4zagg ! Aggregation of particles + USE p4zfechem + USE p4zligand ! Prognostic ligand model + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_bio + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zbio.F90 10227 2018-10-25 14:42:24Z aumont $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_bio ( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_bio *** + !! + !! ** Purpose : Ecosystem model in the whole ocean: computes the + !! different interactions between the different compartments + !! of PISCES + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt + ! + INTEGER :: ji, jj, jk, jn + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_bio') + ! + ! ASSIGN THE SHEAR RATE THAT IS USED FOR AGGREGATION + ! OF PHYTOPLANKTON AND DETRITUS + + xdiss(:,:,:) = 1. +!!gm the use of nmld should be better here? + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi +!!gm : use nmln and test on jk ... less memory acces + IF( gdepw_n(ji,jj,jk+1) > hmld(ji,jj) ) xdiss(ji,jj,jk) = 0.01 + END DO + END DO + END DO + + CALL p4z_opt ( kt, knt ) ! Optic: PAR in the water column + CALL p4z_sink ( kt, knt ) ! vertical flux of particulate organic matter + CALL p4z_fechem ( kt, knt ) ! Iron chemistry/scavenging + ! + IF( ln_p4z ) THEN + CALL p4z_lim ( kt, knt ) ! co-limitations by the various nutrients + CALL p4z_prod ( kt, knt ) ! phytoplankton growth rate over the global ocean. + ! ! (for each element : C, Si, Fe, Chl ) + CALL p4z_mort ( kt ) ! phytoplankton mortality + ! ! zooplankton sources/sinks routines + CALL p4z_micro( kt, knt ) ! microzooplankton + CALL p4z_meso ( kt, knt ) ! mesozooplankton + ELSE + CALL p5z_lim ( kt, knt ) ! co-limitations by the various nutrients + CALL p5z_prod ( kt, knt ) ! phytoplankton growth rate over the global ocean. + ! ! (for each element : C, Si, Fe, Chl ) + CALL p5z_mort ( kt ) ! phytoplankton mortality + ! ! zooplankton sources/sinks routines + CALL p5z_micro( kt, knt ) ! microzooplankton + CALL p5z_meso ( kt, knt ) ! mesozooplankton + ENDIF + ! + CALL p4z_agg ( kt, knt ) ! Aggregation of particles + CALL p4z_rem ( kt, knt ) ! remineralization terms of organic matter+scavenging of Fe + CALL p4z_poc ( kt, knt ) ! Remineralization of organic particles + ! + IF( ln_ligand ) & + & CALL p4z_ligand( kt, knt ) + ! ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('bio ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_bio') + ! + END SUBROUTINE p4z_bio + + !!====================================================================== +END MODULE p4zbio diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zche.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zche.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a3eb565505d309a93ea86ce708a91ce592c57178 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zche.F90 @@ -0,0 +1,830 @@ +MODULE p4zche + !!====================================================================== + !! *** MODULE p4zche *** + !! TOP : PISCES Sea water chemistry computed following OCMIP protocol + !!====================================================================== + !! History : OPA ! 1988 (E. Maier-Reimer) Original code + !! - ! 1998 (O. Aumont) addition + !! - ! 1999 (C. Le Quere) modification + !! NEMO 1.0 ! 2004 (O. Aumont) modification + !! - ! 2006 (R. Gangsto) modification + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! ! 2011-02 (J. Simeon, J.Orr ) update O2 solubility constants + !! 3.6 ! 2016-03 (O. Aumont) Change chemistry to MOCSY standards + !!---------------------------------------------------------------------- + !! p4z_che : Sea water chemistry computed following OCMIP protocol + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE lib_mpp ! MPP library + USE eosbn2, ONLY : neos + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_che ! + PUBLIC p4z_che_alloc ! + PUBLIC ahini_for_at ! + PUBLIC solve_at_general ! + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sio3eq ! chemistry of Si + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fekeq ! chemistry of Fe + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemc ! Solubilities of O2 and CO2 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemo2 ! Solubilities of O2 and CO2 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: fesol ! solubility of Fe + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: salinprac ! Practical salinity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tempis ! In situ temperature + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akb3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akw3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akf3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aks3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak1p3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak2p3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak3p3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aksi3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: borat !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fluorid !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sulfat !: ??? + + !!* Variable for chemistry of the CO2 cycle + + REAL(wp), PUBLIC :: atcox = 0.20946 ! units atm + + REAL(wp) :: o2atm = 1. / ( 1000. * 0.20946 ) + + REAL(wp) :: rgas = 83.14472 ! universal gas constants + REAL(wp) :: oxyco = 1. / 22.4144 ! converts from liters of an ideal gas to moles + ! ! coeff. for seawater pressure correction : millero 95 + ! ! AGRIF doesn't like the DATA instruction + REAL(wp) :: devk10 = -25.5 + REAL(wp) :: devk11 = -15.82 + REAL(wp) :: devk12 = -29.48 + REAL(wp) :: devk13 = -20.02 + REAL(wp) :: devk14 = -18.03 + REAL(wp) :: devk15 = -9.78 + REAL(wp) :: devk16 = -48.76 + REAL(wp) :: devk17 = -14.51 + REAL(wp) :: devk18 = -23.12 + REAL(wp) :: devk19 = -26.57 + REAL(wp) :: devk110 = -29.48 + ! + REAL(wp) :: devk20 = 0.1271 + REAL(wp) :: devk21 = -0.0219 + REAL(wp) :: devk22 = 0.1622 + REAL(wp) :: devk23 = 0.1119 + REAL(wp) :: devk24 = 0.0466 + REAL(wp) :: devk25 = -0.0090 + REAL(wp) :: devk26 = 0.5304 + REAL(wp) :: devk27 = 0.1211 + REAL(wp) :: devk28 = 0.1758 + REAL(wp) :: devk29 = 0.2020 + REAL(wp) :: devk210 = 0.1622 + ! + REAL(wp) :: devk30 = 0. + REAL(wp) :: devk31 = 0. + REAL(wp) :: devk32 = 2.608E-3 + REAL(wp) :: devk33 = -1.409e-3 + REAL(wp) :: devk34 = 0.316e-3 + REAL(wp) :: devk35 = -0.942e-3 + REAL(wp) :: devk36 = 0. + REAL(wp) :: devk37 = -0.321e-3 + REAL(wp) :: devk38 = -2.647e-3 + REAL(wp) :: devk39 = -3.042e-3 + REAL(wp) :: devk310 = -2.6080e-3 + ! + REAL(wp) :: devk40 = -3.08E-3 + REAL(wp) :: devk41 = 1.13E-3 + REAL(wp) :: devk42 = -2.84E-3 + REAL(wp) :: devk43 = -5.13E-3 + REAL(wp) :: devk44 = -4.53e-3 + REAL(wp) :: devk45 = -3.91e-3 + REAL(wp) :: devk46 = -11.76e-3 + REAL(wp) :: devk47 = -2.67e-3 + REAL(wp) :: devk48 = -5.15e-3 + REAL(wp) :: devk49 = -4.08e-3 + REAL(wp) :: devk410 = -2.84e-3 + ! + REAL(wp) :: devk50 = 0.0877E-3 + REAL(wp) :: devk51 = -0.1475E-3 + REAL(wp) :: devk52 = 0. + REAL(wp) :: devk53 = 0.0794E-3 + REAL(wp) :: devk54 = 0.09e-3 + REAL(wp) :: devk55 = 0.054e-3 + REAL(wp) :: devk56 = 0.3692E-3 + REAL(wp) :: devk57 = 0.0427e-3 + REAL(wp) :: devk58 = 0.09e-3 + REAL(wp) :: devk59 = 0.0714e-3 + REAL(wp) :: devk510 = 0.0 + ! + ! General parameters + REAL(wp), PARAMETER :: pp_rdel_ah_target = 1.E-4_wp + REAL(wp), PARAMETER :: pp_ln10 = 2.302585092994045684018_wp + + ! Maximum number of iterations for each method + INTEGER, PARAMETER :: jp_maxniter_atgen = 20 + + ! Bookkeeping variables for each method + ! - SOLVE_AT_GENERAL + INTEGER :: niter_atgen = jp_maxniter_atgen + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zche.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_che + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_che *** + !! + !! ** Purpose : Sea water chemistry computed following OCMIP protocol + !! + !! ** Method : - ... + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: ztkel, ztkel1, zt , zsal , zsal2 , zbuf1 , zbuf2 + REAL(wp) :: ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 + REAL(wp) :: zpres, ztc , zcl , zcpexp, zoxy , zcpexp2 + REAL(wp) :: zsqrt, ztr , zlogt , zcek1, zc1, zplat + REAL(wp) :: zis , zis2 , zsal15, zisqrt, za1, za2 + REAL(wp) :: zckb , zck1 , zck2 , zckw , zak1 , zak2 , zakb , zaksp0, zakw + REAL(wp) :: zck1p, zck2p, zck3p, zcksi, zak1p, zak2p, zak3p, zaksi + REAL(wp) :: zst , zft , zcks , zckf , zaksp1 + REAL(wp) :: total2free, free2SWS, total2SWS, SWS2total + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_che') + ! + ! Computation of chemical constants require practical salinity + ! Thus, when TEOS08 is used, absolute salinity is converted to + ! practical salinity + ! ------------------------------------------------------------- + IF (neos == -1) THEN + salinprac(:,:,:) = tsn(:,:,:,jp_sal) * 35.0 / 35.16504 + ELSE + salinprac(:,:,:) = tsn(:,:,:,jp_sal) + ENDIF + + ! + ! Computations of chemical constants require in situ temperature + ! Here a quite simple formulation is used to convert + ! potential temperature to in situ temperature. The errors is less than + ! 0.04°C relative to an exact computation + ! --------------------------------------------------------------------- + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + zpres = gdept_n(ji,jj,jk) / 1000. + za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (salinprac(ji,jj,jk) - 35.0) ) + za2 = 0.0075 * ( 1.0 - tsn(ji,jj,jk,jp_tem) / 30.0 ) + tempis(ji,jj,jk) = tsn(ji,jj,jk,jp_tem) - za1 * zpres + za2 * zpres**2 + END DO + END DO + END DO + ! + ! CHEMICAL CONSTANTS - SURFACE LAYER + ! ---------------------------------- +!CDIR NOVERRCHK + DO jj = 1, jpj +!CDIR NOVERRCHK + DO ji = 1, jpi + ! ! SET ABSOLUTE TEMPERATURE + ztkel = tempis(ji,jj,1) + 273.15 + zt = ztkel * 0.01 + zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. + ! ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) + ! ! AND FOR THE ATMOSPHERE FOR NON IDEAL GAS + zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel & + & + 0.0047036e-4*ztkel**2) + chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 * rhop(ji,jj,1) / 1000. ! mol/(L atm) + chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 + chemc(ji,jj,3) = 57.7 - 0.118*ztkel + ! + END DO + END DO + + ! OXYGEN SOLUBILITY - DEEP OCEAN + ! ------------------------------- +!CDIR NOVERRCHK + DO jk = 1, jpk +!CDIR NOVERRCHK + DO jj = 1, jpj +!CDIR NOVERRCHK + DO ji = 1, jpi + ztkel = tempis(ji,jj,jk) + 273.15 + zsal = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35. + zsal2 = zsal * zsal + ztgg = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel ) ! Set the GORDON & GARCIA scaled temperature + ztgg2 = ztgg * ztgg + ztgg3 = ztgg2 * ztgg + ztgg4 = ztgg3 * ztgg + ztgg5 = ztgg4 * ztgg + + zoxy = 2.00856 + 3.22400 * ztgg + 3.99063 * ztgg2 + 4.80299 * ztgg3 & + & + 9.78188e-1 * ztgg4 + 1.71069 * ztgg5 + zsal * ( -6.24097e-3 & + & - 6.93498e-3 * ztgg - 6.90358e-3 * ztgg2 - 4.29155e-3 * ztgg3 ) & + & - 3.11680e-7 * zsal2 + chemo2(ji,jj,jk) = ( EXP( zoxy ) * o2atm ) * oxyco * atcox ! mol/(L atm) + END DO + END DO + END DO + + ! CHEMICAL CONSTANTS - DEEP OCEAN + ! ------------------------------- +!CDIR NOVERRCHK + DO jk = 1, jpk +!CDIR NOVERRCHK + DO jj = 1, jpj +!CDIR NOVERRCHK + DO ji = 1, jpi + + ! SET PRESSION ACCORDING TO SAUNDER (1980) + zplat = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) ) + zc1 = 5.92E-3 + zplat**2 * 5.25E-3 + zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*gdept_n(ji,jj,jk)))) / 4.42E-6 + zpres = zpres / 10.0 + + ! SET ABSOLUTE TEMPERATURE + ztkel = tempis(ji,jj,jk) + 273.15 + zsal = salinprac(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. + zsqrt = SQRT( zsal ) + zsal15 = zsqrt * zsal + zlogt = LOG( ztkel ) + ztr = 1. / ztkel + zis = 19.924 * zsal / ( 1000.- 1.005 * zsal ) + zis2 = zis * zis + zisqrt = SQRT( zis ) + ztc = tempis(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. + + ! CHLORINITY (WOOSTER ET AL., 1969) + zcl = zsal / 1.80655 + + ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] + zst = 0.14 * zcl /96.062 + + ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] + zft = 0.000067 * zcl /18.9984 + + ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) + zcks = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt & + & + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & + & + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis & + & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & + & + LOG(1.0 - 0.001005 * zsal)) + + ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) + zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & + & + LOG(1.0d0 - 0.001005d0*zsal) & + & + LOG(1.0d0 + zst/zcks)) + + ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE + zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & + & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & + & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & + & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & + & * zlogt + 0.053105*zsqrt*ztkel + + ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO + ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale + zck1 = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt & + - 0.011555*zsal + 0.0001152*zsal*zsal) + zck2 = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt & + - 0.01781*zsal + 0.0001122*zsal*zsal) + + ! PKW (H2O) (MILLERO, 1995) from composite data + zckw = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr & + - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal + + ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) + zck1p = -4576.752*ztr + 115.540 - 18.453*zlogt & + & + (-106.736*ztr + 0.69171) * zsqrt & + & + (-0.65643*ztr - 0.01844) * zsal + + zck2p = -8814.715*ztr + 172.1033 - 27.927*zlogt & + & + (-160.340*ztr + 1.3566)*zsqrt & + & + (0.37335*ztr - 0.05778)*zsal + + zck3p = -3070.75*ztr - 18.126 & + & + (17.27039*ztr + 2.81197) * zsqrt & + & + (-44.99486*ztr - 0.09984) * zsal + + ! CONSTANT FOR SILICATE, MILLERO (1995) + zcksi = -8904.2*ztr + 117.400 - 19.334*zlogt & + & + (-458.79*ztr + 3.5913) * zisqrt & + & + (188.74*ztr - 1.5998) * zis & + & + (-12.1652*ztr + 0.07871) * zis2 & + & + LOG(1.0 - 0.001005*zsal) + + ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER + ! (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) + zaksp0 = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel ) & + & + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt & + & - 0.07711*zsal + 0.0041249*zsal15 + + ! CONVERT FROM DIFFERENT PH SCALES + total2free = 1.0/(1.0 + zst/zcks) + free2SWS = 1. + zst/zcks + zft/(zckf*total2free) + total2SWS = total2free * free2SWS + SWS2total = 1.0 / total2SWS + + ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) + zak1 = 10**(zck1) * total2SWS + zak2 = 10**(zck2) * total2SWS + zakb = EXP( zckb ) * total2SWS + zakw = EXP( zckw ) + zaksp1 = 10**(zaksp0) + zak1p = exp( zck1p ) + zak2p = exp( zck2p ) + zak3p = exp( zck3p ) + zaksi = exp( zcksi ) + zckf = zckf * total2SWS + + ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) + ! (REFERENCE TO CULBERSON & PYTKOQICZ (1968) AS MADE + ! IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS + ! TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres IN + ! DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS + ! MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION + ! WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND + ! & GIESKES (1970), P. 1285-1286 (THE SMALL + ! FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE + ! SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) + zcpexp = zpres / (rgas*ztkel) + zcpexp2 = zpres * zcpexp + + ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE + ! CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) + ! (CF. BROECKER ET AL., 1982) + + zbuf1 = - ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) + zbuf2 = 0.5 * ( devk40 + devk50 * ztc ) + ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) + zbuf2 = 0.5 * ( devk41 + devk51 * ztc ) + ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) + zbuf2 = 0.5 * ( devk42 + devk52 * ztc ) + akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) + zbuf2 = 0.5 * ( devk43 + devk53 * ztc ) + akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) + zbuf2 = 0.5 * ( devk44 + devk54 * ztc ) + aks3(ji,jj,jk) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) + zbuf2 = 0.5 * ( devk45 + devk55 * ztc ) + akf3(ji,jj,jk) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) + zbuf2 = 0.5 * ( devk47 + devk57 * ztc ) + ak1p3(ji,jj,jk) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) + zbuf2 = 0.5 * ( devk48 + devk58 * ztc ) + ak2p3(ji,jj,jk) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk19 + devk29 * ztc + devk39 * ztc * ztc ) + zbuf2 = 0.5 * ( devk49 + devk59 * ztc ) + ak3p3(ji,jj,jk) = zak3p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) + zbuf2 = 0.5 * ( devk410 + devk510 * ztc ) + aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + ! CONVERT FROM DIFFERENT PH SCALES + total2free = 1.0/(1.0 + zst/aks3(ji,jj,jk)) + free2SWS = 1. + zst/aks3(ji,jj,jk) + zft/akf3(ji,jj,jk) + total2SWS = total2free * free2SWS + SWS2total = 1.0 / total2SWS + + ! Convert to total scale + ak13(ji,jj,jk) = ak13(ji,jj,jk) * SWS2total + ak23(ji,jj,jk) = ak23(ji,jj,jk) * SWS2total + akb3(ji,jj,jk) = akb3(ji,jj,jk) * SWS2total + akw3(ji,jj,jk) = akw3(ji,jj,jk) * SWS2total + ak1p3(ji,jj,jk) = ak1p3(ji,jj,jk) * SWS2total + ak2p3(ji,jj,jk) = ak2p3(ji,jj,jk) * SWS2total + ak3p3(ji,jj,jk) = ak3p3(ji,jj,jk) * SWS2total + aksi3(ji,jj,jk) = aksi3(ji,jj,jk) * SWS2total + akf3(ji,jj,jk) = akf3(ji,jj,jk) / total2free + + ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE + ! AS FUNCTION OF PRESSURE FOLLOWING MILLERO + ! (P. 1285) AND BERNER (1976) + zbuf1 = - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) + zbuf2 = 0.5 * ( devk46 + devk56 * ztc ) + aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] + borat(ji,jj,jk) = 0.0002414 * zcl / 10.811 + sulfat(ji,jj,jk) = zst + fluorid(ji,jj,jk) = zft + + ! Iron and SIO3 saturation concentration from ... + sio3eq(ji,jj,jk) = EXP( LOG( 10.) * ( 6.44 - 968. / ztkel ) ) * 1.e-6 + fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ztkel ) + + ! Liu and Millero (1999) only valid 5 - 50 degC + ztkel1 = MAX( 5. , tempis(ji,jj,jk) ) + 273.16 + fesol(ji,jj,jk,1) = 10**(-13.486 - 0.1856* zis**0.5 + 0.3073*zis + 5254.0/ztkel1) + fesol(ji,jj,jk,2) = 10**(2.517 - 0.8885*zis**0.5 + 0.2139 * zis - 1320.0/ztkel1 ) + fesol(ji,jj,jk,3) = 10**(0.4511 - 0.3305*zis**0.5 - 1996.0/ztkel1 ) + fesol(ji,jj,jk,4) = 10**(-0.2965 - 0.7881*zis**0.5 - 4086.0/ztkel1 ) + fesol(ji,jj,jk,5) = 10**(4.4466 - 0.8505*zis**0.5 - 7980.0/ztkel1 ) + END DO + END DO + END DO + ! + IF( ln_timing ) CALL timing_stop('p4z_che') + ! + END SUBROUTINE p4z_che + + SUBROUTINE ahini_for_at(p_hini) + !!--------------------------------------------------------------------- + !! *** ROUTINE ahini_for_at *** + !! + !! Subroutine returns the root for the 2nd order approximation of the + !! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic + !! polynomial) around the local minimum, if it exists. + !! Returns * 1E-03_wp if p_alkcb <= 0 + !! * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot + !! * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot + !! and the 2nd order approximation does not have + !! a solution + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_hini + INTEGER :: ji, jj, jk + REAL(wp) :: zca1, zba1 + REAL(wp) :: zd, zsqrtd, zhmin + REAL(wp) :: za2, za1, za0 + REAL(wp) :: p_dictot, p_bortot, p_alkcb + !!--------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('ahini_for_at') + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + p_alkcb = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) + p_dictot = trb(ji,jj,jk,jpdic) * 1000. / (rhop(ji,jj,jk) + rtrn) + p_bortot = borat(ji,jj,jk) + IF (p_alkcb <= 0.) THEN + p_hini(ji,jj,jk) = 1.e-3 + ELSEIF (p_alkcb >= (2.*p_dictot + p_bortot)) THEN + p_hini(ji,jj,jk) = 1.e-10_wp + ELSE + zca1 = p_dictot/( p_alkcb + rtrn ) + zba1 = p_bortot/ (p_alkcb + rtrn ) + ! Coefficients of the cubic polynomial + za2 = aKb3(ji,jj,jk)*(1. - zba1) + ak13(ji,jj,jk)*(1.-zca1) + za1 = ak13(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - zca1) & + & + ak13(ji,jj,jk)*ak23(ji,jj,jk)*(1. - (zca1+zca1)) + za0 = ak13(ji,jj,jk)*ak23(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - (zca1+zca1)) + ! Taylor expansion around the minimum + zd = za2*za2 - 3.*za1 ! Discriminant of the quadratic equation + ! for the minimum close to the root + + IF(zd > 0.) THEN ! If the discriminant is positive + zsqrtd = SQRT(zd) + IF(za2 < 0) THEN + zhmin = (-za2 + zsqrtd)/3. + ELSE + zhmin = -za1/(za2 + zsqrtd) + ENDIF + p_hini(ji,jj,jk) = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd) + ELSE + p_hini(ji,jj,jk) = 1.e-7 + ENDIF + ! + ENDIF + END DO + END DO + END DO + ! + IF( ln_timing ) CALL timing_stop('ahini_for_at') + ! + END SUBROUTINE ahini_for_at + + !=============================================================================== + + SUBROUTINE anw_infsup( p_alknw_inf, p_alknw_sup ) + + ! Subroutine returns the lower and upper bounds of "non-water-selfionization" + ! contributions to total alkalinity (the infimum and the supremum), i.e + ! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+]) + + ! Argument variables + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_inf + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_sup + + p_alknw_inf(:,:,:) = -trb(:,:,:,jppo4) * 1000. / (rhop(:,:,:) + rtrn) - sulfat(:,:,:) & + & - fluorid(:,:,:) + p_alknw_sup(:,:,:) = (2. * trb(:,:,:,jpdic) + 2. * trb(:,:,:,jppo4) + trb(:,:,:,jpsil) ) & + & * 1000. / (rhop(:,:,:) + rtrn) + borat(:,:,:) + + END SUBROUTINE anw_infsup + + + SUBROUTINE solve_at_general( p_hini, zhi ) + + ! Universal pH solver that converges from any given initial value, + ! determines upper an lower bounds for the solution if required + + ! Argument variables + !-------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: p_hini + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: zhi + + ! Local variables + !----------------- + INTEGER :: ji, jj, jk, jn + REAL(wp) :: zh_ini, zh, zh_prev, zh_lnfactor + REAL(wp) :: zdelta, zh_delta + REAL(wp) :: zeqn, zdeqndh, zalka + REAL(wp) :: aphscale + REAL(wp) :: znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic + REAL(wp) :: znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor + REAL(wp) :: znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4 + REAL(wp) :: znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil + REAL(wp) :: znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4 + REAL(wp) :: znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu + REAL(wp) :: zalk_wat, zdalk_wat + REAL(wp) :: zfact, p_alktot, zdic, zbot, zpt, zst, zft, zsit + LOGICAL :: l_exitnow + REAL(wp), PARAMETER :: pz_exp_threshold = 1.0 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin + + IF( ln_timing ) CALL timing_start('solve_at_general') + + CALL anw_infsup( zalknw_inf, zalknw_sup ) + + rmask(:,:,:) = tmask(:,:,:) + zhi(:,:,:) = 0. + + ! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF (rmask(ji,jj,jk) == 1.) THEN + p_alktot = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) + aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) + zh_ini = p_hini(ji,jj,jk) + + zdelta = (p_alktot-zalknw_inf(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale + + IF(p_alktot >= zalknw_inf(ji,jj,jk)) THEN + zh_min(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_inf(ji,jj,jk) + SQRT(zdelta) ) + ELSE + zh_min(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_inf(ji,jj,jk)) + SQRT(zdelta) ) / 2. + ENDIF + + zdelta = (p_alktot-zalknw_sup(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale + + IF(p_alktot <= zalknw_sup(ji,jj,jk)) THEN + zh_max(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_sup(ji,jj,jk)) + SQRT(zdelta) ) / 2. + ELSE + zh_max(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_sup(ji,jj,jk) + SQRT(zdelta) ) + ENDIF + + zhi(ji,jj,jk) = MAX(MIN(zh_max(ji,jj,jk), zh_ini), zh_min(ji,jj,jk)) + ENDIF + END DO + END DO + END DO + + zeqn_absmin(:,:,:) = HUGE(1._dp) + + DO jn = 1, jp_maxniter_atgen + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF (rmask(ji,jj,jk) == 1.) THEN + zfact = rhop(ji,jj,jk) / 1000. + rtrn + p_alktot = trb(ji,jj,jk,jptal) / zfact + zdic = trb(ji,jj,jk,jpdic) / zfact + zbot = borat(ji,jj,jk) + zpt = trb(ji,jj,jk,jppo4) / zfact * po4r + zsit = trb(ji,jj,jk,jpsil) / zfact + zst = sulfat (ji,jj,jk) + zft = fluorid(ji,jj,jk) + aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) + zh = zhi(ji,jj,jk) + zh_prev = zh + + ! H2CO3 - HCO3 - CO3 : n=2, m=0 + znumer_dic = 2.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk) + zdenom_dic = ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*(ak13(ji,jj,jk) + zh) + zalk_dic = zdic * (znumer_dic/zdenom_dic) + zdnumer_dic = ak13(ji,jj,jk)*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh & + *(4.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk)) + zdalk_dic = -zdic*(zdnumer_dic/zdenom_dic**2) + + + ! B(OH)3 - B(OH)4 : n=1, m=0 + znumer_bor = akb3(ji,jj,jk) + zdenom_bor = akb3(ji,jj,jk) + zh + zalk_bor = zbot * (znumer_bor/zdenom_bor) + zdnumer_bor = akb3(ji,jj,jk) + zdalk_bor = -zbot*(zdnumer_bor/zdenom_bor**2) + + + ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1 + znumer_po4 = 3.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & + & + zh*(2.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh* ak1p3(ji,jj,jk)) + zdenom_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & + & + zh*( ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh*(ak1p3(ji,jj,jk) + zh)) + zalk_po4 = zpt * (znumer_po4/zdenom_po4 - 1.) ! Zero level of H3PO4 = 1 + zdnumer_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & + & + zh*(4.*ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & + & + zh*(9.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & + & + ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) & + & + zh*(4.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh * ak1p3(ji,jj,jk) ) ) ) + zdalk_po4 = -zpt * (zdnumer_po4/zdenom_po4**2) + + ! H4SiO4 - H3SiO4 : n=1, m=0 + znumer_sil = aksi3(ji,jj,jk) + zdenom_sil = aksi3(ji,jj,jk) + zh + zalk_sil = zsit * (znumer_sil/zdenom_sil) + zdnumer_sil = aksi3(ji,jj,jk) + zdalk_sil = -zsit * (zdnumer_sil/zdenom_sil**2) + + ! HSO4 - SO4 : n=1, m=1 + aphscale = 1.0 + zst/aks3(ji,jj,jk) + znumer_so4 = aks3(ji,jj,jk) * aphscale + zdenom_so4 = aks3(ji,jj,jk) * aphscale + zh + zalk_so4 = zst * (znumer_so4/zdenom_so4 - 1.) + zdnumer_so4 = aks3(ji,jj,jk) + zdalk_so4 = -zst * (zdnumer_so4/zdenom_so4**2) + + ! HF - F : n=1, m=1 + znumer_flu = akf3(ji,jj,jk) + zdenom_flu = akf3(ji,jj,jk) + zh + zalk_flu = zft * (znumer_flu/zdenom_flu - 1.) + zdnumer_flu = akf3(ji,jj,jk) + zdalk_flu = -zft * (zdnumer_flu/zdenom_flu**2) + + ! H2O - OH + aphscale = 1.0 + zst/aks3(ji,jj,jk) + zalk_wat = akw3(ji,jj,jk)/zh - zh/aphscale + zdalk_wat = -akw3(ji,jj,jk)/zh**2 - 1./aphscale + + ! CALCULATE [ALK]([CO3--], [HCO3-]) + zeqn = zalk_dic + zalk_bor + zalk_po4 + zalk_sil & + & + zalk_so4 + zalk_flu & + & + zalk_wat - p_alktot + + zalka = p_alktot - (zalk_bor + zalk_po4 + zalk_sil & + & + zalk_so4 + zalk_flu + zalk_wat) + + zdeqndh = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil & + & + zdalk_so4 + zdalk_flu + zdalk_wat + + ! Adapt bracketing interval + IF(zeqn > 0._wp) THEN + zh_min(ji,jj,jk) = zh_prev + ELSEIF(zeqn < 0._wp) THEN + zh_max(ji,jj,jk) = zh_prev + ENDIF + + IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin(ji,jj,jk)) THEN + ! if the function evaluation at the current point is + ! not decreasing faster than with a bisection step (at least linearly) + ! in absolute value take one bisection step on [ph_min, ph_max] + ! ph_new = (ph_min + ph_max)/2d0 + ! + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_min + ph_max)/2d0) + ! = SQRT(10**(-(ph_min + phmax))) + ! = SQRT(zh_max * zh_min) + zh = SQRT(zh_max(ji,jj,jk) * zh_min(ji,jj,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ELSE + ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH + ! = -zdeqndh * LOG(10) * [H] + ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10)) + ! + ! pH_new = pH_old + \deltapH + ! + ! [H]_new = 10**(-pH_new) + ! = 10**(-pH_old - \Delta pH) + ! = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10))) + ! = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10))) + ! = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old)) + + zh_lnfactor = -zeqn/(zdeqndh*zh_prev) + + IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN + zh = zh_prev*EXP(zh_lnfactor) + ELSE + zh_delta = zh_lnfactor*zh_prev + zh = zh_prev + zh_delta + ENDIF + + IF( zh < zh_min(ji,jj,jk) ) THEN + ! if [H]_new < [H]_min + ! i.e., if ph_new > ph_max then + ! take one bisection step on [ph_prev, ph_max] + ! ph_new = (ph_prev + ph_max)/2d0 + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_prev + ph_max)/2d0) + ! = SQRT(10**(-(ph_prev + phmax))) + ! = SQRT([H]_old*10**(-ph_max)) + ! = SQRT([H]_old * zh_min) + zh = SQRT(zh_prev * zh_min(ji,jj,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ENDIF + + IF( zh > zh_max(ji,jj,jk) ) THEN + ! if [H]_new > [H]_max + ! i.e., if ph_new < ph_min, then + ! take one bisection step on [ph_min, ph_prev] + ! ph_new = (ph_prev + ph_min)/2d0 + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_prev + ph_min)/2d0) + ! = SQRT(10**(-(ph_prev + ph_min))) + ! = SQRT([H]_old*10**(-ph_min)) + ! = SQRT([H]_old * zhmax) + zh = SQRT(zh_prev * zh_max(ji,jj,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ENDIF + ENDIF + + zeqn_absmin(ji,jj,jk) = MIN( ABS(zeqn), zeqn_absmin(ji,jj,jk)) + + ! Stop iterations once |\delta{[H]}/[H]| < rdel + ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel + ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)| + + ! Alternatively: + ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))| + ! ~ 1/LOG(10) * |\Delta [H]|/[H] + ! < 1/LOG(10) * rdel + + ! Hence |zeqn/(zdeqndh*zh)| < rdel + + ! rdel <-- pp_rdel_ah_target + l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target) + + IF(l_exitnow) THEN + rmask(ji,jj,jk) = 0. + ENDIF + + zhi(ji,jj,jk) = zh + + IF(jn >= jp_maxniter_atgen) THEN + zhi(ji,jj,jk) = -1._wp + ENDIF + + ENDIF + END DO + END DO + END DO + END DO + ! + + IF( ln_timing ) CALL timing_stop('solve_at_general') + ! + END SUBROUTINE solve_at_general + + + INTEGER FUNCTION p4z_che_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_che_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(3) ! Local variables + !!---------------------------------------------------------------------- + + ierr(:) = 0 + + ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk), STAT=ierr(1) ) + + ALLOCATE( akb3(jpi,jpj,jpk) , tempis(jpi, jpj, jpk), & + & akw3(jpi,jpj,jpk) , borat (jpi,jpj,jpk) , & + & aks3(jpi,jpj,jpk) , akf3(jpi,jpj,jpk) , & + & ak1p3(jpi,jpj,jpk) , ak2p3(jpi,jpj,jpk) , & + & ak3p3(jpi,jpj,jpk) , aksi3(jpi,jpj,jpk) , & + & fluorid(jpi,jpj,jpk) , sulfat(jpi,jpj,jpk) , & + & salinprac(jpi,jpj,jpk), STAT=ierr(2) ) + + ALLOCATE( fesol(jpi,jpj,jpk,5), STAT=ierr(3) ) + + !* Variable for chemistry of the CO2 cycle + p4z_che_alloc = MAXVAL( ierr ) + ! + IF( p4z_che_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_che_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p4z_che_alloc + + !!====================================================================== +END MODULE p4zche diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zfechem.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zfechem.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c22249471319122df2449ba38dc8f4c2ebaede79 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zfechem.F90 @@ -0,0 +1,282 @@ +MODULE p4zfechem + !!====================================================================== + !! *** MODULE p4zfechem *** + !! TOP : PISCES Compute iron chemistry and scavenging + !!====================================================================== + !! History : 3.5 ! 2012-07 (O. Aumont, A. Tagliabue, C. Ethe) Original code + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p4z_fechem : Compute remineralization/scavenging of iron + !! p4z_fechem_init : Initialisation of parameters for remineralisation + !! p4z_fechem_alloc : Allocate remineralisation variables + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zche ! chemical model + USE p4zsbc ! Boundary conditions from sediments + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_fechem ! called in p4zbio.F90 + PUBLIC p4z_fechem_init ! called in trcsms_pisces.F90 + + LOGICAL :: ln_ligvar !: boolean for variable ligand concentration following Tagliabue and voelker + REAL(wp), PUBLIC :: xlam1 !: scavenging rate of Iron + REAL(wp), PUBLIC :: xlamdust !: scavenging rate of Iron by dust + REAL(wp), PUBLIC :: ligand !: ligand concentration in the ocean + REAL(wp), PUBLIC :: kfep !: rate constant for nanoparticle formation + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zfechem.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_fechem( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_fechem *** + !! + !! ** Purpose : Compute remineralization/scavenging of iron + !! + !! ** Method : A simple chemistry model of iron from Aumont and Bopp (2006) + !! based on one ligand and one inorganic form + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step + ! + INTEGER :: ji, jj, jk, jic, jn + REAL(wp) :: zdep, zlam1a, zlam1b, zlamfac + REAL(wp) :: zkeq, zfeequi, zfesatur, zfecoll, fe3sol + REAL(wp) :: zdenom1, zscave, zaggdfea, zaggdfeb, zcoag + REAL(wp) :: ztrc, zdust + REAL(wp) :: zdenom2 + REAL(wp) :: zzFeL1, zzFeL2, zzFe2, zzFeP, zzFe3, zzstrn2 + REAL(wp) :: zrum, zcodel, zargu, zlight + REAL(wp) :: zkox, zkph1, zkph2, zph, zionic, ztligand + REAL(wp) :: za, zb, zc, zkappa1, zkappa2, za0, za1, za2 + REAL(wp) :: zxs, zfunc, zp, zq, zd, zr, zphi, zfff, zp3, zq2 + REAL(wp) :: ztfe, zoxy, zhplus, zxlam + REAL(wp) :: zaggliga, zaggligb + REAL(wp) :: dissol, zligco + REAL(wp) :: zrfact2 + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zTL1, zFe3, ztotlig, precip, zFeL1 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zcoll3d, zscav3d, zlcoll3d + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_fechem') + ! + + ! Total ligand concentration : Ligands can be chosen to be constant or variable + ! Parameterization from Tagliabue and Voelker (2011) + ! ------------------------------------------------- + IF( ln_ligvar ) THEN + ztotlig(:,:,:) = 0.09 * trb(:,:,:,jpdoc) * 1E6 + ligand * 1E9 + ztotlig(:,:,:) = MIN( ztotlig(:,:,:), 10. ) + ELSE + IF( ln_ligand ) THEN ; ztotlig(:,:,:) = trb(:,:,:,jplgw) * 1E9 + ELSE ; ztotlig(:,:,:) = ligand * 1E9 + ENDIF + ENDIF + + ! ------------------------------------------------------------ + ! from Aumont and Bopp (2006) + ! This model is based on one ligand and Fe' + ! Chemistry is supposed to be fast enough to be at equilibrium + ! ------------------------------------------------------------ + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zTL1(ji,jj,jk) = ztotlig(ji,jj,jk) + zkeq = fekeq(ji,jj,jk) + zfesatur = zTL1(ji,jj,jk) * 1E-9 + ztfe = trb(ji,jj,jk,jpfer) + ! Fe' is the root of a 2nd order polynom + zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe ) & + & + SQRT( ( 1. + zfesatur * zkeq - zkeq * ztfe )**2 & + & + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) + zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 + zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) + END DO + END DO + END DO + ! + + zdust = 0. ! if no dust available + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water. + ! This parameterization assumes a simple second order kinetics (k[Particles][Fe]). + ! Scavenging onto dust is also included as evidenced from the DUNE experiments. + ! -------------------------------------------------------------------------------------- + zhplus = max( rtrn, hi(ji,jj,jk) ) + fe3sol = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2 & + & + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4) & + & + fesol(ji,jj,jk,5) / zhplus ) + ! + zfeequi = zFe3(ji,jj,jk) * 1E-9 + zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 + ! precipitation of Fe3+, creation of nanoparticles + precip(ji,jj,jk) = MAX( 0., ( zFe3(ji,jj,jk) * 1E-9 - fe3sol ) ) * kfep * xstep + ! + ztrc = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6 + IF( ln_dust ) zdust = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) & + & * EXP( -gdept_n(ji,jj,jk) / 540. ) + IF (ln_ligand) THEN + zxlam = xlam1 * MAX( 1.E-3, EXP(-2 * etot(ji,jj,jk) / 10. ) * (1. - EXP(-2 * trb(ji,jj,jk,jpoxy) / 100.E-6 ) )) + ELSE + zxlam = xlam1 * 1.0 + ENDIF + zlam1b = 3.e-5 + xlamdust * zdust + zxlam * ztrc + zscave = zfeequi * zlam1b * xstep + + ! Compute the different ratios for scavenging of iron + ! to later allocate scavenged iron to the different organic pools + ! --------------------------------------------------------- + zdenom1 = zxlam * trb(ji,jj,jk,jppoc) / zlam1b + zdenom2 = zxlam * trb(ji,jj,jk,jpgoc) / zlam1b + + ! Increased scavenging for very high iron concentrations found near the coasts + ! due to increased lithogenic particles and let say it is unknown processes (precipitation, ...) + ! ----------------------------------------------------------- + zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) + zlamfac = MIN( 1. , zlamfac ) + zdep = MIN( 1., 1000. / gdept_n(ji,jj,jk) ) + zcoag = 1E-4 * ( 1. - zlamfac ) * zdep * xstep * trb(ji,jj,jk,jpfer) + + ! Compute the coagulation of colloidal iron. This parameterization + ! could be thought as an equivalent of colloidal pumping. + ! It requires certainly some more work as it is very poorly constrained. + ! ---------------------------------------------------------------- + zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & + & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) + zaggdfea = zlam1a * xstep * zfecoll + ! + zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) + zaggdfeb = zlam1b * xstep * zfecoll + ! + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zscave - zaggdfea - zaggdfeb & + & - zcoag - precip(ji,jj,jk) + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zscave * zdenom2 + zaggdfeb + zscav3d(ji,jj,jk) = zscave + zcoll3d(ji,jj,jk) = zaggdfea + zaggdfeb + ! + END DO + END DO + END DO + ! + ! Define the bioavailable fraction of iron + ! ---------------------------------------- + biron(:,:,:) = trb(:,:,:,jpfer) + ! + IF( ln_ligand ) THEN + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & + & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) + ! + zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) + zligco = 0.5 * trn(ji,jj,jk,jplgw) + zaggliga = zlam1a * xstep * zligco + zaggligb = zlam1b * xstep * zligco + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) - zaggliga - zaggligb + zlcoll3d(ji,jj,jk) = zaggliga + zaggligb + END DO + END DO + END DO + ! + plig(:,:,:) = MAX( 0., ( ( zFeL1(:,:,:) * 1E-9 ) / ( trb(:,:,:,jpfer) +rtrn ) ) ) + ! + ENDIF + ! Output of some diagnostics variables + ! --------------------------------- + IF( lk_iomput ) THEN + IF( knt == nrdttrc ) THEN + zrfact2 = 1.e3 * rfact2r ! conversion from mol/L/timestep into mol/m3/s + IF( iom_use("Fe3") ) THEN + zFe3(:,:,jpk) = 0. ; CALL iom_put("Fe3" , zFe3(:,:,:) * tmask(:,:,:) ) ! Fe3+ + ENDIF + IF( iom_use("FeL1") ) THEN + zFeL1(:,:,jpk) = 0. ; CALL iom_put("FeL1", zFeL1(:,:,:) * tmask(:,:,:) ) ! FeL1 + ENDIF + IF( iom_use("TL1") ) THEN + zTL1(:,:,jpk) = 0. ; CALL iom_put("TL1" , zTL1(:,:,:) * tmask(:,:,:) ) ! TL1 + ENDIF + CALL iom_put("Totlig" , ztotlig(:,:,:) * tmask(:,:,:) ) ! TL + CALL iom_put("Biron" , biron (:,:,:) * 1e9 * tmask(:,:,:) ) ! biron + IF( iom_use("FESCAV") ) THEN + zscav3d (:,:,jpk) = 0. ; CALL iom_put("FESCAV" , zscav3d(:,:,:) * 1e9 * tmask(:,:,:) * zrfact2 ) + ENDIF + IF( iom_use("FECOLL") ) THEN + zcoll3d (:,:,jpk) = 0. ; CALL iom_put("FECOLL" , zcoll3d(:,:,:) * 1e9 * tmask(:,:,:) * zrfact2 ) + ENDIF + IF( iom_use("LGWCOLL")) THEN + zlcoll3d(:,:,jpk) = 0. ; CALL iom_put("LGWCOLL", zlcoll3d(:,:,:) * 1e9 * tmask(:,:,:) * zrfact2 ) + ENDIF + ENDIF + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('fechem')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_fechem') + ! + END SUBROUTINE p4z_fechem + + + SUBROUTINE p4z_fechem_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_fechem_init *** + !! + !! ** Purpose : Initialization of iron chemistry parameters + !! + !! ** Method : Read the nampisfer namelist and check the parameters + !! called at the first timestep + !! + !! ** input : Namelist nampisfer + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/nampisfer/ ln_ligvar, xlam1, xlamdust, ligand, kfep + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_rem_init : Initialization of iron chemistry parameters' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampisfer, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisfer in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampisfer, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisfer in configuration namelist' ) + IF(lwm) WRITE( numonp, nampisfer ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampisfer' + WRITE(numout,*) ' variable concentration of ligand ln_ligvar =', ln_ligvar + WRITE(numout,*) ' scavenging rate of Iron xlam1 =', xlam1 + WRITE(numout,*) ' scavenging rate of Iron by dust xlamdust =', xlamdust + WRITE(numout,*) ' ligand concentration in the ocean ligand =', ligand + WRITE(numout,*) ' rate constant for nanoparticle formation kfep =', kfep + ENDIF + ! + END SUBROUTINE p4z_fechem_init + + !!====================================================================== +END MODULE p4zfechem diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zflx.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zflx.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dc4a496841c3b0edbdbc4c8a43512dc6969a1a68 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zflx.F90 @@ -0,0 +1,370 @@ +MODULE p4zflx + !!====================================================================== + !! *** MODULE p4zflx *** + !! TOP : PISCES CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE + !!====================================================================== + !! History : - ! 1988-07 (E. MAIER-REIMER) Original code + !! - ! 1998 (O. Aumont) additions + !! - ! 1999 (C. Le Quere) modifications + !! 1.0 ! 2004 (O. Aumont) modifications + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! ! 2011-02 (J. Simeon, J. Orr) Include total atm P correction + !!---------------------------------------------------------------------- + !! p4z_flx : CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE + !! p4z_flx_init : Read the namelist + !! p4z_patm : Read sfc atm pressure [atm] for each grid cell + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zche ! Chemical model + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + USE fldread ! read input fields + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_flx + PUBLIC p4z_flx_init + PUBLIC p4z_flx_alloc + + ! !!** Namelist nampisext ** + REAL(wp) :: atcco2 !: pre-industrial atmospheric [co2] (ppm) + LOGICAL :: ln_co2int !: flag to read in a file and interpolate atmospheric pco2 or not + CHARACTER(len=34) :: clname !: filename of pco2 values + INTEGER :: nn_offset !: Offset model-data start year (default = 0) + + !! Variables related to reading atmospheric CO2 time history + INTEGER :: nmaxrec, numco2 ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: atcco2h, years ! + + ! !!* nampisatm namelist (Atmospheric PRessure) * + LOGICAL, PUBLIC :: ln_presatm !: ref. pressure: global mean Patm (F) or a constant (F) + LOGICAL, PUBLIC :: ln_presatmco2 !: accounting for spatial atm CO2 in the compuation of carbon flux (T) or not (F) + + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: patm ! atmospheric pressure at kt [N/m2] + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_patm ! structure of input fields (file informations, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_atmco2 ! structure of input fields (file informations, fields read) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: satmco2 !: atmospheric pco2 + + REAL(wp) :: xconv = 0.01_wp / 3600._wp !: coefficients for conversion + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zflx.F90 12277 2019-12-20 11:54:47Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_flx ( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_flx *** + !! + !! ** Purpose : CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE + !! + !! ** Method : + !! - Include total atm P correction via Esbensen & Kushnir (1981) + !! - Remove Wanninkhof chemical enhancement; + !! - Add option for time-interpolation of atcco2.txt + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! + ! + INTEGER :: ji, jj, jm, iind, iindm1 + REAL(wp) :: ztc, ztc2, ztc3, ztc4, zws, zkgwan + REAL(wp) :: zfld, zflu, zfld16, zflu16, zfact + REAL(wp) :: zvapsw, zsal, zfco2, zxc2, xCO2approx, ztkel, zfugcoeff + REAL(wp) :: zph, zdic, zsch_o2, zsch_co2 + REAL(wp) :: zyr_dec, zdco2dt + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj) :: zkgco2, zkgo2, zh2co3, zoflx, zpco2atm + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_flx') + ! + ! SURFACE CHEMISTRY (PCO2 AND [H+] IN + ! SURFACE LAYER); THE RESULT OF THIS CALCULATION + ! IS USED TO COMPUTE AIR-SEA FLUX OF CO2 + + IF( kt /= nit000 .AND. .NOT.l_co2cpl .AND. knt == 1 ) CALL p4z_patm( kt ) ! Get sea-level pressure (E&K [1981] climatology) for use in flux calcs + + IF( ln_co2int .AND. .NOT.ln_presatmco2 .AND. .NOT.l_co2cpl ) THEN + ! Linear temporal interpolation of atmospheric pco2. atcco2.txt has annual values. + ! Caveats: First column of .txt must be in years, decimal years preferably. + ! For nn_offset, if your model year is iyy, nn_offset=(years(1)-iyy) + ! then the first atmospheric CO2 record read is at years(1) + zyr_dec = REAL( nyear + nn_offset, wp ) + REAL( nday_year, wp ) / REAL( nyear_len(1), wp ) + jm = 1 + DO WHILE( jm <= nmaxrec .AND. years(jm) < zyr_dec ) ; jm = jm + 1 ; END DO + iind = jm ; iindm1 = jm - 1 + zdco2dt = ( atcco2h(iind) - atcco2h(iindm1) ) / ( years(iind) - years(iindm1) + rtrn ) + atcco2 = zdco2dt * ( zyr_dec - years(iindm1) ) + atcco2h(iindm1) + satmco2(:,:) = atcco2 + ENDIF + + IF( l_co2cpl ) satmco2(:,:) = atm_co2(:,:) + + DO jj = 1, jpj + DO ji = 1, jpi + ! DUMMY VARIABLES FOR DIC, H+, AND BORATE + zfact = rhop(ji,jj,1) / 1000. + rtrn + zdic = trb(ji,jj,1,jpdic) + zph = MAX( hi(ji,jj,1), 1.e-10 ) / zfact + ! CALCULATE [H2CO3] + zh2co3(ji,jj) = zdic/(1. + ak13(ji,jj,1)/zph + ak13(ji,jj,1)*ak23(ji,jj,1)/zph**2) + END DO + END DO + + ! -------------- + ! COMPUTE FLUXES + ! -------------- + + ! FIRST COMPUTE GAS EXCHANGE COEFFICIENTS + ! ------------------------------------------- + + DO jj = 1, jpj + DO ji = 1, jpi + ztc = MIN( 35., tsn(ji,jj,1,jp_tem) ) + ztc2 = ztc * ztc + ztc3 = ztc * ztc2 + ztc4 = ztc2 * ztc2 + ! Compute the schmidt Number both O2 and CO2 + zsch_co2 = 2116.8 - 136.25 * ztc + 4.7353 * ztc2 - 0.092307 * ztc3 + 0.0007555 * ztc4 + zsch_o2 = 1920.4 - 135.6 * ztc + 5.2122 * ztc2 - 0.109390 * ztc3 + 0.0009377 * ztc4 + ! wind speed + zws = wndm(ji,jj) * wndm(ji,jj) + ! Compute the piston velocity for O2 and CO2 + zkgwan = 0.251 * zws + zkgwan = zkgwan * xconv * ( 1.- fr_i(ji,jj) ) * tmask(ji,jj,1) + ! compute gas exchange for CO2 and O2 + zkgco2(ji,jj) = zkgwan * SQRT( 660./ zsch_co2 ) + zkgo2 (ji,jj) = zkgwan * SQRT( 660./ zsch_o2 ) + END DO + END DO + + + DO jj = 1, jpj + DO ji = 1, jpi + ztkel = tempis(ji,jj,1) + 273.15 + zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. + zvapsw = EXP(24.4543 - 67.4509*(100.0/ztkel) - 4.8489*LOG(ztkel/100) - 0.000544*zsal) + zpco2atm(ji,jj) = satmco2(ji,jj) * ( patm(ji,jj) - zvapsw ) + zxc2 = ( 1.0 - zpco2atm(ji,jj) * 1E-6 )**2 + zfugcoeff = EXP( patm(ji,jj) * (chemc(ji,jj,2) + 2.0 * zxc2 * chemc(ji,jj,3) ) & + & / ( 82.05736 * ztkel )) + zfco2 = zpco2atm(ji,jj) * zfugcoeff + + ! Compute CO2 flux for the sea and air + zfld = zfco2 * chemc(ji,jj,1) * zkgco2(ji,jj) ! (mol/L) * (m/s) + zflu = zh2co3(ji,jj) * zkgco2(ji,jj) ! (mol/L) (m/s) ? + oce_co2(ji,jj) = ( zfld - zflu ) * tmask(ji,jj,1) + ! compute the trend + tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + oce_co2(ji,jj) * rfact2 / e3t_n(ji,jj,1) + + ! Compute O2 flux + zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * zkgo2(ji,jj) ! (mol/L) * (m/s) + zflu16 = trb(ji,jj,1,jpoxy) * zkgo2(ji,jj) + zoflx(ji,jj) = ( zfld16 - zflu16 ) * tmask(ji,jj,1) + tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zoflx(ji,jj) * rfact2 / e3t_n(ji,jj,1) + END DO + END DO + + IF( iom_use("tcflx") .OR. iom_use("tcflxcum") .OR. kt == nitrst & + & .OR. (ln_check_mass .AND. kt == nitend) ) & + t_oce_co2_flx = glob_sum( 'p4zflx', oce_co2(:,:) * e1e2t(:,:) * 1000.0_wp ) ! Total Flux of Carbon + t_oce_co2_flx_cum = t_oce_co2_flx_cum + t_oce_co2_flx ! Cumulative Total Flux of Carbon +! t_atm_co2_flx = glob_sum( 'p4zflx', satmco2(:,:) * e1e2t(:,:) ) ! Total atmospheric pCO2 + t_atm_co2_flx = atcco2 ! Total atmospheric pCO2 + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('flx ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "AtmCo2" , satmco2(:,:) * tmask(:,:,1) ) ! Atmospheric CO2 concentration + CALL iom_put( "Cflx" , oce_co2(:,:) * 1000. ) + CALL iom_put( "Oflx" , zoflx(:,:) * 1000. ) + CALL iom_put( "Kg" , zkgco2(:,:) * tmask(:,:,1) ) + CALL iom_put( "Dpco2" , ( zpco2atm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) ) + CALL iom_put( "pCO2sea" , ( zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) ) + CALL iom_put( "Dpo2" , ( atcox * patm(:,:) - atcox * trb(:,:,1,jpoxy) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) ) + CALL iom_put( "tcflx" , t_oce_co2_flx ) ! molC/s + CALL iom_put( "tcflxcum", t_oce_co2_flx_cum ) ! molC + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_flx') + ! + END SUBROUTINE p4z_flx + + + SUBROUTINE p4z_flx_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_flx_init *** + !! + !! ** Purpose : Initialization of atmospheric conditions + !! + !! ** Method : Read the nampisext namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampisext + !!---------------------------------------------------------------------- + INTEGER :: jm, ios ! Local integer + !! + NAMELIST/nampisext/ln_co2int, atcco2, clname, nn_offset + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' p4z_flx_init : atmospheric conditions for air-sea flux calculation' + WRITE(numout,*) ' ~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampisext, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisext in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampisext, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisext in configuration namelist' ) + IF(lwm) WRITE ( numonp, nampisext ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampisext --- parameters for air-sea exchange' + WRITE(numout,*) ' reading in the atm pCO2 file or constant value ln_co2int =', ln_co2int + ENDIF + ! + CALL p4z_patm( nit000 ) + ! + IF( .NOT.ln_co2int .AND. .NOT.ln_presatmco2 ) THEN + IF(lwp) THEN ! control print + WRITE(numout,*) ' Constant Atmospheric pCO2 value atcco2 =', atcco2 + ENDIF + satmco2(:,:) = atcco2 ! Initialisation of atmospheric pco2 + ELSEIF( ln_co2int .AND. .NOT.ln_presatmco2 ) THEN + IF(lwp) THEN + WRITE(numout,*) ' Constant Atmospheric pCO2 value atcco2 =', atcco2 + WRITE(numout,*) ' Atmospheric pCO2 value from file clname =', TRIM( clname ) + WRITE(numout,*) ' Offset model-data start year nn_offset =', nn_offset + ENDIF + CALL ctl_opn( numco2, TRIM( clname) , 'OLD', 'FORMATTED', 'SEQUENTIAL', -1 , numout, lwp ) + jm = 0 ! Count the number of record in co2 file + DO + READ(numco2,*,END=100) + jm = jm + 1 + END DO + 100 nmaxrec = jm - 1 + ALLOCATE( years (nmaxrec) ) ; years (:) = 0._wp + ALLOCATE( atcco2h(nmaxrec) ) ; atcco2h(:) = 0._wp + ! + REWIND(numco2) + DO jm = 1, nmaxrec ! get xCO2 data + READ(numco2, *) years(jm), atcco2h(jm) + IF(lwp) WRITE(numout, '(f6.0,f7.2)') years(jm), atcco2h(jm) + END DO + CLOSE(numco2) + ELSEIF( .NOT.ln_co2int .AND. ln_presatmco2 ) THEN + IF(lwp) WRITE(numout,*) ' Spatialized Atmospheric pCO2 from an external file' + ELSE + IF(lwp) WRITE(numout,*) ' Spatialized Atmospheric pCO2 from an external file' + ENDIF + ! + oce_co2(:,:) = 0._wp ! Initialization of Flux of Carbon + t_oce_co2_flx = 0._wp + t_atm_co2_flx = 0._wp + ! + END SUBROUTINE p4z_flx_init + + + SUBROUTINE p4z_patm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_atm *** + !! + !! ** Purpose : Read and interpolate the external atmospheric sea-level pressure + !! ** Method : Read the files and interpolate the appropriate variables + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ierr, ios ! Local integer + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_patm ! informations about the fields to be read + TYPE(FLD_N) :: sn_atmco2 ! informations about the fields to be read + !! + NAMELIST/nampisatm/ ln_presatm, ln_presatmco2, sn_patm, sn_atmco2, cn_dir + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN !== First call kt=nittrc000 ==! + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' p4z_patm : sea-level atmospheric pressure' + WRITE(numout,*) ' ~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampisatm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisatm in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampisatm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisatm in configuration namelist' ) + IF(lwm) WRITE ( numonp, nampisatm ) + ! + ! + IF(lwp) THEN !* control print + WRITE(numout,*) ' Namelist : nampisatm --- Atmospheric Pressure as external forcing' + WRITE(numout,*) ' constant atmopsheric pressure (F) or from a file (T) ln_presatm = ', ln_presatm + WRITE(numout,*) ' spatial atmopsheric CO2 for flux calcs ln_presatmco2 = ', ln_presatmco2 + ENDIF + ! + IF( ln_presatm ) THEN + ALLOCATE( sf_patm(1), STAT=ierr ) !* allocate and fill sf_patm (forcing structure) with sn_patm + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_flx: unable to allocate sf_patm structure' ) + ! + CALL fld_fill( sf_patm, (/ sn_patm /), cn_dir, 'p4z_flx', 'Atmospheric pressure ', 'nampisatm' ) + ALLOCATE( sf_patm(1)%fnow(jpi,jpj,1) ) + IF( sn_patm%ln_tint ) ALLOCATE( sf_patm(1)%fdta(jpi,jpj,1,2) ) + ENDIF + ! + IF( ln_presatmco2 ) THEN + ALLOCATE( sf_atmco2(1), STAT=ierr ) !* allocate and fill sf_atmco2 (forcing structure) with sn_atmco2 + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_flx: unable to allocate sf_atmco2 structure' ) + ! + CALL fld_fill( sf_atmco2, (/ sn_atmco2 /), cn_dir, 'p4z_flx', 'Atmospheric co2 partial pressure ', 'nampisatm' ) + ALLOCATE( sf_atmco2(1)%fnow(jpi,jpj,1) ) + IF( sn_atmco2%ln_tint ) ALLOCATE( sf_atmco2(1)%fdta(jpi,jpj,1,2) ) + ENDIF + ! + IF( .NOT.ln_presatm ) patm(:,:) = 1._wp ! Initialize patm if no reading from a file + ! + ENDIF + ! + IF( ln_presatm ) THEN + CALL fld_read( kt, 1, sf_patm ) !* input Patm provided at kt + 1/2 + patm(:,:) = sf_patm(1)%fnow(:,:,1) ! atmospheric pressure + ENDIF + ! + IF( ln_presatmco2 ) THEN + CALL fld_read( kt, 1, sf_atmco2 ) !* input atmco2 provided at kt + 1/2 + satmco2(:,:) = sf_atmco2(1)%fnow(:,:,1) ! atmospheric pressure + ELSE + satmco2(:,:) = atcco2 ! Initialize atmco2 if no reading from a file + ENDIF + ! + END SUBROUTINE p4z_patm + + + INTEGER FUNCTION p4z_flx_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_flx_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( satmco2(jpi,jpj), patm(jpi,jpj), STAT=p4z_flx_alloc ) + ! + IF( p4z_flx_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_flx_alloc : failed to allocate arrays' ) + ! + END FUNCTION p4z_flx_alloc + + !!====================================================================== +END MODULE p4zflx diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zint.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zint.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4c663c502edfbbf16558f49ef97f7b053eccbf63 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zint.F90 @@ -0,0 +1,67 @@ +MODULE p4zint + !!====================================================================== + !! *** MODULE p4zint *** + !! TOP : PISCES interpolation and computation of various accessory fields + !!====================================================================== + !! History : 1.0 ! 2004-03 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !!---------------------------------------------------------------------- + !! p4z_int : interpolation and computation of various accessory fields + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_int + REAL(wp) :: xksilim = 16.5e-6_wp ! Half-saturation constant for the Si half-saturation constant computation + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zint.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_int( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_int *** + !! + !! ** Purpose : interpolation and computation of various accessory fields + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zvar ! local variable + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_int') + ! + ! Computation of phyto and zoo metabolic rate + ! ------------------------------------------- + tgfunc (:,:,:) = EXP( 0.063913 * tsn(:,:,:,jp_tem) ) + tgfunc2(:,:,:) = EXP( 0.07608 * tsn(:,:,:,jp_tem) ) + + ! Computation of the silicon dependant half saturation constant for silica uptake + ! --------------------------------------------------- + DO ji = 1, jpi + DO jj = 1, jpj + zvar = trb(ji,jj,1,jpsil) * trb(ji,jj,1,jpsil) + xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zvar / ( xksilim * xksilim + zvar ) ) * 1e-6 ) + END DO + END DO + ! + IF( nday_year == nyear_len(1) ) THEN + xksi (:,:) = xksimax(:,:) + xksimax(:,:) = 0._wp + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_int') + ! + END SUBROUTINE p4z_int + + !!====================================================================== +END MODULE p4zint diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zligand.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zligand.F90 new file mode 100644 index 0000000000000000000000000000000000000000..787f4780f82be2666e9a39548e6a74e3768c24a0 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zligand.F90 @@ -0,0 +1,142 @@ +MODULE p4zligand + !!====================================================================== + !! *** MODULE p4zligand *** + !! TOP : PISCES Compute remineralization/dissolution of organic ligands + !!========================================================================= + !! History : 3.6 ! 2016-03 (O. Aumont, A. Tagliabue) Quota model and reorganization + !!---------------------------------------------------------------------- + !! p4z_ligand : Compute remineralization/dissolution of organic ligands + !! p4z_ligand_init: Initialisation of parameters for remineralisation + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_ligand ! called in p4zbio.F90 + PUBLIC p4z_ligand_init ! called in trcsms_pisces.F90 + + REAL(wp), PUBLIC :: rlgw !: lifetime (years) of weak ligands + REAL(wp), PUBLIC :: rlgs !: lifetime (years) of strong ligands + REAL(wp), PUBLIC :: rlig !: Remin ligand production + REAL(wp), PUBLIC :: prlgw !: Photochemical of weak ligand + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zligand.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_ligand( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_ligand *** + !! + !! ** Purpose : Compute remineralization/scavenging of organic ligands + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zlgwp, zlgwpr, zlgwr, zlablgw + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zligrem, zligpr, zligprod + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_ligand') + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! + ! ------------------------------------------------------------------ + ! Remineralization of iron ligands + ! ------------------------------------------------------------------ + ! production from remineralisation of organic matter + zlgwp = orem(ji,jj,jk) * rlig + ! decay of weak ligand + ! This is based on the idea that as LGW is lower + ! there is a larger fraction of refractory OM + zlgwr = max( rlgs , rlgw * exp( -2 * (trb(ji,jj,jk,jplgw)*1e9) ) ) ! years + zlgwr = 1. / zlgwr * tgfunc(ji,jj,jk) * ( xstep / nyear_len(1) ) * blim(ji,jj,jk) * trb(ji,jj,jk,jplgw) + ! photochem loss of weak ligand + zlgwpr = prlgw * xstep * etot(ji,jj,jk) * trb(ji,jj,jk,jplgw) * (1. - fr_i(ji,jj)) + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + zlgwp - zlgwr - zlgwpr + zligrem(ji,jj,jk) = zlgwr + zligpr(ji,jj,jk) = zlgwpr + zligprod(ji,jj,jk) = zlgwp + ! + END DO + END DO + END DO + ! + ! Output of some diagnostics variables + ! --------------------------------- + IF( lk_iomput .AND. knt == nrdttrc ) THEN + IF( iom_use( "LIGREM" ) ) THEN + zligrem(:,:,jpk) = 0. ; CALL iom_put( "LIGREM", zligrem(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use( "LIGPR" ) ) THEN + zligpr(:,:,jpk) = 0. ; CALL iom_put( "LIGPR" , zligpr(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use( "LPRODR" ) ) THEN + zligprod(:,:,jpk) = 0. ; CALL iom_put( "LPRODR", zligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('ligand1')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_ligand') + ! + END SUBROUTINE p4z_ligand + + + SUBROUTINE p4z_ligand_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_ligand_init *** + !! + !! ** Purpose : Initialization of remineralization parameters + !! + !! ** Method : Read the nampislig namelist and check the parameters + !! + !! ** input : Namelist nampislig + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/nampislig/ rlgw, prlgw, rlgs, rlig + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_ligand_init : remineralization/scavenging of organic ligands' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + ENDIF + + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampislig, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampislig in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampislig, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampislig in configuration namelist' ) + IF(lwm) WRITE ( numonp, nampislig ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampislig' + WRITE(numout,*) ' Lifetime (years) of weak ligands rlgw =', rlgw + WRITE(numout,*) ' Remin ligand production per unit C rlig =', rlig + WRITE(numout,*) ' Photolysis of weak ligand prlgw =', prlgw + WRITE(numout,*) ' Lifetime (years) of strong ligands rlgs =', rlgs + ENDIF + ! + END SUBROUTINE p4z_ligand_init + + !!====================================================================== +END MODULE p4zligand diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlim.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlim.F90 new file mode 100644 index 0000000000000000000000000000000000000000..27b49d0f6e0a606abb7a4ffd45a7f9aee89a8aa9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlim.F90 @@ -0,0 +1,320 @@ +MODULE p4zlim + !!====================================================================== + !! *** MODULE p4zlim *** + !! TOP : PISCES + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-04 (O. Aumont, C. Ethe) Limitation for iron modelled in quota + !!---------------------------------------------------------------------- + !! p4z_lim : Compute the nutrients limitation terms + !! p4z_lim_init : Read the namelist + !!---------------------------------------------------------------------- + USE oce_trc ! Shared ocean-passive tracers variables + USE trc ! Tracers defined + USE sms_pisces ! PISCES variables + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_lim + PUBLIC p4z_lim_init + PUBLIC p4z_lim_alloc + + !! * Shared module variables + REAL(wp), PUBLIC :: concnno3 !: NO3, PO4 half saturation + REAL(wp), PUBLIC :: concdno3 !: Phosphate half saturation for diatoms + REAL(wp), PUBLIC :: concnnh4 !: NH4 half saturation for phyto + REAL(wp), PUBLIC :: concdnh4 !: NH4 half saturation for diatoms + REAL(wp), PUBLIC :: concnfer !: Iron half saturation for nanophyto + REAL(wp), PUBLIC :: concdfer !: Iron half saturation for diatoms + REAL(wp), PUBLIC :: concbno3 !: NO3 half saturation for bacteria + REAL(wp), PUBLIC :: concbnh4 !: NH4 half saturation for bacteria + REAL(wp), PUBLIC :: xsizedia !: Minimum size criteria for diatoms + REAL(wp), PUBLIC :: xsizephy !: Minimum size criteria for nanophyto + REAL(wp), PUBLIC :: xsizern !: Size ratio for nanophytoplankton + REAL(wp), PUBLIC :: xsizerd !: Size ratio for diatoms + REAL(wp), PUBLIC :: xksi1 !: half saturation constant for Si uptake + REAL(wp), PUBLIC :: xksi2 !: half saturation constant for Si/C + REAL(wp), PUBLIC :: xkdoc !: 2nd half-sat. of DOC remineralization + REAL(wp), PUBLIC :: concbfe !: Fe half saturation for bacteria + REAL(wp), PUBLIC :: oxymin !: half saturation constant for anoxia + REAL(wp), PUBLIC :: qnfelim !: optimal Fe quota for nanophyto + REAL(wp), PUBLIC :: qdfelim !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: caco3r !: mean rainratio + + !!* Phytoplankton limitation terms + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnanono3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiatno3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnanonh4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiatnh4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnanopo4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiatpo4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimphy !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimdia !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimnfe !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimdfe !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimsi !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimbac !: ?? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimbacl !: ?? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: concdfe !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: concnfe !: ??? + + ! Coefficient for iron limitation + REAL(wp) :: xcoef1 = 0.0016 / 55.85 + REAL(wp) :: xcoef2 = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5 + REAL(wp) :: xcoef3 = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zlim.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_lim( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_lim *** + !! + !! ** Purpose : Compute the co-limitations by the various nutrients + !! for the various phytoplankton species + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zlim1, zlim2, zlim3, zlim4, zno3, zferlim + REAL(wp) :: zconcd, zconcd2, zconcn, zconcn2 + REAL(wp) :: z1_trbdia, z1_trbphy, ztem1, ztem2, zetot1, zetot2 + REAL(wp) :: zdenom, zratio, zironmin + REAL(wp) :: zconc1d, zconc1dnh4, zconc0n, zconc0nnh4 + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_lim') + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + ! Tuning of the iron concentration to a minimum level that is set to the detection limit + !------------------------------------- + zno3 = trb(ji,jj,jk,jpno3) / 40.e-6 + zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 ) + zferlim = MIN( zferlim, 7e-11 ) + trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim ) + + ! Computation of a variable Ks for iron on diatoms taking into account + ! that increasing biomass is made of generally bigger cells + !------------------------------------------------ + zconcd = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia ) + zconcd2 = trb(ji,jj,jk,jpdia) - zconcd + zconcn = MAX( 0.e0 , trb(ji,jj,jk,jpphy) - xsizephy ) + zconcn2 = trb(ji,jj,jk,jpphy) - zconcn + z1_trbphy = 1. / ( trb(ji,jj,jk,jpphy) + rtrn ) + z1_trbdia = 1. / ( trb(ji,jj,jk,jpdia) + rtrn ) + + concdfe(ji,jj,jk) = MAX( concdfer, ( zconcd2 * concdfer + concdfer * xsizerd * zconcd ) * z1_trbdia ) + zconc1d = MAX( concdno3, ( zconcd2 * concdno3 + concdno3 * xsizerd * zconcd ) * z1_trbdia ) + zconc1dnh4 = MAX( concdnh4, ( zconcd2 * concdnh4 + concdnh4 * xsizerd * zconcd ) * z1_trbdia ) + + concnfe(ji,jj,jk) = MAX( concnfer, ( zconcn2 * concnfer + concnfer * xsizern * zconcn ) * z1_trbphy ) + zconc0n = MAX( concnno3, ( zconcn2 * concnno3 + concnno3 * xsizern * zconcn ) * z1_trbphy ) + zconc0nnh4 = MAX( concnnh4, ( zconcn2 * concnnh4 + concnnh4 * xsizern * zconcn ) * z1_trbphy ) + + ! Michaelis-Menten Limitation term for nutrients Small bacteria + ! ------------------------------------------------------------- + zdenom = 1. / ( concbno3 * concbnh4 + concbnh4 * trb(ji,jj,jk,jpno3) + concbno3 * trb(ji,jj,jk,jpnh4) ) + xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * concbnh4 * zdenom + xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * concbno3 * zdenom + ! + zlim1 = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbnh4 ) + zlim3 = trb(ji,jj,jk,jpfer) / ( concbfe + trb(ji,jj,jk,jpfer) ) + zlim4 = trb(ji,jj,jk,jpdoc) / ( xkdoc + trb(ji,jj,jk,jpdoc) ) + xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) + xlimbac (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) * zlim4 + + ! Michaelis-Menten Limitation term for nutrients Small flagellates + ! ----------------------------------------------- + zdenom = 1. / ( zconc0n * zconc0nnh4 + zconc0nnh4 * trb(ji,jj,jk,jpno3) + zconc0n * trb(ji,jj,jk,jpnh4) ) + xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc0nnh4 * zdenom + xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc0n * zdenom + ! + zlim1 = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc0nnh4 ) + zratio = trb(ji,jj,jk,jpnfe) * z1_trbphy + zironmin = xcoef1 * trb(ji,jj,jk,jpnch) * z1_trbphy + xcoef2 * zlim1 + xcoef3 * xnanono3(ji,jj,jk) + zlim3 = MAX( 0.,( zratio - zironmin ) / qnfelim ) + xnanopo4(ji,jj,jk) = zlim2 + xlimnfe (ji,jj,jk) = MIN( 1., zlim3 ) + xlimphy (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) + ! + ! Michaelis-Menten Limitation term for nutrients Diatoms + ! ---------------------------------------------- + zdenom = 1. / ( zconc1d * zconc1dnh4 + zconc1dnh4 * trb(ji,jj,jk,jpno3) + zconc1d * trb(ji,jj,jk,jpnh4) ) + xdiatno3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc1dnh4 * zdenom + xdiatnh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc1d * zdenom + ! + zlim1 = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc1dnh4 ) + zlim3 = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) ) + zratio = trb(ji,jj,jk,jpdfe) * z1_trbdia + zironmin = xcoef1 * trb(ji,jj,jk,jpdch) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk) + zlim4 = MAX( 0., ( zratio - zironmin ) / qdfelim ) + xdiatpo4(ji,jj,jk) = zlim2 + xlimdfe (ji,jj,jk) = MIN( 1., zlim4 ) + xlimdia (ji,jj,jk) = MIN( zlim1, zlim2, zlim3, zlim4 ) + xlimsi (ji,jj,jk) = MIN( zlim1, zlim2, zlim4 ) + END DO + END DO + END DO + + ! Compute the fraction of nanophytoplankton that is made of calcifiers + ! -------------------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zlim1 = ( trb(ji,jj,jk,jpno3) * concnnh4 + trb(ji,jj,jk,jpnh4) * concnno3 ) & + & / ( concnno3 * concnnh4 + concnnh4 * trb(ji,jj,jk,jpno3) + concnno3 * trb(ji,jj,jk,jpnh4) ) + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnnh4 ) + zlim3 = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) + 5.E-11 ) + ztem1 = MAX( 0., tsn(ji,jj,jk,jp_tem) ) + ztem2 = tsn(ji,jj,jk,jp_tem) - 10. + zetot1 = MAX( 0., etot_ndcy(ji,jj,jk) - 1.) / ( 4. + etot_ndcy(ji,jj,jk) ) + zetot2 = 30. / ( 30. + etot_ndcy(ji,jj,jk) ) + + xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 ) & + & * ztem1 / ( 0.1 + ztem1 ) & + & * MAX( 1., trb(ji,jj,jk,jpphy) * 1.e6 / 2. ) & + & * zetot1 * zetot2 & + & * ( 1. + EXP(-ztem2 * ztem2 / 25. ) ) & + & * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) ) + xfracal(ji,jj,jk) = MIN( 0.8 , xfracal(ji,jj,jk) ) + xfracal(ji,jj,jk) = MAX( 0.02, xfracal(ji,jj,jk) ) + END DO + END DO + END DO + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! denitrification factor computed from O2 levels + nitrfac(ji,jj,jk) = MAX( 0.e0, 0.4 * ( 6.e-6 - trb(ji,jj,jk,jpoxy) ) & + & / ( oxymin + trb(ji,jj,jk,jpoxy) ) ) + nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) ) + ! + ! denitrification factor computed from NO3 levels + nitrfac2(ji,jj,jk) = MAX( 0.e0, ( 1.E-6 - trb(ji,jj,jk,jpno3) ) & + & / ( 1.E-6 + trb(ji,jj,jk,jpno3) ) ) + nitrfac2(ji,jj,jk) = MIN( 1., nitrfac2(ji,jj,jk) ) + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN ! save output diagnostics + CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) ) ! euphotic layer deptht + CALL iom_put( "LNnut" , xlimphy(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term + CALL iom_put( "LDnut" , xlimdia(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term + CALL iom_put( "LNFe" , xlimnfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "LDFe" , xlimdfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_lim') + ! + END SUBROUTINE p4z_lim + + + SUBROUTINE p4z_lim_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_lim_init *** + !! + !! ** Purpose : Initialization of nutrient limitation parameters + !! + !! ** Method : Read the nampislim namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampislim + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/namp4zlim/ concnno3, concdno3, concnnh4, concdnh4, concnfer, concdfer, concbfe, & + & concbno3, concbnh4, xsizedia, xsizephy, xsizern, xsizerd, & + & xksi1, xksi2, xkdoc, qnfelim, qdfelim, caco3r, oxymin + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_lim_init : initialization of nutrient limitations' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp4zlim, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp4zlim in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp4zlim, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp4zlim in configuration namelist' ) + IF(lwm) WRITE( numonp, namp4zlim ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namp4zlim' + WRITE(numout,*) ' mean rainratio caco3r = ', caco3r + WRITE(numout,*) ' NO3 half saturation of nanophyto concnno3 = ', concnno3 + WRITE(numout,*) ' NO3 half saturation of diatoms concdno3 = ', concdno3 + WRITE(numout,*) ' NH4 half saturation for phyto concnnh4 = ', concnnh4 + WRITE(numout,*) ' NH4 half saturation for diatoms concdnh4 = ', concdnh4 + WRITE(numout,*) ' half saturation constant for Si uptake xksi1 = ', xksi1 + WRITE(numout,*) ' half saturation constant for Si/C xksi2 = ', xksi2 + WRITE(numout,*) ' half-sat. of DOC remineralization xkdoc = ', xkdoc + WRITE(numout,*) ' Iron half saturation for nanophyto concnfer = ', concnfer + WRITE(numout,*) ' Iron half saturation for diatoms concdfer = ', concdfer + WRITE(numout,*) ' size ratio for nanophytoplankton xsizern = ', xsizern + WRITE(numout,*) ' size ratio for diatoms xsizerd = ', xsizerd + WRITE(numout,*) ' NO3 half saturation of bacteria concbno3 = ', concbno3 + WRITE(numout,*) ' NH4 half saturation for bacteria concbnh4 = ', concbnh4 + WRITE(numout,*) ' Minimum size criteria for diatoms xsizedia = ', xsizedia + WRITE(numout,*) ' Minimum size criteria for nanophyto xsizephy = ', xsizephy + WRITE(numout,*) ' Fe half saturation for bacteria concbfe = ', concbfe + WRITE(numout,*) ' halk saturation constant for anoxia oxymin =' , oxymin + WRITE(numout,*) ' optimal Fe quota for nano. qnfelim = ', qnfelim + WRITE(numout,*) ' Optimal Fe quota for diatoms qdfelim = ', qdfelim + ENDIF + ! + nitrfac (:,:,jpk) = 0._wp + nitrfac2(:,:,jpk) = 0._wp + xfracal (:,:,jpk) = 0._wp + xlimphy (:,:,jpk) = 0._wp + xlimdia (:,:,jpk) = 0._wp + xlimnfe (:,:,jpk) = 0._wp + xlimdfe (:,:,jpk) = 0._wp + ! + END SUBROUTINE p4z_lim_init + + + INTEGER FUNCTION p4z_lim_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_lim_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp , ONLY: ctl_stop + !!---------------------------------------------------------------------- + + !* Biological arrays for phytoplankton growth + ALLOCATE( xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk), & + & xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk), & + & xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk), & + & xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk), & + & xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk), & + & xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk), & + & concnfe (jpi,jpj,jpk), concdfe (jpi,jpj,jpk), & + & xlimsi (jpi,jpj,jpk), STAT=p4z_lim_alloc ) + ! + IF( p4z_lim_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_lim_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p4z_lim_alloc + + !!====================================================================== +END MODULE p4zlim diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlys.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlys.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e3de34a8125415efe7a7ac9e2ad1000011811ff9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zlys.F90 @@ -0,0 +1,189 @@ +MODULE p4zlys + !!====================================================================== + !! *** MODULE p4zlys *** + !! TOP : PISCES + !!====================================================================== + !! History : - ! 1988-07 (E. MAIER-REIMER) Original code + !! - ! 1998 (O. Aumont) additions + !! - ! 1999 (C. Le Quere) modifications + !! 1.0 ! 2004 (O. Aumont) modifications + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! ! 2011-02 (J. Simeon, J. Orr) Calcon salinity dependence + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Improvment of calcite dissolution + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p4z_lys : Compute the CaCO3 dissolution + !! p4z_lys_init : Read the namelist parameters + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zche ! Chemical model + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_lys ! called in trcsms_pisces.F90 + PUBLIC p4z_lys_init ! called in trcsms_pisces.F90 + + REAL(wp), PUBLIC :: kdca !: diss. rate constant calcite + REAL(wp), PUBLIC :: nca !: order of reaction for calcite dissolution + + INTEGER :: rmtss ! number of seconds per month + REAL(wp) :: calcon = 1.03E-2 ! mean calcite concentration [Ca2+] in sea water [mole/kg solution] + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zlys.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE p4z_lys( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_lys *** + !! + !! ** Purpose : CALCULATES DEGREE OF CACO3 SATURATION IN THE WATER + !! COLUMN, DISSOLUTION/PRECIPITATION OF CACO3 AND LOSS + !! OF CACO3 TO THE CACO3 SEDIMENT POOL. + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step and ??? + ! + INTEGER :: ji, jj, jk, jn + REAL(wp) :: zdispot, zfact, zcalcon + REAL(wp) :: zomegaca, zexcess, zexcess0 + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zco3, zcaldiss, zhinit, zhi, zco3sat + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_lys') + ! + zhinit (:,:,:) = hi(:,:,:) * 1000. / ( rhop(:,:,:) + rtrn ) + ! + ! ------------------------------------------- + ! COMPUTE [CO3--] and [H+] CONCENTRATIONS + ! ------------------------------------------- + + CALL solve_at_general( zhinit, zhi ) + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zco3(ji,jj,jk) = trb(ji,jj,jk,jpdic) * ak13(ji,jj,jk) * ak23(ji,jj,jk) / (zhi(ji,jj,jk)**2 & + & + ak13(ji,jj,jk) * zhi(ji,jj,jk) + ak13(ji,jj,jk) * ak23(ji,jj,jk) + rtrn ) + hi (ji,jj,jk) = zhi(ji,jj,jk) * rhop(ji,jj,jk) / 1000. + END DO + END DO + END DO + + ! --------------------------------------------------------- + ! CALCULATE DEGREE OF CACO3 SATURATION AND CORRESPONDING + ! DISSOLOUTION AND PRECIPITATION OF CACO3 (BE AWARE OF + ! MGCO3) + ! --------------------------------------------------------- + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + ! DEVIATION OF [CO3--] FROM SATURATION VALUE + ! Salinity dependance in zomegaca and divide by rhop/1000 to have good units + zcalcon = calcon * ( salinprac(ji,jj,jk) / 35._wp ) + zfact = rhop(ji,jj,jk) / 1000._wp + zomegaca = ( zcalcon * zco3(ji,jj,jk) ) / ( aksp(ji,jj,jk) * zfact + rtrn ) + zco3sat(ji,jj,jk) = aksp(ji,jj,jk) * zfact / ( zcalcon + rtrn ) + + ! SET DEGREE OF UNDER-/SUPERSATURATION + excess(ji,jj,jk) = 1._wp - zomegaca + zexcess0 = MAX( 0., excess(ji,jj,jk) ) + zexcess = zexcess0**nca + + ! AMOUNT CACO3 (12C) THAT RE-ENTERS SOLUTION + ! (ACCORDING TO THIS FORMULATION ALSO SOME PARTICULATE + ! CACO3 GETS DISSOLVED EVEN IN THE CASE OF OVERSATURATION) + zdispot = kdca * zexcess * trb(ji,jj,jk,jpcal) + ! CHANGE OF [CO3--] , [ALK], PARTICULATE [CACO3], + ! AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION + zcaldiss(ji,jj,jk) = zdispot * rfact2 / rmtss ! calcite dissolution + ! + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2. * zcaldiss(ji,jj,jk) + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) - zcaldiss(ji,jj,jk) + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zcaldiss(ji,jj,jk) + END DO + END DO + END DO + ! + + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "PH" , -1. * LOG10( MAX( hi(:,:,:), rtrn ) ) * tmask(:,:,:) ) + IF( iom_use( "CO3" ) ) THEN + zco3(:,:,jpk) = 0. ; CALL iom_put( "CO3" , zco3(:,:,:) * 1.e+3 * tmask(:,:,:) ) + ENDIF + IF( iom_use( "CO3sat" ) ) THEN + zco3sat(:,:,jpk) = 0. ; CALL iom_put( "CO3sat", zco3sat(:,:,:) * 1.e+3 * tmask(:,:,:) ) + ENDIF + IF( iom_use( "DCAL" ) ) THEN + zcaldiss(:,:,jpk) = 0. ; CALL iom_put( "DCAL" , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('lys ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_lys') + ! + END SUBROUTINE p4z_lys + + + SUBROUTINE p4z_lys_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_lys_init *** + !! + !! ** Purpose : Initialization of CaCO3 dissolution parameters + !! + !! ** Method : Read the nampiscal namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampiscal + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/nampiscal/ kdca, nca + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_lys_init : initialization of CaCO3 dissolution' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampiscal, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampiscal in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampiscal, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampiscal in configuration namelist' ) + IF(lwm) WRITE( numonp, nampiscal ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampiscal' + WRITE(numout,*) ' diss. rate constant calcite (per month) kdca =', kdca + WRITE(numout,*) ' order of reaction for calcite dissolution nca =', nca + ENDIF + ! + ! Number of seconds per month + rmtss = nyear_len(1) * rday / raamo + ! + END SUBROUTINE p4z_lys_init + + !!====================================================================== +END MODULE p4zlys diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmeso.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmeso.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fdbeae942e6e8fe6bef0e0d443cacd564745a926 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmeso.F90 @@ -0,0 +1,316 @@ +MODULE p4zmeso + !!====================================================================== + !! *** MODULE p4zmeso *** + !! TOP : PISCES Compute the sources/sinks for mesozooplankton + !!====================================================================== + !! History : 1.0 ! 2002 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !!---------------------------------------------------------------------- + !! p4z_meso : Compute the sources/sinks for mesozooplankton + !! p4z_meso_init : Initialization of the parameters for mesozooplankton + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zprod ! production + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_meso ! called in p4zbio.F90 + PUBLIC p4z_meso_init ! called in trcsms_pisces.F90 + + REAL(wp), PUBLIC :: part2 !: part of calcite not dissolved in mesozoo guts + REAL(wp), PUBLIC :: xpref2d !: mesozoo preference for diatoms + REAL(wp), PUBLIC :: xpref2n !: mesozoo preference for nanophyto + REAL(wp), PUBLIC :: xpref2z !: mesozoo preference for microzooplankton + REAL(wp), PUBLIC :: xpref2c !: mesozoo preference for POC + REAL(wp), PUBLIC :: xthresh2zoo !: zoo feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2dia !: diatoms feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2phy !: nanophyto feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2poc !: poc feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2 !: feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: resrat2 !: exsudation rate of mesozooplankton + REAL(wp), PUBLIC :: mzrat2 !: microzooplankton mortality rate + REAL(wp), PUBLIC :: grazrat2 !: maximal mesozoo grazing rate + REAL(wp), PUBLIC :: xkgraz2 !: non assimilated fraction of P by mesozoo + REAL(wp), PUBLIC :: unass2 !: Efficicency of mesozoo growth + REAL(wp), PUBLIC :: sigma2 !: Fraction of mesozoo excretion as DOM + REAL(wp), PUBLIC :: epsher2 !: growth efficiency + REAL(wp), PUBLIC :: epsher2min !: minimum growth efficiency at high food for grazing 2 + REAL(wp), PUBLIC :: grazflux !: mesozoo flux feeding rate + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zmeso.F90 12837 2020-05-01 08:37:37Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_meso( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_meso *** + !! + !! ** Purpose : Compute the sources/sinks for mesozooplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step and ??? + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zcompadi, zcompaph, zcompapoc, zcompaz, zcompam + REAL(wp) :: zgraze2 , zdenom, zdenom2 + REAL(wp) :: zfact , zfood, zfoodlim, zproport, zbeta + REAL(wp) :: zmortzgoc, zfrac, zfracfe, zratio, zratio2, zfracal, zgrazcal + REAL(wp) :: zepsherf, zepshert, zepsherv, zepsherq + REAL(wp) :: zgrarsig, zgraztotc, zgraztotn, zgraztotf + REAL(wp) :: zgrarem2, zgrafer2, zgrapoc2, zprcaca, zmortz, zgrasrat, zgrasratn + REAL(wp) :: zrespz, ztortz, zgrazd, zgrazz, zgrazpof + REAL(wp) :: zgrazn, zgrazpoc, zgraznf, zgrazf + REAL(wp) :: zgrazfffp, zgrazfffg, zgrazffep, zgrazffeg + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing2, zfezoo2, zz2ligprod + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_meso') + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompam = MAX( ( trb(ji,jj,jk,jpmes) - 1.e-9 ), 0.e0 ) + zfact = xstep * tgfunc2(ji,jj,jk) * zcompam + + ! Respiration rates of both zooplankton + ! ------------------------------------- + zrespz = resrat2 * zfact * ( trb(ji,jj,jk,jpmes) / ( xkmort + trb(ji,jj,jk,jpmes) ) & + & + 3. * nitrfac(ji,jj,jk) ) + + ! Zooplankton mortality. A square function has been selected with + ! no real reason except that it seems to be more stable and may mimic predation + ! --------------------------------------------------------------- + ztortz = mzrat2 * 1.e6 * zfact * trb(ji,jj,jk,jpmes) * (1. - nitrfac(ji,jj,jk) ) + ! + zcompadi = MAX( ( trb(ji,jj,jk,jpdia) - xthresh2dia ), 0.e0 ) + zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - xthresh2zoo ), 0.e0 ) + zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthresh2poc ), 0.e0 ) + ! Size effect of nanophytoplankton on grazing : the smaller it is, the less prone + ! it is to predation by mesozooplankton + ! ------------------------------------------------------------------------------- + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - xthresh2phy ), 0.e0 ) & + & * MIN(1., MAX( 0., ( quotan(ji,jj,jk) - 0.2) / 0.3 ) ) + + ! Mesozooplankton grazing + ! ------------------------ + zfood = xpref2d * zcompadi + xpref2z * zcompaz + xpref2n * zcompaph + xpref2c * zcompapoc + zfoodlim = MAX( 0., zfood - MIN( 0.5 * zfood, xthresh2 ) ) + zdenom = zfoodlim / ( xkgraz2 + zfoodlim ) + zdenom2 = zdenom / ( zfood + rtrn ) + zgraze2 = grazrat2 * xstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpmes) * (1. - nitrfac(ji,jj,jk)) + + zgrazd = zgraze2 * xpref2d * zcompadi * zdenom2 + zgrazz = zgraze2 * xpref2z * zcompaz * zdenom2 + zgrazn = zgraze2 * xpref2n * zcompaph * zdenom2 + zgrazpoc = zgraze2 * xpref2c * zcompapoc * zdenom2 + + zgraznf = zgrazn * trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) + rtrn) + zgrazf = zgrazd * trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn) + zgrazpof = zgrazpoc * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn) + + ! Mesozooplankton flux feeding on GOC + ! ---------------------------------- + zgrazffeg = grazflux * xstep * wsbio4(ji,jj,jk) & + & * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes) & + & * (1. - nitrfac(ji,jj,jk)) + zgrazfffg = zgrazffeg * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) + zgrazffep = grazflux * xstep * wsbio3(ji,jj,jk) & + & * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpmes) & + & * (1. - nitrfac(ji,jj,jk)) + zgrazfffp = zgrazffep * trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) + ! + zgraztotc = zgrazd + zgrazz + zgrazn + zgrazpoc + zgrazffep + zgrazffeg + ! Compute the proportion of filter feeders + zproport = (zgrazffep + zgrazffeg)/(rtrn + zgraztotc) + ! Compute fractionation of aggregates. It is assumed that + ! diatoms based aggregates are more prone to fractionation + ! since they are more porous (marine snow instead of fecal pellets) + zratio = trb(ji,jj,jk,jpgsi) / ( trb(ji,jj,jk,jpgoc) + rtrn ) + zratio2 = zratio * zratio + zfrac = zproport * grazflux * xstep * wsbio4(ji,jj,jk) & + & * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes) & + & * ( 0.2 + 3.8 * zratio2 / ( 1.**2 + zratio2 ) ) + zfracfe = zfrac * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) + + zgrazffep = zproport * zgrazffep + zgrazffeg = zproport * zgrazffeg + zgrazfffp = zproport * zgrazfffp + zgrazfffg = zproport * zgrazfffg + zgraztotc = zgrazd + zgrazz + zgrazn + zgrazpoc + zgrazffep + zgrazffeg + zgraztotn = zgrazd * quotad(ji,jj,jk) + zgrazz + zgrazn * quotan(ji,jj,jk) & + & + zgrazpoc + zgrazffep + zgrazffeg + zgraztotf = zgrazf + zgraznf + zgrazz * ferat3 + zgrazpof + zgrazfffp + zgrazfffg + + ! Total grazing ( grazing by microzoo is already computed in p4zmicro ) + zgrazing2(ji,jj,jk) = zgraztotc + + ! Mesozooplankton efficiency. + ! We adopt a formulation proposed by Mitra et al. (2007) + ! The gross growth efficiency is controled by the most limiting nutrient. + ! Growth is also further decreased when the food quality is poor. This is currently + ! hard coded : it can be decreased by up to 50% (zepsherq) + ! GGE can also be decreased when food quantity is high, zepsherf (Montagnes and + ! Fulton, 2012) + ! ----------------------------------------------------------------------------------- + zgrasrat = ( zgraztotf + rtrn )/ ( zgraztotc + rtrn ) + zgrasratn = ( zgraztotn + rtrn )/ ( zgraztotc + rtrn ) + zepshert = MIN( 1., zgrasratn, zgrasrat / ferat3) + zbeta = MAX(0., (epsher2 - epsher2min) ) + zepsherf = epsher2min + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta ) + zepsherq = 0.5 + (1.0 - 0.5) * zepshert * ( 1.0 + 1.0 ) / ( zepshert + 1.0 ) + zepsherv = zepsherf * zepshert * zepsherq + + zgrarem2 = zgraztotc * ( 1. - zepsherv - unass2 ) & + & + ( 1. - epsher2 - unass2 ) / ( 1. - epsher2 ) * ztortz + zgrafer2 = zgraztotc * MAX( 0. , ( 1. - unass2 ) * zgrasrat - ferat3 * zepsherv ) & + & + ferat3 * ( ( 1. - epsher2 - unass2 ) /( 1. - epsher2 ) * ztortz ) + zgrapoc2 = zgraztotc * unass2 + + ! Update the arrays TRA which contain the biological sources and sinks + zgrarsig = zgrarem2 * sigma2 + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zgrarsig + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zgrarsig + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zgrarem2 - zgrarsig + ! + IF( ln_ligand ) THEN + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + (zgrarem2 - zgrarsig) * ldocz + zz2ligprod(ji,jj,jk) = (zgrarem2 - zgrarsig) * ldocz + ENDIF + ! + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - o2ut * zgrarsig + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zgrafer2 + zfezoo2(ji,jj,jk) = zgrafer2 + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrarsig + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * zgrarsig + + zmortz = ztortz + zrespz + zmortzgoc = unass2 / ( 1. - epsher2 ) * ztortz + zrespz + tra(ji,jj,jk,jpmes) = tra(ji,jj,jk,jpmes) - zmortz + zepsherv * zgraztotc + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zgrazd + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) - zgrazz + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgrazn + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazn * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpphy) + rtrn ) + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazd * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazd * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazd * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgraznf + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazf + + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zgrazpoc - zgrazffep + zfrac + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zfrac + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zgrazpoc - zgrazffep + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zmortzgoc - zgrazffeg + zgrapoc2 - zfrac + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zmortzgoc + zgrapoc2 + consgoc(ji,jj,jk) = consgoc(ji,jj,jk) - zgrazffeg - zfrac + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zgrazpof - zgrazfffp + zfracfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + ferat3 * zmortzgoc - zgrazfffg & + & + zgraztotf * unass2 - zfracfe + zfracal = trb(ji,jj,jk,jpcal) / (trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + rtrn ) + zgrazcal = (zgrazffeg + zgrazpoc) * (1. - part2) * zfracal + ! calcite production + zprcaca = xfracal(ji,jj,jk) * zgrazn + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + ! + zprcaca = part2 * zprcaca + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrazcal - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2. * ( zgrazcal + zprcaca ) + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) - zgrazcal + zprcaca + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "PCAL" , prodcal(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Calcite production + IF( iom_use("GRAZ2") ) THEN ! Total grazing of phyto by zooplankton + zgrazing2(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ2" , zgrazing2(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use("FEZOO2") ) THEN + zfezoo2 (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO2", zfezoo2(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( ln_ligand ) THEN + zz2ligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ2", zz2ligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('meso')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_meso') + ! + END SUBROUTINE p4z_meso + + + SUBROUTINE p4z_meso_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_meso_init *** + !! + !! ** Purpose : Initialization of mesozooplankton parameters + !! + !! ** Method : Read the nampismes namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampismes + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/namp4zmes/ part2, grazrat2, resrat2, mzrat2, xpref2n, xpref2d, xpref2z, & + & xpref2c, xthresh2dia, xthresh2phy, xthresh2zoo, xthresh2poc, & + & xthresh2, xkgraz2, epsher2, epsher2min, sigma2, unass2, grazflux + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_meso_init : Initialization of mesozooplankton parameters' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp4zmes, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp4zmes in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp4zmes, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp4zmes in configuration namelist' ) + IF(lwm) WRITE( numonp, namp4zmes ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namp4zmes' + WRITE(numout,*) ' part of calcite not dissolved in mesozoo guts part2 =', part2 + WRITE(numout,*) ' mesozoo preference for phyto xpref2n =', xpref2n + WRITE(numout,*) ' mesozoo preference for diatoms xpref2d =', xpref2d + WRITE(numout,*) ' mesozoo preference for zoo xpref2z =', xpref2z + WRITE(numout,*) ' mesozoo preference for poc xpref2c =', xpref2c + WRITE(numout,*) ' microzoo feeding threshold for mesozoo xthresh2zoo =', xthresh2zoo + WRITE(numout,*) ' diatoms feeding threshold for mesozoo xthresh2dia =', xthresh2dia + WRITE(numout,*) ' nanophyto feeding threshold for mesozoo xthresh2phy =', xthresh2phy + WRITE(numout,*) ' poc feeding threshold for mesozoo xthresh2poc =', xthresh2poc + WRITE(numout,*) ' feeding threshold for mesozooplankton xthresh2 =', xthresh2 + WRITE(numout,*) ' exsudation rate of mesozooplankton resrat2 =', resrat2 + WRITE(numout,*) ' mesozooplankton mortality rate mzrat2 =', mzrat2 + WRITE(numout,*) ' maximal mesozoo grazing rate grazrat2 =', grazrat2 + WRITE(numout,*) ' mesozoo flux feeding rate grazflux =', grazflux + WRITE(numout,*) ' non assimilated fraction of P by mesozoo unass2 =', unass2 + WRITE(numout,*) ' Efficiency of Mesozoo growth epsher2 =', epsher2 + WRITE(numout,*) ' Minimum Efficiency of Mesozoo growth epsher2min =', epsher2min + WRITE(numout,*) ' Fraction of mesozoo excretion as DOM sigma2 =', sigma2 + WRITE(numout,*) ' half sturation constant for grazing 2 xkgraz2 =', xkgraz2 + ENDIF + ! + END SUBROUTINE p4z_meso_init + + !!====================================================================== +END MODULE p4zmeso diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmicro.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmicro.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e9a0b33be5ecc587d88ee4ec5bae733ca9f88aee --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmicro.F90 @@ -0,0 +1,270 @@ +MODULE p4zmicro + !!====================================================================== + !! *** MODULE p4zmicro *** + !! TOP : PISCES Compute the sources/sinks for microzooplankton + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !!---------------------------------------------------------------------- + !! p4z_micro : Compute the sources/sinks for microzooplankton + !! p4z_micro_init : Initialize and read the appropriate namelist + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim ! Co-limitations + USE p4zprod ! production + USE iom ! I/O manager + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_micro ! called in p4zbio.F90 + PUBLIC p4z_micro_init ! called in trcsms_pisces.F90 + + REAL(wp), PUBLIC :: part !: part of calcite not dissolved in microzoo guts + REAL(wp), PUBLIC :: xprefc !: microzoo preference for POC + REAL(wp), PUBLIC :: xprefn !: microzoo preference for nanophyto + REAL(wp), PUBLIC :: xprefd !: microzoo preference for diatoms + REAL(wp), PUBLIC :: xthreshdia !: diatoms feeding threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshphy !: nanophyto threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshpoc !: poc threshold for microzooplankton + REAL(wp), PUBLIC :: xthresh !: feeding threshold for microzooplankton + REAL(wp), PUBLIC :: resrat !: exsudation rate of microzooplankton + REAL(wp), PUBLIC :: mzrat !: microzooplankton mortality rate + REAL(wp), PUBLIC :: grazrat !: maximal microzoo grazing rate + REAL(wp), PUBLIC :: xkgraz !: Half-saturation constant of assimilation + REAL(wp), PUBLIC :: unass !: Non-assimilated part of food + REAL(wp), PUBLIC :: sigma1 !: Fraction of microzoo excretion as DOM + REAL(wp), PUBLIC :: epsher !: growth efficiency for grazing 1 + REAL(wp), PUBLIC :: epshermin !: minimum growth efficiency for grazing 1 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zmicro.F90 12837 2020-05-01 08:37:37Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_micro( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_micro *** + !! + !! ** Purpose : Compute the sources/sinks for microzooplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: knt ! ??? + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zcompadi, zcompaz , zcompaph, zcompapoc + REAL(wp) :: zgraze , zdenom, zdenom2 + REAL(wp) :: zfact , zfood, zfoodlim, zbeta + REAL(wp) :: zepsherf, zepshert, zepsherv, zepsherq + REAL(wp) :: zgrarsig, zgraztotc, zgraztotn, zgraztotf + REAL(wp) :: zgrarem, zgrafer, zgrapoc, zprcaca, zmortz + REAL(wp) :: zrespz, ztortz, zgrasrat, zgrasratn + REAL(wp) :: zgrazp, zgrazm, zgrazsd + REAL(wp) :: zgrazmf, zgrazsf, zgrazpf + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo, zzligprod + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_micro') + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - 1.e-9 ), 0.e0 ) + zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz + + ! Respiration rates of both zooplankton + ! ------------------------------------- + zrespz = resrat * zfact * trb(ji,jj,jk,jpzoo) / ( xkmort + trb(ji,jj,jk,jpzoo) ) & + & + resrat * zfact * 3. * nitrfac(ji,jj,jk) + + ! Zooplankton mortality. A square function has been selected with + ! no real reason except that it seems to be more stable and may mimic predation. + ! --------------------------------------------------------------- + ztortz = mzrat * 1.e6 * zfact * trb(ji,jj,jk,jpzoo) * (1. - nitrfac(ji,jj,jk)) + + zcompadi = MIN( MAX( ( trb(ji,jj,jk,jpdia) - xthreshdia ), 0.e0 ), xsizedia ) + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - xthreshphy ), 0.e0 ) + zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthreshpoc ), 0.e0 ) + + ! Microzooplankton grazing + ! ------------------------ + zfood = xprefn * zcompaph + xprefc * zcompapoc + xprefd * zcompadi + zfoodlim = MAX( 0. , zfood - min(xthresh,0.5*zfood) ) + zdenom = zfoodlim / ( xkgraz + zfoodlim ) + zdenom2 = zdenom / ( zfood + rtrn ) + zgraze = grazrat * xstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpzoo) * (1. - nitrfac(ji,jj,jk)) + + zgrazp = zgraze * xprefn * zcompaph * zdenom2 + zgrazm = zgraze * xprefc * zcompapoc * zdenom2 + zgrazsd = zgraze * xprefd * zcompadi * zdenom2 + + zgrazpf = zgrazp * trb(ji,jj,jk,jpnfe) / (trb(ji,jj,jk,jpphy) + rtrn) + zgrazmf = zgrazm * trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) + zgrazsf = zgrazsd * trb(ji,jj,jk,jpdfe) / (trb(ji,jj,jk,jpdia) + rtrn) + ! + zgraztotc = zgrazp + zgrazm + zgrazsd + zgraztotf = zgrazpf + zgrazsf + zgrazmf + zgraztotn = zgrazp * quotan(ji,jj,jk) + zgrazm + zgrazsd * quotad(ji,jj,jk) + + ! Grazing by microzooplankton + zgrazing(ji,jj,jk) = zgraztotc + + ! Microzooplankton efficiency. + ! We adopt a formulation proposed by Mitra et al. (2007) + ! The gross growth efficiency is controled by the most limiting nutrient. + ! Growth is also further decreased when the food quality is poor. This is currently + ! hard coded : it can be decreased by up to 50% (zepsherq) + ! GGE can also be decreased when food quantity is high, zepsherf (Montagnes and + ! Fulton, 2012) + ! ----------------------------------------------------------------------------- + zgrasrat = ( zgraztotf + rtrn ) / ( zgraztotc + rtrn ) + zgrasratn = ( zgraztotn + rtrn ) / ( zgraztotc + rtrn ) + zepshert = MIN( 1., zgrasratn, zgrasrat / ferat3) + zbeta = MAX(0., (epsher - epshermin) ) + zepsherf = epshermin + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta ) + zepsherq = 0.5 + (1.0 - 0.5) * zepshert * ( 1.0 + 1.0 ) / ( zepshert + 1.0 ) + zepsherv = zepsherf * zepshert * zepsherq + + zgrafer = zgraztotc * MAX( 0. , ( 1. - unass ) * zgrasrat - ferat3 * zepsherv ) + zgrarem = zgraztotc * ( 1. - zepsherv - unass ) + zgrapoc = zgraztotc * unass + + ! Update of the TRA arrays + ! ------------------------ + zgrarsig = zgrarem * sigma1 + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zgrarsig + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zgrarsig + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zgrarem - zgrarsig + ! + IF( ln_ligand ) THEN + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + (zgrarem - zgrarsig) * ldocz + zzligprod(ji,jj,jk) = (zgrarem - zgrarsig) * ldocz + ENDIF + ! + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - o2ut * zgrarsig + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zgrafer + zfezoo(ji,jj,jk) = zgrafer + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zgrapoc + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zgrapoc + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zgraztotf * unass + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrarsig + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * zgrarsig + ! Update the arrays TRA which contain the biological sources and sinks + ! -------------------------------------------------------------------- + zmortz = ztortz + zrespz + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) - zmortz + zepsherv * zgraztotc + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgrazp + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zgrazsd + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgrazp * trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazsd * trb(ji,jj,jk,jpdch)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazsd * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazsd * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgrazpf + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazsf + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zmortz - zgrazm + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zmortz + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zgrazm + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + ferat3 * zmortz - zgrazmf + ! + ! calcite production + zprcaca = xfracal(ji,jj,jk) * zgrazp + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + ! + zprcaca = part * zprcaca + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2. * zprcaca + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) + zprcaca + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + IF( iom_use("GRAZ1") ) THEN ! Total grazing of phyto by zooplankton + zgrazing(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ1" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use("FEZOO") ) THEN + zfezoo (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO" , zfezoo(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( ln_ligand ) THEN + zzligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ", zzligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:)) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('micro')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_micro') + ! + END SUBROUTINE p4z_micro + + + SUBROUTINE p4z_micro_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_micro_init *** + !! + !! ** Purpose : Initialization of microzooplankton parameters + !! + !! ** Method : Read the nampiszoo namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampiszoo + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/namp4zzoo/ part, grazrat, resrat, mzrat, xprefn, xprefc, & + & xprefd, xthreshdia, xthreshphy, xthreshpoc, & + & xthresh, xkgraz, epsher, epshermin, sigma1, unass + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_micro_init : Initialization of microzooplankton parameters' + WRITE(numout,*) '~~~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp4zzoo, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp4zzoo in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp4zzoo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp4zzoo in configuration namelist' ) + IF(lwm) WRITE( numonp, namp4zzoo ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namp4zzoo' + WRITE(numout,*) ' part of calcite not dissolved in microzoo guts part =', part + WRITE(numout,*) ' microzoo preference for POC xprefc =', xprefc + WRITE(numout,*) ' microzoo preference for nano xprefn =', xprefn + WRITE(numout,*) ' microzoo preference for diatoms xprefd =', xprefd + WRITE(numout,*) ' diatoms feeding threshold for microzoo xthreshdia =', xthreshdia + WRITE(numout,*) ' nanophyto feeding threshold for microzoo xthreshphy =', xthreshphy + WRITE(numout,*) ' poc feeding threshold for microzoo xthreshpoc =', xthreshpoc + WRITE(numout,*) ' feeding threshold for microzooplankton xthresh =', xthresh + WRITE(numout,*) ' exsudation rate of microzooplankton resrat =', resrat + WRITE(numout,*) ' microzooplankton mortality rate mzrat =', mzrat + WRITE(numout,*) ' maximal microzoo grazing rate grazrat =', grazrat + WRITE(numout,*) ' non assimilated fraction of P by microzoo unass =', unass + WRITE(numout,*) ' Efficicency of microzoo growth epsher =', epsher + WRITE(numout,*) ' Minimum efficicency of microzoo growth epshermin =', epshermin + WRITE(numout,*) ' Fraction of microzoo excretion as DOM sigma1 =', sigma1 + WRITE(numout,*) ' half sturation constant for grazing 1 xkgraz =', xkgraz + ENDIF + ! + END SUBROUTINE p4z_micro_init + + !!====================================================================== +END MODULE p4zmicro diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmort.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmort.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9c23ba4c09e6173d175436a3f5dc6122280dddad --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zmort.F90 @@ -0,0 +1,249 @@ +MODULE p4zmort + !!====================================================================== + !! *** MODULE p4zmort *** + !! TOP : PISCES Compute the mortality terms for phytoplankton + !!====================================================================== + !! History : 1.0 ! 2002 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !!---------------------------------------------------------------------- + !! p4z_mort : Compute the mortality terms for phytoplankton + !! p4z_mort_init : Initialize the mortality params for phytoplankton + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zprod ! Primary productivity + USE p4zlim ! Phytoplankton limitation terms + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_mort + PUBLIC p4z_mort_init + + REAL(wp), PUBLIC :: wchl !: + REAL(wp), PUBLIC :: wchld !: + REAL(wp), PUBLIC :: wchldm !: + REAL(wp), PUBLIC :: mprat !: + REAL(wp), PUBLIC :: mprat2 !: + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zmort.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_mort( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_mort *** + !! + !! ** Purpose : Calls the different subroutine to initialize and compute + !! the different phytoplankton mortality terms + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + CALL p4z_nano ! nanophytoplankton + ! + CALL p4z_diat ! diatoms + ! + END SUBROUTINE p4z_mort + + + SUBROUTINE p4z_nano + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_nano *** + !! + !! ** Purpose : Compute the mortality terms for nanophytoplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zsizerat, zcompaph + REAL(wp) :: zfactfe, zfactch, zprcaca, zfracal + REAL(wp) :: ztortp , zrespp , zmortp + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_nano') + ! + prodcal(:,:,:) = 0._wp ! calcite production variable set to zero + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - 1e-8 ), 0.e0 ) + ! When highly limited by macronutrients, very small cells + ! dominate the community. As a consequence, aggregation + ! due to turbulence is negligible. Mortality is also set + ! to 0 + zsizerat = MIN(1., MAX( 0., (quotan(ji,jj,jk) - 0.2) / 0.3) ) * trb(ji,jj,jk,jpphy) + ! Squared mortality of Phyto similar to a sedimentation term during + ! blooms (Doney et al. 1996) + zrespp = wchl * 1.e6 * xstep * xdiss(ji,jj,jk) * zcompaph * zsizerat + + ! Phytoplankton mortality. This mortality loss is slightly + ! increased when nutrients are limiting phytoplankton growth + ! as observed for instance in case of iron limitation. + ztortp = mprat * xstep * zcompaph / ( xkmort + trb(ji,jj,jk,jpphy) ) * zsizerat + + zmortp = zrespp + ztortp + + ! Update the arrays TRA which contains the biological sources and sinks + + zfactfe = trb(ji,jj,jk,jpnfe)/(trb(ji,jj,jk,jpphy)+rtrn) + zfactch = trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zmortp + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zmortp * zfactch + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zmortp * zfactfe + zprcaca = xfracal(ji,jj,jk) * zmortp + ! + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + ! + zfracal = 0.5 * xfracal(ji,jj,jk) + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2. * zprcaca + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) + zprcaca + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zfracal * zmortp + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + ( 1. - zfracal ) * zmortp + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + ( 1. - zfracal ) * zmortp + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zfracal * zmortp + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + ( 1. - zfracal ) * zmortp * zfactfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zfracal * zmortp * zfactfe + END DO + END DO + END DO + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('nano')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_nano') + ! + END SUBROUTINE p4z_nano + + + SUBROUTINE p4z_diat + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_diat *** + !! + !! ** Purpose : Compute the mortality terms for diatoms + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zfactfe,zfactsi,zfactch, zcompadi + REAL(wp) :: zrespp2, ztortp2, zmortp2 + REAL(wp) :: zlim2, zlim1 + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_diat') + ! + ! Aggregation term for diatoms is increased in case of nutrient + ! stress as observed in reality. The stressed cells become more + ! sticky and coagulate to sink quickly out of the euphotic zone + ! ------------------------------------------------------------ + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + zcompadi = MAX( ( trb(ji,jj,jk,jpdia) - 1e-9), 0. ) + + ! Aggregation term for diatoms is increased in case of nutrient + ! stress as observed in reality. The stressed cells become more + ! sticky and coagulate to sink quickly out of the euphotic zone + ! ------------------------------------------------------------ + ! Phytoplankton respiration + ! ------------------------ + zlim2 = xlimdia(ji,jj,jk) * xlimdia(ji,jj,jk) + zlim1 = 0.25 * ( 1. - zlim2 ) / ( 0.25 + zlim2 ) + zrespp2 = 1.e6 * xstep * ( wchld + wchldm * zlim1 ) * xdiss(ji,jj,jk) * zcompadi * trb(ji,jj,jk,jpdia) + + ! Phytoplankton mortality. + ! ------------------------ + ztortp2 = mprat2 * xstep * trb(ji,jj,jk,jpdia) / ( xkmort + trb(ji,jj,jk,jpdia) ) * zcompadi + + zmortp2 = zrespp2 + ztortp2 + + ! Update the arrays tra which contains the biological sources and sinks + ! --------------------------------------------------------------------- + zfactch = trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactfe = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactsi = trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zmortp2 + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zmortp2 * zfactch + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zmortp2 * zfactfe + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zmortp2 * zfactsi + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zmortp2 * zfactsi + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zrespp2 + 0.5 * ztortp2 + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + 0.5 * ztortp2 + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + 0.5 * ztortp2 + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zrespp2 + 0.5 * ztortp2 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + 0.5 * ztortp2 * zfactfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + ( zrespp2 + 0.5 * ztortp2 ) * zfactfe + END DO + END DO + END DO + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('diat')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_diat') + ! + END SUBROUTINE p4z_diat + + + SUBROUTINE p4z_mort_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_mort_init *** + !! + !! ** Purpose : Initialization of phytoplankton parameters + !! + !! ** Method : Read the nampismort namelist and check the parameters + !! called at the first timestep + !! + !! ** input : Namelist nampismort + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/namp4zmort/ wchl, wchld, wchldm, mprat, mprat2 + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_mort_init : Initialization of phytoplankton mortality parameters' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) ! Namelist nampismort in reference namelist : Pisces phytoplankton + READ ( numnatp_ref, namp4zmort, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp4zmort in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampismort in configuration namelist : Pisces phytoplankton + READ ( numnatp_cfg, namp4zmort, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp4zmort in configuration namelist' ) + IF(lwm) WRITE( numonp, namp4zmort ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namp4zmort' + WRITE(numout,*) ' quadratic mortality of phytoplankton wchl =', wchl + WRITE(numout,*) ' maximum quadratic mortality of diatoms wchld =', wchld + WRITE(numout,*) ' maximum quadratic mortality of diatoms wchldm =', wchldm + WRITE(numout,*) ' phytoplankton mortality rate mprat =', mprat + WRITE(numout,*) ' Diatoms mortality rate mprat2 =', mprat2 + ENDIF + ! + END SUBROUTINE p4z_mort_init + + !!====================================================================== +END MODULE p4zmort diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zopt.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zopt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f4af78abfc79b92a8640f1e4c52df2bb76d6f221 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zopt.F90 @@ -0,0 +1,462 @@ +MODULE p4zopt + !!====================================================================== + !! *** MODULE p4zopt *** + !! TOP - PISCES : Compute the light availability in the water column + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.2 ! 2009-04 (C. Ethe, G. Madec) optimisation + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Improve light availability of nano & diat + !!---------------------------------------------------------------------- + !! p4z_opt : light availability in the water column + !!---------------------------------------------------------------------- + USE trc ! tracer variables + USE oce_trc ! tracer-ocean share variables + USE sms_pisces ! Source Minus Sink of PISCES + USE iom ! I/O manager + USE fldread ! time interpolation + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_opt ! called in p4zbio.F90 module + PUBLIC p4z_opt_init ! called in trcsms_pisces.F90 module + PUBLIC p4z_opt_alloc + + !! * Shared module variables + + LOGICAL :: ln_varpar ! boolean for variable PAR fraction + REAL(wp) :: parlux ! Fraction of shortwave as PAR + REAL(wp) :: xparsw ! parlux/3 + REAL(wp) :: xsi0r ! 1. /rn_si0 + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_par ! structure of input par + INTEGER , PARAMETER :: nbtimes = 366 !: maximum number of times record in a file + INTEGER :: ntimes_par ! number of time steps in a file + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: par_varsw ! PAR fraction of shortwave + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ekb, ekg, ekr ! wavelength (Red-Green-Blue) + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zopt.F90 14214 2020-12-18 11:46:40Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_opt( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_opt *** + !! + !! ** Purpose : Compute the light availability in the water column + !! depending on the depth and the chlorophyll concentration + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step + ! + INTEGER :: ji, jj, jk + INTEGER :: irgb + REAL(wp) :: zchl + REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep + REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zetmp5 + REAL(wp), DIMENSION(jpi,jpj ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 + REAL(wp), DIMENSION(jpi,jpj ) :: zqsr100, zqsr_corr + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpar, ze0, ze1, ze2, ze3, zchl3d + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_opt') + + IF( knt == 1 .AND. ln_varpar ) CALL p4z_opt_sbc( kt ) + + ! Initialisation of variables used to compute PAR + ! ----------------------------------------------- + ze1(:,:,:) = 0._wp + ze2(:,:,:) = 0._wp + ze3(:,:,:) = 0._wp + ! + ! !* attenuation coef. function of Chlorophyll and wavelength (Red-Green-Blue) + ! ! -------------------------------------------------------- + zchl3d(:,:,:) = trb(:,:,:,jpnch) + trb(:,:,:,jpdch) + IF( ln_p5z ) zchl3d(:,:,:) = zchl3d(:,:,:) + trb(:,:,:,jppch) + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zchl = ( zchl3d(ji,jj,jk) + rtrn ) * 1.e6 + zchl = MIN( 10. , MAX( 0.05, zchl ) ) + irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn ) + ! + ekb(ji,jj,jk) = rkrgb(1,irgb) * e3t_n(ji,jj,jk) + ekg(ji,jj,jk) = rkrgb(2,irgb) * e3t_n(ji,jj,jk) + ekr(ji,jj,jk) = rkrgb(3,irgb) * e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! !* Photosynthetically Available Radiation (PAR) + ! ! -------------------------------------- + IF( l_trcdm2dc ) THEN ! diurnal cycle + ! + zqsr_corr(:,:) = qsr_mean(:,:) / ( 1.-fr_i(:,:) + rtrn ) + ! + CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) + ! + DO jk = 1, nksr + etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) + enano (:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) + ediat (:,:,jk) = 1.62 * ze1(:,:,jk) + 0.74 * ze2(:,:,jk) + 0.63 * ze3(:,:,jk) + END DO + IF( ln_p5z ) THEN + DO jk = 1, nksr + epico (:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) + END DO + ENDIF + ! + zqsr_corr(:,:) = qsr(:,:) / ( 1.-fr_i(:,:) + rtrn ) + ! + CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) + ! + DO jk = 1, nksr + etot(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) + END DO + ! + ELSE + ! + zqsr_corr(:,:) = qsr(:,:) / ( 1.-fr_i(:,:) + rtrn ) + ! + CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) + ! + DO jk = 1, nksr + etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) + enano(:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) + ediat(:,:,jk) = 1.62 * ze1(:,:,jk) + 0.74 * ze2(:,:,jk) + 0.63 * ze3(:,:,jk) + END DO + IF( ln_p5z ) THEN + DO jk = 1, nksr + epico(:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) + END DO + ENDIF + etot_ndcy(:,:,:) = etot(:,:,:) + ENDIF + + + IF( ln_qsr_bio ) THEN !* heat flux accros w-level (used in the dynamics) + ! ! ------------------------ + CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3, pe0=ze0 ) + ! + etot3(:,:,1) = qsr(:,:) * tmask(:,:,1) + DO jk = 2, nksr + 1 + etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk) + END DO + ! ! ------------------------ + ENDIF + ! !* Euphotic depth and level + neln (:,:) = 1 ! ------------------------ + heup (:,:) = gdepw_n(:,:,2) + heup_01(:,:) = gdepw_n(:,:,2) + + DO jk = 2, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN + neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer + ! ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint + heup(ji,jj) = gdepw_n(ji,jj,jk+1) ! Euphotic layer depth + ENDIF + IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.50 ) THEN + heup_01(ji,jj) = gdepw_n(ji,jj,jk+1) ! Euphotic layer depth (light level definition) + ENDIF + END DO + END DO + END DO + ! + heup (:,:) = MIN( 300., heup (:,:) ) + heup_01(:,:) = MIN( 300., heup_01(:,:) ) + ! !* mean light over the mixed layer + zdepmoy(:,:) = 0.e0 ! ------------------------------- + zetmp1 (:,:) = 0.e0 + zetmp2 (:,:) = 0.e0 + + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN + zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot (ji,jj,jk) * e3t_n(ji,jj,jk) ! remineralisation + zetmp2 (ji,jj) = zetmp2 (ji,jj) + etot_ndcy(ji,jj,jk) * e3t_n(ji,jj,jk) ! production + zdepmoy(ji,jj) = zdepmoy(ji,jj) + e3t_n(ji,jj,jk) + ENDIF + END DO + END DO + END DO + ! + emoy(:,:,:) = etot(:,:,:) ! remineralisation + zpar(:,:,:) = etot_ndcy(:,:,:) ! diagnostic : PAR with no diurnal cycle + ! + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN + z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) + emoy (ji,jj,jk) = zetmp1(ji,jj) * z1_dep + zpar (ji,jj,jk) = zetmp2(ji,jj) * z1_dep + ENDIF + END DO + END DO + END DO + ! + zdepmoy(:,:) = 0.e0 + zetmp3 (:,:) = 0.e0 + zetmp4 (:,:) = 0.e0 + ! + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN + zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano (ji,jj,jk) * e3t_n(ji,jj,jk) ! production + zetmp4 (ji,jj) = zetmp4 (ji,jj) + ediat (ji,jj,jk) * e3t_n(ji,jj,jk) ! production + zdepmoy(ji,jj) = zdepmoy(ji,jj) + e3t_n(ji,jj,jk) + ENDIF + END DO + END DO + END DO + enanom(:,:,:) = enano(:,:,:) + ediatm(:,:,:) = ediat(:,:,:) + ! + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN + z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) + enanom(ji,jj,jk) = zetmp3(ji,jj) * z1_dep + ediatm(ji,jj,jk) = zetmp4(ji,jj) * z1_dep + ENDIF + END DO + END DO + END DO + ! + IF( ln_p5z ) THEN + ALLOCATE( zetmp5(jpi,jpj) ) ; zetmp5 (:,:) = 0.e0 + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN + zetmp5(ji,jj) = zetmp5 (ji,jj) + epico(ji,jj,jk) * e3t_n(ji,jj,jk) ! production + ENDIF + END DO + END DO + END DO + ! + epicom(:,:,:) = epico(:,:,:) + ! + DO jk = 1, nksr + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN + z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) + epicom(ji,jj,jk) = zetmp5(ji,jj) * z1_dep + ENDIF + END DO + END DO + END DO + DEALLOCATE( zetmp5 ) + ENDIF + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "Heup" , heup(:,: ) * tmask(:,:,1) ) ! euphotic layer deptht + IF( iom_use( "PAR" ) ) THEN + zpar(:,:,1) = zpar(:,:,1) * ( 1._wp - fr_i(:,:) ) + CALL iom_put( "PAR", zpar(:,:,:) * tmask(:,:,:) ) ! Photosynthetically Available Radiation + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_opt') + ! + END SUBROUTINE p4z_opt + + + SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0, pqsr100 ) + !!---------------------------------------------------------------------- + !! *** routine p4z_opt_par *** + !! + !! ** purpose : compute PAR of each wavelength (Red-Green-Blue) + !! for a given shortwave radiation + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pqsr ! shortwave + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe1 , pe2 , pe3 ! PAR ( R-G-B) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL :: pe0 ! + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out), OPTIONAL :: pqsr100 ! + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zqsr ! shortwave + !!---------------------------------------------------------------------- + + ! Real shortwave + IF( ln_varpar ) THEN ; zqsr(:,:) = par_varsw(:,:) * pqsr(:,:) + ELSE ; zqsr(:,:) = xparsw * pqsr(:,:) + ENDIF + + ! Light at the euphotic depth + IF( PRESENT( pqsr100 ) ) pqsr100(:,:) = 0.01 * 3. * zqsr(:,:) + + IF( PRESENT( pe0 ) ) THEN ! W-level + ! + pe0(:,:,1) = pqsr(:,:) - 3. * zqsr(:,:) ! ( 1 - 3 * alpha ) * q + pe1(:,:,1) = zqsr(:,:) + pe2(:,:,1) = zqsr(:,:) + pe3(:,:,1) = zqsr(:,:) + ! + DO jk = 2, nksr + 1 + DO jj = 1, jpj + DO ji = 1, jpi + pe0(ji,jj,jk) = pe0(ji,jj,jk-1) * EXP( -e3t_n(ji,jj,jk-1) * xsi0r ) + pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) ) + pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) ) + pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -ekr (ji,jj,jk-1 ) ) + END DO + ! + END DO + ! + END DO + ! + ELSE ! T- level + ! + pe1(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekb(:,:,1) ) + pe2(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekg(:,:,1) ) + pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) ) + ! + DO jk = 2, nksr + DO jj = 1, jpj + DO ji = 1, jpi + pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) ) + pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) ) + pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -0.5 * ( ekr(ji,jj,jk-1) + ekr(ji,jj,jk) ) ) + END DO + END DO + END DO + ! + ENDIF + ! + END SUBROUTINE p4z_opt_par + + + SUBROUTINE p4z_opt_sbc( kt ) + !!---------------------------------------------------------------------- + !! *** routine p4z_opt_sbc *** + !! + !! ** purpose : read and interpolate the variable PAR fraction + !! of shortwave radiation + !! + !! ** method : read the files and interpolate the appropriate variables + !! + !! ** input : external netcdf files + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji,jj + REAL(wp) :: zcoef + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_optsbc') + ! + ! Compute par_varsw at nit000 or only if there is more than 1 time record in par coefficient file + IF( ln_varpar ) THEN + IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_par > 1 ) ) THEN + CALL fld_read( kt, 1, sf_par ) + par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) ) / 3.0 + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_optsbc') + ! + END SUBROUTINE p4z_opt_sbc + + + SUBROUTINE p4z_opt_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_init *** + !! + !! ** Purpose : Initialization of tabulated attenuation coef + !! and of the percentage of PAR in Shortwave + !! + !! ** Input : external ascii and netcdf files + !!---------------------------------------------------------------------- + INTEGER :: numpar, ierr, ios ! Local integer + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_par ! informations about the fields to be read + ! + NAMELIST/nampisopt/cn_dir, sn_par, ln_varpar, parlux + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_opt_init : ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampisopt, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisopt in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampisopt, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisopt in configuration namelist' ) + IF(lwm) WRITE ( numonp, nampisopt ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist : nampisopt ' + WRITE(numout,*) ' PAR as a variable fraction of SW ln_varpar = ', ln_varpar + WRITE(numout,*) ' Default value for the PAR fraction parlux = ', parlux + ENDIF + ! + xparsw = parlux / 3.0 + xsi0r = 1.e0 / rn_si0 + ! + ! Variable PAR at the surface of the ocean + ! ---------------------------------------- + IF( ln_varpar ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> initialize variable par fraction (ln_varpar=T)' + ! + ALLOCATE( par_varsw(jpi,jpj) ) + ! + ALLOCATE( sf_par(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_opt_init: unable to allocate sf_par structure' ) + ! + CALL fld_fill( sf_par, (/ sn_par /), cn_dir, 'p4z_opt_init', 'Variable PAR fraction ', 'nampisopt' ) + ALLOCATE( sf_par(1)%fnow(jpi,jpj,1) ) + IF( sn_par%ln_tint ) ALLOCATE( sf_par(1)%fdta(jpi,jpj,1,2) ) + + CALL iom_open ( TRIM( sn_par%clname ) , numpar ) + ntimes_par = iom_getszuld( numpar ) ! get number of record in file + ENDIF + ! + ekr (:,:,:) = 0._wp + ekb (:,:,:) = 0._wp + ekg (:,:,:) = 0._wp + etot (:,:,:) = 0._wp + etot_ndcy(:,:,:) = 0._wp + enano (:,:,:) = 0._wp + ediat (:,:,:) = 0._wp + IF( ln_p5z ) epico (:,:,:) = 0._wp + IF( ln_qsr_bio ) etot3 (:,:,:) = 0._wp + ! + END SUBROUTINE p4z_opt_init + + + INTEGER FUNCTION p4z_opt_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_alloc *** + !!---------------------------------------------------------------------- + ! + ALLOCATE( ekb(jpi,jpj,jpk), ekr(jpi,jpj,jpk), & + ekg(jpi,jpj,jpk), STAT= p4z_opt_alloc ) + ! + IF( p4z_opt_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_opt_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p4z_opt_alloc + + !!====================================================================== +END MODULE p4zopt diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zpoc.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zpoc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..34da73a62d93938f60e0282976847bf753185f6c --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zpoc.F90 @@ -0,0 +1,938 @@ +MODULE p4zpoc + !!====================================================================== + !! *** MODULE p4zpoc *** + !! TOP : PISCES Compute remineralization of organic particles + !!========================================================================= + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !! 3.6 ! 2016-03 (O. Aumont) Quota model and diverse + !!---------------------------------------------------------------------- + !! p4z_poc : Compute remineralization/dissolution of organic compounds + !! p4z_poc_init : Initialisation of parameters for remineralisation + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_poc ! called in p4zbio.F90 + PUBLIC p4z_poc_init ! called in trcsms_pisces.F90 + PUBLIC alngam ! + PUBLIC gamain ! + + REAL(wp), PUBLIC :: xremip !: remineralisation rate of DOC + REAL(wp), PUBLIC :: xremipc !: remineralisation rate of DOC + REAL(wp), PUBLIC :: xremipn !: remineralisation rate of DON + REAL(wp), PUBLIC :: xremipp !: remineralisation rate of DOP + INTEGER , PUBLIC :: jcpoc !: number of lability classes + REAL(wp), PUBLIC :: rshape !: shape factor of the gamma distribution + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: alphan, reminp !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: alphap !: + + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zpoc.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_poc( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_poc *** + !! + !! ** Purpose : Compute remineralization of organic particles + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step and ??? + ! + INTEGER :: ji, jj, jk, jn + REAL(wp) :: zremip, zremig, zdep, zorem, zorem2, zofer + REAL(wp) :: zopon, zopop, zopoc, zopoc2, zopon2, zopop2 + REAL(wp) :: zsizek, zsizek1, alphat, remint, solgoc, zpoc + REAL(wp) :: zofer2, zofer3 + REAL(wp) :: zrfact2 + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj ) :: totprod, totthick, totcons + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zremipoc, zremigoc, zorem3, ztremint, zfolimi + REAL(wp), DIMENSION(jpi,jpj,jpk,jcpoc) :: alphag + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_poc') + ! + ! Initialization of local variables + ! --------------------------------- + + ! Here we compute the GOC -> POC rate due to the shrinking + ! of the fecal pellets/aggregates as a result of bacterial + ! solubilization + ! This is based on a fractal dimension of 2.56 and a spectral + ! slope of -3.6 (identical to what is used in p4zsink to compute + ! aggregation + solgoc = 0.04/ 2.56 * 1./ ( 1.-50**(-0.04) ) + + ! Initialisation of temprary arrys + IF( ln_p4z ) THEN + zremipoc(:,:,:) = xremip + zremigoc(:,:,:) = xremip + ELSE ! ln_p5z + zremipoc(:,:,:) = xremipc + zremigoc(:,:,:) = xremipc + ENDIF + zorem3(:,:,:) = 0. + orem (:,:,:) = 0. + ztremint(:,:,:) = 0. + zfolimi (:,:,:) = 0. + + DO jn = 1, jcpoc + alphag(:,:,:,jn) = alphan(jn) + alphap(:,:,:,jn) = alphan(jn) + END DO + + ! ----------------------------------------------------------------------- + ! Lability parameterization. This is the big particles part (GOC) + ! This lability parameterization can be activated only with the standard + ! particle scheme. Does not work with Kriest parameterization. + ! ----------------------------------------------------------------------- + ztremint(:,:,:) = zremigoc(:,:,:) + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF (tmask(ji,jj,jk) == 1.) THEN + zdep = hmld(ji,jj) + ! + ! In the case of GOC, lability is constant in the mixed layer + ! It is computed only below the mixed layer depth + ! ------------------------------------------------------------ + ! + IF( gdept_n(ji,jj,jk) > zdep ) THEN + alphat = 0. + remint = 0. + ! + zsizek1 = e3t_n(ji,jj,jk-1) / 2. / (wsbio4(ji,jj,jk-1) + rtrn) * tgfunc(ji,jj,jk-1) + zsizek = e3t_n(ji,jj,jk) / 2. / (wsbio4(ji,jj,jk) + rtrn) * tgfunc(ji,jj,jk) + ! + IF ( gdept_n(ji,jj,jk-1) <= zdep ) THEN + ! + ! The first level just below the mixed layer needs a + ! specific treatment because lability is supposed constant + ! everywhere within the mixed layer. This means that + ! change in lability in the bottom part of the previous cell + ! should not be computed + ! ---------------------------------------------------------- + ! + ! POC concentration is computed using the lagrangian + ! framework. It is only used for the lability param + zpoc = trb(ji,jj,jk-1,jpgoc) + consgoc(ji,jj,jk) * rday / rfact2 & + & * e3t_n(ji,jj,jk) / 2. / (wsbio4(ji,jj,jk) + rtrn) + zpoc = MAX(0., zpoc) + ! + DO jn = 1, jcpoc + ! + ! Lagrangian based algorithm. The fraction of each + ! lability class is computed starting from the previous + ! level + ! ----------------------------------------------------- + ! + ! the concentration of each lability class is calculated + ! as the sum of the different sources and sinks + ! Please note that production of new GOC experiences + ! degradation + alphag(ji,jj,jk,jn) = alphag(ji,jj,jk-1,jn) * exp( -reminp(jn) * zsizek ) * zpoc & + & + prodgoc(ji,jj,jk) * alphan(jn) / tgfunc(ji,jj,jk) / reminp(jn) & + & * ( 1. - exp( -reminp(jn) * zsizek ) ) * rday / rfact2 + alphat = alphat + alphag(ji,jj,jk,jn) + remint = remint + alphag(ji,jj,jk,jn) * reminp(jn) + END DO + ELSE + ! + ! standard algorithm in the rest of the water column + ! See the comments in the previous block. + ! --------------------------------------------------- + ! + zpoc = trb(ji,jj,jk-1,jpgoc) + consgoc(ji,jj,jk-1) * rday / rfact2 & + & * e3t_n(ji,jj,jk-1) / 2. / (wsbio4(ji,jj,jk-1) + rtrn) + consgoc(ji,jj,jk) & + & * rday / rfact2 * e3t_n(ji,jj,jk) / 2. / (wsbio4(ji,jj,jk) + rtrn) + zpoc = max(0., zpoc) + ! + DO jn = 1, jcpoc + alphag(ji,jj,jk,jn) = alphag(ji,jj,jk-1,jn) * exp( -reminp(jn) * ( zsizek & + & + zsizek1 ) ) * zpoc + ( prodgoc(ji,jj,jk-1) / tgfunc(ji,jj,jk-1) * ( 1. & + & - exp( -reminp(jn) * zsizek1 ) ) * exp( -reminp(jn) * zsizek ) + prodgoc(ji,jj,jk) & + & / tgfunc(ji,jj,jk) * ( 1. - exp( -reminp(jn) * zsizek ) ) ) * rday / rfact2 / reminp(jn) * alphan(jn) + alphat = alphat + alphag(ji,jj,jk,jn) + remint = remint + alphag(ji,jj,jk,jn) * reminp(jn) + END DO + ENDIF + ! + DO jn = 1, jcpoc + ! The contribution of each lability class at the current + ! level is computed + alphag(ji,jj,jk,jn) = alphag(ji,jj,jk,jn) / ( alphat + rtrn) + END DO + ! Computation of the mean remineralisation rate + ztremint(ji,jj,jk) = MAX(0., remint / ( alphat + rtrn) ) + ! + ENDIF + ENDIF + END DO + END DO + END DO + + IF( ln_p4z ) THEN ; zremigoc(:,:,:) = MIN( xremip , ztremint(:,:,:) ) + ELSE ; zremigoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) ) + ENDIF + + IF( ln_p4z ) THEN + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! POC disaggregation by turbulence and bacterial activity. + ! -------------------------------------------------------- + zremig = zremigoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk) + zorem2 = zremig * trb(ji,jj,jk,jpgoc) + orem(ji,jj,jk) = zorem2 + zorem3(ji,jj,jk) = zremig * solgoc * trb(ji,jj,jk,jpgoc) + zofer2 = zremig * trb(ji,jj,jk,jpbfe) + zofer3 = zremig * solgoc * trb(ji,jj,jk,jpbfe) + + ! ------------------------------------- + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zorem3(ji,jj,jk) + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) - zorem2 - zorem3(ji,jj,jk) + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zofer3 + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) - zofer2 - zofer3 + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zorem2 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zofer2 + zfolimi(ji,jj,jk) = zofer2 + END DO + END DO + END DO + ELSE + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! POC disaggregation by turbulence and bacterial activity. + ! -------------------------------------------------------- + zremig = zremigoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk) + zopoc2 = zremig * trb(ji,jj,jk,jpgoc) + orem(ji,jj,jk) = zopoc2 + zorem3(ji,jj,jk) = zremig * solgoc * trb(ji,jj,jk,jpgoc) + zopon2 = xremipn / xremipc * zremig * trb(ji,jj,jk,jpgon) + zopop2 = xremipp / xremipc * zremig * trb(ji,jj,jk,jpgop) + zofer2 = xremipn / xremipc * zremig * trb(ji,jj,jk,jpbfe) + + ! ------------------------------------- + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zorem3(ji,jj,jk) + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + solgoc * zopon2 + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + solgoc * zopop2 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + solgoc * zofer2 + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zopoc2 + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + zopon2 + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + zopop2 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zofer2 + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) - zopoc2 - zorem3(ji,jj,jk) + tra(ji,jj,jk,jpgon) = tra(ji,jj,jk,jpgon) - zopon2 * (1. + solgoc) + tra(ji,jj,jk,jpgop) = tra(ji,jj,jk,jpgop) - zopop2 * (1. + solgoc) + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) - zofer2 * (1. + solgoc) + zfolimi(ji,jj,jk) = zofer2 + END DO + END DO + END DO + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('poc1')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + + ! ------------------------------------------------------------------ + ! Lability parameterization for the small OM particles. This param + ! is based on the same theoretical background as the big particles. + ! However, because of its low sinking speed, lability is not supposed + ! to be equal to its initial value (the value of the freshly produced + ! organic matter). It is however uniform in the mixed layer. + ! ------------------------------------------------------------------- + ! + totprod (:,:) = 0. + totthick(:,:) = 0. + totcons (:,:) = 0. + ! intregrated production and consumption of POC in the mixed layer + ! ---------------------------------------------------------------- + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zdep = hmld(ji,jj) + IF (tmask(ji,jj,jk) == 1. .AND. gdept_n(ji,jj,jk) <= zdep ) THEN + totprod(ji,jj) = totprod(ji,jj) + prodpoc(ji,jj,jk) * e3t_n(ji,jj,jk) * rday/ rfact2 + ! The temperature effect is included here + totthick(ji,jj) = totthick(ji,jj) + e3t_n(ji,jj,jk)* tgfunc(ji,jj,jk) + totcons(ji,jj) = totcons(ji,jj) - conspoc(ji,jj,jk) * e3t_n(ji,jj,jk) * rday/ rfact2 & + & / ( trb(ji,jj,jk,jppoc) + rtrn ) + ENDIF + END DO + END DO + END DO + + ! Computation of the lability spectrum in the mixed layer. In the mixed + ! layer, this spectrum is supposed to be uniform. + ! --------------------------------------------------------------------- + ztremint(:,:,:) = zremipoc(:,:,:) + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF (tmask(ji,jj,jk) == 1.) THEN + zdep = hmld(ji,jj) + alphat = 0.0 + remint = 0.0 + IF( gdept_n(ji,jj,jk) <= zdep ) THEN + DO jn = 1, jcpoc + ! For each lability class, the system is supposed to be + ! at equilibrium: Prod - Sink - w alphap = 0. + alphap(ji,jj,jk,jn) = totprod(ji,jj) * alphan(jn) / ( reminp(jn) & + & * totthick(ji,jj) + totcons(ji,jj) + wsbio + rtrn ) + alphat = alphat + alphap(ji,jj,jk,jn) + END DO + DO jn = 1, jcpoc + alphap(ji,jj,jk,jn) = alphap(ji,jj,jk,jn) / ( alphat + rtrn) + remint = remint + alphap(ji,jj,jk,jn) * reminp(jn) + END DO + ! Mean remineralization rate in the mixed layer + ztremint(ji,jj,jk) = MAX( 0., remint ) + ENDIF + ENDIF + END DO + END DO + END DO + ! + IF( ln_p4z ) THEN ; zremipoc(:,:,:) = MIN( xremip , ztremint(:,:,:) ) + ELSE ; zremipoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) ) + ENDIF + + ! ----------------------------------------------------------------------- + ! The lability parameterization is used here. The code is here + ! almost identical to what is done for big particles. The only difference + ! is that an additional source from GOC to POC is included. This means + ! that since we need the lability spectrum of GOC, GOC spectrum + ! should be determined before. + ! ----------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF (tmask(ji,jj,jk) == 1.) THEN + zdep = hmld(ji,jj) + IF( gdept_n(ji,jj,jk) > zdep ) THEN + alphat = 0. + remint = 0. + ! + ! the scale factors are corrected with temperature + zsizek1 = e3t_n(ji,jj,jk-1) / 2. / (wsbio3(ji,jj,jk-1) + rtrn) * tgfunc(ji,jj,jk-1) + zsizek = e3t_n(ji,jj,jk) / 2. / (wsbio3(ji,jj,jk) + rtrn) * tgfunc(ji,jj,jk) + ! + ! Special treatment of the level just below the MXL + ! See the comments in the GOC section + ! --------------------------------------------------- + ! + IF ( gdept_n(ji,jj,jk-1) <= zdep ) THEN + ! + ! Computation of the POC concentration using the + ! lagrangian algorithm + zpoc = trb(ji,jj,jk-1,jppoc) + conspoc(ji,jj,jk) * rday / rfact2 & + & * e3t_n(ji,jj,jk) / 2. / (wsbio3(ji,jj,jk) + rtrn) + zpoc = max(0., zpoc) + ! + DO jn = 1, jcpoc + ! computation of the lability spectrum applying the + ! different sources and sinks + alphap(ji,jj,jk,jn) = alphap(ji,jj,jk-1,jn) * exp( -reminp(jn) * zsizek ) * zpoc & + & + ( prodpoc(ji,jj,jk) * alphan(jn) + zorem3(ji,jj,jk) * alphag(ji,jj,jk,jn) ) & + & / tgfunc(ji,jj,jk) / reminp(jn) * rday / rfact2 * ( 1. - exp( -reminp(jn) & + & * zsizek ) ) + alphap(ji,jj,jk,jn) = MAX( 0., alphap(ji,jj,jk,jn) ) + alphat = alphat + alphap(ji,jj,jk,jn) + END DO + ELSE + ! + ! Lability parameterization for the interior of the ocean + ! This is very similar to what is done in the previous + ! block + ! -------------------------------------------------------- + ! + zpoc = trb(ji,jj,jk-1,jppoc) + conspoc(ji,jj,jk-1) * rday / rfact2 & + & * e3t_n(ji,jj,jk-1) / 2. / (wsbio3(ji,jj,jk-1) + rtrn) + conspoc(ji,jj,jk) & + & * rday / rfact2 * e3t_n(ji,jj,jk) / 2. / (wsbio3(ji,jj,jk) + rtrn) + zpoc = max(0., zpoc) + ! + DO jn = 1, jcpoc + alphap(ji,jj,jk,jn) = alphap(ji,jj,jk-1,jn) * exp( -reminp(jn) & + & * ( zsizek + zsizek1 ) ) * zpoc + ( prodpoc(ji,jj,jk-1) * alphan(jn) & + & + zorem3(ji,jj,jk-1) * alphag(ji,jj,jk-1,jn) ) * rday / rfact2 / reminp(jn) & + & / tgfunc(ji,jj,jk-1) * ( 1. - exp( -reminp(jn) * zsizek1 ) ) * exp( -reminp(jn) & + & * zsizek ) + ( prodpoc(ji,jj,jk) * alphan(jn) + zorem3(ji,jj,jk) & + & * alphag(ji,jj,jk,jn) ) * rday / rfact2 / reminp(jn) / tgfunc(ji,jj,jk) * ( 1. & + & - exp( -reminp(jn) * zsizek ) ) + alphap(ji,jj,jk,jn) = max(0., alphap(ji,jj,jk,jn) ) + alphat = alphat + alphap(ji,jj,jk,jn) + END DO + ENDIF + ! Normalization of the lability spectrum so that the + ! integral is equal to 1 + DO jn = 1, jcpoc + alphap(ji,jj,jk,jn) = alphap(ji,jj,jk,jn) / ( alphat + rtrn) + remint = remint + alphap(ji,jj,jk,jn) * reminp(jn) + END DO + ! Mean remineralization rate in the water column + ztremint(ji,jj,jk) = MAX( 0., remint ) + ENDIF + ENDIF + END DO + END DO + END DO + + IF( ln_p4z ) THEN ; zremipoc(:,:,:) = MIN( xremip , ztremint(:,:,:) ) + ELSE ; zremipoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) ) + ENDIF + + IF( ln_p4z ) THEN + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF (tmask(ji,jj,jk) == 1.) THEN + ! POC disaggregation by turbulence and bacterial activity. + ! -------------------------------------------------------- + zremip = zremipoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk) + zorem = zremip * trb(ji,jj,jk,jppoc) + zofer = zremip * trb(ji,jj,jk,jpsfe) + + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zorem + orem(ji,jj,jk) = orem(ji,jj,jk) + zorem + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zofer + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zorem + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zofer + zfolimi(ji,jj,jk) = zfolimi(ji,jj,jk) + zofer + ENDIF + END DO + END DO + END DO + ELSE + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! POC disaggregation by turbulence and bacterial activity. + ! -------------------------------------------------------- + zremip = zremipoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk) + zopoc = zremip * trb(ji,jj,jk,jppoc) + orem(ji,jj,jk) = orem(ji,jj,jk) + zopoc + zopon = xremipn / xremipc * zremip * trb(ji,jj,jk,jppon) + zopop = xremipp / xremipc * zremip * trb(ji,jj,jk,jppop) + zofer = xremipn / xremipc * zremip * trb(ji,jj,jk,jpsfe) + + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zopoc + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) - zopon + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) - zopop + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zofer + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zopoc + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + zopon + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + zopop + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zofer + zfolimi(ji,jj,jk) = zfolimi(ji,jj,jk) + zofer + END DO + END DO + END DO + ENDIF + + IF( lk_iomput ) THEN + IF( knt == nrdttrc ) THEN + zrfact2 = 1.e3 * rfact2r + CALL iom_put( "REMINP" , zremipoc(:,:,:) * tmask(:,:,:) ) ! Remineralisation rate + CALL iom_put( "REMING" , zremigoc(:,:,:) * tmask(:,:,:) ) ! Remineralisation rate + CALL iom_put( "REMINF" , zfolimi(:,:,:) * tmask(:,:,:) * 1.e+9 * zrfact2 ) ! Remineralisation rate + ENDIF + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('poc2')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + ! + IF( ln_timing ) CALL timing_stop('p4z_poc') + ! + END SUBROUTINE p4z_poc + + + SUBROUTINE p4z_poc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_poc_init *** + !! + !! ** Purpose : Initialization of remineralization parameters + !! + !! ** Method : Read the nampispoc namelist and check the parameters + !! called at the first timestep + !! + !! ** input : Namelist nampispoc + !!---------------------------------------------------------------------- + INTEGER :: jn ! dummy loop index + INTEGER :: ios, ifault ! Local integer + REAL(wp):: remindelta, reminup, remindown + !! + NAMELIST/nampispoc/ xremip , jcpoc , rshape, & + & xremipc, xremipn, xremipp + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_poc_init : Initialization of remineralization parameters' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) ! Namelist nampisrem in reference namelist : Pisces remineralization + READ ( numnatp_ref, nampispoc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampispoc in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampisrem in configuration namelist : Pisces remineralization + READ ( numnatp_cfg, nampispoc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampispoc in configuration namelist' ) + IF(lwm) WRITE( numonp, nampispoc ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampispoc' + IF( ln_p4z ) THEN + WRITE(numout,*) ' remineralisation rate of POC xremip =', xremip + ELSE + WRITE(numout,*) ' remineralisation rate of POC xremipc =', xremipc + WRITE(numout,*) ' remineralisation rate of PON xremipn =', xremipn + WRITE(numout,*) ' remineralisation rate of POP xremipp =', xremipp + ENDIF + WRITE(numout,*) ' Number of lability classes for POC jcpoc =', jcpoc + WRITE(numout,*) ' Shape factor of the gamma distribution rshape =', rshape + ENDIF + ! + ! Discretization along the lability space + ! --------------------------------------- + ! + ALLOCATE( alphan(jcpoc) , reminp(jcpoc) , alphap(jpi,jpj,jpk,jcpoc) ) + ! + IF (jcpoc > 1) THEN + ! + remindelta = LOG(4. * 1000. ) / REAL(jcpoc-1, wp) + reminup = 1./ 400. * EXP(remindelta) + ! + ! Discretization based on incomplete gamma functions + ! As incomplete gamma functions are not available in standard + ! fortran 95, they have been coded as functions in this module (gamain) + ! --------------------------------------------------------------------- + ! + alphan(1) = gamain(reminup, rshape, ifault) + reminp(1) = gamain(reminup, rshape+1.0_wp, ifault) * xremip / alphan(1) + DO jn = 2, jcpoc-1 + reminup = 1./ 400. * EXP( REAL(jn, wp) * remindelta) + remindown = 1. / 400. * EXP( REAL(jn-1, wp) * remindelta) + alphan(jn) = gamain(reminup, rshape, ifault) - gamain(remindown, rshape, ifault) + reminp(jn) = gamain(reminup, rshape+1.0_wp, ifault) - gamain(remindown, rshape+1.0_wp, ifault) + reminp(jn) = reminp(jn) * xremip / alphan(jn) + END DO + remindown = 1. / 400. * EXP( REAL(jcpoc-1, wp) * remindelta) + alphan(jcpoc) = 1.0 - gamain(remindown, rshape, ifault) + reminp(jcpoc) = 1.0 - gamain(remindown, rshape+1.0_wp, ifault) + reminp(jcpoc) = reminp(jcpoc) * xremip / alphan(jcpoc) + + ELSE + alphan(jcpoc) = 1. + reminp(jcpoc) = xremip + ENDIF + + DO jn = 1, jcpoc + alphap(:,:,:,jn) = alphan(jn) + END DO + + END SUBROUTINE p4z_poc_init + + + REAL FUNCTION alngam( xvalue, ifault ) + !*****************************************************************************80 + ! + !! ALNGAM computes the logarithm of the gamma function. + ! + ! Modified: 13 January 2008 + ! + ! Author : Allan Macleod + ! FORTRAN90 version by John Burkardt + ! + ! Reference: + ! Allan Macleod, Algorithm AS 245, + ! A Robust and Reliable Algorithm for the Logarithm of the Gamma Function, + ! Applied Statistics, + ! Volume 38, Number 2, 1989, pages 397-402. + ! + ! Parameters: + ! + ! Input, real ( kind = 8 ) XVALUE, the argument of the Gamma function. + ! + ! Output, integer ( kind = 4 ) IFAULT, error flag. + ! 0, no error occurred. + ! 1, XVALUE is less than or equal to 0. + ! 2, XVALUE is too big. + ! + ! Output, real ( kind = 8 ) ALNGAM, the logarithm of the gamma function of X. + !*****************************************************************************80 + implicit none + + real(wp), parameter :: alr2pi = 0.918938533204673E+00 + integer:: ifault + real(wp), dimension ( 9 ) :: r1 = (/ & + -2.66685511495E+00, & + -24.4387534237E+00, & + -21.9698958928E+00, & + 11.1667541262E+00, & + 3.13060547623E+00, & + 0.607771387771E+00, & + 11.9400905721E+00, & + 31.4690115749E+00, & + 15.2346874070E+00 /) + real(wp), dimension ( 9 ) :: r2 = (/ & + -78.3359299449E+00, & + -142.046296688E+00, & + 137.519416416E+00, & + 78.6994924154E+00, & + 4.16438922228E+00, & + 47.0668766060E+00, & + 313.399215894E+00, & + 263.505074721E+00, & + 43.3400022514E+00 /) + real(wp), dimension ( 9 ) :: r3 = (/ & + -2.12159572323E+05, & + 2.30661510616E+05, & + 2.74647644705E+04, & + -4.02621119975E+04, & + -2.29660729780E+03, & + -1.16328495004E+05, & + -1.46025937511E+05, & + -2.42357409629E+04, & + -5.70691009324E+02 /) + real(wp), dimension ( 5 ) :: r4 = (/ & + 0.279195317918525E+00, & + 0.4917317610505968E+00, & + 0.0692910599291889E+00, & + 3.350343815022304E+00, & + 6.012459259764103E+00 /) + real (wp) :: x + real (wp) :: x1 + real (wp) :: x2 + real (wp), parameter :: xlge = 5.10E+05 + real (wp), parameter :: xlgst = 1.0E+30 + real (wp) :: xvalue + real (wp) :: y + + x = xvalue + alngam = 0.0E+00 +! +! Check the input. +! + if ( xlgst <= x ) then + ifault = 2 + return + end if + if ( x <= 0.0E+00 ) then + ifault = 1 + return + end if + + ifault = 0 +! +! Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined. +! + if ( x < 1.5E+00 ) then + + if ( x < 0.5E+00 ) then + alngam = - log ( x ) + y = x + 1.0E+00 +! +! Test whether X < machine epsilon. +! + if ( y == 1.0E+00 ) then + return + end if + + else + + alngam = 0.0E+00 + y = x + x = ( x - 0.5E+00 ) - 0.5E+00 + + end if + + alngam = alngam + x * (((( & + r1(5) * y & + + r1(4) ) * y & + + r1(3) ) * y & + + r1(2) ) * y & + + r1(1) ) / (((( & + y & + + r1(9) ) * y & + + r1(8) ) * y & + + r1(7) ) * y & + + r1(6) ) + + return + + end if +! +! Calculation for 1.5 <= X < 4.0. +! + if ( x < 4.0E+00 ) then + + y = ( x - 1.0E+00 ) - 1.0E+00 + + alngam = y * (((( & + r2(5) * x & + + r2(4) ) * x & + + r2(3) ) * x & + + r2(2) ) * x & + + r2(1) ) / (((( & + x & + + r2(9) ) * x & + + r2(8) ) * x & + + r2(7) ) * x & + + r2(6) ) +! +! Calculation for 4.0 <= X < 12.0. +! + else if ( x < 12.0E+00 ) then + + alngam = (((( & + r3(5) * x & + + r3(4) ) * x & + + r3(3) ) * x & + + r3(2) ) * x & + + r3(1) ) / (((( & + x & + + r3(9) ) * x & + + r3(8) ) * x & + + r3(7) ) * x & + + r3(6) ) +! +! Calculation for 12.0 <= X. +! + else + + y = log ( x ) + alngam = x * ( y - 1.0E+00 ) - 0.5E+00 * y + alr2pi + + if ( x <= xlge ) then + + x1 = 1.0E+00 / x + x2 = x1 * x1 + + alngam = alngam + x1 * ( ( & + r4(3) * & + x2 + r4(2) ) * & + x2 + r4(1) ) / ( ( & + x2 + r4(5) ) * & + x2 + r4(4) ) + + end if + + end if + + END FUNCTION alngam + + + REAL FUNCTION gamain( x, p, ifault ) +!*****************************************************************************80 +! +!! GAMAIN computes the incomplete gamma ratio. +! +! Discussion: +! +! A series expansion is used if P > X or X <= 1. Otherwise, a +! continued fraction approximation is used. +! +! Modified: +! +! 17 January 2008 +! +! Author: +! +! G Bhattacharjee +! FORTRAN90 version by John Burkardt +! +! Reference: +! +! G Bhattacharjee, +! Algorithm AS 32: +! The Incomplete Gamma Integral, +! Applied Statistics, +! Volume 19, Number 3, 1970, pages 285-287. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, P, the parameters of the incomplete +! gamma ratio. 0 <= X, and 0 < P. +! +! Output, integer ( kind = 4 ) IFAULT, error flag. +! 0, no errors. +! 1, P <= 0. +! 2, X < 0. +! 3, underflow. +! 4, error return from the Log Gamma routine. +! +! Output, real ( kind = 8 ) GAMAIN, the value of the incomplete +! gamma ratio. +! + implicit none + + real (wp) a + real (wp), parameter :: acu = 1.0E-08 + real (wp) an + real (wp) arg + real (wp) b + real (wp) dif + real (wp) factor + real (wp) g + real (wp) gin + integer i + integer ifault + real (wp), parameter :: oflo = 1.0E+37 + real (wp) p + real (wp) pn(6) + real (wp) rn + real (wp) term + real (wp), parameter :: uflo = 1.0E-37 + real (wp) x +! +! Check the input. +! + if ( p <= 0.0E+00 ) then + ifault = 1 + gamain = 0.0E+00 + return + end if + + if ( x < 0.0E+00 ) then + ifault = 2 + gamain = 0.0E+00 + return + end if + + if ( x == 0.0E+00 ) then + ifault = 0 + gamain = 0.0E+00 + return + end if + + g = alngam ( p, ifault ) + + if ( ifault /= 0 ) then + ifault = 4 + gamain = 0.0E+00 + return + end if + + arg = p * log ( x ) - x - g + + if ( arg < log ( uflo ) ) then + ifault = 3 + gamain = 0.0E+00 + return + end if + + ifault = 0 + factor = exp ( arg ) +! +! Calculation by series expansion. +! + if ( x <= 1.0E+00 .or. x < p ) then + + gin = 1.0E+00 + term = 1.0E+00 + rn = p + + do + + rn = rn + 1.0E+00 + term = term * x / rn + gin = gin + term + + if ( term <= acu ) then + exit + end if + + end do + + gamain = gin * factor / p + return + + end if +! +! Calculation by continued fraction. +! + a = 1.0E+00 - p + b = a + x + 1.0E+00 + term = 0.0E+00 + + pn(1) = 1.0E+00 + pn(2) = x + pn(3) = x + 1.0E+00 + pn(4) = x * b + + gin = pn(3) / pn(4) + + do + + a = a + 1.0E+00 + b = b + 2.0E+00 + term = term + 1.0E+00 + an = a * term + do i = 1, 2 + pn(i+4) = b * pn(i+2) - an * pn(i) + end do + + if ( pn(6) /= 0.0E+00 ) then + + rn = pn(5) / pn(6) + dif = abs ( gin - rn ) +! +! Absolute error tolerance satisfied? +! + if ( dif <= acu ) then +! +! Relative error tolerance satisfied? +! + if ( dif <= acu * rn ) then + gamain = 1.0E+00 - factor * gin + exit + end if + + end if + + gin = rn + + end if + + do i = 1, 4 + pn(i) = pn(i+2) + end do + if ( oflo <= abs ( pn(5) ) ) then + + do i = 1, 4 + pn(i) = pn(i) / oflo + end do + + end if + + end do + + END FUNCTION gamain + + !!====================================================================== +END MODULE p4zpoc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zprod.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zprod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..55f80b8c7fb06cb89b16ce422b111390f7930610 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zprod.F90 @@ -0,0 +1,446 @@ +MODULE p4zprod + !!====================================================================== + !! *** MODULE p4zprod *** + !! TOP : Growth Rate of the two phytoplanktons groups + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-05 (O. Aumont, C. Ethe) New parameterization of light limitation + !!---------------------------------------------------------------------- + !! p4z_prod : Compute the growth Rate of the two phytoplanktons groups + !! p4z_prod_init : Initialization of the parameters for growth + !! p4z_prod_alloc : Allocate variables for growth + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim ! Co-limitations of differents nutrients + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_prod ! called in p4zbio.F90 + PUBLIC p4z_prod_init ! called in trcsms_pisces.F90 + PUBLIC p4z_prod_alloc + + REAL(wp), PUBLIC :: pislopen !: + REAL(wp), PUBLIC :: pisloped !: + REAL(wp), PUBLIC :: xadap !: + REAL(wp), PUBLIC :: excretn !: + REAL(wp), PUBLIC :: excretd !: + REAL(wp), PUBLIC :: bresp !: + REAL(wp), PUBLIC :: chlcnm !: + REAL(wp), PUBLIC :: chlcdm !: + REAL(wp), PUBLIC :: chlcmin !: + REAL(wp), PUBLIC :: fecnm !: + REAL(wp), PUBLIC :: fecdm !: + REAL(wp), PUBLIC :: grosip !: + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: quotan !: proxy of N quota in Nanophyto + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: quotad !: proxy of N quota in diatomee + + REAL(wp) :: r1_rday ! 1 / rday + REAL(wp) :: texcretn ! 1 - excretn + REAL(wp) :: texcretd ! 1 - excretd + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zprod.F90 12280 2019-12-21 10:42:44Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_prod( kt , knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_prod *** + !! + !! ** Purpose : Compute the phytoplankton production depending on + !! light, temperature and nutrient availability + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zsilfac, znanotot, zdiattot, zconctemp, zconctemp2 + REAL(wp) :: zratio, zmax, zsilim, ztn, zadap, zlim, zsilfac2, zsiborn + REAL(wp) :: zprod, zproreg, zproreg2, zprochln, zprochld + REAL(wp) :: zmaxday, zdocprod, zpislopen, zpisloped + REAL(wp) :: zmxltst, zmxlday + REAL(wp) :: zrum, zcodel, zargu, zval, zfeup, chlcnm_n, chlcdm_n + REAL(wp) :: zfact + CHARACTER (len=25) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zw2d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d + REAL(wp), DIMENSION(jpi,jpj ) :: zstrn, zmixnano, zmixdiat + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprmaxn,zprmaxd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpislopeadn, zpislopeadd, zysopt + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprdia, zprbio, zprdch, zprnch + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprorcan, zprorcad, zprofed, zprofen + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpronewn, zpronewd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmxl_fac, zmxl_chl + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpligprod1, zpligprod2 + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_prod') + ! + ! Allocate temporary workspace + ! + zprorcan(:,:,:) = 0._wp ; zprorcad(:,:,:) = 0._wp ; zprofed (:,:,:) = 0._wp + zprofen (:,:,:) = 0._wp ; zysopt (:,:,:) = 0._wp + zpronewn(:,:,:) = 0._wp ; zpronewd(:,:,:) = 0._wp ; zprdia (:,:,:) = 0._wp + zprbio (:,:,:) = 0._wp ; zprdch (:,:,:) = 0._wp ; zprnch (:,:,:) = 0._wp + zmxl_fac(:,:,:) = 0._wp ; zmxl_chl(:,:,:) = 0._wp + + ! Computation of the optimal production + zprmaxn(:,:,:) = 0.8_wp * r1_rday * tgfunc(:,:,:) + zprmaxd(:,:,:) = zprmaxn(:,:,:) + + ! compute the day length depending on latitude and the day + zrum = REAL( nday_year - 80, wp ) / REAL( nyear_len(1), wp ) + zcodel = ASIN( SIN( zrum * rpi * 2._wp ) * SIN( rad * 23.5_wp ) ) + + ! day length in hours + zstrn(:,:) = 0. + DO jj = 1, jpj + DO ji = 1, jpi + zargu = TAN( zcodel ) * TAN( gphit(ji,jj) * rad ) + zargu = MAX( -1., MIN( 1., zargu ) ) + zstrn(ji,jj) = MAX( 0.0, 24. - 2. * ACOS( zargu ) / rad / 15. ) + END DO + END DO + + ! Impact of the day duration and light intermittency on phytoplankton growth + DO jk = 1, jpkm1 + DO jj = 1 ,jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + zval = MAX( 1., zstrn(ji,jj) ) + IF( gdept_n(ji,jj,jk) <= hmld(ji,jj) ) THEN + zval = zval * MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn )) + ENDIF + zmxl_chl(ji,jj,jk) = zval / 24. + zmxl_fac(ji,jj,jk) = 1.5 * zval / ( 12. + zval ) + ENDIF + END DO + END DO + END DO + + zprbio(:,:,:) = zprmaxn(:,:,:) * zmxl_fac(:,:,:) + zprdia(:,:,:) = zprmaxd(:,:,:) * zmxl_fac(:,:,:) + + ! Maximum light intensity + WHERE( zstrn(:,:) < 1.e0 ) zstrn(:,:) = 24. + + ! Computation of the P-I slope for nanos and diatoms + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ztn = MAX( 0., tsn(ji,jj,jk,jp_tem) - 15. ) + zadap = xadap * ztn / ( 2.+ ztn ) + zconctemp = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia ) + zconctemp2 = trb(ji,jj,jk,jpdia) - zconctemp + ! + zpislopeadn(ji,jj,jk) = pislopen * ( 1.+ zadap * EXP( -0.25 * enano(ji,jj,jk) ) ) & + & * trb(ji,jj,jk,jpnch) /( trb(ji,jj,jk,jpphy) * 12. + rtrn) + ! + zpislopeadd(ji,jj,jk) = (pislopen * zconctemp2 + pisloped * zconctemp) / ( trb(ji,jj,jk,jpdia) + rtrn ) & + & * trb(ji,jj,jk,jpdch) /( trb(ji,jj,jk,jpdia) * 12. + rtrn) + ENDIF + END DO + END DO + END DO + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! Computation of production function for Carbon + ! --------------------------------------------- + zpislopen = zpislopeadn(ji,jj,jk) / ( ( r1_rday + bresp * r1_rday ) & + & * zmxl_fac(ji,jj,jk) * rday + rtrn) + zpisloped = zpislopeadd(ji,jj,jk) / ( ( r1_rday + bresp * r1_rday ) & + & * zmxl_fac(ji,jj,jk) * rday + rtrn) + zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen * enano(ji,jj,jk) ) ) + zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediat(ji,jj,jk) ) ) + ! Computation of production function for Chlorophyll + !-------------------------------------------------- + zpislopen = zpislopeadn(ji,jj,jk) / ( zprmaxn(ji,jj,jk) * zmxl_chl(ji,jj,jk) * rday + rtrn ) + zpisloped = zpislopeadd(ji,jj,jk) / ( zprmaxd(ji,jj,jk) * zmxl_chl(ji,jj,jk) * rday + rtrn ) + zprnch(ji,jj,jk) = zprmaxn(ji,jj,jk) * ( 1.- EXP( -zpislopen * enanom(ji,jj,jk) ) ) + zprdch(ji,jj,jk) = zprmaxd(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediatm(ji,jj,jk) ) ) + ENDIF + END DO + END DO + END DO + + ! Computation of a proxy of the N/C ratio + ! --------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zval = MIN( xnanopo4(ji,jj,jk), ( xnanonh4(ji,jj,jk) + xnanono3(ji,jj,jk) ) ) & + & * zprmaxn(ji,jj,jk) / ( zprbio(ji,jj,jk) + rtrn ) + quotan(ji,jj,jk) = MIN( 1., 0.2 + 0.8 * zval ) + zval = MIN( xdiatpo4(ji,jj,jk), ( xdiatnh4(ji,jj,jk) + xdiatno3(ji,jj,jk) ) ) & + & * zprmaxd(ji,jj,jk) / ( zprdia(ji,jj,jk) + rtrn ) + quotad(ji,jj,jk) = MIN( 1., 0.2 + 0.8 * zval ) + END DO + END DO + END DO + + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! Si/C of diatoms + ! ------------------------ + ! Si/C increases with iron stress and silicate availability + ! Si/C is arbitrariliy increased for very high Si concentrations + ! to mimic the very high ratios observed in the Southern Ocean (silpot2) + zlim = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi1 ) + zsilim = MIN( zprdia(ji,jj,jk) / ( zprmaxd(ji,jj,jk) + rtrn ), xlimsi(ji,jj,jk) ) + zsilfac = 4.4 * EXP( -4.23 * zsilim ) * MAX( 0.e0, MIN( 1., 2.2 * ( zlim - 0.5 ) ) ) + 1.e0 + zsiborn = trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) + IF (gphit(ji,jj) < -30 ) THEN + zsilfac2 = 1. + 2. * zsiborn / ( zsiborn + xksi2**3 ) + ELSE + zsilfac2 = 1. + zsiborn / ( zsiborn + xksi2**3 ) + ENDIF + zysopt(ji,jj,jk) = grosip * zlim * zsilfac * zsilfac2 + ENDIF + END DO + END DO + END DO + + ! Mixed-layer effect on production + ! Sea-ice effect on production + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + END DO + END DO + END DO + + ! Computation of the various production terms + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for nanophyto. (C) + zprorcan(ji,jj,jk) = zprbio(ji,jj,jk) * xlimphy(ji,jj,jk) * trb(ji,jj,jk,jpphy) * rfact2 + zpronewn(ji,jj,jk) = zprorcan(ji,jj,jk)* xnanono3(ji,jj,jk) / ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + rtrn ) + ! + zratio = trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) * fecnm + rtrn ) + zmax = MAX( 0., ( 1. - zratio ) / ABS( 1.05 - zratio ) ) + zprofen(ji,jj,jk) = fecnm * zprmaxn(ji,jj,jk) * ( 1.0 - fr_i(ji,jj) ) & + & * ( 4. - 4.5 * xlimnfe(ji,jj,jk) / ( xlimnfe(ji,jj,jk) + 0.5 ) ) & + & * biron(ji,jj,jk) / ( biron(ji,jj,jk) + concnfe(ji,jj,jk) ) & + & * zmax * trb(ji,jj,jk,jpphy) * rfact2 + ! production terms for diatoms (C) + zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * trb(ji,jj,jk,jpdia) * rfact2 + zpronewd(ji,jj,jk) = zprorcad(ji,jj,jk) * xdiatno3(ji,jj,jk) / ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + rtrn ) + ! + zratio = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) * fecdm + rtrn ) + zmax = MAX( 0., ( 1. - zratio ) / ABS( 1.05 - zratio ) ) + zprofed(ji,jj,jk) = fecdm * zprmaxd(ji,jj,jk) * ( 1.0 - fr_i(ji,jj) ) & + & * ( 4. - 4.5 * xlimdfe(ji,jj,jk) / ( xlimdfe(ji,jj,jk) + 0.5 ) ) & + & * biron(ji,jj,jk) / ( biron(ji,jj,jk) + concdfe(ji,jj,jk) ) & + & * zmax * trb(ji,jj,jk,jpdia) * rfact2 + ENDIF + END DO + END DO + END DO + + ! Computation of the chlorophyll production terms + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for nanophyto. ( chlorophyll ) + znanotot = enanom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprod = rday * zprorcan(ji,jj,jk) * zprnch(ji,jj,jk) * xlimphy(ji,jj,jk) + zprochln = chlcmin * 12. * zprorcan (ji,jj,jk) + chlcnm_n = MIN ( chlcnm, ( chlcnm / (1. - 1.14 / 43.4 *tsn(ji,jj,jk,jp_tem))) * (1. - 1.14 / 43.4 * 20.)) + zprochln = zprochln + (chlcnm_n-chlcmin) * 12. * zprod / & + & ( zpislopeadn(ji,jj,jk) * znanotot +rtrn) + ! production terms for diatoms ( chlorophyll ) + zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * xlimdia(ji,jj,jk) + zprochld = chlcmin * 12. * zprorcad(ji,jj,jk) + chlcdm_n = MIN ( chlcdm, ( chlcdm / (1. - 1.14 / 43.4 * tsn(ji,jj,jk,jp_tem))) * (1. - 1.14 / 43.4 * 20.)) + zprochld = zprochld + (chlcdm_n-chlcmin) * 12. * zprod / & + & ( zpislopeadd(ji,jj,jk) * zdiattot +rtrn ) + ! Update the arrays TRA which contain the Chla sources and sinks + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) + zprochln * texcretn + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) + zprochld * texcretd + ENDIF + END DO + END DO + END DO + + ! Update the arrays TRA which contain the biological sources and sinks + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji =1 ,jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + zproreg = zprorcan(ji,jj,jk) - zpronewn(ji,jj,jk) + zproreg2 = zprorcad(ji,jj,jk) - zpronewd(ji,jj,jk) + zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) - zprorcan(ji,jj,jk) - zprorcad(ji,jj,jk) + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) - zpronewn(ji,jj,jk) - zpronewd(ji,jj,jk) + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) - zproreg - zproreg2 + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) + zprorcan(ji,jj,jk) * texcretn + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) + zprofen(ji,jj,jk) * texcretn + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) + zprorcad(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) + zprofed(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) + zprorcad(ji,jj,jk) * zysopt(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zdocprod + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + o2ut * ( zproreg + zproreg2) & + & + ( o2ut + o2nit ) * ( zpronewn(ji,jj,jk) + zpronewd(ji,jj,jk) ) + ! + zfeup = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zfeup + tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) - texcretd * zprorcad(ji,jj,jk) * zysopt(ji,jj,jk) + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) - zprorcan(ji,jj,jk) - zprorcad(ji,jj,jk) + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * ( zpronewn(ji,jj,jk) + zpronewd(ji,jj,jk) ) & + & - rno3 * ( zproreg + zproreg2 ) + ENDIF + END DO + END DO + END DO + ! + IF( ln_ligand ) THEN + zpligprod1(:,:,:) = 0._wp ; zpligprod2(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji =1 ,jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) + zfeup = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + zdocprod * ldocp - zfeup * plig(ji,jj,jk) * lthet + zpligprod1(ji,jj,jk) = zdocprod * ldocp + zpligprod2(ji,jj,jk) = zfeup * plig(ji,jj,jk) * lthet + ENDIF + END DO + END DO + END DO + ENDIF + + + ! Total primary production per year + IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) & + & tpp = glob_sum( 'p4zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * cvol(:,:,:) ) + + IF( lk_iomput .AND. knt == nrdttrc ) THEN + zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s + ! + CALL iom_put( "PPPHYN" , zprorcan(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by nanophyto + CALL iom_put( "PPPHYD" , zprorcad(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by diatomes + CALL iom_put( "PPNEWN" , zpronewn(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by nanophyto + CALL iom_put( "PPNEWD" , zpronewd(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by diatomes + CALL iom_put( "PBSi" , zprorcad(:,:,:) * zfact * tmask(:,:,:) * zysopt(:,:,:) ) ! biogenic silica production + CALL iom_put( "PFeN" , zprofen(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by nanophyto + CALL iom_put( "PFeD" , zprofed(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by diatomes + IF( ln_ligand ) THEN + CALL iom_put( "LPRODP" , zpligprod1(:,:,:) * 1e9 * zfact * tmask(:,:,:) ) + CALL iom_put( "LDETP" , zpligprod2(:,:,:) * 1e9 * zfact * tmask(:,:,:) ) + ENDIF + CALL iom_put( "Mumax" , zprmaxn(:,:,:) * tmask(:,:,:) ) ! Maximum growth rate + CALL iom_put( "MuN" , zprbio(:,:,:) * xlimphy(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for nanophyto + CALL iom_put( "MuD" , zprdia(:,:,:) * xlimdia(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for diatoms + CALL iom_put( "LNlight" , zprbio (:,:,:) / (zprmaxn(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term + CALL iom_put( "LDlight" , zprdia (:,:,:) / (zprmaxd(:,:,:) + rtrn) * tmask(:,:,:) ) + CALL iom_put( "TPP" , ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * zfact * tmask(:,:,:) ) ! total primary production + CALL iom_put( "TPNEW" , ( zpronewn(:,:,:) + zpronewd(:,:,:) ) * zfact * tmask(:,:,:) ) ! total new production + CALL iom_put( "TPBFE" , ( zprofen(:,:,:) + zprofed(:,:,:) ) * zfact * tmask(:,:,:) ) ! total biogenic iron production + CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('prod')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_prod') + ! + END SUBROUTINE p4z_prod + + + SUBROUTINE p4z_prod_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_prod_init *** + !! + !! ** Purpose : Initialization of phytoplankton production parameters + !! + !! ** Method : Read the nampisprod namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampisprod + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + ! + NAMELIST/namp4zprod/ pislopen, pisloped, xadap, bresp, excretn, excretd, & + & chlcnm, chlcdm, chlcmin, fecnm, fecdm, grosip + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'p4z_prod_init : phytoplankton growth' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp4zprod, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp4zprod in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp4zprod, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp4zprod in configuration namelist' ) + IF(lwm) WRITE( numonp, namp4zprod ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namp4zprod' + WRITE(numout,*) ' mean Si/C ratio grosip =', grosip + WRITE(numout,*) ' P-I slope pislopen =', pislopen + WRITE(numout,*) ' Acclimation factor to low light xadap =', xadap + WRITE(numout,*) ' excretion ratio of nanophytoplankton excretn =', excretn + WRITE(numout,*) ' excretion ratio of diatoms excretd =', excretd + WRITE(numout,*) ' basal respiration in phytoplankton bresp =', bresp + WRITE(numout,*) ' Maximum Chl/C in phytoplankton chlcmin =', chlcmin + WRITE(numout,*) ' P-I slope for diatoms pisloped =', pisloped + WRITE(numout,*) ' Minimum Chl/C in nanophytoplankton chlcnm =', chlcnm + WRITE(numout,*) ' Minimum Chl/C in diatoms chlcdm =', chlcdm + WRITE(numout,*) ' Maximum Fe/C in nanophytoplankton fecnm =', fecnm + WRITE(numout,*) ' Minimum Fe/C in diatoms fecdm =', fecdm + ENDIF + ! + r1_rday = 1._wp / rday + texcretn = 1._wp - excretn + texcretd = 1._wp - excretd + tpp = 0._wp + ! + END SUBROUTINE p4z_prod_init + + + INTEGER FUNCTION p4z_prod_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_prod_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( quotan(jpi,jpj,jpk), quotad(jpi,jpj,jpk), STAT = p4z_prod_alloc ) + ! + IF( p4z_prod_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_prod_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p4z_prod_alloc + + !!====================================================================== +END MODULE p4zprod diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zrem.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zrem.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4c3f1adf34097d25a503b8f0bad04905f0432a88 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zrem.F90 @@ -0,0 +1,358 @@ +MODULE p4zrem + !!====================================================================== + !! *** MODULE p4zrem *** + !! TOP : PISCES Compute remineralization/dissolution of organic compounds + !!========================================================================= + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !!---------------------------------------------------------------------- + !! p4z_rem : Compute remineralization/dissolution of organic compounds + !! p4z_rem_init : Initialisation of parameters for remineralisation + !! p4z_rem_alloc : Allocate remineralisation variables + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zche ! chemical model + USE p4zprod ! Growth rate of the 2 phyto groups + USE p4zlim + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_rem ! called in p4zbio.F90 + PUBLIC p4z_rem_init ! called in trcsms_pisces.F90 + PUBLIC p4z_rem_alloc + + REAL(wp), PUBLIC :: xremikc !: remineralisation rate of DOC + REAL(wp), PUBLIC :: xremikn !: remineralisation rate of DON + REAL(wp), PUBLIC :: xremikp !: remineralisation rate of DOP + REAL(wp), PUBLIC :: xremik !: remineralisation rate of POC + REAL(wp), PUBLIC :: nitrif !: NH4 nitrification rate + REAL(wp), PUBLIC :: xsirem !: remineralisation rate of POC + REAL(wp), PUBLIC :: xsiremlab !: fast remineralisation rate of POC + REAL(wp), PUBLIC :: xsilab !: fraction of labile biogenic silica + REAL(wp), PUBLIC :: feratb !: Fe/C quota in bacteria + REAL(wp), PUBLIC :: xkferb !: Half-saturation constant for bacteria Fe/C + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: denitr !: denitrification array + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zrem.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_rem( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_rem *** + !! + !! ** Purpose : Compute remineralization/scavenging of organic compounds + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zremik, zremikc, zremikn, zremikp, zsiremin, zfact + REAL(wp) :: zsatur, zsatur2, znusil, znusil2, zdep, zdepmin, zfactdep + REAL(wp) :: zbactfer, zolimit, zonitr, zrfact2 + REAL(wp) :: zammonic, zoxyremc, zoxyremn, zoxyremp + REAL(wp) :: zosil, ztem, zdenitnh4, zolimic, zolimin, zolimip, zdenitrn, zdenitrp + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj ) :: ztempbac + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepbac, zolimi, zdepprod, zfacsi, zfacsib, zdepeff, zfebact + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_rem') + ! + ! Initialisation of arrys + zdepprod(:,:,:) = 1._wp + zdepeff (:,:,:) = 0.3_wp + ztempbac(:,:) = 0._wp + zfacsib(:,:,:) = xsilab / ( 1.0 - xsilab ) + zfebact(:,:,:) = 0._wp + zfacsi(:,:,:) = xsilab + + ! Computation of the mean phytoplankton concentration as + ! a crude estimate of the bacterial biomass + ! this parameterization has been deduced from a model version + ! that was modeling explicitely bacteria + ! ------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zdep = MAX( hmld(ji,jj), heup(ji,jj) ) + IF( gdept_n(ji,jj,jk) < zdep ) THEN + zdepbac(ji,jj,jk) = MIN( 0.7 * ( trb(ji,jj,jk,jpzoo) + 2.* trb(ji,jj,jk,jpmes) ), 4.e-6 ) + ztempbac(ji,jj) = zdepbac(ji,jj,jk) + ELSE + zdepmin = MIN( 1., zdep / gdept_n(ji,jj,jk) ) + zdepbac (ji,jj,jk) = zdepmin**0.683 * ztempbac(ji,jj) + zdepprod(ji,jj,jk) = zdepmin**0.273 + zdepeff (ji,jj,jk) = zdepeff(ji,jj,jk) * zdepmin**0.3 + ENDIF + END DO + END DO + END DO + + IF( ln_p4z ) THEN + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! DOC ammonification. Depends on depth, phytoplankton biomass + ! and a limitation term which is supposed to be a parameterization of the bacterial activity. + zremik = xremik * xstep / 1.e-6 * xlimbac(ji,jj,jk) * zdepbac(ji,jj,jk) + zremik = MAX( zremik, 2.74e-4 * xstep ) + ! Ammonification in oxic waters with oxygen consumption + ! ----------------------------------------------------- + zolimit = zremik * ( 1.- nitrfac(ji,jj,jk) ) * trb(ji,jj,jk,jpdoc) + zolimi(ji,jj,jk) = MIN( ( trb(ji,jj,jk,jpoxy) - rtrn ) / o2ut, zolimit ) + ! Ammonification in suboxic waters with denitrification + ! ------------------------------------------------------- + zammonic = zremik * nitrfac(ji,jj,jk) * trb(ji,jj,jk,jpdoc) + denitr(ji,jj,jk) = zammonic * ( 1. - nitrfac2(ji,jj,jk) ) + denitr(ji,jj,jk) = MIN( ( trb(ji,jj,jk,jpno3) - rtrn ) / rdenit, denitr(ji,jj,jk) ) + zoxyremc = zammonic - denitr(ji,jj,jk) + ! + zolimi (ji,jj,jk) = MAX( 0.e0, zolimi (ji,jj,jk) ) + denitr (ji,jj,jk) = MAX( 0.e0, denitr (ji,jj,jk) ) + zoxyremc = MAX( 0.e0, zoxyremc ) + + ! + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zolimi (ji,jj,jk) + denitr(ji,jj,jk) + zoxyremc + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zolimi (ji,jj,jk) + denitr(ji,jj,jk) + zoxyremc + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) - denitr (ji,jj,jk) * rdenit + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) - zolimi (ji,jj,jk) - denitr(ji,jj,jk) - zoxyremc + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - zolimi (ji,jj,jk) * o2ut + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zolimi (ji,jj,jk) + denitr(ji,jj,jk) + zoxyremc + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * ( zolimi(ji,jj,jk) + zoxyremc & + & + ( rdenit + 1.) * denitr(ji,jj,jk) ) + END DO + END DO + END DO + ELSE + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! DOC ammonification. Depends on depth, phytoplankton biomass + ! and a limitation term which is supposed to be a parameterization of the bacterial activity. + ! ----------------------------------------------------------------- + zremik = xstep / 1.e-6 * MAX(0.01, xlimbac(ji,jj,jk)) * zdepbac(ji,jj,jk) + zremik = MAX( zremik, 2.74e-4 * xstep / xremikc ) + + zremikc = xremikc * zremik + zremikn = xremikn / xremikc + zremikp = xremikp / xremikc + + ! Ammonification in oxic waters with oxygen consumption + ! ----------------------------------------------------- + zolimit = zremikc * ( 1.- nitrfac(ji,jj,jk) ) * trb(ji,jj,jk,jpdoc) + zolimic = MAX( 0.e0, MIN( ( trb(ji,jj,jk,jpoxy) - rtrn ) / o2ut, zolimit ) ) + zolimi(ji,jj,jk) = zolimic + zolimin = zremikn * zolimic * trb(ji,jj,jk,jpdon) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + zolimip = zremikp * zolimic * trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + + ! Ammonification in suboxic waters with denitrification + ! ------------------------------------------------------- + zammonic = zremikc * nitrfac(ji,jj,jk) * trb(ji,jj,jk,jpdoc) + denitr(ji,jj,jk) = zammonic * ( 1. - nitrfac2(ji,jj,jk) ) + denitr(ji,jj,jk) = MAX(0., MIN( ( trb(ji,jj,jk,jpno3) - rtrn ) / rdenit, denitr(ji,jj,jk) ) ) + zoxyremc = MAX(0., zammonic - denitr(ji,jj,jk)) + zdenitrn = zremikn * denitr(ji,jj,jk) * trb(ji,jj,jk,jpdon) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + zdenitrp = zremikp * denitr(ji,jj,jk) * trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + zoxyremn = zremikn * zoxyremc * trb(ji,jj,jk,jpdon) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + zoxyremp = zremikp * zoxyremc * trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdoc) + rtrn ) + + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zolimip + zdenitrp + zoxyremp + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zolimin + zdenitrn + zoxyremn + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) - denitr(ji,jj,jk) * rdenit + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) - zolimic - denitr(ji,jj,jk) - zoxyremc + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) - zolimin - zdenitrn - zoxyremn + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) - zolimip - zdenitrp - zoxyremp + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - zolimic * o2ut + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zolimic + denitr(ji,jj,jk) + zoxyremc + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * ( zolimin + zoxyremn + ( rdenit + 1.) * zdenitrn ) + END DO + END DO + END DO + ! + ENDIF + + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! NH4 nitrification to NO3. Ceased for oxygen concentrations + ! below 2 umol/L. Inhibited at strong light + ! ---------------------------------------------------------- + zonitr = nitrif * xstep * trb(ji,jj,jk,jpnh4) * ( 1.- nitrfac(ji,jj,jk) ) & + & / ( 1.+ emoy(ji,jj,jk) ) * ( 1. + fr_i(ji,jj) * emoy(ji,jj,jk) ) + zdenitnh4 = nitrif * xstep * trb(ji,jj,jk,jpnh4) * nitrfac(ji,jj,jk) + zdenitnh4 = MIN( ( trb(ji,jj,jk,jpno3) - rtrn ) / rdenita, zdenitnh4 ) + ! Update of the tracers trends + ! ---------------------------- + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) - zonitr - zdenitnh4 + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + zonitr - rdenita * zdenitnh4 + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - o2nit * zonitr + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2 * rno3 * zonitr + rno3 * ( rdenita - 1. ) * zdenitnh4 + END DO + END DO + END DO + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('rem1')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + ! Bacterial uptake of iron. No iron is available in DOC. So + ! Bacteries are obliged to take up iron from the water. Some + ! studies (especially at Papa) have shown this uptake to be significant + ! ---------------------------------------------------------- + zbactfer = feratb * rfact2 * 0.6_wp / rday * tgfunc(ji,jj,jk) * xlimbacl(ji,jj,jk) & + & * trb(ji,jj,jk,jpfer) / ( xkferb + trb(ji,jj,jk,jpfer) ) & + & * zdepprod(ji,jj,jk) * zdepeff(ji,jj,jk) * zdepbac(ji,jj,jk) + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zbactfer*0.33 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zbactfer*0.25 + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zbactfer*0.08 + zfebact(ji,jj,jk) = zbactfer * 0.33 + blim(ji,jj,jk) = xlimbacl(ji,jj,jk) * zdepbac(ji,jj,jk) / 1.e-6 * zdepprod(ji,jj,jk) + END DO + END DO + END DO + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('rem2')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + + ! Initialization of the array which contains the labile fraction + ! of bSi. Set to a constant in the upper ocean + ! --------------------------------------------------------------- + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zdep = MAX( hmld(ji,jj), heup_01(ji,jj) ) + zsatur = MAX( rtrn, ( sio3eq(ji,jj,jk) - trb(ji,jj,jk,jpsil) ) / ( sio3eq(ji,jj,jk) + rtrn ) ) + zsatur2 = ( 1. + tsn(ji,jj,jk,jp_tem) / 400.)**37 + znusil = 0.225 * ( 1. + tsn(ji,jj,jk,jp_tem) / 15.) * zsatur + 0.775 * zsatur2 * zsatur**9.25 + ! Remineralization rate of BSi depedant on T and saturation + ! --------------------------------------------------------- + IF ( gdept_n(ji,jj,jk) > zdep ) THEN + zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk-1) * EXP( -0.5 * ( xsiremlab - xsirem ) & + & * znusil * e3t_n(ji,jj,jk) / wsbio4(ji,jj,jk) ) + zfacsi(ji,jj,jk) = zfacsib(ji,jj,jk) / ( 1.0 + zfacsib(ji,jj,jk) ) + zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk) * EXP( -0.5 * ( xsiremlab - xsirem ) & + & * znusil * e3t_n(ji,jj,jk) / wsbio4(ji,jj,jk) ) + ENDIF + zsiremin = ( xsiremlab * zfacsi(ji,jj,jk) + xsirem * ( 1. - zfacsi(ji,jj,jk) ) ) * xstep * znusil + zosil = zsiremin * trb(ji,jj,jk,jpgsi) + ! + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) - zosil + tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) + zosil + END DO + END DO + END DO + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('rem3')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + + IF( lk_iomput .AND. knt == nrdttrc ) THEN + zrfact2 = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s + ! + IF( iom_use( "REMIN" ) ) THEN ! Remineralisation rate + zolimi(:,:,jpk) = 0. ; CALL iom_put( "REMIN" , zolimi(:,:,:) * tmask(:,:,:) * zrfact2 ) + ENDIF + CALL iom_put( "DENIT" , denitr(:,:,:) * rdenit * rno3 * tmask(:,:,:) * zrfact2 ) ! Denitrification + IF( iom_use( "BACT" ) ) THEN ! Bacterial biomass + zdepbac(:,:,jpk) = 0. ; CALL iom_put( "BACT", zdepbac(:,:,:) * 1.E6 * tmask(:,:,:) ) + ENDIF + CALL iom_put( "FEBACT" , zfebact(:,:,:) * 1E9 * tmask(:,:,:) * zrfact2 ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_rem') + ! + END SUBROUTINE p4z_rem + + + SUBROUTINE p4z_rem_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_rem_init *** + !! + !! ** Purpose : Initialization of remineralization parameters + !! + !! ** Method : Read the nampisrem namelist and check the parameters + !! called at the first timestep + !! + !! ** input : Namelist nampisrem + !! + !!---------------------------------------------------------------------- + NAMELIST/nampisrem/ xremik, nitrif, xsirem, xsiremlab, xsilab, feratb, xkferb, & + & xremikc, xremikn, xremikp + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_rem_init : Initialization of remineralization parameters' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, nampisrem, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisrem in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, nampisrem, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisrem in configuration namelist' ) + IF(lwm) WRITE( numonp, nampisrem ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist parameters for remineralization, nampisrem' + IF( ln_p4z ) THEN + WRITE(numout,*) ' remineralization rate of DOC xremik =', xremik + ELSE + WRITE(numout,*) ' remineralization rate of DOC xremikc =', xremikc + WRITE(numout,*) ' remineralization rate of DON xremikn =', xremikn + WRITE(numout,*) ' remineralization rate of DOP xremikp =', xremikp + ENDIF + WRITE(numout,*) ' remineralization rate of Si xsirem =', xsirem + WRITE(numout,*) ' fast remineralization rate of Si xsiremlab =', xsiremlab + WRITE(numout,*) ' fraction of labile biogenic silica xsilab =', xsilab + WRITE(numout,*) ' NH4 nitrification rate nitrif =', nitrif + WRITE(numout,*) ' Bacterial Fe/C ratio feratb =', feratb + WRITE(numout,*) ' Half-saturation constant for bact. Fe/C xkferb =', xkferb + ENDIF + ! + denitr(:,:,:) = 0._wp + ! + END SUBROUTINE p4z_rem_init + + + INTEGER FUNCTION p4z_rem_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_rem_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( denitr(jpi,jpj,jpk), STAT=p4z_rem_alloc ) + ! + IF( p4z_rem_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_rem_alloc: failed to allocate arrays' ) + ! + END FUNCTION p4z_rem_alloc + + !!====================================================================== +END MODULE p4zrem diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsbc.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..11102c904d900281165d621d3961a25c013c4d39 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsbc.F90 @@ -0,0 +1,490 @@ +MODULE p4zsbc + !!====================================================================== + !! *** MODULE p4sbc *** + !! TOP : PISCES surface boundary conditions of external inputs of nutrients + !!====================================================================== + !! History : 3.5 ! 2012-07 (O. Aumont, C. Ethe) Original code + !!---------------------------------------------------------------------- + !! p4z_sbc : Read and interpolate time-varying nutrients fluxes + !! p4z_sbc_init : Initialization of p4z_sbc + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE iom ! I/O manager + USE fldread ! time interpolation + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_sbc + PUBLIC p4z_sbc_init + + LOGICAL , PUBLIC :: ln_dust !: boolean for dust input from the atmosphere + LOGICAL , PUBLIC :: ln_solub !: boolean for variable solubility of atmospheric iron + LOGICAL , PUBLIC :: ln_river !: boolean for river input of nutrients + LOGICAL , PUBLIC :: ln_ndepo !: boolean for atmospheric deposition of N + LOGICAL , PUBLIC :: ln_ironsed !: boolean for Fe input from sediments + LOGICAL , PUBLIC :: ln_hydrofe !: boolean for Fe input from hydrothermal vents + REAL(wp), PUBLIC :: sedfeinput !: Coastal release of Iron + REAL(wp), PUBLIC :: dustsolub !: Solubility of the dust + REAL(wp), PUBLIC :: mfrac !: Mineral Content of the dust + REAL(wp), PUBLIC :: icefeinput !: Iron concentration in sea ice + REAL(wp), PUBLIC :: wdust !: Sinking speed of the dust + REAL(wp), PUBLIC :: nitrfix !: Nitrogen fixation rate + REAL(wp), PUBLIC :: diazolight !: Nitrogen fixation sensitivty to light + REAL(wp), PUBLIC :: concfediaz !: Fe half-saturation Cste for diazotrophs + REAL(wp) :: hratio !: Fe:3He ratio assumed for vent iron supply + REAL(wp) :: distcoast !: Distance off the coast for Iron from sediments + REAL(wp), PUBLIC :: lgw_rath !: Weak ligand ratio from hydro sources + + LOGICAL , PUBLIC :: ll_sbc + LOGICAL :: ll_solub + + INTEGER , PARAMETER :: jpriv = 7 !: Maximum number of river input fields + INTEGER , PARAMETER :: jr_dic = 1 !: index of dissolved inorganic carbon + INTEGER , PARAMETER :: jr_doc = 2 !: index of dissolved organic carbon + INTEGER , PARAMETER :: jr_din = 3 !: index of dissolved inorganic nitrogen + INTEGER , PARAMETER :: jr_don = 4 !: index of dissolved organic nitrogen + INTEGER , PARAMETER :: jr_dip = 5 !: index of dissolved inorganic phosporus + INTEGER , PARAMETER :: jr_dop = 6 !: index of dissolved organic phosphorus + INTEGER , PARAMETER :: jr_dsi = 7 !: index of dissolved silicate + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_dust ! structure of input dust + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_solub ! structure of input dust + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_river ! structure of input riverdic + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ndepo ! structure of input nitrogen deposition + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ironsed ! structure of input iron from sediment + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_hydrofe ! structure of input iron from hydrothermal vents + + INTEGER , PARAMETER :: nbtimes = 365 ! maximum number of times record in a file + INTEGER :: ntimes_dust, ntimes_riv, ntimes_ndep ! number of time steps in a file + INTEGER :: ntimes_solub, ntimes_hydro ! number of time steps in a file + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dust , solub !: dust fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rivdic, rivalk !: river input fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rivdin, rivdip !: river input fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rivdon, rivdop !: river input fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rivdoc !: river input fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rivdsi !: river input fields + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nitdep !: atmospheric N deposition + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ironsed !: Coastal supply of iron + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hydrofe !: Hydrothermal vent supply of iron + + REAL(wp), PUBLIC :: sedsilfrac, sedcalfrac + REAL(wp), PUBLIC :: rivalkinput, rivdicinput + REAL(wp), PUBLIC :: rivdininput, rivdipinput, rivdsiinput + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zsbc.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_sbc( kt ) + !!---------------------------------------------------------------------- + !! *** routine p4z_sbc *** + !! + !! ** purpose : read and interpolate the external sources of nutrients + !! + !! ** method : read the files and interpolate the appropriate variables + !! + !! ** input : external netcdf files + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji, jj + REAL(wp) :: zcoef, zyyss + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_sbc') + ! + ! Compute dust at nit000 or only if there is more than 1 time record in dust file + IF( ln_dust ) THEN + IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_dust > 1 ) ) THEN + CALL fld_read( kt, 1, sf_dust ) + dust(:,:) = MAX( rtrn, sf_dust(1)%fnow(:,:,1) ) * ( 1.0 - fr_i(:,:) ) + ENDIF + ENDIF + ! + IF( ll_solub ) THEN + IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_solub > 1 ) ) THEN + CALL fld_read( kt, 1, sf_solub ) + solub(:,:) = sf_solub(1)%fnow(:,:,1) + ENDIF + ENDIF + + ! N/P and Si releases due to coastal rivers + ! Compute river at nit000 or only if there is more than 1 time record in river file + ! ----------------------------------------- + IF( ln_river ) THEN + IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_riv > 1 ) ) THEN + CALL fld_read( kt, 1, sf_river ) + IF( ln_p4z ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) + rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & + & * 1.E3 / ( 12. * zcoef + rtrn ) + rivdic(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & + & * 1.E3 / ( 12. * zcoef + rtrn ) + rivdin(ji,jj) = sf_river(jr_din)%fnow(ji,jj,1) & + & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) + rivdip(ji,jj) = sf_river(jr_dip)%fnow(ji,jj,1) & + & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) + rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & + & * 1.E3 / ( 28.1 * zcoef + rtrn ) + rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & + & * 1.E3 / ( 12. * zcoef + rtrn ) + END DO + END DO + ELSE ! ln_p5z + DO jj = 1, jpj + DO ji = 1, jpi + zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) + rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & + & * 1.E3 / ( 12. * zcoef + rtrn ) + rivdic(ji,jj) = ( sf_river(jr_dic)%fnow(ji,jj,1) ) & + & * 1.E3 / ( 12. * zcoef + rtrn ) * tmask(ji,jj,1) + rivdin(ji,jj) = ( sf_river(jr_din)%fnow(ji,jj,1) ) & + & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) + rivdip(ji,jj) = ( sf_river(jr_dip)%fnow(ji,jj,1) ) & + & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) + rivdon(ji,jj) = ( sf_river(jr_don)%fnow(ji,jj,1) ) & + & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) + rivdop(ji,jj) = ( sf_river(jr_dop)%fnow(ji,jj,1) ) & + & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) + rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & + & * 1.E3 / ( 28.1 * zcoef + rtrn ) + rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & + & * 1.E3 / ( 12. * zcoef + rtrn ) + END DO + END DO + ENDIF + ENDIF + ENDIF + + ! Compute N deposition at nit000 or only if there is more than 1 time record in N deposition file + IF( ln_ndepo ) THEN + IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_ndep > 1 ) ) THEN + zcoef = 14. * rno3 + CALL fld_read( kt, 1, sf_ndepo ) + nitdep(:,:) = MAX( rtrn, sf_ndepo(1)%fnow(:,:,1) / zcoef / e3t_n(:,:,1) ) + ENDIF + IF( .NOT.ln_linssh ) THEN + zcoef = 14. * rno3 + nitdep(:,:) = MAX( rtrn, sf_ndepo(1)%fnow(:,:,1) / zcoef / e3t_n(:,:,1) ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_sbc') + ! + END SUBROUTINE p4z_sbc + + + SUBROUTINE p4z_sbc_init + !!---------------------------------------------------------------------- + !! *** routine p4z_sbc_init *** + !! + !! ** purpose : initialization of the external sources of nutrients + !! + !! ** method : read the files and compute the budget + !! called at the first timestep (nittrc000) + !! + !! ** input : external netcdf files + !! + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jm, ifpr + INTEGER :: ii0, ii1, ij0, ij1 + INTEGER :: numdust, numsolub, numriv, numiron, numdepo, numhydro + INTEGER :: ierr, ierr1, ierr2, ierr3 + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ik50 ! last level where depth less than 50 m + INTEGER :: isrow ! index for ORCA1 starting row + REAL(wp) :: zexpide, zdenitide, zmaskt, zsurfc, zsurfp,ze3t, ze3t2, zcslp + REAL(wp) :: ztimes_dust, ztimes_riv, ztimes_ndep + REAL(wp), DIMENSION(:), ALLOCATABLE :: rivinput + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zriver, zcmask + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N), DIMENSION(jpriv) :: slf_river ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_dust, sn_solub, sn_ndepo, sn_ironsed, sn_hydrofe ! informations about the fields to be read + TYPE(FLD_N) :: sn_riverdoc, sn_riverdic, sn_riverdsi ! informations about the fields to be read + TYPE(FLD_N) :: sn_riverdin, sn_riverdon, sn_riverdip, sn_riverdop + !! + NAMELIST/nampissbc/cn_dir, sn_dust, sn_solub, sn_riverdic, sn_riverdoc, sn_riverdin, sn_riverdon, & + & sn_riverdip, sn_riverdop, sn_riverdsi, sn_ndepo, sn_ironsed, sn_hydrofe, & + & ln_dust, ln_solub, ln_river, ln_ndepo, ln_ironsed, ln_ironice, ln_hydrofe, & + & sedfeinput, distcoast, dustsolub, icefeinput, wdust, mfrac, nitrfix, diazolight, concfediaz, & + & hratio, lgw_rath + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_sbc_init : initialization of the external sources of nutrients ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! !* set file information + REWIND( numnatp_ref ) ! Namelist nampissbc in reference namelist : Pisces external sources of nutrients + READ ( numnatp_ref, nampissbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampissbc in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampissbc in configuration namelist : Pisces external sources of nutrients + READ ( numnatp_cfg, nampissbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampissbc in configuration namelist' ) + IF(lwm) WRITE ( numonp, nampissbc ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist : nampissbc ' + WRITE(numout,*) ' dust input from the atmosphere ln_dust = ', ln_dust + WRITE(numout,*) ' Variable solubility of iron input ln_solub = ', ln_solub + WRITE(numout,*) ' river input of nutrients ln_river = ', ln_river + WRITE(numout,*) ' atmospheric deposition of n ln_ndepo = ', ln_ndepo + WRITE(numout,*) ' Fe input from sediments ln_ironsed = ', ln_ironsed + WRITE(numout,*) ' Fe input from seaice ln_ironice = ', ln_ironice + WRITE(numout,*) ' fe input from hydrothermal vents ln_hydrofe = ', ln_hydrofe + WRITE(numout,*) ' coastal release of iron sedfeinput = ', sedfeinput + WRITE(numout,*) ' distance off the coast distcoast = ', distcoast + WRITE(numout,*) ' solubility of the dust dustsolub = ', dustsolub + WRITE(numout,*) ' Mineral Fe content of the dust mfrac = ', mfrac + WRITE(numout,*) ' Iron concentration in sea ice icefeinput = ', icefeinput + WRITE(numout,*) ' sinking speed of the dust wdust = ', wdust + WRITE(numout,*) ' nitrogen fixation rate nitrfix = ', nitrfix + WRITE(numout,*) ' nitrogen fixation sensitivty to light diazolight = ', diazolight + WRITE(numout,*) ' Fe half-saturation cste for diazotrophs concfediaz = ', concfediaz + WRITE(numout,*) ' Fe to 3He ratio assumed for vent iron supply hratio = ', hratio + IF( ln_ligand ) THEN + WRITE(numout,*) ' Weak ligand ratio from sed hydro sources lgw_rath = ', lgw_rath + ENDIF + END IF + + IF( ln_dust .OR. ln_river .OR. ln_ndepo ) THEN ; ll_sbc = .TRUE. + ELSE ; ll_sbc = .FALSE. + ENDIF + + IF( ln_dust .AND. ln_solub ) THEN ; ll_solub = .TRUE. + ELSE ; ll_solub = .FALSE. + ENDIF + + ! dust input from the atmosphere + ! ------------------------------ + IF( ln_dust ) THEN + ! + IF(lwp) WRITE(numout,*) ' initialize dust input from atmosphere ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + ! + ALLOCATE( dust(jpi,jpj) ) ! allocation + ! + ALLOCATE( sf_dust(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_init: unable to allocate sf_dust structure' ) + ! + CALL fld_fill( sf_dust, (/ sn_dust /), cn_dir, 'p4z_sed_init', 'Atmospheric dust deposition', 'nampissed' ) + ALLOCATE( sf_dust(1)%fnow(jpi,jpj,1) ) + IF( sn_dust%ln_tint ) ALLOCATE( sf_dust(1)%fdta(jpi,jpj,1,2) ) + ! + IF( Agrif_Root() ) THEN ! Only on the master grid + ! Get total input dust ; need to compute total atmospheric supply of Si in a year + CALL iom_open ( TRIM( sn_dust%clname ) , numdust ) + ntimes_dust = iom_getszuld( numdust ) ! get number of record in file + END IF + END IF + + ! Solubility of dust deposition of iron + ! Only if ln_dust and ln_solubility set to true (ll_solub = .true.) + ! ----------------------------------------------------------------- + IF( ll_solub ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ll_solub=T , initialize variable solubility of Fe ' + ! + ALLOCATE( solub(jpi,jpj) ) ! allocation + ! + ALLOCATE( sf_solub(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_init: unable to allocate sf_solub structure' ) + ! + CALL fld_fill( sf_solub, (/ sn_solub /), cn_dir, 'p4z_sed_init', 'Solubility of atm. iron ', 'nampissed' ) + ALLOCATE( sf_solub(1)%fnow(jpi,jpj,1) ) + IF( sn_solub%ln_tint ) ALLOCATE( sf_solub(1)%fdta(jpi,jpj,1,2) ) + ! get number of record in file + CALL iom_open ( TRIM( sn_solub%clname ) , numsolub ) + ntimes_solub = iom_getszuld( numsolub ) ! get number of record in file + CALL iom_close( numsolub ) + ENDIF + + ! nutrient input from rivers + ! -------------------------- + IF( ln_river ) THEN + ! + slf_river(jr_dic) = sn_riverdic ; slf_river(jr_doc) = sn_riverdoc ; slf_river(jr_din) = sn_riverdin + slf_river(jr_don) = sn_riverdon ; slf_river(jr_dip) = sn_riverdip ; slf_river(jr_dop) = sn_riverdop + slf_river(jr_dsi) = sn_riverdsi + ! + ALLOCATE( rivdic(jpi,jpj), rivalk(jpi,jpj), rivdin(jpi,jpj), rivdip(jpi,jpj), rivdsi(jpi,jpj), rivdoc(jpi,jpj) ) + IF( ln_p5z ) ALLOCATE( rivdon(jpi,jpj), rivdop(jpi,jpj) ) + ! + ALLOCATE( sf_river(jpriv), rivinput(jpriv), STAT=ierr1 ) !* allocate and fill sf_river (forcing structure) with sn_river_ + rivinput(:) = 0._wp + + IF( ierr1 > 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_init: unable to allocate sf_irver structure' ) + ! + CALL fld_fill( sf_river, slf_river, cn_dir, 'p4z_sed_init', 'Input from river ', 'nampissed' ) + DO ifpr = 1, jpriv + ALLOCATE( sf_river(ifpr)%fnow(jpi,jpj,1 ) ) + IF( slf_river(ifpr)%ln_tint ) ALLOCATE( sf_river(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + IF( Agrif_Root() ) THEN ! Only on the master grid + ! Get total input rivers ; need to compute total river supply in a year + DO ifpr = 1, jpriv + CALL iom_open ( TRIM( slf_river(ifpr)%clname ), numriv ) + ntimes_riv = iom_getszuld( numriv ) + ALLOCATE( zriver(jpi,jpj,ntimes_riv) ) + DO jm = 1, ntimes_riv + CALL iom_get( numriv, jpdom_data, TRIM( slf_river(ifpr)%clvar ), zriver(:,:,jm), jm ) + END DO + CALL iom_close( numriv ) + ztimes_riv = 1._wp / REAL(ntimes_riv, wp) + DO jm = 1, ntimes_riv + rivinput(ifpr) = rivinput(ifpr) + glob_sum( 'p4zsbc', zriver(:,:,jm) * tmask(:,:,1) * ztimes_riv ) + END DO + DEALLOCATE( zriver) + END DO + ! N/P and Si releases due to coastal rivers + ! ----------------------------------------- + rivdicinput = (rivinput(jr_dic) + rivinput(jr_doc) ) * 1E3 / 12._wp + rivdininput = (rivinput(jr_din) + rivinput(jr_don) ) * 1E3 / rno3 / 14._wp + rivdipinput = (rivinput(jr_dip) + rivinput(jr_dop) ) * 1E3 / po4r / 31._wp + rivdsiinput = rivinput(jr_dsi) * 1E3 / 28.1_wp + rivalkinput = rivinput(jr_dic) * 1E3 / 12._wp + ! + ENDIF + ELSE + rivdicinput = 0._wp + rivdininput = 0._wp + rivdipinput = 0._wp + rivdsiinput = 0._wp + rivalkinput = 0._wp + END IF + ! nutrient input from dust + ! ------------------------ + IF( ln_ndepo ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ln_ndepo=T , initialize the nutrient input by dust from NetCDF file' + ! + ALLOCATE( nitdep(jpi,jpj) ) ! allocation + ! + ALLOCATE( sf_ndepo(1), STAT=ierr3 ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierr3 > 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_init: unable to allocate sf_ndepo structure' ) + ! + CALL fld_fill( sf_ndepo, (/ sn_ndepo /), cn_dir, 'p4z_sed_init', 'Nutrient atmospheric depositon ', 'nampissed' ) + ALLOCATE( sf_ndepo(1)%fnow(jpi,jpj,1) ) + IF( sn_ndepo%ln_tint ) ALLOCATE( sf_ndepo(1)%fdta(jpi,jpj,1,2) ) + ! + IF( Agrif_Root() ) THEN ! Only on the master grid + ! Get total input dust ; need to compute total atmospheric supply of N in a year + CALL iom_open ( TRIM( sn_ndepo%clname ), numdepo ) + ntimes_ndep = iom_getszuld( numdepo ) + ENDIF + ENDIF + + ! coastal and island masks + ! ------------------------ + IF( ln_ironsed ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ln_ironsed=T , computation of an island mask to enhance coastal supply of iron' + ! + ALLOCATE( ironsed(jpi,jpj,jpk) ) ! allocation + ! + CALL iom_open ( TRIM( sn_ironsed%clname ), numiron ) + ALLOCATE( zcmask(jpi,jpj,jpk) ) + CALL iom_get ( numiron, jpdom_data, TRIM( sn_ironsed%clvar ), zcmask(:,:,:), 1 ) + CALL iom_close( numiron ) + ! + ik50 = 5 ! last level where depth less than 50 m + DO jk = jpkm1, 1, -1 + IF( gdept_1d(jk) > 50. ) ik50 = jk - 1 + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Level corresponding to 50m depth ', ik50,' ', gdept_1d(ik50+1) + DO jk = 1, ik50 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ze3t = e3t_0(ji,jj,jk) + zsurfc = e1u(ji,jj) * ( 1. - umask(ji ,jj ,jk) ) & + + e1u(ji,jj) * ( 1. - umask(ji-1,jj ,jk) ) & + + e2v(ji,jj) * ( 1. - vmask(ji ,jj ,jk) ) & + + e2v(ji,jj) * ( 1. - vmask(ji ,jj-1,jk) ) + zsurfp = zsurfc * ze3t / e1e2t(ji,jj) + ! estimation of the coastal slope : 5 km off the coast + ze3t2 = ze3t * ze3t + zcslp = SQRT( ( distcoast*distcoast + ze3t2 ) / ze3t2 ) + ! + zcmask(ji,jj,jk) = zcmask(ji,jj,jk) + zcslp * zsurfp + END DO + END DO + END DO + ! + CALL lbc_lnk( 'p4zsbc', zcmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged) + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + zexpide = MIN( 8.,( gdept_n(ji,jj,jk) / 500. )**(-1.5) ) + zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 + zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) + END DO + END DO + END DO + ! Coastal supply of iron + ! ------------------------- + ironsed(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ironsed(:,:,jk) = sedfeinput * zcmask(:,:,jk) / ( e3t_0(:,:,jk) * rday ) + END DO + DEALLOCATE( zcmask) + ENDIF + ! + ! Iron from Hydrothermal vents + ! ------------------------ + IF( ln_hydrofe ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ln_hydrofe=T , Input of iron from hydrothermal vents' + ! + ALLOCATE( hydrofe(jpi,jpj,jpk) ) ! allocation + ! + CALL iom_open ( TRIM( sn_hydrofe%clname ), numhydro ) + CALL iom_get ( numhydro, jpdom_data, TRIM( sn_hydrofe%clvar ), hydrofe(:,:,:), 1 ) + CALL iom_close( numhydro ) + ! + DO jk = 1, jpk + hydrofe(:,:,jk) = ( hydrofe(:,:,jk) * hratio ) / ( e1e2t(:,:) * e3t_0(:,:,jk) * ryyss + rtrn ) / 1000._wp + ENDDO + ! + ENDIF + ! + IF( ll_sbc ) CALL p4z_sbc( nit000 ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Total input of elements from river supply' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' N Supply : ', rivdininput*rno3*1E3/1E12*14.,' TgN/yr' + WRITE(numout,*) ' Si Supply : ', rivdsiinput*1E3/1E12*28.1 ,' TgSi/yr' + WRITE(numout,*) ' P Supply : ', rivdipinput*1E3*po4r/1E12*31.,' TgP/yr' + WRITE(numout,*) ' Alk Supply : ', rivalkinput*1E3/1E12 ,' Teq/yr' + WRITE(numout,*) ' DIC Supply : ', rivdicinput*1E3*12./1E12 ,' TgC/yr' + WRITE(numout,*) + ENDIF + ! + sedsilfrac = 0.03 ! percentage of silica loss in the sediments + sedcalfrac = 0.6 ! percentage of calcite loss in the sediments + ! + END SUBROUTINE p4z_sbc_init + + !!====================================================================== +END MODULE p4zsbc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..08b7db4da26cd435ad7e6953d331cdf484d41391 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsed.F90 @@ -0,0 +1,499 @@ +MODULE p4zsed + !!====================================================================== + !! *** MODULE p4sed *** + !! TOP : PISCES Compute loss of organic matter in the sediments + !!====================================================================== + !! History : 1.0 ! 2004-03 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (C. Ethe) USE of fldread + !! 3.5 ! 2012-07 (O. Aumont) improvment of river input of nutrients + !!---------------------------------------------------------------------- + !! p4z_sed : Compute loss of organic matter in the sediments + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim ! Co-limitations of differents nutrients + USE p4zsbc ! External source of nutrients + USE p4zint ! interpolation and computation of various fields + USE sed ! Sediment module + USE iom ! I/O manager + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_sed + PUBLIC p4z_sed_alloc + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nitrpot !: Nitrogen fixation + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ) :: sdenit !: Nitrate reduction in the sediments + REAL(wp) :: r1_rday !: inverse of rday + LOGICAL, SAVE :: lk_sed + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zsed.F90 14588 2021-03-05 07:42:07Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_sed( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_sed *** + !! + !! ** Purpose : Compute loss of organic matter in the sediments. This + !! is by no way a sediment model. The loss is simply + !! computed to balance the inout from rivers and dust + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt, knt ! ocean time step + INTEGER :: ji, jj, jk, ikt + REAL(wp) :: zrivalk, zrivsil, zrivno3 + REAL(wp) :: zwflux, zlim, zfact, zfactcal + REAL(wp) :: zo2, zno3, zflx, zpdenit, z1pdenit, zolimit + REAL(wp) :: zsiloss, zcaloss, zws3, zws4, zwsc, zdep + REAL(wp) :: zwstpoc, zwstpon, zwstpop + REAL(wp) :: ztrfer, ztrpo4s, ztrdp, zwdust, zmudia, ztemp + REAL(wp) :: xdiano3, xdianh4 + ! + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj ) :: zdenit2d, zbureff, zwork + REAL(wp), DIMENSION(jpi,jpj ) :: zwsbio3, zwsbio4 + REAL(wp), DIMENSION(jpi,jpj ) :: zsedcal, zsedsi, zsedc + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsoufer, zlight + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrpo4, ztrdop, zirondep, zpdep + REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zsidep, zironice + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_sed') + ! + IF( kt == nittrc000 .AND. knt == 1 ) THEN + r1_rday = 1. / rday + IF (ln_sediment .AND. ln_sed_2way) THEN + lk_sed = .TRUE. + ELSE + lk_sed = .FALSE. + ENDIF + ENDIF + ! + IF( kt == nittrc000 .AND. knt == 1 ) r1_rday = 1. / rday + ! + ! Allocate temporary workspace + ALLOCATE( ztrpo4(jpi,jpj,jpk) ) + IF( ln_p5z ) ALLOCATE( ztrdop(jpi,jpj,jpk) ) + + zdenit2d(:,:) = 0.e0 + zbureff (:,:) = 0.e0 + zwork (:,:) = 0.e0 + zsedsi (:,:) = 0.e0 + zsedcal (:,:) = 0.e0 + zsedc (:,:) = 0.e0 + + ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. + ! ---------------------------------------------------- + IF( ln_ironice ) THEN + ! + ALLOCATE( zironice(jpi,jpj) ) + ! + DO jj = 1, jpj + DO ji = 1, jpi + zdep = rfact2 / e3t_n(ji,jj,1) + zwflux = fmmflx(ji,jj) / 1000._wp + zironice(ji,jj) = MAX( -0.99 * trb(ji,jj,1,jpfer), -zwflux * icefeinput * zdep ) + END DO + END DO + ! + tra(:,:,1,jpfer) = tra(:,:,1,jpfer) + zironice(:,:) + ! + IF( lk_iomput .AND. knt == nrdttrc ) & + & CALL iom_put( "Ironice", zironice(:,:) * 1.e+3 * rfact2r * e3t_n(:,:,1) * tmask(:,:,1) ) ! iron flux from ice + ! + DEALLOCATE( zironice ) + ! + ENDIF + + ! Add the external input of nutrients from dust deposition + ! ---------------------------------------------------------- + IF( ln_dust ) THEN + ! + ALLOCATE( zsidep(jpi,jpj), zpdep(jpi,jpj,jpk), zirondep(jpi,jpj,jpk) ) + ! ! Iron and Si deposition at the surface + IF( ln_solub ) THEN + zirondep(:,:,1) = solub(:,:) * dust(:,:) * mfrac * rfact2 / e3t_n(:,:,1) / 55.85 + 3.e-10 * r1_ryyss + ELSE + zirondep(:,:,1) = dustsolub * dust(:,:) * mfrac * rfact2 / e3t_n(:,:,1) / 55.85 + 3.e-10 * r1_ryyss + ENDIF + zsidep(:,:) = 8.8 * 0.075 * dust(:,:) * mfrac * rfact2 / e3t_n(:,:,1) / 28.1 + zpdep (:,:,1) = 0.1 * 0.021 * dust(:,:) * mfrac * rfact2 / e3t_n(:,:,1) / 31. / po4r + ! ! Iron solubilization of particles in the water column + ! ! dust in kg/m2/s ---> 1/55.85 to put in mol/Fe ; wdust in m/j + zwdust = 0.03 * rday / ( wdust * 55.85 ) / ( 270. * rday ) + DO jk = 2, jpkm1 + zirondep(:,:,jk) = dust(:,:) * mfrac * zwdust * rfact2 * EXP( -gdept_n(:,:,jk) / 540. ) + zpdep (:,:,jk) = zirondep(:,:,jk) * 0.023 + END DO + ! ! Iron solubilization of particles in the water column + tra(:,:,1,jpsil) = tra(:,:,1,jpsil) + zsidep (:,:) + DO jk = 1, jpkm1 + tra(:,:,jk,jppo4) = tra(:,:,jk,jppo4) + zpdep (:,:,jk) + tra(:,:,jk,jpfer) = tra(:,:,jk,jpfer) + zirondep(:,:,jk) + ENDDO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "Irondep", zirondep(:,:,1) * 1.e+3 * rfact2r * e3t_n(:,:,1) * tmask(:,:,1) ) ! surface downward dust depo of iron + CALL iom_put( "pdust" , dust(:,:) / ( wdust * rday ) * tmask(:,:,1) ) ! dust concentration at surface + ENDIF + DEALLOCATE( zsidep, zpdep, zirondep ) + ! + ENDIF + + ! Add the external input of nutrients from river + ! ---------------------------------------------------------- + IF( ln_river ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, nk_rnf(ji,jj) + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + rivdip(ji,jj) * rfact2 + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + rivdin(ji,jj) * rfact2 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + rivdic(ji,jj) * 5.e-5 * rfact2 + tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) + rivdsi(ji,jj) * rfact2 + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + rivdic(ji,jj) * rfact2 + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + ( rivalk(ji,jj) - rno3 * rivdin(ji,jj) ) * rfact2 + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + rivdoc(ji,jj) * rfact2 + ENDDO + ENDDO + ENDDO + IF (ln_ligand) THEN + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, nk_rnf(ji,jj) + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + rivdic(ji,jj) * 5.e-5 * rfact2 + ENDDO + ENDDO + ENDDO + ENDIF + IF( ln_p5z ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, nk_rnf(ji,jj) + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + rivdop(ji,jj) * rfact2 + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + rivdon(ji,jj) * rfact2 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + ! Add the external input of nutrients from nitrogen deposition + ! ---------------------------------------------------------- + IF( ln_ndepo ) THEN + tra(:,:,1,jpno3) = tra(:,:,1,jpno3) + nitdep(:,:) * rfact2 + tra(:,:,1,jptal) = tra(:,:,1,jptal) - rno3 * nitdep(:,:) * rfact2 + ENDIF + + ! Add the external input of iron from hydrothermal vents + ! ------------------------------------------------------ + IF( ln_hydrofe ) THEN + tra(:,:,:,jpfer) = tra(:,:,:,jpfer) + hydrofe(:,:,:) * rfact2 + IF( ln_ligand ) THEN + tra(:,:,:,jplgw) = tra(:,:,:,jplgw) + ( hydrofe(:,:,:) * lgw_rath ) * rfact2 + ENDIF + ! + IF( lk_iomput .AND. knt == nrdttrc ) & + & CALL iom_put( "HYDR", hydrofe(:,:,:) * 1.e+3 * tmask(:,:,:) ) ! hydrothermal iron input + ENDIF + + ! OA: Warning, the following part is necessary to avoid CFL problems above the sediments + ! -------------------------------------------------------------------- + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = e3t_n(ji,jj,ikt) / xstep + zwsbio4(ji,jj) = MIN( 0.99 * zdep, wsbio4(ji,jj,ikt) ) + zwsbio3(ji,jj) = MIN( 0.99 * zdep, wsbio3(ji,jj,ikt) ) + END DO + END DO + ! + IF( .NOT.lk_sed ) THEN +! + ! Add the external input of iron from sediment mobilization + ! ------------------------------------------------------ + IF( ln_ironsed ) THEN + tra(:,:,:,jpfer) = tra(:,:,:,jpfer) + ironsed(:,:,:) * rfact2 + ! + IF( lk_iomput .AND. knt == nrdttrc ) & + & CALL iom_put( "Ironsed", ironsed(:,:,:) * 1.e+3 * tmask(:,:,:) ) ! iron inputs from sediments + ENDIF + + ! Computation of the sediment denitrification proportion: The metamodel from midlleburg (2006) is being used + ! Computation of the fraction of organic matter that is permanently buried from Dunne's model + ! ------------------------------------------------------- + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,1) == 1 ) THEN + ikt = mbkt(ji,jj) + zflx = ( trb(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj) & + & + trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) ) * 1E3 * 1E6 / 1E4 + zflx = LOG10( MAX( 1E-3, zflx ) ) + zo2 = LOG10( MAX( 10. , trb(ji,jj,ikt,jpoxy) * 1E6 ) ) + zno3 = LOG10( MAX( 1. , trb(ji,jj,ikt,jpno3) * 1E6 * rno3 ) ) + zdep = LOG10( gdepw_n(ji,jj,ikt+1) ) + zdenit2d(ji,jj) = -2.2567 - 1.185 * zflx - 0.221 * zflx**2 - 0.3995 * zno3 * zo2 + 1.25 * zno3 & + & + 0.4721 * zo2 - 0.0996 * zdep + 0.4256 * zflx * zo2 + zdenit2d(ji,jj) = 10.0**( zdenit2d(ji,jj) ) + ! + zflx = ( trb(ji,jj,ikt,jpgoc) * zwsbio4(ji,jj) & + & + trb(ji,jj,ikt,jppoc) * zwsbio3(ji,jj) ) * 1E6 + zbureff(ji,jj) = 0.013 + 0.53 * zflx**2 / ( 7.0 + zflx )**2 + ENDIF + END DO + END DO + ! + ENDIF + + ! This loss is scaled at each bottom grid cell for equilibrating the total budget of silica in the ocean. + ! Thus, the amount of silica lost in the sediments equal the supply at the surface (dust+rivers) + ! ------------------------------------------------------ + IF( .NOT.lk_sed ) zrivsil = 1._wp - sedsilfrac + + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = xstep / e3t_n(ji,jj,ikt) + zwsc = zwsbio4(ji,jj) * zdep + zsiloss = trb(ji,jj,ikt,jpgsi) * zwsc + zcaloss = trb(ji,jj,ikt,jpcal) * zwsc + ! + tra(ji,jj,ikt,jpgsi) = tra(ji,jj,ikt,jpgsi) - zsiloss + tra(ji,jj,ikt,jpcal) = tra(ji,jj,ikt,jpcal) - zcaloss + END DO + END DO + ! + IF( .NOT.lk_sed ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = xstep / e3t_n(ji,jj,ikt) + zwsc = zwsbio4(ji,jj) * zdep + zsiloss = trb(ji,jj,ikt,jpgsi) * zwsc + zcaloss = trb(ji,jj,ikt,jpcal) * zwsc + tra(ji,jj,ikt,jpsil) = tra(ji,jj,ikt,jpsil) + zsiloss * zrivsil + ! + zfactcal = MIN( excess(ji,jj,ikt), 0.2 ) + zfactcal = MIN( 1., 1.3 * ( 0.2 - zfactcal ) / ( 0.4 - zfactcal ) ) + zrivalk = sedcalfrac * zfactcal + tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 + tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk + zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss * e3t_n(ji,jj,ikt) + zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss * e3t_n(ji,jj,ikt) + END DO + END DO + ENDIF + ! + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = xstep / e3t_n(ji,jj,ikt) + zws4 = zwsbio4(ji,jj) * zdep + zws3 = zwsbio3(ji,jj) * zdep + tra(ji,jj,ikt,jpgoc) = tra(ji,jj,ikt,jpgoc) - trb(ji,jj,ikt,jpgoc) * zws4 + tra(ji,jj,ikt,jppoc) = tra(ji,jj,ikt,jppoc) - trb(ji,jj,ikt,jppoc) * zws3 + tra(ji,jj,ikt,jpbfe) = tra(ji,jj,ikt,jpbfe) - trb(ji,jj,ikt,jpbfe) * zws4 + tra(ji,jj,ikt,jpsfe) = tra(ji,jj,ikt,jpsfe) - trb(ji,jj,ikt,jpsfe) * zws3 + END DO + END DO + ! + IF( ln_p5z ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = xstep / e3t_n(ji,jj,ikt) + zws4 = zwsbio4(ji,jj) * zdep + zws3 = zwsbio3(ji,jj) * zdep + tra(ji,jj,ikt,jpgon) = tra(ji,jj,ikt,jpgon) - trb(ji,jj,ikt,jpgon) * zws4 + tra(ji,jj,ikt,jppon) = tra(ji,jj,ikt,jppon) - trb(ji,jj,ikt,jppon) * zws3 + tra(ji,jj,ikt,jpgop) = tra(ji,jj,ikt,jpgop) - trb(ji,jj,ikt,jpgop) * zws4 + tra(ji,jj,ikt,jppop) = tra(ji,jj,ikt,jppop) - trb(ji,jj,ikt,jppop) * zws3 + END DO + END DO + ENDIF + + IF( .NOT.lk_sed ) THEN + ! The 0.5 factor in zpdenit is to avoid negative NO3 concentration after + ! denitrification in the sediments. Not very clever, but simpliest option. + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = xstep / e3t_n(ji,jj,ikt) + zws4 = zwsbio4(ji,jj) * zdep + zws3 = zwsbio3(ji,jj) * zdep + zrivno3 = 1. - zbureff(ji,jj) + zwstpoc = trb(ji,jj,ikt,jpgoc) * zws4 + trb(ji,jj,ikt,jppoc) * zws3 + zpdenit = MIN( 0.5 * ( trb(ji,jj,ikt,jpno3) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3 ) + z1pdenit = zwstpoc * zrivno3 - zpdenit + zolimit = MIN( ( trb(ji,jj,ikt,jpoxy) - rtrn ) / o2ut, z1pdenit * ( 1.- nitrfac(ji,jj,ikt) ) ) + tra(ji,jj,ikt,jpdoc) = tra(ji,jj,ikt,jpdoc) + z1pdenit - zolimit + tra(ji,jj,ikt,jppo4) = tra(ji,jj,ikt,jppo4) + zpdenit + zolimit + tra(ji,jj,ikt,jpnh4) = tra(ji,jj,ikt,jpnh4) + zpdenit + zolimit + tra(ji,jj,ikt,jpno3) = tra(ji,jj,ikt,jpno3) - rdenit * zpdenit + tra(ji,jj,ikt,jpoxy) = tra(ji,jj,ikt,jpoxy) - zolimit * o2ut + tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * zpdenit ) + tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + sdenit(ji,jj) = rdenit * zpdenit * e3t_n(ji,jj,ikt) + zsedc(ji,jj) = (1. - zrivno3) * zwstpoc * e3t_n(ji,jj,ikt) + IF( ln_p5z ) THEN + zwstpop = trb(ji,jj,ikt,jpgop) * zws4 + trb(ji,jj,ikt,jppop) * zws3 + zwstpon = trb(ji,jj,ikt,jpgon) * zws4 + trb(ji,jj,ikt,jppon) * zws3 + tra(ji,jj,ikt,jpdon) = tra(ji,jj,ikt,jpdon) + ( z1pdenit - zolimit ) * zwstpon / (zwstpoc + rtrn) + tra(ji,jj,ikt,jpdop) = tra(ji,jj,ikt,jpdop) + ( z1pdenit - zolimit ) * zwstpop / (zwstpoc + rtrn) + ENDIF + END DO + END DO + ENDIF + + + ! Nitrogen fixation process + ! Small source iron from particulate inorganic iron + !----------------------------------- + DO jk = 1, jpkm1 + zlight (:,:,jk) = ( 1.- EXP( -etot_ndcy(:,:,jk) / diazolight ) ) * ( 1. - fr_i(:,:) ) + zsoufer(:,:,jk) = zlight(:,:,jk) * 2E-11 / ( 2E-11 + biron(:,:,jk) ) + ENDDO + IF( ln_p4z ) THEN + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! ! Potential nitrogen fixation dependant on temperature and iron + ztemp = tsn(ji,jj,jk,jp_tem) + zmudia = MAX( 0.,-0.001096*ztemp**2 + 0.057*ztemp -0.637 ) * 7.625 + ! Potential nitrogen fixation dependant on temperature and iron + xdianh4 = trb(ji,jj,jk,jpnh4) / ( concnnh4 + trb(ji,jj,jk,jpnh4) ) + xdiano3 = trb(ji,jj,jk,jpno3) / ( concnno3 + trb(ji,jj,jk,jpno3) ) * (1. - xdianh4) + zlim = ( 1.- xdiano3 - xdianh4 ) + IF( zlim <= 0.1 ) zlim = 0.01 + zfact = zlim * rfact2 + ztrfer = biron(ji,jj,jk) / ( concfediaz + biron(ji,jj,jk) ) + ztrpo4(ji,jj,jk) = trb(ji,jj,jk,jppo4) / ( 1E-6 + trb(ji,jj,jk,jppo4) ) + ztrdp = ztrpo4(ji,jj,jk) + nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrdp ) * zlight(ji,jj,jk) + END DO + END DO + END DO + ELSE ! p5z + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! ! Potential nitrogen fixation dependant on temperature and iron + ztemp = tsn(ji,jj,jk,jp_tem) + zmudia = MAX( 0.,-0.001096*ztemp**2 + 0.057*ztemp -0.637 ) * 7.625 + ! Potential nitrogen fixation dependant on temperature and iron + xdianh4 = trb(ji,jj,jk,jpnh4) / ( concnnh4 + trb(ji,jj,jk,jpnh4) ) + xdiano3 = trb(ji,jj,jk,jpno3) / ( concnno3 + trb(ji,jj,jk,jpno3) ) * (1. - xdianh4) + zlim = ( 1.- xdiano3 - xdianh4 ) + IF( zlim <= 0.1 ) zlim = 0.01 + zfact = zlim * rfact2 + ztrfer = biron(ji,jj,jk) / ( concfediaz + biron(ji,jj,jk) ) + ztrpo4(ji,jj,jk) = trb(ji,jj,jk,jppo4) / ( 1E-6 + trb(ji,jj,jk,jppo4) ) + ztrdop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( 1E-6 + trb(ji,jj,jk,jpdop) ) * (1. - ztrpo4(ji,jj,jk)) + ztrdp = ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk) + nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrdp ) * zlight(ji,jj,jk) + END DO + END DO + END DO + ENDIF + + ! Nitrogen change due to nitrogen fixation + ! ---------------------------------------- + IF( ln_p4z ) THEN + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zfact = nitrpot(ji,jj,jk) * nitrfix + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zfact / 3.0 + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * zfact / 3.0 + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) - zfact * 2.0 / 3.0 + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zfact * 1.0 / 3.0 + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zfact * 1.0 / 3.0 * 2.0 / 3.0 + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zfact * 1.0 / 3.0 * 1.0 / 3.0 + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + ( o2ut + o2nit ) * zfact * 2.0 / 3.0 + o2nit * zfact / 3.0 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - 30E-6 * zfact * 1.0 / 3.0 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + 30E-6 * zfact * 1.0 / 3.0 * 2.0 / 3.0 + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + 30E-6 * zfact * 1.0 / 3.0 * 1.0 / 3.0 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * rfact2 / rday + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + concdnh4 / ( concdnh4 + trb(ji,jj,jk,jppo4) ) & + & * 0.001 * trb(ji,jj,jk,jpdoc) * xstep + END DO + END DO + END DO + ELSE ! p5z + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zfact = nitrpot(ji,jj,jk) * nitrfix + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zfact / 3.0 + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * zfact / 3.0 + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) - 16.0 / 46.0 * zfact * ( 1.0 - 1.0 / 3.0 ) & + & * ztrpo4(ji,jj,jk) / (ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk) + rtrn) + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + zfact * 1.0 / 3.0 + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zfact * 1.0 / 3.0 + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + 16.0 / 46.0 * zfact / 3.0 & + & - 16.0 / 46.0 * zfact * ztrdop(ji,jj,jk) & + & / (ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk) + rtrn) + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zfact * 1.0 / 3.0 * 2.0 / 3.0 + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + zfact * 1.0 / 3.0 * 2.0 /3.0 + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + 16.0 / 46.0 * zfact * 1.0 / 3.0 * 2.0 /3.0 + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zfact * 1.0 / 3.0 * 1.0 / 3.0 + tra(ji,jj,jk,jpgon) = tra(ji,jj,jk,jpgon) + zfact * 1.0 / 3.0 * 1.0 /3.0 + tra(ji,jj,jk,jpgop) = tra(ji,jj,jk,jpgop) + 16.0 / 46.0 * zfact * 1.0 / 3.0 * 1.0 /3.0 + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + ( o2ut + o2nit ) * zfact * 2.0 / 3.0 + o2nit * zfact / 3.0 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - 30E-6 * zfact * 1.0 / 3.0 + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + 30E-6 * zfact * 1.0 / 3.0 * 2.0 / 3.0 + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + 30E-6 * zfact * 1.0 / 3.0 * 1.0 / 3.0 + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * rfact2 / rday + END DO + END DO + END DO + ! + ENDIF + + IF( lk_iomput ) THEN + IF( knt == nrdttrc ) THEN + zfact = 1.e+3 * rfact2r ! conversion from molC/l/kt to molN/m3/s + CALL iom_put( "Nfix", nitrpot(:,:,:) * nitrfix * rno3 * zfact * tmask(:,:,:) ) ! nitrogen fixation + CALL iom_put( "SedCal", zsedcal(:,:) * zfact ) + CALL iom_put( "SedSi", zsedsi (:,:) * zfact ) + CALL iom_put( "SedC", zsedc (:,:) * zfact ) + CALL iom_put( "Sdenit", sdenit (:,:) * zfact * rno3 ) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (USEd for debugging) + WRITE(charout, fmt="('sed ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_p5z ) DEALLOCATE( ztrpo4, ztrdop ) + ! + IF( ln_timing ) CALL timing_stop('p4z_sed') + ! + END SUBROUTINE p4z_sed + + + INTEGER FUNCTION p4z_sed_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_sed_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( nitrpot(jpi,jpj,jpk), sdenit(jpi,jpj), STAT=p4z_sed_alloc ) + ! + IF( p4z_sed_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_alloc: failed to allocate arrays' ) + ! + nitrpot(:,:,jpk) = 0._wp ! initialization + ! + END FUNCTION p4z_sed_alloc + + !!====================================================================== +END MODULE p4zsed diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsink.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsink.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d1327a88fc40894ce0ca32976c936387cdfd7f49 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsink.F90 @@ -0,0 +1,197 @@ +MODULE p4zsink + !!====================================================================== + !! *** MODULE p4zsink *** + !! TOP : PISCES vertical flux of particulate matter due to gravitational sinking + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Change aggregation formula + !! 3.5 ! 2012-07 (O. Aumont) Introduce potential time-splitting + !!---------------------------------------------------------------------- + !! p4z_sink : Compute vertical flux of particulate matter due to gravitational sinking + !! p4z_sink_init : Unitialisation of sinking speed parameters + !! p4z_sink_alloc : Allocate sinking speed variables + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE trcsink ! General routine to compute sedimentation + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_sink ! called in p4zbio.F90 + PUBLIC p4z_sink_init ! called in trcsms_pisces.F90 + PUBLIC p4z_sink_alloc + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinking, sinking2 !: POC sinking fluxes + ! ! (different meanings depending on the parameterization) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkingn, sinking2n !: POC sinking fluxes + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkingp, sinking2p !: POC sinking fluxes + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkcal, sinksil !: CaCO3 and BSi sinking fluxes + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkfer !: Small BFe sinking fluxes + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkfer2 !: Big iron sinking fluxes + + INTEGER :: ik100 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zsink.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! 'standard sinking parameterisation' ??? + !!---------------------------------------------------------------------- + + SUBROUTINE p4z_sink ( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_sink *** + !! + !! ** Purpose : Compute vertical flux of particulate matter due to + !! gravitational sinking + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt + INTEGER :: ji, jj, jk + CHARACTER (len=25) :: charout + REAL(wp) :: zmax, zfact + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_sink') + + ! Initialization of some global variables + ! --------------------------------------- + prodpoc(:,:,:) = 0. + conspoc(:,:,:) = 0. + prodgoc(:,:,:) = 0. + consgoc(:,:,:) = 0. + + ! + ! Sinking speeds of detritus is increased with depth as shown + ! by data and from the coagulation theory + ! ----------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1,jpi + zmax = MAX( heup_01(ji,jj), hmld(ji,jj) ) + zfact = MAX( 0., gdepw_n(ji,jj,jk+1) - zmax ) / wsbio2scale + wsbio4(ji,jj,jk) = wsbio2 + MAX(0., ( wsbio2max - wsbio2 )) * zfact + END DO + END DO + END DO + + ! limit the values of the sinking speeds to avoid numerical instabilities + wsbio3(:,:,:) = wsbio + + ! + ! Initializa to zero all the sinking arrays + ! ----------------------------------------- + sinking (:,:,:) = 0.e0 + sinking2(:,:,:) = 0.e0 + sinkcal (:,:,:) = 0.e0 + sinkfer (:,:,:) = 0.e0 + sinksil (:,:,:) = 0.e0 + sinkfer2(:,:,:) = 0.e0 + + ! Compute the sedimentation term using p4zsink2 for all the sinking particles + ! ----------------------------------------------------- + CALL trc_sink( kt, wsbio3, sinking , jppoc, rfact2 ) + CALL trc_sink( kt, wsbio3, sinkfer , jpsfe, rfact2 ) + CALL trc_sink( kt, wsbio4, sinking2, jpgoc, rfact2 ) + CALL trc_sink( kt, wsbio4, sinkfer2, jpbfe, rfact2 ) + CALL trc_sink( kt, wsbio4, sinksil , jpgsi, rfact2 ) + CALL trc_sink( kt, wsbio4, sinkcal , jpcal, rfact2 ) + + IF( ln_p5z ) THEN + sinkingn (:,:,:) = 0.e0 + sinking2n(:,:,:) = 0.e0 + sinkingp (:,:,:) = 0.e0 + sinking2p(:,:,:) = 0.e0 + + ! Compute the sedimentation term using p4zsink2 for all the sinking particles + ! ----------------------------------------------------- + CALL trc_sink( kt, wsbio3, sinkingn , jppon, rfact2 ) + CALL trc_sink( kt, wsbio3, sinkingp , jppop, rfact2 ) + CALL trc_sink( kt, wsbio4, sinking2n, jpgon, rfact2 ) + CALL trc_sink( kt, wsbio4, sinking2p, jpgop, rfact2 ) + ENDIF + + ! Total carbon export per year + IF( iom_use( "tcexp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) & + & t_oce_co2_exp = glob_sum( 'p4zsink', ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * e1e2t(:,:) * tmask(:,:,1) ) + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s + ! + CALL iom_put( "EPC100" , ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * zfact * tmask(:,:,1) ) ! Export of carbon at 100m + CALL iom_put( "EPFE100" , ( sinkfer(:,:,ik100) + sinkfer2(:,:,ik100) ) * zfact * tmask(:,:,1) ) ! Export of iron at 100m + CALL iom_put( "EPCAL100", sinkcal(:,:,ik100) * zfact * tmask(:,:,1) ) ! Export of calcite at 100m + CALL iom_put( "EPSI100" , sinksil(:,:,ik100) * zfact * tmask(:,:,1) ) ! Export of bigenic silica at 100m + CALL iom_put( "EXPC" , ( sinking(:,:,:) + sinking2(:,:,:) ) * zfact * tmask(:,:,:) ) ! Export of carbon in the water column + CALL iom_put( "EXPFE" , ( sinkfer(:,:,:) + sinkfer2(:,:,:) ) * zfact * tmask(:,:,:) ) ! Export of iron + CALL iom_put( "EXPCAL" , sinkcal(:,:,:) * zfact * tmask(:,:,:) ) ! Export of calcite + CALL iom_put( "EXPSI" , sinksil(:,:,:) * zfact * tmask(:,:,:) ) ! Export of bigenic silica + CALL iom_put( "tcexp" , t_oce_co2_exp * zfact ) ! molC/s + ! + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('sink')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p4z_sink') + ! + END SUBROUTINE p4z_sink + + + SUBROUTINE p4z_sink_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_sink_init *** + !!---------------------------------------------------------------------- + INTEGER :: jk + !!---------------------------------------------------------------------- + ! + ik100 = 10 ! last level where depth less than 100 m + DO jk = jpkm1, 1, -1 + IF( gdept_1d(jk) > 100. ) ik100 = jk - 1 + END DO + IF (lwp) WRITE(numout,*) + IF (lwp) WRITE(numout,*) ' Level corresponding to 100m depth ', ik100 + 1 + IF (lwp) WRITE(numout,*) + ! + t_oce_co2_exp = 0._wp + ! + END SUBROUTINE p4z_sink_init + + INTEGER FUNCTION p4z_sink_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_sink_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(2) + !!---------------------------------------------------------------------- + ! + ierr(:) = 0 + ! + ALLOCATE( sinking(jpi,jpj,jpk) , sinking2(jpi,jpj,jpk) , & + & sinkcal(jpi,jpj,jpk) , sinksil (jpi,jpj,jpk) , & + & sinkfer2(jpi,jpj,jpk) , & + & sinkfer(jpi,jpj,jpk) , STAT=ierr(1) ) + ! + IF( ln_p5z ) ALLOCATE( sinkingn(jpi,jpj,jpk), sinking2n(jpi,jpj,jpk) , & + & sinkingp(jpi,jpj,jpk), sinking2p(jpi,jpj,jpk) , STAT=ierr(2) ) + ! + p4z_sink_alloc = MAXVAL( ierr ) + IF( p4z_sink_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_sink_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p4z_sink_alloc + + !!====================================================================== +END MODULE p4zsink diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsms.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsms.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e1c18c3ec6dc0842391227de2a259ca0a6f8ed8d --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p4zsms.F90 @@ -0,0 +1,592 @@ +MODULE p4zsms + !!====================================================================== + !! *** MODULE p4zsms *** + !! TOP : PISCES Source Minus Sink manager + !!====================================================================== + !! History : 1.0 ! 2004-03 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !!---------------------------------------------------------------------- + !! p4z_sms : Time loop of passive tracers sms + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE trcdta ! + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zbio ! Biological model + USE p4zche ! Chemical model + USE p4zlys ! Calcite saturation + USE p4zflx ! Gas exchange + USE p4zsbc ! External source of nutrients + USE p4zsed ! Sedimentation + USE p4zint ! time interpolation + USE p4zrem ! remineralisation + USE iom ! I/O manager + USE trd_oce ! Ocean trends variables + USE trdtrc ! TOP trends variables + USE sedmodel ! Sediment model + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p4z_sms_init ! called in p4zsms.F90 + PUBLIC p4z_sms ! called in p4zsms.F90 + + INTEGER :: numco2, numnut, numnit ! logical unit for co2 budget + REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget, po4budget + REAL(wp) :: xfact, xfact1, xfact2, xfact3 + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnegtr ! Array used to indicate negative tracer values + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p4zsms.F90 13342 2020-07-27 09:32:05Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p4z_sms( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_sms *** + !! + !! ** Purpose : Managment of the call to Biological sources and sinks + !! routines of PISCES bio-model + !! + !! ** Method : - at each new day ... + !! - several calls of bio and sed ??? + !! - ... + !!--------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jnt, jn, jl + REAL(wp) :: ztra + CHARACTER (len=25) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,: ) :: zw3d + REAL(wp), DIMENSION(jpi,jpj,jpk,jp_pisces) :: ztrbbio + + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p4z_sms') + ! + IF( kt == nittrc000 ) THEN + ! + ALLOCATE( xnegtr(jpi,jpj,jpk) ) + ! + IF( .NOT. ln_rsttr ) THEN + CALL p4z_che ! initialize the chemical constants + CALL ahini_for_at(hi) ! set PH at kt=nit000 + t_oce_co2_flx_cum = 0._wp + ELSE + CALL p4z_rst( nittrc000, 'READ' ) !* read or initialize all required fields + ENDIF + ! + ENDIF + ! + IF( ln_pisdmp .AND. MOD( kt - nn_dttrc, nn_pisdmp ) == 0 ) CALL p4z_dmp( kt ) ! Relaxation of some tracers + ! + rfact = r2dttrc + ! + IF( ( ln_top_euler .AND. kt == nittrc000 ) .OR. ( .NOT.ln_top_euler .AND. kt <= nittrc000 + nn_dttrc ) ) THEN + rfactr = 1. / rfact + rfact2 = rfact / REAL( nrdttrc, wp ) + rfact2r = 1. / rfact2 + xstep = rfact2 / rday ! Time step duration for biology + xfact = 1.e+3 * rfact2r + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Passive Tracer time step rfact = ', rfact, ' rdt = ', rdt + IF(lwp) write(numout,*) ' PISCES Biology time step rfact2 = ', rfact2 + IF(lwp) WRITE(numout,*) + ENDIF + + IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN + DO jn = jp_pcs0, jp_pcs1 ! SMS on tracer without Asselin time-filter + trb(:,:,:,jn) = trn(:,:,:,jn) + END DO + ENDIF + + DO jn = jp_pcs0, jp_pcs1 ! Store the tracer concentrations before entering PISCES + ztrbbio(:,:,:,jn) = trb(:,:,:,jn) + END DO + + ! + IF( ll_sbc ) CALL p4z_sbc( kt ) ! external sources of nutrients + ! +#if ! defined key_sed_off + CALL p4z_che ! computation of chemical constants + CALL p4z_int( kt ) ! computation of various rates for biogeochemistry + ! + DO jnt = 1, nrdttrc ! Potential time splitting if requested + ! + CALL p4z_bio( kt, jnt ) ! Biology + CALL p4z_lys( kt, jnt ) ! Compute CaCO3 saturation + CALL p4z_sed( kt, jnt ) ! Surface and Bottom boundary conditions + CALL p4z_flx( kt, jnt ) ! Compute surface fluxes + ! + xnegtr(:,:,:) = 1.e0 + DO jn = jp_pcs0, jp_pcs1 + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN + ztra = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) + xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk), ztra ) + ENDIF + END DO + END DO + END DO + END DO + ! ! where at least 1 tracer concentration becomes negative + ! ! + DO jn = jp_pcs0, jp_pcs1 + trb(:,:,:,jn) = trb(:,:,:,jn) + xnegtr(:,:,:) * tra(:,:,:,jn) + END DO + + ! + IF( iom_use( 'INTdtAlk' ) .OR. iom_use( 'INTdtDIC' ) .OR. iom_use( 'INTdtFer' ) .OR. & + & iom_use( 'INTdtDIN' ) .OR. iom_use( 'INTdtDIP' ) .OR. iom_use( 'INTdtSil' ) ) THEN + ! + ALLOCATE( zw3d(jpi,jpj,jpk), zw2d(jpi,jpj) ) + zw3d(:,:,jpk) = 0. + DO jk = 1, jpkm1 + zw3d(:,:,jk) = xnegtr(:,:,jk) * xfact * e3t_n(:,:,jk) * tmask(:,:,jk) + ENDDO + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tra(:,:,jk,jptal) + ENDDO + CALL iom_put( 'INTdtAlk', zw2d ) + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tra(:,:,jk,jpdic) + ENDDO + CALL iom_put( 'INTdtDIC', zw2d ) + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * rno3 * ( tra(:,:,jk,jpno3) + tra(:,:,jk,jpnh4) ) + ENDDO + CALL iom_put( 'INTdtDIN', zw2d ) + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * po4r * tra(:,:,jk,jppo4) + ENDDO + CALL iom_put( 'INTdtDIP', zw2d ) + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tra(:,:,jk,jpfer) + ENDDO + CALL iom_put( 'INTdtFer', zw2d ) + ! + zw2d(:,:) = 0. + DO jk = 1, jpkm1 + zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tra(:,:,jk,jpsil) + ENDDO + CALL iom_put( 'INTdtSil', zw2d ) + ! + DEALLOCATE( zw3d, zw2d ) + ENDIF + ! + DO jn = jp_pcs0, jp_pcs1 + tra(:,:,:,jn) = 0._wp + END DO + ! + END DO + ! +#endif + ! + IF( ln_sediment ) THEN + ! + CALL sed_model( kt ) ! Main program of Sediment model + ! + ENDIF + ! + DO jn = jp_pcs0, jp_pcs1 + tra(:,:,:,jn) = ( trb(:,:,:,jn) - ztrbbio(:,:,:,jn) ) * rfactr + trb(:,:,:,jn) = ztrbbio(:,:,:,jn) + ztrbbio(:,:,:,jn) = 0._wp + END DO + ! + IF( l_trdtrc ) THEN + DO jn = jp_pcs0, jp_pcs1 + CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends + END DO + END IF + ! + IF( lrst_trc ) CALL p4z_rst( kt, 'WRITE' ) !* Write PISCES informations in restart file + ! + + IF( lk_iomput .OR. ln_check_mass ) CALL p4z_chk_mass( kt ) ! Mass conservation checking + + IF( lwm .AND. kt == nittrc000 ) CALL FLUSH( numonp ) ! flush output namelist PISCES + ! + IF( ln_timing ) CALL timing_stop('p4z_sms') + ! + END SUBROUTINE p4z_sms + + + SUBROUTINE p4z_sms_init + !!---------------------------------------------------------------------- + !! *** p4z_sms_init *** + !! + !! ** Purpose : read PISCES namelist + !! + !! ** input : file 'namelist.trc.s' containing the following + !! namelist: natext, natbio, natsms + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/nampisbio/ nrdttrc, wsbio, xkmort, ferat3, wsbio2, wsbio2max, wsbio2scale, & + & ldocp, ldocz, lthet, no3rat3, po4rat3 + ! + NAMELIST/nampisdmp/ ln_pisdmp, nn_pisdmp + NAMELIST/nampismass/ ln_check_mass + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'p4z_sms_init : PISCES initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + REWIND( numnatp_ref ) ! Namelist nampisbio in reference namelist : Pisces variables + READ ( numnatp_ref, nampisbio, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisbio in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampisbio in configuration namelist : Pisces variables + READ ( numnatp_cfg, nampisbio, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisbio in configuration namelist' ) + IF(lwm) WRITE( numonp, nampisbio ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampisbio' + WRITE(numout,*) ' frequency for the biology nrdttrc =', nrdttrc + WRITE(numout,*) ' POC sinking speed wsbio =', wsbio + WRITE(numout,*) ' half saturation constant for mortality xkmort =', xkmort + IF( ln_p5z ) THEN + WRITE(numout,*) ' N/C in zooplankton no3rat3 =', no3rat3 + WRITE(numout,*) ' P/C in zooplankton po4rat3 =', po4rat3 + ENDIF + WRITE(numout,*) ' Fe/C in zooplankton ferat3 =', ferat3 + WRITE(numout,*) ' Big particles sinking speed wsbio2 =', wsbio2 + WRITE(numout,*) ' Big particles maximum sinking speed wsbio2max =', wsbio2max + WRITE(numout,*) ' Big particles sinking speed length scale wsbio2scale =', wsbio2scale + IF( ln_ligand ) THEN + IF( ln_p4z ) THEN + WRITE(numout,*) ' Phyto ligand production per unit doc ldocp =', ldocp + WRITE(numout,*) ' Zoo ligand production per unit doc ldocz =', ldocz + WRITE(numout,*) ' Proportional loss of ligands due to Fe uptake lthet =', lthet + ENDIF + ENDIF + ENDIF + + + REWIND( numnatp_ref ) ! Namelist nampisdmp in reference namelist : Pisces damping + READ ( numnatp_ref, nampisdmp, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisdmp in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampisdmp in configuration namelist : Pisces damping + READ ( numnatp_cfg, nampisdmp, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisdmp in configuration namelist' ) + IF(lwm) WRITE( numonp, nampisdmp ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist : nampisdmp --- relaxation to GLODAP' + WRITE(numout,*) ' Relaxation of tracer to glodap mean value ln_pisdmp =', ln_pisdmp + WRITE(numout,*) ' Frequency of Relaxation nn_pisdmp =', nn_pisdmp + ENDIF + + REWIND( numnatp_ref ) ! Namelist nampismass in reference namelist : Pisces mass conservation check + READ ( numnatp_ref, nampismass, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampismass in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampismass in configuration namelist : Pisces mass conservation check + READ ( numnatp_cfg, nampismass, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampismass in configuration namelist' ) + IF(lwm) WRITE( numonp, nampismass ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist : nampismass --- mass conservation checking' + WRITE(numout,*) ' Flag to check mass conservation of NO3/Si/TALK ln_check_mass = ', ln_check_mass + ENDIF + ! + END SUBROUTINE p4z_sms_init + + + SUBROUTINE p4z_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_rst *** + !! + !! ** Purpose : Read or write variables 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 + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + !!--------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p4z_rst : Read specific variables from pisces model ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' + ! + IF( iom_varid( numrtr, 'PH', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrtr, jpdom_autoglo, 'PH' , hi(:,:,:) ) + ELSE + CALL p4z_che ! initialize the chemical constants + CALL ahini_for_at(hi) + ENDIF + CALL iom_get( numrtr, jpdom_autoglo, 'Silicalim', xksi(:,:) ) + IF( iom_varid( numrtr, 'Silicamax', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrtr, jpdom_autoglo, 'Silicamax' , xksimax(:,:) ) + ELSE + xksimax(:,:) = xksi(:,:) + ENDIF + ! + IF( iom_varid( numrtr, 'tcflxcum', ldstop = .FALSE. ) > 0 ) THEN ! cumulative total flux of carbon + CALL iom_get( numrtr, 'tcflxcum' , t_oce_co2_flx_cum ) + ELSE + t_oce_co2_flx_cum = 0._wp + ENDIF + ! + IF( ln_p5z ) THEN + IF( iom_varid( numrtr, 'sized', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrtr, jpdom_autoglo, 'sizep' , sizep(:,:,:) ) + CALL iom_get( numrtr, jpdom_autoglo, 'sizen' , sizen(:,:,:) ) + CALL iom_get( numrtr, jpdom_autoglo, 'sized' , sized(:,:,:) ) + ELSE + sizep(:,:,:) = 1. + sizen(:,:,:) = 1. + sized(:,:,:) = 1. + ENDIF + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN + IF( kt == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'p4z_rst : write pisces restart file kt =', kt + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + CALL iom_rstput( kt, nitrst, numrtw, 'PH', hi(:,:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'Silicalim', xksi(:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'Silicamax', xksimax(:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'tcflxcum', t_oce_co2_flx_cum ) + IF( ln_p5z ) THEN + CALL iom_rstput( kt, nitrst, numrtw, 'sizep', sizep(:,:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'sizen', sizen(:,:,:) ) + CALL iom_rstput( kt, nitrst, numrtw, 'sized', sized(:,:,:) ) + ENDIF + ENDIF + ! + END SUBROUTINE p4z_rst + + + SUBROUTINE p4z_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** p4z_dmp *** + !! + !! ** purpose : Relaxation of some tracers + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! time step + ! + REAL(wp) :: alkmean = 2426. ! mean value of alkalinity ( Glodap ; for Goyet 2391. ) + REAL(wp) :: po4mean = 2.165 ! mean value of phosphates + REAL(wp) :: no3mean = 30.90 ! mean value of nitrate + REAL(wp) :: silmean = 91.51 ! mean value of silicate + ! + REAL(wp) :: zarea, zalksumn, zpo4sumn, zno3sumn, zsilsumn + REAL(wp) :: zalksumb, zpo4sumb, zno3sumb, zsilsumb + !!--------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p4z_dmp : Restoring of nutrients at time-step kt = ', kt + IF(lwp) WRITE(numout,*) + + IF( cn_cfg == "ORCA" .OR. cn_cfg == "orca") THEN + IF( .NOT. lk_c1d ) THEN ! ORCA configuration (not 1D) ! + ! ! --------------------------- ! + ! set total alkalinity, phosphate, nitrate & silicate + zarea = 1._wp / glob_sum( 'p4zsms', cvol(:,:,:) ) * 1e6 + + zalksumn = glob_sum( 'p4zsms', trn(:,:,:,jptal) * cvol(:,:,:) ) * zarea + zpo4sumn = glob_sum( 'p4zsms', trn(:,:,:,jppo4) * cvol(:,:,:) ) * zarea * po4r + zno3sumn = glob_sum( 'p4zsms', trn(:,:,:,jpno3) * cvol(:,:,:) ) * zarea * rno3 + zsilsumn = glob_sum( 'p4zsms', trn(:,:,:,jpsil) * cvol(:,:,:) ) * zarea + + IF(lwp) WRITE(numout,*) ' TALKN mean : ', zalksumn + trn(:,:,:,jptal) = trn(:,:,:,jptal) * alkmean / zalksumn + + IF(lwp) WRITE(numout,*) ' PO4N mean : ', zpo4sumn + trn(:,:,:,jppo4) = trn(:,:,:,jppo4) * po4mean / zpo4sumn + + IF(lwp) WRITE(numout,*) ' NO3N mean : ', zno3sumn + trn(:,:,:,jpno3) = trn(:,:,:,jpno3) * no3mean / zno3sumn + + IF(lwp) WRITE(numout,*) ' SiO3N mean : ', zsilsumn + trn(:,:,:,jpsil) = MIN( 400.e-6,trn(:,:,:,jpsil) * silmean / zsilsumn ) + ! + ! + IF( .NOT. ln_top_euler ) THEN + zalksumb = glob_sum( 'p4zsms', trb(:,:,:,jptal) * cvol(:,:,:) ) * zarea + zpo4sumb = glob_sum( 'p4zsms', trb(:,:,:,jppo4) * cvol(:,:,:) ) * zarea * po4r + zno3sumb = glob_sum( 'p4zsms', trb(:,:,:,jpno3) * cvol(:,:,:) ) * zarea * rno3 + zsilsumb = glob_sum( 'p4zsms', trb(:,:,:,jpsil) * cvol(:,:,:) ) * zarea + + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' TALKB mean : ', zalksumb + trb(:,:,:,jptal) = trb(:,:,:,jptal) * alkmean / zalksumb + + IF(lwp) WRITE(numout,*) ' PO4B mean : ', zpo4sumb + trb(:,:,:,jppo4) = trb(:,:,:,jppo4) * po4mean / zpo4sumb + + IF(lwp) WRITE(numout,*) ' NO3B mean : ', zno3sumb + trb(:,:,:,jpno3) = trb(:,:,:,jpno3) * no3mean / zno3sumb + + IF(lwp) WRITE(numout,*) ' SiO3B mean : ', zsilsumb + trb(:,:,:,jpsil) = MIN( 400.e-6,trb(:,:,:,jpsil) * silmean / zsilsumb ) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE p4z_dmp + + + SUBROUTINE p4z_chk_mass( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_chk_mass *** + !! + !! ** Purpose : Mass conservation check + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + REAL(wp) :: zrdenittot, zsdenittot, znitrpottot + CHARACTER(LEN=100) :: cltxt + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwork + !!---------------------------------------------------------------------- + ! + IF( kt == nittrc000 ) THEN + xfact1 = rfact2r * 12. / 1.e15 * ryyss ! conversion molC/kt --> PgC/yr + xfact2 = 1.e+3 * rno3 * 14. / 1.e12 * ryyss ! conversion molC/l/s ----> TgN/m3/yr + xfact3 = 1.e+3 * rfact2r * rno3 ! conversion molC/l/kt ----> molN/m3/s + IF( ln_check_mass .AND. lwp) THEN ! Open budget file of NO3, ALK, Si, Fer + CALL ctl_opn( numco2, 'carbon.budget' , 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) + CALL ctl_opn( numnut, 'nutrient.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) + CALL ctl_opn( numnit, 'nitrogen.budget', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) + cltxt='time-step Alkalinity Nitrate Phosphorus Silicate Iron' + IF( lwp ) WRITE(numnut,*) TRIM(cltxt) + IF( lwp ) WRITE(numnut,*) + ENDIF + ENDIF + + IF( iom_use( "pno3tot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + ! Compute the budget of NO3, ALK, Si, Fer + IF( ln_p4z ) THEN + zwork(:,:,:) = trn(:,:,:,jpno3) + trn(:,:,:,jpnh4) & + & + trn(:,:,:,jpphy) + trn(:,:,:,jpdia) & + & + trn(:,:,:,jppoc) + trn(:,:,:,jpgoc) + trn(:,:,:,jpdoc) & + & + trn(:,:,:,jpzoo) + trn(:,:,:,jpmes) + ELSE + zwork(:,:,:) = trn(:,:,:,jpno3) + trn(:,:,:,jpnh4) + trn(:,:,:,jpnph) & + & + trn(:,:,:,jpndi) + trn(:,:,:,jpnpi) & + & + trn(:,:,:,jppon) + trn(:,:,:,jpgon) + trn(:,:,:,jpdon) & + & + ( trn(:,:,:,jpzoo) + trn(:,:,:,jpmes) ) * no3rat3 + ENDIF + ! + no3budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) + no3budget = no3budget / areatot + CALL iom_put( "pno3tot", no3budget ) + ENDIF + ! + IF( iom_use( "ppo4tot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + IF( ln_p4z ) THEN + zwork(:,:,:) = trn(:,:,:,jppo4) & + & + trn(:,:,:,jpphy) + trn(:,:,:,jpdia) & + & + trn(:,:,:,jppoc) + trn(:,:,:,jpgoc) + trn(:,:,:,jpdoc) & + & + trn(:,:,:,jpzoo) + trn(:,:,:,jpmes) + ELSE + zwork(:,:,:) = trn(:,:,:,jppo4) + trn(:,:,:,jppph) & + & + trn(:,:,:,jppdi) + trn(:,:,:,jpppi) & + & + trn(:,:,:,jppop) + trn(:,:,:,jpgop) + trn(:,:,:,jpdop) & + & + ( trn(:,:,:,jpzoo) + trn(:,:,:,jpmes) ) * po4rat3 + ENDIF + ! + po4budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) + po4budget = po4budget / areatot + CALL iom_put( "ppo4tot", po4budget ) + ENDIF + ! + IF( iom_use( "psiltot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + zwork(:,:,:) = trn(:,:,:,jpsil) + trn(:,:,:,jpgsi) + trn(:,:,:,jpdsi) + ! + silbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) + silbudget = silbudget / areatot + CALL iom_put( "psiltot", silbudget ) + ENDIF + ! + IF( iom_use( "palktot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + zwork(:,:,:) = trn(:,:,:,jpno3) * rno3 + trn(:,:,:,jptal) + trn(:,:,:,jpcal) * 2. + ! + alkbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) ! + alkbudget = alkbudget / areatot + CALL iom_put( "palktot", alkbudget ) + ENDIF + ! + IF( iom_use( "pfertot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + zwork(:,:,:) = trn(:,:,:,jpfer) + trn(:,:,:,jpnfe) + trn(:,:,:,jpdfe) & + & + trn(:,:,:,jpbfe) + trn(:,:,:,jpsfe) & + & + ( trn(:,:,:,jpzoo) + trn(:,:,:,jpmes) ) * ferat3 + ! + ferbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) + ferbudget = ferbudget / areatot + CALL iom_put( "pfertot", ferbudget ) + ENDIF + ! + ! Global budget of N SMS : denitrification in the water column and in the sediment + ! nitrogen fixation by the diazotrophs + ! -------------------------------------------------------------------------------- + IF( iom_use( "tnfix" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + znitrpottot = glob_sum ( 'p4zsms', nitrpot(:,:,:) * nitrfix * cvol(:,:,:) ) + CALL iom_put( "tnfix" , znitrpottot * xfact3 ) ! Global nitrogen fixation molC/l to molN/m3 + ENDIF + ! + IF( iom_use( "tdenit" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN + zrdenittot = glob_sum ( 'p4zsms', denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) ) + zsdenittot = glob_sum ( 'p4zsms', sdenit(:,:) * e1e2t(:,:) * tmask(:,:,1) ) + CALL iom_put( "tdenit" , ( zrdenittot + zsdenittot ) * xfact3 ) ! Total denitrification molC/l to molN/m3 + ENDIF + ! + IF( ln_check_mass .AND. kt == nitend ) THEN ! Compute the budget of NO3, ALK, Si, Fer + t_atm_co2_flx = t_atm_co2_flx / glob_sum( 'p4zsms', e1e2t(:,:) ) + t_oce_co2_flx = t_oce_co2_flx * xfact1 * (-1 ) + tpp = tpp * 1000. * xfact1 + t_oce_co2_exp = t_oce_co2_exp * 1000. * xfact1 + IF( lwp ) WRITE(numco2,9000) ndastp, t_atm_co2_flx, t_oce_co2_flx, tpp, t_oce_co2_exp + IF( lwp ) WRITE(numnut,9100) ndastp, alkbudget * 1.e+06, & + & no3budget * rno3 * 1.e+06, & + & po4budget * po4r * 1.e+06, & + & silbudget * 1.e+06, & + & ferbudget * 1.e+09 + ! + IF( lwp ) WRITE(numnit,9200) ndastp, znitrpottot * xfact2 , & + & zrdenittot * xfact2 , & + & zsdenittot * xfact2 + ENDIF + ! + 9000 FORMAT(i8,f10.5,e18.10,f10.5,f10.5) + 9100 FORMAT(i8,5e18.10) + 9200 FORMAT(i8,3f10.5) + ! + END SUBROUTINE p4z_chk_mass + + !!====================================================================== +END MODULE p4zsms diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zlim.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zlim.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5d9e7b580109f4eeabdc1799a31966b37bfc3a86 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zlim.F90 @@ -0,0 +1,575 @@ +MODULE p5zlim + !!====================================================================== + !! *** MODULE p5zlim *** + !! TOP : PISCES with variable stoichiometry + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-04 (O. Aumont, C. Ethe) Limitation for iron modelled in quota + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p5z_lim : Compute the nutrients limitation terms + !! p5z_lim_init : Read the namelist + !!---------------------------------------------------------------------- + USE oce_trc ! Shared ocean-passive tracers variables + USE trc ! Tracers defined + USE p4zlim + USE sms_pisces ! PISCES variables + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p5z_lim + PUBLIC p5z_lim_init + PUBLIC p5z_lim_alloc + + !! * Shared module variables + REAL(wp), PUBLIC :: concpno3 !: NO3, PO4 half saturation + REAL(wp), PUBLIC :: concpnh4 !: NH4 half saturation for phyto + REAL(wp), PUBLIC :: concnpo4 !: NH4 half saturation for diatoms + REAL(wp), PUBLIC :: concppo4 !: NH4 half saturation for diatoms + REAL(wp), PUBLIC :: concdpo4 !: NH4 half saturation for diatoms + REAL(wp), PUBLIC :: concpfer !: Iron half saturation for nanophyto + REAL(wp), PUBLIC :: concbpo4 !: PO4 half saturation for bacteria + REAL(wp), PUBLIC :: xsizepic !: Minimum size criteria for diatoms + REAL(wp), PUBLIC :: xsizerp !: Size ratio for nanophytoplankton + REAL(wp), PUBLIC :: qfnopt !: optimal Fe quota for nanophyto + REAL(wp), PUBLIC :: qfpopt !: optimal Fe quota for nanophyto + REAL(wp), PUBLIC :: qfdopt !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qnnmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qnnmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qpnmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qpnmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qnpmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qnpmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qppmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qppmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qndmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qndmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qpdmin !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qpdmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qfnmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qfpmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: qfdmax !: optimal Fe quota for diatoms + REAL(wp), PUBLIC :: zpsinh4 + REAL(wp), PUBLIC :: zpsino3 + REAL(wp), PUBLIC :: zpsiuptk + + !!* Allometric variations of the quotas + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqnnmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqnnmax !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqpnmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqpnmax !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqnpmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqnpmax !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqppmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqppmax !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqndmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqndmax !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqpdmin !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xqpdmax !: ??? + + !!* Phytoplankton limitation terms + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpicono3 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpiconh4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpicopo4 !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnanodop !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpicodop !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiatdop !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xnanofer !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpicofer !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiatfer !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimpic !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xlimpfe !: ??? + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fvnuptk + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fvpuptk + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fvduptk + + ! Coefficient for iron limitation + REAL(wp) :: xcoef1 = 0.00167 / 55.85 + REAL(wp) :: xcoef2 = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5 + REAL(wp) :: xcoef3 = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p5zlim.F90 10070 2018-08-28 14:30:54Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE p5z_lim( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_lim *** + !! + !! ** Purpose : Compute the co-limitations by the various nutrients + !! for the various phytoplankton species + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt, knt + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zlim1, zlim2, zlim3, zlim4, zno3, zferlim + REAL(wp) :: z1_trndia, z1_trnpic, z1_trnphy, ztem1, ztem2, zetot1 + REAL(wp) :: zratio, zration, zratiof, znutlim, zfalim + REAL(wp) :: zconc1d, zconc1dnh4, zconc0n, zconc0nnh4, zconc0npo4, zconc0dpo4 + REAL(wp) :: zconc0p, zconc0pnh4, zconc0ppo4, zconcpfe, zconcnfe, zconcdfe + REAL(wp) :: fanano, fananop, fananof, fadiat, fadiatp, fadiatf + REAL(wp) :: fapico, fapicop, fapicof + REAL(wp) :: zrpho, zrass, zcoef, zfuptk, zratchl + REAL(wp) :: zfvn, zfvp, zfvf, zsizen, zsizep, zsized, znanochl, zpicochl, zdiatchl + REAL(wp) :: zqfemn, zqfemp, zqfemd, zbactno3, zbactnh4 + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_lim') + ! + zratchl = 6.0 + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! + ! Tuning of the iron concentration to a minimum level that is set to the detection limit + !------------------------------------- + zno3 = trb(ji,jj,jk,jpno3) / 40.e-6 + zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 ) + zferlim = MIN( zferlim, 7e-11 ) + trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim ) + + ! Computation of the mean relative size of each community + ! ------------------------------------------------------- + z1_trnphy = 1. / ( trb(ji,jj,jk,jpphy) + rtrn ) + z1_trnpic = 1. / ( trb(ji,jj,jk,jppic) + rtrn ) + z1_trndia = 1. / ( trb(ji,jj,jk,jpdia) + rtrn ) + znanochl = trb(ji,jj,jk,jpnch) * z1_trnphy + zpicochl = trb(ji,jj,jk,jppch) * z1_trnpic + zdiatchl = trb(ji,jj,jk,jpdch) * z1_trndia + + ! Computation of a variable Ks for iron on diatoms taking into account + ! that increasing biomass is made of generally bigger cells + !------------------------------------------------ + zsized = sized(ji,jj,jk)**0.81 + zconcdfe = concdfer * zsized + zconc1d = concdno3 * zsized + zconc1dnh4 = concdnh4 * zsized + zconc0dpo4 = concdpo4 * zsized + + zsizep = 1. + zconcpfe = concpfer * zsizep + zconc0p = concpno3 * zsizep + zconc0pnh4 = concpnh4 * zsizep + zconc0ppo4 = concppo4 * zsizep + + zsizen = 1. + zconcnfe = concnfer * zsizen + zconc0n = concnno3 * zsizen + zconc0nnh4 = concnnh4 * zsizen + zconc0npo4 = concnpo4 * zsizen + + ! Allometric variations of the minimum and maximum quotas + ! From Talmy et al. (2014) and Maranon et al. (2013) + ! ------------------------------------------------------- + xqnnmin(ji,jj,jk) = qnnmin + xqnnmax(ji,jj,jk) = qnnmax + xqndmin(ji,jj,jk) = qndmin * sized(ji,jj,jk)**(-0.27) + xqndmax(ji,jj,jk) = qndmax + xqnpmin(ji,jj,jk) = qnpmin + xqnpmax(ji,jj,jk) = qnpmax + + ! Computation of the optimal allocation parameters + ! Based on the different papers by Pahlow et al., and Smith et al. + ! ----------------------------------------------------------------- + znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0nnh4, & + & trb(ji,jj,jk,jpno3) / zconc0n) + fanano = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = trb(ji,jj,jk,jppo4) / zconc0npo4 + fananop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = biron(ji,jj,jk) / zconcnfe + fananof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0pnh4, & + & trb(ji,jj,jk,jpno3) / zconc0p) + fapico = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = trb(ji,jj,jk,jppo4) / zconc0ppo4 + fapicop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = biron(ji,jj,jk) / zconcpfe + fapicof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc1dnh4, & + & trb(ji,jj,jk,jpno3) / zconc1d ) + fadiat = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = trb(ji,jj,jk,jppo4) / zconc0dpo4 + fadiatp = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + znutlim = biron(ji,jj,jk) / zconcdfe + fadiatf = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) ) + ! + ! Michaelis-Menten Limitation term for nutrients Small bacteria + ! ------------------------------------------------------------- + zbactnh4 = trb(ji,jj,jk,jpnh4) / ( concbnh4 + trb(ji,jj,jk,jpnh4) ) + zbactno3 = trb(ji,jj,jk,jpno3) / ( concbno3 + trb(ji,jj,jk,jpno3) ) * (1. - zbactnh4) + ! + zlim1 = zbactno3 + zbactnh4 + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbpo4) + zlim3 = biron(ji,jj,jk) / ( concbfe + biron(ji,jj,jk) ) + zlim4 = trb(ji,jj,jk,jpdoc) / ( xkdoc + trb(ji,jj,jk,jpdoc) ) + xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) + xlimbac (ji,jj,jk) = xlimbacl(ji,jj,jk) * zlim4 + ! + ! Michaelis-Menten Limitation term for nutrients Small flagellates + ! ----------------------------------------------- + zfalim = (1.-fanano) / fanano + xnanonh4(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0nnh4 + trb(ji,jj,jk,jpnh4) ) + xnanono3(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0n + trb(ji,jj,jk,jpno3) ) & + & * (1. - xnanonh4(ji,jj,jk)) + ! + zfalim = (1.-fananop) / fananop + xnanopo4(ji,jj,jk) = (1. - fananop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0npo4 ) + xnanodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc ) & + & * ( 1.0 - xnanopo4(ji,jj,jk) ) + xnanodop(ji,jj,jk) = 0. + ! + zfalim = (1.-fananof) / fananof + xnanofer(ji,jj,jk) = (1. - fananof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcnfe ) + ! + zratiof = trb(ji,jj,jk,jpnfe) * z1_trnphy + zqfemn = xcoef1 * znanochl + xcoef2 + xcoef3 * xnanono3(ji,jj,jk) + ! + zration = trb(ji,jj,jk,jpnph) * z1_trnphy + zration = MIN(xqnnmax(ji,jj,jk), MAX( 2. * xqnnmin(ji,jj,jk), zration )) + fvnuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnnmin(ji,jj,jk) / (zration + rtrn) & + & * MAX(0., (1. - zratchl * znanochl / 12. ) ) + ! + zlim1 = max(0., (zration - 2. * xqnnmin(ji,jj,jk) ) & + & / (xqnnmax(ji,jj,jk) - 2. * xqnnmin(ji,jj,jk) ) ) * xqnnmax(ji,jj,jk) & + & / (zration + rtrn) + zlim3 = MAX( 0.,( zratiof - zqfemn ) / qfnopt ) + xlimnfe(ji,jj,jk) = MIN( 1., zlim3 ) + xlimphy(ji,jj,jk) = MIN( 1., zlim1, zlim3 ) + ! + ! Michaelis-Menten Limitation term for nutrients picophytoplankton + ! ---------------------------------------------------------------- + zfalim = (1.-fapico) / fapico + xpiconh4(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0pnh4 + trb(ji,jj,jk,jpnh4) ) + xpicono3(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0p + trb(ji,jj,jk,jpno3) ) & + & * (1. - xpiconh4(ji,jj,jk)) + ! + zfalim = (1.-fapicop) / fapicop + xpicopo4(ji,jj,jk) = (1. - fapicop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0ppo4 ) + xpicodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc ) & + & * ( 1.0 - xpicopo4(ji,jj,jk) ) + xpicodop(ji,jj,jk) = 0. + ! + zfalim = (1.-fapicof) / fapicof + xpicofer(ji,jj,jk) = (1. - fapicof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcpfe ) + ! + zratiof = trb(ji,jj,jk,jppfe) * z1_trnpic + zqfemp = xcoef1 * zpicochl + xcoef2 + xcoef3 * xpicono3(ji,jj,jk) + ! + zration = trb(ji,jj,jk,jpnpi) * z1_trnpic + zration = MIN(xqnpmax(ji,jj,jk), MAX( 2. * xqnpmin(ji,jj,jk), zration )) + fvpuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnpmin(ji,jj,jk) / (zration + rtrn) & + & * MAX(0., (1. - zratchl * zpicochl / 12. ) ) + ! + zlim1 = max(0., (zration - 2. * xqnpmin(ji,jj,jk) ) & + & / (xqnpmax(ji,jj,jk) - 2. * xqnpmin(ji,jj,jk) ) ) * xqnpmax(ji,jj,jk) & + & / (zration + rtrn) + zlim3 = MAX( 0.,( zratiof - zqfemp ) / qfpopt ) + xlimpfe(ji,jj,jk) = MIN( 1., zlim3 ) + xlimpic(ji,jj,jk) = MIN( 1., zlim1, zlim3 ) + ! + ! Michaelis-Menten Limitation term for nutrients Diatoms + ! ------------------------------------------------------ + zfalim = (1.-fadiat) / fadiat + xdiatnh4(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc1dnh4 + trb(ji,jj,jk,jpnh4) ) + xdiatno3(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc1d + trb(ji,jj,jk,jpno3) ) & + & * (1. - xdiatnh4(ji,jj,jk)) + ! + zfalim = (1.-fadiatp) / fadiatp + xdiatpo4(ji,jj,jk) = (1. - fadiatp) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0dpo4 ) + xdiatdop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc ) & + & * ( 1.0 - xdiatpo4(ji,jj,jk) ) + xdiatdop(ji,jj,jk) = 0. + ! + zfalim = (1.-fadiatf) / fadiatf + xdiatfer(ji,jj,jk) = (1. - fadiatf) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcdfe ) + ! + zratiof = trb(ji,jj,jk,jpdfe) * z1_trndia + zqfemd = xcoef1 * zdiatchl + xcoef2 + xcoef3 * xdiatno3(ji,jj,jk) + ! + zration = trb(ji,jj,jk,jpndi) * z1_trndia + zration = MIN(xqndmax(ji,jj,jk), MAX( 2. * xqndmin(ji,jj,jk), zration )) + fvduptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqndmin(ji,jj,jk) / (zration + rtrn) & + & * MAX(0., (1. - zratchl * zdiatchl / 12. ) ) + ! + zlim1 = max(0., (zration - 2. * xqndmin(ji,jj,jk) ) & + & / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) ) & + & * xqndmax(ji,jj,jk) / (zration + rtrn) + zlim3 = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) ) + zlim4 = MAX( 0., ( zratiof - zqfemd ) / qfdopt ) + xlimdfe(ji,jj,jk) = MIN( 1., zlim4 ) + xlimdia(ji,jj,jk) = MIN( 1., zlim1, zlim3, zlim4 ) + xlimsi(ji,jj,jk) = MIN( zlim1, zlim4 ) + END DO + END DO + END DO + ! + ! Compute the phosphorus quota values. It is based on Litchmann et al., 2004 and Daines et al, 2013. + ! The relative contribution of three fonctional pools are computed: light harvesting apparatus, + ! nutrient uptake pool and assembly machinery. DNA is assumed to represent 1% of the dry mass of + ! phytoplankton (see Daines et al., 2013). + ! -------------------------------------------------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! Size estimation of nanophytoplankton + ! ------------------------------------ + zfvn = 2. * fvnuptk(ji,jj,jk) + sizen(ji,jj,jk) = MAX(1., MIN(xsizern, 1.0 / ( MAX(rtrn, zfvn) ) ) ) + + ! N/P ratio of nanophytoplankton + ! ------------------------------ + zfuptk = 0.23 * zfvn + zrpho = 2.24 * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpnph) * rno3 * 15. + rtrn ) + zrass = 1. - 0.2 - zrpho - zfuptk + xqpnmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16. + xqpnmax(ji,jj,jk) = xqpnmax(ji,jj,jk) * trb(ji,jj,jk,jpnph) / ( trb(ji,jj,jk,jpphy) + rtrn ) + 0.13 + xqpnmin(ji,jj,jk) = 0.13 + 0.23 * 0.0128 * 16. + + ! Size estimation of picophytoplankton + ! ------------------------------------ + zfvn = 2. * fvpuptk(ji,jj,jk) + sizep(ji,jj,jk) = MAX(1., MIN(xsizerp, 1.0 / ( MAX(rtrn, zfvn) ) ) ) + + ! N/P ratio of picophytoplankton + ! ------------------------------ + zfuptk = 0.35 * zfvn + zrpho = 2.24 * trb(ji,jj,jk,jppch) / ( trb(ji,jj,jk,jpnpi) * rno3 * 15. + rtrn ) + zrass = 1. - 0.4 - zrpho - zfuptk + xqppmax(ji,jj,jk) = (zrpho + zfuptk) * 0.0128 * 16. + zrass * 1./ 9. * 16. + xqppmax(ji,jj,jk) = xqppmax(ji,jj,jk) * trb(ji,jj,jk,jpnpi) / ( trb(ji,jj,jk,jppic) + rtrn ) + 0.13 + xqppmin(ji,jj,jk) = 0.13 + + ! Size estimation of diatoms + ! -------------------------- + zfvn = 2. * fvduptk(ji,jj,jk) + sized(ji,jj,jk) = MAX(1., MIN(xsizerd, 1.0 / ( MAX(rtrn, zfvn) ) ) ) + zcoef = trb(ji,jj,jk,jpdia) - MIN(xsizedia, trb(ji,jj,jk,jpdia) ) + sized(ji,jj,jk) = 1. + xsizerd * zcoef *1E6 / ( 1. + zcoef * 1E6 ) + + ! N/P ratio of diatoms + ! -------------------- + zfuptk = 0.2 * zfvn + zrpho = 2.24 * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpndi) * rno3 * 15. + rtrn ) + zrass = 1. - 0.2 - zrpho - zfuptk + xqpdmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16. + xqpdmax(ji,jj,jk) = xqpdmax(ji,jj,jk) * trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + 0.13 + xqpdmin(ji,jj,jk) = 0.13 + 0.2 * 0.0128 * 16. + + END DO + END DO + END DO + + ! Compute the fraction of nanophytoplankton that is made of calcifiers + ! -------------------------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zlim1 = trb(ji,jj,jk,jpnh4) / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) + trb(ji,jj,jk,jpno3) & + & / ( trb(ji,jj,jk,jpno3) + concnno3 ) * ( 1.0 - trb(ji,jj,jk,jpnh4) & + & / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) ) + zlim2 = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnpo4 ) + zlim3 = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) + 5.E-11 ) + ztem1 = MAX( 0., tsn(ji,jj,jk,jp_tem) ) + ztem2 = tsn(ji,jj,jk,jp_tem) - 10. + zetot1 = MAX( 0., etot(ji,jj,jk) - 1.) / ( 4. + etot(ji,jj,jk) ) * 20. / ( 20. + etot(ji,jj,jk) ) + +! xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 ) & + xfracal(ji,jj,jk) = caco3r & + & * ztem1 / ( 1. + ztem1 ) * MAX( 1., trb(ji,jj,jk,jpphy)*1E6 ) & + & * ( 1. + EXP(-ztem2 * ztem2 / 25. ) ) & + & * zetot1 * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) ) + xfracal(ji,jj,jk) = MAX( 0.02, MIN( 0.8 , xfracal(ji,jj,jk) ) ) + END DO + END DO + END DO + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! denitrification factor computed from O2 levels + nitrfac(ji,jj,jk) = MAX( 0.e0, 0.4 * ( 6.e-6 - trb(ji,jj,jk,jpoxy) ) & + & / ( oxymin + trb(ji,jj,jk,jpoxy) ) ) + nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) ) + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN ! save output diagnostics + CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) ) ! euphotic layer deptht + CALL iom_put( "LNnut" , xlimphy(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term + CALL iom_put( "LPnut" , xlimpic(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term + CALL iom_put( "LDnut" , xlimdia(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term + CALL iom_put( "LNFe" , xlimnfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "LPFe" , xlimpfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "LDFe" , xlimdfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "SIZEN" , sizen (:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "SIZEP" , sizep (:,:,:) * tmask(:,:,:) ) ! Iron limitation term + CALL iom_put( "SIZED" , sized (:,:,:) * tmask(:,:,:) ) ! Iron limitation term + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_lim') + ! + END SUBROUTINE p5z_lim + + + SUBROUTINE p5z_lim_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_lim_init *** + !! + !! ** Purpose : Initialization of nutrient limitation parameters + !! + !! ** Method : Read the nampislim and nampisquota namelists and check + !! the parameters called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampislim + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namp5zlim/ concnno3, concpno3, concdno3, concnnh4, concpnh4, concdnh4, & + & concnfer, concpfer, concdfer, concbfe, concnpo4, concppo4, & + & concdpo4, concbno3, concbnh4, concbpo4, xsizedia, xsizepic, & + & xsizephy, xsizern, xsizerp, xsizerd, xksi1, xksi2, xkdoc, & + & caco3r, oxymin + ! + NAMELIST/namp5zquota/ qnnmin, qnnmax, qpnmin, qpnmax, qnpmin, qnpmax, qppmin, & + & qppmax, qndmin, qndmax, qpdmin, qpdmax, qfnmax, qfpmax, qfdmax, & + & qfnopt, qfpopt, qfdopt + !!---------------------------------------------------------------------- + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp5zlim, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampislim in reference namelist' ) + ! + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp5zlim, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampislim in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zlim ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zlim' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' mean rainratio caco3r = ', caco3r + WRITE(numout,*) ' NO3 half saturation of nanophyto concnno3 = ', concnno3 + WRITE(numout,*) ' NO3 half saturation of picophyto concpno3 = ', concpno3 + WRITE(numout,*) ' NO3 half saturation of diatoms concdno3 = ', concdno3 + WRITE(numout,*) ' NH4 half saturation for phyto concnnh4 = ', concnnh4 + WRITE(numout,*) ' NH4 half saturation for pico concpnh4 = ', concpnh4 + WRITE(numout,*) ' NH4 half saturation for diatoms concdnh4 = ', concdnh4 + WRITE(numout,*) ' PO4 half saturation for phyto concnpo4 = ', concnpo4 + WRITE(numout,*) ' PO4 half saturation for pico concppo4 = ', concppo4 + WRITE(numout,*) ' PO4 half saturation for diatoms concdpo4 = ', concdpo4 + WRITE(numout,*) ' half saturation constant for Si uptake xksi1 = ', xksi1 + WRITE(numout,*) ' half saturation constant for Si/C xksi2 = ', xksi2 + WRITE(numout,*) ' half-sat. of DOC remineralization xkdoc = ', xkdoc + WRITE(numout,*) ' Iron half saturation for nanophyto concnfer = ', concnfer + WRITE(numout,*) ' Iron half saturation for picophyto concpfer = ', concpfer + WRITE(numout,*) ' Iron half saturation for diatoms concdfer = ', concdfer + WRITE(numout,*) ' size ratio for nanophytoplankton xsizern = ', xsizern + WRITE(numout,*) ' size ratio for picophytoplankton xsizerp = ', xsizerp + WRITE(numout,*) ' size ratio for diatoms xsizerd = ', xsizerd + WRITE(numout,*) ' NO3 half saturation of bacteria concbno3 = ', concbno3 + WRITE(numout,*) ' NH4 half saturation for bacteria concbnh4 = ', concbnh4 + WRITE(numout,*) ' Minimum size criteria for diatoms xsizedia = ', xsizedia + WRITE(numout,*) ' Minimum size criteria for picophyto xsizepic = ', xsizepic + WRITE(numout,*) ' Minimum size criteria for nanophyto xsizephy = ', xsizephy + WRITE(numout,*) ' Fe half saturation for bacteria concbfe = ', concbfe + WRITE(numout,*) ' halk saturation constant for anoxia oxymin =' , oxymin + ENDIF + + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp5zquota, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisquota in reference namelist' ) + ! + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp5zquota, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampisquota in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zquota ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zquota' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' optimal Fe quota for nano. qfnopt = ', qfnopt + WRITE(numout,*) ' optimal Fe quota for pico. qfpopt = ', qfpopt + WRITE(numout,*) ' Optimal Fe quota for diatoms qfdopt = ', qfdopt + WRITE(numout,*) ' Minimal N quota for nano qnnmin = ', qnnmin + WRITE(numout,*) ' Maximal N quota for nano qnnmax = ', qnnmax + WRITE(numout,*) ' Minimal P quota for nano qpnmin = ', qpnmin + WRITE(numout,*) ' Maximal P quota for nano qpnmax = ', qpnmax + WRITE(numout,*) ' Minimal N quota for pico qnpmin = ', qnpmin + WRITE(numout,*) ' Maximal N quota for pico qnpmax = ', qnpmax + WRITE(numout,*) ' Minimal P quota for pico qppmin = ', qppmin + WRITE(numout,*) ' Maximal P quota for pico qppmax = ', qppmax + WRITE(numout,*) ' Minimal N quota for diatoms qndmin = ', qndmin + WRITE(numout,*) ' Maximal N quota for diatoms qndmax = ', qndmax + WRITE(numout,*) ' Minimal P quota for diatoms qpdmin = ', qpdmin + WRITE(numout,*) ' Maximal P quota for diatoms qpdmax = ', qpdmax + WRITE(numout,*) ' Maximal Fe quota for nanophyto. qfnmax = ', qfnmax + WRITE(numout,*) ' Maximal Fe quota for picophyto. qfpmax = ', qfpmax + WRITE(numout,*) ' Maximal Fe quota for diatoms qfdmax = ', qfdmax + ENDIF + ! + zpsino3 = 2.3 * rno3 + zpsinh4 = 1.8 * rno3 + zpsiuptk = 2.3 * rno3 + ! + nitrfac(:,:,jpk) = 0._wp + xfracal(:,:,jpk) = 0._wp + xlimphy(:,:,jpk) = 0._wp + xlimpic(:,:,jpk) = 0._wp + xlimdia(:,:,jpk) = 0._wp + xlimnfe(:,:,jpk) = 0._wp + xlimpfe(:,:,jpk) = 0._wp + xlimdfe(:,:,jpk) = 0._wp + sizen (:,:,jpk) = 0._wp + sizep (:,:,jpk) = 0._wp + sized (:,:,jpk) = 0._wp + ! + END SUBROUTINE p5z_lim_init + + + INTEGER FUNCTION p5z_lim_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_lim_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp , ONLY: ctl_stop + INTEGER :: ierr(2) ! Local variables + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + !* Biological arrays for phytoplankton growth + ALLOCATE( xpicono3(jpi,jpj,jpk), xpiconh4(jpi,jpj,jpk), & + & xpicopo4(jpi,jpj,jpk), xpicodop(jpi,jpj,jpk), & + & xnanodop(jpi,jpj,jpk), xdiatdop(jpi,jpj,jpk), & + & xnanofer(jpi,jpj,jpk), xdiatfer(jpi,jpj,jpk), & + & xpicofer(jpi,jpj,jpk), xlimpfe (jpi,jpj,jpk), & + & fvnuptk (jpi,jpj,jpk), fvduptk (jpi,jpj,jpk), & + & fvpuptk (jpi,jpj,jpk), xlimpic (jpi,jpj,jpk), STAT=ierr(1) ) + ! + !* Minimum/maximum quotas of phytoplankton + ALLOCATE( xqnnmin (jpi,jpj,jpk), xqnnmax(jpi,jpj,jpk), & + & xqpnmin (jpi,jpj,jpk), xqpnmax(jpi,jpj,jpk), & + & xqnpmin (jpi,jpj,jpk), xqnpmax(jpi,jpj,jpk), & + & xqppmin (jpi,jpj,jpk), xqppmax(jpi,jpj,jpk), & + & xqndmin (jpi,jpj,jpk), xqndmax(jpi,jpj,jpk), & + & xqpdmin (jpi,jpj,jpk), xqpdmax(jpi,jpj,jpk), STAT=ierr(2) ) + ! + p5z_lim_alloc = MAXVAL( ierr ) + ! + IF( p5z_lim_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p5z_lim_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p5z_lim_alloc + !!====================================================================== +END MODULE p5zlim diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmeso.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmeso.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a8971fba34e2a85fa7281a1abade816a9e862fe8 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmeso.F90 @@ -0,0 +1,435 @@ +MODULE p5zmeso + !!====================================================================== + !! *** MODULE p5zmeso *** + !! TOP : PISCES Compute the sources/sinks for mesozooplankton + !!====================================================================== + !! History : 1.0 ! 2002 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p5z_meso : Compute the sources/sinks for mesozooplankton + !! p5z_meso_init : Initialization of the parameters for mesozooplankton + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p5z_meso ! called in p5zbio.F90 + PUBLIC p5z_meso_init ! called in trcsms_pisces.F90 + + !! * Shared module variables + REAL(wp), PUBLIC :: part2 !: part of calcite not dissolved in mesozoo guts + REAL(wp), PUBLIC :: xpref2c !: mesozoo preference for POC + REAL(wp), PUBLIC :: xpref2n !: mesozoo preference for nanophyto + REAL(wp), PUBLIC :: xpref2z !: mesozoo preference for zooplankton + REAL(wp), PUBLIC :: xpref2d !: mesozoo preference for Diatoms + REAL(wp), PUBLIC :: xpref2m !: mesozoo preference for mesozoo + REAL(wp), PUBLIC :: xthresh2zoo !: zoo feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2dia !: diatoms feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2phy !: nanophyto feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2poc !: poc feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2mes !: mesozoo feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: xthresh2 !: feeding threshold for mesozooplankton + REAL(wp), PUBLIC :: resrat2 !: exsudation rate of mesozooplankton + REAL(wp), PUBLIC :: mzrat2 !: microzooplankton mortality rate + REAL(wp), PUBLIC :: grazrat2 !: maximal mesozoo grazing rate + REAL(wp), PUBLIC :: xkgraz2 !: Half-saturation constant of assimilation + REAL(wp), PUBLIC :: unass2c !: Non-assimilated fraction of food + REAL(wp), PUBLIC :: unass2n !: Non-assimilated fraction of food + REAL(wp), PUBLIC :: unass2p !: Non-assimilated fraction of food + REAL(wp), PUBLIC :: epsher2 !: Growth efficiency of mesozoo + REAL(wp), PUBLIC :: epsher2min !: Minimum growth efficiency of mesozoo + REAL(wp), PUBLIC :: ssigma2 !: Fraction excreted as semi-labile DOM + REAL(wp), PUBLIC :: srespir2 !: Active respiration + REAL(wp), PUBLIC :: grazflux !: mesozoo flux feeding rate + LOGICAL, PUBLIC :: bmetexc2 !: Use of excess carbon for respiration + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p5zmeso.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE p5z_meso( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_meso *** + !! + !! ** Purpose : Compute the sources/sinks for mesozooplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, knt ! ocean time step + INTEGER :: ji, jj, jk + REAL(wp) :: zcompadi, zcompaph, zcompapoc, zcompaz, zcompam, zcompames + REAL(wp) :: zgraze2, zdenom, zfact, zfood, zfoodlim, zproport + REAL(wp) :: zmortzgoc, zfracc, zfracn, zfracp, zfracfe, zratio, zratio2 + REAL(wp) :: zepsherf, zepshert, zepsherv, zrespirc, zrespirn, zrespirp, zbasresb, zbasresi + REAL(wp) :: zgraztotc, zgraztotn, zgraztotp, zgraztotf, zbasresn, zbasresp, zbasresf + REAL(wp) :: zgradoc, zgradon, zgradop, zgratmp, zgradoct, zgradont, zgrareft, zgradopt + REAL(wp) :: zgrapoc, zgrapon, zgrapop, zgrapof, zprcaca, zmortz + REAL(wp) :: zexcess, zgrarem, zgraren, zgrarep, zgraref + REAL(wp) :: zbeta, zrespz, ztortz, zgrasratp, zgrasratn, zgrasratf + REAL(wp) :: ztmp1, ztmp2, ztmp3, ztmp4, ztmp5, ztmptot + REAL(wp) :: zgrazdc, zgrazz, zgrazm, zgrazpof, zgrazcal, zfracal + REAL(wp) :: zgraznc, zgrazpoc, zgrazpon, zgrazpop, zgraznf, zgrazdf + REAL(wp) :: zgraznp, zgraznn, zgrazdn, zgrazdp + REAL(wp) :: zgrazfffp, zgrazfffg, zgrazffep, zgrazffeg + REAL(wp) :: zgrazffnp, zgrazffng, zgrazffpp, zgrazffpg + CHARACTER (len=25) :: charout + REAL(wp) :: zrfact2, zmetexcess + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing2, zfezoo2, zz2ligprod + + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_meso') + ! + + zmetexcess = 0.0 + IF ( bmetexc2 ) zmetexcess = 1.0 + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompam = MAX( ( trb(ji,jj,jk,jpmes) - 1.e-9 ), 0.e0 ) + zfact = xstep * tgfunc2(ji,jj,jk) * zcompam + + ! Michaelis-Menten mortality rates of mesozooplankton + ! --------------------------------------------------- + zrespz = resrat2 * zfact * ( trb(ji,jj,jk,jpmes) / ( xkmort + trb(ji,jj,jk,jpmes) ) & + & + 3. * nitrfac(ji,jj,jk) ) + + ! Zooplankton mortality. A square function has been selected with + ! no real reason except that it seems to be more stable and may mimic predation + ! --------------------------------------------------------------- + ztortz = mzrat2 * 1.e6 * zfact * trb(ji,jj,jk,jpmes) * (1. - nitrfac(ji,jj,jk)) + + ! Computation of the abundance of the preys + ! A threshold can be specified in the namelist + ! -------------------------------------------- + zcompadi = MAX( ( trb(ji,jj,jk,jpdia) - xthresh2dia ), 0.e0 ) + zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - xthresh2zoo ), 0.e0 ) + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - xthresh2phy ), 0.e0 ) + zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthresh2poc ), 0.e0 ) + zcompames = MAX( ( trb(ji,jj,jk,jpmes) - xthresh2mes ), 0.e0 ) + + ! Mesozooplankton grazing + ! ------------------------ + zfood = xpref2d * zcompadi + xpref2z * zcompaz + xpref2n * zcompaph + xpref2c * zcompapoc & + & + xpref2m * zcompames + zfoodlim = MAX( 0., zfood - MIN( 0.5 * zfood, xthresh2 ) ) + zdenom = zfoodlim / ( xkgraz2 + zfoodlim ) + zgraze2 = grazrat2 * xstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpmes) * (1. - nitrfac(ji,jj,jk)) + + ! An active switching parameterization is used here. + ! We don't use the KTW parameterization proposed by + ! Vallina et al. because it tends to produce to steady biomass + ! composition and the variance of Chl is too low as it grazes + ! too strongly on winning organisms. Thus, instead of a square + ! a 1.5 power value is used which decreases the pressure on the + ! most abundant species + ! ------------------------------------------------------------ + ztmp1 = xpref2n * zcompaph**1.5 + ztmp2 = xpref2m * zcompames**1.5 + ztmp3 = xpref2c * zcompapoc**1.5 + ztmp4 = xpref2d * zcompadi**1.5 + ztmp5 = xpref2z * zcompaz**1.5 + ztmptot = ztmp1 + ztmp2 + ztmp3 + ztmp4 + ztmp5 + rtrn + ztmp1 = ztmp1 / ztmptot + ztmp2 = ztmp2 / ztmptot + ztmp3 = ztmp3 / ztmptot + ztmp4 = ztmp4 / ztmptot + ztmp5 = ztmp5 / ztmptot + + ! Mesozooplankton regular grazing on the different preys + ! ------------------------------------------------------ + zgrazdc = zgraze2 * ztmp4 * zdenom + zgrazdn = zgrazdc * trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn) + zgrazdp = zgrazdc * trb(ji,jj,jk,jppdi) / ( trb(ji,jj,jk,jpdia) + rtrn) + zgrazdf = zgrazdc * trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn) + zgrazz = zgraze2 * ztmp5 * zdenom + zgrazm = zgraze2 * ztmp2 * zdenom + zgraznc = zgraze2 * ztmp1 * zdenom + zgraznn = zgraznc * trb(ji,jj,jk,jpnph) / ( trb(ji,jj,jk,jpphy) + rtrn) + zgraznp = zgraznc * trb(ji,jj,jk,jppph) / ( trb(ji,jj,jk,jpphy) + rtrn) + zgraznf = zgraznc * trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) + rtrn) + zgrazpoc = zgraze2 * ztmp3 * zdenom + zgrazpon = zgrazpoc * trb(ji,jj,jk,jppon) / ( trb(ji,jj,jk,jppoc) + rtrn) + zgrazpop = zgrazpoc * trb(ji,jj,jk,jppop) / ( trb(ji,jj,jk,jppoc) + rtrn) + zgrazpof = zgrazpoc * trb(ji,jj,jk,jpsfe) / ( trb(ji,jj,jk,jppoc) + rtrn) + + ! Mesozooplankton flux feeding on GOC + ! ---------------------------------- + zgrazffeg = grazflux * xstep * wsbio4(ji,jj,jk) & + & * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes) & + & * (1. - nitrfac(ji,jj,jk)) + zgrazfffg = zgrazffeg * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) + zgrazffng = zgrazffeg * trb(ji,jj,jk,jpgon) / (trb(ji,jj,jk,jpgoc) + rtrn) + zgrazffpg = zgrazffeg * trb(ji,jj,jk,jpgop) / (trb(ji,jj,jk,jpgoc) + rtrn) + zgrazffep = grazflux * xstep * wsbio3(ji,jj,jk) & + & * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jppoc) * trb(ji,jj,jk,jpmes) & + & * (1. - nitrfac(ji,jj,jk)) + zgrazfffp = zgrazffep * trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) + zgrazffnp = zgrazffep * trb(ji,jj,jk,jppon) / (trb(ji,jj,jk,jppoc) + rtrn) + zgrazffpp = zgrazffep * trb(ji,jj,jk,jppop) / (trb(ji,jj,jk,jppoc) + rtrn) + ! + zgraztotc = zgrazdc + zgrazz + zgraznc + zgrazm + zgrazpoc + zgrazffep + zgrazffeg + + ! Compute the proportion of filter feeders + ! ---------------------------------------- + zproport = (zgrazffep + zgrazffeg)/(rtrn + zgraztotc) + + ! Compute fractionation of aggregates. It is assumed that + ! diatoms based aggregates are more prone to fractionation + ! since they are more porous (marine snow instead of fecal pellets) + ! ---------------------------------------------------------------- + zratio = trb(ji,jj,jk,jpgsi) / ( trb(ji,jj,jk,jpgoc) + rtrn ) + zratio2 = zratio * zratio + zfracc = zproport * grazflux * xstep * wsbio4(ji,jj,jk) & + & * trb(ji,jj,jk,jpgoc) * trb(ji,jj,jk,jpmes) & + & * ( 0.2 + 3.8 * zratio2 / ( 1.**2 + zratio2 ) ) + zfracfe = zfracc * trb(ji,jj,jk,jpbfe) / (trb(ji,jj,jk,jpgoc) + rtrn) + zfracn = zfracc * trb(ji,jj,jk,jpgon) / (trb(ji,jj,jk,jpgoc) + rtrn) + zfracp = zfracc * trb(ji,jj,jk,jpgop) / (trb(ji,jj,jk,jpgoc) + rtrn) + + zgrazffep = zproport * zgrazffep ; zgrazffeg = zproport * zgrazffeg + zgrazfffp = zproport * zgrazfffp ; zgrazfffg = zproport * zgrazfffg + zgrazffnp = zproport * zgrazffnp ; zgrazffng = zproport * zgrazffng + zgrazffpp = zproport * zgrazffpp ; zgrazffpg = zproport * zgrazffpg + + zgraztotc = zgrazdc + zgrazz + zgraznc + zgrazm + zgrazpoc + zgrazffep + zgrazffeg + zgraztotf = zgrazdf + zgraznf + ( zgrazz + zgrazm ) * ferat3 + zgrazpof & + & + zgrazfffp + zgrazfffg + zgraztotn = zgrazdn + (zgrazm + zgrazz) * no3rat3 + zgraznn + zgrazpon & + & + zgrazffnp + zgrazffng + zgraztotp = zgrazdp + (zgrazz + zgrazm) * po4rat3 + zgraznp + zgrazpop & + & + zgrazffpp + zgrazffpg + + + ! Total grazing ( grazing by microzoo is already computed in p5zmicro ) + zgrazing2(ji,jj,jk) = zgraztotc + + ! Stoichiometruc ratios of the food ingested by zooplanton + ! -------------------------------------------------------- + zgrasratf = (zgraztotf + rtrn) / ( zgraztotc + rtrn ) + zgrasratn = (zgraztotn + rtrn) / ( zgraztotc + rtrn ) + zgrasratp = (zgraztotp + rtrn) / ( zgraztotc + rtrn ) + + ! Growth efficiency is made a function of the quality + ! and the quantity of the preys + ! --------------------------------------------------- + zepshert = MIN( 1., zgrasratn/ no3rat3, zgrasratp/ po4rat3, zgrasratf / ferat3) + zbeta = MAX(0., (epsher2 - epsher2min) ) + zepsherf = epsher2min + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta ) + zepsherv = zepsherf * zepshert + + ! Respiration of mesozooplankton + ! Excess carbon in the food is used preferentially + ! ---------------- ------------------------------ + zexcess = zgraztotc * zepsherf * (1.0 - zepshert) * zmetexcess + zbasresb = MAX(0., zrespz - zexcess) + zbasresi = zexcess + MIN(0., zrespz - zexcess) + zrespirc = srespir2 * zepsherv * zgraztotc + zbasresb + + ! When excess carbon is used, the other elements in excess + ! are also used proportionally to their abundance + ! -------------------------------------------------------- + zexcess = ( zgrasratn/ no3rat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresn = zbasresi * zexcess * zgrasratn + zexcess = ( zgrasratp/ po4rat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresp = zbasresi * zexcess * zgrasratp + zexcess = ( zgrasratf/ ferat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresf = zbasresi * zexcess * zgrasratf + + ! Voiding of the excessive elements as organic matter + ! -------------------------------------------------------- + zgradoct = (1. - unass2c - zepsherv) * zgraztotc - zbasresi + zgradont = (1. - unass2n) * zgraztotn - zepsherv * no3rat3 * zgraztotc - zbasresn + zgradopt = (1. - unass2p) * zgraztotp - zepsherv * po4rat3 * zgraztotc - zbasresp + zgrareft = (1. - unass2c) * zgraztotf - zepsherv * ferat3 * zgraztotc - zbasresf + ztmp1 = ( 1. - epsher2 - unass2c ) /( 1. - 0.8 * epsher2 ) * ztortz + zgradoc = (zgradoct + ztmp1) * ssigma2 + zgradon = (zgradont + no3rat3 * ztmp1) * ssigma2 + zgradop = (zgradopt + po4rat3 * ztmp1) * ssigma2 + zgratmp = 0.2 * epsher2 /( 1. - 0.8 * epsher2 ) * ztortz + + ! Since only semilabile DOM is represented in PISCES + ! part of DOM is in fact labile and is then released + ! as dissolved inorganic compounds (ssigma2) + ! -------------------------------------------------- + zgrarem = zgratmp + ( zgradoct + ztmp1 ) * (1.0 - ssigma2) + zgraren = no3rat3 * zgratmp + ( zgradont + no3rat3 * ztmp1 ) * (1.0 - ssigma2) + zgrarep = po4rat3 * zgratmp + ( zgradopt + po4rat3 * ztmp1 ) * (1.0 - ssigma2) + zgraref = zgrareft + ferat3 * ( ztmp1 + zgratmp ) + + ! Defecation as a result of non assimilated products + ! -------------------------------------------------- + zgrapoc = zgraztotc * unass2c + unass2c / ( 1. - 0.8 * epsher2 ) * ztortz + zgrapon = zgraztotn * unass2n + no3rat3 * unass2n / ( 1. - 0.8 * epsher2 ) * ztortz + zgrapop = zgraztotp * unass2p + po4rat3 * unass2p / ( 1. - 0.8 * epsher2 ) * ztortz + zgrapof = zgraztotf * unass2c + ferat3 * unass2c / ( 1. - 0.8 * epsher2 ) * ztortz + + ! Addition of respiration to the release of inorganic nutrients + ! ------------------------------------------------------------- + zgrarem = zgrarem + zbasresi + zrespirc + zgraren = zgraren + zbasresn + zrespirc * no3rat3 + zgrarep = zgrarep + zbasresp + zrespirc * po4rat3 + zgraref = zgraref + zbasresf + zrespirc * ferat3 + + ! Update the arrays TRA which contain the biological sources and + ! sinks + ! -------------------------------------------------------------- + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zgrarep + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zgraren + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zgradoc + ! + IF( ln_ligand ) THEN + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + zgradoc * ldocz + zz2ligprod(ji,jj,jk) = zgradoc * ldocz + ENDIF + ! + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + zgradon + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + zgradop + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - o2ut * zgrarem + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zgraref + zfezoo2(ji,jj,jk) = zgraref + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrarem + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * zgraren + tra(ji,jj,jk,jpmes) = tra(ji,jj,jk,jpmes) + zepsherv * zgraztotc - zrespirc & + & - ztortz - zgrazm + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zgrazdc + tra(ji,jj,jk,jpndi) = tra(ji,jj,jk,jpndi) - zgrazdn + tra(ji,jj,jk,jppdi) = tra(ji,jj,jk,jppdi) - zgrazdp + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazdf + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) - zgrazz + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgraznc + tra(ji,jj,jk,jpnph) = tra(ji,jj,jk,jpnph) - zgraznn + tra(ji,jj,jk,jppph) = tra(ji,jj,jk,jppph) - zgraznp + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgraznf + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgraznc * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpphy) + rtrn ) + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazdc * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazdc * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazdc * trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) - zgrazpoc - zgrazffep + zfracc + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zfracc + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zgrazpoc - zgrazffep + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) - zgrazpon - zgrazffnp + zfracn + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) - zgrazpop - zgrazffpp + zfracp + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) - zgrazffeg + zgrapoc - zfracc + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zgrapoc + consgoc(ji,jj,jk) = consgoc(ji,jj,jk) - zgrazffeg - zfracc + tra(ji,jj,jk,jpgon) = tra(ji,jj,jk,jpgon) - zgrazffng + zgrapon - zfracn + tra(ji,jj,jk,jpgop) = tra(ji,jj,jk,jpgop) - zgrazffpg + zgrapop - zfracp + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) - zgrazpof - zgrazfffp + zfracfe + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) - zgrazfffg + zgrapof - zfracfe + zfracal = trb(ji,jj,jk,jpcal) / ( trb(ji,jj,jk,jpgoc) + rtrn ) + zgrazcal = zgrazffeg * (1. - part2) * zfracal + + ! calcite production + ! ------------------ + zprcaca = xfracal(ji,jj,jk) * zgraznc + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + zprcaca = part2 * zprcaca + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrazcal - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2. * ( zgrazcal - zprcaca ) + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) - zgrazcal + zprcaca + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + CALL iom_put( "PCAL" , prodcal(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Calcite production + IF( iom_use("GRAZ2") ) THEN ! Total grazing of phyto by zooplankton + zgrazing2(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ2" , zgrazing2(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use("FEZOO2") ) THEN + zfezoo2 (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO2", zfezoo2(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( ln_ligand ) THEN + zz2ligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ2", zz2ligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('meso')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_meso') + ! + END SUBROUTINE p5z_meso + + + SUBROUTINE p5z_meso_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_meso_init *** + !! + !! ** Purpose : Initialization of mesozooplankton parameters + !! + !! ** Method : Read the nampismes namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampismes + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namp5zmes/part2, bmetexc2, grazrat2, resrat2, mzrat2, xpref2c, xpref2n, xpref2z, & + & xpref2m, xpref2d, xthresh2dia, xthresh2phy, xthresh2zoo, xthresh2poc, & + & xthresh2mes, xthresh2, xkgraz2, epsher2, epsher2min, ssigma2, unass2c, & + & unass2n, unass2p, srespir2, grazflux + !!---------------------------------------------------------------------- + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp5zmes, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampismes in reference namelist' ) + ! + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp5zmes, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampismes in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zmes ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for mesozooplankton, namp5zmes' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' part of calcite not dissolved in mesozoo guts part2 = ', part2 + WRITE(numout,*) ' mesozoo preference for nano. xpref2n = ', xpref2n + WRITE(numout,*) ' mesozoo preference for diatoms xpref2d = ', xpref2d + WRITE(numout,*) ' mesozoo preference for zoo xpref2z = ', xpref2z + WRITE(numout,*) ' mesozoo preference for mesozoo xpref2m = ', xpref2m + WRITE(numout,*) ' mesozoo preference for poc xpref2c = ', xpref2c + WRITE(numout,*) ' microzoo feeding threshold for mesozoo xthresh2zoo = ', xthresh2zoo + WRITE(numout,*) ' diatoms feeding threshold for mesozoo xthresh2dia = ', xthresh2dia + WRITE(numout,*) ' nanophyto feeding threshold for mesozoo xthresh2phy = ', xthresh2phy + WRITE(numout,*) ' poc feeding threshold for mesozoo xthresh2poc = ', xthresh2poc + WRITE(numout,*) ' mesozoo feeding threshold for mesozoo xthresh2mes = ', xthresh2mes + WRITE(numout,*) ' feeding threshold for mesozooplankton xthresh2 = ', xthresh2 + WRITE(numout,*) ' exsudation rate of mesozooplankton resrat2 = ', resrat2 + WRITE(numout,*) ' mesozooplankton mortality rate mzrat2 = ', mzrat2 + WRITE(numout,*) ' maximal mesozoo grazing rate grazrat2 = ', grazrat2 + WRITE(numout,*) ' mesozoo flux feeding rate grazflux = ', grazflux + WRITE(numout,*) ' C egested fraction of food by mesozoo unass2c = ', unass2c + WRITE(numout,*) ' N egested fraction of food by mesozoo unass2n = ', unass2n + WRITE(numout,*) ' P egested fraction of food by mesozoo unass2p = ', unass2p + WRITE(numout,*) ' Efficicency of Mesozoo growth epsher2 = ', epsher2 + WRITE(numout,*) ' Minimum Efficiency of Mesozoo growth epsher2min =', epsher2min + WRITE(numout,*) ' Fraction excreted as semi-labile DOM ssigma2 = ', ssigma2 + WRITE(numout,*) ' Active respiration srespir2 = ', srespir2 + WRITE(numout,*) ' half sturation constant for grazing 2 xkgraz2 = ', xkgraz2 + WRITE(numout,*) ' Use excess carbon for respiration bmetexc2 = ', bmetexc2 + ENDIF + ! + END SUBROUTINE p5z_meso_init + + !!====================================================================== +END MODULE p5zmeso diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmicro.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmicro.F90 new file mode 100644 index 0000000000000000000000000000000000000000..179803fc499d251e3bc8aa07c2eb061398b237d7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmicro.F90 @@ -0,0 +1,380 @@ +MODULE p5zmicro + !!====================================================================== + !! *** MODULE p5zmicro *** + !! TOP : PISCES Compute the sources/sinks for microzooplankton + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Quota model for iron + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p5z_micro : Compute the sources/sinks for microzooplankton + !! p5z_micro_init : Initialize and read the appropriate namelist + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim + USE p5zlim ! Phytoplankton limitation terms + USE iom ! I/O manager + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p5z_micro ! called in p5zbio.F90 + PUBLIC p5z_micro_init ! called in trcsms_pisces.F90 + + !! * Shared module variables + REAL(wp), PUBLIC :: part !: part of calcite not dissolved in microzoo guts + REAL(wp), PUBLIC :: xprefc !: microzoo preference for POC + REAL(wp), PUBLIC :: xprefn !: microzoo preference for nanophyto + REAL(wp), PUBLIC :: xprefp !: microzoo preference for picophyto + REAL(wp), PUBLIC :: xprefd !: microzoo preference for diatoms + REAL(wp), PUBLIC :: xprefz !: microzoo preference for microzoo + REAL(wp), PUBLIC :: xthreshdia !: diatoms feeding threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshpic !: picophyto feeding threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshphy !: nanophyto threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshzoo !: microzoo threshold for microzooplankton + REAL(wp), PUBLIC :: xthreshpoc !: poc threshold for microzooplankton + REAL(wp), PUBLIC :: xthresh !: feeding threshold for microzooplankton + REAL(wp), PUBLIC :: resrat !: exsudation rate of microzooplankton + REAL(wp), PUBLIC :: mzrat !: microzooplankton mortality rate + REAL(wp), PUBLIC :: grazrat !: maximal microzoo grazing rate + REAL(wp), PUBLIC :: xkgraz !: Half-saturation constant of assimilation + REAL(wp), PUBLIC :: unassc !: Non-assimilated part of food + REAL(wp), PUBLIC :: unassn !: Non-assimilated part of food + REAL(wp), PUBLIC :: unassp !: Non-assimilated part of food + REAL(wp), PUBLIC :: epsher !: Growth efficiency for microzoo + REAL(wp), PUBLIC :: epshermin !: Minimum growth efficiency for microzoo + REAL(wp), PUBLIC :: srespir !: half sturation constant for grazing 1 + REAL(wp), PUBLIC :: ssigma !: Fraction excreted as semi-labile DOM + LOGICAL, PUBLIC :: bmetexc !: Use of excess carbon for respiration + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p5zmicro.F90 12276 2019-12-20 11:14:26Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE p5z_micro( kt, knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_micro *** + !! + !! ** Purpose : Compute the sources/sinks for microzooplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: knt + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zcompadi, zcompaz , zcompaph, zcompapoc, zcompapon, zcompapop + REAL(wp) :: zcompapi, zgraze , zdenom, zfact, zfood, zfoodlim + REAL(wp) :: ztmp1, ztmp2, ztmp3, ztmp4, ztmp5, ztmptot + REAL(wp) :: zepsherf, zepshert, zepsherv, zrespirc, zrespirn, zrespirp, zbasresb, zbasresi + REAL(wp) :: zgraztotc, zgraztotn, zgraztotp, zgraztotf, zbasresn, zbasresp, zbasresf + REAL(wp) :: zgradoc, zgradon, zgradop, zgraref, zgradoct, zgradont, zgradopt, zgrareft + REAL(wp) :: zexcess, zgraren, zgrarep, zgrarem + REAL(wp) :: zgrapoc, zgrapon, zgrapop, zgrapof, zprcaca, zmortz + REAL(wp) :: zrespz, ztortz, zgrasratf, zgrasratn, zgrasratp + REAL(wp) :: zgraznc, zgraznn, zgraznp, zgrazpoc, zgrazpon, zgrazpop, zgrazpof + REAL(wp) :: zgrazdc, zgrazdn, zgrazdp, zgrazdf, zgraznf, zgrazz + REAL(wp) :: zgrazpc, zgrazpn, zgrazpp, zgrazpf, zbeta, zrfact2, zmetexcess + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo, zzligprod + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_micro') + ! + zmetexcess = 0.0 + IF ( bmetexc ) zmetexcess = 1.0 + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - 1.e-9 ), 0.e0 ) + zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz + + ! Michaelis-Menten mortality rates of microzooplankton + ! ----------------------------------------------------- + zrespz = resrat * zfact * ( trb(ji,jj,jk,jpzoo) / ( xkmort + trb(ji,jj,jk,jpzoo) ) & + & + 3. * nitrfac(ji,jj,jk) ) + + ! Zooplankton mortality. A square function has been selected with + ! no real reason except that it seems to be more stable and may mimic predation. + ! ------------------------------------------------------------------------------ + ztortz = mzrat * 1.e6 * zfact * trb(ji,jj,jk,jpzoo) * (1. - nitrfac(ji,jj,jk)) + + ! Computation of the abundance of the preys + ! A threshold can be specified in the namelist + ! -------------------------------------------- + zcompadi = MIN( MAX( ( trb(ji,jj,jk,jpdia) - xthreshdia ), 0.e0 ), xsizedia ) + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - xthreshphy ), 0.e0 ) + zcompaz = MAX( ( trb(ji,jj,jk,jpzoo) - xthreshzoo ), 0.e0 ) + zcompapi = MAX( ( trb(ji,jj,jk,jppic) - xthreshpic ), 0.e0 ) + zcompapoc = MAX( ( trb(ji,jj,jk,jppoc) - xthreshpoc ), 0.e0 ) + + ! Microzooplankton grazing + ! ------------------------ + zfood = xprefn * zcompaph + xprefc * zcompapoc + xprefd * zcompadi & + & + xprefz * zcompaz + xprefp * zcompapi + zfoodlim = MAX( 0. , zfood - min(xthresh,0.5*zfood) ) + zdenom = zfoodlim / ( xkgraz + zfoodlim ) + zgraze = grazrat * xstep * tgfunc2(ji,jj,jk) * trb(ji,jj,jk,jpzoo) * (1. - nitrfac(ji,jj,jk)) + + ! An active switching parameterization is used here. + ! We don't use the KTW parameterization proposed by + ! Vallina et al. because it tends to produce to steady biomass + ! composition and the variance of Chl is too low as it grazes + ! too strongly on winning organisms. Thus, instead of a square + ! a 1.5 power value is used which decreases the pressure on the + ! most abundant species + ! ------------------------------------------------------------ + ztmp1 = xprefn * zcompaph**1.5 + ztmp2 = xprefp * zcompapi**1.5 + ztmp3 = xprefc * zcompapoc**1.5 + ztmp4 = xprefd * zcompadi**1.5 + ztmp5 = xprefz * zcompaz**1.5 + ztmptot = ztmp1 + ztmp2 + ztmp3 + ztmp4 + ztmp5 + rtrn + ztmp1 = ztmp1 / ztmptot + ztmp2 = ztmp2 / ztmptot + ztmp3 = ztmp3 / ztmptot + ztmp4 = ztmp4 / ztmptot + ztmp5 = ztmp5 / ztmptot + + ! Microzooplankton regular grazing on the different preys + ! ------------------------------------------------------- + zgraznc = zgraze * ztmp1 * zdenom + zgraznn = zgraznc * trb(ji,jj,jk,jpnph) / (trb(ji,jj,jk,jpphy) + rtrn) + zgraznp = zgraznc * trb(ji,jj,jk,jppph) / (trb(ji,jj,jk,jpphy) + rtrn) + zgraznf = zgraznc * trb(ji,jj,jk,jpnfe) / (trb(ji,jj,jk,jpphy) + rtrn) + zgrazpc = zgraze * ztmp2 * zdenom + zgrazpn = zgrazpc * trb(ji,jj,jk,jpnpi) / (trb(ji,jj,jk,jppic) + rtrn) + zgrazpp = zgrazpc * trb(ji,jj,jk,jpppi) / (trb(ji,jj,jk,jppic) + rtrn) + zgrazpf = zgrazpc * trb(ji,jj,jk,jppfe) / (trb(ji,jj,jk,jppic) + rtrn) + zgrazz = zgraze * ztmp5 * zdenom + zgrazpoc = zgraze * ztmp3 * zdenom + zgrazpon = zgrazpoc * trb(ji,jj,jk,jppon) / ( trb(ji,jj,jk,jppoc) + rtrn ) + zgrazpop = zgrazpoc * trb(ji,jj,jk,jppop) / ( trb(ji,jj,jk,jppoc) + rtrn ) + zgrazpof = zgrazpoc* trb(ji,jj,jk,jpsfe) / (trb(ji,jj,jk,jppoc) + rtrn) + zgrazdc = zgraze * ztmp4 * zdenom + zgrazdn = zgrazdc * trb(ji,jj,jk,jpndi) / (trb(ji,jj,jk,jpdia) + rtrn) + zgrazdp = zgrazdc * trb(ji,jj,jk,jppdi) / (trb(ji,jj,jk,jpdia) + rtrn) + zgrazdf = zgrazdc * trb(ji,jj,jk,jpdfe) / (trb(ji,jj,jk,jpdia) + rtrn) + ! + zgraztotc = zgraznc + zgrazpoc + zgrazdc + zgrazz + zgrazpc + zgraztotn = zgraznn + zgrazpn + zgrazpon + zgrazdn + zgrazz * no3rat3 + zgraztotp = zgraznp + zgrazpp + zgrazpop + zgrazdp + zgrazz * po4rat3 + zgraztotf = zgraznf + zgrazpf + zgrazpof + zgrazdf + zgrazz * ferat3 + ! + ! Grazing by microzooplankton + zgrazing(ji,jj,jk) = zgraztotc + + ! Stoichiometruc ratios of the food ingested by zooplanton + ! -------------------------------------------------------- + zgrasratf = (zgraztotf + rtrn) / ( zgraztotc + rtrn ) + zgrasratn = (zgraztotn + rtrn) / ( zgraztotc + rtrn ) + zgrasratp = (zgraztotp + rtrn) / ( zgraztotc + rtrn ) + + ! Growth efficiency is made a function of the quality + ! and the quantity of the preys + ! --------------------------------------------------- + zepshert = MIN( 1., zgrasratn/ no3rat3, zgrasratp/ po4rat3, zgrasratf / ferat3) + zbeta = MAX( 0., (epsher - epshermin) ) + zepsherf = epshermin + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta ) + zepsherv = zepsherf * zepshert + + ! Respiration of microzooplankton + ! Excess carbon in the food is used preferentially + ! ------------------------------------------------ + zexcess = zgraztotc * zepsherf * (1.0 - zepshert) * zmetexcess + zbasresb = MAX(0., zrespz - zexcess) + zbasresi = zexcess + MIN(0., zrespz - zexcess) + zrespirc = srespir * zepsherv * zgraztotc + zbasresb + + ! When excess carbon is used, the other elements in excess + ! are also used proportionally to their abundance + ! -------------------------------------------------------- + zexcess = ( zgrasratn/ no3rat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresn = zbasresi * zexcess * zgrasratn + zexcess = ( zgrasratp/ po4rat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresp = zbasresi * zexcess * zgrasratp + zexcess = ( zgrasratf/ ferat3 - zepshert ) / ( 1.0 - zepshert + rtrn) + zbasresf = zbasresi * zexcess * zgrasratf + + ! Voiding of the excessive elements as DOM + ! ---------------------------------------- + zgradoct = (1. - unassc - zepsherv) * zgraztotc - zbasresi + zgradont = (1. - unassn) * zgraztotn - zepsherv * no3rat3 * zgraztotc - zbasresn + zgradopt = (1. - unassp) * zgraztotp - zepsherv * po4rat3 * zgraztotc - zbasresp + zgrareft = (1. - unassc) * zgraztotf - zepsherv * ferat3 * zgraztotc - zbasresf + + ! Since only semilabile DOM is represented in PISCES + ! part of DOM is in fact labile and is then released + ! as dissolved inorganic compounds (ssigma) + ! -------------------------------------------------- + zgradoc = zgradoct * ssigma + zgradon = zgradont * ssigma + zgradop = zgradopt * ssigma + zgrarem = (1.0 - ssigma) * zgradoct + zgraren = (1.0 - ssigma) * zgradont + zgrarep = (1.0 - ssigma) * zgradopt + zgraref = zgrareft + + ! Defecation as a result of non assimilated products + ! -------------------------------------------------- + zgrapoc = zgraztotc * unassc + zgrapon = zgraztotn * unassn + zgrapop = zgraztotp * unassp + zgrapof = zgraztotf * unassc + + ! Addition of respiration to the release of inorganic nutrients + ! ------------------------------------------------------------- + zgrarem = zgrarem + zbasresi + zrespirc + zgraren = zgraren + zbasresn + zrespirc * no3rat3 + zgrarep = zgrarep + zbasresp + zrespirc * po4rat3 + zgraref = zgraref + zbasresf + zrespirc * ferat3 + + ! Update of the TRA arrays + ! ------------------------ + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) + zgrarep + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) + zgraren + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + zgradoc + ! + IF( ln_ligand ) THEN + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + zgradoc * ldocz + zzligprod(ji,jj,jk) = zgradoc * ldocz + ENDIF + ! + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + zgradon + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + zgradop + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) - o2ut * zgrarem + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + zgraref + zfezoo(ji,jj,jk) = zgraref + tra(ji,jj,jk,jpzoo) = tra(ji,jj,jk,jpzoo) + zepsherv * zgraztotc - zrespirc - ztortz - zgrazz + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zgraznc + tra(ji,jj,jk,jpnph) = tra(ji,jj,jk,jpnph) - zgraznn + tra(ji,jj,jk,jppph) = tra(ji,jj,jk,jppph) - zgraznp + tra(ji,jj,jk,jppic) = tra(ji,jj,jk,jppic) - zgrazpc + tra(ji,jj,jk,jpnpi) = tra(ji,jj,jk,jpnpi) - zgrazpn + tra(ji,jj,jk,jpppi) = tra(ji,jj,jk,jpppi) - zgrazpp + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zgrazdc + tra(ji,jj,jk,jpndi) = tra(ji,jj,jk,jpndi) - zgrazdn + tra(ji,jj,jk,jppdi) = tra(ji,jj,jk,jppdi) - zgrazdp + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zgraznc * trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) + tra(ji,jj,jk,jppch) = tra(ji,jj,jk,jppch) - zgrazpc * trb(ji,jj,jk,jppch)/(trb(ji,jj,jk,jppic)+rtrn) + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zgrazdc * trb(ji,jj,jk,jpdch)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zgrazdc * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zgrazdc * trb(ji,jj,jk,jpdsi)/(trb(ji,jj,jk,jpdia)+rtrn) + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zgraznf + tra(ji,jj,jk,jppfe) = tra(ji,jj,jk,jppfe) - zgrazpf + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zgrazdf + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + ztortz + zgrapoc - zgrazpoc + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + ztortz + zgrapoc + conspoc(ji,jj,jk) = conspoc(ji,jj,jk) - zgrazpoc + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + no3rat3 * ztortz + zgrapon - zgrazpon + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + po4rat3 * ztortz + zgrapop - zgrazpop + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + ferat3 * ztortz + zgrapof - zgrazpof + ! + ! calcite production + zprcaca = xfracal(ji,jj,jk) * zgraznc + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + ! + zprcaca = part * zprcaca + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + zgrarem - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2. * zprcaca & + & + rno3 * zgraren + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) + zprcaca + END DO + END DO + END DO + ! + IF( lk_iomput .AND. knt == nrdttrc ) THEN + IF( iom_use("GRAZ1") ) THEN ! Total grazing of phyto by zooplankton + zgrazing(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ1" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( iom_use("FEZOO") ) THEN + zfezoo (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO" , zfezoo(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) ) + ENDIF + IF( ln_ligand ) THEN + zzligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ", zzligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:)) + ENDIF + ENDIF + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('micro')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_micro') + ! + END SUBROUTINE p5z_micro + + + SUBROUTINE p5z_micro_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_micro_init *** + !! + !! ** Purpose : Initialization of microzooplankton parameters + !! + !! ** Method : Read the nampiszoo namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampiszoo + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namp5zzoo/ part, grazrat, bmetexc, resrat, mzrat, xprefc, xprefn, & + & xprefp, xprefd, xprefz, xthreshdia, xthreshphy, & + & xthreshpic, xthreshpoc, xthreshzoo, xthresh, xkgraz, & + & epsher, epshermin, ssigma, srespir, unassc, unassn, unassp + !!---------------------------------------------------------------------- + ! + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp5zzoo, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp5zzoo in reference namelist' ) + ! + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp5zzoo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp5zzoo in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zzoo ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for microzooplankton, nampiszooq' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' part of calcite not dissolved in microzoo guts part =', part + WRITE(numout,*) ' microzoo preference for POC xprefc =', xprefc + WRITE(numout,*) ' microzoo preference for nano xprefn =', xprefn + WRITE(numout,*) ' microzoo preference for pico xprefp =', xprefp + WRITE(numout,*) ' microzoo preference for diatoms xprefd =', xprefd + WRITE(numout,*) ' microzoo preference for microzoo xprefz =', xprefz + WRITE(numout,*) ' diatoms feeding threshold for microzoo xthreshdia =', xthreshdia + WRITE(numout,*) ' nanophyto feeding threshold for microzoo xthreshphy =', xthreshphy + WRITE(numout,*) ' picophyto feeding threshold for microzoo xthreshpic =', xthreshpic + WRITE(numout,*) ' poc feeding threshold for microzoo xthreshpoc =', xthreshpoc + WRITE(numout,*) ' microzoo feeding threshold for microzoo xthreshzoo =', xthreshzoo + WRITE(numout,*) ' feeding threshold for microzooplankton xthresh =', xthresh + WRITE(numout,*) ' exsudation rate of microzooplankton resrat =', resrat + WRITE(numout,*) ' microzooplankton mortality rate mzrat =', mzrat + WRITE(numout,*) ' maximal microzoo grazing rate grazrat =', grazrat + WRITE(numout,*) ' C egested fraction of fodd by microzoo unassc =', unassc + WRITE(numout,*) ' N egested fraction of fodd by microzoo unassn =', unassn + WRITE(numout,*) ' P egested fraction of fodd by microzoo unassp =', unassp + WRITE(numout,*) ' Efficicency of microzoo growth epsher =', epsher + WRITE(numout,*) ' Minimum Efficiency of Microzoo growth epshermin =', epshermin + WRITE(numout,*) ' Fraction excreted as semi-labile DOM ssigma =', ssigma + WRITE(numout,*) ' Active respiration srespir =', srespir + WRITE(numout,*) ' half sturation constant for grazing 1 xkgraz =', xkgraz + WRITE(numout,*) ' Use of excess carbon for respiration bmetexc =', bmetexc + ENDIF + ! + END SUBROUTINE p5z_micro_init + + !!====================================================================== +END MODULE p5zmicro diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmort.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmort.F90 new file mode 100644 index 0000000000000000000000000000000000000000..20a2ad1dc21dc731c3bbe0b1ecfd0a27f107f3f2 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zmort.F90 @@ -0,0 +1,313 @@ +MODULE p5zmort + !!====================================================================== + !! *** MODULE p5zmort *** + !! TOP : PISCES Compute the mortality terms for phytoplankton + !!====================================================================== + !! History : 1.0 ! 2002 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p5z_mort : Compute the mortality terms for phytoplankton + !! p5z_mort_init : Initialize the mortality params for phytoplankton + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim + USE p5zlim ! Phytoplankton limitation terms + USE prtctl_trc ! print control for debugging + + IMPLICIT NONE + PRIVATE + + PUBLIC p5z_mort + PUBLIC p5z_mort_init + + !! * Shared module variables + REAL(wp), PUBLIC :: wchln !: + REAL(wp), PUBLIC :: wchlp !: + REAL(wp), PUBLIC :: wchld !: + REAL(wp), PUBLIC :: wchldm !: + REAL(wp), PUBLIC :: mpratn !: + REAL(wp), PUBLIC :: mpratp !: + REAL(wp), PUBLIC :: mpratd !: + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p5zmort.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE p5z_mort( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_mort *** + !! + !! ** Purpose : Calls the different subroutine to initialize and compute + !! the different phytoplankton mortality terms + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + + CALL p5z_nano ! nanophytoplankton + CALL p5z_pico ! picophytoplankton + CALL p5z_diat ! diatoms + + END SUBROUTINE p5z_mort + + + SUBROUTINE p5z_nano + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_nano *** + !! + !! ** Purpose : Compute the mortality terms for nanophytoplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zcompaph + REAL(wp) :: zfactfe, zfactch, zfactn, zfactp, zprcaca + REAL(wp) :: ztortp , zrespp , zmortp + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_nano') + ! + prodcal(:,:,:) = 0. !: calcite production variable set to zero + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompaph = MAX( ( trb(ji,jj,jk,jpphy) - 1e-9 ), 0.e0 ) + ! Squared mortality of Phyto similar to a sedimentation term during + ! blooms (Doney et al. 1996) + ! ----------------------------------------------------------------- + zrespp = wchln * 1.e6 * xstep * xdiss(ji,jj,jk) * zcompaph * trb(ji,jj,jk,jpphy) + + ! Phytoplankton linear mortality + ! ------------------------------ + ztortp = mpratn * xstep * zcompaph + zmortp = zrespp + ztortp + + ! Update the arrays TRA which contains the biological sources and sinks + + zfactn = trb(ji,jj,jk,jpnph)/(trb(ji,jj,jk,jpphy)+rtrn) + zfactp = trb(ji,jj,jk,jppph)/(trb(ji,jj,jk,jpphy)+rtrn) + zfactfe = trb(ji,jj,jk,jpnfe)/(trb(ji,jj,jk,jpphy)+rtrn) + zfactch = trb(ji,jj,jk,jpnch)/(trb(ji,jj,jk,jpphy)+rtrn) + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) - zmortp + tra(ji,jj,jk,jpnph) = tra(ji,jj,jk,jpnph) - zmortp * zfactn + tra(ji,jj,jk,jppph) = tra(ji,jj,jk,jppph) - zmortp * zfactp + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) - zmortp * zfactch + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) - zmortp * zfactfe + zprcaca = xfracal(ji,jj,jk) * zmortp + ! + prodcal(ji,jj,jk) = prodcal(ji,jj,jk) + zprcaca ! prodcal=prodcal(nanophy)+prodcal(microzoo)+prodcal(mesozoo) + ! + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) - zprcaca + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) - 2. * zprcaca + tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) + zprcaca + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zmortp + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + zmortp * zfactn + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + zmortp * zfactp + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zmortp + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zmortp * zfactfe + END DO + END DO + END DO + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('nano')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_nano') + ! + END SUBROUTINE p5z_nano + + + SUBROUTINE p5z_pico + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_pico *** + !! + !! ** Purpose : Compute the mortality terms for picophytoplankton + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zcompaph + REAL(wp) :: zfactfe, zfactch, zfactn, zfactp + REAL(wp) :: ztortp , zrespp , zmortp + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_pico') + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcompaph = MAX( ( trb(ji,jj,jk,jppic) - 1e-9 ), 0.e0 ) + ! Squared mortality of Phyto similar to a sedimentation term during + ! blooms (Doney et al. 1996) + ! ----------------------------------------------------------------- + zrespp = wchlp * 1.e6 * xstep * xdiss(ji,jj,jk) * zcompaph * trb(ji,jj,jk,jppic) + + ! Phytoplankton mortality + ztortp = mpratp * xstep * zcompaph + zmortp = zrespp + ztortp + + ! Update the arrays TRA which contains the biological sources and sinks + + zfactn = trb(ji,jj,jk,jpnpi)/(trb(ji,jj,jk,jppic)+rtrn) + zfactp = trb(ji,jj,jk,jpppi)/(trb(ji,jj,jk,jppic)+rtrn) + zfactfe = trb(ji,jj,jk,jppfe)/(trb(ji,jj,jk,jppic)+rtrn) + zfactch = trb(ji,jj,jk,jppch)/(trb(ji,jj,jk,jppic)+rtrn) + tra(ji,jj,jk,jppic) = tra(ji,jj,jk,jppic) - zmortp + tra(ji,jj,jk,jpnpi) = tra(ji,jj,jk,jpnpi) - zmortp * zfactn + tra(ji,jj,jk,jpppi) = tra(ji,jj,jk,jpppi) - zmortp * zfactp + tra(ji,jj,jk,jppch) = tra(ji,jj,jk,jppch) - zmortp * zfactch + tra(ji,jj,jk,jppfe) = tra(ji,jj,jk,jppfe) - zmortp * zfactfe + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + zmortp + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + zmortp * zfactn + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + zmortp * zfactp + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zmortp * zfactfe + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zmortp + END DO + END DO + END DO + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('pico')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_pico') + ! + END SUBROUTINE p5z_pico + + + SUBROUTINE p5z_diat + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_diat *** + !! + !! ** Purpose : Compute the mortality terms for diatoms + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zfactfe,zfactsi,zfactch, zfactn, zfactp, zcompadi + REAL(wp) :: zrespp2, ztortp2, zmortp2 + REAL(wp) :: zlim2, zlim1 + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_diat') + ! + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + zcompadi = MAX( ( trb(ji,jj,jk,jpdia) - 1E-9), 0. ) + + ! Aggregation term for diatoms is increased in case of nutrient + ! stress as observed in reality. The stressed cells become more + ! sticky and coagulate to sink quickly out of the euphotic zone + ! ------------------------------------------------------------- + ! Phytoplankton squared mortality + ! ------------------------------- + zlim2 = xlimdia(ji,jj,jk) * xlimdia(ji,jj,jk) + zlim1 = 0.25 * ( 1. - zlim2 ) / ( 0.25 + zlim2 ) + zrespp2 = 1.e6 * xstep * ( wchld + wchldm * zlim1 ) * xdiss(ji,jj,jk) * zcompadi * trb(ji,jj,jk,jpdia) + + ! Phytoplankton linear mortality + ! ------------------------------ + ztortp2 = mpratd * xstep * zcompadi + zmortp2 = zrespp2 + ztortp2 + + ! Update the arrays tra which contains the biological sources and sinks + ! --------------------------------------------------------------------- + zfactn = trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactp = trb(ji,jj,jk,jppdi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactch = trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactfe = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zfactsi = trb(ji,jj,jk,jpdsi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) - zmortp2 + tra(ji,jj,jk,jpndi) = tra(ji,jj,jk,jpndi) - zmortp2 * zfactn + tra(ji,jj,jk,jppdi) = tra(ji,jj,jk,jppdi) - zmortp2 * zfactp + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) - zmortp2 * zfactch + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) - zmortp2 * zfactfe + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) - zmortp2 * zfactsi + tra(ji,jj,jk,jpgsi) = tra(ji,jj,jk,jpgsi) + zmortp2 * zfactsi + tra(ji,jj,jk,jpgoc) = tra(ji,jj,jk,jpgoc) + zrespp2 + tra(ji,jj,jk,jpgon) = tra(ji,jj,jk,jpgon) + zrespp2 * zfactn + tra(ji,jj,jk,jpgop) = tra(ji,jj,jk,jpgop) + zrespp2 * zfactp + tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zrespp2 * zfactfe + tra(ji,jj,jk,jppoc) = tra(ji,jj,jk,jppoc) + ztortp2 + tra(ji,jj,jk,jppon) = tra(ji,jj,jk,jppon) + ztortp2 * zfactn + tra(ji,jj,jk,jppop) = tra(ji,jj,jk,jppop) + ztortp2 * zfactp + tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + ztortp2 * zfactfe + prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + ztortp2 + prodgoc(ji,jj,jk) = prodgoc(ji,jj,jk) + zrespp2 + END DO + END DO + END DO + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('diat')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_diat') + ! + END SUBROUTINE p5z_diat + + + SUBROUTINE p5z_mort_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_mort_init *** + !! + !! ** Purpose : Initialization of phytoplankton parameters + !! + !! ** Method : Read the nampismort namelist and check the parameters + !! called at the first timestep + !! + !! ** input : Namelist nampismort + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namp5zmort/ wchln, wchlp, wchld, wchldm, mpratn, mpratp, mpratd + !!---------------------------------------------------------------------- + + REWIND( numnatp_ref ) ! Namelist nampismort in reference namelist : Pisces phytoplankton + READ ( numnatp_ref, namp5zmort, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp5zmort in reference namelist' ) + + REWIND( numnatp_cfg ) ! Namelist nampismort in configuration namelist : Pisces phytoplankton + READ ( numnatp_cfg, namp5zmort, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp5zmort in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zmort ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for phytoplankton mortality, namp5zmort' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' quadratic mortality of phytoplankton wchln =', wchln + WRITE(numout,*) ' quadratic mortality of picophyto. wchlp =', wchlp + WRITE(numout,*) ' quadratic mortality of diatoms wchld =', wchld + WRITE(numout,*) ' Additional quadratic mortality of diatoms wchldm =', wchldm + WRITE(numout,*) ' nanophyto. mortality rate mpratn =', mpratn + WRITE(numout,*) ' picophyto. mortality rate mpratp =', mpratp + WRITE(numout,*) ' Diatoms mortality rate mpratd =', mpratd + ENDIF + + END SUBROUTINE p5z_mort_init + + !!====================================================================== +END MODULE p5zmort diff --git a/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zprod.F90 b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zprod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e04532fb9ccee9cb1ba0f42d2b1e6b3ac58bf96e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/P4Z/p5zprod.F90 @@ -0,0 +1,574 @@ +MODULE p5zprod + !!====================================================================== + !! *** MODULE p5zprod *** + !! TOP : Growth Rate of the two phytoplanktons groups + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-05 (O. Aumont, C. Ethe) New parameterization of light limitation + !! 3.6 ! 2015-05 (O. Aumont) PISCES quota + !!---------------------------------------------------------------------- + !! p5z_prod : Compute the growth Rate of the two phytoplanktons groups + !! p5z_prod_init : Initialization of the parameters for growth + !! p5z_prod_alloc : Allocate variables for growth + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE p4zlim + USE p5zlim ! Co-limitations of differents nutrients + USE prtctl_trc ! print control for debugging + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC p5z_prod ! called in p5zbio.F90 + PUBLIC p5z_prod_init ! called in trcsms_pisces.F90 + PUBLIC p5z_prod_alloc + + !! * Shared module variables + REAL(wp), PUBLIC :: pislopen !: + REAL(wp), PUBLIC :: pislopep !: + REAL(wp), PUBLIC :: pisloped !: + REAL(wp), PUBLIC :: xadap !: + REAL(wp), PUBLIC :: excretn !: + REAL(wp), PUBLIC :: excretp !: + REAL(wp), PUBLIC :: excretd !: + REAL(wp), PUBLIC :: bresp !: + REAL(wp), PUBLIC :: thetanpm !: + REAL(wp), PUBLIC :: thetannm !: + REAL(wp), PUBLIC :: thetandm !: + REAL(wp), PUBLIC :: chlcmin !: + REAL(wp), PUBLIC :: grosip !: + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdaylen + + REAL(wp) :: r1_rday !: 1 / rday + REAL(wp) :: texcretn !: 1 - excret + REAL(wp) :: texcretp !: 1 - excretp + REAL(wp) :: texcretd !: 1 - excret2 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: p5zprod.F90 12280 2019-12-21 10:42:44Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE p5z_prod( kt , knt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p5z_prod *** + !! + !! ** Purpose : Compute the phytoplankton production depending on + !! light, temperature and nutrient availability + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt, knt + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zsilfac, znanotot, zpicotot, zdiattot, zconctemp, zconctemp2 + REAL(wp) :: zration, zratiop, zratiof, zmax, zmax2, zsilim, ztn, zadap + REAL(wp) :: zpronmax, zpropmax, zprofmax, zrat + REAL(wp) :: zlim, zsilfac2, zsiborn, zprod, zprontot, zproptot, zprodtot + REAL(wp) :: zprnutmax, zdocprod, zprochln, zprochld, zprochlp + REAL(wp) :: zpislopen, zpislopep, zpisloped, thetannm_n, thetandm_n, thetanpm_n + REAL(wp) :: zrum, zcodel, zargu, zval, zfeup + REAL(wp) :: zfact, zrfact2 + CHARACTER (len=25) :: charout + REAL(wp), DIMENSION(jpi,jpj ) :: zmixnano, zmixpico, zmixdiat, zstrn + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpislopeadn, zpislopeadp, zpislopeadd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprnut, zprmaxp, zprmaxn, zprmaxd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprbio, zprpic, zprdia, zysopt + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprchln, zprchlp, zprchld + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprorcan, zprorcap, zprorcad + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprofed, zprofep, zprofen + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpronewn, zpronewp, zpronewd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zproregn, zproregp, zproregd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpropo4n, zpropo4p, zpropo4d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprodopn, zprodopp, zprodopd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrespn, zrespp, zrespd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zcroissn, zcroissp, zcroissd + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmxl_fac, zmxl_chl + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpligprod1, zpligprod2 + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('p5z_prod') + ! + zprorcan(:,:,:) = 0._wp ; zprorcap(:,:,:) = 0._wp ; zprorcad(:,:,:) = 0._wp + zcroissn(:,:,:) = 0._wp ; zcroissp(:,:,:) = 0._wp ; zcroissd(:,:,:) = 0._wp + zprofed (:,:,:) = 0._wp ; zprofep (:,:,:) = 0._wp ; zprofen (:,:,:) = 0._wp + zpronewn(:,:,:) = 0._wp ; zpronewp(:,:,:) = 0._wp ; zpronewd(:,:,:) = 0._wp + zproregn(:,:,:) = 0._wp ; zproregp(:,:,:) = 0._wp ; zproregd(:,:,:) = 0._wp + zpropo4n(:,:,:) = 0._wp ; zpropo4p(:,:,:) = 0._wp ; zpropo4d(:,:,:) = 0._wp + zprdia (:,:,:) = 0._wp ; zprpic (:,:,:) = 0._wp ; zprbio (:,:,:) = 0._wp + zprodopn(:,:,:) = 0._wp ; zprodopp(:,:,:) = 0._wp ; zprodopd(:,:,:) = 0._wp + zysopt (:,:,:) = 0._wp + zrespn (:,:,:) = 0._wp ; zrespp (:,:,:) = 0._wp ; zrespd (:,:,:) = 0._wp + + ! Computation of the optimal production + zprnut (:,:,:) = 0.65_wp * r1_rday * tgfunc(:,:,:) + zprmaxn(:,:,:) = ( 0.65_wp * (1. + zpsino3 * qnpmax ) ) * r1_rday * tgfunc(:,:,:) + zprmaxp(:,:,:) = 0.5 / 0.65 * zprmaxn(:,:,:) + zprmaxd(:,:,:) = zprmaxn(:,:,:) + + ! compute the day length depending on latitude and the day + zrum = REAL( nday_year - 80, wp ) / REAL( nyear_len(1), wp ) + zcodel = ASIN( SIN( zrum * rpi * 2._wp ) * SIN( rad * 23.5_wp ) ) + + ! day length in hours + zstrn(:,:) = 0. + DO jj = 1, jpj + DO ji = 1, jpi + zargu = TAN( zcodel ) * TAN( gphit(ji,jj) * rad ) + zargu = MAX( -1., MIN( 1., zargu ) ) + zstrn(ji,jj) = MAX( 0.0, 24. - 2. * ACOS( zargu ) / rad / 15. ) + END DO + END DO + + ! Impact of the day duration on phytoplankton growth + DO jk = 1, jpkm1 + DO jj = 1 ,jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + zval = MAX( 1., zstrn(ji,jj) ) + IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN + zval = zval * MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn )) + ENDIF + zmxl_chl(ji,jj,jk) = zval / 24. + zmxl_fac(ji,jj,jk) = 1.5 * zval / ( 12. + zval ) + ENDIF + END DO + END DO + END DO + + zprbio(:,:,:) = zprmaxn(:,:,:) * zmxl_fac(:,:,:) + zprdia(:,:,:) = zprmaxd(:,:,:) * zmxl_fac(:,:,:) + zprpic(:,:,:) = zprmaxp(:,:,:) * zmxl_fac(:,:,:) + + + ! Maximum light intensity + zdaylen(:,:) = MAX(1., zstrn(:,:)) / 24. + WHERE( zstrn(:,:) < 1.e0 ) zstrn(:,:) = 24. + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! Computation of the P-I slope for nanos and diatoms + ztn = MAX( 0., tsn(ji,jj,jk,jp_tem) - 15. ) + zadap = xadap * ztn / ( 2.+ ztn ) + ! + zpislopeadn(ji,jj,jk) = pislopen * trb(ji,jj,jk,jpnch) & + & /( trb(ji,jj,jk,jpphy) * 12. + rtrn) + zpislopeadp(ji,jj,jk) = pislopep * ( 1. + zadap * EXP( -0.25 * epico(ji,jj,jk) ) ) & + & * trb(ji,jj,jk,jppch) /( trb(ji,jj,jk,jppic) * 12. + rtrn) + zpislopeadd(ji,jj,jk) = pisloped * trb(ji,jj,jk,jpdch) & + & /( trb(ji,jj,jk,jpdia) * 12. + rtrn) + ! + zpislopen = zpislopeadn(ji,jj,jk) / ( zprbio(ji,jj,jk) * rday * xlimphy(ji,jj,jk) + rtrn ) + zpislopep = zpislopeadp(ji,jj,jk) / ( zprpic(ji,jj,jk) * rday * xlimpic(ji,jj,jk) + rtrn ) + zpisloped = zpislopeadd(ji,jj,jk) / ( zprdia(ji,jj,jk) * rday * xlimdia(ji,jj,jk) + rtrn ) + + ! Computation of production function for Carbon + ! --------------------------------------------- + zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen * enano(ji,jj,jk) ) ) + zprpic(ji,jj,jk) = zprpic(ji,jj,jk) * ( 1.- EXP( -zpislopep * epico(ji,jj,jk) ) ) + zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediat(ji,jj,jk) ) ) + + ! Computation of production function for Chlorophyll + ! ------------------------------------------------- + zpislopen = zpislopen * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zpisloped = zpisloped * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zpislopep = zpislopep * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprchln(ji,jj,jk) = zprmaxn(ji,jj,jk) * ( 1.- EXP( -zpislopen * enanom(ji,jj,jk) ) ) + zprchlp(ji,jj,jk) = zprmaxp(ji,jj,jk) * ( 1.- EXP( -zpislopep * epicom(ji,jj,jk) ) ) + zprchld(ji,jj,jk) = zprmaxd(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediatm(ji,jj,jk) ) ) + ENDIF + END DO + END DO + END DO + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! Si/C of diatoms + ! ------------------------ + ! Si/C increases with iron stress and silicate availability + ! Si/C is arbitrariliy increased for very high Si concentrations + ! to mimic the very high ratios observed in the Southern Ocean (silpot2) + zlim = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi1 ) + zsilim = MIN( zprdia(ji,jj,jk) / ( zprmaxd(ji,jj,jk) + rtrn ), xlimsi(ji,jj,jk) ) + zsilfac = 3.4 * EXP( -4.23 * zsilim ) * MAX( 0.e0, MIN( 1., 2.2 * ( zlim - 0.5 ) ) ) + 1.e0 + zsiborn = trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) * trb(ji,jj,jk,jpsil) + IF (gphit(ji,jj) < -30 ) THEN + zsilfac2 = 1. + 2. * zsiborn / ( zsiborn + xksi2**3 ) + ELSE + zsilfac2 = 1. + zsiborn / ( zsiborn + xksi2**3 ) + ENDIF + zysopt(ji,jj,jk) = grosip * zlim * zsilfac * zsilfac2 + ENDIF + END DO + END DO + END DO + + ! Sea-ice effect on production + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + zprpic(ji,jj,jk) = zprpic(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + zprnut(ji,jj,jk) = zprnut(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) + END DO + END DO + END DO + + ! Computation of the various production terms of nanophytoplankton + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for nanophyto. + zprorcan(ji,jj,jk) = zprbio(ji,jj,jk) * xlimphy(ji,jj,jk) * trb(ji,jj,jk,jpphy) * rfact2 + ! + zration = trb(ji,jj,jk,jpnph) / ( trb(ji,jj,jk,jpphy) + rtrn ) + zratiop = trb(ji,jj,jk,jppph) / ( trb(ji,jj,jk,jpphy) + rtrn ) + zratiof = trb(ji,jj,jk,jpnfe) / ( trb(ji,jj,jk,jpphy) + rtrn ) + zprnutmax = zprnut(ji,jj,jk) * fvnuptk(ji,jj,jk) / rno3 * trb(ji,jj,jk,jpphy) * rfact2 + ! Uptake of nitrogen + zrat = MIN( 1., zration / (xqnnmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpnmin(ji,jj,jk) ) & + & / ( xqpnmax(ji,jj,jk) - xqpnmin(ji,jj,jk) + rtrn ), xlimnfe(ji,jj,jk) ) ) + zpronewn(ji,jj,jk) = zpronmax * zdaylen(ji,jj) * xnanono3(ji,jj,jk) + zproregn(ji,jj,jk) = zpronmax * xnanonh4(ji,jj,jk) + ! Uptake of phosphorus + zrat = MIN( 1., zratiop / (xqpnmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpropmax = zprnutmax * zmax * xlimnfe(ji,jj,jk) + zpropo4n(ji,jj,jk) = zpropmax * xnanopo4(ji,jj,jk) + zprodopn(ji,jj,jk) = zpropmax * xnanodop(ji,jj,jk) + ! Uptake of iron + zrat = MIN( 1., zratiof / qfnmax ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zprofmax = zprnutmax * qfnmax * zmax + zprofen(ji,jj,jk) = zprofmax * xnanofer(ji,jj,jk) * ( 3. - 2.4 * xlimnfe(ji,jj,jk) & + & / ( xlimnfe(ji,jj,jk) + 0.2 ) ) * (1. + 0.8 * xnanono3(ji,jj,jk) / ( rtrn & + & + xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) ) * (1. - xnanofer(ji,jj,jk) ) ) + ENDIF + END DO + END DO + END DO + + ! Computation of the various production terms of picophytoplankton + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for picophyto. + zprorcap(ji,jj,jk) = zprpic(ji,jj,jk) * xlimpic(ji,jj,jk) * trb(ji,jj,jk,jppic) * rfact2 + ! + zration = trb(ji,jj,jk,jpnpi) / ( trb(ji,jj,jk,jppic) + rtrn ) + zratiop = trb(ji,jj,jk,jpppi) / ( trb(ji,jj,jk,jppic) + rtrn ) + zratiof = trb(ji,jj,jk,jppfe) / ( trb(ji,jj,jk,jppic) + rtrn ) + zprnutmax = zprnut(ji,jj,jk) * fvpuptk(ji,jj,jk) / rno3 * trb(ji,jj,jk,jppic) * rfact2 + ! Uptake of nitrogen + zrat = MIN( 1., zration / (xqnpmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqppmin(ji,jj,jk) ) & + & / ( xqppmax(ji,jj,jk) - xqppmin(ji,jj,jk) + rtrn ), xlimpfe(ji,jj,jk) ) ) + zpronewp(ji,jj,jk) = zpronmax * zdaylen(ji,jj) * xpicono3(ji,jj,jk) + zproregp(ji,jj,jk) = zpronmax * xpiconh4(ji,jj,jk) + ! Uptake of phosphorus + zrat = MIN( 1., zratiop / (xqppmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpropmax = zprnutmax * zmax * xlimpfe(ji,jj,jk) + zpropo4p(ji,jj,jk) = zpropmax * xpicopo4(ji,jj,jk) + zprodopp(ji,jj,jk) = zpropmax * xpicodop(ji,jj,jk) + ! Uptake of iron + zrat = MIN( 1., zratiof / qfpmax ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zprofmax = zprnutmax * qfpmax * zmax + zprofep(ji,jj,jk) = zprofmax * xpicofer(ji,jj,jk) * ( 3. - 2.4 * xlimpfe(ji,jj,jk) & + & / ( xlimpfe(ji,jj,jk) + 0.2 ) ) * (1. + 0.8 * xpicono3(ji,jj,jk) / ( rtrn & + & + xpicono3(ji,jj,jk) + xpiconh4(ji,jj,jk) ) * (1. - xpicofer(ji,jj,jk) ) ) + ENDIF + END DO + END DO + END DO + + ! Computation of the various production terms of diatoms + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for diatomees + zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * trb(ji,jj,jk,jpdia) * rfact2 + ! Computation of the respiration term according to pahlow + ! & oschlies (2013) + ! + zration = trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zratiop = trb(ji,jj,jk,jppdi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zratiof = trb(ji,jj,jk,jpdfe) / ( trb(ji,jj,jk,jpdia) + rtrn ) + zprnutmax = zprnut(ji,jj,jk) * fvduptk(ji,jj,jk) / rno3 * trb(ji,jj,jk,jpdia) * rfact2 + ! Uptake of nitrogen + zrat = MIN( 1., zration / (xqndmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpdmin(ji,jj,jk) ) & + & / ( xqpdmax(ji,jj,jk) - xqpdmin(ji,jj,jk) + rtrn ), xlimdfe(ji,jj,jk) ) ) + zpronewd(ji,jj,jk) = zpronmax * zdaylen(ji,jj) * xdiatno3(ji,jj,jk) + zproregd(ji,jj,jk) = zpronmax * xdiatnh4(ji,jj,jk) + ! Uptake of phosphorus + zrat = MIN( 1., zratiop / (xqpdmax(ji,jj,jk) + rtrn) ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zpropmax = zprnutmax * zmax * xlimdfe(ji,jj,jk) + zpropo4d(ji,jj,jk) = zpropmax * xdiatpo4(ji,jj,jk) + zprodopd(ji,jj,jk) = zpropmax * xdiatdop(ji,jj,jk) + ! Uptake of iron + zrat = MIN( 1., zratiof / qfdmax ) + zmax = MAX(0., MIN(1., (1. - zrat)/ (1.05 - zrat) * 1.05)) + zprofmax = zprnutmax * qfdmax * zmax + zprofed(ji,jj,jk) = zprofmax * xdiatfer(ji,jj,jk) * ( 3. - 2.4 * xlimdfe(ji,jj,jk) & + & / ( xlimdfe(ji,jj,jk) + 0.2 ) ) * (1. + 0.8 * xdiatno3(ji,jj,jk) / ( rtrn & + & + xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) ) * (1. - xdiatfer(ji,jj,jk) ) ) + ENDIF + END DO + END DO + END DO + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN + ! production terms for nanophyto. ( chlorophyll ) + znanotot = enanom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprod = rday * (zpronewn(ji,jj,jk) + zproregn(ji,jj,jk)) * zprchln(ji,jj,jk) * xlimphy(ji,jj,jk) + thetannm_n = MIN ( thetannm, ( thetannm / (1. - 1.14 / 43.4 *tsn(ji,jj,jk,jp_tem))) & + & * (1. - 1.14 / 43.4 * 20.)) + zprochln = thetannm_n * zprod / ( zpislopeadn(ji,jj,jk) * znanotot + rtrn ) + zprochln = MAX(zprochln, chlcmin * 12. * zprorcan (ji,jj,jk) ) + ! production terms for picophyto. ( chlorophyll ) + zpicotot = epicom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprod = rday * (zpronewp(ji,jj,jk) + zproregp(ji,jj,jk)) * zprchlp(ji,jj,jk) * xlimpic(ji,jj,jk) + thetanpm_n = MIN ( thetanpm, ( thetanpm / (1. - 1.14 / 43.4 *tsn(ji,jj,jk,jp_tem))) & + & * (1. - 1.14 / 43.4 * 20.)) + zprochlp = thetanpm_n * zprod / ( zpislopeadp(ji,jj,jk) * zpicotot + rtrn ) + zprochlp = MAX(zprochlp, chlcmin * 12. * zprorcap(ji,jj,jk) ) + ! production terms for diatomees ( chlorophyll ) + zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn ) + zprod = rday * (zpronewd(ji,jj,jk) + zproregd(ji,jj,jk)) * zprchld(ji,jj,jk) * xlimdia(ji,jj,jk) + thetandm_n = MIN ( thetandm, ( thetandm / (1. - 1.14 / 43.4 *tsn(ji,jj,jk,jp_tem))) & + & * (1. - 1.14 / 43.4 * 20.)) + zprochld = thetandm_n * zprod / ( zpislopeadd(ji,jj,jk) * zdiattot + rtrn ) + zprochld = MAX(zprochld, chlcmin * 12. * zprorcad(ji,jj,jk) ) + ! Update the arrays TRA which contain the Chla sources and sinks + tra(ji,jj,jk,jpnch) = tra(ji,jj,jk,jpnch) + zprochln * texcretn + tra(ji,jj,jk,jpdch) = tra(ji,jj,jk,jpdch) + zprochld * texcretd + tra(ji,jj,jk,jppch) = tra(ji,jj,jk,jppch) + zprochlp * texcretp + ENDIF + END DO + END DO + END DO + + ! Update the arrays TRA which contain the biological sources and sinks + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji =1 ,jpi + zprontot = zpronewn(ji,jj,jk) + zproregn(ji,jj,jk) + zproptot = zpronewp(ji,jj,jk) + zproregp(ji,jj,jk) + zprodtot = zpronewd(ji,jj,jk) + zproregd(ji,jj,jk) + zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) & + & + excretp * zprorcap(ji,jj,jk) + tra(ji,jj,jk,jppo4) = tra(ji,jj,jk,jppo4) - zpropo4n(ji,jj,jk) - zpropo4d(ji,jj,jk) & + & - zpropo4p(ji,jj,jk) + tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) - zpronewn(ji,jj,jk) - zpronewd(ji,jj,jk) & + & - zpronewp(ji,jj,jk) + tra(ji,jj,jk,jpnh4) = tra(ji,jj,jk,jpnh4) - zproregn(ji,jj,jk) - zproregd(ji,jj,jk) & + & - zproregp(ji,jj,jk) + tra(ji,jj,jk,jpphy) = tra(ji,jj,jk,jpphy) + zprorcan(ji,jj,jk) * texcretn & + & - zpsino3 * zpronewn(ji,jj,jk) - zpsinh4 * zproregn(ji,jj,jk) & + & - zrespn(ji,jj,jk) + zcroissn(ji,jj,jk) = tra(ji,jj,jk,jpphy) / rfact2/ (trb(ji,jj,jk,jpphy) + rtrn) + tra(ji,jj,jk,jpnph) = tra(ji,jj,jk,jpnph) + zprontot * texcretn + tra(ji,jj,jk,jppph) = tra(ji,jj,jk,jppph) + zpropo4n(ji,jj,jk) * texcretn & + & + zprodopn(ji,jj,jk) * texcretn + tra(ji,jj,jk,jpnfe) = tra(ji,jj,jk,jpnfe) + zprofen(ji,jj,jk) * texcretn + tra(ji,jj,jk,jppic) = tra(ji,jj,jk,jppic) + zprorcap(ji,jj,jk) * texcretp & + & - zpsino3 * zpronewp(ji,jj,jk) - zpsinh4 * zproregp(ji,jj,jk) & + & - zrespp(ji,jj,jk) + zcroissp(ji,jj,jk) = tra(ji,jj,jk,jppic) / rfact2/ (trb(ji,jj,jk,jppic) + rtrn) + tra(ji,jj,jk,jpnpi) = tra(ji,jj,jk,jpnpi) + zproptot * texcretp + tra(ji,jj,jk,jpppi) = tra(ji,jj,jk,jpppi) + zpropo4p(ji,jj,jk) * texcretp & + & + zprodopp(ji,jj,jk) * texcretp + tra(ji,jj,jk,jppfe) = tra(ji,jj,jk,jppfe) + zprofep(ji,jj,jk) * texcretp + tra(ji,jj,jk,jpdia) = tra(ji,jj,jk,jpdia) + zprorcad(ji,jj,jk) * texcretd & + & - zpsino3 * zpronewd(ji,jj,jk) - zpsinh4 * zproregd(ji,jj,jk) & + & - zrespd(ji,jj,jk) + zcroissd(ji,jj,jk) = tra(ji,jj,jk,jpdia) / rfact2 / (trb(ji,jj,jk,jpdia) + rtrn) + tra(ji,jj,jk,jpndi) = tra(ji,jj,jk,jpndi) + zprodtot * texcretd + tra(ji,jj,jk,jppdi) = tra(ji,jj,jk,jppdi) + zpropo4d(ji,jj,jk) * texcretd & + & + zprodopd(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdfe) = tra(ji,jj,jk,jpdfe) + zprofed(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdsi) = tra(ji,jj,jk,jpdsi) + zprorcad(ji,jj,jk) * zysopt(ji,jj,jk) * texcretd + tra(ji,jj,jk,jpdoc) = tra(ji,jj,jk,jpdoc) + excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) & + & + excretp * zprorcap(ji,jj,jk) + tra(ji,jj,jk,jpdon) = tra(ji,jj,jk,jpdon) + excretd * zprodtot + excretn * zprontot & + & + excretp * zproptot + tra(ji,jj,jk,jpdop) = tra(ji,jj,jk,jpdop) + excretd * zpropo4d(ji,jj,jk) + excretn * zpropo4n(ji,jj,jk) & + & - texcretn * zprodopn(ji,jj,jk) - texcretd * zprodopd(ji,jj,jk) + excretp * zpropo4p(ji,jj,jk) & + & - texcretp * zprodopp(ji,jj,jk) + tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + o2ut * ( zproregn(ji,jj,jk) + zproregd(ji,jj,jk) & + & + zproregp(ji,jj,jk) ) + ( o2ut + o2nit ) * ( zpronewn(ji,jj,jk) & + & + zpronewd(ji,jj,jk) + zpronewp(ji,jj,jk) ) & + & - o2ut * ( zrespn(ji,jj,jk) + zrespp(ji,jj,jk) + zrespd(ji,jj,jk) ) + zfeup = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk) + tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zfeup + tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) - texcretd * zprorcad(ji,jj,jk) * zysopt(ji,jj,jk) + tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) - zprorcan(ji,jj,jk) - zprorcad(ji,jj,jk) - zprorcap(ji,jj,jk) & + & + zpsino3 * zpronewn(ji,jj,jk) + zpsinh4 * zproregn(ji,jj,jk) & + & + zpsino3 * zpronewp(ji,jj,jk) + zpsinh4 * zproregp(ji,jj,jk) & + & + zpsino3 * zpronewd(ji,jj,jk) + zpsinh4 * zproregd(ji,jj,jk) & + & + zrespn(ji,jj,jk) + zrespd(ji,jj,jk) + zrespp(ji,jj,jk) + tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + rno3 * ( zpronewn(ji,jj,jk) + zpronewd(ji,jj,jk) & + & + zpronewp(ji,jj,jk) ) - rno3 * ( zproregn(ji,jj,jk) + zproregd(ji,jj,jk) & + & + zproregp(ji,jj,jk) ) + END DO + END DO + END DO + ! + IF( ln_ligand ) THEN + zpligprod1(:,:,:) = 0._wp ; zpligprod2(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji =1 ,jpi + zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) + excretp * zprorcap(ji,jj,jk) + zfeup = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk) + tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) + zdocprod * ldocp - zfeup * plig(ji,jj,jk) * lthet + zpligprod1(ji,jj,jk) = zdocprod * ldocp + zpligprod2(ji,jj,jk) = zfeup * plig(ji,jj,jk) * lthet + END DO + END DO + END DO + ENDIF + + + ! Total primary production per year + + ! Total primary production per year + IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) & + & tpp = glob_sum( 'p5zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) + zprorcap(:,:,:) ) * cvol(:,:,:) ) + + IF( lk_iomput .AND. knt == nrdttrc ) THEN + zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s + ! + CALL iom_put( "PPPHYP" , zprorcap(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by picophyto + CALL iom_put( "PPPHYN" , zprorcan(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by nanophyto + CALL iom_put( "PPPHYD" , zprorcad(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by diatomes + CALL iom_put( "PPNEWN" , zpronewp(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by picophyto + CALL iom_put( "PPNEWN" , zpronewn(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by nanophyto + CALL iom_put( "PPNEWD" , zpronewd(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by diatomes + CALL iom_put( "PBSi" , zprorcad(:,:,:) * zfact * tmask(:,:,:) * zysopt(:,:,:) ) ! biogenic silica production + CALL iom_put( "PFeP" , zprofep(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by picophyto + CALL iom_put( "PFeN" , zprofen(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by nanophyto + CALL iom_put( "PFeD" , zprofed(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by diatomes + IF( ln_ligand ) THEN + CALL iom_put( "LPRODP" , zpligprod1(:,:,:) * 1e9 * zfact * tmask(:,:,:) ) + CALL iom_put( "LDETP" , zpligprod2(:,:,:) * 1e9 * zfact * tmask(:,:,:) ) + ENDIF + CALL iom_put( "Mumax" , zprmaxn(:,:,:) * tmask(:,:,:) ) ! Maximum growth rate + CALL iom_put( "MuP" , zprpic(:,:,:) * xlimpic(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for picophyto + CALL iom_put( "MuN" , zprbio(:,:,:) * xlimphy(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for nanophyto + CALL iom_put( "MuD" , zprdia(:,:,:) * xlimdia(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for diatoms + CALL iom_put( "LPlight" , zprpic(:,:,:) / (zprmaxp(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term + CALL iom_put( "LNlight" , zprbio(:,:,:) / (zprmaxn(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term + CALL iom_put( "LDlight" , zprdia(:,:,:) / (zprmaxd(:,:,:) + rtrn) * tmask(:,:,:) ) + CALL iom_put( "MunetP" , zcroissp(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for picophyto + CALL iom_put( "MunetN" , zcroissn(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for nanophyto + CALL iom_put( "MunetD" , zcroissd(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for diatoms + CALL iom_put( "TPP" , ( zprorcap(:,:,:) + zprorcan(:,:,:) + zprorcad(:,:,:) ) * zfact * tmask(:,:,:) ) ! total primary production + CALL iom_put( "TPNEW" , ( zpronewp(:,:,:) + zpronewn(:,:,:) + zpronewd(:,:,:) ) * zfact * tmask(:,:,:) ) ! total new production + CALL iom_put( "TPBFE" , ( zprofep (:,:,:) + zprofen (:,:,:) + zprofed (:,:,:) ) * zfact * tmask(:,:,:) ) ! total biogenic iron production + CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s + ENDIF + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('prod')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('p5z_prod') + ! + END SUBROUTINE p5z_prod + + + SUBROUTINE p5z_prod_init + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_prod_init *** + !! + !! ** Purpose : Initialization of phytoplankton production parameters + !! + !! ** Method : Read the nampisprod namelist and check the parameters + !! called at the first timestep (nittrc000) + !! + !! ** input : Namelist nampisprod + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namp5zprod/ pislopen, pislopep, pisloped, excretn, excretp, excretd, & + & thetannm, thetanpm, thetandm, chlcmin, grosip, bresp, xadap + !!---------------------------------------------------------------------- + + REWIND( numnatp_ref ) + READ ( numnatp_ref, namp5zprod, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namp5zprod in reference namelist' ) + + REWIND( numnatp_cfg ) + READ ( numnatp_cfg, namp5zprod, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namp5zprod in configuration namelist' ) + IF(lwm) WRITE ( numonp, namp5zprod ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist parameters for phytoplankton growth, namp5zprod' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numout,*) ' mean Si/C ratio grosip =', grosip + WRITE(numout,*) ' P-I slope pislopen =', pislopen + WRITE(numout,*) ' P-I slope for diatoms pisloped =', pisloped + WRITE(numout,*) ' P-I slope for picophytoplankton pislopep =', pislopep + WRITE(numout,*) ' Acclimation factor to low light xadap =', xadap + WRITE(numout,*) ' excretion ratio of nanophytoplankton excretn =', excretn + WRITE(numout,*) ' excretion ratio of picophytoplankton excretp =', excretp + WRITE(numout,*) ' excretion ratio of diatoms excretd =', excretd + WRITE(numout,*) ' basal respiration in phytoplankton bresp =', bresp + WRITE(numout,*) ' Maximum Chl/C in phytoplankton chlcmin =', chlcmin + WRITE(numout,*) ' Minimum Chl/N in nanophytoplankton thetannm =', thetannm + WRITE(numout,*) ' Minimum Chl/N in picophytoplankton thetanpm =', thetanpm + WRITE(numout,*) ' Minimum Chl/N in diatoms thetandm =', thetandm + ENDIF + ! + r1_rday = 1._wp / rday + texcretn = 1._wp - excretn + texcretp = 1._wp - excretp + texcretd = 1._wp - excretd + tpp = 0._wp + ! + END SUBROUTINE p5z_prod_init + + + INTEGER FUNCTION p5z_prod_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p5z_prod_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( zdaylen(jpi,jpj), STAT = p5z_prod_alloc ) + ! + IF( p5z_prod_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p5z_prod_alloc : failed to allocate arrays.' ) + ! + END FUNCTION p5z_prod_alloc + !!====================================================================== +END MODULE p5zprod diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/oce_sed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/oce_sed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d89302ab3001ff3053808e132ce759ae06144c18 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/oce_sed.F90 @@ -0,0 +1,56 @@ +MODULE oce_sed + !!====================================================================== + !! *** sed *** + !! Sediment : set sediment global variables + !!====================================================================== + !! History : + !! ! 06-12 (C. Ethe) Orignal + !!---------------------------------------------------------------------- + USE par_sed + USE timing + USE par_trc + + USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) + USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre) + USE dom_oce , ONLY : e3t_n => e3t_n !: latitude of t-point (degre) + USE dom_oce , ONLY : e3t_1d => e3t_1d !: reference depth of t-points (m) + USE dom_oce , ONLY : gdepw_0 => gdepw_0 !: reference depth of t-points (m) + USE dom_oce , ONLY : mbkt => mbkt !: vertical index of the bottom last T- ocean level + USE dom_oce , ONLY : tmask => tmask !: land/ocean mask at t-points + USE dom_oce , ONLY : rdt => rdt !: time step for the dynamics + USE dom_oce , ONLY : nyear => nyear !: Current year + USE dom_oce , ONLY : ndastp => ndastp !: time step date in year/month/day aammjj + USE dom_oce , ONLY : adatrj => adatrj !: number of elapsed days since the begining of the run + USE trc , ONLY : nittrc000 => nittrc000 + ! !: it is the accumulated duration of previous runs + ! !: that may have been run with different time steps. + + USE oce , ONLY : tsn => tsn !: pot. temperature (celsius) and salinity (psu) + USE trc , ONLY : trb => trb !: pot. temperature (celsius) and salinity (psu) + + USE sms_pisces, ONLY : wsbio4 => wsbio4 !: sinking flux for POC + USE sms_pisces, ONLY : wsbio3 => wsbio3 !: sinking flux for GOC + USE sms_pisces, ONLY : wsbio2 => wsbio2 !: sinking flux for calcite + USE sms_pisces, ONLY : wsbio => wsbio !: sinking flux for calcite + USE sms_pisces, ONLY : ln_p5z => ln_p5z !: PISCES-QUOTA flag + USE p4zche, ONLY : akb3 => akb3 !: Chemical constants + USE sms_pisces, ONLY : ak13 => ak13 !: Chemical constants + USE sms_pisces, ONLY : ak23 => ak23 !: Chemical constants + USE p4zche, ONLY : akw3 => akw3 !: Chemical constants + USE sms_pisces, ONLY : aksp => aksp !: Chemical constants + USE p4zche, ONLY : borat => borat !: Chemical constants ( borat ) + USE p4zche, ONLY : ak1p3 => ak1p3 !: Chemical constants + USE p4zche, ONLY : ak2p3 => ak2p3 !: Chemical constants + USE p4zche, ONLY : ak3p3 => ak3p3 !: Chemical constants + USE p4zche, ONLY : aksi3 => aksi3 !: Chemical constants + USE p4zche, ONLY : aks3 => aks3 !: Chemical constants + USE p4zche, ONLY : akf3 => akf3 !: Chemical constants + USE p4zche, ONLY : fluorid => fluorid !: Chemical constants + USE p4zche, ONLY : sulfat => sulfat !: Chemical constants + USE p4zche, ONLY : sio3eq => sio3eq !: Chemical constants + USE p4zsbc, ONLY : dust => dust + USE trc , ONLY : r2dttrc => r2dttrc + +END MODULE oce_sed + + diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/par_sed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/par_sed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4c8e79d9e084424d2cbf7f2b61f40f854df101fc --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/par_sed.F90 @@ -0,0 +1,66 @@ +MODULE par_sed + !!====================================================================== + !! *** par_sed *** + !! Sediment : set sediment parameter + !!====================================================================== + !! History : + !! ! 06-12 (C. Ethe) Orignal + !!---------------------------------------------------------------------- + !! $Id: par_sed.F90 10222 2018-10-25 09:42:23Z aumont $ + + !! Domain characteristics + USE par_kind + USE par_oce , ONLY : & + jpi => jpi , & !: first dimension of grid --> i + jpj => jpj , & !: second dimension of grid --> j + jpim1 => jpim1 , & !: jpi - 1 + jpjm1 => jpjm1 , & !: jpj - 1 + jpij => jpij , & !: jpi x jpj + jp_tem => jp_tem, & !: indice of temperature + jp_sal => jp_sal !: indice of salintity + + INTEGER, PARAMETER :: jpdta = 17 + + ! Vertical sediment geometry + INTEGER, PUBLIC :: & + jpksed = 11 , & + jpksedm1 = 10 + + ! sediment tracer species + INTEGER, PARAMETER :: & + jpsol = 8, & !: number of solid component + jpwat = 10, & !: number of pore water component + jpwatp1 = jpwat +1, & + jpsol1 = jpsol - 1 + + + ! pore water components + INTEGER, PARAMETER :: & + jwsil = 1, & !: silic acid + jwoxy = 2, & !: oxygen + jwdic = 3, & !: dissolved inorganic carbon + jwno3 = 4, & !: nitrate + jwpo4 = 5, & !: phosphate + jwalk = 6, & !: alkalinity + jwnh4 = 7, & !: Ammonium + jwh2s = 8, & !: Sulfate + jwso4 = 9, & !: H2S + jwfe2 = 10 !: Fe2+ + + ! solid components + INTEGER, PARAMETER :: & + jsopal = 1, & !: opal sediment + jsclay = 2, & !: clay + jspoc = 3, & !: organic carbon + jscal = 4, & !: calcite + jspos = 5, & !: semi-ref POC + jspor = 6, & !: refractory POC + jsfeo = 7, & !: iron hydroxides + jsfes = 8 !: FeS + + INTEGER, PARAMETER :: & + jptrased = jpsol + jpwat , & + jpdia3dsed = 2 , & + jpdia2dsed = 12 + +END MODULE par_sed diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..aad78456ed068ac554b27faa914a671eb7dbfc51 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sed.F90 @@ -0,0 +1,172 @@ +MODULE sed + !!====================================================================== + !! *** sed *** + !! Sediment : set sediment global variables + !!====================================================================== + !! History : + !! ! 06-12 (C. Ethe) Orignal + !!---------------------------------------------------------------------- + USE par_sed + USE oce_sed + USE in_out_manager + + + IMPLICIT NONE + PUBLIC + + PUBLIC sed_alloc + + !! Namelist + REAL(wp), PUBLIC :: reac_sil !: reactivity of silicate in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_clay !: reactivity of clay in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_ligc !: reactivity of Ligands [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_pocl !: reactivity of pocl in [s-1] + REAL(wp), PUBLIC :: reac_pocs !: reactivity of pocs in [s-1] + REAL(wp), PUBLIC :: reac_pocr !: reactivity of pocr in [s-1] + REAL(wp), PUBLIC :: reac_nh4 !: reactivity of NH4 in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_h2s !: reactivity of ODU in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_fe2 !: reactivity of Fe2+ in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_feh2s !: reactivity of Fe2+ in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_fes !: reactivity of Fe with H2S in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_feso !: reactivity of FeS with O2 in [l.mol-1.s-1] + REAL(wp), PUBLIC :: reac_cal !: reactivity of cal in [l.mol-1.s-1] + REAL(wp), PUBLIC :: adsnh4 !: adsorption coefficient of NH4 + REAL(wp), PUBLIC :: ratligc !: C/L ratio in POC + REAL(wp), PUBLIC :: so2ut + REAL(wp), PUBLIC :: srno3 + REAL(wp), PUBLIC :: spo4r + REAL(wp), PUBLIC :: srDnit + REAL(wp), PUBLIC :: dtsed !: sedimentation time step + REAL(wp), PUBLIC :: dtsed2 !: sedimentation time step + INTEGER , PUBLIC :: nitsed000 + INTEGER , PUBLIC :: nitsedend + INTEGER, PUBLIC :: nrseddt + REAL , PUBLIC :: sedmask + REAL(wp), PUBLIC :: denssol !: density of solid material + INTEGER , PUBLIC :: numrsr, numrsw !: logical unit for sed restart (read and write) + LOGICAL , PUBLIC :: lrst_sed !: logical to control the trc restart write + LOGICAL , PUBLIC :: ln_rst_sed = .TRUE. !: initialisation from a restart file or not + LOGICAL , PUBLIC :: ln_btbz = .FALSE. !: Depth variation of the bioturbation coefficient + LOGICAL , PUBLIC :: ln_irrig = .FALSE. !: iActivation of the bioirrigation + LOGICAL , PUBLIC :: ln_sed_2way = .FALSE. !: 2 way coupling with PISCES + LOGICAL , PUBLIC :: ln_sediment_offline = .FALSE. !: Offline mode for sediment module + INTEGER , PUBLIC :: nn_rstsed !: control of the time step ( 0 or 1 ) for pass. tr. + INTEGER , PUBLIC :: nn_dtsed = 1 !: frequency of step on passive tracers + CHARACTER(len = 80) , PUBLIC :: cn_sedrst_in !: suffix of pass. tracer restart name (input) + CHARACTER(len = 256), PUBLIC :: cn_sedrst_indir !: restart input directory + CHARACTER(len = 80) , PUBLIC :: cn_sedrst_out !: suffix of pass. tracer restart name (output) + CHARACTER(len = 256), PUBLIC :: cn_sedrst_outdir !: restart output directory + + ! + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: pwcp !: pore water sediment data at given time-step + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: pwcp0 !: pore water sediment data at initial time + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: solcp !: solid sediment data at given time-step + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: solcp0 !: solid sediment data at initial time + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: trc_dta + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: diff + + !! * Shared module variables + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: pwcp_dta !: pore water data at given time-step + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: rainrm_dta !: rain data at at initial time + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: rainrm !: rain data at given time-step + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: rainrg !: rain of each solid component in [g/(cm**2.s)] + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: fromsed !: + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: tosed !: + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: rloss !: + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: tokbot + ! + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: temp !: temperature + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: salt !: salinity + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: press !: pressure + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: raintg !: total massic flux rained in each cell (sum of sol. comp.) + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: fecratio !: Fe/C ratio in falling particles to the sediments + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: dzdep !: total thickness of solid material rained [cm] in each cell + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: zkbot !: total thickness of solid material rained [cm] in each cell + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: wacc !: total thickness of solid material rained [cm] in each cell + ! + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: hipor !: [h+] in mol/kg*densSW + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: co3por !: [co3--]solid sediment at initial time + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: dz3d !: ??? + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: volw3d !: ??? + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: vols3d !: ??? + + + !! Chemistry + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: densSW + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: borats + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: calcon2 + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: akbs + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak1s + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak2s + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: akws + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak12s + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak1ps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak2ps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak3ps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak12ps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: ak123ps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: aksis + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: aksps + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: sieqs + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: aks3s + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: akf3s + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: sulfats + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: fluorids + + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: mol_wgt !: molecular weight of solid sediment data + + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: trc_data !: tracer data to share with sediment model + !! Geometry + INTEGER , PUBLIC, SAVE :: jpoce, indoce !: Ocean points ( number/indices ) + INTEGER , PUBLIC, DIMENSION(: ), ALLOCATABLE :: iarroce !: Computation of 1D array of sediments points + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: epkbot !: ocean bottom layer thickness + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: gdepbot !: Depth of the sediment + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: dzkbot !: ocean bottom layer thickness in meters + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: dz !: sediment layers thickness + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: por !: porosity profile + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: por1 !: 1-por + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: volw !: volume of pore water cell fraction + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: vols !: volume of solid cell fraction + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: db !: bioturbation ceofficient + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: irrig !: bioturbation ceofficient + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: rdtsed !: sediment model time-step + REAL(wp), PUBLIC, DIMENSION(:,: ), ALLOCATABLE :: sedligand + REAL(wp) :: dens !: density of solid material + !! Inputs / Outputs + CHARACTER( len = 80 ), DIMENSION(jptrased ) :: sedtrcl + CHARACTER( len = 20 ), DIMENSION(jptrased ) :: sedtrcd , sedtrcu + CHARACTER( len = 80 ), DIMENSION(jpdia3dsed) :: seddia3l + CHARACTER( len = 20 ), DIMENSION(jpdia3dsed) :: seddia3d, seddia3u + CHARACTER( len = 80 ), DIMENSION(jpdia2dsed) :: seddia2l + CHARACTER( len = 20 ), DIMENSION(jpdia2dsed) :: seddia2d, seddia2u + ! + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: trcsedi + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: flxsedi3d + REAL(wp), PUBLIC, DIMENSION(:,:,: ), ALLOCATABLE :: flxsedi2d + + INTEGER, PUBLIC :: numsed = 27 ! units + + !! $Id: sed.F90 10425 2018-12-19 21:54:16Z smasson $ +CONTAINS + + INTEGER FUNCTION sed_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sed_alloc *** + !!------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop + !!------------------------------------------------------------------- + ! + ALLOCATE( trc_data(jpi,jpj,jpdta) , & + & epkbot(jpi,jpj), gdepbot(jpi,jpj) , & + & dz(jpksed) , por(jpksed) , por1(jpksed) , & + & volw(jpksed), vols(jpksed), rdtsed(jpksed) , & + & trcsedi (jpi,jpj,jpksed,jptrased) , & + & flxsedi3d(jpi,jpj,jpksed,jpdia3dsed) , & + & flxsedi2d(jpi,jpj,jpdia2dsed) , & + & mol_wgt(jpsol), STAT=sed_alloc ) + + IF( sed_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sed_alloc: failed to allocate arrays' ) + ! + END FUNCTION sed_alloc + +END MODULE sed diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sed_oce.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sed_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..237e380252fe68f7521801db33b5836e342a876b --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sed_oce.F90 @@ -0,0 +1,36 @@ +MODULE sed_oce + !!====================================================================== + !! *** sed *** + !! Sediment : set sediment global variables + !!====================================================================== + + !! History : + !! ! 06-12 (C. Ethe) Orignal + !!---------------------------------------------------------------------- + USE par_sed + USE trc, ONLY : profsed + + IMPLICIT NONE + PUBLIC + + PUBLIC sed_oce_alloc + + REAL(wp), PUBLIC, DIMENSION(: ), ALLOCATABLE :: profsedw !: depth of middle of each layer + + !! $Id: sed.F90 7646 2017-02-06 09:25:03Z timgraham $ +CONTAINS + + INTEGER FUNCTION sed_oce_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sed_alloc *** + !!------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop + !!------------------------------------------------------------------- + ! + ALLOCATE( profsed(jpksed) , profsedw(jpksed) , STAT=sed_oce_alloc ) + + IF( sed_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sed_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION sed_oce_alloc + +END MODULE sed_oce diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedadv.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedadv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e26f72349babadc0e52184e5cd88a3053061427c --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedadv.F90 @@ -0,0 +1,442 @@ +MODULE sedadv + !!====================================================================== + !! *** MODULE sedadv *** + !! Sediment : vertical advection and burial + !!===================================================================== + !! * Modules used + !!---------------------------------------------------------------------- + !! sed_adv : + !!---------------------------------------------------------------------- + USE sed ! sediment global variable + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_adv + PUBLIC sed_adv_alloc + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: dvolsp, dvolsm + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: c2por, ckpor + + REAL(wp) :: cpor + REAL(wp) :: por1clay + REAL(wp) :: eps = 1.e-13 + + !! $Id: sedadv.F90 10425 2018-12-19 21:54:16Z smasson $ +CONTAINS + + SUBROUTINE sed_adv( kt ) + !!------------------------------------------------------------------------- + !! *** ROUTINE sed_adv *** + !! + !! ** Purpose : vertical solid sediment advection and burial + !! + !! ** Method : At each grid point the 1-dimensional solid sediment column + !! is shifted according the rain added to the top layer and + !! the gaps produced through redissolution so that in the end + !! the original sediment mixed layer geometry is reestablished. + !! + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) F90 + !! ! 06-04 (C. Ethe) Re-organization + !!------------------------------------------------------------------------- + !!* Arguments + INTEGER, INTENT(in) :: & + kt ! time step + ! * local variables + INTEGER :: ji, jk, js + INTEGER :: jn, ntimes, nztime, ikwneg + + REAL(wp), DIMENSION(jpksed,jpsol) :: zsolcpno + REAL(wp), DIMENSION(jpksed) :: zfilled, zfull, zfromup, zempty + REAL(wp), DIMENSION(jpoce,jpksed) :: zgap, zwb + REAL(wp), DIMENSION(jpoce,jpsol) :: zrainrf + REAL(wp), DIMENSION(: ), ALLOCATABLE :: zraipush + + REAL(wp) :: zkwnup, zkwnlo, zfrac, zfromce, zrest, sumtot, zsumtot1 + + !------------------------------------------------------------------------ + + + IF( ln_timing ) CALL timing_start('sed_adv') +! + IF( kt == nitsed000 ) THEN + IF (lwp) THEN + WRITE(numsed,*) ' ' + WRITE(numsed,*) ' sed_adv : vertical sediment advection ' + WRITE(numsed,*) ' ' + ENDIF + por1clay = denssol * por1(jpksed) * dz(jpksed) + cpor = por1(jpksed) / por1(2) + DO jk = 2, jpksed + c2por(jk) = por1(2) / por1(jk) + ckpor(jk) = por1(jpksed) / por1(jk) + ENDDO + DO jk = jpksedm1, 2, -1 + dvolsp(jk) = vols(jk+1) / vols(jk) + ENDDO + DO jk = 3, jpksed + dvolsm(jk) = vols(jk-1) / vols(jk) + ENDDO + ENDIF + + ! Initialization of data for mass balance calculation + !--------------------------------------------------- + fromsed(:,:) = 0. + tosed (:,:) = 0. + rloss (:,:) = 0. + ikwneg = 1 + nztime = jpksed + + ALLOCATE( zraipush(nztime) ) + + ! Initiate gap + !-------------- + zgap(:,:) = 0. + DO js = 1, jpsol + DO jk = 1, jpksed + DO ji = 1, jpoce + zgap(ji,jk) = zgap(ji,jk) + solcp(ji,jk,js) + END DO + ENDDO + ENDDO + + zgap(1:jpoce,1:jpksed) = 1. - zgap(1:jpoce,1:jpksed) + + ! Initiate burial rates + !----------------------- + zwb(:,:) = 0. + DO jk = 2, jpksed + zfrac = dtsed / ( denssol * por1(jk) ) + DO ji = 1, jpoce + zwb(ji,jk) = zfrac * raintg(ji) + END DO + ENDDO + + + DO ji = 1, jpoce + zwb(ji,2) = zwb(ji,2) - zgap(ji,2) * dz(2) + ENDDO + + DO jk = 3, jpksed + zfrac = por1(jk-1) / por1(jk) + DO ji = 1, jpoce + zwb(ji,jk) = zwb(ji,jk-1) * zfrac - zgap(ji,jk) * dz(jk) + END DO + ENDDO + + zrainrf(:,:) = 0. + DO ji = 1, jpoce + IF( raintg(ji) /= 0. ) & + & zrainrf(ji,:) = rainrg(ji,:) / raintg(ji) + ENDDO + + + ! Computation of full and empty solid fraction in each layer + ! for all 'burial' case + !---------------------------------------------------------- + + + DO ji = 1, jpoce + + ! computation of total weight fraction in sediment + !------------------------------------------------- + zfilled(:) = 0. + DO js = 1, jpsol + DO jk = 2, jpksed + zfilled(jk) = zfilled(jk) + solcp(ji,jk,js) + ENDDO + ENDDO + + DO js = 1, jpsol + DO jk = 2, jpksed + zsolcpno(jk,js) = solcp(ji,jk,js) / zfilled(jk) + ENDDO + ENDDO + + ! burial 3 cases: + ! zwb > 0 ==> rain > total rection loss + ! zwb = 0 ==> rain = 0 + ! zwb < 0 ==> rain > 0 and rain < total reaction loss + !---------------------------------------------------------------- + + IF( zwb(ji,jpksed) > 0. ) THEN + + zfull (jpksed) = zfilled(jpksed) + zempty(jpksed) = 1. - zfull(jpksed) + DO jk = jpksedm1, 2, -1 + zfull (jk) = zfilled(jk) + zfull (jk) = zfull(jk) - zempty(jk+1) * dvolsp(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + + ! Computation of solid sediment species + !-------------------------------------- + ! push entire sediment column downward to account rest of rain + DO js = 1, jpsol + DO jk = jpksed, 3, -1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk-1,js) + ENDDO + + solcp(ji,2,js) = zfull(2) * zsolcpno(2,js) + zempty(2) * zrainrf(ji,js) + + DO jk = 2, jpksed + zsolcpno(jk,js) = solcp(ji,jk,js) + END DO + ENDDO + + zrest = zwb(ji,jpksed) * cpor + ! what is remaining is less than dz(2) + IF( zrest <= dz(2) ) THEN + + zfromup(2) = zrest / dz(2) + DO jk = 3, jpksed + zfromup(jk) = zwb(ji,jpksed) * ckpor(jk) / dz(jk) + ENDDO + DO js = 1, jpsol + zfromce = 1. - zfromup(2) + solcp(ji,2,js) = zfromce * zsolcpno(2,js) + zfromup(2) * zrainrf(ji,js) + DO jk = 3, jpksed + zfromce = 1. - zfromup(jk) + solcp(ji,jk,js) = zfromce * zsolcpno(jk,js) + zfromup(jk) * zsolcpno(jk-1,js) + ENDDO + fromsed(ji,js) = 0. + ! quantities to push in deeper sediment + tosed (ji,js) = zsolcpno(jpksed,js) & + & * zwb(ji,jpksed) * denssol * por1(jpksed) + ENDDO + + ELSE ! what is remaining is great than dz(2) + + ntimes = INT( zrest / dz(2) ) + 1 + IF( ntimes > nztime ) CALL ctl_stop( 'STOP', 'sed_adv : rest too large ' ) + zraipush(1) = dz(2) + zrest = zrest - zraipush(1) + DO jn = 2, ntimes + IF( zrest >= dz(2) ) THEN + zraipush(jn) = dz(2) + zrest = zrest - zraipush(jn) + ELSE + zraipush(jn) = zrest + zrest = 0. + ENDIF + ENDDO + + DO jn = 1, ntimes + DO js = 1, jpsol + DO jk = 2, jpksed + zsolcpno(jk,js) = solcp(ji,jk,js) + END DO + ENDDO + + zfromup(2) = zraipush(jn) / dz(2) + DO jk = 3, jpksed + zfromup(jk) = ( zraipush(jn) / dz(jk) ) * c2por(jk) + ENDDO + + DO js = 1, jpsol + zfromce = 1. - zfromup(2) + solcp(ji,2,js) = zfromce * zsolcpno(2,js) + zfromup(2) * zrainrf(ji,js) + DO jk = 3, jpksed + zfromce = 1. - zfromup(jk) + solcp(ji,jk,js) = zfromce * zsolcpno(jk,js) + zfromup(jk) * zsolcpno(jk-1,js) + ENDDO + fromsed(ji,js) = 0. + tosed (ji,js) = tosed(ji,js) + zsolcpno(jpksed,js) * zraipush(jn) & + & * denssol * por1(2) + ENDDO + ENDDO + + ENDIF + + ELSE IF( raintg(ji) < eps ) THEN ! rain = 0 +!! Nadia rloss(:,:) = rainrm(:,:) bug ?????? + + rloss(ji,1:jpsol) = rainrm(ji,1:jpsol) + + zfull (2) = zfilled(2) + zempty(2) = 1. - zfull(2) + DO jk = 3, jpksed + zfull (jk) = zfilled(jk) + zfull (jk) = zfull (jk) - zempty(jk-1) * dvolsm(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + + ! fill boxes with weight fraction from underlying box + DO js = 1, jpsol + DO jk = 2, jpksedm1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk+1,js) + END DO + solcp(ji,jpksed,js) = zsolcpno(jpksed,js) * zfull(jpksed) + tosed (ji,js) = 0. + fromsed(ji,js) = 0. + ENDDO + ! for the last layer, one make go up clay + solcp(ji,jpksed,jsclay) = solcp(ji,jpksed,jsclay) + zempty(jpksed) * 1. + fromsed(ji,jsclay) = zempty(jpksed) * 1. * por1clay + ELSE ! rain > 0 and rain < total reaction loss + + + DO jk = 2, jpksed + zfull (jk) = zfilled(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + + ! Determination of indice of layer - ikwneg - where advection is reversed + !------------------------------------------------------------------------ + iflag: DO jk = 2, jpksed + IF( zwb(ji,jk) < 0. ) THEN + ikwneg = jk + EXIT iflag + ENDIF + ENDDO iflag + + ! computation of zfull and zempty + ! 3 cases : a/ ikwneg=2, b/ikwneg=3...jpksedm1, c/ikwneg=jpksed + !------------------------------------------------------------- + IF( ikwneg == 2 ) THEN ! advection is reversed in the first sediment layer + + zkwnup = rdtsed(ikwneg) * raintg(ji) / dz(ikwneg) + zkwnlo = ABS( zwb(ji,ikwneg) ) / dz(ikwneg) + zfull (ikwneg+1) = zfilled(ikwneg+1) - zkwnlo * dvolsm(ikwneg+1) + zempty(ikwneg+1) = 1. - zfull(ikwneg+1) + DO jk = ikwneg+2, jpksed + zfull (jk) = zfilled(jk) - zempty(jk-1) * dvolsm(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + DO js = 1, jpsol + solcp(ji,2,js) = zfull(2) * zsolcpno(2,js)+ zkwnlo * zsolcpno(3,js) & + & + zkwnup * zrainrf(ji,js) + DO jk = 3, jpksedm1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk+1,js) + ENDDO + solcp(ji,jpksed,js) = zfull(jpksed) * zsolcpno(jpksed,js) + tosed(ji,js) = 0. + fromsed(ji,js) = 0. + ENDDO + solcp(ji,jpksed,jsclay) = solcp(ji,jpksed,jsclay) + zempty(jpksed) * 1. + !! C. Heinze fromsed(ji,jsclay) = zempty(jpksed) * 1. * denssol * por1(jpksed) / mol_wgt(jsclay) + fromsed(ji,jsclay) = zempty(jpksed) * 1. * por1clay + + ELSE IF( ikwneg == jpksed ) THEN + + zkwnup = ABS( zwb(ji,ikwneg-1) ) * dvolsm(ikwneg) / dz(ikwneg) + zkwnlo = ABS( zwb(ji,ikwneg) ) / dz(ikwneg) + zfull (ikwneg-1) = zfilled(ikwneg-1) - zkwnup * dvolsp(ikwneg-1) + zempty(ikwneg-1) = 1. - zfull(ikwneg-1) + DO jk = ikwneg-2, 2, -1 + zfull (jk) = zfilled(jk) - zempty(jk+1) * dvolsp(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + DO js = 1, jpsol + solcp(ji,2,js) = zfull(2) * zsolcpno(2,js) + zempty(2) * zrainrf(ji,js) + ENDDO + DO js = 1, jpsol + DO jk = jpksedm1, 3, -1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk-1,js) + ENDDO + solcp(ji,jpksed,js) = zfull(jpksed) * zsolcpno(jpksed,js) & + & + zkwnup * zsolcpno(jpksedm1,js) + tosed(ji,js) = 0. + fromsed(ji,js) = 0. + ENDDO + solcp(ji,jpksed,jsclay) = solcp(ji,jpksed,jsclay) + zkwnlo * 1. + ! Heinze fromsed(ji,jsclay) = zkwnlo * 1. * denssol * por1(jpksed) / mol_wgt(jsclay) + fromsed(ji,jsclay) = zkwnlo * 1.* por1clay + ELSE ! 2 < ikwneg(ji) <= jpksedm1 + + zkwnup = ABS( zwb(ji,ikwneg-1) ) * por1(ikwneg-1) / ( dz(ikwneg) * por1(ikwneg) ) + zkwnlo = ABS( zwb(ji,ikwneg) ) / dz(ikwneg) + + IF( ikwneg > 3 ) THEN + + zfull (ikwneg-1) = zfilled(ikwneg-1) - zkwnup * dvolsp(ikwneg-1) + zempty(ikwneg-1) = 1. - zfull(ikwneg-1) + DO jk = ikwneg-2, 2, -1 + zfull (jk) = zfilled(jk) - zempty(jk+1) * dvolsp(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + DO js = 1, jpsol + solcp(ji,2,js) = zfull(2) * zsolcpno(2,js) + zempty(2) * zrainrf(ji,js) + ENDDO + DO js = 1, jpsol + DO jk = ikwneg-1, 3, -1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk-1,js) + ENDDO + ENDDO + ELSE ! ikw = 3 + + + zfull (2) = zfilled(2) - zkwnup * dvolsm(3) + zempty(2) = 1. - zfull(2) + DO js = 1, jpsol + solcp(ji,2,js) = zfull(2) * zsolcpno(2,js) + zempty(2) * zrainrf(ji,js) + ENDDO + ENDIF + + IF( ikwneg < jpksedm1) THEN + + zfull (ikwneg+1) = zfilled(ikwneg+1) - zkwnlo * dvolsm(ikwneg+1) + zempty(ikwneg+1) = 1. - zfull(ikwneg+1) + DO jk = ikwneg+2, jpksed + zfull (jk) = zfilled(jk) - zempty(jk-1) * dvolsm(jk) + zempty(jk) = 1. - zfull(jk) + ENDDO + DO js = 1, jpsol + DO jk = ikwneg+1, jpksedm1 + solcp(ji,jk,js) = zfull(jk) * zsolcpno(jk,js) + zempty(jk) * zsolcpno(jk+1,js) + ENDDO + solcp(ji,jpksed,js) = zfull(jpksed) * zsolcpno(jpksed,js) + ENDDO + solcp(ji,jpksed,jsclay) = solcp(ji,jpksed,jsclay) + zempty(jpksed) * 1. + ELSE + + zfull (jpksed) = zfilled(jpksed) - zkwnlo * dvolsm(jpksed) + zempty(jpksed) = 1. - zfull(jpksed) + DO js = 1, jpsol + solcp(ji,jpksed,js) = zfull(jpksed) * zsolcpno(jpksed,js) + ENDDO + solcp(ji,jpksed,jsclay) = solcp(ji,jpksed,jsclay) + zempty(jpksed) * 1. + ENDIF ! jpksedm1 + + ! ikwneg = jpksedm1 ; ikwneg+1 = jpksed ; ikwneg-1 = jpksed - 2 + DO js = 1, jpsol + solcp(ji,ikwneg,js) = zfull(ikwneg) * zsolcpno(ikwneg ,js) & + & + zkwnup * zsolcpno(ikwneg-1,js) & + & + zkwnlo * zsolcpno(ikwneg+1,js) + tosed (ji,js) = 0. + fromsed(ji,js) = 0. + ENDDO + ! Heinze fromsed(ji,jsclay) = zempty * 1. * denssol * por1(jpksed) / mol_wgt(jsclay) + fromsed(ji,jsclay) = zempty(jpksed) * 1. * por1clay + + ENDIF ! ikwneg(ji) = 2 + ENDIF ! zwb > 0 + ENDDO ! ji = 1, jpoce + + rainrm(:,:) = 0. + rainrg(:,:) = 0. + raintg(:) = 0. + + DEALLOCATE( zraipush ) + + IF( ln_timing ) CALL timing_stop('sed_adv') + + END SUBROUTINE sed_adv + + + INTEGER FUNCTION sed_adv_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_prod_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( dvolsp(jpksed), dvolsm(jpksed), c2por(jpksed), & + & ckpor(jpksed) , STAT = sed_adv_alloc ) + ! + IF( sed_adv_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sed_adv_alloc : failed to allocate arrays.' ) + ! + END FUNCTION sed_adv_alloc + +END MODULE sedadv diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedarr.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedarr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7e4e259d92530a491cfba6671d0079bc6a195ae7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedarr.F90 @@ -0,0 +1,136 @@ +MODULE sedarr + !!====================================================================== + !! *** MODULE sedarr *** + !! transform 1D (2D) array to a 2D (1D) table + !!====================================================================== + + !!---------------------------------------------------------------------- + !! arr_2d_1d : 2-D to 1-D + !! arr_1d_2d : 1-D to 2-D + !!---------------------------------------------------------------------- + !! * Modules used + USE par_sed + USE dom_oce + USE sed + + IMPLICIT NONE + PRIVATE + + INTERFACE pack_arr + MODULE PROCEDURE pack_arr_2d_1d , pack_arr_3d_2d + END INTERFACE + + INTERFACE unpack_arr + MODULE PROCEDURE unpack_arr_1d_2d , unpack_arr_2d_3d + END INTERFACE + + !! * Routine accessibility + PUBLIC pack_arr + PUBLIC unpack_arr + + !!---------------------------------------------------------------------- + !! NEMO/TOP 3.3 , NEMO Consortium (2010) + !! $Id: sedarr.F90 10222 2018-10-25 09:42:23Z aumont $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE pack_arr_2d_1d ( ndim1d, tab1d, tab2d, tab_ind ) + + INTEGER, INTENT(in) :: ndim1d + REAL(wp), DIMENSION (jpi, jpj), INTENT(in) :: tab2d + INTEGER, DIMENSION (ndim1d), INTENT (in) :: tab_ind + REAL(wp), DIMENSION(ndim1d), INTENT (out) :: tab1d + + INTEGER :: jn, jid, jjd + + IF( ln_timing ) CALL timing_start('pack_arr_2d_1d') + + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1, jpi ) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab1d(jn) = tab2d(jid, jjd) + END DO + + IF( ln_timing ) CALL timing_stop('pack_arr_2d_1d') + + END SUBROUTINE pack_arr_2d_1d + + SUBROUTINE unpack_arr_1d_2d ( ndim1d, tab2d, tab_ind, tab1d ) + + INTEGER, INTENT ( in) :: ndim1d + INTEGER, DIMENSION (ndim1d) , INTENT (in) :: tab_ind + REAL(wp), DIMENSION(ndim1d), INTENT (in) :: tab1d + REAL(wp), DIMENSION (jpi, jpj), INTENT ( out) :: tab2d + INTEGER :: jn, jid, jjd + + IF( ln_timing ) CALL timing_start('unpack_arr_1d_2d') + + DO jn = 1, ndim1d + jid = MOD( tab_ind(jn) - 1, jpi) + 1 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + tab2d(jid, jjd) = tab1d(jn) + END DO + + IF( ln_timing ) CALL timing_stop('unpack_arr_1d_2d') + + END SUBROUTINE unpack_arr_1d_2d + + SUBROUTINE pack_arr_3d_2d ( ndim1d, tab2d, tab3d, tab_ind ) + + INTEGER, INTENT(in) :: ndim1d + REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT(in) :: tab3d + INTEGER, DIMENSION(ndim1d), INTENT (in) :: tab_ind + REAL(wp), DIMENSION(ndim1d,jpksed), INTENT (out) :: tab2d + INTEGER, DIMENSION(ndim1d) :: jid, jjd + INTEGER :: jk, jn , ji, jj + + IF( ln_timing ) CALL timing_start('pack_arr_2d_3d') + + DO jn = 1, ndim1d + jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1 + jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1 + END DO + + DO jk = 1, jpksed + DO jn = 1, ndim1d + ji = jid(jn) + jj = jjd(jn) + tab2d(jn,jk) = tab3d(ji,jj,jk) + ENDDO + ENDDO + + IF( ln_timing ) CALL timing_stop('pack_arr_2d_3d') + + END SUBROUTINE pack_arr_3d_2d + + + SUBROUTINE unpack_arr_2d_3d ( ndim1d, tab3d, tab_ind, tab2d ) + + INTEGER, INTENT(in) :: ndim1d + REAL(wp), DIMENSION(ndim1d,jpksed), INTENT(in) :: tab2d + INTEGER, DIMENSION(ndim1d), INTENT (in) :: tab_ind + REAL(wp), DIMENSION(jpi,jpj,jpksed), INTENT (out) :: tab3d + INTEGER, DIMENSION(ndim1d) :: jid, jjd + INTEGER :: jk, jn , ji, jj + ! + IF( ln_timing ) CALL timing_start('unpack_arr_2d_3d') + ! + DO jn = 1, ndim1d + jid(jn) = MOD( tab_ind(jn) - 1, jpi ) + 1 + jjd(jn) = ( tab_ind(jn) - 1 ) / jpi + 1 + END DO + + DO jk = 1, jpksed + DO jn = 1, ndim1d + ji = jid(jn) + jj = jjd(jn) + tab3d(ji, jj, jk) = tab2d(jn,jk) + ENDDO + ENDDO + + IF( ln_timing ) CALL timing_stop('unpack_arr_2d_3d') + + END SUBROUTINE unpack_arr_2d_3d + +END MODULE sedarr diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedbtb.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedbtb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c4f574d4d73a938773ae312fcf8ebba0f6b3b002 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedbtb.F90 @@ -0,0 +1,79 @@ +MODULE sedbtb + !!====================================================================== + !! *** MODULE sedbtb *** + !! Sediment : bioturbation of the solid components + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sedmat ! linear system of equations + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_btb + + + !! $Id: sedbtb.F90 10222 2018-10-25 09:42:23Z aumont $ +CONTAINS + + SUBROUTINE sed_btb( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_btb *** + !! + !! ** Purpose : performs bioturbation of the solid sediment components + !! + !! ** Method : ``diffusion'' of solid sediment components. + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) F90 + !! ! 06-04 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + !!* Arguments + INTEGER, INTENT(in) :: kt ! time step + + ! * local variables + INTEGER :: ji, jk, js + REAL(wp), DIMENSION(jpoce,jpksedm1,jpsol) :: zsol ! solution + !------------------------------------------------------------------------ + + IF( ln_timing ) CALL timing_start('sed_btb') + + IF( kt == nitsed000 ) THEN + IF (lwp) WRITE(numsed,*) ' sed_btb : Bioturbation ' + IF (lwp) WRITE(numsed,*) ' ' + ENDIF + + ! Initializations + !---------------- + zsol(:,:,:) = 0. + + ! right hand side of coefficient matrix + !-------------------------------------- + DO js = 1, jpsol + DO jk = 1, jpksedm1 + DO ji = 1, jpoce + zsol(ji,jk,js) = solcp(ji,jk+1,js) + ENDDO + ENDDO + ENDDO + + CALL sed_mat( jpsol, jpoce, jpksedm1, zsol, dtsed / 2.0_wp ) + + + ! store solution of the tridiagonal system + !------------------------ + DO js = 1, jpsol + DO jk = 1, jpksedm1 + DO ji = 1, jpoce + solcp(ji,jk+1,js) = zsol(ji,jk,js) + ENDDO + ENDDO + ENDDO + + IF( ln_timing ) CALL timing_stop('sed_btb') + + END SUBROUTINE sed_btb + +END MODULE sedbtb diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedchem.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedchem.F90 new file mode 100644 index 0000000000000000000000000000000000000000..195690015d12b268bf81678481b4cf62dd2d2927 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedchem.F90 @@ -0,0 +1,784 @@ +MODULE sedchem + + !!====================================================================== + !! *** Module sedchem *** + !! sediment : Variable for chemistry of the CO2 cycle + !!====================================================================== + !! modules used + USE sed ! sediment global variable + USE sedarr + USE eosbn2, ONLY : neos + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + !! * Accessibility + PUBLIC sed_chem + PUBLIC ahini_for_at_sed ! + PUBLIC solve_at_general_sed ! + + ! Maximum number of iterations for each method + INTEGER, PARAMETER :: jp_maxniter_atgen = 20 + REAL(wp), PARAMETER :: pp_rdel_ah_target = 1.E-4_wp + + !! * Module variables + REAL(wp) :: & + calcon = 1.03E-2 ! mean calcite concentration [Ca2+] in sea water [mole/kg solution] + + REAL(wp) :: rgas = 83.14472 ! universal gas constants + + ! coeff. for density of sea water (Millero & Poisson 1981) + REAL(wp), DIMENSION(5) :: Adsw + DATA Adsw/8.24493E-1, -4.0899E-3, 7.6438E-5 , -8.246E-7, 5.3875E-9 / + + REAL(wp), DIMENSION(3) :: Bdsw + DATA Bdsw / -5.72466E-3, 1.0227E-4, -1.6546E-6 / + + REAL(wp) :: Cdsw = 4.8314E-4 + + REAL(wp), DIMENSION(6) :: Ddsw + DATA Ddsw / 999.842594 , 6.793952E-2 , -9.095290E-3, 1.001685E-4, -1.120083E-6, 6.536332E-9/ + + REAL(wp) :: devk10 = -25.5 + REAL(wp) :: devk11 = -15.82 + REAL(wp) :: devk12 = -29.48 + REAL(wp) :: devk13 = -20.02 + REAL(wp) :: devk14 = -18.03 + REAL(wp) :: devk15 = -9.78 + REAL(wp) :: devk16 = -48.76 + REAL(wp) :: devk17 = -14.51 + REAL(wp) :: devk18 = -23.12 + REAL(wp) :: devk19 = -26.57 + REAL(wp) :: devk110 = -29.48 + ! + REAL(wp) :: devk20 = 0.1271 + REAL(wp) :: devk21 = -0.0219 + REAL(wp) :: devk22 = 0.1622 + REAL(wp) :: devk23 = 0.1119 + REAL(wp) :: devk24 = 0.0466 + REAL(wp) :: devk25 = -0.0090 + REAL(wp) :: devk26 = 0.5304 + REAL(wp) :: devk27 = 0.1211 + REAL(wp) :: devk28 = 0.1758 + REAL(wp) :: devk29 = 0.2020 + REAL(wp) :: devk210 = 0.1622 + ! + REAL(wp) :: devk30 = 0. + REAL(wp) :: devk31 = 0. + REAL(wp) :: devk32 = 2.608E-3 + REAL(wp) :: devk33 = -1.409e-3 + REAL(wp) :: devk34 = 0.316e-3 + REAL(wp) :: devk35 = -0.942e-3 + REAL(wp) :: devk36 = 0. + REAL(wp) :: devk37 = -0.321e-3 + REAL(wp) :: devk38 = -2.647e-3 + REAL(wp) :: devk39 = -3.042e-3 + REAL(wp) :: devk310 = -2.6080e-3 + ! + REAL(wp) :: devk40 = -3.08E-3 + REAL(wp) :: devk41 = 1.13E-3 + REAL(wp) :: devk42 = -2.84E-3 + REAL(wp) :: devk43 = -5.13E-3 + REAL(wp) :: devk44 = -4.53e-3 + REAL(wp) :: devk45 = -3.91e-3 + REAL(wp) :: devk46 = -11.76e-3 + REAL(wp) :: devk47 = -2.67e-3 + REAL(wp) :: devk48 = -5.15e-3 + REAL(wp) :: devk49 = -4.08e-3 + REAL(wp) :: devk410 = -2.84e-3 + ! + REAL(wp) :: devk50 = 0.0877E-3 + REAL(wp) :: devk51 = -0.1475E-3 + REAL(wp) :: devk52 = 0. + REAL(wp) :: devk53 = 0.0794E-3 + REAL(wp) :: devk54 = 0.09e-3 + REAL(wp) :: devk55 = 0.054e-3 + REAL(wp) :: devk56 = 0.3692E-3 + REAL(wp) :: devk57 = 0.0427e-3 + REAL(wp) :: devk58 = 0.09e-3 + REAL(wp) :: devk59 = 0.0714e-3 + REAL(wp) :: devk510 = 0.0 + + !! $Id: sedchem.F90 12837 2020-05-01 08:37:37Z cetlod $ +CONTAINS + + SUBROUTINE sed_chem( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_chem *** + !! + !! ** Purpose : set chemical constants + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) Original code + !! ! 06-04 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + !!* Arguments + INTEGER, INTENT(in) :: kt ! time step + + INTEGER :: ji, jj, ikt + REAL(wp) :: ztc, ztc2 + REAL(wp) :: zsal, zsal15 + REAL(wp) :: zdens0, zaw, zbw, zcw + REAL(wp), DIMENSION(jpi,jpj,15) :: zchem_data + !!---------------------------------------------------------------------- + + + IF( ln_timing ) CALL timing_start('sed_chem') + + IF (lwp) WRITE(numsed,*) ' Getting Chemical constants from tracer model at time kt = ', kt + IF (lwp) WRITE(numsed,*) ' ' + + ! reading variables + zchem_data(:,:,:) = rtrn + + IF (ln_sediment_offline) THEN + CALL sed_chem_cst + ELSE + DO jj = 1,jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + IF ( tmask(ji,jj,ikt) == 1 ) THEN + zchem_data(ji,jj,1) = ak13 (ji,jj,ikt) + zchem_data(ji,jj,2) = ak23 (ji,jj,ikt) + zchem_data(ji,jj,3) = akb3 (ji,jj,ikt) + zchem_data(ji,jj,4) = akw3 (ji,jj,ikt) + zchem_data(ji,jj,5) = aksp (ji,jj,ikt) + zchem_data(ji,jj,6) = borat (ji,jj,ikt) + zchem_data(ji,jj,7) = ak1p3 (ji,jj,ikt) + zchem_data(ji,jj,8) = ak2p3 (ji,jj,ikt) + zchem_data(ji,jj,9) = ak3p3 (ji,jj,ikt) + zchem_data(ji,jj,10)= aksi3 (ji,jj,ikt) + zchem_data(ji,jj,11)= sio3eq(ji,jj,ikt) + zchem_data(ji,jj,12)= aks3 (ji,jj,ikt) + zchem_data(ji,jj,13)= akf3 (ji,jj,ikt) + zchem_data(ji,jj,14)= sulfat(ji,jj,ikt) + zchem_data(ji,jj,15)= fluorid(ji,jj,ikt) + ENDIF + ENDDO + ENDDO + + CALL pack_arr ( jpoce, ak1s (1:jpoce), zchem_data(1:jpi,1:jpj,1) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, ak2s (1:jpoce), zchem_data(1:jpi,1:jpj,2) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, akbs (1:jpoce), zchem_data(1:jpi,1:jpj,3) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, akws (1:jpoce), zchem_data(1:jpi,1:jpj,4) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, aksps (1:jpoce), zchem_data(1:jpi,1:jpj,5) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, borats(1:jpoce), zchem_data(1:jpi,1:jpj,6) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, ak1ps (1:jpoce), zchem_data(1:jpi,1:jpj,7) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, ak2ps (1:jpoce), zchem_data(1:jpi,1:jpj,8) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, ak3ps (1:jpoce), zchem_data(1:jpi,1:jpj,9) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, aksis (1:jpoce), zchem_data(1:jpi,1:jpj,10), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, sieqs (1:jpoce), zchem_data(1:jpi,1:jpj,11), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, aks3s (1:jpoce), zchem_data(1:jpi,1:jpj,12), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, akf3s (1:jpoce), zchem_data(1:jpi,1:jpj,13), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, sulfats(1:jpoce), zchem_data(1:jpi,1:jpj,14), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, fluorids(1:jpoce), zchem_data(1:jpi,1:jpj,15), iarroce(1:jpoce) ) + ENDIF + + DO ji = 1, jpoce + ztc = temp(ji) + ztc2 = ztc * ztc + ! zqtt = ztkel * 0.01 + zsal = salt(ji) + zsal15 = SQRT( zsal ) * zsal + + ! Density of Sea Water - F(temp,sal) [kg/m3] + zdens0 = Ddsw(1) + Ddsw(2) * ztc + Ddsw(3) * ztc2 & + + Ddsw(4) * ztc * ztc2 + Ddsw(5) * ztc2 * ztc2 & + + Ddsw(6) * ztc * ztc2 * ztc2 + zaw = Adsw(1) + Adsw(2) * ztc + Adsw(3)* ztc2 + Adsw(4) * ztc * ztc2 & + + Adsw(5) * ztc2 * ztc2 + zbw = Bdsw(1) + Bdsw(2) * ztc + Bdsw(3) * ztc2 + zcw = Cdsw + densSW(ji) = zdens0 + zaw * zsal + zbw * zsal15 + zcw * zsal * zsal + densSW(ji) = densSW(ji) * 1E-3 ! to get dens in [kg/l] + + ak12s (ji) = ak1s (ji) * ak2s (ji) + ak12ps (ji) = ak1ps(ji) * ak2ps(ji) + ak123ps(ji) = ak1ps(ji) * ak2ps(ji) * ak3ps(ji) + + calcon2(ji) = 0.01028 * ( salt(ji) / 35. ) * densSW(ji) + ENDDO + + IF( ln_timing ) CALL timing_stop('sed_chem') + + END SUBROUTINE sed_chem + + SUBROUTINE ahini_for_at_sed(p_hini) + !!--------------------------------------------------------------------- + !! *** ROUTINE ahini_for_at *** + !! + !! Subroutine returns the root for the 2nd order approximation of the + !! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic + !! polynomial) around the local minimum, if it exists. + !! Returns * 1E-03_wp if p_alkcb <= 0 + !! * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot + !! * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot + !! and the 2nd order approximation does not have + !! a solution + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpoce,jpksed), INTENT(OUT) :: p_hini + INTEGER :: ji, jk + REAL(wp) :: zca1, zba1 + REAL(wp) :: zd, zsqrtd, zhmin + REAL(wp) :: za2, za1, za0 + REAL(wp) :: p_dictot, p_bortot, p_alkcb + + IF( ln_timing ) CALL timing_start('ahini_for_at_sed') + ! + DO jk = 1, jpksed + DO ji = 1, jpoce + p_alkcb = pwcp(ji,jk,jwalk) / densSW(ji) + p_dictot = pwcp(ji,jk,jwdic) / densSW(ji) + p_bortot = borats(ji) / densSW(ji) + IF (p_alkcb <= 0.) THEN + p_hini(ji,jk) = 1.e-3 + ELSEIF (p_alkcb >= (2.*p_dictot + p_bortot)) THEN + p_hini(ji,jk) = 1.e-10_wp + ELSE + zca1 = p_dictot/( p_alkcb + rtrn ) + zba1 = p_bortot/ (p_alkcb + rtrn ) + ! Coefficients of the cubic polynomial + za2 = aKbs(ji)*(1. - zba1) + ak1s(ji)*(1.-zca1) + za1 = ak1s(ji)*akbs(ji)*(1. - zba1 - zca1) & + & + ak1s(ji)*ak2s(ji)*(1. - (zca1+zca1)) + za0 = ak1s(ji)*ak2s(ji)*akbs(ji)*(1. - zba1 - (zca1+zca1)) + ! Taylor expansion around the minimum + zd = za2*za2 - 3.*za1 ! Discriminant of the quadratic equation + ! for the minimum close to the root + + IF(zd > 0.) THEN ! If the discriminant is positive + zsqrtd = SQRT(zd) + IF(za2 < 0) THEN + zhmin = (-za2 + zsqrtd)/3. + ELSE + zhmin = -za1/(za2 + zsqrtd) + ENDIF + p_hini(ji,jk) = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd) + ELSE + p_hini(ji,jk) = 1.e-7 + ENDIF + ! + ENDIF + END DO + END DO + ! + IF( ln_timing ) CALL timing_stop('ahini_for_at_sed') + ! + END SUBROUTINE ahini_for_at_sed + + !=============================================================================== + SUBROUTINE anw_infsup_sed( p_alknw_inf, p_alknw_sup ) + + ! Subroutine returns the lower and upper bounds of "non-water-selfionization" + ! contributions to total alkalinity (the infimum and the supremum), i.e + ! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+]) + + ! Argument variables + INTEGER :: jk + REAL(wp), DIMENSION(jpoce,jpksed), INTENT(OUT) :: p_alknw_inf + REAL(wp), DIMENSION(jpoce,jpksed), INTENT(OUT) :: p_alknw_sup + + DO jk = 1, jpksed + p_alknw_inf(:,jk) = -pwcp(:,jk,jwpo4) / densSW(:) + p_alknw_sup(:,jk) = (2. * pwcp(:,jk,jwdic) + 2. * pwcp(:,jk,jwpo4) + pwcp(:,jk,jwsil) & + & + borats(:) ) / densSW(:) + END DO + + END SUBROUTINE anw_infsup_sed + + + SUBROUTINE solve_at_general_sed( p_hini, zhi ) + + ! Universal pH solver that converges from any given initial value, + ! determines upper an lower bounds for the solution if required + + ! Argument variables + !-------------------- + REAL(wp), DIMENSION(jpoce,jpksed), INTENT(IN) :: p_hini + REAL(wp), DIMENSION(jpoce,jpksed), INTENT(OUT) :: zhi + + ! Local variables + !----------------- + INTEGER :: ji, jk, jn + REAL(wp) :: zh_ini, zh, zh_prev, zh_lnfactor + REAL(wp) :: zdelta, zh_delta + REAL(wp) :: zeqn, zdeqndh, zalka + REAL(wp) :: aphscale + REAL(wp) :: znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic + REAL(wp) :: znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor + REAL(wp) :: znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4 + REAL(wp) :: znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil + REAL(wp) :: znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4 + REAL(wp) :: znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu + REAL(wp) :: zalk_wat, zdalk_wat + REAL(wp) :: zfact, p_alktot, zdic, zbot, zpt, zst, zft, zsit + LOGICAL :: l_exitnow + REAL(wp), PARAMETER :: pz_exp_threshold = 1.0 + REAL(wp), DIMENSION(jpoce,jpksed) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin + + IF( ln_timing ) CALL timing_start('solve_at_general_sed') + ! Allocate temporary workspace + CALL anw_infsup_sed( zalknw_inf, zalknw_sup ) + + rmask(:,:) = 1.0 + zhi(:,:) = 0. + + ! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree + DO jk = 1, jpksed + DO ji = 1, jpoce + IF (rmask(ji,jk) == 1.) THEN + p_alktot = pwcp(ji,jk,jwalk) / densSW(ji) + aphscale = 1. + sulfats(ji)/aks3s(ji) + zh_ini = p_hini(ji,jk) + + zdelta = (p_alktot-zalknw_inf(ji,jk))**2 + 4.*akws(ji) / aphscale + + IF(p_alktot >= zalknw_inf(ji,jk)) THEN + zh_min(ji,jk) = 2.*akws(ji) /( p_alktot-zalknw_inf(ji,jk) + SQRT(zdelta) ) + ELSE + zh_min(ji,jk) = aphscale * (-(p_alktot-zalknw_inf(ji,jk)) + SQRT(zdelta) ) / 2. + ENDIF + + zdelta = (p_alktot-zalknw_sup(ji,jk))**2 + 4.*akws(ji) / aphscale + + IF(p_alktot <= zalknw_sup(ji,jk)) THEN + zh_max(ji,jk) = aphscale * (-(p_alktot-zalknw_sup(ji,jk)) + SQRT(zdelta) ) / 2. + ELSE + zh_max(ji,jk) = 2.*akws(ji) /( p_alktot-zalknw_sup(ji,jk) + SQRT(zdelta) ) + ENDIF + + zhi(ji,jk) = MAX(MIN(zh_max(ji,jk), zh_ini), zh_min(ji,jk)) + ENDIF + END DO + END DO + + zeqn_absmin(:,:) = HUGE(1._dp) + + DO jn = 1, jp_maxniter_atgen + DO jk = 1, jpksed + DO ji = 1, jpoce + IF (rmask(ji,jk) == 1.) THEN + + p_alktot = pwcp(ji,jk,jwalk) / densSW(ji) + zdic = pwcp(ji,jk,jwdic) / densSW(ji) + zbot = borats(ji) / densSW(ji) + zpt = pwcp(ji,jk,jwpo4) / densSW(ji) + zsit = pwcp(ji,jk,jwsil) / densSW(ji) + zst = sulfats(ji) + zft = fluorids(ji) + aphscale = 1. + sulfats(ji)/aks3s(ji) + zh = zhi(ji,jk) + zh_prev = zh + + ! H2CO3 - HCO3 - CO3 : n=2, m=0 + znumer_dic = 2.*ak1s(ji)*ak2s(ji) + zh*ak1s(ji) + zdenom_dic = ak1s(ji)*ak2s(ji) + zh*(ak1s(ji) + zh) + zalk_dic = zdic * (znumer_dic/zdenom_dic) + zdnumer_dic = ak1s(ji)*ak1s(ji)*ak2s(ji) + zh & + *(4.*ak1s(ji)*ak2s(ji) + zh*ak1s(ji)) + zdalk_dic = -zdic*(zdnumer_dic/zdenom_dic**2) + + + ! B(OH)3 - B(OH)4 : n=1, m=0 + znumer_bor = akbs(ji) + zdenom_bor = akbs(ji) + zh + zalk_bor = zbot * (znumer_bor/zdenom_bor) + zdnumer_bor = akbs(ji) + zdalk_bor = -zbot*(zdnumer_bor/zdenom_bor**2) + + + ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1 + znumer_po4 = 3.*ak1ps(ji)*ak2ps(ji)*ak3ps(ji) & + & + zh*(2.*ak1ps(ji)*ak2ps(ji) + zh* ak1ps(ji)) + zdenom_po4 = ak1ps(ji)*ak2ps(ji)*ak3ps(ji) & + & + zh*( ak1ps(ji)*ak2ps(ji) + zh*(ak1ps(ji) + zh)) + zalk_po4 = zpt * (znumer_po4/zdenom_po4 - 1.) ! Zero level of H3PO4 = 1 + zdnumer_po4 = ak1ps(ji)*ak2ps(ji)*ak1ps(ji)*ak2ps(ji)*ak3ps(ji) & + & + zh*(4.*ak1ps(ji)*ak1ps(ji)*ak2ps(ji)*ak3ps(ji) & + & + zh*(9.*ak1ps(ji)*ak2ps(ji)*ak3ps(ji) & + & + ak1ps(ji)*ak1ps(ji)*ak2ps(ji) & + & + zh*(4.*ak1ps(ji)*ak2ps(ji) + zh * ak1ps(ji) ) ) ) + zdalk_po4 = -zpt * (zdnumer_po4/zdenom_po4**2) + + ! H4SiO4 - H3SiO4 : n=1, m=0 + znumer_sil = aksis(ji) + zdenom_sil = aksis(ji) + zh + zalk_sil = zsit * (znumer_sil/zdenom_sil) + zdnumer_sil = aksis(ji) + zdalk_sil = -zsit * (zdnumer_sil/zdenom_sil**2) + + ! HSO4 - SO4 : n=1, m=1 + aphscale = 1.0 + zst/aks3s(ji) + znumer_so4 = aks3s(ji) * aphscale + zdenom_so4 = aks3s(ji) * aphscale + zh + zalk_so4 = zst * (znumer_so4/zdenom_so4 - 1.) + zdnumer_so4 = aks3s(ji) * aphscale + zdalk_so4 = -zst * (zdnumer_so4/zdenom_so4**2) + + ! HF - F : n=1, m=1 + znumer_flu = akf3s(ji) + zdenom_flu = akf3s(ji) + zh + zalk_flu = zft * (znumer_flu/zdenom_flu - 1.) + zdnumer_flu = akf3s(ji) + zdalk_flu = -zft * (zdnumer_flu/zdenom_flu**2) + + ! H2O - OH + zalk_wat = akws(ji)/zh - zh/aphscale + zdalk_wat = -akws(ji)/zh**2 - 1./aphscale + + ! CALCULATE [ALK]([CO3--], [HCO3-]) + zeqn = zalk_dic + zalk_bor + zalk_po4 + zalk_sil & + & + zalk_so4 + zalk_flu & + & + zalk_wat - p_alktot + + zalka = p_alktot - (zalk_bor + zalk_po4 + zalk_sil & + & + zalk_so4 + zalk_flu + zalk_wat) + + zdeqndh = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil & + & + zdalk_so4 + zdalk_flu + zdalk_wat + + ! Adapt bracketing interval + IF(zeqn > 0._wp) THEN + zh_min(ji,jk) = zh_prev + ELSEIF(zeqn < 0._wp) THEN + zh_max(ji,jk) = zh_prev + ENDIF + + IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin(ji,jk)) THEN + ! if the function evaluation at the current point is + ! not decreasing faster than with a bisection step (at least linearly) + ! in absolute value take one bisection step on [ph_min, ph_max] + ! ph_new = (ph_min + ph_max)/2d0 + ! + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_min + ph_max)/2d0) + ! = SQRT(10**(-(ph_min + phmax))) + ! = SQRT(zh_max * zh_min) + zh = SQRT(zh_max(ji,jk) * zh_min(ji,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ELSE + ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH + ! = -zdeqndh * LOG(10) * [H] + ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10)) + ! + ! pH_new = pH_old + \deltapH + ! + ! [H]_new = 10**(-pH_new) + ! = 10**(-pH_old - \Delta pH) + ! = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10))) + ! = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10))) + ! = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old)) + + zh_lnfactor = -zeqn/(zdeqndh*zh_prev) + + IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN + zh = zh_prev*EXP(zh_lnfactor) + ELSE + zh_delta = zh_lnfactor*zh_prev + zh = zh_prev + zh_delta + ENDIF + + IF( zh < zh_min(ji,jk) ) THEN + ! if [H]_new < [H]_min + ! i.e., if ph_new > ph_max then + ! take one bisection step on [ph_prev, ph_max] + ! ph_new = (ph_prev + ph_max)/2d0 + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_prev + ph_max)/2d0) + ! = SQRT(10**(-(ph_prev + phmax))) + ! = SQRT([H]_old*10**(-ph_max)) + ! = SQRT([H]_old * zh_min) + zh = SQRT(zh_prev * zh_min(ji,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ENDIF + + IF( zh > zh_max(ji,jk) ) THEN + ! if [H]_new > [H]_max + ! i.e., if ph_new < ph_min, then + ! take one bisection step on [ph_min, ph_prev] + ! ph_new = (ph_prev + ph_min)/2d0 + ! In terms of [H]_new: + ! [H]_new = 10**(-ph_new) + ! = 10**(-(ph_prev + ph_min)/2d0) + ! = SQRT(10**(-(ph_prev + ph_min))) + ! = SQRT([H]_old*10**(-ph_min)) + ! = SQRT([H]_old * zhmax) + zh = SQRT(zh_prev * zh_max(ji,jk)) + zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below + ENDIF + ENDIF + + zeqn_absmin(ji,jk) = MIN( ABS(zeqn), zeqn_absmin(ji,jk)) + + ! Stop iterations once |\delta{[H]}/[H]| < rdel + ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel + ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)| + ! Alternatively: + ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))| + ! ~ 1/LOG(10) * |\Delta [H]|/[H] + ! < 1/LOG(10) * rdel + + ! Hence |zeqn/(zdeqndh*zh)| < rdel + + ! rdel <-- pp_rdel_ah_target + l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target) + + IF(l_exitnow) THEN + rmask(ji,jk) = 0. + ENDIF + + zhi(ji,jk) = zh + + IF(jn >= jp_maxniter_atgen) THEN + zhi(ji,jk) = -1._wp + ENDIF + + ENDIF + END DO + END DO + END DO + ! + IF( ln_timing ) CALL timing_stop('solve_at_general_sed') + + END SUBROUTINE solve_at_general_sed + + SUBROUTINE sed_chem_cst + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_chem_cst *** + !! + !! ** Purpose : Sea water chemistry computed following MOCSY protocol + !! Computation is done at the bottom of the ocean only + !! + !! ** Method : - ... + !!--------------------------------------------------------------------- + INTEGER :: ji + REAL(wp), DIMENSION(jpoce) :: saltprac, temps + REAL(wp) :: ztkel, ztkel1, zt , zsal , zsal2 , zbuf1 , zbuf2 + REAL(wp) :: ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 + REAL(wp) :: zpres, ztc , zcl , zcpexp, zoxy , zcpexp2 + REAL(wp) :: zsqrt, ztr , zlogt , zcek1, zc1, zplat + REAL(wp) :: zis , zis2 , zsal15, zisqrt, za1, za2 + REAL(wp) :: zckb , zck1 , zck2 , zckw , zak1 , zak2 , zakb , zaksp0, zakw + REAL(wp) :: zck1p, zck2p, zck3p, zcksi, zak1p, zak2p, zak3p, zaksi + REAL(wp) :: zst , zft , zcks , zckf , zaksp1 + REAL(wp) :: total2free, free2SWS, total2SWS, SWS2total + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('sed_chem_cst') + ! + ! Computation of chemical constants require practical salinity + ! Thus, when TEOS08 is used, absolute salinity is converted to + ! practical salinity + ! ------------------------------------------------------------- + IF (neos == -1) THEN + saltprac(:) = salt(:) * 35.0 / 35.16504 + ELSE + saltprac(:) = salt(:) + ENDIF + + ! + ! Computations of chemical constants require in situ temperature + ! Here a quite simple formulation is used to convert + ! potential temperature to in situ temperature. The errors is less than + ! 0.04°C relative to an exact computation + ! --------------------------------------------------------------------- + DO ji = 1, jpoce + zpres = zkbot(ji) / 1000. + za1 = 0.04 * ( 1.0 + 0.185 * temp(ji) + 0.035 * (saltprac(ji) - 35.0) ) + za2 = 0.0075 * ( 1.0 - temp(ji) / 30.0 ) + temps(ji) = temp(ji) - za1 * zpres + za2 * zpres**2 + END DO + + ! CHEMICAL CONSTANTS - DEEP OCEAN + ! ------------------------------- + DO ji = 1, jpoce + ! SET PRESSION ACCORDING TO SAUNDER (1980) + zc1 = 5.92E-3 + zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*zkbot(ji)))) / 4.42E-6 + zpres = zpres / 10.0 + + ! SET ABSOLUTE TEMPERATURE + ztkel = temps(ji) + 273.15 + zsal = saltprac(ji) + zsqrt = SQRT( zsal ) + zsal15 = zsqrt * zsal + zlogt = LOG( ztkel ) + ztr = 1. / ztkel + zis = 19.924 * zsal / ( 1000.- 1.005 * zsal ) + zis2 = zis * zis + zisqrt = SQRT( zis ) + ztc = temps(ji) + + ! CHLORINITY (WOOSTER ET AL., 1969) + zcl = zsal / 1.80655 + + ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] + zst = 0.14 * zcl /96.062 + + ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] + zft = 0.000067 * zcl /18.9984 + + ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) + zcks = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt & + & + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & + & + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis & + & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & + & + LOG(1.0 - 0.001005 * zsal)) + + ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) + zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & + & + LOG(1.0d0 - 0.001005d0*zsal) & + & + LOG(1.0d0 + zst/zcks)) + + ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE + zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & + & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & + & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & + & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & + & * zlogt + 0.053105*zsqrt*ztkel + + ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO + ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale + zck1 = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt & + - 0.011555*zsal + 0.0001152*zsal*zsal) + zck2 = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt & + - 0.01781*zsal + 0.0001122*zsal*zsal) + + ! PKW (H2O) (MILLERO, 1995) from composite data + zckw = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr & + - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal + + ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) + zck1p = -4576.752*ztr + 115.540 - 18.453*zlogt & + & + (-106.736*ztr + 0.69171) * zsqrt & + & + (-0.65643*ztr - 0.01844) * zsal + + zck2p = -8814.715*ztr + 172.1033 - 27.927*zlogt & + & + (-160.340*ztr + 1.3566)*zsqrt & + & + (0.37335*ztr - 0.05778)*zsal + + zck3p = -3070.75*ztr - 18.126 & + & + (17.27039*ztr + 2.81197) * zsqrt & + & + (-44.99486*ztr - 0.09984) * zsal + + ! CONSTANT FOR SILICATE, MILLERO (1995) + zcksi = -8904.2*ztr + 117.400 - 19.334*zlogt & + & + (-458.79*ztr + 3.5913) * zisqrt & + & + (188.74*ztr - 1.5998) * zis & + & + (-12.1652*ztr + 0.07871) * zis2 & + & + LOG(1.0 - 0.001005*zsal) + + ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER + ! (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) + zaksp0 = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel ) & + & + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt & + & - 0.07711*zsal + 0.0041249*zsal15 + + ! CONVERT FROM DIFFERENT PH SCALES + total2free = 1.0/(1.0 + zst/zcks) + free2SWS = 1. + zst/zcks + zft/(zckf*total2free) + total2SWS = total2free * free2SWS + SWS2total = 1.0 / total2SWS + + + ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) + zak1 = 10**(zck1) * total2SWS + zak2 = 10**(zck2) * total2SWS + zakb = EXP( zckb ) * total2SWS + zakw = EXP( zckw ) + zaksp1 = 10**(zaksp0) + zak1p = exp( zck1p ) + zak2p = exp( zck2p ) + zak3p = exp( zck3p ) + zaksi = exp( zcksi ) + zckf = zckf * total2SWS + + ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) + ! (REFERENCE TO CULBERSON & PYTKOQICZ (1968) AS MADE + ! IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS + ! TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres IN + ! DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS + ! MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION + ! WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND + ! & GIESKES (1970), P. 1285-1286 (THE SMALL + ! FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE + ! SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) + zcpexp = zpres / (rgas*ztkel) + zcpexp2 = zpres * zcpexp + + ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE + ! CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) + ! (CF. BROECKER ET AL., 1982) + + zbuf1 = - ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) + zbuf2 = 0.5 * ( devk40 + devk50 * ztc ) + ak1s(ji) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) + zbuf2 = 0.5 * ( devk41 + devk51 * ztc ) + ak2s(ji) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) + zbuf2 = 0.5 * ( devk42 + devk52 * ztc ) + akbs(ji) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) + zbuf2 = 0.5 * ( devk43 + devk53 * ztc ) + akws(ji) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) + zbuf2 = 0.5 * ( devk44 + devk54 * ztc ) + aks3s(ji) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) + zbuf2 = 0.5 * ( devk45 + devk55 * ztc ) + akf3s(ji) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) + zbuf2 = 0.5 * ( devk47 + devk57 * ztc ) + ak1ps(ji) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) + zbuf2 = 0.5 * ( devk48 + devk58 * ztc ) + ak2ps(ji) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + zbuf1 = - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) + zbuf2 = 0.5 * ( devk410 + devk510 * ztc ) + aksis(ji) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + ! Convert to total scale + ak1s(ji) = ak1s(ji) * SWS2total + ak2s(ji) = ak2s(ji) * SWS2total + akbs(ji) = akbs(ji) * SWS2total + akws(ji) = akws(ji) * SWS2total + ak1ps(ji) = ak1ps(ji) * SWS2total + ak2ps(ji) = ak2ps(ji) * SWS2total + ak3ps(ji) = ak3ps(ji) * SWS2total + aksis(ji) = aksis(ji) * SWS2total + akf3s(ji) = akf3s(ji) / total2free + + ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE + ! AS FUNCTION OF PRESSURE FOLLOWING MILLERO + ! (P. 1285) AND BERNER (1976) + zbuf1 = - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) + zbuf2 = 0.5 * ( devk46 + devk56 * ztc ) + aksps(ji) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) + + ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] + borats(ji) = 0.0002414 * zcl / 10.811 + sulfats(ji) = zst + fluorids(ji) = zft + + ! Iron and SIO3 saturation concentration from ... + sieqs(ji) = EXP( LOG( 10.) * ( 6.44 - 968. / ztkel ) ) * 1.e-6 + END DO + ! + IF( ln_timing ) CALL timing_stop('sed_chem_cst') + ! + END SUBROUTINE sed_chem_cst + + +END MODULE sedchem diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedco3.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedco3.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a935287098782a2bbcab1cda57e4ef8a3b979023 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedco3.F90 @@ -0,0 +1,80 @@ +MODULE sedco3 + !!====================================================================== + !! *** MODULE sedco3 *** + !! Sediment : carbonate in sediment pore water + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sedchem + USE lib_mpp ! distribued memory computing library + + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sed_co3 + + !!---------------------------------------------------------------------- + !! OPA 9.0 ! LODYC-IPSL (2003) + !!---------------------------------------------------------------------- + + !! $Id: sedco3.F90 10222 2018-10-25 09:42:23Z aumont $ +CONTAINS + + + SUBROUTINE sed_co3( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_co3 *** + !! + !! ** Purpose : carbonate ion and proton concentration + !! in sediment pore water + !! + !! ** Methode : - solving nonlinear equation for [H+] with given alkalinity + !! and total co2 + !! - one dimensional newton-raphson algorithm for [H+]) + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) coupled with PISCES + !! ! 06-04 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(in) :: kt ! time step + ! + !---Local variables + INTEGER :: ji, jk ! dummy loop indices + + REAL(wp), DIMENSION(jpoce,jpksed) :: zhinit, zhi + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_co3') + + IF( kt == nitsed000 ) THEN + IF (lwp) WRITE(numsed,*) ' sed_co3 : carbonate ion and proton concentration calculation ' + IF (lwp) WRITE(numsed,*) ' ' + ENDIF + + DO jk = 1, jpksed + zhinit(:,jk) = hipor(:,jk) / densSW(:) + END DO + + ! ------------------------------------------- + ! COMPUTE [CO3--] and [H+] CONCENTRATIONS + ! ------------------------------------------- + + CALL solve_at_general_sed(zhinit, zhi) + + DO jk = 1, jpksed + DO ji = 1, jpoce + co3por(ji,jk) = pwcp(ji,jk,jwdic) * ak1s(ji) * ak2s(ji) / (zhi(ji,jk)**2 & + & + ak1s(ji) * zhi(ji,jk) + ak1s(ji) * ak2s(ji) + rtrn ) + hipor(ji,jk) = zhi(ji,jk) * densSW(ji) + END DO + END DO + + IF( ln_timing ) CALL timing_stop('sed_co3') + + END SUBROUTINE sed_co3 + +END MODULE sedco3 diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/seddiff.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddiff.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bca2014f380dcfa689730618e6c391e6f1688083 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddiff.F90 @@ -0,0 +1,120 @@ +MODULE seddiff + !!====================================================================== + !! *** MODULE seddsr *** + !! Sediment : dissolution and reaction in pore water related + !! related to organic matter + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedmat ! linear system of equations + USE sedini + USE lib_mpp ! distribued memory computing library + USE lib_fortran + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_diff + + !! * Module variables + + !! $Id: seddsr.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + + SUBROUTINE sed_diff( kt, knt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_diff *** + !! + !! ** Purpose : computes pore water diffusion + !! + !! ** Methode : implicit computation of undersaturation + !! resulting from diffusive pore water transport. + !! + !! ** Remarks : + !! - undersaturation : deviation from saturation concentration + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) f90 + !! ! 06-04 (C. Ethe) Re-organization + !! ! 19-08 (O. Aumont) Debugging and improvement of the model + !!---------------------------------------------------------------------- + !! Arguments + INTEGER, INTENT(in) :: kt, knt ! number of iteration + ! --- local variables + INTEGER :: ji, jk, js ! dummy looop indices + + REAL(wp), DIMENSION(jpoce,jpksed) :: zrearat1, zrearat2 ! reaction rate in pore water + !! + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_diff') +! + IF( kt == nitsed000 .AND. knt == 1 ) THEN + IF (lwp) THEN + WRITE(numsed,*) ' sed_diff : pore-water diffusion ' + WRITE(numsed,*) ' ' + ENDIF + ENDIF + + ! Initializations + !---------------------- + zrearat1(:,:) = 0. + zrearat2(:,:) = 0. + + !--------------------------- + ! Solves PO4 diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwpo4, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwpo4), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves NH4 diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwnh4, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwnh4), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves Fe2+ diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwfe2, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwfe2), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves H2S diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwh2s, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwh2s), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves SO4 diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwso4, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwso4), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves O2 diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwoxy, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwoxy), dtsed2 / 2.0_wp ) + + !--------------------------- + ! Solves NO3 diffusion + !---------------------------- + + ! solves tridiagonal system + CALL sed_mat( jwno3, jpoce, jpksed, zrearat1, zrearat2, pwcp(:,:,jwno3), dtsed2 / 2.0_wp ) + + CALL sed_mat( jwdic, jpoce, jpksed, zrearat1, zrearat2, sedligand(:,:), dtsed2 / 2.0_wp ) + + IF( ln_timing ) CALL timing_stop('sed_diff') +! + END SUBROUTINE sed_diff + +END MODULE seddiff diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/seddsr.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddsr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fb825f33ad35037953ea3dfb48167f67c2f7134d --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddsr.F90 @@ -0,0 +1,749 @@ +MODULE seddsr + !!====================================================================== + !! *** MODULE seddsr *** + !! Sediment : dissolution and reaction in pore water related + !! related to organic matter + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedini + USE lib_mpp ! distribued memory computing library + USE lib_fortran + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_dsr + + !! * Module variables + + REAL(wp) :: zadsnh4 + REAL(wp), DIMENSION(jpsol), PUBLIC :: dens_mol_wgt ! molecular density + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zvolc ! temp. variables + + + !! $Id: seddsr.F90 10362 2018-11-30 15:38:17Z aumont $ +CONTAINS + + SUBROUTINE sed_dsr( kt, knt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_dsr *** + !! + !! ** Purpose : computes pore water dissolution and reaction + !! + !! ** Methode : Computation of the redox reactions in sediment. + !! The main redox reactions are solved in sed_dsr whereas + !! the secondary reactions are solved in sed_dsr_redoxb. + !! A strand spliting approach is being used here (see + !! sed_dsr_redoxb for more information). + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) f90 + !! ! 06-04 (C. Ethe) Re-organization + !! ! 19-08 (O. Aumont) Debugging and improvement of the model. + !! The original method is replaced by a + !! Strand splitting method which deals + !! well with stiff reactions. + !!---------------------------------------------------------------------- + !! Arguments + INTEGER, INTENT(in) :: kt, knt ! number of iteration + ! --- local variables + INTEGER :: ji, jk, js, jw, jn ! dummy looop indices + + REAL(wp), DIMENSION(jpoce,jpksed) :: zrearat1, zrearat2, zrearat3 ! reaction rate in pore water + REAL(wp), DIMENSION(jpoce,jpksed) :: zundsat ! undersaturation ; indice jpwatp1 is for calcite + REAL(wp), DIMENSION(jpoce,jpksed) :: zkpoc, zkpos, zkpor, zlimo2, zlimno3, zlimso4, zlimfeo ! undersaturation ; indice jpwatp1 is for calcite + REAL(wp), DIMENSION(jpoce) :: zsumtot + REAL(wp) :: zsolid1, zsolid2, zsolid3, zvolw, zreasat + REAL(wp) :: zsatur, zsatur2, znusil, zkpoca, zkpocb, zkpocc + REAL(wp) :: zratio, zgamma, zbeta, zlimtmp, zundsat2 + !! + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_dsr') +! + IF( kt == nitsed000 .AND. knt == 1 ) THEN + IF (lwp) THEN + WRITE(numsed,*) ' sed_dsr : Dissolution reaction ' + WRITE(numsed,*) ' ' + ENDIF + ENDIF + + ! Initializations + !---------------------- + + zrearat1(:,:) = 0. ; zundsat(:,:) = 0. ; zkpoc(:,:) = 0. + zlimo2 (:,:) = 0. ; zlimno3(:,:) = 0. ; zrearat2(:,:) = 0. + zlimso4(:,:) = 0. ; zkpor(:,:) = 0. ; zrearat3(:,:) = 0. + zkpos (:,:) = 0. + zsumtot(:) = rtrn + + ALLOCATE( zvolc(jpoce, jpksed, jpsol) ) + zvolc(:,:,:) = 0. + zadsnh4 = 1.0 / ( 1.0 + adsnh4 ) + + ! Inhibition terms for the different redox equations + ! -------------------------------------------------- + DO jk = 1, jpksed + DO ji = 1, jpoce + zkpoc(ji,jk) = reac_pocl + zkpos(ji,jk) = reac_pocs + zkpor(ji,jk) = reac_pocr + END DO + END DO + + ! Conversion of volume units + !---------------------------- + DO js = 1, jpsol + DO jk = 1, jpksed + DO ji = 1, jpoce + zvolc(ji,jk,js) = ( vols3d(ji,jk) * dens_mol_wgt(js) ) / & + & ( volw3d(ji,jk) * 1.e-3 ) + ENDDO + ENDDO + ENDDO + + !---------------------------------------------------------- + ! 5. Beginning of solid reaction + !--------------------------------------------------------- + + ! Definition of reaction rates [rearat]=sans dim + ! For jk=1 no reaction (pure water without solid) for each solid compo + zrearat1(:,:) = 0. + zrearat2(:,:) = 0. + zrearat3(:,:) = 0. + + zundsat(:,:) = pwcp(:,:,jwoxy) + + DO jk = 2, jpksed + DO ji = 1, jpoce + zlimo2(ji,jk) = 1.0 / ( zundsat(ji,jk) + xksedo2 ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zkpoca = zkpoc(ji,jk) * zlimo2(ji,jk) + zkpocb = zkpos(ji,jk) * zlimo2(ji,jk) + zkpocc = zkpor(ji,jk) * zlimo2(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + ENDDO + ENDDO + + ! left hand side of coefficient matrix +! DO jn = 1, 5 + DO jk = 2, jpksed + DO ji = 1, jpoce +jflag1: DO jn = 1, 10 + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zbeta = xksedo2 - pwcp(ji,jk,jwoxy) + so2ut * ( zrearat1(ji,jk) & + & + zrearat2(ji,jk) + zrearat3(ji,jk) ) + zgamma = - xksedo2 * pwcp(ji,jk,jwoxy) + zundsat2 = zundsat(ji,jk) + zundsat(ji,jk) = ( - zbeta + SQRT( zbeta**2 - 4.0 * zgamma ) ) / 2.0 + zlimo2(ji,jk) = 1.0 / ( zundsat(ji,jk) + xksedo2 ) + zkpoca = zkpoc(ji,jk) * zlimo2(ji,jk) + zkpocb = zkpos(ji,jk) * zlimo2(ji,jk) + zkpocc = zkpor(ji,jk) * zlimo2(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + IF ( ABS( (zundsat(ji,jk)-zundsat2)/(zundsat2+rtrn)) < 1E-8 ) THEN + EXIT jflag1 + ENDIF + END DO jflag1 + END DO + END DO + + ! New solid concentration values (jk=2 to jksed) for each couple + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zlimo2(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspoc) + solcp(ji,jk,jspoc) = solcp(ji,jk,jspoc) - zreasat + zreasat = zrearat2(ji,jk) * zlimo2(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspos) + solcp(ji,jk,jspos) = solcp(ji,jk,jspos) - zreasat + zreasat = zrearat3(ji,jk) * zlimo2(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspor) + solcp(ji,jk,jspor) = solcp(ji,jk,jspor) - zreasat + ENDDO + ENDDO + + ! New pore water concentrations + DO jk = 2, jpksed + DO ji = 1, jpoce + ! Acid Silicic + pwcp(ji,jk,jwoxy) = zundsat(ji,jk) + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) * zlimo2(ji,jk) * zundsat(ji,jk) ! oxygen + ! For DIC + pwcp(ji,jk,jwdic) = pwcp(ji,jk,jwdic) + zreasat + zsumtot(ji) = zsumtot(ji) + zreasat / dtsed2 * volw3d(ji,jk) * 1.e-3 * 86400. * 365. * 1E3 + ! For Phosphate (in mol/l) + pwcp(ji,jk,jwpo4) = pwcp(ji,jk,jwpo4) + zreasat * spo4r + ! For iron (in mol/l) + pwcp(ji,jk,jwfe2) = pwcp(ji,jk,jwfe2) + fecratio(ji) * zreasat + ! For alkalinity + pwcp(ji,jk,jwalk) = pwcp(ji,jk,jwalk) + zreasat * ( srno3 * zadsnh4 - 2.* spo4r ) + ! Ammonium + pwcp(ji,jk,jwnh4) = pwcp(ji,jk,jwnh4) + zreasat * srno3 * zadsnh4 + ! Ligands + sedligand(ji,jk) = sedligand(ji,jk) + ratligc * zreasat - reac_ligc * sedligand(ji,jk) + ENDDO + ENDDO + + !-------------------------------------------------------------------- + ! Begining POC denitrification and NO3- diffusion + ! (indice n5 for couple POC/NO3- ie solcp(:,:,jspoc)/pwcp(:,:,jwno3)) + !-------------------------------------------------------------------- + + zrearat1(:,:) = 0. + zrearat2(:,:) = 0. + zrearat3(:,:) = 0. + + zundsat(:,:) = pwcp(:,:,jwno3) + + DO jk = 2, jpksed + DO ji = 1, jpoce + zlimno3(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) / ( zundsat(ji,jk) + xksedno3 ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zkpoca = zkpoc(ji,jk) * zlimno3(ji,jk) + zkpocb = zkpos(ji,jk) * zlimno3(ji,jk) + zkpocc = zkpor(ji,jk) * zlimno3(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + END DO + END DO + +! DO jn = 1, 5 + DO jk = 2, jpksed + DO ji = 1, jpoce +jflag2: DO jn = 1, 10 + zlimtmp = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zbeta = xksedno3 - pwcp(ji,jk,jwno3) + srDnit * ( zrearat1(ji,jk) & + & + zrearat2(ji,jk) + zrearat3(ji,jk) ) * zlimtmp + zgamma = - xksedno3 * pwcp(ji,jk,jwno3) + zundsat2 = zundsat(ji,jk) + zundsat(ji,jk) = ( - zbeta + SQRT( zbeta**2 - 4.0 * zgamma ) ) / 2.0 + zlimno3(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) / ( zundsat(ji,jk) + xksedno3 ) + zkpoca = zkpoc(ji,jk) * zlimno3(ji,jk) + zkpocb = zkpos(ji,jk) * zlimno3(ji,jk) + zkpocc = zkpor(ji,jk) * zlimno3(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + IF ( ABS( (zundsat(ji,jk)-zundsat2)/(zundsat2+rtrn)) < 1E-8 ) THEN + EXIT jflag2 + ENDIF + END DO jflag2 + END DO + END DO + + + ! New solid concentration values (jk=2 to jksed) for each couple + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zlimno3(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspoc) + solcp(ji,jk,jspoc) = solcp(ji,jk,jspoc) - zreasat + zreasat = zrearat2(ji,jk) * zlimno3(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspos) + solcp(ji,jk,jspos) = solcp(ji,jk,jspos) - zreasat + zreasat = zrearat3(ji,jk) * zlimno3(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspor) + solcp(ji,jk,jspor) = solcp(ji,jk,jspor) - zreasat + ENDDO + ENDDO + + ! New dissolved concentrations + DO jk = 2, jpksed + DO ji = 1, jpoce + ! For nitrates + pwcp(ji,jk,jwno3) = zundsat(ji,jk) + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) * zlimno3(ji,jk) * zundsat(ji,jk) + ! For DIC + pwcp(ji,jk,jwdic) = pwcp(ji,jk,jwdic) + zreasat + zsumtot(ji) = zsumtot(ji) + zreasat / dtsed2 * volw3d(ji,jk) * 1.e-3 * 86400. * 365. * 1E3 + ! For Phosphate (in mol/l) + pwcp(ji,jk,jwpo4) = pwcp(ji,jk,jwpo4) + zreasat * spo4r + ! Ligands + sedligand(ji,jk) = sedligand(ji,jk) + ratligc * zreasat + ! For iron (in mol/l) + pwcp(ji,jk,jwfe2) = pwcp(ji,jk,jwfe2) + fecratio(ji) * zreasat + ! For alkalinity + pwcp(ji,jk,jwalk) = pwcp(ji,jk,jwalk) + zreasat * ( srDnit + srno3 * zadsnh4 - 2.* spo4r ) + ! Ammonium + pwcp(ji,jk,jwnh4) = pwcp(ji,jk,jwnh4) + zreasat * srno3 * zadsnh4 + ENDDO + ENDDO + + !-------------------------------------------------------------------- + ! Begining POC iron reduction + ! (indice n�5 for couple POFe(OH)3 ie solcp(:,:,jspoc)/pwcp(:,:,jsfeo)) + !-------------------------------------------------------------------- + + zrearat1(:,:) = 0. + zrearat2(:,:) = 0. + zrearat3(:,:) = 0. + + zundsat(:,:) = solcp(:,:,jsfeo) + + DO jk = 2, jpksed + DO ji = 1, jpoce + zlimfeo(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) / ( zundsat(ji,jk) + xksedfeo ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zkpoca = zkpoc(ji,jk) * zlimfeo(ji,jk) + zkpocb = zkpos(ji,jk) * zlimfeo(ji,jk) + zkpocc = zkpor(ji,jk) * zlimfeo(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk) * dtsed2 ) + END DO + END DO + +! DO jn = 1, 5 + DO jk = 2, jpksed + DO ji = 1, jpoce +jflag3: DO jn = 1, 10 + zlimtmp = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) / zvolc(ji,jk,jsfeo) + zbeta = xksedfeo - solcp(ji,jk,jsfeo) + 4.0 * zreasat * zlimtmp + zgamma = -xksedfeo * solcp(ji,jk,jsfeo) + zundsat2 = zundsat(ji,jk) + zundsat(ji,jk) = ( - zbeta + SQRT( zbeta**2 - 4.0 * zgamma ) ) / 2.0 + zlimfeo(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) / ( zundsat(ji,jk) + xksedfeo ) + zkpoca = zkpoc(ji,jk) * zlimfeo(ji,jk) + zkpocb = zkpos(ji,jk) * zlimfeo(ji,jk) + zkpocc = zkpor(ji,jk) * zlimfeo(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk) * dtsed2 ) + IF ( ABS( (zundsat(ji,jk)-zundsat2)/( MAX(0.,zundsat2)+rtrn)) < 1E-8 ) THEN + EXIT jflag3 + ENDIF + END DO jflag3 + END DO + END DO + + + ! New solid concentration values (jk=2 to jksed) for each couple + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zlimfeo(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspoc) + solcp(ji,jk,jspoc) = solcp(ji,jk,jspoc) - zreasat + zreasat = zrearat2(ji,jk) * zlimfeo(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspos) + solcp(ji,jk,jspos) = solcp(ji,jk,jspos) - zreasat + zreasat = zrearat3(ji,jk) * zlimfeo(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspor) + solcp(ji,jk,jspor) = solcp(ji,jk,jspor) - zreasat + END DO + END DO + + ! New dissolved concentrations + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) * zlimfeo(ji,jk) * zundsat(ji,jk) + ! For FEOH + solcp(ji,jk,jsfeo) = zundsat(ji,jk) + ! For DIC + pwcp(ji,jk,jwdic) = pwcp(ji,jk,jwdic) + zreasat + zsumtot(ji) = zsumtot(ji) + zreasat / dtsed2 * volw3d(ji,jk) * 1.e-3 * 86400. * 365. * 1E3 + ! For Phosphate (in mol/l) + pwcp(ji,jk,jwpo4) = pwcp(ji,jk,jwpo4) + zreasat * ( spo4r + 4.0 * redfep ) + ! Ligands + sedligand(ji,jk) = sedligand(ji,jk) + ratligc * zreasat + ! For iron (in mol/l) + pwcp(ji,jk,jwfe2) = pwcp(ji,jk,jwfe2) + fecratio(ji) * zreasat + ! For alkalinity + pwcp(ji,jk,jwalk) = pwcp(ji,jk,jwalk) + zreasat * ( srno3 * zadsnh4 - 2.* spo4r ) + 8.0 * zreasat + ! Ammonium + pwcp(ji,jk,jwnh4) = pwcp(ji,jk,jwnh4) + zreasat * srno3 * zadsnh4 + pwcp(ji,jk,jwfe2) = pwcp(ji,jk,jwfe2) + zreasat * 4.0 + ENDDO + ENDDO + + !-------------------------------------------------------------------- + ! Begining POC denitrification and NO3- diffusion + ! (indice n�5 for couple POC/NO3- ie solcp(:,:,jspoc)/pwcp(:,:,jwno3)) + !-------------------------------------------------------------------- + + zrearat1(:,:) = 0. + zrearat2(:,:) = 0. + zrearat3(:,:) = 0. + + zundsat(:,:) = pwcp(:,:,jwso4) + + DO jk = 2, jpksed + DO ji = 1, jpoce + zlimso4(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) * ( 1. - solcp(ji,jk,jsfeo) & + & / ( solcp(ji,jk,jsfeo) + xksedfeo ) ) / ( zundsat(ji,jk) + xksedso4 ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zkpoca = zkpoc(ji,jk) * zlimso4(ji,jk) + zkpocb = zkpos(ji,jk) * zlimso4(ji,jk) + zkpocc = zkpor(ji,jk) * zlimso4(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + END DO + END DO +! +! DO jn = 1, 5 + DO jk = 2, jpksed + DO ji = 1, jpoce +jflag4: DO jn = 1, 10 + zlimtmp = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) * ( 1. - solcp(ji,jk,jsfeo) & + & / ( solcp(ji,jk,jsfeo) + xksedfeo ) ) + zsolid1 = zvolc(ji,jk,jspoc) * solcp(ji,jk,jspoc) + zsolid2 = zvolc(ji,jk,jspos) * solcp(ji,jk,jspos) + zsolid3 = zvolc(ji,jk,jspor) * solcp(ji,jk,jspor) + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) + zbeta = xksedso4 - pwcp(ji,jk,jwso4) + 0.5 * zreasat * zlimtmp + zgamma = - xksedso4 * pwcp(ji,jk,jwso4) + zundsat2 = zundsat(ji,jk) + zundsat(ji,jk) = ( - zbeta + SQRT( zbeta**2 - 4.0 * zgamma ) ) / 2.0 + zlimso4(ji,jk) = ( 1.0 - pwcp(ji,jk,jwoxy) * zlimo2(ji,jk) ) * ( 1.0 - pwcp(ji,jk,jwno3) & + & / ( pwcp(ji,jk,jwno3) + xksedno3 ) ) * ( 1. - solcp(ji,jk,jsfeo) & + & / ( solcp(ji,jk,jsfeo) + xksedfeo ) ) / ( zundsat(ji,jk) + xksedso4 ) + zkpoca = zkpoc(ji,jk) * zlimso4(ji,jk) + zkpocb = zkpos(ji,jk) * zlimso4(ji,jk) + zkpocc = zkpor(ji,jk) * zlimso4(ji,jk) + zrearat1(ji,jk) = ( zkpoc(ji,jk) * dtsed2 * zsolid1 ) / & + & ( 1. + zkpoca * zundsat(ji,jk ) * dtsed2 ) + zrearat2(ji,jk) = ( zkpos(ji,jk) * dtsed2 * zsolid2 ) / & + & ( 1. + zkpocb * zundsat(ji,jk ) * dtsed2 ) + zrearat3(ji,jk) = ( zkpor(ji,jk) * dtsed2 * zsolid3 ) / & + & ( 1. + zkpocc * zundsat(ji,jk ) * dtsed2 ) + IF ( ABS( (zundsat(ji,jk)-zundsat2)/(zundsat2+rtrn)) < 1E-8 ) THEN + EXIT jflag4 + ENDIF + END DO jflag4 + END DO + END DO + + ! New solid concentration values (jk=2 to jksed) for each couple + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zlimso4(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspoc) + solcp(ji,jk,jspoc) = solcp(ji,jk,jspoc) - zreasat + zreasat = zrearat2(ji,jk) * zlimso4(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspos) + solcp(ji,jk,jspos) = solcp(ji,jk,jspos) - zreasat + zreasat = zrearat3(ji,jk) * zlimso4(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jspor) + solcp(ji,jk,jspor) = solcp(ji,jk,jspor) - zreasat + ENDDO + ENDDO +! + ! New dissolved concentrations + DO jk = 2, jpksed + DO ji = 1, jpoce + ! For sulfur + pwcp(ji,jk,jwh2s) = pwcp(ji,jk,jwh2s) - ( zundsat(ji,jk) - pwcp(ji,jk,jwso4) ) + pwcp(ji,jk,jwso4) = zundsat(ji,jk) + zreasat = ( zrearat1(ji,jk) + zrearat2(ji,jk) + zrearat3(ji,jk) ) * zlimso4(ji,jk) * zundsat(ji,jk) + ! For DIC + pwcp(ji,jk,jwdic) = pwcp(ji,jk,jwdic) + zreasat + zsumtot(ji) = zsumtot(ji) + zreasat / dtsed2 * volw3d(ji,jk) * 1.e-3 * 86400. * 365. * 1E3 + ! For Phosphate (in mol/l) + pwcp(ji,jk,jwpo4) = pwcp(ji,jk,jwpo4) + zreasat * spo4r + ! Ligands + sedligand(ji,jk) = sedligand(ji,jk) + ratligc * zreasat + ! For iron (in mol/l) + pwcp(ji,jk,jwfe2) = pwcp(ji,jk,jwfe2) + fecratio(ji) * zreasat + ! For alkalinity + pwcp(ji,jk,jwalk) = pwcp(ji,jk,jwalk) + zreasat * ( srno3 * zadsnh4 - 2.* spo4r ) + zreasat + ! Ammonium + pwcp(ji,jk,jwnh4) = pwcp(ji,jk,jwnh4) + zreasat * srno3 * zadsnh4 + ENDDO + ENDDO + + ! Oxydation of the reduced products. Here only ammonium and ODU is accounted for + ! There are two options here: A simple time splitting scheme and a modified + ! Patankar scheme + ! ------------------------------------------------------------------------------ + + call sed_dsr_redoxb + + ! -------------------------------------------------------------- + ! 4/ Computation of the bioturbation coefficient + ! This parameterization is taken from Archer et al. (2002) + ! -------------------------------------------------------------- + + DO ji = 1, jpoce + db(ji,:) = dbiot * zsumtot(ji) * pwcp(ji,1,jwoxy) / (pwcp(ji,1,jwoxy) + 20.E-6) + END DO + + ! ------------------------------------------------------ + ! Vertical variations of the bioturbation coefficient + ! ------------------------------------------------------ + IF (ln_btbz) THEN + DO ji = 1, jpoce + db(ji,:) = db(ji,:) * exp( -(profsedw(:) / dbtbzsc)**2 ) / (365.0 * 86400.0) + END DO + ELSE + DO jk = 1, jpksed + IF (profsedw(jk) > dbtbzsc) THEN + db(:,jk) = 0.0 + ENDIF + END DO + ENDIF + + IF (ln_irrig) THEN + DO jk = 1, jpksed + DO ji = 1, jpoce + irrig(ji,jk) = ( 7.63752 - 7.4465 * exp( -0.89603 * zsumtot(ji) ) ) * pwcp(ji,1,jwoxy) & + & / (pwcp(ji,1,jwoxy) + 20.E-6) + irrig(ji,jk) = irrig(ji,jk) * exp( -(profsedw(jk) / xirrzsc) ) + END DO + END DO + ELSE + irrig(:,:) = 0.0 + ENDIF + + DEALLOCATE( zvolc ) + + IF( ln_timing ) CALL timing_stop('sed_dsr') +! + END SUBROUTINE sed_dsr + + SUBROUTINE sed_dsr_redoxb + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_dsr_redox *** + !! + !! ** Purpose : computes secondary redox reactions + !! + !! ** Methode : It uses Strand splitter algorithm proposed by + !! Nguyen et al. (2009) and modified by Wang et al. (2018) + !! Basically, each equation is solved analytically when + !! feasible, otherwise numerically at t+1/2. Then + !! the last equation is solved at t+1. The other equations + !! are then solved at t+1 starting in the reverse order. + !! Ideally, it's better to start from the fastest reaction + !! to the slowest and then reverse the order to finish up + !! with the fastest one. But random order works well also. + !! The scheme is second order, positive and mass + !! conserving. It works well for stiff systems. + !! + !! History : + !! ! 18-08 (O. Aumont) Original code + !!---------------------------------------------------------------------- + !! Arguments + ! --- local variables + INTEGER :: ji, jk, jn ! dummy looop indices + + REAL, DIMENSION(6) :: zsedtrn, zsedtra + REAL(wp) :: zalpha, zbeta, zgamma, zdelta, zepsi, zsedfer + !! + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_dsr_redoxb') + + DO ji = 1, jpoce + DO jk = 2, jpksed + zsedtrn(1) = pwcp(ji,jk,jwoxy) + zsedtrn(2) = MAX(0., pwcp(ji,jk,jwh2s) ) + zsedtrn(3) = pwcp(ji,jk,jwnh4) + zsedtrn(4) = MAX(0., pwcp(ji,jk,jwfe2) - sedligand(ji,jk) ) + zsedfer = MIN(0., pwcp(ji,jk,jwfe2) - sedligand(ji,jk) ) + zsedtrn(5) = solcp(ji,jk,jsfeo) * zvolc(ji,jk,jsfeo) + zsedtrn(6) = solcp(ji,jk,jsfes) * zvolc(ji,jk,jsfes) + zsedtra(:) = zsedtrn(:) + + ! First pass of the scheme. At the end, it is 1st order + ! ----------------------------------------------------- + ! Fe + O2 + zalpha = zsedtra(1) - 0.25 * zsedtra(4) + zbeta = zsedtra(4) + zsedtra(5) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(4) + zdelta = pwcp(ji,jk,jwpo4) - redfep * zsedtra(4) + IF ( zalpha == 0. ) THEN + zsedtra(4) = zsedtra(4) / ( 1.0 + zsedtra(4) * reac_fe2 * dtsed2 / 2.0 ) + ELSE + zsedtra(4) = ( zsedtra(4) * zalpha ) / ( 0.25 * zsedtra(4) * ( exp( reac_fe2 * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_fe2 * zalpha * dtsed2 / 2. ) ) + ENDIF + zsedtra(1) = zalpha + 0.25 * zsedtra(4) + zsedtra(5) = zbeta - zsedtra(4) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(4) + pwcp(ji,jk,jwpo4) = zdelta + redfep * zsedtra(4) + ! H2S + O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(2) + zbeta = pwcp(ji,jk,jwso4) + zsedtra(2) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(2) + IF ( zalpha == 0. ) THEN + zsedtra(2) = zsedtra(2) / ( 1.0 + zsedtra(2) * reac_h2s * dtsed2 / 2.0 ) + ELSE + zsedtra(2) = ( zsedtra(2) * zalpha ) / ( 2.0 * zsedtra(2) * ( exp( reac_h2s * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_h2s * zalpha * dtsed2 / 2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(2) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(2) + pwcp(ji,jk,jwso4) = zbeta - zsedtra(2) + ! NH4 + O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(3) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(3) + IF ( zalpha == 0. ) THEN + zsedtra(3) = zsedtra(3) / ( 1.0 + zsedtra(3) * reac_nh4 * zadsnh4 * dtsed2 / 2.0 ) + ELSE + zsedtra(3) = ( zsedtra(3) * zalpha ) / ( 2.0 * zsedtra(3) * ( exp( reac_nh4 * zadsnh4 * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_nh4 * zadsnh4 * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(3) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(3) + ! FeS - O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(6) + zbeta = zsedtra(4) + zsedtra(6) + zgamma = pwcp(ji,jk,jwso4) + zsedtra(6) + IF ( zalpha == 0. ) THEN + zsedtra(6) = zsedtra(6) / ( 1.0 + zsedtra(6) * reac_feso * dtsed2 / 2.0 ) + ELSE + zsedtra(6) = ( zsedtra(6) * zalpha ) / ( 2.0 * zsedtra(6) * ( exp( reac_feso * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_feso * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(6) + zsedtra(4) = zbeta - zsedtra(6) + pwcp(ji,jk,jwso4) = zgamma - zsedtra(6) +! ! Fe - H2S + zalpha = zsedtra(2) - zsedtra(4) + zbeta = zsedtra(4) + zsedtra(6) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(4) + IF ( zalpha == 0. ) THEN + zsedtra(4) = zsedtra(4) / ( 1.0 + zsedtra(4) * reac_fes * dtsed2 / 2.0 ) + ELSE + zsedtra(4) = ( zsedtra(4) * zalpha ) / ( zsedtra(4) * ( exp( reac_fes * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_fes * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(2) = zalpha + zsedtra(4) + zsedtra(6) = zbeta - zsedtra(4) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(4) + ! FEOH + H2S + zalpha = zsedtra(5) - 2.0 * zsedtra(2) + zbeta = zsedtra(5) + zsedtra(4) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(4) + zdelta = pwcp(ji,jk,jwso4) + zsedtra(2) + zepsi = pwcp(ji,jk,jwpo4) + redfep * zsedtra(5) + IF ( zalpha == 0. ) THEN + zsedtra(2) = zsedtra(2) / ( 1.0 + zsedtra(2) * reac_feh2s * dtsed2 ) + ELSE + zsedtra(2) = ( zsedtra(2) * zalpha ) / ( 2.0 * zsedtra(2) * ( exp( reac_feh2s * zalpha * dtsed2 ) - 1.0 ) & + & + zalpha * exp( reac_feh2s * zalpha * dtsed2 ) ) + ENDIF + zsedtra(5) = zalpha + 2.0 * zsedtra(2) + zsedtra(4) = zbeta - zsedtra(5) + pwcp(ji,jk,jwso4) = zdelta - zsedtra(2) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(4) + pwcp(ji,jk,jwpo4) = zepsi - redfep * zsedtra(5) + ! Fe - H2S + zalpha = zsedtra(2) - zsedtra(4) + zbeta = zsedtra(4) + zsedtra(6) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(4) + IF ( zalpha == 0. ) THEN + zsedtra(4) = zsedtra(4) / ( 1.0 + zsedtra(4) * reac_fes * dtsed2 / 2.0 ) + ELSE + zsedtra(4) = ( zsedtra(4) * zalpha ) / ( zsedtra(4) * ( exp( reac_fes * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_fes * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(2) = zalpha + zsedtra(4) + zsedtra(6) = zbeta - zsedtra(4) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(4) + ! FeS - O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(6) + zbeta = zsedtra(4) + zsedtra(6) + zgamma = pwcp(ji,jk,jwso4) + zsedtra(6) + IF (zalpha == 0.) THEN + zsedtra(6) = zsedtra(6) / ( 1.0 + zsedtra(6) * reac_feso * dtsed2 / 2. ) + ELSE + zsedtra(6) = ( zsedtra(6) * zalpha ) / ( 2.0 * zsedtra(6) * ( exp( reac_feso * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_feso * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(6) + zsedtra(4) = zbeta - zsedtra(6) + pwcp(ji,jk,jwso4) = zgamma - zsedtra(6) + ! NH4 + O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(3) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(3) + IF (zalpha == 0.) THEN + zsedtra(3) = zsedtra(3) / ( 1.0 + zsedtra(3) * reac_nh4 * zadsnh4 * dtsed2 / 2.0) + ELSE + zsedtra(3) = ( zsedtra(3) * zalpha ) / ( 2.0 * zsedtra(3) * ( exp( reac_nh4 * zadsnh4 * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_nh4 * zadsnh4 * zalpha * dtsed2 /2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(3) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(3) + ! H2S + O2 + zalpha = zsedtra(1) - 2.0 * zsedtra(2) + zbeta = pwcp(ji,jk,jwso4) + zsedtra(2) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(2) + IF ( zalpha == 0. ) THEN + zsedtra(2) = zsedtra(2) / ( 1.0 + zsedtra(2) * reac_h2s * dtsed2 / 2.0 ) + ELSE + zsedtra(2) = ( zsedtra(2) * zalpha ) / ( 2.0 * zsedtra(2) * ( exp( reac_h2s * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_h2s * zalpha * dtsed2 / 2. ) ) + ENDIF + zsedtra(1) = zalpha + 2.0 * zsedtra(2) + pwcp(ji,jk,jwso4) = zbeta - zsedtra(2) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(2) + ! Fe + O2 + zalpha = zsedtra(1) - 0.25 * zsedtra(4) + zbeta = zsedtra(4) + zsedtra(5) + zgamma = pwcp(ji,jk,jwalk) - 2.0 * zsedtra(4) + zdelta = pwcp(ji,jk,jwpo4) - redfep * zsedtra(4) + IF ( zalpha == 0. ) THEN + zsedtra(4) = zsedtra(4) / ( 1.0 + zsedtra(4) * reac_fe2 * dtsed2 / 2.0 ) + ELSE + zsedtra(4) = ( zsedtra(4) * zalpha ) / ( 0.25 * zsedtra(4) * ( exp( reac_fe2 * zalpha * dtsed2 / 2. ) - 1.0 ) & + & + zalpha * exp( reac_fe2 * zalpha * dtsed2 / 2. ) ) + ENDIF + zsedtra(1) = zalpha + 0.25 * zsedtra(4) + zsedtra(5) = zbeta - zsedtra(4) + pwcp(ji,jk,jwpo4) = zdelta + redfep * zsedtra(4) + pwcp(ji,jk,jwalk) = zgamma + 2.0 * zsedtra(4) + pwcp(ji,jk,jwoxy) = zsedtra(1) + pwcp(ji,jk,jwh2s) = zsedtra(2) + pwcp(ji,jk,jwnh4) = zsedtra(3) + pwcp(ji,jk,jwfe2) = zsedtra(4) + sedligand(ji,jk) + zsedfer + pwcp(ji,jk,jwno3) = pwcp(ji,jk,jwno3) + ( zsedtrn(3) - pwcp(ji,jk,jwnh4) ) + solcp(ji,jk,jsfeo) = zsedtra(5) / zvolc(ji,jk,jsfeo) + solcp(ji,jk,jsfes) = zsedtra(6) / zvolc(ji,jk,jsfes) + END DO + END DO + + IF( ln_timing ) CALL timing_stop('sed_dsr_redoxb') + + END SUBROUTINE sed_dsr_redoxb + +END MODULE seddsr diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/seddta.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddta.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ab37cd0f80ce6c30bff222683d9752556764e587 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/seddta.F90 @@ -0,0 +1,226 @@ +MODULE seddta + !!====================================================================== + !! *** MODULE seddta *** + !! Sediment data : read sediment input data from a file + !!===================================================================== + + !! * Modules used + USE sed + USE sedarr + USE phycst, ONLY : rday + USE iom + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sed_dta ! + + !! * Module variables + REAL(wp) :: rsecday ! number of second per a day + REAL(wp) :: conv2 ! [kg/m2/month]-->[g/cm2/s] ( 1 month has 30 days ) + + !! $Id: seddta.F90 10362 2018-11-30 15:38:17Z aumont $ +CONTAINS + + !!--------------------------------------------------------------------------- + !! sed_dta : read the NetCDF data file in online version using module iom + !!--------------------------------------------------------------------------- + + SUBROUTINE sed_dta( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_dta *** + !! + !! ** Purpose : Reads data from a netcdf file and + !! initialization of rain and pore water (k=1) components + !! + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) Original code + !! ! 06-04 (C. Ethe) Re-organization ; Use of iom + !!---------------------------------------------------------------------- + + !! Arguments + INTEGER, INTENT(in) :: kt ! time-step + + !! * Local declarations + INTEGER :: ji, jj, js, jw, ikt + + REAL(wp), DIMENSION(jpoce) :: zdtap, zdtag + REAL(wp), DIMENSION(jpi,jpj) :: zwsbio4, zwsbio3 + REAL(wp) :: zf0, zf1, zf2, zkapp, zratio, zdep + + !---------------------------------------------------------------------- + + ! Initialization of sediment variable + ! Spatial dimension is merged, and unity converted if needed + !------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_dta') + + IF (lwp) THEN + WRITE(numsed,*) + WRITE(numsed,*) ' sed_dta : Bottom layer fields' + WRITE(numsed,*) ' ~~~~~~' + WRITE(numsed,*) ' Data from SMS model' + WRITE(numsed,*) + ENDIF + + + ! open file + IF( kt == nitsed000 ) THEN + IF (lwp) WRITE(numsed,*) ' sed_dta : Sediment fields' + dtsed = r2dttrc + rsecday = 60.* 60. * 24. +! conv2 = 1.0e+3 / ( 1.0e+4 * rsecday * 30. ) + conv2 = 1.0e+3 / 1.0e+4 + rdtsed(2:jpksed) = dtsed / ( denssol * por1(2:jpksed) ) + ENDIF + + ! Initialization of temporaries arrays + zdtap(:) = 0. + zdtag(:) = 0. + + ! reading variables + IF (lwp) WRITE(numsed,*) + IF (lwp) WRITE(numsed,*) ' sed_dta : Bottom layer fields at time kt = ', kt + ! reading variables + ! + ! Sinking speeds of detritus is increased with depth as shown + ! by data and from the coagulation theory + ! ----------------------------------------------------------- + IF (ln_sediment_offline) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zwsbio4(ji,jj) = wsbio2 / rday + zwsbio3(ji,jj) = wsbio / rday + END DO + END DO + ELSE + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + zdep = e3t_n(ji,jj,ikt) / r2dttrc + zwsbio4(ji,jj) = MIN( 0.99 * zdep, wsbio4(ji,jj,ikt) / rday ) + zwsbio3(ji,jj) = MIN( 0.99 * zdep, wsbio3(ji,jj,ikt) / rday ) + END DO + END DO + ENDIF + + trc_data(:,:,:) = 0. + DO jj = 1,jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + IF ( tmask(ji,jj,ikt) == 1 ) THEN + trc_data(ji,jj,1) = trb(ji,jj,ikt,jpsil) + trc_data(ji,jj,2) = trb(ji,jj,ikt,jpoxy) + trc_data(ji,jj,3) = trb(ji,jj,ikt,jpdic) + trc_data(ji,jj,4) = trb(ji,jj,ikt,jpno3) / 7.625 + trc_data(ji,jj,5) = trb(ji,jj,ikt,jppo4) / 122. + trc_data(ji,jj,6) = trb(ji,jj,ikt,jptal) + trc_data(ji,jj,7) = trb(ji,jj,ikt,jpnh4) / 7.625 + trc_data(ji,jj,8) = 0.0 + trc_data(ji,jj,9) = 28.0E-3 + trc_data(ji,jj,10) = trb(ji,jj,ikt,jpfer) + trc_data(ji,jj,11 ) = MIN(trb(ji,jj,ikt,jpgsi), 1E-4) * zwsbio4(ji,jj) * 1E3 + trc_data(ji,jj,12 ) = MIN(trb(ji,jj,ikt,jppoc), 1E-4) * zwsbio3(ji,jj) * 1E3 + trc_data(ji,jj,13 ) = MIN(trb(ji,jj,ikt,jpgoc), 1E-4) * zwsbio4(ji,jj) * 1E3 + trc_data(ji,jj,14) = MIN(trb(ji,jj,ikt,jpcal), 1E-4) * zwsbio4(ji,jj) * 1E3 + trc_data(ji,jj,15) = tsn(ji,jj,ikt,jp_tem) + trc_data(ji,jj,16) = tsn(ji,jj,ikt,jp_sal) + trc_data(ji,jj,17 ) = ( trb(ji,jj,ikt,jpsfe) * zwsbio3(ji,jj) + trb(ji,jj,ikt,jpbfe) & + & * zwsbio4(ji,jj) ) * 1E3 / ( trc_data(ji,jj,12 ) + trc_data(ji,jj,13 ) + rtrn ) + trc_data(ji,jj,17 ) = MIN(1E-3, trc_data(ji,jj,17 ) ) + ENDIF + ENDDO + ENDDO + + ! Pore water initial concentration [mol/l] in k=1 + !------------------------------------------------- + DO jw = 1, jpwat + CALL pack_arr ( jpoce, pwcp_dta(1:jpoce,jw), trc_data(1:jpi,1:jpj,jw), iarroce(1:jpoce) ) + END DO + ! Solid components : + !----------------------- + ! Sinking fluxes for OPAL in mol.m-2.s-1 ; conversion in mol.cm-2.s-1 + CALL pack_arr ( jpoce, rainrm_dta(1:jpoce,jsopal), trc_data(1:jpi,1:jpj,11), iarroce(1:jpoce) ) + rainrm_dta(1:jpoce,jsopal) = rainrm_dta(1:jpoce,jsopal) * 1e-4 + ! Sinking fluxes for POC in mol.m-2.s-1 ; conversion in mol.cm-2.s-1 + CALL pack_arr ( jpoce, zdtap(1:jpoce), trc_data(1:jpi,1:jpj,12) , iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, zdtag(1:jpoce), trc_data(1:jpi,1:jpj,13) , iarroce(1:jpoce) ) + DO ji = 1, jpoce +! zkapp = MIN( (1.0 - 0.02 ) * reac_poc, 3731.0 * max(100.0, zkbot(ji) )**(-1.011) / ( 365.0 * 24.0 * 3600.0 ) ) +! zkapp = MIN( 0.98 * reac_poc, 100.0 * max(100.0, zkbot(ji) )**(-0.6) / ( 365.0 * 24.0 * 3600.0 ) ) +! zratio = ( ( 1.0 - 0.02 ) * reac_poc + 0.02 * reac_poc * 0. - zkapp) / ( ( 0.02 - 1.0 ) * reac_poc / 100. - 0.02 * reac_poc * 0. + zkapp ) +! zf1 = ( 0.02 * (reac_poc - reac_poc * 0.) + zkapp - reac_poc ) / ( reac_poc / 100. - reac_poc ) +! zf1 = MIN(0.98, MAX(0., zf1 ) ) + zf1 = 0.48 + zf0 = 1.0 - 0.02 - zf1 + zf2 = 0.02 + rainrm_dta(ji,jspoc) = ( zdtap(ji) + zdtag(ji) ) * 1e-4 * zf0 + rainrm_dta(ji,jspos) = ( zdtap(ji) + zdtag(ji) ) * 1e-4 * zf1 + rainrm_dta(ji,jspor) = ( zdtap(ji) + zdtag(ji) ) * 1e-4 * zf2 + END DO + ! Sinking fluxes for Calcite in mol.m-2.s-1 ; conversion in mol.cm-2.s-1 + CALL pack_arr ( jpoce, rainrm_dta(1:jpoce,jscal), trc_data(1:jpi,1:jpj,14), iarroce(1:jpoce) ) + rainrm_dta(1:jpoce,jscal) = rainrm_dta(1:jpoce,jscal) * 1e-4 + ! vector temperature [C] and salinity + CALL pack_arr ( jpoce, temp(1:jpoce), trc_data(1:jpi,1:jpj,15), iarroce(1:jpoce) ) + CALL pack_arr ( jpoce, salt(1:jpoce), trc_data(1:jpi,1:jpj,16), iarroce(1:jpoce) ) + + ! Clay rain rate in [mol/(cm**2.s)] + ! inputs data in [kg.m-2.sec-1] ---> 1e+3/(1e+4) [g.cm-2.s-1] + ! divided after by molecular weight g.mol-1 + CALL pack_arr ( jpoce, rainrm_dta(1:jpoce,jsclay), dust(1:jpi,1:jpj), iarroce(1:jpoce) ) + rainrm_dta(1:jpoce,jsclay) = rainrm_dta(1:jpoce,jsclay) * conv2 / mol_wgt(jsclay) & + & + wacc(1:jpoce) * por1(2) * denssol / mol_wgt(jsclay) / ( rsecday * 365.0 ) + rainrm_dta(1:jpoce,jsclay) = rainrm_dta(1:jpoce,jsclay) * 0.965 + rainrm_dta(1:jpoce,jsfeo) = rainrm_dta(1:jpoce,jsclay) * mol_wgt(jsclay) / mol_wgt(jsfeo) * 0.035 / 0.965 +! rainrm_dta(1:jpoce,jsclay) = 1.0E-4 * conv2 / mol_wgt(jsclay) + + ! Iron monosulphide rain rates. Set to 0 + rainrm_dta(1:jpoce,jsfes) = 0. + + ! Fe/C ratio in sinking particles that fall to the sediments + CALL pack_arr ( jpoce, fecratio(1:jpoce), trc_data(1:jpi,1:jpj,17), iarroce(1:jpoce) ) + + sedligand(:,1) = 1.E-9 + + ! sediment pore water at 1st layer (k=1) + DO jw = 1, jpwat + pwcp(1:jpoce,1,jw) = pwcp_dta(1:jpoce,jw) + ENDDO + + ! rain + DO js = 1, jpsol + rainrm(1:jpoce,js) = rainrm_dta(1:jpoce,js) + ENDDO + + ! Calculation of raintg of each sol. comp.: rainrm in [g/(cm**2.s)] + DO js = 1, jpsol + rainrg(1:jpoce,js) = rainrm(1:jpoce,js) * mol_wgt(js) + ENDDO + + ! Calculation of raintg = total massic flux rained in each cell (sum of sol. comp.) + raintg(:) = 0. + DO js = 1, jpsol + raintg(1:jpoce) = raintg(1:jpoce) + rainrg(1:jpoce,js) + ENDDO + + ! computation of dzdep = total thickness of solid material rained [cm] in each cell + dzdep(1:jpoce) = raintg(1:jpoce) * rdtsed(2) + + IF( lk_iomput ) THEN + IF( iom_use("sflxclay" ) ) CALL iom_put( "sflxclay", dust(:,:) * conv2 * 1E4 ) + IF( iom_use("sflxcal" ) ) CALL iom_put( "sflxcal", trc_data(:,:,13) ) + IF( iom_use("sflxbsi" ) ) CALL iom_put( "sflxbsi", trc_data(:,:,10) ) + IF( iom_use("sflxpoc" ) ) CALL iom_put( "sflxpoc", trc_data(:,:,11) + trc_data(:,:,12) ) + ENDIF + + IF( ln_timing ) CALL timing_stop('sed_dta') + + END SUBROUTINE sed_dta + +END MODULE seddta diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedini.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6f26966be1e9f77bfd0478b0ef727dc0f944a7fc --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedini.F90 @@ -0,0 +1,693 @@ +MODULE sedini + !!====================================================================== + !! *** MODULE sedini *** + !! Sediment : define sediment variables + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sed_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedarr + USE sedadv + USE trc_oce, ONLY : nn_dttrc + USE trcdmp_sed + USE trcdta + USE iom + USE lib_mpp ! distribued memory computing library + + + IMPLICIT NONE + PRIVATE + + !! Module variables + REAL(wp) :: & + sedzmin = 0.3 , & !: Minimum vertical spacing + sedhmax = 10.0 , & !: Maximum depth of the sediment + sedkth = 5.0 , & !: Default parameters + sedacr = 3.0 !: Default parameters + + REAL(wp) :: & + porsurf = 0.95 , & !: Porosity at the surface + porinf = 0.75 , & !: Porosity at infinite depth + rhox = 2.0 !: Vertical length scale of porosity variation + + REAL(wp) :: & + rcopal = 40. , & !: reactivity for si [l.mol-1.an-1] + dcoef = 8.e-6 !: diffusion coefficient (*por) [cm**2/s] + + REAL(wp), PUBLIC :: & + redO2 = 172. , & !: Redfield coef for Oxygen + redNo3 = 16. , & !: Redfield coef for Nitrate + redPo4 = 1. , & !: Redfield coef for Phosphate + redC = 122. , & !: Redfield coef for Carbon + redfep = 0.175 , & !: Ratio for iron bound phosphorus + rcorgl = 50. , & !: reactivity for POC/O2 [l.mol-1.an-1] + rcorgs = 0.5 , & !: reactivity of the semi-labile component + rcorgr = 1E-4 , & !: reactivity of the refractory component + rcnh4 = 10E6 , & !: reactivity for O2/NH4 [l.mol-1.an-1] + rch2s = 1.E5 , & !: reactivity for O2/ODU [l.mol-1.an-1] + rcfe2 = 5.E8 , & !: reactivity for O2/Fe2+ [l.mol-1.an-1] + rcfeh2s = 1.E4 , & !: Reactivity for FEOH/H2S [l.mol-1.an-1] + rcfes = 1.E5 , & !: Reactivity for FE2+/H2S [l.mol-1.an-1] + rcfeso = 3.E5 , & !: Reactivity for FES/O2 [l.mol-1.an-1] + xksedo2 = 5E-6 , & !: half-sturation constant for oxic remin. + xksedno3 = 5E-6 , & !: half-saturation constant for denitrification + xksedfeo = 0.6 , & !: half-saturation constant for iron remin + xksedso4 = 2E-3 !: half-saturation constant for SO4 remin + + REAL(wp) :: & + rccal = 1000., & !: reactivity for calcite [l.mol-1.an-1] + rcligc = 1.E-4 !: L/C ratio in POC + + REAL(wp), PUBLIC :: dbiot = 15. , & !: coefficient for bioturbation [cm**2.(n-1)] + dbtbzsc = 10.0 , & !: Vertical scale of variation. If no variation, mixed layer in the sed [cm] + xirrzsc = 2.0 !: Vertical scale of irrigation variation. + REAL(wp) :: & + ryear = 365. * 24. * 3600. !: 1 year converted in second + + REAL(wp), DIMENSION(jpwat), PUBLIC :: diff1 + DATA diff1/4.59E-6, 1.104E-5, 4.81E-6 , 9.78E-6, 3.58E-6, 4.01E-6, 9.8E-6, 9.73E-6, 5.0E-6, 3.31E-6 / + + REAL(wp), DIMENSION(jpwat), PUBLIC :: diff2 + DATA diff2/1.74E-7, 4.47E-7, 2.51E-7, 3.89E-7, 1.77E-7, 2.5E-7, 3.89E-7, 3.06E-7, 2.5E-7, 1.5E-7 / + + + + !! * Routine accessibility + PUBLIC sed_init ! routine called by opa.F90 + + !! $Id: sedini.F90 11536 2019-09-11 13:54:18Z smasson $ +CONTAINS + + + SUBROUTINE sed_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_init *** + !! + !! ** Purpose : Initialization of sediment module + !! - Reading namelist + !! - Read the deepest water layer thickness + !! ( using as mask ) in Netcdf file + !! - Convert unity if necessary + !! - sets initial sediment composition + !! ( only clay or reading restart file ) + !! - sets sediment grid, porosity and others constants + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) Original code + !! ! 06-07 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, ikt, ierr + !!---------------------------------------------------------------------- + + + ! Reading namelist.sed variables + !--------------------------------------- + + CALL ctl_opn( numsed, 'sediment.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + + IF (lwp) THEN + WRITE(numsed,*) + WRITE(numsed,*) ' PISCES framework' + WRITE(numsed,*) ' SEDIMENT model' + WRITE(numsed,*) ' version 3.0 (2018) ' + WRITE(numsed,*) + WRITE(numsed,*) + ENDIF + + IF(lwp) WRITE(numsed,*) ' sed_init : Initialization of sediment module ' + IF(lwp) WRITE(numsed,*) ' ' + + ! Read sediment Namelist + !------------------------- + CALL sed_init_nam + + ! Allocate SEDIMENT arrays + ierr = sed_alloc() + ierr = ierr + sed_oce_alloc() + ierr = ierr + sed_adv_alloc() + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sed_ini: unable to allocate sediment model arrays' ) + + ! Determination of sediments number of points and allocate global variables + epkbot(:,:) = 0. + DO jj = 1, jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_1d(ikt) + gdepbot(ji,jj) = gdepw_0(ji,jj,ikt) + ENDDO + ENDDO + + ! computation of total number of ocean points + !-------------------------------------------- + sedmask = 0. + IF ( COUNT( epkbot(:,:) > 0. ) == 0 ) THEN + sedmask = 0. + ELSE + sedmask = 1. + ENDIF + jpoce = MAX( COUNT( epkbot(:,:) > 0. ) , 1 ) + + ! Allocate memory size of global variables + ALLOCATE( pwcp (jpoce,jpksed,jpwat) ) ; ALLOCATE( pwcp0 (jpoce,jpksed,jpwat) ) ; ALLOCATE( pwcp_dta (jpoce,jpwat) ) + ALLOCATE( solcp(jpoce,jpksed,jpsol) ) ; ALLOCATE( solcp0(jpoce,jpksed,jpsol) ) ; ALLOCATE( rainrm_dta(jpoce,jpsol) ) + ALLOCATE( rainrm(jpoce,jpsol) ) ; ALLOCATE( rainrg(jpoce,jpsol) ) ; ALLOCATE( raintg(jpoce) ) + ALLOCATE( dzdep(jpoce) ) ; ALLOCATE( iarroce(jpoce) ) ; ALLOCATE( dzkbot(jpoce) ) + ALLOCATE( zkbot(jpoce) ) ; ALLOCATE( db(jpoce,jpksed) ) + ALLOCATE( temp(jpoce) ) ; ALLOCATE( salt(jpoce) ) + ALLOCATE( diff(jpoce,jpksed,jpwat ) ) ; ALLOCATE( irrig(jpoce, jpksed) ) + ALLOCATE( wacc(jpoce) ) ; ALLOCATE( fecratio(jpoce) ) + ALLOCATE( press(jpoce) ) ; ALLOCATE( densSW(jpoce) ) + ALLOCATE( hipor(jpoce,jpksed) ) ; ALLOCATE( co3por(jpoce,jpksed) ) + ALLOCATE( dz3d(jpoce,jpksed) ) ; ALLOCATE( volw3d(jpoce,jpksed) ) ; ALLOCATE( vols3d(jpoce,jpksed) ) + ALLOCATE( sedligand(jpoce, jpksed) ) + + ! Initialization of global variables + pwcp (:,:,:) = 0. ; pwcp0 (:,:,:) = 0. ; pwcp_dta (:,:) = 0. + solcp (:,:,:) = 0. ; solcp0(:,:,:) = 0. ; rainrm_dta(:,:) = 0. + rainrm(:,: ) = 0. ; rainrg(:,: ) = 0. ; raintg (: ) = 0. + dzdep (: ) = 0. ; iarroce(: ) = 0 ; dzkbot (: ) = 0. + temp (: ) = 0. ; salt (: ) = 0. ; zkbot (: ) = 0. + press (: ) = 0. ; densSW (: ) = 0. ; db (:,:) = 0. + hipor (:,: ) = 0. ; co3por (:,: ) = 0. ; irrig (:,:) = 0. + dz3d (:,: ) = 0. ; volw3d (:,: ) = 0. ; vols3d (:,:) = 0. + fecratio(:) = 1E-5 + sedligand(:,:) = 0.6E-9 + + ! Chemical variables + ALLOCATE( akbs (jpoce) ) ; ALLOCATE( ak1s (jpoce) ) ; ALLOCATE( ak2s (jpoce) ) ; ALLOCATE( akws (jpoce) ) + ALLOCATE( ak1ps (jpoce) ) ; ALLOCATE( ak2ps (jpoce) ) ; ALLOCATE( ak3ps (jpoce) ) ; ALLOCATE( aksis (jpoce) ) + ALLOCATE( aksps (jpoce) ) ; ALLOCATE( ak12s (jpoce) ) ; ALLOCATE( ak12ps(jpoce) ) ; ALLOCATE( ak123ps(jpoce) ) + ALLOCATE( borats(jpoce) ) ; ALLOCATE( calcon2(jpoce) ) ; ALLOCATE( sieqs (jpoce) ) + ALLOCATE( aks3s(jpoce) ) ; ALLOCATE( akf3s(jpoce) ) ; ALLOCATE( sulfats(jpoce) ) + ALLOCATE( fluorids(jpoce) ) + + akbs (:) = 0. ; ak1s (:) = 0. ; ak2s (:) = 0. ; akws (:) = 0. + ak1ps (:) = 0. ; ak2ps (:) = 0. ; ak3ps (:) = 0. ; aksis (:) = 0. + aksps (:) = 0. ; ak12s (:) = 0. ; ak12ps(:) = 0. ; ak123ps(:) = 0. + borats(:) = 0. ; calcon2(:) = 0. ; sieqs (:) = 0. + aks3s(:) = 0. ; akf3s(:) = 0. ; sulfats(:) = 0. ; fluorids(:) = 0. + + ! Mass balance calculation + ALLOCATE( fromsed(jpoce, jpsol) ) ; ALLOCATE( tosed(jpoce, jpsol) ) ; ALLOCATE( rloss(jpoce, jpsol) ) + ALLOCATE( tokbot (jpoce, jpwat) ) + + fromsed(:,:) = 0. ; tosed(:,:) = 0. ; rloss(:,:) = 0. ; tokbot(:,:) = 0. + + ! Initialization of sediment geometry + !------------------------------------ + CALL sed_init_geom + + ! Offline specific mode + ! --------------------- + ln_sediment_offline = .FALSE. + +#if defined key_sed_off + ln_sediment_offline = .TRUE. + IF (lwp) write(numsed,*) 'Sediment module is run in offline mode' + IF (lwp) write(numsed,*) 'key_sed_off is activated at compilation time' + IF (lwp) write(numsed,*) 'ln_sed_2way is forced to false' + IF (lwp) write(numsed,*) '--------------------------------------------' + ln_sed_2way = .FALSE. +#endif + ! Initialisation of tracer damping + ! -------------------------------- + IF (ln_sediment_offline) THEN + CALL trc_dta_ini(jptra) + CALL trc_dmp_sed_ini + ENDIF + + END SUBROUTINE sed_init + + SUBROUTINE sed_init_geom + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_init_geom *** + !! + !! ** Purpose : Initialization of sediment geometry + !! - Read the deepest water layer thickness + !! ( using as mask ) in Netcdf file + !! - sets sediment grid, porosity and molecular weight + !! and others constants + !! + !! History : + !! ! 06-07 (C. Ethe) Original + !!---------------------------------------------------------------------- + !! * Modules used + !! * local declarations + INTEGER :: ji, jj, jk, jn + REAL(wp) :: za0, za1, zt, zw, zsum, zsur, zprof, zprofw + REAL(wp) :: ztmp1, ztmp2 + !---------------------------------------------------------- + + IF(lwp) WRITE(numsed,*) ' sed_init_geom : Initialization of sediment geometry ' + IF(lwp) WRITE(numsed,*) ' ' + + ! Computation of 1D array of sediments points + indoce = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( epkbot(ji,jj) > 0. ) THEN + indoce = indoce + 1 + iarroce(indoce) = (jj - 1) * jpi + ji + ENDIF + END DO + END DO + + IF ( indoce .EQ. 0 ) THEN + indoce = 1 + iarroce(indoce) = 1 + ENDIF + + IF( indoce .NE. jpoce ) THEN + CALL ctl_stop( 'STOP', 'sed_ini: number of ocean points indoce doesn''t match number of point' ) + ELSE + IF (lwp) WRITE(numsed,*) ' ' + IF (lwp) WRITE(numsed,*) ' total number of ocean points jpoce = ',jpoce + IF (lwp) WRITE(numsed,*) ' ' + ENDIF + + ! initialization of dzkbot in [cm] + !------------------------------------------------ + CALL pack_arr ( jpoce, dzkbot(1:jpoce), epkbot(1:jpi,1:jpj), iarroce(1:jpoce) ) + dzkbot(1:jpoce) = dzkbot(1:jpoce) * 1.e+2 + CALL pack_arr ( jpoce, zkbot(1:jpoce), gdepbot(1:jpi,1:jpj), iarroce(1:jpoce) ) + + ! Geometry and constants + ! sediment layer thickness [cm] + ! (1st layer= diffusive layer = pur water) + !------------------------------------------ + za1 = ( sedzmin - sedhmax / FLOAT(jpksed-1) ) & + & / ( TANH((1-sedkth)/sedacr) - sedacr/FLOAT(jpksed-1) * ( LOG( COSH( (jpksed - sedkth) / sedacr) ) & + & - LOG( COSH( ( 1 - sedkth) / sedacr) ) ) ) + za0 = sedzmin - za1 * TANH( (1-sedkth) / sedacr ) + zsur = - za0 - za1 * sedacr * LOG( COSH( (1-sedkth) / sedacr ) ) + + profsedw(1) = 0.0 + profsed(1) = -dz(1) / 2. + DO jk = 2, jpksed + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) - 0.5_wp + profsed(jk) = ( zsur + za0 * zt + za1 * sedacr * LOG ( COSH( (zt-sedkth) / sedacr ) ) ) + profsedw(jk) = ( zsur + za0 * zw + za1 * sedacr * LOG ( COSH( (zw-sedkth) / sedacr ) ) ) + END DO + + dz(1) = 0.1 + DO jk = 2, jpksed + dz(jk) = profsedw(jk) - profsedw(jk-1) + END DO + + DO jk = 1, jpksed + DO ji = 1, jpoce + dz3d(ji,jk) = dz(jk) + END DO + ENDDO + + ! Porosity profile [0] + !--------------------- + por(1) = 1.0 + DO jk = 2, jpksed + por(jk) = porinf + ( porsurf-porinf) * exp(-rhox * (profsed(jk) ) ) + END DO + + ! inverse of Porosity profile + !----------------------------- + por1(:) = 1. - por(:) + + ! Volumes of pore water and solid fractions (vector and array) + ! WARNING : volw(1) and vols(1) are sublayer volums + volw(:) = dz(:) * por(:) + vols(:) = dz(:) * por1(:) + + ! temporary new value for dz3d(:,1) + dz3d(1:jpoce,1) = dzkbot(1:jpoce) + + ! WARNING : volw3d(:,1) and vols3d(:,1) are deepest water column volums + DO jk = 1, jpksed + volw3d(1:jpoce,jk) = dz3d(1:jpoce,jk) * por (jk) + vols3d(1:jpoce,jk) = dz3d(1:jpoce,jk) * por1(jk) + ENDDO + + ! Back to the old sublayer vlaue for dz3d(:,1) + dz3d(1:jpoce,1) = dz(1) + + !--------------------------------------------- + ! Molecular weight [g/mol] for solid species + !--------------------------------------------- + + ! opal=sio2*0.4(h20)=28+2*16+0.4*(2+16) + !--------------------------------------- + mol_wgt(jsopal) = 28. + 2. * 16. + 0.4 * ( 2. + 16. ) + + ! clay + ! some kind of Illit (according to Pape) + ! K0.58(Al 1.38 Fe(III)0.37Fe(II)0.04Mg0.34)[(OH)2|(Si3.41Al0.59)O10] + !-------------------------------------------------------------------- + mol_wgt(jsclay) = 0.58 * 39. + 1.38 * 27. + ( 0.37 + 0.04 ) * 56.+ & + & 0.34 * 24. + 2. * ( 16. + 1. ) + 3.41 * 38. + & + & 0.59 * 27. + 10. * 16. + + mol_wgt(jsfeo) = 55.0 + 3.0 * ( 16.0 + 1.0) + + mol_wgt(jsfes) = 55.0 + 32.0 + + ! for chemistry Poc : C(122)H(244)O(86)N(16)P(1) + ! But den sity of Poc is an Hydrated material (= POC + 30H2O) + ! So C(122)H(355)O(120)N(16)P(1) + !------------------------------------------------------------ + mol_wgt(jspoc) = ( 122. * 12. + 355. + 120. * 16.+ & + & 16. * 14. + 31. ) / 122. + mol_wgt(jspos) = mol_wgt(jspoc) + mol_wgt(jspor) = mol_wgt(jspoc) + + ! CaCO3 + !--------- + mol_wgt(jscal) = 40. + 12. + 3. * 16. + + ! Density of solid material in sediment [g/cm**3] + !------------------------------------------------ + denssol = 2.6 + + ! Initialization of diffusion coefficient as function of porosity [cm**2/s] + !-------------------------------------------------------------------- +! DO jn = 1, jpsol +! DO jk = 1, jpksed +! DO ji = 1, jpoce +! diff(ji,jk,jn) = dcoef / ( 1.0 - 2.0 * log(por(jk)) ) +! END DO +! END DO +! END DO + + ! Accumulation rate from Burwicz et al. (2011). This is used to + ! compute the flux of clays and minerals + ! -------------------------------------------------------------- + DO ji = 1, jpoce + ztmp1 = 0.117 / ( 1.0 + ( zkbot(ji) / 200.)**3 ) + ztmp2 = 0.006 / ( 1.0 + ( zkbot(ji) / 4000.)**10 ) + wacc(ji) = ztmp1 + ztmp2 + END DO + + + ! Initialization of time step as function of porosity [cm**2/s] + !------------------------------------------------------------------ + END SUBROUTINE sed_init_geom + + SUBROUTINE sed_init_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_init_nam *** + !! + !! ** Purpose : Initialization of sediment geometry + !! - Reading namelist and defines constants variables + !! + !! History : + !! ! 06-07 (C. Ethe) Original + !!---------------------------------------------------------------------- + + INTEGER :: numnamsed_ref = -1 !! Logical units for namelist sediment + INTEGER :: numnamsed_cfg = -1 !! Logical units for namelist sediment + INTEGER :: ios ! Local integer output status for namelist read + CHARACTER(LEN=20) :: clname + + TYPE PSED + CHARACTER(len = 20) :: snamesed !: short name + CHARACTER(len = 80 ) :: lnamesed !: long name + CHARACTER(len = 20 ) :: unitsed !: unit + END TYPE PSED + + TYPE(PSED) , DIMENSION(jpsol ) :: sedsol + TYPE(PSED) , DIMENSION(jpwat ) :: sedwat + TYPE(PSED) , DIMENSION(jpdia3dsed) :: seddiag3d + TYPE(PSED) , DIMENSION(jpdia2dsed) :: seddiag2d + + NAMELIST/nam_run/nrseddt,ln_sed_2way + NAMELIST/nam_geom/jpksed, sedzmin, sedhmax, sedkth, sedacr, porsurf, porinf, rhox + NAMELIST/nam_trased/sedsol, sedwat + NAMELIST/nam_diased/seddiag3d, seddiag2d + NAMELIST/nam_inorg/rcopal, dcoef, rccal, ratligc, rcligc + NAMELIST/nam_poc/redO2, redNo3, redPo4, redC, redfep, rcorgl, rcorgs, & + & rcorgr, rcnh4, rch2s, rcfe2, rcfeh2s, rcfes, rcfeso, & + & xksedo2, xksedno3, xksedfeo, xksedso4 + NAMELIST/nam_btb/dbiot, ln_btbz, dbtbzsc, adsnh4, ln_irrig, xirrzsc + NAMELIST/nam_rst/ln_rst_sed, cn_sedrst_indir, cn_sedrst_outdir, cn_sedrst_in, cn_sedrst_out + + INTEGER :: ji, jn, jn1 + !------------------------------------------------------- + + IF(lwp) WRITE(numsed,*) ' sed_init_nam : Read namelists ' + IF(lwp) WRITE(numsed,*) ' ' + + ! ryear = 1 year converted in second + !------------------------------------ + IF (lwp) THEN + WRITE(numsed,*) ' ' + WRITE(numsed,*) 'number of seconds in one year : ryear = ', ryear + WRITE(numsed,*) ' ' + ENDIF + + ! Reading namelist.sed variables + !--------------------------------- + clname = 'namelist_sediment' + IF(lwp) WRITE(numsed,*) ' sed_init_nam : read SEDIMENT namelist' + IF(lwp) WRITE(numsed,*) ' ~~~~~~~~~~~~~~' + CALL ctl_opn( numnamsed_ref, TRIM( clname )//'_ref', 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numnamsed_cfg, TRIM( clname )//'_cfg', 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + + nitsed000 = nittrc000 + nitsedend = nitend + ! Namelist nam_run + REWIND( numnamsed_ref ) ! Namelist nam_run in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_run, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_run in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_run in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_run, IOSTAT = ios, ERR = 902) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_run in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_run' + WRITE(numsed,*) ' Nb of iterations for fast species nrseddt = ', nrseddt + WRITE(numsed,*) ' 2-way coupling between PISCES and Sed ln_sed_2way = ', ln_sed_2way + ENDIF + + IF ( ln_p5z .AND. ln_sed_2way ) CALL ctl_stop( '2 ways coupling with sediment cannot be activated with PISCES-QUOTA' ) + + REWIND( numnamsed_ref ) ! Namelist nam_geom in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_geom, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_geom in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_geom in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_geom, IOSTAT = ios, ERR = 904) +904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_geom in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_geom' + WRITE(numsed,*) ' Number of vertical layers jpksed = ', jpksed + WRITE(numsed,*) ' Minimum vertical spacing sedzmin = ', sedzmin + WRITE(numsed,*) ' Maximum depth of the sediment sedhmax = ', sedhmax + WRITE(numsed,*) ' Default parameter sedkth = ', sedkth + WRITE(numsed,*) ' Default parameter sedacr = ', sedacr + WRITE(numsed,*) ' Sediment porosity at the surface porsurf = ', porsurf + WRITE(numsed,*) ' Sediment porosity at infinite depth porinf = ', porinf + WRITE(numsed,*) ' Length scale of porosity variation rhox = ', rhox + ENDIF + + jpksedm1 = jpksed - 1 + dtsed = r2dttrc + + REWIND( numnamsed_ref ) ! Namelist nam_trased in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_trased, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_trased in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_trased in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_trased, IOSTAT = ios, ERR = 906) +906 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_trased in configuration namelist' ) + + DO jn = 1, jpsol + sedtrcd(jn) = sedsol(jn)%snamesed + sedtrcl(jn) = sedsol(jn)%lnamesed + sedtrcu(jn) = sedsol(jn)%unitsed + END DO + + DO jn = 1, jpwat + jn1 = jn + jpsol + sedtrcd(jn1) = sedwat(jn)%snamesed + sedtrcl(jn1) = sedwat(jn)%lnamesed + sedtrcu(jn1) = sedwat(jn)%unitsed + END DO + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_trased' + WRITE(numsed,*) ' ' + DO jn = 1, jptrased + WRITE(numsed,*) 'name of 3d output sediment field number :',jn,' : ',TRIM(sedtrcd(jn)) + WRITE(numsed,*) 'long name ', TRIM(sedtrcl(jn)) + WRITE(numsed,*) ' in unit = ', TRIM(sedtrcu(jn)) + WRITE(numsed,*) ' ' + END DO + WRITE(numsed,*) ' ' + ENDIF + + REWIND( numnamsed_ref ) ! Namelist nam_diased in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_diased, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diased in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_diased in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_diased, IOSTAT = ios, ERR = 908) +908 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diased in configuration namelist' ) + + DO jn = 1, jpdia3dsed + seddia3d(jn) = seddiag3d(jn)%snamesed + seddia3l(jn) = seddiag3d(jn)%lnamesed + seddia3u(jn) = seddiag3d(jn)%unitsed + END DO + + DO jn = 1, jpdia2dsed + seddia2d(jn) = seddiag2d(jn)%snamesed + seddia2l(jn) = seddiag2d(jn)%lnamesed + seddia2u(jn) = seddiag2d(jn)%unitsed + END DO + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_diased' + WRITE(numsed,*) ' ' + DO jn = 1, jpdia3dsed + WRITE(numsed,*) 'name of 3D output diag number :',jn, ' : ', TRIM(seddia3d(jn)) + WRITE(numsed,*) 'long name ', TRIM(seddia3l(jn)) + WRITE(numsed,*) ' in unit = ',TRIM(seddia3u(jn)) + WRITE(numsed,*) ' ' + END DO + + DO jn = 1, jpdia2dsed + WRITE(numsed,*) 'name of 2D output diag number :',jn, ' : ', TRIM(seddia2d(jn)) + WRITE(numsed,*) 'long name ', TRIM(seddia2l(jn)) + WRITE(numsed,*) ' in unit = ',TRIM(seddia2u(jn)) + WRITE(numsed,*) ' ' + END DO + + WRITE(numsed,*) ' ' + ENDIF + + ! Inorganic chemistry parameters + !---------------------------------- + REWIND( numnamsed_ref ) ! Namelist nam_inorg in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_inorg, IOSTAT = ios, ERR = 909) +909 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_inorg in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_inorg in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_inorg, IOSTAT = ios, ERR = 910) +910 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_inorg in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_inorg' + WRITE(numsed,*) ' reactivity for Si rcopal = ', rcopal + WRITE(numsed,*) ' diff. coef for por. dcoef = ', dcoef + WRITE(numsed,*) ' reactivity for calcite rccal = ', rccal + WRITE(numsed,*) ' L/C ratio in POC ratligc = ', ratligc + WRITE(numsed,*) ' reactivity for ligands rcligc = ', rcligc + WRITE(numsed,*) ' ' + ENDIF + + ! Unity conversion to get saturation conc. psat in [mol.l-1] + ! and reactivity rc in [l.mol-1.s-1] + !---------------------------------------------------------- + reac_sil = rcopal / ryear + reac_ligc = rcligc / ryear + + ! Additional parameter linked to POC/O2/No3/Po4 + !---------------------------------------------- + REWIND( numnamsed_ref ) ! Namelist nam_poc in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_poc, IOSTAT = ios, ERR = 911) +911 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_poc in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_poc in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_poc, IOSTAT = ios, ERR = 912) +912 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_poc in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_poc' + WRITE(numsed,*) ' Redfield coef for oxy redO2 = ', redO2 + WRITE(numsed,*) ' Redfield coef for no3 redNo3 = ', redNo3 + WRITE(numsed,*) ' Redfield coef for po4 redPo4 = ', redPo4 + WRITE(numsed,*) ' Redfield coef for carbon redC = ', redC + WRITE(numsed,*) ' Ration for iron bound P redfep = ', redfep + WRITE(numsed,*) ' reactivity for labile POC rcorgl = ', rcorgl + WRITE(numsed,*) ' reactivity for semi-refract. POC rcorgs = ', rcorgs + WRITE(numsed,*) ' reactivity for refractory POC rcorgr = ', rcorgr + WRITE(numsed,*) ' reactivity for NH4 rcnh4 = ', rcnh4 + WRITE(numsed,*) ' reactivity for H2S rch2s = ', rch2s + WRITE(numsed,*) ' reactivity for Fe2+ rcfe2 = ', rcfe2 + WRITE(numsed,*) ' reactivity for FeOH/H2S rcfeh2s = ', rcfeh2s + WRITE(numsed,*) ' reactivity for Fe2+/H2S rcfes = ', rcfes + WRITE(numsed,*) ' reactivity for FeS/O2 rcfeso = ', rcfeso + WRITE(numsed,*) ' Half-sat. cste for oxic remin xksedo2 = ', xksedo2 + WRITE(numsed,*) ' Half-sat. cste for denit. xksedno3 = ', xksedno3 + WRITE(numsed,*) ' Half-sat. cste for iron remin xksedfeo = ', xksedfeo + WRITE(numsed,*) ' Half-sat. cste for SO4 remin xksedso4 = ', xksedso4 + WRITE(numsed,*) ' ' + ENDIF + + + so2ut = redO2 / redC + srno3 = redNo3 / redC + spo4r = redPo4 / redC + srDnit = ( (redO2 + 32. ) * 0.8 - redNo3 - redNo3 * 0.6 ) / redC + ! reactivity rc in [l.mol-1.s-1] + reac_pocl = rcorgl / ryear + reac_pocs = rcorgs / ryear + reac_pocr = rcorgr / ryear + reac_nh4 = rcnh4 / ryear + reac_h2s = rch2s / ryear + reac_fe2 = rcfe2 / ryear + reac_feh2s = rcfeh2s/ ryear + reac_fes = rcfes / ryear + reac_feso = rcfeso / ryear + + ! reactivity rc in [l.mol-1.s-1] + reac_cal = rccal / ryear + + ! Bioturbation parameter + !------------------------ + REWIND( numnamsed_ref ) ! Namelist nam_btb in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_btb, IOSTAT = ios, ERR = 913) +913 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_btb in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_btb in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_btb, IOSTAT = ios, ERR = 914) +914 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_btb in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_btb ' + WRITE(numsed,*) ' coefficient for bioturbation dbiot = ', dbiot + WRITE(numsed,*) ' Depth varying bioturbation ln_btbz = ', ln_btbz + WRITE(numsed,*) ' coefficient for btb attenuation dbtbzsc = ', dbtbzsc + WRITE(numsed,*) ' Adsorption coefficient of NH4 adsnh4 = ', adsnh4 + WRITE(numsed,*) ' Bioirrigation in sediment ln_irrig = ', ln_irrig + WRITE(numsed,*) ' coefficient for irrig attenuation xirrzsc = ', xirrzsc + WRITE(numsed,*) ' ' + ENDIF + + ! Initial value (t=0) for sediment pore water and solid components + !---------------------------------------------------------------- + REWIND( numnamsed_ref ) ! Namelist nam_rst in reference namelist : Pisces variables + READ ( numnamsed_ref, nam_rst, IOSTAT = ios, ERR = 915) +915 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_rst in reference namelist' ) + + REWIND( numnamsed_cfg ) ! Namelist nam_rst in reference namelist : Pisces variables + READ ( numnamsed_cfg, nam_rst, IOSTAT = ios, ERR = 916) +916 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_rst in configuration namelist' ) + + IF (lwp) THEN + WRITE(numsed,*) ' namelist nam_rst ' + WRITE(numsed,*) ' boolean term for restart (T or F) ln_rst_sed = ', ln_rst_sed + WRITE(numsed,*) ' ' + ENDIF + nn_dtsed = nn_dttrc + + CLOSE( numnamsed_cfg ) + CLOSE( numnamsed_ref ) + + END SUBROUTINE sed_init_nam + +END MODULE sedini diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinitrc.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinitrc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ea46fe1d52989e23461b45b4d43e82b7874bc5a9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinitrc.F90 @@ -0,0 +1,192 @@ +MODULE sedinitrc + !!====================================================================== + !! *** MODULE sedinitrc *** + !! Sediment : define sediment variables + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sed_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedini + USE seddta + USE sedrst + USE sedco3 + USE sedchem + USE sedarr + USE lib_mpp ! distribued memory computing library + + + IMPLICIT NONE + PRIVATE + + REAL(wp) :: & + ryear = 365. * 24. * 3600. !: 1 year converted in second + + !! * Routine accessibility + PUBLIC sed_initrc ! routine called by opa.F90 + + !! $Id: sedini.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + + + SUBROUTINE sed_initrc + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_init *** + !! + !! ** Purpose : Initialization of sediment module + !! - Reading namelist + !! - Read the deepest water layer thickness + !! ( using as mask ) in Netcdf file + !! - Convert unity if necessary + !! - sets initial sediment composition + !! ( only clay or reading restart file ) + !! - sets sediment grid, porosity and others constants + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) Original code + !! ! 06-07 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, ikt + !!---------------------------------------------------------------------- + + + ! Initialize the sediment tracers concentrations + !------------------------------------------------ + + IF(lwp) WRITE(numsed,*) ' sed_initrc : Initialization of sediment concentration ' + IF(lwp) WRITE(numsed,*) ' ' + + ! Determination of sediments number of points and allocate global variables + + ! sets initial sediment composition + ! ( only clay or reading restart file ) + !--------------------------------------- + CALL sed_init_data + + + CALL sed_init_wri + + + END SUBROUTINE sed_initrc + + + SUBROUTINE sed_init_data + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_init_data *** + !! + !! ** Purpose : Initialization of sediment module + !! - sets initial sediment composition + !! ( only clay or reading restart file ) + !! + !! History : + !! ! 06-07 (C. Ethe) original + !!---------------------------------------------------------------------- + + ! local variables + INTEGER :: & + ji, jk, zhipor + + !-------------------------------------------------------------------- + + + IF( .NOT. ln_rst_sed ) THEN + + IF (lwp) WRITE(numsed,*) ' Initilization of default values of sediment components' + + ! default values for initial pore water concentrations [mol/l] + pwcp(:,:,:) = 0. + ! default value for initial solid component (fraction of dry weight dim=[0]) + ! clay + solcp(:,:,:) = 0. + solcp(:,2:jpksed,jsclay) = 1.0 * 0.965 + solcp(:,2:jpksed,jsfeo) = 1.0 * 0.035 + + ! Initialization of [h+] and [co3--] + + zhipor = 8.0 + ! Initialization of [h+] in mol/kg + DO jk = 1, jpksed + DO ji = 1, jpoce + hipor (ji,jk) = 10.**( -1. * zhipor ) + ENDDO + ENDDO + + co3por(:,:) = 1E-6 + + ELSE + + IF (lwp) WRITE(numsed,*) ' Initilization of Sediment components from restart' + + CALL sed_rst_cal( nitsed000, 'READ' ) + CALL sed_rst_read + + ENDIF + + + ! Load initial Pisces Data for bot. wat. Chem and fluxes + CALL sed_dta ( nitsed000 ) + + ! Initialization of chemical constants + CALL sed_chem ( nitsed000 ) + + ! Stores initial sediment data for mass balance calculation + pwcp0 (1:jpoce,1:jpksed,1:jpwat ) = pwcp (1:jpoce,1:jpksed,1:jpwat ) + solcp0(1:jpoce,1:jpksed,1:jpsol ) = solcp(1:jpoce,1:jpksed,1:jpsol) + + ! Conversion of [h+] in mol/Kg to get it in mol/l ( multiplication by density) + DO jk = 1, jpksed + hipor(1:jpoce,jk) = hipor(1:jpoce,jk) * densSW(1:jpoce) + ENDDO + + + ! In default case - no restart - sedco3 is run to initiate [h+] and [co32-] + ! Otherwise initiate values of pH and co3 read in restart + IF( .NOT. ln_rst_sed ) THEN + ! sedco3 is run to initiate[h+] [co32-] in mol/l of solution + CALL sed_co3 ( nitsed000 ) + + ENDIF + + END SUBROUTINE sed_init_data + + SUBROUTINE sed_init_wri + + INTEGER :: jk + + IF (lwp) THEN + WRITE(numsed,*)' ' + WRITE(numsed,*)'======== Write summary of sediment char. ============' + WRITE(numsed,*)' ' + WRITE(numsed,*)' ' + WRITE(numsed,*)'-------------------------------------------------------------------' + WRITE(numsed,*)' Initial Conditions ' + WRITE(numsed,*)'-------------------------------------------------------------------' + WRITE(numsed,*)'dzm = dzkbot minimum to calculate ', 0. + WRITE(numsed,*)'Local zone : jpi, jpj, jpksed : ',jpi, jpj, jpksed + WRITE(numsed,*)'jpoce = ',jpoce,' nbtot pts = ',jpij,' nb earth pts = ',jpij - jpoce + WRITE(numsed,*)'sublayer thickness dz(1) [cm] : ', dz(1) + WRITE(numsed,*)'Vertical domain of the sediment' + WRITE(numsed,*)'-------------------------------' + WRITE(numsed,*)' Indice, profsed, dz' + DO jk = 2, jpksed + WRITE(numsed,*) jk,profsed(jk),dz(jk) + END DO + WRITE(numsed,*)' nb solid comp : ',jpsol + WRITE(numsed,*)'(1=opal,2=clay,3=POC,4=CaCO3), 5=POS, 6=POR, 7=FEO, 8=FeS' + WRITE(numsed,*)'weight mol 1,2,3,4,5,6,7' + WRITE(numsed,'(8(F0.2,3X))')mol_wgt(jsopal),mol_wgt(jsclay),mol_wgt(jspoc),mol_wgt(jscal),mol_wgt(jspos),mol_wgt(jspor),mol_wgt(jsfeo),mol_wgt(jsfes) + WRITE(numsed,*)'nb dissolved comp',jpwat + WRITE(numsed,*)'1=silicic acid,,2=O2,3=DIC,4=NO3,5=PO4,6=Alk,7=NH4,8=ODU' + WRITE(numsed,*)'redfield coef C,O,N P Dit ' + WRITE(numsed,'(5(F0.2,3X))')1./spo4r,so2ut/spo4r,srno3/spo4r,spo4r/spo4r,srDnit/spo4r + WRITE(numsed,*) ' ' + WRITE(numsed,*) ' End Of Initialization ' + WRITE(numsed,*) ' ' + ENDIF +! + END SUBROUTINE sed_init_wri + +END MODULE sedinitrc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinorg.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinorg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..83eca1c619c228ed0e83d180ba6250d46684e6c0 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedinorg.F90 @@ -0,0 +1,301 @@ +MODULE sedinorg + !!====================================================================== + !! *** MODULE sedinorg *** + !! Sediment : dissolution and reaction in pore water of + !! inorganic species + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedmat ! linear system of equations + USE sedco3 ! carbonate ion and proton concentration + USE sedini + USE seddsr + USE lib_mpp ! distribued memory computing library + USE lib_fortran + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_inorg + + !! $Id: seddsr.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + + SUBROUTINE sed_inorg( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_inorg *** + !! + !! ** Purpose : computes pore water dissolution and reaction + !! + !! ** Methode : implicit simultaneous computation of undersaturation + !! resulting from diffusive pore water transport and chemical + !! pore water reactions. Solid material is consumed according + !! to redissolution and remineralisation + !! + !! ** Remarks : + !! - undersaturation : deviation from saturation concentration + !! - reaction rate : sink of undersaturation from dissolution + !! of solid material + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) f90 + !! ! 06-04 (C. Ethe) Re-organization + !! ! 19-08 (O. Aumont) Debugging and improvement of the model + !!---------------------------------------------------------------------- + !! Arguments + INTEGER, INTENT(in) :: kt ! number of iteration + ! --- local variables + INTEGER :: ji, jk, js, jw ! dummy looop indices + REAL(wp), DIMENSION(jpoce,jpksed) :: zrearat1, zrearat2 ! reaction rate in pore water + REAL(wp), DIMENSION(jpoce,jpksed) :: zundsat ! undersaturation ; indice jpwatp1 is for calcite + REAL(wp), DIMENSION(jpoce) :: zco3eq + REAL(wp), DIMENSION(jpoce,jpksed,jpsol) :: zvolc ! temp. variables + REAL(wp), DIMENSION(jpoce) :: zsieq + REAL(wp) :: zsolid1, zvolw, zreasat + REAL(wp) :: zsatur, zsatur2, znusil, zsolcpcl, zsolcpsi + !! + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_inorg') +! + IF( kt == nitsed000 ) THEN + IF (lwp) THEN + WRITE(numsed,*) ' sed_inorg : Dissolution reaction ' + WRITE(numsed,*) ' ' + ENDIF +! ! + ENDIF + + ! Initializations + !---------------------- + + zrearat1(:,:) = 0. ; zundsat(:,:) = 0. + zrearat2(:,:) = 0. ; zrearat2(:,:) = 0. + zco3eq(:) = rtrn + zvolc(:,:,:) = 0. + + ! ----------------------------------------------- + ! Computation of Si solubility + ! Param of Ridgwell et al. 2002 + ! ----------------------------------------------- + + DO ji = 1, jpoce + zsolcpcl = 0.0 + zsolcpsi = 0.0 + DO jk = 1, jpksed + zsolcpsi = zsolcpsi + solcp(ji,jk,jsopal) * dz(jk) + zsolcpcl = zsolcpcl + solcp(ji,jk,jsclay) * dz(jk) + END DO + zsolcpsi = MAX( zsolcpsi, rtrn ) + zsieq(ji) = sieqs(ji) * MAX(0.25, 1.0 - (0.045 * zsolcpcl / zsolcpsi )**0.58 ) + zsieq(ji) = MAX( rtrn, sieqs(ji) ) + END DO + + DO js = 1, jpsol + DO jk = 1, jpksed + DO ji = 1, jpoce + zvolc(ji,jk,js) = ( vols3d(ji,jk) * dens_mol_wgt(js) ) / & + & ( volw3d(ji,jk) * 1.e-3 ) + ENDDO + ENDDO + ENDDO + + !---------------------------------------------------------- + ! 5. Beginning of Pore Water diffusion and solid reaction + !--------------------------------------------------------- + + !----------------------------------------------------------------------------- + ! For jk=2,jpksed, and for couple + ! 1 : jwsil/jsopal ( SI/Opal ) + ! 2 : jsclay/jsclay ( clay/clay ) + ! 3 : jwoxy/jspoc ( O2/POC ) + ! reaction rate is a function of solid=concentration in solid reactif in [mol/l] + ! and undersaturation in [mol/l]. + ! Solid weight fractions should be in ie [mol/l]) + ! second member and solution are in zundsat variable + !------------------------------------------------------------------------- + + DO jk = 1, jpksed + DO ji = 1, jpoce + ! For Silicic Acid and clay + zundsat(ji,jk) = zsieq(ji) - pwcp(ji,jk,jwsil) + ENDDO + ENDDO + + ! Definition of reaction rates [rearat]=sans dim + ! For jk=1 no reaction (pure water without solid) for each solid compo + DO ji = 1, jpoce + zrearat1(ji,:) = 0. + zrearat2(ji,:) = 0. + ENDDO + + ! left hand side of coefficient matrix + DO jk = 2, jpksed + DO ji = 1, jpoce + zsolid1 = zvolc(ji,jk,jsopal) * solcp(ji,jk,jsopal) + zsatur = MAX(0., zundsat(ji,jk) / zsieq(ji) ) + zsatur2 = (1.0 + temp(ji) / 400.0 )**37 + znusil = ( 0.225 * ( 1.0 + temp(ji) / 15.) + 0.775 * zsatur2 * zsatur**2.25 ) / zsieq(ji) + zrearat1(ji,jk) = ( reac_sil * znusil * dtsed * zsolid1 ) / & + & ( 1. + reac_sil * znusil * dtsed * zundsat(ji,jk) ) + ENDDO + ENDDO + + CALL sed_mat( jwsil, jpoce, jpksed, zrearat1, zrearat2, zundsat, dtsed ) + + ! New solid concentration values (jk=2 to jksed) for each couple + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zundsat(ji,jk) / ( zvolc(ji,jk,jsopal) ) + solcp(ji,jk,jsopal) = solcp(ji,jk,jsopal) - zreasat + ENDDO + ENDDO + + ! New pore water concentrations + DO jk = 1, jpksed + DO ji = 1, jpoce + ! Acid Silicic + pwcp(ji,jk,jwsil) = zsieq(ji) - zundsat(ji,jk) + ENDDO + ENDDO + + !--------------------------------------------------------------- + ! Performs CaCO3 particle deposition and redissolution (indice 9) + !-------------------------------------------------------------- + + ! computes co3por from the updated pwcp concentrations (note [co3por] = mol/l) + + CALL sed_co3( kt ) + + ! *densSW(l)**2 converts aksps [mol2/kg sol2] into [mol2/l2] to get [undsat] in [mol/l] + DO jk = 1, jpksed + DO ji = 1, jpoce + zco3eq(ji) = aksps(ji) * densSW(ji) * densSW(ji) / ( calcon2(ji) + rtrn ) + zco3eq(ji) = MAX( rtrn, zco3eq(ji) ) + zundsat(ji,jk) = MAX(0., zco3eq(ji) - co3por(ji,jk) ) + ENDDO + ENDDO + + DO jk = 2, jpksed + DO ji = 1, jpoce + zsolid1 = zvolc(ji,jk,jscal) * solcp(ji,jk,jscal) + zrearat1(ji,jk) = ( reac_cal * dtsed * zsolid1 / zco3eq(ji) ) / & + & ( 1. + reac_cal * dtsed * zundsat(ji,jk) / zco3eq(ji) ) + END DO + END DO + + ! solves tridiagonal system + CALL sed_mat( jwdic, jpoce, jpksed, zrearat1, zrearat2, zundsat, dtsed ) + + ! New solid concentration values (jk=2 to jksed) for cacO3 + DO jk = 2, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zundsat(ji,jk) / zvolc(ji,jk,jscal) + solcp(ji,jk,jscal) = solcp(ji,jk,jscal) - zreasat + ENDDO + ENDDO + + ! New dissolved concentrations + DO jk = 1, jpksed + DO ji = 1, jpoce + zreasat = zrearat1(ji,jk) * zundsat(ji,jk) + ! For DIC + pwcp(ji,jk,jwdic) = pwcp(ji,jk,jwdic) + zreasat + ! For alkalinity + pwcp(ji,jk,jwalk) = pwcp(ji,jk,jwalk) + 2.0 * zreasat + ENDDO + ENDDO + + !------------------------------------------------- + ! Beginning DIC, Alkalinity + !------------------------------------------------- + + DO jk = 1, jpksed + DO ji = 1, jpoce + zundsat(ji,jk) = pwcp(ji,jk,jwdic) + zrearat1(ji,jk) = 0. + ENDDO + ENDDO + + ! solves tridiagonal system + CALL sed_mat( jwdic, jpoce, jpksed, zrearat1, zrearat2, zundsat, dtsed ) + + ! New dissolved concentrations + DO jk = 1, jpksed + DO ji = 1, jpoce + pwcp(ji,jk,jwdic) = zundsat(ji,jk) + ENDDO + ENDDO + + !------------------------------------------------- + ! Beginning DIC, Alkalinity + !------------------------------------------------- + + DO jk = 1, jpksed + DO ji = 1, jpoce + zundsat(ji,jk) = pwcp(ji,jk,jwalk) + zrearat1(ji,jk) = 0. + ENDDO + ENDDO +! +! ! solves tridiagonal system + CALL sed_mat( jwalk, jpoce, jpksed, zrearat1, zrearat2, zundsat, dtsed ) +! +! ! New dissolved concentrations + DO jk = 1, jpksed + DO ji = 1, jpoce + pwcp(ji,jk,jwalk) = zundsat(ji,jk) + ENDDO + ENDDO + + !---------------------------------- + ! Back to initial geometry + !----------------------------- + + !--------------------------------------------------------------------- + ! 1/ Compensation for ajustement of the bottom water concentrations + ! (see note n 1 about *por(2)) + !-------------------------------------------------------------------- + DO jw = 1, jpwat + DO ji = 1, jpoce + pwcp(ji,1,jw) = pwcp(ji,1,jw) + & + & pwcp(ji,2,jw) * dzdep(ji) * por(2) / dzkbot(ji) + END DO + ENDDO + + !----------------------------------------------------------------------- + ! 2/ Det of new rainrg taking account of the new weight fraction obtained + ! in dz3d(2) after diffusion/reaction (react/diffu are also in dzdep!) + ! This new rain (rgntg rm) will be used in advection/burial routine + !------------------------------------------------------------------------ + DO js = 1, jpsol + DO ji = 1, jpoce + rainrg(ji,js) = raintg(ji) * solcp(ji,2,js) + rainrm(ji,js) = rainrg(ji,js) / mol_wgt(js) + END DO + ENDDO + + ! New raintg + raintg(:) = 0. + DO js = 1, jpsol + DO ji = 1, jpoce + raintg(ji) = raintg(ji) + rainrg(ji,js) + END DO + ENDDO + + !-------------------------------- + ! 3/ back to initial geometry + !-------------------------------- + DO ji = 1, jpoce + dz3d (ji,2) = dz(2) + volw3d(ji,2) = dz3d(ji,2) * por(2) + vols3d(ji,2) = dz3d(ji,2) * por1(2) + ENDDO + + IF( ln_timing ) CALL timing_stop('sed_inorg') +! + END SUBROUTINE sed_inorg + +END MODULE sedinorg diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmat.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmat.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9d41c8b7a56e7871440bcf3fa6a36bf36a86fbc8 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmat.F90 @@ -0,0 +1,265 @@ +MODULE sedmat + !!====================================================================== + !! *** MODULE sedmat *** + !! Sediment : linear system of equations + !!===================================================================== + !! * Modules used + !!---------------------------------------------------------------------- + + USE sed ! sediment global variable + USE lib_mpp ! distribued memory computing library + + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_mat + + INTERFACE sed_mat + MODULE PROCEDURE sed_mat_dsr, sed_mat_btb + END INTERFACE + + INTEGER, PARAMETER :: nmax = 30 + + + !! $Id: sedmat.F90 10222 2018-10-25 09:42:23Z aumont $ + CONTAINS + + SUBROUTINE sed_mat_dsr( nvar, ndim, nlev, preac, psms, psol, dtsed_in ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_mat_dsr *** + !! + !! ** Purpose : solves tridiagonal system of linear equations + !! + !! ** Method : + !! 1 - computes left hand side of linear system of equations + !! for dissolution reaction + !! For mass balance in kbot+sediment : + !! dz3d (:,1) = dz(1) = 0.5 cm + !! volw3d(:,1) = dzkbot ( see sedini.F90 ) + !! dz(2) = 0.3 cm + !! dz3d(:,2) = 0.3 + dzdep ( see seddsr.F90 ) + !! volw3d(:,2) and vols3d(l,2) are thickened ( see seddsr.F90 ) + !! + !! 2 - forward/backward substitution. + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) original + !! ! 06-04 (C. Ethe) Module Re-organization + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER , INTENT(in) :: nvar ! number of variable + INTEGER , INTENT(in) :: ndim ! number of points + INTEGER , INTENT(in) :: nlev ! number of sediment levels + + REAL(wp), DIMENSION(ndim,nlev), INTENT(in ) :: preac ! reaction rates + REAL(wp), DIMENSION(ndim,nlev), INTENT(in ) :: psms ! reaction rates + REAL(wp), DIMENSION(ndim,nlev), INTENT(inout) :: psol ! solution ( undersaturation values ) + REAL(wp), INTENT(in) :: dtsed_in + + !---Local declarations + INTEGER :: ji, jk, jn + REAL(wp), DIMENSION(ndim,nlev) :: za, zb, zc, zr + REAL(wp), DIMENSION(ndim) :: zbet + REAL(wp), DIMENSION(ndim,nmax) :: zgamm + + REAL(wp) :: aplus,aminus + REAL(wp) :: rplus,rminus + REAL(wp) :: dxplus,dxminus + + !---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_mat_dsr') + + ! Computation left hand side of linear system of + ! equations for dissolution reaction + !--------------------------------------------- + + + jn = nvar + ! first sediment level + DO ji = 1, ndim + aplus = ( ( volw3d(ji,1) / ( dz3d(ji,1) ) ) + & + ( volw3d(ji,2) / ( dz3d(ji,2) ) ) ) / 2. + dxplus = ( dz3d(ji,1) + dz3d(ji,2) ) / 2. + rplus = ( dtsed_in / ( volw3d(ji,1) ) ) * diff(ji,1,jn) * aplus / dxplus + + za(ji,1) = 0. + zb(ji,1) = 1. + rplus + zc(ji,1) = -rplus + ENDDO + + DO jk = 2, nlev - 1 + DO ji = 1, ndim + aminus = ( ( volw3d(ji,jk-1) / ( dz3d(ji,jk-1) ) ) + & + & ( volw3d(ji,jk ) / ( dz3d(ji,jk ) ) ) ) / 2. + dxminus = ( dz3d(ji,jk-1) + dz3d(ji,jk) ) / 2. + + aplus = ( ( volw3d(ji,jk ) / ( dz3d(ji,jk ) ) ) + & + & ( volw3d(ji,jk+1) / ( dz3d(ji,jk+1) ) ) ) / 2. + dxplus = ( dz3d(ji,jk) + dz3d(ji,jk+1) ) / 2 + ! + rminus = ( dtsed_in / volw3d(ji,jk) ) * diff(ji,jk-1,jn) * aminus / dxminus + rplus = ( dtsed_in / volw3d(ji,jk) ) * diff(ji,jk,jn) * aplus / dxplus + ! + za(ji,jk) = -rminus + zb(ji,jk) = 1. + rminus + rplus + zc(ji,jk) = -rplus + END DO + END DO + + DO ji = 1, ndim + aminus = ( ( volw3d(ji,nlev-1) / dz3d(ji,nlev-1) ) + & + & ( volw3d(ji,nlev) / dz3d(ji,nlev) ) ) / 2. + dxminus = ( dz3d(ji,nlev-1) + dz3d(ji,nlev) ) / 2. + rminus = ( dtsed_in / volw3d(ji,nlev) ) * diff(ji,nlev-1,jn) * aminus / dxminus + ! + za(ji,nlev) = -rminus + zb(ji,nlev) = 1. + rminus + zc(ji,nlev) = 0. + END DO + + + ! solves tridiagonal system of linear equations + ! ----------------------------------------------- + + zr (:,:) = psol(:,:) + psms(:,:) + zb (:,:) = zb(:,:) + preac(:,:) + zbet(: ) = zb(:,1) + psol(:,1) = zr(:,1) / zbet(:) + + ! + DO jk = 2, nlev + DO ji = 1, ndim + zgamm(ji,jk) = zc(ji,jk-1) / zbet(ji) + zbet(ji) = zb(ji,jk) - za(ji,jk) * zgamm(ji,jk) + psol(ji,jk) = ( zr(ji,jk) - za(ji,jk) * psol(ji,jk-1) ) / zbet(ji) + END DO + ENDDO + ! + DO jk = nlev - 1, 1, -1 + DO ji = 1,ndim + psol(ji,jk) = psol(ji,jk) - zgamm(ji,jk+1) * psol(ji,jk+1) + END DO + ENDDO + + IF( ln_timing ) CALL timing_stop('sed_mat_dsr') + + + END SUBROUTINE sed_mat_dsr + + SUBROUTINE sed_mat_btb( nvar, ndim, nlev, psol, dtsed_in ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_mat_btb *** + !! + !! ** Purpose : solves tridiagonal system of linear equations + !! + !! ** Method : + !! 1 - computes left hand side of linear system of equations + !! for dissolution reaction + !! + !! 2 - forward/backward substitution. + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) original + !! ! 06-04 (C. Ethe) Module Re-organization + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER , INTENT(in) :: & + nvar , & ! number of variables + ndim , & ! number of points + nlev ! number of sediment levels + + REAL(wp), DIMENSION(ndim,nlev,nvar), INTENT(inout) :: & + psol ! solution + + REAL(wp), INTENT(in) :: dtsed_in + + !---Local declarations + INTEGER :: & + ji, jk, jn + + REAL(wp) :: & + aplus,aminus , & + rplus,rminus , & + dxplus,dxminus + + REAL(wp), DIMENSION(nlev) :: za, zb, zc + REAL(wp), DIMENSION(ndim,nlev) :: zr + REAL(wp), DIMENSION(nmax) :: zgamm + REAL(wp) :: zbet + + + !---------------------------------------------------------------------- + + ! Computation left hand side of linear system of + ! equations for dissolution reaction + !--------------------------------------------- + + + IF( ln_timing ) CALL timing_start('sed_mat_btb') + + ! first sediment level + DO ji = 1, ndim + aplus = ( ( vols(2) / dz(2) ) + ( vols(3) / dz(3) ) ) / 2. + dxplus = ( dz(2) + dz(3) ) / 2. + rplus = ( dtsed_in / vols(2) ) * db(ji,2) * aplus / dxplus + + za(1) = 0. + zb(1) = 1. + rplus + zc(1) = -rplus + + + DO jk = 2, nlev - 1 + aminus = ( ( vols(jk) / dz(jk) ) + ( vols(jk+1) / dz(jk+1) ) ) / 2. + dxminus = ( dz(jk) + dz(jk+1) ) / 2. + rminus = ( dtsed_in / vols(jk+1) ) * db(ji,jk) * aminus / dxminus + ! + aplus = ( ( vols(jk+1) / dz(jk+1 ) ) + ( vols(jk+2) / dz(jk+2) ) ) / 2. + dxplus = ( dz(jk+1) + dz(jk+2) ) / 2. + rplus = ( dtsed_in / vols(jk+1) ) * db(ji,jk+1) * aplus / dxplus + ! + za(jk) = -rminus + zb(jk) = 1. + rminus + rplus + zc(jk) = -rplus + ENDDO + + aminus = ( ( vols(nlev) / dz(nlev) ) + ( vols(nlev+1) / dz(nlev+1) ) ) / 2. + dxminus = ( dz(nlev) + dz(nlev+1) ) / 2. + rminus = ( dtsed_in / vols(nlev+1) ) * db(ji,nlev) * aminus / dxminus + ! + za(nlev) = -rminus + zb(nlev) = 1. + rminus + zc(nlev) = 0. + + + ! solves tridiagonal system of linear equations + ! ----------------------------------------------- + DO jn = 1, nvar + + DO jk = 1, nlev + zr (ji,jk) = psol(ji,jk,jn) + END DO + zbet = zb(1) + psol(ji,1,jn) = zr(ji,1) / zbet + ! + DO jk = 2, nlev + zgamm(jk) = zc(jk-1) / zbet + zbet = zb(jk) - za(jk) * zgamm(jk) + psol(ji,jk,jn) = ( zr(ji,jk) - za(jk) * psol(ji,jk-1,jn) ) / zbet + ENDDO + ! + DO jk = nlev - 1, 1, -1 + psol(ji,jk,jn) = psol(ji,jk,jn) - zgamm(jk+1) * psol(ji,jk+1,jn) + ENDDO + + ENDDO + + END DO + ! + IF( ln_timing ) CALL timing_stop('sed_mat_btb') + + + END SUBROUTINE sed_mat_btb + + END MODULE sedmat diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmbc.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a1321a834e37cae69a2b49d601fac6f6e59c719e --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmbc.F90 @@ -0,0 +1,257 @@ +MODULE sedmbc + !!====================================================================== + !! *** MODULE sedmbc *** + !! Sediment : mass balance calculation + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sed_mbc : + !!---------------------------------------------------------------------- + !! * Modules used + USE sed ! sediment global variable + USE seddsr + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sed_mbc + + !! * Module variables + REAL(wp), DIMENSION(jpsol) :: rain_tot ! total input rain + REAL(wp), DIMENSION(jpsol) :: fromsed_tot ! tota input from sediment + REAL(wp), DIMENSION(jpsol) :: tosed_tot ! total output from sediment + REAL(wp), DIMENSION(jpsol) :: rloss_tot ! total rain loss + + REAL(wp), DIMENSION(jpwat) :: diss_in_tot ! total input in pore water + REAL(wp), DIMENSION(jpwat) :: diss_out_tot ! total output from pore water + + !! $Id: sedmbc.F90 10250 2018-10-29 13:19:44Z mathiot $ +CONTAINS + + + SUBROUTINE sed_mbc( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_mbc *** + !! + !! ** Purpose : computation of total tracer inventories for checking + !! mass conservation. + !! + !! + !! ** Method : tracer inventories of each reservoir are computed and added + !! subsequently. + !! + !! History : + !! ! 04-10 (N. Emprin, M. Gehlen ) Original code + !! ! 06-07 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + + !! Arguments + INTEGER, INTENT(in) :: kt ! time step + + !! local declarations + INTEGER :: ji,js, jw, jk + REAL(wp) :: zinit, zfinal + REAL(wp) :: zinput, zoutput + REAL(wp) :: zdsw, zvol + REAL, DIMENSION(jpsol) :: zsolcp_inv_i, zsolcp_inv_f + REAL, DIMENSION(jpwat) :: zpwcp_inv_i, zpwcp_inv_f + REAL(wp) :: zdelta_sil, zdelta_clay + REAL(wp) :: zdelta_co2, zdelta_fe + REAL(wp) :: zdelta_po4, zdelta_no3 + + !!---------------------------------------------------------------------- + ! Initilization + !--------------- + IF( ln_timing ) CALL timing_start('sed_mbc') +! + IF( kt == nitsed000 ) THEN + + DO js = 1, jpsol + rain_tot (js) = 0. + fromsed_tot(js) = 0. + tosed_tot (js) = 0. + rloss_tot (js) = 0. + ENDDO + + DO jw = 1, jpwat + diss_in_tot (jw) = 0. + diss_out_tot(jw) = 0. + ENDDO + + ENDIF + + + ! Calculation of the cumulativ input and output + ! for mass balance check + !---------------------------------------------- + + ! cumulativ solid + DO js = 1, jpsol + DO ji = 1, jpoce + ! input [mol] + rain_tot (js) = rain_tot (js) + dtsed * rainrm_dta(ji,js) + fromsed_tot(js) = fromsed_tot(js) + fromsed(ji,js) / mol_wgt(js) + ! output [mol] + tosed_tot (js) = tosed_tot (js) + tosed(ji,js) / mol_wgt(js) + rloss_tot (js) = rloss_tot (js) + rloss(ji,js) / mol_wgt(js) + ENDDO + ENDDO + + ! cumulativ dissolved + DO jw = 1, jpwat + DO ji = 1, jpoce + ! input [mol] + diss_in_tot (jw) = diss_in_tot (jw) + pwcp_dta(ji,jw) * 1.e-3 * dzkbot(ji) + ! output [mol] + diss_out_tot(jw) = diss_out_tot(jw) + tokbot(ji,jw) + ENDDO + ENDDO + + ! Mass balance check + !--------------------- + IF( kt == nitsedend ) THEN + ! initial and final inventories for solid component (mole/dx.dy) in sediment + zsolcp_inv_i(:) = 0. + zsolcp_inv_f(:) = 0. + zpwcp_inv_i (:) = 0. + zpwcp_inv_f (:) = 0. + DO js = 1, jpsol + zdsw = denssol / mol_wgt(js) + DO jk = 2, jpksed + DO ji = 1, jpoce + zvol = vols3d(ji,jk) * zdsw + zsolcp_inv_i(js) = zsolcp_inv_i(js) + solcp0(ji,jk,js) * zvol + zsolcp_inv_f(js) = zsolcp_inv_f(js) + solcp (ji,jk,js) * zvol + ENDDO + END DO + ENDDO + + ! initial and final inventories for dissolved component (mole/dx.dy) in sediment + DO jw = 1, jpwat + DO jk = 2, jpksed + DO ji = 1, jpoce + zvol = volw3d(ji,jk) * 1.e-3 + zpwcp_inv_i(jw) = zpwcp_inv_i(jw) + pwcp0(ji,jk,jw) * zvol + zpwcp_inv_f(jw) = zpwcp_inv_f(jw) + pwcp (ji,jk,jw) * zvol + ENDDO + END DO + ENDDO + + ! mass balance for Silica/opal + zinit = zsolcp_inv_i(jsopal) + zpwcp_inv_i(jwsil) + zfinal = zsolcp_inv_f(jsopal) + zpwcp_inv_f(jwsil) + zinput = rain_tot (jsopal) + diss_in_tot (jwsil) + zoutput = tosed_tot (jsopal) + rloss_tot (jsopal) + diss_out_tot(jwsil) + zdelta_sil = ( zfinal + zoutput ) - ( zinit + zinput ) + + + ! mass balance for Clay + zinit = zsolcp_inv_i(jsclay) + zfinal = zsolcp_inv_f(jsclay) + zinput = rain_tot (jsclay) + fromsed_tot(jsclay) + zoutput = tosed_tot (jsclay) + rloss_tot (jsclay) + zdelta_clay= ( zfinal + zoutput ) - ( zinit + zinput ) + + ! mass balance for carbon ( carbon in POC, CaCo3, DIC ) + zinit = zsolcp_inv_i(jspoc) + zsolcp_inv_i(jspos) + zsolcp_inv_i(jspor) & + & + zsolcp_inv_i(jscal) + zpwcp_inv_i(jwdic) + zfinal = zsolcp_inv_f(jspoc) + zsolcp_inv_f(jspos) + zsolcp_inv_f(jspor) & + & + zsolcp_inv_f(jscal) + zpwcp_inv_f(jwdic) + zinput = rain_tot (jspoc) + rain_tot (jspos) + rain_tot (jspor) & + & + rain_tot (jscal) + diss_in_tot(jwdic) + zoutput = tosed_tot(jspoc) + tosed_tot(jspos) + tosed_tot(jspor) + tosed_tot(jscal) + diss_out_tot(jwdic) & + & + rloss_tot(jspoc) + rloss_tot(jspos) + rloss_tot(jspor) + rloss_tot(jscal) + zdelta_co2 = ( zfinal + zoutput ) - ( zinit + zinput ) + + ! mass balance for Sulfur + zinit = zpwcp_inv_i(jwso4) + zpwcp_inv_i(jwh2s) & + & + zsolcp_inv_i(jsfes) + zfinal = zpwcp_inv_f(jwso4) + zpwcp_inv_f(jwh2s) & + & + zsolcp_inv_f(jsfes) + zinput = diss_in_tot (jwso4) + diss_in_tot (jwh2s) & + & + rain_tot (jsfes) + zoutput = diss_out_tot(jwso4) + diss_out_tot(jwh2s) & + & + tosed_tot(jsfes) + rloss_tot(jsfes) + zdelta_no3 = ( zfinal + zoutput ) - ( zinit + zinput ) + + ! mass balance for iron + zinit = zpwcp_inv_i(jwfe2) + zsolcp_inv_i(jsfeo) & + & + zsolcp_inv_i(jsfes) + zfinal = zpwcp_inv_f(jwfe2) + zsolcp_inv_f(jsfeo) & + & + zsolcp_inv_f(jsfes) + zinput = diss_in_tot (jwfe2) + rain_tot (jsfeo) & + & + rain_tot (jsfes) + zoutput = diss_out_tot(jwfe2) + tosed_tot(jsfeo) & + & + tosed_tot(jsfes) + rloss_tot(jsfes) + rloss_tot(jsfeo) + zdelta_fe = ( zfinal + zoutput ) - ( zinit + zinput ) + + + END IF + + IF( kt == nitsedend) THEN + + IF (lwp) THEN + WRITE(numsed,*) + WRITE(numsed,*)'================== General mass balance ================== ' + WRITE(numsed,*)' ' + WRITE(numsed,*)' ' + WRITE(numsed,*)' Initial total solid Masses (mole/dx.dy) ' + WRITE(numsed,*)' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numsed,*)' Opal, Clay, POC, POS, POR, CaCO3, FeOH, FeS' + WRITE(numsed,'(8x,4(1PE10.3,2X))')zsolcp_inv_i(jsopal),zsolcp_inv_i(jsclay),zsolcp_inv_i(jspoc), & + & zsolcp_inv_i(jspos),zsolcp_inv_i(jspor),zsolcp_inv_i(jscal),zsolcp_inv_i(jsfeo),zsolcp_inv_i(jsfes) + WRITE(numsed,*)' ' + WRITE(numsed,*)' Initial total dissolved Masses (mole/dx.dy) ' + WRITE(numsed,*)' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + WRITE(numsed,*)' Si, O2, DIC, Nit, Phos, Fe2+' + WRITE(numsed,'(5x,5(1PE10.3,2X))') zpwcp_inv_i(jwsil), zpwcp_inv_i(jwoxy), & + & zpwcp_inv_i(jwdic), zpwcp_inv_i(jwno3), zpwcp_inv_i(jwpo4), zpwcp_inv_i(jwfe2) + WRITE(numsed,*)' ' + WRITE(numsed,*)' Solid inputs : Opale, Clay, POC, CaCO3, Fe' + WRITE(numsed,'(A4,10X,5(1PE10.3,2X))')'Rain : ',rain_tot(jsopal),rain_tot(jsclay),rain_tot(jspoc) + rain_tot(jspos) + rain_tot(jspor),& + & rain_tot(jscal), rain_tot(jsfeo) + WRITE(numsed,'(A12,6x,5(1PE10.3,2X))')' From Sed : ',fromsed_tot(jsopal), fromsed_tot(jsclay), & + & fromsed_tot(jspoc)+fromsed_tot(jspos)+fromsed_tot(jspor), fromsed_tot(jscal), & + & fromsed_tot(jsfeo) + fromsed_tot(jsfes) + WRITE(numsed,*)'Diss. inputs : Si, O2, DIC, Nit, Phos, Fe' + WRITE(numsed,'(A9,1x,6(1PE10.3,2X))')' From Pisc : ', diss_in_tot(jwsil), & + & diss_in_tot(jwoxy), diss_in_tot(jwdic), diss_in_tot(jwno3), diss_in_tot(jwpo4), diss_in_tot(jwfe2) + WRITE(numsed,*)' ' + WRITE(numsed,*)'Solid output : Opale, Clay, POC, CaCO3, Fe' + WRITE(numsed,'(A6,8x,5(1PE10.3,2X))')'To sed', tosed_tot(jsopal),tosed_tot(jsclay),tosed_tot(jspoc) & + & +tosed_tot(jspos)+tosed_tot(jspor),tosed_tot(jscal), tosed_tot(jsfeo)+tosed_tot(jsfes) + WRITE(numsed,'(A5,9x,5(1PE10.3,2X))')'Perdu', rloss_tot(jsopal),rloss_tot(jsclay),rloss_tot(jspoc) & + & +rloss_tot(jspos)+rloss_tot(jspor),rloss_tot(jscal),rloss_tot(jsfeo)+rloss_tot(jsfes) + WRITE(numsed,*)'Diss. output : Si, O2, DIC, Nit, Phos, Fe ' + WRITE(numsed,'(A7,2x,6(1PE10.3,2X))')'To kbot', diss_out_tot(jwsil), & + & diss_out_tot(jwoxy), diss_out_tot(jwdic), diss_out_tot(jwno3), diss_out_tot(jwpo4), diss_out_tot(jwfe2) + WRITE(numsed,*)' ' + WRITE(numsed,*)'Final solid Masses (mole/dx.dy) ' + WRITE(numsed,*)' Opale, Clay, POC, CaCO3, Fe' + WRITE(numsed,'(4x,5(1PE10.3,2X))')zsolcp_inv_f(jsopal),zsolcp_inv_f(jsclay),zsolcp_inv_f(jspoc) & + & +zsolcp_inv_f(jspos)+zsolcp_inv_f(jspor),zsolcp_inv_f(jscal),zsolcp_inv_f(jsfeo)+zsolcp_inv_f(jsfes) + WRITE(numsed,*)' ' + WRITE(numsed,*)'Final dissolved Masses (mole/dx.dy) (k=2-11)' + WRITE(numsed,*)' Si, O2, DIC, Nit, Phos, Fe' + WRITE(numsed,'(4x,6(1PE10.3,2X))') zpwcp_inv_f(jwsil), zpwcp_inv_f(jwoxy), & + & zpwcp_inv_f(jwdic), zpwcp_inv_f(jwno3), zpwcp_inv_f(jwpo4), zpwcp_inv_f(jwfe2) + WRITE(numsed,*)' ' + WRITE(numsed,*)'Delta : Opale, Clay, C, Fe, S,' + WRITE(numsed,'(7x,6(1PE11.3,1X))') zdelta_sil / ( zsolcp_inv_i(jsopal) + zpwcp_inv_i(jwsil) ) , & + & zdelta_clay / ( zsolcp_inv_i(jsclay) ) , & + & zdelta_co2 / ( zsolcp_inv_i(jspoc) + zsolcp_inv_i(jspos) + zsolcp_inv_i(jspor) & + & + zsolcp_inv_i(jscal) + zpwcp_inv_i(jwdic) ), & + & zdelta_fe / ( zpwcp_inv_i(jwfe2) + zsolcp_inv_i(jsfeo) + zsolcp_inv_i(jsfes) ) , & + & zdelta_no3 / ( zpwcp_inv_i(jwso4) + zpwcp_inv_i(jwh2s) + zsolcp_inv_i(jsfes) ) + WRITE(numsed,*)'==========================================================================' + + ENDIF + ENDIF + + IF( ln_timing ) CALL timing_stop('sed_mbc') + + END SUBROUTINE sed_mbc + +END MODULE sedmbc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmodel.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmodel.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dd006e6acabfd22f6c983c66596b91662e0fe294 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedmodel.F90 @@ -0,0 +1,43 @@ +MODULE sedmodel + !!====================================================================== + !! *** MODULE sedmodel *** + !! Sediment model : Main routine of sediment model + !!====================================================================== + USE sed + USE sedstp ! time stepping + USE sedinitrc + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sed_model ! called by step.F90 + +CONTAINS + + SUBROUTINE sed_model ( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_model *** + !! + !! ** Purpose : main routine of sediment model + !! + !! + !! ** Method : - model general initialization + !! - launch the time-stepping (stp routine) + !! + !! History : + !! ! 07-02 (C. Ethe) Original + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + + + IF( ln_timing ) CALL timing_start('sed_model') + + IF( kt == nittrc000 ) CALL sed_initrc ! Initialization of sediment model + CALL sed_stp( kt ) ! Time stepping of Sediment model + + IF( ln_timing ) CALL timing_stop('sed_model') + + END SUBROUTINE sed_model + +END MODULE sedmodel diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedorg.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedorg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c32c980ae13f4c0ba36a72cc450cc4f02dc93ee6 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedorg.F90 @@ -0,0 +1,159 @@ +MODULE sedorg + !!====================================================================== + !! *** MODULE seddsr *** + !! Sediment : dissolution and reaction in pore water related + !! related to organic matter + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sed_oce + USE sedini + USE seddiff + USE seddsr + USE lib_mpp ! distribued memory computing library + USE lib_fortran + + IMPLICIT NONE + PRIVATE + + PUBLIC sed_org + + !! * Module variables + + REAL(wp) :: zadsnh4 + + !! $Id: seddsr.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + + SUBROUTINE sed_org( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_org *** + !! + !! ** Purpose : computes pore water diffusion and reaction + !! + !! ** Methode : Computation of the redox reactions in sediment. + !! The main redox reactions are solved in sed_dsr whereas + !! the secondary reactions are solved in sed_dsr_redoxb. + !! A strand spliting approach is being used here (see + !! sed_dsr_redoxb for more information). + !! Diffusive fluxes are computed in sed_diff + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) f90 + !! ! 06-04 (C. Ethe) Re-organization + !! ! 19-08 (O. Aumont) Debugging and improvement of the model. + !! The original method is replaced by a + !! Strand splitting method which deals + !! well with stiff reactions. + !!---------------------------------------------------------------------- + !! Arguments + INTEGER, INTENT(in) :: kt + ! --- local variables + INTEGER :: ji, jk, js, jw, jnt ! dummy looop indices + REAL(wp) :: zadsnh4 + !! + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_org') +! + IF( kt == nitsed000 ) THEN + IF (lwp) THEN + WRITE(numsed,*) ' sed_org : Organic degradation related reactions and diffusion' + WRITE(numsed,*) ' ' + ENDIF +! ! + dens_mol_wgt(1:jpsol) = denssol / mol_wgt(1:jpsol) + ! + ENDIF + + dtsed2 = dtsed / REAL( nrseddt, wp ) + + ! 1. Change of geometry + ! Increase of dz3d(2) thickness : dz3d(2) = dz3d(2)+dzdep + ! Warning : no change for dz(2) + !--------------------------------------------------------- + dz3d(1:jpoce,2) = dz3d(1:jpoce,2) + dzdep(1:jpoce) + + ! New values for volw3d(:,2) and vols3d(:,2) + ! Warning : no change neither for volw(2) nor vols(2) + !------------------------------------------------------ + volw3d(1:jpoce,2) = dz3d(1:jpoce,2) * por(2) + vols3d(1:jpoce,2) = dz3d(1:jpoce,2) * por1(2) + + ! 2. Change of previous solid fractions (due to volum changes) for k=2 + !--------------------------------------------------------------------- + + DO js = 1, jpsol + DO ji = 1, jpoce + solcp(ji,2,js) = solcp(ji,2,js) * dz(2) / dz3d(ji,2) + ENDDO + END DO + + ! 3. New solid fractions (including solid rain fractions) for k=2 + !------------------------------------------------------------------ + DO js = 1, jpsol + DO ji = 1, jpoce + IF (raintg(ji) .ne. 0) THEN + solcp(ji,2,js) = solcp(ji,2,js) + & + & ( rainrg(ji,js) / raintg(ji) ) * ( dzdep(ji) / dz3d(ji,2) ) + ! rainrm are temporary cancel + rainrm(ji,js) = 0. + ENDIF + END DO + ENDDO + + ! 4. Adjustment of bottom water concen.(pwcp(1)): + ! We impose that pwcp(2) is constant. Including dzdep in dz3d(:,2) we assume + ! that dzdep has got a porosity of por(2). So pore water volum of jk=2 increase. + ! To keep pwcp(2) cste we must compensate this "increase" by a slight adjusment + ! of bottom water concentration. + ! This adjustment is compensate at the end of routine + !------------------------------------------------------------- + DO jw = 1, jpwat + DO ji = 1, jpoce + pwcp(ji,1,jw) = pwcp(ji,1,jw) - & + & pwcp(ji,2,jw) * dzdep(ji) * por(2) / ( dzkbot(ji) + rtrn ) + END DO + ENDDO + + zadsnh4 = 1.0 / ( 1.0 + adsnh4 ) + + ! -------------------------------------------------- + ! Computation of the diffusivities + ! -------------------------------------------------- + + DO js = 1, jpwat + DO jk = 1, jpksed + DO ji = 1, jpoce + diff(ji,jk,js) = ( diff1(js) + diff2(js) * temp(ji) ) / ( 1.0 - 2.0 * log( por(jk) ) ) + END DO + END DO + END DO + + ! Impact of bioirrigation and adsorption on diffusion + ! --------------------------------------------------- + + diff(:,:,jwnh4) = diff(:,:,jwnh4) * ( 1.0 + irrig(:,:) ) * zadsnh4 + diff(:,:,jwsil) = diff(:,:,jwsil) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwoxy) = diff(:,:,jwoxy) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwdic) = diff(:,:,jwdic) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwno3) = diff(:,:,jwno3) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwpo4) = diff(:,:,jwpo4) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwalk) = diff(:,:,jwalk) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwh2s) = diff(:,:,jwh2s) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwso4) = diff(:,:,jwso4) * ( 1.0 + irrig(:,:) ) + diff(:,:,jwfe2) = diff(:,:,jwfe2) * ( 1.0 + 0.2 * irrig(:,:) ) + + DO jnt = 1, nrseddt + CALL sed_diff( kt, jnt ) ! 1st pass in diffusion to get values at t+1/2 + CALL sed_dsr ( kt, jnt ) ! Dissolution reaction + CALL sed_diff( kt, jnt ) ! 2nd pass in diffusion to get values at t+1 + END DO + + + IF( ln_timing ) CALL timing_stop('sed_org') +! + END SUBROUTINE sed_org + +END MODULE sedorg diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedrst.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedrst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..61b5dcf643daa40ecf83d531379f8a7766e56a63 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedrst.F90 @@ -0,0 +1,413 @@ +MODULE sedrst + !!====================================================================== + !! *** MODULE sedrst *** + !! Read and write the restart files for sediment + !!====================================================================== + + !!---------------------------------------------------------------------- + !! * Modules used + !! ============== + USE sed + USE sedarr + USE trc_oce, ONLY : l_offline, nn_dttrc + USE phycst , ONLY : rday + USE iom + USE daymod + USE lib_mpp ! distribued memory computing library + + + !! * Accessibility + IMPLICIT NONE + PRIVATE + + !! * Accessibility + PUBLIC sed_rst_opn ! called by ??? + PUBLIC sed_rst_read + PUBLIC sed_rst_wri + PUBLIC sed_rst_cal + + !! $Id: sedrst.F90 11536 2019-09-11 13:54:18Z smasson $ +CONTAINS + + + SUBROUTINE sed_rst_opn( kt ) + !!---------------------------------------------------------------------- + !! *** sed_rst_opn *** + !! + !! ** purpose : output of sed-trc variable in a netcdf file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + ! + CHARACTER(LEN=20) :: clkt ! ocean time-step define as a character + CHARACTER(LEN=50) :: clname ! trc output restart file name + CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file + !!---------------------------------------------------------------------- + ! + IF( l_offline ) THEN + IF( kt == nittrc000 ) THEN + lrst_sed = .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. MOD( kt - 1, nn_stock ) == 0 ) THEN + ! we use kt - 1 and not kt - nittrc000 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 + ELSE + IF( kt == nittrc000 ) lrst_sed = .FALSE. + ENDIF + + 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 tracer restart file one tracer time step before writing the data (-> at nitrst - 2*nn_dttrc + 1) + ! except if we write tracer restart files every tracer time step or if a tracer restart file was writen at nitend - 2*nn_dttrc + 1 + IF( kt == nitrst - 2*nn_dtsed .OR. nn_stock == nn_dtsed .OR. ( kt == nitend - nn_dtsed .AND. .NOT. lrst_sed ) ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough) + IF( nitrst > 1.0e9 ) THEN ; WRITE(clkt,* ) nitrst + ELSE ; WRITE(clkt,'(i8.8)') nitrst + ENDIF + ! create the file + IF(lwp) WRITE(numsed,*) + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_sedrst_out) + clpath = TRIM(cn_sedrst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) WRITE(numsed,*) & + ' open sed restart.output NetCDF file: ',TRIM(clpath)//clname + CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed ) + lrst_sed = .TRUE. + ENDIF + ! + END SUBROUTINE sed_rst_opn + + SUBROUTINE sed_rst_read + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_rst_read *** + !! + !! ** Purpose : Initialization of sediment module + !! - sets initial sediment composition + !! ( only clay or reading restart file ) + !! + !! History : + !! ! 06-07 (C. Ethe) original + !!---------------------------------------------------------------------- + + !! * local declarations + INTEGER :: ji, jj, jk, jn + REAL(wp), DIMENSION(jpi,jpj,jpksed,jptrased) :: zdta + REAL(wp), DIMENSION(jpi,jpj,jpksed,2) :: zdta1 + REAL(wp), DIMENSION(jpi,jpj,jpksed) :: zdta2 + REAL(wp), DIMENSION(jpoce,jpksed) :: zhipor + REAL(wp) :: zkt + CHARACTER(len = 20) :: cltra + CHARACTER(LEN=20) :: name1 + LOGICAL :: llok + !-------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_rst_read') + + IF (lwp) WRITE(numsed,*) ' ' + IF (lwp) WRITE(numsed,*) ' Initilization of Sediment components from restart' + IF (lwp) WRITE(numsed,*) ' ' + + zdta = 1. + zdta1 = 1. + zdta2 = 0. + + DO jn = 1, jptrased + cltra = TRIM(sedtrcd(jn)) + IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta(:,:,:,jn) ) + ELSE + zdta(:,:,:,jn) = 0.0 + ENDIF + ENDDO + + DO jn = 1, jpsol + CALL pack_arr( jpoce, solcp(1:jpoce,1:jpksed,jn), & + & zdta(1:jpi,1:jpj,1:jpksed,jn), iarroce(1:jpoce) ) + END DO + + DO jn = 1, jpwat + CALL pack_arr( jpoce, pwcp(1:jpoce,1:jpksed,jn), & + & zdta(1:jpi,1:jpj,1:jpksed,jpsol+jn), iarroce(1:jpoce) ) + END DO + + DO jn = 1, 2 + cltra = TRIM(seddia3d(jn)) + IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta1(:,:,:,jn) ) + ELSE + zdta1(:,:,:,jn) = 0.0 + ENDIF + ENDDO + + zhipor(:,:) = 0. + CALL pack_arr( jpoce, zhipor(1:jpoce,1:jpksed), & + & zdta1(1:jpi,1:jpj,1:jpksed,1), iarroce(1:jpoce) ) + + ! Initialization of [h+] in mol/kg + DO jk = 1, jpksed + DO ji = 1, jpoce + hipor (ji,jk) = 10.**( -1. * zhipor(ji,jk) ) + ENDDO + ENDDO + + CALL pack_arr( jpoce, co3por(1:jpoce,1:jpksed), & + & zdta1(1:jpi,1:jpj,1:jpksed,2), iarroce(1:jpoce) ) + + ! Initialization of sediment composant only ie jk=2 to jk=jpksed + ! ( nothing in jk=1) + solcp(1:jpoce,1,:) = 0. + pwcp (1:jpoce,1,:) = 0. + + cltra = "dbioturb" + IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) ) + ELSE + zdta2(:,:,:) = 0.0 + ENDIF + + CALL pack_arr( jpoce, db(1:jpoce,1:jpksed), & + & zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) + + cltra = "irrig" + IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) ) + ELSE + zdta2(:,:,:) = 0.0 + ENDIF + + CALL pack_arr( jpoce, irrig(1:jpoce,1:jpksed), & + & zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) + + cltra = "sedligand" + IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) ) + ELSE + zdta2(:,:,:) = 0.0 + ENDIF + + CALL pack_arr( jpoce, sedligand(1:jpoce,1:jpksed), & + & zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) + + IF( ln_timing ) CALL timing_stop('sed_rst_read') + + END SUBROUTINE sed_rst_read + + SUBROUTINE sed_rst_wri( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_rst_wri *** + !! + !! ** Purpose : save field which are necessary for sediment restart + !! + !! History : + !! ! 06-07 (C. Ethe) original + !!---------------------------------------------------------------------- + !!* Modules used + INTEGER, INTENT(in) :: kt ! number of iteration + !! * local declarations + INTEGER :: ji, jj, jk, jn + REAL(wp), DIMENSION(1) :: zinfo + CHARACTER(len=50) :: clname + CHARACTER(len=20) :: cltra, name1 + REAL(wp), DIMENSION(jpoce,jpksed) :: zdta + REAL(wp), DIMENSION(jpi,jpj,jpksed) :: zdta2 + !! ----------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('sed_rst_wri') + + !! 0. initialisations + !! ------------------ + + IF(lwp) WRITE(numsed,*) ' ' + IF(lwp) WRITE(numsed,*) 'sed_rst_write : write the sediment restart file in NetCDF format ', & + 'at it= ',kt + IF(lwp) WRITE(numsed,*) '~~~~~~~~~' + + + trcsedi(:,:,:,:) = 0.0 + flxsedi3d(:,:,:,:) = 0.0 + zdta(:,:) = 1.0 + zdta2(:,:,:) = 0.0 + + + !! 1. WRITE in nutwrs + !! ------------------ + + zinfo(1) = REAL( kt) + CALL iom_rstput( kt, nitrst, numrsw, 'kt', zinfo ) + + ! Back to 2D geometry + DO jn = 1, jpsol + CALL unpack_arr( jpoce, trcsedi(1:jpi,1:jpj,1:jpksed,jn) , iarroce(1:jpoce), & + & solcp(1:jpoce,1:jpksed,jn ) ) + END DO + + DO jn = 1, jpwat + CALL unpack_arr( jpoce, trcsedi(1:jpi,1:jpj,1:jpksed,jpsol+jn) , iarroce(1:jpoce), & + & pwcp(1:jpoce,1:jpksed,jn ) ) + END DO + ! pH + DO jk = 1, jpksed + DO ji = 1, jpoce + zdta(ji,jk) = -LOG10( hipor(ji,jk) / ( densSW(ji) + rtrn ) + rtrn ) + ENDDO + ENDDO + + CALL unpack_arr( jpoce, flxsedi3d(1:jpi,1:jpj,1:jpksed,1) , iarroce(1:jpoce), & + & zdta(1:jpoce,1:jpksed) ) + + CALL unpack_arr( jpoce, flxsedi3d(1:jpi,1:jpj,1:jpksed,2) , iarroce(1:jpoce), & + & co3por(1:jpoce,1:jpksed) ) + + ! prognostic variables + ! -------------------- + + DO jn = 1, jptrased + cltra = TRIM(sedtrcd(jn)) + CALL iom_rstput( kt, nitrst, numrsw, TRIM(cltra), trcsedi(:,:,:,jn) ) + ENDDO + + DO jn = 1, 2 + cltra = TRIM(seddia3d(jn)) + CALL iom_rstput( kt, nitrst, numrsw, TRIM(cltra), flxsedi3d(:,:,:,jn) ) + ENDDO + + CALL unpack_arr( jpoce, zdta2(1:jpi,1:jpj,1:jpksed) , iarroce(1:jpoce), & + & db(1:jpoce,1:jpksed) ) + + cltra = "dbioturb" + CALL iom_rstput( kt, nitrst, numrsw, TRIM(cltra), zdta2(:,:,:) ) + + CALL unpack_arr( jpoce, zdta2(1:jpi,1:jpj,1:jpksed) , iarroce(1:jpoce), & + & irrig(1:jpoce,1:jpksed) ) + + cltra = "irrig" + CALL iom_rstput( kt, nitrst, numrsw, TRIM(cltra), zdta2(:,:,:) ) + + CALL unpack_arr( jpoce, zdta2(1:jpi,1:jpj,1:jpksed) , iarroce(1:jpoce), & + & sedligand(1:jpoce,1:jpksed) ) + + cltra = "sedligand" + CALL iom_rstput( kt, nitrst, numrsw, TRIM(cltra), zdta2(:,:,:) ) + + IF( kt == nitrst ) THEN + CALL iom_close( numrsw ) ! close the restart file (only at last time step) + IF( l_offline .AND. ln_rst_list ) THEN + nrst_lst = nrst_lst + 1 + nitrst = nn_stocklist( nrst_lst ) + ENDIF + ENDIF + + IF( ln_timing ) CALL timing_stop('sed_rst_wri') + + END SUBROUTINE sed_rst_wri + + + SUBROUTINE sed_rst_cal( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_rst_cal *** + !! + !! ** 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, + !! nn_rsttr = 0 no control on the date (nittrc000 is arbitrary). + !! nn_rsttr = 1 we verify that nittrc000 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 (nittrc000-1)*rdt. + !! This is valid is the time step has remained constant. + !! + !! nn_rsttr = 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 + ! + LOGICAL :: llok + REAL(wp) :: zkt, zrdttrc1 + REAL(wp) :: zndastp + + ! Time domain : restart + ! --------------------- + + IF( TRIM(cdrw) == 'READ' ) THEN + + IF(lwp) WRITE(numsed,*) + IF(lwp) WRITE(numsed,*) 'sed_rst_cal : read the SED restart file for calendar' + IF(lwp) WRITE(numsed,*) '~~~~~~~~~~~~' + + IF( ln_rst_sed ) THEN + CALL iom_open( TRIM(cn_sedrst_indir)//'/'//cn_sedrst_in, numrsr ) + CALL iom_get ( numrsr, 'kt', zkt ) ! last time-step of previous run + + IF(lwp) THEN + WRITE(numsed,*) ' *** Info read in restart : ' + WRITE(numsed,*) ' previous time-step : ', NINT( zkt ) + WRITE(numsed,*) ' *** restart option' + SELECT CASE ( nn_rstsed ) + CASE ( 0 ) ; WRITE(numsed,*) ' nn_rstsed = 0 : no control of nittrc000' + CASE ( 1 ) ; WRITE(numsed,*) ' nn_rstsed = 1 : no control the date at nittrc000 (use ndate0 read in the namelist)' + CASE ( 2 ) ; WRITE(numsed,*) ' nn_rstsed = 2 : calendar parameters read in restart' + END SELECT + WRITE(numsed,*) + ENDIF + ! Control of date + IF( nittrc000 - NINT( zkt ) /= nn_dtsed .AND. nn_rstsed /= 0 ) & + & CALL ctl_stop( ' ===>>>> : problem with nittrc000 for the restart', & + & ' verify the restart file or rerun with nn_rsttr = 0 (namelist)' ) + ENDIF + ! + IF( l_offline ) THEN + ! ! set the date in offline mode + IF( ln_rst_sed .AND. nn_rstsed == 2 ) THEN + CALL iom_get( numrsr, 'ndastp', zndastp ) + ndastp = NINT( zndastp ) + CALL iom_get( numrsr, 'adatrj', adatrj ) + ELSE + ndastp = ndate0 - 1 ! ndate0 read in the namelist in dom_nam + adatrj = ( REAL( nittrc000-1, wp ) * rdt ) / rday + ! note this is wrong if time step has changed during run + ENDIF + ! + IF(lwp) THEN + WRITE(numsed,*) ' *** Info used values : ' + WRITE(numsed,*) ' date ndastp : ', ndastp + WRITE(numsed,*) ' number of elapsed days since the begining of run : ', adatrj + WRITE(numsed,*) + ENDIF + ! + CALL day_init ! compute calendar + ! + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN + ! + IF( kt == nitrst ) THEN + IF(lwp) WRITE(numsed,*) + IF(lwp) WRITE(numsed,*) 'trc_wri : write the TOP restart file (NetCDF) at it= ', kt, ' date= ', ndastp + IF(lwp) WRITE(numsed,*) '~~~~~~~' + ENDIF + CALL iom_rstput( kt, nitrst, numrsw, 'kt' , REAL( kt , wp) ) ! time-step + CALL iom_rstput( kt, nitrst, numrsw, 'ndastp' , REAL( ndastp, wp) ) ! date + CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj ) ! number of elapsed days since + ! ! the begining of the run [s] + ENDIF + + END SUBROUTINE sed_rst_cal + +END MODULE sedrst diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedsfc.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedsfc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fe705c283c0df9aa06888f1423f4d68e7d279a51 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedsfc.F90 @@ -0,0 +1,67 @@ +MODULE sedsfc + !!====================================================================== + !! *** MODULE sedsfc *** + !! Sediment : Data at sediment surface + !!===================================================================== + !! * Modules used + USE sed ! sediment global variable + USE sedarr + USE seddta + + PUBLIC sed_sfc + + !! $Id: sedsfc.F90 10222 2018-10-25 09:42:23Z aumont $ +CONTAINS + + SUBROUTINE sed_sfc( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_sfc *** + !! + !! ** Purpose : Give data from sediment model to tracer model + !! + !! + !! History : + !! ! 06-04 (C. Ethe) Orginal code + !!---------------------------------------------------------------------- + !!* Arguments + INTEGER, INTENT(in) :: kt ! time step + + ! * local variables + INTEGER :: ji, jj, ikt ! dummy loop indices + + !------------------------------------------------------------------------ + ! reading variables + + IF( ln_timing ) CALL timing_start('sed_sfc') + + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,1), iarroce(1:jpoce), pwcp(1:jpoce,1,jwalk) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,2), iarroce(1:jpoce), pwcp(1:jpoce,1,jwdic) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,3), iarroce(1:jpoce), pwcp(1:jpoce,1,jwno3) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,4), iarroce(1:jpoce), pwcp(1:jpoce,1,jwpo4) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,5), iarroce(1:jpoce), pwcp(1:jpoce,1,jwoxy) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,6), iarroce(1:jpoce), pwcp(1:jpoce,1,jwsil) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,7), iarroce(1:jpoce), pwcp(1:jpoce,1,jwnh4) ) + CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,8), iarroce(1:jpoce), pwcp(1:jpoce,1,jwfe2) ) + + + DO jj = 1,jpj + DO ji = 1, jpi + ikt = mbkt(ji,jj) + IF ( tmask(ji,jj,ikt) == 1 ) THEN + trb(ji,jj,ikt,jptal) = trc_data(ji,jj,1) + trb(ji,jj,ikt,jpdic) = trc_data(ji,jj,2) + trb(ji,jj,ikt,jpno3) = trc_data(ji,jj,3) * 7.625 + trb(ji,jj,ikt,jppo4) = trc_data(ji,jj,4) * 122. + trb(ji,jj,ikt,jpoxy) = trc_data(ji,jj,5) + trb(ji,jj,ikt,jpsil) = trc_data(ji,jj,6) + trb(ji,jj,ikt,jpnh4) = trc_data(ji,jj,7) * 7.625 + trb(ji,jj,ikt,jpfer) = trc_data(ji,jj,8) + ENDIF + ENDDO + ENDDO + + IF( ln_timing ) CALL timing_stop('sed_sfc') + + END SUBROUTINE sed_sfc + +END MODULE sedsfc diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedstp.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedstp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..41a8b07cbfdc0c898e438af2b48b21e03c83ff8a --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedstp.F90 @@ -0,0 +1,97 @@ +MODULE sedstp + !!====================================================================== + !! *** MODULE sedstp *** + !! Sediment model : Sediment model time-stepping + !!====================================================================== + USE sed ! sediment global variables + USE seddta ! data read + USE sedchem ! chemical constant + USE sedco3 ! carbonate in sediment pore water + USE sedorg ! Organic reactions and diffusion + USE sedinorg ! Inorganic dissolution + USE sedbtb ! bioturbation + USE sedadv ! vertical advection + USE sedmbc ! mass balance calculation + USE sedsfc ! sediment surface data + USE sedrst ! restart + USE sedwri ! outputs + USE trcdmp_sed + USE lib_mpp ! distribued memory computing library + USE iom + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC sed_stp ! called by step.F90 + + !! $Id: sedstp.F90 10222 2018-10-25 09:42:23Z aumont $ +CONTAINS + + SUBROUTINE sed_stp ( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sed_stp *** + !! + !! ** Purpose : Sediment time stepping + !! Simulation of pore water chemistry + !! + !! ** Action : + !! + !! + !! History : + !! ! 98-08 (E. Maier-Reimer, Christoph Heinze ) Original code + !! ! 04-10 (N. Emprin, M. Gehlen ) coupled with PISCES + !! ! 06-04 (C. Ethe) Re-organization + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + INTEGER :: ji,jk,js,jn,jw + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('sed_stp') + ! + CALL sed_rst_opn ( kt ) ! Open tracer restart file + IF( lrst_sed ) CALL sed_rst_cal ( kt, 'WRITE' ) ! calenda + + IF(ln_sediment_offline) CALL trc_dmp_sed ( kt ) + + dtsed = r2dttrc +! dtsed2 = dtsed + IF (kt /= nitsed000) THEN + CALL sed_dta( kt ) ! Load Data for bot. wat. Chem and fluxes + ENDIF + + IF (sedmask == 1. ) THEN + IF( kt /= nitsed000 ) THEN + CALL sed_chem( kt ) ! update of chemical constant to account for salinity, temperature changes + ENDIF + + CALL sed_btb( kt ) ! 1st pass of bioturbation at t+1/2 + CALL sed_org( kt ) ! Organic related reactions and diffusion + CALL sed_inorg( kt ) ! Dissolution reaction + CALL sed_btb( kt ) ! 2nd pass of bioturbation at t+1 + tokbot(:,:) = 0.0 + DO jw = 1, jpwat + DO ji = 1, jpoce + tokbot(ji,jw) = pwcp(ji,1,jw) * 1.e-3 * dzkbot(ji) + END DO + ENDDO + CALL sed_adv( kt ) ! advection + CALL sed_co3( kt ) ! pH actualization for saving + ! This routine is commented out since it does not work at all + CALL sed_mbc( kt ) ! cumulation for mass balance calculation + + IF (ln_sed_2way) CALL sed_sfc( kt ) ! Give back new bottom wat chem to tracer model + ENDIF + CALL sed_wri( kt ) ! outputs + IF( kt == nitsed000 ) THEN + CALL iom_close( numrsr ) ! close input tracer restart file +! IF(lwm) CALL FLUSH( numont ) ! flush namelist output + ENDIF + IF( lrst_sed ) CALL sed_rst_wri( kt ) ! restart file output + + IF( kt == nitsedend ) CLOSE( numsed ) + + IF( ln_timing ) CALL timing_stop('sed_stp') + + END SUBROUTINE sed_stp + +END MODULE sedstp diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/sedwri.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedwri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..58a0e99a38890622cc43288b0f27fd246991020f --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/sedwri.F90 @@ -0,0 +1,138 @@ +MODULE sedwri + !!====================================================================== + !! *** MODULE sedwri *** + !! Sediment diagnostics : write sediment output files + !!====================================================================== + USE sed + USE sedarr + USE lib_mpp ! distribued memory computing library + USE iom + + IMPLICIT NONE + PRIVATE + + !! * Accessibility + PUBLIC sed_wri + + !! $Id: sedwri.F90 10222 2018-10-25 09:42:23Z aumont $ +CONTAINS + + !!---------------------------------------------------------------------- + !! NetCDF output file + !!---------------------------------------------------------------------- + SUBROUTINE sed_wri( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sed_wri *** + !! + !! ** Purpose : output of sediment passive tracer + !! + !! History : + !! ! 06-07 (C. Ethe) original + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt + + INTEGER :: ji, jj, jk, js, jw, jn + INTEGER :: it + CHARACTER(len = 20) :: cltra + REAL(wp) :: zrate + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta, zflx + + !!------------------------------------------------------------------- + + + ! Initialisation + ! ----------------- + + ! 1. Initilisations + ! ----------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('sed_wri') +! + IF (lwp) WRITE(numsed,*) ' ' + IF (lwp) WRITE(numsed,*) 'sed_wri kt = ', kt + IF (lwp) WRITE(numsed,*) ' ' + + ALLOCATE( zdta(jpoce,jpksed) ) ; ALLOCATE( zflx(jpoce,jpwatp1) ) + + ! Initialize variables + ! -------------------- + + trcsedi(:,:,:,:) = 0.0 + flxsedi3d(:,:,:,:) = 0.0 + flxsedi2d(:,:,:) = 0.0 + + ! 2. Back to 2D geometry + ! ----------------------------------------------------------------- + DO jn = 1, jpsol + CALL unpack_arr( jpoce, trcsedi(1:jpi,1:jpj,1:jpksed,jn) , iarroce(1:jpoce), & + & solcp(1:jpoce,1:jpksed,jn ) ) + END DO + + DO jn = 1, jpwat + CALL unpack_arr( jpoce, trcsedi(1:jpi,1:jpj,1:jpksed,jpsol + jn) , iarroce(1:jpoce), & + & pwcp(1:jpoce,1:jpksed,jn ) ) + END DO + + ! porosity + zdta(:,:) = 0. + DO jk = 1, jpksed + DO ji = 1, jpoce + zdta(ji,jk) = -LOG10( hipor(ji,jk) / ( densSW(ji) + rtrn ) + rtrn ) + ENDDO + ENDDO + + CALL unpack_arr( jpoce, flxsedi3d(1:jpi,1:jpj,1:jpksed,1) , iarroce(1:jpoce), & + & zdta(1:jpoce,1:jpksed) ) + + CALL unpack_arr( jpoce, flxsedi3d(1:jpi,1:jpj,1:jpksed,2) , iarroce(1:jpoce), & + & co3por(1:jpoce,1:jpksed) ) + +! flxsedi3d = 0. + zflx(:,:) = 0. + ! Calculation of fluxes mol/cm2/s + DO jw = 1, jpwat + DO ji = 1, jpoce + zflx(ji,jw) = ( pwcp(ji,1,jw) - pwcp_dta(ji,jw) ) & + & * 1.e3 / 1.e2 * dzkbot(ji) / r2dttrc + ENDDO + ENDDO + + ! Calculation of accumulation rate per dt + DO js = 1, jpsol + zrate = 1.0 / ( denssol * por1(jpksed) ) / r2dttrc + DO ji = 1, jpoce + zflx(ji,jpwatp1) = zflx(ji,jpwatp1) + ( tosed(ji,js) - fromsed(ji,js) ) * zrate + ENDDO + ENDDO + + DO jn = 1, jpdia2dsed - 1 + CALL unpack_arr( jpoce, flxsedi2d(1:jpi,1:jpj,jn), iarroce(1:jpoce), zflx(1:jpoce,jn) ) + END DO + zflx(:,1) = dzdep(:) / dtsed + CALL unpack_arr( jpoce, flxsedi2d(1:jpi,1:jpj,jpdia2dsed), iarroce(1:jpoce), zflx(1:jpoce,1) ) + + ! Start writing data + ! --------------------- + DO jn = 1, jptrased + cltra = sedtrcd(jn) ! short title for 3D diagnostic + CALL iom_put( cltra, trcsedi(:,:,:,jn) ) + END DO + + DO jn = 1, jpdia3dsed + cltra = seddia3d(jn) ! short title for 3D diagnostic + CALL iom_put( cltra, flxsedi3d(:,:,:,jn) ) + END DO + + DO jn = 1, jpdia2dsed + cltra = seddia2d(jn) ! short title for 2D diagnostic + CALL iom_put( cltra, flxsedi2d(:,:,jn) ) + END DO + + + DEALLOCATE( zdta ) ; DEALLOCATE( zflx ) + + IF( ln_timing ) CALL timing_stop('sed_wri') + + END SUBROUTINE sed_wri + +END MODULE sedwri diff --git a/V4.0/nemo_sources/src/TOP/PISCES/SED/trcdmp_sed.F90 b/V4.0/nemo_sources/src/TOP/PISCES/SED/trcdmp_sed.F90 new file mode 100644 index 0000000000000000000000000000000000000000..67527de5e7d05cf636c098214cd76dc118669206 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/SED/trcdmp_sed.F90 @@ -0,0 +1,157 @@ +MODULE trcdmp_sed + !!====================================================================== + !! *** MODULE trcdmp *** + !! Ocean physics: internal restoring trend on passive tracers + !!====================================================================== + !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code + !! ! 1996-01 (G. Madec) statement function for e3 + !! ! 1997-05 (H. Loukos) adapted for passive tracers + !! NEMO 9.0 ! 2004-03 (C. Ethe) free form + modules + !! 3.2 ! 2007-02 (C. Deltel) Diagnose ML trends for passive tracers + !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! trc_dmp : update the tracer trend with the internal damping + !! trc_dmp_init : initialization, namlist read, parameters control + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and tracers variables + USE trc ! ocean passive tracers variables + USE sed , ONLY : dtsed => dtsed ! ocean dynamics and tracers variables + USE trc ! ocean passive tracers variables + USE trcdta + USE prtctl_trc ! Print control for debbuging + USE iom + + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_dmp_sed + PUBLIC trc_dmp_sed_alloc + PUBLIC trc_dmp_sed_ini + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: restosed ! restoring coeff. on tracers (s-1) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 3.3 , NEMO Consortium (2010) + !! $Id: trcdmp.F90 7646 2017-02-06 09:25:03Z timgraham $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_dmp_sed_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( restosed(jpi,jpj,jpk) , STAT=trc_dmp_sed_alloc ) + ! + IF( trc_dmp_sed_alloc /= 0 ) CALL ctl_warn('trc_dmp_sed_alloc: failed to allocate array') + ! + END FUNCTION trc_dmp_sed_alloc + + + SUBROUTINE trc_dmp_sed( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_sed *** + !! + !! ** Purpose : Compute the passive 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 trdta computed + !! and add to the general tracer trends: + !! trn = tra + restotr * (trdta - trb) + !! The trend is computed either throughout the water column + !! (nlmdmptr=0) or in area of weak vertical mixing (nlmdmptr=1) or + !! below the well mixed layer (nlmdmptr=2) + !! + !! ** Action : - update the tracer trends tra with the newtonian + !! damping trends. + !! - save the trends ('key_trdmxl_trc') + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jn, jl, ikt ! dummy loop indices + CHARACTER (len=22) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztrcdta ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_dmp_sed') + ! + ! + IF( nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping + ! + DO jn = 1, jptra ! tracer loop + ! ! =========== + IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file + ! + jl = n_trc_index(jn) + CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 + ! + DO jj = 1, jpj + DO ji = 1, jpi ! vector opt. + ikt = mbkt(ji,jj) + trb(ji,jj,ikt,jn) = ztrcdta(ji,jj,ikt) + ( trb(ji,jj,ikt,jn) - ztrcdta(ji,jj,ikt) ) & + & * exp( -restosed(ji,jj,ikt) * dtsed ) + END DO + END DO + ! + ENDIF + END DO ! tracer loop + ! ! =========== + ENDIF + ! + ! ! print mean trends (used for debugging) + IF( ln_ctl ) THEN + WRITE(charout, FMT="('dmp ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_dmp_sed') + ! + END SUBROUTINE trc_dmp_sed + + + SUBROUTINE trc_dmp_sed_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_ini *** + !! + !! ** Purpose : Initialization for the newtonian damping + !! + !! ** Method : read the nammbf namelist and check the parameters + !! called by trc_dmp at the first timestep (nittrc000) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_dmp_sed_ini') + + IF (lwp) WRITE(numout,*) ' tracer damping throughout the water column' + ! + IF( trc_dmp_sed_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_dmp_sed_ini: unable to allocate arrays' ) + ! + IF( .NOT.lk_c1d ) THEN + !Read in mask from file + restosed(:,:,:) = 0.5 / rday + ! + ENDIF + IF( ln_timing ) CALL timing_stop('trc_dmp_sed_ini') + ! + END SUBROUTINE trc_dmp_sed_ini + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_dmp_sed( kt ) ! Empty routine + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_dmp_sed: You should not have seen this print! error?', kt + END SUBROUTINE trc_dmp_sed +#endif + + !!====================================================================== +END MODULE trcdmp_sed diff --git a/V4.0/nemo_sources/src/TOP/PISCES/par_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/par_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0a1bfec5d61f0f61d89388eeb63fa20e8d50bdaa --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/par_pisces.F90 @@ -0,0 +1,70 @@ +MODULE par_pisces + !!====================================================================== + !! *** par_pisces *** + !! TOP : set the PISCES parameters + !!====================================================================== + !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! productive layer depth + INTEGER, PUBLIC :: jpkb !: first vertical layers where biology is active + INTEGER, PUBLIC :: jpkbm1 !: first vertical layers where biology is active + + ! assign an index in trc arrays for each LOBSTER prognostic variables + INTEGER, PUBLIC :: jpdet !: detritus + INTEGER, PUBLIC :: jpdom !: dissolved organic matter + INTEGER, PUBLIC :: jpdic !: dissolved inoganic carbon concentration + INTEGER, PUBLIC :: jptal !: total alkalinity + INTEGER, PUBLIC :: jpoxy !: oxygen carbon concentration + INTEGER, PUBLIC :: jpcal !: calcite concentration + INTEGER, PUBLIC :: jppo4 !: phosphate concentration + INTEGER, PUBLIC :: jppoc !: small particulate organic phosphate concentration + INTEGER, PUBLIC :: jpsil !: silicate concentration + INTEGER, PUBLIC :: jpphy !: phytoplancton concentration + INTEGER, PUBLIC :: jpzoo !: zooplancton concentration + INTEGER, PUBLIC :: jpdoc !: dissolved organic carbon concentration + INTEGER, PUBLIC :: jpdia !: Diatoms Concentration + INTEGER, PUBLIC :: jpmes !: Mesozooplankton Concentration + INTEGER, PUBLIC :: jpdsi !: Diatoms Silicate Concentration + INTEGER, PUBLIC :: jpfer !: Iron Concentration + INTEGER, PUBLIC :: jpbfe !: Big iron particles Concentration + INTEGER, PUBLIC :: jpgoc !: big particulate organic phosphate concentration + INTEGER, PUBLIC :: jpsfe !: Small iron particles Concentration + INTEGER, PUBLIC :: jpdfe !: Diatoms iron Concentration + INTEGER, PUBLIC :: jpgsi !: (big) Silicate Concentration + INTEGER, PUBLIC :: jpnfe !: Nano iron Concentration + INTEGER, PUBLIC :: jpnch !: Nano Chlorophyll Concentration + INTEGER, PUBLIC :: jpdch !: Diatoms Chlorophyll Concentration + INTEGER, PUBLIC :: jpno3 !: Nitrates Concentration + INTEGER, PUBLIC :: jpnh4 !: Ammonium Concentration + INTEGER, PUBLIC :: jpdon !: dissolved organic nitrogen concentration + INTEGER, PUBLIC :: jpdop !: dissolved organic phosphorus concentration + INTEGER, PUBLIC :: jppon !: small particulate organic nitrogen concentration + INTEGER, PUBLIC :: jppop !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jpnph !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jppph !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jpndi !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jppdi !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jppic !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jpnpi !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jpppi !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jppfe !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jppch !: small particulate organic phosphorus concentration + INTEGER, PUBLIC :: jpgon !: Big nitrogen particles Concentration + INTEGER, PUBLIC :: jpgop !: Big phosphorus particles Concentration + INTEGER, PUBLIC :: jplgw !: Weak Ligands + + !!--------------------------------------------------------------------- + !! Default No CFC geochemical model + ! Starting/ending PISCES do-loop indices (N.B. no PISCES : jpl_pcs < jpf_pcs the do-loop are never done) + INTEGER, PUBLIC :: jp_pcs0 !: First index of PISCES tracers + INTEGER, PUBLIC :: jp_pcs1 !: Last index of PISCES tracers + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: par_pisces.F90 10416 2018-12-19 11:45:43Z aumont $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE par_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/sms_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/sms_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8fc6f79e3a9f25981ed87f6486522ea81c595937 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/sms_pisces.F90 @@ -0,0 +1,194 @@ +MODULE sms_pisces + !!---------------------------------------------------------------------- + !! *** sms_pisces.F90 *** + !! TOP : PISCES Source Minus Sink variables + !!---------------------------------------------------------------------- + !! History : 1.0 ! 2000-02 (O. Aumont) original code + !! 3.2 ! 2009-04 (C. Ethe & NEMO team) style + !!---------------------------------------------------------------------- + USE par_oce + USE par_trc + + IMPLICIT NONE + PUBLIC + + INTEGER :: numnatp_ref = -1 !! Logical units for namelist pisces + INTEGER :: numnatp_cfg = -1 !! Logical units for namelist pisces + INTEGER :: numonp = -1 !! Logical unit for namelist pisces output + + ! !: PISCES : silicon dependant half saturation + + !!* Model used + LOGICAL :: ln_p2z !: Flag to use LOBSTER model + LOGICAL :: ln_p4z !: Flag to use PISCES model + LOGICAL :: ln_p5z !: Flag to use PISCES quota model + LOGICAL :: ln_ligand !: Flag to enable organic ligands + LOGICAL :: ln_sediment !: Flag to enable sediment module + + !!* Time variables + INTEGER :: nrdttrc !: ??? + REAL(wp) :: rfact , rfactr !: ??? + REAL(wp) :: rfact2, rfact2r !: ??? + REAL(wp) :: xstep !: Time step duration for biology + REAL(wp) :: ryyss !: number of seconds per year + REAL(wp) :: r1_ryyss !: inverse number of seconds per year + + + !!* Biological parameters + REAL(wp) :: rno3 !: ??? + REAL(wp) :: o2ut !: ??? + REAL(wp) :: po4r !: ??? + REAL(wp) :: rdenit !: ??? + REAL(wp) :: rdenita !: ??? + REAL(wp) :: o2nit !: ??? + REAL(wp) :: wsbio, wsbio2 !: ??? + REAL(wp) :: wsbio2max !: ??? + REAL(wp) :: wsbio2scale !: ??? + REAL(wp) :: xkmort !: ??? + REAL(wp) :: ferat3 !: ??? + REAL(wp) :: ldocp !: ??? + REAL(wp) :: ldocz !: ??? + REAL(wp) :: lthet !: ??? + REAL(wp) :: no3rat3 !: ??? + REAL(wp) :: po4rat3 !: ??? + + + !!* diagnostic parameters + REAL(wp) :: tpp !: total primary production + REAL(wp) :: t_oce_co2_exp !: total carbon export + REAL(wp) :: t_oce_co2_flx !: Total ocean carbon flux + REAL(wp) :: t_oce_co2_flx_cum !: Cumulative Total ocean carbon flux + REAL(wp) :: t_atm_co2_flx !: global mean of atmospheric pco2 + + !!* restoring + LOGICAL :: ln_pisdmp !: restoring or not of nutrients to a mean value + INTEGER :: nn_pisdmp !: frequency of relaxation or not of nutrients to a mean value + + !!* Mass conservation + LOGICAL :: ln_check_mass !: Flag to check mass conservation + LOGICAL , PUBLIC :: ln_ironice !: boolean for Fe input from sea ice + + !!* Biological fluxes for light : variables shared by pisces & lobster + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) :: neln !: number of T-levels + 1 in the euphotic layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: heup !: euphotic layer depth + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etot !: par (photosynthetic available radiation) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etot_ndcy !: PAR over 24h in case of diurnal cycle + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: enano, ediat !: PAR for phyto, nano and diat + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: enanom, ediatm !: PAR for phyto, nano and diat + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: epico !: PAR for pico + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: epicom !: PAR for pico + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: emoy !: averaged PAR in the mixed layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: heup_01 !: Absolute euphotic layer depth + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: xksi !: LOBSTER : zooplakton closure + + !!* Biological fluxes for primary production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: xksimax !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: biron !: bioavailable fraction of iron + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: plig !: proportion of iron organically complexed + + !!* Sinking speed + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wsbio3 !: POC sinking speed + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wsbio4 !: GOC sinking speed + + !!* SMS for the organic matter + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xfracal !: ?? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nitrfac !: ?? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nitrfac2 !: ?? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: orem !: ?? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xdiss !: ?? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: prodcal !: Calcite production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: prodpoc !: Calcite production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: conspoc !: Calcite production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: prodgoc !: Calcite production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: consgoc !: Calcite production + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: blim !: bacterial production factor + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sizen !: size of diatoms + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sizep !: size of diatoms + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sized !: size of diatoms + + + !!* Variable for chemistry of the CO2 cycle + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak13 !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak23 !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aksp !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hi !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: excess !: ??? + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aphscale !: + + + !!* Temperature dependancy of SMS terms + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tgfunc !: Temp. dependancy of various biological rates + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tgfunc2 !: Temp. dependancy of mesozooplankton rates + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: sms_pisces.F90 10788 2019-03-21 11:15:14Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sms_pisces_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE sms_pisces_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp , ONLY: ctl_stop + INTEGER :: ierr(10) ! Local variables + !!---------------------------------------------------------------------- + ierr(:) = 0 + !* Biological fluxes for light : shared variables for pisces & lobster + ALLOCATE( etot(jpi,jpj,jpk), neln(jpi,jpj), heup(jpi,jpj), & + & heup_01(jpi,jpj) , xksi(jpi,jpj) , STAT=ierr(1) ) + ! + + IF( ln_p4z .OR. ln_p5z ) THEN + !* Biological fluxes for light + ALLOCATE( enano(jpi,jpj,jpk) , ediat(jpi,jpj,jpk) , & + & enanom(jpi,jpj,jpk) , ediatm(jpi,jpj,jpk), & + & etot_ndcy(jpi,jpj,jpk), emoy(jpi,jpj,jpk) , STAT=ierr(2) ) + + !* Biological fluxes for primary production + ALLOCATE( xksimax(jpi,jpj) , biron(jpi,jpj,jpk) , STAT=ierr(3) ) + ! + !* SMS for the organic matter + ALLOCATE( xfracal (jpi,jpj,jpk), orem(jpi,jpj,jpk) , & + & nitrfac(jpi,jpj,jpk), nitrfac2(jpi,jpj,jpk) , & + & prodcal(jpi,jpj,jpk) , xdiss (jpi,jpj,jpk), & + & prodpoc(jpi,jpj,jpk) , conspoc(jpi,jpj,jpk) , & + & prodgoc(jpi,jpj,jpk) , consgoc(jpi,jpj,jpk) , & + & blim (jpi,jpj,jpk) , STAT=ierr(4) ) + + !* Variable for chemistry of the CO2 cycle + ALLOCATE( ak13 (jpi,jpj,jpk) , & + & ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , & + & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , & + & aphscale(jpi,jpj,jpk), STAT=ierr(5) ) + ! + !* Temperature dependancy of SMS terms + ALLOCATE( tgfunc(jpi,jpj,jpk) , tgfunc2(jpi,jpj,jpk), STAT=ierr(6) ) + ! + !* Sinkong speed + ALLOCATE( wsbio3 (jpi,jpj,jpk) , wsbio4 (jpi,jpj,jpk), & + & STAT=ierr(7) ) + ! + IF( ln_ligand ) THEN + ALLOCATE( plig(jpi,jpj,jpk) , STAT=ierr(8) ) + ENDIF + ENDIF + ! + IF( ln_p5z ) THEN + ! + ALLOCATE( epico(jpi,jpj,jpk) , epicom(jpi,jpj,jpk) , STAT=ierr(9) ) + + !* Size of phytoplankton cells + ALLOCATE( sizen(jpi,jpj,jpk), sizep(jpi,jpj,jpk), & + & sized(jpi,jpj,jpk), STAT=ierr(10) ) + ENDIF + ! + sms_pisces_alloc = MAXVAL( ierr ) + ! + IF( sms_pisces_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sms_pisces_alloc: failed to allocate arrays' ) + ! + END FUNCTION sms_pisces_alloc + + !!====================================================================== +END MODULE sms_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/trcice_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/trcice_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8ce76bc76b9740e84bcd3bac29fea74ad22daae7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/trcice_pisces.F90 @@ -0,0 +1,352 @@ +MODULE trcice_pisces + !!====================================================================== + !! *** MODULE trcice_pisces *** + !! TOP : initialisation of the PISCES biochemical model + !!====================================================================== + !! History : 3.5 ! 2013 (M. Vancoppenolle, O. Aumont, G. Madec), original code + !!---------------------------------------------------------------------- + !! trc_ice_pisces : PISCES fake sea ice model setting + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE par_pisces ! PISCES parameters + USE oce_trc ! Shared variables between ocean and passive tracers + USE trc ! Passive tracers common variables + USE sms_pisces ! PISCES Source Minus Sink variables + USE in_out_manager + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini_pisces ! called by trcini.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice_pisces.F90 10794 2019-03-22 09:25:28Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini_pisces + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_pisces *** + !! + !! ** Purpose : Initialisation of the PISCES biochemical model + !!---------------------------------------------------------------------- + ! + IF( ln_p4z .OR. ln_p5z ) THEN ; CALL p4z_ice_ini ! PISCES + ELSE ; CALL p2z_ice_ini ! LOBSTER + ENDIF + ! + END SUBROUTINE trc_ice_ini_pisces + + + SUBROUTINE p4z_ice_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_ice_ini *** + !! + !! ** Purpose : PISCES fake sea ice model setting + !! Method : Assign prescribe values to tracer concentrations in sea ice + !! + !! For levitating sea ice, constant ocean tracer concentrations also have to be defined. + !! This is done specifically for Global, Arctic, Antarctic and Baltic regions + !! + !! Sea ice concentrations are by default prescribed as follows + !! trc_i = zratio * trc_o + !! + !! This formulation is modulated by the namelist parameter trc_ice_ratio + !! + !! trc_ice_ratio * betw 0 and 1: prescribed ice/ocean tracer concentration ratio + !! * -1 => the ice-ocean tracer concentration ratio follows the + !! ice-ocean salinity ratio + !! * -2 => no ice-ocean tracer concentration is used + !! instead, the tracer concentration in sea ice + !! is prescribed to trc_ice_prescr + !! + !! cn_trc_o specifies which disinctions are made for prescribed tracer concentration + !! * 'GL' use global ocean values making distinction for Baltic Sea only + !! * 'AA' use Arctic/Antarctic contrasted values, + Baltic + !! + !!---------------------------------------------------------------------- + + !--- Dummy variables + REAL(wp), DIMENSION(jpmaxtrc,2) :: zratio ! effective ice-ocean tracer cc ratio + REAL(wp), DIMENSION(jpmaxtrc,4) :: zpisc ! prescribes concentration + ! ! 1:global, 2:Arctic, 3:Antarctic, 4:Baltic + + REAL(wp), DIMENSION(2) :: zrs ! ice-ocean salinity ratio, 1 - global, 2- Baltic + REAL(wp) :: zsice_bal ! prescribed ice salinity in the Baltic + REAL(wp) :: zsoce_bal ! prescribed ocean salinity in the Baltic + REAL(wp) :: zfeoce_glo ! prescribed iron concentration in the global ocean + REAL(wp) :: zfeoce_bal ! prescribed iron concentration in the global ocean + INTEGER :: jn ! dummy loop index + + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_ice_ini_pisces: Prescribed sea ice biogeochemistry ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~' + + !-------------------------------------------- + ! Initialize ocean prescribed concentrations + !-------------------------------------------- + ! values taken from a 500 yr equilibrium run + ! used only in the levitating sea ice case with virtual salt / tracer + ! fluxes + + !--- Global values + zpisc(jpdic,1) = 1.99e-3_wp + zpisc(jpdoc,1) = 2.04e-5_wp + zpisc(jptal,1) = 2.31e-3_wp + zpisc(jpoxy,1) = 2.47e-4_wp + zpisc(jpcal,1) = 1.04e-8_wp + zpisc(jppo4,1) = 5.77e-7_wp / po4r + zpisc(jppoc,1) = 1.27e-6_wp + zpisc(jpgoc,1) = 5.23e-8_wp + zpisc(jpbfe,1) = 9.84e-13_wp + zpisc(jpsil,1) = 7.36e-6_wp + zpisc(jpdsi,1) = 1.07e-7_wp + zpisc(jpgsi,1) = 1.53e-8_wp + zpisc(jpphy,1) = 9.57e-8_wp + zpisc(jpdia,1) = 4.24e-7_wp + zpisc(jpzoo,1) = 6.07e-7_wp + zpisc(jpmes,1) = 3.44e-7_wp + zpisc(jpfer,1) = 4.06e-10_wp + zpisc(jpsfe,1) = 2.51e-11_wp + zpisc(jpdfe,1) = 6.57e-12_wp + zpisc(jpnfe,1) = 1.76e-11_wp + zpisc(jpnch,1) = 1.67e-7_wp + zpisc(jpdch,1) = 1.02e-7_wp + zpisc(jpno3,1) = 5.79e-6_wp / rno3 + zpisc(jpnh4,1) = 3.22e-7_wp / rno3 + zpisc(jplgw,1) = 1.0e-9_wp + + ! ln_p5z + zpisc(jppic,1) = 9.57e-8_wp + zpisc(jpnpi,1) = 9.57e-8_wp + zpisc(jpppi,1) = 9.57e-8_wp + zpisc(jppfe,1) = 1.76e-11_wp + zpisc(jppch,1) = 1.67e-7_wp + zpisc(jpnph,1) = 9.57e-8_wp + zpisc(jppph,1) = 9.57e-8_wp + zpisc(jpndi,1) = 4.24e-7_wp + zpisc(jppdi,1) = 4.24e-7_wp + zpisc(jppon,1) = 9.57e-8_wp + zpisc(jppop,1) = 9.57e-8_wp + zpisc(jpdon,1) = 2.04e-5_wp + zpisc(jpdop,1) = 2.04e-5_wp + zpisc(jpgon,1) = 5.23e-8_wp + zpisc(jpgop,1) = 5.23e-8_wp + + !--- Arctic specificities (dissolved inorganic & DOM) + zpisc(jpdic,2) = 1.98e-3_wp + zpisc(jpdoc,2) = 6.00e-6_wp + zpisc(jptal,2) = 2.13e-3_wp + zpisc(jpoxy,2) = 3.65e-4_wp + zpisc(jpcal,2) = 1.50e-9_wp + zpisc(jppo4,2) = 4.09e-7_wp / po4r + zpisc(jppoc,2) = 4.05e-7_wp + zpisc(jpgoc,2) = 2.84e-8_wp + zpisc(jpbfe,2) = 7.03e-13_wp + zpisc(jpsil,2) = 6.87e-6_wp + zpisc(jpdsi,2) = 1.73e-7_wp + zpisc(jpgsi,2) = 7.93e-9_wp + zpisc(jpphy,2) = 5.25e-7_wp + zpisc(jpdia,2) = 7.75e-7_wp + zpisc(jpzoo,2) = 3.34e-7_wp + zpisc(jpmes,2) = 2.49e-7_wp + zpisc(jpfer,2) = 1.43e-9_wp + zpisc(jpsfe,2) = 2.21e-11_wp + zpisc(jpdfe,2) = 2.04e-11_wp + zpisc(jpnfe,2) = 1.75e-11_wp + zpisc(jpnch,2) = 1.46e-07_wp + zpisc(jpdch,2) = 2.36e-07_wp + zpisc(jpno3,2) = 3.51e-06_wp / rno3 + zpisc(jpnh4,2) = 6.15e-08_wp / rno3 + zpisc(jplgw,2) = 1.0e-9_wp + + ! ln_p5z + zpisc(jppic,2) = 5.25e-7_wp + zpisc(jpnpi,2) = 5.25e-7_wp + zpisc(jpppi,2) = 5.25e-7_wp + zpisc(jppfe,2) = 1.75e-11_wp + zpisc(jppch,2) = 1.46e-07_wp + zpisc(jpnph,2) = 5.25e-7_wp + zpisc(jppph,2) = 5.25e-7_wp + zpisc(jpndi,2) = 7.75e-7_wp + zpisc(jppdi,2) = 7.75e-7_wp + zpisc(jppon,2) = 4.05e-7_wp + zpisc(jppop,2) = 4.05e-7_wp + zpisc(jpdon,2) = 6.00e-6_wp + zpisc(jpdop,2) = 6.00e-6_wp + zpisc(jpgon,2) = 2.84e-8_wp + zpisc(jpgop,2) = 2.84e-8_wp + + !--- Antarctic specificities (dissolved inorganic & DOM) + zpisc(jpdic,3) = 2.20e-3_wp + zpisc(jpdoc,3) = 7.02e-6_wp + zpisc(jptal,3) = 2.37e-3_wp + zpisc(jpoxy,3) = 3.42e-4_wp + zpisc(jpcal,3) = 3.17e-9_wp + zpisc(jppo4,3) = 1.88e-6_wp / po4r + zpisc(jppoc,3) = 1.13e-6_wp + zpisc(jpgoc,3) = 2.89e-8_wp + zpisc(jpbfe,3) = 5.63e-13_wp + zpisc(jpsil,3) = 4.96e-5_wp + zpisc(jpdsi,3) = 5.63e-7_wp + zpisc(jpgsi,3) = 5.35e-8_wp + zpisc(jpphy,3) = 8.10e-7_wp + zpisc(jpdia,3) = 5.77e-7_wp + zpisc(jpzoo,3) = 6.68e-7_wp + zpisc(jpmes,3) = 3.55e-7_wp + zpisc(jpfer,3) = 1.62e-10_wp + zpisc(jpsfe,3) = 2.29e-11_wp + zpisc(jpdfe,3) = 8.75e-12_wp + zpisc(jpnfe,3) = 1.48e-11_wp + zpisc(jpnch,3) = 2.02e-7_wp + zpisc(jpdch,3) = 1.60e-7_wp + zpisc(jpno3,3) = 2.64e-5_wp / rno3 + zpisc(jpnh4,3) = 3.39e-7_wp / rno3 + zpisc(jplgw,3) = 1.0e-9_wp + + ! ln_p5z + zpisc(jppic,3) = 8.10e-7_wp + zpisc(jpnpi,3) = 8.10e-7_wp + zpisc(jpppi,3) = 8.10e-7_wp + zpisc(jppfe,3) = 1.48e-11_wp + zpisc(jppch,3) = 2.02e-7_wp + zpisc(jpnph,3) = 9.57e-8_wp + zpisc(jppph,3) = 9.57e-8_wp + zpisc(jpndi,3) = 5.77e-7_wp + zpisc(jppdi,3) = 5.77e-7_wp + zpisc(jppon,3) = 1.13e-6_wp + zpisc(jppop,3) = 1.13e-6_wp + zpisc(jpdon,3) = 7.02e-6_wp + zpisc(jpdop,3) = 7.02e-6_wp + zpisc(jpgon,3) = 2.89e-8_wp + zpisc(jpgop,3) = 2.89e-8_wp + + + !--- Baltic Sea particular case for ORCA configurations + zpisc(jpdic,4) = 1.14e-3_wp + zpisc(jpdoc,4) = 1.06e-5_wp + zpisc(jptal,4) = 1.16e-3_wp + zpisc(jpoxy,4) = 3.71e-4_wp + zpisc(jpcal,4) = 1.51e-9_wp + zpisc(jppo4,4) = 2.85e-9_wp / po4r + zpisc(jppoc,4) = 4.84e-7_wp + zpisc(jpgoc,4) = 1.05e-8_wp + zpisc(jpbfe,4) = 4.97e-13_wp + zpisc(jpsil,4) = 4.91e-5_wp + zpisc(jpdsi,4) = 3.25e-7_wp + zpisc(jpgsi,4) = 1.93e-8_wp + zpisc(jpphy,4) = 6.64e-7_wp + zpisc(jpdia,4) = 3.41e-7_wp + zpisc(jpzoo,4) = 3.83e-7_wp + zpisc(jpmes,4) = 0.225e-6_wp + zpisc(jpfer,4) = 2.45e-9_wp + zpisc(jpsfe,4) = 3.89e-11_wp + zpisc(jpdfe,4) = 1.33e-11_wp + zpisc(jpnfe,4) = 2.62e-11_wp + zpisc(jpnch,4) = 1.17e-7_wp + zpisc(jpdch,4) = 9.69e-8_wp + zpisc(jpno3,4) = 5.36e-5_wp / rno3 + zpisc(jpnh4,4) = 7.18e-7_wp / rno3 + zpisc(jplgw,4) = 1.0e-9_wp + + ! ln_p5z + zpisc(jppic,4) = 6.64e-7_wp + zpisc(jpnpi,4) = 6.64e-7_wp + zpisc(jpppi,4) = 6.64e-7_wp + zpisc(jppfe,4) = 3.89e-11_wp + zpisc(jppch,4) = 1.17e-7_wp + zpisc(jpnph,4) = 6.64e-7_wp + zpisc(jppph,4) = 6.64e-7_wp + zpisc(jpndi,4) = 3.41e-7_wp + zpisc(jppdi,4) = 3.41e-7_wp + zpisc(jppon,4) = 4.84e-7_wp + zpisc(jppop,4) = 4.84e-7_wp + zpisc(jpdon,4) = 1.06e-5_wp + zpisc(jpdop,4) = 1.06e-5_wp + zpisc(jpgon,4) = 1.05e-8_wp + zpisc(jpgop,4) = 1.05e-8_wp +! +! ln_ironice and tracers in seaice are redundant. Thus, if tracers in ice +! is activated, ln_ironice should be set to false +! ------------------------------------------------------------------------ + IF( nn_ice_tr /= 0 .AND. ln_ironice ) THEN + IF(lwp) THEN + WRITE(numout,*) ' ==>>> ln_ironice incompatible with nn_ice_tr = ', nn_ice_tr + WRITE(numout,*) ' Specify your sea ice iron concentration in nampisice instead ' + WRITE(numout,*) ' ln_ironice is forced to .FALSE. ' + ENDIF + ln_ironice = .FALSE. + ENDIF +! + DO jn = jp_pcs0, jp_pcs1 + IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1) ! Global case + IF( cn_trc_o(jn) == 'AA ' ) THEN + WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic + WHERE( gphit(:,:) < 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic + ENDIF + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN ! Baltic Sea particular case for ORCA configurations + WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & + 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) + trc_o(:,:,jn) = zpisc(jn,4) + END WHERE + ENDIF + ENDDO + + + + !----------------------------- + ! Assign ice-ocean cc ratios + !----------------------------- + ! 0 means zero concentration in sea ice + ! 1 means same concentration in the sea ice as in the ocean + + ! Ice ocean salinity ratio + zsoce_bal = 4. ; zsice_bal = 2. !! Baltic ocean and sea ice salinities + zrs(1) = sice / soce !! ice-ocean salinity ratio, global case + zrs(2) = zsice_bal / zsoce_bal !! ice-ocean salinity ratio, Baltic case + + DO jn = jp_pcs0, jp_pcs1 + IF( trc_ice_ratio(jn) >= 0._wp ) zratio(jn,:) = trc_ice_ratio(jn) + IF( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) + IF( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp + END DO + + !------------------------------- + ! Sea ice tracer concentrations + !------------------------------- + DO jn = jp_pcs0, jp_pcs1 + !-- Everywhere but in the Baltic + IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron) + trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn) + ELSE ! prescribed concentration + trc_i(:,:,jn) = trc_ice_prescr(jn) + ENDIF + !-- Baltic + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron) + WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & + 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) + trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn) + END WHERE + ENDIF + ENDIF + ! + END DO ! jn + ! + END SUBROUTINE p4z_ice_ini + + SUBROUTINE p2z_ice_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_ice_ini *** + !! + !! ** Purpose : Initialisation of the LOBSTER biochemical model + !!---------------------------------------------------------------------- + END SUBROUTINE p2z_ice_ini + + + !!====================================================================== +END MODULE trcice_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/trcini_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/trcini_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c9a691cbac65d4cafef2f1c5f4ccd4298eef8a14 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/trcini_pisces.F90 @@ -0,0 +1,358 @@ +MODULE trcini_pisces + !!====================================================================== + !! *** MODULE trcini_pisces *** + !! TOP : initialisation of the PISCES biochemical model + !!====================================================================== + !! History : - ! 1988-07 (E. Maier-Reiner) Original code + !! - ! 1999-10 (O. Aumont, C. Le Quere) + !! - ! 2002 (O. Aumont) PISCES + !! 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcini.pisces.h90 + !! 3.5 ! 2012-05 (C. Ethe) Merge PISCES-LOBSTER + !!---------------------------------------------------------------------- + !! trc_ini_pisces : PISCES biochemical model initialisation + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE trcnam_pisces ! PISCES namelist + USE sms_pisces ! PISCES Source Minus Sink variables + USE sedini ! SEDIMENTS initialization routine + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ini_pisces ! called by trcini.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini_pisces.F90 10817 2019-03-29 17:23:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ini_pisces + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_pisces *** + !! + !! ** Purpose : Initialisation of the PISCES biochemical model + !!---------------------------------------------------------------------- + ! + CALL trc_nam_pisces + ! + IF( ln_p4z .OR. ln_p5z ) THEN ; CALL p4z_ini ! PISCES + ELSE ; CALL p2z_ini ! LOBSTER + ENDIF + + END SUBROUTINE trc_ini_pisces + + + SUBROUTINE p4z_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_ini *** + !! + !! ** Purpose : Initialisation of the PISCES biochemical model + !!---------------------------------------------------------------------- + USE p4zsms ! Main P4Z routine + USE p4zche ! Chemical model + USE p4zsink ! vertical flux of particulate matter due to sinking + USE p4zopt ! optical model + USE p4zsbc ! Boundary conditions + USE p4zfechem ! Iron chemistry + USE p4zrem ! Remineralisation of organic matter + USE p4zflx ! Gas exchange + USE p4zlim ! Co-limitations of differents nutrients + USE p4zprod ! Growth rate of the 2 phyto groups + USE p4zmicro ! Sources and sinks of microzooplankton + USE p4zmeso ! Sources and sinks of mesozooplankton + USE p4zmort ! Mortality terms for phytoplankton + USE p4zlys ! Calcite saturation + USE p4zsed ! Sedimentation & burial + USE p4zpoc ! Remineralization of organic particles + USE p4zligand ! Remineralization of organic ligands + USE p5zlim ! Co-limitations of differents nutrients + USE p5zprod ! Growth rate of the 2 phyto groups + USE p5zmicro ! Sources and sinks of microzooplankton + USE p5zmeso ! Sources and sinks of mesozooplankton + USE p5zmort ! Mortality terms for phytoplankton + ! + REAL(wp), SAVE :: sco2 = 2.312e-3_wp + REAL(wp), SAVE :: alka0 = 2.426e-3_wp + REAL(wp), SAVE :: oxyg0 = 177.6e-6_wp + REAL(wp), SAVE :: po4 = 2.165e-6_wp + REAL(wp), SAVE :: bioma0 = 1.000e-8_wp + REAL(wp), SAVE :: silic1 = 91.51e-6_wp + REAL(wp), SAVE :: no3 = 30.9e-6_wp * 7.625_wp + ! + INTEGER :: ji, jj, jk, jn, ierr + REAL(wp) :: zcaralk, zbicarb, zco3 + REAL(wp) :: ztmas, ztmas1 + CHARACTER(len = 20) :: cltra + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + IF( ln_p4z ) THEN + WRITE(numout,*) 'p4z_ini : PISCES biochemical model initialisation' + WRITE(numout,*) '~~~~~~~' + ELSE + WRITE(numout,*) 'p5z_ini : PISCES biochemical model initialisation' + WRITE(numout,*) '~~~~~~~ With variable stoichiometry' + ENDIF + ENDIF + ! + ! Allocate PISCES arrays + ierr = sms_pisces_alloc() + ierr = ierr + p4z_che_alloc() + ierr = ierr + p4z_sink_alloc() + ierr = ierr + p4z_opt_alloc() + ierr = ierr + p4z_flx_alloc() + ierr = ierr + p4z_sed_alloc() + ierr = ierr + p4z_lim_alloc() + IF( ln_p4z ) THEN + ierr = ierr + p4z_prod_alloc() + ELSE + ierr = ierr + p5z_lim_alloc() + ierr = ierr + p5z_prod_alloc() + ENDIF + ierr = ierr + p4z_rem_alloc() + ! + CALL mpp_sum( 'trcini_pisces', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'pisces_alloc: unable to allocate PISCES arrays' ) + ! + ryyss = nyear_len(1) * rday ! number of seconds per year + r1_ryyss = 1. / ryyss + ! + + ! assign an index in trc arrays for each prognostic variables + DO jn = 1, jptra + cltra = ctrcnm(jn) + IF( cltra == 'DIC' ) jpdic = jn !: dissolved inoganic carbon concentration + IF( cltra == 'Alkalini' ) jptal = jn !: total alkalinity + IF( cltra == 'O2' ) jpoxy = jn !: oxygen carbon concentration + IF( cltra == 'CaCO3' ) jpcal = jn !: calcite concentration + IF( cltra == 'PO4' ) jppo4 = jn !: phosphate concentration + IF( cltra == 'POC' ) jppoc = jn !: small particulate organic phosphate concentration + IF( cltra == 'Si' ) jpsil = jn !: silicate concentration + IF( cltra == 'PHY' ) jpphy = jn !: phytoplancton concentration + IF( cltra == 'ZOO' ) jpzoo = jn !: zooplancton concentration + IF( cltra == 'DOC' ) jpdoc = jn !: dissolved organic carbon concentration + IF( cltra == 'PHY2' ) jpdia = jn !: Diatoms Concentration + IF( cltra == 'ZOO2' ) jpmes = jn !: Mesozooplankton Concentration + IF( cltra == 'DSi' ) jpdsi = jn !: Diatoms Silicate Concentration + IF( cltra == 'Fer' ) jpfer = jn !: Iron Concentration + IF( cltra == 'BFe' ) jpbfe = jn !: Big iron particles Concentration + IF( cltra == 'GOC' ) jpgoc = jn !: Big particulate organic phosphate concentration + IF( cltra == 'SFe' ) jpsfe = jn !: Small iron particles Concentration + IF( cltra == 'DFe' ) jpdfe = jn !: Diatoms iron Concentration + IF( cltra == 'GSi' ) jpgsi = jn !: (big) Silicate Concentration + IF( cltra == 'NFe' ) jpnfe = jn !: Nano iron Concentration + IF( cltra == 'NCHL' ) jpnch = jn !: Nano Chlorophyll Concentration + IF( cltra == 'DCHL' ) jpdch = jn !: Diatoms Chlorophyll Concentration + IF( cltra == 'NO3' ) jpno3 = jn !: Nitrates Concentration + IF( cltra == 'NH4' ) jpnh4 = jn !: Ammonium Concentration + IF( cltra == 'DON' ) jpdon = jn !: Dissolved organic N Concentration + IF( cltra == 'DOP' ) jpdop = jn !: Dissolved organic P Concentration + IF( cltra == 'PON' ) jppon = jn !: Small Nitrogen particle Concentration + IF( cltra == 'POP' ) jppop = jn !: Small Phosphorus particle Concentration + IF( cltra == 'GON' ) jpgon = jn !: Big Nitrogen particles Concentration + IF( cltra == 'GOP' ) jpgop = jn !: Big Phosphorus Concentration + IF( cltra == 'PHYN' ) jpnph = jn !: Nanophytoplankton N biomass + IF( cltra == 'PHYP' ) jppph = jn !: Nanophytoplankton P biomass + IF( cltra == 'DIAN' ) jpndi = jn !: Diatoms N biomass + IF( cltra == 'DIAP' ) jppdi = jn !: Diatoms P biomass + IF( cltra == 'PIC' ) jppic = jn !: Picophytoplankton C biomass + IF( cltra == 'PICN' ) jpnpi = jn !: Picophytoplankton N biomass + IF( cltra == 'PICP' ) jpppi = jn !: Picophytoplankton P biomass + IF( cltra == 'PCHL' ) jppch = jn !: Diatoms Chlorophyll Concentration + IF( cltra == 'PFe' ) jppfe = jn !: Picophytoplankton Fe biomass + IF( cltra == 'LGW' ) jplgw = jn !: Weak ligands + END DO + + CALL p4z_sms_init ! Maint routine + ! + + ! Set biological ratios + ! --------------------- + rno3 = 16._wp / 122._wp + po4r = 1._wp / 122._wp + o2nit = 32._wp / 122._wp + o2ut = 133._wp / 122._wp + rdenit = ( ( o2ut + o2nit ) * 0.80 - rno3 - rno3 * 0.60 ) / rno3 + rdenita = 3._wp / 5._wp + IF( ln_p5z ) THEN + no3rat3 = no3rat3 / rno3 + po4rat3 = po4rat3 / po4r + ENDIF + + ! Initialization of tracer concentration in case of no restart + !-------------------------------------------------------------- + IF( .NOT.ln_rsttr ) THEN + trn(:,:,:,jpdic) = sco2 + trn(:,:,:,jpdoc) = bioma0 + trn(:,:,:,jptal) = alka0 + trn(:,:,:,jpoxy) = oxyg0 + trn(:,:,:,jpcal) = bioma0 + trn(:,:,:,jppo4) = po4 / po4r + trn(:,:,:,jppoc) = bioma0 + trn(:,:,:,jpgoc) = bioma0 + trn(:,:,:,jpbfe) = bioma0 * 5.e-6 + trn(:,:,:,jpsil) = silic1 + trn(:,:,:,jpdsi) = bioma0 * 0.15 + trn(:,:,:,jpgsi) = bioma0 * 5.e-6 + trn(:,:,:,jpphy) = bioma0 + trn(:,:,:,jpdia) = bioma0 + trn(:,:,:,jpzoo) = bioma0 + trn(:,:,:,jpmes) = bioma0 + trn(:,:,:,jpfer) = 0.6E-9 + trn(:,:,:,jpsfe) = bioma0 * 5.e-6 + trn(:,:,:,jpdfe) = bioma0 * 5.e-6 + trn(:,:,:,jpnfe) = bioma0 * 5.e-6 + trn(:,:,:,jpnch) = bioma0 * 12. / 55. + trn(:,:,:,jpdch) = bioma0 * 12. / 55. + trn(:,:,:,jpno3) = no3 + trn(:,:,:,jpnh4) = bioma0 + IF( ln_ligand) THEN + trn(:,:,:,jplgw) = 0.6E-9 + ENDIF + IF( ln_p5z ) THEN + trn(:,:,:,jpdon) = bioma0 + trn(:,:,:,jpdop) = bioma0 + trn(:,:,:,jppon) = bioma0 + trn(:,:,:,jppop) = bioma0 + trn(:,:,:,jpgon) = bioma0 + trn(:,:,:,jpgop) = bioma0 + trn(:,:,:,jpnph) = bioma0 + trn(:,:,:,jppph) = bioma0 + trn(:,:,:,jppic) = bioma0 + trn(:,:,:,jpnpi) = bioma0 + trn(:,:,:,jpppi) = bioma0 + trn(:,:,:,jpndi) = bioma0 + trn(:,:,:,jppdi) = bioma0 + trn(:,:,:,jppfe) = bioma0 * 5.e-6 + trn(:,:,:,jppch) = bioma0 * 12. / 55. + ENDIF + ! initialize the half saturation constant for silicate + ! ---------------------------------------------------- + xksi(:,:) = 2.e-6 + xksimax(:,:) = xksi(:,:) + IF( ln_p5z ) THEN + sized(:,:,:) = 1.0 + sizen(:,:,:) = 1.0 + sized(:,:,:) = 1.0 + ENDIF + END IF + + + CALL p4z_sink_init ! vertical flux of particulate organic matter + CALL p4z_opt_init ! Optic: PAR in the water column + IF( ln_p4z ) THEN + CALL p4z_lim_init ! co-limitations by the various nutrients + CALL p4z_prod_init ! phytoplankton growth rate over the global ocean. + ELSE + CALL p5z_lim_init ! co-limitations by the various nutrients + CALL p5z_prod_init ! phytoplankton growth rate over the global ocean. + ENDIF + CALL p4z_sbc_init ! boundary conditions + CALL p4z_fechem_init ! Iron chemistry + CALL p4z_rem_init ! remineralisation + CALL p4z_poc_init ! remineralisation of organic particles + IF( ln_ligand ) & + & CALL p4z_ligand_init ! remineralisation of organic ligands + + IF( ln_p4z ) THEN + CALL p4z_mort_init ! phytoplankton mortality + CALL p4z_micro_init ! microzooplankton + CALL p4z_meso_init ! mesozooplankton + ELSE + CALL p5z_mort_init ! phytoplankton mortality + CALL p5z_micro_init ! microzooplankton + CALL p5z_meso_init ! mesozooplankton + ENDIF + CALL p4z_lys_init ! calcite saturation + IF( .NOT.l_co2cpl ) & + & CALL p4z_flx_init ! gas exchange + + ! Initialization of the sediment model + IF( ln_sediment) CALL sed_init + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Initialization of PISCES tracers done' + IF(lwp) WRITE(numout,*) + ! + END SUBROUTINE p4z_ini + + + SUBROUTINE p2z_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE p2z_ini *** + !! + !! ** Purpose : Initialisation of the LOBSTER biochemical model + !!---------------------------------------------------------------------- + ! + USE p2zopt + USE p2zexp + USE p2zbio + USE p2zsed + ! + INTEGER :: ji, jj, jk, jn, ierr + CHARACTER(len = 10) :: cltra + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' p2z_ini : LOBSTER biochemical model initialisation' + IF(lwp) WRITE(numout,*) ' ~~~~~~~' + + ierr = sms_pisces_alloc() + ierr = ierr + p2z_exp_alloc() + ! + CALL mpp_sum( 'trcini_pisces', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'p2z_ini: unable to allocate LOBSTER arrays' ) + + DO jn = 1, jptra + cltra = ctrcnm(jn) + IF( cltra == 'DET' ) jpdet = jn !: detritus [mmoleN/m3] + IF( cltra == 'ZOO' ) jpzoo = jn !: zooplancton concentration [mmoleN/m3] + IF( cltra == 'PHY' ) jpphy = jn !: phytoplancton concentration [mmoleN/m3] + IF( cltra == 'NO3' ) jpno3 = jn !: nitrate concentration [mmoleN/m3] + IF( cltra == 'NH4' ) jpnh4 = jn !: ammonium concentration [mmoleN/m3] + IF( cltra == 'DOM' ) jpdom = jn !: dissolved organic matter [mmoleN/m3] + ENDDO + + jpkb = 10 ! last level where depth less than 200 m + DO jk = jpkm1, 1, -1 + IF( gdept_1d(jk) > 200. ) jpkb = jk + END DO + IF (lwp) WRITE(numout,*) + IF (lwp) WRITE(numout,*) ' first vertical layers where biology is active (200m depth ) ', jpkb + IF (lwp) WRITE(numout,*) + jpkbm1 = jpkb - 1 + ! + + + ! LOBSTER initialisation for GYRE : init NO3=f(density) by asklod AS Kremeur 2005-07 + ! ---------------------- + IF( .NOT. ln_rsttr ) THEN ! in case of no restart + trn(:,:,:,jpdet) = 0.1 * tmask(:,:,:) + trn(:,:,:,jpzoo) = 0.1 * tmask(:,:,:) + trn(:,:,:,jpnh4) = 0.1 * tmask(:,:,:) + trn(:,:,:,jpphy) = 0.1 * tmask(:,:,:) + trn(:,:,:,jpdom) = 1.0 * tmask(:,:,:) + WHERE( rhd(:,:,:) <= 24.5e-3 ) ; trn(:,:,:,jpno3) = 2._wp * tmask(:,:,:) + ELSE WHERE ; trn(:,:,:,jpno3) = ( 15.55 * ( rhd(:,:,:) * 1000. ) - 380.11 ) * tmask(:,:,:) + END WHERE + ENDIF + ! ! Namelist read + CALL p2z_opt_init ! Optics parameters + CALL p2z_sed_init ! sedimentation + CALL p2z_bio_init ! biology + CALL p2z_exp_init ! export + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Initialization of LOBSTER tracers done' + IF(lwp) WRITE(numout,*) + ! + END SUBROUTINE p2z_ini + + !!====================================================================== +END MODULE trcini_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/trcnam_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/trcnam_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3165ded6ea02f5acf29feae71d17573e153138d7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/trcnam_pisces.F90 @@ -0,0 +1,93 @@ +MODULE trcnam_pisces + !!====================================================================== + !! *** MODULE trcnam_pisces *** + !! TOP : initialisation of some run parameters for PISCES bio-model + !!====================================================================== + !! History : - ! 1999-10 (M.A. Foujols, M. Levy) original code + !! - ! 2000-01 (L. Bopp) hamocc3, p3zd + !! 1.0 ! 2003-08 (C. Ethe) module F90 + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcnam.pisces.h90 + !!---------------------------------------------------------------------- + !! trc_nam_pisces : PISCES model namelist read + !!---------------------------------------------------------------------- + USE oce_trc ! Ocean variables + USE par_trc ! TOP parameters + USE trc ! TOP variables + USE sms_pisces ! sms trends + USE trdtrc_oce + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_nam_pisces ! called by trcnam.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam_pisces.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_nam_pisces + !!---------------------------------------------------------------------- + !! *** trc_nam_pisces *** + !! + !! ** Purpose : read PISCES namelist + !! + !! ** input : file 'namelist.trc.sms' containing the following + !! namelist: natext, natbio, natsms + !!---------------------------------------------------------------------- + INTEGER :: jl, jn + INTEGER :: ios, ioptio ! Local integer + CHARACTER(LEN=20):: clname + !! + NAMELIST/nampismod/ln_p2z, ln_p4z, ln_p5z, ln_ligand, ln_sediment + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + clname = 'namelist_pisces' + + IF(lwp) WRITE(numout,*) 'trc_nam_pisces : read PISCES namelist' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' + CALL ctl_opn( numnatp_ref, TRIM( clname )//'_ref', 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numnatp_cfg, TRIM( clname )//'_cfg', 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + IF(lwm) CALL ctl_opn( numonp , 'output.namelist.pis' , 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + ! + REWIND( numnatp_ref ) ! Namelist nampisbio in reference namelist : Pisces variables + READ ( numnatp_ref, nampismod, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampismod in reference namelist' ) + REWIND( numnatp_cfg ) ! Namelist nampisbio in configuration namelist : Pisces variables + READ ( numnatp_cfg, nampismod, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nampismod in configuration namelist' ) + IF(lwm) WRITE( numonp, nampismod ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : nampismod ' + WRITE(numout,*) ' Flag to use LOBSTER model ln_p2z = ', ln_p2z + WRITE(numout,*) ' Flag to use PISCES standard model ln_p4z = ', ln_p4z + WRITE(numout,*) ' Flag to use PISCES quota model ln_p5z = ', ln_p5z + WRITE(numout,*) ' Flag to ligand ln_ligand = ', ln_ligand + WRITE(numout,*) ' Flag to use sediment ln_sediment = ', ln_sediment + ENDIF + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + IF( ln_p5z ) WRITE(numout,*) ' ==>>> PISCES QUOTA model is used' + IF( ln_p4z ) WRITE(numout,*) ' ==>>> PISCES STANDARD model is used' + IF( ln_p2z ) WRITE(numout,*) ' ==>>> LOBSTER model is used' + IF( ln_ligand ) WRITE(numout,*) ' ==>>> Compute remineralization/dissolution of organic ligands' + IF( ln_sediment ) WRITE(numout,*) ' ==>>> Sediment module is used' + ENDIF + + ioptio = 0 + IF( ln_p2z ) ioptio = ioptio + 1 + IF( ln_p4z ) ioptio = ioptio + 1 + IF( ln_p5z ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE PISCES model namelist nampismod' ) + ! + END SUBROUTINE trc_nam_pisces + + !!====================================================================== +END MODULE trcnam_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/trcsms_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/trcsms_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..07fe0961097514b9324eb0f89f622b4bd5904cd0 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/trcsms_pisces.F90 @@ -0,0 +1,47 @@ +MODULE trcsms_pisces + !!====================================================================== + !! *** MODULE trcsms_pisces *** + !! TOP : PISCES Source Minus Sink manager + !!====================================================================== + !! History : 1.0 ! 2004-03 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !!---------------------------------------------------------------------- + !! trcsms_pisces : Time loop of passive tracers sms + !!---------------------------------------------------------------------- + USE par_pisces + USE sms_pisces + USE p4zsms + USE p2zsms + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms_pisces ! called in trcsms.F90 + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms_pisces.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms_pisces( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_sms_pisces *** + !! + !! ** Purpose : Managment of the call to Biological sources and sinks + !! routines of PISCES or LOBSTER bio-model + !! + !!--------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !!--------------------------------------------------------------------- + ! + IF( ln_p4z .OR. ln_p5z ) THEN ; CALL p4z_sms( kt ) ! PISCES + ELSE ; CALL p2z_sms( kt ) ! LOBSTER + ENDIF + + ! + END SUBROUTINE trc_sms_pisces + + !!====================================================================== +END MODULE trcsms_pisces diff --git a/V4.0/nemo_sources/src/TOP/PISCES/trcwri_pisces.F90 b/V4.0/nemo_sources/src/TOP/PISCES/trcwri_pisces.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1685be7a04a3dd92b1e0bba2edca967da966cf8f --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/PISCES/trcwri_pisces.F90 @@ -0,0 +1,103 @@ +MODULE trcwri_pisces + !!====================================================================== + !! *** MODULE trcwri *** + !! PISCES : Output of PISCES tracers + !!====================================================================== + !! History : 1.0 ! 2009-05 (C. Ethe) Original code + !!---------------------------------------------------------------------- +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! trc_wri_pisces : outputs of concentration fields + !!---------------------------------------------------------------------- + USE trc ! passive tracers common variables + USE sms_pisces ! PISCES variables + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri_pisces + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_pisces.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_wri_pisces + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri_trc *** + !! + !! ** Purpose : output passive tracers fields + !!--------------------------------------------------------------------- + CHARACTER (len=20) :: cltra + REAL(wp) :: zfact + INTEGER :: ji, jj, jk, jn + REAL(wp), DIMENSION(jpi,jpj) :: zdic, zo2min, zdepo2min + !!--------------------------------------------------------------------- + + ! write the tracer concentrations in the file + ! --------------------------------------- + IF( ln_p2z ) THEN + DO jn = jp_pcs0, jp_pcs1 + cltra = TRIM( ctrcnm(jn) ) ! short title for tracer + CALL iom_put( cltra, trn(:,:,:,jn) ) + END DO + ELSE + DO jn = jp_pcs0, jp_pcs1 + zfact = 1.0e+6 + IF( jn == jpno3 .OR. jn == jpnh4 ) zfact = rno3 * 1.0e+6 + IF( jn == jppo4 ) zfact = po4r * 1.0e+6 + cltra = TRIM( ctrcnm(jn) ) ! short title for tracer + IF( iom_use( cltra ) ) CALL iom_put( cltra, trn(:,:,:,jn) * zfact ) + END DO + + IF( iom_use( "INTDIC" ) ) THEN ! DIC content in kg/m2 + zdic(:,:) = 0. + DO jk = 1, jpkm1 + zdic(:,:) = zdic(:,:) + trn(:,:,jk,jpdic) * e3t_n(:,:,jk) * tmask(:,:,jk) * 12. + ENDDO + CALL iom_put( 'INTDIC', zdic ) + ENDIF + ! + IF( iom_use( "O2MIN" ) .OR. iom_use ( "ZO2MIN" ) ) THEN ! Oxygen minimum concentration and depth + zo2min (:,:) = trn(:,:,1,jpoxy) * tmask(:,:,1) + zdepo2min(:,:) = gdepw_n(:,:,1) * tmask(:,:,1) + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,jk) == 1 ) then + IF( trn(ji,jj,jk,jpoxy) < zo2min(ji,jj) ) then + zo2min (ji,jj) = trn(ji,jj,jk,jpoxy) + zdepo2min(ji,jj) = gdepw_n(ji,jj,jk) + ENDIF + ENDIF + END DO + END DO + END DO + ! + CALL iom_put('O2MIN' , zo2min ) ! oxygen minimum concentration + CALL iom_put('ZO2MIN', zdepo2min ) ! depth of oxygen minimum concentration + ! + ENDIF + ENDIF + ! + END SUBROUTINE trc_wri_pisces + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- + PUBLIC trc_wri_pisces +CONTAINS + SUBROUTINE trc_wri_pisces ! Empty routine + END SUBROUTINE trc_wri_pisces +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri_pisces.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcwri_pisces diff --git a/V4.0/nemo_sources/src/TOP/README.rst b/V4.0/nemo_sources/src/TOP/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..a502c3b1023a98c9eee022c8a7caea3d62850e6c --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/README.rst @@ -0,0 +1,392 @@ +*************** +Oceanic tracers +*************** + +.. todo:: + + + +.. contents:: + :local: + +TOP (Tracers in the Ocean Paradigm) is the NEMO hardwired interface toward +biogeochemical models and provide the physical constraints/boundaries for oceanic tracers. +It consists of a modular framework to handle multiple ocean tracers, +including also a variety of built-in modules. + +This component of the NEMO framework allows one to exploit available modules (see below) and +further develop a range of applications, spanning from the implementation of a dye passive tracer to +evaluate dispersion processes (by means of MY_TRC), track water masses age (AGE module), +assess the ocean interior penetration of persistent chemical compounds +(e.g., gases like CFC or even PCBs), up to the full set of equations involving +marine biogeochemical cycles. + +Structure +========= + +TOP interface has the following location in the source code :file:`./src/TOP` and +the following modules are available: + +:file:`TRP` + Interface to NEMO physical core for computing tracers transport + +:file:`CFC` + Inert carbon tracers (CFC11,CFC12,SF6) + +:file:`C14` + Radiocarbon passive tracer + +:file:`AGE` + Water age tracking + +:file:`MY_TRC` + Template for creation of new modules and external BGC models coupling + +:file:`PISCES` + Built in BGC model. See :cite:`gmd-8-2465-2015` for a throughout description. + +The usage of TOP is activated +*i)* by including in the configuration definition the component ``TOP`` and +*ii)* by adding the macro ``key_top`` in the configuration CPP file +(see for more details :forge:`"Learn more about the model" <wiki/Users>`). + +As an example, the user can refer to already available configurations in the code, +``GYRE_PISCES`` being the NEMO biogeochemical demonstrator and +``GYRE_BFM`` to see the required configuration elements to couple with an external biogeochemical model +(see also Section 4) . + +Note that, since version 4.0, +TOP interface core functionalities are activated by means of logical keys and +all submodules preprocessing macros from previous versions were removed. + +Here below the list of preprocessing keys that applies to the TOP interface (beside ``key_top``): + +``key_iomput`` + use XIOS I/O + +``key_agrif`` + enable AGRIF coupling + +``key_trdtrc`` & ``key_trdmxl_trc`` + trend computation for tracers + +Synthetic Workflow +================== + +A synthetic description of the TOP interface workflow is given below to +summarize the steps involved in the computation of biogeochemical and physical trends and +their time integration and outputs, +by reporting also the principal Fortran subroutine herein involved. + +Model initialization (:file:`./src/OCE/nemogcm.F90`) +---------------------------------------------------- + +Call to ``trc_init`` subroutine (:file:`./src/TOP/trcini.F90`) to initialize TOP. + +.. literalinclude:: ../../../src/TOP/trcini.F90 + :language: fortran + :lines: 41-86 + :emphasize-lines: 21,30-32,38-40 + :caption: ``trc_init`` subroutine + +Time marching procedure (:file:`./src/OCE/step.F90`) +---------------------------------------------------- + +Call to ``trc_stp`` subroutine (:file:`./src/TOP/trcstp.F90`) to compute/update passive tracers. + +.. literalinclude:: ../../../src/TOP/trcstp.F90 + :language: fortran + :lines: 46-125 + :emphasize-lines: 42,55-57 + :caption: ``trc_stp`` subroutine + +BGC trends computation for each submodule (:file:`./src/TOP/trcsms.F90`) +------------------------------------------------------------------------ + +.. literalinclude:: ../../../src/TOP/trcsms.F90 + :language: fortran + :lines: 21 + :caption: :file:`trcsms` snippet + +Physical trends computation (:file:`./src/TOP/TRP/trctrp.F90`) +-------------------------------------------------------------- + +.. literalinclude:: ../../../src/TOP/TRP/trctrp.F90 + :language: fortran + :lines: 46-95 + :emphasize-lines: 17,21,29,33-35 + :caption: ``trc_trp`` subroutine + +Namelists walkthrough +===================== + +:file:`namelist_top` +-------------------- + +Here below are listed the features/options of the TOP interface accessible through +the :file:`namelist_top_ref` and modifiable by means of :file:`namelist_top_cfg` +(as for NEMO physical ones). + +Note that ``##`` is used to refer to a number in an array field. + +.. literalinclude:: ../../namelists/namtrc_run + :language: fortran + +.. literalinclude:: ../../namelists/namtrc + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_dta + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_adv + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_ldf + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_rad + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_snk + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_dmp + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_ice + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_trd + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_bc + :language: fortran + +.. literalinclude:: ../../namelists/namtrc_bdy + :language: fortran + +.. literalinclude:: ../../namelists/namage + :language: fortran + +Two main types of data structure are used within TOP interface +to initialize tracer properties (1) and +to provide related initial and boundary conditions (2). + +1. TOP tracers initialization: ``sn_tracer`` (``&namtrc``) +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Beside providing name and metadata for tracers, +here are also defined the use of initial (``sn_tracer%llinit``) and +boundary (``sn_tracer%llsbc, sn_tracer%llcbc, sn_tracer%llobc``) conditions. + +In the following, an example of the full structure definition is given for +two idealized tracers both with initial conditions given, +while the first has only surface boundary forcing and +the second both surface and coastal forcings: + +.. code-block:: fortran + + ! ! name ! title of the field ! units ! initial data ! sbc ! cbc ! obc ! + sn_tracer(1) = 'TRC1' , 'Tracer 1 Concentration ', ' - ' , .true. , .true., .false., .true. + sn_tracer(2) = 'TRC2 ' , 'Tracer 2 Concentration ', ' - ' , .true. , .true., .true. , .false. + +As tracers in BGC models are increasingly growing, +the same structure can be written also in a more compact and readable way: + +.. code-block:: fortran + + ! ! name ! title of the field ! units ! initial data ! + sn_tracer(1) = 'TRC1' , 'Tracer 1 Concentration ', ' - ' , .true. + sn_tracer(2) = 'TRC2 ' , 'Tracer 2 Concentration ', ' - ' , .true. + ! sbc + sn_tracer(1)%llsbc = .true. + sn_tracer(2)%llsbc = .true. + ! cbc + sn_tracer(2)%llcbc = .true. + +The data structure is internally initialized by code with dummy names and +all initialization/forcing logical fields set to ``.false.`` . + +2. Structures to read input initial and boundary conditions: ``&namtrc_dta`` (``sn_trcdta``), ``&namtrc_bc`` (``sn_trcsbc`` / ``sn_trccbc`` / ``sn_trcobc``) +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The overall data structure (Fortran type) is based on the general one defined for NEMO core in the SBC component +(see details in ``SBC`` Chapter of :doc:`Reference Manual <cite>` on Input Data specification). + +Input fields are prescribed within ``&namtrc_dta`` (with ``sn_trcdta`` structure), +while Boundary Conditions are applied to the model by means of ``&namtrc_bc``, +with dedicated structure fields for surface (``sn_trcsbc``), riverine (``sn_trccbc``), and +lateral open (``sn_trcobc``) boundaries. + +The following example illustrates the data structure in the case of initial condition for +a single tracer contained in the file named :file:`tracer_1_data.nc` +(``.nc`` is implicitly assumed in namelist filename), +with a doubled initial value, and located in the :file:`usr/work/model/inputdata` folder: + +.. code-block:: fortran + + ! ! 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) = 'tracer_1_data' , -12 , 'TRC1' , .false. , .true. , 'yearly' , '' , '' , '' + rf_trfac(1) = 2.0 + cn_dir = 'usr/work/model/inputdata/' + +Note that, the Lateral Open Boundaries conditions are applied on +the segments defined for the physical core of NEMO +(see ``BDY`` description in the :doc:`Reference Manual <cite>`). + +:file:`namelist_trc` +-------------------- + +Here below the description of :file:`namelist_trc_ref` used to handle Carbon tracers modules, +namely CFC and C14. + +.. literalinclude:: ../../../cfgs/SHARED/namelist_trc_ref + :language: fortran + :lines: 7,17,26,34 + :caption: :file:`namelist_trc_ref` snippet + +``MY_TRC`` interface for coupling external BGC models +===================================================== + +The generalized interface is pivoted on MY_TRC module that contains template files to +build the coupling between +NEMO and any external BGC model. + +The call to MY_TRC is activated by setting ``ln_my_trc = .true.`` (in ``&namtrc``) + +The following 6 fortran files are available in MY_TRC with the specific purposes here described. + +:file:`par_my_trc.F90` + This module allows to define additional arrays and public variables to + be used within the MY_TRC interface + +:file:`trcini_my_trc.F90` + Here are initialized user defined namelists and + the call to the external BGC model initialization procedures to populate general tracer array + (``trn`` and ``trb``). + Here are also likely to be defined support arrays related to system metrics that + could be needed by the BGC model. + +:file:`trcnam_my_trc.F90` + This routine is called at the beginning of ``trcini_my_trc`` and + should contain the initialization of additional namelists for the BGC model or user-defined code. + +:file:`trcsms_my_trc.F90` + The routine performs the call to Boundary Conditions and its main purpose is to + contain the Source-Minus-Sinks terms due to the biogeochemical processes of the external model. + Be aware that lateral boundary conditions are applied in trcnxt routine. + + .. warning:: + The routines to compute the light penetration along the water column and + the tracer vertical sinking should be defined/called in here, + as generalized modules are still missing in the code. + +:file:`trcice_my_trc.F90` + Here it is possible to prescribe the tracers concentrations in the sea-ice that + will be used as boundary conditions when ice melting occurs (``nn_ice_tr = 1`` in ``&namtrc_ice``). + See e.g. the correspondent PISCES subroutine. + +:file:`trcwri_my_trc.F90` + This routine performs the output of the model tracers (only those defined in ``&namtrc``) using + IOM module (see chapter “Output and Diagnostics” in the :doc:`Reference Manual <cite>`). + It is possible to place here the output of additional variables produced by the model, + if not done elsewhere in the code, using the call to ``iom_put``. + +Coupling an external BGC model using NEMO framework +=================================================== + +The coupling with an external BGC model through the NEMO compilation framework can be achieved in +different ways according to the degree of coding complexity of the Biogeochemical model, like e.g., +the whole code is made only by one file or +it has multiple modules and interfaces spread across several subfolders. + +Beside the 6 core files of MY_TRC module, let’s assume an external BGC model named *MYBGC* and +constituted by a rather essential coding structure, likely few Fortran files. +The new coupled configuration name is *NEMO_MYBGC*. + +The best solution is to have all files (the modified ``MY_TRC`` routines and the BGC model ones) +placed in a unique folder with root ``MYBGCPATH`` and +to use the makenemo external readdressing of ``MY_SRC`` folder. + +The coupled configuration listed in :file:`work_cfgs.txt` will look like + +:: + + NEMO_MYBGC OCE TOP + +and the related ``cpp_MYBGC.fcm`` content will be + +.. code-block:: perl + + bld::tool::fppkeys key_iomput key_mpp_mpi key_top + +the compilation with :file:`makenemo` will be executed through the following syntax + +.. code-block:: console + + $ makenemo -n 'NEMO_MYBGC' -m '<arch_my_machine>' -j 8 -e '<MYBGCPATH>' + +The makenemo feature ``-e`` was introduced to +readdress at compilation time the standard MY_SRC folder (usually found in NEMO configurations) with +a user defined external one. + +The compilation of more articulated BGC model code & infrastructure, +like in the case of BFM (|BFM man|_), requires some additional features. + +As before, let’s assume a coupled configuration name *NEMO_MYBGC*, +but in this case MYBGC model root becomes :file:`MYBGC` path that +contains 4 different subfolders for biogeochemistry, +named :file:`initialization`, :file:`pelagic`, and :file:`benthic`, +and a separate one named :file:`nemo_coupling` including the modified `MY_SRC` routines. +The latter folder containing the modified NEMO coupling interface will be still linked using +the makenemo ``-e`` option. + +In order to include the BGC model subfolders in the compilation of NEMO code, +it will be necessary to extend the configuration :file:`cpp_NEMO_MYBGC.fcm` file to include the specific paths of :file:`MYBGC` folders, as in the following example + +.. code-block:: perl + + bld::tool::fppkeys key_iomput key_mpp_mpi key_top + + src::MYBGC::initialization <MYBGCPATH>/initialization + src::MYBGC::pelagic <MYBGCPATH>/pelagic + src::MYBGC::benthic <MYBGCPATH>/benthic + + bld::pp::MYBGC 1 + bld::tool::fppflags::MYBGC %FPPFLAGS + bld::tool::fppkeys %bld::tool::fppkeys MYBGC_MACROS + +where *MYBGC_MACROS* is the space delimited list of macros used in *MYBGC* model for +selecting/excluding specific parts of the code. +The BGC model code will be preprocessed in the configuration :file:`BLD` folder as for NEMO, +but with an independent path, like :file:`NEMO_MYBGC/BLD/MYBGC/<subforlders>`. + +The compilation will be performed similarly to in the previous case with the following + +.. code-block:: console + + $ makenemo -n 'NEMO_MYBGC' -m '<arch_my_machine>' -j 8 -e '<MYBGCPATH>/nemo_coupling' + +.. note:: + The additional lines specific for the BGC model source and build paths can be written into + a separate file, e.g. named :file:`MYBGC.fcm`, + and then simply included in the :file:`cpp_NEMO_MYBGC.fcm` as follow + + .. code-block:: perl + + bld::tool::fppkeys key_zdftke key_dynspg_ts key_iomput key_mpp_mpi key_top + inc <MYBGCPATH>/MYBGC.fcm + + This will enable a more portable compilation structure for all MYBGC related configurations. + +.. warning:: + The coupling interface contained in :file:`nemo_coupling` cannot be added using the FCM syntax, + as the same files already exists in NEMO and they are overridden only with + the readdressing of MY_SRC contents to avoid compilation conflicts due to duplicate routines. + +All modifications illustrated above, can be easily implemented using shell or python scripting +to edit the NEMO configuration :file:`CPP.fcm` file and +to create the BGC model specific FCM compilation file with code paths. + +.. |BFM man| replace:: BFM-NEMO coupling manual diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcadv.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcadv.F90 new file mode 100644 index 0000000000000000000000000000000000000000..93f8a7f851d6e04b0967cb142f602f5d200bbda8 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcadv.F90 @@ -0,0 +1,243 @@ +MODULE trcadv + !!============================================================================== + !! *** MODULE trcadv *** + !! Ocean passive tracers: advection trend + !!============================================================================== + !! History : 2.0 ! 2005-11 (G. Madec) Original code + !! 3.0 ! 2010-06 (C. Ethe) Adapted to passive tracers + !! 3.7 ! 2014-05 (G. Madec, C. Ethe) Add 2nd/4th order cases for CEN and FCT schemes + !! 4.0 ! 2017-09 (G. Madec) remove vertical time-splitting option + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_adv : compute ocean tracer advection trend + !! trc_adv_ini : control the different options of advection scheme + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers + USE trc ! ocean passive tracers variables + 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 ! ML eddy induced transport (tra_adv_mle routine) + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + ! + USE prtctl_trc ! control print + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_adv ! called by trctrp.F90 + PUBLIC trc_adv_ini ! called by trcini.F90 + + ! !!* Namelist namtrc_adv * + LOGICAL :: ln_trcadv_OFF ! no advection on passive tracers + LOGICAL :: ln_trcadv_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_trcadv_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_trcadv_mus ! MUSCL scheme flag + LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths + LOGICAL :: ln_trcadv_ubs ! UBS scheme flag + INTEGER :: nn_ubs_v ! =2/4 : vertical choice of the order of UBS scheme + LOGICAL :: ln_trcadv_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/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcadv.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_adv( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_adv *** + !! + !! ** Purpose : compute the ocean tracer advection trend. + !! + !! ** Method : - Update after tracers (tra) with the advection term following nadv + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: jk ! dummy loop index + CHARACTER (len=22) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! effective velocity + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_adv') + ! + ! !== effective transport ==! + IF( l_offline ) THEN + zun(:,:,:) = un(:,:,:) ! already in (un,vn,wn) + zvn(:,:,:) = vn(:,:,:) + zwn(:,:,:) = wn(:,:,:) + ELSE ! build the 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 + 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 + ! + IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & + & CALL ldf_eiv_trp( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the eiv transport + ! + IF( ln_mle ) CALL tra_mle_trp( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the mle transport + ! + ENDIF + ! + SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! + ! + CASE ( np_CEN ) ! Centered : 2nd / 4th order + CALL tra_adv_cen( kt, nittrc000,'TRC', zun, zvn, zwn , trn, tra, jptra, nn_cen_h, nn_cen_v ) + CASE ( np_FCT ) ! FCT : 2nd / 4th order + CALL tra_adv_fct( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra, nn_fct_h, nn_fct_v ) + CASE ( np_MUS ) ! MUSCL + CALL tra_adv_mus( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, tra, jptra , ln_mus_ups ) + CASE ( np_UBS ) ! UBS + CALL tra_adv_ubs( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra , nn_ubs_v ) + CASE ( np_QCK ) ! QUICKEST + CALL tra_adv_qck( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra ) + ! + END SELECT + ! + IF( ln_ctl ) THEN !== print mean trends (used for debugging) + WRITE(charout, FMT="('adv ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + END IF + ! + IF( ln_timing ) CALL timing_stop('trc_adv') + ! + END SUBROUTINE trc_adv + + + SUBROUTINE trc_adv_ini + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_adv_ini *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! passive tracer advection schemes and set nadv + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! Local integer + !! + NAMELIST/namtrc_adv/ ln_trcadv_OFF, & ! No advection + & ln_trcadv_cen, nn_cen_h, nn_cen_v, & ! CEN + & ln_trcadv_fct, nn_fct_h, nn_fct_v, & ! FCT + & ln_trcadv_mus, ln_mus_ups, & ! MUSCL + & ln_trcadv_ubs, nn_ubs_v, & ! UBS + & ln_trcadv_qck ! QCK + !!---------------------------------------------------------------------- + ! + ! !== Namelist ==! + REWIND( numnat_ref ) ! namtrc_adv in reference namelist + READ ( numnat_ref, namtrc_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_adv in reference namelist' ) + REWIND( numnat_cfg ) ! namtrc_adv in configuration namelist + READ ( numnat_cfg, namtrc_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_adv in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_adv ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'trc_adv_ini : choice/control of the tracer advection scheme' + WRITE(numout,*) '~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtrc_adv : chose a advection scheme for tracers' + WRITE(numout,*) ' No advection on passive tracers ln_trcadv_OFF = ', ln_trcadv_OFF + WRITE(numout,*) ' centered scheme ln_trcadv_cen = ', ln_trcadv_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_trcadv_fct = ', ln_trcadv_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_trcadv_mus = ', ln_trcadv_mus + WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups + WRITE(numout,*) ' UBS scheme ln_trcadv_ubs = ', ln_trcadv_ubs + WRITE(numout,*) ' vertical 2nd/4th order nn_ubs_v = ', nn_ubs_v + WRITE(numout,*) ' QUICKEST scheme ln_trcadv_qck = ', ln_trcadv_qck + ENDIF + ! + ! !== Parameter control & set nadv ==! + ioptio = 0 + IF( ln_trcadv_OFF ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF + IF( ln_trcadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF + IF( ln_trcadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF + IF( ln_trcadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF + IF( ln_trcadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF + IF( ln_trcadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'trc_adv_ini: Choose ONE advection option in namelist namtrc_adv' ) + ! + IF( ln_trcadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & + .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 ) ) THEN + CALL ctl_stop( 'trc_adv_ini: CEN scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_trcadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 ) & + .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 ) ) THEN + CALL ctl_stop( 'trc_adv_ini: FCT scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_trcadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN + CALL ctl_stop( 'trc_adv_ini: UBS scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_trcadv_ubs .AND. nn_ubs_v == 4 ) THEN + CALL ctl_warn( 'trc_adv_ini: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' ) + ENDIF + IF( ln_isfcav ) THEN ! ice-shelf cavities + IF( ln_trcadv_cen .AND. nn_cen_v == 4 .OR. & ! NO 4th order with ISF + & ln_trcadv_fct .AND. nn_fct_v == 4 ) CALL ctl_stop( 'tra_adv_ini: 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 passive tracer 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 + ! + END SUBROUTINE trc_adv_ini + +#endif + + !!====================================================================== +END MODULE trcadv diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcbbl.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcbbl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a5698d8ace3050f05faaecf09f57b8f6822abbc3 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcbbl.F90 @@ -0,0 +1,102 @@ +MODULE trcbbl + !!====================================================================== + !! *** MODULE trcbbl *** + !! Ocean passive tracers 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 + !! 4.0 ! 2017-04 (G. Madec) ln_trabbl namelist variable instead of a CPP key + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers variables + USE trc ! ocean passive tracers variables + USE trd_oce ! trends: ocean variables + USE trdtra ! tracer trends + USE trabbl ! bottom boundary layer + USE prtctl_trc ! Print control for debbuging + + PUBLIC trc_bbl ! routine called by trctrp.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcbbl.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_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. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step + INTEGER :: jn ! loop index + CHARACTER (len=22) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrtrd + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_bbl') + ! + IF( .NOT. l_offline .AND. nn_dttrc == 1 ) THEN + CALL bbl( kt, nittrc000, 'TRC' ) ! Online coupling with dynamics : Computation of bbl coef and bbl transport + l_bbl = .FALSE. ! Offline coupling with dynamics : Read bbl coef and bbl transport from input files + ENDIF + + IF( l_trdtrc ) THEN + ALLOCATE( ztrtrd(jpi,jpj,jpk,jptra) ) ! temporary save of trends + ztrtrd(:,:,:,:) = tra(:,:,:,:) + ENDIF + + !* Diffusive bbl : + IF( nn_bbl_ldf == 1 ) THEN + ! + CALL tra_bbl_dif( trb, tra, jptra ) + IF( ln_ctl ) THEN + WRITE(charout, FMT="(' bbl_dif')") ; CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + ! + ENDIF + + !* Advective bbl : bbl upstream advective trends added to the tracer trends + IF( nn_bbl_adv /= 0 ) THEN + ! + CALL tra_bbl_adv( trb, tra, jptra ) + IF( ln_ctl ) THEN + WRITE(charout, FMT="(' bbl_adv')") ; CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + ! + ENDIF + + IF( l_trdtrc ) THEN ! save the horizontal diffusive trends for further diagnostics + DO jn = 1, jptra + ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) + CALL trd_tra( kt, 'TRC', jn, jptra_bbl, ztrtrd(:,:,:,jn) ) + END DO + DEALLOCATE( ztrtrd ) ! temporary save of trends + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_bbl') + ! + END SUBROUTINE trc_bbl + +#endif + + !!====================================================================== +END MODULE trcbbl diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcdmp.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcdmp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7aeb2edde03ec26fb964dd2a8c8346e9d28cf002 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcdmp.F90 @@ -0,0 +1,386 @@ +MODULE trcdmp + !!====================================================================== + !! *** MODULE trcdmp *** + !! Ocean physics: internal restoring trend on passive tracers + !!====================================================================== + !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code + !! ! 1996-01 (G. Madec) statement function for e3 + !! ! 1997-05 (H. Loukos) adapted for passive tracers + !! NEMO 9.0 ! 2004-03 (C. Ethe) free form + modules + !! 3.2 ! 2007-02 (C. Deltel) Diagnose ML trends for passive tracers + !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! trc_dmp : update the tracer trend with the internal damping + !! trc_dmp_init : initialization, namlist read, parameters control + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and tracers variables + USE trc ! ocean passive tracers variables + USE trcdta + USE tradmp + USE trdtra + USE trd_oce + ! + USE iom + USE prtctl_trc ! Print control for debbuging + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_dmp + PUBLIC trc_dmp_clo + PUBLIC trc_dmp_alloc + PUBLIC trc_dmp_ini + + INTEGER , PUBLIC :: nn_zdmp_tr !: = 0/1/2 flag for damping in the mixed layer + CHARACTER(LEN=200) , PUBLIC :: cn_resto_tr !: File containing restoration coefficient + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: restotr ! restoring coeff. on tracers (s-1) + + INTEGER, PARAMETER :: npncts = 8 ! number of closed sea + INTEGER, DIMENSION(npncts) :: nctsi1, nctsj1 ! south-west closed sea limits (i,j) + INTEGER, DIMENSION(npncts) :: nctsi2, nctsj2 ! north-east closed sea limits (i,j) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcdmp.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_dmp_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( restotr(jpi,jpj,jpk) , STAT=trc_dmp_alloc ) + ! + IF( trc_dmp_alloc /= 0 ) CALL ctl_warn('trc_dmp_alloc: failed to allocate array') + ! + END FUNCTION trc_dmp_alloc + + + SUBROUTINE trc_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp *** + !! + !! ** Purpose : Compute the passive 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 trdta computed + !! and add to the general tracer trends: + !! trn = tra + restotr * (trdta - trb) + !! The trend is computed either throughout the water column + !! (nlmdmptr=0) or in area of weak vertical mixing (nlmdmptr=1) or + !! below the well mixed layer (nlmdmptr=2) + !! + !! ** Action : - update the tracer trends tra with the newtonian + !! damping trends. + !! - save the trends ('key_trdmxl_trc') + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jn, jl ! dummy loop indices + CHARACTER (len=22) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrtrd + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_dmp') + ! + IF( l_trdtrc ) ALLOCATE( ztrtrd(jpi,jpj,jpk) ) ! temporary save of trends + ! + IF( nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping + ! + ALLOCATE( ztrcdta(jpi,jpj,jpk) ) ! Memory allocation + ! ! =========== + DO jn = 1, jptra ! tracer loop + ! ! =========== + IF( l_trdtrc ) ztrtrd(:,:,:) = tra(:,:,:,jn) ! save trends + ! + IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file + ! + jl = n_trc_index(jn) + CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 + ! + SELECT CASE ( nn_zdmp_tr ) + ! + CASE( 0 ) !== newtonian damping throughout the water column ==! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - trb(ji,jj,jk,jn) ) + 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 + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - trb(ji,jj,jk,jn) ) + 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 + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - trb(ji,jj,jk,jn) ) + END IF + END DO + END DO + END DO + ! + END SELECT + ! + ENDIF + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) + CALL trd_tra( kt, 'TRC', jn, jptra_dmp, ztrtrd ) + END IF + ! ! =========== + END DO ! tracer loop + ! ! =========== + DEALLOCATE( ztrcdta ) + ENDIF + ! + IF( l_trdtrc ) DEALLOCATE( ztrtrd ) + ! ! print mean trends (used for debugging) + IF( ln_ctl ) THEN + WRITE(charout, FMT="('dmp ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_dmp') + ! + END SUBROUTINE trc_dmp + + + SUBROUTINE trc_dmp_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_ini *** + !! + !! ** Purpose : Initialization for the newtonian damping + !! + !! ** Method : read the nammbf namelist and check the parameters + !! called by trc_dmp at the first timestep (nittrc000) + !!---------------------------------------------------------------------- + INTEGER :: ios, imask ! local integers + !! + NAMELIST/namtrc_dmp/ nn_zdmp_tr , cn_resto_tr + !!---------------------------------------------------------------------- + ! + REWIND( numnat_ref ) ! Namelist namtrc_dmp in reference namelist : Passive tracers newtonian damping + READ ( numnat_ref, namtrc_dmp, IOSTAT = ios, ERR = 909) +909 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_dmp in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc_dmp in configuration namelist : Passive tracers newtonian damping + READ ( numnat_cfg, namtrc_dmp, IOSTAT = ios, ERR = 910) +910 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_dmp in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_dmp ) + + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'trc_dmp : Passive tracers newtonian damping' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Namelist namtrc_dmp : set damping parameter' + WRITE(numout,*) ' mixed layer damping option nn_zdmp_tr = ', nn_zdmp_tr, '(zoom: forced to 0)' + WRITE(numout,*) ' Restoration coeff file cn_resto_tr = ', cn_resto_tr + ENDIF + ! ! Allocate arrays + IF( trc_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_dmp_ini: unable to allocate arrays' ) + ! + SELECT CASE ( nn_zdmp_tr ) + CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' ===>> tracer damping throughout the water column' + CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' ===>> no tracer damping in the turbocline (avt > 5 cm2/s)' + CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' ===>> no tracer damping in the mixed layer' + CASE DEFAULT + WRITE(ctmp1,*) 'bad flag value for nn_zdmp_tr = ', nn_zdmp_tr + CALL ctl_stop(ctmp1) + END SELECT + + IF( .NOT.lk_c1d ) THEN + IF( .NOT.ln_tradmp ) & + & CALL ctl_stop( 'passive tracer damping need ln_tradmp to compute damping coef.' ) + ! + ! ! Read damping coefficients from file + !Read in mask from file + CALL iom_open ( cn_resto_tr, imask) + CALL iom_get ( imask, jpdom_autoglo, 'resto', restotr) + CALL iom_close( imask ) + ! + ENDIF + ! + END SUBROUTINE trc_dmp_ini + + + SUBROUTINE trc_dmp_clo( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_dmp_clo *** + !! + !! ** Purpose : Closed sea domain initialization + !! + !! ** Method : if a closed sea is located only in a model grid point + !! we restore to initial data + !! + !! ** Action : nctsi1(), nctsj1() : south-west closed sea limits (i,j) + !! nctsi2(), nctsj2() : north-east Closed sea limits (i,j) + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji , jj, jk, jn, jl, jc ! dummy loop indicesa + INTEGER :: isrow ! local index + REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace + !!---------------------------------------------------------------------- + + IF( kt == nit000 ) THEN + ! initial values + nctsi1(:) = 1 ; nctsi2(:) = 1 + nctsj1(:) = 1 ; nctsj2(:) = 1 + + ! set the closed seas (in data domain indices) + ! ------------------- + + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA") THEN + ! + SELECT CASE ( nn_cfg ) + ! ! ======================= + CASE ( 1 ) ! eORCA_R1 configuration + ! ! ======================= + isrow = 332 - jpjglo + ! + nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow ! Caspian Sea + nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow + ! + nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow ! Lake Superior + nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow + ! + nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow ! Lake Michigan + nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow + ! + nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow ! Lake Huron + nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow + ! + nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow ! Lake Erie + nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow + ! + nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow ! Lake Ontario + nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow + ! + nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow ! Victoria Lake + nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow + ! + nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow ! Baltic Sea + nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow + ! + ! ! ======================= + CASE ( 2 ) ! ORCA_R2 configuration + ! ! ======================= + ! + nctsi1(1) = 11 ; nctsj1(1) = 103 ! Caspian Sea + nctsi2(1) = 17 ; nctsj2(1) = 112 + ! + nctsi1(2) = 97 ; nctsj1(2) = 107 ! Great North American Lakes + nctsi2(2) = 103 ; nctsj2(2) = 111 + ! + nctsi1(3) = 174 ; nctsj1(3) = 107 ! Black Sea 1 : west part of the Black Sea + nctsi2(3) = 181 ; nctsj2(3) = 112 + ! + nctsi1(4) = 2 ; nctsj1(4) = 107 ! Black Sea 2 : est part of the Black Sea + nctsi2(4) = 6 ; nctsj2(4) = 112 + ! + nctsi1(5) = 145 ; nctsj1(5) = 116 ! Baltic Sea + nctsi2(5) = 150 ; nctsj2(5) = 126 + ! ! ======================= + CASE ( 4 ) ! ORCA_R4 configuration + ! ! ======================= + ! + nctsi1(1) = 4 ; nctsj1(1) = 53 ! Caspian Sea + nctsi2(1) = 4 ; nctsj2(1) = 56 + ! + nctsi1(2) = 49 ; nctsj1(2) = 55 ! Great North American Lakes + nctsi2(2) = 51 ; nctsj2(2) = 56 + ! + nctsi1(3) = 88 ; nctsj1(3) = 55 ! Black Sea + nctsi2(3) = 91 ; nctsj2(3) = 56 + ! + nctsi1(4) = 75 ; nctsj1(4) = 59 ! Baltic Sea + nctsi2(4) = 76 ; nctsj2(4) = 61 + ! ! ======================= + CASE ( 025 ) ! ORCA_R025 configuration + ! ! ======================= + ! + nctsi1(1) = 1330 ; nctsj1(1) = 645 ! Caspian + Aral sea + nctsi2(1) = 1400 ; nctsj2(1) = 795 + ! + nctsi1(2) = 1284 ; nctsj1(2) = 722 ! Azov Sea + nctsi2(2) = 1304 ; nctsj2(2) = 747 + ! + END SELECT + ! + ENDIF + ! + ! convert the position in local domain indices + ! -------------------------------------------- + DO jc = 1, npncts + nctsi1(jc) = mi0( nctsi1(jc) ) + nctsj1(jc) = mj0( nctsj1(jc) ) + ! + nctsi2(jc) = mi1( nctsi2(jc) ) + nctsj2(jc) = mj1( nctsj2(jc) ) + END DO + ! + ENDIF + + ! Restore close seas values to initial data + IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' trc_dmp_clo : Restoring of nutrients on close seas at time-step kt = ', kt + IF(lwp) WRITE(numout,*) + ! + ALLOCATE( ztrcdta(jpi,jpj,jpk) ) ! Memory allocation + ! + DO jn = 1, jptra + IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file + jl = n_trc_index(jn) + CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 + DO jc = 1, npncts + DO jk = 1, jpkm1 + DO jj = nctsj1(jc), nctsj2(jc) + DO ji = nctsi1(jc), nctsi2(jc) + trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) + trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) + END DO + END DO + END DO + END DO + ENDIF + END DO + DEALLOCATE( ztrcdta ) + ENDIF + ! + END SUBROUTINE trc_dmp_clo + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_dmp( kt ) ! Empty routine + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_dmp: You should not have seen this print! error?', kt + END SUBROUTINE trc_dmp +#endif + + !!====================================================================== +END MODULE trcdmp diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcldf.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcldf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..08bf2c2c8164b61a7cf9c03631cdeb3cb2bfe3d9 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcldf.F90 @@ -0,0 +1,195 @@ +MODULE trcldf + !!====================================================================== + !! *** MODULE trcldf *** + !! Ocean Passive tracers : lateral diffusive trends + !!===================================================================== + !! History : 1.0 ! 2005-11 (G. Madec) Original code + !! 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.7 ! 2014-03 (G. Madec) LDF simplification + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_ldf : update the tracer trend with the lateral diffusion + !! trc_ldf_ini : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE trc ! ocean passive tracers variables + USE oce_trc ! ocean dynamics and active tracers + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + USE traldf_lap_blp ! lateral diffusion: lap/bilaplacian iso-level operator (tra_ldf_lap/_blp routine) + 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 ! trends manager: tracers + ! + USE prtctl_trc ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ldf + PUBLIC trc_ldf_ini + ! + ! !!: ** lateral mixing namelist (nam_trcldf) ** + LOGICAL , PUBLIC :: ln_trcldf_OFF !: No operator (no explicit lateral diffusion) + LOGICAL , PUBLIC :: ln_trcldf_tra !: use active tracer operator + REAL(wp), PUBLIC :: rn_ldf_multi !: multiplier of T-S eddy diffusivity to obtain the passive tracer one + REAL(wp), PUBLIC :: rn_fact_lap !: enhanced Equatorial zonal diffusivity coefficent + ! + INTEGER :: nldf_trc = 0 ! type of lateral diffusion used defined from ln_traldf_... (namlist logicals) + REAL(wp) :: rldf ! multiplier between active and passive tracers eddy diffusivity [-] + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcldf.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ldf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf *** + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jn + REAL(wp) :: zdep + CHARACTER (len=22) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zahu, zahv + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrtrd + !!---------------------------------------------------------------------- + ! + IF( ln_trcldf_OFF ) RETURN ! not lateral diffusion applied on passive tracers + ! + IF( ln_timing ) CALL timing_start('trc_ldf') + ! + IF( l_trdtrc ) THEN + ALLOCATE( ztrtrd(jpi,jpj,jpk,jptra) ) + ztrtrd(:,:,:,:) = tra(:,:,:,:) + ENDIF + ! !* set the lateral diffusivity coef. for passive tracer + zahu(:,:,:) = rldf * ahtu(:,:,:) + zahv(:,:,:) = rldf * ahtv(:,:,:) + ! !* Enhanced zonal diffusivity coefficent in the equatorial domain + DO jk= 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( gdept_n(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN + zdep = MAX( gdept_n(ji,jj,jk) - 1000., 0. ) / 1000. + zahu(ji,jj,jk) = zahu(ji,jj,jk) * MAX( 1., rn_fact_lap * EXP( -zdep ) ) + ENDIF + END DO + END DO + END DO + ! + SELECT CASE ( nldf_trc ) !* compute lateral mixing trend and add it to the general trend + ! + CASE ( np_lap ) ! iso-level laplacian + CALL tra_ldf_lap ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, tra, jptra, 1 ) + CASE ( np_lap_i ) ! laplacian : standard iso-neutral operator (Madec) + CALL tra_ldf_iso ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, trb, tra, jptra, 1 ) + CASE ( np_lap_it ) ! laplacian : triad iso-neutral operator (griffies) + CALL tra_ldf_triad( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, trb, tra, jptra, 1 ) + CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: all operator (iso-level, -neutral) + CALL tra_ldf_blp ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb , tra, jptra, nldf_trc ) + END SELECT + ! + IF( l_trdtrc ) THEN ! send the trends for further diagnostics + DO jn = 1, jptra + ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) + CALL trd_tra( kt, 'TRC', jn, jptra_ldf, ztrtrd(:,:,:,jn) ) + END DO + DEALLOCATE( ztrtrd ) + ENDIF + ! + IF( ln_ctl ) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('ldf ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_ldf') + ! + END SUBROUTINE trc_ldf + + + SUBROUTINE trc_ldf_ini + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_ctl *** + !! + !! ** Purpose : Define the operator for the lateral diffusion + !! + !! ** Method : - ln_trcldf_tra=T : use nldf_tra set in ldftra module + !! to defined the passive tracer lateral diffusive operator + !! - ln_trcldf_OFF=T : no explicit diffusion used + !!---------------------------------------------------------------------- + INTEGER :: ios, ioptio ! local integers + !! + NAMELIST/namtrc_ldf/ ln_trcldf_OFF , ln_trcldf_tra, & ! operator & direction + & rn_ldf_multi , rn_fact_lap ! coefficient + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_ldf_ini : lateral passive tracer diffusive operator' + WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + REWIND( numnat_ref ) ! namtrc_ldf in reference namelist + READ ( numnat_ref, namtrc_ldf, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in reference namelist' ) + ! + REWIND( numnat_cfg ) ! namtrc_ldf in configuration namelist + READ ( numnat_cfg, namtrc_ldf, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_ldf ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist namtrc_ldf : set lateral mixing parameters (type, direction, coefficients)' + WRITE(numout,*) ' no explicit diffusion ln_trcldf_OFF = ', ln_trcldf_OFF + WRITE(numout,*) ' use active tracer operator ln_trcldf_tra = ', ln_trcldf_tra + WRITE(numout,*) ' diffusivity coefficient :' + WRITE(numout,*) ' multiplier of TRA coef. for TRC rn_ldf_multi = ', rn_ldf_multi + WRITE(numout,*) ' enhanced zonal Eq. laplacian coef. rn_fact_lap = ', rn_fact_lap + + ENDIF + ! + ! ! control the namelist parameters + nldf_trc = np_ERROR + ioptio = 0 + IF( ln_trcldf_OFF ) THEN ; nldf_trc = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF + IF( ln_trcldf_tra ) THEN ; nldf_trc = nldf_tra ; ioptio = ioptio + 1 ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'trc_ldf_ini: use ONE of the 2 operator options (NONE/tra)' ) + + ! ! multiplier : passive/active tracers ration + IF( ln_traldf_lap ) THEN ! laplacian operator + rldf = rn_ldf_multi ! simple multiplier + ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator: + rldf = SQRT( ABS( rn_ldf_multi ) ) ! the coef. used is the SQRT of the bilaplacian coef. + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nldf_trc ) + 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 trc_ldf_ini + +#endif + !!====================================================================== +END MODULE trcldf diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcnxt.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcnxt.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3fc02f6707493f7e4e66a179e1063f08ebe1aedd --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcnxt.F90 @@ -0,0 +1,290 @@ +MODULE trcnxt + !!====================================================================== + !! *** MODULE trcnxt *** + !! Ocean passive tracers: time stepping on passives tracers + !!====================================================================== + !! History : 7.0 ! 1991-11 (G. Madec) Original code + !! ! 1993-03 (M. Guyon) symetrical conditions + !! ! 1995-02 (M. Levy) passive tracers + !! ! 1996-02 (G. Madec & M. Imbard) opa release 8.0 + !! 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-08 (G. Madec) F90: Free form and module + !! ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries + !! ! 2004-03 (C. Ethe) passive tracers + !! ! 2007-02 (C. Deltel) Diagnose ML trends for passive tracers + !! 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-06 (C. Ethe, G. Madec) Merge TRA-TRC + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_nxt : time stepping on passive tracers + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and tracers variables + USE trc ! ocean passive tracers variables + USE trd_oce + USE trdtra + USE tranxt + USE bdy_oce , ONLY: ln_bdy + USE trcbdy ! BDY open boundaries +# if defined key_agrif + USE agrif_top_interp +# endif + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl_trc ! Print control for debbuging + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_nxt ! routine called by step.F90 + + REAL(wp) :: rfact1, rfact2 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnxt.F90 12026 2019-12-02 14:54:57Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_nxt( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trcnxt *** + !! + !! ** Purpose : Compute the passive tracers fields at the + !! next time-step from their temporal trends and swap the fields. + !! + !! ** Method : Apply lateral boundary conditions on (ua,va) through + !! call to lbc_lnk routine + !! default: + !! arrays swap + !! (trn) = (tra) ; (tra) = (0,0) + !! (trb) = (trn) + !! + !! For Arakawa or TVD Scheme : + !! A Asselin time filter applied on now tracers (trn) to avoid + !! the divergence of two consecutive time-steps and tr arrays + !! to prepare the next time_step: + !! (trb) = (trn) + atfp [ (trb) + (tra) - 2 (trn) ] + !! (trn) = (tra) ; (tra) = (0,0) + !! + !! + !! ** Action : - update trb, trn + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: jk, jn ! dummy loop indices + REAL(wp) :: zfact ! temporary scalar + CHARACTER (len=22) :: charout + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrdt ! 4D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_nxt') + ! + IF( kt == nittrc000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_nxt : time stepping on passive tracers' + ENDIF + ! +#if defined key_agrif + CALL Agrif_trc ! AGRIF zoom boundaries +#endif + ! Update after tracer on domain lateral boundaries + CALL lbc_lnk( 'trcnxt', tra(:,:,:,:), 'T', 1. ) + + IF( ln_bdy ) CALL trc_bdy( kt ) + + IF( l_trdtrc ) THEN ! trends: store now fields before the Asselin filter application + ALLOCATE( ztrdt(jpi,jpj,jpk,jptra) ) + ztrdt(:,:,:,:) = 0._wp + IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend + DO jn = 1, jptra + CALL trd_tra( kt, 'TRC', jn, jptra_zdfp, ztrdt(:,:,:,jn) ) + ENDDO + ENDIF + + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rdttrc + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from tsn terms + IF( ln_linssh ) THEN ! linear sea surface height only + DO jn = 1, jptra + DO jk = 1, jpkm1 + ztrdt(:,:,jk,jn) = ( tra(:,:,jk,jn)*e3t_a(:,:,jk) / e3t_n(:,:,jk) - trn(:,:,jk,jn)) * zfact + END DO + END DO + ELSE + DO jn = 1, jptra + DO jk = 1, jpkm1 + ztrdt(:,:,jk,jn) = ( tra(:,:,jk,jn) - trn(:,:,jk,jn) ) * zfact + END DO + END DO + ENDIF + ! + DO jn = 1, jptra + CALL trd_tra( kt, 'TRC', jn, jptra_tot, ztrdt(:,:,:,jn) ) + ENDDO + ! + 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(:,:,:,:) = trn(:,:,:,:) + ENDIF + + ENDIF + ! ! Leap-Frog + Asselin filter time stepping + IF( (neuler == 0 .AND. kt == nittrc000) ) THEN + ! set up for leapfrog on second timestep + DO jn = 1, jptra + DO jk = 1, jpkm1 + trb(:,:,jk,jn) = trn(:,:,jk,jn) + trn(:,:,jk,jn) = tra(:,:,jk,jn) + END DO + END DO + ELSE IF( ln_top_euler ) THEN + ! always doing euler timestepping + DO jn = 1, jptra + DO jk = 1, jpkm1 + trn(:,:,jk,jn) = tra(:,:,jk,jn) + trb(:,:,jk,jn) = trn(:,:,jk,jn) + END DO + END DO + ENDIF + IF( (neuler == 0 .AND. kt == nittrc000) .OR. ln_top_euler ) THEN ! Euler time-stepping (only swap) + IF (l_trdtrc .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 + DO jn = 1, jptra + CALL trd_tra( kt, 'TRC', jn, jptra_atf, ztrdt(:,:,:,jn) ) + ENDDO + END IF + ! + ELSE + IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping + IF( ln_linssh ) THEN ; CALL tra_nxt_fix( kt, nittrc000, 'TRC', trb, trn, tra, jptra ) ! linear ssh + ELSE ; CALL tra_nxt_vvl( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra, & + & sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh + ENDIF + ELSE + CALL trc_nxt_off( kt ) ! offline + ENDIF + ! + CALL lbc_lnk_multi( 'trcnxt', trb(:,:,:,:), 'T', 1._wp, trn(:,:,:,:), 'T', 1._wp, tra(:,:,:,:), 'T', 1._wp ) + ENDIF + ! + IF( l_trdtrc .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt ) + DO jn = 1, jptra + DO jk = 1, jpkm1 + zfact = 1._wp / r2dttrc + ztrdt(:,:,jk,jn) = ( trb(:,:,jk,jn) - ztrdt(:,:,jk,jn) ) * zfact + END DO + CALL trd_tra( kt, 'TRC', jn, jptra_atf, ztrdt(:,:,:,jn) ) + END DO + END IF + IF( l_trdtrc ) DEALLOCATE( ztrdt ) + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('nxt')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc(tab4d=trn, mask=tmask, clinfo=ctrcnm) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_nxt') + ! + END SUBROUTINE trc_nxt + + + SUBROUTINE trc_nxt_off( kt ) + !!---------------------------------------------------------------------- + !! *** 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. + !! - save in (ta,sa) a thickness weighted average over the three + !! time levels which will be used to compute rdn and thus the semi- + !! implicit hydrostatic pressure gradient (ln_dynhpg_imp = T) + !! - swap tracer fields to prepare the next time_step. + !! This can be summurized for tempearture as: + !! ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) ln_dynhpg_imp = T + !! /( e3t_n + rbcp*[ e3t_b - 2 e3t_n + e3t_a ] ) + !! ztm = 0 otherwise + !! 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 + !! ta = zt (NB: reset to 0 after eos_bn2 call) + !! + !! ** Action : - (tb,sb) and (tn,sn) ready for the next time step + !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(wp) :: ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d ! - - + !!---------------------------------------------------------------------- + ! + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_nxt_off : time stepping' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + IF( .NOT. ln_linssh ) THEN + rfact1 = atfp * rdttrc + rfact2 = rfact1 / rau0 + ENDIF + ! + ENDIF + ! + DO jn = 1, jptra + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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 = trb(ji,jj,jk,jn) * ze3t_b + ztc_n = trn(ji,jj,jk,jn) * ze3t_n + ztc_a = tra(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 + ! + IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN ! first level + ze3t_f = ze3t_f - rfact2 * ( emp_b(ji,jj) - emp(ji,jj) ) + ztc_f = ztc_f - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) + ENDIF + + ze3t_f = 1.e0 / ze3t_f + trb(ji,jj,jk,jn) = ztc_f * ze3t_f ! ptb <-- ptn filtered + trn(ji,jj,jk,jn) = tra(ji,jj,jk,jn) ! ptn <-- pta + ! + END DO + END DO + END DO + ! + END DO + ! + END SUBROUTINE trc_nxt_off + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_nxt( kt ) + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_nxt: You should not have seen this print! error?', kt + END SUBROUTINE trc_nxt +#endif + !!====================================================================== +END MODULE trcnxt diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcrad.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcrad.F90 new file mode 100644 index 0000000000000000000000000000000000000000..def252df8175f5c310ce4fb9f4947528e9f8e166 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcrad.F90 @@ -0,0 +1,295 @@ +MODULE trcrad + !!====================================================================== + !! *** MODULE trcrad *** + !! Ocean passive tracers: correction of negative concentrations + !!====================================================================== + !! History : - ! 01-01 (O. Aumont & E. Kestenare) Original code + !! 1.0 ! 04-03 (C. Ethe) free form F90 + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_rad : correction of negative concentrations + !!---------------------------------------------------------------------- + USE par_trc ! need jptra, number of passive tracers + USE oce_trc ! ocean dynamics and tracers variables + USE trc ! ocean passive tracers variables + USE trd_oce + USE trdtra + USE prtctl_trc ! Print control for debbuging + USE lib_fortran + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_rad + PUBLIC trc_rad_ini + + LOGICAL , PUBLIC :: ln_trcrad !: flag to artificially correct negative concentrations + REAL(wp), DIMENSION(:,:), ALLOCATABLE:: gainmass + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcrad.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_rad( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_rad *** + !! + !! ** Purpose : "crappy" routine to correct artificial negative + !! concentrations due to isopycnal scheme + !! + !! ** Method : - PISCES or LOBSTER: Set negative concentrations to zero + !! while computing the corresponding tracer content that + !! is added to the tracers. Then, adjust the tracer + !! concentration using a multiplicative factor so that + !! the total tracer concentration is preserved. + !! - CFC: simply set to zero the negative CFC concentration + !! (the total CFC content is not strictly preserved) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + CHARACTER (len=22) :: charout + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_rad') + ! + IF( ln_age ) CALL trc_rad_sms( kt, trb, trn, jp_age , jp_age ) ! AGE + IF( ll_cfc ) CALL trc_rad_sms( kt, trb, trn, jp_cfc0, jp_cfc1 ) ! CFC model + IF( ln_c14 ) CALL trc_rad_sms( kt, trb, trn, jp_c14 , jp_c14 ) ! C14 + IF( ln_pisces ) CALL trc_rad_sms( kt, trb, trn, jp_pcs0, jp_pcs1, cpreserv='Y' ) ! PISCES model + IF( ln_my_trc ) CALL trc_rad_sms( kt, trb, trn, jp_myt0, jp_myt1 ) ! MY_TRC model + ! + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('rad')") + CALL prt_ctl_trc_info( charout ) + CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_rad') + ! + END SUBROUTINE trc_rad + + + SUBROUTINE trc_rad_ini + !!--------------------------------------------------------------------- + !! *** ROUTINE trc _rad_ini *** + !! + !! ** Purpose : read namelist options + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namtrc_rad/ ln_trcrad + !!---------------------------------------------------------------------- + ! + REWIND( numnat_ref ) ! namtrc_rad in reference namelist + READ ( numnat_ref, namtrc_rad, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_rad in reference namelist' ) + REWIND( numnat_cfg ) ! namtrc_rad in configuration namelist + READ ( numnat_cfg, namtrc_rad, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_rad in configuration namelist' ) + IF(lwm) WRITE( numont, namtrc_rad ) + + IF(lwp) THEN ! ! Control print + WRITE(numout,*) + WRITE(numout,*) 'trc_rad : Correct artificial negative concentrations ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namtrc_rad : treatment of negative concentrations' + WRITE(numout,*) ' correct artificially negative concen. or not ln_trcrad = ', ln_trcrad + WRITE(numout,*) + IF( ln_trcrad ) THEN ; WRITE(numout,*) ' ===>> ensure the global tracer conservation' + ELSE ; WRITE(numout,*) ' ===>> NO strict global tracer conservation' + ENDIF + ENDIF + ! + ALLOCATE( gainmass(jptra,2) ) + gainmass(:,:) = 0. + ! + END SUBROUTINE trc_rad_ini + + + SUBROUTINE trc_rad_sms( kt, ptrb, ptrn, jp_sms0, jp_sms1, cpreserv ) + !!----------------------------------------------------------------------------- + !! *** ROUTINE trc_rad_sms *** + !! + !! ** Purpose : "crappy" routine to correct artificial negative + !! concentrations due to isopycnal scheme + !! + !! ** Method : 2 cases : + !! - Set negative concentrations to zero while computing + !! the corresponding tracer content that is added to the + !! tracers. Then, adjust the tracer concentration using + !! a multiplicative factor so that the total tracer + !! concentration is preserved. + !! - simply set to zero the negative CFC concentration + !! (the total content of concentration is not strictly preserved) + !!-------------------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: jp_sms0, jp_sms1 ! First & last index of the passive tracer model + REAL(wp), DIMENSION (jpi,jpj,jpk,jptra), INTENT(inout) :: ptrb , ptrn ! before and now traceur concentration + CHARACTER( len = 1), OPTIONAL , INTENT(in ) :: cpreserv ! flag to preserve content or not + ! + INTEGER :: ji, ji2, jj, jj2, jk, jn ! dummy loop indices + INTEGER :: icnt + LOGICAL :: lldebug = .FALSE. ! local logical + REAL(wp):: zcoef, zs2rdt, ztotmass + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrneg, ztrpos + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrtrd ! workspace arrays + !!---------------------------------------------------------------------- + ! + IF( l_trdtrc ) ALLOCATE( ztrtrd(jpi,jpj,jpk) ) + zs2rdt = 1. / ( 2. * rdt * REAL( nn_dttrc, wp ) ) + ! + IF( PRESENT( cpreserv ) ) THEN !== total tracer concentration is preserved ==! + ! + ALLOCATE( ztrneg(1:jpi,1:jpj,jp_sms0:jp_sms1), ztrpos(1:jpi,1:jpj,jp_sms0:jp_sms1) ) + + DO jn = jp_sms0, jp_sms1 + ztrneg(:,:,jn) = SUM( MIN( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:), dim = 3 ) ! sum of the negative values + ztrpos(:,:,jn) = SUM( MAX( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:), dim = 3 ) ! sum of the positive values + END DO + CALL sum3x3( ztrneg ) + CALL sum3x3( ztrpos ) + + DO jn = jp_sms0, jp_sms1 + ! + IF( l_trdtrc ) ztrtrd(:,:,:) = ptrb(:,:,:,jn) ! save input trb for trend computation + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( ztrneg(ji,jj,jn) /= 0. ) THEN ! if negative values over the 3x3 box + ! + ptrb(ji,jj,jk,jn) = ptrb(ji,jj,jk,jn) * tmask(ji,jj,jk) ! really needed? + IF( ptrb(ji,jj,jk,jn) < 0. ) ptrb(ji,jj,jk,jn) = 0. ! supress negative values + IF( ptrb(ji,jj,jk,jn) > 0. ) THEN ! use positive values to compensate mass gain + zcoef = 1. + ztrneg(ji,jj,jn) / ztrpos(ji,jj,jn) ! ztrpos > 0 as ptrb > 0 + ptrb(ji,jj,jk,jn) = ptrb(ji,jj,jk,jn) * zcoef + IF( zcoef < 0. ) THEN ! if the compensation exceed the positive value + gainmass(jn,1) = gainmass(jn,1) - ptrb(ji,jj,jk,jn) * cvol(ji,jj,jk) ! we are adding mass... + ptrb(ji,jj,jk,jn) = 0. ! limit the compensation to keep positive value + ENDIF + ENDIF + ! + ENDIF + END DO + END DO + END DO + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = ( ptrb(:,:,:,jn) - ztrtrd(:,:,:) ) * zs2rdt + CALL trd_tra( kt, 'TRC', jn, jptra_radb, ztrtrd ) ! Asselin-like trend handling + ENDIF + ! + END DO + + IF( kt == nitend ) THEN + CALL mpp_sum( 'trcrad', gainmass(:,1) ) + DO jn = jp_sms0, jp_sms1 + IF( gainmass(jn,1) > 0. ) THEN + ztotmass = glob_sum( 'trcrad', ptrb(:,:,:,jn) * cvol(:,:,:) ) + IF(lwp) WRITE(numout, '(a, i2, a, D23.16, a, D23.16)') 'trcrad ptrb, traceur ', jn & + & , ' total mass : ', ztotmass, ', mass gain : ', gainmass(jn,1) + END IF + END DO + ENDIF + + DO jn = jp_sms0, jp_sms1 + ztrneg(:,:,jn) = SUM( MIN( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:), dim = 3 ) ! sum of the negative values + ztrpos(:,:,jn) = SUM( MAX( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:), dim = 3 ) ! sum of the positive values + END DO + CALL sum3x3( ztrneg ) + CALL sum3x3( ztrpos ) + + DO jn = jp_sms0, jp_sms1 + ! + IF( l_trdtrc ) ztrtrd(:,:,:) = ptrn(:,:,:,jn) ! save input trb for trend computation + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( ztrneg(ji,jj,jn) /= 0. ) THEN ! if negative values over the 3x3 box + ! + ptrn(ji,jj,jk,jn) = ptrn(ji,jj,jk,jn) * tmask(ji,jj,jk) ! really needed? + IF( ptrn(ji,jj,jk,jn) < 0. ) ptrn(ji,jj,jk,jn) = 0. ! supress negative values + IF( ptrn(ji,jj,jk,jn) > 0. ) THEN ! use positive values to compensate mass gain + zcoef = 1. + ztrneg(ji,jj,jn) / ztrpos(ji,jj,jn) ! ztrpos > 0 as ptrb > 0 + ptrn(ji,jj,jk,jn) = ptrn(ji,jj,jk,jn) * zcoef + IF( zcoef < 0. ) THEN ! if the compensation exceed the positive value + gainmass(jn,2) = gainmass(jn,2) - ptrn(ji,jj,jk,jn) * cvol(ji,jj,jk) ! we are adding mass... + ptrn(ji,jj,jk,jn) = 0. ! limit the compensation to keep positive value + ENDIF + ENDIF + ! + ENDIF + END DO + END DO + END DO + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = ( ptrn(:,:,:,jn) - ztrtrd(:,:,:) ) * zs2rdt + CALL trd_tra( kt, 'TRC', jn, jptra_radn, ztrtrd ) ! standard trend handling + ENDIF + ! + END DO + + IF( kt == nitend ) THEN + CALL mpp_sum( 'trcrad', gainmass(:,2) ) + DO jn = jp_sms0, jp_sms1 + IF( gainmass(jn,2) > 0. ) THEN + ztotmass = glob_sum( 'trcrad', ptrn(:,:,:,jn) * cvol(:,:,:) ) + WRITE(numout, '(a, i2, a, D23.16, a, D23.16)') 'trcrad ptrn, traceur ', jn & + & , ' total mass : ', ztotmass, ', mass gain : ', gainmass(jn,1) + END IF + END DO + ENDIF + + DEALLOCATE( ztrneg, ztrpos ) + ! + ELSE !== total CFC content is NOT strictly preserved ==! + ! + DO jn = jp_sms0, jp_sms1 + ! + IF( l_trdtrc ) ztrtrd(:,:,:) = ptrb(:,:,:,jn) ! save input trb for trend computation + ! + WHERE( ptrb(:,:,:,jn) < 0. ) ptrb(:,:,:,jn) = 0. + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = ( ptrb(:,:,:,jn) - ztrtrd(:,:,:) ) * zs2rdt + CALL trd_tra( kt, 'TRC', jn, jptra_radb, ztrtrd ) ! Asselin-like trend handling + ENDIF + ! + IF( l_trdtrc ) ztrtrd(:,:,:) = ptrn(:,:,:,jn) ! save input trn for trend computation + ! + WHERE( ptrn(:,:,:,jn) < 0. ) ptrn(:,:,:,jn) = 0. + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = ( ptrn(:,:,:,jn) - ztrtrd(:,:,:) ) * zs2rdt + CALL trd_tra( kt, 'TRC', jn, jptra_radn, ztrtrd ) ! standard trend handling + ENDIF + ! + END DO + ! + ENDIF + ! + IF( l_trdtrc ) DEALLOCATE( ztrtrd ) + ! + END SUBROUTINE trc_rad_sms + +#else + !!---------------------------------------------------------------------- + !! Dummy module : NO TOP model + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_rad( kt ) ! Empty routine + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_rad: You should not have seen this print! error?', kt + END SUBROUTINE trc_rad +#endif + + !!====================================================================== +END MODULE trcrad diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcsbc.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcsbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..18101239f22322381a720fdeec0faf190574a5a7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcsbc.F90 @@ -0,0 +1,215 @@ +MODULE trcsbc + !!============================================================================== + !! *** MODULE trcsbc *** + !! Ocean passive tracers: surface boundary condition + !!====================================================================== + !! History : 8.2 ! 1998-10 (G. Madec, G. Roullet, M. Imbard) Original code + !! 8.2 ! 2001-02 (D. Ludicone) sea ice and free surface + !! 8.5 ! 2002-06 (G. Madec) F90: Free form and module + !! 9.0 ! 2004-03 (C. Ethe) adapted for passive tracers + !! ! 2006-08 (C. Deltel) Diagnose ML trends for passive tracers + !!============================================================================== +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_sbc : update the tracer trend at ocean surface + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers variables + USE trc ! ocean passive tracers variables + USE prtctl_trc ! Print control for debbuging + USE iom + USE trd_oce + USE trdtra + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sbc ! routine called by step.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsbc.F90 10788 2019-03-21 11:15:14Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sbc ( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sbc *** + !! + !! ** Purpose : Compute the tracer surface boundary condition trend of + !! (concentration/dilution effect) and add it to the general + !! trend of tracer equations. + !! + !! ** Method : + !! * concentration/dilution effect: + !! The surface freshwater flux modify the ocean volume + !! and thus the concentration of a tracer as : + !! tra = tra + emp * trn / e3t for k=1 + !! where emp, the surface freshwater budget (evaporation minus + !! precipitation ) given in kg/m2/s is divided + !! by 1035 kg/m3 (density of ocean water) to obtain m/s. + !! + !! ** Action : - Update the 1st level of tra with the trend associated + !! with the tracer surface boundary condition + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jn ! dummy loop indices + REAL(wp) :: zse3t, zrtrn, zfact ! local scalars + REAL(wp) :: zftra, zdtra, ztfx, ztra ! - - + CHARACTER (len=22) :: charout + REAL(wp), DIMENSION(jpi,jpj) :: zsfx + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrtrd + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sbc') + ! + ! Allocate temporary workspace + IF( l_trdtrc ) ALLOCATE( ztrtrd(jpi,jpj,jpk) ) + ! + zrtrn = 1.e-15_wp + + IF( kt == nittrc000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_sbc : Passive tracers surface boundary condition' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ! + IF( ln_rsttr .AND. .NOT.ln_top_euler .AND. & ! Restart: read in restart file + iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file' + zfact = 0.5_wp + DO jn = 1, jptra + CALL iom_get( numrtr, jpdom_autoglo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc + END DO + ELSE ! No restart or restart not found: Euler forward time stepping + zfact = 1._wp + sbc_trc_b(:,:,:) = 0._wp + ENDIF + ELSE ! Swap of forcing fields + IF( ln_top_euler ) THEN + zfact = 1._wp + sbc_trc_b(:,:,:) = 0._wp + ELSE + zfact = 0.5_wp + sbc_trc_b(:,:,:) = sbc_trc(:,:,:) + ENDIF + ! + ENDIF + + ! Coupling online : river runoff is added to the horizontal divergence (hdivn) in the subroutine sbc_rnf_div + ! one only consider the concentration/dilution effect due to evaporation minus precipitation + freezing/melting of sea-ice + ! Coupling offline : runoff are in emp which contains E-P-R + ! + IF( .NOT.ln_linssh ) THEN ! online coupling with vvl + zsfx(:,:) = 0._wp + ELSE ! online coupling free surface or offline with free surface + zsfx(:,:) = emp(:,:) + ENDIF + + ! 0. initialization + SELECT CASE ( nn_ice_tr ) + + CASE ( -1 ) ! No tracers in sea ice (null concentration in sea ice) + ! + DO jn = 1, jptra + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + sbc_trc(ji,jj,jn) = zsfx(ji,jj) * r1_rau0 * trn(ji,jj,1,jn) + END DO + END DO + END DO + ! + CASE ( 0 ) ! Same concentration in sea ice and in the ocean + ! + DO jn = 1, jptra + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + sbc_trc(ji,jj,jn) = ( zsfx(ji,jj) + fmmflx(ji,jj) ) * r1_rau0 * trn(ji,jj,1,jn) + END DO + END DO + END DO + ! + CASE ( 1 ) ! Specific treatment of sea ice fluxes with an imposed concentration in sea ice + ! + DO jn = 1, jptra + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + zse3t = 1. / e3t_n(ji,jj,1) + ! tracer flux at the ice/ocean interface (tracer/m2/s) + zftra = - trc_i(ji,jj,jn) * fmmflx(ji,jj) ! uptake of tracer in the sea ice + ! ! only used in the levitating sea ice case + ! tracer flux only : add concentration dilution term in net tracer flux, no F-M in volume flux + ! tracer and mass fluxes : no concentration dilution term in net tracer flux, F-M term in volume flux + ztfx = zftra ! net tracer flux + ! + zdtra = r1_rau0 * ( ztfx + ( zsfx(ji,jj) + fmmflx(ji,jj) ) * trn(ji,jj,1,jn) ) + IF ( zdtra < 0. ) THEN + zdtra = MAX(zdtra, -trn(ji,jj,1,jn) * e3t_n(ji,jj,1) / r2dttrc ) ! avoid negative concentrations to arise + ENDIF + sbc_trc(ji,jj,jn) = zdtra + END DO + END DO + END DO + END SELECT + ! + CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1. ) + ! Concentration dilution effect on tracers due to evaporation & precipitation + DO jn = 1, jptra + ! + IF( l_trdtrc ) ztrtrd(:,:,:) = tra(:,:,:,jn) ! save trends + ! + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + zse3t = zfact / e3t_n(ji,jj,1) + tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + ( sbc_trc_b(ji,jj,jn) + sbc_trc(ji,jj,jn) ) * zse3t + END DO + END DO + ! + IF( l_trdtrc ) THEN + ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) + CALL trd_tra( kt, 'TRC', jn, jptra_nsr, ztrtrd ) + END IF + ! ! =========== + END DO ! tracer loop + ! ! =========== + ! + ! Write in the tracer restar file + ! ******************************* + IF( lrst_trc .AND. .NOT.ln_top_euler ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in tracer restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + DO jn = 1, jptra + CALL iom_rstput( kt, nitrst, numrtw, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc(:,:,jn) ) + END DO + ENDIF + ! + IF( ln_ctl ) THEN + WRITE(charout, FMT="('sbc ')") ; CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + ENDIF + IF( l_trdtrc ) DEALLOCATE( ztrtrd ) + ! + IF( ln_timing ) CALL timing_stop('trc_sbc') + ! + END SUBROUTINE trc_sbc + +#else + !!---------------------------------------------------------------------- + !! Dummy module : NO passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_sbc (kt) ! Empty routine + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_sbc: You should not have seen this print! error?', kt + END SUBROUTINE trc_sbc +#endif + + !!====================================================================== +END MODULE trcsbc diff --git a/V4.0/nemo_sources/src/TOP/TRP/trcsink.F90 b/V4.0/nemo_sources/src/TOP/TRP/trcsink.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6d5fa8af155840e29eb5642aa08ccf7f9a40892b --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trcsink.F90 @@ -0,0 +1,238 @@ +MODULE trcsink + !!====================================================================== + !! *** MODULE trcsink *** + !! TOP : vertical flux of particulate matter due to gravitational sinking + !!====================================================================== + !! History : 1.0 ! 2004 (O. Aumont) Original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 + !! 3.4 ! 2011-06 (O. Aumont, C. Ethe) Change aggregation formula + !! 3.5 ! 2012-07 (O. Aumont) Introduce potential time-splitting + !! 4.0 ! 2018-12 (O. Aumont) Generalize the PISCES code to make it usable by any model + !!---------------------------------------------------------------------- + !! trc_sink : Compute vertical flux of particulate matter due to gravitational sinking + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sink + PUBLIC trc_sink_ini + + INTEGER, PUBLIC :: nitermax !: Maximum number of iterations for sinking + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsink.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! 'standard sinking parameterisation' ??? + !!---------------------------------------------------------------------- + + SUBROUTINE trc_sink ( kt, pwsink, psinkflx, jp_tra, rsfact ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_sink *** + !! + !! ** Purpose : Compute vertical flux of particulate matter due to + !! gravitational sinking + !! + !! ** Method : - ??? + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + INTEGER , INTENT(in) :: jp_tra ! tracer index index + REAL(wp), INTENT(in) :: rsfact ! time step duration + REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pwsink + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx + INTEGER :: ji, jj, jk + INTEGER, DIMENSION(jpi, jpj) :: iiter + REAL(wp) :: zfact, zwsmax, zmax + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwsink + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sink') + ! + ! + ! OA This is (I hope) a temporary solution for the problem that may + ! OA arise in specific situation where the CFL criterion is broken + ! OA for vertical sedimentation of particles. To avoid this, a time + ! OA splitting algorithm has been coded. A specific maximum + ! OA iteration number is provided and may be specified in the namelist + ! OA This is to avoid very large iteration number when explicit free + ! OA surface is used (for instance). When niter?max is set to 1, + ! OA this computation is skipped. The crude old threshold method is + ! OA then applied. This also happens when niter exceeds nitermax. + IF( nitermax == 1 ) THEN + iiter(:,:) = 1 + ELSE + DO jj = 1, jpj + DO ji = 1, jpi + iiter(ji,jj) = 1 + DO jk = 1, jpkm1 + IF( tmask(ji,jj,jk) == 1.0 ) THEN + zwsmax = 0.5 * e3t_n(ji,jj,jk) * rday / rsfact + iiter(ji,jj) = MAX( iiter(ji,jj), INT( pwsink(ji,jj,jk) / zwsmax ) ) + ENDIF + END DO + END DO + END DO + iiter(:,:) = MIN( iiter(:,:), nitermax ) + ENDIF + + DO jk = 1,jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,jk) == 1.0 ) THEN + zwsmax = 0.5 * e3t_n(ji,jj,jk) * rday / rsfact + zwsink(ji,jj,jk) = MIN( pwsink(ji,jj,jk), zwsmax * REAL( iiter(ji,jj), wp ) ) + ELSE + ! provide a default value so there is no use of undefinite value in trc_sink2 for zwsink2 initialization + zwsink(ji,jj,jk) = 0. + ENDIF + END DO + END DO + END DO + + ! Initializa to zero all the sinking arrays + ! ----------------------------------------- + psinkflx(:,:,:) = 0.e0 + + ! Compute the sedimentation term using trc_sink2 for the considered sinking particle + ! ----------------------------------------------------- + CALL trc_sink2( zwsink, psinkflx, jp_tra, iiter, rsfact ) + ! + IF( ln_timing ) CALL timing_stop('trc_sink') + ! + END SUBROUTINE trc_sink + + SUBROUTINE trc_sink2( pwsink, psinkflx, jp_tra, kiter, rsfact ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_sink2 *** + !! + !! ** Purpose : Compute the sedimentation terms for the various sinking + !! particles. The scheme used to compute the trends is based + !! on MUSCL. + !! + !! ** Method : - this ROUTINE compute not exactly the advection but the + !! transport term, i.e. div(u*tra). + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jp_tra ! tracer index index + REAL(wp), INTENT(in ) :: rsfact ! duration of time step + INTEGER, INTENT(in ), DIMENSION(jpi,jpj) :: kiter ! number of iterations for time-splitting + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pwsink ! sinking speed + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx ! sinking fluxe + ! + INTEGER :: ji, jj, jk, jn + REAL(wp) :: zigma,zew,zign, zflx, zstep + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztraz, zakz, zwsink2, ztrb + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sink2') + ! + ztraz(:,:,:) = 0.e0 + zakz (:,:,:) = 0.e0 + ztrb (:,:,:) = trb(:,:,:,jp_tra) + + DO jk = 1, jpkm1 + zwsink2(:,:,jk+1) = -pwsink(:,:,jk) / rday * tmask(:,:,jk+1) + END DO + zwsink2(:,:,1) = 0.e0 + + + ! Vertical advective flux + DO jn = 1, 2 + ! first guess of the slopes interior values + DO jj = 1, jpj + DO ji = 1, jpi + ! + zstep = rsfact / REAL( kiter(ji,jj), wp ) / 2. + ! + DO jk = 2, jpkm1 + ztraz(ji,jj,jk) = ( trb(ji,jj,jk-1,jp_tra) - trb(ji,jj,jk,jp_tra) ) * tmask(ji,jj,jk) + END DO + ztraz(ji,jj,1 ) = 0.0 + ztraz(ji,jj,jpk) = 0.0 + + ! slopes + DO jk = 2, jpkm1 + zign = 0.25 + SIGN( 0.25_wp, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) ) + zakz(ji,jj,jk) = ( ztraz(ji,jj,jk) + ztraz(ji,jj,jk+1) ) * zign + END DO + + ! Slopes limitation + DO jk = 2, jpkm1 + zakz(ji,jj,jk) = SIGN( 1.0_wp, zakz(ji,jj,jk) ) * & + & MIN( ABS( zakz(ji,jj,jk) ), 2. * ABS(ztraz(ji,jj,jk+1)), 2. * ABS(ztraz(ji,jj,jk) ) ) + END DO + + ! vertical advective flux + DO jk = 1, jpkm1 + zigma = zwsink2(ji,jj,jk+1) * zstep / e3w_n(ji,jj,jk+1) + zew = zwsink2(ji,jj,jk+1) + psinkflx(ji,jj,jk+1) = -zew * ( trb(ji,jj,jk,jp_tra) - 0.5 * ( 1 + zigma ) * zakz(ji,jj,jk) ) * zstep + END DO + ! + ! Boundary conditions + psinkflx(ji,jj,1 ) = 0.e0 + psinkflx(ji,jj,jpk) = 0.e0 + + DO jk=1,jpkm1 + zflx = ( psinkflx(ji,jj,jk) - psinkflx(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) + trb(ji,jj,jk,jp_tra) = trb(ji,jj,jk,jp_tra) + zflx + END DO + END DO + END DO + END DO + + DO jk = 1,jpkm1 + DO jj = 1,jpj + DO ji = 1, jpi + zflx = ( psinkflx(ji,jj,jk) - psinkflx(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) + ztrb(ji,jj,jk) = ztrb(ji,jj,jk) + 2. * zflx + END DO + END DO + END DO + + trb(:,:,:,jp_tra) = ztrb(:,:,:) + psinkflx(:,:,:) = 2. * psinkflx(:,:,:) + ! + IF( ln_timing ) CALL timing_stop('trc_sink2') + ! + END SUBROUTINE trc_sink2 + + SUBROUTINE trc_sink_ini + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_sink_ini *** + !! + !! ** Purpose : read namelist options + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namtrc_snk/ nitermax + !!---------------------------------------------------------------------- + ! + REWIND( numnat_ref ) ! namtrc_rad in reference namelist + READ ( numnat_ref, namtrc_snk, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_snk in reference namelist' ) + REWIND( numnat_cfg ) ! namtrc_rad in configuration namelist + READ ( numnat_cfg, namtrc_snk, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_snk in configuration namelist' ) + IF(lwm) WRITE( numont, namtrc_snk ) + + IF(lwp) THEN ! ! Control print + WRITE(numout,*) + WRITE(numout,*) 'trc_sink : Sedimentation of particles ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namtrc_snk : sedimentation of particles' + WRITE(numout,*) ' Maximum number of iterations nitermax = ', nitermax + WRITE(numout,*) + ENDIF + + END SUBROUTINE trc_sink_ini + + !!====================================================================== +END MODULE trcsink diff --git a/V4.0/nemo_sources/src/TOP/TRP/trctrp.F90 b/V4.0/nemo_sources/src/TOP/TRP/trctrp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ac233b56bc4049e0000bfeed467b4e29b3325267 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trctrp.F90 @@ -0,0 +1,111 @@ +MODULE trctrp + !!====================================================================== + !! *** MODULE trctrp *** + !! Ocean Physics : manage the passive tracer transport + !!====================================================================== + !! History : 1.0 ! 2004-03 (C. Ethe) Original code + !! 3.3 ! 2010-07 (C. Ethe) Merge TRA-TRC + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_trp : passive tracer transport + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers variables + USE trc ! ocean passive tracers variables + USE trcbbl ! bottom boundary layer (trc_bbl routine) + USE trcdmp ! internal damping (trc_dmp routine) + USE trcldf ! lateral mixing (trc_ldf routine) + USE trcadv ! advection (trc_adv routine) + USE trczdf ! vertical diffusion (trc_zdf routine) + USE trcnxt ! time-stepping (trc_nxt routine) + USE trcrad ! positivity (trc_rad routine) + USE trcsbc ! surface boundary condition (trc_sbc routine) + USE zpshde ! partial step: hor. derivative (zps_hde routine) + USE trcbc ! Tracers boundary condtions ( trc_bc routine) + USE bdy_oce , ONLY: ln_bdy + USE trcbdy ! BDY open boundaries + +#if defined key_agrif + USE agrif_top_sponge ! tracers sponges +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_trp ! called by trc_stp + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trctrp.F90 12841 2020-05-01 10:52:40Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE trc_trp( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_trp *** + !! + !! ** Purpose : Management of passive tracers transport + !! + !! ** Method : - Compute the passive tracers trends + !! - Update the passive tracers + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! --------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_trp') + ! + IF( .NOT. lk_c1d ) THEN + ! + CALL trc_sbc ( kt ) ! surface boundary condition + IF( ln_trabbl ) CALL trc_bbl ( kt ) ! advective (and/or diffusive) bottom boundary layer scheme + IF( ln_trcdmp ) CALL trc_dmp ( kt ) ! internal damping trends + CALL trc_bc ( kt ) ! BC for BDY + IF( ln_bdy ) CALL trc_bdy_dmp( kt ) ! BDY damping trends + CALL trc_adv ( kt ) ! horizontal & vertical advection + ! ! Partial top/bottom cell: GRADh( trb ) + IF( ln_zps ) THEN + IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kt, jptra, trb, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! both top & bottom + ELSE ; CALL zps_hde ( kt, jptra, trb, gtru, gtrv ) ! only bottom + ENDIF + ENDIF + ! + CALL trc_ldf ( kt ) ! lateral mixing +#if defined key_agrif + IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_trc ! tracers sponge +#endif + CALL trc_zdf ( kt ) ! vertical mixing and after tracer fields + CALL trc_nxt ( kt ) ! tracer fields at next time step + IF( ln_trcrad ) CALL trc_rad ( kt ) ! Correct artificial negative concentrations + IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kt ) ! internal damping trends on closed seas only + + ! + ELSE ! 1D vertical configuration + CALL trc_sbc( kt ) ! surface boundary condition + IF( ln_trcdmp ) CALL trc_dmp( kt ) ! internal damping trends + CALL trc_zdf( kt ) ! vertical mixing and after tracer fields + CALL trc_nxt( kt ) ! tracer fields at next time step + IF( ln_trcrad ) CALL trc_rad( kt ) ! Correct artificial negative concentrations + ! + END IF + ! + IF( ln_timing ) CALL timing_stop('trc_trp') + ! + END SUBROUTINE trc_trp + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No TOP models + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_trp( kt ) ! Empty routine + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_trp: You should not have seen this print! error?', kt + END SUBROUTINE trc_trp +#endif + + !!====================================================================== +END MODULE trctrp diff --git a/V4.0/nemo_sources/src/TOP/TRP/trczdf.F90 b/V4.0/nemo_sources/src/TOP/TRP/trczdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bfc7dd48f54bd6eb70e2fad8fec665463568ea54 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trczdf.F90 @@ -0,0 +1,88 @@ +MODULE trczdf + !!============================================================================== + !! *** MODULE trczdf *** + !! Ocean Passive tracers : vertical diffusive trends + !!===================================================================== + !! History : 9.0 ! 2005-11 (G. Madec) Original code + !! NEMO 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.0 ! 2017-04 (G. Madec) remove the explicit case + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_zdf : update the tracer trend with the vertical diffusion + !!---------------------------------------------------------------------- + USE trc ! ocean passive tracers variables + USE oce_trc ! ocean dynamics and active tracers + USE trd_oce ! trends: ocean variables + USE trazdf ! tracer: vertical diffusion +!!gm do we really need this ? + USE trcldf ! passive tracers: lateral diffusion +!!gm + USE trdtra ! trends manager: tracers + USE prtctl_trc ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_zdf ! called by step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trczdf.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_zdf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_zdf *** + !! + !! ** Purpose : compute the vertical ocean tracer physics using + !! an implicit time-stepping scheme. + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: jk, jn + CHARACTER (len=22) :: charout + REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: ztrtrd ! 4D workspace + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_zdf') + ! + IF( l_trdtrc ) ztrtrd(:,:,:,:) = tra(:,:,:,:) + ! + CALL tra_zdf_imp( kt, nittrc000, 'TRC', r2dttrc, trb, tra, jptra ) ! implicit scheme + ! + IF( l_trdtrc ) THEN ! save the vertical diffusive trends for further diagnostics + DO jn = 1, jptra + DO jk = 1, jpkm1 + ztrtrd(:,:,jk,jn) = ( ( tra(:,:,jk,jn) - trb(:,:,jk,jn) ) / r2dttrc ) - ztrtrd(:,:,jk,jn) + END DO + CALL trd_tra( kt, 'TRC', jn, jptra_zdf, ztrtrd(:,:,:,jn) ) + END DO + ENDIF + ! ! print mean trends (used for debugging) + IF( ln_ctl ) THEN + WRITE(charout, FMT="('zdf ')") + CALL prt_ctl_trc_info(charout) + CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) + END IF + ! + IF( ln_timing ) CALL timing_stop('trc_zdf') + ! + END SUBROUTINE trc_zdf + +#else + !!---------------------------------------------------------------------- + !! Default option Empty module + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_zdf( kt ) + INTEGER, INTENT(in) :: kt + WRITE(*,*) 'trc_zdf: You should not have seen this print! error?', kt + END SUBROUTINE trc_zdf +#endif + !!============================================================================== +END MODULE trczdf diff --git a/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc.F90 b/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..33ab1b84291e5b50ebae7cc189c8816cfe88b591 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc.F90 @@ -0,0 +1,991 @@ +MODULE trdmxl_trc + !!====================================================================== + !! *** MODULE trdmxl_trc *** + !! Ocean diagnostics: mixed layer passive tracer trends + !!====================================================================== + !! History : 9.0 ! 06-08 (C. Deltel) Original code (from trdmxl.F90) + !! ! 07-04 (C. Deltel) Bug fix : add trcrad trends + !! ! 07-06 (C. Deltel) key_gyre : do not call lbc_lnk + !!---------------------------------------------------------------------- +#if defined key_top && defined key_trdmxl_trc + !!---------------------------------------------------------------------- + !! 'key_trdmxl_trc' mixed layer trend diagnostics + !!---------------------------------------------------------------------- + !! trd_mxl_trc : passive tracer cumulated trends averaged over ML + !! trd_mxl_trc_zint : passive tracer trends vertical integration + !! trd_mxl_trc_init : initialization step + !!---------------------------------------------------------------------- + USE trc ! tracer definitions (trn, trb, tra, etc.) + USE trc_oce, ONLY : nn_dttrc ! frequency of step on passive tracers + USE dom_oce ! domain definition + USE zdfmxl , ONLY : nmln ! number of level in the mixed layer + USE zdf_oce , ONLY : avs ! vert. diffusivity coef. at w-point for temp + USE trdtrc_oce ! definition of main arrays used for trends computations + USE in_out_manager ! I/O manager + USE dianam ! build the name of file (routine) + USE ldfslp ! iso-neutral slopes + USE ioipsl ! NetCDF library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE trdmxl_trc_rst ! restart for diagnosing the ML trends + USE prtctl ! print control + USE sms_pisces ! PISCES bio-model + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_mxl_trc + PUBLIC trd_mxl_trc_alloc + PUBLIC trd_mxl_trc_init + PUBLIC trd_mxl_trc_zint + + CHARACTER (LEN=40) :: clhstnam ! name of the trends NetCDF file + INTEGER :: nmoymltrd + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndextrd1, nidtrd, nh_t + INTEGER :: ndimtrd1 + INTEGER, SAVE :: ionce, icount + LOGICAL :: llwarn = .TRUE. ! this should always be .TRUE. + LOGICAL :: lldebug = .TRUE. + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: ztmltrd2 ! + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_trc.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_mxl_trc_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_trc_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ztmltrd2(jpi,jpj,jpltrd_trc,jptra) , & + & ndextrd1(jpi*jpj), nidtrd(jptra), nh_t(jptra), STAT=trd_mxl_trc_alloc) + ! + CALL mpp_sum ( 'trdmxl_trc', trd_mxl_trc_alloc ) + IF( trd_mxl_trc_alloc /=0 ) CALL ctl_stop( 'STOP', 'trd_mxl_trc_alloc: failed to allocate arrays' ) + ! + END FUNCTION trd_mxl_trc_alloc + + + SUBROUTINE trd_mxl_trc_zint( ptrc_trdmxl, ktrd, ctype, kjn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_trc_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 nctls_trc in namelist NAMTRD : + !! nctls_trc = -2 : use isopycnal surface + !! nctls_trc = -1 : use euphotic layer with light criterion + !! nctls_trc = 0 : use mixed layer with density criterion + !! nctls_trc = 1 : read index from file 'ctlsurf_idx' + !! nctls_trc > 1 : use fixed level surface jk = nctls_trc + !! Note: in the remainder of the routine, the volume between the + !! surface and the control surface is called "mixed-layer" + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT( in ) :: ktrd, kjn ! ocean trend index and passive tracer rank + CHARACTER(len=2), INTENT( in ) :: ctype ! surface/bottom (2D) or interior (3D) physics + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: ptrc_trdmxl ! passive tracer trend + ! + INTEGER :: ji, jj, jk, isum + REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk + !!---------------------------------------------------------------------- + + ! I. Definition of control surface and integration weights + ! -------------------------------------------------------- + + ONCE_PER_TIME_STEP : IF( icount == 1 ) THEN + ! + tmltrd_trc(:,:,:,:) = 0.e0 ! <<< reset trend arrays to zero + + ! ... Set nmld(ji,jj) = index of first T point below control surf. or outside mixed-layer + SELECT CASE ( nn_ctls_trc ) ! choice of the control surface + CASE ( -2 ) ; CALL ctl_stop( 'STOP', 'trdmxl_trc : not ready ' ) ! -> isopycnal surface (see ???) + CASE ( -1 ) ; nmld_trc(:,:) = neln(:,:) ! -> euphotic layer with light criterion + CASE ( 0 ) ; nmld_trc(:,:) = nmln(:,:) ! -> ML with density criterion (see zdfmxl) + CASE ( 1 ) ; nmld_trc(:,:) = nbol_trc(:,:) ! -> read index from file + CASE ( 2: ) ; nn_ctls_trc = MIN( nn_ctls_trc, jpktrd_trc - 1 ) + nmld_trc(:,:) = nn_ctls_trc + 1 ! -> model level + END SELECT + + ! ... Compute ndextrd1 and ndimtrd1 ??? role de jpktrd_trc + IF( ionce == 1 ) THEN + ! + isum = 0 ; zvlmsk(:,:) = 0.e0 + + IF( jpktrd_trc < jpk ) THEN ! description ??? + DO jj = 1, jpj + DO ji = 1, jpi + IF( nmld_trc(ji,jj) <= jpktrd_trc ) THEN + zvlmsk(ji,jj) = tmask(ji,jj,1) + ELSE + isum = isum + 1 + zvlmsk(ji,jj) = 0.e0 + ENDIF + END DO + END DO + ENDIF + + IF( isum > 0 ) THEN ! index of ocean points (2D only) + WRITE(numout,*)' tmltrd_trc : Number of invalid points nmld_trc > jpktrd', isum + CALL wheneq( jpi*jpj, zvlmsk(:,:) , 1, 1., ndextrd1, ndimtrd1 ) + ELSE + CALL wheneq( jpi*jpj, tmask(:,:,1), 1, 1., ndextrd1, ndimtrd1 ) + ENDIF + + ionce = 0 ! no more pass here + ! + ENDIF ! ionce == 1 + + ! ... Weights for vertical averaging + wkx_trc(:,:,:) = 0.e0 + DO jk = 1, jpktrd_trc ! initialize wkx_trc with vertical scale factor in mixed-layer + DO jj = 1, jpj + DO ji = 1, jpi + IF( jk - nmld_trc(ji,jj) < 0 ) wkx_trc(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) + END DO + END DO + END DO + + rmld_trc(:,:) = 0.e0 + DO jk = 1, jpktrd_trc ! compute mixed-layer depth : rmld_trc + rmld_trc(:,:) = rmld_trc(:,:) + wkx_trc(:,:,jk) + END DO + + DO jk = 1, jpktrd_trc ! compute integration weights + wkx_trc(:,:,jk) = wkx_trc(:,:,jk) / MAX( 1., rmld_trc(:,:) ) + END DO + + icount = 0 ! <<< flag = off : control surface & integr. weights + ! ! computed only once per time step + ENDIF ONCE_PER_TIME_STEP + + ! II. Vertical integration of trends in the mixed-layer + ! ----------------------------------------------------- + + SELECT CASE ( ctype ) + CASE ( '3D' ) ! mean passive tracer trends in the mixed-layer + DO jk = 1, jpktrd_trc + tmltrd_trc(:,:,ktrd,kjn) = tmltrd_trc(:,:,ktrd,kjn) + ptrc_trdmxl(:,:,jk) * wkx_trc(:,:,jk) + END DO + CASE ( '2D' ) ! forcing at upper boundary of the mixed-layer + tmltrd_trc(:,:,ktrd,kjn) = tmltrd_trc(:,:,ktrd,kjn) + ptrc_trdmxl(:,:,1) * wkx_trc(:,:,1) ! non penetrative + END SELECT + ! + END SUBROUTINE trd_mxl_trc_zint + + + SUBROUTINE trd_mxl_trc( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_trc *** + !! + !! ** 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_trc_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 ntrc_trc 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 ( nctls_trc > 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. ntrc_trc=5, rn_ucf_trc=1., nctls_trc=8 + !! for checking residuals. + !! On a NEC-SX5 computer, this typically leads to: + !! O(1.e-20) temp. residuals (tml_res) when ln_trdmxl_trc_instant=.false. + !! O(1.e-21) temp. residuals (tml_res) when ln_trdmxl_trc_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_mld 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 & al. + !! - See NEMO documentation (in preparation) + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk, jl, ik, it, itmod, jn + REAL(wp) :: zavt, zfn, zfn2 + ! + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmltot ! d(trc)/dt over the anlysis window (incl. Asselin) + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlres ! residual = dh/dt entrainment term + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlatf ! for storage only + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlrad ! for storage only (for trb<0 corr in trcrad) + ! + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmltot2 ! -+ + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlres2 ! | working arrays to diagnose the trends + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmltrdm2 ! | associated with the time meaned ML + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlatf2 ! | passive tracers + REAL(wp), DIMENSION(jpi,jpj,jptra) :: ztmlrad2 ! | (-> for trb<0 corr in trcrad) + ! + CHARACTER (LEN=10) :: clvar + !!---------------------------------------------------------------------- + + + IF( nn_dttrc /= 1 ) CALL ctl_stop( " Be careful, trends diags never validated " ) + + ! ====================================================================== + ! I. Diagnose the purely vertical (K_z) diffusion trend + ! ====================================================================== + + ! ... These terms can be estimated by flux computation at the lower boundary of the ML + ! (we compute (-1/h) * K_z * d_z( tracer )) + + IF( ln_trcldf_iso ) THEN + ! + DO jn = 1, jptra + DO jj = 1, jpj + DO ji = 1, jpi + ik = nmld_trc(ji,jj) + IF( ln_trdtrc(jn) ) & + tmltrd_trc(ji,jj,jpmxl_trc_zdf,jn) = - avs(ji,jj,ik) / e3w_n(ji,jj,ik) * tmask(ji,jj,ik) & + & * ( trn(ji,jj,ik-1,jn) - trn(ji,jj,ik,jn) ) & + & / MAX( 1., rmld_trc(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + END DO + + DO jn = 1, jptra + ! ... Remove this K_z trend from the iso-neutral diffusion term (if any) + IF( ln_trdtrc(jn) ) & + tmltrd_trc(:,:,jpmxl_trc_ldf,jn) = tmltrd_trc(:,:,jpmxl_trc_ldf,jn) - tmltrd_trc(:,:,jpmxl_trc_zdf,jn) + + END DO + ! + ENDIF + +!!gm Test removed, nothing specific to a configuration should survive out of usrdef modules +!!gm IF ( cn_cfg .NE. 'gyre' ) THEN ! other than GYRE configuration +!!gm ! GYRE : for diagnostic fields, are needed if cyclic B.C. are present, but not for purely MPI comm. +!!gm ! therefore we do not call lbc_lnk in GYRE config. (closed basin, no cyclic B.C.) + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + DO jl = 1, jpltrd_trc + CALL lbc_lnk( 'trdmxl_trc', tmltrd_trc(:,:,jl,jn), 'T', 1. ) ! lateral boundary conditions + END DO + ENDIF + END DO +!!gm ENDIF + + ! ====================================================================== + ! II. Cumulate the trends over the analysis window + ! ====================================================================== + + ztmltrd2(:,:,:,:) = 0.e0 ; ztmltot2(:,:,:) = 0.e0 ! <<< reset arrays to zero + ztmlres2(:,:,:) = 0.e0 ; ztmlatf2(:,:,:) = 0.e0 + ztmlrad2(:,:,:) = 0.e0 + + ! II.1 Set before values of vertically averages passive tracers + ! ------------------------------------------------------------- + IF( kt > nittrc000 ) THEN + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + tmlb_trc (:,:,jn) = tml_trc (:,:,jn) + tmlatfn_trc(:,:,jn) = tmltrd_trc(:,:,jpmxl_trc_atf,jn) + tmlradn_trc(:,:,jn) = tmltrd_trc(:,:,jpmxl_trc_radb,jn) + ENDIF + END DO + ENDIF + + ! II.2 Vertically averaged passive tracers + ! ---------------------------------------- + tml_trc(:,:,:) = 0.e0 + DO jk = 1, jpktrd_trc ! - 1 ??? + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) & + tml_trc(:,:,jn) = tml_trc(:,:,jn) + wkx_trc(:,:,jk) * trn(:,:,jk,jn) + END DO + END DO + + ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window + ! ------------------------------------------------------------------------ + IF( kt == nittrc000 + nn_dttrc ) THEN ! i.e. ( .NOT. ln_rstart ).AND.( kt == nit000 + 1) ??? + ! + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + tmlbb_trc (:,:,jn) = tmlb_trc (:,:,jn) ; tmlbn_trc (:,:,jn) = tml_trc (:,:,jn) + tmlatfb_trc(:,:,jn) = tmlatfn_trc(:,:,jn) ; tmlradb_trc(:,:,jn) = tmlradn_trc(:,:,jn) + + tmltrd_csum_ub_trc (:,:,:,jn) = 0.e0 ; tmltrd_atf_sumb_trc (:,:,jn) = 0.e0 + tmltrd_rad_sumb_trc (:,:,jn) = 0.e0 + ENDIF + END DO + + rmldbn_trc(:,:) = rmld_trc(:,:) + ! + ENDIF + + ! 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 + ! ntrd 2*ntrd etc. + ! 1 2 3 4 =5 e.g. =10 + ! + IF( ( kt >= 2 ).OR.( ln_rsttr ) ) THEN ! ??? + ! + nmoymltrd = nmoymltrd + 1 + + + ! ... Cumulate over BOTH physical contributions AND over time steps + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + DO jl = 1, jpltrd_trc + tmltrdm_trc(:,:,jn) = tmltrdm_trc(:,:,jn) + tmltrd_trc(:,:,jl,jn) + END DO + ENDIF + END DO + + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + ! ... Special handling of the Asselin trend + tmlatfm_trc(:,:,jn) = tmlatfm_trc(:,:,jn) + tmlatfn_trc(:,:,jn) + tmlradm_trc(:,:,jn) = tmlradm_trc(:,:,jn) + tmlradn_trc(:,:,jn) + + ! ... Trends associated with the time mean of the ML passive tracers + tmltrd_sum_trc (:,:,:,jn) = tmltrd_sum_trc (:,:,:,jn) + tmltrd_trc (:,:,:,jn) + tmltrd_csum_ln_trc(:,:,:,jn) = tmltrd_csum_ln_trc(:,:,:,jn) + tmltrd_sum_trc(:,:,:,jn) + tml_sum_trc (:,:,jn) = tml_sum_trc (:,:,jn) + tml_trc (:,:,jn) + ENDIF + ENDDO + + rmld_sum_trc (:,:) = rmld_sum_trc (:,:) + rmld_trc (:,:) + ! + ENDIF + + ! ====================================================================== + ! III. Prepare fields for output (get here ONCE PER ANALYSIS PERIOD) + ! ====================================================================== + + ! Convert to appropriate physical units + tmltrd_trc(:,:,:,:) = tmltrd_trc(:,:,:,:) * rn_ucf_trc + + itmod = kt - nittrc000 + 1 + it = kt + + MODULO_NTRD : IF( MOD( itmod, nn_trd_trc ) == 0 ) THEN ! nitend MUST be multiple of nn_trd_trc + ! + ztmltot (:,:,:) = 0.e0 ! reset arrays to zero + ztmlres (:,:,:) = 0.e0 + ztmltot2(:,:,:) = 0.e0 + ztmlres2(:,:,:) = 0.e0 + + zfn = FLOAT( nmoymltrd ) ; zfn2 = zfn * zfn + + ! III.1 Prepare fields for output ("instantaneous" diagnostics) + ! ------------------------------------------------------------- + + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + !-- Compute total trends (use rdttrc instead of rdt ???) + IF ( ln_trcadv_muscl .OR. ln_trcadv_muscl2 ) THEN ! EULER-FORWARD schemes + ztmltot(:,:,jn) = ( tml_trc(:,:,jn) - tmlbn_trc(:,:,jn) )/rdt + ELSE ! LEAP-FROG schemes + ztmltot(:,:,jn) = ( tml_trc(:,:,jn) - tmlbn_trc(:,:,jn) + tmlb_trc(:,:,jn) - tmlbb_trc(:,:,jn))/(2.*rdt) + ENDIF + + !-- Compute residuals + ztmlres(:,:,jn) = ztmltot(:,:,jn) - ( tmltrdm_trc(:,:,jn) - tmlatfn_trc(:,:,jn) + tmlatfb_trc(:,:,jn) & + & - tmlradn_trc(:,:,jn) + tmlradb_trc(:,:,jn) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf(:,:,jn) = tmlatfm_trc(:,:,jn) - tmlatfn_trc(:,:,jn) + tmlatfb_trc(:,:,jn) + ztmlrad(:,:,jn) = tmlradm_trc(:,:,jn) - tmlradn_trc(:,:,jn) + tmlradb_trc(:,:,jn) + + !-- Lateral boundary conditions + IF ( cn_cfg .NE. 'gyre' ) THEN + CALL lbc_lnk_multi( 'trdmxl_trc', ztmltot(:,:,jn) , 'T', 1. , ztmlres(:,:,jn) , 'T', 1., & + & ztmlatf(:,:,jn) , 'T', 1. , ztmlrad(:,:,jn) , 'T', 1. ) + ENDIF + + +#if defined key_diainstant + CALL ctl_stop( 'STOP', 'tmltrd_trc : key_diainstant was never checked within trdmxl. Comment this to proceed.' ) +#endif + ENDIF + END DO + + ! III.2 Prepare fields for output ("mean" diagnostics) + ! ---------------------------------------------------- + + !-- Update the ML depth time sum (to build the Leap-Frog time mean) + rmld_sum_trc(:,:) = rmldbn_trc(:,:) + 2 * ( rmld_sum_trc(:,:) - rmld_trc(:,:) ) + rmld_trc(:,:) + + !-- Compute passive tracer total trends + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + tml_sum_trc(:,:,jn) = tmlbn_trc(:,:,jn) + 2 * ( tml_sum_trc(:,:,jn) - tml_trc(:,:,jn) ) + tml_trc(:,:,jn) + ztmltot2 (:,:,jn) = ( tml_sum_trc(:,:,jn) - tml_sumb_trc(:,:,jn) ) / ( 2.*rdt ) ! now tracer unit is /sec + ENDIF + END DO + + !-- Compute passive tracer residuals + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + ! + DO jl = 1, jpltrd_trc + ztmltrd2(:,:,jl,jn) = tmltrd_csum_ub_trc(:,:,jl,jn) + tmltrd_csum_ln_trc(:,:,jl,jn) + END DO + + ztmltrdm2(:,:,jn) = 0.e0 + DO jl = 1, jpltrd_trc + ztmltrdm2(:,:,jn) = ztmltrdm2(:,:,jn) + ztmltrd2(:,:,jl,jn) + END DO + + ztmlres2(:,:,jn) = ztmltot2(:,:,jn) - & + & ( ztmltrdm2(:,:,jn) - tmltrd_sum_trc(:,:,jpmxl_trc_atf ,jn) + tmltrd_atf_sumb_trc(:,:,jn) & + & - tmltrd_sum_trc(:,:,jpmxl_trc_radb,jn) + tmltrd_rad_sumb_trc(:,:,jn) ) + ! + + !-- Diagnose Asselin trend over the analysis window + ztmlatf2(:,:,jn) = ztmltrd2(:,:,jpmxl_trc_atf ,jn) - tmltrd_sum_trc(:,:,jpmxl_trc_atf ,jn) & + & + tmltrd_atf_sumb_trc(:,:,jn) + ztmlrad2(:,:,jn) = ztmltrd2(:,:,jpmxl_trc_radb,jn) - tmltrd_sum_trc(:,:,jpmxl_trc_radb,jn) & + & + tmltrd_rad_sumb_trc(:,:,jn) + + !-- Lateral boundary conditions + IF ( cn_cfg .NE. 'gyre' ) THEN ! other than GYRE configuration + CALL lbc_lnk_multi( 'trdmxl_trc', ztmltot2(:,:,jn), 'T', 1., ztmlres2(:,:,jn), 'T', 1. ) + DO jl = 1, jpltrd_trc + CALL lbc_lnk( 'trdmxl_trc', ztmltrd2(:,:,jl,jn), 'T', 1. ) ! will be output in the NetCDF trends file + END DO + ENDIF + + ENDIF + END DO + + ! * Debugging information * + IF( lldebug ) THEN + ! + WRITE(numout,*) 'trd_mxl_trc : write trends in the Mixed Layer for debugging process:' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) + WRITE(numout,*) 'TRC kt = ', kt, ' nmoymltrd = ', nmoymltrd + + DO jn = 1, jptra + + IF( ln_trdtrc(jn) ) THEN + WRITE(numout, *) + WRITE(numout, *) '>>>>>>>>>>>>>>>>>> TRC TRACER jn =', jn, ' <<<<<<<<<<<<<<<<<<' + + WRITE(numout, *) + WRITE(numout,98) 'TRC jn =', jn, ' SUM ztmlres : ', SUM2D(ztmlres(:,:,jn)) + !CD??? PREVOIR: z2d = ztmlres(:,:,jn) ; CALL prt_ctl(tab2d_1=z2d, clinfo1=' ztmlres - : ') + + WRITE(numout,98) 'TRC jn =', jn, ' SUM ABS(ztmlres): ', SUM2D(ABS(ztmlres(:,:,jn))) + WRITE(numout, '(3x,a)') ' -->>>------------------- ztmlres is computed from ------------- ' + WRITE(numout,98) 'TRC jn =', jn, ' SUM +ztmltot : ', SUM2D(+ztmltot (:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmltrdm_trc: ', SUM2D(+tmltrdm_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmlatfn_trc: ', SUM2D(-tmlatfn_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmlatfb_trc: ', SUM2D(+tmlatfb_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmlradn_trc: ', SUM2D(-tmlradn_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmlradb_trc: ', SUM2D(+tmlradb_trc(:,:,jn)) + WRITE(numout, '(3x,a)') ' --<<<----------------------------------------------------------- ' + + WRITE(numout, *) + WRITE(numout,98) 'TRC jn =', jn, ' SUM ztmlres2 : ', SUM2D(ztmlres2(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM ABS(ztmlres2):', SUM2D(ABS(ztmlres2(:,:,jn))) + WRITE(numout, '(3x,a)') ' -->>>------------------- ztmlres2 is computed from ------------ ' + WRITE(numout,98) 'TRC jn =', jn, ' SUM +ztmltot2 : ', SUM2D(+ztmltot2(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +ztmltrdm2 : ', SUM2D(+ztmltrdm2(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmltrd_sum_trc : ', SUM2D(-tmltrd_sum_trc(:,:,jpmxl_trc_atf,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmltrd_atf_sumb_trc : ', SUM2D(+tmltrd_atf_sumb_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmltrd_sum_trc : ', SUM2D(-tmltrd_sum_trc(:,:,jpmxl_trc_radb,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmltrd_rad_sumb_trc : ', SUM2D(+tmltrd_rad_sumb_trc(:,:,jn) ) + WRITE(numout, '(3x,a)') ' --<<<----------------------------------------------------------- ' + + WRITE(numout, *) + WRITE(numout,98) 'TRC jn =', jn, ' SUM ztmltot : ', SUM2D(ztmltot (:,:,jn)) + WRITE(numout, '(3x,a)') ' -->>>------------------- ztmltot is computed from ------------- ' + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tml_trc : ', SUM2D(tml_trc (:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmlbn_trc : ', SUM2D(tmlbn_trc (:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM +tmlb_trc : ', SUM2D(tmlb_trc (:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM -tmlbb_trc : ', SUM2D(tmlbb_trc (:,:,jn)) + WRITE(numout, '(3x,a)') ' --<<<----------------------------------------------------------- ' + + WRITE(numout, *) + WRITE(numout,98) 'TRC jn =', jn, ' SUM tmltrdm_trc : ', SUM2D(tmltrdm_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM tmlatfb_trc : ', SUM2D(tmlatfb_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM tmlatfn_trc : ', SUM2D(tmlatfn_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM tmlradb_trc : ', SUM2D(tmlradb_trc(:,:,jn)) + WRITE(numout,98) 'TRC jn =', jn, ' SUM tmlradn_trc : ', SUM2D(tmlradn_trc(:,:,jn)) + + WRITE(numout, *) + DO jl = 1, jpltrd_trc + WRITE(numout,97) 'TRC jn =', jn, ' TREND INDEX jpmxl_trc_xxx = ', jl, & + & ' SUM tmltrd_trc : ', SUM2D(tmltrd_trc(:,:,jl,jn)) + END DO + + WRITE(numout,*) + WRITE(numout,*) ' *********************** ZTMLRES, ZTMLRES2 *********************** ' + WRITE(numout,*) + WRITE(numout,*) 'TRC ztmlres (jpi/2,jpj/2,:) : ', ztmlres (jpi/2,jpj/2,jn) + WRITE(numout,*) + WRITE(numout,*) 'TRC ztmlres2(jpi/2,jpj/2,:) : ', ztmlres2(jpi/2,jpj/2,jn) + + WRITE(numout,*) + WRITE(numout,*) ' *********************** ZTMLRES *********************** ' + WRITE(numout,*) + + WRITE(numout,*) '...................................................' + WRITE(numout,*) 'TRC jn =', jn, ' ztmlres (1:10,1:5,jn) : ' + DO jj = 5, 1, -1 + WRITE(numout,99) jj, ( ztmlres (ji,jj,jn), ji=1,10 ) + END DO + + WRITE(numout,*) + WRITE(numout,*) ' *********************** ZTMLRES2 *********************** ' + WRITE(numout,*) + + WRITE(numout,*) '...................................................' + WRITE(numout,*) 'TRC jn =', jn, ' ztmlres2 (1:10,1:5,jn) : ' + DO jj = 5, 1, -1 + WRITE(numout,99) jj, ( ztmlres2 (ji,jj,jn), ji=1,10 ) + END DO + ! + ENDIF + ! + END DO + + +97 FORMAT(a10, i3, 2x, a30, i3, a20, 2x, g20.10) +98 FORMAT(a10, i3, 2x, a30, 2x, g20.10) +99 FORMAT('TRC jj =', i3,' : ', 10(g10.3,2x)) + WRITE(numout,*) + ! + ENDIF + + ! III.3 Time evolution array swap + ! ------------------------------- + ! ML depth + rmldbn_trc(:,:) = rmld_trc(:,:) + rmld_sum_trc(:,:) = rmld_sum_trc(:,:) / (2*zfn) ! similar to tml_sum and sml_sum + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) THEN + ! For passive tracer instantaneous diagnostics + tmlbb_trc (:,:,jn) = tmlb_trc (:,:,jn) ; tmlbn_trc (:,:,jn) = tml_trc (:,:,jn) + tmlatfb_trc(:,:,jn) = tmlatfn_trc(:,:,jn) ; tmlradb_trc(:,:,jn) = tmlradn_trc(:,:,jn) + + ! For passive tracer mean diagnostics + tmltrd_csum_ub_trc (:,:,:,jn) = zfn * tmltrd_sum_trc(:,:,:,jn) - tmltrd_csum_ln_trc(:,:,:,jn) + tml_sumb_trc (:,:,jn) = tml_sum_trc(:,:,jn) + tmltrd_atf_sumb_trc(:,:,jn) = tmltrd_sum_trc(:,:,jpmxl_trc_atf ,jn) + tmltrd_rad_sumb_trc(:,:,jn) = tmltrd_sum_trc(:,:,jpmxl_trc_radb,jn) + + + ! III.4 Convert to appropriate physical units + ! ------------------------------------------- + ztmltot (:,:,jn) = ztmltot (:,:,jn) * rn_ucf_trc/zfn ! instant diags + ztmlres (:,:,jn) = ztmlres (:,:,jn) * rn_ucf_trc/zfn + ztmlatf (:,:,jn) = ztmlatf (:,:,jn) * rn_ucf_trc/zfn + ztmlrad (:,:,jn) = ztmlrad (:,:,jn) * rn_ucf_trc/zfn + tml_sum_trc (:,:,jn) = tml_sum_trc (:,:,jn) / (2*zfn) ! mean diags + ztmltot2 (:,:,jn) = ztmltot2 (:,:,jn) * rn_ucf_trc/zfn2 + ztmltrd2 (:,:,:,jn) = ztmltrd2 (:,:,:,jn) * rn_ucf_trc/zfn2 + ztmlatf2 (:,:,jn) = ztmlatf2 (:,:,jn) * rn_ucf_trc/zfn2 + ztmlrad2 (:,:,jn) = ztmlrad2 (:,:,jn) * rn_ucf_trc/zfn2 + ztmlres2 (:,:,jn) = ztmlres2 (:,:,jn) * rn_ucf_trc/zfn2 + ENDIF + END DO + ! + ENDIF MODULO_NTRD + + ! ====================================================================== + ! IV. Write trends in the NetCDF file + ! ====================================================================== + + ! IV.1 Code for IOIPSL/NetCDF output + ! ---------------------------------- + + IF( lwp .AND. MOD( itmod , nn_trd_trc ) == 0 ) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) 'trd_mxl_trc : write passive tracer trends in the NetCDF file :' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) ' ', trim(clhstnam), ' at kt = ', kt + WRITE(numout,*) ' N.B. nmoymltrd = ', nmoymltrd + WRITE(numout,*) ' ' + ENDIF + + NETCDF_OUTPUT : IF( ln_trdmxl_trc_instant ) THEN ! <<< write the trends for passive tracer instant. diags + ! + + DO jn = 1, jptra + ! + IF( ln_trdtrc(jn) ) THEN + CALL histwrite( nidtrd(jn), "mxl_depth", it, rmld_trc(:,:), ndimtrd1, ndextrd1 ) + !-- Output the fields + clvar = trim(ctrcnm(jn))//"ml" ! e.g. detml, zooml, nh4ml, etc. + CALL histwrite( nidtrd(jn), trim(clvar) , it, tml_trc(:,:,jn), ndimtrd1, ndextrd1 ) + CALL histwrite( nidtrd(jn), trim(clvar)//"_tot" , it, ztmltot(:,:,jn), ndimtrd1, ndextrd1 ) + CALL histwrite( nidtrd(jn), trim(clvar)//"_res" , it, ztmlres(:,:,jn), ndimtrd1, ndextrd1 ) + + DO jl = 1, jpltrd_trc - 2 + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jl,2)), & + & it, tmltrd_trc(:,:,jl,jn), ndimtrd1, ndextrd1 ) + END DO + + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_radb,2)), & ! now trcrad : jpltrd_trc - 1 + & it, ztmlrad(:,:,jn), ndimtrd1, ndextrd1 ) + + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_atf,2)), & ! now Asselin : jpltrd_trc + & it, ztmlatf(:,:,jn), ndimtrd1, ndextrd1 ) + + ENDIF + END DO + + IF( kt == nitend ) THEN + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) CALL histclo( nidtrd(jn) ) + END DO + ENDIF + + ELSE ! <<< write the trends for passive tracer mean diagnostics + + DO jn = 1, jptra + ! + IF( ln_trdtrc(jn) ) THEN + CALL histwrite( nidtrd(jn), "mxl_depth", it, rmld_sum_trc(:,:), ndimtrd1, ndextrd1 ) + !-- Output the fields + clvar = trim(ctrcnm(jn))//"ml" ! e.g. detml, zooml, nh4ml, etc. + + CALL histwrite( nidtrd(jn), trim(clvar) , it, tml_sum_trc(:,:,jn), ndimtrd1, ndextrd1 ) + CALL histwrite( nidtrd(jn), trim(clvar)//"_tot" , it, ztmltot2(:,:,jn), ndimtrd1, ndextrd1 ) + CALL histwrite( nidtrd(jn), trim(clvar)//"_res" , it, ztmlres2(:,:,jn), ndimtrd1, ndextrd1 ) + + DO jl = 1, jpltrd_trc - 2 + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jl,2)), & + & it, ztmltrd2(:,:,jl,jn), ndimtrd1, ndextrd1 ) + END DO + + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_radb,2)), & ! now trcrad : jpltrd_trc - 1 + & it, ztmlrad2(:,:,jn), ndimtrd1, ndextrd1 ) + + CALL histwrite( nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_atf,2)), & ! now Asselin : jpltrd_trc + & it, ztmlatf2(:,:,jn), ndimtrd1, ndextrd1 ) + + ENDIF + ! + END DO + IF( kt == nitend ) THEN + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) CALL histclo( nidtrd(jn) ) + END DO + ENDIF + + ! + ENDIF NETCDF_OUTPUT + + ! Compute the control surface (for next time step) : flag = on + icount = 1 + + IF( MOD( itmod, nn_trd_trc ) == 0 ) THEN + ! + ! Reset cumulative arrays to zero + ! ------------------------------- + nmoymltrd = 0 + tmltrdm_trc (:,:,:) = 0.e0 ; tmlatfm_trc (:,:,:) = 0.e0 + tmlradm_trc (:,:,:) = 0.e0 ; tml_sum_trc (:,:,:) = 0.e0 + tmltrd_csum_ln_trc (:,:,:,:) = 0.e0 ; tmltrd_sum_trc (:,:,:,:) = 0.e0 + rmld_sum_trc (:,:) = 0.e0 + ! + ENDIF + + ! ====================================================================== + ! V. Write restart file + ! ====================================================================== + + IF( lrst_trc ) CALL trd_mxl_trc_rst_write( kt ) ! this must be after the array swap above (III.3) + ! + END SUBROUTINE trd_mxl_trc + + REAL FUNCTION sum2d( ztab ) + !!---------------------------------------------------------------------- + !! CD ??? prevoir d'utiliser plutot prtctl + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ztab + !!---------------------------------------------------------------------- + sum2d = SUM( ztab(2:jpi-1,2:jpj-1) ) + END FUNCTION sum2d + + + SUBROUTINE trd_mxl_trc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_init *** + !! + !! ** Purpose : computation of vertically integrated T and S budgets + !! from ocean surface down to control surface (NetCDF output) + !! + !! ** Method/usage : + !! + !!---------------------------------------------------------------------- + INTEGER :: inum ! logical unit + INTEGER :: ilseq, jl, jn, iiter + REAL(wp) :: zjulian, zsto, zout + CHARACTER (LEN=40) :: clop + CHARACTER (LEN=15) :: csuff + CHARACTER (LEN=12) :: clmxl + CHARACTER (LEN=16) :: cltrcu + CHARACTER (LEN=10) :: clvar + + !!---------------------------------------------------------------------- + + ! ====================================================================== + ! I. initialization + ! ====================================================================== + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_trc_init : Mixed-layer trends for passive tracers ' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + + ! I.1 Check consistency of user defined preferences + ! ------------------------------------------------- + + IF( ( lk_trdmxl_trc ) .AND. ( MOD( nitend-nittrc000+1, nn_trd_trc ) /= 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_trc = ', nn_trd_trc + 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 sea-ice frequency parameter (typically 5) ' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) + ENDIF + + ! * Debugging information * + IF( lldebug ) THEN + WRITE(numout,*) ' ln_trcadv_muscl = ' , ln_trcadv_muscl + WRITE(numout,*) ' ln_trdmxl_trc_instant = ', ln_trdmxl_trc_instant + ENDIF + + IF( ( ln_trcadv_muscl .OR. ln_trcadv_muscl2 ) .AND. .NOT. ln_trdmxl_trc_instant ) THEN + WRITE(ctmp1,*) ' Currently, you can NOT use simultaneously tracer MUSCL ' + WRITE(ctmp2,*) ' advection and window averaged diagnostics of ML trends. ' + WRITE(ctmp3,*) ' WHY? Everything in trdmxl_trc is coded for leap-frog, and ' + WRITE(ctmp4,*) ' MUSCL scheme is Euler forward for passive tracers (note ' + WRITE(ctmp5,*) ' that MUSCL is leap-frog for active tracers T/S). ' + WRITE(ctmp6,*) ' In particuliar, entrainment trend would be FALSE. However ' + WRITE(ctmp7,*) ' this residual is correct for instantaneous ML diagnostics.' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7 ) + ENDIF + + ! I.2 Initialize arrays to zero or read a restart file + ! ---------------------------------------------------- + nmoymltrd = 0 + + rmld_trc (:,:) = 0.e0 ; tml_trc (:,:,:) = 0.e0 ! inst. + tmltrdm_trc (:,:,:) = 0.e0 ; tmlatfm_trc (:,:,:) = 0.e0 + tmlradm_trc (:,:,:) = 0.e0 + + tml_sum_trc (:,:,:) = 0.e0 ; tmltrd_sum_trc (:,:,:,:) = 0.e0 ! mean + tmltrd_csum_ln_trc (:,:,:,:) = 0.e0 ; rmld_sum_trc (:,:) = 0.e0 + + IF( ln_rsttr .AND. ln_trdmxl_trc_restart ) THEN + CALL trd_mxl_trc_rst_read + ELSE + tmlb_trc (:,:,:) = 0.e0 ; tmlbb_trc (:,:,:) = 0.e0 ! inst. + tmlbn_trc (:,:,:) = 0.e0 + + tml_sumb_trc (:,:,:) = 0.e0 ; tmltrd_csum_ub_trc (:,:,:,:) = 0.e0 ! mean + tmltrd_atf_sumb_trc(:,:,:) = 0.e0 ; tmltrd_rad_sumb_trc(:,:,:) = 0.e0 + + ENDIF + + icount = 1 ; ionce = 1 ! open specifier + + + ! I.3 Read control surface from file ctlsurf_idx + ! ---------------------------------------------- + IF( nn_ctls_trc == 1 ) THEN + CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + READ ( inum ) nbol_trc + CLOSE( inum ) + ENDIF + + ! ====================================================================== + ! II. netCDF output initialization + ! ====================================================================== + + ! clmxl = legend root for netCDF output + IF( nn_ctls_trc == 0 ) THEN ! control surface = mixed-layer with density criterion + clmxl = 'Mixed Layer ' + ELSE IF( nn_ctls_trc == 1 ) THEN ! control surface = read index from file + clmxl = ' Bowl ' + ELSE IF( nn_ctls_trc >= 2 ) THEN ! control surface = model level + WRITE(clmxl,'(A10,I2,1X)') 'Levels 1 -', nn_ctls_trc + ENDIF + + ! 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 cp time) + ENDIF +# if defined key_diainstant + IF( .NOT. ln_trdmxl_trc_instant ) THEN + CALL ctl_stop( 'STOP', 'trd_mxl_trc : this was never checked. Comment this line to proceed...' ) + ENDIF + zsto = nn_trd_trc * rdt + clop = "inst("//TRIM(clop)//")" +# else + IF( ln_trdmxl_trc_instant ) THEN + zsto = rdt ! inst. diags : we use IOIPSL time averaging + ELSE + zsto = nn_trd_trc * rdt ! mean diags : we DO NOT use any IOIPSL time averaging + ENDIF + clop = "ave("//TRIM(clop)//")" +# endif + zout = nn_trd_trc * rdt + iiter = ( nittrc000 - 1 ) / nn_dttrc + + 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 :', nittrc000 & + & ,' YEAR ', nyear, ' MONTH ', nmonth,' DAY ', nday & + & ,'Julian day : ', zjulian + + ! II.3 Define the T grid trend file (nidtrd) + ! ------------------------------------------ + + !-- Define long and short names for the NetCDF output variables + ! ==> choose them according to trdmxl_trc_oce.F90 <== + + ctrd_trc(jpmxl_trc_xad ,1) = " Zonal advection" ; ctrd_trc(jpmxl_trc_xad ,2) = "_xad" + ctrd_trc(jpmxl_trc_yad ,1) = " Meridional advection" ; ctrd_trc(jpmxl_trc_yad ,2) = "_yad" + ctrd_trc(jpmxl_trc_zad ,1) = " Vertical advection" ; ctrd_trc(jpmxl_trc_zad ,2) = "_zad" + ctrd_trc(jpmxl_trc_ldf ,1) = " Lateral diffusion" ; ctrd_trc(jpmxl_trc_ldf ,2) = "_ldf" + ctrd_trc(jpmxl_trc_zdf ,1) = " Vertical diff. (Kz)" ; ctrd_trc(jpmxl_trc_zdf ,2) = "_zdf" + ctrd_trc(jpmxl_trc_bbl ,1) = " Adv/diff. Bottom boundary layer" ; ctrd_trc(jpmxl_trc_bbl ,2) = "_bbl" + ctrd_trc(jpmxl_trc_dmp ,1) = " Tracer damping" ; ctrd_trc(jpmxl_trc_dmp ,2) = "_dmp" + ctrd_trc(jpmxl_trc_sbc ,1) = " Surface boundary cond." ; ctrd_trc(jpmxl_trc_sbc ,2) = "_sbc" + ctrd_trc(jpmxl_trc_sms, 1) = " Sources minus sinks" ; ctrd_trc(jpmxl_trc_sms ,2) = "_sms" + ctrd_trc(jpmxl_trc_radb ,1) = " Correct negative concentrations" ; ctrd_trc(jpmxl_trc_radb ,2) = "_radb" + ctrd_trc(jpmxl_trc_radn ,1) = " Correct negative concentrations" ; ctrd_trc(jpmxl_trc_radn ,2) = "_radn" + ctrd_trc(jpmxl_trc_atf ,1) = " Asselin time filter" ; ctrd_trc(jpmxl_trc_atf ,2) = "_atf" + + DO jn = 1, jptra + !-- Create a NetCDF file and enter the define mode + IF( ln_trdtrc(jn) ) THEN + csuff="ML_"//ctrcnm(jn) + CALL dia_nam( clhstnam, nn_trd_trc, csuff ) + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & + & 1, jpi, 1, jpj, iiter, zjulian, rdt, nh_t(jn), nidtrd(jn), domain_id=nidom, snc4chunks=snc4set ) + + !-- Define the ML depth variable + CALL histdef(nidtrd(jn), "mxl_depth", clmxl//" Mixed Layer Depth", "m", & + & jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + + ENDIF + END DO + + !-- Define physical units + IF( rn_ucf_trc == 1. ) THEN + cltrcu = "(mmole-N/m3)/sec" ! all passive tracers have the same unit + ELSEIF ( rn_ucf_trc == 3600.*24.) THEN ! ??? trop long : seulement (mmole-N/m3) + cltrcu = "(mmole-N/m3)/day" ! ??? apparait dans les sorties netcdf + ELSE + cltrcu = "unknown?" + ENDIF + + !-- Define miscellaneous passive tracer mixed-layer variables + IF( jpltrd_trc /= jpmxl_trc_atf .OR. jpltrd_trc - 1 /= jpmxl_trc_radb ) THEN + CALL ctl_stop( 'STOP', 'Error : jpltrd_trc /= jpmxl_trc_atf .OR. jpltrd_trc - 1 /= jpmxl_trc_radb' ) ! see below + ENDIF + + DO jn = 1, jptra + ! + IF( ln_trdtrc(jn) ) THEN + clvar = trim(ctrcnm(jn))//"ml" ! e.g. detml, zooml, no3ml, etc. + CALL histdef(nidtrd(jn), trim(clvar), clmxl//" "//trim(ctrcnm(jn))//" Mixed Layer ", & + & "mmole-N/m3", jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef(nidtrd(jn), trim(clvar)//"_tot" , clmxl//" "//trim(ctrcnm(jn))//" Total trend ", & + & cltrcu, jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zout, zout ) + CALL histdef(nidtrd(jn), trim(clvar)//"_res" , clmxl//" "//trim(ctrcnm(jn))//" dh/dt Entrainment (Resid.)", & + & cltrcu, jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zout, zout ) + + DO jl = 1, jpltrd_trc - 2 ! <== only true if jpltrd_trc == jpmxl_trc_atf + CALL histdef(nidtrd(jn), trim(clvar)//trim(ctrd_trc(jl,2)), clmxl//" "//clvar//ctrd_trc(jl,1), & + & cltrcu, jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zsto, zout ) ! IOIPSL: time mean + END DO ! if zsto=rdt above + + CALL histdef(nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_radb,2)), clmxl//" "//clvar//ctrd_trc(jpmxl_trc_radb,1), & + & cltrcu, jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zout, zout ) ! IOIPSL: NO time mean + + CALL histdef(nidtrd(jn), trim(clvar)//trim(ctrd_trc(jpmxl_trc_atf,2)), clmxl//" "//clvar//ctrd_trc(jpmxl_trc_atf,1), & + & cltrcu, jpi, jpj, nh_t(jn), 1 , 1, 1 , -99 , 32, clop, zout, zout ) ! IOIPSL: NO time mean + ! + ENDIF + END DO + + !-- Leave IOIPSL/NetCDF define mode + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) CALL histend( nidtrd(jn), snc4set ) + END DO + + IF(lwp) WRITE(numout,*) + + END SUBROUTINE trd_mxl_trc_init + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trd_mxl_trc( kt ) ! Empty routine + INTEGER, INTENT( in) :: kt + WRITE(*,*) 'trd_mxl_trc: You should not have seen this print! error?', kt + END SUBROUTINE trd_mxl_trc + SUBROUTINE trd_mxl_trc_zint( ptrc_trdmxl, ktrd, ctype, kjn ) + INTEGER , INTENT( in ) :: ktrd, kjn ! ocean trend index and passive tracer rank + CHARACTER(len=2) , INTENT( in ) :: ctype ! surface/bottom (2D) or interior (3D) physics + REAL, DIMENSION(:,:,:), INTENT( in ) :: ptrc_trdmxl ! passive trc trend + WRITE(*,*) 'trd_mxl_trc_zint: You should not have seen this print! error?', ptrc_trdmxl(1,1,1) + WRITE(*,*) ' " " : You should not have seen this print! error?', ctype + WRITE(*,*) ' " " : You should not have seen this print! error?', ktrd + WRITE(*,*) ' " " : You should not have seen this print! error?', kjn + END SUBROUTINE trd_mxl_trc_zint + SUBROUTINE trd_mxl_trc_init ! Empty routine + WRITE(*,*) 'trd_mxl_trc_init: You should not have seen this print! error?' + END SUBROUTINE trd_mxl_trc_init +#endif + + !!====================================================================== +END MODULE trdmxl_trc diff --git a/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc_rst.F90 b/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc_rst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6a3e9c589c7b3a5d03e07a473a4ce0ee7426493b --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trdmxl_trc_rst.F90 @@ -0,0 +1,210 @@ +MODULE trdmxl_trc_rst + !!====================================================================== + !! *** MODULE trdmxl_rst *** + !! Ocean dynamic : Input/Output files for restart on mixed-layer diagnostics + !!====================================================================== + !! History : 9.0 ! 07-03 (C. Deltel) Original code + !!---------------------------------------------------------------------- + +#if defined key_top && defined key_trdmxl_trc + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE trc ! for nn_dttrc ctrcnm + USE trdmxl_trc_oce ! for lk_trdmxl_trc + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_mxl_trc_rst_read ! routine called by trd_mxl_init + PUBLIC trd_mxl_trc_rst_write ! routine called by step.F90 + + INTEGER :: nummldw_trc ! logical unit for mld restart + + !!--------------------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_trc_rst.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!--------------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_mxl_trc_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=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 + CHARACTER (len=35) :: charout + INTEGER :: jl, jk, jn ! loop indice + !!-------------------------------------------------------------------------------- + + IF( kt == nitrst - nn_dttrc .OR. nitend - nit000 + 1 < 2 * nn_dttrc ) THEN ! idem trcrst.F90 + IF( nitrst > 1.0e9 ) THEN + WRITE(clkt,*) nitrst + ELSE + WRITE(clkt,'(i8.8)') nitrst + ENDIF + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_trc_out) + clpath = TRIM(cn_trcrst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) WRITE(numout,*) ' open ocean restart_mld_trc NetCDF 'TRIM(clpath)//TRIM(clname) + CALL iom_open( TRIM(clpath)//TRIM(clname), nummldw_trc, ldwrt = .TRUE. ) + ENDIF + + IF( kt == nitend .AND. lk_trdmxl_trc ) THEN + + IF( kt == nitend .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trdmxl_trc_rst: output for ML diags. restart, with trd_mxl_trc_rst_write routine' + WRITE(numout,*) '~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + IF( ln_trdmxl_trc_instant ) THEN + ! + DO jn = 1, jptra + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) ) + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) ) + END DO + ! + ELSE + ! + CALL iom_rstput( kt, nitrst, nummldw_trc, 'rmldbn_trc', rmldbn_trc ) ! 2D x 1 + + ! ! =========== + DO jn = 1, jptra ! tracer loop + ! ! =========== + + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc (:,:,jn) ) ! 2D x jptra + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) ! 2D x jptra + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc (:,:,jn) ) ! 2D x jptra + + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! 2D x jptra + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) ) ! 2D x jptra + + DO jk = 1, jpltrd_trc + IF( jk < 10 ) THEN + WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I1)") ctrcnm(jn), jk + ELSE + WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I2)") ctrcnm(jn), jk + ENDIF + CALL iom_rstput( kt, nitrst, nummldw_trc, charout, tmltrd_csum_ub_trc(:,:,jk,jn) ) + END DO + + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , & + & tmltrd_atf_sumb_trc(:,:,jn) ) ! 2D x jptra + + CALL iom_rstput( kt, nitrst, nummldw_trc, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , & + & tmltrd_rad_sumb_trc(:,:,jn) ) ! 2D x jptra + ! ! =========== + END DO ! tracer loop + ! ! =========== + ENDIF + + CALL iom_close( nummldw_trc ) + lrst_trc = .TRUE. + + ENDIF + + END SUBROUTINE trd_mxl_trc_rst_write + + + SUBROUTINE trd_mxl_trc_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, jn, jl ! loop indice + LOGICAL :: llok + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!----------------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_trc_rst_read : read the NetCDF MLD restart file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~' + ENDIF + + clpath = TRIM(cn_trcrst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_trc_in), inum ) + + IF( ln_trdmxl_trc_instant ) THEN + + DO jn = 1, jptra + CALL iom_get( inum, jpdom_autoglo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) + CALL iom_get( inum, jpdom_autoglo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) + CALL iom_get( inum, jpdom_autoglo, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) ) + CALL iom_get( inum, jpdom_autoglo, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) ) + END DO + + ELSE + CALL iom_get( inum, jpdom_autoglo, 'rmldbn_trc', rmldbn_trc ) ! needed for rmld_sum + + ! ! =========== + DO jn = 1, jptra ! tracer loop + ! ! =========== + CALL iom_get( inum, jpdom_autoglo, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc(:,:,jn) ) + CALL iom_get( inum, jpdom_autoglo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) + CALL iom_get( inum, jpdom_autoglo, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc(:,:,jn) ) + + CALL iom_get( inum, jpdom_autoglo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! needed for tml_sum + CALL iom_get( inum, jpdom_autoglo, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) ) + + DO jk = 1, jpltrd_trc + IF( jk < 10 ) THEN + WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I1)") ctrcnm(jn), jk + ELSE + WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I2)") ctrcnm(jn), jk + ENDIF + CALL iom_get( inum, jpdom_autoglo, charout, tmltrd_csum_ub_trc(:,:,jk,jn) ) + END DO + + CALL iom_get( inum, jpdom_autoglo, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , & + & tmltrd_atf_sumb_trc(:,:,jn) ) + + CALL iom_get( inum, jpdom_autoglo, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , & + & tmltrd_rad_sumb_trc(:,:,jn) ) + ! ! =========== + END DO ! tracer loop + ! ! =========== + + CALL iom_close( inum ) + ENDIF + + END SUBROUTINE trd_mxl_trc_rst_read + +#else + !!================================================================================= + !! *** MODULE trdmxl_rst *** + !! Ocean dynamic : Input/Output files for restart on mixed-layer diagnostics + !!================================================================================= +CONTAINS + SUBROUTINE trd_mxl_trc_rst_opn( kt ) + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'trd_mxl_trc_rst_opn: You should not have seen this print! error?', kt + END SUBROUTINE trd_mxl_trc_rst_opn + SUBROUTINE trd_mxl_trc_rst_write( kt ) ! No ML diags ==> empty routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'trd_mxl_trc_rst_wri: You should not have seen this print! error?', kt + END SUBROUTINE trd_mxl_trc_rst_write + SUBROUTINE trd_mxl_trc_rst_read ! No ML Diags ==> empty routine + IMPLICIT NONE + END SUBROUTINE trd_mxl_trc_rst_read +#endif + + !!================================================================================= +END MODULE trdmxl_trc_rst diff --git a/V4.0/nemo_sources/src/TOP/TRP/trdtrc.F90 b/V4.0/nemo_sources/src/TOP/TRP/trdtrc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..35ad9ec2801481011c077323e301ffa8a15ce341 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trdtrc.F90 @@ -0,0 +1,127 @@ +MODULE trdtrc + !!====================================================================== + !! *** MODULE trdtrc *** + !! Ocean diagnostics: mixed layer passive tracer trends + !!====================================================================== + !! History : 3.0 ! 2010-07 (C. Ethe) Original code (from trdtrc.F90) + !!---------------------------------------------------------------------- +#if defined key_top && ( defined key_trdmxl_trc || defined key_trdtrc ) + !!---------------------------------------------------------------------- + !! 'key_trdmxl_trc' mixed layer trend diagnostics + !! 'key_trdtrc' 3D trend diagnostics + !!---------------------------------------------------------------------- + !! trdtrc : passive tracer trends + !!---------------------------------------------------------------------- + USE trc ! tracer definitions (trn, trb, tra, etc.) + USE trd_oce + USE trdtrc_oce ! definition of main arrays used for trends computations + USE trdmxl_trc ! Mixed layer trends diag. + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_trc + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trdtrc.F90 10096 2018-09-07 11:38:22Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_trc *** + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time step + INTEGER, INTENT( in ) :: kjn ! tracer index + INTEGER, INTENT( in ) :: ktrd ! tracer trend index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: ptrtrd ! Temperature or U trend + CHARACTER (len=20) :: cltra + !!---------------------------------------------------------------------- + + IF( kt == nittrc000 ) THEN +! IF(lwp)WRITE(numout,*) +! IF(lwp)WRITE(numout,*) 'trd_trc:' +! IF(lwp)WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Mixed layer trends for passive tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +#if defined key_trdmxl_trc + IF( lk_trdmxl_trc .AND. ln_trdtrc( kjn ) ) THEN + ! + SELECT CASE ( ktrd ) + CASE ( jptra_xad ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_xad, '3D', kjn ) + CASE ( jptra_yad ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_yad, '3D', kjn ) + CASE ( jptra_zad ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_zad, '3D', kjn ) + CASE ( jptra_ldf ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_ldf, '3D', kjn ) + CASE ( jptra_bbl ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_bbl, '3D', kjn ) + CASE ( jptra_zdf ) + IF( ln_trcldf_iso ) THEN + CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_ldf, '3D', kjn ) + ELSE + CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_zdf, '3D', kjn ) + ENDIF + CASE ( jptra_dmp ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_dmp , '3D', kjn ) + CASE ( jptra_nsr ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_sbc , '2D', kjn ) + CASE ( jptra_sms ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_sms , '3D', kjn ) + CASE ( jptra_radb ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_radb, '3D', kjn ) + CASE ( jptra_radn ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_radn, '3D', kjn ) + CASE ( jptra_atf ) ; CALL trd_mxl_trc_zint( ptrtrd, jpmxl_trc_atf , '3D', kjn ) + END SELECT + ! + END IF +#endif + + IF( lk_trdtrc .AND. ln_trdtrc( kjn ) ) THEN + ! + SELECT CASE( ktrd ) + CASE( jptra_xad ) ; WRITE (cltra,'("XAD_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_yad ) ; WRITE (cltra,'("YAD_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_zad ) ; WRITE (cltra,'("ZAD_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_ldf ) ; WRITE (cltra,'("LDF_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_bbl ) ; WRITE (cltra,'("BBL_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_nsr ) ; WRITE (cltra,'("FOR_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_zdf ) ; WRITE (cltra,'("ZDF_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_zdfp ) ; WRITE (cltra,'("ZDP_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_dmp ) ; WRITE (cltra,'("DMP_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_sms ) ; WRITE (cltra,'("SMS_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_tot ) ; WRITE (cltra,'("TOT_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_atf ) ; WRITE (cltra,'("ATF_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_radb ) ; WRITE (cltra,'("RDB_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + CASE( jptra_radn ) ; WRITE (cltra,'("RDN_",4a)') ; cltra = TRIM(cltra)//TRIM(ctrcnm(kjn)) ; CALL iom_put( cltra, ptrtrd(:,:,:) ) + END SELECT + ! + END IF + + END SUBROUTINE trd_trc + +#else + !!---------------------------------------------------------------------- + !! Default option : Empty module + !!---------------------------------------------------------------------- + + USE par_kind + + PUBLIC trd_trc + +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt ) + INTEGER , INTENT( in ) :: kt ! time step + INTEGER , INTENT( in ) :: kjn ! tracer index + INTEGER , INTENT( in ) :: ktrd ! tracer trend index + REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: ptrtrd ! Temperature or U trend + 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 + WRITE(*,*) ' " " : You should not have seen this print! error?', ktrd + WRITE(*,*) ' " " : You should not have seen this print! error?', kt + END SUBROUTINE trd_trc + +#endif + !!====================================================================== +END MODULE trdtrc diff --git a/V4.0/nemo_sources/src/TOP/TRP/trdtrc_oce.F90 b/V4.0/nemo_sources/src/TOP/TRP/trdtrc_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..20b82970dad8677482578861425ff10c7be95013 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/TRP/trdtrc_oce.F90 @@ -0,0 +1,163 @@ +MODULE trdtrc_oce + !!====================================================================== + !! *** MODULE trdtrc_oce *** + !! Ocean trends : set tracer and momentum trend variables + !!====================================================================== +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE par_trc ! passive tracers parameters + + IMPLICIT NONE + PUBLIC + + ! !!* Namelist namtoptrd: diagnostics on passive tracers trends + INTEGER :: nn_trd_trc !: time step frequency dynamics and tracers trends + INTEGER :: nn_ctls_trc !: control surface type for trends vertical integration + REAL(wp) :: rn_ucf_trc !: unit conversion factor (for netCDF trends outputs) + LOGICAL :: ln_trdmxl_trc_instant !: flag to diagnose inst./mean ML trc trends + LOGICAL :: ln_trdmxl_trc_restart !: flag to restart mixed-layer trc diagnostics + CHARACTER(len=50) :: cn_trdrst_trc_in !: suffix of pass. tracer restart name (input) + CHARACTER(len=50) :: cn_trdrst_trc_out !: suffix of pass. tracer restart name (output) + LOGICAL, DIMENSION(:), ALLOCATABLE :: ln_trdtrc !: large trends diagnostic to write or not (namelist) + +# if defined key_trdtrc && defined key_iomput + LOGICAL, PARAMETER :: lk_trdtrc = .TRUE. +# else + LOGICAL, PARAMETER :: lk_trdtrc = .FALSE. !: ML trend flag +# endif + +# if defined key_trdmxl_trc + !!---------------------------------------------------------------------- + !! 'key_trdmxl_trc' mixed layer trends diagnostics + !!---------------------------------------------------------------------- + + LOGICAL, PARAMETER :: lk_trdmxl_trc = .TRUE. !: ML trend flag + + INTEGER, PARAMETER :: & !: mixed layer trends indices + jpmxl_trc_xad = 1, & !: zonal advection + jpmxl_trc_yad = 2, & !: meridonal ========= + jpmxl_trc_zad = 3, & !: vertical ========= + jpmxl_trc_ldf = 4, & !: lateral diffusion (geopot. or iso-neutral) + jpmxl_trc_zdf = 5, & !: vertical diffusion (TKE) + jpmxl_trc_bbl = 6, & !: bottom boundary layer (advective/diffusive) + jpmxl_trc_dmp = 7, & !: internal restoring trend + jpmxl_trc_sbc = 8, & !: forcing + jpmxl_trc_sms = 9, & !: sources minus sinks trend + ! jpmxl_trc_xxx = xx, & !: add here any additional trend (** AND UPDATE JPLTRD_TRC BELOW **) + jpmxl_trc_radn = 10, & !: corr. trn<0 in trcrad + jpmxl_trc_radb = 11, & !: corr. trb<0 in trcrad (like atf) (** MUST BE BEFORE THE LAST ONE **) + jpmxl_trc_atf = 12 !: asselin trend (** MUST BE THE LAST ONE**) + + !! Trends diagnostics parameters + !!--------------------------------------------------------------------- + INTEGER, PARAMETER :: jpltrd_trc = 12 !: number of mixed-layer trends arrays + + INTEGER :: jpktrd_trc !: max level for mixed-layer trends diag. + + !! Arrays used for diagnosing mixed-layer trends + !!--------------------------------------------------------------------- + CHARACTER(LEN=80) :: clname_trc, ctrd_trc(jpltrd_trc+1,2) + + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + nmld_trc , & !: mixed layer depth indexes + nbol_trc !: mixed-layer depth indexes when read from file + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wkx_trc !: + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rmld_trc !: ML depth (m) corresponding to nmld_trc + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rmld_sum_trc !: needed to compute the leap-frog time mean of ML depth + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rmldbn_trc !: idem + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: & + tml_trc , & !: \ "now" mixed layer temperature/salinity + tmlb_trc , & !: / and associated "before" fields + tmlbb_trc , & !: \ idem, but valid at the 1rst time step of the + tmlbn_trc , & !: / current analysis window + tml_sum_trc, & !: mixed layer T, summed over the current analysis period + tml_sumb_trc, & !: idem, but from the previous analysis period + tmltrd_atf_sumb_trc, & !: Asselin trends, summed over the previous analysis period + tmltrd_rad_sumb_trc !: trends due to trb correction in trcrad.F90, summed over the + !: previous analysis period + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: & + tmlatfb_trc, tmlatfn_trc , & !: "before" Asselin contrib. at beginning of the averaging + !: period (i.e. last contrib. from previous such period) + !: and "now" Asselin contrib. to the ML trc. trends + tmlatfm_trc, & !: accumulator for Asselin trends (needed for storage only) + tmlradb_trc, tmlradn_trc , & !: similar to Asselin above, but for the trend due to trb + !: correction in trcrad.F90 + tmlradm_trc !: accumulator for the previous trcrad trend + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: & + tmltrd_trc, & !: \ physical contributions to the total trend (for T/S), + !: / cumulated over the current analysis window + tmltrd_sum_trc, & !: sum of these trends over the analysis period + tmltrd_csum_ln_trc, & !: now cumulated sum of trends over the "lower triangle" + tmltrd_csum_ub_trc !: before (prev. analysis period) cumulated sum over the + !: upper triangle + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: & + tmltrdm_trc !: total cumulative trends over the analysis window + +# else + LOGICAL, PARAMETER :: lk_trdmxl_trc = .FALSE. !: ML trend flag +# endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trdtrc_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_trc_oce_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_trc_oce_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop + INTEGER :: ierr(2) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! +# if defined key_trdmxl_trc + ALLOCATE(nmld_trc(jpi,jpj), nbol_trc(jpi,jpj), & + wkx_trc(jpi,jpj,jpk), rmld_trc(jpi,jpj), & + rmld_sum_trc(jpi,jpj), rmldbn_trc(jpi,jpj), & + tml_trc(jpi,jpj,jptra), tmlb_trc(jpi,jpj,jptra), & + tmlbb_trc(jpi,jpj,jptra), tmlbn_trc(jpi,jpj,jptra), & + tml_sum_trc(jpi,jpj,jptra), tml_sumb_trc(jpi,jpj,jptra), & + tmltrd_atf_sumb_trc(jpi,jpj,jptra), & + tmltrd_rad_sumb_trc(jpi,jpj,jptra), & + ! + tmlatfb_trc(jpi,jpj,jptra), tmlatfn_trc(jpi,jpj,jptra), & + tmlatfm_trc(jpi,jpj,jptra), tmlradb_trc(jpi,jpj,jptra), & + tmlradn_trc(jpi,jpj,jptra), tmlradm_trc(jpi,jpj,jptra), & + ! + tmltrd_trc(jpi,jpj,jpltrd_trc,jptra) , & + tmltrd_sum_trc(jpi,jpj,jpltrd_trc,jptra) , & + tmltrd_csum_ln_trc(jpi,jpj,jpltrd_trc,jptra) , & + tmltrd_csum_ub_trc(jpi,jpj,jpltrd_trc,jptra) , & + ! + tmltrdm_trc(jpi,jpj,jptra) , STAT=ierr(1) ) +#endif + ! + trd_trc_oce_alloc = MAXVAL(ierr) + ! + IF( trd_trc_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_trc_oce_alloc: failed to allocate arrays' ) + ! +# if defined key_trdmxl_trc + jpktrd_trc = jpk ! Initialise what used to be a parameter - max level for mixed-layer trends diag. +# endif + ! + END FUNCTION trd_trc_oce_alloc + +#else + !!---------------------------------------------------------------------- + !! Empty module : No passive tracer + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE trdtrc_oce diff --git a/V4.0/nemo_sources/src/TOP/oce_trc.F90 b/V4.0/nemo_sources/src/TOP/oce_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6c94ba681945d3d04a375f8262aba5794b4549ee --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/oce_trc.F90 @@ -0,0 +1,101 @@ +MODULE oce_trc + !!====================================================================== + !! *** MODULE oce_trc *** + !! TOP : variables shared between ocean and passive tracers + !!====================================================================== + !! History : 1.0 ! 2004-03 (C. Ethe) original code + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) rewritting + !!---------------------------------------------------------------------- + ! !* Domain size * + USE par_oce , ONLY : jpi => jpi !: first dimension of grid --> i + USE par_oce , ONLY : jpj => jpj !: second dimension of grid --> j + USE par_oce , ONLY : jpk => jpk !: number of levels + USE par_oce , ONLY : jpim1 => jpim1 !: jpi - 1 + USE par_oce , ONLY : jpjm1 => jpjm1 !: jpj - 1 + USE par_oce , ONLY : jpkm1 => jpkm1 !: jpk - 1 + USE par_oce , ONLY : jpij => jpij !: jpi x jpj + USE par_oce , ONLY : jp_tem => jp_tem !: indice for temperature + USE par_oce , ONLY : jp_sal => jp_sal !: indice for salinity + + USE in_out_manager !* IO manager * + USE timing !* Timing * + USE lib_mpp !* MPP library + USE lib_fortran !* Fortran utilities + USE lbclnk !* Lateral boundary conditions + USE phycst !* physical constants * + USE c1d !* 1D configuration + + USE dom_oce !* model domain * + + USE domvvl, ONLY : un_td, vn_td !: thickness diffusion transport + USE domvvl, ONLY : ln_vvl_ztilde !: ztilde vertical coordinate + USE domvvl, ONLY : ln_vvl_layer !: level vertical coordinate + + !* ocean fields: here now and after fields * + USE oce , ONLY : un => un !: i-horizontal velocity (m s-1) + USE oce , ONLY : vn => vn !: j-horizontal velocity (m s-1) + USE oce , ONLY : wn => wn !: vertical velocity (m s-1) + USE oce , ONLY : tsn => tsn !: 4D array contaning ( tn, sn ) + USE oce , ONLY : tsb => tsb !: 4D array contaning ( tb, sb ) + USE oce , ONLY : tsa => tsa !: 4D array contaning ( ta, sa ) + USE oce , ONLY : rhop => rhop !: potential volumic mass (kg m-3) + USE oce , ONLY : rhd => rhd !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) + USE oce , ONLY : hdivn => hdivn !: horizontal divergence (1/s) + USE oce , ONLY : sshn => sshn !: sea surface height at t-point [m] + USE oce , ONLY : sshb => sshb !: sea surface height at t-point [m] + USE oce , ONLY : ssha => ssha !: sea surface height at t-point [m] + USE oce , ONLY : rab_n => rab_n !: local thermal/haline expension ratio at T-points + + !* surface fluxes * + USE sbc_oce , ONLY : utau => utau !: i-surface stress component + USE sbc_oce , ONLY : vtau => vtau !: j-surface stress component + USE sbc_oce , ONLY : wndm => wndm !: 10m wind speed + USE sbc_oce , ONLY : qsr => qsr !: penetrative solar radiation (w m-2) + USE sbc_oce , ONLY : emp => emp !: freshwater budget: volume flux [Kg/m2/s] + USE sbc_oce , ONLY : emp_b => emp_b !: freshwater budget: volume flux [Kg/m2/s] + USE sbc_oce , ONLY : fmmflx => fmmflx !: freshwater budget: volume flux [Kg/m2/s] + USE sbc_oce , ONLY : rnf => rnf !: river runoff [Kg/m2/s] + USE sbc_oce , ONLY : rnf_b => rnf_b !: river runoff at previus step [Kg/m2/s] + USE sbc_oce , ONLY : ln_dm2dc => ln_dm2dc !: Diurnal Cycle + USE sbc_oce , ONLY : ln_cpl => ln_cpl !: ocean-atmosphere coupled formulation + USE sbc_oce , ONLY : ncpl_qsr_freq => ncpl_qsr_freq !: qsr coupling frequency per days from atmospher + USE sbc_oce , ONLY : ln_rnf => ln_rnf !: runoffs / runoff mouths + USE sbc_oce , ONLY : fr_i => fr_i !: ice fraction (between 0 to 1) + USE sbc_oce , ONLY : atm_co2 => atm_co2 ! atmospheric pCO2 + USE traqsr , ONLY : rn_abs => rn_abs !: fraction absorbed in the very near surface + USE traqsr , ONLY : rn_si0 => rn_si0 !: very near surface depth of extinction + USE traqsr , ONLY : nksr => nksr !: levels below which the light cannot penetrate (depth larger than 391 m) + USE traqsr , ONLY : rkrgb => rkrgb !: tabulated attenuation coefficients for RGB absorption + USE traqsr , ONLY : ln_qsr_bio => ln_qsr_bio !: flag to use or not the biological fluxes for light + USE sbcrnf , ONLY : rnfmsk => rnfmsk !: mixed adv scheme in runoffs vicinity (hori.) + USE sbcrnf , ONLY : rnfmsk_z => rnfmsk_z !: mixed adv scheme in runoffs vicinity (vert.) + USE sbcrnf , ONLY : h_rnf => h_rnf !: river runoff [Kg/m2/s] + USE sbcrnf , ONLY : nk_rnf => nk_rnf !: depth of runoff in model level + USE sbcrnf , ONLY : rn_rfact => rn_rfact !: multiplicative factor for runoff + + USE trc_oce + +!!gm this can be removed if : +!!gm in trcadv.F90 and trcsub.F90 we add a USE ldfslp + !* direction of lateral diffusion * + USE ldfslp , ONLY : l_ldfslp => l_ldfslp !: slopes flag + USE ldfslp , ONLY : uslp => uslp !: i-slope at u-point + USE ldfslp , ONLY : vslp => vslp !: j-slope at v-point + USE ldfslp , ONLY : wslpi => wslpi !: i-slope at w-point + USE ldfslp , ONLY : wslpj => wslpj !: j-slope at w-point + USE ldfslp , ONLY : ln_traldf_triad => ln_traldf_triad !: use of triad scheme + USE ldfslp , ONLY : ln_traldf_iso => ln_traldf_iso !: use of isopycnal scheme +!!gm end + + !* vertical diffusion * + USE zdf_oce , ONLY : avs => avs !: vert. diffusivity coef. for salinity (w-point) + USE zdf_oce , ONLY : avt => avt !: vert. diffusivity coef. for temperature (w-point) + + !* mixing & mixed layer depth * + USE zdfmxl , ONLY : nmln => nmln !: number of level in the mixed layer + USE zdfmxl , ONLY : hmld => hmld !: mixing layer depth (turbocline) + USE zdfmxl , ONLY : hmlp => hmlp !: mixed layer depth (rho=rho0+zdcrit) (m) + USE zdfmxl , ONLY : hmlpt => hmlpt !: mixed layer depth at t-points (m) + USE zdfmxl , ONLY : avt_c => avt_c !: Kz criterion for the turbocline depth + +END MODULE oce_trc diff --git a/V4.0/nemo_sources/src/TOP/par_trc.F90 b/V4.0/nemo_sources/src/TOP/par_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..034106bb78293c4b5f25582f4c18712f1408959b --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/par_trc.F90 @@ -0,0 +1,43 @@ +MODULE par_trc + !!====================================================================== + !! *** par_trc *** + !! TOP : set the passive tracers parameters + !!====================================================================== + !! History : - ! 1996-01 (M. Levy) original code + !! - ! 2000-04 (O. Aumont, M.A. Foujols) HAMOCC3 and P3ZD + !! 1.0 ! 2004-03 (C. Ethe) Free form and module + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + USE par_pisces ! PISCES model parameters + USE par_cfc ! CFCs tracers parameters + USE par_c14 ! C14 tracer parameters + USE par_age ! AGE tracer parameters + USE par_my_trc ! MY_TRC model parameters + ! + + IMPLICIT NONE + + INTEGER, PUBLIC, PARAMETER :: jpmaxtrc = 100 ! Maximum number of tracers + + INTEGER, PUBLIC :: jptra !: Total number of passive tracers + INTEGER, PUBLIC :: jp_pisces !: number of passive tracers in PISCES model + INTEGER, PUBLIC :: jp_cfc !: number of CFC passive tracers + INTEGER, PUBLIC :: jp_my_trc !: number of passive tracers in MY_TRC model + INTEGER, PUBLIC :: jp_bgc !: number of passive tracers for the BGC model + + INTEGER, PUBLIC :: jp_dia3d !: number of 3D diagnostic variables + INTEGER, PUBLIC :: jp_dia2d !: number of 2D diagnostic variables + + LOGICAL, PUBLIC :: ln_pisces !: PISCES flag + LOGICAL, PUBLIC :: ln_age !: AGE flag + LOGICAL, PUBLIC :: ln_cfc11 !: CFC11 flag + LOGICAL, PUBLIC :: ln_cfc12 !: CFC12 flag + LOGICAL, PUBLIC :: ln_sf6 !: SF6 flag + LOGICAL, PUBLIC :: ll_cfc !: CFC flag + LOGICAL, PUBLIC :: ln_c14 !: C14 flag + LOGICAL, PUBLIC :: ln_my_trc !: MY_TRC flag + + REAL(wp), PUBLIC :: rtrn = 0.5 * EPSILON( 1.e0 ) !: truncation value + +END MODULE par_trc diff --git a/V4.0/nemo_sources/src/TOP/prtctl_trc.F90 b/V4.0/nemo_sources/src/TOP/prtctl_trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a6d1bf44ffeab88345f432b140b3bfed3121ad66 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/prtctl_trc.F90 @@ -0,0 +1,295 @@ +MODULE prtctl_trc + !!====================================================================== + !! *** MODULE prtctl_trc *** + !! TOP : print all SUM trends for each processor domain + !!====================================================================== + !! History : - ! 2005-07 (C. Talandier) original code for OPA + !! 1.0 ! 2005-10 (C. Ethe ) adapted to passive tracer + !!---------------------------------------------------------------------- + !! prt_ctl_trc : control print in mpp for passive tracers + !! prt_ctl_trc_info : ??? + !! prt_ctl_trc_init : ??? + !!---------------------------------------------------------------------- + USE par_trc ! TOP parameters + USE oce_trc ! ocean space and time domain variables + USE prtctl ! print control for OPA + + IMPLICIT NONE + PRIVATE + + INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit + INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain + INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain + INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor + INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain + INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl + + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values + + PUBLIC prt_ctl_trc ! called by all subroutines + PUBLIC prt_ctl_trc_info ! + PUBLIC prt_ctl_trc_init ! called by opa.F90 + +CONTAINS + + SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl *** + !! + !! ** Purpose : - print sum control 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 mask + !! array tmask(:,:,:) must be passed through the prt_ctl subroutine, + !! it must looks like: CALL prt_ctl( mask=tmask ). + !!---------------------------------------------------------------------- + REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array + REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array + CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array + CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ??? + INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value + INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays + !! + INTEGER :: overlap, jn, js, sind, eind, kdir, j_id + REAL(wp) :: zsum, zvctl + CHARACTER (len=20), ALLOCATABLE, DIMENSION(:) :: cl + CHARACTER (len=10) :: cl2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, ztab3d + !!---------------------------------------------------------------------- + + ALLOCATE( cl(jptra) ) + ! ! Arrays, scalars initialization + overlap = 0 + kdir = jpkm1 + zsum = 0.e0 + zvctl = 0.e0 + cl(:) = '' + cl2 = '' + ztab3d(:,:,:) = 0.e0 + zmask (:,:,:) = 1.e0 + + ! ! Control of optional arguments + IF( PRESENT(ovlap) ) overlap = ovlap + IF( PRESENT(kdim) ) kdir = kdim + IF( PRESENT(clinfo ) ) cl(:) = clinfo(:) + IF( PRESENT(clinfo2) ) cl2 = clinfo2 + IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:) + + IF( lk_mpp ) 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 js = sind, eind + ! + ! Set logical unit + j_id = numid_trc( js - narea + 1 ) + ! Set indices for the SUM control + IF( .NOT. lsp_area ) THEN + IF (lk_mpp ) THEN + nictls = MAX( 1, nlditl(js) - overlap ) + nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js)) + njctls = MAX( 1, nldjtl(js) - overlap ) + njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js)) + ! Do not take into account the bound of the domain + IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls ) + IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 ) + IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls ) + IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 ) + ELSE + nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap ) + nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) ) + njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap ) + njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) ) + ! Do not take into account the bound of the domain + IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls ) + IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls ) + IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 ) + IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 ) + ENDIF + ENDIF + ! + IF( PRESENT(clinfo2) ) THEN + DO jn = 1, jptra + zvctl = tra_ctl(jn,js) + ztab3d(:,:,:) = tab4d(:,:,:,jn) + zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) & + & * zmask(nictls:nictle,njctls:njctle,1:kdir) ) + WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl + tra_ctl(jn,js) = zsum + END DO + ELSE + DO jn = 1, jptra + ztab3d(:,:,:) = tab4d(:,:,:,jn) + zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) & + & * zmask(nictls:nictle,njctls:njctle,1:kdir) ) + WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum + END DO + ENDIF + ! + END DO + ! + DEALLOCATE( cl ) + ! + END SUBROUTINE prt_ctl_trc + + + SUBROUTINE prt_ctl_trc_info( clinfo ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_trc_info *** + !! + !! ** Purpose : - print information without any computation + !!---------------------------------------------------------------------- + CHARACTER (len=*), INTENT(in) :: clinfo ! information to print + !! + INTEGER :: js, sind, eind, j_id + !!---------------------------------------------------------------------- + + IF( lk_mpp ) THEN ! processor number + sind = narea + eind = narea + ELSE ! total number of processors + sind = 1 + eind = ijsplt + ENDIF + + ! Loop over each sub-domain, i.e. number of processors ijsplt + DO js = sind, eind + j_id = numid_trc(js - narea + 1) + WRITE(j_id,*) clinfo + END DO + ! + END SUBROUTINE prt_ctl_trc_info + + + SUBROUTINE prt_ctl_trc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_trc_init *** + !! + !! ** Purpose : open ASCII files & compute indices + !!---------------------------------------------------------------------- + INTEGER :: js, sind, eind, j_id + CHARACTER (len=31) :: clfile_out + CHARACTER (len=27) :: clb_name + CHARACTER (len=19) :: cl_run + !!---------------------------------------------------------------------- + + ! ! Allocate arrays + ALLOCATE( nlditl (ijsplt) ) + ALLOCATE( nldjtl (ijsplt) ) + ALLOCATE( nleitl (ijsplt) ) + ALLOCATE( nlejtl (ijsplt) ) + ALLOCATE( nimpptl(ijsplt) ) + ALLOCATE( njmpptl(ijsplt) ) + ALLOCATE( nlcitl (ijsplt) ) + ALLOCATE( nlcjtl (ijsplt) ) + ALLOCATE( tra_ctl(jptra,ijsplt) ) + ALLOCATE( ibonitl(ijsplt) ) + ALLOCATE( ibonjtl(ijsplt) ) + + tra_ctl(:,:) = 0.e0 ! Initialization to zero + + IF( lk_mpp ) THEN + sind = narea + eind = narea + clb_name = "('mpp.top.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.top.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_trc(eind-sind+1) ) + + DO js = sind, eind + WRITE(clfile_out,FMT=clb_name) js-1 + CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + j_id = numid_trc(js -narea + 1) + WRITE(j_id,*) + WRITE(j_id,*) ' L O D Y C - I P S L' + WRITE(j_id,*) ' N E M 0 ' + WRITE(j_id,*) ' Ocean General Circulation Model' + WRITE(j_id,*) ' version TOP 1.0 (2005) ' + WRITE(j_id,*) + WRITE(j_id,*) ' PROC number: ', js + WRITE(j_id,*) + WRITE(j_id,FMT="(19x,a20)") cl_run + + ! Print the SUM control indices + IF( .NOT. lsp_area ) THEN + IF ( lk_mpp ) THEN + nictls = nlditl(js) + nictle = nleitl(js) + njctls = nldjtl(js) + njctle = nlejtl(js) + ELSE + nictls = nimpptl(js) + nlditl(js) - 1 + nictle = nimpptl(js) + nleitl(js) - 1 + njctls = njmpptl(js) + nldjtl(js) - 1 + njctle = njmpptl(js) + nlejtl(js) - 1 + ENDIF + ENDIF + WRITE(j_id,*) + WRITE(j_id,*) 'prt_tra_ctl : Sum control indices' + WRITE(j_id,*) '~~~~~~~' + WRITE(j_id,*) + WRITE(j_id,9000)' nlej = ', nlejtl(js), ' ' + 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(js), ' nlei = ', nleitl(js) + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------' + WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' ' + WRITE(j_id,*) + WRITE(j_id,*) + +9000 FORMAT(a41,i4.4,a14) +9001 FORMAT(a59) +9002 FORMAT(a20,i4.4,a36,i3.3) +9003 FORMAT(a20,i4.4,a17,i4.4) +9004 FORMAT(a11,i4.4,a26,i4.4,a14) + END DO + ! + END SUBROUTINE prt_ctl_trc_init + +END MODULE prtctl_trc diff --git a/V4.0/nemo_sources/src/TOP/trc.F90 b/V4.0/nemo_sources/src/TOP/trc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1e161f1e6a626eeb8dcc73ceac7c7b9d8cefbece --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trc.F90 @@ -0,0 +1,173 @@ +MODULE trc + !!====================================================================== + !! *** MODULE trc *** + !! Passive tracers : module for tracers defined + !!====================================================================== + !! History : OPA ! 1996-01 (M. Levy) Original code + !! - ! 2000-04 (O. Aumont, M.A. Foujols) HAMOCC3 and P3ZD + !! NEMO 1.0 ! 2004-03 (C. Ethe) Free form and module + !!---------------------------------------------------------------------- + USE par_oce + USE par_trc + USE bdy_oce, only: jp_bdy, ln_bdy, nb_bdy, OBC_DATA + + IMPLICIT NONE + PUBLIC + + PUBLIC trc_alloc ! called by nemogcm.F90 + + ! !!- logical units of passive tracers + INTEGER, PUBLIC :: numnat_ref = -1 !: reference passive tracer namelist_top_ref + INTEGER, PUBLIC :: numnat_cfg = -1 !: reference passive tracer namelist_top_cfg + INTEGER, PUBLIC :: numont = -1 !: reference passive tracer namelist output output.namelist.top + INTEGER, PUBLIC :: numtrc_ref = -1 !: reference passive tracer namelist_top_ref + INTEGER, PUBLIC :: numtrc_cfg = -1 !: reference passive tracer namelist_top_cfg + INTEGER, PUBLIC :: numonr = -1 !: reference passive tracer namelist output output.namelist.top + INTEGER, PUBLIC :: numstr !: tracer statistics + INTEGER, PUBLIC :: numrtr = -1 !: trc restart (read ) + INTEGER, PUBLIC :: numrtw !: trc restart ( write ) + + !! passive tracers fields (before,now,after) + !! -------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: trai !: initial total tracer + REAL(wp), PUBLIC :: areatot !: total volume + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: cvol !: volume correction -degrad option- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: trn !: tracer concentration for now time step + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tra !: tracer concentration for next time step + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: trb !: tracer concentration for before time step + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: sbc_trc_b !: Before sbc fluxes for tracers + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: sbc_trc !: Now sbc fluxes for tracers + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: trc_i !: prescribed tracer concentration in sea ice for SBC + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: trc_o !: prescribed tracer concentration in ocean for SBC + INTEGER , PUBLIC :: nn_ice_tr !: handling of sea ice tracers + + !! interpolated gradient + !!-------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtru !: hor. gradient at u-points at bottom ocean level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtrv !: hor. gradient at v-points at bottom ocean level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtrui !: hor. gradient at u-points at top ocean level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtrvi !: hor. gradient at v-points at top ocean level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean qsr + + !! passive tracers (input and output) + !! ------------------------------------------ + LOGICAL , PUBLIC :: ln_rsttr !: boolean term for restart i/o for passive tracers (namelist) + LOGICAL , PUBLIC :: lrst_trc !: logical to control the trc restart write + INTEGER , PUBLIC :: nn_writetrc !: time step frequency for concentration outputs (namelist) + INTEGER , PUBLIC :: nutwrs !: output FILE for passive tracers restart + INTEGER , PUBLIC :: nutrst !: logical unit for restart FILE for passive tracers + INTEGER , PUBLIC :: nn_rsttr !: control of the time step ( 0 or 1 ) for pass. tr. + CHARACTER(len = 80) , PUBLIC :: cn_trcrst_in !: suffix of pass. tracer restart name (input) + CHARACTER(len = 256), PUBLIC :: cn_trcrst_indir !: restart input directory + CHARACTER(len = 80) , PUBLIC :: cn_trcrst_out !: suffix of pass. tracer restart name (output) + CHARACTER(len = 256), PUBLIC :: cn_trcrst_outdir !: restart output directory + REAL(wp) , PUBLIC :: rdttrc !: passive tracer time step + REAL(wp) , PUBLIC :: r2dttrc !: = 2*rdttrc except at nit000 (=rdttrc) if neuler=0 + LOGICAL , PUBLIC :: ln_top_euler !: boolean term for euler integration + LOGICAL , PUBLIC :: ln_trcdta !: Read inputs data from files + LOGICAL , PUBLIC :: ln_trcdmp !: internal damping flag + LOGICAL , PUBLIC :: ln_trcdmp_clo !: internal damping flag on closed seas + INTEGER , PUBLIC :: nittrc000 !: first time step of passive tracers model + LOGICAL , PUBLIC :: l_trcdm2dc !: Diurnal cycle for TOP + + !! Information for the ice module for tracers + !! ------------------------------------------ + TYPE, PUBLIC :: TRC_I_NML !: Ice tracer namelist structure + REAL(wp) :: trc_ratio ! ice-ocean trc ratio + REAL(wp) :: trc_prescr ! prescribed ice trc cc + CHARACTER(len=2) :: ctrc_o ! choice of ocean trc cc + END TYPE + ! + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: trc_ice_ratio !: ice-ocean tracer ratio + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: trc_ice_prescr !: prescribed ice trc cc + CHARACTER(len=2), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: cn_trc_o !: choice of ocean tracer cc + + + !! information for outputs + !! -------------------------------------------------- + TYPE, PUBLIC :: PTRACER !: Passive tracer type + CHARACTER(len=20) :: clsname ! short name + CHARACTER(len=80) :: cllname ! long name + CHARACTER(len=20) :: clunit ! unit + LOGICAL :: llinit ! read in a file or not + LOGICAL :: llsbc ! read in a file or not + LOGICAL :: llcbc ! read in a file or not + LOGICAL :: llobc ! read in a file or not + END TYPE PTRACER + ! + CHARACTER(len=20), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ctrcnm !: tracer name + CHARACTER(len=80), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ctrcln !: trccer field long name + CHARACTER(len=20), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ctrcun !: tracer unit + ! + TYPE, PUBLIC :: DIAG !: Passive trcacer ddditional diagnostic type + CHARACTER(len=20) :: sname ! short name + CHARACTER(len=80) :: lname ! long name + CHARACTER(len=20) :: units ! unit + END TYPE DIAG + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: trc3d !: 3D diagnostics for tracers + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: trc2d !: 2D diagnostics for tracers + + !! information for inputs + !! -------------------------------------------------- + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ln_trc_ini !: Initialisation from data input file + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ln_trc_obc !: Use open boundary condition data + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ln_trc_sbc !: Use surface boundary condition data + LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ln_trc_cbc !: Use coastal boundary condition data + LOGICAL , PUBLIC :: ln_rnf_ctl !: remove runoff dilution on tracers + REAL(wp), PUBLIC :: rn_bc_time !: Time scaling factor for SBC and CBC data (seconds in a day) + ! + CHARACTER(len=20), PUBLIC, DIMENSION(jp_bdy) :: cn_trc_dflt ! Default OBC condition for all tracers + CHARACTER(len=20), PUBLIC, DIMENSION(jp_bdy) :: cn_trc ! Choice of boundary condition for tracers + INTEGER, PUBLIC, DIMENSION(jp_bdy) :: nn_trcdmp_bdy !: =T Tracer damping + ! + ! Vertical axis used in the sediment module + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: profsed +!$AGRIF_DO_NOT_TREAT + ! External data structure of BDY for TOP. Available elements: cn_obc, ll_trc, trcnow, dmp + TYPE(OBC_DATA), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: trcdta_bdy !: bdy external data (local process) +!$AGRIF_END_DO_NOT_TREAT + ! + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trc.F90 14588 2021-03-05 07:42:07Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE trc_alloc *** + !!------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop + !!------------------------------------------------------------------- + INTEGER :: ierr(4) + !!------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( trn(jpi,jpj,jpk,jptra), trb(jpi,jpj,jpk,jptra), tra(jpi,jpj,jpk,jptra), & + & trc_i(jpi,jpj,jptra) , trc_o(jpi,jpj,jptra) , & + & gtru (jpi,jpj,jptra) , gtrv (jpi,jpj,jptra) , & + & gtrui(jpi,jpj,jptra) , gtrvi(jpi,jpj,jptra) , & + & trc_ice_ratio(jptra) , trc_ice_prescr(jptra) , cn_trc_o(jptra) , & + & sbc_trc_b(jpi,jpj,jptra), sbc_trc(jpi,jpj,jptra) , & + & cvol(jpi,jpj,jpk) , trai(jptra) , qsr_mean(jpi,jpj) , & + & ctrcnm(jptra) , ctrcln(jptra) , ctrcun(jptra) , & + & ln_trc_ini(jptra) , & + & ln_trc_sbc(jptra) , ln_trc_cbc(jptra) , ln_trc_obc(jptra) , & + & STAT = ierr(1) ) + ! + IF( ln_bdy ) ALLOCATE( trcdta_bdy(jptra, jp_bdy) , STAT = ierr(2) ) + ! + IF (jp_dia3d > 0 ) ALLOCATE( trc3d(jpi,jpj,jpk,jp_dia3d), STAT = ierr(3) ) + ! + IF (jp_dia2d > 0 ) ALLOCATE( trc2d(jpi,jpj,jpk,jp_dia2d), STAT = ierr(4) ) + ! + trc_alloc = MAXVAL( ierr ) + IF( trc_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_alloc: failed to allocate arrays' ) + ! + END FUNCTION trc_alloc + + !!====================================================================== +END MODULE trc diff --git a/V4.0/nemo_sources/src/TOP/trcbc.F90 b/V4.0/nemo_sources/src/TOP/trcbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4e196d84b1d11125072a99795a6b0ef95149e554 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcbc.F90 @@ -0,0 +1,473 @@ +MODULE trcbc + !!====================================================================== + !! *** MODULE trcbc *** + !! TOP : module for passive tracer boundary conditions + !!===================================================================== + !! History : 3.5 ! 2014 (M. Vichi, T. Lovato) Original + !! 3.6 ! 2015 (T . Lovato) Revision and BDY support + !! 4.0 ! 2016 (T . Lovato) Include application of sbc and cbc + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP model + !!---------------------------------------------------------------------- + !! trc_bc : Apply tracer Boundary Conditions + !!---------------------------------------------------------------------- + USE par_trc ! passive tracers parameters + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE iom ! I/O manager + USE lib_mpp ! MPP library + USE fldread ! read input fields + USE bdy_oce, ONLY: ln_bdy, nb_bdy , idx_bdy, ln_coords_file, rn_time_dmp, rn_time_dmp_out + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_bc ! called in trcstp.F90 or within TOP modules + PUBLIC trc_bc_ini ! called in trcini.F90 + + INTEGER , SAVE, PUBLIC :: nb_trcobc ! number of tracers with open BC + INTEGER , SAVE, PUBLIC :: nb_trcsbc ! number of tracers with surface BC + INTEGER , SAVE, PUBLIC :: nb_trccbc ! number of tracers with coastal BC + INTEGER , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_indobc ! index of tracer with OBC data + INTEGER , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_indsbc ! index of tracer with SBC data + INTEGER , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_indcbc ! index of tracer with CBC data + REAL(wp) , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: rf_trsfac ! multiplicative factor for SBC tracer values + TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf_trcsbc ! structure of data input SBC (file informations, fields read) + REAL(wp) , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: rf_trcfac ! multiplicative factor for CBC tracer values + TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf_trccbc ! structure of data input CBC (file informations, fields read) + REAL(wp) , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: rf_trofac ! multiplicative factor for OBCtracer values +#if defined key_agrif + TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf_trcobc ! structure of data input OBC (file informations, fields read) +#else + TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET :: sf_trcobc +#endif + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcbc.F90 12850 2020-05-01 16:21:38Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_bc_ini( ntrc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_bc_ini *** + !! + !! ** Purpose : initialisation of passive tracer BC data + !! + !! ** Method : - Read namtsd namelist + !! - allocates passive tracer BC data structure + !!---------------------------------------------------------------------- + INTEGER,INTENT(in) :: ntrc ! number of tracers + ! + INTEGER :: jl, jn , ib, ibd, ii, ij, ik ! dummy loop indices + INTEGER :: ierr0, ierr1, ierr2, ierr3 ! temporary integers + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nblen, igrd ! support arrays for BDY + CHARACTER(len=100) :: clndta, clntrc + ! + CHARACTER(len=100) :: cn_dir_sbc, cn_dir_cbc, cn_dir_obc + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! local array of namelist informations on the fields to read + TYPE(FLD_N), DIMENSION(jpmaxtrc) :: sn_trcobc ! open + TYPE(FLD_N), DIMENSION(jpmaxtrc) :: sn_trcsbc ! surface + TYPE(FLD_N), DIMENSION(jpmaxtrc) :: sn_trccbc ! coastal + REAL(wp) , DIMENSION(jpmaxtrc) :: rn_trofac ! multiplicative factor for tracer values + REAL(wp) , DIMENSION(jpmaxtrc) :: rn_trsfac ! multiplicative factor for tracer values + REAL(wp) , DIMENSION(jpmaxtrc) :: rn_trcfac ! multiplicative factor for tracer values + !! + NAMELIST/namtrc_bc/ cn_dir_obc, sn_trcobc, rn_trofac, cn_dir_sbc, sn_trcsbc, rn_trsfac, & + & cn_dir_cbc, sn_trccbc, rn_trcfac, ln_rnf_ctl, rn_bc_time + NAMELIST/namtrc_bdy/ cn_trc_dflt, cn_trc, nn_trcdmp_bdy + !!---------------------------------------------------------------------- + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_bc_ini : Tracers Boundary Conditions (BC)' + WRITE(numout,*) '~~~~~~~~~~~ ' + ENDIF + ! Initialisation and local array allocation + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + ALLOCATE( slf_i(ntrc), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate local slf_i' ) ; RETURN + ENDIF + + ! Compute the number of tracers to be initialised with open, surface and boundary data + ALLOCATE( n_trc_indobc(ntrc), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate n_trc_indobc' ) ; RETURN + ENDIF + nb_trcobc = 0 + n_trc_indobc(:) = 0 + ! + ALLOCATE( n_trc_indsbc(ntrc), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate n_trc_indsbc' ) ; RETURN + ENDIF + nb_trcsbc = 0 + n_trc_indsbc(:) = 0 + ! + ALLOCATE( n_trc_indcbc(ntrc), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate n_trc_indcbc' ) ; RETURN + ENDIF + nb_trccbc = 0 + n_trc_indcbc(:) = 0 + ! + ! Read Boundary Conditions Namelists + REWIND( numnat_ref ) ! Namelist namtrc_bc in reference namelist : Passive tracer data structure + READ ( numnat_ref, namtrc_bc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_bc in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc_bc in configuration namelist : Passive tracer data structure + READ ( numnat_cfg, namtrc_bc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_bc in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_bc ) + + IF ( ln_bdy ) THEN + REWIND( numnat_ref ) ! Namelist namtrc_bdy in reference namelist : Passive tracer data structure + READ ( numnat_ref, namtrc_bdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_bdy in reference namelist' ) + ! make sur that all elements of the namelist variables have a default definition from namelist_ref + cn_trc (2:jp_bdy) = cn_trc (1) + cn_trc_dflt(2:jp_bdy) = cn_trc_dflt(1) + REWIND( numnat_cfg ) ! Namelist namtrc_bdy in configuration namelist : Passive tracer data structure + READ ( numnat_cfg, namtrc_bdy, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_bdy in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_bdy ) + + ! setup up preliminary informations for BDY structure + DO jn = 1, ntrc + DO ib = 1, nb_bdy + ! Set type of obc in BDY data structure (around here we may plug user override of obc type from nml) + IF ( ln_trc_obc(jn) ) THEN ; trcdta_bdy(jn,ib)%cn_obc = TRIM( cn_trc (ib) ) + ELSE ; trcdta_bdy(jn,ib)%cn_obc = TRIM( cn_trc_dflt(ib) ) + ENDIF + ! set damping use in BDY data structure + trcdta_bdy(jn,ib)%dmp = .false. + IF(nn_trcdmp_bdy(ib) == 1 .AND. ln_trc_obc(jn) ) trcdta_bdy(jn,ib)%dmp = .true. + IF(nn_trcdmp_bdy(ib) == 2 ) trcdta_bdy(jn,ib)%dmp = .true. + IF(trcdta_bdy(jn,ib)%cn_obc == 'frs' .AND. nn_trcdmp_bdy(ib) /= 0 ) & + & CALL ctl_stop( 'trc_bc_ini: Use FRS OR relaxation' ) + IF( .NOT.( 0 <= nn_trcdmp_bdy(ib) .AND. nn_trcdmp_bdy(ib) <= 2 ) ) & + & CALL ctl_stop( 'trc_bc_ini: Not a valid option for nn_trcdmp_bdy. Allowed: 0,1,2.' ) + END DO + END DO + ELSE + ! Force all tracers OBC to false if bdy not used + ln_trc_obc = .false. + ENDIF + + ! compose BC data indexes + DO jn = 1, ntrc + IF( ln_trc_obc(jn) ) THEN + nb_trcobc = nb_trcobc + 1 ; n_trc_indobc(jn) = nb_trcobc + ENDIF + IF( ln_trc_sbc(jn) ) THEN + nb_trcsbc = nb_trcsbc + 1 ; n_trc_indsbc(jn) = nb_trcsbc + ENDIF + IF( ln_trc_cbc(jn) ) THEN + nb_trccbc = nb_trccbc + 1 ; n_trc_indcbc(jn) = nb_trccbc + ENDIF + END DO + + ! Print summmary of Boundary Conditions + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,'(a,i3)') ' Total tracers to be initialized with SURFACE BCs data:', nb_trcsbc + IF ( nb_trcsbc > 0 ) THEN + WRITE(numout,*) ' #trc NAME Boundary Mult.Fact. ' + DO jn = 1, ntrc + IF ( ln_trc_sbc(jn) ) WRITE(numout,9001) jn, TRIM( sn_trcsbc(jn)%clvar ), 'SBC', rn_trsfac(jn) + END DO + ENDIF + WRITE(numout,'(2a)') ' SURFACE BC data repository : ', TRIM(cn_dir_sbc) + ! + WRITE(numout,*) + WRITE(numout,'(a,i3)') ' Total tracers to be initialized with COASTAL BCs data:', nb_trccbc + IF( nb_trccbc > 0 ) THEN + WRITE(numout,*) ' #trc NAME Boundary Mult.Fact. ' + DO jn = 1, ntrc + IF ( ln_trc_cbc(jn) ) WRITE(numout, 9001) jn, TRIM( sn_trccbc(jn)%clvar ), 'CBC', rn_trcfac(jn) + END DO + ENDIF + WRITE(numout,'(2a)') ' COASTAL BC data repository : ', TRIM(cn_dir_cbc) + IF( .NOT.ln_rnf .OR. .NOT.ln_linssh ) ln_rnf_ctl = .FALSE. + IF( ln_rnf_ctl ) WRITE(numout,'(a)') & + & ' -> Remove runoff dilution effect on tracers with absent river load (ln_rnf_ctl = .TRUE.)' + WRITE(numout,*) + WRITE(numout,'(a,i3)') ' Total tracers to be initialized with OPEN BCs data:', nb_trcobc + + IF( ln_bdy .AND. nb_trcobc > 0 ) THEN + WRITE(numout,*) ' #trc NAME Boundary Mult.Fact. OBC Settings' + DO jn = 1, ntrc + IF ( ln_trc_obc(jn) ) WRITE(numout, 9001) jn, TRIM( sn_trcobc(jn)%clvar ), 'OBC', rn_trofac(jn), & + & (trcdta_bdy(jn,ib)%cn_obc,ib=1,nb_bdy) + IF ( .NOT. ln_trc_obc(jn) ) WRITE(numout, 9002) jn, 'Set data to IC and use default condition' , & + & (trcdta_bdy(jn,ib)%cn_obc,ib=1,nb_bdy) + END DO + WRITE(numout,*) ' ' + DO ib = 1, nb_bdy + IF(nn_trcdmp_bdy(ib) == 0) WRITE(numout,9003) ' Boundary ', ib, & + & ' -> NO damping of tracers' + IF(nn_trcdmp_bdy(ib) == 1) WRITE(numout,9003) ' Boundary ', ib, & + & ' -> damping ONLY for tracers with external data provided' + IF(nn_trcdmp_bdy(ib) == 2) WRITE(numout,9003) ' Boundary ', ib, & + & ' -> damping of ALL tracers' + IF(nn_trcdmp_bdy(ib) > 0) THEN + WRITE(numout,9003) ' USE damping parameters from nambdy for boundary ', ib,' : ' + WRITE(numout,'(a,f10.2,a)') ' - Inflow damping time scale : ',rn_time_dmp (ib),' days' + WRITE(numout,'(a,f10.2,a)') ' - Outflow damping time scale : ',rn_time_dmp_out(ib),' days' + ENDIF + END DO + ENDIF + ! + WRITE(numout,'(2a)') ' OPEN BC data repository : ', TRIM(cn_dir_obc) + ENDIF +9001 FORMAT(2x,i5, 3x, a15, 3x, a5, 6x, e11.3, 4x, 10a13) +9002 FORMAT(2x,i5, 3x, a41, 3x, 10a13) +9003 FORMAT(a, i5, a) + ! + ! + ! OPEN Lateral boundary conditions + IF( ln_bdy .AND. nb_trcobc > 0 ) THEN + ALLOCATE ( sf_trcobc(nb_trcobc), rf_trofac(nb_trcobc), STAT=ierr1 ) + IF( ierr1 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate sf_trcobc structure' ) ; RETURN + ENDIF + ! + igrd = 1 ! Everything is at T-points here + ! + DO jn = 1, ntrc + DO ib = 1, nb_bdy + ! + nblen = idx_bdy(ib)%nblen(igrd) + ! + IF( ln_trc_obc(jn) ) THEN !* Initialise from external data *! + jl = n_trc_indobc(jn) + slf_i(jl) = sn_trcobc(jn) + rf_trofac(jl) = rn_trofac(jn) + ALLOCATE( sf_trcobc(jl)%fnow(nblen,1,jpk) , STAT=ierr2 ) + IF( sn_trcobc(jn)%ln_tint ) ALLOCATE( sf_trcobc(jl)%fdta(nblen,1,jpk,2) , STAT=ierr3 ) + IF( ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini : unable to allocate passive tracer OBC data arrays' ) ; RETURN + ENDIF + trcdta_bdy(jn,ib)%trc => sf_trcobc(jl)%fnow(:,1,:) + trcdta_bdy(jn,ib)%rn_fac = rf_trofac(jl) + ELSE !* Initialise obc arrays from initial conditions *! + ALLOCATE ( trcdta_bdy(jn,ib)%trc(nblen,jpk) ) + DO ibd = 1, nblen + DO ik = 1, jpkm1 + ii = idx_bdy(ib)%nbi(ibd,igrd) + ij = idx_bdy(ib)%nbj(ibd,igrd) + trcdta_bdy(jn,ib)%trc(ibd,ik) = trn(ii,ij,ik,jn) * tmask(ii,ij,ik) + END DO + END DO + trcdta_bdy(jn,ib)%rn_fac = 1._wp + ENDIF + END DO + END DO + ! + CALL fld_fill( sf_trcobc, slf_i, cn_dir_obc, 'trc_bc_ini', 'Passive tracer OBC data', 'namtrc_bc' ) + DO jn = 1, ntrc ! define imap pointer, must be done after the call to fld_fill + DO ib = 1, nb_bdy + IF( ln_trc_obc(jn) ) THEN !* Initialise from external data *! + jl = n_trc_indobc(jn) + sf_trcobc(jl)%imap => idx_bdy(ib)%nbmap(1:idx_bdy(ib)%nblen(igrd),igrd) + ENDIF + END DO + END DO + ! + ENDIF + + ! SURFACE Boundary conditions + IF( nb_trcsbc > 0 ) THEN ! allocate only if the number of tracer to initialise is greater than zero + ALLOCATE( sf_trcsbc(nb_trcsbc), rf_trsfac(nb_trcsbc), STAT=ierr1 ) + IF( ierr1 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate sf_trcsbc structure' ) ; RETURN + ENDIF + ! + DO jn = 1, ntrc + IF( ln_trc_sbc(jn) ) THEN ! update passive tracers arrays with input data read from file + jl = n_trc_indsbc(jn) + slf_i(jl) = sn_trcsbc(jn) + rf_trsfac(jl) = rn_trsfac(jn) + ALLOCATE( sf_trcsbc(jl)%fnow(jpi,jpj,1) , STAT=ierr2 ) + IF( sn_trcsbc(jn)%ln_tint ) ALLOCATE( sf_trcsbc(jl)%fdta(jpi,jpj,1,2) , STAT=ierr3 ) + IF( ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini : unable to allocate passive tracer SBC data arrays' ) ; RETURN + ENDIF + ENDIF + ! + END DO + ! ! fill sf_trcsbc with slf_i and control print + CALL fld_fill( sf_trcsbc, slf_i, cn_dir_sbc, 'trc_bc_ini', 'Passive tracer SBC data', 'namtrc_bc' ) + ! + ENDIF + ! + ! COSTAL Boundary conditions + IF( nb_trccbc > 0 ) THEN ! allocate only if the number of tracer to initialise is greater than zero + ALLOCATE( sf_trccbc(nb_trccbc), rf_trcfac(nb_trccbc), STAT=ierr1 ) + IF( ierr1 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini: unable to allocate sf_trccbc structure' ) ; RETURN + ENDIF + ! + DO jn = 1, ntrc + IF( ln_trc_cbc(jn) ) THEN ! update passive tracers arrays with input data read from file + jl = n_trc_indcbc(jn) + slf_i(jl) = sn_trccbc(jn) + rf_trcfac(jl) = rn_trcfac(jn) + ALLOCATE( sf_trccbc(jl)%fnow(jpi,jpj,1) , STAT=ierr2 ) + IF( sn_trccbc(jn)%ln_tint ) ALLOCATE( sf_trccbc(jl)%fdta(jpi,jpj,1,2) , STAT=ierr3 ) + IF( ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'trc_bc_ini : unable to allocate passive tracer CBC data arrays' ) ; RETURN + ENDIF + ENDIF + ! + END DO + ! ! fill sf_trccbc with slf_i and control print + CALL fld_fill( sf_trccbc, slf_i, cn_dir_cbc, 'trc_bc_ini', 'Passive tracer CBC data', 'namtrc_bc' ) + ! + ENDIF + ! + DEALLOCATE( slf_i ) ! deallocate local field structure + ! + END SUBROUTINE trc_bc_ini + + + SUBROUTINE trc_bc(kt, jit) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_bc *** + !! + !! ** Purpose : Apply Boundary Conditions data to tracers + !! + !! ** Method : 1) Read BC inputs and update data structures using fldread + !! 2) Apply Boundary Conditions to tracers + !!---------------------------------------------------------------------- + USE fldread + !! + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in), OPTIONAL :: jit ! subcycle time-step index (for timesplitting option) + !! + INTEGER :: ji, jj, jk, jn, jl ! Loop index + REAL(wp) :: zfact, zrnf + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_bc') + + IF( kt == nit000 .AND. lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_bc : Surface boundary conditions for passive tracers.' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! 1. Update Boundary conditions data + IF( PRESENT(jit) ) THEN + ! + ! OPEN boundary conditions (use kt_offset=+1 as they are applied at the end of the step) + IF( nb_trcobc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading OBC data for ', nb_trcobc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trcobc, kit=jit, kt_offset=+1) + ENDIF + ! + ! SURFACE boundary conditions + IF( nb_trcsbc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading SBC data for ', nb_trcsbc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trcsbc, kit=jit) + ENDIF + ! + ! COASTAL boundary conditions + IF( nb_trccbc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading CBC data for ', nb_trccbc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trccbc, kit=jit) + ENDIF + ! + ELSE + ! + ! OPEN boundary conditions (use kt_offset=+1 as they are applied at the end of the step) + IF( nb_trcobc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading OBC data for ', nb_trcobc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trcobc, kt_offset=+1) + ENDIF + ! + ! SURFACE boundary conditions + IF( nb_trcsbc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading SBC data for ', nb_trcsbc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trcsbc ) + ENDIF + ! + ! COASTAL boundary conditions + IF( nb_trccbc > 0 ) THEN + if (lwp) write(numout,'(a,i5,a,i10)') ' reading CBC data for ', nb_trccbc ,' variable(s) at step ', kt + CALL fld_read( kt=kt, kn_fsbc=1, sd=sf_trccbc ) + ENDIF + ! + ENDIF + + ! 2. Apply Boundary conditions data + ! + DO jn = 1 , jptra + ! + ! Remove river dilution for tracers with absent river load + IF( ln_rnf_ctl .AND. .NOT.ln_trc_cbc(jn) ) THEN + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + DO jk = 1, nk_rnf(ji,jj) + zrnf = (rnf(ji,jj) + rnf_b(ji,jj)) * 0.5_wp * r1_rau0 / h_rnf(ji,jj) + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + (trn(ji,jj,jk,jn) * zrnf) + END DO + END DO + END DO + ENDIF + ! + ! OPEN boundary conditions: trcbdy is called in trcnxt ! + ! + ! SURFACE boundary conditions + IF( ln_trc_sbc(jn) ) THEN + jl = n_trc_indsbc(jn) + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + zfact = 1. / ( e3t_n(ji,jj,1) * rn_bc_time ) + tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + rf_trsfac(jl) * sf_trcsbc(jl)%fnow(ji,jj,1) * zfact + END DO + END DO + ENDIF + ! + ! COASTAL boundary conditions + IF( ln_rnf .AND. ln_trc_cbc(jn) ) THEN + jl = n_trc_indcbc(jn) + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + DO jk = 1, nk_rnf(ji,jj) + zfact = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_bc_time ) + tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + rf_trcfac(jl) * sf_trccbc(jl)%fnow(ji,jj,1) * zfact + END DO + END DO + END DO + ENDIF + ! ! =========== + END DO ! tracer loop + ! ! =========== + IF( ln_timing ) CALL timing_stop('trc_bc') + ! + END SUBROUTINE trc_bc + +#else + !!---------------------------------------------------------------------- + !! Dummy module NO 3D passive tracer data + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_bc_ini( ntrc ) ! Empty routine + INTEGER,INTENT(IN) :: ntrc ! number of tracers + WRITE(*,*) 'trc_bc_ini: You should not have seen this print! error?', kt + END SUBROUTINE trc_bc_ini + SUBROUTINE trc_bc( kt ) ! Empty routine + WRITE(*,*) 'trc_bc: You should not have seen this print! error?', kt + END SUBROUTINE trc_bc +#endif + + !!====================================================================== +END MODULE trcbc diff --git a/V4.0/nemo_sources/src/TOP/trcbdy.F90 b/V4.0/nemo_sources/src/TOP/trcbdy.F90 new file mode 100644 index 0000000000000000000000000000000000000000..616f855d2ae682f237ae488186f96dbf6081b80c --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcbdy.F90 @@ -0,0 +1,164 @@ +MODULE trcbdy + !!====================================================================== + !! *** MODULE bdytrc *** + !! Ocean tracers: Apply boundary conditions for tracers in TOP component + !!====================================================================== + !! 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 + !! 3.6 ! 2015 (T. Lovato) Adapt BDY for tracers in TOP component + !! 4.0 ! 2016 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! trc_bdy : Apply open boundary conditions & damping to tracers + !!---------------------------------------------------------------------- + USE timing ! Timing + USE oce_trc ! ocean dynamics and tracers variables + USE par_trc + USE trc ! ocean space and time domain variables + USE bdylib ! for orlanski library routines + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE bdy_oce ! ocean open boundary conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_bdy ! routine called in trcnxt.F90 + PUBLIC trc_bdy_dmp ! routine called in trcstp.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcbdy.F90 11821 2019-10-29 10:08:08Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_bdy( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE trc_bdy *** + !! + !! ** Purpose : - Apply open boundary conditions for TOP tracers + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! Main time step counter + !! + INTEGER :: ib_bdy ,ir, jn ,igrd ! Loop indices + REAL(wp), POINTER, DIMENSION(:,:) :: ztrc + REAL(wp), POINTER :: zfac + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_bdy') + ! + 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 + DO jn = 1, jptra + ! + ztrc => trcdta_bdy(jn,ib_bdy)%trc + zfac => trcdta_bdy(jn,ib_bdy)%rn_fac + ! + SELECT CASE( TRIM(trcdta_bdy(jn,ib_bdy)%cn_obc) ) + CASE('none' ) ; CYCLE + CASE('frs' ) ! treat the whole boundary at once + IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy), tra(:,:,:,jn), ztrc*zfac ) + CASE('specified' ) ! treat the whole rim at once + IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy), tra(:,:,:,jn), ztrc*zfac ) + CASE('neumann' ) ; CALL bdy_nmn( idx_bdy(ib_bdy), igrd , tra(:,:,:,jn) ) ! tra masked + CASE('orlanski' ) ; CALL bdy_orl( idx_bdy(ib_bdy), trb(:,:,:,jn), tra(:,:,:,jn), ztrc*zfac, ll_npo=.false. ) + CASE('orlanski_npo') ; CALL bdy_orl( idx_bdy(ib_bdy), trb(:,:,:,jn), tra(:,:,:,jn), ztrc*zfac, ll_npo=.true. ) + CASE DEFAULT ; CALL ctl_stop( 'trc_bdy : unrecognised option for open boundaries for passive tracers' ) + 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') + 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( 'trcbdy', tra, 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + ! + END DO ! ir + ! + IF( ln_timing ) CALL timing_stop('trc_bdy') + ! + END SUBROUTINE trc_bdy + + + SUBROUTINE trc_bdy_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE trc_bdy_dmp *** + !! + !! ** Purpose : Apply damping for tracers at open boundaries. + !! It currently applies the damping to all tracers!!! + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + !! + INTEGER :: jn ! Tracer index + 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('trc_bdy_dmp') + ! + DO jn = 1, jptra + DO ib_bdy=1, nb_bdy + IF( trcdta_bdy(jn, ib_bdy)%dmp ) 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 * ( trcdta_bdy(jn, ib_bdy)%trc(ib,ik) - trb(ii,ij,ik,jn) ) * tmask(ii,ij,ik) + tra(ii,ij,ik,jn) = tra(ii,ij,ik,jn) + zta + END DO + END DO + ENDIF + END DO + END DO + ! + IF( ln_timing ) CALL timing_stop('trc_bdy_dmp') + ! + END SUBROUTINE trc_bdy_dmp + +#else + !!---------------------------------------------------------------------- + !! Dummy module NO Unstruct Open Boundary Conditions + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_bdy(kt) ! Empty routine + WRITE(*,*) 'trc_bdy: You should not have seen this print! error?', kt + END SUBROUTINE trc_bdy + + SUBROUTINE trc_bdy_dmp(kt) ! Empty routine + WRITE(*,*) 'trc_bdy_dmp: You should not have seen this print! error?', kt + END SUBROUTINE trc_bdy_dmp + +#endif + + !!====================================================================== +END MODULE trcbdy diff --git a/V4.0/nemo_sources/src/TOP/trcdta.F90 b/V4.0/nemo_sources/src/TOP/trcdta.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a19c8950f9b17dd1720689bceadb9e4b67eb2444 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcdta.F90 @@ -0,0 +1,258 @@ +MODULE trcdta + !!====================================================================== + !! *** MODULE trcdta *** + !! TOP : reads passive tracer data + !!===================================================================== + !! History : 1.0 ! 2002-04 (O. Aumont) original code + !! - ! 2004-03 (C. Ethe) module + !! - ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !! 3.4 ! 2010-11 (C. Ethe, G. Madec) use of fldread + dynamical allocation + !! 3.5 ! 2013-08 (M. Vichi) generalization for other BGC models + !! 3.6 ! 2015-03 (T. Lovato) revisit code I/O + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP model + !!---------------------------------------------------------------------- + !! trc_dta : read and time interpolated passive tracer data + !!---------------------------------------------------------------------- + USE par_trc ! passive tracers parameters + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + ! + USE iom ! I/O manager + USE lib_mpp ! MPP library + USE fldread ! read input fields + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_dta ! called in trcini.F90 and trcdmp.F90 + PUBLIC trc_dta_ini ! called in trcini.F90 + + INTEGER , SAVE, PUBLIC :: nb_trcdta ! number of tracers to be initialised with data + INTEGER , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_index ! indice of tracer which is initialised with data + INTEGER , SAVE, PUBLIC :: ntra ! MAX( 1, nb_trcdta ) to avoid compilation error with bounds checking + REAL(wp) , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: rf_trfac ! multiplicative factor for tracer values +!$AGRIF_DO_NOT_TREAT + TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf_trcdta ! structure of input SST (file informations, fields read) +!$AGRIF_END_DO_NOT_TREAT + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcdta.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_dta_ini(ntrc) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dta_ini *** + !! + !! ** Purpose : initialisation of passive tracer input data + !! + !! ** Method : - Read namtsd namelist + !! - allocates passive tracer data structure + !!---------------------------------------------------------------------- + INTEGER,INTENT(in) :: ntrc ! number of tracers + ! + INTEGER :: jl, jn ! dummy loop indices + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + REAL(wp) :: zfact + CHARACTER(len=100) :: clndta, clntrc + ! + CHARACTER(len=100) :: cn_dir + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N), DIMENSION(jpmaxtrc) :: sn_trcdta + REAL(wp) , DIMENSION(jpmaxtrc) :: rn_trfac ! multiplicative factor for tracer values + !! + NAMELIST/namtrc_dta/ sn_trcdta, cn_dir, rn_trfac + !!---------------------------------------------------------------------- + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_dta_ini : Tracers Initial Conditions (IC)' + WRITE(numout,*) '~~~~~~~~~~~ ' + ENDIF + ! + ! Initialisation + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + ! Compute the number of tracers to be initialised with data + ALLOCATE( n_trc_index(ntrc), slf_i(ntrc), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'trc_dta_ini: unable to allocate n_trc_index' ) ; RETURN + ENDIF + nb_trcdta = 0 + n_trc_index(:) = 0 + DO jn = 1, ntrc + IF( ln_trc_ini(jn) ) THEN + nb_trcdta = nb_trcdta + 1 + n_trc_index(jn) = nb_trcdta + ENDIF + END DO + ! + ntra = MAX( 1, nb_trcdta ) ! To avoid compilation error with bounds checking + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' number of passive tracers to be initialize by data :', ntra + ENDIF + ! + REWIND( numnat_ref ) ! Namelist namtrc_dta in reference namelist : Passive tracer input data + READ ( numnat_ref, namtrc_dta, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_dta_ini in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc_dta in configuration namelist : Passive tracer input data + READ ( numnat_cfg, namtrc_dta, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_dta_ini in configuration namelist' ) + IF(lwm) WRITE ( numont, namtrc_dta ) + + IF( lwp ) THEN + DO jn = 1, ntrc + IF( ln_trc_ini(jn) ) THEN ! open input file only if ln_trc_ini(jn) is true + clndta = TRIM( sn_trcdta(jn)%clvar ) + clntrc = TRIM( ctrcnm (jn) ) + if (jn > jptra) clntrc='Dummy' ! By pass weird formats in ocean.output if ntrc > jptra + zfact = rn_trfac(jn) + IF( clndta /= clntrc ) THEN + CALL ctl_warn( 'trc_dta_ini: passive tracer data initialisation ', & + & 'Input name of data file : '//TRIM(clndta)// & + & ' differs from that of tracer : '//TRIM(clntrc)//' ') + ENDIF + WRITE(numout,*) + WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & + & jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact + ENDIF + END DO + ENDIF + ! + IF( nb_trcdta > 0 ) THEN ! allocate only if the number of tracer to initialise is greater than zero + ALLOCATE( sf_trcdta(nb_trcdta), rf_trfac(nb_trcdta), STAT=ierr1 ) + IF( ierr1 > 0 ) THEN + CALL ctl_stop( 'trc_dta_ini: unable to allocate sf_trcdta structure' ) ; RETURN + ENDIF + ! + DO jn = 1, ntrc + IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file + jl = n_trc_index(jn) + slf_i(jl) = sn_trcdta(jn) + rf_trfac(jl) = rn_trfac(jn) + ALLOCATE( sf_trcdta(jl)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_trcdta(jn)%ln_tint ) ALLOCATE( sf_trcdta(jl)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + IF( ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'trc_dta_ini : unable to allocate passive tracer data arrays' ) ; RETURN + ENDIF + ENDIF + ! + ENDDO + ! ! fill sf_trcdta with slf_i and control print + CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta_ini', 'Passive tracer data', 'namtrc' ) + ! + ENDIF + ! + DEALLOCATE( slf_i ) ! deallocate local field structure + ! + END SUBROUTINE trc_dta_ini + + + SUBROUTINE trc_dta( kt, sf_trcdta, ptrcfac, ptrcdta) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_dta *** + !! + !! ** Purpose : provides passive tracer data at kt + !! + !! ** Method : - call fldread routine + !! - s- or mixed z-s coordinate: vertical interpolation on model mesh + !! - ln_trcdmp=F: deallocates the data structure as they are not used + !! + !! ** Action : sf_trcdta passive tracer data on meld mesh and interpolated at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_trcdta ! array of information on the field to read + REAL(wp) , INTENT(in ) :: ptrcfac ! multiplication factor + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout ) :: ptrcdta ! 3D data array + ! + INTEGER :: ji, jj, jk, jl, jkk, ik ! dummy loop indices + REAL(wp):: zl, zi + REAL(wp), DIMENSION(jpk) :: ztp ! 1D workspace + CHARACTER(len=100) :: clndta + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_dta') + ! + IF( nb_trcdta > 0 ) THEN + ! + ! read data at kt time step + CALL fld_read( kt, 1, sf_trcdta ) + ptrcdta(:,:,:) = sf_trcdta(1)%fnow(:,:,:) * tmask(:,:,:) + ! + IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + IF( kt == nit000 .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_dta: interpolates passive tracer 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_n(ji,jj,jk) + IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data + ztp(jk) = ptrcdta(ji,jj,1) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data + ztp(jk) = ptrcdta(ji,jj,jpkm1) + 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) = ptrcdta(ji,jj,jkk) + ( ptrcdta(ji,jj,jkk+1) - ptrcdta(ji,jj,jkk) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 + ptrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord + END DO + ptrcdta(ji,jj,jpk) = 0._wp + END DO + END DO + ! + ELSE !== z- or zps- coordinate ==! + ! zps-coordinate (partial steps) interpolation at the last ocean level +! IF( ln_zps ) THEN +! 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) ) +! ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik-1) +! 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) ) +! ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik+1) +! ENDIF +! END DO +! END DO +! ENDIF + ! + ENDIF + ! + ! Scale by multiplicative factor + ptrcdta(:,:,:) = ptrcdta(:,:,:) * ptrcfac + ! + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_dta') + ! + END SUBROUTINE trc_dta + +#else + !!---------------------------------------------------------------------- + !! Dummy module NO 3D passive tracer data + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_dta( kt, sf_trcdta, ptrcfac, ptrcdta) ! Empty routine + WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt + END SUBROUTINE trc_dta +#endif + + !!====================================================================== +END MODULE trcdta diff --git a/V4.0/nemo_sources/src/TOP/trcice.F90 b/V4.0/nemo_sources/src/TOP/trcice.F90 new file mode 100644 index 0000000000000000000000000000000000000000..087454efb2919b86101b3b4f2d3916786b61d2e0 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcice.F90 @@ -0,0 +1,121 @@ +MODULE trcice + !!====================================================================== + !! *** MODULE trcice *** + !! TOP : Manage the communication between TOP and sea ice + !!====================================================================== + !! History : 3.5 ! 2013 (M. Vancoppenolle, O. Aumont, G. Madec), original code + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_ice : Call the appropriate sea ice tracer subroutine + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE trcice_cfc ! CFC initialisation + USE trcice_pisces ! PISCES initialisation + USE trcice_c14 ! C14 bomb initialisation + USE trcice_age ! AGE initialisation + USE trcice_my_trc ! MY_TRC initialisation + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_ice_ini ! called by trc_nam + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcice.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_ice_ini + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_ice_ini *** + !! + !! ** Purpose : Initialization of the ice module for tracers + !! + !! ** Method : - + !!--------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_ice_ini : Initialize sea ice tracer boundary condition' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + CALL trc_nam_ice + ! + trc_i(:,:,:) = 0._wp ! by default + trc_o(:,:,:) = 0._wp ! by default + ! + IF ( nn_ice_tr == 1 ) THEN + IF( ln_pisces ) CALL trc_ice_ini_pisces ! PISCES bio-model + IF( ll_cfc ) CALL trc_ice_ini_cfc ! CFC tracers + IF( ln_c14 ) CALL trc_ice_ini_c14 ! C14 tracer + IF( ln_age ) CALL trc_ice_ini_age ! AGE tracer + IF( ln_my_trc ) CALL trc_ice_ini_my_trc ! MY_TRC tracers + ENDIF + ! + END SUBROUTINE trc_ice_ini + + + SUBROUTINE trc_nam_ice + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_nam_ice *** + !! + !! ** Purpose : Read the namelist for the ice effect on tracers + !! + !! ** Method : - + !!--------------------------------------------------------------------- + INTEGER :: jn ! dummy loop indices + INTEGER :: ios, ierr ! Local integer output status for namelist read + ! + TYPE(TRC_I_NML), DIMENSION(jpmaxtrc) :: sn_tri_tracer + !! + NAMELIST/namtrc_ice/ nn_ice_tr, sn_tri_tracer + !!--------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trc_nam_ice : Read the namelist for trc_ice' + WRITE(numout,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + ENDIF + ! + REWIND( numnat_ref ) ! Namelist namtrc_ice in reference namelist : Passive tracer input data + READ ( numnat_ref, namtrc_ice, IOSTAT = ios, ERR = 901) + 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtrc_ice in reference namelist ' ) + REWIND( numnat_cfg ) ! Namelist namtrc_ice in configuration namelist : Pisces external sources of nutrients + READ ( numnat_cfg, namtrc_ice, IOSTAT = ios, ERR = 902 ) + 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_ice in configuration namelist' ) + + IF( lwp ) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) ' Namelist : namtrc_ice' + WRITE(numout,*) ' Sea ice tracers option (nn_ice_tr) : ', nn_ice_tr + ENDIF + ! + ! Assign namelist stuff + DO jn = 1, jptra + trc_ice_ratio (jn) = sn_tri_tracer(jn)%trc_ratio + trc_ice_prescr(jn) = sn_tri_tracer(jn)%trc_prescr + cn_trc_o (jn) = sn_tri_tracer(jn)%ctrc_o + END DO + ! + END SUBROUTINE trc_nam_ice + +#else + !!---------------------------------------------------------------------- + !! Empty module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_ice_ini ! Dummy routine + END SUBROUTINE trc_ice_ini + SUBROUTINE trc_nam_ice + END SUBROUTINE trc_nam_ice +#endif + + !!====================================================================== +END MODULE trcice diff --git a/V4.0/nemo_sources/src/TOP/trcini.F90 b/V4.0/nemo_sources/src/TOP/trcini.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fb20bf47b33db9b80810d4642ad4dd51aafae341 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcini.F90 @@ -0,0 +1,293 @@ +MODULE trcini + !!====================================================================== + !! *** MODULE trcini *** + !! TOP : Manage the passive tracer initialization + !!====================================================================== + !! History : - ! 1991-03 (O. Marti) original code + !! 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !! 2.0 ! 2005-10 (C. Ethe, G. Madec) revised architecture + !! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_init : Initialization for passive tracer + !! top_alloc : allocate the TOP arrays + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE trcnam ! Namelist read + USE daymod ! calendar manager + USE prtctl_trc ! Print control passive tracers (prt_ctl_trc_init routine) + USE trcsub ! variables to substep passive tracers + USE trcrst + USE lib_mpp ! distribued memory computing library + USE trcice ! tracers in sea ice + USE trcbc, only : trc_bc_ini ! generalized Boundary Conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_init ! called by opa + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcini.F90 12841 2020-05-01 10:52:40Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_init + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_init *** + !! + !! ** Purpose : Initialization of the passive tracer fields + !! + !! ** Method : - read namelist + !! - control the consistancy + !! - compute specific initialisations + !! - set initial tracer fields (either read restart + !! or read data or analytical formulation + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_init') + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_init : initial set up of the passive tracers' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + CALL trc_nam ! read passive tracers namelists + CALL top_alloc() ! allocate TOP arrays + ! + IF(.NOT.ln_trcdta ) ln_trc_ini(:) = .FALSE. + ! + IF(lwp) WRITE(numout,*) + IF( ln_rsttr .AND. .NOT. l_offline ) CALL trc_rst_cal( nit000, 'READ' ) ! calendar + IF(lwp) WRITE(numout,*) + ! + CALL trc_ini_sms ! SMS + CALL trc_ini_trp ! passive tracers transport + CALL trc_ice_ini ! Tracers in sea ice + ! + IF( lwm .AND. sn_cfctl%l_trcstat ) THEN + CALL ctl_opn( numstr, 'tracer.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp , narea ) + ENDIF + ! + CALL trc_ini_state ! passive tracers initialisation : from a restart or from clim + IF( nn_dttrc /= 1 ) & + CALL trc_sub_ini ! Initialize variables for substepping passive tracers + ! + CALL trc_ini_inv ! Inventories + ! + IF( ln_timing ) CALL timing_stop('trc_init') + ! + END SUBROUTINE trc_init + + + SUBROUTINE trc_ini_inv + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_stat *** + !! ** Purpose : passive tracers inventories at initialsation phase + !!---------------------------------------------------------------------- + INTEGER :: jk, jn ! dummy loop indices + CHARACTER (len=25) :: charout + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_ini_inv : initial passive tracers inventories' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! ! masked grid volume + DO jk = 1, jpk + cvol(:,:,jk) = e1e2t(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + ! ! total volume of the ocean + areatot = glob_sum( 'trcini', cvol(:,:,:) ) + ! + trai(:) = 0._wp ! initial content of all tracers + DO jn = 1, jptra + trai(jn) = trai(jn) + glob_sum( 'trcini', trn(:,:,:,jn) * cvol(:,:,:) ) + END DO + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Total number of passive tracer jptra = ', jptra + WRITE(numout,*) ' Total volume of ocean = ', areatot + WRITE(numout,*) ' Total inital content of all tracers ' + WRITE(numout,*) + DO jn = 1, jptra + WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), trai(jn) + ENDDO + WRITE(numout,*) + ENDIF + IF(lwp) WRITE(numout,*) + IF(ln_ctl) THEN ! print mean trends (used for debugging) + CALL prt_ctl_trc_init + WRITE(charout, FMT="('ini ')") + CALL prt_ctl_trc_info( charout ) + CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm ) + ENDIF +9000 FORMAT(' tracer nb : ',i2,' name :',a10,' initial content :',e18.10) + ! + END SUBROUTINE trc_ini_inv + + + SUBROUTINE trc_ini_sms + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_sms *** + !! ** Purpose : SMS initialisation + !!---------------------------------------------------------------------- + USE trcini_pisces ! PISCES initialisation + USE trcini_cfc ! CFC initialisation + USE trcini_c14 ! C14 initialisation + USE trcini_age ! age initialisation + USE trcini_my_trc ! MY_TRC initialisation + ! + INTEGER :: jn + !!---------------------------------------------------------------------- + ! + ! Pass sn_tracer fields to specialized arrays + DO jn = 1, jp_bgc + ctrcnm (jn) = TRIM( sn_tracer(jn)%clsname ) + ctrcln (jn) = TRIM( sn_tracer(jn)%cllname ) + ctrcun (jn) = TRIM( sn_tracer(jn)%clunit ) + ln_trc_ini(jn) = sn_tracer(jn)%llinit + ln_trc_sbc(jn) = sn_tracer(jn)%llsbc + ln_trc_cbc(jn) = sn_tracer(jn)%llcbc + ln_trc_obc(jn) = sn_tracer(jn)%llobc + END DO + ! + IF( ln_pisces ) CALL trc_ini_pisces ! PISCES model + IF( ln_my_trc ) CALL trc_ini_my_trc ! MY_TRC model + IF( ll_cfc ) CALL trc_ini_cfc ! CFC's + IF( ln_c14 ) CALL trc_ini_c14 ! C14 model + IF( ln_age ) CALL trc_ini_age ! AGE + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'trc_init_sms : Summary for selected passive tracers' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' ID NAME INI SBC CBC OBC' + DO jn = 1, jptra + WRITE(numout,9001) jn, TRIM(ctrcnm(jn)), ln_trc_ini(jn), ln_trc_sbc(jn),ln_trc_cbc(jn),ln_trc_obc(jn) + END DO + ENDIF +9001 FORMAT(3x,i3,1x,a10,3x,l2,3x,l2,3x,l2,3x,l2) + ! + END SUBROUTINE trc_ini_sms + + + SUBROUTINE trc_ini_trp + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_trp *** + !! + !! ** Purpose : Allocate all the dynamic arrays of the OPA modules + !!---------------------------------------------------------------------- + USE trcdmp , ONLY: trc_dmp_ini + USE trcadv , ONLY: trc_adv_ini + USE trcldf , ONLY: trc_ldf_ini + USE trcrad , ONLY: trc_rad_ini + USE trcsink, ONLY: trc_sink_ini + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + IF( ln_trcdmp ) CALL trc_dmp_ini ! damping + CALL trc_adv_ini ! advection + CALL trc_ldf_ini ! lateral diffusion + ! ! vertical diffusion: always implicit time stepping scheme + CALL trc_rad_ini ! positivity of passive tracers + CALL trc_sink_ini ! Vertical sedimentation of particles + ! + END SUBROUTINE trc_ini_trp + + + SUBROUTINE trc_ini_state + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_ini_state *** + !! ** Purpose : Initialisation of passive tracer concentration + !!---------------------------------------------------------------------- + USE zpshde ! partial step: hor. derivative (zps_hde routine) + USE trcrst ! passive tracers restart + USE trcdta ! initialisation from files + ! + INTEGER :: jn, jl ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_trcdta ) CALL trc_dta_ini( jptra ) ! set initial tracers values + ! + CALL trc_bc_ini ( jptra ) ! set tracers Boundary Conditions + ! + ! + IF( ln_rsttr ) THEN ! restart from a file + ! + CALL trc_rst_read + ! + ELSE ! Initialisation of tracer from a file that may also be used for damping +!!gm BUG ? if damping and restart, what's happening ? + IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN + ! update passive tracers arrays with input data read from file + DO jn = 1, jptra + IF( ln_trc_ini(jn) ) THEN + jl = n_trc_index(jn) + CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl), trn(:,:,:,jn) ) + ! + ! deallocate data structure if data are not used for damping + IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN + IF(lwp) WRITE(numout,*) 'trc_ini_state: deallocate data arrays as they are only used to initialize the run' + DEALLOCATE( sf_trcdta(jl)%fnow ) + IF( sf_trcdta(jl)%ln_tint ) DEALLOCATE( sf_trcdta(jl)%fdta ) + ! + ENDIF + ENDIF + END DO + ! + ENDIF + ! + trb(:,:,:,:) = trn(:,:,:,:) + ! + ENDIF + ! + tra(:,:,:,:) = 0._wp + ! ! Partial top/bottom cell: GRADh(trn) + END SUBROUTINE trc_ini_state + + + SUBROUTINE top_alloc + !!---------------------------------------------------------------------- + !! *** ROUTINE top_alloc *** + !! + !! ** Purpose : Allocate all the dynamic arrays of the OPA modules + !!---------------------------------------------------------------------- + USE trc , ONLY: trc_alloc + USE trdtrc_oce , ONLY: trd_trc_oce_alloc +#if defined key_trdmxl_trc + USE trdmxl_trc , ONLY: trd_mxl_trc_alloc +#endif + ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + ierr = trc_alloc() + ierr = ierr + trd_trc_oce_alloc() +#if defined key_trdmxl_trc + ierr = ierr + trd_mxl_trc_alloc() +#endif + ! + CALL mpp_sum( 'trcini', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'top_alloc : unable to allocate standard ocean arrays' ) + ! + END SUBROUTINE top_alloc + +#else + !!---------------------------------------------------------------------- + !! Empty module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_init ! Dummy routine + END SUBROUTINE trc_init +#endif + + !!====================================================================== +END MODULE trcini diff --git a/V4.0/nemo_sources/src/TOP/trcnam.F90 b/V4.0/nemo_sources/src/TOP/trcnam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9e0c65e27a4bddefb53a8c47c8ccdb32967bee2c --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcnam.F90 @@ -0,0 +1,298 @@ +MODULE trcnam + !!====================================================================== + !! *** MODULE trcnam *** + !! TOP : Read and print options for the passive tracer run (namelist) + !!====================================================================== + !! History : - ! 1996-11 (M.A. Foujols, M. Levy) original code + !! - ! 1998-04 (M.A Foujols, L. Bopp) ahtrb0 for isopycnal mixing + !! - ! 1999-10 (M.A. Foujols, M. Levy) separation of sms + !! - ! 2000-07 (A. Estublier) add TVD and MUSCL : Tests on ndttrc + !! - ! 2000-11 (M.A Foujols, E Kestenare) trcrat, ahtrc0 and aeivtr0 + !! - ! 2001-01 (E Kestenare) suppress ndttrc=1 for CEN2 and TVD schemes + !! 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_nam : Read and print options for the passive tracer run (namelist) + !!---------------------------------------------------------------------- + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE trd_oce ! + USE trdtrc_oce ! + USE iom ! I/O manager +#if defined key_mpp_mpi + USE lib_mpp, ONLY: ncom_dttrc +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_nam_run ! called in trcini + PUBLIC trc_nam ! called in trcini + + TYPE(PTRACER), DIMENSION(jpmaxtrc), PUBLIC :: sn_tracer !: type of tracer for saving if not key_iomput + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcnam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_nam + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_nam *** + !! + !! ** Purpose : READ and PRINT options for the passive tracer run (namelist) + !! + !! ** Method : - read passive tracer namelist + !! - read namelist of each defined SMS model + !! ( (PISCES, CFC, MY_TRC ) + !!--------------------------------------------------------------------- + INTEGER :: jn ! dummy loop indice + !!--------------------------------------------------------------------- + ! + IF( .NOT.l_offline ) CALL trc_nam_run ! Parameters of the run + ! + CALL trc_nam_trc ! passive tracer informations + ! + IF( ln_rsttr ) ln_trcdta = .FALSE. ! restart : no need of clim data + ! + IF( ln_trcdmp .OR. ln_trcdmp_clo ) ln_trcdta = .TRUE. ! damping : need to have clim data + ! + ! + IF(lwp) THEN ! control print + IF( ln_rsttr ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Read a restart file for passive tracer : ', TRIM( cn_trcrst_in ) + ENDIF + IF( ln_trcdta .AND. .NOT.ln_rsttr ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Some of the passive tracers are initialised from climatologies ' + ENDIF + IF( .NOT.ln_trcdta ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> All the passive tracers are initialised with constant values ' + ENDIF + ENDIF + ! + rdttrc = rdt * FLOAT( nn_dttrc ) ! passive tracer time-step + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Passive Tracer time step rdttrc = nn_dttrc*rdt = ', rdttrc + ENDIF + ! + IF( l_trdtrc ) CALL trc_nam_trd ! Passive tracer trends + ! + END SUBROUTINE trc_nam + + + SUBROUTINE trc_nam_run + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_nam *** + !! + !! ** Purpose : read options for the passive tracer run (namelist) + !! + !!--------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namtrc_run/ nn_dttrc, ln_rsttr, nn_rsttr, ln_top_euler, & + & cn_trcrst_indir, cn_trcrst_outdir, cn_trcrst_in, cn_trcrst_out + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_nam_run : read the passive tracer namelists' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + CALL ctl_opn( numnat_ref, 'namelist_top_ref' , 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numnat_cfg, 'namelist_top_cfg' , 'OLD' , 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + IF(lwm) CALL ctl_opn( numont, 'output.namelist.top', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., 1 ) + ! + REWIND( numnat_ref ) ! Namelist namtrc in reference namelist : Passive tracer variables + READ ( numnat_ref, namtrc_run, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc in configuration namelist : Passive tracer variables + READ ( numnat_cfg, namtrc_run, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc in configuration namelist' ) + IF(lwm) WRITE( numont, namtrc_run ) + + nittrc000 = nit000 + nn_dttrc - 1 ! first time step of tracer model + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namtrc_run' + WRITE(numout,*) ' time step freq. for passive tracer nn_dttrc = ', nn_dttrc + WRITE(numout,*) ' restart for passive tracer ln_rsttr = ', ln_rsttr + WRITE(numout,*) ' control of time step for passive tracer nn_rsttr = ', nn_rsttr + WRITE(numout,*) ' first time step for pass. trac. nittrc000 = ', nittrc000 + WRITE(numout,*) ' Use euler integration for TRC (y/n) ln_top_euler = ', ln_top_euler + ENDIF + ! +#if defined key_mpp_mpi + ncom_dttrc = nn_dttrc ! make nn_fsbc available for lib_mpp +#endif + ! + END SUBROUTINE trc_nam_run + + + SUBROUTINE trc_nam_trc + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_nam *** + !! + !! ** Purpose : read options for the passive tracer run (namelist) + !! + !!--------------------------------------------------------------------- + INTEGER :: ios, ierr, icfc ! Local integer + !! + NAMELIST/namtrc/jp_bgc, ln_pisces, ln_my_trc, ln_age, ln_cfc11, ln_cfc12, ln_sf6, ln_c14, & + & sn_tracer, ln_trcdta, ln_trcdmp, ln_trcdmp_clo, jp_dia3d, jp_dia2d + !!--------------------------------------------------------------------- + ! Dummy settings to fill tracers data structure + ! ! name ! title ! unit ! init ! sbc ! cbc ! obc ! + sn_tracer = PTRACER( 'NONAME' , 'NOTITLE' , 'NOUNIT' , .false. , .false. , .false. , .false.) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_nam_trc : read the passive tracer namelists' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + REWIND( numnat_ref ) ! Namelist namtrc in reference namelist : Passive tracer variables + READ ( numnat_ref, namtrc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc in configuration namelist : Passive tracer variables + READ ( numnat_cfg, namtrc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc in configuration namelist' ) + IF(lwm) WRITE( numont, namtrc ) + + ! Control settings + IF( ln_pisces .AND. ln_my_trc ) CALL ctl_stop( 'Choose only ONE BGC model - PISCES or MY_TRC' ) + IF( .NOT. ln_pisces .AND. .NOT. ln_my_trc ) jp_bgc = 0 + ll_cfc = ln_cfc11 .OR. ln_cfc12 .OR. ln_sf6 + ! + jptra = 0 + jp_pisces = 0 ; jp_pcs0 = 0 ; jp_pcs1 = 0 + jp_my_trc = 0 ; jp_myt0 = 0 ; jp_myt1 = 0 + jp_cfc = 0 ; jp_cfc0 = 0 ; jp_cfc1 = 0 + jp_age = 0 ; jp_c14 = 0 + ! + IF( ln_pisces ) THEN + jp_pisces = jp_bgc + jp_pcs0 = 1 + jp_pcs1 = jp_pisces + ENDIF + IF( ln_my_trc ) THEN + jp_my_trc = jp_bgc + jp_myt0 = 1 + jp_myt1 = jp_my_trc + ENDIF + ! + jptra = jp_bgc + ! + IF( ln_age ) THEN + jptra = jptra + 1 + jp_age = jptra + ENDIF + IF( ln_cfc11 ) jp_cfc = jp_cfc + 1 + IF( ln_cfc12 ) jp_cfc = jp_cfc + 1 + IF( ln_sf6 ) jp_cfc = jp_cfc + 1 + IF( ll_cfc ) THEN + jptra = jptra + jp_cfc + jp_cfc0 = jptra - jp_cfc + 1 + jp_cfc1 = jptra + ENDIF + IF( ln_c14 ) THEN + jptra = jptra + 1 + jp_c14 = jptra + ENDIF + ! + IF( jptra == 0 ) CALL ctl_stop( 'All TOP tracers disabled: change namtrc setting or check if key_top is active' ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namtrc' + WRITE(numout,*) ' Total number of passive tracers jptra = ', jptra + WRITE(numout,*) ' Total number of BGC tracers jp_bgc = ', jp_bgc + WRITE(numout,*) ' Simulating PISCES model ln_pisces = ', ln_pisces + WRITE(numout,*) ' Simulating MY_TRC model ln_my_trc = ', ln_my_trc + WRITE(numout,*) ' Simulating water mass age ln_age = ', ln_age + WRITE(numout,*) ' Simulating CFC11 passive tracer ln_cfc11 = ', ln_cfc11 + WRITE(numout,*) ' Simulating CFC12 passive tracer ln_cfc12 = ', ln_cfc12 + WRITE(numout,*) ' Simulating SF6 passive tracer ln_sf6 = ', ln_sf6 + WRITE(numout,*) ' Total number of CFCs tracers jp_cfc = ', jp_cfc + WRITE(numout,*) ' Simulating C14 passive tracer ln_c14 = ', ln_c14 + WRITE(numout,*) ' Read inputs data from file (y/n) ln_trcdta = ', ln_trcdta + WRITE(numout,*) ' Damping of passive tracer (y/n) ln_trcdmp = ', ln_trcdmp + WRITE(numout,*) ' Restoring of tracer on closed seas ln_trcdmp_clo = ', ln_trcdmp_clo + ENDIF + ! + IF( ll_cfc .OR. ln_c14 ) THEN + ! ! Open namelist files + CALL ctl_opn( numtrc_ref, 'namelist_trc_ref' , 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numtrc_cfg, 'namelist_trc_cfg' , 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + IF(lwm) CALL ctl_opn( numonr, 'output.namelist.trc', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + ! + ENDIF + ! + END SUBROUTINE trc_nam_trc + + + SUBROUTINE trc_nam_trd + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_nam_dia *** + !! + !! ** Purpose : read options for the passive tracer diagnostics + !! + !! ** Method : - read passive tracer namelist + !! - read namelist of each defined SMS model + !! ( (PISCES, CFC, MY_TRC ) + !!--------------------------------------------------------------------- +#if defined key_trdmxl_trc || defined key_trdtrc + INTEGER :: ios, ierr ! Local integer + !! + NAMELIST/namtrc_trd/ nn_trd_trc, nn_ctls_trc, rn_ucf_trc, & + & ln_trdmxl_trc_restart, ln_trdmxl_trc_instant, & + & cn_trdrst_trc_in, cn_trdrst_trc_out, ln_trdtrc + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_nam_trd : read the passive tracer diagnostics options' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ALLOCATE( ln_trdtrc(jptra) ) + ! + REWIND( numnat_ref ) ! Namelist namtrc_trd in reference namelist : Passive tracer trends + READ ( numnat_ref, namtrc_trd, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_trd in reference namelist' ) + REWIND( numnat_cfg ) ! Namelist namtrc_trd in configuration namelist : Passive tracer trends + READ ( numnat_cfg, namtrc_trd, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrc_trd in configuration namelist' ) + IF(lwm) WRITE( numont, namtrc_trd ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist : namtrc_trd ' + WRITE(numout,*) ' frequency of trends diagnostics nn_trd_trc = ', nn_trd_trc + WRITE(numout,*) ' control surface type nn_ctls_trc = ', nn_ctls_trc + WRITE(numout,*) ' restart for ML diagnostics ln_trdmxl_trc_restart = ', ln_trdmxl_trc_restart + WRITE(numout,*) ' instantantaneous or mean trends ln_trdmxl_trc_instant = ', ln_trdmxl_trc_instant + WRITE(numout,*) ' unit conversion factor rn_ucf_trc = ', rn_ucf_trc + DO jn = 1, jptra + IF( ln_trdtrc(jn) ) WRITE(numout,*) ' compute ML trends for tracer number :', jn + END DO + ENDIF +#endif + ! + END SUBROUTINE trc_nam_trd + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_nam ! Empty routine + END SUBROUTINE trc_nam + SUBROUTINE trc_nam_run ! Empty routine + END SUBROUTINE trc_nam_run +#endif + + !!====================================================================== +END MODULE trcnam diff --git a/V4.0/nemo_sources/src/TOP/trcrst.F90 b/V4.0/nemo_sources/src/TOP/trcrst.F90 new file mode 100644 index 0000000000000000000000000000000000000000..decc0010d40c3274417395083ca6943d993c5211 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcrst.F90 @@ -0,0 +1,358 @@ +MODULE trcrst + !!====================================================================== + !! *** MODULE trcrst *** + !! TOP : Manage the passive tracer restart + !!====================================================================== + !! History : - ! 1991-03 () original code + !! 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !! - ! 2005-10 (C. Ethe) print control + !! 2.0 ! 2005-10 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! trc_rst : Restart for passive tracer + !! trc_rst_opn : open restart file + !! trc_rst_read : read restart file + !! trc_rst_wri : write restart file + !!---------------------------------------------------------------------- + USE oce_trc + USE trc + USE iom + USE daymod + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_rst_opn ! called by ??? + PUBLIC trc_rst_read ! called by ??? + PUBLIC trc_rst_wri ! called by ??? + PUBLIC trc_rst_cal + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcrst.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_rst_opn( kt ) + !!---------------------------------------------------------------------- + !! *** trc_rst_opn *** + !! + !! ** purpose : output of sea-trc variable in a netcdf file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! number of iteration + ! + CHARACTER(LEN=20) :: clkt ! ocean time-step define as a character + CHARACTER(LEN=50) :: clname ! trc output restart file name + CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file + !!---------------------------------------------------------------------- + ! + IF( l_offline ) THEN + IF( kt == nittrc000 ) THEN + lrst_trc = .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. MOD( kt - 1, nn_stock ) == 0 ) THEN + ! we use kt - 1 and not kt - nittrc000 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 + ELSE + IF( kt == nittrc000 ) lrst_trc = .FALSE. + ENDIF + + 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 tracer restart file one tracer time step before writing the data (-> at nitrst - 2*nn_dttrc + 1) + ! except if we write tracer restart files every tracer time step or if a tracer restart file was writen at nitend - 2*nn_dttrc + 1 + IF( kt == nitrst - 2*nn_dttrc .OR. nn_stock == nn_dttrc .OR. ( kt == nitend - nn_dttrc .AND. .NOT. lrst_trc ) ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough) + IF( nitrst > 1.0e9 ) THEN ; WRITE(clkt,* ) nitrst + ELSE ; WRITE(clkt,'(i8.8)') nitrst + ENDIF + ! create the file + IF(lwp) WRITE(numout,*) + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trcrst_out) + clpath = TRIM(cn_trcrst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) WRITE(numout,*) & + ' open trc restart.output NetCDF file: ',TRIM(clpath)//clname + CALL iom_open( TRIM(clpath)//TRIM(clname), numrtw, ldwrt = .TRUE. ) + lrst_trc = .TRUE. + ENDIF + ! + END SUBROUTINE trc_rst_opn + + SUBROUTINE trc_rst_read + !!---------------------------------------------------------------------- + !! *** trc_rst_opn *** + !! + !! ** purpose : read passive tracer fields in restart files + !!---------------------------------------------------------------------- + INTEGER :: jn + + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_rst_read : read data in the TOP restart file' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + ! READ prognostic variables and computes diagnostic variable + DO jn = 1, jptra + CALL iom_get( numrtr, jpdom_autoglo, 'TRN'//ctrcnm(jn), trn(:,:,:,jn) ) + END DO + + DO jn = 1, jptra + CALL iom_get( numrtr, jpdom_autoglo, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) ) + END DO + ! + CALL iom_delay_rst( 'READ', 'TOP', numrtr ) ! read only TOP delayed global communication variables + + END SUBROUTINE trc_rst_read + + SUBROUTINE trc_rst_wri( kt ) + !!---------------------------------------------------------------------- + !! *** trc_rst_wri *** + !! + !! ** purpose : write passive tracer fields in restart files + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: jn + !!---------------------------------------------------------------------- + ! + CALL iom_rstput( kt, nitrst, numrtw, 'rdttrc1', rdttrc ) ! passive tracer time step + ! prognostic variables + ! -------------------- + DO jn = 1, jptra + CALL iom_rstput( kt, nitrst, numrtw, 'TRN'//ctrcnm(jn), trn(:,:,:,jn) ) + END DO + + DO jn = 1, jptra + CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) ) + END DO + ! + CALL iom_delay_rst( 'WRITE', 'TOP', numrtw ) ! save only TOP delayed global communication variables + + IF( kt == nitrst ) THEN + CALL trc_rst_stat ! statistics + CALL iom_close( numrtw ) ! close the restart file (only at last time step) +#if ! defined key_trdmxl_trc + lrst_trc = .FALSE. +#endif + IF( l_offline .AND. ln_rst_list ) THEN + nrst_lst = nrst_lst + 1 + nitrst = nn_stocklist( nrst_lst ) + ENDIF + ENDIF + ! + END SUBROUTINE trc_rst_wri + + + SUBROUTINE trc_rst_cal( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_rst_cal *** + !! + !! ** 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, + !! nn_rsttr = 0 no control on the date (nittrc000 is arbitrary). + !! nn_rsttr = 1 we verify that nittrc000 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 (nittrc000-1)*rdt. + !! This is valid is the time step has remained constant. + !! + !! nn_rsttr = 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 + ! + LOGICAL :: llok + REAL(wp) :: zrdttrc1, zkt, zndastp, zdayfrac, ksecs, ktime + INTEGER :: ihour, iminute + + ! Time domain : restart + ! --------------------- + + IF( TRIM(cdrw) == 'READ' ) THEN + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_rst_cal : read the TOP restart file for calendar' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + IF( ln_rsttr ) THEN + CALL iom_open( TRIM(cn_trcrst_indir)//'/'//cn_trcrst_in, numrtr ) + CALL iom_get ( numrtr, 'kt', zkt ) ! last time-step of previous run + + IF(lwp) THEN + WRITE(numout,*) ' *** Info read in restart : ' + WRITE(numout,*) ' previous time-step : ', NINT( zkt ) + WRITE(numout,*) ' *** restart option' + SELECT CASE ( nn_rsttr ) + CASE ( 0 ) ; WRITE(numout,*) ' nn_rsttr = 0 : no control of nittrc000' + CASE ( 1 ) ; WRITE(numout,*) ' nn_rsttr = 1 : no control the date at nittrc000 (use ndate0 read in the namelist)' + CASE ( 2 ) ; WRITE(numout,*) ' nn_rsttr = 2 : calendar parameters read in restart' + END SELECT + WRITE(numout,*) + ENDIF + ! Control of date + IF( nittrc000 - NINT( zkt ) /= nn_dttrc .AND. nn_rsttr /= 0 ) & + & CALL ctl_stop( ' ===>>>> : problem with nittrc000 for the restart', & + & ' verify the restart file or rerun with nn_rsttr = 0 (namelist)' ) + ENDIF + ! + IF( l_offline ) THEN + ! ! set the date in offline mode + IF( ln_rsttr .AND. nn_rsttr == 2 ) THEN + CALL iom_get( numrtr, 'ndastp', zndastp ) + ndastp = NINT( zndastp ) + CALL iom_get( numrtr, 'adatrj', adatrj ) + CALL iom_get( numrtr, 'ntime' , ktime ) + 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 - 1 ! 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 + 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 + ! + IF( ln_rsttr ) THEN ; neuler = 1 + ELSE ; neuler = 0 + ENDIF + ! + CALL day_init ! compute calendar + ! + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN + ! + IF( kt == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_wri : write the TOP restart file (NetCDF) at it= ', kt, ' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + CALL iom_rstput( kt, nitrst, numrtw, 'kt' , REAL( kt , wp) ) ! time-step + CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) ) ! date + CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj ) ! number of elapsed days since + ! ! the begining of the run [s] + CALL iom_rstput( kt, nitrst, numrtw, 'ntime' , REAL( nn_time0, wp)) ! time + ENDIF + + END SUBROUTINE trc_rst_cal + + + SUBROUTINE trc_rst_stat + !!---------------------------------------------------------------------- + !! *** trc_rst_stat *** + !! + !! ** purpose : Compute tracers statistics + !!---------------------------------------------------------------------- + INTEGER :: jk, jn + REAL(wp) :: ztraf, zmin, zmax, zmean, zdrift + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol + !!---------------------------------------------------------------------- + + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ----TRACER STAT---- ' + WRITE(numout,*) + ENDIF + ! + DO jk = 1, jpk + zvol(:,:,jk) = e1e2t(:,:) * e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + ! + DO jn = 1, jptra + ztraf = glob_sum( 'trcrst', trn(:,:,:,jn) * zvol(:,:,:) ) + zmin = MINVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) + zmax = MAXVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) + IF( lk_mpp ) THEN + CALL mpp_min( 'trcrst', zmin ) ! min over the global domain + CALL mpp_max( 'trcrst', zmax ) ! max over the global domain + END IF + zmean = ztraf / areatot + zdrift = ( ( ztraf - trai(jn) ) / ( trai(jn) + 1.e-12 ) ) * 100._wp + IF(lwp) WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), zmean, zmin, zmax, zdrift + END DO + IF(lwp) WRITE(numout,*) +9000 FORMAT(' tracer nb :',i2,' name :',a10,' mean :',e18.10,' min :',e18.10, & + & ' max :',e18.10,' drift :',e18.10, ' %') + ! + END SUBROUTINE trc_rst_stat + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_rst_read ! Empty routines + END SUBROUTINE trc_rst_read + SUBROUTINE trc_rst_wri( kt ) + INTEGER, INTENT ( in ) :: kt + WRITE(*,*) 'trc_rst_wri: You should not have seen this print! error?', kt + END SUBROUTINE trc_rst_wri +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcrst.F90 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcrst diff --git a/V4.0/nemo_sources/src/TOP/trcsms.F90 b/V4.0/nemo_sources/src/TOP/trcsms.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c2be3225772d6c63f2fc0cb451879d74752bce7d --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcsms.F90 @@ -0,0 +1,79 @@ +MODULE trcsms + !!====================================================================== + !! *** MODULE trcsms *** + !! TOP : Time loop of passive tracers sms + !!====================================================================== + !! History : 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90 + !! 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_sms : Time loop of passive tracers sms + !!---------------------------------------------------------------------- + USE oce_trc ! + USE trc ! + USE trcsms_pisces ! PISCES biogeo-model + USE trcsms_cfc ! CFC 11 &/or 12 + USE trcsms_c14 ! C14 + USE trcsms_age ! AGE + USE trcsms_my_trc ! MY_TRC tracers + USE prtctl_trc ! Print control for debbuging + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_sms ! called in trcstp.F90 + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsms.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sms( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_sms *** + !! + !! ** Purpose : Managment of the time loop of passive tracers sms + !! + !! ** Method : - call the main routine of of each defined tracer model + !! ------------------------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + CHARACTER (len=25) :: charout + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sms') + ! + IF( ln_pisces ) CALL trc_sms_pisces ( kt ) ! main program of PISCES + IF( ll_cfc ) CALL trc_sms_cfc ( kt ) ! surface fluxes of CFC + IF( ln_c14 ) CALL trc_sms_c14 ( kt ) ! surface fluxes of C14 + IF( ln_age ) CALL trc_sms_age ( kt ) ! Age tracer + IF( ln_my_trc ) CALL trc_sms_my_trc ( kt ) ! MY_TRC tracers + + IF(ln_ctl) THEN ! print mean trends (used for debugging) + WRITE(charout, FMT="('sms ')") + CALL prt_ctl_trc_info( charout ) + CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_sms') + ! + END SUBROUTINE trc_sms + +#else + !!====================================================================== + !! Dummy module : No passive tracer + !!====================================================================== +CONTAINS + SUBROUTINE trc_sms( kt ) ! Empty routine + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'trc_sms: You should not have seen this print! error?', kt + END SUBROUTINE trc_sms +#endif + + !!====================================================================== +END MODULE trcsms diff --git a/V4.0/nemo_sources/src/TOP/trcstp.F90 b/V4.0/nemo_sources/src/TOP/trcstp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d136755643af9ec1d06629ea7a309d9822ef37e7 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcstp.F90 @@ -0,0 +1,271 @@ +MODULE trcstp + !!====================================================================== + !! *** MODULE trcstp *** + !! Time-stepping : time loop of opa for passive tracer + !!====================================================================== + !! History : 1.0 ! 2004-03 (C. Ethe) Original + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! trc_stp : passive tracer system time-stepping + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers variables + USE sbc_oce + USE trc + USE trctrp ! passive tracers transport + USE trcsms ! passive tracers sources and sinks + USE trcwri + USE trcrst + USE trcsub ! + USE trdtrc_oce + USE trdmxl_trc + USE sms_pisces, ONLY : ln_check_mass + ! + USE prtctl_trc ! Print control for debbuging + USE iom ! + USE in_out_manager ! + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_stp ! called by step + + LOGICAL :: llnew ! ??? + REAL(wp) :: rdt_sampl ! ??? + INTEGER :: nb_rec_per_day, ktdcy ! ??? + REAL(wp) :: rsecfst, rseclast ! ??? + REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcstp.F90 13323 2020-07-17 17:08:12Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_stp( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE trc_stp *** + !! + !! ** Purpose : Time loop of opa for passive tracer + !! + !! ** Method : Compute the passive tracers trends + !! Update the passive tracers + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: jk, jn ! dummy loop indices + REAL(wp):: ztrai ! local scalar + LOGICAL :: ll_trcstat ! local logical + CHARACTER (len=25) :: charout ! + !!------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_stp') + ! + IF( ( neuler == 0 .AND. kt == nittrc000 ) .OR. ln_top_euler ) THEN ! at nittrc000 + r2dttrc = rdttrc ! = rdttrc (use or restarting with Euler time stepping) + ELSEIF( kt <= nittrc000 + nn_dttrc ) THEN ! at nittrc000 or nittrc000+1 + r2dttrc = 2. * rdttrc ! = 2 rdttrc (leapfrog) + ENDIF + ! + ll_trcstat = ( ln_ctl .OR. sn_cfctl%l_trcstat ) .AND. & + & ( ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) ) + + IF( kt == nittrc000 ) CALL trc_stp_ctl ! control + IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer + ! + IF( .NOT.ln_linssh ) THEN ! update ocean volume due to ssh temporal evolution + DO jk = 1, jpk + cvol(:,:,jk) = e1e2t(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + IF ( ll_trcstat .OR. kt == nitrst .OR. ( ln_check_mass .AND. kt == nitend ) & + & .OR. iom_use( "pno3tot" ) .OR. iom_use( "ppo4tot" ) .OR. iom_use( "psiltot" ) & + & .OR. iom_use( "palktot" ) .OR. iom_use( "pfertot" ) ) & + & areatot = glob_sum( 'trcstp', cvol(:,:,:) ) + ENDIF + ! + IF( l_trcdm2dc ) CALL trc_mean_qsr( kt ) + ! + IF( nn_dttrc /= 1 ) CALL trc_sub_stp( kt ) ! averaging physical variables for sub-stepping + ! + IF( MOD( kt , nn_dttrc ) == 0 ) THEN ! only every nn_dttrc time step + ! + IF(ln_ctl) THEN + WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear + CALL prt_ctl_trc_info(charout) + ENDIF + ! + tra(:,:,:,:) = 0.e0 + ! + CALL trc_rst_opn ( kt ) ! Open tracer restart file + IF( lrst_trc ) CALL trc_rst_cal ( kt, 'WRITE' ) ! calendar + CALL trc_wri ( kt ) ! output of passive tracers with iom I/O manager + CALL trc_sms ( kt ) ! tracers: sinks and sources + CALL trc_trp ( kt ) ! transport of passive tracers + IF( kt == nittrc000 ) THEN + CALL iom_close( numrtr ) ! close input tracer restart file + IF(lwm) CALL FLUSH( numont ) ! flush namelist output + ENDIF + IF( lrst_trc ) CALL trc_rst_wri ( kt ) ! write tracer restart file + IF( lk_trdmxl_trc ) CALL trd_mxl_trc ( kt ) ! trends: Mixed-layer + ! + IF( nn_dttrc /= 1 ) CALL trc_sub_reset( kt ) ! resetting physical variables when sub-stepping + ! + ENDIF + ! + IF (ll_trcstat) THEN + ztrai = 0._wp ! content of all tracers + DO jn = 1, jptra + ztrai = ztrai + glob_sum( 'trcstp', trn(:,:,:,jn) * cvol(:,:,:) ) + END DO + IF( lwm ) WRITE(numstr,9300) kt, ztrai / areatot + ENDIF +9300 FORMAT(i10,D23.16) + ! + IF( ln_timing ) CALL timing_stop('trc_stp') + ! + END SUBROUTINE trc_stp + + SUBROUTINE trc_stp_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_stp_ctl *** + !! ** Purpose : Control + ocean volume + !!---------------------------------------------------------------------- + ! + ! Define logical parameter ton control dirunal cycle in TOP + l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 ) + l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline + IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', & + & 'Computation of a daily mean shortwave for some biogeochemical models ' ) + ! + END SUBROUTINE trc_stp_ctl + + + SUBROUTINE trc_mean_qsr( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_mean_qsr *** + !! + !! ** Purpose : Compute daily mean qsr for biogeochemical model in case + !! of diurnal cycle + !! + !! ** Method : store in TOP the qsr every hour ( or every time-step if the latter + !! is greater than 1 hour ) and then, compute the mean with + !! a moving average over 24 hours. + !! In coupled mode, the sampling is done at every coupling frequency + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: jn ! dummy loop indices + REAL(wp) :: zkt, zrec ! local scalars + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=2) :: cl2 ! 2 characters + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_mean_qsr') + ! + IF( kt == nittrc000 ) THEN + IF( ln_cpl ) THEN + rdt_sampl = rday / ncpl_qsr_freq + nb_rec_per_day = ncpl_qsr_freq + ELSE + rdt_sampl = MAX( 3600., rdttrc ) + nb_rec_per_day = INT( rday / rdt_sampl ) + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's',' Number of sampling per day nrec = ', nb_rec_per_day + WRITE(numout,*) + ENDIF + ! + ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) + ! + ! !* Restart: read in restart file + IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 & + & .AND. iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 & + & .AND. iom_varid( numrtr, 'ktdcy' , ldstop = .FALSE. ) > 0 & + & .AND. iom_varid( numrtr, 'nrdcy' , ldstop = .FALSE. ) > 0 ) THEN + + CALL iom_get( numrtr, 'ktdcy', zkt ) + rsecfst = INT( zkt ) * rdttrc + IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' + CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean ) ! A mean of qsr + CALL iom_get( numrtr, 'nrdcy', zrec ) ! Number of record per days + IF( INT( zrec ) == nb_rec_per_day ) THEN + DO jn = 1, nb_rec_per_day + IF( jn <= 9 ) THEN + WRITE(cl1,'(i1)') jn + CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr + ELSE + WRITE(cl2,'(i2.2)') jn + CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr + ENDIF + END DO + ELSE + DO jn = 1, nb_rec_per_day + qsr_arr(:,:,jn) = qsr_mean(:,:) + ENDDO + ENDIF + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values' + rsecfst = kt * rdttrc + ! + qsr_mean(:,:) = qsr(:,:) + DO jn = 1, nb_rec_per_day + qsr_arr(:,:,jn) = qsr_mean(:,:) + END DO + ENDIF + ! + ENDIF + ! + rseclast = kt * rdttrc + ! + llnew = ( rseclast - rsecfst ) .ge. rdt_sampl ! new shortwave to store + IF( llnew ) THEN + ktdcy = kt + IF( lwp .AND. kt < nittrc000 + 100 ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', ktdcy, & + & ' time = ', rseclast/3600.,'hours ' + rsecfst = rseclast + DO jn = 1, nb_rec_per_day - 1 + qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) + ENDDO + qsr_arr (:,:,nb_rec_per_day) = qsr(:,:) + qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day + ENDIF + ! + IF( lrst_trc ) THEN !* Write the mean of qsr in restart file + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file kt =', kt + IF(lwp) WRITE(numout,*) '~~~~~~~' + zkt = REAL( ktdcy, wp ) + zrec = REAL( nb_rec_per_day, wp ) + CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) + CALL iom_rstput( kt, nitrst, numrtw, 'nrdcy', zrec ) + DO jn = 1, nb_rec_per_day + IF( jn <= 9 ) THEN + WRITE(cl1,'(i1)') jn + CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) + ELSE + WRITE(cl2,'(i2.2)') jn + CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) + ENDIF + END DO + CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_mean_qsr') + ! + END SUBROUTINE trc_mean_qsr + +#else + !!---------------------------------------------------------------------- + !! Default key NO passive tracers + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_stp( kt ) ! Empty routine + WRITE(*,*) 'trc_stp: You should not have seen this print! error?', kt + END SUBROUTINE trc_stp +#endif + + !!====================================================================== +END MODULE trcstp diff --git a/V4.0/nemo_sources/src/TOP/trcsub.F90 b/V4.0/nemo_sources/src/TOP/trcsub.F90 new file mode 100644 index 0000000000000000000000000000000000000000..59179c4080a518526e4ec9326465f6be6ba982b3 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcsub.F90 @@ -0,0 +1,597 @@ +MODULE trcsub + !!====================================================================== + !! *** MODULE trcsubstp *** + !! TOP : Averages physics variables for TOP substepping. + !!====================================================================== + !! History : 1.0 ! 2011-10 (K. Edwards) Original + !!---------------------------------------------------------------------- +#if defined key_top + !!---------------------------------------------------------------------- + !! trc_sub : passive tracer system sub-stepping + !!---------------------------------------------------------------------- + USE oce_trc ! ocean dynamics and active tracers variables + USE trc + USE trabbl ! bottom boundary layer + USE zdf_oce + USE domvvl + USE divhor ! horizontal divergence + USE sbcrnf , ONLY: h_rnf, nk_rnf ! River runoff + USE bdy_oce , ONLY: ln_bdy, bdytmask ! BDY + ! + USE prtctl_trc ! Print control for debbuging + USE in_out_manager ! + USE iom + USE lbclnk +#if defined key_agrif + USE agrif_oce_update + USE agrif_oce_interp +#endif + + IMPLICIT NONE + + PUBLIC trc_sub_stp ! called by trc_stp + PUBLIC trc_sub_ini ! called by trc_ini to initialize substepping arrays. + PUBLIC trc_sub_reset ! called by trc_stp to reset physics variables + PUBLIC trc_sub_ssh ! called by trc_stp to reset physics variables + + REAL(wp) :: r1_ndttrc ! = 1 / nn_dttrc + REAL(wp) :: r1_ndttrcp1 ! = 1 / (nn_dttrc+1) + + + !! averaged and temporary saved variables (needed when a larger passive tracer time-step is used) + !! ---------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_tm , un_temp !: i-horizontal velocity average [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vn_tm , vn_temp !: j-horizontal velocity average [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn_temp !: hold current values of avt, un, vn, wn + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsn_tm , tsn_temp !: t/s average [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avs_tm , avs_temp !: vertical diffusivity coeff. at w-point [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhop_tm , rhop_temp !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_tm , sshn_temp !: average ssh for the now step [m] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf_tm , rnf_temp !: river runoff + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf_tm , h_rnf_temp !: depth in metres to the bottom of the relevant grid box + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld_tm , hmld_temp !: mixed layer depth average [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i_tm , fr_i_temp !: average ice fraction [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tm , emp_temp !: freshwater budget: volume flux [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx_tm , fmmflx_temp !: freshwater budget: freezing/melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_b_hold, emp_b_temp !: hold emp from the beginning of each sub-stepping[m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tm , qsr_temp !: solar radiation average [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_tm , wndm_temp !: 10m wind average [m] + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshb_hold !:hold sshb from the beginning of each sub-stepping[m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshb_temp, ssha_temp + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivn_temp, rotn_temp + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivb_temp, rotb_temp + ! + ! !!- bottom boundary layer param (ln_trabbl=T) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_tm, ahu_bbl_temp ! BBL diffusive i-coef. + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahv_bbl_tm, ahv_bbl_temp ! BBL diffusive j-coef. + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: utr_bbl_tm, utr_bbl_temp ! BBL u-advection + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtr_bbl_tm, vtr_bbl_temp ! BBL v-advection + + ! !!- iso-neutral slopes (if l_ldfslp=T) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp_temp, vslp_temp, wslpi_temp, wslpj_temp !: hold current values + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp_tm , vslp_tm , wslpi_tm , wslpj_tm !: time mean + + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcsub.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trc_sub_stp( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE trc_stp *** + !! + !! ** Purpose : Average variables needed for sub-stepping passive tracers + !! + !! ** Method : Called every timestep to increment _tm (time mean) variables + !! on TOP steps, calculate averages. + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp):: z1_ne3t, z1_ne3u, z1_ne3v, z1_ne3w ! local scalars + !!------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sub_stp') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_sub_stp : substepping of the passive tracers' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + sshb_hold (:,:) = sshn (:,:) + emp_b_hold (:,:) = emp_b (:,:) + ! + r1_ndttrc = 1._wp / REAL( nn_dttrc , wp ) + r1_ndttrcp1 = 1._wp / REAL( nn_dttrc + 1, wp ) + ENDIF + + IF( MOD( kt , nn_dttrc ) /= 0 ) THEN + ! + un_tm (:,:,:) = un_tm (:,:,:) + un (:,:,:) * e3u_n(:,:,:) + vn_tm (:,:,:) = vn_tm (:,:,:) + vn (:,:,:) * e3v_n(:,:,:) + tsn_tm (:,:,:,jp_tem) = tsn_tm (:,:,:,jp_tem) + tsn (:,:,:,jp_tem) * e3t_n(:,:,:) + tsn_tm (:,:,:,jp_sal) = tsn_tm (:,:,:,jp_sal) + tsn (:,:,:,jp_sal) * e3t_n(:,:,:) + rhop_tm (:,:,:) = rhop_tm (:,:,:) + rhop (:,:,:) * e3t_n(:,:,:) + avs_tm (:,:,:) = avs_tm (:,:,:) + avs (:,:,:) * e3w_n(:,:,:) + IF( l_ldfslp ) THEN + uslp_tm (:,:,:) = uslp_tm (:,:,:) + uslp (:,:,:) + vslp_tm (:,:,:) = vslp_tm (:,:,:) + vslp (:,:,:) + wslpi_tm(:,:,:) = wslpi_tm(:,:,:) + wslpi(:,:,:) + wslpj_tm(:,:,:) = wslpj_tm(:,:,:) + wslpj(:,:,:) + ENDIF + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl_tm(:,:) = ahu_bbl_tm(:,:) + ahu_bbl(:,:) + ahv_bbl_tm(:,:) = ahv_bbl_tm(:,:) + ahv_bbl(:,:) + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl_tm(:,:) = utr_bbl_tm(:,:) + utr_bbl(:,:) + vtr_bbl_tm(:,:) = vtr_bbl_tm(:,:) + vtr_bbl(:,:) + ENDIF + ENDIF + ! + sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) + rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) + h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) + hmld_tm (:,:) = hmld_tm (:,:) + hmld (:,:) + fr_i_tm (:,:) = fr_i_tm (:,:) + fr_i (:,:) + emp_tm (:,:) = emp_tm (:,:) + emp (:,:) + fmmflx_tm(:,:) = fmmflx_tm(:,:) + fmmflx(:,:) + qsr_tm (:,:) = qsr_tm (:,:) + qsr (:,:) + wndm_tm (:,:) = wndm_tm (:,:) + wndm (:,:) + ! + ELSE ! It is time to substep + ! 1. set temporary arrays to hold physics/dynamical variables + un_temp (:,:,:) = un (:,:,:) + vn_temp (:,:,:) = vn (:,:,:) + wn_temp (:,:,:) = wn (:,:,:) + tsn_temp (:,:,:,:) = tsn (:,:,:,:) + rhop_temp (:,:,:) = rhop (:,:,:) + avs_temp (:,:,:) = avs (:,:,:) + IF( l_ldfslp ) THEN + uslp_temp (:,:,:) = uslp (:,:,:) ; wslpi_temp (:,:,:) = wslpi (:,:,:) + vslp_temp (:,:,:) = vslp (:,:,:) ; wslpj_temp (:,:,:) = wslpj (:,:,:) + ENDIF + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl_temp(:,:) = ahu_bbl(:,:) + ahv_bbl_temp(:,:) = ahv_bbl(:,:) + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl_temp(:,:) = utr_bbl(:,:) + vtr_bbl_temp(:,:) = vtr_bbl(:,:) + ENDIF + ENDIF + sshn_temp (:,:) = sshn (:,:) + sshb_temp (:,:) = sshb (:,:) + ssha_temp (:,:) = ssha (:,:) + rnf_temp (:,:) = rnf (:,:) + h_rnf_temp (:,:) = h_rnf (:,:) + hmld_temp (:,:) = hmld (:,:) + fr_i_temp (:,:) = fr_i (:,:) + emp_temp (:,:) = emp (:,:) + emp_b_temp (:,:) = emp_b (:,:) + fmmflx_temp(:,:) = fmmflx(:,:) + qsr_temp (:,:) = qsr (:,:) + wndm_temp (:,:) = wndm (:,:) + ! ! Variables reset in trc_sub_ssh + hdivn_temp (:,:,:) = hdivn (:,:,:) + ! + ! 2. Create averages and reassign variables + un_tm (:,:,:) = un_tm (:,:,:) + un (:,:,:) * e3u_n(:,:,:) + vn_tm (:,:,:) = vn_tm (:,:,:) + vn (:,:,:) * e3v_n(:,:,:) + tsn_tm (:,:,:,jp_tem) = tsn_tm (:,:,:,jp_tem) + tsn (:,:,:,jp_tem) * e3t_n(:,:,:) + tsn_tm (:,:,:,jp_sal) = tsn_tm (:,:,:,jp_sal) + tsn (:,:,:,jp_sal) * e3t_n(:,:,:) + rhop_tm (:,:,:) = rhop_tm (:,:,:) + rhop (:,:,:) * e3t_n(:,:,:) + avs_tm (:,:,:) = avs_tm (:,:,:) + avs (:,:,:) * e3w_n(:,:,:) + IF( l_ldfslp ) THEN + uslp_tm (:,:,:) = uslp_tm (:,:,:) + uslp (:,:,:) + vslp_tm (:,:,:) = vslp_tm (:,:,:) + vslp (:,:,:) + wslpi_tm (:,:,:) = wslpi_tm(:,:,:) + wslpi(:,:,:) + wslpj_tm (:,:,:) = wslpj_tm(:,:,:) + wslpj(:,:,:) + ENDIF + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl_tm(:,:) = ahu_bbl_tm(:,:) + ahu_bbl(:,:) + ahv_bbl_tm(:,:) = ahv_bbl_tm(:,:) + ahv_bbl(:,:) + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl_tm(:,:) = utr_bbl_tm(:,:) + utr_bbl(:,:) + vtr_bbl_tm(:,:) = vtr_bbl_tm(:,:) + vtr_bbl(:,:) + ENDIF + ENDIF + sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) + rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) + h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) + hmld_tm (:,:) = hmld_tm (:,:) + hmld (:,:) + fr_i_tm (:,:) = fr_i_tm (:,:) + fr_i (:,:) + emp_tm (:,:) = emp_tm (:,:) + emp (:,:) + fmmflx_tm(:,:) = fmmflx_tm (:,:) + fmmflx(:,:) + qsr_tm (:,:) = qsr_tm (:,:) + qsr (:,:) + wndm_tm (:,:) = wndm_tm (:,:) + wndm (:,:) + ! + sshn (:,:) = sshn_tm (:,:) * r1_ndttrcp1 + sshb (:,:) = sshb_hold (:,:) + rnf (:,:) = rnf_tm (:,:) * r1_ndttrcp1 + h_rnf (:,:) = h_rnf_tm (:,:) * r1_ndttrcp1 + hmld (:,:) = hmld_tm (:,:) * r1_ndttrcp1 + ! variables that are initialized after averages + emp_b (:,:) = emp_b_hold (:,:) + IF( kt == nittrc000 ) THEN + wndm (:,:) = wndm_tm (:,:) * r1_ndttrc + qsr (:,:) = qsr_tm (:,:) * r1_ndttrc + emp (:,:) = emp_tm (:,:) * r1_ndttrc + fmmflx(:,:) = fmmflx_tm (:,:) * r1_ndttrc + fr_i (:,:) = fr_i_tm (:,:) * r1_ndttrc + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl(:,:) = ahu_bbl_tm (:,:) * r1_ndttrc + ahv_bbl(:,:) = ahv_bbl_tm (:,:) * r1_ndttrc + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl(:,:) = utr_bbl_tm (:,:) * r1_ndttrc + vtr_bbl(:,:) = vtr_bbl_tm (:,:) * r1_ndttrc + ENDIF + ENDIF + ELSE + wndm (:,:) = wndm_tm (:,:) * r1_ndttrcp1 + qsr (:,:) = qsr_tm (:,:) * r1_ndttrcp1 + emp (:,:) = emp_tm (:,:) * r1_ndttrcp1 + fmmflx(:,:) = fmmflx_tm (:,:) * r1_ndttrcp1 + fr_i (:,:) = fr_i_tm (:,:) * r1_ndttrcp1 + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl(:,:) = ahu_bbl_tm (:,:) * r1_ndttrcp1 + ahv_bbl(:,:) = ahv_bbl_tm (:,:) * r1_ndttrcp1 + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl(:,:) = utr_bbl_tm (:,:) * r1_ndttrcp1 + vtr_bbl(:,:) = vtr_bbl_tm (:,:) * r1_ndttrcp1 + ENDIF + ENDIF + ENDIF + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + z1_ne3t = r1_ndttrcp1 / e3t_n(ji,jj,jk) + z1_ne3u = r1_ndttrcp1 / e3u_n(ji,jj,jk) + z1_ne3v = r1_ndttrcp1 / e3v_n(ji,jj,jk) + z1_ne3w = r1_ndttrcp1 / e3w_n(ji,jj,jk) + ! + un (ji,jj,jk) = un_tm (ji,jj,jk) * z1_ne3u + vn (ji,jj,jk) = vn_tm (ji,jj,jk) * z1_ne3v + tsn (ji,jj,jk,jp_tem) = tsn_tm (ji,jj,jk,jp_tem) * z1_ne3t + tsn (ji,jj,jk,jp_sal) = tsn_tm (ji,jj,jk,jp_sal) * z1_ne3t + rhop (ji,jj,jk) = rhop_tm (ji,jj,jk) * z1_ne3t +!!gm : BUG ==>> for avs I don't understand the division by e3w + avs (ji,jj,jk) = avs_tm (ji,jj,jk) * z1_ne3w + END DO + END DO + END DO + IF( l_ldfslp ) THEN + wslpi(:,:,:) = wslpi_tm(:,:,:) + wslpj(:,:,:) = wslpj_tm(:,:,:) + uslp (:,:,:) = uslp_tm (:,:,:) + vslp (:,:,:) = vslp_tm (:,:,:) + ENDIF + ! + CALL trc_sub_ssh( kt ) ! after ssh & vertical velocity + ! + ENDIF + ! + IF( ln_timing ) CALL timing_stop('trc_sub_stp') + ! + END SUBROUTINE trc_sub_stp + + + SUBROUTINE trc_sub_ini + !!------------------------------------------------------------------- + !! *** ROUTINE trc_sub_ini *** + !! + !! ** Purpose : Initialize variables needed for sub-stepping passive tracers + !! + !! ** Method : + !! Compute the averages for sub-stepping + !!------------------------------------------------------------------- + INTEGER :: ierr + !!------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_sub_ini : initial set up of the passive tracers substepping' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + ierr = trc_sub_alloc () + CALL mpp_sum( 'trcsub', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'top_sub_alloc : unable to allocate standard ocean arrays' ) + + un_tm (:,:,:) = un (:,:,:) * e3u_n(:,:,:) + vn_tm (:,:,:) = vn (:,:,:) * e3v_n(:,:,:) + tsn_tm (:,:,:,jp_tem) = tsn (:,:,:,jp_tem) * e3t_n(:,:,:) + tsn_tm (:,:,:,jp_sal) = tsn (:,:,:,jp_sal) * e3t_n(:,:,:) + rhop_tm (:,:,:) = rhop (:,:,:) * e3t_n(:,:,:) +!!gm : BUG? ==>> for avt & avs I don't understand the division by e3w + avs_tm (:,:,:) = avs (:,:,:) * e3w_n(:,:,:) + IF( l_ldfslp ) THEN + wslpi_tm(:,:,:) = wslpi(:,:,:) + wslpj_tm(:,:,:) = wslpj(:,:,:) + uslp_tm (:,:,:) = uslp (:,:,:) + vslp_tm (:,:,:) = vslp (:,:,:) + ENDIF + sshn_tm (:,:) = sshn (:,:) + rnf_tm (:,:) = rnf (:,:) + h_rnf_tm (:,:) = h_rnf (:,:) + hmld_tm (:,:) = hmld (:,:) + + ! Physics variables that are set after initialization: + fr_i_tm (:,:) = 0._wp + emp_tm (:,:) = 0._wp + fmmflx_tm(:,:) = 0._wp + qsr_tm (:,:) = 0._wp + wndm_tm (:,:) = 0._wp + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl_tm(:,:) = 0._wp + ahv_bbl_tm(:,:) = 0._wp + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl_tm(:,:) = 0._wp + vtr_bbl_tm(:,:) = 0._wp + ENDIF + ENDIF + ! + END SUBROUTINE trc_sub_ini + + + SUBROUTINE trc_sub_reset( kt ) + !!------------------------------------------------------------------- + !! *** ROUTINE trc_sub_reset *** + !! + !! ** Purpose : Reset physics variables averaged for substepping + !! + !! ** Method : + !! Compute the averages for sub-stepping + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER :: jk ! dummy loop indices + !!------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sub_reset') + ! + ! restore physics variables + un (:,:,:) = un_temp (:,:,:) + vn (:,:,:) = vn_temp (:,:,:) + wn (:,:,:) = wn_temp (:,:,:) + tsn (:,:,:,:) = tsn_temp (:,:,:,:) + rhop (:,:,:) = rhop_temp (:,:,:) + avs (:,:,:) = avs_temp (:,:,:) + IF( l_ldfslp ) THEN + wslpi (:,:,:)= wslpi_temp (:,:,:) + wslpj (:,:,:)= wslpj_temp (:,:,:) + uslp (:,:,:)= uslp_temp (:,:,:) + vslp (:,:,:)= vslp_temp (:,:,:) + ENDIF + sshn (:,:) = sshn_temp (:,:) + sshb (:,:) = sshb_temp (:,:) + ssha (:,:) = ssha_temp (:,:) + rnf (:,:) = rnf_temp (:,:) + h_rnf (:,:) = h_rnf_temp (:,:) + ! + hmld (:,:) = hmld_temp (:,:) + fr_i (:,:) = fr_i_temp (:,:) + emp (:,:) = emp_temp (:,:) + fmmflx(:,:) = fmmflx_temp(:,:) + emp_b (:,:) = emp_b_temp (:,:) + qsr (:,:) = qsr_temp (:,:) + wndm (:,:) = wndm_temp (:,:) + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl(:,:) = ahu_bbl_temp(:,:) + ahv_bbl(:,:) = ahv_bbl_temp(:,:) + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl(:,:) = utr_bbl_temp(:,:) + vtr_bbl(:,:) = vtr_bbl_temp(:,:) + ENDIF + ENDIF + ! + hdivn (:,:,:) = hdivn_temp (:,:,:) + ! + ! Start new averages + un_tm (:,:,:) = un (:,:,:) * e3u_n(:,:,:) + vn_tm (:,:,:) = vn (:,:,:) * e3v_n(:,:,:) + tsn_tm (:,:,:,jp_tem) = tsn (:,:,:,jp_tem) * e3t_n(:,:,:) + tsn_tm (:,:,:,jp_sal) = tsn (:,:,:,jp_sal) * e3t_n(:,:,:) + rhop_tm (:,:,:) = rhop (:,:,:) * e3t_n(:,:,:) + avs_tm (:,:,:) = avs (:,:,:) * e3w_n(:,:,:) + IF( l_ldfslp ) THEN + uslp_tm (:,:,:) = uslp (:,:,:) + vslp_tm (:,:,:) = vslp (:,:,:) + wslpi_tm(:,:,:) = wslpi(:,:,:) + wslpj_tm(:,:,:) = wslpj(:,:,:) + ENDIF + ! + sshb_hold (:,:) = sshn (:,:) + emp_b_hold (:,:) = emp (:,:) + sshn_tm (:,:) = sshn (:,:) + rnf_tm (:,:) = rnf (:,:) + h_rnf_tm (:,:) = h_rnf (:,:) + hmld_tm (:,:) = hmld (:,:) + fr_i_tm (:,:) = fr_i (:,:) + emp_tm (:,:) = emp (:,:) + fmmflx_tm (:,:) = fmmflx(:,:) + qsr_tm (:,:) = qsr (:,:) + wndm_tm (:,:) = wndm (:,:) + IF( ln_trabbl ) THEN + IF( nn_bbl_ldf == 1 ) THEN + ahu_bbl_tm(:,:) = ahu_bbl(:,:) + ahv_bbl_tm(:,:) = ahv_bbl(:,:) + ENDIF + IF( nn_bbl_adv == 1 ) THEN + utr_bbl_tm(:,:) = utr_bbl(:,:) + vtr_bbl_tm(:,:) = vtr_bbl(:,:) + ENDIF + ENDIF + ! + ! + IF( ln_timing ) CALL timing_stop('trc_sub_reset') + ! + END SUBROUTINE trc_sub_reset + + + SUBROUTINE trc_sub_ssh( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_sub_ssh *** + !! + !! ** Purpose : compute the after ssh (ssha), the now vertical velocity + !! and update the now vertical coordinate (ln_linssh=F). + !! + !! ** 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 : ssha : after sea surface height + !! wn : now vertical velocity + !! sshu_a, sshv_a, sshf_a : after sea surface height (ln_linssh=F) + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoefu, zcoefv, zcoeff, z2dt, z1_2dt, z1_rau0 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zhdiv + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_sub_ssh') + ! + + IF( kt == nittrc000 ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trc_sub_ssh : after sea surface height and now vertical velocity ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' + ! + wn(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) + ! + ENDIF + ! +!!gm BUG here ! hdivn will include the runoff divergence at the wrong timestep !!!! + CALL div_hor( kt ) ! Horizontal divergence & Relative vorticity + ! + z2dt = 2._wp * rdt ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == nittrc000 ) z2dt = rdt + + ! !------------------------------! + ! ! After Sea Surface Height ! + ! !------------------------------! + 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 forward Euler time stepping case, the same formulation as in the leap-frog case can be used + ! because emp_b field is initialized with the vlaues of emp field. Hence, 0.5 * ( emp + emp_b ) = emp + z1_rau0 = 0.5 / rau0 + ssha(:,:) = ( sshb(:,:) - z2dt * ( z1_rau0 * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) ) ) * tmask(:,:,1) + + IF( .NOT.ln_dynspg_ts ) THEN + ! These lines are not necessary with time splitting since + ! boundary condition on sea level is set during ts loop +#if defined key_agrif + CALL agrif_ssh( kt ) +#endif + IF( ln_bdy ) THEN + ssha(:,:) = ssha(:,:) * bdytmask(:,:) + CALL lbc_lnk( 'trcsub', ssha, 'T', 1. ) + ENDIF + ENDIF + ! + ! !------------------------------! + ! ! Now Vertical Velocity ! + ! !------------------------------! + z1_2dt = 1.e0 / z2dt + DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence + ! - ML - need 3 lines here because replacement of e3t by its expression yields too long lines otherwise + wn(:,:,jk) = wn(:,:,jk+1) - e3t_n(:,:,jk) * hdivn(:,:,jk) & + & - ( e3t_a(:,:,jk) - e3t_b(:,:,jk) ) & + & * tmask(:,:,jk) * z1_2dt + IF( ln_bdy ) wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) + END DO + ! + IF( ln_timing ) CALL timing_stop('trc_sub_ssh') + ! + END SUBROUTINE trc_sub_ssh + + + INTEGER FUNCTION trc_sub_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE trc_sub_alloc *** + !!------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop + INTEGER :: ierr(3) + !!------------------------------------------------------------------- + ! + ierr(:) = 0 + ! + ALLOCATE( un_temp(jpi,jpj,jpk) , vn_temp(jpi,jpj,jpk) , & + & wn_temp(jpi,jpj,jpk) , & + & rhop_temp(jpi,jpj,jpk) , rhop_tm(jpi,jpj,jpk) , & + & sshn_temp(jpi,jpj) , sshb_temp(jpi,jpj) , & + & ssha_temp(jpi,jpj) , & + & rnf_temp(jpi,jpj) , h_rnf_temp(jpi,jpj) , & + & tsn_temp(jpi,jpj,jpk,2) , emp_b_temp(jpi,jpj) , & + & emp_temp(jpi,jpj) , fmmflx_temp(jpi,jpj) , & + & hmld_temp(jpi,jpj) , qsr_temp(jpi,jpj) , & + & fr_i_temp(jpi,jpj) , fr_i_tm(jpi,jpj) , & + & wndm_temp(jpi,jpj) , wndm_tm(jpi,jpj) , & + & avs_tm(jpi,jpj,jpk) , avs_temp(jpi,jpj,jpk) , & + & hdivn_temp(jpi,jpj,jpk) , hdivb_temp(jpi,jpj,jpk), & + & un_tm(jpi,jpj,jpk) , vn_tm(jpi,jpj,jpk) , & + & sshn_tm(jpi,jpj) , sshb_hold(jpi,jpj) , & + & tsn_tm(jpi,jpj,jpk,2) , & + & emp_tm(jpi,jpj) , fmmflx_tm(jpi,jpj) , & + & emp_b_hold(jpi,jpj) , & + & hmld_tm(jpi,jpj) , qsr_tm(jpi,jpj) , & + & rnf_tm(jpi,jpj) , h_rnf_tm(jpi,jpj) , STAT=ierr(1) ) + ! + IF( l_ldfslp ) THEN + ALLOCATE( uslp_temp(jpi,jpj,jpk) , wslpi_temp(jpi,jpj,jpk), & + & vslp_temp(jpi,jpj,jpk) , wslpj_temp(jpi,jpj,jpk), & + & uslp_tm (jpi,jpj,jpk) , wslpi_tm (jpi,jpj,jpk), & + & vslp_tm (jpi,jpj,jpk) , wslpj_tm (jpi,jpj,jpk), STAT=ierr(2) ) + ENDIF + IF( ln_trabbl ) THEN + ALLOCATE( ahu_bbl_temp(jpi,jpj) , utr_bbl_temp(jpi,jpj) , & + & ahv_bbl_temp(jpi,jpj) , vtr_bbl_temp(jpi,jpj) , & + & ahu_bbl_tm (jpi,jpj) , utr_bbl_tm (jpi,jpj) , & + & ahv_bbl_tm (jpi,jpj) , vtr_bbl_tm (jpi,jpj) , STAT=ierr(3) ) + ENDIF + ! + trc_sub_alloc = MAXVAL( ierr ) + ! + IF( trc_sub_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_sub_alloc: failed to allocate arrays' ) + ! + END FUNCTION trc_sub_alloc + +#else + !!---------------------------------------------------------------------- + !! Default key NO passive tracers + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE trc_sub_stp( kt ) ! Empty routine + WRITE(*,*) 'trc_sub_stp: You should not have seen this print! error?', kt + END SUBROUTINE trc_sub_stp + SUBROUTINE trc_sub_ini ! Empty routine + WRITE(*,*) 'trc_sub_ini: You should not have seen this print! error?', kt + END SUBROUTINE trc_sub_ini +#endif + + !!====================================================================== +END MODULE trcsub diff --git a/V4.0/nemo_sources/src/TOP/trcwri.F90 b/V4.0/nemo_sources/src/TOP/trcwri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..61ecbcc6b7d7cd1aee5551f7420d279800c14269 --- /dev/null +++ b/V4.0/nemo_sources/src/TOP/trcwri.F90 @@ -0,0 +1,93 @@ +MODULE trcwri + !!====================================================================== + !! *** MODULE trcwri *** + !! TOP : Output of passive tracers + !!====================================================================== + !! History : 1.0 ! 2009-05 (C. Ethe) Original code + !!---------------------------------------------------------------------- +#if defined key_top && defined key_iomput + !!---------------------------------------------------------------------- + !! 'key_top' TOP models + !!---------------------------------------------------------------------- + !! trc_wri_trc : outputs of concentration fields + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain variables + USE oce_trc ! shared variables between ocean and passive tracers + USE trc ! passive tracers common variables + USE iom ! I/O manager + USE dianam ! Output file name + USE trcwri_pisces + USE trcwri_cfc + USE trcwri_c14 + USE trcwri_age + USE trcwri_my_trc + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_wri + +CONTAINS + + SUBROUTINE trc_wri( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trc_wri *** + !! + !! ** Purpose : output passive tracers fields and dynamical trends + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt + ! + INTEGER :: jn + CHARACTER (len=20) :: cltra + CHARACTER (len=40) :: clhstnam + INTEGER :: inum = 11 ! temporary logical unit + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('trc_wri') + ! + IF( l_offline ) THEN ! WRITE root name in date.file for use by postpro + IF( kt == nittrc000 .AND. lwp ) THEN ! WRITE root name in date.file for use by postpro + CALL dia_nam( clhstnam, nn_writetrc,' ' ) + CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + WRITE(inum,*) clhstnam + CLOSE(inum) + 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(:,:,:) ) + ! + ENDIF + ! write the tracer concentrations in the file + ! --------------------------------------- + IF( ln_pisces ) CALL trc_wri_pisces ! PISCES + IF( ll_cfc ) CALL trc_wri_cfc ! surface fluxes of CFC + IF( ln_c14 ) CALL trc_wri_c14 ! surface fluxes of C14 + IF( ln_age ) CALL trc_wri_age ! AGE tracer + IF( ln_my_trc ) CALL trc_wri_my_trc ! MY_TRC tracers + ! + IF( ln_timing ) CALL timing_stop('trc_wri') + ! + END SUBROUTINE trc_wri + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No passive tracer + !!---------------------------------------------------------------------- + PUBLIC trc_wri +CONTAINS + SUBROUTINE trc_wri( kt ) ! Empty routine + INTEGER, INTENT(in) :: kt + END SUBROUTINE trc_wri +#endif + + !!---------------------------------------------------------------------- + !! NEMO/TOP 4.0 , NEMO Consortium (2018) + !! $Id: trcwri.F90 12280 2019-12-21 10:42:44Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trcwri diff --git a/V4.0/nemo_sources/src/zpshde.F90 b/V4.0/nemo_sources/src/zpshde.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a57595c62f2203af7e7922baf691037dfb456ad6 --- /dev/null +++ b/V4.0/nemo_sources/src/zpshde.F90 @@ -0,0 +1,1040 @@ +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 + + ! INTERFACE zps_hde + ! MODULE PROCEDURE zps_hde_sp, zps_hde_dp, zps_hde_exc + ! END INTERFACE zps_hde + + INTERFACE zps_hde_isf + MODULE PROCEDURE zps_hde_isf_sp, zps_hde_isf_dp + END INTERFACE zps_hde_isf + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zpshde.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! SUBROUTINE zps_hde_sp( 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(sp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields +! REAL(sp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts +! REAL(sp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields +! REAL(sp), 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.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. +! ! +! IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) +! pgru(:,:) = 0._wp +! pgrv(:,:) = 0._wp ! depth of the partial step level +! DO jj = 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.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions +! ! +! END IF +! ! +! IF( ln_timing ) CALL timing_stop( 'zps_hde') +! ! +! END SUBROUTINE zps_hde_sp + + SUBROUTINE zps_hde_exc( 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(sp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(sp), 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.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + ! + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + pgru(:,:) = 0._wp + pgrv(:,:) = 0._wp ! depth of the partial step level + DO jj = 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.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde') + ! + END SUBROUTINE zps_hde_exc + + + SUBROUTINE zps_hde_isf_sp( 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(sp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(sp), 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(sp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(sp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(sp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgrui + REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: 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.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + ! horizontal derivative of density anomalies (rd) + IF( PRESENT( prd ) ) THEN ! depth of the partial step level + pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; + ! + DO jj = 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.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + ! !== (ISH) compute grui and gruvi ==! + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! + DO jj = 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.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + ! + pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; + DO jj = 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.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf_sp + + 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(dp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(dp), 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.0_dp , pgtv(:,:,:), 'V', -1.0_dp ) ! 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.0_dp , pgrv , 'V', -1.0_dp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde') + ! + END SUBROUTINE zps_hde_dp + + + SUBROUTINE zps_hde_isf_dp( 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(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(dp), 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(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(dp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(dp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgrui + REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: 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.0_dp , pgtv(:,:,:), 'V', -1.0_dp ) ! 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.0_dp , pgrv , 'V', -1.0_dp ) ! 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.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + ! + pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; + DO jj = 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.0_dp ) + CALL lbc_lnk_multi( 'zpshde', pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf_dp + + !!====================================================================== +END MODULE zpshde \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca025 b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca025 new file mode 100644 index 0000000000000000000000000000000000000000..978191aaa1fe26e5fbcf86e079f46fa6b2c4b909 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca025 @@ -0,0 +1,639 @@ + nb_cores 1 ( 1 x 1 ), nb_points 1740494 ( 1442 x 1207 ) + nb_cores 2 ( 2 x 1 ), nb_points 871454 ( 722 x 1207 ) + nb_cores 3 ( 3 x 1 ), nb_points 581774 ( 482 x 1207 ) + nb_cores 4 ( 2 x 2 ), nb_points 436810 ( 722 x 605 ) + nb_cores 5 ( 5 x 1 ), nb_points 350030 ( 290 x 1207 ) + nb_cores 6 ( 3 x 2 ), nb_points 291610 ( 482 x 605 ) + nb_cores 7 ( 7 x 1 ), nb_points 251056 ( 208 x 1207 ) + nb_cores 8 ( 4 x 2 ), nb_points 219010 ( 362 x 605 ) + nb_cores 9 ( 3 x 3 ), nb_points 194728 ( 482 x 404 ) + nb_cores 10 ( 2 x 5 ), nb_points 175446 ( 722 x 243 ) + nb_cores 11 ( 11 x 1 ), nb_points 160531 ( 133 x 1207 ) + nb_cores 12 ( 4 x 3 ), nb_points 146248 ( 362 x 404 ) + nb_cores 13 ( 13 x 1 ), nb_points 136391 ( 113 x 1207 ) + nb_cores 14 ( 7 x 2 ), nb_points 125840 ( 208 x 605 ) + nb_cores 15 ( 3 x 5 ), nb_points 117126 ( 482 x 243 ) + nb_cores 16 ( 4 x 4 ), nb_points 110048 ( 362 x 304 ) + nb_cores 17 ( 17 x 1 ), nb_points 105009 ( 87 x 1207 ) + nb_cores 18 ( 6 x 3 ), nb_points 97768 ( 242 x 404 ) + nb_cores 19 ( 19 x 1 ), nb_points 94146 ( 78 x 1207 ) + nb_cores 20 ( 4 x 5 ), nb_points 87966 ( 362 x 243 ) + nb_cores 21 ( 7 x 3 ), nb_points 84032 ( 208 x 404 ) + nb_cores 22 ( 11 x 2 ), nb_points 80465 ( 133 x 605 ) + nb_cores 23 ( 23 x 1 ), nb_points 78455 ( 65 x 1207 ) + nb_cores 24 ( 4 x 6 ), nb_points 73486 ( 362 x 203 ) + nb_cores 25 ( 5 x 5 ), nb_points 70470 ( 290 x 243 ) + nb_cores 26 ( 13 x 2 ), nb_points 68365 ( 113 x 605 ) + nb_cores 27 ( 9 x 3 ), nb_points 65448 ( 162 x 404 ) + nb_cores 28 ( 7 x 4 ), nb_points 63232 ( 208 x 304 ) + nb_cores 29 ( 29 x 1 ), nb_points 62764 ( 52 x 1207 ) + nb_cores 30 ( 6 x 5 ), nb_points 58806 ( 242 x 243 ) + nb_cores 32 ( 8 x 4 ), nb_points 55328 ( 182 x 304 ) + nb_cores 33 ( 11 x 3 ), nb_points 53732 ( 133 x 404 ) + nb_cores 34 ( 17 x 2 ), nb_points 52635 ( 87 x 605 ) + nb_cores 35 ( 7 x 5 ), nb_points 50544 ( 208 x 243 ) + nb_cores 36 ( 6 x 6 ), nb_points 49126 ( 242 x 203 ) + nb_cores 38 ( 19 x 2 ), nb_points 47190 ( 78 x 605 ) + nb_cores 39 ( 13 x 3 ), nb_points 45652 ( 113 x 404 ) + nb_cores 40 ( 8 x 5 ), nb_points 44226 ( 182 x 243 ) + nb_cores 42 ( 7 x 6 ), nb_points 42224 ( 208 x 203 ) + nb_cores 44 ( 11 x 4 ), nb_points 40432 ( 133 x 304 ) + nb_cores 45 ( 9 x 5 ), nb_points 39366 ( 162 x 243 ) + nb_cores 46 ( 23 x 2 ), nb_points 39325 ( 65 x 605 ) + nb_cores 48 ( 8 x 6 ), nb_points 36946 ( 182 x 203 ) + nb_cores 49 ( 7 x 7 ), nb_points 36400 ( 208 x 175 ) + nb_cores 50 ( 10 x 5 ), nb_points 35478 ( 146 x 243 ) + nb_cores 51 ( 17 x 3 ), nb_points 35148 ( 87 x 404 ) + nb_cores 52 ( 13 x 4 ), nb_points 34352 ( 113 x 304 ) + nb_cores 54 ( 9 x 6 ), nb_points 32886 ( 162 x 203 ) + nb_cores 55 ( 11 x 5 ), nb_points 32319 ( 133 x 243 ) + nb_cores 56 ( 7 x 8 ), nb_points 31824 ( 208 x 153 ) + nb_cores 57 ( 19 x 3 ), nb_points 31512 ( 78 x 404 ) + nb_cores 58 ( 29 x 2 ), nb_points 31460 ( 52 x 605 ) + nb_cores 60 ( 10 x 6 ), nb_points 29638 ( 146 x 203 ) + nb_cores 62 ( 2 x 31 ), nb_points 29602 ( 722 x 41 ) + nb_cores 63 ( 7 x 9 ), nb_points 28288 ( 208 x 136 ) + nb_cores 64 ( 8 x 8 ), nb_points 27846 ( 182 x 153 ) + nb_cores 65 ( 13 x 5 ), nb_points 27459 ( 113 x 243 ) + nb_cores 66 ( 11 x 6 ), nb_points 26999 ( 133 x 203 ) + nb_cores 68 ( 4 x 17 ), nb_points 26426 ( 362 x 73 ) + nb_cores 69 ( 23 x 3 ), nb_points 26260 ( 65 x 404 ) + nb_cores 70 ( 14 x 5 ), nb_points 25515 ( 105 x 243 ) + nb_cores 72 ( 8 x 9 ), nb_points 24752 ( 182 x 136 ) + nb_cores 75 ( 15 x 5 ), nb_points 23814 ( 98 x 243 ) + nb_cores 76 ( 19 x 4 ), nb_points 23712 ( 78 x 304 ) + nb_cores 77 ( 11 x 7 ), nb_points 23275 ( 133 x 175 ) + nb_cores 78 ( 13 x 6 ), nb_points 22939 ( 113 x 203 ) + nb_cores 80 ( 10 x 8 ), nb_points 22338 ( 146 x 153 ) + nb_cores 81 ( 9 x 9 ), nb_points 22032 ( 162 x 136 ) + nb_cores 84 ( 14 x 6 ), nb_points 21315 ( 105 x 203 ) + nb_cores 85 ( 17 x 5 ), nb_points 21141 ( 87 x 243 ) + nb_cores 87 ( 29 x 3 ), nb_points 21008 ( 52 x 404 ) + nb_cores 88 ( 11 x 8 ), nb_points 20349 ( 133 x 153 ) + nb_cores 90 ( 10 x 9 ), nb_points 19856 ( 146 x 136 ) + nb_cores 91 ( 7 x 13 ), nb_points 19760 ( 208 x 95 ) + nb_cores 95 ( 19 x 5 ), nb_points 18954 ( 78 x 243 ) + nb_cores 96 ( 12 x 8 ), nb_points 18666 ( 122 x 153 ) + nb_cores 98 ( 14 x 7 ), nb_points 18375 ( 105 x 175 ) + nb_cores 99 ( 11 x 9 ), nb_points 18088 ( 133 x 136 ) + nb_cores 100 ( 10 x 10 ), nb_points 17958 ( 146 x 123 ) + nb_cores 102 ( 17 x 6 ), nb_points 17661 ( 87 x 203 ) + nb_cores 104 ( 13 x 8 ), nb_points 17289 ( 113 x 153 ) + nb_cores 105 ( 15 x 7 ), nb_points 17150 ( 98 x 175 ) + nb_cores 108 ( 12 x 9 ), nb_points 16592 ( 122 x 136 ) + nb_cores 110 ( 10 x 11 ), nb_points 16352 ( 146 x 112 ) + nb_cores 112 ( 14 x 8 ), nb_points 16065 ( 105 x 153 ) + nb_cores 114 ( 19 x 6 ), nb_points 15834 ( 78 x 203 ) + nb_cores 115 ( 23 x 5 ), nb_points 15795 ( 65 x 243 ) + nb_cores 117 ( 13 x 9 ), nb_points 15368 ( 113 x 136 ) + nb_cores 119 ( 7 x 17 ), nb_points 15184 ( 208 x 73 ) + nb_cores 120 ( 15 x 8 ), nb_points 14994 ( 98 x 153 ) + nb_cores 121 ( 11 x 11 ), nb_points 14896 ( 133 x 112 ) + nb_cores 124 ( 4 x 31 ), nb_points 14842 ( 362 x 41 ) + nb_cores 125 ( 25 x 5 ), nb_points 14580 ( 60 x 243 ) + nb_cores 126 ( 14 x 9 ), nb_points 14280 ( 105 x 136 ) + nb_cores 128 ( 16 x 8 ), nb_points 14076 ( 92 x 153 ) + nb_cores 130 ( 10 x 13 ), nb_points 13870 ( 146 x 95 ) + nb_cores 132 ( 12 x 11 ), nb_points 13664 ( 122 x 112 ) + nb_cores 133 ( 19 x 7 ), nb_points 13650 ( 78 x 175 ) + nb_cores 135 ( 15 x 9 ), nb_points 13328 ( 98 x 136 ) + nb_cores 136 ( 8 x 17 ), nb_points 13286 ( 182 x 73 ) + nb_cores 138 ( 23 x 6 ), nb_points 13195 ( 65 x 203 ) + nb_cores 140 ( 14 x 10 ), nb_points 12915 ( 105 x 123 ) + nb_cores 143 ( 11 x 13 ), nb_points 12635 ( 133 x 95 ) + nb_cores 144 ( 16 x 9 ), nb_points 12512 ( 92 x 136 ) + nb_cores 147 ( 21 x 7 ), nb_points 12425 ( 71 x 175 ) + nb_cores 150 ( 15 x 10 ), nb_points 12054 ( 98 x 123 ) + nb_cores 152 ( 19 x 8 ), nb_points 11934 ( 78 x 153 ) + nb_cores 153 ( 9 x 17 ), nb_points 11826 ( 162 x 73 ) + nb_cores 154 ( 14 x 11 ), nb_points 11760 ( 105 x 112 ) + nb_cores 156 ( 12 x 13 ), nb_points 11590 ( 122 x 95 ) + nb_cores 160 ( 16 x 10 ), nb_points 11316 ( 92 x 123 ) + nb_cores 162 ( 18 x 9 ), nb_points 11152 ( 82 x 136 ) + nb_cores 165 ( 15 x 11 ), nb_points 10976 ( 98 x 112 ) + nb_cores 168 ( 14 x 12 ), nb_points 10815 ( 105 x 103 ) + nb_cores 169 ( 13 x 13 ), nb_points 10735 ( 113 x 95 ) + nb_cores 170 ( 10 x 17 ), nb_points 10658 ( 146 x 73 ) + nb_cores 171 ( 19 x 9 ), nb_points 10608 ( 78 x 136 ) + nb_cores 174 ( 29 x 6 ), nb_points 10556 ( 52 x 203 ) + nb_cores 175 ( 25 x 7 ), nb_points 10500 ( 60 x 175 ) + nb_cores 176 ( 16 x 11 ), nb_points 10304 ( 92 x 112 ) + nb_cores 180 ( 20 x 9 ), nb_points 10064 ( 74 x 136 ) + nb_cores 182 ( 14 x 13 ), nb_points 9975 ( 105 x 95 ) + nb_cores 184 ( 23 x 8 ), nb_points 9945 ( 65 x 153 ) + nb_cores 186 ( 6 x 31 ), nb_points 9922 ( 242 x 41 ) + nb_cores 187 ( 11 x 17 ), nb_points 9709 ( 133 x 73 ) + nb_cores 189 ( 21 x 9 ), nb_points 9656 ( 71 x 136 ) + nb_cores 190 ( 19 x 10 ), nb_points 9594 ( 78 x 123 ) + nb_cores 192 ( 16 x 12 ), nb_points 9476 ( 92 x 103 ) + nb_cores 195 ( 15 x 13 ), nb_points 9310 ( 98 x 95 ) + nb_cores 198 ( 11 x 18 ), nb_points 9177 ( 133 x 69 ) + nb_cores 200 ( 20 x 10 ), nb_points 9102 ( 74 x 123 ) + nb_cores 203 ( 29 x 7 ), nb_points 9100 ( 52 x 175 ) + nb_cores 204 ( 12 x 17 ), nb_points 8906 ( 122 x 73 ) + nb_cores 207 ( 23 x 9 ), nb_points 8840 ( 65 x 136 ) + nb_cores 208 ( 16 x 13 ), nb_points 8740 ( 92 x 95 ) + nb_cores 209 ( 19 x 11 ), nb_points 8736 ( 78 x 112 ) + nb_cores 210 ( 14 x 15 ), nb_points 8715 ( 105 x 83 ) + nb_cores 216 ( 12 x 18 ), nb_points 8418 ( 122 x 69 ) + nb_cores 220 ( 20 x 11 ), nb_points 8288 ( 74 x 112 ) + nb_cores 221 ( 13 x 17 ), nb_points 8249 ( 113 x 73 ) + nb_cores 224 ( 16 x 14 ), nb_points 8188 ( 92 x 89 ) + nb_cores 225 ( 15 x 15 ), nb_points 8134 ( 98 x 83 ) + nb_cores 228 ( 19 x 12 ), nb_points 8034 ( 78 x 103 ) + nb_cores 230 ( 23 x 10 ), nb_points 7995 ( 65 x 123 ) + nb_cores 231 ( 21 x 11 ), nb_points 7952 ( 71 x 112 ) + nb_cores 234 ( 18 x 13 ), nb_points 7790 ( 82 x 95 ) + nb_cores 238 ( 14 x 17 ), nb_points 7665 ( 105 x 73 ) + nb_cores 240 ( 20 x 12 ), nb_points 7622 ( 74 x 103 ) + nb_cores 242 ( 11 x 22 ), nb_points 7581 ( 133 x 57 ) + nb_cores 247 ( 19 x 13 ), nb_points 7410 ( 78 x 95 ) + nb_cores 250 ( 25 x 10 ), nb_points 7380 ( 60 x 123 ) + nb_cores 252 ( 14 x 18 ), nb_points 7245 ( 105 x 69 ) + nb_cores 255 ( 15 x 17 ), nb_points 7154 ( 98 x 73 ) + nb_cores 260 ( 20 x 13 ), nb_points 7030 ( 74 x 95 ) + nb_cores 264 ( 24 x 11 ), nb_points 6944 ( 62 x 112 ) + nb_cores 266 ( 14 x 19 ), nb_points 6930 ( 105 x 66 ) + nb_cores 270 ( 15 x 18 ), nb_points 6762 ( 98 x 69 ) + nb_cores 272 ( 16 x 17 ), nb_points 6716 ( 92 x 73 ) + nb_cores 276 ( 23 x 12 ), nb_points 6695 ( 65 x 103 ) + nb_cores 279 ( 9 x 31 ), nb_points 6642 ( 162 x 41 ) + nb_cores 280 ( 20 x 14 ), nb_points 6586 ( 74 x 89 ) + nb_cores 285 ( 15 x 19 ), nb_points 6468 ( 98 x 66 ) + nb_cores 286 ( 13 x 22 ), nb_points 6441 ( 113 x 57 ) + nb_cores 288 ( 16 x 18 ), nb_points 6348 ( 92 x 69 ) + nb_cores 294 ( 14 x 21 ), nb_points 6300 ( 105 x 60 ) + nb_cores 296 ( 37 x 8 ), nb_points 6273 ( 41 x 153 ) + nb_cores 297 ( 11 x 27 ), nb_points 6251 ( 133 x 47 ) + nb_cores 299 ( 23 x 13 ), nb_points 6175 ( 65 x 95 ) + nb_cores 300 ( 20 x 15 ), nb_points 6142 ( 74 x 83 ) + nb_cores 304 ( 16 x 19 ), nb_points 6072 ( 92 x 66 ) + nb_cores 306 ( 18 x 17 ), nb_points 5986 ( 82 x 73 ) + nb_cores 308 ( 14 x 22 ), nb_points 5985 ( 105 x 57 ) + nb_cores 312 ( 24 x 13 ), nb_points 5890 ( 62 x 95 ) + nb_cores 315 ( 15 x 21 ), nb_points 5880 ( 98 x 60 ) + nb_cores 319 ( 29 x 11 ), nb_points 5824 ( 52 x 112 ) + nb_cores 320 ( 20 x 16 ), nb_points 5772 ( 74 x 78 ) + nb_cores 323 ( 19 x 17 ), nb_points 5694 ( 78 x 73 ) + nb_cores 324 ( 18 x 18 ), nb_points 5658 ( 82 x 69 ) + nb_cores 330 ( 15 x 22 ), nb_points 5586 ( 98 x 57 ) + nb_cores 333 ( 37 x 9 ), nb_points 5576 ( 41 x 136 ) + nb_cores 336 ( 24 x 14 ), nb_points 5518 ( 62 x 89 ) + nb_cores 338 ( 26 x 13 ), nb_points 5510 ( 58 x 95 ) + nb_cores 340 ( 20 x 17 ), nb_points 5402 ( 74 x 73 ) + nb_cores 342 ( 19 x 18 ), nb_points 5382 ( 78 x 69 ) + nb_cores 348 ( 29 x 12 ), nb_points 5356 ( 52 x 103 ) + nb_cores 350 ( 25 x 14 ), nb_points 5340 ( 60 x 89 ) + nb_cores 351 ( 39 x 9 ), nb_points 5304 ( 39 x 136 ) + nb_cores 352 ( 16 x 22 ), nb_points 5244 ( 92 x 57 ) + nb_cores 357 ( 21 x 17 ), nb_points 5183 ( 71 x 73 ) + nb_cores 360 ( 20 x 18 ), nb_points 5106 ( 74 x 69 ) + nb_cores 368 ( 16 x 23 ), nb_points 5060 ( 92 x 55 ) + nb_cores 370 ( 37 x 10 ), nb_points 5043 ( 41 x 123 ) + nb_cores 372 ( 12 x 31 ), nb_points 5002 ( 122 x 41 ) + nb_cores 374 ( 17 x 22 ), nb_points 4959 ( 87 x 57 ) + nb_cores 377 ( 29 x 13 ), nb_points 4940 ( 52 x 95 ) + nb_cores 378 ( 21 x 18 ), nb_points 4899 ( 71 x 69 ) + nb_cores 380 ( 20 x 19 ), nb_points 4884 ( 74 x 66 ) + nb_cores 384 ( 24 x 16 ), nb_points 4836 ( 62 x 78 ) + nb_cores 390 ( 30 x 13 ), nb_points 4750 ( 50 x 95 ) + nb_cores 391 ( 23 x 17 ), nb_points 4745 ( 65 x 73 ) + nb_cores 396 ( 18 x 22 ), nb_points 4674 ( 82 x 57 ) + nb_cores 400 ( 20 x 20 ), nb_points 4662 ( 74 x 63 ) + nb_cores 403 ( 13 x 31 ), nb_points 4633 ( 113 x 41 ) + nb_cores 405 ( 15 x 27 ), nb_points 4606 ( 98 x 47 ) + nb_cores 407 ( 37 x 11 ), nb_points 4592 ( 41 x 112 ) + nb_cores 408 ( 24 x 17 ), nb_points 4526 ( 62 x 73 ) + nb_cores 414 ( 23 x 18 ), nb_points 4485 ( 65 x 69 ) + nb_cores 416 ( 32 x 13 ), nb_points 4465 ( 47 x 95 ) + nb_cores 418 ( 19 x 22 ), nb_points 4446 ( 78 x 57 ) + nb_cores 420 ( 20 x 21 ), nb_points 4440 ( 74 x 60 ) + nb_cores 425 ( 25 x 17 ), nb_points 4380 ( 60 x 73 ) + nb_cores 429 ( 39 x 11 ), nb_points 4368 ( 39 x 112 ) + nb_cores 432 ( 24 x 18 ), nb_points 4278 ( 62 x 69 ) + nb_cores 440 ( 20 x 22 ), nb_points 4218 ( 74 x 57 ) + nb_cores 448 ( 32 x 14 ), nb_points 4183 ( 47 x 89 ) + nb_cores 450 ( 25 x 18 ), nb_points 4140 ( 60 x 69 ) + nb_cores 456 ( 24 x 19 ), nb_points 4092 ( 62 x 66 ) + nb_cores 459 ( 27 x 17 ), nb_points 4088 ( 56 x 73 ) + nb_cores 460 ( 20 x 23 ), nb_points 4070 ( 74 x 55 ) + nb_cores 462 ( 21 x 22 ), nb_points 4047 ( 71 x 57 ) + nb_cores 465 ( 15 x 31 ), nb_points 4018 ( 98 x 41 ) + nb_cores 468 ( 36 x 13 ), nb_points 3990 ( 42 x 95 ) + nb_cores 475 ( 25 x 19 ), nb_points 3960 ( 60 x 66 ) + nb_cores 476 ( 28 x 17 ), nb_points 3942 ( 54 x 73 ) + nb_cores 480 ( 30 x 16 ), nb_points 3900 ( 50 x 78 ) + nb_cores 481 ( 37 x 13 ), nb_points 3895 ( 41 x 95 ) + nb_cores 484 ( 22 x 22 ), nb_points 3876 ( 68 x 57 ) + nb_cores 486 ( 18 x 27 ), nb_points 3854 ( 82 x 47 ) + nb_cores 493 ( 29 x 17 ), nb_points 3796 ( 52 x 73 ) + nb_cores 496 ( 16 x 31 ), nb_points 3772 ( 92 x 41 ) + nb_cores 504 ( 24 x 21 ), nb_points 3720 ( 62 x 60 ) + nb_cores 506 ( 23 x 22 ), nb_points 3705 ( 65 x 57 ) + nb_cores 510 ( 30 x 17 ), nb_points 3650 ( 50 x 73 ) + nb_cores 518 ( 37 x 14 ), nb_points 3649 ( 41 x 89 ) + nb_cores 520 ( 40 x 13 ), nb_points 3610 ( 38 x 95 ) + nb_cores 522 ( 29 x 18 ), nb_points 3588 ( 52 x 69 ) + nb_cores 527 ( 17 x 31 ), nb_points 3567 ( 87 x 41 ) + nb_cores 528 ( 24 x 22 ), nb_points 3534 ( 62 x 57 ) + nb_cores 540 ( 30 x 18 ), nb_points 3450 ( 50 x 69 ) + nb_cores 544 ( 32 x 17 ), nb_points 3431 ( 47 x 73 ) + nb_cores 550 ( 25 x 22 ), nb_points 3420 ( 60 x 57 ) + nb_cores 552 ( 24 x 23 ), nb_points 3410 ( 62 x 55 ) + nb_cores 555 ( 37 x 15 ), nb_points 3403 ( 41 x 83 ) + nb_cores 558 ( 18 x 31 ), nb_points 3362 ( 82 x 41 ) + nb_cores 561 ( 33 x 17 ), nb_points 3358 ( 46 x 73 ) + nb_cores 567 ( 21 x 27 ), nb_points 3337 ( 71 x 47 ) + nb_cores 570 ( 30 x 19 ), nb_points 3300 ( 50 x 66 ) + nb_cores 576 ( 32 x 18 ), nb_points 3243 ( 47 x 69 ) + nb_cores 585 ( 45 x 13 ), nb_points 3230 ( 34 x 95 ) + nb_cores 589 ( 19 x 31 ), nb_points 3198 ( 78 x 41 ) + nb_cores 594 ( 33 x 18 ), nb_points 3174 ( 46 x 69 ) + nb_cores 600 ( 30 x 20 ), nb_points 3150 ( 50 x 63 ) + nb_cores 608 ( 32 x 19 ), nb_points 3102 ( 47 x 66 ) + nb_cores 612 ( 36 x 17 ), nb_points 3066 ( 42 x 73 ) + nb_cores 620 ( 20 x 31 ), nb_points 3034 ( 74 x 41 ) + nb_cores 629 ( 37 x 17 ), nb_points 2993 ( 41 x 73 ) + nb_cores 638 ( 29 x 22 ), nb_points 2964 ( 52 x 57 ) + nb_cores 640 ( 20 x 32 ), nb_points 2960 ( 74 x 40 ) + nb_cores 646 ( 38 x 17 ), nb_points 2920 ( 40 x 73 ) + nb_cores 648 ( 36 x 18 ), nb_points 2898 ( 42 x 69 ) + nb_cores 660 ( 30 x 22 ), nb_points 2850 ( 50 x 57 ) + nb_cores 663 ( 39 x 17 ), nb_points 2847 ( 39 x 73 ) + nb_cores 666 ( 37 x 18 ), nb_points 2829 ( 41 x 69 ) + nb_cores 672 ( 32 x 21 ), nb_points 2820 ( 47 x 60 ) + nb_cores 680 ( 40 x 17 ), nb_points 2774 ( 38 x 73 ) + nb_cores 684 ( 38 x 18 ), nb_points 2760 ( 40 x 69 ) + nb_cores 690 ( 30 x 23 ), nb_points 2750 ( 50 x 55 ) + nb_cores 696 ( 24 x 29 ), nb_points 2728 ( 62 x 44 ) + nb_cores 702 ( 39 x 18 ), nb_points 2691 ( 39 x 69 ) + nb_cores 704 ( 32 x 22 ), nb_points 2679 ( 47 x 57 ) + nb_cores 713 ( 23 x 31 ), nb_points 2665 ( 65 x 41 ) + nb_cores 720 ( 40 x 18 ), nb_points 2622 ( 38 x 69 ) + nb_cores 736 ( 32 x 23 ), nb_points 2585 ( 47 x 55 ) + nb_cores 740 ( 37 x 20 ), nb_points 2583 ( 41 x 63 ) + nb_cores 741 ( 19 x 39 ), nb_points 2574 ( 78 x 33 ) + nb_cores 741 ( 39 x 19 ), nb_points 2574 ( 39 x 66 ) + nb_cores 744 ( 24 x 31 ), nb_points 2542 ( 62 x 41 ) + nb_cores 756 ( 36 x 21 ), nb_points 2520 ( 42 x 60 ) + nb_cores 760 ( 40 x 19 ), nb_points 2508 ( 38 x 66 ) + nb_cores 765 ( 45 x 17 ), nb_points 2482 ( 34 x 73 ) + nb_cores 768 ( 24 x 32 ), nb_points 2480 ( 62 x 40 ) + nb_cores 775 ( 25 x 31 ), nb_points 2460 ( 60 x 41 ) + nb_cores 780 ( 20 x 39 ), nb_points 2442 ( 74 x 33 ) + nb_cores 792 ( 36 x 22 ), nb_points 2394 ( 42 x 57 ) + nb_cores 806 ( 26 x 31 ), nb_points 2378 ( 58 x 41 ) + nb_cores 810 ( 45 x 18 ), nb_points 2346 ( 34 x 69 ) + nb_cores 814 ( 37 x 22 ), nb_points 2337 ( 41 x 57 ) + nb_cores 816 ( 48 x 17 ), nb_points 2336 ( 32 x 73 ) + nb_cores 828 ( 36 x 23 ), nb_points 2310 ( 42 x 55 ) + nb_cores 832 ( 32 x 26 ), nb_points 2303 ( 47 x 49 ) + nb_cores 836 ( 38 x 22 ), nb_points 2280 ( 40 x 57 ) + nb_cores 846 ( 47 x 18 ), nb_points 2277 ( 33 x 69 ) + nb_cores 850 ( 50 x 17 ), nb_points 2263 ( 31 x 73 ) + nb_cores 851 ( 37 x 23 ), nb_points 2255 ( 41 x 55 ) + nb_cores 855 ( 45 x 19 ), nb_points 2244 ( 34 x 66 ) + nb_cores 858 ( 39 x 22 ), nb_points 2223 ( 39 x 57 ) + nb_cores 864 ( 48 x 18 ), nb_points 2208 ( 32 x 69 ) + nb_cores 870 ( 30 x 29 ), nb_points 2200 ( 50 x 44 ) + nb_cores 880 ( 40 x 22 ), nb_points 2166 ( 38 x 57 ) + nb_cores 891 ( 33 x 27 ), nb_points 2162 ( 46 x 47 ) + nb_cores 896 ( 28 x 32 ), nb_points 2160 ( 54 x 40 ) + nb_cores 897 ( 23 x 39 ), nb_points 2145 ( 65 x 33 ) + nb_cores 897 ( 39 x 23 ), nb_points 2145 ( 39 x 55 ) + nb_cores 899 ( 29 x 31 ), nb_points 2132 ( 52 x 41 ) + nb_cores 912 ( 24 x 38 ), nb_points 2108 ( 62 x 34 ) + nb_cores 920 ( 40 x 23 ), nb_points 2090 ( 38 x 55 ) + nb_cores 928 ( 32 x 29 ), nb_points 2068 ( 47 x 44 ) + nb_cores 930 ( 30 x 31 ), nb_points 2050 ( 50 x 41 ) + nb_cores 936 ( 24 x 39 ), nb_points 2046 ( 62 x 33 ) + nb_cores 945 ( 45 x 21 ), nb_points 2040 ( 34 x 60 ) + nb_cores 957 ( 33 x 29 ), nb_points 2024 ( 46 x 44 ) + nb_cores 960 ( 30 x 32 ), nb_points 2000 ( 50 x 40 ) + nb_cores 968 ( 44 x 22 ), nb_points 1995 ( 35 x 57 ) + nb_cores 972 ( 36 x 27 ), nb_points 1974 ( 42 x 47 ) + nb_cores 986 ( 58 x 17 ), nb_points 1971 ( 27 x 73 ) + nb_cores 988 ( 38 x 26 ), nb_points 1960 ( 40 x 49 ) + nb_cores 990 ( 45 x 22 ), nb_points 1938 ( 34 x 57 ) + nb_cores 992 ( 32 x 31 ), nb_points 1927 ( 47 x 41 ) + nb_cores 1008 ( 48 x 21 ), nb_points 1920 ( 32 x 60 ) + nb_cores 1014 ( 39 x 26 ), nb_points 1911 ( 39 x 49 ) + nb_cores 1020 ( 60 x 17 ), nb_points 1898 ( 26 x 73 ) + nb_cores 1023 ( 33 x 31 ), nb_points 1886 ( 46 x 41 ) + nb_cores 1024 ( 32 x 32 ), nb_points 1880 ( 47 x 40 ) + nb_cores 1035 ( 45 x 23 ), nb_points 1870 ( 34 x 55 ) + nb_cores 1040 ( 40 x 26 ), nb_points 1862 ( 38 x 49 ) + nb_cores 1044 ( 36 x 29 ), nb_points 1848 ( 42 x 44 ) + nb_cores 1053 ( 39 x 27 ), nb_points 1833 ( 39 x 47 ) + nb_cores 1056 ( 48 x 22 ), nb_points 1824 ( 32 x 57 ) + nb_cores 1073 ( 37 x 29 ), nb_points 1804 ( 41 x 44 ) + nb_cores 1080 ( 40 x 27 ), nb_points 1786 ( 38 x 47 ) + nb_cores 1092 ( 28 x 39 ), nb_points 1782 ( 54 x 33 ) + nb_cores 1100 ( 50 x 22 ), nb_points 1767 ( 31 x 57 ) + nb_cores 1102 ( 38 x 29 ), nb_points 1760 ( 40 x 44 ) + nb_cores 1110 ( 30 x 37 ), nb_points 1750 ( 50 x 35 ) + nb_cores 1116 ( 36 x 31 ), nb_points 1722 ( 42 x 41 ) + nb_cores 1131 ( 39 x 29 ), nb_points 1716 ( 39 x 44 ) + nb_cores 1131 ( 29 x 39 ), nb_points 1716 ( 52 x 33 ) + nb_cores 1140 ( 30 x 38 ), nb_points 1700 ( 50 x 34 ) + nb_cores 1147 ( 37 x 31 ), nb_points 1681 ( 41 x 41 ) + nb_cores 1152 ( 36 x 32 ), nb_points 1680 ( 42 x 40 ) + nb_cores 1160 ( 40 x 29 ), nb_points 1672 ( 38 x 44 ) + nb_cores 1170 ( 30 x 39 ), nb_points 1650 ( 50 x 33 ) + nb_cores 1178 ( 38 x 31 ), nb_points 1640 ( 40 x 41 ) + nb_cores 1188 ( 36 x 33 ), nb_points 1638 ( 42 x 39 ) + nb_cores 1200 ( 48 x 25 ), nb_points 1632 ( 32 x 51 ) + nb_cores 1209 ( 39 x 31 ), nb_points 1599 ( 39 x 41 ) + nb_cores 1215 ( 45 x 27 ), nb_points 1598 ( 34 x 47 ) + nb_cores 1224 ( 36 x 34 ), nb_points 1596 ( 42 x 38 ) + nb_cores 1240 ( 40 x 31 ), nb_points 1558 ( 38 x 41 ) + nb_cores 1248 ( 32 x 39 ), nb_points 1551 ( 47 x 33 ) + nb_cores 1260 ( 30 x 42 ), nb_points 1550 ( 50 x 31 ) + nb_cores 1276 ( 58 x 22 ), nb_points 1539 ( 27 x 57 ) + nb_cores 1280 ( 40 x 32 ), nb_points 1520 ( 38 x 40 ) + nb_cores 1287 ( 33 x 39 ), nb_points 1518 ( 46 x 33 ) + nb_cores 1295 ( 37 x 35 ), nb_points 1517 ( 41 x 37 ) + nb_cores 1296 ( 48 x 27 ), nb_points 1504 ( 32 x 47 ) + nb_cores 1305 ( 45 x 29 ), nb_points 1496 ( 34 x 44 ) + nb_cores 1320 ( 40 x 33 ), nb_points 1482 ( 38 x 39 ) + nb_cores 1320 ( 60 x 22 ), nb_points 1482 ( 26 x 57 ) + nb_cores 1330 ( 38 x 35 ), nb_points 1480 ( 40 x 37 ) + nb_cores 1332 ( 36 x 37 ), nb_points 1470 ( 42 x 35 ) + nb_cores 1344 ( 32 x 42 ), nb_points 1457 ( 47 x 31 ) + nb_cores 1350 ( 30 x 45 ), nb_points 1450 ( 50 x 29 ) + nb_cores 1360 ( 40 x 34 ), nb_points 1444 ( 38 x 38 ) + nb_cores 1364 ( 44 x 31 ), nb_points 1435 ( 35 x 41 ) + nb_cores 1368 ( 36 x 38 ), nb_points 1428 ( 42 x 34 ) + nb_cores 1386 ( 63 x 22 ), nb_points 1425 ( 25 x 57 ) + nb_cores 1392 ( 48 x 29 ), nb_points 1408 ( 32 x 44 ) + nb_cores 1395 ( 45 x 31 ), nb_points 1394 ( 34 x 41 ) + nb_cores 1404 ( 36 x 39 ), nb_points 1386 ( 42 x 33 ) + nb_cores 1440 ( 45 x 32 ), nb_points 1360 ( 34 x 40 ) + nb_cores 1443 ( 37 x 39 ), nb_points 1353 ( 41 x 33 ) + nb_cores 1470 ( 30 x 49 ), nb_points 1350 ( 50 x 27 ) + nb_cores 1476 ( 36 x 41 ), nb_points 1344 ( 42 x 32 ) + nb_cores 1480 ( 40 x 37 ), nb_points 1330 ( 38 x 35 ) + nb_cores 1482 ( 38 x 39 ), nb_points 1320 ( 40 x 33 ) + nb_cores 1488 ( 48 x 31 ), nb_points 1312 ( 32 x 41 ) + nb_cores 1512 ( 36 x 42 ), nb_points 1302 ( 42 x 31 ) + nb_cores 1520 ( 40 x 38 ), nb_points 1292 ( 38 x 34 ) + nb_cores 1521 ( 39 x 39 ), nb_points 1287 ( 39 x 33 ) + nb_cores 1536 ( 48 x 32 ), nb_points 1280 ( 32 x 40 ) + nb_cores 1550 ( 50 x 31 ), nb_points 1271 ( 31 x 41 ) + nb_cores 1560 ( 40 x 39 ), nb_points 1254 ( 38 x 33 ) + nb_cores 1584 ( 48 x 33 ), nb_points 1248 ( 32 x 39 ) + nb_cores 1596 ( 38 x 42 ), nb_points 1240 ( 40 x 31 ) + nb_cores 1612 ( 52 x 31 ), nb_points 1230 ( 30 x 41 ) + nb_cores 1620 ( 36 x 45 ), nb_points 1218 ( 42 x 29 ) + nb_cores 1632 ( 48 x 34 ), nb_points 1216 ( 32 x 38 ) + nb_cores 1638 ( 39 x 42 ), nb_points 1209 ( 39 x 31 ) + nb_cores 1650 ( 30 x 55 ), nb_points 1200 ( 50 x 24 ) + nb_cores 1665 ( 37 x 45 ), nb_points 1189 ( 41 x 29 ) + nb_cores 1677 ( 43 x 39 ), nb_points 1188 ( 36 x 33 ) + nb_cores 1680 ( 40 x 42 ), nb_points 1178 ( 38 x 31 ) + nb_cores 1692 ( 36 x 47 ), nb_points 1176 ( 42 x 28 ) + nb_cores 1696 ( 32 x 53 ), nb_points 1175 ( 47 x 25 ) + nb_cores 1710 ( 45 x 38 ), nb_points 1156 ( 34 x 34 ) + nb_cores 1716 ( 44 x 39 ), nb_points 1155 ( 35 x 33 ) + nb_cores 1728 ( 48 x 36 ), nb_points 1152 ( 32 x 36 ) + nb_cores 1736 ( 56 x 31 ), nb_points 1148 ( 28 x 41 ) + nb_cores 1740 ( 60 x 29 ), nb_points 1144 ( 26 x 44 ) + nb_cores 1755 ( 45 x 39 ), nb_points 1122 ( 34 x 33 ) + nb_cores 1776 ( 48 x 37 ), nb_points 1120 ( 32 x 35 ) + nb_cores 1798 ( 58 x 31 ), nb_points 1107 ( 27 x 41 ) + nb_cores 1800 ( 40 x 45 ), nb_points 1102 ( 38 x 29 ) + nb_cores 1824 ( 48 x 38 ), nb_points 1088 ( 32 x 34 ) + nb_cores 1848 ( 44 x 42 ), nb_points 1085 ( 35 x 31 ) + nb_cores 1856 ( 58 x 32 ), nb_points 1080 ( 27 x 40 ) + nb_cores 1860 ( 60 x 31 ), nb_points 1066 ( 26 x 41 ) + nb_cores 1872 ( 48 x 39 ), nb_points 1056 ( 32 x 33 ) + nb_cores 1890 ( 45 x 42 ), nb_points 1054 ( 34 x 31 ) + nb_cores 1908 ( 36 x 53 ), nb_points 1050 ( 42 x 25 ) + nb_cores 1920 ( 60 x 32 ), nb_points 1040 ( 26 x 40 ) + nb_cores 1944 ( 72 x 27 ), nb_points 1034 ( 22 x 47 ) + nb_cores 1950 ( 50 x 39 ), nb_points 1023 ( 31 x 33 ) + nb_cores 1976 ( 52 x 38 ), nb_points 1020 ( 30 x 34 ) + nb_cores 1980 ( 36 x 55 ), nb_points 1008 ( 42 x 24 ) + nb_cores 2010 ( 30 x 67 ), nb_points 1000 ( 50 x 20 ) + nb_cores 2016 ( 48 x 42 ), nb_points 992 ( 32 x 31 ) + nb_cores 2025 ( 45 x 45 ), nb_points 986 ( 34 x 29 ) + nb_cores 2035 ( 37 x 55 ), nb_points 984 ( 41 x 24 ) + nb_cores 2067 ( 39 x 53 ), nb_points 975 ( 39 x 25 ) + nb_cores 2088 ( 36 x 58 ), nb_points 966 ( 42 x 23 ) + nb_cores 2090 ( 38 x 55 ), nb_points 960 ( 40 x 24 ) + nb_cores 2106 ( 54 x 39 ), nb_points 957 ( 29 x 33 ) + nb_cores 2115 ( 45 x 47 ), nb_points 952 ( 34 x 28 ) + nb_cores 2120 ( 40 x 53 ), nb_points 950 ( 38 x 25 ) + nb_cores 2139 ( 69 x 31 ), nb_points 943 ( 23 x 41 ) + nb_cores 2144 ( 32 x 67 ), nb_points 940 ( 47 x 20 ) + nb_cores 2145 ( 39 x 55 ), nb_points 936 ( 39 x 24 ) + nb_cores 2160 ( 48 x 45 ), nb_points 928 ( 32 x 29 ) + nb_cores 2184 ( 56 x 39 ), nb_points 924 ( 28 x 33 ) + nb_cores 2200 ( 40 x 55 ), nb_points 912 ( 38 x 24 ) + nb_cores 2220 ( 60 x 37 ), nb_points 910 ( 26 x 35 ) + nb_cores 2232 ( 72 x 31 ), nb_points 902 ( 22 x 41 ) + nb_cores 2250 ( 50 x 45 ), nb_points 899 ( 31 x 29 ) + nb_cores 2256 ( 48 x 47 ), nb_points 896 ( 32 x 28 ) + nb_cores 2262 ( 58 x 39 ), nb_points 891 ( 27 x 33 ) + nb_cores 2280 ( 60 x 38 ), nb_points 884 ( 26 x 34 ) + nb_cores 2304 ( 72 x 32 ), nb_points 880 ( 22 x 40 ) + nb_cores 2320 ( 40 x 58 ), nb_points 874 ( 38 x 23 ) + nb_cores 2340 ( 60 x 39 ), nb_points 858 ( 26 x 33 ) + nb_cores 2385 ( 45 x 53 ), nb_points 850 ( 34 x 25 ) + nb_cores 2412 ( 36 x 67 ), nb_points 840 ( 42 x 20 ) + nb_cores 2436 ( 58 x 42 ), nb_points 837 ( 27 x 31 ) + nb_cores 2440 ( 40 x 61 ), nb_points 836 ( 38 x 22 ) + nb_cores 2448 ( 48 x 51 ), nb_points 832 ( 32 x 26 ) + nb_cores 2457 ( 63 x 39 ), nb_points 825 ( 25 x 33 ) + nb_cores 2475 ( 45 x 55 ), nb_points 816 ( 34 x 24 ) + nb_cores 2520 ( 60 x 42 ), nb_points 806 ( 26 x 31 ) + nb_cores 2544 ( 48 x 53 ), nb_points 800 ( 32 x 25 ) + nb_cores 2556 ( 36 x 71 ), nb_points 798 ( 42 x 19 ) + nb_cores 2574 ( 66 x 39 ), nb_points 792 ( 24 x 33 ) + nb_cores 2610 ( 45 x 58 ), nb_points 782 ( 34 x 23 ) + nb_cores 2613 ( 39 x 67 ), nb_points 780 ( 39 x 20 ) + nb_cores 2627 ( 37 x 71 ), nb_points 779 ( 41 x 19 ) + nb_cores 2640 ( 48 x 55 ), nb_points 768 ( 32 x 24 ) + nb_cores 2680 ( 40 x 67 ), nb_points 760 ( 38 x 20 ) + nb_cores 2691 ( 69 x 39 ), nb_points 759 ( 23 x 33 ) + nb_cores 2700 ( 60 x 45 ), nb_points 754 ( 26 x 29 ) + nb_cores 2736 ( 72 x 38 ), nb_points 748 ( 22 x 34 ) + nb_cores 2750 ( 50 x 55 ), nb_points 744 ( 31 x 24 ) + nb_cores 2769 ( 39 x 71 ), nb_points 741 ( 39 x 19 ) + nb_cores 2784 ( 48 x 58 ), nb_points 736 ( 32 x 23 ) + nb_cores 2808 ( 72 x 39 ), nb_points 726 ( 22 x 33 ) + nb_cores 2835 ( 63 x 45 ), nb_points 725 ( 25 x 29 ) + nb_cores 2840 ( 40 x 71 ), nb_points 722 ( 38 x 19 ) + nb_cores 2860 ( 52 x 55 ), nb_points 720 ( 30 x 24 ) + nb_cores 2880 ( 45 x 64 ), nb_points 714 ( 34 x 21 ) + nb_cores 2898 ( 69 x 42 ), nb_points 713 ( 23 x 31 ) + nb_cores 2928 ( 48 x 61 ), nb_points 704 ( 32 x 22 ) + nb_cores 2940 ( 60 x 49 ), nb_points 702 ( 26 x 27 ) + nb_cores 2948 ( 44 x 67 ), nb_points 700 ( 35 x 20 ) + nb_cores 2964 ( 76 x 39 ), nb_points 693 ( 21 x 33 ) + nb_cores 3015 ( 45 x 67 ), nb_points 680 ( 34 x 20 ) + nb_cores 3060 ( 60 x 51 ), nb_points 676 ( 26 x 26 ) + nb_cores 3072 ( 48 x 64 ), nb_points 672 ( 32 x 21 ) + nb_cores 3105 ( 69 x 45 ), nb_points 667 ( 23 x 29 ) + nb_cores 3120 ( 80 x 39 ), nb_points 660 ( 20 x 33 ) + nb_cores 3180 ( 60 x 53 ), nb_points 650 ( 26 x 25 ) + nb_cores 3190 ( 58 x 55 ), nb_points 648 ( 27 x 24 ) + nb_cores 3195 ( 45 x 71 ), nb_points 646 ( 34 x 19 ) + nb_cores 3216 ( 48 x 67 ), nb_points 640 ( 32 x 20 ) + nb_cores 3240 ( 72 x 45 ), nb_points 638 ( 22 x 29 ) + nb_cores 3300 ( 60 x 55 ), nb_points 624 ( 26 x 24 ) + nb_cores 3350 ( 50 x 67 ), nb_points 620 ( 31 x 20 ) + nb_cores 3384 ( 72 x 47 ), nb_points 616 ( 22 x 28 ) + nb_cores 3408 ( 48 x 71 ), nb_points 608 ( 32 x 19 ) + nb_cores 3465 ( 63 x 55 ), nb_points 600 ( 25 x 24 ) + nb_cores 3480 ( 60 x 58 ), nb_points 598 ( 26 x 23 ) + nb_cores 3510 ( 90 x 39 ), nb_points 594 ( 18 x 33 ) + nb_cores 3550 ( 50 x 71 ), nb_points 589 ( 31 x 19 ) + nb_cores 3572 ( 76 x 47 ), nb_points 588 ( 21 x 28 ) + nb_cores 3600 ( 80 x 45 ), nb_points 580 ( 20 x 29 ) + nb_cores 3630 ( 66 x 55 ), nb_points 576 ( 24 x 24 ) + nb_cores 3654 ( 63 x 58 ), nb_points 575 ( 25 x 23 ) + nb_cores 3660 ( 60 x 61 ), nb_points 572 ( 26 x 22 ) + nb_cores 3692 ( 52 x 71 ), nb_points 570 ( 30 x 19 ) + nb_cores 3712 ( 58 x 64 ), nb_points 567 ( 27 x 21 ) + nb_cores 3744 ( 96 x 39 ), nb_points 561 ( 17 x 33 ) + nb_cores 3752 ( 56 x 67 ), nb_points 560 ( 28 x 20 ) + nb_cores 3780 ( 90 x 42 ), nb_points 558 ( 18 x 31 ) + nb_cores 3795 ( 69 x 55 ), nb_points 552 ( 23 x 24 ) + nb_cores 3816 ( 72 x 53 ), nb_points 550 ( 22 x 25 ) + nb_cores 3840 ( 60 x 64 ), nb_points 546 ( 26 x 21 ) + nb_cores 3886 ( 58 x 67 ), nb_points 540 ( 27 x 20 ) + nb_cores 3960 ( 72 x 55 ), nb_points 528 ( 22 x 24 ) + nb_cores 4020 ( 60 x 67 ), nb_points 520 ( 26 x 20 ) + nb_cores 4118 ( 58 x 71 ), nb_points 513 ( 27 x 19 ) + nb_cores 4176 ( 72 x 58 ), nb_points 506 ( 22 x 23 ) + nb_cores 4180 ( 76 x 55 ), nb_points 504 ( 21 x 24 ) + nb_cores 4221 ( 63 x 67 ), nb_points 500 ( 25 x 20 ) + nb_cores 4260 ( 60 x 71 ), nb_points 494 ( 26 x 19 ) + nb_cores 4320 ( 96 x 45 ), nb_points 493 ( 17 x 29 ) + nb_cores 4392 ( 72 x 61 ), nb_points 484 ( 22 x 22 ) + nb_cores 4400 ( 80 x 55 ), nb_points 480 ( 20 x 24 ) + nb_cores 4473 ( 63 x 71 ), nb_points 475 ( 25 x 19 ) + nb_cores 4560 ( 60 x 76 ), nb_points 468 ( 26 x 18 ) + nb_cores 4608 ( 72 x 64 ), nb_points 462 ( 22 x 21 ) + nb_cores 4623 ( 69 x 67 ), nb_points 460 ( 23 x 20 ) + nb_cores 4675 ( 85 x 55 ), nb_points 456 ( 19 x 24 ) + nb_cores 4770 ( 90 x 53 ), nb_points 450 ( 18 x 25 ) + nb_cores 4824 ( 72 x 67 ), nb_points 440 ( 22 x 20 ) + nb_cores 4899 ( 69 x 71 ), nb_points 437 ( 23 x 19 ) + nb_cores 4950 ( 90 x 55 ), nb_points 432 ( 18 x 24 ) + nb_cores 5088 ( 96 x 53 ), nb_points 425 ( 17 x 25 ) + nb_cores 5092 ( 76 x 67 ), nb_points 420 ( 21 x 20 ) + nb_cores 5112 ( 72 x 71 ), nb_points 418 ( 22 x 19 ) + nb_cores 5220 ( 90 x 58 ), nb_points 414 ( 18 x 23 ) + nb_cores 5280 ( 96 x 55 ), nb_points 408 ( 17 x 24 ) + nb_cores 5360 ( 80 x 67 ), nb_points 400 ( 20 x 20 ) + nb_cores 5396 ( 76 x 71 ), nb_points 399 ( 21 x 19 ) + nb_cores 5472 ( 72 x 76 ), nb_points 396 ( 22 x 18 ) + nb_cores 5568 ( 96 x 58 ), nb_points 391 ( 17 x 23 ) + nb_cores 5580 ( 60 x 93 ), nb_points 390 ( 26 x 15 ) + nb_cores 5665 ( 103 x 55 ), nb_points 384 ( 16 x 24 ) + nb_cores 5680 ( 80 x 71 ), nb_points 380 ( 20 x 19 ) + nb_cores 5760 ( 90 x 64 ), nb_points 378 ( 18 x 21 ) + nb_cores 5832 ( 72 x 81 ), nb_points 374 ( 22 x 17 ) + nb_cores 5974 ( 103 x 58 ), nb_points 368 ( 16 x 23 ) + nb_cores 6030 ( 90 x 67 ), nb_points 360 ( 18 x 20 ) + nb_cores 6144 ( 96 x 64 ), nb_points 357 ( 17 x 21 ) + nb_cores 6264 ( 72 x 87 ), nb_points 352 ( 22 x 16 ) + nb_cores 6360 ( 120 x 53 ), nb_points 350 ( 14 x 25 ) + nb_cores 6390 ( 90 x 71 ), nb_points 342 ( 18 x 19 ) + nb_cores 6432 ( 96 x 67 ), nb_points 340 ( 17 x 20 ) + nb_cores 6592 ( 103 x 64 ), nb_points 336 ( 16 x 21 ) + nb_cores 6696 ( 72 x 93 ), nb_points 330 ( 22 x 15 ) + nb_cores 6816 ( 96 x 71 ), nb_points 323 ( 17 x 19 ) + nb_cores 6901 ( 103 x 67 ), nb_points 320 ( 16 x 20 ) + nb_cores 7068 ( 76 x 93 ), nb_points 315 ( 21 x 15 ) + nb_cores 7205 ( 131 x 55 ), nb_points 312 ( 13 x 24 ) + nb_cores 7272 ( 72 x 101 ), nb_points 308 ( 22 x 14 ) + nb_cores 7290 ( 90 x 81 ), nb_points 306 ( 18 x 17 ) + nb_cores 7313 ( 103 x 71 ), nb_points 304 ( 16 x 19 ) + nb_cores 7437 ( 111 x 67 ), nb_points 300 ( 15 x 20 ) + nb_cores 7590 ( 69 x 110 ), nb_points 299 ( 23 x 13 ) + nb_cores 7676 ( 76 x 101 ), nb_points 294 ( 21 x 14 ) + nb_cores 7776 ( 96 x 81 ), nb_points 289 ( 17 x 17 ) + nb_cores 7828 ( 103 x 76 ), nb_points 288 ( 16 x 18 ) + nb_cores 7881 ( 111 x 71 ), nb_points 285 ( 15 x 19 ) + nb_cores 8040 ( 120 x 67 ), nb_points 280 ( 14 x 20 ) + nb_cores 8343 ( 103 x 81 ), nb_points 272 ( 16 x 17 ) + nb_cores 8370 ( 90 x 93 ), nb_points 270 ( 18 x 15 ) + nb_cores 8520 ( 120 x 71 ), nb_points 266 ( 14 x 19 ) + nb_cores 8712 ( 72 x 121 ), nb_points 264 ( 22 x 12 ) + nb_cores 8777 ( 131 x 67 ), nb_points 260 ( 13 x 20 ) + nb_cores 8928 ( 96 x 93 ), nb_points 255 ( 17 x 15 ) + nb_cores 9090 ( 90 x 101 ), nb_points 252 ( 18 x 14 ) + nb_cores 9301 ( 131 x 71 ), nb_points 247 ( 13 x 19 ) + nb_cores 9579 ( 103 x 93 ), nb_points 240 ( 16 x 15 ) + nb_cores 9696 ( 96 x 101 ), nb_points 238 ( 17 x 14 ) + nb_cores 9900 ( 90 x 110 ), nb_points 234 ( 18 x 13 ) + nb_cores 10184 ( 76 x 134 ), nb_points 231 ( 21 x 11 ) + nb_cores 10224 ( 144 x 71 ), nb_points 228 ( 12 x 19 ) + nb_cores 10323 ( 111 x 93 ), nb_points 225 ( 15 x 15 ) + nb_cores 10403 ( 103 x 101 ), nb_points 224 ( 16 x 14 ) + nb_cores 10560 ( 96 x 110 ), nb_points 221 ( 17 x 13 ) + nb_cores 10720 ( 80 x 134 ), nb_points 220 ( 20 x 11 ) + nb_cores 10720 ( 160 x 67 ), nb_points 220 ( 11 x 20 ) + nb_cores 10890 ( 90 x 121 ), nb_points 216 ( 18 x 12 ) + nb_cores 11160 ( 120 x 93 ), nb_points 210 ( 14 x 15 ) + nb_cores 11330 ( 103 x 110 ), nb_points 208 ( 16 x 13 ) + nb_cores 11616 ( 96 x 121 ), nb_points 204 ( 17 x 12 ) + nb_cores 12060 ( 90 x 134 ), nb_points 198 ( 18 x 11 ) + nb_cores 12120 ( 120 x 101 ), nb_points 196 ( 14 x 14 ) + nb_cores 12183 ( 131 x 93 ), nb_points 195 ( 13 x 15 ) + nb_cores 12463 ( 103 x 121 ), nb_points 192 ( 16 x 12 ) + nb_cores 12780 ( 180 x 71 ), nb_points 190 ( 10 x 19 ) + nb_cores 12864 ( 96 x 134 ), nb_points 187 ( 17 x 11 ) + nb_cores 13200 ( 120 x 110 ), nb_points 182 ( 14 x 13 ) + nb_cores 13392 ( 144 x 93 ), nb_points 180 ( 12 x 15 ) + nb_cores 13802 ( 103 x 134 ), nb_points 176 ( 16 x 11 ) + nb_cores 14410 ( 131 x 110 ), nb_points 169 ( 13 x 13 ) + nb_cores 14520 ( 120 x 121 ), nb_points 168 ( 14 x 12 ) + nb_cores 14874 ( 111 x 134 ), nb_points 165 ( 15 x 11 ) + nb_cores 15553 ( 103 x 151 ), nb_points 160 ( 16 x 10 ) + nb_cores 15840 ( 144 x 110 ), nb_points 156 ( 12 x 13 ) + nb_cores 16080 ( 120 x 134 ), nb_points 154 ( 14 x 11 ) + nb_cores 16608 ( 96 x 173 ), nb_points 153 ( 17 x 9 ) + nb_cores 16740 ( 180 x 93 ), nb_points 150 ( 10 x 15 ) + nb_cores 17424 ( 144 x 121 ), nb_points 144 ( 12 x 12 ) + nb_cores 17554 ( 131 x 134 ), nb_points 143 ( 13 x 11 ) + nb_cores 18120 ( 120 x 151 ), nb_points 140 ( 14 x 10 ) + nb_cores 19158 ( 206 x 93 ), nb_points 135 ( 9 x 15 ) + nb_cores 19296 ( 144 x 134 ), nb_points 132 ( 12 x 11 ) + nb_cores 19781 ( 131 x 151 ), nb_points 130 ( 13 x 10 ) + nb_cores 20703 ( 103 x 201 ), nb_points 128 ( 16 x 8 ) + nb_cores 20760 ( 120 x 173 ), nb_points 126 ( 14 x 9 ) + nb_cores 21440 ( 160 x 134 ), nb_points 121 ( 11 x 11 ) + nb_cores 21744 ( 144 x 151 ), nb_points 120 ( 12 x 10 ) + nb_cores 22660 ( 206 x 110 ), nb_points 117 ( 9 x 13 ) + nb_cores 24120 ( 180 x 134 ), nb_points 110 ( 10 x 11 ) + nb_cores 24912 ( 144 x 173 ), nb_points 108 ( 12 x 9 ) + nb_cores 26331 ( 131 x 201 ), nb_points 104 ( 13 x 8 ) + nb_cores 27180 ( 180 x 151 ), nb_points 100 ( 10 x 10 ) + nb_cores 27604 ( 206 x 134 ), nb_points 99 ( 9 x 11 ) + nb_cores 28920 ( 120 x 241 ), nb_points 98 ( 14 x 7 ) + nb_cores 28944 ( 144 x 201 ), nb_points 96 ( 12 x 8 ) + nb_cores 31106 ( 206 x 151 ), nb_points 90 ( 9 x 10 ) + nb_cores 32160 ( 240 x 134 ), nb_points 88 ( 8 x 11 ) + nb_cores 32160 ( 160 x 201 ), nb_points 88 ( 11 x 8 ) + nb_cores 34704 ( 144 x 241 ), nb_points 84 ( 12 x 7 ) + nb_cores 35638 ( 206 x 173 ), nb_points 81 ( 9 x 9 ) + nb_cores 36180 ( 180 x 201 ), nb_points 80 ( 10 x 8 ) + nb_cores 38560 ( 160 x 241 ), nb_points 77 ( 11 x 7 ) + nb_cores 41406 ( 206 x 201 ), nb_points 72 ( 9 x 8 ) + nb_cores 43380 ( 180 x 241 ), nb_points 70 ( 10 x 7 ) + nb_cores 48240 ( 240 x 201 ), nb_points 64 ( 8 x 8 ) + nb_cores 49646 ( 206 x 241 ), nb_points 63 ( 9 x 7 ) + nb_cores 54360 ( 180 x 302 ), nb_points 60 ( 10 x 6 ) + nb_cores 54360 ( 360 x 151 ), nb_points 60 ( 6 x 10 ) + nb_cores 57840 ( 240 x 241 ), nb_points 56 ( 8 x 7 ) + nb_cores 62212 ( 206 x 302 ), nb_points 54 ( 9 x 6 ) + nb_cores 69408 ( 288 x 241 ), nb_points 49 ( 7 x 7 ) + nb_cores 72360 ( 360 x 201 ), nb_points 48 ( 6 x 8 ) + nb_cores 82812 ( 206 x 402 ), nb_points 45 ( 9 x 5 ) + nb_cores 86760 ( 360 x 241 ), nb_points 42 ( 6 x 7 ) + nb_cores 96480 ( 240 x 402 ), nb_points 40 ( 8 x 5 ) + nb_cores 96480 ( 480 x 201 ), nb_points 40 ( 5 x 8 ) diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca1 b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca1 new file mode 100644 index 0000000000000000000000000000000000000000..6845b05c8e21fe864bab4c12017222bf02f8ae5c --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca1 @@ -0,0 +1,205 @@ + nb_cores 1 ( 1 x 1 ), nb_points 120184 ( 362 x 332 ) + nb_cores 2 ( 2 x 1 ), nb_points 60424 ( 182 x 332 ) + nb_cores 3 ( 3 x 1 ), nb_points 40504 ( 122 x 332 ) + nb_cores 4 ( 2 x 2 ), nb_points 30394 ( 182 x 167 ) + nb_cores 5 ( 5 x 1 ), nb_points 24568 ( 74 x 332 ) + nb_cores 6 ( 3 x 2 ), nb_points 20374 ( 122 x 167 ) + nb_cores 7 ( 7 x 1 ), nb_points 17928 ( 54 x 332 ) + nb_cores 8 ( 4 x 2 ), nb_points 15364 ( 92 x 167 ) + nb_cores 9 ( 3 x 3 ), nb_points 13664 ( 122 x 112 ) + nb_cores 10 ( 5 x 2 ), nb_points 12358 ( 74 x 167 ) + nb_cores 11 ( 1 x 11 ), nb_points 11584 ( 362 x 32 ) + nb_cores 12 ( 4 x 3 ), nb_points 10304 ( 92 x 112 ) + nb_cores 13 ( 13 x 1 ), nb_points 9960 ( 30 x 332 ) + nb_cores 14 ( 7 x 2 ), nb_points 9018 ( 54 x 167 ) + nb_cores 15 ( 5 x 3 ), nb_points 8288 ( 74 x 112 ) + nb_cores 16 ( 4 x 4 ), nb_points 7820 ( 92 x 85 ) + nb_cores 18 ( 6 x 3 ), nb_points 6944 ( 62 x 112 ) + nb_cores 20 ( 4 x 5 ), nb_points 6256 ( 92 x 68 ) + nb_cores 21 ( 7 x 3 ), nb_points 6048 ( 54 x 112 ) + nb_cores 22 ( 2 x 11 ), nb_points 5824 ( 182 x 32 ) + nb_cores 24 ( 4 x 6 ), nb_points 5244 ( 92 x 57 ) + nb_cores 25 ( 5 x 5 ), nb_points 5032 ( 74 x 68 ) + nb_cores 26 ( 13 x 2 ), nb_points 5010 ( 30 x 167 ) + nb_cores 27 ( 9 x 3 ), nb_points 4704 ( 42 x 112 ) + nb_cores 28 ( 7 x 4 ), nb_points 4590 ( 54 x 85 ) + nb_cores 30 ( 6 x 5 ), nb_points 4216 ( 62 x 68 ) + nb_cores 32 ( 8 x 4 ), nb_points 3995 ( 47 x 85 ) + nb_cores 33 ( 3 x 11 ), nb_points 3904 ( 122 x 32 ) + nb_cores 35 ( 7 x 5 ), nb_points 3672 ( 54 x 68 ) + nb_cores 36 ( 6 x 6 ), nb_points 3534 ( 62 x 57 ) + nb_cores 38 ( 19 x 2 ), nb_points 3507 ( 21 x 167 ) + nb_cores 39 ( 13 x 3 ), nb_points 3360 ( 30 x 112 ) + nb_cores 40 ( 8 x 5 ), nb_points 3196 ( 47 x 68 ) + nb_cores 42 ( 7 x 6 ), nb_points 3078 ( 54 x 57 ) + nb_cores 44 ( 4 x 11 ), nb_points 2944 ( 92 x 32 ) + nb_cores 45 ( 9 x 5 ), nb_points 2856 ( 42 x 68 ) + nb_cores 48 ( 8 x 6 ), nb_points 2679 ( 47 x 57 ) + nb_cores 50 ( 10 x 5 ), nb_points 2584 ( 38 x 68 ) + nb_cores 52 ( 13 x 4 ), nb_points 2550 ( 30 x 85 ) + nb_cores 54 ( 9 x 6 ), nb_points 2394 ( 42 x 57 ) + nb_cores 55 ( 5 x 11 ), nb_points 2368 ( 74 x 32 ) + nb_cores 56 ( 8 x 7 ), nb_points 2350 ( 47 x 50 ) + nb_cores 60 ( 10 x 6 ), nb_points 2166 ( 38 x 57 ) + nb_cores 63 ( 9 x 7 ), nb_points 2100 ( 42 x 50 ) + nb_cores 64 ( 8 x 8 ), nb_points 2068 ( 47 x 44 ) + nb_cores 65 ( 13 x 5 ), nb_points 2040 ( 30 x 68 ) + nb_cores 66 ( 6 x 11 ), nb_points 1984 ( 62 x 32 ) + nb_cores 70 ( 7 x 10 ), nb_points 1890 ( 54 x 35 ) + nb_cores 72 ( 12 x 6 ), nb_points 1824 ( 32 x 57 ) + nb_cores 75 ( 15 x 5 ), nb_points 1768 ( 26 x 68 ) + nb_cores 77 ( 7 x 11 ), nb_points 1728 ( 54 x 32 ) + nb_cores 78 ( 13 x 6 ), nb_points 1710 ( 30 x 57 ) + nb_cores 80 ( 8 x 10 ), nb_points 1645 ( 47 x 35 ) + nb_cores 81 ( 9 x 9 ), nb_points 1638 ( 42 x 39 ) + nb_cores 84 ( 14 x 6 ), nb_points 1596 ( 28 x 57 ) + nb_cores 88 ( 8 x 11 ), nb_points 1504 ( 47 x 32 ) + nb_cores 90 ( 9 x 10 ), nb_points 1470 ( 42 x 35 ) + nb_cores 95 ( 19 x 5 ), nb_points 1428 ( 21 x 68 ) + nb_cores 96 ( 12 x 8 ), nb_points 1408 ( 32 x 44 ) + nb_cores 98 ( 14 x 7 ), nb_points 1400 ( 28 x 50 ) + nb_cores 99 ( 9 x 11 ), nb_points 1344 ( 42 x 32 ) + nb_cores 100 ( 10 x 10 ), nb_points 1330 ( 38 x 35 ) + nb_cores 104 ( 8 x 13 ), nb_points 1316 ( 47 x 28 ) + nb_cores 105 ( 7 x 15 ), nb_points 1296 ( 54 x 24 ) + nb_cores 108 ( 12 x 9 ), nb_points 1248 ( 32 x 39 ) + nb_cores 110 ( 10 x 11 ), nb_points 1216 ( 38 x 32 ) + nb_cores 114 ( 19 x 6 ), nb_points 1197 ( 21 x 57 ) + nb_cores 117 ( 13 x 9 ), nb_points 1170 ( 30 x 39 ) + nb_cores 120 ( 12 x 10 ), nb_points 1120 ( 32 x 35 ) + nb_cores 126 ( 9 x 14 ), nb_points 1092 ( 42 x 26 ) + nb_cores 126 ( 14 x 9 ), nb_points 1092 ( 28 x 39 ) + nb_cores 128 ( 8 x 16 ), nb_points 1081 ( 47 x 23 ) + nb_cores 130 ( 13 x 10 ), nb_points 1050 ( 30 x 35 ) + nb_cores 132 ( 12 x 11 ), nb_points 1024 ( 32 x 32 ) + nb_cores 135 ( 9 x 15 ), nb_points 1008 ( 42 x 24 ) + nb_cores 140 ( 14 x 10 ), nb_points 980 ( 28 x 35 ) + nb_cores 143 ( 13 x 11 ), nb_points 960 ( 30 x 32 ) + nb_cores 150 ( 15 x 10 ), nb_points 910 ( 26 x 35 ) + nb_cores 154 ( 14 x 11 ), nb_points 896 ( 28 x 32 ) + nb_cores 160 ( 10 x 16 ), nb_points 874 ( 38 x 23 ) + nb_cores 162 ( 18 x 9 ), nb_points 858 ( 22 x 39 ) + nb_cores 165 ( 15 x 11 ), nb_points 832 ( 26 x 32 ) + nb_cores 171 ( 19 x 9 ), nb_points 819 ( 21 x 39 ) + nb_cores 176 ( 8 x 22 ), nb_points 799 ( 47 x 17 ) + nb_cores 180 ( 12 x 15 ), nb_points 768 ( 32 x 24 ) + nb_cores 189 ( 9 x 21 ), nb_points 756 ( 42 x 18 ) + nb_cores 190 ( 19 x 10 ), nb_points 735 ( 21 x 35 ) + nb_cores 195 ( 13 x 15 ), nb_points 720 ( 30 x 24 ) + nb_cores 198 ( 18 x 11 ), nb_points 704 ( 22 x 32 ) + nb_cores 200 ( 20 x 10 ), nb_points 700 ( 20 x 35 ) + nb_cores 208 ( 13 x 16 ), nb_points 690 ( 30 x 23 ) + nb_cores 209 ( 19 x 11 ), nb_points 672 ( 21 x 32 ) + nb_cores 216 ( 18 x 12 ), nb_points 660 ( 22 x 30 ) + nb_cores 220 ( 20 x 11 ), nb_points 640 ( 20 x 32 ) + nb_cores 225 ( 15 x 15 ), nb_points 624 ( 26 x 24 ) + nb_cores 234 ( 18 x 13 ), nb_points 616 ( 22 x 28 ) + nb_cores 240 ( 24 x 10 ), nb_points 595 ( 17 x 35 ) + nb_cores 247 ( 19 x 13 ), nb_points 588 ( 21 x 28 ) + nb_cores 252 ( 18 x 14 ), nb_points 572 ( 22 x 26 ) + nb_cores 260 ( 20 x 13 ), nb_points 560 ( 20 x 28 ) + nb_cores 260 ( 26 x 10 ), nb_points 560 ( 16 x 35 ) + nb_cores 264 ( 12 x 22 ), nb_points 544 ( 32 x 17 ) + nb_cores 264 ( 24 x 11 ), nb_points 544 ( 17 x 32 ) + nb_cores 270 ( 18 x 15 ), nb_points 528 ( 22 x 24 ) + nb_cores 280 ( 20 x 14 ), nb_points 520 ( 20 x 26 ) + nb_cores 285 ( 19 x 15 ), nb_points 504 ( 21 x 24 ) + nb_cores 300 ( 20 x 15 ), nb_points 480 ( 20 x 24 ) + nb_cores 308 ( 14 x 22 ), nb_points 476 ( 28 x 17 ) + nb_cores 315 ( 15 x 21 ), nb_points 468 ( 26 x 18 ) + nb_cores 320 ( 20 x 16 ), nb_points 460 ( 20 x 23 ) + nb_cores 330 ( 15 x 22 ), nb_points 442 ( 26 x 17 ) + nb_cores 340 ( 20 x 17 ), nb_points 440 ( 20 x 22 ) + nb_cores 345 ( 23 x 15 ), nb_points 432 ( 18 x 24 ) + nb_cores 352 ( 16 x 22 ), nb_points 425 ( 25 x 17 ) + nb_cores 360 ( 24 x 15 ), nb_points 408 ( 17 x 24 ) + nb_cores 378 ( 18 x 21 ), nb_points 396 ( 22 x 18 ) + nb_cores 384 ( 24 x 16 ), nb_points 391 ( 17 x 23 ) + nb_cores 390 ( 26 x 15 ), nb_points 384 ( 16 x 24 ) + nb_cores 396 ( 18 x 22 ), nb_points 374 ( 22 x 17 ) + nb_cores 416 ( 26 x 16 ), nb_points 368 ( 16 x 23 ) + nb_cores 418 ( 19 x 22 ), nb_points 357 ( 21 x 17 ) + nb_cores 432 ( 18 x 24 ), nb_points 352 ( 22 x 16 ) + nb_cores 440 ( 20 x 22 ), nb_points 340 ( 20 x 17 ) + nb_cores 450 ( 30 x 15 ), nb_points 336 ( 14 x 24 ) + nb_cores 468 ( 18 x 26 ), nb_points 330 ( 22 x 15 ) + nb_cores 480 ( 20 x 24 ), nb_points 320 ( 20 x 16 ) + nb_cores 494 ( 19 x 26 ), nb_points 315 ( 21 x 15 ) + nb_cores 495 ( 15 x 33 ), nb_points 312 ( 26 x 12 ) + nb_cores 495 ( 33 x 15 ), nb_points 312 ( 13 x 24 ) + nb_cores 504 ( 24 x 21 ), nb_points 306 ( 17 x 18 ) + nb_cores 520 ( 20 x 26 ), nb_points 300 ( 20 x 15 ) + nb_cores 528 ( 24 x 22 ), nb_points 289 ( 17 x 17 ) + nb_cores 540 ( 18 x 30 ), nb_points 286 ( 22 x 13 ) + nb_cores 560 ( 20 x 28 ), nb_points 280 ( 20 x 14 ) + nb_cores 570 ( 19 x 30 ), nb_points 273 ( 21 x 13 ) + nb_cores 572 ( 26 x 22 ), nb_points 272 ( 16 x 17 ) + nb_cores 588 ( 28 x 21 ), nb_points 270 ( 15 x 18 ) + nb_cores 594 ( 18 x 33 ), nb_points 264 ( 22 x 12 ) + nb_cores 600 ( 20 x 30 ), nb_points 260 ( 20 x 13 ) + nb_cores 616 ( 28 x 22 ), nb_points 255 ( 15 x 17 ) + nb_cores 627 ( 19 x 33 ), nb_points 252 ( 21 x 12 ) + nb_cores 660 ( 30 x 22 ), nb_points 238 ( 14 x 17 ) + nb_cores 690 ( 23 x 30 ), nb_points 234 ( 18 x 13 ) + nb_cores 703 ( 19 x 37 ), nb_points 231 ( 21 x 11 ) + nb_cores 720 ( 24 x 30 ), nb_points 221 ( 17 x 13 ) + nb_cores 740 ( 20 x 37 ), nb_points 220 ( 20 x 11 ) + nb_cores 756 ( 36 x 21 ), nb_points 216 ( 12 x 18 ) + nb_cores 780 ( 26 x 30 ), nb_points 208 ( 16 x 13 ) + nb_cores 792 ( 36 x 22 ), nb_points 204 ( 12 x 17 ) + nb_cores 792 ( 24 x 33 ), nb_points 204 ( 17 x 12 ) + nb_cores 840 ( 28 x 30 ), nb_points 195 ( 15 x 13 ) + nb_cores 858 ( 26 x 33 ), nb_points 192 ( 16 x 12 ) + nb_cores 880 ( 40 x 22 ), nb_points 187 ( 11 x 17 ) + nb_cores 900 ( 30 x 30 ), nb_points 182 ( 14 x 13 ) + nb_cores 924 ( 28 x 33 ), nb_points 180 ( 15 x 12 ) + nb_cores 960 ( 40 x 24 ), nb_points 176 ( 11 x 16 ) + nb_cores 990 ( 30 x 33 ), nb_points 168 ( 14 x 12 ) + nb_cores 1036 ( 28 x 37 ), nb_points 165 ( 15 x 11 ) + nb_cores 1080 ( 36 x 30 ), nb_points 156 ( 12 x 13 ) + nb_cores 1110 ( 30 x 37 ), nb_points 154 ( 14 x 11 ) + nb_cores 1144 ( 52 x 22 ), nb_points 153 ( 9 x 17 ) + nb_cores 1170 ( 45 x 26 ), nb_points 150 ( 10 x 15 ) + nb_cores 1188 ( 36 x 33 ), nb_points 144 ( 12 x 12 ) + nb_cores 1200 ( 40 x 30 ), nb_points 143 ( 11 x 13 ) + nb_cores 1260 ( 30 x 42 ), nb_points 140 ( 14 x 10 ) + nb_cores 1260 ( 45 x 28 ), nb_points 140 ( 10 x 14 ) + nb_cores 1320 ( 40 x 33 ), nb_points 132 ( 11 x 12 ) + nb_cores 1350 ( 45 x 30 ), nb_points 130 ( 10 x 13 ) + nb_cores 1430 ( 26 x 55 ), nb_points 128 ( 16 x 8 ) + nb_cores 1440 ( 30 x 48 ), nb_points 126 ( 14 x 9 ) + nb_cores 1480 ( 40 x 37 ), nb_points 121 ( 11 x 11 ) + nb_cores 1485 ( 45 x 33 ), nb_points 120 ( 10 x 12 ) + nb_cores 1560 ( 52 x 30 ), nb_points 117 ( 9 x 13 ) + nb_cores 1650 ( 30 x 55 ), nb_points 112 ( 14 x 8 ) + nb_cores 1665 ( 45 x 37 ), nb_points 110 ( 10 x 11 ) + nb_cores 1716 ( 52 x 33 ), nb_points 108 ( 9 x 12 ) + nb_cores 1800 ( 60 x 30 ), nb_points 104 ( 8 x 13 ) + nb_cores 1890 ( 45 x 42 ), nb_points 100 ( 10 x 10 ) + nb_cores 1920 ( 40 x 48 ), nb_points 99 ( 11 x 9 ) + nb_cores 1980 ( 60 x 33 ), nb_points 96 ( 8 x 12 ) + nb_cores 1980 ( 36 x 55 ), nb_points 96 ( 12 x 8 ) + nb_cores 2160 ( 45 x 48 ), nb_points 90 ( 10 x 9 ) + nb_cores 2200 ( 40 x 55 ), nb_points 88 ( 11 x 8 ) + nb_cores 2376 ( 72 x 33 ), nb_points 84 ( 7 x 12 ) + nb_cores 2376 ( 36 x 66 ), nb_points 84 ( 12 x 7 ) + nb_cores 2475 ( 45 x 55 ), nb_points 80 ( 10 x 8 ) + nb_cores 2640 ( 40 x 66 ), nb_points 77 ( 11 x 7 ) + nb_cores 2860 ( 52 x 55 ), nb_points 72 ( 9 x 8 ) + nb_cores 2970 ( 45 x 66 ), nb_points 70 ( 10 x 7 ) + nb_cores 3300 ( 60 x 55 ), nb_points 64 ( 8 x 8 ) + nb_cores 3432 ( 52 x 66 ), nb_points 63 ( 9 x 7 ) + nb_cores 3735 ( 45 x 83 ), nb_points 60 ( 10 x 6 ) + nb_cores 3960 ( 60 x 66 ), nb_points 56 ( 8 x 7 ) + nb_cores 3960 ( 72 x 55 ), nb_points 56 ( 7 x 8 ) + nb_cores 4316 ( 52 x 83 ), nb_points 54 ( 9 x 6 ) + nb_cores 4752 ( 72 x 66 ), nb_points 49 ( 7 x 7 ) + nb_cores 4950 ( 90 x 55 ), nb_points 48 ( 6 x 8 ) + nb_cores 5720 ( 52 x 110 ), nb_points 45 ( 9 x 5 ) + nb_cores 5940 ( 90 x 66 ), nb_points 42 ( 6 x 7 ) + nb_cores 6600 ( 120 x 55 ), nb_points 40 ( 5 x 8 ) + nb_cores 6600 ( 60 x 110 ), nb_points 40 ( 8 x 5 ) + nb_cores 7470 ( 90 x 83 ), nb_points 36 ( 6 x 6 ) + nb_cores 7920 ( 72 x 110 ), nb_points 35 ( 7 x 5 ) + nb_cores 7920 ( 120 x 66 ), nb_points 35 ( 5 x 7 ) + nb_cores 9900 ( 90 x 110 ), nb_points 30 ( 6 x 5 ) diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca12 b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca12 new file mode 100644 index 0000000000000000000000000000000000000000..aad100b9fbdf994f8393402ccefec9eeb16c2009 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/best_jpni_jpnj_eorca12 @@ -0,0 +1,1348 @@ + nb_cores 1 ( 1 x 1 ), nb_points 13601334 ( 4322 x 3147 ) + nb_cores 2 ( 2 x 1 ), nb_points 6803814 ( 2162 x 3147 ) + nb_cores 3 ( 3 x 1 ), nb_points 4537974 ( 1442 x 3147 ) + nb_cores 4 ( 4 x 1 ), nb_points 3405054 ( 1082 x 3147 ) + nb_cores 5 ( 5 x 1 ), nb_points 2725302 ( 866 x 3147 ) + nb_cores 6 ( 3 x 2 ), nb_points 2271150 ( 1442 x 1575 ) + nb_cores 7 ( 7 x 1 ), nb_points 1951140 ( 620 x 3147 ) + nb_cores 8 ( 4 x 2 ), nb_points 1704150 ( 1082 x 1575 ) + nb_cores 9 ( 3 x 3 ), nb_points 1515542 ( 1442 x 1051 ) + nb_cores 10 ( 5 x 2 ), nb_points 1363950 ( 866 x 1575 ) + nb_cores 11 ( 11 x 1 ), nb_points 1243065 ( 395 x 3147 ) + nb_cores 12 ( 6 x 2 ), nb_points 1137150 ( 722 x 1575 ) + nb_cores 13 ( 13 x 1 ), nb_points 1054245 ( 335 x 3147 ) + nb_cores 14 ( 7 x 2 ), nb_points 976500 ( 620 x 1575 ) + nb_cores 15 ( 3 x 5 ), nb_points 909902 ( 1442 x 631 ) + nb_cores 16 ( 8 x 2 ), nb_points 853650 ( 542 x 1575 ) + nb_cores 17 ( 1 x 17 ), nb_points 808214 ( 4322 x 187 ) + nb_cores 18 ( 6 x 3 ), nb_points 758822 ( 722 x 1051 ) + nb_cores 19 ( 19 x 1 ), nb_points 723810 ( 230 x 3147 ) + nb_cores 20 ( 4 x 5 ), nb_points 682742 ( 1082 x 631 ) + nb_cores 21 ( 7 x 3 ), nb_points 651620 ( 620 x 1051 ) + nb_cores 22 ( 11 x 2 ), nb_points 622125 ( 395 x 1575 ) + nb_cores 23 ( 23 x 1 ), nb_points 597930 ( 190 x 3147 ) + nb_cores 24 ( 8 x 3 ), nb_points 569642 ( 542 x 1051 ) + nb_cores 25 ( 5 x 5 ), nb_points 546446 ( 866 x 631 ) + nb_cores 26 ( 2 x 13 ), nb_points 527528 ( 2162 x 244 ) + nb_cores 27 ( 9 x 3 ), nb_points 506582 ( 482 x 1051 ) + nb_cores 28 ( 4 x 7 ), nb_points 489064 ( 1082 x 452 ) + nb_cores 29 ( 29 x 1 ), nb_points 475197 ( 151 x 3147 ) + nb_cores 30 ( 6 x 5 ), nb_points 455582 ( 722 x 631 ) + nb_cores 31 ( 31 x 1 ), nb_points 446874 ( 142 x 3147 ) + nb_cores 32 ( 8 x 4 ), nb_points 427638 ( 542 x 789 ) + nb_cores 33 ( 11 x 3 ), nb_points 415145 ( 395 x 1051 ) + nb_cores 34 ( 2 x 17 ), nb_points 404294 ( 2162 x 187 ) + nb_cores 35 ( 7 x 5 ), nb_points 391220 ( 620 x 631 ) + nb_cores 36 ( 9 x 4 ), nb_points 380298 ( 482 x 789 ) + nb_cores 37 ( 37 x 1 ), nb_points 374493 ( 119 x 3147 ) + nb_cores 38 ( 19 x 2 ), nb_points 362250 ( 230 x 1575 ) + nb_cores 39 ( 3 x 13 ), nb_points 351848 ( 1442 x 244 ) + nb_cores 40 ( 8 x 5 ), nb_points 342002 ( 542 x 631 ) + nb_cores 41 ( 41 x 1 ), nb_points 339876 ( 108 x 3147 ) + nb_cores 42 ( 6 x 7 ), nb_points 326344 ( 722 x 452 ) + nb_cores 43 ( 43 x 1 ), nb_points 324141 ( 103 x 3147 ) + nb_cores 44 ( 4 x 11 ), nb_points 311616 ( 1082 x 288 ) + nb_cores 45 ( 9 x 5 ), nb_points 304142 ( 482 x 631 ) + nb_cores 46 ( 23 x 2 ), nb_points 299250 ( 190 x 1575 ) + nb_cores 47 ( 47 x 1 ), nb_points 295818 ( 94 x 3147 ) + nb_cores 48 ( 12 x 4 ), nb_points 285618 ( 362 x 789 ) + nb_cores 49 ( 7 x 7 ), nb_points 280240 ( 620 x 452 ) + nb_cores 50 ( 10 x 5 ), nb_points 273854 ( 434 x 631 ) + nb_cores 51 ( 3 x 17 ), nb_points 269654 ( 1442 x 187 ) + nb_cores 52 ( 4 x 13 ), nb_points 264008 ( 1082 x 244 ) + nb_cores 54 ( 9 x 6 ), nb_points 254014 ( 482 x 527 ) + nb_cores 55 ( 11 x 5 ), nb_points 249245 ( 395 x 631 ) + nb_cores 56 ( 8 x 7 ), nb_points 244984 ( 542 x 452 ) + nb_cores 57 ( 19 x 3 ), nb_points 241730 ( 230 x 1051 ) + nb_cores 58 ( 29 x 2 ), nb_points 237825 ( 151 x 1575 ) + nb_cores 60 ( 12 x 5 ), nb_points 228422 ( 362 x 631 ) + nb_cores 62 ( 31 x 2 ), nb_points 223650 ( 142 x 1575 ) + nb_cores 63 ( 9 x 7 ), nb_points 217864 ( 482 x 452 ) + nb_cores 64 ( 16 x 4 ), nb_points 214608 ( 272 x 789 ) + nb_cores 65 ( 5 x 13 ), nb_points 211304 ( 866 x 244 ) + nb_cores 66 ( 6 x 11 ), nb_points 207936 ( 722 x 288 ) + nb_cores 68 ( 4 x 17 ), nb_points 202334 ( 1082 x 187 ) + nb_cores 69 ( 23 x 3 ), nb_points 199690 ( 190 x 1051 ) + nb_cores 70 ( 10 x 7 ), nb_points 196168 ( 434 x 452 ) + nb_cores 72 ( 12 x 6 ), nb_points 190774 ( 362 x 527 ) + nb_cores 74 ( 37 x 2 ), nb_points 187425 ( 119 x 1575 ) + nb_cores 75 ( 15 x 5 ), nb_points 182990 ( 290 x 631 ) + nb_cores 76 ( 19 x 4 ), nb_points 181470 ( 230 x 789 ) + nb_cores 77 ( 11 x 7 ), nb_points 178540 ( 395 x 452 ) + nb_cores 78 ( 6 x 13 ), nb_points 176168 ( 722 x 244 ) + nb_cores 80 ( 16 x 5 ), nb_points 171632 ( 272 x 631 ) + nb_cores 81 ( 9 x 9 ), nb_points 169664 ( 482 x 352 ) + nb_cores 84 ( 12 x 7 ), nb_points 163624 ( 362 x 452 ) + nb_cores 85 ( 5 x 17 ), nb_points 161942 ( 866 x 187 ) + nb_cores 87 ( 29 x 3 ), nb_points 158701 ( 151 x 1051 ) + nb_cores 88 ( 8 x 11 ), nb_points 156096 ( 542 x 288 ) + nb_cores 90 ( 18 x 5 ), nb_points 152702 ( 242 x 631 ) + nb_cores 91 ( 7 x 13 ), nb_points 151280 ( 620 x 244 ) + nb_cores 92 ( 23 x 4 ), nb_points 149910 ( 190 x 789 ) + nb_cores 93 ( 31 x 3 ), nb_points 149242 ( 142 x 1051 ) + nb_cores 94 ( 47 x 2 ), nb_points 148050 ( 94 x 1575 ) + nb_cores 95 ( 19 x 5 ), nb_points 145130 ( 230 x 631 ) + nb_cores 96 ( 16 x 6 ), nb_points 143344 ( 272 x 527 ) + nb_cores 98 ( 14 x 7 ), nb_points 140572 ( 311 x 452 ) + nb_cores 99 ( 9 x 11 ), nb_points 138816 ( 482 x 288 ) + nb_cores 100 ( 20 x 5 ), nb_points 137558 ( 218 x 631 ) + nb_cores 102 ( 6 x 17 ), nb_points 135014 ( 722 x 187 ) + nb_cores 104 ( 8 x 13 ), nb_points 132248 ( 542 x 244 ) + nb_cores 105 ( 15 x 7 ), nb_points 131080 ( 290 x 452 ) + nb_cores 108 ( 12 x 9 ), nb_points 127424 ( 362 x 352 ) + nb_cores 110 ( 10 x 11 ), nb_points 124992 ( 434 x 288 ) + nb_cores 112 ( 16 x 7 ), nb_points 122944 ( 272 x 452 ) + nb_cores 114 ( 19 x 6 ), nb_points 121210 ( 230 x 527 ) + nb_cores 115 ( 23 x 5 ), nb_points 119890 ( 190 x 631 ) + nb_cores 116 ( 29 x 4 ), nb_points 119139 ( 151 x 789 ) + nb_cores 117 ( 9 x 13 ), nb_points 117608 ( 482 x 244 ) + nb_cores 119 ( 7 x 17 ), nb_points 115940 ( 620 x 187 ) + nb_cores 120 ( 12 x 10 ), nb_points 114754 ( 362 x 317 ) + nb_cores 121 ( 11 x 11 ), nb_points 113760 ( 395 x 288 ) + nb_cores 123 ( 41 x 3 ), nb_points 113508 ( 108 x 1051 ) + nb_cores 124 ( 31 x 4 ), nb_points 112038 ( 142 x 789 ) + nb_cores 125 ( 25 x 5 ), nb_points 110425 ( 175 x 631 ) + nb_cores 126 ( 18 x 7 ), nb_points 109384 ( 242 x 452 ) + nb_cores 128 ( 16 x 8 ), nb_points 107712 ( 272 x 396 ) + nb_cores 130 ( 10 x 13 ), nb_points 105896 ( 434 x 244 ) + nb_cores 132 ( 12 x 11 ), nb_points 104256 ( 362 x 288 ) + nb_cores 133 ( 19 x 7 ), nb_points 103960 ( 230 x 452 ) + nb_cores 135 ( 15 x 9 ), nb_points 102080 ( 290 x 352 ) + nb_cores 136 ( 8 x 17 ), nb_points 101354 ( 542 x 187 ) + nb_cores 138 ( 23 x 6 ), nb_points 100130 ( 190 x 527 ) + nb_cores 140 ( 10 x 14 ), nb_points 98518 ( 434 x 227 ) + nb_cores 143 ( 11 x 13 ), nb_points 96380 ( 395 x 244 ) + nb_cores 144 ( 16 x 9 ), nb_points 95744 ( 272 x 352 ) + nb_cores 145 ( 29 x 5 ), nb_points 95281 ( 151 x 631 ) + nb_cores 147 ( 21 x 7 ), nb_points 94016 ( 208 x 452 ) + nb_cores 148 ( 37 x 4 ), nb_points 93891 ( 119 x 789 ) + nb_cores 150 ( 15 x 10 ), nb_points 91930 ( 290 x 317 ) + nb_cores 152 ( 8 x 19 ), nb_points 91056 ( 542 x 168 ) + nb_cores 153 ( 9 x 17 ), nb_points 90134 ( 482 x 187 ) + nb_cores 154 ( 14 x 11 ), nb_points 89568 ( 311 x 288 ) + nb_cores 156 ( 12 x 13 ), nb_points 88328 ( 362 x 244 ) + nb_cores 159 ( 53 x 3 ), nb_points 88284 ( 84 x 1051 ) + nb_cores 160 ( 16 x 10 ), nb_points 86224 ( 272 x 317 ) + nb_cores 161 ( 23 x 7 ), nb_points 85880 ( 190 x 452 ) + nb_cores 162 ( 18 x 9 ), nb_points 85184 ( 242 x 352 ) + nb_cores 165 ( 15 x 11 ), nb_points 83520 ( 290 x 288 ) + nb_cores 168 ( 12 x 14 ), nb_points 82174 ( 362 x 227 ) + nb_cores 169 ( 13 x 13 ), nb_points 81740 ( 335 x 244 ) + nb_cores 170 ( 10 x 17 ), nb_points 81158 ( 434 x 187 ) + nb_cores 171 ( 19 x 9 ), nb_points 80960 ( 230 x 352 ) + nb_cores 174 ( 29 x 6 ), nb_points 79577 ( 151 x 527 ) + nb_cores 175 ( 25 x 7 ), nb_points 79100 ( 175 x 452 ) + nb_cores 176 ( 16 x 11 ), nb_points 78336 ( 272 x 288 ) + nb_cores 180 ( 18 x 10 ), nb_points 76714 ( 242 x 317 ) + nb_cores 182 ( 14 x 13 ), nb_points 75884 ( 311 x 244 ) + nb_cores 184 ( 23 x 8 ), nb_points 75240 ( 190 x 396 ) + nb_cores 185 ( 37 x 5 ), nb_points 75089 ( 119 x 631 ) + nb_cores 186 ( 31 x 6 ), nb_points 74834 ( 142 x 527 ) + nb_cores 187 ( 11 x 17 ), nb_points 73865 ( 395 x 187 ) + nb_cores 189 ( 21 x 9 ), nb_points 73216 ( 208 x 352 ) + nb_cores 190 ( 19 x 10 ), nb_points 72910 ( 230 x 317 ) + nb_cores 192 ( 12 x 16 ), nb_points 72038 ( 362 x 199 ) + nb_cores 195 ( 15 x 13 ), nb_points 70760 ( 290 x 244 ) + nb_cores 196 ( 14 x 14 ), nb_points 70597 ( 311 x 227 ) + nb_cores 198 ( 18 x 11 ), nb_points 69696 ( 242 x 288 ) + nb_cores 200 ( 20 x 10 ), nb_points 69106 ( 218 x 317 ) + nb_cores 203 ( 29 x 7 ), nb_points 68252 ( 151 x 452 ) + nb_cores 204 ( 12 x 17 ), nb_points 67694 ( 362 x 187 ) + nb_cores 207 ( 23 x 9 ), nb_points 66880 ( 190 x 352 ) + nb_cores 208 ( 16 x 13 ), nb_points 66368 ( 272 x 244 ) + nb_cores 209 ( 19 x 11 ), nb_points 66240 ( 230 x 288 ) + nb_cores 210 ( 15 x 14 ), nb_points 65830 ( 290 x 227 ) + nb_cores 215 ( 43 x 5 ), nb_points 64993 ( 103 x 631 ) + nb_cores 216 ( 24 x 9 ), nb_points 64064 ( 182 x 352 ) + nb_cores 220 ( 20 x 11 ), nb_points 62784 ( 218 x 288 ) + nb_cores 221 ( 13 x 17 ), nb_points 62645 ( 335 x 187 ) + nb_cores 224 ( 16 x 14 ), nb_points 61744 ( 272 x 227 ) + nb_cores 225 ( 15 x 15 ), nb_points 61480 ( 290 x 212 ) + nb_cores 228 ( 12 x 19 ), nb_points 60816 ( 362 x 168 ) + nb_cores 230 ( 23 x 10 ), nb_points 60230 ( 190 x 317 ) + nb_cores 231 ( 21 x 11 ), nb_points 59904 ( 208 x 288 ) + nb_cores 232 ( 29 x 8 ), nb_points 59796 ( 151 x 396 ) + nb_cores 234 ( 18 x 13 ), nb_points 59048 ( 242 x 244 ) + nb_cores 238 ( 14 x 17 ), nb_points 58157 ( 311 x 187 ) + nb_cores 240 ( 16 x 15 ), nb_points 57664 ( 272 x 212 ) + nb_cores 242 ( 11 x 22 ), nb_points 57275 ( 395 x 145 ) + nb_cores 243 ( 27 x 9 ), nb_points 57024 ( 162 x 352 ) + nb_cores 245 ( 35 x 7 ), nb_points 56952 ( 126 x 452 ) + nb_cores 246 ( 41 x 6 ), nb_points 56916 ( 108 x 527 ) + nb_cores 247 ( 19 x 13 ), nb_points 56120 ( 230 x 244 ) + nb_cores 250 ( 25 x 10 ), nb_points 55475 ( 175 x 317 ) + nb_cores 252 ( 18 x 14 ), nb_points 54934 ( 242 x 227 ) + nb_cores 253 ( 23 x 11 ), nb_points 54720 ( 190 x 288 ) + nb_cores 255 ( 15 x 17 ), nb_points 54230 ( 290 x 187 ) + nb_cores 256 ( 16 x 16 ), nb_points 54128 ( 272 x 199 ) + nb_cores 259 ( 37 x 7 ), nb_points 53788 ( 119 x 452 ) + nb_cores 260 ( 20 x 13 ), nb_points 53192 ( 218 x 244 ) + nb_cores 261 ( 29 x 9 ), nb_points 53152 ( 151 x 352 ) + nb_cores 264 ( 24 x 11 ), nb_points 52416 ( 182 x 288 ) + nb_cores 266 ( 19 x 14 ), nb_points 52210 ( 230 x 227 ) + nb_cores 270 ( 18 x 15 ), nb_points 51304 ( 242 x 212 ) + nb_cores 272 ( 16 x 17 ), nb_points 50864 ( 272 x 187 ) + nb_cores 273 ( 21 x 13 ), nb_points 50752 ( 208 x 244 ) + nb_cores 275 ( 25 x 11 ), nb_points 50400 ( 175 x 288 ) + nb_cores 276 ( 12 x 23 ), nb_points 50318 ( 362 x 139 ) + nb_cores 279 ( 31 x 9 ), nb_points 49984 ( 142 x 352 ) + nb_cores 280 ( 20 x 14 ), nb_points 49486 ( 218 x 227 ) + nb_cores 285 ( 15 x 19 ), nb_points 48720 ( 290 x 168 ) + nb_cores 286 ( 22 x 13 ), nb_points 48556 ( 199 x 244 ) + nb_cores 288 ( 16 x 18 ), nb_points 48144 ( 272 x 177 ) + nb_cores 289 ( 17 x 17 ), nb_points 48059 ( 257 x 187 ) + nb_cores 290 ( 29 x 10 ), nb_points 47867 ( 151 x 317 ) + nb_cores 294 ( 21 x 14 ), nb_points 47216 ( 208 x 227 ) + nb_cores 296 ( 37 x 8 ), nb_points 47124 ( 119 x 396 ) + nb_cores 297 ( 27 x 11 ), nb_points 46656 ( 162 x 288 ) + nb_cores 299 ( 23 x 13 ), nb_points 46360 ( 190 x 244 ) + nb_cores 300 ( 20 x 15 ), nb_points 46216 ( 218 x 212 ) + nb_cores 304 ( 16 x 19 ), nb_points 45696 ( 272 x 168 ) + nb_cores 306 ( 18 x 17 ), nb_points 45254 ( 242 x 187 ) + nb_cores 308 ( 14 x 22 ), nb_points 45095 ( 311 x 145 ) + nb_cores 310 ( 31 x 10 ), nb_points 45014 ( 142 x 317 ) + nb_cores 312 ( 24 x 13 ), nb_points 44408 ( 182 x 244 ) + nb_cores 315 ( 15 x 21 ), nb_points 44080 ( 290 x 152 ) + nb_cores 319 ( 29 x 11 ), nb_points 43488 ( 151 x 288 ) + nb_cores 320 ( 20 x 16 ), nb_points 43382 ( 218 x 199 ) + nb_cores 322 ( 23 x 14 ), nb_points 43130 ( 190 x 227 ) + nb_cores 323 ( 19 x 17 ), nb_points 43010 ( 230 x 187 ) + nb_cores 324 ( 18 x 18 ), nb_points 42834 ( 242 x 177 ) + nb_cores 325 ( 25 x 13 ), nb_points 42700 ( 175 x 244 ) + nb_cores 329 ( 47 x 7 ), nb_points 42488 ( 94 x 452 ) + nb_cores 330 ( 30 x 11 ), nb_points 42048 ( 146 x 288 ) + nb_cores 333 ( 37 x 9 ), nb_points 41888 ( 119 x 352 ) + nb_cores 336 ( 24 x 14 ), nb_points 41314 ( 182 x 227 ) + nb_cores 338 ( 13 x 26 ), nb_points 41205 ( 335 x 123 ) + nb_cores 340 ( 20 x 17 ), nb_points 40766 ( 218 x 187 ) + nb_cores 342 ( 18 x 19 ), nb_points 40656 ( 242 x 168 ) + nb_cores 345 ( 23 x 15 ), nb_points 40280 ( 190 x 212 ) + nb_cores 348 ( 29 x 12 ), nb_points 40015 ( 151 x 265 ) + nb_cores 350 ( 25 x 14 ), nb_points 39725 ( 175 x 227 ) + nb_cores 351 ( 27 x 13 ), nb_points 39528 ( 162 x 244 ) + nb_cores 352 ( 16 x 22 ), nb_points 39440 ( 272 x 145 ) + nb_cores 357 ( 21 x 17 ), nb_points 38896 ( 208 x 187 ) + nb_cores 360 ( 24 x 15 ), nb_points 38584 ( 182 x 212 ) + nb_cores 363 ( 33 x 11 ), nb_points 38304 ( 133 x 288 ) + nb_cores 364 ( 14 x 26 ), nb_points 38253 ( 311 x 123 ) + nb_cores 368 ( 16 x 23 ), nb_points 37808 ( 272 x 139 ) + nb_cores 370 ( 37 x 10 ), nb_points 37723 ( 119 x 317 ) + nb_cores 372 ( 31 x 12 ), nb_points 37630 ( 142 x 265 ) + nb_cores 374 ( 22 x 17 ), nb_points 37213 ( 199 x 187 ) + nb_cores 375 ( 25 x 15 ), nb_points 37100 ( 175 x 212 ) + nb_cores 377 ( 29 x 13 ), nb_points 36844 ( 151 x 244 ) + nb_cores 378 ( 27 x 14 ), nb_points 36774 ( 162 x 227 ) + nb_cores 380 ( 20 x 19 ), nb_points 36624 ( 218 x 168 ) + nb_cores 384 ( 24 x 16 ), nb_points 36218 ( 182 x 199 ) + nb_cores 390 ( 30 x 13 ), nb_points 35624 ( 146 x 244 ) + nb_cores 391 ( 23 x 17 ), nb_points 35530 ( 190 x 187 ) + nb_cores 396 ( 18 x 22 ), nb_points 35090 ( 242 x 145 ) + nb_cores 399 ( 21 x 19 ), nb_points 34944 ( 208 x 168 ) + nb_cores 400 ( 16 x 25 ), nb_points 34816 ( 272 x 128 ) + nb_cores 403 ( 31 x 13 ), nb_points 34648 ( 142 x 244 ) + nb_cores 405 ( 27 x 15 ), nb_points 34344 ( 162 x 212 ) + nb_cores 406 ( 29 x 14 ), nb_points 34277 ( 151 x 227 ) + nb_cores 407 ( 37 x 11 ), nb_points 34272 ( 119 x 288 ) + nb_cores 408 ( 24 x 17 ), nb_points 34034 ( 182 x 187 ) + nb_cores 414 ( 23 x 18 ), nb_points 33630 ( 190 x 177 ) + nb_cores 416 ( 32 x 13 ), nb_points 33428 ( 137 x 244 ) + nb_cores 418 ( 19 x 22 ), nb_points 33350 ( 230 x 145 ) + nb_cores 420 ( 20 x 21 ), nb_points 33136 ( 218 x 152 ) + nb_cores 423 ( 47 x 9 ), nb_points 33088 ( 94 x 352 ) + nb_cores 425 ( 25 x 17 ), nb_points 32725 ( 175 x 187 ) + nb_cores 429 ( 33 x 13 ), nb_points 32452 ( 133 x 244 ) + nb_cores 432 ( 24 x 18 ), nb_points 32214 ( 182 x 177 ) + nb_cores 435 ( 29 x 15 ), nb_points 32012 ( 151 x 212 ) + nb_cores 437 ( 23 x 19 ), nb_points 31920 ( 190 x 168 ) + nb_cores 440 ( 20 x 22 ), nb_points 31610 ( 218 x 145 ) + nb_cores 442 ( 26 x 17 ), nb_points 31603 ( 169 x 187 ) + nb_cores 444 ( 12 x 37 ), nb_points 31494 ( 362 x 87 ) + nb_cores 448 ( 32 x 14 ), nb_points 31099 ( 137 x 227 ) + nb_cores 450 ( 30 x 15 ), nb_points 30952 ( 146 x 212 ) + nb_cores 455 ( 35 x 13 ), nb_points 30744 ( 126 x 244 ) + nb_cores 456 ( 24 x 19 ), nb_points 30576 ( 182 x 168 ) + nb_cores 459 ( 27 x 17 ), nb_points 30294 ( 162 x 187 ) + nb_cores 462 ( 21 x 22 ), nb_points 30160 ( 208 x 145 ) + nb_cores 464 ( 29 x 16 ), nb_points 30049 ( 151 x 199 ) + nb_cores 468 ( 18 x 26 ), nb_points 29766 ( 242 x 123 ) + nb_cores 473 ( 43 x 11 ), nb_points 29664 ( 103 x 288 ) + nb_cores 475 ( 25 x 19 ), nb_points 29400 ( 175 x 168 ) + nb_cores 476 ( 28 x 17 ), nb_points 29359 ( 157 x 187 ) + nb_cores 480 ( 32 x 15 ), nb_points 29044 ( 137 x 212 ) + nb_cores 481 ( 37 x 13 ), nb_points 29036 ( 119 x 244 ) + nb_cores 483 ( 23 x 21 ), nb_points 28880 ( 190 x 152 ) + nb_cores 484 ( 22 x 22 ), nb_points 28855 ( 199 x 145 ) + nb_cores 486 ( 27 x 18 ), nb_points 28674 ( 162 x 177 ) + nb_cores 490 ( 35 x 14 ), nb_points 28602 ( 126 x 227 ) + nb_cores 492 ( 12 x 41 ), nb_points 28598 ( 362 x 79 ) + nb_cores 493 ( 29 x 17 ), nb_points 28237 ( 151 x 187 ) + nb_cores 495 ( 33 x 15 ), nb_points 28196 ( 133 x 212 ) + nb_cores 500 ( 20 x 25 ), nb_points 27904 ( 218 x 128 ) + nb_cores 504 ( 24 x 21 ), nb_points 27664 ( 182 x 152 ) + nb_cores 506 ( 23 x 22 ), nb_points 27550 ( 190 x 145 ) + nb_cores 510 ( 30 x 17 ), nb_points 27302 ( 146 x 187 ) + nb_cores 512 ( 32 x 16 ), nb_points 27263 ( 137 x 199 ) + nb_cores 513 ( 27 x 19 ), nb_points 27216 ( 162 x 168 ) + nb_cores 517 ( 47 x 11 ), nb_points 27072 ( 94 x 288 ) + nb_cores 518 ( 37 x 14 ), nb_points 27013 ( 119 x 227 ) + nb_cores 520 ( 20 x 26 ), nb_points 26814 ( 218 x 123 ) + nb_cores 522 ( 29 x 18 ), nb_points 26727 ( 151 x 177 ) + nb_cores 525 ( 25 x 21 ), nb_points 26600 ( 175 x 152 ) + nb_cores 527 ( 31 x 17 ), nb_points 26554 ( 142 x 187 ) + nb_cores 528 ( 24 x 22 ), nb_points 26390 ( 182 x 145 ) + nb_cores 532 ( 38 x 14 ), nb_points 26332 ( 116 x 227 ) + nb_cores 539 ( 49 x 11 ), nb_points 26208 ( 91 x 288 ) + nb_cores 540 ( 30 x 18 ), nb_points 25842 ( 146 x 177 ) + nb_cores 544 ( 32 x 17 ), nb_points 25619 ( 137 x 187 ) + nb_cores 546 ( 21 x 26 ), nb_points 25584 ( 208 x 123 ) + nb_cores 550 ( 25 x 22 ), nb_points 25375 ( 175 x 145 ) + nb_cores 551 ( 29 x 19 ), nb_points 25368 ( 151 x 168 ) + nb_cores 552 ( 24 x 23 ), nb_points 25298 ( 182 x 139 ) + nb_cores 555 ( 37 x 15 ), nb_points 25228 ( 119 x 212 ) + nb_cores 558 ( 31 x 18 ), nb_points 25134 ( 142 x 177 ) + nb_cores 559 ( 43 x 13 ), nb_points 25132 ( 103 x 244 ) + nb_cores 560 ( 40 x 14 ), nb_points 24970 ( 110 x 227 ) + nb_cores 561 ( 33 x 17 ), nb_points 24871 ( 133 x 187 ) + nb_cores 567 ( 27 x 21 ), nb_points 24624 ( 162 x 152 ) + nb_cores 570 ( 30 x 19 ), nb_points 24528 ( 146 x 168 ) + nb_cores 572 ( 22 x 26 ), nb_points 24477 ( 199 x 123 ) + nb_cores 575 ( 23 x 25 ), nb_points 24320 ( 190 x 128 ) + nb_cores 576 ( 32 x 18 ), nb_points 24249 ( 137 x 177 ) + nb_cores 580 ( 29 x 20 ), nb_points 24160 ( 151 x 160 ) + nb_cores 585 ( 45 x 13 ), nb_points 23912 ( 98 x 244 ) + nb_cores 588 ( 42 x 14 ), nb_points 23835 ( 105 x 227 ) + nb_cores 592 ( 16 x 37 ), nb_points 23664 ( 272 x 87 ) + nb_cores 594 ( 27 x 22 ), nb_points 23490 ( 162 x 145 ) + nb_cores 598 ( 23 x 26 ), nb_points 23370 ( 190 x 123 ) + nb_cores 600 ( 24 x 25 ), nb_points 23296 ( 182 x 128 ) + nb_cores 608 ( 32 x 19 ), nb_points 23016 ( 137 x 168 ) + nb_cores 609 ( 29 x 21 ), nb_points 22952 ( 151 x 152 ) + nb_cores 611 ( 47 x 13 ), nb_points 22936 ( 94 x 244 ) + nb_cores 612 ( 36 x 17 ), nb_points 22814 ( 122 x 187 ) + nb_cores 616 ( 28 x 22 ), nb_points 22765 ( 157 x 145 ) + nb_cores 620 ( 20 x 31 ), nb_points 22672 ( 218 x 104 ) + nb_cores 621 ( 27 x 23 ), nb_points 22518 ( 162 x 139 ) + nb_cores 624 ( 24 x 26 ), nb_points 22386 ( 182 x 123 ) + nb_cores 627 ( 33 x 19 ), nb_points 22344 ( 133 x 168 ) + nb_cores 629 ( 37 x 17 ), nb_points 22253 ( 119 x 187 ) + nb_cores 630 ( 30 x 21 ), nb_points 22192 ( 146 x 152 ) + nb_cores 638 ( 29 x 22 ), nb_points 21895 ( 151 x 145 ) + nb_cores 640 ( 40 x 16 ), nb_points 21890 ( 110 x 199 ) + nb_cores 644 ( 46 x 14 ), nb_points 21792 ( 96 x 227 ) + nb_cores 646 ( 38 x 17 ), nb_points 21692 ( 116 x 187 ) + nb_cores 648 ( 36 x 18 ), nb_points 21594 ( 122 x 177 ) + nb_cores 650 ( 25 x 26 ), nb_points 21525 ( 175 x 123 ) + nb_cores 656 ( 16 x 41 ), nb_points 21488 ( 272 x 79 ) + nb_cores 658 ( 47 x 14 ), nb_points 21338 ( 94 x 227 ) + nb_cores 660 ( 30 x 22 ), nb_points 21170 ( 146 x 145 ) + nb_cores 663 ( 39 x 17 ), nb_points 21131 ( 113 x 187 ) + nb_cores 666 ( 18 x 37 ), nb_points 21054 ( 242 x 87 ) + nb_cores 667 ( 29 x 23 ), nb_points 20989 ( 151 x 139 ) + nb_cores 672 ( 32 x 21 ), nb_points 20824 ( 137 x 152 ) + nb_cores 675 ( 27 x 25 ), nb_points 20736 ( 162 x 128 ) + nb_cores 680 ( 40 x 17 ), nb_points 20570 ( 110 x 187 ) + nb_cores 684 ( 36 x 19 ), nb_points 20496 ( 122 x 168 ) + nb_cores 690 ( 30 x 23 ), nb_points 20294 ( 146 x 139 ) + nb_cores 693 ( 33 x 21 ), nb_points 20216 ( 133 x 152 ) + nb_cores 696 ( 24 x 29 ), nb_points 20202 ( 182 x 111 ) + nb_cores 697 ( 41 x 17 ), nb_points 20196 ( 108 x 187 ) + nb_cores 700 ( 20 x 35 ), nb_points 20056 ( 218 x 92 ) + nb_cores 702 ( 27 x 26 ), nb_points 19926 ( 162 x 123 ) + nb_cores 704 ( 32 x 22 ), nb_points 19865 ( 137 x 145 ) + nb_cores 713 ( 31 x 23 ), nb_points 19738 ( 142 x 139 ) + nb_cores 714 ( 42 x 17 ), nb_points 19635 ( 105 x 187 ) + nb_cores 720 ( 40 x 18 ), nb_points 19470 ( 110 x 177 ) + nb_cores 725 ( 29 x 25 ), nb_points 19328 ( 151 x 128 ) + nb_cores 726 ( 33 x 22 ), nb_points 19285 ( 133 x 145 ) + nb_cores 729 ( 27 x 27 ), nb_points 19278 ( 162 x 119 ) + nb_cores 731 ( 43 x 17 ), nb_points 19261 ( 103 x 187 ) + nb_cores 735 ( 21 x 35 ), nb_points 19136 ( 208 x 92 ) + nb_cores 736 ( 32 x 23 ), nb_points 19043 ( 137 x 139 ) + nb_cores 740 ( 20 x 37 ), nb_points 18966 ( 218 x 87 ) + nb_cores 744 ( 24 x 31 ), nb_points 18928 ( 182 x 104 ) + nb_cores 748 ( 34 x 22 ), nb_points 18850 ( 130 x 145 ) + nb_cores 750 ( 30 x 25 ), nb_points 18688 ( 146 x 128 ) + nb_cores 754 ( 29 x 26 ), nb_points 18573 ( 151 x 123 ) + nb_cores 756 ( 36 x 21 ), nb_points 18544 ( 122 x 152 ) + nb_cores 759 ( 33 x 23 ), nb_points 18487 ( 133 x 139 ) + nb_cores 760 ( 40 x 19 ), nb_points 18480 ( 110 x 168 ) + nb_cores 765 ( 45 x 17 ), nb_points 18326 ( 98 x 187 ) + nb_cores 768 ( 48 x 16 ), nb_points 18308 ( 92 x 199 ) + nb_cores 770 ( 35 x 22 ), nb_points 18270 ( 126 x 145 ) + nb_cores 774 ( 43 x 18 ), nb_points 18231 ( 103 x 177 ) + nb_cores 775 ( 31 x 25 ), nb_points 18176 ( 142 x 128 ) + nb_cores 777 ( 37 x 21 ), nb_points 18088 ( 119 x 152 ) + nb_cores 780 ( 30 x 26 ), nb_points 17958 ( 146 x 123 ) + nb_cores 782 ( 46 x 17 ), nb_points 17952 ( 96 x 187 ) + nb_cores 792 ( 36 x 22 ), nb_points 17690 ( 122 x 145 ) + nb_cores 798 ( 38 x 21 ), nb_points 17632 ( 116 x 152 ) + nb_cores 799 ( 47 x 17 ), nb_points 17578 ( 94 x 187 ) + nb_cores 800 ( 32 x 25 ), nb_points 17536 ( 137 x 128 ) + nb_cores 805 ( 23 x 35 ), nb_points 17480 ( 190 x 92 ) + nb_cores 806 ( 31 x 26 ), nb_points 17466 ( 142 x 123 ) + nb_cores 810 ( 27 x 30 ), nb_points 17334 ( 162 x 107 ) + nb_cores 814 ( 37 x 22 ), nb_points 17255 ( 119 x 145 ) + nb_cores 816 ( 48 x 17 ), nb_points 17204 ( 92 x 187 ) + nb_cores 819 ( 39 x 21 ), nb_points 17176 ( 113 x 152 ) + nb_cores 825 ( 33 x 25 ), nb_points 17024 ( 133 x 128 ) + nb_cores 828 ( 36 x 23 ), nb_points 16958 ( 122 x 139 ) + nb_cores 832 ( 32 x 26 ), nb_points 16851 ( 137 x 123 ) + nb_cores 836 ( 38 x 22 ), nb_points 16820 ( 116 x 145 ) + nb_cores 840 ( 40 x 21 ), nb_points 16720 ( 110 x 152 ) + nb_cores 846 ( 47 x 18 ), nb_points 16638 ( 94 x 177 ) + nb_cores 850 ( 25 x 34 ), nb_points 16625 ( 175 x 95 ) + nb_cores 851 ( 23 x 37 ), nb_points 16530 ( 190 x 87 ) + nb_cores 855 ( 45 x 19 ), nb_points 16464 ( 98 x 168 ) + nb_cores 858 ( 33 x 26 ), nb_points 16359 ( 133 x 123 ) + nb_cores 864 ( 48 x 18 ), nb_points 16284 ( 92 x 177 ) + nb_cores 867 ( 51 x 17 ), nb_points 16269 ( 87 x 187 ) + nb_cores 870 ( 29 x 30 ), nb_points 16157 ( 151 x 107 ) + nb_cores 874 ( 38 x 23 ), nb_points 16124 ( 116 x 139 ) + nb_cores 875 ( 25 x 35 ), nb_points 16100 ( 175 x 92 ) + nb_cores 880 ( 40 x 22 ), nb_points 15950 ( 110 x 145 ) + nb_cores 888 ( 24 x 37 ), nb_points 15834 ( 182 x 87 ) + nb_cores 891 ( 33 x 27 ), nb_points 15827 ( 133 x 119 ) + nb_cores 893 ( 47 x 19 ), nb_points 15792 ( 94 x 168 ) + nb_cores 896 ( 32 x 28 ), nb_points 15755 ( 137 x 115 ) + nb_cores 897 ( 39 x 23 ), nb_points 15707 ( 113 x 139 ) + nb_cores 899 ( 29 x 31 ), nb_points 15704 ( 151 x 104 ) + nb_cores 900 ( 36 x 25 ), nb_points 15616 ( 122 x 128 ) + nb_cores 910 ( 35 x 26 ), nb_points 15498 ( 126 x 123 ) + nb_cores 912 ( 48 x 19 ), nb_points 15456 ( 92 x 168 ) + nb_cores 918 ( 54 x 17 ), nb_points 15334 ( 82 x 187 ) + nb_cores 920 ( 40 x 23 ), nb_points 15290 ( 110 x 139 ) + nb_cores 924 ( 42 x 22 ), nb_points 15225 ( 105 x 145 ) + nb_cores 928 ( 32 x 29 ), nb_points 15207 ( 137 x 111 ) + nb_cores 930 ( 30 x 31 ), nb_points 15184 ( 146 x 104 ) + nb_cores 935 ( 55 x 17 ), nb_points 15147 ( 81 x 187 ) + nb_cores 936 ( 36 x 26 ), nb_points 15006 ( 122 x 123 ) + nb_cores 945 ( 45 x 21 ), nb_points 14896 ( 98 x 152 ) + nb_cores 950 ( 38 x 25 ), nb_points 14848 ( 116 x 128 ) + nb_cores 957 ( 33 x 29 ), nb_points 14763 ( 133 x 111 ) + nb_cores 960 ( 32 x 30 ), nb_points 14659 ( 137 x 107 ) + nb_cores 962 ( 37 x 26 ), nb_points 14637 ( 119 x 123 ) + nb_cores 966 ( 46 x 21 ), nb_points 14592 ( 96 x 152 ) + nb_cores 969 ( 57 x 17 ), nb_points 14586 ( 78 x 187 ) + nb_cores 972 ( 54 x 18 ), nb_points 14514 ( 82 x 177 ) + nb_cores 975 ( 39 x 25 ), nb_points 14464 ( 113 x 128 ) + nb_cores 980 ( 28 x 35 ), nb_points 14444 ( 157 x 92 ) + nb_cores 984 ( 24 x 41 ), nb_points 14378 ( 182 x 79 ) + nb_cores 986 ( 29 x 34 ), nb_points 14345 ( 151 x 95 ) + nb_cores 987 ( 47 x 21 ), nb_points 14288 ( 94 x 152 ) + nb_cores 988 ( 38 x 26 ), nb_points 14268 ( 116 x 123 ) + nb_cores 990 ( 45 x 22 ), nb_points 14210 ( 98 x 145 ) + nb_cores 999 ( 27 x 37 ), nb_points 14094 ( 162 x 87 ) + nb_cores 1000 ( 40 x 25 ), nb_points 14080 ( 110 x 128 ) + nb_cores 1008 ( 48 x 21 ), nb_points 13984 ( 92 x 152 ) + nb_cores 1012 ( 46 x 22 ), nb_points 13920 ( 96 x 145 ) + nb_cores 1014 ( 39 x 26 ), nb_points 13899 ( 113 x 123 ) + nb_cores 1015 ( 29 x 35 ), nb_points 13892 ( 151 x 92 ) + nb_cores 1020 ( 60 x 17 ), nb_points 13838 ( 74 x 187 ) + nb_cores 1023 ( 33 x 31 ), nb_points 13832 ( 133 x 104 ) + nb_cores 1025 ( 41 x 25 ), nb_points 13824 ( 108 x 128 ) + nb_cores 1026 ( 27 x 38 ), nb_points 13770 ( 162 x 85 ) + nb_cores 1034 ( 47 x 22 ), nb_points 13630 ( 94 x 145 ) + nb_cores 1035 ( 45 x 23 ), nb_points 13622 ( 98 x 139 ) + nb_cores 1040 ( 40 x 26 ), nb_points 13530 ( 110 x 123 ) + nb_cores 1050 ( 30 x 35 ), nb_points 13432 ( 146 x 92 ) + nb_cores 1056 ( 48 x 22 ), nb_points 13340 ( 92 x 145 ) + nb_cores 1066 ( 41 x 26 ), nb_points 13284 ( 108 x 123 ) + nb_cores 1071 ( 51 x 21 ), nb_points 13224 ( 87 x 152 ) + nb_cores 1073 ( 29 x 37 ), nb_points 13137 ( 151 x 87 ) + nb_cores 1080 ( 36 x 30 ), nb_points 13054 ( 122 x 107 ) + nb_cores 1088 ( 32 x 34 ), nb_points 13015 ( 137 x 95 ) + nb_cores 1092 ( 42 x 26 ), nb_points 12915 ( 105 x 123 ) + nb_cores 1100 ( 50 x 22 ), nb_points 12905 ( 89 x 145 ) + nb_cores 1102 ( 29 x 38 ), nb_points 12835 ( 151 x 85 ) + nb_cores 1104 ( 48 x 23 ), nb_points 12788 ( 92 x 139 ) + nb_cores 1110 ( 30 x 37 ), nb_points 12702 ( 146 x 87 ) + nb_cores 1116 ( 36 x 31 ), nb_points 12688 ( 122 x 104 ) + nb_cores 1118 ( 43 x 26 ), nb_points 12669 ( 103 x 123 ) + nb_cores 1120 ( 32 x 35 ), nb_points 12604 ( 137 x 92 ) + nb_cores 1125 ( 45 x 25 ), nb_points 12544 ( 98 x 128 ) + nb_cores 1131 ( 29 x 39 ), nb_points 12533 ( 151 x 83 ) + nb_cores 1134 ( 54 x 21 ), nb_points 12464 ( 82 x 152 ) + nb_cores 1140 ( 30 x 38 ), nb_points 12410 ( 146 x 85 ) + nb_cores 1147 ( 31 x 37 ), nb_points 12354 ( 142 x 87 ) + nb_cores 1150 ( 46 x 25 ), nb_points 12288 ( 96 x 128 ) + nb_cores 1155 ( 33 x 35 ), nb_points 12236 ( 133 x 92 ) + nb_cores 1160 ( 40 x 29 ), nb_points 12210 ( 110 x 111 ) + nb_cores 1166 ( 53 x 22 ), nb_points 12180 ( 84 x 145 ) + nb_cores 1170 ( 45 x 26 ), nb_points 12054 ( 98 x 123 ) + nb_cores 1175 ( 47 x 25 ), nb_points 12032 ( 94 x 128 ) + nb_cores 1184 ( 32 x 37 ), nb_points 11919 ( 137 x 87 ) + nb_cores 1188 ( 54 x 22 ), nb_points 11890 ( 82 x 145 ) + nb_cores 1196 ( 46 x 26 ), nb_points 11808 ( 96 x 123 ) + nb_cores 1200 ( 40 x 30 ), nb_points 11770 ( 110 x 107 ) + nb_cores 1209 ( 39 x 31 ), nb_points 11752 ( 113 x 104 ) + nb_cores 1210 ( 55 x 22 ), nb_points 11745 ( 81 x 145 ) + nb_cores 1215 ( 45 x 27 ), nb_points 11662 ( 98 x 119 ) + nb_cores 1216 ( 32 x 38 ), nb_points 11645 ( 137 x 85 ) + nb_cores 1218 ( 29 x 42 ), nb_points 11627 ( 151 x 77 ) + nb_cores 1221 ( 33 x 37 ), nb_points 11571 ( 133 x 87 ) + nb_cores 1222 ( 47 x 26 ), nb_points 11562 ( 94 x 123 ) + nb_cores 1230 ( 30 x 41 ), nb_points 11534 ( 146 x 79 ) + nb_cores 1240 ( 40 x 31 ), nb_points 11440 ( 110 x 104 ) + nb_cores 1242 ( 54 x 23 ), nb_points 11398 ( 82 x 139 ) + nb_cores 1248 ( 48 x 26 ), nb_points 11316 ( 92 x 123 ) + nb_cores 1254 ( 33 x 38 ), nb_points 11305 ( 133 x 85 ) + nb_cores 1260 ( 36 x 35 ), nb_points 11224 ( 122 x 92 ) + nb_cores 1269 ( 27 x 47 ), nb_points 11178 ( 162 x 69 ) + nb_cores 1275 ( 51 x 25 ), nb_points 11136 ( 87 x 128 ) + nb_cores 1280 ( 32 x 40 ), nb_points 11097 ( 137 x 81 ) + nb_cores 1281 ( 61 x 21 ), nb_points 11096 ( 73 x 152 ) + nb_cores 1287 ( 33 x 39 ), nb_points 11039 ( 133 x 83 ) + nb_cores 1290 ( 43 x 30 ), nb_points 11021 ( 103 x 107 ) + nb_cores 1292 ( 38 x 34 ), nb_points 11020 ( 116 x 95 ) + nb_cores 1295 ( 37 x 35 ), nb_points 10948 ( 119 x 92 ) + nb_cores 1300 ( 50 x 26 ), nb_points 10947 ( 89 x 123 ) + nb_cores 1302 ( 42 x 31 ), nb_points 10920 ( 105 x 104 ) + nb_cores 1305 ( 29 x 45 ), nb_points 10872 ( 151 x 72 ) + nb_cores 1311 ( 57 x 23 ), nb_points 10842 ( 78 x 139 ) + nb_cores 1312 ( 32 x 41 ), nb_points 10823 ( 137 x 79 ) + nb_cores 1316 ( 47 x 28 ), nb_points 10810 ( 94 x 115 ) + nb_cores 1320 ( 60 x 22 ), nb_points 10730 ( 74 x 145 ) + nb_cores 1326 ( 51 x 26 ), nb_points 10701 ( 87 x 123 ) + nb_cores 1330 ( 38 x 35 ), nb_points 10672 ( 116 x 92 ) + nb_cores 1332 ( 36 x 37 ), nb_points 10614 ( 122 x 87 ) + nb_cores 1342 ( 61 x 22 ), nb_points 10585 ( 73 x 145 ) + nb_cores 1344 ( 32 x 42 ), nb_points 10549 ( 137 x 77 ) + nb_cores 1350 ( 45 x 30 ), nb_points 10486 ( 98 x 107 ) + nb_cores 1360 ( 40 x 34 ), nb_points 10450 ( 110 x 95 ) + nb_cores 1363 ( 29 x 47 ), nb_points 10419 ( 151 x 69 ) + nb_cores 1365 ( 39 x 35 ), nb_points 10396 ( 113 x 92 ) + nb_cores 1368 ( 36 x 38 ), nb_points 10370 ( 122 x 85 ) + nb_cores 1369 ( 37 x 37 ), nb_points 10353 ( 119 x 87 ) + nb_cores 1378 ( 53 x 26 ), nb_points 10332 ( 84 x 123 ) + nb_cores 1380 ( 46 x 30 ), nb_points 10272 ( 96 x 107 ) + nb_cores 1386 ( 33 x 42 ), nb_points 10241 ( 133 x 77 ) + nb_cores 1392 ( 48 x 29 ), nb_points 10212 ( 92 x 111 ) + nb_cores 1395 ( 45 x 31 ), nb_points 10192 ( 98 x 104 ) + nb_cores 1400 ( 40 x 35 ), nb_points 10120 ( 110 x 92 ) + nb_cores 1404 ( 54 x 26 ), nb_points 10086 ( 82 x 123 ) + nb_cores 1410 ( 47 x 30 ), nb_points 10058 ( 94 x 107 ) + nb_cores 1425 ( 57 x 25 ), nb_points 9984 ( 78 x 128 ) + nb_cores 1428 ( 42 x 34 ), nb_points 9975 ( 105 x 95 ) + nb_cores 1430 ( 55 x 26 ), nb_points 9963 ( 81 x 123 ) + nb_cores 1435 ( 41 x 35 ), nb_points 9936 ( 108 x 92 ) + nb_cores 1440 ( 48 x 30 ), nb_points 9844 ( 92 x 107 ) + nb_cores 1443 ( 39 x 37 ), nb_points 9831 ( 113 x 87 ) + nb_cores 1450 ( 29 x 50 ), nb_points 9815 ( 151 x 65 ) + nb_cores 1457 ( 47 x 31 ), nb_points 9776 ( 94 x 104 ) + nb_cores 1458 ( 54 x 27 ), nb_points 9758 ( 82 x 119 ) + nb_cores 1470 ( 42 x 35 ), nb_points 9660 ( 105 x 92 ) + nb_cores 1476 ( 36 x 41 ), nb_points 9638 ( 122 x 79 ) + nb_cores 1480 ( 40 x 37 ), nb_points 9570 ( 110 x 87 ) + nb_cores 1488 ( 48 x 31 ), nb_points 9568 ( 92 x 104 ) + nb_cores 1500 ( 60 x 25 ), nb_points 9472 ( 74 x 128 ) + nb_cores 1504 ( 32 x 47 ), nb_points 9453 ( 137 x 69 ) + nb_cores 1512 ( 36 x 42 ), nb_points 9394 ( 122 x 77 ) + nb_cores 1520 ( 40 x 38 ), nb_points 9350 ( 110 x 85 ) + nb_cores 1525 ( 61 x 25 ), nb_points 9344 ( 73 x 128 ) + nb_cores 1530 ( 51 x 30 ), nb_points 9309 ( 87 x 107 ) + nb_cores 1536 ( 48 x 32 ), nb_points 9292 ( 92 x 101 ) + nb_cores 1539 ( 57 x 27 ), nb_points 9282 ( 78 x 119 ) + nb_cores 1540 ( 70 x 22 ), nb_points 9280 ( 64 x 145 ) + nb_cores 1548 ( 43 x 36 ), nb_points 9270 ( 103 x 90 ) + nb_cores 1550 ( 62 x 25 ), nb_points 9216 ( 72 x 128 ) + nb_cores 1551 ( 33 x 47 ), nb_points 9177 ( 133 x 69 ) + nb_cores 1554 ( 42 x 37 ), nb_points 9135 ( 105 x 87 ) + nb_cores 1560 ( 60 x 26 ), nb_points 9102 ( 74 x 123 ) + nb_cores 1575 ( 45 x 35 ), nb_points 9016 ( 98 x 92 ) + nb_cores 1584 ( 72 x 22 ), nb_points 8990 ( 62 x 145 ) + nb_cores 1586 ( 61 x 26 ), nb_points 8979 ( 73 x 123 ) + nb_cores 1591 ( 43 x 37 ), nb_points 8961 ( 103 x 87 ) + nb_cores 1596 ( 42 x 38 ), nb_points 8925 ( 105 x 85 ) + nb_cores 1600 ( 32 x 50 ), nb_points 8905 ( 137 x 65 ) + nb_cores 1610 ( 46 x 35 ), nb_points 8832 ( 96 x 92 ) + nb_cores 1620 ( 54 x 30 ), nb_points 8774 ( 82 x 107 ) + nb_cores 1632 ( 48 x 34 ), nb_points 8740 ( 92 x 95 ) + nb_cores 1638 ( 39 x 42 ), nb_points 8701 ( 113 x 77 ) + nb_cores 1640 ( 40 x 41 ), nb_points 8690 ( 110 x 79 ) + nb_cores 1645 ( 47 x 35 ), nb_points 8648 ( 94 x 92 ) + nb_cores 1650 ( 33 x 50 ), nb_points 8645 ( 133 x 65 ) + nb_cores 1656 ( 72 x 23 ), nb_points 8618 ( 62 x 139 ) + nb_cores 1664 ( 64 x 26 ), nb_points 8610 ( 70 x 123 ) + nb_cores 1665 ( 45 x 37 ), nb_points 8526 ( 98 x 87 ) + nb_cores 1680 ( 48 x 35 ), nb_points 8464 ( 92 x 92 ) + nb_cores 1692 ( 36 x 47 ), nb_points 8418 ( 122 x 69 ) + nb_cores 1702 ( 46 x 37 ), nb_points 8352 ( 96 x 87 ) + nb_cores 1710 ( 45 x 38 ), nb_points 8330 ( 98 x 85 ) + nb_cores 1722 ( 42 x 41 ), nb_points 8295 ( 105 x 79 ) + nb_cores 1728 ( 48 x 36 ), nb_points 8280 ( 92 x 90 ) + nb_cores 1734 ( 51 x 34 ), nb_points 8265 ( 87 x 95 ) + nb_cores 1739 ( 47 x 37 ), nb_points 8178 ( 94 x 87 ) + nb_cores 1748 ( 46 x 38 ), nb_points 8160 ( 96 x 85 ) + nb_cores 1755 ( 45 x 39 ), nb_points 8134 ( 98 x 83 ) + nb_cores 1760 ( 80 x 22 ), nb_points 8120 ( 56 x 145 ) + nb_cores 1764 ( 42 x 42 ), nb_points 8085 ( 105 x 77 ) + nb_cores 1775 ( 71 x 25 ), nb_points 8064 ( 63 x 128 ) + nb_cores 1776 ( 48 x 37 ), nb_points 8004 ( 92 x 87 ) + nb_cores 1786 ( 47 x 38 ), nb_points 7990 ( 94 x 85 ) + nb_cores 1794 ( 46 x 39 ), nb_points 7968 ( 96 x 83 ) + nb_cores 1800 ( 60 x 30 ), nb_points 7918 ( 74 x 107 ) + nb_cores 1813 ( 49 x 37 ), nb_points 7917 ( 91 x 87 ) + nb_cores 1820 ( 70 x 26 ), nb_points 7872 ( 64 x 123 ) + nb_cores 1824 ( 48 x 38 ), nb_points 7820 ( 92 x 85 ) + nb_cores 1830 ( 61 x 30 ), nb_points 7811 ( 73 x 107 ) + nb_cores 1833 ( 39 x 47 ), nb_points 7797 ( 113 x 69 ) + nb_cores 1836 ( 54 x 34 ), nb_points 7790 ( 82 x 95 ) + nb_cores 1840 ( 46 x 40 ), nb_points 7776 ( 96 x 81 ) + nb_cores 1845 ( 45 x 41 ), nb_points 7742 ( 98 x 79 ) + nb_cores 1850 ( 37 x 50 ), nb_points 7735 ( 119 x 65 ) + nb_cores 1855 ( 53 x 35 ), nb_points 7728 ( 84 x 92 ) + nb_cores 1860 ( 60 x 31 ), nb_points 7696 ( 74 x 104 ) + nb_cores 1870 ( 85 x 22 ), nb_points 7685 ( 53 x 145 ) + nb_cores 1872 ( 72 x 26 ), nb_points 7626 ( 62 x 123 ) + nb_cores 1880 ( 40 x 47 ), nb_points 7590 ( 110 x 69 ) + nb_cores 1886 ( 46 x 41 ), nb_points 7584 ( 96 x 79 ) + nb_cores 1887 ( 51 x 37 ), nb_points 7569 ( 87 x 87 ) + nb_cores 1890 ( 54 x 35 ), nb_points 7544 ( 82 x 92 ) + nb_cores 1900 ( 38 x 50 ), nb_points 7540 ( 116 x 65 ) + nb_cores 1917 ( 71 x 27 ), nb_points 7497 ( 63 x 119 ) + nb_cores 1920 ( 48 x 40 ), nb_points 7452 ( 92 x 81 ) + nb_cores 1927 ( 47 x 41 ), nb_points 7426 ( 94 x 79 ) + nb_cores 1932 ( 46 x 42 ), nb_points 7392 ( 96 x 77 ) + nb_cores 1944 ( 72 x 27 ), nb_points 7378 ( 62 x 119 ) + nb_cores 1950 ( 39 x 50 ), nb_points 7345 ( 113 x 65 ) + nb_cores 1961 ( 53 x 37 ), nb_points 7308 ( 84 x 87 ) + nb_cores 1968 ( 48 x 41 ), nb_points 7268 ( 92 x 79 ) + nb_cores 1974 ( 47 x 42 ), nb_points 7238 ( 94 x 77 ) + nb_cores 1989 ( 51 x 39 ), nb_points 7221 ( 87 x 83 ) + nb_cores 1995 ( 57 x 35 ), nb_points 7176 ( 78 x 92 ) + nb_cores 1998 ( 54 x 37 ), nb_points 7134 ( 82 x 87 ) + nb_cores 2016 ( 48 x 42 ), nb_points 7084 ( 92 x 77 ) + nb_cores 2025 ( 45 x 45 ), nb_points 7056 ( 98 x 72 ) + nb_cores 2035 ( 55 x 37 ), nb_points 7047 ( 81 x 87 ) + nb_cores 2040 ( 60 x 34 ), nb_points 7030 ( 74 x 95 ) + nb_cores 2050 ( 41 x 50 ), nb_points 7020 ( 108 x 65 ) + nb_cores 2052 ( 54 x 38 ), nb_points 6970 ( 82 x 85 ) + nb_cores 2068 ( 47 x 44 ), nb_points 6956 ( 94 x 74 ) + nb_cores 2070 ( 46 x 45 ), nb_points 6912 ( 96 x 72 ) + nb_cores 2080 ( 80 x 26 ), nb_points 6888 ( 56 x 123 ) + nb_cores 2088 ( 72 x 29 ), nb_points 6882 ( 62 x 111 ) + nb_cores 2091 ( 51 x 41 ), nb_points 6873 ( 87 x 79 ) + nb_cores 2100 ( 60 x 35 ), nb_points 6808 ( 74 x 92 ) + nb_cores 2106 ( 54 x 39 ), nb_points 6806 ( 82 x 83 ) + nb_cores 2109 ( 57 x 37 ), nb_points 6786 ( 78 x 87 ) + nb_cores 2115 ( 45 x 47 ), nb_points 6762 ( 98 x 69 ) + nb_cores 2130 ( 71 x 30 ), nb_points 6741 ( 63 x 107 ) + nb_cores 2135 ( 61 x 35 ), nb_points 6716 ( 73 x 92 ) + nb_cores 2142 ( 51 x 42 ), nb_points 6699 ( 87 x 77 ) + nb_cores 2150 ( 43 x 50 ), nb_points 6695 ( 103 x 65 ) + nb_cores 2160 ( 48 x 45 ), nb_points 6624 ( 92 x 72 ) + nb_cores 2183 ( 59 x 37 ), nb_points 6612 ( 76 x 87 ) + nb_cores 2193 ( 43 x 51 ), nb_points 6592 ( 103 x 64 ) + nb_cores 2196 ( 61 x 36 ), nb_points 6570 ( 73 x 90 ) + nb_cores 2200 ( 55 x 40 ), nb_points 6561 ( 81 x 81 ) + nb_cores 2201 ( 71 x 31 ), nb_points 6552 ( 63 x 104 ) + nb_cores 2204 ( 58 x 38 ), nb_points 6545 ( 77 x 85 ) + nb_cores 2205 ( 63 x 35 ), nb_points 6532 ( 71 x 92 ) + nb_cores 2208 ( 46 x 48 ), nb_points 6528 ( 96 x 68 ) + nb_cores 2209 ( 47 x 47 ), nb_points 6486 ( 94 x 69 ) + nb_cores 2214 ( 54 x 41 ), nb_points 6478 ( 82 x 79 ) + nb_cores 2220 ( 60 x 37 ), nb_points 6438 ( 74 x 87 ) + nb_cores 2250 ( 45 x 50 ), nb_points 6370 ( 98 x 65 ) + nb_cores 2256 ( 48 x 47 ), nb_points 6348 ( 92 x 69 ) + nb_cores 2268 ( 54 x 42 ), nb_points 6314 ( 82 x 77 ) + nb_cores 2280 ( 60 x 38 ), nb_points 6290 ( 74 x 85 ) + nb_cores 2294 ( 62 x 37 ), nb_points 6264 ( 72 x 87 ) + nb_cores 2300 ( 46 x 50 ), nb_points 6240 ( 96 x 65 ) + nb_cores 2310 ( 55 x 42 ), nb_points 6237 ( 81 x 77 ) + nb_cores 2318 ( 61 x 38 ), nb_points 6205 ( 73 x 85 ) + nb_cores 2331 ( 63 x 37 ), nb_points 6177 ( 71 x 87 ) + nb_cores 2337 ( 57 x 41 ), nb_points 6162 ( 78 x 79 ) + nb_cores 2340 ( 60 x 39 ), nb_points 6142 ( 74 x 83 ) + nb_cores 2350 ( 47 x 50 ), nb_points 6110 ( 94 x 65 ) + nb_cores 2368 ( 64 x 37 ), nb_points 6090 ( 70 x 87 ) + nb_cores 2376 ( 54 x 44 ), nb_points 6068 ( 82 x 74 ) + nb_cores 2379 ( 61 x 39 ), nb_points 6059 ( 73 x 83 ) + nb_cores 2385 ( 53 x 45 ), nb_points 6048 ( 84 x 72 ) + nb_cores 2392 ( 92 x 26 ), nb_points 6027 ( 49 x 123 ) + nb_cores 2394 ( 57 x 42 ), nb_points 6006 ( 78 x 77 ) + nb_cores 2397 ( 51 x 47 ), nb_points 6003 ( 87 x 69 ) + nb_cores 2400 ( 48 x 50 ), nb_points 5980 ( 92 x 65 ) + nb_cores 2412 ( 36 x 67 ), nb_points 5978 ( 122 x 49 ) + nb_cores 2418 ( 62 x 39 ), nb_points 5976 ( 72 x 83 ) + nb_cores 2430 ( 54 x 45 ), nb_points 5904 ( 82 x 72 ) + nb_cores 2448 ( 48 x 51 ), nb_points 5888 ( 92 x 64 ) + nb_cores 2457 ( 39 x 63 ), nb_points 5876 ( 113 x 52 ) + nb_cores 2460 ( 60 x 41 ), nb_points 5846 ( 74 x 79 ) + nb_cores 2475 ( 55 x 45 ), nb_points 5832 ( 81 x 72 ) + nb_cores 2479 ( 67 x 37 ), nb_points 5829 ( 67 x 87 ) + nb_cores 2480 ( 80 x 31 ), nb_points 5824 ( 56 x 104 ) + nb_cores 2484 ( 54 x 46 ), nb_points 5822 ( 82 x 71 ) + nb_cores 2485 ( 71 x 35 ), nb_points 5796 ( 63 x 92 ) + nb_cores 2496 ( 96 x 26 ), nb_points 5781 ( 47 x 123 ) + nb_cores 2501 ( 61 x 41 ), nb_points 5767 ( 73 x 79 ) + nb_cores 2516 ( 68 x 37 ), nb_points 5742 ( 66 x 87 ) + nb_cores 2520 ( 60 x 42 ), nb_points 5698 ( 74 x 77 ) + nb_cores 2538 ( 54 x 47 ), nb_points 5658 ( 82 x 69 ) + nb_cores 2550 ( 51 x 50 ), nb_points 5655 ( 87 x 65 ) + nb_cores 2562 ( 61 x 42 ), nb_points 5621 ( 73 x 77 ) + nb_cores 2565 ( 57 x 45 ), nb_points 5616 ( 78 x 72 ) + nb_cores 2583 ( 63 x 41 ), nb_points 5609 ( 71 x 79 ) + nb_cores 2584 ( 76 x 34 ), nb_points 5605 ( 59 x 95 ) + nb_cores 2585 ( 55 x 47 ), nb_points 5589 ( 81 x 69 ) + nb_cores 2590 ( 70 x 37 ), nb_points 5568 ( 64 x 87 ) + nb_cores 2604 ( 62 x 42 ), nb_points 5544 ( 72 x 77 ) + nb_cores 2613 ( 39 x 67 ), nb_points 5537 ( 113 x 49 ) + nb_cores 2622 ( 69 x 38 ), nb_points 5525 ( 65 x 85 ) + nb_cores 2625 ( 75 x 35 ), nb_points 5520 ( 60 x 92 ) + nb_cores 2627 ( 71 x 37 ), nb_points 5481 ( 63 x 87 ) + nb_cores 2640 ( 60 x 44 ), nb_points 5476 ( 74 x 74 ) + nb_cores 2646 ( 42 x 63 ), nb_points 5460 ( 105 x 52 ) + nb_cores 2660 ( 76 x 35 ), nb_points 5428 ( 59 x 92 ) + nb_cores 2664 ( 72 x 37 ), nb_points 5394 ( 62 x 87 ) + nb_cores 2679 ( 57 x 47 ), nb_points 5382 ( 78 x 69 ) + nb_cores 2698 ( 71 x 38 ), nb_points 5355 ( 63 x 85 ) + nb_cores 2700 ( 60 x 45 ), nb_points 5328 ( 74 x 72 ) + nb_cores 2720 ( 80 x 34 ), nb_points 5320 ( 56 x 95 ) + nb_cores 2726 ( 58 x 47 ), nb_points 5313 ( 77 x 69 ) + nb_cores 2730 ( 39 x 70 ), nb_points 5311 ( 113 x 47 ) + nb_cores 2736 ( 72 x 38 ), nb_points 5270 ( 62 x 85 ) + nb_cores 2745 ( 61 x 45 ), nb_points 5256 ( 73 x 72 ) + nb_cores 2754 ( 54 x 51 ), nb_points 5248 ( 82 x 64 ) + nb_cores 2760 ( 92 x 30 ), nb_points 5243 ( 49 x 107 ) + nb_cores 2769 ( 71 x 39 ), nb_points 5229 ( 63 x 83 ) + nb_cores 2775 ( 75 x 37 ), nb_points 5220 ( 60 x 87 ) + nb_cores 2784 ( 96 x 29 ), nb_points 5217 ( 47 x 111 ) + nb_cores 2788 ( 68 x 41 ), nb_points 5214 ( 66 x 79 ) + nb_cores 2790 ( 62 x 45 ), nb_points 5184 ( 72 x 72 ) + nb_cores 2800 ( 80 x 35 ), nb_points 5152 ( 56 x 92 ) + nb_cores 2808 ( 72 x 39 ), nb_points 5146 ( 62 x 83 ) + nb_cores 2812 ( 76 x 37 ), nb_points 5133 ( 59 x 87 ) + nb_cores 2820 ( 60 x 47 ), nb_points 5106 ( 74 x 69 ) + nb_cores 2835 ( 45 x 63 ), nb_points 5096 ( 98 x 52 ) + nb_cores 2850 ( 57 x 50 ), nb_points 5070 ( 78 x 65 ) + nb_cores 2867 ( 61 x 47 ), nb_points 5037 ( 73 x 69 ) + nb_cores 2880 ( 72 x 40 ), nb_points 5022 ( 62 x 81 ) + nb_cores 2888 ( 76 x 38 ), nb_points 5015 ( 59 x 85 ) + nb_cores 2898 ( 46 x 63 ), nb_points 4992 ( 96 x 52 ) + nb_cores 2911 ( 71 x 41 ), nb_points 4977 ( 63 x 79 ) + nb_cores 2914 ( 62 x 47 ), nb_points 4968 ( 72 x 69 ) + nb_cores 2923 ( 79 x 37 ), nb_points 4959 ( 57 x 87 ) + nb_cores 2940 ( 70 x 42 ), nb_points 4928 ( 64 x 77 ) + nb_cores 2952 ( 72 x 41 ), nb_points 4898 ( 62 x 79 ) + nb_cores 2960 ( 80 x 37 ), nb_points 4872 ( 56 x 87 ) + nb_cores 2982 ( 71 x 42 ), nb_points 4851 ( 63 x 77 ) + nb_cores 3000 ( 60 x 50 ), nb_points 4810 ( 74 x 65 ) + nb_cores 3015 ( 45 x 67 ), nb_points 4802 ( 98 x 49 ) + nb_cores 3024 ( 72 x 42 ), nb_points 4774 ( 62 x 77 ) + nb_cores 3040 ( 80 x 38 ), nb_points 4760 ( 56 x 85 ) + nb_cores 3050 ( 61 x 50 ), nb_points 4745 ( 73 x 65 ) + nb_cores 3060 ( 60 x 51 ), nb_points 4736 ( 74 x 64 ) + nb_cores 3080 ( 40 x 77 ), nb_points 4730 ( 110 x 43 ) + nb_cores 3082 ( 46 x 67 ), nb_points 4704 ( 96 x 49 ) + nb_cores 3100 ( 62 x 50 ), nb_points 4680 ( 72 x 65 ) + nb_cores 3111 ( 61 x 51 ), nb_points 4672 ( 73 x 64 ) + nb_cores 3116 ( 76 x 41 ), nb_points 4661 ( 59 x 79 ) + nb_cores 3120 ( 80 x 39 ), nb_points 4648 ( 56 x 83 ) + nb_cores 3145 ( 85 x 37 ), nb_points 4611 ( 53 x 87 ) + nb_cores 3149 ( 47 x 67 ), nb_points 4606 ( 94 x 49 ) + nb_cores 3150 ( 90 x 35 ), nb_points 4600 ( 50 x 92 ) + nb_cores 3168 ( 72 x 44 ), nb_points 4588 ( 62 x 74 ) + nb_cores 3192 ( 76 x 42 ), nb_points 4543 ( 59 x 77 ) + nb_cores 3195 ( 71 x 45 ), nb_points 4536 ( 63 x 72 ) + nb_cores 3213 ( 51 x 63 ), nb_points 4524 ( 87 x 52 ) + nb_cores 3216 ( 48 x 67 ), nb_points 4508 ( 92 x 49 ) + nb_cores 3230 ( 85 x 38 ), nb_points 4505 ( 53 x 85 ) + nb_cores 3239 ( 79 x 41 ), nb_points 4503 ( 57 x 79 ) + nb_cores 3240 ( 72 x 45 ), nb_points 4464 ( 62 x 72 ) + nb_cores 3280 ( 80 x 41 ), nb_points 4424 ( 56 x 79 ) + nb_cores 3290 ( 94 x 35 ), nb_points 4416 ( 48 x 92 ) + nb_cores 3290 ( 70 x 47 ), nb_points 4416 ( 64 x 69 ) + nb_cores 3312 ( 72 x 46 ), nb_points 4402 ( 62 x 71 ) + nb_cores 3315 ( 85 x 39 ), nb_points 4399 ( 53 x 83 ) + nb_cores 3318 ( 79 x 42 ), nb_points 4389 ( 57 x 77 ) + nb_cores 3330 ( 90 x 37 ), nb_points 4350 ( 50 x 87 ) + nb_cores 3337 ( 71 x 47 ), nb_points 4347 ( 63 x 69 ) + nb_cores 3348 ( 54 x 62 ), nb_points 4346 ( 82 x 53 ) + nb_cores 3360 ( 80 x 42 ), nb_points 4312 ( 56 x 77 ) + nb_cores 3384 ( 72 x 47 ), nb_points 4278 ( 62 x 69 ) + nb_cores 3402 ( 54 x 63 ), nb_points 4264 ( 82 x 52 ) + nb_cores 3404 ( 92 x 37 ), nb_points 4263 ( 49 x 87 ) + nb_cores 3420 ( 76 x 45 ), nb_points 4248 ( 59 x 72 ) + nb_cores 3444 ( 82 x 42 ), nb_points 4235 ( 55 x 77 ) + nb_cores 3450 ( 46 x 75 ), nb_points 4224 ( 96 x 44 ) + nb_cores 3456 ( 72 x 48 ), nb_points 4216 ( 62 x 68 ) + nb_cores 3465 ( 55 x 63 ), nb_points 4212 ( 81 x 52 ) + nb_cores 3478 ( 94 x 37 ), nb_points 4176 ( 48 x 87 ) + nb_cores 3496 ( 92 x 38 ), nb_points 4165 ( 49 x 85 ) + nb_cores 3500 ( 70 x 50 ), nb_points 4160 ( 64 x 65 ) + nb_cores 3510 ( 90 x 39 ), nb_points 4150 ( 50 x 83 ) + nb_cores 3520 ( 80 x 44 ), nb_points 4144 ( 56 x 74 ) + nb_cores 3525 ( 47 x 75 ), nb_points 4136 ( 94 x 44 ) + nb_cores 3534 ( 57 x 62 ), nb_points 4134 ( 78 x 53 ) + nb_cores 3542 ( 46 x 77 ), nb_points 4128 ( 96 x 43 ) + nb_cores 3550 ( 71 x 50 ), nb_points 4095 ( 63 x 65 ) + nb_cores 3552 ( 96 x 37 ), nb_points 4089 ( 47 x 87 ) + nb_cores 3570 ( 85 x 42 ), nb_points 4081 ( 53 x 77 ) + nb_cores 3572 ( 76 x 47 ), nb_points 4071 ( 59 x 69 ) + nb_cores 3588 ( 92 x 39 ), nb_points 4067 ( 49 x 83 ) + nb_cores 3591 ( 57 x 63 ), nb_points 4056 ( 78 x 52 ) + nb_cores 3600 ( 72 x 50 ), nb_points 4030 ( 62 x 65 ) + nb_cores 3618 ( 54 x 67 ), nb_points 4018 ( 82 x 49 ) + nb_cores 3648 ( 96 x 38 ), nb_points 3995 ( 47 x 85 ) + nb_cores 3666 ( 94 x 39 ), nb_points 3984 ( 48 x 83 ) + nb_cores 3672 ( 72 x 51 ), nb_points 3968 ( 62 x 64 ) + nb_cores 3690 ( 90 x 41 ), nb_points 3950 ( 50 x 79 ) + nb_cores 3710 ( 53 x 70 ), nb_points 3948 ( 84 x 47 ) + nb_cores 3713 ( 79 x 47 ), nb_points 3933 ( 57 x 69 ) + nb_cores 3720 ( 60 x 62 ), nb_points 3922 ( 74 x 53 ) + nb_cores 3735 ( 45 x 83 ), nb_points 3920 ( 98 x 40 ) + nb_cores 3737 ( 101 x 37 ), nb_points 3915 ( 45 x 87 ) + nb_cores 3744 ( 96 x 39 ), nb_points 3901 ( 47 x 83 ) + nb_cores 3750 ( 75 x 50 ), nb_points 3900 ( 60 x 65 ) + nb_cores 3760 ( 80 x 47 ), nb_points 3864 ( 56 x 69 ) + nb_cores 3780 ( 60 x 63 ), nb_points 3848 ( 74 x 52 ) + nb_cores 3800 ( 76 x 50 ), nb_points 3835 ( 59 x 65 ) + nb_cores 3811 ( 103 x 37 ), nb_points 3828 ( 44 x 87 ) + nb_cores 3819 ( 57 x 67 ), nb_points 3822 ( 78 x 49 ) + nb_cores 3825 ( 85 x 45 ), nb_points 3816 ( 53 x 72 ) + nb_cores 3840 ( 96 x 40 ), nb_points 3807 ( 47 x 81 ) + nb_cores 3843 ( 61 x 63 ), nb_points 3796 ( 73 x 52 ) + nb_cores 3854 ( 94 x 41 ), nb_points 3792 ( 48 x 79 ) + nb_cores 3864 ( 92 x 42 ), nb_points 3773 ( 49 x 77 ) + nb_cores 3885 ( 111 x 35 ), nb_points 3772 ( 41 x 92 ) + nb_cores 3900 ( 78 x 50 ), nb_points 3770 ( 58 x 65 ) + nb_cores 3901 ( 47 x 83 ), nb_points 3760 ( 94 x 40 ) + nb_cores 3906 ( 62 x 63 ), nb_points 3744 ( 72 x 52 ) + nb_cores 3914 ( 103 x 38 ), nb_points 3740 ( 44 x 85 ) + nb_cores 3936 ( 96 x 41 ), nb_points 3713 ( 47 x 79 ) + nb_cores 3948 ( 94 x 42 ), nb_points 3696 ( 48 x 77 ) + nb_cores 3969 ( 63 x 63 ), nb_points 3692 ( 71 x 52 ) + nb_cores 3984 ( 48 x 83 ), nb_points 3680 ( 92 x 40 ) + nb_cores 3990 ( 57 x 70 ), nb_points 3666 ( 78 x 47 ) + nb_cores 3995 ( 85 x 47 ), nb_points 3657 ( 53 x 69 ) + nb_cores 3996 ( 108 x 37 ), nb_points 3654 ( 42 x 87 ) + nb_cores 4000 ( 80 x 50 ), nb_points 3640 ( 56 x 65 ) + nb_cores 4020 ( 60 x 67 ), nb_points 3626 ( 74 x 49 ) + nb_cores 4032 ( 96 x 42 ), nb_points 3619 ( 47 x 77 ) + nb_cores 4050 ( 90 x 45 ), nb_points 3600 ( 50 x 72 ) + nb_cores 4080 ( 80 x 51 ), nb_points 3584 ( 56 x 64 ) + nb_cores 4087 ( 61 x 67 ), nb_points 3577 ( 73 x 49 ) + nb_cores 4100 ( 82 x 50 ), nb_points 3575 ( 55 x 65 ) + nb_cores 4104 ( 108 x 38 ), nb_points 3570 ( 42 x 85 ) + nb_cores 4107 ( 111 x 37 ), nb_points 3567 ( 41 x 87 ) + nb_cores 4120 ( 103 x 40 ), nb_points 3564 ( 44 x 81 ) + nb_cores 4136 ( 94 x 44 ), nb_points 3552 ( 48 x 74 ) + nb_cores 4140 ( 92 x 45 ), nb_points 3528 ( 49 x 72 ) + nb_cores 4158 ( 54 x 77 ), nb_points 3526 ( 82 x 43 ) + nb_cores 4182 ( 82 x 51 ), nb_points 3520 ( 55 x 64 ) + nb_cores 4183 ( 89 x 47 ), nb_points 3519 ( 51 x 69 ) + nb_cores 4200 ( 60 x 70 ), nb_points 3478 ( 74 x 47 ) + nb_cores 4223 ( 103 x 41 ), nb_points 3476 ( 44 x 79 ) + nb_cores 4230 ( 90 x 47 ), nb_points 3450 ( 50 x 69 ) + nb_cores 4250 ( 85 x 50 ), nb_points 3445 ( 53 x 65 ) + nb_cores 4266 ( 54 x 79 ), nb_points 3444 ( 82 x 42 ) + nb_cores 4270 ( 61 x 70 ), nb_points 3431 ( 73 x 47 ) + nb_cores 4288 ( 64 x 67 ), nb_points 3430 ( 70 x 49 ) + nb_cores 4320 ( 96 x 45 ), nb_points 3384 ( 47 x 72 ) + nb_cores 4324 ( 92 x 47 ), nb_points 3381 ( 49 x 69 ) + nb_cores 4347 ( 69 x 63 ), nb_points 3380 ( 65 x 52 ) + nb_cores 4374 ( 54 x 81 ), nb_points 3362 ( 82 x 41 ) + nb_cores 4389 ( 57 x 77 ), nb_points 3354 ( 78 x 43 ) + nb_cores 4392 ( 72 x 61 ), nb_points 3348 ( 62 x 54 ) + nb_cores 4402 ( 71 x 62 ), nb_points 3339 ( 63 x 53 ) + nb_cores 4410 ( 70 x 63 ), nb_points 3328 ( 64 x 52 ) + nb_cores 4418 ( 94 x 47 ), nb_points 3312 ( 48 x 69 ) + nb_cores 4440 ( 120 x 37 ), nb_points 3306 ( 38 x 87 ) + nb_cores 4464 ( 72 x 62 ), nb_points 3286 ( 62 x 53 ) + nb_cores 4473 ( 71 x 63 ), nb_points 3276 ( 63 x 52 ) + nb_cores 4500 ( 90 x 50 ), nb_points 3250 ( 50 x 65 ) + nb_cores 4512 ( 96 x 47 ), nb_points 3243 ( 47 x 69 ) + nb_cores 4536 ( 72 x 63 ), nb_points 3224 ( 62 x 52 ) + nb_cores 4575 ( 61 x 75 ), nb_points 3212 ( 73 x 44 ) + nb_cores 4590 ( 54 x 85 ), nb_points 3198 ( 82 x 39 ) + nb_cores 4600 ( 92 x 50 ), nb_points 3185 ( 49 x 65 ) + nb_cores 4620 ( 60 x 77 ), nb_points 3182 ( 74 x 43 ) + nb_cores 4635 ( 103 x 45 ), nb_points 3168 ( 44 x 72 ) + nb_cores 4662 ( 111 x 42 ), nb_points 3157 ( 41 x 77 ) + nb_cores 4680 ( 90 x 52 ), nb_points 3150 ( 50 x 63 ) + nb_cores 4690 ( 70 x 67 ), nb_points 3136 ( 64 x 49 ) + nb_cores 4700 ( 94 x 50 ), nb_points 3120 ( 48 x 65 ) + nb_cores 4740 ( 60 x 79 ), nb_points 3108 ( 74 x 42 ) + nb_cores 4747 ( 101 x 47 ), nb_points 3105 ( 45 x 69 ) + nb_cores 4752 ( 72 x 66 ), nb_points 3100 ( 62 x 50 ) + nb_cores 4757 ( 71 x 67 ), nb_points 3087 ( 63 x 49 ) + nb_cores 4788 ( 76 x 63 ), nb_points 3068 ( 59 x 52 ) + nb_cores 4800 ( 96 x 50 ), nb_points 3055 ( 47 x 65 ) + nb_cores 4824 ( 72 x 67 ), nb_points 3038 ( 62 x 49 ) + nb_cores 4841 ( 103 x 47 ), nb_points 3036 ( 44 x 69 ) + nb_cores 4860 ( 108 x 45 ), nb_points 3024 ( 42 x 72 ) + nb_cores 4896 ( 96 x 51 ), nb_points 3008 ( 47 x 64 ) + nb_cores 4914 ( 117 x 42 ), nb_points 3003 ( 39 x 77 ) + nb_cores 4920 ( 120 x 41 ), nb_points 3002 ( 38 x 79 ) + nb_cores 4941 ( 61 x 81 ), nb_points 2993 ( 73 x 41 ) + nb_cores 4944 ( 103 x 48 ), nb_points 2992 ( 44 x 68 ) + nb_cores 4950 ( 99 x 50 ), nb_points 2990 ( 46 x 65 ) + nb_cores 4958 ( 74 x 67 ), nb_points 2989 ( 61 x 49 ) + nb_cores 4960 ( 80 x 62 ), nb_points 2968 ( 56 x 53 ) + nb_cores 4970 ( 71 x 70 ), nb_points 2961 ( 63 x 47 ) + nb_cores 4980 ( 60 x 83 ), nb_points 2960 ( 74 x 40 ) + nb_cores 4995 ( 111 x 45 ), nb_points 2952 ( 41 x 72 ) + nb_cores 5016 ( 76 x 66 ), nb_points 2950 ( 59 x 50 ) + nb_cores 5025 ( 75 x 67 ), nb_points 2940 ( 60 x 49 ) + nb_cores 5040 ( 80 x 63 ), nb_points 2912 ( 56 x 52 ) + nb_cores 5076 ( 108 x 47 ), nb_points 2898 ( 42 x 69 ) + nb_cores 5092 ( 76 x 67 ), nb_points 2891 ( 59 x 49 ) + nb_cores 5100 ( 60 x 85 ), nb_points 2886 ( 74 x 39 ) + nb_cores 5130 ( 114 x 45 ), nb_points 2880 ( 40 x 72 ) + nb_cores 5150 ( 103 x 50 ), nb_points 2860 ( 44 x 65 ) + nb_cores 5184 ( 72 x 72 ), nb_points 2852 ( 62 x 46 ) + nb_cores 5185 ( 61 x 85 ), nb_points 2847 ( 73 x 39 ) + nb_cores 5217 ( 111 x 47 ), nb_points 2829 ( 41 x 69 ) + nb_cores 5250 ( 70 x 75 ), nb_points 2816 ( 64 x 44 ) + nb_cores 5265 ( 117 x 45 ), nb_points 2808 ( 39 x 72 ) + nb_cores 5280 ( 80 x 66 ), nb_points 2800 ( 56 x 50 ) + nb_cores 5293 ( 79 x 67 ), nb_points 2793 ( 57 x 49 ) + nb_cores 5320 ( 76 x 70 ), nb_points 2773 ( 59 x 47 ) + nb_cores 5325 ( 71 x 75 ), nb_points 2772 ( 63 x 44 ) + nb_cores 5355 ( 85 x 63 ), nb_points 2756 ( 53 x 52 ) + nb_cores 5360 ( 80 x 67 ), nb_points 2744 ( 56 x 49 ) + nb_cores 5400 ( 72 x 75 ), nb_points 2728 ( 62 x 44 ) + nb_cores 5460 ( 78 x 70 ), nb_points 2726 ( 58 x 47 ) + nb_cores 5467 ( 71 x 77 ), nb_points 2709 ( 63 x 43 ) + nb_cores 5481 ( 87 x 63 ), nb_points 2704 ( 52 x 52 ) + nb_cores 5490 ( 90 x 61 ), nb_points 2700 ( 50 x 54 ) + nb_cores 5494 ( 82 x 67 ), nb_points 2695 ( 55 x 49 ) + nb_cores 5499 ( 117 x 47 ), nb_points 2691 ( 39 x 69 ) + nb_cores 5508 ( 108 x 51 ), nb_points 2688 ( 42 x 64 ) + nb_cores 5530 ( 79 x 70 ), nb_points 2679 ( 57 x 47 ) + nb_cores 5544 ( 72 x 77 ), nb_points 2666 ( 62 x 43 ) + nb_cores 5550 ( 111 x 50 ), nb_points 2665 ( 41 x 65 ) + nb_cores 5580 ( 90 x 62 ), nb_points 2650 ( 50 x 53 ) + nb_cores 5600 ( 80 x 70 ), nb_points 2632 ( 56 x 47 ) + nb_cores 5640 ( 120 x 47 ), nb_points 2622 ( 38 x 69 ) + nb_cores 5670 ( 90 x 63 ), nb_points 2600 ( 50 x 52 ) + nb_cores 5695 ( 85 x 67 ), nb_points 2597 ( 53 x 49 ) + nb_cores 5700 ( 76 x 75 ), nb_points 2596 ( 59 x 44 ) + nb_cores 5734 ( 94 x 61 ), nb_points 2592 ( 48 x 54 ) + nb_cores 5740 ( 82 x 70 ), nb_points 2585 ( 55 x 47 ) + nb_cores 5751 ( 71 x 81 ), nb_points 2583 ( 63 x 41 ) + nb_cores 5760 ( 80 x 72 ), nb_points 2576 ( 56 x 46 ) + nb_cores 5780 ( 68 x 85 ), nb_points 2574 ( 66 x 39 ) + nb_cores 5796 ( 92 x 63 ), nb_points 2548 ( 49 x 52 ) + nb_cores 5828 ( 94 x 62 ), nb_points 2544 ( 48 x 53 ) + nb_cores 5832 ( 72 x 81 ), nb_points 2542 ( 62 x 41 ) + nb_cores 5850 ( 117 x 50 ), nb_points 2535 ( 39 x 65 ) + nb_cores 5893 ( 71 x 83 ), nb_points 2520 ( 63 x 40 ) + nb_cores 5922 ( 94 x 63 ), nb_points 2496 ( 48 x 52 ) + nb_cores 5950 ( 85 x 70 ), nb_points 2491 ( 53 x 47 ) + nb_cores 5976 ( 72 x 83 ), nb_points 2480 ( 62 x 40 ) + nb_cores 6000 ( 80 x 75 ), nb_points 2464 ( 56 x 44 ) + nb_cores 6030 ( 90 x 67 ), nb_points 2450 ( 50 x 49 ) + nb_cores 6048 ( 96 x 63 ), nb_points 2444 ( 47 x 52 ) + nb_cores 6120 ( 72 x 85 ), nb_points 2418 ( 62 x 39 ) + nb_cores 6157 ( 131 x 47 ), nb_points 2415 ( 35 x 69 ) + nb_cores 6160 ( 80 x 77 ), nb_points 2408 ( 56 x 43 ) + nb_cores 6164 ( 92 x 67 ), nb_points 2401 ( 49 x 49 ) + nb_cores 6204 ( 94 x 66 ), nb_points 2400 ( 48 x 50 ) + nb_cores 6230 ( 89 x 70 ), nb_points 2397 ( 51 x 47 ) + nb_cores 6237 ( 99 x 63 ), nb_points 2392 ( 46 x 52 ) + nb_cores 6258 ( 149 x 42 ), nb_points 2387 ( 31 x 77 ) + nb_cores 6262 ( 101 x 62 ), nb_points 2385 ( 45 x 53 ) + nb_cores 6283 ( 103 x 61 ), nb_points 2376 ( 44 x 54 ) + nb_cores 6298 ( 94 x 67 ), nb_points 2352 ( 48 x 49 ) + nb_cores 6300 ( 90 x 70 ), nb_points 2350 ( 50 x 47 ) + nb_cores 6345 ( 135 x 47 ), nb_points 2346 ( 34 x 69 ) + nb_cores 6363 ( 101 x 63 ), nb_points 2340 ( 45 x 52 ) + nb_cores 6375 ( 85 x 75 ), nb_points 2332 ( 53 x 44 ) + nb_cores 6390 ( 71 x 90 ), nb_points 2331 ( 63 x 37 ) + nb_cores 6432 ( 96 x 67 ), nb_points 2303 ( 47 x 49 ) + nb_cores 6460 ( 76 x 85 ), nb_points 2301 ( 59 x 39 ) + nb_cores 6480 ( 72 x 90 ), nb_points 2294 ( 62 x 37 ) + nb_cores 6489 ( 103 x 63 ), nb_points 2288 ( 44 x 52 ) + nb_cores 6545 ( 85 x 77 ), nb_points 2279 ( 53 x 43 ) + nb_cores 6550 ( 131 x 50 ), nb_points 2275 ( 35 x 65 ) + nb_cores 6580 ( 94 x 70 ), nb_points 2256 ( 48 x 47 ) + nb_cores 6624 ( 92 x 72 ), nb_points 2254 ( 49 x 46 ) + nb_cores 6640 ( 80 x 83 ), nb_points 2240 ( 56 x 40 ) + nb_cores 6678 ( 106 x 63 ), nb_points 2236 ( 43 x 52 ) + nb_cores 6696 ( 108 x 62 ), nb_points 2226 ( 42 x 53 ) + nb_cores 6715 ( 79 x 85 ), nb_points 2223 ( 57 x 39 ) + nb_cores 6720 ( 96 x 70 ), nb_points 2209 ( 47 x 47 ) + nb_cores 6750 ( 90 x 75 ), nb_points 2200 ( 50 x 44 ) + nb_cores 6800 ( 80 x 85 ), nb_points 2184 ( 56 x 39 ) + nb_cores 6840 ( 76 x 90 ), nb_points 2183 ( 59 x 37 ) + nb_cores 6882 ( 111 x 62 ), nb_points 2173 ( 41 x 53 ) + nb_cores 6900 ( 92 x 75 ), nb_points 2156 ( 49 x 44 ) + nb_cores 6930 ( 90 x 77 ), nb_points 2150 ( 50 x 43 ) + nb_cores 6970 ( 82 x 85 ), nb_points 2145 ( 55 x 39 ) + nb_cores 6993 ( 111 x 63 ), nb_points 2132 ( 41 x 52 ) + nb_cores 7040 ( 80 x 88 ), nb_points 2128 ( 56 x 38 ) + nb_cores 7050 ( 94 x 75 ), nb_points 2112 ( 48 x 44 ) + nb_cores 7084 ( 92 x 77 ), nb_points 2107 ( 49 x 43 ) + nb_cores 7110 ( 90 x 79 ), nb_points 2100 ( 50 x 42 ) + nb_cores 7182 ( 114 x 63 ), nb_points 2080 ( 40 x 52 ) + nb_cores 7200 ( 96 x 75 ), nb_points 2068 ( 47 x 44 ) + nb_cores 7225 ( 85 x 85 ), nb_points 2067 ( 53 x 39 ) + nb_cores 7236 ( 108 x 67 ), nb_points 2058 ( 42 x 49 ) + nb_cores 7290 ( 90 x 81 ), nb_points 2050 ( 50 x 41 ) + nb_cores 7344 ( 72 x 102 ), nb_points 2046 ( 62 x 33 ) + nb_cores 7371 ( 117 x 63 ), nb_points 2028 ( 39 x 52 ) + nb_cores 7392 ( 96 x 77 ), nb_points 2021 ( 47 x 43 ) + nb_cores 7426 ( 94 x 79 ), nb_points 2016 ( 48 x 42 ) + nb_cores 7437 ( 111 x 67 ), nb_points 2009 ( 41 x 49 ) + nb_cores 7470 ( 90 x 83 ), nb_points 2000 ( 50 x 40 ) + nb_cores 7560 ( 108 x 70 ), nb_points 1974 ( 42 x 47 ) + nb_cores 7614 ( 94 x 81 ), nb_points 1968 ( 48 x 41 ) + nb_cores 7636 ( 92 x 83 ), nb_points 1960 ( 49 x 40 ) + nb_cores 7650 ( 90 x 85 ), nb_points 1950 ( 50 x 39 ) + nb_cores 7725 ( 103 x 75 ), nb_points 1936 ( 44 x 44 ) + nb_cores 7770 ( 111 x 70 ), nb_points 1927 ( 41 x 47 ) + nb_cores 7802 ( 94 x 83 ), nb_points 1920 ( 48 x 40 ) + nb_cores 7820 ( 92 x 85 ), nb_points 1911 ( 49 x 39 ) + nb_cores 7905 ( 85 x 93 ), nb_points 1908 ( 53 x 36 ) + nb_cores 7920 ( 120 x 66 ), nb_points 1900 ( 38 x 50 ) + nb_cores 7920 ( 90 x 88 ), nb_points 1900 ( 50 x 38 ) + nb_cores 7931 ( 103 x 77 ), nb_points 1892 ( 44 x 43 ) + nb_cores 7968 ( 96 x 83 ), nb_points 1880 ( 47 x 40 ) + nb_cores 7990 ( 94 x 85 ), nb_points 1872 ( 48 x 39 ) + nb_cores 8040 ( 120 x 67 ), nb_points 1862 ( 38 x 49 ) + nb_cores 8100 ( 108 x 75 ), nb_points 1848 ( 42 x 44 ) + nb_cores 8160 ( 96 x 85 ), nb_points 1833 ( 47 x 39 ) + nb_cores 8253 ( 131 x 63 ), nb_points 1820 ( 35 x 52 ) + nb_cores 8280 ( 92 x 90 ), nb_points 1813 ( 49 x 37 ) + nb_cores 8316 ( 108 x 77 ), nb_points 1806 ( 42 x 43 ) + nb_cores 8325 ( 111 x 75 ), nb_points 1804 ( 41 x 44 ) + nb_cores 8370 ( 90 x 93 ), nb_points 1800 ( 50 x 36 ) + nb_cores 8400 ( 120 x 70 ), nb_points 1786 ( 38 x 47 ) + nb_cores 8460 ( 94 x 90 ), nb_points 1776 ( 48 x 37 ) + nb_cores 8505 ( 135 x 63 ), nb_points 1768 ( 34 x 52 ) + nb_cores 8532 ( 108 x 79 ), nb_points 1764 ( 42 x 42 ) + nb_cores 8547 ( 111 x 77 ), nb_points 1763 ( 41 x 43 ) + nb_cores 8549 ( 103 x 83 ), nb_points 1760 ( 44 x 40 ) + nb_cores 8585 ( 101 x 85 ), nb_points 1755 ( 45 x 39 ) + nb_cores 8640 ( 96 x 90 ), nb_points 1739 ( 47 x 37 ) + nb_cores 8712 ( 72 x 121 ), nb_points 1736 ( 62 x 28 ) + nb_cores 8742 ( 94 x 93 ), nb_points 1728 ( 48 x 36 ) + nb_cores 8748 ( 108 x 81 ), nb_points 1722 ( 42 x 41 ) + nb_cores 8755 ( 103 x 85 ), nb_points 1716 ( 44 x 39 ) + nb_cores 8777 ( 131 x 67 ), nb_points 1715 ( 35 x 49 ) + nb_cores 8880 ( 120 x 74 ), nb_points 1710 ( 38 x 45 ) + nb_cores 8910 ( 90 x 99 ), nb_points 1700 ( 50 x 34 ) + nb_cores 8910 ( 135 x 66 ), nb_points 1700 ( 34 x 50 ) + nb_cores 8925 ( 85 x 105 ), nb_points 1696 ( 53 x 32 ) + nb_cores 8928 ( 96 x 93 ), nb_points 1692 ( 47 x 36 ) + nb_cores 8964 ( 108 x 83 ), nb_points 1680 ( 42 x 40 ) + nb_cores 9000 ( 120 x 75 ), nb_points 1672 ( 38 x 44 ) + nb_cores 9045 ( 135 x 67 ), nb_points 1666 ( 34 x 49 ) + nb_cores 9072 ( 144 x 63 ), nb_points 1664 ( 32 x 52 ) + nb_cores 9170 ( 131 x 70 ), nb_points 1645 ( 35 x 47 ) + nb_cores 9180 ( 108 x 85 ), nb_points 1638 ( 42 x 39 ) + nb_cores 9240 ( 120 x 77 ), nb_points 1634 ( 38 x 43 ) + nb_cores 9270 ( 103 x 90 ), nb_points 1628 ( 44 x 37 ) + nb_cores 9360 ( 80 x 117 ), nb_points 1624 ( 56 x 29 ) + nb_cores 9380 ( 140 x 67 ), nb_points 1617 ( 33 x 49 ) + nb_cores 9387 ( 149 x 63 ), nb_points 1612 ( 31 x 52 ) + nb_cores 9432 ( 131 x 72 ), nb_points 1610 ( 35 x 46 ) + nb_cores 9435 ( 111 x 85 ), nb_points 1599 ( 41 x 39 ) + nb_cores 9450 ( 135 x 70 ), nb_points 1598 ( 34 x 47 ) + nb_cores 9480 ( 120 x 79 ), nb_points 1596 ( 38 x 42 ) + nb_cores 9540 ( 106 x 90 ), nb_points 1591 ( 43 x 37 ) + nb_cores 9579 ( 103 x 93 ), nb_points 1584 ( 44 x 36 ) + nb_cores 9648 ( 144 x 67 ), nb_points 1568 ( 32 x 49 ) + nb_cores 9690 ( 114 x 85 ), nb_points 1560 ( 40 x 39 ) + nb_cores 9720 ( 108 x 90 ), nb_points 1554 ( 42 x 37 ) + nb_cores 9792 ( 96 x 102 ), nb_points 1551 ( 47 x 33 ) + nb_cores 9810 ( 90 x 109 ), nb_points 1550 ( 50 x 31 ) + nb_cores 9825 ( 131 x 75 ), nb_points 1540 ( 35 x 44 ) + nb_cores 9870 ( 94 x 105 ), nb_points 1536 ( 48 x 32 ) + nb_cores 9945 ( 117 x 85 ), nb_points 1521 ( 39 x 39 ) + nb_cores 9960 ( 120 x 83 ), nb_points 1520 ( 38 x 40 ) + nb_cores 9983 ( 149 x 67 ), nb_points 1519 ( 31 x 49 ) + nb_cores 9990 ( 111 x 90 ), nb_points 1517 ( 41 x 37 ) + nb_cores 10044 ( 108 x 93 ), nb_points 1512 ( 42 x 36 ) + nb_cores 10080 ( 96 x 105 ), nb_points 1504 ( 47 x 32 ) + nb_cores 10080 ( 144 x 70 ), nb_points 1504 ( 32 x 47 ) + nb_cores 10125 ( 135 x 75 ), nb_points 1496 ( 34 x 44 ) + nb_cores 10200 ( 120 x 85 ), nb_points 1482 ( 38 x 39 ) + nb_cores 10260 ( 114 x 90 ), nb_points 1480 ( 40 x 37 ) + nb_cores 10323 ( 111 x 93 ), nb_points 1476 ( 41 x 36 ) + nb_cores 10349 ( 131 x 79 ), nb_points 1470 ( 35 x 42 ) + nb_cores 10395 ( 135 x 77 ), nb_points 1462 ( 34 x 43 ) + nb_cores 10430 ( 149 x 70 ), nb_points 1457 ( 31 x 47 ) + nb_cores 10500 ( 140 x 75 ), nb_points 1452 ( 33 x 44 ) + nb_cores 10530 ( 117 x 90 ), nb_points 1443 ( 39 x 37 ) + nb_cores 10602 ( 114 x 93 ), nb_points 1440 ( 40 x 36 ) + nb_cores 10611 ( 131 x 81 ), nb_points 1435 ( 35 x 41 ) + nb_cores 10665 ( 135 x 79 ), nb_points 1428 ( 34 x 42 ) + nb_cores 10720 ( 160 x 67 ), nb_points 1421 ( 29 x 49 ) + nb_cores 10780 ( 140 x 77 ), nb_points 1419 ( 33 x 43 ) + nb_cores 10800 ( 120 x 90 ), nb_points 1406 ( 38 x 37 ) + nb_cores 10873 ( 131 x 83 ), nb_points 1400 ( 35 x 40 ) + nb_cores 10935 ( 135 x 81 ), nb_points 1394 ( 34 x 41 ) + nb_cores 10998 ( 94 x 117 ), nb_points 1392 ( 48 x 29 ) + nb_cores 11016 ( 108 x 102 ), nb_points 1386 ( 42 x 33 ) + nb_cores 11088 ( 144 x 77 ), nb_points 1376 ( 32 x 43 ) + nb_cores 11132 ( 92 x 121 ), nb_points 1372 ( 49 x 28 ) + nb_cores 11135 ( 131 x 85 ), nb_points 1365 ( 35 x 39 ) + nb_cores 11175 ( 149 x 75 ), nb_points 1364 ( 31 x 44 ) + nb_cores 11200 ( 160 x 70 ), nb_points 1363 ( 29 x 47 ) + nb_cores 11205 ( 135 x 83 ), nb_points 1360 ( 34 x 40 ) + nb_cores 11322 ( 111 x 102 ), nb_points 1353 ( 41 x 33 ) + nb_cores 11340 ( 108 x 105 ), nb_points 1344 ( 42 x 32 ) + nb_cores 11473 ( 149 x 77 ), nb_points 1333 ( 31 x 43 ) + nb_cores 11475 ( 135 x 85 ), nb_points 1326 ( 34 x 39 ) + nb_cores 11591 ( 173 x 67 ), nb_points 1323 ( 27 x 49 ) + nb_cores 11616 ( 96 x 121 ), nb_points 1316 ( 47 x 28 ) + nb_cores 11655 ( 111 x 105 ), nb_points 1312 ( 41 x 32 ) + nb_cores 11771 ( 149 x 79 ), nb_points 1302 ( 31 x 42 ) + nb_cores 11790 ( 131 x 90 ), nb_points 1295 ( 35 x 37 ) + nb_cores 11880 ( 120 x 99 ), nb_points 1292 ( 38 x 34 ) + nb_cores 11880 ( 135 x 88 ), nb_points 1292 ( 34 x 38 ) + nb_cores 11900 ( 140 x 85 ), nb_points 1287 ( 33 x 39 ) + nb_cores 11952 ( 144 x 83 ), nb_points 1280 ( 32 x 40 ) + nb_cores 12000 ( 160 x 75 ), nb_points 1276 ( 29 x 44 ) + nb_cores 12060 ( 180 x 67 ), nb_points 1274 ( 26 x 49 ) + nb_cores 12069 ( 149 x 81 ), nb_points 1271 ( 31 x 41 ) + nb_cores 12096 ( 96 x 126 ), nb_points 1269 ( 47 x 27 ) + nb_cores 12150 ( 135 x 90 ), nb_points 1258 ( 34 x 37 ) + nb_cores 12240 ( 144 x 85 ), nb_points 1248 ( 32 x 39 ) + nb_cores 12320 ( 160 x 77 ), nb_points 1247 ( 29 x 43 ) + nb_cores 12367 ( 149 x 83 ), nb_points 1240 ( 31 x 40 ) + nb_cores 12463 ( 103 x 121 ), nb_points 1232 ( 44 x 28 ) + nb_cores 12543 ( 111 x 113 ), nb_points 1230 ( 41 x 30 ) + nb_cores 12555 ( 135 x 93 ), nb_points 1224 ( 34 x 36 ) + nb_cores 12600 ( 120 x 105 ), nb_points 1216 ( 38 x 32 ) + nb_cores 12665 ( 149 x 85 ), nb_points 1209 ( 31 x 39 ) + nb_cores 12826 ( 106 x 121 ), nb_points 1204 ( 43 x 28 ) + nb_cores 12865 ( 155 x 83 ), nb_points 1200 ( 30 x 40 ) + nb_cores 12960 ( 144 x 90 ), nb_points 1184 ( 32 x 37 ) + nb_cores 13068 ( 108 x 121 ), nb_points 1176 ( 42 x 28 ) + nb_cores 13152 ( 96 x 137 ), nb_points 1175 ( 47 x 25 ) + nb_cores 13175 ( 155 x 85 ), nb_points 1170 ( 30 x 39 ) + nb_cores 13280 ( 160 x 83 ), nb_points 1160 ( 29 x 40 ) + nb_cores 13362 ( 131 x 102 ), nb_points 1155 ( 35 x 33 ) + nb_cores 13392 ( 144 x 93 ), nb_points 1152 ( 32 x 36 ) + nb_cores 13410 ( 149 x 90 ), nb_points 1147 ( 31 x 37 ) + nb_cores 13500 ( 180 x 75 ), nb_points 1144 ( 26 x 44 ) + nb_cores 13560 ( 120 x 113 ), nb_points 1140 ( 38 x 30 ) + nb_cores 13600 ( 160 x 85 ), nb_points 1131 ( 29 x 39 ) + nb_cores 13728 ( 96 x 143 ), nb_points 1128 ( 47 x 24 ) + nb_cores 13755 ( 131 x 105 ), nb_points 1120 ( 35 x 32 ) + nb_cores 13857 ( 149 x 93 ), nb_points 1116 ( 31 x 36 ) + nb_cores 13950 ( 155 x 90 ), nb_points 1110 ( 30 x 37 ) + nb_cores 13986 ( 111 x 126 ), nb_points 1107 ( 41 x 27 ) + nb_cores 14040 ( 120 x 117 ), nb_points 1102 ( 38 x 29 ) + nb_cores 14100 ( 188 x 75 ), nb_points 1100 ( 25 x 44 ) + nb_cores 14157 ( 117 x 121 ), nb_points 1092 ( 39 x 28 ) + nb_cores 14175 ( 135 x 105 ), nb_points 1088 ( 34 x 32 ) + nb_cores 14279 ( 131 x 109 ), nb_points 1085 ( 35 x 31 ) + nb_cores 14359 ( 173 x 83 ), nb_points 1080 ( 27 x 40 ) + nb_cores 14400 ( 160 x 90 ), nb_points 1073 ( 29 x 37 ) + nb_cores 14520 ( 120 x 121 ), nb_points 1064 ( 38 x 28 ) + nb_cores 14688 ( 144 x 102 ), nb_points 1056 ( 32 x 33 ) + nb_cores 14705 ( 173 x 85 ), nb_points 1053 ( 27 x 39 ) + nb_cores 14796 ( 108 x 137 ), nb_points 1050 ( 42 x 25 ) + nb_cores 14880 ( 160 x 93 ), nb_points 1044 ( 29 x 36 ) + nb_cores 14940 ( 180 x 83 ), nb_points 1040 ( 26 x 40 ) + nb_cores 15004 ( 124 x 121 ), nb_points 1036 ( 37 x 28 ) + nb_cores 15120 ( 144 x 105 ), nb_points 1024 ( 32 x 32 ) + nb_cores 15198 ( 149 x 102 ), nb_points 1023 ( 31 x 33 ) + nb_cores 15255 ( 135 x 113 ), nb_points 1020 ( 34 x 30 ) + nb_cores 15300 ( 180 x 85 ), nb_points 1014 ( 26 x 39 ) + nb_cores 15444 ( 108 x 143 ), nb_points 1008 ( 42 x 24 ) + nb_cores 15570 ( 173 x 90 ), nb_points 999 ( 27 x 37 ) + nb_cores 15645 ( 149 x 105 ), nb_points 992 ( 31 x 32 ) + nb_cores 15795 ( 135 x 117 ), nb_points 986 ( 34 x 29 ) + nb_cores 15851 ( 131 x 121 ), nb_points 980 ( 35 x 28 ) + nb_cores 15980 ( 188 x 85 ), nb_points 975 ( 25 x 39 ) + nb_cores 16089 ( 173 x 93 ), nb_points 972 ( 27 x 36 ) + nb_cores 16200 ( 180 x 90 ), nb_points 962 ( 26 x 37 ) + nb_cores 16241 ( 149 x 109 ), nb_points 961 ( 31 x 31 ) + nb_cores 16272 ( 144 x 113 ), nb_points 960 ( 32 x 30 ) + nb_cores 16320 ( 160 x 102 ), nb_points 957 ( 29 x 33 ) + nb_cores 16335 ( 135 x 121 ), nb_points 952 ( 34 x 28 ) + nb_cores 16440 ( 120 x 137 ), nb_points 950 ( 38 x 25 ) + nb_cores 16506 ( 131 x 126 ), nb_points 945 ( 35 x 27 ) + nb_cores 16650 ( 111 x 150 ), nb_points 943 ( 41 x 23 ) + nb_cores 16731 ( 117 x 143 ), nb_points 936 ( 39 x 24 ) + nb_cores 16800 ( 160 x 105 ), nb_points 928 ( 29 x 32 ) + nb_cores 16920 ( 188 x 90 ), nb_points 925 ( 25 x 37 ) + nb_cores 16940 ( 140 x 121 ), nb_points 924 ( 33 x 28 ) + nb_cores 17010 ( 135 x 126 ), nb_points 918 ( 34 x 27 ) + nb_cores 17160 ( 120 x 143 ), nb_points 912 ( 38 x 24 ) + nb_cores 17280 ( 180 x 96 ), nb_points 910 ( 26 x 35 ) + nb_cores 17424 ( 144 x 121 ), nb_points 896 ( 32 x 28 ) + nb_cores 17640 ( 140 x 126 ), nb_points 891 ( 33 x 27 ) + nb_cores 17730 ( 197 x 90 ), nb_points 888 ( 24 x 37 ) + nb_cores 17820 ( 135 x 132 ), nb_points 884 ( 34 x 26 ) + nb_cores 17820 ( 180 x 99 ), nb_points 884 ( 26 x 34 ) + nb_cores 17928 ( 216 x 83 ), nb_points 880 ( 22 x 40 ) + nb_cores 17947 ( 131 x 137 ), nb_points 875 ( 35 x 25 ) + nb_cores 18000 ( 120 x 150 ), nb_points 874 ( 38 x 23 ) + nb_cores 18029 ( 149 x 121 ), nb_points 868 ( 31 x 28 ) + nb_cores 18144 ( 144 x 126 ), nb_points 864 ( 32 x 27 ) + nb_cores 18360 ( 180 x 102 ), nb_points 858 ( 26 x 33 ) + nb_cores 18360 ( 216 x 85 ), nb_points 858 ( 22 x 39 ) + nb_cores 18495 ( 135 x 137 ), nb_points 850 ( 34 x 25 ) + nb_cores 18720 ( 160 x 117 ), nb_points 841 ( 29 x 29 ) + nb_cores 18733 ( 131 x 143 ), nb_points 840 ( 35 x 24 ) + nb_cores 18774 ( 149 x 126 ), nb_points 837 ( 31 x 27 ) + nb_cores 18900 ( 180 x 105 ), nb_points 832 ( 26 x 32 ) + nb_cores 19158 ( 206 x 93 ), nb_points 828 ( 23 x 36 ) + nb_cores 19176 ( 188 x 102 ), nb_points 825 ( 25 x 33 ) + nb_cores 19305 ( 135 x 143 ), nb_points 816 ( 34 x 24 ) + nb_cores 19360 ( 160 x 121 ), nb_points 812 ( 29 x 28 ) + nb_cores 19530 ( 155 x 126 ), nb_points 810 ( 30 x 27 ) + nb_cores 19620 ( 180 x 109 ), nb_points 806 ( 26 x 31 ) + nb_cores 19650 ( 131 x 150 ), nb_points 805 ( 35 x 23 ) + nb_cores 19728 ( 144 x 137 ), nb_points 800 ( 32 x 25 ) + nb_cores 19920 ( 120 x 166 ), nb_points 798 ( 38 x 21 ) + nb_cores 20020 ( 140 x 143 ), nb_points 792 ( 33 x 24 ) + nb_cores 20160 ( 160 x 126 ), nb_points 783 ( 29 x 27 ) + nb_cores 20250 ( 135 x 150 ), nb_points 782 ( 34 x 23 ) + nb_cores 20340 ( 180 x 113 ), nb_points 780 ( 26 x 30 ) + nb_cores 20413 ( 149 x 137 ), nb_points 775 ( 31 x 25 ) + nb_cores 20592 ( 144 x 143 ), nb_points 768 ( 32 x 24 ) + nb_cores 20933 ( 173 x 121 ), nb_points 756 ( 27 x 28 ) + nb_cores 21060 ( 180 x 117 ), nb_points 754 ( 26 x 29 ) + nb_cores 21235 ( 155 x 137 ), nb_points 750 ( 30 x 25 ) + nb_cores 21307 ( 149 x 143 ), nb_points 744 ( 31 x 24 ) + nb_cores 21600 ( 144 x 150 ), nb_points 736 ( 32 x 23 ) + nb_cores 21746 ( 131 x 166 ), nb_points 735 ( 35 x 21 ) + nb_cores 21780 ( 180 x 121 ), nb_points 728 ( 26 x 28 ) + nb_cores 21920 ( 160 x 137 ), nb_points 725 ( 29 x 25 ) + nb_cores 22165 ( 155 x 143 ), nb_points 720 ( 30 x 24 ) + nb_cores 22350 ( 149 x 150 ), nb_points 713 ( 31 x 23 ) + nb_cores 22680 ( 180 x 126 ), nb_points 702 ( 26 x 27 ) + nb_cores 22748 ( 188 x 121 ), nb_points 700 ( 25 x 28 ) + nb_cores 22880 ( 160 x 143 ), nb_points 696 ( 29 x 24 ) + nb_cores 23240 ( 140 x 166 ), nb_points 693 ( 33 x 21 ) + nb_cores 23250 ( 155 x 150 ), nb_points 690 ( 30 x 23 ) + nb_cores 23542 ( 149 x 158 ), nb_points 682 ( 31 x 22 ) + nb_cores 23625 ( 135 x 175 ), nb_points 680 ( 34 x 20 ) + nb_cores 23688 ( 188 x 126 ), nb_points 675 ( 25 x 27 ) + nb_cores 23837 ( 197 x 121 ), nb_points 672 ( 24 x 28 ) + nb_cores 24000 ( 160 x 150 ), nb_points 667 ( 29 x 23 ) + nb_cores 24235 ( 131 x 185 ), nb_points 665 ( 35 x 19 ) + nb_cores 24408 ( 216 x 113 ), nb_points 660 ( 22 x 30 ) + nb_cores 24660 ( 180 x 137 ), nb_points 650 ( 26 x 25 ) + nb_cores 24739 ( 173 x 143 ), nb_points 648 ( 27 x 24 ) + nb_cores 24926 ( 206 x 121 ), nb_points 644 ( 23 x 28 ) + nb_cores 25200 ( 240 x 105 ), nb_points 640 ( 20 x 32 ) + nb_cores 25200 ( 144 x 175 ), nb_points 640 ( 32 x 20 ) + nb_cores 25272 ( 216 x 117 ), nb_points 638 ( 22 x 29 ) + nb_cores 25730 ( 155 x 166 ), nb_points 630 ( 30 x 21 ) + nb_cores 25740 ( 180 x 143 ), nb_points 624 ( 26 x 24 ) + nb_cores 25950 ( 173 x 150 ), nb_points 621 ( 27 x 23 ) + nb_cores 26075 ( 149 x 175 ), nb_points 620 ( 31 x 20 ) + nb_cores 26136 ( 216 x 121 ), nb_points 616 ( 22 x 28 ) + nb_cores 26560 ( 160 x 166 ), nb_points 609 ( 29 x 21 ) + nb_cores 26640 ( 144 x 185 ), nb_points 608 ( 32 x 19 ) + nb_cores 26884 ( 188 x 143 ), nb_points 600 ( 25 x 24 ) + nb_cores 27000 ( 180 x 150 ), nb_points 598 ( 26 x 23 ) + nb_cores 27216 ( 216 x 126 ), nb_points 594 ( 22 x 27 ) + nb_cores 27565 ( 149 x 185 ), nb_points 589 ( 31 x 19 ) + nb_cores 27588 ( 228 x 121 ), nb_points 588 ( 21 x 28 ) + nb_cores 28000 ( 160 x 175 ), nb_points 580 ( 29 x 20 ) + nb_cores 28171 ( 197 x 143 ), nb_points 576 ( 24 x 24 ) + nb_cores 28200 ( 188 x 150 ), nb_points 575 ( 25 x 23 ) + nb_cores 28440 ( 180 x 158 ), nb_points 572 ( 26 x 22 ) + nb_cores 28675 ( 155 x 185 ), nb_points 570 ( 30 x 19 ) + nb_cores 28718 ( 173 x 166 ), nb_points 567 ( 27 x 21 ) + nb_cores 29040 ( 240 x 121 ), nb_points 560 ( 20 x 28 ) + nb_cores 29353 ( 149 x 197 ), nb_points 558 ( 31 x 18 ) + nb_cores 29458 ( 206 x 143 ), nb_points 552 ( 23 x 24 ) + nb_cores 29592 ( 216 x 137 ), nb_points 550 ( 22 x 25 ) + nb_cores 29880 ( 180 x 166 ), nb_points 546 ( 26 x 21 ) + nb_cores 30240 ( 240 x 126 ), nb_points 540 ( 20 x 27 ) + nb_cores 30855 ( 255 x 121 ), nb_points 532 ( 19 x 28 ) + nb_cores 30888 ( 216 x 143 ), nb_points 528 ( 22 x 24 ) + nb_cores 31208 ( 188 x 166 ), nb_points 525 ( 25 x 21 ) + nb_cores 31500 ( 180 x 175 ), nb_points 520 ( 26 x 20 ) + nb_cores 32005 ( 173 x 185 ), nb_points 513 ( 27 x 19 ) + nb_cores 32400 ( 216 x 150 ), nb_points 506 ( 22 x 23 ) + nb_cores 32604 ( 228 x 143 ), nb_points 504 ( 21 x 24 ) + nb_cores 32880 ( 240 x 137 ), nb_points 500 ( 20 x 25 ) + nb_cores 33300 ( 180 x 185 ), nb_points 494 ( 26 x 19 ) + nb_cores 33600 ( 160 x 210 ), nb_points 493 ( 29 x 17 ) + nb_cores 34020 ( 270 x 126 ), nb_points 486 ( 18 x 27 ) + nb_cores 34128 ( 216 x 158 ), nb_points 484 ( 22 x 22 ) + nb_cores 34196 ( 206 x 166 ), nb_points 483 ( 23 x 21 ) + nb_cores 34320 ( 240 x 143 ), nb_points 480 ( 20 x 24 ) + nb_cores 34780 ( 188 x 185 ), nb_points 475 ( 25 x 19 ) + nb_cores 35460 ( 180 x 197 ), nb_points 468 ( 26 x 18 ) + nb_cores 35856 ( 216 x 166 ), nb_points 462 ( 22 x 21 ) + nb_cores 36000 ( 240 x 150 ), nb_points 460 ( 20 x 23 ) + nb_cores 36288 ( 288 x 126 ), nb_points 459 ( 17 x 27 ) + nb_cores 36445 ( 197 x 185 ), nb_points 456 ( 24 x 19 ) + nb_cores 36990 ( 270 x 137 ), nb_points 450 ( 18 x 25 ) + nb_cores 37389 ( 309 x 121 ), nb_points 448 ( 16 x 28 ) + nb_cores 37800 ( 216 x 175 ), nb_points 440 ( 22 x 20 ) + nb_cores 38110 ( 206 x 185 ), nb_points 437 ( 23 x 19 ) + nb_cores 38610 ( 270 x 143 ), nb_points 432 ( 18 x 24 ) + nb_cores 39456 ( 288 x 137 ), nb_points 425 ( 17 x 25 ) + nb_cores 39840 ( 240 x 166 ), nb_points 420 ( 20 x 21 ) + nb_cores 39960 ( 216 x 185 ), nb_points 418 ( 22 x 19 ) + nb_cores 40500 ( 270 x 150 ), nb_points 414 ( 18 x 23 ) + nb_cores 41184 ( 288 x 143 ), nb_points 408 ( 17 x 24 ) + nb_cores 41866 ( 173 x 242 ), nb_points 405 ( 27 x 15 ) + nb_cores 42000 ( 240 x 175 ), nb_points 400 ( 20 x 20 ) + nb_cores 42180 ( 228 x 185 ), nb_points 399 ( 21 x 19 ) + nb_cores 42552 ( 216 x 197 ), nb_points 396 ( 22 x 18 ) + nb_cores 43200 ( 288 x 150 ), nb_points 391 ( 17 x 23 ) + nb_cores 43560 ( 180 x 242 ), nb_points 390 ( 26 x 15 ) + nb_cores 44187 ( 309 x 143 ), nb_points 384 ( 16 x 24 ) + nb_cores 44400 ( 240 x 185 ), nb_points 380 ( 20 x 19 ) + nb_cores 44820 ( 270 x 166 ), nb_points 378 ( 18 x 21 ) + nb_cores 45360 ( 216 x 210 ), nb_points 374 ( 22 x 17 ) + nb_cores 46350 ( 309 x 150 ), nb_points 368 ( 16 x 23 ) + nb_cores 46350 ( 206 x 225 ), nb_points 368 ( 23 x 16 ) + nb_cores 47175 ( 255 x 185 ), nb_points 361 ( 19 x 19 ) + nb_cores 47250 ( 270 x 175 ), nb_points 360 ( 18 x 20 ) + nb_cores 47808 ( 288 x 166 ), nb_points 357 ( 17 x 21 ) + nb_cores 48600 ( 216 x 225 ), nb_points 352 ( 22 x 16 ) + nb_cores 49320 ( 360 x 137 ), nb_points 350 ( 14 x 25 ) + nb_cores 49852 ( 206 x 242 ), nb_points 345 ( 23 x 15 ) + nb_cores 49950 ( 270 x 185 ), nb_points 342 ( 18 x 19 ) + nb_cores 50400 ( 288 x 175 ), nb_points 340 ( 17 x 20 ) + nb_cores 50400 ( 240 x 210 ), nb_points 340 ( 20 x 17 ) + nb_cores 51294 ( 309 x 166 ), nb_points 336 ( 16 x 21 ) + nb_cores 52272 ( 216 x 242 ), nb_points 330 ( 22 x 15 ) + nb_cores 53190 ( 270 x 197 ), nb_points 324 ( 18 x 18 ) + nb_cores 53280 ( 288 x 185 ), nb_points 323 ( 17 x 19 ) + nb_cores 54000 ( 240 x 225 ), nb_points 320 ( 20 x 16 ) + nb_cores 55176 ( 228 x 242 ), nb_points 315 ( 21 x 15 ) + nb_cores 56199 ( 393 x 143 ), nb_points 312 ( 13 x 24 ) + nb_cores 56700 ( 270 x 210 ), nb_points 306 ( 18 x 17 ) + nb_cores 57165 ( 309 x 185 ), nb_points 304 ( 16 x 19 ) + nb_cores 58080 ( 240 x 242 ), nb_points 300 ( 20 x 15 ) + nb_cores 58916 ( 206 x 286 ), nb_points 299 ( 23 x 13 ) + nb_cores 59760 ( 360 x 166 ), nb_points 294 ( 14 x 21 ) + nb_cores 60480 ( 288 x 210 ), nb_points 289 ( 17 x 17 ) + nb_cores 60750 ( 270 x 225 ), nb_points 288 ( 18 x 16 ) + nb_cores 61605 ( 333 x 185 ), nb_points 285 ( 15 x 19 ) + nb_cores 63000 ( 360 x 175 ), nb_points 280 ( 14 x 20 ) + nb_cores 64800 ( 288 x 225 ), nb_points 272 ( 17 x 16 ) + nb_cores 65340 ( 270 x 242 ), nb_points 270 ( 18 x 15 ) + nb_cores 66600 ( 360 x 185 ), nb_points 266 ( 14 x 19 ) + nb_cores 68040 ( 216 x 315 ), nb_points 264 ( 22 x 12 ) + nb_cores 68640 ( 240 x 286 ), nb_points 260 ( 20 x 13 ) + nb_cores 69525 ( 309 x 225 ), nb_points 256 ( 16 x 16 ) + nb_cores 69696 ( 288 x 242 ), nb_points 255 ( 17 x 15 ) + nb_cores 70920 ( 360 x 197 ), nb_points 252 ( 14 x 18 ) + nb_cores 72705 ( 393 x 185 ), nb_points 247 ( 13 x 19 ) + nb_cores 74778 ( 309 x 242 ), nb_points 240 ( 16 x 15 ) + nb_cores 75600 ( 360 x 210 ), nb_points 238 ( 14 x 17 ) + nb_cores 77220 ( 270 x 286 ), nb_points 234 ( 18 x 13 ) + nb_cores 79680 ( 480 x 166 ), nb_points 231 ( 11 x 21 ) + nb_cores 79920 ( 432 x 185 ), nb_points 228 ( 12 x 19 ) + nb_cores 80586 ( 333 x 242 ), nb_points 225 ( 15 x 15 ) + nb_cores 81000 ( 360 x 225 ), nb_points 224 ( 14 x 16 ) + nb_cores 82368 ( 288 x 286 ), nb_points 221 ( 17 x 13 ) + nb_cores 84000 ( 480 x 175 ), nb_points 220 ( 11 x 20 ) + nb_cores 84000 ( 240 x 350 ), nb_points 220 ( 20 x 11 ) + nb_cores 85050 ( 270 x 315 ), nb_points 216 ( 18 x 12 ) + nb_cores 87120 ( 360 x 242 ), nb_points 210 ( 14 x 15 ) + nb_cores 88374 ( 309 x 286 ), nb_points 208 ( 16 x 13 ) + nb_cores 90720 ( 288 x 315 ), nb_points 204 ( 17 x 12 ) + nb_cores 90720 ( 432 x 210 ), nb_points 204 ( 12 x 17 ) + nb_cores 94500 ( 270 x 350 ), nb_points 198 ( 18 x 11 ) + nb_cores 94680 ( 360 x 263 ), nb_points 196 ( 14 x 14 ) + nb_cores 95106 ( 393 x 242 ), nb_points 195 ( 13 x 15 ) + nb_cores 97200 ( 432 x 225 ), nb_points 192 ( 12 x 16 ) + nb_cores 99900 ( 540 x 185 ), nb_points 190 ( 10 x 19 ) diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca025_like b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca025_like new file mode 100644 index 0000000000000000000000000000000000000000..9085453170306914652b639c5e0398d8d5e49863 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca025_like @@ -0,0 +1,220 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OPA BENCH Configuration namelist : overwrite some defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = 'BENCH' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 1000 ! last time step + nn_stock = -1 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = -1 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + nn_isize = 1442 ! number of point in i-direction of global(local) domain if >0 (<0) + nn_jsize = 1207 !! 1050 ! number of point in j-direction of global(local) domain if >0 (<0) + nn_ksize = 75 ! total number of point in k-direction + nn_perio = 4 ! periodicity +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_nnogather= .true. ! 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) +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + nn_print = 0 ! level of print (0 no extra print) + ln_timing = .false. ! timing by routine write out in timing.output file +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 900. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.05 ! asselin time filter parameter +/ + +!!====================================================================== +!! *** Surface Boundary Condition namelists *** !! +!! !! +!! namsbc surface boundary condition manager (default: NO selection) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) +/ + +! +!!====================================================================== +!! *** 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 +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue) + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 1 ! geothermal heat flux: = 1 constant flux +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag +/ + +!!====================================================================== +!! 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 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_blp = .true. ! laplacian operator + ln_traldf_iso = .true. ! iso-neutral (standard operator) + ! + ln_traldf_msc = .true. ! Method of Stabilizing Correction (both operators) + nn_aht_ijk_t = 20 ! space/time variation of eddy coefficient: +/ +!----------------------------------------------------------------------- +&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) +!----------------------------------------------------------------------- + ln_mle = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization +/ + +!!====================================================================== +!! *** 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_dbg = .false. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) + nn_dynkeg = 1 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .false. ! Number of sub-step defined from: + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_blp = .true. ! laplacian operator + ln_dynldf_hor = .true. ! horizontal (geopotential) + ! ! Coefficient + nn_ahm_ijk_t = 30 ! space/time variation of eddy coef +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfevd = .true. ! enhanced vertical diffusion + ln_zdfddm = .true. ! double diffusive mixing + ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm) +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca12_like b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca12_like new file mode 100644 index 0000000000000000000000000000000000000000..d67232450efa834c1c57ca02a4b9afcefdf63d01 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca12_like @@ -0,0 +1,216 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OPA BENCH Configuration namelist : overwrite some defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = 'BENCH' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 1000 ! last time step + nn_stock = -1 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = -1 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + nn_isize = 4322 ! number of point in i-direction of global(local) domain if >0 (<0) + nn_jsize = 3147 ! number of point in j-direction of global(local) domain if >0 (<0) + nn_ksize = 75 ! total number of point in k-direction + nn_perio = 4 ! periodicity +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_nnogather= .true. ! 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) +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + nn_print = 0 ! level of print (0 no extra print) + ln_timing = .false. ! timing by routine write out in timing.output file +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 300. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.05 ! asselin time filter parameter +/ + +!!====================================================================== +!! *** Surface Boundary Condition namelists *** !! +!! !! +!! namsbc surface boundary condition manager (default: NO selection) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) +/ + +! +!!====================================================================== +!! *** 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 +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue) + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 1 ! geothermal heat flux: = 1 constant flux +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag +/ + +!!====================================================================== +!! 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 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_blp = .true. ! laplacian operator + ln_traldf_iso = .true. ! iso-neutral (standard operator) + ! + ln_traldf_msc = .true. ! Method of Stabilizing Correction (both operators) + nn_aht_ijk_t = 20 ! space/time variation of eddy coefficient: +/ +!----------------------------------------------------------------------- +&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) +!----------------------------------------------------------------------- + ln_mle = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization +/ + +!!====================================================================== +!! *** 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_dbg = .false. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .false. ! Number of sub-step defined from: + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfevd = .true. ! enhanced vertical diffusion + ln_zdfddm = .true. ! double diffusive mixing + ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm) +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca1_like b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca1_like new file mode 100644 index 0000000000000000000000000000000000000000..e7081868fe0fd3dc000c134d6f7e61ae686b19c9 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_cfg_orca1_like @@ -0,0 +1,219 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OPA BENCH Configuration namelist : overwrite some defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = 'BENCH' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 1000 ! last time step + nn_stock = -1 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = -1 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + nn_isize = 362 ! number of point in i-direction of global(local) domain if >0 (<0) + nn_jsize = 332 ! number of point in j-direction of global(local) domain if >0 (<0) + nn_ksize = 75 ! total number of point in k-direction + nn_perio = 6 ! periodicity +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_nnogather= .true. ! 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) +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + nn_print = 0 ! level of print (0 no extra print) + ln_timing = .false. ! timing by routine write out in timing.output file +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 3600. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.05 ! asselin time filter parameter +/ + +!!====================================================================== +!! *** Surface Boundary Condition namelists *** !! +!! !! +!! namsbc surface boundary condition manager (default: NO selection) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) +/ + +! +!!====================================================================== +!! *** 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 +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue) + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 1 ! geothermal heat flux: = 1 constant flux +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag +/ + +!!====================================================================== +!! 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 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_lap = .true. ! laplacian operator + ln_traldf_iso = .true. ! iso-neutral (standard operator) + ! + nn_aht_ijk_t = 20 ! space/time variation of eddy coefficient: +/ +!----------------------------------------------------------------------- +&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) +!----------------------------------------------------------------------- + ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .true. ! use eddy induced velocity parameterization + ! + nn_aei_ijk_t = 20 ! space/time variation of eddy coefficient: +/ + +!!====================================================================== +!! *** 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_dbg = .false. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) + nn_dynkeg = 1 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_een = .true. ! energy & enstrophy scheme +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .false. ! Number of sub-step defined from: + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_hor = .true. ! horizontal (geopotential) + ! ! Coefficient + nn_ahm_ijk_t = 30 ! space/time variation of eddy coef +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfevd = .true. ! enhanced vertical diffusion + ln_zdfddm = .true. ! double diffusive mixing + ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm) +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_cfg b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..657a0d16cb6ef485837d02f4ae6d2d7c86227720 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_cfg @@ -0,0 +1,85 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface forcing (namforcing) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namforcing ! Ice surface forcing +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + rn_thres_sst = 0.5 ! max delta temp. above Tfreeze with initial ice = (sst - tfreeze) +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_ref b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..23b14529cf92c567f7cc1d10b42ff842a5bb3bea --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ice_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_cfg b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_cfg new file mode 100644 index 0000000000000000000000000000000000000000..d0ad181f7d085f496dac88c50fb2bafe201e2753 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_cfg @@ -0,0 +1,140 @@ +!----------------------------------------------------------------------- +&nampismod ! Model used +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisext ! air-sea exchange +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisatm ! Atmospheric prrssure +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisbio ! biological parameters +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zice ! parameters for nutrient limitations for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zice ! parameters for nutrient limitations PISCES QUOTA - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zquota ! parameters for nutrient limitations PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisopt ! parameters for optics +!----------------------------------------------------------------------- + ln_varpar = .false. ! boolean for PAR variable +/ +!----------------------------------------------------------------------- +&namp4zprod ! parameters for phytoplankton growth for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zprod ! parameters for phytoplankton growth for PISCES quota- ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmort ! parameters for phytoplankton sinks for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmort ! parameters for phytoplankton sinks for PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmes ! parameters for mesozooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmes ! parameters for mesozooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zzoo ! parameters for microzooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zzoo ! parameters for microzooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisfer ! parameters for iron chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisrem ! parameters for remineralization +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampispoc ! parameters for organic particles +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampiscal ! parameters for Calcite chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampissbc ! parameters for inputs deposition +!----------------------------------------------------------------------- + ln_dust = .false. ! boolean for dust input from the atmosphere + ln_solub = .false. ! boolean for variable solubility of atm. Iron + ln_river = .false. ! boolean for river input of nutrients + ln_ndepo = .false. ! boolean for atmospheric deposition of N + ln_ironsed = .false. ! boolean for Fe input from sediments + ln_ironice = .false. ! boolean for Fe input from sea ice + ln_hydrofe = .false. ! boolean for from hydrothermal vents +/ +!----------------------------------------------------------------------- +&nampislig ! Namelist parameters for ligands, nampislig +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisice ! Prescribed sea ice tracers +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisdmp ! Damping +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampismass ! Mass conservation +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobphy ! biological parameters for phytoplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobnut ! biological parameters for nutrients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobzoo ! biological parameters for zooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdet ! biological parameters for detritus +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdom ! biological parameters for DOM +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobsed ! parameters from aphotic layers to sediment +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobrat ! general coefficients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobopt ! optical parameters +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_ref b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_ref new file mode 120000 index 0000000000000000000000000000000000000000..d4bd2d17dc6850bd4a143ac8a4ad629eadbc7102 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_pisces_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_pisces_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_cfg b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_cfg new file mode 100644 index 0000000000000000000000000000000000000000..38929f422fa67214b416d473a6c0ba020f281585 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_cfg @@ -0,0 +1,110 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/TOP1 : Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_top_ref +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namtrc_run ! run information +!----------------------------------------------------------------------- + ln_top_euler = .true. +/ +!----------------------------------------------------------------------- +&namtrc ! tracers definition +!----------------------------------------------------------------------- + jp_bgc = 24 +! + ln_pisces = .true. + ln_my_trc = .false. + ln_age = .false. + ln_cfc11 = .false. + ln_cfc12 = .false. + ln_c14 = .false. +! + ln_trcdta = .false. ! Initialisation from data input file (T) or not (F) +! ! ! ! ! +! ! name ! title of the field ! units ! initial data from file or not ! +! ! ! ! ! + sn_tracer(1) = 'DIC ' , 'Dissolved inorganic Concentration ', 'mol-C/L' , .true. + sn_tracer(2) = 'Alkalini' , 'Total Alkalinity Concentration ', 'eq/L ' , .true. + sn_tracer(3) = 'O2 ' , 'Dissolved Oxygen Concentration ', 'mol-C/L' , .true. + sn_tracer(4) = 'CaCO3 ' , 'Calcite Concentration ', 'mol-C/L' , .false. + sn_tracer(5) = 'PO4 ' , 'Phosphate Concentration ', 'mol-C/L' , .true. + sn_tracer(6) = 'POC ' , 'Small organic carbon Concentration ', 'mol-C/L' , .false. + sn_tracer(7) = 'Si ' , 'Silicate Concentration ', 'mol-C/L' , .true. + sn_tracer(8) = 'PHY ' , 'Nanophytoplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(9) = 'ZOO ' , 'Microzooplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(10) = 'DOC ' , 'Dissolved organic Concentration ', 'mol-C/L' , .true. + sn_tracer(11) = 'PHY2 ' , 'Diatoms Concentration ', 'mol-C/L' , .false. + sn_tracer(12) = 'ZOO2 ' , 'Mesozooplankton Concentration ', 'mol-C/L' , .false. + sn_tracer(13) = 'DSi ' , 'Diatoms Silicate Concentration ', 'mol-C/L' , .false. + sn_tracer(14) = 'Fer ' , 'Dissolved Iron Concentration ', 'mol-C/L' , .true. + sn_tracer(15) = 'BFe ' , 'Big iron particles Concentration ', 'mol-C/L' , .false. + sn_tracer(16) = 'GOC ' , 'Big organic carbon Concentration ', 'mol-C/L' , .false. + sn_tracer(17) = 'SFe ' , 'Small iron particles Concentration ', 'mol-C/L' , .false. + sn_tracer(18) = 'DFe ' , 'Diatoms iron Concentration ', 'mol-C/L' , .false. + sn_tracer(19) = 'GSi ' , 'Sinking biogenic Silicate Concentration', 'mol-C/L' , .false. + sn_tracer(20) = 'NFe ' , 'Nano iron Concentration ', 'mol-C/L' , .false. + sn_tracer(21) = 'NCHL ' , 'Nano chlorophyl Concentration ', 'mol-C/L' , .false. + sn_tracer(22) = 'DCHL ' , 'Diatoms chlorophyl Concentration ', 'mol-C/L' , .false. + sn_tracer(23) = 'NO3 ' , 'Nitrates Concentration ', 'mol-C/L' , .true. + sn_tracer(24) = 'NH4 ' , 'Ammonium Concentration ', 'mol-C/L' , .false. +/ +!----------------------------------------------------------------------- +&namage ! AGE +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dta ! Initialisation from data input file +!----------------------------------------------------------------------- +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_trcdta(1) = 'data_DIC_nomask' , -12. , 'DIC' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(2) = 'data_Alkalini_nomask' , -12. , 'Alkalini', .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(3) = 'data_O2_nomask' , -1. , 'O2' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(5) = 'data_PO4_nomask' , -1. , 'PO4' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(7) = 'data_Si_nomask' , -1. , 'Si' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(10) = 'data_DOC_nomask' , -12. , 'DOC' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(14) = 'data_Fer_nomask' , -12. , 'Fer' , .false. , .true. , 'yearly' , '' , '' , '' + sn_trcdta(23) = 'data_NO3_nomask' , -1. , 'NO3' , .true. , .true. , 'yearly' , '' , '' , '' + 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.0 ! - - - - + rn_trfac(14) = 1.0 ! - - - - + rn_trfac(23) = 7.6e-06 ! - - - - +/ +!----------------------------------------------------------------------- +&namtrc_adv ! advection scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcadv_mus = .true. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths +/ +!----------------------------------------------------------------------- +&namtrc_ldf ! lateral diffusion scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcldf_tra = .true. ! use active tracer setting +/ +!----------------------------------------------------------------------- +&namtrc_rad ! treatment of negative concentrations +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dmp ! passive tracer newtonian damping +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_ice ! Representation of sea ice growth & melt effects +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc') +!---------------------------------------------------------------------- +/ +!---------------------------------------------------------------------- +&namtrc_bc ! data for boundary conditions +!----------------------------------------------------------------------- +/ +!---------------------------------------------------------------------- +&namtrc_bdy ! Setup of tracer boundary conditions +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_ref b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_ref new file mode 120000 index 0000000000000000000000000000000000000000..4233e1ce2efd11b51c88898874f2858175351632 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/namelist_top_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_top_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/sh_bench b/V4.0/nemo_sources/tests/BENCH/EXPREF/sh_bench new file mode 100755 index 0000000000000000000000000000000000000000..309e879e5ffaa22660ce5de5f34c92b31f90adaa --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/sh_bench @@ -0,0 +1,59 @@ +#!/bin/bash +set -u +#set -xv + +resolution=${1:?"you must provide the resolution: 1 025 or 12"} +mincore=${2:-1} # minimum number of core to be tested +maxcore=${3:-0} # maximum number of core to be tested + +machine=$( hostname | sed -e "s/[0-9]*//g" ) +case $machine in + "jean-zay") ncore_node=40 ;; + "beaufixlogin") ncore_node=40 ;; + "curie") ncore_node=16 ;; + "irene") ncore_node=48 ;; + *) echo "you must add your machine \"$machine\" with its number of cores per node" ; exit 1 ;; +esac + +[ $mincore -eq 1 ] && targetnb=$ncore_node || targetnb=$mincore +# +# build the list of experiences: +# must be a multiple of ncore_node and as close as possible of the targeted number of core +# +n1=0 +list="" + +# Prepare gnuplot data file +dateref=$( date "+%Y%m%d-%Hh%Mm%Ss" ) +echo "# nb_proc jpi jpj" > gnuplot_tbc_${resolution}_${dateref}.dat +nbl=$( cat best_jpni_jpnj_eorca${resolution} | wc -l ) +for ll in $( seq 1 $nbl ) +do + line=$( sed -n ${ll}p best_jpni_jpnj_eorca${resolution} ) # for each line + nn=$( echo $line | sed -e "s/.*nb_cores \([0-9]*\).*/\1/" ) # get the number of core + [ $maxcore -gt 1 -a $nn -gt $maxcore ] && break # if below $maxcore (if specified) + if [ $(( $nn % $ncore_node )) -eq 0 ] # if it is a multiple of $ncore_node + then + if [ $nn -lt $targetnb ] + then + n1=$nn # store the number of core + line1=$line # store the line + else + [ $(( $targetnb - $n1 )) -le $(( $nn -$targetnb )) ] && line=$line1 # keep the previous line + echo $line + nb=$( echo $line | sed -e "s/[^(]*( \([0-9]*\) x \([0-9]*\) .*/\1*\2/" ) # get jpni*jpnj + list="${list} ${nb}" + targetnb=$(( $targetnb * 2 )) + subsize=$( echo $line | awk {'printf "%d %d", $11, $13'}) + corenb=$( echo $line | awk {'printf "%d", $2'}) + echo "$corenb $subsize" >> gnuplot_tbc_${resolution}.dat + fi + fi +done +echo $list + +for cores in $list +do + ./submit_bench $cores $ncore_node ${resolution} ${dateref} +done + diff --git a/V4.0/nemo_sources/tests/BENCH/EXPREF/submit_bench b/V4.0/nemo_sources/tests/BENCH/EXPREF/submit_bench new file mode 100755 index 0000000000000000000000000000000000000000..fe80efb08f3b28232381f7b0c1ddddd4deee302a --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/EXPREF/submit_bench @@ -0,0 +1,276 @@ +#!/bin/bash +# +# BENCH launching scripts for beaufix, Meteo-France +# and curie, TGCC +# To be modified for other machines +# +set -u +#set -vx +# +cores=$1 +ncore_node=$2 +resolution=$3 +dateref=$4 +machine=$( hostname | sed -e "s/[0-9]*//g" ) +# +# number of processes for each executable +nproc_exe1=$( echo $cores | bc ) +nproc=$nproc_exe1 +nnode=$(( ( $nproc + $ncore_node - 1 ) / $ncore_node )) + +nproc5=$( printf "%05d\n" ${nproc_exe1} ) + +case ${resolution} in + "1") + if [ $nproc_exe1 -lt 50 ] + then + timejob=3600 + elif [ $nproc_exe1 -lt 100 ] + then + timejob=1800 + elif [ $nproc_exe1 -lt 200 ] + then + timejob=900 + else + timejob=600 + fi + ;; + "025") + if [ $nproc_exe1 -lt 50 ] + then + timejob=15000 + elif [ $nproc_exe1 -lt 100 ] + then + timejob=7000 + elif [ $nproc_exe1 -lt 200 ] + then + timejob=3600 + elif [ $nproc_exe1 -lt 400 ] + then + timejob=2000 + elif [ $nproc_exe1 -lt 800 ] + then + timejob=1000 + else + timejob=600 + fi + ;; + "12") + if [ $nproc_exe1 -lt 200 ] + then + timejob=30000 + elif [ $nproc_exe1 -lt 400 ] + then + timejob=15000 + elif [ $nproc_exe1 -lt 800 ] + then + timejob=20000 + elif [ $nproc_exe1 -lt 1600 ] + then + timejob=15000 + elif [ $nproc_exe1 -lt 3200 ] + then + timejob=7500 + elif [ $nproc_exe1 -lt 10000 ] + then + timejob=5000 + elif [ $nproc_exe1 -lt 20000 ] + then + timejob=2500 + else + timejob=1200 + fi + ;; +esac + + +###################################################################### +### beaufixlogin +###################################################################### + +if [ "$machine" == "beaufixlogin" ] +then + +cat > Log/run_bench << EOF +#!/bin/bash +#SBATCH --time=00:1:00 +#SBATCH -p normal64 # partition/queue +#SBATCH --job-name=bench # job name +#SBATCH -N $nnode # number of nodes +#SBATCH -n $nproc # number of procs +#SBATCH -o /scratch/work/cglo315/ESIWACE/dev_r9759_HPC09_ESIWACE/tests/LBENCH_RN/EXP00/Log/job.out%j +#SBATCH -e /scratch/work/cglo315/ESIWACE/dev_r9759_HPC09_ESIWACE/tests/LBENCH_RN/EXP00/Log/job.out%j +#SBATCH --exclusive + +module unload intelmpi intel grib_api +module load intel/16.1.150 intelmpi/5.1.2.150 + +itac=0 +xpmpi=0 + +if [ \$xpmpi == 1 ]; then + module load bullxde + module load xPMPI/1.1_intelmpi +fi + +[ \$itac == 1 ] && module load itac/2017.2.028 + +set -vx + +cd \${TMPDIR} +cp /scratch/work/cglo315/ESIWACE/dev_r9759_HPC09_ESIWACE/tests/LBENCH_RN/EXP00/* . + +# Best decompositions BENCH-1 +jpni=${cores/\**/} +jpnj=${cores/?*\*/} + +sed -e "s/jpni *=.*/jpni = \${jpni}/" -e "s/jpnj *=.*/jpnj = \${jpnj}/" namelist_cfg_orca${resolution}_like > namelist_cfg + +export OMP_NUM_THREADS=1 +ulimit -s unlimited +# +if [ \$itac == 1 ]; then + source /opt/softs/intel/2017/update_1/itac_latest/bin/itacvars.sh + time mpirun -ordered-output -prepend-rank -trace -np $nproc_exe1 ./nemo > jobout 2>joberr +else + time mpirun -ordered-output -prepend-rank -np $nproc_exe1 ./nemo > jobout_${resolution}_${nproc5} +fi +/opt/softs/bin/ja + +if [ \$xpmpi == 1 ]; then + module unload xPMPI/1.1_intelmpi + module unload bullxde +fi +# +EOF + + +### 4. Execute the model + + echo 'Submitting the job to queue using sbatch' + sbatch Log/run_bench + squeue -u cglo315 + +echo 'is executed or submitted to queue.' + + +fi + +###################################################################### +### curie or irene +###################################################################### + +if [[ ( "$machine" == "curie" ) || ( "$machine" == "irene" ) ]] +then + + [ "$machine" == "curie" ] && queuename=standard || queuename=skylake + + EXPjob=../EXP_${resolution}_${nproc5}_${dateref} + mkdir -p ${EXPjob} + cd ${EXPjob} + jobname=jobbench + cat > $jobname << EOF +#!/bin/bash +#MSUB -r bench${nproc5} +#MSUB -n ${nproc_exe1} +#MSUB -T $timejob +#MSUB -e bench_${resolution}_${nproc5}_%I.eo +#MSUB -o bench_${resolution}_${nproc5}_%I.eo +#MSUB -j oe +#MSUB -x +#MSUB -q ${queuename} +#MSUB -A gen6895 +#========================================== +set -u +# + +cd \${BRIDGE_MSUB_PWD} + +for ff in \${BRIDGE_MSUB_PWD}/../EXPREF/namelist_*cfg \${BRIDGE_MSUB_PWD}/../EXPREF/namelist_*ref \${BRIDGE_MSUB_PWD}/../BLD/bin/nemo.exe +do + cp \$ff . +done + +jpni=${cores/\**/} +jpnj=${cores/?*\*/} + +sed -e "s/jpni *=.*/jpni = \${jpni}/" \ + -e "s/jpnj *=.*/jpnj = \${jpnj}/"\ + -e "s/ln_timing *= *.false./ln_timing = .true./" \ + \${BRIDGE_MSUB_PWD}/../EXPREF/namelist_cfg_orca${resolution}_like > namelist_cfg + +time ccc_mprun -n \${BRIDGE_MSUB_NPROC} ./nemo.exe > jobout_${resolution}_${nproc5}_${dateref} 2>&1 + +EOF + + ccc_msub $jobname + +fi + +###################################################################### +### Jean-Zay +###################################################################### + +if [ "$machine" == "jean-zay" ] +then + hh=$( printf "%02d\n" $(( ${timejob} / 3600 )) ) + mm=$( printf "%02d\n" $(( ( ${timejob} % 3600 ) / 60 )) ) + ss=$( printf "%02d\n" $(( ( ${timejob} % 3600 ) % 60 )) ) + + EXPjob=../EXP_${resolution}_${nproc5}_${dateref} + mkdir -p ${EXPjob} + cd ${EXPjob} + jobname=jobbench + cat > $jobname << EOF +#!/bin/bash +#SBATCH --job-name=Seq # nom du job +#SBATCH --partition=cpu_gct3 # demande d'allocation sur la partition CPU +#SBATCH --nodes=${nnode} # nombre de noeuds +#SBATCH --ntasks-per-node=${ncore_node} # nombre de taches MPI par noeud +#SBATCH --ntasks-per-core=1 # 1 processus MPI par coeur physique (pas d'hyperthreading) +#SBATCH --time=${hh}:${mm}:${ss} # temps d execution maximum demande (HH:MM:SS) +#SBATCH --output=bench_${resolution}_${nproc5}_%j.eo # nom du fichier de sortie +#SBATCH --error=bench_${resolution}_${nproc5}_%j.eo # nom du fichier d'erreur (ici en commun avec la sortie) +#========================================== +set -u +#set -xv +# +#cd \${SLURM_SUBMIT_DIR} +cd \${JOBSCRATCH} +pwd + +for ff in \${SLURM_SUBMIT_DIR}/../EXPREF/namelist_*cfg \${SLURM_SUBMIT_DIR}/../EXPREF/namelist_*ref \${SLURM_SUBMIT_DIR}/../BLD/bin/nemo.exe +do + cp \$ff . +done + +jpni=${cores/\**/} +jpnj=${cores/?*\*/} + +sed -e "s/jpni *=.*/jpni = \${jpni}/" \ + -e "s/jpnj *=.*/jpnj = \${jpnj}/" \ + -e "s/ln_timing *= *.false./ln_timing = .true./" \ + \${SLURM_SUBMIT_DIR}/../EXPREF/namelist_cfg_orca${resolution}_like > namelist_cfg + +ls -l + +echo +echo +echo " =========== start the model ===========" +echo +echo + +time srun --mpi=pmi2 --cpu-bind=cores -K1 -n ${nproc} ./nemo.exe > jobout_${resolution}_${nproc5}_${dateref} 2>&1 + +ls -l + +if [ "\$( pwd )" != "\${SLURM_SUBMIT_DIR}" ] +then + rsync -av namelist_cfg time.step ocean.output jobout_${resolution}_${nproc5}_${dateref} communication_report.txt layout.dat timing.output output.namelist* \${SLURM_SUBMIT_DIR} +fi + +EOF + + sbatch $jobname + +fi diff --git a/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..08ae71a345178fb85ae85d7ed6a863ccec6e5665 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,118 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === BENCH configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for BENCH configuration + !!---------------------------------------------------------------------- + USE dom_oce ! 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_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0, NEMO Consortium (2016) + !! $Id$ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +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 : square box mesh mesh and Coriolis parameter + !! + !! ** Method : set all intent(out) argument to a proper value + !! BENCH configuration : beta-plance with uniform grid spacing (zres) + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in grid points) + !! - 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) :: zres, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : BENCH configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Beta-plane with regular grid-spacing' + IF(lwp) WRITE(numout,*) ' given by rn_dx and rn_dy' + ! + ! + ! Position coordinates (in grid points) + ! ========== + DO jj = 1, jpj + DO ji = 1, jpi + + zti = REAL( ji - 1 + nimpp - 1, wp ) ; ztj = REAL( jj - 1 + njmpp - 1, wp ) + zui = REAL( ji - 1 + nimpp - 1, wp ) + 0.5_wp ; zvj = REAL( jj - 1 + njmpp - 1, wp ) + 0.5_wp + + plamt(ji,jj) = zti + plamu(ji,jj) = zui + plamv(ji,jj) = zti + plamf(ji,jj) = zui + + pphit(ji,jj) = ztj + pphiv(ji,jj) = zvj + pphiu(ji,jj) = ztj + pphif(ji,jj) = zvj + + END DO + END DO + ! + ! Horizontal scale factors (in meters) + ! ====== + zres = 1.e+5 ! 100km + pe1t(:,:) = zres ; pe2t(:,:) = zres + pe1u(:,:) = zres ; pe2u(:,:) = zres + pe1v(:,:) = zres ; pe2v(:,:) = zres + pe1f(:,:) = zres ; pe2f(:,:) = zres + + ! ! NO reduction of grid size in some straits + ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_hgr 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 Coriolis parameter afterward + ! + zf0 = 2._wp * omega * SIN( rad * 45 ) ! constant coriolis factor corresponding to 45°N + pff_f(:,:) = zf0 + pff_t(:,:) = zf0 + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8c7c4bb425fb54096b0bd3d5753b7d6322902d3a --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,92 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === BENCH configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : NEMO ! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE dom_oce + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lbclnk ! lateral boundary conditions - mpp exchanges + ! + USE usrdef_nam + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2016) + !! $Id$ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here BENCH configuration + !! + !! ** Method : Set a gaussian anomaly of pressure and associated + !! geostrophic velocities + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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 + ! + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp) :: zfact + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : BENCH configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ! + ! define unique value on each point. z2d ranging from 0.05 to -0.05 + DO jj = 1, jpj + DO ji = 1, jpi + z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig(ji) + mjg(jj) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) ) + ENDDO + ENDDO + ! + ! sea level: + pssh(:,:) = z2d(:,:) ! +/- 0.05 m + ! + DO jk = 1, jpk + zfact = REAL(jk-1,wp) / REAL(jpk-1,wp) ! 0 to 1 to add a basic stratification + ! temperature choosen to lead to ~50% ice at the beginning if rn_thres_sst = 0.5 + pts(:,:,jk,jp_tem) = 20._wp*z2d(:,:) - 1._wp - 0.5_wp * zfact ! -1 to -1.5 +/-1.0 degG + ! salinity: + pts(:,:,jk,jp_sal) = 30._wp + 1._wp * zfact + z2d(:,:) ! 30 to 31 +/- 0.05 psu + ! velocities: + pu(:,:,jk) = z2d(:,:) * 0.1_wp ! +/- 0.005 m/s + pv(:,:,jk) = z2d(:,:) * 0.01_wp ! +/- 0.0005 m/s + ENDDO + ! + CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions + CALL lbc_lnk('usrdef_istate', pts, 'T', 1. ) ! apply boundary conditions + CALL lbc_lnk('usrdef_istate', pu, 'U', -1. ) ! apply boundary conditions + CALL lbc_lnk('usrdef_istate', pv, 'V', -1. ) ! apply boundary conditions + + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3c4a5fa78ea108dd717d209961554ce16eb7f9f2 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,118 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === BENCH configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_nam : read user defined namelist and set global domain size + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lib_mpp ! to get ctl_nam + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2016) + !! $Id$ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +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 EW_CANAL 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 + ! !!* namusr_def namelist *!! + INTEGER :: nn_isize ! number of point in i-direction of global(local) domain if >0 (<0) + INTEGER :: nn_jsize ! number of point in j-direction of global(local) domain if >0 (<0) + INTEGER :: nn_ksize ! total number of point in k-direction + INTEGER :: nn_perio ! periodicity + ! !!* nammpp namelist *!! + INTEGER :: jpni, jpnj + LOGICAL :: ln_nnogather, ln_listonly + !! + NAMELIST/namusr_def/ nn_isize, nn_jsize, nn_ksize, nn_perio + NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly + !!---------------------------------------------------------------------- + ! + REWIND( numnam_cfg ) ! Namelist namusr_def (exist in namelist_cfg only) + READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 903 ) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'BENCH' ! name & resolution (not used) + kk_cfg = 0 + ! + IF( nn_isize < 0 .AND. nn_jsize < 0 ) THEN + ! + REWIND( numnam_ref ) ! Namelist nammpp in reference namelist: mpi variables + 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 configuration namelist: mpi variables + READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) + + kpi = ( -nn_isize - 2*nn_hls ) * jpni + 2*nn_hls + kpj = ( -nn_jsize - 2*nn_hls ) * jpnj + 2*nn_hls + ELSE + kpi = nn_isize + kpj = nn_jsize + ENDIF + ! + kpk = nn_ksize + kperio = nn_perio + ! ! 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 : BENCH test case' + IF( nn_isize > 0 ) THEN + WRITE(numout,*) ' global domain size-x nn_isize = ', nn_isize + ELSE + WRITE(numout,*) ' jpni = ', jpni + WRITE(numout,*) ' local domain size-x -nn_isize = ', -nn_isize + WRITE(numout,*) ' global domain size-x kpi = ', kpi + ENDIF + IF( nn_jsize > 0 ) THEN + WRITE(numout,*) ' global domain size-y nn_jsize = ', nn_jsize + ELSE + WRITE(numout,*) ' jpnj = ', jpnj + WRITE(numout,*) ' local domain size-y -nn_jsize = ', -nn_jsize + WRITE(numout,*) ' global domain size-y kpj = ', kpj + ENDIF + WRITE(numout,*) ' global domain size-z nn_ksize = ', nn_ksize + WRITE(numout,*) ' LBC of the global domain kperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ad750f24d4c39a320637c21a68c0c0fc045799ff --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,167 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === BENCH configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in BENCH case + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE dom_oce + USE oce ! ocean dynamics and tracers + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ocean fields + USE in_out_manager ! I/O manager + USE phycst ! physical constants + USE lib_mpp ! MPP library + USE lbclnk ! lateral boundary conditions - mpp exchanges + +#if defined key_si3 + USE ice, ONLY : at_i_b, a_i_b +#endif + + 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 + + !!---------------------------------------------------------------------- + !! 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 BENCH case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : BENCH case: surface forcing' + IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ 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 + ! + utau_b(:,:) = 0._wp + vtau_b(:,:) = 0._wp + emp_b (:,:) = 0._wp + sfx_b (:,:) = 0._wp + qns_b (:,:) = 0._wp + ! + ENDIF + + ! + END SUBROUTINE usrdef_sbc_oce + + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_tau *** + !! + !! ** Purpose : provide the surface boundary (momentum) condition over + !sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + INTEGER :: ji, jj + !!--------------------------------------------------------------------- +#if defined key_si3 + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : BENCH case: constant stress forcing' + ! + ! define unique value on each point. z2d ranging from 0.05 to -0.05 + DO jj = 1, jpj + DO ji = 1, jpi + z2d(ji,jj) = 0.1 * ( 0.5 - REAL( nimpp + ji - 1 + ( njmpp + jj - 2 ) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) ) + ENDDO + ENDDO + utau_ice(:,:) = 0.1_wp + z2d(:,:) + vtau_ice(:,:) = 0.1_wp + z2d(:,:) + + CALL lbc_lnk_multi( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) +#endif + ! + END SUBROUTINE usrdef_sbc_ice_tau + + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_flx *** + !! + !! ** Purpose : provide the surface boundary (flux) condition over + !sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + !! + REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + !!--------------------------------------------------------------------- + ! +#if defined key_si3 + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : BENCH case: NO flux forcing' + ! + ! ocean variables (renaming) + emp_oce (:,:) = 0._wp ! uniform value for freshwater budget (E-P) + qsr_oce (:,:) = 0._wp ! uniform value for solar radiation + qns_oce (:,:) = 0._wp ! uniform value for non-solar radiation + + ! ice variables + alb_ice (:,:,:) = 0.7_wp ! useless + qsr_ice (:,:,:) = 0._wp ! uniform value for solar radiation + qns_ice (:,:,:) = 0._wp ! uniform value for non-solar radiation + sprecip (:,:) = 0._wp ! uniform value for snow precip + evap_ice(:,:,:) = 0._wp ! uniform value for sublimation + + ! ice fields deduced from above + zsnw(:,:) = 1._wp + emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) + emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) + qevap_ice(:,:,:) = 0._wp + qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + + ! total fluxes + emp_tot (:,:) = emp_ice + emp_oce + qns_tot (:,:) = at_i_b(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot (:,:) = at_i_b(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- shortwave radiation transmitted below the surface (W/m2) + qtr_ice_top(:,:,:) = 0._wp +#endif + + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3407c0f994990f983b08f4fcbfbb601973af4363 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,245 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === BENCH configuration === + !! + !! User defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 phycst ! physical constants + 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/OPA 4.0 , NEMO Consortium (2016) + !! $Id$ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +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 : BENCH configuration (z-coordinate closed flat box ocean)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ld_zco = .TRUE. ! BENCH 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) :: zd ! local scalar + !!---------------------------------------------------------------------- + ! + zd = 5000./FLOAT(jpkm1) + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates ' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' BENCH case : uniform vertical grid :' + WRITE(numout,*) ' with thickness = ', zd + ENDIF + + ! + ! 1D Reference z-coordinate (using Madec & Imbard 1996 function) + ! ------------------------- + ! + pdepw_1d(1) = 0._wp + pdept_1d(1) = 0.5_wp * zd + ! + DO jk = 2, jpk ! depth at T and W-points + pdepw_1d(jk) = pdepw_1d(jk-1) + zd + pdept_1d(jk) = pdept_1d(jk-1) + zd + 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 : BENCH 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 + REAL(wp) :: zmaxlam, zscl + !!---------------------------------------------------------------------- + ! + 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,*) ' BENCH case : closed flat box ocean without ocean cavities' + ! + z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom + ! + IF( jperio == 3 .OR. jperio ==4 ) THEN ! add a small island in the upper corners to avoid model instabilities... + z2d(mi0( 1):mi1( 3),mj0(jpjglo-2):mj1(jpjglo)) = 0. + z2d(mi0(jpiglo-2):mi1(jpiglo),mj0(jpjglo-2):mj1(jpjglo)) = 0. + ENDIF + ! + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed) + ! + k_bot(:,:) = INT( 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/V4.0/nemo_sources/tests/BENCH/MY_SRC/zdfiwm.F90 b/V4.0/nemo_sources/tests/BENCH/MY_SRC/zdfiwm.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7fceed56b16989b7eea71dbf776ae075984109b0 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/MY_SRC/zdfiwm.F90 @@ -0,0 +1,482 @@ +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: zdfiwm.F90 8093 2017-05-30 08:13:14Z gm $ + !! Software governed by the CeCILL licence (./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 ! 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 + zemx_iwm(:,:,jk) = zfact(:,:) * ( EXP( ( gde3w_n(:,:,jk ) - zhdep(:,:) ) / hcri_iwm(:,:) ) & + & - EXP( ( gde3w_n(:,:,jk-1) - zhdep(:,:) ) / hcri_iwm(:,:) ) ) * wmask(:,:,jk) & + & / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) + +!!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) + ! + zweight(:,:,:) = 0._wp + DO jk = 2, jpkm1 + zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_iwm(:,:) * wmask(:,:,jk) & + & * ( EXP( -zwkb(:,:,jk) / hbot_iwm(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_iwm(:,:) ) ) + 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 + DO jk = 2, jpkm1 ! Calculate S/T diffusivity ratio as a function of Reb + DO jj = 1, jpj + DO ji = 1, jpi + zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp * & + & TANH( 0.92_wp * ( LOG10( MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & + & ) * wmask(ji,jj,jk) + 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) + ebot_iwm(:,:) = 1.e-6 + ! +!!$ 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) + epyc_iwm(:,:) = 1.e-6 + ! +!!$ 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) + ecri_iwm(:,:) = 1.e-10 + ! +!!$ 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) + hbot_iwm(:,:) = 100. + ! +!!$ 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) + hcri_iwm(:,:) = 100. + + 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/V4.0/nemo_sources/tests/BENCH/cpp_BENCH.fcm b/V4.0/nemo_sources/tests/BENCH/cpp_BENCH.fcm new file mode 100644 index 0000000000000000000000000000000000000000..eb35129dca18fa0b306b021c33ab27e7da3632f1 --- /dev/null +++ b/V4.0/nemo_sources/tests/BENCH/cpp_BENCH.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_mpp_mpi key_si3 key_top diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/field_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..2145827c897baceb33d38fdbb0d2aa07c3837dcd --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1,1002 @@ +<?xml version="1.0"?> + <!-- $id$ --> + + <!-- +============================================================================================================ += definition of all existing variables = += DO NOT CHANGE = +============================================================================================================ + --> + <field_definition level="1" prec="4" operation="average" enabled=".TRUE." default_value="1.e20" > <!-- time step automaticaly defined --> + + <!-- +============================================================================================================ + Physical ocean model variables +============================================================================================================ + --> + + <!-- T grid --> + + <field_group id="grid_T" grid_ref="grid_T_2D" > + <field id="salgrad" long_name="module of salinity gradient" unit="psu/m" grid_ref="grid_T_3D"/> + <field id="salgrad2" long_name="square of module of salinity gradient" unit="psu2/m2" grid_ref="grid_T_3D"/> + <field id="ke" long_name="kinetic energy" unit="m2/s2" grid_ref="grid_T_3D"/> + <field id="ke_zint" long_name="vertical integration of kinetic energy" unit="m3/s2" /> + <field id="relvor" long_name="relative vorticity" unit="s-1" grid_ref="grid_T_3D"/> + <field id="absvor" long_name="absolute vorticity" unit="s-1" grid_ref="grid_T_3D"/> + <field id="potvor" long_name="potential vorticity" unit="s-1" grid_ref="grid_T_3D"/> + <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D"/> + <field id="e3t_surf" long_name="T-cell thickness" field_ref="e3t" standard_name="cell_thickness" unit="m" grid_ref="grid_T_SFC"/> + <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D"/> + + <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/> + <field id="toce_e3t" long_name="temperature (thickness weighted)" unit="degC" grid_ref="grid_T_3D" > toce * e3t </field > + <field id="soce" long_name="salinity" standard_name="sea_water_practical_salinity" unit="1e-3" grid_ref="grid_T_3D"/> + <field id="soce_e3t" long_name="salinity (thickness weighted)" unit="1e-3" grid_ref="grid_T_3D" > soce * e3t </field > + + <!-- t-eddy viscosity coefficients (ldfdyn) --> + <field id="ahmt_2d" long_name=" surface t-eddy viscosity coefficient" unit="m2/s or m4/s" /> + <field id="ahmt_3d" long_name=" 3D t-eddy viscosity coefficient" unit="m2/s or m4/s" grid_ref="grid_T_3D"/> + + <field id="sst" long_name="sea surface temperature" standard_name="sea_surface_temperature" unit="degC" /> + <field id="sst2" long_name="square of sea surface temperature" standard_name="square_of_sea_surface_temperature" unit="degC2" > sst * sst </field > + <field id="sstmax" long_name="max of sea surface temperature" field_ref="sst" operation="maximum" /> + <field id="sstmin" long_name="min of sea surface temperature" field_ref="sst" operation="minimum" /> + <field id="sstgrad" long_name="module of sst gradient" unit="degC/m" /> + <field id="sstgrad2" long_name="square of module of sst gradient" unit="degC2/m2" /> + <field id="sbt" long_name="sea bottom temperature" unit="degC" /> + <field id="tosmint" long_name="vertical integral of temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" /> + <field id="sst_wl" long_name="Delta SST of warm layer" unit="degC" /> + <field id="sst_cs" long_name="Delta SST of cool skin" unit="degC" /> + <field id="temp_3m" long_name="temperature at 3m" unit="degC" /> + + <field id="sss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" /> + <field id="sss2" long_name="square of sea surface salinity" unit="1e-6" > sss * sss </field > + <field id="sssmax" long_name="max of sea surface salinity" field_ref="sss" operation="maximum" /> + <field id="sssmin" long_name="min of sea surface salinity" field_ref="sss" operation="minimum" /> + <field id="sbs" long_name="sea bottom salinity" unit="0.001" /> + <field id="somint" long_name="vertical integral of salinity times density" standard_name="integral_wrt_depth_of_product_of_density_and_salinity" unit="(kg m2) x (1e-3)" /> + + <field id="taubot" long_name="bottom stress module" unit="N/m2" /> + + <field id="ssh" long_name="sea surface height" standard_name="sea_surface_height_above_geoid" unit="m" /> + <field id="ssh2" long_name="square of sea surface height" standard_name="square_of_sea_surface_height_above_geoid" unit="m2" > ssh * ssh </field > + <field id="wetdep" long_name="wet depth" standard_name="wet_depth" unit="m" /> + <field id="sshmax" long_name="max of sea surface height" field_ref="ssh" operation="maximum" /> + + <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" /> + <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" /> + <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" /> + <field id="mldkr125" long_name="Mixed Layer Depth (rhoc=.125)" unit="m" name="mlots125" standard_name="Mixed Layer Depth 0.125"/> + <field id="mldkr03" long_name="Mixed Layer Depth (rhoc=.03)" unit="m" name="mlots030" standard_name="Mixed Layer Depth 0.03"/> + <field id="mldt05" long_name="Mixed Layer Depth (t_c=0.5)" unit="m" name="mlott05" standard_name="Mixed Layer Depth 0.5C"/> + <field id="mldt02" long_name="Mixed Layer Depth (t_c=0.2)" unit="m" name="mlott02" standard_name="Mixed Layer Depth 0.2C"/> + <field id="mldzint_1" long_name="Mixed Layer Depth (mldzint_1)" unit="m"/> + <field id="mldzint_2" long_name="Mixed Layer Depth (mldzint_2)" unit="m"/> + <field id="mldzint_3" long_name="Mixed Layer Depth (mldzint_3)" unit="m"/> + <field id="mldzint_4" long_name="Mixed Layer Depth (mldzint_4)" unit="m"/> + <field id="mldzint_5" long_name="Mixed Layer Depth (mldzint_5)" unit="m"/> + <field id="mldhtc_1" long_name="Mixed Layer Depth (mldhtc_1)" unit="m"/> + <field id="mldhtc_2" long_name="Mixed Layer Depth (mldhtc_2)" unit="m"/> + <field id="mldhtc_3" long_name="Mixed Layer Depth (mldhtc_3)" unit="m"/> + <field id="mldhtc_4" long_name="Mixed Layer Depth (mldhtc_4)" unit="m"/> + <field id="mldhtc_5" long_name="Mixed Layer Depth (mldhtc_5)" unit="m"/> + <field id="heatc" long_name="Heat content vertically integrated" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" /> + <field id="saltc" long_name="Salt content vertically integrated" unit="1e-3*kg/m2" /> + <field id="salt2c" long_name="Salt content vertically integrated" unit="1e-3*kg/m2" /> + <field id="hst" long_name="Steric height" unit="m" name="sostheig" standard_name="Steric Height"/> + <field id="hbp" long_name="Bottom Pressure Equivalent Height" unit="m" name="sopbheig" standard_name="Bottom Pressure Equivalent Height"/> + + <!-- EOS --> + <field id="alpha" long_name="thermal expansion" unit="degC-1" grid_ref="grid_T_3D" /> + <field id="beta" long_name="haline contraction" unit="1e3" grid_ref="grid_T_3D" /> + <field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-1" grid_ref="grid_T_3D" /> + <field id="rhop" long_name="potential density (sigma0)" standard_name="sea_water_sigma_theta" unit="kg/m3" grid_ref="grid_T_3D" /> + + <!-- Energy - horizontal divergence --> + <field id="eken" long_name="kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_3D" /> + <field id="hdiv" long_name="horizontal divergence" unit="s-1" grid_ref="grid_T_3D" /> + + <!-- variables available with MLE --> + <field id="Lf_NHpf" long_name="MLE: Lf = N H / f" unit="m" /> + + <!-- next variables available with key_diahth --> + <field id="mlddzt" long_name="Thermocline Depth (depth of max dT/dz)" standard_name="depth_at_maximum_upward_derivative_of_sea_water_potential_temperature" unit="m" /> + <field id="mldr10_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr0_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr0_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mld_dt02" long_name="Mixed Layer Depth (|dT| = 0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" /> + <field id="topthdep" long_name="Top of Thermocline Depth (dT = -0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" /> + <field id="pycndep" long_name="Pycnocline Depth (dsigma[dT=-0.2] wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="BLT" long_name="Barrier Layer Thickness" unit="m" > topthdep - pycndep </field> + <field id="tinv" long_name="Max of vertical invertion of temperature" unit="degC" /> + <field id="depti" long_name="Depth of max. vert. inv. of temperature" unit="m" /> + <field id="20d" long_name="Depth of 20C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_20C" /> + <field id="28d" long_name="Depth of 28C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_28C" /> + <field id="hc300" long_name="Heat content 0-300m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" /> + + <!-- variables available with diaar5 --> + <field id="botpres" long_name="Sea Water Pressure at Sea Floor" standard_name="sea_water_pressure_at_sea_floor" unit="dbar" /> + <field id="sshdyn" long_name="dynamic sea surface height" standard_name="dynamic_sea_surface_height_above_geoid" unit="m" /> + <field id="sshdyn2" long_name="square of dynamic sea surface height" standard_name="dynamic_sea_surface_height_above_geoid_squared" unit="m2" > sshdyn * sshdyn </field> + <field id="tnpeo" long_name="Tendency of ocean potential energy content" unit="W/m2" /> + + <!-- variables available ln_linssh=.FALSE. --> + <field id="tpt_dep" long_name="T-point depth" standard_name="depth_below_geoid" unit="m" grid_ref="grid_T_3D" /> + <field id="e3tdef" long_name="T-cell thickness deformation" unit="%" grid_ref="grid_T_3D" /> + </field_group> + + <!-- Tides --> + + <field_group id="Tides_T" grid_ref="grid_T_2D" operation="once" > + <!-- tidal composante --> + <field id="M2x" long_name="M2 Elevation harmonic real part " unit="m" /> + <field id="M2y" long_name="M2 Elevation harmonic imaginary part" unit="m" /> + <field id="S2x" long_name="S2 Elevation harmonic real part " unit="m" /> + <field id="S2y" long_name="S2 Elevation harmonic imaginary part" unit="m" /> + <field id="N2x" long_name="N2 Elevation harmonic real part " unit="m" /> + <field id="N2y" long_name="N2 Elevation harmonic imaginary part" unit="m" /> + <field id="K1x" long_name="K1 Elevation harmonic real part " unit="m" /> + <field id="K1y" long_name="K1 Elevation harmonic imaginary part" unit="m" /> + <field id="O1x" long_name="O1 Elevation harmonic real part " unit="m" /> + <field id="O1y" long_name="O1 Elevation harmonic imaginary part" unit="m" /> + <field id="Q1x" long_name="Q1 Elevation harmonic real part " unit="m" /> + <field id="Q1y" long_name="Q1 Elevation harmonic imaginary part" unit="m" /> + <field id="M4x" long_name="M4 Elevation harmonic real part " unit="m" /> + <field id="M4y" long_name="M4 Elevation harmonic imaginary part" unit="m" /> + <field id="K2x" long_name="K2 Elevation harmonic real part " unit="m" /> + <field id="K2y" long_name="K2 Elevation harmonic imaginary part" unit="m" /> + <field id="P1x" long_name="P1 Elevation harmonic real part " unit="m" /> + <field id="P1y" long_name="P1 Elevation harmonic imaginary part" unit="m" /> + <field id="Mfx" long_name="Mf Elevation harmonic real part " unit="m" /> + <field id="Mfy" long_name="Mf Elevation harmonic imaginary part" unit="m" /> + <field id="Mmx" long_name="Mm Elevation harmonic real part " unit="m" /> + <field id="Mmy" long_name="Mm Elevation harmonic imaginary part" unit="m" /> + </field_group> + + <field_group id="Tides_U" grid_ref="grid_U_2D" operation="once" > + <field id="M2x_u" long_name="M2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="M2y_u" long_name="M2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="S2x_u" long_name="S2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="S2y_u" long_name="S2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="N2x_u" long_name="N2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="N2y_u" long_name="N2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="K1x_u" long_name="K1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="K1y_u" long_name="K1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="O1x_u" long_name="O1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="O1y_u" long_name="O1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Q1x_u" long_name="Q1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Q1y_u" long_name="Q1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="M4x_u" long_name="M4 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="M4y_u" long_name="M4 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="K2x_u" long_name="K2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="K2y_u" long_name="K2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="P1x_u" long_name="P1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="P1y_u" long_name="P1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Mfx_u" long_name="Mf current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Mfy_u" long_name="Mf current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Mmx_u" long_name="Mm current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Mmy_u" long_name="Mm current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + </field_group> + + <field_group id="Tides_V" grid_ref="grid_V_2D" operation="once" > + <field id="M2x_v" long_name="M2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="M2y_v" long_name="M2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="S2x_v" long_name="S2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="S2y_v" long_name="S2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="N2x_v" long_name="N2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="N2y_v" long_name="N2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="K1x_v" long_name="K1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="K1y_v" long_name="K1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="O1x_v" long_name="O1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="O1y_v" long_name="O1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Q1x_v" long_name="Q1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Q1y_v" long_name="Q1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="M4x_v" long_name="M4 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="M4y_v" long_name="M4 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="K2x_v" long_name="K2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="K2y_v" long_name="K2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="P1x_v" long_name="P1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="P1y_v" long_name="P1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Mfx_v" long_name="Mf current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Mfy_v" long_name="Mf current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Mmx_v" long_name="Mm current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Mmy_v" long_name="Mm current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + </field_group> + + <!-- OSMOSIS variables (available with ln_zdfosm=.true.) --> + + <field_group id="OSMOSIS_T" grid_ref="grid_T_2D"> + <field id="zwth0" long_name="surface non-local temperature flux" unit="deg m/s" /> + <field id="zws0" long_name="surface non-local salinity flux" unit="psu m/s" /> + <field id="hbl" long_name="boundary layer depth" unit="m" /> + <field id="hbli" long_name="initial boundary layer depth" unit="m" /> + <field id="dstokes" long_name="stokes drift depth scale" unit="m" /> + <field id="zustke" long_name="magnitude of stokes drift at T-points" unit="m/s" /> + <field id="zwstrc" long_name="convective velocity scale" unit="m/s" /> + <field id="zwstrl" long_name="langmuir velocity scale" unit="m/s" /> + <field id="zustar" long_name="friction velocity" unit="m/s" /> + <field id="zhbl" long_name="boundary layer depth" unit="m" /> + <field id="zhml" long_name="mixed layer depth" unit="m" /> + <field id="wind_wave_abs_power" long_name="\rho |U_s| x u*^2" unit="mW" /> + <field id="wind_wave_power" long_name="U_s \dot tau" unit="mW" /> + <field id="wind_power" long_name="\rho u*^3" unit="mW" /> + + <!-- extra OSMOSIS diagnostics --> + <field id="zwthav" long_name="av turb flux of T in ml" unit="deg m/s" /> + <field id="zt_ml" long_name="av T in ml" unit="deg" /> + <field id="zwth_ent" long_name="entrainment turb flux of T" unit="deg m/s" /> + <field id="zhol" long_name="Hoenekker number" unit="#" /> + <field id="zdh" long_name="Pycnocline depth - grid" unit=" m" /> + </field_group> + + <field_group id="OSMOSIS_W" grid_ref="grid_W_3D" operation="instant" > + <field id="ghamt" long_name="non-local temperature flux" unit="deg m/s" /> + <field id="ghams" long_name="non-local salinity flux" unit="psu m/s" /> + <field id="zdtdz_pyc" long_name="Pycnocline temperature gradient" unit=" deg/m" /> + </field_group> + + <field_group id="OSMOSIS_U" grid_ref="grid_U_2D" > + <field id="ghamu" long_name="non-local u-momentum flux" grid_ref="grid_U_3D" unit="m^2/s^2" /> + <field id="us_x" long_name="i component of Stokes drift" unit="m/s" /> + </field_group> + + <field_group id="OSMOSIS_V" grid_ref="grid_V_2D" > + <field id="ghamv" long_name="non-local v-momentum flux" grid_ref="grid_V_3D" unit="m^2/s^2" /> + <field id="us_y" long_name="j component of Stokes drift" unit="m/s" /> + </field_group> + + <!-- SBC --> + + <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> + <field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> + <field id="empbmr" long_name="Net Upward Water Flux at pre. tstep" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> + <field id="emp_oce" long_name="Evap minus Precip over ocean" standard_name="evap_minus_precip_over_sea_water" unit="kg/m2/s" /> + <field id="emp_ice" long_name="Evap minus Precip over ice" standard_name="evap_minus_precip_over_sea_ice" unit="kg/m2/s" /> + <field id="saltflx" long_name="Downward salt flux" unit="1e-3/m2/s" /> + <field id="fmmflx" long_name="Water flux due to freezing/melting" unit="kg/m2/s" /> + <field id="snowpre" long_name="Snow precipitation" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="runoffs" long_name="River Runoffs" standard_name="water_flux_into_sea_water_from_rivers" unit="kg/m2/s" /> + <field id="precip" long_name="Total precipitation" standard_name="precipitation_flux" unit="kg/m2/s" /> + + <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> + <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" /> + <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" /> + <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" /> + <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> + <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" /> + + <!-- * variable relative to atmospheric pressure forcing : available with ln_apr_dyn --> + <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" /> + + <!-- * variable related to ice shelf forcing * --> + <field id="fwfisf" long_name="Ice shelf melting" unit="kg/m2/s" /> + <field id="fwfisf3d" long_name="Ice shelf melting" unit="kg/m2/s" grid_ref="grid_T_3D" /> + <field id="qlatisf" long_name="Ice shelf latent heat flux" unit="W/m2" /> + <field id="qlatisf3d" long_name="Ice shelf latent heat flux" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="qhcisf" long_name="Ice shelf heat content flux" unit="W/m2" /> + <field id="qhcisf3d" long_name="Ice shelf heat content flux" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="isfgammat" long_name="transfert coefficient for isf (temperature) " unit="m/s" /> + <field id="isfgammas" long_name="transfert coefficient for isf (salinity) " unit="m/s" /> + <field id="stbl" long_name="salinity in the Losh tbl " unit="PSU" /> + <field id="ttbl" long_name="temperature in the Losh tbl " unit="C" /> + <field id="utbl" long_name="zonal current in the Losh tbl at T point " unit="m/s" /> + <field id="vtbl" long_name="merid current in the Losh tbl at T point " unit="m/s" /> + <field id="thermald" long_name="thermal driving of ice shelf melting " unit="C" /> + <field id="tfrz" long_name="top freezing point (used to compute melt) " unit="C" /> + <field id="tinsitu" long_name="top insitu temperature (used to cmpt melt) " unit="C" /> + <field id="ustar" long_name="ustar at T point used in ice shelf melting " unit="m/s" /> + + <!-- *_oce variables available with ln_blk_clio or ln_blk_core --> + <field id="qlw_oce" long_name="Longwave Downward Heat Flux over open ocean" standard_name="surface_net_downward_longwave_flux" unit="W/m2" /> + <field id="qsb_oce" long_name="Sensible Downward Heat Flux over open ocean" standard_name="surface_downward_sensible_heat_flux" unit="W/m2" /> + <field id="qla_oce" long_name="Latent Downward Heat Flux over open ocean" standard_name="surface_downward_latent_heat_flux" unit="W/m2" /> + <field id="qt_oce" long_name="total flux at ocean surface" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> + <field id="qsr_oce" long_name="solar heat flux at ocean surface" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qns_oce" long_name="non-solar heat flux at ocean surface (including E-P)" unit="W/m2" /> + <field id="qemp_oce" long_name="Downward Heat Flux from E-P over open ocean" unit="W/m2" /> + <field id="taum_oce" long_name="wind stress module over open ocean" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> + + <!-- available key_oasis3 --> + <field id="snow_ao_cea" long_name="Snow over ice-free ocean (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="snow_ai_cea" long_name="Snow over sea-ice (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="subl_ai_cea" long_name="Sublimation over sea-ice (cell average)" standard_name="surface_snow_and_ice_sublimation_flux" unit="kg/m2/s" /> + <field id="icealb_cea" long_name="Ice albedo (cell average)" standard_name="sea_ice_albedo" unit="1" /> + <field id="calving_cea" long_name="Calving" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" /> + <field id="iceberg_cea" long_name="Iceberg" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" /> + <field id="iceshelf_cea" long_name="Iceshelf" standard_name="water_flux_into_sea_water_from_iceshelf" unit="kg/m2/s" /> + + + <!-- available if key_oasis3 + conservative method --> + <field id="rain" long_name="Liquid precipitation" standard_name="rainfall_flux" unit="kg/m2/s" /> + <field id="evap_ao_cea" long_name="Evaporation over ice-free ocean (cell average)" standard_name="water_evaporation_flux" unit="kg/m2/s" /> + <field id="isnwmlt_cea" long_name="Snow over Ice melting (cell average)" standard_name="surface_snow_melt_flux" unit="kg/m2/s" /> + <field id="fsal_virt_cea" long_name="Virtual salt flux due to ice formation (cell average)" standard_name="virtual_salt_flux_into_sea_water_due_to_sea_ice_thermodynamics" unit="kg/m2/s" /> + <field id="fsal_real_cea" long_name="Real salt flux due to ice formation (cell average)" standard_name="downward_sea_ice_basal_salt_flux" unit="kg/m2/s" /> + <field id="hflx_rain_cea" long_name="heat flux due to rainfall" standard_name="temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water" unit="W/m2" /> + <field id="hflx_evap_cea" long_name="heat flux due to evaporation" standard_name="temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water" unit="W/m2" /> + <field id="hflx_snow_cea" long_name="heat flux due to snow falling" standard_name="heat_flux_onto_ocean_and_ice_due_to_snow_thermodynamics" unit="W/m2" /> + <field id="hflx_snow_ai_cea" long_name="heat flux due to snow falling over ice" standard_name="heat_flux_onto_ice_due_to_snow_thermodynamics" unit="W/m2" /> + <field id="hflx_snow_ao_cea" long_name="heat flux due to snow falling over ice-free ocean" standard_name="heat_flux_onto_sea_water_due_to_snow_thermodynamics" unit="W/m2" /> + <field id="hflx_ice_cea" long_name="heat flux due to ice thermodynamics" standard_name="heat_flux_into_sea_water_due_to_sea_ice_thermodynamics" unit="W/m2" /> + <field id="hflx_rnf_cea" long_name="heat flux due to runoffs" standard_name="temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water" unit="W/m2" /> + <field id="hflx_cal_cea" long_name="heat flux due to calving" standard_name="heat_flux_into_sea_water_due_to_calving" unit="W/m2" /> + <field id="hflx_icb_cea" long_name="heat flux due to iceberg" standard_name="heat_flux_into_sea_water_due_to_icebergs" unit="W/m2" /> + <field id="hflx_isf_cea" long_name="heat flux due to iceshelf" standard_name="heat_flux_into_sea_water_due_to_iceshelf" unit="W/m2" /> + <field id="bicemel_cea" long_name="Rate of Melt at Sea Ice Base (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_basal_melting" unit="kg/m2/s" /> + <field id="licepro_cea" long_name="Lateral Sea Ice Growth Rate (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_lateral_growth_of_ice_floes" unit="kg/m2/s" /> + <field id="snowmel_cea" long_name="Snow Melt Rate (cell average)" standard_name="surface_snow_melt_flux" unit="kg/m2/s" /> + <field id="sntoice_cea" long_name="Snow-Ice Formation Rate (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_snow_conversion" unit="kg/m2/s" /> + <field id="ticemel_cea" long_name="Rate of Melt at Upper Surface of Sea Ice (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_surface_melting" unit="kg/m2/s" /> + + <!-- ice field (nn_ice=1) --> + <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" /> + + <!-- dilution --> + <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" /> + <field id="emp_x_sss" long_name="Concentration/Dilution term on SSS" unit="kg*1e-3/m2/s" /> + <field id="rnf_x_sst" long_name="Runoff term on SST" unit="kg*degC/m2/s" /> + <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" /> + + <!-- sbcssm variables --> + <field id="sst_m" unit="degC" /> + <field id="sss_m" unit="psu" /> + <field id="ssu_m" unit="m/s" /> + <field id="ssv_m" unit="m/s" /> + <field id="ssh_m" unit="m" /> + <field id="e3t_m" unit="m" /> + <field id="frq_m" unit="-" /> + + </field_group> + + <!-- U grid --> + + <field_group id="grid_U" grid_ref="grid_U_2D"> + <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> + <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/> + <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> + <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> + <field id="uoce_e3u" long_name="ocean current along i-axis (thickness weighted)" unit="m/s" grid_ref="grid_U_3D" > uoce * e3u </field> + <field id="ssu" long_name="ocean surface current along i-axis" unit="m/s" /> + <field id="sbu" long_name="ocean bottom current along i-axis" unit="m/s" /> + <field id="ubar" long_name="ocean barotropic current along i-axis" unit="m/s" /> + <field id="uocetr_eff" long_name="Effective ocean transport along i-axis" standard_name="ocean_volume_x_transport" unit="m3/s" grid_ref="grid_U_3D" /> + <field id="uocet" long_name="ocean transport along i-axis times temperature (CRS)" unit="degC*m/s" grid_ref="grid_U_3D" /> + <field id="uoces" long_name="ocean transport along i-axis times salinity (CRS)" unit="1e-3*m/s" grid_ref="grid_U_3D" /> + + <!-- u-eddy diffusivity coefficients (available if ln_traldf_OFF=F) --> + <field id="ahtu_2d" long_name=" surface u-eddy diffusivity coefficient" unit="m2/s or m4/s" /> + <field id="ahtu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s or m4/s" grid_ref="grid_U_3D"/> + <!-- u-eiv diffusivity coefficients (available if ln_ldfeiv=F) --> + <field id="aeiu_2d" long_name=" surface u-EIV coefficient" unit="m2/s" /> + <field id="aeiu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s" grid_ref="grid_U_3D"/> + + <!-- variables available with MLE (ln_mle=T) --> + <field id="psiu_mle" long_name="MLE streamfunction along i-axis" unit="m3/s" grid_ref="grid_U_3D" /> + + <!-- uoce_eiv: available EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) --> + <field id="uoce_eiv" long_name="EIV ocean current along i-axis" standard_name="bolus_sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> + + <!-- uoce_bbl: available with ln_trabbl=T and nn_bbl_adv=1 --> + <field id="uoce_bbl" long_name="BBL ocean current along i-axis" unit="m/s" /> + <!-- ahu_bbl : available with ln_trabbl=T and nn_bbl_ldf=1 --> + <field id="ahu_bbl" long_name="BBL diffusive flux along i-axis" unit="m3/s" /> + + <!-- variable for ice shelves --> + <field id="utbl" long_name="zonal current in the Losh tbl" unit="m/s" /> + + <field id="u_masstr" long_name="Ocean Mass X Transport" standard_name="ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D" /> + <field id="u_masstr_vint" long_name="vertical integral of ocean eulerian mass transport along i-axis" standard_name="vertical_integral_of_ocean_mass_x_transport" unit="kg/s" /> + <field id="u_heattr" long_name="ocean eulerian heat transport along i-axis" standard_name="ocean_heat_x_transport" unit="W" /> + <field id="u_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_x_transport" unit="1e-3*kg/s" /> + <field id="uadv_heattr" long_name="ocean advective heat transport along i-axis" standard_name="advectice_ocean_heat_x_transport" unit="W" /> + <field id="uadv_salttr" long_name="ocean advective salt transport along i-axis" standard_name="advectice_ocean_salt_x_transport" unit="1e-3*kg/s" /> + <field id="ueiv_heattr" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" /> + <field id="ueiv_salttr" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" /> + <field id="ueiv_heattr3d" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" grid_ref="grid_U_3D" /> + <field id="ueiv_salttr3d" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_U_3D" /> + <field id="udiff_heattr" long_name="ocean diffusion heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_diffusion" unit="W" /> + <field id="udiff_salttr" long_name="ocean diffusion salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_diffusion" unit="1e-3*kg/s" /> + </field_group> + + <!-- V grid --> + + <field_group id="grid_V" grid_ref="grid_V_2D"> + <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> + <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D"/> + <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> + <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> + <field id="voce_e3v" long_name="ocean current along j-axis (thickness weighted)" unit="m/s" grid_ref="grid_V_3D" > voce * e3v </field> + <field id="ssv" long_name="ocean surface current along j-axis" unit="m/s" /> + <field id="sbv" long_name="ocean bottom current along j-axis" unit="m/s" /> + <field id="vbar" long_name="ocean barotropic current along j-axis" unit="m/s" /> + <field id="vocetr_eff" long_name="Effective ocean transport along j-axis" standard_name="ocean_volume_y_transport" unit="m3/s" grid_ref="grid_V_3D" /> + <field id="vocet" long_name="ocean transport along j-axis times temperature (CRS)" unit="degC*m/s" grid_ref="grid_V_3D" /> + <field id="voces" long_name="ocean transport along j-axis times salinity (CRS)" unit="1e-3*m/s" grid_ref="grid_V_3D" /> + + <!-- v-eddy diffusivity coefficients (available if ln_traldf_OFF=F) --> + <field id="ahtv_2d" long_name=" surface v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" /> + <field id="ahtv_3d" long_name=" 3D v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" grid_ref="grid_V_3D"/> + <!-- v-eiv diffusivity coefficients (available if ln_ldfeiv=F) --> + <field id="aeiv_2d" long_name=" surface v-EIV coefficient" unit="m2/s" /> + <field id="aeiv_3d" long_name=" 3D v-EIV coefficient" unit="m2/s" grid_ref="grid_V_3D" /> + + <!-- variables available with MLE (ln_mle=T) --> + <field id="psiv_mle" long_name="MLE streamfunction along j-axis" unit="m3/s" grid_ref="grid_V_3D" /> + + <!-- voce_eiv: available EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) --> + <field id="voce_eiv" long_name="EIV ocean current along j-axis" standard_name="bolus_sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> + + <!-- voce_bbl: available with ln_trabbl=T and nn_bbl_adv=1 --> + <field id="voce_bbl" long_name="BBL ocean current along j-axis" unit="m/s" /> + <!-- ahu_bbl : available with ln_trabbl=T and nn_bbl_ldf=1 --> + <field id="ahv_bbl" long_name="BBL diffusive flux along j-axis" unit="m3/s" /> + + <!-- variable for ice shelves --> + <field id="vtbl" long_name="meridional current in the Losh tbl" unit="m/s" /> + + <!-- variables available with diaar5 --> + <field id="v_masstr" long_name="ocean eulerian mass transport along j-axis" standard_name="ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D" /> + <field id="v_heattr" long_name="ocean eulerian heat transport along j-axis" standard_name="ocean_heat_y_transport" unit="W" /> + <field id="v_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_y_transport" unit="1e-3*kg/s" /> + <field id="vadv_heattr" long_name="ocean advective heat transport along j-axis" standard_name="advectice_ocean_heat_y_transport" unit="W" /> + <field id="vadv_salttr" long_name="ocean advective salt transport along j-axis" standard_name="advectice_ocean_salt_y_transport" unit="1e-3*kg/s" /> + <field id="veiv_heattr" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" /> + <field id="veiv_salttr" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" /> + <field id="veiv_heattr3d" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" grid_ref="grid_V_3D" /> + <field id="veiv_salttr3d" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_V_3D" /> + <field id="vdiff_heattr" long_name="ocean diffusion heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_diffusion" unit="W" /> + <field id="vdiff_salttr" long_name="ocean diffusion salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_diffusion" unit="1e-3*kg/s" /> + </field_group> + + <!-- W grid --> + + <field_group id="grid_W" grid_ref="grid_W_3D"> + <field id="e3w" long_name="W-cell thickness" standard_name="cell_thickness" unit="m" /> + <field id="woce" long_name="ocean vertical velocity" standard_name="upward_sea_water_velocity" unit="m/s" /> + <field id="wocetr_eff" long_name="effective ocean vertical transport" unit="m3/s" /> + + <!-- woce_eiv: available with EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) --> + <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" /> + + <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" /> + + <!-- avs: /= avt with ln_zdfddm=T --> + <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" /> + <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + + <!-- avt_evd and avm_evd: available with ln_zdfevd --> + <field id="avt_evd" long_name="convective enhancement of vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_convection" unit="m2/s" /> + <field id="avm_evd" long_name="convective enhancement of vertical viscosity" standard_name="ocean_vertical_momentum_diffusivity_due_to_convection" unit="m2/s" /> + + <!-- avt_tide: available with ln_zdfiwm=T --> + <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" /> + <field id="av_wave" long_name="internal wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" /> + <field id="bflx_iwm" long_name="internal wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" /> + <field id="pcmap_iwm" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D" /> + <field id="emix_iwm" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" /> + + <!-- variables available with diaar5 --> + <field id="w_masstr" long_name="vertical mass transport" standard_name="upward_ocean_mass_transport" unit="kg/s" /> + <field id="w_masstr2" long_name="square of vertical mass transport" standard_name="square_of_upward_ocean_mass_transport" unit="kg2/s2" /> + + </field_group> + + <!-- F grid --> + <!-- f-eddy viscosity coefficients (ldfdyn) --> + <field id="ahmf_2d" long_name=" surface f-eddy viscosity coefficient" unit="m2/s or m4/s" /> + <field id="ahmf_3d" long_name=" 3D f-eddy viscosity coefficient" unit="m2/s or m4/s" grid_ref="grid_T_3D"/> + + <field_group id="scalar" grid_ref="grid_T_2D" > + <!-- Need to have a salinity reference climatological file : sali_ref_clim_monthly --> + <field id="voltot" long_name="global total volume" standard_name="sea_water_volume" unit="m3" /> + <field id="sshtot" long_name="global mean ssh" standard_name="global_average_sea_level_change" unit="m" /> + <field id="sshsteric" long_name="global mean ssh steric" standard_name="global_average_steric_sea_level_change" unit="m" /> + <field id="sshthster" long_name="global mean ssh thermosteric" standard_name="global_average_thermosteric_sea_level_change" unit="m" /> + <field id="masstot" long_name="global total mass" standard_name="sea_water_mass" unit="kg" /> + <field id="temptot" long_name="global mean temperature" standard_name="sea_water_potential_temperature" unit="degC" /> + <field id="saltot" long_name="global mean salinity" standard_name="sea_water_salinity" unit="1e-3" /> + <field id="fram_trans" long_name="Sea Ice Mass Transport Through Fram Strait" standard_name="sea_ice_transport_across_line" unit="kg/s" /> + + <!-- available with ln_diahsb --> + <field id="bgtemper" long_name="drift in global mean temperature wrt timestep 1" standard_name="change_over_time_in_sea_water_potential_temperature" unit="degC" /> + <field id="bgsaline" long_name="drift in global mean salinity wrt timestep 1" standard_name="change_over_time_in_sea_water_practical_salinity" unit="1e-3" /> + <field id="bgheatco" long_name="drift in global mean heat content wrt timestep 1" unit="1.e20J" /> + <field id="bgheatfx" long_name="drift in global mean heat flux wrt timestep 1" unit="W/m2" /> + <field id="bgsaltco" long_name="drift in global mean salt content wrt timestep 1" unit="1e-3*km3" /> + <field id="bgvolssh" long_name="drift in global mean ssh volume wrt timestep 1" unit="km3" /> + <field id="bgvole3t" long_name="drift in global mean volume variation (e3t) wrt timestep 1" unit="km3" /> + <field id="bgfrcvol" long_name="global mean volume from forcing" unit="km3" /> + <field id="bgfrctem" long_name="global mean heat content from forcing" unit="1.e20J" /> + <field id="bgfrchfx" long_name="global mean heat flux from forcing" unit="W/m2" /> + <field id="bgfrcsal" long_name="global mean salt content from forcing" unit="1e-3*km3" /> + <field id="bgmistem" long_name="global mean temperature error due to free surface (linssh true)" unit="degC" /> + <field id="bgmissal" long_name="global mean salinity error due to free surface (linssh true)" unit="1e-3" /> + </field_group> + + <!-- variables available with key_float --> + + <field_group id="floatvar" grid_ref="grid_T_nfloat" operation="instant" > + <field id="traj_lon" long_name="floats longitude" unit="degrees_east" /> + <field id="traj_lat" long_name="floats latitude" unit="degrees_north" /> + <field id="traj_dep" long_name="floats depth" unit="m" /> + <field id="traj_temp" long_name="floats temperature" standard_name="sea_water_potential_temperature" unit="degC" /> + <field id="traj_salt" long_name="floats salinity" standard_name="sea_water_practical_salinity" unit="1e-3" /> + <field id="traj_dens" long_name="floats in-situ density" standard_name="sea_water_density" unit="kg/m3" /> + <field id="traj_group" long_name="floats group" unit="1" /> + </field_group> + + <!-- variables available with iceberg trajectories --> + + <field_group id="icbvar" domain_ref="grid_T" > + <field id="berg_melt" long_name="icb melt rate of icebergs" unit="kg/m2/s" /> + <field id="berg_buoy_melt" long_name="icb buoyancy component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_eros_melt" long_name="icb erosion component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_conv_melt" long_name="icb convective component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_virtual_area" long_name="icb virtual coverage by icebergs" unit="m2" /> + <field id="bits_src" long_name="icb mass source of bergy bits" unit="kg/m2/s" /> + <field id="bits_melt" long_name="icb melt rate of bergy bits" unit="kg/m2/s" /> + <field id="bits_mass" long_name="icb bergy bit density field" unit="kg/m2" /> + <field id="berg_mass" long_name="icb iceberg density field" unit="kg/m2" /> + <field id="calving" long_name="icb calving mass input" unit="kg/s" /> + <field id="berg_floating_melt" long_name="icb melt rate of icebergs + bits" unit="kg/m2/s" /> + <field id="berg_real_calving" long_name="icb calving into iceberg class" unit="kg/s" axis_ref="icbcla" /> + <field id="berg_stored_ice" long_name="icb accumulated ice mass by class" unit="kg" axis_ref="icbcla" /> + </field_group> + + <!-- Poleward transport : ptr --> + <field_group id="diaptr" > + <field id="zomsfglo" long_name="Meridional Stream-Function: Global" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfatl" long_name="Meridional Stream-Function: Atlantic" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfpac" long_name="Meridional Stream-Function: Pacific" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfind" long_name="Meridional Stream-Function: Indian" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfipc" long_name="Meridional Stream-Function: Pacific+Indian" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zotemglo" long_name="Zonal Mean Temperature : Global" unit="degree_C" grid_ref="gznl_T_3D" /> + <field id="zotematl" long_name="Zonal Mean Temperature : Atlantic" unit="degree_C" grid_ref="gznl_T_3D" /> + <field id="zotempac" long_name="Zonal Mean Temperature : Pacific" unit="degree_C" grid_ref="gznl_T_3D" /> + <field id="zotemind" long_name="Zonal Mean Temperature : Indian" unit="degree_C" grid_ref="gznl_T_3D" /> + <field id="zotemipc" long_name="Zonal Mean Temperature : Pacific+Indian" unit="degree_C" grid_ref="gznl_T_3D" /> + <field id="zosalglo" long_name="Zonal Mean Salinity : Global" unit="0.001" grid_ref="gznl_T_3D" /> + <field id="zosalatl" long_name="Zonal Mean Salinity : Atlantic" unit="0.001" grid_ref="gznl_T_3D" /> + <field id="zosalpac" long_name="Zonal Mean Salinity : Pacific" unit="0.001" grid_ref="gznl_T_3D" /> + <field id="zosalind" long_name="Zonal Mean Salinity : Indian" unit="0.001" grid_ref="gznl_T_3D" /> + <field id="zosalipc" long_name="Zonal Mean Salinity : Pacific+Indian" unit="0.001" grid_ref="gznl_T_3D" /> + <field id="zosrfglo" long_name="Zonal Mean Surface" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfatl" long_name="Zonal Mean Surface : Atlantic" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfpac" long_name="Zonal Mean Surface : Pacific" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfind" long_name="Zonal Mean Surface : Indian" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfipc" long_name="Zonal Mean Surface : Pacific+Indian" unit="m2" grid_ref="gznl_T_3D" /> + <field id="sophtadv" long_name="Advective Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtadv_atl" long_name="Advective Heat Transport: Atlantic" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtadv_pac" long_name="Advective Heat Transport: Pacific" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtadv_ind" long_name="Advective Heat Transport: Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtadv_ipc" long_name="Advective Heat Transport: Pacific+Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf" long_name="Diffusive Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf_atl" long_name="Diffusive Heat Transport: Atlantic" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf_pac" long_name="Diffusive Heat Transport: Pacific" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf_ind" long_name="Diffusive Heat Transport: Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf_ipc" long_name="Diffusive Heat Transport: Pacific+Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtove" long_name="Overturning Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtove_atl" long_name="Overturning Heat Transport: Atlantic" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtove_pac" long_name="Overturning Heat Transport: Pacific" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtove_ind" long_name="Overturning Heat Transport: Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtove_ipc" long_name="Overturning Heat Transport: Pacific+Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtbtr" long_name="Barotropic Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtbtr_atl" long_name="Barotropic Heat Transport: Atlantic" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtbtr_pac" long_name="Barotropic Heat Transport: Pacific" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtbtr_ind" long_name="Barotropic Heat Transport: Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtbtr_ipc" long_name="Barotropic Heat Transport: Pacific+Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophteiv" long_name="Heat Transport from mesoscale eddy advection" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophteiv_atl" long_name="Heat Transport from mesoscale eddy advection: Atlantic" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophteiv_pac" long_name="Heat Transport from mesoscale eddy advection: Pacific" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophteiv_ind" long_name="Heat Transport from mesoscale eddy advection: Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophteiv_ipc" long_name="Heat Transport from mesoscale eddy advection: Pacific+Indian" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sopstadv" long_name="Advective Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstadv_atl" long_name="Advective Salt Transport: Atlantic" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstadv_pac" long_name="Advective Salt Transport: Pacific" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstadv_ind" long_name="Advective Salt Transport: Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstadv_ipc" long_name="Advective Salt Transport: Pacific+Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstove" long_name="Overturning Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstove_atl" long_name="Overturning Salt Transport: Atlantic" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstove_pac" long_name="Overturning Salt Transport: Pacific" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstove_ind" long_name="Overturning Salt Transport: Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstove_ipc" long_name="Overturning Salt Transport: Pacific+Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstbtr" long_name="Barotropic Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstbtr_atl" long_name="Barotropic Salt Transport: Atlantic" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstbtr_pac" long_name="Barotropic Salt Transport: Pacific" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstbtr_ind" long_name="Barotropic Salt Transport: Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstbtr_ipc" long_name="Barotropic Salt Transport: Pacific+Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf" long_name="Diffusive Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf_atl" long_name="Diffusive Salt Transport: Atlantic" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf_pac" long_name="Diffusive Salt Transport: Pacific" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf_ind" long_name="Diffusive Salt Transport: Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf_ipc" long_name="Diffusive Salt Transport: Pacific+Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopsteiv" long_name="Salt Transport from mesoscale eddy advection" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopsteiv_atl" long_name="Salt Transport from mesoscale eddy advection: Atlantic" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopsteiv_pac" long_name="Salt Transport from mesoscale eddy advection: Pacific" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopsteiv_ind" long_name="Salt Transport from mesoscale eddy advection: Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopsteiv_ipc" long_name="Salt Transport from mesoscale eddy advection: Pacific+Indian" unit="Giga g/s" grid_ref="gznl_T_2D" /> + </field_group> + + <!-- +============================================================================================================ + Physical ocean model trend diagnostics : temperature, KE, PE, momentum +============================================================================================================ + --> + + <!-- variables available with ln_tra_trd --> + <!-- Asselin trends calculated on odd time steps--> + <field_group id="trendT_odd" grid_ref="grid_T_3D"> + <field id="ttrd_atf" long_name="temperature-trend: asselin time filter" unit="degree_C/s" /> + <field id="strd_atf" long_name="salinity -trend: asselin time filter" unit="0.001/s" /> + <!-- Thickness weighted versions: --> + <field id="ttrd_atf_e3t" unit="degC/s * m" > ttrd_atf * e3t </field> + <field id="strd_atf_e3t" unit="1e-3/s * m" > strd_atf * e3t </field> + <!-- OMIP layer-integrated trends --> + <field id="ttrd_atf_li" long_name="layer integrated heat-trend: asselin time filter " unit="W/m^2" > ttrd_atf_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_atf_li" long_name="layer integrated salt -trend: asselin time filter " unit="kg/(m^2 s)" > strd_atf_e3t * 1026.0 * 0.001 </field> + </field_group> + + <!-- Other trends calculated on even time steps--> + <field_group id="trendT_even" grid_ref="grid_T_3D"> + <field id="ttrd_xad" long_name="temperature-trend: i-advection" unit="degC/s" /> + <field id="strd_xad" long_name="salinity -trend: i-advection" unit="1e-3/s" /> + <field id="ttrd_yad" long_name="temperature-trend: j-advection" unit="degC/s" /> + <field id="strd_yad" long_name="salinity -trend: j-advection" unit="1e-3/s" /> + <field id="ttrd_zad" long_name="temperature-trend: k-advection" unit="degC/s" /> + <field id="strd_zad" long_name="salinity -trend: k-advection" unit="1e-3/s" /> + <field id="ttrd_ad" long_name="temperature-trend: advection" standard_name="tendency_of_sea_water_temperature_due_to_advection" unit="degC/s" > sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) </field> + <field id="strd_ad" long_name="salinity -trend: advection" standard_name="tendency_of_sea_water_salinity_due_to_advection" unit="1e-3/s" > sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) </field> + <field id="ttrd_totad" long_name="temperature-trend: total advection" standard_name="tendency_of_sea_water_salinity_due_to_advection" unit="degC/s" /> + <field id="strd_totad" long_name="salinity -trend: total advection" standard_name="tendency_of_sea_water_salinity_due_to_advection" unit="1e-3/s" /> + <field id="ttrd_sad" long_name="temperature-trend: surface adv. (linssh true)" unit="degC/s" grid_ref="grid_T_2D" /> + <field id="strd_sad" long_name="salinity -trend: surface adv. (linssh true)" unit="1e-3/s" grid_ref="grid_T_2D" /> + <field id="ttrd_ldf" long_name="temperature-trend: lateral diffusion" standard_name="tendency_of_sea_water_temperature_due_to_horizontal_mixing" unit="degC/s" /> + <field id="strd_ldf" long_name="salinity -trend: lateral diffusion" standard_name="tendency_of_sea_water_salinity_due_to_horizontal_mixing" unit="1e-3/s" /> + <field id="ttrd_zdf" long_name="temperature-trend: vertical diffusion" standard_name="tendency_of_sea_water_temperature_due_to_vertical_mixing" unit="degC/s" /> + <field id="strd_zdf" long_name="salinity -trend: vertical diffusion" standard_name="tendency_of_sea_water_salinity_due_to_vertical_mixing" unit="1e-3/s" /> + <field id="ttrd_evd" long_name="temperature-trend: EVD convection" unit="degC/s" /> + <field id="strd_evd" long_name="salinity -trend: EVD convection" unit="1e-3/s" /> + + <!-- ln_traldf_iso=T only (iso-neutral diffusion) --> + <field id="ttrd_iso" long_name="temperature-trend: isopycnal diffusion" unit="degC/s" > ttrd_ldf + ttrd_zdf - ttrd_zdfp </field> + <field id="strd_iso" long_name="salinity -trend: isopycnal diffusion" unit="1e-3/s" > strd_ldf + strd_zdf - strd_zdfp </field> + <field id="ttrd_zdfp" long_name="temperature-trend: pure vert. diffusion" unit="degC/s" /> + <field id="strd_zdfp" long_name="salinity -trend: pure vert. diffusion" unit="1e-3/s" /> + + <!-- --> + <field id="ttrd_dmp" long_name="temperature-trend: interior restoring" unit="degC/s" /> + <field id="strd_dmp" long_name="salinity -trend: interior restoring" unit="1e-3/s" /> + <field id="ttrd_bbl" long_name="temperature-trend: bottom boundary layer" unit="degC/s" /> + <field id="strd_bbl" long_name="salinity -trend: bottom boundary layer" unit="1e-3/s" /> + <field id="ttrd_npc" long_name="temperature-trend: non-penetrative conv." unit="degC/s" /> + <field id="strd_npc" long_name="salinity -trend: non-penetrative conv." unit="1e-3/s" /> + <field id="ttrd_qns" long_name="temperature-trend: non-solar flux + runoff" unit="degC/s" grid_ref="grid_T_2D" /> + <field id="strd_cdt" long_name="salinity -trend: C/D term + runoff" unit="degC/s" grid_ref="grid_T_2D" /> + <field id="ttrd_qsr" long_name="temperature-trend: solar penetr. heating" unit="degC/s" /> + <field id="ttrd_bbc" long_name="temperature-trend: geothermal heating" unit="degC/s" /> + + <!-- Thickness weighted versions: --> + <field id="ttrd_xad_e3t" unit="degC/s * m" > ttrd_xad * e3t </field> + <field id="strd_xad_e3t" unit="1e-3/s * m" > strd_xad * e3t </field> + <field id="ttrd_yad_e3t" unit="degC/s * m" > ttrd_yad * e3t </field> + <field id="strd_yad_e3t" unit="1e-3/s * m" > strd_yad * e3t </field> + <field id="ttrd_zad_e3t" unit="degC/s * m" > ttrd_zad * e3t </field> + <field id="strd_zad_e3t" unit="1e-3/s * m" > strd_zad * e3t </field> + <field id="ttrd_ad_e3t" unit="degC/s * m" > ttrd_ad * e3t </field> + <field id="strd_ad_e3t" unit="1e-3/s * m" > strd_ad * e3t </field> + <field id="ttrd_totad_e3t" unit="degC/s * m" > ttrd_totad * e3t </field> + <field id="strd_totad_e3t" unit="1e-3/s * m" > strd_totad * e3t </field> + <field id="ttrd_ldf_e3t" unit="degC/s * m" > ttrd_ldf * e3t </field> + <field id="strd_ldf_e3t" unit="1e-3/s * m" > strd_ldf * e3t </field> + <field id="ttrd_zdf_e3t" unit="degC/s * m" > ttrd_zdf * e3t </field> + <field id="strd_zdf_e3t" unit="1e-3/s * m" > strd_zdf * e3t </field> + <field id="ttrd_evd_e3t" unit="degC/s * m" > ttrd_evd * e3t </field> + <field id="strd_evd_e3t" unit="1e-3/s * m" > strd_evd * e3t </field> + + <!-- ln_traldf_iso=T only (iso-neutral diffusion) --> + <field id="ttrd_iso_e3t" unit="degC/s * m" > ttrd_iso * e3t </field> + <field id="strd_iso_e3t" unit="1e-3/s * m" > strd_iso * e3t </field> + <field id="ttrd_zdfp_e3t" unit="degC/s * m" > ttrd_zdfp * e3t </field> + <field id="strd_zdfp_e3t" unit="1e-3/s * m" > strd_zdfp * e3t </field> + + <!-- --> + <field id="ttrd_dmp_e3t" unit="degC/s * m" > ttrd_dmp * e3t </field> + <field id="strd_dmp_e3t" unit="1e-3/s * m" > strd_dmp * e3t </field> + <field id="ttrd_bbl_e3t" unit="degC/s * m" > ttrd_bbl * e3t </field> + <field id="strd_bbl_e3t" unit="1e-3/s * m" > strd_bbl * e3t </field> + <field id="ttrd_npc_e3t" unit="degC/s * m" > ttrd_npc * e3t </field> + <field id="strd_npc_e3t" unit="1e-3/s * m" > strd_npc * e3t </field> + <field id="ttrd_qns_e3t" unit="degC/s * m" > ttrd_qns * e3t_surf </field> + <field id="strd_cdt_e3t" unit="degC/s * m" > strd_cdt * e3t_surf </field> + <field id="ttrd_qsr_e3t" unit="degC/s * m" > ttrd_qsr * e3t </field> + <field id="ttrd_bbc_e3t" unit="degC/s * m" > ttrd_bbc * e3t </field> + + <!-- OMIP layer-integrated trends --> + <field id="ttrd_totad_li" long_name="layer integrated heat-trend : total advection" unit="W/m^2" > ttrd_totad_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_totad_li" long_name="layer integrated salt -trend : total advection" unit="kg/(m^2 s)" > strd_totad_e3t * 1026.0 * 0.001 </field> + <field id="ttrd_evd_li" long_name="layer integrated heat-trend : EVD convection" unit="W/m^2" > ttrd_evd_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_evd_li" long_name="layer integrated salt -trend : EVD convection" unit="kg/(m^2 s)" > strd_evd_e3t * 1026.0 * 0.001 </field> + <field id="ttrd_iso_li" long_name="layer integrated heat-trend : isopycnal diffusion" unit="W/m^2" > ttrd_iso_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_iso_li" long_name="layer integrated salt -trend : isopycnal diffusion" unit="kg/(m^2 s)" > strd_iso_e3t * 1026.0 * 0.001 </field> + <field id="ttrd_zdfp_li" long_name="layer integrated heat-trend : pure vert. diffusion" unit="W/m^2" > ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_zdfp_li" long_name="layer integrated salt -trend : pure vert. diffusion" unit="kg/(m^2 s)" > strd_zdfp_e3t * 1026.0 * 0.001 </field> + <field id="ttrd_qns_li" long_name="layer integrated heat-trend : non-solar flux + runoff" unit="W/m^2" grid_ref="grid_T_2D"> ttrd_qns_e3t * 1026.0 * 3991.86795711963 </field> + <field id="ttrd_qsr_li" long_name="layer integrated heat-trend : solar flux" unit="W/m^2" grid_ref="grid_T_3D"> ttrd_qsr_e3t * 1026.0 * 3991.86795711963 </field> + <field id="ttrd_bbl_li" long_name="layer integrated heat-trend: bottom boundary layer " unit="W/m^2" > ttrd_bbl_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_bbl_li" long_name="layer integrated salt -trend: bottom boundary layer " unit="kg/(m^2 s)" > strd_bbl_e3t * 1026.0 * 0.001 </field> + <field id="ttrd_evd_li" long_name="layer integrated heat -trend: evd convection " unit="W/m^2" >ttrd_evd_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_evd_li" long_name="layer integrated salt -trend: evd convection " unit="kg/(m^2 s)" > strd_evd_e3t * 1026.0 * 0.001 </field> + + </field_group> + + <!-- Total trends calculated every time step--> + <field_group id="trendT" grid_ref="grid_T_3D"> + <field id="ttrd_tot" long_name="temperature-trend: total model trend" unit="degC/s" /> + <field id="strd_tot" long_name="salinity -trend: total model trend" unit="1e-3/s" /> + <!-- Thickness weighted versions: --> + <field id="ttrd_tot_e3t" unit="degC/s * m" > ttrd_tot * e3t </field> + <field id="strd_tot_e3t" unit="1e-3/s * m" > strd_tot * e3t </field> + <!-- OMIP layer-integrated total trends --> + <field id="ttrd_tot_li" long_name="layer integrated heat-trend: total model trend :" unit="W/m^2" > ttrd_tot_e3t * 1026.0 * 3991.86795711963 </field> + <field id="strd_tot_li" long_name="layer integrated salt -trend: total model trend :" unit="kg/(m^2 s)" > strd_tot_e3t * 1026.0 * 0.001 </field> + + <!-- **** these trends have not been apportioned to all/even/odd ts yet **** --> + <!-- variables available with ln_KE_trd --> + <field id="ketrd_hpg" long_name="ke-trend: hydrostatic pressure gradient" unit="W/s^3" /> + <field id="ketrd_spg" long_name="ke-trend: surface pressure gradient" unit="W/s^3" /> + <field id="ketrd_spgexp" long_name="ke-trend: surface pressure gradient (explicit)" unit="W/s^3" /> + <field id="ketrd_spgflt" long_name="ke-trend: surface pressure gradient (filter)" unit="W/s^3" /> + <field id="ssh_flt" long_name="filtered contribution to ssh (dynspg_flt)" unit="m" grid_ref="grid_T_2D" /> + <field id="w0" long_name="surface vertical velocity" unit="m/s" grid_ref="grid_T_2D" /> + <field id="pw0_exp" long_name="surface pressure flux due to ssh" unit="W/s^2" grid_ref="grid_T_2D" /> + <field id="pw0_flt" long_name="surface pressure flux due to filtered ssh" unit="W/s^2" grid_ref="grid_T_2D" /> + <field id="ketrd_keg" long_name="ke-trend: KE gradient or hor. adv." unit="W/s^3" /> + <field id="ketrd_rvo" long_name="ke-trend: relative vorticity or metric term" unit="W/s^3" /> + <field id="ketrd_pvo" long_name="ke-trend: planetary vorticity" unit="W/s^3" /> + <field id="ketrd_zad" long_name="ke-trend: vertical advection" unit="W/s^3" /> + <field id="ketrd_udx" long_name="ke-trend: U.dx[U]" unit="W/s^3" /> + <field id="ketrd_ldf" long_name="ke-trend: lateral diffusion" unit="W/s^3" /> + <field id="ketrd_zdf" long_name="ke-trend: vertical diffusion" unit="W/s^3" /> + <field id="ketrd_tau" long_name="ke-trend: wind stress " unit="W/s^3" grid_ref="grid_T_2D" /> + <field id="ketrd_bfr" long_name="ke-trend: bottom friction (explicit)" unit="W/s^3" /> + <field id="ketrd_bfri" long_name="ke-trend: bottom friction (implicit)" unit="W/s^3" /> + <field id="ketrd_atf" long_name="ke-trend: asselin time filter trend" unit="W/s^3" /> + <field id="ketrd_convP2K" long_name="ke-trend: conversion (potential to kinetic)" unit="W/s^3" /> + <field id="KE" long_name="kinetic energy: u(n)*u(n+1)/2" unit="W/s^2" /> + + <!-- variables available when explicit lateral mixing is used (ln_dynldf_OFF=F) --> + <field id="dispkexyfo" long_name="KE-trend: lateral mixing induced dissipation" standard_name="ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction" unit="W/m^2" grid_ref="grid_T_2D" /> + <field id="dispkevfo" long_name="KE-trend: vertical mixing induced dissipation" standard_name="ocean_kinetic_energy_dissipation_per_unit_area_due_to_vertical_friction" unit="W/m^2" grid_ref="grid_T_2D" /> + <!-- variables available with ln_traadv_eiv=T and ln_diaeiv=T --> + <field id="eketrd_eiv" long_name="EKE-trend due to parameterized eddy advection" standard_name="tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection" unit="W/m^2" grid_ref="grid_T_2D" /> + + <!-- variables available with ln_PE_trd --> + <field id="petrd_xad" long_name="pe-trend: i-advection" unit="W/m^3" /> + <field id="petrd_yad" long_name="pe-trend: j-advection" unit="W/m^3" /> + <field id="petrd_zad" long_name="pe-trend: k-advection" unit="W/m^3" /> + <field id="petrd_sad" long_name="pe-trend: surface adv. (linssh true)" unit="W/m^3" grid_ref="grid_T_2D" /> + <field id="petrd_ldf" long_name="pe-trend: lateral diffusion" unit="W/m^3" /> + <field id="petrd_zdf" long_name="pe-trend: vertical diffusion" unit="W/m^3" /> + <field id="petrd_zdfp" long_name="pe-trend: pure vert. diffusion" unit="W/m^3" /> + <field id="petrd_dmp" long_name="pe-trend: interior restoring" unit="W/m^3" /> + <field id="petrd_bbl" long_name="pe-trend: bottom boundary layer" unit="W/m^3" /> + <field id="petrd_npc" long_name="pe-trend: non-penetrative conv." unit="W/m^3" /> + <field id="petrd_nsr" long_name="pe-trend: surface forcing + runoff" unit="W/m^3" /> + <field id="petrd_qsr" long_name="pe-trend: solar penetr. heating" unit="W/m^3" /> + <field id="petrd_bbc" long_name="pe-trend: geothermal heating" unit="W/m^3" /> + <field id="petrd_atf" long_name="pe-trend: asselin time filter" unit="W/m^3" /> + <field id="PEanom" long_name="potential energy anomaly" unit="1" /> + <field id="alphaPE" long_name="partial deriv. of PEanom wrt T" unit="degC-1" /> + <field id="betaPE" long_name="partial deriv. of PEanom wrt S" unit="1e3" /> + </field_group> + + <field_group id="trendU" grid_ref="grid_U_3D"> + <!-- variables available with ln_dyn_trd --> + <field id="utrd_hpg" long_name="i-trend: hydrostatic pressure gradient" unit="m/s^2" /> + <field id="utrd_spg" long_name="i-trend: surface pressure gradient" unit="m/s^2" /> + <field id="utrd_spgexp" long_name="i-trend: surface pressure gradient (explicit)" unit="m/s^2" /> + <field id="utrd_spgflt" long_name="i-trend: surface pressure gradient (filtered)" unit="m/s^2" /> + <field id="utrd_keg" long_name="i-trend: KE gradient or hor. adv." unit="m/s^2" /> + <field id="utrd_rvo" long_name="i-trend: relative vorticity or metric term" unit="m/s^2" /> + <field id="utrd_pvo" long_name="i-trend: planetary vorticity" unit="m/s^2" /> + <field id="utrd_zad" long_name="i-trend: vertical advection" unit="m/s^2" /> + <field id="utrd_udx" long_name="i-trend: U.dx[U]" unit="m/s^2" /> + <field id="utrd_ldf" long_name="i-trend: lateral diffusion" unit="m/s^2" /> + <field id="utrd_zdf" long_name="i-trend: vertical diffusion" unit="m/s^2" /> + <field id="utrd_tau" long_name="i-trend: wind stress " unit="m/s^2" grid_ref="grid_U_2D" /> + <field id="utrd_bfr" long_name="i-trend: bottom friction (explicit)" unit="m/s^2" /> + <field id="utrd_bfri" long_name="i-trend: bottom friction (implicit)" unit="m/s^2" /> + <field id="utrd_tot" long_name="i-trend: total momentum trend before atf" unit="m/s^2" /> + <field id="utrd_atf" long_name="i-trend: asselin time filter trend" unit="m/s^2" /> + </field_group> + + <field_group id="trendV" grid_ref="grid_V_3D"> + <!-- variables available with ln_dyn_trd --> + <field id="vtrd_hpg" long_name="j-trend: hydrostatic pressure gradient" unit="m/s^2" /> + <field id="vtrd_spg" long_name="j-trend: surface pressure gradient" unit="m/s^2" /> + <field id="vtrd_spgexp" long_name="j-trend: surface pressure gradient (explicit)" unit="m/s^2" /> + <field id="vtrd_spgflt" long_name="j-trend: surface pressure gradient (filtered)" unit="m/s^2" /> + <field id="vtrd_keg" long_name="j-trend: KE gradient or hor. adv." unit="m/s^2" /> + <field id="vtrd_rvo" long_name="j-trend: relative vorticity or metric term" unit="m/s^2" /> + <field id="vtrd_pvo" long_name="j-trend: planetary vorticity" unit="m/s^2" /> + <field id="vtrd_zad" long_name="j-trend: vertical advection" unit="m/s^2" /> + <field id="vtrd_vdy" long_name="i-trend: V.dx[V]" unit="m/s^2" /> + <field id="vtrd_ldf" long_name="j-trend: lateral diffusion" unit="m/s^2" /> + <field id="vtrd_zdf" long_name="j-trend: vertical diffusion" unit="m/s^2" /> + <field id="vtrd_tau" long_name="j-trend: wind stress " unit="m/s^2" grid_ref="grid_V_2D" /> + <field id="vtrd_bfr" long_name="j-trend: bottom friction (explicit)" unit="m/s^2" /> + <field id="vtrd_bfri" long_name="j-trend: bottom friction (implicit)" unit="m/s^2" /> + <field id="vtrd_tot" long_name="j-trend: total momentum trend before atf" unit="m/s^2" /> + <field id="vtrd_atf" long_name="j-trend: asselin time filter trend" unit="m/s^2" /> + </field_group> + + + <!-- +============================================================================================================ + Definitions for iodef_demo.xml +============================================================================================================ + --> + + <field_group id="TRD" > + <field field_ref="ttrd_totad_li" name="opottempadvect" /> + <field field_ref="ttrd_iso_li" name="opottemppmdiff" /> + <field field_ref="ttrd_zdfp_li" name="opottempdiff" /> + <field field_ref="ttrd_evd_li" name="opottempevd" /> + <field field_ref="strd_evd_li" name="osaltevd" /> + <field field_ref="ttrd_qns_li" name="opottempqns" /> + <field field_ref="ttrd_qsr_li" name="rsdoabsorb" operation="accumulate" /> + <field field_ref="strd_totad_li" name="osaltadvect" /> + <field field_ref="strd_iso_li" name="osaltpmdiff" /> + <field field_ref="strd_zdfp_li" name="osaltdiff" /> + </field_group> + + <field_group id="mooring" > + <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> + <field field_ref="soce" name="so" long_name="sea_water_salinity" /> + <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> + <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> + <field field_ref="woce" name="wo" long_name="sea_water_z_velocity" /> + <field field_ref="avt" name="difvho" long_name="ocean_vertical_heat_diffusivity" /> + <field field_ref="avm" name="difvmo" long_name="ocean_vertical_momentum_diffusivity" /> + + <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> + <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> + <field field_ref="sstgrad" name="tosgrad" long_name="module_of_sea_surface_temperature_gradient" /> + <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> + <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> + <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> + <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> + <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> + <field field_ref="taum" /> + <field field_ref="20d" /> + <field field_ref="mldkz5" /> + <field field_ref="mldr10_1" /> + <field field_ref="mldr10_3" /> + <field field_ref="mldr0_1" /> + <field field_ref="mldr0_3" /> + <field field_ref="mld_dt02" /> + <field field_ref="topthdep" /> + <field field_ref="pycndep" /> + <field field_ref="tinv" /> + <field field_ref="depti" /> + <field field_ref="BLT" name="blt" long_name="barrier_layer_thickness" /> + <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> + <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> + </field_group> + + <field_group id="groupT" > + <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> + <field field_ref="soce" name="so" long_name="sea_water_salinity" /> + <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> + <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> + <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> + <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> + <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> + <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> + <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> + <field field_ref="taum" /> + <field field_ref="20d" /> + <field field_ref="mldkz5" /> + <field field_ref="mldr10_1" /> + <field field_ref="mldr10_3" /> + <field field_ref="mld_dt02" /> + <field field_ref="topthdep" /> + <field field_ref="pycndep" /> + <field field_ref="tinv" /> + <field field_ref="depti" /> + <field field_ref="BLT" name="blt" long_name="Barrier Layer Thickness" /> + </field_group> + + <field_group id="groupU" > + <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> + <field field_ref="ssu" name="uos" long_name="sea_surface_x_velocity" /> + <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> + </field_group> + + <field_group id="groupV" > + <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> + <field field_ref="ssv" name="vos" long_name="sea_surface_y_velocity" /> + <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> + </field_group> + + <field_group id="groupW" > + <field field_ref="woce" name="wo" long_name="ocean vertical velocity" /> + </field_group> + + <!-- TMB diagnostic output --> + <field_group id="1h_grid_T_tmb" grid_ref="grid_T_2D" operation="instant"> + <field id="top_temp" name="votemper_top" unit="degC" /> + <field id="mid_temp" name="votemper_mid" unit="degC" /> + <field id="bot_temp" name="votemper_bot" unit="degC" /> + <field id="top_sal" name="vosaline_top" unit="psu" /> + <field id="mid_sal" name="vosaline_mid" unit="psu" /> + <field id="bot_sal" name="vosaline_bot" unit="psu" /> + <field id="sshnmasked" name="sossheig" unit="m" /> + </field_group> + + <field_group id="1h_grid_U_tmb" grid_ref="grid_U_2D" operation="instant"> + <field id="top_u" name="vozocrtx_top" unit="m/s" /> + <field id="mid_u" name="vozocrtx_mid" unit="m/s" /> + <field id="bot_u" name="vozocrtx_bot" unit="m/s" /> + <field id="baro_u" name="vobtcrtx" unit="m/s" /> + </field_group> + + <field_group id="1h_grid_V_tmb" grid_ref="grid_V_2D" operation="instant"> + <field id="top_v" name="vomecrty_top" unit="m/s" /> + <field id="mid_v" name="vomecrty_mid" unit="m/s" /> + <field id="bot_v" name="vomecrty_bot" unit="m/s" /> + <field id="baro_v" name="vobtcrty" unit="m/s" /> + </field_group> + + <!-- 25h diagnostic output --> + <field_group id="25h_grid_T" grid_ref="grid_T_3D" operation="instant"> + <field id="temper25h" name="potential temperature 25h mean" unit="degC" /> + <field id="tempis25h" name="insitu temperature 25h mean" unit="degC" /> + <field id="salin25h" name="salinity 25h mean" unit="psu" /> + <field id="ssh25h" name="sea surface height 25h mean" grid_ref="grid_T_2D" unit="m" /> + </field_group> + + <field_group id="25h_grid_U" grid_ref="grid_U_3D" operation="instant" > + <field id="vozocrtx25h" name="i current 25h mean" unit="m/s" /> + </field_group> + + <field_group id="25h_grid_V" grid_ref="grid_V_3D" operation="instant"> + <field id="vomecrty25h" name="j current 25h mean" unit="m/s" /> + </field_group> + + <field_group id="25h_grid_W" grid_ref="grid_W_3D" operation="instant"> + <field id="vomecrtz25h" name="k current 25h mean" unit="m/s" /> + <field id="avt25h" name="vertical diffusivity25h mean" unit="m2/s" /> + <field id="avm25h" name="vertical viscosity 25h mean" unit="m2/s" /> + <field id="tke25h" name="turbulent kinetic energy 25h mean" /> + <field id="mxln25h" name="mixing length 25h mean" unit="m" /> + </field_group> + + <!-- +============================================================================================================ + --> + <!-- output variables for my configuration (example) --> + + <field_group id="myvarOCE" > + <!-- grid T --> + <field field_ref="e3t" name="e3t" long_name="vertical scale factor" /> + <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> + <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> + <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> + + <!-- grid U --> + <field field_ref="e3u" name="e3u" long_name="vertical scale factor" /> + <field field_ref="ssu" name="uos" long_name="sea_surface_x_velocity" /> + + <!-- grid V --> + <field field_ref="e3v" name="e3v" long_name="vertical scale factor" /> + <field field_ref="ssv" name="vos" long_name="sea_surface_y_velocity" /> + </field_group> + + </field_definition> diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..5b7170bfa163b5805bfafaa40c467f9ba7dc80cb --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,43 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@" sync_freq="10d" min_digits="4"> + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE." > <!-- 5d files --> + + <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="toce" /> + <field field_ref="soce" /> + <field field_ref="ssh" /> + <field field_ref="socegrad" /> + <field field_ref="eken_int" /> + <field field_ref="relvor" /> + <field field_ref="potvor" /> + <field field_ref="saltc" /> + <field field_ref="salt2c" /> + </file> + + <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="utau" /> + <field field_ref="uoce" /> + <field_group group_ref="trendU" /> + </file> + + <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="vtau" /> + <field field_ref="voce" /> + <field_group group_ref="trendV" /> + </file> + + <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > + <field field_ref="woce" /> + </file> + + </file_group> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/CANAL/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..8a1ffca37b5e8e266097de22cb94c67ed92105bd --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/iodef.xml @@ -0,0 +1,25 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> +</simulation> diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..c5f414e99b399e0a942dd4eabb2d728f46a001c8 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_cfg @@ -0,0 +1,378 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO Configuration namelist : overwrite some defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! CANAL 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : CANAL configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + rn_domszx = 2000. ! x horizontal size [km] + rn_domszy = 1000. ! y horizontal size [km] + rn_domszz = 1000. ! z vertical size [m] + rn_dx = 10. ! x horizontal resolution [km] + rn_dy = 10. ! y horizontal resolution [km] + rn_dz = 1000. ! z vertical resolution [m] + rn_0xratio = 0.5 ! x-domain ratio of the 0 + rn_0yratio = 0.5 ! y-domain ratio of the 0 + nn_fcase = 0 ! F computation (0:f0, 1:Beta, 2:real) + rn_ppgphi0 = 38.5 ! Reference latitude [degrees] + rn_u10 = 0. ! 10m wind speed [m/s] + rn_windszx = 90. ! longitudinal wind extension [km] + rn_windszy = 90. ! latitudinal wind extension [km] +!!clem rn_uofac = 0. ! Uoce multiplicative factor (0.:absolute or 1.:relative winds) + rn_vtxmax = 1. ! initial vortex max current [m/s] + rn_uzonal = 1. ! initial zonal current [m/s] + rn_ujetszx = 4000. ! longitudinal jet extension [km] + rn_ujetszy = 400. ! latitudinal jet extension [km] + nn_botcase = 0 ! bottom definition (0:flat, 1:bump) + nn_initcase = 1 ! initial condition case + ! ! -1 : stratif at rest + ! ! 0 : rest + ! ! 1 : zonal current + ! ! 2 : current shear + ! ! 3 : gaussian zonal current + ! ! 4 : geostrophic zonal pulse + ! ! 5 : baroclinic vortex + ln_sshnoise = .FALSE. ! add random noise on initial ssh + rn_lambda = 50. ! gaussian lambda + nn_perio = 1 +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = 'CANAL' ! experience name + nn_it000 = 1 ! first time step + nn_itend = 100 ! last time step + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 99999 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 99999 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_rdt = 1200. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.0 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg" ! newly created domain configuration filename +/ +!!====================================================================== +!! *** 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 = 1 ! frequency of surface boundary condition computation + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) +/ + +!!====================================================================== +!! *** 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 +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! 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 = 2 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 2 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 4 ! =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 = .true. ! 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 = .true. ! 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 = .true. ! 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 = 31 ! 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) +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! 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 = .true. ! 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_een = .false. ! energy & enstrophy scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .true. ! energy conserving scheme (een using e3t) + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. + ln_dynspg_ts = .true. ! 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: + nn_baro = 24 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 + ! ! Coefficient + nn_ahm_ijk_t = 31 ! 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) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 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 = 30.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] +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ + +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .true. ! (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) +/ +!!====================================================================== +!! *** 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") +!----------------------------------------------------------------------- +!! jpni = 8 ! jpni number of processors following i (set automatically if < 1) +!! jpnj = 1 ! jpnj number of processors following j (set automatically if < 1) +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_timing = .true. ! timing by routine write out in timing.output file +!! ln_diacfl = .true. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ +&namzdf_mldzint +nn_mld_diag=2, +sn_mld1=1,10.0,0.2,0.1, +sn_mld2=1,10.0,-0.2,0, +/ diff --git a/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/CANAL/MY_SRC/diawri.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/diawri.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d256f2793fbb1d9a2d34e055db7f7c3863ab8e75 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/diawri.F90 @@ -0,0 +1,1008 @@ +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 ! + +#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: diawri.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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):: ze3 ! - - + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: bu, bv ! volume of u- and v-boxes + REAL(wp), DIMENSION(jpi,jpj,jpk) :: r1_bt ! inverse of t-box volume + !!---------------------------------------------------------------------- + ! + 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", tsn(:,:,:,jp_tem) ) ! 3D temperature + CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature + IF ( iom_use("sbt") ) 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", z2d ) ! bottom temperature + ENDIF + + CALL iom_put( "soce", tsn(:,:,:,jp_sal) ) ! 3D salinity + CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity + IF ( iom_use("sbs") ) 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", z2d ) ! bottom salinity + ENDIF + + 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 + + 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 + + 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 + + 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("socegrad") .OR. iom_use("socegrad2") ) THEN + z3d(:,:,jpk) = 0. + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 ! sal gradient + DO ji = fs_2, fs_jpim1 ! vector opt. + zztmp = tsn(ji,jj,jk,jp_sal) + zztmpx = ( tsn(ji+1,jj,jk,jp_sal) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,jk,jp_sal) ) * r1_e1u(ji-1,jj) + zztmpy = ( tsn(ji,jj+1,jk,jp_sal) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,jk,jp_sal) ) * r1_e2v(ji,jj-1) + z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) + CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient + z3d(:,:,:) = SQRT( z3d(:,:,:) ) + CALL iom_put( "socegrad" , z3d ) ! module of sal gradient + ENDIF + + IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) 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", z2d ) ! square of module of sst gradient + z2d(:,:) = SQRT( z2d(:,:) ) + CALL iom_put( "sstgrad" , 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("salt2c") ) 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) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) + END DO + END DO + END DO + CALL iom_put( "salt2c", rau0 * z2d ) ! vertically integrated squared salt content (PSU*kg/m2) + ENDIF + ! + IF ( iom_use("eken") .OR. iom_use("eken_int") ) THEN + z3d(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zztmpx = 0.5 * ( un(ji-1,jj ,jk) + un(ji,jj,jk) ) + zztmpy = 0.5 * ( vn(ji ,jj-1,jk) + vn(ji,jj,jk) ) + z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) + CALL iom_put( "eken", z3d ) ! kinetic energy + + 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) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) + END DO + END DO + END DO + CALL iom_put( "eken_int", z2d ) ! vertically integrated kinetic energy + ENDIF + ! + CALL iom_put( "hdiv", hdivn ) ! Horizontal divergence + + IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN + + z3d(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vn(ji+1,jj ,jk) - e2v(ji,jj) * vn(ji,jj,jk) & + & - e1u(ji ,jj+1) * un(ji ,jj+1,jk) + e1u(ji,jj) * un(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) + CALL iom_put( "relvor", z3d ) ! relative vorticity + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) + END DO + END DO + END DO + CALL iom_put( "absvor", z3d ) ! absolute vorticity + + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ze3 = ( 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( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 + ELSE ; ze3 = 0._wp + ENDIF + z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) + CALL iom_put( "potvor", z3d ) ! potential vorticity + + ENDIF + + ! + 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") ) 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", rau0 * z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint") ) 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", 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 + !!---------------------------------------------------------------------- + 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 ) + ! + 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 + + CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current + 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 + CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity + 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/V4.0/nemo_sources/tests/CANAL/MY_SRC/domvvl.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/domvvl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dab39b940c14cfcde023a73a6539ec171c2b7494 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/domvvl.F90 @@ -0,0 +1,1053 @@ +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: domvvl.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 + ! + ! usr_def_istate called here only to get sshb, that is needed to initialize e3t_b and e3t_n + CALL usr_def_istate( gdept_0, tmask, tsb, ub, vb, sshb ) + ! usr_def_istate will be called again in istate_init to initialize ts(bn), ssh(bn), u(bn) and v(bn) + ! + DO jk=1,jpk + e3t_b(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshb(:,:) ) & + & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & + & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) ! make sure e3t_b != 0 on land points + END DO + e3t_n(:,:,:) = e3t_b(:,:,:) + sshn(:,:) = sshb(:,:) ! needed later for gde3w +!!$ 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/V4.0/nemo_sources/tests/CANAL/MY_SRC/stpctl.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/stpctl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..85cd82378a41c7c3ae67ec9151a8a084c4be58d3 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/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: stpctl.F90 13137 2020-06-22 06:29:57Z smasson $ + !! 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(3) = MAXVAL( -tsn(:,:,:,jp_sal) , mask = llmsk ) ! minus salinity max + zmax(4) = MAXVAL( tsn(:,:,:,jp_sal) , mask = llmsk ) ! salinity max + IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file + zmax(5) = MAXVAL( -tsn(:,:,:,jp_tem) , mask = llmsk ) ! minus temperature max + zmax(6) = MAXVAL( tsn(:,:,:,jp_tem) , mask = llmsk ) ! temperature max + IF( ln_zad_Aimp ) THEN + zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! 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(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! 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(:) = MINLOC( tsn(:,:,:,jp_sal), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) + is2(:) = MAXLOC( tsn(:,:,:,jp_sal), mask = tmask(:,:,:) == 1._wp ) + (/ 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/V4.0/nemo_sources/tests/CANAL/MY_SRC/trazdf.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/trazdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..271f0c4d88efde8b185c706adda5b58d5d1b2cd5 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/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: trazdf.F90 10572 2019-01-24 15:37:13Z smasson $ + !! 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/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2653cc4386ab7f4b8d2bb8daa29e04ab7b1c7ebc --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,141 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === CANAL configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-11 (J. Chanut) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for CANAL configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam, ONLY: rn_dx, rn_dy, rn_0xratio, rn_0yratio, rn_ppgphi0, nn_fcase + ! and reference latitude + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! CANAL configuration : beta-plance with uniform grid spacing (rn_dx) + !! + !! ** 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) :: zphi0, zlam0, zbeta, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : CANAL configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Beta-plane with regular grid-spacing' + IF(lwp) WRITE(numout,*) ' given by rn_dx and rn_dy' + ! + ! + ! Position coordinates (in kilometers) + ! ========== + zlam0 = -REAL(NINT(jpiglo*rn_0xratio)-1, wp) * rn_dx + zphi0 = -REAL(NINT(jpjglo*rn_0yratio)-1, wp) * rn_dy + +#if defined key_agrif + ! ! let lower left longitude and latitude from parent + IF (.NOT.Agrif_root()) THEN + zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*Agrif_irhox()*rn_dx & + &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx-(0.5_wp+nbghostcells)*rn_dx + zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*Agrif_irhoy()*rn_dy & + &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy-(0.5_wp+nbghostcells)*rn_dy + ENDIF +#endif + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 ) + zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp + + plamt(ji,jj) = zlam0 + rn_dx * zti + plamu(ji,jj) = zlam0 + rn_dx * zui + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + + pphit(ji,jj) = zphi0 + rn_dy * ztj + pphiv(ji,jj) = zphi0 + rn_dy * zvj + pphiu(ji,jj) = pphit(ji,jj) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! Horizontal scale factors (in meters) + ! ====== + pe1t(:,:) = rn_dx * 1.e+3 ; pe2t(:,:) = rn_dy * 1.e+3 + pe1u(:,:) = rn_dx * 1.e+3 ; pe2u(:,:) = rn_dy * 1.e+3 + pe1v(:,:) = rn_dx * 1.e+3 ; pe2v(:,:) = rn_dy * 1.e+3 + pe1f(:,:) = rn_dx * 1.e+3 ; pe2f(:,:) = rn_dy * 1.e+3 + + ! ! NO reduction of grid size in some straits + ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_hgr 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 Coriolis parameter afterward + ! + SELECT CASE(nn_fcase) + CASE(0) + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + pff_t(:,:) = zf0 + CASE(1) + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + zbeta * pphif(:,:) * 1.e+3 + pff_t(:,:) = zf0 + zbeta * pphit(:,:) * 1.e+3 + CASE(2) + pff_f(:,:) = 2._wp * omega * SIN( rad * ( rn_ppgphi0 + pphif(:,:)/110. ) ) + pff_t(:,:) = 2._wp * omega * SIN( rad * ( rn_ppgphi0 + pphit(:,:)/110. ) ) + END SELECT + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c8c9e9a8f6aec36ef82fb76d83fdf8c7c5a0a8ff --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,322 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === CANAL configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-11 (J. Chanut) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE dom_oce + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + ! + USE usrdef_nam + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here CANAL configuration + !! + !! ** Method : Set a gaussian anomaly of pressure and associated + !! geostrophic velocities + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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 :: ji, jj, jk, jl ! dummy loop indices + REAL(wp) :: zx, zy, zP0, zumax, zlambda, zr_lambda2, zn2, zf0, zH, zrho1, za, zf, zdzF + REAL(wp) :: zpsurf, zdyPs, zdxPs + REAL(wp) :: zdt, zdu, zdv + REAL(wp) :: zjetx, zjety, zbeta + REAL(wp), DIMENSION(jpi,jpj) :: zrandom + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : CANAL configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ! + zjetx = ABS(rn_ujetszx)/2. + zjety = ABS(rn_ujetszy)/2. + ! + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + ! + SELECT CASE(nn_initcase) + + CASE(-1) ! stratif at rest + + ! sea level: + pssh(:,:) = 0. + ! temperature: + pts(:,:,1,jp_tem) = 25. !!30._wp + pts(:,:,2:jpk,jp_tem) = 22. !!24._wp + ! salinity: + pts(:,:,:,jp_sal) = 35._wp + ! velocities: + pu(:,:,:) = 0. + pv(:,:,:) = 0. + + CASE(0) ! rest + + ! sea level: + pssh(:,:) = 0. + ! temperature: + pts(:,:,:,jp_tem) = 10._wp + ! salinity: + pts(:,:,:,jp_sal) = 35._wp + ! velocities: + pu(:,:,:) = 0. + pv(:,:,:) = 0. + + CASE(1) ! geostrophic zonal jet from -zjety to +zjety + + ! sea level: + SELECT CASE( nn_fcase ) + CASE(0) ! f = f0 + ! sea level: ssh = - fuy / g + WHERE( ABS(gphit) <= zjety ) + pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav + ELSEWHERE + pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav + END WHERE + CASE(1) ! f = f0 + beta*y + ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + WHERE( ABS(gphit) <= zjety ) + pssh(:,:) = - rn_uzonal / grav * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) + ELSEWHERE + pssh(:,:) = - rn_uzonal / grav * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 & + & + 0.5 * zbeta * zjety * zjety * 1.e6 ) + END WHERE + END SELECT + ! temperature: + pts(:,:,:,jp_tem) = 10._wp + ! salinity: + pts(:,:,jpk,jp_sal) = 0. + DO jk=1, jpkm1 + WHERE( ABS(gphit) <= zjety ) +!!$ WHERE( ABS(gphit) <= zjety*0.5 .AND. ABS(glamt) <= zjety*0.5 ) ! for a square of salt + pts(:,:,jk,jp_sal) = 35. + ELSEWHERE + pts(:,:,jk,jp_sal) = 30. + END WHERE + END DO + ! velocities: + pu(:,:,:) = 0. + DO jk=1, jpkm1 + WHERE( ABS(gphit) <= zjety ) pu(:,:,jk) = rn_uzonal + END DO + pv(:,:,:) = 0. + ! + CASE(2) ! geostrophic zonal current shear + + ! sea level: + SELECT CASE( nn_fcase ) + CASE(0) ! f = f0 + ! sea level: ssh = - fuy / g + WHERE( ABS(gphit) <= zjety ) + pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav + ELSEWHERE + pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav + END WHERE + CASE(1) ! f = f0 + beta*y + ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + WHERE( ABS(gphit) <= zjety ) + pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & + & * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) + ELSEWHERE + pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & + & * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) + END WHERE + END SELECT + ! temperature: + pts(:,:,:,jp_tem) = 10._wp + ! salinity: + pts(:,:,:,jp_sal) = 30. + DO jk=1, jpkm1 + WHERE( ABS(gphiv) <= zjety ) pts(:,:,jk,jp_sal) = 30. + SIGN(1.,gphiv(:,:)) + END DO + ! velocities: + pu(:,:,:) = 0. + DO jk=1, jpkm1 + WHERE( ABS(gphiv) <= zjety ) pu(:,:,jk) = SIGN(rn_uzonal,gphit(:,:))*SIGN(1.,rn_uzonal) + WHERE( ABS(gphiv) == 0. ) pu(:,:,jk) = 0. + END DO + pv(:,:,:) = 0. + ! + CASE(3) ! gaussian zonal currant + + ! zonal current + DO jk=1, jpkm1 + ! gphit and lambda are both in km + pu(:,:,jk) = rn_uzonal * EXP( - 0.5 * gphit(:,:)**2 / rn_lambda**2 ) + END DO + + ! sea level: + pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1) + DO jl=1, jpnj + DO jj=nldj, nlej + DO ji=nldi, nlei + pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) + END DO + END DO + CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. ) + END DO + + ! temperature: + pts(:,:,:,jp_tem) = 10._wp + ! salinity: + DO jk=1, jpkm1 + pts(:,:,jk,jp_sal) = pssh(:,:) + END DO + ! velocities: + pv(:,:,:) = 0. + ! + CASE(4) ! geostrophic zonal pulse + + DO jj=1, jpj + DO ji=1, jpi + IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN + zdu = rn_uzonal + ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN + zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) + ELSE + zdu = 0. + END IF + IF ( ABS(gphit(ji,jj)) <= zjety ) THEN + pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav + pu(ji,jj,:) = zdu + pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. + ELSE + pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav + pu(ji,jj,:) = 0. + pts(ji,jj,:,jp_sal) = 1. + END IF + END DO + END DO + + ! temperature: + pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) + pv(:,:,:) = 0. + + + CASE(5) ! vortex + ! + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic + zlambda = SQRT(2._wp)*rn_lambda*1.e3 ! Horizontal scale in meters + zn2 = 3.e-3**2 + zH = 0.5_wp * 5000._wp + ! + zr_lambda2 = 1._wp / zlambda**2 + zP0 = rau0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) + ! + DO jj=1, jpj + DO ji=1, jpi + zx = glamt(ji,jj) * 1.e3 + zy = gphit(ji,jj) * 1.e3 + ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) + zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal * zy + ! Sea level: + pssh(ji,jj) = 0. + DO jl=1,5 + zdt = pssh(ji,jj) + zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z) + zrho1 = rau0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) + pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g) + END DO + ! temperature: + DO jk=1,jpk + zdt = pdept(ji,jj,jk) + zrho1 = rau0 * (1._wp + zn2*zdt/grav) + IF (zdt < zH) THEN + zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH)) ! F'(z) + zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) + ENDIF + ! pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) + pts(ji,jj,jk,jp_tem) = (10._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) + END DO + END DO + END DO + ! + ! salinity: + pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) + ! + ! velocities: + za = 2._wp * zP0 / zlambda**2 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zx = glamu(ji,jj) * 1.e3 + zy = gphiu(ji,jj) * 1.e3 + DO jk=1, jpk + zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk)) + IF (zdu < zH) THEN + zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) + zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal + pu(ji,jj,jk) = - zf / ( rau0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) + ELSE + pu(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END DO + ! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zx = glamv(ji,jj) * 1.e3 + zy = gphiv(ji,jj) * 1.e3 + DO jk=1, jpk + zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk)) + IF (zdv < zH) THEN + zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) + zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2) + pv(ji,jj,jk) = zf / ( rau0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) + ELSE + pv(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END DO + ! + CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) + + END SELECT + + IF (ln_sshnoise) THEN + CALL RANDOM_SEED() + CALL RANDOM_NUMBER(zrandom) + pssh(:,:) = pssh(:,:) + ( 0.1 * zrandom(:,:) - 0.05 ) + END IF + + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..19b0d6ffec1d33409e1f17e38fcbb4b95d8f20ba --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,162 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === EW_CANAL configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-10 (J. Chanut) 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp) :: rn_domszx = 1800. ! x horizontal size [km] + REAL(wp) :: rn_domszy = 1800. ! y horizontal size [km] + REAL(wp), PUBLIC :: rn_domszz = 5000. ! z horizontal size [m] + REAL(wp), PUBLIC :: rn_dx = 30. ! x horizontal resolution [km] + REAL(wp), PUBLIC :: rn_dy = 30. ! y horizontal resolution [km] + REAL(wp), PUBLIC :: rn_dz = 500. ! vertical resolution [m] + REAL(wp), PUBLIC :: rn_0xratio = 0.5 ! x domain ratio of the 0 + REAL(wp), PUBLIC :: rn_0yratio = 0.5 ! x domain ratio of the 0 + INTEGER , PUBLIC :: nn_fcase = 1 ! F computation (0:f0, 1:Beta, 2:real) + REAL(wp), PUBLIC :: rn_ppgphi0 = 38.5 ! reference latitude for beta-plane + REAL(wp), PUBLIC :: rn_u10 = 0. ! 10m wind speed [m/s] + REAL(wp), PUBLIC :: rn_windszx = 150. ! longitudinal wind extension [km] + REAL(wp), PUBLIC :: rn_windszy = 150. ! latitudinal wind extension [km] + REAL(wp), PUBLIC :: rn_uofac = 0. ! Uoce multiplicative factor (0.:absolute or 1.:relative winds) + REAL(wp), PUBLIC :: rn_vtxmax = 0. ! initial canal max current [m/s] + REAL(wp), PUBLIC :: rn_uzonal = 0. ! initial zonal current [m/s] + REAL(wp), PUBLIC :: rn_ujetszx = 150. ! longitudinal jet extension [km] + REAL(wp), PUBLIC :: rn_ujetszy = 150. ! latitudinal jet extension [km] + INTEGER , PUBLIC :: nn_botcase = 0 ! bottom definition (0:flat, 1:bump) + INTEGER , PUBLIC :: nn_initcase= 0 ! initial condition case (0=rest, 1=zonal current, 2=canal) + LOGICAL , PUBLIC :: ln_sshnoise=.false. ! add random noise on initial ssh + REAL(wp), PUBLIC :: rn_lambda = 50. ! gaussian lambda + INTEGER , PUBLIC :: nn_perio = 0 ! periodicity of the channel (0=closed, 1=E-W) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 13284 2020-07-09 15:12:23Z smasson $ + !! 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 EW_CANAL 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 + REAL(wp):: zh ! Local scalars + !! + NAMELIST/namusr_def/ rn_domszx, rn_domszy, rn_domszz, rn_dx, rn_dy, rn_dz, rn_0xratio, rn_0yratio & + & , nn_fcase, rn_ppgphi0, rn_u10, rn_windszx, rn_windszy & !!, rn_uofac & + & , rn_vtxmax, rn_uzonal, rn_ujetszx, rn_ujetszy & + & , nn_botcase, nn_initcase, ln_sshnoise, rn_lambda, nn_perio + !!---------------------------------------------------------------------- + ! + 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 ) + ! +#if defined key_agrif + ! Domain parameters are taken from parent: + IF( .NOT. Agrif_Root() ) THEN + rn_dx = Agrif_Parent(rn_dx)/Agrif_Rhox() + rn_dy = Agrif_Parent(rn_dy)/Agrif_Rhoy() + rn_dz = Agrif_Parent(rn_dz) + rn_ppgphi0 = Agrif_Parent(rn_ppgphi0) + ENDIF + rn_0xratio = 0.5 + rn_0yratio = 0.5 +#endif + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'EW_CANAL' ! name & resolution (not used) + kk_cfg = INT( rn_dx ) + ! + ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m + kpi = NINT( rn_domszx / rn_dx ) + 1 + kpj = NINT( rn_domszy / rn_dy ) + 3 + kpk = NINT( rn_domszz / rn_dz ) + 1 +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + kpi = nbcellsx + 2 + 2*nbghostcells + kpj = nbcellsy + 2 + 2*nbghostcells + ENDIF +#endif + ! + zh = (kpk-1)*rn_dz + ! ! Set the lateral boundary condition of the global domain + kperio = 1 ! EW_CANAL configuration : closed basin + ! ! 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 : EW_CANAL test case' + WRITE(numout,*) ' horizontal domain size-x rn_domszx = ', rn_domszx, ' km' + WRITE(numout,*) ' horizontal domain size-y rn_domszy = ', rn_domszy, ' km' + WRITE(numout,*) ' vertical domain size-z rn_domszz = ', rn_domszz, ' m' + WRITE(numout,*) ' horizontal x-resolution rn_dx = ', rn_dx, ' km' + WRITE(numout,*) ' horizontal y-resolution rn_dy = ', rn_dy, ' km' + WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' m' + WRITE(numout,*) ' x-domain ratio of the 0 rn_0xratio = ', rn_0xratio + WRITE(numout,*) ' y-domain ratio of the 0 rn_0yratio = ', rn_0yratio + WRITE(numout,*) ' H [m] : ', zh + WRITE(numout,*) ' F computation nn_fcase = ', nn_fcase + WRITE(numout,*) ' Reference latitude rn_ppgphi0 = ', rn_ppgphi0 + WRITE(numout,*) ' 10m wind speed rn_u10 = ', rn_u10, ' m/s' + WRITE(numout,*) ' wind latitudinal extension rn_windszy = ', rn_windszy, ' km' + WRITE(numout,*) ' wind longitudinal extension rn_windszx = ', rn_windszx, ' km' + WRITE(numout,*) ' Uoce multiplicative factor rn_uofac = ', rn_uofac + WRITE(numout,*) ' initial Canal max current rn_vtxmax = ', rn_vtxmax, ' m/s' + WRITE(numout,*) ' initial zonal current rn_uzonal = ', rn_uzonal, ' m/s' + WRITE(numout,*) ' Jet latitudinal extension rn_ujetszy = ', rn_ujetszy, ' km' + WRITE(numout,*) ' Jet longitudinal extension rn_ujetszx = ', rn_ujetszx, ' km' + WRITE(numout,*) ' bottom definition (0:flat) nn_botcase = ', nn_botcase + WRITE(numout,*) ' initial condition case nn_initcase= ', nn_initcase + WRITE(numout,*) ' (0:rest, 1:zonal current, 10:shear)' + WRITE(numout,*) ' add random noise on initial ssh ln_sshnoise= ', ln_sshnoise + WRITE(numout,*) ' Gaussian lambda parameter rn_lambda = ', rn_lambda + WRITE(numout,*) ' Periodicity of the basin nn_perio = ', nn_perio + ENDIF + ! ! Set the lateral boundary condition of the global domain + kperio = nn_perio ! EW_CANAL configuration : closed basin + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..82dd1770762dfb999f786f3c436b7c09f675aa01 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,117 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === CANAL configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2017-11 (J.Chanut) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in OVERFLOW case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE phycst ! physical constants + USE usrdef_nam, ONLY : rn_u10, rn_uofac, rn_windszy, rn_windszx + ! + 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 CANAL case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zrhoair = 1.22 ! approximate air density [Kg/m3] + REAL(wp) :: zcd = 1.13e-3 ! approximate drag coefficient + REAL(wp) :: zrhocd ! Rho * Cd + REAL(wp), DIMENSION(jpi,jpj) :: zwndrel ! relative wind + !!--------------------------------------------------------------------- + ! + zrhocd = zrhoair * zcd + + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : EW_CANAL case: surface forcing' + IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ 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 + ! + ENDIF + + IF( rn_u10 /= 0. .AND. rn_windszy > 0. ) THEN + IF( nyear == 1 .AND. nmonth == 1 .AND. nday <= 10 ) THEN + WHERE( ABS(gphit) <= rn_windszy/2. .AND. ABS(glamt) <= rn_windszx/2. ) utau(:,:) = zrhocd * rn_u10 * rn_u10 + ELSE + utau(:,:) = 0. + ENDIF + ENDIF + + IF( rn_uofac /= 0. ) THEN + + WHERE( ABS(gphit) <= rn_windszy/2. ) + zwndrel(:,:) = rn_u10 - rn_uofac * un(:,:,1) + ELSEWHERE + zwndrel(:,:) = - rn_uofac * un(:,:,1) + END WHERE + utau(:,:) = zrhocd * zwndrel(:,:) * zwndrel(:,:) + + zwndrel(:,:) = - rn_uofac * vn(:,:,1) + vtau(:,:) = zrhocd * zwndrel(:,:) * zwndrel(:,:) + + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6842867e8028567610d8740fa311d006370765c1 --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,250 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === CANAL configuration === + !! + !! User defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2017-11 (J. Chanut) 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 phycst ! physical constants + USE usrdef_nam, ONLY: rn_domszz, nn_botcase + 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: usrdef_zgr.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: 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 : CANAL configuration (z-coordinate closed flat box ocean)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ld_zco = .TRUE. ! CANAL 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) :: zd ! local scalar + !!---------------------------------------------------------------------- + ! + zd = rn_domszz/FLOAT(jpkm1) + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates ' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' CANAL case : uniform vertical grid :' + WRITE(numout,*) ' with thickness = ', zd + ENDIF + + ! + ! 1D Reference z-coordinate (using Madec & Imbard 1996 function) + ! ------------------------- + ! + pdepw_1d(1) = 0._wp + pdept_1d(1) = 0.5_wp * zd + ! + DO jk = 2, jpk ! depth at T and W-points + pdepw_1d(jk) = pdepw_1d(jk-1) + zd + pdept_1d(jk) = pdept_1d(jk-1) + zd + 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 : CANAL 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 + REAL(wp) :: zmaxlam, zscl + !!---------------------------------------------------------------------- + ! + 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,*) ' CANAL case : closed flat box ocean without ocean cavities' + ! + SELECT CASE(nn_botcase) + CASE(0) + z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom + CASE(1) + zmaxlam = MAXVAL(glamt) + CALL mpp_max( 'usrdef_zgr', zmaxlam ) ! max over the global domain + zscl = 0.5 * rpi / zmaxlam + z2d(:,:) = COS( glamt(:,:) * zscl ) + z2d(:,:) = REAL(jpkm1 - NINT( 0.5 * REAL(jpkm1,wp) * z2d(:,:) ), wp) + END SELECT + ! + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed) + ! + k_bot(:,:) = INT( 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/V4.0/nemo_sources/tests/CANAL/cpp_CANAL.fcm b/V4.0/nemo_sources/tests/CANAL/cpp_CANAL.fcm new file mode 100644 index 0000000000000000000000000000000000000000..2819bfcbeb5f83c2813e44fbee32e54d3318bfdc --- /dev/null +++ b/V4.0/nemo_sources/tests/CANAL/cpp_CANAL.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_iomput key_mpp_mpi diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..cca98038109faed2c5314ba7c3bc81cda347cefe --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/context_nemo.xml @@ -0,0 +1,40 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-ice.xml new file mode 120000 index 0000000000000000000000000000000000000000..5990a8ed642fc2e6c2e2e665cff2a9a8b94f3c56 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-ice.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-ice.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..712929ba9dafed4a8e0465203df44be460936813 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml @@ -0,0 +1,68 @@ +<?xml version="1.0"?> + <!-- $id$ --> + + <!-- +============================================================================================================ += output files definition = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."> <!-- 1 day files --> + + <file id="file1" name_suffix="_icemod" description="ice variables" enabled=".true." > + + <!-- ice mask --> + <field field_ref="icemask" name="simsk" /> + + <!-- general --> + <field field_ref="snwvolu" name="snvolu" /> + <field field_ref="icethic" name="sithic" /> + <field field_ref="icethic" name="sithic_max" operation="maximum" /> + <field field_ref="icethic" name="sithic_min" operation="minimum" /> + <field field_ref="iceneg_pres" name="sineg_pres" /> + <field field_ref="iceneg_volu" name="sineg_volu" /> + <field field_ref="fasticepres" name="fasticepres" /> + <field field_ref="icevolu" name="sivolu" /> + <field field_ref="iceconc" name="siconc" /> + <field field_ref="icesalt" name="sisali" /> + <field field_ref="iceapnd" name="siapnd" /> + <field field_ref="icevpnd" name="sivpnd" /> + <field field_ref="sst_m" name="sst_m" /> + <field field_ref="sss_m" name="sss_m" /> + + <!-- momentum --> + <field field_ref="uice" name="sivelu" /> + <field field_ref="vice" name="sivelv" /> + <field field_ref="icevel" name="sivelo" /> + + <!-- rheology --> + <field field_ref="icediv" name="sidive" /> + + <!-- categories --> + <field field_ref="icemask_cat" name="simskcat"/> + <field field_ref="snwthic_cat" name="snthicat"/> + <field field_ref="iceconc_cat" name="siconcat"/> + <field field_ref="icethic_cat" name="sithicat"/> + + </file> + + </file_group> + + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..a08549161444b2e17ee7ad77ecbebcd3a7b27131 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,33 @@ +<?xml version="1.0"?> + +<!-- +============================================================================================================ += output files definition = += Define your own filesfor ocean dynamics context = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> + + + + diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..47d022024e7a915a6c72016b7229132afe6b868c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/iodef.xml @@ -0,0 +1,30 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <!-- + <variable id="optimal_buffer_size" type="string">memory</variable> + <variable id="buffer_size_factor" type="double">1.0</variable> + --> + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/make_initice.py b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/make_initice.py new file mode 100755 index 0000000000000000000000000000000000000000..474a4c27a6671e3d4bd4d167b27c7fa184450cfe --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/make_initice.py @@ -0,0 +1,120 @@ +#!/usr/bin/python + +import os,sys +from netCDF4 import Dataset as netcdf +import numpy as np +import matplotlib.pyplot as plt +from math import exp +from math import ceil + +resname='' + +# input file +###fcoord='coordinates_'+str(resname)+'.nc' +#fcoord='mesh_mask_'+str(resname)+'.nc' +fcoord='mesh_mask.nc' + +# output file +#fflx='initice_'+str(resname)+'.nc' +fflx='initice_60pts.nc' + +print ' creating init ice file ' +fflx + +# Reading coordinates file +nccoord=netcdf(fcoord,'r') +nav_lon=nccoord.variables['nav_lon'] +nav_lat=nccoord.variables['nav_lat'] +time_counter=1 +LON1= nav_lon.shape[1] +LAT1= nav_lon.shape[0] +print 'nav_lon.shape[1]' ,nav_lon.shape[1] +print 'LON1 ', LON1 +print 'LAT1 ', LAT1 + +# Creating INITICE netcdf file +nc=netcdf(fflx,'w') +nc.createDimension('y',LAT1) +nc.createDimension('x',LON1) +nc.createDimension('time_counter',None) # Setting dimension size to 0 or None makes it unlimited. + +cdflon=nc.createVariable('nav_lon','f',('y','x')) +cdflat=nc.createVariable('nav_lat','f',('y','x')) +cdftimecounter=nc.createVariable('time_counter','f',('time_counter')) + +# ati : Fraction of open waters in sea ice - units % +# hti : Sea ice thickness - units m +# hts : Snow thickness - units m +# smi : +# tmi : Sea ice internal temperature - units K +# tsu : Sea ice surface temperature - units K +# +# Take constant values from namelist &namiceini of NEMO +rn_hti_ini=2.0 +rn_hts_ini=0.2 # initial real snow thickness (m) +rn_ati_ini=0.9 # initial ice concentration (-) +rn_smi_ini=6.3 # initial ice salinity (g/kg) +rn_tmi_ini=270. # initial ice/snw temperature (K) +rn_tsu_ini=270. # initial sea ice temperature (K) +# +cdfati=nc.createVariable('ati','f',('time_counter','y','x')) +cdfati.units='Percentage' +cdfati.long_name='Sea ice concentration' +cdfhti=nc.createVariable('hti','f',('time_counter','y','x')) +cdfhti.long_name='Sea ice thickness' +cdfhti.units='m' +cdfhts=nc.createVariable('hts','f',('time_counter','y','x')) +cdfhts.long_name='Snow thickness' +cdfhts.units='m' +cdfsmi=nc.createVariable('smi','f',('time_counter','y','x')) +cdfsmi.long_name='Sea ice salinity' +cdfsmi.units='pss' +cdftmi=nc.createVariable('tmi','f',('time_counter','y','x')) +cdftmi.long_name='Sea ice internal temperature' +cdftmi.units='Kelvin' +cdftsu=nc.createVariable('tsu','f',('time_counter','y','x')) +cdftsu.long_name='Sea ice surface temperature' +cdftsu.units='Kelvin' + +cdflon[:,:]=nav_lon[:,:] +cdflat[:,:]=nav_lat[:,:] +cdftimecounter[0]=1 + +# Fill fields +#print 'cdfati[:,1]', cdfati[:,1] -> 32 values + +# Add a gaussian for sea ice thickness here +cdfhti[:,:,:]=0. +cdfhts[:,:,:]=0. +cdfati[:,:,:]=0. +cdfsmi[:,:,:]=0. +cdftmi[:,:,:]=rn_tmi_ini +cdftsu[:,:,:]=rn_tsu_ini + +# -------------------------------------- +# for basin=99x99km with dx=1km ; dy=1km + +# --- Lipscomb 2004 experiment --- +cdfhti[:,:,:]=1. +# thickness +for y in np.arange(0,LAT1,1) : + for x in np.arange(0,LON1,1) : + if (x >= 15. and x <= 43.): + cdfhti[:,y,x] = 0.2 +# elif (x < 10. or x > 50.): +# cdfhti[:,y,x] = 0. + +cdfati[:,:,:]=0.001 +# concentration +for y in np.arange(0,LAT1,1) : + for x in np.arange(0,LON1,1) : + if (x >= 10. and x <= 29.): + cdfati[:,y,x] = 0.9 * (x - 9.) / 20. + elif (x > 29. and x <= 48.): + cdfati[:,y,x] = 0.9 + +# --------------------------------------- + +nc.close() +nccoord.close() + +#sys.exit() diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..25e2ab0431e816a612a6b8bac182e14fc894db60 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_ADV1D 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_ADV1D user defined namelist +!----------------------------------------------------------------------- + rn_dx = 4. ! horizontal resolution in meters + rn_dy = 4. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_ADV1D" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 40 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 2. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_ADV1D_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts new file mode 100644 index 0000000000000000000000000000000000000000..dcb44d021cb80ca6132337f5c78cc37694af09c8 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_ADV1D 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_ADV1D user defined namelist +!----------------------------------------------------------------------- + rn_dx = 4. ! horizontal resolution in meters + rn_dy = 4. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_ADV1D" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 80 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 2. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_ADV1D_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts new file mode 100644 index 0000000000000000000000000000000000000000..8a308213a7059fc202f89f757ba77fd9004606d4 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_ADV1D 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_ADV1D user defined namelist +!----------------------------------------------------------------------- + rn_dx = 4. ! horizontal resolution in meters + rn_dy = 4. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_ADV1D" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 160 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 2. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_ADV1D_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts new file mode 100644 index 0000000000000000000000000000000000000000..856ad8ae5c0062c14f657627cf2caa8555a8049f --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_ADV1D 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_ADV1D user defined namelist +!----------------------------------------------------------------------- + rn_dx = 4. ! horizontal resolution in meters + rn_dy = 4. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_ADV1D" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 40 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 2. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_ADV1D_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..2d37339237e6d8f88a01c150195206612bc5b121 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg @@ -0,0 +1,107 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ + jpl = 1 ! number of ice categories + nlay_i = 2 ! number of ice layers + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) + ln_dynADV1D = .true. ! dyn.: only advection 1D (Schar & Smolarkiewicz 1996 test case) + ln_dynADV2D = .false. ! dyn.: only advection 2D w prescribed vel.(rn_uvice + advection) + rn_uice = 1. ! prescribed ice u-velocity + rn_vice = 0. ! prescribed ice v-velocity +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice_60pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice_60pts' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice_60pts' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice_60pts' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice_60pts' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice_60pts' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts new file mode 100644 index 0000000000000000000000000000000000000000..2a6775f5e729da8b89f4e56b837ddfc5e222eceb --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts @@ -0,0 +1,107 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface forcing (namforcing) +!! 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 = 1 ! number of ice categories + nlay_i = 2 ! number of ice layers + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) + ln_dynADV1D = .true. ! dyn.: only advection 1D (Schar & Smolarkiewicz 1996 test case) + ln_dynADV2D = .false. ! dyn.: only advection 2D w prescribed vel.(rn_uvice + advection) + rn_uice = 1. ! prescribed ice u-velocity + rn_vice = 0. ! prescribed ice v-velocity +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namforcing ! Ice surface forcing +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice_120pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice_120pts' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice_120pts' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice_120pts' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice_120pts' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice_120pts' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts new file mode 100644 index 0000000000000000000000000000000000000000..9aa7dd1f8dde1e6e24eb40e1f2bd57f2e27e365b --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts @@ -0,0 +1,107 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface forcing (namforcing) +!! 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 = 1 ! number of ice categories + nlay_i = 2 ! number of ice layers + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) + ln_dynADV1D = .true. ! dyn.: only advection 1D (Schar & Smolarkiewicz 1996 test case) + ln_dynADV2D = .false. ! dyn.: only advection 2D w prescribed vel.(rn_uvice + advection) + rn_uice = 1. ! prescribed ice u-velocity + rn_vice = 0. ! prescribed ice v-velocity +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namforcing ! Ice surface forcing +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice_240pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice_240pts' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice_240pts' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice_240pts' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice_240pts' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice_240pts' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts new file mode 100644 index 0000000000000000000000000000000000000000..8208909800492591131aa1bead9e607076acc034 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts @@ -0,0 +1,107 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface forcing (namforcing) +!! 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 = 1 ! number of ice categories + nlay_i = 2 ! number of ice layers + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) + ln_dynADV1D = .true. ! dyn.: only advection 1D (Schar & Smolarkiewicz 1996 test case) + ln_dynADV2D = .false. ! dyn.: only advection 2D w prescribed vel.(rn_uvice + advection) + rn_uice = 1. ! prescribed ice u-velocity + rn_vice = 0. ! prescribed ice v-velocity +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namforcing ! Ice surface forcing +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice_60pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice_60pts' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice_60pts' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice_60pts' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice_60pts' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice_60pts' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_ref b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..23b14529cf92c567f7cc1d10b42ff842a5bb3bea --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ice_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d8304487f4d4e622b2790592ae5d52b356ef5fc0 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,125 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === ICE_ADV1D configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for ICE_ADV1D configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam, ONLY: rn_dx, rn_dy, ln_corio, rn_ppgphi0 ! horizontal resolution in meters + ! coriolis and reference latitude + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! ICE_ADV1D configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zphi0, zlam0, zbeta, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : ICE_ADV1D configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' f-plane with regular grid-spacing rn_dx, rn_dy' + + ! ========== + zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx + zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 ) + zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp + + plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti + plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + + pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj + pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj + pphiu(ji,jj) = pphit(ji,jj) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + + ! constant scale factors + pe1t(:,:) = rn_dx + pe2t(:,:) = rn_dy + + pe1u(:,:) = pe1t(:,:) ; pe2u(:,:) = pe2t(:,:) + pe1v(:,:) = pe1t(:,:) ; pe2v(:,:) = pe2t(:,:) + pe1f(:,:) = pe1t(:,:) ; pe2f(:,:) = pe2t(:,:) + + ! ! 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 Coriolis parameter afterward + ! + IF( ln_corio ) THEN + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + zbeta * pphif(:,:) * 1.e+3 + pff_t(:,:) = zf0 + zbeta * pphit(:,:) * 1.e+3 + ELSE + pff_f(:,:) = 0. + pff_t(:,:) = 0. + ENDIF + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5fb35c60ee2c17496d26b3016567f93fcbb416d2 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,106 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === ICE_ADV1D configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dy ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_ppgphi0 ! reference latitude for beta-plane + LOGICAL , PUBLIC :: ln_corio ! set coriolis at 0 (ln_corio=F) or not + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 ICE_ADV1D 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 + REAL(wp):: zlx, zly ! Local scalars + !! + NAMELIST/namusr_def/ rn_dx, rn_dy, ln_corio, rn_ppgphi0 + !!---------------------------------------------------------------------- + ! + 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 = 'ICE_ADV1D' ! name & resolution (not used) + kk_cfg = INT( rn_dx ) + ! + ! Global Domain size: ICE_ADV1D domain is 480 m x 480 m x 10 m + kpi = INT( 480.*0.5 / rn_dx ) -1 + kpj = INT( 480.*0.5 / rn_dy ) -1 + kpk = 1 + ! + zlx = kpi*rn_dx*1.e-3 + zly = kpj*rn_dy*1.e-3 + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! ICE_ADV1D configuration : bi-periodic basin + ! ! 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 : ICE_ADV1D test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' meters' + WRITE(numout,*) ' ICE_ADV1D domain ' + WRITE(numout,*) ' LX [km]: ', zlx + WRITE(numout,*) ' LY [km]: ', zly + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' Coriolis:', ln_corio + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' ICE_ADV1D : closed basin jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4ee7d6f56f1e8f69675a5a3f79aeb2356f5dd372 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,164 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === ICE_ADV1D configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in ICE_ADV1D 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: ice fields + USE phycst ! physical constants + USE ice, ONLY : at_i_b, a_i_b + USE icethd_dh ! for CALL ice_thd_snwblow + ! + 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called by sbcmod.F90 for sbc ocean + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 ICE_ADV1D case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usrdef_sbc_oce : ICE_ADV1D case: NO surface forcing' + ! --- oce variables --- ! + utau(:,:) = 0._wp + vtau(:,:) = 0._wp + taum(:,:) = 0._wp + wndm(:,:) = 0._wp + ! + emp (:,:) = 0._wp + sfx (:,:) = 0._wp + qns (:,:) = 0._wp + qsr (:,:) = 0._wp + ! + utau_b(:,:) = 0._wp + vtau_b(:,:) = 0._wp + emp_b (:,:) = 0._wp + sfx_b (:,:) = 0._wp + qns_b (:,:) = 0._wp + ! + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_tau *** + !! + !! ** Purpose : provide the surface boundary (momentum) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV1D case: no stress forcing' + ! + utau_ice(:,:) = 0._wp + vtau_ice(:,:) = 0._wp + ! + END SUBROUTINE usrdef_sbc_ice_tau + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_flx *** + !! + !! ** Purpose : provide the surface boundary (flux) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + !! + INTEGER :: jl + REAL(wp) :: zfr1, zfr2 ! local variables + REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!--------------------------------------------------------------------- + ! + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV1D case: NO flux forcing' + ! + ! ocean variables (renaming) + emp_oce (:,:) = 0._wp ! uniform value for freshwater budget (E-P) + qsr_oce (:,:) = 0._wp ! uniform value for solar radiation + qns_oce (:,:) = 0._wp ! uniform value for non-solar radiation + + ! ice variables + alb_ice (:,:,:) = 0.7_wp ! useless + qsr_ice (:,:,:) = 0._wp ! uniform value for solar radiation + qns_ice (:,:,:) = 0._wp ! uniform value for non-solar radiation + sprecip (:,:) = 0._wp ! uniform value for snow precip + evap_ice(:,:,:) = 0._wp ! uniform value for sublimation + + ! ice fields deduced from above + zsnw(:,:) = 1._wp + !!CALL lim_thd_snwblow( at_i_b, zsnw ) ! snow distribution over ice after wind blowing + emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) + emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) + qevap_ice(:,:,:) = 0._wp + qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + + ! total fluxes + emp_tot (:,:) = emp_ice + emp_oce + qns_tot (:,:) = at_i_b(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot (:,:) = at_i_b(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! + cloud_fra(:,:) = pp_cldf + 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 + + + END SUBROUTINE usrdef_sbc_ice_flx + + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dd82d400d3901baab05a349ad752f9401849e0bd --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,111 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === ICE_ADV1D case === + !! + !! Ocean domain : user defined vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE usrdef_nam ! User defined : namelist variables + ! + 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: usrdef_zgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 :: jk, k_dz ! dummy indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : ICE_ADV1D configuration (slab ocean - advection of ice in one direction)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate ==>>> here ICE_ADV1D : slab ocean always + ! --------------------------- + ld_zco = .TRUE. ! z-full-step coordinate + ld_zps = .FALSE. ! z-partial-step coordinate + ld_sco = .FALSE. ! s-coordinate + ld_isfcav = .FALSE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! + ! + k_dz = 1 + DO jk = 1, jpk + pdepw_1d(jk) = k_dz + pdept_1d(jk) = k_dz + pe3w_1d (jk) = k_dz + pe3t_1d (jk) = k_dz + END DO + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + k_top(:,:) = 1 + ! + ! !== z-coordinate ==! (step-like topography) + ! !* bottom ocean compute from the depth of grid-points + jpkm1 = jpk + k_bot(:,:) = 1 ! here use k_top as a land mask + ! !* horizontally uniform coordinate (reference z-co everywhere) + 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 usr_def_zgr + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/ICE_ADV1D/cpp_ICE_ADV1D.fcm b/V4.0/nemo_sources/tests/ICE_ADV1D/cpp_ICE_ADV1D.fcm new file mode 100644 index 0000000000000000000000000000000000000000..161874503647aa33cf54d816806356c7f4c28aba --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV1D/cpp_ICE_ADV1D.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/README b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/README new file mode 100644 index 0000000000000000000000000000000000000000..f9fae517a00ece26f1d3dcaa831ab5ae2b67f3aa --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/README @@ -0,0 +1,61 @@ +WARNING: For now, the test case ICE_ADV2D only works if the logical "ll_neg" is set to FALSE in the routine icedyn_adv_umx.F90 + (it is still unclear why) +------- +Purpose +------- +This demonstration case can serve different purposes: + +1) The main one: study of the advection of a patch of ice in a bi-periodic channel with a slab ocean (i.e. 1 ocean layer) + ==> set ln_icethd=false in namelist_ice_cfg + +2) Secondary: study of ice thermodynamics in the same basin + ==> set ln_icedyn=false in namelist_ice_cfg + ==> eventually change usrdef_sbc.F90 in MY_SRC to fit your needs + +----------- +Experiments +----------- +Two experiments can be configured: + +a) A simple channel at 3km horizontal resolution (slightly variable => +- 10%) + ==> in MY_SRC/usrdef_hgr.F90, uncomment the part "variable scale factors" and comment part "constant scale factors" + +b) A simple channel at 3km horizontal resolution (constant scale factors) + ==> in MY_SRC/usrdef_hgr.F90, comment the part "variable scale factors" and uncomment part "constant scale factors" + +---------- +How to run +---------- + +a) Compile and run the model once to get a mesh_mask.nc file with the following command: +../../../makenemo -r ICE_ADV2D -n ICE_ADV2D -m X64_ADA -j 4 +mpirun ./nemo -np 1 + +b) Create the initial condition file for sea-ice (initice.nc) by running this python script: +python ./make_INITICE.py + +c) Run the model a second time +mpirun ./nemo -np 4 + +--------------- +What to look at +--------------- +In case of purpose 1, One can test +--- +a) the advection scheme: Ultimate-Macho (ln_adv_UMx=T) versus Prather (ln_adv_Pra=T) + for a square (ice concentration) or a gaussian (ice volume) + with either a constant velocity (ln_dynADV2D=T) + or a constant ice-atm. stress, thus velocity is calculated by rheology (ln_dynRHGADV=T) + with 1 or 5 ice categories (jpl=1 or 5). + (note that ln_dynADV2D=T only works with jpl=1) + +In case of purpose 2, one can test conservation of properties: +--- +b) ice should not change at all if surface fluxes = 0 and SST = freezing temperature + +-------------------------------------- +Interpretation of the results (remarks) +-------------------------------------- +- Prather conserves the max values but also creates side lobes +- UM does not conserve the max but does not create side lobes +- The "unmoving" ice (if any) is due to ice rheology which states that ice mass below a certain thresold (1kg/m2) is considered to move at the ocean velocity (thus 0 m/s) diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..cca98038109faed2c5314ba7c3bc81cda347cefe --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/context_nemo.xml @@ -0,0 +1,40 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-ice.xml new file mode 120000 index 0000000000000000000000000000000000000000..5990a8ed642fc2e6c2e2e665cff2a9a8b94f3c56 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-ice.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-ice.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..d4980d9636a8097312a4289f8775a1664b84b9f4 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml @@ -0,0 +1,107 @@ +<?xml version="1.0"?> + <!-- $id$ --> + + <!-- +============================================================================================================ += output files definition = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="5ts" output_freq="5ts" output_level="10" enabled=".TRUE."> <!-- 1 day files --> + + <file id="file1" name_suffix="_icemod" description="ice variables" enabled=".true." > + + <!-- ice mask --> + <field field_ref="icemask" name="simsk" /> + + <!-- general --> + <field field_ref="snwvolu" name="snvolu" /> + <field field_ref="icethic" name="sithic" /> + <field field_ref="icethic" name="sithic_max" operation="maximum" /> + <field field_ref="icethic" name="sithic_min" operation="minimum" /> + <field field_ref="iceneg_pres" name="sineg_pres" /> + <field field_ref="iceneg_volu" name="sineg_volu" /> + <field field_ref="fasticepres" name="fasticepres" /> + <field field_ref="icevolu" name="sivolu" /> + <field field_ref="iceconc" name="siconc" /> + <field field_ref="icesalt" name="sisali" /> + <field field_ref="iceapnd" name="siapnd" /> + <field field_ref="icevpnd" name="sivpnd" /> + <field field_ref="sst_m" name="sst_m" /> + <field field_ref="sss_m" name="sss_m" /> + + <!-- heat --> + <field field_ref="icetemp" name="sitemp" /> + <field field_ref="icettop" name="sittop" /> + <field field_ref="icetbot" name="sitbot" /> + <field field_ref="icetsni" name="sitsni" /> + + <!-- momentum --> + <field field_ref="uice" name="sivelu" /> + <field field_ref="vice" name="sivelv" /> + <field field_ref="icevel" name="sivelo" /> + <field field_ref="utau_ai" name="utau_ai" /> + <field field_ref="vtau_ai" name="vtau_ai" /> + <field field_ref="utau_oi" name="utau_oi" /> + <field field_ref="vtau_oi" name="vtau_oi" /> + + <!-- rheology --> + <field field_ref="icediv" name="sidive" /> + <field field_ref="iceshe" name="sishea" /> + <field field_ref="icestr" name="sistre" /> + <field field_ref="normstr" name="normstr" /> + <field field_ref="sheastr" name="sheastr" /> + + <!-- heat fluxes --> + <field field_ref="qt_oce_ai" name="qt_oce_ai" /> + <field field_ref="qt_atm_oi" name="qt_atm_oi" /> + <field field_ref="qtr_ice_top" name="qtr_ice_top"/> + <field field_ref="qtr_ice_bot" name="qtr_ice_bot"/> + <field field_ref="qt_ice" name="qt_ice" /> + <field field_ref="qsr_ice" name="qsr_ice" /> + <field field_ref="qns_ice" name="qns_ice" /> + <field field_ref="qemp_ice" name="qemp_ice" /> + <field field_ref="albedo" name="albedo" /> + + <field field_ref="hfxcndtop" name="hfxcndtop" /> + <field field_ref="hfxcndbot" name="hfxcndbot" /> + <field field_ref="hfxsensib" name="hfxsensib" /> + + <!-- salt fluxes --> + <field field_ref="sfxice" name="sfxice" /> + + <!-- mass fluxes --> + <field field_ref="vfxice" name="vfxice" /> + <field field_ref="vfxsnw" name="vfxsnw" /> + + <!-- categories --> + <field field_ref="icemask_cat" name="simskcat"/> + <field field_ref="snwthic_cat" name="snthicat"/> + <field field_ref="iceconc_cat" name="siconcat"/> + <field field_ref="icethic_cat" name="sithicat"/> + <field field_ref="icesalt_cat" name="sisalcat"/> + <field field_ref="icetemp_cat" name="sitemcat"/> + + </file> + + </file_group> + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..a08549161444b2e17ee7ad77ecbebcd3a7b27131 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,33 @@ +<?xml version="1.0"?> + +<!-- +============================================================================================================ += output files definition = += Define your own filesfor ocean dynamics context = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> + + + + diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..47d022024e7a915a6c72016b7229132afe6b868c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/iodef.xml @@ -0,0 +1,30 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <!-- + <variable id="optimal_buffer_size" type="string">memory</variable> + <variable id="buffer_size_factor" type="double">1.0</variable> + --> + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/make_INITICE.py b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/make_INITICE.py new file mode 100755 index 0000000000000000000000000000000000000000..8f2852fb3d6fc506b1ce977dc44b30063120a341 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/make_INITICE.py @@ -0,0 +1,119 @@ +#!/usr/bin/python + +import os,sys +from netCDF4 import Dataset as netcdf +import numpy as np +import matplotlib.pyplot as plt +from math import exp +from math import ceil + +resname='' + +# input file +fcoord='mesh_mask.nc' + +# output file +fflx='initice.nc' + +print ' creating init ice file ' +fflx + +# Reading coordinates file +nccoord=netcdf(fcoord,'r') +nav_lon=nccoord.variables['nav_lon'] +nav_lat=nccoord.variables['nav_lat'] +time_counter=1 +LON1= nav_lon.shape[1] +LAT1= nav_lon.shape[0] +print 'nav_lon.shape[1]' ,nav_lon.shape[1] +print 'LON1 ', LON1 +print 'LAT1 ', LAT1 + +# Creating INITICE netcdf file +nc=netcdf(fflx,'w') +nc.createDimension('y',LAT1) +nc.createDimension('x',LON1) +nc.createDimension('time_counter',None) # Setting dimension size to 0 or None makes it unlimited. + +cdflon=nc.createVariable('nav_lon','f',('y','x')) +cdflat=nc.createVariable('nav_lat','f',('y','x')) +cdftimecounter=nc.createVariable('time_counter','f',('time_counter')) + +# ati : Fraction of open waters in sea ice - units % +# hti : Sea ice thickness - units m +# hts : Snow thickness - units m +# smi : Sea ice salinity: +# tmi : Sea ice internal temperature - units K +# tsu : Sea ice surface temperature - units K +# +# Take constant values from namelist &namiceini of NEMO +rn_hti_ini=2.0 +rn_hts_ini=0.2 # initial real snow thickness (m) +rn_ati_ini=0.9 # initial ice concentration (-) +rn_smi_ini=6.3 # initial ice salinity (g/kg) +rn_tmi_ini=270. # initial ice/snw temperature (K) +rn_tsu_ini=270. # initial sea ice temperature (K) +# +cdfati=nc.createVariable('ati','f',('time_counter','y','x')) +cdfati.units='Percentage' +cdfati.long_name='Sea ice concentration' +cdfhti=nc.createVariable('hti','f',('time_counter','y','x')) +cdfhti.long_name='Sea ice thickness' +cdfhti.units='m' +cdfhts=nc.createVariable('hts','f',('time_counter','y','x')) +cdfhts.long_name='Snow thickness' +cdfhts.units='m' +cdfsmi=nc.createVariable('smi','f',('time_counter','y','x')) +cdfsmi.long_name='Sea ice salinity' +cdfsmi.units='pss' +cdftmi=nc.createVariable('tmi','f',('time_counter','y','x')) +cdftmi.long_name='Sea ice internal temperature' +cdftmi.units='Kelvin' +cdftsu=nc.createVariable('tsu','f',('time_counter','y','x')) +cdftsu.long_name='Sea ice surface temperature' +cdftsu.units='Kelvin' + +cdflon[:,:]=nav_lon[:,:] +cdflat[:,:]=nav_lat[:,:] +cdftimecounter[0]=1 + +# Fill fields +#print 'cdfati[:,1]', cdfati[:,1] -> 32 values + +# Add a gaussian for sea ice thickness here +cdfhti[:,:,:]=0. +cdfhts[:,:,:]=0. +cdfati[:,:,:]=0. +cdfsmi[:,:,:]=0. +cdftmi[:,:,:]=rn_tmi_ini +cdftsu[:,:,:]=rn_tsu_ini + +# -------------------------------------- +# for basin=99x99km with dx=1km ; dy=3km +#sigx=-0.04 +#sigy=-0.04*9. +#xshift=50.-1. +#yshift=17.-1. +#dlat=7 +#dlon=21 + +# -------------------------------------- +# for basin=99x99km with dx=3km ; dy=3km +sigx=-0.04 +sigy=-0.04 +xshift=50.-1. +yshift=50.-1. +dlat=21 +dlon=21 + +# --- gaussian and square experiment --- +for y in np.arange(dlat,LAT1-dlat,1) : + for x in np.arange(dlon,LON1-dlon,1) : + cdfhti[:,y,x] = rn_hti_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) + cdfhts[:,y,x] = rn_hts_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) + cdfati[:,y,x] = rn_ati_ini + cdfsmi[:,y,x] = rn_smi_ini + +nc.close() +nccoord.close() + +#sys.exit() diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..68649faf3f398b56e875f938178fdc986dc3d872 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_cfg @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_ADV2D 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_ADV2D user defined namelist +!----------------------------------------------------------------------- + rn_dx = 3000. ! horizontal resolution in meters + rn_dy = 3000. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_ADV2D" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 485 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 1200. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_ADV2D_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..b3523682b5c5edc70c40ab82a10740bfb1448696 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg @@ -0,0 +1,105 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! 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 = .true. ! 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 +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_ref b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..23b14529cf92c567f7cc1d10b42ff842a5bb3bea --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ice_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..eeb06d16968cd26b1ec694b71716bd10bdbb199c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,162 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === ICE_ADV2D configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for ICE_ADV2D configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam, ONLY: rn_dx, rn_dy, ln_corio, rn_ppgphi0 ! horizontal resolution in meters + ! coriolis and reference latitude + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! ICE_ADV2D configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zphi0, zlam0, zbeta, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : ICE_ADV2D configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' f-plane with regular or irregular grid-spacing (+- 10%)' + IF(lwp) WRITE(numout,*) ' the max is given by rn_dx and rn_dy' + + ! ========== + zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx + zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN +!clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5 +!clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5 + zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhox() * rn_dx & + & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3 + zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhoy() * rn_dy & + & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3 + ENDIF +#endif + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 ) + zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp + + plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti + plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + + pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj + pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj + pphiu(ji,jj) = pphit(ji,jj) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + + ! Horizontal scale factors (in meters) + ! ====== +!! ==> EITHER 1) variable scale factors +!! clem: This can be used with a 1proc simulation but I think it breaks repro when >1procs are used +!! DO jj = 1, jpj +!! DO ji = 1, jpi +!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape +!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape +!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape +!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape +!! END DO +!! END DO +!!#if defined key_agrif +!! IF( .NOT. Agrif_Root() ) THEN ! only works if the zoom is positioned at the center of the parent grid +!! DO jj = 1, jpj +!! DO ji = 1, jpi +!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) & +!! & * REAL(jpiglo) / REAL(Agrif_Parent(jpiglo) * Agrif_Rhox()) ) ! factor to match parent grid +!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) & +!! & * REAL(jpjglo) / REAL(Agrif_Parent(jpjglo) * Agrif_Rhoy()) ) ! factor to match parent grid +!! END DO +!! END DO +!! ENDIF +!!#endif +!! ==> OR 2) constant scale factors + pe1t(:,:) = rn_dx + pe2t(:,:) = rn_dy +!! ==> END + + pe1u(:,:) = pe1t(:,:) ; pe2u(:,:) = pe2t(:,:) + pe1v(:,:) = pe1t(:,:) ; pe2v(:,:) = pe2t(:,:) + pe1f(:,:) = pe1t(:,:) ; pe2f(:,:) = pe2t(:,:) + + ! ! 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 Coriolis parameter afterward + ! + IF( ln_corio ) THEN + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + zbeta * pphif(:,:) * 1.e+3 + pff_t(:,:) = zf0 + zbeta * pphit(:,:) * 1.e+3 + ELSE + pff_f(:,:) = 0. + pff_t(:,:) = 0. + ENDIF + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..981a3da314a306ccd232c9aeef3593ef0389587e --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,125 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === ICE_ADV2D configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dy ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_ppgphi0 ! reference latitude for beta-plane + LOGICAL , PUBLIC :: ln_corio ! set coriolis at 0 (ln_corio=F) or not + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 10161 2018-10-01 09:48:55Z clem $ + !! 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 ICE_ADV2D 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 + REAL(wp):: zlx, zly ! Local scalars + !! + NAMELIST/namusr_def/ rn_dx, rn_dy, ln_corio, rn_ppgphi0 + !!---------------------------------------------------------------------- + ! + 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 ) + ! +#if defined key_agrif + ! Domain parameters are taken from parent: + IF( .NOT. Agrif_Root() ) THEN + rn_dx = Agrif_Parent(rn_dx)/Agrif_Rhox() + rn_dy = Agrif_Parent(rn_dy)/Agrif_Rhoy() + rn_ppgphi0 = Agrif_Parent(rn_ppgphi0) + ENDIF +#endif + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'ICE_ADV2D' ! name & resolution (not used) + kk_cfg = NINT( rn_dx ) + ! + IF( Agrif_Root() ) THEN ! Global Domain size: ICE_AGRIF domain is 300 km x 300 Km x 10 m + kpi = NINT( 300.e3 / rn_dx ) - 1 + kpj = NINT( 300.e3 / rn_dy ) - 1 + ELSE + kpi = nbcellsx + 2 + 2*nbghostcells + kpj = nbcellsy + 2 + 2*nbghostcells + ENDIF + kpk = 1 + ! +!! zlx = (kpi-2)*rn_dx*1.e-3 +!! zly = (kpj-2)*rn_dy*1.e-3 + zlx = kpi*rn_dx*1.e-3 + zly = kpj*rn_dy*1.e-3 + ! + IF( Agrif_Root() ) THEN ; kperio = 7 ! ICE_AGRIF configuration : bi-periodic basin + ELSE ; kperio = 0 ! closed periodicity for the zoom + ENDIF + ! ! 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 : ICE_ADV2D test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' meters' + WRITE(numout,*) ' ICE_ADV2D domain = 300 km x 300Km x 1 grid-point ' + WRITE(numout,*) ' LX [km]: ', zlx + WRITE(numout,*) ' LY [km]: ', zly + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' Coriolis:', ln_corio + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' ICE_ADV2D : bi-periodic basin jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b3cbb9bccce4290bd4d8acd29f6638c4e7b1137e --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,164 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === ICE_ADV2D configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in ICE_ADV2D 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: ice fields + USE phycst ! physical constants + USE ice, ONLY : at_i_b, a_i_b + USE icethd_dh ! for CALL ice_thd_snwblow + ! + 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called by sbcmod.F90 for sbc ocean + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 ICE_ADV2D case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usrdef_sbc_oce : ICE_ADV2D case: NO surface forcing' + ! --- oce variables --- ! + utau(:,:) = 0._wp + vtau(:,:) = 0._wp + taum(:,:) = 0._wp + wndm(:,:) = 0._wp + ! + emp (:,:) = 0._wp + sfx (:,:) = 0._wp + qns (:,:) = 0._wp + qsr (:,:) = 0._wp + ! + utau_b(:,:) = 0._wp + vtau_b(:,:) = 0._wp + emp_b (:,:) = 0._wp + sfx_b (:,:) = 0._wp + qns_b (:,:) = 0._wp + ! + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_tau *** + !! + !! ** Purpose : provide the surface boundary (momentum) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV2D case: constant stress forcing' + ! + utau_ice(:,:) = 1.3_wp ! <=> 0.5 m/s + vtau_ice(:,:) = 0._wp + ! + END SUBROUTINE usrdef_sbc_ice_tau + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_flx *** + !! + !! ** Purpose : provide the surface boundary (flux) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + !! + INTEGER :: jl + REAL(wp) :: zfr1, zfr2 ! local variables + REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!--------------------------------------------------------------------- + ! + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV2D case: NO flux forcing' + ! + ! ocean variables (renaming) + emp_oce (:,:) = 0._wp ! uniform value for freshwater budget (E-P) + qsr_oce (:,:) = 0._wp ! uniform value for solar radiation + qns_oce (:,:) = 0._wp ! uniform value for non-solar radiation + + ! ice variables + alb_ice (:,:,:) = 0.7_wp ! useless + qsr_ice (:,:,:) = 0._wp ! uniform value for solar radiation + qns_ice (:,:,:) = 0._wp ! uniform value for non-solar radiation + sprecip (:,:) = 0._wp ! uniform value for snow precip + evap_ice(:,:,:) = 0._wp ! uniform value for sublimation + + ! ice fields deduced from above + zsnw(:,:) = 1._wp + !!CALL lim_thd_snwblow( at_i_b, zsnw ) ! snow distribution over ice after wind blowing + emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) + emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) + qevap_ice(:,:,:) = 0._wp + qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + + ! total fluxes + emp_tot (:,:) = emp_ice + emp_oce + qns_tot (:,:) = at_i_b(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot (:,:) = at_i_b(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! + cloud_fra(:,:) = pp_cldf + 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 + + + END SUBROUTINE usrdef_sbc_ice_flx + + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1afabca7df41c278a56015e04ad9f548c55e9668 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,111 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === ICE_ADV2D case === + !! + !! Ocean domain : user defined vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE usrdef_nam ! User defined : namelist variables + ! + 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: usrdef_zgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 :: jk, k_dz ! dummy indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : ICE_ADV2D configuration ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ (slab ocean - advection of an ice patch in a biperiodic square box domain)' + ! + ! + ! type of vertical coordinate ==>>> here ICE_ADV2D : slab ocean always + ! --------------------------- + ld_zco = .TRUE. ! z-full-step coordinate + ld_zps = .FALSE. ! z-partial-step coordinate + ld_sco = .FALSE. ! s-coordinate + ld_isfcav = .FALSE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! + ! + k_dz = 1 + DO jk = 1, jpk + pdepw_1d(jk) = k_dz + pdept_1d(jk) = k_dz + pe3w_1d (jk) = k_dz + pe3t_1d (jk) = k_dz + END DO + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + k_top(:,:) = 1 + ! + ! !== z-coordinate ==! (step-like topography) + ! !* bottom ocean compute from the depth of grid-points + jpkm1 = jpk + k_bot(:,:) = 1 ! here use k_top as a land mask + ! !* horizontally uniform coordinate (reference z-co everywhere) + 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 usr_def_zgr + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/ICE_ADV2D/cpp_ICE_ADV2D.fcm b/V4.0/nemo_sources/tests/ICE_ADV2D/cpp_ICE_ADV2D.fcm new file mode 100644 index 0000000000000000000000000000000000000000..161874503647aa33cf54d816806356c7f4c28aba --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_ADV2D/cpp_ICE_ADV2D.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_si3 key_mpp_mpi key_nosignedzero key_iomput diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_context_nemo.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_context_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6a3fc9a676f06b1723e423872d5567fadf13d84c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_context_nemo.xml @@ -0,0 +1 @@ +context_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_cfg b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..39a830161c86e944b9a6082fab9ac35de2ccf32c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_cfg @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_AGRIF 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_AGRIF user defined namelist +!----------------------------------------------------------------------- + rn_dx = 1000. ! horizontal resolution in meters + rn_dy = 1000. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis to 0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_AGRIF" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 1500 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 400. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_AGRIF_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_cfg b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..e64cb6f430d12bccd40a15cc162db8492e592871 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_cfg @@ -0,0 +1,96 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .true. ! 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 +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .false. ! activate ice initialization (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_ref b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..23b14529cf92c567f7cc1d10b42ff842a5bb3bea --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ice_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ref b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/1_namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in new file mode 100644 index 0000000000000000000000000000000000000000..c153b11cf98643a1b981175687e1f8b7b638bbc0 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in @@ -0,0 +1,3 @@ +1 +34 63 34 63 3 3 3 +0 diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_1ghost b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_1ghost new file mode 100644 index 0000000000000000000000000000000000000000..bf5f4ad235ad21a1ac2f4573f6eca12d9fadb20f --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_1ghost @@ -0,0 +1,3 @@ +1 +36 65 36 65 3 3 3 +0 diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_3ghosts b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_3ghosts new file mode 100644 index 0000000000000000000000000000000000000000..c153b11cf98643a1b981175687e1f8b7b638bbc0 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in_3ghosts @@ -0,0 +1,3 @@ +1 +34 63 34 63 3 3 3 +0 diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/README b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/README new file mode 100644 index 0000000000000000000000000000000000000000..a88831350f3517f0c8ccf802f91d1102e4494174 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/README @@ -0,0 +1,40 @@ +------- +Purpose +------- +This demonstration case can be used to study the advection of a patch of ice in a bi-periodic channel +with a slab ocean (i.e. 1 ocean layer) and an agrif zoom in the center + +----------- +Experiments +----------- +Two experiments can be configured: + +a) A simple channel at 3km horizontal resolution (slightly variable => +- 10%) + ==> in MY_SRC/usrdef_hgr.F90, uncomment the part "variable scale factors" and comment part "constant scale factors" + +b) A simple channel at 3km horizontal resolution (constant scale factors) + ==> in MY_SRC/usrdef_hgr.F90, comment the part "variable scale factors" and uncomment part "constant scale factors" + +---------- +How to run +---------- + +a) Compile and run the model once to get a mesh_mask.nc file with the following command: +../../../makenemo -r ICE_AGRIF -n ICE_AGRIF -m X64_ADA -j 4 +mpirun ./nemo -np 1 + +b) Create the initial condition file for sea-ice (initice.nc) by running this python script: +python ./make_INITICE.py + +c) Run the model a second time +mpirun ./nemo -np 4 + +--------------- +What to look at +--------------- +the advection through an agrif zoom 1:3 + for a square (ice concentration) or a gaussian (ice volume) + with either a constant velocity (ln_dynADV2D=T and define rn_uice & rn_vice) + or a constant ice-atm. stress, thus velocity is calculated by rheology (ln_dynRHGADV=T) + with 1 or 5 ice categories (jpl=1 or 5) + (note that ln_dynADV2D=T only works with jpl=1) diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..10c52ce760b00ec18fc961c39a0c143565b89c97 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/context_nemo.xml @@ -0,0 +1,50 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> +<!-- $id$ --> + <variable_definition> + <!-- Year of time origin for NetCDF files; defaults to 1800 --> + <variable id="ref_year" type="int" > 1800 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO sea-ice model --> + <!-- +============================================================================================================ += grid definition = = DO NOT CHANGE = +============================================================================================================ + --> + + <axis_definition> + <axis id="deptht" long_name="Vertical T levels" unit="m" positive="down" /> + <axis id="depthu" long_name="Vertical U levels" unit="m" positive="down" /> + <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> + <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> + <axis id="nfloat" long_name="Float number" unit="-" /> + <axis id="icbcla" long_name="Iceberg class" unit="1" /> + <axis id="ncatice" long_name="Ice category" unit="1" /> + <axis id="iax_20C" long_name="20 degC isotherm" unit="degC" /> + <axis id="iax_28C" long_name="28 degC isotherm" unit="degC" /> + <axis id="deptht_surface" axis_ref="deptht" > + <zoom_axis begin=" 1 " n=" 1 " /> + </axis> + </axis_definition> + + <domain_definition src="./domain_def_nemo.xml"/> + + <grid_definition src="./grid_def_nemo.xml"/> + +</context> diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-ice.xml new file mode 120000 index 0000000000000000000000000000000000000000..5990a8ed642fc2e6c2e2e665cff2a9a8b94f3c56 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-ice.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-ice.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-ice.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..d78d50a295d227963d49dc0731b7f1fdb5bb902c --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-ice.xml @@ -0,0 +1,105 @@ +<?xml version="1.0"?> + <!-- $id$ --> + + <!-- +============================================================================================================ += output files definition = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="5ts" output_freq="5ts" output_level="10" enabled=".TRUE."> <!-- 1 day files --> + + <file id="file1" name_suffix="_icemod" description="ice variables" enabled=".true." > + + <!-- ice mask --> + <field field_ref="icemask" name="simsk" /> + + <!-- general --> + <field field_ref="snwvolu" name="snvolu" /> + <field field_ref="icethic" name="sithic" /> + <field field_ref="icethic" name="sithic_max" operation="maximum" /> + <field field_ref="icethic" name="sithic_min" operation="minimum" /> + <field field_ref="fasticepres" name="fasticepres" /> + <field field_ref="icevolu" name="sivolu" /> + <field field_ref="iceconc" name="siconc" /> + <field field_ref="icesalt" name="sisali" /> + <field field_ref="iceapnd" name="siapnd" /> + <field field_ref="icevpnd" name="sivpnd" /> + <field field_ref="sst_m" name="sst_m" /> + <field field_ref="sss_m" name="sss_m" /> + + <!-- heat --> + <field field_ref="icetemp" name="sitemp" /> + <field field_ref="icettop" name="sittop" /> + <field field_ref="icetbot" name="sitbot" /> + <field field_ref="icetsni" name="sitsni" /> + + <!-- momentum --> + <field field_ref="uice" name="sivelu" /> + <field field_ref="vice" name="sivelv" /> + <field field_ref="icevel" name="sivelo" /> + <field field_ref="utau_ai" name="utau_ai" /> + <field field_ref="vtau_ai" name="vtau_ai" /> + <field field_ref="utau_oi" name="utau_oi" /> + <field field_ref="vtau_oi" name="vtau_oi" /> + + <!-- rheology --> + <field field_ref="icediv" name="sidive" /> + <field field_ref="iceshe" name="sishea" /> + <field field_ref="icestr" name="sistre" /> + <field field_ref="normstr" name="normstr" /> + <field field_ref="sheastr" name="sheastr" /> + + <!-- heat fluxes --> + <field field_ref="qt_oce_ai" name="qt_oce_ai" /> + <field field_ref="qt_atm_oi" name="qt_atm_oi" /> + <field field_ref="qtr_ice_top" name="qtr_ice_top"/> + <field field_ref="qtr_ice_bot" name="qtr_ice_bot"/> + <field field_ref="qt_ice" name="qt_ice" /> + <field field_ref="qsr_ice" name="qsr_ice" /> + <field field_ref="qns_ice" name="qns_ice" /> + <field field_ref="qemp_ice" name="qemp_ice" /> + <field field_ref="albedo" name="albedo" /> + + <field field_ref="hfxcndtop" name="hfxcndtop" /> + <field field_ref="hfxcndbot" name="hfxcndbot" /> + <field field_ref="hfxsensib" name="hfxsensib" /> + + <!-- salt fluxes --> + <field field_ref="sfxice" name="sfxice" /> + + <!-- mass fluxes --> + <field field_ref="vfxice" name="vfxice" /> + <field field_ref="vfxsnw" name="vfxsnw" /> + + <!-- categories --> + <field field_ref="icemask_cat" name="simskcat"/> + <field field_ref="snwthic_cat" name="snthicat"/> + <field field_ref="iceconc_cat" name="siconcat"/> + <field field_ref="icethic_cat" name="sithicat"/> + <field field_ref="icesalt_cat" name="sisalcat"/> + <field field_ref="icetemp_cat" name="sitemcat"/> + + </file> + + </file_group> + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..a08549161444b2e17ee7ad77ecbebcd3a7b27131 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,33 @@ +<?xml version="1.0"?> + +<!-- +============================================================================================================ += output files definition = += Define your own filesfor ocean dynamics context = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."/> <!-- 5d files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> + + + + diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..85f1a36cd0d155102b0b3d34a43b51abe4de7959 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/iodef.xml @@ -0,0 +1,33 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <!-- + <variable id="optimal_buffer_size" type="string">memory</variable> + <variable id="buffer_size_factor" type="double">1.0</variable> + --> + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + <context id="1_nemo" src="./1_context_nemo.xml"/> +<!-- + <context id="2_nemo" src="./2_context_nemo.xml"/> +--> +</simulation> diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/make_INITICE.py b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/make_INITICE.py new file mode 100755 index 0000000000000000000000000000000000000000..1b5d1c0c638d5ccfe19ef176b60a6d30b6522e16 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/make_INITICE.py @@ -0,0 +1,127 @@ +#!/usr/bin/python + +import os,sys +from netCDF4 import Dataset as netcdf +import numpy as np +import matplotlib.pyplot as plt +from math import exp +from math import ceil + +resname='' + +# input file +fcoord='mesh_mask.nc' + +# output file +fflx='initice.nc' + +print ' creating init ice file ' +fflx + +# Reading coordinates file +nccoord=netcdf(fcoord,'r') +nav_lon=nccoord.variables['nav_lon'] +nav_lat=nccoord.variables['nav_lat'] +time_counter=1 +LON1= nav_lon.shape[1] +LAT1= nav_lon.shape[0] +print 'nav_lon.shape[1]' ,nav_lon.shape[1] +print 'LON1 ', LON1 +print 'LAT1 ', LAT1 + +# Creating INITICE netcdf file +nc=netcdf(fflx,'w') +nc.createDimension('y',LAT1) +nc.createDimension('x',LON1) +nc.createDimension('time_counter',None) # Setting dimension size to 0 or None makes it unlimited. + +cdflon=nc.createVariable('nav_lon','f',('y','x')) +cdflat=nc.createVariable('nav_lat','f',('y','x')) +cdftimecounter=nc.createVariable('time_counter','f',('time_counter')) + +# ati : Fraction of open waters in sea ice - units % +# hti : Sea ice thickness - units m +# hts : Snow thickness - units m +# smi : Sea ice salinity: +# tmi : Sea ice internal temperature - units K +# tsu : Sea ice surface temperature - units K +# +# Take constant values from namelist &namiceini of NEMO +rn_hti_ini=2.0 +rn_hts_ini=0.2 # initial real snow thickness (m) +rn_ati_ini=0.9 # initial ice concentration (-) +rn_smi_ini=6.3 # initial ice salinity (g/kg) +rn_tmi_ini=270. # initial ice/snw temperature (K) +rn_tsu_ini=270. # initial sea ice temperature (K) +# +cdfati=nc.createVariable('ati','f',('time_counter','y','x')) +cdfati.units='Percentage' +cdfati.long_name='Sea ice concentration' +cdfhti=nc.createVariable('hti','f',('time_counter','y','x')) +cdfhti.long_name='Sea ice thickness' +cdfhti.units='m' +cdfhts=nc.createVariable('hts','f',('time_counter','y','x')) +cdfhts.long_name='Snow thickness' +cdfhts.units='m' +cdfsmi=nc.createVariable('smi','f',('time_counter','y','x')) +cdfsmi.long_name='Sea ice salinity' +cdfsmi.units='pss' +cdftmi=nc.createVariable('tmi','f',('time_counter','y','x')) +cdftmi.long_name='Sea ice internal temperature' +cdftmi.units='Kelvin' +cdftsu=nc.createVariable('tsu','f',('time_counter','y','x')) +cdftsu.long_name='Sea ice surface temperature' +cdftsu.units='Kelvin' + +cdflon[:,:]=nav_lon[:,:] +cdflat[:,:]=nav_lat[:,:] +cdftimecounter[0]=1 + +# Fill fields +#print 'cdfati[:,1]', cdfati[:,1] -> 32 values + +# Add a gaussian for sea ice thickness here +cdfhti[:,:,:]=0. +cdfhts[:,:,:]=0. +cdfati[:,:,:]=0. +cdfsmi[:,:,:]=0. +cdftmi[:,:,:]=rn_tmi_ini +cdftsu[:,:,:]=rn_tsu_ini + +# -------------------------------------- +# for basin=99x99km with dx=1km ; dy=1km +#sigx=-0.04 +#sigy=-0.04 +#xshift=50.-1. +#yshift=50.-1. +#dlat=21 +#dlon=21 + +# --- gaussian and square experiment --- +#for y in np.arange(dlat,LAT1-dlat,1) : +# for x in np.arange(dlon,LON1-dlon,1) : +# cdfhti[:,y,x] = rn_hti_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) +# cdfhts[:,y,x] = rn_hts_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) +# cdfati[:,y,x] = rn_ati_ini +# cdfsmi[:,y,x] = rn_smi_ini +# + +# ---------------------------------------------- +# for basin=300x300km with dx=3km ; dy=3km + AGRIF +sigx=-0.012 +sigy=-0.012 +xshift=20.-1. +yshift=50.-1. +dlat=18 +dlon=18 +for y in np.arange(32,66,1) : + for x in np.arange(2,36,1) : + cdfhti[:,y,x] = rn_hti_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) + cdfhts[:,y,x] = rn_hts_ini*exp(sigx*(x-xshift)**2)*exp(sigy*(y-yshift)**2) + cdfati[:,y,x] = rn_ati_ini + cdfsmi[:,y,x] = rn_smi_ini +# ------------------------------------------------ + +nc.close() +nccoord.close() + +#sys.exit() diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..4a264538d1ad54831f58a4c97bbe438e5791589b --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_cfg @@ -0,0 +1,236 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ICE_AGRIF 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! ICE_AGRIF user defined namelist +!----------------------------------------------------------------------- + rn_dx = 3000. ! horizontal resolution in meters + rn_dy = 3000. ! horizontal resolution in meters + ln_corio = .false. ! set coriolis=0 (false) or not (true) + rn_ppgphi0 = 70. ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "ICE_AGRIF" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 500 ! last time step (std 5475) + nn_istate = 1 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time + ! + rn_rdt = 1200. ! time step for the dynamics (and tracer if nn_acc=0) + ! + ln_meshmask = .true. ! =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 ==>>> see usrdef(_...) modules + cn_domcfg = "ICE_AGRIF_domcfg" ! domain configuration filename +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_fsbc = 1 ! frequency of surface boundary condition computation + nn_ice = 2 ! sea-ice model +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .false. ! =T Read in file ; =F set all to 0. (see sbcssm.F90) +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!---------------------------------------------------------------------------------- + ln_traldf_OFF = .true. ! laplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .true. ! linear dynamics (no momentum advection) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .true. ! z-coordinate - full steps +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_OFF = .true. ! No operator (i.e. no explicit diffusion) +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdfcst = .true. ! constant mixing +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..a932a48fe7f3810a5623c1fdac94c0995aef6d87 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg @@ -0,0 +1,105 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .false. ! ice thermo (T) or not (F) +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .true. ! 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 +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .false. ! Advection scheme (Prather) + ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 1 ! netcdf file provided for initialization + + sn_hti = 'initice' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'initice' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'initice' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'initice' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'initice' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'initice' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_ref b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..23b14529cf92c567f7cc1d10b42ff842a5bb3bea --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ice_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ice_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1da5120802c6537bc09b1fbc9cc355e95b75acd7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,162 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === ICE_AGRIF configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for ICE_AGRIF configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam, ONLY: rn_dx, rn_dy, ln_corio, rn_ppgphi0 ! horizontal resolution in meters + ! coriolis and reference latitude + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10516 2019-01-15 16:31:25Z clem $ + !! 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 + !! ICE_AGRIF configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zphi0, zlam0, zbeta, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : ICE_AGRIF configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' f-plane with irregular grid-spacing (+- 10%)' + IF(lwp) WRITE(numout,*) ' the max is given by rn_dx and rn_dy' + + ! ========== + zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx + zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN +!clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5 +!clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5 + zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhox() * rn_dx & + & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3 + zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhoy() * rn_dy & + & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3 + ENDIF +#endif + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 ) + zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp + + plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti + plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + + pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj + pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj + pphiu(ji,jj) = pphit(ji,jj) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + + ! Horizontal scale factors (in meters) + ! ====== +!! ==> EITHER 1) variable scale factors +!! clem: This can be used with a 1proc simulation but I think it breaks repro when >1procs are used +!! DO jj = 1, jpj +!! DO ji = 1, jpi +!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape +!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape +!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape +!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape +!! END DO +!! END DO +!!#if defined key_agrif +!! IF( .NOT. Agrif_Root() ) THEN ! only works if the zoom is positioned at the center of the parent grid +!! DO jj = 1, jpj +!! DO ji = 1, jpi +!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) & +!! & * REAL(jpiglo) / REAL(Agrif_Parent(jpiglo) * Agrif_Rhox()) ) ! factor to match parent grid +!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) & +!! & * REAL(jpjglo) / REAL(Agrif_Parent(jpjglo) * Agrif_Rhoy()) ) ! factor to match parent grid +!! END DO +!! END DO +!! ENDIF +!!#endif +!! ==> OR 2) constant scale factors + pe1t(:,:) = rn_dx + pe2t(:,:) = rn_dy +!! ==> END + + pe1u(:,:) = pe1t(:,:) ; pe2u(:,:) = pe2t(:,:) + pe1v(:,:) = pe1t(:,:) ; pe2v(:,:) = pe2t(:,:) + pe1f(:,:) = pe1t(:,:) ; pe2f(:,:) = pe2t(:,:) + + ! ! 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 Coriolis parameter afterward + ! + IF( ln_corio ) THEN + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + zbeta * pphif(:,:) * 1.e+3 + pff_t(:,:) = zf0 + zbeta * pphit(:,:) * 1.e+3 + ELSE + pff_f(:,:) = 0. + pff_t(:,:) = 0. + ENDIF + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..5a1d5234301c3e6cc86efbf76f54935c2c5c533d --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,125 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === ICE_AGRIF configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dy ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_ppgphi0 ! reference latitude for beta-plane + LOGICAL , PUBLIC :: ln_corio ! set coriolis at 0 (ln_corio=F) or not + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 12598 2020-03-25 09:02:31Z smasson $ + !! 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 ICE_AGRIF 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 + REAL(wp):: zlx, zly ! Local scalars + !! + NAMELIST/namusr_def/ rn_dx, rn_dy, ln_corio, rn_ppgphi0 + !!---------------------------------------------------------------------- + ! + 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 ) + ! +#if defined key_agrif + ! Domain parameters are taken from parent: + IF( .NOT. Agrif_Root() ) THEN + rn_dx = Agrif_Parent(rn_dx)/Agrif_Rhox() + rn_dy = Agrif_Parent(rn_dy)/Agrif_Rhoy() + rn_ppgphi0 = Agrif_Parent(rn_ppgphi0) + ENDIF +#endif + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'ICE_AGRIF' ! name & resolution (not used) + kk_cfg = NINT( rn_dx ) + ! + IF( Agrif_Root() ) THEN ! Global Domain size: ICE_AGRIF domain is 300 km x 300 Km x 10 m + kpi = NINT( 300.e3 / rn_dx ) - 1 + kpj = NINT( 300.e3 / rn_dy ) - 1 + ELSE + kpi = nbcellsx + 2 + 2*nbghostcells + kpj = nbcellsy + 2 + 2*nbghostcells + ENDIF + kpk = 2 + ! +!! zlx = (kpi-2)*rn_dx*1.e-3 +!! zly = (kpj-2)*rn_dy*1.e-3 + zlx = kpi*rn_dx*1.e-3 + zly = kpj*rn_dy*1.e-3 + ! + IF( Agrif_Root() ) THEN ; kperio = 7 ! ICE_AGRIF configuration : bi-periodic basin + ELSE ; kperio = 0 ! closed periodicity for the zoom + ENDIF + ! ! 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 : ICE_AGRIF test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' meters' + WRITE(numout,*) ' ICE_AGRIF domain = 300 km x 300Km x 1 grid-point ' + WRITE(numout,*) ' LX [km]: ', zlx + WRITE(numout,*) ' LY [km]: ', zly + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' Coriolis:', ln_corio + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' ICE_AGRIF : bi-periodic basin jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..52192f5f5aa5303f2057b4477d49e45f2dce0a64 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,163 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === ICE_AGRIF configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in ICE_AGRIF 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: ice fields + USE phycst ! physical constants + USE ice, ONLY : at_i_b, a_i_b + USE icethd_dh ! for CALL ice_thd_snwblow + ! + 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called by sbcmod.F90 for sbc ocean + 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: usrdef_sbc.F90 13284 2020-07-09 15:12:23Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 ICE_AGRIF case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usrdef_sbc_oce : ICE_AGRIF case: NO surface forcing' + ! --- oce variables --- ! + utau(:,:) = 0._wp + vtau(:,:) = 0._wp + taum(:,:) = 0._wp + wndm(:,:) = 0._wp + ! + emp (:,:) = 0._wp + sfx (:,:) = 0._wp + qns (:,:) = 0._wp + qsr (:,:) = 0._wp + ! + utau_b(:,:) = 0._wp + vtau_b(:,:) = 0._wp + emp_b (:,:) = 0._wp + sfx_b (:,:) = 0._wp + qns_b (:,:) = 0._wp + ! + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_tau *** + !! + !! ** Purpose : provide the surface boundary (momentum) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_AGRIF case: constant stress forcing' + ! + utau_ice(:,:) = 1.3_wp ! <=> 0.5 m/s + vtau_ice(:,:) = 0._wp + ! + END SUBROUTINE usrdef_sbc_ice_tau + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc_ice_flx *** + !! + !! ** Purpose : provide the surface boundary (flux) condition over sea-ice + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + !! + INTEGER :: jl + REAL(wp) :: zfr1, zfr2 ! local variables + REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!--------------------------------------------------------------------- + ! + IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_AGRIF case: NO flux forcing' + ! + ! ocean variables (renaming) + emp_oce (:,:) = 0._wp ! uniform value for freshwater budget (E-P) + qsr_oce (:,:) = 0._wp ! uniform value for solar radiation + qns_oce (:,:) = 0._wp ! uniform value for non-solar radiation + + ! ice variables + alb_ice (:,:,:) = 0.7_wp ! useless + qsr_ice (:,:,:) = 0._wp ! uniform value for solar radiation + qns_ice (:,:,:) = 0._wp ! uniform value for non-solar radiation + sprecip (:,:) = 0._wp ! uniform value for snow precip + evap_ice(:,:,:) = 0._wp ! uniform value for sublimation + + ! ice fields deduced from above + zsnw(:,:) = 1._wp + !!CALL lim_thd_snwblow( at_i_b, zsnw ) ! snow distribution over ice after wind blowing + emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) + emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) + qevap_ice(:,:,:) = 0._wp + qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + + ! total fluxes + emp_tot (:,:) = emp_ice + emp_oce + qns_tot (:,:) = at_i_b(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot (:,:) = at_i_b(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! + cloud_fra(:,:) = pp_cldf + 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 + + END SUBROUTINE usrdef_sbc_ice_flx + + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..214feddf75c070c9d5716595b5389fc84a067c5a --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,111 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === ICE_AGRIF case === + !! + !! Ocean domain : user defined vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE usrdef_nam ! User defined : namelist variables + ! + 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: usrdef_zgr.F90 12598 2020-03-25 09:02:31Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw, & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: 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 :: jk, k_dz ! dummy indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : ICE_AGRIF configuration ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ (slab ocean - advection of an ice patch in a biperiodic square box domain)' + ! + ! + ! type of vertical coordinate ==>>> here ICE_AGRIF : slab ocean always + ! --------------------------- + ld_zco = .TRUE. ! z-full-step coordinate + ld_zps = .FALSE. ! z-partial-step coordinate + ld_sco = .FALSE. ! s-coordinate + ld_isfcav = .FALSE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! + ! + k_dz = 1 + DO jk = 1, jpk + pdepw_1d(jk) = k_dz + pdept_1d(jk) = k_dz + pe3w_1d (jk) = k_dz + pe3t_1d (jk) = k_dz + END DO + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + k_top(:,:) = 1 + ! + ! !== z-coordinate ==! (step-like topography) + ! !* bottom ocean compute from the depth of grid-points + jpkm1 = jpk-1 + k_bot(:,:) = 1 ! here use k_top as a land mask + ! !* horizontally uniform coordinate (reference z-co everywhere) + 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 usr_def_zgr + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm b/V4.0/nemo_sources/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm new file mode 100644 index 0000000000000000000000000000000000000000..5f9c4287ffd797be07ccff35ea016d3bc3f1e418 --- /dev/null +++ b/V4.0/nemo_sources/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_agrif key_si3 key_mpp_mpi key_iomput diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_mlt.png b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_mlt.png new file mode 100644 index 0000000000000000000000000000000000000000..5435a75b3ce83568f9458cd51df0209e9b108b83 Binary files /dev/null and b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_mlt.png differ diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_moc.png b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_moc.png new file mode 100644 index 0000000000000000000000000000000000000000..5afdfbd5c5f22d809056dbdb913beef70447b0bd Binary files /dev/null and b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_moc.png differ diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_psi.png b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_psi.png new file mode 100644 index 0000000000000000000000000000000000000000..5c46d728c3b6dc012e6ffb669f52687b2abb58cc Binary files /dev/null and b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/ISOMIP_psi.png differ diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/README b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/README new file mode 100644 index 0000000000000000000000000000000000000000..06dd530372dc213f637492d698ed8b044d1c6bc1 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/README @@ -0,0 +1,25 @@ +# ISOMIP is a simple TEST_CASE to test the iceshelves in NEMO. +# no input files are needed (all is prescribed in MY_SRC/usr_def routines +# for a reference documentation on the ISOMIP test case, see experiement 1 on http://efdl.cims.nyu.edu/project_oisi/isomip/experiments/phase_I/idealized_numerical_models_5.pdf + +# default namelist is setup for a 30y run on 32 processors with the minimum output using XIOS in attached mode with single file output + +# How to build moc.nc and psi.nc + - Download or clone the CDFTOOLS (see https://github.com/meom-group/CDFTOOLS) + - Compile all the tools (or at least cdfpsi and cdfmoc) on your cluster (see https://github.com/meom-group/CDFTOOLS#using-cdftools) + - if mesh_mask.nc is splitted, you need to rebuild them using the rebuild NEMO tools (see in NEMOGCM/TOOLS) or run 1 (or more) time step on a single processor (nn_itend variable in the namelist). + - set the correct link: ln -s mesh_mask.nc mask.nc ; ln -s mesh_mask.nc mesh_hgr.nc ; ln -s mesh_mask.nc mesh_zgr.nc + - run the cdftools : + - cdfmoc ISOMIP_1m_00010101_00301231_grid_V.nc => moc.nc + - cdfpsi ISOMIP_1m_00010101_00301231_grid_U.nc ISOMIP_1m_00010101_00301231_grid_V.nc => psi.nc + +# How to plt moc/psi and melt (python with netcdf and matplotlib library requiried): + - psi.png => python2.7 plot_psi.py -f psi.nc -v sobarstf + - moc.png => python2.7 plot_moc.py -f moc.nc -v zomsfglo + - mlt.png => python2.7 plot_mlt.py -f ISOMIP_1m_00010101_00301231_grid_T.nc -v sowflisf +by default the last time frame is plotted. + +# location the expected circulation and melt plot after 30y of run: + - ISOMIP/EXP00/ISOMIP_psi.png + - ISOMIP/EXP00/ISOMIP_moc.png + - ISOMIP/EXP00/ISOMIP_mlt.png diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..8b856d3074ea23e61650703ce5f3364bb8ff6a61 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,51 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + + <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> + <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files --> + + <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> + <file id="file1" output_freq="1mo" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="toce" name="votemper" /> + <field field_ref="soce" name="vosaline" /> + <field field_ref="ssh" name="sossheig" /> + <!-- variable for ice shelf --> + <field field_ref="qlatisf" name="sohflisf" /> + <field field_ref="fwfisf" name="sowflisf" /> + <field field_ref="isfgammat" name="sogammat" /> + <field field_ref="isfgammas" name="sogammas" /> + </file> + <file id="file2" output_freq="1mo" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="uoce" name="vozocrtx" /> + </file> + <file id="file3" output_freq="1mo" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="voce" name="vomecrty" /> + </file> + </file_group> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> + diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..d4be5c1bd4104bfd3e1a69db33d6647804565cf9 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/iodef.xml @@ -0,0 +1,26 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..96365c68f8ba5134f46cd21ffecf8267baf81eab --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_cfg @@ -0,0 +1,307 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ISOMIP 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 = "ISOMIP" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 525600 ! last time step + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 99999999 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 48 ! frequency of write in the output file (modulo referenced to nn_it000) + nn_istate = 0 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namusr_def ! ISOMIP user defined namelist +!----------------------------------------------------------------------- + ln_zps = .true. ! z-partial-step coordinate + ln_zco = .false. ! z-full-step coordinate + ln_sco = .false. ! s-coordinate + rn_e1deg = 0.3 ! zonal grid-spacing (degrees) + rn_e2deg = 0.1 ! meridional grid-spacing (degrees) + rn_e3 = 30. ! vertical resolution +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_rdt = 1800. ! time step for the dynamics (and tracer if nn_acc=0) +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_isf = .true. ! ice shelf melting/freezing (T => fill namsbc_isf) +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) +! ! file name ! frequency (hours) ! variable ! time interpol. ! 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.0e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.0e-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 = 0 ! 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 +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 +/ +!!====================================================================== +!! *** 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 = .true. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .false. ! implicit top/bottom friction flag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 2.5e-3 ! drag coefficient [-] + rn_Uc0 = 0.16 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 0.0e-0 ! 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 +!----------------------------------------------------------------------- + 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 [-] +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_eos80 = .true. ! = Use EOS80 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_lap = .true. ! laplacian operator + ln_traldf_hor = .true. ! horizontal (geopotential) + ! ! Coefficients: + nn_aht_ijk_t = 0 ! = 0 constant = 1/2 Ud*Ld (lap case) + rn_Ud = 0.02 ! lateral diffusive velocity [m/s] + rn_Ld = 10.e+3 ! lateral diffusive length [m] +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) + nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: OFF) +!----------------------------------------------------------------------- + ln_dynvor_ene = .true. ! energy conserving scheme +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_isf = .true. ! s-coordinate adapted for isf (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = 0 ! = 0 constant = 1/2 Uv*Lv (lap case) + rn_Uv = 0.12 ! lateral viscous velocity [m/s] + rn_Lv = 10.e+3 ! 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) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ln_zdfevd = .true. ! enhanced vertical diffusion + nn_evdm = 1 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 0.1 ! mixing coefficient [m2/s] + ! ! coefficients + rn_avm0 = 1.e-3 ! vertical eddy viscosity [m2/s] + rn_avt0 = 5.e-5 ! vertical eddy diffusivity [m2/s] +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_mlt.py b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_mlt.py new file mode 100644 index 0000000000000000000000000000000000000000..edb9e04afe6a73d309ca73ecf5922344e4c0c060 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_mlt.py @@ -0,0 +1,47 @@ +from netCDF4 import Dataset +import numpy as np +from numpy import ma +import argparse +import matplotlib.pyplot as plt +import matplotlib + +parser = argparse.ArgumentParser() +parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True ) +parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) +args = parser.parse_args() + +# read mesh_mask +ncid = Dataset('mesh_mask.nc') +lat2d = ncid.variables['gphit' ][ :,:].squeeze() +lon2d = ncid.variables['glamt' ][ :,:].squeeze() +msk = ncid.variables['tmaskutil'][0,:,:].squeeze() +ncid.close() + +plt.figure(figsize=np.array([210,210]) / 25.4) + +# read psi.nc +ncid = Dataset(args.f[0]) +var2d = ncid.variables[args.v[0]][-1,:,:].squeeze() +var2dm = ma.masked_where(msk==0.0,var2d) +# convert in m/y +var2dm = var2dm * 86400 * 365 / 1e3 +ncid.close() + +# define colorbar +vlevel=np.arange(-1.6,1.8,0.2) +pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel,extend='both') +vlevel=np.arange(-1.6,1.8,0.4) +matplotlib.rcParams['contour.negative_linestyle'] = 'solid' +plt.contour(lon2d,lat2d,var2dm,levels=vlevel,colors='k') +plt.grid() +plt.title('melt rate ISOMIP (m/y)') +plt.ylabel('Latitude',fontsize=14) +plt.xlabel('Longitude',fontsize=14) +cbar = plt.colorbar(pcol, ticks=vlevel) +cbar.ax.tick_params(labelsize=14) + +# save figure +plt.savefig('mlt.png', format='png', dpi=300) + +plt.show() + diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_moc.py b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_moc.py new file mode 100644 index 0000000000000000000000000000000000000000..f8fc48e811b92f6c2d44cb70942afe119d228242 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_moc.py @@ -0,0 +1,60 @@ +from netCDF4 import Dataset +import numpy as np +import argparse +import matplotlib.pyplot as plt + +# read argument +parser = argparse.ArgumentParser() +parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs=1 , required=True ) +parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) +args = parser.parse_args() + +# read mesh mask +ncid = Dataset('mesh_mask.nc') +vx2d = ncid.variables['gphit' ][0,:,0].squeeze() +vx2dv = ncid.variables['gphiv' ][0,:,0].squeeze() +y2d = ncid.variables['gdepw_0'][0,:,:,1].squeeze()*-1 +y2dt = ncid.variables['gdept_0'][0,:,:,1].squeeze()*-1 +msk = ncid.variables['tmask' ][0,:,:,1].squeeze() +ncid.close() + +# build x 2d array +x2d=y2d*0.0 +x2dv=y2d*0.0 +for jk in range(0,y2d.shape[0]): + x2d[jk,:]=vx2d[:] + x2dv[jk,:]=vx2d[:] + +plt.figure(figsize=np.array([210,210]) / 25.4) + +# read data and mask it +ncid = Dataset(args.f[0]) +var2d = ncid.variables[args.v[0]][-1,:,:,:].squeeze() +var2dm = var2d[:,:] +var2dm[msk==0] = -1 +ncid.close() + +# define colorbar +vlevel=np.arange(0,0.13,0.01) +pcol = plt.contourf(x2d,y2d,var2dm,levels=vlevel) +plt.clf() + +# plot contour +ax = plt.subplot(1, 1, 1) +ax.contour(x2dv,y2dt,var2dm,levels=vlevel) +ax.grid() +ax.set_title('MOC ISOMIP (Sv)') +ax.set_ylabel('Depth (m)',fontsize=14) +ax.set_xlabel('Latitude',fontsize=14) + +# plot colorbar +plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1) +cax = plt.axes([0.91, 0.1, 0.02, 0.79]) +cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax) +cbar.ax.tick_params(labelsize=14) + +# save figure +plt.savefig('moc.png', format='png', dpi=300) + +plt.show() + diff --git a/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_psi.py b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_psi.py new file mode 100644 index 0000000000000000000000000000000000000000..16b615fdad922cd8f0cd41591e937a7e9f5d909d --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/EXPREF/plot_psi.py @@ -0,0 +1,52 @@ +from netCDF4 import Dataset +import numpy as np +from numpy import ma +import argparse +import matplotlib.pyplot as plt + +parser = argparse.ArgumentParser() +parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True ) +parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) +args = parser.parse_args() + +# read mesh_mask +ncid = Dataset('mesh_mask.nc') +lat2d = ncid.variables['gphit' ][ :,:].squeeze() +lon2d = ncid.variables['glamt' ][ :,:].squeeze() +msk = ncid.variables['tmaskutil'][0,:,:].squeeze() +ncid.close() + +plt.figure(figsize=np.array([210,210]) / 25.4) + +# read psi.nc +ncid = Dataset(args.f[0]) +var2d = ncid.variables[args.v[0]][-1,:,:].squeeze() +var2dm = ma.masked_where(msk==0.0,var2d) +# convert in Sv +var2dm = var2dm / 1e6 +ncid.close() + +# define colorbar +vlevel=np.arange(0.00,0.36,0.02) +pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel) +plt.clf() + +# plot contour +ax = plt.subplot(1, 1, 1) +ax.contour(lon2d,lat2d,var2dm,levels=vlevel) +ax.grid() +ax.set_title('PSI ISOMIP (Sv)') +ax.set_ylabel('Latitude',fontsize=14) +ax.set_xlabel('Longitude',fontsize=14) + +# plot colorbar +plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1) +cax = plt.axes([0.91, 0.1, 0.02, 0.79]) +cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax) +cbar.ax.tick_params(labelsize=14) + +# save figure +plt.savefig('psi.png', format='png', dpi=300) + +plt.show() + diff --git a/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..390d6c7533d8174e9f23d06a3143468f6c716b03 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,120 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === LOCK_EXCHANGE configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for ISOMIP configuration + !!---------------------------------------------------------------------- + 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, ONLY: rn_e1deg, rn_e2deg ! horizontal resolution in meters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! ISOMIP configuration + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) + !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) + !! - define u- & v-surfaces (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) :: zfact, zti, zui, zvi, zfi, ztj, zuj, zvj, zfj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'usr_def_hgr : ISOMIP configuration' + WRITE(numout,*) '~~~~~~~~~~~' + WRITE(numout,*) + WRITE(numout,*) ' ===>> geographical mesh on the sphere with regular grid-spacing' + WRITE(numout,*) ' given by rn_e1deg and rn_e2deg' + ENDIF + ! + ! !== grid point position ==! (in degrees) + DO jj = 1, jpj + DO ji = 1, jpi ! longitude (west coast at lon=0°) + plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) ) + plamu(ji,jj) = rn_e1deg * ( REAL( ji-1 + nimpp-1 , wp ) ) + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + ! ! latitude (south coast at lat= 81°) + pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) - 80._wp + pphiu(ji,jj) = pphit(ji,jj) + pphiv(ji,jj) = rn_e2deg * ( REAL( jj-1 + njmpp-1 , wp ) ) - 80_wp + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! !== Horizontal scale factors ==! (in meters) + DO jj = 1, jpj + DO ji = 1, jpi + ! ! e1 (zonal) + pe1t(ji,jj) = ra * rad * COS( rad * pphit(ji,jj) ) * rn_e1deg + pe1u(ji,jj) = ra * rad * COS( rad * pphiu(ji,jj) ) * rn_e1deg + pe1v(ji,jj) = ra * rad * COS( rad * pphiv(ji,jj) ) * rn_e1deg + pe1f(ji,jj) = ra * rad * COS( rad * pphif(ji,jj) ) * rn_e1deg + ! ! e2 (meridional) + pe2t(ji,jj) = ra * rad * rn_e2deg + pe2u(ji,jj) = ra * rad * rn_e2deg + pe2v(ji,jj) = ra * rad * rn_e2deg + pe2f(ji,jj) = ra * rad * rn_e2deg + END DO + END DO + ! ! 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 = 0 ! Coriolis parameter calculated on the sphere + pff_f(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that + pff_t(:,:) = 0._wp ! require an initialization of INTENT(out) arguments + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8ef347986262b9b0cb551b796af0544263b561a3 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,69 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === ISOMIP configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-11 (S. Flavoni) Original code + !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here ISOMIP configuration + !! + !! ** Method : - set temperature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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 + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : ISOMIP configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant salinity and temperature. ' + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + pssh(:,:) = 0._wp + ! + ! ! T & S profiles + pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields + pts(:,:,:,jp_sal) = 34.4 * ptmask(:,:,:) + ! + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0738cfee49d0726c2891b411139b1ed9c89337d6 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,109 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === ISOMIP configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code + !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 ! i- & j-indices of the local domain + USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_e1deg, rn_e2deg !: horizontal resolution [degrees] + REAL(wp), PUBLIC :: rn_e3 !: vertical resolution [m] + + REAL(wp), PARAMETER, PUBLIC :: rbathy = 900._wp !: depth of the seafloor [m] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 ISOMIP 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/ ln_zco, ln_zps, ln_sco, rn_e1deg, rn_e2deg, rn_e3 + !!---------------------------------------------------------------------- + ! + 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 = 'ISOMIP' ! name & resolution (not used) + kk_cfg = INT( rn_e3 ) + ! + ! Global Domain size: ISOMIP domain is 15° x 10° x 900 m + kpi = INT( 15.0 / rn_e1deg ) + 2 ! add 2 for t-point in the east & west coasts + kpj = INT( 10.0 / rn_e2deg ) + 2 ! - - north & south - + kpk = INT( rbathy / rn_e3 ) + 1 ! add 1 for t-point in the seafloor + ! + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! ISOMIP configuration : close basin + ! + ! ! 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 : ISOMIP test case' + WRITE(numout,*) ' type of vertical coordinate : ' + WRITE(numout,*) ' z-coordinate flag ln_zco = ', ln_zco + WRITE(numout,*) ' z-partial-step coordinate flag ln_zps = ', ln_zps + WRITE(numout,*) ' s-coordinate flag ln_sco = ', ln_sco + WRITE(numout,*) ' resolution' + WRITE(numout,*) ' zonal resolution rn_e1deg = ', rn_e1deg, ' degrees' + WRITE(numout,*) ' meridional resolution rn_e1deg = ', rn_e1deg, ' degrees' + WRITE(numout,*) ' vertical resolution rn_e3 = ', rn_e3 , ' meters' + WRITE(numout,*) ' ISOMIP domain = 15° x 10° x 900 m' + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' ISOMIP : closed basin jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e67b6b4f140d59f615984a4605830caedb5527e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,88 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === ISOMIP configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !! ! 2017-02 (P. Mathiot, S. Flavoni) adapt code to ISOMIP case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in ISOMIP 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: ice 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 ISOMIP case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : ISOMIP 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 + ! + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a498fb61a8a8b8faa21df055f34a0739b3fade5d --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,250 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === ISOMIP case === + !! + !! user defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !! zgr_z1d : reference 1D z-coordinate + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce , ONLY: mj0 , mj1 , nimpp , njmpp ! ocean space and time domain + USE dom_oce , ONLY: glamt , gphit ! ocean space and time domain + USE usrdef_nam ! User defined : namelist variables + ! + 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 + + PUBLIC usr_def_zgr ! called by domzgr.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_zgr.F90 10491 2019-01-09 19:53:37Z mathiot $ + !! 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(in ) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags ( read in namusr_def ) + 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 :: ji , jj, jk ! dummy indices + INTEGER :: ij0, ij1 ! dummy indices + INTEGER :: ik ! local integers + REAL(wp) :: zfact, z1_jpkm1 ! local scalar + REAL(wp) :: ze3min, zdepth ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zht , zhu ! bottom depth + REAL(wp), DIMENSION(jpi,jpj) :: zhisf, zhisfu ! top depth + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2d workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : ISOMIP configuration (z(ps)- or s-coordinate closed box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ! set in usrdef_nam.F90 by reading the namusr_def namelist except for ISF + ld_isfcav = .TRUE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== isfdraft ==! + ! + ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0 + z2d(:,:) = 1._wp ! surface ocean is the 1st level + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90) + zmsk(:,:) = NINT( z2d(:,:) ) + ! + ! + zht (:,:) = rbathy + zhisf(:,:) = 200._wp + ij0 = 1 ; ij1 = 40 + DO jj = mj0(ij0), mj1(ij1) + zhisf(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp + END DO + zhisf(:,:) = zhisf(:,:) * zmsk(:,:) + ! + CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + ! !== top masked level bathymetry ==! (all coordinates) + ! + IF ( ld_zps ) THEN !== zps-coordinate ==! (partial bottom-steps) + ! + ze3min = 0.1_wp * rn_e3 + IF(lwp) WRITE(numout,*) ' minimum thickness of the partial cells = 10 % of e3 = ', ze3min + ! + ! !* bottom ocean compute from the depth of grid-points + k_bot(:,:) = jpkm1 + DO jk = jpkm1, 1, -1 + WHERE( zht(:,:) < pdepw_1d(jk) + ze3min ) k_bot(:,:) = jk-1 + END DO + ! !* top ocean compute from the depth of grid-points + k_top(:,:) = 1 ! + DO jk = 2, jpkm1 + zdepth = pdepw_1d(jk+1) - ze3min + WHERE( zhisf(:,:) > 0.0 .AND. zhisf(:,:) >= zdepth ) k_top(:,:) = (jk + 1) + END DO + ! + ! !* vertical coordinate system + DO jk = 1, jpk ! initialization to the reference z-coordinate + 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 + DO jj = 1, jpj ! top scale factors and depth at T- and W-points + DO ji = 1, jpi + ik = k_top(ji,jj) + IF ( ik > 2 ) THEN + ! pdeptw at the interface + pdepw(ji,jj,ik ) = MAX( zhisf(ji,jj) , pdepw(ji,jj,ik) ) + ! e3t in both side of the interface + pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik) + ! pdept in both side of the interface (from previous e3t) + pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp + pdept(ji,jj,ik-1) = pdepw(ji,jj,ik ) - pe3t (ji,jj,ik ) * 0.5_wp + ! pe3w on both side of the interface + pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik ) + pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1) + ! e3t into the ice shelf + pe3t (ji,jj,ik-1) = pdepw(ji,jj,ik ) - pdepw(ji,jj,ik-1) + pe3w (ji,jj,ik-1) = pdept(ji,jj,ik-1) - pdept(ji,jj,ik-2) + END IF + END DO + END DO + DO jj = 1, jpj ! bottom scale factors and depth at T- and W-points + DO ji = 1, jpi + ik = k_bot(ji,jj) + pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) ) + pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik) + pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik ) + ! + pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp + pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp + pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) + END DO + END DO + ! ! bottom scale factors and depth at U-, V-, UW and VW-points + pe3u (:,:,:) = pe3t(:,:,:) + pe3uw(:,:,:) = pe3w(:,:,:) + DO jk = 1, jpk ! Computed as the minimum of neighbooring scale factors + DO jj = 1, jpjm1 + DO ji = 1, jpi + pe3v (ji,jj,jk) = MIN( pe3t(ji,jj,jk), pe3t(ji,jj+1,jk) ) + pe3vw(ji,jj,jk) = MIN( pe3w(ji,jj,jk), pe3w(ji,jj+1,jk) ) + pe3f (ji,jj,jk) = pe3v(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'usrdef_zgr', pe3v , 'V', 1._wp ) ; CALL lbc_lnk( 'usrdef_zgr', pe3vw, 'V', 1._wp ) + CALL lbc_lnk( 'usrdef_zgr', pe3f , 'F', 1._wp ) + DO jk = 1, jpk + ! set to z-scale factor if zero (i.e. along closed boundaries) because of lbclnk + WHERE( pe3u (:,:,jk) == 0._wp ) pe3u (:,:,jk) = pe3t_1d(jk) + WHERE( pe3v (:,:,jk) == 0._wp ) pe3v (:,:,jk) = pe3t_1d(jk) + WHERE( pe3f (:,:,jk) == 0._wp ) pe3f (:,:,jk) = pe3t_1d(jk) + WHERE( pe3uw(:,:,jk) == 0._wp ) pe3uw(:,:,jk) = pe3w_1d(jk) + WHERE( pe3vw(:,:,jk) == 0._wp ) pe3vw(:,:,jk) = pe3w_1d(jk) + END DO + ! + ENDIF + ! + END SUBROUTINE usr_def_zgr + + + SUBROUTINE zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z1d *** + !! + !! ** Purpose : set the 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 ] + !! + !! === Here constant vertical resolution === + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalar + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z1d : Reference vertical z-coordinates: uniform dz = ', rn_e3 + WRITE(numout,*) ' ~~~~~~~' + ENDIF + ! + ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function + ! ---------------------- + DO jk = 1, jpk + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = rn_e3 * REAL( jk-1 , wp ) + pdept_1d(jk) = rn_e3 * ( REAL( jk-1 , wp ) + 0.5_wp ) + pe3w_1d (jk) = rn_e3 + pe3t_1d (jk) = rn_e3 + END DO + ! + 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_z1d + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/ISOMIP/cpp_ISOMIP.fcm b/V4.0/nemo_sources/tests/ISOMIP/cpp_ISOMIP.fcm new file mode 100644 index 0000000000000000000000000000000000000000..904e97e07b64bb4e7bde3223b041c6099aa69141 --- /dev/null +++ b/V4.0/nemo_sources/tests/ISOMIP/cpp_ISOMIP.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_iomput key_mpp_mpi diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..86c4d0ebb280478f53f878aff8769a172a9cc6d5 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,38 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@" sync_freq="10d" min_digits="4"> + <file_group id="30mi" output_freq="30mi" output_level="10" enabled=".TRUE." > <!-- 5d files --> + + <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="e3t" name="e3t_inst" long_name="instantaneous T-cell thickness" operation="instant" /> + <field field_ref="toce" name="thetao_inst" long_name="instantaneous sea water potential temperature" operation="instant" /> + <field field_ref="ssh" name="ssh_inst" long_name="instantaneous sea surface height above geoid" operation="instant" /> + </file> + + <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="e3u" name="e3u_inst" long_name="instantaneous U-cell thickness" operation="instant" /> + <field field_ref="uoce" name="uo_inst" long_name="instantaneous sea water x velocity" operation="instant" /> + </file> + + <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="e3v" name="e3v_inst" long_name="instantaneous V-cell thickness" operation="instant" /> + <field field_ref="voce" name="vo_inst" long_name="instantaneous sea water y velocity" operation="instant" /> + </file> + + <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > + <field field_ref="e3w" name="e3w_inst" long_name="instantaneous W-cell thickness" operation="instant" /> + <field field_ref="woce" name="wo_inst" long_name="instantaneous ocean vertical velocity" operation="instant" /> + </file> + + </file_group> + + </file_definition> + + diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..b49154cddcc7413a89873e4d3b30c67fed097ba6 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/iodef.xml @@ -0,0 +1,26 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">true</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg new file mode 100644 index 0000000000000000000000000000000000000000..4161993e32c7ada8e64af855dfe08b8d0f99ee7a --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg @@ -0,0 +1,200 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_flux_cen2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! vector form (T) or flux form (F) + nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .true. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..5ae8dd6d21c0fb30ae10ef1f72d2703ec32fe3ad --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg @@ -0,0 +1,312 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! LOCK EXCHANGE 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!!====================================================================== +!! *** 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 +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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 physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! 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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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 & Benchmark +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg new file mode 100644 index 0000000000000000000000000000000000000000..8edd1c2f5fc1c88aa05a5fb8f88a36c3957cb377 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_vect_eenH" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) + nn_dynkeg = 1 ! 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg new file mode 100644 index 0000000000000000000000000000000000000000..0c15c423becce18cdef8c77e495c3b56dba2df71 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg @@ -0,0 +1,198 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_vect_een" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg new file mode 100644 index 0000000000000000000000000000000000000000..0eabfa89f6493ae11565ca140e362c5601dfa400 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg @@ -0,0 +1,198 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_vect_ene" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .true. ! 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 = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg new file mode 100644 index 0000000000000000000000000000000000000000..7d1cb5bf14cc356032e42ecd84238e4966a46165 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT2_vect_ens" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg new file mode 100644 index 0000000000000000000000000000000000000000..037301e8916b4e376b16317d92e5e22d720051cc --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_flux_cen2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! vector form (T) or flux form (F) + nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .true. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..be05eddb05e79c88e97256012c76a14d043ca261 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! 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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg new file mode 100644 index 0000000000000000000000000000000000000000..4f3dfc81052ec43fa8283c5742e9c73ad143206c --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg @@ -0,0 +1,198 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_vect_eenH" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) + nn_dynkeg = 1 ! 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg new file mode 100644 index 0000000000000000000000000000000000000000..a4d2b7ae1dc9ba258fbb1eb7ca3d1462f1edf34b --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_vect_een" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg new file mode 100644 index 0000000000000000000000000000000000000000..96d3510ce96bd544b07a827111d60a5b0459fd77 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg @@ -0,0 +1,200 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_vect_ene" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .true. ! 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 = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg new file mode 100644 index 0000000000000000000000000000000000000000..af3273d65c9f69a16eb1dfdad4cb0653ddc48ee1 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg @@ -0,0 +1,199 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! LOCK_EXCHANGE user defined namelist +!----------------------------------------------------------------------- + rn_dx = 500. ! horizontal resolution in meters + rn_dz = 1. ! vertical resolution in meters +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "LOCK_FCT4_vect_ens" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 61200 ! for 17h of simulation (=61200 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 61200 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 61200 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .false. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + rn_isfhmin = 0.00 ! treshold (m) to discriminate grounding ice to floating ice + ! + rn_rdt = 1. ! 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_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! S-EOS coefficients (nn_eos=1): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + rn_b0 = 0. ! saline expension coefficient (nn_eos= 1) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 4.e-5 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 500. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_cfg new file mode 120000 index 0000000000000000000000000000000000000000..00c1623ede0b8373c9560b0cbe6e90913b1af0b9 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_cfg @@ -0,0 +1 @@ +namelist_FCT2_flux_ubs_cfg \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..cc5ba73359f076d8ada4157e8a552adc1ce2a49f --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,109 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === LOCK_EXCHANGE configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for LOCK_EXCHANGE configuration + !!---------------------------------------------------------------------- + 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, ONLY: rn_dx ! horizontal resolution in meters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! LOCK_EXCHANGE configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zfact ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : LOCK_EXCHANGE configuration bassin' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ uniform grid spacing WITHOUT Coriolis force (f=0)' + ! + ! !== grid point position ==! (in kilometers) + zfact = rn_dx * 1.e-3 ! conversion in km + DO jj = 1, jpj + DO ji = 1, jpi ! longitude + plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) ) + plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) ) + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + ! ! latitude + pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) + pphiu(ji,jj) = pphit(ji,jj) + pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) ) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! !== Horizontal scale factors ==! (in meters) + pe1t(:,:) = rn_dx ; pe2t(:,:) = rn_dx + pe1u(:,:) = rn_dx ; pe2u(:,:) = rn_dx + pe1v(:,:) = rn_dx ; pe2v(:,:) = rn_dx + pe1f(:,:) = rn_dx ; pe2f(:,:) = rn_dx + ! + ! ! 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 Coriolis parameter afterward + ! + pff_f(:,:) = 0._wp ! here No earth rotation: f=0 + pff_t(:,:) = 0._wp + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f692029cfb67251d02fba9e4a1e6fb8acb0e4785 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,81 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === LOCK_EXCHANGE configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) 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 + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here LOCK_EXCHANGE configuration + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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] + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : LOCK_EXCHANGE configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant salinity (not used as rho=F(T) ' + IF(lwp) WRITE(numout,*) ' and a vertical density front with a 5 kg/m3 difference located at glam=32km' + IF(lwp) WRITE(numout,*) ' (i.e. a temperature difference of 25 degrees with rn_a0 = 0.2' + ! + ! 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 + ! + 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) = 30._wp * ptmask(:,:,:) + DO jk = 1, jpkm1 + WHERE( glamt(:,:) <= zdam ) pts(:,:,jk,jp_tem) = 5._wp * ptmask(:,:,jk) + END DO + ! + pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) + ! + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..be4cf5aadc926c7316c9f37d13bfe4493a6f8d54 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,99 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === LOCK_EXCHANGE configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dz ! resolution in meters defining the vertical domain size + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 LOCK_EXCHANGE 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/ rn_dx, rn_dz + !!---------------------------------------------------------------------- + ! + 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 = 'LOCK_EXCHANGE' ! name & resolution (not used) + kk_cfg = INT( rn_dx ) + ! + ! Global Domain size: LOCK_EXCHANGE domain is 64 km x 3 grid-points x 20 m + kpi = INT( 64.e3 / rn_dx ) + 2 + kpj = 3 + kpk = INT( 20. / rn_dz ) + 1 + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! LOCK_EXCHANGE 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 : LOCK_EXCHANGE test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters' + WRITE(numout,*) ' LOCK_EXCHANGE domain = 64 km x 3 grid-points x 20 m' + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' closed jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9ec7db93bec53ec2ae5bd3f527ddfee9d24e201d --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,87 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === LOCK_EXCHANGE configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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: ice 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 LOCK_EXCHANGE case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : LOCK_EXCHANGE 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 + ! + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fc6de8a5055eb319ba93e8ab72c8b68cfdec0a3e --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,168 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === LOCK_EXCHANGE case === + !! + !! Ocean domain : user defined vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !! zgr_z1d : reference 1D z-coordinate + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE usrdef_nam ! User defined : namelist variables + ! + 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 + + PUBLIC usr_def_zgr ! called by domzgr.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_zgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw, & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: 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 :: jk ! dummy indices + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : LOCK_EXCHANGE configuration (z-coordinate closed box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate ==>>> here LOCK EXCHANGE : flat bottom always + ! --------------------------- + ld_zco = .TRUE. ! z-partial-step coordinate + ld_zps = .FALSE. ! z-partial-step coordinate + ld_sco = .FALSE. ! s-coordinate + ld_isfcav = .FALSE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! + ! flat bassin (20m deep and 64000m wide, set through the jpk and jpi (see userdef_nam.F90)) + CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + ! + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0 + z2d(:,:) = 1._wp ! surface ocean is the 1st level + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90) + k_top(:,:) = NINT( z2d(:,:) ) + ! + ! + ! !== z-coordinate ==! (step-like topography) + ! + ! !* bottom ocean compute from the depth of grid-points + k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask + ! !* horizontally uniform coordinate (reference z-co everywhere) + 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 usr_def_zgr + + + SUBROUTINE zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z1d *** + !! + !! ** Purpose : set the 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 ] + !! + !! === Here constant vertical resolution === + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalar + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z1d : Reference vertical z-coordinates: uniform dz = ', rn_dz + WRITE(numout,*) ' ~~~~~~~' + ENDIF + ! + ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function + ! ---------------------- + DO jk = 1, jpk + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = rn_dz * REAL( jk-1 , wp ) + pdept_1d(jk) = rn_dz * ( REAL( jk-1 , wp ) + 0.5_wp ) + pe3w_1d (jk) = rn_dz + pe3t_1d (jk) = rn_dz + END DO + ! + 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_z1d + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm new file mode 100644 index 0000000000000000000000000000000000000000..904e97e07b64bb4e7bde3223b041c6099aa69141 --- /dev/null +++ b/V4.0/nemo_sources/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_iomput key_mpp_mpi diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..4dbf60e29549427c526d316f9c52dd36f61480f6 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,36 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@" sync_freq="10d" min_digits="4"> + <file_group id="30mi" output_freq="30mi" output_level="10" enabled=".TRUE." > <!-- 5d files --> + + <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="e3t" name="e3t_inst" long_name="instantaneous T-cell thickness" operation="instant" /> + <field field_ref="toce" name="thetao_inst" long_name="instantaneous sea water potential temperature" operation="instant" /> + <field field_ref="ssh" name="ssh_inst" long_name="instantaneous sea surface height above geoid" operation="instant" /> + </file> + + <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="e3u" name="e3u_inst" long_name="instantaneous U-cell thickness" operation="instant" /> + <field field_ref="uoce" name="uo_inst" long_name="instantaneous sea water x velocity" operation="instant" /> + </file> + + <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="e3v" name="e3v_inst" long_name="instantaneous V-cell thickness" operation="instant" /> + <field field_ref="voce" name="vo_inst" long_name="instantaneous sea water y velocity" operation="instant" /> + </file> + + <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > + <field field_ref="e3w" name="e3w_inst" long_name="instantaneous W-cell thickness" operation="instant" /> + <field field_ref="woce" name="wo_inst" long_name="instantaneous ocean vertical velocity" operation="instant" /> + </file> + + </file_group> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..b49154cddcc7413a89873e4d3b30c67fed097ba6 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/iodef.xml @@ -0,0 +1,26 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">true</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_cfg new file mode 120000 index 0000000000000000000000000000000000000000..00b917418246d2ae7206efd9fb0fc8860f2e3943 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_cfg @@ -0,0 +1 @@ +namelist_zps_FCT4_flux_ubs_cfg \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg new file mode 100644 index 0000000000000000000000000000000000000000..5296b5cb396163efa72c35fc1d8dba8945af8977 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg @@ -0,0 +1,223 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .false. ! z-partial-step coordinate + ln_sco = .true. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_sco_FCT2_flux_cen-ahm1000" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + !nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 6120 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 6120 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&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 (T) or flux form (F) + nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .true. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&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 = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! 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 + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..320c813fdf51dc6f0cadd2195c9fb4e4112d1de5 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg @@ -0,0 +1,223 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .false. ! z-partial-step coordinate + ln_sco = .true. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_sco_FCT2_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + !nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 1080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 1080 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&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 (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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg new file mode 100644 index 0000000000000000000000000000000000000000..2fda887c50bb340e62c55e1ee323642da4484f2e --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg @@ -0,0 +1,223 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .false. ! z-partial-step coordinate + ln_sco = .true. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_sco_FCT4_flux_cen-ahm1000" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + !nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 6120 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 6120 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&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 (T) or flux form (F) + nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .true. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&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 = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! 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 + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0e ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..a503cde01915c7cfa469f9fccafe718b395410f7 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg @@ -0,0 +1,223 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .false. ! z-partial-step coordinate + ln_sco = .true. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_sco_FCT4_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + !nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 1080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 1080 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&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 (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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..8bbe45dbbf12a466cbb1cfb0e7bee3cd546825aa --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg @@ -0,0 +1,224 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .true. ! z-partial-step coordinate + ln_sco = .false. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_zps_FCT2_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + !nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 1080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 1080 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! 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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&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 (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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg new file mode 100644 index 0000000000000000000000000000000000000000..ebe14c861a500765b108368ac029b7393bb0b048 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg @@ -0,0 +1,328 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! OVERFLOW 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .true. ! z-partial-step coordinate + ln_sco = .false. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_zps_FCT4_flux_ubs" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 6120 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 6120 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!!====================================================================== +!! *** 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 +/ +!!====================================================================== +!! *** 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 = .true. ! 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 +/ +!!====================================================================== +!! 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_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ +!!====================================================================== +!! *** 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: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&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 (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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .true. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! 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 = .true. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg new file mode 100644 index 0000000000000000000000000000000000000000..79070386d406c49c12c18dbcb34ff392fc352071 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg @@ -0,0 +1,223 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : OVERFLOW configuration +!----------------------------------------------------------------------- + ! ! type of vertical coordinate + ln_zco = .false. ! z-coordinate + ln_zps = .true. ! z-partial-step coordinate + ln_sco = .false. ! s-coordinate + rn_dx = 1000. ! horizontal resolution [meters] + rn_dz = 20. ! vertical resolution [meters] +/ +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "OVF_zps_FCT4_vect_een" ! experience name + nn_it000 = 1 ! first time step + !nn_itend = 6120 ! here 17h of simulation (=6120 time-step) + nn_itend = 5760 ! here 16h of simulation (=5760 time-step) abort after 5802 for zps: pb of physics conditions + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 1080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 1080 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + rn_rdt = 10. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.1 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 0. ! free slip +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!!====================================================================== +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_isfcav=T) +!! namdrg_bot bottom friction +!! 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 = .true. ! 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 +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + 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 = .true. ! FCT scheme + nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 4 ! =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 +!----------------------------------------------------------------------- + ! ! Operator type: both false = No lateral diffusion + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ + +!!====================================================================== +!! *** Dynamics namelists *** !! +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + 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 +/ +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: zstar) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! 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: + nn_baro = 1 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&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 = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 1000. ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ + +!!====================================================================== +!! vertical physics namelists !! +!!====================================================================== +!----------------------------------------------------------------------- +&namzdf ! vertical physics (default: NO selection) +!----------------------------------------------------------------------- + ! ! type of vertical closure (required) + ln_zdfcst = .true. ! 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) + ! + ! ! 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.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.0 ! 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) +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4039de6350e8d89011faf49e621bd18d5e64c1a8 --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,109 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === OVERFLOW configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for OVERFLOW configuration + !!---------------------------------------------------------------------- + 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, ONLY: rn_dx ! horizontal resolution in meters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! OVERFLOW configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zfact ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : OVERFLOW configuration bassin' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ uniform grid spacing WITHOUT Coriolis force (f=0)' + ! + ! !== grid point position ==! (in kilometers) + zfact = rn_dx * 1.e-3 ! conversion in km + DO jj = 1, jpj + DO ji = 1, jpi ! longitude + plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) ) + plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) ) + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + ! ! latitude + pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) + pphiu(ji,jj) = pphit(ji,jj) + pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) ) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! !== Horizontal scale factors ==! (in meters) + pe1t(:,:) = rn_dx ; pe2t(:,:) = rn_dx + pe1u(:,:) = rn_dx ; pe2u(:,:) = rn_dx + pe1v(:,:) = rn_dx ; pe2v(:,:) = rn_dx + pe1f(:,:) = rn_dx ; pe2f(:,:) = rn_dx + ! + ! ! 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 Coriolis parameter afterward + ! + pff_f(:,:) = 0._wp ! here No earth rotation: f=0 + pff_t(:,:) = 0._wp + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7c1cbdb49f454a8bd11e898c3f699d8a5c16e18b --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,81 @@ +MODULE usrdef_istate + !!============================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === OVERFLOW configuration === + !! + !! User defined : set the initial state of a user configuration + !!============================================================================== + !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) 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 + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here OVERFLOW configuration + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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] + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : OVERFLOW configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant salinity (not used as rho=F(T) ' + IF(lwp) WRITE(numout,*) ' and a vertical density front with a 2 kg/m3 difference located at glam=20km' + IF(lwp) WRITE(numout,*) ' (i.e. a temperature difference of 10 degrees with rn_a0 = 0.2' + ! + ! rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) + ! rho = rau0 - rn_a0 * (T-10) + ! delta_T = 10 degrees ==>> delta_rho = 10 * rn_a0 = 2 kg/m3 + ! + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + pssh(:,:) = 0._wp + ! + ! ! T & S profiles + zdam = 20. ! density front position in kilometers + pts(:,:,:,jp_tem) = 20._wp * ptmask(:,:,:) + DO jk = 1, jpkm1 + WHERE( glamt(:,:) <= zdam ) pts(:,:,jk,jp_tem) = 10._wp * ptmask(:,:,jk) + END DO + ! + pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) + ! + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..455adbc366cf4b0e5207091b93e85e4ea5935c9d --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,103 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === OVERFLOW configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 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 ! i- & j-indices of the local domain + USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dz ! resolution in meters defining the vertical domain size + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 OVERFLOW 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/ ln_zco, ln_zps, ln_sco, rn_dx, rn_dz + !!---------------------------------------------------------------------- + ! + 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 = 'OVERFLOW' ! name & resolution (not used) + kk_cfg = INT( rn_dx ) + ! + ! Global Domain size: OVERFLOW domain is 200 km x 3 grid-points x 2000 m + kpi = INT( 200.e3 / rn_dx ) + 2 + kpj = 3 + kpk = INT( 2000. / rn_dz ) + 1 + ! + ! ! control print + WRITE(numout,*) ' ' + WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namusr_def : OVERFLOW test case' + WRITE(numout,*) ' type of vertical coordinate : ' + WRITE(numout,*) ' z-coordinate flag ln_zco = ', ln_zco + WRITE(numout,*) ' z-partial-step coordinate flag ln_zps = ', ln_zps + WRITE(numout,*) ' s-coordinate flag ln_sco = ', ln_sco + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters' + WRITE(numout,*) ' OVERFLOW domain = 200 km x 3 grid-points x 2000 m' + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + ! + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! OVERFLOW configuration : close basin + ! + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' OVERFLOW : closed basin jperio = ', kperio + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ea23e866ed264439068a41f7a1a59c0472f927aa --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,87 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === OVERFLOW configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in OVERFLOW 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: ice 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 OVERFLOW case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : OVERFLOW 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 + ! + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..eba531eb4d4d042afeef87b88866dd48109007be --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,265 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === OVERFLOW case === + !! + !! user defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !! zgr_z1d : reference 1D z-coordinate + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce , ONLY: mi0, mi1, nimpp, njmpp ! ocean space and time domain + USE dom_oce , ONLY: glamt ! ocean space and time domain + USE usrdef_nam ! User defined : namelist variables + ! + 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 + + PUBLIC usr_def_zgr ! called by domzgr.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_zgr.F90 11077 2019-06-05 14:13:02Z jchanut $ + !! 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(in ) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags ( read in namusr_def ) + 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 :: ji, jj, jk ! dummy indices + INTEGER :: ik ! local integers + REAL(wp) :: zfact, z1_jpkm1 ! local scalar + REAL(wp) :: ze3min ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zht, zhu, z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : OVERFLOW configuration (z(ps)- or s-coordinate closed box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ! already set in usrdef_nam.F90 by reading the namusr_def namelist except for ISF + ld_isfcav = .FALSE. + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! + ! western continental shelf (500m deep) and eastern deep ocean (2000m deep) + ! (set through the jpk and jpi (see userdef_nam.F90)) + ! with a hyperbolic tangent transition centered at 40km + ! NB: here glamt is in kilometers + ! + zht(:,:) = + ( 500. + 0.5 * 1500. * ( 1.0 + tanh( (glamt(:,:) - 40.) / 7. ) ) ) + ! + ! at u-point: averaging zht + DO ji = 1, jpim1 + zhu(ji,:) = 0.5_wp * ( zht(ji,:) + zht(ji+1,:) ) + END DO + CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrouding grid-points + ! ! ==>>> set by hand non-zero value on first/last columns & rows + DO ji = mi0(1), mi1(1) ! first row of global domain only + zhu(ji,2) = zht(ji,2) + END DO + DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only + zhu(ji,2) = zht(ji,2) + END DO + zhu(:,1) = zhu(:,2) + zhu(:,3) = zhu(:,2) + ! + CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + ! + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0 + z2d(:,:) = 1._wp ! surface ocean is the 1st level + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90) + k_top(:,:) = NINT( z2d(:,:) ) + ! + ! + ! + IF ( ld_sco ) THEN !== s-coordinate ==! (terrain-following coordinate) + ! + k_bot(:,:) = jpkm1 * k_top(:,:) !* bottom ocean = jpk-1 (here use k_top as a land mask) + ! + ! !* terrain-following coordinate with e3.(k)=cst) + ! ! OVERFLOW case : identical with j-index (T=V, U=F) + z1_jpkm1 = 1._wp / REAL( jpkm1 , wp) + DO jk = 1, jpk + pdept(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp ) + pdepw(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk-1 , wp ) ) + pe3t (:,:,jk) = zht(:,:) * z1_jpkm1 + pe3u (:,:,jk) = zhu(:,:) * z1_jpkm1 + pe3v (:,:,jk) = zht(:,:) * z1_jpkm1 + pe3f (:,:,jk) = zhu(:,:) * z1_jpkm1 + pe3w (:,:,jk) = zht(:,:) * z1_jpkm1 + pe3uw(:,:,jk) = zhu(:,:) * z1_jpkm1 + pe3vw(:,:,jk) = zht(:,:) * z1_jpkm1 + END DO + ENDIF + ! + ! + IF ( ld_zco ) THEN !== z-coordinate ==! (step-like topography) + ! + ! !* bottom ocean compute from the depth of grid-points + k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask + DO jk = 1, jpkm1 + WHERE( pdept_1d(jk) < zht(:,:) .AND. zht(:,:) <= pdept_1d(jk+1) ) k_bot(:,:) = jk * k_top(:,:) + END DO + ! !* horizontally uniform coordinate (reference z-co everywhere) + 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 + ENDIF + ! + ! + IF ( ld_zps ) THEN !== zps-coordinate ==! (partial bottom-steps) + ! + ze3min = 0.1_wp * rn_dz + IF(lwp) WRITE(numout,*) ' minimum thickness of the partial cells = 10 % of e3 = ', ze3min + ! + ! + ! !* bottom ocean compute from the depth of grid-points + k_bot(:,:) = jpkm1 + DO jk = jpkm1, 1, -1 + WHERE( zht(:,:) < pdepw_1d(jk) + ze3min ) k_bot(:,:) = jk-1 + END DO + ! + ! !* vertical coordinate system + DO jk = 1, jpk ! initialization to the reference z-coordinate + 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 + DO jj = 1, jpj ! bottom scale factors and depth at T- and W-points + DO ji = 1, jpi + ik = k_bot(ji,jj) + pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) ) + pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik) + pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik ) + ! + pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp + pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp + pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) ! = pe3t (ji,jj,ik ) + END DO + END DO + ! ! bottom scale factors and depth at U-, V-, UW and VW-points + ! ! usually Computed as the minimum of neighbooring scale factors + pe3u (:,:,:) = pe3t(:,:,:) ! HERE OVERFLOW configuration : + pe3v (:,:,:) = pe3t(:,:,:) ! e3 increases with i-index and identical with j-index + pe3f (:,:,:) = pe3t(:,:,:) ! so e3 minimum of (i,i+1) points is (i) point + pe3uw(:,:,:) = pe3w(:,:,:) ! in j-direction e3v=e3t and e3f=e3v + pe3vw(:,:,:) = pe3w(:,:,:) ! ==>> no need of lbc_lnk calls + ! + ENDIF + ! + END SUBROUTINE usr_def_zgr + + + SUBROUTINE zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z1d *** + !! + !! ** Purpose : set the 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 ] + !! + !! === Here constant vertical resolution === + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalar + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z1d : Reference vertical z-coordinates: uniform dz = ', rn_dz + WRITE(numout,*) ' ~~~~~~~' + ENDIF + ! + ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function + ! ---------------------- + DO jk = 1, jpk + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = rn_dz * REAL( jk-1 , wp ) + pdept_1d(jk) = rn_dz * ( REAL( jk-1 , wp ) + 0.5_wp ) + pe3w_1d (jk) = rn_dz + pe3t_1d (jk) = rn_dz + END DO + ! + 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_z1d + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/OVERFLOW/cpp_OVERFLOW.fcm b/V4.0/nemo_sources/tests/OVERFLOW/cpp_OVERFLOW.fcm new file mode 100644 index 0000000000000000000000000000000000000000..547cb48ec7ce17d34d138b5fe3883ed8e9a0aa0a --- /dev/null +++ b/V4.0/nemo_sources/tests/OVERFLOW/cpp_OVERFLOW.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_mpp_mpi key_iomput diff --git a/V4.0/nemo_sources/tests/README.rst b/V4.0/nemo_sources/tests/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..eec436ebcf401d439a8b6ae4387c13bd532fb08f --- /dev/null +++ b/V4.0/nemo_sources/tests/README.rst @@ -0,0 +1,215 @@ +********************** +Explore the test cases +********************** + +.. todo:: + + CANAL animated gif is missing + +.. contents:: + :local: + :depth: 1 + +Installation +============ + +Download +-------- + +| The complete and up-to-date set of test cases is available on + :github:`NEMO test cases repository <NEMO-examples>`. +| Download it directly into the :file:`./tests` root directory with + +.. code-block:: console + + $ git clone http://github.com/NEMO-ocean/NEMO-examples + +Compilation +----------- + +The compilation of the test cases is very similar to +the manner the reference configurations are compiled. +If you are not familiar on how to compile NEMO, +it is first recomended to read :doc:`the instructions <install>`. + +| As the reference configurations are compiled with ``-r`` option, + test cases can be compiled by the use of :file:`makenemo` with ``-a`` option. +| Here an example to compile a copy named WAD2 of the wetting and drying test case (WAD): + +.. code-block:: console + + $ ./makenemo -n 'WAD2' -a 'WAD' -m 'my_arch' -j '4' + +Run and analysis +---------------- + +There no requirement of specific input file for the test_cases presented here. +The XIOS xml input files and namelist are already setup correctly. +For detailed description and Jupyter notebook, the reader is directed on +the :github:`NEMO test cases repository <NEMO-examples>` + +The description below is a brief advertisement of some test cases. + +List of test cases +================== + +BENCH +----- +| Benchmark configuration. Allow to run any configuration (including ORCA type or BDY) with idealized grid + and initial state so it does not need any input file other than the namelists. + As usual, all configuration changes can be done through the namelist. + We provide 3 example of namelist_cfg to mimic ORCA1, OR025 or ORCA12 configurations. + By default do not produce any output file. An extensive description of BENCH will be abailable in + Irrmann et al. 2021. + +ICE_AGRIF +--------- + +.. figure:: _static/ICE_AGRIF_UDIAG_43days_UM5.gif + :width: 200px + :align: left + + .. + +| This test case illustrates the advection of an ice patch across + an East/West and North/South periodic channel over a slab ocean (i.e. one ocean layer), + and with an AGRIF zoom (1:3) in the center. +| The purpose of this configuration is to + test the advection of the ice patch in and across the AGRIF boundary. + One can either impose ice velocities or ice-atm. + Stresses and let rheology define velocities (see :file:`README` for details) + +VORTEX +------ + +.. figure:: _static/VORTEX_anim.gif + :width: 200px + :align: right + + .. + +This test case illustrates the propagation of an anticyclonic eddy over a Beta plan and a flat bottom. +It is implemented here with an online refined subdomain (1:3) out of which the vortex propagates. +It serves as a benchmark for quantitative estimates of nesting errors as in :cite:`DEBREU2012`, +:cite:`PENVEN2006` or :cite:`SPALL1991`. + +The animation (sea level anomaly in meters) illustrates with +two 1:2 successively nested grids how the vortex smoothly propagates out of the refined grids. + +ISOMIP +------ + +.. figure:: _static/ISOMIP_moc.png + :width: 200px + :align: left + + .. + +| The purpose of this test case is to evaluate the impact of various schemes and new development with + the iceshelf cavities circulation and melt. + This configuration served as initial assesment of the ice shelf module in :cite:`LOSCH2008` and + :cite:`MATHIOT2017`. + The default setup is the one described |ISOMIP|_. +| The figure (meridional overturning circulation) illustrates + the circulation generated after 10000 days by the ice shelf melting (ice pump). + +.. |ISOMIP| replace:: here + +LOCK_EXCHANGE +------------- + +.. figure:: _static/LOCK-FCT4_flux_ubs.gif + :width: 200px + :align: right + + .. + +| The LOCK EXCHANGE experiment is a classical fluid dynamics experiment that has been adapted + by :cite:`HAIDVOGEL1999` for testing advection schemes in ocean circulation models. + It has been used by several authors including :cite:`BURCHARD2002` and :cite:`ILICAK2012`. + The LOCK EXCHANGE experiment can in particular illustrate + the impact of different choices of numerical schemes and/or subgrid closures on + spurious interior mixing. +| Here the animation of the LOCK_EXCHANGE test case using + the advection scheme FCT4 (forth order) for tracer and ubs for dynamics. + +OVERFLOW +-------- + +.. figure:: _static/OVF-sco_FCT4_flux_cen-ahm1000.gif + :width: 200px + :align: left + + .. + +| The OVERFLOW experiment illustrates the impact of different choices of numerical schemes and/or + subgrid closures on spurious interior mixing close to bottom topography. + The OVERFLOW experiment is adapted from the non-rotating overflow configuration described in + :cite:`HAIDVOGEL1999` and further used by :cite:`ILICAK2012`. + Here we can assess the behaviour of the second-order tracer advection scheme FCT2 and + forth-order FCT4, z-coordinate and sigma coordinate (...). +| Here the animation of the OVERFLOW test case in sigma coordinate with + the forth-order advection scheme FCT4. + +WAD +--- + +.. figure:: _static/wad_testcase_7.gif + :width: 200px + :align: right + + .. + +| A set of simple closed basin geometries for testing the Wetting and drying capabilities. + Examples range from a closed channel with EW linear bottom slope to + a parabolic EW channel with a Gaussian ridge. +| Here the animation of the test case 7. + This test case is a simple linear slope with a mid-depth shelf with + an open boundary forced with a sinusoidally varying ssh. + This test case has been introduced to emulate a typical coastal application with + a tidally forced open boundary with an adverse SSH gradient that, + when released, creates a surge up the slope. + The parameters are chosen such that + the surge rises above sea-level before falling back and oscillating towards an equilibrium position. + +CANAL +----- + +.. figure:: _static/CANAL_image.gif + :width: 200px + :align: left + + .. + +East-west periodic canal of variable size with several initial states and +associated geostrophic currents (zonal jets or vortex). + +ICE_ADV2D +--------- + +| This test case illustrates the advection of an ice patch across + an East/West and North/South periodic channel over a slab ocean (i.e. one ocean layer). + The configuration is similar to ICE_AGRIF, except for the AGRIF zoom. +| The purpose of this configuration is to test the advection schemes available in the sea-ice code + (for now, Prather and Ultimate-Macho from 1st to 5th order), + especially the occurence of overshoots in ice thickness + +ICE_ADV1D +--------- + +| This experiment is the classical :cite:`SCHAR1996` test case , + which has been used in :cite:`LIPSCOMB2004`, and in which very specific shapes of ice concentration, + thickness and volume converge toward the center of a basin. + Convergence is unidirectional (in x) while fields are homogeneous in y. +| The purpose of this configuration is to + test the caracteristics of advection schemes available in the sea-ice code + (for now, Prather and Ultimate-Macho from 1st to 5th order), + especially the constitency between concentration, thickness and volume, + and the preservation of initial shapes. + +.. rubric:: References + +.. bibliography:: tests.bib + :all: + :style: unsrt + :labelprefix: T diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_context_nemo.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..46789362fe2177914539d9c0a0dbb30b7a466267 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="1_nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_cfg b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..fdb96ff17597062b65c589b981cbbb4782367d6b --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_cfg @@ -0,0 +1,307 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! VORTEX 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : VORTEX configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + rn_dx = 30000. ! x horizontal resolution [meters] + rn_dy = 30000. ! y horizontal resolution [meters] + rn_dz = 500. ! z vertical resolution [meters] + rn_ppgphi0 = 38.5 ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "VORTEX" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 18000 ! last time step + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 99999 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 99999 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_rdt = 480. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.05 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- + ln_spc_dyn = .true. ! use 0 as special value for dynamics + rn_sponge_tra = 800. ! coefficient for tracer sponge layer [m2/s] + rn_sponge_dyn = 800. ! coefficient for dynamics sponge layer [m2/s] + ln_chk_bathy = .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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + 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 = .true. ! 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 = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ +!!====================================================================== +!! *** 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. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! 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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: OFF) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: OFF) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. + ln_dynspg_ts = .true. ! 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 = .false. ! Number of sub-step defined from: + nn_baro = 24 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 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 = 30.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_ref b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/1_namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/AGRIF_FixedGrids.in b/V4.0/nemo_sources/tests/VORTEX/EXPREF/AGRIF_FixedGrids.in new file mode 100644 index 0000000000000000000000000000000000000000..9dada0540dd633d3d30189ce81773686c8a5cb26 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/AGRIF_FixedGrids.in @@ -0,0 +1,3 @@ +1 +19 38 19 38 3 3 3 +0 diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..8fb39dfca7d8b4ed54c11f8bcee8a53795cea6e3 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,36 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@" sync_freq="10d" min_digits="4"> + <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE." > <!-- 5d files --> + + <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="e3t" name="e3t_inst" long_name="instantaneous T-cell thickness" operation="instant" /> + <field field_ref="toce" name="thetao_inst" long_name="instantaneous sea water potential temperature" operation="instant" /> + <field field_ref="ssh" name="ssh_inst" long_name="instantaneous sea surface height above geoid" operation="instant" /> + </file> + + <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="e3u" name="e3u_inst" long_name="instantaneous U-cell thickness" operation="instant" /> + <field field_ref="uoce" name="uo_inst" long_name="instantaneous sea water x velocity" operation="instant" /> + </file> + + <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="e3v" name="e3v_inst" long_name="instantaneous V-cell thickness" operation="instant" /> + <field field_ref="voce" name="vo_inst" long_name="instantaneous sea water y velocity" operation="instant" /> + </file> + + <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > + <field field_ref="e3w" name="e3w_inst" long_name="instantaneous W-cell thickness" operation="instant" /> + <field field_ref="woce" name="wo_inst" long_name="instantaneous ocean vertical velocity" operation="instant" /> + </file> + + </file_group> + + </file_definition> diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/VORTEX/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..4b391895cc763ff46811cbbd2cd61cba0b86758a --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/iodef.xml @@ -0,0 +1,26 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">false</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + <context id="1_nemo" src="./1_context_nemo.xml"/> <!-- NEMO --> +</simulation> diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..117ccf5d8075ac521b75f539641307e83ec74ba5 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_cfg @@ -0,0 +1,298 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! VORTEX 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! User defined : VORTEX configuration: Flat bottom, beta-plane +!----------------------------------------------------------------------- + rn_dx = 30000. ! x horizontal resolution [meters] + rn_dy = 30000. ! y horizontal resolution [meters] + rn_dz = 500. ! z vertical resolution [meters] + rn_ppgphi0 = 38.5 ! Reference latitude [degrees] +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "VORTEX" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 6000 ! last time step + nn_istate = 0 ! output the initial state (1) or not (0) + nn_stock = 99999 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 99999 ! frequency of write in the output file (modulo referenced to nn_it000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_rdt = 1440. ! time step for the dynamics (and tracer if nn_acc=0) + rn_atfp = 0.05 ! asselin time filter parameter +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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 = 1 ! frequency of surface boundary condition computation + ! (also = the frequency of sea-ice & iceberg model call) + ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + nn_ice = 0 ! =0 no ice boundary condition + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr ) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!!====================================================================== +!! *** 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 +/ +!!====================================================================== +!! *** 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 = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot +/ +!!====================================================================== +!! 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_seos = .true. ! = Use simplified equation of state (S-EOS) + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state) + rn_b0 = 0. ! saline expension coefficient (for simplified equation of state) + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + 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 = .true. ! 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) +!----------------------------------------------------------------------- + ln_traldf_OFF = .true. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator +/ +!!====================================================================== +!! *** 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. ! zstar vertical coordinate +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .false. ! 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 = .true. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: OFF) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: OFF) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. + ln_dynspg_ts = .true. ! 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 = .false. ! Number of sub-step defined from: + nn_baro = 24 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .true. ! 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 = .true. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coef + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! bhm = 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 = 30.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .true. ! constant mixing + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + ! + ! ! coefficients + rn_avm0 = 1.e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.e0 ! 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) +/ +!!====================================================================== +!! *** 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") +!!====================================================================== +! +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/VORTEX/MY_SRC/domvvl.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/domvvl.F90 new file mode 100644 index 0000000000000000000000000000000000000000..dab39b940c14cfcde023a73a6539ec171c2b7494 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/domvvl.F90 @@ -0,0 +1,1053 @@ +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: domvvl.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 + ! + ! usr_def_istate called here only to get sshb, that is needed to initialize e3t_b and e3t_n + CALL usr_def_istate( gdept_0, tmask, tsb, ub, vb, sshb ) + ! usr_def_istate will be called again in istate_init to initialize ts(bn), ssh(bn), u(bn) and v(bn) + ! + DO jk=1,jpk + e3t_b(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshb(:,:) ) & + & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & + & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) ! make sure e3t_b != 0 on land points + END DO + e3t_n(:,:,:) = e3t_b(:,:,:) + sshn(:,:) = sshb(:,:) ! needed later for gde3w +!!$ 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/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c504255872d560ce9c0f15a887081c3095c924ec --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,131 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === VORTEX configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-11 (J. Chanut) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh for VORTEX configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam, ONLY: rn_dx, rn_dy, rn_ppgphi0 ! horizontal resolution in meters + ! and reference latitude + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! VORTEX configuration : beta-plance with uniform grid spacing (rn_dx) + !! + !! ** 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) :: zphi0, zlam0, zbeta, zf0 + REAL(wp) :: zti, zui, ztj, zvj ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : VORTEX configuration bassin' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Beta-plane with regular grid-spacing' + IF(lwp) WRITE(numout,*) ' given by rn_dx and rn_dy' + ! + ! + ! Position coordinates (in kilometers) + ! ========== + zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx + zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy + +#if defined key_agrif + ! ! let lower left longitude and latitude from parent + IF (.NOT.Agrif_root()) THEN + zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*1.e-3*Agrif_irhox()*rn_dx & + &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx*1.e-3-(0.5_wp+nbghostcells)*rn_dx*1.e-3 + zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*1.e-3*Agrif_irhoy()*rn_dy & + &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy*1.e-3-(0.5_wp+nbghostcells)*rn_dy*1.e-3 + ENDIF +#endif + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 ) + zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp + + plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti + plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + + pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj + pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj + pphiu(ji,jj) = pphit(ji,jj) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! Horizontal scale factors (in meters) + ! ====== + pe1t(:,:) = rn_dx ; pe2t(:,:) = rn_dy + pe1u(:,:) = rn_dx ; pe2u(:,:) = rn_dy + pe1v(:,:) = rn_dx ; pe2v(:,:) = rn_dy + pe1f(:,:) = rn_dx ; pe2f(:,:) = rn_dy + + ! ! NO reduction of grid size in some straits + ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_hgr 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 Coriolis parameter afterward + ! + zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + pff_f(:,:) = zf0 + zbeta * pphif(:,:) * 1.e+3 + pff_t(:,:) = zf0 + zbeta * pphit(:,:) * 1.e+3 + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ae5a6b5ac0722ce8246bbf51731aac5765961e2b --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,144 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === VORTEX configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-11 (J. Chanut) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE dom_oce , ONLY : glamt, gphit, glamu, gphiu, glamv, gphiv + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + ! + USE usrdef_nam, ONLY : rn_ppgphi0 ! Reference latitude + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called by istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here VORTEX configuration + !! + !! ** Method : Set a gaussian anomaly of pressure and associated + !! geostrophic velocities + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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 :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx, zy, zP0, zumax, zlambda, zn2, zf0, zH, zrho1, za, zf + REAL(wp) :: zdt, zdu, zdv + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : VORTEX configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ! + ! + ! + zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) + zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic + zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters + zn2 = 3.e-3**2 + zH = 0.5_wp * 5000._wp + ! + zP0 = rau0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) + ! + ! Sea level: + za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH))) + DO ji=1, jpi + DO jj=1, jpj + zx = glamt(ji,jj) * 1.e3 + zy = gphit(ji,jj) * 1.e3 + zrho1 = rau0 + za * EXP(-(zx**2+zy**2)/zlambda**2) + pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1) + END DO + END DO + ! + ! temperature: + DO ji=1, jpi + DO jj=1, jpj + zx = glamt(ji,jj) * 1.e3 + zy = gphit(ji,jj) * 1.e3 + DO jk=1,jpk + zdt = pdept(ji,jj,jk) + zrho1 = rau0 * (1._wp + zn2*zdt/grav) + IF (zdt < zH) THEN + zrho1 = zrho1 - zP0 * (1._wp-EXP(zdt-zH)) & + & * EXP(-(zx**2+zy**2)/zlambda**2) / (grav*(zH -1._wp + exp(-zH))); + ENDIF + pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) + END DO + END DO + END DO + ! + ! salinity: + pts(:,:,:,jp_sal) = 35._wp + ! + ! velocities: + za = 2._wp * zP0 / (zf0 * rau0 * zlambda**2) + DO ji=1, jpim1 + DO jj=1, jpj + zx = glamu(ji,jj) * 1.e3 + zy = gphiu(ji,jj) * 1.e3 + DO jk=1, jpk + zdu = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji+1,jj,jk)) + IF (zdu < zH) THEN + zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) + pu(ji,jj,jk) = (za * zf * zy * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) + ELSE + pu(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END DO + ! + DO ji=1, jpi + DO jj=1, jpjm1 + zx = glamv(ji,jj) * 1.e3 + zy = gphiv(ji,jj) * 1.e3 + DO jk=1, jpk + zdv = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji,jj+1,jk)) + IF (zdv < zH) THEN + zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) + pv(ji,jj,jk) = -(za * zf * zx * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) + ELSE + pv(ji,jj,jk) = 0._wp + ENDIF + END DO + END DO + END DO + + CALL lbc_lnk( 'usrdef_istate', pu, 'U', -1. ) + CALL lbc_lnk( 'usrdef_istate', pv, 'V', -1. ) + ! + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9d516167bb31c0bf107eae30f2d9403aca6ddf52 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,120 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === VORTEX configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : NEMO ! 2017-10 (J. Chanut) 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dy ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dz ! vertical resolution + REAL(wp), PUBLIC :: rn_ppgphi0 ! reference latitude for beta-plane + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 VORTEX 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 + REAL(wp):: zlx, zly, zh ! Local scalars + !! + NAMELIST/namusr_def/ rn_dx, rn_dy, rn_dz, rn_ppgphi0 + !!---------------------------------------------------------------------- + ! + 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 defined key_agrif + ! Domain parameters are taken from parent: + IF( .NOT. Agrif_Root() ) THEN + rn_dx = Agrif_Parent(rn_dx)/Agrif_Rhox() + rn_dy = Agrif_Parent(rn_dy)/Agrif_Rhoy() + rn_dz = Agrif_Parent(rn_dz) + rn_ppgphi0 = Agrif_Parent(rn_ppgphi0) + ENDIF +#endif + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'VORTEX' ! name & resolution (not used) + kk_cfg = nINT( rn_dx ) + ! + IF( Agrif_Root() ) THEN ! Global Domain size: VORTEX global domain is 1800 km x 1800 Km x 5000 m + kpi = NINT( 1800.e3 / rn_dx ) + 3 + kpj = NINT( 1800.e3 / rn_dy ) + 3 + ELSE + kpi = nbcellsx + 2 + 2*nbghostcells + kpj = nbcellsy + 2 + 2*nbghostcells + ENDIF + kpk = NINT( 5000._wp / rn_dz ) + 1 + ! + zlx = (kpi-2)*rn_dx*1.e-3 + zly = (kpj-2)*rn_dy*1.e-3 + zh = (kpk-1)*rn_dz + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! VORTEX configuration : closed basin + ! ! 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 : VORTEX test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' m' + WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' m' + WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' m' + WRITE(numout,*) ' VORTEX domain: ' + WRITE(numout,*) ' LX [km]: ', zlx + WRITE(numout,*) ' LY [km]: ', zly + WRITE(numout,*) ' H [m] : ', zh + WRITE(numout,*) ' Reference latitude rn_ppgphi0 = ', rn_ppgphi0 + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' VORTEX : closed basin jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8b713c45bc9e65a7bf4d7e67c368970f5acd7bfc --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,86 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === VORTEX configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2017-11 (J.Chanut) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_sbc : user defined surface bounday conditions in OVERFLOW case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 VORTEX case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : VORTEX 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 + ! + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a643060c36fd46c7d0faa38f65a4880f8a125268 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,238 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === VORTEX configuration === + !! + !! User defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2017-11 (J. Chanut) 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: usrdef_zgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: 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 : VORTEX configuration (z-coordinate closed flat box ocean)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ld_zco = .TRUE. ! VORTEX 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) :: zd ! local scalar + !!---------------------------------------------------------------------- + ! + zd = 5000._wp/FLOAT(jpkm1) + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates ' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' VORTEX case : uniform vertical grid :' + WRITE(numout,*) ' with thickness = ', zd + ENDIF + + ! + ! 1D Reference z-coordinate (using Madec & Imbard 1996 function) + ! ------------------------- + ! + pdepw_1d(1) = 0._wp + pdept_1d(1) = 0.5_wp * zd + ! + DO jk = 2, jpk ! depth at T and W-points + pdepw_1d(jk) = pdepw_1d(jk-1) + zd + pdept_1d(jk) = pdept_1d(jk-1) + zd + 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 : VORTEX 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,*) ' VORTEX 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(:,:) = INT( 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/V4.0/nemo_sources/tests/VORTEX/cpp_VORTEX.fcm b/V4.0/nemo_sources/tests/VORTEX/cpp_VORTEX.fcm new file mode 100644 index 0000000000000000000000000000000000000000..6f67d589df8493ec9efd40d965ddaad4c5dae929 --- /dev/null +++ b/V4.0/nemo_sources/tests/VORTEX/cpp_VORTEX.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/README.py b/V4.0/nemo_sources/tests/WAD/EXPREF/README.py new file mode 100644 index 0000000000000000000000000000000000000000..fd6bf8707cce321659f2bc1063d0c08438cf278d --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/README.py @@ -0,0 +1,5 @@ +ncks -O -d y,17,17,1 WAD_1ts_00010101_00010101_grid_T.nc sshtime.nc +ncks -4 -A -v gdepw_0,ht_wd -d y,17,17,1 -d z,10,10,1 -C mesh_mask.nc sshtime.nc + +python2.7 matpoly2.py sshtime.nc +animate wadfr*.png diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/axis_def_nemo.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..6117f35baf7f6be7afa129d96a3ec521cbbc06e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/axis_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/context_nemo.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..68ee6dd02a2965497f80887c4782e33073a0ec6d --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/context_nemo.xml @@ -0,0 +1,37 @@ +<!-- + ============================================================================================== + NEMO context +============================================================================================== +--> +<context id="nemo"> + <!-- $id$ --> + <variable_definition> + <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> + <variable id="ref_year" type="int"> 1900 </variable> + <variable id="ref_month" type="int"> 01 </variable> + <variable id="ref_day" type="int"> 01 </variable> + <variable id="rau0" type="float" > 1026.0 </variable> + <variable id="cpocean" type="float" > 3991.86795711963 </variable> + <variable id="convSpsu" type="float" > 0.99530670233846 </variable> + <variable id="rhoic" type="float" > 917.0 </variable> + <variable id="rhosn" type="float" > 330.0 </variable> + <variable id="missval" type="float" > 1.e20 </variable> + </variable_definition> + +<!-- Fields definition --> + <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Files definition --> + <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> + +<!-- Axis definition --> + <axis_definition src="./axis_def_nemo.xml"/> + +<!-- Domain definition --> + <domain_definition src="./domain_def_nemo.xml"/> + +<!-- Grids definition --> + <grid_definition src="./grid_def_nemo.xml"/> + + +</context> diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/domain_def_nemo.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/domain_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/field_def_nemo-oce.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..ff97068135ca98cec33e26d72ad41a072faf64b8 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/file_def_nemo-oce.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..a9c10b7e0ec45084087a8614c64a3d13fc5392a0 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,103 @@ +<?xml version="1.0"?> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."> <!-- 1 time step files --> + <file id="file96" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="ssh" name="sossheig" /> + <field field_ref="sss" name="sosaline" /> + <!-- + <field field_ref="wdmask" name="wdmask" /> + <field field_ref="wetdep" name="wetdepth" /> + <field field_ref="toce" name="votemper" /> + <field field_ref="soce" name="vosaline" /> + --> + </file> + <file id="file87" name_suffix="_grid_U" description="ocean U grid variables" > + <!-- + <field field_ref="un_b" name="un_b" operation="instant"/> + <field field_ref="uoce" name="vozocrtx" operation="instant" /> + --> + <field field_ref="ubar" name="ubaro" operation="instant"/> + <!-- + <field field_ref="un_b" name="un_b" operation="instant"/> + <field field_ref="ucli" name="uc_un" operation="instant" /> + <field field_ref="ucli2" name="uc_un2" operation="instant" /> + <field field_ref="ssu" name="r1_hu_a" operation="instant" /> + <field field_ref="wdlmtu" name="wdlmtu" operation="instant" /> + --> + </file> + <file id="file88" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="vbar" name="vbaro" operation="instant"/> + </file> + </file_group> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."> <!-- 1h files --> + <file id="file97" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="ssh" name="sossheig" operation="instant" /> + <field field_ref="e3t" name="e3t" operation="instant" /> + <field field_ref="toce" name="votemper" /> + </file> + <file id="file98" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="ubar" name="ubaro" operation="instant"/> + </file> + </file_group> + <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> + <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> + <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> + <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> + + <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> + <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files --> + + <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > + <field field_ref="toce" name="votemper" /> + <field field_ref="soce" name="vosaline" /> + <field field_ref="sst" name="sosstsst" /> + <field field_ref="sss" name="sosaline" /> + <field field_ref="ssh" name="sossheig" /> + <field field_ref="empmr" name="sowaflup" /> + <field field_ref="qsr" name="soshfldo" /> + <field field_ref="saltflx" name="sosfldow" /> + <field field_ref="qt" name="sohefldo" /> + <field field_ref="mldr10_1" name="somxl010" /> + <field field_ref="mldkz5" name="somixhgt" /> + </file> + + <file id="file2" name_suffix="_grid_U" description="ocean U grid variables" > + <field field_ref="uoce" name="vozocrtx" /> + <field field_ref="utau" name="sozotaux" /> + </file> + + <file id="file3" name_suffix="_grid_V" description="ocean V grid variables" > + <field field_ref="voce" name="vomecrty" /> + <field field_ref="vtau" name="sometauy" /> + </file> + + <file id="file4" name_suffix="_grid_W" description="ocean W grid variables" > + <field field_ref="woce" name="vovecrtz" /> + <field field_ref="avt" name="votkeavt" /> + </file> + + </file_group> + + <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> + <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> + <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> + <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> + <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> + + <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> + <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> + <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> + <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> + + </file_definition> + diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/grid_def_nemo.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1be74edf6d85af6063315421809ef3994216004f --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/grid_def_nemo.xml @@ -0,0 +1 @@ +../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/iodef.xml b/V4.0/nemo_sources/tests/WAD/EXPREF/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..b49154cddcc7413a89873e4d3b30c67fed097ba6 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/iodef.xml @@ -0,0 +1,26 @@ +<?xml version="1.0"?> +<simulation> + +<!-- ============================================================================================ --> +<!-- XIOS context --> +<!-- ============================================================================================ --> + + <context id="xios" > + + <variable_definition> + + <variable id="info_level" type="int">10</variable> + <variable id="using_server" type="bool">true</variable> + <variable id="using_oasis" type="bool">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + </context> + +<!-- ============================================================================================ --> +<!-- NEMO CONTEXT add and suppress the components you need --> +<!-- ============================================================================================ --> + + <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> + +</simulation> diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/makebdy_tc7.py b/V4.0/nemo_sources/tests/WAD/EXPREF/makebdy_tc7.py new file mode 100644 index 0000000000000000000000000000000000000000..2f8c32a0e346b9f6eed76516050186be6e1cd37b --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/makebdy_tc7.py @@ -0,0 +1,80 @@ +from netCDF4 import Dataset +import numpy as np + +pathout = "bdyssh_tc7" + +nx = 34 +ny = 1 +nt = 24 +ndays=4 + +#------------------------------------------------------- +# Create bdyssh_tc7_m01d01.nc, bdyssh_tc7_m01d02.nc etc. +#------------------------------------------------------- + +pathstart="{}_m12d30.nc".format(pathout) +for nd in range(ndays): + print pathstart + ssh = np.zeros((nt,ny,nx)) + for nnt in range(nd*nt,(nd+1)*nt): + tx = 2.5*np.cos((3.141592654/6.0)*(nnt+1.0)) + print nnt, tx + for nnx in range(nx): + for nny in range(ny): + ssh[nnt-nd*nt,nny,nnx] = tx + + + fo = Dataset(pathstart, 'w', format='NETCDF4') + nxo = fo.createDimension('x', nx) + nyo = fo.createDimension('y', ny) + nto = fo.createDimension('t', None) + ssho = fo.createVariable('sshbdy', 'f4',('t','y','x')) + + ssho[:,:,:] = ssh[:,:,:] + ssho.long_name = 'bdy ssh boundary condition' + ssho.standard_name = 'sshbdy' + ssho.units = 'm' +# + fo.close() + pathstart="{}_m01d{:0>2d}.nc".format(pathout,nd+1) + +#------------------------------------------------------- +# Create bdyuv_tc7_m01d01.nc, bdyuv_tc7_m01d02.nc etc. +# u is -(1/H)*d(ssh)/dt; v =0.0 +#------------------------------------------------------- + +pathout = "bdyuv_tc7" + + +pathstart="{}_m12d30.nc".format(pathout) +for nd in range(ndays): + print pathstart + u = np.zeros((nt,ny,nx)) + for nnt in range(nd*nt,(nd+1)*nt): + tx = 2.5*(3.141592654/6.0)*np.sin((3.141592654/6.0)*(nnt+1.0))/10.0 + print nnt, tx + for nnx in range(nx): + for nny in range(ny): + u[nnt-nd*nt,nny,nnx] = tx + + v = np.zeros((nt,ny,nx)) + + fo = Dataset(pathstart, 'w', format='NETCDF4') + nxo = fo.createDimension('x', nx) + nyo = fo.createDimension('y', ny) + nto = fo.createDimension('t', None) + uo = fo.createVariable('ubdy', 'f4',('t','y','x')) + vo = fo.createVariable('vbdy', 'f4',('t','y','x')) + + uo[:,:,:] = u[:,:,:] + uo.long_name = 'bdy u boundary condition' + uo.standard_name = 'ubdy' + uo.units = 'm/s' +# + vo[:,:,:] = v[:,:,:] + vo.long_name = 'bdy v boundary condition' + vo.standard_name = 'vbdy' + vo.units = 'm/s' +# + fo.close() + pathstart="{}_m01d{:0>2d}.nc".format(pathout,nd+1) diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_cfg b/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..9d4395f9840cf49ea10c58749c0d66bbcdc80b2f --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_cfg @@ -0,0 +1,477 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! Wetting & Drying 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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namusr_def ! Wetting and Drying TEST CASE +!----------------------------------------------------------------------- + rn_dx = 1500.0 ! horizontal resolution + rn_dz = 1.0 ! vertical resolution + nn_wad_test = 1 ! ??? +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "WAD" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 3840 ! last time step + !nn_itend = 6 ! last time step + nn_leapy = 30 ! Leap year calendar (1) or not (0) + nn_stock = 48000 ! frequency of creation of a restart file (modulo referenced to 1) + + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_istate = 0 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + ! + ln_meshmask = .true. ! create (>0) a mesh file or not (=0) + rn_rdt = 18. ! time step for the dynamics +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules + ln_write_cfg = .true. ! (=T) create the domain configuration file +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false ! T/F activation of iterative limiter + ln_wd_dl = .true. ! T/F activation of directional limiter + ln_wd_dl_bc = .true. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .true. ! 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 +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of surface boundary condition computation + ! ! (also = the frequency of sea-ice model call) + ln_usr = .true. ! analytical formulation (T => check usrdef_sbc) + 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 ) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ln_qsr_rgb = .false. ! RGB (Red-Green-Blue) light penetration + ln_qsr_2bd = .true. ! 2 bands light penetration + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) +/ +!----------------------------------------------------------------------- +&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) +!----------------------------------------------------------------------- + nn_sssr = 0 ! add a damping term in the surface freshwater flux (=2) + rn_deds = -27.7 ! magnitude of the damping on salinity [mm/day] + ln_sssr_bnd = .false. ! flag to bound erp term (associated with nn_sssr=2) +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs namelist surface boundary condition (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! specific treatment at rivers mouths +/ +!!====================================================================== +!! *** 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 +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries +!----------------------------------------------------------------------- + ln_bdy = .false. + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .false. ! =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 = 'flather' ! + nn_dyn2d_dta = 1 ! = 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 = 'frs' ! + 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 + rn_ice_tem = 270. ! si3 only: arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! si3 only: -- salinity -- + rn_ice_age = 30. ! si3 only: -- age -- + + 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_index +!----------------------------------------------------------------------- + ctypebdy = 'E' + nbdyind = 50 + nbdybeg = 1 + nbdyend = 34 + !ctypebdy = 'W' + !nbdyind = 2 + !nbdybeg = 1 + !nbdyend = 34 +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data +!----------------------------------------------------------------------- + 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 = './' +! ! 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 ! + bn_ssh = 'bdyssh_tc7' , 1. , 'sshbdy', .true. , .true. , 'daily' , '' , '' , '' + bn_u2d = 'bdyuv_tc7' , 1. , 'ubdy' , .true. , .true. , 'daily' , '' , '' , '' + bn_v2d = 'bdyuv_tc7' , 1. , 'vbdy' , .true. , .true. , 'daily' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ln_lin = .true. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_isfcav=T) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-4 ! drag coefficient [-] + rn_Uc0 = 0.1 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 1.e-4 ! 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 = 0 ! geothermal heat flux: = 0 no flux +/ +!!====================================================================== +!! 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: OFF) +!----------------------------------------------------------------------- + ln_teos10 = .false. ! = Use TEOS-10 equation of state + ln_eos80 = .false. ! = Use EOS80 equation of state + ln_seos = .true. ! = Use simplified equation of state (S-EOS) + ! + ! ! 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 (nn_eos= 1) + rn_b0 = 7.6554e-1 ! saline expension coefficient (nn_eos= 1) + 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) +!!org GYRE rn_alpha = 2.0e-4 ! thermal expension coefficient (nn_eos= 1 or 2) +!!org GYRE rn_beta = 7.7e-4 ! saline expension coefficient (nn_eos= 2) +!!org caution now a0 = alpha / rau0 with rau0 = 1026 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + ln_traadv_mus = .false. ! MUSCL scheme + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_lap = .true. ! 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 = .true. ! iso-neutral + ln_traldf_triad = .false. ! iso-neutral using Griffies triads + ! + ! ! 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 + ! ! = 0 constant + ! ! time invariant coefficients : aht = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Ud = 0.2 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Ld = 10.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .true. ! 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: OFF) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&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 = .true. ! s-coordinate +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: OFF) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .false. ! Number of sub-step defined from: + nn_baro = 12 ! =F : the number of sub-step in rn_rdt seconds +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! 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 + ! ! = 0 constant + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 2.0 ! 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) +/ +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! type of vertical closure + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .true. ! 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 = .true. ! enhanced vertical diffusion + nn_evdm = 1 ! 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_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + nn_etau = 0 ! penetration of tke below the mixed layer (ML) due to internal & intertial waves +/ +!!====================================================================== +!! *** 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 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) +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 60 ! time step frequency for transports computing + nn_dctwri = 60 ! time step frequency for transports writing + nn_secdebug = 0 ! 0 : no section to debug +/ +!!====================================================================== +!! *** 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) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_ref b/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..97682863712c9d973a2d1aa35a12452a3e8b4f96 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/namelist_ref @@ -0,0 +1 @@ +../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/EXPREF/plotframes.py b/V4.0/nemo_sources/tests/WAD/EXPREF/plotframes.py new file mode 100644 index 0000000000000000000000000000000000000000..957d83c50fd5a563cdb803c3b76510a623855673 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/EXPREF/plotframes.py @@ -0,0 +1,304 @@ +#!/usr/bin/env python +################################################################################## +# Utility to produce animation frames directly from the WAD_TEST_CASE output. +# It can be used without arguments, i.e.: +# python plotframes.py +# in which case a frame is created every tenth time level from SSH data extracted from +# WAD_1ts_00010101_00010101_grid_T.nc along the centre of the basin (j=17). A closed +# basin is assumed and frames are named wadfr0000.png etc. Bathymetry information is +# extracted from the mesh_mask.nc file. The frames are annotated with a timestamp that +# assumes an 18s baroclinic timestep. +# +# All these settings can be overridden with command-line arguments. See: +# python plotframes.py -h +# for details. For example: +# python plotframes.py -nt 300 -stride 30 -froot mywad +# +# Two major variations are also supported for specific test cases: +# python plotframes.py -obc +# plots the right-hand side of the basin as an open boundary (test case 7) and: +# python plotframes.py -use_sal +# colours each gridcell according to its salinity value (test case 6) +################################################################################## +import os, sys +from argparse import ArgumentParser +import numpy as np +import netCDF4 + +import matplotlib.pyplot as plt +import matplotlib +from matplotlib.patches import Polygon +from matplotlib.collections import PatchCollection +from netCDF4 import Dataset + +# +# Turn off the unhelpful warning about open figures +# +matplotlib.rcParams['figure.max_open_warning'] = 0 + +if __name__ == '__main__': + parser = ArgumentParser(description= + """ + produce frames for the animation of results from the WAD_TEST_CASES. + Mostly this can be run without arguments but command line arguments may be + used to override defaults. These are necessary in cases with open boundaries + (e.g. nn_wad_test=7) and cases where it is desired to show variations in salinity + (e.g. nn_wad_test=6). + e.g. plotframes.py -tfile <T-grid file> -bfile <bathymetry file> + -froot <root name for frames> + -nt <maximum number of time frames to process> + -stride <stride through time frames> + -rdt <length of baroclinic timestep (s)> + -obc + -use_sal + """) + parser.add_argument('-tfile',dest='tfile',help='T-grid file if not WAD_1ts_00010101_00010101_grid_T.nc', default='WAD_1ts_00010101_00010101_grid_T.nc') + parser.add_argument('-bfile',dest='bfile',help='Bathymetry file if not mesh_mask.nc', default='mesh_mask.nc') + parser.add_argument('-j',dest='jrow',help='jrow; j-row to extract and plot (default: 17 (fortran index))', type=int, default=16) + parser.add_argument('-froot',dest='froot',help='froot; root name for frames (default: wadfr)', default='wadfr') + parser.add_argument('-nt',dest='nfmax',help='nfmax; maximum number of frames to produce', type=int, default=None) + parser.add_argument('-stride',dest='tinc',help='tinc; stride through time frames (default: 10)', type=int, default=10) + parser.add_argument('-rdt',dest='rdt',help='rdt; length of baroclinic timestep (s) (default: 18.0)', type=float, default=18.0) + parser.add_argument('-obc',help='Right-hand side boundary is open', action="store_true") + parser.add_argument('-use_sal',help='colour polygons according to salinity variations', action="store_true") + args = parser.parse_args() + tfile = args.tfile + bfile = args.bfile + jrow = args.jrow + froot = args.froot + nfmax = args.nfmax + stride = args.tinc + rdt = args.rdt + obc = args.obc + use_sal= args.use_sal + + +fw = Dataset(tfile) +ssh = fw.variables['sossheig'][:,jrow,:] +vot = fw.variables['sosaline'][:,jrow,:] +if use_sal: + sal = fw.variables['vosaline'][:,:,jrow,:] + nz = sal.shape[1] +fw.close() + +fw = Dataset(bfile) +bat = fw.variables['ht_wd'][0,jrow,:] +if use_sal: + mbat = fw.variables['mbathy'][0,jrow,:] +fw.close() + +#print "ssh" +#print ssh.shape +#print "bat" +#print bat.shape +#print "vot" +#print vot.shape +nt = ssh.shape[0] +nx = ssh.shape[1] +#print nx,nt + +bat = -1.*bat +batmin = np.amin(bat) +batmax = np.amax(bat) +brange = batmax - batmin +tol = 0.1*brange +#print batmin,batmax,' ho' +if obc: + batrhs = batmin +else: + batrhs = batmax + +if nfmax is None: + nfmax = nt + +nf = 0 +ntmax = np.minimum(nt,nfmax*stride) + +if not use_sal: +# +# plot solid single colour polygons just showing ssh variation +# + for t in range(0,ntmax,stride): + wadfr = froot+"{:0>4d}.png".format(nf) + nf = nf + 1 + + tfac = rdt/3600.0 + t24 = np.int(np.mod(t*tfac,24)) + dy = np.int(t*tfac/24.0) + mn = np.int(np.rint((np.mod(t*tfac,24) - t24 )*60)) + hour = "t={:0>2d}:{:0>2d}:{:0>2d} ".format(dy,t24,mn) + hour2 = " (days:hrs:mins)" + batpts = np.zeros((nx+4,2)) + sshpts = np.zeros((2*nx,2)) + votpts = np.zeros((nx,2)) + + for pt in range(nx): + batpts[pt+2,0] = pt + batpts[pt+2,1] = bat[pt] + sshpts[pt,0] = pt + sshpts[pt,1] = ssh[t,pt] + votpts[pt,0] = pt + votpts[pt,1] = np.minimum(36.,vot[t,pt]) + votpts[pt,1] = np.maximum(30.0,votpts[pt,1]) + votpts[pt,1] = batmin +0.2*brange + (votpts[pt,1]-30.)*brange/6.0 + + batpts[nx+1,1] = batrhs + batpts[nx+2,0] = nx-1 + batpts[nx+2,1] = batrhs + batpts[nx+3,0] = nx-1 + batpts[nx+3,1] = batmin + batpts[0,0] = 0.0 + batpts[0,1] = batmin + batpts[1,0] = 0.0 + batpts[1,1] = batmax + batpts[2,1] = batmax + sshpts[nx-1,0] = nx-1 + sshpts[nx-1,1] = sshpts[nx-2,1] + sshpts[0,0] = 0.0 + votpts[nx-2,0] = nx-1 + votpts[nx-1,0] = nx-1 + votpts[0,0] = 0.0 + votpts[nx-1,1] = batmax + tol + votpts[0,1] = batmax + tol + sshpts[0,1] = sshpts[1,1] + for pt in range(nx): + sshpts[pt+nx,0]=batpts[nx+1-pt,0] + sshpts[pt+nx,1]=batpts[nx+1-pt,1] + + + xs, ys = zip(*votpts) + fig, ax = plt.subplots() + + patches = [] + polygon = Polygon(batpts, True) + patches.append(polygon) + p = PatchCollection(patches, cmap=matplotlib.cm.jet, alpha=1.0) + p.set_facecolors(['#f1a9a9']) + + patches = [] + polygon2 = Polygon(sshpts, True) + patches.append(polygon2) + p2 = PatchCollection(patches, cmap=matplotlib.cm.jet, alpha=1.0) + p2.set_facecolors(['#44a1ff']) + +# Maximum depth set here to -10m + ax.set_ylim([-10., 6.0]) + ax.set_xlim([0., 51.0]) + ax.add_collection(p2) + ax.add_collection(p) + ax.plot(xs,ys, '--', color='black', ms=10) + + plt.annotate(hour,xy=(2,batmin+0.1*brange)) + plt.annotate(hour2,xy=(2,batmin+0.05*brange)) + plt.savefig(wadfr) + +else: +# +# plot each gridcell coloured according to its salinity value +# + for t in range(0,ntmax,stride): + wadfr = froot+"{:0>4d}.png".format(nf) + nf = nf + 1 + + tfac = rdt/3600.0 + t24 = np.int(np.mod(t*tfac,24)) + dy = np.int(t*tfac/24.0) + mn = np.int(np.rint((np.mod(t*tfac,24) - t24 )*60)) + hour = "t={:0>2d}:{:0>2d}:{:0>2d} ".format(dy,t24,mn) + hour2 = " (days:hrs:mins)" + batpts = np.zeros((nx+4,2)) + votpts = np.zeros((nx,2)) + salpts = np.zeros((nx*nz,6,2)) + salmin = 28. + salmax = 37. + salrange = salmax - salmin + faccol = np.zeros((nx*nz)) + cl = 0 + for pt in range(nx): + batpts[pt+2,0] = pt + batpts[pt+2,1] = bat[pt] + votpts[pt,0] = pt + votpts[pt,1] = np.minimum(35.,vot[t,pt]) + votpts[pt,1] = np.maximum(30.0,votpts[pt,1]) + votpts[pt,1] = batmin +0.2*brange + (votpts[pt,1]-30.)*brange/6.0 + batpts[nx+1,1] = batmax + batpts[nx+2,0] = nx-1 + batpts[nx+2,1] = batmax + batpts[nx+3,0] = nx-1 + batpts[nx+3,1] = batmin + batpts[0,0] = 0.0 + batpts[0,1] = batmin + batpts[1,0] = 0.0 + batpts[1,1] = batmax + batpts[2,1] = batmax + votpts[nx-2,0] = nx-1 + votpts[nx-1,0] = nx-1 + votpts[0,0] = 0.0 + votpts[nx-1,1] = batmax + tol + votpts[0,1] = batmax + tol + + cl = 0 + for pt in range(nx): + mz = np.maximum(1,mbat[pt]) + im1 = np.maximum(pt-1,1) + ip1 = np.minimum(pt+1,nx-1) + dz = (ssh[t,pt] - batpts[pt+2,1] )/mz + dz1 = 0.5*(ssh[t,pt] + ssh[t,im1] - batpts[pt+2,1] - batpts[im1+2,1] )/mz + dz2 = 0.5*(ssh[t,pt] + ssh[t,ip1] - batpts[pt+2,1] - batpts[ip1+2,1] )/mz + dz = np.maximum(dz ,0.0) + dz1 = np.maximum(dz1,0.0) + dz2 = np.maximum(dz2,0.0) + bat1 = 0.5*( batpts[pt+2,1] + batpts[im1+2,1] ) + bat2 = 0.5*( batpts[pt+2,1] + batpts[ip1+2,1] ) + ptm = np.maximum(pt-0.5,0.0) + ptx = np.minimum(pt+0.5,nx-1) + for z in range(mz): + if ( sal[t,mz-1-z,pt] > 0.0 ): + salpts[cl,0,0] = pt + salpts[cl,1,0] = ptm + salpts[cl,2,0] = ptm + salpts[cl,3,0] = pt + salpts[cl,4,0] = ptx + salpts[cl,5,0] = ptx + salpts[cl,0,1] = batpts[pt+2,1] +dz*z + salpts[cl,1,1] = bat1 +dz1*z + salpts[cl,2,1] = bat1 +dz1*(z+1) + salpts[cl,3,1] = batpts[pt+2,1] +dz*(z+1) + salpts[cl,4,1] = bat2 +dz2*(z+1) + salpts[cl,5,1] = bat2 +dz2*z + faccol[cl] = 100*(sal[t,mz-1-z,pt] - salmin) / salrange + faccol[cl] = np.maximum(faccol[cl],0.0) + faccol[cl] = np.minimum(faccol[cl],100.0) + cl = cl + 1 + + + votpts2 = votpts[2:nx-4,:] + xs, ys = zip(*votpts2) + fig, ax = plt.subplots() + patches = [] + + for pt in range(cl-1): + polygon = Polygon(salpts[pt,:,:], True) + patches.append(polygon) + + p = PatchCollection(patches, cmap=matplotlib.cm.jet, alpha=1.0) + + p.set_array(faccol) + p.set_edgecolor('face') + + patches = [] + polygon = Polygon(batpts, True) + patches.append(polygon) + p2 = PatchCollection(patches, cmap=matplotlib.cm.jet, alpha=1.0) + p2.set_facecolors(['#f1a9a9']) + +# Maximum depth set here to -8m (suitable for test case 6 only) + ax.set_ylim([-8., 6.0]) + ax.set_xlim([0., 51.0]) + ax.add_collection(p) + ax.add_collection(p2) + ax.plot(xs,ys, '--', color='black', ms=10) + + plt.annotate(hour,xy=(2,batmin+0.1*brange)) + plt.annotate(hour2,xy=(2,batmin+0.05*brange)) + plt.savefig(wadfr) diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC1.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC1.pdf new file mode 100644 index 0000000000000000000000000000000000000000..185bbba440be60256686ca719d9baba434ef659b --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC1.pdf @@ -0,0 +1,3877 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R 267 0 R]/Order 268 0 R/RBGroups[]>>/OCGs[6 0 R 267 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 56774/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Print</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-10T14:12Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-10T14:12Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T13:26:06Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG8tBcm1M8f1lUEr Qcl9QIxKq5WteJKkA+2Kr/Uj/nH3jFXepH/OPvGKu9SP+cfeMVd6kf8AOPvGKu9SP+cfeMVd6kf8 4+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xVsSITQMCfnireKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KpTq8q/pTRYklAlF2zvCCvNo/qlwtaHfiGNa+1MVTbFXYq7FXYq7FX Yq7FXcV5BqDkAQD3oev6sVdiqX65/vFH/wAxdn/1FxYqmGKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2 KuxV2KuxV2KuxV2KuxV2KsZ866haadc+XL65A4Q6qqly3AIs1pcQtIxO3FBLyau1MBZRF2ySGaKa JJoXWSGRQ8ciEMrKwqGUjYgjCxXYq7FXYq7FXYq7FXYq7FUv1z/eKP8A5i7P/qLixVDnWtYW8uoW 0C7aCFwtvcxy2ZWZaVLhXnjZd9qEVxVUXWNRZgDod8oJoWL2VB7mlyTirD9U8++d4LGkHl/jfGaW Mn6vqd0I4472SD1RFFaJHKDBGJQPrCFq/CDVeSrd7+YPnu31Kws18mzPb3V1bW9xfRvNIIVdIHuJ GjWAKEQzsit6tPgYnpxKqceTfOGu67IkeqeXLnRGNoLlzOZGVZTcSw+hyeGEFuEayeNG6dyqyvFX Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqwj8xbuw9bS7Tkv1/wCtLKyU+L0jbXQU8qbjkrbV yvJycnSfWx21n1Cwma40u6aymd/UmQAPDMwUL++ibZqhFBZSsnEABwMqjMhzsuCM/ezTRfO9ldyL a6igsLxjxiZmrbykyCNBHKaUduafu3APIkJzClsvjIF12XBKHuZLkml2KuxV2KuxVjWp/mJ5UsQw W7+uSqFYR2g9UMHNPhk2i26kc6/hmRj0uSXINU88Y9WF6v8Amvrdzyj02GOwiIoJT++mqHqGBYCM VXYqUb2OZ2Ps4D6i409WegSXR9T1DUvNmlTahcyXUgvY3j9ViwQu68vTU/CgNOigDJ6nDCGI0Pxb HDklKYsvc80zsHYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWGfmJeWzJplqs gM8d6rugrsHtboLv034Nt7ZXk5OTpPrYzmO7RbJHHJG0cih43BV0YAggihBB6g4VROn+YdZ0KzSO CWS90+1VmW0lb1JgAvwok0gd3UfEeDGpPECRFHE2xyd7g5tKKuL0TSta0zVYnksZxIYmKTREFJI2 BIo8bAMtaVWoow3FQQcuBcGUSDRQ+q+avLulOYr6/jjmBVWgWskq8wSpaOMO6qQPtEUyzHilP6Rb XKcY8ywzVPzeqCuk2JBoKTXZGxD/ABD0oyagqNj6g69NszcfZ5P1GnHnqx0YbrPmfWdZVE1Ob6xH E5eKKnBFJ6HinEEr0UtUjx3OZ2LSwhuObjTzylzS31E/30v3t/zVmRTVbvUT/fS/e3/NWNLaP8u3 Cr5o0RAir6t9Elfir3bx/wAnMPXbYy36b63v1D45pHZOp74q6nviqlZzNNaQTMAGkjV2A6VZQdsV VcVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVYb+Yt1bNFpduJUM63wZogw5hTa3IB49f2 TleTk5Ok+tjGY7tHYqhdUmlg0y8mhCtLFBI8avUKWVCQDTelcI5sZ8irSwRysrnksqV9OZGKSLy2 bi6kMOQ2bfcbHbDGRibCJ44zFHkxe70e6sdgvq2wqI5EH2UUVHqKAOPfcfDt2qBm/wBL2hGQqXpl 9jz2r7NnA3H1R+1Cdc2TrHYVdirsVRmgf8pZ5f6f8dCLr/qt0zB7Q/u/i5WkHq+D6EzSuwdirsVQ 2mf8c20/4wx/8RGKonFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWCef9a02abTtMjlP1 2G8EskTI6fAba6QMrMoVviQ/ZOV5OTk6T60hzHdo7FUHrH/HIvv+YeX/AIgcI5sZ8i16V3Zwott/ pMEKMPQaglNAOAjclU2CkUfqTUuKbm7RRHLdWt7uGeqiqTKA0kD7SICzKCy+BZG4t0amxIwEMhK0 Ff6DbzkyW5FvMak0HwMS3JiyinxGp+IeNTXMzTa6eLbnHucLVaCGXflLv/Wx+eC4tpvRuYzFIalK kEOqmhZCOo+e42qBXN9p9VDL9PN5/UaWeI+pZmS4zsVTHy1Fz8z6M3++r2F/vbj/AMbZr+0foH9b 9BczRD1H3fpD3/NO5zsVdiqUy2V/eeX7eCx1B9MuWiiK3cUcUrKAoqOMquu+Kt/oXUv+r9ff8BY/ 9kuKpdrHlDUb9rORdduvVs5JpFMw4qwltZbfiRZNYNs0qvXlUcaLxrXFWMX35O319qVrqE+uRrPa mBgY7WdmkMEksitNLcXdxNMymVTH6ruqFBRaVXFVa/8Ayo1651f9IR+ctRiQi+P1YvcSIsl4twkc kXK4pEYEuEVOAH2NuPI4qyjyn5c1XRUuFv8AWZ9Y9ZbZYmn51j+r26Qufjkl3ldDI3TcmtTviqf4 q7FXYq7FXYq7FXYq7FXYq7FXYq7FWF/mDeQyxabAokEkV+C/KORF3tbkfC7KFbp+ycrycnJ0n1sR XUtOaNZFuoWjZSyuJFKlRSpBr0HIZRTs+IL4r2zllMUU8ckoHIxq6swANK0BrSuNJsIfW1J0i9ox WkEx2p/vthvX54QxmNkdkWSlPbQzFC4+OMho5FJVlIIbZhQ0PEch0YbGowgoItCx3F3aclvh6lul BHepuxBKrWaNVHA/Fuy1SgLHgNsOxY2RzRFylnPaP9Y4PalebMxHEKPi5cu1Oobt1wxMgduaZiJj 6vpYrqEUENxxspfXjq/MNUFD9pQrcaOu/Go6e5zo9JlzSHrj8eX2PMazFhif3cvhz+1D0YqQWoa/ aUU2+muZdHvcOx3IzTNRm066iuYUR5YnR1LgkEo4cVAK91yrNpxkFSJbMeYwJoDcMpH5s+afVqYL ExfyiKYN/wAF61PwzFPZ0ehLaNWeoRq/nHqCgBtHilPdxctH/wAL6Mn/ABLKz2cehZjVjuVm/OUJ E0kmkU4KWNLivQV/30Mgez5DqGQ1ce4vQdM/45tp/wAYY/8AiIzAcpE4q7FXYq7FXYq7FXYq7FXY q7FXYq7FXYq7FXYq7FXYqwzz5ci7g0uG1hnuJUu1mkSK3mcqrWtwo5cUPFqndTuO4yExYb9PMRlZ YHdeWNVlvnnit7iK3eAW/wBXbS5ZOKrUrxYp05HcU3G22xFfCe5zDmhfP7FqeX9UtSIbb6zavKGC BdNYM1FYCn7scuA4nv032NMeE9y+PAcj9ireadrEGh6l9bjvJmaOdxM9nNEqIYioU1TgAtK1x4D3 L48DtaZ5U5TsVdiqV6jo8UgV7cFZOYAiB/c1llq8pjPw8xzZqihNdzmTp9Qccrq3E1WmGSNXX47k juFurWYQXKIkpXkvFVZWApyKNxFQpNDsD7bjOg02phlG3Pued1OlnhPq5d6n6z+C/wDAL/TMqnGt 3rP4L/wC/wBMaW3es/gv/AL/AExpbd6z+C/8Av8ATGltD6lO4066Pwj9zJvwXb4T7ZXkFRPuZQ3k H0Zpu+nWp/4pj/4iM5x26JpirqYqoX0jxWVxKho6RuynrQhSR1xVXxV2KuxV2KuxV2KuxV2KuxV2 KuxV2KuxV2KrWjjdkZlDNGeUZIBKtQrUeBoxGKrsVWNDC0qTMimWMMqSEAsoanIA9QDxFfliqUed EZvKeslZGTjY3RIXj8X7hxQ8gfGu2A8mUOYYBmI7t2KuxVB6tNJDaLIkgjpPbh3YAgIZ0D9fFCRX tkgxnyRFxbwXELQzoHjbqp9twQexHYjGMjE2NimURIURYSO/8vzIxksz6iEj9w1Ay1JqVYmhA22P vuembfTdqHlk+bptT2UOeP5JODXqCpHVWBVgaVoymhB9jm4hMSFg2HSTgYmiKLeTYuxVRvVZ7OdF +00bgfMqcpzn93L3Ftwi5x94fRumf8c20/4wx/8AERnOu1ROKuxVDan/AMc27/4wyf8AETiqJxV2 KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVIPPNkJ/K+qy+tNE0FldOBG5VX/wBHkXi67qw+ OvzA8MB5MocwwXMR3bsVdiqB1mOOWx9KRQ0ck1urqehBnQEYQxmNl8kN7D8Vo4lWir9WnYhdmNWE oV3Bo2/LkDQAcdzhu+a0RyVLe8imYx0aKdApkgkFHXkobtVWA5U5IStaitQcBCRK0FqNvo13MyTy JFdxcKyqVWRV+0ELEdCD9k+NetDmVpjmh6oA19jiakYZ+mZAP2pDdWstrEJ5GSS1YAreRkGI8iQN 6nj267b0BObvT66E9j6ZebotRoJ49x6o94UsznBVLaMSXMUbdHdVPyJplGp/u5f1T9zfpv72P9Yf e+g9M/45tp/xhj/4iM552aJxV2KobU/+Obd/8YZP+InFVaZpFhdok9SVVJSMnjyYDYct6V8cVSS1 1bzbLbpJPoEdvMwq8JvUfifDksdDiqhrOvebbLTpLmDQkmljeEektw0pKPMiSnhFE8h4RszfCp6d DiqR6h5z87PZrd2OmrbpEl3Jcw/o/VLx2EEaekIxJHpkhkkmmVQnpEFQ7cxxNFVurfmB55s3eC28 oTXgFnLKl9GbjibmOwW6CfVzAG4vM4gUGQMWDdCKFVNvJ3nDzDrV/NZ6t5bn0T0bWC4+sSNLJE7z jkYUd4IAWjVgH8GqKbVKrLcVdirsVdirsVdirsVdirsVdirsVSXzlCjeVtZkJYMlhdUAdgv9w43U HievcYDyZQ5h5Pq9xqNnIkkclxLDPMvNYbcTejEqjlso5nkw677E0GwzGDuJEhDx3mtRzGSY3UsM bMfRW1jBYfFROQc/yncbfZ333dkWUztNTe4uzB9TuIVVWYzSpxQlX4gKd68vtfLBTMSsu1ZFNvGx rUT24BBI2NxGf4YQiQ6o7IslK4toLhQsq141KOCVdCylCyOtGVuLEVU13wg0iUQebHLzQ7625OpN 3GzV5qP3o5FjV1H2u1WXqT9kDN5pe0YkCMvT937HQ6vsyYJlD1ff+1LkMbNFOhBZfjhlWhIr3Vh/ DNoYxkN9w6kSMTtsWhEFTihKCtdt6dNhWtBt0xEQBQ2Uys7qsEskMsUvFXZJAxFSo4g12+1vkMsD KBj3hnimIzEu429RtfzX8vwWttA1peMyIkbsqQ8QVUAneUGn0Zqz2fkHc5g1UE3X8yPJxjDtfFTS pQwzEj2+FD+GV/ksvd9zP8xDvdB+ZPkuY0TUCN6fHBcR/wDE41yB02QfwlkM0O9df+dPLEtlNFFq EbyzKYo0HKrPJ8Cgbdy2QOGYFkH5JGSJ6hkmVs3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq 7FULqOm29/Zz2s/JorhHSRObhSJIzGQeDKePE9K+/XfFUv8A8GeXP+WZ/wDkfP8A814OENniz7ys l8l6CUpHCyNUfEZp22qOQp6g3I6fxx4Qviz7yv8A8GeXP+WZ/wDkfP8A8148IXxZ95SPzp5Z0Wz8 vvc28DJNFcWnBvVlb7V3EDUM5B+nIyApswzkZiyxzMZ2rsVdiqVajpVnNOHY+lNckJG6A7yKjtVx UqwovgDt9rpmXp9XPFyO3c4Wp0cMp3596TXdsbSdoponArSOTl8Dg1I4tx+1RTVeo+VCd7ptXHKN tj3Oh1WjlhO+471GsH8jf8EP+acy93E2dWD+Rv8Agh/zTjuuzqwfyN/wQ/5px3XZ1YP5G/4If804 7rs2hgN1ZfA/+9lr0Yf8tCf5OY2rvwy3af6w+jN80Ls3b4q7fFVK4mMKB6cquiU6fbcJX6OWKquK uxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2Ksa/MKJW8tSyEtyWezAAZgu97Ad1Boenf+ORn ybsH1hheYrt3Yq7FUPdXDRT2aBC3rzNGzVA4j0ZH5GvX7FPpyQYy5hVliilQpKiyIaEqwBGxqNj7 4ASDYSYgiikl/wCXnXlLYksNybdjvsuwjY+JH7Z79QBTNrpu0zHae47+rqdV2UJb49j3dEmJ4yvE 20sZpJGdmWu4qOoqOmbrHkjMXE2HRZMcoGpCi7LGDsVVLaNnvbNR1F1bt9CzIx/VmJrT+6Pw+9yN KP3g+P3PozNE7J2KuxVDah/cL/xmg/5PJiqJxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2Ku xViv5h6fZvob3rRD61FNaokoJB4veW/IGh3r6a9fDIz5N2D6wxDMV27sVdiqX6tE8smnrHIYpPrX JXpX7MMjUIqKg0od+mSDCYult7q09gC1zZySw12uLfiyhQnJmlDFDHuG8RSnxVNMnjx8RoED3sMm UwFkE+5E2+pWNw/CKYF+XEKaqWIXl8IYAtt4ZLLpsmP6hSMWqx5PpLV/p1reoomBDpy9OVTRlLCh p2PjQgitNtsjhzSxyuJZZsEcsakGOX+mXdj8Ug9WCtBNGpIHw1JdRXgOu9SKdT2ze6ftGE9pek/Y 8/qezZw3j6o/ahc2TrUdoaK+rWwbpyr9IBI/VmHrv7o/D7w5Wi/vB7pf7kvoLNG7B2KuxVDah/cL /wAZoP8Ak8mKonFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWNfmBBB/hyeb019b17NfU oOVDeQ1Fev7IyM+Tdg+sPL7611OK+gFqlzPau0jzuLlV4vITxqHqfTTkdl9tjSmY4doQb2UrC01q 0ZXZbq5FfsT3UbgVO5ICD7IkIpyoePyOJpABCaafc6nM0n12zFoqqnp0kWXkxBL7imy7DpgLME9W r4P9c081HH1z8NP+Xeau/wB2EIPMI7Isko1Ly/BOHktqRTNyLRn+6dmIJ5ChpWh3XxJIbM7Ta6eP bnHucDVdnwy7j0ySj65qtqxjkea2mZOKxyENQKAaoDzjPHmKla+BzawxafOLAH3Oonl1OA0SfvCM i8x3ik+pHHKoSigVQlx3ZviFD7LlM+yYn6ZEfj4N+PtiY+qIP2frQ93JpdxDJcRA2V0KloypaORi wZmpGHO/xfEADvUg44ceowmq4ofjkufJpswv6J/jnSzQrqGO/t7i4P1aJSS5mKqFHE/aNaD78ytU TPCaB6dPMOFpgIZRZHI/cXvllqul3wrZXkF0KVrDIkm3+xJzSkU56KwK7FUNqJAgjB7zQAf8jVOK onFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FULd6Zp93GI7m3ilQGvF0Rx9tZDswYbsgJ +/riql/h/QP+rba/8iI/+acVWP5b0JihFhbKEbkQsEVG2I4tVTtvXbFV/wDh/QP+rba/8iI/+acV Yp580mxtI9LmtbaCDlehP3UKI1PqtyW+JaE1+Hb2yvJycnSfWkGY7tHYqpXNrb3ULQzoHRq+IIqC KqRQqd+o3yUZmJsGixnASFEWEivvL9xGS9qxmTmCItlcKSNqnZgN69DTpU5t8Hal7T+Y/U6bUdlV vj+R/WlizIyhvRC16q3IMD3BHLqO+bbHLiiDfN0048JIIb9RP99L97f81ZZTG3eon++l+9v+asaW 3Fo2BDQoQeoPL+uCltRFtYA1FnACep4/25Hwwy4ynHlN1HnDQgsaLW7oSOVaejJ03zD1sAMew6uR ppEye909807nuofHFXU98VdT3xVStZmliLNSokkTbwSRlH4DFVXFXYq7FXYq7FXYq7FXYq7FXYql OveZ9M0OSxjvluXbUJWgtltbae7YusbSmqW6SOBxQ9vwBIVSDXvzZ8vaHdSW97aXw9OK3uWk9JEA t7o8FlKSyRyrxk+B1ZA4P7NKnFVW1/NjybLFpRuJriyuNYERtLWa2md1aeZ4I0leBZoUYyROKF/2 SegOKq2hfmf5M1s2yWN45nugfSgkgmRqrE8rCpTgaLDIOSsVLKVBJGKpj/i/QP8Af0n/AEj3H/VP GlXWnmzQrvUotNgnka8mR5I4zBOo4R05EuyBB17nFUm/MYTfV9KPJfS+vCi8Tyr9VuanlWnh2/sr ycnJ0n1sWzHdo7FXYq7CqTQ6bDqWnWl3KogvZYY5JXh+yXaNQQ1ftAUFK70FK5k4dXPEfTy7nDy6 PHliOIb94Sm9sLqyb9+o9Kvwzruhq/FQSfssarse5oCc3mm10Mu3KXc6LU6CeLfnHv8A1ofM5wXY q7FU08pKT5x0IgV43dT7fuZB/HMDtE/ux7/1uXox6j7v0h75mmc92KuxV2KobT/7hv8AjNP/AMnn xVE4q7FXYq7FXYq7FXYq7FXYq7FUFq2h6LrEEdvq+n22owROJYoruGOdFkUEB1WQMAwDEVxVD3Xl Pyrdwxw3WjWNxDEiRxRy20LqqRKyxqoZSAqK7BR2BPjiq8eWvLirAg0qzC2vpi1UW8VIvRLGL0xx +HgZGK06VNOuKutfLXly0mgntdKs7ea2qLaWK3iRoweYPBlUFa+q/T+Y+JxVMsVdirCvzDgu1/Rs rXJe2e9VVtiijgwtrolg4odwQKHw98rycnJ0n1sbzHdo7FXYq7CqU6NbXMGkWP1VwytGkjxTdKOh LBHUVX425bhvDatRIlriCBsiV1SzKBbv/QpXqDbXRRWNAtaUZkcD1FqUYipp12xESeW6TkA57e9L 7/y6o5TaftUEm2JJViTX4GJ+Davw/Z6fZ3zYaXtGUNp+ofa67VdmRnvD0n7Ckzq6SNHIpSRCQyMC DsSK79jTY9D2ze48sZi4mw6DJilA1IUWssa0+8jRB/NFix/3VIHH0kL/AMbZru0voH9b9Bc3Rc5f 1f0h7lmoc12KuxV2KobT/wC4b/jNP/yefFUTirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVY d+Ycbrb6YxlZ1a/FIyFov+i3PSgB79zleTk5Ok+t5tca/d210bGee0W8S39VqrMFaTqQgHI8UUFm 3rQ+xymnYGZGy6z8wug56lNAq+mSyQxT8g68uVCwPJf3bdB12xpRPvTaw1G0v0ke2YukUhiZiCvx AAmlaH9rAQzEgUQy1FKkUINR7GtMUkWhNFFNHsRWv+jxb/7AYnmiPIK9za291CYp0Doa+IIqCKqw oVND1G+GMzE2DRROAkKIsJFcabqenyvLZMz2vIy8UJ5huBDcowKSCigL1boKbcs2mLV48m2YC+91 OXR5cRvCTXcpR6il60YvbZLuOIBRPGKSo1AWNR/P8NQOP3bZedDwnixSouOO0OIcOaNj8fjogvq8 nqlESUwigWSVQHOxqWCVFNuop1+yMzsU58pge8OBlhju4E13FO/KdxDp2tQ3d0WWGMjkQjsdnU9A vgMq1uMziBHv/QWelmIE31H6Q9HP5l+XQdkuj7iE/wATmu/J5O77Q5Pjw71FvzS0EE0tL1qdxEm/ 3uMP5PJ3faF/MQUn/NjRVNBpuov7iOH+Mww/ksnl80fmIrf+VtaP/wBWrUv+Rdv/ANV8fyWTy+a/ mIsm8u38V/o9vfxq0cd3znSOQAOqyuzgMASK0O9DmKRRpuBtMqjxwJdUeOKuqMVdirsVdirsVdir sVdirsVdirsVdirsVdiqUa35dj1dbWO4uZlS2lEq+mY1PIRyR8t42qWEu42Hh7gi2UJmJsID/AWm /wDLZdffD/1SyPhht/M5O9afIVl6qhbq59Kh5sWi5V24gD0aeNd/7Hwwv5nJ3rv8Bab/AMtl198P /VLHwwv5nJ3rW8h2YkQLc3BiNfUYvEGFPs8QIaGveuPhhfzOTvYFoopo9iK1/wBHi3/2AzHPN2se QRmBLsVSzUNGhu7hZA/oOVcvwUfvH+FUL+PED+3MrT6qeLk4ep0kMpo/YkV9ZXFlKqTgcZCwilU1 VqVIG/RuI5cfnQmhze6bWwy7cpdzodVoZ4d+ce9QzNcJ2KuxV2KuxV7b+XH/ACgehb8v9Di38ds5 mR3LuQKDI8il2Koa7/v7P/jMf+TMmKonFXYq7FXYq7FXYq7FXYq7FXYq7FULqeqadpdm17qNzHaW iNGjzysFRWldYkBY7Dk7gYqk13+Yvki1t5Ll9Yt5LWKGa5kubcm4iCWxjEo9SESLzBuI/wB3XmeQ oDiqqnn7yWbOa9fWrS3s7e6ewlubmVbeP6zGvN4lebgrMFNfhr+GKr7Tzv5Ou7k2lvrdjJdiQw/V frEQm5iQRU9MsH3kYBdviqKVqMVTvFWiyggEgFjRQe5pXb7sVakRnWiu0ZqDyXjWgIJHxBhv0xV4 5oopo9iK1/0eLf8A2AzEPN3keQRmBLsVSy+ngg1qwkmJUPDcxhyaIKtC3xb0/YpX+uSAthIgEWmM kcciNHIoeNwVdGFQQdiCDgBpmQCKKSX/AJeIUyWJ+yv+87mvKlKcXJ2NK/a6nuM2mn7TlHae4+11 Op7KjLeGx7un7EmdXSRo3UpIhIZWBB2JFd+xpseh7Zu8eWMxcTYdFkxSgakKLWWNbsVdir2/8vVZ PJGio32ltYwfmBnL27uQoshxQ7FUNd/39n/xmP8AyZkxVE4q7FXYq7FXYq7FXYq7FXYq7FXYqhdT 0yy1OyeyvYzJbuyOVVnjYNE4kRldCrKVdAwIOKpVc+Q/K13aPaX9rJqEDxzQst9c3N2fTufT9VQ1 xJIwqYEIofhIqtDXFVGP8tvI0VtHawaPBbWsV6upR29vyhjW7RFjWUJGVX7KDbp3pXFVDT/yp8g6 cbc2Wl+gbW5+uQ8Z7nacGFuRrIeW9rF8J2+Hp1xVOp/LPlueZ5p9Js5ZpCWkke3iZmY7ksxWpOKq EvkvyhK0TPotlygkWaIi3jUrIhqrbKOhxVMb2zF1GqGaWEqyuHhco3wOHoabEHjQg9qjFXkWiimj 2IrX/R4t/wDYDMQ83eR5BGYEuxVBSOh1m3UH4lguAR/soD/EZLoxscTf6P8ASlV7OU268y8tuADE 5dgzkr1Vj8RqhHxGrBsbXh7l0F7Vkhuk+r3TBf3ZPJGYhiRFIQok/u2PQMBuyioxpRLvdf6baX0f GdBzUERTAD1IyaboxBp0Hse9RkseWUDcTTHLijkFSFse1DSrqy5yEepajk3rL+wopT1B269RttU0 6ZvdN2lGe0vTL7Hn9V2ZOG8fVH7UErKyhlIKkVBG4IObJ1jeFXvXlOMR+XbGNeiIVHyDEZy0eTvc v1H3pthYOxVDXf8Af2f/ABmP/JmTFUTirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdiqyWF JOPIsOJBHF2ToQd+JFenfFXhEkuo22g2tzayTPW1t40t4YVmKmnxy02ZjxOwrSoHjmL1dzuI7L47 7VvrJb9+9q26g2gVwGCgbl1PVgfsVHxBht8LS2UZb6w81zFB9QuohJXlLLHxRQI+e5BPc8fnXBTI S8laUgazbKdmFvcVHf7cB/jj0W7KMwMlK5toLmB4J15xOKMKkHxBBFCCDuCNwcINIIBFFBSR6pZg G2P16AAD0ZWAmHYUlP2gKgnnVtjuxOXQ4JbS9Pn+z9XyaJjJHePqHcf0H9fzQ7eZouCGO3YvWkyO eHEjYgbE1B2oQMzcfZcpb8Q4fLdwcnawjtwni89klupWuJRKVSGSpL+iCocFi3xKxYV+LdhQn7s2 2n03hChIl1Gp1PimzEBSKAyc6sDSlAzBT81B4/hl/AHH4i54opBSRFceDAH9eDwo9wT4ku8qQsbJ TVbeMHxCL/TDwDuY8RVwABQbDJoZR+WMtPOtvFX7drcNT/V4D/jbNd2ifSB5uXpB6i9ozUOe7FXY q7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqskhSSvIsK8a8XZfsnkPskfT49DtiqSW/kfy3DbxQ rbNSNFQUmuAKKKbAyH9eDhDZ4su8tyeS9AMbCOBlkIIRmmuGAamxKiRa/KuPCF8WfeVw8meXQBW3 cnx9ef8A5rx4Qviz7yxLzbpmkafrWnJYDi7QXYnX1XkIKtbEAh2bjs9fpyrIKDl6SZJNlLspc52K uxVCX2mWl6B6qkSD7MqGjjYjr3A5E0aor2y7DnnjNxLTn08MoqQY3d6deWZpOvJKE+ugPCnKgrX7 JO2x8diaZv8ATa+GQUdpfjk87qtBPEbG8fxzQ+Z7gOxV2KuxVkv5Zf8AKd2vT/eO6+fWLNZ2lyj8 XN0Y5va81TmuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KoHWNastIt4Z7z1PTuLmC0j9KNpD6tz IsUdQgNByYVJxVjHmD82vLmhwST3dpqPpJA06crV7d5PTliikSOK6NvKSn1hXLceHHkeXwsAqpwf nP5FZplup7myaGRUb1baWROEkXrxzGS3WeNI3iDP+8ZSFViwWhxVMfL35meTtfktIdOvHa5vDxht 5IJkYsI3lYcinAgCFxyVivJWAJIxVMX82aEjsjTSBlJBHoTncfJMVWJ5y8vPe2tktxJ9ZvHMdtH9 XuByYDkdzHxWgHUmmKsY88ahaXOuadFC5MlvDeJMjKyEEm0cfaAr8LjcZVl5ObouZSfKHYOxV2Ku xV2KpNe+XYm+OxKwMKD0SKRUVSKKB9jt0226VNc2Om7Qnj2l6o/a63Vdmwybx9MvsSJ0ljkMU8bQ zqAzRNQkBuhqpZSDTqD+rN5hzxyi4ugz6eeI1INZe0uxVlX5YRV84wzfyW86f8HxP/GuartLnH4/ oc/Rj0y+H6Xs2axy3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVG7s7O8iEN3BHcQh0kEcqK684 nEkbUYEckdQynsRXFUs/wV5N+rfVv0Dp31apb0PqkHDk3Ek8eFKn00r/AKo8MVVB5S8qgTgaNYgX LM9yPq0P7xnV1Zn+H4iyyuDXsx8Tiq+18teXLSaCe10qzt5raotpYreJGjB5g8GVQVr6r9P5j4nF UyxV2KsB/MG7g/SemSuxjiht70yPKrRqAGtWJq4XYDv0yrK5uj5ljh1CwAqbmICgNea9GJAPXuQR lNOfxBdBeWlwXWCeOVo6cwjKxWvStDtXFIIKtgV2KuxV2KqN1Z211GI7iMOqkMvUEEdwRuPDJ48k oG4miwyYozFSFhjt7od7bVaGtzbqtS3+7tgSaooAbp+zvU045utP2oDtPbzdHqeypDeG47uqAqPu JB+Y2ObYEEWHUEEGizT8rP8AjvN/q/8AGj5qu0ucfj+h2Gi+iXvj/vnrma1yXYq7FXYq7FXYq7FX Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq0zBVLGtAKmgJO3gBucVYT58tp7zU9PENpNcxRQXcU/CC SRKyG2IBIUghgD9xHY5XkBPJytNkjEm2Ey+T9ZkuruR4pmt7plcwtpzMwKUUDmV3HAeFQd69QYcJ 7nJ8aF8/sVIvLHmCACO3NzCNiwTT+JJqpYkBAN6N2/a8RXHgPcozw/nfYj7HSdagtUiuILu5mBYv ObWVOXJifshTSlaYDA9zIamHer/UdRrT6jdV60+rzf8ANODwyn8zj72/qGpf8sN1/wBI83/NOPhl fzOPva+oalWn1G6r4fV5v+acfDK/mcfe39Q1L/lhuv8ApHm/5px8Mr+Zx97X1HUeXH6jd1pX/eab /mjHwyv5nH3pdqflW9vP3kVnc291WplFrMwaoAPqKFXlsooa1HyqDlabPkxHbl3OJqoYcw3NHvpM /wAudH1ex15/rllNAgXaV43WNvgatCwU9WpuBmVqtQMvCRtV/ocDDi8MSF3uP0vUcxGx2KuxV2Ku xV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVripYNQcgCA3cA0qPwxVvFVojjEhkCgSMAr PQciqkkAnwHI4quxVb6MXq+twX1uPD1KDlxrXjXrSuKrsVWiOMSGQKBIwCs9ByKqSQCfAcjiq7FV gggEzTCNRMw4tIFHIjwJ64qvxVaIohKZgiiVlCNJQciqkkAnrQFj9+KrsVf/2Q==</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:46febdef-04ac-4645-a174-fc3ee4805e5e</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:01801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>uuid:29e17876-faee-8948-9286-1741a44a591b</stRef:instanceID> + <stRef:documentID>xmp.did:F77F11740720681188C6A5613A2C864B</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 1/Kids[8 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0 0.0 422.158 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 269 0 R/Group 270 0 R/LastModified(D:20170110141200Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 271 0 R>>/Resources<</ExtGState<</GS0 272 0 R>>/Font<</T1_0 266 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 267 0 R>>/XObject<</Im0 273 0 R/Im1 274 0 R/Im2 275 0 R/Im3 276 0 R/Im4 277 0 R/Im5 278 0 R>>>>/Thumb 279 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 269 0 obj <</Filter/FlateDecode/Length 624>>stream +HUˎ@+w13}!Va#`yf,O'JV㞪o^\+J +?G#9If\\my%ֽ< )RA00y0%q8g*dfa"~^ݙJn?;WT,fϳ4q] M@n~ EyЈVjݣOl} ZQmRu w"Kf +3.+CV8#*98=r mMh+ar*CbZDkXw%/,y)+Bey:(*m '$z큊Ãxuu.LNĐ-1C5 s{9%8hTRuLJ9U+Pnvk5DX9:`Fl[wôg{[ & ʬpJÎ1ѫH˱E1>2eq#a͒W?p0ڏI®lj6=~ƷMC 1IS?11c&׳&d)V X˙x=L gs2T9&�V endstream endobj 270 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 279 0 obj <</BitsPerComponent 8/ColorSpace 280 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 416/Width 52>>stream +8;Z,f]b/+8%#*6:#bBF!#TIH=<5d"TNa:WslQH5KE<:,*8sF\XEJO,U8[?4=r-u5W +F&AL#KQ6Su'mBfgZmL%iRR\Ni.:lot<DJ>d4$9ik5(TGi;kinJ`N/P0f.Q<'%b"7: +Ob^,kV526j8[!O^Upqk.G^8p5<W<(5&JQK2<G8D!Lbq;L#Zu;cqLC(tf>k[*HUKZm +EL&L_2sHH]MXogGX*=B1b2S'D;g4PYaTIShR^4hV!._JJ4P_aik`[?+f;J(M224ej +WuFD%oJ$']NhH!.Aj]t#RVb55dl_=G2dh.3nh,GdKsLGH;dnAlQ0PGFq;&ql[ah]Z +?eOQkSl(:^WhJmfhrH5H#>*k-lK.7<(95f\j$@_Vrn1;tl[0VN)]NJq[dcpg.\Es0 +'5;i/eGgi`!<B`4)k-~> endstream endobj 280 0 obj [/Indexed/DeviceRGB 255 281 0 R] endobj 281 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 273 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36027/Name/X/SMask 282 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_<3 G0ѺԎtԊ[]T)o+(U�!jcG+:(MG{ +#B|33npJw U1~V9���b&*3"D,WInjƯ7lȌē{pvl=hRUw%߉$&h*gdm(^pt~G)��� ݈$'e+w?&^s7^cv/wWee%lm3fSߤbT)" #w==抽Ղ&mMZK(EwR[���Нip0F(~o?'v~_5 aCZOj]MRjԒd'81����ei'?؜ :8Vs >wunJgunP`SRZIϑkh) &<>k@>7L����#`cmݶ3`lq._W>=|[L$R遖nTϲ+($wvzzvL���0ȶmO;\a,.!o}-#k-Zv=ea\䤑���;43#k-& 5 +B^wi֣�Wc0o> SdФc_;0‚���SIBO5k~.|rCץӉ~}<˜!OngIlxZr4:FR-5���1 'Et׺KLۜM$.z|a޶J?+Bu!~)s#RE.zvy  [G ���\^uSr#=cZ>Bno; ߶H ?+J0dR +LgȊ+oqrʅB-# +e=R���FMMyDvjB^jZvlKDK޽sO]SqE�jۉ|},{+c|mNP2c +���<#rXF!RO +$`x_h0{Kt +CM1+o)UZ1ϊ\sf{���!Æؑc;w̕}2缮)wC߯sϗllO:1+C\6Wu^nTϲ+LOQo~��sivb\5 +E?"; iRϱx|"p3ْpl|#c䵿oYZqÆ=j���"x<t+;\Wk۫.>ͺ/]fӥc?+? g W^ +t#=5g.?;j";07g{���`<Iߦ߯>a>-9ŅC�Z0dV2Lm ϊBc1ygl��� [rd6k2a6݉?,esϯ%3أ�Wp:kcR?zҨv=~���`ٶ҃t +[Ä$-fwZ껒1tOC�r0dJ'LD!7/h7Yxl���`y=Q3Wog"^~i)�tAcDbVj7/l)Z *JL6a"۷���:Ǝ#!it?)rZ~xS+\QJ�tasȡ5&A`グx:a۷���!_9D}W.7k鶳)%MeA m? q|0K^;Ѥc_զonp_b}��wceaA,]nO|o1͋o5#wߒgG.0r?h|>%jF@մn\Z꽜#=>6`۷���^gbBOw"IsƢ?_7 EpIwNNd$9go5[.?G?ؽk۷ ���ڙ8b$9s `&->Gf>˞n{N)?K?Li7}Ӝ66UJS;}���5۾H=%ݥ8SK'#D~WTR?K?;6f<}2/ +Lj* 3=N?���s07'܉BM,1҇-fޣj\8?Drr9r3F%N"AtD]\C%]hR))ڵowJt{w[0au\3 f?593YV޵?#~թ/+IC�!AXK͐ҷ/׶ڙ\U{~4c=8���;vtr6,t]sX+NН6&GB=M:lYՊm:*mtZ8m�� Hd*& %1?_va*uy)"sRC?@H?wF/$Y7w*θxֲ CN981��JMݞ S鞭N^݄Sv3,;%3?|AFLzǓp9!>Yx Q�� +Dy*fFlr~MHoI}w97-bZ xQ~/<;k}<r`=R��ioJvT>QL0T{jjD/˄NxNj}ܳ +J𨯯Y}}֣��`+$|RDCw&ݕmE!ejYAe*ˊMsIeݾWZljZNH;z:��t ='GBQQfS7Wb|x|۠  ϫwM +2Д��T}}l4*echlݶ!֌d:{kJՊGG�!AxV/)?]E&μ:볞5��6sr葩?$5HvBJ9evI  Ǎf>9ˋS6wxY3yqroz���dp7Xv ,YdU^Zx-1 kb;o[#Me*-'А��ޙ1]Z\7^;BҖӅ[n:{l" GfQ4O^~?VuL_4Z+3?��2r۹$#&ʑW)q旵?L4ד` ='듃Ǡt}lCIfpǼZ}N{Ͷ ݳb,}3���7 I4*uZҿX8&I<hB}z3wr[͂ +?8eHs��O!H֭9tO]?SR0NTSmX}jPM_Y5nl ݻ_ l/_Fh.;֟��|"-.6tx-$"iߟz|1"n[Wq*DY8 O��HG&'"C/6ԓds#Iݞcىm $l3:Qr4qYtA[Eevm^%U���a>fXM +9qӼk/Q77HCmC6/?rʦu_׮[D璛:j4��zfAorSjsS_r܏3͍67l> GωΥ$KȖyQlo4:OR6ط{Q>?��/G'=uR>ir5NBojӔj)7`O G˒F\yO_iT]n;'��=. ⨰N@z[M`pK…_"dHg9;A�!AՖ̌-ᔍNrՌwY, e���cF{2k~xG?{p'<͛aJ:)gIlnz2э /3s~n7l4XB��Ѝ"{{]LNFSv"v`3#/mvtƣw9EWo󜲹.t_H̜<g��]YāOzvvKxY^eL$dkҮ]:h#/ <Z^K<$/Xq֟��|DsY^%GU:ޚ9O *ws6t8OZDRޢBQQIy9:��D9TbK}^=to:<7wyN.xuκMNt9) �Ą\C3qw"[rmVM�!bw0&t󜲙}ޝ_AQ]i>4Ј%u4C%:XW X.FV%A J�o_6 M7J%&&qEA@ʚ8AE1eՄL4So{dž q_X'sbmj{�� ֖d"H9f)wkB7HH}!>:tc)h@�@@"KXYeRQw:#a/aL +{Cf::IŲY֠QH4KfP��/f;ܷU_`'pkwiVbLqbR#|x@8c.AsHB?o֩O>4DF+;wA{0���^0iٿmPBo%)55Bqm0U\]ޡ=n6/ά--I\zE#j+)%skuZ/XXL(�c mz˂xWI>5]Eh-4}TUaF�JbĎZm +u`gkC0Omߴ*15a׺юZ(<I*��׋%Y5o>9S:ӠcoYd{}>1f TaOHŲ\~Ѳl{?[d2m4G{פݞM��0wr<6]RvsSז*Z^L|Hx_ Y#Gpށ-V|y֘{؇<Fϕ^dnX +��fP<"KieK[yXTV�SP.-bRu<#?vv?Н;)nk9oڠus'm4 +��$G8%};*ٍU"Z +˫%)j*R4'-uk#`5=]"Hb8߫ԙZKZ1V:Ҳ ��K,wM$I;Yα͏wD6rGw'ψ�S=R :s,Tȸ UGKZmy\M9S4Sd,63 ��̔&Ǣ\t9ol*gvSo/C-mD7st'{05#v0Bcymq4{/]N|ð2YfNsAZ+K3!>-=^��0 IJd"%}m.!擄i]E5?w#7~ř@@ +e}]C}-z]\GÙoJmk[ZL�DZ +&UtVp͞YJwPw=^٫:LeZmHwY#~M~3z̨bg!Ϫ6̡8u*i`�XX#ătSO߹VCTLhY !U}-6'm3T%PTHX0mKKJsϕ^}YT[zM%��^/nj%I;#GkskP۠kBr.6u-@],g.h+e=,WnvE|G��^ IԦEtd}ۦ|!vcn}3et'$ 34ۨU)/wo9~dG# ��E?kkBv4^Tp@'{%bJ!;c`NWqIr^Q'k[K:~_r̭@{+(�8F绾O2wq ^b8+և]j >N00'?jō|gLK[mmzNL=|�q9U/yvS\s"G:m5``N!IJ˱-*y}[i2lgw�f?p?a8}{*sŗ{ Z-Ouf C=\Z:߉�Z o�B++%MM)٦ +N6jx+B: M3/`&ٔg| YƱMj>|VA3J?8a#�OJN폝Uʯҷʘ{ +҇R{Kg:o?9_#?[F2i.J~l-XxFdve+u�@/b@XCBʕ]kɂa ! |RE�|.MǨjcd7eՕ4\IL2.qM kXKQ"QTTBD Mom@A4k(7DhD7Y(OSu=F&?sTҲ]X;�%, Ғb^*HWq47 )MXjG+m!=1G˩tbլtg <�+,7зAV=. m5$Y^o@YYM  w8OfAeЛt[l�/?DSo7e/E=Z9xULT $?T;MZQTm!!m+t~JS3gO:�nbP{r80pP<2;+^iփܬu  O\SFڒ_TD&Kigk: +�w@?j8/a2NCy'$ݝZafF G?@#ietcZ/HԲz-�ciaA<::S5V?Jɖ ׇ/xD�Bv־75jB|k ՛=&Ѭc�7|pZvI-{7ϛ-aOE4GVvN $? +?NsRMCs}BZkp%x��#D)Ssio'[unod_^uJ35vGD�B#.6TM%K?sGZe&щuD��DBM>R~aӒC$ݝl~D5,xq׮D�BIhQQ<j+_1Uun:S^ +� ,H2ND/9l>m֐<B$_VPhW,Jwm]{ hNN_K2L.L(obbrMC ��a{Y54 |毗f _>PvTyϡsڏ@H@sS;-(򜪱&ؿb9}z%3%X�Ac@oBy7J='.7aNi7�!Uč|.4*g#çf�u>d;f;͘?l]v;JB2<b6^^)M; h̸$iyVj.Y#eˮop`!�z,N̜EҎ.xYpcƇbJ6ΠBNyϴ ?@=Ak?'-=bNTO: uIJ;|(c0](>;@3++>o.[{kwL{ ؓtM3krC]QVV +b%�fɐvdϦd]HKm+]ye!ino-l )n'u*?}yNbwsS>.g\^0sX`H,-ɺnDxڷo*mk!+yUڴ?@=ՁdXQ<l+lq"zv� )Gxof*{% +B<ZyI^by@H̃D.IUt]盋 3?{�'#G萝îe4 uEڗW]^!>.Y`u@H@!#ِ1FQkO:A>Usl'{ ~Xd&^y|PBO_}m<Tas@H@!9|W$KFg,GZע]84Zt&<lD:r�*brB:ZP)ڍ>No&۱٪ Ze+y.#-ŋFjdU �?S#3x.}WDQ5Q­b'A߾7_M15 $?Pw$(#fS=i;*;}輫Ow`?�+c#AACEtno&h VC^jmtnJi�!$.7$K7_uuw)FYŬc?`cK֬&3[#k\|=tw7{,ɼsӴ?@Alty9Z^llZY l(kN:ciaA\\trZUdATU>մ?@A\^/S59:q?U D ןu$A/b愉$!b$ZvೲϹ6k>Bz9�=Rbð%62 JDSRI\r%Ʉؔsu~'~JOڝ] e5kYWy^ YWhS?;:&JwaQhVC!RsrɍM+W=f Srۻo,>Wӣ^pFw�XL2ͽhS?iMELmKsK|:q'x"ZcCC[g2&2_ +fv5@@s�XY.; Ѧ@w7l"rFѭy5TrΑ|)#{YDbəBy|ǎCe6�йq +YͶٚ +Ѧ�ORZF*b%8&vߣtL;?N"#=[k CSMkg�(`ZQW; +Ѧ�Y7M><RM.Vn3" ?b G� #Nw2Qd\&w�8?:Qs? wMڳ%q5#!g૙e*Vz =uBG9drA<h*_pI\�]?m +gaE\wJWHogeߎe*9Sl=qtp?7$D.K JW�vHvz??m +@L}>&…E +G?)9N&:>={=H;gQ$t\JeH{UߌS�@1E6mfYgy->gyv%?k eƴO?nQVR\5;M,%$ޞ�W۰4wMA�h;Ck!VS5Wwl*_@gHo|4顧GyT;+bM^7 ȑ�mcVchS?�>܈Xj>:;7l~B3UrQVs]]G̙: X]>-\'8�@SuXtܧA@)�?[RJeꞖnTُ)b2x ㍴Æ~TJsf�ۭW1/=}hS?�>N%~Ss XVV,Y1yŎ]t$?|p|97E3c"Sxe2?B9��S=f~/5Hg̜bQZ\v?Ks.𴁽1e W<Ȏ(iȳ5Xݝk A/K\YH*y\j*|��N4V%Nc?ΘذLIR~=oj/aMz9OԻnsfϗ%fg>K7mx*tXN&Asrmz|`__˝-��Z䂥ѫg錱89ɒv-[9Oo@J;" n?y<`ibdԞA(s r״@&RsVv!<o�@[#f�=rzs ]))kГ9@ MHptCrY\T$Q/@{ؘ͈s"VSunB#��>l7oXe9lceymp_RLNq>b-:XЊvLJG/+xG��>FcDzG {s ]%պYw?�:Ƙ$Bl re쵆<[;a͛ҝi=3&DT%7'*V/��|*e.3ys bc9p,S6EJ=u. n,vWj쯧gIW0S3?IȦg̳%|V��+.睁՛i̚<v6en-ɵzz-ۖ쒜^ UťYL<yl>}x112"VI +EV|U{ Ip7��hO-WLЫ7Y$h C}_<;�-gJ2钬B޶34�mՁ5(eག0!2Kn! #YI*9P^Tl4��tJ&q3흌iHgLo$#Y0LF.xXsg)w82k\gΟy;Ǒ3{ƫ,+:&~8͕��;f(d^:0 ElTTsMS2:Z TQ5`nx7 +Q A. .g/g/ (κrTFTK&TVAu|$}yf~A?%Ӱ?[t�bg/1_}�ը$^!ӆ+w?Ϳ[ɿru} ҿymC&R{f-}��ݭۖl227Ũ[/2Z?͛SH(J<_'ԫrZe]'c<߸I$,pĐy4tAݪٍ_99{��[cuB ob9(+Obߞ}�M6D}UΪ궇KE.U]zQY/'ۇOiffSw#kP�`J( *w)�3&g(G^,=ltwgg+?$56f,U6͜lY8yu��[^\S*`�ؾiyNWeSF*;KyQA' U|f?gU!r9�hS`�؇aK&-c5 湿uf^C?Y9w89,,Sؔ(%�o8�=j:yPa^` 4|LrHi.N4E/vvH^hgߤ y,sk:rV/n�ػog4@h +q !2ǞdWͬ9Ye~i#"G}vŻoIli'_%SX)�I)^cv?`ƬEvǢgQqV{OuJY<<F JWr=3&ycw?H_ �@jSnnCac 4}R>]7<RJ\F.++ܲbt۠d,K?fSڈ/s#�2��* cž@h +�^^g>?yJ9i3[7Ý i%6lUq,Ӓg/w i"JLtnUHR]$-�p$u˅�3r{^^[?'Vk%uC6?+eiwJ}=V�Y_9PM�4̛q\4q>*`a]˝CȅRݰ.wU'E"�8:UF%u`�kD Us8S/�pm2WM�ԄNEYoL.*]-}�'& {)�a` YʪS49ww��XMyac 4џ1d})B��~±ڮЬwݍ�䟼Mkbݺmɺ o.�SGe+xCM�p\L#)̪>1uط�{GHz?�.& +r.h<q:o0�#*]ݻ?E4BS?�' &!qzj:]�8ʵc^ꆗ�֏l]ʱ.^u=g�Q4v3BS?�I9朗4Ŀ��/I"d`� Bd=Xu+jڻO!w�V-GIip1BS?�45f']Qc7$�QG[|N޹T"a`�/Wzsc5cv�h;Ε/uq@h +�/#>$Ѫ3̪[i4X{ �@[{gL`@h +�< !E W̖H6�[kW_0Ob 4�4̛,>D\XMǃ�7�o FӷM�׫Q3I0KN)�أ.fZ@h +�</3d."c]?+\"-�'kW|¿W`�&J"*g929t��{NYi[?�/gL I1(ۆX:�멏 +/c-w*BS?�EZyȜLgwæ Ŀ��M%z]�xцEX&m.j:qbx��[t>.4>ޣM�A2ɱB%wN ZĿ��fM|:kbO`�@r !+~Eua?Eq8Ķ8:FGZT,FDD#bE0x/. Dbmfl6{dl1j|^΁W;=I櫥A圱)� +nj0O8v'h)�" (Ijg/^u�˶;A�&ą7XMjSG!�tE{Y] Z +h "|eKM1�@ r= Z +Jtxoթo�hMg|>؏?�C黢Y_p:b1PM��zl\vnd-X:FZgIScb~v;w�[qDR�\ٰMs=|o�@K)_V/uBR�\O@;Ezl{P97_��/[b1s<d-](mUDu"K>o�x)k- A�w3qG9TeƯ>)3�`S5k Z +;O4U"[Je/ w}7�wUo|c-n+'c ++*"�Jd6_Ǯc-ݵ*J\b`-O/G�R;lIZ@Ǟcw1F.]Ӟc�Њ^c պ>o �x yOA\=zGɖڒCk�mߖVCm*b)�<9zoiP)-Y8LZ"\cS7WL/�o9inގ y<.t~gIRlvF*l�n3ve +-ʵ! :�d';ɹ36uio �xұ1Uc?fGԪ/OG�?,%EtT6~:{�Zմ?w,_3y~ߔF;�4 t}K˖;�ܦvnqqK{AZ:#~K ݡƜ?оĕO�8>t4{߆>M1=Z,�v]&ucg?HK{.Ҽ[G{eQқ_kңTh6ܻ;\>,GR`{vJܓf%%F�F8):soڃY?C mKv2!7z?+e~ToA װs#h7D� /lk,;vo�mw;7f5(NcWv&l(x:#>t�hqp),5v`lQkN/&6ܱd?]ج]R`(1=�QXO&=N]@*[u^bw}5f=�87+ddK+�Ю{eRoחkG?�6ZZcoRXC:Q�hӽ7+KF5"R�l//ڗ5"" +�mrc|B}uh)�x6JItD6])-O"f ^0fg Z +�O R?\l]-�3Kd g Z +�^%Ml"&)'H}ݭZyD6]q7?�uZ4\Z6XԖ*+^;R�luIMPuu* �SWrLgu h)�x9ڇf2jýO4�LJg Z +�^aH, nm,j-㔴\c^a-�-cئIVUغ󎆈o�c; [3r h)�h9>RHҦdR2hD;TP;WKDKa�@9Q*'},q:�\˹=t9:A�_m`5U{6o�ښt&.'%Yw?�yӯX,7,S@٩J^7DKa�ﭛ!%YAber�qʕ1JR`-�*J\b:o-Oh}dz2.Gg q?�@^c xL6^K)к)k-g:R�:x%^n(SD�ZM1֬5Ov ?�zʪ8~�EPWKݼNN5Vn^61-lzE2WdH" +sxA ޯ /R;5Ng9|9h l9 Uj*`h{@Pֿ\`+�ީ!(;^{F);@Pѹ<`+�mtJtKݷNƭ)d~OU*rM=E�X)�~",[gTv] o-'Yg�X)�h>LJl,qlמnؿ?׳u}lv>X)�h^ 2ܩ\\sx$_N +2wb?�y10c ?P{zFw;_fǴ1uc\W{g+�[p4ʥHbcR�+~LH;g+�_`a=>ER/?;9~Nnwb?�:'+IԞJϜ^n~o&GѻmR�`=S:3.Ev:8N +5_0vq]>hkwb?�:E K?}۳AjTښݱ�軞GcCVջgR�`mVN(.kԽp}-_a>zw V +�/ <HyE݊xRk11޷k}Oq7 V +�Z)R6Ӟr#.�=vϢѺ V +�Z7m[*r)^ 3--רZ=RfJa�@>eaA|åJ7/T=<u{b?�e7QH-ޚ Ne<.4w n00|?�� Bw*-z 'bO4-ŝsƸmtb?��t|MUWˀit6Ja��~*ht-%%FU}sg>[.$X)� aOQ+\shP{= ['(S/A�<󶐠nY+9_HnkzW_SUxJa��bQbxΨպ2X7GdN?��4ondh"߬Tj7{`_N*tWX)�z~d!͹-S{ݕ~BМݨJٙQftsb?��D`aƸeKk~53w=h.2thtob?��Fר2yRP_ͻZI?ܜݙ~4͹-Ja��aZ[{&a~S%Y+I6/ 0H(L)/ϗJ a�%$rUj*ݼ}h�{vǜ9gWxkl'xn)=S"'dYFa��ދBeHܹ5;*rPɊ1)PQ(]Yσ|�h,S']҄I<Ps/*̌0%$gE\_֭9�1uA RS׾+]6Ujޕx9=glۚ(awW MX౟�^\>Utصw=o~E5N0~S^(FEtuMTT 9k? +vHRFc��J`Mߩ\\sD;1w?l.E:v)ϯA|/qf{6֭u�Ժ/!,4K{W._cvR1)ÌnA;CY xϺϔJw5sXA=��'Z9J\wW?j~P_F9 +4vt(3Χ!>Spj;5//mtֽ#׺&�ٓSk.O}`3 Д<}w紛O;۲#]y}FsGXƲf��-ӱt$輪 `-2?e+j%sނ~c��ɸ;NK?].Ɣ?~L\]? cJEٴjeSM"=UwP!?��ާSd(Ro7#V?/ftiӪ>nI=rъBı5;Q?�[ \OFvY{O]HsV^M[Ja��Y@x0}^Tد;FmMZk3jj'c6E5֥hB&qF"(,8,c֠"K16q$t:m両/g3u~>;OΝd*3XTcm?La��<'(qp:RufSZ m?�~]~Os*?nصm=�t PfV庣1){$p?.evQwjD?��1Aʦd.~r]W A]fW[ 2�d>!JЖz9  [_~k[nD?��2 Ĩ)/pHϭG3{%p7by"S��8imKu(rBw 2�ʼwijݍʙclSLv* 1Xm4�@V&) ڞ(;g=q]͕3F7=4[f��n_^5~y|v} Gɹ. ?La��:az\s\d{'`YJ]Z/�#yvEՙ|>ܻDR7'yPsX-� Wf,^n?64W/=M|ET,vn?ku"S�c-`a=!΢(:k'W%9 nAd +�эN9ݕs|'9Iq\='iQ)��+]CF(hCw\q,xXZ5ە[au"S��W% +bͷXA晿?&BnuIEq쳺K)��mE\jCSU&祖Ecs΢,D?��VY2M+odo]9s`mT[d��/VPR\ $"8UzSaFd��|Bou7^|'\i[��ws -sJ^+<'.;)��!]2s Zu,= \;D?��?]TB3=9.ZT1mH}吞;f[��f@e}aZpm\ϭUSnAd +�159`hjCѫm q):wDb�� +^ R_+(|~ r+K7+)��߯Wӕe7 e[CopOeZȶa=?La��p+w_7tG]7mS]CSZ��#_Pw푂yp8?5ib��6Vd0 w_e Tn9WvD?��xt(~U9.ڦCdL߃!6u#ݰ?La�� ^0}WR?߅kۢAd +��q^wӆoZNGbaND?��/|¾5ԆC95kx4cZǤ Z��7qveE#t~D[=lPo`��}.΀B7Wg*'Ḹa}]?La��~~x4#z +h?l~kfzY��k†^V7~YC.3|?Æay"S��aYI#K5{RtoF^^fY4`��3 Yٙg>U%3̵g~~Q,=��'_}yb~U rhܟÁ,;��OXe7sjlҸw7*=gh 2� +SZQ>-H**'S<1g|"S��x!#i K4G;ܨ 1E|Ɲ5WN/Ժ;}c)��d彂]?8q~ k7"m]3tӊ=e54"[zzYV��@.vsګZƯO\,gW-٧雲?;ƼGCS/22ΞX7o +2l^3��ȥgheI1eZW9.?讍oVXT`NߓA1;߉{,_\7eŕ$1h<]U1H4FJW-T@88* WFGafX[J쪉ܲm?vaz~Ok~so����.`'Vkn\DXkL3\P>P6uWZ����\X`)#~ 87aRX5!g ήr-2cb=@Ξc����ӃaX^?9oTu;{3x^`ngYCXT'1����0X[조jΠS{ӕݍ@LExzx8}pP c7Gaaj!vݘ}����'-KU~Mh(Ӌ~'d_O7t5\h*L dǚV O )JKեSy͘\-CۥU_����p*@Yw5tzL@Lvys6e#N\/7kOB>?$sk=l����|f$n_Gk@?uY EdHpc)-u5.d�����{,c=vD]g ?-d[:M[<gtg R)Wt5_}.oKz m1MP:#G]~.'v;[J; #~PU'5y<}crEh*ZK㕺(V-x?%mĊ67(>;2$/;3Md����eeq]AurѬ36s gG uhN'fiJ*Q(-mXd(nGQu3QMEє()ej<Xlu{Y5w8+Ws<'GK`nB㘆wp07ƭi#ByN`>٫���GMŋoطSVqި['1=a> M"n^sAЪI3vtoTW?$~iA#00f$< +or~zV[L}X{\kio JѶ\AEh bmdz?S���¬X єESw'繱]sFL+Tuz@2^87T狖ҥnFy&iŌߤ(ы(p7=d$$'[Aiwg>EZ 7((ٗi3l9 sIZ@"K-r}ny^09G:���OT^ru78Cya$p +I +SaS[+ޏ,@޷ns9¬óCj=<Ƀ`%1nůԚe5y GvʈLOߘIh#"~9?>(i7sz+~Mosu"���WozQ[ChX*d_ÿΜ1jRՅ2=W ?e{]oCH*eHZ#3Q/k&U&٦}1>/.{&Yk*7hOEVC>zގ7Dw4.4H m9?t<G:���dY6ZC?)Z:uqg)+3Mo&bGdjBP=5JTwODqy/oBB"o^Gv4{9\ughs9ޓ{���`2.<ŌߤOCOqi_7wi$J ep^Y326mEh yQu3Q͂Lz ,܊GxMY;vya$2D����;<\Ig#f[ӿN ݐ"-_t? \),89FrB zk˓<  YZbSJYVC|t n7&#_@/ϋ~ύsˌv#~D����ͧnV4޺t1Qg_S?BR)C}<Zќa[8 % MlMbIk! ?(w<@(?Ӗ#_*Mz _ZML^Οb[���L/ӂ0; n0Ίanq݂p*EKR?u,4}S5Ǜ W)J]=; ύi}q;_v8aĿ0$'[QQXPw2~n٦2X7Oxr$IxEc^=?����L%±2$ 鋋f坻o~G5u/p>i8kuVQ:)Z<(cJxK!4< 3!!$K YQ06MYwz꺿vqwD8p=sN~7'qF:Ÿ)+dSGB ^fR&{iٌ|9+O Ym +v0{e ivbs; +juSJ>פgyƚ# y/9 [hɛ7=\źG*sVԦs-LwAA`,v!{WRCw&.=}s%+d))05xw&evtQOZ-[ʶzE[KH .P&wa7~>j${ |]kHC37sM0nHLL?^ "6YݔZ?cuП?Kϲw |7y-c?QaVWAsH35Y {J  d0SEU-dh[{<|2 lKaT{wJ  d(Η2TǣKt B05$ޝ`R  "ݔߗ0 +ߌ7 {W XDD(()zEj`2x̼5jv ÕAAYGҊ4I.in<!L4_] +qvÕYcAV!ՙKRF 9 JW}eњ ?]wƯi>' {-d?{>?YF ŗVB vÕY#ě}3^vJ8zcz%.dz2<(XGtQBAqFo&e>)w?:,&?.5wJM04y#N##?&Q&t6eVE s>;47)N~ʕ$0_8Xd.?0\)?SP?Mt͚8P}} wb/":s9bC[woD39rR>}}x|u;AR1nh Lؾ(m{[T1]5:ZZaRɹ6i6X*ksH'dƢ n;M${?J>xbEoD +__ ÿf +|/fu_-{`bUZ,5)ƳsrwS3ii;ja˻Kr5ZȁS̷(jzӱC3Z{GḊ]*gQmiڮ(Η�߄s CA%ۉcuhNDk _?0\)?^-2)lgupUOvR_[h5OE(/[cSP)O o{ rsM\pl*܇j^%]aVWk_d +qP[`Zц)s`ݣ\??1~2u/qA2|Wئ +o`]dX{,P_ TZ99QfϰtW`/ݔ~pU&ZBK& ͂حV {M;yƦj˷ywiڊ06Xsp}(u"63gE ;ZhvJQkG1^H9197+XD@͚A~h;^xwI;ݶuwW:.mtwXPC]noPd?Iy%gZ\wWfj,[֩47)9ȃkpֵ.Ragm;9-Mw9nJL2G;vU^BA#қRZɕ}@&o:rf W +gτ]xs?<ϚOUuYZCY]a"i)"mu)ݐ咴e>ݔ=y8x1a|s4yks!i6SG>imuEq=$mrc]c;]%kSJk Ox6C ȷSށ:פ~-Mpx_;j:rV W +gMR1aulLJT$ϭeZ.J?8ZߞP_o/nmmxq Oֺ(G]܁=<8 ǵ9Hl.dO=i!m;9͑4<8DIUn5 UA\{,m,UinRp_=| 2> ۔Y}BAo.,Z{ n=ľ{9#+XD@I>ӞGPP +.s/)pPk@Րf"{W7^y fna<Ч߱͏17Fg^E>fv氷/&4/X{O;GzF|EV +gaDkEi5 !Bnȋ/(֎w]gnzs./,nߙhC9!2K[f^ڼ^sIH=*9}mE[R���^Lo$s:?/_O*Vc rJWfM[6Ɖyv?tuA$qK e;+F^AI(p+RYs{DŽ;Wjpm ,=yY"��͔U~ +6W8Izƽ#6Es?9+AG=ugzT)f?^Fl/]c;7lhrO1-u?w8}v;MiͥsE}#XUs}�ŬG&XvBJT7}6zMsGLY8=���/>=HaLGKu w;qLDNāԏ߾aYq/c'C5GtKvU5jf/Y G=ki6)K[uZ'xm97C]Q_ZQb3س27W_Mw.y޵'̚MMY5bWW2nn���04v.ZY9\9mg rJW^1!]`>?9TQY/].;lƆHgЦO{NX*a@NubfʂnY<^vD`s-? e&]NI=}'<=h]0p<Ky5ZGn'y!ݯ;=rBwڕt!\viK3$+J��'j<pTZ=Rz Y4 rJW"NB}nirq',}[2TKr>#u-���KFM\˛ {?և.?NWk/5;@䔮`θnUYR?h]PhR��7ɨ.MUsddA'n"tU oɐߤVsJ����Y߷b@?O4.|ܬF=z'Kٛ m9R���cbdT-r:Hc`ת :?܁bj r/����]~E*nst8γU-S#S����uOc֨w8ʳyQsu?_Lw ١b r +����3{XNVP{~s!b r +����q)7li_S{ԖU<רЦOSS�����ml\s޿j Hpҽc@����w"6%<{h1Zu(15?9����>=ym{7=[SDD&DN�����cb6;{x{vL=?VH,DN�����<W 65dڏ{2poem)����'g4fzcV=ϙUӵǙˊ{Y̽�����xzo]Ȥ %O}a].kRC=�����xvd9g_ϳ)9 +q-Os5+-%1{?9����10٪ϚQsyjfKQ(1?+}1mê +kLל]SȄ^O%ŻL7k8ؽ{�����t,?`Tr5X)8sj=;&ƦL8!L^AA#G1Nej?w_Uqkڻ����̬,>~Ɵ+V뗴-o+()B^ؽ;ӻg eSpִ&&<Ÿ̙{?|(u �g p�gk eRU7l,퇚&j"E}׻3UkS/wȨ.UJ]3*3Vf3뤠A'j-"ԱA4n1A]EQy۷?;5/<(u �g p�g8[wyԧ?N{:4Xy5ጷ}[#;Qkb(7I]3SwMb/O}ytMҞD-ZGcFi3IOq䭦V,rVI]|3oI4>q7M"x8amַcAڌg_Xxw^],u �g p�g O~S 2O_f%~bf}{1ulPDfLP}jjTj}~?5q�9! *u+PWQiP݂ e,E";"" ]gw:zT?z D&!39o<Γ @ vн R>da/0`⸄؈^؃ldF @̱{`)?VQiՏ\Ic4����]._-^g"Cب^]/%~L}R�����C=c5ZJ0yR{dTj�����������������31yqaW?k_ioGX;-!W]_Ue=^ݻ&ȴ#zsVQ)G/^XwOT kşQVW.7ۦРzվ!MAaioK㹽q[R^7]Jb#X_keMxjϗ=涭62$118 +eU垇ʢ€ܔT~Z`{.Q]oK||iUi=rW9MڮuW?=W}0+sto5Bmo7!u]''9;u䨴 mڧPcBu,3#bU0;O:,o{j[+_cQsL}lbxCQDD2T"a5AČ׈h()s/3o`unb2w[Evjl*;Zu+ugؾ(*ͷMG T:>FP +g?<EUqQpgy3 ٞ{xP1kYg:>ߪ?i a6w Qg|F4~5q70:׮XL:k'#86>k|)tM?f2CtOT2%i,f~fN[Ea岄bЪUeg>Ȝ; [Š P;ؾh/AM) kiVgT#}Ͽ_Z&E!F18UJؐo::0H\y8kc8w;@=%JoK;D5LXk>(JS Z*~ۏtxϦGr|zlsDٻ0ǖ>V̺puj_VAq[ٹ,aQUg918PO}mxb?\;}4y옪"sq<%a;W&Y,O4!lDϾ֦RjlVQby#MUSsjl?e/iAzn 3{|.Jf%K*25G2TMWZ^!y옪0go0@ i C=ݣQcU̾ZMQc(+]?M Tf+^2l_=Ϩ18V{*t|GTx%nFZ0K?}_VQ}Xyj,ad2vWB +x;>莲r?jlV,]&Ԑ[p1cZ1KϞnn,6<BuJ.t +'zC*. +z˿D99^&Z)3 SD]YUt|Pu[ؐo a mi<7> +[;>B{05m[7l=zn9{&M&ctVWL|_qL5]m̜:iT}IQcp$to=Oǜ}jv[UkCGCHa{1Izhu7~/Uwz94㜜Xgj*svPconNPO辭X\.J$pԣ$l�l,Uoq=8#QVi ȋ 鼢7GDZ;5t\o=DUSD\\9K}aGsr?tW"pmjϕR]յ53ga. +.<KZ:fs1C퓾V@WrXdpzWԃ~}KIyA=ӝZyzk3JsrrSR%gCڽ0>5G,Q{xcioGX;-C=ݣtO,.:0 Zֈ^mV&S՗b\6ߪGzNg65?T8_'KָJV>ƷGݪBXOi= Q [b65����������������������������������������������������������������������������������������������������������������������������������������������������������������!�"b endstream endobj 274 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35579/Name/X/SMask 283 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_<(á 05IuƌI 8F<H + PD<*"( ,>ϳ<, , .ZS G'63!u2>5Oy?p~om礩6:5,���`1,Xvv@.ӫUgLqy7Lu.Iw8x8L lݬ˽2дmյx;ƈ2ЉsM [���LT�{RO_C%ecCq2iTpsHofՔGf망E'لǿ+T8| E.hNjrhZS+n?f +1;vI���`$3p8X"eto['O1/2S.'s|n6_p{ϭcU:υ���X.[k{ZBqn4,͙C.gNߴҗz|cEtkO_'Qͱf̟& ���`&88 8>XMveP3 };YvćZ}˹Q+jШۼΝ���m{qMVR,;6<1rl@^9ʳN!����^9r!̯ q _Fp|u%.'yӯ$Q3nj-����^yӢt?%y Sҍwqra+���x%:xOS| á?8xPᅉUnF?-ɳ钯]vz����/i*byF$%/fTxNZYo軇ekm-J���^Z;ϾdOp2vAnJyg껴?55lGEk���xa{7"݊D7pz7Ŧݵnq?6ɉu z���ۑq^�b1<sK=:.$轜 4BZk-���G\x#坘�CNm +[ͱ?l_=дŇ[ij���gr: rٚs]X<SN^rϐ|֨a'j?j+���x*1G;ͦ옩 yV +苦w!&fZNZWzA���<QnB"rO vAX?Ȍ۱ګL^\ͱFi_у}}Sߚ$���Tc= b!0h?* s=/e59-[X[ } ����C& VH2vAn!<}/ oXaynG��� lfZh9OD0S:#ky>~d]0~B ��� ^uXU~�1iaE'Kz^:^qӨV^���JH2c?Bqj[V 4!(eDtqx���`ezHK%hsc=T5l{Nmm>&���ʊ +RbЗ M_j8./M��\8]ZT�1Ar&\LPI19)"Hq:͉B���癢4]a>g� BIvsCVS.ACڷqh+���DU6K c rMt7i_9 ~;K���ӫU=;�1A<yÖRmdOuŊ[K] ~4zB#���PW�1A<x*tZ;QO㔷 ꢋ>˅>J���JNu=C?mƆxP 83 wr]S'; }��� V:s |3+T6/I{bTA;:qG ���\%GͦC?^lV?^[bخbv-ǴU:x��`HU* gb'Eo05HW1k~bq>f���L˛c +4dFrScoFg ���K5/LtG?^Se1sm#v4 igdgy3f +}���=( aA-&cj�o +h"*h!(w %܄o˲],M@jpΤq6Q,yg3 }"X.OD�u19eg +ɽ)HL&K3cun=���80S crPNw?JfRV\j��ihh_Yckz*<e]3#g׏^ 9D{UNɂ\���Y::;ځcP'ʫO\ү!/nlx.*Џbx<���T";ھ Q?@ (ZSnY-}=ڱkUT4 ,lXG���TrSmW9N?)ϩ݊{?T>|btҋ⤄ gs=���!k;]P'ܖY/^\('=oMn7a% z>���>?@ p_:6OQFF +#~2vuˑEVS3���~)G 1g*) 'Z]HqߕtyD$-*Ӧq=.���$v ;O+"}]ї>o۶|tE,h۱q#���JEv4Sլ9cw-E޵z^Y s=:���0N$O]?@ v:Z/$=u9vͿ!���ov +t_k=%)}eB_tlU]/()_‚1��w,-2”hFV?NoNs<Xj|uZ|ҿ8+=ݙ\���#ٱ-;~nfP+S6;Y*6 v$W4_ +H7ةL��+LL%z_P+Sȳȷ܊FF􈕊v~yg'eMQ s\���,# }P'SmOvՔAsF}DPZZ\���Q2-J3i HDkJR׬3Q;CgJd Jms6oU<E۬m4���r>2~jbK[Ǎ'-*8ܿn Ol"(z>"^=M+<{ùJF���xLA^Tjr#"6MS\"9M?ԯ,OSd׻m ˊn }?K��_(IzTUjDbhk)?يy4?9S]\ s5ɨu$��KhݍJT+ _ngAgCP2 +v$yH۫+i{" q1tt&}6��#{RPUrA*BM|1趗79}啭b^M49|Q-VUpr��N(*d*Lׯ,X8?S{sOIM1ˈ7 +132A��K=]^,  Uy_nnx<Mte;Ԛ$k vkbYq#ijN��Oj 3/"f +ׯYζ'<*V^VY9' ޕQW2jj,#|OQ~IY���o\ʬ OVM&;Ӑ?@դF/Vi)up^#aK?ȎtV@~4 ]'LӒ}xfU *V\@igהngJrbGE9鮥)_9&&枉[sb)y$.$g qڿuo/`&6�MU&{eI{ƫkZ<U'ȫ tEjmAÖ͆KJ*P5yϬ).H_[[RG#\,asF:Gx9=v#y;cӟ+gS$3o\%g;{&~VBce͗3Ź7GG~|AKQW�8("*㧥8/%"$m/b ^ ?ʫ ִ0ⁱޠcl"q0}~i_H9R'&&2jLK Ph +\�+h( +* "Eu4 ʎ@B +ncAE֭" :NF9GrNrνw}*3XA<qOoϒ&Ca�~��5@??l{O�+1)HڐJk̓[BZYkq^׫}C(E$vR|wo6 �yIڏ7"x{ьXQ=j:>\nN/ 8/g"|S/QP>P19IV,\G<<)4Ɏ~}`|6&v3{TfX +Ty�ټxɷF_Hq_A0,^iHx!Y^Op_+y5̓dϳq0y{Orw359>[0F:ٌ#K`y],LaoAk4}H`Xbs iW +`[5Đ n-}A>s�8@�p-^. =*5P۪3b2zݓ[BZYkq^W=*gyvnI9##yKn|S~XE}JvfFkA.Mc6LSRv-0bf2,Mm ' n7b<NuGᥝڋf?#˼ot0wH&Sp$R|r8 zO ꒟oP^27oI(,n'8w^-|֥qoˈc&ӂt{{B,`n `TҮF#$s4`d 8oeG!=u"cWS +$3)e$;m7'tk�N +7F_zRTa?"v3zr[\VB\윢Ԁ|I 5C886jqod+ }'%m(ց bv3G:4XQOpְ&VKFS]]DiC83|?y6�<{�ZPNb2zƣ-Nc~j9AsQW;$|!Q-.gd$pӓτ.}s~;{Mfg As,(c&uʈ`Y {fޯ/*^-ٸhUiy+ t�լ7$?-WtΌ# o;JetGvl9ԑ_Lg4ꍉ^tt/gwW57uw_/Rͫ.(J (H:#+:ʐv4H;g!o<lllLLx*Xhk2I|0Мݗ^YwRN)0jbFP2W}I62dyy@\VL!yuquL칵'Evwqd'�o�Ij0\J~\j4cHhyX> 4E ++% 7OB}So-<-ˈ㦟8uFd-8H'JU;Iw 9YX–h砧 f4%%1�dG.B3Fg=ɉ\\Cpzn _=,QJY˴u]q_XANlz!:f zzIGĎ(=ЭX;ι�&r8 ~LV{ Eϛiر|Lf3qPMQ,7or{E<:n^m 3QFOexNfDK ы=ՍΞe+XF}0Z**@QP+/3(M2fGF.F]j.οb_O;Q CbrE~!.55|[|�p�PtENxL?] үf 7ۯks7k?2, |z<Oȿ^sFZ@ooπk~BCX[˯J+Ig`Jr'[fEG"I<rx~59G'wۿsS0_cX KuZڠ=wQUe +>n ܝ,,]D"ݎ㶈aLk +{MlJu8z|tlEZweZpݶEMЭ L0�J\�h8 N'TNbū>29$zhly݋v#~_QMi `]Jgjk{,XmEE +pAdѱAdAdٲnBnd o˸"i×Yqz\9#_yN:U\RXvTx{V)В&CsK*d24LLRe*ONKJ >u9 qbDGInƩ&~{mBC' + 0Uv?}2}iii&;<8ֻqpuqE[]皵hqWc#rD8qrYsX_ 5/}cpB�m;jR*=TC+:~_BQ=mOz1mG(>,t&_Tg(c&~k  $!F +*EH׮SPKBע}ikt?sScz G?/[U\\+=!}7_߰mC(Էi yѰLhf.^@{BuGTZ(K\|(0jy*K*YUܙ@K?�6|W< %3|])IoR/bZ}o  +ڴٴT jK.G"$v%~Ap) $Y?sCHPBA7:fCo年&!g*M@�ߥWjM52H +�FبyێgyΛ VyO 6m;^̟&nGtHt*ٝk?6*~O$ +rHK-ey^Vӥ^nSM}� 9oCV?�6Ll3-=ԝ(|Qh[j+;<8:̟n:hiV%k{# ڿSvf8+~' `_sbUJޡo9,J?4^ ,,P:/[U}V`][�Ap0`3"6g'M@�I9e�ş>篮@trńۚ$VHjk^`X`?Y*ZZ  ȿ@IU'{]3&uM /ZcwWUΟhF.a9,!";ŠCa>#y2|*5O-" a8)duVB�p(8zr_ Slex6N8Κ�oQX-Mݩ} ^W |ރ jg $M@�{B ujMw -EY Mm&~#GZ#m:Ed!AKtG�5Њξ]} sL3H সd(+b-MѪ k\$vOso �l8T Eoe WԬRl.eaAz}kb,D1Ghem<EB!<A4_7ykhL PwE?W|!=qMWmm+sȝ3ʼV|OnU$W0S 8Y`?@c⿨ZP߰uoΦbUVX#ut.鄛n.A]ΟۍP A4f{,VQ? M@�ɩPBAN,ن]e *+J#LMIk񐿻'?-i7hӢc*jA6t8QUH]?�nIЊ_6}uI`*)iBk̹\f-N'zs<?s^|AdOf+ +Ɓ܃ :.r6t*ukH<ϒ6cƑ^/kbK!ZjImTzE 8|\\ȫ<�"p\*_LfWLh*̻3CzɌ�s梳Qʼ[>%(;Xo' U9Œ  s1={drjcT[| T>3;ҫ6c tp ߁d͋JAp8{[̤]R9`?@6iEgLWu;>tL{HZV<# + W;g4^Z?.\ "t4>P1o?�6dFH;LjԎp1[ +sH`2q5)4O;(?:QO<(;o`# Q Zu\]1,Dn<8<PPQQШ(xr st3=̰Ce+"elib$Veqx@Q5_^gy Ɣ�2b++/Fj{ 1`B\tT3tFAշx9Z%~Oao7Yܲ:K SIHؿu*��tTu2qӰ?C +!I2>{|lNjtѠB!g#3{C>fSťz5Mtyzk%] +��?j 1`@_`D*MV*-PԔ]4ӅS|U} +IMKۄPBDn'��Byǰ?C +%ݲ3,C70yZ݀T'ca>d&G)R3�+$5s@ )9Xct!C +g8ZT'ThY^_AB##O[lAS.&(K��,# .bHיe<nl-h$jʕ^J ϳ˼?ԒJ/v?] ��=e`@ )׍ڶd;(RnG9}Џ%L_(DM^)]O�@bT}8z?C +@6e%mqiX#DӪr #1"v# KըOd#�1tfQڎ@ )�3*rQ3thk_<>H/e-pr^'K4o "*o��tefo&k 1`�nnOrZu)K +~* >[>a"aқJb<F��o%bH�m>Na +Ͷinܲ!Np=| j7mjbl+w:k4;{\Myߋ��;b&6l?C +@l6#{;yXDO]86蔂m_2'FaTPR{��tKݾ?V=\E!{f\k.KcqUu</]MTɷ03\:3TD��н+CR?�3ِxpBCgTbO ruŌ|zʥwna5or5 \DvͭEn!��m?C +abr$-qw;in#Qy,o}#ed1a{&Yti,q|3 YyP`^�@ +m m6bH�xsQ +{Aȓî5rb9G~0:5Y`QZ2e1ʃ��~܎4l6o?C +۱3.9YC7j'Y3,%_r܍NGy~%:ʌŞB��񵑶k?}OC32%"Uɖsb#§[[ u�=c/r6]ӭE="r#1iQ-}>g�~ir}@1>Fx:K}t{eˍo6\-ɡ%ew:c#2,C7'Pyk��~P:=;8OfNqC:{@{?szol($|��~vw +.%7UzCױ?�tgaarnG��跟?zc/:yWbfbBX;?̡�Э3a+ Uv-]7��O\Opf֛ut ƍCޫͳN{?�zǸn$R[iz8��?%^\W s7bbl-a*a>ϻ=�kɉA +>[*Rw��ֲg3S@tYSqa74aFT UrY3.@{o,=m4i';��VT3t˽:V-Z7wAwZZ˔0KϐfW^|s`> Jp!=Eོl&{��^~&Ӱ?}�)19|nF?/Y /2q"kbFg+dwYZM��~T Tnso1 +2)!J-؏:�`u>9 (-nm�lqRv@1S'V/FO_kPTA1c6i6glLƀ$N b-o)ޢ ^ "X/#VIIz{=E;Dj_F@` _qʡUe�GJmbk ,_ލg_@;RW +T.] +"D�@|pZT樱) p No4z֣Dw�йkR=컭Ad +|3s:Owd�9-?La�1RgFK_%F�:^3 +[o�\^I-STb~Mi{*f�sJ7YAd +>)oM~n:_-7M3�{ۉR 2_]Y&R鳩}M�éu4.D?7n!2g[nzhf} �x05%;$ks= 2ቸ?+wKU_�Wϭؙ3"S\^\.6r-K�?]h\fMv; PeCS[nz8�ghKx"S WYQoZ7ڞL]�0CS/-,Jcs)@~#Scm~5Y+� G í= 2t c”V .\mY5 B�ghjK\ڡg�_/|CYSd~Sk{ +�3y)/XAd +HSvz}۵#sE*߿f~򬵳D?o(eaQژJMm\M �]6YD?� ]>M,+nv=ٵ>+*ugDe.oi)�P%:gӻtiCS[nE�Е7-x"S�ƏUVgkhmպ|AEc�*{[Ad +݌ZA2GSwM@v]6v]lOk'?La�sF(k^ܧ.| +"g�ՅQ?ac)�?ER̮+?ybew7�dRf_n7k?La�"?44O\o� o!w/{k R.5�?B4e'^)�b؊nٞN?VdTU ]7f>`|e�BbB[w14wH�l`v} 2a<5%yK8{qϺ�nFlvi߸QzAd +@G _qZqەUe�Ln.5']?La�H}bG* +?V uFD� n}RSAd +@g8II+پg$w�Moœ}?La�L3s:OzFŎ;�G-٭;w)%ə1*qmH/7�5ﲵIe�𨼒<[nYfvcS+@ Z 2Q5'LyokojUrnXD7�ׇe 2@A }k?Jmϥ~@TwǾϿ3D?�4n!vCmWs?�rH߷STߕ"S�D{<v`V u># ��".Ϫ*$@񇤷twAIvm^(-��9GK3Ad +@ U2SnjY"M��דw|} 2  ,SZ7^v<w�tڒ†5%yI 2 <fO5פzg�@g9Pj;B)�wL2;/}RSoM +N�Vϭ,y߿D?�gWyK:Xbamoo�HuǿYQ 2 ،U;i4o�Ȉ=)�o(e=mt6Wio|J�VjZ\)ܿD?�MU2݅yfܓ][@�T~`u"S�]HLw/ Mm}4.M�_f-\Gc`H}m=�Y P _Uc^0=ʌmRک:ZoN- Fm"jD0x!JJd ,ע삨 jkLl2I۩aID/3y+?']t�Gt%^ly3_H6r<|ⱷPܶώ.)�Af5 iyՓmQM9�Wx),s2\g}slp~�%wsM[4qv8Iw�:EK1ʝ.{w�Ԕ.rR??S:h1ToY|f�U]"iliyry�ܯ"¹?f'?fǺK=ݛ??�zO;6H]6_xtw}�]~;Vx_4#r/CS'O� Ԣlr.NW.;�llN6-!ܳbė~]MPbNM^'5�:DZMmVsÝ%YRrN6)nG˛ m>ݺKo= /OOiQ{e֤Ҡ>9=W:h6MKY|V{CWbܟXp�Ж,&mM Q`U~+)}Dw�SCrVd;e'SzRvsN6){?kZJ4@t��Q^~'Sv渙7e"�:ú(lnĕҿWowR+eS{o\_��'}òn5_eI�t _t_Fiud)~R}�6t]Xƚ37%�__ܝC %qȐ4��uߋ^Ph8c-MNE3*�Юە3W:YZ#R�zEL~ h7[tGMt["R�`cbSe=̶T|W-_rcBǵA?�t '-lh-wkN˚%�І\2-jA�<3rrvVdCxo=lQlW;?�LO4_۪+ _�_j׬> .R�. zwarn5_Ew�͓Q[Kn h)�~~T߭S'k׊2�ڗkNNR�dt+uMgwU9; mLEj Z +�>/K-8nJ禡{ �T`Wd,W+?�m]+6+7HbɡZszqN=a-�m+t}L6Z.[TM9�\+Sn h)�h{Wϔd[ʽ=ɹo]k9[AMR>U톰?�˻L{5I;�pXw:03^v?�ۛꜝe5l}E�/In?��1~5)hNO>J| N5Vnڽ`-�t+OV6xTĂ@=w$?–ܴ[ Z +�|mI ɹ+d`w]Ua5^dIy]F?��=#X妪k"a6nh)�p-^dsjvjHnm[k R�DIʍ>^ll'@)-V옠vDKa�k߹")liy2jk<= g-jwA�oNvMulFtݕ�<Y} `-� ln+]YL|g>Xs Z +�ڗΡc̓Js6xyYg{}=h)�h,&-VniDw(�$ع?DU{?�})Xas8gPz.ؖ:ǫoP{?� +/_:$dKíʀ~;S;W>DKa�v.PJόSzMQƙm߫�<ؙhYm?��홝t&[n֮2߯�| ݚؔNjoA�hS)z{3j`@]n.tW{?�@Fg[[_gO*Z�sPO华rS{?�@=lh-wO,5K|eȮJu\7 Z +�:fH[p>)z <8LxDG?֦"F¨ *Q$zTwx *J]؅xEh̨5rH;f&ֳ8De0Q>d}ueb?� 03H<aSr\b 3-ǺElβ?��.r0/3ap"T槒o�WqX9W1S�Ņ +ҷio3b`b?��^>„ 7~L̼;*+g)]?��<q§Z*Ws)kmt/\SJd3�x睊{ + +|#3gݯ>HW$)�@c#|{V9H"/#3KVE f +�Д1uꞅ[q"rrB[û`6=6*׻b?��1[,+oF֕P;`wNIbc3�hg n+Q[et#ú�3d|(\?��<K' +dp ВՔoٟRwLa��~ paθŪxѦȵl|Zol/K*+71S�ߢsTLjSr뎪յoy倖Dkf=c3�x^}P{SNg STwę`!79)$OT']f8|��<+m}u+u*ݺw3v;mM_Rn?&|x7ٴKI懆y̝8cK\[Ӧ{}��<k ˴TA7߬imxى|˥JJޝbgL<ָ%;�y%Bʦ*8cj֕UyɑzwA1 (͓iݺޞ�x^(kkcԖftM}39)L?3ƚXQpH>8uGr w�N%C{s.q<;,Ԝ8y8 Θ<7J5QQ m_!1 }��(^>'u߯m\[&re0MnfowwEãYqǹ͘GJJ$W==;�uaesT;z30Mjb ջ37&k{=)ɓݵ}~״cݴb��>(xӾ;XW{ `REeIwWy+ +5G֭)ζX4l G#e_΁Mi 49ii&�xO?"ݰ9:cc2/#ֿdZOcgK #Ώ<b|AnG#lnFA��76XH(H[I S>NABCgu4q}vvGG?6@=+pwo;�o+U<oSd˥ Cy y?&w/Y{2Eݵjasg2!?��Χ\!6@-Wx^a䤥]8kZ-}Hή(͓ZS> +l�Y ZN]-M"V2]`3�pf/Wq@Tv}QwFY9p޺=`3�h /PX|9G{Rx-?7Fy1S�dٞ} [wԚTk-.'mbzA�i9D0DkT-WF=5nu15<)�@K/.DRU{ǪRΞYb|ҷvwLa��Z2p!EY 6U_b|{v bDs f +�` qq6E9ѽh uA�L|VMu߽/۪m7l[2_Mkv^f3�0_aƞ}+ҵREsX{&И{ǂk]�3 f +�`V=cF k;/5'Wjg]ݳ f +�`vBʝ$;'H}QZ +=b?��~Bt!%|Lnx(ѽ<=q.k:b?��d҉B53Y{:] vrÊTԹe3�p5^>B%Eh7#+ +tjŪx3 f +�:G䝡w]m. +囬gރ,8먓նm̎ۺjdixIT.%`^@p\^xρsAr}#k]AlW'oϫtX8x9uWDOa��:^uaCEJ9;):Ϫ.(()��JAå9(֋.ʍ?BwSժ r\u?DOa��GKxmemP0к?��͋ .EnO* SOuYν}d=�yNZj2En(Y}`Do]S{h{նl z +��mO.e8$bqzE )�� vYλ托01G䢜ZA��9.fp%nh=m{ z +�nTRdg>K}CVmc>U~ZuDOa��E IO*z"7\4*Ϣ}9b3 z +�ä䢜{z̑s̻;-ڏrb1E뎱?��eLVl9R'c*k2qZwA��-Q2sڟ=+?/r~ +SGk+S��WkQ e#oMeܰظi}b=�@&E\AyaƉ.|Kcrk%S�� %Vۣm'wkкC?��hc6DJo~\ǫ/2Iz؜]uwDOa��vmazf|ȸP=b(o )��哥Ԣvd:B|F+{{o[K뾰?��@yqfm5,T.?&nuODOa�� V0"7.~^qbEAZwA�� v9\Rrx~aR!:@n?��wt.ݽf!z\1Nߓ:S{)��|o)o"OR hyyWx{)��|׋Z[ϚL4-jj=`=�oޔf|4ތz=7&iS��V"vig4zľy?��h?#IӶ/fu)r (=?j(DDOa��Y8FZ%g{ +bםEwip7j‡={Hf=�@:8MԷ2Y2W|ƽylXF <gS��oAå9(֋.ʍP}鎞V ΘA��hx)ўB}׫ &vý$Ty;[ ~ ɒ5D6Z4Κ��2>eQpAyߛ{lp=wl)bRzѐ4bNwOK~\1@s��{H).?ut"7+K9Lo]w[y;OdIRV(ko\ٕK>��@.msQswT],skW٩[Nx;GR_KIW"s��-0r433~Koi ߽!I dv!bN﹗MYk `>Ң3=3fs��:Bw vr)6Ӆ=uݿ;Ɗ\ٱ?&qs?U_~#|g��t,#sjyl=sf9ΌA"Y1)=mF Ԑ祽[R'dw��t<AQ#AwtP}9_Q0vS&hM=gމV"j;w*ܹciTu�� R='A5EξIx'H<Vӻ{I~"K[9d?gc"^ Twjg>R'fXW"��h}aoާ8L\{jTݼ#p;$YͳPw;ݴqwr`u<`;~13k��8=^trZ⧻zWmϫMgv6jOc_h+-0r2Z>jNkJg.4(U +q" Y,g܃8PdtjZmݩ(<Eؕ(;<!)exHBǽRtcdcW⫫ݙݙ?܋+W;|;w|OmN}oxM+_^i0҉r+3Oⷤ(09^2_>*Ȝ=Q~@V�a.";7mS(@ f&ĉ>Jw焞ӽ 얄M@6pl&ßI(L:4ǮQC23sM˂Kvl5[ +AMNUU[nC<2@5E\/Io{^9PeU@/F#4-n*Q87q'~)]S&Hs3 ޺|<4zeN!kB=xv9=U+'5뙻@ f.pw&w3wطpt9}q4ޮ*H ):m5]=csbZMξ*Fټ?3l,Vll亊c1*SH] Q`<i 9fcb2wAy?U% z\E@͔N A`4@ t. Xݛ4[:@M6{A_hDf57<?`06&k*(~_ڪLcH@VXleQ#Fxi5k` 't_ +'2g1ޮ)')[[wy^-m CR_Iu _)Dɲ`4~~c=\w&y~v2"#̛l*Շ|b3z>HT/yy0Jv6,̍|Ȭzkf(5CS6RzVB$6&%z@pud0�Oō:Y0?WJ\$~:+V +<љuA Z<~{^y(o0?�_2 4yB !�wi~պ833~H & +e0Csziav X+!zrV⟩C;iO+R8jh `cGqHi 3_ Vbl&i/eI@X(ΫաUyM<~ ߁񋇺*u[>fAyB wt+2˕23F}_ܝ9ȼɦI.#2alMA_S ,y^;a8'ĖD~^\3]ԫt.+~/#tT-˚7"cVba FayU+@IlY s#ǾORVB/A+RRU @ ű7(~xEt̴Lfܝ5ȼɦxzD|C;iO+R8jh W#m0? {˨(1n4β̤^Y4$kll["ڈF~@ gQN Ww4񁿧g5ddA,`EQ[ *˗A͵il̡f}f6RzVB$.v Ï-;$su`~TH˞hfgo#3fC:[oW-OIx}(9#`7rj(ttT3U% rwH &2}<1-ғk%DOf8GT5zQ Phh gc2FL9Ȋt/pew4P,kIovM9F_TP=rKg+0f_)$,۝Nc]@  0Yh==OWl$eEE7T5a~(9.&w\y m[>K߂J1I:[seQ࣊acUxtӆ>e/)MsְyTUk-/yE Չ_uu~<^*./.8[[?O}?t.vwH &*6mmS"0lɂ-TӖ5N*U% ʪLg hK]hhڔs]q5DO]e&Ehj2-UU.<ܼ;.;ć3z~o2:iȊW/scjjzekbx!7w8g0߱;B!$);~㝣;<~ &!HpgX$x~N>[Y"̛lPYfw2>)Z }z9rnF3yKQhSyҫkR|ye܃�FT-IHTh4&X:EQy*p"<N8OwqpwޞEgEt:NĦug]7G4➗w3~w~ߏn�6y-nA=kZ&C_ {MaKʐ}5YEYo8tQyOsE*TAԇJdVA&spЖ]4~l=>9`R<N@A̼Մ1ӑ)}/5Jr`F   qbm]&/r[ {T\[P2١`R  8CX \q$my]@ +ÂP$y;3@ +AA j߆ k: +u+㛥w_m]?0)?AY$-y\리C:i o=5ثy ^ #AA ϊ#hm$˗C$1~]H1yBɋ4ږPrzí8eHu<, EӸ9+Gd\zz W%8ɳp|vvo5('_5سc F ǎ(IExm3l yV5rUu<, a=HǴ8 T(^A`D:X]aDԚPMJz&!QK3ʟc�6oD( +NA" =DӢ:1Y;ãnor -D,?0)?VfOS@=?µ?.g +oAod:M~ wŗےVJ=r%Tt}pp$<IY =6C j+ZZչ6jhԹ̝1dʡ�8FW`ׄ}fv#®xB4W,hR>Y~Sv䮂p'PFl쿛(~&ĚXXpI$f䬼o~h]4 +gXLme`a䆢iڜdYS6^A+C%oHje6.4Vx1&[oAOB勉B&NҦC @F}?F ?ԫ]8_}<WgZuw[MLE~hp{X4S%/A[Ʀ]^cfcS!7p(a[FCͽpn|<<fKӾzm]'uxkT67I]Wnη 役7ӳW/캂M8yUaR`U'6uΖfa5i3-|0.EXKe> eU L޶ +`b0S7T|͛1@"  寗]7;=AĿ;ZϚ:vtEэ{E\sŗ}`R" Y靦>^V)[\?_WϚj>m U,W'G·ڡ.2d04uh#ϼO='o\m~i +ss$ꦬC;yJ✃ [T:=c)t4+}y۩A'$5Hӗ͂;ܼ{zlC>|ޟWK##,s6z BϊsͪXq[!$T]4IG| _]4I0v| ݔL]<~xx.s}5Gh2^i 7~?q;ԌvU/ses;vB87kރN^CA^ܵ{3sA;Ńiov2^?0)?2"e)!P4MGЕcjz,Џo -1icϜcs\<D&p 9!Wwp]g?vVFٻ'?${ S2?85!qcU埇O}a:E?c`Lp<smI<̮+�CA<.&=y^mn ;G@ +Y$n>YB.a>JGs?1_WXv #@pj$uo&xO5eqוE&i khAYG O<uCS}n}6?8<8DY)Cpᩯ?-\|{R6\mh, +U1eCAL&GfU,wgz&?IR7nAioq}F @:^]³ܵqID"ON8NY3A , Ϫ^u&/C vOofv?*}Ue9!m׶?w5mg,y]W( <ټY~jNɓ{p8Q}mc|F ?G/4\"^nZ#x[/E UG+V6"-HT+"@@ɁVRuV[EŊݝtgm^(n${To}oIGw=ӳ7>H/#]e;=q! 9I_ə04NGE.UşC\5rKk8Vl6Tɵ뙉f@}MA2E Q'��=ܟ 3~ѱw:\pjaɝ_Q yODJaԏN_zWx1#Sl362w *ն ʏϫboԨDq(k&˱ӇjTJZgcbʳwɇΘG}yDGA]{$sOY?O~u>?!gZU-I'Z \^���èLrEvsԩ>,aηgN^+" DdjuwQ�˱!eƸFC=>g6oS7 Wtʠi +3і=92e wgYͮ.o@E~.q]j\޵\Zں_Pm;KLw"yakKev-q՗_yVk'":؇Xf/yݮ-t=zK*#W�� MJY w/Sjw⪾Fi_?)e UH}ǎ�QG>0aJ߻#1frjUGb��@xE22eڌz^Qm1xrqZy38QHDJ1Tbonȏik5Rш,+0b��19V}:z+57 \V>SD H)?]䊂Fk koĮ ����/9уXǗUԃH)|{{;<k����~ -`4&ikir=IȝX/V"8�����I +s*-~Ac9c}hrxVRHDJ����lQ$=˳wy+>xѠ>ܯ +RR�����]9ğB=ϋ{U(."?�����z$}^2xHsm2e !?)����ЛA̞ zk5괭_2?sOR R����� e<ꗮN]C쿶* H)�����۸3ksct-S4!.+<�����pB& 1NM:Mˏ$gڰ.p"n}�����x:M0 C6e֞tak1>B R +���� `+R&- <ߗ7U#xԫB R +����o9+~*ӽ|-M H)����gٱHm {Wuʁl~uh>-H EDJ�����;1ʏϫGOuGF;Qnfg!?{>LzLJm:s&2S) ujNb6�����/S1RX|ޞ#;ɍf$d=b̝6ܠ33&h+dk׹޳ D[{?�����pfC~twFklS.~7_qւ +3ӳEA-˷qK4;!4gV8(v �g p�gh bp|EGV:姺#,h "Flc֣n~ٙ6$ںXtk�8cs8cGe.%9.QQKͅ bĖ̙KcA) +?+:^{HFk38g3vdLV ]5iޱc~J33qnKmYV�l84^ԧ?g -ؼbM8XqZ-k5ugGQc,#Osאgi@Go?}zff,ԗEsy~p (H38g3OԧQW 2{0u*'!xo?LtРzrkuu?�����``C}+ݝ1\kzLh.L}PLk4A})oM������ Ө_ A[A˷qKOE:ӜYU&   /qwIڹӧ$bKtlzM7-RۢW߽nKjTzM^"R  d!09}]QAw?i$ƿ*F      eޟ:8$ ^PE@FQiPmAQ b Q^k(A@e行HAqt-it)~͜g<</����,J*+* 5 Xo]o*K[a-y҅ƺ{fw0xhWH}Jƺ+9ѷd㴩S=dR3h5:y>/s6OjTG+gϬXz{zdZ> vW[5Qҍk7kSKĚ+%`lW1& Mm;L/./ 9߽RL<!3f)\}PwTo#JLsW*H8'.5Un#+xO]k=:}*"gw87_S)έVd<qjGrMQ%E妤ۯVBmN[kyy,_m|&}\sd^/>dր꠳Ƌ'OO! }|1&ȥʜ(:pڦvwݢqvU*iK|G?jϝ׹bJ=g$۳9s7l빭iiӮ1[صh/n3[]-?D=k=VDm*g=cYݛ^ۏ1Y,/xz~&'O|4L<?L^gޭkiZs1#xlmj3+3+$/@?-~XwU*b|\XǏc5YmcrFg۾)6N̕uhGP@~2cwKK67J^ƺlqOƮC +‚fKEyodZn4ǚh%-vhl8\ Y~__1- ub"cL&]V6߶}qh21.k{v]EɁDYɿV&cPwx􃦢,[]GAz=>ʳm(\c&zM-eQRۥɻݶǯNgg Xϣ>\!cL&wCMUm{ e_;?(J{jw.kƉw($TyFƮaap)6N/W.k++}FƮAY²?D"ϕv7lq2oI?몳3c2ҶjCÔ}-/mgniNYQaXUD?h>0?`]Jέ +qOƮ\n][˴m(\c,פ{b<}ub^ܓ1&՚#wm8e_KZaaV*'>}dcYqnkZE^!FƮ)/mJQ &c0\9C!3fI53HuC<HkS7t6W;axGeEb>O$cL*Ew^o\1'fO t0F?lwMmݺ|njoK.u4֟F.c3=ڼ2"Ry&mb`>^^ث// J%k?s߀H{2d"-bC6[vlvcû{]Q{l=^cn]Kۣr@t՗+U/Ũ}x +kSID^JOl .m>c)r|:פ{V5JN 0ӦNkp7^_bm#cL&$1ʊ +C~%6:C[*H8wp8s"Y<kgNtϬ^i> ִ48ϪN*fn)^Vd<q3#!vYC +3xZk\Z֪Hk߸gqfu816憺\éi˧N.{*jxpP?2d!Q5A}@SFg84L׵~XKK69q q6-_q KޭLWkW;L/[.ޮ/ꏖ5Qҍby~g]٩%jF7i>|*#1y_ćͶK����������������������������������������������������������������������������������������������������������������������������������������������������������������������������5q endstream endobj 275 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35352/Name/X/SMask 284 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_<(á 05IuƌI 8F<H + PD<*"( ,>ϳ<, , .ZS G'63!u2>5Oy?p~om礩6:5,���`1,Xvv@.ӫUgLqy7Lu.Iw8x8L lݬ˽2дmյx;ƈ2ЉsM [���LT�{RO_C%ecCq2iTpsHofՔGf망E'لǿ+T8| E.hNjrhZS+n?f +1;vI���`$3p8X"eto['O1/2S.'s|n6_p{ϭcU:υ���X.[k{ZBqn4,͙C.gNߴҗz|cEtkO_'Qͱf̟& ���`&88 8>XMveP3 };YvćZ}˹Q+jШۼΝ���m{qMVR,;6<1rl@^9ʳN!����^9r!̯ q _Fp|u%.'yӯ$Q3nj-����^yӢt?%y Sҍwqra+���x%:xOS| á?8xPᅉUnF?-ɳ钯]vz����/i*byF$%/fTxNZYo軇ekm-J���^Z;ϾdOp2vAnJyg껴?55lGEk���xa{7"݊D7pz7Ŧݵnq?6ɉu z���ۑq^�b1<sK=:.$轜 4BZk-���G\x#坘�CNm +[ͱ?l_=дŇ[ij���gr: rٚs]X<SN^rϐ|֨a'j?j+���x*1G;ͦ옩 yV +苦w!&fZNZWzA���<QnB"rO vAX?Ȍ۱ګL^\ͱFi_у}}Sߚ$���Tc= b!0h?* s=/e59-[X[ } ����C& VH2vAn!<}/ oXaynG��� lfZh9OD0S:#ky>~d]0~B ��� ^uXU~�1iaE'Kz^:^qӨV^���JH2c?Bqj[V 4!(eDtqx���`ezHK%hsc=T5l{Nmm>&���ʊ +RbЗ M_j8./M��\8]ZT�1Ar&\LPI19)"Hq:͉B���癢4]a>g� BIvsCVS.ACڷqh+���DU6K c rMt7i_9 ~;K���ӫU=;�1A<yÖRmdOuŊ[K] ~4zB#���PW�1A<x*tZ;QO㔷 ꢋ>˅>J���JNu=C?mƆxP 83 wr]S'; }��� V:s |3+T6/I{bTA;:qG ���\%GͦC?^lV?^[bخbv-ǴU:x��`HU* gb'Eo05HW1k~bq>f���L˛c +4dFrScon�+���j^�1Aܱv6bFhsӆȎef��~5yq�rp +`T£#"+*^+ RdUР( "(娋 +`.RDĮe[P@صEm^{n[73#d&=Ox_4DD0=K LlxBmMgU+m*eםGO5ק{!r{CW;H`جJUcU\e[-> /7XIi5 !J3);n2K |L8CC!m#咶>s:t'u>G e R{E$-n7!~Qy0АBȨ-?.1xu +ygUm.xݲZpL&0( l *~IyL3S>I+ I+u6T|>)H$!$d2W !6²sXH`9wFyq;{oGxU%K2?ӽtTĤb@_" hͶf(ܧ>R/?3+{ s .B"w4# ]XuhI4wuRY9t$ݫ1 ϠIٿwׅpe+=xRxtM\O$zIg8@6vϞk&B!|G[*%?ӧba156ejYwwxL&\<N7=��tMfV{^\#U'y o/=MwH=i{1 ޶Âv`k>61&A Bz^Q4`}H`?FAK 0'~z!iNH:K <{d䝈 6S%!o=^;�{]콗 ?;\V{[IH'R&G󕲬 foSS !0|EmiR %?'ANͣ@ז[)R +2ô)Ft6|*ہ<Jn<7]gnQqJBڡA{`Vh!0s8mgb@emJH|S3'qY= + 7Q3)Z]r/$e7=~K>�]Õ!5C->JBDV6uGH`Ό@T*Bڮ $ {CwSLaciEjQ1n[=wERߣMڹx(�!8žt +h8SϦftjfӫw2kIBr1c^7oa zeݖEtwd3@}{nj&U^)q!#4;))i~}>99,I0xǏBh 5ݱ CcGƕM$![JB^)◬^H,+=NYVؓ.#|g@oY?6Gmܙ/JΫP_"n:J\IK3_h7 NEFL%!n?N1t2.dJ3D~=xVҦ>5?Q-,^~#lM+ ��0cb ')u^/B!-tX1:cH`zqI +u$|'7K7pX, +MGB&:hݝ@Bk&)R +LFgciEBi'9a)?fEA+I )POSJlZw~mNo>oAHڨbd!%&ABRJjvP}H`ڙ|h=(KPUx3UQ1kS[ƏrwZtR^�RGA_߲ϩ3TDMsGyx2Ml! $?6c3p2MT.4\p߃C7!uYIH;7ILa.& qK\p5(;hl`�4@ϝ;Pͥ�0W-9Ү)5$D~g(W&HI^{lϞQT߳6"<̌}H559xfo<u9}(R^yB.պ)JB^)\[ˀ`f\Bxl;wx]NBuj?|V+U'yDDM9YGO ^ |!=D.nՂvTaXP&+zއCb y\8{43x^S:ϛ߿K6>\s(_QM^i�~bXԃT-NqڑS)"lUR@Aa�=B/6A4E) X@A@iڪ&79-ź_s~=\3U˧ZVIdԍ"ޱ}A׼o= 2(-ȋ@`KMur9񙨞>&C~{/ّUr5\v%Vyt+cV.<a\^>%MR /\qA fD[xp91I8,;vF:e"q䛮\S?bNҼp^h&]ز4:u4ʅߒ},ȉK + t^L'  #Jj?mBP$fg>maI⦟;{?Ɔ+ys+D*,c�W AK/x꜑uqexi9m)']}\u^#&Hc6pvBA^*"VDjqFL5m۹C}1v4?~ҒT4si _>"s z/16>.l:uݖd->ýZMq aP7N礧GFݾ~n6}d.0AwxeD[ ٙg[Xj͝=wcOЍTZO~(rhO32rNeضg4+qsi>sK<[.=�@ss]2J#&^$kr-r#!Aj(asjYV(^/|N;:,[)V vKVӻ2:rnJo\Z*{B$;;4V*Qsޢasyen�WbU3~j ='\$}<>H{mtfY[} |zxr2ȞhI!96rskL&C~?<#f0^p@ꠞz҅Fd$Bz^ɌhX]$'ͪi芌0ev0^BAYR"?dO@sHG ݱ͆*BsIaD譬rBG]R~>I~͆Lؤ_o9f-f<܋ 321ܽ6?蠢Đ~nl l XeiZ Zw:+="V,qva5ޔ 2l/Fc +5V&(-K\mk`Ws\4*׿M�:_c=ht^'PMMH_SCw4Xf.s8DR2I{.>u ~ܒ +yz?)&̃=%�k-4mEޚ<~naO6ټmzl6W& +CIK:iNM@t k{(i[%t UT-vh +a/%=RœԈw<Xo4g +E1ji+Dxb y?]}p42+_:v!=; +7|O/4˱]r̢Idk2^նv`2}" J[rܞ.>K-=tJB|I=3}. 0cS+WlSm? &&)+Ȍ>dIJ45cEy!ji'[c N_aT&MEsL(Z)hXU\GUҒ6aqpό..Ջ T;];.og畗O:Vp%V~T(kDF8Uq(r3A~v"o.K`/2ؕwdv -ifE(: ��K-:Uɧ4=ieiVWL@uKrlC@t t8|}Y:(Z&>RWKG8pC{mAM +M`ǧs`W6 c&S4ٖ0Sb :~` .gC)fK} 1g=8^cl~-4fG/ƞ?-`XL_ -,5sZ$b :NܽW(iF-{C3wJ}K64l[Ӑ ^rwdʂԈw<XVL_�sj {Ǔ%?БpwH+$u:oL(:\�X4~˩]r&]Wd2jN@BENqVw!8* +P6(8XJdI! ;*Q}A\Ƕ3.U)6Sϙ33s|SVta8.\ M@:¶JE{u.BWoG +n�Q,x\i;a6m4]on`6GAf>s8c@)$?2`D2AR|p>ݷ"%�3ՊI/!mł_D\kf = ^ ,?aG($?tY~~zs[x^߇(:;|7ӧ퇸-WMB*ғq.a@SEQ,j??&F>K'/nV !E*w[,p Q._MRnsbAI.EVАI_Z Ӭ&@dH iD}sia(]~ʁ.\DQ]1 +8ZvwUh$fU?X;NYO`9ތIAwC]40 n]$$!\8o?U_&;pDQײ9A[> tO %BPߴUVb Lc l{ JIJ ty(:Rp�T;LIgS_Cy%r.Ȋ9<:ۥ0Xt o%-2b:hva. rdԛJonCёh@YOU-v_Dv 9ǒ8qAAN 064{䝆˵Q#_;>b L5 }l5J2I P) +8�U�=1bqEF-;vF"p>ߌj3f1Ӆ 'r;|FI`Ġ-"MJ'Xtm(tn�m!�Y^kQF(ǩ)60ݮX_Λ-E!(LI\GHok7a<@X^DR%^RATHcJ ?~(lIm"S/*!X={{8q`9`1~ݳ #ifjBz]@GFvW0nk{ EY +P p!v<W[rO z~'BzN_NdQ}ou#~B`G4"(3C+K@:,x%yqԛ(=I݅Vq/Dc^1é=pեy~'>hT$Dcaxx? ޣ{:d)ǖH0 t$2NY*& g"nW(bzT:<RG^Im"$o4Bv r"x+xC'o7pYf53SSA/JRZ{@GfVרd 7Cc3r+@K <~;vqJ'ioE.$cNk?~S,,a>3 o\$5i7aHwqv։קJ(@;@k0dSM<'L{Z:<fmJeR|Ft[U'Jŏ.߷`a,kln ;bQi^Ru@ߥ?<RrTJtL=n u �փ;y=3oݲYN~*S׈sĉ܄#˒CN#OgXfMlq{FpJRX{@9I`LrҾ-K₫7ش;(<�+�M<c7o7йg?NG'_Im!~)>I:U9BU;$M1ݴY2 S'Zg�dⶴ|v߰?&2ѕ ~DV?[N=(3o:B�$ƒV[lq[HHލ‹oi +Y_BVs +ao}zT570<sgkR;X<YMcrjdEI%y<a Le&~_@gSGҾoE]E�J;p# Y>U-o<gDEWEvG!}khbLP{JD 6pܣdޣj0+) 4\s\I)]uw+R$v[[;N%Μ Y1RoݰL3og?ٿ@wwmj-hצme(3Ըz ]HQơ0Ea Pvl)*;%ןOR;�@WeXfCj?7yYj٭^/<8r8\ڷη~Y&|'&NwL<0GokPF6*6iL5y +M>tꐦ:Mqa?2D)2�?- +�%e%P;DTAT!O$s|3ݗ2 חhu^zYpv)-Zua"#cx=S\q&|jA ouG#>>D  +i7Y4g!9m铞P=44H]M+'MqެDEa Mx-` k#nf{`��ϊ(ӎ($Ht-ZԘ0L7ϿC-vϼ-fzkEԻm|~9(饰ئ»%1rOUWKkеm6Y臲,AE&,3T_,Hd$s6>T/N^Q˳I& 3 3Q;w95P}[  쪵}FFuj^kTmlU]WlRaҺ%|1Y/XH7V1e_&xʘ}Ef锩4k24fLضIv?#wPLt\7ʢK\x�&ՒHbOt؅ܻ}Sm9wcm[IdsΟ7yK +I*T9lZZjZRf۶5A{RxRsyDّ{1y3?jnbMuvU2mt=#CaG8n?e +V%i"Ft7T;.⾏�`7ϊ(ú}+ m2euDR\T,'PE.[ĕԍHAT&wKUU]?vc*: Q`@o7߂3I9ݼu?}��L"z5OU2oMaZ~t9d��S)#nETtL�\8fVˆ1 ��}d#TE?a wM XiZ"{6%To律��`̾q^@)�M͔v˕g%ÚN��v {7sJ \I2{nI{9y\.kN7P㺛��@yI.@)�]3oZJ=/MG(��P>śǚ(S?�lrM?ݓID[LR-*��PU*?e +nLJ:t.y7{vΥ5|ޗ��puW8⭩DYqvEdq[��г݌jPW L�xΧEL"l] ��zƓUػoT]t,4AY}3 zs�n{ᥲ¸J_; ��zf>l9(:鎑&^nc?$KxP̯=?�> 7Ӷȓo:u<+ ��zنZm[#خ_?S9 mΞ�仄B36\¿ +}��=ó|3]n6~uG` =)EcV,p듚+g_6rk��н(Yg7F-DS]d1>,԰`�|\gJa1#jǦWSS-7��؞`fC;)5H]m;ݨ`�|[Qdvr8{jro\}�@Zm?f|uIg13N2F %OkUtD**?ͯ��hu^4L;ؙ;݈@OꏢL ijr{? k,oGei���_=ח0o;PU_߾o=;r.y(GR h7= @ ݠr*']Ȟ;[=��֓2F;{O@ctS^) Fѥg\�z# 7SrJ <_"-Zk7[Vq��e^0 $4Ik68cZxc&F[F("A/({veE@De$x)$N$N]=hc>3W̾<1nUP[a$ޥZ|P浗=@px!nxpw=V8\;L �<y7ONvԳ ۦ/[v'}>h俎x@pQ˽uY�'ze<3 RsK>=b) sTJu[G!{�h׎mrwAd +^WNQR\Y[oڳo�h_ɞB=`�Դ.W7-]b*>�G7x|D?{HS5mWs4uZM�;mo"S@hy3qVOnR+�mWS\Y 2n#&;/j;gGZ&�wҽf׾$s?La�뷋*=q7\^L)n�O;f3s߳?La�o|-8v>]�<r ڞg�t_kᇢ_�_L^Zs0cD?�;J;{])8QL-�<RVHfv)@>C;VJWk/nm +�y^~e˱^g�gaʑ[tk].*�jKsSFAd +߰;X o<S4W}�ܟWc˖g�:ʼ}i:ݩ=A�MY;Ad +X~to| +�jy-2^5w71O^#ϭ͓F�Y&)?%sg?La�Wܔ%T7|hسo/�tdڌ{cfFf�0p e{~~ YY �Q{#jf�`Hx@WkS3-b�H-y"S�̞[4JY=R[/7I=:uQws7?La�?윓o+1ڱMY2�Ʈ?Fmjd)�}P%&kG4h]1 3�Ȫ~G0]6|} 2[6QڗdtE+ٵh�QS;];x{af�&,~JwjV~f[�| fѪD?�,oR~_?}@..rJe�(s@5bqZiBw�B#~cKƵ\)�*<z2{z92IPulR]ܢQAd +z!nxpW%U�Neԟ.;Uϲ?La�h+bZ<jWk^.']�Bɏ'e˺͏hկ"S�Raœ/knzl'� +yDs4v+%Ź/>:�;G4{}`?La�hOSӖrԳi]lm�֩e+ +uB`?La�hoTմ^\t} %l8s= 2Iy3qV؞\z"o[�FUbVAd +m~ėk˥nQo>�oomAd +}(I8*\K}�,ٝ L)�"QգV{FUb>]�Q꽩Gvyr] 2@b)q-ŚW_[/~�Ed�,^[Iugt`Ro�xfLue#`=DھGWNu\m7�< >OͮAd +@00RIpOSKnf{w�JgNgf|`'?La�fC?iZhTcyh� +6Q߳0 D?�ʼ̤WhxjFD�hkeڼ{Ad +@xi8ecN75 +�@[:ʑ"S�B͸UZ~Nf3�@[x[ڄc�zWXSFhRaϊ~7�* sEvPFte;'svVV.~�GUz 8~@ bR&^MjZgjJh6R%"*רx +JD%( + rYeQ!5f=rIm:I۩a{>3xo1eױ?�<CHR6b<o jf#�i)v0nx˞cWm1&ÞG=�}#&KQ@-+>o �x(}k-A=^dKsMW�:!X%J}y2.8XM�9y|up^cgO^mbG2f?�tD^I3-M6Ʒ'g /�ar:?4e?3nGs{[b�~fE>.��5NZv8k<<f}冐E]�p{rM67ު^5g[�t,ܱ?f%naٹnbC֡N͟�=&ISL6]:{�;ֱ?w.ڲ=N 0PO ?�Qn)Yz.M*+_&�sѝo)a-{A:^kzPbJIZ/e̓�<CHA|-Ƌ6E3�:+Iݛo:,i&7#IxyxH~#F6'I{RI"'59B<#p(!?#AR6}#�@[1Eښ`E^֥k}D �: wg&S4q, fN6*?k\L_��ŝ + 6{g<U$бEɆoת;A)zNl$P;'J>/Q]�8t]2^ + ?*,˦I�t _[GuSnGnO*9d.5I |3�!8 +Ϟ(.}:�w~zA\%qD8Qϰ?�@ݬt/П5k�Ю;^Qn~˧#R�p=HC}4Y U@;RzMjE?�Fo rWt0Wڲ +�m7 +۪DKa�xe^Ղ)3,�?Ջfݢ??�xKG(YyJRww �w̲T;?�L[lrNW'c +/�\ӫW},/ h)�xv/./-1l^f1]ѩD0�\ӭȘ"sa-�/ϖ t{>>V-|S$KZǰ?�3t=zYx瓕o�mJ~a-�W7潳T.qk,4 +h)�hYVc' �p^׏:ߚ]'?�xBҢ_-M_t�ɅYj] Z +�ޠUӤX9}oOeU+*@!?�&!x޻MJ�pִ3qj Z +�ڗR_iU.ߣFlI}D=�;,./}Zo?��1~)`J<R@ +KօK +`-�xlM67ܫ  e_ښ?�@(sJMi:&�cMw:A�8!ҋ %J/7V[D�ڇb`L ?�xB3-M69#to#�mb[=YDKa�s_KR:TsѝG�Nl"{x>`-�m/klVudL\wL67↫�h)�p~ݖNwOo27E!V|ЌC:A�QnɅYJo_([^LK´蟪?�xR7,/dsO͜!~Ls#h_{ Z +�\S)ҖԅJ˾\M 9Ǽ>j;h)�pm~3c69XrLj�<x;j9h)�p}^Ia׏Ȧk6\|k:7'SƱ?Z; Z +�uRB^FUgY]F9[j6h)�ОY-Ƴ6xH|ņvV{DKa�6 >f ,ڿ*.r^>?��m%-՚eV,ĶX~Eqqo@ I6j--&.Dz* +W#Tka@<a ^]Sxɖ&cNcYi )h!nA�w0ur"W?:2 Cw?Ŏs8b?�ut&Rv͕w le#.)�p=7,۔;'$[C߿�WvE:Du8b?�5e+V**UX<;~>1>zNy3�Gl5?m)J<] p5u! {?B��4%,jU' 5OG6~'\E]̑6EћQ1S�GPm׾{xAŊtSo6L��j}*d`f+#*3�p;OguCtTCӃ�3wz"UZoL��:u8gp1`6;|j!)�@Cn +QJDw6,\"[ +3�hg Q{7+REÑ�3Ć\Kav?B��<^K ֌$8 DДUOg)қ91S�_y0iGl"Uڦ9=h.VXWԛ71S�ߢm acMɩBͺVѻԜߟX`Hқ31S�aiY7X\t@Sq SA9rs Ź%kz>�BS8Hmt5zE Κ1cwFJL5b<ccގ6[ �uY$lKY/'ӿj̎Y.UfA1ڼ!JW.,�2">Ҧ5?V,Y{V&8c.T+_oUg?�� 3 wRU"׌�gSf]].'8c) i! +;Z{$G<n7v�x]6Iako΅Cۏg8R5Z}?38W\ښc>R7~ Q?��/JP_ᓝK;Wŋ6E;>20Mndm7;" Rj?n53fߑf;oOOC��hV윮?_YWn&wp3zdSz3C :AmtةLqtY}֏i#Fi��mf).ߴo}*=0B"ߎ՛iyUan ˫LQŪ w֐p]GҤ%~��"}aNG;?: AE='w2mOgKڦC}66]ow{?Bv-`�p]cF q7TAʿ.3~'^ ~gu74q`vwkGF>V@=I+dpwwx�p&*)rOgbIƔLIZ\?&g׎y\s'x;ϵ՚qˇ@��8VsLh,֐cRvz3A Κ͚ [bw=$g ,i)!> �mW^Y{$laV<a,?B��830?a%*ݮ>2x^ND?#D)�@S1jJ=G{tm[kFy8awL��g{ZmJN흓kR!oq1e.6hC޽3�hj| 2+rU*UݳvI2~~ڻiizwA�,mޱ3KϪҽvwL��桾B _mT}2:2;h>bx{N f +�`16E)S;F@C|m3Z~?B��)eYmˁYܳ }K{L��;OguÊtDo\>92=p䧣{jt4)�Y=\X$Gk1uo6d <|vG}e1S�� -?'WP'sULbC}u0)�+xy"*U?<=~/vL��\I%kF+y|'\kPT񃈈h45M՚Ԉ DbkH˲8 z"A1Z@4IN{t21F&8<ZA�V|6ܬ=Y|gjZujugDOa��< H ;Xf5U7dEyZ_X`>uWDOa��<ȍo{gLG,HN +ʼn s N; z +�!_0i^Ea\q"wbm)׺?��3K'HӢԷD~l B6!{ z +�߾S\PΨؼ@=TH<lϒ#)��񈗥e,QR߇wU?UuDOa�� )f4EIЏJ(خuDOa��<С;ACoUE0hNmк?��xx q(eVӥ}DWmO7.׺w?��Fņ7qo赊-{,ڦbZA��?_p)|bu(r]S}m1okk5S��8. +6I[3kwZ֜(9ic=�1iǒBi"74}ben P,+ruDOa��t?JZg/u/ ?&½ʕ )��׽l2o쥒cpO%\иm}b=�@ *[|a<578I|߅{q(r}DF z +�W}{{<?bn^;/܇Cm9; z +�1fKn.Wn̰)B,cta=�@>BZwGRJӱ {0P쏙{ziS��+H 7iK=]J|F+sgZM뾰?��@wYR\$u<cIg{ z +��-6 p(rñ|So:hU׶GiS��?JgrcGy1Z'>{->ZwA��c0i(K\2xqQFnu/DOa��~^<^ڨ,R x3᭞fyiS��W-5̕1{wf<: AAA��sKGjrxlѽƿ_yDOa��6 \XhأSN\*?ǹy]ٳ?�� *M߽Co8Lߣ4 P{Xȱ z +�ǂ1RzˬڋnTQ{X z +�kĆڥMԷ<^4G|ûu2dzvÆi3)��6aҼKjz2p_|Fn:ç(r]sg z +��}xfis~*]?Qh8I~ m7ŠKMsg A>'.sG,32̚ ��})t=5/P|}\Ysg >:n4d. 0vى Sտ=W�t)-N]u.k㻮;bs͝'c .ɓk~ұ~$ |A߱?��ЯAA.[f֟;;7BsUs C|ܫqdө}��@|CJ3F:h5_p(r"fwoH?lʱT4wY0=u/ )wRd oߙ%f<;��gXimY%jTT;՗fM͝kv]Qw{k}��4;ӖS*gឪƑXlo5Pβ3'L#aA&|� .glXXj]]ǧ<o=ͅ$y?HK߾nƇЯw߬ \$*}۷oϲ"A�岉R\~Z* 2Ν}NI{* cgs -]0:tK ~W)O?@س迋��$,~LN;+ui⻹'pSo,uo'S{[\/j3mwWϝIzw_O��:”Sԗ*Et??eřT5h,W&T¥,D(02rnfjB1n£]c<⭩ݭ/!;y~żO?E cgۻc葟֩x{7V=?Nfd6/qcNhUiJsOo!/6+Եkf+< $:39s uR<JNZgl/yˆ\UMnQn{7O,o= KL]z2쩧O=$Pdr~! ӗu%qn> 9>:U`R\|wc*Ɓ(ʯz 4:N@8-g~�(c -mG%u[ivIoEsOE(Ia.>q;u౬6"{͊>/?c}<Yȋfy'O:em IoOC?.Adzwg7H?r]s2$}eBޚ{ZtFcQt2wqǡ7?4y^F҂T[;}r@ͳ "V:sYEX)"xc^L+z y ܒ'#tw5ewzߡIm>ɛ 0Zw 2y7kQFV`T޸Ƶfw%1oj[v٪͠A_"Ĺ8;W:y 窍"L'I4As˲#62Ӥ*aű/m=L�6ʶ>dc"6=X3w :WT!J%{ +ȻjQpp�M\e-Z')\fl}Nyžx+=͚&YMZoL̺Di2c}i=WAI~wFB][�쿦`1gbOUǎ' +Aq-CuVJsoȠӹȕ=QkpGJ dʫ@;z;"Z y2f2[=f<)klZ{{x̺F4='4H#u֙mf혪ix{fok?Dfy�E�O= &1Dqb:~bqAlgÕb*D|/6c "ƌ' +Ah[u|O1r}'["#a=yPӼs~lv݄ >;EGMU]G; (+T3ފ1ϤtVjAJs[o1s`u']OZaf7cӨ8j6^?gؖ?LvAy{FhwIZO'OU3 W?J,͎de?p2ك9ެ\m6mY(-]c/wlB][ +xf~MI^+-AyDxMj@SjJ^Ou:+GO&"Z :{2f+s|JG*DZ1 ʺ`{(+1ȫy;=dҵc_W3ƪ؃Vdr~  o/^iAhJs,}p\~S/)Zv?0\)?v-YpyZL2Z5 |S5nȱv8{wbAo 2v9,;X[ z[MX)"m>ZzU6/sM|l`};YAA`IVQa}q~i.Z*ҟm_v?0\)?6V&{n0uKǶflz1?k!;:ˋ=.I҂6Z@(CS;+>SAw{_u~d( +DNQ>ڰ:'Pmt/56۱VlQ\}*D/I5F>Ư}:Z3?3�s>˿\ϑ'y3AC*Ba/*q4,`R8�Y f]B̩\_?Mi-䥜ކټ1u~pBkK3)f3<ѝY'4Ha[ayuV[c[/dlɜYf˱VD+a.: yqgCLT)i& IAs?ںk?U{?x# W +gAAN"=bWjkkV1kTmɜv~?0\)   <yĞciwxߋY/\qK4wTm:vv?0\)  LÉB xrΠG\{.xص4X0`R@A etuA=3n=8`R@~Eub5ԑ&&F6PXCły֕.,{v{qWD +D PΤd&~k7KvM%w~g7}w~ "AP*QSj'mB\~nc zNX  "5T)ɂpZY~0|~:E/z>XLM]A E3[bQns><NӖR㇒P0|ZV􈌟m>Yi  \K8=al^س빠` b qe!^1i6'$[[m%:~( zhT'm7Y" ˨ SUX7m|#ձgRˆǹ͋!L?RGJZB fPƗ#ߤ#:G]rRA/Qu )WNϟϐ$_&ނd^K MS{h_e>PGG86eM=_7 xYE3$C]u_j1Zzwx|ӗ9` QL7ʉ\,؁)z79I[t #U_mk5c<WF Z<&8t|}0)܄K~-b/_O)im7C M}ɺn:nџGs7׷ΐM5 z3/*Ak}0~XLI=kYrnm|BClXkqm.WhV'k|w$\7(i a +6.ԮVxi&[ ̐GP6u|w'eLӶ?RG|ܡ-W W=`GzGmNKAzkUh4Q{'m7[G .+5r'r_ +D8]MyVUl]\e;ܮ͇ywj~rd1͜ ԎWY]eEwZU1¹MYe :IއeE&jσtֻq:rr) ׮fjꊇgZaps7Tg >mYfjVCۉm e K~؛wΝ=AĿ;Zǚ:!w{˾</FH#HJAΪ Qg:ri)͏V'@-c]Ζ>|Js;Y?ۂ[tЖ[SR†C^m퐗[0I7 Ƶ5::S3Wh.{sh1kEyqCsuAq޳9cV%c/]g9 |o*J_;v*p/ J֕.;EE͐kK Ykr=GCȡxfb2C1G|(|Vj( B)\)fX*ލJqՏs7duGQ[?bMq;53Vcmu;vmpn9^ e'HCA^Eyђ;Yo6ߗ` n8*//M񄆂>JX5&׳F @?.'lUwc@=R$\8'?֐쫋;pk#x|Km:<'.қoUo]Y4֗ 8QU0GUׇO}a:gq{0&\QYjICA>.]{>Emn p/G,T?d9v0V&?g(%Bƀ\|\aѴ %f0&$RNa) B]WBoup o68>4sS:=ɭ'_p4+q<Y!Į馭 }kzm <LI 25;{ wH޸WeeX�Ezvm09gjV?rӴcpa;ȁ('rrepxvbb{R!UUvֻ~o[C|7hYS{靗۵RARZM|ة:{6Mz: K b)r\q];'yԕc*!gGI<GhQh9ԅgW}g-|Gx_Ajx{3/+@Jn8c!Wȋ+] Ay/ !7z7}  17Rw˞?RG\5 х9ģҟ馭O'f#:hԅF:hk0aZ沓t.S'�nsѻ3D2amM|]r:'r* :i�K @J3/ksZ,TR+ת} A~5qq|  +VOVX_2PRiZ|E EPLB%(V;k_<_ӻ. n@'<K|!Aʭ)MO [~g?\bT $FcF5oRԅעJIF)t4?2FzVc?#&]Ku<7IY逸KEL,;#3Oy3Gv@|R۞3w"w&߄nMו}2q}FUEc<_$k(|\#=!s{GTfp֬v1*RVdB0}1[_Ab&5~%1S4adu#y.(6;յ@!¨$eFl`:~l^pmhS~UP[ͧ~ $Fk*ϜU6e*߷+][fpB{** kr]XqĠHS758C75e-O&!>z*MPg^#?^MMmt~Vs |E�B E{Y}#Ms|B󜘴"٠Wq-ݝl>"�!B!0pGyJO桻%- kɤe|jD�BB!w|(CqO8V3vtyj64{ԇBaS^pltN2G?8~8O]@H @!t4Kk[-\M.Qc~h$e"> �!!BhoB0c;,㟍kf<aخA|jA�BB!оhĨ<I楫_\9CA_;ԀBcƅPN?i2_[禮}/I5D|B!?'%Je'SwA=5ۛ?ʘ@H @!W&P- v/X{FY!�!!B8|}B݊99cﶘe~-7? >B�BB!pؿ7TyZ7~6|yX3.M@H @!>kzunqh|2?n k#�!!Bpg9_sly#o{?WL*ܯ +yE|S(iZj\ڨgnZ PyMz掙])Μ-;B͔^ 3֗m Ӂ^dmqN!�glB >֪kI (kh7*+O&mytާ]TG@B!| 3|lplOWi6揿'$#׵?)_ߣVS#2VrN Q"rΪK}$}豻9%9a1T=yd2J]8>^^c;>L}wZ"ըgnlcQ]5@=vWyƤ=O残msj^"�W(IZwtk6kEARf}|gP6slk1D!zZv2wik2!�g(H٬ יYmJ߱ +׆j z gÝ^Ш廟i`$==y9HpNZeA 5jxDIk�=@z ϘHX`!yny5sZGZd͚pն٫CmoypeY}1~ɜF浡f=�1ijg>xyٜ(IzMtk6kEARfB!np?ƍKY8CHD5ꙛGۻoO ̣^<B!e9kdnY8F.efb%DE9K:L������cLnb={~ښ%Od)yMoެTi7*l♟2&E������3He+9xop2T;YٙsbW ����������������������eHDHnfMzp⥮. oz?9)F.݅z3Wӽ3rP{gLF=s,Kd@dUZOMpݯNً?yYJ}(Nc9EYal"71я|nJ e8G 3R9|Ͳ )!z9{c.k-{O'"[_w0Ϲs\| ?OLsV[mJy{'R*y W(A}8jJ2oJH@I>Ǘ߄Z3luuuq˲AFQyq@ut:A` JQJHĭhjBƒ< ++,..*"2N&NSf.% 5sǽgug=[a3bm}{XHX+gC=✃O>`٤]KQOՋgbf^A")n&tGicZm6>ēa~*$dyڷ|T^Hs~g;ixgޖϖV Zi#csy`ߓw1^zRbҦs?D?:f1 hDo*g=b{S9+juc3~2~{ayV1n1%:SuK[s{*+ ~O|!W>|i'cIW!9b}Vv*r3jJ <h$W,6d[th09JJke*}['ʂD+9>9n5w_p_Z +g2Z),8XX.wd]nv+.$ώǖ%무=N]8?ԣorcxNcOXǶ2Gۑ1|ɰhmo)q_9*Oט;L,Zj/$GOdZ%k2D?^ u5wd=Js=4(Xw?2SDS[1vyŒl[_OǿZC%|eʾvp~'k2xVg>.)Y*ށAZċY-Mq>Faud+)Y/͗ruKB+ߑw=|ts8U;Dr"/_!ǣ֦qO%q|mtQy.l}<gjteVB ΢澱ɥadZ/U'>wh0bR5d&$:=oIZRwg{'mg2/52L㻒}-}['ʂD+9>9n5w_ ViyFF;2N'sTH2V3P2IFH7vU iK|uVZg} ѕE( Sjuc Z*BŚXj*+䯆K:z[[JS!KVK&l&ŭ2>wuq=/l(SkLlV+鲨ϫU*I~<dO ?c}]ƤmL%"q8z,>/oW>dmxq?Z*/$ｇ3{I'sTn-;yzw/fC WxHӘO*2+cdKvt=wHqR6YLw52TGI۴CW^qs75|i#cC]MX5h_CoMHti<'DCu^\9+—HV׷Ƒi.-Ncˬu"WSc}$ˎ.q&^,.voR$>Jn0s,1v$EUWF{qfTkGG͍EE'U g=k562jz×{=,{w~jWMjfO07))O"_[:=omt$ +'lߊjGxH+\lk\2^dik>!3hy"߈m)Nstw;oOuuT{q?}+P@xgjyY^w>$%&b\2�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������x9W�� endstream endobj 276 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35625/Name/X/SMask 285 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_=(Y@K &mL|->KP5D4AS@ +saawy +j+4u=8;%V&D\8<{9G( %0}ɌSgc����F]\j))fU*$m^rə܄ٖnl \Ct:KwSiΕǙ50 Kp4 `_]���0L;I +]:'?16&L J)j "g<5ʼMdy`cl_^ܢS5#wfOˁ;yw2,yM>kU7Ϫe"MD>����Qt'Ƣ!';pϼHxxY'Ĝgd5?jyǑ'n5n$tp���� Qߜ_dD\ݽ<ə< w %iyRUuT365f[#cWOm&���07b?(3e@96G#+bC$uRi]S_rbURr}6S����6͜f7Uf�WJxxfE>nifm;Vuf&.m��� 9:"3 +C v$1`bU&t_w#B2;���2v iSn?qL0ItWѬJHn7^��� v0i3pH4~I]#Pd nv|͚>���x\ pH,K[2[5jEz=\z4���mԈ8&B�iǖN)SI[{WOˁNKZFN(DS-b���c:E�CkHV*%sM iO6xhI.7,'VEcрIY_,tr&cD����:72yK?+FrgyQNGIJs^n DSSyM{]"?;/ipup$>>QU +TɄej>%WN~+9.���b-{l>pb9Fvw6m|Ch$ Gd䒟ZU{x-;{.+gF4O?OSM .ZdW$F<���t",Ԇ^G�Wp3kD{;x!�B"DD?|g,1s{XLhq���EYLgQ?+?^3Yݺ^:ĸ1-#QZ +���kO4!k + d8ie5#0;ήB#J? :jK~VJKOFuup$V>f���DIC4 +.}GlWϤB#t"%oV&WϤQ+kdlc��IRYph4>d[ZiUQ}J şHz.󾭋N2>d)1{NYlX���yzj@Jzd}%ijFѭUou2?4Ӷ|/_KWY :tٛVپ���`�TYJ?KF[nca + jB <n +2v񱠠i��`*fɔH?KFk1]F +YZ%~b!H6r?6ZWW$jgS̿p227+,%F<W���Ii0KR^X\2>6I|qN݇bտFAr0<+>R|-7. ���PyaBX&D�.A_O3gJ-jF}shb+D!ytMb1=35#*7>vㇶĈc*��+V!)8YVX\XYIJrOڿ+5RMȃ+,I4 +#λl_)���xE +kRKEy%1ݛUm y:RDHtU2QUܾ}Vsf��pN.n ?K?-8<B%V:I~(y K!OݗZ鹞)=~l_5/չ1܌XH!Ă% b DDl`A *u)ς JcHE{X0npgnb?θ<��5idi?@H?^nW{ܗN9Y$؉Xw%kѵ^R޳S6ߛI KgXz���kUu9)?@H?^=ӿ[g,3v_/Dfd3^%EDiUwmfD `z���/s_"@׋ɴQ5S7ORUSOrNqޛ^s&C���?u{VYB=(&7-vUy/d-^'DJnMTw(ʋvٓH��9խ]K?@H?. o{Rqin U.b-^'DU!D-UrNs'=:rQάG��+ѫnoW}oSo+oC7چuxpKzё~&d7-HX)��@d !هf]&Y):Qmc\a=N&KYRKuwS8Սv!q��RrƠhWMu䓼{n4Wr\Si +Vw(8QIAzlBҒ��KgDA�!Ah4"@ٖf^y/.6ɘOt== 忓Q9ngz��t6BѾ-(Uo"Ozo5DOULgGd,Y3��`E'y# Gɴ)3zb kЫ>.mϺCE=U3df_4~Hc ��nѾ>=m).7k.le!*D}5D J̓Ge=���wZwe tlֺg|U7=vr1VK.$j\z!' +?[T՞ ~0]��i ں- B&Nu"ӳo.TNݡѕ﬩WzN٩B}g=���fMzp  |o89_Ͽ}b!Q}@QKMO)n{WNrb_?Q��q8uGsK?@H?z+D +g9ͽ^SR$ ~RT)3jrY,?EA>���-1uGgBa>%Er!8U !aeRM߽4];OB c��x,w^o1 e^L`wuY-g:*R[yהO'iiR1YŬ ��@۴˒DŽ L SisvNh *܎u7褻!ziRSϺG8U>)!#GJ,,X#��6ϯؾüet$/#G?I-^*0olg7;Ϻ?Ns'7%qGD`1cIbiX��5^﹡ (."qǠSz{Fl}uR�߸6-9?liS +5a"XY>f���`V{^y2(p&k S޺`S>Rf#j?_Qvpڦ씴ÝRJCla}���^{ (/SZ+T.ӟac݉J;[*VNm=GAY+s[2a$XE��3β^9M;0S6ՍO˗Kn)hzb2,S7n1nu֍�.N#c4{sqrRwX+n%3%kQUÓ{TZNXq"`V{锩Ǧ +��]eE̙XL[_QTթsRgAFj ZO}g\JdXOԬtR+tbEk1Putw9sɮo:��U}ϩn9ˈ3 -C6,S}w(? pg4ڪ84; +&cw!jL"j58>rV#/L7ydۻOt�� + ++`: {DU^Vf{ȟ}Cx2zhYY�=^H]At3?=-[ɽRE9HɈ0ŕ%9�� XaN:8?,2wԺ[SnI(֠5QAQL("EQ %Y�[]69Ǻ&[hpc p;{¼yFZ&;@:^yfMWymӶ?L3"LtT]֟{Mٮ\[I̚=.M26-i.Oƌ% s��`BdNUR&HIJϝ&ڳ~<ű?L;>7̑^Oo&nt!*YImt߳J#:5wUxiвV#<��wą`%YUrB@lџF?E-12;_^ӟ++~W#:D`J!弢>">os\ȶk6��9*iZ0VG".>fyvkA˖[Glj##?.t +QYs;RdnDteFޭدfK45-*x I¢��cT-A�c/ɒ?a7?G @nF$kߜ ~/ OdT=6 MtjMur_U6c��RRVJ_ ˚?whoS[|eH-w%[ +#mssot٩_;r2]˝٩ }e*ٙ3}��t =s6v29i~g}}kC-x$zF?NE?;5r'#?F\8STDFryqaO:[[t��!9f{#GѸyO 9IsS=eODB]Ytn7݉n';\9cU7dgd�4|.֤1rv~Y`;w?^3R‡klmvΞ/ލboFND"uNj6}0q��@*QsWvW;9QUW+r3ҢfOz;H \?v)\TH\!>Ys:|ZiSFvGˊKEc&��RF2a1? g\W5~{bwj{6fv%Lȱ!a&b. +ZjaB��xR^qs+d0%בI)(n?-|л5#]@t&qSG"yEdd1n\ef ��~rW`J?7|Aѹ쬜)<rT;5 'zR:ӎ +~[Nݱvm)'P' G�@U+oJ:{L 8{^9yiԆ�ȯd>QS>,t6(U6䝑AوDB,�8N=? 4S2M+5h+gu5uDROi[RqGHc _�`=1ݽ`J?ӴR-;?-Y%ތM2]JW5H[4U{:*|Gdgqtq!,-k��&ؕ~\0%ȯɴ2m׈b^q8T15k2Q]''3n ȮZy0;%.&t=fϡA} +=��9YY3#}i L,Ud_Fi߈UWj}CaQΩwvHvz� ْE�SfD\L5f{4X.K.}iCg |Vx2':Rm>H6"�hlnW0%Hkک^rpj)S+|O=1dy1{^mI;-[4Ï#�@Fy;L Vu扏u(z_5l-ѝ!W{bgb/?*:}dݭc�MG~6kݩ`J?ǁ$-puή[!] ΋wė>e +QkBvVi$_v]Hw4l@2z�"7i%O? 푾fP2aW5Vhdu["V2]G'3힟^pZve')㹺씸Ԉ=^ޢwBX�5ՌͶ)=iy/3ZJDlj@LX1.( (ADEv 8"G@Y;`�aMKQQDjLNbS۴1s|>rAJvעRWK1,d`MC|^=)K$Ya6hk"G\4?<ƍE'$?ZKɏ7=G2Myv߱(sS@'g<1luU˩RD?OrNFzUz2<a_2 0_zzP@JsC $/zͥWڴ߭(84db=]gowW-猊%y88]clFSA +>'>~x3?&ҭ}jDN\P⾧m%SѷKr?@'g2<:6ozRS{jybazKJw;odr:qAHrX\7@G'>j{JqJwIQgpv#cdѸ-<k QV?DA7r)IS=YK>6A&=:ʔ_}mwaHrE+*7y:E_gf:or /Z\,7G/s]R0 2Nx/C +ޛeZtO� #jx?&4X 2⺂l߷@'�~ɺ\a˲]5J)yO+ܬcNMs0gLy)HJ\Cm@:R5 X ]^&əD_+b'^Ɠ/^zr۬"}IJo(&$&insL` 7aH1B! D7$)�՞�|'m [=V?n*C"Ew_%Iܪ˲O&['M2(Lb (EUE:[0 t4 +|yjHm)}ఐgGԻph LR[o\=4(?k:1 3'#͋ܳGofja޻as +HOgVʈk@:Iԛm]Dё&(�TLng +۹k۵IkxUJIEү_vJDө1K~~.N6b06:tO0죥%a L:rB~'+#.)Hqh376=�nMoCRꔧޫO\^Pޟ$BEE"}xh/=t<Y,,aa֔i0NKCQG//C\Fwahuj{*]x9e<;� r@G,鬇Rݧus[mڃ<hd^l$7U$ +[)-l*JiIkңLZ;7-etCC<"yEraz?&v?wYP^CѷbG�~�Wh ʷҥOj0z޴6_D(9m*RfQ{JR-_V&29TdD/<8-|8-,'d.4:tO+j* +~z?&2q{-aga2B&loCQ- p<�:bn}|Gg  z~{[{UIg2Iw]RH +Źܬ("#x /A{mwt` ,,b05LzAD#o1gP$?P&93h=đپԛn,)5t}[(;�\�y4�\92OMaQG֮3ht6l=p g3dk*SmHRQR"󪫊rt/H>6&l/o]W͝a/? 3 `. ?Q-4d a(]O_A4)H27$EG���u>C  pHwgk<,茕 &ϛS3xqkDܟt+R;*-2JwRJ)|-_64ܡgq_9&[g,N 5bS]6fa5Za Lx̞nS&Nݱco9BJi~zװ?&20iٯӨ< 6E[:"Z-\P7@K.)(" ;l!E[\F;j) 8zT ~\8Bxs~_Hɗ򼏜TTXb|�Mt :yU]=fHSC~aiK﷖^ht]f}VG+ ..r.fה1kD(2B^R\8IBg ia'$͎=zdjq=<Loqyu-6 Vi4K1i2MqާQ  8KP4D("'-}k/W=�UDd4f+Q'j/Gn 1Ό7rf<*|鸶rO,UW{8VlQ"0QyBxWUp JV{5v{<ӤdwR R!N_?TIŜr9?0=ȡ) +iv}׮>_y99Y^i2rXhK+ΣşY͌OiǟЧN&LFt#i`2]2NNghHzz\_^)73ɾ.@t)wuɲWRѽ݂u)��zDBGQWDD廈*]9Dt!:iҹyR>o_L;`{Z짴]0;JOj7kvmmRy azE<¸չ)+3;֕2?Y)+$4B"+ߗ2jRfe;DV({X*,⧜-L9nB^R\!/Υ'jQvsɒf'e''M:G$x[L확!?&"%1P1D}O[:(qPhz%cc��^,ݎ(ӁHq$`3Q6"DvUGt=؈n #LN9a^Ù2lМ9hr_>1 g omfxKzX1rVmS[,No~f%*9jզjZy-Kٽr]^N]^]A]V]cU{8kvlTWynzRӥ+rFpTI_." 2ݯSDʷs߳���Z +Fqmoa 諌cѝFخr}}���(Q?j?] +uL/{.n +�M!fFh +ѥ`�tZe,4wN��M%ыw3mGa gO3qRh4��}7y}k'Di)ZȞ+U{"��;ٚrl?] +w&o +ohHfL; ��t5lsXm'a ᵈO;kIsx ��tlSwp?] +@w5HgKcdpQ��{.lvK�nsh{)EB*jhpJ㾫��@wTvm` W=(4;0{v*3n\ y_�nrs2K�½f +k?ՇB$��n7O츛- +0 K�X@{0FTX`P ��z#ػ]ΜEIA<YDtPYtl0^13w��>MIlXi;鉑Fػgu!>>#"1jȠw|fRM#pse��{<ȱر5:>'fŴ6w%-w7{ goQh_!\>�yCٻ$?g jy]}, q3L?'PgPqW��l˗c{ceO-162"# ;�o�#-#Ӝrt; ��z&'ػ0EO- |O6͟>`�ɜ Up�GrvǼtKWg9>-ĒE LxEs>Z/��PWdfݬv3 v4wC=?| g je驱FF/-s! k6=%#{3ӄ�I͎rF\_4%MtblIc3&8n5QQジF%E . ˅{ϽxrA@D/enjYN%ʉV|^9WwA:۾L $q~z^:sQy$sŸ7ZeDzi_5!hgvj~f{��K74WMf$r_)96-jcDŀ(82iת.yzНUM ��b.jy + -wJ悽}cN+Q{wEcIV!Ao �u[=eeleozN:\;XlhiF|Ț o!�QQ} <5`e̓<m"*sҾY9Ϋ ]07�v[-ĺS6h7o�hXU1l{?La�oTvzНշ} ;F�QawAd +hBfWa9eٽ �x~xkvZ?La�Qv{3JQl^t�ط<֝"S@jF2%1~yPsU=2im �xz<{Nmt>x>oFi~%n۹ 1mM�)]D?ojZV-<z>V�<QY֞g�?)chʿZ �rEʽ  2e)qw}2'hB� +uGr׶ng�[}I}z\w}3T�bw 2ȫÜ +׶1uxmnB]�溺 #D?�=֫cSW�_684UY-_sVn٘^Y�@}檞D?CuYIKԓzo-� -vzR;f�1sdzT__{1{Lj�”ewz"S@vf?eAFlPs^W^o/�4eڸc|׬} 2NJqd N(-R (1fkO?La�0V',-GW3b�hJ#"S�:eKUɝ�T/?l"S�iӲ~vx+g �;Oﲁ"ZZ;Ad +ôGHYy\UwJF!u �d"S�Fh+)On&F~^?0;Eݣ\5-YT�uoezWD?�PYlnTjV�Y3+滬ےAd +r|ojDž¢96�4v ٫]׹"S�TpxoeҮsub ]|u;^߲?La�xZ"?V 7$+�-GKWgD?�<+6DybCˬQ&-{[�ɏG'dZׯ"S�6}9i,МW yNѐߧ1w,ⳃʿ[D?�4nKF*Yɛ~yO/ E89+;Ad +@Cǭ뙚; 9F�n_8WWw)2TnhBQֽ�ozozڿGD?�</DM ڝSil7"z�$7ˢ4Zߟ"S�V3B/گ9/j{eF�Ygwd;w'�:GRHJܶs � ZuQ'k?ߙ"S�DqvݫPͲ}�Tqvz3Ad +h/FU"mB 4UCw^G]D�@sۊeR{Ad +@xwJ'uI'rv.�dn±8wJ??La�$ὕ1[xuL]7--M��σϛtr;y7?La�D P"^qv �hhYige%-D)�7s͞*O>�R⶝wB)�ux2=)檺W6.4uw�<kĒ)= 2xcekPTXz&gLm֙bQ)5FDJU0x(%ະ785vEE $dD63II2^y=Jgџ?[�Z1FwA�w3mw9T讦6爿�5جuDc-uY+0+-v\m񸞢�xZeVsݪ̽;A�wҾ*=VS\QB��OL܈u?�a{d5ɖ{gg#�q)~8nsϱ?;ؑiq_B=�#'K1`ʭ+<E�8maڶלA\=C_d-˲W�^ + %J}Y]4_M�?E?r~Aν nQl,c�h|oR"kmV+f /�dj`c?NcW{A٦=~Eb�h~ mVz2Pg=�h~E.cWtb\�.^7ɖ[kdk�ÎE4 +8wjvY=ȘQy3�{Ɛ0ձA#7� "?z$2_?.o�{$gTh/_*�dSý{A:kzPbNN\} 9��uFK!bYMmVsݪA@Jb7ل ;A:=t x>#=_jb/p2+%)R<#X+7=as}#�@[9EڒKגzyA�O<.Z9&S4q,N6*Ƀ5<`l+��Q|Q|cљ7+vdE�/7tRna(NcWJzHZ(2=nҀz.�u^<N +uvm{`@uȮMu3[KMe} ? �5AҮ8O}zv}wdR?w^^ 8jHLcϰ?�@݌Ew3|j-D1%>]wʧd}MiG?�1QZgLwlX졝E(�Y#{_.b-�?m'U�hMR:'lLb-�Ӣ1ͿX6]˖{ߝ.f ^8a-�g@X`ҝ'r$v~�p._"zA�<ކ)UElj^]rDzZ߰?�'q2QjҩE0�ӭuV9a-�OkgJ yJ)8X]Z-|s<Ya-�ch}kzjxƙo�mMJ~a-�gěnm*_4[]57 +h)�hcZ`(P:£�= 2A�1RhWKdenex;xdyR>CKDKa�@bCN] :�\KMtj Z +�?d7U9z韧c9o� l|^zZw?�g_iERr.=K@Sr6h)� éJV\Y\@֌ (`-�t -M^#M4;1/3H;yiKVJZW?��zGNb,69lZ)ln$QR�:|zK^n<o-/&lج@n`-�'l}HlY7nx{_mmYu {'h)�pMO>A}ɖQǩh)�pm{7ɖ[bf�>li SR�. 6 v7.VкwcX!j Z +�`|}J/3xz:= u}R�^:BR6/.dKO�<9#@�A�S) ?y. +) isR{DKa�{#x&g5<à1o)�Ƕy{ Z +�ܟϢR.M.|M/h*GqR� ~Uqa_@-5xh1MV#qzX(Z@TGa.њJttM'軞q&fZL=,g39omy雴KWW.[:m1S�`>?iK,T,N6~ڶ6ufA�SpaY1RSUnm;ݴ}lA�5w}Uiq5] ӾhUnA�w0sGez,<.92 @hc';a1S�|t-.'Fo ߻�·džuNgA�4?#<X(V{g֧ڂ߿C:Gr:b?�y ",7XUZ]F`@sÙokXNA�4o}bD.PRY] hn fU`sJ f +�2d09ii<N?^dN4Seɮ7b?��O_u$m*So}#2z/ǕӋe٤3�)ߵ3,'f2:l7b?��x +suL,G2�3zPlu"~7b?��-zQٷX+NY\kmίJTl%93�hbX3j]IjŽ$X7b?�� ~BԁWO hg6Z +fA�y|d۟$;e4eeYfA�h2H+C"~R#f`4EO(M.< )�/!bB5Usj?Sn]hj.N>d۟7gb?��/ =2 +jwT\љt@Sq mqzE  +9)Ź\5[f)#F?� +B79.[T 4~\y[ikfA\5!'9Φݚ4o`)yƼ3k3�cq9/mv^w+;gAN֛)qtmPk<G��,c#S Vd|Ɯ�WtR9xmmnJ,?+&n%RU+/==�22=aRS]4Uw=Ք)Y7WIzsD [fZRc֬ӎ3Z{"GqѢן�Y9MedjwΕc;O\hR%Vs?+8W\&/o_!:=G��4!wrXT"#8w?hl8Jov1 ORx;Υ=v?krG'w�iHaMuNjg7?Hb>?TofeǯߟNP�]=Skݩmkn}r[�Q7f;SE5~P"Kw#,qfA^vڷyE=n[C{(bzS52~C֓z(ȶw�ZdnwBV;Ó 4~26fBۿ~i{Z2nuxIA'#xϊFA�w!.?}v'/Hŕ@c v9қmOWigvSdSDٗxNEww?��dB'mxI%bVZ'/SvP}\?&gϮT{~{Hw;Ϊ=,h!?��m=Aj~>Fb Ӓwԛ qմlBH]u$W*dg��W5`n{ +H=u$IUCx^},?B��2P_a5ݏ(5U}T>{e;#𢜉c|A�)5ZX+]Y\{#"\\Y?Fx1S�dĖCiUΩwv}-%Ƶņo;b?��MOaŲT]X=2#ΞNn.~ޙ3�h  =VYzb$-3<pt7N f +�Д $m_-O*֚ёA@CW˧s1S��3h_vNTe^dW+Ȑ.;f3�0Akg9ej‘y<PGN;{L��;Wo]f,txLONbE =b?��f-zANyq "hmFmc5ij:Q[b6U5&FQ(H Q1JE Ȳ=pXD"E 8M2iF{t:ip0.gg&?o|G{lY/~Lxߝڍ>6[f#�0)"|d\|>=y-P|NS. ?��ٻǞPg%n}]6/)�;.@J*<}gSDpo׮XZZA�xJAk~p&_pw#fCnկ)nA�]0b^|*l֬g<EwQ + sz F +�o}3n9 p{;PӻQ1R��zoZZ6ۧ~kMa|7w(Jd#�^9Mڞ3/%~ +ckL(:lջK1R��|errCUZo0FG≃EY=?��}/)ڲ2Ui.WytL?]s}iz F +��}ϯf^~X\YL|gqPz7 F +�y6CUZև1,Hӻ?1R��<&KrS8ܶ +A+|V)��C87Fx2?RDHa�� #⇗֫UiU9sO|ErfƼ`[c#�w*igAz;Q|EQniQg)��{z +zp}zuu[SnA��K^V$ѹAZʝ򓂑pm[iZg]?��ͦ=ڳd퍽R8T|υk*Se]A��w|hc6fmS<C|߅kqJKxF[b#�bimU~}=Dw^۶8-9b#�@瘸#\$Wj}[3쯋/a R7DvHa��yz"2 zfmur 1ԠcnJ�a#�@f cޫ_+ ,?w/b?��畤?@>Y[nխyE|'F穌?fw'b?�� :9ߡ*'- ݋9SwGԻ1R��H-Fޒc<Z{avy)��\Ohi[WWUNM$ =FZm]?��xi\{ +/'ޕdSƣ6л1R��wExvV}Zb ߙ|7Fҽ1R��Y cNJfmY:iތžOh=g�)��a^ Mw3+g|77ߙ<X~{1R��t!R5 Ui]<4goVP=9I?��1QZ$8 +45'|f#�@56Oҋ,G2dNŵڷ Ha��е --N:D68lkFwktN]X`4wHa��` O&mO[ +M>ޯvRѷeW͈g䷂Kyֿ32 ��c+PsmYf^UkK}SqhPEfSftK^ 薝goO⺵C~��XVfP*ڿ'kn;9%vdYϗ\M=\B{c��`\#I왇'R #bL ;_sJbmw��;W3&_tJwwoHOos;⊉ te-# zJد4ըy��d$icy5f|nkH((vU!fso\sgMK=~��߶3ӞS7w(pwH,=X7cΈD/aIJ<mKY{6/?��p?=CHaۇ֫ήyլ&?}\,ILM}/yM�Z8o6.Q,5ݻw@tR��},z3?=V5m&GSj 2:Nӯ/<hdT냵kNjGb-0>yР !pIryA|uuGmZ;ᆽ^#r!~3y7HߴY<L8qpLIZwOyg sym<c(  /Ϧɴpu6?ϥr6%Ou�d`wGr!?8Hn/݇  )Qhhhi9M[:w}s!m@m>)!!O:J}+xƸg4aK*0>tꢮ7Ty $m1WWq;OP +BH-8K0mOR_fU` ~s?z􍑞1ZSreNɩY! ce~BuzrA^TBh]7xc8#3$?eF}r<kHܮpn~i5'CMxsvOaEt6Ҧ[3;׹'lo[0Wډc{;I7Ջy8|ۗ*Zݧ \DUBA.v>^6F݀KM@p¢L=`Xcz\!H&w{¸ƌ�mP4'8;b(W`h^oKr@oͅp:+Hx4R<3$iuQWfb){?E"]SJƐZAѦ;Ї_$ +|+o 2%!*㙠ۻ6]f$،Km}#?>M Z~z/dQ9A-"#Z頮qkTX'i퐜ȡܜ%ޛT/Jzb|x?;5 <_IlNxWSF ܖοo5 ѵ9H:7y{y˕¿vN]Q Q�Z<deL tOFD1~m=s:MWk +orQFnTU<EUѪ<lo$gҦ[I z�']sm+(vBۗ�= 낳_X.%}36/$[yA"$'v]O L8~n#~,sfwP`R�rjAuנÇJiU.<qSTޮ`It[jmkΟ 564xsRJ=dmx`m_{?`07~Fݘv/1\\7 +A \Mzח%=F h++Sǭ#P1>UOΐ1z۠̊dnzahVqpk:7uZ1?JLǶ<Ǘ6ݑC?E-騜oqQI:. KoA]󼅏~,>h¿kF`R"L>InKY~qƆjpj)uݻjZb|9ܢL50ԅI+rGpvR<_\@u|K HVjBB;m3a0ߚ~,:"SS9 ck__i*KfBzVjCSm{Å&/UU>j,+O v=< 7d۰O<BEHhg4馾6u4nc&! ˥*Mqg@~C~>?w?0)Fj,!cH-hေRZ,Y� uvwl +Z頮qa~�?]?]3׸?br'BYgPb:&)g@{c!:$c<t~AWt/mu6?5kc, w?0)F騜zyt $C0ޠCC<}Eoۏͅ=6F]sĒDbRVPn8Jmr[oug,x1۞%![š\tnE]o90uYyEVOd<̬HBA^Mfb*Z⼃~u޵h'V4ߙ)U>rCۘ, KjLݻj~޼ +hmK-5]nQgGLIfG顽d5hU7`%FFez=a~0.a%imþ}.Rsۧ!Zͷ8u +_T?x  #Mlݾ C]J5ho90Y)tmf9ķC~Eq|X5UkC:&<Sc(S ZԢCCN! +p<ۻcVBi5jRDL34LlW{vu=r|3޻hYC{ej#R_|_Sf&/tR+Ռ^R+nRaMWea~n!=6+= Sm7ۂW\cr;tsOLCB>RsA̟ҦOYRB],19`xS<N@AuD%SA5H +;jpexWM  `,P9\q@j1JzUw`KǸ:; o +AA'3Rˆ*?n W?3+ HpL_ ÛAA))ղvCWvn '{o˳B@@AD*eD.t2tt.Rz7x|ξ`dG<' o +AA&0-(5P6]p_r?m {\7ǴK &oT pն[lkimxXbkfq2׌YC5l %>A Lo_9-'_ 53;] 7F rVAץX_5tYu<,3{)YiDeZS>E" D<2}#ѱi]aTPMMuy& !KSp=7)qѨQllM: xFՌ^uʹcSҤwGɝ0؛,Y`xSxʘKo,+ʭ>8ʵ':s:wo{AdAF4y_liY#;< +=9`xSxRurFq_ԡSuvxejdp?Jf35smTlSnr6%*kxh̝Pu9?I(NtNUʷ{9k-܇ɺ7_Pᅊ}7}&?g ,I8Fs23֤?7i,V(װ-V8<T'[7 `\(mkP$w̐gbjH?!H3rAj[A<nj0|- x&DE}NІú@_`f o +OWKڴ|dَ\zj-a+V4Ϣ)|r5656|}m5#9{p] �{ͪ VMu֨hm/iU n~`Ėz _U^<"(,5r̪(\ЦڦoئF! k2MoD~ȴgS[pmm_3abh'ob91ܛ7gi\},Gu^/5`oN9w.R?{ gFgJZ7KWvsu%wMi/ &f&Vk:xenq?9mdU`2sk_ ۂ[tPSCPC]jP0Im:,kYC{׼O=+g\e[C0O5ssF;gpF-;0=]8!}U֠tsnCA<"5ҦwN'/ 4y=`xSxL}Qh>$E8pq[!$@QZ1G|,تɆzK&+yOsin|cUyt?<|4yCZ#s6[<h8㉝fFJc -KH{cj.U > . f%?CA^ص1ϝ)2AwMt0X_R?y}mBLRöP]ipMaU;'A}$qs ( y! Zkupn ypcgsi} x?57-;0֝XqqB9UY_k_~4|6VElVmx rfp|'.-oiwMi/ &CVCܙ>ʶ"@ c@- `_%`|ˑ-pOg'Ȃ]WB늴P ~Me,Ώɺ7T7f0-j~pypҶ8?G#�rEVMHe dtj+ <LM%274yS WҪ{7@>U"qrNGYI3A , ۬Z{&/B vgYXs}cGB`_LcY7e1)q7?-khoeLyU+ <ټGmk6@mq?{PSgPu/]]kZ*ㅪUzk\!  1Ɂ* +kTݱVQtwgg3;_a9x<9=ΐpaa3FAs?)?A"z\*ڇG#g86g?x|zbr# i3ah>[XحƏ?sE}/cYryOMMXnjBLnz7v-`h?=���>aL봞kǫT+ kϹpJuJ3?)?ǟrbP?:)nM3#_'O+Oڧ9tg鳥,NSkT%۫ `oTiDq(뱴ʓrTJZgSQc oهN[G}eD_GQSYYT?O~u=,?!wRQ͊щe'Z\n5���/ˆLRY6sk=aɷO\2(< Rxfw�AeִZC=>g`ocF+Oe6h2u޻Ti3BgU S,/{t[AѳTێÓݬHC=}'<l{9Fdy]9"k4zM$CZ_55{sb|7ڝ^DQ63,˼XrE;���d^0r)TuA\3L3t= "G "`KR[!;.eȩVf}-v-���WlFLVu?/\&\TJ(NR?R c*[cjmT!s;1%F5/v��� 1+'SZU|J՝zE_ 9!I*f֏5���*;j`As~]mBH=zާN;c Į����cl/3;HK^哽 z:!?)ő����`VbSAui9CΙ&ıBj R +�����f"qYWs-\ݴP:>ͱ !?)����[|aF+Uw}^Hul!u?)����ЕEi;4F/kۥ +Æzk)S H)���� >_s&Fx5䡉Bj R +����6!LAK ck^=˘k"i�����0fMNmZ6C?R�����*sީAm<Q/R�����ɛFz憌۞?L;c<G~DJ�����<;a6Esʆ9eJT,ό|]^DJ�����<?.eRE1O}UNoi2w!{?)����,9ᡫb\ݟůGy)a YH)����{G WXsyݣj?tMBօ }訑yQF{6{Ϛ +uj8세w=\]{����зL_ȫJc}s&ʥ=]GvM߿Iz^3e*AUyߖ˘ɠ,ΕYrh֕sٛ{����3g3\/7d+;ƆZ +�O/bz]|k Ls:LsLis@ŮA~.o/kkZJGT3w_c Z͍1\O޴Ԗhk]pd5�19xhKQsz}wD"As?fMr[vy^C K=ϵ]3;2~NLϚ4bc~J3җp+cټHS:k�8cs8cDRr{S@'..)Ǧe+hl ƊSSϗmxmNk@^npƎ3v<9_C'sLM�cm~o9m4#}i b.C@xk�8cs8cL}k=zb+C2[Vt[ǬnA13Xn�����ooC{7rwgL<ל5򺋳3S[k,8<ֺ hw_?f;�����@?4רoC{7[k8eWקƒCiNЌ*AAAW8I;w$S~d% +??8>}+5'v]9>T:   X9̴vkwD_F_Tpq qzQ6 _)aaAQ +TPkDV 0 E%aY::i'NR=I.8̮,y9|s�����������RIeE&݃Me q=,%oZ?XW}lJvPXw%b|"6l6u72"R9{fF'٧2ESQ`n]_2"Imw{匟:Oo_oח]yybjk&*Zt&zMU}vjX~[b$2\J_2d)~!ST⻗_9'd,e1ꎊmc@Ii]grrzmrKzMUOENQ}J?ŹՊ'_H)ܔT}O-ik?2v-"O1m0\Ϥ;[k'7Vtx16I;ᗿP?2dTEyY][!ގJ%M@_xHG1:TwVcWIVld{?gtҒ62v=5-w5f3Mm|˵EG{MjPMV;|;k{sk1&aOW}uGIlۻum7MWk8fO5Um}&cףr9]>|e}&c|$Hأo_ J%[c"K Y"cL.bl7Ɖ2.8 +TOf}cNsi>FkXW-5xyxHRXl!/|]޶Xd g:[8T!ko1K+汥PVdɤK۪5۶/ SA^3ƅ1ZamܾPQ{~"9c4+Jd/9t~T%z{+(Hg6Wy?REփkcDIqśZ,JjT#;yl>yԇ >d^cʴmkgz:c\\iOMb΅b r8nJ?o45[5, 6)tmeEt5C>~{<PX_2"Ғ vqp1N͞#3c]ux&cL&]V6߶}qhQ9c\;)+* k'qѷf k2]ɹT!5ԝ+^ޭkT?REփkcT%t3Z/XLߋ{2dbZsVmkI1,ꏠ@d>4l39nx[>^^mMK+<85Q3ʂdϙ+gh =#d,IfI7vug?iMTujFcÙj' 館0T)dIxKW/iNh M)Ͷ[v\_mݥȥ#!cslXWFD*d<_Rу~<y"K{!wW$y xq3qOƘLĹEq?x!wuڮ.8slxw?jϝ׽kͱyi{T(ޘo5O\~~vm*77zCi#-Wڹaեmv EΛ5UgtsSRUFI\IbԩvmQ.Ƌ˗RmdDSQ$@YQaدD!F8{hxKgqVV$gqMT .k?ا>=ۚFwǖYS"W]U;%ˊ'.q&1?r$P?ܽӮ1sHaOk?2vMkWZ5bIr\Ԡ ,ά'PwPSY85MuErvO\ GƘL<=J&CߺT;1sHWCIo1>`siɆ@??'c!&+}xbڻjay]~\c|+%cSb۾&*ZP,L>;[v&>اV<~$<4v}��������������������������������������������������������������������������������������������������������������������������!���a�������������������������������������������@�]8 endstream endobj 277 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 34667/Name/X/SMask 286 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_<(3xs(hFc"z&+LLBXˈf5 +AD<VDPQ"@c`af{a@f@%FˬwD-kwSP";/USkܥmh~~^ޯQͶq3v|{Y ���cbY66N&U˳9=ϛCR<K|t39<|Jӿxn^hܾZ u_jY1W\">:uװ%���+)Qy=TC_Cp4ʊ$J5s{\so#vӎV! +"_BQ᭾K#Z,Z-j7U1Ƙ;"���08UwrQ^#Eto]gO9/2_RN +GcsY`w[n[5Ǵ2Epc����×=-(7C/S6l^G=>CyLI>.F-V؎HW|οɯI⼧L ���0 Lq}nٙLߗ]CPg<:vXE(En"b{ގ ZUZy-l)����ߵWg?@(K<"[$f;Fh?иɛ<YivY^���+G<sT-b8y×QI8yZm^D.QTĜqc>���WÏilFp,K Q gq×3j8][Xۇ���?Eҩ~dB<$Jm3hwggE:k*���^ K ""_H̋\G33_*n)z,wimiJ���^Y;ϾS^dlܨ ih迚~lTRc|��� 4v˓ #?.*Mk4}ƕZTD''>}���xnGBB&{Mh~Hxn-Q踐\ڣv+]3?|Β���<p{r ;�BNޥcVqlǿwhKޭ$W|e W ���LR"&wm9CP?3} +*NAǢ>N5mnj{����O%#|rٜ3B!0ϊa}nݿǤU/S)[J/^;���&y{ZBAfNOj*0rLkO4 'K\���0Sɫ= B̏H)z.kҬF#G9u8+KK���(Dӂ�! A&ȍ8pVC_7plË{-6</\> +���`3B4Mh8-2 FwX AVǿ���� H봊 $?ybD'Y/qoU[\����Ҝ\1݌�!Af\T4C=Ǵ4L@MAk>$s>���t2DYZX�!amn CVzk/rm߳a5���PiL%-Q $_;dخW_1t~gn|���2eJ" 3hA:saWz#Ȏ)I~oM���`8V + $? Xd +u9 j־MZ}p��� x嬢I?@HCMuĹLC4h;w7Ls>>���0JS6q [JS=oV,]wutHh7lm>F��� +}5('Bx5Sw6&R)nT|}��� 0z,�!A<یBTrLQôoh.5qG +���QfnŨ2?@H7s#D%kuWz*;8f4{CC'h��`_ٴNj͚'jW c}5]j8B)+]' ���#XnTB?^|&zQSt5ʖ ?詏<LɌ^���F S0BxyiLEVLMb\m;?$Mq��RűI`wj$fym΁ƭ]9VW2j̑C.y].^R wLѪ(V"x +bR$^.{Vd*Qjb�LҤ =;C'eQ8<pf|=v���D<gϚF+zĮc>? r{��Yl; 㛚lif5-Betj_ҴkxrwLIO���D,YhC�!AҎXmQijDk{_WΣ߸'iz:Qóh3ӷT(sl5۸5]cd{F1IbcKÃֈ, <7���xNg2D�!ALݻҋspZ}4QMѿ%tլVKx\}53U֮hwu\n%:҃Qo7.& ]O!YjVR71s'ߣ���0m|r?@H?z7a>t"f,sr~P"t"2m#-e" >H\?-ʻPyt|搽D(��L=zF{;}@~GӜxrͬWd_o<O!?]D|^2r׏��xxM>Bo(6 T];3D&)ѣr_̉0-5bgGGG��dlmIJ q +C9 =j_d_>2Oл=3뉾.ﺽYmes$̙9ՓQ��xZzF*A�!A޹=~\>[pn3/3D}TfTUްa c �� x-޿>7?@H?l/R#iz˾?Og寃p<$jV6R{o��@v h mf6?کLbLQa|v胉q+/ u2` ߣ �� ({.v +m`:^,姮DA5=ۼ2M&2=50`Ib��Ktcv~|hKm#m!b2ҙ5DMsj$fT~|_$F��bGsK?@P?N#ST-lfՍGט#:'5\Rą{��^ܻ5| +Gߋ_IAu۷K)M == 4/,ߵ:}cJQ?{{��e'˽pEayYFAǥeYM*+yt5.5-7)w|?��͒id{og�J>"٧77D6VWrVq)yg#G(���ձϳfevb1QU]/9hgAFV}+fk Awg%ߟvяg]+r3X&uǻ!A.���.ͩ[+X2yj29eQV9gYn5ɠm)Zb˞L?Kf3'@C.jIi5y~${ ��왬%z6ت铧p==zfk \y:{Z:Y\ y;ySB޻9Y}S};��(I֟c*5zkFV?o:2m]!8к]\>_HDsP(>Y��by^S\E�[̈(QU]/>mvCzO*5g +^4DIUfi/;6 998�� \'/U^D�[ePY'#^/Ãֈ[jdaR]A]mWT%/jVXɣq ܚXQv4iђYI,��KT +CNlUZQdak֡:qR<i2/;+/MD5J6*bcz��@`s +ULQu2YGxqw?^L Ԣdnkso\OTEa~ڢUUŅ��@Ԫ;'D�[̈(QU]/>?v]g.Q[Τ)?Saj8:s+PED.\u MDeH]LPҽwN29Ln.kdVgͮbǨ~9ޯyQs8~{]weseyON&!Qx]M1g51!9ٮݻ1>,\ܼ!��ۗve[*= :v-D,7Zצ_#|އRwZ[ӧ4RJ;!Z+O5 ~V)mԶ|Gޝ g���t4'Uֳy4hFzD󚅑g(БC9[_9eg r*,f51֌r.]_6$uři$ +�� +ɷI?#+Hp[i l̞#`8앟A@8ƕ"r6WrﴜYuO,Ck|tj[(jlKv6n< �� v|"6?2uc'қyic_b%q9عJU\,+;C[EC{:͎#j޿mxo $ +��/BzclOO?WeZq! 'o٤ m|_xPgV;QHflE"W��3jNZNf2u1uqjNVQJڣhc]9٦Rv?fiVFh_ ��'9٭Ͻ<F�} YBY\:}&^9E1ټ[EzޝKft��=dK2F�}E]kRI.'5+3_#ͧ8Yc|(-KZ; u��=rݎ+3O?7Mץ(dMe7J|>KԐG:vv#&7%5k*}�lt^P6{?@ 5r+J*?ȉEwR@_M/gV!kPYtW��1lDҟ\'8ƕr 8IodX;Gݕ8WX|+cwL-/޴1Ó,M��Ёźl^F[6o?@ >+}(Y3o:JJ,'gBF~w<Z|x5 3]\us��๞]t{m؜E�}f%j_߿1 h9!|}AGC%%w4rB���[;~ڊW'HkbDZQ1QփSzw"#$~Z;2)6r∑ddhS��yn?߱܌V'H[e9u0G8v~GODT#WX\*~?-'k<Rg׆}ȶ O��!ctٌԥFl>A@2F.DJUMq KߕHQs@ѳ n3+Gw4򒋥Y}j:l8 ~N��{3mцl>A@#6q^'LɛO+Ko6ۿ]M1.$nJYzCIE;lS0!d,��o` ["l>A@3F ++J+ٙkJUUFϿ)''+bBzm'$-}O-;X16LWnՙg��p!{ǝ7iDRt^qNZQJ\O) $:v~_ݐR,K/qvť' +6pqF],:�FF11T7;?@ |*?ڮ:sW$y9DG#j-1Ok^;[D(v(gW~ve˺.Q O�2 +$ +X$"Xw-Mͨ9udIݭ:SO.ԫk7͆lz}_Կ-ή cOоhGi@ݻ<؁8 qCqMDnN#hQ4yh=<Աhڸ4ŕ]'7uH~'?i2͚<S{xRzMei4w ]f̤޺|K}taoY_,"/|D<1!%6$:L'߱L^!dM%g󿫿O) $]aIgܼnHȽn~s`ﶼϴU+==:[v�>(q624|O[uҝUKve䙆'\p2P*Vu"*Xe(2Ddd' $ a.u *V(7LN Ϲ� M{'G&<;Yė+/7+nL80q_itbov5O;{uovk8: d2 x&&찷Q#Sb͌?>'!04)rX!k8g2"my1H'a|섳^yIq+dŇbJ332Sie,VD J$bY" .u޺HfQ@z+=+jܗ/h/G��j5`(^6W{5&cBޝdg-%~9ӣNN{62,XJܤ`GzF9"Bx]]?)Sahg&L\|첰yVU;ܵ[qWW�&s8qЃ^"sw܋ 4KvYS37N Ɍɏprxd'zS~|4?5֟vs!?{2'1$=)$#S̥}%ěY,q;_$gBis+C/d> N~(RfV ӛ/fKsS.7%_-Y#i)*nwO :+8+zVs,EO+Ow7]{{zݶl[`I^nEo/\ܺڤrg=vKM꾰Uǿ,]1 ͆?+|ȳ|S9&Oe|ȝޕ>eP'X^ݤq;cq#Bt)m*p.�4h<P@PZOٳz@r/@@PLPh7���v�y;�rl)�l�Y�|<kYE son6 cX&?f\r-{FOgsiL("=hG~ҏ߈8JW$%_}SsqIFľǾFyUC4;'<lc|g2dx٫Zۨد[�Òs`0yǴ{AO[t45i7WWS7O> + K[Cut`;� Gw #cΘ K΃ Laܺj5V#nnA=: ψ E&!^TM&^N\7qn}z?X%h!KVRn\~!,d?E< z)=O˫уtݾu[o_xώ\uۅklՌ=&wgg׆2o^9v/GXtċ%ß :oy&X0KQ 2fOT2O7ߟ|ۥ)9Eʟ8sY'1aY}K)qNEGD [-g3q`)?"9{^Ľ)|Ŗt�y78dvIy7Niݤ *O落Bܔ+,oG_)8W{1uR>+:%~Xkwb:cgwR~C^RBRnp^Kڄx2_/,T`6qm޵5`4 wC�-H�v2W{2:2 ,zsKލ?0He>sˊ%;c挍�{rG�R/ݛ[%BnG rV&cK3Toȝ(klǂYZ5𦪓u'g'~'a=nx~k #Qr�:�R[ގ> H]AO;˅;NQ@;_93d<➷S|/  _b!Eޅ?0@@ ҂ yb!*iA+n8W ސ 22m!9)'ə%_W   a\ey(Sp ϏsY,w4y xR{F u_ޙk rBm{c@A`>;?By?0@gƹ| Q +w a)Q@M`pܰHmxz AynGc9\y(Sp XU/Lp#g:=L  uQxy(Sp `AnX6 9wAAW.7椄{ FQVt]�bZ.wHDn4 w + 7)Ws~Ey`Q4^1v^Ga&VFS<`4"A@<*" ." +/" +*A8dرΚMC}f>~$wt)oWN);2'l +{�G9e8-';A<O0mڲĿ*s*i/��<L%RdfbDOat]8NRCl�;n1^Y+/SD~Am_/}��W+ z +wHan҆Ge"Y]8d;��E6.7,St}&rRzNX .nF�x6bDOa�L+fݩ �3R]a뎎b=1 ezl}o;�yYjI4O? v%g\K"�Pg 8zAp>~ŒZjiS)w�@ԮQ͂׽$SVK 3礱biHZn�mֽ1sODOG?�9SGRWk;2[�ϱOw/DOa�.x0/9z`lQ,H}W�, SҒ):T�@\uoLS/7ib"K 7+Vdj[��vakfC} z +x<%,5xH-b?uw�WmB/lLǭ] q og4؊2WMQwϱ?'cB|!U=O KO,Ҿ��0%o1⊱&>lJ߲tIS Y)^,gvs y"Kw*B2�:ݭx_3rm!hܸhsM=�_/zGXwb?%xig��o˧q0U4srI5)f)#{ �]8E7_>awR4;e?JX3lǺ[SNҾ��I ۬{.awI…]jØÚt,@jMRsk8�S>cBFynݺY!CElΣx&h_gíט׾��Ι9T|wt nfh׻p4TeKM~b�O߳ +M;` Ų[k;�ko備t͹7ӭSgaNh׶폞յpl,=lJSc$c:'i}iz/V}�ulS"Kdwb:FK7ozƱ?f[Ko1 A^ȷΙO ?�6nU.[g/8w 6mkʁ텙{ϱ?�kx!231D='.}K�<}7ϬY*`Wq׎11jM~klϱ?�9ې#*ͩB�MYTRMpqEa?;s-2P6_-:>$;�>YJ6:)u \gMٮʜ+E�@˪+9m<?�7u]lVJoU, 7Mվ�-FY/'MrS{p!PdxFƫZw$�ɫ>pC;A^~,^-/}W�&VYSv8?�;0')#r,>o}g�[rVkr z +p_}&>a5\I�<2[jƬ˜{S{w>bXn?ˍߝZ`}�~Ҭ<)@:.#Ŏ*kŲP�Wb1cm ;A/",촥Q˗jߥ�+jVIӜvS VtϵՊ,߮X<4MN�4E6.7|?�{Z0ֽ +�x4E-I|?�otǭsճ^WS0W~�<b1__d6g=xv#y dsmGNҾg�?R!w8)d)JܗRy�~Df=xϰx̚@;�<!@]6{lSد(;cPƓIZ36cM=Z Qš"Q ƊRO +ȱ>F(R jI<btj'q_GbԈ݇g2|~O#5T6הɦ)Lո?m?� ]7Kړt¤cſ�-l3Dh?�(:=b1^ƒub�hKF4)WдDKa�hODi}NS_n_Iv@[q2ql?�g"|C׏Ǜ.}}]61>}Nf-x~W,es͝cAg@pS2-<1h)�?(i&+*npFfC77qk?�<]wOesUjzG[ �Z<r ]7Y?�$/'E&;6Hml?z~@+sddw.:Y?�4vKeTXVL �VJ·Y?�:_]`1^{Uuo�pU+wYA_d)pJ%r.]M�nŌJz4YR� au6QS͙?$.:Y?�,u#-tn1]S;(O�ާaKes[DKa�h WIrӶ+Re;:�8UŲZݩ?�Yg=Swd*T;�8ۧ ,Ƌ.e-X2^1&es]P<7�ѭ[mse-yS\ٲ9E0o=�8r?DKa�x:tL6ޫ7Q7E�?|quw?� w&HYuL&�jwd-@-+=T262S�TSlٹd-@.acHQ%bvI/�@ E{e{A�gۘwJ'}v$J��<Og +?M'A�g1d4cOt 7L�PeK=͚Eݍ?�8^&Hk{9ܢD�*r3MQw"h)�lJOa+Z(>�r̪k9L݅?�8;ϐQM˦KesͽY2 �[_nI^AR�\+|8KjYsu)V�gu3 Z +i7V9wɳ �,-CDKa�pE^> +qL6]pLOw�\Uٻ';A�WڙҞT&UT?�*D궏Rwh)�cHivҚ>G,v\{Txpv;�aK2㇩{A\!6o$?{�Z'bޜlwt_E&]-�OB<Xo:U.6}�lYn+v"p|7�ݔq}؁^cgOo8И]�yBӶ )Mv電AC3�cr7wWw8s6�ֽ/[mPzҚ~w7�`~ou/u?ƳCȬ\hqg3�~?mu?\3]�M}q%Rw8kvFr!ݽ3�qR>acԖɦ+7m#7� #=<˃ ?@rWǍ�7%gTXVL�6k&m[A[yP~NJLI Oj?�eCFJs./-{Uu�mn 7ظbNO҂@١4 {eqҀ/6[*2P>+k) ;iۚ�ZSIRlN"f]@Ttr77r?3ea`7Yl[9w^NYO��ykh|Cљ7*>#жIɆ}8R4qEgCs ;_e�@acJd222$�چ]71'qK {�4ZtÚtCgN�о&Wz+P/?ı?>'&~w�вGuesSQц�uwr]>kPTZo1fhLjӉꘊj4e5QQԡJ,gYvo ǻPf&I'jʉg/cy?La�@`=F) X;;@NwJg2: F>pD?�in\^%*�mƍb ?La�8\Y`^*\*珵-�ÿjޛo-fAd +�xm +v/\N.�}N-_P9�<q:fr|,_�KfAd +�_%ÔQtg70�Bӭ|]=kvkD?�zt%ceӓ}5իw�ʍ)G=evcD?�ut Qf\ϭֶզ;U+w�f իV)�h]/Ewr[k7W;5�_SIu3+"S�t 2՗3n;.o�C|Y{ 2�OOKȺy~"r-B||.u|מivKD?�3QٮY?4m~|bW]@p=d-솰?La�3aNJNZrwKf<�Cz*ѓ`v;D?�z~%&+iDV9>2@<ۙw 2�b%śa5n_V�Sg׭fAd +�dI]뀮k{'eM߃�<{'Y7Ydv+D?�@^+(qH\9\i' xuǕ ݳn�Oww$Q?@|'luG:5em`�XҷV9m_ 2�ߪ%g<ۙ-#�O1u-:afAd +�ۤrIjU3S|O4Wc-wfwAd +�ߏAY阖 XDw%�}7YҷfvD?� t gw|ǗL�-B-ng�2D磟~xjLd sθ?{ݳ?La�@hb)wB㆟pg]0 +ɟ{콳?La�@hs濗o6z.R>nD?� uY<TYfKQ_s]}|l;Sg��yfÝݸ޴H|N:m)�=ijU:9C|Fmt0{"S� Q?Ml źZEހ;�saFe~; 2�rin_˸uEvC}FEc)�_}KE^qw.�}7~; ?La�@ھe?μp9@Q>2.je�?.AO-k97⭞H hn'3XqoAd +�ڦnK)+2jlp\ h-:c/.e^D?�m;]I,<z.5w+"o⡦Ad +�2Dϭֶ|TǬpLɀnբ~荲?La��㥨7ΝӌT;Pwˀ^MBYm?La��Wy{8E ;51ч5@oAd +�`pe-<9iƻm{ [k7ճ#�YDe(uϝO*2.YC)�ØΪWjf4]I-YU�appee' 5׵"Yϣ#{m Vk9=)�z},%œ~J([)8`z@7 2�x,C9c{ճ~xYS8 ]:(՗zo"S�'shekl|\Ͼژѷ.ڃ)�5nϼهoJSI|'S;/ 4XٛS+u^vzklg��ZKKbIֿ@su;3"w; Uzk6z[LLMyّf>)vM5 7�@k*BIpm0/y3g; +w@0+umլf8@jL|ةFwvtV]̇IKDPPC \΁{L⳸j;j"N>YރlܳTrxf^b_L="ǵ%1c��Zk[pU"5?y/T *ʎ-?/&w;u�В%[>ڳA*T{KCz9Z'?/ƕݽ7ow0zs ;ퟬIHa;�5<beߜK3*+|PmK䌉޾Ŕ/{QmbҞ B>iAOoc��ZKPL4-syUeMn}!i&ٺuoAZ#r7{~ɬ;q>˳I6?��gi3sQW?OtDTǍ-#}319}44C}}SV=vk?6``� Jژ}ÚMytM=\k-i}+̈HԱcoJ3 ] 1ؽv`Sɞs&�u47G`TF<.syk߄޿~ ϣsgmwwGt^ �@?9RJ+ٳFNs/[!!?\jbr{Z&zI݆ 5';v.߿߱?��$r‡T&pLd?g<`_3k +E\rP”�93cVc&5=>$�<2/TJm lê%/t⊾?\oA|5A:HK?}P,/-y ��);u|l1iG} b?��,x0iOPW4Q{ ;#pO?^K_w f +�^J5W\Vaヽ?)�@[ʆ@~1Mq6|q"5-??΍]l@ow f +�t.ߛ6LoT_ka}H,FLa��ڪgDI[JwjgUoA!+vb?��mYPLݮb'*)%S|mt;g3�0nsC%rDM:,Wû]rf3�0U[]V(-_F>/_zb?��f<g4+~ǵrE {&Д[.hh7 f +�`VO$V+wZp>9e~]b{e1S�� lwOz޻XC}]|}zxńxa1S�Rbey_G;wUqS=wy~La��ړK'K]{|i橓h߾9`!Qmtb?��MPL4%cq ]5VaVբeͲ?��Wŏ;x#o.+6JnA�zf@hN㩻.e3�PS0iv_T՚㓇䇋0˅n[}?��࿞Z{imq2m<^S; +0M%)��WNJS,[W4Y|O9]׶e+A��M{8n5rEP5*G;}ڛctb?��0)RےfTMYagWm)ltb?��bB;`j)rwUqS-+ھS i%F f +�0FJqfgz>~+ڶcŖKks)��~to7r{,ڦOW))��~Ns^b <8j4EU9 ?\|ErX^{(sѭ?��(BJ+MS ivTerFэ?��IS[gW8&}Im 3-1S��?]$%۶l +O.-|Vn,,jtWb?��Lr7jv<=\k,)��ZFPL4=;:jo~;2A|߅o..oonA��-WXiUQv-.r}G7?ѝCS sRitCb?��hZ+ʼnyi/IJDH=lƮ'nA��sp)~ߖ)_AQ\y96c5[)55DVV-F9EHTK@DDfzND!0 +jQ]^kH`]S2M~B5n E)dA@?���ߜU5eW/p "x7S!���p糼/~Vt +Y(g0x_OF{N?P|*���n ub :i?cp[cO��`~͢D[$}Ѻ�cXߦ[=\3=(>�� rv&>ag-~Oa`?1΂aΩ,=(>��JaK"}N%y+{426ۖd'Z{?P|*���:+̚--I +O{f?ۑ>l~�ŧB���0o!˨lyS>wu 'Im4 T���CXw*W-, ڒKp?yd=gD5(>��a<Bc fh<i0aFŧB���z&|Ѥk;^wO[<>ltF@?���h%d/Ԝ}O }Edl3O��0:R9uN!B7{k0>سeZc +��ڳJSŐ}Zxt+k0>"7(sGA.WTDn26��_eUiarl1 +;Sk2"ϣeZb(TLjܜݓ38���~LqidGgXكZ:^~>.]ZO9VQrF9s66gKYMm���͏kDd~¹Ϲ᥿]H.feS2fg)g31KC���7%Oaܤ +e~#} $R5D@cyzY䤅N@{y[3Q۬z��0<8R :I!|ᮭ)[]ԛZ;Vށ9|v46��`xqNe)Hm}]n}Jij͐?PQV}ҵGIr֭<dΟ:��cDWͭge^m'tnn7kBSZ :}֔ +c$-#Gr-yqAtLr?���_G2$ *_KyO>|S[x)WUgj?P]GvlhF=sZVupKk}ݚz3HOe3.u���oCNFrU2?m7ڲo2U]ׂ_{2ҧ!̭ ֊+`GǬ)S{י?|'s���']e)ΰֿ? Jэ4eY!}J+ꫥ_ٽr\-7?Z2nKZ(I a+Eh%\C_Sb&M.UoԱ{5rd}:p &\Td.A ֡9~gd3jU2FvY֧ySvX&0>,O)C)itgn6eG0C0��~cQX#VCޙ0t:LRZ9ֶn$GJ+O +kc{7X#Te߷߮hyjQķm ]#@[ɜfew", (;}kZ.'s2F&앿WB2YKyI`7W2OJTȽ!rT+,r~A!��.w'LUߑ}>`x:4)$ wZ뢏)yqAt}JWB=F3XcXK7 Z ǟu%^?#-y{v"TEYyfEQ ,0z<_+5&킗RGvYyd5Ya6"m^96/0!EiTOcGNl'r��_&G�+SVj=1т랝O*wŧ%YNb҃;~,0ǂ\ggY;]gqc ^uFbu:Vvc3R 6e !G_]@>=g}:]k]r1eZIMVwIlIhMf +��Š`+n4[[cynj0Se{IXOa$bL'?!l59bIcwhO眲ò|rjJ_*t?ϿLrEZj<cVlCs괺6u+`QzDXşP-1A$6!~$$7 BrQ!ʄN]bQ{?zκ?lvl5jɍy}y'z9VHiS@sܦIl,W]ϓm )I yqU aHzH :xınsc  F@bBNE[n=9S%9E[E|GMH Asu%cЁnX+|32ʧe-j|,qsLNk,JY-Tr+59,sC-m :5yS;!6Aqpߔ4~aj? TXe8?0)<$.@5Ő/8mCTPϘڝϠw\*^98ޕZ}븯8t@X* )zOjG qkCXou}zf� .)Nw{OQ@#7'7#3wZآfgV_7kĮA5%)*JI:{ɀ2Ul]\,7kv<6"-ƲAL,#d2Ӵƿ~Bk' wg?YALc5?Ι"m뚯nhw>\Yu^`x1]n$q'0w<M'e+7(v~YuS{M^^r1qXHzT ~/! Oou)7;նZtp+?Ay8`Jk3k fqsf5;-yV׺N__@}| ~@"Vs#'*7t`1 lJ`}r w +�-NY_[h4o?T7ǎCiR?>\!?gLcL:scU?+&:ǂVi-u9C#8،h~kl\hr}3H*'X/\% +ԟ 6Ls43 |{4$Td)-"Acj*M}V?TL\{"Ƿ'7GġcAJTUɂw/yo?^ChkUm烶<z&5U} 69qY&V}[m+pxs8L,#AO,}O 7aC-Xj#~91[ޑ{AdUQ!n[^Mo^{gGLEx^p�R aN}U? +1G3f c2qC"Bn$rX^:ONka[Jc6;18\C!|%cAAƆ1\/  ¸'eE[n+ =}GT�>p@AdlQa׫@s||L  H_`xS@ACMYj6U α|CMAAw2I*"rs6]<7L * o + AxAO=c::c6ξ@o`xS@AD(aκWOR(kwݱa(ὁ;y=4دeyÛ  BI@m1\`C }9c o`xSxx1y8|s )mA +AY G%4ǝYkG%h1RBA "KS-ozQșY?ҚJIyW;WNk6;#[;e*>]hiIҷ"cgEA<#tSS4{G}I^aTٍ@ Y?w M^^|qIGƑà gXX:>J3|{.^g7' }/vQۿ^??{0X5oFA|šDzc4y{ +~ +ۻ34>DQHiSHy~w}AF~ps'<?j ++vumssTPf>9XCh)%N\y pǜczfQdoPtPkm4yi?|SdpGWO-eCx/fkpiZ>P_0a:^,<a-##C]]]_spk6'A6Ij[5~]+H7-e띃9[M&"&[{ g29e9gSob3j>Gh|A ߑ7'Ы_MW�_)Ɓ$@:4h mq P%6m| d;>0>/!˧$밴+ɻJq\c z8p%'63S,Y/r,Z +߇}?W}?XTs SW6׭+:1n0iqcN$j@nya$Ue{'Cה<\Y +JиWse-whyЗ�9iO*BwB~col&vkJ^{]~EE^-7ͷ 1.c0r K]7]ж;Շ:K2sM 7nfVZZ +Cb0yan. +12ע\sM Ea)%e6 sE 7ZtC3{?/des} ΍Lh1-)UNb.KҳS7Tg@-g}d5%袭7g^C}XC_ncGf +unKg׼OˈV?S5҂޽NҶ;?yϊ眃ύ[S<zxC٦sn >ӒW) eufR&}APsf`@@{ +a>,s7C*soQyUrV4Nr)LKv;Vԃyu#15%I�YutCa=I_ᐹ6ύ+^S!]po%yc 堮HCA^ʊ!}Y'$w uП`SLU&C~WK 9 +T[nvn:x^zX8.t诣*S^sk2 kǁ<RG:ZRup[<8 _qzxw! S.j"y?d8Q׉GM_^Q_'`Mp9zq$_u;t}RA.;y}n_=jg9#F0EǴp<JY_]4Q8ʄ}/0 +†2F%pb{n>Jk2NԤ#J^Il˜C-ct֛hjus}X> k?8<8DM!hk?\6annFw26\$mZ&d +Ay<!7k>3at'9F0E@CW"̅enƹ:xGM})8pb�6c"{S3;a8W5mD|XCmй-u;t +! 7Mjt[ڭ>u*]zkOͬ?BD(e42qywbXsikެYyTV?>yz{^o'I|Gxɮ'` -p-?/#.?E>0rJy/O�_u3v3ԟ9k #E_X 35i}:Z/c 6KbTϙ?0)?vΆ~tI^|L쩓)%9.BXH +}m2Yi]rPW.K/�t<TVv NBkQXn-q>)}am:5ګVWݴu?;tc5 Ma|zp^[n 0/#(7>rcIR;˝M甬џ`SDHf +~<{&8foRv`vS8hq/$P zt{orf)z.Cw17yqP !^ZkmbxlEy(5K0;5r8_ 9D8kԱ=G1\_jviծO[?aTjZRy\Q H"Or)oKYE{\}nHr엢/_ >0ggHen$*=-u- HA*֡>7}16INÕJ?0)?fE.uƼ㱟C\Fh74ʹu  WrζJ}ιtNRF#n`@`fj޼}.s5! v<'koK5|zE68 u5\VzA?fErRs> Ia?`SLd@Ay8~RЭ>ewoG/<yj?5`S  2 I'5 hFmhӖG'P.ʟ?0)?AA2_([37:4]zm-3DSF0  H)R`qS˯Δjظ}m8P̟z?0)?AA{PSW -b}`(JP+-UT +UFy D�I"tfn]ViK+Lٙ9a`B|?3I9qf~zdF핑*v_ åә?U-Y B!&+:/}QxҚK,YB!u>I\=1K-Fٲĩ&i,k,K @!Z-KNԲNSޖ\p !ɹ,%={'?3Ǯ|/KBu=l.Q1C}*$G-yccǥ\wKB]z,[N~ꋛmR?Ǔ<]ˊlgKBw[U sKHW%WTUksaGK΍Byd#9qic'[|h,gy??ۋT(EyJfP{ߍF 6D[ +{TsJ5? B5E{I-I3 Ǐ�':V`?`䶴&!\GcSZg/ѣ 7殁!B8:$N-_žW) c<i%,L\ZU?1&6]Jcd&&11a&a?w�Qc:C\KJXQrJ1@%{R'޴a9?-0?\Hw|q>Gz`CYi"؏U_ j Qg۫оwwQl(sI[͍ŝZS{*[y}k1D!jlj!wִOC�\E +$ՕqV:`q߉i.vK[u1LsVz6W)fOC�SA[D;\\֤d[Aԙd~ LzߌZȲ>FǛHaќ2NJLC;t6䮪"[u1|iFz=�L1s6Iۙ`NNFǛB]Ij4nn,֚Z~B!ooZnΤ_WxW 6~Vfs<<t$RD,_!B0iF5ڷ`- +#Mװ҇.$=&v] ������fey=rFYbgt:~ O u~#~yn7ݦFK������0h:b,p߈@!Q4=qS+][,����������������������8#G* |5azKeLX@@gD)RLph>]U2^(4K$?ԕnH2$Օq.Zl/j<3_iTW֡EBh{TѾ1(6p."PH-MeаG5O|fBhM'p$4`k^TUlWUIͣv{>`3o=wWѧh﷉9oܑw&X1.$xvzؕ;9~hIV=W뵙6]ۋLL۷_jj8Ims ZOk4e~Dۓu[?ztAF^_sV O폋'j? tDAj~L;4rm`jy<2w+u(ԟ- Ҿ-a<b51-o[/oҏFswDFb>Gt0<a]Wc4jk=n][b{ gvurzm8#c\aep&{.:+INk~5WɗmԘ;D &{j0o4w|c<U2 e_1LPc`_SwDj894>+#ql,0M^o z|SBV #QcnH 5Y۟@GPcnqFkݙ!o?"Z'n5:NX)nR$^>FQFA=.nW4]{vb]`z0?)wSYK'$Rw:К'ZWkԘΞYK8&RR]⢛CCn'uۆ#1&z$Rdt,'4tz%|u iT(ahRt{B>%32>1'jR }xk8b]`z0?э'n5:\N|tsv:c/Uʟ[Pcnl˗W/W'̝婛C^I~ʁW2!FǷ^(H wM#Mۨ1'튆Ktߵ{xe,�7H Ke+fJs-ʭ[Eu֨.8+(x۴Z\]f[tS4o|>۳}ME\\LeyYA8ӢRZpsӑ-MÇ;=/Sk'/쭫 +r?T`lsBO3~B* c_]h*?5\1I|˦eb49]+6=aq Mίxl_fѶ.JWvVV䳆m!_Gor?-](j) ^aNj&"{wԮ=شsWΎL7>s?voyk_) TY^VL9f@|c⿅waO27Eq1ۆ>|=m[7ti"|eEvm'&kyp6O36y/}ی;'33SV>:;++./|Z4I?ּzr~q]#?k9f uK8^{swPq퟾ظpl^ĹSIS.\rb?V;^qߕc.:hPd_Ӭm.,2occ}ᖦǧǾq G3ƕ_cnM7~dw1ICUeae{p TxQ%K$! a L6Ѷ57|艌KJ궥E-gX9&5aENrwm˖#M m)+~*sOn)߿܄ѷD/}qikJK}YS'gM+JJ.Y0~[)#Oc7*GⱯ{wGmw:,.ᖦPizu$εho=kIa䜍P0i"-$寏튟L߇i{q#kk*꟏ƛgd BEOd$j}|<ľc���������������������������������������������������������������������������������������������������������������������������?)�O endstream endobj 278 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35469/Name/X/SMask 287 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeGS4-5-$ SMrЋAK(+Q*ifQfzSSܻ RC?TwthvT=s\(����������������������������������������������������������������������������������������������������������������������������������������������������������������WٴQS]m塶lo|f鲢��2ny'{v~Oݷxg<~rҽ��9|xUkw% ��<Ԓݿ6,��Peo[t[\ܟ$Eno彍/e2I��=G[Ui2/QaFCl=��p|e.k{+{?+S&]Tk��@`:q}i o(_pѐ7zt|u3KiӕRJ)T*}- -Z?xwe?.).9%Ǻe^<˹TJ)Rxo\'<yQygE]74iUձê{PXgsZAZ̜ziwz?W&7♎9Iؚj+>w\Nkծ6汆k*,d0k/\8|>w\B0$WVeLJ:Z=?ٺe{<gsDž=Be A2υcił[,sDž=ӹg!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}% +��}?I<~Lҽ��_!]t/��AHz9).J��E $=|Uf$��'?I<ڲp{ϣFH%��z?I<Q~m+@��RD $yo} �P6K c΍2[�wVw�� }B"��AH�t?�n!?��M $�@$_?��HAH另l}Cm� `ɗ?͹'��ȷ`sy74Vp[��M $''oh pg��Bry.dۚ~n �H ,2[֬H{#G`g��Br*<QWG/>l �H ,:z[w�``<�3K�nvזּ +� Br'yj7}1Q*>B1ny99999jA(44l{l}C~/01~\3.v<1XESAPi��첯 �n5Bb�;FH3�@y�H7ŦUfxg1��f_c04n|t/4J`$RV5X Tu#=mR8ZJ3GMM(9Hs4&y'7M(bPQ!6(i8~0?!ĉ%}?<oF\?���kH's|5gw7U?���kw<Dյgf)��@b~ `/6���5ij͓/W���5+9z|+D^?���kW#%ϝw;ے��ظ_C<ʜ]jws7O,%|fVZ՗w9uG>=w>畹C5 ��y_:vx꒥FGܭ(<EC|$b7���FWOsěʺ9.+ՕJG>n7��0ʢ…ES]H&r���bS}~44D{?ƙ>��� [d1?>zgc=���x���a3"A]K���<LVm? H;}]���kE?J[lS��!Zlu? H+~kI7��6,"W[<?kEo��ΆGnvW{uA&���<rbhk܀ ���|i<O@C#dx3D��UWY 폗d<.1ѻ���p_s_? _+]T/z���y? ضޭD��}|bxn ]���/F@csyO= ��� >{/[ ���I@#u +GWTkV���],q^J6���;@@#Gfy3�� d1Rg-ZV\���LWnHM׊w*z��مY;V(=گU[v��`v{{d1R5%���θW? hQZԵ[��O&M? h,'��iH%Z,.|']��2JHپ\}=7��E?S¯y.��`V+.? 〧ruPEo��0u+Wh3��9g 6;?[N���3MdHپ\ֽw��Ѿ-)d2ZLl���ft㏧X]zP)z'��ݓA@&c[U/{:[T���ө,*\H@&cS(;WV���9vy2?R/W:ך뎉 +��`6d0NEVV���i(@@&wkA]-z+��x-g$Pwq͊_>+z.��jI,wM3E��02?zT^���3i۪$(o9wGw_��L: dk^ m{��˩{dk+O7/ ��`]GW"ug=-z3��Yt~]I@qZk۪Do��0 F ,]X?{6w>G٩?des鏓?_W'+��^mK;Y^ޯ/9Th[o'9ͯy.~ 6Zޫkw&��֡~M ޼g]9'C €hO9;͸>���PGcz@h,SG7ZJOw���0aH~jqZߴY';���U@WtH]ۺͤh׌?J[l{u΁-K��� /NW3xp|%\_[2uO'^݋zL}7z<w]N��@ +vg#x6cTwy]Ӧzx#']֭9I+G&+6_=0>_<(á 05IuƌI 8F<H + PD<*"( ,>ϳ<, , .ZS G'63!u2>5Oy?p~om礩6:5,���`1,Xvv@.ӫUgLqy7Lu.Iw8x8L lݬ˽2дmյx;ƈ2ЉsM [���LT�{RO_C%ecCq2iTpsHofՔGf망E'لǿ+T8| E.hNjrhZS+n?f +1;vI���`$3p8X"eto['O1/2S.'s|n6_p{ϭcU:υ���X.[k{ZBqn4,͙C.gNߴҗz|cEtkO_'Qͱf̟& ���`&88 8>XMveP3 };YvćZ}˹Q+jШۼΝ���m{qMVR,;6<1rl@^9ʳN!����^9r!̯ q _Fp|u%.'yӯ$Q3nj-����^yӢt?%y Sҍwqra+���x%:xOS| á?8xPᅉUnF?-ɳ钯]vz����/i*byF$%/fTxNZYo軇ekm-J���^Z;ϾdOp2vAnJyg껴?55lGEk���xa{7"݊D7pz7Ŧݵnq?6ɉu z���ۑq^�b1<sK=:.$轜 4BZk-���G\x#坘�CNm +[ͱ?l_=дŇ[ij���gr: rٚs]X<SN^rϐ|֨a'j?j+���x*1G;ͦ옩 yV +苦w!&fZNZWzA���<QnB"rO vAX?Ȍ۱ګL^\ͱFi_у}}Sߚ$���Tc= b!0h?* s=/e59-[X[ } ����C& VH2vAn!<}/ oXaynG��� lfZh9OD0S:#ky>~d]0~B ��� ^uXU~�1iaE'Kz^:^qӨV^���JH2c?Bqj[V 4!(eDtqx���`ezHK%hsc=T5l{Nmm>&���ʊ +RbЗ M_j8./M��\8]ZT�1Ar&\LPI19)"Hq:͉B���癢4]a>g� BIvsCVS.ACڷqh+���DU6K c rMt7i_9 ~;K���ӫU=;�1A<yÖRmdOuŊ[K] ~4zB#���PW�1A<x*tZ;QO㔷 ꢋ>˅>J���JNu=C?mƆxP 83 wr]S'; }��� V:s |3+T6/I{bTA;:qG ���\%GͦC?^lV?^[bخbv-ǴU:x��`HU* gb'Eo05HW1k~bq>f���L˛c +4dFrScoFg ���K5/LtG?^Se1sm#v4 igdgy3f +}���<(+xp{* XB" 4Y<@QE9Č\Kp2 C0=3͡(5TmjâDgotWj'X]"\� fbJ` +^.3'G2sXG3cc]o=���p0\8 f*9X;YgYiEFO]o?���p,CN+OYH{Y�v^d7i����8fm[Q['؍TFٯ*~Rfm%ƅ���)Vhsb'>AnLB\)U +]:4tq^\&lt=���3 gC7ڻ:"ڠmLg-kN$)3u=���CNshA�}۸/RUdz[k{v(XY?lz>���@7qnC1 YB'<hf^^ ʎUd_f9L���m-;l;q8Cf~\R3aӜjIFN552���]#w@>;U`*QW2cW|޳5ۘʇRQKzd���@ l5$w('̄=KKw-yWtV[���Р#cɹ?F+μ#"G7.v=5[]!���ЀE�R[,#>cӂV:Qi9N#���xbFz:.2UL^L( Wx|X]���#qǝo +vUȾ_LV 6z^n׃z���Nt#gY+gQH9 !+|Jϋd/s;z���-&fi9?@ߙJR'{Y]vq6&1���ęg6702C>J;eե) ]޸C?yzX2+R|[YM5K4���HrBp05[}Ig_^\xRܻxkנO,g<{"j0+_?[[Xjq��m05rp󌙤G D2y'=u?/ P9r mO[_U_c^dc>��_8I~pUjt=H{͌Xhx[[XC?cJm?6VNVE;Z[^R@*���pRXO+.*i^P< +煤_Cc#Nw=nWTO*O I9qig���~9rhF�RDU9I珶Ȋ!VV= _J6zMe*y��/R+JJ:;3p{Iɘ0w*\|2G/=_t dfcA��`Ε?T2QU~`{G;mLJ1TjuiʒOVmb[dҞ@ ���oT/we+C�e #߯p^8?|G]T^PI7u}WF4u?>wN#mz.r��潖ت>{ +&{pMjtzN{͌>.,\={?}~,b+3}Գ*1qבSd&iI&}d��I&43Id!OՊE*EIa֡ $.' +*2 Z2V\.Q;M<v���5oEe´DGڅI ϮNs_y%Ԏ8:H^v1uryjq��>l2N|UnrF�WRqWL򠺴8cנ #c5 +\+Dw6_yĥV̵4���{cQir6>A@^p +}e~L(żS!*o߶݈7��h9kLƎ-,)'Shl"͝ڰ҃ںƛ廞'gU aay'qǝO;$ug$A/p=岅b%ewTڤRQv$`(Bk-"И13 +Ÿ &3rʊTN4w;>{v:G9w^f@%1'[CKd֕ e% ԋrRuSAqI2nrnw8 Z/I/àsB62'iM3>|7C %\ ޵8 7ofRT~t0`jj0_S 2Ű[cشTv[6{):rD5_3)$X7=온Ąx R9RB=} ;Jq^j{zq#Aimq?2Jf&UrWpu&_5pSYC͉%ZRDŽaO]w/zM +=l&k&WM4/o5zٹx~67l^?{䒙HjLS猕U(?}8L5V.Nab$l(@vGxYIp%RW;җ)>iI g6hO)c0̌AANT$&k뀑>,_lk3+l`{n> _#<+G~P=HhSI''(IO[{RSO-5ы\E .qofR,ʝUvqs./ۢ ch~Emn[momN7u[uF<gfGޟ-ӛ Jp4@{�?P p��b@mxߌa?03 ?Q ؟U]I%!QgpHjU~%Atv`0g,EEPWQ-`Ӂź fGoݺeKrؾn,^+k8h a{ItCrG=O|RHnjxBYQŬA]_tvkqjez.xsRJ "zS9SAvqC{c{[ˤ{ !A�'Lƛ~2c[٠;^v +@ +r;%}�%{fF.{ [`?03 ?չIa҇x,jڍ"#NEԑ#} �j95.ЃK +6Aλ~#2.'{B .4dj온 g/&'nf\y~kyu%IӋ\aR:ĭޅZ(S{Q3*gQ*Uagq4P?nN*{Odj;8yz#$Xtl꺿T~nRa#yum6WW,4^V?gX1PnPO/sF4@ i7`q`9KۿnDы &3nu-*B3KD%Z7d$ DI^kjņeZke Nd#U/:-T;zդ3B2^܈v�A=,heG}H~q-6Tx{X#g󘋤nVkKZzkhlaU{VByjZad@O +܎WQ2p=@&m���j=\r8 �{CtE3Bo.DeU YIz64WRdrpt:3PSE`mpJ)ijhjRNlcP9 z +p& m;#:&6Nk g&ʃ e{fí8y<C4'�o9,K(nQ3)\l PtKhw$HT.}>y C]EL rU\h)bxO wD mQGTΉf7u[uvZ;AڂVb?kܤ%;Rx`fx`??(Ӫh~-"0(�2OZΒѭՖ  r}̴#+#zsa*S𰳗mzjähf# QG;Azk'ƊiA:N?a؏+asf&S~iTSw_)Z֢#BǥZZh݊@YAD" +$䒛&xlm +z:x&89tz 9 BhCNUEfi3^URsg)r&3s33�AwN3fBjClɉ^L\B4_r Hv汑P ۅE>ypM Bv+K`@WCRa R_,K qV}9-+j{cn] 3u.lu ~Id*#򅂦:[+zBjܦݣ쌛/НEсᥝ҄@cS1 \ڟH +]ڐ|-詘o*ʸ@0?9򫌶 NaV +OQrMrFSQFSOގ gkI5(|[g }?סU"R`jiޭΜ?&wfoNJ,*hƆlcmѨS#䒼f]PJ-?E')=s?0{(:mKGf̼o=?'{6d啓R&rhP7x+hya֣-F*6Y#]3r35Ǯ[UGJ5y9Z^;`,w +ֈ̞Y;p |3&ŷ9Y.?{4٤Oj +Z?1~S2k^El)HӢw ۩;C^m(@JE%hjvwb@-'~٩(RuͱF8E�O1Yu4'#wAFF~6A^+;Ox"Z޼)@큢mO|+2 wLkbȐ"QCS]{,vWzBw$r|xl2�5,Y +I;& +ҏi9j*lˣEWBweM 3kLg]?Ёo[s/bȍ(}C/gxRN)hKx'3?bh7n<l6NؿQh3g* t~`?ϱl(ڕ!3ldp @h/H)gZ\S,t+5j, )dW10n-ô?\H$UkwU/Ԛ8 +ٿ!PE_Euk~%0Mc߹9["]chS__9 p1*hB=zpZbŐ?�cCCX`? b-eD|-Ly#V3(|\4s[1 \:Py 䧭g4Zw-} �̲ uf2S8;:͆4fưs!><̺8D\B9E)ɘd3 qeF@Q5~UEt;%0| s !wD%k_nvtdY26xD07g퐟ajdm}{uo*8nG+�]ؿ PE_OT[i .p `odQIchΓv P7]XM o%T[ց MaXx4c& ~0xt9t q] 6d9(a1=?7H(Ȍ#5Pt6%� +^?TIQ~O}V4zm'A9}X"NӬn'lTyEQT#UtPtI0 \:u;6eGD=~\vhÃ>Mf$kIQ'[3،_~&'zK挒λާ + $P;QEŞ +E?E] +6i_eƗm�x\MCA% ř'Wyݞ + yg]%]Ne5-nѲa+�9;EQt0x~_,TvK`@c;^,H8(_m V�LǍa!guiэ}ӦݦI6 k3Pj#ߠ<Sz_7;;EQt0ڮH,</:rA?XwrMTHw >.>O)sl<Ɛg3z˂ebH=rȻT󧚜rfo(voV%1na@KZ.�RJֱkg�\a5wmskW.Xlka @WQFN9Muwۮ8X'wKr(\?yPgeF]5xEMlh<vA n\< <8UD@D``dDzϬWyuM%k;-ۄy4TW{Nŗ֦~@R<*a'C_R%y\*Ό>Cq΀O ]EE-,ȂϜHžZ^EŝޫkGJN ��bw)Gv12Dkb]@6FLgjFU=<Źuz!ϋ\t9GVΝV>kgZc3j0nufb^M?*6d~ި+H] �ЙkO\ J +; S?@>z!J>'/Vlo~HKH/!?MhO2=C?X0P#ڼ?h0,aOujw2{+}6[*�3+ɔc.@ ,<C[{k3kFyraE +Bj$u*d*lNh"mb?z 1[uF?O<={qWՊovRFmMak!$M�Ej1DLΤt@qcP(=زC1[=ȋ+/dĝ3V%Gݸ9ӑHw+V;ClHlON%&k]IbӼi6W"��^Fqw7/DL.ؽ˱W1۶GR )B9]_bwETdȽQɔ{MJ{.חv,7Ցjb$˫wvB'D1#>#d^;:]sg t�@˰ uk:v>[{61dFuk^rj!%܏gM}YOJcK3SbO!CUqك?+ߺbeKή}D ��˨g) 41~9(Β߼6D7!gt7&��hFU=*DL�h0%MC4K�� +[1(DL�Y)7=!շ?9 ��a M;'DL�x՘6UƝ+e["��<Y{<?1,<h3bܸ6MN��q㺆)�ofDvqK礶PgHUn��.o])�-35lMliFjO��@|ήkoArVd}R=Vztg +��ģԯaDo"`�zmK3vrg437+��K;ޖ|` b +ocMU mb>b{ ��:/fNR 7t$[10t^CUBw��t\Uq6flJ.|` '=)n2=O2_^o|u۹fSt#/G� МIA+@L1ڔçila.6m꟯nъ }zs�eG4MWH]2��8˲~57 b=敯Mcm=>>4@9 85B΃̈́3��:f5 +ґr&CyU?�δ})9J;cJiJ{ ��Lۿgz]߿5 Qb)mea2Lg{QUcM]g ��LݬSc` %^^UÔ6ʝ줫Wv q��`z˖s]]!H{Dҵk4۱e?{?�ڗk_d<T:��0fv݁um0 4G ~P^զ$ZJ$o|@5+2nzFU]B��Tz.gꦽuݓqq3k n~>}i2M~$(s#ND4,>4�1ٱ4;w +��@XK 靌a o]ɣCl~,?sw1Îj۬FUSaU��aUnۡP7vwO@L-$+xT[i;eR<gݾL�Ӆ],jӎ@L1C1KZYhHSӚ}8K%Tk<O·%g)|�@yR*vbɥ Kw?�LԁxϨkTufHq�=* ӳEM{/՝q5HkiۚlZ55ZڢKU.VZ)"RDP:2 TVEtpD ĴuӚUrn +g|n^y~G?�5"nVZFݻyE�@jKuY˽fe*4tG Y#�g4vwAd + NT3zKےDH�@;ǡeE7Ad +,%.vmKmZŁ%o%�bWcZi6g�π݉/k4Io&�u\"S@d-'ZΞO(n�NL3} 2)? +:k爿�Ss.QY"S|OzFsP9Wo(� fx)@./y_Iwf}GV�F5%Ad +OPXeΎ!_3uxb"lT�R{Ad +אejfh7^[X^zL]�4CS/,N"S'-綖zk]r +�qc˖1= 2!ʒɼm c +� Mm*8ʻD?+V68sUxo-� }Inpf�zS/q= sLW|wg?La� ⴉ՚Z9Z �6NxƻD?�Z;W^Vov�U.?Bi)�JXv3tYCSn +L7?fl[wG?La�64z$C+iխ[}h?nf)�?fB~Eejڤ'.No]6ySdNf�GS" 6\9.zW +�  )y1{ya;Ҽ$+J N\W�ٵcǻD?�\Ӗ?04<q:@&i#Qkv_)�㩥+7;7H[/� .7K?La�xׅrﱛq@FM2w�ɿ6{St.>Vkݰr~Զ[%Z�nNaˆFOҷ"S�/cT 7sK;~G @Q٥&tY)�eҦJِ\T�# 0e"B+xxeYF-|vꋅt�F_ 2'9q>/DTifNe�Гfe*+7W_8*\R)�=m҉J=CSﴑDx�G= N)e�𨼖8ONYfvN҈\kH\Fd�( QN|~XmO|{xVf;۝"S�D3EIwǘsrB w�DkMuU 2@)? + =~!1[#(FzNwӷ+D?�Dx%Ʋ%䀦^6tYo��lef]fз'D?�ǿ +3N:oJo�xNgM/-G)�$(|=v[+1Q�(xܹ'6v#�4d$%A͜OD �;lpv"�6}rZRݕĿ�,Msv!�,M^95Vܐi �ju% @܊=7CNWg6 +�@wR}V ?)�f`G]?x>I3�@w0t[s-co?La�D&(+iWkjkhbӢ �uGm|;Ad +@ {%aUkة�5˖߮c�*Z3tnԶǢŠ�evҢM9 $'?mmO߱?�bhdeftv_nؚ?�$/yo?gԋCS/Wu|�LHYܯm2j ſ)�^,3쏫 w'>kq$Jlt7 +D䧌͆/}q/xM:ckڌmTwH:QAD%"^j"+g]qWDEQk$D&Ltⵯ['19|ϋeV_<W  /�X]?McO!^EƏzWb�h RJr;W]w �Pg{晦A<5]||f}ڈE]�p ھlӟv憛'l5�a#4}o 1}3�gO Nts�<Pڽ?.~?HkɃ 0PrM �0,[^}*2�8N655ʧb~5>ew(1ee,,ڙ��u"J;;kwk�گK=wɋ:4Y]z=8QtFWfNy?iIĒ|V#̰7$/as�%*mdG(wL?/@t-or5i'SzxRz~' ă5<`e/�(/eqẙ׏&"�ڗaN6bf7JiI׫4ir3é5p$iг~�n]Lu)#*dSjr4T(�h>t_$jvdo�nh|V3׉%�_ܝ} m%q@>۾��uou/)՟q[ '�v匟)h)�fCFk; *�ЦGR:Y(fA�|1I^;v)֙^X"�Ж;潤ܘ. R�h:/'-I>x)?5@srQu[h)�~N6˻bYURF@w岩N?�3-5Go7sȖG7甆/�ڮ[5V h)�x|ݖL5B6_qZMW6Xt6<jPְ?�kfI饺==euf.mRi Z +�Nc?^l<뺫 O6i� 7h3VR�d~QZg1u[+e'5�<_CUupP?�1~|ޮkD7�<וCR�rD"r6=_.>9(ݭ s�xwTf n h)�hyWΐ7{{8s]w�wnh)�h=/t6ٌ5k;�pҞs:4/Ev?�tpۤ +|)'�XjwA�uJ9 ~oV�q6[sbh)�SXinھ?t{A�Z -jA�7fh +sȖCkޢujx95 Z +�<Ǥ-r ]nJY hv1#X6?��%reXluXMWoU ߍ�VSj)jwA�x!qRJqnr>8~Wc NP?�m}f< 7O&lߓ�<yN\KvDKa�tZ}k;_rȼ-n�h)�h;F&ye }|Ge2  9~DKa�@)raC6=dN~fGAjA�McJIE ~b]v?/ +) w ~jA�mɑCxX^1DZĽ?^x;g-�m_(] delv2@ +smOqR�LJHiy]?n= {v&ѽ?FwR{?�@{BWZKgfl +7{$GvT{?�@zEHk opmCVcg%ûX�RM3h)�жI^rk8Gyü1h)�о΋Iw9xlN̟?S|YnJUl7 Z +�ڏ+K]Q?\\pRF $}Oy]R�K*8dK㍣sJ/=xyNS}?�}d;utlⰚ|U1mWwWX� Z +/Uq�rѬ&5/[6:i eLV(H +(&^Cr89x"b(/^U=8Φar3C~pmBMEYtIZw14Tkw}[MS1S��_a|ʂN s7~Tܜ;*)]?��<egqZPj&2~ɥt]n?��<o9P[a3UWzwA�)>~´P+\Pd|OΩKKT}d3�hN︑*u<8Vhp1] 0|jC1S�\#U7^JJ 0'VdVJ?��Գ3]KF"];ݍm:T`ٝWwLa��~&)֝iqn_jXЖVl؛RwLa��~ _aքn%xަul|ڢm.OݽKԻob?��F�a5ԦVskvatښs{S+S;)�@k2#8w؏&Nӿ^Wwę!?-5@PZ ]fgl�h-#U*U*ݸw7v;i<TwY1vlڥԔsC<fO!!>z߰?��ϼ !0c(^;+\X)qU(+lLX�xRFmy&X)UVd|5Ҳ( ΘzW{y5ӳE߱?��O3l plrUzPs|.#qX3Rwf}(r9h|ܪs6�4djޜ 928r5&A2V?3@퍲fEtt2|1\!Iq=c��_m{Uŋ6Ek852ͦHs7wwiãEqǹ'L᧿GJM$}<=;�c!1[Vs/_OɦJq9ymԷO^ߔHiѩ#k1n lo?��F:ew^:X{ `2EmIwWIs ᣃZW7%3<]#S z?[WSRu7m�[ȷYI)5;2 49ξ=*k�NhN4qd]3B^#Džk?&{?¶/~7� E7dq7g !;Hhbv,w? Ζ1o11 uG҃yg<ݛ�p&>}Ngml{:~4~<Iy!ǔ8koSuۖ%!o2qVQ!�|:.} ux?v4#O5ޝ`gwvƄs+ +Ŗ�pV~}.Y{.lwEx?Ƨ,wLa��O0SK6UP>2qǨ)�@[3a,:ZRΆF5Y`;b?��m{kfzZlJ~+2aG׸ܡ$Ey{1S�cPa!\[Jwl}/q}{7wLa��ڪ !†;V;wI[nzgA�-BP<gS{q1y!wJW_ظ-M=b?��fyp!A2֦ +51W-}Ch]_|f3�0eSܷɵjo5}3@sY;@\?��O0mJ"rp{&ДGh]�3 f +�`VF ++8;55TigcPݳ f +�`vk}bDVux*|ż#|u0)�+xv~h"(W?it4gNr/)�+hbݙ}gKg|kW;"4wnLa��\wea=xL 65ݭ^Y*^l̲?��nbyk?w0j:kMsgA� [U_{o^gVTsgA��o +#+w@jltdMa~%9yG;b?��?yP:h֚tͤĚ#sErQѨj(Jp, >첻^X5#4=Xi% ,kهgwr┻- ]4OoU\i\?B��^..r'\xX +}ug: $y=�=ܴ +Yu7ֻ*#;jH z +��uOFr_+M:Xqj)%y[fA��]pD c+ڿc3I%9A��wxa]Ѯ9.t~Zhߎ،6ڲW)��1 {.filXOU䬅jF z +�&(biH|LԹdZk gѾxWڬ?B��yjETAO9rΜ^Nj'6c?��hStœ.Yj57m\ny٢=�@yxa9P+.y-|gV,+L6W?��hyC׽(;bE;MT0y=�@ .^~xe8>?8E}%K QyCfA��%/ Ż#BΞ~Z.iAfA��m͑FX<Ж1DZ?B��Go]l\i\vp@d`hC~WmnDO��*mU`#XwayG莕=A��y=ݟK3.{YuwbcʶjsB z +��m\8VX-dt+7]ދ6NF)��|fe9 mʽ\VZ@Ā[{ظ͑jA z +��5b0Ȗp:lq{2ZGΞ~6z|=�y|}9krG.1C]-!{o<?B��w@!V{T'N~gFxH :?��mݣ$,+.ղqޛ2w땯�)��ڇR >:~l3~B9'b&=)��ڏ´zﱊ5.Yj^a~C=?̵C!=O8s=�@{KBÛYM.zu0e5ZDO��~0SӴO뫒ߩ|7]׈L z +�-(| Ajzu0dwkxw9B꽝1)��& lٱʽ~n,1@ꮻDɖZogK !O=-J%g1//f�g��ˤ"M98T={E>3_2.Ys tYVhԔ7ߞձ՞��/=F +SVR}lzik^WqNxy?/&s}sROvs9+sGEb̓��_C ;]vË߹_]['#b Iܯg''M(L��} .wU<D4h{C&a> ht\6fOxn`DŽ~z g{~gbfxs��:>ㄵE\rQ!b}c޿;C<?&mM O߸&W �esrydw{xGUJ-tڼEY6)-uFؤW7A(ؖ2U ~��E"6 .-u]>c>ќ/MJw ΋AZ;Y45C~o=&"{dU;cytA��qrB-'AKΞy;yGrz߮%yiΉAZ;z<$)53,s$o67P)?|Ǽ?$7fd"��h}!)KI,5~^yGvfN*ݳPw2eO_.-|JЯ}̌T>��VR_ =-f-;({ZFC~YT;>rˋs~xMcL)cz/zEqɖe)cGG<M(ʜ*֔ʖK;#E=& Hw i{䬅VMm[(!֜6jO{U,Mtﾘ9Y zWkgПr jLxPYյ#ZT[gunqa +%@0 rKI@B̅$'!'Rto3kuv;ުݙݙ: JÁ<39>{2ϏCA.+SA uriNlW |&?0&cʼn̬ԃ3ȝəy?Clk& +gÚr;]]N#?<Ȭ@kt�i-4J#zjyC_ډ[H|^e8=PէL^S0>({YojZZlm_@ى-+{^94?? 2yk=nE7jqje\] ݕK [utO@1Yc<[wg>ճ6]AKL6ޜ(⢆2儏JL\+:0�^ad7ZÃojW<""WPM\ox#jӧAq^ӡ77'&0k[\:E|3/?j4s`w 2yKWMvgVyca�ךݟ8o7ߩv$`SL(245bW"*S`#=5+ 44{sFrkT)3N;ܲ8:ڻ~i4u`O&yb5=[̯ϿᓀrB@{!yQcG M^a #=,52,嶸+; A%@E\ ݩkw,I+7}?6W w~>U:EYuAFżzul.5SSnrS+eץRZRU�^@˃g_SoW?a?{`o0kvj>A۠\KybAP[V4y`_Q6]zjDq}W! E0?'q[x!n.{ ?9k?nEz?0)&�yzzL]ENIU{gSQFG'kO;b[W6.AV8\͉*{gK+=0{>'[u'ݻN|<^̜c )VZ{Ȯ84"= 'Z@?\_Uν>띣 cKMڴ&A/֟L#4J#`˜gSP2 xǠ+)캘&L{ڊ玷w[yGG}/Ƽ_$5|C<C㦗yOKS+e]Ǒ^9W8U) +GeLg~;q Aoʏr_7^O5@F`SL*'<LET;>MZm]YlXcWsAx]Z) [G<Auxה!-4u|K1]nv~CeJ�P`^{ٵF%A ɋwIZO%n}ßb2Gwd ߡb1Y1e&qjc;\nqj4U2XcSUjx{ueaWw6N&A-+m 93`_Q6]zjDq}'! F4!!>~c=?/~`SLI~"! ZsŤ*;gceJ�35+k}l׈'(mIJq?<[?-:2 <W)' aH^ԘŠFŠǬ b[W6w z- 9Acs'+'#U) +n`SL8SGCg[jҦ6 |~fǣl;M^ͅčzGO seEquY9E֎Zk,׼a΢Ϝ=>sYخ0+i/صysiOA˝TY.yOJ8`!Ad0WkW A_\rZ2ҟ([띢(Y1[ZiRQpnWZshx [NW$W)ӘuA9.Zi'nJ?}O1Êc֬%Uio̗0sxk +yImX{D]n3c'D5nz%qhDy�=300uΐ{ K{A$1"XiϽL\<{Z׻DO1Qm.˵{lx.o67q%jVv3u }]#=ubJ�y{+7nsW^y0"`~ҾW6 Am]G2h;?^I\suQFG`ο!gFDu;  �ipCv˃iRudJ/==H  ɚ}VN/{P7Xc֘:&DM�(SQ,jѡx + $'y㎃cOD*DZQF+jәtLlW{v9r~3޻씾OGjehOO  ȳ`,Z_5eE{/=#Hŵjť #<?  ϒiTEzM3GJR08m8`E=?  Rwp-kl:dO;oo?0)?A@Y)~6-:_%< `"`1 ßAA ʈJM$˗JC͗_tJO11u 2uOmzyIv6_zOJ|]tFVm:Y˶RA "r=_SAJ C=3{y{sAU\JYǶEL}Zz̓6_zOJ|]nrwczF$IoEW/^A`|"*XE[>Xc]aHԺPMH x&ːi/i1tKZ8sZ*A/^Ab^^,Uco@r ir7>( xk3'vӖȎ񪽿q ɚ;oA1`j:gQ\o7}q-һ۾5'oß9C'd'mcM'ڝf iXs=W +ۨXA4uȒ*w.q!Waƒ7}Ru!UXv6_w2R^ Tݬ5pNҕ΁wі0 qsg7r5&\R3_0a П ˕)k+Q KN(Lu!AmQ޲ٸ=? L 2a|l19-߄}K! 2*U}z}pfPٴrupUwTw/z[mvsVMЖiq*wln(o&컨d7}Wu]ְw&gQ/j~PXcQ[lkޟY0V|;?1Қ>\�~3#s55ԪP*"ZkZT1¹MQf :N>eE&h͂-cU? ov6S<_? *epCpoej9-h=iS}AP~F s" 6ֱN]>?]־YzxR۵czo  +_@Y5TG9PKOJo}\�u!WǚNTۛKK) nf~+l nAMH s]CuC]n'p Dײz_>5UȸJ[c 0OI#́@\ˋuE[=yϊ㜃 [?q${ep WQ}N% >Tt|ûӯ'N\f?pۛ A|*BV"_檏[qG|*ԪQ@=_$Pv+P4 cE r;"?/$k9(C.׼܍hߖ;?1\a<LN wagK>7蝦nZSi :>8?A]Q|w9c]8_8\rx-<f7{W  +_tÁa~qiLQڴb9m;i-w*wzYY(5pyP(\8;V䭋;pk)΃x5;Cm@ 'қoQo\?q7XIq¦a<j== s؛4o>Lc(Lի+nVm.x rat}'S-g5q3ß#PBACW ae#G4qDPP +8Phv k~ 1G7dXmYJ ~W;9 khAGmw㼘>vn}4?8<8DQ)?ñ`ᮯ?M2%VM&HmT_$[e׫NS |2!%4UEp߬;18ߟ _x&˛`S�AzVm0骍UNrRUq|Aj`� +jQ\Z\A>(h= zK{=-*-%-޶R۠emvs{^fK! 7ov4Sӓ&g _OVg[ ßiHWjN>~)urXCj9>>yv18;)cpo#Ys|\D#O?ͯ Q\;S<̽Kx [71ːp +HҕΑCAȂ8ΐ+݌y۾5+904{'  +_u5Yo=3em^Zk٩x]/EEk6.hP  $$9IUuj[+vf;6@H'gI} ߘR~OH꼠+B^[uYQd.4({KgU宨ר?FM=#7M}eU*Q9/[M%ud.8Ġ6V 'c,ב?QA~Uɇg푥NMNJf C,m}B,N^CU#sg:'Eq:sXz҅zgA�bb8揑QG^ZHAwrƴEKf|VOanWUsNi43Q̅d>ZZ$~l~uD_E%s?S*aYkyo:A35]G6wB>]C7'h +ֿ|pUud9=dgd}'gc O+Xܟ"3gJZ׾D~ wNQQd +cكxK_z'Ko}ڟ@L AQ9k2/<c37 ٝ)G7P$Smpе@!##(yzyҨc~j'64WeVS?5ZETvH;~FMF!s; E'tBCL2ܬ)dǵj:Y ?9"&hc;;+kBzϪT-dS/Μ?~w^TyB!sl**Q# 6gF_F:244 gB!KS\ +-7י"?L̓DK6 !:^Q{dSpFm5oh1OyA|C�bB!1먓h2]V} SB!]uCmM\e߮w}h(yB> �1!BhOd u";cL:k e0qlGD٩|jA�bB!жT^^Hۆ_ފ!pYt>5 �1!Bh_ψ�j비 :k/DiB?V2?@B!+QPlayvliZ<?acq|B|+}̠6)xuiw"s? &? Bw2j,}VǴ6ps<_۝?6Ƽ^@L @!)G7P2O}^~?Ju횿eEyB!^L }<WufJ>vh9;kZ1@L @!rWsFycq叧%\VnW>"�Gh_*+.vX[eZ]g6/OJ.7hGV7B!ph(dd#(e ?X>U$Wmi)shK ns;uc|{@B!z=#ҤoL]ţ,()oﮟCVQ#edO!dEKly$}豳9>:Ja;M\egyԮcqd@oımgb?h+UeZ~o\luY5@=vVWVnPבN;!f-@句ɵРwdRs{UcBȱB�c>Cؙ5[dijdNC�^?"'{C-aܞ=^P+5@=^Rko's nn{cw&rm,?k+V_۪'y?s;<_c�}?s0>c^aaǴ=X]Sdoe7lEy{m(^9YQ5@=3ȼ߬-^5 +ߴمV句MhлVtzyV]=3B!ޒ �Ga/Lۖ;}7WW^˴L_d1>>]$5wL!B8$s?TU7{ȐPW'hG ������xI;x73kY'DusϠL^^&=m[FL8J������`aZڥ)]I sxTj,8􆗻e���������������������hJeNe Z${%B;qtT򇫕F3|fΘ4bkdmifc||]2 fQ)4V(0&ENNh=~12leGu?q[EEد;]nB *ljӊڂHD6D@A@X]SG'MԨNCI.8 +y9|sɺlmUtry&,T|vjx]\LG㢖З. <p<?pJN{L>a3fi\o[뀵樬o#+rc2v祥{ +-õZLj +->곘T>(kW0;;P)9ʹՆ'_P)*3ճѽ:֞-봭Sz=?bG*iWscՑ{_|ɬm5^(?y"r_ve?ԏ.⢖hs`A[^1{qz:2=`vtb-ߑsgcuw6V(}Vl9o\^_Emmdznog2v- [չWRYL}ڤ6UrNJ6nzi?2(-8YO~LVV|4L>/?-odo1ܰ\:21#xjnRJ3Kik3ُ{O?d߾?:NhT{q?bCtؐ2{`o/se0iM3q2ZVÉ%K_5䞌]DV +Q'72v-Z +Ƚ}*:F:%q{t57VNPlݎʿ2;je!cncZ[k߾0<B9uh=cwJ +å~2ٿ#4s篵5Ԝ+\*9tY~4$jKK@?پHޔ(YuxW>čjJvؖV9}@Gk}VUa>+D׎vƸ0>F?>֞ssg3aěYhB[aʆx4_f,/9=`9Գw3 e_HEQ7eq9Z<i̔g2;66չ #}-'uglNIA~zOr5 j'c^s9fSCܓk9Wҥ2m_$oJW:o(+I곘Lh1J2aArmd߾!.^ג$8cX'!AZ̏i,.Zo5?Qu( MWdh kIݭ3{sC̛3Wc^Zg،Yv Qn^k(im�??eUtuJfz}ݙJ' o ?\oo2[)-8q\ +eN̞중a<VlWC酭=܉!^^tמ}\Ԓ9/[勢g2.[.kp <^}x~:x>Y^l@G'c9}mm~dxsg oeGxx1n?'unBWf[uze/FCƓWp@CCjV#xzjmd<+;֭w޶ցk)QTfYL}NNIbŴwqh~Z/]L1܉$I@IA~WRwXg )/-Ar6sl<5[3'xo5{l4}_YvTqlyU>Hr5UضClx3:#r{`sH~~o[?2vMWt4F.PZԠ}Q^^<˙YXjUUdfgNI]:urcaCSݣ賘w~ZCɦ@o[뀜SFBg0<BQ׵Cw;ڿuh]p@Gh5/ON{R\:_<Sk9iMC_2v=?MMc u^bS}0BOzgbu? "!"dC_2���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������_Q0 +F(� �p endstream endobj 287 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4271/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnFDQO3KI+þ,=@P +p$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItC; +6!=4~ÉH_9 "}eMV}V}V>CៜݔLj|Oǟ?`w?9d;co'گKZʔصě)k7+SboVĮ%ެL]KYx2%v-feJZʔصě)k7+SboVĮ%ެL]VĪuI@$iC]>%iC]x2%v-feJZʔصě)k7+SboVĮsJ&dC]K>%dnN]Y;>%coN<^Q+>%bn<^Q!]+k7+SboVĮ}y? Ÿ([7:]"'$ެL]KYx2%v-feJZԵߧݬp9]܇t}_L6~)]qPB~P!2'*ӂjiA"kCԵ}hUsX5.UsX5.U$6}Kb܇$6}Kb܇$6ms jX4.EsX4.EsX́Ib܇$}Kb܇$}Kb6&5sX3.5sX3&5zD}Id܇D}Id܇Dls Y2&%sjY2&%zDv}Id܇Dv}Id܇Dvls Y1&sjY1&sjÝGd܇D6}Id܇4l&! ۏas R#݇E}YT܇%߯\.T>rGrp_I2=}|+H;#tk!5ڟyt _;KiѾm]e6mdMd֧O-dodv}~xyiy)\fq^G +YWBe}}H9'1d>?X̺G' Yf2`_~MYV̞,GއYfMV#*$ّzl}~dc>PzG`jY A 2q>R2q>s2{q>2kq>Х2Kq>Ѕ2+q>u2q>U2p>%Bp>"Bp>CzUG^*Z. -Eih#/Z}uB+йtLhZ }}&%B_}yiG`H:/}ƤBG^N:)ݡ}&Sr^}w)LΣ#$,-Wbqiy[ud%b=y#"3ַGBh:+﷏tNCq 鄠wyv}D$b^ߧEy]5|EyݥXw<]+с~%:Aс}9N :tA܍λt4Ws%ٗс}Ng!:{_o|N5NUtnD?JtFUt^7F?MAtL1@et`A O +訞 B?UX 't i*z@G~2:::wtw+{B_t`/2Lлe&΢;Ô="t`P[4Irk]lq[]l cI.FDXL=2[F2[Nt`ín : }/1>W菿إ~muz:CQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQMKӠ?f*a,~-qmqm3s)F&>\Ĥ|Å21i(p(`ڟIQ? K?d*a:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(ts)FA[åt`aҁiG=^ +YL!Z6!ZvI:v>D W7ƣ!V.* rQi "/p"F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сi<ƥa;MKӰ?d%FZ܏+?I]? K?d*:M# +(7=y”=Dr5`, +N<lyw̲}!! +[C_BȲ*ڰ?fٔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?bYMKmJ:l9o}6އ�dZW%Ri UT = ˑ<;xf}hzx ?ϖ]dXVeS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`Bv˦\T* MԈv/އ&'v?6C�l8ypi>D~}@?zB_ܯu~u lؼUaK$I1GGL-̷_x~_q-O?gN^&_j<79x}%=|{? E𿽏W>6>b�O|;w~9e&M}@5c|Cj}|w.twoeK3ߕmovn>0==m9/ӑ'9߱w;>zワӧ\a;>t}3<fuiGS +Y>۷SG,I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$/�NK endstream endobj 286 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4179/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HNVDao{#&BVII$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$]zE_!]r#NCz>߯܇4>ԇ.}V>Da˺vȸ_<3񲙲/QvǸ_<C>FK|qx'Į%ެL]KYx2%v-feJZʔصě)k7+SboVĮ%ެL]KYx2%v-feJZʔصx"%V}KbՖQĦuIlPĦuIlZʔصě)k7+SboVĮ%ެL]KÝ+M>NWĒuI,PĒߜx$v}Kbޜx$V}Kb>n<^Q!+k7+SboVĮ߼ӿ'O?&feJZʔصě)k7+SboV=5frj5~1][CRNn)]s"tLn!]sBdtmu'*ӂjiA"kCԵ}hUsX5.UsX5.U[DM>%iC]>%iC]$}Kb܇$}Kb܇$m95IPĞuIPĞuIr jX3.5sX3.5sjY@#eCM"[>$eCM"[>$eˁGd܇D}Id܇Dl9PȎ5PȎ5r Y1&sjY1&sjY@#aCM">$aCMB݂PmǰzHnQsjU0fI{+עUjG(@Nn.a1ˋ)?#t]IEܹoK ̽H2]YJ߽out}D|*A}}.#@}~.">}~.!<}} ;O#+lSL2>?T<O*4#[E/d6W\a2 }~ u>?Y̲~y,BfWGW_fSGw[fOGއYfMG৫UfIG޷SfGG׫OfCGKf?G^�jYZd}8cy)|8e9l8iI\8myQT8oaD8sq48w$u8{B}|x }qt9ͮ:5;wt +:]CAs2;-: (EܣiB@te%:!m)<BÅ>,oXʎ[t4:R蛲 lw1B_-.tD:B[n.j_#<sX[1zNJW<ە﷒}c/<ۑ+r+"a}!"BֽNJY1O#"i݈yd+"l z+?^żO%} 6MX^a>yͥ\&>CQ;oVhtz(>T_ }'Cg/<t,lEgO|t_{AGqqt㥾^tԣX�TeЙO=ZT0񏑚7ΫaԤ^^ 3Aw@ 7oٕс]Y<;Ё2'MF^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`KѴ4 }ai޸܇�dK܇�l[C�-!�G>q)F& o.ebPqwLL +n;4 +XgҁimO%8lwٞJq?Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]2:0B׽Lu/(t4 +]>.(hwLR:0~K4 >D@rhs3xhsCr}sko<wrQi ;E}t`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQr{*aT4-M6t`k~\k{*aT2,V́oW +夙<pQ<pQ܇crӈ MO` 0eDuχ(\ VC[MKm۔Keuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?b*ڰ?d*?伥!�cKz?h*?d)ڠjnU"$B݆HIa<}hzx ?ϖ]UɰT1MٸT-wЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]gvrQv�/,7ŒR#f>N׿x+_۝ؼq>}V۳; .䏽a! +u qKa1ye[UaK-W}H$2sv<lK>ީoߗelm\ᙧe+KM&|jy Krupv۫i>>_ب<y|ǫ!1r + $yMxjvT\>Rwׅ!19g+jv2=m9/ӑ'^cG}}Ϝ;6玏〞+;,C7sk_<5 };5:~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I`�9 endstream endobj 285 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4225/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HN#WDa'2dY3>ߏHSJJ$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItB; +6!4.p"ҿmtneMV>Dads_}vȸ_<3񶛲OQqx'c}ͧdQ~Ovm]KYx2%v-feJZʔصě)k7+SboVĮ%ެL]KYx2%v-feJZʔصě)k[ъX5.U$6}Kb܇$6}KboVĮ%ެL]KYx2%v-feJZʔصo\iw$}Kb܇$͉+Kb܇$v%bC]+%{ұx2%v-feJכ?'Oz'-Mʔصě)k7+SboVĮ%ެLA]<5f>.kCbKNn)]s"tLn!]sBdtmt'*}}#k%uj9G+Zb܇$V}Kb܇$V}Kb6&Ms4.Ms4.M$}Kb܇$}Kb܇$ms j3.=s3.=sس́Ib܇$}Kb܇$}Id6-sj2&-sj2&-zD}Id܇D}Id6sj1&sj1&zDV}Id܇DV}Id܇DVls 0& sj0&! o}IHczHnQsjU0fIWE ԶQ>]]>b>ISCGg鼒smS }$|,E/#t^){_lPiy,PmȬOuS,O}yߨ3HL2s>Tܽu3]fCǓZd A 2q>s2{q>С2Kq>2Q2p>"32аXtEGd4z#1=OfZ$!}$Ƥe><g>2G``Ss#P̷A 2_^':-Y\б2$a2wt :Hk': i%DǢg }Wv?s*;B]x, !-ꯢSB}ltd~:1%خߋNMetr* }4ӪbtZVlQ }'OEGR·@rgW%aտż ろXżǕn%K|06fżǑMZWbc>' 1 \11qhy"^EǕ}\UŰ0SN`o0ONK� Ä&"4m'A?I<!^]hl)O~W0[3_EvWy=5<7i^JjhϏ~'ھ(%*\jhЯ+5@n7KZdÅIM X>b慶UЏ 5)W/~3K-kRA=P +M@?Ivga)~qFǣU~Vߌ6D4HRQR?-~DwR? -EyPWoѽ +=} +Hȸ;Mu,\WwzǠ3:g•{v\ƫi躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`hZmdX7!�Y!�[um}o +J#a .ebP~C48e;4 +XU34 +WeSɰ4[%Sɰ4[;Ёiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{Ft`mK4 +ZeWҁi/,h]t"_Aߴ;|GܴH!~7 a[4\_n@p"/p"F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiKOe0lNE4l쯤(X]ܮ$u{j*ad*a+ +夙ܲps;ew>Daw?(7(($ +@SKT|8{Հ7Cl_xwݪhZj6ݦl\*;T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUTUѴԆm!UɰT!-s^,AUɰT!MѴmSw!zO6.GOc݆%7C38m1 +.pدJ:lmƥ2hLUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LU?n۔Jxan)qo7nq$^}�m!�W6C4ڞߩop#}Qcx_m�+{g* _4m +C$㱏g[oN ~ ,coZ_<5.]^&_j<79xSSY֯^OqFt~G c^?^~S`}^&ykTS>˧:wBq?\.~ɹ/>]Ve|hˉ|<z?{|a1>w|<_O\ayݾ[3:4~xo~\f۩g$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IT��$LH endstream endobj 284 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4287/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrXEK+N&$,na}?D Tϯ_$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I =tI!iHOD_Iwy}NMæ}¦}¦>AOθ_S>F%>9>6Ǹ!}K|Qq?<gVgVgVgVgVgVgVgVgVgVgVgVgVֶġ)15C]S<5I,PҼuI,PgVgVgVgVgVgV9pr&12C]#>%1gWƼuIlc%11C];s}Z%άL%άL}y{?'?+/]D&qfeJl-qfeJl-qfeJl-qfeJl-qfe +jcԠ.Pּim>/szҚ!BHkoczҚ!DFkۇK yb$Pn#ghEKLPԼuILPԼuILm@$4C]K>%4C]K>%QмuI PмuI P6DM;>%3C];>%3C];<5IP̼uIP̼5l@#2CM"+>$2CM"+>$Qȼ5Pȼ5l@#1CM">$1CM">$Qļ5LPļ5LP6D=" >$0CM" >$-xjR6D=B{P5 +PעeG(@NO7p1ˋvП#t]I!<vK h?H2]YJEGķRz>"NWYP>>OP>?PO>?QO>QWe}}p<v*Xf6G +"e6}~8<uy+Lf0G ˳Bd}}p_~r߭ntyfuVwy߮Nx_>z߯.}|y P<ξEfG 3Yƒ܃Vb}-Bef>W2XwBImh"G>JfٍnT_ +J92]@C'r V +}xp/g}[u<e�x_fΉx߮ft ^B_O-xUVw = +h{M>Ɖ!liЗ8ēE- + J|WGT&]~a]%[?Ub6vz_k}ֶj>F̺ ]>OhU_>.Ch-_>GˋYJy]1>@_u{יgz51;}cT2�S}+/\/"gI겠/ +BV~ddKDX屭_-P΢O%tglb/6@aUa.uMhT~ KK_RgԽ8m$u%h@{@㙂~ H,SRw3ޔGc~~f2R-D[`2IX4 };X-3(2߇֠{,N]h iR}}Eg@_]et/J}l=(sj#]1Q@V[N_BTYs}Eu{sY*ЗS;3>hݝYl߽ +tg]s/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/QOnKӠ\a?m ;)(>Ox3)& 7>Mx;(& a9i0c (\G%qُJ.K?^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:2zaν^Fs/Qi:NJ/Lv3)0fͤ4 +Q,h  ݀ǿ/i5 M6!y}3kz4||[?Ӭܪ4a A/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +{0B^F/Lй (te4 +!0lFEiOI/L`{.`GG%qُJ.K߳ϔB{Lܳp>Da݄QnQDQI ,ܗp%R{wp}VC[MKm۔Keuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?b*ڰ?d*?伥!�cKz?h*?d)ڠjnU"$B݆HIa<}hzx ?ϖ]UɰT1MٸT-wЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]gvrQv�/,7ŒR#f>N׿x+_۝ؼq>}V۳; .䏽a! +u qKa1ye[UaK-W}H$2sv<lK>ީoߗelm\ᙧe+KM&|jy Krupv۫i>>_ب<y|ǫ!1r + $yMxjvT\>Rwׅ!19g+jv2=m9/ӑ'^cG}}Ϝ;6玏〞+;,C7sk_<5 };5:~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I`� endstream endobj 283 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4351/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnFDQO3X˙[{8b!I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$It^>Gؿp"ҟ9 "yԇ%%%}`ß)%?`wß17ēGWß>x2%v-feJZʔصě)k7+SboVĮ%ެL]KYx2%v-feJZʔصě)k7+Sb׎ģ)jC]v85IlPĦuIlPĦ%ެL]KYx2%v-feJZʔصě)kxD#tI,PĒuI,7'ޮ,sر_7'(sXW}H{%v-feJZʔص7?OG7tDOHx2%v-feJZʔصě)k7+SP~ttpj5~1];܇t;݇t}ҵ3݇t}ѵ㗏ҷTA!2>HnI]-jC]>%jC]>%jQĦuIlPĦuIlPĦDM>%hC]>%hC]v85IPĞuIPĞuI@$fC]k>%fC]k>$fQȖ5lPȖ5lPȖD="K>$dCM"K>$dQȎ5PȎ5PȎD="+>$bCM"+>$bCM"+v8lPȆ5lP>$a1D=B +vP5*P=+עm*u\G{ O.>bS}1J*kx^ZHg^GRZt.}DM+CO#uzU *#yz#z#z #zyb/9O#e}>T< +YV2;sc'1\a2 so$.wd!2ryo!+ jlʒ}[2{hyW̚G*$vu}^}2tW~,G^�jY@-2˱~!Af5v#/ٌ-Aeb>fص(Uf)#0 mYKCd6b>.}ؼDEh#/Z EVcyh�-ڃ}&B[жhRh  @>2 hG`>Z$7#0!-V I~zb1#/'ݡ}&[rRlQi~'6H'%ֈ?Vryi5/t[̷~}$b>#"6_q 醠S>71}ש[_Ʋ�Nrx}Bfg.])BsY\,![> tc7}@e^_˺~ td$zaљq}ݫsSNOb?ct.W-ћUo[6_:vŵ߻FG:֍VР:d+Бd^iģ?`_oXFvOt +.CH)!1oOʀ3>2xXkwсL/XkЁUIϷX֣{i{Q6{9Z6{!DZ:Ё=hmnH+Y+:[&=ӒviC+n:F>:Gv'\[:kW[d{Smlt` {n]ށlY с4걙Rޚ+с-6詑j rs^kЁm0桁z˽�Sޙwсm2⑁@ͷ`$O{.]2:0BhZm5Sɰ4[Kn<܇�dK܇�l;܇�l;܇�lK46/}åLL +>]P&& ӝt`U34 +WΧaiO%8l@Q躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`Eҁi}Låt`U/,h/L!Z!ZN:N>D Wƣ!\V.* OrQi "/p"F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сiet`{F^FQ躗сi|<Kðſt*aJ:0HQ3 ø¹݊|QYH֟ϖ4YdXV}U2,aʶuۮPN+ۆW ! +{,C?Bʶ*ڰ?g۔Keuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?c[MKm柲J:lOn}6އ�dOW%R웢i UT = H>;xe>4=sa]dXVmS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`Bvۦ\T*bIw>.oMO+]?-C�_Yxp>DV}@]?򯽏0! +u yOèc8acy:W=_4pއ$Iҏ!jfΎbmg~;5sY?Ƶ O?=w?<69VOM=~g!9`qpvǫe>/}\?2x<u|ǷW)0>F/5m)vݹ}<.K}^/ɹ>]YGe|h˅|<>ߙ{㻍1>>}:q@̕yLJsk_ԟyj[!?G7?rj}h%I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$K� endstream endobj 282 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 267 0 obj <</Intent 288 0 R/Name(Layer 1)/Type/OCG/Usage 289 0 R>> endobj 288 0 obj [/View/Design] endobj 289 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 266 0 obj <</BaseFont/PCPGMH+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 290 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 290 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 291 0 R/FontName/PCPGMH+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 291 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat;]:3UhD@>WA^ZB*<gP .XQh@LE"&=wv{sr{}uq q|N n<(5hnOjFp9QEwW-F_';08;B9g_rO=%>>>S֗_5&]I7)AcitFx|S7:iN5Rp^ :-o4Z]FH IyIߚwHh5ZoI0%ސl:wPdvc.l3bX(m±(!ۄE`U^ƉwZYd6G DG섳x|2~\� dH¤xqxȁ<W/Aɘ '0h' J0@`~_r}y0"u%~^?~񐓗C'1LC$BsWa&'b&ܬL]F{0{*'"^"~mhlFUզ#5Z[)y}h+`t,dhaҪLVxeuY\^hV` eˆsnkvl P bBZHzbxHE96n)n qD7{R})n +!1S,8wyN.(I*:z c2wr>Yjv~n~D \A~QzM"EZ� yg]B{l8iZYkuj-k{-bE/Y$ˬY$\Lj.GE` =槏Xw;l.E?輥 +{ `ikdUU>GMsEtGw.wMW1Q +Tmy[s..ۅnfeP w{' 6xtڋ>"'_&s w_`'C7Ri͓˙}BRR*,Ew,]a$ǝNZFOgozj8tenPŹ"ruuQ8Sʳ)tGd6pzaKٞRH᎓tK�@ەr7 2lt6ԒW_mlW=ϡj4RkL_1O83Ӻa3,k׶iS9ҷiE^n8۠TQyjݡ߲]DGXOm \<UܕsV^aO}{#tʄxY&*-RXSi͑FU%\f,*Pm'g@у"}e(� Z +S톂)4.336ݖxz10�R endstream endobj 272 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 271 0 obj <</LastModified(D:20170110141200Z)/Private 292 0 R>> endobj 292 0 obj <</AIMetaData 293 0 R/AIPDFPrivateData1 294 0 R/AIPDFPrivateData10 295 0 R/AIPDFPrivateData100 296 0 R/AIPDFPrivateData101 297 0 R/AIPDFPrivateData102 298 0 R/AIPDFPrivateData103 299 0 R/AIPDFPrivateData104 300 0 R/AIPDFPrivateData105 301 0 R/AIPDFPrivateData106 302 0 R/AIPDFPrivateData107 303 0 R/AIPDFPrivateData108 304 0 R/AIPDFPrivateData109 305 0 R/AIPDFPrivateData11 306 0 R/AIPDFPrivateData110 307 0 R/AIPDFPrivateData111 308 0 R/AIPDFPrivateData112 309 0 R/AIPDFPrivateData113 310 0 R/AIPDFPrivateData114 311 0 R/AIPDFPrivateData115 312 0 R/AIPDFPrivateData116 313 0 R/AIPDFPrivateData117 314 0 R/AIPDFPrivateData118 315 0 R/AIPDFPrivateData119 316 0 R/AIPDFPrivateData12 317 0 R/AIPDFPrivateData120 318 0 R/AIPDFPrivateData121 319 0 R/AIPDFPrivateData122 320 0 R/AIPDFPrivateData123 321 0 R/AIPDFPrivateData124 322 0 R/AIPDFPrivateData125 323 0 R/AIPDFPrivateData126 324 0 R/AIPDFPrivateData127 325 0 R/AIPDFPrivateData128 326 0 R/AIPDFPrivateData129 327 0 R/AIPDFPrivateData13 328 0 R/AIPDFPrivateData130 329 0 R/AIPDFPrivateData131 330 0 R/AIPDFPrivateData132 331 0 R/AIPDFPrivateData133 332 0 R/AIPDFPrivateData134 333 0 R/AIPDFPrivateData135 334 0 R/AIPDFPrivateData136 335 0 R/AIPDFPrivateData137 336 0 R/AIPDFPrivateData138 337 0 R/AIPDFPrivateData139 338 0 R/AIPDFPrivateData14 339 0 R/AIPDFPrivateData140 340 0 R/AIPDFPrivateData141 341 0 R/AIPDFPrivateData142 342 0 R/AIPDFPrivateData143 343 0 R/AIPDFPrivateData144 344 0 R/AIPDFPrivateData145 345 0 R/AIPDFPrivateData146 346 0 R/AIPDFPrivateData147 347 0 R/AIPDFPrivateData148 348 0 R/AIPDFPrivateData149 349 0 R/AIPDFPrivateData15 350 0 R/AIPDFPrivateData150 351 0 R/AIPDFPrivateData151 352 0 R/AIPDFPrivateData152 353 0 R/AIPDFPrivateData153 354 0 R/AIPDFPrivateData154 355 0 R/AIPDFPrivateData155 356 0 R/AIPDFPrivateData156 357 0 R/AIPDFPrivateData157 358 0 R/AIPDFPrivateData158 359 0 R/AIPDFPrivateData159 360 0 R/AIPDFPrivateData16 361 0 R/AIPDFPrivateData160 362 0 R/AIPDFPrivateData161 363 0 R/AIPDFPrivateData162 364 0 R/AIPDFPrivateData163 365 0 R/AIPDFPrivateData164 366 0 R/AIPDFPrivateData165 367 0 R/AIPDFPrivateData166 368 0 R/AIPDFPrivateData167 369 0 R/AIPDFPrivateData168 370 0 R/AIPDFPrivateData169 371 0 R/AIPDFPrivateData17 372 0 R/AIPDFPrivateData170 373 0 R/AIPDFPrivateData171 374 0 R/AIPDFPrivateData172 375 0 R/AIPDFPrivateData173 376 0 R/AIPDFPrivateData174 377 0 R/AIPDFPrivateData175 378 0 R/AIPDFPrivateData176 379 0 R/AIPDFPrivateData177 380 0 R/AIPDFPrivateData178 381 0 R/AIPDFPrivateData179 382 0 R/AIPDFPrivateData18 383 0 R/AIPDFPrivateData180 384 0 R/AIPDFPrivateData181 385 0 R/AIPDFPrivateData182 386 0 R/AIPDFPrivateData183 387 0 R/AIPDFPrivateData184 388 0 R/AIPDFPrivateData185 389 0 R/AIPDFPrivateData186 390 0 R/AIPDFPrivateData187 391 0 R/AIPDFPrivateData188 392 0 R/AIPDFPrivateData189 393 0 R/AIPDFPrivateData19 394 0 R/AIPDFPrivateData190 395 0 R/AIPDFPrivateData191 396 0 R/AIPDFPrivateData192 397 0 R/AIPDFPrivateData193 398 0 R/AIPDFPrivateData194 399 0 R/AIPDFPrivateData195 400 0 R/AIPDFPrivateData196 401 0 R/AIPDFPrivateData197 402 0 R/AIPDFPrivateData198 403 0 R/AIPDFPrivateData199 404 0 R/AIPDFPrivateData2 405 0 R/AIPDFPrivateData20 406 0 R/AIPDFPrivateData200 407 0 R/AIPDFPrivateData201 408 0 R/AIPDFPrivateData202 409 0 R/AIPDFPrivateData203 410 0 R/AIPDFPrivateData204 411 0 R/AIPDFPrivateData205 412 0 R/AIPDFPrivateData206 413 0 R/AIPDFPrivateData207 414 0 R/AIPDFPrivateData208 415 0 R/AIPDFPrivateData209 416 0 R/AIPDFPrivateData21 417 0 R/AIPDFPrivateData210 418 0 R/AIPDFPrivateData211 419 0 R/AIPDFPrivateData212 420 0 R/AIPDFPrivateData213 421 0 R/AIPDFPrivateData214 422 0 R/AIPDFPrivateData215 423 0 R/AIPDFPrivateData216 424 0 R/AIPDFPrivateData217 425 0 R/AIPDFPrivateData218 426 0 R/AIPDFPrivateData219 427 0 R/AIPDFPrivateData22 428 0 R/AIPDFPrivateData220 429 0 R/AIPDFPrivateData221 430 0 R/AIPDFPrivateData222 431 0 R/AIPDFPrivateData223 432 0 R/AIPDFPrivateData224 433 0 R/AIPDFPrivateData225 434 0 R/AIPDFPrivateData226 435 0 R/AIPDFPrivateData227 436 0 R/AIPDFPrivateData228 437 0 R/AIPDFPrivateData229 438 0 R/AIPDFPrivateData23 439 0 R/AIPDFPrivateData230 440 0 R/AIPDFPrivateData231 441 0 R/AIPDFPrivateData24 442 0 R/AIPDFPrivateData25 443 0 R/AIPDFPrivateData26 444 0 R/AIPDFPrivateData27 445 0 R/AIPDFPrivateData28 446 0 R/AIPDFPrivateData29 447 0 R/AIPDFPrivateData3 448 0 R/AIPDFPrivateData30 449 0 R/AIPDFPrivateData31 450 0 R/AIPDFPrivateData32 451 0 R/AIPDFPrivateData33 452 0 R/AIPDFPrivateData34 453 0 R/AIPDFPrivateData35 454 0 R/AIPDFPrivateData36 455 0 R/AIPDFPrivateData37 456 0 R/AIPDFPrivateData38 457 0 R/AIPDFPrivateData39 458 0 R/AIPDFPrivateData4 459 0 R/AIPDFPrivateData40 460 0 R/AIPDFPrivateData41 461 0 R/AIPDFPrivateData42 462 0 R/AIPDFPrivateData43 463 0 R/AIPDFPrivateData44 464 0 R/AIPDFPrivateData45 465 0 R/AIPDFPrivateData46 466 0 R/AIPDFPrivateData47 467 0 R/AIPDFPrivateData48 468 0 R/AIPDFPrivateData49 469 0 R/AIPDFPrivateData5 470 0 R/AIPDFPrivateData50 471 0 R/AIPDFPrivateData51 472 0 R/AIPDFPrivateData52 473 0 R/AIPDFPrivateData53 474 0 R/AIPDFPrivateData54 475 0 R/AIPDFPrivateData55 476 0 R/AIPDFPrivateData56 477 0 R/AIPDFPrivateData57 478 0 R/AIPDFPrivateData58 479 0 R/AIPDFPrivateData59 480 0 R/AIPDFPrivateData6 481 0 R/AIPDFPrivateData60 482 0 R/AIPDFPrivateData61 483 0 R/AIPDFPrivateData62 484 0 R/AIPDFPrivateData63 485 0 R/AIPDFPrivateData64 486 0 R/AIPDFPrivateData65 487 0 R/AIPDFPrivateData66 488 0 R/AIPDFPrivateData67 489 0 R/AIPDFPrivateData68 490 0 R/AIPDFPrivateData69 491 0 R/AIPDFPrivateData7 492 0 R/AIPDFPrivateData70 493 0 R/AIPDFPrivateData71 494 0 R/AIPDFPrivateData72 495 0 R/AIPDFPrivateData73 496 0 R/AIPDFPrivateData74 497 0 R/AIPDFPrivateData75 498 0 R/AIPDFPrivateData76 499 0 R/AIPDFPrivateData77 500 0 R/AIPDFPrivateData78 501 0 R/AIPDFPrivateData79 502 0 R/AIPDFPrivateData8 503 0 R/AIPDFPrivateData80 504 0 R/AIPDFPrivateData81 505 0 R/AIPDFPrivateData82 506 0 R/AIPDFPrivateData83 507 0 R/AIPDFPrivateData84 508 0 R/AIPDFPrivateData85 509 0 R/AIPDFPrivateData86 510 0 R/AIPDFPrivateData87 511 0 R/AIPDFPrivateData88 512 0 R/AIPDFPrivateData89 513 0 R/AIPDFPrivateData9 514 0 R/AIPDFPrivateData90 515 0 R/AIPDFPrivateData91 516 0 R/AIPDFPrivateData92 517 0 R/AIPDFPrivateData93 518 0 R/AIPDFPrivateData94 519 0 R/AIPDFPrivateData95 520 0 R/AIPDFPrivateData96 521 0 R/AIPDFPrivateData97 522 0 R/AIPDFPrivateData98 523 0 R/AIPDFPrivateData99 524 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 293 0 obj <</Length 1015>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC1.pdf) %%CreationDate: 10/01/2017 14:12 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -559.5688 26.3804 1.68 2452 1484 18 0 0 66 102 0 0 0 1 1 0 1 1 0 0 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 294 0 obj <</Length 12116>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 11964 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD28FFA8FD %56FF7DFD27FFA8A8FD56FFA8A8FD27FFA8FD56FF7DFD27FFA8A8FD56FF7D %A8FD27FFA8FD56FF7DCAFD26FFA8A8FD08FFA8FFA87DA8FFA8A8AFFD45FF %A8A1FD27FFA8FF59FD06A87D7D7D527D5227525252A8FD43FF7D7DA8FD25 %FFA8A8FFAFA8FFA8FFA8FFA8A87DA8A8A87DA87DA8A8FD43FFA8A1A17DA8 %FD22FF7E7EA8FD56FF7DA1A1C3767DA8FD1CFFA87E7E5A5A54A8FD56FFA8 %A1CAA1CAA1A17DFD19FF847E5A5A5A7E5A5AA8FD55FFA876A1A1C9FD04A1 %77A8FD14FF7E7E5A5A545A5A5A545A53A8FD56FFA8A1CAA1CAA1CAA1CA76 %7DFD11FF845A7E5A7E5A7F5A7E5A7F5A7EA8FD56FF7DA1A1CAA1A1A1CAA1 %C376A17DFD0BFFA8A85A7E5A7E5A7E5A7E5A7E5A7E5A7E53A8FD0CFFA8FD %49FFA8A1CAA1CAA1CAA1CAA1CAA1A17DAFFD07FFA87E7E5A5A5A7E5A5A5A %7E5A5A5A7EFD045AA8FD55FFA87DFD04A1C9A1A1A1C9FD04A176A2A8FFA8 %A8595A535A545A5A5A545A5A5A545A5A5A545A5A5A2FA8FD0CFFA8FD49FF %A8A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A17D7E5A7E5A7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A59A8FD56FF7DFD04A1CAA1A1A1CAFD05A1C3A1A1 %53FD155A53A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1CA76A1A1CA %A1C97D5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A597DFD54FFA9FF %7DA1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C97D7D535A5A5A545A5A5A %545A5A5A545A5A5A545A53A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CA %A1CA76A1A1CAA1CAA1CAA1A17D5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7D %A1FD0FFFA8FFAFFFA8FFFFA8A8A87D527DA87D7D7DA8A8FD34FF7DA1A1CA %A1A1A1CAA1A1A1CAA1A176A176C9A1CAA1A1A1C37DFD0F5A53A8FD0CFFA8 %FFA87D7DA87EA87DA8FD047D527D7D52277D527DFD34FFA8A1CAA1CAA1CA %A1CAA1CAA1CA7DC9A1A17DA1A1CAA1CAA1CAA17D537E5A7E5A7E5A7E5A7E %5A7E5A7DA8FD19FFA8FD3AFFA87D52FD04A1C9A1A1A1C9FD08A17D7D7DCA %A1A1A1C9A1A1535A5A5A545A5A5A545A5A5A53A8FD0CFFA8FD49FFA8A1CA %A1CAA1CAA1CAA1CAA1CA7DA1A1CAA1CAA1A17DCAA1CAA1CAA1CA7D5A5A7F %5A7E5A7E5A7E5AA2A8FD56FF7DFD04A1CAA1A1A1CAA1A1A17DA1C3A1CAA1 %C3A1A176A1A1CAA1A1A1C97D7D537E595A597E595A5984847E7DA8A8FFA8 %FFCAFFA8FFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1CA7DA7A1CAA1CAA1CA %A1CA76A1A1CAA1CAA1CAA17D5A7E5A5A5A7EFD075A7E5A5A537E7E7E59FD %48FFA8A87DA176A17DA1767D7DC3A1CAA1A1A1C9A1A1A1C9A1A1A1CAA17D %7DCAA1A1535A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A59A8FD %49FFA8A1A176A17DA17DA1A1CAA1CA7DCAA1CAA1CAA1CAA1CAA1CAA1A17D %7D5A855A7F5A855A7E5A855A7E5A855A7E5A855A7E5A855A7F59FD4AFF7D %A1A17D52A176A1767C52A1A17DA1CAA1A1A1CAA1A1A1CAFD04A17D7E5A7E %5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A53A8FD0FFFA8FD39FF %A7FD07A1A7A1A1A1CA7DA1A1CAA1CAA1CAA1CAA1CAA1CAA1CA7D7D597E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E53A8FD0EFFA8FD38FFA8A8 %7DA87DA87DA87DA87DA87DA87D7DA1A1A1C9A1A1A1C9A1A1A1C9A1A1A1A8 %A1A1535A5A5A545A5A5A545A5A5A545A5A5A54FD045A59A8FD0FFFA8FD46 %FFA1A1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CA7D7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F53CAFD0EFFA8FD46FFA9A1A1C3A1CAA1A1A1CA %A1A1A1CAA1C37D7DA1A1A1C9A17D53FD105A7DA8FD56FFA1A1A1CAA1CAA1 %CAA1CAA1CAA1CAA1A176CAA1CAA1CAA1A1535A5A7E5A7E5A7E5A7E5A7E5A %7E5A5A53CFFD0EFFA8FD47FFA1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A17DA1 %C9A1A1A1C9A1A1775A5A5A545A5A5A545A5A5A545A5A7DA8FD0FFFA8FD46 %FF7DC9A1CAA1CAA1CAA1CAA1CAA1CAA1CA76A2A1CAA1CAA1CAA1CAA17D5A %7F5A7E5A7F5A7E5A7F5A5A7DFD0FFFA8FD46FFA87DA1CAA1A1A1CAA1A1A1 %CAA1A1A1CAFD04A177A1A1CAA1A1A1CAA17D53FD0A5A7EA8FD0FFFA8FFFF %FFA8FFFFFFA8FFA8A8A8FF7D7EA8FFFFA8A8FD32FFA1A1A1CAA1CAA1CAA1 %CAA1CAA1CAA1A77DCAA1A776A1A1CAA1CAA1CAA1A1535A5A7E5A7E5A7E5A %5A7EFD0FFFA8FFFFFFA87D7DA8A8A87EA852FD047DA8FD045228A8FD30FF %A8A1A1A1C9A1A1A1C9A1A1A1C9FD07A1CAA17D7DC9A17D7D7E7DA177595A %5A545A5A5A547EA8FD0FFFA8FFFFFFA8FD05FFA8A87DFD05A87DA87D7DA8 %FD30FFA1A1A1CAA1CAA1CAA1CAA1CAA1CAA1A17DCAA1CAA1CAA1A17D7E5A %7F5A5A5A7E7D7E5A7F5A7E5A7F7EFD0FFFA8FD47FFA87D7D76A1767C76A1 %A1C9A1CAFD07A1CAFD04A153FD0B5A535A5A7EA8FD56FF7DA1A17D76A176 %A17DA176A1A1CAA1A17DCAA1CAA1CAA1CAA1CAA17E5A7E5A7E5A7E5A7E5A %7E5A5A53A984847EFD0BFFA8FD47FFA1A1C3767676A17DA1767D7DA1A1C3 %A1A1A1C9A1A1A1C9A1A1A1C9A17D535A5A5A54FD075A545A535A5A7E5A5A %535A597E7E847E7EFD47FF7DA7A1A8A1A8A1A8A1A8A1A8A1A8A1A17DCAA1 %CAA1CAA1CAA1CAA1CAA1CA7D7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A %7FFD065A59FD48FFA8FFAFFFA8FFA8A8A8FFAFFFA8FFA8A1A1CAA1A1A1CA %A1A1A1CAFD04A17D7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5A7DFD57FF7DCAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1537F5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E7DFD0FFFA8FD46FFA8FD04A1C9A1 %A1A1C9A1A1A1C9A1C376A1A1A1535A5A5A545A5A5A545A5A5A545A5A5A54 %5A5A5A537DFD0EFFA8FD48FF7DCAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CA %A1CA7D7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7E7DFD0FFFA8FD46FF %A8FD04A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA17D53FD0F5A537DFD %0EFFA8FD48FF7DCAA1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1CAA1A1 %535A5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DFD0FFFA8FD46FFA8A1A1C9A1A1 %A1C9A1A1A1C9A1A1A1CA76A1A1C9A1A1A1C9A1A177595A5A545A5A5A545A %5A5A545A53A1FD0EFFA8FD46FFA8A87DCAA1CAA1CAA1CAA1CAA1CAA1CAA1 %A17DCAA1CAA1CAA1CAA1CAA17D5A7F5A7E5A7F5A7E5A7F5A7EA1FD0FFFA8 %FD46FFA8A1A1CAA1A1A1CAA1A1A1CAA1A1A1CA767DA1A1A1C3A1CAA1A1A1 %CAA1A153FD0A5AA8FD57FF7DCAA1CAA1CAA1CAA1CAA1CAA1CAFD04A1767D %7DCAA1CAA1CAA1CAA1C37D7E5A7E5A7E5A7E5A7EA8FD0FFFA8FD46FFA8FD %04A1CAA1C3A1C9A1A1A1C9A1C376A1A1C3767D537E7DA1A1C3A1C9A1C376 %7D54FD055A53A8FD0EFFA8FD46FFAFFFA1A17DA1A1A17DA1A1CAA1CAA1CA %A1A1A1CAA1CAA1A1595A5A7E7DA8A1CAA1CAA1A1595A5A7E5A7EA8FD0FFF %A8FD46FFA8A1A1A176A1767676FD04A1CAA1A176FD04A1CAA1A177FD055A %7D7D7DCAA1A177FD045AA8FD0EFFA8FD48FF7DCAA17676A17DA1767D76C9 %A1CAA1A1A1CAA1CAA1CAA1CA7D7EFD055A7E5A7EA1CA7D7D5A7EA8FD0FFF %A8FD44FFA8FFA87DFD0EA176A1A1C9A1A1A1C9A1C3A17D53FD055A545A5A %5A537E5A7D7DA8A8FFA8FFAFFFA8FFA8FFA8FFA8CFFD47FFA1CFA8A8A8CA %A8A8A8CFA8A8A8CAA8A1A1CAA1CAA1CAA1CAA1CAA1A17D5A5A7E5A7F5A7E %5A7F5A7E5A7E5A7E5A855A7E5A7E597E597E7E7EA8FD4EFFA8FD07FF7DA1 %A1CAA1A1A1CAA1A1A1CAA1A17D7E5A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E53A8FD10FFA8FD45FFA8A1CAA1CAA1CAA1CAA1CAA1CA %A1CAA1A2597E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A59A8FD %56FF7DFD04A1C9A1A1A1C9A1A1A1C9FD04A153FD055A545A5A5A545A5A5A %545A5A5A545A5A5A53A8FD10FFA8FD45FFA8A1CAA1CAA1CAA1CAA1CAA1CA %A1CAA1CAA1A87D7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7DA8FD %56FF7DFD04A1CAA1A1A1CAA1A1A1CAFD04A17DC37D7E53FD115A53A8FD10 %FFA8FD2DFFA9A8FFA8A87DA8FFFFA8FD0EFFA8A1CAA1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA17DA1CAA1A1595A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DA8 %FD3EFF5252A87D5227527E2753275952A87DA87DA87D7D7DFFFFFF7DA1A1 %C9A1A1A1C9A1A1A1C9A1A1A1C9A1A176CAA1A1A1C3775A545A5A5A545A5A %5A545A5A5A545A53A8FD10FFA8FD2DFFA87DFFA8A87DFD07A8FD0BFFA8A1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1CAA17E5A7E5A7F5A %7E5A7F5A7E5A7F5A7EA8FD55FFA87DA1A1CAA1A1A1CAA1A1A1CAA1A1A1CA %A1A176A177A1A1CAA1C3A1A1535A5A7EFD085A7DCAFD10FFA8FD45FFA8A1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1A77D7DA1CAA1CAA1CA7D5A5A %7E5A7E5A7E5A7E5AA2CAFD56FF7DFD04A1C9A1A1A1C9A1A1A1C9FD04A176 %C3A1C97DA1767DA1A1A1C97D7D2F5A5A5A545A5A5A7DCFFD10FFA8FD45FF %A8A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CAA1A1595A7EA8A1 %CAA1A1595A5A7F5A7E5AA8CAFD56FF7DA176A17CA1767DA1CAA1C3A1CAFD %04A176C9A1CAA1A1A1C97D5A305A7D7DA1C37DFD055A7DFD11FFA8FD45FF %A8A1A176A1767D7DA1A1CAA1CAA1CAA1CAA1A1A1CAA1CAA1CAA1CAA17D5A %5A5A7E7EA2777E5A7E5AA2A8FFA8A9A8A9A8A87EA87E847DA87E847DA8FD %45FF7DA1A17652A176A17676527DA1A1A1C9A1A176CAA1A1A1C9A1A1A1CA %A1A153FD045A7E5A7E5A7E5A7E5A7E5A7E597E5A5A535A535A535A595A59 %FD45FFA8A1CAA1A1A1CAA1A1A1A8A1CAA1CAA1CAA1A1A1CAA1CAA1CAA1CA %A1CAA1CA7D7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7EFD43FFA8FFA7FD07A8A7FD09A876CAA1A1A1CAA1A1A1CAA1A1A1C976 %7D53FD175A53FD0DFFA8FD49FFA1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1 %535A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DFD57FF76C3A1 %C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1525A5A5A545A5A5A545A5A5A545A5A %5A54FD055A53FD0DFFA8FD48FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1 %CAA1CA7D7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7DFD56FFA876 %C3A1CAA1A1A1CAA1A1A1CAA1A176CAA1A1A1CAA17D53FD115A7DFD0DFFA8 %FD48FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1CAA1A17D5A5A %7E5A7E5A7E5A7E5A7E5A7E5A7E53A1FD3DFFA87D7DA87D7D277DA87D527D %7DA8FFFFA8FFA8FFA8FD05FF76C9A1A1A1C9A1A1A1C9FD04A176A1A1C9A1 %A1A1C9A1C3777E545A545A5A5A545A5A5A545A5A5A7DFD0DFFA8FD30FF52 %7D7DA853527D7DFD04527DFFFD05A87E7DFFFFFFA1A1A1CAA1CAA1CAA1CA %A1CAA1CAFD04A17DA1A1CAA1CAA1CAA17D597F5A7E5A7F5A7E5A7F5A7E5A %A8FD3FFFA8FD07FFA8FD0DFFA8A876CAA1A1A1CAA1A1A1CAFD04A176C9A1 %A176A1A1CAA1A1A1CAA1A153FD0B5A7DFD0DFFA8FD49FFA1A1CAA1CAA1CA %A1CAA1CAA1CAA1A1A1CAA1CAA17DA1CAA1CAA1CAA1C97D7E5A7E5A7E5A7E %5A7E5AA8FD57FF76C3A1C9A1A1A1C9A1A1A1C9A1A176CAA1A1A1CAA1A176 %FD04A1C9A1C3A17D53FD065A7EA1FFA8FFA8FFA8FFA9FFA8FFAFFFA8FD48 %FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CAA1CAA1CA77A1A1CAA1 %CAA1CAA1A17D7E5A7E597E5A7E5A7E595A537E5A7E5A7F5A7E5AA9FD49FF %7DA1767D7D7676A1A1C9A1CAA1A176CAA1A1A1CAA1A1A1CA7D7D7DA8A1C3 %A1CA7D7E535A5A5A53FD0F5A59FD48FFA8A1A1A152A176A17DA17D7DA1CA %A1A1A1CAA1CAA1CAA1CAA1CAA17D537E7E7E5A5A5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7EFD49FF76C3A17676A1A1A176A176A1A1A176 %C3A1C9A1A1A1C9A1A1A1C9A1A1535A5A5A545A5A5A545A5A5A545A5A5A54 %5A5A5A54FD055A53FD48FFA8A1A1A8A1A8A1A8A1A8A1A8A1A87DA1A1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA17E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A %7F5A7E5A7F5A7DFD49FFA8FFAFFFA8FFFFA8A8FFAFFFA8FF7DC3A1CAA1A1 %A1CAA1A1A1CAA1A1A1CAA1A153FD155A7DFD57FFA1A1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1A1535A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E53 %7DFD56FFA876CAA1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1777E545A54 %5A5A5A545A5A5A545A5A5A545A5A5A77FD56FFA8A1A1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA17D5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E59 %7DFD57FF76CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A153FD %0F5A7DFD40FFA8FFA8A87DA8A8FFA8FD0DFFA8A1A1CAA1CAA1CAA1CAA1CA %A1CAA1CAA1CAA1CAA1CAA1CAA1C97D7E5A7E5A7E5A7E5A7E5A7E5A7E5AA8 %FD3FFFFD047D5227FD0452277D52FFA8A87DA87DA852A8A8A176C3A1C9A1 %A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1C3A17D54FD055A545A5A %5A545A7DFD40FFFD04A87DA87DFF7DA8A8A8FD0AFFA8A1A1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1595B5A7E5A7F5A7E5A %7F5AA8FD57FF7DC3A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CA %A1A1A1CAA1A177FD085A7EA1FD56FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CA7D7D5A5A5A7E5A5A5AA8FD55FF %A8A87CA17DA176A1767DA1CAA1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1 %A1C9A1C3A1A153FD055AA1FD57FFA1A1A176A176A17DCAA1A1A1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1C97D7E5A7E5ACAFD57FF76CA %A17676A176A1767D76A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1 %A1CAA1C377595A5AA1FD56FFA8A1A1CAA1A1A1CAFD07A1CAA1A1A1CAA1A1 %A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1C9A17D53A8FD55FFA8A87DA8A7FD05 %A8A7FD07A8A1A8A1A8A8A8A7A8A1A8A1A8A8A8A7A8A1A8A1A8A8A8A7A8A8 %FDFCFFFDFCFFFD0CFFFF %%EndData endstream endobj 295 0 obj <</Filter[/FlateDecode]/Length 14236>>stream +HWmoHG5^UM HsVт76I?~gok0 9& +س<;ӐACF4ڇF |z0h hFCw 0f%; 1 ѫFQA|2J-SȋF37rG�L$EPc8pLY\z &a}@_i(Ho:^0�hhv|5m Ɍih<XNޔX0j K'1n>_INp!yC,YP{@rYR_qkأ>E\'F\ELcN ]zNψ61udNhS+qGj"aԼu)\x"&V'E<{(E1΢XR4E7!r( 0pM"-,2v0j~k8WN:zM]QRSԅ+ᤥ?ƪ=qZs\XbKUQmiU k*)%XMk5iMǚQMk2օWP-Dlʳ5,ٚ5ռ'^k^ۖD",rV 0vkj݀֌V3}fԌJMl>EH]EZMiEifMil> +RZMk5="yb$z^p~){`N8<wnBŏwf2X"-&ShzU�;uwHfX*ɶ.*<Xj&ȊmFe&5eiqZSzmhKGb'L]n4mvOgR=V~ʩ=sȬ[~w26B%;`2eY 障Z + Nq(3dlx[|s\=( =0ڽL+]IJ  [ƳLsiUu{bˈƨO M!P"j+Nϐ +\F1 f;o~<0VP⊇gJ?`콲 ꤫ۗna0K¼!PC1S_ ̾n<nu>HtBwZ/JhJ짏}CgV5qb^()ic֑b,[–*Fհv.xhh>6~p+7xAPy uOZ;cVd0쪆aLWn6Y&LӐev՛ + +7LsLk?jјx }ϋ~\&'߹[pY/ +4 bӋ\$1gCܐ?/ޒ1j!.9=ssO1<+ .-y3'NyszA0b}2velU-),ph]dO}y2'_9wNONgW}eipƀ N"nVҵٕf75 ya$Kɂ99qÖ8kߙ@oFWLbdzrw3^iq랺QOl;5+HTu$v29Ӌ{j2x +ߩ$IRrfaaa >^ߘgWanwDŽsr! .TaHO'ozMsr?r ,Ʈf.Q#$BJz^pğV& Lv96z93Ǟ7u$_@J^UhGlH!&W 7g^|}`XΑ}w:a׋DgY/qB6Gr+#5 `l+;QcY菅41 J7| EyL|/ qGdawK\z //| C1 ꃗH>`H[FYQ:a(+m +ŕQzA*bT}eAd̶ύ@EN!$]2JXJ|#3N�>sӟ/ ,9[]Dz&1lF@*P8ہm@p ɗKMaHE/㊨,JT]<Ba9N/&߮RJWtz[-=R'rƴjz^)7/y +C= `p0ۻV2WKZ=`.M0KU3,^57*ٛCRZfz^,L2G fM*ŷj8@ S!.S-Н2.ap'(tN|vܫ|kfU_pq\ݫf +dVi^EPsh`$XܟwkpYa7dVqvfʲVaVf0m*,t0X"2B]cV)kW0z X`Zzv^НLĊ`[\*L]1Bwo]*.Z4dxs)n^tfeQmeh<)XHVR!a`s,iO~1H߻אdңPg4MjS7 HkN[*Wdhx;S/b9[/]tPt#hnfGZ{Ʊ/@`0(ߞ~r"mv`(hEܤ~/%Qe:f%C׹FR 'X2WzӫW#@~j+E{n`#ϟoX@/k.%=;P- {^Yϝ?F{x>>:@i/s]"* +5Ð@D\Cs`d 'kwF*Ta8q9K9CGau-9>81>!Waz(:EN=0c1+";!#K\. aFe/C w:^k~hA6NLH@`B ZGX@uޑGT5eT=Q0_*p>J33wO/ϫ1:0JuS-8͒; sIW79?N؝A^$Zٲਹ4F62dIkCjt4MLOz'6,#"aelB>KÙ x^>4�p ZuHzLAhLL X 2;˿pVFӔY=% g>HA6Z%XPˠ^[,Zގ2;ӗ%)4񣇂Ak!~s, +† A|jmM/dMrGI6t_.j\ݘA/`^$<~=5ͯCFb2ݐ'|10_PFɨ/_vFz='fY2zouF%2&,z|1OƜ =۝ _œg +Qnih٪SVuo# $s'{ўi{$%=Ojͱ֙m?h+ykNj|Sydd"c%3AM-cKZO3wA TЁ|<跌1[0b +-E`H@X*"p%Ёs8ȩ)FyT@J%fT=r ,wtU,uU{pX_yxp= ?÷p&%fn/z+YMPIā ~ "*V~I-PezB4 t2wXnP/ 1;WˌeҮtr!An[ѯ7^3Ja$Q԰| Au!$tKd\E &byrjGwٖu+~ GW7JW +T̠ s_p(CIOnXAn +>qgPa,#"OxdE<S xIb +LP^ΏCxZen'RGkY5A킚ӨU|C)LJۺ8ǃ꾧 wEٰm|@q}Sg4KZ`G3eOf1}jYZmFc\WZk'iF:lO]=4tǭ}fBoCqDВ@ltV}ܼdzn%,'=i5e' i'$>d =f.A>D/Aԭrqpmq+rt*\SM.Q4[c``Y"* + aeXG 6 a H(i<n{ovB)na+- ೇz,Bp:w ``ì`64tճ͌YDUuMqD3_σ GCG/t49Yo�Q@<q& + W[=DUMykb($|\%eHQDfZP� + +H`ڙ/Cu 7r/ؑ81'lu(P<IזӝA52ԟ>uV.>B^=؉|C9wԳgU-hMuUrV5@92Z"gpUr5 \Q&OSr H&IJ'>lHggyw:]:fH%+,q5Ձ^ qÅL8L$ +VFCV؛e46jP!íy5hO$M C(ɢA;.&ؗvc}eWiu&/Е@G37�=L]:8D"Nꡊ퀌lYzUPk +fT0� X(ȞA*ðfѰ fdy@҅BDۄ R[66*V=Rn-Vµ@g9]y?-6pPu bEpqVUd25Rb^ykd&ѳJS$~N+XJ <TfJԈ9Z]{q%xKnk3H 2/[19aF F\ w\=n}:뢅.43HtE|b7I }#̴[Y;Dzh6G"Ybʥn L(e]q�AOϮ5`YLLI"* +QB!Jז Y$2dA@PhCW?MvU*ܪhCM2N6dX0K.Icva80elʢK0ʥ 8eý̲:'q7B&GEwLn[/ Z�jΔ' `SӱS{{v:pvв*&jhs}k'PQ̥e*,A)(#Ǵv`🔃P<0zM8F맩Y:0H6;| +t/:n]0`ZkP"w9a\҅?6"~b|M&]srol(M5w^~=tsU FJGO1(FʿhP[UT !QߑlZ<a((eNe~TDހ!`>lP1 jX]~i!Y�w'cPm]X.ݙ3q[rXfuSDa.cDVK!Mc`'/(Aż ІhL0ϴ e ajb/ hMvɶjGXGR@ٚU35[(c +l.Z% 8+l(cu#ѦB,Nm+f3=݁hQWg._ٿA ɻci|>ם?MXq5AyYJNӎe _y/lzwcCÎ"> SnOP 0sx̎l۴p{0T6isa궮,}֕7x蝲0?M^Ngǵ8CO;&e[bl ,qthYCjٴi[0>X5й B +jMDa=YC<ig +K"ӿn§MuSm1l*;Wb.t-8ن;2U8}p6P0^ZLc_CAVU屘eR)U~( |'R)_<npSn_Q EeT ?].QdƏ5L-Vyȋ\4SU@,+I"az 2'x>x.ue`ύ^aWDfDt?6V˾SFtsaŇJq.̩kvLLvB[81QB c)ŕ%^ѭOulx$Ÿp(=I3G�p l;$'>)xqT8@ |T$f/#:Ӣkm5Ln/\睢U1r1bA!1ugZUD6.e6&@~OHXfDcxVSlu̝y)Ӿ<j8ّU?8Oj)̮ӑUivZ<{b/nkIH +"LJSyru"ŪCΆGX-Y}|1 +㇕?>P&:sDLemƀDi)>Qap(ҽTFWQWLzi__:4QK޳ ?zk:쥥^3w+]iUXnyvt�єעJk7UNl@;7g{ʵvŴYODꗮ:k^=?NRsP7a2ڎ7n")L E |ƩR+џ_|hTqK^_}!H[͌̇kvnΊx-o*f#L(JZ55; "'4i8lT})*{OpLmZD+#x4d<YJ=}_79%|io_&wD0RfjJ fv4=yU|-`Y k?| Bh�k-Q1 jGAA}SW05/~ئ v~?GHhF�Z6Z%N2RR"^FzU =|u7f*9dc0On}๲1}wLš֠®n3"( :�Ytj6p >,(]lyg,Y /^1TZGbՄD;CNy&Po18@RX1VCce:pxVܮG#l] )琬y6WҲvEx_sTf16Il-Hm5r!{7DkwUl@_pW: D/P"ʍ" ^+Dl'jj6;iXkI^`+~ލV8_^PؚpsR<pN:Sgv!զf0pC�)_mr"kHڒZ4OE@uEVFud˫dꙸ32:6,1 e9jw3K3N=WF{jY4C&^ِ3�VVF]ċ/#;ncG0KbgLd#/= {Hp.mE-7+a -J,N*ݤhyL\̅_{K喣1-,t"vYXibF(A> an-._*Xk@Xf[^FoB^vHV mOimdI_oэ!v2. +1ⅺ'dadnVi[JwAϾg]R0]z84AL'&&!ԏBx0Mn+8k}Yt7,ǥcrS_bI78ll9<t(Byj {@Yęgx[+7UCw?'Qa3CrF}9Ceϭ2W 6ۿO)ʛV͖)i1arLCzY)LlT ZGW-$<x<Vp!Do D`Į DrTEIe pGC. + teIm|`?l cM|djF[9޹2$;IɳٕOמߜ7HhENVw" RwP\b[ڳy6zau=Ԡ?bT;hF%k1Gߋy|QW7S]ǘm"hKwj^Wrm,aQ+, +dtj1n7L2.}#B^CP)$p,RkY-׍+&¹hlڽP+id(aBc3SF?J9?P+<<ȿePWz\,)O\gmlu4<V[09xFؑ綱7%NU@;GOs_U`JNexx:"HQ0a%LC`u0Gt:rͲ_L_a]G+U1G/8"u +LtM!.@X-Eͭu&:׀ =8ND'uZn;2X5#(sim''++EI.ݵ +P:#<*{135YJzGؚS)YUSK`2BL#&s3FV E 2Y+Uv =IrP" ;4MHogL[[E П%4cwlqdJc�;*1La +C.tn*J0HIDؽy/K{裟L3+$()nuB!c`%lyjM&Nu8 61*" Uz*0Tpͼ+,w:ّU:?EtEc^+@ⷑ4J:U6L<r襺BE`P +'FcJb!>Pdus$-ǔ]L {H[ .j9jMG^`{`7R&/wX_bJ\ Tl,X8 '9h+G+c`)ؚ*/S{8tVߠXk$±e2P ${'ڽlJ$.hF|rz{7'=X"vLuVb#L]n+ _%#3^KCGbr'0m?H7*"Ԡ dɄ&+lҦN}QҰi M2D8+�TBu1˾"t\֘̽1م+Z[gjqڡK S b!6_м'JxhVD60fYSaJVoZ$F#3ueah'|}a~eJ{q wrJvD=L6zۑR6.};z�*0^lN^@Y iMĬXC-|57sQa]P=6 8ւ$HR_$r3Oos攒 \Ǭ3"LiyaӽjY 툔rϣwA"̶D0C@q"".( QQ{sj}~诫Kk{+BMo7%)E<+_ڼy0P>#\ob.b8;#>FCH[ GE6vk؎1霜[qÂ3\RR.UFv~LxLbm'SG ms΋ O3zJE +;{3ԋ{%e9<XөnA?fjݚnt1z  D99?p?zT^";xX`]N{TY+0/̻ǔϋM& s5~Bx,|Km/#<ٵZgu6h^3H`V??Kux(ŷMD<5,;::Opck^q\f-eV0A,^7DN-εA3<'k|Râtp{ Dㇵ~ZpcUoScKS @4[ ̾P7l?MpW$(gOOĻe6ҡ_ؒW=H&@X `LmRBô +8svNCP*3Džoc9 >pKR6嫇2۱e8ڸFũ"FB<փ)\NCg$Yq2`> }Ic46@(B?czGjP4ݚXҵEvu"ڼ�� Xi=ad%bvaBkBݲa$PC1]d0T{[b_v4f&G Uye5;s7BF?_v<{C&TCéb~y_\8λdn< GrWn+d<~~fPE0|acM!"V04:Q/2Y.L!AStn$'F+$l+(@I.BS[ +T{q[43ۄʷ�D$BɮG\IDQaI)*bv=K>*!9iǎbS1|J^-j!"%, :Byh6�L;{ *= co/uMK +`"i^xLI6^b cXmH;vFSykn |$؀ +hʠn3j-PSRr_Èf +"0P>;@+�ȥ}F\u-JHRJ={-tvUB6P6qpqB28쥔 8_״*ypN l}U]�hVJe"{~|h4G%_#m+̄f$O 'B<?1{hC@ϳ+A/z@R0졑nD +KKؑ5;(Já+FJ :!ظmog&ԅX|rc+- NW#kzVz8a@]ˋݘ$2Gkv3۹:AMQcX lfUfG9BK&EA q9 +vpI^T헎>Pk?OKGZcO6Q>9$_#:`đZmڶ`B=M7:1q{hus1;*{kH!wE[hPfXϺi#ftNezIЄ_~L,o@P ,vw3fo +=QK`\njR�+p3V�͝ެP 4.#Ď夡<ldB Ѵto@ TVEգzҤ%a1V\a1ѯ[^:zxvRW<F +^xm^cQXx\U}{ە~S*G5Fcgu5Q}<2Ox<_d̵[m[sٷNn5GLC:-c6Q9}eGu&VJN_)QGHFRCfiAGU+ӅZ$p9c<Dz 1Uz>9뮔q>?71sW#z^GQb=ك^z11n9/ƻQ?3 „F1o#I#{s> &}/ҏܔ|XmK[ ?0(EoTbAU V.nnl/y93st8h}|-Z):{vJ;n_IKG(),g'\#uVocۏ*R)VB^L8>^Y'yS%NGB.\R�PSDIDV-u5ufs4w="}v=|w/(5s{߽"}Gآ9Lrmtwˠ¿,_ XMgS`{ $aO.6Q*vqwSzp&ɴ&+x D>Ӱj%3qyte8na!A[vBLm:�M?!W(Q + ҆mev9WGxV.h`ȁ-of!N$ i~I3ďuKekW~&?B,1gEjiXYwsy! nI'o|r]lq7`ԓ^;zu_Y�9�-zݹH%d܌1vw )m˦mے[ 'W(_}oEA5-$~(+v1Y YTF]r5aw1c}ڂzUI2SaǮ ́ɷdd9L'?2c1);${;wꩃ]-L9Aύ> ~UnSTN@-(zUZ2ɐ_q~ąsYxJ\inЋ^tgqnŤǠfnҵdq!LjՓhZx!- <$H:I.V3L +w"Js|1"F;y c`* %n\>#&N_oh1R׵uQoi⩉A.|1F`rQNTVzho +T_v_)6 :{|2NieՑ5XB 2/P"X@+ gAv%+ZYFsPϘ{ho,[OD(BC2 u08A6$�-.LZ%:%�:]+R zn8x.vQf`$Ӷm!eΟ +sQ?ҳ_I�V +FS@#^V"j8ͤ5L +anZ2zl \WD#9*-+7hN$R}QwDV>hE} p(%%YyMKfyEP-Zvj> B{-6n8ɾ.0RX !%P*x,eiu2ÛɅG4'Oa) }: !Ͱp<:f+w?ء`nXR›EZZt7 U}>m,!a/M55_tU'ӲNhE!V0.7|eOStēhp#zѶJ)j߅kFey +b,%,U\53dhTl;VVNXp  ߉4RNd_2u01X7X>`ѣpO JF~ϸ-f(h~|F#k(�t-u)8 +>l, Ӕ݆т&ohP5Ş}�� endstream endobj 296 0 obj <</Filter[/FlateDecode]/Length 1098>>stream +H}LUu rmjnYF=0K8[e$fW|D.\=p}R +EFxpͭ=GM<}_w~qc:fZtV]2to&9~�wԕ֮t<iPk{!(᭩֬|eW;;6g0 -~R4eS?}yvw �Ի*֎`pЁw9YVgUO\w ͜ (F=_.?o�]M> iQ΄ˉ +bkG4HPwNMX^N�̾ k/?La�kE[|rE�pS>`�o*yq�z"SܰxKةN24u5S H�<]r"Sp  ݎߕ�bog�׊+ +5u|;-ޙlg�]j`zD? H+6py~ȱ�\._{ 2}O{-Z+=<s{%z �:<h[wAd +YG4u4G~m�wwKӬ7Ad +˃;}wO{޴K�W/7G7Xo; 5"$w ]44u|/{s;� ۍwAd +ג"_=zkxy_ݽ +�g4Y9 —n +No}h}~�\8zD?pSZ^UUs6ݓS�Y5{VYo8YIz*1}v=mZ�_ i2~f�"SM>/'/r4߹�I^,}f?La�kQc"85/-ݽ�ɴMyY5U]y l9չF~`�+B] endstream endobj 297 0 obj <</Filter[/FlateDecode]/Length 1064>>stream +H]lSu3a@v!_XB7ɢ#fh K%#4LPX&^ +i6#tC@e݈b1ܑFEI>71zRq}GUXib'*{:?0d(ݹ^,lWqwl8f�oQI8E:Bǵ91�5wÊ 2ڞs7:wVw�d?e:KV|'?La�;s˟W, +h!]sL,o['>r3wYѡ} 2<Q^9A+]/#Fbe]f�ogǫ~k"^@&7e9ƻ'/b*G  j_}@v,4e% 2^-8?q!-n@5zusB?La�Weʶky+MFvl/ ] +Ee�-Ql5]yЩ3Dp�HGѥw%,:KݯZ}r�H'w~c.)/LW)�ӃUWjukx"d^ڶNMt0{$[D?�Lxg1_"ju�Hu#&w*鴱aozigF'*:7�n]:Q$w)閻EFmXkѠ-} Gw{Ad +Lyζ5Y蜨~G�JnmWHO)�3)PyZPs&L o>�:pAd +yֵAO. }�-w;Ad +Hk5z^@^hLJ)�ͳRc{XǿXD��D9wgoKI)4��Ih endstream endobj 298 0 obj <</Filter[/FlateDecode]/Length 1309>>stream +H{Lu XaP67ͬͦN 1@a捬LMMd*Pp@sx0$eZ2o(j3=RiϹ?_>1A{{dlD~󗫅0Xs\{q#nPAG}Y}=� 8y/wR_2S��‹;Lm7?7M*6ZtS{bay=P��zZSY뵝 �w6a'EZ]}r�33m?7݅$mdFlm}pn8�x[lj{A)�bЪXu! +�4V,ӭgkA)�&6'5D*ovvW/͛s�ip(-yqco +' +[-VYjvb�{j;A)�l9b߱#j]565~�^YYkě�邓ljy '+z K&G�R;lّ(mϱ?'`1ݲ/7韾�-S$VS޷�< v3mSo9tpu�_8\v[GSvEo +�73:Gǂ ʢ퇶m][~, 2M"ݹߔ8$N�mk|x0}ĝpzߩ+_ �nȚxm/ڢ9{o~c�@wjǜjA5!AA|nbC�� Wvֶ_ϯ˰�^ô j,e�bD9} K~K{�4u폸bgKW(- 1S�9XUfVꩼ�5&sY3w1Cd[Tqȸ�'mQp(RfCBt�ZK7,C'X8=q)Fwc>\'%Y[TY^w[jwM;6ϸ!\�zRD4a_ʲZMj(5V{wS%$96uht}ֶ ]#)?=B;��%eUF35e-ܳ ^ɢ6{;A)[GO~Dr^\7)ZD߲?�%ӉbyIv)YjiPۿ5ĿQM`�9 endstream endobj 299 0 obj <</Filter[/FlateDecode]/Length 1068>>stream +H]lSu#$%F|!5&D !.LYP 'QpQ1dL`[.1q͖t㜭dll`{ BDX{H[鼲RwDA$s.y{2&.^#EYJƴ?, +!fۮwخl뿾u�?ZPJ)o)31>5P,. Zg;K,cuNǺk��k?91Pw*G,T_�xg|&gI} 2�μ"չ2AF":fQ�iˋ̛-K'u�=qSa/#& +�ڽ~1r'u�;3_KW]{<k"d"aE7 �9޷qu8-V 2�m*zUٝ]_:o~�H~gV 2�7f}KJ]HcWN6 uwGQ]`7"S�pnAZVa�$_J Uװ?La�[Y#0?T[@r>hV 2�7nj+ +5hc::<5KM 9\yV j=V 2�7ܼbEV[:u7ڂw 7e7jjU?La�xbiP]Mr7�PǾ檐7`'"S�0uf+9KJws@sȪKD?�`d*7̾=}[@b9}䣨#ழ)�gZow~vk<�C_5`ԔYu�m3ﾌ6UD]eݢ�u7ϔ5TX�x ֺv�qCJ 6`��qf.VU U �w;sAd +�ě_i czq؝:M- : bZ`�đ^&.q$[M >†:Ks` "S�4_ endstream endobj 300 0 obj <</Filter[/FlateDecode]/Length 1067>>stream +HOUuu\TY+glEp9Ŧ^Mq2rD]%Ʒ{{bK p1`-ǻjUx?ya�lWp5o]أFp̅O"!W�P١phӾcջ;]T߳]�4HE7hW5琮j{{{ *�׶{ㆮ%Ƈ[:I�݁Q)�ݸ1i߱lrc?rʚyB7AT +�RGami5= 3ER[T3D?� d'״O�._Ȟ];AT +�RSNSb^Z ?i;5&C<N{g�VPh3γ?m7{.1ʓcU+AT +�R_vY=pP6t %w*�α(nuR�_}Vl4ך=_l߫�a_r,βmQ)�Pʆg ]Kz!~`j_oyԺ2nAT +�4] ^xg# c6ڔc3X~M4{f��-[55e:'Ӽч|?Ja�/ߜ<ӵŁ–gw.�Irg}>D?� }rY]a#_}8Kz ϟ<>Ǽ;-oAT +�ϓom;wȖ} Hg>SUhyR�f/n[ܫkcF84Ko\ HWYc7WX+�բ_p]C] H77]oyR�,aoOLTٱZ~'CS(�]epǷ 2e2 \r;{T *�O{?5c}Ϥ]�}: endstream endobj 301 0 obj <</Filter[/FlateDecode]/Length 1461>>stream +HkLSg +nL$1Q>h"qXĠl&DiwQA@KhŻÈkÖlYm=Yz nP'}mb�y|%=4 X?,ްwC X⽖�� 0$ vs<iSbi�w -yD@)��"|VV;nS�ow  ��)z3z]x/p ��6-ǿoGv}{Â6�o{>׬56KMA��X*KP9Nj?o +��Òquss Ew~k3RxS?��dsEq6sV0t:*'+hr�CMIu[Tj?o +�� +ViMqSUN0T\];RUI",1LGci +|%?��U JG9lM`=n]=KCm{nfl rM>dS㔊Mk*23&gK:��ڔ1$Z-/jt7o Ykc?_.5S2f,i2fn2?��S䥽a2Wl<RVi5=@Z;{̥R1m[C\WP@@߁:��4r|BWq׺o�Y0ɩRs1ZYQ\MYC4Ա/:��Ȣ׉oNG}aKf;\cg&W\j~?9t}vKI<S=t0R![&HC��2,i.8{Im9ǓkK~�x;Ð b@u/ {XuA w;��0&Fݦ9+=( d؇UyR3x:3;A�8L ;hfO5w[G|ތ0��DHm7AK{ � M<S^5[jV?Og̈$ai@3-bP9u0:RU=/^5��-h'[]v-Kb�uf3!_= [*G;}aJ_Ӧ=(KiA��z/#j9tѪ;!`Ő],|o|{",@=t9��F憍]xqUIRs5vs=35N 73y*僠��I2Ǣ],0]|&S,ʧ#^5^j&?f9}j=ghk2s]V}F(gTG�.r endstream endobj 302 0 obj <</Filter[/FlateDecode]/Length 1045>>stream +HoLUur3zPgZ9nͱhh4 *SхHMB {`E7GntqV?,Yg{=;?gh^�pG_{.o7YV;L[eލw̿ $ck ��W󔤋;k5*n["f+AT +�fU.7hdFzlӕQ)�@"yim=1=^\&~3.b[J9AT +�hRJ3Ě֭aC3筬9{rߑq{W}-}~SD?��y}w,:$O`w8fySD?��,8M-.Kp1RUљ'O#)ņ|Ǟ?Ja��T0s"^e豏菁<JZқq}{5ױR��m^1߶plT,v5�@5t26K-gB-v{ycD?��*[U;w|p[`Aє .?Ja��Tܣn5;gߜ& +[,8ͱR��7lho>׃dߝH^/�MoM2vqC?R��I.Ncj'&Ddͪ\w(Bdm~SYQ)�[Y)6; +&#fG43U- +97>O"^WD?��nX]ݡ{8v>x`qv9ԆuAT +�tQRALK{rߦPߙc[Pg~?Ja��/=)jƁ_N~BmcݻB%��@HX;7\|w*NAT +���T2u( endstream endobj 303 0 obj <</Filter[/FlateDecode]/Length 1069>>stream +HOUusg]ֆkm-YFf+-VR K2I"t"UKK&Yl12YkfŁ?e]Ϟn̏[ +{'æoW:MbSGz][xlY躲"}FHǾco� =X5<n<(YN4jD7 *�?K-X9O G.|͓-"  +VAT +�oi3ZyWuCvEr x AT +�뷺 eWX$H +HtoR��7Ҝ_ '#/<^/"?n��=ڡ`k |_~EދD7 *�@lԕ,1{|,C<m{w[$>Oz?��s[j3$长IvEbKծ��H&P~c7\$>C,��#`\~o2׾ٖɑwX,CUenAT +�l׳ZEw~oiٝ2]nAT +�xڙ9}6ﾐ˓--wnAT +�Y|\ç /ai?+ݽ^~FشonD?��yQ oِ^]׻unr4Mt/R��ȳ[{G.n߉?s#dND?��+h>2΋Wňsc]Ea�� 1<ZrX~ǭ1U)=lm3EtR��$Ӷ~A)?6赡=c1a'n[ Q)��ϝofi]=\f]mg3!Q)��swBzꏡ&Us;c2rw * �7&yl endstream endobj 304 0 obj <</Filter[/FlateDecode]/Length 2057>>stream +H{PSWb]Wֵ(:2:"UE^VPL(!MHPG>emm-ή]fhI[=sM��NeWtqN}ngԜhC>i~xiF@bC,r R(T/B_��ETA.!W. +?oszˉ(W*��/=r"Fp=kH}4BQvJ��0|*b=|GGT-t/ ޥaw?PT���S<&&0q?_NYM_fw?PT���S[@z& ̩oZt][._/|o dݱc1ʕ +��5<7#E/>`=kSr(g _cfVeҪo2YNV{s?���\:@п/ g~סcv(g,>Z8Ϥ+S|wyTM=5؛��ZeDPՑSיӅAw&=sz"˖vk[O7ΝlXښ��SǍf_;#x={n/7r3Grƒ֌3⪵fbk��kK wZ\pW31@QVU!+sK^6-]0g.5{ jw|Ick��{Eh$IN3ԣo)tztv(g>o!}gW/{s?���KT/QM.bOowW,5 V5C@MFxyMKNkkm6GID2Ȇ?ۼ�� v*ur>WM/ ߏsuFz!wd ?{b(җ;QgVl] ��}1oU^RWˎ+5mZGz5}S;<#u'͇+#Ǟm~$<73xkS3$B��~3ҟ[8vGk~f{sw`55}Y|pZklOF49zxAjZ gwHHl(%���U^-8˩aX6M]+z+M Ӑ?PV&\ѩQ}x߸A.21oGdEw]jF=%5\m H{นu4 :̩o7*WxN:~TjXɵIA"zh듛Lt{~yIG_iv %5~5ԟg,-Aa��0u$ѣ]"7]g{2]62LGkrUԴw|SdX$ +5oNšWI/ލf?IYkP4n;UBD,@F48ҫKL-G۬W5xgt̍EVX45)Z|_Evq$cu䤩ՠlg.<lDcHcd>;nP4Sqk9JL۸<?'��S;C|Mi1뮦GG(ow(geQFI^Fu[2*eҝqLV%CibIMt(엱=(\\W\癑k(M=ksty.Sō3)Z#s|Gf2‡k$?w^;;6Orrܪt-k=/��S߬R1 +-!tJ>ѩ+dO:Z+dzI_L[ҒDrw>wy,呰Czij9J5͜;ˏ>'Zg_3Mr'7?ARL_=GIcV4BY= �\�z endstream endobj 305 0 obj <</Filter[/FlateDecode]/Length 2715>>stream +H{PT/1F֢4jTd|y)<lx >ݻ܅K,`F*LZŠ8mg2Ysf>3~]|c#& c`Ix M^L.R[wDCtR^V]Qo9@C{ ~{h}q;\24[6k4|0x=y=+Sh[Vd1\(cJ^*oQ1ys ƲnBJdŒ͏&6p~hn FQ7ԹsL5 pujT~ +=rg=k7&yÚȓ"_*A_xǭ$ꏖvP.!U/3fCamE0[Qɜ?d })QB<VL楇=ONkkF}Nnd_XED=}Nl msYjQ4L7s='[rPgfpn5RTE 4 O2ÉzzE/+6U$?d? 7=XxMl%ěxմFum1ƚ]L %BOwU]j%?a{GjP;PW&w HO{pϿl@=[Q\AHyaO=hS[&V2bl*M)WEYFZnO|РUj3GI/o>BAS"Rw9?E\/p(O +cơuV ?͚Vnjd1\(cvTޢ,cE@eyFڻ$;9XmWlixp~! cnrvWE{W`P<W'V_h|2( X+ 5KswH4 RKsfE׮+VwIN߂5P$nP뜡?V;8PM7j__ ]<c(swQCu4x?vfd-4>ǁЋuc> ,vX"dkhֵyUos7:{{UT̔ i3ű#1礆fG^sÈUd/M6-{Φ?~c`fU+ AA`V\ Z4Q9^9y2s[MQɜ?Vtylwmȓ"_AEꫠ5Vuݾ:lcj<ch<c&o4/|KժY;YHɓ` mq^7Ws8~.4Z +|c8oU\s(?6 +7+?IԄhN/Tޟ#k> m6'zhŵy#^6?d@$3C_> +Zw,ed%-_%xWLMfZ;eUeQD3f4P{KR/7Y[>%9:鳾8a|g|LG_)QB.f jc2É|�1%OAAq+xl߯u*y?By̙AAb6Ң㳏e=L皿N'L`4>AAQ16Wmo{[\qS:y :3v?d?Aq&ӄDz8o}@�7r_V3h|2 pA`A֝>B)~{MLnZ g_Z+h|2 p /|,e2 +^8>ЃBN?d?A9!qs}$5ׯ}Ź>mi }#mk}P\ULI\Kfjdl<d%{p{k u*o10cԟZs" AHYJMON9N-=،CXO#4=b\h=\yQ\y:;2-1;58K6WM k0)~5+_IrFE\ܾzְWl AɫBMgG1zrTsoVdU[5*ϊ Ύ ,zS|OS ?&^ +y XkOcȔ.x[ɟGޣ۫2g} CODwzh7s~ gz:@㓹(I<Գ'j%?9KCDdI hN=kas}iFѪ?;TM^lQJcA g plŢm8P i Z䵣wMe{HPIމS2u[}Ѱ'\fG 26?ڪQ^z[n{-'Lf&/n,Mt\u*o6kC\-mi(č?Zgr~+6HՕ>.j:fiS+ @Q<G(ŃK1ԯX'\֣ +L< hc �0�* endstream endobj 306 0 obj <</Filter[/FlateDecode]/Length 14285>>stream +HWZL\`9+RB=|b)T"LIfL&?X +kk瓵e+-'r!UͲlOU*M|XIz!ڗTuY(V*󠖛T}Ḣ<GB 8R͝co4'Jה^>Y ^bQ蛈ۣk]KUL+OUƪRj_a>l4\2$ÿ W*~i@X(M{u6UdTllT+3/dxjNo_} GTeFnd؛4`3@PO5`7X�sB{VƣTXB?E|>%b m7@!EWxc8Q7ISf0LwI`lr (cZX-�K(wu7dΌZ^\\9<Qiyp+9ӝ$gUͮgoB%(( ^lM:QC׼U.b'{]xC8xQ-݆]&&6$vtKBd|tї97F2Hfxt)3Fm4XPv;r}YKf̍JB+BUKUk@>Gշ7剎s0ozыfR]2d_I_v,tٿr=vx#SUM,-ƨ/ giZUYc?`8f?9fTrr:c}N~GHBN v̍lPg޻eaRn5O(ޟңf(\!0`I(Xd ~ +:|~R4Fl5݆3bsE + +śտua\շ}{Wrn= ǀl/�N=gFS'ڟ>edd8ݹ-N~324k!WGǑXb?MaڍK,ܷܖ *M GGMLFAzO5BAXK ǑM{d<PF%H^dmFL<It2;֥4Շh!sTd92 ~y#= yl<fߙbb~Gܧ-0emC +?lb<7Յɦ8:ѥWY{_7Rk妶W]d}deϩY8 ݚj-R}+żqr.~i@$A{ T<}O +O-zO'v ';KW'0 {wxҳ]2vSu<&P`,ִMrָfYӄ۶7d"],Oҟ|IJVaA~b)S4d В?fMٿiCnc] 7bFT.}:Ԝ"AZ+y%1$+S}g[Z&f:Mΐ&l(c[;|ʯmanm-_G/b%"9k1ý%gzW06Zw +t 鴗63)gLg!ok0KC},1:ٯh3e(׸C)}i{.*ꮾӭDf!dTIhtfė-f::å{;W*Ȭ_:'ɂby@38t ucw6-[ʚA;^<c6PD;(c:M'غ?qw U;L`$ w{^P U.Oc>O\vw=|y{: @=Dn<I6+.+aܼ4_,INϊއ${u=;ӭ$ \@@r+,봎)d<X<ȼMSPJPGvUOm~;ew[ 3wR~<-SQ%DGK$'OEQT];0O[LE8R' .Her=ּ_\z6c8t1# (((D\ΆBƜ-gFK)FZ-4w~ v 7bFTRr49ECؑS@*X;iwcU^6E~ͩ8%;1<R @yw2F&rz#r Bu4$S@�:4`]}EOPZ9c#v:)wCcs�W伯uOXc{U6c_WMr?D^‰!rlTDbXzL`C[-D8#i>\tf,UW VZZY9(88 +\,{ @9zܚ ɗCqڲ%qWrpȥw7?%nms + 6q>2\ڇ27-6o688oi%4 _b +T4̀]T.I~*q]-"ZKuWwZW)Zo$C$eG ku#&X!{TA~OJऽ/ ⍡%Qe9WRv:{4ԜOv=emhW!̣  EQZ>Y#SiH +1& 'kQr8̷{ѵњ zxV|p>�%+<qrHScJ2f)F_:%fa;JsdL2qjd&N  |w+[MþdЖ,f/xAIusGpկ X .Qb8o7W}>yr佒U3YTOÅ??H9ͤ!IŒY}44IX8s#63-2@Jt R!캌Sxrl7+a 3Vn{_qWZyϻ`#2:bfdwa Jz úu0Q4dvQ�&?^(̍Ƌk�<n$X]8ڡ{]WVWi^k+A x $lDEH, Q^ v7ILTթS$#Zc>'ksxz{u�*.o6R4V Fժr=>^F aQS.2`~z7U.~5wz-O^˴^G<+WEKg:>i +ˏ'7Ld.+<جVO|AYƁ ++듛Rm* w,?]_PGD`wk9-Ӱ:0fջ Ԩ(D뾰=jө( +պ\[ڤL`9jp uZNW&pZfHwZПN9sͪ;S:NM[fv\=iLx#و(ح6~Y}^°eYS+JrNIR.߱N*\&f.}W{RO 9Q""G</T8B&C م]%vy6HRySk!q*,8IJg>-(\X(Y;XQxQ!m@!d/&?RhR\#~sw%^*_S(F[<Ƹ`S n 34.1=�A ŕ7SK(ԪrVr +D] L΋)E3+:; F<:xht%T7(S#mX{~x^jqy_21\&-0}9F~QOXӫ'ωr:r>$ZӗpW&L;-J_F`4%,�1R-H+'KB!}WZ+.  0*C\h TgAk}~-ykr`is(Aˍ/VJ8qөsʠi2-Ct|bb1Sٍ CغWN7(V"d;kuj&t �N f|A5 �/>cn&1)}cZܝmctG}O`Bk"2UgL=W,=+4 j)we;t0\5xzp800yQKPEBK j=�]^;FƕtIwJrRϰc u\``;e@%;)EɹL߾‚cA!Rƽ~툓"¯=p/L_)Q&bET[k"GNw#<^2J\wk/-8OKo6$\8%g G,2ܖOZ ')h )#aFVZ[ E[+%Ζ[ch%L"Y0.NqK@to=8Ôn +uݲgw9u/DHns^ܞhtMJnS;+r?=FB*T\N][BGkG+wexy+2[@CtpdW rdUdr:VZ9wޕߨhC?ӭT5e)%*[oBc{npߞ=6�CHVj9q$hXOX- ;K^pJ4ef vNl>tJI@e*scCPѠ=$=DD<a|R9mF:^!(Dnb0}>LDAdW" ջJbTgã-Q�g4;]\Wie۳vޤAh]I+㹢ٕVնs}4Pʟ09Ⱦ~߃XKGǓ1|!1(Bʀݕ2| 'Ǘǘc jڍ/!ĔҮv0j <-? + !Hڛ'1)󮴌n_2;a_)]H +^|j{8rezńeNGvg#v>LeKYo'd~$,-kGƢiV2ElPwa+$0 i a]Z ^)d }w Kb>!1 ^c�wdD-f +KR,痤mʩv xZ>$J{׻TR}ߕ 6m0a80v\0MOr zZf/ 'k%"5;�Jb3I 7c^bJwl_h,Ύ*;4S5d>u[I@ΕUˌ1r#sɀ٧ (z( ]1ݟ-ҙQ|xLwCxm݆j'ֻ|Kuu0T9n9$$<�'5>QU;LY(hEKvuҬOJ\fʃjU9j3.8'cnj6e8- +~T2\25 L$T@] Qq:Euŕ49=cէP; /iӬ>1h16Zz xTN45Z)z_pAﳝ\N^5O9/WD9W]e~g̾{(Ⱈ,-wM):_ dtyjE<zyhɫo7%#U)OT]zԼ!NfU_A! /{'CQ Bh]o Bl!T& +'bs0XPitR b3$_?i}og(+k~>ݔyBQ&ϛZÖMWʰ0ʉA!U}AJ^o1h.x;#oVRI#5=L a39fj\J_kVհ@3Ci$yzEWgRgbJ PPAvP"xt/]2IrrrԽj@�1labߩRC4[;hX@lk8,S>ΘF0iSӲS{cJ4'e9(eRƤsZ2 &𢠓\7ߌ` ikY\$G XiԿjצU1u.K1QX/y dtYΫ65 *e7adq "fr/>gM.tbFyP�O)<Q@y`>>'J,,v1b`gIO1T9w?%޳!fa3k%_0S +b|Q;,<?U x`bIx0 > m+Lۺ5 ]n:�#xQ0&jBٲ@iUX&m鰰�y&Eʹ9oNvO:ZDly^)qx:}/p'~ٍ% p2aLE1[\Y&?QSvgUOyn5E9u(Gj%y;qav?n#fPZ~e;% 8.As(qZ26u rPupIm1NI.澓Sn"%cSiS +DǴmr[Wmr%{sq[nA[.h!;+BkMAj9x l"d UR KױЯ%4]|Yt*#/BrTU rn^M\j̃rХ {q &y:0ǰ(20gxt,=dغv@!۳f޴ +v*)j'م|?8M/Jܷ}Ed)l&_IO ֘)8vP#$gJ/+|:) bߩ\n}$i!dC`Ėx љto25iKȑVQw+)8-ǙDsRͤ01-jo̢[hյ1hxޝVcm~\cp k.01G;\Q9 +y{ug;nܭB3!22fZaO3f(aTqu4U +t d3.SF(?OP‹*YJ€F%);)&SBĻkVvr@M�"\a f뼞I<W@^Eډ ElGN*z֐7 6䍉ie޴JWچK"PkjBE) krGzkC`64oCu[/qwB+0{;>JB米0ަۆi*�cc\PJ:g|Icˋx*Mtw6`j.Opl;ϝ^6Pt;cNz:7@.Tcӽ%M<iU;Za\uCi7k/}a dc0niCx7?m,byL)fF([m(l&S2qyytDL.xq͖{W#&o yWcBxl<+ qXvCgDH.XCH@q|Q\`pqؑ*KySQu( +g,'  31de1l4쇃A]8TAxxvh}Ը7 +r:׵JpwNM˘vV<V.,դ�^qfmHiGѦ X"yoD[;%J,#JK7sKhF%7؏0UڿPL/ӹ�~M +dj?l4ȋT"vٮfbKZؕvi[ܧ6z| '>nS~^Eތ/6'TPi}T(zYdO0T-kmk*bVl5n ]>wl:,s#daO #r^VW^�>Q5ܾ=˩?k=L82r[h5B`p!!H`c,)Ͻ\{TB|!9'li�B_:y?g�q[H6XRY-B딴B{4h\,|se!ro+Ks_7 +n~UN ؾsρr[K3`gQ͒HpQZEu||zG;`O`,W!p6' wI%(G�o" Ppk&&@)6ڂa%0[cw1Pk:_7iaE9 +EJU)Á7QÃit#G/>ꃺv^x^<X_܇e$O{QeU_oڣNue=FG{j�ƅ|�|)D4� +ܫ J( ^B_?�: @9Pn�tFfH`$|ۋFs�|$XfaL�3e}Su9aHQmD|+.YȳT 7.3JZBa~ȩz^8p@S6fqTJR3fzq>E0W> o' %RY#! +4b_ LVyc+!+OREJ>5^ZO{%'!@YIրl" (0 *?|!Kus뗹YU}B&]cCgwCc6;I.Fu`nV;DVv_]֩{>"Eq_6{|8hNViu &o(졊s(lG)Pk^)GKxT^E*YnenG;?u^|…vv-)X 7u<HF &0 `|gaY4eLǓvaxp5˶*Qw9wq'UB%&An <^|v'G+hC$'z)D IRM"UͬxyNḻM(D;xRfWF\mD{&d7R4w<G9h|~T0M?I%H]~qP ?SFC5h(74u4X{֊,P WՐt|2{,r+'4 4XQiq'Czp7rּQMѐr9O�C�>PIm@^ɲZ8%qW:EC|Od9@nfvw;nj 1A$KMU'z(WwmY9 ۱aC7=_>%Z;$qgŭ\ޯyxOqZ Vy^ EuO)'䋈[!fdt cۤ}JjdLJqoWH/WOO%Ǘu }Qo;mf~#J""Zô mp{uez3/܉x.Sf6/pj"cA (q:,Lb gTAu\/mp/ !xg6@ XVeF �w6XT^>Dk 7h@u&RD}T"9?ɁLJmKC} 雧a9;8xYN؆i3H �&b8%ϜXJ{" v~UMM}69ǘrL<Dhc~1�hnކ/z8+tlC<s)?6nC:+qGv6D/ةs(<gXe#SHu,Ցfar Nׁ@ 7u"t oq mvf~.aNz [FlCʴ4=9/=z(*(\+n2 VŌ@C|Z XPUZ8 OBɴ+kRIVX[ݗ#eV +; ۲K*گՓ_%~ +n2bJ,iiX% cƆo+@3hJ`6ૡy.}bCp[o#3$4|+˝l5+Md˂\jӜ4IТ8;K%U"( &Akw̷8omxj..A[脰jn¹-8q\I2|W*< +jlI ԧQs,=pJ"1�2ݸ)x-.!VɦEƟ$64)xϕ@J+&T\k1$pR%i/3iYT/@C 6$=Ӝ3b#P$R!y@Mf^־R_3BUho<b=/W5l[\u})K�9Y昩d3[X v+T7dJ'IOs{k9Y<7o{|+q)f=~l�pR ;UbJ�fI$jTo21 ֣x;"3>*j ̢(7AA 14[L&lpd4d[mv]iF=gVQ. bjW.@9Be>y}*TMEOQG\*L VTP_g{Ņy}S\ž"o[(/˩"ty}S\vy<%Ա5]IiW^\w^><D$` +)|- 4hx`%Bu)ʲ+ѶteW|L]ERM8/>w\}pPa + i<%:`$mGiPظ2j6Ө*Zgͮ  +4RBNY%pD" ѭ&HUzZ>y;G1ժ*m]�bve{,W/˃kr4\0[;uPWFG _ 1}n*ZTe.ehҭԁBB&@ ʌ2u}Uu:IsVwUڅG#WVy&F'mi\my|oFі?rԄ\y +n~ܻw#`g\БY4!OG,,&,>v1hPCSp?FWNJ"(u%LwleyAB2ZZSRHj5Q>ܥ.(gd]a&n!O}x<TȽ%E +á.8R{oD�l]t!ѷ=D^u=_y"ߗ۱eMY)p{ &.iȌ#W>˨'A` mefDb)%+~H޳b2@lxcZ7?(A,n +~@fV+ xX9<` y(kl'9 N7~.%\O9 uUШ +Tm.`m :q1Ȗ Qn;# ïhܴ\J_=rjs}ӭjYld;x ?̼:qwM;nqq#O*w- nQRB5QK++$MUmZ ѧe[O@yn<.wix'YР?Sӌ.f!;e.c9Q4KɗO+U޴Enǥ1eCyN6%9 kj;O8C~yk=ci=?}kĴbu2T&!HVSwv:18nv]Hakx +乒`b{ȸ&"XiY5)0HhȚعnPnid)# + +&rEf"wC+ j�S i6E"\>CUQ1'kcG{`fUA) +5뻔jhd/i G_pX%5}yzYl6)SVj.l?{m==W__R+#!m>]93 +t'SR8HehqQ:k$ڣK:罵 ϯ%PTtمᬏ²ivP٩$x$wͷCVn* Q>v7).2wW]LK{ymYj$>RM+Vݻ\:hKs]ZD \:vqFC +u.T%osedppX~WPEfI"P+} >J sA2330 9e:SYbڿ)cj)5>3;C=BLX[>{^ gz=$kR>y$Dld։@ &'[?I6Av*ld4iwǞVv!1& 8sT(p<~<rhG2r iϼg ;^W1lKeu-g2ͫdPàN&m++J'PWz' dB&�Nc,H\.#^*\ei`eƦJf1 0=0M14휙1|^eÇzF.d)Bpzdd4VzpkӄK^;~G0$6pqk11hjI )"v +{btn} S`^jqDu6f˳Rr|2 b140!�]̱  "kX%KPkxKf>]}2 躡lAJ1ƠCr!t$Vd ljDkf0HSEmI I=o\PᑤT<%$2 "KR ~g԰n:Xqd¨Uð`zҙQO K˷zԪ̜-C_nJ=FRV'<s61ud[|Z eW\mUu0o@vDJqߩx\T]kǏq1F{uEh]8v(-MSAVgУroٰ,^Kq$,xk  l2{yh·QL!`<ҷ1/AasMvo YJtpS5C7\,xPzpztk)we6al8Pw"t6+ĵ Cepw#Nvܴ346<y�+n %yTA]h = ƀpLA@ @S5 6؎�Z А� \hg+҃xml.+>2MpmAAP + V=´P/էSK攋dLu_DC{VN#bFV3l4ز8օkbw:طJl5'5zq +!Z Qp/ <Ǡ%=Éˊ80zO:-؊?kj@I}Er` H 8?cʼnN8f;F�P2Bs/x]ADTTw `Tj� -Dx +t7 R%@�S endstream endobj 307 0 obj <</Filter[/FlateDecode]/Length 2945>>stream +H{TSNj+Ƕvөus TTjeT 0" +DaxIȃ$7 &7I2l+jZm*ڳv;_5xf!||{|~?cˋ^U|S%"IW84ꃡ=uH6weKk7vR ccȏcdualHs*^sו>Up-gt U^ +ʸ2ZgsuH閌.rj7S{®)}-[r4}c.Cbejkkr{Uҗ^]Zִ?ߪ 9ܜe y j;j>9j馬wv+q욯:h4.ZvNj#\&92$sl-Ea"]RZ g"oA luwlE{GAFOu1Чoh1-%UB*bNS'sҾ돷Te@g#j]noK@np+,w,E'elVz5ЗV;V́yĆpn^2uS3+sB1z57yp onyn^)]潞:77@nCyo6ó7x_UV?u;%п?A$𙖺i˖7庭EI&? ě=|XV'cG@.2#=q!k{eviuHj8+%JejwS;15g<^/4,oM~)?ɛ<w=56Dxs#mᯩqdv7زQഓW! ㇗c@sΡr)qGq};cbCe87FYdi.z?GДc&,0 Kqudi5p]9[8i8,En4ڪǮx>$ S?8e!jZ~(*#WW{{&Ĭغ8a:|> N~}QRb%[׳s#"cZJ8nͯ/O? +\ր^|\aKeFH)@Hj8}oq/\TYvyyju!f̀ʐpc:)gHu=s}> k?8<8DU?\8ܼHvuiz7(?Wtnsп?Ad|2+m=cG߬^Oog qC]4|�$ev ˊƹ&&xGU}8w|�$Ve{4) +|E1 VwS;Ekw6h\v2W5BAm&mu)Ϝ3F˾S-.#Ϲ?0)?Jhz\~];i\72CgGYgXpܫ8/y +`31Ys| 9o\#O?|/!1s*M@HU7<cM=DڲBAԔD=/& |Lϙ?0)?v΁~tY^ܰ|LӔ."]Smd'EހklO>Z2-2֬sɫZӗ�dZttNbKQcFOc};rnqhU( ? 3/k3'V&ZVNo7Aa~f!5>tsIB;+匮`SnDl y,ps{R1V\\u+0~Ϳ"gܡU0v +~vh˰qɛ5e{ Ж/MRI_ t[E yV5Xa2?FKM.#źڵ)2LK 6̮+ +CA Sڜ3=wg »1$c#"B>&eKlhjLkAAPZ"]W Җ/Y*;tW+GTA8w~[ԫ>D#|rKH ] 21XrV@sީ4/|0\+UbFT f'o=ڬBׄ  Og|svЃS/F0D%Gc;hcFAAd옝AH̊ [k_:G?/V`  &5w?zX##AANHj8*^I7{)'Fq j##AAcA8 YhhթMpMql)ZA +A%GmApmq Ӛ"C3o<7.2=\+]i��gBժ?y|)6ܚ=i��WK)tfyiV4e֧r t��=ADZԵ߷!_Ѫ i��l񀈞{f77Zш|šW}4�7�W endstream endobj 308 0 obj <</Filter[/FlateDecode]/Length 1301>>stream +H[leߵp3AG`F6p2eqB"`dL8! لW̠$Y`*8*7&rwo[>Od~!k9¼#HEc@zM!|k=7 ߟ>Y�v=YHO#"""gW44=K.^u/^%Y~&7abMS.M_-ӶP_譸?*\^&#ռUS_>q1?1 _VكZFrqWyzamYW4X1=k?  """>J擇5EM{nPVsjfW4YɱɢzKEVT|³YAɰ +Wrív\۹}d +:}RQIXW?~΃cYe.ӳŜ2>o?qZ +9XNJr썥6=Tt[j"""7~]Xn>GSl%o3deVk- $?b_V? rμYA Ď70g@jq9~cحڊ=)%@3ƻ)JXk DP#lMy݉?7 ۩5T}.غرH1RgƱj5g]u;]s B叜 s55lk?\Дܚr׋:3 5F8[Yk٧? ܄\kfX{j ?|J,]#uFj%Ov:}_i &QC*\8N͘2-`ê ;?pG BcP`8u_0'k7^ޞ415`~˵f,p`s}^`Ukj3 5F_g٧~m^ ƊK`6?r2٦(~qWg[K}s3"""">ʾ \cGSoVoH`Nq_evuHL L1=}2"""">b>MkoDկvg rNY:&�����bnؐ4/fLK=Neƪ]�����F2s:ws2/wR;۹}dı�����������������/� endstream endobj 309 0 obj <</Filter[/FlateDecode]/Length 2249>>stream +HSSD/E@+^e@,*^VqKY"!דrvt:Gsx"99o1!8V+Vujw (P`WJKY4i .R2Fѐj*͞9C.65\O3 +sٟ,jKE:Eƞ)6z1Vwd ?w4ߓũ/2._ѺѮ1>u޺L߄7s+i͇ۖe:5굾|˫ˣges ϯh牚;_\̆ak$o f3:3{rBң[{Z~;o|Tw\lсL8):ҹ{7}(YtvqfwaE筦34ivCޅy,\OG²&I_tkN}mƺ/L={&p^6 + +퇌W$ŭȱ�GB&cL~C96DZ9!5+VW4^(shsؑI7YLz\p{[[UцOϠ:wU_mmj,ݺTy@bjS! .+L8#1jhjkB{yS1țNol8tn6W{Ӎk32)k2ڏW-YʤW"Ǿ#86d<iEG 5,6dԧۓioNqǰ`LTDg > 6h5=v(a-ƿZ4tC\‚Yt:r,@8ߐwh6T\L{i1>A:+m{]-۵.*%G1d3ylk֔퀌֦Ri +e8Js8w D=>wԪr%՞2{#{QFAsb Q!cQ'o5#4(X|iȦDw雰G- Yǵ꽅la om, c%LsC]]9?BNwǸ`zLT|K=+m;WJKq»YdC6?Z+m;,bۓtz&cN,7d΢ߝ?:)uqNk*R4Y`!M}=#c%vTھB-k%9;cўg;jU@=EL0</4l{'FݶGAsbM2-?2S(M Njv5Ԧjװ1fÉ>(mߞ,kS1,&abقOh* ZM]7J�֣kkb"^ {(KE"c/d"!CDz<yLE[ 6'Ygt?Z/tk0|xGjU d >Zu:A'*CiN,t ꫻Ǝ;֦R׌J!ΖC6ӤUA|ZƉسmY]?sԞ=hz<j2c7kk2mtйָ=h =w ݛKusGzIvҁ[3_WܵWAƞ+<$ĩc5i\.!cmtf-[Y%b_*gfqTি�&c̙Nm,zLG2_QPʕ_QAϛ=4<lB}mM=5_0|gwHqx}][ñ}Vw\,j=g^sљXvĉp:3t)?臌MUoGnl[br&Ԛ/*"ά'LYsP_Q\z<+~r!g4Wc"F!c%raw~v:5y`lsxWyV(,OiVUn  qa2l2Qt틌=]1fqa]A'R1)N}hkoO`]^|7}S +Fo㳼C +lU%4y_DG,pꋌ���������������������������������������������'W�\ endstream endobj 310 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 311 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 312 0 obj <</Filter[/FlateDecode]/Length 459>>stream +Hj1�}N鏊.EsB&2n�������������;Ɨ)}Ӏc0 +_1`ɰVY[ `cY]|'7=M>.q)òO}\S<>޻r_NJ]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصQ MRj,Ū abYMf)6>شbf]+fصbf]+fصbf]+fصԤыNLd,ŒKv\NKc,Ŏ3ÓR}0Kbصbf]+fص}q 'xV|_׉b׊i*vb׊i*vPQCtmuf̗ڰ{tC�Q) endstream endobj 313 0 obj <</Filter[/FlateDecode]/Length 571>>stream +H[jQQҝD"ww%k@jqeq 3DZ|}i>8Eۿ~PfhfԚ?X+vΣI+fSV+샕bj0R,>X)fKV+a}R >X)fCVH3`ؙ}R>X)vf;; bfJ13`}R>Ifv샑deH2`$Y}006#샑ddH2@H6f$F#샑dcL>I&f$F#a#Y}0,>IfD +߂}0)~  Z*0`,}0V +/oJxh{t/9tЯ9*t8KdtGQ+TtHuUzy븪fAOw }"<\B3ѻ+h>Wrf9/w&k>rf6#x*jF>zrf3o#x-i>zrf0#x0'i>' �j endstream endobj 314 0 obj <</Filter[/FlateDecode]/Length 867>>stream +HR@DQ +IL{>o<ݝx{{ێcmOgW +ClJ~Ӝ=)c&U!|zrn?|oIΎ1ِ?8Qg=C8,G~-!Ctsi?|fZtpY#9+ѹiDg#ZC8C~pe~I͒AǁnZNT~+XFc\ in#۱o2m4}8֏0iNPSޯ0iH;P0iB/mp1JOY <uN r==,H*bqigO~0 +X㢟4&5vh&M<ݴ= pp%]$.r[b? =<hFq]?G=4~l_.G zhF~)xd.'4 7hB'$vwS<t6dب3ϻ扰qgw7Z&v12N-txl׬Ԅc{FG"[1=:>zuThNqu1::̅Y'DdZc]u.hNv%֑�:UXǁ*`ڛkFYg6)e,:yև56:Q7 MX]Et>-E|Eס}hZ mA<Cף=hStMM=^Fe/Ѱc?8/r:G7gT mB.t꽞AS tޭtW8gamgcUAӉu۝$Bp;w\ ] /� endstream endobj 315 0 obj <</Filter[/FlateDecode]/Length 622>>stream +HAjAQm, 1C@L[7$ 7PQsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT/E׊ ZXa?q /~^J % |åLO>)I0S3e~*9VtO%NJ7ЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT}^Jc҃Eå`QA?x)W\9K~J~ ^]qd#;OpVn|o�6L endstream endobj 316 0 obj <</Filter[/FlateDecode]/Length 601>>stream +HjAPO ; +A:] +b?Vn_s)=XT迃,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~\aÿs+`QWSocEMy*9Vt_9}Nqb+DžO#r\>Ba +'8]+6lwKٹ"`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F.� endstream endobj 317 0 obj <</Filter[/FlateDecode]/Length 1468>>stream +HYWHys"!J¾!, j c#(aze>܄uϼRZn(HJVpk˨܍O_̠i܆5<g}q4*^#=ќlV�d H4DPn͟{5hŎZWI:$m^*f8hrfJiN4IkQYᩦtM5c-rV2bĮgHR\ F Q~)g_{[?I;"̫r6W;HoˊMUeSMn5֣?Ny0Y8x}V(\~疓,H9:1s3ohM5oO2¶Y5?;jܙiTPCtn/ +s,kݏ5ܪ^UϷz}GoDgrH+M8OF?zbsIcM M8j6>vƧNoQnBD9yD#\bV4=[Tɖ;N7#Um`.ŎL]c856_QvD"yJV+g~T6VNSJ!iU j;X֭o( K\k2T~(GH4:oKè yClvrTmۓ-=o[_f5~x*=R{j,^&hdŤ؏4o`o`7r`|@M:/ժznKCmߓr-ys_ F&q5*O );ӄwܛ4NI&t/ N+Qb-DY6jr#y0!ufwl?;zf$iظxCiŘw(5 K˿6hݱ6r�eVcަK%qn>M +Cv^&솿Ŗ.XmtFMz*^:'gtqɽ$HIIoCRtxgfջ=uI'lg5w;zE{4֭oRPNDUKZ,F^_QTztJ3M71>j7ZIL=ޣ$!G+ \,O7SU.J*CCzՕ>a/?5r>JRn;5|^rOG;SU`%6K}%<<JR"zB ?]1ɹR_~ quuS+-) �������������������������������������������������������������������������������������������������������������������������#�;0Xe endstream endobj 318 0 obj <</Filter[/FlateDecode]/Length 594>>stream +HAJ0Q -m4C +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~8]+6lWSɱæye#�;#_:O%NJRtؠtxJ-t\$ߞ_W G>{7-Ǖ_{ny*9VtsE 'B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйw�  endstream endobj 319 0 obj <</Filter[/FlateDecode]/Length 844>>stream +HO@^ސhт{6nfYL̑l s_+QS?}?Pb-$xj ^K^0xE{/M{4WҴ ^K^0xE{H +R+fGR^/dHR"э,u( YmzNqT~(//)l?fh*>͟<22܃ua(E9d +M9���FVɔWT՜sW*TVa"/ܜ4psEnykN\*=zqVN!7p +ίp?QVkOn1f<_lJ4L+˩Bp54CiNT)xhR? +o›Ż~L X~Hj~+%+cf%Kg2wY=ătwʡ4gMVW<¹gK=7gR t:Tp/=g����������������������������������������������Tdway<$vQX9aIW[&:zKt~8&S}w$`-x\GIGi,\|nb~FM;<{oGgWFxrT׫ۛE=WW lűiģ7_O.{6fj[CnN ++)pԶlgگ,�������A +0�⹣3 endstream endobj 320 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 321 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 322 0 obj <</Filter[/FlateDecode]/Length 591>>stream +HKUQS *"L(ɨ6H2 jPf6A eb؋{7ARf͛MjPn!P8ٗ E�����������������������������9(UZ O ~>\<Րw]��@}-g +;Rsak��cYAA~xs.Z��d;dާK\��T*Go^_ew_F=q"?//��y{69:=J}{m^w}��@rȼS]<[* ��HL&*RwD_gjuoQ#(UZ&""""90y-m+? E7O r"""" sKͅw9gY{UNj漷"Se=}w ǢϢ2>9-kan\Q^qzx~}dž^r{M~IޞkAOټFzrfUmN쨹p>/Yo75ם? �G2 endstream endobj 323 0 obj <</Filter[/FlateDecode]/Length 384>>stream +H׽JQЈHN+++�DI)jԤ >`es D2XZ>ؙZN6Rhɸ rOe&ŹF{}=c{puq=7\d\9'2?(>,>Aɸ J\YM=#&29>akD��y>�;F$ �73�@kD��y>�;F$ �73�@kD��y>�;F$ �7T}^j,�DRygm}<,��sIn|/,��sIgvz&8�� ϽN`><�� ϭ^m^O=�ǧ�� endstream endobj 324 0 obj <</Filter[/FlateDecode]/Length 436>>stream +HױKqBPSC-.6(4mi *IK x7!pnA4EޡxKw=|>A<{N?}~32~_{&��n"i睍;_=��7^rH��8ުh��G��(6A$��bD?��M��(6A$D� ?HG9{X��\{v19:|k�G{ zM}>ݫU7g3 �+H:Ǚw.=}$��hDi˥RyX;VV3 �?}^[^~3 �A$tR?t7��HX癩f��-A$�>}(׈B��VŽF � endstream endobj 325 0 obj <</Filter[/FlateDecode]/Length 684>>stream +HOQ !iZTHMD# #unPM  `LKKFugF&&tv4Orv'9���ݛ7F^e_vnUs\<8 NVj^}v[~7}}}}Ї}<M;!.szT+U':(ucz:MAAAj<vQn���ž;a��ƾ;a��ƾ;a��ƾ;a��ƾU5fu1GRa��ƾ[/2s +��.5@p#}}hf&<H���Pd'^fSڼ��@mk=r{jv3��@mk@0T<|Wp.}'���} 22dztɮ3�� kcY~mM͏g���AFަ\>Cu<kR5ܚp3a\K'NPǁ*t��2;YNji䈅Z4tjsfHzqo���X8~48``oQbd|ZEd.��oMj%@`Njޛc>X{��τ|[DJ7Qgo� �[ endstream endobj 326 0 obj <</Filter[/FlateDecode]/Length 609>>stream +H׽oQ�DT"b`6HH FDZME#btRepmsۇj\t Чuۛn"G'9y^po.ݗ.xܴac)Dz{߷~=��s.A,ݡ��0[ǫcto,��fKGǃx9M�lC]VA,*qQw{[4$��<{AJ_ߙ=Ol\z��3?Ģ]ki{Ƶ7�0c}A,*VIX2&��fzR�сXTGs׹ueug�۳0?Eul94/{om>0.��=/Ģ?۞+ɷ[7B�`ڋXT£[sÅYR �i/3i2z��CŏXǡ;m5W�@. l#-Co�`?>bQm˽H$z��&_ϓ�0XJd"6�� sGCա�^/�K endstream endobj 327 0 obj <</Filter[/FlateDecode]/Length 641>>stream +H׿ka�qAQ!lY4:H:.J-Q+ +X!$mXԡMSBUr+BtD_ߡͽ +/w;w>ў[F^x8љ���v%f}w-{��@wjbxiU��;qW? +șK-&{��Ӈ.��uhRT<L��@WNJq`"f4/'Ҳ7��DRCRM|/{#��z(ū?fB˶��AJꏫ��sxG$wͥRGd��QHJ#M^L ��[A*q^-7;��t4;>?ηl���:ϤTK!dDT���zį?M ;Ld:eo��M%?{J#7j6eo�� 8V({+��n^TNZSV���KTNċM���ZWSTNtgoS]�\`� endstream endobj 328 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 329 0 obj <</Filter[/FlateDecode]/Length 1332>>stream +HLu񇃒)EZiJMmNS&ci$Xijh(D1Y#@C<~<wqpw +5ǔ-µZ.67vt{ظ}-�Ž@yvd#/{;CcyNVe)_?]6 ٺy/��@$UK_Z)N{���@8?ҵ$`�� HnI \KN-��DF…12u%Y/{���␨kuHeΦ;eV{���aoW {n`CES(^?vթsK:��@s'u3BMMQ2QV93aÊ))FqY^?>͟閌QQ<��@:l256'iLzv ÔrxΟX\v<���?_kjϔzܟPnZнvOI<��@rIvC !~J{ܟjb, ���"KTKEyε.ȳܒVƚc.(<>��@kev@;b2-ʳ{[oivNVJXtpj +%/JN���]MZlFh6==hpkXy:Tâ|b77%U1!Csc���O(i +Ir~Tug{G||?nXTuK'fW[-Pm߸/]��M G~O[ ǢBe/N7ާkG*Kٳ5 r(|߮N1yo}M[2ޖժpQQ]>YqR{^Iiޖ:X>��@$sKke.P+-Nw,>kO<( +U9,nw +rf$p5sL}w �� t(iyVuPS93\vJ{KM:[XVY6jbh$o^u;${4kyC +��OuJ5<N793ŋ c6;tSUq6L=��wm7=[dM7IfxԤΓyjc}���9G~6[M +0� endstream endobj 330 0 obj <</Filter[/FlateDecode]/Length 1804>>stream +HPu"my%MfubQ"Ǒ@ n]}X$%ut)2̀ũ&+8d%=~ͼ3}072͗ +R<I)SBh$Z7 8w[J|K���2fii+�F?Vzs6C:{Ӷ[s:y}ݤ;gB���!B9-ŐR1țVcwkd`;1t@Ow����7UDpYzb!3S^&U&Vɧ \:u51)&����Y=،/]"?Xc("/yjx`/oܣ6ʉuAmѾN+���*_5{?@*Fb2q3j:r`N+qIa9QW߭vΫ]xBqݾ~7'~>)plZlR9$y*gŪ0e̘!>���ogR(HHBXQf{k;CTȰDY(Wl#!; 3/܄Ff i)?+3cT?p'iv���_++)ɗ;R!" $E3Ǝ&Yz}Nr">btZy3]3|g`^}FxQAw4* 7ŅA!}��� AR#tt +!Pt3{'XCpˈJ"߈ԡ{45(bdlLH4G��� 63?@*?,ycXk81n_ؚGq#iI"oz;ӧ=>&��eg-`sZt) R,6r9AM?Bߡ ,D[fɻa٠}3u!3^c��Hw)c؜R!!dNZ$(ey|ktu(Q{ +Q+Okmdb7W~6)3F2���=}*m؉R2wl�=Aጝ7]έֽ4t=DHMy8 <'o#9pOX$*���0c*S[ g?@JFK~1ih=\y)D=N;VUq@. +3,���aZR;R2;׎Q۸\ٖտ_6DMD}NtH_LL3���W F�)E7Yxcjk!BˉΫQۚ[g4Y*%L+��� +uNB�)CȴMa]]Z} Q;m8txd]a+[.ߕॠE)��!T0m\H Ǐ ۷a,_chߺ3+ BԡD D߼|Oco5;3;o<;+(!}���&W,?@J?7> A^<A.8xcח'{\/ +-Գsw>C}���&9dɫj?@J?QJ͹\szQ5']vݺ6Fq׆ ~ӧ-��ఉ;Vtc((}jpn5|V,ӆ9~*D]qEoҞatZŭ)U ~`�; endstream endobj 331 0 obj <</Filter[/FlateDecode]/Length 1652>>stream +HiLG. +UUFjh B=ꅶ +RPQUEX"CXxZaQ9jԶ1[wHiP<w<D��T[NkyQ@9fZ&w ߱t=cl*oO(I_Lԕ^\Y!(MI̤Rc���PU]O G�1Ah}h]0򿜋.YͿg&D҇Ieڠͩhߊ��(7@׋ +PL N¸Nʿc6D/z~\)1}GCދ;C���eyۻGסY`Az ۻW.EQҮۣ31*VQWnٷgO# ���(TvjB�1Ah[܏l{0A<zqq[r9n:p!%j^Yn0ig0ޞh��:U}20d)͛dɻWI/'z.׳8Zmf!S��w4b~qؽZ\Wj)$ +W{ͩfrS2;~=# +��N9-hgpB�1AhD>G`zMo:g-)4%<5gj6'%)%2ssޣ �� z[?3f + GE%,Ⱥu7.іd.!}= ck2)E2��mf  Gfa,Xu`\Tj7.֔'zntu0*]JbT{��DC*|Rآt|z͠zAhЩ!#9nD ֒U 9"{��z=-,Zh_92ndijXr+ROqKkZ>&d6G��4ꃖ7ڊ?@L?:778gBX|UӾ?zY%@?WD"V:ϼfjM} {��c۴BzU\P',7}S{희D[Ps]]6gg%]}`~G��KsFs6o>ٻVZ[̾Ace{CG$ם.avOn`+?5)lr[���qvFs'E.uWU3;CGEI0cyMHpcg^T,- ۏ���c7h G)ZH el~֍ܻBG'Ǎr$3BJwd.3fL���tnv':Y#E�1Az``u':+ѽ{Il6yEiGwh?̥R��6gUb5{,ښsh^<0 +?N}:w7d'z׽vO.VKTuGfLLx#��v! *];#VP|Qf*F?L:/%DlOzy!hY]M/<QVL%9c��f^cM G�� endstream endobj 332 0 obj <</Filter[/FlateDecode]/Length 2245>>stream +H{PTъcE+i0^^+FQDDX- D,g/gY@ZxAT $'VK2h8f|p;Cm/P5:@{ݖY_C=i].2=wkZT(gpGGtn;wLۃ +^iZJr$ڱcY`o/1��xccwm\Bbsm�S|ڣ0^uU>Z`Na}Gպl_`ȽGxm[e47=a??=��ľ[;6*(/ +Qb\|9&ϗj üI#e#_uG|6͜+YY }��^}:, + BsN?ūzgV=Ըd^pY'DF;݃ +}4�`$-2VG�K139ڏ swXg]F E!E}qBծ><(r8V<waBU��dG?;ū[?وD,v(w y\aYzd0]1d5mO/ ?aD*ێguS*REz׵Әt�`Rgzn9$-1͟-I1㷭YLϚ5Xyt靷V{J?%<?ГKTtUDž�w3Ye}_Kя'��>KT]G�s2v`gTRuщ|{7Nn~>HjWxX#JH\Şi]|��X\i q#sߺui9rue>ԓ% Ӿh柿Lc dY}<|WiK3싈p5ݕE��s%\1WJQ+{>vsggW?,;"^d3{g nHZ =[r|No&fy)"^q:+uQ8O���>6 +Π*QZɉȞ٬cگkDC>j_1·u!DuQDJ>.W<# /^ė��rDZ\P\Sz>w~oLWd:0/ +'~xW3jM ?(W];`KϪ<MұRQ-MG;s [k뾿0�� +E +0W% +B+9 ]#u/.+(Ő{CqΕ5ED-Y:7K;1:IZx&��fRO-edG*ʞϽܻ^uRUi&M$]VF0+F^Q^-<>KTNQUw٬*dI BWN%�� K|IuXR\]c3?ܤc&vv/<O aگmN{]?$ =#oکJ1=as8<+.'=1~7sL紝*.xi~BÆ ��pZ]M,;lNC�s2M?$6"+%9Y^ahUвpXq7btDwZϛ'Ӎ]Uzcin"#ߝ 6y�� tw9N1dqs췧/]tgٴ1+aI΋>˅SL^0Ŧ1 MN+do~BVx��O봎V¾`lD"bݣR?S5J{r 3?"gE}qPqvHgmՑAsԓz坮>SP]/l:t�OJ[sb-6%A@^Iv%y#m�lb,^fvΫu)d7mB_?�� +Uy}? [a^YUQӉBț`QSJ?` n#Zeejʪ蠍v.B�5-b{yz!/핦//5?ʕDYZޭQ}L ۻm93fWԛ��gTe endstream endobj 333 0 obj <</Filter[/FlateDecode]/Length 2181>>stream +H{Tǟ%޵(Zujպ*-ԕ\ +0-DQ0rQPPE(rM! AALL�QjW=ն"aEMzvviU|s<χ��xQ+.:n +̊70%sNY�<5?f3 S(r!?(S^3"_ +ˉDw*]3Fϔ~C"/+!9r]F(zd� iF&ؙ':j'Ũ3Mq_UMt&osm7_4HOw,,L3��ݳE�>Ok‡E&vw3 B Xv7O|#Ņ4xh\GX��^9;>7Ӫյӌ!pԛ{~D_$ n]G;4fSoTʳǾx َ1��k++}Nvߢ?�@gmK)Q2)6*! 'PͰn ^CZS(>+ɔ ͝F��f숑, #Ǝݳ'Y$5l\iSo)a!w uV{g+^z$BIo\H7F(z�0a>[yh0v?�@gQx`Q00NcyXdQK˂eXQ4?l[Ze~Y^Ao\H��癳LOؖݭ'{:tLv_Nf6ԛJt#z?g2kZ-L;kӦ]\iԐ\M��s<2gRٝ�|Rȅ2b*5/?/+z2&DԚ=^U;1&^SxIܨʔVzz$q$z�3d>'S< xu)UQܔMƅ˂eDD͒atWС|DMb`-Ľ.AB/y4jPG,��<A޾v`( |7ز\Q3)eUAߵ{4;2G5uyLD&;#`\MV[8͘IVV\^��ldg@?O?ZJYuFu~ԛ;G?i5KQgnk:IU nKJg񱯆Xus=�GYզ݉�|rJ7%ųQ{8[!U f{MaZt5Q(>Jڝ,\ 9#�B',l$;~cڙ'k}Ķ%zF16ď;X} D͒wFw7&2-Dݪ-S>!t|7h\q��Ir`g=ӮD�>i(S2B7 K_Kf]9^S䶯t5_}&zFuUaNlʒĭ[G/p}}�ĤΗ=L{ocr)'T ?Y贈˔A] \(1vɏ*[N)?$6f5k_ZFS;K\��w<vXot3Ghn +E.9[Q^3M>roBsU 2]M\u+"h%5>e(-4>/y߂}b]j? /y4~߲3w7?�@@suѮO=Vhnͱp}WBJHt!M]B4s5>)˲RdSFG9l\NMLCml^!�>HJǨZ{w" 4wM U8\ a_)%&ctV{n\ea} x5B1&S̞<@?Eyh}j݅'?hэ6K=n_ԛ[-!j"j\.ό;KrDf}O[VK KN ]\M0Y[s��Qz$3Rһ 0� endstream endobj 334 0 obj <</Filter[/FlateDecode]/Length 2888>>stream +HSg?bPO*4XFŋG@QYDbK$r(r 53=3)B <cHxeNu˸[}|otd(ᑆ@$~N uA|1?{Kma�5Hyk V`<f暼dWM|Ӽ}ůCE rwGYZ^+;[&Ȉ.8z*2|Nyf=Wǥ=V#alh"ܬž4;6CuI +D^B]d af P4�n #Z)NNy + 骋*I翷|<?89hmQ_{4rvq_Saphz~GI^nj=m:URʩ'6Dm4o- w>@[c\=M-~3W)l+3<+]vxFt@EVmka?{e+kz R&/(m6A,b@ʽ[)O1[oGt{{=ך/ƼjpiPt@_(nV2, +FڥEk(~Iy/VuKZxohzWǥX<o>fMQ0647E~t֑ h?ڠўؖi])nrIg{KaD" +�"W8�E�Sq_<YEw֥[w%S/RPψn[E|U9ҜTJ~1G_b5]i~̰іaf2zhGL%UxWZ@6AM +\(&˗{E7oMVD"S ݁jo|0p>OYpnmzVnٷYcرNEu2A.^um+dZi^ՙ,c$ɞG"% `qpIfmk%flM1c1LLHދ*|j oH DmtYj`sK<4'O�{ \ōD3}(meӄW p`uGIJr^SZWZڡ◨npiF0sαEiou\-_d L1n,d�7ZFTz߷k?j5z咎쪉yk5DkB@Tyu@s(p>n% ݜ?S3 ٚ=^:[fƯl{T^NoZ<_BB6F$vŊnUT}WjPwM#xg7wY2VVϞJ+Y[|r !nyVL]Zxccv`׀�z\븯tºK>ySawFj9А4_HL|)87oH Dmw H,ykY5D(t$u@~- vwR-u͓bgYa׍oiqn {t0qcTZ"STq"DpT2?:{OP芒Xi^Y1>SUy4'0K&{Lt'ۣQO ;4kc#|}3(tQO7wݮuuq[.;b",͇ݬ٘?umRoM=F[ È!Ca> $C}}hz/ʨkG젾-#A&H?dž!%EeV.zOA7H$~h(Q +�`C#!{p#z2[_,uOwW >﹤GuϦր-AU6F$>8&зk\Lo)͹X:QH-g,-iWw-W2Q(haBZF"(zZKUr + +s\[U ++\cbe(uosUMQvzhQ֩y֩`yfZ k1+H3wK3f-#팢3}vA A4u7T ޵:F|lH$o7o-PH6W@bP (  @R.z n$v9~Yʟwp4ÇF&OmLvuTE]XQԅ$DF2[&n1q/j-J^dtQY!j6vD<Y]tuYbǻv.z~<?ۄfI]E6ߚ.eP=Vߝ5ŌX\+hRCDx[Hha@FpID~D$ZIe%y7K],ra 4HsӶѸ?$Edĩ|��> +7pR-`ZwhHi8sh{O(9���.^?; )v;?- }��P7!~]wy`, aA��4siA?ˆ术HRQ nS��@}tު )� KvxA.��J%`�Z1\o$Cg>��tFن; )�]\;Y 2+˔&��WRC=[.@h +<ec)^ҳwCSmw��祣?/n;)�ΥeO<{< Tuˡ w��.S endstream endobj 335 0 obj <</Filter[/FlateDecode]/Length 1372>>stream +HkLSg�J 8.qhdS09"DLFpb9P8T.ҖKEA+lt#22(-.$tqeQi~/XC��< BZ8(}%RL?[: }ѽזгV{ro +��<㩾@<)�On]atk}ؑWA��},.?Ijē'/#{To6sl_1*P��sjbNw ",_A/iP) 5L2ሙ3F}`|,DNU<l:i&|�*{.y{` bQ4ݓ9{W»Ӄ5̏M=`ta�GѠcyHڨ e��>mFc.XgQ 8?�߳i+HxS\D>��):gĝrQRʜub<=cl6{ ��whoٽjO?wTJx9}07w?�\kʮ(\vcߐeu�� z77%PJ ۻj _;�c^9/O8��o6-]15)zC?t1qpslo+F;�+8c\Oе:��k'1r;?W'&|c`;;CC搋ZuT:�xOĒ,l</*t�8љ̱:zXL۳FeiT+z@_qxrJJJ%叅=��ֽϕ<;= c" +Uw<7+hLǖҜ`b�G>d{Y&si?)?��P->^^D_y\|uKc~@w$jʒyZ���arDQ}Q^Gl_6q,s�$U1vYq]��~t8v"Ƙf{i']r%EG#̜nN;tyuh:;��\o56-xR?�}"}e!=ugu�,uFUc` �K(dAt:MPGf:A~��׸ß0)Y@<)�! e9ϔx^Uݹ}W�w©/+;�`�7m"y] ��"}e~7 +0�:=- endstream endobj 336 0 obj <</Filter[/FlateDecode]/Length 1031>>stream +HOU#DHK6gnYUrnM1X_9 3+B 8Dhą˽p12Z~Z:#4׭Z6KN|m?%!҇an= +�󗉗ۿCVd̖ z!Z��f!׹NW?96Bfzujq@6rp׵&�:_SAL +y9xT7鿟�WeĤ?�3)xB]/=꾡�[~DĤ?�,y9q8npݍK�YG7 &'1/Ml/~7lK+2>+} +�9[GKY:`drh#W=ަ�-+V} &oEq>W{g +�1;nTĤ?ؐL,綍f鿳�liE +ZSg�b˃k=λ/T'h�2m\v7&׳oԞs y2 MP;AL +]x KOKX&'GNcĤ?�g#]m-N?0пS XԳurd)4�Gb^i,[]O[ �pr9jG?Ia�P]J 4le ^k/N=Xٞ$Ĥ?�HzնN?\ �Pp_Ĥ?�b{%I-7,uTϛҫū} &f~Ft*l="N�Ew6b,Ĥ?�LWf]ѝ [ZW*V�|/Rʳ/[1wǓ{  KǓuk�0Ois SAL +0ʟ �.% endstream endobj 337 0 obj <</Filter[/FlateDecode]/Length 1058>>stream +HohumE`2)GC],CiPnZM#ԕ6q6kڬ%.imbllt +-l==w9x=HV?&Æ;>Nqaw< Iv�rG+{um}IؿZ$B +=5lv}~`͠*_)Tsޭo�(T[w{*-X)�˵FKzW7� +G.]QiIϲ?�-ј?Wr�($ٽYJjmKAlLjhð Jo:�ųu/(ic?� ~^j u%uwRڨH;A\nZ9Mmw�0?mT.e+ VĔl\T*ͧBOe+ _wRt<ҧ蝓ՉL%]ʀ<nOR�&%k\ ,&wUx}2v'X)�"qlމm+� L 5v&X)�"m9fOt/@t-ڡ] V +hוI۰o7}�CQOcIR�a R@Gs_uμ%�|:?~-|mGR�̤fTI*Mt¸޿]M��Һw`FR�Άri_г=Os wE�kCZB]Nc'?�`fO/4ߠSӣG�+caK=`BR�̮&Uw|0([O;�-.Ja�(6ڥYS!/ +� Sz V +@4S'NC��Si]i=R� +ъMR%8W]v�kD L6+7v 0�w . endstream endobj 338 0 obj <</Filter[/FlateDecode]/Length 1313>>stream +HLu`f,57-u:-a9E&LCQcXyuG'?R7NŖ}=uHF>B8m]!�5s{dkз.|�frcYɞ]'4sn#$�/$R}g3w(ӪG�YY0ֳ${c{z˸P�Š:^pu_pfyLڷ�< ym|ӳ3f¡X7טb�5S7-[ghv>M�*cN+]?ܳ߳lƒ L�BQdƻ"|Ө&|a3xК<"^�:۽?>vPNcμDm/�Q`/˓=wܾ܏y�K}{ٵg?&R ңg�%|JCvjzlo �x#0g?f{ �ޙ"P8ӵAڜݺ j� +߾4ʳ ]ҙC o5mc�qtaj쾋-KԿ;�܆n7YܖLgo?Δߑ߭.hCƬ/_Sy?� 'Ԓu16|ڪD�rQlb~=żDmXWDj4b{%iZo[l8j-ޕ%?|s46loyT~ o�xdʼn쯾xu0o�fyL좥U['zdNc|mrlCwٟ9@:x��P_gt58\yusTo�uTy*ū }Ӽ4Y{l2U o�=`a|i3_LYM 4ܭ-oV}O(i0k6,=�\f//x5%�߯3y%#^b@k|o(*Ly3�-yGNC;kX@2k/# ?�,.V]i3^fL7 +t&ELa�MK +9XY#򊳰ɱH[@pypl 1 '{uS�5=2&ҼW)KNqUI,�ғn?La�YWvg<bpw ̒&|W?H0�-CC5N@w2{!tW߰?H0`�*\ endstream endobj 339 0 obj <</Filter[/FlateDecode]/Length 431>>stream +H׿KqowwQgKtRQ[u5t!lȜBjQ~TY{[ВCwtS>< ������������������������������������FbwܜҪ.Esѣ٤��B̻}7n{<5dl��@z—FGur,��@=u;}v8_xёD��@ZU''*_O WۻVёR6Iz<�� E>TggVZո˧G=dv|R��}nk#ώfyO|~pF��Rf)=l\'VvmݾwZ8snI${Z|_mS4N?C]MGc^v$Iڦ 0�8 endstream endobj 340 0 obj <</Filter[/FlateDecode]/Length 1049>>stream +HOUu$ZmYkÌՖ#׆2fM+ +%*Ȑ;r9%�pF55]e~Kƽ{u/-7;ooz>2`sq?]ۅ�dU].ȺY>n~ڴ!AHU [=nh ۬><[]Ljsa;�#Ǒ'^{"Am:٫,i�d_?ڸ_Na�YqDo+JvҰjw ̗m2þAY?�xՕHo؅/K7�2PoH'b?� u8RWҠ/\/~]y;6ȺA�^pmWAϷ3M)u�d&ZBY?�yhv6ٻKMԴ<�2du)(S�^w>7~zzc'ղ`;�jl:h wT?�5{fLW/Na�:9</LB*}I F? 8Ke] v +�[W^ jX2|ܹ+UB�k]w:A�d[:~Mfko"�3}k;d v +�2Vo/L;7 F�RkV+)�LU(5VGt]>:>_dNa�@f{am*f艫Uu]$�/ned= v +�2] +d1nj?^>~[ J~Na�@\S=z{mx 7](j7>)�.9<Q|>S3wyv�8dA�dωN8Y>0o +\{ګ;)�n48Vy"Xe׺cTRM�H#P endstream endobj 341 0 obj <</Filter[/FlateDecode]/Length 1057>>stream +HoLUuVfΩc+m6NE˸ +8 ")匌ݮ"/=t.\n +;ڤ+P16iPt"g wNmg{=O>Q)Tۄ͗7z_cF#K_$߱wm�fSEnG: ߷uծzߊO[8�W֋-5ٶ|&Ǫf��l4MC-)e9߯�X[nAT +�4//]lz7sbD~ҵ֥X� K},uo {f��-cKܑ`./<L] ]7h+D?�@}}tv>d\�&]k]6[K,oAT +�b]h ޹.�BxreZ.�Ğ~[cP;c#W _@,5W+XrAͲ?Ja�@lq|y~] `@{R[+�Ķť=| >m-qf,J78ӝjyR�"[2/آ L {v4mrbg:ЇnAT +�yO|67]-w`/oKMQ)�R<7MC኎έ3@e +N v7 *�N/T]t}2XĕVhwvvD?��L񦿺XgZ|] Pg<owR�DMx3FdW26;�U\dq=�fݱ=M6e߅ O+t*}`SD?��ԒW@]|?>t:߀l(\Qa}ͱ?Ja��"!gxpiR_;gzt;|PeA7Q)�إl#_s]n:*#@]ݝ?Ja@1 0�b:r endstream endobj 342 0 obj <</Filter[/FlateDecode]/Length 1479>>stream +HmLSWSJΉlN?qΗ馎ĠZ7'N@E&Q!/bKu!sM SP',3ٗmƏ)1kpK<rCO'�{w%j,gC}O 1.�VS~Q/7_t&1 2w4b(ͨuؚk\d(Y>/Z{L3׬.��Bf$cs&/M1Ų�xiȕ-DI_M7WZ>mVi +u.̵rg?��K + }4ݼ|Pjs.2Cn?%&r0R鶏~s��Wd]|2{5[v:*Rf Qb۶F9 MΡ��@_avh׋14 Η|Vn?%e2Ώ!g9Kvn䧥 {9��9!Dߜ%|�JQ/Z[u|I JLLFkKM = cK9��I3߈[?¼$pw3->Ѩ=4=ҭ[g+-^$5n��|-"-h}r$r3Ζ3k[t{HZ3;",w]Ϝ0B���Vv'OX$ϛ۩O�, T~ܬ }EU==sbvў]vY~QUYYM��B%M ]ɳ=n\4~%wT@g_螆(-UF+]>O^@?:n|myo��\LNc>}.~~'S,b|5Fn>螆(-qsާwcwzz"qn��(]%wu-3[~?Kքbǫrs(5ClgZ5_VsW) K/��'lSɴtv(cUip@@H}Y}o1Wc{��jժxNݮ+d"@o]?&7 ?��,8y&Ys8ӢEO.'.0DZzwcaіP9@@)��)H߬ ZZg79#f_jG@)��ПۻAc>ik{o .-࿸h=OA��&4=~Z߯J1LH^ybyğ��8])tVwkW%^<6i:OA��l@ ppW$r폯f[�=HYe9OA���1xI WJ�mV endstream endobj 343 0 obj <</Filter[/FlateDecode]/Length 1041>>stream +H_Lu_D+׍Zu#[79VMbV#lqB@ˠp=9<9>A!SDq.Z".Vn?w~ߏ8)D<T>?@IXfQ/4iI?Y{lu�/RlITop*~:fD?��Y#Mlo|3]:m+Co(3^mbd4�@Ue +Hϝ5[/V$h~(7;cvAT +�,B7oԙ˿9̏l˴o$Wj?Ja��ubwkuzO~θK خF7-k?Ja��Ik9`a;Y?<WȞ{ ߄SoD?��&ɕ*rk_ȮP$Hqi;uAT +�n/ez]?8oz'[["E<*خ:uAT +�ضXe`V7)ǷGASGD?��X#Dn7a+9{ߦPA5v'��[3퀻Mc/~BmpՉ!I^?Ja��gYՅ7CZ2J+ȿS/zNN}d��`q?*zk8m>SڕoUgn`SSD?��pPY 5{BwmlpcNd��%R;Mm2oF75o" ܣNc��ﻣI~egMSw_'~E|4_x+X;Q)��*]7x:,8w(E| +Z.0>zɩoR��;w;=)=o2\8{'K=r^~SD?��o7Cr?G"~mzNc��XS jZ>=I>so[YoNb5��= endstream endobj 344 0 obj <</Filter[/FlateDecode]/Length 1093>>stream +HLuet9VEa֊?d.'-pablDR"vx=?_gqux֦k䠈6kƠ+pOwKܑ,�jgEy۱ ׵zӅ�̭;ꮶ\ѯXJAHǼcͻ �*f;2k}k{.Sy(D?��X)"TUװƧ/pf/:jnAT +�9Qqn;[Gl;/‡O5_euCR��ƺ(5h͟ql}!3Ca;Q)��B'־Z=D&6$4o߃!evl==Vw *�@%}Ir6@OW+wa/wvd_gu/R��ȳ\-8(+m,#tgG%Vw *�\q׊} Cw_l?##4.WŋnAT +�T[\.G}y1֕ڨ[=,=6D?��1" ڵ~93d,ц8ּk]?Ja��~۳A%}pR]/xE7N~kD?��_*v3oįlFGRÒ*X��mI3bOKӽ{hc7ϧ+7c~q2=\ ?Ja��8nm4T&?㿹x{Ɨ[~{Q)��"Gt~nػ#몡Sh;2vwqwg�� ,/Z'*dzf ֑·nݥMpf�� rmgo`ח+SchzZ~gQ)��"Tw&ѧk#GqʟܼI~ܦ>=>7f��@ mv6UWFIװ6()8ks}[ $\%\w^Q}Go��ec]ql{+0O>Ty#+$]O�, endstream endobj 345 0 obj <</Filter[/FlateDecode]/Length 3202>>stream +HyPPAl4^cuW]7+(%DtDnqaffQ%&jrJmYGհ80W)߯% a|u8@ޛ;b8BYRK."00%}줴=B&GLH䪬U kwAAxo⠲§>9Kii\kmEӕy6#8CsyV'yg: |L0ି}Ztkn{y92#Ϟϐljժ UAAUDhuSn'ߍPV7BRR՗#F`7W,|{.1gt")8č;~: 26щ:)]y\N2V G Avbo<d~nՠ@AwaܬbJwgUV Hx7:xT  ++xr 2}Fiz-VY!c/o:>hxojcc'jUWǍ{Fkը. 5A,%F &[ykW-ת}BcڔDm./ jhu(|;wf̴;5O55X"ʘwAA7֊IYu}וɽ6 t_45Z/[M: 葖hψ1v,#T5o  uDʗg)MϿL+pϝF"c}:ހNChA+d6ɞM2]O~2DHqT'}JhUKy77*+|&x0n3/_'j6wZ)_O #\_vUDdDv\fu{(c8(}ux=jnox߫_| ?RZnoMQuJͪ3==0?Wdx\a Pf7킳&]6mO`8b>Ex*#*3eOxrٱ) /^Z^[πʔIS`u.7G' +:]D7jPF֬<m cK͕>> WWs55u0c3VW x +X=PIˊfH7/AdggxMyvEoSl^; otՑlQcO}צSk +$aWp5#?@n Z5;�s@~˒G7Pcg>o hGYZau^H+z3yіd?brggD?LVZ!c6J cKw~gj;>Ad_"pM.\kvgA S{r>p q@U41hqiUȊPy}"nɊR/K(25l{#[)ϸ5yew}oEK +zg<W"ʘ gol]Y$k6$L`<O\)=lk+UU 8+hB'sjܼ{ tPdOZp XxLC{ՙk>=q=1;ٗփL=.tOo,nYI3yIZn;.6wXŒ;B&F|8 o[~�}Y!zۼG!iVDapm�bZIY,:6Y +Aq.<cSͣgɶpG3Cl3H A^�tp@-MBZZiэZu+y׋clTL˒<-96Z$-g<UzOTU{fp0mL7;i8{O=j~NΥ9?AeqZ Qal(E}y={?Za|dE3GLcu~D6g $+@9)~/ +V\ъBm&f<Λ:fy<gwY5?25'۫c�q@~';tp!;)#,C?>L^WwAA7=&s=;νmF`8S8x~ x/VEtrJiq)$*3II3y6?5~HUUګ1#WW+cWX/rYZau~iFNio\BA' �λuߩ< ђl3#Y_l$~y?Μ "lMM<5T4ImE΃+s vN6~a?w`Bi$}!`_i;̽,öY&\I S^ZMYǽwtO=_#?d ?B0Ho90=f 9f)EKzmaboܰ~W^ MbPhȵ3>R9l + jVN ^-px37/Y5u(ţx⑅92m@mkWڿv@mnV&Q+M(lG`8z?R6VM rIL>=y0zm^=.VlОjV쎘R! .bضnsˑT(e0f̰0Yaijn^tƕgGƄ._Г!dR)?:^e՛VXg?d&PO~؁F(ţxL,[вnN!}qxk7' + x[0mɐGԴJQBa: ЫК j/oX7V:fZ8#EfM('oZ4'yNr ~I82mfn^j7٧m�A|(3[S7@Z>ԗh\=#%yN >@ڂKׂ #iB]9y 6/߃.>q 7kJMp� �# endstream endobj 346 0 obj <</Filter[/FlateDecode]/Length 3280>>stream +H{PW|Q64ƤI46 +Eh%hq%oAr" ;ۻcVBi5jRD|L3vN&6=|3޻|z&.J^  V0^ϐ=(=cVP  =+S';;3{s 3<#Jo(`7e;?#[Ho렌ZlSWH Bfc')jVPKNF'k3ڤZ{f+5:)}m{'ڦUV1Fn'ŽO$7hnvO7h3U]T(9 L]wRϻiml~w7;9`xR<K@AYJj?C|R4Q9;? O +AA%~Ė M^bk {X\[Q=١`xR  ,DjiZa]@ ճEy9;3 O +AA pѷA22nYW[ްE9=+ O +AAGOD+^7(z"5 +wzN ͜Vf@MrƢr~0|q2%˩8= O +wi + &/mSd:k[DK6O5xZgǽa#2~HH-LOA=9,1^|ѻFN̅ŽNÓ]#,Kf++[[;e&:YݔH2UN{ {09n9/Lo?W +ټjNÓ'&`hRNKWڣc%UNM{ {07jP\<8{6E|g.yx.*#wzҧuS? w&plΘ;oAxM{&뾄0}aO';GU/%m ?oN~AC'\ E ++-%oa\~FS CͣgsU5` p4yQv&r$endxr^ƒw`]ipQ𿄝F50zğļ毱4%7gb<~\-l3jf3ʤQua]ymd_YZT;Q<Y'>1D<{5sH "7ab?{ {+]M746%?|[O _WIji@=w[gZu_sEP;EEc7t joVlVmw}EDΆBnqQˋ{2j{ +-%eu(kn(|Ԣʃyw+ r8��?H~fnbWUĢ {u7e=9p\ЦڦUsUeDkL#j2lm%/$5^~öfZgob51ܛ_2C_曏Q?'VspA1L ysCAF72]-mi)G<-_c똫ÓGO@͚EVhӷC-==27ºR1tVYu\G  nf*o nNMt\CuC]n9O??bmL|j4qbXajVρ@\-̍pE=9ϊd [u0f {)y-�*kU]Հ{! OL�X|ûig7.ԄOʗ}YEvʞ?0<)?f%u{sRBtCeԭB+]̊H#>WbQfA=]{V ynHr)Nt{}yt?LZX>ttq]s!k 5F?'h0 fFbc +pcE% > {u}YO~AW݁:/ѝIxph^?0<)?t%ѣ!U?[Gު*GXeZꠌЏۭHرk1:ԇ&pV.Uw`pSk?mF 'm<b1c\@>![+y#T? sU[JWō߃1u UK +"G *OAyo9e;_e7Z?0<)?|$Իd~>d#ț%#oU^japuiec { v!J^/{|]1o*R&Aoa-m)5a~8ה;8SV[f�냶0 !Zraஇ:æUsՎ1-tp.4>oU b? @"P~[/*_8(N`?@xŦǺkBS(+MDWpˊUSv]yg@Vj?@jԐV\A}6ܰzF,p@ n\зg<Yvxtnyٶ5WtţxQ<i},MK6vM=x0ogo^?FpѲnN!.lXqy\_o>͌^1%͗�W]�`4%2�kA >TjԂ9/FU+&�?uF3#@x  +V\Fse�ّ](ţx⡏3׶u+[ѯ!rpڦKhc '0S*AQHBkW=v/c >rë;ԎyԹjK6_qie;?@xޖ{@znYq�]{/4AlWPmCVj#yٖ +Xv]y.du (ϫ[e<QqY5!닄7zmQ<G1I � endstream endobj 347 0 obj <</Filter[/FlateDecode]/Length 1583>>stream +H}Lg&!6L熉L% QB|!D"H`DP奔׃;-]|c:q-Kdq(UTl&ڻ{~W.Oxhb +^]n>ͫnP/tB!Z:>yϵO<G<s=Vq1r#x(7M |.V\xş40gq +183Nı]OZS"Ϛcw)Y"MjW뙋iՅaos}z:Ii}f|= mGYnO3虦$u~}U>=̨fiіgYNl|9y׼z.]c i4m]=5·y��҃#M_eV=]lߧO)CP~tk*2?}`ZZp29n5*(3w{��G$9k:x?kYeBG@Ĕ?J0e-+3J{IR��+)h˳ާY_vg,V2T-ٹ~^]nخuG^L���Ϗթ.{l?N*o=y?1e8{{>3 #=���X?IVK-̫oZ3͖WJem2+" ���`_CnNl?LΓH +S?���`s%ecn9~u/4DՑBC@���^~$h xyc* S?����ZYe`L\uot?)g2"����<nT:Sϱ&^WɃ?LQ~`Y?1���!$O'/K-/=䁤g,}?1���``##|ƣI <euMHo+N>"����d)[Nݍ.<?K/d]DLA����x6 39 *Cu46~l?6H<)����5—2?i8·. +{ǚW)����orjɗ&ZwnOW9VeKF +YS?����^\@NFϴXU4q7r{_#\S?����$Nc9MuK?)@_ 39 +.b1ڃd'O).ܰ<w~f{ބ/-hܪc-)89 ���w+etuds3}onZ ʢnu\_2XzGN^V ٸ11o6԰cZ���`![ +S&&IU?~s/AB@l''2յe@CS(U5s$*8đl~@t +0�t endstream endobj 348 0 obj <</Filter[/FlateDecode]/Length 2025>>stream +HOTwƿ0m*^" +!tQۂi tEKIE"raa˙V6iimv4*5+'y:Ð3p$Ofr&>̯<DVu&5@<6UexjjxL?7C[=61 �wQs73anrO/ל?.؄H}!}ysyzfk1!xهQ8]_=տvi/%est8?YM?ڬǐtu=t <3Y|5M})> 8LtӶ8Cgӧp4�&O�c>C* p!ibԧ!A!X,x9MS{fjγ1t^+t {Yc`)>_d:7.hfKx8LtӶ8Cgu:% IW^YO�c>CZԧQP3^ZJ |\??m9 ԍ h:%g  he6�b#ߟMY'k"e26a1=bnXV D#&  Za>5�p¤(q +ر"ޕ2������ʐ Ǐ\%fo\4I%FǰIizdFX]JהK<T:������`A׌gklO9÷l P(<Q6����������������������H_D8Ii;4O�]hRu3zj-/YhmLD$3:+&,ZMS k׺dDYwtZ=>i m[KkI\+lJkޘa{dlګ>a-< !ϥ'(pߍt&lsg;lv'%3tͤoZx mkSV'k"ѹ篟3�V/mscơIsz-?6׍V[WQzڛjςq8g* Է;o𙢣E7+,} + )z=-҂#tzd@ѡ}I cwQO \CWO>+80hn<BJ6ᙨ=R/)rvנr'kχ\&c/[/Uw}|"{L;Sv1<vb;-_}y3r?jcXzҚkx,-UkQP̍Q6彞JMs{uqEc-֞{k~2^WQoX},?9÷\?GzG,'#.^5<k|x C$Fm}ir͉{2/6b*yAfx}JIge&痙( ,Gh h ߹J\LLr/ +bQaH?ߟ9x,-nk+}HOP +^es7S72pc`cbslQ7ZobT73c#!'˃!wR[IS.#y>iY{X.$'%'( @ҡ{fAµ}(&g2{L8CU J6x5Onnv<hl4a <]n^b?)T8\牺,C/RUFzN&,z1x, GRR|iVV<9^/'KΙe?39.aqe7 W^f|xbRu5<Ĩn@gVwWُFF ߵʃd ,8^aOKmM$2X^t0d3Mn ĤꬸF �3 endstream endobj 349 0 obj <</Filter[/FlateDecode]/Length 1096>>stream +HOu݁(ʗ ḿq%ec(R` "Dߏ$U~K}^W|l^׽ߟ[Q橩|爣wH0s5 XYӔ]{|V[2Fx|t[Mw;1VgsCU13RbRH m;<u<ffw<<䉗?d3U\}w.K,THPr.僧:sX'=3#زiZC_EGR<cCrj;(А%9.SW|/z:5Hd))hXQΗ9S浲'63iBM~? e T[NpM}~5|NQ]c=sjaѓɚbByW;U|Ngo_M3`l5ՙ35J"}qw,x*WKm_igsݞ'r4Q<4G}j"=9P(C=]MR [ʡ>ccocځNǭ`aysVN(ih 0֬=7&b+ڒ!{RR%+w|o|֩a+ + +¤7>VS)sFϚM'1Wl#'ΘO|=PG8;]]ꨫ2sL˗$Ƣ&?d^[]҇kZGdK٪wa[EE2U<1?֦9ڲҭj^^Gw=F=a9G봰ҧ6"o^-*ZQϵn9YUj + 0ṡ&sWZj<妿8 +s 3Gwxr\r\}WsXyَ`A 0N5U~VoN賖���������������������������������������������������������������������_[�U endstream endobj 350 0 obj <</Filter[/FlateDecode]/Length 503>>stream +HAKTQ i.r"VVd16bnWQDF +%.ZDnB (灏a.\8pS|0dR8?͑h?kv|FWL)ޯ-}#c#g#c}Vk<aͽ\^W?e_b^}ת .A8l_#U^nwpceQgD|'<9>δL߷O[_榦}·Y|2΃q?ȕ>,>A8J9^8e2΃qپF$ �63�@kD��i>�;F$ �63�@kD��i>�;F$ �63�@kD��iICW> +��I}��r �QDR>-� endstream endobj 351 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 352 0 obj <</Filter[/FlateDecode]/Length 176>>stream +H1 +0 @u:))䃥������������������������������������������������������oKK}H 4=u=)YrOJ}-͟FJY[LœHcC�ݱ endstream endobj 353 0 obj <</Filter[/FlateDecode]/Length 533>>stream +HAjQQ?$ĊIי71sv\7.|+w_{^|}$[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbkGZ1ӁdD,ȊXZ#+bi1c[7$&nIlMh#F}dEȊfq{,bcGVƞ񡈉uY}%&nIlM?DO|u?C#nIlMؚ9&5qsLbk映֞S9#sNkGN=;)uگG֐ֺ\h<tנ>ՃrFkG!YZ{wԺuYS>"}dELt K>"}dE,ȊXZӁdD ȊZ1#+bhGVN#+bgGVκuY;;HF̺uC�N endstream endobj 354 0 obj <</Filter[/FlateDecode]/Length 694>>stream +H n0 +vl2cEXlۛzҟЭ}JĚA֬9@}eCE-s*lPd˚Q d܇ K>TY2"Ȓ5ȎAv}cCEs*Xs Pd܇ +>TY1"Ȋ5ȆA6}aCE n}a14HjC}`_mT{×I:Lzg\"]> 5~}^QZt-} ަsQ:4t*f{,P>!:<Q'`vg`g*Y}_,fkX7ט ǓH0xTY�j1Ŧ}VR3} 3.cfhu u (1 -<>i Ƥig JgO탘f0o1. c<``<wx#P A/K:<sxIh/ãHg'OtچyD0^ÏҙhiKU:kvOZЫfG\:-=iv/*{fK:"�ewS4!NJSGvW:- 04zlGSS7=NN]Gv|�w#| endstream endobj 355 0 obj <</Filter[/FlateDecode]/Length 767>>stream +HV1CQzJE~]�IҷxvA_QѮi? cE'vOEGgt:.<l駛ytg2\lqܓzǭ'ccL'#&7dzM2exdp|4)}4v6%>ldҿ\y*9U ['仑`Ï&tt.DfǹI\]DSfG&rEt# V,:õlE5StنjD@5JtxJĩnNݖ.�ѹ;S:4etqbTSC7Oj^vA(@5)tW\jDDW$l%mnv-r@48n8Cѩx)oFW^@K]z~:8EoT? @ կ@;wS%zv.!A{h1=]4/΀~ ShΦLh!yC7s/ + +=2:BϽ,s/ + +=2:BϽ,s/ + +=2:BϽ,s/ + +=hZ]T2NƖ�r%y`G?}]�v;R*=S/)Lķ oeb +S#IVُϤ +avCSɰ; + +=2:BϽ,s/ +.� endstream endobj 356 0 obj <</Filter[/FlateDecode]/Length 589>>stream +HAJCQQ"D"Z3$KSo/WC:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:Cߗ҃Eե`QA?vu)=XTO]_ +Cg>B@?t}́_??J G+x[wݭT?pw+7U3B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3rw�̍ endstream endobj 357 0 obj <</Filter[/FlateDecode]/Length 602>>stream +HJ%AQ[ŃJ!zwI<yЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTܯ|?+2lwSѵbÖ弒,*X]|J +Tr_9O%NJ+ǁW~ +'r\>Ba+DžO#\yz_y>BzspWSѵbÖ縔+2h?A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qsq+Xaӿqow�|N endstream endobj 358 0 obj <</Filter[/FlateDecode]/Length 787>>stream +HnPDaKV%kS72{~$Zi,1cH%ݖ\WSmW%Rl7ER/mܬJXpGW҇wfےP? >A̿-y) #a)[c6q) ZSet`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t+vM;7bI)wxrN >�Θc>>Ddxu~K|?D?k=+èc8`13!^Uj_m +C$cGifx~%_oS `}Y?ƥ O_^s37:ǯ5a^79x»?.YK}Lo>n_TM=b�6?u.ro}^&y{i)vc}Cj}t.t_e}9.rs>]|`)0�K endstream endobj 359 0 obj <</Filter[/FlateDecode]/Length 474>>stream +HAOA=KH + +E%H@c1dS*6bJAd$N}i2ϓ$icMF'uߥRq%˒yr5L:Q=JGM5=?K9WIXts ^ucW������������������������������xdEulOh7jRL򫵼/t6O.no8jV,7_vn6`-{w=^gpg{i,Y\|n6\yJx8;<{G釐7ۭZ~kom7Nx4:1t<l1ym{Vhu&/ŠXXn<<{_������������������������������`&Z endstream endobj 360 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 361 0 obj <</Filter[/FlateDecode]/Length 450>>stream +H׽kqRZHtr.uPLIK[ *u|$EХUJ!}HD&qAMhL2]^ppgN �`M^H_7 =7yb{�� =.7= � A${UJ͝ ��%?${k^NX{M��u} l>~" U*EO� ەEA��|�rD?��M��(7A$��rDҭ?fU��Dҭ?f�p7\mk�(F54yos}^[y��GGsws9/�EI{TK9O� b瞗|jlq��-HAsGs�@=ݜnw�o� endstream endobj 362 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 363 0 obj <</Filter[/FlateDecode]/Length 710>>stream +HKQcs@(/: 7Iɰ2"$ S/K(vc 1mrHv]M^{Byȁ�������yjDb2_$/6s]���KF683=6y@76m����ԱXd����P/L[^n����*X$_l8%c.y!n<���� +Y_HmD{^hχ=d6j1}����)_1vȃ;_>G1i����=Wp~W'b*+*DOT>O !BX&59V~5uKǜj;bd/E!B9V:̝;Y_p~!/T! +';z7jL3Ƥ:9Mkrn:g}yl8ԲM<@{e?˿P[b27 ]XY}Xԙy VF7síw:Xd]?;>:*(3򨯯r%~m#Z}C??+Y|G@G]jm3 eXY}Xԙy *��y *��y *��y *�F~ 0�{ endstream endobj 364 0 obj <</Filter[/FlateDecode]/Length 347>>stream +HׯJQ -M&qQf$"hUl +l:d૳^_8ߪBV6|a3�@ټ׈Ğ�F$ �P65"g�y=�{H�lkDb��e^#Nk-)��CIN#-��LD<]�IHҞRs��CIhp~u|��~D;;f��D]^{� H{_o.s�vGF?櫙F#I��<ޜ��D?��ʦ?D��M��( A& �ƃ endstream endobj 365 0 obj <</Filter[/FlateDecode]/Length 512>>stream +H׿Ka/$ +EC :TcZ4*J" ZBo "qJ0(;{sG7|y N�%;[Ν:@96��P��:G &Q-*r�k7kmB o/��נ4ZT3~��bl{r|"�?IyMnU g3~��A\Zc>}}?×�?I+<zt(ك3|��A\Z+W=�l<�ۓ;}5b��zF,�|?IceqqMaLs$t?=F135KKr!r!ݚh_^ʍӻO&<~"Ƿnxr!r!G\}v��}g�| �o5bb�;FL3�=�= endstream endobj 366 0 obj <</Filter[/FlateDecode]/Length 690>>stream +HKSq i)E 2u TH](IFL!٦õ}H-)h:Vv?<s|T1]6MZ6\|Vb8R7<���ƾ=8sI~,��~A"#[���/5hݙv6Z9a9"���ƾˉ���75hY0No2���ƾM:|v3��@נU8S_W3��@נEsp6ܳOX?{ /_L$1+o4*SY)?:J~^��;Y^ GhM?oΪ)w17���}N i6' G iBM8~RqR͇��_yЋLߗÑj+I}\���Р^PJȧdd���؊QGוj��ra;(q%��@S5Fb6U<ZP{���Kn0 +?³l���\fK(pO]uwG��@`P79'_o_wlS{&���l C ԊL���ؐC!FcaTNҼ3& 0�� endstream endobj 367 0 obj <</Filter[/FlateDecode]/Length 612>>stream +H͋Ma�+fŌFoQ 1jV0h.2s9ױA3zY(,,, 9wvzϧ:Ygq�_x8|<ܼn})8nﺘjYSM��| K=%KC�d cCsӇt�t W%_ūB�`dFq|{p6  �OX4ǹھZL�;A,e+BO�G^z~��GA,cAdL%c�0YYOi^e"yz��2?EL{jY2z��?E-]߭=�=oX4.<0>�v7h w&Sz8z�@W?EOqtU}��.WĢU v?/�ysҪ?Ϭ7 =�m-_XVipo�ڮnATZ; +Yzt*F�veFATZG~FܚH˯Co�_ �d endstream endobj 368 0 obj <</Filter[/FlateDecode]/Length 739>>stream +HKSa�iA ]J/BBatыbTP ]dbp, 4t3g, $3nڎ><<W9;pn6+%Fy3?67<@ل��JRI8w��s\"gM#}���*u62IY#��@E-u׳$UZދ ��l2IZ鄡��@Eݎ2I-"S��v7LfG���vuIȪ/G.[��T~TI@&<}|x8,z+��j\5db?4Ʉ +��ࠧLGMcybs��J9w\��$2Ly"H���* pό ���*? aN$ }]^���<OF'YXj}yTQѓ��"ōYX폽3{Bћ��Tƌ7jf}7��"f"&tBf{>/'7{Q×I��x8< ~?L]bsf̎]1=j:`=[h?2326ˤ[�$ endstream endobj 369 0 obj <</Filter[/FlateDecode]/Length 1498>>stream +H{LSWCAAWQY!).c9c*#:Ѡ"NT^*(*(X +}]z˫"NN|m(`=5IGR~_zm���UW +u-?{yKxNNnѳiZbsaDЈYc8]0����a7teғ\eޟ!`\{2 K���`aU +t:UjwꜬs?h)/+˱����V*)+?lYډ{W}ܚ援ieŇouO-q,y|����;9:lѨi&=k]G\.tkfJ>CQ^}D^ssP'����W-˴g!-3T*U*y#(#΍_>M<A#Rd~ig'a]cZ1����vwd`rYXԉ]o24/ +Fpc_u].Ӹ}eK+xۣuIćcc_ t ���6m +&0S9IU -LX8F5m>caDAa|!~Ἶ֢#۝ RgfY>D~yw|xS[SȵE7Zu`L(z���Lwe -RdB-`>"eJ \N6{Jϱ;K?׎/,cw%s`����l gJ`k'{{/ǿi*һ̱txc>Ԉ鴪kt,q[/ ~ИJH>r���|㜖Jv!ќ>^v+sY3<]nQdqJsR*W]{mU?4_k-;BB-S����kakr?QJE%|˪1̽ОtΜ1e���0C矤S[?Qb0pIJtJ ?^q>])J6t���0`|ߛip?L"=UQjgacYe_Z-���A紽U(!Gaao ˴'M;ޙln%���+!`qNW?QK0Ռ뉨 tê%=uZGEpR���W"zzyvɏ-A�GaokB䞱ZUnͻԯe0U|Yn+���K|!tNY=S[JOw*Z $9;Ϸv{���^؁hw:F�GaT~<i,=GG}abEQn==���x)Bo"LG�GְH_!ҧUֲL?MkzҳUHŇ|&Mv���j endstream endobj 370 0 obj <</Filter[/FlateDecode]/Length 1256>>stream +H}LujBeM-M+7s ӹ|B5\>'c":Dy;QBHtQ?ƚ+eo|>sc�(+y0f԰szIsc}O|g9JÐ$tYvA7OJmn0$W/W��LrS4? kKkugk>PfiN��HFZxO:,d1/~7l}n ֊U[kz��'c{Y]36+`yA<œumU(8k,ޣg���KNvG6I(>+&)r<P/y5[˃_?4=6aO��[^NBCB@&]8Cfύjր|~ͬ*;(ص}K}��G[]Nodj5ѻ[v|az��i4ճd!ʏUƴݚzذdÆ_}& <D��*2Z*J$kmU2GR~q/UMx:WjnMd=>��A%EvqL菿&6k ZzΫc~\?hާ��!b:qxI+cMii~&iؑ)+3}2��"NYK9cdB|-.,e2\vڪb"]sRꆯp��@zU6sCxL'OmC*zaӋ&ZYdH��$[~<L菧OTLe=SmjgtCS��@Bz1̐L@&dz'+{\7wkU!w1nlO ��$,viȄwo%XƸjsXov/auء7}R�� Oj=o mF&}u;:ryT[j3!a@pO ��9^O,? 6,7_j;7Ь7=yS>/��ƪjS<2?$LS`nO*4䥌g��P?/ɚN@&7S +*J>|{1{nʌ:0Js�nFZ[9LB?`� w endstream endobj 371 0 obj <</Filter[/FlateDecode]/Length 1914>>stream +H{PT](#NL1!1u7R@"iD+d1D U)eÞEe k&#PiM 3t:Ncmf?`Ι9s=H;ί_-l7M<7tk +s'/`a[fNN����rH >u _ǧ|H�76l\?Tͼ7^L8ʏO͵*vCFC + '{{���l1[vt ǣ͆GMh#Ĩ c5cK!/֋];1_C~LrJx���@$vv3Ë?@L?})BhwV0t_n߼h+.fZ~5)b/r$):ĝTlR{c7\ykcr[P'Dn}| =n���Xh<0c|8)kU}\N%H&[gz}Xycwmزri#%j,',0kc!&nbFޭʆ3WxU?2or_G���sLl(p߬3ګ>mwrbu8Q\ɰ#S<>H%#:\Nd"v̉X?=}F~桀A +=���/_`=|Cx&u?3_}3퓎o<HGIfKykk?ϕEoDnB%��o=b!l9#)Գ5h?w~tdD&hcg2&=7?YH"qurzD��g  &%.bK3n]?ܽ\>=d< ܐ ^WQ��RŸ[g=ɎNL|^T^*HOkD!כO35UiR8puzl��Da/۱76  eS^N{ٲ.#_ue(W ,rG$4vYzvyޱC ��pp+fCi:?MyBv򛟺*ܜשΦƺ͚.(�� +_^pSQTPWQwE: ,*QoͼI yaա$Hk��I/3)ɓ ޔ~hk[^ 5# }כM&|O?]ed|Pp m)~#��woK'֣Lx% (׌}C Bw{cN$&[[W檹L1SQ��TNc{GZɗЬRUp{v{ǽxã4f?<pW%;g��d}.q *3(to h iXQ.w"*JG/gY3ߗeg<i��f`!L,JSΙ ^=b/x߸_cj תlf|jٓ<g\o?���y^׏^")9MV=#/᦯yn̚Hu%bTEC 6 ݯDKgM��`tE7ڛ`*r7YΟ{S#"%#}dFJռβC&_Ϯg<HaD}Nwrɠ2~2/L:~A���/>A{ lՊ'1iR)j`=C_n*غh9a6c<hj0L6hj4H[gb>$� +!�ce endstream endobj 372 0 obj <</Filter[/FlateDecode]/Length 636>>stream +HKUaX"e@.lSUv(.4BV@esޫiތfm]Pw䕌< 9=܁] HUKo2sw3�@5d_#)�hj}?��M I?]h9\>l +=_R\ͼq8{wr!r!G\s<^ )?RgNmʦ;Rc;&_:3; >Cöa{.C9C9k'ݝI1�e_#Ig�h$3�@H� k$ �m5xc:Mw �m5`ս�_5 uduʥ=?��˾Fԭ_]R^8?��;F=J߾v{� kDYSMmLǩEC�xU"aκ)��f_#.;Na~^ޯ�xEes ޯM5 JgC3sv֍t_sqasqW*}\S[y��rȝ,HDMeŚ\s0:d0 �@ֽsfZQQjèvvt>z*XlԹn׻P?�ܮT endstream endobj 373 0 obj <</Filter[/FlateDecode]/Length 2014>>stream +H{PTV[D'^ZЦڤF)b5xAa5 +kB,ٳ{X.,\4VLiD_: E'*p<pf /<*JCE&?4"n=;G_ N6 |T燣[g$Acs5o12&r }jVYhi0QqГ{usڌ،֩;wyo��QY,\3+>/'ZT|Зؙ#Nbrc-*InX?K*nGz'wtW ��@^)k@�{U*Q乱xy~I2{#).UFu>W<J8|0ͭEக\$NNÿh���#VRˌ`j53\NցϽjoU:{'2V>_/ho潦%k3ۉ]:9ͰYW֖d��`qeRث*UJ'ύ?C7I{ceNz:YQ-ƢKK<NN!zѽ ϶T_bNS>k �� 9$SR>XkAK}VkX'74啬}+*Kf(~xܔwk +il#q[œ'7{��~z iNeYc9Wv'c47'{[]*2DL9{#L~had@oih?xC1Ta}K-^Am~F}^Vu/; ���{S.b5Y8g. w?sHV*/*C@X^|;ܩұYn4Cf<.>>YUi,)��C8>I2F�{LO 2 |GZ>M;K qmGg Uw*}Y0ԩy&:uJQJEI4r ���z1|';?^H$ĺY^ܠ^(Vw?RPrՕd?%zg nΨeעW0~Ky6��k-lF�G/+ODK˪ fA ++ Õk}m^k:f=wezꪐ*�(c`v&#A@q2+M[dNAi,Ht諺4~X:;}㶵N^[��#^ +v#A@O~VeVfAM #sD_T0 rl]Dw"C7I& +�2 |tv#A@oD.S ʹ֙mo&D~0'L7NKF~5|b3��8 F�G<l,D>44osb1bLU<Sm,AuYW֦x'oX77��`윍,N9;{? c[% +cOgcFmN;X) & ݆ٝ;;=|^u��x°$lv#A@'nQ~8sV^k}aJ֊ΙDy{{^o4lLs#7,c^}��cR~ċH?̽AlPctOOx%e>Nvo.,z.}G֪ + ~v���9v?{57q*;g? CioqFݯl9)looJU<Sm>o=UU$OJ{W 'Wgg5��|m b+8d3eG$]AqľkN! #Mbyef]?wT& h*��`Νg=HD`�w + endstream endobj 374 0 obj <</Filter[/FlateDecode]/Length 3501>>stream +HwPgeR( +(RHDt) `@@E)RwY!X(.IN؂;&<0 yA"ar�ԕ9GJ]e;@'ͫdFcn|p(5E?4`0>{$zSOh.Z,o Ӡs3:U)e Jq<AC&n KH#q�4=0[]#6J/<ᗼ-Rj!HP(' @x;}f$S`D `?q, qX=\u:da*'�`<K~JpRz/~ỈsG `�$4ۭwQ؏mfގþpn@N.n7>.FuK}NY.V$챃`0Π`2i$~#J;<nӽ_Mk݅$ gY}܆3;#>>9YC4X g {a0 f#JymGxx +KݽpT +:k\ɐz5n�m�syܗ\(I؍WduʠRU<Xo)IK {Ta011'AJ\%$ # Jrr2K`l +UAK}h�ya|MX�.}/`.\st>/`i hخ6;cp01GSsXgnk +6XY ٬vK|ia:gt^O]6nh{޸c[#<޺#|k+>}~ͧ*2\^׃x3%dYQ,4/�~4\xjr0@j֥֪M,gjˎTgg9Oܫ;$Tu�j9JD`0@LOKR(o{ZQVAUA85ԉ^(hШ t%2je{Sp23'51j`ԾsQӢfE}# sS0eOhľ-R##eDG+*eRGwE&7iNAJ^4*23̫۠{U! / YV)/\QZUvZeU'Bc5Ef>Ϯq/gӯٍ<6øc3{<~jx+%TZ`y2pRI]`�SJN}z8&ۋyݜ|ͮF}D-Lݿ,%*Jn7}-s5@ePcF]$'DG/ ˿c`Ґhf˨C'qA!(fP*s.ŕG2O=bWss݉㮨iy!̲m쓅}>N9SSN4r췝PYAW5t6b̨ni<Vo8ii<v㵙)LKOs'>|cixC1\7>RXkkwxg&x{dV>?X?-ǡ? Ҟ/GwLRN?=ݽP/,Lz| z<-~qE秮u;4]}vZ5JOϘ+<9m"XR4= b擾 -S#.R%W +p=[,I)wi$f?X�#� �C{};z�=q�ݱ��^4@v�t +.p 03�ZN#7pp��,G�S&עYE ZҼ޵a㿭u<޵q0ٱ;(짤q&(iEgjGq/zDŽGoeq;Pn?#uM+Jr3ؗIeOhDXx;1Z,%Z VUPeyyPY))%(b!y>8 $(ʂSQBG}`چ>ֻ�ڻvϐ-R&=6V1+>~RSOJ7-zzA^ 04{;u9jqߨ?7r7gˇJ{mqbn}1dᚿ*S'm<05OF6/?&:#)'V9tQĕmIJSgeJss`w7ysq`gwXZY‰󹻧b^�p{} umjٵ~eԣ]9yd3-'?9Q|z[ta]#}ڲ~7qC=jZ1 +vYf_/scKg;bfMltcԃK)uNߏ<>:-ޗ8%6R}֛/MwQ˝pctL]~/])?dfWR2)v6^l=W,_s3}&À`v,>c3;{RA=QhO'o.߾iqlJxz㋿sԴ&6vܭ,>ўoAzOg̺ߕ \RϑR6bt0[J6߳S]ޫ;GԳv2f˘%\/3:uo3_`] Xwq$+YgJyj*:īCb1~Miaa}\W,tHt<(U_b٥wC؅;JB:c0f6@Θv+cm'E2nSnjZ-vr{��[iڡF^%e!NI@Vm}odʪ$��VpͶRbtLg&c̶Y*.~%F���̴Y:3)?pJ:FɅGe7x';2; +��2֚Saڥ)? X-xeV(n!/w^���̄<Z2`HnI@qי"!n���܌gҦ�%K`:~p-%IM���ݎ"UI9Saw)_viW8R ��.O/ӔJSamKMkZxu5��ߺ`+8^[/NIJ5?}#;_ fS$��U�+ endstream endobj 375 0 obj <</Filter[/FlateDecode]/Length 1153>>stream +H}LUu�(Բ[SZ2RĖtDѐiWlċ,0H�%D}9p\CAl-/޶8C[gsߞ#yZ�LȹܺYU;ۤK +{sg\kg0wGu9쳮] +��9Sk-%k] F +(DZ9Ev\;9��0Sr{kJc#O2`!~"vCC&;�X)Dk F +(pC VzX��"ٿ-=)x*Ӷ !,sI*W:7[ѿs��P$GNb#OwOR-%tbލ�)uZW?�F7aO2M�3J`eZG?�2{Z!*oM$I~mYw�<"k F +jP<Zލ/Lѿ��CퟘÙK^b#(D b$�]Ͷ߫u)`r C48j >ױgM��rFJRj] F +>_QQo=ޗw'Q��|i F +~7%G";tDܨW�#yt'ݤ)o!<M;G5K�{FGx;b?oc^_u[Do]{rj"-�{76 ɍAb-xUd{Wӻ��x6[52 +}YgkV\9LE EJ>]h.:u:A�eLKVfl:AcmǚNٱhs9II [jEsg<w`G:Q(xjW&K]�p?lȱ~a阠?@COzw$<)Wܪ ߿vỼ3�{i<mlgX?;dKK~^D?9晕 6Ec䊍/k�޸;>awGP$$#=``�Ϟm endstream endobj 376 0 obj <</Filter[/FlateDecode]/Length 1257>>stream +HmLUu�?)OM]^V.[tl=`en>:ERBP{s"xѫ%/̑06 }�"&LZ%9ɑa_�׀3Ū¯'М?hs�l{]6B̜aj۬)S;;&&Ŋ4w~~.x.mq��szW J! ׯK:K)¯ͅzA�zW\.}|u\ܸ�ǝesYAz:L7A{='yJ|WhgE>@{"qfpVk뿺_$��gUl 2T,l8Ua?8*iFo%XKۗxm~?Z~�y+_S[w2 fЁb.=sw,I}WL۟t)W.g˝Ob�@-.励+{- wUeʏϏ9D}]&L/Cdw �Q5V f}o=7io-^s\w&?xo(.߅�s\j^G3v1Jw LkV9]S1D�@ϻqvZu V +0g7#2܅3Z˻XI~/�zVK W5X)lǭ4]֎  #�g4TlJa�}9b/֯m7Kݑ�wXo  V +[^I0䠯\?M3*J�@Hn}0g+=+gey)ik՚z&>8N~g�]'!͝j|?�bZ q_>Dzo�9O/%b?W9<|Z$?�MSv0g+XU:[*Mm֜M-C�imexRL)گK.T~�hܢf-4Ja�bXirٯ֮t,ߩ�k{cuRu\-լgVLٽ +�x06o(ɘc|?�/*}Yo ,_!_ � endstream endobj 377 0 obj <</Filter[/FlateDecode]/Length 1059>>stream +HOUuW,G[r}Y_,9prK⼚Ah F 'Z)pʹpadry&k7[k%oe`y?/![�M6 +ҵ?؏U. +,X~6�ԒTJ+8/|/oD_^zSw�pqcuD?uځ 4}s:[ �!|>knQ) 6;\ t{Ys ֹmڽw٦v?alQ) v%gj;OծG�DXlkQ)�i6W삁s=۬�ο3?{AT +40CX׿57|rm@,~!sG?Ja�0[Ҫ| na<1�Ċ3R�J.7ve]�]N.˪q$;AT +I*zQs4xSx ]єc}�U I} *<]^^}W̳F®eצgaQ)�+CxG~ n�,2?D?� d gVk�P/ ,,7{D?�܏U[�:e�pfhoZ_foN5 �v-U9"AT +dZ3 +e>t8o8�D޼d&gF,r#ݮ_4o}7�M~.K,ZѯR�fjm냕0ޝ)�%];<[D?�̆Բ\P_[`m/ *`6mpU23#%7X`}_6KD?�̶-krn!#A-<�sXEޣ2C]� endstream endobj 378 0 obj <</Filter[/FlateDecode]/Length 1123>>stream +H}LUu Q\fk֚%:+73h& >BWb>q'37}sp'y/-%l>Z_ZY8~0A>XtcُD&?/�``{}VEkw`#K8�ƃ2gONӻS ?�L{ScERmѧJ|cc7� g;Ja�aAzUslP�tk)d+@GD)>W0CA[ �Yr_C+Ja�mήU"q4 +h?{17��0QrQgIR�♬WDoN~_-��B[ٗvoIc??�`&Q)+Ķ̹>]nKOsn�tU]87v#X)�f4oZqS%Oݚrm=�j= + V +<fDOi{j1_[�*缎V؅b?�]tJH]ҩUغxw�LnMX؃b?�q@;|҇o�Lg4lO6c?�nvzC5S'o� 9<o=R�QLjXW=]}7�m(Zk<R�C Jﱋ==�FhJa�wQ)+ī\3Wi �p]_$R<?uw�V1:41nM2\ B-�wCݒ2=/3or_e�iV]S:n)ljKS�ql?ƒ*m fOsuEǹkw5�fԕ"&N=7nl^V/�ӸubVY\s�3lڋDH1�௴%M쏄3v5ёãLOf� EoQ[/}l[�ggL1cx{ ۜώ�?<{T/6H~ܷIwo �VV endstream endobj 379 0 obj <</Filter[/FlateDecode]/Length 1262>>stream +HLuj)i`Z6WmPDQ7l)*jy35%fbN%=;&p@*i02j0ȼw_Ǘ^{Dl!�BowfFEƊLyG=XAHrW߾=ҙF^9)~U(k̦[Yu�0 Lb}g-U�pfK7YB NSOqZ؛?�@[IbM1JhVd:o|&-ob`'AyI=102RL0^?-^v}EXiޞ |N+Zn)+ja[}#�@0H<z7{G}�Z b.ʴ~;AB)˒D6A-Śs6��xy"Ƿ/л\.}|ƿ0 CS**㝉qSḚ�VLWf;0Q@A&{t}r@??HB_ce6�ոuI"`:'7�0+g@֜^bp)�h[Ae^ԚuO�cM6"3!Ha�>][i'Q�c/N7ٽ+A�͋"; \]X~;x영i:A�̀R9Zrzݒ|o�{C[A�;1=';ٚ[~�W-RZ F +�nϬ앑W-mr|e~:VVsZ} F +�n+LێjtR=k7 kNKa#�co& pS2�ˏuX.QcHa�?mxi׺]t{7 p{rR_Ha�>Cl(ٝZ~;e\w v4۹m1R�nY)Ȏm<H .>a#�30mHnyJu\QKZ4&�=MkmEZ] F +�obj}CΎZ*1R�y>'cí{Mfeo�cmvla��d+W endstream endobj 380 0 obj <</Filter[/FlateDecode]/Length 1035>>stream +HOUuU&_0ͭf&H6Vnd,vQaMq0 `7sKHear4 /V[8ޟ>2sk{ ^/!XA"k��Lm9`cΗ9Wl_/m;p!V#nOsI?�@$z>nuj@!stZ!S�NwԲkѧc_ nP߃�̼hވW?Na�zv RXKV9oט/~�$-szC}_o{U}'03;4h*)�H.󽫄nYsĵ@n`zU]dAt +�!spwis2'*﯑)�Hn ˜mF= xya?Na�@s3`lOߥ+{^LD?� ud==p`u 7ڥg�Ԓ])JQ2ںP}pEQ>ݳ?Na�@jsĿq= +-IMՙ{g�Ԗ[M8wȥ߆Kob[ ew :�o~j=Vc >Wߩ�;'+bD?�@A׻랶vU�و/?/O6�Cof؟#eN^:\_{gdc4M?Na�.>X?A1vUw,�rY-#g)�ۓ{J<b2] _j<<Ͻ'|?Na�n+[%Js8Su<sHܝ}.0�\'Z0M .�B\96ӽ* :`S�� endstream endobj 381 0 obj <</Filter[/FlateDecode]/Length 1253>>stream +HoLUu1Jin5-ĶlXXꔥ3JP{"F! ^c8{K^$]É3@tϺͭ5Bl'}?"db"[ytwpYUw]!�0}y>qgvRİ3k.mhXڽ6=�gb %Y=׫ʽ<՟͑kشO ;b?�`b[ATނK5ymŀf]o ;b?��c}/TWJ7͚P (Zw*~3�xhzr||5=J BˀA{GE7b?��Oې][ 0vkR"w$)�pBw-_?>7b /^k_ԨUy3�xkDZG{+*K;eM5|WsT?B��C%3]Ij vԪ7b?��#p|pbS[Կ{`w3 zG f +�,r]%y񃭥9 zk/ћ91S�brLv2uf*]*㷗}`G٪HzF f +�̌_!'zydnѻ0tZr]%yzsF f +�0 +:.ޔ*>1~ƋKTerV,Z,y6)uzuWq+W~�-Sb?* *lڴx.:2 +jb"O~ٖ3q%(nԔ)ۣB?��mޞ"0M{_.T_b~#JUo$3g q)wK㜣��vvbz ñ=DjμXY@L=s97shp?��Os{ˎw>*&yw= 46?H U\.9oyo8+7@CHLs�Xxm⤫X{s:ϞhlL0~OIԛ xR79i˖_-zH5y9�`L J{Vy{P[u~Ѽ|3<'Bovd,4"ej;-7IB?�XJrޟjy׭ٓ�#yUZTof�؉ endstream endobj 382 0 obj <</Filter[/FlateDecode]/Length 1280>>stream +H}LUul͚%hQM `(̄P0t)�Wx\1 .NK4ʧZ61Qrg;Hqg6{3r=%` Z(K<[Oߺ\aϪ��Kday<I:xVz=X4W=Mkbo#d$2qҊ^1ǧM1àZ0.o Sӧu)i_d&�K{QZS- rZ<:V}H*#΄ؿĞF  D6AL0sgv@H.0U;�โr⥢;l}7 :VVVlv>ĞF _]5(ekMc ?��$+6luhI~?F)mv.]S[wmlsAȻKXpΪ#=!u��)vE;;ȍbKI' qz{K%yOִ^7VU&=;�m㇭uݞk-GjgA�I) +hRz18wF^*,*YvDO��Fu 5:}KO|o΍#8OmDO��FWkl0ik=Җ]EbQǪ=)�h.=T4E^kS,nۣgTjG)^bغܠ6?��լig]U::W] o1 +y:)�h*%1vrNGv)A[s}"?B��5Ruv8.R{%07OXPN|?B��ICiCMmW%M-/ܶdz5)�I++l-?/4ig#vIQ3M z +�WӳclqϝVw}AwMnKČ2)�Eg3{9VĈ]75TuDO��<C##;[dm';ᯎIι6?B��x%nۡ2q]h}Ox;e4˖KC-)�M }A1kW~gXabjfDO� �0 endstream endobj 383 0 obj <</Filter[/FlateDecode]/Length 614>>stream +H͋Ma�񋒗PHyˊdAQ66Ldc3$1&sgNb͸2 eeaa!Y;8ܹ5Q<}>tl~g��GmO}}_v])Gw;NN?}~1\?w�w:.^ؠ?.*=jdgѼq��mXDZ 3C�`kWwbQ}w�d7oĢ/ҷ'OC�`$~Dj<*c=��L6ܙoĢWwd% �@]w/bQ۳񽍳Bo�`ƒvA,ٲZw�nA,x{  Co�`£B R7Л��d y~M|г��YRĢ?6]80#{on:8;.��*FK폹GieVہл��|?Em>9wg>K +w�P|V8SPNϡw�PQ.Ģ?w]}Z,4��rY$>y��9Gso?z��?#M>bQɏGW0M`�C- endstream endobj 384 0 obj <</Filter[/FlateDecode]/Length 1051>>stream +HOuY:]mMVO,fjY C]2 3@;dܘ�;GxnuԠ)d I7A%zPuwίg{h 25@;wm*>#45`&-8t̞h$0*=^rFHgײ���2<QcA{m@];_OCOCR��dj  +\ի{e<;Ko +MGcR��޲î +6;}X(?#1 Q/D?��%X`2k5TudkWAT +�?wk;Ƨ{ =g:ٿ*syP)"��bUiM1۾{JPWF"?Ja��7Z>HOt5?r *�߷*Ԓow +`sswR��sj +or[ Տ*Ez3AT +�g"w͚ύe艙H/-E]c��Y;[q9{z:zUM/: *�i,]jFg-C|O-ReluAT +�s Zsdo1-[ٮ\.;WR��̿GeƼ^=h)Ej5DLQD?��1ӶU`/g^wZ,C(nyP%Q)��no?l+¥e^M8: *�@rl-/c˓]W#��ɳqmWGkOM+Y`a폭-Ea�� Viopyv}0絹{|/R��ȳ໷E#Q N 7<GNcRQO 0� endstream endobj 385 0 obj <</Filter[/FlateDecode]/Length 1349>>stream +HLuIk~`֔h.r_31T؄T.#BDL8Nu(ӳUNgD.j*ҒQ{>3&r8*U__Pxh��+&,saS5]!=Z6]hLѵM0=L{wFH_��RNr@V~[9,U?F:Եn]t7DK��;BSNjŻs#IKG%k-WJ5d=,fҽ-�z$uƋUߕqU<g1)@>?B��wM`e?rvߙqܨ/aQىA��m@$z~zi\;TO="aϽ;[?B��o5Ow {kߟ<<e<k+ΞA��}GȲq"aǺl N^Z5W=oq=,"=Vq?��{|Ed[=oxGtL?wi{hy OQ7h)��/ +c7zc;5zSمW3h)��e=F9$e]+>0Sr/OhfL Z +��mxb L]?Uop>/H:ݫR%K?&j\qZ>Rcn,/_t�Ч7={/īg~uyfL#Gdb7*2RXY}St�ň'7I֣'R{?tϳךy'bJrs6X[ + Riɺ ݝ��]QىⓆ2?wԉ߹Ng͑A|1}{ +}4ts��-d8`i q϶Nz!bV&$<$7glabȠ"=q=seMRrPw��X^uqSh. T{wmrWSa(O߸깟2ތO)��_b6/U4T5[U^Ymf ȝHYl*,2cx=Us2+n?� K o(YxvOc>o.:5 E I/(whjЮ3RS8&WH~w]dwE��=1KɑwW]6/<SPW^mNx#nv@Ow9d<V-o)B2ш{~֟c;/ΊP{@C�z endstream endobj 386 0 obj <</Filter[/FlateDecode]/Length 3095>>stream +HyPwYDcPY&n% +"VDI+a@q r ܎ 3==WO-ī6zdMUL<US[mlc U} +^~ ~d@qIh2]{!԰ :bն*Hl)YktꏝM?-zg>1V^91?_ޟa1='AAjbq=) m_>UAk{w: X TkN_O UMf<?" +F=ӺqGA*F}61;Ky]aC}%t8mC^:qL dr�TN}obKL7kmRp>6|ʮU'2ͿؒvRa>IjU/*6<X3Pgw [-]3 AyqYV'wjNz_*lwBy&/ 3E'XUʃ;9ey>x= PSf״P]dlgZsǁ/hap#neF{Ż Y(^#1KMTzjNh5fH m +'1e3kԦ*ڨ+TEihYfR߰^&#/9` Ai3dNα_.d|F~}k讗iDZ'LK'[Suhs<?v ꬊud w 9 MsBD|S,bw}7ni+7ĐA]o4\f$iV72neTXyC衩k"mm8 򬘝(2@+jnf%N[7 _ +O\]Š"$A6z5aԪ*ۨ+e&yqp|+C,a$#O\ϻ@-3!P売 +up|h3:1ݓЊVFk}_ J5d}9G/pne? _ +OU}U'ɋfAVߟ!"fw˴ݑP/2͟l7\TekA}UoKUB~\$p?-p=0. orj?ZF[Jgp~.̏C <7VBeNp31՛_dNZ wv5D{@F>W׻1d'рZͯ7O;鲶0Z8m)1 +bDWNbQAsYz׏v]CSg ]8n2~G x8o5.0ʯ/x_ǿ>&ݞ #<u܆a;HUꅈkbHRz\נK-Iq5‰㎈F{vCT;D~_d8yMܩ,I |B]kqhuЏ{/EQz7 ?AOYž=(ޫ}=4FK1ԛ'rOtY[ujs?.A4jl8ZZ{gAVKl.e֝O7DA] ͍tk &>•C xّD%E/png*gccMV_c0hԋL3 6U_:RPcyih.1?(2w<M/mSmdv:t=N uuIq{d-=;uҬ <t :0k%Aϒ.4ŭ}Yc~dEK1.th\ vYVten6{6ܕZU%vu+to=PthZ +41$ 5pc$zOpx<BA^2=)x)@c{[U[dyqEK)|H8<u܆a;d*F3Qb Oװs;6)uttW.DMt[﫬5Csc% $A@n8襍?c_i`aԨ{bЋuH~wcs~;0Iʸ# .Qnnˊk̛^?A99DE✍z+^cǶ/GDe?hz[g]8$ 8hꧪiC2F ڻشKMT8xB]iVeWvzQѶA5+hxXoeÔi;eo:3=;�?r6C9 ˚CܚMR "cs<R|wha~jbo= ]{e5Xk̛n/`Rx�9dMKvk'!8HOІfu)>r lȸ`a!1;~4qb.dv0 <n KB8RP Fl"!x(MA .&4FyM^aђY5#Bq0'c.̗9'rmc7~/ix̤8N|�ࢨySӅE-U#;_y}hJcf���HfjTdՏ_{ֆ2?��JK,pCגk۫΄W~e3zF0V��0SILzK6d(Nܶ >Xi��@W^$rHq}.igZP��dy5VZ<k"=Xi��@=OLv6l3 �հ endstream endobj 387 0 obj <</Filter[/FlateDecode]/Length 3414>>stream +H{PQVm<1m<* +E+Rd(x["S8ww;v'"V0Ѩ1j ML;L&v4:{\ߙ{~?!q,}}!u|ۘ?03u 26e2 Hv6ݑzOK|SYelFVOK}NA32|{{P5CQɗB 6woؘ4 uxO}AA.MI o1ӜfRyuѦRio*G</XNuӦ3>+ س0T37?]&+<8u9`~)c o +Oߤ eȵ47Gx~MO^\(V" Ųަ:) ;ó8obÛcK]>WQnVѴ\{[fqA0%1ڦ̝s!7[@j>Rzwx|3}@D(eA.uIvӦ! k쁶+HՖd~b hQ:iv%6M߆w.q!`_ ǼeaWlӴ鎓!sI&xgoYdM8/m~O>p=[sdžkC-ʊ|l}C(0"/S^hdVGzP)*T�`^ TZ!ɓ2ɥCM +2 zn1;-߄sKCA<9PIa`s~ o +OWm"q~ci\zjՃ.|ua7 (cT%\MCQo:gGK+[^#tDcBJ4hڵ-fEtU#uxn=w4&j9zU]�R^ r𛅙-ů2:oGK񫜋YliܝgVD ׂ>Vai;m<>C(j+7\Apko*{ILCM(c!x6 ev-4l\蟬=Q|} x6ְn]>PѹCzxZ8pcnsn o +O@ +jR!qxCl*=μSgoks/87e/Em<҆:uN. spt]E0f ͬηy�' {l^>NM%́@\-ˏY6{9? h$>}^ <J[ܝιK &Qɚ% cLyv>|1SduwΌMi1?}Hm"@gkcn9Б<c2*i=5)[%e{h<K_X>|bIۼw4&gՑt}S %|b25|n4:}9Ncܪ. >47z}spXGRAk"(@sѦzhN$D4Y?0)<?u겄o*\ #KYF#ij~5C}Z<y9ëd=@M<8 Ƿy^$m:q2vѤIcgypjF5͊h= kT|wL߃9uruWgU'AvF_ XJϋGڸEwΈMiHAK6 G'=1r[k?9_WP6QԤ@ +"KNh[26reJbJ +Pf;{<Ч6GmۮɞOds0X@/΃CTZC8÷GWcG*͑QjUeͅⱵvR4ICA'~)T6f?ÐO|Oj[^w·Mi[œFHme]'uB3+NӦ3A , Ǭ|!7VW+ +- ar|ogB\vMUm7=y?5k찛]=r@ 2y Gh7@mqܹ4=c4qT3s. o +O%j\q];ԵrTʦA,\Rǝ{V=fNN?'\ס->O=&,s"byjR?3uͣ;1"'�R}=frMBɚ%RAϔ�*~u2fcf an!ϝp97'YP.͍~,Qb/mz:Y{ti&&@[SV:.U+H0t@4_ZK\P_4·:.xb jjo{E�~M`_~0^XR2:/-EYv\yfEp\[n C' - c58Gjrovҝ`xSxLK^I9r=]W(u8/(8O޶K.!aQfRn:3Jo讽E!y` ЭF:yv73ovaqʲF_&)U37G3 Zɰ&qXC +/FzI;<ɠ/O>Ӷ%踴u{(pskR]K6wlOτåI;5ni^ο +ȭ$O%=Np?Oԟ>cwݿ|rEw���ɡڡ44'翽teM:M>]F Zh-1W*r?Kй|`Vrzϕ jw��]J-U5c y!y1,TL&C3D!?RVL:͜ܪYv̗޷ް^c&ʫ��>(3]4LoϓٛENoVPs9>ݺ^N����Xymiz/idzD= r?-Ejm����aV3FtB^`翏*wJNW?�����t dã4=Ore#':O'竕h)����s%|cHǸ[ @�S�z endstream endobj 388 0 obj <</Filter[/FlateDecode]/Length 1357>>stream +HLuwq1e7aYTfE\0MT2a?tbJ q徧)efS* .֖[[s6yDξ|m~?{t�x+^ vֶM\:}[U#D]x$ZUNqC,-?u<Ӵ!X~y��LNKs6U.yQyDO���K\3K;7ã*]^?SX+UYDO���f.t7W?za](WeG3?B���/0C,9Fs?y}cyM8-=��ȢpnjkbH8,;R:J{DO���KEP]+^Xݿ}Uq?B���迄WjK󪣳UU~=u^?r?]?���nlu|ܧ<uw\n_ *ⴼA��{cx޽WeԷC}I݅Ohy6)��~а?ӣ*wTOsF=9#+ ZK CgK5%z!-OO5 cNmxƆ}��`pM۲TTܵO1k3c<A*ӦnsvP<!Efk%K֭{թ`?rpUw?���_\aXVy9[t}hE[Ir2iz UccEbBܹY"\pTWVlW=3{x%;C39GkDRU|猒WJIg?H$$L«*]|8 q::x)sc麊H8ZeZmv^]\ ckA"p#=,]sYj5[kB=7?.ݪMU#}0c0g0hֻouʽ+qrONatro[zn|ZqʦUЯ'>131 +?۱=F IѨɃ\(F^>yJе=3/4o:S=?G цGGÌ#3HfMߍO c?2SWv+Pyś9oZn9=Mk IE1Z$LAf˚tel +u ��ǛWU*6${ <NGGTbdi'��G�#q endstream endobj 389 0 obj <</Filter[/FlateDecode]/Length 2392>>stream +HSE.^P+XUN+Ct 2\\UuY4 !7ED?ttvtmSPLd|?3g{r^0ߜ> _ɦ6Fǰ=ۛXKzR2G?v݄F^C*+H ֚&�����رEE~ + :dWv +ۖ3bوA]%%%Lu�����vjZ6؄h\!/x㺳<R[L�����������������ary6YR\3! tzݛ26XEUVookOi}D$k8n]R-uEY#KY$b,2OKY׵݃n!IOkәccXTGvWhr~F^󷺳hχue:A\Xd BY}u׃Փ״_(s}8oiU%Yٮ}rGĹLXGZ^#~Tw<"_:WQPK?j7~&]Կ =;~𐴧mڧM㐱c<i y" wҗ}cH꫅#mc[TԞ>v(e7|=!cp5QvO*{�!̌<+WNT4^8#s3o7kr%AoEUVS2v<wwz32v,꫻MņeգF^C*Tz4).s3'w2gQ]v2TN|?53Pwo6 a6u*VozFƎGszp?Gu˖3hJ鉠H8 tO.]aŁ̐18:jmqVFS6%bZ0K&?ӹ_x:<,auy;wWWBG݅(?;;]ټHHa^okNE +d? ѿ R:M18~UJXl޿2$T\E9[ fd?'u;=%'wuLs fBZƿQR<<(vK|6?ғ)э1oȫYo0]kX׵yi\R73yy^Cz͏#˨OVc18{ՠ.Ǽ?dax8fy올,S?#y;ny‡ a?{ۚ+L}1 +fbRsz&m\;d?92yAS#"-WTUnJӅYtb&/t\zFLU*}ScyʐP\+b^0;&?L9{,ޑ(=蠦8Y7֏N~#vG[ }FƎA~b퀺s6m^'%S֣c,WRuf Cve爁>#cp&͆cwUJy8\Kٔhi, O~ir^ztwgwWXP;!cT;%A,[DȐS<!ۂ@vj}<=YBTuF\_Ӈ$++ < S.;M* + +|iM,`6LVnwe][bfJ*֦3ݳAƎġ7ڛGDؾm^ӧ<WO_qL6s)V̜&mĠ{A18#G=L}oZKrٖsa{>A_Da(Uv&v1~Xq..]N}ؾyy=[Z~UjP={t8V'5R(mT{{[E}Wׯ18e,ր4+;yct3TzЏ&tQ֤39nnؐ^=js?QvJ8\[>fug#(Wu]큜=̼ cEw}ScɥcAknROҜnq1Znwu*ń3|I5>T3Ym5O}.0#^~:\9հqpFQaՏw~Moiv=e4ظ!L g**p0t7,_j"ct`Pؗxÿj9eSXdx~?::Yo[spV5ΖJm0CJUzöM \d1���������������Bk endstream endobj 390 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 391 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 392 0 obj <</Filter[/FlateDecode]/Length 339>>stream +HKj0DA +@pxU<-�����������������������������VGWLD +.\+} gmo*k˰VY[[}, ͟q}lqONcYo>Ncˏx}v7}b׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}0Kj@4`bYMf)6b׊i*vb׊i*vb׊i*v+s095}S,_M�� endstream endobj 393 0 obj <</Filter[/FlateDecode]/Length 517>>stream +HJcQDO_iiq`=wZ.. vιo{stb\bcJI)&f{9x<)}*Vbkśi*|y^xEŭx3M֊7Tlx3M֊7Tlx3Mn&ڱ:{֎}WiϝZ5 +^ϴ"hv>~*i>O4ZQjZѤSV+샕bjJ1c KV+샕biJc CV+샕bhJ1c ;V+샕bgJc 3V+샕bfH2c l$+F#샑deHc l$#F#샑dd@H6f$F#샑dc@H&f$F#샑db@Hf$ F#`D +{16"iRcz`�Ò_ endstream endobj 394 0 obj <</Filter[/FlateDecode]/Length 629>>stream +H׽kSQ AAdЂUHuthE U`,P cBUznFGAMZ;sns;>Zߺ퇤�M}{Rz㸥N)]s���]4S][4&=��xo\]4돎[ݝ���L?YlmBJz��6~EPP{,��`:F@~gMz��ɶB +{}|���ڽ#B@+~q4s޻ϦR;7��-?'V-<��`qZuOWF���StvJHs'!��T}=Ҫ?.<L[��siZit63<Wz'��RBtҪ?ɄUwK݅N���_?V΃WKN���M E$?&s']z'��fGGtu$.=��8sSv: ꏃc}ݱјV���$?ɄZT} +��`ٙ^: urV���Ӽ?#�yD endstream endobj 395 0 obj <</Filter[/FlateDecode]/Length 805>>stream +H r@AimS,40M}EUOD5On^f/it|+T;84I\,-~>th>r6h>|ߋph>pg>_Cpg>|#pvg> 9fٶG}(gi 9;c٘]}70ۇqe>_,s])؇1)%;Fsh`ΚTCY}#9;RcgCJ!G>| zTCA ,G>!�jt×Bs6eM&hۇ/h,E>aD#g%:!#8 ѻa Y}FŜx|#8c`:.bi|SvCAWfG1Gg'fqN#H:!.;HSrò;x&jIʎ%:$);wtlk_(*xn9{)W5м琳a_,\IIn<9o%\9r"x@s=>&EqOs:>&E1GCt\C1)Ž+ɮ>`"ʟ y5VJlRr&IĶe"[jt@lЁcenBI/kܑmq/:e= Z~th{Ǡ#OzcQhctge-+ѣE%5u<: '� PX endstream endobj 396 0 obj <</Filter[/FlateDecode]/Length 612>>stream +HQN\ACA)?QZi㮹/3ZwO!'~:3o +t˭֞?A{^K�`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts?p֚6tgXSN#џ??w `W?w +5 _]j2M) >ׇLS +~c;ug~6UO2Ա6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M6G�"Y endstream endobj 397 0 obj <</Filter[/FlateDecode]/Length 625>>stream +HjAQOOpB_CTm8W:`?C:=XTg`QsуE}F:=XTg`QsуE}F:=XT,*h. +KfRxz?S??o3xv#{!y"?_n妊/rSEX?B@>B@ zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +Sٹ"Æv*Vlܯ +V+oɫݟJ6#Sɱæ+ +'<s}¾gn^Pwp}¦k`�Y endstream endobj 398 0 obj <</Filter[/FlateDecode]/Length 601>>stream +Hj\1O@DPJ:[m.My>>a˿s\4 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй8NE׊ [Tr_y]�-G�dSɱæ]+6ho#E o>䯧䛱בO#?ws^qۿqJ6;ǥ\A +zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +, �D endstream endobj 399 0 obj <</Filter[/FlateDecode]/Length 674>>stream +HN@ Ey]4q҅"!݉{s.3ͺK.uOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t?Ow8)7*5-pII#ndsߏ~W>N5_q?!�WKgo n~ɷݏb! + p>I?Z0~LC�WfrJ&KV$I?x +#&lK^*x \=K>k +^ypGքn2xU{.H;^]|G ~<~21<b�Wv|* ^&Q|;Q~ eTSl?\h?NeiB}7ُ\O}WfT5u)D[LG8G[}fwlQ[Gy^=5s%[!|Eqn-/\rseU_M_$I$I$I$I$I$I$I$I$I$I[`�wJ endstream endobj 400 0 obj <</Filter[/FlateDecode]/Length 439>>stream +H]KP�`P5Iӫju+C?26sMGmԹk7y yp5����������9(΢3l]7i*::Ŭ.eV=V7%+!> ݽltQgmzhw#G4=6 a|$.mEC֍ʺnlڈv0 yaz/>!} _NXaq<.bW8ャr4WlJYoqGW8^?ՠIz{ɰ>aOskOua3!6YnIQz[ ~տ����������������������������������������������������`�j Ë endstream endobj 401 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 402 0 obj <</Filter[/FlateDecode]/Length 295>>stream +H׽+_ ؄EX- +gpJ&]uI.SWd9v_z;| ���������������������������������������������7C}ivQ~iVKEqsy=.�� ZGǂZ;?L%[]G;ɞ��L$s!s<v ��m Z壷C.��9iT_'GB{|>TKogXy��@fljov|"8K Qz*>��%�fB endstream endobj 403 0 obj <</Filter[/FlateDecode]/Length 578>>stream +HMKQWP. "Z8A`AiZimsL L$-ØED#/>(uiq{G6?s{0ػ]��$p81Pi:?Y,翮^h\wWWqy|1\(*%,aO Z 毆ަDgB-""""q'm뵞F/Nj:?=tl1v@JIN~1c1g1cÞA,ʇ>8;w|.t:9%mKO^fsNa+s7vnz؎Gs={F{>3΃9όA +:;9ٽݷ/>':>,}fsN\s>|gy0q?ȕ>Ruݯ63<s8[}3�@kD�f_#% �7)g�H>�;FJ� n5R��q}�}3�@kD�f_#% �7)`p_G�pu endstream endobj 404 0 obj <</Filter[/FlateDecode]/Length 432>>stream +HױKUqC]ZʆpІn$Q%-ruB?h ;ꊇInw gp>Y�162}mjbIz ��")*��.DRsqZ9��CIqLJ{_L�X;>q?$��Jv?�ByO[WRo�0qe`0ԓ��(ncAE?��A$��jD?��M��6A$�돇j��"iNY��y:955co7��i_^鞏vw.� N<xҟ'C׻ �A$/ϳo7< �~ 0� endstream endobj 405 0 obj <</Filter[/FlateDecode]/Length 19270>>stream +HW{o8? +4|гM4.z`,ѭ,z4~mm&H$ o7IݛsaE=vEeL[7g! R._M?]{XYZI[1̺GWg3ccW֛oIbWfAOG@0A8$ۏz?,[0ɀvS[&>]#H`~c0 NXlt '` ˻մ5xw+3 YtpfO 8:|g{ F~?)vS_ +ߘژT L.a1$5$tNuS̔dt/pѾ[r֌# dWu'{0_<Csw3pVlw Ѕ %8]챰K;'P<)(6U +/2dBR̼15cm/]k|̒~EfjLmL^e]/9;o%5J^,@R~OV w~u>s\@ШX0,,"NM Kl OgdbuZS1|כ8$OهJϩ[ȓ?uC Ѵ@eW'UW`hD BPXMq@|Ї�*6hBB%JPe+SMQWhJߠ,@og !iCzUP#|B)_' E͉EkSϘ֩P籝v'nvޕC'�M3қQVo4o.U1#F`@b꾁(X +4ÈWl}-n%=<3ic`[tx>mó뫵UukV@}odɪ{ljֽBu+݀,]_٘mg=W>+d_lG:[#m.!uWb:HĪX6h1ԝora�hv@LJnDhq(f +KO<-tAt}kxoOռf +<:UoZ;H~6zt4w�38:ҵ]up.KRз{CfigDI|t v ge|:96>� nM|$ B#kTz`[7Ѯimmx^*t5Dq]|{$MJ}% ôC [p}w~s%fIzM3UMv/ rO8Nhޝ}ULބ nyx~[:7k=h?۝)ptFP">kx!FGGw(Ύ>3 ; Y_qOەxaOCxuͬϬYcظqu=sKp�-�G֞iFT3 yOaWc=PnlK^5 bۯiр~_A!vlxwJr;`N{W/aڞ_�z#\ñggk4L+�/io_OZD;|.,É :33i>Q]SxkU<{1o0pXb %JU$!)HN +RRL шr*hPIMhJ3ӂ 3(c,b 3KX2HD#ED(( 8Sx9<+g</DPD$"R(Td"(c,b8b88K%T2I.J&2e!KQT1)TJ%*UU Ih’(HD&*I4ɒ<)2)Ii(HT*M4<-2hƲ( ʒ,Ͳ,ϊqNr<y.8 +KK/@Kڟ`A%إ`'%xR?w +�9x`$`U® +[{La +v,aɁHPQXYOA Eь$ P2%g¯�gd_5=V�(X, c ` tzEJlmw +%W/6`:!l{JۍZ 7�$(OhP eP.D񠲫CUETWhWZpEhPQXkhD(eQEGe}AG|oP0HaFDЧIjR`+/5Kz ^)DpJ"?2څ;7.m^.]=ŰQŁEGCeAAZXy(Y( +*VҫVIT2 U$RI@euJڔiҥJI")ɑ%%J:4PҠ@I&ICQّ$I&M֚4IgjL,02i %JRj,(,&IJC :5]ň֍@ǂTU 8?Ka~B h/0g&=Zq}I.$g嚈ww7qww7qww7q۵qBZS+6sk;wQB$YJE,^2yV;2<RJuԪF(V*W`%(Z*[pePKK Ov1IT&1)h*iM6R oB}S*KOSS$~?@E/Y;jaLzH7H.GM$MĨosMM2]F3\/_^P!t0WSgɨ_Y²˹w;):+@+M_.YczKXAn1lR6y^7`t5beC ۸X{0⠯MQ ݇⿤֗l;q!Z~{~wsb<lwy=߲9\Zg^7c/_܇??=K'ӧөᷯ~y:'>~^N>c?ʗlJ͖Ӱ#UڹzvMi+k6LmAOc=ncrlՎ3_Ѳw9g tΘ疴 C}9zڋ�v CD +viҭ͋g0ihjZƓH3 a\)i*GT3G&)FsLGifȞ`1ɰp'hRQG2D枎٧gO .0V.06D Z"ftDO SvHn${Lf&bJ33ڌ8N]m0c,@BQހ_CՇ&.u`K{ȹ [GYIb K슙WUP4%2}H6|Wd3MF$ʴPJ̅.`O\]1Wu*Wq*T1+4%Qr\tSu2NrգEw]I^]ŭTaԧ+$꡹G+(b4hZUH Õ:MY~?#*`Os:I*lQsLˉM|ѱt@ )ݗңRzJi_e$Ag2ڌ8%x9 + P2M!q>}s>}E!+#--}0·9]G-jۀ?՚t׊b麻1n]0<?I[:>}~Npo>}=߾●ϟ?=?}\_PfZ͓0 rP2'}V.m3etCSÃfolƮ\<=>S]8).$d$9 Igihd\$9Mh +E)M(š&R +2sBƟ~|L=.ӥ3emRA@#L3%ci_"̢y2 (c$D4TL^8Z #E &00yu5\"tH0ʈԸ:"gXn48,rQG +n,THT +q,W` 6,ل9 )`Vp+ L!*˭2՝f9ėE;zd#平6Q%Q5cQEf,ec#,<a(2C wj؍KE% xbCbPK%j@-X$iAA +$*ABQL `hDa5{RU(A] +[PلAA4( =4B+4C<DBL/ң#&@t<A,ԅكjZbjf\QX�? rhŽة슐`v +ZZBSr c讇�; 0#u#;@=A-8l$ՆcI5�~Х+lIٸeX_ojzepRNJq38'-zo}9ZgoM;fr{n z~BLo^x:@w+[!>y@/=g<;䅓N~89ኅ8Yc5j '&6h-_Zp +B.i-tEChk넆mF̠[z3XY\!wz ;kɉ-.!oJM �Ҕ($iAeA;VjYKX VkS+P+ kCמqp΂Ss)PI0e) <aʄiEs!fCa<Ԁ"bŘAQEQCcdpr"QՒHe3fFX�#Нİ>c{~;~k /\ii?%˷So}%ȔSYƾ3_m;rF 1Ǚc%(0@,61 >HfOOv)h5]Ӭ N]UaU!wJ:/BKxf] |+,ˤԳ,jHXo#Y+VLpa+rO/q=[Fkyu>"irVi^SC2i8ICYäԧ 23wDDsLD25qhzØqAcJi'1/3脘}i11Miw*؏CUMB Gy-B f%m|Jz<_pfԓGb+l>K*pC_`3 LiQ5Gx,� ҚHVH JH{�>C pMS9x %G&JyKtNt*tWWSﰢC6%PV&>Nz@DD:R!\"_(~hRF:?raz\gl)rKMq[5]nNJckm5RCKXYf~c澧ו>ԓm[G^@GҸYcTj(|Ymkm\.#@~ASI +1b!z6iCΠ1@1An +63h g!OHy 5/]tJz'uY%{R>Zba $^{�E aʋ9N 'OjBs6JZ)ijPR۠0է7,]V:-Q鶹ߞR*=DUͽwf;/:u6PJW#M!]txɟRE\&#ΕU:V:t+r+ +tc?}l>ȸ3%~IJxR)8p9'$R� 8N1D^))*1ACqJHX4=!% 2 ){Bp.4&f 3�+�ZTxГ bwlیvܴ +- +rkiN][iG&&Fٳ Lpu/\9Z1WЉUJU9reٕeX1.9rl6jr0g!7*]Lzv'k;vk^zMo]2w|zy5Ԟ6m*}oːN_o6{-CtM<vd<Z 6ϙ<~h?rK~<|?=E7?L~_t7>?>|\@^ffiG 3?&SeoK|O_~'淉_%xX _ʑ<=<$W2|b~ZrָK#RaPX\Ԃ爥 j3^Xw<A|/B9+XHTTZqu̻ �l1"Vlqq"#%{[_PB6 u{MqPfS3Ņzxo7 c50#<(d;H혶;{}}=k-Dѳr95z&.YU7̵vAP5^{jGl0 IbRD68ƥ7c&q,GգI],"e%[TBpH-U ^,"r-f +K nLA\tTXBXְ~3 +9BP1�ֱ ~T^eSg/N3-Sbq]]̅P.0SrZD2(Ť/h<A<"0v璛?H:D Ͻs�˨ϝ+T/?/1(yCp 64ߞsntu3HU5wS\`bIQ,a/Azգϡad-*jcFk *4A *,<z*23b  **`+D5M$R>ZLҡ:Sxl+g|}PQy9,zz@ϝ+T/?=F +rCX).TTV(ް)Xmi"¤#58nCjښ, +cd7D!Բ-|Eag,EQQOW[+#HZWLb:[h6`Rθj1tt3o)Fz:+^4V`2΄j"vݬh3pdƟIQ 1`R݅HHDA8b8ZlQ-65E/}MرI}&86q&^۲Efaz+/7W?|,|ןHC7<|/?i6fz8y/p[ ѹe &Yqs?=@WSVOuEe}\6oTheӻȸC=v9Z-ǂ f+$F4wEu(AN0*ŔovEu[,lﰋQiek`|^v2^oeJQ5~z+:UV'9PQq㭡*YT}1i-쑑 e7!6qMîοCUI"ݙta! bEuޞN +yW~sPl-M +J1O=O\Z^ԄOi4jM3퍽ބnn*6J{% aJ5U z{% aJiXajWқW0 m+M{bXcFicF^+"jrq ^0 uoM{k O,0@6]'XG۔G??{?|Riu?iGٿnJWfdhm/dj +h5 +[�C{3`b*te>[rɉki�;;2ym,�g/1(΢Vu3} pmƧ*@d[3?/kO9x{Qx.==A%Mo&p(E]O$@4,^Z#q<zoԻr0zpJ{Ԟ8~UO8<xJ $兀%ַ/VcR\Fe2 Fr�`(#/`;Ew|בuS"BAL S>|MCA,^zݖ٫q_`P>q Aye*`Y2 +V'ښrt +W6=_U+g<c6Iv<0+E+ؑ"X`{2Bmx_E\]ȓsnLrcsECOi*,GU1d :|j9Aɜ M^?ѱn)}5 U;-"U;ukp-`TY{ +`<тuLF.nt~CVQ9Rtg:f \x _8 �5�>c;/NQ֕lp*#g3eŔ ;DI `w^@nQ#PD V<n@hGg{xuOao--6 +ܽ +eVǸKs/�Fct~w+{,R2ygKחR!xI d'*^9YI.X<- 3z5˖*st5&pt3_l"UWJ8HFi!;x*ԙ�w]"6VcndYxebaԶjW(v�fPbǪW�N1–zRN*q< +xᅍp?gn5;adL,BFMvn]udGȍ1neϭ9!z?~u[kNS͠�Lgfj[{d}j +~/"V1a0Vk%<t#72 +6$8{ +zsS<F,+�< cPNR4=]aS/y}=|ym +'IzHu>| +GsN Q^ DwMJK`(LfOnaxG'!~/J07Nro^>\O1g~f h)yvF"K<cf!V0 r pO:#x 'β!iAE!DbyzK-N/W%ڮUǀT{꿅}9Hnozpӿuڂ@wR9(Eey( AREc߾v^ +V[SZv=9am;0 +EhVQ)O9jc93G)7KCdCNmx=ߛ Sg< +@՟}-:BT;eY2yձG|yt/)_+pb`Ϯvĩ t})n۾Zm+:CvGe�]j&Bz1i9Ƣxc�g,)=7E6~N O^b!ħ P�AZcm\蔍[x}\?ڪR}D=Vf4Ŵ`e-} + Dh+}0DȽGlMޥɊ7gLi!go*0VʡaR#mCvDT%cDo|a;$`q,gm?Y-ܛg1gە춴RXoFP'|+p*pm=!+*rg ųtOxBŃU +sj40bd1f,M5,? BIJ,4|k--Qi>OF3cW!h2$Ԡ%9 vo|lYgH N�UnwG*' s5ӏ$ŦŖ~ +HWrglFJ=֪W)bϠ> +bZ{]Ys +i{mjEBQJBk\?mTS�Ǩ#;9nu^߄aH)݄V2I8`e6h`C[o[`<qד2vxV@nyu*6Nqt, ^zB7Sr] 0`-G* b,�)sBu[v4T?#Dp>RH@QcN: 돝` +`:TbG{H3�+;9^R/x7yJt`$n`0r9V$R0RH׀E)#hY"Y.:M2I )r 0|\}ZjKݻ +{t,u'�f>;cbm68qzصދ�4꧘TF^O;*MkDT+ ̔_r)'ICr/kɞ m mL+%># ]:@ &$oC8)|R狀HhْGm}y nUvK#3$8pyψpiXS=lV5/+,ʈ^208otmH3Q _>Զ )[UVf{N'Ԇ#ChĢ\c/Ƀ JZ6ZA4P.#d\z;ֲI;0.*ÚG^zV+"̸gUk:;}LDuGnzxw(-[Fز-V\y/E W'o՞q?ÅA]fۃLYu]qe<�A Nk)˖W]nV);]# )2Gז]L0q.P7HRo +a}�s?nHQ,̸+m"L#B\k|ƪ:@QϞ6XT9`G5( +hע+] +Դto+SI8qty3L|zbb�뮰ܠ=8O1yTԝGRUh-7:l hsS{7 rWXoxy}PUn?0D2E=?ꐁrh\khTcT}MckwfR "W 5ރk&CyCL2 ݎiSoy{g.*r +Aig{ϾM2mA*1G4]NrAf=v~&hUO2CU Z.ȟ*2 `4~bD&tPBF/{=#ƥdrcqPl\{k[yvmY;x]4d/kҬ,|kPqq NkPXo:`O|+!@`gȡ )K|PU1Kxz.rS+4>^%Xl<h{CvSIvGpב@~MtS.>Qh^"la3up6ؿSs_3OmE'A"Y賑/.`*8|m^L[k v-XpU7[wVf"'i3㲰h՛Z>zqqStNf9`k)/,5eotRNʞf-Va\=ŶhD)Ukj<Tl:JZbc(GzӽU[mo}eNj$O߾~|w8| 3w Qx<Ѵ?Hf_RPt_cqur\FsH#J< .Ƌ`hVo 9z0y%J$_B;orW ^+Bd�o@5TkA=n3c|y̳>ODYn*/0Xbf2U6 я5>i .dsTF<]K):ni,խUl_1r0w-`C-©cp-5IKL +k~Jgo4PĄJXZ6#ZSDZU�X$ݠ j(xL!))x.c t)$A:>f)x,1I=iHg X:5,Ԝ>^+]F(XeW8QqKP]9XhFr<OܹpiG#ܬhm=94 gRwvQאGkgT5~/hY-VkaF~-2VZ|%Z[YN"4|E. ڝcJ:W \1Fu Vd�,3We Z:HeclzpLz!2%ֆͣ8Bt0UTjPV0z/sQtuԷ<)Y-V=D%^PL nՓjTF<\D^*\V`DW^0%eJv-Jl:N^`}eKO5Z\ +kQaJd][-,߹ݬO:Mv/9<X<j6'?ϰGW;0Bdp/'LB4ws@|" :SysqYc>‰L91Ӌ`2|bulqVg*r4 +-e̓ry4l=T8|ʼnlJP=kIs"8<8$2xU-*7e`d<%׭2v~$wd'WKSVt^@2.rg#햺dlF0O[3 +3.Wc-Ft[x<ӝL8&>C1df0| ]_O_}3\',Z +Tt|,WEb,C&L 3sm� I#ȡ.}WHmM-+AfPCRwsK{$G .##,[$s3TEwi<&_NL󼌥 V7pt8ZkVm4z"cv^7\OV雾-ܿ&,"xJϜ(TPyg#-|-?dplysg%\+]Hr6N ˡ.xhovƒUOwc$.[:U'ld5[#ک E*xW<f鴑(eeW fb5>w)!F%;pNQmpGoϷ~ &!?,7)g [?I(S}t][/+N(@�IeH-9Jyߣ}I<s,Ư}}h()*}L˼Bꀇg+beuȼÐ 3*4e"=_K= +F{Nxb z (Wr$[z: ?H= +jw$tl>/Aejd�< BJ1\Qvؘp[ } ^)@lm3b�ߣ@EqOk|˾`,\~]T0i|s~`(BzhHd mdSKz9~O&۹nuDvd1\g_=Q sCPN㔹e/ +~ j�&}v5P$$fJ7gIMQo4{??g\8pKfQUŅr]V:ʕ 8r�xx>Ms_`oku,\�F22/i\Xk8",`չJs}nBsuMLw*UGf9Ns!p_ bHbofM ׫f&mWz׿pO<a�7/edE7U\ :0o׿)'` 74/WWl1ڞ~"=_~ }glhr]Cpws A%!=A%SO9녫Gylg?" N]#G ӄ, u*G`k1掲Lr8|\r|y*ǢB8,+Qq&:F16)2jA{Lht~=gj'A8*`LG̶v> SR1M .?ײʵGb1U@ŠWE~1C�ȻFɕMGH̱98ɻJFPlwh7 +gn9:%Mc gQ$N9ImĈJ?TQ<K ~P"гF kqsce;_G.s^ \Y_IE$7`Ng`"ca�o `Oc p GV?WBϹ GYy2b`l!/U{i(2`zlh<|A;\avF;dѥI1c(9; q`ԧ2VZ2,'~lNRxFf +lXd0'_Z}d++Z�Yibn;v&1iYɎ!eUԟ^c1p!q@|KJ:$qbT3!9^`'$ +[ 8Mb4PgŰG".3O`v⽭IQm~΢>jXu#2>&)J[nb pk+"}/c:O6{z*"JR =k)V"~;o==WGu a@Lul}c\SdX�RF�ʰ\xV&NqASMaf[&F.7'E0riIaR2�rJh2|JO˭wj\;i~dn%8\5<WD`is߯iy[j/?O?vIn)#dm?XmZp�5Yk~reվ#w{dc5F(GA7un80~dcr׼ D +�\(T[mPv65w ud`cX@óg'<.3Tkkʨse[a&,g1O.Fe[qE#V4`Z5FzKAH5�^99l,CB=t,5$Δet'�NEݟ4/݄H/U/d; ֗m%n[Ѡ>VUrzjҨ12-d+*?Np|{RFoф^NrmrW?2k,+{ }Nmә K|n- N]dWV;5ހ۔lAtAyP~"�೸( Z'x W>E50\Z$ʧWV%بJ}SgwjIP~ ӗ�$[Dwd@Ash9;2j" ~³A L�Bӵrub[-ZfϝZsrI SBXOP/)`o5S+wJ[dX"8J#]dD5pK(bO,6؁Ϊ 3:ш}O.& ΀ڝd4' IGz#N"z-ϗ9\y{?QC-,4аGM#׀sī/௑u!}=NM#&`>u+x.ubƌpmt1Zsx~ m9{;(R1ƪQ?^`r ˋ?xPXð39Ԙ?mŲ~AC@º_CN l<L=OI*};glkvKZkI*|'Tů$Z ݂x 0r&:PBpRq)a?H`µB,zy66#QN63 0ҠQIq i# wªJ5Dú 9q{TZV0j 쭢҄ DW1Yk#q{;/uʋa~UXo'-b2'^7M ,Nۘ {{ː[er^&"S("n0>Lu J:6&j} >$8-K >DCKl&mљt7C >5'C|HzIfi|K!%'Cc69j_AT!vni,o:_ZKphV�k֡T@.i?B|=c<4>3؈-B?pفȐ h<`w)x) tm='6(s9sRdE&JO`9']9XQ.IOK.O`9']97ȎsҀ%SX.T&KV)3Ac_}Gri;FJ}MXbŢ+JyY;@S[' +bI1eKR(0HXJb RUB=LG"8Uʊ}Lj Ri @ӎV_�LBNeŵ.}0SbMVD8%W,Wr"+C@ܡ僈U^Yh(ȸ%.Ed+`>**yXs<S)X9|]w06ؤr桂,W#[*R�8an1yKqO`/\2&l ~s{C2^IH�s�1wSgp\Jw.)ƾ=cqn'Si^ ˈ`qc0Vsy0s!olɯN""l`] |:0>ry8Dj�1#Q밙U' +捊*NE5}ؤ5&LƋ�KyY]$C<t'TE$;oԍ-몂O˱T(Y~ۄyܞp} Is!ֲondT@od1LKYua'8/f*yueZ.=l<:{gi`Kv,`j#XJ*âmA6[v] Q)LZY(E;W^j=AXAlٵ$w91&|JcB4& 67^ 1Pxy:Clj` 4R109E cY Bgʀul(B"VߨPB3M8Nlps畈Ӆ6}̼xhu\*<q ˄;?s1# 7;4ylA4}/hQ'!\28;zK«c-fny+:qH}]mmO+ֵ-9fSu0U.ɗ[2v~Jƽ?N=%WA(m=%VvWCo+?lյe}Fk}W۩y2ykimt+}qS;'*bܐiU,εxs5UqlA6 zEiP>`O[tNQEE1{6f j)8J+]Lc-[ۤ 3) h α#21'V7ĮieU{36zu0 LP]4eap T÷,Rޝp+2ǣ72>m07v�"+nn XUR/WFņxyeNއJkUP�+˷S61f +n ]v<4{Xv2V;91%acҩ�'VG4-akVGpvnT v? v뇔a _/CԳE\G! ,I/H/g%97qQzk[4T�Ss-lޘp:u4ɡ&PGN k%jr6ʞ8@M"PPލ4L((l;AK~`o[\wn,R$~ "[j~W)zdje*=X^}b%\2˽,3:& 0Rs+&d~ʰm9%[*. *㎻%8i1~-'2IE{ -V Wk -S@,ccmfmQ!)G&;Su1eTwrI 7@!jqS |Hn XmJ/*>-#\fnI32n0hYI[N!M.sxwtO`VAT%3y!`[yPxpfj `j=GVձO*<ٴ?;ehyWTYa\n!:ڻ^(슨6ǵIѿ囗_|}???_/O_^Wﻟ_~Ÿ_˿Z^׏_~SBy{<KC-~Dz*_8P!l"2�6恺``i, ) bK4է*Ff0s`@e5D)LXAl0�7eb endstream endobj 406 0 obj <</Filter[/FlateDecode]/Length 1252>>stream +H}lek�"%Q@5 s@�PApq:#.Xnvm]hedio Y,\UvO˒y.]r_A%,}ӅO,esʽ? ���'[UJYM HtJcI4yOv��TšߛC (鏱2{ה~6&��P׾DIⲝjW��PI (2wݎ6r2��PzDiKg$X��@M67JAC Y(Ee9usL��TjI%Biyw]E~33��Z->I<O Y(y<Ce ��>hE ޼>^ںedEsͱw.d(< YNEH���w7~?oJC?\`ݺ>)KEJf%UFœ��픽E<F L{vз ƌ ^h(.z%uG殍ϸ�� %W<D Qx U ~$8wmUy���Ks ^[D-ߊՕkýIX~4UG ���j ^k+DŚogpk"b!?(ٯz?5y}KBV��$P\]ݸQWSpuGqP\tY.tJ泊e9/GiXZ kA0055Jw�� q$͍&lCiBk r׵GFIvsr[p7gEFvߓ"E7tXtn ��@ J@пlmsX?5r=ZuWS;gyuޣ}cxk?MϑfÉ[,<cRrTrÆ'=d��@|Z)Xg9벝?OjNܔ]s?n&|TUJtfߺ67}nٛ>֏t :.ؾm!y���,(9zv#Ke}3_o㿌.g~˨MxQ߾/4zqP׎Tޙ!۬S;��Rb!@؜]X*v2sw‰v9ig >ͩ_uٺ}$_m7;28]~aiw3 -�Bf- endstream endobj 407 0 obj <</Filter[/FlateDecode]/Length 545>>stream +HKQO邚hFtYT"UmEѦh0))iPAYA."9FnnVnj7pa.$Aڹu[y +do45sU]] �,d[+gW��Hy>vb�<�Bǩ5B��۫gOkd�6,Yjn?8Vݷ?~1I_:״ǡ{RFooN9C9#&GdRG#3|sZZ}g8wDm{]r!r!x;rV +?��kdy�},1��a%� l5<�;F,4/ꯙHo3�@k`\qj��˾F wn.>>?e� ^5B}W27=9߶yK��;F^<0tuG�7!?ٱCq[S}g� n5BUc_/uv�7zxm}v𺶦wQ#�o endstream endobj 408 0 obj <</Filter[/FlateDecode]/Length 701>>stream +HKq�mXf =d-RpAGǥb /@"KAĈeT\l{r*'Cnzlfy_/a<��k<3R?+Q4j/7<m;k?gqߴ5JcsyJik9+���l]W;Y&h\8?rz.=0%b7���w릋FTλO8X86T5 +cNSs>���H`Hngj[?.���MA_"j[a=:.��Z}daKE��@ȓ-dah ���Tecп$b���6<I@V-��Rn7תݢ'��f"8,1ׯxv�� YX1=5M���(DC!3[;>N&yћ���P4FRda>%ћ���P4M?:Fכ]D��@'ڷ;V��7z=Yc׵SJо$w�� m*H@<dTcNSsw�� o>@@qOњ5Ϣw�� /N~? h 4kDO��[/� q endstream endobj 409 0 obj <</Filter[/FlateDecode]/Length 640>>stream +H׿ka񃠩$E +"PE *jh-P$ :YcU$H]"X;X.gpý- >۟ި]S~|fJ|}V0Nz���B@cZRv.懥��F@=W*uVz���ZҤ? 9cnJo��+tCm]g<!=��x.wwmll>���ӵ]Gh΃BZz��Zj¯?SX|PwJ��W?ȕG.��dk"Z Ӆ>}D���cm?؛;H7Jo��0Ug<A@+Aj\}X��`IZ <;��Lߓ?Ȕ6"��Th%?Nl[��saZ dV���&JIXDGz|T;��L4s|N=w_.ܯUw��xNǥҝ ��`[Sq:i31}jORz*��qfs]tҮ?vNxoOO%?+�Җ endstream endobj 410 0 obj <</Filter[/FlateDecode]/Length 1019>>stream +Holu벸" 8$1&`4(Q$.t&0:\Km]{֭:ZL)сS1&&fqc~U=K+���xZ _gÚ;^}ջ۷E=enQy*qٻ��؍ݴ\?9>oI w��qO%+1o-G4ٻ��؍<+1Zy f ��`+a߉Vb?ΞԾ}��$@J>CQyrm���v{Xh>sf ��`'C}==hԄ<he��OB}ZZ  +dKB72��m KDRSXXUx\k}Zw��8Д h3z^w��*ꗧ*. #ǓJh4i~ܵbr鏣Oid��`{ɰ4? Cx&Tqמ~a U:(+nur׃[Ӛz���TXTwfw.! ms=K>vp~vǖ���@R}0(^[fs}KȞmk8|O>���`W)M>G"~{y.OL:ݞ;���UJS.vƥa={˕O9:kiMRK\ %%>��@ǥx(JЭYJHEhWG|rMe,*^B?xA]Ysӛ���(^#:}b/H-~0,rhd=kjvH?Vo{T-}Ϛ#Rגb���L?~ +Ղ2a0ә KwXyGg\>6}l{ͳcY#B*;6Dn3_ʄ_띿׾5)ٿixo=o ��� endstream endobj 411 0 obj <</Filter[/FlateDecode]/Length 1479>>stream +HmLSgc̜(BS\Fg訌 4*"2 +8X:A@`hO=QbLt27˲d6i.dLS)i(W!r=fjI^xx�pvrX*A˂|=& Qы'i ' 49Iɮ,.1L7K?])TMљ>"&���LlYOf)8"qeu\ECTz(_`wg7 滶}7z[u+,ĉ���8"mO;T^X7O^wx:nqY߸T[9e:LJc_]_)4nc_0���8WW۞`Չh OgLD$)Jì4=.Wh Ns����|n$ ?"Q}Ӿg,saiHyV9kt���0C ?񒮤ZJPQC2ϮÜnee(���0hij&;‘=+o/[g~#ӊĔ6.{����"XĶF� +UGI3Y殉ߵ\?nKd+7{Mp{����+m{L B�*ÞY(噢rU5m4t{jl[#E"G +���JHֆΓXB1_jɤU}Ww_ +g60]5o< +���"7:=mGI/PR*zzNg)MISpP.x���^^č5ۋG�?yJ{ܣRfu1УMA{C6L���^B*u'M̩3?@(?H\bTt>5en^ciDVU3e*ߣ���_NNvgP3%a +dN?=tSY+k3#���dٔ>BhÞUG]z4g{׳Z}9c��� +)ɞJD�j qYֲLw>i\QKܗ>~d;?���@2?#{ ?@(?왛N8sޚIת,};iV'����/ d81TDΞg92_ISE>����x{r9B2\=Q{r"MlYO=6j2<yo#���y $í`Jk$w_Qи̳+e.^Z ���@{nE�!%v %(fY}߳lYei %(Wȼ={00�8[hS endstream endobj 412 0 obj <</Filter[/FlateDecode]/Length 1243>>stream +H[PTu%RdR2N4RjZYfZ(A&UTea{urSJ>hoigg|�� pNXKקNP_,렸@  tyms{˕fiؐ���TY.C5?6 O$}.uͪOU櫕/F)}*��0KNԄ<-|f5HW4_}srwÖTyG%z(T�Y_uY\D@M菿b:K n.TrGuol?X��-FC{?F +m /Z$ڭ[g\w<wӓ>��P +,lj=Ԅ4OaXSMinϼ;2J9=>#��P!ԼVjB.i|q&$wHh$Ygc_{]S��vIԄo38~X9R4_mVnLw(|:nO +��Tc3_L殡?&I[>wȔw,<kHregbbJ��st9r]jB,9i$Z:nMqjVa9NA�~njj<w>s ^Un_S{-3bp ��!_\ݬ?C@M菻73W+}z5]o$B5��_-?/ΞI@M菻;f + ҟ8-.yEKƄV,` >9��'$߷D.s5?̈́_ 8[+_ Veq0-%"$(H�>W;vg%\:sn i˒E_4��(?o;?&ǽ!Mn7,ӐwQ͚𑣔~��"7m,5?<T8}7uþ-?zFM+��@؈hIywlyUjji֞%SvsPdJ? ��DDq5?sTs۾wVozFR}|ݳCUi���EMԄPv^oV3Td3~;~�w� endstream endobj 413 0 obj <</Filter[/FlateDecode]/Length 1596>>stream +H{LSgC"Ak0:YP2Np:Wpá`*S.ea(V2ʡ==pZ,ȥf4h&c2oHH&3Ŷ7/ {( +`|- & >v10a$$$pO +cXL|)p睑_ںESZ:lS���lmYZ%̬݁TWGqN]@cwKV}ploGSM���0mAk-țp� & S2Ea:{pӶs8n[ԑ���#bEh~{Q,fC7.z8SG��� hx4ݟ +gM/YG>k /8vS-SG��� E"NB�NZ3t~{1��7XB,FK?LIl~ohy6!L'���xCrp#x`V?&xnFHw6C=xNEUɯ 0u���`Ҏ,!zۈ`V?&EVRX }.NΦ���L@YfWZ%}0'{~MK^.W|DyO�� >Sv�Y X3BKNuiQ߅^z<fuV̴* sY˱}3]Z+)���(s"8,3#@Έ~@U|'=nA0ZFˏwޫS1ۿl#!W~7"{#���&;)[b�_y̝GzD03kKKNA&=d{7T&{јrQcnņn +,,J���xmեSoWqZ +_8O|W>Ø?sl"3T }.z:c"o"U���/Th+ wg-->XHE_cC0KCUmd[7=MFzHޡ$wlm M���xu]';]т|UCѕ<s'g/7luEVف&Ϊʊ- P���x%urXSA�SLnvs=߇ +ǺKhY{:BuEs9f T���_ +mr.+y.N#zFX?޾DeV_Ԕ\yfcVWvH$ӭ-- X���x3#TY[Gx,Kyo*oҌOp>Xj抖ct%<m rm=M +Y Y���-(EΉ[f7y�d9sc+p~p;}^Dc!$Nj";PVsw}ͧ:LȎ1 ���4U2W%I{Mi7sџCؔ3+5꒓Gƻ1#� endstream endobj 414 0 obj <</Filter[/FlateDecode]/Length 3936>>stream +H{8?KJR\R)BV#=!l"Ą3.3c~Ÿ̌KtڲecGlOMG{=m RޟOb]H\ KZo]u~7]ZD `0} (iЍ^zPϦYqôKjK +ѳﾃzz=3n1.|eh,Hsy) |޴wЍ"!&h{vc8mfwo^H +^t֖y޾pr\z.=cy NHˆHL+Ax`fx^,S*zeOBXѼZMo\$ѷ`0tkd$%a,VTe*aͲ堿J S `4{k#98[!;7! @9%0sQkrb L))ts\P[@ɍk6 +ˋ +ٕU6Yʩ,C\V-a8,].A' |e1y$a\6(en28)Ҍ!N cN 6agFh%F:3]a  #%򠪤 jVcl\ _7%}]HFy{+eF\u>6Z()фvƲqG+<v,?=zǢ ]s ?MAUS~rZcAmvw|i^3ܑ\+`;:}7"n/4|qW]8zz,L&NvدY;ngxk.M *53 0}ҟZW}HH4-'TMebJ3hUfZ{f6D QPW^,\+3NoURP*c0̬AR\dEοXQ .R-B6} &z`fn5;wچ{X72Ѿs[zBc  ;Fn[MAJ^B0,csY4oއQ5]CZ_'t~΃ #dO=1q~D >?gnoM;U`"gG onJk��x~��M�h6�Z]?*Κ;f6F 8d+7ҿvfX4ZA6aU +trJc0 ݙ#% +0TA} +P[.9;u׮y af#[ovfpr/[rG.%{G!O|JHZzX29ѧtc7"/I9,=uoyY,afً(P9+[J Jh}B׿.G0vw(7n4В:KL7"n/$Hp%}CƓ4fc[_7%Q���|�.`(?;S C�ft&Yo;T jڦ$໘q+zddf #)/UKAo*0s-"wڻmI%NzxADc KSw2TeYY~E"Wg,j7] ?;Κ{57vfp?H|֑X4sϩSWBA߾Ae=f)l:up~ijk./(To?)C[ USQ:i0{o%Iõ�=!~P4�e38^Н=Zn/8mqb?CKL)v~afFDN`>M%$@UItVhŽ|M + \t.*r tkf޹ vE1,kC;b>|_ C]5巑#G>K4.3a]Dzx*l^'3R-\a: Iv,L$:]�<ioohrh8Pwq+�h6q>gQx`fx/~;|oht~v\WsLW(˃r 07G!C:_YPg@oH�EQ +*غ*V"jUbeXP *A$ Uv-UKQԩ) 5_RGkm;ӊ?{fK&=AGEX qZLL5]+(;3UHt*vmp$K gZ i潯c�@ @[y{o{3@#4N|6l<yo?M}~"<6%79zlqewt< 8bdpY~_؁)X|~9eOTQ&M}[^u yߎZ],:򗚐vhJø U��bWl/^ܬ`b 6?;D#UTۯ5aM�ik"Sɬ y[8SKGb0g 琶(&dѭWTqfip:m<+\>aNc( t~BQ+VwHb ihb ,d{Vl ٥k�~8�Y@f2/JO_O�A㑆`3|\7hE <V$:%S_ʬң|]Ns|;�.8(V7&B6�BY2_+_R_ꭟ(D.݉ 9ԌALjnY�w6J>ev.^&5 X- *[#jnm tAQc?Vqv7$?оTk!\nȔwWmu/k@G22<W_@g Q~5y{H9YU$Lz_Jh W5sE'FO#X=@4 ]hk T&$T~%u=KnfaYd*A2qSŢA9:]NLJ+׿r)i~NWU`* B킢^81և<;htɑ/9dZ9Y޷k��=>%yQ@ӱF �&Z#Pe ''sW<-Up[ltnU,w +#=s@4 ];kx^(Y&hpݛl.y SbX̤A43#cذM%%F˃Sn&]{Eld vQ&dJ +%WR_X;X 8bȝ|T^z'6I rypǐ;E='⍂ӥ=9V`�ێe&d?Ma;LD@1oXfH!PՆDdy8�\ІNn(N455z里1VwrgMEVOu +lMo +n()Lv8$?ΥGpVFnD饅 tQ.7(Ux*i'tNM0Θ8 vsgpeUBnQO]`*KX +��( endstream endobj 415 0 obj <</Filter[/FlateDecode]/Length 2379>>stream +HkPTrx55$FDc%ڈ5MbED(! +. ,=YnY`U1 + +j$ [ngdw�;B;)?& 65= uL3Yd}#ĥ9qkp4k'|pԤ.HCF zka^a2sT fVŝGgszO1Jq@04[H5[gOJue{}_><�.c^=Iza ֖1$-İJE;9%7znc[bd>Bh ts4`h_|dk<U^̮ +�aMn*)BC ͆yY[×̇o6B"J(NrNgJ:%h�(B¿΅2ۦç`@g, *,!J;H5M5^Fza/VVFI,"L_~pN=ݺ. ߓ;BOQՌib)?P`+\�!kEw6,2w3�zFޮQҷݻx\oa,HLr4LsE-nt:ZnB\Wk9ç`@C1ސV*I!kVW~҅;ϕ/uݩ'Ĺ[|W\oE^i* Ѭ0 C߿A5ͪV}!L2TeESߐseޖ8˝�WЫߺٸYz-[7q?"ȳ3֒ߗ3ZF]>2t@mGQSq:k{?0| +4TuerNE;m�jpЕJ.P!5z{wMoY(:bWEHs?Bh(ߘJK+uç`@C̎Vd<օ/\p+s4tv[5 uؾ$ަ6SރMv*QvFI&Ϡ::_+!4ueYç`@|`#t U*R5=+<rZŒQS 4#lmw NIEM䷩gmЇڜ +~n#Pw6ͩ(LsOdb䗐䆐5-)і5W�Ч۸xn7n}b47zx2U~n C#mg]zYR9ys?Bo.i,+ ђ`TM5Lqe~,Wt˝I"g4Ų v1XY[ܔĹRLkJvO]4Epb=s!ZԒ^*I35>^6;5*Eglr̅ ˧_PtdJK=Ύmqzvn+h:،^fPYBÉLr9xia)?M]y:?W!n )y=4 }c68n;,7%qieA鹭4 ^Kגqia)?p`4VUVB]fU{OEEW Pt˝z {%Qo2sqm`gHزM T}>M[=K(~"zAUt#Q) +61>NƄN*˛ezFxͫ2t{k[tyXR*:$)<|'̙#lmlOO6VsE[*loz|qA|E!T[uç`@Gղ2;U_h' ~n?6ťˏbم#{{]nltx0$^nrҼQ*inV"RzlF%y.f<E!bXj}Ls O+ lq<(nf}ƻt/Jo=^4Π۸љ3%WG=CuVs=9=h^.=?>kP~v"?Qt~aY?0| +4M\Ɍ8mz78;0M�kL!^V*4`=0j6p?B On4miFa)[�" endstream endobj 416 0 obj <</Filter[/FlateDecode]/Length 1366>>stream +HoLu�/%*fԭ :MBZlZ!+ Mb??y"GbHNԜ)gOvfGW~w?'>ϲ"pY}RbĪtV2ku3��lɞ\cLD)߱=ߵo?@-"DH|7.Y?N.�<>YrhHg/?/(cfe5~4^N�6k‚aNb_ +ڠ"ݴ/qOZϘu7%&�o9A|)=/o[_T;!ߗ39(�9}[ė�+iXVjxf6>aB, +�;״={;A|){nL}0];G\&3P�WtR7+75hL{6f'([��vuWYlv7Ka�OHNӒlhP �ཚ f1pv 1/>ݞ9ѪZNҗVdn? _16=QWjt:l�>v�K&l~1X Kv[;x[oZ:mIпO_#fUdv!y6N.�xFZBG?3itC69"RSS:�SlwƬ~? �~f6w +xSN雴{r\tYI62d}W^�o5ӟ{c:A%=5aL7gDнz-,R"OIf}l_?x�P''ـ] ޒ-+Vs|1c]ĮL,l�Ps!h*ёcM2,ڽsZWxk-iM9w�@=ϐfAIQ ݝ1cMC:?bPqLd).t=bؠu]+Vt�Ɣy5f`Nh8.r68aחXWTټiaJ�_R%^?g}{�w$o2 jLHZM +ss?[ x%Eê̆k6aiv�Pf]!Dm +Erk W^:.$ђkt�<^æKsG?d\wZu™ofOPdsCqj[Q?�%Y93 endstream endobj 417 0 obj <</Filter[/FlateDecode]/Length 1912>>stream +H{TeA *JE vK +a@HYsIC YEA\ED.rdyen20܎XBH,#965z9{8aߗ�''s_%pY 3f +}$Sg`y_1}?o8f{"TƆzWm5L)@KunbY^4<h/9S����!yLtS_C�.㿻ȶsVc8Py9=g,3ig���Cs#}u!zWe9Zb8k<"VxMV=_mqg}]S7f8 =>���E$'Kz5ߙbn.ry~7yҟ?̦X aSerΞ[Dz_jmz.` +G���3=~ENFsbtBw?\;}|8ޞ͜G� )̛Dzƀ)nӞPzv6UcУ��Q)ggy}E~f +Q_7.?@{5m)OӢ5 #X3/z=37e6j}&\J7l'=R���EڒUjSu7U$cp/N;OdAH4!/0X~ܼ?nM.m^c���p<v^RҾf8p9ܱoD�Ú 4637vQ)x/'' ���"2e9>R_IU?_*<];b$kIrut$ꖻ.~W+^"��`zbcdO&Dk:`ڴ9C;ӭt{b.c 9>[˩ڪ8귯V7{TG ���#DB-!jר͍{wL)X7cp̆7f]fG bLK4Q_ﻼ/ώΤ"=Ǝ#��`sHjyZq_՜}-Wo \Lϱ%3v +5gULznŦ_aU|{c��ac+۵JVNw?g_· 93b!A{/}eUs~c; zsgݞ/��@�Nd׆@Iivh]QB +;h@XXpI)M4cg <ǴܾV"6���{?D~^~Yͱ?p#F]1"2jG�1 !ēlL + s]o۸/nogGܼs +}+���`Y$%&z_JwSEΥ/~*Q4 &X3)|%9R+1hwL6>BхO{L[���ȑǵL>K̼,n;äPbihּ|bLm8]ܧ[^*nF���ޞ )L=`y8e[ε-EۦtiB�11%&KTzsa@CH�GQVZ wo���܇Ɔ^IWF{Go]tLg%G7Tyd4kON9e-Zjy5{#qIvvB&���d$`T}aA#}~ߨN*]ĥ|L!DVС'g:q%Lco5jNQV/V��jO>Ew<7._5_ D'|WteE%�<S� endstream endobj 418 0 obj <</Filter[/FlateDecode]/Length 1055>>stream +HmLe+Wn6sZ7nQ ttc0JeG40s}Ud}Er,Ucܱզ=):yxw_R 7~gAC{bLtxN'I߳]9�uf!| kgVD�z}-#0u-.}^To?p1^�kuF<'>`�Շ߸+^ĵxɎ�09C]GS0os=k虠g{c3Uw$�8Us:;At +^xh[~CU]�p|vPA?Na�M+ 2}Wb?>˽J}g�nޅpӥJ?Na�۳^~φܗvUޛ�v l|SSҼo_-xZ �z_U; :aNb{.;Uݡ�;fϱg�ġ~ןu] +�b2?Na�I+\&֔?XoԾF}�eQ|D?�}ߒ%ʍ#y7> ]u�e%mU=g�Q򌦨Gz΍�p}VVg�Rì墠iN7hwx_^k�e}K :KVwv |] �e ++o7V8gxr-DZ< �Ν+~] :EψӦ13}C?udܭ{ &G~]B^?Na�XRNTGZ-V �sȫ9OS�liD~]e4^,wb�H%=cs :@Y_eǺ+#fc�H&G΁Ymfr��Ԣ endstream endobj 419 0 obj <</Filter[/FlateDecode]/Length 1061>>stream +H]lSuS4@!_0Y dѰ�A@:-9tB{Z<g}MZ蔗�;1"ۼn=7*?'ܜW([ +OEccg=�0.V-nfO-{ߗ>X!$clע;�+֎O4`X^/[ڹN}�Y%YwYQ} 2<^^i}y芘� G]ez?La�J3G?5ȟ=j� mI.[e�_RrIn\�dGO|]_[ҽ"S�n}[,F\kDm�tG^]nIJ?La�]9-իa;</Y*~@-7e]ҷ"S�5 +K]<E L4g.(gD?�)Πz:-AWu�2_gXmr+ SAd +uR>KX MDKw LrJ^7w+_[n?lK<v~N]t7U4Oܩ"S�f҆>bgF&w7�n}_]ӫW] 2`zQSև5HDw'nhKrEx�HG=%s?La�-ٷY>׌I?>�Nn-_0'ٔ[YfkSDOŶ;_ A;>cN)�",Um6}+?: � p#G2w&�6 +dތ[W�%vZǻ] 2@9֕yOu7~�WN6n8;= 2 ]<UIq;N:?��̦ -&s??La�H'9Ojz9M#�0/.4 2 =XJmޘѨy佢w�L endstream endobj 420 0 obj <</Filter[/FlateDecode]/Length 1326>>stream +HLu`6榥N/l5S.+KINLE DDA!)ܴLS[nY_F2-{?ݾw{bȏrׄ&msRժ[_,X־� > +Ϋ0WʞjzgE|�,'ߧ,v!S�]"1wUɩZ= V;�:Ǎ}= �_1pEH:YVx0o�x-S_??�̤0]76ߥf�e\YcɎS�|Q(¼+کZjU窉=�rڕϊwOvS�|uĞ#se2ׯ~�ʩZRcğ�.'Lk|i/R7~?Xl�G%;l጑ڞc_ȁ-Ǹӛ=Y=�/$)6XMFKMz�(햘m?g!¥Z9K�&j낐Cm3J+S�)Ѳ?n=6Hk);eMJ�(l(U+Q}�6ӳ?ߗ_i͙7tBg@{)9Nd86ʞ;8t�Бʹ1k.coMXhO]M~f�GOQg\oWfk�@[ǗzG|pm?&3eJKQUHppg�%"Ŝ{ܨUw*D}o�@UI䩐ҚAoj!zʟ߱?�QA"쾋Dzkw�M]Zniۗj{A:;^{]7B2){~~Sr�u]8Nٿ!^ˮ4oH4N�.e?rMNO vtvzGy A#,4TL5e̘-ѳV'm9{g\GiZv:򷷕`ZG�:Si"͖@W#e-/1V{;A) AwYnW~ausR}�^ضKQEG�,mÞ7 :JiMBw5Pnf(٫w��nOK 2FSZr^mЂXo�NŘyv beOAϰ?�NG~oΞY]ݭ_΋+nK+qY z�<9q|֥ZNN}Z3Xd}OkGD��m endstream endobj 421 0 obj <</Filter[/FlateDecode]/Length 1026>>stream +HhuOID?$FQeJ2ykU:m2\cv{7?_v7=栉icZ_*xHKsHȎKUߑ1_��vkbUC[�ʉ~[6?ͺY!�՗X|_^~[1:At +�ERλH|Bf6<}N@m|!>-v :�͝O:\aug{;�ovҘ �\9Q/.;f.sK/�H]߰?Na�q +nO_Wa�d߆ua�EChhV .3l u �̏޽-2FzuW[�RmF)�_Kʟ;s:sL/`ܟN-)�HGk7,pGۣVNe@s9 �N@k1O?@9wވw]?Na�@UI;Vߞy9\YF}>4u�3+"\<P תy�d{n)�H^/U=28_]@NPK]o?Na�v"\6_n?E@l鮴 )�Pgcxi҃q&.SWH!߷t+ +)�Poi*Ql*ˎ^0[^BupZ`�Q.<T'q?p=k S�YrѺ {F�R mmt]/?Na�@f"Qj:szJ'+At +�2_ �~}o endstream endobj 422 0 obj <</Filter[/FlateDecode]/Length 1078>>stream +HOUuo36r+mjٲYBh.?tw +ȍyW^'3(7"܃M_ع4\(-urxsbm}pޟzmxT$nMVui2h�e<M;_{39hłX,k�ލ~zjIuWp~�)�|-=^;)S\cynAt +�bKR +|1j[fhrp]ss"ýwݳ?Na�@lJ.~Vl_'gnMPݡ�\xqwӽ?Na�@lK̟g[r1.5ss)�}3 REQ·Ye~s}M;f,?Kf;8�_:+~7U�ވ/?VUynAt +�չ.cĶPן_]sN7 :�zIɘ qRY;�gc VNsg)�S5G] ]4M7ϕtS�)"w-L2CWsӛW߹�D\\6G97 :�WVm"hl< ?yr˻˲oAt +�3om8a[;˥l~.ǒKoAt +�ӜEU{-sM_ꗓ>vsQ㽲?Na�@|[]+j:? b@p78 ND?��I+DNm㓩BPiqZ m GQ)�5xo]#{P_ƒDս W=^?6D?��i ݭ0W}z ҒÖld��8Q"*_-349Zٔ:ڴ`4=?Na��ʝbGL+Nt46Z5KyWt)_Mv8ɯ � endstream endobj 423 0 obj <</Filter[/FlateDecode]/Length 1449>>stream +HkLSg*i+u&.̌E ޡfNC*NQDÖRi99"xNEaS7X-ٲ,3z &bz n{ϓ>r"oN'@]5w\��Ndδ?Zwc /}:ƴ͟I!p��+CICxgYh <hɵkMrxR?��yg![Et^lI gw'r3xR?��KG2 +"us9yCe =`8^C[s7ē��$+yKYtb.0ܴi/jlrsxR?��` ,*NIw\^թOt�%{#<B@ų#RmZhl]ᚏe��J@|ϙqg;EنHҵպlB@+\煉j6ĪU[֬UgOI/w��$J%/ W(*c~,Mn?%&h8heod<?��`Do{bg~yW[fe5=@k{Ir(1y;5Z�_ߞ>>:��idGebWrkJ{P&ts7U :L$fM]hwiIIs��0GlFtt.lnJP +`.Di2Rh%'Y!:&ܴԉr?��`%#늳& /"u=>i1@ȳMG?d(R8\]3cg/=;VIn}�� )$R/?gӍ;eh�4{72̠ АNΩz4X牁cֆe^g}��v a$2hhƼ9r vƎMc#׷Lhzۻo}D.pj}ޓⴙhM��? rCy6G4Dw&%̈́=I{>.>qJo93f=K&Ѿ��Vz ɫHwR]ӕ]wB`$=c_MiOC@e InmX3s��$1G%ؘEs})}~0+{=XJ:xxovHJZnqΤܗ��%pu&ݑwDbS8m@@#HAi9F+i7K"y��jΞu^%59鞺ѨD"@k?Vi ē��J8.sMJKZo*H)7'�) +0�q endstream endobj 424 0 obj <</Filter[/FlateDecode]/Length 1077>>stream +HLuBFkMk͹t5c-:8CTpӎ!H%, w#!5F֥U_|Z[y_>瞯y9Yem|^mn68*wjVSƆ7^,X=lZ�<sv}0O}kߏ1R<wKޓ3;\D?��&.'Il+2n3z96M g+ab+\ yQ)�@zt{RSfc֪χɿ%k~mVwR�HHyY2`z_ 5eȿ)[DؑR��۸Rl_ +gfSXw%p+~94ߺŖR��$~efegmgeGߗˁZ}}0oU^?Ja��TZpG w }ڕ/ʿ3ғuݓR��U=*|5F)C @VѸ]f��.eonN0_s\jb1f��D;+D^ciR6<gL^ ,׃S/� ,ۑ)>/?>9UvupG OȮR�hHYm3?p|2iCc;JvS,� Zݗ, +p7,%E4ע*� =U~VacK|ߤ]U^6dQQ)��"N +s3kߦP߅=zǮR��aϋw n+)6Sz>lKQ)��*t\_  }P{fʿStU6v}d��r>-˞9fcݦvOΗ}B=}}u *� D/,,f:Nk) ��7HMm$`_"W.nv7�b + endstream endobj 425 0 obj <</Filter[/FlateDecode]/Length 1034>>stream +HoTU=%H!֘> j"HI0Tnmd"iKaJgδt +AX.$Fm*ڡ$h gw"Lg_!fvc//��M۰@T5Ͷo?fx*[wG6iN_sz!��߼lq.rbmWAt +�3y\ >ml324ҳhV`>mLvkS��ܛK'#;|ȕw +tu[e7 :�@jWf[˶> g5_"m?Na��:S+ _$Şz@u`ձew :�@=Ss(v3 v{.S ')��sDܓV϶VK]mFkke :�eQ~g-}s<;/6ۆ˛v>&!)��:oV3?_B`V��3Xw㧻Le tP\2?6n&)��_c?b-0ʱgٽ?Na��ꈅؖXUZ#}z֏lٝ?Na��VN|5Pb֫7''HK[Ge7 :�;<[<uTW~Sm֝VX͒��1isb}m 3[V,Uߓ1>xUdw :�<H2?l,Kwe^7.D?��pW{G{kwf)N߾DzS��[ĦsȠmNPݛ3aIoAt +�0k@G |{s{VKߞAt ++�+Yh endstream endobj 426 0 obj <</Filter[/FlateDecode]/Length 2489>>stream +HyP_.15ZGkꑔ6j#!DĪDQA>r,!ʽ'" +U<B1Qj1u^2U^X~ߙxyyUĤXAcrjb癬YzBizXU8sJOa=6o{ggSAR<09;{}7ݹOIW*a]o(gA*-p?ħ[s祝a<]g(gAx㾭E~+l4{o5agy̶Ƙ?P$ qp3Qlh̆sIU'ִ6J}mm1ƪ.y Z5*kN}K${<AATo2{?; g#pvmM1Ƣ{PZ.eDEOJ檨  Ŵ�⠢"<@L6"&zb@EVt4\Aq^"Neb8ozc=7\-Ll5%m,geZ5φAAq[J7BX2!XT]nwW[[x|bYDp7fI1T? 21I]Gk#-SX<ߕk=$m0ƪGr}>a;݆AA&E1n2ojއOT[jim0FCnn#^Qѓ͡u *+A py0  +}"ARva/o{G½hj^Rz 􏀾s 9?UXVPsa@AˢP 2Jn(pܓO$|Ve Ukľ-[]FפI}Ϋ'J:w2_t.[hhVeWp/" Rq` +eV~a4}Ys'VzQ\d=4&f葔XXωpAGDm>AAIkLeS^=4Ƶ?wvdņl5D˥6˩MR]Ge~?ӕkfqʘ.-mL^;{lf^6YOvR{2Ѯ#grj"E^Rk"0Y^noo, _ڙvОG'fm3MI'USK+ 'Sk$޽n"vMfF6#93 AR,S?]p3{\6o)lk5'8rD_lNLݑQC1ԎOh$Yr M֗6fh)0$P\͙uo:ҾdƣkS;iޒ6,svh,թ`=D\| w ~a憼()YUwWʵ h=ՂUlS0'#xQOieŇA*J.Ad|ggT]=5?XcʷpםNvfz`@U[hӪu4r(iGp}F+$K_~%l{Z;\Ҽ]Ok +la==Hߘ6Œ@Ff_rL^=z)lsŸA[/LvAo[a +&5FOzq}v! 9i.eC7=gfpٝz\͙lLX|1d.0%7nOjQHp@[RNZ[L,cWܳL+: Hsës|$ޝm{TUѾ&rM +B赤W\2Bg&L(Suj};xO[ 8A rdaγwwsݝV B?3i4{.EE}R<:3yr8Τ(*]f +c `GwjǨT +<xz>+ 86'u=1?m#7`MTO6B\ +kLi3yqM)OS2\ftl+ BA "EvvJW?3x4{?ЫRT{(gh IV<!}yT}x2B_V&RjۅVclzj<}} +S뵿OIr0]!?e*68Ͷ{o֓݃exn˾&mVY&Yc.0־";{PicR(`$op}N! Ήo6 .`<{?^arܣ4y;0 �\@ endstream endobj 427 0 obj <</Filter[/FlateDecode]/Length 3372>>stream +HkTSW/1ZGƥGZ: +8ť.Q>�A|d& $KEXaqǚе4wcc Mkg=?A` L4e~zt` ]IԳ]kX]X?uSѷl޽<"X`ce]fkPiZ3y/A�݃c&UEIR~9:ѷErNP֬.οW+\oCbGps iUJ+M^AA66= >1FA^݆sW/ތ0:i4I)慕5֖|WĪ.e}Aw~장} S_yLtPur֗)6./jŪ$3`*"M͕Z>^BAD6) ;4moj7ߚ?0)\L޻ VLŎd5^6Ǭw8_֬.98 Xtp.1+pW ~=JZBί)zCi #aMKniԩ=  Kvzth[흉k{WG<QI;;_C?4?dV Zy&¼(Sr\} $>'YKܺv_ᛸ{F>-HG9뿎ѷ+d~I˟OBa}cbe ũ^(uIR]  / pL^o4m}?W- wk f~^,}TsM\eO@{ ח`s̍g +jo&ZiaK~5#A9ŦcrQd5^ׇw&V<{(S:bfz +FW0&2FF[ɿOĨ߀^ז|AɔD!J}f?U]"1ǶcY) wbtuYt{?Xı{Ԛ^!5bTb|+w9y'JVk-i1tx~ζ',jD97p6ց7WǂƇ>` }s& +CvxCt<q軻UoQ΁-O)i5PۗR'f]�i(<m6Z߁1AY]g.TY#"UggÝb-l/LݹEX17&t]rASy $fe�UֆZ< ]#D Ed7[뎚1T7q cڤ(l7)wѪw~ xK3y R2:Khȧ?:0RakԳyl3`㓗~  �w')Nx\9o*t?֕uv?0)  2<j9pt[Y4p@  P% Ve14yIcuٸ> HggÝ  CacYZaH�O  tvf?0)  A<}+OJ{_HgÝ  |#$k gwPƛ(S]u{K惱~`S@AoGL$,ϯ 6_Cuz>?0)\O^N04y9Rq`BFd=|Y{k7Nj}T ~2T(DA\RFvUwnO,>:4+  w +W%A%p+kf+6x}(tR?ΆWAq ^L˖L;?mK'۲4kI˜  w +W> ACڢEG1xdPkmZ ߽" ŻP :'~ƿg)|t#tz?0)\lI>|w=d +lc{Aთ T1M~ww=;t?= `S(jD߳}iZ31q#Y#]`Mbso2ȗ3Zm]:z<_Ѭ5KkP;\weoq?g#vx& eo=ﭬ;<HHKTy?EzKvzs[oUg`OG27<Q_nj`]XU4Z,pF:<D~Sa_s5Ȟi⨚G1Y ;q|'!Hӗ-c띇-F=a~oAqM&VyfŎNN:Kjy^. +cH?0)\^6sוeu= UC( M?ƋfET|mle567<u='F-̋p|7pQ9aD +F*Ms�?@e ȍMkffiV\?dof5:X�u7j )sT@r$iREVLY55 .)GyuWr$yZ YaJV\(\g�՝mrg˂܊Xee@a ),+MmX=#)ivBusKA~p7G(ţxpcP`]˳k%|?\tis?Fpa�jV.`Ӳp}ӛjwy1]y͂0�w+OFV [X`jjڸ$OdymyF�=P0 vB왲q\d1P$k kv]Y>L W$ґ.}xW;o77G(ţxcL[:|ߺ 1\? RU-[֭BG`8- X#+˗O@j?D}\zz<q Y}*P{ȴaظ~Ŗus +ab]0TR(5El]*4 Pǡ5TAVDާsdi3L Wc͜e # ֯4oC1@�Ƅ endstream endobj 428 0 obj <</Filter[/FlateDecode]/Length 1917>>stream +HkP֕4EFr &&(TAPCH-h"'h�CAP'[V0$eTG iP}u^}oynBז-'f`abq2t9n9ͰSOm]9y$QgY>γg=2��CbmM}0'ܼGmܗyrz[m�O@ +}<XCWu^~Ab փ��(c7NJRyNCwmH/O2ϬеdשOjukN=4ilf~ZYq\X��@0\:C1Kx&Һ\`=Uj/eKS?@H?{Gm$ɕwj>ްqhsz!'^}J"a=F��ii,=V%f1yY]_~%8!}UEț{͖t!-<赙(�� x׋hNJ Z͐SL"gۑo;;B&̝Dgn7 :e{Sx }C07yb#��&kk{RMXΟ1=I{?@H?FK3uV\p֐ZMш{kKK֣��`E%$&@w&ݕcuCuMއ $՟U\9ȭFFN=PUop}x��mmV_eUW=f:LH7~:)9[?@H?>o`  OZ`\c��x--;D`j9):7Ǟiҩo:' ǣ˚]ɴ= ey;*`%Y��<jk^]I +&2hW%ʕ]�]i4Yn $6ndwQ_qc +۹s=}/ʊ2#��x(K ~RMMu7᲌ $'N%)(-z8 5gjͿG>O]>[,f=z��fgcC">liaʽ)ztzb<![BGCJ@�!Axٔ.VԨyǟۏ7=w^5g<a=~��e%uI4˗j9-osG^(0w-ZixzNw̗qZ,���_\]V ZeF]mgR*  $O.,pRsİV"��f% }իKtO]<w{1>SS~d3 $O6B#kT_}d¡t:EUbI�� DB>?yws$)i?KA�!A`H:}ۏ9w ֖MgQq-{;;֟��‚lv{Ndx񜪏#qK,ﳿD  ۼy4XTT3hήtl}kW}/b}��0}/$nRqA7F~:_wm P7RR= wΥTϱL��`Zd?$)KTt/N}%2o5#wF[bB1uHWtΣJx㍦V3t"6fښ��Slf;wOFo3tYDF<CN"zMLl>%QW#?4FuY2� )�M + endstream endobj 429 0 obj <</Filter[/FlateDecode]/Length 2282>>stream +HipBC8iʌON҃b܄@m.G6>"Qcc0mY,KZ+:ل\a@L鑙KNOctX3Ͼvolf6��ؼ3ѻMO< g3U6Jκ:g*s1`z}Z"L깥_/7yV>G1D4 >wvм^<)]c|0׵(8^^:FZ϶Q^{ji )iy^ݫϽ\Y]gl{.WaJ7f&ϻT=r5aTUK{ u׿|{{4-C켸a,tE7{Q��껅<!]?bǘ,ְBw ~D=A}/A0 +²) u;=?1:!7ud ]inѨ9}Jˬ,M{zNdP-;9;?IZ34۟zy␧^/GGmI]Խ~w]:qvO|nh?���IItG7U`?uRn:+9hA^]6Ksi˻{ {xmG6W.F G=?Lb++'{\G6Z/g縇R\Dsq }1>1c77~")Ww��ǹUy\>VqDq7nS볉J@h)F|w=*셧PXꙥŖ +gv{2crPq8s>]KOM]|GLfX͑}aG3YCtp~s?YǼ(BMU7=c~,==ͅ��_{% 8oܶ+Z R Dx<c +3bKtM-fKOZKɣY;-V^2{GCa;Zh϶=+V vO.[BO Pt:u>c.~ڟ젺h'znSvJ?l{.ud UH~{ ���6LM]仪R`Qaj;GN*%g ?&F2~z0B~/IsXc5z|NdHmY}`-$[fQbT~o!}rlEuU}oDz>(/j{G`km򱛍SoOτz eSGņ:i[$O +:D<Okp!.sC?R] 3]I{��@,808~Aa?N} Ί zi(-@Bg+>wtBDh.||`Z +>O[ΐS*{kڵ���.c#dKѬ*8o|={,ܦ%?Z3^7{i}U3h1xj{8gծ��`z*搧z^ӅIr`)R T&%co][<׵4 k���gOzD ǚݶOQR/1cj:fVPz����LNd: QAl6YWNIb(����켸a5&ꇮ $ΓV(R?����0l6=wg\NoZl]hH.RR�����[X|jي#@h)�����}YOiu +ↇ<יl)BK�����̛܍%?<_%%?Z +����y9s-S&Z*_W{lwKm1濠BK�����70S|qoיɎoε=WdBK�����PS l"&;jNM+3d_BK�����x04VoG ?vMT�����<8c#ƽ/׎ K28?Kto?�*' endstream endobj 430 0 obj <</Filter[/FlateDecode]/Length 1641>>stream +H{LSWC(%QB؄{J`|׀1|PPm亮Uyl-�Y2K G*'sO;3g2wR_uwB!r^<67Z5.e{UYn܃it>� @!dK [B_5w%'`zr,kF�B3#u<{nSA (X.I|_M<G +n|P󣂥DXޫauV]QAD,x!§d"h=o?<rc%).֬lELhchR?"䎑Y[E99{5]!BuM>,UssULj-`+$b1pwN\G,V.ۥ75zڈH@p;{1D!jl.̎#%<G,_&@�Rpwu%}<wX'.bңaͭ<֜o j Qg;^T^}!wQV]쁥,cIqƴM m-2su]dzCqQ{u3+[#2geila)jurܺq;S%qԡ`C0UeYihF}OC�SA,Y),\XX@X]ɐ?pթ)x +1a܌[žF[hiј:^)^C g:|S}�Qc:C>yiF5S�ER6XGTTmiZde8B!pzK6�l1͍1 Ѱ #̭ B!f>koVXV.ۥ7%bzMܪH[m������0).>[}!K79IS' 'vUYVQen;m������0àCpXntܨ`)67r5N}]QAD,Ƕ���������������������a0z_٫aGη6WHv<V.}KS?5\%JѰѹ-G+DNvC١W-6L^|xUթj<|K#T_au\ر(mcQRmn,gBǩnw>ĄZS-l.j EM>W77#C{} UugoW<L叅>\Qv\MxVqZڻ\P3.& +&Mqʁ‚C^?ij�5)d^'=1do?@m6C ZO Nҥ~DIGZNgmIUpwgvk: ~7z~<8 Aľn"Ls=a s<W. T8SZ";o"`g`�R endstream endobj 431 0 obj <</Filter[/FlateDecode]/Length 1842>>stream +HSTe^DRPX2/:fN#jCZPk"#` &n)dFB\]r~itʱiNy-gAٕg {󞝇90bk3. ࡱE K=ֿUivͨ6'f?r ϻ~}g`8GƾE_sz~E5Х;_h FARXQvg=mXJx&ۜyEp,g;K&{h{w^`I{Ex}'+@|mj:뼵g*wiq}L}?q}GjJF^fhmh{9-[O~aeAf OQ<)9( d#2<B?R/X|*mf*]F,-B}\"a!!,62(?}KWD}ks2vOm`ǘ'ަ)5?0 Rx"VxJrwqި c1ܾ\Ag g=; L FƾASYD9>8̐ 2eymÂCsqAYOKHt~#VU Oj뻚YlOL-/ c'MasSR<)k>RʼQT[o9[\9UZ:ށrg,F?z;*c7,aSt>PWB2 s{kO%?(s.k6RrM^ZEX@ɀAg6ºVF]Sq.U +zr~&谩{d=>/,|r& MeEҐ 5-?3(u .kՙ#VT ԩv}FO-M zx|SreOFY&S}{Ui6UU O+X.gvkitCאo*,Zz,/_|&"مsC]=t'Ydlq}:mʇgV+y%!c+5ñzwﬢ(^ a{_5LJ]mͥ40$xs9RFUWxf۰r';?☨;`Z}pywNxg[ngd -A1 [h4 מ==h<ȿn:W Krwq-~uSA3WDht4\"ƐvnLs9 :ð{|džlKMcx9H*(;%c/0sgv_;e;Ɛ1}:\At.!ۥS*˗Tބ!,:cL&Y~h2 Pzh6o@ۖYñ)WcCnL|8 㙋$沓Dn!=2<dg[T]:Xe5oS"ު֦Ԡ(* ++Ygwե11 FQ1b5^s5. {):_79/NZrރꪍ^&SK\d<364.X=5:\2Ggx|m|h[V _}%H*B$(Vs|gשQ.s1�������������������������������������������������������������<ҿ �[8h endstream endobj 432 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 433 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 434 0 obj <</Filter[/FlateDecode]/Length 519>>stream +HJ$1�D΢30>5缵R*������WS% 3^a"+8epm߹ǀyV)>Xem2UV)q˂lwOn㸛}lq%Dz]#c[|'Ϯ͟lpصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR0&)6>4`bYM+fصbf]+fصbf]+fصbf]9>zщ)>X2`b3R}0Kc+fRG`xRUZ13MŮ3Tcp'̗:Q?q3TZ13MŮ3TZ13MŮ3-j(3q `N2]|ft>X!ҵטlK46n>Nşٗ}&](uVڧ}tBVO�0CDe endstream endobj 435 0 obj <</Filter[/FlateDecode]/Length 584>>stream +Hmj0] L>\*:+ W+c.GG888Q VVVV6 +$####FbY}bY}bY}bY}b(@3P3P3P3@3rerererere@P>Q>Q>QlHʍG ʍG ʍG ʍG ʍ C9D9D9D9D9Q a(V(V(VHvl>,(0$~d}X}X}f/WՒ?#8Շx}hN4cz>4ge_!yaٚdFgpYvfYqPܖ}Y6tuٕsAm8tلs>W-8sߍفs;7^˹Շ,ν>f1l!<5K9Gs߭Yɹ}:<wnqYƒs.O%cyއʄ>W\ʔ>wɤ>|ɬ>ɼ>|>ׇ\>>| <f| 0�9@M endstream endobj 436 0 obj <</Filter[/FlateDecode]/Length 834>>stream +H RCADӱLJh~.YN'~Dع�'Hs5*C܌`4>BX1͵VJs)C0\Ыau47>{X}("VBtC/U]bDW>X:Mh.LtC݂KcD>X:FtZC%}oDAt!։LJt}uEsC-љKHeit~yIJ$2#r}H2uh2><>$YifLfC!fkd=>9__yul̔/~*yYΌo;,VJg7/0q==ǛLtmyTCH!`wQ&gF{¡ע+w{Tat:3SBYFF5Qt衄A7{ F&&:ӛL + +G=0:X�!:zTatt5`Qt虅btU`*trGr-M܎Rڧ•, l X*:2QR: +t.hVu`)EE81%r2fԊ-KNtl0Z궠p**t2[~uNG+Z4t;y*`l+l+l+l+l+l+l+l+l+l+҇��O endstream endobj 437 0 obj <</Filter[/FlateDecode]/Length 625>>stream +HjQOO X#GqRFKSo1ו|zйB~~)VlO%NJG�dG�lG�lG�l|8Rj(aOS>\)|C">c;f~&=XTO%NJXazйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +KVRz{,*h/ _g>B@?t>Av% ^]vd#ɭvӭT?t+7UWЃE}F:=XTg`QsуE}F:?)�ߖxu endstream endobj 438 0 obj <</Filter[/FlateDecode]/Length 598>>stream +HAjAQmdP-FT<ax}E|IG`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTܯ|?+2lwSѵbÖ弒,*X~_|Jy*9VtcEM+ +'r\>Ba+DžO#\yz_y~Bzy;+ǩZa˿s\4A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуEK�\nD endstream endobj 439 0 obj <</Filter[/FlateDecode]/Length 2302>>stream +HyPgw9cb f`Q4ZHO`xp˾ .ˡ,$ +:BfәF]g;μ=yߗ�c'"L8װEOzN<˼uGFc~1g(ƗeD sz�~5:t\YBoVÅI+T,P:z;h=BJ3)\��pl$1"^]TLge&Ws;#>.u:'/`T? ; +Ϧgt2MFYޏڵRs=B��GS&;UfлV_æB zp3#o.=5l@�a1p&iGlo,z`UEuߗEKz��`-k=<|cem `{222ww;m(fױ/kg16_V'��xV.r$9_.U˥w6&qE^e#=wU`T?F_V-u7ָNi;7x)��9ٓö~V_P=ZN.aDow3` + 䞚WʾW+d_]>вǓeINz�0irx6dR\mUpB7e轏ctgV:W|(=æ/W3=hknb�0LƍRn}ֱ-w|wn")~Eϫfe`L|fWňjܜNqd}re{$ջ;@R=M ��/,$';6z>z"f9V^J!O_?; WdMsɼ}xbDϮ֝yF!}װ^md=_ل?XO4�ȩd*M*WN1ܼh-SHA�C8#Gli>T Q9!{(Ɨ* D\۪S{Vٴ(sY0f|O?C �0YY'|e¬x=nT h>EH:w[%`#,iaf1tmc=i?3dkF̻ +in.[_qb&��f +d˧DrFtj'Ozr"+O'J L/q1˖q6čggP\xGgӟ4Χ=$x,,F|6�s撴1 4rm}pJ]hYt7+Z0T<QQFjv_<=&:n\czk~X,.*lݲc�M} =z,C V8YT,T*)>G?B ؉$8?nQ +{fGZA3l�boYX |eNQlPhv!yWʝTe U(OT2O#x7?^fGzĒ8zʋ7{\~{:Y3bl*�>x,${dtx-<#ۖ'onU7IOW&}l 2In'zWFF.χYHoYEkTˆ sYYgLXig�-tx$Do{Q]</Rĸ }*ozȞCY,Mw2I푝ff?{~l^+ݼvXOm>?/$uU~ߧ =M_ҙ?z^��`;m8J'ʜ֗q"c/ڒq}M404?=q䎝B,*-uu 4NǷ򲔢": sU6K咶>~~�@,.ύ<EVj(GYI{n4%AF-V} Yw5t$DoA; l:62+aWj޲G0;߿i�9|-#Kj\6أ|&Ni(.{(c7?Pv*FKrs\;;L;'fйh(U{Tw_&�͚7sI"r~:jJ;[o~DSHG3>nFE#�ꯏ endstream endobj 440 0 obj <</Filter[/FlateDecode]/Length 620>>stream +HAnAPҊ!� fQ`ntO-=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs8]+6lcEMǕ�y Tr_r^S> oc3Dž#ｏ }+?o Xaӿ渔+2h,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйBK"=vy)TwݿwC?�-k endstream endobj 441 0 obj <</Filter[/FlateDecode]/Length 1310>>stream +Hn6zHH+]`:-@H̘ 6OM[Ρ ? Đ#v^�>F*o<jU}x_o|;[W1t<?^�2Tn}T̼~wƩ +����h{bz\KxT澜,ls}CZ36ΟY8ig>Υ>x΃nͨ_]\&~OW +.lz*Mv>SZ>˞5><:/iQ]Ot3't_;R>?|srv=otaȖ᩺ٙɟcmʃ]xp8<_me̺{#<ﱇf.eˮ#<K^3����������������������������������������������������������������������������`ݼ'yp[%W~?LqGп:'ד(?PA$d<݆''wzo'8F(>nCg+']h2aP 40 +/o}qo UJ:<FH] M$,Kmi3b6 i~!Qr2В:23|*RMh6ce2;dOwвl?/^K_uZ;ڿZ1/A Fu ??{,bLx2)Ui\?J%"ӉdbU)E bLɨ^T"36]6_FVdQ"ciWjDzDjj<RT1CBeV;¬zaR4Shչw{kSD&nWj+*z~4>Hm\wDXM&VAڴY2"4i ݞJ)܎]6.R<f# ٢] +4Fц%AB4Yo`uPV5)mgwMc6lQ(I\|ewh}}ʰYKEGVQZ2[2Jɿt7 (o222}z?0Qɨ6w{Z +b*]keM w< +a>?}q(o|XCQmގ?_2N2Oo �I endstream endobj 442 0 obj <</Filter[/FlateDecode]/Length 1998>>stream +HS D +K*bhDc4: 1H4"¸VPAтV)caaa]]E]>$1 `?[|/Lc"rf<~nBiq%7ݺ@m3-l⹒^;${RؠUt%E5�BlmCDX\)˧yR&b!йIB̏!4LyNy7I@3it~d?E+k8uUu 7 m3SrOvG��Sp�#͙mSvE|uĜߕ>Zս]<F�B> RY*ζWyݪn9MD"֣ �x1{8M)տʝL!oI[Rt0i5t!!xAyS?36:q*E�2#9?4<ɬz\!~YqꞸ?.Έ"SxN[-3XZ=ncez�%9r4=.|9ظ~YK<!2?w#!ȼ7i�!)Er:?+^5ŷbևX6�@X|:;3\Q߯T]#N"�"i?϶Ou|F-yUSzTLYkG�0q[9MGd>P7Մ!|^Mg-p<IVOg/^]ue:~ƞGsSS֣�DqIK$Z\GەtUB'KD1Y $?xxTeM?S}ZRrxW;Ə<<Y;�$ߘTΥ\jn umȄ=DGk@H*Ɲ(<^éupw9S~0ec�0 /oBFUǩڷGudِ@7 lk3$4[?@IHVYY:_7*rZWzo\:ӢI[-E"�`7Kt[{8k?fAh??>8kF3 <5t!ZW<j۹s)xi]Y'wYz��,9g{2͝s8F 44}H@HPMCy^3P:{Rޱd +�瀕qYޙt97#s2!o< {άJ E�BNXV3w>컫M:ƖuF�예Dd0xNWǩ{vJ:suNoJr0#@H<ҕD-Twy{5-"atf^ �`7ȩ{4/>U<Ծ=,-dait%N $? +rVeUOJF},~ ��3g!&ƺZWJwKDZ >ӝv43?@]!,)W󜺷zr`zNYk\W^�aafFEI4?O|oH? B!8C^3@H@CpzI(: =:s)x银t6遯ز^�^hDFFŕ8sʻewbtQq[ B9ܼn @m$А|;y#.әU_iY]|wf�Ls=sv|/mbA(dGZΙGG $?i2VhyN3.nuiyt X �6d֭Ź +mχ6"cA"8OslD�Bl_M^Iテ4O$/fnz}!�f endstream endobj 443 0 obj <</Filter[/FlateDecode]/Length 1977>>stream +HkPT_X.b(Q)5ҡ]xbi% A {9Yn +g.X-"0&P{9tz}x?y|]jdȖ ճۡAw9y !_@ҧm :»gnl>^ +�~yZq^IvJYnM̨׽Xl?H;B�X-6}<ג Yu7 i=u|DLvut  h :m$od594}7iϮ.7^]D;J�X +~+)6zȥU}]q7O'u{D�bZ29~fM׾v0LobTDB;R�LK\#'B>u8/OKyo' !gGqiru?@֨9̱TXԳ*yZڱ`ZhgG6;=ֱISľfv?;rS-= &?r79JtGu:uxtՈ)6g̝G;^�Pa˻kȵ6rZu'4I*}.7qS2T ; hz ZYsu+f*upZ?lgC;d�L+nF> oj^9D>}ui2Ju@L@18+l9N4樐ٮ* $7*7Yg! !v2+Ejaϡ�1~N~K:G j{03.c#𝰗H._|1بeXMhHץyo&+a�1ŨOrBnؒDM% :eWR|{lX$Ưᴪ=ܜpOnww2Y?@bM$J2}Fo ~޵K~J;~�WĨ(CIa-?wod5| ao#WSNrٵxa�1؝$"?my#5ޮDZ#GK$cߙ;wD/MgsXB +ѿ ScS^"-2 &?L1t=ٙRy<zrdX:V_,Խλf0vDM;Zh1Ȟ,e;B86;9C�b$GxOՙReYՃ1c׭q|d);ϡI0\ɊFK~7o.GҵN>\// &?Lt}A۫ze9?iGjʿ⴪Hhnj +u诶>;#Ǫ{bAB�bTgm >tbma<5}A/Mzsr"E''rd٧j)&-qچn@yxBy}ag�1gD6/AcHϢ>cjQ \d+DbkK6m&�N<cG5(6-E'* &? |VK=׳S,U`%Ɍ0(u)̟+8Wӿg -8HvC#_l2LN4]?f>gDsb iGLC/ ( W䷍=#0BcOwrylHkGuvUw:|-8986Y19gU&LU=ҿ] -BK@L@u ]O^>PSL4e27 +7ZM;`!~~F +S|-];FZbeKl;+BqX,}?Y"$o �  endstream endobj 444 0 obj <</Filter[/FlateDecode]/Length 2324>>stream +H\yOQ~5k>,:=$+$Z."J~4w}G)=K(ۭj;x<P}U3hyfNBҬCn#�6 '"NPIKYɏ*NҺIk6x0e93 deBy&$u9�@{WS8ictoC�=١ziBZ/*b=)q^QH W]Hl8&^j:}ϫi m3*Isa?dw H +cO6V$fdMn/j6MN j=F#eSRa ˑ׍�^nq;tH +w7a N SqđW&._!ߍaivi#EslIF*AUG6s'ײ�SQ㎹On71Rq.SʥRY>߁FT$zW#UxxFx{�v5nk1op )?�ϰ I eR=Lr]A?Į3|e7#L@/oTeg\~^ֶ:4w��1Bv6f[r6".ϕID +Egڎfs?�zr2N„GΥ:F*{fV eDp[!/^(ǙJ �̝Og_t6F/ ie;8"1_9th�=F>^͈<*umy^NUc-ܔTik+ 8"Iasq ?6e��ΣWƾ/6~̟}lLz[Dl>p�1ۗЬDoFU2gi151Qg;hiEX +׮T9Y|>�S?8=ljK)4pbݺ<�qO?/`hTDKauQƻ_rYNc>d ܠG_Jj=G��~6.`y+160 Tx@MW_@mOEڔHEzRnZZw ;'YZi-5N_8DtA*n[I;�hpAg(7Wg[m^0kv_@3v#9)jrSZK9׋KUC۶;5}BQH?Kf c_��- ux3Cp Ez8"TܔvȒ�Zy;S\X'mKEM%BnvKz-8$D8䟪|ZA;�:+7.gޛفQw̚Mohhi'[#YyzIcn�3s$AT7}T{Ci-fF-mf'bjbB:=yp\o|y}0!��nR;##uzb[ώ1^_:󂂘֟a{O~At.OHkfY<ZȩMg$kud0zugwB"sAu=S hLW��hê<F;dtOhc &y\iXPkm3鐱lb�<u&t|Lx^U-yܳ'l|n>#rbi + O5G>"d��`C[<jYA4H_%ǖJW>8�cI/NjټOJt?llXEB}} SetL3˔r>��۞(:6ñu˖3m\VV.t9�)׀{NXaaӲ2M&+SnR vލYZ';T9Vr?%{��m,lhc +e_\IW�>&?mTtG!5ٰߋ֪$1w<g&˯Y6ϞdF9+۪&(np 3�@=g +*:H +�5m*Kk\ҥ +Z\):YHča~~zzl_̌Iɱ{&1YugoR+Wu��mw"\j.?<�~ws LtYжrEsln#1N7o\(HӞ��, endstream endobj 445 0 obj <</Filter[/FlateDecode]/Length 1437>>stream +HoLu/ SgeRWf Ai + *&)c8@ED8<󐿒%s=MglVL}ߟ{W]|h{i3!%!K�9^S& #:5ޛA\=s>s-@S$TsUm!ofWs0sфc>D,'~o .Rm7�uoʫ.-�`�xػ)ZX}[,NkSDǿ_aF7q55taw�}{DGY+~`�qɺiNSu_}M{ˢP֜0/]1s$Ѩksn&G�xnQ_6ӥ�5infoY{`sԂFS [pGwHhnj%)FNŢhZnK2!7�G͖Ҿ@x +$ Z:?o!G;#zl*3{ ׮Ss;A1llTwQGm Ie��5V}F =�>l)SBmh3<.~U$c!mavj:3#37e+X'7q{W�܉TÞʂϥ�)9d)9wm̼ۜZqWGguZ([ʞٵ#gX}�ܕTѝ*]!v`�GO"xʤ7xas\ +]+ &r t$ }GS@S_{ +!w�݉p+ic <_7-&lgMwo8N.L[ ��OTIJ)�[)coQUc]/}�gM;Iڃ~@x +{ObgXݶp`,��HxMic <LIV̪7[J.gy~k�)1Eӥݍ�T%4Z޿ݪpo.�ӆ',l`� I.',zmp~ r^��wF## WO�9"I^ui1c��Ⱥ޹?RK{)�(bITAoIUBo⣴b��wҘrv4S?�@ xlHzokrc��wѱù?~#f`�,UZ]qýB2��.gy?^t`?�'.ldj["z/],}�{Œ ^>@x +�<ϴm!$۬Ng]jt^)�Q_T/ֵ~V{H{إǯ � endstream endobj 446 0 obj <</Filter[/FlateDecode]/Length 1031>>stream +HoSegF4@ F4K0z?VѰ�ɂS~#Vp*d[ hEQ`3lОvv',6B 0 bċEؼ'D\>y|GB5޻D$˛[v/Q�s]B+A +�L/-eޔӿ?zmz�۟uߪKK+^*8^6֯^Q)�7bٞEG5?5&S6�xV.~"sD?�ܨ2=z \BMgWʿ�P*K]-kg~Rmu@KY$@!:Kn{"gD?�̔oZB-ng o9�Nm]iJj\9 *`&^.j;?\֧~I멊%kt�(ӧϝãne�kšH_2fw�n*㩉a{?Ja�ȧu;Ţٞ>cgp�Nuu=vޥR�mDtB'}i�N4~(Ţts&o=�8մYid�0Jj\V=_ꡟzxl:�N7d� "jhX3]͓~@3w&�V8`jlM\M{�e8ዷ"d� rpᑄjb��aaIQ)�N@u4YtxKԛ�04E4AT +W-0 l7O z�lȘmgG߳w#�'vnZx9xͲ�o'#?틴5;AT +=֛>7=VO4{_?�|Z{?Ja�p۪]mq=tNoruO�2j~ރR`�ڍW endstream endobj 447 0 obj <</Filter[/FlateDecode]/Length 1351>>stream +HLu/`( d,57-u:Mz̸PORLE T{"$ɝ,I:se:D[jWFNʾw{w_߽2B 2xIɾ')ۮ?PraRq�qni=e 2Px,ko �茸0KUyj\]~_� i9/^{?�:-ͿL��VYَc-X5S?s5Ɔ%�O֫l:R�]$~_;dk e:�x\RgRCvmX?^3VK{SZc5.G}K�h~c_ȡ/Izr DoVtdo +�xzC E6_7 .o^+[vջ #ū_�f_fTvrL(? н eWe;QY�Mu{ܹW*Ng�ӧ*lm�pc#1wiWlp&$83�=5F0 Nr桱j�Сq{,Wy*$S:2d ڬw�4z>XUjwhc�8KM%5T[3wV?�Ҭ5QvKo]4�b޳7Meg?ȓNHi4]PgJSFi+'HzqW:b1Lsұ?v6l,r$~j�$ H +@;}�L-Qlĝ ;&6BwmK?ut}A���PSVμѰ,o�mx7qZQNc_J=jmӕ{O�p _0QZ/{Q[v& M 0<46Rdxף_RS^Vg?�ݰ 8[tɪgV�о[Gҷ=zA%)/7aϰ?�#+:dkwԿO�hם&8֣DKa�X4EZa΋wmVspo�t1&E?�e +*<Be3ֱ@[nT1a'xth)�n)Y-䔭N~[2]6~ʐpuy��X7 endstream endobj 448 0 obj <</Filter[/FlateDecode]/Length 21277>>stream +HW9] <cWy2937@_=x v4ބ'~_ߖd-{sɫ@SN�@!${6]0-9o56@{t.]D^4<�byzbG x..eCV2Aw +`uP!$>^S(΄cα54lU*a:]hE·="GXJ0jèS<a[\n8̷0NttA+[f!ẋwpP+"9? <jx9d#'�')<o3JA0UO&m9IO)vu*c] 0;6BVnٞ�/ < seD]MӻSK(k_cU9�*xptH]909 f❁T nXo/8gZkiktq($ duVOPx2rL8-0P1_>6 MR65:3aJ +ٽZAX؆ 3 +" (%kVt6@%fV~U'0VhS9VpDD.J<PQ] #8a<y;dBmͰ۰'L{O؇6SʉB7oHBE^œ;ϰ+Wna%RGѡ^<2֪VԽB -5^, P'La~jE Kzi1Nr Gg%k( +>P-; +j|33TSAHұ-lxF• ŬOx޸ߺHz\~R<+ bv5 e�Ta>A5gItÂqe-*M1c< ˻DR;?A)#aݵ-?5LF{ s4IbRj� B5K_σcJ޳ոZ*[ng&50LxSm=|(H>hJ} {}1xL>ߖљINv+8:PBa,P\۱a7 w`p(LEwY @p xj9.t'iYJWiQK'Ԧ~}GvrDcW ύ焧ϫkwrۧi{ӣiBA5#\L* 2&ꇯ$-+V֪@2 D0+fhݫ 2([DE\zD~ †7}~xP T#$@mbIa.w%t"eYN +nWo;"M{祧 ΂I + ZQx?J*&T͡WqGD[ ֎06ܫ]f-jAh.;> C=/jtz^ U(f/xz鍼koTgJx`mz;8բI qvˠĖ=UU!z{"p߃$ˁ#~`wpmPCpāٲ9Z}X(`цeY;$g _xZY2 DY9Z2u}֬;{6 +Rpe1 $*ohK +u>4jnEWAl[`MJrk?{4쬴fgE8{.VKVrvӷ{i+{z8WM2[Dy.Èpj9H'YSgۯ d-'xx15[y0NDa(8\K"DG,*y�l>Hr0vP7nx|h%`dgeD; (`pOn>j9`ap9]T¶Ԝ &(ET~ &%/?}[2k%8Ys%w̻ + "pb)rN\ЛNUv�YClc5eNJY= yt l`æ_X[C{L, YT`\ZwA'm@#8WBw?.4/pw(d7gBdz,e/NȚAեk[oݛjh +CJ8?cY\0[#I0wBh2{OIs)~ +C}@T.RV榟V~;~7</փoGvH\S!@ZLO + +X< FsqY'=(Pl;o' 9f{roEU)+EԤYjro1 0LL+'MOPm=Oi&S@XpOVP +.Xθ8q6U/B`:V)>2 d^}ko m koqkEqjGp%a';Lx*^`c"ZofH�W[#$r<xSeczi3}}Ћt/@d蘏g b Jo5D7ES� +f?k+.iF7'?ojk*Y ,r m jۈ4[U7,.>-ie LF{ Ix G]ڦȨ%Wgyt(gX0y0Z�ETv@l̫r�+jjro�ߘژ<Ƒ\GۺvAa; e-,JM0G# )Np�cJ3/fb `]pg@+<;6 6z{ N`,D=.:Zrէ,qO 0`5.?X1�qE΁`s lg {Qx9:ZGPdS7y֖"iP>6Ѡ%Cgp9ciFC!kAj9 ok`̧`B{T"IANJ(@kb@}O�֜rC0pAK�qO}lL{'kX- vm4gEp)ЍMe-&<JAgp)_=,.6Ɔ~h rQ# +'f-I,L6l{ȏ3bvk5g+/0A6>U [<RY[8ѐpNi\ >rVvI;(nϗb~|j(W~ +e}`m!s0F ed\�17�'WeO +iҠ"vK@/w|E> * ѕ;`o'!UƼyvM3'gpYi 2B׫@<&O5v`j,n3yտ͟sO2O7WY *^7p&Ҷy c7F hAJ@ZgS|b ^,@fzGq}�آmr0b.nڏr |2u~_ h;ַj�)#AdYMA[Gh}uCW^2W p +wm}\NDɊl/3_&t"bOF3KUoGb{nrX.CfZIۃ_VoxaN_-~@GGg#qbQb K4[+Zx 2?>bQ9*nguJ?^ܸ-,KQlS|�ϨʤU093kIדlst | \Ӷ;0v[^p-ml=<2WxJgZ4_q۫|K%]ەo?9ۧjk/٘F;Sb<h qŸ<[fv4ǷnYbd? OW8k؛f%Z[-Kާ2UA\lgGOm˧I t[zO}F&g40w0ap8t_J5˽z3XnbmM N9&C!4Ru2n+G�%^"Gb||88Ix9?D/�_Ԃz+ =ŻtR۹lςi-jġ�W҆[]x*G�b<=[,`uOAۿnZKʭ>!w(Sc?mǕYfu|{[£ +.txd^e]lFqj-E=AZ}1;ϿXFk41~ͷZ5ɂ{[K�N7�W �bcz�@ Dm@v)6vK6£4c#k K*0luFJ;*F5UelbCx�!a W,#]`c\d-bޯp0u 8fR㱪\B JZ +'EM9dz=<]J5<5Fq|*n:K*�Gss-̚ء0~ ~"G3 πpH g |zao Xfߜ%Y$$yD mZ[Rl0-pJ(6|W`^s6a UM=x鈊h2ܫEҺ֎me E~g5P0e$0 \^ڌG�vT (a{>n9' `bJT%dSlQ{ѦUxsU޴:\Rda#_@ F>*(PԨm VhVt6i�`˅z�x +*@o""wkZ>cTm?U;ZKx�تTu2&#I[-\lS8-�bT}5?K~ {ڼi5;$F{"2~g2ؾ]b,td au(@qs~!sk/7okۺjZcje]qXD +cۓ?D5.5):�75b�zmyК&_b%A +l62kcWyl~^"D) }> crGT0a- +xN;ȵ)7yٚ+kraXSǒD&{VgbLEg`I8:+0x+4b|ء4-t%?viĿ͹ۣrjw֩}s2њ,%}DԾp 4z'ۢĠybDwy,l|a-Ud M</HОMyskS.()yc 53RI^up/2 \ +<M;6 -uݣm@7s]azEvAo>&@r 80${oAB_)+QfH0K;TGQZg\~ڣe2R* 3Z# |'vZ(LzLϹ^g^ +ژ1�%h�seJ5]JJW�]U- ^S rhxZP}p&ܰrbC_%(|Cw/JWIz΄OB+pp l,ΰ�Srb +wG0Tz!N!m*ZETmD#.`SߢdI[y;  rBqQgPd_ `$.Qˮ/mu|L&`!7�-c*p"c]!OaqT}�]P +8`'?I9gh'į;) +]M d?hC�w(]6g-?5G0н�%P[UjX,pwe^Tv-8Pb-Aaʱh; )~3)ZʲHƔlhW)gǧkK`ZnMa*ή@>k zU' +p ̮M}4e|E 08b%˭{MI%r(Bvca|m:zmMt4ݟS]_Z8UwwL}Є$*XĠڋ,$'e਌a= FG`Xm^`@kgs山/H +r@9 \0~hxS|&e B>KFSh2aFK]a͊JRvP\#}يf�_Gu9;kZI XNmM9+a׏%P?zMkF˺66#%|hfSL}AYjC$XM g%9";b(O{z63<vb F̰NB=[ٟ5q҇ �b\]Vw+A0Fɟ Ø-X kŷuW9TRVؒդ2rő3m;_�P X[UDgM&1G]h9jn<=(|>HHd¸ɿ]}dcr €iϽ KaY93na[6ua +藃Z�b�'%0e@J1 AN;nt$qrb.q1j7w7r}٣Y./[o4osˀv �NИl5dR}Lx10|Z:xmk[ ew<R]Ob{S8ʣѳfm S }ʭ>F o9anmw*.k*Kv1<`aSՐ lt!+/ ޵dۨ{~o>vW$4j ͼU|"ESrE9eJl4Wy]@r@5 !ʩ=vQgcEFpΜ5c9kYL02@kQYM -O\pRf[tL)*r;cWRdvռq:o" [DO{;3+KX]e21ld䨶d/rѪf4iVYJ3o]xnS:_i ^/8ruU!mcn28=2J1 jK~ϼܾhC$&$O!}1ɒQ Gޗ~l|_sLkf0i.)%ObUoz %U9:�(vRG}i(-h3tqS3TU"N즳=KA Co-Z}�x~hį[~5:wJ 2q$=GS FٹlfT$omR5Nal/$I5-ɇezŲ@0..w}:rr#z +$+5ߧ@T2cPDM Џ J#{E7 +1DH\'8ɾck|}ڈgq_, +݊yskaRl,~Š/ē"jq&ץ= ^4 .GA=yv{}dKRx%@a]ۼyrzM >`ԉ(8Kp(k⓵{Y< zRH]eE�ms[!-~ӽcJUP&4LkFtS zA'Adz:`+A;LbBVݭ ~-/v谷7 5RI!YҪ%J GAq֦TQ "\v铑:S>~S"'u}&)l I[)h??1,8[b |{]tp`5W8gp +PatVVfv<YëDn,),M.w.ˉ3W$c8 i|1.\rmgNF%+s O+V(aCwȋ!hZ ?6f!G%ػ,OOD@J֤I +L4/-%3K^B,%[Z&}YPd-g ,KMp]';` 1Q M =!,_Gt ]X#ZsmYRS'TqGa*CY3~NطWrQ[ױ>"2#~gu{bFX?|a c~0m();+?+ۥ̴n]XIC렏bd<{3)߉qvKJ~fFpAۃR! t׎Fe BP5ȉɅ a~DN&C4Upp/l[<>ro,".SKZ@k[XUGxO~`/c.jnG8wo7j_gPhiДlLŬu&83 +(l-]#j.$GA!)P{('PtEX˴|$C  xZq<HF>:+U +q5lT `cVI=Ve=Sͳf]5>cYlh)XY[]0 ô8\Ǿ 8cGR{z 1S%?If^Zr +hop;E5pȦhɽ+ ?0f^Hߌ>WCMEʺIX5N&(y E3,Z}k<sU!jWj-ō{uL?u1-ގtmTsAa-6 C;sIEg:ieѨTSH�nD }+[S^g#ePZyAˌS :ëdpYR!h x�J߸z3].=t6/F\]& l-kВ"-E:A0sD~1i\$U =`XUHW1Ù[6Nw܌BeWӜyri9ߐYis jV?mB{kzl}m{MPU mm8i +~NgIhþV3gt,A;Ll|_Vf/omj8% y П.?}/->$/> 0U}K#5"8:#̱IyJVx-EG/#[ +zH~F</$ +hfO5zv'u쾊�@X:;v]K=w}<wuԃ <)vxU(@?=Iѥu Jk{2M_?UD~jTó!zZnv-X]KX<a'pV sK%º_inF!i#De{W0p;~pW? '<y⡦ttpuQ19-K&ic[ItONtw5-62T_L\SeGKݭ}ՎХ.MG +[P+ِorP{,.fc_n#$oR\tܛ}$xOWAc8%%8V9^rro2hQ=}ԣv}? h}Oo=[TtQ%+юT-D^l!nkSHD80pkq+y͵a�TWZaJbPՊz3+LIH5lT^p�sۮ/'"|ps~4s&)>8%d=4�vq$ (/hpTq=*^qS[0ۆNjM„#"] ݎ?RH=Z\ 7 Y^R90=\?9m6&#.~CӀt5Y^/Z;H*;x6ot-*AKbF,z) l]-S]'$RLrS%^+6h.xCP}9AIbu]Xyhu鞳, >ԼLF,)I/ +�"8.!b?o9q/6%RLsHkB@?.]/h$cP ++Xb Bȼ%*Zpaڱ{#$[^bJ[{Y(ӭڒ]&�uC6a*FK]%XbAY9c]'c8*> zBwW y[׈*'qyUrmn"pG"5k's0({˒8�` 氚NSZYl2L$|< =as)}^ߓ(:g,+M=rJa9Vq�,? IKBu�v$tv3eᦳ ܧM�<ѣ= o=BfD>N@8-;(#!>YR.#0RaHa~?Fi˫aḻ\mM1f,uɳ,.uiprUҀG `i`�~#%1mĠ6L$Kf<Cil}36$؇, X.fL?v-nmH챊ǹ%ф{0|V>:NyVk2f\`憐|,0e#yU\)) S|דX6*氬d?E80 -.;cd4W# +ؓ<$VDYB2՗\9>d.b2�z$ā?+.pGMjWkzU#D]?U[ E&")m^"\{m_9-*vY>]E �ǕԂFtr3?;H[3C={mk3Lٱ=AɓeFjJ:M֚ .E&k+ZA1/Q:*5+sRms +HWZ{ԣKeN M;N]e7Y [TeuZP>_[Dݪ;~m௒l+( +4,8/ye0,a~#GxN^S[/`+p p6Q0역sd�,k_Mfll9ANC3*(,l8ma]޺.�6~vyvo< V)\f +('Q@*4i/6nඛ;%;K=v?]0KvĄ,Bl#NNAk(ԯc,`gWJ Ylk,xA35R3[o%h:ѭVtX[mgFb#GVp=ILr nxAl{(Prl\OB�{*<XL &oF.[p5'Hci�I;3� S�cӽ5m`aazߵ@? [ņIHo~(7Hn:K�V^Pp]%ޮ]bE%֟,m3ym +C/=iW}Zyge^'V˂([7:Rէ}juݴq:''Flq_Ê:r#?M8whN]jgonڭ+ ~:q4ŀl^feG7JMV:C,+@\#}?KL<W5n۫5fxb劲EH~Q6GnO%Uf0W`~ڏ.V. "<@.;7&D~7-S/ +g;PUoͶ�t�40tHF +pwK?6Kujx;_K]!_֥:ƭ� ߮Ҋb9u10z./v%?{!J y/3:~bK߬V� +B,Z(H 8Z% /%Pg6nRU5*K`|{ +ϞZٿ{qB+@�2`Z8GRQZzsەNFq~~)mt3�0}sczR&0N W�Ί$j k 6UKO?�?|k5[b3`XZ6`mBu^y +cˮs p)Q7wGsgrهk8fj^b:EO'V;se^1؃Q� ]]G v?;/d~}mvʀ 7vO +p-ץj`G}oS&;�㬺syY7+hS"h+^7K㶻g\2�Z9E}r0`6�dt`b!ܯt>$ r`$+r~<"qôheDC<ޝ1iH?`tib& hރtV�5BОnsҵ {o}dB4 厑B]zbsL|Tk*kjƬ +�p[ ߶p;YcVȴ-j*?[Xy#.0"v&!컱6`KA137Xhf=:bte3dgp%拥^$�[D; `a\"0g}0�J[8q%Ip'}{`M3 P/a&ocwe˰P}vKBF{_ o +C:tް<970yX(yVv%>*�V3 ޡM]kEX +>UGׂѤSv#Y۰?xOjPfz(�Ϫ\-8<6'~né+NGC)ݩ3\]d79ezmagyz^"3b /]c +Њք<JRAGSy,N< 2 yY +P'CyUUz;\qa;Ki?[G˜u'� ʋοU7wJ KvkBr?zrs37CgeůN$jO1 ,Sg;6x՝~onU[sȞwxhb ~dVI;><#|D1r &5?z=@ +L +uy ܯ,_Ŀa&95uFX%-衡��,D"KuZeXO�ǰ^s*@i'.2Fa'dב'l=/D̝>i�puiOklr?" mdO +h[,8ધ~DU�cQ Dg�`kG\}Or?;ok̜[k/{D[K.wMm)l[iao ЗMWQcQ}E';[î89o3ɓ& iʞ&zٮ:#-g\,f +0f7W w)//'#.#]ޥJ{a]!Z͸dܭfp~Gk~hiF<lр/x3PV;g7I 6GYSz3{E7&+ɣY<;2eڎh BV&b0q>SeV=Kz@gi/\jz�RVrn3TNZt`K.6K5?2'$>?{lNؚSu.3V\s}'IdsbMNR7(#v@ck֖?vgMّgO :v *$YLoD~1|Oҿ}hפOD}".|]x;ąm<e7dt �ﲍ�n*b]+Au3U(9ˠ,fuWMզrHr,͹09Yi�.visujbhϟc*`4g�B][)k89,N@(>E6u/ͳw|' D a*b]v'kha< z'/ Y#$$ +\lʳQ˓K}OoJvRuͻ^6ʡ8i/MYl!VXZϮ�+yltsGIHlM^L)R 2ՌhKyQ+z +-vFe Vn,e|ט=3o{6+;cKI5u͇et  7?,i +5{i,v\뙎Z>ygߛɐۙU k󝎪3NXirTL2o3q^g;ttLLf/#ќsQ>QZXrN@H[sPŴ1/I CV=Djٔ`a +t.3tvZe�hoiSMd5v#ƶb֊Rxe"춒!vVO1y}TJCK\vi L}T~qȠsmMQR9ohYf|XJ/5@'NM#&=fyN?nT搯^-kۏ / c +1Y<ë%C]wnק\%hh%}+XOM>k^ T%Ҹ�! rmk+�GTX)l ;ʮ jM?Kg .0agE+?dim1I^iti; ͔k9,!1`ޣģqmZ=kp.]"mڼ[}S<$.W6`+Ҷd *g^"`-9c{!@$$eMUR Y#W'v)r5JEƀ'fg�Hg{Q#we7=a5 -;Q!کi݂j| +lqGyu$o1jK�|ȥu5N=fLT ۈ];B-݊c%%@<sc87NwpxPAc ^Iՠ xc<j^豞">pO߱ľE$|5#)fO[`+Zz&ΪnL1�8mLU}InUfNjz] 9 {f(= oQ&vT +|d�sCc;9۝iF͜Ŀ&h=yzB{ 0\eeR4mj咭-o­#2݀Xlʮ~3u]d$jtR;ɜ>p 0wyVM>pM�u0DЋ�KR&]"1Kz'g~Q. `"ͳ( Ck,}8k?gxNeZWÂSGߍ۲ ^1'/szų"6JY#ڑ-m +f;҇+?5(:}vn<]"A@Wf#[w6ɪeoυEޞݞq:� bC1OzI<k%WN<.<-STL5Il/Z=^Pü|2Rw n?a_ҧ*kpF O1}ry[Ϸu]ZcLƴ"|;\Iy1l <DgTe2&!H`SJ~+K�GZLS u-3{ l[ezkzk´G()Z2z#} SC ڒ1,6@lYEq~㎩LNo0x#|Jtmt!QefE͌oterh T=HK|H- P/8_/{0b�%V igH +U*XK][RNfRDe~3@R!&E<tIJFPjE]jKt$yI+|DAOһ?2}l)DϨ:` Ef!x   ؀g/uN a=͔5)"9*f*Kz־9uQSy+LBs�K"$znގj'߅G 4$"1/>fڔv,d =($kSME~'iA;"y4eb@.:/- +E4Q_)Ȇ�*k69;\@jq#lwe .[y2@5 s.gڅׯ l3@q"ȉ"+)0\2ȮiPCwyCkɒðSoJd/9|rޫA9u6RԔ(mExYu<jd¦T�ʸnZ}વc"#1H=::=IɓdlMͳ)2.%!)4KeQi^#$EC02 )"*ӷxL_ܫl-Fl]. IYsrTryثZtI0^<R!H k p5”[C)}(.==@wmּqd 9#N4#J3�"\gƜui“&qtQΜV?eК7#jIQS�2.Q\|$ˆihU H +pl90޸�WdBK]mv_W b[S}~M?s�OUZ޾ SjܖZ+j@k/wxlOQ�t#ҚS ?4V'z%4CRN7ccP6im*WT[;?%6m'Npt18yLJC1z!;Q g3C:a-qƏ^aJ}\ m$a㍐v+^w07#7SdPT)@w9oy֯<V05 +g*�Z,Ⱳ1E5Զౖ vxY"gqC|^`˄ua3is4I?&wz 9_L|T'g.d_X "5W> 1“ خV\UuD7# +JY4NrISLՔnxB-Pa(>ic}usjLcJLDDzNi7f( R"*ZYCMÇ95݈r9z欁RD2@lXJǸF~_j<~( F%C*qΌc[Nq 96__'-`O/Cz_%<K7>yvp?g>N9XH!|ZQ`<^s31n =1jߞ~駰YeYN tgvņh 8S={$A!j/1O�lncTħ}ԛ*ʯ6Mz$q_tq21k>zZ?'xu :`tzO]s 5R9@W=Rӽ[AD76p?F[K0Vj0JH S 2_<"N-R{8b%8en�gY =,GiPy! +؛g<n5uXصsl]; [!7>C46;g$X18M�MT=ع1գƘPa-2=pHm\elg 굋oZS 9 +ˌr݄hľ2k%1}jk<B)xh*8+&Iy <5q2 v'.eI ��t7lU޲pC1lr""q[24 zȯk9/eg4YQ{S%}\M>OZ.vMHa 2%wx~298(Qfs2՜F@-s\jSom~魳mVh!"xC>s|ϋp0z]K}ӝe#2Jg[/YŠ�QK/jV IG3~2MoԼa}n:&5]>]x[;cKY0>] IiO6ʿz,ZY^z铱[]:` ؒ7s.'St;5Q�-R],RfE #H_ώ~̢kto:e떚VA隼xah?Q`+IIu*r=E1*kѳZ2ڱ<]bQh!pT}< 辺pg�#kf#_aP];eVn|1,q=/~Xe45' +Eq!,yu66_ܶD/z_G`0XH,$Oa 7ty>,KAgӁMd9>ՁwN9<ل9&蠗H�P~L(õ=/m+ BIeX#Llw<1I[jZY o9{]K�RرqKS0\qT9 t ]܊Exj5襉Gp2ş*zEǝ\[r|ty5Gh�eP&p/okG7j'$kc6|]8W҉Oas6rQC*i�<QtXR/z\|aӹme1(f nV$@ukLamLuj6,?ȩAfQQ:2UΕ7? +`=kyZ3ʩLJwA(lYTuwcB]esиEtt-� 6XkZ6YETGRq8rt=JY2BG 8"F`S>{~$<tEğ"7K fq HDu9X~rv<h�<n^gDYF)[ @QSg1Om xpV]6vg�hf׎a`K'x[:3FF(�a�l|WBWr>laHp�PX 9UsK+ǑteKkcpqm#-F\Jmaܣpm1;]qO}EaGW8lT?G[dzVf{;)M>vf t薖[-j#@a,gT>͒e<^ŝ 3TNTPgV~.ǒh:s..�W* +0Ka~?$KCrR:pT,VOq=]x&SuZeES4�DYaSYkk a[88ZVE* g0!R5',o?ze$.PB|O3EY19c[)&-p#*5|д1eMmtvL8;v!fb1|% ;<;ܲ}knH#rk.!%O;)'E3j pGOW Prkhh?_dI?n0Nx-oI +}d @#5CaNx 0;#q{]֞drrt`0>rۯ.%�5%֕n-Z^Jyfj +`Gͺ]{^]Yl7YU\EXATVéZt�/A`*}mq)md3bX͙߳g]d=kU .u]~ί`xke!ˁ++mD &\4G֭OޗGݮ|w&RKS^  uCc\s 0jR{0e˜r^Y(ovA^m4侘fLWo‡<=$t^D +PDJ+[/՚v1VӍ|i8pȭǮMӂA?`�y endstream endobj 449 0 obj <</Filter[/FlateDecode]/Length 1016>>stream +Hk[uS: +A(.ܜU0qT̅kpvZV*6VJ]m -is$usMŵ`m)Uݙ/&?[g˦E:Vw_ћ�_]UVw~iS�*fMyYX9FH�gWEqm,iW.x. uuݚo gY߰?�w[;;϶ B -5X0]:4a'�ȇ5kt:55YPX.O|fFYǰ?�޽]w#lW32XP.ҫŴqY?�uO^֕Q#xw" �ˤXpX+⤰?� 7ox}7:vԑo+7�kaDW< 8)�ȝ P]6]O9�юO%⤰?� kvO V~8|_r5u8)�ȟgTi]cأ`SqLsI⤰?� nW"j-%C2B|^�|g"u`'�jl9hzD�;9魖8)�Pg{xƯMlЗMWxA NE?}>V! +qR�ƪRQwFxe_S ȯ3xN#qR�`%7vV/g"�4im˺A�iܜ0Bfhjŭ26CGKe N +�DSߙنG�rg8)�Zo*M' =se'? KrQY?��cߓhiv,L˃ݥWq4nu�8)�([]7t}Vo%GG�Lm$}qR@+�C + endstream endobj 450 0 obj <</Filter[/FlateDecode]/Length 1061>>stream +HLu�͜6jUtkV I[dJvMb@DR32wjA/~8.M]ND2(@Q-2/>=_ -N;-~ڛ/<�S@vX{;<f߻@2#,תT�e=!lsRTw(�xyv :�S[N]toXmߟ{_] +چ9�L}3\Yye~ WT�&*?V-D?�@<X'; |U}jcE}im?Na�~ָ_뫮W�rXN]tf��=-[|oMlXp}L )e,fwS�۝)p)".] ]2O7p#D?�@LQocq.jz sO\�⮴?4Kj +loAt +�+k_|qa@/'ն :�76NFݻ"+},<fD?� 9*~T_eC;~^DKrlAt +�ۢu[iVŀd3Ȗ78Õe{S�ezn8hxFU֩d@ݘ̑D7 :�-Wo=(}}XZ&M)�_exnZSGk|b{vnT�],?f'I)�tWдsqU2{ͫ4@Gc}[ %G)�߹2Ohoɠ3w5@7?uB@;d��L7O7:މ7cTv%k]̐ћD?��ulQfve~?u.Uuotp{aoKt{S�gDCP|?|nOwo&� endstream endobj 451 0 obj <</Filter[/FlateDecode]/Length 1475>>stream +H]LSgjL +lQ.4Ѹ͏Ġ́Pa:!ՀC( J9@QSDǦna/d7ی[DL yo{}2B ^NgCiSMq<t ==t<��F”s]܌x �w]w$#7o;��^nyK%U>EE{nn]ͷNA��h|NzSU羠 7jJo6h QrB']Ri-6`P��'&g\vQ`}ܴn1ntl9 B@U=w&lԨvߠMI-w��$J*/WwdyQ�Լ/M)D ?[y){9��,swfa~y}ٖu<�%j*Z2%qr(1=\WjuΡ��`m1S ]v6uڻ4p: Jͨϯ)/+, #Ysv_0&�� "Idޜ;|�Ja*RUr(1uVYV-+>~ܪO`$%ɝC��22&l*J|F`<䇸 w?�DH6Tnv?Zꗧ;wKGʖ/G==.z.��_B(ɰEK%߃@(If, 1ur@ϙ:+{Oo>|yЬ. ��h >3tAti.dj?PsMyr vƏCWDx􇏗WϙZ& g +]AO _o=+6h7��'Cݘ3"vq㊙p Pr}G\فYLH; JKCRxcbcW>7csO8՟��_$Gm![zF' +pҳm9t4DiYcvصON_TRyz<��JqтI97صCTl.ISn.?R\s]Es6jT\Q]uĭY|��P;Irwa 0WK{G,6Mo$7R3rwy|ʵטa/<��J5/}G񩓜Nb,]`mk+7 ;��;6l>YiL+�</Wn?w +�� ?#қudK۱qFp+;��%M&tv%Ko^]],$'N-w?w +�� 7qu<iοİp{$CfEyyĝn_�2` endstream endobj 452 0 obj <</Filter[/FlateDecode]/Length 1056>>stream +HLuZVךkVkCal"V46f9AdBKH?`b~;@8!ke q+8jr_|Z[y߰>}|m+o4ݓlo3Gw+ʑ ܫ^oӢx]VMݫB=f>��p%׮_HqQ[X_{sAd +� vlP5To_Xߎ0oկg7�@&/^U ۤQ}/O} Xx|;k)�l*[Zի= Û6g3Zcb74�@Vwg(Z}ϝ[T]#in87iq 2�ݓ${Cnω9̍l0o$#nD?��vpmJQkUZNkIM .F7?La��$eoa}uN'+/j ޲?La��&Prkvԩ{\孭YPldWI,�n.HWJpz@LZZ,y2=eU)�=TeqSmс`f7)㧡z;jQ)��)˜J^c==o}Srֺ2ߦ5'��[S;o +4}]T} +EÕGBVd��2 +CScFK*>BNuV}d��X~FuGׯ}B>cݵ 2�Kse{j' +߬#ۛ: 2�Kr:.݀]wԳ#O]NOXf?)��ǔ76z@|3p"+`}@.ޱ?La��pp.qu:3x@zAٯ}êo"S��?˶W*Rz5ߤpW{`�Zl endstream endobj 453 0 obj <</Filter[/FlateDecode]/Length 1057>>stream +HOedp9VEkʭ)?T#\NfkB 0au| ib$(9r=Qx-j@iu.pιs^ݮ'O>KFZ +o)Ά#5 C韗f,I;,Zv��-zݩhp7wZ$?Vvcb?��ƪT{S3_=L^Na��=><lp(+ <t~ kD+ew v +�{vH+ǵW\X?{Na��[£QM^?Wwa-͔)��bkaZ]RߞoNsS?=]|~ ?�� >V+MrzE=/r;=lSk=a;�@-]|~SM fxF}eםa;�@-v0~@#/P߅}E}W^Na��Κn x//<3R]Y#~+fG~cUNNa��V֕NoSݝcWSTbDž#@ŭa;�5<ZTƾbޤ=,g_i6Na��`)%˴coe|.tPa;_}OFl79D[9`;�ܽ-WۣV?\h<]>yYo)��ޠw(WO6TbSߙ=W2Y^zb?��Բǵm M\<.սE{Na��|A;soz~Z}s=ӫo v +�đ%[[׼}G;STx֪of:vGENa��xj "Ysl}ͪ4kCY+[!}oS��$/'zwjs oZ-.dNa f`�'[ endstream endobj 454 0 obj <</Filter[/FlateDecode]/Length 2539>>stream +HyTS ԥj])r,vp`G,ZA=#,$y/ˊ(puF[uttL뻜(~s>ǽ/k)6���6~I1$$vo^*İpT?;XQ쳤ۏ,@];F3?����{ +7qѻ~(ףތ׀c'wD/ق�-|kǷUN-q,H2vy;j����܋~ƈ[}?=f>;!nL\Q{&}fTƉO-SQStds8j����܋){WaU]Yx!ӘεW%Yߢ;O WKKqA' ~{v?����}Y;a5iϹrQ=iįѝ#+J/_?ϐ7Wk����eXl]άS:n7~{cϽ ەRʤDw?@(^w/*-^0g.0m:#Ƌg2vy����f5¸nR3p^y'xyQbVvНJDG9~/z6?����`|H̤Bԧv1Wzk:DfB^^Na+N|D&&>" +ۺXKufAVv����0K^HJ? >*Wx揤㍻jMr)y�Vc ?0``jeτ /r ����(\/\ uГ|<e[D@wN?@iSb{6npۜ!皏 `nS~9ccYGc4\nK0{&"�����ƪIIyTg* 2,/ Gl_9\M}'8}<;G`!YG(w6w�����5ae:*xz$e\2ݹ.7qi?@&\*ШR(vj;ô+Z4!SYf:;8gجl GZ~*/i+fP4V~$0ɚW%x:;O2-/_14U#̞9T(yЦ32;���|Q*SNltwA~k`ӝ +jWx$mSى,qzqc)%'OXTYYp7MoϨIOQV9ۨ|0ζBs IOWTߓO{fosj,pj +4u h,wf¶|NF; W,EgWЎ3:~����)=ϟKa_ k|#q^WCw?@K>ŴBNFuK5%mўڌ'}Cn/Py}oC\y y +cdНzDġ'uǹhxY.ך莶u$kl?H7H���2;}VHֳPpQuL9A6s�r'TVA95"c=P?l*Zh@Z@b5V M> +5u{(?%yl^f81%Y 4༘ggG'Xc&=R8~,t(}:mٹd����𺄕xnGO̴">JI?@y7BzRcrf!]=0lv:Zj[U~<QfZ˸ ReTKh(XR+&PnxQoyTTDI˂3[uۘƄ_qmٹd����&O زctģnHs.蠢:nIc?`/Vf@mydC}9Q`VNxZQ}I~55SyJطG f*,C%W%DcCCmįsv#Y?����I6cU +?X̍_\2ǿP>tyr=r'XQ๡KGp^6_@W5b򌵌DZk_o}9S]`5J[sqe#8זxڬiu9|s���`4"8SIOϮq0ϿmwHt{ Nr:DB/4vxӊEUgLB}D7J*qcw8Y+w{P{U "X)!\G~����-~qqAzT'e:@yK\D?@$W*3u9PJx57 BkW Jz PK +vz8;O#JD>wKF 'rOZl_Xט٪퓳s���`oGIA � endstream endobj 455 0 obj <</Filter[/FlateDecode]/Length 3371>>stream +H{TwlXUZZ|mmK>GY-|�B@ Ph@mH& 3 "kWeu]]g9={j\q0iz9s27ǽ3vwD?4ti|?R);6=iVe΄K_"00~1<\{8m[]3: [ýseTM7gEV 䣔k X_Yf3}e檨vx#vSkVY/?2]P1/r9&/53lh`ȳrK]sj +E#y?AZ2^?M|4:Qi|\9٢p-[Z}'.dGn,Lp1jF6N(/]s?6X +콽<u +GMs3 wQn޾D'ei:`-Ƌ+YppE7yKҷ=KCAAFOC+/جze#<6ޙp-Ȯ1K5Wf +9>mϵGI/֖[딑JLb\2WFǹň*t&%Ym1tҌ̡j$Pt<�|asHנ>R-4y{ YpUcշyĮJ-dpkj "~ oeN5#q&Z<Yp-HuF)VMT3UsrCZwq| * +A;eQnSdGڎ5 MRW.v[Rq``5R֬>=rhS8& ya>K "cW;)]~luГw?0)F  dI6̢Uˉ?% o9c53AAFqbobGy&/^C>@(_`;;?AM&&E?7 ZOW`޲pW{gÙ  BfC>-bw Fpޗ {V?0)  "bYAoL}w{݉='?A9IDJMrIwQwHm,Mv3k &/TnolU#1[^k~Rmu CY?p̿iAq %F+ߞo{P3^f]o\`8S8H/!qbocetMB]jkׅcWgyvQ#?f'V`Y{EA {VI5(Si϶ӄ +#?n_lRgÙ{]o2o|#IB 82rK +t'+ΝK3<8 Ev3#m]ӂ4Y<FX;SP7 a؛80M^oa {For?0)P5J^쿠c'i[?tP[ ׃xm ++vW*F߲չ1 +FS:Gϐ˚5r}x4y }?gI~9@Xj)|ow*7nQVojބOQebve+M~d `b~jVj}p Yl([4450ٍE7CuV7?Śso,䅰u!%kzS| з L#a]7 ާ*x^~ ߡÙfa|@^V�ZuCoE]bŃhUjl +4ܘH "+ԅ?wUnܡ3zS,ڊ(e| ӤؑפJ]n[x@*neM,w*ۋ~WbR6kRgD*esY/Xf0){rk]-?'gtBjK3VYtRW,g҆oqL_h~xu'j?t-Y/]g ~;L՗m̕5j.ͥUA9{.B?{ ch �r\~ck>b|׻o?c o?"4k:)lƪo-=%xc tia rK]5e L5?Ee>)nM5|j]n9ЏTW(Ռipל�?5S~͵ParKy\nYfp^(Sǹ<X? јܬD?8[`(v +^B? Cjބoxme�ij<`8S8k$|lЭtɺ~}ec}UyMtܵ[4J)KҗL7HpctÀ|4yJ<V5Yq&a=[O35䆒_~/Ma?^D^tT3 + mJKiNm6lӬ<gg$M6" ~PvU@;9pzڂx{}^<>}? vK3vף><1g;EUhk{wsL*xh]9S~$))])ULkՉ!گ鿼qr=%ӏ!ɳ:VnXe@\?Z ?*q ƍA#iPOh{&sw:~\=P`ivwc'㌛QG8*;ͥ=ّ#Ve_u +Ox˅d9=[奄#i4(̻Q_;/Y{oS^, ^+Rfz3?Tf1{K&1-/C5siZٟWl>y*ߓ~6h TgCs ssc#GC.j:LٟN9#4C~.]&z;"遥뒂;GEEEEUle:XAZz>LԚ/rK܏]ŴV@\KE_ګ2էg듮Cd~0ͫw|&?yI̼ē(2XdLDƚPk_{9sRaܛ=��J endstream endobj 456 0 obj <</Filter[/FlateDecode]/Length 1804>>stream +HiLglM[[c[ 6haԈk ֠!UDD* J"]cADeř=jw"CcSÈuXO3z2qJK]꾫'3bNLD-]*Z_/ۛ2Yo%?Z+YV"]o7$js*9,X'{"æKyе���r|W$x0.aJvOMY\FZZ<iۣy/hҌ+]f*6 SMyf}m|\vI +e4KK럶7C83WK\ڸEEU8S4q/c7Qv'\ +~r3F7Gg}{ًⵗg0Gdixo��/b +.U%oϙ!Rv<JIyCiiqyYs[4OGwLH0eϬZ?fUhw _og̚괱JѹtJ%=gyі&Jy4 O#L,{u;rԗ<^<ozme|B:*bJfk~w?oiv��xcf1ih9›,|3=r9ςRRuyXN!YL3l7.gpkÅ9Z:h6?[Iͱj6<4T~Nh]gHyה?;&J]M{f{zOyX'{"ќ;ghT`<GYxl%'$!CdH\ۚ?DS^*t9!5,s)S< ¿u$ʊ�2M߱O\9^~ ]qig?PJ?HqW�͹w~)NgIFe(S|5۽��rD0*}Ƥjr4ݩn8a_ȰRRu +d6’Mv~:Z,z{DsBv��3%3 }N9u 6{/X9}#T5t!Q7i<���<{!^;L D®Gl4czJm7fv?���u|ULY$d|}}2karzE@)zr����klC7jrz"&x̳̗#JI���=]5 +m*RY>|aySL9!T����mFfqE14.] ~vk / +���Q}M.h6c5YϘ$ +���~/D0wNMGg#fp%ߕ JI���`19}>Kg]Eg<{胘k6-9= T����_fq^P^^2>~,j{SFB����gj:ٚ*N-Ϭ_dw+rE@)?����'[ֺL.jwzYӖ?jB����xt"Uڭcr9뭿N.T$/Ж?eJI���FeD 7}?M:VB����xrs2c[l0W~*% {p9u +L#(%��+� endstream endobj 457 0 obj <</Filter[/FlateDecode]/Length 1934>>stream +HkPTe_κ\)E`( Cy$s -(f f+) + +&&+eqsvlJ45DJe }[qpYo=}s?%oД+c+zE᷋"crsoqaEUmoaLZx|ɽScX.mIuҾ^$D jmsW}e #jA3kY `zo/O[B8ͥUs?('P6:gir{L&cöTo~5oAAw^ode3uپ|u叿NK'ϯ{!@V(qnV6?xnS\kdr8&+- t <3CM3JY֫v>KW9W +gpY#Uz2}?BGu(]! PՊCNPIWiE�J+d$jhn8/{\WKSyɨv_9\_" +^]J�c>C8%[wkӐ?@?LMǜhmS\v_9gw; +"3t <3ȓ{]O}*_ _c㚵a4 cxz;o598t 9ǡ~ ˓Sh <?LMǜhmS\V]Cgsm(x%*]! c}>z=�qϔ`0qqeUs]-M&[]~  ƶo P#"X(\٥98VyhW$CAAcLԧQF}�W xnS\ToqtM@ ������Tغ5T푧,1t:'\?9nS /w숥s% +������gP4)ڌD jm/厫=}e #j%���������������������eDZRl`?hkJKW,pDݒ{ynۋ}`΋x^5^9-::%[$eAk(l"=W>;?6yp,x|`XݚNkŰe=ࢲ8gMfD jm=_+[H|0YQ4覵 +溚k.mּ85z#y[gIob|h8# 充w9mn3pa0Fh?vtS\[\nQTNQI} <<)t^tZQnWba7=XҀ{̍gRO:m26l[Auh}g[c&!5g 'XALn,*qrCqS\K/t;Zh<P$Nԥ̽c?{E<>NO4sx\jV %擥S\ToQ6JKxY>c*ԕ#,עo//,L}7 ?|%}YN6l LNm26H88/'8xX$x2Ah;}{kTz25?K2 }4zVr[DY-߳W[\N-z:AĄ ,f$6'v+X!'4 +4t?25.Wy\Tm2X*EH;ZFcJ0u %gq=/用+W�$ endstream endobj 458 0 obj <</Filter[/FlateDecode]/Length 1448>>stream +HOSg  +E'( 3Ήe\ hUFVt'vS7!1f\r[D$4˦qYy+c-, +Mh$=yyb˦6uGTpצD,2LK>FƾAW]r|q؞鵚@2Ev˯! Ѫ;gPS;gbfjUm#\Sa@vn\iiЄ|oa}!0,͍JqŪvR*D]s$ɏdsbyy8rkulR0ګc7DF1{S|P[}^i\ʟvwmM.^*<d5 <J?1m-wxV3?\{4J"/3,qd웬+vi72 -a6eڵOϠv&&ݯjmީ<W}FOl'&)w-kWeDgJ>][gn*a2sMIyFF2M Gymm$2׬2=(*G\Gx3U;j`ّg]o v=$@@u%R)2R>}{'=3UT!N^&Pe sۛ;|ID"f-arAƾaq92^v詿Sgd }/yen )B0zmޤ~#c'o5cbYa2\(dmpTOֽG3{w`Z(2SSܷi掷眃`16 Q2CƋ[hP1,ɜiL\df(L߯/`Gض]�^K6Pp99赚,z4J}IBTQT,.+ C <:cTY0FOWݴ[~ض5;G*s /^'T\8q"^7T:!chUg%nd^ HTSQAgNx9vFeJRVP6=Q11cfKPO&=eeYO\>=o"ֵ[CZkk‚^Mʗst0=\ƭ?=zt+m.2=/^ `W{~<a3́�«8Y|Hj>{}oS#VE�������������������������������������������������������������������������������K�VX9 endstream endobj 459 0 obj <</Filter[/FlateDecode]/Length 7414>>stream +H|Wݪ }\x3I3ɡ-.-@(%N/҄зh;>q &%MijָKl pr#Nl9A}̒?!~[oOUIxm[ּ>N428{HOB +V/X3$,k.K'=iNI|G.?THͶ1-M׆2b /~1n׎X6Bm(낥M.CԱL5MnlhV[Fpup@>,BOٹe} F/zH"`<#5ncЋ-" t-JH/o ˦c,]2mHɉ4M]uKk/b0rU)\;_8㔒9c %R +t-t3dMI}UYeSL(c*f~a14}o`QbQߪGPtu;޽յ3 \1%ǕEP6J-ΔPޟ8P᝞9"ipO >,v=9(;M�1GDA6e |1X%Oޝj= +Pg6Ç*?H^5lM *ifs)%l2ѪkUMX?g Fhg-Z3~'51>IJw€m�Vh_T[}tgќ<UhAm}L*Odݥd1?<\s]z½_@kS%`C/t p7"KpK^pQ*,-;=Lþ}ۿ|oo߿_?}ozo/ywoz|ˇv +Onǿ�z?ܾk ??_nf'8y_?A׸ +3J9A[0xw``?@?QfX\ʽ6Uc9P)v�'N8GzP|.b G3QQ̫ΈUW{54:+�q R8౜\9BGN ?*EH<seIGG�FgDO=;a\5\0= +>*�@qsĭEٱJ``c*ֹ_cu͝v/~IInK;ۘ5v1%[)2pT*[:NW"GNwKK=7f,*E <y v.e 7)0q^ +,?p.xL�Q)ll}0V5̩uXI.Hˉֱ142 Ǟ u:w23`+gi l cr20TV,L>e8lak(`CرsfwEӂoRٸYӅ%B 27e{)}.c9ʡ5-Kw*he9L'?SC,U}^탘dMK[Ď1 +ZPEeh4U6QVPǓ%xU$X#}+ѭrAjc4n7.~i2F[ڏ#,Ad( I|Kp^M3јC# Tns$% +4G2Ǣ,; ĊDYEB[|V(c\ +t$Φ,I*�{tj8<U[64O6@-<4޵u(-"Ź9Iy'h-իˤc߲ka)A4qBhc.%Z܄yNhAC$2pN Ms1nL8<j@ܦdAZ&dß2v3g<INcड<Ό +۸ /v5lJ EV-K 4M.rlM͂gq>s΂Q2ME&U0fF( 0χJn<pP*`8`#{]JQP% l/ 916QJQ m񢠧xK93{sn#wc+2xl6ژYGƎQcG70[P0xSl�kƫ}]NcsKt<IM B8ZoUϻ5€m\Ţ5X~ +%&b_NYu.`+NM6GljqgxH2jL`q/8ЊbD�֒V`ఙg|;\H\V1O@FK0gܓ'U38{F�GR1ָe ph�=hjۑʢ_KDJs9NhH@d4oT)vM@~־7PE%8BZ TbZ. R1_h );_8! `Awye�O0\qu0> EaP!,81xS^:΢މ +;A>Q$ WsFhpgc&pc=+O²˜d:P81S!j\e (IT P]}B|6Vcu7BdW)Dcu1$ۺ05HO|_.YY􋕺i)8i@VފFVTei@'`NM,4Qs^V�:bF2#)CKBa":5hDi*_p_y}/V;֗9�\.5?) 26T=RUVW:Xk w TS-HZ'+� =VP,fքb)9A] DQ�xeuoЌ4wkBp%}U$ѹ$" \4AŨfby݂WA;Z8uB%2Rc&ԓ.ufĉژ&Zi 0fAu QSbIKcAtA^A Xa7 AoxJbāJ#rUH*bs(hDlt/$N5ݕ901V4NwYQ-lH0#51PfJHz$Q 8;DCT[N5KHE._D"}pBAHezū>8%|c S>[QzdSoMWxevFP+А 'cUb7;K`lWr~2:YBb:W6{5{fb4y1х232+5Z\`KMX<qga: -,NF/F}z�+ P.6$U#Wf/\f0rXeųfiySl2Zn'CF(rIOW4G%b'cE@d$Bªbu2 |f!rl^@[Ol:A`*e7 =VuEelP9ZsgKg 7tV2hP#K'&QS +Ս J<KV1@E>FkN*Gb=%JU-`܂ pR3HvȆ9ӓV3˜o.DYD7ԼRj1kg Fb[$1k@> AԂ\P:YD|b4 z%]&*%LE4P9d֪81NBp|̹5$<g"cIHF񕌤)|L +7. oc/ *K sQ@BmPgCƉY[hJꚃ%5*Nr@A[Y/>H ǪJq\aɵV>'*52kqAyy_�>gtZyJ.|s AϕZJDQcAFRwa2Ѹ@l4*[ n\X +% HP0V1b Ɂ*2Ɓ)tSk+3e$Xj# :,N, [1c8[<`ASH)M24>i�fK7FJb"J]h/4:H角׊X0jaPkFEZd30h2X3c�ՉC%^:d%B_n 5gJ< yjʤ0]`bb/ةR-a - b hY8V:b 7Xu<IcZ#3<�cXy@-u,FLA(eljd`h.T&QX ٢&O +5J9-܆$ +(Nic@cmg�F:܏1ډB�\[;'(Nu"QEa e}=!2+Bݯ}޷)L/MwBJԷ?_볟>{}~mumϛql7=#_<目/W]kzb<9{8|퇧UK?c7݇|W=íMr7/|yոßnǗxؿ9MZc>7jg݃5?{hi~b٭6mOaV<&e۽Zw.Q1]s=0?x1+-G +uSsqcq;2 +}0G߿xZ/vHȣ/E{$u̸ۼܭ~?*яjnwC'Q1c=<AQmn\,VG<_6M`|'_yAk|>5́yrq ��OGFs`0nhl[վy<^n7=~II'w^89_=I%Lq{Hٓ;ɽ;ɽ/ܛ-%@":}Ӯ.HýTCMٻűo{%n#YzNm]_H :zgcm8W zێlCc3|~;[aEj|R,<Ͷuh/ƙqnl}?Xј"/~W~;6G9o7}zo>9}BcQRK"_Lr`ϝyˑs(;r,;[n(<~9sIL|hXf T}Gƭ#A,G ia0g i|<^[D}$4n\nnq@aN;gJ[ +9.C;l@n=ZvM߫)ɦY/U6D V *0^\9(LJGm{e4"~6v^1Jޛuw19:;Zlb+tTo-(N0?Ljvwx$}BEJ9\6hK 6@MM%=$@?[DJpEŠxZ=p��SW;wl Nx[1l=TZx~FgDRlxu?W죵2Of:^0*F<jt>cvjZScmڤXkL1kYydsmչrx3R,% 酾*a[Gz\f9t)lO`b&#`]\$bW^.F33v>éH:jtiМLMgC+:k[Q"&]ȭ(Bc'9&.OHtV a h:$ f/ёH.i$xHDWއ*c7bGDtٰQ-+ߒt!�v:΋ݽ<73j7$QYzLs>25*ǤK}e0i(a:u PgJk}?3P]w^"Տ2R-<v\30څF6s6:0.ф +C#V&bupk#t +st *x=a" ǰ1Q/vX1q"#+5)g?Gʀ(Ϻ8=C+}QQhpaZRO2ÊcLӔKf6Km"7"!V%Ls]$׳gҥ=IP1I>]`$fW^.FS3v>.'r=#N9`BWޔS7Muvg:2O5"ft6lFLQmYii{D\c@O@!]0{DrI#yC%>4TI9[R$ˆGjI\A~Ĥ %� D|=}Kwiuw,vv1DӾ}\qcҥ�4I0#M2cps`]g<띫JLU׼y%rH +GhEdNJi` +ŗS�{xg i0q~FnERTBLm'6uFN %&묋ن8_iS&Zh/јJM6J/ ޼<k'6ώ'ͳv>kHI=FćCxTb}iGVnrhmm8mtݭm^%dQ}.;7~`SfvɣP\I[}d�[/N + K F޸>2-A,R! )(W@20څF:ONtu= ʫ)X ɥu1܇H9S'L$>a>WE'D" y$!-2/)g?GKbQPf*1+QQѝpC5GZLS]U5fD:aeIB0OTm$*VF"M%̠Ԑ818->yxEL3r"^(eSx6mӛ#+3Te@NE<M9vmaC#rXQ`*�Vu2);gC˰9pIjo|mdNJifag/T Ra;lj.yTJ B_nn\[D:ŅV^15h̏$@k;#]&2R-|-/c ]h$n9W9tN>[6iⅡvJ2BrFy{GCbm !hNay+�ns endstream endobj 460 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 461 0 obj <</Filter[/FlateDecode]/Length 92>>stream +HA��  =��������������������T�����������������������������������������i �H endstream endobj 462 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 463 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 464 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 465 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 466 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 467 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 468 0 obj <</Filter[/FlateDecode]/Length 351>>stream +Hk@phAk>!`S)!5_?m~>p}/�����������������������������������������3dw̛<YNxӎ/}S*I7ټnUT7fT/~.mCo7MEY|ѶrQnݾY^<{?_nǗۋ6T(U-UQ] U!h8ict8 40]dvtw0 iŶ<BI_{YG9H֧O���������������������%�$ endstream endobj 469 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 470 0 obj <</Filter[/FlateDecode]/Length 4081>>stream +HW]o9Y+5[6RD߾{øسB b27M09~ I)'O޼Ꞽ1[{Vaͤ@jfEZ+62fo&F~`~8?%4?igON7ѳ'7?Գ4uzRE3$̀8Ȃxa'1EVEl-pb)EｄL1.[H嘶OKgArs4 C󳞣f"Bep_qrV9 NwLCi< `kbv#Cڦ e ^Xa:jkB@rlr@X } \ +@SAH.P^IaS]P~ ."gX[Xrfs93)4 `_>�LJgWh"'@P +)I GSR�Z-=I cEZ]Xv'LrTH/Mkv56�FmmދS28;W^$~+�C +ucoB|f@JdA{%(zS+hK)}%@#&[B%_::,1:m _ +Z6-AOZXr%I}QMAOW0CۄYJ χ&x[` ,WR /4zmo7*9 jyV4wR;ֺv7.[�PGs$r +XA˅06+U-[QS:XQ*3ʹv8INu>TH/Mkv56�Fmm޳\+he47qqѱ^ >kyN)4=i|S4T" e~["78"^Bk 4b($XR/n:I?`ѱ}�% R[ 󃞴ZõwD?/hMɔ*+fT5=d̓P%Oc$shApN .ΫS2dʌ>Qb:Nfā(2P | 90"5#rJwàV7@'g/Q9gt +1N7sIO_R''j't` 6wn~CwE~=gM էIUkup͸FSҙtź' PO>Lyh__~ƈ=L'2MtN9NU׽l1`čVJ0i"d!+9 `"d9Gqjs<AE�N(ʨ�]~5}/�k e*{JcԾMѱl;ڿt*HbƱvΡ(-aIz/S7uOA졞tDXn� N;@ MsIhf!/?cD HCE<iҧg==uo"}0uEJd!+H*U0s K|H >�]~5}2w`!>]ӕٽ{Jcl $VF'Wu+~n-ݍQ{b|V3m;c1+&E +ad+Uxyt SH!}uK71ji0Z,L Ԅ߁!/eZ xɱ#pFۓVcrϛW4 )`-$#kB + V +II)lT0\;)GjV%0jos^ ܄DIadUfVohE|f@JdA? 789*N+h˗Rω B#&[߶4K +u%7>2>ɔ*`&s$4FazA5޳`Rub;LRھVF'W5㚪ɔ(:o0s[ +Z˜q/(-a|vD}XRDt.yB58/F ޟ);q({�^kmty@]by4+s^`m/Ik4z: bf_f&0 |A G(׊c ~m_E`鵩{Mݫ7)|5^zJ5 *߻t_4գ]_4jiX:KI +A9QVL>04?["loč#բyg" Jc!Osא2Dt$ P !E$՟b22+(,q0w.eŤ"fwK4G"cq9 y%#{RJ3=~ yrԻ!(k$~L9$Sv]o9 +>h:g5a a!ӫ:iݕLR1MG2"#q6^"9.*x +)@y%E] QlkmJӸPM�=C9@3�ݭŸ?/4&oa툷{%FǾt% R[ 󃞴޷aXr\Hפ秽,p|H ?{zF>/;F+pG/"05yKM^rMLT!-m.mj`+XK%4 +KʊΚi1d\$Y{ԋ=RL 8E&r' #r^3"D|7 Hju|*yrBLsAgPCt/;O(޹BٹBV㟁 suEQQFٯm >II'';Mt.-$w(Ŏm#pX0dQhxfp('}52۵{J{ Ca! +4 "Ti7|`DyW*R$2ds:II9�j=vͥlVE\DWjmZoo+ o\fgFxf F.> a[}�@(TwzuIGF7fL^"o:4;[MG*F^L>ˇ8Բ-Cګ֑0Pt_Z& 20.N*MCvhؒ[C@z +p1j0oWs!=ޝei2$MU ^`mI1T!|q8ݒw4>754 ٝҰEMFtG J$6oTfqf}亝Ȥ$ .YU+o"5iG.CVC{Ve S�s䠽;Ϻ3!sEVS㳫Xڲ?k8 eIhqdIpu]kZy\lNobۙd_)<{-&o|$0iP\N~SHI2]NcULy\vHu>th1Mu�G}ԇ*�U<?#rM"hfn]:k�b.(YQceaxRpYb;0\VrY{9J;eM_Tlp7vQ*t�.'.e6QQ;$ 荽g0,GPzLޘ~-x4OEd}Lܠ'5{{c=D)\:,C2*HőEx<hl t F Q'H5.}L=5v?v/8%G6A}cAeO8E9z }Qv ,~EOb DtmQ,)b 9K|@$|" +�& j <=P<(A Kk$D,@@ w[�T7O endstream endobj 471 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 472 0 obj <</Filter[/FlateDecode]/Length 699>>stream +HKQcsF Q BnbdXPvh# .K(vc ٖӹ!%&\g8X.9|9<B�������������������@y.3+K7S[kݞ^u���P˥"NnMTݼv}Op8P706����WU%>'biٵ����P\}#{oe���PU,<ˬ,|J/V]dKj狉qf3<���� +od"W/c ͮ���:>%Ʈpbˉ#f���@1k3xg8UWS]-;VGx.B!bw|w`Wq༡Α?}b,M!Bn"852wdSQ^#γ" +'=z=&cRz;M +w}C~xih(؞M'=9r_-1]ʋ>롔>^UyŘܻPǝn-꒿'gzz` +*<Xzɦ닱>0{>z>zy3c=gc=@W̳>z::.eF@GPJyA%3��^Jg@`�A endstream endobj 473 0 obj <</Filter[/FlateDecode]/Length 341>>stream +HׯJQ Z,LN'oAX"IDd) zu~S*�(X{U >?u �P6}H�l3�@5"g�kD"��e׈D�ʦ<�M_#y�(F$ �P6}HR;ܧ�� HRw7o�`A$)~[��dI-/>�"Iy n_/s�w<Nt$��j"IyV� ?;]ߜ �/kA173[M5O� ��<�?)�{ endstream endobj 474 0 obj <</Filter[/FlateDecode]/Length 517>>stream +H?kSQKKEC +(ͤ?Sե*ZD +Ep6$B58.Ihkuv8ϡ7tI xsyrw8$)?g(гt3�@~D��7��� bS�bl^a,��v]EϞk}K�{ >7Z:X��?I}~0sccO�@J &yhp0Y)x4��tϖ '� ny'p4��t3.z��?}�ȷGs׈�oke5b��ALz ^O;_IB3qh,S<]\C9C9(joĢQ{j^; ݟOBs o]9C9CxQ ��/5bb�{gr�� endstream endobj 475 0 obj <</Filter[/FlateDecode]/Length 623>>stream +HKUaR<dPA-"m_U(D +QQ-6!R٨%^M @e'm + +#ou!^[ ��fee.5 +q>�D}b>�D}8\5qW~>�D}8XpQ<;n��e_#;37t��e_#/r鏛� kD݃T_ﵶ�@׈# e2Co*+��f_#43ā�@׈3m5L��ě}(^j^?ih,[dY,]ܻ}@*?|s}Hf^j|w?�;H*DڭywZ7?ך +17��~JATUTv8#CcTx.'|h��tI%}X6a.�t=S?7aOeyN�m?W?(iB�Tb1?R/)<��Lur~Ac,hq�`+"Ы�7Ew{[/(H���Ub endstream endobj 476 0 obj <</Filter[/FlateDecode]/Length 638>>stream +H͋Ma� oy F;{! Hl,!Y/;sxq,Ԭ,,,!0vs?:soq[(WܸvUsݪա?˿{>{aK~?%&��&<u[?vkY%K.z��ܼ?şhrrryM��LxTݯ?Emt=)&��&<Xhzzyhг��YRz?Eml8oJ|mл��7bQ37*Yxq_]��{?EmL;pe=KJC�`;A,Dzig%KFC�`\^ %y BO�GAXjO؁3Bo� +Y2t �ȒXG~ -%oBo�`?Ghiq[%KFCo�_h{z/V.^z�@{hN쪞u><3>�f7h7Szz�@W?Eȯ[CiH}��.Wb"K�̦2Y.[Y"D�5lAT&돵;g;:K�qm1 endstream endobj 477 0 obj <</Filter[/FlateDecode]/Length 633>>stream +HKq/! Y-P!TP _6u%BAa?˘~/eZ=" wwб |><- ��z;tOI9_sog~_$hoғF���S +ʟ=gOwk��L5<0H@+#^\iڞF���SGh]\?_��s(@<ܺ;��LttҮ?|_rN���MIpOvsmqǩ| ��`.:S} ��`D,?Nq-7��'3N:ljP~a"-��4!:HzU~礷��?NV1p*��y:?/-.4Um_z+��ict?™a͹s��m:=֛d|^��� KKg^RHH��0˵bNGBC?I��0*x<T}���&y]ZWo.G(er]:#=��o*݆أ? q̾z ��_ �  endstream endobj 478 0 obj <</Filter[/FlateDecode]/Length 1531>>stream +H{LSgCAYaS$:uMŒN4( 5]�e ' XJs҉"NAe:xEA쒨ǟ; !)SSx~{sHއ @Nњ#Kߵŏwq�^s,I,*)\)-Td;����}!/'9{L2*-}Vbdt%Ӭ暃���U%UCM+D11 yѤo}m�3<9f����}bSN#`97JBpy"=u}䏰f}���� L,ySek?U*rʶ=C5غ6'yG���2BUHk~7ܞTki<G���2t@V +Xdnr5t"2#y}����yǗ0iٛ?fpFiaշU:]f-yCy0=$*$xS,vP'����\W4?@Ȇ DTjc1xHkqb~s1MQnݭyO{?>[L3+;C2lc���b TB5ӓ(S+F!7Y%'2^ȼowq `U2ŕKyO?MU:o:K����´:4 H: ::Q?wwMZ #Dɒ$s91'e5Ǎ1iSsˊTfiWWjߑ$֔~asY&Y]d;���@_ff['R?@4Hno +5{Ox/"d(RN}S>j8 &9P*Ie3zc����!Yt" pnliaKe5(v.з^ e3K+۪C%+L >h ��� �CsZ*+ߎB=v{lU93\@b^&RBQ3ݳH+VIjK +)���3i1[%t"?=w,,Rld{ ?˚2v���CB|):y<%E7U.yx&C"ML{g���~8:%1[9t-r;g_u͋ƜaF3>-���Y]TR-\!3/ 4LYG7F-?;+];٭���xV/i 4z W5eJBZZǟإ<zR{zDn)���kbyG_U9;k[w$ f2fGӜV���Wݚ9m*3�z W5"n~ŝNf d)i)CW� כ endstream endobj 479 0 obj <</Filter[/FlateDecode]/Length 1252>>stream +HkLuG6-kI5tYaY9%2˹dDA:DDID$Es8<8GtyCqLſ5+œlK/���CbLf["~1fI$δ~Uӫ;3+J~r|O��<k]B=U*j|ZY8)rx[UAΎ/j��w[fEαd!KNJ-?^XEN׬/3{-7m5_?W��@O4%l;sK?tv1^tN-,k��;-"gH? |ޘZY<zq[֊Ysz��J3?1;,dޙ𩲿$_̑Ǝ#NU6y4͑+>��2#\zL|? ,2|έYiYu|=1O~uާ���`VlJ@&7[IfG5kfpnK5$&o:h'��-/wn<K@&3}J*Sw9{dO-[G���؋hd!&`ջJLQNM䶩׺#w7G,Q?f(��|(T]H@&3zcf/H{^tvƈG3k=喫W3��T]Vb-2:Ȅ{{J4tk'~}~z娹;S>��15&CUedB=ϬU624u^ӸΦbGÆ?=L��ZV(-? gRbxl(v3Q?.7ٲ}>��^؜i/G@&ǽg@%"7qT궩m]k-ڳ!|��@bNo셻ȄQvXsV=5Tw^jr`{„}F�� !|&" >3SW58L^wOwlH5iЌe-s}J�� f:? fP4%8-䨦^ԫ]Ǘn^.v"xD'��p瓬#Ȅxn/Lkr luw-wi�Υ/&X xۍCnrVjU1s[z���K` endstream endobj 480 0 obj <</Filter[/FlateDecode]/Length 1319>>stream +HOu/D ADyYY@E혚`A+yQ C9 !/45dH[m5u[s�6}}?$Qm5&YN| B&Xko]D{o!oM6wح%O~Д&ε03];tc��n?ڶ>@M=={+lgW=4ݯmўJ��|7835lVyB6nϮt7&|A^7G)=r��&lD\Ѿ w0GJ֗{L Vz��9 PGfvFhs|?jL-xlb3nTz��Ei<<oUy{CPGg)R|qfXlnYMϚt5ǯ~&'{uW^��b8h+ @M}첂#⼯r 9muü4��W}G:h˾MA?6cåG\^j8]׷&u/`:* ＫJ���0:(F[y(jBP&?MG?u}g\r}~? ,NK:|W��((|xm CLz&P.f^ua6Rˆ%K5J��PƬoYq CFH)oUɦ;5^uQWVs96&(X5��},J;F@MMt9o_]d-{>_?��5{7A/4 2~c.7=:|iJ ��1^6h5fn6Ίwig_R/fe<<wҫ��zQN7HcPkgB2٢<1s\fllIZvF +�^?x|T.E;o5޲掮k6,XT~qqJ��ao o4,T>ϔvsblZmnȟ)b~{6p��z7wwKqP%2mgAJ~}FKڀSO.Pz��KO,zTߢUf5z޳Ebe'rvj�Px cM6w{5wB,%fXVxAֿ:n1ߜK��eUWH۶V 5ӝ'=o+�z5O endstream endobj 481 0 obj <</Filter[/FlateDecode]/Length 26164>>stream +HWˎ OQO}Ɇ<a$;"ggw}1(.s"##Vїzt[rY YξJK:rn}p_˧~'aK~o_>?|寿}k/?ϩ,*rRX.'řZkH<:<RVZVfMcWZ7lkyP FF ix,? +2�Rjb%HV,qaM;R+>{H#vjpP&]-P "ӻ"AkUG`�BY�"x%ЮŜbQO@L\3&ְ#*P&01Ӓ'UJ&otPt%*`83�덛gA H9~Vsv43qG=ہ{P\5F$sdwgw<?~g ^�*C9(r_#V^՗h9C2Gٚto^؛aU>jVZBG.Q 6ie'V kc;H)XF)es eeĊ7$+c;{bTR "W8+Jr: �,̫hD'WwHUTCΊ떆ʡ> +=j%yQRŠFOsʛ oYEp%MP{w^GԆf(q gvظʘm^w>3>z;/:kk&j<HZVxfu:e!�3 y@U%v3߸)^ a2i~I6dYG0yT + VboX MF`pԋt*#ݳ+VV^qwb + +NdJ1`fg.Hbyt67#5WWڝrV&Jq&}k� Oj!̏X,5{< p%dÇc)"&GF)hۮ'�{!5(:y66Lj +&ƆkF1VJ"̞ls[Qp:wԜm9^Lm#ӕy {w },<wLyT!`3f$R!ў|9gݜm}S:VPh+ tM"d#BV +aG4ڷqT]a?bH'j 3qب +Sr6Dg紑&T^ނV)Ggi%3e֊nMBK%,6u:TPu + hMC4z`WirDI2W=9u9 ^$1I&J^D^Z񐣗.uކ6RW5DA&nc:1aa-^ w~]/[\^)25R7NY')Ol6ߨ~!!$C7SHԛ+$4É<MRD֭)UdGvy헰H!; Bac6,Y۬~i ط7cP4 0y(P .d?R6 Sm=ww6lr_XMQ`z13-49RMu!4/|'fEzq"poE1y-Gfu~^ȉ%O}HE +6 Ŕm I)="8YjMIw%TEQ-6XTHBC~CVJA +7ND+La*CQgO;tO!6'yYCi`bt<ӑ8ׁ$g(*~V;EiN= @"|{_?+> F\,^Цd>_#Yͯӝ\q\UV/p^NGto] .k'TkΔ|/\wdTnvx|*X TO FgOUVGtF[ShH9Xl8:"4H^C#bZZ=(DEDҥB/lJ"kya5UWk +3AG(\մ~ cYV *mtF)cmg BòކAOZL% 6TW.f:գ^ <d[u7;`,h?3aJgZ՗<jh*]QghŦoߖG̙}x/b][*FJ܊)pfIJ ?v=zV܇�m|>nzՆțVW1X+v[h\MR:Yf܊I5Leݸ6ji +w=*k6/ o49i|a^+c+DlcjsJU',6gFC3;>FDב3+1St 7cnI^%|{}zKPza2y rפQl!9-F)^2z[D!q>QqZ",gyŀjd# ڣy�]َD$i/ݨ% ?úd.<χK&bG$FDfm)3x;Șz-ϑK]]]_6dMIWkc@^LxӚ)ڕyk :hm(64"UU\m δp!zj ]]$Z(׶ e\Wl~2[�;[5B0DeV"$I$<lI - </t/.saM Yէ}!^Xuꩿў4}+51Ms :?D_D4muIԹwtuR޸r'wIOԫI7.yYVQyw4-sk<[-^=ܜ^fZ+G'�)?ga^*w7>"/n!NUD#rw`i+P(VLYAjIt.DtÎ`O> W-n\Lf;?vGWr]W}gH٪K}P7#Z{rڃ2*3y7;gd't/ԉ$}۔}|;aC~O4NDfd4V$){Z`Ld.JO|/U0LMҎǛ_uwW?]-~/߾}o$lM)Ҝ„K,xGu\t>>͉I#Ed.䀽\R@fÂԐ6lhј.2qP;mpD &&3HAxlEb5RAChۈGL`rgn:]ebl. h]Fyr~[/LEwQĜ'j!Lmm<DTV (X%UF]t!08 v5tM ,}rHAYDzvL;-&=5]16frTBK3r#tјihn|*RvuMQ2bXYQųm :ҙ-)Sgؿ~PF"BAZQèOEj-B#FsZ:&)=[Z[.w0 + S*bk|LZ]ڶ ^/芏-̸ I']vMnjIX鈨pQ#ə&wtИ(x7s+\n/08m@ꎜ 5YŁҶAyfk8`)�K,g-.AKHJ]Cy,y;߼ZrCA5q)E{a,rһW:W]=J =\QZb"Cbh^YYw@+#Z(U Dh74Z@iw:T<l׿}6s>,5 q?JyQþ@w-'eh+ aLaSds}#c!`i;K}LCOeؖcCHdԌyx~_lbAF H2mk%J!!Z,=X6l%ǡAG1l" Qcx΃+]S-==7T(&6lcNؔ{s[Ppz|2ؓzB܏zp8$')t1<Cz:.dPk)s[oMI&Gs$~o V&d&) I;Gqj5Y.˻j.<]N]śB,"\\YkWA(QFg_d}i`/MCnYKg򌙴<S9m/{.]b}@].T/%v)M2Z&_b|IT,Ųp%@??*='TrLQLe,;ōc}٧oզhׇs/V˫wsߗ;z .no>\-ۮTDyI)9Eu}]J7/wWrb`}u}u|u1Z]CZ>l<vGONylxps~{ÛO[+Gx}|%?\~Pֽ~t 9x:Ш _kDZyM䝖3*,<jV?"j靾 r8c APePrFEt%f5pIs8w؅zvMCr?+(oڱiݝtaW`Cd@(4t \H mf9Gk OS`FƩȱBt[`f7Wb? KQr,M+>Ve~,y \%? L}*Y2F<zF:qw\e8ğӜdyj C2L l# 2qIQ92Ɍ$]jWIZ"#AV\K5U~sH)%HC@@zđWAސ;똻$m։wKyU 0 _�bL e >jMCK"o:BDc ZA|DjwOl55U%�*>V߈n!7<$&PF)2s]+!PYԨ$yT% >>0-AF("A@ P)6[ȌtbCPT6Eo +O7X!M�ƙ*[(^7^$`wC2 (Nd)﯊ ف0:bUd>[<?i~͠"::4J:'&=k ?LbBxgyq Hr[ے]L܄7rXo7PSBգ8wu>g[$֝J: :Bg?CT(^64GS$g㢖Bz6ad}JKƮWxKգέy^M<ޙyqͺj Gu9nu�ou{ܲDd٢4s ,x7iZNy?V +eTŭo>" 9F%)Φ;Co=(&�oiDHy]?֪of0xg-Y<M/#Rs*[yK%ELn3dE9EptYol}b֛nv2us8u<m +&FV˧wt]*еRQ 榥*(hЋx%D/`<]n'q\EC-qWM)m!AM[/4ڻY&+ )*(9bD8Ih5#)kզ[X>:wҍ 0_IɧPu9K\%9$S^T,bԉ4pO;F1rbez}n3)@RS5"U"Šx;ʕp4_3ie!VuYw=OdLOI6n6Z=xۺ_b]O0~y7Os, {i7<n$bU󒻆3:S7sq{NY7dZ�r3EhRR +@2F(BETma8J@K3 +<ZѰ,,&5_<G_wg.&__7'}G5CTHX)C$HɕٻLΌJ\TW$QifX@XxJzZ69Qo$mM|7~ "a{wi<SuL(cxѥ5Z>L$˩+_BԮTR +;"^VAj:A;tkV-.r$1U0L^9m&OLoI஁7VMWuGHAr@RRo2῿ZTgDаrC,+a,d!| T?>ȬNyKq H0 .wZxCd$3ܖ ֦Gadm͔U+!xu@|D І +ݳ%)d<u*?Fܨ=4Jҹ8劉T xQ)i(҉)QWC愎Ku(c{=�S(k:}Ը%EMfi;B!lĒ'8n +aZyztCŘ"Eyk[ƳI[+f>cT!g̔p8ԔrJy2.IJh=Q.5?o/pBJ=uURGՈaM$I^C`YlwU֥ )x|nY DRɓ "\Q:zpv͸}3jOC[PvM:U�S̀x6$kc`])I97 /+qG�$f;OϚ_JW& =X]Ƙ$?% r9 tLZjKQ\<B5UzO]}\ܦFcqgfF*й#IXA\�Qյi}:B}w >RC�`{us9`j44]'/+{ *F(`Tm9nG#'vϚV:)ܠP>JR + +߽{-Rh{yzL^ޓ*`f$TJ;m=�>paJXthO` B&AU= Dʢ`Pyo8nu tɸiJ^ +S"rtI٭Lr{?}|l z\{\6^ 9%&XE݄A8z\/}"n(<"ӳdA^o+طYjvO/✾Kc=;K[]cJxKG6k)nO~inΚh>)0CX^܇(f*g܇0>v8#el*BW̕f? t,ƨ8` W<Gho5 D2AEnٹo!("9 n&4*a5ېlj)Lc3w쁛6X!0zl`U8BNq/J‹yڳDN8|m&ڏ<NW0Y3""q0'ُ& sSS~pDL#m]I)lHH�oa'oc<*Q8S=^od�f%|Rb{z4V?HծDMRfㆯHah<&QC\Vɲ:m1Ӭɰse♅D-G;ΎjrQN3ڒmis.Xrs5Y}+^[^"[xdb?aoEST8;rY(=|!븫tXAI3}Uc 4z]:�R2% +l&3lm5tAr!K~ZfkHз2 xtT+V%4F<~f{[.}"5=\D GjpDE&x/aJkL p(Fd+)dvLDG[xU XA1v1iR8SES,J?f)M =YT&M7i!4ȧsŠكUgm]=8u51.}o=w>)@;&R)qF:EUfB6 >v?T\}0=`)4uT*t^AFi+y(݇vCG,=yO8 [V5VC9C)Ïz6ӒDZěКE.xsIBs|ۦ:]1cQE'�lrRX�q:D p2tq$/+yOg`Mlۗu)6UQrڭ\QDfRg̐U$b.k8'Ed6,߮Җ@Ȳ�do�BC:Q6:wFʻQEXl'c>.Aggps;m HsG^nϧPKlxE}<Ж!*èALR}lWz?Mƌ ;$By!n턙MZHtw9-qJPQ4&i_P*b 1>*w=4ݻ/D}XRO@z~&z)uNm Xe8-OyUymؗ{ R Jz)Qck(YFpFL]ZGy2BJe4WGF2(|Y?P>)L9֥rJ6RIt/zOɶg|[|BSrfDm9A{> ,q3@3p;_`m)!Mk ɬd6Wpۡ{V]pMv~:!ewkg`f / +2AȤr̂ŬU=t� ] p$d*0p I)ݹQ_ZE^&[׼f;{yyz5frkŠ / @=m>|n!pDXEf(2b + 4K ISO�r1"54ͭ6,T$ Ңh`1eʂ讧G D[r<_ FO{9m9l-yYq/ՇLhC=;xuwZ9K}NK/k9n*!jn}ԑwQ7J =7F9+ϧL;n}:{5Yvy(8<L6ú]H9֒ތlaCЭ >_I[= n€j5ֵ)uo{T\|MS0q fsrByvF,mi~,+@ Jlku` +}V[Zs#u=?<ۮxf7RXT +.`zlA&ӝU^!,ĥr QG#6Uνx6Z OJ+3.GX;W>i"ܠ�׫}\oVJAKo=Źmd+۵  `~b?91p*ƄPE1LVܢ:6{] %8M8:)<0)9ap<6(;u5 _p�0Q4c7ܤZ/2 g(0s!} o5xR :XF-iꈊԆb&4o‹Ō=s;[ a!�J +Ao=k;Y6߅=[0Fc|%IRzP<X+RA/;0_<!^͂cRfs=/tNW3x>`-6 +/iRZ g�'uEpOJߏsx Kau勜J<3X;VܫE/~?}~o<%(W}7_/?O헯_oz]|}oeJ[9J7l +73!) ‰9bC&M ݔ5άj1.ҵ"UݷM:dLKn +bRج.mEt}P& ]=Њ11Ȝ'Ŀ4[gGo+lE4^M!k|# >l~w .EV]J*󮥝%'&dft=< VDՏ](rRwiw^LQf+c3+F0^kJ�Ŗ~Y/Nٜ?faN"hELHZP mG| "J,n#C@j ފ&�߅J;SL{:Ȣˏp~1{h%aǭ*0̣҉ʷ,Fu̞͢c^!{ЧbP}_ء(~#!<N/Ƕ%oU ҕ\!du=. +fAx̢eun}3׎zU"x7Tԉ]GƷR805*֟Ut[GEj e_rtl?&Ǽ 4o $O(ګ",md:e@|5jȯ7r׵$)?\ wE`!a ,v.hOeec;1p~]`5Sk#jI3[d}區C\ŸѰxײ0"OОa%Q?z^X/gyV944T""(R\V.]vӹ}e½έ3 8`=eaБ.`F@`!Bcr2M8'\Eуt߮'t߶B-gg9\FϯOTx1Zov+bT4[N+>Z 1Ƈ)iז!gr~gn˷K=` _"5Blu<5B3kB'bt9XR?ͥa 0.cK9[<Z}MCWwyVIyN{+]T/=iJ1mcRbOu;/3-(2j67*Hmt}]TJ< ?2Y8ml^Gp"Pj<'9mQD0QNRnO3*Rh$Ș4EȸIs^/dW\<AuSz +<+kM\9:-=2«jld4`XL|>eKFs[{O gBnƤfL(eē2.>:+uZۯNM)콊2~,4τY_iv2͘,o']shrq[ZͅΨ;{ě�f1l ʃs]݃svj DAg/<b|YϺRf6jE$ʰ?jPr xV +(gW&(@5xaSa<_' xC7~mB~{fbR߭tc˺nqmm}\ˈȌd Ev2.*֑8[ioLz<ݲ[f-|q*뇍m1Tm'3coB8|]t~{w<ElTԓAr-"$2IDK c`N$̧( `Ss,]*66&wqNA:l6u<2H&XTΠDG-&27n*INY)e]II݂\dJ#lƠ^{sG} :UJ +/ڪֆN%_X&i2vq=UӲ/*vl[*i"֐bcLj%Mrc/aGu[S2KcD1ٓa(ӈ(j1TZHˊ[ʄDTʳRT9͐Ÿ~ǟ/^z뷱'.*K�]&W[~/=4I3 p!S[EEe.SW]ak9iH?P8[]§kCEp\ל~[}7t0VtcnԎ(d~msdTPyHD7iwWM5%J"\ 3^ml~U5>:RkfLYQ)Gd^<Ylܦsdv'阺//GMM oDE9*'Etfׯ_k??~z4 + /?~ Rz~mc7Qm 8nҖXG0b3X"2wZfb +4J&j;hsQebwDuY^c3?Ur#Jp$_l{*#Aݵj&mEl "s}/j%3IjrG*Rs!7sU.R88gG?XJCpҧH}roxN3t~ߕQ?@~r >~G˓)\fNeKJzf]PQEX'W>w$57%MCD5 an`z^*7c3˸=.7;[~�ǔ&rj(KyIV,:r<Ӣ|Ad C}Ex@7zb/A|ہ#Z, pj _&[|O?ZDW!UD`y"lSO~Hi>k:y^;Soj##'זnjر]ӓ&rsIe xdMVܺ,I`[r s;$/@z bj((>eFtUe1gq5RK<٪FYn׳4S}[TsjH%,Ԝ1 vڞ\-1fߧ{&͒c3r2(&I\FVӇѢ'FciY'PP,r-irc ZDW_;hPG x}lmܵ<'ڴϩRδÈ:yR*^dž!DqO;^ +`rdsr%!iİGdF?o0poDiiCGkZS^jicu#GU%rXSO{כ9wvb ͳ y' |3ؑ|k,DҔ2./ǛL/6J Npk hj~u +~&%v#`hMc?+ *[GΈFSC1FFFXn(|F\5U9:2-R 1ZB&d6c1itngC]24ifE㊢Op'ҨoU<$3ڶ oN}M$$[JU֭:gﵙAR ˞R[ x9Bz,5-b(_Ҫ[rP~<Ь^N6\0A|RdTAWVTimjs iҔUgOZIY*!Θ=mmOƬH1U0վ�lWECthbm5}6v̙řu +j>5u|6̨V>B)~>D쟸~Qvȶgݢvc%78XI+ABaw UI<lY$5W#oPκw0<d %,i힤%w +R;q9xRK& ~aUIUJ(xKiIU-{mzY<Z͊Pۄs =թB?PG"uU[t2PR$fz`Eu5Ѿ\z?(%N}7hGWRxzMcRґ`ZICVkw!b;u]ga5ALIshL94b&S c}7(%=JY$+zp{3^P#-mK>l48'RHa5cYhOgY9G]vyw7g"HxO+B-{wi`T|Ύ5񴪼GBފ#RIWmuo32#ް +<{-ҠNӞʏ~vf<ꛫ/~|{ߎ?졇׿k>~{|ٙ'7+Ofw?>}ⓗ?<û<>_}g߼}w>ڏ9W}~_on|Wp=Kx|uq/vm2Gsֽx勛?|U:՛q<KFc.@%(圠(TcES})RyFotִZNEڇ=ZزKts*<E@@vAWNjpL4!6ziJ'h`O#ki|#zȹ(8WS\-+jE + Vӿ;+ifPK-Xw>Ɍs.*n9)hy_ş3q鼠Z?I[4^٣K?жoWM1JRtY(-` +U|:/$R5 13UHغQo)ˈ't`X1Xd!/R 0%Mõ2ԈB$G) $]8؋PǗ ]&!ctQE{3g!c&,<sJҤZ  F+Y][ ̨g6^|s^&U ?S&Cqxk ~iO,uy9qAsr9vFP+HiD/۫LVBGiցcZ1V`JPf{ά{Yz|cszfR((Rh,:5]a2@wH͕cHˣH>)MݦQ`3_^W eSllhe91DUul-4JSzKWc "qu^ >H +l7k zOyd%F'% >G2}ƒ1/{'T+ugِӎ?^{_mYT`�+#i* Vh\>w 舘HDHtw2֖3Ki7%IC1h҅gCVdnD!̃>1&Jhur+<e*N 1$1!y=]HZRN1lƵB۠Mac7:+13kHFKmK ?Hv7h,$NfY),ƈfrJa,eݸX)hl: R|Ubum&o$GP7G}g�M?+2}J($ݓd\ֆ;] R"&6m ׺Câ]Rea{uJ4[f>^FV|~I 'H�4x- zUB"4ǎ ;KMjWPR`-qAq&>P a +ŧ!*1z]֞\ET3qXB�H;gyOIFTbIIeji)u0ЪDbF|(<^(tNZZAM`.-d!$Pڸ >bH6Hk{|IFJm:Tb{ >Wo'vn'h . 'z#yyxB + +׏m҂Mi.Ņ>ky8� +6Anfb^IHᳳ^n1c|9S74ֵ_n&#MlweL6q{J26\L <�I`؋JE$3s JqD;v^ӓC# n8UjDfD8s{[G),SԼ';y<.Ǔ8x +\L*2ٮØ8UvVpd3"vnd`褈@%ҡcqd+KfhCQuK CDys ~+ruY5~qڬJWNyuƫG3MEj^ +)/2RjkojŵZ^U]x$⊿^ȒV]A6P ؽ]sM *�pgbm/W_y̟7OUz禸㛥"|Bǂ<qeKGA%8\6o҅TI{3;mT-TT&@<6C`e r!S>Q٧{Acڸc*mW{u9jڶz2C%Ӽ%b*ї fܼ*5bɺYi>A*\xrBOOA=7G`bn`$BuSQ '~(A+ +g"-`^Q;R@\`y^ +/{#hO!6 :�>:{Th @J^~  C~Kޅk %\ '(/^Av͉S zF zө#n?{7ATyD g{9-g_q8>Hg0zJP\/2ʋZ8>\>-[U3٧]ղ.V%*C Lp9yR-%-xP뱽ϕ8.TGϩOT*++<)bu͏QGuIf&>_ʛ2μӁLwB9?OE+W;sevX4'LY TݾC(RRnϵ?t80U1@ֲsXU{#CӲ/L [l f:cvҺ3КS8)DK!) +總U HzeUXOĮ^w G)B�<eolSzj5ZoW'sF2X ?lԼ^3%[٧ܷ2 6JX6g?39n&#^ct~~iLfcܻ7vED[hTF'KQ [!H;|u,pdg_Y JR,MD˅?7}TY5 wj<7Yv)ghU2TI|bsq=^y7iU+:,k6L/RL^kXMڥ9jixfQ q9E|WMQڭ#ϭL7Lu c羳)aFy ɿfyg1C5x-^0Yj&k۾&B58#̜eu6 Se*jz)`_5�i6G`3HKV̝Nķ~ Ǒy*e?7ⴁEJ'";%}~76^):lq*n lSƛw msQ+GJC/0)Bţw;1Ӑ52$k֫L͍Mؒ`y;d]S&gjO77%^zQTvjҺ;"7Lg3Wv-ehQmQb\h[yվ| Vvz7*5Vqa2�SSB(r&-Fwse�t.9^UϺbx]GFjs:©R!NE>5p2Q9\hTaSE1U܈Yށ: +0>w`kұ@BHPV*HF'5٢mwcfz;pf +[ӻ!TF:Qq9t{Rhi_rt_ȿEޒ.kl;j>$H(sKy-O@iT*" 1M-ksZ#@J- c/%yr&ƭx*9r+aP_jBi+jCXy`D>*I_jeN{qg%an˻|co!ҠRyUYGtFM/ퟔ]=^X[ugW&rޝz$&M%‡):e왺'x%߅^�$JNh  +urΣ1}_Dvu\6n\޼|`рh*ꄗžEe/3Go+sp(h Y#joOx'@1Pp(⻈7a-`mr'qpaΥ"cU/,AmA\\֪^ErA`>c eGaf&Zs'>,d r -Lin^F=lw2iJW:nOyyHg`D Zk#/u/t}傱yoŷmm/~_tDVnu`Ϋa19W#EqNP!;Ss)7E»n5u}ӫGV2vk9ol{ηh(YfnSmvd;rQcAizHYYjUy^];}rG&sd69vcY^½0Q,"N$:ʘgI- 7]aq~K~9zTQJY!3Gb�1:v_IB5_V5yiR] (?2ܸ83:H=�T`UK˯&$ʔ߾ !XU4օ ,#5v̧"m<1~y>XHCa~nQйٕ= 7gtmZ[d@F,IBJhl, wƱ\kEnbp葪iy}A*ueŽ h/+ +?A]w1,1Y@;h%_?Z؉) 0]uNվsMT .+Sm*9H9ػǍp1. Wc#gqqw,è'hSv@\SZ5e-W\33$]n8kgom8fϟt:-8WCSl S0pp H:rMdȾ^UӅ;]e*&[HHvZN= УwS29 FZ CO$Rձ# ES$j>h;VBi]LfvDfB&PJ駒xn4̤-ЖƁ$0/rM?D䬝ѝ=%CVjK}WZ+9RtdwDԫ^b>%_G3i g^P y0JF-Cg +!o\!8Yje;T|[#;.[t:/+52:j]BQgZ0QsKr7dYQS8rc|nT\K%1Rz-BRjr[қ#E{RrymQuꂼ*.AtRStc iKMv5c. y]tq#p*lmxh|*qDiM !PvAފ,qvm:X1JƟ3u-\/dT6SqL"淙`K.% +kCVQ5.߰Rv3u7𭯜uȻvpq2Vfh9<2#(ȉpz ";?F@5cX<AZp _H.SQMG:Z.͖-5K'u=.F諿?ܵH1pKDgz`|+a-!5BA0}6ړaBTirEwh mTz+�UkO*+g*&kRkfjpYٞ8mG;0"h"Gyinn3tjW`r ȧH8Aeo9Jꀻml +XUݩ?;Y>gh.qJY` 3/" ̠Jn2h +ۄOGw9QE&:4q XI*Z!�/WEat b 'x"Q8J){gـ/ ,Tkj)uR4aXhGSއ j(ڑPqJZ.vn'^toZ-TC %S&}},~+AV`8{ĈPM;-\zHVLi։rKE1 &U@5U纇ok^%yea(Rc;Y<{GjUYA>E+V{$hR7ГM9=›t(*37mUTw)M⠥Ȣ#dnKB$MLGRrhE}6Zb5Fj>/*?L=,\L9QI-GBPAGY`'LĠ)$X NX^ew\0fN6/B*K1'eA,h'Oa վ2z &S(*Okj_>i1 +GVt4JNMwH| +{Q]gf[YiH(2D[,ܑb3-c+0L"RMd.梹-M% !/v*=tlh-9Go"74Zhљ´C]xQFqwSu)8޶%C' T`zH1[>8p"cgc8YoAߜ> yQ, ,U,p +EUI V2, %!`EMg)3fHzPnILq GoUrkSަ>@(Z&8N2V1$i�}")jPW;Ø)[؂$=[~ltVF@ڝ]UkbJmFVbJ +�>-ʗ +yD0dAk Va>\~:4;K묔X=�->ĢvjN7(S<sRPH,.&+O}af~Fb~Rr{y>*)iY&u~^&j~2 +sH t? +65O~Hzpu�j.)S-QP=}Օcy{ +P"oEA~ME,~!+قyKoHoAi̤ 0o�k@l+x:%6}f\=y\޾g |aulVVA|ilon_?ՋW}ǷI=>>]?޿˧>wp߼CxÛr+}2o_ODܦ5졑hf#6[ ^ݗ +m23KGi +]"ZrjwPgJstiqi5K͡L,;M#._iV]-ciqM%-=2I</�HdƘ&J\G*ylM[$ˎ^FwL#(AL2 [2g]ǐ +(AySԠ>iFu@=|pRnCJ8j+4ϷϿ|6W m86�57JgSv3s꧂UH'|r} EO`q@?VY]ĤgƴK hTD$v#0/Ãn >qlu<} I @[3|׆Umj "VY"NRU--jǻˈH1NoTRX8z7`%V}\:w6SQlgz7 p s*qЃ<7ԉ+T5Ή<jaSbG R)s#7LbMɑ~5"GAܸY"Y ]b~mGC +Zn圢Zp {DEBCƂrLTMrGqɪz-c |M5zhϩF[FV v))jhhi{Wh#+'3)>p59yEyc}z:w G)߳6jelOh:3D'ҶP$pMhʑN-d*3 v^vn;6{*{|1(pt'?jcks-11ږJ!xQ2ʌG5~fuF-í}( u7k`lmŐ%'d>,\Sš5\Ǖa#nN=\P`ǼղYF"/2F(6G#bfk 7<T aZa<g9":K~I!i�V\w"2s}\=+<Ҟ'y8)6s5^`#Gj7=i,pV+š ^r8xJPLgĥyHwz(O<@X,@O +pr@*ѧ\+Q ^!4[\b+rt M,/Gaز =p^)؄v\$ԥ4p쐙|Ê*Dj)'2W43Uϥ,7$b v(W7alС[-- X$6y@Cmo۹b^S|ޮAgEXD<>zygpǃtNsCF* +˽yOQ\1")J$SI=`G1"||+Ux1L(,+WxDǒ~Đ -WL#!> +҂.+dbSt t$Z5B h9ԊүĢC-Ua S!}=PՊyiHjQ* T儂SoA:#Ms92s\TQCXO(F*BSy .eӤ<f6PJ�Ϛk9ДD@S4RWv!% 5sm4=FT6FF% H؝)o(r,,Vf,"uk6rar4#G)ޯEeոS3;l!f?IZMItY"6B]k&]u\բ*;zF/,۶lxe[p$:ғUkg1smo^엄"P?Kƍ!<(@?]IZӾw;xe%Rin"*Qg�̏Θ3#p'xP!y@; /j\;"`EHAe Nw5%nIz(Ei'c?%`F ➍ %3r?<,F;:6$m~In}w^K۾$\kKך�ET(6$+>p*57 ٪.wJY"M LjS?H2$X ;?CÆqθJ )Sn` 'dkk`P)s; sVgͻ%mB L痍XLM}총w'3F $ +u�F{dJ4_>2JBˑf}D̵$Uy%tI㣫Ԕ"0UH*C"AWͼ/UM8VOYAKL:)h!݂fvscB'< 4y%ckDȒUh +aC0UM& `_ǔ"%>x=oG駇{7W?< v}<~o~xׯOx7gEWZE@c-FT;LR8Yœ4t@v߀O}i{TֽFz�C% OFFޡ.G�Ċk3z.N]Ўs�&ʷn d{~Z~jX2hI ]yCz˧XISL$b;boDv'߄$VMIxOZ*0H.!D(gdc +UQhw||]LqGr'1zwN<enۄhxu۰Yg]c0߽ѳ[^@91=9SHALfLT(nYk"$<qkFx"h9%,RieT HKrtJ0/8m`g$N]?~8ubv1\� Ղ͆{P8Pچ<x馝5&Tutg@d%1$l<Fv ~J]^eJ|fFsW%CnsY1ԛ1m+Tg5[ S<dpӒR,6| ߧpq\BM?wX LNK5Q -tռGLPs5 ^ ylEu1Y,)S&D&5r4+G6)$iDҒsn@xTVG] "iQQ=BNYwg(H[: YuVSeClͷ + (xӇuBzGejuOy|Y;G};, +U!4yzM )Y:5qi@ wb jm&AnZ+)�vZcMqXXB +nsR$k\t7EYL:89iFajh|3!>bU$ + I/vy͉'cGaiȣ?CrYmtmmz0YQH1j#2AWsh<zVDdd,*�mi endstream endobj 482 0 obj <</Filter[/FlateDecode]/Length 3357>>stream +HyPg P[jųV+ՎxX5+( +"Fp7 ĀQ g=pvY6]gW7gɈ/|xl;jP'u /9NE +QbyB(5ٷsލ6<v]z /!n8j CqXe7SzC3k]ߡ1A;A23oQ^6L{ %Wx"CpB!> ξuW֓Hh6yfdBY>a )<>y7Ϝ:Q<AISw=}3! +sbeEԏ?J-Ư~6!Za1>9dM\v^ +:tԲtWB!%?U \AE|;wH)U;O+bxDMhj볉Bߏx?*%7'CENM m|nW_ '_/VJ[W;"Bw)9SIobXwim'f~vkSI)i.粮[ӓw1!B卵(ӊ?*%7'?vlbhۇu:H(̉%ϽV}~3JT|/Ų0b2{`B!Vb:(7 WSJ<3|;^̒Ӛ;igK~K]ߕ1I + JZ>4jsR-Y:cV,B!N95r'#4H$ik~~4f9\WÍ6BaL|=OrNkjz 5LǮ:hpL/B7nn¼߂tܶF1xHUzy54'%I#JM$7r9dDO;9-)lDr #{C1۽u*Xb; ?!TJa&4HZO"=={  ( 3{ڇC2+ CΗY[\l.^QJovuc#ԯVΙ =5$'(ߝE-uE9?U$|T./Vtma=ЈG#UG[FEb dy&m߯R\$qZOvl"vhȸ~~mtfd3F~> +B:pFJ% x7鲉Az<w`�yaUNSwhq]/k."QdOj|N3BQCya6̘y'ݿ*t#r/ kFPp�r?{��5{1Y !Tª2k5)5W[ +z>%(u sep L C &ǀRJ:$3W=bTt0'+~Yo݃fFY Qt=bqb經a_D# 4x6%4wi_.JXkn5^�k^ћ[[R\=lWiMOkZ +uմA}YqnE/(5;;6f!;4dA?X];ۙ)0q+984ShS ++Lبj-"=st~S:4勆]?b�\'Sg3>�{~>fsd*Un :/\~I.)ȽZM[u*.rJx8[rO +?1Ųسq 8̞6a0Khj@W(hQ~Zr&c@ 2vVLyͮIfFC~w�uRHgi:i/ �W"p7yA{ϫRĵT%uմ"^-X*G#vАq~~X]˖"[<vX1#&S[y'?06Bb!$ŖSTJj"g!QFOcfbVQ{͝ @@S@IshLOoXRuJ5'Z{ X%](df2R汏M;9=.(pԁm>ذd),n[[�##](H(hqK9]c}.$XPW53>sպմ~0W`t]3BبoF4'U%b*zX/˴4 O 2W+5bDa$(H e (K 2 +@ bERB)=E(EP +a .G(*Z+~2j^ faP4G\\X#1f!ƮhΫ Jte7?,QwG(r"ܜu3e'&NKװ߹9s~ +aeEu1VLZn0)kcφTx$zwd2T"]b\RF}9?)YV ofꃼE}[yKo.FCyvvՔ�3?;m(h'}tR@JTh+KDj#)&۵<? +ݖe8:L Ш~8e?0oWf8]RWUs[{P3{ƅZivoSm C,�9 sVYՍ{Vzh/c:n C޻K5U -yN~c+;_;pE`8UvEO<Ԓ>J֩.%+D9Dhi^f/=?5م`w "26(~ls%xf;Dkk1�Jx1%|Ob J›DHwLЈ!bT]8{ i4X lVU} uE8[Г:ީ88@pr@1zmzġfm,!=_<T_lh'}s(tJVBT%./+E%inI0N}&_ݕ a*2`inN7'LxB3f{cJ`/ԥZMtNT`~~'`~&nK03}N%9Q-q~`�ce)n endstream endobj 483 0 obj <</Filter[/FlateDecode]/Length 2694>>stream +HiTg/! :3-jq*,H7Aٔ-,Mńึ"RZkEHM:|̜ w�߀{�ت Pf0#㔱g/ ̇VYqeF.*0ⴴ(ZYuYxSEStӷtz"+UQ,-LwTqӧ,/7:rho}v萫s?olدŰ+301|a +G1#GP#:p xOW1&Xu$?Ϙ9ӿey&sMEkO{r)5ɟAqLSљMW$,ez3t 80^!ɨ"wVAlE {R h_7��Py�8Ɓ;gBsΓϹ/2l+\8uѝWMtXz*M7u>^5Aʃc[NIG&+d ڼx?Jޣn)Zm)+D<a|]ĝw˼)ȈؘzUr 'BッFv9oI!^^Ã݇=谛ۀ; ]ᑾQߢ{&u:?Xֵz l\ Vea2 yHE`eG.($_ lg]TJKZM3BèaÙ{EL=|}LJdjsߨf7{ Ek�M�َ�.�w*_�s4'iMTl3=wf^.[{O;XMxJrHSdپFvӨz/^V +*0 0#YSidACQvalĺ꜔S/߹*5ha-nӝ-6$يa?匃z6wr8L?G-1d{RZ @ 'E?>|uKS-h@�U K۩گ2[J}3\ܷ<?6}cLq^AKZ;~~gi'-6@s0KA_i;l#κ{(һg>~Yp< s98('*ʚ+`CCW{BQb2[m%yN̿PEߗ #u3!9a?)"9Ǫ39J7(뮶v:L{02N+iI)v=]n@g]('eGˣ?6} nɡiLܢרw#swxZ 1�]I"2 hyF[ (~Hg@ഀMىa?Paj/Y:~i\)r^1o4H>XAShqKW-79 3@Qe¶$L2MaV.U%?xSvV ^=1@_|3D-*}7H#󹏢(ʴm齪;+ lg g[ Jbjd63ϟ3j )S!DhqKWc{EbW写$-s&9G!&'MHf<h:MvvGGA`+WF>yCg<hoTS-XD.| ho綠˨-iU@;O +Ӓ4AΜ'&Lܪp!lGQjjvId#M`@{&{-!0+nB{U2QU^ M!8.́LXΛCUfCQey(Wé7d"M`@{KOqST"Ltgm +ra2H9uB!l ^qTIb*_�!GQkvziqcOb@/܅aJhC-yf[ݮdvebƏU0يgl4u|U" '@5ٍ(ڗ='~A%'P25I7 +-F+*QJ%!^^2Re>mɊN3`>QEd{Yu' le-`蛫|S-~TB-gzXkP3t|gEQ\u<IC{r&}I(יb$`u+~;xU(=/5$ âNkW竣M_57u(ţxHśyQ0hcul8sUt|k}w:I45˯'2t&�FΦf ۚY~vyVxgãxQ<oYV׍?FpQ<0G CFVطn壟gr͝a9YmPRWaJ]KOʁ&C~׽xQ<=M߼dI �P endstream endobj 484 0 obj <</Filter[/FlateDecode]/Length 1941>>stream +HyPrF%iHщƉƩBFm' (J%R*Q`@ù.,"QSDI3W^w:u^g�ه؆/#�9}fb4Kݫ[y񋒑׷rX4L8ڒUITFujm}xB)Z��BɱdKr~ :ɃgU s3\ `XJ}?XJ~<ƃ##?}wS]HLh&'k;opk>4�{��~*DEQ:kb5#j9Uk`^-=y/ϓzQ,*I۵˭Fǽ_3C߳$$,v&|�:U; S?@$l!s7f՛t=RpB½S^e5+W|;ta{`MB'|�qӘ8˰?1?%ksru'n>سoиP=JsЧ88}ᙃ:U׃(O��x2:(ǰ?1VSXh`ʮseoweY.B/3Z٤+ڲG�3T]0?1#Y}]s~OCf*_ʂ6:9Sje%i)HmiQB#|_�`uw}:-DL>ҟlOg.#CojڸФn֗TwؼBUvS] ��e{U_w"`t7'vIc;hP\gҙ?Zp˲26{ }?@)ؿ5o'�`b:7N*DL�˝JeniI}]`QjbEG?kcm->׋ _U(|G�32tNEo@|Xn`>C<0ma)+Y/.~4 :}��e()�?h֗rqLKO%!{>>巺tj.n<"gBF��<\l+H"`�ov~$t#720ܾ+Kr挅e);v8X[Oɝxc iNΤE��<MN@s߹$ѲБ;ՠS]^0Ȯ{P}F!6R;#߲7Q$|/�҇?w"`�ʴO啪ܽ7wHP�3C4iTFEz~B3hjbҽb"D��|lv;S?�!Ÿͯc묎j'Ֆ]=;uߤ.O?rí[!��L;DL�^@&q\^rDFȠqOeݲ䤅^nc^&);v8(Pq +iq]��S#qtr=;2b56&Ն &n&-_~ys^YI$d7Ʉ}6h 6^[&?��ƕtGS?�)dj#CtwktCD?;k4s7ݍ&oUC!)RRQ��ݐKX5ӘUYJ.V)F-U[MMYc`b,I +%+=}[w)fG˽kxB9��x (I=Uw 4F_\]SVZ{|wg-VGccguY?�&]ߣ֩ }s5}np}m }��= endstream endobj 485 0 obj <</Filter[/FlateDecode]/Length 1304>>stream +Hile�҂\XM8LL +@1M�AlB h iARR -Ѓ҃nwgvwK)DzrED$!47wcp +ۙO~wyDL!�#O\~clʻ.F%ƌoFڶ9)q_)r?+u=<4Uv Һ��0ճ;{A)G-Y1>g�3e˒%,8VP^�/iO+1,yzg?H$48Xxd۵�"xKQz{kg)}�I ѝ] ā{5jxa�c(LW9Wa w�@}o}#;;A#=ztDFTٶнbgwJ_zgkoku��Shndbgw?5n ںuĐ\?j0q,)|b�)bek R#[vW�o ܲI ޽zAa\{bR?cTg:2 = 0SLr9L�hOM֢~'SDQUV*Y?1Ktyµ~BLqOUۥN1�@ V٥KPDo S8fK_??bdc�<MϏW +v +Һ�NԨc̟o/?B-)>c�5>Rx3] B�@u:)իAjl;ώOH|߶ nznmj?>cT,;�7Nm,^`#׳kَ,6T_}/�6e>1R@Cjح-Ѿ�qճÝWi{A%*R1z|fsZw$�xh/\ F +,/- SYV'݋J�ՁlGvAxBN +FWjd[˯gKcL�s6f8 +}1R@b$IVIG˙5M�9,b*Ag, \YYn'�࿩0}&IT?Ha�/!J0eNv˶zCP�wnv83A`,cR;%9ʹP{Gw)�j얫kmR?Hc.�fE endstream endobj 486 0 obj <</Filter[/FlateDecode]/Length 1066>>stream +HOUuD+6g.uadtU7vlҸІ +%U\?']X-+ ^/[JNsz^5o,�Ŀ4glsՂӆ#SJҴ�!|<fuNe,X~@= Wi5{< +t*�B?_qiD?�ֽ:,pcp`�0;#vgWD?Đ\nMٳ; +�X#eYg�˝k=?qT}�C%3w74{Wڭ�<6l[0w62M+s?ɽ �LǞ-} * X&䑖ё`�HDg}w|sO?Ja�Ҝ9cϖE#W>-sxlb�H$[o6w4�|߲h(umI�ʼnQ;R�fcCJg_ɏ筿�SWe Ts'?Ja�#k CK#E: +�o'wYގ )>f�W~qCu+b[7�T+EvmIf�wٚ^)ǫVJϑﲬe�O{$2$|?>a�U؟3O2bAT +X^Hj 8sݡPw�ţ^}sAL?Ja�Vikx2<^fxKȖ)e 1} *ZiN%#=L4ߚd x45jHviFY^Lϲ?Ja�^V5R=A!Ƕw=g-xruwٜ1 *z;__~LKt�z *࿐YU52uW�u endstream endobj 487 0 obj <</Filter[/FlateDecode]/Length 1072>>stream +HohUuEs!X H&Qy)R[X9S.1VtEM/ew.3Ϲ.nֽkZI&?Qj{I;yx%KQ�L]5y*S_Ѐ9 +!?gu�][juwKo#-w�_+5C?] N +\[4TR'L5r7�F@$:'(8)�9λz: sc]z�A6z}fh }�`?~UT{bw?� R<[s+0zѻH�M nbg?� ӦCe#TM]�%F#a+Ia�]w C؍_|D ��2NzmbO?�`Ox|V'}{>o�Og{xZk~d'N2(jKGnq[�0Znd'ܳA)}[S45hL#.�6n?_n*;A�;[͑`S'Dߑ�\9 {.d'2]J^SŊ]lw�̶A3xNb?�.-RͦNȔ~+�lT/mb?�n>ٛ%Qc�fCTjM{⤰?� +E }|Юܷw�ܮ]-8A<qR�٪Jmw{cꆆ� ;p%v8)�.#zKN qCLaN�UVn?six&Nޜ)ݨ|S7h/,] �[any͕O v+Ŏk�4޽5Z6=txo�K`c:ѳL5{ V/c�eU +ZVF -7k3Cn˖_�?|ad��ˈ endstream endobj 488 0 obj <</Filter[/FlateDecode]/Length 1311>>stream +HLu`0?엍U[?4nf@` CT{Ej?enԴ/һȤݗk{=%Y!<GT봏zG dA[v&-F� 6wyx�sphd\9=M k4а:5-B~f�@/* Nݴru]�t4}$x0 l]1򠱬:,4�+r  r%rTo�@#~[Vb#OuJG>Bx^Mg�5f6 ߾zWR{�Уghtu& nyw1*y?�]L6sƴY�E}߶N6eSZb>bĐh1c)b ͆g=EU~F��]iز8Z*c_9$D{j- +oQVN&4 ,JL +|';y~Ht��LlqJcs3oTV5W.{a}Fs S|X{?i<?�]Ē"dZ|e3q%D+I�t"Nd j:vQ?�aѹbx|OU9ӼF^@~9<}|w~.?Hij?G��̉W8%\�u~( ͊G?�Ϝ*V re3^; +�u{|XˈE?� U\] +�u OsDMa�@Z<A,({d,W:[@~oJKrzn j +�y^z@߼tAd?�3#?CcpN:%'6Uh/�םI )�x|LY[bj%KfnvH; ti*;A�wL==ԸB. |ư?�'gxLc@p>S}a5�OibeG^~4Ek5�Xm_]a5�] C|c[Zu$U~ pzc{ j +�NxZ|NkN*s!�ˈ~ endstream endobj 489 0 obj <</Filter[/FlateDecode]/Length 1044>>stream +HkUusuTX/(¢@(X FDcI:FvXټdXs n\v{ݭ+\Rː9*v?r?~x|>o^/_i�#`WP4b?]}FH~{ߵ�nުීKw�m}N a�yh"rf:j3<�~ߗ}~v?Ja�@f)Z>33e�.x] *�r}%=Ͼ_y7�ݓM_^?Ja�< ڶ+>6#X\ˡ{;]|7)R� ߊͥwVZFln_X@vYfRޱUt#D?� {5\5h9]~':i/Q)�.OjNӚ!#:eљke9R" R�Wy].F.o̓ޏ�>' }6S{ *�mSkc9g?"'xQ)�~wyZ9R2ARI3rwJ�n=7�Q)�\D۾ۓCGGF^ߙ�ܼ@v5}Q)�- Z=fd2wo O�n\"?>t+R� +koxiJ TǶ *� -#6Ә1ڝ/KD?� -޵Q{-yS#z2+F +T�ScSkRg��u<f%ww}<5A +ps *�y/2a3u + +?Rpy? *�jZV]~t~Ͻ/ݱ�M +vf��=~[?lvZ�ȃ?!%��x$3 endstream endobj 490 0 obj <</Filter[/FlateDecode]/Length 1157>>stream +HLuO1/'rj쏜 Q8Etk) ??03Y}##5&Ͷ~LG_|a|^/!4+^!˼E!;�� MI'-iWK^2:՗[U�_gr7aW{!s=�Of.?^6?{ kջ\?�ۣXo.w_@ [E>oA�;_kVˈ.r.ѻϞ Ϫ}]W1R�"r7-8Z6пW.^Sza)/S1R�yɑbyc-ipMݴINɾoz˘֍?��cAګCFuٛ,Eˀ@05[i&)�E#]mgM dg+ed#�%4%J|PE*^StM= 0ڥ Z F +�p'Oev P] 0,;A�`&>M\R1v%%QӇ+-NOHa��fhUy[\*?:<woFOKHa�� -SߏK{{o\6UVU]ͱ?��#Żs[b:m{0]<-mA�Oy:h 0 eZw F +�0^:-خ)c9ړt\qU~"bN̪ZVICn|YSE4�-aQ" E'׿j#bMM7RDSPZ;AŹۺ-T3�l[/ +yr!;u;ꆎ(Z7 6yhw9�^Y_% xح-<7\̷Ժ%Y|fϡ3�p/=p4fzzOF>wMqԤuGqT]7D=J 9���r6 endstream endobj 491 0 obj <</Filter[/FlateDecode]/Length 1380>>stream +HoLUul.5KhәM \j0 Ti8LQCAQ#?1%g43TkYcwlH}M&J:qeT@S,9YZ'xqvƾ<B"[RSi|aT[ik\<+mt(lZc1b��&+Zbss3�FviZgAz"]ґ:q\rR>wlw;ɵ@C��S<GQV*,IUlMYM:3݉-]:흚JOpFx>fߢ��!|rJuiOo@=ClaΟuV33RxۧO;*N3|MNߚ:.9ou􏒣ϫJ{`&�M{CZRiIvCu`g.z{]eƈ3!w2?l橢 \i% F{|$�xr̎J?wwp1W R.o!4Ľݖ +oϚE_{�7Qi^{smdIh u.[(޵N7|np{V] =�>FIٖ|J^SZ;"]I#qZgA5~~RAʗ+j+'w��o5a<#➺VSUǭfQ{ZgA�K PXVs;#|?f:b?��AZyqg>tjp1DoԚ1R�͋Gߨ3;J~]lʦt#�m#e_OMu=<V=/n],rB?B��VrmUe;¹23<1o֬?B��faRŽu^R[YwJ(ںŪ5A�DI9YlwR,:^ {ꈁb9b?��FvhSm7ԂEU(sM F +�`4iRʾu#NȶkeG3OǏؠ)3M F +�`TòbO,qϝV\qSZ憋 JМe1R��ޒh=lmpw-ۥ:MX@j ?B��< ^)eQ#m7<>%T>8=M_G�cvY endstream endobj 492 0 obj <</Filter[/FlateDecode]/Length 26323>>stream +Hn_wSkrgfe�A(]r,D�YZu@ծ KΜ9sf>FY{o秷Ë|'gge5Yo/p}ի_=\h포SSߞ=߾Ħd}w,e4{i9o%z)s2Vl6}[.-5_dieW'_O -u, HOcyb{KSM>6{}Ue d( }v뵃սv0|ܪ=WjxNk[݇ Yt9Y#)ѭ+ͽ=+i/kW+\(+}=lɍɋŶ؜`VZ%x▽" LJ{rdJ{+3XBZI}@,G0m& $U3$XE^R<j}FJAz�훓Ma`WxQz /#d==/dzKgxʁ'"݀*þtyH= !�t5LayFPxAqTJ%>qX%e@c!ĪRE^2/ +X5Ԏ}7O]񶼮 xY㢊Uo"WGA4BfT(e3J[@Ђŧ=L2ޛUtRJfѷURIYRU>|\yF۲QBB%%F fo>C*p/vr<qsQn/s/):ymm!JS.SIE,軶YR̈X,!=/$GkISkXPT +\Hs"umjR-%sb$ T$8sm"& +ZmHsH*W򘶖D_fVUarE/BӢ% +Q/H́zSLӻ8n +Qlz+_PD{߲qeۘHZ\ C2}#Z|~ʎh0NJ8GA3%7N!j"80H(VE͍v,GWdfOG<ʤhH5uJ#*Z7]F!0^Po-)/VAH!CrPQHvHJ +Hy! +ɯ8K/.nB@T~:}˯_]]<>\}A~wo}{廻Koz}?|{:l/}x8{}XN#b$%-@{ƴE:UEG:PҦRvE^'wYRbN^A{H4 l2U6@g&yĄ[k0 oh7'R67$N0I↶ڔ4Mu|-#L1LB V&.M2%9*u⢝ '9oƕy`u,ںeA8eqm #5NȒ@1g5| Ŕ8 +X%݋&KZwδ*I}#baߋ)R0ؗjG1INMT\x%n@¤kc4u,8r@b0B;gW`+j~Jf5\"xh`<TIG#!Gs`˔),!F }�s cM۝ �cfmʐ1%5um>3My,!4WOK)PJ-6K<(ʬhObدz}كo*ʷSkܠ^J3Lf BP$L\6Aje:֧{ BY�f]iO+y9j.1e 4N-loC�C)%#+KlT 5dyqDFT@O]r�{G4t4_:|zbm�d8n1E/6ԫ&j? +fu=2&ØdU.))FمAQF 1r-^]bPmφ*\E5-/5:-@_�P4܏G#IfV `iY)hEp؈Q 6MLQ"~hS^@dz!b4E3n)*REkӚ kb@Q + 3E0#Dܦët.`8K*6J6Ghj .UyS fu^/)◧O!IgE�<R~OJ/ٹ4^$f p-"L$Ȥ +{ҴkNaޔp1rI:e4*"{<ASR#V\JTzAPscHIUC5mTq=7먚`$Zt."!#WxnKIc/}"li@Q#+`m_a$m*Ї8iKq+uڣj77D%Sk;EpݱDs2M@Bm +rann`.強l�tr3&D,'R4�ż8 +ȓ`nh*ѺV'aM3)ǰ �Bˣۛ_ۭkh"DOMa:-ӒMpZgCOU7�Զl8J4Qa+]^#]kG4K@B/#[ONE*Ao(xpNDpFbVE졟MWM$V9ېt$PL ;d.Jj[qX�3`rTbH7!eR+"B|@$~p"%@ #t_JO]t]GDf<切]+44uwRJ`v~_}a(YT( ܂i`( Q:[3ůJ2aZ7RkGln@JTKd#dd3_6ꗲQ2,)[)%[ Yyз} Qb:us(Ll8rʮRsW>eU2;Ұ+@oFnc6'IlvcaeNRq'ipT;[ BBM m(ݑ"f\4lm602b*<7J�=JQ땣C7gBBTN4)=1 2#WA>!UNWtyV˙#TC_k_h'ZXJhh[^jܱ*1)f�GjFH֬k<E-Þmէ7C*[:ב]z?%#j΀COS6}[0 +ũ)I-B6GGً`#UMnNs9J{@V@K~4@RۑW"//zDjش#D}4r�)�$"MSI}xG&#|Nvk̪ ҫzْG] g c7<Ǟ(6Cr\m~HAسǂ=P@|xüիKκǵ BGq9NTjaE=cd~xZ Us@ebyf�K]&?$/el�y+}&? 2 �sqt.nڲܳ4P0ehVc*7r,$* ¹|딚ZKU5 "{{M;%1WoA~Q=:P*=RE`TEB4G ҽVuIS;"ӛ>kf �ϓJ/=!.}cWOW{#rEɴ93R{aDu"ybhV;>0\HoLSjXyZN'Tf"E^$m),{{$ +hR&B-٤�]$p�=m |ߌ ōGT2I =o?O t&6(?Ѵ`(|�7%vL:fnKԳFc}6EIkhjt&(QEtFn8"/$-A-OT<R3uɎ!)"W_wۜL~AC;HWI98ilKamN-}#)'&/,jUN=?b/hQz +dҭmS!9BZ?d5Վ 3La3RewQ;xTyQ=P,hN&1 )mGNos=Mk7"'OH/ p?3.`*@ w�XVXp04r ޶2t}3KA.H$ :G<k >~>qiu,%9Z0wk N?3=ؒ×+[כ &"+%n~o~c*~x3(vIN*I5L7롈,@�o9 X XY/^cU 0+�UyVJ (Y �u|R93 +1ű([jGU5.wPu�3mҎ]~g䦩a##)h~ה H~rOjykz D%!A{OPQrC-3m &&=V +t;^Jp:?Lo&[L~^Z康' ~ϙp/iǡ!UU+d"2a�:髀E MG֦�9 %i4VqKs;,~Jh T@Y)iC~H KFBGL)<@Tֳ,To\)1a~`ig[瞱6aj؎Ǎ JQ_A{g*먺 MsS9"0`[l8[\^(!v.;A;4e9Iш%jq$99N]`.�*Oo�I~Fl( %uW5 DPˮ^ٕ ߀s$$!g]{T<�Aw20GE >J[!8XI` +F�kF%@|8CNBG*=5L:mY= Ԁ! #TSjS1 k"ŘޒT~kl>}[bߺ{ e(T?=ŢzQx0:=dqEI[b0 `g9�H@s E/8Z@>SlԒzM *څA$vWoœsd_Kuo9J鍖u0NN*>>J9_$i'3u=X(8|WvmyyWS*gx% +Z)qq׿)saǨD}H:g�٘D2[zh8gOgϠ[K�x}~`,n +, {raq)q"h!~ +-�ܻNOH5N|JFs%6zDS32q2q݊>>x*/LߓdMƛV3 1,Q olh$$o; + شR�@Iq7$mE򹭞<`@=gY⚣eaLRl,"VY*6vW݄dCO?d)#` 8uU] `D&s.}:<\Ag"| +!ݻKnVgA_/A6⯞/"GsE$ɿ1`@dė+&K0bAEO $L T g +M 7IbI恦%J3{^(b%Ĝ"kI"[oOh1Ҟux!$y(ëA6An"đϕ9yRr'<[@h3[ȎkՉa^I+T5E@稨k a\8G}tK93Is/AC]>2BEATҺu$ /P *~X UjW %ݏ~Sp'bKsB#P.`W;CUKgeTG#oCa.T;>aAVeo4rZ0$ꭺ*tH֭B|fYo/s}n W\(d\sWH!A__Qu{~NAYcch,OHkDRTOxlJ ГUQ< Ḯw"ϲDi}=XשF,􇫺!K|(ňP%^bvta~X%aӯbC8QWְAbM9AC_j9+H `~<$k5@MvzbCdϙ"1-*#f}Bm,fyA:ke#Qn_& UrFE}a8O B9ʃv=O7<{kߢfnIt\B^/CqV%ݝ@Jq)՘` + ./tp<;)Oԗ5o㋬3ekOyh fxDx oLÉ(HJ0qCLQ*;fRֽu}s=]:|o.L2(Fߣev72uצ;j�utms <W8EM#tRs-�󹠨Ւ1;�Cի}6zJJc&:u9QL;n-)}-hƅg 5a/NoK?5A mc~՟ ]kօ/J%@zCK=v1�iAnq" _ H9kDY;`W 1{Qfu +صv˰Em64(SP"6ܼ{ �/|fT +g xz%\i700G FN Xt<AG]#ibh"п`ͻ|0 o +<Q]ɏ38fByN`P 8,MDp0*qFv'/ 4] 53Pe2(L G!mgT([e%sZEkY _n\њd()>_V˞ݨq Nd~=1o"q{ fV!n1%6opQVXi0I(/1}!SpW V,CP '>�ƉRl7[gx4Q93eSP֑ᴴ%fN[!S-}s|t9,< EJO,Yo& bO$2?|#Sy-©9AƷh wF4LDPkQ':H@YwI!1rQG`Xq&'@{uK^�׊yzuM7e/%gׇ)f]kvs!_FdF)H +BGS_NLteG�U�K`B;R@/eqD';L{.8 p (qh$4�\9u $,(vvw-gQ`8L/]2IrkQ+a=1ZYՈ6yZ�B _Ũ(Nt|ZkԲ=Fg}_S45O3Wn̗WQPN?Ŝ= k4Dd`5g ,~tb=CŴ5]\:1W`kDfAWl97s 2 TE9 �ϻo4_Azus9~Gv]CQdmL/V${@<Z>QY* y$OqƼ>02\azj|WPK++\=PI+#A62 8l38jĊz~|az.ޣ)>4 ?\ƺi5ϙeNYӄJt_[YxĥXfciZb +̘p"-I/0ŜAWJ95S& xM'glaʆR܆7*jM-bҜ<S=Ȯ\I<pIgOEd`v%°"^ѤJENW݀v=z"~#6"+2gx&r +r8pAFz 34j2ٰ5Kjbh&J)6:b-^D*$D;w"gA^)IO7n1eĨ` <Pa`:I#Pp^ q[:bw ilM:VKn(t߃C4KlEֱLOZCl!WWE^פ)dѸטaӚw":1`F' RS)J+|˙#s-Q.ַ,UL G + .mI +oDCܖ;7EkxV<Qs /*Ko$;uCMNH.V{|,8.qhMX9l:s +4DMRFgMu\,pvr@$`rǒ觘qfF#Vdw^�#8S;:odlԐVƟfI_+=6QUjŀ(ږ9#kc+9h:V̞!]8%P:,G/[x!܍O/~_z/xo߼x]P{ÿ_{߿|F{'?{o +bek,| >=ъAƌȲ遞, 6yk8v<A }CQԵ_P]m~)3V`%?=`z<e/=Sy*RW+ +׎P(Ѧb),]A< |KVrk w@ӦU# LJ8b[b!00cLDp~.(E0K @IEW)A7$ +-?P%L_5qLD"ñuf%p|pk,o!$sjhyjS(rx7Aؐ (K_WO.Cxȼ[Z�˾\+K$0/5lS;o9Z@A\1jB9SvL!W2m+\~e<K,j 2]Q m6GkaIlSREl#|Zёhp{E?@ɬIJlӉu\d5-8"q"8 E{s|,eIY&S%zngUbf獦b@ 2՛m2X=ЌR@9m J^$b<*q@ӆHsk5Q5[Ey)L, T/p|©˂&5>e:o4/OfjNe6eQ;>5=?Le7 +GdlCHU4gR*<FX{w"ۜj#:Hܑ&z.[=/vc{PIÒ2 _AkHD-JN4亘C@`L %ÂDCS%f1 +IE-4#' ;Jlm)J}Ԝ씭vhi;TIU@3té1Kw7&<<;t M ^4A�v%-på)M\WϹ,% a^mlt{Gv5K'�F5=t5_*.&XdZF[V"M2C!�O|!+h5BCiR);|*H;N[z +1v \A+?c|ѵt ́]a^k踦[ +ZY-hxXmc'xD )3 |C-~A >5(p~I61u!>kl ~#d0G2Վ6D +4zL}VP1kVٸh;P|} #CۃEL6%0h 4."U#VlbE?ҟb w_i>vZ(Gr+{+;Rؙ3Ӱ꼊A:gStKθvj7p"tZhIM[s}˸Zpno;M1Q7(TJVӻ~M];O+u5+3lv{hSPq7 <P^u4 G +;Cjt:wXwpaT(7M>Qt!kٮ+#5\A] Ѳ>xkL=&ZKչv>ėh H:RR$/#U$9ēBtϣ*'nl50qU>R*$F/kBYXO�Vi�ez\UO[bQ,`{V)s-#8:ZIgw{1P_h*MH>Hş(U<v _RAKĸBg:;m lF} [Ɏz}L pK KU;QU41?OЧWSwmVr N8@_I곘GzYi {#P/H '$ƈ,b=xy|s) +Z] ߴNr\ϕY v�h5Fg jO�%>$D&zْs?ۄB67+ 4W^IE=%%l+!r@1 Z_+e 1PxLEH6_kf�"ތL>qʸf}vpKK ~}p[j $6Zv"J (nKiISL=$Ƚ&=lXs w;L"qt\>(F>N>pv @%F*ͽY&+7!Ƅ GvMR`g * ڪ :;B?MI<WAC~$bV 1]"x<K>;Hl\O*.X s&+`=6S^%۫JxC)ݵ5CV%Qʜb fw8Q2rro&Kj$jFnSC~؊yZ;}s˟/p1&B⤔Ж׌5W*&JAѯ(h0bbD(O]1[:P^ 2\c1<EyPO"Wzm˹9A CLMQtZyG2&ΓȫǍd,lk,ҲOmvWZ}RY3: wGd\hH|L' n4zߒ) +FZXLM pB_7`4WB;VG`702==&v$|{hDffEgtKfRHurWG*<g (;%ψO?֍S޺Dv<+iG) FxޱM}[kH g5y-7$Q</ȫP]꾛?aS QJD܏ahv趘"`\[z!"Kk�nU+.67̓/+³jWIMgTG{qe艺<)2v++ ԞrO#hZжmy"'2sߋ Hg�⎴!&swLb^.>xC%P+q>\TsVFMPPzsl;5Tg{:wD9BVwAu{Yvl[$8aWoI 9[20*j%i*j_w~q<yOXLiyyQԭK)'x`g*%[>WmDpqD)qp:MC^4 "`e_ a6njê(Y@5GW9Կ>n|x0D-ۅAڴg?6b+}m +E~Ã*"83<w/sP/h1|S!HJ@H irH gȍ,ma}0baVkK<�>yoAiWr~i�Rxk<M@9-ЪW,ˀr�Lv qSzj[<Lӻ<E&jKky6`<ʹ#m;8G!՟.>ipl th42Ǘ& ;K  { l_ram2t b2!7`Uh9::urJqB'PWh1x[',Jm}' feɜ$6T|^hϤ;-Ph=@q,W\4+[7): �r;2@PPjեunIe\ٻ,)JWdBaVk5ǎ{z~$k[.j8jj&%&zo-i<)E{7׫d!prd:TBus�1eGxݏ""x#lf>t^4y̡ s)qp^lRCS, s]A&mKlW3\ b-ES] 6O$p<MFb8fh/N܂;&^sXQG{uSgǢ)}ˀ�Jr_` jF1A?5bȍOz<NVAzL_Kh`5Yq?#,pZe"L�:gjѰ=d8x!rU(Wް\c%@*} w7 Qw#ߦYnF bjȻ3rϳoq&fݷ)/Èpφ'BMGlBJ"hw-G>S_ 6+=9Gy% ܸ +4ޅV:? +Vcz]\-ڌ#ݎܭ^.+U~3:1uuQcEp&4Z08 aUڗu5UVNzRk5=!<&mz.ՅMMijtWh +!Bw*TŚ )eEB +*5�V폟<JN@]K7]r:C�jҔ,Rک>ܣk?Z3i֢pxvdÎN(AzW_~?~?zX_=O?|o˿ǯY;;73_ ̟htba#MĤ@GPYRSj6de]өԆ^ ۧ,/PDOI-gU%G)ע=QΠ~El'k&Sth5C ~)d*~ZFHR{ 害(}N!I[iX%WY$3T,>LJ]~ Iڑ`1i'T=kDMj!(H8!4EOZADjI]1%& L/N'HH}bNO$"ZIE4X icTegdtnM*Py ?ܥX`trߥ=y|@SsJ G$ Ӧd)IA"eL\R*f^&"!Pepf|g:VIfkq+f2m&a< +aPB9E5P4'KEE&dEcչn΢ˀk +i-#gc4*fqDp҇DDO":7HAln %1фμqQB&ni>4>݁ˆ#GmYiW _}}MؐJ_Ykl"(- +ڼ!fo7sLػe]iO{[{3rU {1$Ddp8VKC_H[n5SIq%\ܶBn/5$쾮lͱ%iGܥOtunDF}˯MۢK3y ';Oɾd1"`%^sDVUުI2۬iZj[m܄O$"xxCR3\U D"snY5BZYc?NhWW{aZ>)9>(29}m0otZ#F,[^hk+5PguHQ{%>v(*N5~ؤ=Iĸ5oSQZ>YL rIԂ[T'h(n'DD(v.ɶ,Ѷ6٩r^ {lVɊdЩf k{{! 6r4<"öd1z`a@V<*oͦy݅lU|.IW@]۶ɤqzmAiب {UN6BdO#@m&0EX,7Q�5ҨVQ5'ʉ=ia=h[P̹ߦ$۬И.-3S6ET 2nbw[*f Pu̝e!ɊUΨd;HIHo +a-A s)lR}aԥ\+6iY~SCwh^ %Py1Nr9ztI[)ۅxIj++_A&7`,ӹ,.#'jdB\-E/w7R^s+2۷bV:Ɣ4J@$Lg҉ኴ,<(㟙߿/dˣ<w_nϐ3T.}դP5,alhzs֖1OR`TG,Ν ,+D~Qԛ3l|xVSИAKT@FzG kGʾ"a&l7Gv dvcAēd4nk2dBR<wJ/1J\cr?<[ +MUƁzf4MדҀLDU7ev + $5Ea +NSW +2$P Eȼ +i'_]7X_#9*yE>)Xm<pN,-x׼Š^?O ߄TLG�x' qkz❙Vt +U[&6o"0F !/e@k)MNHqc'Itpb ZyZ=r[+rWairPWfH6Q\M +mрeLaVIBPGOb)i -<nd3.)ȓ@U]֋n]Xm^ +pͻ1$x_vy]jtiY } (㱥Pv!i t-ò"̺BKմZ$TVMڟ@2 O7glJG" +"- Bu#�4-]GZ}qk(/ĆS1NޓE1i⵽oȝ; hmcN9v:oM*V :itהV7 !<Hq<SMz[gRrU;@9`'MEN:"د..w W9QHME%Te 쭏<MEt`# sSsv43ͦ%0JFv}YelLZa+K{+m@ +=lH?YvLJJ9tZ;mW8Y60rzO USe K3Kު\JڑO +]Teڐ:/_ERK |NnճJ|g~JsyT.Z-8+k1?7V O ؕ1僅uD-c}ҀQ097SQ}U^fCMaWڒW=Ucؿg- fYU`Q,3Eg<afɐ![J*]nZ{.m"i3F7XHک@T6{ +)cuW.2΢^ ЕYS!" )`D%o]q8C&ꪭu +N"7т�ʂ:[H9+7b0B5Pn~|%~@ųP pnKb½lO~k)rd%uѶظDNrBNՑʝyQf.d˦V `ځڧn-WUUKI0(7k8%C}'ڵ zjj=?U$-~;AMu!Vs0bb~, Ye{H9r׶tbg;yr઒Klt+BwD>KglŕXI_^W@xGdo~_oSMu#W<*|ٵK!ŁSteCw3@rsTѳ돃o!Z_xI^ JxaЎQ`G6/j#K-_|U<§%w|`S-Rr^lW{@Z]'G{m-;-7zK5Wj/ɦyǧ #Q[Ge_ف"d>*4?ёS"e/1Fm6֛Z{њ(H抣:KF=@Y_a{J-}?) )hGVPQ;T>ݧr^w`DxW9qm3{ٗ0r 2CKo\zUJx>t\:}NP8b)RwK{%oФ~Bh<ӢeaDFCB(I@�[ʗ2 [uĮ>Q +>d\9@'@Xy)DK-ԩh beҊ)!W㻿'̶ګ0&⮶P<6\``iYsY[O)wa\ɢ!W: ݘQe6E>>Mat߂*!K32)W +^´~M@orW\}j~S] ɘ@=(D並05v�=Yqdt" +o3Q1n׸rc;ދGuɘ[^{>*`‚7ŰayS֐7 KCuSƷԠ 7Uޔ\қ_&"tԧCp,C&־N.#7xugUHޟv p8P:�x먨mŀ@9c̺]4tD]Ϩ ȴ%dLn7<o5_l1@X]Z/Ѷ.SΕ'b>N[H8(7}ϣbıw`Lvkc<c+H^,ӃPEblUghA>bWJ9S6)YHٱ]dzƭcHfM} c2T >˻Or<Qv¿t6zkdRtN=No߃Rj|)jJ!GG6SK"9~PpdEay}ⷔ4#&ٝDP[ݻN<I-54L!-*hvRuՠ+H%S^\ț.\nVZm Z�ٵͥ_i-TqF \5TR/DڧZ5W`SG^*TV]QyO`tdo +Ѹ_NK`E,Z3T( +jXtFYa� zDf3ĉ!ܲ~fCYf2A3yDH?dy{i͟&_U)j{oP<}nf J#5iآdRYd=GNEۍdJJYU<  uv ++wxpݖv:* P}eGfgWW>Bc6=͗Ђ6٨V�TV֏-摔}+[Hla;Ϲ&X"ie;dv.[.7\OuU)Fɴ\;yeSche- b쁼}m<lMbxzShv]%kP:sn.IUhd~~Im[<W+3k>|Ze,~3 bCK E~D ѶZ{' =EFMSBu[КVZ/֌}d0id7m!>`Ƀ˫O1}R7 +5>.9u6)Bk˩_UrӆeL}gyeY\q~Wpwv{l�icU k妝^3O/yG_ o|PzMn 2wvb鵹6и+;V,eX^.uY?IvH C M<kB%UC30ݪ:Uk}kѓL#*R_o2""}a"5ǀogeYDI+FYep!Nxt}=VT6ʒ[)ҰBڥaNxR d¯L.}! M8z!qNdz~ZOMwYuc|z^g,\LV +SlTG?(t.v-A U|5\ɓ氖MF'E͕v9i0ܕ@ $0cjdimgmQBD6Fi4v*{gR{X\Kt?/_>z+^?q㷧_~o#;+Wm&|ҢjR;)NͧTBe!>j[)o1(z/<0MƢMt5/|P1zPOJY*ږsFI52Ze؋r. ~Mc  ۄ<w!]gnɈ]:<ľuVʸ8 h(Uq) +�$90R&)}0`$AݎŅ'V>01kP#W-PΒg3H W-W&AxN4{kA=LZcWIW 9杈 )#{xL + >_JкzݧXYdb.M6=~$]za +x$@hm6R؈!\~j+F;n6d&"XѯT9GuE,rҪa nCjD-sr/EE~j& +{yP.y(żXfD +]*)2#T:akIbB;A)j uMu0'/j +bpR7n︯|t/sr;ڇ@it/uryJKnb6I f//#zuiXIrs.71q�؏㔓txJ1hU3 +Of!|K*5x7zlJ],�DwƊ5AQSh Q +N7@!#ԬHmJ,lt'j>eP*kn-(%zU8H\Bhkqűct ++[qL%d!W 1;R S�ͳ@ӹ|P`蔛6u� O[M8DiBԎ-_ +xۊLs v`]L'?ԁtXTvPO!VC[r _[1Pq.ժz,Kml'Rkn1:mEd+ST?@ ʨ& y5: US`"?iMk Q-\hiV,;@skV:B-!RD3 ˼4먮QĢ@8bKν@҇)ȝ'ZSr,Q8×mkE# zl�]*^JkV!v+~7vHXܚp +8)Gcnٙ%҃G&)^¤Z̝[QulGE&ׇU;DM׎n'NI2Jgyf]%*el%>&[еRsCQј� Q;$$mOdNLw4ҡ/[iFjVFt Dpqf7[�\=LonU8ܭAT.)Y>ΧBȜrEHՙmP SrJ۾2c?Շ ?Ś1(:?}r i-#>3zWL^r["5\K̓9\djy̛rr:5,ՅzyӺv.wWXD6ј,K;>XtKΦ;mz쾫@z-  rnsQzHs0 +̷-#Cw)jm�B0h=Gou7uᔅeG5/[;M@x"b )rjM%rKm_rgak. +0O^weG 5c t/Evw78"$u>TlkBpVTŨ @=#M7_Y'_{v)fg'!mMv%rc434Hе40)磹f~(T" hMnZHCK\LL=t^ +ojMMhX2_6قbi Zny.i @:5W'=FrB矆kAP=KҒi[4gR,3X1Pi@krԎj{`a+Okuh4?/^Ŭ/_>z;I!x˗݇ߞ~I??t|2"G#hÓEU$qPYFؕYd-kzdDO!96[< !nL;v1]bΑ/]t d 4#Eبq%KEE] A\Xެަ5ׯ=CcB'h%+k7kb+;:%M2bX eb-.vOr ~řlq$BE2ClӍ$HJUu'J3lRJ,bi3KjKO5&BB2|*RzcF¿0Yc"jF"op:Fy[<% JdRn]Dp'$ NL  gCQa(rϪ}e+d cUzr,W]*lZ\a]bE>DeC %_QerEc[kܳ�?$.K$ȅx#^\d΂pnB³PUPJKz ~O ~d䫡z1EQމ{BZa%p3&ik�nWEG[U<%]⓭pɬɽ.5hj$K-%" �C"X�9;6�2ӣɟwәbjnZr2XX�M4'ENB"/-㩡 K +P?85\F- s<2bA8*$:(ل U4w$LJ%./mK@օS8kAUV +9FRpC1Z ZQi-(186UPGkmMd|Fڑ\0K|/xH;}TI*lĈ\VMn_0w>7ɖOO*>l CDUr-fΡ-m!k;C8Zx*˥06dx%!׺Yb^pRNX𜆦vEŀ|'_B;vՑ9M--AC05 N")`Kޑ ̙Ȋ=7WW fW^>SEirDՅ]*hjHNyTj9ZYﺑs&;7U6fG/y:G:DuC zazڇ|kFȒSe_Ghߦh?ґÛ<`١V1ffxFV"tcX/Ʋ< l9vy̕cJ^Bs:X"FsOb"-;~7釾yMznd0a kߨn˘l`>Cӡ#ZKIe#힯֭jw&5fJ|ic<rj*CBMi ƹj9WBbTbҖv*{UmfwZV;#*$LnӞQ %VQTK\:pЁnFLiɐZd.^A^,ys{"Uk/vwj+֭HeSv]}9' \ɱu7'Z@m̴3%Fd +||:ףҞ"Vgi$]e "DQKoT%%TYzl4TMmL۔(Ikq^"4T:jm͏nQ7GX\2!Jfd?nv)A$'@Ctr}i{W +b#=Z';m}1GL}7y._"hR( 9؃angRaaiH]u0c)sD�i؟ET ~[#[#v5EoT[ 氛 +,90ՒyA}3L317I,%y4R/ q,yQt>l}Y\Vs"]Zd3crw +Q( +gIt 1/~t8k +<SlBկ@exy"\24]LL=ĸt8Ig-"q=³-UXĦɉ1:(j;]F@҇J=aDDQέs,P%x q!6vp`L%rYPҽ4D#8M-�}M'}?zb,Z:GFhI_[*XF{IIlԏ@58[U3|>*&rz%s0K_Z!KRn%-.~7O~}z1xo?w7Ww[zO'N7._<t&jק_^7WOͧ}LJw7o?<<~z9zpg}woo}{᫻OϏ7uzbK9Y^^1Ӌo\_?JOq:N?/O?|i[=CZQM"iD&Z= +\sf?Is2LTH92ct£Ai8Ua&:p yB Yi)  >NbcNV2BU0%J8pNjYFe.Ea-Lm3V_ʞAJ?V-5d,&]1;`).4$,SPj59lq6Y8 =61đBQ%ħ_tzDm @!xQeKa賂v-ZSpDzs.nt|p Q^=9L҄*H̐*b__=spF<HT +ߧ]f7RD2?Qet& TYD*nUE﬩vkWgݷҫD pJ$لɔ4¦xplHP87:,P)WTJwI;ĝc +#TG۪ZzY,J̵;~u׀ɖM &оIDSa&PͦT~99@W<0EV% *6V 0o#C'#&rϤ<O |9PH!o9C:V BW5ǁ7o\ Q-\� !ez2w*UYrSP<+J9^Ze_^%j=OUUۊB5'X-`U8I|cG1?/w\Kn{ +}N`vK7i]8Q׼*! \ +d-\ X]%^QԛRcSYVj êNt'<rI'UsrX"~Vo<a ѽh8_13Nu7=GI9S~ki.U,HF$r},)<ufj5-"+W!5Nx`艹gV^B듆;։< \<'e3#+"tWX*(ILj~oOӖSb ty=9]1{{ nX{ +!oZd=Q сXs.EI_ʵ%r�YU�?C]?1ے*JgM*o\?gQJyd~mvOJ#T\HT\ ۻQ3HS*tnC<gcwЊ0oxhree/Z"cH((ާwGQJ'94O8nS`CbLJ4.cD=\7_>DpNp럚Gm@_V?\p15/Am.^lqg 5ˉk0`*X 7Nm"~v=RAnM/Dgc .CjmfU.o޷$=*2@B#CM5C&0QlPkEfu3}ڔw{".e{xEft>d +\΁83)]wEHkB%A^jmV9\lepW% LXQ6ea:Nn&lf!wㅬ0ic$*k�X9)eԤ Jä( B;&v`.?4IEv!-v�gW? Qcp7ťMz[*ϫE؆Yʮ9 5Ϫ.+J2;"g_uLW#=рyINvr\oDO++*\yRTR }>${;'2\<up�{-</<!UW٦ɮDe[ʛњbɶ]-4C]ϳ!wHqLeԇ2OWS 7@p=á-$@n}ܯ(ޫ>1:5~-�A endstream endobj 493 0 obj <</Filter[/FlateDecode]/Length 1013>>stream +HKu&"(AE4'#JlPAэA!hRiՆF8MKQgssܨˍgZSM­̓ XYړ\??| Js1l^nY$W�� hWN C<ζcVpZvnOsom{�L]'޻6R?prz6L8#Y)�@ l.J?=} +]hĘ*� =Vꊎɑ`Nqqi(j(��bU飢[wQ+8 >ҙB fO,'��{ðcᮩo=+S-o;%��PH89wdu}o +=w|mAt +�?wcbCEuW~G?vnAt +��5E)tM;+M[b_cD?��k٥yW:mq,sDKo<zd :�w{S6RXBY+hwp{D?��ח^p0`"=m��Ϊ7։cVpƱb|,qޖ-[c��YSY DǼvHv`lzAvcS��,߽_;9U-? +T>~Vv[S��,UϤ6pWyz[V~޳ ]?Na��ݜ6{ns|i2re :�Ց]'mu`.2g;��W귟{{"}|Y;/ +͗{�� e7/~Q۬B-_Ê%)�&�)Kŏ endstream endobj 494 0 obj <</Filter[/FlateDecode]/Length 1246>>stream +H}LUu4Y ٴ4WVl6ˆŜC 1<P B-H@{ ^dV@\Gh-9\}w)a"v]r2zdtp!'W,PۛG\ALǷ޹Z&�)B^%-7v|oaSp`kھ?B��@;~jiXMTTX?gڞ?B��@[m,]9l&?]c0ڗ5GmGDO��^(JUeoVc[wܾâv)��܇_2Iqb,O[{cP,ܱ[m/DO��~-U}w�oe}Ox+3{?a>?B��}0fw?UXcq\k +W8==�{.Y[-;j}7=a{z+;@ z +�mDikMnm:;y.Y:{S��"P^gV]'i 뵿 QYQs=�(oD4|M”;, #Ru?��">xtLyNmn l\/mDO��0I]&Rl-v~CXokvӑ-KcfL z +��}x<w|8_yZkIGvZlq5[qׄ.yJ~!58,ꪫs}Ծ��/Yf}mpOA;wcVfJ etVWSVٛ7KK+=վ��/"dy,Ȗ˿(ek6s5OqT-nFʼ龣��_q@[Q?wO}˭AWswLq;Ztv��oj(Xn5_/3b!ď_455q5Cqdy;JeqģDVkߙK9 >}G��3ϊ5'Ɖ^E^ZߞnZm3uk-qP8=![��%r&ڶnzfԞF쥝fW3iC�h endstream endobj 495 0 obj <</Filter[/FlateDecode]/Length 3448>>stream +HyPw{�4&fq]r8jTp #53LLs5KB<WKԨhǮ?fqlaq|S{_~ cHňawbF5ѱk+>%ZwӖ{QK>E?4N  3*y+}mj?:} #FM}/i@a`x· !<ktZNi6}V/ 2SE9r睺kW W/8uJ_ /^KXN4FYan=|P8@)4^Pp6y]w`EAA~yVeݴ{7 +_z͕2gs�d` `wt?$$Os?br +CAD8H]FdkV |_y 8 ߔ:4پ 4C-Ro8f5}5F,~"kU]6& 4V-(xu2cM]Z>*iS&}ֆ6;M'mmh^T0>I )Y6z]w`r_sC^nnՙ;GT862q9k5Nr}dB: *2D&CA^NLj &u)O +3N$N` ) ⌭F8R%'yֺEh7myu/fTuhtՅαĎ[yPǴX:hʰDMm/4^MG"szX`^G(7͔EǹNsڃw埀a=RǨE>@2gsM3R9KR[=1nm,SwR6#BA^^mþ;觞uZqnZ@1Tcż [ctrM괩6fGNڼ=(yaonz|'?қ�^ar8.oj]#'D&!h˽\jw^ŐM]o4˷Dz~!\nuŮ <sݹp9kU.;/%u滋AdjJnLpݝDBkvt+rtßb0Gjo/E>ʏA/4EoY0,_mI](`-qJXonFf$!]F%=4ڃayO;0%rnuCPg޹w7zSWby.J]c/)A?P t7{A{8NSwMJGO1mfhwbs�^( ɸza~6©-Ɣ:WU5̀ +\1ݴ 7[:hMz0 Cd8M-3uM]lBr32: v/u0ֶV +}O! 8%υ;nT,Dx 2sn}? ?T"4P2sZ9ݔʯ7ST&QǴXq'm%5$EUgk*v$esYU<='[f%6)% \E]j:%ϷǎZooiZ춆i߂cBAUr=-,_`S (.`u4yѽk[+à^pƪ2n ~"Rß\~t6$??r̵`B2R+3V/NF ˷VW +m,LnkL`^#D&ڷ�RlWg +}?! ]N*{=xtQ״Ax=4FO1ϩ7SoMLipN|KnkHϋ 5T׫¥y~~ΥeY 0,MJ  +kmnC6f^k] BK 3>5ȦQpǝn~'HhM2wyl_ßb()?#gFd4a}az6©-Ƭ?WU5̀ +ۻڐ�7{ߍ3N+Bs6;uy<cv.KCfnCnn}'! EMV4P:_?9JԁX+R5scDOPֻ{x<@FK".ph]N*/+)a͋~[?H;R6_*]=s3Ntі{*7U1$ AWh|mC?`/4E@?ϗo[T\ '괖1v&-3V`EM轩6k<n-qh~4q(D!t!"eI"]DRZl:̵kN'N76wv̬L>XZQ&eR}K_ڞq`Gyx"望KN%D]zW19VE:7+.oz4h147^ iEOI0rϵ߹sef^A[]&4/ :ֳr7w?2o{:S,_*oDZ;yjƬFqDXQyd ١HI,txeU0pf`yL G[e;{L"cޜ2[ ¼ؤLr5U[?9nCH'9V.6ĺ<g\4͛| V#whw΍pp4h=sKln;,gG7~  I_ 2ܫ?j*̿GBY`Ry?�3!/BҰ6f$_ ;뎇p9E +ST f;\k}Ѧȥ^따IƁX+fHE4E,nrTnVWZir{lOEAVƹ(g˅aѬ$z:G,_*o  +qp s}<R~gQY;%ʯz:?,_*AAA7Ho(@S+{|="(2l1\`w=/  $@TXT}2N0``F,V?|?dG� endstream endobj 496 0 obj <</Filter[/FlateDecode]/Length 3466>>stream +H{PWc̨5I4&jbl* +U+A-2|p p"*Cȉp<wwcOD +(Dƨ1V4Ngif2I_usN#~g>3ﹻP/A~j +FjXCIy_(17 ov{ksAyΤ00{s 3<RAyR:h']?ukw/>5؜H ×AA H Ju$gWJ%!/y{K1)y2fUTw}zAz`{;AnJ%.o||zFĐ̿x8m>' |{Ö́ŝ+^ _ +o]AAΏ-v۷O<i N?fQvD RA&XB*hsI??l\5Ĥ`×?!br9E'? %VMҡI}VAĻE؛P\::{6Mzgx|g'u{Q_xX1w= Xbj*k1\oŷ1-һÓp&O/7G]/'rN9ɩt[;?ue TlW\Oլs}^q;\c`IOM[ͷsKguX; 737 򞵔Xv6t2J^T}>|+{+Q[2E-_ƭsjcȵžkEʈxh}C.ʏa<79ZT$=S˶Xrp|l] y-[nkT%?NpBf>p/Tfx))!&[gANC\*&f 7u#˷})[?0|)?^-ivԻ Pm i:[vS~*:^]jlj]>[#co5w\>Uvj{C, ǬTbUg +A].[`m Y56uL)M/P +Wbdoi(xs9fep-ShjY`o5f^:i(徟mbjˡo~}6=[;*PCpo\ CJg9W+W̨\sH! |jϖm#{랜×_HA͚Iiv''>^].[\?wߛW;Mu|2UhM7&&·ޡ.7yaΓ?(kXC[=bۼOMxh^n}Xޤ? D E=yϊᜃ [^0Ͻk\֨snCA *Q[2݌7g׭'z3 ə?0|)?w6\, ӍU+cnЁ8ע<#%Vu&|/![ɥ"!ϥ*;ig<LK]P>|d1\ۼ\Q>q\a>LI e|n0995Ncª) >6/k}}pXɇR? =|w9g^?Rrx?j7yrV _ +oT@a~iI(Q4Eb=m;hmw+w:,q@s h yN +[=upnypo<Hw =fU҄ўgyp +R5rM|{0p5֪71|4V]3>Kl>?AdraN~՛Yd([x?h<9#/,z7TKeGtXPP +>W̨k~/!7rt+ iV8V}%QL{j[;iM7#IWy߱ӑ}S}/n}pypr[BG`j8Ё9tp.W [eשtNc 2<LVp߬'鿜N/qo +k?0|)?� = +@ H 3 U+uNrJfe 8b�2rjep"r4z3s{R!Unw'}AZ>W̪ɕCA7FP9 P|ԡ<}:Ez8^϶=9/7GӐ +58ծ팝|B5qP3 #DpqsŽ%ɌI\G`AHsh &_=k̆s"byjLR΍;)yك9Q,'�R}5frYBڒR?{ gl1}r1^Nzs/58͞ ×ccMdGemz(^lmz:QW:/PN-UPG+Y~pfZK|u]q;aINS扫 R_/Mq%C{R=(IRAcZA +H432G9fLs6ϻmn ͬĢJF`Pލ|~ >4&\?c86]= _= /8/y}Թww.Z]j-u7A'!W=)vt~m!fvlhΓٜKMQШ%,߫ޫv +Ӊ*a3d ϼ;N*<q=Y+hi'{gEs,~7B;e>q%oOtlۼ=<8elK.c̿`tM$!밆)8P9?D/bTXppyn\Q N4Ow HVy�^񞔍{Xj\B]נeFe?ގS=v�_ݨt/ z)hzZ:,$b\YsVcʦ,5UG^GD9frΨϭ #(sŨ}  Ayh3t)"-ݚMXj\9(l:BߘCD8t{BAdto)/n7UG MXj|}*_X&m)  Q\p$K@NdJC�,e9 endstream endobj 497 0 obj <</Filter[/FlateDecode]/Length 1325>>stream +HLUer?6Wò +̒Ej-&cZLPB!Nf($^5@."\L17L1!Zn9wlx8y}?B}yѦzdǔ��?.H lyN[is'F^wgl39MOmC���.t\0kSv?f;?Zm zG F +��%bvt.VڕU[\b?���Xqzɩջ~ܐ:MS3<b?���!Vl:7ES;vϖ#?ړqbw?B���̔"JtwW=zZ*毵z@ F +��q1bšsS_nάK~PRGZet=#��ә<<wvruܳF 4Us'y/)��YXhn4|IӹuC㽲A��Ѕe,̅5US=5jў?zBϻH��� ߌ-I~,GSߜC?_K3y)��G־޹R} }kEٛA��ȘQR?ES4}ǢIc0=PϾ2Vyɉxk4[eEvMݹb_ё&a?vզvuWBhpw?���FܼLYX׾hq"ُA*qQd79k9%{S0 +xy投A7mzզޱ>;���#o\FXU}Y{v?{+eMѵUB'oC(Z.gِ(Y<U�3c3ycW+RZVwzf}ǢIr +^kEϳ?rHΗ=KN({ww , [)Y_[45WJy?iMjn_1gpwsS]9A:{-4gZu$ji4<gPWjg�w 1ֆ~ fF IpP.[H_<@͛1`s|OݡT_nclp3NƥCϬ<bLsUMrvOymf>3`P0�B endstream endobj 498 0 obj <</Filter[/FlateDecode]/Length 2517>>stream +HSo\r+ˀPVQiunAQY�˲R,E"1\ !7 4nl:Vbϻ 8$gds/CY~ c{FG¬;? se@rH\b Ҷny/ws3ۼVg=c````````, A/OMUp<ȄAꕤ~7ߟ %:ciЯA߆ cIۋL7R&cGDAAą\VT_Z/~ﻯ]M1弄h2iнVI:2KT:   .x&l~g=7%^@zj<mXчsF         n D,0Ǔ}dg,\X?kΨHLs#Nzd {s {]22OƑK䀹jfϾnI5a6sQc$6r-|hL3hb4~5<3jvE݋eeApn (Rd +|&Z׶G7m' 1郹1)(>2oD᥹y|-_=ƴ.Y8fC4ԪnmII�.}2kF,n1'm5ձ%Gs:0)?o5.MEL/,ɥΞ83vކs<5v/@OL< QI_+ǎs땓gmgigՋ hp>d!b~PcSH 3|s(gֆ, EeK1Y}gs%wf% ĺ\z yd%olcΡ=eA<F esA}[l?hco:ޔz*=)"s?K<ULvڒ�-45O᮳Ώз;S!bO&cܺ'ߛǨuxӺ ﮋ΅YP0ˮ\Nt|\ͅLPcijJML23e!vb6/}kFذg\y*{aҩ3j\G"CW3|?7Pc@�GJ:7cͺa݁"?& _dž.h31I*:c3BlÜ/:lF"EP(+q/д(w֨{ +:;e$LJ}܇z}رI�R 6k0'/ɛCGvbqIug91I<Шƴmvd3Bl-l>7c͚k+ V'iDG C]ujl '{Xu3_ڒ,`)5vs0UŲ?=6fa7x؉VIۋ`#ĈJ:+1VwrF]}YmHĢ89J +@/:4i'WMQcD'UrQc@Z_uT=0Ly9T fEiOS-bO%L5F< vG}Rmߛk;ӜQb'fA!lBїk {gY(|>?x'ey(Q֯ C݀u0* W6V}Fxun~V۝P>HĢKQcģhWE>2o۷N( =*8I!`60ߔM;zYgc*D +!Ÿ́A"1nӌsPcBo8Ʊcصٵm;S3TQ|>JnCQ9w]Y8֖I<ƈ'} q8}ǜ2j䎼3kC>K ̹cK/;F9PdިoHsPc%$ &GyyaE4sl5vm{lbDPi'M֮cE&Z؇Ǜ^/ɥdHv̅`\goy#ǜCOB"Ʉ= "TAKCHe~4zCT-0XY5?<ШF)8$.}tOámY̴TǂYuA]I+!޽?C"*<m'2M<Wǿ4TVzVgՉ }N( ,ͣnV_f{ {5*,|zjx\aO;+IOJvvY'0>e[bz^LD$aε Ɔ!N Л̦/\59~7Qʜ?2o#3wEݏ_Gu>%^@z꘻8yvz +M [52gf_?i,W� endstream endobj 499 0 obj <</Filter[/FlateDecode]/Length 127>>stream +H 0�obI,k1H\F">CG]:,=mR +���������������������������������������������������������������~`� + endstream endobj 500 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 501 0 obj <</Filter[/FlateDecode]/Length 288>>stream +H1j0DQ +INcs:Wo3��������������������������������������S+ Ӏ}\`>`wWտe->XemoXdÛ?4e+Dzɑ}_dodb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}bՆb샧}| 0�(C. endstream endobj 502 0 obj <</Filter[/FlateDecode]/Length 513>>stream +HJCAO(%g9.zۍs _vNjoZfoZfoZf>zS>X)Ff#{x;-샕bcǓRL>X)&~sxRUlx3M֊7Tl//n57_׋[MfoZfoZfBO L\cuZ2`Z5 +^δ"hv>~*PfqAkZRk9bjJ15`}RL>X)v biJ4`X}R,>X)v bhJ14`}R >X)v bgJ3`ؙ}R>X)vv bfJ13`}R>Ifv deH2`$Y}0>IVv ddH22`$}0샑dcH1`$٘}0l샑dbH21`$wI�2` endstream endobj 503 0 obj <</Filter[/FlateDecode]/Length 25361>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-v德^ksV[y}|{[4KVkb ٯ7o2y&5kMdcvmӾp=dk=unjH3qڬ;GÐw;dݣ6gOoٗ,۔3[sYbWo,*rcV͖&KޖY{ 'ǯ![{hfW Ŵf(Lݝuȩ +wdQ\w =S#rdu7kMQ8<7J~FWwVqn⬕WSZ3U0 +O~Tiye.&FB1f3KYתy+kN:QN"[N6*W{Uaֹͨ4I1urw|5&7gq\݇|ciU3nO G3 ֧j$6}h#Mn_ Ib$ڎo5ʻs1]'lhr^%u#SaB')hBycf`Ͻšxq ΢jݐ},nNY+3QwjEcfdUфmBd9 @]o'>I0 @B8Rm~` +?Pv/i۲FqmF �ب_HG? Q6oL h<(qg:kag%Uӆoy߾Ͽ~~u//>}}>~?;5+[_pM ;8$�\G[j2Gk6{~f;5GPKs&08dΛ4ejD^:kԜn'&%s Ϥ:1u? 48A@`|>GneEJ-EFC<{uҍ.M`է>Y@9;s(:u0SsojGP,&`r pGY5iB&>0 g( -OT2 ra�4TT "c +q znBzf~h"mdD/WE_]C<MQ6h;_mAS샨:51xwH00 }6ĈC`1Ҫ,Z9tRz@&rj1b@QXЅDL)""E׈ +84I{d*:+5ؕvU�^K @/e; kJ>"K0n +X|~)t0ɳDև!e0`?l +]܏_ +r +o-ۮRC}8!$v8u5Qsh5t*jB0ҫt" `D]iAB3! Tw rDƇ$Q"R!,4pS<LhH"4+db%65xjnPn=Wl3^rg*]![yV'&IR)!^~t=,_/8h}M2pJ)ByxW9WZt8%~"9]7q!˖h5j *R\Q|K*H=J׵x\]'ؓ�'ՖhqyF IUjV#4aXVSɰXW 4RqP,LM %M"4+'SFEE.N^RbS&h=SKJ؁!t |BA/3\Zwuaeiq:-oȩ: 1 "Ek>pzD|Aj vElA/4^ގ(CUR@{@k 5 +<M:Rg#X0hzjYI |Ήe*Qz,"ߓ;;/&p w%SOAWШ塶xS/Vy0RY?ds!1[ɒMo9p 24pm)S<HovLKB-ύ1pxd)BQ;dǛz s>G9. �,C(u5c|`[e`W㤓kUx\SP45ENz +0⹊!*ңTjGk#liȭ/Cb.:;;njH_*5+t9z`k%T= M.)s^n U`ĩ]8^x$~HA-"2 0xԚX_4U,% ?XS3Nv1KäR.}-FC2X/Jv/Fĉ!C/9'Bx>ĩ:$R(nO~8^]R#Pg-#xd#X+z'@(CT4MI%X,K%D QRMfu.ˉ(']v B"CU>NR.e]Ǣ(dd3+ZM,CPdF"ۚF,F/o\I�X^ZT TXRz2'ڰ=JUjIYƆdIOHh}Dy"QQPh[RA. Oj4,`NE 1yW+w\R]wܜ,דRHbwM,;߳le47|]#}! PN3Kʼn!5m 10?7}WL`:qi8}D Uic"'ixf�Hձ|RKRT栤Ou_uuP>T5ꧮuRLo=iK-.jÞe#+QIY IN u I$>iׅHRu8HZUd4FB}<Rkނi| )nמ2QL<(4}5c-7-jEd{p~L}g;*g%/ڣQYyW1:u8eUkWV:oڹb1Ȓi /]iv1)eL*!@yI"DMѺ5nݭfwߚow}|߷|Kw}9dQiƈi!%~m_T{WͶ0.g .1;`X:aw@ٓ7ZZNwAn$X_{cAGvzZ\S΃Xr"0|ZDX/=c= ծr$Z,Kq8�zs}-F$QbՍЩXJCp(@fdw13f UFbC;Z@bqlY% ߆{G(y89l7<7B" +mGg:- xnD=V2"j,EFe&kV.ObJ`\q[V m8zi4k�t fTdIfJNo9 KG4Z)wn}�[#~P?f+v)v`W /ZnkF)mt>oV[H%}7S9C௯J{q +e;aUy-&Zs XS�dHyfA"~)pO$_$L9AOˏڧ}PWBA=(%XPl؆6E%Mi`Gph<`PfJo:)Fbo@XQf!,d P1rsQ@EEo#ɵp$b2TǞ4O?zˏ$#vonۏV׫t4.1|/4O?}$<̌7\մUch9ETV20 v?&q$?`_?^"s 3yԹo BO+wzJi؏Ph ŠxV"VHe&  .R8ҁiK.H~EdMɘO #A rC[Uw&W(@-A%'ƲP4O jA&V\8A6-F'.yB:)47uidfkij:;%raKE6osNvZ +QGj�~[kïg + ZuיP~l"- ij `߀pT+o˼T$=(yuMāJPu.y�m&oN䟰334^ r'/4rx7) $N] c4!oR{GZQbzjp9$Drv1J|@Z\GS\r%2cF}ҶZv@-W1LpuLjY[]>oCtJs$Fy҅&5!a= s @rv~IQ-̄X&6U% 3O.|&\0+ PJ{@Iorԡ)ig\'`BWtQWnꍅF*f+krOjغBTL"A EEdy.N }U%rӿOp& *=?m߯>E'?&EbPJs$s`qVJRi~mdie,lu+FUiTtԘ~N5UQ}Hcy٫[FC1jVOu}H/Y]fz/S<s ,JVwT,e OJuo[EƠUHX=qKngbyX"wбU (^`SRF}6rj- _BW,YaW 1*(3,/cUV VR.yY#c\YX ($1;5 B摽?ȸ N-P]I~!3�'g rf&9djFHCB$w*]~(ɬnxk)Ф=\B++n vTPi@ӂ2E|Qsp_" 2RHܺ*_VCvqu>ڈ7-GPkiR>HNf6X0RXZ:j7ezg_Wcd_.;Z]W~~-"FRXLYD EWF!J"f`/>gjUٞm kFeH+)SxVRt04 / !]V8u +T1q&E 4b֖|ΓS봥C#wX8y(d2°mWW#EQoO+QW}𲓃3il7v +#K |64ř=^wm/<Tn\愈1r[PE{q==ﶍrH. +%2',?+ ޡ8L'(}z_7VI_X\\i7V/V;}cubuZݿX݉gZ=X=4~qz_]}|�zÇ>ݿxsB??]Ç7?]3G<{.!hNӳW^^]=޾xˏ/sN˻qz闟u?=C|z:n;4i겶B~_ix(}ZϴKuF`~[:F>uȫSk30%YEQ$J;{1#Yڻ$TLwizDa^*sm6. {\`N)tdrhxmIewSEsسuކ[- ޢ߼VSǶ<Z?'ѿ&z>={yw{If#~dLaRRr-˭ҪO"e\WNcATW֧J2` #3!4/xr2,<�X Ne٩ ǖ /8eI C6s0l玬q +dL35J)d"ےw, c.5Tٔ$FlRnT sM?Oi]H}rXl&C&tɺ:ђ|: ;*`Vw?ThR+gB"P|fuvśʌ6#}X�XG d^^q(L-V;EFcu}]D + +{f]n-�s`@)/, 8"Ma(p™5<zM4�(Kd7 |};vNap`OV^6[hjC?pH W G5n +e&N~ +Uza[ +{҂9V[9}Eox2++[9>Պڹ Nb P,;sy)2.u#W2z7Ț`?{Q{.ߚJΙޤu]%`vGEY_.[SK!l 㫝vEX}SɁ&c]BTךAɐC0m:yWx1=޼:L +ca[-r CcS6Yԏ2gx1ʌHFTB#ca5aS{𭣚Kh_BіVhrf6}Ѻc2 +Y""doKR71 (e%تj[l!鱇 d8cL(Ѳ }Ҡ}eݎv暚\{R[7˰qO rM)54:Z ؋.+w&<ҽ +o f)S.M@Ҵۇks\v--f_bؔ}@&%UoKJ&r+*`Ki/:r 4vA< B5(\l7.ՒTfC!AcSb5BfJb4b8ocC8/>Ѩ9&nw10ԇ;DW?:~d#0.(M]S0l ʣ%cbu*{6Na\%ll7.ŸJ\/ӥ<.Eqg//ȌԔ,%Y0c731LR)M"RCШ�vabf} +cCG-aD/FuT'Gi:n",B}0[iA&ːgJ1*ܦ0Bu=)#6"hrXT \jx>aCiuXoBˇwf-=kǾCg@#6OxJi~߲8\-mbe~*Յk]U^QPh}3jL;*[9=t%j@=Jorѷw\&ܰU5V`nAxsVw{ +嘓Sŕݍ &KOX-J+zr5]!#Z*|NF8-N)6fNBFD7K]QJRc`:'UR=Tb}1W㨔xw۲܇^7*kK94(N5R|i�йgiXqJ7rg+gn 㴅ylk&NS>y `YjLJג$aꔞ+cnh49lňws 8(>pRD5Oq6؎;5ȳ"W4FI)z~$ -A=! YVj }r'Ⱥ F|WNxj={ +$KmOݳt4[Ki@NC(H{ +rDZTs5VGRB2+k.G E) /O7c NHACV 8@=C`3;;]]]52V*&7RYpҴz=F"I[;]ST2ټ}aphs(mW{V(F:\I5xlOdQg%Jy_ [GI_Mn+Sя )j )ó%3�{O/8b@ۋv{Pr{ۗ7nןNn}ݾOnǧ{ԫYy_T3n=c9CJVӵ-܋r*{Xr&1(_R."M~}&2kֲkfńFli{a�h6%=WzykZrKrG +Cr@M$Ub)K3ͤĜ֑ +Z#sp,GbJ `Fp(w)n -+~�\50FQkX]PnHZtH5tWPN|c@R +E<f+ Ĕ8dh FGRd4*Ap^ WIc?b!c}>RZpBdFhWj8q Zz\p +Ȯ9jjKWkjС3ZCy:E0<2+[kJ`Ay7Z�Jo6!naq^lq+7̱f)o5)Z?TnfWQ 9 x@Z4VYZXWhuΗQuWqߓuPqθiiQ'*N_" ފ[RݨE_MZc|a1)i`Fd%&fQF"+.$UE<AF<SR‘D +jDc^'eGkܶ 5J^+4Z |eip c~%Ju/!$ԡɂx DA9(߁f(ORVfȖ;yboxP0% +n;;PIف/ˀƔ {92w 0R}CHn-B$zRxsE`W@aUPU`mݯmw,Lˀ/ * 9 ~KuKq -0%% č/ګ3KnlrB"*ET9'XP5u*fM +Ѡ{ZL 3u*E.8RѓhD,N-D88m1ڥcPilBDΗB\3sY+$n׾Ԉ1)$BP 5uS9w:Nq.n_>@Ea^WPT~5!!/2lM!Ĭ(۪8npŒ4l?8/c\ +&hPp>= z5ս- +맦<:rͲ{ۮ~ +Vp0p5Qǭp &%͂ +:)fpP!xBMͭC *-Au(2mt;_!KDZNw` }%6$Bɑ28t_?AOs% h_y%9pq J5h;D'rbvR.G`ub<J:3frPr0F\|)ІD%p( Dŷaúuٗ:+f DUxNb#93ioc98 -gZ"(gPs"E:;R8WBE+^;NhU狎~]4]9�_<cRFH3I<M7eZio 릦{_C.r6A1r k>bfS)�&}cy=$Z)CP<9Kγ?J]56^?X( ?A$³3\3f2Xຑ:kt+ٱчw 2Ši%b}(og N$f܁8<tѳ16cު%8q\5 0LB",@fvFI-^?O +WnӋ1$eumbPt/Xcx>Nf|,hWo؇.!Qx (cKUu@BR=WPO +$=bȒJOV[Z/ᆜX)E!.cg] AsMR}]vC*ooq#*~�5{9`\Xqzg-WcgP& -_ c$4`I(@D Kcpax)A/<|uq=H@Q7y=ça{xw<=r>n_oӇ_mq~w|~<_fY,ԔS"Cr#l[[eLW< N 7ɑEv;$hq5?F8-f3,$f7.S~ ;(ftB3+ }(+vqJl\NuɭgyfNa<*pԋGP 1,N*ͅ7 ϴH1}:RBR@xkBtJȺCp-J)g86\B4`v}kt4<'YuX4(urIa +z@)qO?5W~pG4R=IV 3 eHiDm"!k4C5!O=\詚'r?s!MPcYz)⍹БfT3n+-+[bP!фԺyN(sz¼p 5w(AAzIK6bSpH4l\YG&_hC{M=cڧit}J 2[ ad?$(u‚FF%_\%`P8յz*6sTJ,9'D}_۽;ykqW(=0t:ؖ]PQ:lTKHw8%bap/cYagmjSB3O$ajS#97$pם]t )ԛ ȨT5wv7e)OiMGf +1v}c排g +f޴)�2+ ttYF5NjFB4p]7ܪrluJ; VKsWww/S>Z'irUUuki3۴f}Á$ (Xb'׭q=)_)}ם]ϡ8HiaK&Y6ݫ)Yv"?L Ӳ[UqNe8ɷlGnj`W<Yx||K´u+H2;tHn2=<ѻbg^,hk_ʖ9dF2qHs˱G j)̜:8Qјx'6fBR\1n.ܚrShY}ֹ.DtUPN+QnsI}C=Ţ>` Au4F + njSkҺأWF4zRCDc[97ť핚5>MաdnLr .OdiG/&0鸺$y;]F3ӈ�q:(T5ef5)H:njWG},%uu[>MF *w6 U!=/)݉bpT#wT)=:?%6Vn-DFAroU)Q9j4Zw/uZ+#[F\y muifc;lس5CJ8~%oĿגUEBT kf:Fp1*]H�OG"-,t{'7SPCe=Vc:ujra}f ҜQn Q)ji9 0ШF9N[z)*uvY衺)rbv=;Ʉ 8??7{2i7lZbn5?$ηCUѶՔqy_WOs )8h*ehVAk1Em"{ jzAj$M)`d +ߣr~z@xTXܓLG6JAP3)=K|]U v̮|q{tDF�0^ +7'UJz]q$ 7m7f/z>HEbD BV:`j2<q^ME}Jh?1,J> BWueqxhv%b+1=О6*IV+ hǸV}Ҍn_f-Q` +E`kI'`a:뽼&y "큅 kJvFCc'4o<HYt)u+f./w"g^oќ_2\ԗhWh�,4T~72+&x%\Fe4z, N`oFh#3?{_*J,OjI3װ?|U_CU2Y}Z:%;F6+C&l@,`*}M zF!v�˃]SNJԛ0;Yq} `m +'#Nj!q+T h`Pr۵yEq]GoV)ޥ m(TSn�}kɸ\{,c7e,3 H{Q�Ν�Ҫ h{ w/:~@'*5qjdK{>9Ɇy$h:eCx$+ F^^9'Rq?LbY#=WbmI{ JUyjŘsȜ^'dyosYٽߪl v2fϺ]FK*aD\;UAnceWv Pl=\b.&_+f\{EՆ+Иxq<7[N '##lO {uPKW(Y'YcB$tB3فRWw{gٙ~urN7FTPRhr\WI,O Jٿkxaks<` +RV\DL.W~9Aԍ͢IrD�:Nd:FFVɏ|wc="*;s2G3ҏv? ڡ "A6*:ܛ2li:^?_9;̏$Ğ5'o&P^rƽ:~̀ƬcY'z̭bHJ!zPU.M%pm:Oiz +5a FzJAgڃid<{2@v) i`Uc"�̈+$y;D#:O�aM@U5wtnO}D$, -0�Icp +8@U8%/l H'I,m,ȿtNW [%Nx+8 +~a ~2֕5-=cڢbRR%TԾ@#M^dF+R"ABɩ"Rޱ2s G<Ő8@"A,BJham&ڷ$$| +Y}S>bos`ЃoF̙"R;|pۑdC6(~I,P dҜys @'wd'!x$guL 6D?w2;~(%_B;" !#hvbɸk|W F=5Dۙ `d[.Xh)1g:p΋l6s( YIfT?Wz:y+?s侥jH4rG]_F^W^啤".ɇH}d^!+<qq hsy0ZF2oQ4he^ 3vр5o9O+],oV0{-Jwrx&b hT/C,g<=~4xw>7=3V(xwo(3(t 6"s!]r`ʨ6/1WjRNV]bJ�`m oӊ kgG j>}f&j&j&2-Jd$m<aXLcICl +=EiA;!SwٮbDDYlb iL F.蕞El<rpiY*TP k[548w=qYA2ԪzEO 9�E2"{f1*}da8]:z[~zi:2 m/NN JVkەV"dΌ%5/ldG N¿]89ٲ2^NB)B/ݶ &ɘrSH~c깋,NY@HJkd kI̒$.؏qҜY>C+hi3=J$ibVxSJ Y ,є3�gc�^R.ɀlBR�ͽK#�b`1L`(ց4͠0(B1Tu,xD"7Ta +8i H@ueT mIrt <O}klAϻ>K C͕$B^.që/ yvzU1P謰g/#eYJFM +3SM@b6cn mxGJuʗ@BqGJ09�!$}ϐ*OS#PEH ]@eSaӉINK;[}++~\3e-pvdN)ZS;O4xa ?=&ݹP! . ]79S "k.5x,!m8M]K`1H΂*厉 :b ? ĉv^u-  DC{;Kbr' WARZ($PS#Z' ̭ )4s'F +F0r;z}DY 7wz˦DKJ˶G"B*fkqε1 #Sq(8k+%}>%^*<SNt_S&[<N5 LroʖH jπpt/2ļp2AOj"c] k\lYNkb 9NC}7!:jY5d"PlwB`}&js?=caDCsoҷ,&j{f5 rZ&|e,M +)WLu45?`aJ"])flN>\EJ^(ǻ6#R0;lUpKS bXqVdѸb֩|b{Isdq9CZNmδDRkp1C@lzƑ%]Aը$OԁdkC0[b,fl1JWnbPyež!&ʯ[ |^}H&Öɲ:e3>媘͊2wwu:A]B{7Q\[U?g&=zBR8(EU'zͪg,<y6e=,FT@MQ =Hg PFaBxgiqQP.?RT +2׿wwMts(RP6'f\F>AJɭkPM3ZBGQ{D$px#~oI#<Xj1rkg煍 $<0եrIV]tD=YggUShpV? 'cKqFm<�vnW~]ѬD<-OE} !+ɶx<Ϩ쨨o_'Q/3KuB+_O8U|)݉\f7>AA^/ENOrrɱp6"[-g;FS ]zr?.fй*Us\`\UI.'!zUH{d^YCY/;3:orś>W38 @&q)h51k@jݧZHC_첌1e$^67eLP\, A DKw DB/g�1@h //S/3Jsӻ|GQ}KK- H٥ec_) +T w\1m_dI_[|竳"!;}{4 "]:L]:'! 5![V2"S�c$3HiDžP_i +]Oj*:buN}7Vo ~,t%.*̆  "Q<i7 XrM$`˾^02}";" g'3̖ݖ + ՇvDƪS(+u_O%Kۗnd>H `PfX˩r<O;[8"?bCT'M_{ zYt�bV.$fJ4;Ȍ;I3#blj-j F1jZ"Ά0!*M.'N˧itiPCf6h= p~w禶22sl~ +vW(Q6uW<S̉fE/Z'-͸si9n2 Hh:u8 <uv�S,Ûg4񭀴/'R"^4@cPHK�$a"p)s붘~A|u_o^g aC +&vwk[>kVǴ*"ƪB)TxJc*3,zKp`Af_~ԧx}mp9(e`xNó+ӬR,Fg$~Iwf,FaR@2"gz"}\҈5�"` '2j}V?ra+!5 Ɨs'] HBH 9pߣ|+/ -=X=,}PB84]S"{\U-Ӛ&0:5Roٖ|.P!@QxT1=x72kӫҰ}N J`KsΪˇc1lkd>zki-fV'%-U ^$ߨ7%L!zB`Ǧkl�#%fc:KT�dÙ尖t d�љ)=o9=}q5P+F Bnlտb +m2meb@6Ѡ"dÒ8yb/)9�i-tzp @kKme3U9Twg3Y$s5_QK%d$t立G0ల1n24ukHzYԂ@:}dM 'LAƴlS2UAY$=%B<nxAi<0K.ƙa``o P3A$GRx;gFph]9vN@8X.d:}n:N8Ths"4cUhjO$Է  ;|CRML0-v38tA+/ Xܽy@Ov~Z, XpP&\p6ɨt*PUk 6no{5e$ɔy/"?7hNEFP C*OGB|1؁5Mށ׸y?0/!yg<5LBC5{7Ѿ33(llޤ5Hz~O".iLPἈt<yOdwD-ڏ +,q2;aj\W7IEJJP!֦#3ŘnL]\He씄d)DGg/.¢®UBqM, $;q㺆eSQE݄EX**Y8HҫeXaf }f16T fy>2"ĕ[ -\"J-=%`*zp !i!*Ҿi9dR-G n({s%'s 9 0[p�6%)p'c6p]E.�!(QT-少h@R>1'[38ezR-d6bigTg|=)b͋o_i.1s>=F_w߽owwuן^=yywӇۼc޼tOZ3\f>r +I+M6 +<E$Dc""Xs)1Ęh=M?=i.Eg45@InG*}ꇴ@!5ш .dAFXNbRf1xSvV@Cfr`cx6شept=q,0 5JAQ+6"fY$2eDwHQ6tp^!3 5hub}vz>$f vIHA"ܺغpa "Ȇq!7d@ +E�Qp;D_lo%,+ggviy>L(uzPh#Qy3y`0Bs,4$x[DjFFX'iT\:-Z.i +-mn"˖P'be!Nd-3#FԘUuGoClbj1q[x )է@6GDALm?o*L<5;"Ӛzh ^2#.)·ڵf,vh# +ˁN= ՜Dk͊ɍדJb{Y%w g0Xjmm'P97('{H +nPxe@)HO A@cP3Vg&ni?:~7Jo^m<P(9PH-Ηsś `,DI;YDK$IcBrRMd l_$�&Ns2_RP�jtHZB}&dd.dT?G3> s0f5z < :5_`AzFR&'H%@;rXAsB7&hJ]?FLH%tYڗXŨע1 B> ^ N!jo5H45ViguK>¸PpVP`*WӢ ^!FnwY}'~7]bBˈl ؝7:v!ǧK-: |z i8Ġ=4 Ʀ + B*yo&�n=8|hX98&.~q:=w^Co|HULWcTn>}%"WnQV]HT`e?uUԳ6sh&ī 75B[5Xق=H0g3M̒1*fXj$nH>*`(:}V0dX\=A4RsOkglo9R<=J!.2UfDnAMvtUtq3_,ɸ)ɝe?X(nH=hj:$Eq!VM܆_@aΘ%G팀ފg`V0 +0^ vg #r1�õћF)r I9 +4gq +9mRJJs=Ag~g"h<Qr$(w| &l@YM@wơ +yw/HST +E{a(o:WēMRE]j8y!Mq OhtPi?LH @UГ4e+iϲ=}MK3B-sPkBmAyk4;8M=>=\-ϰi.1Kkp}Y~@7 tm7Kb7fa2_\tw�3$MNk�(ad>Q\vWm?Dws`G;Cw<xhفbskBS-++WDrAjڔ�+5Wlj-!�М *rdF CpM;^fz7#G\o_/8ck b� EcZf\Ebo9sG�RGq{ov2~rC~Nfc;KM7{ǔ6SNuH,gw[{^Q`b[{u%j)UHwg5mbgf݊ޠK +l޼IWWlY_3gq^�W+ll- ;V>- ,w'WB.!֒waDɅ"Ad?mly0\5I[3[ssom5qzaSl 29I^t-DhQ3|3R/hH>RYBGPMV&Fk}ꆽ+~kf#uX_=@ !<6 Hf,%9YPuӞؑUqm⨂A4yfEF-MJX{I?S "Ѓon)$tȊP.iw̭: HĶ8JEbbjK*qP:-&&OQkN uR)hd>x#o>#v'?WgiVk1468괮#lU?곧H}~pnlHTnL#C| +mUЏV@ G.ZI1ZEzduq>l9=2K.)/z`(БE;n鶢t>])@gywlºلubG"K4sJU=1;P^n>44_ wEY9 DBT*[^ja- +-}խUk&̊7]+NZV%xFl3Bhtab܍P"0##◉9ɑNMPd�jR-0Bc ݉=_9`~9>!/D&<C+*,ـ uR=25\G5Ǒz$Kl;[]Oj.toFOLGbkJ>}W{n.#[{߭'4jK3=co{3_D0A.;F>z9J%x +."KvEVu;.uSb,2 dDb m=ycb [Nx"W'Rk+[MCu|jR^Jk1;L%2+2rۭM%e т%TU8.r8A޾)D\ uqF +.eĺ~S_) +ud  9/kR0NTFRu +ZHp-saF/qpg[]8UsF>{ԢVt{:xXVc@2B�]eТE݉p=>WItҝgۘ +T s *{bp*=B<͙) +)!'jV<N@(4*g q +|jlӔ5 +U ݣ캌[}NBU' %}Sb&}@|IZq%f2ׇ2%E(h&c u٤+TRaH|,SCڻ@3^uӱEdq<sQ4+Q +dY\ܩ9kCMl(] jd<r'rA>R)ReH]V}{C36FbcYS^Xv7K:"'_[M.5UݿÚ,"mǔ}x7t)"U^БyDj呔*mEYnnj[ iH2!Q)ƌ@ǯCBFjdP3l<]Q-_Mɻ 4㔳HRY#B[>7?*` Pz.\\T^?pK-0c]Yn,vbvwT:KFFssmS:GDzx�cV5Cuc@'i22K #eZ"|JI!b*&Ui 5H?,WXњdԈ\ >Đ +j$g 5i\V.B`%D +V?O.D*xHOɂ@TSEn"b^]#h~6qS;m1lɎMLٰX!5;hHBk_qMf DZ&]7t2$!U4T7GBMZ2b1YYXô67Wj1QL`e֤ےT;b�EZɌvd4QP +t_i"0w,ۺ H t&KY6og;/ HHh#2y9J0 +4)j2 I�eTZ$C9rS{79<WFi:B&Cʲ:]0lۡc{DQL *Y.R[E`#[6½p^ιڕ-Ԥ;ILhzX+>:J0{ .ލFR+4fWO{k׉1e( D2MAD7꼯 <D"1ϣ7Y_e\h7(fpbS_ͩ$%y`(y{l,0(hO}陛IvPmD[WU#kȸQYO{]+7-Sۀ!fjoHWO?~s{qgB=ӧ\^ś }O|{}`tz͛"?_<˷}sŷ7Wz;ӓ/nq}~quw|~~o/O~WW?M\kć_j yR3<yquqE_\_^!S]5,I|v*7Oyů>>`a#UѦSm-Ov+>l)^!cB]QHE/u~c/Nk waS�&)!`N#+mX-"${۞*/-<R)I8=��c| -=BJ:R,1^oD&WӵG>$R{X-)Pm\p+K@)Ƅw$�( rW3FϭtK6nY%4|9U~J\Am nYPKd'bgKmv?CqZ5rdWZV<# ԅ ^]bbk'7PQ4XM i].⳵љ!�,^ ԗ*fG4Kl@9=8ȧN))B] rT2Ru4]};i:&oMBpxpNG.8X?8|0GzV;ޏO@cR#ud +_ӟH=BK~㎚`F*HYҢ4{Fu6&ZxR"0pjԕެK,VV `eI ezlR'ueś.i<<0Qyc#RIf6z^MNs7~RE22j#F-@k4``19LO 4+->V:[!rr]i5?!̕lEJӬ!2 ʱ5Y#@S賾rs3eRci"U:LUk)>r?{$d.?:i dIhtЈOZLxn? +l'V"Ie6t/!er<D* )kH@G` +(rAY6[.Q/Ҁ#U4=-3v$ځEZ,X8ʤBkB{Q&T:0A|5-24UâjM̤9h#Bz\huNŪ�-)8ȒR<3Q7S+ l(`ZXyFŸ3%;ح4SZFDZ`1sq.9hˇ> 6Ƙt՘sݚޖmSrv1 Ve(S+3X oZ2x&UOp M[+"tI(sWgQ7%qﺩ~Ǩ`ZWZ˺z'̑\7\|r/r6IKV6YF`KRFv=WK"4:=jRL'r +~;XY>% X2XB2/+]4:Be~Rw?%P@9&SsFǝHQ99 o-AX\d{bgc/Ʃ0%$]xŜaj\L7o=7}JsO Ț0ViD<foy3-xF=j\?QE#/Qc>hӝSKނ6&˗тc!@@?;ā?r:=˞5^J H[QG]I~kRSJ-jSDeQ@Lr zv9Sa^ zt?^mkh~}JvaH˿��( endstream endobj 504 0 obj <</Filter[/FlateDecode]/Length 796>>stream +H N@DQib{z]S%Mk m?FaCE s*lPH-4l@TRGUC}`CH{ZTm>8ӧ/}IZLz.RܷaZFg2ҢMt>iU<-Yc�E0stfywVΉ}�T?fsNw1snCՌY�VҜVubvfbkՇ٘}Ufa<XMud`e~Ձٕ}�V=fSB[՘= pc$jUY}nW%fG^u ~Ua#x�TY}�#P f9 A/c6#eً}P2f-B0 %bV"s4و}�PfLD)mH/e!PZ}RQ8hJE=(0lh Z}�Qh*KGa (0> )H_`H}}�c,샗&A߽i4×p}g< a)/_>q)_`~>)�"3Mür Y^o4+&Z@$w?=̹KsqK sO5rН3z EO_w gsOtGrBwdߺxh{5j߳@� endstream endobj 505 0 obj <</Filter[/FlateDecode]/Length 789>>stream +HQr@ QқÖk9 +x5M?Kq"\?j O\zstt֍bՇh~n:ddtstF_OF{sD>] ` D4!et5i!/JGxlY<s`o IRf@$pXJvL 5Ԙv=`$T=kD&?\3:U0Rv]Um: f[nq~L%݉vÇ&t,=Wz3|\ E+Z6܉Vcu͸ {j\r:XNպt:^{`;ӆEעrzL[6]V#u:X9Nq5` l:qpy<}#bF~89K``a㗢 5O%cvK~+�×�v^}]W~`W>KPa _o_CLa +,;|',_uL:XXfdNSXatB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +etB]F +?~ 0�]A endstream endobj 506 0 obj <</Filter[/FlateDecode]/Length 591>>stream +HױNBQQ1[#S̬dgn.5yN=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:C_҃Eͥ`QA?vs)=XTO^ +Cg>B@?t}݁?J G+x[_;OpVnx*Bp~7B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tGnOe̟}`�?? endstream endobj 507 0 obj <</Filter[/FlateDecode]/Length 636>>stream +HAjPQ +!Ztfh/xq_+T~ty*9SɱTM8y+:ʸ}¾+! +V߇(l+߇n2NERq);ʠῂLUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usk [<KuW+}G> _cʼ]Km/ǩH>KH$ #߇>߇0h;_W +.pTr,as +T=F*t1z0Usу +{LUc`BS:=йT=F*�<-9 endstream endobj 508 0 obj <</Filter[/FlateDecode]/Length 726>>stream +HQn@ѽ7dK*3=%}2`L]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]2z`B׽u/(t) +]ﬧ;a pa9ؤۀ}p? \+_{�`u?!�WKwo_q1Z?8F-?~LC�W=住*57Yl!IcG%7{Ąmk޿vjg?-~K G[r]wz9tu?k\7|g.29 w?hޏ&Ǥj\#Ukd?o@y?Z7pj|>!5u?7ڏG~sYy_ǛGg.ŧ+s8ԥ=wmD3u?3cwX6shһ,t\|EsnL?k +rseWM_$I$I$I$I$I$I$`�? endstream endobj 509 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HkP�= K$f}jשCA!RBk@;It?|AޜsMrrp������������������t{=/"Zx/][5"ɴiu7ۢ&R/w!lz lZ߿.ob_]nܟRMY%vUKL|=8L.&Ұz%.7a>t0.>DQv<OQ>1i}٧QBvMiEQ}Ҿ=vyΞ? ��������������������������������������������`�V= endstream endobj 510 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 511 0 obj <</Filter[/FlateDecode]/Length 220>>stream +HλJa�Ᏺ?r +[t0 [<BHH' mwsuhBn⃟ ����������������������������������������������������:_~3r4?��ҥtS cڪ?&OIٸ|k��H/��@=WNC*L#9 +0�`y!U endstream endobj 512 0 obj <</Filter[/FlateDecode]/Length 631>>stream +HMKUQ#LQiQ$ hh0LkF)YQII'EY&5;[n}^nٰa-8k% �BnnķcۯKg&?:P[VZZ��yyefGȽKU6'=ddhx��pޕ珯^;n+��|}5u'sm%m*/OζLjjjIYœ0AZL=yx>;+*Wܾvvz9"""" bboE/kXu~qy8R^SMm몪%>_7:0 Ңf=[+G/Nڼac{C?mb٠SlXKkճ{s ;Jsw==[uG?gY89~j bPϵM&/N˽*gSlPq6?*gSlPq6?*gZZ֙g:Oa-u6 �n5b�ͼFL3�@׈~�H71��f^#&� kD?�yg�t3 �n"#�<8 endstream endobj 513 0 obj <</Filter[/FlateDecode]/Length 406>>stream +H=K\Q C*)L*-^ZĐ*`Q0~BH"#ū&c#f-L1[<E#z=P\6~�ȏg�yIyS��A$=MMRo�>A$=77Ro�>A$=W}��p Ϗ^}&��nDRԓ��DRx]q<=iV��dDIW?no}K �CuAyYRO�dA�� ?H�@�"��yD?��?D��MI{h��?S쯭Μ&�}sө?k�F<7�� endstream endobj 514 0 obj <</Filter[/FlateDecode]/Length 12655>>stream +HWn\ }}7r HkP$5UC{Frqxȫ/қRMk*HK7^ZQH[kM2RsKfdm%kiTo8mP#uZpQsh㗪^Bi,4ligR[6)!:N  t7}Q\6xk،ִ +=yQRʢ#OR VPVb->dRֲz 60!uVwt},N<n/:dClK\2NΐNz25s<sILU ×9)5mEɒD,ede1:P3jW^}1</K3Mi)Ү@i@A RG�H]ܘhC+ "]d`B/0!_+HTE f+V' F|1>.0PR"-zy +RE+GdpB{�'�(u!S4X3lcPL\%e@` Hs� �jI'�KCSO<h@mYՠ�hЯHJML0a4i"i,"�}dC�F E5ٍ#¦'  B�`P {V* Bc:z�GbpS@*xGt&{Y8et)WXKED&Glvo0 +r`υ0zJzl +fBp�5(@cML`U:+ă_Hw!& <E;R!a(FeT&er5v!® �WP7op�x5@sZPBBC�>Rpe#K]2maCc}((aqgAMԈ͙ؗel 3{՝y⭙6@݊=o<3~' +%4\qǴ;^Eqjh#V8 ZhEƃ J X%\10YB{uԙ\sH9IpdpZY5Li +ktҔ0/#m !L#mp9+I,)!eQ(kSb,^9.0s h`@ž3TfxC" #n;v a F�oTFUX cV߀P(aܽGcJN*b0u%toFdK)-$*Żq*NP6 Al[ +]N NbI +%s jn8ȇ@Ms+\8.WF)-`eG깁pt`er*Qlq-niLOU:]' 4.1tɇ�S< R'oy2(\AI I:ɋّl`scEnsX2 O '0+hkHl1N'E9)6ȴ1h}]ҧ +ڲ)p1g92vE3nR d50<lԥm>�3zIc:"6eUgXeE07s6zŸ%xsuB:3XTTҧ laXF$ 0w!lf TZFB @'4@s_] # nqD5z7W7'!oӓgJN7Woo]=OW7gOpO `/w'<݇׿?7_\>wgw1A"DFGgū˗'Ax}yqzon/rA#=y3g?\|sKvJ:N^\'ޥmXMNwI+px3 {,L?u^L9 ||?s +ŵ'?<OOyH,cCX3GxAE0 q5;<>najxwl-<x|p Zwz k7;Vq- ˡxPd?>n&*vPV;v(P{AAٻ/ތ-Z,ǃ2V}_7q r}/q`y_e^p@7gN='MB.S{-"SduUs*&ZmYVAd~p{ډV>>W1m*Gދf9Swu+<R +.8fwq@Kl;8 lA;b ?/w2�V)νhWXh@̚.*W ~ykTv"yrݩSq.+ZBjaVs73_u@nʾ<*]ūc΀ t\Y +l%ZCBmA2Ȕ6dL'9"&d{/;[h?Gސ0CٳN<W: . *{#P-dh?,X"sk{DJgY=`to-&ǷnmL+8d5 hr|d/uPV]udEtn?䫫A)# oJ›G0HF?Zsi<Um o;=n+ޝB 7_ӚF][B]Jw-2S{-=E¶mhi؛{ fģ]iq/AAw:l${9uFJVY33p ۇD Za m} +~wZA3V^q0g#pZ0R4֙5{(h9Ԉ!Ge:`"R9ĴMi +K35փ8c<{@%f "*JD 5A�oClԄqFO9V@:۠#O +|ݬb W᫪M jkCFAYvܧBqTstUkē*Ҏ\B#n;"4W#LpaIKڝe ԓyga 2؃XiT&ӢDj4IRT@u|G{MF}ЌݎB?wDژo?0[LRFs[S ѥ'?i0uu&W{ɨ jl|Ai?]q7?jp B}b=fB٥`i&ȓOfRb ϛ +mg FTWHd|F,z(BIf JV /,h g.ښcZƒ97'+ȣ>[}/'dK[!@ZÚt^2 "M j~p~i~w"F-Lh�:TtBemcE8}?zwGRO 9ಲϣ{U½b/M.B};_:ԭ̮'D7btY,~\~]Pz'qbio!7JF'Vt?_9Cik^@2y�Ϸ3`ӏaѢ.N:lTk#A8ٷuɍyBW?A -9iy&/wXjmr ޟ[G*R$̥'R˕gTR ( 6>O.2O)8`WAc~BrCNO0'5rXn<bE +MoSPn?ԧ�m|/y]OgX!֞n3v8߼!]nJ[O5]TX|x3b }`Q)z~O߿~w1d)Yo , JP +HLA% "� q۠eI=f`jLm.AmMP[X6'# ?eGh# +*OSZ'D1'{Pm.j)+)5wGm2/k=ԍ0c \"*8ڻYK'&0kWIֹ;8c,B9F׹vAhSkIDA3ThUߺ%݀6"kʩjY.N0ly Oa\lm&kuK손ǖ FN>3h)]xՐ ųaۢ4rߕ</kvGx@4!CRF(A57?D›aѼҊ +:P=mMlzA:BjvKukJQW�BYTmoJ>6m3wre[e>䙕$+..+с^␵BLX鰡^?)UA9�?Ax]#:}  .](Jtѿ�\ Q= +fx?W#޿DZi~[Hq^^>J" z!IY\? yqx!=#vxqpP<Ԙ +1W4@qҷLp}o'x�u:ø.>c\3o HfY R^q{U<*oh1TN:ٳ8qVQr-TV͸m|z{9wH'͠b"3o'J(VOBD-kV2P\F]($=6`4:mȅPBaZ">58ʜBZKzJ89!A?7S}dBBH&wi*19**Sy>D??O6u] RpF"qXV'֟ޖPw'W_avZMbحD4뷡*t4+D0k7XxWpE\ :(%c~x熒n0X.jY<3ZUb DɦT!`7E! Y%=4 s5j<sV1tlF|l[/p޹>t^c248/=>H{'.?qۇ?}Ɠ.ۏ^J<,=W&43xؚ@!\NeB^EPsؚu]5!3Xѹo@5Y0) +9dbSvnBz0T{gBEl+1`ȚXܹBswIױچ\Ybb7v؟@ h 5 YuK68}ӑ] 4FgeA*u56t(MwzA|<]V3S?86VuI1\zCO)i:4߿n25#!e^ъtȱ+\ϔ:yLpkNMk(+S!T@n| Zu2,11$< {LnҭK\75iE^_CqYWj+!Ľު[[ +-kXei=Րj~aCnP`alm1yRВNB[a^Le8R5QVUUeB ݛw k*pK!$];e Ptz}u(cz52\GUѻּbs,V)юи<1{Z tZLq!PAF進qP6{xP1^=qB#ּ6Tj k6w+~ + άO. \B<eRUʕXAY,/I_K]\.M^n\+Y+&39Npmm +hNMzməCQn0s&] +ɶ܏؀1Qs^X}ռհi˙i {G-d(gI"Ӵ8M5u+((^m'Iݮh82%Npҟ_EY?e@t2P#z[?tc!wJ=Z3.Fhw(`;d֎¦R yA]9QxT ;DAkDw],0|Qז mkVyEbi`}wRʸ"OϹ#2<W*8)>WbC~6;bY*G>E}Aov98ܹlx!4>Qt +)e +/ CqM'_~%sIHʾd~<F~_z>?ɿ~|^G/x{+~}B'}Dz! m¸2-:Truh<i,`םma#kmL ҝ 2fܢ +$Ҵf!d|gu$A +5mؗ,b O!/`g5N iHx-׌ 4"qYZչ9j۹T*LPOjHjo!>[ѕrT L`iAdG1uDF#଺n%-dRn�WLUjB$6r 4[ jΰ+bn%Z)nFfA9@$&a"ɝZ j^CJM1`1-e*ސ({B,CX A}-}l#E{HB!O>uH%]),u gwf2dhaCXdH"4Xݻ<Nu,~Ab:E!)5RM=zZV3Oy|*= )uk4nfMJ +mCV2߱;my뭨_Pͩ+Ø[4az+H=>.Uaak\Ը2 y|CosS_aUS4O 87`w*sk�\o(2ngէ7�B*bĺ߈k�&Q8g4T7nY,!'#S5Kkl~Q)"rɘ8ڠy?̜Is-#6`#8j.rUrb6_8dRb38lt*F5_tm^Mt<y$G|g+fkV_^B$oW*57-ePXڟA=-(@7B5[ԼilkK; շAO(l?p1BSfOЎ!T[; 6x[8TPWNK*Ø'oXXH4@Oxt' +۠S ˑv 1gZvD Wft4U5%o#+\ΖOrDfw8,^ͫO=|w:ǔ@Q%c ^vL_dM[UJ?-e?K/J9=W&ģWV- |$1b*"SE ԗ4:@D'"jlg"rc5=+"ǪƝqP\4oN|g,)kE幷6تRXPa]n;ȄYi`DwTڵ$1PW3.;K%}d`a/c]XZ\/a-cȫig#4.LXZqNtd6[qzRڗ&B@w4S*ZgދjSeqˢXGӇֺ!}_T?i#yW.4iLGK�H-@HV9 K"ktk+MUr!Oծu1U,:xNN4dh$ I_UG?/@*f_OQnHU}E^ڈ3{['=;3<GB[#ٻU>Gȕ]to; +`Ī')S8m3(T$1|L 2-61DBHHrKLЕnH/z[9 +,{ u$<VG2d]Pa) |IL�2 ^]7l8Z3'|[Ə+kNn*$#:ۋTx䝡HihZ35Gю5&.٦Sע S+sQ{'?:N,Ps| vuˇVjP +YVG>LJZTO؞gH$!*L SA*^ E'-$s zcT,m3B^dKb BJHsi3,&n4&D#�b%l�UKԐUd`zCPb挳%WZ$` ++WJE@%vP1Hb*?RCDBl  TVU}*]Ʊ[Prq;lC"b pZXtipJ1R-jBEʝ,`! #U]!E)xU?9'!E ~RE +$U NJ9Zw!ydqǾbT9"H>IVY�MK=M`NƖ3@qYܰGѐ( R+k^Du77vK2[pHm3=@c1,[$H#)gXQ8Rhj^+7dr 5bF׉ Ml7f$MchMj`OrwvuΜm~f쁑f.�@G�Ə�XJ P@)H+͆ڰ,g(S=q'dfR`'J6-Qwy<-=i 9Gz<|6!-NT�IX_ 9s %E.qwZs^9iGsI,Ι409[HĂ$ԐxE|%^gąZBXeqN!|TF +Ωp*&g1]^΍&vf+b$Heyd@uzChi2Ǽz[+6Cz +1lt4-rGCDDoMB6TjdҐxD乱p`  !ޕJrMP++ܨ߰ěQ]-3x +.[Ò'k[_\noĜt]kf{у{z%3^hvTF&cE7 l {Fadl(ns=kvN0WE T|\b߮vAS@-3DQŊ*ML`GTK,(Kǀ@ Ļ*hv.ʌw) r6Z[_krE7x4nSʇж3E=27@Cvk 1 &lg[@?,L2b�r/=b;jlat'JǤz1n,q?\Y*7Z&ѦWcja|ň%25~$xf >RsHiK}[jXOӍ�„ Au�~\cl$J4*` n]Rg7"P3/�)%Ps +&6.mgiv7n,G d?Q.#QvmB(F&T"TPMszD(H^kpH12P3r'5j_-{_l7bk�͵y"fcPK5XX쌥 +[z[ !ScaچئGv,/:z`>--ʮB۴S=0!Ř80*l04t:"]g|rȰY 6ۀye'ubʍzH<1^+"]豦5~N.I$p͹9tVW"_~{lc@PZȾk~|rv<m֮·F/O:p:O765utm>Л t/`SD)ύj1O?]t1]\?󞣨LX5 �qkLL1ړuT]PxCSK) +P>i9$KX.O?=vtYKlv8MVcߗ?}x)|ʵ2U; ^S9F%3frI823sfZ:iX1Cdl3KĩmN3?nп0}Z~!UI6P~29])IE( p}Eߖ?pNݩkJKڝ~Rm%".^c*Q3D w׭v^У>Z;Ap\ݏxY O *#W:?֩ibD#.\;DUMA< fp"/w#}49aJكSԏH1Tt(I0N}?KWV˥g*ŕR/rד^=~rEa=@q{wֿ8n;Xh~~^sszV| +<`51 4㗻Otک.vg7.;ǿ|W\}~}ocۛ{#7oۛo^_kwq۳7p;< _~}_9~a L^%ٶvYmbx؅I;dr$r6?aJ']r~%ՃśQ:^xP .*m0u$*]ןB +up74<Y+›G_*"EU-OUt*eȎ3ms#ȥbI腆 '.OpGY+\˳Kg! m6S8#|ӧ4͟VմiƖ< GCS LHYڝtc?) ԐyY xy7 +YM̅L8D$d,oAB +Pd2625 FIK+[f La{/![#,GӥT8ΔY~ڏn=pQ6$Ǔqh;:O$�)9-/{w_51 _$,L^pM.!wxCox8Mg~<|:Ξ>c [?@>Nc zNQ\WB+rt !y ]R^Ji\/"Ά^tɻ,]̇rW:Mof~@!8E⫉eﬓOh_)@_tQ8_Oy! b^q\g`1?OA<ttY|eo`bXG|ꈱpyRV>kOGx-'zsOz$d_Cc`C<8�~ "uo�Y6ef,x<.FsdtNˊIۋt:LatΟJ4 nzŴ=uoW9λVk9'sH@7`Gm6Km\ 49ps|qxzy!z-QO U2mP?sa l +6% u6[K``©j)*VL=l2NF r%)ZsqǪQ$R8 x7pjll4ו`cԪR%5tZv8zu Skfkͱe,rZUi41(.F窄<Q}eRFC=BQ*MeDRqͪ3' X*D =]=^KsmgY5崎)gzF˩%5IE!`ΪKX*d,j.XI1#rV  ++@ #zP!sRXwI%lNéDB 8B)bŤFJP +yrJbX]RM]c1k]LBZJe $mQ_Zڒ8S)&%x=q!אk-qM!ךsM sX^š4;5[v2\kkrz$sCtICt!ZBAtmQjbX'(ۍ&ɤ:  r ,r9פS1,MQS!w5n;.eKMZ[\sȵ-@3Bǘc ט*X5{HsT;9`k68%ڊQ!jK8ik\k @��g# endstream endobj 515 0 obj <</Filter[/FlateDecode]/Length 529>>stream +HKQb`%٤ + + ZզZmVV$R ) +tYtnDD\Z$EٺMjf904|y0swB�XoUꟐume��dyhoS?mm��qidoZ/�N &s0[-]={ny �@?K<�@k<�ۥ';kB��Hw/kB��H74?ƇW<̏.tݗx?Oߚ8kwo!r!rd5ǧқh=<S,,t.:,~OoH_?[oH|ÅcےxpF9C9#9>Nf��}g�t �n5bb�;FL3�@Ȋ##ݵY)Ny�H7Ynu.|L�@vȂ½;O'.V?��d}۳cg7� k⫗o\V[��ȶ%`�G endstream endobj 516 0 obj <</Filter[/FlateDecode]/Length 724>>stream +HKah3Bt+!4(\*U^05Xt3UqٗLw}IW[ je5j'yہ$\mjs:5Iˡf?xTz%G���X5X ؇{;{��@ic See���w~rUw@Z]J_MxfYӯ sF 'c/.jk=/���=YZXMsI#V?Gֿg17���sN-tJ[nXH(2W.4H6g|Bm���'F"5IˡfύXJs.���l@R`pF���ϓva+WE��bgO[؅?D��bC؅Ku6=���%|P&je���XjM.LcMn#��d20]:o_w=��� +Bava{pVS(ˢg��@AZ؅чu\\Y=��� +2J8I.ѧ\Y-,z&���"3zvo���f>؅?N ��@5]c׭3RVK|xE��d=0Geii4h %'z.�S� endstream endobj 517 0 obj <</Filter[/FlateDecode]/Length 614>>stream +H׽KUa� RR;TCKD 6deBTC54-\;Y-A- AEyn{3, [(�WBO}|@ ᶙ4 �f?b1?:n 4ekW += �B'A,ǶKޓ�@?b1?vd6<z��s&y8 �xRĢRΤlm�� }nCcSy��2-ĢR)]>sfq}��y7 ]; itk;>�W?ES7�]?E"-}� R?׭=� V.Y?Jw|{Y��yIjQ߹0&� nnDZdgp�u6ATjG/ҏ�j.ATjG͞u�p:DV4(v;�:ALjG}dZ޽z'�@]8~^ZOO � =4h`� endstream endobj 518 0 obj <</Filter[/FlateDecode]/Length 871>>stream +HKSaDIA2 +";_tE%م̒ +dV:LN9gfBA"VD_3w~s{$TA"UX\^s.5{t{��YvaW3dLK^��@8xr��@47?`'ǔhH +5ݿa���:Ø^ww0]��D^*?`'fڣk߬��@4J}avb?j˦g6(z]���3lץ��@${LR;V �� ?`'fnV �� vb?J=}��DߦlwN3m[��8uva?;WWQ��DDb:B.1MX3��(bZ`+ hV/]]mo{:OOTV= }/Tt%���uÝ;MU+'ʮ<ujFL ;󒾗JmW׾ggef���zT.%feҟ]0CJgjKR鏽wL5X���ڣj?LyI<p1vt��@Tq]E2EL_ dScUܐ;���*2}YEI?aoE}tXN*}:iRvv:��!fϑP^Υ[$G_HMMH1>#Uk4-''M`�lY6 endstream endobj 519 0 obj <</Filter[/FlateDecode]/Length 1526>>stream +H{LSgcQ'"$:ed85jt0/.Q[@;0a +\ +=҂77ŀ Ye_&8'zw^P��LBu ݓ^.-0%/a8�i4KZVTS-/=}<yL XK(afOvMm3լ~p]P@(Ft!f ���`{i +?PejJkKdϷ}C\)N)Mz>aUC\[% ҞhJVh92Q~WUX;aJ����i% ӇI*y;"##b*zaT(fx)Q(!eB5CVZͣݢS n*N!ą ���0\4v^Q_*ub@N&I05ڏ7%HPڌzT( +VÉ���.cO)Ģ9s]s_|ܮ^[xcJ}ERtR% c.vQKl"^^r ����̴iFFyL\c< gAQLI^.o%gkjmn>F9S����6ͱiʬ` +Cû~E0;?;Բǝr^vE���#;NdC�0#Iz\moCJu0&|T���0f?Xbt +ClL +5-7kgKzF֩{=B���1nOmE�"؅K2tZjq~v$Nc(���ި]7HppD,3șoVd Ըͻ]٨a'xl���#;ODQpD$NԮQV*ڳ <%[SG,_X���^[)LvB�CaT AגM'~rgZX=^���Wep%kBϬD�C<IEqk)6je;yl���U|kvD�B 1t$_90:-`PˁM*$S =j���r.:j1e/A�JgAfJʉ$mwթ5J^ʱ;3G���0*q'fov +}6=l([æzOFUj\>f{����/$9#p%{-pWe+^{5Y5OZ#~igw̲b{����#l!{ ?+?YC]TCvuF@ۼ[Y-F~'As#?���. +0.?HL(ߌs/jFgMޫ뵟Wyߑ?���?ЙC`�7& endstream endobj 520 0 obj <</Filter[/FlateDecode]/Length 1442>>stream +HkPTu^Hs%bjXyYihx[-1HLPeUƽxvUY2I0g7!һό9tQ8ry^ny3竧cKB(<y&uGJDZݩWuv\b# $����F*;/1)-ou:- ƹFVݦ���`З'd͡KYիoo^SCjqqqa\���|Q*N)Σ?O|?̄1T" a{V`4-9\ ���|)T+1)-É5XFyiW_q0f-,ygק���S.3)'?ӢHj`AZfwbƌ d���#Ψ" +|HJk"g9RxX/6l p}8���=FY_`G�?~oEŕFV}>isf{^+-?d���<fѪ=l<�>A&.jKɞ\N9r!'64(3���YT Otζ�QdqǕCq1Vq1v{\���xʨ~d'6CϥrmٮWܿq~O())ű\���xªS7ehOnF�?LN:b%s+.w#Bin~2ߟ���gei5ǣͪcGjYFu1=)NFbQIoq}^���lzړ:>Eo*i_"{˞?\��� o4QG�?̈>=K5RXW#թ%p}l���P2[;ey';AfS0u;i^.i >9��� ]B$ G�?fv.2D[Ai[vqXXZʤ@O���O8{C)Gâ@z?^Ȓt_Fj, +>���O$I6�>A >Jʹ1VnqN][|,1B~&yYsZVVXq͙>��ܰw'ӞC�?o|D$ɾLe:̑«Xd12Ϗǡ_ ls#wCz︲FLvCJYUѵYWEESh��ƍz)'[gQ 1UW{onؓZ5ݮWUyosHԽ㝌ceG"j +'Z6T^Itt$(}T5~L]�~ endstream endobj 521 0 obj <</Filter[/FlateDecode]/Length 2769>>stream +HyPw$QQ@V*x"Bu=V! EY((PT@`\ 7*HH]+e], Ǻm͏vS[ |gHf^&y�!0&[ژggf,X3d^�f`bc%O8}g%%l~p_Of[Բ1^~`Lo +m y�^,GO(]WĨ V()I;WwxyqkZcL !;wFs:k8M/E"2Ve|iwJ3UQ.~c;xX ewUEg׿{,�5�9S=Uc/rK'RHWdiIm?8d}l™`4r$0tt5!!+Lscc@,gQ +JrOud.YVSҽ&EB&nd9o�WZsw5IJ +xW~LRuy._)M9Ẻ1 ]!8Uhc3 mCs29pPAdyxpnY"._!I fӽ.o|"G#,{n?:lp9r'k +#;L TRv :d'd54!mبC[?6yY?L\(KȔ +IY.9rYy+3o;@K֣ %%CPoo%B!b'{�MhfFqAe(IT-iCf|)ݫ>%!nƛxRUw=JB}6|0�!}ܙiaX 3z6Y{j9%}5e2^`2ԟӚM+@Kxކ^6qV vbWFL]ݦ;\ggXLG}B bMȳb#Uh~8o\L$$={.JIʅ⏗ҽF/$M9ιZR#r?V1T}O >n?TG&~]RCQ3(y'NY~p1fͦ{,!!ɳ*?OdO9۩^ȼ64Oxtox;}C>[!}@h3*f1|GD8|z\M +ʈs^ +lGBH%E& #?b@Z˲ϘYE22y{qZ5r uL +T:;&`k*TJY|)ݣC!!2bsB*?g"/ڪߖm*Oӕ\/]cֽ=FUuUN_s~+\aB*)q+[</:%9|霹ѡu!s:.c9%i'}H`ܙ Of?/lv*4%4wSTK [뵢02 +)/d}9uY�653E!4ǏQH 8DyGV-ZkhG!-}%$EwdOc])NSۑ~~Lp==Krj7g99 +xpޤqB9z}(qk#|}Gg6d@BhOD7 MWGϖؠn Yf׭6V/d4w9 Vϼ]!}]qźiJJV.>~)--?w-{X~ZsN% +3S8'60LWBP驟DM?Z8s[. œC^t˂p8YCz,f!< #K2lϛ߷Kws}V*r( tH~,3mz.utJB 2òeHSMSV}67cs؂WjRz/jq&Z~PH$.:zpEmF2!~MDi'C9Tp�3ٽ|\ T祊 +E?$( }1IXgghw4uqUޙ-:Q{31n ijBqdK}~(.8hU`jhV{BsLrN䦞}K_tmb<:C#+b8"RޅACU'%XYrHuqeHS}IP])+sy>X\G: :ؑ!:zY !-[yF`m˗l_1uR"8QȆMhc`,;E&׮oG_j- +d`@*P:X3cRJf c_!(=}<Qjn(oN�~/{}U8vHdígORW /!IlQ0 +Fرb/ +6/YdijrGND$6}5+z7MΟc`Xp{ÃA⫦MH(e^=}RxMlb<i@}'<외 I,~gS3N66p`Q0� � endstream endobj 522 0 obj <</Filter[/FlateDecode]/Length 2199>>stream +HmTuAiY LM- 7_R# ֆ#NR +( 0? ("Җ,(9}Or55+w9sp}_/TT i5H?fD >u ? �@7pRuS2׼gx>c6هJr~}Ca8-|PI33s&2JG/#wPQ9͉͆7tlKDiְ|-::gƈ' /aB̌{}"_K;��2ﾳ{RVfԜc412eA, |0{Bf&uev:kZ,y͎eMCX;+uDQ6] 5Ygv!3-(Ap;ݿ���4ƃ1^Sǎc=UIb*W2wRUVgp&d?'OYƉ髊YCi + 7*/Xߖfem</z~>ً��$sԠPg͜-92ĬwO7䟵JNO Oy : \%5ur>^ͫٞD<ɹ7%��<3h.md7W$b1QS5TKrs纹? _) +esQg,X(GtyuS:kZ욵Uvn\0cdHfq�@?dж2ی|ޗҜ4[ ٥r+Z?s۞M^.76'rVktUE9ĭ,+و|L��3L5Zn2Qf'/Hftbmm[/W-! %,p|[/ݡ:i=e4b_^vr{�@Q"U1qi 䥳Yȁ3TZLt: 5oOZLlĠܐ6>$a; J^��#8]ݞ�!W۠tFCFMef: Tl +N~Dgts7gB :IgUQNnF\$h|Y��ETs +N7v?@?!!s(Jwu/V_/;B/#2]%jlN)GEMˢM8 ߫��~vgr_e KWqNYQ)ϠP2VCԖbUtWdN|b��l_Ύwe7 kAsTqږjNwA>3_A*XOt];Vu~9刵X;~_Z`B8Ύ �x(Z.ޢ�!{}M9lN .~d{քq5Kf՛4;I[zpdz6ߕL;{e�^ppQ؝E�B$+h4Tn9ŸcDmY΢'~.`-mv0{ָ)_5"k� @Ƹ3쾢�!{Zu3)pLRin{s8ߙ_c"0Ү͹Zd8:4sD/:�mxk>[Yv[?@e^<櫹b_o|H{J/Q&/Sj i1VY/2"#]y|z�ƜoXI!즢�!{S۠"#jؑb3UEώz?bE#ӟj +Yy|ߩNRW}ݗ:{'9�,=ǚf$a S̥]r3V[ܡewV/,]iG:ip)c~:(uעܧ='�O؞/fw ؗ`Wd3y"X>/[@Ta=tf N Iezoʊq? | ��_.a;-V.b  G9mX{ɥn2s!|hNRQ#627wwSCfڝ:-O/p"�Ыl +X='FYo'/Gh` S%%H+�OPjr endstream endobj 523 0 obj <</Filter[/FlateDecode]/Length 3025>>stream +HYPTwO  +&.1w!H"VTutTE0 `A4(@ovmfhu *:&(&pIu&VLMfRzz7sຢ!o@751<Yaݯ=_@Vu!Dޑ(]_ +VfcAzڻל? +_#|3'ښ{OCc=|(]:JV.T?JmCѡb x^XӾq +Y!KȋQ}(+Мs灉S HJDd]=@{`ѱ rA!yR0;E|&r51<vШ{R/]"u tItv|܂>kdK+`P=B̘h5tIN`CɅ1DOoYv(:\n�h�}bOJsASRaQ|K%*G)/,<L re¼g 5;#B'?СlB|UEHkl!(o9|&@7x=V>Ϩugb.T&:_$$q +K™ȈBc'jPuB+ީmRY3PJ6d[2N;YR\2D.\-=FH |_�,,A! (JO#$w t<OOPQ";QKʋ EG6i iOƼl`bWy6ޭka]ܞ=f^L=,P={2,utkpk Io`gR(En�u�dֈ3^uo~k+_uu^BI|P]nN 'ӈ #=^AN`O"݀]M$lGy1](w��WS[< gi:l{UqO|(+)G##yy|2 ,FR=))$/hp-=lL|AEH芌lBQ f7C ǛL<AGuT̍&BZȥwTR~]y~v4?|Rv˜wm 2~ALB'? g,>2 ߗ.2BQ[ +pm eG>_;en31IWY&BF TlhQEg5ka_dK+եzT&a t.ȩ(︻>CD軗(h f2(?VO}޹GuṰfFeQ>WȲOڷo|v+`-LNA9U"aRX:N`tpRM9_W)$4¿R(:lP�\ӁuV;Zn^+3.Wlm"$o蔋5 ȲԈD2^V.)Sd40v; NNܷ@M^iN дR`<t4ovܳ3i7j2j[эt +!{"ʢ|*ܯӢ"F{0?_vak064 @(J-B'?P:*9@_X)nUߵ +<gP@GTxX4SﴓՋMVyþY~LZQ\(BD u(Ɩl=b'se#,l(`P}< oiqgj)5N`t83ioB\2ϤVAQU1AOArUYgb{U)M2-WS㲜�~*{ɸy_M7 ޺Ms a]fL L@_WȊ/&i7 (ݵ9ic;:E (G-rO\O3u3}^vK5@gmb6'fԝ)\n$]wd<]);$;y0)yyusgX ؁9`;u|`5,FH}}R+_I nB'?A?8LYJ!ehwے@<;W ��dweGez+ط l {( n!ZeQ}+:~l ?Ȳό!lqwԾ;<6[q>~ AN   Z> (0/;;+3@7 +vYqiͬ,X=6 ?FH9 +[ ^Fţx20d`؞ d30+a`8Wp 1'UY^5g>Tv(lj3#.xɏwgs[f?~`| *޷fk_9vڻrڱtmfM4zúYSV͘,:zFsԆzI5]%텅͹B YYi\I) 19LaL!IRCC3C#5) ?e``` _k2i`*X񞵫֯ F`8(غ)ieAi޾ |?G(# /g`X.a["Ty>* L~B gˀ:/Vrd~ǝ_(;pv?N$y8dNSO}<QXGZ<9ر5wvOzsݗO?|vˬ'6?^&ot`ʇ􏨅AUSC`hc '0#sd0iVݵvkW=~<yqǣxQ<0@�6J endstream endobj 524 0 obj <</Filter[/FlateDecode]/Length 1384>>stream +HmLUu"bBVs@,6M!i2iHa(*}8p\" CNL7s$pqm4alt +8{],HJTFxH*}"N"m4Q.DXf8x"}Qѵ$}DR03gm$&$˭zʃc>ZxfA_Lc砫F~Az��kԏ* 7 ]H)�N%۩jU=0×Giv?��0;@<Q'�:PYsu ��}<gH(?)"`�AE+lܭp'].�كO쥣B/a R +ߛ"?YZQ3aw��Hv7]I01@EPFPZn��FBa R +l΍.U42qZ۴G��ixtzQ DJ�WW?kuGlU�� i#0ADJ�^=6ZN+α��@A@. žVu[s_nΫ��ϷHR?�)]q6hר~ls��rsbw]cX8^!׶UmTVJs[h?�OV$e<}+J��.pd19F+++jPV4L?l䥦V8Ŏ M>0uoz꾞o%씇e��`9xۏl̈~@1^Ͷб�z/l {סQ<n%v�eߙVg +bIiR BM}0}ϕ)=~P^��kWXo,?X` ;\#ަ0<^g<:<e!��'n$9pK?KII!``� C_Sۍڲ޻q��`~{"}YW8$u2S^Cz{\~։~`fs&QU1Oó2>Uu��`>oټMc݁LwM04 =}95W){b;  `潐2g7`;{ZA��ĨV{|o` Nf5mmbgjR+:SqNxrg}OXV|VO��q}}Bs= 18/J9㔷VNaDd}3��xd endstream endobj 6 0 obj <</Intent 28 0 R/Name(Layer 1)/Type/OCG/Usage 29 0 R>> endobj 28 0 obj [/View/Design] endobj 29 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 268 0 obj [267 0 R] endobj 525 0 obj <</CreationDate(D:20170110132606Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170110141200Z)/Producer(Adobe PDF library 9.90)/Title(Print)>> endobj xref 0 526 0000000004 65535 f +0000000016 00000 n +0000000162 00000 n +0000057013 00000 n +0000000000 00000 f +0000000000 00000 f +0000755973 00000 n +0000000000 00000 f +0000057064 00000 n +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000756043 00000 n +0000756074 00000 n +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000297251 00000 n +0000297059 00000 n +0000756159 00000 n +0000057550 00000 n +0000058244 00000 n +0000299604 00000 n +0000299490 00000 n +0000059434 00000 n +0000095727 00000 n +0000131572 00000 n +0000167190 00000 n +0000203081 00000 n +0000238014 00000 n +0000058311 00000 n +0000058870 00000 n +0000058920 00000 n +0000296317 00000 n +0000291715 00000 n +0000287177 00000 n +0000282701 00000 n +0000278271 00000 n +0000273749 00000 n +0000297133 00000 n +0000297165 00000 n +0000297613 00000 n +0000297947 00000 n +0000299674 00000 n +0000306146 00000 n +0000307213 00000 n +0000319382 00000 n +0000333692 00000 n +0000334863 00000 n +0000336000 00000 n +0000337382 00000 n +0000338523 00000 n +0000339663 00000 n +0000341197 00000 n +0000342315 00000 n +0000343457 00000 n +0000345587 00000 n +0000348375 00000 n +0000362734 00000 n +0000365752 00000 n +0000367126 00000 n +0000369448 00000 n +0000369606 00000 n +0000369764 00000 n +0000370295 00000 n +0000370938 00000 n +0000371877 00000 n +0000372571 00000 n +0000373244 00000 n +0000374785 00000 n +0000375451 00000 n +0000376367 00000 n +0000376525 00000 n +0000376683 00000 n +0000377346 00000 n +0000377802 00000 n +0000378310 00000 n +0000379066 00000 n +0000379747 00000 n +0000380460 00000 n +0000380618 00000 n +0000382023 00000 n +0000383900 00000 n +0000385625 00000 n +0000387943 00000 n +0000390197 00000 n +0000393158 00000 n +0000394603 00000 n +0000395707 00000 n +0000396838 00000 n +0000398224 00000 n +0000398727 00000 n +0000399849 00000 n +0000400979 00000 n +0000402531 00000 n +0000403645 00000 n +0000404811 00000 n +0000408086 00000 n +0000411439 00000 n +0000413095 00000 n +0000415193 00000 n +0000416362 00000 n +0000416937 00000 n +0000417095 00000 n +0000417343 00000 n +0000417948 00000 n +0000418714 00000 n +0000419553 00000 n +0000420214 00000 n +0000420888 00000 n +0000421747 00000 n +0000422293 00000 n +0000422451 00000 n +0000422973 00000 n +0000423131 00000 n +0000423913 00000 n +0000424332 00000 n +0000424916 00000 n +0000425678 00000 n +0000426362 00000 n +0000427173 00000 n +0000428744 00000 n +0000430073 00000 n +0000432060 00000 n +0000432768 00000 n +0000434855 00000 n +0000438429 00000 n +0000439655 00000 n +0000440985 00000 n +0000442117 00000 n +0000443313 00000 n +0000444648 00000 n +0000445756 00000 n +0000447082 00000 n +0000448435 00000 n +0000449121 00000 n +0000450245 00000 n +0000451667 00000 n +0000454835 00000 n +0000458322 00000 n +0000459752 00000 n +0000462217 00000 n +0000462375 00000 n +0000462533 00000 n +0000462944 00000 n +0000463533 00000 n +0000464234 00000 n +0000465111 00000 n +0000465795 00000 n +0000466492 00000 n +0000467165 00000 n +0000467911 00000 n +0000468422 00000 n +0000468580 00000 n +0000468947 00000 n +0000469597 00000 n +0000470101 00000 n +0000489445 00000 n +0000490770 00000 n +0000491387 00000 n +0000492160 00000 n +0000492872 00000 n +0000493964 00000 n +0000495516 00000 n +0000496832 00000 n +0000498501 00000 n +0000502510 00000 n +0000504962 00000 n +0000506401 00000 n +0000508386 00000 n +0000509514 00000 n +0000510648 00000 n +0000512047 00000 n +0000513146 00000 n +0000514297 00000 n +0000515819 00000 n +0000516969 00000 n +0000518076 00000 n +0000520638 00000 n +0000524083 00000 n +0000526073 00000 n +0000528428 00000 n +0000530142 00000 n +0000532057 00000 n +0000532215 00000 n +0000532373 00000 n +0000532964 00000 n +0000533620 00000 n +0000534526 00000 n +0000535223 00000 n +0000535893 00000 n +0000538268 00000 n +0000538960 00000 n +0000540343 00000 n +0000542414 00000 n +0000544464 00000 n +0000546861 00000 n +0000548371 00000 n +0000549475 00000 n +0000550899 00000 n +0000572250 00000 n +0000573339 00000 n +0000574473 00000 n +0000576021 00000 n +0000577150 00000 n +0000578280 00000 n +0000580892 00000 n +0000584336 00000 n +0000586213 00000 n +0000588220 00000 n +0000589741 00000 n +0000597228 00000 n +0000597386 00000 n +0000597549 00000 n +0000597707 00000 n +0000597865 00000 n +0000598023 00000 n +0000598181 00000 n +0000598339 00000 n +0000598497 00000 n +0000598920 00000 n +0000599078 00000 n +0000603232 00000 n +0000603390 00000 n +0000604161 00000 n +0000604574 00000 n +0000605163 00000 n +0000605858 00000 n +0000606568 00000 n +0000607273 00000 n +0000608877 00000 n +0000610202 00000 n +0000611594 00000 n +0000637832 00000 n +0000641262 00000 n +0000644029 00000 n +0000646043 00000 n +0000647420 00000 n +0000648559 00000 n +0000649704 00000 n +0000651088 00000 n +0000652205 00000 n +0000653435 00000 n +0000654888 00000 n +0000681285 00000 n +0000682371 00000 n +0000683690 00000 n +0000687211 00000 n +0000690750 00000 n +0000692148 00000 n +0000694738 00000 n +0000694937 00000 n +0000695095 00000 n +0000695455 00000 n +0000696040 00000 n +0000721475 00000 n +0000722343 00000 n +0000723204 00000 n +0000723867 00000 n +0000724575 00000 n +0000725373 00000 n +0000725804 00000 n +0000725962 00000 n +0000726254 00000 n +0000726957 00000 n +0000727435 00000 n +0000740164 00000 n +0000740765 00000 n +0000741561 00000 n +0000742247 00000 n +0000743190 00000 n +0000744789 00000 n +0000746304 00000 n +0000749146 00000 n +0000751418 00000 n +0000754516 00000 n +0000756186 00000 n +trailer <</Size 526/Root 1 0 R/Info 525 0 R/ID[<95DD853467B9422398A2A55684A3162A><1FBDA4727CB2497E90E64D51E5E8C0C8>]>> startxref 756344 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC2.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC2.pdf new file mode 100644 index 0000000000000000000000000000000000000000..0a76f4e40fdf1fae13049f3a3fdf9e89a41f661d --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC2.pdf @@ -0,0 +1,3644 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R]/Order 7 0 R/RBGroups[]>>/OCGs[6 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 58529/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Fig_WAD_TC3</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-10T15:19:36Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-10T15:19:36Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T15:19:36Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG6tRObczILgKJDD yHPgSQG41rSoIriq/wBSP+cfeMVd6kf84+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xV3qR/zj7x irvUj/nH3jFXepH/ADj7xirvUj/nH3jFWw6E0DAnwBxVvFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7F XYq7FXYq7FXYq7FXYq7FUo1WS2/TGkRrIouxcl5IlKeo0X1a5UFgfi4BmJHviqb4q7FXYq7ivINQ cgCAe9D1/VirsVdirsVdxXkGoOQBAPeh6/qxV2KqUwb1YGULsxDkjcKUbp/sgMVVcVdirsVdirsV dirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVYj5313TtM1DQp50eSSz1COSUIjkpFcWt3B6l VB5cBzYqKmg6dMeZAZAbH3MuBBAINQehxYuxV2KuxV2KuxVB3+taPp7Kl9ewW0jqXSOWRUdgvUqp PJvoyUYGXIWgyA5scu/zT8qQen6DT3gcsGMMRThx7t65hO/bjXMmGiyS6V72mWogGO3n5v6m8aiy 06G3kD/G0zvOpTwAUQUJ8anMmHZ384tMtX3BR8p+a9d1rzhp8GpXLSW6yT3MMapGkaOIJECclUOf hkagYnpXtlWswQxxAHMlu005T4ieQH6f7WfnWtYW8uoW0C7aCFwtvcxy2ZWZaVLhXnjZd9qEVzAb 1RdY1FmAOh3ygmhYvZUHuaXJOKsP1Tz753gsaQeX+N8ZpYyfq+p3QjjjvZIPVEUVokcoMEYlA+sI Wr8INV5Kt3v5g+e7fUrCzXybM9vdXVtb3F9G80ghV0ge4kaNYAoRDOyK3q0+BienEqpx5N84a7rs iR6p5cudEY2guXM5kZVlNxLD6HJ4YQW4RrJ40bp3KrK8VdirsVdirsVdirsVdirsVdirsVdirsVd irsVdirBvzJm02R9NsnCNdvcK0iMn24DbXSgFiKMK8vhr+vIZDQcnSi50Ux/L3U/rGifo6Vw13pD fVZB8IJhA5W70WnWIhSeI+JWp0yy7372nJDgkYsowMEJe6vpNi6JfXsFq8tfTWeVIy1OvEMRXJRi SaAtBIHNjd5+aflSD0/Qae85lg3oxFeHHu3rmHY9uNcyIaLJLpXvaZaiA6se1D83r96rp+nxQ8ZP hkuHaXlEPFE9Lgx/1mA98yYdnfzj8mmWr7gx2/8APXmu+WRJNRkiid/UVLfjAUHZFeMLJxH+Ux98 yoaLGOltMtTMpHLJJNPJPKxknlPKWVyWdj4sx3OZMYiPIU0mRPNbkkOxVmv5b26xapp87EepdvI6 mqmqehJ6YUgDYr8e/ic5vVZ/Ey+Q2D0WHB4en/pHcvW8rcd2KuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxVhf5iXts40y0V6zx3qyOtDQK9rdBfipxrWNtq1yvJycnSfWw661fVtEu BqWmy+n6sZtbkH4k+Kpicqx4VRyeJ41q1OlRl2hEZy4JdeXv/H3Mu0okR449Ofu/H3pVe+bfM97x +s6pcNxUpSNvRVg3XmkIjRvpGb2Gkxx6OglnmeqTqiqoVRxUGtFoB1rT6cvrahs1X3qolUqCYAtQ DxblUV7GjZGBsAplsad6if76X72/5qydIt3qJ/vpfvb/AJqxpbd6if76X72/5qxpbd6if76X72/5 qxpbVbaH61cxW6xKRIw9Q1kFIwav8SMCp47Kf5qZiazN4eMm9+QcrRYfEyAVtzL0Py06f4hsBRVL PIF3Na+hIdqn2zm8fN6TVfQXotD45kOqdT3xV1PfFVK1maWIs1KiSRNvBJGUfgMVVcVdirsVdirs VdirsVdirsVdirsVdirsVdirsVdirsVYX+YF5DNDp0CBxJDfqX5xyIvxWt0BxZlCt9g/ZJ/EZXk5 OTpPrYtcQR3EEkEgqkilWpsd+4PY+GUxkQbHMOzlESBB5FiFxbSWs8lvJUmM0DkH4l6q1eKg1HWm wNR2zqdLn8WAl16+95LV4DiyGPTp7lgIB3FfbMguMpW8s0tvFLMAJXRWcLUqCVBIFd6eGV4TcAfJ syipkeaplrW7FXYq7FWRaDpwhg+tSpS5nG3IEMkZ3VaNQgnq2w8D0zmNdqPEnt9I5PU6DTeFj3+o 8/1Mo8sf8pDY/wCtJ/yZfMXHzb9V/dl6NmS6l2KuxVA6JdQXmmx3du/O3uGklhcdGR5GZT9IOKlH Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqwr8wL+3lXTrVPU9aG+DOGikRaG2uVBDsoV qlT0OV5OTk6T62N5ju0SjX9OMsYu4ULTRDi6Iqlnjr9DHhUkCvjsSRmfoNT4c6P0l1/aOl8WFj6o pAKV3FR4Z0jzCxbRbOGzTkOF3Ak0CmgPIqGlUblmozcunenbNZ2bn4o8J6Oz7S0/DISHKTaOjryR gynoQajbbtmzBt1pC4KT0pt4kD9eJKFjOF61+gE/qGR4x5/IsuEt2c1nNeJFceokH2pWMbcSFp8H xKa8+/tXcGmY+plMwrGNz8PvcjSxxiYOQ+kfG/kyr9NaZ/v7/hX/AKZo/wCT83837R+t3/8AKWD+ d9h/UqaX5w07T9Vtrt4Z5ooS5YRBKnlGyCnN07tlkOzsoPL7XHz9o4pRIBZQn5w6AzcTp2oKP5it tT8JycyBoMnk686qCqfzb8u02trwntVIh/zMyX8nT7x+Pgj83HzS3UvzPOo2Umn6XayW19dn0kuJ GPGKMqTJIDH8XNVHwbgV/a8a8umOKPFKv1t2CfiyEYsnsLK/vPKdvBYX76ZcsCVu4o4pWUBzUcJV dd/lmHHk5GX6z70Z+hdS/wCr9ff8BY/9kuFrS7WPKGo37Wci67derZyTSKZhxVhLay2/EiyawbZp VevKo40XjWuKsYvvydvr7UrXUJ9cjWe1MDAx2s7NIYJJZFaaW4u7iaZlMqmP1XdUKCi0quKq1/8A lRr1zq/6Qj85ajEhF8fqxe4kRZLxbhI5IuVxSIwJcIqcAPsbceRxVlHlPy5quipcLf6zPrHrLbLE 0/Osf1e3SFz8cku8roZG6bk1qd8VT/FXYq7FXYq7FXYq7FXYq7FXYq7FXYqwr8wL+3mXT7VPUE0F 8rSBo5EWjW10oKuyhWqUP2TleTk5Ok+tipvLMOEM8fNlV1XmtSrHirAV6FjQHKHaWG4bq1mJEMyS kAMQjBtmAZTse4IIxUFj2qaSbOUzW6AWZIPGpPFyTVeNNk6U39thTN1oNWJAY5Hfof0Oi7Q0RiTk iNuo/Srz2fr+VrJqc3toYJgDXfgg5bKDU8alRT7VM1+kzeHlBPLq7DWYfEw0OY3CT51LyrsVdirs VdirsVdirsVTry1aNWW9cLxYGK3IJrQN+8J7faUAbdvfOf7T1HFPgHKP3vRdlafhhxnnL7nsXlf/ AI4Np3+Ft/8AZnMWPJry/WfemmSa3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWGefZ5bn 9G2sVpcM8d2socRkq4a3ul4pxqzMvHkwpsCPekJiw36eYjKywW78o6zJP/o0D29mV4/VTpZcDdWJ Vio6lBWoP3gHK+E9zmHNDv8Asak0HVYbtFWSaC+uEdYa2AErqoNQnwBmWMFDTfpvsaY8B7l8eHf9 icR6dqghCS2d1I9AGf6rMK067cab98HAe5l+Yh3oDRRTR7EVr/o8W/8AsBkDzb48gx7UtOFjcmON aWzDlB4AftJua/CfwIzouztQckKPOLzXaWmGOdj6ZIXNi65olh8Srzdd0UmgJpSh/tGV5PpJ7mUO aqZZASCFqNj8C/0yVItr1n8F/wCAX+mGlt3rP4L/AMAv9MaW3es/gv8AwC/0xpbXRNLNPFbpwWSd uCEohpsWJoaV4qpale2UanKMcDJv02I5ZiLMogsUSRRqAkahUFAaACg3OcqSSbL1wiAKD0XyxvoV pXrxb2/bPhmTHk6fL9Z96aUwtbqYq6mKqNjI8tlbyOau8aMx6VJUE9MVVsVdirsVdirsVdirsVdi rsVdirsVdirsVWtHG7IzKGaM8oyQCVahWo8DRiMVXYqsaGFpUmZFMsYZUkIBZQ1OQB6gHiK/LFW5 EZ1ortGag8l41oCCR8QYb9MVeOaKKaPYitf9Hi3/ANgMxDzd5HkFms6f9btSY1rcw1aHYVP8yblf tjbc0rQ9syNLn8KYl06uPrNP4uMx69GL/MEexBB+kHOqBBFh5Igg0VO6eVLWZoWCSiNuDkBgGpsa HwOVZzUJHyLPCLmB5uhnWW3WcKVVhyANCeNKg/CW65OMrFsSK2XCRCqMTxD0ChvhJJ6Choa+2HiF WiiuySHYqnnlyyIRr5/92jjAPiHwV3Yg0HxEbddtwfiznu0tTxy4Ryj970fZmm4I8Z5y+5O81jtH ovlf/jg2nf4W3/2ZzKjydNl+s+9NMk1uxVQv7tLOxuLyRWdLaJ5WRBychFLEKO5NNsUgWaW6Z/xz bT/jDH/xEYoROKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVD3tmLqNUM0sJVlcPC5RvgcPQ 02IPGhB7VGKvItFFNHsRWv8Ao8W/+wGYh5u8jyCMwJY3rOkSwzvd268reVi8yKADG56sAOqsd27h t9wTx3PZ2rr93L4fqdJ2nojvkj8f1pRcmlrN/wAY2/Uc2uo/u5e4/c6nB/eR94Ruo2Qsrt4EWkNA 8GxoEP7NeKr8JBFBXaleuY3Z+fxMdHnHb9Tk9o6fw8ljlLdDEAih6ZnOA1wWqkVHAUUAkClKdOny wcITaxkchRyDKHDSLIocMgapjI2FCPh+WQyQMokXVs8cxGQNXTIE8yoC3qWzCNVqnpsGYt/LRggG 3euaefZMh9Mgfs/W7uHbET9USPt/UjotZ02Q09YIQvNvUBQAf6x+Gv05hT0WWPOJ+G/3Obj1+GXK Xz2eoeU5I5PL1k8biRGVirqQQRzO4I2wxGzgZDcj702wsHYqwr8wdTkea00SBiqtS8vmAB/dxv8A uI/iFP3kilqg1HCn7VcEpcMb79v1/jzb9Nj4p+7f9X48mU2TSLpEDRJ6kq26FIyePJggoOW9K+OF oS211bzbLbpJPoEdvMwq8JvUfifDksdDiqhrOvebbLTpLmDQkmljeEektw0pKPMiSnhFE8h4Rszf Cp6dDiqR6h5z87PZrd2OmrbpEl3Jcw/o/VLx2EEaekIxJHpkhkkmmVQnpEFQ7cxxNFVurfmB55s3 eC28oTXgFnLKl9GbjibmOwW6CfVzAG4vM4gUGQMWDdCKFVNvJ3nDzDrV/NZ6t5bn0T0bWC4+sSNL JE7zjkYUd4IAWjVgH8GqKbVKrLcVdirsVdirsVdirsVdirsVdirsVWSwpJx5FhxII4uydCDvxIr0 74q8MWS7h0O0kjnkjja2gRVgtmuJFfjXnReXw0+0OPQbbnMXq7negq/Wp7gSzWt5MqSCOS35WjtG q0AYU4q78uXLrt8g2KbtGpqNvK6RCKb96SvxwSooAXl8RdVA22+e2CmVpD5g0h7a2mlt1Z7cxyep TcpUUA2+Ij4jv2pvm1xa0TxmE+dGj8HT59BwZBOH03uO7f8AHuTLzHa+paLdKBztSSxpv6TbPuSo AFAxPguY/Z+bgyC+UtnK7SwceKxzjv8ArY/nTPLuxV2KuxV2KropJIZ454WMc8R5RSoSrqelVYbj IyiJbEWkSI5JzaedvNtpCYodUm4li5aXhO1Sakcp1kant92Y8tHjPRujqJjqyOw/N7UYrfjf2EVz MDtLE5gHH/KUiXfxIIHtmMezR0l9jaNX5JfbPd3UlzqV6SbvUJDM6kEGNCP3cO/xUjHY9DXNJmmD LbkPxfxej0uIwhvzO/7Pg9Z0z/jm2n/GGP8A4iMudUicVdirsVdirsVdirsVdirsVdirsVdirsVd irsVdiqySFJK8iwrxrxdl+yeQ+yR9Pj0O2KpJb+RvLcNvFCts3GJFQUnuAKKKbVkP68jwBuGon3t yeS9AMbCOBlkIIRmmuGAamxKiRa/KuDgCfzOTvXDyZ5dAFbdyfH15/8AmvHgC/mcnelnmrynoMPl fV5Yrdlkisrl0b1pjRhC1Or48AUZ5kiyxNlVlKsAVIoQdwQcx3bMQv7MWV29utPTFHhUHcRtWgpT ahBUewzpdBn8THvzGzy3aGn8PJtyO6hmc4LqdN6bg7e3b6cBCQvEqlQTAFqAeLcqivY0bIQNgFMt jTvUT/fS/e3/ADVk6RbvUT/fS/e3/NWNLbvUT/fS/e3/ADVjS2itNt1u71ImgUwqDJMaMVKrT4DX kvxE9D1Wua/tHNwY6HOX4LsOzcHiZLPKO/6mWFlIpwH3t/XOdemp6dpv/HOte37mP/iIzLdEiaHx xV1PfFXU98VUrWZpYizUqJJE28EkZR+AxVVxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KpL 50iV/Kesliw4WN0RxZl/3Q434kV698B5MocwwDMR3aXa3p7XVsHiXlcQVaNagcgftLuD1G46bgb0 rmXo9R4U7/hPNw9dpvFhQ+ocmMKyuodCGVgCrA1BB6EHOoBt5UilwIB3FfbEoUreWaW3ilmAEror OFqVBKgkCu9PDK8JuAPk2ZRUyPNUy1rdirTMqip8QB3JJNAAO5J2AyMpACzyTGJJoc2UaNp/1S15 SLS5mo0xIAI/ljqC32K+NK1I65y2q1ByzJ6dHrNHpxigB16pgRUUzGcp6hpn/HNtP+MMf/ERmY6J E4q7FXYqgdEuoLzTY7u3fnb3DSSwuOjI8jMp+kHFSjsVdirsVdirsVdirsVdirsVdirsVdirsVdi rsVdiqQeedPs7nyvqs00QaW3srqSCSpDK31eRKggj9l2wHkyhzDBcxHduxVjer6PJbyyXUHxW0jF 5UJ+JHY1YgnqrE9Ox9vs7rs7Wcscvh+r9To+0tFzyR+P6/1paKV3FR4ZuXSLPqItbW1RGKpdQLPG 1RUMygyAAlq0Zq/Zp8QGa3s3MJQMesXZdpYOGYl0k5w/FQhAI6kgmo+gjfNjRrm66w3IXArGoJ22 ZqD33AP6sd6XZFWFzbWs4uZo5JXiFYkiIHxMCrV5MgNFO1T9FQMwtZhy5I8Marr+Kc7RZsWKXFKy en4tPo9d01ow7O0ZPVGUlh/wIYfcc1B7Ozd32h3I7TwHr9hX2+sabcg8J+I7+oGiP/JQLlUtJlH8 Jbo63Cf4g9L07zN5bW1tLdtWsxcGJAITcRcyQoB+HlXLpY5DmC6kTB5FO1ZWAZSCp3BG4IyDJ2Ks c89a1Lp+kra2jhNR1Jjb27VNY14lpZvhKv8AAgopH7ZUHrhBA3PRlDGZnhCP8sf8cK0/1W/4mchH kyy/WfemmSa3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqkvnKCB/K2sytGrSJYXRRyAWX9w4 2PbYnAeTKHMPK9US5hdZ40vLlPUWV4rd4l9MRgdFYozh6bpU9z1pmMHcy+LUNvNFLJcGO+kb1HkW F54yv7wD4QvqBeK+n8IJ25e5ooA96MjuJppPSls5I4mRizyGMqSCBxorOfiG+BlaT6no00EhmtYz JbqORjFWcEci3w9WFAAAKtXNzpe0ARw5D8f1uk1nZpB4sY27v1Kktq0vleydatJbwQyjruFjAfZQ S3wkkCnWmYGjzeHlB6ci5+sweJhocxuEmzqXlXYq7FXYq7FXYq0yI1OShuJDLUVoR0IyJAPNIJCP i17XIYRDDqV1FEooqRzyIAPYKwpkPAh/NHyZeLLvKbaPc6rfItzqF1JdRwK0Fk0sjyOFLlpSxYmp ZwBU7/D1pQZz+vlET4YigOfv/Y9F2bjlwccuZ5e79r1jyv8A8cG07/C2/wDszlUeTRl+s+9NMk1u xV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVD3en2d3DJDcQpIkgYMHRXB5IYyaMGB+A8dx02xV Q/w9oH/Vttf+REf/ADTg4Qz8SXeVkvlvQnTiLC2j3B5LBFWgIJG6nr0OPCF8SXeV/wDh7QP+rba/ 8iI/+aceEL4ku8qVx5Y0KaIotlBCaqfUjhhDfCQf2kYb0odseEL4ku8vLtFFNHsRWv8Ao8W/+wGY p5u5jyDHtS04WNyY41pbMOUHgB+0m5r8J/AjOi7O1ByQo84vNdpaYY52Ppkhc2LrmjWhoaHsSK0+ iowFIXrJbsKhXIqR1puDQ9V8cjEkhMhTdYP5G/4If805LdGzqwfyN/wQ/wCacd12dWD+Rv8Agh/z Tjuuy6JIpp4rdAwknbghLDbYsTQgV4qpale2UanN4cDJv02HxZiLMYY7eGJIo0YRxqEQFq0Cig3I JzlSbNl64RoUHo3lj/jhWlOnFuvX7Z+WZMeTp8v1n3ppvha3b4q7fFVOGb1HmSlPRcJXxqivX/hs VVMVdirsVdirsVdirsVdirsVdiqU695n0zQ5LGO+W5dtQlaC2W1tp7ti6xtKapbpI4HFD2/AEhVI Ne/Nny9od1Jb3tpfD04re5aT0kQC3ujwWUpLJHKvGT4HVkDg/s0qcVVbX82PJssWlG4muLK41gRG 0tZraZ3Vp5ngjSV4FmhRjJE4oX/ZJ6A4qraF+Z/kzWzbJY3jme6B9KCSCZGqsTysKlOBosMg5KxU spUEkYqmP+L9A/39J/0j3H/VPGlXWnmzQrvUotNgnka8mR5I4zBOo4R05EuyBB17nFU1kRnWiu0Z qDyXjWgIJHxBhv0xV45oopo9iK1/0eLf/YDMQ83eR5BZrOn/AFu1JjWtzDVodhU/zJuV+2NtzStD 2zI0ufwpiXTq4+s0/i4zHr0Yv8wR7EEH6Qc6oEEWHkiCDRcKV36d8ULIp2mTkUKcWdApIJojlQdv 5qVyvEbHxP3tmQUfgPuX5a1uxV2Kp55csiEa+f8A3aOMA+IfBXdiDQfERt123B+LOe7S1PHLhHKP 3vR9mabgjxnnL7k7zWO0ei+V/wDjg2nf4W3/ANmcyo8nTZfrPvTTJNbsVdiqEsJY5Zb1o2DqLjiS DUckjRWH0MCDiqLxV2KuxV2KuxV2KuxV2KuxV2KoLVtD0XWII7fV9PttRgicSxRXcMc6LIoIDqsg YBgGIriqHuvKflW7hjhutGsbiGJEjijltoXVUiVljVQykBUV2CjsCfHFV48teXFWBBpVmFtfTFqo t4qReiWMXpjj8PAyMVp0qadcVda+WvLlpNBPa6VZ281tUW0sVvEjRg8weDKoK19V+n8x8TiqZYq7 FUPe2Yuo1QzSwlWVw8LlG+Bw9DTYg8aEHtUYq8i0UU0exFa/6PFv/sBmIebvI8gjMCWN6zpEsM73 duvK3lYvMigAxuerADqrHdu4bfcE8dz2dq6/dy+H6nSdp6I75I/H9aWZunRrI7aSGFJixaC6eYpW tVdJGUp047qOQFan4vDNfpM3rnA8+Iuw1eAiEJjkYhfmxde7FUVpdgt/ctGwJt4SDOeIZW6H0jyq DyH2hT7PhUHNb2hqhCPCPqP2Oz7O0niS4j9I+1lbMiIWYhUUVJOwAGc9T0hICFk1fTI0RzcI6OQF MdZOvQ/By298vjpMsuUS409ZijzkPv8AuZHpH5m6DYWEVlJBdSNCKGZEj4MSxO3KRW+9Rmwx6DIR vQdLl1cOIkboW6/OC5ZJltdLSN+kE0sxcfN41RPuD/Tl0ezj1LSdWOgSu4/NTzVNbNEotreVhT6x DE3JT4qJXlT7wcvHZ8O8tZ1cvJI5/NfmiaRXbVLppSQiKkxhDM5oo4qY46k7DLDgxYwZEcvixjky TIiDuXrH5fxvH5fCyHlN6rGZ6li0jBS7Fm+JizEkk7nqc0XEJbjZ22WHCa7gPuZJi1uxV2KuxV2K uxV2KuxV2KuxV2KuxV2KuxV2KuxVZLCknHkWHEgji7J0IO/EivTvirwxZLuHQ7SSOeSONraBFWC2 a4kV+NedF5fDT7Q49Btucxerud6C5ri9uWlntL6RIJRE8AaydlVQKMF2Vm5l1bfoOneimyeR+xME 1G3ldIhFN+9JX44JUUALy+IuqgbbfPbBTK0m1TRpYHD2qNJC1eQA5FCSAooPiINfopvm60faFjhm aPQ/rdFrezqPFjFjqP1N21p9e8qj0KPKrzT2hWh+JZnKhSSPtr8BNehzBOXgzmX9Jzxh8TTCP9FJ 4Xd6MQpiIBVkflWv+xG3vnSgkvMEBcA9HBYb14kChA+kmpxo1zWwrwT3noxwwyycLf4QIyV3Iqef CnImtfi+eY/5bFxEkAnz3cn81l4QASB5bfc00E7SPK0bGSQ1dyCWY+575fERjsKDRIykbNlr0J/9 9t9xyVhjRd6E/wDvtvuONhaLvQn/AN9t9xxsLRd6E/8AvtvuONhaKYaFYXEuoCVonENuC3PsZCKB aEGtAS3ttmp7Uz1HgHV23ZWC5cZ6cve9e8lArpDBtj6zdduy5q8fJytT/eFP6jxybQ6o8cVdUYq7 FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVkkKSV5FhXjXi7L9k8h9kj6fHodsVSS38jeW4beKFbZuM SKgpPcAUUU2rIf15HgDcNRPvbk8l6AY2EcDLIQQjNNcMA1NiVEi1+VcHAE/mcneuHkzy6AK27k+P rz/8148AX8zk71k/krQWhdYoWjlZSEkM07BWI2PH1BWhx4Av5mfe8+t4Bbvd24IIhvLxFpXot1IB 9osfvOUS5uywm4gljer2BtLxivIwT1kQncK1fiTpsN6rv+rN92bqOOPCecfudB2ppuCXEOUvvQWb R1bfB/tFiFAoFpsxJ619t8rP1D3H9DMfS1ljB2KuxV2KtE0GwJPQKBUknYADuTkZSEQSeQZRiZEA cyy7TLIWdmkRp6h+KZhvV2670WoHQVHQDOTz5TkmZHq9hp8IxwER0eieSa/odq/7+f8AUuTx8nXa n+8Kf5NodiqGu/7+z/4zH/kzJiqJxV2KuxV2KuxV2KuxV2KuxV2KuxVC6nqmnaXZte6jcx2lojRo 88rBUVpXWJAWOw5O4GKpNd/mL5ItbeS5fWLeS1ihmuZLm3JuIglsYxKPUhEi8wbiP93XmeQoDiqq nn7yWbOa9fWrS3s7e6ewlubmVbeP6zGvN4lebgrMFNfhr+GKr7Tzv5Ou7k2lvrdjJdiQw/VfrEQm 5iQRU9MsH3kYBdviqKVqMVTvFWiyggEgFjRQe5pXb7sVakEhjYRsFkIPBmBYA02JAK1+/FXkx5fW 9Q5EE/X77cbf8fcvzzGnzdxg+gIXVbE3lm0amkynnCSSF5gEANQHYg0Ox8euWafOcUxIMdVgGWBi fwWJg1FaEdiCCCCNiCDuCO4OdXGQkLHIvIyiYmjzChLxW9t3YNUpIisPsipQ/FvT9kD5/PKZzrJE d4P6G2ELxyPcR+lEZkNDsVdirsVTHQ7EXN16zgNBbMDQ8WBl+0oINSOFQ/bfjTvmo7U1NDwx15u4 7K01nxDyHJk2aJ37OvJNf0O1f9/P+pcycfJ1Op/vCnF5fWNjAbi9uIrWAEAyzOsaAnoOTEDLALaC WPax+ZHlfTW9NZnv5tiY7MLIAD39RmSLbw519svhpMkule9qlngOqjpPnW11/W7S3sYZI7eESSXD ThVfmUIj4BWcUpz5V9sGfTyx1fVliyCYJHSvtv8AUy7KGbsVdirsVdirsVdirsVdirsVdiqF1PTL LU7J7K9jMlu7I5VWeNg0TiRGV0KspV0DAg4qlVz5D8rXdo9pf2smoQPHNCy31zc3Z9O59P1VDXEk jCpgQih+Eiq0NcVUY/y28jRW0drBo8FtaxXq6lHb2/KGNbtEWNZQkZVfsoNunelcVUNP/KnyDpxt zZaX6Btbn65DxnudpwYW5Gsh5b2sXwnb4enXFU6n8s+W55nmn0mzlmkJaSR7eJmZjuSzFak4qoS+ S/KErRM+i2XKCRZoiLeNSsiGqtso6HFUzvYbia2kjt7g2s7KwjnVVcqxBAbi4INDvTFXlIDi5vw7 cmF/fVYClf8AS5e2+Y0+buMH0BfkG1juv6dLHcNfRKXgkA9dRUlGG3qUJPwkUBp0692I2/ZurEf3 cvg6btPRk/vI/H9aE0u1iu717ab7EttMo+ySCHiPIBgwqpII265Z2pkoxI5i/wBDV2VjEhIHkQg4 zIeSSACaJmjmVegdDRqV3p3Fe2bPDlE4CTq82IwmYno0ZY/T9QHmnSqAv+C1yziDXwltnITkqljt RRQHf/WpiSoDpvV9OkNPUO1X6L70H2vltib6KK6pkmtTW6Rw2UMcNtGKem/ORj3J58l3J3NQTms/ ksE3ORJ/Hvdr/KpiKhEAfj3NS63qTyh1lEa0p6SqpWvj8QZq/TlsOzMQ52fj+qmqfamY8iB8P12t TW9aTmI9QuY0k+3FHNIkZr1+BSE/DMiGlxx5RDiT1E5GyUCqqoooAFSaDxJqcvAA5NRNt4UM/wDy 1s1ttRtnZeNxcK8ktQQ1OB4qQxNOKmhHStT3zmc2bxMpPTo9F4HhYAOt7vUci47sVdirsVdirsVd irsVdirsVdirsVdirsVdirsVdiqyaN5EKpK0THo6BSRt/lhh+GKvHNUuprWbUZ+cMdul7qBmmmLD gfrcnAhVHxd/hqK7UOY0ubtsRqAQS6xcSiNre606ZTCrPSZqGVWBk4uvIcPTDU2rt4VwU2cXuRqa vppCK93AZmKxlEkVqyOePFe5+IEdMFMuIIS309LPXl4N8MsExEZ6rR4SR8viGZObUSyRAlzj1cXB po45yMeUuiC8wWhhvRcKCY7n7RFSBIgpuakAMgFAB2Pc5sey9RtwH4Ot7W05vxB8UtzculdirsVd irsVdirsVROn2C310sEi8rcDnONwCo6LUCnxHseormv7Rz8GOhzl+C7Hs3T+Jks8o/gPRvKRH6eg HfjJ/wAQOaDFzd3rPo+L0HL3WuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KrJY3dSFkaMl SoZQpIJ6MOQbcdu3iMVY2PIWntJPK11cq88007BWiIrNK0hpWL/K/wBvIHGC5MNVKIoU5fy/0pBR Lq6UEk0BhG7GpP8Addya4PDCfzk/JbF5CsTEvrXVyJaAuqtEyg+AJhFfnTHwgv5yfkxrzLo1hpmt WCW1y87vBdCVZGjJQq1sQKIqU2eu/tkJxADkafMZndLry1ju7WS3k2WQbMKEqRurCtRVSKjI45mE hIcw5GTGJxMTyLDirqSrqUdSVdD1BBoRtnW48gnESHIvHZMZhIxPMOyxg7FXYq7FXYq4kAVOwHU4 FZLoNkbey9SRaT3B5vsQQv7CnkFYUXcg9GJzl9Zn8TIT06PWaHB4WMA8zuWVeUiP09AO/GT/AIgc pxc11n0fF6Dl7rXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FUDrGtWWkW8M956np3FzBaR+lG0h 9W5kWKOoQGg5MKk4qxjzB+bXlzQ4JJ7u01H0kgadOVq9u8npyxRSJHFdG3lJT6wrluPDjyPL4WAV U4Pzn8is0y3U9zZNDIqN6ttLInCSL145jJbrPGkbxBn/AHjKQqsWC0OKpj5e/Mzydr8lpDp147XN 4eMNvJBMjFhG8rDkU4EAQuOSsV5KwBJGKpi/mzQkdkaaQMpII9Cc7j5JiqxPOXl5721sluJPrN45 jto/q9wOTAcjuY+K0A6k0xVjHnjULS51zTooXJkt4bxJkZWQgk2jj7QFfhcbjKsvJzdFzKT5Q7Bj /mOyWJhfoKK5WO4ACgcj8KOTsxJ2Tv8As9ADm27M1PCeA8jy97p+1dLY8QcxzSjN86B2KuxV2Kux VG6PYG9uuTgG1t2Hq1P2noGCUUgilVZq7Ebb1NNV2lquEcA5n7na9maTjlxn6R97Ks0D0SceUiP0 9AO/GT/iBy3FzcTWfR8XoOXutdirsVdirsVdirsVdirsVdirsVdirsVdirsVUbuzs7yIQ3cEdxCH SQRyorrzicSRtRgRyR1DKexFcVSz/BXk36t9W/QOnfVqlvQ+qQcOTcSTx4UqfTSv+qPDFVQeUvKo E4GjWIFyzPcj6tD+8Z1dWZ/h+Issrg17MfE4qvtfLXly0mgntdKs7ea2qLaWK3iRoweYPBlUFa+q /T+Y+JxVMsVdirAvP9xE2q6W/wASLHb3vNpFZAPitTX4wu1D1yrK5ui5ljj3tlH6vqXEaehx9bk6 jhz+zyqfh5dq5TTsLC4Pa3KSRhkmT4o5kqHHdWVhv7gg4iwg0dmNalpX1Bx6ZZ7dv7ssalf8kset OxO/zO+dDoNYMg4ZfUPtec7Q0Rxnij9B+xBZsnWOxV2Kqlta3N3N6FsBzoC8jCqRqf2mpSvsvf2F SMXVakYo316OVpNLLNKhy6ll1tbx20CQR/ZQUqaVJ7k0AFSdznMTmZEk8y9XjxiEREcgq5BknHlH /juwfJ/+IHLcXNxNZ9Hxeg5e612KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KtMw VSxrQCpoCTt4AbnFWE+fbWa91PT1itJrmKOC8iuOEEkifvDbEKSFKkMAfuI7HK8gLl6SQBNsPXy7 5hS4f07QLaNTgg06cPGEYNGoIPFqElqkbN+FXCe5y/Ej3hWTQ9bimZ4LQxSS8WnK6fOGcilSSGHf lSvSv3vCe5PiR7wiIdK1g2/p3dncTuS3NhaTKhBYkDiQ3QbdcQJA2E+JAiiQUiuvKGtwkC1srq4Q UHBoJRKB8K1JKhW/aJO3sDm60/aXSY+Lo9R2fHnjkPcgP0PrtGP6I1H4SQf9Cuu3h+73+jM8arGR duvOCYNUirTyt5gndOenXUER4sWe3m5FSCfhTjyqNgeVKV79Mxc/aMYj0DiP2OXg0BkfWREe/dkF hoF1Y24ggsLsivJ3a3mLux6sx4bn9Q2G2aLJKczcty77EcWOPDEgBEfUdR5cfqN3UCv+803/ADRk OEtnjQ7w39Q1L/lhuv8ApHm/5px4SvjQ7wm3lS0vY9chaW1niUK5LSRSIv2SOrKBlmOJBcbV5ImO x6s8y517sVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirXFSwag5AEBu4BpUfhi reKrRHGJDIFAkYBWeg5FVJIBPgORxVdiq30YvV9bgvrceHqUHLjWvGvWlcVXYqtEcYkMgUCRgFZ6 DkVUkgE+A5HFV2KrBBAJmmEaiZhxaQKORHgT1xVfiq0RRCUzBFErKEaSg5FVJIBPWgLH78VXYq// 2Q==</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:b5010f36-c028-5642-921d-45ce820f1da6</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:02801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stRef:instanceID> + <stRef:documentID>xmp.did:01801174072068118C14AA247F7D2A30</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:19:32Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY2/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 2/Kids[8 0 R 9 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0 0.0 422.158 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 10 0 R/Group 11 0 R/LastModified(D:20170110151935Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/Font<</T1_0 5 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R/Im3 17 0 R/Im4 18 0 R/Im5 19 0 R>>>>/Thumb 20 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 9 0 obj <</ArtBox[0.0 0.0 172.8 129.6]/BleedBox[0.0 0.0 172.8 129.6]/Contents 21 0 R/Group 22 0 R/LastModified(D:20170110151935Z)/MediaBox[0.0 0.0 172.8 129.6]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/ProcSet[/PDF/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R>>>>/Thumb 23 0 R/TrimBox[0.0 0.0 172.8 129.6]/Type/Page>> endobj 21 0 obj <</Filter/FlateDecode/Length 287>>stream +HMN0 9/Pױ'A͂ ~$‚ӎf<S@p L;XV)ՀD6$U[YF<~$}C)|lm&\TdTܔ2((^BB/ >7C ,~ +XZ.3ÕHT%]DiQ܄y)~x+S'lVEKjFp|MD&JYR%j*1EHQ_Q@jcZt%& v�kk} endstream endobj 22 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 23 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 16/Length 139/Width 21>>stream +8;X^7_%"1&$j4*Po>!/7n:Xq,&,p.2L5&Mc5`MifF0^D_s(]t>bo)(g2"S@dE$>c6 +!:g^aUqQLV(5]KRVAZ2+N5e9r!.o7@3_:RmgMA$m1sa1bV4)EV2&"c7mb_ClleV^D +9?>`2~> endstream endobj 24 0 obj [/Indexed/DeviceRGB 255 25 0 R] endobj 25 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 14 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36237/Name/X/SMask 26 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�a΃8>WM3<-<S<A1EeOsUE4vtj2c6?~]}}>f>#m'kp[6ٵsa��bٍ_T*v��kcg۫K+?���\{ ,:$Գ,Ys?���^Qc:<|3��k2fpws3��;v^ Ҧ}mۋ62d)�?ACfiGRH:f +��_L4/ˎQϻÚ���hmEp6-ńxEfCFs(���xbW;eEAVFfC?GE“ ���i\Oo_C?|e���xMhA?%]{���p_indm:Q{���p_v Zb +zД]=���d(;V#㠹\W���'ihI���iۼ}?XfL|Chz7��@E3B<>[j:Gxj|rzِm7��@`l;V#dNi"L��� mU.0;Vx>\1W&���QX.чВM~ݱUk��x=&wYxj|WZR? s_/ ]���O|.F@KG\\2Ծ ��@k|聃L;Bzr]d0A@K!bWA)6*վ ��5zuشli7TZUs`ߙ'.wzᜆ}r}F@Kcugpyw��__1vege&V)krgOީo}| 1^JrqU78Gh.mک}��S Fb~W{mC];ԓN aU)ľqx}F@KcFnm���ΤbꕽitC3cNDã˫ ZDbh'V6���5h&-_ӧش(7|(Uݫ jF{IΩ%Ѷ=vA2Z %Qo��xڵh)B#ksUircauq+ Q;[gیqVݤrrQ���ZqD_־Rfw˒ +Lv1"riyG-?fWvuY���.mډAni>Va(-9<nB|o}em&-?^Z55j��֡|wލGVdV{jf#?JMS7mS-?|#Rrޚ}���V]Ă6ͪ7n\?! 7Fce1rJ@tY%Vc��4ٮψgxdm<R:!7Mbu{oW{Dⷼ3)wge3%PԾ��bqhWv_'VO}_wrLR,bMЪc.w@O��O=ze3[TmrX\' ~,;<YfxT:Ji;cЪoܔ?j��@l߳D̬_.12"Պ7P20NR׻Y'v?U ܡXI/QF��=b/Us"l$Ӆjt I['cL?U |{Jj��\7Wϛ,7%y^b>'7ȑ<?,TVz N>hIccJzB^VF��z<<,h[l덯X1~u%R!&UY.ަ?eGg}{TL��==Ũ.l>2r7򲿸}b jv>^$j7ٔhYc;&g-j��zyRrndwO-mހGw7-k?|ŊKeX��j-ظtIu޸"7ıg +g7~}GEu&P�d 5`QuMPâ4UQX + E@6 Lc.M`-Flv1 |DN"02;{y~m~:!EMD70]}��rKH!O 2vڬ=~*sxWiȍFa*m⇭,1}���пFv)vƼz'6ɰ݄$[3U-tɤia+?@?Fԣ؄[��wHOG8/'^ }=TjM(ޅx>ᩋmg<=&2}���ƌI֯9:JwEQ-jE;7sb͟n3!��"[V&1 ${vqdI{VG mwogu>!uM] TMo&,'S.��@G!۬mI܉c%νW52ߵ?6'JHvr( w>R +���1|agϊ?忨T-C_Um\p?z,+{ 9\B== E}Hz's]��!k dZVbe){"HrݼI&4ҷ!]lM +=; =|Ș��*&L${7lT9B&Iz7Z+N}3H72ߟ//lM߭{EMn:Np6| j$o��@гqzJpLʫnTcDQ feIL՞zEGHVRL*nmotu^]Y�� Z3'-H -K77D͏</vao|ׂ?`Pt.-6TG*zrÈ��,fOJ<mG/Tq~)U "\|Fګʤ!K?`Ptrtu}_-%6O0���K}LcpAgsDpx*OW6߁0o}HG=  +Eeu//͢ ׆8BmMM��Qj,15Av9e-znVH~}ieoBɋKsdn;EMV*wx'!2e9���I]M,5:;tIw^o < +6?` 7݄DKMJDw Ei)V &쏠Ā̔o)2Ѥ_eXIO +��|ɒ%ՓƝ_&ޣߥ ?_0U{<J +k"YNYH,/LA؟l&[xk~{o t:J|b��CƲyI˘e}z^~zE}OrVco oڧh ^g3g5X߀H <ywqekkL͔U���AKC,7rspηL"~@<zS*0[ȵ�͎fꪍ$%OdweZt\]ߡ΍c-1A��`$ @wܤcՙܫ [2}{鿼)a`S$Wb"/F-l|\J&Uuez���bkiՋCFχI-Jjjwbo ɒa" 6v,omk?3Vfn=l 1'!=&b2��_ΑÓSg]+=9^{mdXnB S2?@UL34"%͌8pI9L*nٽ]~R۷q��$kzAZ|,jQS^lM{V4;7ڣh `̈@VT L+}]ozUhV&`r��z֭_%9stf!?!MSQTE{v)jE�wAe종[K$ paw<AAHVR9kBxD&<=zwJgeI,%<3��zr>;H(#Kk?J0docW""yVBU]_];i0 SW'X莩 ӹ?5.is4[{p?k��TЄQWV6$1Qrn޸W^qX}VV{$5IFjG9_(ڽhOY&?XH`;/%9 }߯cL0uo`BRj,RjHԨ�1pA%(PYeo",4Qh7t}}OS;})ƛjp���tJ[;Q}c_ESBҗ!,7.9x9keaGmŻ΢N^{t\[3hGTȊ?/k0���tzF Bn DQ~|ro(9Lq.>/BNHhO5,G'wΈ""ԣӖm]sM$)mY|NVzu/m��΅vCV}NAICk[$|>PS>H57fۛ?.ёaڂBx&sYXd''b ��@KI24ٌhD τjCRHZ|,O+ӑ@g9YU8_Gp=W��LLiÁ6|rbEKߐ/94wo.jUޑ,/owB�FG%b {Ɠ9&mcϩa>B��z0ں̥hЂ<Eߨ}X~?A>m6.{FkB�:4 +N䕲Z~gZpLL-��h'"j^x,_iC<E}֣gg^D{IX> +J`y �-Rsef*!tDQ{��LjE"2;v~g$9W$]eߊNZX8j]Dv;;,] +oGWGm ̅<g5:Yif|ڗWȫ m���i'{^Уn<'7nڱ?YUxo@-|ьt u~.bo>"NZ;oB��2b$Y~|c'J/OT۷?j;Qr"|ԑ?.1d,JKT{)籩tU<X$z��e`}c)?%"d;U2ڻd ┸+, vlt u漠 왿_<N[0c[��@_f6nWȫ[ge{jn\(F[l+[�]B[s;6JR"Oz��+ޝ7:eS~y +y KR.5K Dg3uY{X-a:s%4?Ҳ”v��%F4 +623&"oԲ{U]T^uj$"{O)A�Mt?W=i8û|Ufk.�}Gt +aq޾QMen v|-|s=,;S�]B= +*j=ͲIo6)��@OϞdeQvWWf6\?qEs؜n<t M5!-8y*9-UFB��M^a,:{ITO8פZ>.f8}NkyzwXA�t`;qa׫ʾ9x^$!��ػ9B~?1[zRo\;{,tUm(q +3ϽMϳ=&R@Fs:I/=z^6̫υ>��(Ce)wϔit˾q#șbg[D.(a_?&K)�6+u't|uf]s ?Qs���u2|@Za(gj<6eߨO5/Z2PD!iDRVtt&s%?yڳuT֭:tB��3# &7(?˜Xeߨ+P<+r|X?J],|Vצ2W[oXA�V`FW&݌O8=I��tpZ[q!\E\ыQࠤn->A5'3,DtB�6@w8jh'��olHrwtҋ <4ONT,߾[P`;j%o@إ|jn ?�x{? ܦQbzR̰Lj0<��1v m\쬟p8ЦoT YݽsOs]7 BP8Ya�m檨}=^FIq>�@d˜h2A }aɞ#O9w#yB9,$U̴?.oesK}B[q6z?Y|&��t}W$vjSjxȟIb/|ƁvN gy�ڇ/*3{لhUU.X8b4Z\e( EDQlwg(wiMQBĚ4jq{ gJ87Qfϼ~C ZS5+ֽ4;BWD$+N`=�~!$}4fNsoH۪C#JlG-,GB6;ZB$q?>Lv"RQTwR-mz,�>PHN#aOzp +ICWȹvOأE7 o揚iyׇEҎ_ReJϙK/d +��Fr ߾}21Gܠw\}&(aт! X>@4"M=ڛ 1_3ޗO맻׏KScc֣�7~0J)=lxV`ޠ� arZ?zoV5E�`?L<IJqB^VI[?dz6��~`bhHlH?y)r +Y#[k<gտr'!bB8F_iA�`?)5wcͅYֳ�ؘ,G,<V;U+^rY!ݑ[h~̄ c-)QJoՅt:taG�LL6$:(м(-)Z7 ^x_>B>싡eȎŽ?PN+Sʚwa�<MM݇ hqHޠ|Q˜"$͎}ހB*)J*wf?>]W| ?9q2�ޒf?-&1!f%'iwĚv}kDmBQ㲐ޮ!z=+�}u䧟*W=~!K?zh �^Kذ))}g*~ݼE<g¾!$T7bbYe%O8Op7c4U+dM#a=&�/0d?}%gdtϝ:4M)oa! M3ɐ4?�x{?yyu]JU@ss�䷿L\WٓgJR_􍛥1ګ\>6yȍ}fžSh^A�CzԾ¯?-[5S\556f=*�YFF8|,Ho]&M+~79QO|>#@aOKs 'X$OYB.(OjC"uM*iK&W#ֳ]ad'Cӹ}Y͸!$υ}._uQ%|2LS?�?d .R֜Iou_]*(�zؑZ'aꑨe +qO}Y}DѲA46B؛JTҦ0y 댄 >a;yW$?_ؖ� &!>7Yɳ4t.*e-#Ӟ]Z=zt"_!,mZgM㬽#oPc  ހGUaQg�}ߏ%~] 3DvھQ7+"|x5ʔȜ!O</u6B�ǚ]4ހtb +{O6esT+/7~}­wemB"o@o6F@[0!W j;nOȍ%W�|B@[MrD} +KJ靇aяK:\HװCa_Gh.a?AJ}SkU@[oTB<z0cB̞lA?s7şp9׺:4vUfVC3G?,!%J퇚/buSU⫢=AcY @($s8/O8)$ ]}#=a=ш`B!P|POsPo[#|I#6t O8EuScc֣WX ۷R&tGU7~X`HnB2VFCIs!լW?,v;N)Q{ +] 6m1a=;�z7~0JߥNVf6<}P0oPM u^i!W?U)!jծٺT 114$搃RB8`*z? +T$D; !4oUC)3+ +c˲[y)G̱sXn@tXPG:tY Y:ךVU>n+gUn !O}^tp  +cᔲoͷ;9 U)I3o>jba27WoD&xQjRT/ 3r {XMtjӾx_?4(+ ÇfDQc@QTT8:b\cb n$YUPQ" + +6MomvnͱnԈhdfG >8L5 NTߧU~}:Vo@IFR$e}?�_poO{DkokƆT"*=uzXy$Ԋ> q@>qR `nfFfa#Kr5Cm6*3.5x,` + $ۙ +!{d +^2uA�|!>4d331t}CCZu{3B)p*=B3 qx/}sGS5?bqZ}[Z<;37 O^HWJh`}?�_K +, ]sJ%Ou}־I*Mƫ +ƛwb + bBrdN2qo\)Myqp)? !9C7&<OrDA]u*wAw 8dwLe/^N6O [}Bq8%ɔ$U[Y#e>K!Oj+8m7Xg'J%2iRWXm^&LJA.9*=P~yg<=J!JX/?u&"rZU7nU&TynNfP|BKsK:orDA]oW /.Ե}?C{o 3{SaoW}+ee}[աkq;ED!oߗMkh9uA�|C~,)X$w>qj{X2˩:Gz,DVSv emLAF5vmu^ +CA 96C:1ѳT3}:yJG@!=+4Wp!34ud4�]#>4d331t}o@{}8tUu]X|YtPwuu3Yf+SVwU?0|܃BUK3/Is5 kqH bQQaǧAMQ5'ri_-i]b6$sCa܁EG51ծoĚ|wBݲPt#Y+bm?�[qW hp{?%[m2! a=\fsL;|ټ(PmYN]MT3fD!Pw}(zߐgm?�1rq]BvDVF܂=|3IIi㕊s]w?veqb{5y n|W}CvsGU.ue1.gA!䏗RjeJi# 7?237w%W+h<z #>r]_i'GӋF\ _)lY5uA�U<Rn=9Or\yP[ ONf=Wf Ǝ''T)$_ ݟaw"^B;|r>:~CL>j$aS0=֣`(i&]כ$U)7_ ɷOwX>vB؟OB{%&NuA� +_._7h\WB'Wgg=[@opLXrG79-Uo!$쟥7"ZLBmk +Y+|h.}5u-SL6S+lXalhH~?DZOަwUÉyִ%? ~YABKThYg̊g^j_92=;YϷcbdD9N%AACNdP)wor@tEf[~܁B߾vHϨ^3|䓹95]w̏s՜􎕅*Li-[eF{-^qSl&$Dž9!vH%9 w?jAdQ"@|;:(h3ɟf->NfVqwU7 궏Mzh9SD]*KkWMR)$WhoqvM,MKTs}4*3.5x,`@H3B!|SiNIhn`]?AKCvM'!g9/>笫XGΙKo]*JO!yo@!䯗"ڳozh֙?oH=/sZ#ud$q׎qe oҔsm[ Oo@!=jA&'\yufA�wj0v?sHs[nz,ߒ$P!ɔYPW$=!(F߀B;Lrc*�z8$ EiR2tvVV%լK+ !B DrrNrN.'BH"qW.رkt+?<R%%Hޟm~*c/uc68(׳wV^gRO#-_#"6lO7YSQ<[;:dMU��xn-"y'UT^(qh9JwٳOƱÆ~ϫ.4w˃cֵY+v!CT�M.O\?JB ~t]0F1')]03B2c~cW1söɺ{}R^XZnpiS|��T+?/לto!cOC +4mauUgЉ9_O^tn^̙7+1ey w=H~�,1y aM1^L6R5?.sbLP!#MW5G3It+ߵY"ש4Q<�yPQ2COyMTieZt`^BGYt1UvS쿤k)BGYJלtzapԝczi"��Z6Ƌ+SI<{o{;o*/<}d|#T]Mm.3/Yon Ӟ_Xƫ��<xuP}?y8? SgtUg7LIeںo`ӧN5^y&1f㥛q{.s ��r[bT"B{>wu3V%8!cl^пAĢ37~ՔxB{Ƌ,3áA|�rk%wsU"B{N>n"ƢMC)sfp:5*? &7RtjZk(ud֬#M{͉op+g/HT?�Ђ-lyE<:?IVンI.ġ�[rkUQ;" +埻ˤ?fiȼy<#ڿ[`z!ΙB<=uBďU?�К2]G6AT{M| PzdGDfVB_$nZ~wve{j+ܾ57.4d߿|By��hQ۾{_7cCC~߱4b1USďv(- W3��'QAUBjEdNe��qiL۾oo!547.t՜tW|�� h̵9<>ZsG܍e[TH��а]˶ꛃA㣅!'e5']V?'�@9M׽֠Rht?Z䚓.XzV�qB;[AH!&GN/K��P?r˽9MA RK~뵊g&��YrY<QA RVF/3/&x��=.mRh v{ ��LyḾrY6QmA nZ-Q)3:w��ԍ߶=~.<=vꛂAHݣ1r\'ͷwoz�3#C?sR}S?{?|ĖXSaji9 +��jGw3>W}S?{?$5Mwrkz�!{HkDŽ}T-A ɢ&2iqS��P3 ROm$XW}K?yhHc\~?7S=S�@nLm󚩾!<y?|DL~WQ +��j/5dESo7'4a_+ד{;��e,po!"ޒ_sTl��&t\F^'7ECiQW7R=_�@UWz Z?Ay`0|SuH��UDN0Z@ u.oz�Je;9Avo! G&>b(9T��fl= Ӫo!UΛq{LƳ;r/5㾏,$��;AlY<IEg'XpA'8̛.d8/qiޢڟtPaQz�uGvD˽d7j,fp!}nqmo~QwTPwּ|�UZܽO <eWr⑸k<􏪚*ݽ!_�@NTn8,Y@ K7Vs҅~fm |c/*��hwo_1Uw*jm;UGnZ;wiY Z0F;eeT:; FZD%n?D.1s>?/9<|?gnf`w`d…M{ϰ?~' Y3Ԥh`��Beacw`HZA;d7u~W>OI; �@ޕk ;^s+4ޝ;>w?ۂ Vuj]Z-� T4֦U?Hӻk7냩FNz*ʯQ?2UL[?}Ӵ075y +1��;Ғw9IC4׽d vLg* <E mgUov36ª򺾾V[&�`kR*{^Wn=AVYԚ]s/R?xyFOsR �go&~;b;pg{mmѿi&>s쏇xH[6�`*Y[]#c]_.o9ǣ秎yMg��L#*=W:VAL +Mkҍ#In �inM%=+}v &:6?w��S4=yQn31)aUz]kӪo5��ZUzVAL +|S|5��Nw&1ܒ^펷;1)`UQ:s&�\'*v &6s3Un�T7vǜ Ĥ?c-nחgkn��Tߎ{ ^v'`hmyA~a��ޖ_ӝAL +c] ׾��8S.1;)Ĥ?-+sQ48\�pg+~N &x7//;V-�)ͫ(r'ax|/.eßӾ��ݿv滛vpax|cFYYUJΙ�+å7?;iĤ?iq~>ڷ��ρ}/.~FAL +teeT뼅rw��&oeIOf绤7ۉĤ?ܤ䅝ު<P�`7-uo lbZo弩w��^--;wvW;G`LXayO}�#3^~]dbRVzR�@[%VsvG;G^<ǢԾ��hS[Q~hc}w��-҃҇IY l1)wN̟}�ra,VVf?Ia:8}�ho҃kqڝl +1){rw\��[ Z"=l +1)X]5Jn=��@{вVDjwIĤ?c@dkc벵��r~];.6 G秎yM +��`;Ғw渂Աl1)aUz]g/|P�� 5{OOM &\s20^�� Xf sKk"1)2oUX?VU~�� Фߤ}wLzO{M &|/.Uczkw��}snZMsM &|cFY:o弩=�@HIe绤;TbR#b}L<;�@}4jOcµdbR',k[X2C/��xRfZZri5G*yM-'c;�'Ұd׮Yk:1)P>o}s{�u`eHpoP &Ѿ^XS|汵Y�>?Y[CG[R6̛��mհ²|wS|~8N bR:w�.}ٞ*Ĥ?tّ8H[zi��ueK094?Ia2o*w/:%��V}Y +Wv1)=ӗgݞ��Q=ߴv1)=cFY <o +��"=U-mO./ 5bRt^<Gg��v̑W[Ĥ?\S|d~��p/'14kvg*1)}VEZ>D|v��p%;3T?Ia꒭Q~6Vg��KzIIzJ+C8!׭;m.ڼ1a?~&Y{=��jM~P vϐA/yqE jFڑLǚf$mtx@3IFM(5*Dx@vwYϲ +`TƌTԦ<M>u8VA}_30k/+`{K ?g8G~&oq>�|v饄jwdcPOQNE/䕲?VnAMC{�垒^~p wF+ЦpZ>9�+屿>rZKnnZEEYy~ _?iuц_~;�顕 ˵;7?Hf՜;[v6o웯\9wv�媹)v'i<ּy3?*YΕNT!�@ޑhviy Vv$]uni@ks]�) ?:NޅA;>n3,6>ZEEY1/^ޯյ7tlw*X;M[nΕ o7zݼٸ6#�`/==wFkw`8_L&$2>6.";Y+;n~�?d^m]>י�0LuVzGGm9AB)O?ڷ7_5O_Ove˒^1v7�ubl̀#wbd'Խ&m~ ~O��󔌵/_K'kwAJO}asb}]Q��|udZ<3t)�9eI[WpobR~rksxqQ�Jý?Ia8u󞒷_+�}U+&w8sHiel.,b{ �\#'[/cp>l 꾮J.�s]?4J`hwYޚ �<#)Iڝap虃=v-jw�y?GDP?bR4yӲvA.=�p Ie?1)gj5[>Psg�'}!2s X:1RzeBv�BU q1K#; AL +R +3^�%}R1AĤ?7>鳥n�{SzCĤ?o\ւhyK_7�@D|hap{Y% <_G� t䏴,里-^ a0o+f:�@\9;95{BĤ?1ϓ>L6HU~�}:߲=C; +AL +&X[i~�HTg^~(<1)Lg�ʁA?>xwkwYZ$c�@Ҥ AL +<?Oi՗/@�@l澥IhbRfee֝^V�MLZ;+sW"41)3lT߇�'^S:U.Ba0נS[^݉�wH@oBаĤ?̶~^;A�G|giwٺlUXUݍ�S}`vr AL +| 97ݏ�G?41)Jevs= �h8r˝{9hbRWJ|\57E+� rUr;5h<bRc;[םIkޗ�Gw6txlׇiw Gh3*)/;ߛ�'w:W9$]cиĤ?KS�VΜ~Kkw GfD~(R?�Qdqڝ &~OolTߣ�-[sNA`Oo.BѤQ] +�IQ] &|2.s�^lokwG4u9Q٦! +�7rn4-1)6UV�];?PhzbRXlgMޚW�>˝NeO `@i[%>cYU,�ǶgVɝ{ &9絻�p˵q/}]=bRiyQNJH[�e=̟P#AL +7u9e{Μqv�,䮵r>kwt?Iavc3?6 mi!2p: 0ld=[Eq/,2Sa< +QJV(RsN{ + h, C]\rOB`\K>/h雋u<\7n �b}Cزb�}bR^tH+(/`{zUp$+=\eĤ?u/IOrvk�?Z<IN3?Ia=\\;v= �¾q82ʮ- xg�ow7r889qj[~z}jǾM/=7>u<ZW~q �&mo?&+}YĩIBlu͜rRDK"-Wcn 2Er$y �&rxF܅} N̠{Yt|7ɨ:Cv53�HUzvuڝgb'&O5T{>ݫ?DEu;ɀqVXSqT{�L"z[qJzVVL %EIO+ Ѷ}Uϛw߭c#bץDlO륣j�`G^{]7fFhw=Ajׇ7ݧΙ3`J3֎dd/xf߱?Q ˳Z64B�>)^p6DEDtȵ=-sٺl>;MILTT3InuƗo@(>/Np6</du@Ё~S_>%~W7|iw?p;Y>ͪݟ;NPgHjw;A:Jأ#zu>={o{7WLSc]G;7Ⱥ_785\7n �R ~hrA0No2y?Rq?}~Ԟ~v?xPBCtHk('u=@(98DzlϹoJjw:Bit숶7Ͽaxo[o={w &X;NJs�җG +IJjw9B85U[7o{Zd~tI-҂guw.1wa_9;W̘}@(<3QzsrN;AH+ga{<5T{>&=?߰?p7VWo.H{�샵ݲjKvw#?IanO~W!oũʩ;�8㡚Sҗқݍ &5zy:;�+KOJ_jw6B:CzEvlj;oѾIWczyFb@g:UlϹ@}�Np Ͳ7ՕKOjw5B:E .{K'�Iz ␅Uh61)tUmҾ@ӥK3'l}bRl ˳L}^oi�῾JWdjw2 &;edG>{p;��ӡ%dv' bR +'Z;M5%'J'�;'ZVvbR*ҢgBuo�_^^z/>kv/YĤ?Еo|R;G~G]��]IzNnAن ?Ia+Ť|%^y� +M`{ν+"ݽ0珷j\kKO'�3I5zNJIiw. &06sVT\�t/ʓ~{6s] s?Ia-z\ڗy~�t//641펅Ĥ?]bRGYEymO{ �p7Ǥς+ݱ0Ӄ-_޲*�NH5֖~$}&ݭ0[)yӚmo�iZ[ =.%RSĤ?avI/]>0a;�nGAL +SFZgTn?�t'ylͬ)\)=ݥbR?-*W6ݟW�fy+?+P1)hDkuW|r�#nM;}%ݝ?bR?FlO˿2�О,YQڝ &'^f+G'j3�zWH~J.ݕ_bRpUbۿFh7�@GH/'iw$Ϭ'Ҳ}y@xj=6J;AL +N2pxs;8흦�lűǫw# &yb+=3w7'C�!#Nż\^>x[@x?KHiw!p *<{͋iG�K!; 6>݁Ĥ?T1µ�f;ϒɪ)̈?}' "֘1ZQUIbd`MbUUWG1ZCDj'DC\]ؽ +b񁚘Ī ر3 v/3w޻pAg @g(9WbCڪ=(?�yjbʪ >�B@ɩ?N[k_jC)� /4W>Qݤ93=e +Xoom9gU.翯�<<抍Biu�=A@ɩ?]DeLgQS; �ã)Y4W"{< JN$QL"[�ƅ4OUm�A@ɩ? bƒHhhxf�ú4G2 4Wx6 TnGڊlmkQN�{iUM4Ox4�G TFmˎ[ųF}�{͍2Hs,pJNjB" +Esq�pm4'h^ܘ   +Ufn٤c^�dY 47x.B@ɩ?gEzԋ{-P{� 4hNIx(9oXP\�@nCagB@ɩ?@.֕gWx<�6\/N=�^JNr�WV<UeM�/ +%B�9좡}�Ⱦ$Bi.M�/ +%B� fٵLo0Û�E}O]Ƞy{&;uzmSQw۪L0Y u;fQWI;Hkj'}�*�Y_?PX<J3٪V#7zdž.]=<WbCXMe]ދ�``QSZg@B@b͚y֨7Ҕ3fO!Jms4  Sv}L܇g@C@b)rw3Ty9K+=r7N +YQre{�;/Kg@@@bSz.Jf|m$?f,KXiIt -dVMݤ_�[GEaS5�U6]糝H~#gńELm՞ CCM�bUVH(gPOOtȍޚ‚e+aUGWQY1gnAdRb h}CK}LL}{� 4@ׯ.evO||NzL:0/e,+Ni.t/l~i%Iz= +�t>~=S�55QloWqpoUPHk!r0)?:GM{*"T?0Xt2HS +} +�CJ}+X+Ǽg @NF{.+s?Yx(_=#+=w8ӫ+"\mu/%߫�.` p&Ӑ?PVVRUo~6f(|5?`0{d7OW�=OS,\&-l(W KSh;S(#(ұ=݌]֬Q5OgӨ/?kkϩ_y �?PZ fnjeF=RY �N c qv߷�M)?dԟoZ}V�S9+J?_h(Us^7Zk;CGI2nu?ZT}Exu,Yh{)lچT +">wOʓ/v;:woh=ux `[K`"{`S9+Ī͏W5WfYU<sjX5P}UӢNbQ'iLSWRwjc(HʫȡkR~}&`RnJoSOD|}YIKލئ{E}HH}{6�S9+)?yi?N͑{c(+.9LN$vA?ح/ZxU6Zk:eK"D7C:-Ko* +^}~Cwf὇ 6ߝ;nҵTq�WS9#$iNM"33 ;c}DunpDZnsp52 %p+ã LT?:c˃5 +%kc9YFmk*r_V住 +;?C޳�U TeF 9Psb'~$m<26~>WB~C|ޜ=h]ϮUdv,]߷tY{8O<@:g,CӢN);{)_)w<?4(+QD+.13h`JG0F@Ui` Moy~D\!Jq aqLM&-Is9U*{}}ϑks&+4Yǹ:#C'.^I/C;@oc?NR�d _vyg%"yiaO hnI}y]XixcUq}N)Ķ{y[%6_<'-]W %-0]fpo|9F 9n1YD4 U{4} ,@w  !;EbX73ڒ@ozJju-kO+ׅ/=6ֺjU#9<|:/ŏWצJN`<;bub/ +ԫk"@Ow[@_O:+?0?eiaOOk*x>na ݒ*ҔǪ$߾*(Kt8O~Hוxt'{{zy(` 1^n8gXOoCVϤqqg`)L!3#ueL_`qޯb(36~Ȭ,q^$8oG_KLU8/\?bk͇ОqJyNmȵ@s#[Yu3 AF+v +i|K  !ň9VBU$؟Y۫ 8]z<@8>'k͵%s7>_ F>]ŏz6y-O[kOV*!^'Ywg9]Wk,>AFm sAeNkpa8ښF� !Hm5o@cx({sZ^%{4GWv=ǵOMO aNp={L]ɼN cZYǵF[o1\t<?2~S܊$o[%_ǹ:#~#HQdpXt2`)F,ݷu ʒ͕9#fNgϥ^[nR-c,<Se:88ҕ)Y[#jԷwٛS* ykC*nc7f9 oټuU؞&+4Yȅ:#᭬ '}; C[2@!)$-ƻл;Ca IpJޥ=Gĺ) Fbޠ5tx:p +1>[R]/κYS{Qef!媓_Kybj?&>+𢠡.&Bxn.~LM[%E !H"qL,ttU~~#~A6av cC m"h G3poϥ6i z�]DgJ[2A!@ G@AL.q;s^!-Af/hOD !^~56x } 4^n]yPemM"@!@ @&jhot5{Bq5pyAu:E +?0?5x}Xvg*ΡcksiA !q-!^My5ܾY">A\0DR9r5"kjk"d%s~Zn-vC%X [}<%g,{735? +3"ȳu u uN[k"T`)hV)& @;P>*1#u%s5^SEwu51V�zTq9~ Ce\jzDȠR `x\ d=o||K8P]nUhut4csu {_}$ [_nT +mM!� !;=XdhPȟuql8>y-椯ayp=%~@B5PǴ ?0?"X~x˪Fr$k0$d +xS\U7\5Z]ۨ?9:r8"k*^#]pvu|fAcVZ(Sh9.ka ݍ&W{> *o?gwߓ|ߝȍj^CNg8V +r}7#a xm#-O\Q|<}MVYl>^$߳rt|'.Iv^;Ϣª91YĀ߄{ӮNuѻ6h.{R/i\.x:z!y@!pG\<Z~3@[[̒F}.5UDHZ[BV2޾fKu0(7٥;2{/נ3T3kꭵ:6LluFgm/KBĘXW@a]PA(7\v쁳WT4H8Q[/ɇdd&鷞?fo]}8Ͼ{s%.6]lK!\z{1&~} ٸzqq~c{oƥ- krJ.21fC[&Txg1:=G荆 K(\ ? Ɲ Mso~\mUfÇp6e|!4VYs '<T8)ߩ߆g x{a]{,@9x߶3-fkwK_Ng!E(EG=kQfZKCU +C߭muߺFU1sÓr\KE>n":.y>}yO{G_.x3ϣG|jjAu5|콧>^ &g1Qן{j9 }).o U<ȹKn{?Vsj-?\ޑN@;\uuT/KӅ""czQgox<ݙO/PAߪ9#U;ƪՒGt+p3O"8?YRmp3T=a 3E??>y<'<S:͈y{j-uf{rMCeȕ>6igl9x]ǚ؊a-Nǧ_'g/SQKAv?(B)?Ԗy}yI9G6Qk|V踁y~^|\LY@６T{ gw7&>=\S4XʱS6q７oV-L X|<m,Sq,A?Ž*<faMN]OV?h.C&uw]4c9^=48c1K[ ""_|~w']"Gcs4|+p|~a ]p'֥wW ͲA{[<":.+fS׸UHXy8D^ʕ#N幑kipcpḱprloc]Y3Mz׿M{u_J>_7y uC E(E|eȕS;{t[BxS3\nq X Cнu_D WPO r`e,qO?J<}ps`? |CM@g^2d`cj*|N¾G%B uz{U;ֵODW?(B)?8qywmqz'ͽ{D=?vK%2x{&f,$#"7gXC;忏R-o y0V.'kc&͹CJn�Koc<7"y{$ ^a]{ ӹWg>;p0iu)xAPW/uq?+*҇3K>T=(B?h*f+"p-EG|zq^赵`hb?My-&@NvkټCNcɇǡ/< lͥn- qQq|yXyːl;umݮw5VZn|^t7+ڲnk_N_g; cWPOٍUQ_k !F8kvQ[#-ۿ}A꿯mn9z|ßyOag?Z꣕=$S-צ -w}?ouJTq+v(~/mprںܱN<oOyNq_19̃[)ׄ'IQc,A{ K5>(Zq2k2π+g|Ng uzb]A E(E0P[DTh,x>0.m gMFsp[˳.>"{fmU-FCZ& V4 oW4ghj:HYExV8O::>7yKJs'ݖ uúv x8?(B)?C6Grƚ mpͲADBT*o;'5{P#89uhPRf-<g|vk<!aЦY\yNR(d!Bž&>8O F xt?(B)zD(2<i.P2踂==1Ӄs=ψsoՖ$! 9GE5Uw6'OF%：j+A ڌR-m D۲}L<>8G'Ui8o5Gē" zcԋ ^* +9`G͇;r8 vEk P +]FsnԷ?ԙ� +k+j;] C+ +"*xY"WTD)B!r @.'E/KŪۙ];-^R3vg:mظ4!Yp57 979뿿Hϻ55u;18'A_@ ԥ�W^nki:ԕ}jX0J:ȏ,MOF A8!�g\[?`2&V)h.Sג_{oc| ?|"~f r?3AsK{' }n:256p,+w> !CWH?|?#'L @d7ʬ�9U Wʶgw>53nkzUN'~ B�b+O["ImЪ[]6ϟ/f#ZC`T/=? %-!9Igt:$i7nϢQW/M}{?9A +m+'LdV&-LZZx,9ydkSowz),:7NQOsQ7{_Q_7I}1A}WQxDg�pf/% &]c&!:F@ׄۼO}r^3N7'4\+pD}x\1V@}S>>5ǧje䴨>3ğk7>#�>?xx0x1] ֠Uɘm"V]|V~TWrY~@I^z^GiV)SÂQ4~Nu?S_B}~G! +z3{cuƄ/:/+II l_g/=}N^pVuOg6,n+榌?' +8h<47h4^7@8<v !a>":Vu"7)Zl_gί6Z̩Dyymޤ:nkZٜyoNx3yyžּPq3I :Fw!x 9g𲈄; Qntl֔iVǤY_Ѩ٪ u{<4q[i{BeVQ]YꜪLBs_ʿwܲ~3]Xǘ, tݗOuP=T<;i:n??!x N?:s;{ c?BVǪNF8EzH&W@+yU35@R>̮8VSj%H7􊶻K~䥎s=O՗sVIݳ3gZ\Z�[ 6E-sxxX]o/ML"cZV],eCAAm�8 +{c'kq9R +An-<d1eq�AAPhF6�A% ⦗Hb_Bt 2������!nR{|1Kt mR&NbZZYd5¬;F6J������3(sa-sL_^rȘ;s;M(����������������������w妥5pZaA|^/ݾ}ZRwEUsS2Ν7%7h\iv>>.YSƒ3WW)kU'r#ykչ2ex&?yIYc0z^RWVɼPss8:\1ӗg)o7|з 9ݨc:W*/&mήT1+�#M%UMDB[wc7i.*vĮuODksUn +#O2pįJH?ij_> yט) +6עCc)JлM<x\j?&2QLZjXrF-צ*Wgǟ."u@c*̞6Nmi' +Ee!|^@ l8yGy},=Yo@cof0˵oŚt?Yq|MƼ 4E۵,Q%GuGXPk=ǜ?V, {<B^ڮq5K�_OD{o},_Pp S!xʤFTq}y;g2Of?Mǎ@#_1)]yiAf}:_] zW:"ޛGYa+i͟ F5^qUWAhVK +7<v<oo6nhaq}cع8':(ߖcuL"e%2iKĜ?o/I*}cJU˪5E-O;$\%.j?/YjuMnZXʞBOlr#O7/[n;ÇTȍ2ÎصW4{Mۖ#:,X]KτS8Z[g3ɼȸe+ܖ e~VYq�~jX-:K(s"Ɖdohز#unfsRB-n  f4%S\X2잻 Bk+yܼs\pKΑ1SɅ@{ڋϕf.h7˾߸g^ݽ{VXƭNn͂ni0$̓[c .37OHE?SpXG?tᢴ[k +8Hth{1SɹX{ؑݩMk;7mf.hx3Ҟ* k`VTA8tw^5c'ަ7r>|дkNN2lxjuڣKҞ隷[{1TXjݚg3ďn+ue˓Vf,hG?O}?*Yyyw:ڎd<9ܴ9(_XƓsKdGm%I^"gNԞ<y*GV,^zͿ:z(sꪫJ|[nR^3SH53;1 UXg?uwRw|ؑS!7+'++r.~lW;GƓϋϕ熵yE{Ol}iXuk {1??//T|>+$ր6ܼXC+᳌J¹%q?ӇƲ ]soj&kާ#{o-{89q-ϭ'kV|c92 + +ƢӦEζh +eg'd<ͼȺUO]b>*s{mzzN6FCG2 wqG~j76 ɘnmxꪫJ~p蒲LMܺ-{3$Cb }nMΙSxwR_c_lwtϊ:|5oaȵaK3"O\LwH+vGxw 琪͓s';F_I[u(܇3k57pcyMEŌ7Eۻ ݧ]_\2<OL%ى=*]-uO-$eq z:9zW==T:7X~|XUXPʹl2Z9WӖ5ߎďޑXީDq_ʴ2|X$r&W_c/}yzNN*xa۳9Um=(ωfܢise ���������������������������������������������������������������������������������������������������������������������������/�6\ endstream endobj 15 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35074/Name/X/SMask 27 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�a^:8/QFm4(6N-iB{io1QCS`$iǪ,eg9]dqbZtVN_vM7P7>~f ;}^C,h=zUo}mu��@b!ڽxvK���h5,_���hy9Zb|B{�� Dst{]ۓV\5�� j-]|i=j���hK^N<5U ?SiM'q |ul~uO��`^bdb6/-Y*:<+Hu֝2��B;-@IJHV-CO~|i:+Eq\xG��`X~"XXWeki]���ĊyGC< 2��� 'bPAعnh���WPIYW˾���k$AC~V=���uF@h9cxnʾ���>;*"q e��)I*"wƌ1o��ޔ1V<T̆C㨴}���4QU^-F@Ȩ?;v}���4-˂]SbPE(k3z M7��@z ϭ * OO,,���S{L̆d*~w(u~Oɾ ��d'vٷJ7?1>vY+Ⱦ ��֪LoOoV0nyw��{>?Q׬iwߒ}��3<uZ?T٧��Ri<w`Sn/6���3mb-ݿQ?xVmx>Vo}��vض%vvٷ��Q@wgwF {u=ٷ��Qos[C@EǦ}_͞>Cy���"abP@xCYYd��`&%;vL ƾ75*?J׺ MκS}���f_bmO?C<V%;/˾��Lm|M}w {]+~[}���f"Wj9U ES멳Rd��` +Rfwن)T5X,ػ.zYv$7��]&5hF@UG4oxnxjse��`m v jOx@w]}#��Vw6dT2T*_ 7��]PPXdΑ}&��"l]u$*?R ׄݻʾ��@eə&v?#n{72d ��2x}{?E@eCx:Zj^Uw��p\ld(pV(hʾ��@eboqT7$?T٧��(cW'Pp1'Uϛ!V���)O{m1?⶧ih?P*V���h,;>?C<nCٷ��(u}dh.?`#\{ACT���* +2f0XS7QNڂ��PJE-ZEf0";)��PeoWJ]>?x﹎Uf,嫿<S���1I(Įwv?v4>osm5Mƌ}>��@Loov\\JÝMH#QbﶬԴCs /Y���haLߥibWc?i$XӚkgdi ���1!}"|{>I쩏h&vi$_\=_Դ\*sǍ1���K=n[ObG=k}5㝗`T3OG_*k/ުi۝++Y,s���D%t#%]:xp@4Z:7U yn= GϞ>c}8qS#3'ux+i��^zJ}rPGSXdUfvtu3g /G=k7+4Wr{IOx�� %%$hb'_=,|gjHȮRrY9랰HI6%riRCIBZjifJ3Jq]v]g>cҤ<?7g>ߜ^f(S֊Fh ΪoDŽ۩1!ۘ?nDikBf9���=i圗^OWvSf$=.j"Խޘa=ڧھ?<# 5 ����u}Mvuvvz4_vZ ڛdI~wu7(ҥe wޡXbO\䊹Y<"���@yH)OZ]r~pW<CZ֐ŲsjyilIO_kDeѥ)Ghs���5ȃ+>uDff<e/ʑKF =# +YxnݻT۰ykQ���E.zԙ8GqZ2t_Lޣ̤ĬLi⿺{mc^/#|w:˸\>{΁���l%et=Ը&e흱!eFe$]׿Q2NB_Gv7LJ"=vJHt#KeNA+���-FvDN҂sϯa8WZjg2i"_< ep=oQn|CH۫ϭںݸ ���&W}'%ARC4h$ዕ +ٝi4c !9*%wV_Orew���ϦĹuوs'Q )hm]VIXau?xl +rwū۱yD΅fcDBa}����@O2DqB ֝x']Q]ɏG~Ս?x<v{n.x)+==M[����h-ǃv<H{[}xt¶#&?@4yejnYӈ\C}}m���@RUѽ\U^:.f<[)[|@(O!\3m���@SYss+7<?@4,=݊[t+u{W]r^NX)}d���f2}q|c}?@hKD{Jwռ۬>2���@mϹ*iA}݃s磰PK�<}6̢3|s:(nv;[ƍh ���T7oưy%|tz&g,5< #|;_tW^ +1f ���ha>8<HbT_.pr>jnB�]Kq|R!,ysc\ud ���{|tao%DvFDB�]{ +^.<wEmx4XG���hu_ -fg+5<aFe\kdlr&ܷ@g���x]kp(ӷuk>zi*[.i/;T_m^V%WgU>>���QB ]f։,tTڪ/ !Cp[:j4ُOs&ڑ)2c&-=W>o`piQdlhϰcj3I?۩!݃s!gM*%-?:D iě^MsIFt#}~���h>==jjF-{i}Bl_,t K<x)ءg*I$ϕ+ eJyu<*Tq>)w)q2Q1:-w"c?δ=q. ID{T" TBOZ)tjL\쎹Ygm���zzB!u61=v`:j4̘I.<<L;DPް/G*JW*ĥJv}"t7ȩ<"0 iz%/~\_X.?fؚ<HbT8@BGx;~S*mH t Q ^Dr܉v#XBBH:=RUݎ.x|E?_LgKdcD5#kyCϓ́{8h:S.i1d!xuGeN;Rnn���?} <b9NB ?_!hn~cB3#$ rqR!;)diW;|P̯EZ̽iǙ<Hѝ( AT(o}Ϛ/ +=/raCy ɁOZ"O.ia9ħgL8Ob"(.(2j-`Q@TD1 # "ElȂ#@X�ZGa,Rq)um33`R}}N=y^}WE;MD\v.c@ B0~<̜l�FsT`c7ـ3zzN>z<lVNv)/.()̭(.<v6 >Qa1BzlJ9n?}^:c�n�`Κoaz';@ ϧl//~{~{Wx?i-Zx<tt`D0: L ``tl2�66;8k'!N<~|vvLKFz6̼2zY'氺jlodKU ~q[iC`,esiKԧ\3C\=H?4pQ?c]r)ƟʥP $(&gIGokLM h(&8hi.YS``j4G†b-د�N֛v+x:�_ݸ@>Ӌp|C~@`'dEG^[]x&i=#-Ŷ\#+;ӣ2/˟_x1jQn [Z6 +knI˺wXmn'T$ujV'MIڣT x)}S/׬<&3=4!Y�[~�WX�ENwkL|16lQ4g}{{gk@@ 8nLƳf*~Jj7٨? ֊'%MN;n}*zI~b%#=e[i9z^ܯn_\fT8 [~G&~齶:j.Ir{n5P5?kI-&yP5,?Fy+ޯ&+}x[ivjܽl~ǂ-3j6?嚑-~H7L$>(pƣ#߮>�w=̫+Og;~JBPW,; E軫yזi03a6Lן &F`x)l^k {6o:!60P/5S/)<ͣZF}%S(ȕ=pC}Wч.ﮥ'MI*oPC~r{ |i:9/6^7)w5Qyy3q T~6tH#G_t#�g8�n#tּwaSHwc~yPW`^a6{G7o 5}I&@OgEKTvOS##%ě3YT91|4V'V1+ 㨃c +E7n;XO}3#=*5!4ܝ"t�)d +�%5yhha>y qS;ė:![kuGWQ יM@?x<L"M�i3`ZcVN'8I =vl-6f=%ٺ,;soUAIan}E@au jF[4$ɗ_E~|@}uM|\TAtU/ȣ�$!�B?�'@ @ ϰW,up:7BYMzl}F[?l-#A _ZfП0 ˍÆ~pîd܉ssOڱiY^F,uW"ؽ^O mepC,es`VSpVH7KׅuCͻ k0A@|8l~E"߽EN�SY|Z@hq0]2̟m9 +<;@ B<v"B\ +zJui9ݸOźq\m15F^yqMX\-&I0<ܲo6ӟrW2O5.:~iڃ;I�R: KBal B^E@[B o&/w ?&<H$e05fcng~.P/oh�RRH':?7#-Ŷ,;s/ 'k!^*d։9.13V+zV3:kiu4@su="B!x)}5׼>oW]B!}C �1�x g0A@|lQ\y_P{tTm+nW:Kҍ<%DRHGbI6 iȝa03jpL# :ݶ{)<K|si:n~}/ggRD k> KbIFh1X,X6fz\\mTӌ ڣo2E/f=b]DOG(έ0*MB뺈m{O8ח0X.[t.\+ %z;$~Y5~›;a1k|(@}�@@�{#@-}Awyw>NJ?f:_)lL?a7`>( + +0kX8c&͝VrpZ v4_G'�W7yzGj|n|^Czx،sb\Le%''(cFU03SX9Zn^ E<U!s}~}X/,Ƚp2E&/y|.:)48«o'Ys zjMLh$ +wZp5FZ~orwbG��ASÚg?0AH<Hͳ}}6�HKyGl0_^h4PS]0q>O2ꥦ}Xؠ=ICF07+)#.֪XN%)?xeQvA Q&*ί-!uhU6Q#񡬮iHh4{ <\L{&WMzQ^WQgu0*fn'iy4|�*=�_aC %Bz /'sfoB P6sv۳ hOUBC\a6L3 +.w/ @7w ̉qy{nig +kع "C{+SDkO#MQҠ=}dRo/qY+8Gduw +3gE#fw~ܞ;Aމ1#_.�(v�pPh?pQ}" C%`0Cu)Kْ+ o}uژS}Dd:肉d0;l͗-M)W3>daqk3Vrr_['.@@tUesMKzEwWt&qy$kõêp! 1hWm(w;mޏ |+R%Hz q?;rC&O{Ɠ> +уSPo,Z#F0UUPVTl*JJ {"[6{^j ++{BVq{ NDFfZqRy1ҢrDz!u] s$ƥ[UκFwch3lۛtWY?-vxGdE +W)CO�90cA!}_3`R]P떆'iY:.uFT.�5k!]9_'%"8?>nmIFJ`eavǔy心mٷE+B>S**ίUpeU6Y\Wq2^^:ݏYDOJNr-N?8qLaVv5+[aT%7k{YwnVk:ć ^H¢e-^&^9UVOO-p\>�A�5;�N0l#AySD-~ڗ?0C-T�7Ź}PY/wP)-gdƩ=`2jxӊ rG~~iP@t.z;s\]ex4]ڥH�hhp1j2܈w5ӀF#L'it/;={j+7!5$=Vɤ;eRM+;CYּN&j'qYFeqpd]K4s~LWiҧ}=o9p\篧ݎ  #K8aNT%P +1'lS\6Nj{ >Yk@rI Y}l(�aC;AAE&q5;wj?Il>wZg~i WdidMWRCAZH?N:ŠSՕ?0C)?8졃9M]L5;OGCWsds[}>Nti\'s |>̚D�  s5eP,`KL{3l�^J { g:_{lS,L L&p1`l"1QٱnLq*'LZ@ZӾPp*R, )0 K}}OHO$<(\m\_ؔ��5I?"}AwH.Z:0M߼ pnp#<cnFqֲ_Su^?cs��;^"dja�͞ NU3FMٯ͸-3;rk{ (YhǶD,��ܭò]~9Sob! 6 e=I6S^wߣ]Ɏ5M ��k;8)V?b\98n'msRwho,w|{u+ĭ��.it;~ N yWzOmgUE3{w5ww;��w!}$ggv7bjU;ȆPa\u? +/z +��O# ^ݍih?eQ='F��$=Dn NH.^T䝚f��]25%-݉ĉ<cGso��._\FzCމĉs}Aw��D?r]A F 4^=}��@tz8y"=D ?Sc! ֘%n{��MFMwvieA6.3PzpoLUaACn1n_]&��gwxT×L@bxVs+RS16,ذ(g?-y[%'o��p6y!O?]2o?MiMl{cbmeޭCn؜N~ ާ}��35ƹo6;va$+-[ |>6M@kcZ}FEwo��p;skC#;%uӫҖ4XEc3Z}CL)6˛S��pfHxB?[-[3}ɾhj9;Oa2g[^F��gX8 vʶ2v_n-?c+ƶx,gL8o��3H sʲ㵻-[53[~'[j9>ipo��pkG,Bzva%.wzS7g_]=pō^\;- טs%n{��Mf~vǹLzX-Yif7}>?9ȿ.;1>jgOpɻ^pto��ʾ>+Evǹib OvDS2zTnܰVi!o7 ��[m5va;~f| LK!??[>cBvʃ<=c��Fo/A۰?2d{ *,9xmh7uQwo��cC+ D[?w><G~��{ =ŏkwqt>aO_<x ��r/'; Dc?Dz٪_��U Dk?zi8c-��pIGhwu%fnS=��&}!,;{ ;gwO��kR/aW]A9vbS7 ��XWÐ*).xY6ڷ ��X羾+vwahGC _Wlz��IzB_ 1)Qo/p7��`-i:>Y8ctxc5;PE��kHO8.}A?q3=+@cL;��a!`FɊhw!_)#̗ i:��` _-Z/@zvWau?Ĝm��H/H/Q|'3ˇgҾy��@ו#){; +o!TM +G6Hy��:* #_Pnv7ars?$ߧGh>��n !Wm\P-q?��pomJ0"nyw; olj\Ժk@��po]M(=`Xhw!ߎXS/Xzx��ޗ9!Ovaz?Fgl'R:jB��po\tG?:sF;. 8uQ*qڷ��uㅡm!yH[CaK�.:kpT-"NQi_P. +$8V8  K @ .H油쒄@ T@zӖ:I|euC~aq?"c<DEFM��VK B:xѱ>NS��֐_0Z X}D-y(+Xr@6�[|MZ@\2] X}9'G��ps5b[myo!7峌Jo޹ I7��\oHv +@k98vU'._'�qÐ~սo !.G<iTy/|ڷ��_[݁~k? .vb}.>/�@HKQ7c1~}7��M/͑^o !NCl,޷=os&��q@`ҵmLK^[~/Ӿ��{vԤzk-t-v"ݗ-r}?�@Hz\zivAHc3_9<#Z�R9.7/ ~S?z?cمγYqw��Gz3_\M qgYڷ��_SJ?[AHbc8.}I8{ +��:'}]W<ח~K?^?3[_(?hT��й%HoN[9@ 1]JNjT��й#9\B;շׂw��\߼c#禯v`ҳ}D$Ndm��'=wׄǨ,vbޮ5;hu}_�@{9cJO۹fAHbD$.&��k{H_k<^{wd/; ��Ψ3Fkܜ?5<>4iZ��p1J?KOkILR)}0 +wnefraw9wd%ŹC-��v]CzI/:ombƔfK/w;+6] sʕU3 s_<(yTd4h\��DEFrdT761cbǍM?AEۛwv9G{ Fq&6 �]M}бo3`Pʡ{G{O3JJ]ͧվ��թJ=o3`PID~F7oLϰ?wqr�nVo&Icf K]m> ZL7ŞϪҫo0��vsz[,~}L0Ѩ߿ecחΛcm0��v!+@k̄AnuO_~ڂ:|ޑCYvFq}<byN}QV}�5i=)=05xq^ kC\ungwno〻"7?cm״F�`ufțmiƉo�M7Č6,7[n>՞GhfE3kSJo2��Vw.ҿo�w-}%VzNl=AѹĜ-SO[* �UIJ߮v1[mfrO=m|3s ]qґڷ��~3b3“ne>D �HJϾ:M͊AǍ _>8ґ7��԰PzVV͊AGpsL |OmMӿ��XEC!m+7?f V +#8w,iyNI+׾��X[+_gJaoq[㫽m'V��f V +#xQK6ŞUil��B;jW_;Jat"GΦDm��B'ޤ=?EZ*2o7��lQvR] ;1� HJ.\7JCX)쏮Ljx|& � kv=*Jat] {L_;�@aҟܹN.%b?'"!pܵd}}� 'sQ.%b?on].4@�`v(}0Jziwxa+}1>y&+N�`VғγқҟjJai/&߿+g ׾��Օ3/Rkww(b+313iV}�lr1 =>GzSCX)쏞{l0y^�|U}ғҗڝJalد*;J,KkulmmYk;׊.ˢqXeMV7B#AT95ڪ0.1IָV-7y9ϧX<I=�@.V.޵MNL:GxqmRWyߙ:X]�@h=?D89][dΤctY5~8=��/Yt1-F;3gxƬ.,o5N�Y. QNL:GZ_Y*6z�"(\f?8ѱH +>ϖs��higΤctL;A]�l?&t쏎xy6J_���:Wӥ?[2Uɦ`p&#4&Ȼ��Y'Yoottx<mu^z"sv ��,W2wwUoIIQ\X��ک%|hYP5Rap&#tzZ{3nn��vpNMu{?tJ,X<߆Q]�� T +DIfdP&bp&#bRFX*O݉ʝ9Q��t4t.ػ=t}kߓg}#j7�#Jl^Sbp&#'J|Gœ;�@GIxw53#vmr<綺õ[�@GnHۘuڭ53gCe X ��i%]PQXӱ?8y-nl_sɴTf��m֧v7^VoI\+rg+�7uheXMnk$`p&s=>:h{/_=P��|S1i I|٣ϼ~~?��_-+`JFi75R?8̋=g/l:��GrHL:~ik(��^~%~Rt1)#,O{{ +n ��UW*OtLt=SsgW{�׹wX/K_HL:ì=vx~W��Q]/Fgұ?t]-ƻӆj�Q7+v;#36V e}�vҧ۸0St}/,nl_sɴT��p)v3#3ayYnBT��n.ISڭd fhi{˦{#< msʱڭ�}'v+# ԏk<REoD>Qڽ�`@t)0ڍt.ܯ0?sۚC{J?#&eU\9Ne�\ҡK'FF:7{R\r>a?gB<ZMv{��gG7P`p{1ݺY|s#??)譀hO� HC+6h77?p .ߵK~f8sKYI �DON-8bH\g]˭ qcbgZΙ{w�9;ҟ[ϱ?Pߨ_MͲ;伹9r~p^g{Ξ?S"�@8wh`MB|i͞1ݺY|W&8z7=:u/:_~߻+6|ьܥh{d_9P>OGk�`y&ݙjv#|;|OcptqS'e֟5Yw GB޲e vq}P<YK��sIg]Hw? ė4N׿ww_eV؞5qh뱇eq> O[](6�unff캔hSn{˦{#(|#`~��橞iYk+/n9+gӌ{#=zu5^{oev��ĪҙntgHwe ؾ;�0VX%4{vpwΤc8CycݕOWn�K_3ڭݱ?83r>"տwv��qОҕ[nt<VX-�sIG'yU%>vpoΤc8˨5Z>=4E]��j;97^z22?8<vt Q_��~HG2ʷnڇt>:h{/}t|Oa��~HGDihgұ?i첖Q�8tCi L:3Ťܵ œ{� Ʈ*w@:235v]J|vmIqM�OO%MnĮMn3ΖQ}M]�X"{pwDBUVͲK^:{k֒F%(ݬQPA5tW"E뒤$䜓#"9b%t3(V%ٝY=_3tyf^x?Γ'i݅G &ߺzΗy �`_o8vwѱ?Ia.%Uo;j�~Ĥ ; &`mqaq1~�9βK/; &a&]ߜ\X��qrQj^vWĤ?̱ԑ6R6HU~�ZfY a0GYaVqʒS9�#=PYvGiĤ?2.mQW<{>�o*='}0ÅOhwAL +,Ԣ4y8J��OA_ UzAtbRe8|-�h}=!=Ꝅ &ay׽\έރ�Sl] &aN %GrC�@˓{/w?qWԻ͇AL +\n/ô;�n4DkgjwV3]WLE�@ˑ;/~'sv?Iagpkyr]�h9+s;=h~bR曞3w~`~�48~"w~zfO;-AL +|XYy{/I�@.]{A` ']5׫$jw%�\Ow絻-AL +#p,O }uթ]�tӺH-KyMcвĤ?GwZycw1Z7�'w'Rǧrߵ;-AL +# ^u81/F;�w2n-hybRgsU{zEz�I!xHNA`<Ol8ߣ�-[sNA`L ։ojw)�nUΜ {Y!] &l~V.S�ɽ]5/<ICкĤ?SXEϏeΉU�ɝ{-w[vu?Ia):0n�cȽ=@c{^\~�?r<ڝbR>'q9Y*'Bg�ߒ|r*r;:Ĥ? oXMރG"iw-�[7FZ; &;J,wxg-�]~(+A#AL +wn}vTݿv�,',Y#AL +w>\;Sw }]6n~Yn>1)-4Zu왬߿�T�}bRG[΋){;�}n煟, 1)gJFby/v@ v _]�`@}B[E)^>@ V]�`;g_ +l++t)+t+8OϸlUiɜ^�ɝ,<%wWv^Įn:7MVTP Ax{p~:1ev7ncZo?AO>m:L_Qca ҧɮ="XDr_&Oվ'c,\УuCHo׮Aϱ?0fYŎ#;�`=yrgj|19Yi%ggD1(p^9wz::v^Oj�0':h [b;qFFyB"^}:Lvqs4a^Twv_ js]K}aoi wr񽗵S=vqnJ$۷kWaQWzT�=,Qa7 -/F6A]~g +gv{M1|}xM]9T]XyIm?HKΏ[SFnBBn?;/XvFP۶|x{D S?ؕw]Ѷ5w˦?}LX3o�G׽C$wtJFb7 vKex|}Ƙm>wgD] !48;q~U�OͶrJmkjt;AQˎ[{�dnY m}anleI橜>� 4OڷA욂tj6'&0 1wvq:;NL�nUN-wsTJ\' vMhp>WBŒ쬨7="0}l+{�실q$l}Ĥ?]c,g':~د*3㏔Bх1ԠX6 /\ niu)TE8)Rj%ZTZj 眶}6}@X` 1'&lvKp9OBH\羼H@CIKMFa\БV7�|koIOJ_jw6b!ts&$ifܪ] &h!kcse]R{�Y%>\Y%=Ո]bR+XB55o;x\w�4I~dg}1Flc@4^=uz:^�M}G +gd'iw3bŪҩ>k �KVNdAL +6,#zٿ ՞p��@eI@Pa1)oζvj:�Us-)'=0⬡{#M��|koIg`AL +)j>ߙ-�� %iw/ &4*ooqCgп�?ZVcw$ݽ093pCͱUs�&鵃swڝ 3?Ia` L/Z:v? ʴo�_/~9Ĥ?0P?ů}/�@4|{(;fc@IZb5n/݇V �p#Ǥ"V&ݱ0TP`��C`cv|bRhS:vgmkh�p=V)k3kw*4d&ʻrqw�|[_hw)4 H+VG^ɲ�\S#7@zLK?Ĥ?edTlԞiYW�ո"B3/E|a<9 �p9OnngAL +}DױVT}c�,IOM/ZݙObRo]3N־3�R۟#hw%n[k݄${�9gBRqvG"?Ia+n^9Pjvw�oCݵ)~H71)xɘfZ? U14_�G礪w# &E7ujO6;@|ޑ>D@?Ia(i/}�/_U?C]*tޣ}�}n;/TvbW%-M+p%�f;Y6’)n(ށĤ?efN}N홽'�ԲIJg;2kzAL +^w+i֮P͉}�f^ikwJόϛy?Ia gq@I7G^`H~AL +"}KV:^׾Y�H^ʢHhwp5bR%9S^<>]nվxɊʷ *bR%C3MS{~;�icG +6.^6૰?Ia HJEmOAw /u잒moJhwp-Ĥ?#UNcw]=HlIolᯗ2Z?Ia VI59gg5�MzBBzct 1)IJyCէ7�g%=!}!] &XR>hSi{s`['#}Y` fd'龲=9�o>CKyvW׋AL +X)Ny*Ѿy�xU 6zvG7AL +&M|c\Y2O _4Q & H ON]oz@G;kӤ QbR0Mb=``w/QCEv' ^Uvd8}{g7h ́ /A00z*&w/߿v ^H|鋇d>ԠҴ[-{qW;LtkTk"g?&@\J[Ak +'۟ޒ?＿9oo]Mݾ|yGuӾMrz(6`(Pm|eD{hc/WR<r;_R<k]}JFE6HEzWcw,~'S#"cv|kwċY>ȻټpҸvױO.z&J@<s k{z={f{ @tXw];{;?WS*|do^pa ^I~ ]~71];O2ILH&fe!e Gw~EuqBPt1Z5NĠ$QPHEp| " +fAqJy/,}K +!Q5Ѩδ3Gzq"{ߞs~^{$l'AL&^O ]ŷWy6@c3ZA^4?0^t[6x`kgOG26K4Ol,4 5]BE>ESx1YԁmSt:?i;q<O)7ZhҞQ3_h!ȋ`񡭔F Bd|^AF.KE�'> EIGY~C~>'6Nk8٘zCGDFlbIww@"|_ |~@[Яw8`8[0jUY"#yZ1nOX̼2r,C +A}NM4խw8CBG v9'6Nwr 32].JktwΥ +g!(KЧJ^3D`8kl{26KbcS+ɻKb,8[sEvw W +Gx MsAuY +FsIwh#uVN_ؼyl]1L~Ƥ}_>:k(@ADmo~UC:Nɗ% qDҔ +kH.Cͭ*'x6_@תH?̷Y*G*]9рC}fݽ*!x߅ TL 6r2AJ(.5 N{/0ﳟޡwt_uVĵVե=m&7=ZG!{zPhhZG(GuG~e?o$b= b#GT HZ.;Q&;Y%[ kB+~sru'wF5.JRԢ]U&]9Ǿ!2/|]:=.Dh`R8P3ۛv$[y#Wgr^ :fn<$1h#pcCnr[*RAϳ<笤 m!תh>/Vtwוĸ }/S7_%݇!d zͺ ]y q`R8dhއsȪH7Ň<HSr2"= XpK0f&Nqt97?9!xYR"_!>";|<42zn L+,y}? +.,m]ϧ᫄dݫAw?!?0\)?)vҚ z|۱G6.�ߖ 굴OevJCaGįgueVE7&6rʪϋn.= +qSs*{#1ۤcI8E%-1dt F.h28;q eik�<Y}gZ;zL0Vti{R<'] .&Eݗ!åH[)'  W +G ] =}_!gJJMHۯ3zn|Ƥ%56Uπ=V,fsYA++Y3_ Ζ u%10]fkPK0ɅWU)E!j]_t2_c}Mg+]5To{0*T A\ տ>;:&0НGg+3h-iO7?bdMZge�~uZ`4D>?/\ =Zɬ.'<F\ɝ0$K?ß+To}'ﶥ"uZTS"gRcS6yA->БmsKw+!VN>- ߯!�z4K~bZGg+3Ic53zCύϘtx֊TX*he%~~V҆a u%10]fkPK֨29*oğnoe{AՈn.w~tgp6耎@O"o5  W +g ~H-y*sAuؐ�[K̪(l/~ʪσ~+6٥X0a8>qJ˟[bn2g?3i84jfZZOɗBߕȮï* +߿!Dsުz)?K  W +lQ+ X+55'skVDA>x^m�\NfQVr_Ā1G<zp9LVjQdHnoz҃ǯ&R:Zş[ǨPOU .K<k}sά'| D:g޿7%OZ2@J(qkRߓw_\<i5C)Mg\yTTǟK1ƥI6Z6fՠ%EDY"IA2 " 6lxo1i#T'뉸_1]g#�q9sm{g�a;ұԩbtq\γkkJxG>ٷ [yt7s3+ +sx/D59omEg7=>}\4rsp'Xm" 1\:ɑrQs2\xv/#pbʃc@;"mi^$^U_F9;æ묆08(_7ښ9r5xm|}Țlu<sAJ#4Ki x솊5ٯ}5܇tMLG&.Yhps.չ->+YD洼I-y~)6&O}'sz q{{ KNr+Λ[3O:ݺjm]  F 9P P+jiy辗txk"k*}lܴ8FPA+k^. >NUc_gWWOoiߦIי8Ja\MŒuasx#5o0nQPؾU*F8!rr}"xQ$k<4/?�}R; }CwdCN1AW/b.Y }tdc} 0>+#Rv"p Ӧ_pk>M>~UNݣ2A!@ NଷK[!-NWJhڽ r +2"q=SmN?m C]�^Hh$r +2L^d7VggD_"`c fv@CCE ?0?dp\t:>M_"` u͝ODnS@e*v|3Gd=W&R׉2\-)}#תb9#?0?&1<G.nӤOol.["giIgkeiyQTeނAY?rtC%obi`(-1;X۝ +} }͈ ?cgkosڽ rSGh9q#;VU58g~ZX5x^U3mqw̤ Lk *;6c%[vYs%~Dut7k'Q13?0?3<G.T=x +u|eӾסbkys]?Yow,#Y߶Wh`)<l.M:5xG2>=-e)}i߷Ĩy z_*ה?1 +m`:K2R@!DV9wGo"֞:}X}h;Ƒo7)Dй1j`5Y̓G]xM>�/̑wTmosH܋4'^ote-Lý}o߄?n^Q}\Ûy8t2Bw=vp֥;Fg/%>qē/{I+f¹HmpEZA cs;*?twr&\Jدиf=37iPrp)xMWGSח$eN^n~i$`)<^-pxЪMG[XrEdpNO4#aYи$N~rfn%2o+ ?,^&gaS۵iy=QX&Wv]&K3W'?}MLxr|oY-xEʆl`^0U_+͕:IZn\gigmBթSҝ`:0xI~+2gY| sGwYKܬYC8>>߹\h ެ.r߃N>D]ӕSxe@ҍչ-'_/_֭-*1JjFߦXJ  ޢ^{9fU5|tINKs?~ Ҽ7MNZ^_Ⱥ*Gma2gVybnIFh^'Xmоb^Y;!? PX1Z:x=Qz.x;5x/G iecU4fͩ]u'@v7k.^Ar +O3j=e dK9[8AC۵ik(_i's1d.^nm,Nɳޏ?^MXH|1|#^Zʃcuꞇ=͔835'}}M]Me){[9=MHYz$gy߱ćDF.'@B=B] SxH0JG*kC?JNMlkyã80J`4kcb\hij45+ s1^z#"rITTP9fifG<w1r䏤Zi:|CVok}zz9i,y <!<MOE;V`f8erϖree|[ڭBβi׿4l8<Dj&M93bEm}?%aOxhC쏷/=[X.:۪+{ùmƅ{Qy(;/ۢ '~7Ϝ+CurMryaW|Ǜ=?p_ɡ^ϻļ0s97 -~"7/-zŸ]-}0R4P?cZۧgQ},0{<|xqxdC-&a-*޴G9?^(ԭ<mrmE0YQ{R<^} x{RBP^tA BBMhV6\'67ԧkc[%o3V-d-8dD >4w%JhV½;+Ћ+Y[y`+k9.m*P=*>+ :>tZANSqw4Y h)!3G o?n0Ѽ}9xg܊Cc9埿2Ww\WkOË(H{Ώ3H{M}4an'�{#6|_735 Xkq57v! 5p1hy|=+' +Π7֚'אPS8t_d,j1>'ukEv"r139 }tM[cXXI+[P5 +FYrya|U>+n$JCЗ嚽{&|kK>?`?sࢤq򶿻4w5"d-JFֲvF'MEﺰ_KCpzZbq چG7I\ASo^R}G[a%s ^>oŁmJl 5˥>Z &EK򳅙53O}Zø/?ߥw */nz{߇򵑆 >S[}|[)O<Dr{ +Y~c+MCv>~[(ykUR<ϳźs~4"kuįuXxoNتְe@?ZA<j +G`CIs{vyQ"2Y<MKgί0}:xϗMf &:f]k-tPS84+KsbwyLkQlD2|JD%#6_jk\:w\w :^% ApT +oJBüDσOJ;oJrcdp=/�z.=JABMcD|&4o!Gd.(i. + ߜ͟ +a͙D: 胵F x~P)4X2J4Dmz=1AݥA+E =kMPS uf7$uQx[zݞ}l-hq:KV> gA j +nE?9&Eؤʕ{fAQOUw" 3Po֚#!A A 3h>sN(ܵu?^vo{hA~߁zF2g8xyPS bp,n+NHrnx2"8:wCId) ^>?(?9>biE[ޥWy˾&~̫?:^ZCAt?(?¹8[7Tc3Th#k`CPAP/֚!!A ApM_g:\- +w߅ƫUg+M;}? ߙv* :ĉQԇF` +5 :$Y>0n?r%] .1oGXk ǀEGEopɛ);^]f.q1mw#9Sˌ7Åؘ]]{ o739-\kzGrчW;3|"/|#kOcAb uf +ݖ9d('[mAVТ.񡡿9^&3V= A< fq{&hl͐h-^yp)`م(|g�yB7yD>Wu p\PtTr=<=s2T Zi߅]{6 <,͉:j<<r>.{m]rҤu\lҽw䡮p`WF4DB]E u&A5v?(XǫrRp7)|�K׮\uq/!0ո_78+.1/R4d[2{PSOnA_<@U a-VTXtX (E>"D^<&AyA[k]wvvB]C1! &$}fC߹sη퇻q4�k +}_?<xw' '9GQzϘ?[0^ +fZڤ<ekgeo&u=MWoS?֦?jy58~e ső|F{!Lga-5'&h倥<5<&l,j,]s^_+P7֖>(o<<yb<A}sȏP70f,Q΁;(e1 SNHc1^8ā{aAf$e[i_[ 3L'}w.9e 'יְ?ޖgqďoWG7�!w/ z.K!0BQgT hh^ 재J`1{.%)>FWN[׀BMmMZ:^ ~ŗ_JЃ +8?UܖB~f3 +=FpNhXb/r8)3ru5?^ +&5~ٽֆ6Dd{d` +BP(m6w>۹Ezu gl6D B{VP( +Bf58!/�(@+x#m9)i2AAcz;rĻYxy'%/F5htЕHNM$Gsˎk%6*AAA;2!sѯLFHkc] ;ЪG?;ƍdzE          Eaa~V>injnuYqż(VÇ9c]@4ٽ:+)/=%#$,(TTȔ;sY0a?}ȯT&vZ zڳcbǎ\oX;R齨im� gglb7t }/z8 ʊ]z|#i :׭n։O6VX3Rq<}KQv']eMg̸W r3A{S/ا V#A&&S2ONJ*uxSn:m;'njM`JœII%G}Ľt>B]sE&1\=}j偄D2Z^#cY^˾m<.Q) ز6djp)~^z X\q(=ȶ|<6|1=[.[Hm.knlic!إ,4G 7ٔzh{DkE&1ݶ}~1,T2g\]h/= ?=u]J-fQTL'mRI5#=v<T73瓿c!feˉi=]?7z HN3X{|+F&^m=F ؟:2ixW6آ,d?|3?q7#)/Ѫ[Jd0h4bQ|F H||=cǢ],.)g"`Na6M*YTdGN-XW'·=z8 +B[[gھ: }rQ ,c{=fc=ZoOLL‧^ǎ\z'ѯdU77z8OrO݃6)hAXMhE&K"R;&Ѫil=F;*Ezi{B_v_;y u!Ӄ)==5~٘yy ` tV'v :[Jmcϟl `Ƶtժys{c�9 ЈY?ÂK˶@vR4tbg(cęPHښ<쾖E]`)3v1#,5K�EU-nuK/v1шodnnc >WK)o8_MGxz(Zj6^V%L0TL';t #}hB4mk clQ2MXsәhUW%2U|.kn�Vq=vLrQpFY=v�-^xH:Bj/X"õ; +^0ֆ6DdDX�,WWq** K폦$' މE>smT2X�s6RVY˴K)ɳNTqDP{Wyv>q@+aA5zln5z赆ӧVꊂ|E5`BLժ>|Fg-}z谛ͅQ*:nI/ڲ6/Ԝ+eֽ3lܴ}U E&RtW^Ψ_X/s==(I)ŅmCogK:RE/1v ^2 72>'%e�|EAlQZm])"(HMBA&`e䫙IXE-{J-Ř~prw8swNQm(O/`*͛7d0o v;~&&U;~SiY_:]W0&ha<oql45ÆSF>K_жLg]'ֆuuTyWIR.#D*!jtrO?ǢYKATl>'SxtvAݾMNj} +ZTb"NMoT=$^k}m[חZ#CUdDܚ•];͏ڲ%/777g*Boc*%{wɱhx;7WLƒ؝[y49dӺ9i!:;Z:~9}V_6)V��������������������������������������������������������������������������������������������������������������������������� �<: endstream endobj 16 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36049/Name/X/SMask 28 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�a΃<8? Q5֘TihQBCE-)r. 9o&i2V6}׬"&3wyyvwva?~_b;O%9Y��[qozt}̈���kuey4_?���7lYdPb\X���{ Jn#O7p>G���to5ت.*(utpx��н`F8i4KX@oq݇uS?W)AO{sK���염n2y5/woϝvؘQmgSf��@;m[ާ;Nyʠ6] Qm5t��LƢ^G]+��Fik.���e@߾5h���۰hqjҺ? +S>���x0y?5GdY/R>���xJwP+(}���<&3yP k>t ^ѯW��@7wNJ@-U+XC;��@AN>P4ZX#$;~XdKIZ��� .59Pg;ZX#hteUQ���!̻.\wHiԢuě2j%���!j%c jҺ?B��`=&ﲐaԤuLܱA=*}g��`6pwلԤu^;UJkzM2��` y^3EPz[ z��`ϪbyPŔX{Ь���QؼŤYH@mGp!㡞^J_ ��. ~bP涥1+WVn���(ծu?6m)djL[���y6fyP!BCw��G53eEmF@MXf~d���QdgH?F̸As#Qz���vE_5j?~emkS~���$~ݺֈ[$Q{kqD2^1ei+}?���{b_f2Uj?)+֚#ڞ7G^��P³ew5?bi~uZ'NCIAcE~vbAR_Rl7pY8sQ+��t+u-F:ZuK41^ECx;ۅ?q\M<.雟hӵ:hQڞtA?��1Ҳg ?V[wl!ɛ#HaB|Q_ek؝p`fcBx[Dogg?���%y[ilBA@:5Ed|yBߥ̡{tpAvjrl̨3|GJ,���]$;3UG!}*Ph8^;=[VξT9Ģ3r0iunK~psG��\TϥgdԤ֧[/?hTq5_oiZS NʿK,mTU/w8j$1bpuqQc��̻+(jYG{ȯq*R{Or6h؝+3O5HOn+.k!Bw!#yݻž34t@h"ljc_ +���m/P'ݚCΎ_BoFuT4.m93|.>ULښ aa!~=H��ؙ].yżYgf _?tc<f9&čs)fۙCϬMR_b\+cGO×,1ձI ��oʃE@:j5t/tɛ#DYSl?~,`diӍœ IVwxi0>��G$yywɳcsQ:tC|(u ++ĩH!eqn92j}RĢD);=O76]xwS+��ݐ6gPgǂM7*tLB|Q|]9󛦈M5Iq~CD |gQC +Gj��`~>UF@Z^_H7-9BT,(+Y]b- +F є&#N\b3$AKDU@ed*("nFLiDřrJ6ܶi Sߏ{oFVʶ-=$r٭BQHe1|7!Kq����E0hSJ4UMBta;?2>\rʃ˳S/K~'ˎcv{{Q h���@Q& Y)먋ajRc*s.r)UDADVͧ}TZX]’!8-Os *3iP# ���e oa@T) ivmtY?$s?TZcM?B|y# a;ݖx>H���N*d}_`@X}LU�FDT! o֊K"Mg&Fn7]3l8G ���40wtu'!h?,4O溇#F|0уYF.o\X.Y4���'{{}= &%W)}XuFNZk! MA;(D!'> x\?��~i9 1N])y]�mJ(IuF4Gb7KXS<v*W˖O25(�� tXjz݉C[6)_h?|cTn.uF%zo3"hgBz'=ob5Ԉ ��[IzUBvg˱h/4>s烹ۍh)Q.}zznI,'ɢۂ&̣\U��>ow5>șe IXBac~T2nt&qhg{D.kMNwp}t��T$>, 9>s^2ݳcu?@h?X$Yv~\R +75[+We +yQ)$7`8e��K Rt`{~Yx2[rџ,S D''1Q&c_Ȭp?wIs$*!z7{zdDE7I��Ι[b+ղ촺0苄<6xeuB܆UEriNם},jJ!#/!J[e;K[<+$וG4^��^h`ReW>Muxq>z0jE2txW6؄{whAaz^w�m"+=q@,;o֛,Mk ��@߷,SP;&@cb6NK>ؖ>0U? +k{.7@T!\l՜%3Ԩ$r%8?_ !Q{���x\.RwFߑͥ+gόm_ۿ?)Jq:;E-6<^V]ӣ[|6W$VȳMR8r;*֎ƍ1��m4TrqmKҎgws$՚/+;:j%Ky=R)uE+.Du{ />hR~盤̣hpY��Ǻ;Z%_Ԟ`LͨH.L:纻?<f;B';+Q:ҧG6#[+] +$[W-&=f��ty.jwwxDZGZ #O%'G 5z<伟"/.<<ǟyI:C~Qfζvd>zLϼp���/ol֭$5:>9Hݿ< ?dhH9 ǚv'>rVo\@*NSE>((WҧG6#[*=Ǘ$!L z-�ז씄kqEe]+G>zUWNzFHL.K뭭>;KBIY_ I<'t3QnCj*qy`5,<֎xo%��'6 no+:n+ib= z#Q*wY5ΛAn(5GtRrC=]AJ#Q=Akņ~+R& +#]g䏈Q��^S-&P\բG7#g} +mmQ:>ybÅW5/%["a<<0 % cIvmc]5kI%&FA+r *kD "30`ˮ+Vpݨ9;/hQyqs_^7|3<G9\. +-j[V͟oi^diaa��[%%&ȋT. .Q_e]?чM?{- a}eD3˗k5\AqI!͇���jz<AyMW;s'={Ww~�D}-K*5k3#TJTn&J/(βoETd%Ĭ +_ӀO{��p‚ĴDžzSX'{i[4x`DeYy?^И&YD_u_҅3ғ;\Au3[ckTNF?k���&}-[R�nZܨ`zƭ~χ!4lD)]{^PGnWTńy}؊g��d&Ɔ x(~Ց ;ۿika�sf JO(jB^x]o'y\>9N&FF8-n٫SgHx��� :wuM?�0`X(Ν̎)Nr߁65DMw~ 4>OPި$ WnOn#Z>���ހaC~طM<7Љ}1oX0`No~W}0!FTHt7s`b'jH-Q\(۲5p}ʊy���;pp Qr/f/ = C:!n(n/z It>)=<<0&R&QIvV{&�ķMyzʋğP&~! +mFQf_EIo㈴~D)]t3FGMV~PNp +3~Ύ�w dG;0=4֋V0`g~c>[BsPˎ,&*u<2݂|A~&%%[7M m0��f$Q{f?)]8ۘl V0`RmsU Bs4ɅH&VROt_6Z~:#!fU>Xڍlx��0 2_:ⷷuU?9aw)G)R&o5w9e$: q|R`J CLw4s9k �[EώRtn|}Xa�r?¼,E}T[wA.FT\ٲ2bMr+WzJmq ao�� '꤮ڇ%{X?9a\I+ƶn0r&ʞItf;DuKO_7dlaGvvO��p]c}7).XaM/S0J=xUL$:OUODžCo gDLKeQ߹͛xd֖��k],J8zu�svNoV7yMt%20&MrHkwbdr6ڛly6��08RJ9<[jV\pc0'L? }E;yw0&l J*'[/˞n;S"BOѡ#S��fT{cѺ]{5w?�cL?h\AuS37AԕHGT.l`gauvcD:&;׷ښ�BԾ{DFy#@u1; +ߩ*rHBәFt<~ʒ ҥgT7sdq۶ZuڗM!��I{J7ꨗ+9�M4I.BGUt*k޴dmRNjѡm;��~!f}e%J]gk6'?9a1z"hn a1Ã|TSy&:p&J>l՚�7jo%ťG}dgjtB�^S(%K=[»w Wdȭ#UQGҒńs\'Hڵt}>� k*3kX`�r0&^?ƁȹH{̟F!êqa!GMyS�rP!H7wlT@$ +is~d~�愩G#itOûi oT[/(3?, hc5M5^zW$0(ZcT"*.,˾ADX@Y.&&E(քx@֤Mx[g3;<En#gIOغcx"^��+`ޤƜT|pk?�x:ڻ0ÅTQh1Ž@M[9 +Niz԰nj�AY q p;B߻&xI'6U-[ ֥Ӑ qzT6qY I\z�߿bH7]lL̿Wd9�tB\U!^ .ybLnWV3g;uڕ*�X #?zǝr /Iy37�kWL ud{7w|!< +DuIqk%)g2tJ~}IFD{5�8hoO:Qut|-w`{c޾Ю�<}R>+L#k៉+l!H@^��l\hW&NUK%1�</Gws6 BE#jRhUGM]_佶�/r2ϴWXna3&xuT$oF'BS}>Ged],VO3g;uwt�/wɘ*7ocRXnvz%`m(!կDs}g !9KE%}GN+o1n<uJyu�sR ?u*:tYNi _y XǨH&B4YNԨ/i^U[ d# yZĮ^SƸ-5�x + 1撺W潭*`NmY X3%?#|^> +O5D_kFvm Y˼vN#HhTG�p2SW$+6$rm + KúghRB"4敐'}eyG򏠏�`˙J5B|'g N�<??VO|UgS B2>R ?wcofq998> �tZnvf}|~Y>a9�K`EHs4_X?'@>2ڱz{5O.6Tx|tPo�]NC7MgOV3'�kRGߐtNT? Ux"jTU-~8ȝ!ѽqS, pq}6�J6.R&N-3j#IoCNA�`)#D1g!,�!=@t-=*~|2Qm$OթKW>eKO �jeqk*/T/&i ѹi3&,YW}!T-"CB-E=ٲB^Vݓ>"4V(*bpsoާBQ|Z~nQK#`mXR` +2CETBԜ3ĮzkE>bPQVe$,غb֖b9yЮo"c:c,3FڰᓲWy3Ixv!hjߍ>zOsI4SKf!>�طsYߖ}m%6,t HեbY);!]"}իɊ}ĠNTfEu2ƍx$�e҇s2CXaw6B�ֆfpƞQgjo!}#}wnZ*ã/WtǏvl�W' +s*ٛΈ>X6jVč䝉?5bw *7WoBhfx%jRV.v,1e/c'\{΄ɉM}^lW,8s瞉?5bӪf!l}cCNv~|q|ec1XV>7nچD8ۓN{r*YX+?l&(4BUx}6~gZNЮ}۶[4Ãl]ҾLT7 4jYd!V,0j^BhqoMD8ծ^ dVdKbodgk_$66TVլeNQUyg QJ$uY!D1yŒ;?ƮexV?wB/[.zX2or1Ɠ>":<QdĠ9sŹO;]F�wfυnW@?W' +7lvYW`߱eՕG%K#NE(8gADTDE"[[ PA^辽\@@fk3.S&Nt4dN{߬RHxLEQE^� a�厦͛<o=vNGU E)I^сL7FDىO1+Y%"vp'GtF`r|%ӤnUǢϝh@{(�7-Y6IP>+ˊ;5#;jODp=^myd}ej +QvJVfflz}?6/�E sFUDQE߼B/p)7ryfKN"OLxj#`0y${U){zWK;hgWOZ&ݝIputxG%+TGП([�MVy;>;QJkfm۶m̢y.`fl<y{oD[s8�y=ڙ%JE|<+cT[;[ cL;ew7?A{&(ïb zZ¶4 EdEANnyxߎpcc5 4~=j˩dߐA;`@DDThێDžATJ?QEQ=7t kT#]JV,:,2 dt0~#:(YDr.Iu \Tɳ2kOP_A?\S4߇Ӟ{(Y)$sx\biOe}I;%w +9aBma1C9b6n2WҶSޛ-[ג|Ar[Dx e)T$'tu6o=X]J[^(ۊ#�ε;$}DUǐxS&F2>uw +93@Id$a@tH;%+k336~e}_HȨace=辗?kڿra\ <kw)(-O.XКAOsꐸk:B|U)64j<05э 9.^=*S5fᇏbQiQ^R f(}�wv><Hx]GYICrkU<w' ,G<NΚY0}nfE 'y(YYkRTm=\> &Ҟ[(%\wy= |Ю:$eed(lVڶ;-Y +V8_T13ߩwœx"{Cr>)ῡm \ƈ=*ebuBz8?7cgk4xO1Q@{N(o�_xrzUAt@):Ŧ ?͙ f4CrteN}W*2%+hgA ;0<%EQT<rݵK}۸'P|E'鬒r99̀G^7 +ك'ecϐr^Aqig>aΰۏh!EQ{IF?<+mt0;x엳}b8gv!g`�¼u׏QӁgXk'hg>A,V(j[ Ph׼Tܯ(͎ LG012 vYwُ:�)e +W}mg (>d'@߭6AbmN;JChp058Ǥw&nw2ΠeFHe +W�xӟ)((K-!7iu~b%w_tjJ"64tXYӎ:MQvF35iklv g?\gVy͠=?PEQM)XPК3fSu̾"F."XhRT%MځB^R ^{f_a 1㔐__$E{V(Pzr)@y�Gz[oZC'ae ڲʗ0Аv6ƍBrOh y!Dȧ] ;GL3=PEQte�.58mZ}T-+kt~eA 7!-2 d9`ajJ;z I˛/)|Od;:%w?L�S¨Tdi�EQ>�.qoǝP=M'ZƯ*HI 6VִȯCwM1uq)&vv;\č9<|EQEyP Q<TmbLjkUDS' ɨ*jƫ*I#N<*%*˱ +* +x8mcc`@ad ޟ?"ʳ#-6^#ڸDvҕ'X!&o_ֺil`aHiCz88SFJe}ժ[~oEqoYXG|(_- S=�xU{pWÜģp¨wF~bcti o l |'\ꛅAu?qL2�WY!U9{6T.qXXqCZ^b2$Ub#|8|ŜD;<v\ R Vk"CZUm��MB_!HgGſpz݅ ~K* 1~7-{ q=^b׭(NM4~rO?Xy;AB )? {fsG�@ R(])ĭ692}~>׋Ë̽I/i&kGRf~+eG!F}z{z}&;~!~K1r蛍ʄwA_.51-{@ST}?ykCG kV��hY_ Dz!nF:8ީ{T}Wl~)sG^'kgx|zC]ճ(Bƚd s^��`(RFkz7Q\b'mg66毗q|G}(^lٙs0e ʈ^6<?ΕPS\��j4T- T&B5@б,$/��toamno>IMB Xcc+k��:W}&7 gcCM_~�!8շccf|��s<,p+~o!-Z7Iz�QxQW(�շcCwCڃ.!��xj\mޟAXs!ҌN��`rb9?Eqo] }]\��/rS}{?i=?z-* +kUF��r90߼OQ~{?i=?$ u#��x*V yK6AA 䧣1o(2<U=#�]Eh\y;ꛃAOG CZgɐ~G��/B>u շE+u,QbHug%��x1Ϭ]/W}k?i[?EsK��1r˽9#zAHۣ1&p|%^g&��蘆Ͻ^w ƠhH[l:fH~n�#ۂAH19VM��q}>)dۂAH!Jt<O��>rxMxnbꛂAH?{GG>z�yT4 ?ھ^MA bu<Q��6roe龍KN\MA b<w8w?,pz�wrwT}K?yh<]^yN7 )��heWSr%<_?IAֻ=UT��к9{ʽkUO7珖W&\V=S�@Nd']7r>ݳ|?2F9��e4ru}TB:"٘Zz*' +��Z&tR^q{_wECY~uú��==oo!cpX!tyyqgUX��\< U B:_G1H~wQ=g�@ڃ.r?8P@ ńѤUg bUZ��L޾r?=V< m XK=vPjJQlh}Z>S b7Ϣ&y �݌g#|~V}#F ]1  Sm[捥|jUK2WuUzY>S&L̅CQg.��ZwP)/FPAb<<kƌ[>Gs>qqugs��֫> zSm?ȫIvzY:&\ݹoD��hՕÑeYsr/ yU`g'L[QAZ=g}?3 �\ڮ6Y2\MU?ȫ+MCx)"/[FIx �Ԙv=,ꛠΈ]nmb)ǎ&Cۦ?ZQ&Csa��B]y[+_1UwZgZWvwλKYWxA+S`jSW*QՁxs@骍ZVKu]bҹy~I^O~ߐ߽h|g|u0LO>}_V>W_R}� U)=+=-$ݵ5gҔҩl^yGA?2'C}WMӢ7eխп��JKIe& I&4qb=U;ͯЧo~H[OizFV'Ѿ��ꑤ`pNcsxUkGrn/cߒÂTT.�`*YYjw?{7d߳~hq9z/^?վ��JzVVzWAr;pe C9ǃ$Gg��L#*=<JAL +mkc^ �iO-=+}N &2K7 SSr; �)VXҴ8kPw21)쏖5*Rij��Lq%Yv;G-\jWt5��nw&.ܒ^]k+tbR-1Vi}BEj�R-*N &:2^Un�V7uq Ĥ?Z癅,3jo7��ne_OJ^v7`hy^ެ>_�m?Ggn &z]4o7��9Q2Ԯ9B݂AL +ںµ8��nw?g~]&bR#̯o9��nq(lvi~v  uYwy~F�tқo^M݆AL +unyJ):s]�'\ޔpax4D?-q}o;��NCJ_NL^vwǣ9J+V.eNԿ��8Md˒L+ɱ7ۍĤ?;u7Y5a�i$=)}n &6RK2'y��Bz(rꞬtv31)쏶1vo:X�Ǧ ~ǵĤ?NJJ}%w�@[%RsvGGvcjf}�vvoQݎAL +m%{>  +}��HJ&yhw Ĥ?5al}r4�u gHzz7AL +%G|ޫ�&'=ψdS?IaW>&wZh��ݬS+w)Ĥ?mr{��:J|˒[:SM &>L +ܨIإ��t YԻ$bR'&'ytm[��S+-hMah?=[e~셃[*;�v"ro;4bRknF@ygô{�R/LnNDbR˂V^][SUD~��IIFzO{M &>H]]_F��zKϽyi75G9J+V.gO ��ڊ[ZI-}ݹbE;߮9B+��h+G~>2\kM &q6{i}�=ݲ6yjwĤ?:kfZdLvg��b{ګޱcXk +!/z`~o��ͳ,k"5?Iatcߵ +ܨhw��KzLl@n bR/67eL͛��U²>ocLNhN bRעV>wrSv��Z=vgxN bR:$^a=�@K]'LknF@. %bR:,i%vi.�jw+kǴ4?Ia虚w{CO��xʆpjĤ?tnm/Uɞ+��܋T?rެ_jĤ?t~AӇjw ��rv0+- EbRvN��&4$y;3T?Ia{cL+66��\XzJJ3C3.ת{�;2?=!~hiSMo;~}ꑤ]� U)2?ڠ[o_ɟE}ڳa}�@}F0_jwdcȳ=!=>nH{]ǎgϜ;�%=t(vG:qrLV>']~G|q" 6UԎӳ֭;~z8~ҍZ$4:?("~+\W&Qӝ11L=g8k](A~u>u_y-Tiw� z]=S飾&5F?Hil*1&;5Ùl]0ڿ�@ZX@qDjOK޴QÆ_pgil_YeY�>3ؾKGڝ>XF5r3>^>~#c8W;-+C�!#3q?.-RdT@wE-VLa8W~ϙsjw� zݷ ?i=zn546֊_A{X[?uC^h^I\u?Vp^XvWxZ-ʙ'os1F��)Vz'1gvvF3ug2 'ej1"vo&cX뷻Jr�\3~y74|Vրn>Xfqݬ?նl<&spDWn�pdMyccwcdgG䛻u̐-~�gH +uMvz┄>WV #u`},�㳗Kt vzbRΐZ#dOS��s˒~IݼvĤ?ֶ` �"ý?Ia83׶_6+�}| jwAL +9'wVظv_؜[��>nIhwAL +YyaΫ8ivw�a'{EĤ?'_��ز*EP3bRʷ/0�HHtvfĤ?i/켊Wkc��ސ~ ]cpc_rC܁}�|vĤ?缱1v׋; �*N,?79F`Ĥ?-cKvrk�U0Ѳ/2hw; +m�u.]~_7 AL +F̊7y3~�D+IO$̎,<1)k2j-!=�ޡ%䓾,<1)3j!W~i]�Ei~({9] &aA�ә%Qx4bRh5>.ھ {�Gz(vGѰ?IaehVړ򞕡jw�@C} }&<:1)4Nlegm#�P @2 AL +<?Ij}W}J�欖xnꝄ &a)~׊s �dB?9wa.Ba0Z#ܳ�Pw=R^U"1)s]8mUxN�Խ㉽pbcBb0\{lߥ}c{�Pw˽TAc0[~VPzhn�ԝCKv=}bRKZя/;h#�}+w>i͜iw&w] +l�r˽ 1)%#aUOJ�@,N#skw GHsguEIf �<Y-+\K_-1)+9~x �xxr 󛃞rߵ;uAL +#*2A;�ZQpWtH[PĤ?L!!Wه1 �xpkO}2XSP?Ĥ?O=#ܳ{�Psr~{)bR˻_?2LK�5w(r,%?bRkVQ//ߧ�o':d>ز2QCPĤ?Wm6U�ɝ{-w[v~?IaDK4*ݭ�{:K%bRΙ}eG~߯�};=ǿzvg@Mm{Μ o߳�[.ܹXk΀1)7Mk%׎ ~^k�Ta; &l]q] +-�]X;[#AL +7uHg=%g?)\�eٳe]bRݻ�OVv7@n8X}v߿�L�}bRSi V �H^{i;AL +y{LrfvunΩYάsyՊ1/E'yNEcEH;8ΡYxTźLku +,s]j;_mТy?K,k�J0@WzX.}?Ia5ݒGXY[僩1�[ނ-wAU37qy[&?p/&[{=k>*ӿdҳ]'w� 5_8ܜY_MK}eFX?ZzbԽa~197%N־d7&IN^Sa?b -˗ ~&;dמ\~?_gT'c2]Ѧ&}X^Gc}Ux{�L"zSvAzVVaObx s|Ey /N9>і~߱?nWi�`^uܛ´ vLm썺J'3=wbdd-|^߱?VJb\2(L�48\z5,+Zao k9v5eI=w93㨈Vmch+qћo@0>+uO7K-m<t^??ٻ]E~>ϴxϬaպT}w@0w;/Jjw;A::|J2K[t͞b쌰]&<[[&nVn{wg鏹o|Ogf!rf0@`t;Pz41/}v~7n)xkU~>韵ce?oݒGX[僩8�Cs-U-SNGpw-SEˎhysgW-kVca`$kqѷDa}�@xM OQ.G`bǶyܮk5!̵}kj6ώa?e/)g汤)w:�IoNݒmGpa[xe\eG*] ^toxk*w̔{rm�vvj]8TlOn1)<ީ1h<)PI?* })>bRxTc'ݮk+6h�`G_]QzRRĤ?ʲQ<�_~L+^bRhSFY2uşL,ŭ5%ғ] &2hq8{ķd{�4I~X]xjO.zG#?Ia=M<]rqj�4]?,]pҦyQ݌ &4+Fgտ�Sz0,+Za1)#w|ECs�Йϳ,wE;f`@G6qn*:]<E=��te5x OKIjw1 &213[l\k\AM��ˣ+7JfΉ`AL +iAr>3;�Hsw K6^AL +)*e-8/�@GhH:{ ?Ia}Dql4w�'zOY9;΅Ĥ?g̎];*[��sߞv\bR,2_~/�@{b_t_鵹řõ;fc@gJieWp,7�> ZvlbRLZj=%�0꫋IIiw+ &frjaN7�<4˓ސݩ bR0(Wrn4D�BzKkNa0.E`n#5|!{�^rg6gT寒R1)hcjg+�~< +jk;AL +~t8-<]�H?}PU|fOAL +^J7�>#=5>cvvg"4?Iaf" �ͣIqOy郵AL +v"Ylw(�QK\  &1{W\8/7.w�mCunוmB'Dhc<p:N}♡�ܾĪw# &ynk]OPZw;bRssyo�GK"#=݅mbRҬr6{@h(d &JieV]M7T�0ۅ^MfU~z܉AL +vgNU\S~yijgYLQMwjz_ &{zy8auxw +�H4TAL + 6sNj?}'"֘ZhbbɤjM|F_"hK@jAX P؅ݻ\UQ3#7vl'c O^g3=gϷZ�@D+6/+9{t%B�WR6ǍIy,� %e\  +\I:ۏ.ཷ�k{r%t%͓=پg@o?Pr*p%#}Y0.}ԇ�Q4G 4Wx6 TjF1Euiܶ6Os�kiQpVEUQ'g@_ TF.a-yQ|3ݍ>�CFMe9{JNjR* +D �pn4'h^ܘ  +\Mfnɤk�slg g@!T2BDݽ+Mf{�8 4hNJx(9E]Էkȭ+_�@z4'x*S!\LgWSw�pSsh.$Q�/%B�9.ϜKway=�myʜ{6( +dd/Kџ +Uy?�cݖLslxQ(9ȍgˬVE}뿄Fރ�3i4x$rz72Vm7Xee ;tK)BAZZT3yC�3ݩiE�Eϣ4srUbH舨n9g-7yk=r(VlSiyX2e�9{BO{ $3Vѡy{==9..J < 1YMcnvS �2Em7隩G/>{�\RdkvwȝAVMyQ|'e{� y/Kcsw3`0 b>.=E26e*<~nM ;ww deVMݤ{U} �yQ߬iyrKM-FDos?` Avl8 �^ 1ʪS1� '+1$t&/70deD& />0L[67ݸO�|yZ9 u)OIS\̵:ͥCͫ k*\tnߣ�>OeA_cg3?P]_vn㰾5bs*/~r̿s$W}W{8cӞUTfuXû�"4RiLO@PR +*1Y0h꼓ўrOVv>;̋S<=Ļ�闉"\ku/'߫�gW2FJ}K{�8i(g+\Ug~>re~QnC͏62Y`QRf,oy�GC@9cXrDkɻüR9JR#"tw uo̪͚/D]X{�<Z�嬵b{X\Xg^?o߳˔Q[z:�fq} �ט}0K-g�/(9pM 1N&UZ55u"\[?*'a(m3 jE??J +u}Fu|Yh{)mdί[|d{0ĪՋvQڟ3.ڟ%jN,˭.˫1 _I6miSz?!_UTfͺmZ{|bE+݆㣹]�C?/1GECJNʜKmkn83fYUL�4CApѮ^`Пuw*/ +9gMwt$ɵ +C^ޟEoOEQƪikYm.7NDm}YUBw?(sa,>?{Ni k= ߱U=˃0T}A}HH}{6�S9*D|P[J3c4'Vm?@}ڏM_jL#33q=v<oU:cSV1j(op!{%~ӟFﻫA[z,ܣkc<yJW [=p<= `oIRhSics ��%rDH,=bo/E O߻>O[:ۯXfZ]kۏMKXHeT&LlzsS9? ه/;@z?CN꬧ѝ҃]=󞕮llSUMy<PK>= �JNA;񑪒}UPaD2!f9WC|wwѬYLo]ͩ.;uNk?}XX똍2 Eω{Ӯ[ȷuX/:'~o޳ՍX<|Zd @\ ~;l,=� JNATsi2xHh Zn4^`.`x&0(r + x 8 88\==WC +QZ$JHR[U[G<7vZohޫTѿ~y_ +֨?`ѤכzT&ﺕuK"~^texXzvߘġ{p)w+?-R3?a?P돵0 tB Hʧk@#PpEGC煇Agy"tGZoR/M\Y.eXM\zJhԱ5Ev~ފrqfO +ODo$/Um@c ~e,/N + Qtr3Ӹ| Bt ^HZ⯠RxfeG?tOÚ*d]2nIZϋkgܭ=t'|ŽKUdo^%DH)Jm A;#*^S2ğA!1uU2YL>^vIҕޡK_σ~XT5KIam?u6o6#sF +{oc:]+7~:\=ϑ6;?0C? 7 +֨>?`Ѥ,,�I9ܵ~{}OiƤN]E_!K=; ~ ~@1 +@(x%k2?]Ǒ +YzIY-| ÍT:4wy]%iR H+ ;KWY?k|߻nn2E{cu$ش }n/wY +cqc6~^ͅmݟ@c׋^}&k[8q$5ꔃyl,~A @7i-#pbGA/}ĥZ[8-&/tŽh?Vf=^CnJfڕຸ6FYAwe*M+khfɀszxU^v6mKp ̓y&y8f ṹJ�{+Y>5}S'BLJ[N^˲CѤB;ٺ,t_ 0 '`)�ar~8;=AZNdl7=w,' +{(/TAIIMV] /MI1>vz^=zʟω�ǧS`z؋F|l~:@hH+Gu^4 CA vNn}膴vdCH1AHpJchSjDC>>k�BZ2A!@ O6s>!Mg6E@IkA3?0?^vї[Y&!)A./a@D !y*s%fMv~} 5rO1ѠҚD!CHA>SP%D:Zk2Xc(PPZDCHA b*Y~;c2\$| 79{r]\CCHAf}c!x O(z,m,i!A!W11}9:kq)1}:[+c&}%Xto}ܛvPϵ]f l^ɋt;cCG|!|ψ O +13579i!PA!Wi|hF/>s_gkal_>`YgmgI?`3)m9%a4i+ͪs- Gy\Z)rzbrC!CHc\J8:kblѣ<O]2{t +kr'{=W)ۿ~BD -/|6+s_ ) Rؠ;Mn# Q!s&yG}B`NZJɚ̠|^Ɛ)d ) +c4A`)1 C^='[uo# ]bMܛui(YQd=>r8UXDSx;絼 (J>.melM|Z&HAuo)c�/ssA_ײX(=Fo]Uf',`c\86xrqY4us{n}NeY,9.Tdq~t %/wui\HDR::z%!IR~Uҕǣ*voxU+#Znۥ} -ues!c3FWflӖc p.=4 +z-Sz<#UtPhWn:΃%jQeSW&֕x  ޻ڮ̂{mZLyEҠN*+c{r<I1#^Soձ2I̘F[cmK@ ZSk!^�\P(\.7]=p +hNVcL2M'3Iy0(߲};{<Ɣ:j=S ꬩK`XU EǝG`~DU$U?tMIM2/;Fټ)yɆEP//F;-RZ{,L,wA%&A?P Z!*o*OC9xT^&M04Kw}YW4uU n&K$l,u _vQ}p`Sow]Ԅn*m{o}Ju5U]:"F^Oу\ .oK U`U>ιٮ ًXMg6V[x⣖u}'A@V.3FIѷP1Ioϟ-%v%9!e|.PFWXkR]׾_eVzVVwW]׮@Iq*c=yԵ-@Wm2T7)L齑Ǧmu8Z /M,>6}(kI \B%o :?<5(t[9|Џʘ,wDz-#:!t\^t\Xqpy1/v]סC{BAbXYAMy빮]#`|w r=tN1yȦ)q4sY뺧n.Ujq]{{XY'ըZk^pzrkyܡw i{/J Vrtu)IKAP1$ʟΫJQI9J[m4b xad8lKV|Άʵ6={8qΟ^-z{iL&moݭƷCX }d[R޿?W{vG]7>~a֚$d#N ?Bdlc?OA|rLrz/%8 +z?@}(PySyZ�oWZՙҞ_bh7N6,6Ǥcly` , \~ ^YA}ܑP~G=!U` +1st,!eԦ�N4hλ;<:<_(w^n);~b3{JxAooc} Cʛ.KWk<6vޟ 3Kvt?8Ss$fϰ;O~dYS1VYDGEpwT^&ο;:6Awi$9wqG& DGV6q3߹5e=+' +Π7֚'Q(PySybXY<~tn"Ű#t6wZxa_ŵ4,V.stj>/4CMV6)meDۦ/:`?8r>5NCSMS>6|uH0ƾ0_wcU=ꝯl\v˖KpFt痛ʈ6a1\[kJ_:_9&CO k/'g(PySyb3kV-߳m2oimQm9<Οʘw'1N4[#h͛S^ +UFeW !ơ/v*_u]#`o5c߯|;d㞐1R{]yV5 'c4sY&0+HשĬvE09)g 6/ZZw}4C3; -{Y�@7t=4ACʛP Fb49o LIZ~2ղ-#Y? U:r]Gj}|j#tA5:be TT?Fr+齊~&cQW=!{z>+o9d|',W>)Ղ +t@7KēAʛSG_0jS�|ٰw}`|8q=R;S|zj+{K: #$?ΗV x:(PyS 15]<6}qOay\\-6\x<{L=8O晡>Xk 7@ፌ]%iL?hߥnf, νY0]S֚$CʛAx'/q[EM}g=2iq8_;o$p5Hij7n&sɆEӭ6|i#{f⧃sy\Ŝy+Xf9 =?(`b1ʫZgmӝoϦd;{M<98oϥd"w<S%3ATT?b`0-}kQѿDM88Y<O֚"CʛA L~5K3:$n 9uKl!8op^87k wPA2 JfըqM: +1 +: aTP3E X/2B,^dqk\HFMf$8aOj2?RN"t S}7ws 9&/a3U5)Zh.U}=S_{;nlg| ?|"~f ?#A}k{'L]-mz[%= >݈{v?-K&_p$? 2kYRUvQA5;)_>NM}|?  !�{1~h;GS*IoѨ: ]V3]EٱVꡞS.8C$y}kCn{y6-Ġ//KtUMۇG'K}~S%`/͝G٠碼< +m-Nc ]'<:U=Rlu7"Yjm^XU zo{_Q_7I}1ACW^xDlwLx?T-zN~1+kƒCy'I|�93d Y~ smZ !7t}v+|\jZ(W@}U<>jgdߌ!3ğsh0>#�>?<ܘa }2}kѨ:KeYΣ\kٺkӮhUh>iөo5�{4~Vy?KWF}~ G! +;3[#_Lzc#YӕjI _g/=L|>7mWJ۠Cs M7ݧ?*뢈?'8h<47h4^7@8<v!a:&8V}*/R;_g06z,LmYrMimަzn:Ӟi¯Oyh-Q};QT?Ôh|4No83 c>>#E$Ha+GEбy3gYd{Ug&g?'&Ueז)m?gZ_+ǎ)dW^dQ/7_t꡺+Oxh\<Σu~�3uX8XH='V]Csyڼ0qUsAw <6řs*O5)!M ew_?}=q:~0rYT/=>Cu>:z�Xc+.Gؘmb#YӕjI յqŇl0`  Ѻ �{a+x6-ם;ݧ~@Z4Ҭc#$Lޞ>  buh?pK5CU&������`<mN.7d޲Y!M{^UjUJHsDڦ\S������aez,=1?7_tG a3SppHG����������������������స +,/#WojT]y!|߱cJRpU5wsJΝT-}:Wẍ. y3gÇ\WTu׫OEdsd7Xˊ:j+.8;ɣinU 3]E1z&v~4烡͢yڏzfŹ8 iorwl]#ްM�~`.+Zե4ƼhMsI^۴3nđvi,Wh='(8fQ'[Ma pa-:&)&Vd/4O΃ǎIAC<u3IdҢ'RS'jGM| )ei"X_~v<BЬw"#~iH(d)Yx>;~FG34h>3_߀ak7_{iIscǣB]ڴ %;4e2Q='!=GuOxpkǔ?V/ y<B~)5K/JLI{o~͜}_לاB"iI *4mcCqLa}76<ve=[<7L55BhT%2_1(}yiAf8}P[-7߿$(ޕwQxAXGjܿo'^Hs7_دJЫ*Iaǎ+ͦL27'?:ƚ*iёbm?BFc#Y\+/= ڱT0HLE{)7<DSV]R| ) yZuaڿqŇeR +`p">*څ<ݲrkxH $T^<vvƭwVm61uO8Zz&~Ղ2ǟ՜ΏJXeE@BwZyFs1p&.)j/+ +60]۵au m؈e߱c<́^v:򟺊#}1:ه- +6K3qg8}jE7Q#̈M$FM* ԭt7!nc +HK[noۢ "?jT4;[^ 4}6}çn%Wg&!]-O5<Ϛ~S%v2Dn25돳 {6g3H${n`e32ڦ5kCcYVW=0/! EO>3iľ~N ={.|аc'SG'M?Vݿ4d}o]~:pxfPj粞᳌Kn~;ٚ 3{bZ K3[7<]<𝦚jlfɥ*.*jm>9mMƣӦ5kxi qU>>uG6irtpcɶ#GsIqqhL֫>?8t/[`\ꪲ(,1c+[f4]bBXS) +A|72uͮr +򢣇^wW f~12}xya؛Ϛyv/=hifqQQꗷTM~^"{\}.]neOwYƌ%?>޾N*yͦ˹q_oNj}5ܙiİN-goܲEtGҒĸq !ӢLGW^Xr_V;lIhy%oʌlسt:+VNewp1ꪬ9?9vOƌ%u* U;szj\Gظqb{Hnex̘Fg?}=yXQq]_|(/SmB^ ld<r;Iׁ}/m\a!UOGZZ͛yKך߄w~rrxw\͓u{woqĮm[o:ՙӦ1cI~|Ft:a;X{»r=-.épOPvݤq͈}; +`S%%%99#M7ce<2[`޿wc/<</gqX>?/37z>{&?om|AAfȏ +UM? 9^4gL5V����������������������������������������������������������������������������������������������������������������������������? `�_ni endstream endobj 28 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4354/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HNIDQ{d}p硪vG^#)_^$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItC+:tK!=iHOD>N|;KCvއ(/9/nr:eo'G`9r'G|O>j/nއX3+S3+S3+S3+S3+S3+S3+S3+S3+S3+S3+S3+S֎Њ85C$N*S;<-4C$.*KK̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[?s`r +82C$w +}yٕ%qcއVI{81C$N#s^veɾiĭ%fVĭ%fVĭ}|/ /idwDOI̬L[K̬L[K̬L[K̬L[K̬LA[{YrvxZ.gkއ֋}h}hy"l5B}翣SikA3>@j"ckއI[Z-ik#'EN-2EN-2EN-2EN-2ENL<KL<KL<KL<KL<K;2c+MBc+MBc+MBc+MBc+MЎʒʒʒʒʒ#5,6,6Σ-}x( vU#stK>"?I;GgVrt>RN}x)zJn/EZ(x'#FDFGf.x#͔)څHmD%a}qw>R�X{GȞw#,=#ɩۈ-L%ύt&{ 1<@Wuh w ]F|sҥ˿mHcd9W5B5pЪϙrت엌Wl_*~#>^pðtB ?D=Yb˶< XI~se;kSP+ֻ۪>d?9.67;=в.C7VjkѭìZztmm( +mhXS]q3{Ţ֬&; N[K&yCtڭ%c+ ;ٮL@&ybЏo. "+wϒi^O-6q6tʲe:/,F)vrvA?T[ous[V8{SƶovD=Y)m~ٳ3vge';cӾΧ aӮN q4u5Oڵi~M̶\KO"-gR_um]iR&DysxҾL^/eۅ>Я<Eۄ藞gAC?;%Gg@ߣ}?{dO^]~d/*?r[9yg�=)/gqٮ۔6.^NIGCO{}͛Sؽ|g/y>°y`8{K;wDr>B9tARs'CGx-}lRB̪הQǾPwtO:E8+i8%0e+aƾn䎻i/۹l&řg[3I& [fd%>W׼bp1٥ƕ,f wau+ ^|ÚVu3FUtK3sS *W{{mPɼ0c +Վ&elH5 +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ += IѶ kQɲ;K^3އ�K_wx>`W?RE%5᧤LMj +<o|I9(SSN0sL0sT,NsT,N taj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV_.LSR0OI +:>'R//E!:N˟J =N _Cz"W7Y֣CKV*5/Y< ?.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=K>GeR39EER7/zM+(䂁0ᔅg;|Q"ur5t`?[;iGa[CUɰT3˂-/B9{,CY6އ(2Q2>>CUѴԆm1˦l\*+T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT˪hZj6uU2,ayKC�ǜ> к*?dMKm?.JZ<l8.GO7ce~}6[^wRGa[cMٸT-WЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]gMT;MԈٸxc}�1K!t _u _u >!�Ww^Uv?ݦ>$I Vkw<~oK>]j�ߗe۸?g5.o: wM?dJ{?n5*~|Ӌ{} �<v۫S`}lL>ׄ}˻:WBq+sY{9gWli>0=l{"r"_#O<wnc}u〞+;Ly/6ϭ|~x] +Y>s/w ?~fI$I$I$I$I$I$I$I$I$I$I$I$I$I$I$Ie~ 0�vm endstream endobj 27 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4149/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnQO3C3 Ylv $76[uM$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I'Ni}H4~o~%x>_cæM! +&R?9}'ⓣ߿>V|?\ɾoVoVoVoVoVoVoVoVoVoVoVoV֖ģ)15߇CGILm >t|:Jbi7+Sbk7+Sbk7+Sbk7+Sbk7+Sbk7+Sbk7+SbkxD&12߇OWw$6Qss񊒘CGILy+KZʔZʔڧ?>/?1oi>|u-MʔZʔZʔZʔZڟSnV߇ӚCNjim}x)!3}:ZHk!2Z[+*]ZPf_}Jd#5CGKj}dEDEDEDED-W+OfiW+OfiW+OfiW+OfiW+OfiKJZJZJZJZJzvzvzvzvzv$$$$$-+Gne+Gne+Gne+Gne+GneKJYJYJYJ|2$7|2$7|2$7|2$7|2$7$щEщEщ-k9Й:>@y@\Ud\K~B7(Af[S  MH߇֣:Ye߯C'SCgͥw#CtRYzC2D]/I%W>$|):?%[tFM>I5u <**/K}xG^R?5}< b#ҷ#/}@?=>6<.A}lyy9]cJ.HSOgџ:v/wx邟[7?A1vOjٯA4vo{==)M =%?_%?,-W!vN5j;wtUm_R;'S]]o + 颟Ⱦw?vK=?lߕes}َ!z{ߏ{=˾mIu!DBvRtl/ïiF]Џ>o u]H?e@]Ӟ=Ձ?/a:`cSԁ}O|jjA>F*tc`B>F*tc`B>F*tc`B>F*tc`BRv.Ahu*ڰo~M+J*l|>t<m| o-߇0h>Ao~STMթZjÖRv.A=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йo]KmYJ:l߸> }F~!�[=_{)5*aO\̤R#xӅ236[I*`[ϤS.֧c&SɱTM `B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`BKT~KT~KT~K~_g>D@h}% }w.|?! +{p6t+7 +oVn*~!3T}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}SٹT թZjÖJz0Uו_IGj}*9o>KuYq[ԉ}.\|ՅCl>Da:i (ijH;)=Ts *Ү>>4!UѴԆm1MٸT-WЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]#vi Ca[C[z?溤!�Ya[Ci OܭJZ|jv;{mx]r>4=cagp^wdXVݦl\*+T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUTgvrQv�o,7ŒR#f>.x;]?mއ�`xpk>Dy y^wIߌ:x^wIߌ:>6C�l!?{Ui~%KӖ>$I Vk9;{ %Sme2>2~yg?<tyE OM]?dI{Y?x "#sUo1'{}{5:L?>_N1z} }lwuHM΅WpY0??>&we[͎^ϱ і 16y>ߙ;nc|yO|9虹a;>t{|1<f}eGSO\f˩g$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IT��kG endstream endobj 26 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 6 0 obj <</Intent 29 0 R/Name(Layer 1)/Type/OCG/Usage 30 0 R>> endobj 29 0 obj [/View/Design] endobj 30 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 13 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 12 0 obj <</LastModified(D:20170110151935Z)/Private 31 0 R>> endobj 31 0 obj <</AIMetaData 32 0 R/AIPDFPrivateData1 33 0 R/AIPDFPrivateData10 34 0 R/AIPDFPrivateData100 35 0 R/AIPDFPrivateData101 36 0 R/AIPDFPrivateData102 37 0 R/AIPDFPrivateData103 38 0 R/AIPDFPrivateData104 39 0 R/AIPDFPrivateData105 40 0 R/AIPDFPrivateData106 41 0 R/AIPDFPrivateData107 42 0 R/AIPDFPrivateData108 43 0 R/AIPDFPrivateData109 44 0 R/AIPDFPrivateData11 45 0 R/AIPDFPrivateData110 46 0 R/AIPDFPrivateData111 47 0 R/AIPDFPrivateData112 48 0 R/AIPDFPrivateData113 49 0 R/AIPDFPrivateData114 50 0 R/AIPDFPrivateData115 51 0 R/AIPDFPrivateData116 52 0 R/AIPDFPrivateData117 53 0 R/AIPDFPrivateData118 54 0 R/AIPDFPrivateData119 55 0 R/AIPDFPrivateData12 56 0 R/AIPDFPrivateData120 57 0 R/AIPDFPrivateData121 58 0 R/AIPDFPrivateData122 59 0 R/AIPDFPrivateData123 60 0 R/AIPDFPrivateData124 61 0 R/AIPDFPrivateData125 62 0 R/AIPDFPrivateData126 63 0 R/AIPDFPrivateData127 64 0 R/AIPDFPrivateData128 65 0 R/AIPDFPrivateData129 66 0 R/AIPDFPrivateData13 67 0 R/AIPDFPrivateData130 68 0 R/AIPDFPrivateData131 69 0 R/AIPDFPrivateData132 70 0 R/AIPDFPrivateData133 71 0 R/AIPDFPrivateData134 72 0 R/AIPDFPrivateData135 73 0 R/AIPDFPrivateData136 74 0 R/AIPDFPrivateData137 75 0 R/AIPDFPrivateData138 76 0 R/AIPDFPrivateData139 77 0 R/AIPDFPrivateData14 78 0 R/AIPDFPrivateData140 79 0 R/AIPDFPrivateData141 80 0 R/AIPDFPrivateData142 81 0 R/AIPDFPrivateData143 82 0 R/AIPDFPrivateData144 83 0 R/AIPDFPrivateData145 84 0 R/AIPDFPrivateData146 85 0 R/AIPDFPrivateData147 86 0 R/AIPDFPrivateData148 87 0 R/AIPDFPrivateData149 88 0 R/AIPDFPrivateData15 89 0 R/AIPDFPrivateData150 90 0 R/AIPDFPrivateData151 91 0 R/AIPDFPrivateData152 92 0 R/AIPDFPrivateData153 93 0 R/AIPDFPrivateData154 94 0 R/AIPDFPrivateData155 95 0 R/AIPDFPrivateData156 96 0 R/AIPDFPrivateData157 97 0 R/AIPDFPrivateData158 98 0 R/AIPDFPrivateData159 99 0 R/AIPDFPrivateData16 100 0 R/AIPDFPrivateData160 101 0 R/AIPDFPrivateData161 102 0 R/AIPDFPrivateData162 103 0 R/AIPDFPrivateData163 104 0 R/AIPDFPrivateData164 105 0 R/AIPDFPrivateData165 106 0 R/AIPDFPrivateData166 107 0 R/AIPDFPrivateData167 108 0 R/AIPDFPrivateData168 109 0 R/AIPDFPrivateData169 110 0 R/AIPDFPrivateData17 111 0 R/AIPDFPrivateData170 112 0 R/AIPDFPrivateData171 113 0 R/AIPDFPrivateData172 114 0 R/AIPDFPrivateData173 115 0 R/AIPDFPrivateData174 116 0 R/AIPDFPrivateData175 117 0 R/AIPDFPrivateData176 118 0 R/AIPDFPrivateData177 119 0 R/AIPDFPrivateData178 120 0 R/AIPDFPrivateData179 121 0 R/AIPDFPrivateData18 122 0 R/AIPDFPrivateData180 123 0 R/AIPDFPrivateData181 124 0 R/AIPDFPrivateData182 125 0 R/AIPDFPrivateData183 126 0 R/AIPDFPrivateData184 127 0 R/AIPDFPrivateData185 128 0 R/AIPDFPrivateData186 129 0 R/AIPDFPrivateData187 130 0 R/AIPDFPrivateData188 131 0 R/AIPDFPrivateData189 132 0 R/AIPDFPrivateData19 133 0 R/AIPDFPrivateData190 134 0 R/AIPDFPrivateData191 135 0 R/AIPDFPrivateData192 136 0 R/AIPDFPrivateData193 137 0 R/AIPDFPrivateData194 138 0 R/AIPDFPrivateData195 139 0 R/AIPDFPrivateData196 140 0 R/AIPDFPrivateData197 141 0 R/AIPDFPrivateData198 142 0 R/AIPDFPrivateData199 143 0 R/AIPDFPrivateData2 144 0 R/AIPDFPrivateData20 145 0 R/AIPDFPrivateData200 146 0 R/AIPDFPrivateData201 147 0 R/AIPDFPrivateData202 148 0 R/AIPDFPrivateData203 149 0 R/AIPDFPrivateData204 150 0 R/AIPDFPrivateData205 151 0 R/AIPDFPrivateData206 152 0 R/AIPDFPrivateData207 153 0 R/AIPDFPrivateData208 154 0 R/AIPDFPrivateData209 155 0 R/AIPDFPrivateData21 156 0 R/AIPDFPrivateData210 157 0 R/AIPDFPrivateData211 158 0 R/AIPDFPrivateData212 159 0 R/AIPDFPrivateData213 160 0 R/AIPDFPrivateData214 161 0 R/AIPDFPrivateData215 162 0 R/AIPDFPrivateData216 163 0 R/AIPDFPrivateData217 164 0 R/AIPDFPrivateData218 165 0 R/AIPDFPrivateData219 166 0 R/AIPDFPrivateData22 167 0 R/AIPDFPrivateData220 168 0 R/AIPDFPrivateData221 169 0 R/AIPDFPrivateData222 170 0 R/AIPDFPrivateData223 171 0 R/AIPDFPrivateData224 172 0 R/AIPDFPrivateData225 173 0 R/AIPDFPrivateData226 174 0 R/AIPDFPrivateData227 175 0 R/AIPDFPrivateData228 176 0 R/AIPDFPrivateData229 177 0 R/AIPDFPrivateData23 178 0 R/AIPDFPrivateData230 179 0 R/AIPDFPrivateData231 180 0 R/AIPDFPrivateData24 181 0 R/AIPDFPrivateData25 182 0 R/AIPDFPrivateData26 183 0 R/AIPDFPrivateData27 184 0 R/AIPDFPrivateData28 185 0 R/AIPDFPrivateData29 186 0 R/AIPDFPrivateData3 187 0 R/AIPDFPrivateData30 188 0 R/AIPDFPrivateData31 189 0 R/AIPDFPrivateData32 190 0 R/AIPDFPrivateData33 191 0 R/AIPDFPrivateData34 192 0 R/AIPDFPrivateData35 193 0 R/AIPDFPrivateData36 194 0 R/AIPDFPrivateData37 195 0 R/AIPDFPrivateData38 196 0 R/AIPDFPrivateData39 197 0 R/AIPDFPrivateData4 198 0 R/AIPDFPrivateData40 199 0 R/AIPDFPrivateData41 200 0 R/AIPDFPrivateData42 201 0 R/AIPDFPrivateData43 202 0 R/AIPDFPrivateData44 203 0 R/AIPDFPrivateData45 204 0 R/AIPDFPrivateData46 205 0 R/AIPDFPrivateData47 206 0 R/AIPDFPrivateData48 207 0 R/AIPDFPrivateData49 208 0 R/AIPDFPrivateData5 209 0 R/AIPDFPrivateData50 210 0 R/AIPDFPrivateData51 211 0 R/AIPDFPrivateData52 212 0 R/AIPDFPrivateData53 213 0 R/AIPDFPrivateData54 214 0 R/AIPDFPrivateData55 215 0 R/AIPDFPrivateData56 216 0 R/AIPDFPrivateData57 217 0 R/AIPDFPrivateData58 218 0 R/AIPDFPrivateData59 219 0 R/AIPDFPrivateData6 220 0 R/AIPDFPrivateData60 221 0 R/AIPDFPrivateData61 222 0 R/AIPDFPrivateData62 223 0 R/AIPDFPrivateData63 224 0 R/AIPDFPrivateData64 225 0 R/AIPDFPrivateData65 226 0 R/AIPDFPrivateData66 227 0 R/AIPDFPrivateData67 228 0 R/AIPDFPrivateData68 229 0 R/AIPDFPrivateData69 230 0 R/AIPDFPrivateData7 231 0 R/AIPDFPrivateData70 232 0 R/AIPDFPrivateData71 233 0 R/AIPDFPrivateData72 234 0 R/AIPDFPrivateData73 235 0 R/AIPDFPrivateData74 236 0 R/AIPDFPrivateData75 237 0 R/AIPDFPrivateData76 238 0 R/AIPDFPrivateData77 239 0 R/AIPDFPrivateData78 240 0 R/AIPDFPrivateData79 241 0 R/AIPDFPrivateData8 242 0 R/AIPDFPrivateData80 243 0 R/AIPDFPrivateData81 244 0 R/AIPDFPrivateData82 245 0 R/AIPDFPrivateData83 246 0 R/AIPDFPrivateData84 247 0 R/AIPDFPrivateData85 248 0 R/AIPDFPrivateData86 249 0 R/AIPDFPrivateData87 250 0 R/AIPDFPrivateData88 251 0 R/AIPDFPrivateData89 252 0 R/AIPDFPrivateData9 253 0 R/AIPDFPrivateData90 254 0 R/AIPDFPrivateData91 255 0 R/AIPDFPrivateData92 256 0 R/AIPDFPrivateData93 257 0 R/AIPDFPrivateData94 258 0 R/AIPDFPrivateData95 259 0 R/AIPDFPrivateData96 260 0 R/AIPDFPrivateData97 261 0 R/AIPDFPrivateData98 262 0 R/AIPDFPrivateData99 263 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 32 0 obj <</Length 1017>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC1.pdf) %%CreationDate: 10/01/2017 15:19 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -559.5688 122.8096 1.68 2452 1484 18 0 0 266 275 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 33 0 obj <</Length 12416>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 12264 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD7FFF7DFD %27FFA8FD57FFA8A8FD7EFF7DFD7FFF7DA8FD26FFA8A8FD56FF7DFD21FFA8 %FFA884595A7DFD09FFA8FFA87DA8FFA8A8AFFD45FFA17DFD1EFFA8847E5A %7E5A5A5A7EFFAF59FD06A87D7D7D527D5227525252A8FD42FFA8767DA8FD %18FFA87D84535A535A5A5A545A5A5A76FFFFAFA8FFA8FFA8FFA8A87DA8A8 %A87DA87DA8A8FD43FFA877A8FD16FF84A9595A5A7E5A7F5A7E5A7F5A5A59 %CAFD57FF7DA17DFD11FFA8A87EFD105AA1A1FD57FFA8A1A1A8FD0CFFA884 %845A5A54FD045A7E5A7E5A7E5A7E5A7E5A7E5A7EA1CAFD56FFA876A1A17D %FD06FFA8FF7D84535A535A545A5A5A545A5A5A545A5A5A545A5A5A545A5A %5A77C9A1FD57FFA8A1CA7DA9FFFFA9A87E7E5A5A5A7F5A7E5A7F5A7E5A7F %5A7E5A7F5A7E5A7F5A7E5A7F5A7E59CAA1CAFD57FF7DA1A1A1537E537E54 %FD045A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DA1CA %A1FD0DFFA8FD49FFA8A1CAA17E5A5A5A7E5A7E5A7E5A7E5A7E5A5A5A7E5A %5A5A7E5A5A5A7E5A5A5A7EFD045AA1CAA1CAFD56FFA876A1A1C37D5A5A5A %545A5A5A545A595A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A53C3 %A1A1A1FD0DFFA8FD49FFA8A1CAA1CA7D5A5A7F5A7E5A7F5A7E5A7F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A59A1A1CAA1CAFD57FF7DFD05A153FD %065A7E53FD145A7DA1CAA1A1A1FD0DFFA8FD49FFA8A1CAA1CAA1A15A7E5A %7E5A7E537D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7EA1CAA1CAA1 %A7FD55FFA8A87DA1A1C9A1A1A17D5A5A545A5A5A535A5A5A545A5A5A545A %5A5A545A5A5A545A5A5A77C9A1A1A1C9A1FD0DFF7DFD49FFA8A1CAA1CAA1 %CAA15A5A7F5A7E5A7D5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A59CAA1 %CAA1CAA1CAFD0CFFA8A8FFFFA8FFAFFFA8FFFFA8A8A87D527DA87D7D7DA8 %A8FD34FF7DA1A1CAA1A1A1C977FD045A7E767EFD115AA1A1CAA1C3A1CAA1 %FD09FFCFFFFF7DA1FFA87D7DA87EA87DA8FD047D527D7D52277D527DFD34 %FFA8A1CAA1CAA1CAA1CA595A5A7E5AA17D7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E547DA1CAA1CAA1A27DA17E847DA884A984A984847E7E7DCAFD0CFFA8 %FD3AFFA8A87DFD04A1C9FD04A15A5A545A76A1535A535A54FD045A7E595A %535A5353537E5A5A5A7E5A5A535A535A2F5A545A545A545A53C3A1FD49FF %A8A1CAA1CAA1CAA1CAA17D5A7F59A1A17D5A7E5A7F5A7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5AA2A1CAFD49FF7DFD %04A1CAA1A1A1CAA17D5A7E76C97DFD225A59A1C9A1FD49FFA8A1CAA1CAA1 %CAA1CAA1CAA17E5AA1A1C9535A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAFD47FFA8A87DA17DA176A1 %76FD04A1C9A17D76CAA1A12F5A5A5A545A5A5A545A5A5A545A5A5A545A5A %5A545A5A5A545A5A5A545A5A5A53C3A1A1A1FD49FFA8FD04A176A17DA1A1 %CAA1CAA1A1A1CAA17E5A7E5A7F5A7E5A7F5A7E5A855A7E5A855A7E5A855A %7E5A855A7E5A855A7F5AA2A1CAA1CAFD49FF7DA1A17D527D76A1767676CA %A1A176CAA1C3A1FD0A5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A %7EA1CAA1A1A1FD0FFFA8FD38FFA8A7A1A7FD05A1CAA1A1A1CAA1A1A1CAA1 %CA7D5A5A7E5A7E5A7E5A7E597E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %5A7DCAA1CAA1CAFD48FFA87DFD07A87DFD05A876C3A1C9A1A1535A5A5A54 %5A5A5A547E5A5A545A5A5A545A5A5A545A5A5A545A5A5A53FD04A1C3A1FD %0FFFA8FD47FFA1A1CAA1CAA17E5A7E5A7F5A7E5A7F7E7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5AA2A1CAA1CAA1CAFD56FFA876C3A1CAA1C3A1FD08 %5A5959FD0E5A7E5A7DA1CAA1A1A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CAA1 %CA7D5A5A7E5A7E5A5A53595A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1 %CAA1CAA1CAFD0EFFA8FD48FF76C9A1A1A1C9A1A1535A5A5A545A5A53525A %5A5A537E535A54FD075A53C3A1A1A1C9A1A1A1FD0EFFA7A8FD46FFA1A1A1 %CAA1CAA1CAA1A15A7E5A7F5A7E777D5A7E5A7F5A7E5A7E5A7E5A7E5A5A59 %CAA1CAA1CAA1CAA1CAFD0EFF7DFD46FFA8A876CAA1A1A1CAA1A1A17DFD05 %5A7D77FD0B5A537E537DA1A1A1C3A1CAA1A1A1FD0DFF7D7DA8FFFFFFA8FF %FFFFA8FFA8A8A8FF7D7EA8FFFFA8A8FD33FFA1A1CAA1CAA1CAA1CAA17D5A %7E5A5A7DC37D5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E597E7DA1A1CAA1CAFD %0CFFA87DA1FFFFFFA87D7DA8A8A87EA852FD047DA8FD045228A8FD31FF76 %C3A1C9A1A1A1C9A1C3A17E5A5A5A7DA1A1535A5A5A545A5A5A545A5A5A54 %5A5A5A545A5A5A597E7DFFA8FD0AFF8477C9A8FFFFFFA8FD05FFA8A87DFD %05A87DA87D7DA8FD30FFA8A1A1CAA1CAA1CAA1CAA1CAA17E5A7E7DC3A17E %5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7E84A8A8FD07FF %7DCAA1FD48FF7DA1767DA17D7D7DA1C3A1CAA17E367DA1C377FD195A545A %5A7E7DA8FFFF7D7DA1A7A8FD46FFA8A1A1A17DCAA1C9FD05A1CAA17E53C9 %A1A1597E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7EFD05 %5A7E5A7EA1CAA1FD48FF76CAA17676A1A1A176A176A1A1C3A17DA1C9A17D %305A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A %5A5A7DC9A1A1A8FD46FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1CA7CCAA1CA %A17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A5A7DCAA1CAA1FD48FFA8FFFFFFA8FFFFA8A8FFFFFFA8FFFFA1A1CAA1C3 %7DFD0A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1A7A8 %FD0FFFA8FD46FFA1A1A1CAA1C9595A5A7E5A7E5A7E5A7E5A7E5A7E5A5A5A %7E5A5A5A7E5A5A5A7E5A7E5A7EA1CAA1CAA1FD57FFA8A1A1A1C9A17D2F5A %5A5A545A5A5A545A595A545A5A5A545A5A5A545A5A5A545A5A5A77C9FD04 %A1A8FD0FFFA8FD46FF7DA1A1CAA1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F5A5A7DCAA1CAA1CAA1FD57FFA7A1C3A1CAA1C3 %7DFD085A7E53FD0F5A53A1A1CAA1A1A1A7A8FD0FFFA8FD46FF7DA1A1CAA1 %CAA1C9775A5A7E5A7E5A7E537D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1 %CAA1CAA1CAA1FD57FFA1A1C9A1A1A1C9A1A1535A5A5A545A5A5A535A5A5A %545A5A5A545A5A5A545A5A7DA1C9A1A1A1C9A1A1A8FD0FFF7DFD45FFA87D %C9A1CAA1CAA1CAA17D5A7E5A7F5A7E5A7D5A7E5A7E5A7E5A7F5A7E5A7F5A %5AA1CAA1CAA1CAA1CAA1FD0FFFA8A8FD46FFA1A1CAA1A1A1CAA1C3A17DFD %065A767E5A5A537E5A595A7E5A5A5A7E7DC3A1CAA1C3A1CAA1A1A8FD0EFF %7DA1FD46FFA1A1A1CAA1CAA1CAA1CAA17E5A7E5A7E5AA17DFD045A7E5A7E %5A7E537E59A27DA1A1CAA1A1A1CAA1FD0EFFA877CAFD46FFA1A1C3A1CAA1 %C3A1C9A1C3A17E5A5A545A76A1535A5A5A54FD075A54FD055A537D7D7E7E %847DA8A8FFA8FFCFFD05FF77A1A1FD46FFFD06A176A1A1CAA1CAA17E5A7F %59A1A17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7FFD055A7E5A7E %598484A984A8A8A1A1CAFD46FFA8A1A17DA1A17D7DCAA1C3A1CAA17E547E %76C97DFD1F5A545A5459A1C9A1FD46FF7DA1A17D76A1A1A17DA17DA1A1CA %A17E53A1A1C9535A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A5A7DCAA1CAFD43FFA8FFFFA176A1A17D76A1A1A176 %FD04A1C3A17D76CAA1A12F5A5A5A545A5A5A545A5A5A545A5A5A545A5A5A %545A5A5A545A5A5A545A5A5A53C3A1A1A1FD46FFA8CAA8CAA8CAA8CAA7CA %A8CAA8CAA8CAA1A1A1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7F5A7E5A7F5A7E5A7F5A7E5AA2A1CAA1CAFD56FFA876CAA1C3A1FD0C5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7EA1CAA1A1A1FD57FFA1A1CA %A1CA7D5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E7DCAA1CAA1CAFD10FFA8FD46FF76C3A1C9A1A1535A5A5A545A5A5A54 %5A535A545A5A5A545A5A5A545A5A5A545A5A5A53FD04A1C3A1FD0FFFA8FD %46FFA8A1A1CAA1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5A7F5A7E5AA2A1CAA1CAA1CAFD10FFA8FD45FFA876C3A1CAA1C3A1FD %085A7EFD0F5A7E5A7DA1CAA1A1A1C3A1FD3DFFA9A8FFA8A87DA8FFFFA8FD %0FFFA8A1A1CAA1CAA1CA7D5A5A7E5A7E5A7E5A7D5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A5A7DCAA1CAA1CAA1CAFD10FFA8FD2CFF5252A87D5227527E27 %53275952A87DA87DA87D7D7DFD05FF76C9A1A1A1C9A1A1535A5A5A545A5A %5A537E5A5A545A5A5A545A5A5A545A5A5A53C3A1A1A1C9A1A1A1FD0FFFA8 %A8FD2CFFA87DFFA8A87DFD07A8FD0CFFA1A1A1CAA1CAA1CAA1A15A7E5A7F %5A7E5A7D597E5A7F5A7E5A7F5A7E5A7F5A5A53CAA1CAA1CAA1CAA1CAFD0C %FFA8A884A2A8FD44FFA8A876CAA1A1A1CAA1A1A17DFD065A527DFD0D5AA1 %A1CAA1A1A1CAA1A1A1FFFFFFCAFFFFA87EA9847E535A545A7DFD47FFA1A1 %CAA1CAA1CAA1CAA17D5A7E5A7E5A7D7D7E5A7E5A7E5A7E5A7E5A7E5AA2A1 %CAA1CAA1CAA1CAA1A87EA9847E597FFD055A7E5A7E59A1A8FD46FF76C3A1 %C9A1A1A1C9A1C3A17E5A5A545A53A1535A5A5A545A5A5A545A5A7DA1C9FD %04A17D7E535A5A5A2F5A5A5A545A5A5A545A5A5A547DA1CAFD45FFA8A1A1 %CAA1CAA1CAA1CAA1CAA17E5A7F5A7DA1A15A7E5A7F5A7E5A7F5A7EA1A27E %7E597F5A5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA8FD46FF7D %A1767DA176767DA1C3A1CAA17E5A7E53A1A17D5A5A5A7E595A5A5A537E54 %FD175A53C9A1CAFD45FFA8A1A1A17DCAFD07A1CAA17E5A7DA1CA775A595A %5A7E5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E %59A1A1CAA8FD46FF76CAA17676A1A1A176A176A1A1C9A17E52A1A1A1535A %5A5A545A5A5A537E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7DA1A7A1FD46FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA17E %5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7EA1CAA1CAA8FD46FFA8FFFFFFA8FFFFA8A8FFFFFFA8FFFFA87CA1A1C3 %A17EFD075A7E53FD155A53C9A1A1A1FD0DFFA8FD49FFA8A1CAA1CA7D5A5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1 %CAA1CAA8FD56FF7DA1A1C9A1A1535A5A5A545A5A7E595A5A5A545A5A5A54 %5A5A5A545A5A5A545A5A5A547DA1A1A1C9A1CAFD0CFFA8FD49FFA8A1CAA1 %CAA1A25A7E5A7F5A7E597D5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A %7EA1CAA1CAA1CAA8FD56FF7DA1A1CAA1C3A17EFD065A53FD135A53C9A1A1 %A1CAA1CAFD0CFF7DFD49FFA8A1CAA1CAA1CA7D5A5A7E5A7E5A7D5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA1CAA8FD08FFA87EA97E %A8FD2FFFA87D7DA87D7D277DA87D527D7DA8FFFFA8FFA8FFA8FD05FF7DFD %04A1C9A1A1535A5A5A547E52FD055A545A5A5A545A5A5A545A5A5A307DA1 %A1A1C9A1A1A1FFFFFFA8FFA8847E7E535A305AA1FD30FF527D7DA853527D %7DFD04527DFFFD05A87E7DFD04FFA8A1CAA1CAA1CAA1CA597E5A7F5AA17D %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CAA1CA7DA9847E5A %7E5A5A5A7E5A7F7DCAFD31FFA8FD07FFA8FD0EFFA876FD04A1CAA1A1A17D %FD045A7DA153FD0C5A7E5A59A1A1777E7D7E535A5A5A54FD095A53A1A7FD %49FFA8A1CAA1CAA1CAA1CAA17D5A7E5AA1A17D5A7E5A7E5A7E5A7E5A7E59 %7E5A7E597EFD055A7E5A5A5A7E5A7E5A7E5A7E5A7E5A7DA1CAFD49FF7DA1 %A1C9A1A1A1C9A1C3A17D5A7D76CA775A5A7E535A535A545A535A5A5A54FD %075A545A5A5A545A5A5A54FD055A7DA1A1FD49FFA8A1CAA1CAA1CAA1CAA1 %CAA17E5AA1A1C9537F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F53CAA1CAFD47FFA8FF7DFD05A176A1A1C3A1CA %A17D76CAA17DFD205A53FD04A1FD49FFA8A1A1A1A8A1A176CAA1CAA1CAA1 %A1A1CAA15A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7DA1CAA1CAFD49FF7DA1A17D76A17DA176A176A1A1A176C3 %A1C977FD055A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A54FD055A %7DC3A1C3A1FD49FFA8A1C9FD09A1CAA1A1A1CAA1CA597F5A7E5A7F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F7DCAA1CAA1CAFD49FF %7DA8A8CAA8CAA8A8A1CAA8A8A7A87CC3A1CAA1A154FD1B5A53FD04A1C3A1 %FD57FFA1A1CAA1CAA17E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7DA1CAA1CAA1CAFD56FFA876CAA1A1A1C97DFD055A545A %5A5A545A5A5A545A5A5A545A5A5A54FD055A7DC3A1C9A1A1A1FD56FFA8A1 %A1CAA1CAA1C9597F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A5B7DCAA1CAA1CAA1CAFD57FF76CAA1A1A1CAA1A153FD175A53FD04A1CA %A1A1A1FD40FFA8FFA8A87DA8A8FFA8FD0DFFA8A1A1CAA1CAA1CAA17D5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA1CAA1CA %FD3FFFFD047D5227FD0452277D52FFA8A87DA87DA852A8A8A176C3A1C9A1 %A1A1C9A159FD045A545A5A5A545A5A5A545A5A5A545A5A5A2F7DA1A1A1C9 %A1A1A1C3A1FD40FFFD04A87DA87DFF7DA8A8A8FD0AFFA8A1A1CAA1CAA1CA %A1CA7D7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CA %A1CAA1CAFD57FF7DC3A1CAA1A1A1CAA1C37DFD105A7E5A597DCAA1A1A1CA %A1A1A1C3A1FD56FFA8A1A1CAA1CAA1CAA1CAA1CA7D5A5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A5A7DCAA1CAA1CAA1CAA1CAA1CAFD55FFA8A876A1A17DA1 %A17DA1A1C9A1A1775A5A5A545A5A5A545A5A5A545A5A5A7DC9A1A1A1C9A1 %A1A1C9A1A1A1FD57FFFD04A1CAA1A176CAA1CAA1CAA15A5A7F5A7E5A7F5A %7E5A7F5A5A7DCAA1CAA1CAA1CAA1CAA1CAA1CAFD57FF76CAA17676A1A1A1 %76A176A1A1C97DFD065A7E5A5A547E7DC3A1CAA1A1A1CAA1A1A1CAA1A1A1 %FD56FFA8A1A1C3FD09A1C3A1C9A17D535A5A5A535A597DA1CAA1C3A1CAA1 %C3A1CAA1C3A1CAA1A8FD55FFA8A8A1A8A1CAA8A8A1A8A1A8A1CAA7A8A1A8 %A1A87D7E7E7D7DA8A1CAA1CAA7A8A1A8A1A8A1CAA7A8A1A8A8FDFCFFFDFC %FFFD0CFFFF %%EndData endstream endobj 34 0 obj <</Filter[/FlateDecode]/Length 14260>>stream +HWmoHG5^UM HsVт76I?~gok0 9& +س<;> ~F^רo]Ʒmר}c}LT<$r0!!zhv=;OFv +y}F�0vj C)Ktk[o7 ,W)Q_Ft`6>>?]0jڸf_ y)q-aNb|0x9 C,Yf䲤(5ְG}:N<VI6 u36oA m=c8V0V E8Nèy9RAsEL1MNeyQbEhnB,kP˙)(]a |gƛDZXd(aV7<7?qt6. W 0IK>UsUU{*JpU]$K7̇ӗ.Ҫ$4U5SKEkZMkӚ5d j'6,[fؔgkX5Uk^ymO׼-DfcY("aԺfͨmw|H̚v|*X^5jZ{DZ;IL9R,qE=y$$;FpM)rMdG3D9A[L\0v" +d Tm]UxdKL&@Ǎ@%NMx;jʨ9`(<[İO;5h䕡\[ǟϤz&=t9S9{HY dm�;xJwdʲ59APfZy𒷲^EK7 I{PX{`{w=TV$e= gnӪ@v'Qӻ.&CDWR۝> !g^3b-<w&kxa? RAπՕVg{eڣ/'IW`ryC8q)b$.Q}w'0ݢy(1 }2^TO/MkwԽPSZSƬ#X4 -CUa ]m]D>~7/ |mOWn4C>XꞴZmwƬp;`U ØяmrwmK;pM63eC9T! 7nׂ֙ ~G1{RU?  MN0ss?^0w+ +i$*HbΆ!^%cpCդC: )]2(s&TS{\?eyIcZ=xV\ZgOZ<!YЧa֛d\+ٰ|[RY"f!ѺȨ/,e8%NpSr. LFv; 9஻DKk+MnkHL=s2.Ks-q43ߌ #o:Cgb(O4=uhAQvjIW,o1I?8d/sN}?vd> rSI6v:ё |~7΃}j1Ϯ~ ;" j#B&)\(˩ÐF%O +5~dMYf]gFY]tGPI4߅/9: ?-8MsllsLg=Q;o'H,Ў ۑCLA/o8X`#t˜1$d'/_&.l1VG\3k~(O?Wv:Ʋ i5uc*1v=hR!Nof1P'^ܕHd44_^@&ԇ c/ٽ|81,=u� :>(PV +(++|3[UĨʂ */(<m BJIѫ1f d f#4Gf>]m�l}.SKk?M_8.Yr&Y<6Lc]ٌ[Up9_.Rѓ/^l QY>3˕5 qU/C-x.r^M] +lJ)lZzla!5%NXilmSo^2dчz4+0`wds{45]`<f&XjnU7[= * +Yd.d6v3s To Dq +B\BZۡ;e +9\2NP̝W*l̪4&GĻWq6ߓ'Ҽ+Є-Hr?$<odɲᣭ2e¬2`UY Va[Eez SXaxJ&/E켺;ʼnA˷T +z(bDeKEpVߺeU\E|i) QqSݼjˢyRd}XGCO X@ Bcw!Gb 7Πin-(JT0v6 +<_r֝߷^ +".Fm͈Nmpb''iZkhZHMROZ֫m_8:$}{/AOdȧWGD=ԛW܋0^F?gaѿm +~WZ +D@$ak<{%gף?~O|zP�̶Q(D CF@�RI[Rr9 xOh'7ѽTpsr3N8 + 6hr,|qb}<AC@ѹz(:CN=0c1\+"?!'K\.gÌ_M`& Cj%{y;sbvFd+Z8<*Ƨ +Qǃ  ,9Wyz4= T?uݒC٬[k�:<T?O:?78[h-竒23"Uw+*C6ƳĤ9)f ,UVxt3k�tfOuOԵ>CsA|_o>W+3{ܳ�>, +F)S)L 8סYŠ +dDazAZ{ ?kANW Zގ2_.)JT +nď +x@^( g6 Tm. |n}&oȵ%պ}ɺhpukyT|'h +&Z6Hћ tK:>r诠Q_P_Z:e&lY2z�h2{ 2JV,z|1OƜ OG/a3qlԭ[ZpwU<k[HxGIw^'AZ#gLS a\<θ@rsƣ`TV~_pR"[ZO&I6_6ʬDTr;HIu%plJKi.! +:q #&R+H}D "�W8ib4 HGU*T?d04q@u3Œ'tCuc7aJ}~� k3GpΤdQgqAdD"BQ헄KU;)T},N#X+ 0�J#UcQ"W&|\jL8MC.r6(mk59kƹXW%v$5;Bs'n! ;2-:1d0 țGUp=V=˴_Cc@U3B!TR_+PS1c6Hj}ɡ u'=a vP=k=4P kfx|xM#k Mߘt83vNR}WhgNf:q~2{.s3!:\c̃mx-i=jg_7Tr|̹}<{J}WT*87NJ&>x$0[oӧvD:kuؼּ=.|⟶itݦC]1nG75z+O'rVH}43ks< +F{SZ~:zBRChl*DAD:Kޖg-z*L•9KE#C0 <DE!6[<ӰKH߆dCؠBFj.::'tZry۞V4-me| >{82L/$} +& 6: +FՁFf1ch*{]qѥ~"pT-z1ROGx�SɞUo y�dimk@~UC_5$`|IhF)VqފRURed%[RLPD +�3푫]UH$"T!e;W $M� icr{Z[7(CSo+tpNȉ=à-=57A.EWsYle-eBfRӟ<I佹<O;@>OUO|X$.".oq0t̬KZTxeYjkN q˅LX<Hz Pc3EjR@aooE_ؤKFUCsy hO$m Ca)ɢA;.6ؗnc}eWi&/OJr 㣏 +.ˍ74'f(fa7 #hNh6n d#$�2r0lC4,}:u0Y.tѬ&U-bWEULp#:-Үuh)ctκuuCpb4hU&z=,x˩cd zF=׉}avKoiEVWqLZ1GKzp>oim|yA4`Bc]=&'0Hƽl!W[_|ah 3$^11^pRܛ]$K>df-dltD4_tm, +g +{7h.`2?8CGhh'̒f`YL^ۉjK JISkhD0t>O %Ʃڋ]s +銦!x+mVQǭ:AZmtw-f/۰ v$$~fGU]yP.ee4L)dV0}YLzڵ+eA 72?}r&8*3Q9ݛ)OUKˁMUGNh3GA +.eﭝ@)OD25ˤUEp� OeNvֆҵ/9~o$2<M2ց@ԅxdmt۷�p#T Z0&) Ď-esk:}@Q+g[\Girzo;x 81uFoX uY w8J;m['L>̙MUQ9K Æ=# �XXՕO_" 33`N]pwlvsl'ƍ]O pN '`VI +t1%Y/H7AD1_Q gؿIAhCG G$| +ZmծÏEQeVvTmΰ!K`4h{5,^ͫ*h3e+զ@,Nnb) ?݁h^w_덠ci|>ם?MXq5Ay8{Ϸrg/ \ׄ滿r^׎kOGt :|i9,t83ܰ+3Şd& +'/OȆvn: y;_=鋁Cibv:;ƹ1�._/*϶RG5{) SNUAЏCΥX2ΫVyǃ3 'v{37zVml4qN..k|ڶQ >W'\;aSHM - +٢T#pg_fJ݆Z1++)?S.ke4e.n\e@xR3$tryLe2d`," +jaӉ Qh\QͤfO ψ]Z~(L<}S^Aư<6 cQr6 5% X,Pexpdd+,7Od+|y#Bhb#aztŎ1ӷF-K~JI&-aԗpC j|x)<p>{WdBϯn,6pu#(_"(d6R?c,-Z7~- x['-O9Lp._{MR8?- }_t{o,$j +]S<S36,,bۤM5"H-$*;ReEVQ/I[TP1{S2O"֥[$8<^C֒/)E09qh'|Pt<v_U(ݗ$Z,i4{X<a`עZm x<tl"1'082avΓ=f2Dq+*;y~ʵ/d̴+oEʼ>`°BTl|Al0]g,=IA�c V}sU'[:\ u76^ڇZ -Oסb# +=W3D//' /EPc$ٟĭSg(J\}?^")ID |ǩ֨S18ldZI7L__!_Ñ:9kZveg +U[ +%QBZIe+9h?._dS)Ǣܾbs x]֡U^)<r:d+leeiX.[+~ʖ;Z}p~Q$ 57T*ٓ^@DQG ŰٙJa`{ QY!hyLÏYV\,_=-K^l34 .Dvz|D6вWkIZD4+ۇ%>N%'V99v[䈉<~Q)k9"͑c@2 +4BTjh}]:ĀccE|>f>xE+Vɚ9"Ȫ JSj98GfZܚN׹˳r\a tK&\-l"Gˊ3~Q[$8G +`kqt$F]S]Z㕣 ] |2*kf |F?;E0ÓNn# Z&jj6;ihI_V`kԙy:64; C)_mr"kHڒN_/ro!ߔD@uh>`0dwc2qK)ftmR5lb6xkn5&"{ӯ/j=WU_Lk!g \7-_zh FoC`W˘7FJ_Z@( =RL]܉k/ bv+8)w#D}v`.Z +ia9:UfKg9c&g@= 2:c=-F]n[^=X<xnNS`* >{h!Q!q7+>3o3ސϤT{p+Ĕ +W IIHSm)U:=f+r}wS71RBP +m_{cZ4P3jrl ~U`5VMO|%]�55a ɬE4اɢϯciegbmdVݩD4IȲ*5x]H|vX@{Հ` ~y/كuJQdlHI e*큯cpVH!e M }mlr`I[~n"U9ro#v<`'J2LL*86Q]+CjבجT`kUºۊk*cAg6rwuZ%J=KӋg+_|=8iي$ʝ Id8Bɶt`slAolyAPɢ~Ќ+Fb>Y 9ǼW7S]ǘe" өhGwjgbi`Qk ," +wj o7D2NmüL^CP"e_p^,RE35Z!f!Dٚ6{,WT+`RǺ Sz?9?RV^vee[~0j+ +=.XL #OjU m4=VZ09xBّw%G;GhOc_`JNxX*,,47I#cC u.`TUL *L_a'3UgK8"u +LTM!m./CX5n7ͽ5&86 ʚXIټPcvDs JXKIF~ӑBٔa_ѓ,'VZ(nӽÑ]j,)\I.F؆S9QQ+a2FL#* Bַ E3R'2+Uv-A铥X"G;4L~HoH(;KM ПElqdrcVV{]:!T:i?;Pe9dP̼G]Lp^ejz%juR!c`%Lބ'~jM&F586>*l" z3T`ükS6+,:~8edEaV+@QuHul%U[O:~9{0(3#ql бvmy5N+}tޘ9iVq1hj#*ARhrK"bNGN{`{dR:/5+M1d s.� rb̟CmtlM)ۗə} A :S,^fgӎP ${'ڽlRt$.hF|I!�"x�+ʮ)Ȇf;S܋7SG[54(߽hPN0ϏI5"Ԡ[e~2_d PeO6iiU>^Om|q 4q&n"k� !̺(Oe:RRKnYLف3dmפR¯h^>9uG +4ɇetXa "yw30%R.37,Y0uyih#tq~cJyq +3+9%c9B{%\eO[>] a�e؂_+6x Hv@GK v,yp}w*bfjsߡ>rh œ>piBtװ.R(ʖHvIf$ұ/E`>]`k{N.-\̞ǭ"LħŴ۫e'Z'TTĹUv‘v\ggIT`ɿW ^4<[<]"o]/i<z<*(.ʴY/b'7@c&~CzCH \G9.d=c_ ‚t#,2 \'~zlrmg`D4.߂;4w Ob˥0({WheWI?802bQLxN<o5=cQARĂGZT cBnG}sb1)bP\,`_ιGoԤم.+(zzc#^7;OA,n.9̖fqRk}h^ H`ָ<kuKl +|}iJYtu4kѼ&+E6`c>g b1!}snܜ)==ےArU660%5'pО]lnSᇶssR?ء�/\KpWy/(gwC{e. /KFd�y*O3!+yY)p^f6Ŏ=K=uv9{)*@.5]x_9*/ҝa?LOg|#AX�Al#olxp~MQt 2F~l=w{,%uIREo-"([%}`JR쌲FPl?LcfyGH:$ΐq�j{Dˮʄ#g}O;qq⫤̾Z9h_<rӿiMy}Ɍz)Su1]K󳼸H~jʹ)u!/?*&a*^>q|(|!_( ]H::!,jɬa/"B7Ch<2d8#s(lW35{C%T\9a!DCަv"- gpۉ\3Xe(V%P3Qg߈hn(dt8A4:*&VtjRq~J?ac|OSLjp $W!½$ cU4UMj"X(Һ\BRl r9:4 cn iB$~JncߡCuT6ҷ%Tr@Cn>\ӧj8ZCa"ꀟX678kh?Dhbi)KjwX1>W@IS6О +by/EKhA D81gvA%/銎p?FR`5A>+AfdwP)3iACXiHs5O} +$wT ^JL?[Fz=O`5K(/c枨[A0ƏFM y;+'khc/3؜+A{ϔL-n7h*1סk +ds�;2Om+]ŪQ€5fxִް-,˜Tw�Zc?d6}ЎV̀:XS>JnY:e = +(dMu)jK:oT_>c :c#mZCk㾞MP@1"zM + Ƹd Pș�:eߠth4`@ o'GZ&ѡ'Pt,vs~J5C5œAs8\/aPi'�+Q#V�͟?P+4Q |ـ֭Ab&2rߒբvdƷ)"ODǭc}QB#)k„ |y،{AumI%X6q* +үSj4'j*yӟ۪!Y/TM#]uh>lF@=%Lcޜ:XWcjvYiY*uϘ>VݜS~˧%`IdV-}a֪؍8=aVLUKD38 Qƥ)_Ҥ"bC7m>8)" ,-&NW迬Wk[J\"жx*X.KiQ,xgv$aw~'坙w޹x8q<s1<[%хY6 0_ѓAWwA Y99+&&9ų.j"ڟLckָ?{GΞRNr9dvt-tN?$Нswz<:%j+tN-r:wNܥ #;sԿ45+,'tտ)܃} )�"/tHsȜ~5Ng"MqTu\ظB*7w=/?$N^H(Cοǽ)B~=Lџi,;f@<yY&zGQ,طU a yDk:yq%Ɓ-!Hl~1h|2sE+fC .|\E^l:f 3?ׁHЮ7踺1A`N|�]jȟ jRhCzXкt,e=ʥ*r`˻u:zH3A~fLGXM%I2D'K~3ܟeĘ_~T}?:+f#eZDG;F>W)4kbXImS}z֭j,i�� zא!� IC cBMe4 SN._qn(+A Ճ@Vw2ˏYx \CSׯ +ʔ[äY1@.o٦sN~ʧD,Uc<SwIs7P;ki-VgsO#cP0^+' F=PP*%dc~DŅsYȊ#J<;^TvI}]TgtbRЌǠfnWµQk#LoG63JBZ]ģ" $۔N*XHʅEg*KEٝow)Sd](Qr361QUݻ{XEXF/>U<~\n:c/Ow -wAXQ?RMeH}U@/O5N%%FwAg7TO[):ZiXSa=@ +y /Sёx@H'oJn=B{ XQֳϕ̭ >?]P O|-;P1҇`@r١QJH�,[[J� �x&Vw-Oɓ ^ٱ37jw3u% ir)yɫ'E |%XGq|09braGx>հZqᕫ>q'c豉rCE&@OHY-jHyZck׻4Zde >>XpBPNkةނfش}U`h:{C +)A)W/)}Ji胘d1Pnt\=ȕ0] tuEZm^N/S/?o:]VpBF;ۅ�J=D 0ۆE :t.lZͅZu̎ +OSGurO.oJ)lky +b,%Mϗ~\ӫj)ahyVkҷ(v=D7KEzUh䤑=+*JPa cE\Ddǯ}%()y`XќIjќAtF#k �|.F_�/ׅ endstream endobj 35 0 obj <</Filter[/FlateDecode]/Length 1065>>stream +HKlUiHKMu@(!^h@Ԣ Q\4-b&:)-*)Lg>{!d bB aBp&$:mcO[a<\Kqayg 03SvK<E-W4Ǧۿ 4niˁKڎ}oI7s)��_z7I6\$&5y-^b:ÉXҜ~smN7Y^wy6jd��\we9I_7;A<s`yWοcX}xwydwe��\%=+}iv1}{_m4>P&3G+;Ǎ=fޥ3m�UҳҷһG x_f]^7?{#p"~t}�5үҳ;:[6hw_?Ka̮`3�5gǥgo;߯ĥ?rS]N[w��WC2;jw?KafyFM<_V�HJjw?Ka&ı̷ߤ~�Dc^9wR+|&N?}�'ҫүwRsJ{*^Sͅw��[]xWjw ĥ?fi띟80}�Յ%ҫnq)쏹j{f?-Ҿ��FSz۴;RsW!%t�m%]n q)ٮnӱUyw��[|ӆ[&Rs&~N�`߇SQ. =e~=�~}Pz};;6R_JEǺ#Cw��<ޔp۰?Ka,̦=;DEm�(l_6bXu5vE/*;��~ldk2Iojwĥ?ڀ|?G\}/�8 endstream endobj 36 0 obj <</Filter[/FlateDecode]/Length 905>>stream +HKoa"bCJ-$B"BDZj"Mh!2-h*hʤ̔:DT6XtQaa;wx}M0+ٻinO'/usʙ :B2=,ߵo+5o =E�0VH/> 7kՙA,U;|X�0V$_/~\yhvWg2w.vިU�/Ư_L q +j|��^\Gtb)ov6Jyw��-҃҇*nA,U{~(׾��h,%}nnA,὚`"��MOzL,d+Rޛ<_v��n?KΫSd+R8H��HgIUFhw%b).躣jnhw��򭿦%f7w%b)֯HD#��~{]?ŗ\A,i׸Cݗ{;�� =ky=?A,}fdi��~%}7T=G{-bKaky��פߤR}'ݽ??Tyrkw��^8wܶKGhwUb)M*Y暺Z#[[{��HI5om\R\y]�W~ +J>_2Ak-cKaO]gD,#_/��Www:'VoXR鳰%Ɂڝ�JJڧ'vwub)hܓG ��"d{TE?`Xo�7! endstream endobj 37 0 obj <</Filter[/FlateDecode]/Length 1152>>stream +HLuω]Җ ,r֤[i,?dh3lEl1TLq0~YD $MX ?#4>{ݽ>/LujjPl۬(NW_[~_LW +�h{LE;ŻkFHj ��V*|EǪIw)$Xzo^g~�V6PUij +?d~^u6�`׭mX'ݥ&aX +CF|VnYK��X`_\_yǤ$KaydzI��ϥ- ^>ntAb)9ۢ۬!}5SW��Ss=_vPӰ?H,!kǧ]&n�f7ҽ%ݝ&bX +CɠhU_��OSttTIw$| +X +;�fG uO龒LS?H,>h O  ��at?鞒J?H4rS{:>r( Ʌ/̅aGt��69Ts\)4DzL}X,@,#zs~~ ڤ�dG;tliji`D3mW{�`.C#㺗t?Iw$7#KsbDx<f3�zBNG +nDnvu +wfDNgw-?��=rDaHM{%)-zN˲UM]-= A��\wAt'b,En[po>NdmO5Gz]+N�wtKw!aζ6M0�zwxks;_9T3kt�1͑S9TC q ,vVޥfd"nWiOoW2߮&=guio+}7Jx4]΃{ߛh:EC˥�<b׽4>?sDRr^z~mpGNCy "Yuub:Ӛ)K@[� endstream endobj 38 0 obj <</Filter[/FlateDecode]/Length 984>>stream +HMlTeRQ&nԸ#BqQ.Z%N)&!6&m723-ҙޡ*-!|LďƆs--1羯?<9|�kی$n'[YkZ^8.eXK̖u Wz۾\\b^Xlw,߳|-Lvs~&.Vk �ி/VJo64E +ۇɸ?-;:<tbg?¯}~��4&tx-<Lٲ}"v|g?=eKcڍ�ҙWn\w{ N�H_h\]ozSƲ[�pxN"n4{9yWXW��ϮzZR~8LqsiXPƴ tɟ�tDz/ڍ?KKW;~Ѫ�kr{ғ]nsii[k|oG�G!iinf4m2~=�#v03̥qةXkˑy�C!޴Be9Ҹ?TMәM$~ܪ3�@I/d nf4{mhȻUi7 �~GK7J `.n =Ƈww �^##hH?nf4~ќΤn< �NeRץq0a[;y}v��sw"Ep0aeg8|Gs�~C<{ܓ^h7 s\VW |_Wvn� <>0* Va?KpTl Q�]gt!mnsiXR[jzSrmWm�@t =2&]>h7 +? �U) endstream endobj 39 0 obj <</Filter[/FlateDecode]/Length 932>>stream +HKTqCeXЦMJDȊ +HJa+KD) ddA 8vlnEl +jkٲy|?xcY,=j?ztFj me=cٳno,�?}oϞ-}݄0KZR+Skjlީ��oK@ ݄c0Ϣm3;2k�W7oU$8AL +L%/Kk)=�N_ Ê%q*S1)3]a[h]0W�{/w?O.\Ep&ێwD�F*J 8AL +lgۑO"�=rޟnyH{<1),`=/<F�{۫=>8AL +|N-7\?7E�*w>f<΁;Ĥ?7 ӺzaoI�s};/^s1)<7.fG{Ohw%�9ýrߗ&v=bRQVX|D_ C/�c_!( լAL +?B6&�`w4Z/kw &/ď �=Xy&v}bRsҖdz�TKxEfN7Ĥ?gUVcK3|Q�ߓ-[sN7Ĥ?ii? kw)�)!{ݹ}]?Ia+o\O�&:fGݿ!M/ʲ7w7*�N˽-[C-1)˩),?ߵZ[�7ҕ%:xvw{bR8e_/ّ΃ +%� endstream endobj 40 0 obj <</Filter[/FlateDecode]/Length 1323>>stream +HSu,G/t&wfʄ$CE]p "&rTww߅e, B$fRJ\)//3,6cw} /ܼ<}hL�<!\f͐^@I--ŭ^#C1^sotfv0Ԕg�.κ!ik<?5HwQ=㾵��p??럧~ܷ` j +*km(͓��>^>pF�/DMY1Il:y�NS/S?s)0'_k}p]�@v˹)㏿/^}`\X͓/�@ q2m�~Z[Mt Wy �/ҵ5_la ޤJb齘zG}�t.zr` j +x/*ڌ.t/�[rzr` J/",u5NiiڛN[?`!1I460 7%e��5lޥ,Ry7RMuVއg +#zG%~ܹ}�/ԷQbK{eї<H6v핃!�@_gXk3; Qb>ߧG|s Q& +48zj; �&ԫqY[e@{SCuFC{E';:m1]9~a/ddPQ)�P[~x8K\㴚FioXkQķD#CYs૽g+]}f^�Ղe@j4>Mly/E:óI~ w?Wv! fG4aO��zl{; y‹ |^R;*+D8 FW;S?��ϾnY^vP>Qg%"}˶ _D<|N;C<wֿ:e7oCGmes}T 7P Lwb7�?4h$Ay׽s.{|wmLyݳ^o³EXI7r8�?+Dlhm<N}slݘ@;bp~b&8s_<g贙G9�?rF?Gzǿ �R. endstream endobj 41 0 obj <</Filter[/FlateDecode]/Length 1030>>stream +HouO(^HH1754[47\2f708̰Ȁ`1uݷkKfwl֋#1H kn?>_޾y}/cHe'>u5i7G?/m|{HφojZ'76�xқ<,rɷ#w!唵>9Y t5<?Fȧqu�(gW/1DQyĦ?Ouԛt,7^=ۢ@9~\nT)֖/\gnn�\QIKFeb@!u_X@91cҏFb@!Դo6ߤQu{=�H/:HOjw5* +}|I�M҃cl 6Bj<ʽ\�4a1v7?Maк"ML�LmZ'=iw2 6Bi5'Q/1~w��Ҍ鿓w҇ڝ ;?Ma 4Dl!;\5�P +fc?A.=Ħ?P,;濭}7�{[wUiw0 6bK[So>}�@1II ۬ݽ ��!0\*56,ݽmdl> -F�($L"(='}ݹJ#;\go�([sv^bS(unz{� +kC;vc@Tך䙡iYݧ7�jHI{mPMca7)҆έ&Imѿ�aHe+gk +?Malyt3{ �o|ڝ)h<|w_lب}G@#�w endstream endobj 42 0 obj <</Filter[/FlateDecode]/Length 1000>>stream +HkTw.7El1NjdQ HH&.bJX(F$$393$9ҨZ" &RL :B%j6=w|yӺ�s 䃚Hxxۻ@ݲw !~cy򮵿-GNU wg^Ρ<{�ȳ-!1.Ep?Ma@Kb :w�[P 4s6PwvL�H?~&W[݉a:CN�ؘZݙ&)xg';u;�&Ti뉆%]bWٷxari�⑳4Wz)hޢݑ6)xk#=67qj ؤȑXDI#lbS𒅻?6S6�IGz9ucnĦ?5+g9y(R�!#Nh|yjҾE�=_KHiw! ꋓ$oIb{@0%oIn;v?MarƮo\'1Ww �9go- 9UL 6/_SlbsNp6+/T"�v^JGoKϼWQ󀩰?MaJkNbtBSoT^`l~YAl +~Qq<Hպ}7 �;]k^)v/ 6?;P$ur=:jw2bS𓜪B<Z:V}�?^(=J6Khw2bSyUE5}w �=ut'ڝL+=''1r~=nm7vJhw0]W�? endstream endobj 43 0 obj <</Filter[/FlateDecode]/Length 1434>>stream +HLu/kFXҕ-e@i0I,$1#;{Ȃ -iw?Z|܄q_w߇{{m/s7c<%럙9rYLNa-YFkN� qw|НFm܃en`7�291F{ ޻ `?5Z2|ѡnN�^@{b/x,@@P`$k{Zw�@h[K]Pjez.3X^�e{BFcijZ${�.>3Tn彛� QS?@MĆ4d�>b[XJ{nX,DMA� *;']8%�EsO_ٮ?MO1 mhYn:--EYA�5Z.07q {�|c-FCsOO{.X*CGy8bts5wuxl?@͚ 6E|.�9y9D;`) JTŶ>8:8xW O?@}Ln&iGP)o2F*?%jL=P]-=C� ;i:'c7kr�`iݪ[+iiy�o@@jTŶ ,*l+8qIHQVvw/8M=.oU!%�XI☾Cs{�x ԕmƨ$Ϸhf{+Eda<3:A~9nš9y68.o;?_$@S=hKboy}^B$i+$ +2cpA'O�04444׼w  Ͽ@`r&b) MAVM]n邧+cE\v+e(�匹9yS�|v<~#o. + ;˹3wO]h +hxČ~8eA 6,a:P { +�Vp4Ǽw 75&; QZ\8陸韗 =#Sw"I.%@1 +�fwc444w/ѝ(-Ncj2V}}M;Xɞ(;+n0S +�fFIs*u +�5DNO=b⼹#9! +hן>+ V-SYG[Xh.i>;:k4w�Rŗjg}^Zlo?�gJӘ]nyX 0�Sɣ endstream endobj 44 0 obj <</Filter[/FlateDecode]/Length 2787>>stream +HyP_Z-qHLMZrQҘr-a(rZ]v=ew_`(TM1Uzi;S}/F<gv|)#Bf7=Ԭ_#ȴ$NZ0;( w8p\H݄~)RmX qcB]:[8&:X/M50,;`-%TVћ0W3ۜ<qf%U2Cg~z(x)3җͽ]֢7jL쩫W3$RK !~O#P6jo] A;Wj~J zdO,\ {>1EsaLYѺ|]vB}.<՛Y^ Nj/}jFy\9#- 0ƜyDvO?rq޷ fE;O<군&5Hߓ_V$gc=U{dr_ :=.I B| +gJ>!g}Ɂ7A ˂GmVok["rc{yJ 2[퍬Rig^ˌ楆PcNJ0h!=`P!䶋T!0j7]Y *m>8 +: AwZz_a;A\| +g,u.Nj*m/Yf-{@[[els(ַ`סeER+e౧IzW}ls"hX<�u+|D|Xk{5+T]OG5|>t= Ӆ_o_ I*S8@M\ӾjqAG/ZwajfC槇>֡?lL|\I^l{-H +1ak+edFb4^_MMV;eg[j2@ئ\_w3;9vp&5t] |燳qRCk:  >3\ }]oC*;f +fdifGOv4*y^n^Th.5Ml mwYczS`mԇ۳#&YĬhg+Hߕ|Kʣ%Fu:k+ A.8:˥%Q;GWGPIj#V}'6["3^#TYujB]s7/Z#>]bQu;k>#ሧ@oo[;I!TV=Yգ| |3K8UAp<-͎ifU:�.6Hܼz\cKMƜ1w'u8>>^?gئ\_ K+ "?=.mFMnCwtz]ˊHkA\| +W?z#+! auؒ[Wg&w<Y{$/=[H$h.KpۗF$yYx?? 2ڛUJ@w$?dtO:/Xv].>|3FWiW :{2.m%co˨'jlm=B>ϝ+Ov0ʃO@a)/c]yLC#ꞗB~DT{c?aT_L"_!1BQ'zZ«f4?0{KA-gp? *I\-vW 9}Զ_]:ܘƜ0/ږ">#}}~YԊj Q(j.5Bo0ko#ob0D;HMޫpf`/ Kg]kK:"eq`)?֕ tvgKئ\_5oאXmows%>;9*Q#}U Ij/}W31KY=7oH(ַVayO l79gط}nEsq$/ BCK<|^#x%}hix?2CgC]wNYz܃ :qu@' 致ĝ@p�2Ձrn,l;#g} >.t pL0륉FF{h*I才2![[C>mf'm[ JǥϕN;Bw(34wt`\ =<ѵ| ᙬLItCZnS8 N J ;{*01u髆㠏^HkA| +2562[Ǎk߈}BSz�]4,$Qqg`) Ta6燌5?!ЁɬK8ރ6A@ S͔UćT&{ԢA5 |�L=sSbt/h#_?!_"ȋFE?YAù: E ?0?%XK%ݝSůoQL+ JߠtJs[4:Q<hc '0ţث;}7]yF/߀G(69Q[qݳ;m(C �u endstream endobj 45 0 obj <</Filter[/FlateDecode]/Length 14620>>stream +HWy_L,a kBв+R.X +Ug&d&d&?]ϽRYΔʗ?I.V/*Ac])WtW㧽uB.?/z_Ug}U.szɒwfKr + >x1ehѾRsJNJ{UG7=hJ+JS6v73 \2vfZ~0)j/o$GUE�F%Qҵ>=1S,o% gwΫV/F6=TL$pҞls|J`^$o$pD;fPb_ϿȲ,&yޚzya2R 2^-7i0F!70 %g`r9o2&ao H=qt&MG_q@z)'n(`FSi3ia�Ouy nO3=n6,<Qiytې %{ +lC.D|`oC[]wmC[ ߆(xކ|cqD! s ]89v!> ˉ][+�6/-0qJB҈v#~cQvf2� n/ntƄUIhe%Y +1t P}S^<cs1ճTKŤ{z_| sr=vx#;gUT +k[Q_'X >k]V]f V|gi q$,fTrtA :q!fO9%27A]{U\/ nB4=6Cc(s^jMB> cV(s.JQ\Иe]P*.wzAޑ[,_9[V%X}+˹޷x>w:v'rE`R 7wlʨr;~DwFLz*0[/땈k$V8e4ZF]FceV,L l8?hr4 +{R%c-1~D#aTEvi4_$[= Nf'8ܺ3a%4!0(YH?Rg|q>6Ǘ_fߙbb~q@ܧī-0eC +?rC1{dSTJcw ZJ*rSȊK1F]þKD]2r\0N�C9ZKT劊mhD=a�PN@$A{נT<}OQ +XПVO/V?Ovo'0Œ#cdCٻ#DϚ$BX@<6Y"EfMZnnߐw<I%cB C WQLx30BK7BZ&ͺWYn_zG3rsɠU WR#$A>CBLKN4:Cf9 lCT"\:b>r&Z^J;"9kqL{K |enҹ#H5^|t(dLg!o0KC},1:ٯh3e(>=e#ꮿӭT!dTIhtfė-f:K'T?<1+vnQAfǯ$ Vp@d]!U[5ywx +hYgm vTƌuj5ZO2u&@4)=v{&i@,Kp@0�az#@<<q8q{,�I^l:lV]Vf~ Xi{XƝݓwIH;h{v2;ILOh H:88:;ud5H$ՙ@ 7]N%C)A?WR}?\zL6ߙzlu&xI \*{[@rp~\"*: +<\8y*d\|<ٻ#dNŲRDW9\n:ǚKÕަz N5~2u%HK٠Ei!2~n +k�%BC{xWomܾz*fD[ +*%@;&==5ZAOcr-Z5wtb;DPd;LezrsZuDA@҇�:4`]H-ß r-4b#v#4ZOr�W䂯uOXѻ# boǾ$~TC嫝Z]PaM:;s][LD8#}&XXuo%ʺtƩt?cN0C˂%;9`~a|I>|9Zw%^zGz#Ɂp[6\K!m mNЛSfYsDQPj 3DŽw3EJ\x֒`zI+Z%-b1~rи,h}0$X|gi݋ZPP=%ɟ N&7C8O*ǹrw"BP% %zh3B8HH/j NC�FP`1i8وҐa݋ּo8'e?^Prb['/$ }>5~+coiJ]aCMN#cI8F9a/Yx^Bl%sd �6=]n٣.c&!E׷A@0\=4żqʉ o.}P!tA*N^驸?a.7RN3iH0cV80 MydŨMrZ@H2d.qP v]J5z|@@$ۯj{JXiM3JP,v*xp؃ٟ0.aXqCz z6s Ya.,i*' Q�&?^(̍Yҵĕ <6�$AE\䢗;. lНt?ZNU:%ih˘'RO!XOQxƊ?araXߚ<\ZwQcY+yXF#�Tv]Xo6S,v ժr97 i2_ +`~z8lÛƽ:,޴?z-NcKgEȐ/_)Z).P ч`Z=Se :*J=ƫ0`~/Γ'\v~ӽҭ0Y4Ԯ(f]LE)z_t?ƜdYBNWRrmmK2I yqjNO1i:65M957{(I͈0|:˂5/nnN|sL9iߩv`p|O<@nU w'P_F!x^"C^8WRE߼ u&W\B|;Hrړޗؾ~h_S9䁏pɦ)N.F: AUпrZ + օSaI T:{YA8(5N1o'R(P?-Psc~7gW!Dp[?2/ N}em1eER9nF:G31e%u^wcqټ؈ S_; zǽPD6ZTcVUNMm_8%Ͻ$0=/𗭬jN +ZZ1ڲٕPnXLLp`agryim}ɄH.D4bIw?M۟Aݕ|X𱇯(̚>*e +T|,oGVd7�Q"T-f+`j!NJ\y=ZR#ah_4D d@`th gAkza-Ek`i1:sF,WJ8 әsʤiw2-C}و,q)ļ/bs-W a^M܄y^X%ǘU6'2�8606�LrTL<ƴ0=kq4۰ǰ;"M�Di|]i΄zr$Y?v8_1=_@j񢆇 `-Xp< +v�B ,3}t�"@8FΕtNwJB{g �s.qE0Ek\D]TPr$ ƗlnBxL8(*$Q*ոWPoℜB@P䵵N087v ʄ[jkM]DvK] ]|e'p;d$os_QUKW]oA]E!ڐ#hˡ(w~VpIVD)[l+D!g i>NackNQ�j-q'gRd՞$_'8-$y /d;zzQRSj +>Dgn*5$-tq +1jW%-f{t[l//ؽ0Px h)̙_R*\.ܬbܜCQUgsλMb SRb2:|&4ݽ&ck {g;deV_phЕdyM+ %eGrwIV!Y,#Rb\P7-R;xg +hE ]\(oXP2""0?7#]/4*`cX&.~=W& +w@|%mі83 >HΕihw9aYYs(xWxh!twUu\^ gۭ1Lvsnϲ_.$c XcH a(*2]2lwmtCc1jaxg5a F.!$wlaմx Y[ } rC89,c\S]i$0dv<QþR<W~4vpdz%eNHDvG(d]⃧p7Ųx `iUbddQJi>^-`@rƺXS|S0'6h Kb>`!5& ^c�͍A C_-e)K1ؓy +"-TOQxSYL%O됈}w%{+95^ym`p`'/(#a! ?i($ i[Xx`d +w#OSDiw�N|=g +i,5ĴؾXWUmwXk:_mMTI@Uˌ1rckɀg z( S!۟#ҙA|xULwCzn]j$;|)u}0g9nX9,<'5>qUOy(= ъW;Y)2ݣ%)6U!>H;/,ͤLD(EG֗ynYC:UΧt/\@cDp{9L%t+ipz0Ǫo,(ϕt֟\Y}8-JEcb: é)W=i(jR°wztѾ;մ[tld6?\m Y}wz9IKbК9 t~)&6YG6!9{>'#� y0 z7WnK\G$9R2$ѫΠy=C"C*?\^O^ҺJpC +E8%~M5&Nf,a?tR`bgHJ!~2P| " :>!^AM?-76;(;7Q%aҕFR}AJo1l.y;c(a߬cSgRgBBK! +H ME. W3*M$)3gfΜ0 # ͓!%k&G])GDh3!ȯu@&[؀wj3p]!Daz` VW`4X8 ,@c<c)igLA^ #LTȴͩiũν1L52ua)}Ec9ZxQIo` ikY\$G XiԿ5kӪ:FzԘMX/y m+"ݦl8E1sf֡;\ :,.ALN%ϙfqK%)=y%S +:m?Pc2>ޝ?%{S c7'~ݘe;bY0ڙ/c کCDq0awY`y~PgĒ`@V}8V6I2ql0t�,~E˜ fˎ}U `Mbc�p'5a:=ch}ny1ޞe7) 1y,boq LdMGeVOٝU=9k>$5GsPYEKJw~}�A kI4<ऻyMxibKGڨB|hr%ˑSSKh{qJzp0r..ASJcR :mo_ ʕem 9li Pخy4#&LH Z@jc6_-Khi%494hCUfG(/BrTU rn^M\j̃rElPU½ۄ`f<cXAֳQ<:T2l];]Iv9`oZ�T5B Y 릁pP%\۾"6|/$ BҧkYtT(D +s_lqf\n}$i!dC`Ėx љto21iKȑVQw+)ƜLDsRͤ01-jo̢[hյ1hxޝVcm~\cp k.01G;|Q= +y{ug;nܭB3!22fZaO3f(aTqu4U +t%d3.SF(?OP‹*YJ€F%);)&SB<w׎jd%=^D +6Wy=yP- +8[y;j'+QٶboUF!# oAm0&>VzszP "6\܆ZQ*Jm8\{>[c ]L5v~x yZXB�+cgaM1W; -+U3%0 +L-t%HT:g|Icˋx*M2ScSmx9,#]]yS>wz@; !;;LV� 쬠;-,llI#yx +H_pJBK|[{,_ ؆qKSz6t`bmruض2J.`0Lݑk(1A4OW/X1rJwĄ|{{%%9j C�Ͼ`!l74~^bG°ĸ c]+V3#a"'%&*�7(KǎDg,ELF1֦(c4L8ܧfA&@ g ӟȳuaSEy6I=PL:*ȉtcV0,x-�i]XI1�½0 hӎMYp"yoD[;&vK9v ]/tK"x3MouR.c/BǿTqSjoC1ML5)˫ZaImG^]u4-jI#?wewq{6,y{3ؐwxSA^Qr*ϰT-L@$mk*pbUuI.kzKFmdaO\nw/+x/T pgnԟxQ&<-v`!0@̋$SZn.eD!9'li�B_:y?}\p1+d_[.iFYi К4Y:su1(JKs_7 +n~Uv ؾsgr[K3`Q͒HQZEu||zG+A ?X!p6' ;L̦JӠb4@@ ! P`FQ?Jqr<TZǨWMd86wFBUoM`,HQ)?J{yA];i<//U`À2V/S^TG+=,ﱊ>J݃_K�=a<+p(Eˢj,A<w ~�صXr*�ix|ߑm7i|q찥2O�82;e}Su%aHQmDV]gMP9Y5n\>f.jZt 0?p&$ŸROiRa +Ngژ=Q+E<J?k׈)z&rzm6_$2$Y q$D|+8+y3ӮCX`xJҫt-q%>JNPք%D@A@pCQQy[/d:uN- M ʎm~LtRJ*tL/y=um~'cM ^=$W Wws`辄_$!d-{"MsҤm%㸊=q8I<Dj\](j)_:<h֍]u3|,G5m7f}w[hbqK.{ \(1+Ttk,IyĚe'(i ȄHӆ +]:);Y*3azp[epAc|w9mp'XU΋F=)A4=n༽#f'4! 8I8&ڠ@/U TmRL&>gO8x;J4n4^%Y'IC+DEc2G9Ϸ=�gMw=p͇J1@/Y%ʝړ~bU(w ?1QbVK~5h<Oh.m6;efC_MOfKE/oWTMKSyBo*/k}d=o`oMTAh +euҴɚ $Y-*^I ކ#>gΤ4 ói -$ܟ 7"|AiJީw4 !ʿ+orvsYy{ J +0oK~]܋_oz^& ~V0zŝkNo""M)ԇ\?Yp"Iy&HR0뵋U w\7hR#UYAe2TdhLJ݄uo+N;C;0C'،N'MF~�;-\w*G|ah}�jD&4edžA w0>G)ۛ/9Z+1gQ"z(q&CϨ Ŏˮ. AbK!#@(<: $�a6AUY^|@ici`j`a'֡�h-A#v/)V,^7x`d\*X\xJL\$? Ȥ #_R!aH �υ(iaCE0M>(yp|ecQCɶ79 +&=ǘrLoFl c~1�!j � l!8/C } ;�}>>B0]PnO'Q^6 0Jܑ&~ m v6D>|YZRR;}u^&6| %׎l 7u"tw op  +Re~]aÒ7)hiҋs6RMCƽE-ŵaoβءm16~}{[Px7B* I[ gc wɴjRIL&Y EoY+YpM+}Z>?xjdBFl+:iy- (C_MHbM 8M`:pזgMIhY{س4# V\9iEqvɖkU@9G-1h tXA2%~Olym qOMve6}VKWڐ%'4 Wߒ̽ 2%ƕ:[Ub{l?e^8IЄ*+D؞b.^0^hҪ+^_TZ~OS�{H3$Np:3R=)byzXP=a*"c? 3! +>lU{ӜPhm Ѿ`Gl0pTr@lD/\d!PTpL=Mc\y + )WW}j/@{Nu9fLFN*$J 'l`=n|V }lypcO ̬�}|a /@/T-io/Jl0Br,锸]4XMAfK&X;6xe`GQ$t"ĉX>,8Cu 4m)å&矍U'fRء$r }\z!,74Zc_(WiCA #&V ++<Dｪ<g2փObR +jpN@,m^ ,W/>}h#eA(NQF*>>&Vey[X:_;\˶^N< 8z|sA̓m)PHGŮDj67@ӞU*^"!pK_Y?ۑ>n<Oz!4L_c_<5D??nC6`=ď>8\ +ƻ_/a"v+D"9_/8~4׽y'O>pwl#t :ۮ'pChԁ%  $ , + ʌD[=dkNWR]]{׮>>!Di#c_ C bqOЭUM1WP ++TFm�l 1X2/PCZ4 ME5èK /͊ 2cĔ%=p}P͏ƍRv!xj N33pe?U1r�`Xg[Y^&+"qfDA Z n}&jʜA9!JAf|cgjS˞8*>;K�לdĴG>$3�c3+</$rȃe`ty% њOʿEN~R!Z.? + +הVD +@\r1�_/>�C\a)K*U.`3p5mx\%\}^&`/!E:j +o %!Ye1 ^QƥEz?hұgߥ߅g\9 ҳuf@S\U(< Q]B'?_'E9]g}qm.zu[ _r] t7\ +mUhkEyzi%|nC5`A<h..KhTvcl EX,R@pK]Aů8mB31/ʬT�:KaF!0e)kҤՇ\* hg&HY4vC[�6�*i<R5zt#GSq(9iƌ o~< X0~`;F !mU y2`xܽɓob퓷u;!^c_yZz/](7ĥaF;=bͧR@s$G[nϜ:oT(^|;N՛ly%T=zbu|gK#QR2$XcYihFVmiz xHJ,BE>fGxL2\$ؤG\GŶQ|fT +ON<x5 +,|KMUހ�/b<Zm>hj {,8ǞE|[i�~񫱽 Ξ撚ֵsm?y +c +T6G / [;bzu޺Mb\'=?\ݠ%r0lf E.E*pp `#^DSձ�A"Y +ڞ +wJ2;NcAgB*ڪl=PE ,pOY*_y̍x-OPr+ +U} ͓Sp$_b/wٲ,g}7s6z~%f[r9luFaK*_=`9%Z\ɱ"R6-l^f<[FVr ? G#9b^{HS2T:DbqܱkgB±PrfF/b)XN+#!ol=)4_D .q2~Ӂ}.CXd.Asޠ Cg3FwKo{C"2B~\}W{K"V: !J7 +s~TƮ|02Y8SYW|5 ٪蔚IV<aMw}'yvCSƯtی{ t S<M|MN^*�xp q� l]n}r~,ذ@` fɖ +NG&;pfT*(=oyb <rjGFz3ʳ$CʆWOV+CUc{zM~APàN&m+ɓZ+R&%-+pWqud<S z&P eP˾dVMOY΂6À ,׷f^1>p/z#\El|HɁ"H�݀ /S,,/Ʋ1YjJÛ :KlߩF c\/`})"n{bn;@> tSǷ 0%z՜+Wֵ2 ch`lrCtBcg#M*x� |i%(5=Qln(KǖJ/#sAs+܍Xi"kfbd6ȀI 'E5`e#Y$EHzNHlj_\9BVG`*DAD$j[9+̜;–S`׺RTVa&wmKNvA-Q}ᏕDū떋n.-ȎȑRAmؔ  $ l@]6`ohaB%,= +΅%1½ Ύ>:tP&!3g'|d ߾̃o `prM҂Z4Q[jڴT MhR&޿{`Yxgvf5vd薷vB$ScEw4twwJ\(uq9"8p=`?7׳%ClXŐl П: +)i<} /m2Q4[@@"Cώ 8q4TCk%:x;~ %@@Ƌz`F&`J8!t&!f7nMK[)Sb|,"adku\$0ɥym)R z˛T=4%&\:n 9/X`Ӱ:۽('徟piwBwϟ)sW wnqPcv9>W*p1Rbd]e8 �_1c1ħX󔓿+ F1Sx%[4@I`�w endstream endobj 46 0 obj <</Filter[/FlateDecode]/Length 3542>>stream +HkPTǏAc[ǘ::FDcc@kDZXRR,]`Ae²]*Ai15ZC/N[stij.;}{yyVQ/_5"rc,Z"4Ҟh4#1b]9#-dd'}Q꜇˭1ݔ:'Ut}|?6&gOԱzFk- t1BQM!DDϷcsi<?ɱ#[, s.tC<TX1U&f&Rr!J곎G"'U^ܮ:?3%cDD,ySD[MVjNь'1vM_3{4JN+>+ɘ1sV#W-߶ʌYR)" ySDV61MF{+P~c\{W{` ZF)V=הDD#g_>. ͛'G! wOuѽ]5v?%+TlƍN\\+du:nKUڛ.Uhױw\Sos6(a珅P +GSI'cȢN8nI8%7?˘| <o49 z7g'%Nʏ1[<-6*^c6|#=KL6E8?>o>zSI_,7)J'5<ovR87n5j(_ׇ18 cvR{Kg)et$/ӕ| +·wh<i<?P5~f@zD_j]19LZTՅXfPVʏݘ:b+s#'-烚;6U?*_Ъ5,rʈb:S8u8j{(oXFM} x�cZN,JJi +ϊmݍ,[e½0$UfeO[\ʌ_85n%͌s!W1\f7l|tCFͳ4-_VdUƻ=sH=)~?EiH_ks>:} =G;CD4E4ojjL*Ti@-=32df]hcSJ7VQ8lnLOX7G|Qa Iѕp;>੹ CU؛HcjGZ csvu1AyΊ☃ ?7vpep^e&hΝc;%KjI%xZVx]Y^N""r<|)o=[ ͛ǼMqrk0 5d0f UB͑ǹU_ ԙ�aZSX|]7cZsS6gk>n c{|wG.c=1N +ᐾ< ZGeR4reY#sp诤ԊNng_'uI4~uϺb*|?—R ".ySTHѕA<>ox®)GXiubLNjB+NE}\?i1!'eœ8[Ѳ؁8z|珃ecWE9Lv}fUqG?@{q0DB9fe?^Վ5É{Xiڲ*?j<mlp-uS׊{y*6kQ#vN(mwi<?|c(ԻYtVa|؉#wxT$ԽX0x4iJU}XXCS(Խ=cSmvXyŭT2j\#t0p-y:Q1X1`8ޤGN?;Ζ&al,xp": ,r1߉i[ [Ъ.cZs~cH]y>w|(] ""z yS4h'ݧi؂Ԑ8PQ<^{mVw2P4+?>mV+ǝ,1Xm?;iPx2Gn|{j+55=aa gKμĦɕ{jVkO,}J}/ ~{'""*ySD(6ǹڵ꠿a2jf!daܜv`qK3)0;G57>+H5ǖ`4XD#O?IWrf$>Z,HJp71k +c(\DMRi+5a׬DϿ# 3Mj=*ySD^>責!2;Ǘ*;[I8u :mWNC;4.c7h]tTtX'!o}E+ CgP Y|2S?|aI6MvRˉ_ϷZfep^O-f7z5yVÝ߬-H]=ۺЧ1ބr-(Kj _v!Mq?ЍIZPW]EQ], ͻEMDD~;#"(ɯt~ 9w8nZ6٤"ʂlz!t]퉢y(*ysy=KKcU~4_Xt{'+B}ϠwT9 ? w6<qVəV{pzv{{N*ͦכJ Ẻ6_?~#sNs[M#u aKW5CR?9)!+[~~_?ޏ)698Ŗƽ+su չ.!+]6{7s;3feI�@7t=4!0Tј?@9>7!Ov l<,|Ė2ѶDѽpj#\fmI}|J{8gH !KK#(C\uGMKuUv}צ#VA~suU ]W $2&J~$t@7K7?XZh 0]BߑS#ekDDbd<:˳A{xK@o2$*!dq0T?R.g +[k~Y +k +$!<S9<V,ȃ}opBt}(!d0T?"H}#-|z/O'&|ƌ}VoJM:A& !Kb Dl0dJ嶖]?~-#g4GP.kI !d``i?_�D endstream endobj 47 0 obj <</Filter[/FlateDecode]/Length 1817>>stream +HkPUr1tRf LRT!(.t!*j6 }#»*.b$B.}q&>*HAŞeyf~3?p +ߵn=om'Ɵ{tھ8!*#X>OzV}~8!?ӤقƺeoBFVUm5{.>v=5~nFN}{=F=?(w!}(6kͯ}3f35gڶ +s^!daIx&3SV4˪חu\,R%&?.[zO ?{<?(w!mgVq4ƟHv"A4' +|? ~3A?!o]XO4QUmB-Fʟ=XZ#{BA?!7swRPb8lhdw ''FwGׁWO ]7{0P'-)jKSk}׿h< +=kg, mGF{ +sUYUF߷ss?}M>AG}Eg}=!ĵ`#UBG–;ΚE /LJxe8Pg0Bý"ܰzQ6Oiۖ* O'0PΒF#\;zr( ߰(SgPcqϲ >sxx]k mϊfVUlҝx:m߹i^ȟ]r7rB՟AJOY[>yc`$>3P2( + н/e?d{?<5ebuQ{ղ#ۜgؔ�g^,Gj!T>_cg\g0?(r?Bq?f!Le%;ڊB{9qGœ9ەTg ΦC<>p:.m^h9�zyX'֋ucdǞr? kWo]xxK^k3zܪ*}'M;iV"voQ#P_gq5v1FX`NwX/|&8gJ3,NG\d͟skYKW3=T<[6TeU˒ kguams5Zpw9đWFn9xԃPTӏQ τ7Z<o>a7c!;‚C\hnEѵګ `?gؕqnq_?1Ȯ٦*\yr- &]W'_ux}$C}9uWvƢτ34E7Q=>ax=Y;~G#4(JYb5SYN^]>J7B!sE9K8??aU-)n|[4;K2,ǏA‚CfB!s5m,9 ;\oCt7YBgIQEQEQVz|w7nT/ܖ%Kf,kpBfkgk|6m%J(((j FPޛ?,L%mQE^#_Q6EQEQEQEQEQu] +0�4i endstream endobj 48 0 obj <</Filter[/FlateDecode]/Length 2249>>stream +HST𗳻 xAE(b5N"^ +h JKKc %. ""]::i'NR=IYp]3ss}2^�������@^Ǵ +7?t^ܾѦMO]aTbY,?ޝ0Z1jf]-p؞R_}uզSzzV'sg5œ}'/Zmyn}o:/쳘B]gvmp닌Z{:; &&m/7-RZa*Fr $,{/2aA҉#9}+{bf׹>iޢ;Fhǜ鑌4ƞ|0:1hF-W=yv7??s:xO6WYRN?ꂌ}>jB,:$;;zI۴N!cy<i i( gƣ{)كkS!oUԝ:w s'yC/RsBspMP{c/!L،i%K|G?ΟKֹg߹lIYͤxr&=[.;=jCszdj.m779_HGaJ5FPzUْ~EDpfy5%0a-^'m5w5a2uwrJp>#mJF =~xw'HaFۆ̐1ڟ fiT+CӼ1,$cQbOB諫6-=7J,N6]C#cyR*YDh(4 P~2;sIt/?&&Ydlu{fk} +oU 8i;ZtG c'=LھD+΃ܽ7c^c;ZMjO}(¬_Y#cyН\A9|?joX>#;=Z.}Nsfy"\(kO LQQh"Ebd gm/gGL)dlu{bY,ZC<6Nx7claͶJW2E1lsJX_Z^3f&j,݉CaIʟ\j#..Ls2xn532c0ڛʤKԱVƸ`rU vr{GP/h쳚gG #cyno{d,+z͝\iiAYKJv{PtG-LvWt5)⾖>ÂI2V)*$DjSs + +bw W\tk!cy*ehd, 2,W̜kV}Ea!!lmbuNVfk}HP|hN>_ѷ?ReII8͉9#42 cD8PsiyTD +|fa{l>X~(yU|}ۆh(Pݩq!AAK'*bF8&OZp![L6ka{N [h63{n_ݽh:.YX1<:Pxk+j>wEqㆎ2 R*6d"BCٮܮcjܹa#K@k5:y`jjkxL:խ-ETo4]jCO LZM+;y]RT<HMb͢g}F`v˷,ΕLo~ުply՟9OŤ 2]t&77_8z44w v:T tC~Maٖ A7(z3 co6T宜>Xո~RأpG߾ѦMO]a;賚2=sp%X&kESZU#¼8r:/]#"cߴoGxDX~ſj9s}[_d,??If[KW?-~ziJ,J8[U 1ga^?liQs"c�����������������������������������������\ endstream endobj 49 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 50 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 51 0 obj <</Filter[/FlateDecode]/Length 433>>stream +Hj0�DAO7䡒yk*B �����������������x:Ұ8bps& }i<K}dK~˂\?aqO>,q/>%n>œ㽫/wşlpصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصQ MRj,Ū6 IMf)6>شbf]+fصbf]+fصbf]+fصbf]LNMzKfR,o`tbe1`bnI)V>X{^vZUZ13MŮ3T.?p[.]''bf]+fصbf]+f$]`�A� endstream endobj 52 0 obj <</Filter[/FlateDecode]/Length 716>>stream +HN0DQ4Iju!<,CkmϿKYp5rtգt+P5J܇ ][bUt}(ѵt*M T?HE0>Aꚿ?TԵ}pB Y5dh! -"dՐE2Uka6Z<̦1S4fj0L-f3hE hآ [4ТAcZ-jϨB5X= gbQ[3lp`k .lڝtM [}8 m}0?G-} ?I-} ?K-Ҷ}PNmЮ}}mn~ +{ȉW pEzy nG} -4z#a>wQ?zu@.@>7[oN: }0#O`څܑQI@:Ϡ1S;vLiK铨ۮ6]Q ;WLzM ETz9)XdOC/"{/~"{5m~ߨ&{;m~+z@~۠u yD=~Uβ.<!:fY]S@?:jE{kd_GZG-(nem*nE/oǩjmU/mjle/kGjkH4{4)}⋙-:eL 5<`)晤/> +0�0L endstream endobj 53 0 obj <</Filter[/FlateDecode]/Length 808>>stream +Hn"Q PiVjN o{.Bץ*3D-1v_Z%;]+8r1Wlo v%\a؍Ln&b2`fH+(q6)KSJ$#DoJ $CI4OI~4cH^4#OH>Dgv=fTsfvTAMـkى(l8ȥnl0ȕnn(ؼ9I78p0pmŽM(�]7aKgؕg~;jDFocwDɨ$�>ZPG_ +jKx#1]{kx1=ؓQ~H),NS}7Ht9\ݩ%NOZ;ܦ!pKnW^ 8_}kz]?#?h@]Ի_!7>BKu9?І4ԈWR8Cpfǩ-U_éyX +jz'c}ar{F:zBj#Nـš3K2kZ&�Ѥ|R^6o4-BLpmUo&yxiI\u(+bd1)C$kЋ9[R7Y R=iv{al؁*칇UscfVa=ž{;0[=0v` +{al؁*칇UscfVa=ž{;0[=0v` 0�lM endstream endobj 54 0 obj <</Filter[/FlateDecode]/Length 597>>stream +HANQP 0D Z%?H,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +ZA?s?+:lG>o|O�=�=�KK^.ef/<]x=)RI0S3e~*9VtO%NJ/ЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT}]JcKfr)=XTO]/ 3ֻ��I endstream endobj 55 0 obj <</Filter[/FlateDecode]/Length 627>>stream +HjSQaT[DAfB͟\u_|d?+gG>B _cD~M!8_n妊~F?}F zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +ϧsE Ttذ_IsoW^?%v~*9VtO%NJ#^q+Sw« +]x>Ba +GH#/v*Vl.e 3B> +,*t3zйB> +,*t3zйB> +,*t3zйB>}`�wW endstream endobj 56 0 obj <</Filter[/FlateDecode]/Length 1555>>stream +HYWHys!J�ك nжbB~>BXz>}f^㈩TvS ΚdT;Dz3&#w=؞v]vӯ-?n.C Qr#nL_ٟ΂��~x^~:!;/ARqzROfdbcp q'ѝͪihh +Q a`j ~GbxՍv:֬X˴ң^:d,ghfeLahѵ筡t*^1khdM&zi|f<g~N7\=zP?5QԂb.XP'hZ9~,U| ?tl0P3*g` +g*.*تVlcUUb;?(/*^噳j1sՊU%eQU}kī7ӧU~1QjmPtoKO$_^%*ui{Ԩg(6x76[~|su5.F z%j5 YZE/wc6s +;8ԒJ ̱5>j(_NNmXc8~G$"!s^DT2gLr/Z${/2k5C}nIJ^'^fL,Q5MorłﵹޫTQJff^⪟?Ds?b=N6 ]*zFT7ьۍDUƻe7YjޙL"woqle~ښOh%``v|=e,-׫^}q7V-l;yOF*̧b]C.4dgB&4,L@O.΄ ǩH8Uc;/R53B{7+ifVaϻ64-ܿh>׼turLszEUzIO;ڬgWNhys\ѣiwqDs1աu7*۷ŁS7UʃA>G^$Ŋ=f^9EirtC2Ey2˔Rz`ܿtً;$E;7{ R}w0ם/DG|ndd#BJܭVU>.+O<{x _䋜ڍzf9y޶KmrFûԚT9Jh]eix1P.gYrCr_4<2|vsk8w ZSw2e=;9h4هݵ<pTUUb޵c}"]<n)=LpލDZ߉ߕo .OœrR,{_$}m?/񜜬g tBj~ �������������������������������������������������������������������������������������������������������������������������`�嚻 endstream endobj 57 0 obj <</Filter[/FlateDecode]/Length 593>>stream +HAJ0Q -m4ǃ߀[Ň}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуEq*Vl򯜧cEMG�hwG? ÿtJ6+ZA<8)Z7xI=%>|?op Z+n Tr9.e OЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg` 0� endstream endobj 58 0 obj <</Filter[/FlateDecode]/Length 872>>stream +HOP67K ѵC%H@1d0cjk~]:tԔlOV{vN% +V`sS ^Q{n+vM]0xE =7uu.nW힛`sS ^Q{n+vwuwV+<$]Rn-]Y2` KXdS|@@$|tP|@MsJf>eej]Vi,w>_$q?,Rc]I9S|���<ŭi/*<k\Dl| /ܞ4YqsEfJuVs@ r0ۯU<0"1zGjS-`ǣXbWEZ0 +a:\ +|T6NҦ#o,`\%\^I\N w<7PtKKv·K=}ϴ"w0[ўuMV<4z<_=[Jls5Ci}z����������������������������������������������<S..A|S*7/O[7Nt\*_Dm׽Vwh-ķlµz5<u=|2Wݯ^Eo:nGG'чzq;=EZwau)jt~v۝a1+Vx|TRZ\lnm8I/'7}7jXNpcxR\ӰauVyyD�� endstream endobj 59 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 60 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 61 0 obj <</Filter[/FlateDecode]/Length 498>>stream +HKTQ[~D]9BDmI/jQTԢtY !EJ*DPDRGEH*¬}M.Zٴyෘ3\x9Q��������������������������������Tl1{>ѱ8m}iac5?p&��dxDyseziWw7w֏>o{6�� 9vF s_scq��$[ϭU_S [wUW<��T[EVJoOK ?^ ej��Hg;dftB��~.(N=>'a}}q��$j~6'3m맲Qi}jr\ښ2Q6(I ++}-۠R^MmR [λ5 g/I$Uvbt.l[?ҺtwmMyΦ^=}=-½?[�,t endstream endobj 62 0 obj <</Filter[/FlateDecode]/Length 446>>stream +H׻J\QV j!`5~ +G (jDBVABDML9tA' lp֪THȧ}?ڜkp/-/A8oټFVǟp{43}}{^>,>A8"zzj]re~3߳d9'<?ȕ>,>A8rN}ޙ dl^#}�HyH� m5"g�׈D�f^#}�HyH� m5"g�׈D�f^#}�HyH� m5"g�׈Ѳ�@")��H>'e�DRL~/:��<c 7WݟeH֣��/ endstream endobj 63 0 obj <</Filter[/FlateDecode]/Length 439>>stream +H?KUq㟄%2$AAQS=4Zr!лtPNQ) "h1(gGA#WN^$�έdwv~;珕;p/I��4Drro'kJyo� {˗>MO{��g�bZ:F�~~_z��(6A$��bD?��M��(6A$cqýf�P?Y|}^g{{��Hy9֡?Y ?7>$e��9k_*V2�@ yK/� ?{:?8Y��"i߾+.� ?{Օq0E[��HzϽ=-�  �Pl>kv$�@ endstream endobj 64 0 obj <</Filter[/FlateDecode]/Length 646>>stream +HkqY-[22IpvPn6yIٝDa;;{:ˆ0/ 7\(ewؑ#y׫߷﻾woqpc�l?e^#W��ѦKf?fҲ=*+BI\39xpr!r!G\s<N?3}meCGRbth/ۣ9r!r!q1~J W̤��%3�@%3�@%3�@%3�@׈ɻ:1g�h3K/ \o�2U]9>֨��ėy۾istx}iɪ@��7Qw7yFk �@׈ +>?��ͼFTe:ǣtd?��ͼFT]=Ӽ~oNެY_?��ͼF,[>y/?4X8- n߼~~*9<ps|/՝|U[$�eg̜5;6gz558ٴc87��&cQS\T쮬F{zv ֭,\<H=�`Zz_PG[hgg໿y.}`�xZ3 endstream endobj 65 0 obj <</Filter[/FlateDecode]/Length 706>>stream +HNQ?+]h&0DX 1a!R\ N;3e$iP* UP0.{cFΓy~ɤt_t>B��d?9gNV} +GŅ.,=2���l@SF@޵C=���f=c11qU=���JONtЉ%>^Q}���VFQ4;su ���J3g˯e>'��p~o9W}��� 쁑L@^Dmc5o��dg}F@^gc^i ���BTvYi`,˝F@۩o��cr0#27~R~?zEY���&exӾ:}8rA]���A0r{e{KulrO]���Af&#r :GC-Ϊi|T}��@Z|>Njc~5˪��5*Nޙq~P���NjXwCo��Fƺv6~շ��QeE+{,w|RY2U��DE;%OgmF@''vXo��co/:~m �W endstream endobj 66 0 obj <</Filter[/FlateDecode]/Length 763>>stream +HKquBB!X +"ʲ:7 EӜZi0: +eBCG~B~t|>zob?5_o~Pձ]eY���lE/f$͙wZZ��NneZA@l嘱d}>}��6.'zөhxY}���v<y.? I3 i+M}���v>K@\q%-UkvW>��j+*3yԻT)~X���vpDދr4j,4֥F���;SqsU0R3V���v3?7II[o��<aiK#Z���ml@o1G1^GG;��$ٹC}drI+Ś��@2kr|u<Y/ /L&c;��$[fWl{$7<t*mEt �� [=C'HW?.z>��@#2{{+ +G\ww[��$zޥV-F@Bp9ȧT[��$OM G>fb)J<-o��(3?=?`]a߉]}+��D;G׬8;hw8>�� endstream endobj 67 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 68 0 obj <</Filter[/FlateDecode]/Length 2286>>stream +HyPg_8+"ZTeqZmBOZn-R<[ED3\$X D@ZoHשoɢ `~f~}}&��a&N*i/ww+-š4C].1;\k:v\TkCClu}����IRX,g/0@oM`s@x㕷'iٜ���҇#lrWBr&8T|Y{5;ٞqFF~����alhHey`嫸xWh?o,"bs/>ǥlq~ ����TtLU% M+Iغ‰>D- + +bd`���豦MrWd,KJr+#=96^?p]~+>Z*uy~ ���kbBB^EdR΢9DӘ?Ѷ)*mQl;bP�U Errt`����=HڶȏO𯔯kO g_?'<ƞR:$?&])UsYt_WG\QvE!bGM;Qk2D MO���sw[{8bLQ6GDr1vo1.3( NWJD،Ը+# 7I.-1RyqTxgrАli'< +YmbyDWg}VVo'���x,#y~^ӛ]S,W?@}2n<p8/}f;Ԛ135JpI7ckͨFY ^�O/;w8I$T3Uyv9.\\RRэK7\̴ylZd94Q.���Гb( +~9+n` @oRdM׻?Uk[O.wxUPϥX3je4(s%i+RoIͲ8 acp{WeYDTAt2)ތ-oH>YuaQW*˕} Vy^Яv,_���tm}FzRb*64\į&t+XxLmGmJo~ٛ<Ux:D({ն^SRw4d_|���2` % O7,(?#["6j?@_]QuK8tfF..&Je뺺ϊH>׮!ȿQ^N"\;=sƍgR?���@HCɡӒg 3?=|UJ +2FvÏ;U.cxހZ?=5M^"ep q \ŗ4f$tӛ���}irŅX͉ߣRA^y0ek?a/.&ۅHw3D'yXo;늳Ϊ{I?RUON\y0o7wΔS_ny���lZ+'5GS*͋3E�}gfjJ2nvzĘa_^?K EYq/Ϊ-Cڟ~sH"buc +<ˆƭ''>&SmD9B/yk�O/&OAYt��Y?U$W +jߚU_3i4=-R"`?V=akMyI˥ͷ2stt5eD5D7 <k{k#Rmu/KM%܃ 1џEX,=Gڪ���>6WfvI^,@OO޳J.pv{^Ll@xMR]' ύ,:D6{r甋RxvJO?[x���ަvSD||rM,?eGYB�}7|lŕڏ&?8|ũoݯuׇv!*ZEFt7ڨiC?T$WKwD.^.K%%, } 4ܼ���t!fܮ.֜)s&Q]]IQ˻FӾl|rvMb{[ +uaSrӯ2󧵞օE)IUU7ˎuobU7Ew5��w� endstream endobj 69 0 obj <</Filter[/FlateDecode]/Length 2683>>stream +HyTSg7AQdㆊZ툊KĵZ7@*H;0Q`P$ ! ܰZF\˨G XG!^ 8~{Wp*)��c׹Wh;@AwO1׉wʎag?wyL= }7΄샴\zꗟ7̛G +P73jW{XXHoLqP7c_<Fl6ӏB!=Kj^vhKIE"ҟpެ;dbSҫWeLwM\ /ummzOnyYʂ4^}knٗYSPs `1"B1%K;;_Nukw-HtwIiE>I"+;9׈~\p2V8%cԪoVrt"N"_vR&*RFde`3 B! +u/[E}&5rԛv-H0 ri3yuĮ�4,~L4hU8W7pV|,:@I3Ef$ܳ{^-C3`0g1F!G:zԅ}]޷~PGzf?%NJ93߯1݋ @}rG:rAMdҔZ%%QħLOHcrb4!ޘ,K<ޏΏܲ;kzj'|kN>K]5n]�8 +Мaztx٭ A[UUMDLe)K2Sq{o [y\!Q@!^@h߮/t`Ww%HQw;KzrPiiJv>a.B'<w*stzhjÚe +%%m(rTX"OMܒ΋q ݃~|4r30` BVQW<6| @P<}sO+H� +%k Egdc݈ +7{?rV7pV;x4^Inu(t~rqXIe7]0v%3}Bzl6y9mu^3_H):G`V?At_@_Ϗy3q1w]�h <Ym nWESIGgr2vFLpuva͙1<1}B/OJ獛V-οoOu+Hhc%yє>wXn'g9@a�,Y*eViָٯEWRSuōBSٍnC7ndjn,&BwZ %q}hԋw=%zdt3KT9H?dbzwĮ�NdCp QgusZ냃Uė46JRg$Gb4<[qlh5E!Đߺx& SGzA2GS[Oogb0@83۹<XdVw|X;_PRΗ\,͔HO rbz" hF!%yIZy6DCOOw*Hhs e111D P> _lkzg@ehDzB*,OI슲pL8-6'S3>B7`nl tڃb{w9l\} +%Fِ]*9X~h3B'<w� qiFO\7nZu'-:>DP K$FF؄n1rL1j@!ԅHǤʽy4g }1mu;ǐq"0@.վOOy +m˯4I#9b~[|ћ_0Y>zzL:BcQyn?]jmZK0G(ɥљL? ] @Pp3jZUۛʔYcP%)Q{vϋa+ki0b~ baGgڤ[#<,\$}B6Ihnݔda0cD�VhY/T;ޯ7g4v&|ٍJL%-&.5]š9e* 5}Bo8#9Q]K[Brwft!V830]ص�O7nhtj}I:/!: `͝=10jBw;R\ݫV~Cz?ok+QsjLoo\l>M2lU8[j?NeE<<̦9']Υs>!izca}V_ heQ0ff](WAPwvZF`8z?zAv^g3mQ<G1*^=toX ~=ndAポˎ_t ֬ggO+[^&W` +&<(`PyxYuVkArSPY՝>x@{5M:@F��7s endstream endobj 70 0 obj <</Filter[/FlateDecode]/Length 2985>>stream +HWP R2xq4:* (DA !*Mۥ9He.`91* +x,EֻG.+"/gf{�s+�J�.EtLe<)[n'qZl\t6NJ;$uH:u>-2b~~?}N+V\0AHl@tRw%&ՠ3O-MHw Ȉc{}vh} k #Pe9��ā�W1Xi +[\zqw_6Sx]A(4'3mwNwˎO Z+rb=y*hij:D`0Wܬ{ Z#9{6t4NvL<h5Sy\靄(YK\�G�n#"Z2Oo6%R+o +Z)gaLM 3 ܼZܙ`6+AW[z={5~vF27P{wEѱo#@:O+VI]([\bk3js˪g:a>7w-j`ji<);$~hm'D _D1Qڑ5(,���9Xn'qZlsy!N]~aSڇw +F=Y. +eLM 5ݻOcf^j5)㵵I_"K9op#Θr׼Qx;32VTXzБfAQӓ:)~vv\,6VmFbyS$WXSʎ+JMq> ;\56^MaD }#2B&ƭZ+/rAzFs7a pH֣1.(.Y�<N S:s2_5l5}UkXd@^NPVaW+NKqEBpC_{s`묖cS [냘t<Z;i;D>[Sc _TNGKu@QE�U^�_t^ӊUF}J旊ҤUyF^y ^0ErJN%į8qȬ}>>.-k`<m:&| Zo 8Bճsu|`DkZsG~v@Q-Y��~�m�7S'@OٸgUk'Iߴxok ~ܜ[M*^y(:%"T ֩c>;p(hX/9`GAq (^6C.WBL:A?&\56@Qo -@GcgB<:K,l)g^nx5wW"buQNVڞ +BBڣ~U͚ &! 4cntfTn^{Żw#(�|wz?XnvZy)qsB޵F{wXPz.|YAvv)a&a>:7 K3uhij~P[Z(|8;L;E,vGH%D ѻ~I(,�� Б5Dd@ٲ<:6FJ A/5łĄUM `,$~w"T(2}Էn&QɭBG0(nN\=ƀٌgW7me_ʕ7Rl,(51=*4j^'Y.Ad%>&}"2Hm%D b@ #(#jd!�7 o&Jfa FsWXWy.71Q80\ LDCC&ƬDO| >k_i^DDQEG�5�m�L?z[iHwJWc袰No).f'&pȌ^{7Z˥`2c&ji~b ^Vڞ.IrYJz{AFX@GO!o"(:v,q ? +p#z zkyo 9>Zuvs#ŽvuH<dji3v +=]`1w OKH$D+1-(n˖Do(r�h p7[Hqݴt:$t�/څ3%U #rRLVV oBv@1l#Zcvs sm6pJDF8]W7S1?g#k qYZ;Џ<:f)#m-ӣ@KfHk?c1f|WJm'|z` ȿ![Q1= g ;(L;L(t'}r6=yv>rZ(0e [,n4޼tSҖ'[ʁf>_PV\a3[Vtφ9C;鍄u߲=}BQE׶NQ�&8Uq*cRXWDF S֨dTW)EV G~Ny*:dr|_bw3V%!?\#Q{>dC(说6<T[FEBW'2}r >ʨ?gޮ%`6HO5zzfR1G>]5?ux$,٤o (fy~.|"bqdDkzә}BQ}۠;=Э:eAXR٤i 0�y5 endstream endobj 71 0 obj <</Filter[/FlateDecode]/Length 2232>>stream +H{T@9aj'S{z0ڃ8rcJ5\D $$ /`\NkO[eruvv7~ 뺳ˋ򃗘K-ݰ(:SkAwF#BwO`3{OR`0OlŸn^@zFV���LtDDmYnt0mq˜3fֳ㚜읓iMI?:wH]\ugr#,F6?Ȓ��'x6}.Q<EEc{klT5V_(fVhR/8~z|Ą C,#U4F ''fۚP Ӵ #fD8?.jA// ���pTADp$2k̡_U2q͂ޖ4Ȯruuҧ\j*+آ?JJ)bX7^G3<GcFʮ"qry[݋),Y=`8b`5Af2~��wK;fQwg}yU>-Qoyk2S}mͺYUA&){fDEGtZGޞ^*4?j~rY ,czb]WoSd0 ��4) " +#ѕaԥºJuQC=Ŭ״UDzJ[5lN-TA Cgјom\ǯr,9d' +ve ] ���XO1$7}KLZfZvN(m)eh*򣻕Yupǎɛ"EHB^}^͝6&Oyray֠iO❁?0b\f$yt'K|~#E69{Iw,���oXO9Ⱥ蓃Cdq}Kަo;-ԟTY +\W6UjRccGJ?:/ DzݮKS/o̯Ofcpg#Qdat7&F +}}kyƑRkP~{w��QHLTFd!jEt5YL%\?gؽ/m }"hko>_e9sύ1N|J;`2>g;aCسxLuGsJ3���:<SY"V:9=&/)җUjmVG卷ď}?0b̄x/*\wksy鍚+-���8-}=9r53b +f_9<]ӥ?SSN]QrĜR)}|xLP��cjNuS|"5 ^cy3҉Kl]IrF_xwAiNJT[{{z~"Ǩh7X���}c,ٱs#Ȭ׵߫Z8u7xgLJsduϱuC`vɖ Z{ ���[R,7u!3j:Zy\atIeGxg椪DUW tN,;!?|{��8(uLUj^<߿k,g:hN)BmǷpsGE{;/y<aiyb ���@X`"M(q}&c9 het\R{##G_Ə܃{q^J {፩w���۷�o+ qXNC8LzDwbX\$:V(<Q?<J]By���qP]5*U F̣x/#,nf$yFHX`_a#ψ87ob3���ԥzΙwm?0bX0ԍ'K|~- R)���q*Ϫ5jYm?0Oۈ0g{nN⿿���@\X~`9"B:wA<#Og/.aO +0�? endstream endobj 72 0 obj <</Filter[/FlateDecode]/Length 871>>stream +HIhq?h*E𤸡zs_@<!q"jT*"D46[;i[)F4.* +*bqEo-f /f&{&߼Tb ��N^N+jԖfȆَ1]V'By}Z?Gć5w ��8CZc?TG.2q?~>i2�� }*?H2quVeŻK��7 d:Mð?H>c~`}ީ7 ��[o;MzüuA9NT[8tK��+1FT8]$Ʌڷ ��ӗؔ!.q(4R맳ڷ ��ؓXVzvwa|&3<)Po��^ +Nyvvga1b"ӑx}��A{'<YcVcJ��{]A@ܲ?FVl[��9 +ec%i+Z��H/+(B~Mc܎斕xp_��]vi%ލw!!jVsi��:WN4)&Bnj=y>ݯh>��AWn ϸmka��M@}ڝAqX@7㝦}�ɔN ; !N5\y ��ݗTCP?wܺ?뫊~} �1w|ǭcƹr*y5L�p�7)" endstream endobj 73 0 obj <</Filter[/FlateDecode]/Length 939>>stream +HKqEQQeBLVm*"69$!E7efeQɔhcj3cVhjtYTJ(Z.qf94=<FUa^g_jY1cٝ/ Xghuty@8y��׀#)N~ƅi7cmQٝK3��}/{_ B dr{'^īE��0>d˾ϲ}{? X5n{n thF��0>><(om IרB'ȩ)]nܓ?�@t eskBF̜F_\=#�@t}׾93QPw~SSk��іi mԾ5􏤼T㾻'g%��O~ڷb!7^x3C^�}.{XLAH1SH.̐?ڻE{f�~.{}INAH1S'׎v_Oן�� 2ezmA $.ɊN_=;�@dlK}R}[? /fwy\i��Gw`WrVjBdž9y{fiP��_Pz}S? ?fըlq־qQ��+͵ ϵo +!njCɝ(q:U{�lM.{sڷbaY {#M�d_w{k__]׾%Dl$ygiL�� 5-KP A $XlVuѧ=S�@p5/}67c!vϟ*ڸ8A{�^ z{EہAboQm~=[CW� +? + endstream endobj 74 0 obj <</Filter[/FlateDecode]/Length 1225>>stream +HOe !hLBAd,& aFm=e0]s$kdD~U*�!EHtPiE%9%8p6g{=.~DkB��kF& VڌE$xԷmO BV{{,g^TI,9_ +��r9~>/B@ CHɢժ}?j�� ]7bՆV3?y?1S}�y1k|[y,R@ c^HFкk7mUZ��0u9V+?YŅ‚$[rW]9l>#s[��|~r.ϪwD4֝16hk9ߡMZou{qϺC)[1a�׍+G\ܥ|GPAۮx-99;GX@ͩX<+w�UOԜ|Bnr8n(/9",cS {�UW:-ژ˪w=Ւ@1`6QyxwCX`mX�t:n~Mv;^?jɩwՑ?p8UX&nW}�kn|/簜Ǫw#q1`64yuCXZf}3v 0��B]d]@Oa'5apn^t~[tn4֝ \o?vxujU��rk,]@Oa'"4L-?O-8!zZmY)wG7F{iW}VTTyyc��OIYE w�LiDŽ[/l-s8HGfSvԦgJ-d��RkNz?޲6 @t5Ԗwh>9r %I9^�[9+푦❪g?.O~o~9"_f׹"��o%笜rzD z]kz/Kq쒻s6Mr��x9_,E+?VWD";��o3wCY9oU|o +39$sr~�[ 84T=A)lNNmjfG] �9 0�j endstream endobj 75 0 obj <</Filter[/FlateDecode]/Length 919>>stream +HoLqSi"VXP"-B,4u'.Y.HH(nQڎL;DH/.m5q%H`]KL;/'yy c7Mn\GldX]#9r#߱|]k_{`bS'k��LUH/Oxcwf8}Yf�`NJJjwױ?Ma$gmlWL �^ǚe9n) Owîgڵo7��z|lG$z(&`HzXy4 �i?G}եc;bS~D �4ǡ>8_M 6;No%1<.]�`O ϕr?MaN0nmk}}�0XݳDEzTM 6{K*ܐ;T�u_dJo.>evAl +95;"�WIOލ7?;4bS}3dכo;��^VhˢkwĦ?f@qS^i^w��~HOVŃvwAl +ژ!oe^�k~HOJ_jwĦ?R2^h_/п��xbK,ZM 63w~wY�+~[>YqdbSSphs}si�@[xH/V.hӱ?MaN_?y˟m7��m=9ҋyQM 6Zjv7E/L�EzP`Tm 6Z~燞ڷ��-=҇vRf?Ma޾ȹȕ�MOzpo4Pɶ`H/�)"| endstream endobj 76 0 obj <</Filter[/FlateDecode]/Length 916>>stream +HMKTaGUiBdtˮ2-UQRH™RL"A0rB^|i=Zd6"MipamB+Ϲ9~_5Zrbφs9*l>Ͻڣ��n=zګ;7UlLMS߱w-e ]��)'4I$̤q#œΉK[��Sf"aMn4x궇T|��rSLeJ74̤q'8Kc׆��}C}I74̤qث:UdӪ8.��`qwǚID̤q+(Cu##=w+��\w#{53i;+]냌dF��ؾ=L֝;PftsML޶pcu|'��X,koM6tsML3.w& +��ˏgo;k +[k2fҸ?Sr1ؕ# ��UwRk[k:fҸ?"O Ot3��WsQX>o<D`&Y]GO +�z|\)}{T̤q8kw:'fF.H�;{op0<o7�?=T +LyK7-?IpފY?;>tuP!��wO|XFě̤q(YCÊ8��P +t +S[&̤qH(P?<J%��,T^DwLnLþ$}[{�|fu՗&J7m?I0][O{[w�ѝv_ۭ%P`&C֮x?nn �~ 0�q endstream endobj 77 0 obj <</Filter[/FlateDecode]/Length 1205>>stream +H_Lu$mJ%ZՖ2]5p"Fz MCZ°$l`0@9r9EB,u, ʰN*"Fyg{]<g\y({RVvnoY8W?Bb},׺-*K ��I?|RCδ*1S)ܪ^uw ��M HOI_Lb36dL3��I/I?IOJ+c#x"c!.eu8[ڮk��9W~JIzJwWZzY +x=#]-Ʊٓr-k��ŅI/e6?#AB=p5u?#*%qh�XPqHzIIwGZrvlu.,z Z?','JD獵tw�=-}Ji DEF3Gۙ1Ø/>w�XPiN Ք0XGy׏ƴ` +x=cWtw�z~I3*}1AE懇I0>\YmI0|geZ߭��!#2UwIxvlKs0.C⮩RW0mT'} tVv"�u 쟟cSw!n`j&[\DEF^+7$1K,Ug܎9fJpjwv,`ު/ksٹ2Bw�OתHuww2yOcPNkaliHpd~pY/#'{}�gz|_wtw n%iJY"j|ᲴDȒ6~|>g$&�y]ߖ,}r +BwvbtU}%^7�|ڷ)(y%㬣"}sozFRwG�ʷgVNLaC<)S��c_ruwA1<n:i�];c3a5KZuh}�0+mJW8̎AqܷUUK{Mo�KzDGEwavbl'�^6 endstream endobj 78 0 obj <</Filter[/FlateDecode]/Length 429>>stream +H׿KqowwQgKtRQ[u5t!lHBjQ~TY{[ВCwtS#gx'������������������������������������t(CϵV}}%Z&=��.WΜ ߖ޽=ykēɧCg��c.4j?Sg��;K͍󾎎'��Ҫ:=UYm.ttE6_L��):?֪͌ o\^>9!��HOs{ؘ}~7c=Ⴧ ��Hh!RyrOho\pd)ݒ$Ie`h}GΏ [`Nr_IR'�Mi< endstream endobj 79 0 obj <</Filter[/FlateDecode]/Length 923>>stream +HKTa.`eF!lQQPtqa- +{(/Pa+(J23XEV*iFH- +W4:Ϝ>y<frr?ˮ;s +^3�xdu+mÿ=6_50X~o!>n}IxO_��~HG*Zꊵp0?GLeUHa��~HG2b=nl?ܬZ̓_'hw � i `6ß2HcyNop~��Oz!ݸi#-C?M5&ɷYEi�7UUspv02̦q[EKm�H]J^T4nF4K?< ;=<�RWOatC]9fӸ?oOLC%i}�֥i҉g3`64uoDN_6�RGS1҇BYfӸ? mq�Rc> ,uBU=fӸ?q l\w��}ݧ.;ڍBb?MǜsyyZ �tFIڍBb?MK~l?ܹ�͒lrtv8fӸ?2piMww�0ou փv8fӸ?쳠<<qCCi7�0~l?]IHfӸ?tU:siz�㧷fb`J!y?Mƹth ~n!�`{/ӑVZEHfӸ?[]:U]9M�߯ww}u!?MS7~.�Ǝޟ_+n4e3mnm`�e endstream endobj 80 0 obj <</Filter[/FlateDecode]/Length 929>>stream +HOqh5Öl!\qil&bkEbE-?.1?a]Hͪ7CV k&qK}a5y>_/~^B1'n9M/cMd2Xf˙;_`#X޳k Yst|�x="g/Y9 )MZajZڝW{�0q};/^sbS8c| kw%�`| }_]ap/VK�{Q->PFcZbS1}Jyq>E7�'wE}wAh?MaK<8Խwvw�o'/'߃eNkwD'�`잖DESڝ`p;LUOw = +�=r=;+%kwvv�FkOfkKwFjw ‡Al +ý5Wm ~=} +�3~;pRUv Ħ?kxsyKU�N˽-[C^bS\w| +�x'sjwAl +G\ܣ߯�};]r.W3Al +s̵ϳ@]~�~{l@k΀)M3 u.Z�ÏR}N i)|Wz}[�1r.bw1y~Tv�yvte]bSYs=|ݻ�fﮝ'xk9�}bSYTrS;wm�H=. 6_N7 �n$jAzNAl7�h+ endstream endobj 81 0 obj <</Filter[/FlateDecode]/Length 1391>>stream +H[LgWZ +Lqn:2b[\9,Yr2+EP9*# jү'h. +Ɩu.D"t/ǼrZ}$ a Og)Ow9?a\s*c��dSR @Zt.Vz!C3k-GT:fn1ҭ=�zb}8?o3Cv)]Qʬ7ne42�QMWwy Dgm]:A.hV߶]e,ٞzb:tf��%F}ux` "&n2~3$>s s.ڡ +5�@_g˜ޝb@D/97b4ɿ##z$d?t_O�( :B=K}˻AL񴞪~bnICgta**Zv? Ij{] �$\:PEHw׃?]~,,J~5T'ʰwla@;y +'x��Jl{IMjxw< yT2~v\Ksr>RC]Nh9`@zY|V_vӣo�(iS{ǃذ?ǝ kޠM0`sq:{iӌ?a>?Fx��r@tzw?ǝ3]zph4Ϝyhg""Ww&Lچ3~xw{}pY7Obx7�zTg)O d; --jRh=̴ fGoʌM +7ub[z8�|_X>jj>F}ʻAw"Z26%ю;gϴn:yUDČax~vmx�rzw|` afw~lMXf ]Etv&.�`"Ia2<ŻA^?QV3SiI9B~rJy}(sshU��"Za~tѨ ?sD$-0趎tf�DD81B}IɻA~?%jcUy��"IKޝ ()0 Vcz5=� ;R?:yw5`|)XV>/�`@bzwW|a J +̗}i6|<Ԗ�z֫gB ()0Rkw]ü~�W +0�j endstream endobj 82 0 obj <</Filter[/FlateDecode]/Length 965>>stream +HkqυqHRrcʅ-Dr'7~̌WqL~5?9~w4Qvdffʯ(΅y|?|_\*2ˣNc_>wbrFTCy]k[fw9c+(d؁Al +mdI9p{lѿ� #w* }ɰ2areiu:S͡J{��ؘT<)'=Ű2eY`p��Sޣ{Keõ;va@&Uϗu8��2IzNn[ݱ ?Ma |LM<t>6$� Jcڜhxv>bSȴI̵'XXN�$t뺤;vb@6,$hj[�}5o=ݵ<+o㍅� oL^X؍Al +ۘgckڝhw� 1tUKiw, 6lXc nݳ*�W2~&}&ݭpɰ{:x^�&uVzH0N7?Ma@CY?Ks�[_eAL.w?Ma@È?WU'�w+~*1.w?Ma@ͅ&ikwomп+�Win-/?Ma@Ӵ]Е;# �{᧭龒Nx-9)'D^Wo �dZ/Lxus~{H�}XBim)] bPQtfM-jӾ7�@vgVkw$Al +CŨ|s%\p{Կ;�xP=; .�2 endstream endobj 83 0 obj <</Filter[/FlateDecode]/Length 996>>stream +HKwOj75즌ۅ좛8E /7F&")f]iZbgl s2=Mec_ZP#X_౺v;Auy_ "j0~?>_>>19|q/7l4-I]KtN|eL�r;VԻ;M5{5 %s~i9)пC�.;?CGڝ)xȻ|4V0<NGzH ?Mav>N?á!VHj~vcWeփO/PK�MsokcVy@?MaUl0:GG{C�v.3Fz&:TnP>EbSU?E,ҿS�Ez\oL^Mz/ 6?5WdN<9{x R�IW_=u?Ma/JO/ٯ}�CjQz$/)IAy/nҾ[�ۓ_Kl?6uĦ?'YSsuO}X~Oӿn\*=RR"m?MaoM)n�~8uS޶C'ڝ )o֛O;9ɫ  �v`892M?MarCc va7Z�6 ܪ|, &b)ֿo�xS6c'/7 x[bS`ciY֫Ew�o^~Bw 6lWeN<ygHn ~*]?Ma'j[R]X uG|X`M*#M=?/ۢ}�tP"ڴZbM6~K龟rC+�:R(^&`Ħ?`A:񩇱Uw<`� endstream endobj 84 0 obj <</Filter[/FlateDecode]/Length 2487>>stream +H{PSWXŢvm}֮Z-Z*#U(G)S" "H.$77,kݵmtL&rB|3so8__RF2<`v\_Q2/)& hEn`tbJW[q6vwt>#fġ9 皶dB*LAz{/{C8ޠ{?ڽAF XXpŞ#0*467%bׄY}Thy?w)k9�^A\/ھAtzW vB+`ww|3$¢1u2�3)N!}m0`bJC uI6Nsuy?w'@ JAr*A'!2ܖǸ^9vA�+dwx.+͝G̜ER#;y'#fa@<~ N_%AFS{hA{ ?\dy9yx>wjSLHA{2w''RM<cгZviK0`9&z{ےjdQ3e!t'1/-0@?!A״{ 5?ƺ2F@߂9s%%Mm4W&<\ڦ\l/0+F9} _%t zS`9m:ٷuH?Uxɵk}wf;˚?j,%uŶDɳg/Ltf2H!~ +Azݲf*v/A�'ժzO`?cYG"7ę,]U WnA{8i?\FnkĸI0?x 2ɼzp1]F }Ny{=H-ށ +֞-#Z _d'3IYs򒒦6,AMox]ϥT> A']>o@{�o9]~53ʔ]A!odG3xL~ A>s0|=k'^ NDOYuJAek''?u_o^o1߷nV׭*0}&%K$LJ톽mG<{}! Us:yY/tyT/h;=S|MaPY*s2J5>9og˨t +u߅ JУ^x:?ܩ?REzpۨ~&9XSfR[s2Bcl.V^w|BWTmy#{uH{6 ra}UU\W ב~i{d1T &^~PN Ws;Y\vx|uޚUEY3{rOȱ}޴{xd~F%>&ȇBO6tz] BXTG;0{I)hZ25gCy37r` 2csCIyX+n-Ds]u7ֱyidj{g'9dSo?&'v^w_r{xevzȫ=x~L> A<[tuU6@zO@W�;3G}d^'m_:1cEM\S3GUxOW#:<<'Gɳg'|=p#H|e69ɖ )by/GcZrH{r_K Ԕo+3ӓא˝+h1s9-tH ˝<Lu]`m%YG6 xac3t7G׬SYs}}qՇ+e;Wom6*+[ymg�Op̨`_R0QZzy \;BhX``d[zLNZe=Eۗ!hQù?=�A\ XT@h9xq[_o5𡀹|uz OW-46ɅzI\o+0VKı^,1՗|Ol5p<bdonQS+h,<Ҝ0)]ʶF՝sRGCwtϯrOβXY8莶N +cUa܄M%~ñ</j`NZcjXoNzSU 4k<ӒIٷNefu^H#GSɥ?^LDkrȏdp^c5 )^ :J߯!�zzK>m#ã �} endstream endobj 85 0 obj <</Filter[/FlateDecode]/Length 3212>>stream +H{PT`Mh|MVcbq#bA% +˺˾rݽD4VjHUb#>37+r=g3;߽\Ηܷ~ Hib-wge~:Т׸5_4VWf=V>)VCS8?gw/X׺=Ve ,*9; )᜜i4SD`Т͏$Vz'H\]x۔ i C�uu[W2v#7}kз u1iGdrfXK L:}fԮ.qy}Ȯp~XPIgXUa[@$kݳovZɋ *ZS0g+A[M +No#ջ_s A*P?v%uݯЮmvPMh>N9z'k%l]k/!׻V=`לE]3tE`'�ğ'߂5P4yx_URF?gP`Y0辏3Pqz oXY!K`ߞ{;q2J&d~=5 ChbJCH8ߕýqI5g<旸\r97J;bo{=c9jcki9%3WEMZM:YB(B3x-\vYѶNڪ]ozmM"dyEC[)f g?1WۘFPdppuuDdML6Xcޭà_>dTl-|=pބ?Y{2eΦ-E$qB? 6ӛx?l&0['{upY6%J[ԗ 1C23ý +N i4}ʡU2 ]򏼦׽ 1ݐsnpA5 C hbNf;{amuh5g<o4;2Z߄"[mWz!4ObK}-I9Ǻ z Z?'T24ϝgStn}TZoxqUh.l|QhQfkxm@]|.s'ICSuCvdML6AĈR1VB]o!Fr峚/>MUAЮY@@!pބNr >MO!PPQkA2?d?d.uؙ ]6/Pv I/D41X~8;6v zbWzvM"@&&C %Y j5{B4B�yu@D,@@$b-wKS@~CC'4ͤ]"6PP gY!Kk1׎GQdz@~1WCe)#hhb2ocR\VOϷK:s)ǽY9k<:LX4s"3b-w~ цy y yND@yЗ3N_~}%49K̏;15s</G{3Hkj(w4cS [vMyXAm\hS@>C^I]FD̠@yH +&-x%E]p괴:Xl<;\׏̷i] >A[_mTvM!ȋ�4171]or#_# 1z6}b`FXnS"H +y{ةCӮ%yQ@&&FQ֥3NL_ET~Uʜ`75}Tt[>1}o4pH(8Nj+ck̟{h1;qok[�KL +'2G5_o1_3?ýdwI6|Qs3rp&a +{?ppօ%߰߻,Be)#TcN,O=R<5Kɜ+7BDµI$xC>^7P:FBM7L@_\dB/Aҗ)+-/B hb2oЯJ4 !X暶?{ʘ,+3F|ԗ sb|k=wLm$*OqC/Z[/w?ጒfUҷ-"tϥ?@c>Hk|7ӳ?&[%--# ,a,q65 +Ncs0_rMa 꽳,v"w\iX;fL겇cguV6V.g z2X +kqquS5dW as` t Jo+78 +]|[sb݀P:uhMa<3GHģQ0`pf0ڬU+&-شl--hs~l{ sl^gE`b". ݊Ղ;֮%v9!68,SY|efo^Ƈ?@)|s7o {l\4Y �01h]{׮zjax`&sdIy>rwnbط +{ t( JMkfeӏLv(Štxatٴffr;G(/[C 6.Xc,P /_>]݊@nq~5ds@i#ӆa[)/wڳvÀBnRHz׬u݊0>㱙80j?}݊ 4y`7,w,ܲ|,ս~^ݠAu$Awa: 4R!c[׭|z!@?G1 +0�s endstream endobj 86 0 obj <</Filter[/FlateDecode]/Length 2560>>stream +H}T'5OՓ5QSk1Qj5ȂDqAPevv`f]DP\>mC +G<izғ_` Q.{{̝>8o4wdQ).-='pAc!5bѿQQug~-)~Vwxa52F96?cC"hu-EA9onXip={wX|-%~[`{IrB=\UG~-#7-h~s~>W객３N۹Gye1Y\Zx?VfJWBqCDZ<k OvzVX s&l]L[L8' &uRS"^J8rX#1&A#ȏ)w={/ Uї'*|//(E*=?]n-ٷ;{OfnzDx^->S).!7ۺOos4!sq=�_= ZWYKZmm΂|HE![s⇫f8r<|a7Ԉk_cK uCo*-;:ݘ1Ggo.kcJ]AfP΃V#d.8(+#+O[ė[{:*({:LEf:(]zl7Ʊ֞1.n3YNK!ϫ2_ޣ3Xk PRyb.eZ)9<vϩa=ᙕc3w?.];cr$mV>$lڸc$*O#HG䏶]5EN�,G[$3ؠlJZ{ODob_:(ݳeE{VAOAo5OďA7/n5>7-QQ?l9:8}F_ĵ2|3]yFDMqOMʶ0[\תӗ'f:-fgyNE+$ 9U(+:"乊LLؗr+?`?pIvЂ]Vn}ykɾ!srnDk^\7+{T|n+ui,|[h =ŕd/Xk A3x2W.-)~AV_ iÊ\ ̳dJtޡԿ-2D (3v~oV0vH{ihF֚vQ] +=;h란!S[<![$gd8+d.m#/wrVmWЇA~%bY뮫0%qU7c{Y�@7t=4A/=>w_</ؔ4 +y`D<M !SЗ^pA#׹%>^:<%<'uTnA7;FBGLģAJKcn*󟾟ypg<Xn68 rYmU$GW-Iʋ7|\*bw/><.厗Ya] ~?T?:!MBUnQh|7==;x\o?H eU TZ*o#7-7UH|ƢCOBoqnQh}|',&:d: 胵F x|(Pi9y^7[_:J]nѽ'&>u;L{hnIXk 'AhBsҦmWo񫺭YGVDS_YΝW"$AAfHL.8#[9r9{L<9#9Z5c&ZsAt<?T?;> sE[̦gM g0k *-.G ezF9a =5pDqUs/wDd) >?T?;y5r.+d-9,ڮŒs2&~�`}B7􏵆<(Pi(w30d*27UZ5EF{ooPCA/֚!AA MI\-A ߅ UY'iޏ{8;ޟUe bNAAAMIx'j$ջgu*Zz.Vq8 (PuV ّե&y~'l;Zj\%Xk AODn^l7ƺEA¡}`L ++9<q8_3κAx?�sH endstream endobj 87 0 obj <</Filter[/FlateDecode]/Length 2361>>stream +HkP,Wo$*V$UU/`$HFKA 8X!r[]˻]DT̴&R|L[:d݂}a<y?0AįX>k.+ ͍9naϛϺt>LZgܙ]:}gXuz>1 h8r[+bϵ+;h0k_tw$AO4O4_4o44444|{ Ah͠s�?M|NMHdFR)P+Yi_K=<^\(;ۭrӠ'GN9Kg -zC.=Q&[P2}< g򇿏3O3](Nx9Rw y<kzZO '7+\[phߘ^ <|\ӫhh&ϐk=C.ki +2i9~cW>wF=Z[hmy>ǿd^RB4v'Myyq'/xB�gz-VawM^Ud=/k<yXhWFsɢlElޭnz]Oq_U2E +y™)۞xqX3I:E!x g𬈄i8)^tmvפeU&3x8(5YJ#N=?dZxA%sw_޷=W{/mɒoOϡsTCuQ}g' Mg и33xWs40oN]gz-VawM^Ud=>{.;/=Z ԷǶPu2cɶvrȈtˠ|o:pHES??Q}%T/s6}1|sEÝ�p)SΔ ^#]g#&\l6i +2if  �pG/sC ֩6G9A&Y2H8- [�AA39ktnU8FR)DO۲R'qU������L`ggO;{s^7g%4aK3Z$lyOXwo0}\S������ e=7&\ ESݫ>rhHG����������������������x  ?)t4}Z+. <#~";3C#ɸUcvpg eG:}WZV&h$W FʅY¥ZJ;톼"ss_bӕWUm&;M ݋hnWbXL [}"Z&~JFK~t/<n=!6 woO�xLiY箪ۺ <Z߆^`tlmߛջ03s2].[^0NPJ1qʞÇfnLeeM}Οtn'.oƮ6g]hPVj 7Dn:m'f|&3ʤ{6o͝٥^02ߖ̆jj@1"/;vZDB!jL9!؋X>/_p:;+k#W1 Rf{|gYt .ɵؽW5-GMH끄h +F5l\>x <ʂsg~ffN= L<Nu:JylTLZkV;<v?TI7Ol݇+K^~ڣک}s +S/>H?K cYtUmUd+IQ#i/XmmiYsU +Fy[#ɠ=fY`N_1G{qQqNZ[tTLmGLuZ:~BLZR(N+KﱮAO{x <VY.Ƕ}A\{i(X۷ۮOEA~(eO�O$v$x6kcE=WU$YcaoVZS-mGjB"y=+K q]`D/ gӕ6zg32;Ϻtϳ'qEzU][ݶ=tfe_۷muQXҞήωN e: E67 �s endstream endobj 88 0 obj <</Filter[/FlateDecode]/Length 1275>>stream +HSUeqAPh2L1i0hᥦEcRK3"W"Wa {"TML| څFac93{Ξ2=9GQĢ8eSjo =ʊ3߽mINF u.(B?]w?BCIwGi/K+&y=Z^~$ `<eed9(}2F 6uKC4 cŒe +m<g%k~*hi'cd? +LTkUM?۴#{sd=69yS1a;9b":r&P{dߔ~e[0AƺDFǏ|OLky~Ut5S[?ݥ3ʋc,7_Gў9/(\Rc~^Y:'c߸d,)<-4PΕM]~# &ΊQec?z6t[=֎ƺɩ VOr&<2?*{ʥI>Om^]){(mاzNw٣q#hui0~ʊ|&c9aCc!o}_ֆ_S'S};Ljxf֚wwk^sO]Q^c jzT#-rteGFmn7vZoHW,tϵsXis4rGXGƬ3ƖH-Ud1˜)kXR/+wHmrK8 9UP)g9++/mZh{μJ H^IaMgOLm-g'/\ՕP<2Ll+:}p?d^r):4BCIwGiXJbEk*ww\VT#}9N<gSGCDANjve& #c%w>ί\l1nN[z;-rNΉ$>AQodl-/K +axr6+_i#Դ{뛊@ݗx1K?szdyY\ji*UՏ?;,LAxGjճUzV\3k.����������������������������������������������������������������ğ �R, endstream endobj 89 0 obj <</Filter[/FlateDecode]/Length 489>>stream +HAKTQ i].$r 7Fd]ҕ(:DF +c.ąD7pn08{0.x_9m<5Ƅ٩HEs1k_Oֺ7^tSxZ߶>=bO+boTT3\'WtsKl_>>wKys|2C/9HՕv7/~nn>L?m)?}·Y|2΃q?^{vOZg3}·Y|2΃q?ȕ>,>A8J6Uc2΃qzپF$ �63�@kD��i>�;F$ �63�@kD��i>�;F$ �63�@kD��iIՑ�@Ds��pt|s\Y��^\ 0�- endstream endobj 90 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 91 0 obj <</Filter[/FlateDecode]/Length 124>>stream +H � Ao:'(8S}5���������������������������������������������������������8++IHj@.+(j+ @f#R`�& endstream endobj 92 0 obj <</Filter[/FlateDecode]/Length 557>>stream +HIn#1A4<4003vnPc^y޺ϔMM)*kʸeC{l攻-Le;{柌Ǎc7'wzoG;5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[Ժ"}d1сd#uE,Mؚ9&5qsLbk1c[7$\ }`Ⱥ"Fv Nƾo{,bcGf;6C>2e=>%&nIlMq艞xn{u{B7$&nIlMؚ9&5qsLPkThspNktNkGcZGSZ}d6#+ }>2Z%իA=AلZ5GfZgtddj#"S#GGD6񘥙1K3Wcf,\Y0gGΎ  :;44tv4hhڙ;3u>� endstream endobj 93 0 obj <</Filter[/FlateDecode]/Length 756>>stream +HIr@ CQrt.ը!I IP__,uݨ3j`llͰ[3l <H5llඌ<8-&n˸Ƀ2nlF +pу\2p� =(%[ك1r` w=#grكܱ>Ct�]eM'S +'v= 1/|ZA1!dI_!19fQ_dz>>]N[ꜹKCݚ{o4cetWGvSۣ#7IiQ ݎ۠4(*g}p Y{@&vh81� gQ*Zz5,޳Zv|D boHܦMӦQ`ʞUl`žfZ䶹>QO/-c_n{jio#</n=UPU%|o z᷇nD=nocd8*NM=~/ z \<>[^8,fp,Z2 %1XNZf뚘KxNEW^$<gUܝkQ/StB.^ۙ%z\GQZx^xחv!S/W?S$gV<Pn:QWc7(o.G>/WO]ߨ[eR3&u & +:ne[v"VBΫQ-� endstream endobj 94 0 obj <</Filter[/FlateDecode]/Length 686>>stream +HN@Q@ zhx\N. ĥS`{;O:ΪFq֞Dt֜ТBt/>ǚ4 dOft=9: 綮ed_9#T�džK^P/gK~SN Sur}vփU?/!ß}|$߇0hs| }?! Zt6)+?OS69éZjÖ?gKeS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LU'k ZTr,aӟrq}@}F?o}V?o}V??J' ]̤R#ÅefR)LS0Y`e?m<Kuc`��م endstream endobj 95 0 obj <</Filter[/FlateDecode]/Length 589>>stream +HAJCQQ"D"3$KSo/< +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t/ +ZKfRzٟ+.h>} ~~ G+x[vݭT?pw+7U3B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +.� endstream endobj 96 0 obj <</Filter[/FlateDecode]/Length 594>>stream +HױJAQWD'x0m`!U'<7`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTܯ<+2lwSѵbÖ弒,*X>|~~%y*9VtcEM+ov^9.|z§ +<P<_?!9+ǩZa˿s\4ߠ +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>w�a endstream endobj 97 0 obj <</Filter[/FlateDecode]/Length 726>>stream +HnADD!bVd=Ɩ-uSF0>iT{LU躟16lOW%R\>@eIC�'ͫa[SMѴmSӪDHSӆz$ތg /KCgp! slyK]1J:lϙ6eRLUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LU?nڔJxaݼ)qo7n?xZ <Wnwyއ�`_ؼ4Ѹ?8n5Ѡ[q_IoFkJz3Nއ�`_!?{UiKV]!I6[̵㱷{[9?,ǵ Mߖ⡻W5a79x~⫦%_|Ec_ �'bd endstream endobj 98 0 obj <</Filter[/FlateDecode]/Length 582>>stream +H_kP\ZLԶ-QĺNnc>Zb 9gh9'=1I(dIB*7bx~.G˫1>K,bߛGʌYQքY4MiW><O>x5'x:X6z)?Bjܛ.s%<O}slm (Toғ7xhq6$ϡW*ʥ?qc������������������������������X3ӛ*ݗjyw=+GyO:dx5Wy-fptno_N&顛gkχr8 ^Yώwyx4{sr~.>V^:Lu߇{TyF}ܗ߶z-o6vmlV;=g{~bn*5=Ri:iifQ[ ������������������������`�]r endstream endobj 99 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 100 0 obj <</Filter[/FlateDecode]/Length 457>>stream +H׿KUqᣙP"AEAN5cu2 ҢҶA쇒 !*^ ١ #6\tgyJbu3۬M�jN=o,X0;��DR7F畼'�p =Nv*ʓyo� \mjjޛ��8?=�§q5��B{(�@"��Ŧ?D�� �PlH�@"Sw'FFr�@ zyu�zAֵ߆>a��z58mNřg�P?{~to{_wO��H"i䞷W Y��T"imx)e��4rZ[ݍ/<mp�� FO�I endstream endobj 101 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 102 0 obj <</Filter[/FlateDecode]/Length 705>>stream +HKQP^DBn6Iɰ2좡.lN,lEJfBAb-)1.&/fwA`y:#||�������������ݡgþ\:u=X-nF ���\.HÁН���@{l6c*%:35-����vs6]ho(]]m����*:3ͥηV.)lbeX~����F3 ]sӱѣbF���<>ckQwlCF= ���dVb1grKO5|k[U^mMuIkw4A!BL1yMmY^ǑY'!B1wEp8Pe-wS^ӥgA$Nvo ԘPgBIusg~cy$gS?Wi/ ~v5Vu5VC%uf^YzM›V'gjj` <]K峩ե軀;:ɏ:ˏL~X Y~X P^OOjjk ��`nk ��`nk �W~ 0� endstream endobj 103 0 obj <</Filter[/FlateDecode]/Length 332>>stream +H;JAv6V΀LPl+Q`#pnuH!\/ô89Ma9ΐg�52g�52g�52g�52g�52g�52g�52g�52)yج} +��?Ȥ`-��L?ȤepV��dR<zۭ��A&%ϷO��A&%ǝ__}��2)yn7ûj��?d2Ͻv{X&��2g�]},�=},�2?��b?K�+q endstream endobj 104 0 obj <</Filter[/FlateDecode]/Length 545>>stream +H=kSa4jТ. +B[14TES*mAl;5(6DmilpQΎ!)M 49}.8p^S;u:]S{�<R1F,�d?�l1 ő�@ALB׭L�@[3'N~z�P~h+k|zvc�PF|6O�@AL/?Ʊ��?I3pbGq2��jb>u/{�?KM�/g�dv � ٪b}X��ɦVGw:Zr;? qih8xF"hف7̱Z=M_.,5tf?tƣ;Cr!r!H½U6Ģje"fg\ apss3zC9C9kj?E+�FL3�@ �lk>�� endstream endobj 105 0 obj <</Filter[/FlateDecode]/Length 660>>stream +HYoLqCHZ% B{*\%.D\ AC";Z"h;.3XZZ'!!0GU\uϓ9sII_�h|Kxs�M^#)N[]8my�7y$=ej00�Hsg^{Q��H.y[U"xϾ_Z ?��M^#[o\:ybYY��H6y8;/~UUQ^��H6y +;\#L��&WWNߙ3~ܸ�d׈9s 2`|1+}t>TQ1<˴.^H O��_a59M nVXO?oS }/ٖK �?+}qS]Yl[3b::3WK׌x/{2|i��aO ؗnk fߍ^��0$:Qr 7�oL3a�!(?(%Gb�[JI?:��C2œP*v@m�`HœP*q֍uڤ^ �UQN;P*qy]x=3UV��Ra>;iZ'_� endstream endobj 106 0 obj <</Filter[/FlateDecode]/Length 740>>stream +HKaNj?:hYi +BCaO2]E/QFJD6!W?;gAؖ~̜[=H c-̿V}���p}6iru1:6ζ��� D~m8_N?@6pT���!MtR\|?[ߠ,���=&wY(k?bJ? =V}��ɞ]v}nN.|Kd`ݚR}��\k!$wYh?)V7`u ��dc-H}F@'1/d?9w��l;rӾM@712,ϝlT}��ZO褴?#T��`蓑cr]tS.x86���wH~.?p3^���Lt"y\Lֽl ��D;uQ跣gf��E/?r1[7W}��Ibcc' +} \ԆV+ָ���L_rՌvR>'wU��`̧Rû]F@'cj}N��$rEnU"6'��R[{a.GNU2uD��LjrAˑnA@WfSlT~F�8* 0�ʏ endstream endobj 107 0 obj <</Filter[/FlateDecode]/Length 1675>>stream +HwLwqEQUYā**"W( *TŁ(p2{O!S +uT(*qE?ˏcrG_}~^7~��^61ARS^/svKG==?ەrCz{E7ƞc<M|nzrZY����mAFYb&C�!i)-W���-`+L YkwG5ҳk���ZK&jBZpijU���,wm_ d27Tu\Ҟ5| ��� d\u ,?lNەQ'���rq9i;_?@HPEbN]����BXO:}cF~| +��� H#hcӷK:$So+���m 8S,B~,q=߻���ؘڛQΖԽ-wA#Әa4sMYZdIts/b 4ܽB߻���K9Sx@e^JbdQSUՕr,+:%MBܢULj,ZY4;5CGB:S+���deaA 6G{jX&:˸x<!\7(E2qVt.ZL'U *\L;H3:=<!DzSN=%E&a>cǑͿhYׂ3c?-0ątdg\.���k362Q\MeGM^HM2'u +yDtWj[:I T<yZl!SĄ:/���>"rBD3='P2bN-*ϱLS/LcRzQvD線ӝwr>x\Zvr +BcH`Se;>:���1deaAv6Ξ;a}i!4c'͝'d]'>@!(*~g)㲮ܪ OxP0ζ*(nՆ]yT[a $m)[J8ڕK:">���|@D"!O?-Yj;|.qgP:הhKY_r.C w7{R17Ƨ#ԟHK:N;%'ebN}-͋|y4BC���/"|1g$Z)9r[l2ݡˬk(Noxr<l䎰KbvC۴^`ti5]ҁNGRDI*V/#f߽aS_mc4=;wb?_X6}nps-����OD"5ȅ%Gmt/Ȕ<1*U$9[Mw1'rITxdKѽ"<v ���xbJ S6G+RU7e,qYWnVD}Z[Cf?QU0f}>g4 &;[uveDb;SB;bP���ގ;un?5*qT>rNyOɑDro8*MN`￿�f' endstream endobj 108 0 obj <</Filter[/FlateDecode]/Length 2706>>stream +HyTSg7B7D*hk[BE[v, D@d\ RB@HBQ&*HXt +NqCa>Zc!,Ʌs~{X͆a%9<YV(W]mi:}0=Kx0n/KLQfxu!jj!ׯZl?DwBb9ٕ0ˊYYJINۯ'ɟ(yzm~+g:]sy0Ku1jtQwHO#.8r&jΝ~װ\W[)ݴn:uG`NbJ*ny~n�:jwS ;F!P_Zt:7y;/>ƜgeS}7I,j`1u|?!}@~4-k tf1Ք<͙ёT]pb;?[� +xqѫ>Bh�ϜNK?="&GۊS-pr徛75lb%{C_zp/a4D t|V@I173;0 p m45ϕ8AB!u[yΝor>My +DwS(ⶆ4/WYLlк U�NnjccTYՆ95 iE*QrvU_WgHw/g?CN�>r#㡼EBh0f0ӏ@&0朂 -$V>Vcv):<\a .+x.ΘňlLX* ):ҺT}F]yEH^ƩONf(!n4X[�_Ç>qR%w,뒟ף5L ^>YFYfBDxveSw-6Gu{΍ZCt!YL5͎NfqVj\*o;C"gunw{P[ǍPŌ?S;@喗 +sN24zgo_Sy:=w{d0B!4&5˖CTP$5O.In%Q]>lՅ�| \_+cuqN_Wd쌊#$U7CM?S�J*n{<pLՙ4V|OgӆBb|ikw0IIޭQ+? yP+ot{-fd0SWZd@[ZZ HeVJD7mfykzWϿFIorhU~ v7B7BOG~zxV-U9+1P+,نP y9]:QڽHO#AMT'|}ߥ-) +MWճOs-,B!M40mt3"#Te +߇xNkXλZ7l:kbF~Ho")K&8M4%0Cۂxo'U^gUJŭwk"xXϊI)?3KN_B!;=X4v@O8ׂ|Ay5?î7C?�E=3:KudNwj!=Jޅ Geu/7rǩ:g�RQKc(!clW.khѻ +7SbnePHmMTWݎM˗Oul:kbFٌ#Ϣov|u;4 dc'd@rjYiO*tM.Bl!,~>ls[K + +2bKɔ$z i(IC^+njv M3vCz/(sIƲ!P!55QΜz~JM.BaLW[Y;n^8tJ"l1]dwV{-UfgtL4ɏW4gZ4 tx I + U2#_BM4=<#xXKc}B*jYxr~"F6~10#+ +KL{2ݮ&ob~؅YTykd3giB IF`7}vr#~~3"#qC^U{}!nZ|2Hr˖MiB�JΚ@CzGҗp fp@x<+8QgBc:a"|7yi'0C'Te +RᏽDYunn8E@V�!3!}Tjmw?>=;4ڼA>q1^]5/:|2_<<Q0 +F(�''6Cr@cGQĒ^K.Bc\}[.v(z#< rV |oߏځ }Dik1 +f[.ܷv%pm$+efG(`@�?7Calf6_<xU>ƕv] 7G`ħ@us +ѾwcظaŅc^Zw޻ja&FƁ(`�� endstream endobj 109 0 obj <</Filter[/FlateDecode]/Length 2210>>stream +HkPg`""vų;kggׅSq:VEQ9(E +hXHB@LP9&jםq-'f_ɛysDp +1hU` #.v2/+BIu\ߘonRt6<<>]gɂ + /d.QRWnkg?b% e{:y�~1=f3{c?s9j_;g3g��` p&%"b43=XS\Xi{,S5mٮ]13  KٞI[] +$Ow9|?;��݆}ihwenj]3Շ[7&>90V]} ,|r?I} 3W�[Rc`t˛Ψ׳=;s/��z c<r�QjqNV)k5uy O Qk92P(Gr14Oc 5Sw4&$��2b-#X$-'fNfUwݯ:e[_*aoG}&{XLl KƢ=f|GqqNo=��nw6}SupV)k5uYNyߗW Ye9 =3-?-aC +yᨸ|OUj+C��XW +1vvWeEShʩ4D._=b)5 ϱr�K +f/vƹwqlMD+{��`!8LԨ%9ySh.7<iZtKT) +BOgYjMTB�5Git_~+o�kC)}{h9Ik4\GG>:9shk/?3ASɯ/q۪E/[Q|��^W +>R+]n5Շ.YXy5-XFT(?#A߲DZU8Y%s%?&st6!vo= +��IN }g 1ʼRz5 +uיFΦ�oXA�V`Q?[I�Qsy!gKdg�hHZ,LL[&I*eUUNSúOLwӉʗk@؛eytuPf(m;jʛ w'|�K`;RL2{ۼuJ7q]xa͂ރZ%"^{o]�<RQ<-&኿ݸl��\h,L>8Tm9[O]1ѡq#|B 5,ߠ�X0W槌a?q6WW=�@^()SvI)BFMq57C0a =O}+R2 Α3W|-{ܰ9{$� Maa%DyAigH }TFY~Ux)Ձ,B^]gXA�հv`+ 1wn+s3W=�냽PHSƍy2ƕ$蔲Kb֪>hHL8<a>M + v<;Z |'-Wraهm0-<=��x}>@;Mvv/p꽕]5 Ty\D!D"wո|61,Ϡ�?OmDH\��^(ߍOae%'N(M*e]ĬUI<lHL8<>uD 3K ͚ |Q:'vݒI{XUʯ{4�nyyЦ]sjmU]5 Ty\ޏ*C +Eg !)Mrdu?�8JryC˱:>BSߎ^/߳�<B;;5V ǍRܿQyVuu۟ ~]2ZXC$ ?K@xXN1ԳzO�a! endstream endobj 110 0 obj <</Filter[/FlateDecode]/Length 2290>>stream +H{P]`@/PMFQhH J�u덈Pe4R0*rT+({vA+|eYLlڨQDcJWv%mD9<3 ws�(AG<JQE{` s@l=V=A7]]aimm䠢􀪣bѵxm(ǩ[�JsEс&+$ߙ4܆ }\6h?lNɶߍq{%iA{^>B-5yeg֥2n K"&~F@Q}>hڑCr˰s5/a@ ˍ1}OIhAB  +$I'kXʋ?lYu=CP@~@QINaڛIpy bO~I{L{~5gp琉pɾjSaߝ*-, kʔssO;4'((46g}$߳ޠ?9ܳeGɿ[Nd{iA2C`؛5ߤ-ޟ1ho9VB]%@GQ$UWsHie%=ӏn+m7 n:d@@ʒِ;Lcn +S Yv2^GQwގ]r?\|*},7^ښ0o<|,dǍbKc8꼵kKxdٚ.{G�w8@SH^ >bLIo9:65ƱHD{TBF?, <yNX#M-Vْk�JkEQ{O|h$=1<6N,4{Ogފ[ډY#`+"8$>.;5hXƥ\۲Q /ӜnFQgٜQݓO<zr +y:wY]wY4ja!SA(!4L#eReqAg\vҪ*_00v�kLH?{O㭔gy\>o߇ΙK{\prp)_ûvyBy�Zw}ƠfWt["IOv(O& Qz\QXWVzo] ?ޞ8 6;I?UZX1w[YLwa|],�aw,(ߒ<"-W GhNyB7eߋ: #C"t_?HXVTP*Rq=|m[Ǚ EY<kD9@J(?-yCzr l7?\6L&)g\9P؟̐8$^P͚oܝ']Cz.HWCm8-�ߟ(ϓGH. 1FGr]C\߷Ǚct=h sF  +A3gM#8,'ijF}ֆ=�`EQ}:6| $uĔD?{#6 >ھ02?m=7~xuhX|Ȍpzg֮X#sΚEyLQ�w#(׸3Msg"=AhFm{Ye-/ D{t�{[*<<(?5hX|sVղE8$DQEO;Hh^kAwn.T8cܺfGquvSބ5kE{fTs|gzV69*^K_q(ҷ9f9=9v+|LLoCWSV +Cx_ÇTNn"4֠i[Ze^1v)@J( ΨiM/m GnKMNXh+ # m9#Cf=y`^@c_0$1! Ǩ/XFc̉;7G +'>CQE}'ҁv ݍ c,\h?7|R]}߈MwUdx~d+̙: E:eT)8Ff_rN}w.:2Aj ��U2 endstream endobj 111 0 obj <</Filter[/FlateDecode]/Length 589>>stream +HKKTq ZtAЈT.{ Mml"$0sQef7'/9*dW(.H͑:.,<0<.'�=;vo'_WH: �o-Gk�o5B��74YJXQ\ dG}UՑwqFbZuG۩R9C9CΏ?HQg;c'{ld*ho9R9C9#9&;b)�ϾFg�x&� ky�7ib�;FRte2Y}{4ߘg�x֬ ^?T8�䲯ׯ5:?~M��H.qw6x31r[��$}{{x�l5BSst~Cy٪�@׈sʏxtw�@׈W:ksϊ~|��$}8ܼ0c_.45l]!;7Oܻ:5?.+rh0?rpd��kNiqs.3oLRc}g�VM�ZC endstream endobj 112 0 obj <</Filter[/FlateDecode]/Length 2484>>stream +HiPTW?E"*(8Q f 5S:ш X7-,:(;F_fǸ AČC*@pzVy�A^KQz[P#$5s K`Jḡsq. E܌֑sL39״[}d y2tzΈk jl0f&/ݻMj|*Fra푤uvV�(Adx7{gu|1aKzz<?cu^&nLjmvPJ/^/?UsNd9|WW"Z9ۋyzLu[I8#q&eF�Isn`%; A\+MQJH}?0l<9P$~z.6 \71K}uVܗ#l/2nhX6o>غ̨%|YdVFu6lqfPYGAA��3G;M)erRw~ni>EZN_c}C#64\3`)E 3sp_nLV$oS1Fr5/uլnZj�dпkADڰRF;M) ^O0�O/ֱ?$'TVWgƓeW1[ &ky tu`:n)Fmk\.Lh/͚L ˉ  Az ;:@%IInu[k[2ȹ{>GQl1=1cvё+*|rYdd ztz�Zw -/6~Aza[ ~"sa>i#PR}ٓuI'hnF_KT +ͥ6|[t\m!ls]EnZbZ!9\эǵ=ZIk4N.l >AzQ&=v _;i)*F~w+o>뼶M46s?<RN{{6qȻ>\as~HW<kV[^fc&CəDG(lt沓 Fnt?  @Q`I]vy`Zg$iÁ" tZx$H\sFx r5D ʦL7Ϸrl +3"U +ɍq|C:ί=ےw@=  IuFR(m?0lDD5u[!AaM`txHa˜HG=owc6V-}[ ӏ/8+LU1[Ϩb$۫#2;7rz!yOg> ФM4KJ׸Q q8@ܣT.;>ψ\׮aANjif# ݻvhvG~s t_Ǎ *9^&9-U)dw4Q+n&,sɿ?1}(D# PJqRL)m$vAh[gwn \�hTf\* +K0ٌ6},ͧYA7dI+|BޢqJF\viCUs~R6 g=2qAa ?ukF؇; FF0[ %ᅰӯ/ś�VW)$WΞCe j4pZoԍ *=R,L;_Kh)x޸ۧJJ(J5  ^,aHi?06!Xgb +7~�4R+-^+r0},o yN/q-NP+$沓Ouy,xḖ43�YNg2  g}KC8+]aL=?^\ڱMF Y﹄|ΰcv&1YG|}ǤG'W+~C_4?upt�/A6M;I =vAhkp&_Z]<o2-G>鿅/q8ݟSU'$-"l^njžsbBޢ B}>k$t6lq~R`"/�JsAA!}A+i gv0mcAFygU3}.g) + +am~Ѩ̸SMhҋ&jGsf\;nU;�$NAA7:]owċCà`9lBb0&OtmOC0@gǢ'Kۄ+(v?Ayd9f.m/FK>ўm  MHg葾g$? |@])N=A .֑@ W��p2 endstream endobj 113 0 obj <</Filter[/FlateDecode]/Length 896>>stream +HKQDETA`tYNq&6i^6eYƤ9:LMænn,lQ9fv~oB!y#y}{Bf7Nף,>Gǽ } 6���tﮓ-٠Y4y6B{lMG]4\q_�nO藾Yر?D|G | 9��07<7F|vWa2[jOv~(Ҿu��`n))@zvWa2[8XrY��> 2U?Ǻƒ.,оy��@H=N` M?(n>r7Ha��td + ml=)}sH��rҥH/&BǶ!.ܭ)~lX��@|0nZs^?76}eY pf��k8Ez^hw!!zlx_wH�_m>va2qlyK]?w%iB��?;v'zɳT?8%'wm ]ֽվ�� >"ڶN]Aıu#ϬEk&hC��[Ѻ3 B&c=7��_ dؼ?Ddmb��bCyﳼ%뵻cHo:MpEm��v_O{?:/r_G��0"F̐wqv`2}XI1ݎHM ��f׷Hϯr{ d,!+SCN`3KN�uߋBf? L=uZVK�y endstream endobj 114 0 obj <</Filter[/FlateDecode]/Length 1023>>stream +Hhu3/R/)N EBoB5fJ_CҢvmsLsls9ME&P{yr~_,� 'nZfMؐZ[SM:b,kmgS{'[C9��GMy7cRpȳ}Ի~��yԷ![zZ;7cR{[jnU?7�@ld>۴o !Ŵ$?Aawv��gSyۂAHt1ptKo��ё=oVjBc8|F ��y,K?ߡ}S?>&eU z(�� +(\}L"ka<iڳ��D揣e$[AHl18.c6o<��}8 ׾%SXզI[^O֞��`t%^eQ A $?nUcm^֞��`tgZ}?ׄdkBbCz4yߚ&jU��t&ʾ^Ue@ $? 2,Kڳ��<i]R=u;+��dO:]fVbA?ٞ 3��c:;xF@ $?_򒼇óiY��0vkʊSo!N&3`8{O{�aeOk +BFEC{J;B ;*Kv/1eߣ<n9.n|>o�0̓)d/76iVw~YV'|ZTz"j L?Hڸ +:j\��Lw76HsLk-),?F/c`s��S]7}9O6 " 0��窛 endstream endobj 115 0 obj <</Filter[/FlateDecode]/Length 1158>>stream +HOe3R*d3Ȭ'gJ.5lNĝ @y 7!`AZMпѹ,8pplGsQ3r7TY-ׯ].Zwڟ;S-vT{wd@[J�o`[5{Yn`}O5}o#$\*ߨ:tpCa̴YNċ��,6vݾqK L v#թ쌍Q1c٪5W~3�~ú`ҥ1 *O֗}\1ܺ/Z#a�� ݻ^'w?NvF `j͓f<vju7pD5b.9noTb��ɋH{X.`IIJVl۾$y6{;kg5uwQJFKz ˟��8/ <w�I;?I~Q~*ueL;OOfEVfqkCL�n wEzwB4 8^_[a31?[QSYf>?�p*ݳo6n~?~s=.q;nny-s쏹zK �S}{WM &&h\N&hϱ?IsEv(H|�it"KM N +c~zgK��8OguJwIaĦ,3ßɟ��8pM]o2qRYQUuY+{j��FHPY78)5^ +G=$~^�`wc8{5;t⤰?b:g]?vA�&^*c'0j}]+O?�G߾|X^'v N +caeXjH�F^ѽ*v N +cr>͚%7��vShNҝn⤰?.1euZC]5J��#.k(qfN qRf}Mq��xݟ(~BAǽIݬ;}?7\>a�r  endstream endobj 116 0 obj <</Filter[/FlateDecode]/Length 913>>stream +HKTqcBw2Bʖ""d.Ҍ&SȰbB5x23^HK%EYT [h.w"9?|ggݖU�75mu=3s7Xse-4}]"Xg[n-/o9~=� hY7Oz3f~v q4*omJֿ��D*g!v )̑}P�~u&-L.99[݈AL +crfMwU�HSϲ'ZқFbRc=o<��fw +IKv+1){x[}=w�H!Tj7cǖ9co=��byZWĤ?S\Y_�eI/*nhw۱?IagŬii|��Mgm^LvG5_ +6|lHӿ��h>*?&`W̨{L<}�21psԻbR+t?2?��SMOzrdS?Iaot_y;��66p:Ozpeaz'AL +d��ʓ˒+j&apƲS@J.��`|/]l1)l +4~8��8U%)F<K;4bRYpb0XfVv'��'ޓ`Ӱ?Ia8RQڽ��S>DI]\ݽ&bp֬܍Vm[}_sd~��nos^?Ia8/[0_gX��ncRnhw? � endstream endobj 117 0 obj <</Filter[/FlateDecode]/Length 993>>stream +HOlu_e8MbD&j,f(si8%.MDbtMH`,aN6{e e+;i"$d y?o?Фηm|DCݵ~uur>{f\*Ro&OMƌ4�`mhjԓi7V̦qGÞH<翳-/k�+ҷF*[k3fӸ?gd7H'r��aM4#]ۗ}Xq0Q<':;�/tE ]wk;fӸ?kwj zU��<v#`X.`6j4?+7i�%ܦVp0Q|]c]��~-|dL';GTWp0Q|54iS �~]9:ǚ4_spMH#��ܫ+ IZnK?MQվxS^שo-�^e'}i%̦qyЮ5oMo ��։j_|XPp0gU Os�HNL;!nk?Mеuo{<�ݬd7I[ti3#{fRj~_��)H'rXv3]l[L':;� ]QJ`64| _ ��IO)VÆz7Ǿ<q߻xuZ5��ܖN$n˸?XoC3&𓹙e9- +i�!R[YF2#=/}p-&>y2~7�ptL&~A$}n?X)Sǟ0@J~|�/HGn#?X鮪ҜLg?ٶZ>s -)G0� endstream endobj 118 0 obj <</Filter[/FlateDecode]/Length 1154>>stream +H]Lub*#[lwfi=]0E-̈% SGhGD#EB.z@W䡛-U+#m;?94g) �7BK{:w'?_ggrX(q;.6ݾ^6wϱ|s)_W:XZA�Pie,=DLap-= +yfJw*3뭐t`�<Kw qK]l7t:u,q䔻Ow��O'!qk7חxzg+&T\+צ˦,MR'޳AOn=ͻoP\m>{"Eޛ ce�wߪ])8d\1lLn÷68@Gggnu_ዪ3!֍�p.L{A#@J\4C<^M[{mGˁS#˒f[Gt[WS@ޟɁTm�8_27Յۇ;?8\ר͝5Wu-3p�pMJY!oUnfrq͙5jK2­Q��zpot73cpN:=x[f`l�8w*%})iۗu;cHΦs[�pcAtFwpwI^qź{�+-ԗ%nftXXj:ow �`_鉧P@qsұ?%-6]��<WpWt 9Si6y�tHwcOJI1N n�~ґG=4D9Te _ܟc��nHk~Rw9cӢ—TkqL{u�BqӰ#[ȱ?8'þ2 彛wn� ]ϖndTn sұ?쭲S`[w �)% z.;c[oB6�@;,ݮ��KL endstream endobj 119 0 obj <</Filter[/FlateDecode]/Length 955>>stream +HoTuL +)s#AB E"DbL +BATqQ^"0tΔ; BPDhhŀ bFL{vn|=Oy֨G|`7!{;Yk Yi򆣹[��7['=r|4ByRϿIܱ 缿M=�xvd~8Z8,A,aü]&m\��ώX zBP>_xAb}�wcs 1/\PlZ罛}7N-=�B ʰ??liN,9Vl|]��z7N>XshTnBRLlb.3r~~�ƟKA}^&TA,aXώ^sL�￫]vQ$A,aӖ3Zs�x+dgv!<b)&o\>oJ>y;R�ѓ{/w?U>~W]'>XX�{|}vnAX +ö~??~ߋ�ȝ{M{v |b)^ۺg￠ݍ�Kv |b)ZO|~�_of7;`KaR[;QH]鍊{�r˽DA,QvPƆvJ�@xƆbrw^kGhO?޺4WK�@$KK;bKaTT˹U �(˹ԝwAReѷm5EO�PG[? cKaTME?{֞�<?:jXjN`KaT>oJ>y;2^|"�v2 endstream endobj 120 0 obj <</Filter[/FlateDecode]/Length 1095>>stream +HOuOV5-c4WAV S91 h!J":%=Lq*mqӥm?�[py9]y:o|m 7WWw1�D3ƌF{gB;MVHea~]JC==˻B<R-X[ +�XZo RAGz+R⷏Կ�I_Ǭ7훵oRAGG?LJ*� 9ikmob'{*ܙMڷ�ܷ {oѾH=qRx:TF+�蘭#7:Ia`+Ex?=yЄD�^̀qR6;}ԵZ�DOk +a'+Zv5X*{ �0FXzy_k.qR"]lNZs3Ҿ��cO~tZzYYF@8)\kSf.�>~}=ڷIaZٕkMk-f/آ IJ'UzY6@8)ժg͠S t${ +_7 N +SٴBcw�PQ-}?dW5h7 e=t }+~WzX>)|h <Á%$.6'"c �N&=;>һҿ7� vM빛o38VQBYFM Oc} [ʗ&q}vycڷ�l%ҷiw?A;pGo;*vL �N$*=;vÞĎiyuGH8x欬?tɒE}Br L?>zO׿�$ҫ#}go; vLmβ'2}_'/C!Ԟe7[&o5�8H>nEvþĎeokks\vwXG<{?C^{WeJ<oC�| endstream endobj 121 0 obj <</Filter[/FlateDecode]/Length 1243>>stream +H]L[ewGԨs,ۼQ#Θe6d7l غ+^0!C , -hjt0nv !)_&d]ʟd ?$ ryc>WA-珤]/ +*1&Ӫ,gPq, B@뗸1g:ܿ-зETw!2�`GO[}v_5A߰?s` Vavs[뚤ĊH&<դ 5p�0߇\U\wW:O&>&s7FټL奝aZ]{\2YRr}3ܿ7П_M}�BvܝC_~'4Doi?_NcSOn^}祗>?,[o` :o{CPuM ��Fr{<)w1{伕F;bDm|OϦaZp*CTDz#>�0[ԟԣ]Ɓ5毋LSUXLKEgux{LJ4΃ +t��#x:K`{X?&6:Z4.qc Geosmܱ:�,kӔ`<L\tP|а�q>I}I`<LJTܳsw<�ݿYQM=I}`LLH9ӂgJ=�'z_K~S ) vt�PԋvI@d +DʎOķs↯m+�D=cǝb/n/}ذ?YWT<s 3w?��[eUԇq ƇR{A:S�/DA>ALH?,.:ۂk ��4\,Eog+!w'?Zf9>9ޕ>��Bz;Ʃᚢų57*?N��߬;T󱙻A.L�-;q��-QQߝM^"S?@Kqdqy9FN��ha&ĀDݽ D`֞/9,}α {.{�@$Qswܝ r@d +|`�/q endstream endobj 122 0 obj <</Filter[/FlateDecode]/Length 983>>stream +H[leƶ1("D L0s# x+^yHdt_:;J00+7jzi_M]-Ӑ}?ɛu!+27T9fu/ ktS5eC? iɨufڏ��Wjt݇&y?Fby���G_d?zx���r…o5&7^���Lxs"&/���ރ$vp8}���&$ֈiLPLʎ^}���&}vSG=kuE���uۢNs0E?ZCm"7��@dvMjX".gIʎ`uo}���DNogٝFpq3h &"֗o��Hvvǭj0E~xb>gʎ\}���DRvtI$X>yK���4.s=K$?V_?O}nu,}��\V1Iiᮎzw��X~t||Gӻ5Ysee&Hܲ���fy'֖Cb?udZd.8SvgLRcRGu��08JKv͓ɾ|Ojg6s؊EDzkǺ60Ma8^u��0Uƚe7U. 2cYˋSM"}/L/S?i4*}��LRpKKPOov3]S̹ګN{zre Gij9eG/G}}��NӶ">RIFҙgi(|Ӝcj0Ma##׺o��T endstream endobj 123 0 obj <</Filter[/FlateDecode]/Length 992>>stream +HkTw`bBBҍF"ZQTD(kb-x;ZA 3ds2I꥘hh-T)(^ +p !Hz!w|yW0> \9j,1�lo[\iw-I==˻`/=>{�ޅǿϛ .\ca7)ճL4}Iemҿ�mHIz-*ݱFSiO7_u� t_LzM[a?)ݕc='}yP�7 AzlOc; 6 gN}U}G�ޒkw)Al +U4t-T'�QW(p[cv"8Ħ?hmw${ +�^ūq:]_`aɛcnL{j\�H?iK}4W[݉a{yN*{7U� F\<D0?MamY"K �Yߪ2駕 ;>J~E-޹:@��qߙZ T_ݑ6)UDܺPw�6n'u{{"&ݑ6)Giȿ7`r:\.^RFAl +~3c1'�"##=$}݉`-)w9tf- X.mQGzH Ħ?W<W擮D{@0<BKlh7GĦ?WgHq礲~�h5W9SĦ?gVDgT2pr}N]H;^R^ 6C96MJ)�"i_; Hu礲+ӿW�A$+I,v׽ �uh endstream endobj 124 0 obj <</Filter[/FlateDecode]/Length 1242>>stream +H]Lu_UnT Q 0Ad <67oh60ykUoW"?_n~Ox*yԘ!9r\[rerV'hP)�X;+V8`9b?L +;'y}4< u++IL< )Uw5{]@pZ:-=Rۘ)ۀ'a;`lNZe۹Ctc�YN4j~)}Ӏ`;`es4f&Cg�+CFOzDw+ v +*0Y=cfσ5�FTA)ũj2o�O]b;`X 6{n Lv�,  V_,`5NaRj +"1;5V7 }HVA"b9.&JkmQZ?Wh"�z}';U UGw7k v +vJ^w~ћ�=)qĸ&b;MTUW[ʽ1GkA�֗{UWZʤtw yc׫·!kb瞧lɰa^8O5 ttZoYN1{/_z@w 9VN{:]EάB.զYgug}jt[w1~/rߛ<b*+S"#yzoݥcζ>Ƭ7t66`Sr=3r߷俯{�_c@L{M!}{mi5{u�1cVwݝbN?\SeXe*8̓aK}FLj󸇽=~N{ o&5j3-]ruw //-mֿ?vܱ7lQɪuC6O_i7Xr].oGoYtGՑojSe޷F[xHu vߴdyՑ+Xk;l xDhcW_scPR{0�g endstream endobj 125 0 obj <</Filter[/FlateDecode]/Length 3155>>stream +HkTT/Z *mh1WRA+D0 f 3c!0"00 0y?.*(XhhZFӮծott@k=saH@EpBEW G dcCt zfNAG[/Xأ>]2UپD=ncpNr[oq-\nK$>zCW을BeBd|^At] 还=i?0-2I>?zyV[/Xȶđ,GZ yG~x~_ }&+ 4Y>>CYm6<T{1>_!22OЩL^u݁ 3G oWOJa5~ +cF꼓0U_zg!2%d"}g p[>k/iۯY΢2O7|@EPF&8}9[D_OLsE^$w W +G-L穪6Nhݽ2Ju^Pg!gUmN 6Ώ^WO0W?cim.I6u<SE:샵d]11 EĦfάuZ:ڻJqZ'4ѽP#m /|ؓ(,ygE'-ؾ''#yԏnWz߅ S;Qk!@:?0\)?2ZEܙPp(qVrv tfUnHn:[ wƵVnp틴u 196u9[,Z(+8! 錹i<Lb{Id)*F&E-u|ic<8p=l@8 A*OAKa-?+TRrTa^,|AdMkΟ8o ock 4mBOb\eF +Xk|!y#yԓwJq01pU>ˁ.lv S:7uԏ:Z8  pp੪6C_ =82^dMa9T68{'I"ȚeQKW`‰UwNyie}W2?F?[O_|`]m>*d&JH>RN>26Wy5lc2U_ւ@Cq`R8@]flʁ^=wu �yPbaֶ1P/4ѝάdgB^2+EPc]Q5w\/= lP[ԩW˜"/W0)>bk-ȏ fI^̇%{x ?E1x[Ov_ ΏcAou ?�q&`R8�Vj(f{\^1j3J(|Q'է0ETsgB ֜ @?ob0W?Ufo5ֆN=y|s߰XgW'u +3^K<㙲'kvFWpe=}!8 :#k"@wlkA ?Kxc1dUnzR +RuZ/HbWp<_{kk,-efGF<X֋#(U�[_5Q |VnTf_CWϿ͠/NɵlkA?^R~İϤTQB)5gG'է0ETsgB>啤oNmi^<?_?"{|И/Z�/|gs3f#yVb͡x$H|o^|doCqqf`R8Xɇ"y:+X�BJݙtfu$+>JI^$XWf݅$0~?YVx.aY *:; Uai=GX̠�Di3}rTa쓶w/ﯚ7-qo2Y\1|z/68;?0\)?ZD?j(f{\^a0 I%g\8ؚefyWէr}m>,RʶYYZJPk1BktN֟~lW!/LKzwݮd8ltD.}Vd2ÕQPSɲzi;*8^c+T)rTa:mFkG9+kΟ8o orlk‰Uh;%Yn)?khFێ3m_CyK {&ls^A,{QhsrQG!ms3~_*=g c |s܃~A& ;1�݀~@GlkA& ?0\)?BJݡ72+1g|7T?Vfר6B-"m]8~2q"&P 1"HJM4m]A +/uM"$e >CSE"ro[ϓw^S#:NM}2N%̳> ڠE f:64>] 2#ӦR.1wKǜۧ-X:}.:SlӘOg0g*I': `ssoy; CZRH(�ca&?=; =+ 6{֒\&N NgB֘63Pu*knJ5鱞l0ѿ>)綷>7>ۋ?*}RI#&!HH]@'1tCZRh( H1R6*&ݠۄd| #C)c"z!Y)D`S@߮$i4p"!i.4z�]HmSդ5 � 5i endstream endobj 126 0 obj <</Filter[/FlateDecode]/Length 3463>>stream +H{PTǯG5:M&ƈ֨XŨ<!VɊݳ 8k8_zk7KP+|f=s}GND;8}QWF{QϨkg w&m]ag$ێ]+ :"~:љ$ +=A<]~~Pv5#Byx ʭb_5y}& BP)?'fUWg͹{Bhop u9} B/P)?}5Ql$n4{_m 7Y*GzBOAAlc\]8*:^˽O$ł +f1;3GzBO?nعe̓-&I{nmoEexR"J2qrǞb9ۛѩ8$nk3 F}y5+z`5ͱ4˾(:/ǓQ1T-n K +Ϋ +6̀iA,y;`q% L8u?n3FzBO+zعxw2ܮk-i&YKRuglo}$A<.[/o[bJLDGBOpS&u7)4^+*Dν0ho�{xF&/L_d:? u[Uy%(P)?c'~zvZwu 3]%v^m^XscL~R8h5x* e̓qD.b芜ߪ缞uN7ފr5Q);܊Sᯝ{}S'Zo/gbVt¿1_q]2v/׸j9 =#J2a_[c'=мn^uyى[~+zd5U^c-̾jvA|ͻ%u^k.̽$8:EnQAt$?(W<,m~u΀^ݡ"`w4i<ּ<<U{l=(c>,r3wRϝ z~zk5):Lsy˵ uQ˶d`[G(c>ik붤}XfxYvц5i.Sz-뫪P +JNco)=amâRSϼv&fd<ܦܴ#J2bZճ0w} c۪wl/V,c>&G*߈g »xzsؗx#Bszx )Vu}f#BA6"gMeU?}apJpD .np%QGXE/vj5|m}Ns<OmG:okʵ! 3S>*W5-k]*yųVΡZo^Z?{{*e3x/Pӆų wL8PW g "chx]𤰖&GLZP38aFKQk^!{r觕!fKeJ.ɾkaumޮğ<(1$qC4WѢ;\+mU] <uA-{Pkk?&=-CFŠ^>6f6sxoM(:/ͻ$:.wq}PG%A +=EGmG:^nd#J2i=l,(з_#W1OAo۽y1Zeu΄^=qֺGu+<SX_?I;vܖeBy +3kpOQևc<br65]ukh.*Wn=(;!kE@u[}/)"΅{QPHPw":b|g  +}EGfV8_=}cT}/^W#gTQ!ެ}pM,Kr{ؙQW$O^@ ܢFyIo?byoϋk xa,p<"SaGR54?|U-qo]Wf-ZzG pQȻ/%wPw?!@}?(Xm1sÓZzd{,xk=;4)A==?@~G WкO 2kĽ^O]㞖s{+w]LѱCMةo?Pu +ܖ ޵lXީg=ɧ@]Pg]A< "#[*KD˽keM{??7zflf{q)ƍN $#tkCf`m0Vw.Oe7M{{+}0R 7ޱ_bԹAֈ}w#=& +ٗ~}oq+j~ٽ4q| JoD *h,ABY\&iE6sZgwlFeS4}Tm~8y~sco}# 3Mn3?1i/-dV +t[f cY >6<dsΈ'X�zKJCF[Ή[Ez�{Cys?QOrNWwK<bx禠um{xOqIU4 [݈LַStKͼX)%rO%ʤ} =uMB_rk AOceZ :_%W=_﹘7qĪ_yu77!Qo6_›wH +BNk8Ȟzʌyg`k.e5*[?~"qwlE<]vk"'3Dtk\4?"coC?ҍ[Hg39yFUF)h(rr)3wzp=: %r~#InMk(PSec�:>w?ٯiڂ<Pj8,OP SU ]X-Yr d fD5wP~oKd/Ǘ'5g +9 :[A?5h+ ;>ڱO{ +0�p endstream endobj 127 0 obj <</Filter[/FlateDecode]/Length 1956>>stream +H}PT_C6IfbjkĔcDIm&&+$+2@XݻK#(Hi2DIQw#h'' 6d|Ⱦ˽f/w>ٻω\HDQGsAGFGU:+Xn,EҦp͢<^?Omu s#{v !#`g c1ײ[涤X|Y׹5;[eDHXyҠt^O[nmgsy\`>L=AIf?X{Օ׫މ]!W{ו^zn߯稘!{F !#2̜?1"Sإ9c#('&c|cg|oҜj{ {& !2?1&RĖ}М}\'G&7B_˝,}_ BnAsRnI[S/_;i?/g~ձ)=se$1bzuئl~EWƛ^C߾8?9 +Vxm#A/[|#;5tm~|;.ǻ}~ʞ)BAIYi+EZ ֪Kb?k'c=CAIۓ/fͪht4]Т9ewZd9"|'%{f!2?!`uYzIJ \Eͻr} ϟ鿼}Wa;$d!DA>?M]*6U잫4(x?莾شVnD/֕>}GY Ttǔf*Nkqȼ~~ќhuyޥ:dn=)""3?!!F,MSktkeުy$oϠ#3Z0P <Z +_w ?+5'j>KA +w[EꑼF 3|x;*qĮ x�}B7}D?WWDŽЅ +&ED[%"Ppɥ;pπ6^3-|3?ۧˮӟ˲g[S/rF_v6sŲa�p iq}:WmMi<9 Q·I2?|\=V֯}.yȯ+ϕ]1wĉg 3J-McOܺMV;9 W]p~hҔR ~GIp`8>3P2(,k5KtM/=Zs?όl6>,Mܦsxt#Ϯ]Wt{cp#9pRk~#Ή8?~/F=0P@cZLA͋wNa{f|BbįCYZIQiݚiիz_ȇ{oy"73q1F8@pNwa8|&gj?@c튄0\[pYsv?zZy_M恿g'=-)V<m=wVjQNwﰶ:[v/X|ғ{8+6_<QA]TEݨc98E =&c35-�{wx1s蹃ޛR=ZGbqUe@IwmN}F2$Zu{_ђwӞ0Ty/Κzel<L1.]i)g†BTdEs6k<1^zhG}_]/>R 7B U-�y endstream endobj 128 0 obj <</Filter[/FlateDecode]/Length 2448>>stream +HSS_N\r+a( +PEe.jH/e)A $(" hl:VblC 8Lb3 }f{},<(GYfd滛L۰᝿PH[׍H<ȸ~740EH>4נoCg>m%VZO Ir(X9Ye"  \+/_xݗ/~^bt 0__W_Uc%.*AAA7<AMMޮZw[֬\Q6         §("IEVZpl|yW겐9'˕K{&O,L77&RDef3lO tv).?Fc?V7˳Vp'qQ+զzŘIy&;m\سPQJ} &ᛰY g>im&NIޙ#ނq} ZYOwό_@܏KsnԠ0u)N6XF WϕAr[ILkWOQ뙚TD з@ݗnm%L/*ͣN:,tw mjYx5фI_ 曥fgCGQWՋh9}*p^bSPc[H_ ّcB[N㑻zWֆ EEA kY}us9w6v&m&[ZܷR6ԧrq[sG6ƨgnjc4wߐqQ+{'L2ZOf$8Vdǁ#B:Y^/}',w; q??hcMFqT'C*e;m1jy_+dmcsH۰}njpGû+ғkxEƧ/$9bdB&1]tGq;aLfmMsEY<1 cKQ6ԧOW%2_Xm{B>eDv䘐O ;س=Яl=/gHMZerX7unHlsbbf?/csB +w &5*E"rE]0勳9ˤ"< +w'5 u@_~ngPcϡd{�;܌Lzr8a-|VZy"J2pioimLiiIÄ25&5bn^4N.uE]0"s6a%p N8b"Edl`oW-{k""Ɏd__+Դ4, +ZȾC=L/cu)=7;W6oryb/ƈ71QiL|(* (Wԅ3[8{L*3G�zuԠX2G=z٭fxF=E]c?r32A-Dfy=rN|/{L Ϩ1M7ڏѨud^ښ抲yb&O|]lO38Jd 䶺􊎈|jTPУ^{�`4T#/%l, 'zF1u^.:7R|#ˤ" |}QcīhUGݷЯ۷V" =,4E!L`zp#ΎJTG,=ggI릝{'ټ).Ͷ_&&[N + ՍH<"dWѴ4L/5F [c~47ݗ]YtԝOdνsgfv~E~BFv]jwg/aAA9LJ gs{@mOwaJ3jNݶį\5*J@0^GGܜ� րxv5זCoB,ς= IEp_qKCHUa<zC4-90XY?kF-:$8/,g2t[ãmi=SZ[g#ܰ/Г:;.?;Z i_<31wߐ x͗A>%*гNdv' ŵIpy^>ut sثSPcě3wx+{^yFrB>Qv"by(œkf38 Â\X927I_{rpo}9o_1GgmMs{~n>5AL{jzf@ +ۢCj`̾~Ң—9EAAA}��&R endstream endobj 129 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 130 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 131 0 obj <</Filter[/FlateDecode]/Length 312>>stream +HAj0DA +@18U-���������������������������������0xYi\1 φ+dpg1`տe->XemoXdÛ?4e#Dzɑ}dodkŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮbhUf)V>Xa LRl}0Ki,Ŧ3TZ13MŮ3TZ13MŮ3`�b endstream endobj 132 0 obj <</Filter[/FlateDecode]/Length 569>>stream +HN@FQh*Qΰp;|%x:2X=j1oGC߇7=1#}lc߇=#m񡈉uELs=>cc[7$vylοq=W?qҜm~O''NqsLbk1c[7M66L}d>}d>םGfSZ>#!uYhml~zU}hRk٤־܇3:225rtDdj#"Sx񘥙1K3Wcf,mACCgGΎ  :;4ELڙ;3uw,jgXΆ:<63vx$lfHᑰ#a38qp+sV.ílӣ#GGO ـ 7&oAnLܘ=eyc受μ'w[Utb,mEq՗&7ó݇9Н΋A0zWȽzf\O +Éҥ"�tX endstream endobj 133 0 obj <</Filter[/FlateDecode]/Length 1667>>stream +HwPwd8T\X8ւZ +NKTΉp‰!# +,[Yg曖;Ojy=Cy�gG1֓k"F!w6Ob J׸sF/7ɳӕvsVvd{ ѓW콮~5G5޻���4N)˛ )Pͩ+qi[7~o<:ueDFĨ.h>ֱ����Kg +ci{&7<;7J|[7^d=�1?jlUppK���.;P{6o֐ZT7jť8'M/CnֈBi; +<���.N.4ouʖMm޸sxSbbZ0c5O+B%rC(ldi)y~����Z0mz譞!4E=OzҜ2}7śi}BI|vjwĤWI +J���T۵-om1SYOoo;V[=?xy2LcĪ& sfҕ���?5;̲SJ6):ȘgPdPSBlΰc@u!!Nw���2ϠIS` YLVu"EAM<:Iȿk}׎&Īr\A})S!_{G���&4bΜ@sog7InS+w5O"suKCXl٩yU��gcas[isB%v)/?6IMyQ;TLf*^ &uD7P\#���|xl4t +bso\f71AyI%9,%J_ƠS_(Ơ?@xIklkwk��{ƆF B,h?Q.1hW-K?t?luq-$M+]�1?H|,Ϣ.t'���_ڒЯhEVJv7؟zyt|Qx0GﯗBAn+d\v +'���ΎF6/]`"7 qrʙ?7+Ao<.2γ bVWq egn���n5'OmyhCiXnɿV7Eo4ԔL<"C˕ + {��@jټ9y;b%w4ٍP(*sGǶ0h[]l hn.�?&I9{*���4 -hiNJ^%&zɪqzFo1#c]}=|KNw��׺e+ůZ7W~ٜ͓W}3u^ z<1xkWn1M}aF9s$E$]��9;8Ҍ$_9(/#Y[GL#o$XGٚn1M}&6{OL~]��vZS7)6rD`uo\)?7Ms*ǟyuJڻ0`�Gt`9 endstream endobj 134 0 obj <</Filter[/FlateDecode]/Length 911>>stream +H n#1 ҳ@~HSs,wS?>ؕKwԢ!ڊPpZG^?^R`ڻQ'EQbQ'F{+wuer_d>ˤ^H;L}9?^Z;HOQgχNҾm|H3wNҞL} 3KGiƃ\Ƨr5SmY0c`VaeH}BUWYS_fMj/ +Jc"i¼TRafqʙ08 scTȽOsSCw><-Rf-av61ͩ+S*P�Kա.h# +F0[H +0feF8uA0LiYPs̔*`F2T<[y"oș:g*z y" a"qsu0XAc9PkUԕK]+5@f4UpF@Q/a1Faf^QMگԭÌ~{qxŷ) h7z0lhm7z +0p5v7@= +e8Vmz0t^[ <`FH@,qlKUǩ+R`RoV3ƧZ@Fi-z>3 +U'ϴ5T4<^y jJϷn0&۞ὴ=dg#xBZ.~X n*~;GhENkĤ {!d9\W~=U3ޭ O tVU܊y&% :o+.|lqmc&`e hs8a,e{YTܘ5sߴ7jkGQ>X;z0Qs֎;l)?�0 endstream endobj 135 0 obj <</Filter[/FlateDecode]/Length 583>>stream +HAjQ&_و 4C:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:Kѵb~*9Vt<n�'G�l#�sW�[;*J |zӥL efnw҃ELzpJ6#Sɱæ`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:ͷ�� endstream endobj 136 0 obj <</Filter[/FlateDecode]/Length 607>>stream +HjAQO+2c,BǥzL +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйs)=XT]. +˥`QA?u+.h>} ہ?k3xv瑽W_n}</rSE["!z!=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуETvȰ៹#+U[.`cEMTr7_ �9] endstream endobj 137 0 obj <</Filter[/FlateDecode]/Length 624>>stream +Hj[AQO; A0mkQuͥY]ˎ G(;x}¾+O#6+?!:+ǩZa˿s\4 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй8NE׊ [Tr_�Z#{_:O%NJRtؠtxJ-t\|>~J~^9.8}N#;W~ +Xaӿs\4 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zlq`�!ÖW endstream endobj 138 0 obj <</Filter[/FlateDecode]/Length 695>>stream +Hn@ Eyz5IhRkJM]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩{:)7*5-pbRGݟc?J +>e3~ C�!W! ?9r+ŨeX_I/F-?q?!�;3~yJŎ}Mp?$I^x +#&lK^*x \#K>?5W84*㷚0M?_xUj| &0Wqn~Lߏ?bJWz((Lr?{2)s{Cj~o.ei}>x7ُ\O}WfT5R; "xKG8GGϬ +i<<~_=za9kJB[:7ŹmQQ_*x)2۪=>fI$I$I$I$I$I$I$I$IK�'C endstream endobj 139 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HAo0�|I8i7J9 :,HС4 IN>)γ,��������������;^ϋHVhŮdiu7ۢ&P?Ð^M݄l6-o_7mO= w_E܇jSo6owUKL|=8L,{q1n7!$WuY_E>Aws!G, O188ٗkӿQB6؅}Rݝi=˻&Gi�����������������������������������������������O�V[ endstream endobj 140 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 141 0 obj <</Filter[/FlateDecode]/Length 260>>stream +H+KCq�?ȾV-CyE7\b61 gXK  &_y~ ������������������������������������������������șо8~u*f��bxW'Z:vz?qvX/g��G)C4լ[��|][^d +��y4Qy_̇dE~ݏbe�¯��h1[ endstream endobj 142 0 obj <</Filter[/FlateDecode]/Length 601>>stream +HMKQp'4Hm:A`A%IhEb(DH*,k"Ѣ6h(L 972G^x~}N�$o|XWѽKǺ~��@:.KSW[}pkj��O/f=P[qb{||dM +g{O:[ +,aO Z ·5M;W# \o;aoX]i(ґkΏvX\gk[<[$ᔞ>\wEDzÞA,Z43߽ӵ|z|{4k- 39%ms&l,Aqӳ}X=u`y6^N\8ݿiD_}{xxۿ1=K8CC o^}],z`1=K8<,}:΃ӧ<+3=~68پFJ3�@k<�;FJ3�@k<�;FJ3�@k<�;FJ3�@k<�;FJ3�@k<�;FJs0�H̴ endstream endobj 143 0 obj <</Filter[/FlateDecode]/Length 420>>stream +H׿KUqዶIKh*(.5K q XiѵB7;M庈s?<pΫT�D_{G .S�� W_>J�`w-��\?$J=�+sow/S�H{^)w''�p +oRo� \y6?גz��g�b;ژF�ؾmoU��(6A$��bD?��M��(6A$csyi`az),��"<hhH �̫ɩFAٷc �{ng�pNm<>`W=/�?�� endstream endobj 144 0 obj <</Filter[/FlateDecode]/Length 19272>>stream +HWn8~G7II:Fl ,tF-ut<n&$aK.W>N {^VC۝!~w�rMw}6ge~7e}T]y>M5xEYg˛,v`dj�`AB-iǦM~>9O0#)SJ,(  �X0N"\֮ƭn]Oۺ3?}R6Q{]jq&R�ЋR%ȟӛV VR 鲨j iܪ'$5>'2|;n4$8ҐåuEn|yʵ ¤= }WP5wnw&t x{,Diq'<�e&\r12~"9F?T6,kQ8ZwMenݔ.imkr/jeseܨnh`zҦK3pMR F`!d>Y0 ODXcc~�9wvV`CUΗ]S +]XȭplD 1?:dat.^\\ռ)vkJћ@kwq}B>{Uk_2ԃӣ6JWZ\A4Fn' jCjUu%ZFq*_k+!DLTOS_9L5T=:l Nֹ2:q–j*A +Aw+Ӈnk=Lv$)jRg76h+ѪqlRE^8G}{o"`lf<'ݠ%{;<ۮ\kPU5ڼoUk8�?7AcUZ&5lyZo[=rcڙZibf?rԚiJp }F[iWG#CedJڔۺSصSS&ʪк촥i[>S Cx(h>{]gsK͹|;Х]t[uT +&=IBlժ3nK٨nj`|V +伛ܞMS8<¥=f՚™|6_sz.8Cp6̸N{#="ȕ4 U4ہ&?�(ܛ fAF`T]V5@v]ז + +4B˭(#"8̦H@ )Pk$w2?t0Ű][/{ /!WP03N;^%Xovܝ7{7L.'!X zWD l緥3QQAnvW۪j@X +F╂uiߡ;3}a+; np.nm}+s{mIY=R ǰqe%蹥=KKp�-�G֞*FT^2xWc?(WH^ bۯi3ـFv3߲is/,zRH̀_9| fc�L38=Xo?)J=Z&y}0+<\XK z`>}IL'ٗ'S0 頜x~0'0|b 8)p ! ID(mCW$$%I�>0{dIYECaF! YC00 0G$ +0"(((4QN4 MiFsZ0 X"Fc &YGrƹ< Oys^,D("A\!E,L䢐XPFJ&RX&2e8&qqӘ<88HpB ( Kx"III┤AQJSr/L4I4KpF (x&2 41?1K`7�8.I�_L" eQ[ +1& ~(d"E!K +$ YH$ZF`^@sHx +O pAUP�Dٯq+ eKCEQ\,[Ara0HwL:O"%K䶻MXvےLSzUE=b]= vco]] bQuF�)P +ģLʥBє(Tv5|jjU â #k(ڠl=ס(QҠL9/(oQ2�*‚)`A=51IM +l%RSrT\"k8%HNɒTXf]TpށE KE]v1ʸ8s(}y,`3@:W k:EsP6 3]AJz*iJfJ2D*ITNI2MT)iRRV %9ԢDI&J(Ϥ>I{<*;P9IqdZ&LM"Y]&md]IBMr$IIzCѺhX0t<j}`~)L/^[3XrL$vBoC+N3"\n&n&n&w2q6N(Wk#wjfnm4J(QD5KPK&Jy'"R[RZJ*@dEKe+yB,]vz~IŽ"26 J$f5M%m5IFMopqV@Ss)v*w*xU==>ď%`G-IFiCWp ɣÜp CF?ˈ3aK +5y +r~7 V]^6WXv9WbG7ZGrӿ`r28kLo +ȭ_8m\&,!.W law�kP>8) +ὼCRG>.=^Woo^nN'^yҜm?_.׷[6Kf]0<?oD|y:?/O?/gY#6GsU͢bCrvJ;Wώ6)?mc͆3iygmLڱu{拔0Z6.猁sܒ6bp>G@{@:ڎAcH]2Xy & MMxiuz`T1+% Rhj=2hh4 ٳL5&΂MJ;Zf1?C$…\ڊѥ1݆DKČ!cɍdoԔ VY u1aFg0Mf,:bX`(W@QH33kW2lɿ>sϐw9WstH4+I1Ta]1**"&"P3Ƒ/,qH$rTJes\=N\*N +7beԢd5J.Bn*.TC&Tzu 0ѫ7L:}RZ=47""CHzE:~ElMj)dP?G=cU{$Vi^T')x]%-jN r9Oq2:V9PRzTJO)$hY,3YCFg/cX`6CY<SB w=d񡞸=xw.1 h4~EpD%R>š0ؽHC|Zs|vZQ#]w7ƍkqǟ">=K'ӧө߽ק۷C?oߞ kLky?pS +_p/;vyh|xؕK7ݲz~ç|` '#eZ嘄$!,"1-ќ$)M(E)8P$rPJAfN@?OɡusrƱ75M54hidq0 KdrY4X%0t$# G˘bd(!3CÄZ~C;NFkZD`FWGKMÔFqGzE.*hB]ZMEjBBX] NEVlĆe 0c8$ +nz)yYeu[l7绌Hz'YRڛl<wUc"$Z<ơz,Ȍ0zrDG9 e[f(0X-uhĒؓa?[lwrQ,jDҁ$-Ҁ45SD%TH;Y=#i`-h"fRj�e=@a *P4#ݣ"F%#GFhEfxXE=B\zt87b={P BTCTB͌+k߃1r {5AMU;Ճ]rl#ZAKKhjQd�`!dSfDn`;GP|, ԿFO#bSc3B0)ѼLr޷sMMWuX)r}<\O~}m7g_i,P`OP-!WoAH+!['npC+/^7;>g'pr'G<1\'kXd$& e1[YZh5%hMuMc!͈tkBpt 0 +#Nz~ 99܀>}%dp"SA@S$-ȡ0boY#Kb kjmjj9am3YpJs6qs1 ,8S"L02h.D2l(SD5(jT԰q102jh ]N1*r3ZҖz x3֐zuoo:y ?-m|vur~mxr5W3_m;rF 1Ǚc%(0@,61 >HfOOv)h5]Ӭ N]qX@U⢒?l'J(2)l,Z3~֊ŵ\SKsu\iњj}iH#tUT䐦c3iҐi0i<i9)QQLMf0faØFld@ :!f1u_hGL)G1GftZj +PUaЂQ^hYI^EG9O\{<$)8 +%XSbT,p/i630w$?�z ҦR${OC\THw DRR}� +*Ք;(PM$�I`v�O�'C?.P}�i*NdTHl" +b6;?TO\י?${ +lu3AR+-/7<nwVznSmoZ[kMR?;~j;3vmku<cۖD0ѧ4h;&'{VZ)ws(TEs<Bwc䢍&jPE3脲x P !x w_ٟ@w({{-xM-K/pwR=wsdh~p 'ŞATXjI׭@ѿ$HXbΠpFI(DR#Vf)5Tj6hz<LrwiM*KթgNKTmԃJiys}΋N]='rHSH*^qs%wJ#~?܊@fC +O[42nrI%;,h +8\ p8D wT+@SxJcʱGc`LP<P3M"eFcAbH@t C%0 ( *cp +8U^a|#$Coc6#ￃ 7n 9prmnAmZcQ@ Q,=\]8qΤVU)tbR)eUΫ\svjsK|δk9jMsk:rY ⤊%!9%y/Nڦ+W%jG]:_r^M%MoJ2כ^P1]?q+' s<h<1⏧?psk_0_O?xӫ_͇?|Ǐo0/PdYuQ̏TY|}[z_l߉m&Wd==dI=Wr?OU1ߥ_?ნ5/HTX 9bG#W<aPE$y(wFJ,V$.V CGw8+[ȿ[t\E{IԠPmMG-{Sz簁aLqav3>[͂X 05 +$8R;l_~CEϚE j\dfvV!s]$T ޹Q5>lM(qMXIQhRKcY,cq0�=Ao irՠ"~\ٮ’~DSt{.=)< ࢀ5B5w <u,{=WlavT~ܥEzWs!=̪+D57*Jh1i0z OP1m"]f(`QrFs\}82s-bgK ʬd܂ ͷA/B] &lUMyݬXF}nj*XREKGoKt^s(BX8{ʆC9,Zz9 +M(wgJ,(Ͻ+bc>6b + +:)Qlyɬ7t_;TT^A`d}la}8Pes-bg>y|}n* &w U?75U,"7f5cb +V[H0E 됚& El` _QkqKcQTSDnUc֫m0':Z 3ڠb64݌)6E +mxު + :M3Z9]7G7+2\-'jj|yTx X.aw!<!R-Fh<}"[E xcmoNj-x=ea8vlR;7εM=i:u,ysxi^J0/&1$R _`}r;17^f N ?HtneiõhlOՔS]b~Yߠש5vF42.iA(n]o$7FK걠4Ȭ +vr]F)J*J1Dƛvr]V)&hF@m1[;"dTZZ�EWq][٣R`F_ +-"FnIΧz,|nexkAvzmlLg %{ddwM Dbm찫PU҅Hemw&]XȹGQîBޕ%*&{eKîBRxiS7ֱW.5!;S.(Eӌak{c7!;A)(E7^IoBv؃RzՂf^IoBv؃Rd(Ū(m&d=(z=LB5Jz^+e>,XQثфJ#f>^59z8sIIӺ&@ֽۧHmw .S)׏~ � ~ht%:ϯ%)5^8.( ќk �ȿP'f"`T|�'|g7ȏ<vve.X,V ^cPDEfP8x1ZwOU%>f�^Dm׾?6]r>]z*zJ+/Mh"PIhX2lAG23=lxfިw0a2֕=%qpx .I& 7Kƭo_Ƥxd<>y:P G^wř<#' DlX }͛I)˃Yڽ2-W &2}*SqqY Td'.O>5(mܯ{>c)9 \!Wx*J/lx`W`<gqW#E>37Ndےx&'ݘnZ pE9P;TXb $AtrHуn59A$~>rceݨӓS4zWj;Ad/ v6[E2v *ZR�"y:.>"뾙@z]R,r&8(uP?G+p�< Nk �|vs_+P!UFfʞ)vw1oL)).[tGԡx* 1@ !1%=s%[ZD m01Ywv{<6qr+Qh_�$j̧=W2X +e6ΖԱ/[B%|@*+p OVqCU;s\x,Va[ fGcXkyi9-Ulý %kLfgؒEup. BvEU3DlȲyúmD߯P�x�(U�c蕅-ʥdUxh;/ ~kv4\ê:#X>CiHɎcܼXB[1rCln > DnלPA̤!^n08$H ^Eb`ׄKLy0FnjemHpF8` xfYtW0,y&A Z1ɑi z�Rq#_%zn?,O*25]9-&&|f@@É(8==Q̞,(ε NC^`n>Z52M. O߼7}Jb&63~S׍D +exB`L!+tdG +NeCs'2:B HnߗZ^>K]~Y ,&{';s^+5gwL7!F/E-{_1sQا# P֥ƾ}�3`ⷦ*ͣ {sx .w`ѬdBSRrԾsfhRn'%7 +dz\VE$ +z7Jx <?ZtxvPS5dc413/o_;RrW"iSH]]!ĉSAFjS܄}o"$mWt%+�!L<Lcs E�(bYYXSVIC{nS9pmz6JC0g3SO6  j$̹0A#;) U& zWwii;Z௯ۉV`aډ{MKo +|Bψ>U`\8:t5CܥFچJ>ů)F$)4wI +X~%ZZwϹ7όcζ+mi/> ʍ7N*MV UTۇ=8{BWT.P!g!g .l԰i`bXf +k<YdA\Xhֈ[Z/H}$-g%ƮC�dHA;Kr<خ ΐ^j5 @>@+n*T!N>kIM -'20s،zURAY}V=SԊX]׽&a~EGi�QG>vs4| ÐR?r nepPm,޶V8y3'e25K9$0`y Ul4X-ݽn0ۗ߻�aZU0ĞY�|R {htGh1|0(@b%Ɯt�;k3|uŎ8 gPvWLwr20:_ h>'oȅH04`rڭH`a.*hSGвD�]u�?=:d5R 8`4Ԗػw1XdNH<O6|v9vO mbq kّiO14!vT}V)4RJO^vy'h=ڶ)8\QVJ}^G9jo]Dz~Ärx'EO +!TwW m2[(^+Aޫ?FgIpjRё+bӰ"7{r/.ټj>^VYW<eWaq?=2*?@Lg4}mKySALykg(t O: G4ˏ->EƢ _).(iplJ]ki \G\ɸwewa\T)5#(%VDrqyϪtv~RP,[4qa e[Z)<^*p8:O?ߪ=~70 7b Rh[.py�ۃ E1uSї-!~dS&8wĻfG%͇Se[ӯ-v0=*a\ oFz\V®5f~&?YuMљqWuEЙF؅2%,^Uuߣ=m7r=g1jP+EC Wim2?LaW. "qv)kJg� O-]aA?zp +]c$.fW=,;&+:в-[nu0.N\k(n .>Ư&ܘad6z~! ͧZݩ,S >;1lF9Y̤NE2>UkMd8SӦr ?k6\]T%lKF&҃@{o0<,}%㗡d8":Tc0E iۃN3 Y{,1JMЪez3g!\?oU e&qh(L2s1t^B*{F>K xǰ/e׹p/׶1Fӳ29v.ֻvi*#<_ΙYYנR +^/tzc; AV2CfΑC ScԱ4s]FVi|J\]&y7o.D l! +v# RY~\|d ѼLE^-`ng7X# 3vm^[Q/fۊND0g# ^\Tp%Z[ߙZ̝3Cjoqj]ENfvWea0O 7}>!rT=S^Y.!j4/o麥˝h=&Zx.øf{mmшS$vx t<P<56{j6rk=,IhHo};o?Lq^ %ѕgx�ig̾8wƿdžǣ Fy$\`hs`K镌I*85vZIߔ꙯^V.3�?ހ&rA-j$ւzݸgxg}lT^`G3>;el8xAh{Ok|R#]樌y槗StkXDI?[ F<+>bjwu`[ZSz[jx+~ov?m,h,z tlGp�#2g%-H౻A]MQ lQ +CRR \�>RHXw4uuN}RpYjMc Ι4zҐ,'+t�1tjS5XV9'}I ~gVs0PZˮp㖶3r<Ќx<ߟ$s-$q-GeߋYY&zns .1:iΤ"︑!֖r<4jБ_ 'Z֭":Zd +Fy;Jӵ|DhNc\е;pە uXc-�wY$g&&")u *8*zCdK$ Gq>>anՠ8`2vR_X/У\a#r]G[o;yS7Y[qg[8k{l78uiK%Pl7  'ըxfv+T0~`*K˔f["uN )`)/-2f9ʖj޵ע”Ⱥ$Z3XsYu^2syx6l>=/O& ~av v`=ɠ'_PO.3iD.uu4 +#V9%U-]}'$rcue*(!ΨU7hy[&ʘ'-hƻ{to'\%8q}'֕zF%/ג@EpxqHe|[TFaoF5 :yJ[eH}w Nۯ "3`꽀e\(F-u +`\gf]'^9$[|u/G1Ny;q[pL(|b.$a篟fo fN~3Y 4oj;Y,#]#@[XZcLRf�FC]]ښ\[V2닃+͠,.HDˏ|y1d\F0 GXͷHj g܋3xLh+6>yKnp1֬hF^ELjn=;&77}[MYD\p9CQ2-&zPGZD#\[~*٢"Jx/12W:I@w "$c9o3?u XRzCn$.[:U'ld5[#ک E*xW<f鴑(eeW fb5>w)!F%;pNQmpGoϷ~ &!?,7)g [?I(S}t][/+N(@�IeH-9Jyߣ}I<s,Ư}}h()*}L˼Bꀇg+beuȼÐ 3*4e"=_K= +F{Nxb z (Wr$[z: ?H= +jw$tl>/Aejd�< BJ1\Qvؘp[ } ^)@lm3b�ߣ@EqOk|˾`,\~]T0i|s~`(BzhHd mdSKz9~O&۹nuDvd1\g_=Q sCPN㔹e/ +~ j�&}v5P$$fJ7gIMQo4{??g\8pKfQUŅr]V:ʕ 8r�xx>Ms_`oku,\�F22/i\Xk8",`չJs}nBsuMLw*UGf9Ns!p_ bHbofM ׫f&mWz׿pO<a�7/edE7U\ :0o׿)'` 74/WWl1ڞ~"=_~ }glhr]Cpws A%!=A%SO9녫Gylg?" N]#G ӄ, u*G`k1掲Lr8|\r|y*ǢB8,+Qq&:F16)2jA{Lht~=gj'A8*`LG̶v> SR1M .?ײʵGb1U@ŠWE~1C�ȻFɕMGH̱98ɻJFPlwh7 +gn9:%Mc gQ$N9ImĈJ?TQ<K ~P"гF kqsce;_G.s^ \Y_IE$7`Ng`"ca�o `Oc p GV?WBϹ GYy2b`l!/U{i(2`zlh<|A;\avF;dѥI1c(9; q`ԧ2VZ2,'~lNRxFf +lXd0'_Z}d++Z�Yibn;v&1iYɎ!eUԟ^c1p!q@|KJ:$qbT3!9^`'$ +[ 8Mb4PgŰG".3O`v⽭IQm~΢>jXu#2>&)J[nb pk+"}/c:O6{z*"JR =k)V"~;o==WGu a@Lul}c\SdX�RF�ʰ\xV&NqASMaf[&F.7'E0riIaR2�rJh2|JO˭wj\;i~dn%8\5<WD`is߯iy[j/?O?vIn)#dm?XmZp�5Yk~reվ#w{dc5F(GA7un80~dcr׼ D +�\(T[mPv65w ud`cX@óg'<.3Tkkʨse[a&,g1O.Fe[qE#V4`Z5FzKAH5�^99l,CB=t,5$Δet'�NEݟ4/݄H/U/d; ֗m%n[Ѡ>VUrzjҨ12-d+*?Np|{RFoф^NrmrW?2k,+{ }Nmә K|n- N]dWV;5ހ۔lAtAyP~"�೸( Z'x W>E50\Z$ʧWV%بJ}SgwjIP~ ӗ�$[Dwd@Ash9;2j" ~³A L�Bӵrub[-ZfϝZsrI SBXOP/)`o5S+wJ[dX"8J#]dD5pK(bO,6؁Ϊ 3:ш}O.& ΀ڝd4' IGz#N"z-ϗ9\y{?QC-,4аGM#׀sī/௑u!}=NM#&`>u+x.ubƌpmt1Zsx~ m9{;(R1ƪQ?^`r ˋ?xPXð39Ԙ!GV-;n8/$ˣC93ǎߧ$zfmI-NSZB *WuKvBn OY<vOrvRNw9 nAb\p!8lTg)ٸESZ!RNLya<Jj~'hhiP娤Ƒ;aU"Ra]=*@|^C_5VSYiB +,wS赑ĽÝ:L0z*wU1KmL=e[er^&"S("n0>Lu J:6&j} >$8-K >DCKl&mљt7C >5'C|HzIfi|K!%'Cc69jvT BsBu747^ŏR'\#Z.w�Zu4Ka!>yM1 + BwlD +!d_dHD\eO; A잓D9SXK\9)HUIys'0.T,(ا%K'0.Td9i‹)AI|J PSpJ*% DZID^h꾣c˴ pD#n,bQosy PN,|-x2%)GWB`x$Ls\%J1V*#}t*e>&o }H)qd4iG/y&!ZN>rc&+"VS Vk~!R jAD +*a,4LdҒvR`"kvp0qkq[o<,yéڂm_;OsAIlRY9PAKS+ё )�qX@0S<⥸'q.[?乃=!J$Yu$�9A勩3u8|n;cߞ18|_7ݓ4yeB08 ]sy+ݹ< +ZTZOho k60.u>t[tOhӘ(u*\]FEZ>lW&EO޼.!d:Qk"w_Iuc˺r,${ց.6!Edl$`pm iB-\%Y>)v wViت�s54|W%L%GUGGtO, l3{~eLmDkWIe"{X-7aQcˮ =!*I+�hJq S8+-6t2G�X b`]„OUXiU@W<Ak!`J2/~3$oV +B# +S0 t >Zߎ.t.rNjQ +%T;C$j G:9~^8]Hii^́V5N2)9̓װLSEa9Q93>pYH'VDIf{%3[$:bG!~-Ya]cv>U S|A)رNO9!AjdtSrTSbh'5$JBlO)1SV]+YX'a8|ʹ L/�ۜȈFWR8<q" V)(a\7WSX*Xa]dӠǹX M �/ Ki\%o/NaPT谻nj`�[Xt8xlBKEQnM0rf9!NY1<{k[yC욆Qf^ m ]<c[G�sEOsQ� O5|.- /s<z 곫Z(|#`w 0/*Uu-rht[l8:|W}T1VH�?,pQk|;el6>0X +ew*ΓMSZa*s l밟]y6)0v.buaM2huD o:.:H hWP`~Hj0H2A=[u)d@Tr0=Q^`? |j'+NC5 05woBO썹n SGZjuNKQ[ &'+`D$HɄ¶sd8 VuVl+E!ݡG{ErkJ6[v.aW+ЫO⾒KseBdAF|.xDv,S1k) vؚS2B0ikX0\ÞZ!Nr"aj\D@0)zbh~f21}28=v+mV_ڦZґR�zd 3U\Fax'1Trȡ7bߦޒ>aͅKly*mN0<#v }䑡$j;|KfAU2 ah�澾�[X}d]tO`˓MS]ދ]'qE[\.I%h%rQkʮjC{{\o^yW_ ?�ϟ5%~'^kϿZ^׏_~SBy{<KC-~Dz*aWQG*dM^<P70 ,Ma6\`A`Yl 0u>fTe!X fL(55 K4M��b endstream endobj 145 0 obj <</Filter[/FlateDecode]/Length 2165>>stream +H{PW7 XW U/*kkeXFAV]PTPD.P $%hzkEAv]/*Ӗ1/7!0ߑpއ&+.0celzZe·9m���~f?bdŸU+ŕ>gUTX0fHAI 1}:欖<|]m�}>/%b[4��?z m\T7@R7ZjTg\ON+iubF@ݹ&y6G��pGxWh;rM*L\�3Pȅný:ѧ/uSd߉~t���Е% jNNlF:ц +?/#ܫߓ^V$9 L#Xwυ]HI���}$G' + "P"MO}CrWj [}S_,P"GB<S}j7wSJ��S_}f,-yF%ۓqvUvcArapasSnMc0l[eO ansm[���0:LuWiTkw=-FWscs0uNNaECvsҒm���L WI!FVݛ\ {r/y~{2n LX~{m3sj=Bٍc1��!Ѭ)S):8xXZ_{7cqvQbg\xsWYX"?  g:kʉ\Z^ȫ$'z9ٍ{z?cE˿<7)\,1N�� o9}}:ݴɖ;~x`BM?|>"/3-w-_/Š@_$&V*egR"?Zo;8xh2J<Iؒ攭?o"wW]8fw ��{Xߘ?c&ņ\i'j&/(af G@^<lbsilޜ<_}q{͎{Kz?Bm 1:?eIH>��z&Ņ.:Q)ٝG[/R]؇1\C?t$M{?B=:>bk3Q ��`--cGە=V_$~vۜE@z/ꖿ޹[<9@_S)~O W"?w>6&zF%8v!��\6VVcr>MpVv5η7gԁ57nU>k}|jz%]kz?⋲wI<+:[p4u! ��K$ܱ$+㮻;vO7n\ږ2z#Q7s(?橸(0J%Ru|H攭RߧK:*���DKCQyYwQΟ8޸t7<Y?L˃Py~^e<zPgix?1d [3X]ɯ2fa6 ��떽':k +YV.:# k=Zr^5D@4_'t_!VXYQ$'TAWg]#D~yR(Yu4rLtȻ攭vuDWOV2b3��CmiBJ=RWOUYvJ'?6JbZl>9 �ss23Tk.LWiו<5W:Wgwmlzy��` Nz}{\9e]}FUJ3+4gX =MQ2^lNC�c$KKY̋yS*)T>_&hTɎNk��0#F:_?Af\[R\7n$<̺>RP#ORI6O@_^RX㽈G,с*Ny}]g,Ϗ&AU.Y?��M1 endstream endobj 146 0 obj <</Filter[/FlateDecode]/Length 586>>stream +HMKTaࣕ.4ԮЈR]{wNQY:d0s+he5.Z_("];r  3s.x;{kKw󛹙ё +> �yua·]M;*2��y V?]N��ynЋ��Ag�hLUH +� ږ&k$�mIRJT];v4q=̽Two Fw϶r8̎gltf2w; k!9C9䐣9 +%7{zk 3+IQj +;G[qp3 c8n Rs{TsT'r!r9&�@H �m5<�D}$1��f_#I3�@׈tq}V~o3�@׈ۛ_g� kAvt#�u6��f_#^N?}21t@{� kDs7?6Y��7Qoss_wGD`�i endstream endobj 147 0 obj <</Filter[/FlateDecode]/Length 758>>stream +HKSa�g*oYErQAQ A˔E2,vܛ'i[w(EYG{|98O�� 9|dF+MM9My;b~Z>��d7Q]Uu|l*ط{}*7z )?zzghy~_PO���r_+;idX{~,y<޿9kD[T��{Z+fGIpfՉ|xH]ojV=gDؘ���XW"<b;&f��ȞVg?)/.d���XZc<���h~#<���xz?kȷw@\u���dă{Ѕ?|^P���ɞ.3-eUG��@Zeu? kOzkMgL���햳@FYtaר&iF}WUg��ƀQtOc@ptV3Au&���e)o̘=];2Lՙ��� D />9Љ}Fj}ծ +ձ���rcF5ľ?Nt7;}v\���6ˎw59Љ}?-fKpYu.��\p^Vt`@'Qxf"d|T �� %Ƽw&O#/Cs�_ �PF endstream endobj 148 0 obj <</Filter[/FlateDecode]/Length 763>>stream +HKq)-(Bk)4B^ ")E]9&YK$BR>6|>|>|ep6P ")gL~{ߵLGxT��`C3:oݶݪo��0Q^XtzkE8N8ئ6���wX{zm]F@7!h҉|P}��nc8>ft?wT}��R +D(Wʲr��E/?\Q3؜y7U}��Iuv˴FE@G[o;>���WaEu?MU��$8:{.?|1`>���ǮUh =}ձ +'��lEef5OUhʼUF���<.뜿Ѣ?|QQg%?P}#�� Kat?$]��LٟsٛN +w7��@._d2ꏛR_��&k +Y5d{Q}'��ΞtzY(ꨳ"U<��@gbfjR_tV?3jv"T ��6<ʵd菌\J ;��t&VE۩?nkT>%�F endstream endobj 149 0 obj <</Filter[/FlateDecode]/Length 2170>>stream +H{PW7 BZuRZ2k@ cEAtK1^V "Jn@""P_jբՙqA\>̶0'ͼwœ<D����/ 89h7&M@ٴ2 69dƍ# )9 \etgYzf{̼{-Sďe{����llkKƸ ذ%i<aqypX~ZV^grSOS_9U^xxvja3g"yQ_GZ%>{���x\hIV-Slj}xl}ZEmLgwؐ)f=Qj"2"Ih/QS#o]*yQ`&Ha%+���0֖}sE.<<Fh'4ʛߝ>n{ҰjÊnL8'ZG$_ux@'@'\PQW���zcP +MyAZBAj5w˕9GU=0ɸ/_4u+8s 0apf ���-A}w)aM4=տF%2 SrZ[} De}3mԙŖd C11>sM l���q.l)'wvԪV&j7:|WNe$8մB=O[eC�kcI`VqYWr@Je;���@_Jxh r6%0ل5',3ɸ +KiGRŹrXKLרڲ)BEH$lk�� +%X7uk*ycă9#Ow224( +KGlq$6c4?���o# shWtENGz5tS_nxX>{*[~_x*Fu{s` X'fݩg~ot|oG���~ɉ>|y<gyvFA-5Tzqs|ܣ}#F嫉wW9319  +KǸ؀uu\oHB43 +;;���w&%EE9eUjs0j.?jږX4Z:FWV|c7t?X?)+SaW_GT_ߵ}*����8ӟMmJQ_yx2iO!zh$!ga5BSyQC^=ٻH*Q+V(OH3Otz? +w7J/Uz1G'���69ܩ(qm8-eQB3w:ڃɂ0=855zbJhG nJ~rg?]܆9WJ+=w􏘢t?Fu[FL9>NѩO ���57D؋R-RJ;r&;jJh Mk=ic؀ћabd??Ɇ&qg){w`&Gf]~v~Ld,]fs��4d͛>FD,Vt??wO%`soDP3|:3M`Mtœyo&εmߡ�T��0GGZ;>$Q&H Vdk|/4wh"nmn\1?Tʍʼ0)Zv>DO?]nPϻ#��@F w9 a5*IkiWLՅxDP@{G-//ֆp9uaK9ݭmH)-X*=R j9ry?s��3\)lBZ]è-ƿls wNz"I9|&xcU +=m(Mרn˸]ߥ {;^_jGG��p8GA$HL1]I':)>QTI$f?sc <-I`t򘢸fKk{?7a_zҰϠQ\1}s`���KW�d endstream endobj 150 0 obj <</Filter[/FlateDecode]/Length 2497>>stream +H}T4$<e,\O;Xk\$tS +E!d +ѨLm`Dkݻ"ڝsliQS9~�} 3>�>\N$wUTO$7_Tn_|QA  y)f17G| m7^?evDcCCP$gkYzߓIܘ׳ms_;)٣::S�OgyX=p!`dπ >4?Oz.R?dVnZ$cR|Ƽ~ !}]472`J)KLN7^Esmh*?ѹ򾍻7o1F!$duNjL&)ĵK~qF��<LH�wv/pHt<n M}9_әam )Jх"VjtJ.4ƪ!ƌ�-Ác4%lRfSEHDKĺQ,7@r{2F!d<S?P_vleXjw6 ucR_utEsgz@!V?&[G'y6+ \|K5jOW<ڔpm �b|/L_>$TGOz#yb.}Q:z]gwjT'/L::gQa^^{@!>̚4\ؼA Z.w .Vy|=X|0'Yr_x %]F^sR 9;>o/]l==/!-goeW >#S??3?*>,jXo|J`�3}{BzJݗN}Ⱥ?H&|JZ[Kut|g^ ӗBhlk~~fUre#l_\Kɷ'R� +-wVO`Z? qO CY1sgxL_/B!O_}9x:9\OKŷ4[Jɿ\^lupV@2,oY};۵p ]ap3 +i=w;L7KF!m>@{ԡP|V\jsk4+;Zik ˍފ!hҗp AqR8ܺPK[pR~ԁL_3B!ejbπu x#8ih%,3ZSEHDK'��3={!}&WG7Go_鎅moBޫu9\v<B9d(,5vo>]OUEW5;5G _VnX3\ b|/|yq͚܋uc@D OSG!PLIyy dB~l==eC ?*:Gp:Knkvy<*>,jۅ߉7pS $m+Hh{ضfISzMyl-_gsQ&,ctBa`˙~nؐqS +)9*^3J2FķV}znQ! u]y=\LA]k?Hl3"Vg^}ӗB 6NO'gw;-ӹGD|!-j6F%WwEWKF0u�)J ]䈯KcNҔzAs߲̤SAL_;B!6l83gޑ];>ri*JrW1H*yVt_i# !@|w`{H ŻhW@(%2Lwټ{bϜl5G!F 3Ս +][ Nr};(dn]+wD#@{}&`0J�{ Yw4%kh8�\敟>aBg9l8pfjW678J]~cH?R}[%)3at= +<g b0=}N$;cXzk=LEI 2WBFF06._ھ}{!Orimۍ\R<a�10wvbmO@5%璮~NϵL!X,{yɣ?oGO)Afcd {^ji# !3n ]SO=?{ݽ?H6&%֊ +B}swp<{Ա@|Fh6%NcQTZkǦ<X%~�bknxe|ܖJݠ@hc '@#Î+n:2_ �:u endstream endobj 151 0 obj <</Filter[/FlateDecode]/Length 2461>>stream +HiPWO#@ M5(cFeР2 DEAʥ@ءAA "브&(QAQ&7\.TxܯN}~kP@Ho;-Acb<ϜAkH&(yU.U{8qCXӚUH(9�أ(WW" v!}+zEaiEBCc>v.LtT25N"L{ } ƚ;gyqNLxI1*q{뙄S]MA>ǵeҩ ^M?q�\ܾKxԾ7s?a˕ӡj訹R?b'M{ Zl&YJV|6Sw\2aD)P*Xg_Qlk ��3܅(q37$`@C[x0'B.lu|Y)3hAmc[eˁy8ܴxLpA1 Z6d +^"/�|kv'? +b?1GLǁ Ld)޴8cg'R Ic]|PI|[FD(E6Fd dc@G?V;֤=�*qێ>l@+tt`G hvq!?3M)1oWTM~.J2a J(]I!h7dE[v] ˄yhAVf&vLqZɊ nAfJB辳nE#nCqCXdWy1j l}1x3o.�#ؐmOh \T=ϱb- 11N^7 `pzL&=)\[Inx{dU[gqǬtaA/�ߙ~AQkI!pIk9#icLYQ3ACOWF{50!"R]wZ-P2+ lU:Vw$Sؗb٠�5(mН$7#DI.N?1-|5(i~b}n˲`gonA{,Acqz0(3nmQvBozkY'۶<^msƨk �"7Ewg KI!y94[;R):� 9DXӞ tс||S9f3߮k5;FӽZN/ڲF4{h+(oSr-9܄OsJk3KF*d==ڣA1df5lpqej!L;#T2Q%\Y/P5y\t4 ;�w�oT}r?bA.N/juR.ퟞiA3bX Miͤ'+ezu ^*Ilejp/(5]Rߝ_H Z藽ZH;C_F2a)ڳA1>}1vzc)eKQۮ)E@eKG_4cl(#+$̄OӌGM]ϟn! 1f@v3(;>$?#I~QJFQq Ok`(;(=aÞ[L6/j^7hb$ٽKyu-J=y1209֓مTpiaH)\Wjy5DU'l<o\GEQmKrB.n| O3"<?c_IViA%:,15{㫟ovaVj7;©?Ÿ֬}W:M>(9(RU@H;fDk=+a@1xnrU_r_9},I{(+3Bw]V̳zI&Ry%JM1䂫TM~.J^KU pGQ-$rB^"O6# t57tLYغ`=f,\N޻gޫ[Q<,j +T:Xu8m}GQN%w?iH~*Mw*yχv='P##c=yЬ8 +ߨ%@NŊo-uFv EH )$`@179:_r{KLQ!Hbb<N~.nHrQ_%sfu> .>44;]Εc:Y1aӣx��gw+ endstream endobj 152 0 obj <</Filter[/FlateDecode]/Length 2669>>stream +H{PSg`Q[עPmZ(`A k$'!'`$VUQ(ֵVm>:*_g3sfoyo5@jBlYD^ 7Dsܛ yLkՄ]ˠ|W{^Mƴg /<xxrPZ-ˑKWwU9͏[Z6.|(ss= +v0(Ockd:`@bw d@zC{X_p͉}b 2MLp,NRHJeymZb[|ё4�ޢ(��rvlI_ bHR*k=0p}i A~Ôǃ93a'9,i{ +DܥMlʄ-{ߺ3 +wb@QT>d9j>?⼦rA*62?'WKssxo۰gQFL INfBRt ⥪'cz^s9\:P Ѝ(o<yl14tMMh +W{\Mxy3i 1Pް qM]>(+ F}پ]<_9+׆ +`蟑(N\B;a@ ]D\Th"w3jKҎҞx？$m]jA^ekzF#Ve۶{TdBg(k蟇(Hr#$F?CC1(yzT{e& +z<!:Ld,}y'9IsO+$%-Al/ײq჊y%B_.sEQ* H6 .Lr .qA-+փ@@Y^rH;sCb=5p�n˼ޓ; +nHoxR¶+׆ (C'H!L1Dtr*;DxlHڣC^\&YN1AAbg1Y_Ֆ*XS/g +*>-ЃtB;1�g�c(HrL,1Tt9+쭽X툀O)c-Fwk|�a~ƩSS\+}/R[c +ݫ@:j4`U(B; a@ ]#R~,Zȹ!C3j8NCF_#{'M^Z?}^\T#ojwFVt.qkT/mW>_as-oAC/?PEWC7RfR9?v #\8϶F\|^"QQ?lG@#lOWNM0뗯"aaf6x-[Q[Ͳ9똂r N6L6'ӎ4 PT?oPEQLMr~-l SS\嬸+%b͎\)?[.{.bN@,/<tG<n*M2Lk +] 8-j]izW<\"/.HKw7HzB~ϣ�2?(~IFL>?}aL#z"7ofldg/Itό"wo <,p`$X $iɗ%,sM/XQWg}zֈ^21ǂ* (tV(苰K>K/FFL[<ޠ۷[׻[Z=>]D\RwQ{Ol,H?1g1|V|i{ +DܥMR:Mf3}(px&B/vV K^_:o>wWsAV gzZ D<َrq4ضv'36f'0vǭQJL.((Jp�3yO3D rNz}d/zB}ϻOؐPˊn<P>/J4qWc4`&&T rqkt֧WozX?wEQEP%հN7hg>qV(8de n;~@{}?QLwT-3}9\ebL#F,8H:awkdE5%5/_`ҶQEQT$BΊ|*XM;`@JA,קN!>ݧ/cz~ߡ{d𨭁f//c##=n5K:ni~BߨuoJ8ի]hǽK<nEQC<j_V͘eɢeΦfV}ǜ-˷nߍcWK t~CVߏ;_~oy,'ÚZ�ȋfh}@<5>;ܾhKX5F(ţxbjbP +jWS6md j@(lLnU YYDBPU@�i8 endstream endobj 153 0 obj <</Filter[/FlateDecode]/Length 1456>>stream +H}Lu?,GsLEM͇C- 2RVtm!9Hx#?P8cΞ Dͭ } fOP~wCwno frm]T/;{93Fg ' -R En*-34Jvg-m,-o2wdSw-<^~8KՖ4N|G���x[B2Wq{?+6q;75&|%+:5甴?XQmtG>)ߧ^[pG5ƌPZl{^;m,߷Fg3Knr_[��@{M7 +QrXesgO6J^<gQO~|H=}w99WL7GT7Hy;wT(P[e];^an=n%H&��x|guD^XQr|%x{4*ӕ#e9+,g?7/!QRCٻmm9wfؑ𤟏Ͽ^BVjDCAMfaW;N'F|jŤ}i3���wOjN mQ`f3;}_LkldSWIg\rϏ^ABFѨh,;,{uŎ[$ ]ۉ(���3=4sNxc?'.m4ƻvSZs0%d2JXVݑ:Rj) o vs))}-Vn%J��F[ᓲ2 ѝ(qTC*l~s{kn=˧?-5xZWd-)6��WC>u](uLK~%Ao.q3Qe;���@8#Dw[MlĎ���{`6tf07Gci%l���6{Ò]H; Q`Gu35ߊi���ྴD +juZ(}q~k龢o��� \(}o^BZ"���{Atw@=J,$#B$��{;ubKv='` g쏱 P}n'D8���p/~P _r_Y?3Z*ڷs���l#~EPtW@xe%5Ȧ+7u���~l8{讂 C !Vs<F���p/H5(r'?MZMMϙ}���@F5E"` ȝx`UqV���@("k+ݲ?Vt7@?ǼQ>6}��n7�ezp endstream endobj 154 0 obj <</Filter[/FlateDecode]/Length 909>>stream +HKTq,RQ*UQVFiA))͍DY2i3h3dZ#Z%Ri٢@puf393>~p91憋iƲ㻗cMH۶ dGcb~K@<��iKMWy후AȟbȨ.tțfy;g ��H3U=}?3VAߨ'W�Đ/!uk"BUGv=ڳ��$ԣduڷcTn +z_מ�� 1ZCo!ǪC~nmuC{�8d_+[}?{?V5oҞ�� ޙ^Ac!U[}𧻓E��ehBǪƣ`p}l��ns߯,P=,]?}|��5tڐ[f彴Sءse}د3��ϡjsϯ5A ߱Cewf:I��!Cڷbr:x}}��1L׾5DQXן��`qd^X}c?<viɹ< ��gnSzjAHS5]-/mN ��q^о-DՅyLؙ=;�<&|mA $ح"O��kxm־)D;:Wy3��Dg/sI7cTn4w{ v՟�� 2Aߧw:dk[�uN endstream endobj 155 0 obj <</Filter[/FlateDecode]/Length 1217>>stream +HOur; 7A2lۚK9jӵfKPZҍ̙ʘ@B(sz.F(6AտHNpN EwBI=G ^V*?5/ ��Ϯ_.};T-(;M~nyܣ.j&VDv��&`gd.[A!;z��ZɽS^禋 +��|ioV}C?Y|?Z#?oIs��$;*E,-z d7 YTV��0?tECUYVD��x6n {z׹7& y|3쨹z��OFr_,=􏿿ן|��`T}*wWU}+?B!,vaճ��̺pMgU +B<mVq8i2ھlxen9_|b(?x.nV>o�л+^~ͽU?ck27N|w]ގNY&{ZLW#>Gx th[��ݨjH吼L7jd<<2Sd))(xsO{k'1YZ�@~(w9^mj5x{Yj3L|qv@�@ƻ+;lUZ@ %@SձR c}w]q �|2mf͉oQ٩ ciWѧz�7?{Xc7V?ȣHxKVJoop~c~y%I3#Ga��B]y[@Ka';u,t9oOQ[c9C`E_2@K,�@/\*wMUZB ;1⍜W"$(ٸ}4enrr|nvZ?UcUTfc��Vk y7JU}$dN-&2tp6{ZO=g=GTߴ汷@ML�`,uܿo�wh-P[f.?Gx&~f�V�J?( endstream endobj 156 0 obj <</Filter[/FlateDecode]/Length 2056>>stream +H{PT](-h`GR&F F E$E`1(u岻Y ,CNzW>$"\s9w6a"mtuIL^]cUŨkODe?*甗vzmxU|̵y]࿨Rt}s;f33L}YfJNq9w`��)ibWNLþ^/^ +ۖQy!47 +,w׶ }(PūK=ou|^D,z��� צf&1KxNV5{Ygc)o$Mw^J:*`  0 sE~Y_3WO=kz��` fϰ OLǺyٍzM䡻l6#|II8P~g-`l 0Sw`S.,Hr��}{X΁87*a߸r6"_dJrwsB{{|xDLެ }P|4W+Ox˞uli#��=_Y53ƥ[1O,~yr\z%Y.b(@�[1ú '/ӅCZIn ��Dd7k6}\We*Nz[yiҩD+wUY$;esg,`l0W&Xwuy:<mof Rz���za"[s(w<'?o^n.ards@30&?{ S^}rDU߄7��̼bbBs)4r0PϳA:owt;VL$[.|E! }+`LLܼ\[qZѓUƩBuR, u��xi`}c; `l~jR0R\dwIu|v޲v+埚Xh +̥qwشgd�p[��ԔJUVvje_F6(Ecgkؼ- l Ce')D\ު O;M�0b0۴oIEҔ(Jy;yf g,=,P~\ C1P^_}.{y؞5߲)�̌>|ǁbCZ7{UW mj[CޜD,t:?�x:Q>&<l״-|ʖ5'ץe'�Ebrf]"K=}oPUb0ޏ(g0_V6F30& ?uR$QWN~|G���C#GҊ(04 G]\\שq~O7 * ?1aaHb(WUrKa }�� 4VFt0|Ǜs$Y^f9vdnm3eY +%Xa>mLƩ*+dHC��Afh\!%i[&?|7ZN$wխq"&.]/|߆SOZ1PY +?,7K9뵻WmЃyuY���e+Z̙RvG/K>wx9^J,*>GA=jy ;�<?aNyU62K9(9��>8Z(-*ҾBQoE5Ɖ +?>7AQ/"^h =̐9 +?fu:t>νD[iӅ> +��xn@]D( QhQ׺;hEJBUﳜs?�x60 +*չ27DMCs> ��xV'OM+?KvPej}9Wض[!|6NgX˗5tz�rcJf endstream endobj 157 0 obj <</Filter[/FlateDecode]/Length 971>>stream +H]Lu_PkN[JWz|B t6C>@9ܚ6(|T9QxFFk +Urkve[Nܾobs>y|I\^<N+`_|}RkWfBlI}YI>s=|l;[o3��~? +8ϱ?ph2 �o_g˯n|[?Oa<[桷Lw@u�7IJjwħ? S49tDN�J#C&jfS7LG[pN[ �/~=%*=6cҦFN��׍T7ҫOx۱?OaL_Ƈ9& FF}�pݞW_;vS3jw��WY.Veiw ħ?f&tikGjn��\uh<2,.`†+~o\�5ҟң ^tW?Oaܢ&CƟo8��t'oRtW?Oa{fʻZV׾��A:Mݯ+jwKħ?fga&ݺ-�7c_-IQ.w Sby?K׾��37wxE] >1{ 7KHX^S]�VғvA| +cn +N,ڷ��[ӓL2%v,(h־xS}�6ͻMvܽ]s MarJ�meIOJ_jwħ?x12ѼS�` d,2Qjj?Oa<N͓w|ؿg�~9vWI 0�D< endstream endobj 158 0 obj <</Filter[/FlateDecode]/Length 909>>stream +HMOTgtQ7T7դ]DcL_D!)_ R b$D2` :3 VHf҅CwFD 6Xv spO~_,α6mrƊOnqXΑ\&91s}��(mwN9wUK1muȷ~�ж0^GGF/uҸ?6ͤ&S}��HmÉ&6[,__7Eʊsf��- ㇥_]Ap0K_w#oZ�I-ިv`/Ȼ;5$n���a{_8~qz`Cy{���a;1}VŖp0KXR~��?{ytz-`@ǎ.��A{r?LtRp0KUn&赜v��ڋ?Il 4`^ uϚ2.��׽eһzk"fivwNr<?r}��o7\wyv{-`Noڍ��oW}͵YG5lu=wfn~'��tM@Rz\?q׆r ۴[�_E*o4k2fiiId3ɡ^��:t}8ѬX?qgsczDZ��c6aZ,#\MC?f37�b=<Mv[K4ps^jb6ߒn��%Up0K_|sg�U8\KO:vh7Tp0KߪLoc J �0A` endstream endobj 159 0 obj <</Filter[/FlateDecode]/Length 1193>>stream +HoL ePlck-4sփbFf6b̐h60#pw@zP +g>2a|eh߻?~>OaXS�Wg{+nǩ$#"gn>WۅU+ B=r,e& rh��[UE+xv R:"s7N�u4dR3aP +Cϋ_zjv��o.v_"whwٰ?H(玝덺W~9]W��ڮڥ;l$Е?7\7k�eN3bP +C_Zr/��&u;G<%ڝiVJa[]Z'&{+Oc��mSWڝiVJaڪ{��?%')43 ԕ[;}Wʺqq836X֥5��<*$=ݕf 4v9Gi#5-}�H}Ez)a4; xJjq?Gd1uGT�АyXzII#͎A9;2,'Zl?OJy~\G�`^f<&}lY"nn"#"6_9wgGp:~u;G][�`>?Ceڝ)owQ=a \N +3 uɂ�0K|j>D`ۑaaw֑I|^{^sܷK��!#S`?݅AnuX-<L8+kw]k[n'*�`_ULϩd.rncGZe>"#"'\+6+bXkwچj7WSa=p ~쵺rm.#�@P;k;?H %;y=9!dwＺ}Y5Eq(ivlm;ӜK�%=3ඝޑ@\K$<*xn|f<5qq߲9ض|B> �|ےokw GKP͎aRO^WX+�=] v^iأy �;nj endstream endobj 160 0 obj <</Filter[/FlateDecode]/Length 929>>stream +H]hq-%Jȍ!Fbb<tip9ƶ?m ٸeq3\Qr|={~ޟzݝ_k ǻW.7'M6~MCr3}X*c��>?-:/vk&kƘCA噥u�/#})8Du=Ҹ?0:l5k +�[E::siȾP8^Sڽ�s|(J8ơg̥qch|Sz_"S[��{IG'uO84,>mp|ђN]��{}o޹Qz(ϸ?KO_{w �`ttv;̥q'`i?>>i7 �`tdB'MCp0ag~͇iw �`tוS3[`.NkG7 �ҍxU nz4{-?&o=4�@ђNdnv7̥qح6^gn�R=H/k";ۅ`.n{W;v��uù۱+vw̥qokٱ yج}�#[ʊ2`.~қMh{z�RGu1҇H'n47+<(on� u|M%97 V?KpGa4Vn~��Z#]Ek`.cčKWWw�G:_l.H`.-Yc=+'j�[I҃ gn4 ͝oJꮄXuG&�?oLv كv0p̥qgZ('KO�*( endstream endobj 161 0 obj <</Filter[/FlateDecode]/Length 931>>stream +HoLq"66V`) DӦJHS ҊKJARNONA6. $DhԐX7.ͻBs>/>y,R�|h|{fV2K�i:k=,ߵT]z=�Hl+.{Ĥ?4f˾i:ڃ}�{]6_1)s!o/D�%rVdiw &aqC'F^�xG#mvhw &aI{N˧oiw#�;=Oܹ|=pJ/!oyjv?�͞)wB`vbR)Ǻ y4j^ߓ��].w^vbRsdX ūjw%�=}=sSw^k1)ܰ4։l�'BK;b1XzSwJ�=OB"3o?Iaˢ2NkEUvw�^N,)-m9*ꄿ>ޟ�?&i>])H1)ezӎw {�n;.\SbRXy5] +�}]e~/;%SK>bRŭS�ɽ:ΔhwҋAL +ÿ&TZ7W˯*�`hr^ݖ!H/1)+-/V�В%r NT;+Nc~�~&YtR3AL +.no_Fǯ,�`嗷N˽ `X{jx;fiw-�`PylkRwZ+ǘC�+Ƌ endstream endobj 162 0 obj <</Filter[/FlateDecode]/Length 1378>>stream +HOuȒ1QǶ M$3Q'x2rf aD Cvb"aХ@ ZvD12tvRXe޶ϓ|. p|0 ,vo6Pm pUwT8̆gcI��1ٮr7iy>!D%fDo-7��yqz�? +,;}hw� ݳ{󦲭oS?`8Vץw 33_�@DK=:e޷@)%i,LM;U7x`�@Dc&M�q@)RSC|G2w� ɣyğƱ.i��zƪUQ o1"I?n7 m- ?$vݢ֖.�3a[(./�5Kh)<<$--y$S3caH6�_o#yw?"6nbḌ<SaTgӮr��zܤ NSqd ]:<$ī?aL`F~˷;2i��B:hMRR|'D~jYc + 7x#Li6V��Sԯ{OHxw="Mqp *=zL퐳E6xJm>.o��վSJZ n+K7f參4+{#4g7ɟ!!xk]{Lӭ觭 +w�QR6ۮ"˽Aܰ?=^M0׶g&a޼!j$5k<o1Y{fB7 �gWyw;1r=Sy#"4tkv+ Ip%Iǿ?4W;n\j^ƓTnwfO~�}/Q*51;ć>=>a b99ٳϭ7_ysKC. |CXnjUNpw �% +s 3Oyw:-{iG̝>zt�4_$8s8^8ȮYöѶd�P_tkF?Gyw9D1/~o66U*<+/SaK+wga(;M� 9iԛgxw8D JDLAdk[|DIEwR�UifˍMJ `ؐ~xТK 0�;�E endstream endobj 163 0 obj <</Filter[/FlateDecode]/Length 971>>stream +HKT{t҈hwucoڑF)EtoKC3E*s85Όl7LdQ7QiЁN}az>o=}i6cDte⃳*+ƹNB==˻PV>u4i`<4xRzRRQĦ?@gKtvh`<yߟӥі] 6/֔H$^5{�#x7j/)xez2>r?>ޢ�M҃R`&FqcNחNؗ�˃G7/f?)xmoR3�]zL@gKv'bSZiu9 ɮҿ�Ow덑;]>d؁Al +0?Pe\Oh8E��?DKw KIjw1 6B\7->hҾ �OJo  +!zz}+о �DNkw/ 6B*)3m%7<[>�B$^Iw\^؇Al +6aeSV;�$MFF;vbwNq臁ڷ�x6鷵Z؋Al +~5#o5s�Ǜsvkw, 6ԔԵ~'>�~YZߴ;vc67Ta6yۦ?�ʦϤ״c*OTOv˷o�or.KU4UOTL bSP +%띍�[_e]Al +U47u=�?i,g{RLbS2҄2N׳[; +�wg^2Zovbbl|`�ʮ endstream endobj 164 0 obj <</Filter[/FlateDecode]/Length 994>>stream +HKwOn&A emg^Β.vÙ#~y~G+u̕jA Me/2Z|?x2] :e>̛{Om6ýX1m�{wG;+-Dȟ&m=h{=2Nrpc�O2yɕX5O3LbSg;c�3M*~qavW"Ħ?TKyZo�Y+Niw$Al +^RD:ڑqݪ;�'9~7~H$r;v�IGzIwɫ w# 6YW_>gIzbpD,;?CGڝ)xK.߮=�HGzH ?MaM?/i#�a*zUz@g;Al +^~ii8$'7/TK�/雦ֆ 6/{yoŮ:] �;]mL{_,Hc׽A'mTO`Qu[;x)Ai/R�IW_=ua_T":uSWʳqӰ?MaOj +^oTl[�_#K8Vm?MaOTpɊzh �ztiCH8R.m?Mao^,4=mٻ,c�Dk/ddsw''ڝhў̙9犓[�{G]#]*&d:7jIOH_Ho+V0y?MaVm1n|tLMHOH_HohwĦ?w 9_:_Fҭwcά-�Xy endstream endobj 165 0 obj <</Filter[/FlateDecode]/Length 1779>>stream +HkLSgWl:۔yO4ԈH&2D! ,b-B/SaКE릛 T.?,hL-I~4>?P�p]8cʛq~FO@<lRc ޚ4P}}{ͻ�^6IliժVw�=<. ޳ +E!<?Sl:6_ӳy<�lHϡY: 'xtnY{�F N9l)'xYXa mm'�Ƕ-M,{6ʓ +<M,Zy&3xA�ZU4x$ހrך5y* +ND׈J],1jw 'c+4kE=ї>�ZK}OOs,-(w,mhT-q}*rږ2?ŠJE׏^�E}Ng@oB@c)g̩s";p?_V.$M#A�<ͨo~s1ې?PX uvQ{?Ӎ3Ң=S/wqߓ�w&[ϩy�g@@co+V9ƍgc` #}mؔٿ?b+hkmF_K�;%YiR5�΂rOO.l#\w?[ٵi,An7@PS?-:7L(WCWR�m~^d5lҏXynNe5>&w`pA曇|O�by�gC@9mh ;;鱱kD@?UY\T^,6%2Eh3\KGs=1ܿϼg ++ ]Ç e~#<y眾|鱣!譁S^9ӳlvuiV{Ex3LسBed�8V0 y�g4Mʾ>SQ;Mcx+1^�ݻ1W[_3hOC@[Y4*uAw}pPPM*eA]s.C�o6mZf4 FD�tT2 W}{v�ksjgtߦn I};?H g& o>�Q_RVW 7_y �?PZK*j bYSX;�f~K�<Ր4{|3eY ʓU#vDm·#HhJf꞊繑6Q]#Ƭ.}G >kLB"RG=֒Fe~3Sqӓ; |!K6YM +KEU=h_\kł/ >'"mٍwwx_0GYIΜmiw=3ߤ.ZrhbX!rP9.vU_s*v(ܝYɺSA-tVvui ٔ7v]|$mbpP:RLt&)knAFÓV.lS]{NUDw.ߣV?zG}H`�ܛU endstream endobj 166 0 obj <</Filter[/FlateDecode]/Length 3023>>stream +H{PT/xT>I&Nj}% FqvHxȊ,dYaeeݻ}]hhfbi;S{.^l{=ߴIi?IjSTů. ysci6ȗP4Ym>>+07g湳D0KPbxo`7/78 T9ZGMD7e)v*h{ U3kV4WdUxW/dC6zApeі sB<S̖'f#f#AƎ]kB{;-mPqw?Єdc?BM u1,ZdyiR�|Ҿ{9pOI.;FYGK z=$#b7?/Xh`#M\]v qH:}pk=Bˡ߱ /e$T3ZCk߆3ׁ&Uhie^(5Y:ҟwsۖ]!ȋ?o_yy] 4!X菷~Pl-Ytꍤ92S5PĴG59"+Ss系.]Mzz^Kc<+뫠4PsYm@W>>+@<'չ<u vc4@mh1t֊ vsChNU n6ki3]w] B Io#ِ|K@�ˠg^Qp@_xLl z]fWq auOЈ:zaA? +͇NRkt_>Ia.iQێpc&X)ZYw4NG3&rcN"+@hT9%ՆMh"4 ǐgŤ2G_q⠑Xv qON"ƛx*h.ojR[s7.V5S[Ӧ5t~FBk蚬I9?0T/n͝bcʧz^h\Gހ<dexnlCsA^ Oq^C�tLK +sA|hB2_2^X~c4t6ټ̮qr'$!U+]O\3 +͇f6$e\4Ҿ ׿4)�J p:=J1+wN])45;xgmm@A>A^֔;ėA&$1 /Fd8Q́"+Ssdz.]hz^zXypWpkuSAp+4[nC<֊` yS:}wfpcU]KiJ!uS[}.]o@ !(?)߹ 4!٘7??Qp@_YQ�TmBX/8 rMu>SWvy"$#bصHzOE3&mzRL*{<=k6 +ˏh"Kc;EYjwP<IY=0_N㿎C' :ۯ275YiP Jm-_�oe>[]<.V4Hg3a&fۛ +{}rccJ=8b4Z_j;UѦvz;?-Y#RJn1ۿb075o2)HLlzApe?*{e/^7IB+ ?9ȯN9+&^! ߹ 4!XʔޥWjK<\:5s3!o +h MG+{EjSdv\Pz8fjjINZkkNK2f:_g_lQn%j|aޘPqq^ُdd꫗ՖZjkNb|t:/1UKIsL@w@;J1m%|ߓ/>4 gwCׁ<|އ 4!X Xnw[/~JnCέ 4On~m(8u*�MV߹q2F 'MVV<t'6~AX=.2zSF=Oft/5SHu=&3I^ 6-{-L\zx>Ob r Oz ߹ 4!X"ADP4S{+P 'Mg ? +,6@⏠@@Cnv|\>᛾||HP;GğA&$C Ϗ.au߲p|)\{߹ 4!y"7P&[eQ|ׁ2ozrO1|$hB2A{!Gsׄ2Xs${8|"hB22:ViE=NpTC-|9Z B .15U.u+n_^o'QLm|s�(}o[gw@Q<#kC(יacWKR۲vvM+NqmڕY T"&W.;sҵOZc0śطv]|qbJ1(3(]7(t^ţx(N`?ڮش${5AMf޸@v]ykA.NU/ l[<UCؗaڕ' _is巋ۧݑ4Q<;S.l~AZ(y(?Fpi˰y݊y͉Q?xhjGy5S7-^HW� endstream endobj 167 0 obj <</Filter[/FlateDecode]/Length 1977>>stream +HkPbMјj9Ȕ`:҂"$F5(Q`V"HPmLmT*SG5}1 K&T}ff|<3}LuLՂ;$k$I,z.No]Mw&vjAyyq��BA6DMݲ6)f5{d#;Cƾr�#Sil*,U~IV!:+cVKy��S{bVL5sZvbT,ϰ\ �?59Zý>gS�x2qWnhЁڢxžQw aV"QtNt5E~B�S'U+7veqǟ=�cEo{"Uɂ }?5Ƅ; ]>iMEgyz!cgXA�0u`nS/=[Btnw6P��, k++[8J*.ʶۍoxB?Bh +dN8e$xW(h^7g+_?{,�5;%DFf}C _pnNj1,Ϡ�LYIG5/}M"}Iqn�99Si;<%dEW .,;}KȖ_dŹ)M?{Mngw*ZeD{4��3FQQNG=+.h9iÍYO5nF߀vxWF&eByF^ %֩:7(޳�R[[{JP]Ԫݪ\w.&z Dr_Bh<ɐ_YA�?imXvF!?{6��>K$p,p'e֪;X,Uh|YB +-,:3�KgEW[dݸx�`R9Ź,ho/=ߧ_7 |ߑr˸&K?UCbl@V{>�ޞ̛Oi5C-9kVMBd9EԩGVK?!dy�uM~Ըm +v^ZɶB)dh]SM?0SO+gpߗΤ){�p3Nʋr}2k^FE5‘!$5˩%yye%`IC=ɑ/7Zj}8c�l,-ZLGvPS}f^4]ӇzҺ|5 !c%[v|eG�CCʖVҟ^Wp19v39�ϝ(ۇ2wNTW*S?mIVea3, +�9溼wt o]E {�xbyvӴM]3Ty}MW4-sU[3,|3'�K\3 茠jdeaש:7:�xRp -޻gn&_Wzf\IG%!s>n;m'Or +�ÃuF(;ˇ~oڥ㧭x � hu}UZy}zϣU6ts�RU�S'h2Bxg$`IS-Wx7R<x �مm)B=ۯ6)fۥdG!<m\4̩0ʳ Zxn5$;y,ky0��ΒU endstream endobj 168 0 obj <</Filter[/FlateDecode]/Length 3435>>stream +Hkp8$)!a $B0��%1 F%˒d +0s)ai L)뾆%Nj93ϷX;{6Vmۯtڿܼ㘘P~m.kZwi0)>oI3_Ʊ@oc3Z%k6c qYO4٘&Oλ',TZ_9V:'=@̵Nl@kPS21'ۇzEx̭c`#S,Ю&/9oE[#T:Vluv؛zꍔ|.=F'>Vrrڜ X,qIbs^^#:&ԝ8\z_:ɗ9DfxGfd}s{cx;Eq^'Iȉ뭼<frW=c9[,$>[/Z\FYQ2P +n|Vnք& k|0C w;2~nX$wcpVraxv_恽N,W/>dbK PW-W;4@jnC2`j0~ ,a<䵝PG`6*V+ylwuQMS5Z-;.%/O FJ0nk3s"K\lz|2=r,jڴR!n&>Hn90|3-c xV2nn**kEmrz/41h6:9r˲Zk7tuY?bB4fLGc'!W% fX+C8oiZmu65LN0YĻ<s黨]{jfOu6&̴J}$ s1}[Ծ3LLQ?X o12.g&gF^zlwxEyn~[(ںBKFXEo6:qQO>9Ox4sY7#E2&,\T -z:@!fm8+eΊC-?Tc9-p^f͓v:PE V}'sˢ8/ӏ+R7ͧW3lUKs[AkBJx?o8 +ĥφ#C8E.u6ɱtkŢ.q{uEs?}dW<Q\27}[~NrUzJ֓ǖr/0ym'kNPD o8|v̱I{YjO{٣PGԥwik?e!tݒ c +^QѸ {E oa,KwVW^0/1+s ȅ= O"`)8}?v/P#]_s!gQK}�fvJCT8s"~_k.Zrۇ&X'ۦ]50z<K\\p.}'Z:(QzCݡjiZ wsv _?nȟq7ߋ5+`e#Fćpmu[7_2yx@#E12$J΋6dR~5L�﯌!el}񇯹=iicR{(v3"yǝMsSk;vpRZ4so}8E})SѨ7u]`bbz R7ո EtlroiZoS4:tx7`z<?lNr^d_*hۄ^^{ ƃ];Vm5:qgG_g^2]{9QCj<VtGe +<P_3Rݩ]LLL@j{Miʸ];|\ҒGSi!k%G^ˎ$#(!<<G~>1ec9Xw,䑧&1IM8R?|o,:0{$KPQs{\糤hZ=+B}Poj<bZ 5ՙcGgDH{8?`?3Zѧc&i8|N4LKTz\ ? օ9&/9|q7<fX0y2숓|%z|94C/Znֲ|o!/zR?K\s67N)lۂrz^VSoo9!џk-SLWw[mQOmѨ/ko1`-?GpB$_B" FMvC;rPE$g0,NEK>Zi%Jg{'5U>[S6jXk<Q'\a.rܶRT4C<lЊ{jEO0l\$1D25ﾣcnPE /ڕcCJfȸ^J\lu7PZ-v9].۪e8/uTw9"(ȫ.좻LAL&FW хfjPY5*ZΝ83֛:B쮋%HE!e?sPn(?#w`e=M!b UҝkjNu>yۍ S:JߥP;qNuj8A#m 'TJ)7-rw`4?6Ոȸs<`F +4>(QuGֱ߹Pxf="h$I9Pn �jȇ·ͪ"K f$E//c7go^G9<P.(^;�}}YXJ r@6JNU paiVUbC\);�9@6=/g?Wj+M kO(O +w& {= >m +G˷'odȽh_ڳ;iAi?�mNƼ&МN_83ChOګ3Ao;s�{= 1lՋɷ?ph~y}1VI5nmg�X |v׻iM +q +A;R>3PT +0� endstream endobj 169 0 obj <</Filter[/FlateDecode]/Length 1950>>stream +HmpTO6l^0 TNG^BLZXFLqVĆ JiǤa%%rweQ@#q LAȘB/3Q5e; -{fv޻d3p}eg-X( wysoR<>-ʤCN^j^1ۘ+Dk я/OO) QJ'$?(n>.65os~5XHw4{f?3C) $`Y-w4n떥}%S kߏG玟%}GчrQ?J?#Rd VTZliL `}80_P􇮍#Q`}0ꍺ44d bִB4ޠ/[ϝg~LGs[2-ەVԟįuEUG[zeO~%ﾠ=EPGuE}QguWВG+_<8_xsewcc-j_tJD|$GjsNb9i_U~?N'*cJiAEZ-o^r?ݒc˺<Y,=?wQz 42zhZQ\R4+KWq.~ف7'^?DS.}#KWrWrCT9p2}f J($ `@so<Vv^豦Uhxֶb}3M%]'35k]Ͷ=|5٘?ztɖ +>G3Q@#3UcUOs45vZ}/GW'BJ{MFvZ.`mthEǯq{b 1rƅyb7:K$y:ر,Mϱ9n4{?GEYן)hH)F޼WF::>믒~/\D 177Əye,|ɏϔ=3]Աr<反krcp,}bc-UY>7&goxv_ +liL'7XYz$Xi{ο\ʘnxB|}p?80 Ovy0nu*yϔ=wv^}g>87@cX&Xd7.\h˞#Y4r5+=N[OV9[w, ya<7OMTpd:[*0^k}1}֢zcĦܵ111.@#3Us#z瘣aRo\?0RJ)UF x+K#7Rnub2;#)FҤ,RJ)!&iدaFH?U_[2KPl˺<YHFI!B cʵol:jo4{xyiЪ߶~ClDB!B dJWo=73U# {sǥBmٮZaB!B!B!B!BH2EկsKs=v2Mj綾fYulmMkc;wA<ans[*!Ih߳ǏO}s~|\sd5kN;_:i3Cn:秖gGZt.chn܋g-זJOB=чeI^M,}Q5Y{H< KGA_m1g4?7ewaw9zX3n\3|+�X endstream endobj 170 0 obj <</Filter[/FlateDecode]/Length 2041>>stream +HSSg𗓄 ArVXu@]+(/]PT`)]-K EHB$igggul9ݰi".`&9cΛ8{a zñ ŸY\B2:e5?Y7;/bE#yw-ou7;8??j{̬n)t"+)@WDž?X~(lw<i ף> lj~6մ垐|ᇫ3gmncՅSG4;H, rۘL"acF`OUO#82xy˦w|t:\IsOh99og2dz5kٽ_}1d}uwu=2.k[:ʭ]J p?@&Tz&-ekt2_Q<#Y[{`yY1q|woo-sOJCZMp1h'_Hݲ~y[̱=\3cSV󣎫$b/tڐ2B8?9LTO.2W&W~vߤ}UL 1[32r<}V.OMwػ jZ$gcgBuvA;/i5-n,LYMi[;ՕG c%#zV8):F\9'ט>JYMCK#(_Y#cB9xTAw{TKZL tzfWbӳ W-,ԎwX#Ea&-Ưg oo c%cFq<zu;U5?K8~OW;0P.w[j6FE)=ն1d6DF)biєol\\{9 ̆P綸x5u{wqS""0xjV=2_2-m㛢c}4'D]sGQ)+(R@gqcĸzUH82Nf۽= {uMQC״cNYJLrz^נʘ S-RCV[ew:q_؝ꉲE?CJX@ z)Ȩ|SiN.GgF"c/~Z!C|iԛx +goԍ }p` ۙ(f~<մx|xE*ee4e|J|̽;۫V(BhMDPe +sD8MW}QC-KG[{*ŒI$lҔ89~ csT?ŋxi۳ug{kBl\hv2y 1WS<72/s ~lmL* [O=Ym5W@vq~iN.Ba -Mvb9x + vؐ2K2^BѽV?n>g/_^kVN2lz;<|x 7Pzm /52h Ѵ_QA<],RE^$&t76d=]9kVI1~+ +7ún c8xQx 㥋$eeat{_gsHei<d읬]ʑ>~,)v#zgԃo$tOgVO cTljm.V(BJsUZH=z ~oRvx,xi:|sM1LxMY͏=a>l2WtEKӉCd|{k^�\1ݩNsuߙ{:$o <P!,G'e٪NXi= ~ϟ>K p������������������������������������������������������ endstream endobj 171 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 172 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 173 0 obj <</Filter[/FlateDecode]/Length 491>>stream +HN1�Dbl9oNL¶���������6V4;Dg+e}?ǀyV!>Xem2UV!~˂?fq_ɩ}\?,q>n!n~'sW?>`_k4VLSk4VLSk4VLSk4VLSk4VLSk4VLSkbYUf)VmfRl}0Ki4VLSk4VLSk4VLSk49>zщ)>XĴNKc,Ŏ]2ÓR}0Kb̽촴صbf]+fصoOj2׉b׊i*vb׊i*vP.QCtmuf̗ڰt>5`H1"]htm\|:/j&�8n endstream endobj 174 0 obj <</Filter[/FlateDecode]/Length 725>>stream +HAn1@Hb 奴aQ]7uWǻ2D2M}8CFN "rjdS#C:D2ux̥c.LsifK3S\a :44vhСC thhРC;aQw35wXԝâLug<$!ag ;36xHؙC`]<pW&27y8ܕnP#=血Gv oL:ѝk=U*~> ucrw2ЍiGgNÜ>=}Q09/@vi<W * 9 *朆2fdi(ۺ> eZ!s4i=E4e=F<2aϨrW_Q1]$Ā+^rn'q]NIlt 1*HGt Q.KNÜp( _gVe\_Dö*UwTktְڼI_͆]z7l:Y<7l:lݯ8l>)m[ XۭJڣimWHV^/<lBi.Rɕt?! +ƸWa_Ẻ~؆5~6Cta;vZ-�� endstream endobj 175 0 obj <</Filter[/FlateDecode]/Length 770>>stream +H0 C)0`R~,nO" +=Ǒ d3SݩyQǒLu%DM63U FN64VXO(VfЗMUu,{ʦZպ_Yec]9{qec]9xO,L9>ln4N!A[675n >lp>~F__68Ys +d:td9.7!뺱^lXF z1.Ot@EsFz2-.ˑmfqx@-*�~<9_˅t~*<0`]nϲK8rz c>^<ڄdzJ%,o>vPNGWzcGc/?.fn:vT>c[Sn?Z]c|՘u5^Ԗu},7{QKJneh/ +4 +=w]XX. +etaa.,sхz2B]FV +=w]XX. +etaa.,sхz2B]FV +=w]XX. +etaa.,sхz2B]FV +=w]XX. +etaa.,sхz2B]FV +=w]XX. +etaa.,sхz2x � endstream endobj 176 0 obj <</Filter[/FlateDecode]/Length 630>>stream +HAnZQD"ym)EUgɥUo~o'A> +,*t3zйB> +,*tk-Try ܭ�[[#�g>q)5T'w23E +|/<\x(3SGpr'=XTO]Ϥ +Xa?r=+:l_@:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?q)=XT]J4cw҃E^qA?vf#4CG hO]䧡˅G>B _s/nD~n妊["!z!=XTg`i�#Z endstream endobj 177 0 obj <</Filter[/FlateDecode]/Length 597>>stream +Hױj%A],d] +u0mB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~\aÿs+`Qv+.`Sɱæ<+:lVh8§ +^9.|zM'o8]+6lwKٹ"`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=X>W� endstream endobj 178 0 obj <</Filter[/FlateDecode]/Length 2379>>stream +HyPWpOh(,f^! +PU9DeEQT@f`@=mY/(5 +(kUToa&{ȼn}>U_0m_eu"ʕSfiY ."Uj%b< r|iƩ^)41wMlaߧ9Ӗ21a,-�8\mUshz\s})/# R;1\B:A�z|#F~4^k82UW"=~t=�>!BoqZ_}*>嬢IeXԳ҅6߅SH} (qy[ggV4<d(m�bP"P }ޜ*曾!roӒyW ъgȉ371t|T*R?p<U+~bw-}�c!(8GoӦ JoyV; E(ۃ 2< !g"@oG^gsy4ʩ43#u�#hI(|lJV-+EvkMPȓkBr'G 6qc<ޝtV?B<2j= B7BXES:s{�7f}Gt0 J}:iogRK7f@ ư%s,`hYݮUREGD�kML\жmCғp*.>͗uk] Bү 8oh򻑹顤3@(P)fde*ŝ<IzS~u ݞ:v,4)Ztt玏%)Zӈߊ\W5[}~dGL7w/l+<ه|Ť3@(Hcs,s/*(p垔:AߍSOx>lJ\ͺuF<=P(9}Ĉ �}Ѣi>} ڪ~`Q}Aw⼑夳@(89=%xy3Sˡu|ロ5Έ`�x }--YxH٬8w�m~~3p% ,^4tࠑ4Zuzწ]ai:Rio~Pn8'2]{>�̀> 9:-E~ZRZV%ޤt# A!y8R#ùtTb@!-u}>i2\fvvxN;ϊ +3F  X뇖_-K;Ƶsɺ5kK%o  +]ᜡHg(3ieJҶmF~Ѳs:![VqS l Bҫ{C C@+%넒3r|>jyMQT:% n""Uyts9t<1Χs]>fݭBĻqjE3YBN%o¢7 hYN[$o*-nu/ZTC~A߽8Wp,swN t&LIs:`f/ùP9h޲w XֺR(s'ξX5EDA}] 3Hg`N%RYs&3]? +sb$QN3y34Re;ώ*e SV,=gahRQZY71N</w  h\q"M "q k&9 7bFr,hif~AVݮ^)IrV: + ?j "c5ol?F˖SgF)SI/vf1nDU=A/]0S/Hg4�pr3xK:_g&3m6YCtyY71Cgg0mO|bX} N]shyX)W@A~y1OdѤ @HGp,s/:8f + + ߺFhcI\�vbR۬p2:ʱY~e?Ej]D'{ A߉$vW dL( +QȪT;y H/Vx,yRS I=lh;sivlV)o(_:ZaS$_J.Aߋ+y-MO 0�YŴ endstream endobj 179 0 obj <</Filter[/FlateDecode]/Length 596>>stream +H\1O@ +LDZ:[o.<,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~8]+6lWSɱæue#�;#_:O%NJRtؠuxJ-u\|}?ow _G>{7-ί+ +Xaӿs\4A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=)� endstream endobj 180 0 obj <</Filter[/FlateDecode]/Length 683>>stream +HQkP||6pn7U& +Cez844*.i}Zke>ޣ è)V;U!Yz^Lat jeG|C?`IX><xa?"j]Pu1euvLUGt}= +3ULJC{dZ +��7[ 6^v)Uk<(/X{wX۸7Kg!7 hh ޸Uj8 9An~5Wp{\~x՘?bv?iƗSApTCrM!SY?|}W'S񿹢~tet 8~X*?ϊFalynH\Kvn3gl݆yy|S&Y7dCyC}8w4M~dR*xPwO}&}jG ���������������������������������������������`d*rJ~/noܪ̊]ޞOr1+G'/8M?"''d6fYɳWտz>+4٧-V)%.}~̋lU.,Y-RI}x �E endstream endobj 181 0 obj <</Filter[/FlateDecode]/Length 2046>>stream +HyT!hBŐDhcBG$ZdZи)`DYgAP8"`%6A#X:jeHNmy~!`2gOI'n162Cf3]ȶd{DduE%=O^bߴNPܸߙ21|=B8\Y~`oKh^tޙfr�)_SsI7QW]F{`xE"zmm yJy_]Ͻx%/$^A!4:TpJL,SYr|xt8}fM{{i,w;Z@ߐ}9vS>FT}Bh~V#M%,,S?ݿ?ǰ{XBtTf}{- 6y=hƍCa:Azߚczq&A!4·r,,S$!7J'(:J}w˟:yZ6VVyOJؼy&'so\cW _W2Fu'~ Z,/h5$!3 dL fg禎_Εڵ}&;/QRxcyY۵juMjJ#~݁BhK5?~wA�)ffyqaCYɧCw̽N:A~m#v66/Srd:ˊھm StCQ7wB!|({X^Ȩ(.]?ccՁ(Gv[27{F^#>M{[[ի[&UF'b_w[5ۮ. }BK [~I>t]?cn|W'CwMOϴjep' i̻e7?Z*>kYMD^!p =.׳;�K387a8Ѯ'GHeSOӪEX%ن9~fyHS_sft BM;�`M?*CwN_S2Z,=d)>4oDپES> +F߀Bh>A!';�`^VP~Qnst~>"޳gF(cղ|9JuIQ� !iCa)syg�0ŵjiNc[+p|iѲ}LZu~ŽgQ?�B!|iL8 +�K`Wje@Mw\h1q?v&>7%=skUm\; ?BeyY +GSŋʮ-QCwнɕ9)<މ}Vר +kcg׼tstl!A99j%#̩0ZCQ1AmɣyO#pCo.:.7t{|紧!Z;B!IEgpl1?lc=xxuզUYiAgpL~kU XϾqVޢzRI>BM {?Y.M?�0s߱8F~Xb:r']ݧL=cXΪ85eVUW+(o7$z%ۓ}B!>d6}exg�9bvz}'u]k޳&OmJR}t*酁s6>3˧^cCr_B!4U{}<xg�9:x'VͶө]?}"(z}(~:uqW3e. bo@!E`EQ.,ccEjWv{>YE"zm+2UjE={{W/taxgd��!; endstream endobj 182 0 obj <</Filter[/FlateDecode]/Length 1182>>stream +HLuϮ!Aa5ʭJ(]j^˭ R#Ksf!QC;ywp .Y+(JƟݻ[ wH}}}~_+�gvZb\-߭؝{że*Rv+!X>59Uuvfl%ʛ{[Oxm o\hJ6>e&ZrZf{đ-E{ㇶ(Uo?�01Ruvω!ּbm:dOU`L lX{@_7֊ ZV]`Xv]ju=}S3n?u% lVn �ьd/e}?x"\sj6~rL3)bV<wU;~gWo~/_woGM?s�0O^7'Ȫqox^X3fRO+u$Jt葄lKJ9?c�d˾ϬqۃAAn/鞍��{|}`o!'ȭ-Yj֟>�(Pr˜uDA d.W=J3��̭U{}s?9F^W7]$��J~5}LA $,*XOOT{V�qahMM=֠Z?-zM[K��pid^/jٗƠz?[L <{f�K35mxo !HCyw{z ��fG^ߦ^?/4{/[랝��`v&O$>Oڙa}[? /F:v꟟�� <{|Q~?Rv%/=C�@x&z {<9AH1b0XTԝ꟣�� 4ΓuͲuBH}=ol%F,��9ו'{UuBfsEUu8;mSS��0=^o !QXFy(3��Lo(i{tBf#sEt8#g*��jnߺo*� endstream endobj 183 0 obj <</Filter[/FlateDecode]/Length 1249>>stream +HOUuE +LB +X,KMk5gKP,bi#s0&ʗ@z{p EHtRie^VE#9%p7k{p97A/]eG¿4MƬF#c<z1ߓbC7���%:@ŇU*?'G@Zk7 ֌>[�6ZM|wx{RJ{`U}� ~rN +U3?Yx " -Q4X7T��`۫ڀתw! O,��2QL睥T +B')Bk׮(R}�)׭,]Aly1^Ih0]jne3wdǯ +:}ˏF{qL��o[I8A5cj;Mu?Z}Dza=xjȪ.ܷb_hn׮J>s�v#A96)T=&?+#7#qW?Sq<Jޏ•]��'{*=z7YJd1ns9cG%ֶ>{�Vc]%-mڰ˪w=�AZ̿,?f['?+?�6?0Mޫޠz' Y*9|Vq]cU+mVOq3��os9<V1UbD|&s}cviչѽ&Q0��B]:]@Oa'9n|nGqHq4V[u6` ڿYthcT��x;lêw=Amo#ڵ!T!|?*6 +ZO=hg0J^=o(Ky �;#6/Nܿ=A+EGm6 =6̭k]eGUoz؁-E+hS}&�& ι{S_;=A~~Y{.i-Ø?e��<r~pKg?pޖd~sx[_qycn^]Ɂ<��O%笜rzD zM|.q~vue&Zo3ԟ��x9_0I+?DɁ<3��O3y%YY9oU|O +=}r }`�xU endstream endobj 184 0 obj <</Filter[/FlateDecode]/Length 914>>stream +HoQC)P uIK\B,H݉bA !hnmvδ3AST`]km$|}\bL%�X{kg[fc{ ن#߱|]klԎv{)Y|GV� gJJjw?Ka`) ^~�]{ #vlv6$b^{ǃF �ܿ$*~ .;ˋ&{uT��ݹlZ6`&Z=k{Ev�`ϤWR(;4^c��HJ +iw-ĥ?z/c,ŽDs�mZ/ % Om .7.ϒw8H�`/ޤtr?Ka͐y&45UҾ��IuM"r?Kaݪ# ׾��ݷқ+a"0z[�+GPvۆA\ +&޼,�_?oe]CFR3 ה&B7U��Yndi<Iojwĥ?o?'hx��WӒlIKζGjī˓Hg2;�_H/&cΒ2Gj=%M59ڷ��x49G7iwĥ?Rڙƨ +{�jcc;vRw$0Pws`�@[wK`bnO?jwĥ?RD]O7}��HJUjw ĥ?R+p〞~\}�\'}8>#�wx endstream endobj 185 0 obj <</Filter[/FlateDecode]/Length 912>>stream +HKKaGUiA$TlaYFBH<A3SF <Pe(dZj;fX7 klOyߛsyϫXo)RV=}Y0~{ߵߖe_ tJZ �@jl}MւiG9~��׾lW-d-?qT_k)���^06R"bM?qc ;-��+ӱk["bM?qTuSc=��mǍ⳯)_p0MpOVu^4&��jyv{ ֆiʂ9}߷-M��nyN;[)^?qk~U ;wn��ff;ݸt{5`ᾝ5 X��$۷mv\<@Zq0Mp_Fei +?M��$[@WNZq0MFt?c%[�@xToletk5`s H=��`n5vܭ:j4;jKL O>WK7�%i}ՎiNFz?+��j{{J5p0M֊@vz'ڥ�=[/ok*`@M7?*��V1Q'<j*nj`E P$؅Q��^o&:"Pi+컿kY&��d˒4ۯ`}tKS 4Lh {<T%��XdzPvLiGސ)��~gf(7vkŚL醦ir2*sns]q/�< endstream endobj 186 0 obj <</Filter[/FlateDecode]/Length 1198>>stream +H_Lu$mJ%ZՖ2\5p"F@1!iH"H̀ ("?8砢hA"Qɲ @ɮ TE;?9{<s>ǖ �`xJu{յ}r׮gTh&AQ]Z1z>Ykϖ%�\&7I_IoN+b3_Vq 5_��Iu uwU?oCVϿc��i?/WzJJwgZ)&s}\�`21BLާU Qϫő6]�s姤tw?H5+=al=*bvU�`pTRVC#;$k/;vgS'8²SmޯZ?K;��5J/I?Hc@Ύe+$IyLw��ǥ^(] Pum+x=n9fSl?��*m݉ =Fr|hѵc1/HW~{j~�X?Gtw"?ȝ΃w֡>c^Geۭ��!#4Iw:݉}rlK 0&C⪩RW0omQ' ?wTv"�u 쟟"rw!c۝jGJZB6^+SG3.{osmuyezns(`^/ksٱ6Dw�Puww2yOc@δ&1 3L6Ϋg #0J-~V=n?_lLK��ޑ݁?H e}ԋqoe֣Gʒc+"g[G`ӗ��5ѷ-A&`ví(iw6u:*2;J| ='�mSu^;WwavbLʊau{T=׷E; +�`>W_-=votwf f +~{l`�+%T071SpXǁuw�<NKH:̍Aqdk籧u�Y*Q7�d endstream endobj 187 0 obj <</Filter[/FlateDecode]/Length 21278>>stream +HW9] <cWy2937@_=x v4|f~[m%Mo:e\n� +?v_Xzζs *�mYUs vzUnXTZmUlmKG'̖] Y!IRo* B7_,2 43DxM 4:[�8?аUL vE +Ub+ NmSs08r?8J +o,k:1AƯXbFx 名�`zN(}[V=匧&=֩TXw%Xw_¼ڜ +Yκe{t~&$6̕cv5M~ZL . }U,WoWXtʻYQ!IktT@b怘w>WS_acW˾ǟe?h}i<Ucqwd0 pA֥Z=AYV1w àCkBŌ , 0F6H̄+)djaa6ZTX+h,Ȓ@BZ`Yu_3yln�TY +V9°ZMX(B9GuLHj{~NtGOmY +5Xl0!e>s`pL*' +"$^E {O<î\HF׏z`VXZQ +%Nb:xI'8BQP0=7>W/qk 8ɺ18zNtVBi R#*VBh @;(ÀSO"Ut"{X2HǶVj +Wڲ3>Uzz~f"Bp J0 ,P^  0j[lNz,%M_ ƕ= + L4ŐSX,J^OHMÛw0m-Z$ K' +Ԕ/Yz=?({vSTjn j4 3M= 6;imGP!(yO&,Ů1c[2OCGg&;-ڭ@ @e6smJN4Κށ0BIfyx j5 н"qf  (]I*Fv.8vRAA_֊V3<7RK*?ymna~M g.�NNPs11ȘXyX'0H\l@vˠlsͻB%.,& z U@6R�i̶CwD&}UޡP҉Eg]8*8F^X 4흗&8 2') hJF(+kS6^z L2o'X;"hpkwҪ91Bw6| y5tW�7Q)*r}xeStS@TNLj&/6?UC/[Z_TQV}2ޒhf/bق9µAGef.,{klaE +eAve#&|կkg,e>j5Zj,v*HaN>$PzR쫨-%w+̢Ш u_"n6]X_(+i5>wҚQ}dOd�z[q*ĺ.-[-]XMnFn!8x^ :j~ 7nG彻 #é`!dMo'a|Ԍo{8O6[Ts/ъQQLX MRA_<xs]s |чΞ w0|#u#+z>lW߫@.t!S Rs.7 jP~/DHo&ʬ9Җg΅<#w0*L2ҋxʝ:qBo^:Uadu{iԜ>+f0Lb=pr.dz ~amq17d%fRqXk}<J"h_ Q|ݡ޼ i8Wag;!"kVmywoǢ) +eO`Llepl$]A ɐ[= '> +Υ)0d s><iRKY~>[18^_0[=! rM�iv0y?)XS+bANwj gR\,MvrrzWf@➳＝4ɽZUUMJP:fn,[[3�32ڣva4g<A)Q[pPPZ<bnvNmLfb=E [~?g3C)@z@B`9 +Eb\VXx4ȚK^ +z]Ӿ1%voՎJrNwQ?8T +}E-=Lb@WZ#$xh[xSeczq3u}ЋKt/dg d +@›f %MB<gDx1蟵4w#Û͓}%nmޔk*Y J`h۬jZi:yїfJյ2rycZBsZ;mb]h/9jR+Qɶ2jIʸ ]^Y:]?#V� D^<`l!\7ny5gc%E4;K[#Mm<q#VxmuK . lq>cQj8Tw 8`9b)f`J]> Im ]lAx58p=.?ؗ++g>%lp}t[p� +;;Zp? vi0Vyw 'iu If]4Tf'I- :K5? +Y_RVShpcY6pTnR{'nzUwO51Vr>ҧӸ�֜!8|PtYȸy�ɚ}=VKl6 "H`CfXgP)_=S,Tczk?_FG41<*>9Av\T3u &k6=Wv; E==b LMa{yxǂ0>j 'y�I0k1"9 --ZMo'롴B|)Y"pbO2siYF&HpA89C.{gHg '[z9|Y+quB`o' U c<;ۦw3RdE*ɓ}60L^owf)'=bEB{g6Α0OA}�-QH8U*CS+�fΫYuPc6`rb�Gp u;fh;loդHkSF,Z uo^JɲZ<M;0DX뤇BW^e9@X`i/3JMSEԖ6liV 3_&t"bO-Fg.UA)Ec\2Sgzœk5ub_.BtTLr޻0 %a9$@ N3NT%P7}!8Xƕ^m\ ijiΐ +^ޮ,#Eɍna| ,FYق�gTeҪn|3kdIn9:}K@i۝)g+vd:v@(+<SU{3x-[ _vIW,v_%s|<o,|  Ngˬ}}%~-[0g=X儧3u M1WmӭdLl3ƒ9L9j`nlj.S姶D,'>o#ݳφa `.ii?V1^mO YrkjkdwrWr-lN1i.Ru2n+G�펒`k/#1>ro$y^m =_;)K-hB`zS;A%}x�Y0EW9t @nzxWO0@LB# .>hyMkWG9"e r;k<P,´ooKxT%K2sߨ�k܂J XZۍx[#93BPZtD}EwY{77ߺ3Khkט& mU, 8ȥ�p:_ 0 ^N6螁Vծ;?c;Y4kc.p ,Xx |d`Zsal""{|JCHoMiU8`p($q2= >< oNvj% +W_ `cרK1:U]*`8;[IKT~)gEϮ(oR᎚kmQ;>xZ7%�#\cw�&&vV?~"G3 πpH g |zao XfߜEY($lh%$2kmQo;nSmgGwp>z�kt� gZ#W8&ɽZ+|l툺Vf(;39 (#Yl +f8l8m<@ YPs-qpZzS5~rN>*b:Ú%"lQ{ѦUv匊<*oZb}Nְ#_L@ F>*hs\j6j+8+{i,5��=Gn{@ +*@oZD(0f~ U\.~vv&} Rս@@>$zn)>tNMRcQqouWX",%jN4嫦Մ`* $˘>m즗۞y ,KcBwjБ .TPk/Csϲ`]lخcYW00dad,}nͮKg,ӭ):�75b�zmyК&_b%A +l62kcWyl~^"D) }> crGT0a- +xN;ȵ)7yٚ+kraXSǒD&{VgbLEg`I8:+0x+4b|ء4-t%?viĿ͹ۣrjw֩}s2њ,%}DԾp 4z'ۢĠybDwy,l|a-Ud M</HОMyskS.()yc 53RI^up/2 \ +<M;6 -uݣm@7s]azEvAo>&@r 80${oAB_)+QfH0K;TGQZg\~ڣe2R* 3Z# |'vZ(LzLϹ^g^ +ژ1�%h�seJ5]JJW�]U- ^S rhxZP}p&ܰrbC_%(|Cw/JWIz΄OB+pp l,ΰ�Srb +wG0Tz!N!m*ZETmD#.`SߢdI[y;  rBqQgPd_ `$.Qˮ/mu|L&`!7�-c*p"c]!OaqT}�]P +8`'?I9gh'į;) +]M d?hC�w(]6g-?5G0н�%P[UjX,pwe^Tv-8Pb-Aaʱh; )~3)ZʲHƔlhW)gǧkK`ZnMa*ή@>k zU' +p ̮M}4e|E 08b%˭{MI%r(Bvca|m:zmMt4ݟS]_Z8UwwL}Є$*XĠڋ,$'e਌a= FG`Xm^`@kgs山/H +r@9 \0~hxS|&e B>KFSh2aFK]a͊JRvP\#}يf�_Gu9;kZI XNmM9+a׏%P?zMkF˺66#%|hfSL}AYjC$XM g%9";b(O{z63<vb F̰NB=[ٟ5q҇ �b\]Vw+A0Fɟ Ø-X kŷuW9TRVؒդ2rő3m;_�P X[UDgM&1G]h9jn<=(|>HHd¸ɿ]}dcr €iϽ KaY93na[6ua +藃Z�b�'%0e@J1 AN;nt$qrb.q1j7w7r}٣Y./[o4osˀv �NИl5dR}Lx10|Z:xmk[ ew<R]Ob{S8ʣѳfm S }ʭ>F o9anmw*.k*Kv1<`aSՐ lt!+/ ޵dۨ{~o>vW$4j ͼU|"ESrE9eJl4Wy]@r@5 !ʩ=vQgcEFpΜ5c9kYL02@kQYM -O\pRf[tL)*r;cWRdvռq:o" [DO{;3+KX]e21ld䨶d/rѪf4iVYJ3o]xnS:_i ^/8ruU!mcn28=2J1 jK~ϼܾhC$&$O!}1ɒQ Gޗ~l|_sLkf0i.)%ObUoz %U9:�(vRG}i(-h3tqS3TU"N즳=KA Co-Z}�x~hį[~5:wJ 2q$=GS FٹlfT$omR5Nal/$I5-ɇezŲ@0..w}:rr#z +$+5ߧ@T2cPDM Џ J#{E7 +1DH\'8ɾck|}ڈgq_, +݊yskaRl,~Š/ē"jq&ץ= ^4 .GA=yv{}|WI%) İm< +WYfO0Q'r,ɷ:O*SdA;4cH0X +O՛֛K!u~b[_o-N)WA0~{�&Obg\joN%x9a0 +&#Py2}H 7vYu6 Q4tK%gJC(E'_bTZR~GA2 Bs1ڥOFONE<}.'m%l,ǰoOGw7tѽEV՜^mH',:)<CYY=Id? &cX v4=D]X ,'\ J6ŀldgs˵:AX7<|XDm!/j vb`<=A(Y&=*zJ0 w,y +ni8JdC!ӷоj,A4tK0%BڿD%@p696H@|YNGj -taM׏oj͵e=pJaLP a=e79m$V`^ $j!GjGmٖ*_ZLȴVwh URa C%UXeP옋#$�OkBo"3:u]`% >N ͤ<|'-{(WKf Nm^ym[K`'"\;ŖA Ԙ"'&9``Wu ovmPȽYl LE.Bk}EoaAT=-ЫcܽE߈TAAS޳2=֙T4+[5~t\}h<TKp4C^@eҵa1.|~%'42iُL# XdpT)5 RQEZ%XOag 6Ϛu@Yfm@bmfEnuosXW2 ӎrjI>�%LD&y!k)0"HQާ9d}"=&Bp7\y#}3C\7U +s+G'MN,Bby;;%)iR!̈jybW_R7Z3[2q>kgOz;ҵQn]xۤ& q %%DoROS LLHoo5O@{fAi-3N% bؒg!H߃t(c}`wg"Dqvf<x&/a@K8myاjp)3WhW3aU#^Sĸgn8^9s3&; ]mbOsQXFfCnPdq%Y! mQUs5AU2)Q7K;' +*[͜ѱ3N}[} -\fؗ~_2ોCf dDZx&T"C,Ԉ8l~0v$yz*CX鶤KYAH۳n)!AȿT("?Lٝ(Ѳ*�au-9S&ܧ|ڝUb�$~Ga'(ů`697S|TIS Bi %j k8cv}.EcԆENZ1m/ж f_|U�GoqB׏tGa]]0؞Z= qE$.`r~n%c"=9IYx`L֐؜OcDPS} \0qME.!v:ECW;`&"Bn4]bp+;l9kC dCbUv]@5}=TղKqqbqo:_^!<\3YDXU{˽ɠ.GD zVQ + Lf,=zwn`RZ:G헬`G;~Q({dz@RI&O!؛z->nzV<ƭ 6>p:P]ak+UA]W+K̄2I$!հQy=K�̩nn4_g^+[c(ϙ_n|.g? X`x_!$Q՞p{ţnLuno.:^Z537 +>~ 3vqT,orv;hJ!jq1,/0ggy%K{csd٘tD + WN:dY�Z.zhU BWRl[ڼkҵl.QeG` |J^?7h@wYNw H1)&O`R{ج~] +AzV*c&[ZPvayե{NDv'dP62NvTB#$ (� O{:hJz @?;Wu\gƽ0^H0I! %lx`tA+`tW +#"6hyj;ikoyًe*m!s"8zNϮEd<LjKw�l "So#8וل.w`eue20 ]% m]#`aJ-mXHzEu^uY�<_z`y0մv\�b Дf"6M M=2D 9cA=]9m2o7PSB?u6 ϑ~`H`HHZbceϝ 饳) 7<=o>m�h,Lѷfqy2#hp�b mŁhqgA 祔7tՄ퇔 C*s~[1ʸ8L]^u c�ghkR1diKp4~gqOr֐<jD._�M)1Ϭ-h&WGGa"Y2XOc룜)!>fhrX߼7cR&9okq lCeU8-Q&܃Q۴r_]pγZ1bv�37,e9)8A+ +OQe vLAOfV2滞ŚwQ6e%s!,rihq cVƞ!"HΪ&--=ήyX!s-'!]v ;n%gTZӫ'v)j0(2)0~ߘ,HiKnkėn`͙mQsr�$je/t}H847*!9uFDܚ k[f:ώ%p Ol.Xm4rGdTVi"~L^M�v -4 ^[ђ yrQ_]ʮnG+PV0nF+\/s\Xmo}uz,.9 bNpܯdܢB},ӂ"Vk�`c\)�-,@TGg)@i|+# fG ;;J%ۧs"/z ]d=-al'`\Jm2`c r"�Gd=\FqTGaeai 7uIk˳{`JF2PE\>tL�rWa6)N@|ٴq[f,)qt_jӝ!<Y_~ &d 7bQܝtr@t½ZCWo~c<PwRE?Ϣd]gɸ gg _:}/GqnB4rBnӀ> W=՟4x72T8ڴTLb2 V\p#K*d3D;x`zJ{T\Vbj0x3 +tْM9AжMSOhgj۞ulVS Iz\.6LBz;c&`E AwtYr J:or.qv5+(fi,lS`ɳmU +VاHʫ?+>Bo]$LGٺ19Lܔ>S轢99? 6JeVA ሇh¹DuR=MԆxsCUtn]iӉ)4fC7+="QnUby^js-Q\bJ9u^1+W(b?Gӏr0LD9r*=2Ѹ~TuigraVnrٹ1Q&iʰ8}IW8QzoOo�hS/܌=ЦF2 +VЧ[Yn[WƫuϧT\�7z. v0ndHvV˩$>;vy+YDgSE �Ul{1[fePbBFNH*YxA,><t<WYj3P~'~?,ֺ-ދӅZIp7a<?B +"һԜ;ܮtw*0Om+ȇIӀKΠ7مqe lH?pV$tW3.fX{VgXzrq,o]aRDHs52OkkW[vkKَG;?#> X4GxW6Y'/ }Pz?qVڙ.:,t%@l�8My à5mSd?{ZPk.U;OW%{z5i6Og# ̺W]AQG\X;{*w܀q߰(˕쵩%^~9 N$A]y#]%i5gƈ-@+#w$ĈI;E�CN x5O@37dr�RφtC\ߓ~ 'sBY�,wmScX( U_S3fU�Cnzg<rv'�EmQSwțvyu7!@[_Ώ7yaߍU9C\B@3qT ^,Ο7=';x-96_,$q�"'<̞ǀd� imv9P,WL?3<+ ݻ8d{m*AW^xz� 5a~H˸+7_ՅcXr`7JxSzס ~B0γ+=g,AQpIN%nB\+RU�>TlW= ;a/*Sa_T9EzlǏHHʵ2csBm9$p=ҝ9UEy ݜCZvצp[(b9C\,+&A�<5�nM ,tt1UTͣ *sϐu2D)1zW_ůw*on>A%Gcu+Y]w `B.[uqy@:dF- ! '<;_=}#@*Z?t^ZV�a?^lO;ujccWYƊ?Q%z%0iz,ƽ7KfD�C#k,͓(n0"pGa!i[cP tZא]*EfSc[gtUڂ +p B[.[U|]ډp ?}}0&{*sm4)qB})K{</2Ncn=�W6*.'#NF([pzGT0FE@$xL�6j՗*s̹EAMDzٴV2�}It5*ՇYt5jJ*6<ii2L^3rjub�cfa|sXPk}gz21]WՌkoH]Mݚk& +*GqTWmVlz˓ X7exv`sD?i7 *<@_Q|c�lb̑<ɳ,S툶 dE~i)67(c<Uf +ѳkgt(Ϯ p,-e%W6L5EAĸX}bP#ë,xBBC.g愭9UW2c <wD6'(,n+em|2bW4lmihwd ykq+ ICI{hWQrB"e?1ڡK$ۇvM:;D41hG/G٥>׾C\c_&�8}CH.�V�R yA!Vڅ4Q7S bVwXZmA,WmQ?ߋ!'kaМ Al `l.k6Ww&;v0Y +9fNnxp,5\/c +r GIc\Tls1Kp].<{y@-6ݵNyhwy׿'|r:<rhAXK<<tdߡξ)U׼{(XIkS.; +Xdo +`oy9F+An,>| ԌϔR+-ZנrlgT`^ι^w3g;?˻$ZS|[F`[ rb`Pc,oQW-F̲jǵ哝gzj[m* YŰ6:@>4? +&GU$6uhL'@o$n29GMS-5%D%:G[~ %ZLK>3d-0jI4ѫVMP6Own2LgU-1eD&Pc77al/fX!J\&n+bggOwI4T˵aƠɄGŸ :w%%.VeZa|`Ƈeb^zz4bChM k!uRƘm�> ?ƻ{;Ú;[:%+{{}5[]rߞVrݷB�!#<6:�Ae\"+ gHٖп1~Oe~ȶ1ޠV{- svV$j asO1=TN+*LɟK6=J<zGѦS(ם҅ Ҧͻ܇:ͳ�L OR{~|kR/m{AfR{fe/ξ֢A34,AxHRQ%uK ~?r/(p||o{+WsT<o Ypm~xߏzk-~5rxgYPvV5h-fG֪w7]gAƨV[! Wm \*KQ'[Znv^̔AŐ8-%c,bݭh?>VBP37st gk]4@T r`>{̳=!j<&�*qK +[D2OW?9`T�e~ksTޗVUivʭ b>.ðg&�c)ʼa%:oiMG `8;:Ii̩J| m֓7ѩG* UVZ&Eۆ[.m&a1" Xz67\[EHJ'ӛ�ӋqhKj�H?�$[ PZyCJoN$5o%qɸw{m�&Rq<[R0"1sVTu?,8uݸ- 3q2w9^Y<;)n�`jG,a+=t`JJvxS`ԠUκty(2un6{g#`^!ZF\X lOs ;.6mijVr³r9HTDF +Q"S%5 '3)U:paq'ް/}mXlOm-u| jQ7 E5dLk(_|.b'Õ)ΖpJSNDxFU.SlBj65ٯ[$7 p$ń<Pג=cY<`%ѹZ̼Fׁڹ&L|Rb%7BIܗ9e9Ġ-#rmV\MO7a7͇(aDѶ\M K\fPT̨8^hM^Ə!*֐AՓtaLJ�*CG�c/v[KkE 2vİB[ٵ%l&E^7+b^D[ +h)Md VաDבAWGt.,D$ #!ϖ.@)ӊPjؠ x6޻]G�cLZҚ)SmM7�Όo8Sx>5$49 'KB G0y]x@oJC"!Wc֫MiB[OЫ X1A6T]wF*GJQ^L~-n⮬p\DMl⸹6iS<�T7vWv�KR't[?'�{]xV=4'h,b1 +!5~?, ؑ9 zZ>ePv$;@,)7{/]7`#yJM{QTjw9K^ǣFf-lZA Vߧ Z;?fP)2Nԣӓ<O +<[8-XR.O\f<~>5RA]1DIs! /ϚB 2"<}$ŽbU=!gKe+wGOG#B$`�g�ZCK/L鋰y;҇BXC�tYmLڎo-m٠q|=D#14@-…ZApva__&<ig OiSyH >үY5 �-CG;LBlFV5ـ$\�7)*z-YQ�3 `yYK+丈ufIz`/5G73'yTk+jkh. +1u1m�ԱFqg4Q iKg?"9Ccz>\~|^RI3$/o36Z=`V >"p%KC}_ISbyH|�`AǤ )O?4<ip6s}1c,_߂WNlX>ݦ@∺o~>*a)һ/yJ:Xc{c:r3':Eu[PlLLtVgc]p(+SQCm khb+!~_lF!>LLX6n9Gh2}7i?Gɴ[ȧIur~AxqB倵,]s�cn)<Y:{l%XPG43BuK$w$:^M-/f6^7 <G�4D4,&az|xm�-,:,=T4|c\Ӯٍ)#[g(J)ĆՎT~k$/Y[oTO>t̸:fXG +cEqq2DwU9~3�_/gjs3OJb +(G5 v57#PQг�~ +żY \\plОa�BG}fZlz +;#Kbdp f<fJE|G[[m$XGʼE7'3^|ϸ飧sbWَ*=KtA?Pp[#.tej#^<ݛjzDAtcg +cy +c,m1v jd0%`q+%(((7j#_SLpV`rFI 򬀽1A|fs~^SX]?%CY`r0dJcyJ8jyL$~Dڃ3P=j "S 'h + !KpmkPA]vLͬ^YI80c� MF_*6Zߧc.B9lě_.owš첡Z!p @~Fz^-[O�9 ;6+7-H(=%C^̠RZ|I7UW"nׄH1/S[rG(cК3R5 o&>'|މ*Y͙j N"=ǥf;%8 ~MvOHLj:fY(nnB'2W=3>ۅy7Q;!i)�N*}lxѽ~nU +|"fQzd}^<#'F h86aț_j|\#ޅok<Lթ-:4.ڞH%,`d?|W=d,\ieXR0lI>Ps9ٜܩ(hy%w bQ2/J9Czv+}w}e]ux)[̴:nOuV sW&GXV[IJS) ֈVWa] ^ՒюQBMxEխp&K>7Y3#Ұ (v;@1f4}qC<.K9Q, fƯư%zqo=s-MtBb\}&y +shO`uCgWf] ,_=l"^1{ut &̙u6ED|2 ;eB1ym[~dJ. nifbI"WZx˯AZ_Jx|Ǝ+]ZޘۧүϱUdpkЕ V, +kDUA/M<I/$VY;?-F֨8w㓟'>{lL1<E[txǶV=�.B0%<~1@= \;Q#5>l&4XSUU#8Mq,ؔN|Q:<PNz+z3�B εm+<&A63ep$^c +kcrS.f AN 6֑,rdaT�^S֚WN-gV cGpeRsR({D?�Ľ/hA�MhMMuZ[]µ*zx<—ZÑAW +̚16:uewi4�{v'9+^'_J0k@""k&6:ۗ TsOVAۅq:#2Jo�⟢?yj?l[s^@s;@3v �[r<ۺԙ42BiWd +bsufۗ[GZ- ZX�ϩ[zXwTE<L/[Zsøek3h,4Wn Ǹkȸu xj#`- +;za;92"kֳBG覇0SIi3[ghCl:oQz|ge=i/Ei*F`GMMw8o[t9DsԱctpRI}mWY{!#Ym]eL2}q`ǰzJWS7+BŦ(/z^/& +;ER Z[cq׺Wr}.*-]WY=+ e-N<a}e+%q +,l{B):X%A j L1i V!僀n.זpnj;CfO߱)4+Yy9s^?vvC-x[ w p .(yiL8=-QOn�?2x`\']CF/ CMxw|q3oyKR@L#c� 9s,ěh�1p9E+ +L {g�Qf~<v/n()tk)ײRϫ7WS�8bm֍kƷbɪ$%. +ڠN-FТUxIb�VY5CnOn#3yjΌX=R5'Y |nxtk�],gO Y_Xi#J\�a-43m=nu,إx$?v%g x4Z:Mv�?ߝkQ#T)[洖ʲX@Y|3n%Ŭ0`|>8yh&؅Mjշ V"'VZzy p<Y57GW'.x}n|NÁ߄kEn-<vm܈}D/� endstream endobj 188 0 obj <</Filter[/FlateDecode]/Length 918>>stream +HKTa,s((\XmD,K&Tt[ش5J8zu(h4UY3_pf/Ϝf&7x)m^|a߱w¿%n2Uu-/so'��#avo̦qKƵó=yh`v��5dK+mq0?nuI||D_��~HG[`6N4Oܦïn�tdi'Mp0O%7znзY�tC5-q0OM(")Gg�'nE=v0~̦qEIF{ i7 � +K72&i7 l =7<u\k�Eysv0q̦q[Q,i �|q>J7ۅ`6U_No8Y7�@i]"ȯ,Li7hk8_w�8r>av09̦qa㕼Ysڭ�$_gb}v0y̦q#7H_~��/#](s`6KJ2M[n.�Hz5 Faj?MKNbe�ݕ\z}"6a?MKr&Sz?E�0u փJv0u̦qgUYyꆿt_n �`V#Xy>[IfӸ?tVz ZA�TxDbv?̦qi ;=/[CB{{�~˻uzRl*JʷӓD�:;*J`6n�-A endstream endobj 189 0 obj <</Filter[/FlateDecode]/Length 929>>stream +HKTq%FT`D +luUH +IJ + R.&]jeر)KJsBN + +Ymټ Qlf^8Ww8޾\O�Jz^|C+ 청GNӗe B;,ZB$6Ǘjo#� |>=.j}4~)K_*Kâ(}�Wϒhky7Al +fęNcCN�BGz]]z^^{sĦpC\n$ J�@ I |?Mp# % o=S�[#>px ?Mp{V'z6&�`;{Z<Oߵ7Al +w^ܫ�铵Al +h,K;oE'�͋6ǽڛ 6}ff1Mw<._M; +�sڛ 6Ý6"T-�ݙ[fEko ":T3?wS�I_oi 6ýf7}/|7lU�7Al +%.Ŏ +�x뤢iہ 6NUwW�fkotp9fϻW-U; �%ޕf@)[ʎΒw0ԕL{k�%/~N V@)Qx:3�`E_Y퍀.bS?0"6'w<=;7�`̻H/K?kotqvT'[{B}~s?MXS2VߍRkݥ�Fҿ>.^H`�' endstream endobj 190 0 obj <</Filter[/FlateDecode]/Length 1375>>stream +H[Lg +H:7Dؖ1lsΉ& ^Ѭ -nCԡ:�SNJ_Eg8ƖL`,aF6a/ǼrR}I~4|̴}(=t<ӹ1l<ƺdi|cܘ��<^Կtc×; DM�2ͥ1t.>}�<Iy DM�na M&Sٯ�< ow+]M&aw918W{uWsCXH!}^0Ҝ^�P3!w./;�Ă]Ajr +4{4Ƣ/ޗ3o-13n�P+)Էg #yw?1QV^H<Rj˦];Z~�P#WG]1a "zpvЀ{YYC?\oO� 2F=K}˻ALq57Tk2v$NNuۭ +V/"dnGy �ǩ_z"bz֫7zҍ Ɗ C6\sVcw-4k��5Bjyw< y h2>vw.EYwTS$TwNtm��%>wrxٶuS{.j4FYr{85^X##KN}w�(_eizw?Ϊ,sgZP µg.YλhghWgLʶ85?.xn} ēe.[Ogf;1 �Dw<@=i. d; -M+iD=̼veox-(ò-d8z8�Xl47> ; -iGL8p`�q֟&8s ?.9׆#)s��%0PRrPDOݪ--TWV}gջ?aK;[Iggf0{';�@ frҨ7SMxw8( "j0SёN^m}A#ig?a8h㎖p�D[yҭ{m&@x+ Lr[ ;�[Ǩ/7yw7(`Ê;6бx��szwg2a j +< +1#ۧn˯�DrZǻA?5𼭬bȶIO�@zƨ;ZZ'yw5(`,�Y} endstream endobj 191 0 obj <</Filter[/FlateDecode]/Length 989>>stream +HkTgwah7 "mB)ӂ $ELi*T`$Fh3xNf"t:JэIDiQp<;"~cs.ܾz'{7nt@׭fc�ofzq鞍m/3;,ZWPt&ע�MOwPpñv7cc@9^&oj*r�4<IHzڝ ;?Ma ۊjJɁPWm��t鿓9CNĦ? K̠IF›�ȇjc҉vbSȕ@ۚGo�ȇޫjw0 6\jiJw�Ǿ^؇Al +Qb:Iw,[>�\H7sՉs"<-ݽrmqcG{�&鵔=*='}ݹ_[tb7k +�M-o3=ݵ!X-omu �Ȇ_JJ +Viw, 6|(1 CNl^�އYڥߴ;vc@>-j0x}'E~�w!HIiw+ 6|+;\3'Ƨҭgo�xӇ:JTx4ԅ_Ȼ{b;�ކW]v;Ħ?anZ㏟?y{w�&u̗愿|v;Ħ?2\rz_ٮW�$k3 "W; 6M6h:lѿ/�U~=+-?Ma@Gw$�2 +S΄7?MaCmgk7Ui�m~ySw?MaCw[|ط§}o�xI/5Nm}N{!�i+ endstream endobj 192 0 obj <</Filter[/FlateDecode]/Length 968>>stream +HKQ]1#i&N.i0hYbSD]@:JQX]"^2Vͻ"ߙIΟg$n͜3 !^cyۘMh]},z[bLJ�#=t o H?iw$d&tJid 1IH9ц۩>nĦ?6tB d!�v'Al +nXyJvk"�[;ʤAl +n̑6uj#�P7Mzg[|Al +n5jcj9sc�v{ttjYށĦ?f NE򍑞 7&-Q>[bSp;͹HӃk{w +�HK*R<{Ħ?od+� }闌xhw#bSSSվY�aBz%7/ Pi-�'[iw+bSi쉼zsq/,,=R\+m?MakFkmeݾLMҾc�x@p~o=(}i`ۼȜq.9;�pw#q#xVzDˀ 6J-N"IOH_HonP0O?MaffH+m9 �w3FzBBzC? 6KK脞݈iֿs�DZ/; bS +Q1'<@t~*o?Ma9'vOf_eGVJ(_?Ma&Eʹ?Ҿ{�ԗ%}PMbb,� = endstream endobj 193 0 obj <</Filter[/FlateDecode]/Length 2262>>stream +H{PT?"bLŨi5xI4iqDC!cF1bK*7񂈈/ gY]`uɤ6F$mc35f�.}y|;xw'(q >褅,[<cZWΨd �{|k]%f/M�<.r7YE1}]� 8y+lUY%_ A �{!ߓ [I�SP~2Sv5[ qZۗSfu<=�C_S?O}w/U @(cQ7 A)1F5ҬYCC�R"Xu@uxE�|N~4=�Wy;g@]g`?73)m9jӘ䙤T(2�^ +j!OL}{ @U UqNQsqu 3Ңi?'w>}N�eOʿcb/λ�0 @w6e_Ձy=æN7[%'#ns`?/oը�5\;>;69^Hyry}߷S7?+Lٱ-(H �x*Jc�I? w()쥈OҔƯfW5(y2He|gvb6;>?� /L[�i?ky2AMvoMnrNQsat@2TW(:u|_fD2E`5n_?G�'u%y�4Қ8~Z?gtoMG"-)"t{Gmtqk}=Yy `Ʈ5Lg)t?O�JE1^H@LFsiJbOño:ֳ%P:mu*g +oNf*,\t.(U�xcW-wМy,Fq!!M ?/htf��C$J&ٷ{�Dm׮mSֶĐ(kS-79y`?B:j|%z>L?g�|Ilm>%��T*3TW(赗įeJ̆QCA�`{)+YZьӽ�g3s�&+DN +Д>)mKIE~F2˻K"$-ymmFNIͪF9褅,M]4_oi/ellE ύeryFcmԝ~ܫ6׎>wx<#?%d @$wUaU߳e׌> fIU6lT|ܻO_ge +K!nh>$6QRVS{՞S~}eUZ_Dh&熫Y(Qypc (cL3{uLψdا{W@>$?/y�xyܕ?R]?CyoN^t[sb/l_@Ya}l;W19\;dS<l0E;+s rZm0 )3j K!`Km~ν:`xLN_AP9d"9 �_㛎eVM M[ν'� @$w M4SSm?No]ufgZCӿC}lVآ1 +9^#O_U +7C[r6=#"c~>>"k28`[nQf;lΟ45V^\:gee<�|G#�x +7ռ8C-uiVO?MOߖIiٔ+S?P^O[zp~Ja2v,JZ;P:]cwl&~Qj[ḞKQS -0f5Y7 5gu81ɋm.m=|wy&[:ǻ�I @$w"EUN\o̢n}(hmTx]Raimǝf*;k)N5ir>M \pq='=ҕtZQt<лԖE^!-_!9{y~NZȲ#>F _㜣L,| +_� W endstream endobj 194 0 obj <</Filter[/FlateDecode]/Length 2780>>stream +H{PSw/XZ_vܵյ<jTFD` *D +A@!<B Iy]*`)>ZauU[ٙٿssƍyI%sf>3~~p~I+)?q҂_dzc>y yκIi.b D=,$w]?`0}&]S +b?1RYmclWhĹWw6k@l2e+}uޟAn3x8W,m!ީPcg*_urrj#E5E 2@==]i7t#K Yg ,aǸHy~3&+:ҪmtO9ښ0~t/{y:Q$:ཆp Es^no!߷!uuP<t#'K cٙ2:ϟ :k~-VEE^۵CIcEb \mICa<7+o.s-52[Mw:#Gt;Ým An +fH6x:?иdc?·?DJ}@ZӐX0e% zm> q BzCW&; 8 ~�a9D_-3]а"kPc骊`ҿ\%<IۙDCo+Θ5ߴ-O#] @㒍X2zw> )I]W _g䬶ݟh.[[~=gq48{k]ܬp급~ܘꝂj/ܼ T'cS`8+f՚-?8U&%s^4oKsÉuGFM&֕R?x W?OA@@ePqJ:kG,bMϴ_3,)-0X'jCPWXP٪[۳iH8D=6E.(6)+~cT=K+¦mL}lO`GP7l, L'!uuCě@%+*[_2л#aSm$9=~jۧ9z/ 0J`&6`7͍!% ~S?[Zs@/Ϻ`u3鏅q>5Qj>7Xs=L+ТPC?LSFӀBf:IUQuCv@%K \$`O0Y utSte~A<&}Qw#[W! Eo Gw2Oߟ !iz( +"F;t"7KAF_ey[AHu`j MvPqP یuUH2'~MMC=I?иd?dJHwCmL""ESï>!!H"ph\2yAT.pۢE"A79{RcB \ T6}$}E}"65/QM)~kA4.ɩ)D_1o)ӐfH:MqcE`QN[FHY CfI^4buýÔ{FyV !!!!Iph\2OF +05V<队[;t#%X⾻UEwu7SRVS!rl{AFJn&|x!A%D1aOŚ|Up&&2<_lS)Iu~4w]s<iOI2\ o!m85 ?иd?'w1ˍ?W^0Z3 {s9QUk".|O LQGm*51ZBh\2OLCm,vV F[:aܟHU +IXsV#mfs}ĬJ%o՝-KwX"8Vr`ZD{yҼ-}89ܬH$`7[MhF^#Ź;<HQ +NV 1}W<?7ez r6b]Y {8?)1;Ұ*+ q-rh/TZÄJHz7k' 2G> >-$60 +&ܛt%/*V:c^*%_"Ӹ\y + +y KyBu>jo �~MuX;CP\GUQX|=6=ꌉanyaUAW?+a\cUJe% x[1yqbHye%oB8wwc|C�}ol9]2<xVf ڵQoG;>u&9R7[6"I~h1ĈsY-tMU(E6SW?ZUB,޲Ho n0@qc&z64A!kaAۺ as` t Jo+78 +]|[sb݀P:uhMa<3GHģQ0���= endstream endobj 195 0 obj <</Filter[/FlateDecode]/Length 2901>>stream +H{PTOxM5V$F[kMK@ZJ/WD"$ +ꂀ˂",,g." kD[xL2M'<5#·,;绝>}6ɽpj:,A?C -gc|h]Rr#fsF%Oʱ>Z^z UI^ v2"D}y꠳sTQymV}rŅʜi6"R3WnRֽB^'qVcbyNf +ʍ޴�nWFEQm7M|cWI@)C‘kq\B` tّSeʡAt/$·89 +1 ]ƒi腭K<jdfnkT$&4[a<i׵wgvHQ\tYo(ȌqQQ%??vG$su=͈9g\u?LzJKfHQ ?6q[`D6"k&0'vXh YbR'{J<:KAvPxR2(omB~u~Xma,<T0υKQ 4ݡϷ^ j)dp(?Q|<< s]Ǧ걓;d}LVQ0;-<<Df1K>uݑho.ʱ'y= o-zs{s3fHc?w5]:%.9.gߋAvi|bA?(<+ nuy]}19ڊT@ߋ5 ï+GzJ[=?n/߿;łh[Yim2{'+zzΟY-:{WGio[ŰƍXyx":t]w?ڛ?EH5Rm1"DyqvSRZMv4֛_;Ⱥ/%<o*0z?@}PxR�?Rq [{زJQ?zA9=xA_B >\ u<WݸNn cY%C}9zXkݘ\]A_;YwOD[PxR!DU޵Z v?zf,ǵa{=~OҞIY!kQyqaUNËwF=6q%'�s;%܈95Z{Hi_'>,ME.a߳=z/ zcy ';9ЏN&5(45S5ZZ?h#;u.͜0TZ0T7i+R 9<nki֜*,*8s? +eƽKҧaZz R|eX4!!xϔ +|Z )~_ow#CW5P*ze/+si)yūQ\/'cPxR:D}:Ao*-m)z|ΟQ[<qf1H=#߫- ͮ06~&6Wg;",w\8[q$ +R^AowX>a~ma~P<x+IحcDA{lt0(_:,eT#Zb~>m +Y뮧0+uQVxf^9@/ AO5MDpGJ@-ހ&E/੖do,= x%|jiޖp_Z5(4C7 ;'@GLģA“]?a/mdwgkY*>GO-M*7|B*iw�>p?d NTa]  +O +wp_&zQhy'+z3)[rBk;}K: ?=қV x<PxRf1!n)n7m-͚<$ +ErDԋB˽=0>-@t}(A +O?1T1F^C=1A<ӈW֫Qt聵& xrPxR 9LZzC[>=z=2q/,e?k  AIA <Qy\lYf(t5{fAQOU7c,Po֚#C“AD-y]@(|Q/Y;|o{hnߝK@=-E7-`1 ?(<)Db\B.A/ r3g̾&:l ǡ^ }mq\O֚"C“AN^% ++kEz9g'}ɼ}M�Qߑznk } Aa~ڂWNK4[dKlc޻7a$ǡNk_Q0hcQ  miMfY\xze#7r-Hp~΄ΩG@s@N#xãQ0hcQ% <ش8|ؿnݟsw$ |}8bP<x`݊;(A0i `�A" endstream endobj 196 0 obj <</Filter[/FlateDecode]/Length 2255>>stream +HkPT_vY.U4xmX C5MKM 1%^J@8D h+݅^�QK$43L*[g$zu.,vy9}@V hZYWcVf�<N eCzyAQ??w#I;%e榆^ެ.. H\ރcz݂ ȳN"l_`E=5o>ymݥ]5BSHR~)ϔoʻе ȳE56ݙXxqϢT{sd^ޢ^#w_wz{@4=Z*/tji5r]>ۛyLEyQ)Wʯ5 sEDBGlf^^in56r3DtMJ\{~%/Z,t w8m,,ڢ<grͬOO)OK{}OA2I{k(唿Յi]gH8ƾ+`TcE"c֕uf1@W聆05_1zg=Ve0�w0?qŤ]fņ<Qfb! +5 M@\()ؼ᜹ĢT8_35~Lp}dݢ֦kmӝ/?6]x0y|h^Wu<i4o?Ay:C_ox:\4te 8_3'8D~YMeM Nu[og↯[$3ӳ:Mx?J`\@f2M<lGB!rO?Tx;ѹ5?Ƞ?|Gϼ_^/MϹP}Ԙ }Ih C s`o=y_f;Sn}C) #7ş|2CB!zu�S!y} #׻shsӕVN3,.6ѼD{ =ٗ+,'[;u Ys? ]=sy_1Qx(>Y:g3j u>֢z=�`<;mDp+%6837֗Xgq_AA0 �w + d}&nHv |qHz8g;?$dԃ$JsVCAA&Ө_ �wzy+$<:!k6owW������ Py%K4(ߤWbF=Yo%������a5(؄()37}nN{(2H""l����������������������ZE"VYXinڛ*S L ؿ^^AMi*|?1oXEE!!L5hɳ]-* ޹o:]̒cQILV+_ƺ_MJv{ssCiT+UPJτެ..5x6ct ǮY1TUWL?d +f!=D�y/X4]ֵ?QOsIy m9ԻtD~!ϜNr"_OəGԷ@g./'>{=|/:?'=CSCaziC 'ǼtJ,JE7O-5ruw /6#WHjެُơW]v(ܹ;vL"KږC L HĞ3wՑh4ݡƦ ̾dž?{˧+*7ڎGBcW`{*+s Q+$<:FޔpJ\c?^ߔrj |Ce(8 K>vO3WޢE;_=ĢTFg3䏶ߨn=x0{A{4;Uppk"1JǺ?b0QÆPc[բil+é/$ &'FY(*7v/J0]X~&A? =-[ +wT?:{ cG$DIGkyuRQP$KX//=j +0�?L endstream endobj 197 0 obj <</Filter[/FlateDecode]/Length 1468>>stream +HOSWDNe0g@1N4@ /nUYM݄8Ry +H{ ~,eY2_s]kaQ ~{9{aosvUz'+ +IXF9^stjoL"zʴ4#!kd 5k)̤e +q*.t~P ׮ ځ>}?{e=)%k.=]߭^Նs >œ(+ qZOW c&7ܐYٯZ#|׎SX̎R vx9]YM{R:afVũ[.;k}80c |S1ר[>OYQ<ʟ\:k~O}]&.>Z.̒e0|nh)kd d3rΎJDU](,bX̎w:'kN[=P"z@g!yxfGƁn8n=FƁP[vw w?gQcRRaoV WQO!8[]Lmiw-{s˂Y2U%+L9nzwR*5So{80UtFyci,2�˗,3t<*.-\-:r~OJ%19EȺ k߸UcOˇiU>ϑˑ1ٟFwb(Vag_L g?]vvUf0]28qecq9O-y$-ﬣ=z|6xBз급%,{ߝJy.c!й uIgsᴘkd*=Xc^_QXt,-Mߪ;7;d쿢ýؐ2UHB2oaaLnV6!ytזL&iraR: k XQo?1\+xjn:CLLz]6:mWTwTTU\"-/ CF}]S# cD-`F{7ᒽͼNۯL]ǖY)WKsuN.ܐ3ԡCQtwsHz=&ׅv@4/5aךOb'3X넗4|ikmVh4lcѻ7>C0(=_ح۞Ae ̣tN.g}̨pW/&SKmXdqOO]goϋ׳cr +sV?qXnPL«8\WƟ>{}1"c����������������������������������������������������������������������������� �Bh endstream endobj 198 0 obj <</Filter[/FlateDecode]/Length 7415>>stream +H|Wݪ }\x3I3ɡ-.-@(%N/҄зh;>q &%lmܧZ.mWsH}ˍXo;ikuq{2KV\xaއ{l#<U%Uo ZN 8'zi#=i +X`θ_P/:U $Es%PY#5۶JltC477]􋁼PW1wcpػ^;b 6 cSO34徳q#͞Xmթf4%~=eZo4&#]メP֌[ﻍA/$ӵp(!xe$,t\l#%'^RL4t] +Z/̋-:UhsɦSJ挅2R0K)cٶ[͌o5Y&nUgALvw3ɪZ忁%FWE}u@X{WZ$xpdԺWA٘+lP;SBv6z@y旆vGwz戤i½?6'8@] f6I ٔ/ct`_~Ɩ> {w(@  1{P52/P@ئ^ɰG^Z{PUa7q?`U-KpN';[vC, +h!}?Okl[x@dƀrn&*El޹ +ngS|Z}Qm[ѝIFsxLVyn1z2T?uZZǰۋsv ~iWNd $c@5,.iE.zEP|V\l27ŗo_wo}~??}_??߽}s; m/+ׇ_?߷_~mp&$s|ᮻ!\t. ~ 6]*8(y|HI?4Vl J݁ڂeubDb)op+T CJlF8YAitzMt7hDE12N8#Z +Vq_KL@`.Bx`rǁHrrMQ\+;fX&\0!ϱ +J'qĶ-?GgqlZp=O(PHP�\ze"(A X~}M4wwLغVTy$%-<HlcRKŔl _Pl8]' U;./dk#h5H$<AłG 8ĵz)pVO1D1;=:k[լ6v2a%#.'ZT$b{j@F̀a#-5\PM[QĶ0=ijcǞjf-=@2VNL I8d:C $fMN +]G8'sܔ (x<h.�n#Tq<2ݞ7L="xVuyUb.65-m ;g$#*hqvBC9T lFY'CW䷓"O\U`}ODz 9bDʙ&Ѹ@t:}^njFmi?NTZ͒Ẉ0$,>zR"yWN7�GcRJs'DRS͑`\*ɬKxL\+Z׆ean pZ q)0^88$� +{mlWmKx>rZ~xN�#X'x& Rzl\{&m8LV&R.~uфjhq9  ]wsL92x;4!hJ1 +Ic�qqAj@P ڝw(Μ$9 +83*�n.P6Tq(]ck[<j/-LW4`;51V4 ̑; Fy +.B7Wmd`ɣ48O8HRl'?*8WC�v^Rku)EAh2X'@DqT+E`uċ/k�)@܍qhcf.s;FwFM+7G Wܳ&o%>bB3O㱃7[Oɳ"ኃv9I-3&7&o3 +chi xW=F1Fs`a)䚈}9ݚVg ,g8Y6$'RĝW#t,;3/@+]H[K[f3G s#+rY <-1ڒÜ!;sOT8ImXBږyl*Y|ߣ ?mGj+~A/)-8yI"e�Ѽ!S<S5U.YrtfBtz + TlkP k,K|9/02N|E,Xd?yp9L֕#q\҆A@Mz8z'f+NHZG$\zEMYP < +Z& +c @is8Nx@Nr.@$Q-@it)V CTRHhdvXZ)SJvnrp*4 U|ܓ] z+ApoRÀ =}|5duf/Vt�{Ebfڣ[{+NRlSXQMbu95XGŮO|yY<:ʌh-G 9Ԡ"n|} +D4[X_D�r{s .@PE LHUi[I`^db5܁P1N ix�p2FX=@qYѦuE^E j սA3"ܭ r^jÕeVrD܋4p*)v ^K&{�:&jA2 ԅ& H PROTי'jcnh-˜ee/78DO=C{'-aKH=7Ï)j@{p4bD-4u)I*{ UY"g  XʿB8_dtW$X8eGL!1Ìh@Mؚ *9*"ꑈG1@cAzRm90F/#)| #ז PǢ┠7OlEL$N 5]@^ڹbA@CFZvl$lU`/e_Y@Gd}P'ʆ^ Mє:|d,FȼcȬ`jqi?,7cĝi,'0:a6c$@D�Vl_`paY'c]H Ϛ}bWL\k UI'=_XT c  ʊ94𵚅ȱNzm= >pVޔK/Z!9$ʒAhMϝ-pYufƂ +A,DN*T7(x,Z�:Ub*GtXV*Vqrq 2TI Y 裾oOOZ X`r +c�eZ@PJŨbOFp&ar3UoMzcĬmlPTj.Q rCXgzрjRt)LH0@向ZĀ; U2rTLğQY$!W2"bGE3U(߸$h/,5N/�BIDA8 MHZA)'"Bfm*=kFԨlFPs;]ImJfG@"^7dD*ep'ג/Z<$|ZeU}dXӞ ]Vk)Q-Sԣ&}?Wke@+1J DAN=7IUڇ0F2QҨl-ra) AZĈ%&M>�b]J2谳8d6& lƜCV#5{l+M#qh6ɜ .+ъ(vE !J8\+bĪCC@+N'cj>Abikc̜!V'ʗz鐅0 +}q%h* *>+t`~K'K$~V.=fX1D^0b@'Վi a Czֱm2Ms7ң[EYԣARDrtb5d2>)b}(5昷p�+8Se|p?vkbi' + +peZl {8uVmD%8Cdm^d##>'*3 +u2֓yߊ0I4 )U;S|1.ή~:ŷf]>oƱdd|to~Wbh_uΞ5OVWgW-[7wz߾^xt6nx?wW_a47[>kG4u~ߏͦWeڴ==Y򘈖mj9޹[GtͥlŰpbx;O=*=NUG8+}jl^y"!;,{O'!.8,1nrjŞ|OG?>Mݭbk[G^?[͛P(v_Gq[Y?\;x˿"|l6wb~!}@> +GgXf6Vˍ[-~� �>́\͢}in1WTz=lO|'wR{'w{ ]S{P{כ~t'{3 I}"gOr$Nr$^ro~;TꠋM\6W/f" R mǫo7]CgǾ٧D/W=tNHdVesW8fvM!'\PipޫC\ ?jm;^ܳ3nXS<>_ aKQDO66͢\4ggnUz`Ecf]Q>Ax遞l EK-x1!ˁ)?wI/Gϡ<<ʱTPn}n+˻}|%=3anq؃DSUaw`@nhf.0vyœ5;z=lEq`lq=;X@W80v+s\ n)@988{k97]'f ?WRH/[K xw|xq`0+5Ɏfш+KءVjz(**Fcxo^eljY~ӊT^=R9yn<:¬p2:Rڃa?T ~ ) lsQw.}'@~65avh`<,V�cnI$a+uf +rŗKkLV~^lޱ18mPimJ\ֶ<:&]xDuDTV9CkMib1aƤʯf!~!szIVr$Kof|s|^]3'ڪil=&sgҥ=I{<vq%^yWI{H "+S0;\O[}ꦩNBsڒ27͟kD mEGيt!D +䘸<A"Y].1'Az.xDG"!]y$BBƏEܜf)eöF$ ?|Kb҅ܒr�!l:/^v^ހ/ϼKoLߐK|8G%g1yר +G.EHI1$@6)=s�T@uyT?B4JqXj¸@D* WXR[l4j9z?|í>J)ѭ''æ&GDrp1Gbi[D<lxHDrIG+< lFEE}íi! +WH> +G2 LOS.Y,Pϋ܈B_[0ۣͥvi\f۞I&&n2O<B$<v%^yWMI{hH;i ]ySO47MlLT?%ֈYی1BnFIbg9 r!= [dv%:%ɗP%"0~,4WlIȞ.7%q[.䖔.Ag_/yXogޥ֍7oH%>£͖kE}LSqᣏI"`$$Q t4́ww*1UU_摖!U* +aOʣ!:'+=-_J \[LU5:uymJS m0vI9/<.^d|uawL{hmDc*6D+M\vD 4X_x<;<k6ͳg#&fSpQYm{Yivˡ 6 uyEexd@MM%{@is&!n.g<n 8+6,2y"ȴH$LT _uXj[n? :^~Cx&d**n<c-$[l4j9z?d@p" +;OL0\ 瑄!VLHrI,ghDb~.BeBldlNFEEw~ i1jlJLuUq֘9,ꄕibS'B >Qeʷ㒨XKV4I0SC32ȉx$mN9M(IOoҊcS ;eA8x.0k7صvce"rF%2."Ҫ�^Z]ɤO ->7]g' %5㷭ʣ!:'+=4S'HH? CQy(- +?^|yUKзZ*qmrXzApw3?Β07 vXHB4JP5Lv@^i9 n`ʫ*)X ɥu1܇H99z +��s! endstream endobj 199 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 200 0 obj <</Filter[/FlateDecode]/Length 91>>stream +H�� H��������������������������������������������������������������� 0�!m endstream endobj 201 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 202 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 203 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 204 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 205 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 206 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 207 0 obj <</Filter[/FlateDecode]/Length 1027>>stream +H]OG^W7@Jfggfggɕ Ei@UCSקg@zmBZ| ɜ=��������������������������������������������������������������{1=YW|4iџwr:}ηhC+l|6|nO3Ɋ^Y}K΋ht<= +b7=}ULw9|EOd</z=$P'g767x{7Gy7Rp +u^dֲP˟"3^ied)6eU]%A#uY`-N+ZykCe;UϩPä铎|]v5o?uJ?w5R1e;A-(4<hh�2X?QUbmTmX?Vq/Ųd,LM(1M% ߮iU}H =t|2 +j}˨s\kd/Y#KW4G(*\5Nݗb4;\S&c$mt\;vMCҌ.`ҕsEJq>ypROY4ګڅnP`*s_N]^UN.R ߮iU+/qiٵLW^r)"oײ씳3l 6T"6u:nUu3w>ʸӺk@㥿8k8ֲb&Z7tHklVX:Ŧp8ib$u>;A&6ﺅLryUF9}OF[?n므hvU būMtQ)>tiszSV>޾O_sY&<czխɛJi<h{Fo {vodA~iytR/[\f'{?��������������������������_ �_s endstream endobj 208 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 209 0 obj <</Filter[/FlateDecode]/Length 4081>>stream +HW]oY)+m +$M*W!lP&YsøسB =Ŏ3 dnV`89}Lq7ݓ[|g||3HOHkFFlSb'C#PBvq=?i}zC=KZWJ'!Q4HiOBO S,F{LPkUV'RKL;B 6jEP\\2Mth&P0W%FܵjD+POcC+ؚ݈搶@DdCW`:90*B%l ۽E&sE�|>;j RT(|W 8\\Nah>x, qv�Ӫҙ"ƹ+ 4v +alÑ┼@֡qˁdRXQ*֤h׶?6 ꮢ+c KaS%iZ]M5@c-Q[x{& #:UmǢWk),ʸ.BX#Y/m +ZRt{ Ј V`I׻NC$K}CHr d~Г{ Vk\I=odyRafTdSг%6cRlô1 ^ß཈z|? r[ +G.w޵ (uԎ.F`h=E -#T{��%Vr!Mb' +%/au(8A qƲ;Vr.]+;aSݵ+c KaS%iZ]M@c-Q[x, +ZMA\GtmdmǢWk)qyZ^C +MO)̀8ȂxroߖMN,HZ`.onn%m) + ~K[?$;ꦎuO?Xbts*c +'@pm}f%QϋzS2 +iU l+h8$4Faz Zh07Gd)Ŷ{$Kt+-攌k2cd>2q ,L…;d'E͈\0(" @D:ə1qTYBi ӍwbCRk?z Ed Z 4 ۰R5]?{Q߽)mwSB>jit}~0xQGt9]9FI#=ԓ0S�&t1ӫO9}Z]XݜDIN)Gک7>qԠJ�CiW<Q]}L1$zU1L<'(nUa'h<B{ET�>S5o}4LpBip3W)#:m]7.P^L85%0)_~8FI#=ԓT AT}Yhri7^1 ،80FDN΁D8D?_>&}:ah~sy\&ݗSgXT:@&⪏$_�3J +7]Ӈ,sfwK~s5]ݻ@4f@B>jit}~9Bź' PO:̷)o�a56C-1{mRֈI9RՍGw1e1܁З]/;0ɽ}Ɲ6 u`A240MMaPFoPgo/a==/}1jd=yh:&yE9VR!Mb8Ҿ*�b-*FE̵Sk rfUb .GrXMATQ/FVQhfHVħhĩDKKoX@*q|kI3AcAⴂ|)E 4b,mKCHp]_BcGU'R̤V{(Lx#{LnWlGI*3V۷5:a\SUq92eZ fn TAKS6}%RޢԎ(To4C=V*W@:Ry88Y2^}zbp۩ UqǽF7%G +ᾂ<rXAIF`H +"iqqofBp2z?>o~۾e]^ԽzzSWJMk +k(|@H!dYSk*AW>5i|Mk_=5>0JM㫶u1ide4 C*vF82_-zw)r@4f2>z �,cH +LGR�� PDB]Y*&(ziRVL.bvDs$2 gXr>8߻'ůd0ӳ`'G{2&@Bt3ߞyK2 +ic+Xs^sO6eRv9]$x.3*B1@`(2KB�: Rd \EƱ<ܦd8 ` 94 `ݪ_>�<Jc|ގxw]@?XbtK@[ +"E2?I}. Ʌ0!tM{yR GT +o@[3g߼7o4~xQp {*S%dJhATJ0i載 sJƵLRGأ( tPaQd2(. yr90"5#rJwàV7@'goQ9gt +1N7sIO_R''j5蟰:aj J_^E=nԿWr6~A7ɹ@A ^99?;M3xzdp$wcxՇ`ZV~Z)1}/ܮS|ݓX +S U*HgIɮ}]Til.Jun rvzЏKCM:,ˋڴ4Uߘ1pVF8UgFxf F.>`[}�@8wzuIGF7fL^"o:L-Ӧ##/&CiٖsMU޿x?(v/|-QIjw'&m!P;4YlɭIC_bZNsQtN BEEZ)v + -)F<*_ \[.溠I!Sh 6(n󨡴|[d@|f| +u(C%#Tŕ<npdU֔W[Q^kyK(r YuZi<Nβ̑g<ȞfͅLVS㳫Xڲ?k8 ei$6դQSGں5 -<)Dw67L;ї4^I;߼) LwsT.&S`?g|NF׃DBW~3>K@]�pۮ_$]-f�tOp<Z%Xٟw`'zD.:C᠉ZC,Rm=X[Zp @3cB<`,�;̡@;Ô?@ snH+嬽VY~֯Vo a*68;($:�xɓBME\N:IuE,t<zc .hBCh^@c�JӯO*^DW^T dR7Cqr8<O "$8J&?/V>(Ua|:7$&Wi@lS/h!v?vrK9ql +3! S8-}) +qiy@,$As"DԟK_ѓq�<f>!|L ( )b 9K|@}H)H9.ELL> Q +?@x,8"@j{,D`]XZ#9,x@Ϝ�ro�>O endstream endobj 210 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 211 0 obj <</Filter[/FlateDecode]/Length 694>>stream +HKQcs@(/ݺmaAeEIP6^P6"%3 +[C~]7Rbu]M^{ +8#xG�������������������������d _M'֖ѻAu���P˥"I/Όt8n^'rF ���:9s2͘o����jq5WW +[\����UTSbyX4w/#>fuy����ј]M'd&ﻯ^hχ=d.n>����F~z/G󣇏XU����,Er8o9?FO[{Y{h!B!%N5nJE-sVm9rP^잜e !BHiGۀR9͹̟;Y|]}a\n)zy=du L1~;M (žӦsps.upLydgk(Uo<n0g3n,r#`3&ѾC<?23z{+WﳹLr}y +vwy3c=gc=@W̳>>bju aXY}X35dW��Ѷ endstream endobj 212 0 obj <</Filter[/FlateDecode]/Length 325>>stream +H׫JQlQhI`rE0" &AAOkÌI|Na�_Z^iF<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�ĦIfS��A&%'so�`A&%Ûڷ��0 nwj�7<?^?/j�W<z4P$��&dRY[o^Fw烣7�0fdaM��d"��_]5?�3 � endstream endobj 213 0 obj <</Filter[/FlateDecode]/Length 511>>stream +HMKTaX0l*75.5w} JL"h H&aSqrhS[82V L9r]pV{' 4j^S +t,c �_1?��M &�@D��7��PX]\^XZ��4$?^>PЅ��HݟݯP8srk] �T=7^=Zk�ФV<}Xƛ�?I;y{ӻϮd��M1iubx�?I;<80|ލ}�@vyPF�7g�|+]^#�@5jղ?��M &B!Z̆g'36+k3x8Nr!r!GZNso8qyb28zV=Vf<.C9C9ZN��=��C endstream endobj 214 0 obj <</Filter[/FlateDecode]/Length 609>>stream +HKKTqit'ȠZD}>Т (DˊpSԦ.dR97Ǚq.V 6Qc6"s灗sx/ڲ~CX~�=y�6yj<�DF5q�M^#..?8vVGRd8��&+/s�_qryWέ]�׈[/�@kDݣTϽ6�x׈/ +}Տ_��&Uax^Ⱦ;u=� 5[L?��M^#W;omW/Yw/=ɤºLym]� +L4iٶ=#f73ru+|WJ �QX_m9c҉`_fxOKkqMJc(y3K�0\[:=J$=/ �4?zz=/pf��̦a"T؁�I'PMԵ*��ׯ?&1\}MVz��& f3œP-J#bS!�lr endstream endobj 215 0 obj <</Filter[/FlateDecode]/Length 734>>stream +H=OSQC4<F$AgMԈACP(*B!& bG'ky{HRLpQ#o&É|?M{;�svKuwqY_[$���>~bLQ菡9:&���1: g6S#o˙h}���p'>4(Gh>6dΦ��� D~m-9j0Eqd(��� D J2D$^;Y,���=vYx!L$qUw>~\.��� ?RxWGM}��tXVA$Q{C̯9ru ��f랳I}F$1i>9w��lSzQ?F45kRO5> ��J ggLRW:އ ��FgLSՑV!=/9ӣ6���wXo~.?`POr-fݷ��(&3ta0I ��F[ߏ\t&got��`S{G裃"Z��$_wчGuUlHoןK ��&\T?ԓ|\��$)3x0ɿcdyޖu��`8? �n;n endstream endobj 216 0 obj <</Filter[/FlateDecode]/Length 853>>stream +HMHa�?Hyޔ + +M,-C +"L(<Es͹)Q霯ss,`bt*FIֽc>!J}<Ӵu+`6~ۻrn7S'Ȏ��`i ^v|߽L4]6`[kWW��`cE:Z~Cc@UkB}m-��y[u=U?i��`Cpoۿv҄]��D8/?Pf=Vܥ'%ˎ ��N`a@eG=7xd���*{d6rb@eGtI 螯z{k���*;Z+_=_Db@e8C={ZvN���ipOj} wQvN���U; e;é��(xڑ`VodkNt���*zjƉd?p#Ф=meg��P3Zc@58u#>���*?:k0HeqnB. +��垵dq9β?`\g6Ɣ!;.��RNed:V Xz9nK��@% +ѳ,Y0T3+޹}+)q��lHG>%zW#/<B0T~{S0h~%;>��"S5h~+zW]0HU{fB.dkTjlq��l$5vkQSŚ&zդv4Fqw3֕iFO\Ô!/�G�Y endstream endobj 217 0 obj <</Filter[/FlateDecode]/Length 1724>>stream +HyLw_9 [!ma%۲!:t$Wt!Ka +QJ-TaA +$StA--DwE +؃=}K~M1�zyYoU|_Ʈ2fkBrbl97Dž>=Lz{?os\i_KA,<7L����kZO(O=k \LjNo SXME* Mf{9����YN|{tf9W,>zə8zHt^&{NRP`;g4 y,q6Wxzi����r奞Rgӡ9JU)hOǣ!HE3YknU#-mI8ͷ|O8S)v W7~ޥ,+i���%Dyr`<Ej0 2Wfw6t$%~&/5҂)|r͢����D~GU^Nyih~`6|"TR)(8L5}vsCs?-} +���@BV d3yó󦠥/045Q$+3sMR|RB*c%<^&> m���@PRJohz/*U%?=WѴ$4 oGu]ʿRE���7쌰Oʂh(O%DT8wo*Oō#R\- yڏ|߶u덵tT����>ؘЍæ#%Q TkҒjqV֣>iIFϷ>>_Ͷ΁���􄽍:[=ҭdaܜUՖ^{gܗ>??NVVΆOR.9(N2v;e%?'3���=nf֕9'JyrEkx&ؘrd;΋`ɉ~fwI'JyYOg\^]{{Zc���PK?-{G]ǚ(>eߠK,`X +D:[X/>pwx���=WrOmlDJt('e[o%>\?hˇv$ ɊjaH{ ����-256f|AWCxȹWUb:?=IB�}$ޫp7zb =X\n���>\1{<pA)0q i[*aR!yxf#=o +ZZ/����*`:Kt7BydP@ &?h\erIGX |X\ڽ/Mu}^���r".څrTWAQҢ}5Z0Ll֞ig\{X'*x<]���`2c;Qy$t4{)?s6oBd2y'K/(N֑wb;}u}d��� 9#嚞RgѺ"GdK�?hv +mg#={E|]���`|AyڙVu>5ϸ3K�{ endstream endobj 218 0 obj <</Filter[/FlateDecode]/Length 4290>>stream +HiPgg#Q0 +x"0܇(!\*0* k(@ɢFw=o︵U=z@4 x02FM!\fkΕ]kE^6B!K HLoe7U#ÊKf,ȹHnCS7QAVH>̳i.>_F!ǂe`Zݣ-hav`+h$19\m:`ûdm̍MtB %׳$4:Hl4?%s{3|5SN8{!B9Cr + ^6rq?V?H2L8H}c;=MfT}y/!B4()g0NS t*;4̀3g恍9:kp].׀z.G'-�–+aT#PSV=Dh"t{H 2 +Ih,N9}$gD-B!`&L }O'gzw"558uМXvJfa橠 ̤b&_g] +E"~?lM`M+c{:ַv`6C^^cVZ {;Cf dž٩ phw>>PKԖ#@!tVWIz`nl+,,ewqUT'!=*r>+1E5fHP , o1/wVܯ/zB/mt63_? ~Xrsn4{/:Oj@G2\$ i@f@y7o.�M� X�_g�Ӟ^mu_[沼o3ZeA.S={yz;Sa@#P2IdLGw31d~!ЧN`:lfζy=tjL@Ԉ&6d𪢜B1Q$x_wp7K}LZJ]IoxQk?iNoʝl=ZG*HBj}^']CR 4҃-nɝ<ߓCޢeCd\TdݫEvSD|NhUUy?BhѨLEkiDYo65%\ +w4!-"|&)IY+ Ԕ +$bzڅ34E$zK[w}Y4YB]Γp @/�8N�´\&ydgGN& 7jVPr'S]!z"j0Fs S `֤`nlKꅋv9l_E!}rf|g2g&ْHObD1J j,eu\:%P؋ _i.W.=yȟv/ OC@;�o+ RY *Ka@#p o(xwϾjdXxlBaB@YQF1x02(Ӎr65`o6~ \Vw4O'gžmnJ;<T#<=Տj?wb0ӑf`uڢ¬yg* 2S>0KI'Eר^p.>ζv+= љZ¢d}A*mq[ikV>9xC\ծ|CTm1F ZC��8�(g/l<j:W)t G V ­oj=K]wV, !$'FX M0sLYapXb-h 0jQ>>Z맄q$ʜg[t±$-e 3-<'=,X61>4ۿ?t o5 j.˻^QyfMŻjXN|0y[H+Iwwu}FKΦ/֛<aUKu[j>SfPc@6W$ ) p1�D’┵CdIFYϐtw>bB}"T`L7�`cflud=!S=>x^ZDX¤^yT/`ͯ +$TyyNPrd}Iy:8Q)-I%ͽdپ?kPSgI%PEEAqhpZ +:Q`P+\@4 .u( +^ +K9َ̎&}y'92>K5n~*uXLe"+_6�]ߞu�MZϿ1x�I;аib1<1=hֺځ [=ǁ@ #́lc]7}сAC{#2)"-5Ů,+ӅC+0ucV+DU +qMr:ynJю XWrFF c-7zd>\ӷ p7s͠7Lh߭u�n= 6g0g|!; [O0{~f]0K } 0,+c= {xž/]a}'lGW3ss<k8۔FYFݨbۻ?%e7eh9BI=@F;eҧR׹#7,B7=@PP7?I+8`>ܡBm{ߥr;|=H^7H,m3-&ar{d3}do*8w828+>HKMcd# =LFwՕX7%n?nhtqȸzO~J<ڑA>Q skG"g! fCo:_φw)44 k0A@L}US߼l<o3A `o֭tO |P<  +1pҌN3F<w'U*ļ +ۚ[v@}D簟+OhzMb&:w麡qc:!2y}%4Hx/C{~> Fb*;ßP >$V@&UfM˃e qس`ށ@ ~xcn>!I3 {@LP0.qw}'ƞy)>CRQǬ 9 +O!VBN{ +"?ڑASh)5m!_^]6CN ?dAy@A "TI +g0A@ }64E"/]|wy }.kV`ouxmadKiV|<1/m_>>}}*ߗG/FaZV1W%R PGǾr@s3ezθ:.T녵_,WG$UfCHpa�?`x@CCC& ; KN?g*шF=N?:hgf<̌ha6D+ëځ󊕰i$ldo +Q;I{f1ˤP9ִ;e37;[H -) +ǚ"=h=orhK!! ~N풚]RV-Y➂Vꉊ*jvhT[ǯ7lw|!ZT:Ce;t+cݯ;9a/ 4˽REb b?ֳO8oi^0RGC Á)X-a"[pwйf ;{m?~jLyV|e^!ۢ4##2'۝]]}0XPZYWQzp+e<fu}Q!jKZGfo.*)Mt=)öю ژ::Nl(߉0񶠵?˿.fۼG"ga㬻" zmp-@@ z�t: endstream endobj 219 0 obj <</Filter[/FlateDecode]/Length 2354>>stream +HyPwoP. +jxԃm[ڊ(((zQDp@@dH W hף[cieW$oٙփyf>/y-�x=iroDF]Nȹ<f,!ț{~uWGnQ=Ͻhw>ŞnzK? Ϡ߆)')Siౄ<׷mv!{'<0[t,ƂӢI%|<R-_VeMgUHo犮 +R}w&N}4:Q!zX&hE.h[^i{~vՌVRj-yf>NMYק 3?Wݛ.[7jvUJ|<<:Ǹ.�{pb! Xc ˅aq:I +$KE O{\Gm,?"emMq(hѬȝ{_ۇ&~aFT+ Iũ2^ЪUy @ՠ>$ij vz'+k93wps~l67kCFX=DUA_9QbQ~��x9Rz \OWU aGct-,~ r=BCKӟM=,-ɼ[7Ϣ{`o3}tZ|ڴtYZo "LJ: #Γ&>%LܯNV3*TrBzG/pU)(n* T + uix8(]N(ՍmK_SΎPM$$t;��z /]ݙ?S +v )қ-觽DMg#D2ƶO_>#KCg_JkƅL̈t=x&+%M-Ԫ["Q+$K*ENQV*K/. +O)ũvݢŒȂм$fiBlAjql ?'I탯3=u"X*+ +گˮ/~^IߨO;_W,(iDilW{o,unQγxrrv_QUQI>QЍ��[l6ҾZ^Y܊R!zd]09°*}{l再pBz|!IKծnӲ[.vs`u+q BUl% $IMpsًd{K&X<gsG<: .z͡UȮVj^5O:w綬m?࣯[]];MjO|rŮSsO: ;vOl7ne?c1g;��1b=E+#/a ??Y<fƑ-2MR+dw}PԾj_"2"g ���t-?Kir޽˻bjz01qeyYW=.~7ۼw:#39]_y $g���n~;sR(+a cbИy߭l+=!Ra!^"j[ā<'���{b/,A^=ư?6͠|_gʞ ݈h7,T)$7u`{J |?Kl��� )` ȫ+<d= `[}Ѫ:c Oga~6���%lJ w'a cRBz?5_t$tHnmag?|eFreů+L���nOOz +`Be |B ^@KT']3M1D1s]>_֔/ܟa���.'RJCr\w$ĔbLcR{yR93pK:ݍYF!#5ǪEes~��rT)>ܻ~Zi0yΞ NO +^+=lHn���A~qbj1$&!:s6݈OWE֧2s^��nnxz 18su%5g���Xa}bj1G8r���]*u&_';b11.)қ?Vp}��ۥ*,-.w"c-PJܟC���v`;]1ӃT +Yד���zJ? =.��fd endstream endobj 220 0 obj <</Filter[/FlateDecode]/Length 26163>>stream +HWˎ OQO}Ɇ<a$;"ggw}1(.s"##l[%F_F em."(C龜۪5z_>sÿ|z_ wؤң_ۗϟ~yy?=~o_~s*࿲/c1I|ŹƃCjqR<Fm֦kX"~UV u#?biѹB=cˏ>򵔚X |=K\AӎTƊ0RĻIn ?TsjnHZUX>@Hkf k1':X׌5lLjJTILzF̴ImR[)4�9q >=?N zD+@%:s>hλ�mt@LܑuO=0;vT�A+b<\3ݙ8*O{럧߶3ق@P$5J׈W%fh#Z謌uzfݛ1,&nXUžБKTMtFZ(E5{pXRG@ +VAJ\CY #4HբC R3�4K1*Iղpq,R*鐣⺥p>,rBD?koI^xT~1f[V\ n>k}᝹�h\62fF̮K2jꚺⶖ-Y]NY@@ AB�m2P"t@m:7qʦ!*H,`ؽaڱa YLjl$CSG-"#H0Ċչy\򸘂S;jRhy ٙ o)X _U>䕷v>=FRI�C%s%c(7KM<\y XQy +#ڶ! aiM/#ʡm^ a:暑r@RH%q�'$9VΝ25g[ek:6SH}tyc-b3 S!9r2; I(p4rpHass41_Y7g{[ߔJ-]yوBi4;�blW}Ҩ bZ"}hy6”2d9m .12U٭6|Z dy1pS>&RGGMaaNw�` TmSm(damF3g?QF~OG?|*d]NG¶#GL=syRI'R#Ѽo<K 䭺G QtAۘitit}WÝaVg�WWLͶTMS m:o 7j?cGH2=G. , +.<p"nx~u@Jّ]@%,)$G#9rN6ygؘa( gu65:go> g~ ;ML^m%? +5� ;T5l[]a])'[(3tS`^v z c)k!GS6v8d3I١xf%i%ܛsQL^QjzYrbchm7yMC1zk+;}|JqN֫ZS]kI'x}~TKV4U6?a RnÊ9ъ'|ʨPc'-쎁$yGvIިaeP{=s6+t$Nwu q59NvG# 9JOó)ioAVct0~`1WiջUo|˶7ӑ-[ Z3% ս;_ +o2Sz& �Sq8(RjNs>V< %z1M8"t(PƈoOy> +zQ>tP -)Z^r |eCL!w +)ײy5)'t>(XՂ +x"]nQ|JX.аlaPb@V?S|nkM? YB>7Dx>uz"8KLҙ;{%;*<!ڀJWY5雦Qe;smd^'2KiAז!bAJ6Y,lǏ]f"!1Dz@8[G>^!&U 6֊})WlEkY>dR e;ӺF>yY7. Zګ༦y +wZ9 _ND<lsJX'J!ۘZ@?R$j~U .D͙ѢŌτQE6##Au~g6͘pqg'^^R0T|L^5i2l>}H>phQʤW| QHOTִH>Yd^q@1{h@hW#_m7c O0n" ᒉh["4 82&o^s$2tWWW_55Y}}dR'X<7޴f`veڂZHozWƂ3j/\GW}/* +a@mBU_/ D!'V� 0y d O<[RB-Oil ݋\jtCf)m_.Vzo'ManuJMBn|̤qe@)ǫ9&:-MD[{67ru6tT7"n]bb|K^Cw{V{kTM{{ܚ7VW79-/V Gzt&F=GȩE˯[ȁSH<(Xڳ +SV8FPZR? Qݰxc==ؓOUk7j~\twru'RGjR_ ͈֞=?4p<|8༌!pc  ul1I6e8NؐF;_oh%x ǁY#$Iad$K(K$ Scdr~r~wW˷o/[)9 ~h4'0 +f j5ϽFs"r҈lK99`o<-6ٰ5rͦ?[784Eq4&L/ }4E*&Q } R"[Fb TУ#69s;NWzyټuk!lt׮b`߄,E3q9S]1GDzu67Dm[o.!5%j |D] Nc#*:]K08"Rp^Eo.tI7bMvvY3ըP D]4h* AE]c=twq,VV2zTl|utf eY_ Ȭ4$ruЩFVobr0S9eѼ@ȮќIJ9ּ+`/ʀ`i4.Vm�"ȥ rc 3n@BRI:j]S11A@::r�k.:"*\Erݨ154&23|$[K< dP#BMVqmj<lP^&ٚ0X +YKВ=R 8ih <'(tEiq/7"PP t@J޿cfDX n/镆ըw{mBW֤H+Pdiر5ti9$ʬ8JUZ }9aZ7𝎠(7p}ܮO%KMkbߏi^zư/yI18B@uq1S<)}nl<ܨ`i*}䈱GئEXڎESY&5A77^[gPQ4qZRy@Vyn([dlqadl {Htس8 JGWTKxM:%U!# (ۘ6e➱�+:~߼ 15ɉm +38v>萞DK?{ʜ{pxSpx}Ҿܷ:ɿ"$rzF-##AJCCN{Qs8zZonZ Ozgfi�'j W3u<=JԃY}:KЁ[l$ <c&-(ϔmh+xex[z˞K`P +Ksɱ]J@4no` ֻ}x.c%|=08C <O*ϤE ><UG S8S#vtCqz{i|iui3Zaq8˻\g~{wނ=W+Q޹sR +>vFr]F_ }՟2X_]_],_]̯VПϬѓ쿓8b<[-^=ܜ^fVѿo9޽}s)?g'{l70u/_~5BN,4jEnxqzyeL +KE�ZOZz/'XdyTy&]IY wҜe%!ivsӐ\E +ěv,x9DŽg�9dw<=ƄeEU$+8G<7"/!ʦ< bfB)"&ȩ$DkpΑZuBTuq|.r8؃͕gBAT KJ`Y.K^WOr=SwJ޶ƽG\W|xcb<"2so*4,YZC{ 6ȂLl@byCδL2#IUHH39AǒbMzGRJ +q$=xp7d:.Iu❴E^&`#H2EX0<SBFZțB)<V3Q%SD'[.FFgfMU ʀO-U7[i+ȅC%  TQ"x pFJ\סJlgC*%n3xg)5:I^%FCɂ)5LKP,(c,T`C2c&ݧ5T.U=M·S @qq&z4E9x!+; W0{8q0v?P x +ƀYJƂgv /XU5ن胸OZm3hΡ҅ mZCX#,^YGu*<{9ֶdy"<}('7M*8B1V {;`7p+Ԕpjcrz1E=ɢuҶNkO=;Mw2t(x}ٸM4r*`u>a|k}gF( Ris+{ބW7O`/gfwfޡo\}{k/:‘z63G]npG@[1`(\3*a%GS?~,&)O:B8Uq뛭9FHiqsNQi[i- [8fyip׏*LY�vV(OS8q6>KܺJVRqs)Ӯ r_|�kj\<][ݢLxz+d�A-N]&a;b[B}݀8~5]y +t!'Dzc>i7fd +J8"m "ыb3nIWPuKGbzJeHP"K2 .j +j~J>"7 +pnN2N,ZHZzc:]#ntWR)Tt]�RFI@ի i-`r"u" ӎŪ�{ }^_~>qe+h}"PT*H!b%d%ގr%7M.WiZ_Yc:c~]eO:ro0k ́v^ƶ.EXL_~M-1^M(O2ɺXռ!(N~ lޢS @"LEC/̇1PA(m4Ue[.2ČV4, %I~7|0a3Oם| z,o{Qg͐=+As�.Rr%h.3cUU3bTY##&f@ l@` iE_ ߂5z^u¢]xOTe&?25^tFϺ5%rꊢ;Whp1s;NeP]U / $E0zIGU{fy* |-ӠW>w9jNɓ [kUUQpFDyrԭ?Ac}_~~ __Y$+4'J:K=tg8O82SR57d4 ȪP�t25 x1%o)‘`"qX)}[3e>dD5^1HEaBlI.Y3<n@ʏ07 { t.!UF*^cTJkEtbJՐ9#o +0h��8ʚN5nI0uӁtNPk! BuV^]c1|vV~lrruY!3%2A+5 e Kq|CmK͏6\mmC`nձ�g)B5~X:I!X#]Fu)Co +>^:{5%0E8Tdd6G΃+]3~_2]NnFU%)T3 I9$$fW +bR Ju; �*lَӳ& ׽$&}=}q|l׹1&Ixf Ȱ<ܣkS2VR."(Ю+xMSW5;vEŘ܅ +1tn{l=V5@pu-i9~.!zq]d%�9F-^=~\ڧ- AW^E)J'X-:U[?.Q/ȉݳչN7()ҁw^sKbdf^f,%ӻWjƷ +) ժĎ@[@\&ݵ؂�{P.hq(mT((.#[]+:]e2nE$n=TgRvp:^O%=3WGy}i 1wI0D9VFF7a&E�׋nty;37A@: +s@jg dE8}#3wxX:+D2Z +fۓ߀p&wD7|s +V*3a2L]25H[ +z՟5ss,1*,[MC 5 Ap[}vCrHN.*-nIm9JX6$b8Z +L{ff pqLf+>~N夐S(oz܋:b,C/8N:_[F/#t3Ө 4a(_H\'ɬo&|Ԕ_|�1#H[cbW6wRʴ(!k#"5a2A+/AT`jBۣY`tj;^8U?Cn/}bQS+R9ϩIT/UF,N[4k2,\Yxf!t ,=<莳Z7\̯@zn;\zMVu_J=&Hm9V<A7sl8U'N\V6;(|}DH:*%:VPDg"@ {g{XMu|׻�b l [[ ]Pm$6|ǡ\pȒ_ְ¿$7~*z-ՊUI%3O"5Vfe`*HM!g }K#dRi!H� +ttyJ&/+^Uł(l| c}]L(Δ:˃&ҏbJSyO/D*u!I簾<ne3\G1(F$F`UnǙsfvN]dLfs[Ayc +1I7JoNQkYMó%8݀U:W2L؄qE +M]JW@ġ:l{JJ~]KO8ÖubfPj +𣞍d|dq'=-!+5ysѵK)\mP}'ǶNWwqXԩ|I3�ผT#ƥĮ~e`:y) q]K}dXG]{ʹMaԡ)ƦvkxF8WQ03d z+ 63pl|l>Y %%Pb>c'lv7/qf͡ΝnpI&;s\F"Bܑ([12 aQd{-0%qA +0jzSB2qە+C8F馆1#=6rP,sv�z[;afө0]wK܀+~@*Bk{g}>]9rpCzQ'i2y^IabdFSj_<{,NKp(}ހ{{w)c޳1m{gJ#J.S顖Q̀R~&U# #pg#/ +_V;ϼm +$du(fR=K {8iSc:߄T&Y8QdqN`nq  \XeJrHwS~jejlj�*zv2( !v^},܇DS!riYڙ(XYBgKL62`1knU00Ƶ2@n-85YJ* 4r(}jwnԗV*5Ysu^̓Y}vb</ PO`Em2ߧ##uܭcuVѡ{?h%BkBe�G#+2;=BHc %=- ?js< #4ɂ59XLE>=tY {;іzW|j9AQS^gh[aK^Vs!l(ZЧnzN^ݝV)>}Ӓ%s+d,!x,woG}xudrRlQ)ӎaGΞ}E 9hn#]^|>46n!D7#`E>t,3ẵϗgkF9~O0Zjͩu-G +x'_ӔF'q/-Y|sƠP]x1K*z46 +ЂRۚ{aU\H]϶?^ٍ/2ֵ=.KlX1{Pjt{cW-G.-Kr�q\;f8F/jȵi's/^:x>Ε/OplĆ{?.7h'?j-WlлRAAOqnF2v$bC1_XOn(15<fC (Υ^6$yig5N/N2L +qsϫ!uݯtM`#W#�L+obX0'7)y 4̜bHepwC@�[{-h ^=TxVѼEKZ+:b2I= bd1#lOC}9Ao[uVwzO&%?_I+<%v ~Wk廉ajHh`0yWT` ݬL05ixˬM{tgԻ0Ihd|^wmRp]"=%U5jѳ~ˇ_O߯0O v՟?__|}ˏӷ~|[|^o0__|_aV8?2B̫CHv +xEFpcNbX'!Ivdg7e3oltH$qU}S2%:Ӓ[x&ش6){nw0C3AO#rL=2 ) ?ۊ2vW";Dic&'i H[῟dŝi;{ѫU& +1ki|I6 ]%O" ;FkvFy}3JT]oZݟW?`T{&抃X̊Gtߟo֋tn6gYDDQo=?}y}ǟ>RB?x>)РZ/, w!ŷkwӞo#ܰ_oZIq+"o*wJk9 ht;m-f]('avl)*CW1v(߈CnȁӋl~qG["t%hȥ?Y]FmK?YiP&n|uxEߌcdzG= b:;6ub<~%-9i|}_txʽ'oݱzQBٗ=ۏ 1/0w?IS)G{0q`-Mqau-I(A9iqXHxagu1SYYرN _`7cuڈ'?hGY'vy#`4g4,޵,8~iFOhYUwλ� -(7KtAAsps+ #XOF=t :Ѩ!X\i-urQ % ݷP(فYC^y>Jՠ9͖ + |a�hiJڵe\#DRDcO=;a(*3bp1Bee [>OMڹIar"Osiq>Xtq~V(rFSx]:xRJ:KOl>hL{ۘ=XS`  +L͍wŪf>R]t_gDqR#O4ÏLx>NG$%ω=jNl~~%l`9E[; hJ'Ĵ -z62&M 2nR}=K9k{"Y5 6OFoP]"OZbWNFkK?uO ĆZ}#M$A:>G;;_w:ORlޓBfjc1{q46J~=ˠ0J~+4FSӲtʾgk){9 >͡3xWڬ1ݮL3& nqI8\փVs3jޫ /&3Ys *H\qrQ>w4+cֳnpԢe-t 2tG(^LJ /' +P ^T)WI;)h损@_n~y?w+]'[\[+%p~2"2#Yk2CLJu$V?f-OV| _`u#ary[4UG̘ۣ(b;_O-d`xdHwR!>{`R)D( &) +1;Լ\j;KWJ͇]SsNG26Ds@!#mφ 9 g13h2$QGc}x˳̍[i.SVJYnWҀ|l:ٻ҈11pܑD_nN:ui‹! ,nɮu* @x =]\}մl0G9> +�kl%a0([ +k5X3a }FS`?K)QbxDyAaX5QLd)x4b4Z U%֥2k6vw|-B36`i�s?}mo;kJ )�*fzeVoMfock(0ԖyQgQDp˔zGZvaҢuE)Nփh)gd?ZP5D_  d';/# +Y"nzb<Ŝ<p ;ZUSMo9-C+njEuۡ_v ;ǿOԚSVTQ;1wuV=04%%I:K}i+ˑqSQu;zIQ(@/Y~_Z=ozOިˏv¤jhۘkMTz_:$񸛴e2?V5댮k3֠`8:LŝzG%k9ɶ}Ϊ7y8\bnty*nȩ-IleH@aw-InQA|%B\eyZjL|Zܑʩ}3Tr\}-Nb|-7O?Ґ.%(|)RL|]weԏpburߑd!}J}5`هy`TIժ]8!vMƄsIo/QdMC$d}&4 +2nKNl>Ŗ11Jw^? #˦N\$(_PYPh7^a ߍ﵁؋G|v $Zӏ+QvUiH$XED,*E޶-F_i$RZZN5wwx|ȉ%9vl \a,b)#qYB)7e"#.ua=o\CN" 1 +ʧwsYm9qG5CUYy?Yes#9syj!"~, T4=՜RI|9+5{Lgݢ%x {I$+Xz9r%ao!qpv`nf։#TC:=˾\hlW=#^[[!w-I6s3=0g^#jo{qQܣl >(ف\4BIH9=.1ldtz9 Ÿ)hZ$֔!WZZXzQ.#|EɃ-uXBzC<~G物"&._L0v$ 4%̺Kf|)ˇERSa"=enڭ'_IZ +Qd3QFQD!֫pJ~ŀ&WrMmnLo/#e1phn9XLgۙi:PWL+MgdY븢;I@4[$eb0q0(-,uC5gS_C Rսu{mGTòg:^88% :fyzdMvX5ꖺ\":߇ 94ױìMŧ8L"9UUU>|=F8=B4fՄvVRghV{3&`O[ө1+:RFL//�7ەAZ|p#Evb |sfqDxB>OM]4qǩŷ�3*zOv'_w>iݾ~Iem qҊe}uP؝#eCw{҅h,z�h' vUF1ԧ' { KZgp'iɝ|\ gXpUyR. +:RZgU˞h[^|e"T6d\|`:<`jhOuuue>fԑH] (İ`Qr]A|lM/O*zl뷿SuzMoe*ѕŇ^Әt$V&Fi,N]ehhS0`'S>Xͻ/ +n Ewgf ̺HK[R3I)9"e?Rr&bÓjDVrpG]yӊP ]X=s1ߺ#ǾCo<*/bH=TU[][bxH77c4ӴlGO2qꋫ}<{{/߾~wD4dverM]쏏g߿o/o<~7oݾᇏc/U߾}ۇ7~ջ><g'w#_{˟]L2uo=|_{A{wt|j>:( 7P1J9'?JXQT_Dpe7b5mSѹ!rx�,J7ODk8݄~"$5S3 FȦM-afZRIl{a1Zءӈ<}߈#r. +xW#C v4ZmBλʡFt55R ֝O2ᜋJ#[Nl +?.fW t\g:/Oo&dzwwy+,# /+uq R&,|*:d XDJ&2DK!%E|yuuv ?9Ga_7C[_v=2 ?*V@%>0|( rH�LIpL905 7IQJI#"%HhIH`2]@iTQlތ:Y ~? x:Om 4VuE*s|3ꙍW|,ǩwϺP#ZB<_FK]^mrl +*AjZ1{-n *էPQ%uuc y/X$F(#ٞ3^V~p<i^YJ<#TuZ7N;=hq P#F2vs%,R:@JG`ti.״ו'whCb٫p/-Z|~YqL4Q}]6[o={=RF?os\WO903e*#ᚫDtqS^'Y,i Qj-yj>` JY6$´G[c*�l$iHlJ#ϝF{j+R-8u]DL>kGqMhPg tYjQ@q> O̠lRaG/Zsʬq>Ogn ILH^O}"R!z hq6oGScإM3JL#<QRERO8!] 4 Yihk31"(桜Rgj(urY7b +="΂AvFX]; ~[3ɬ1Q�)vA@i& +?GLD +I$Wan)eT e[õа(mTYX^Y=_R R(<( ރ)GK+DиͱcCBΥRgGԮf*t˩vP9Ūb:Tj*Gq@ +lf ^'WU cL\="2كjS)`klFYZ$xJ j5o" +38 *,o�$kЅ4|S+i/2{!~솵|=2=K$| 6o'5:^&_'Rm-^tüባa0'dI$y2|- 2}7~`ުHthPc[m !dq`}Z9`$@`M+WR׳[_M).u헛H]� Ek봷͇/*$%;G"Rf@Q2#ã>},‚R}Q쎝WBNlhQ&^? { +.>5 N<ϧ4,� +Lkp0&>@U]490 3܁*YČ!):)b"PthX�풙"1ZPjTrgħb^'~'JF]V_6+Ձ氺SiDь|i>}eaw#Zq֮WU)q~ﴗ9$EW{ "1v/.W\d C2ĠJ$7YX[)fWvSsަ)fH1P<%OsR*kk8N$8͛t!h$=UNj[7sƭEg U#z8 ϧ@5XoY`\c}n󔁽OTyvط6.,m%{0z7^gn-^-a4/u +x%07 +gXn%wqygu +>2\S"EPO X2G�IP釻yT/n>É/;J!iЊařE XF2%yTEX‹鞇SGM;C@Ξ?Ճ8+W _b#B+ ߒ/xwZfcx s JKWF:-/}spTQtMbUs";B4kNYW@#^R5׋9 49""3wg$qLpiWUhD)\:j{^TK"` ^3zls%༁�Uas*l* +0b3O~b~#bsQäyz ϗ 3t ӝ:-|ϓwN@k}"Fw7{D,4 ~}bi�(s<LF 0m#VEr>l+Ȗ#ۂ]1c:2NA +Rj9nf&ң^Y4<Ӣ/.긃tAQJ9A&#:9�OYۦ?۔ޮrpUFGǬD V//mm&["5ote`) =ָ͙yhowۣH_=?)E=Y.s]s4={1Uj R3V'4_)\/bٿCsWV,KrawƏ }UVxZ?M=†yV`C]Yhb/{U D�ط\-bOW9 lnxl슩Φ - ӷ&#Śv-VviyZZ=Yԁ,f\}~kՀ>aStvs+Ӎ9%B]d,{cJXQBijY h wKL3ڦmڣ/礉P3gG]T^ +W @M=:⒀%s._qdfJ !8m`Q{yNu | -僡WN?.[y\G[#k>B[\Tʑ LqGhsN~ 4d ɚ*`vsy8d%XeN2zהIS"MÍvI=o{*ȍ#Ӧ- ]vKY0Zjy[jWDe79lV^/uލJdU\E! @Ԁ!'\⇧IB\�E ~EWeճv0dyǑpTib 8SfwO cTN?gaؔw~h}7bw5 $ؚt,:R?ԇ +RCMqh^Y�E~;NgaE\-C9lݞT5Gڗ`%o˚87 )/Re"zv{PHBmLS;m쨬f j.˜KI\#q8^JJi;W)vuPZh +"su+, +CzRDW#7B~i#E}\}YFn"X[4zT^Aj]"b+5n'%}WzW 'g0V*Ywg^E9 {uy!fN1{ 3xw!0/,6�Rȳ<Du](kFcm:t7!X4 w=5g +縄:D?)vr-[&J|z +EֈZۓ"fiD" <P �%Jq.M`X!w Cyk\&9v@X4`siy *KPx39W=e\OosYc؄ɼ K~Y8l:3v/QݮLZ҃_S^5~&Ql-K /?d_`uA[mdu']ռ:~jXnhU%GQS1TμŔF(MQ[MD*ᥕ̶ZN/4[`- +~T[Ǫuَ\$tvPĿboU~yWWNѺMDgspݵrCִWp ~tmG265H25}RjCMrtaةj܃uR_6$s{R}~Q@ lE]WP׮EM^TWB9Gzʏ 7n'̶΄7R+�jk~Ւ)ikI6I2/pxH�wu`ˈb*�o !,bHO wGqރPG|G#tnvFy =w۟m%; B4*K#&w:0'';K)hql.Z[z!xnZ^d, +t]sGac2eGOwdТj]#$KAL`9Ў-nɗϷ>v8B +vWS/\$dd(:D//oTJΟiğ82R5y>F6nq#i̴ Xȹim|w]0 Z]A7A2”VpMeYg2ո1n d#I:g`[!'~4]N34:GCC&t. (3ܺ;<%RN03o/D#o}D7cU't!w~Wٴ}�}]Sg xȀVP TuH$i,A"mOA:(ڎЭ@Ank#Ѣw /A$*3)k�8q DD3̋kxx9kgsytgOɐՆ@U +9]9-Q7X=nL癴׺3!Hޅ6jR=eAħC[*W?,NVZH08 *9]KJMZnԙV35 6:jxԜj\9 '}ևti0.4גA z^fjEа{ny,At0uHCa+GT /ొKz9ݯT:9ne]͘_BEb;j0d=] +w2iEZS'H=xgqP3" G])f R;'L]a ׆ Tgmf!D!ؒKuP/UT7ԇL #|+mm\d\ #Uh#{9ZObj!()rbj*'ΏǧgMc",p5q\+FsDcӑ*mqK%uKs͒zIݵşm s'w-i%\C{2 JE `H Pje5LMdCeZ5$FQZ(Aʼ+@՚Ss9J>J� 8 5Zj\V.l-`Q^0]U46E�?)Nd[:n<VUwN45| a%Kw}�̋H3dƨ?Aa)?n 6]NGT$.e p`3<!MrD�‡oq>{ +yl! UQع5: i8H?|T&gzRޙh6  *${J~<*C.є!Hbú-v'AV%ɨ ƄV Ր$ná8*qTI>r_2%_J}C ը.A+#Nk1"z:N +{e=&{SquDs?9EI*C1PMW!y^+whNQZUVOmъmo0Z<d{t& LMb[ypJl/-Cl"8h):H9ےITƪ:ZQاpjѧڪ!@v.rO, %u|TrR )i~"Tjѹi; 1h + VDC|j�W]*l0=W(8 YK7RɼxY {FBLނ9ɔk/ӚW~kŮ}4{̼&Akl2uQgS$-gT}E5뺬VeZ Q;Fu֡ wd d h&T5hnK&m uȋJ]=gK~Q=! Zt0!'p<'j?jP{2^lzQ`T]J'N�-d I^&&n̖N�xXN[7`uF^CG 8c)-C4K= 逪AQyiR%KtI/XQvllL>8=ҾǷ[R<y![f+)B\Z"BTin%P 6 +V16 , կ{ 2 Eű@߼HZ%oa80&t It]vg@}ưDiZX,a*2:¯B!E?uOzs%B>l#YК'Ukߩ>c:+%V@K,Achb. Ĝ>>G4JASr_ѵ~uJJ@IcmWhI$_1L:GRe8ϼB-MMS3R:\o]8 xJTpKy|T@_ue XB=B?{mg|@d_;~S6K~ߥA|GHa`P3*"L}[D)v,n�^DNIMgO^7D`wYh=mq|�9_X>[m+}z|z�_Z=?[=5W}w?.wկ_ūotw{׏_?<o7+?}}n_Wi~=x}{h$Z&H͖!H@WxLw6}+gHzȁ.ҡ]hFZx_څhRs(';8NH˗.aU}AbsG9-FDhyL#�21Il|*Ѡ +p[SI'岣Wq'!6u(#)J #i햌Yk1$Jg`ԩ}.5Oⶸc]+ev*ܸې%D.*J_> p/_=͕b2~F-@ zE/̜a`i.\GeƁ@`FQ1S=cЏUAVih 1i1m9.cl7Q!BO[(O')s_C:og1:L>dU<3}ȭUTG@AK:yz<2wR>~U^ 3nr)fI帾U&7wYF<BzJ2 u +_s"Z9DByF\ S*fvS<b{r_HQP057nHiHX_[ +z9hjx1^QѽУS8U}Ӧ9Q\@z*k a0:_FqfMs!⡩] +B"tZ8ڈJL:\gMNyDd^ueiޟ]QMZ$# I-1 \rSo #Ωj^^+F ( +Oژ}jk\~oLa"nkE*RH{#:^ 2Q 6~9@QFDhp+1<itJiCkGh *=iX&[Dj[1a&YK8W}Tqh q�?iX툛S1p|04сˢ {߫aH;"v9B CVYNΒ4_�|mH�=fxD]ƻ<眃zovpt +s9<v \{iXLjmZ.vxO/Jq8>4'qiҝ6E><Г!:J)J$`͖2׫C-ŊbGjS4nQlBz$.\fuW +6I?u)+ :;d&߰5 +ZgDʳĉv{:Ls) <IwXl}[$tc "b;<-*0s+>P)%vn"-_裷kY'=O^pke�\ ݭlmAB:븑r|n<ejT%~v,TEXQlv~CG J>Cl  +!ﱤ51d`Kk#S=d;=&(z{ˊ +i V 84Z+hPKfp;THe_-T"j^!a|2'0;ZC=U97<t8h1FyS\)5"Dk.iTP8֓$*ʻu,|$Ae4)ƹ @|Aff?fb4%$C{HIB\"M1U0㢻 s}c vrv[-JK(K=Hڡd`0MjkQY5dpC)[5Bo.EY~DkC6Ad'ES0] ~ DEW-ʎ^ ˶*9^٦2p#_'6dZY}ۛW's6%Rq)DŽ|7"J1POWy(2^Yt%Jԙ93f̈! 0#<eH2wKλXRPYrwEM|D{ۢuJtɘO gc{܏"/N C&`|R_{W=R/ )"8,&@Uxh5ʮ Ɋ +EFB*l杺}H@kS菆il3hD7 }ƩDsa3BJ8!#9r49<�YbX &g`�y\Y{ -qPhte(=Ss;mg .oIB{n8͗r$CY#slIUb ="%k-j$n,#5%H9Lg>ʐ5:`ycЕ'y3 sqnUSVtNqZE ٩ܘ ϣy+r^ (d; Ba3mU|I~FE1%H ~ŷ/c$o/7?~~||O>n_|}xś?>F}7'<zYGմ_5G0}X8m508䁬F3NwV$j;]']n7S~E գuQ4�cjD 7/pQwˑ*x9茞}SὉ$䢢*ٞ֡x|# )@sBW^)E'V4N[?݉fu7a#px?ޅÓ +L2<G">Bb-`uڝ'49_WSI mb,ޝ(O6!^u6GYW+ hdnwdpyPNLOs*7RP)`4J$$[Z% ϵD`:'28Zxt"?TmY8ᒺ a3r7-ahaI~Sxر]>W$@n gaa^i~)1*,!7(^vig~bG;y9FI+ (=!!s=Rlٿ_ٿU><=gV bF +3/<Y.5B|cV$*9$A2oy&FO]a$Vdch5~]5/Q2 \d WBm}gln>@ʔ uMʧ4Mo +Gjd&#>6P/cQCHZqTTSd> +"VNB0qTBmc� +qQ&iڦpkr>n}z|Kl$BUMdo^SF`Jàhlqu8gvB{[冮IЩu}8JJ1xXS%Vd/B,yuiMueFufQ؁$4=LXqB8 -s^sI.kQXP\nFƖQ]7fvL}R e Z FEcϾU*Y,Y*/� endstream endobj 221 0 obj <</Filter[/FlateDecode]/Length 1250>>stream +H_Lu#('mŜɒҺrc^dHJQȵ:[K5 @x@C࿦vњ )tA˻Ayׅ΅|м&Y{I>u7 #��#}csxJz5mDRQH.Nw86oxH'osS}��@t'M5%q;蒮-A7Y[Yj|yܿ6[Hu]뾮&�&}5`yTw%ikSeG8v<8cmػHO8\��ӭ$S[+Tw%ZJK:"!Hd=ϵ|>6�t}i\ޡ?.l*\߳e_Lff}C8.hg.WO�� |0gTw)Vom=%)YLY~lk;ţ_Q�� ^nKPyD aOScQgvŇ{'{憎S�� :Hھݍ6<? pt)pھBշ +��D{WwH?nl*\߳GnfVw m=\Q{['{^gըS��ޤOH8nU8ɤ?HQ}S޽N'HnaYQ^.6n7 ��Xn􊬹~<4M1SU\t4\@_?DKrﾡf��Y?7-݆AtNguA7YH*/0ewȿ_[ʢot+B��4m>S %i.Nw86ox s姑 o��ӏ- Ztbw{M+/��#v;_Ti$H(6f/Ua��@/j<k{~>Ӱ?H,F! om��Ù!Ր˰?HFbŪo��ÿW+Az. ]>_�&}!랬O}ð?H,Gyt)X^��"񼗥7d|Rd0yݝ_T4�O�?2 endstream endobj 222 0 obj <</Filter[/FlateDecode]/Length 895>>stream +HMHqfAAPD){%KdES/eR6Kfͧ5pI1!xl:d"?x>1M�7H7s&3trqo !=;߳Ůj]=K�ٿ&Sܡ݅Afz:k|!}��@zKo.23(ToxPo�� Tu=+; ;Ǽ+vh8��^3/hw!vQ cew��rckr +e,r0wC_㕍ڷ��/UHO*B~Ɩ!^pDCE��> X< Wl4C7��}vP +zGa+6y$ m��qИh8XMmcBck>��c>݄Aض?[Wݽaf��u$M; ?cV]!4sվ�� FblMN ظ?DmߕW|;��RC}y/F|. dغ?j˲仾un} �@j|2_,. dغ?fbEZ<Ծ�� 5}CMn]Aıu=ʷ%dhC��0ޥ[A=69rM !}�HA=6Q\!7X~�Ԑw^"Or dؾ?n7]aP"V۩}�x\wg.ݦ=Lp5DCr�� +#]wfv` �/ endstream endobj 223 0 obj <</Filter[/FlateDecode]/Length 968>>stream +H]HwqXdV Uhؚ4db/F(Nl(aAOxt|8tJ,j aQ E/C9/\pBM櫯P?5VyzWy; ڦfkǷ��wk==7E4n#;Q{k(~��d1˃l־5DKS {˴g%��X.-RdkB]aPWt6y ��#\bAHSȬ&o{[g&��HĮBB}z8vPn�}UڷbvGHa��}7SynMqmA $حpLW/o��Sn훂AHc?!o3��@Z>qhBb4͝9 +��#{{+p>׾);Qp}TY +��s?w}B_?.Xk@�ɾy4=}K?/v❯Kt=S�fz6՞AHsp + zӞ��`icݾߛo!C_W*ձ!Y{�mH}^}JہAHb{H.1pٞ_g+��XirB("MM+OjW��MdO}WJfx&$_&,Ϥ�� bɾ־$ǣu;L} 9 ��]?.I?Tk +B'yϸrLkd_��.ZG.~=}+?Y77f#_f|;ۮlpd=r?]NԷϫ[`<`�U-O endstream endobj 224 0 obj <</Filter[/FlateDecode]/Length 1210>>stream +HOu!%C-RlMŖ4nI,׬9D4L98: +((s·M6{<_+w>j@Bd gUaGT0;xD~[)BKݶFיcmN{99}k"ׇ|NY[֤'֫_F]g.��nU9741b^?v'n9scl� XM'yHF@ -~Nk]zjh=/={�Vc=:z/KF@ Ur;*N&|G ׂ0 �@2{o A%237x?);}c)}Ͼ> �@}Oao#++ tLՖycCXXZp� X轫{X0yIIܩ{?Lm2[bHGݥoVY,-"26r,� XL,wyzKFB ;QB:,lγ1Qr@K?Ka~gs?/o2^=o<�~BēYW(}H׿o2}?fjjp^s؆3'boF1knO</퐞��݃NW0}?Dhj.k?P}?cs��{VۣŻw? 7Rz{ϫ>,.*5ߝU䐞��޳z+A{rz!ޟzƲ1C|�l~{ӦdoTb?U33��]Ԫ޷;ߨL'$<Ci��bwh}.]odb?1kjO,��=YޯzJz#3x3B|^�FCޫ_FG f ++ɾ3�@7{_U_w?BX}Mm��sfI@@ f +cy֥'QW� P w}jWw{ 3|U'5&Dz~�h{4*7Vz?`�u\ endstream endobj 225 0 obj <</Filter[/FlateDecode]/Length 915>>stream +HKQc]h΢M";EDaw%s4)h .R(d,љ +𒥥PBv+XZh. +891De7;osb3Wă+7 ��_U;)&5?g8yo8��Nݻ0V3ډ]$bS3`q=o9��N,P]Hjw?Ma ~'LѾ��D ˧Jorlv; J4O7w�h%=pHoJjwӰ?Ma̶bdy_iv��GfI_&N 612Mi]~[�6U;, қDbS#ҡXy-7�h3кuvg;Gx+Zުw�h!-iN 6k/fwoKIо��Dˤ\80VAl +#|5Կ��h1Fz8pvG;G$#o=c�@`GFġ~hc3M5)w��-҃҇l)J83__dj~�� vf>\zjz7ۀAl +# +|\MO4�h</siw-Ħ?oTr]��h<+=(/Em 6n}t@��-3˯6ay9[L}_{.��`uT߻]l)qn~<��DZW?WݢUl)șqxv4^m��"qIޓ`۰?MaDsJgh`�; endstream endobj 226 0 obj <</Filter[/FlateDecode]/Length 933>>stream +H]Lqٚff07H\ЌyJ;s#NVFar򐜇VyT:tq.pU.ro׿Ә�vlt9ᏻ̝gAby*2}2Mw,߳|[6Zc;.o��&}{'n?MԔO7r3gv#��HVΐm>ovsml6uMHՍ�� QkҷN`6#9rR䝿 +Vh�D9Kn͸?MHmh$8ޮ ��UK1ҵ#ڍiɳDbf��FJ]{ڎ4:)��uo1r{z̦q$ל<s Wn��%.]V7`6#ʮ^�X0&ꄆKNn[p0|{s͍H@י �`^=;<8Wnl‹Gߜhw�L<햺 i:@{ D%��XۥtLnlm5?w.O ��Fvtk4톺 izR}٦\}u~W��TOyBvC݆4]kO/n ��2_&niӍ?MWx �IPuJnl%&ꄆGk7�HWt+fӸ?&CZob��tI$nqɰʥsg9!d^{Xݩ��~>}S$nqYM =h <|bnG7�� 6dzK{U 9)}`�P0 endstream endobj 227 0 obj <</Filter[/FlateDecode]/Length 1196>>stream +HLu?$i Wbk2[V+؂̒\YH6a`0@=; +F(A,Gl5M~O-#!ݚDZw{+iukd0ڦ<@5p]YS{s,g\ߪ>~(U�� wǥK'ݍ v.o{-uf]Qa>)y<J{Dw{��!ۣңn#\^dDu;F^ϺS^?̩c��G:TٴOw1U|7S瑞˯洦E5F u7�|..(7GYEaa~[)Yü +թ^O�I +w/~ 0)C:nüQ|W=E�1~fןJB\nEG-Ql!PIOW6mHT+Zz[myZ7ΞΦ}WK+Z^m,g3\G��ŵ:Bqw3uo22mC|I י;lw폌]ogU1gCY&]�XtfA#@\K~?@{Y^Hpmί;T'omcY"y>3#�?G&IoKu7bpfWK*c?ގy c/�z*@a~,'U Vﴩ>}u7 +�`=]+Ya~J0|GepOS��/- [cpV:9ܝvj<U��;^?*}nnY^WBկG+�]zjt%0Fw0gco<[l�0/[qXұ?%~k^mYu �`^3rHOuEwa>%Fc/�H?#% 9?8+|S 2�G!yMaNzscCtw �` ͥnts^]χ<4=�>tp+2Y\.nf4˦io�| Ő endstream endobj 228 0 obj <</Filter[/FlateDecode]/Length 931>>stream +HKTq_]jצ FD"J\E"&T9Ym2MK3ǩ3YFq&hER3̂At> ~O17 ��:~/7xAYsj9L|=woa*הp_~�Wk1jhwAl +#8<8/1n�gW[# б?MadOϒ7,7�@hZ%=QtbvgaxĦ?2Ľ;[h~�Gc15ѻa ?MaayŮ117ǵ�>|~[ ?Ma,çw��}N#s; +ayaQ݇{�Gz=ZQzAA)ʦ{gkw�@ϟx~+Ǧjw 6a %+V i}S��#OK}^&$Al +>|x{v�FU ww 6aw/Lk)=�9]lKCչ]?Maiy䴽n\E�'^~0e[EK'mە݉�h ե;byK7^�y"uGc#X�m*w_{=)8@gh8~�x3⺪yڝ`ߤ\s#lnuC== �urkwRAl +ctȭ,s}] �`JĝQKu?[/�dK/1yj:^=hjتߛ�; v7D7rߵ;&-`�lxB endstream endobj 229 0 obj <</Filter[/FlateDecode]/Length 1033>>stream +HKwЎFm]41qnƢn6k;E6*Z"2fZYQCǕeN)cLO?d+@il V`^vރ(V'my|/x\97EWlM;\r"wΛoy#X޳k%K2Nh�F[λ3o ?)2txe T�g>7o +҃Al +{f-13ɡQ�IoKKKk7}P[%xoj[ +�Dee>[aݑOpb=�LL:omܠ}C^bSڧ#Zu@�Rޖ־!H/)o[|c/վ�~ِ+}b@?Ma`s"olտ�I?KOkoо 69[ +,�!sot?Ma@%`ǿP�dOk +a[jx�#},ue.)<So.8?:h\�1\^~־ 6Goڕ-ab^�/׵ u;_׾ 6Ge,6Cq'|F �^$+=ze�}bSUN'txG �^$k+o܁Al +OR\3WH{w�db^-{?MaIJXk r=�/5 =} ;Z vEC7:Z +KSoη6e�l̉_wo�܅Aܚʗos8tP֏fɨzjcTain!c(_6Ưo.6]>d:tGCw}ϱ?0Hfٵ{33�HUzvOivÝč|{vw4|e߿N2ϱ?0YeKM#9}m/�sf endstream endobj 230 0 obj <</Filter[/FlateDecode]/Length 1310>>stream +H]L[ew(Ⲱq,scc `(&jsY*^ 0A1LYj) 8̄`t:hMɐ]? кhy9ywASn>y3�@ 9M9sv\" f`-q׋ AWυnHd5?Qe=G3k޿-pQyy��J ԯNxw=H"Ō9,?wX/.O6365i|+_aZUj *5�x^ +^ՙ); وDTk ?ު~6ϿI~?`b`arۥo�(i)J mHsp |kMx~3cesݬM/??dcaw7�:zqTަ^ }HT,73{ZDF.?3bsPԽo-o0\eO<ғg8hv7�-wPvtz;a RKT۞~vE{^~%s+CY !pkuuNI-{�@N.36.3ԧ;Ӱ?%P +鲲Uo߫>46nd�rzpzw|` R QW#q^?c9 ]qtv_}�}OA6fVqH5Qᬭr%HCutƝ9^�LtZjQR?`=6kx湁;�Q?N /7yw7`z%7D]T7�޵&IKޝ () :>E쾻«Ѽy��)x=Qg'j/DI`)Jb~("=�Lj^<?o _iium�D=P/8ʽAް?%)$F%OIw?��OKӕuԇi-%ѼQR? *Lz5߇|�=qԃ:>w'2` J +[L~vk;��lƨιzyw2(`@(lץe`l_&�`f슫gzwr` J +;(-zy��l{j7,Tfj=@ϑ}O~/��%9$+ 0�IΪ endstream endobj 231 0 obj <</Filter[/FlateDecode]/Length 26322>>stream +Hn_wSkrgfe�A(]r,D�YZu@ծ KΜ9sfiulgu칧ޞ~/^?۟=fy۳W^^^>}pϷ?+~NiKoN}{|;}6%y/-W eVfيݦO=uk%;?eޞ|#+??,Yrۘ<e>ziL7BloTbjGfU1\=dֵnvf[T�Jm3�im>7g5;k2e!tw}%t͞jke-�:Q=yVvJ[S<Oܲ7^=Xi|r5X@[{Oqyfs+qP@HK qݵov:d{澐#U"Kj:GhQiP94:@\S`}sR q>LJ/6A#ex 1ET/:y O9d\p4Ves i5bB3@),9/ҨJ/(J Q0=KĢ7 h,X@j XEVyfs4ڱ +ޖוz!/v\TѳM<*(57FhYL#j,}FqZP1矉^w{*]JW,JPj2q;)KJǀ+wh[v6Bh@$rhr:X%ne<!^ǶQ5|7=ʍ]pr%E'CUU}6Di%=w*�Ԕ%t0}6K*E<u-ij kʜV™ }Nij2PMq9y`R̃dD9 +s3gNVqD!y] iIqS֒x̪8̔YRhuZԻ[!]90U0<@`{izw-T!My`c[#γ|u3RB++aHoPZO_㡳 ƉC GU3hF&z@IRp0DM1p e1JȜ|ꀑ鈧Z4Cu v2W:}DEf(Ւ7K_%!]%!)dQJ1X8 + YI)=/S!g tMWǿ~zLJ뷏7(OW~ûo^\|wwa_^]_՛o/ޝ}xZg׷wkۉr$]$e8=za˜ߢQhWJTjҮk^d;>CJ,߉+hIM&ʆ$0tk-m&D$F>IVXVFie)4iC%I$R%.[\3arD1͸2E[L6, d|&)Y(2欆~R4R'C{1u2d|VÙV!i1ToD r?{Q{ %Bz3Rp(&I顉  PHt|q.qRH fBh􊔗̕`\OIp_۬f?K\OCbM*Urd=C@B(;|l2er%(4o qDr^\^Iw 5`,v~ W32g26e5D�Pi2E +Vpi ^r�ePW]IU4~QO8{ZeP| +}tKi),Z֞d)&UMLS"7zwV( 1 iX 1Ge0F,? eU:c~y(]b$q}} —dv8/n4 +K^QA`�Bgqo:Co@l '-ƢņzDG>쵮Gc]sÔLtUJ%=%6E7(Y`4#$&]ū+UL�PKYeŠF�c�j0h$I*p,-+4Q17cԦ>J>abC`UoB4$Vƾh&-%AEhmZ3tZ,#СP5;Az&8#`ux GuI֦P߂hMcSQ@e*Opc[ %E)DR?@Ѓ'TʏߒI)e:;Ӌ6p%CSz3t]uOv39\)L"ӛR8"F.ILFEd44ҜR3hcRjĊKJ!jn)p5jFsB*n{fUs,DED ^.9r:]膾4Rjj'ʶ {U1R �_+M�'m:nT{TZffdjC| uG@;@~nC C\A.,b |AU ӥNn:D]~Py M%Z7$: ܸ֕i#eC6`pShytt{x~pcky C艱)L%`Z N lf?ږ cG&u6*l3 >ck+wf Hed)H%7H މ(nH̪=ɣ]*#g2? + ḁ/_I }+2 `vLJ O"9lQjVT[NB6auKQ.W'p}f[[ ?/7% +=A[P! ea{C1:J1S c]I&[K{q|@jM֍H\5 +pllf[R9jtA3e+d+|B<=oboxa7j[L'y=znE㕉t GNUQwB4Ӈl7JzTv~H0 5t7\.r 5? BCi"SJ>1ag+@hT_iq;RBČkƃVm&\FQR&[ G)=jrrFLQӓʉSS7E`'R;3Af1h<'7Jڹ +\:cj9sJ#rk C_ɜ m K;֜Q%=5HiݚugeسMԶ7#yhCEyK:KOxcxDu{Ѧoy\q A]Y89er`=E&h {qlj AC-i5GIv^ +(6bI׏At;*S=奰֙T]Mvsd#fX2 $7@ԂTT`*շҟvu Y5ܢAz_/[Rhk>l7#vسF}H){X0ʞo7zuYOcA(.4ݩ J-2b Rد_^jW,@ ` l o=gz!P46ZQ^yn6\cceM[6:{ +揼LjL%T�u7QT8^bRs@k 8Cuui$0f1M4H/GJ[G XjHD\j<ijtXdzڧz=" �XyR'Dҥo +yo\[μ26gFj/?lB}wN$OjR֧`BPS/SRiqJ +UZb)䔪YPRVڋ-%`]sDRMD%`U>Zdz!@hjP&)F' eON7Imzh̲Ҧu5r:)c MD#Z8|HV GDW%剪2'c]_J�|F>"n714ۂ8 %Y{ [/ �qHXb*)w<'m <Iod=䥀%Q? G@=JOLUb U{x*䑖 vB[H@K㧛fqt#lFu.j1p| +{t>@1=>JGID9S=em~WiMB 6%>g{̃T(��K*F fZ.!Pn5qt3|))DGg Dv'/]3.3#U3c6f|n{gg[xr%tkzԱDd7:m_C9[Y-o,PP/]1o&%.C%?y=@!rT\8:1Vkfqv3jwQiq٠=5�B*gF!F;87א~K@XʢFֹ{A.1v~fM45}w$9rvɏqZnV�I_-oqM^o|cԝ!p賵7?wit*JnEoYrf ĹJAn+V)7wP1A Mׄzk\\dЯ9.%m8"_v<W\pl]D& @'}0h"ڴ 53:-j:~i.X�-B +8##%m�o�!rqH |)55zv�J"% &3wQ3,u3vv|;<^}&9l@ 1`QA\1#hLeUip*Gry+�gqkR U%>e'h5b0)Dm61n$4'i %�@MsR;h^r~ ePf9ACh*ٕ:2ȮV#! 8좧9v '%= +9 +-ZQ +*xNT@7X3 +/3]?rB&8RD)'`ԹlC2nG1dИu ^RY\ch.)0[g/|0ݻ?`輅gt( @1Y.hy/eDƒA!@S-H2%@il0;@Y6.E9ط*�b]՛h P!.4 "zۼ p\$8^QROo$s@րqr +ߨ֠U~Q|"I;IAx~jFPys l˫R9+�)UHlN}(My ,>Fu~ BC +9Ɣ%BՕC9{:{E\KCku`at&@T&Xw`Y ؓc ;KAS%o!MUpot\}FdUwB].S4Z -ћ w?iƏCe5O1t}cVկWxar$[l7|Im!dɈh|sgC$&Yk߹PdĦUڸN!~nX-mHl9Ŝ(cedx Rkj&$#!+%.lMlü̆`(ݨ J�#2pI!Ju=>3VHdA޵&^r:[Z| 2hAx99+("IB'p$'#\1Y (zJ azf8 Thjз MK24- ^W؜B($'YOz{b@A8, !uxF^E  wD%~̹UΓJ䍕80):GۘGv\NÈ/LZ|(:GE]c9꣛8\ʙM}uBJ- +:Η֭#^xQͅZ-Tb rDW xZ.!~vf;["{IrtZb|?? .+v8 ?y;p15ڙ :,|[q;Ђi&VoUCntW=G4cB~|vC_H<}EB&ʎ^oB +姶 +_۫.t +Fc|Br\#}Ze+W*NNNl&4}ؽQ|%JGƺN?^?_W6ʄlg?\ y_@C(F*; 7ź, ~I L[dnDe rjVP7Y1Ebg_hK=XE!Ywm*,h%'}ΌimQ)1볐jd1 oD jչ0Xk. ^vvn? 7I:'^0 +no/n7 Y$xMPQ;)}x1Q#\4wMR5,tbz*TjԎ;NdV_XYuyI,I8dx}9O~[_d]w)\{b}[Gۈ\6#Sg^x;dNԼTFA2PTIbU 6]GKM4}W{kUuaAI5]t,ӿyկ6QP`,oL̵[i]ݿ)2h"GۇoY0E֏l^e ?+/uѣ/<PR3y֩ye)woIKmA3.?\I ~pxHl'XJLa  +Hh?]{.|VjD/Kh4]ӈAH rX$]\fj`@>@A&=X%oً2E UĮ8^-jצA)Gw�olg,ـݫXv�HקH+5RT<u8+Nf?9-/�1,8pX&_ *8zIC,kcfa~U:ެM~Yĉ6{$wem,D : @`V(Dp&s}0h?߰;y!O0J٘y*GaJP? m?:LF*S,�e,\zgr#$DدOʼ^FoHw:&PqM'f0 +~nv) /o(JI~@x Ħ�*d9u*Z8'` 6Nb:W&VģXwI/-1sJ jޞsSaY(Rf|dU:}C7&g?")( %HQ+hN E4EcO{P5GH%f ZC:AcLD )ߗsפƀ, @:j3!u?ګXr8ǽVӛ[m)h ~-9>tH0Z˘ "0"C7NARH +<rbҤ[@,˔<(]ڡ͕2J/s# +?aB'{wHACF !ΩK&a@.۷k9Ca}jI^Z +ϪFѕ+:eLj:pdTEqcպ`^ 5:Zާy l�vgD…r)M|]A(5G% &y8 tp`@gI|*E<Oi }E^#6 b˹%@[&mouY *a�x]. +2׫s-=o'oczɵ"qܫRA:R^͍C&x395q +ӫW><G^\YR Jr\ +%g G0�aC%,U;T<=W'VK [smL駑6M[םxm-u&T#.]2MՊ/ܴdUT(gƄ;oL Hz!0O-} P̩)B5lphF3h:?kf~{W6`6Կ!8WQkjLAvJK={ ("?H.)@?ڈ&|W +,w<C~CٶYG83sPTÁHP7cx)tQɆ YR+LE3uUJ1n"rW!% +ݹ9 JAMz50v)[h'F�w* {I%bےsWtqHch*бwV]rCC4^ڼf+%d0xPԀ:` B,rtd&M!M;ּ5�)։ [4:T +JT\Q[ΌL8kɎ +v ܷe2u/e`8RPHp9\l{NMWx#! ."մXeě≚k}Q Xx#فjtFZtcőd,wwE#oʆfʉdәW&j”2<kbM击c so;E?33ZAװ"{VǙyp%cD67K +Z)BRSE/-DqXֶXiyX3pEȭ\͉ D3b T|)ц)?G`9Bozn|~x0/W?ǟ_=Ƿ_߿~x峇w7߼>7S+[c93Vu: 4fDLƠUfI0W[@ J숢ejH韉xO$.�{-%)x*SZWvBF6%$]cLaQvмY[ $7_K6i`R*v�ᄱc s1 F9l,YN�N-J hw,&iW(h8G9Z.`c:%Z 5.U6X.Wey V,!5%M/SC[ eƯP ΘEfû WƆG�WFYRtzrCв^MdD$T^Y"yeݞ%yIV�b1c +0i_g/YbQKHPEjxn=Zs@k LzTg*eKꍎFs$HHޛ(HfMRgN+ "m(Ǒ=, ?/A/ڛkKg,KʪW5a*s;Z[5;o45 Ho۔Ijyd-fTj�2i;fP:"3,U46D]:*EK)`giPz 5HN]4@.oyCPyx2Ss*)}Gz1g*Q8r'c@:r!G<R5*- .KlW#aQDJ4s };H_cJjM(dH +_Cʨ mhV2uy%�dB$w`-$*1Q(M(*m9IQr>gk3MU]d$dl3\FKߩJ)NY1桸٩Ġ`ho_`"9.8m.͐N1 h}΍f)a7­neˤ;ʴ^:p0顫yTq1"3B7 ,hph +x Y@BHZHqS@JE)u-fS]dm ZkD䳶0`5ytm +ZC5RjY\Fh;#'dHA-'ƞ�Noj ]AAYK:Ys`n!D=v|!W g#(^EA H,Zd)= Ec1w1.g+[B>n^NuF9-#_Yܻ^YݙLUU z9U]uƵV@ZDKj^^:tx0 iѵ5"vYFѤRޥK lY| +<XKQ@Xaۋ&Fտ/y�YDj=Y8PܩLTӹj׿Ӆ3UgDg n"qƏj Y !?/sd@{Lv<rr[wuN떂 F| H$2mcTknH|&̀tɨ3/%E2Ҫ[ABC<,4Mg<r|bpv9>Xs >_3[+e8nrObmT&ՏtO +[NoePUd8o!+>g>G":I:3Sn-}FqI 1D:dT0Rc%0}D+t6F.mdz-߷ +_ʹTTUe A}zO<<u!h%1mTN}.>qoؠ9.>h 1-p-yrMb"6ۃwGG9e5MM*\` VctV0 vPJ^Hdw-y?M(dqѽN3%50T\Zbζ" "ګRC ]T o3fP.Ȅך^k۟۷onG~'w'U*@`em'rJJ2趔o:8CkݎΏ�+<pѸ# D/.L`;_ywnjTb{er +bLpno7l:*q iK c*#$t:tK|4Gb+fPN%]3vyAܱ0lFm8U=M][38dX%k)))(pjp)#'gk"HhF9?ׯEӷ; wӚa'D!NJ my\#}b�C)!Fdc")å 1^$rwzJ0~H{/c<kzHOFϫvRX--kwe'?#Oqpw4O=Oޡ!IwO$}2IyќJ{-`%lʈ�W,p:Ks}U+dcuv#ޣͿibNgOD)^m<a`VtFi<�\>1i+o)ΊT,<qu{os|Bj^ +Hc8OOdC؟t~.`+$kއO.u&trfYXrCujj: u|ݥv1:DOVk'n(ε~,=ߍPYPN"ks|<"<vUtfLU!8ipqWv+ϓ+Cagz[¼PO)4:ҋmʜJ r"1G8tF�/Hb2wd o,rꃷ:4] ŻL5{le5]<oYiMwVsL#d%Tǻegvl%pIm/J|v%-`@]Tߐ%VVJq>yqO˓I~h5^tlG:EJ} A|hrG vV񍠫B_k_s6I 'J7MR Ӕ< +O!R VE`f6j% t^ztC3_6ןo:݌#L߂]Mq#`#vP7<"BC1cZϣ ~R>GYg1 0 Đ7)DZ?qh"#*j8o[%* ߄�z ('tZ1)`<KEsT1˃^$h&J$hQ3Lk-?ҶSs]cG�N:=O zK/Cq|a2�뱓4?j �2oMgx 9%0Axi,7_f #mΌO)A/ayn[wߜAZ' {ue%/}R{ɒ$' y~gV暟9 MݟlCeL˻/i+B~Eu@-,4hzk,  Z][Tvu:ˢ퐛t({E6/hVsH 1kg'Hr�OzhB}q[BkR(;ޢƃRw~J'(GAe.D]73\{("R:f>^Cu_1L`8ۑR&5T;"/<ץd8٦tv? +/�Y9Q.Poc�DOIkd.CAi-X3iRg5n|wѨXPwO9;uv,ҷ X^ !D(ΐ>kzp}oS#4i%V3"Ȣ ި5\&<N�t -~ C.^5 K>vPpu7Rxmjf)Fy 1#<kb}<2 l{"4t&$VyRq#Jx?.,nY5@Zmڃ3qq,_»,!ˍpLs]hu�۟Spa5r8am(݂z\~TQ DeMGC@;t|{k:_,&Uտj_EcXe'VZ3#n&P<R]=|$KIn|ޫ2_-tB[) \X$$MpP)x^c +P`8̓1+T۵$yCHХ,3pL.MBH)Sѡ=&uI1h- +hw۹|@62Ρn$_w-%7>w-OZ,|?~Nkz߻s3fAIg v6DL +td Wi!uH =fC)^O;Jm}J" E4Q"^[qK}v\U]rr-۳% WԮ&{n"O :eO ]3t,~ϛMe$jG P:ҧUrI2L"凚9�<vBS8F+ BST_M^S"|`̴tD.II"B:4\DA/ՐȈȑ9FYvFfAMֹ0{]!F,-]:/Lg t;ɫ85wѻDJPhqD2m|AND!2]Fĕ-}lU a"\gwv^skdF8�bV/lb-nC8i|^-^#[TE!Is>0PTKmr0MFPJϡL\=Z+, 2r?Fcn=g+I-}HL$"`ss&jPM(+%iPC#Y((ًYpy>rԖEOfy>aއmЄ q!X͛əbv3tOѕ$0#Wp8-Hk9;CItlMc}ݾ4yV3GjPEm+BPCpM;Ya&}t]zI_OdN-7Kڴ-1WnJybT[I.VRe1GJdU孚$͚oޯEMDb)>$;Uu~@H+2U^s(t5ᄦy}bハ-sa J5<rkIJ氶2_epfXYRqcG^2|TXMÙA[*q;-uC!)-D-=\,EuFo9-.B>1}RKPNԍB`lmksj/煻h'I]�kehNj;DZl 2h#G.>lNdecrl]^PuAti +DеmL([ʰJYl�)`)D;"hKiSݑ/bhk}P.jŜ\SzH!1NsփFɜmJ +I2#.1eJiPD%;�-f+~b�u_ܹ[fYXEoJs̰:V;//(|!)F]ʵbIk#7A0t륚Pn+w <Ntb]dR.B%Kdrz&;"2zq<} ?FO&"Y 2nh~w#U5ǿ-P!}*fImLI#Dt!HbÛj1YB<ox7K1( 9CEYWM +UXf&v7:mmɯ+ +A .KuTkN-BgN9Ö͇Gn5% *OhxదyI)nAfv#x4o ߻Jf7fD<LvM&;&K($s5f-qȣDY5liMt=) dHTE{SkNYNJ"-PSQ)4Eq̽ C2OQ }Eڵ>Ǐ '}9BW퓂jɣ wtRO,:xͫ*(쥈XZ)MG5tPwL ޙi5[OP]%mekb&i4 B >Xm֘B9j$=nN1vBD fqˠ(5>z"pvO,w uEi6taaݤa (~ˡYhf</u)6ߛҜ bI6뒂< \e[aU@(9Q饠 +׼SNX`%~ko7/ݥ|MЧ1[ +e'+qɾ@2,+*ɬ;.TM+(EBeդ y,* }tsȦ$q$R /^<\ +"-t+9\7+ JӒudI;Bl8U=Y4&^fܹ@v>+md2oŹ�XPfNiK=[MikuCTǓ;դ~,%WC9؞ +|bؔ]#ykLp5#XjԄ[TbN>ȫQI\3!TdL6015mG1lZidd7[ZUo"M뿴&; Æ$PeǤTCq1O<)!٭μcKV٪zYP*|o#WD]5<U]ƾ@4]ϼzͥtEU U$kMDIW�]=[Dw&* +4zgyNUقCozc.n_0]K<N*]>X8PGB+^=G 1|@K {3'[k/Z1t?ve-o}S9{VѲz0 l_ uN�0_cj "j6A+N9.l:lt^mmݏՎZDjC9_:͏w_2Vw",]=,ҰbFT>q5#>dZ'K]߫|Y*rs-˙,NCݿ!q)oioy +,Y{ &ߑW"̼�Y<[~q� }�.,!w.GVYmkK$,|{!$$yJ\99O;%jOl)n�}JrUN[Lo_ yr6Sr;djp]@pCJZE"b-kl~d_`5#Q(/FL0UA].wmN''* ɶKy+@!K#DY~V\y`%uD?)W1T>rG]Q8ʼn@^9tG0D w|0I5=Z8679؊vn6/lg\#|zZRLpW7 6uka"Џ.%'~U,o~rwV*p2N~Ӳ~GdYsq"ʚlw|j`?yuTQ=Ll!QIICi Bs#9)^cv(Ynm魏bPa8JIdEWݐyno źC%[+}: u&J4ˏwES6}y #y˘�!C0Tpƥw]/QD'CNȥEc?+,uZ6 MZ'3-ʙQKd4O/4R}t 0|)!Ռ\K +#CV(ʕDNA}ΘbN$"J"V&X茟z5{lۯ +czJi"j CnC6a .}e8'rǮe,rCЍ[fSs܄?I-8r\K[jQK<(J +zծ:E)Lf !yU 7a>Ր ЃADk +L!Ql 㑕(MF'6q*7Mxt_ΝZ* .,x]l[ {ƌ:um yӰtɯ;Z1e|K pSM_%iOa"B<N}:d 2db2z(=|'Q'zVx_yo0|W@#WV 3ƬESAwO<AL[BƔvVs:eC եrm0 }~\y¡ -/4cYr<*6L+=}dǺ63fY+;Y+؏hҾ9=U.!VEyȊt胺/&q%/̯ZH�1Ui㝒e^z5HƱ`:dY+;Ƌ/HP^ܞ�S+Se'KgáFNf!Lw s0*ݮN8i=(Ɨrxd3,™ u{! G]aM +~KM3bݙKTi ޽[ϳ]CѢbf)UW Y=E5H]fQ ]\{):őF8m.ٲ,PH; +k԰U3AEڻ,/B{}%XU6uiꥂMuxhU{E؜fIgOL6k<�,{;QV45Cߏ0l~&EwadE РNdV?C-g6e)4cO)4A,'kiUŻ｝vqZU3fv $?]-J&*EVqP.z>$[h(HU\Cٿp�[n'~mo Ǟ[&y4[<nqvuL #4m9X>ڣ| -hәi A@emxbI(GՏ`%1YsKf璿lyY1QbL˵>xW<%i9X"�(;iΖiDM-7%~O&(~jGUZF| #~8_aM'0Ԧu}Q`sR9va1ʮu>P釈; 1i ^GDme~B3YlAz=%Te+Oj/Z i /b(ǁ LFf?ތ~恚<X~޺݇!5I^N}PC꒿.Sg"伶:\(w:mX&$owW%{Upw'a�6V!� 8VnNO<s$w=6owl[p۝a,37iw)^k#J ACauR%э^.uY?IvH C M<kB%UC30ݪ:Uk}[#팞D`:yTzAg 9,l}~;f8+"LT]1R/{X qE7m-E+"0P*Nѐ,. s2Ɠh ~e*v Yh qusBp #c+N֊~j$#T%ΰڐϬr=Hgz` Ug/:QG4vk ZHJ 5\h20<.jܰKI3䮜<j 4d=S#Kk;k3*T%XM&F1jL(W);SJZ*˟]/?~y|_,]1Fח/ϟ=~{|/%ewY:lg5yU(awMqj>=H:5P.+ QL|aDQ{ }id?7Um9xa7䃊Z~R"RYԶ;M4dNL-47^-u ]ocXeh&1<Uj?StKFL2,u'�*Uƭ0H>GC9?N!P�P/'N(ݔ5aOX샱# v,-.=)wXnr4<FMUnq2i~0 b;vB^ a5%M*j̡5Dg`fHƟgRXh_RZՃ>]ŢLG"snJA%o $ SK'i"El:F cP[1QuYHU%3I~1>z+jfIV NpuR]E&j4h -7h{,*/LV7ـVhȴv`F?߅wC9(]*W7'R mHRIᖁU' [Kl 1JqTӐ_ַOXoӄy->i~QàVPtyw{}e{7۩>7DL{CCUJH\zu>OLr_p0{yVћK:L{Evl~3#V DQ|2 [ +0(Pɨ$c+V`�t}& +v=7VlńIBKWZXqQ� +ѦfEoSbd=q7ϝVS- )+zWX-wk9eD)3zA"BKo[.-SXg(c$7/! fjr o%20CLLhxr=No9%J{vl`PVdxOb=Ƣ> + +ܒKZIu!V`\jc;L_s#i+:,%\ rjPF-5qnˮal"AIku\{DfPZl)$0@Kj4d ޱ$�R X @hQ"IXYGu}")+\r>LA|8՚}וc(]n[X֏(PaNcK�"hWRZkVnR[k@ORd'w�SL=℅O/=t,82<N& +fʎ+eS<*2)>&hvtws>qJiW>3*Q.;d+7rGŅؤꎊL:!!i{J%%vjdոo1~J3Rk6K $3pV*azsK0RƹnE ̧rHHT Iw>BU = .<F:(άDl'_S2핔qE>L)֌)Dљ}MMkm1 9Գzd3g%~]j"kTkgcөfqE.˻ֵu!;U"ggYij/Ʀ3Xu5w6if]f&kI�iܕsCE @CطfV`oLAVK$.oAD9G�},6(;yi݊nfHSkB(\j*>KPsXsQĆy+,;j N�{("DXaI&i<%wMf^j2U;.F5dgXō�ji08ʲ?BS{M1è?s=hkj+EݗaIO?<0S@Q@M@kow;dG^bxf7術wRuSlRulBBK{mr0ۧuIҩ>ׇ%<1*=4t]TЧYJ4Oޢ`=fJZ<v\W#ݣSXyZӿC(\y/f/?~y|_,Iɮ^_<>>|xx|OtqgE9yD(( b^2ŮD"kYs#{l&\|z5Ie?qcڱ٦PCu|c \̤a)F͍+\(. +Zg� Z +gf681~P%< uE~?QG=.YaX+$YGXYI,i[%ŪO(skyps~e@.D`;w(%1.jdn$ERBϭC8Q9e+RbK90X@Uu\zQ|v-7S8k>>s67*}dMOP#7x1#)i|P /ݺ+~NH@~wG#ə0A` , P UV80@2Urյ¦h%8@+VC8N}\P6B]U&Wd1溕16=+ +xCD"\x1H,8�G~1,.< Y! Ha{@ʩ[8j'e[h9kF ve\tOPX%:HzMS2%>zx ̚XsOM"X.*�7[) C9sh KY @.3KN1=i;Kyg1yΘ(FF%.e +TNsRd9$- 2j@p);e. Q3%alt +bP=+/k+F#IRɩ M~zLMXP!]KsG¤4} ,_(PRbX@D +* nk]G1߈,dXec+o$7ւc8[uf^dKkIl�7{@LeՄ+^smsy0lL̆{P>LT%WbҖ3^0K`\Z cC7_1r.% ' ihjJPT w%nW!CD AزoТt>$ C\pY$ّV丸 œ1ssu`v啬]S):\/G$Z]إ⍦vJȻGE59gsSec~sM4Z?Сy} f,_0U6\UHqm +#9sY^JȯHj*mc`zh'kl(Nw1:Vo,c@cM;1G\9F%91ʺ/b4$&I#G{~+ܤױMƾ+:|y>& ց34:RT>[k>lZxWoRCjO6#[KR?Ԯ*ԔF0jʪ6M}%$F5N!hh:!miWf qAmu(#<(mB6ًyPkuEZĥ f$y̔ e@ϒg8W,RbwGʨbjTV<5i%ۇy 8\8Iyb F +HL;XRXmDm{=:-)b]!k|FU1Xְ B N4]qF[!{y]RAGz ICUٖۤAɴM)֋e*2.KCeú+F8{q%C;bmFNfDK q"4O'.Ǜ׈j  6B٣u|b{ԇ}璑iJe(P&Ґ=f~f|&{&ZtU7 +cj9I2GYIŽ15miZStFU�b˒S-4H9s90S8}Y7K(-A#E12WJHm%L^nI'!/ť8i5!ߥHH93&wH)y&ODP32GgS,,3&TQg'՝.SHzĤC@IޯKt֢*3,<ZREuXa +JlJH#e,}X F@N:\:G@ + bcTB.?Q( +uXkP*,KJ8#q1R +tr:jn#٨>)/&΢sd&}=ծeWQF QSU5Ib2.gZ2.EV_w?zۇCW3^}wsuw=Xگ^z:t~Y}O/n}o~{stO?|wO}|x{w㧗ӫwyw7o>ݷWO{xXW_?Wx)qn:xtAk]û~zk;U5p@)^@dEߣ%>g4(sͤK5#8F'<sPEfi g!Ԑe9".КP4jO,>d%C*T Sr,Tc)礡6ꞛ(j$Qf>]f8[nz`d!_#iRíAbhrLs +2�NC(<VlΆg둅Rc|C)XB|ծMoOt> ~UD l^H0iע5 G w:FWP�~x=\o~�Qړ$M i"e3y1nŚD5 �}in6PXq#E$U&:JWjBLUI"VY9 olΚjj|uf}+)JA�/o@:M)LI ,l3hAp1Ȓ5rEUap8#J90MutaŒ\YY7q haqlYڔ aD4j" +ElJ헓# +tESiUA.ac�19t2b"LK .M B͗e#0c+4z\}x.!9ubȕPORM\/sWɞRu</7 +ųE-Qu[rTU؈]y@콭x.^CxbֱQH71vcmŹrǵ䆁 +Џ<=006n$U8o;prg8U2 ͭ{heүD<u'4tfUFÆaէCQ vW{$ss-C߾9~l</a ѹȜՑҮSS쏞)?ߚNK1 99jxrkd +Fjj +Qp#G L<ڗD-dub!=Ga } +j]t8:ͬ +Z5<!!tX=]YOMT&wbC5ۅ7Ng-HיhA]9B d.Ēi9P]U<C]?mI%RŵAʧW/ܒqc-@8׀bRگna俛1BͅD{88^=%MWR90sݡC+¼a; +_dݵDQмO-15G)00z<6aw>?7C 3؈f>\7Ob>DpNpˣ´/\ e �}:錿f%QmUL TF֩`&b>kH:n{q'>627ܻ\oI.=2@F#CO5C&0(QrmPȹ"ws ,/ECRv'uqHZ-F2J|+2C5!S4Q=N"+jFr/$])&=6s(� ׀ZQp"[?`DxYo^^l qɍ܄q,YkBV4J�-G9[:+> %<[(Q N}QACpv}E8x$=ޅ|ە71^q0K4DeJga£U7َu,]y^±6RVVPzݐ$#B|6KN*~Hgv s>0/}B`*AdgJ;EO77W<U̥^>.Y8=UU $b)\筅F&آ]1󋼔}(Fk]n3dW-MJۮЏb +ʮ9= JQ] ^+W# Pp`!4\`E߭u{U>VY?�[kA endstream endobj 232 0 obj <</Filter[/FlateDecode]/Length 953>>stream +HۋqL.Q+EYBI +C+r(%7؃֩Sm,;yvfYu*uH.9-{BrX{>S2 (A_Xvl[Az\hCy]k[ȄuǓncN,��7^NJiw/ 6mx<s^*<HN�$r;;vb@6%Xǎ��}CǎLiw- 6lY_$oC� .*.ݱWVdv'u}��CzL,kA7펅Ħ?M&orF�'RC35nĦ?mO:ǵo�{jf+ݩ)hXS B;�~ךv;Ħ?a`̼|{�~œP3͵Uc] +`!kgh[D�Ig'F[; 6Mc,2݆t"|?X�~yp.W[ aW%X�?ҝ +Ssyڝ ob@.XYP+h�׎U Vݕ.)䊪噷MX�3'T^ݑ6)AS͑H}m|qR�mCmND$,ݑ6)a7p{T�M?CN;?Ma L޹eٽ B;HHHIiw" Ħ?*ȻUU-=lB;)MMx=$GJl?8MĦ?|eE&ݓtb] VK�q0Hkw ,ށ@obSM�ğ endstream endobj 233 0 obj <</Filter[/FlateDecode]/Length 1171>>stream +H_Lu_HKN6hpQ ͋x4At $1<9rpx<�r`m5si\XWe Gls>|?orwZU:cvgJ�7RL r^}c6E#߱|]~[|v/QWz÷*�0ʏ} 5;ܠ2˱DoԿG '^I${Fw a[xZ6ɷ:7^nK%Ewa<'ku-� Otmð?IaMW䪺 ~w; =R}LzEw &y"Oytj;$3ۚ-}ӀG &7z;%{ԶNehg� +XGzDwAL +nsPkcv*w &=!}!S]À &7^Sb{w/o�O]b{2[w" = ݝ< 1)[VbryȿG =H6rvDAzBwWOAL +(P^?oy�g?NwGK &Tw`#w�Y^,}PhܩbIWZecw9�1mmֹ,Lyjo;Y �ϖ{y}mu; HI׼u>g +DD;;:Xo0KV-]$l}x6dʻ/=Tat|Νv_xfU8R:|~VUXGnm|N]w. $k5cM틾BcdkVXX&jY %彯zO{� vFT4ho,;L6Aڢ+ӼR ]?f%{9 ßL~Ӿ][7nRVQg:5u~##rz#mzQ 5nBV-wk? �^ endstream endobj 234 0 obj <</Filter[/FlateDecode]/Length 3388>>stream +HkTT/ST,Vj1M@X  o7#=00sgTE&D"j|&mLDsڵڵw^$ZŜ=}:jj +D6-3W( g +Y~^.~>�R;e5 BdavJh.>-ڃ)A^`@ǠF A#sʔqajYmDTHmz7x[Z2x%-RH? ?!�AϠkh`LtlZx`{/77HBL6gSj {Ws~|OQ}~AǠgq?0&:4:sx>unB�^GbbQkqզ9[in/'!gzC`ɑA DŽW-KcdЧp5h(*NƉz/u?" +7q$K%aJ.*A#z݂~>Cđ@قQ);4[=u?̫Y(\3;e_!2:OЩB,gu+ف 3#h:'J?p$o-\~B̧CLv~2[ Ry%l&@B"?05}77H4WӪRȓwk YGbL8[|＇p + +뾻$y}Wo%WtULļylb]SHv@yѾxxxůĪ: Zr'!ghs#Zs|VblNWO%yVۥz }onY!Z1|Q?ؠ~o5fE$TEzxϫ~"x߅ WDuVr2AJ(!5h^ I{,1Ei;_k8h?Cө6_uUǵZi5o\iP XP~RIz[J.O8XH6>]nn?yb}TKOR +}VυҧD5.NR^j.t|cjLVj{AK)?T LK0Tl^Fr+2gs9 4IUWJJ+o\1_r;*SAbrPQmQbU}wSI+1?uUφ9?G> A&tok7:4ā  ppPW7}1^duAǶK<HSUlrR<b&{^($Lz<M +^G4ֲ̇.g5&y.VC,Fas +Ftj1x\+5e|磫�ϲ^> _-t? [ᙆ @JfALO61wR Ӷ?)tȮ684_OoJ"nLbYQşR{-<J -guM z0 }%ԏ?ؚa3[9\YhlN{/\Ѯ@{fub=\_ cMT%9 +LOȽ!t_ ηW"Ao%Пg�8?0\)?}=Q)w X[lhIT~-Lrsv)?/&}R*r1oEa?ekxSI;G{Y(%h-hϫ֬qޢ@5n޺/wi)Wyv>x>JW+~=Cd;A#-S +ߣ!y@gDZlppx +g1&NzbzF3nn ~@ɟT!~wdX.v*m?>>ۤ0~\f+\\qพwQ:-p1b}s씀4yC-Б̝ckg+!V }XnR_CW_+-/qǩ5BkA?~~K%aO|tN-7>gojg!jUZUJYI[Gv;7ĸxgB-QWXiz&y:gP iKG{>+]Bx76|D ߷!ȋj)Z̠pp;g2WH `'M立Wfy7f{fEnc]{)< ?2;|O$tx[3lFr>?8ޟixPN2sKMmg3JWdoї{ گ̊ohV=Fg+RiCƨK-6$skDA>r �靕$/u~]WǼvP/?(P#$ŐiE US@vIy9 zMyb}]VW՝˾kʻ-'}qx5/7ӣx< Ы:Y ~jJ`DmNb 784ope܀<FV=R dwĔ +am݊m#P`\aS) �֮v%Kl\y53Au*HĻ7'JӤ_*d 0N"ߍdM+N#wor!н01]ݭf[qm. x{n⡂/w2 (@Q< +phMa7,苛Q+3J?ۑ"3&7-<IvHa$du6 37/Y}݊EKh,ܲ|oPbf wjVW-4<Q duj [֭bӊ۴ X9lZ+LPbn^{N>=eK'>Er!d;֮~Ê y XׯX7ep 68Jsv:tnA_@:Q<hc '@.Amw6>98dR)˶ZޚM+Δ,w̰P'дzfosS6.kۜĄi<Pm-@]l^'fz677, h0� endstream endobj 235 0 obj <</Filter[/FlateDecode]/Length 3278>>stream +H{PTǯ1UcjmNҨ1mMcDkTX)ZSѱKTT`AYVXV,v{Ԛ({:?c=؛^o`@[.|f$J\˼1l.r$\.om49rpE6uat=TU; V‘+*>?xLpkC#"sɉ'κ7{AF*τZ\c135Bo?jRA]i+h +[`O?H1@YS@g֊q3IuЦk@?@_k^ݣ2A!@ ώecYn3PKb,D 9y"iSn;;u <oRܭt5= r�<{&,gr*wBoԸ&DOce{/$PP{A 9 2 YN⧻CPPPA 9,kUqZ8r])L]'"ȳ q|}v!A!V15nȥڌCcl.r r=EUl>#WYiLenvza"B_3" 13579^CCN#xq QKmNr[+k}EQ5w<?f'3'YKFɴL](X -3#<-'v2LO zj*= r_2͑KF3�7)fG(35.>/TM=׵rcD:A[_۶E2B� 97Me)SY_k\_?3\:޷ԍ2s(}M Ca @BV PǴ{ AF ?0?"z)fr$ks`<3-ֺ8rmjuxm4':&jG]0ު͘{hU8;65ooGkBk̑d ~?oAڇމ+xkc(>mrÝgf8#�w]} {w "HBM>_W+^ʞ zCE;jUE1:I?^$JVuZWIz�&<7{c<W{rRח2r}SW[_= r +oWi>xЪ7䊡.MN6H]|kl4ҤIœjr^ܻYƈ׮54?&X4hw[5av]xr=;**v^dg;usy� wMQ~+3?Q{7]VM,S:IG.֛ᚴWғxx9~y6SV}^Q5 *f9M1;?淢wjRlш91…n<ۀߜ/kPo9 a"B_k"�w]@w32A!6πfM'e륿չLO+N-/sʜUB oZzĮ]>A[[ϓh</ݦF0 kW͇u>S׉s? ^C-)z |vsVF%w'n|wi{Ѯ?Z@M+b/hϜI_w"aO RT%ۋ ǬĵxOá|YFtدlJ[]zZF3N;$ +dS6zs}I⏞y131|b1\Ƃϊ;=?Z8rUfz|@6rC]|Re+g[6=;"MXyVYnw,H["IPPP{AF;?0? +"A^Q=[FIFɕF$ku-4icc8pNq 9ܦzKi`?a,eҹle;q,vh6C8Jy8cU&ʝ:aOv{I7,>f{hן70.c/,kQd`0PwPNan=  y(n) ί,y?fIרb�- ~ºCnX 0>$gBsiN wo1V+?b E K?`TMsaO�_QUIGE0 kŹ {u)EN[skNln]AB=`-Ku)"4? v/ r +o�qN]$kT:H:LNGUz<xh`�ҭq2he +R3ٶ[#@ n\зg<Yvxt 81ۼlۚ+b: 6lV8m%<zuC :+P3Pz3NxbT< G˺96.8cEr]b~\63rzŔ``6_\vUOaӔ2ɃRnLתR\O"j?_br�Pc\gqm4:R?ݠ0޼ned1<WY : F̞a7Vz@qtno⡏A@ +@ :͏Q<1hc '0S*AQHBkW=v/c >rë;ԎyԹjK6_qie;?@xޖ{@znYq�]{/4AlmV\!ˑݼlK}KzAW֮r:~?d-2KӨԸzF +ȬUSÐEB6QdCqtpݲ[)1tu]d2oS5i|Xb��z endstream endobj 236 0 obj <</Filter[/FlateDecode]/Length 2083>>stream +H{PT?dP&1653؉$5q0h1Ɓ1DMj^- (P京ge "ib$ceryf~3}-FGrD<٤U]/Bײ[<:H[Ms^i>Ylz$ZڔϮ=&UؕVg:1rOSS~왱]u3e2ҜDzjrl5?\NZB;^v|wiKֶ㙃]QlT`?JҖd3pl~J͍YeS: ?=Rw~։7Ϻe+VCk3^ sui5śs&)۹ҷ۞a }~ӄAI?AsWqV@.}3ajqƱ2@.K:rʱ "-\߷G==蛨G{rk0Pzb狺LpJ͍9uEm$C uTҬI;Ϲ2GkM'%<,oR +V:5O&BPZNiw}fԴ'ȟy|#43_vB JO1-y ޿ߪTIr7<f+5Urjjţ+-k*�@QBȝAIޜ?#Ǿ.63,g0~ӶĹJLL?eA|ޔ9 ' !w'1ODž{,ݮx?wh{ٕ;W {r`$B͓kʬ7isNM|<eWr33{#y.ќ�~9BȽғ?&_(6+9o5jy]GO$&|39~n6,zjB=F0Pz!3a/jnkn_هt$ +;.I.?e!AIx')jjnVi/:q<.&?�?. +�oOvB'1݌/\:nnĻI| IͱgooH~!JOb 1сbΕ¸FM=z/t~[;"7:k}/?|H +c #y0Pz!d0?[@.K)x?4YW;c5,?J7ꍺAv/B<]z'M OWOht?hC?Z\jjN2og0BbLtX;&$ũ.Norl+#uD=QWuFQwB< ]K}Vj+Pc+wKrcywu?=\v+y+{!V& ,W;E['Dv$˟Gꅺ~#ꉺ=&x.' +!o%?Zنk:b(\2!=e5}x\bU}jwrZy]1-P҉Pf|u:=Y6c>7%1ܣ}&Ap#`hJԵ%-]z2x k nn;'N|RoW^~p'%Gxu@=4vkQ<zD{Apc qᘵh6cIPe{d{5fFjͦt݂wӑӘǯ_;o9B~N`bc/'{k1p,p sCݗ{$DW'xT0dWZfsX+.WE}Aa +'2߷Gź~c ca';kk >zL3u%~L}p瞿XIzڼCUC+�z + endstream endobj 237 0 obj <</Filter[/FlateDecode]/Length 2522>>stream +HiPSY//ʢ HP)tA@dh77 İBYe]3ttMM2Zcoq`B@:1U%'߽XAW;k{+ܼʈ>}F?t~*_9O?j2xY*!?CA/ _  }FǨLepm\ tIIx?WYOOLM>FX<׊ rZ^;ҲS +Qy9~hP豹PZWO}ȴnoZƐautaA~=+gzz?NhZAp9/m:[ MF.gݭͥ2iR( +BP(6S_WMs(4O\w$NA6YBP( +ukP!�4l|3(X%Vi"  \8q·Ct}7Kmz%Ơ"V!:͋^Y>T;   =#7scÅ;Ӫ/_#mAAAAAAAAAKQDTRlFu=m{w\-(X7Ӫ}׾=/mkF|+wDJ*yy:edDƲ  +ٳR^+J^,b.z옄,'7jRT]Z}BJ|\ع vLn,6\HZ.;aU__<|&as$O'1*l;scUT﹯_U8@{ό_@snH5mmc?R_y[ K]BMڮ 7jhXө<z|)Z//=:Er6Ӧys~>fԼZMELx!εScGSDxxCW!*l='Jb<U)gnPY=i:{Q[y}|xlb^[XVUn7cO:%ךs!ޣ4ZnЏh#wo<)11:"ߙ8<qjJC<>xin74U_]gTvޡo7M\+62j0cCuf&S4FM W$zљk8EFt˗l12]&ŅLcĵi@!WwDE^1&o9ZeaFZU}Xzb, Q>Ԉr3z\IBL}OE_gLp!uF.uݭͥ2i SEfѩ>56#DBJ +kC} eZagX#*) +ޓC}nivگYc@\Q |Qy(ݝ};xxc#=1 6 #,;ac)1I獚Ԝn) BNVxTy*vzwU!uc}y<xq�{9ŷG^`g$Xs`Dޏ5AdD[w[s);ȎhTݺM[=};s0_egdhziU6]l.2G,_0s!1J+d +<6827X?L񬔽kD%Epr(ZtHeRw.ΉF|+>΁|Ӡr1m'&8azy(@+l-2t/3zƓ +<#*ג?GZag?0_#>U=]lHZ39?pe@ Xt!007hbjQ�ioÃĆ Y3vY^#(<>=F\z5)=N!s`jo5{;ZISm2Df !VɅA3Gp6GcرI g'DƺsgW{⢠9E3i Qզ43zPűy*w-WL4UE0޳=Ψ-)&e0wիݱ:=v\-b镵ScӓݶB +bH5-_Ո ;7>/=%iK~2,b~UzZQ2QIQ0Ww8NaԐYRy[q/&P(j` s/ Z*+˛OOʡlp>|UJKe=v\&J +/<݁.ꐢ|<xW�O_ endstream endobj 238 0 obj <</Filter[/FlateDecode]/Length 403>>stream +HKKUQ�õ M$MY@qPP X2\QOālV:M!C }{ ^WF~zmq~Ymu"g~&{[Jʢ}&e|rSΡ;=-/bcoa~nGqjMr+ FTndFljNKXO/|.?{XYsk;ᆻE̜&g7Zcjjml +=\[̭GSj|;yq155~mfWݎNj!#F>s_RW=8�����������������������������������������������������������h�9 endstream endobj 239 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 240 0 obj <</Filter[/FlateDecode]/Length 266>>stream +HA0DA +3xPΫ߂nq�����������������������������������������:Ұ1 ه{LM@>|_2UVa}, ͟q}lqON,v7rd'[<>wzÛ?>`صbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصQ 1�S endstream endobj 241 0 obj <</Filter[/FlateDecode]/Length 516>>stream +HNQEnё=Ix 98:3s8:$1#[Ԧ#[ҺlK7$&nIlMؚ9&5qsLbk1}oGC߇7=1#[~6ӃX-bcfq|(bbGnbGZbk1mE/~qh6 š7$&nIlMؚ9&5qsLPkThspNk}dZ}Lk}d#۔ֺ\ikfmHkG.a6ۿ^? >h5#ۤn9:"25rtDdj :4su<fix񘥙1Ksv4hhhѠACCgG6XݱcQ;SwǢvElᑰ#a3cGf͌ ٰp+sV.í][<qGGO <= +8 7&oAnLܘ=1y�Q endstream endobj 242 0 obj <</Filter[/FlateDecode]/Length 25363>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-F+Zsŵzk=RѼ_2ZcȐ,~~y4|Ykr%S'-5n}݆%^+禎wW3 ~Gg;,.f9으&9{_0|z̾dݦ,ٚ+zflVj4Y9)?~ C6Z(5Cvg$s^DNU$Zwz#Y\moŹUi.WW7swUgȝ"՚Q~dJ+-sĬ04:G0yM]ʺV[v^uЉrvINVث +ݝlFeM +Ӑ+;hq619K>+Nq{"`\8a`> Uvd&yCԸ)lږpN*F04#v0|!ՇTލh:fCHb-L +E~p]xM?IG{6{/ēcpU]o;eq۬t"Z$ T+u(<5{|$&m"i�"}{?T}I5PƉEjl PX~Nݖ-}7Wo6JPFB:Riʴy3dҽAA;Y[;[(yŶ6TLxۯW??ӧ~L+q}?_/?iׯY[ծoׇ/oPlm1&XR=P{�-?^{D5ݩ9rF7ZZ5͎ !sޤY-T;%b"<Yt;)/7,QՄϘ@\}&=׉숩sqd ̭Pv.9r$.+Rj)2waܳntall'ׇ> Ϊ/}!3ΈD) )5xP8b4k};"@9O2�A=Dihy*ާJFY 5 �L@%ShkEtӴ5[.0GFi3&# z*)nADj 2 `4j,cDl@qCC!/h`}!F<bǜH.Ve5ʡЗ6U;!**.$eJٸA/"E?FTI#,ЬV0�_PƮd`?X"|]�Zg'x%?`.aXSYqSCN[edO'>g')9.fS:~RoH�io^|k~v핺zﻄđ !ùُCӬ/UQ^kI#ZJ  W + K%B-ED]6>t'r^e +Ye-arFE5,^ $+(+Vwˬ}ݽt@e 8Ub Z̳j5?1IҔO az6YEo^)TJA>'O'Lƻʙ~"I/iS麱# _@;OlvW<]Pߐ]@?[RAQu:8D랖s375NHzMT)qh òJźj-G_gє`l1.iY9h@ m5*.*pqw%l u2AXPk?$Lz"݆ +[/Nt0iy@Nai@>' ) +_Kף$KZW[+bz6*T%vE)ʮ;ZkW\'xhQƗ:<Ƃ)ES2NEl{],ScQ̽y>y1ɰ@k+z +z"F--ǛzYװ[,(є2!c[IJl~ yUop٭C}o{OcOAzcZj|n$#wij + N2!C<$sdIT>i}pa�gD!mے/:'dX"|)rSU/ 'P.V<Zid;OCn=P{tqᗤ]ީqUER94_;�^+!)hrI1rKc'N5l*6G QC +j(''fuKݗ٥_)K/gq(!"q`v"y\Z>&Ru@lׇм3o5)z1V{4$N |94K!Nh!Etx" +<Q$-:#moU.#)"Xɤ;E줢iʏN*8bY*. :M'fumm v&D)I S3PMZgi- bO<6 GY6',zov89A : E f$ibƕ$eE{ 2M%U;I7)-8׆7 /'ZJ )cט,ơZQ;nH}TimkT*(4eI-'ۙE8ͩ�$f5jd{񖋺^\Ks[ez 5%vϲ=VE,`9+,' -a$�LЃD{u_+N\N;Q&'})DEUez1듋Rϴr6kb3Hձ|rKVU栬Ou_uuXB*SW: +Sڞr}lw ppWaNn3l-LYz_xn_E!\ҁ9' #_#"iV͒وZnDAD| )nמ3QL<(}=c-=7-jDL}g;*g%/ڣQYk|1m^ŴiM䬻g)V^u0}:vK9+nUΝ ˞WC/tU y0)&cP}F_1Y(HHσ-`~ݺ[o پ�ŷߗ3[Qzl@L);}Q^mq\zn$X?] c`:qgBٓ7[醞Zюˎ2ENwan$_{caGvz\˧"  `Uok=Wsq1{!1]K96QسXz\Y R0:y\vri<k6#HǫYbB͋ȩT#v!:{[BlQ1B 3*#IQY|8 2va^<h菕)t cFh*=^~tF%@ THE6dEVe}OG\j?]>P-c㪌۲oh-lS 29Hh<kt VTdI0i'6 /Xi0rT2a|,6AE,[˱o|­kDv dROq< nBb[y/ QPk=;6ee8bsl9L8H֯n1nv~H/Ԃ;/?o&>X*J4eV ~{eԆ5ۣEd$kC^KMi`ps)\ℷA['cQ,?9T*+jYo z3 LDPFxʹ(m{"ڶEDkH^Hs.QFi_I vonOV׫|4EW1|/?>_C)0낀Hj|\}cD[9>~t^'Dz"YӣT~Bf^8`g*b4vy߽E:F;m~ޅ\˯VuZ觍(Jj䪻 T\LԫG!–XcP4OUԀJ~k4̻H2X4ԝO'Kq0@~\am; +( ;vi($>"m Vʠq)Z-P| uP-/&*ْA< R vXa G8͋[l8)IEH߃QW"VB;$vj.;10֦ʐ+>>| 8u%̏x;JkS!;} Q.Hr:Ouן?aj5$yQFkd*Q]%*؜^ |pU>P -q KbN 7"aj']1n[ k xfhsH;羯MZL^eq`RU238t4Qrф,N)M%QM=p_PzھvsWol7T5[YӶtۡ69WWɤEQ5AS?oS$:DlS7IJ˟WےGN'?&EbPJs$spqFJRi~mliellu+FUkTtԘ~N5UQ}HcBy٫[^5ׇo.3 +>GIˢlu7b1/C5e@}IAP^B7fm%MAW_@Wj<X 婚cՈܩboB +#:5VhcP?/,Fa~<k4b8+;} +nc=sb+DuU R. ܬ #cI\EYئ(d1!;5 B摽?ظ҉NmP]IB:f=OΦA`/ ٪1S* U0Wvy$XRL!=^+W+%RA屺M +D JeRug)%U{P#PGȯMHױh"޴0@_ ;?l0`mh3'uh sݔ( "v?eG +Ož_Y=HHc(DIlvUEp=ۊAz1DǏʐVRv%$e`jwibm_Bf9@q<@Vb`MB;Ai­-'iKFp2+Pe23afFln z\WLe'u7-@gx=oF;#3 lmiX35{-^53xx1q-*(f;ݸBUc䶠z{&Ym匑t]Jd OYx$WCq-9љOR.`Q7oo~|xo_v꿵Ͼz|zh>]췗?~ 㻇?}ՇO#W7yכ\~ۇo??~g?=Wxx}x۟]B.Ѯ?ݯg^z}sV+_"w/?~{p5t0fwiC6emFP`i?3d5R(u^|W,gnaK=c Hj55w cFƳ\wI]PEUm] +RseRة>ڒv%? +$�)g 6Z$Ey.=;myOM|zG7z!4ɘ¤ +Lo/Z[UD> $,? &ǂ-ܯOdF0gC&hb_d0Y2|%x�NʲS2-._cqVN0P2fmG pWay3Y!D rݙfjR D%lY]kҡXY)I.܂,�q稛:~=)#Pב(5tMO T_M^uu%u&˧w*TT8&ФW΄D7mGJq7-ɼ PZ-w\čB.bKSͺZJ5�~S_Yp*ETQ˅3kx8h�Pn@.%v +vn<,lHD~,u͑@R/kʊMr̓E>54-*Î? ٻ.8Ts6X3reGWyW.r}56s ZA^Yv�2R!e]ZGdL5?wEo5 8f[-\5)gaO3I/K.Zg[($3V,]jg?(B**tA +W;ʋw%.MǺ;!5߃!,aIt$bz^ * +[y GuP!ZBW"IǦ6ãmke"bn! )FKk8[G5sB@- &R1m|=٣u#eTDD6k<pyM=6obH5Q>(KU5c$B c/pƞQe7-W3۟A<z?$ͻ55C9ڹv|7oRaq8,Sk&itw]V>z'MxH{M@RdC!d ]ܛ\Pi2#Da$[zG [0͒!3 +) 4MV5K,M&E5ZWT藠# 7_t&C>iH킴ykPn\%=1N^3B +:Mǀk0ThJqjYǖ q^ }}QsL1c;N`e/w/>u' Wt.F`n)) \Q~DaوG#%KTlF#¸T%voK؊n)\qُ2__=Ky:]G2_: l _)YʅKl]anfbLSE� Qò h.ȏ[È_\ )/bN$\k2t$E&YJt`<ӂL�!ϖ.cvUMaZg7{RFjm&9D2尨A|4Jr^6"[z6R׎}bF$!l|CVeqZ>+-3*U>\ 0ӻ*ˣ +OfԚ*Fw>O UZSo<Y;svq-{K?Ԁ{"[qBoLza!6@g')f)jǭb +, ݭ$%|#P91'+M`&1[V- j ~sCF.VTzqJ ![Rēmv:Ppw-o@裔h!rtvO8{Qk*b%Q)l*encQU^זr<hQB"j~X߫sn+HJ7W27ݳa1I3ZUi LL@}:[՘b>'%Iv)=Whr؊++>pP|ᤂkIJmwjgE@!hRVHl[ + zBwNRu 2JeFMh@*2z=3F+V-I*!ghsҀ*=\P + +c<k譎xoQ#d0W\K$mW=o+ #I�M@B'p<WU+ :źSigvv^reTL #n$J5>iSO9:{JExEKI#nw (ejyQۮ607PUu!dkT&')ɢJ b~/z�WR*/R>gK<3Ag ^pĀN?_/o޿n?>?ۛǻ5 ]ݼ=?_q}{;m>ܞOϧW7jٗ^%;9V)~g܂{ 3rه�k1h[ɝ8UMbLQ烧](EEr1^ieL(e,Ae M + +j�6l +JH{.״䶇bM4:z&MeIo=Rl'fI9#M+G9YĔ PܩA;R&CAZW*�jqa6\װܘk鮠%ƀ:VgyV)oq8D%VQ;,iT54t)~B=|"+ƅ,?ȌbѮpk 3)]s`$yQԠCgbt`x:dVl6JoIml +B^ݺ<z�Vn4sceͰSjS }N݆ͮ2r@A!՝D"h˭*r|%ر.;/~$/2) '$qӲӢN +6UxD7Q2 i "cFSh *.dJ,XM̢4rEV\H$2yV+x.0#SmB^ƈ@Oʶ$ָm'Kjy'v2V6ij7FǵA.&�JԱTY_@C2HC@ 0rQͮQ 6j6-wj56,%`Jܬwv4:A_�g)Ys d`t,~|Z@2I(lEꫠZNۺ_Y_TT1,y@$s>@ AZaJJ(Li/N_pWg8QEUQ=\sO2 f/jT̚:A(f,T\p^'шX [p4qbK 2)۝/ʹf̩^-VHQ#}i +cRH煠:k8/rjtV]2B}vü|YéjB>.-"C*^dؚ,!CYPUq>%iӡ +~p/^xL8� +wc}zjb{[8>OMy_U_uZe];!l `0jH[S!13LJ�f tR +p%5,-Bz0[ITZn[d3A}QevrwrC68J5| @Jl ,FIqw+ #e+q" +H`Kr@xJ2s @0=<ckpw-NF\bq ty"tf`v :RС J^:Gwm;/Q> N7o<uYN/EuV~jFrgX-X ]spгZδDP.DuvpӅWvȝH98h»r�d + +y ( fjy1rZoN-\(MM\2m- b|z+09SL8ǂ�=${$*HR<xr9gEܕ_Kkl.P<1dIggg&equ#+uTW@c+5sd4+J,03Qx WOX-7!B&KI̸Qq`ygc8 amƨUKp;jra^DXōZ +ݦc0-I^9nŠB^0)!|PXx +\BzPƸDVgq:{  Hz"H֑%.^ 9R:B]1:2 k5ZCW5"һTU + +YÉٓG T�j+s坹b) DK#'X8[96MK[Hh0BPʁ $6 84(8R@7Q^x@ۋv{䁢o=˛oTe{χOxzrLW7oW}ܾn_Nۧwi=x<̲Y)#D,i7 FyxoJ% ZS#46<VwH +B/jnqt[fXH n\:ҧ8o/v/(Q8$f$IWQVj 5ٸV[̜8xT4!�ۍ@%N7cXT oi v(!b&tā290T鰕uYZRMpl+3i0`"P?iyNB$iQx/$ "ԻjSywO#ՃnHvvY[%$*π4!yiu8_PD\:ntE_3o' iRք<r*rj0Lن4ZBŏdꥈ7BG[SAzϸ8lA9 DbR;zBQp +FSC'Ԁ9!'|,-RۈM}!Ѱ/rr->Bd| 5kiaVrӭm(1Ho2zG<t &|r%0pA>WײqIPy+~nZ?:kU]P8`[vCMGS.!`k$uVeʇO +6Ȧ>-yNw:N ސ@z]wvI-Po& vPiݔ=zp<Χ!7"қ) 4u;J)yӾTT.e#_iBfi85 mwp&[ i=+MVT#[},]eSݽ$BO^j< 59WW?׭l!5~3`m΋\~]wJwY>vhFj -󿇕/tfŚRhwdۉ0TLnU9'߲Am_Ed]- nm mb ! Dnz@})[2[h#-.xdO2s FEc{v _ jKq>Ϻpk2vOmWdY}VA9SkDY%^t<&&F -yK/I=+Td 4d3NJb^xI QmkgWjT`c4W1ɵ&>”~b(t]͈N#Ҫ P͚֔(#UD,n$Jk]Z>b Uo-KSh6a;5U0WTt'Q}ldP:ԃ|[ +g$㷜6ɽU̳OGah޽i܏|o!sE<-֝;ڏaN#HD)ŃgR =^K"FÓV%dg8 YP1,ŨHw!T?i4Nvr.K@ QzXU!wd֩˅F%KsF=(3GS^k6:ʢ4@u8nAMЖl\9�fƧ|ˉQil~&'&H`v~$~ɤ:~BkIyHrl>W;WEVSq]?ͳ61Cd旡YkA|\Oq9* +!Z7EI( MR `pOn3 (=@@D|,UZ0wU-ۑ0Pǹ|@x)HpL;l jW_ +WwJđT7ߴl"9y]$YFf-w +Z-56y5-*d`*"50]A#ەo5R@{'Y00 xƢV[I3S}D (V'-%Rȶy*.Tu'2) ~P ygEԭQ`idy5VFs2~p'#|S_]!lpP}Ȭrs-0h2_z:՚i l394*_W<%\U~ UdjY۬ a�9ITp 7%qM:"4,vM9)QodQ'a%;)H/`ĭR1@m׮YTz.RuzI[x'�PMUDA%";ruL[ߌzhV4 1Ev�(;wlKK6&޽t��ʓǩ.$JEw Β p `pb,zyHuǥT3նGet_% . ;+U)r`cE"sz\S{g]g~һoip7AȘ>z{vrϓ. s TQ^eW_y +.@ݲr`8|+{pCVz@c@o9Qσԏr<%�EAoj/^}tg"dy mdJ]I1egoa cdK;߬RsBJas]g'a{<n>PG<1(z+eSe)IuX+@JXq+#2e.^IpR7FfJK4&UEݏ8 Z%? ߍRLZ̽H?zo/k3Vir\֪ Npoʰ{|v�3?,{{ל՛Be{qgW5eI2V"!K*IׇC[T :7?i+Ԑ)V h:)sTaz<.$TPQU-�H 0#<r7tǁhC'0 9 ȕw�掮ȟ$IG2ȃVd�x$ŏ=@!B,F |\T�[Wi*xv 1 e$۲Ԃ; {>{#p p!8]'2n=L;;K |?/-|@ˀ[W֬'zjKal +N&KՖS]Pf@R?7yyHd A&Hy5@CC�MGlE+}䶅Vk:֓ē)$g=E^jNL6v^umCn|mEvj:0grHmG @ 'HC1EJsA6Tg}dDy3}7?]�A;W|] +0Ԣ %a] 2XmgAF!C$6nbɦTKdƜI;/U{|Xg'qjnS~_d:ϑ! E:EvE~y]yEW*W4$"syǓy[K߯űI8l”k j˼FѠbgy1D �6F׼=< t;Yb+I #.zQA{ľD4ӟ#ggpVV +[-ۛrϠdL|mf& ۈ| ̅t *hʾH\Y6J9Yu(ݦ1M+&]+2iS H?jȴ$J*1܇aU3^g|pe$ C)Lea eqxЊv"Zl1IκDWzuoWtKGfPA%Eܚn}{Ӡ +O;j# erSVE=IVF,�@v"{Hʸf̫vQ@s +l]9x#28D޶;9$+YagoWZkW93lּ$58 + >vMdpz9 +t.&c2Mafv#bY.|;g!h�&"Y+I1%1K`?~Ksg+c %Kbv* YM)50gazDSΤqSx9SH& I4.� +(m831Xӄ7:_@X SV񟂳!PRپb+yC)_4 S~ԅR]&%<J<Z=?S,]D_'5Wy4yuW<CafP e+k6+L5):QP;(N(_ +_))\�Lݶ:<C6�R>YO@!t)2n�OO'bV|$9-lҮs0RZcs͜:m9va/; >hkMY?ahy3tVC4L@'wL2Kౄ4u-<"9 B;&FCл&^<5j,'ډzAQ$4$ 0.a˝^}J5kGGT@Mh,`3Ɩ&,B_d̝)PԫFe5--)m�{.4_i :N(/ ;Lyߧ˯rଭP`xiNu;A}]VNl/;5פO3\0ɽ)[z 1=eJL1><uhrM SeM;)>58 +8 6JHeqZΓB]*^ݭ pG&#U fϽIߞ뛲[X,k#m44*^\Y,2a l{t+Y)t̲E;p)z#\PJiW/]LO1b%[MFYMFc%qΑunWRHj i!;ҷ';IIkU GbhtU0>ESl!(پw_A1f\ɖ"Jtg:+n'z# [&,j|bb6+S>ݭuVu 1F]rmUr79oe YJWkU5^8-w^| +Q5}nD3 in-BfA Q+r'˟I*}@GAHQ*8�++C|\6ѭϡHAmjbۜq) PNFZ*Qf'VCz7a<j iDUMV%ښh0`)ȭ 66|@TV%Y%wa{2Drgik\;UQh ?OE;[V'47-ѿe�ح_5_9KwEB dt_׃>>Ve3T$<&=?|DGyN, |=Vt'?Uqc/"ħ�9X-߿3C~)z.h?áUj=B8*WQqq*W%TV˧zhVI"U[>{Ipf eD 0Joj$_r7�ĥdakjdatjr#~ 2ef`xTހ1A2nr,RFj-4 MLs0.g�uL2(ΩNXg f2G-. e}iP(S R4q^}'-z~mΪG0rO(촊+ 췟 #ӴG.t2}w[lc,naZɈL D"B}2[+Oc+t>b⫩I;XzYغ0֪2z/xDV/3zRLD V$/c5-/zDxic�s$Q~C2[v[*ؚVfBO}Y?>a#.}l_l;#5</F5Ba-<lӮ +R,6~}h$x'g=duMZiۛB»HQ;*�"3`&\u' AĨi8Z^Ð+4~Sğ4:-ҥm;SC 8|$-Z`1)d@Gb^D^9*2kOIz3'ӧj]JK|ʷ7fϥu +ɐ[$&;+k`V#Ԫ ٵL oDƷ:"D/Kx^dp�{B#M/ ]e:b3]}y' I(Lsg�1 mZRP +%Z,WSek( _ḭ.}eyR笒: +);Ϯ0NJwg}'u"B +I #dʈ鉌rI#(1 f̫A2[ȅT"D(3zc_vΝw !-%~$B',L`S@ItNqULk|8Je["@tESi�c|L);LJ!;5(U.Efz9.Ap{"lѮYbDVY^~tG:V 'xUϓ\R|bߔ3}: NwS^Bٳ�l>vIEt.wP-|g& Zb|}�Dg`@x%y@W.)`:h▍ZGIpTGE<BVv/K䉽_�964E}Vx�-1"TxTMPSޝUd@h|A@_G^v/C;:LLƸT?#YgiR AL5.೺{ʞ73ܚӮRMT hRygh ag,xglM||BL]=Hu8EcNt!TKs9UJ` 2;APƢAIDP�^9V%F ?~P.@4 Ha7MGo2hLc:zL6cq= -n<iA\6X/p`nnCp&nЩ@UY2�^g`{ HX'StܠA#Ȳ:iFAU\ڂ$ ?qc @`<#7y^Sgt8n D0 t6BDfS̼<Hly\ )=D1!LCccC":"d*#=1%j?+0R@ɠjq]!n_')(AXcvx2w=p!޳SjZ*vc_ +V 7Uf`zԓHYzӎVMEu9cɪ$d5sP }KaP7(Ȉ#WNn%cpR0*Mȃʪ5чF HA!PH(E\hx$' º٣de`MbC3,8lyH$|DÝٸu �DQi <@FtZLIgTndF"J-JڌBx_ͣS�zBu +ë~7/~}uρo߿߾Owm~/o}xӇ~swoݾ_zOny/?kapq! )c&y X[4mt+Ph`969$#c-l6le?H!EPp.�h'Ahp^DxG# Fa8 JV,ENeڑ#X * ˁA`Ӓm )J k4TԢ+ݳG؈ qg1|n Fwa"5 +GY I{@d'ܖg~b*{ q^r9+m7%!#s"a!j)<6"Ғ-T$jcb?�D-a}֑@tރ6=.4-)B + 4zd?*o&/ FP`S}ȳ<Ґ R|o}Xb=OQesh!s*dX,[Z^@18]ό<PRcV=Iv)tDƩ7#lm$<TZX1Ed 0Mr\HLk>6z9b&xʌkײoܛw<ۡb +(,:4&Ts5+rgO&7z^OJ*=*:fI ߽ 3ԞnCc`ͷCL E/DCᕩ\ =ᾦ;a BJ C[iڢ +G3 +(zDB@B!t;_o9 ߓj"$~fI-$ gKMn7 3v�:15S~JqHR*CS�ҍ#Ek }ȓ7ߧ<gqSt j +΂l>0|‚9ͯJ",VRbN `+vU3!Ihfi_bCZB_RD6Sj'1b&W('x%$sn:xG%"vXn->\v@!3q.{#;XCIa^^_M6GxD{3ק:jgNtw= a,#RƳ`wA.00J^.3s˧ScW{l / *H.21{$Ϋ| I�xa^|1IsZz Y5"uVQ0}C_SSULKD.ҋȂ.G\uGXw"QU!RϡmR$.qlqxce <"-?jΞ ޳c41KƨpacŪ;[0#XF[aEdr}J=vҳwiܒH|W(TJ~Y6ynDWܗVQe|J$$wNl[c壸5#꜓ƅS+[5q;cJ3^{+Z9P(x/؝-�ׂFo1{'e䈓G*c89)�v[|FJ)1s(G7a2G˭瓰LQ%� +9�g7ML�R+ vտ MQ+셡\O"6Iw䭇6!6>A2!�eTT)FCO҄]Og">ˢ8e7-V$ E{. C f v?6r<rx,#~e N] +7ipo.  T#ɔesX�cwt7;9AՃrGsQ^�@%g-^ +ME`^iS\\M0Fl�Cs&d+U>6 6zMJqsC0WWzsi ÿ]|4visW Ky٩K 9nq_,c$6SbXУ?Li;F`!7moT;\{G + o3)BW!Rߝִً%u+x.=j*+y&9_]6W `e}Ϝzy9\;[|g�=28t[qkB|slޭ_ x{;S[K߅%.m%p&mlΡϽTrqN,'{ѵ@8DPK忠K#\JQg @7Yɛ]UL"]ubmN~TO%.j~5kT. m3dyCYL{bGV/ǽ +! +ctŷ?R6)b%OyȊB}!+Buܦ52, ]rk(E.}@86><5BFmo':9)/<YKn\X:FHx +xؑ;Jvh\ZӺsVȫϞ"I"R1- )dUA?Z5q h%pkQyelo=$HȀ.ܣye6@Ge츝3ۊt�U'U f։,E)VČ@ x +Dj~E/fKl4 Ql){+<c3C{T +*WF`t0+ +ӓth;Ch[qRJYnJuq7B<ʏ_&o$G:5iCvIc5Hw'|^>~ !8WPf.ׅ"pr^tTKEHp \@RGC>,}lu=Fa=1;ƃCW+aX0Z# _5lW |ʟҨ-ͤ+\'<!\Pk9*͗t)@, YQTiOMx +,MsPHZc獉?26*n9\yH5޾;jo 7A ]IyM*Ǩo02*vPd˿/:+ +?AaTQ^-HQJHU"1L"_yvN:+OW:(9-,伬I8QMK)Hj#n΅qÝil;wgWͩgsR#[5HarXetZAz]hv'63RK _IG'ѡ~HJwnc6+txRw6H 6H'9f΋Q4éV̢ +(6gg*SOZ8!М7@)[]/MS0+T-t2nU:Y VF4 Mқǧ@Av\hk'iŕ hqHȴ_ʔ'Ԗ\Vҏ5ePjH)"PL ; i6Ux!>MNJ{.b"YFChҬD*eqGrt~E; ZX6a=|w>/8jMƊ>H(K!uX1 %،me]^F{O5{Wc,FCH~Ilq4pnהVukSҥTyAGJDJ\VGRޫT_ "ud3O[l5!XD3e7v c e"Z5NAu$X&ӳ}tGiv~6i#'2ЌSR|T#%JeT + +l01@pqI�>NSy5-uecQt)qR긃/ZkB ٶM)I]C�Y  T0/1x.Ifhu+FV$l +T)q$ЛD#("=@\Qbu'GkQ#2sk0 C:"jث|IDפrvVZX=\)Z1z<C4 +!=& >Q=OUauҲzu+v :�MmX7ǰ%;J73fb]J W#M Y=W|5=6FtId @cVWP 7Ehʰ6dug +p`5Nӊڈo_eG1YݗZFnKREhA$3>ۑQӼNFC+'~%� +pޱl6DF mn3Й, fS3ڼў̣B,d#Y#U`V{ +(s8+Ф̫"22$ee[QIkT ȑvN8P"\՚ A+*tcTbmjE1^4t f9Hmle"U{9jWPS$2aܯ{<(1ST5<[hz7ƊyH8ӈ¯>\=i=B^'̖H4a\ +2dP>Xg}}s ܠȚMY4vf|5v,uqTu!חS_LMԣq?ygn'ځCExU#l]U(c"F]g?w9wNQol?Ͽ!1_O>ӟ }HkԿ~|zGO~ryo/ǧ?_>r7on8ܟ_|uW/߾g\mOO틫U|~߿'<7>_]pl4%r!"~!^IWdg~ys}yL}~wo׼?$}xn<uG# TwDNٷ׷WB??N8ڲy +`x uY2JGv M+=4"8)J`F%܅MI9cm{:,̶d {#bH$!${��U)JxmT^MHaѶ@!sså,.ߑ8`'ܣ/]YX=6Ӂ,ڤe!%T)"p 973$eA-a=&,M11HZfjylˑ]k[9LT֏0Pfxu@E}pc51,u9 t>Gg^Sk|�P[{P_ftNʚf,ū9r[ .;G +u5P}Hխ҄wwIzO6 9K|x_A:ba2!\zX #Y-x?>5oKgԑI+4~M"N +-u;j1z"]dJ"SD\G9ٴ^hI*b˜c©a:SW{g{.Qz.XY%<7AJ]o'|"G E H%&ӛe +7Ixy79m@EJ=0hȠ:dqXgp.rN2]<%Ь`ZqWl9ud`2WY+M$(֜fmH"�!N2XIT0Vg`M쑐t1%MC#Bfs<Mrk2(t]p^ +X%H&]5AֿU;a "ƒ#ebS$+PflD!kTؾHҫ`Tvx,z<hkxii8wX$c( + E,R6PJsp4dT 6r3P>8yqr9f:з#KJSDL)bjc[ Δ`~2ZzfOAj%'ii^Ņ@V洣j,,xcYTcukz[Mwv1 Ve(S+3X=;]xӒ3*~KmMEDoRč +P\KB:){M;F |�5%]+7,젼']U;au{!`IZҕ 8'0�x(O\J`2Z90Pbro=\8!\)1hPĂy)^*)-цvFϩ7*夥wNE0:DzRΑAOxkJB&=C{յ4N7y/9D&. S>f Ŀ~ySR||o�l,GxԯNf6mq ζH#1[x;?/ϳfoy3G)U[Jy.y_E_ĴI5!X4n,mWPh1$x՗a^|VR]O@ +X=WORt_RnQ$.bnWˡJS(HУAj[@k;U +; ӎ�x endstream endobj 243 0 obj <</Filter[/FlateDecode]/Length 786>>stream +Hn0 DO{Ӎ#ڢC�j l?ԣmÁuŬY~mP}2zK+_Tՠ\ "*r'!xvk?28@}z } u'n}@U:2ʁ{3wTeݫI0 k< IPuvsZ'AQέڏ6Cd]8dAEޝ>R~j5ʯR@<*+ ԎïQ@y5YH}:B5Wfq < +-tୁS@H#WvpP_k2;3!=/>ڴa$<|za #(s1S}za3yId%e UVvS?@XPUd͏EzHV 7 +*_rR?[XTS%Wf) knHMcm�>_5r9|@RW'x̷D5:VėAhh{ww-mhRO4'\:}ŞdBU{=tIkDSKrv$B5UO;0c{NsN&LX- "֠{؉U^{zaXaa)꺇^{zaXaa)꺇>b7v]XvJh?1}@@[!SU0,E[!Cn'm2> #m2> #m)7Vch?f7t[Xcvj�� endstream endobj 244 0 obj <</Filter[/FlateDecode]/Length 587>>stream +HQJDAP'.&gu_{kB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tk-Tr@?FVV/~^J % |åL? O>)I0S3e~*9VtO%NJЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}`� endstream endobj 245 0 obj <</Filter[/FlateDecode]/Length 589>>stream +HAJCQQ"D^3$KSo/䉷,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t/ +ZKfRzٟ+.h>} ~~6<ts瑽Wؓ[vݭT?pw+7U+B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t� endstream endobj 246 0 obj <</Filter[/FlateDecode]/Length 635>>stream +HjBQOߐCx0-hN M;GzLUc`BS:SٹT g6l+Jz0U<~kJ:l+Tr,aӿ2]yIwpe\x|ʸ>Da}¦r~>B|z;q*ڰKٹT `BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +8]KmWXær!�ZH߇�dKTr,a_k Zy8Igpi\x_ҋʸv}g-[ncJ:l;Rv.A=йT=F*t1z0Usу +\��A endstream endobj 247 0 obj <</Filter[/FlateDecode]/Length 750>>stream +HQn@ѽ7d+ 35%}X2``jJ}с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]?YOrR.*rדbI)dsߏ~WNx�`u?!�WKT څu|9f2|x7u?!�+sG,u[$IzQk;{Ąmk޿v ~,K}\mhO5N7]h5az]Sw?sA䀹c8;k~~<~21z�1?u>d?o~n&=6yۏ|Cj~\h?B{|~t%wezG/xKAeӑ+^gwFzަw,t\m:7scoGG}B~.3x5x?fI$I$I$I$I��U endstream endobj 248 0 obj <</Filter[/FlateDecode]/Length 360>>stream +HQk1�= rЁrgWԮSNCh':{ݦ>~䟄$���������������������KܕUNΎV]Qnwu̓tMݬvͦlq7ԋx0d٬Co:Tշ/]O= ]E߇zleouʪٻl58,{y nև!$շMU_y>~ϊ0FI>Qq>0t~׺m<]pOJNG|Tt/4Y=_ ����������������������������������������S�V} endstream endobj 249 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 250 0 obj <</Filter[/FlateDecode]/Length 193>>stream +Hνa��7s 2 9-HQJ$q6Wz+xB��������������������������������������������������������a5T/<O"n_��w)}~5˕Ԡ {l7��{DQ8oWxTJ{ 0�6 endstream endobj 251 0 obj <</Filter[/FlateDecode]/Length 646>>stream +HKUQ#*Mj +M%IICiBRzQѓk# +sP?Ѥ5 =}C ւV��8vLUE%%~��ܭGhܞL̽"^~wB]iqq��D]nףC{Uٷ?۳9!C} >�� ^ Owo~ņpaB= ��gaUW|w}C?=ZؽeeɉںFDDDDR0y-mc +** /Iwiw<ߗ3{n[pw[~i{;k?\_]#gBAXYX^0y-mU7>wpzb皕z:sK^l/X^j ?5ΆټFZ=zeG7g7ik/h uugSlPq6?AQ>;;WO8=1cem{?5ug{?5ugqO`q6s8Rg1��f^#&� kD?�yg�t3 �n5b�ͼFL3�@׈~� +�� endstream endobj 252 0 obj <</Filter[/FlateDecode]/Length 392>>stream +H+av)Qkig7ٳYɆ"pe3e%bd9.maamw/y^:g]|ϻT}}û>;{�ț3�@޼׈Ğ�F$ŞzzS�")gzK[��xKIԷ�� bϕߏ�� bgNW�{^l|ۚS�3H=vu.no� {.7δ �'H� oG[3kD?��vU^# +�7A$� oH�@�"��yDR?.-~Op��Tͥݛ�P112Z?Z|k߯ .c 0� endstream endobj 253 0 obj <</Filter[/FlateDecode]/Length 12657>>stream +HWn\ }}7r HkP$5UC{Frqx+]=I_7O[Ttqo.>ZK,+d,斶RiK:tߊ/2pv۠\Fb/UͽXri< δm&qSCRuJm%KBo"8k{m@бDi +zn֥&EGܭH .+Z| I$(e.ma.=B2:LBXFϝ:xl^2utɆЙ&e !u# vd>kB眅y:Az/Qs8+Rj*3.=n5%{.TY(bj-tf'(N7up+kxI +R&o4PʋiWDZĠ +{#֍Jh nLu`.d20P/Zs$@+#S ~C`QV()J_PO<J)#2V8!ٽRe�ؐ)X6@xF1O(&2} w$L\�EUX q%Ɗ)'J4 ʶ?,jP�zC ׊r$&&0D 44j�>!ZPm� +N[@k"M a +vl!�0= Bi j^?Pxp#q1e) k#f:et=2+\,ȥ"G"ģW67ljx9BNX=%=N +q3!vu8�yP1Ʀu&0}LB* /DTuܢ)␰@`GK TMn*2D9s;a+78[�< 9-(! �DwAsz) Mֲ.0^>S w0 &ujD ˁ P26߉̽<LnEI7Jw qt +.\cZ"Z85Gx+s4"e�%D,L@R,!lx:l9$B\r✊$U8X28W45wj:iJ�I6fp֐ &ԑ6$ym +Ԋ2 +zAx(Hp)1^tp94b0JH aϙ�A*3FS0#7W*L* eW v,Fo@Nx0rt1%t`o'Hf1P�7f#E2ХT`b}8B'(e -֕.Cm$9SH5h7zFbC&ӹllX[Y+#VaQSֲ#@8bjb:qmh02|[ɨs6Ƹ4p'*鮓bxquuCy) +@r)q7<enXW $Vw$xm ` 㱢 9,KQxȧׅЕL5 LJrY 6 "ӔXkdGKzj. L�mY8јTR"{GL72p6P6�kOnUd2ت3[,Ͳ"雹 bܒ[<^:Ip֙F,w**0,#6q3*U#! +oco TD C.{ 8"m~A||ŷɳo%ӛ7ݿNޞ8'vPvr~{Ո|z/on.\|yͻy  c{pF"#vb3˓ۋߠqdp8=}zryq7g9 ̑<McS~w}%B^%O^\\n/˓_ҏO6&gͻgoI=J^~:�Db^l>zܟߓV䧧$DN!r}q# "a[7\0ye5;<>na{;ckq5 W[rPz(k27l{rcqVu;mo=|xܠӠܗkoF-}BeRGO̾u8yx>80zò/| 3 +!)=EW)r9]U-, +=Dbknޘl#gN3w)ỺB`PP)ui ۻ8V +K%D6E͝hr p[RVc؆;GkIlw+q^SAEUGlYY fr]Cݫg +~?ټ�*;j9ԁ8Ho-!0w</JsW5{3e _۩nP|r[ 2Elg;Iɤm)8FN%/+$"wm7$+̐i.NKp7G bt}1O d @)YV;)AKDA'[~ +;.5E B3A* {/~Wb%n8DFmD!j@ %HƛmDf`n=RQŏ֜iGU2H+[yۊw4P?-C .~״QֵPu]̔kmKoFm}}xfG$esp3yW++zKj{Pbɞa|.wG{m ?w{ Ƃ!|V+<H~_??¯VAw6�WLm ufE +Z|pi5bȑqAټTwc&91mSfsL0!~ >#P  {CgCm>�a=5aD*EPFb6(HA2S_78ȕj-ڐ9.QsgEP\@(UF񤊴#Wcah|Ǝ͕"S2sX|v'olY!dޙ}Xhļ7Vnh fI(Z1~w2 un *hk<Q}"w|d=Qp4v-6;2O6L9\%$j/BtI(;Oqڣ>5 j]] vI՞f2*s8$_POW+h\܂r{X-wv)X: 䓾 T~|g{[zY0oPpҼ$C~憒n0. Z٣ |&Ø&Cprv +Vd}h'GE/ְ&?ALHp@CZ EگH3=E 4k*9P}YtNŏbѠSeN,?}s@U0pK{@4AӵˁPFu+ f{,MX%]K_T9`I\Xڛoʹ>QIݴCPZWm'w^p9@- (cngd4p|(|8zHib:)N&|*q]rf9l0UOm|~nBaKGDaީ -Z[,򁮠0G'V +> sIr9mY&w!#'J"?f&˺S@<N(U8kИЭIzց6dDB}~{yO(!)?@7 q}=v#l*br.;7DmHgDSMw5i"^̱؂&Cj.5x~ +'^?}+G /YJ#4ø!g˂T|e"vPe.pB\6(mYRkKd[*ֶͣ�OZ¾ +ӭ=ԁ wLdۥFJpͪb]Q+)F۸Zw=:u#3B�'yH8 +-7l-*: m *`ZU?uFN !Pu]>x|xbC"Q̥&dE�Zo.h*#uɣ�w7ඍȚxsrjmamKS<: [zA'3D lZ!!$ 6ӭ Z|(hJm56jGlkضh#w%`-e|˚ݶr6)P#f,ka!JfmfXF4:Ttb -)EmEкNwPZR`Ƶ2Rj2s;UqpMzDuV4yfh3I˺wJt`:Wz8dS/g:l({w +maP9@cdϲz@ncN_BurKm>m`)WB}T1Y>OUƈ/V"`׬nޟàDEp.GCj@.^yȧ]50+^15&34h  P- \.y 6^?@]!50n Wƌ>+k/EC+F@W^# +'G Nr,jkUhy@!Ĩ\U|UC3n[<^~uN]sRgIr3L{|k:rڬA ba? +I *5Ac"ͽwu}r!f+T PVm(21Ǹ҅.(q5NN;(sTЧ3҆@]ZJs+恮JTO}j": .dgW:'"ȧHU %9_&}F=v+Q*> m( +])n' +23 "39>`/W(Jɘ޹ ˢAu9 VWɊ]7[&FRiB!`l'6f 4<PzN9^F^:q6#Xf>6c-՗{m8\Lb:Y/1Jopq $ Lpx]ENIC~_z>?ɿ~|^G/x%{+~}yBlX ֐.q!s/B"CP9lͺܷ rBihR,fN|p2);7U=s3}C"6AV^0dM,BXMZ!XmC +1d`;O {4LꚄx p%CKEvH[ c:;u>P Yzurg+bCp.W!꧔4`7Śku}k2h huCU{gJMM<&Ir55F* 7o`NB̘=&�̥{"聯!X+5Jooխzyn5ϊjHY5!Tf7Z(00K[<hGi![ҭ0T&2)( |V+2RSxͻZ~8%y.؝(:`]F:ڱVc]k^19 +hgpBhrod=-l:-t t@ٸCf=<D(q Y|pMh8Lk^Q*P5;r?HBRgT'Qʆt\.!_U2PYb S^*J, K@chF . &rrR7.Pwms +ϙY'66uP4e +&V6ڡ(@7~9.d[Gljਹ\ />jXGjҴ4M= 2椌iZk&躕KQN6Ԋ nWjEË +' vU8ٯ +Nڟ2q :GVz}T=U:sݐ;%P W#4;ht2jkG`aS)@ɨU<{y ʵ "ݻ.JqWX^(kKɆ65"14;@)e\'\ANJ^+zTT+G!j^1,k#">7r;qYW(F@b:ǔ2ˎ馓/?҃?H9$WO$e_tA 2?#?᯿?~o_?K/tN߽EcYG6akHP*:4]E4Trζ찑6&ul^W YgjjnKiZ2Cj`m3 : mKANMHv٧rŐbqUг'4$ASFkFu\霌L5ɀ\EU*hj&'c$խJftu& hTdu"pV]NSk2)ku+Z5K Rdeme9M +zr5iTgؕ]Y1KK7 #3 bj u N{@U-IWs/!&D NV2MoHVsn!T! ⾖SV=${ސ'~:  ; 3240!,2O$ we ]rZV i:v PZU[W&=-U+ݙ<>J̺5AD7&% +!+IXW6LVԯ}a̭? 0=TzXvڵ{.j\zufz>!M79l/ˆްvXXρɛSѻ_5k�Dr7ӳ\J!y1Mb]oĵA�(f3\e,|\NRSݐ)Ϛ%y6ob(d`LaAmȼfΤK9ٖĈ5 }91N/A2)1J6: Ye/:6& NK<F#d>N5 SL/\7+pUݚtʖ2(,gϠ̞S[]W-jNִ 놂۠'~R'hG-H*+'jώYa7npq]l$W֧gP^[r mP)HL; m-Jwd ;LJc+yL3^Pk* ךzeّCEsg˧O"3;wm/';cJc/;/2DWMЪtEʖHղߥjɜ{+~}+UA`> 1KRig "rA3R9ձc N 8(K\7T_`m +NqƢ`e[ ZElU^m,Z(찮Bc?dˆ׊K4Y0;{*ZkKdLlk>Y0g Ұ1.]Y-.ԗ14&,-H\:2 ݸN\ +i]f +)NKR!aa;@Z)�r-i3E5)k`|FӲ8e ,}Ckݐh CHдDռBc4եvt$y_]G$^%N +g@\&Jܐ'j:IͪMK<|T'24j~Vu_pD}i?AFQC@U#U2u{mk#¿m H* ts<3#-*H# PʮoQ0bU܋rՔHg } H*[YE[i|"Q +u!$h9pY%v&_ +Q~ PQEAa=\=u DzN#}ew.G�qRu�/I.X6\n>HEխtGmU5 ]'Zkʼnm*rd <QPmʴNchXw{ȃGlǩk~O)qfu@'\W9@>e^;_C+RĈTY,cJR&%-* 'ulϳHLV BT{/EUyʢ r K=1h*!Ye ^D/I% +kuJ4ZgS"v�LiPKj*!M@Je(R1sY+-Fn0`\WES+" }u^^Oqć w}u +G*�]*>e +-Tj{9UD̸m! 1 Ij8-,WJyq_8%_̘@wJѢkR +X*֮z<*rşb Y"dD݅DJ)"*U脈cŜQH-;ʐvż@~ c_Kyjc1 +^SJRnCM[,&ԥ&0S'cm@nUhHZ5 /cn-86 PUJa 1eX-rx۳t +)H5U|21ą&\fz@&1DS} +4d50zr9; Dg6xdmtH3P #�JTU�,%NWrq �YHfCmX3JJEċUln2H3)W +%n; }dp慜#[Bhi\E'*i$nEW9U"Xr\ye;9@g#$Lo u-D$bbAjHAIIB-�8 >h#TbTX8hQL3./Fr;1pccc<\2 J=!R IScJ=֭FZ=^P6: ɡV"7& !cP*5q{D2iH<AlWa`FH ZB%eH&ԕljnoX(<faֵn/woW7xxvbN:宵i=Aw=n/4k] *#O1"6]G=#M02`h5;o' +]>.oT;_Š)zۙi(b\u&&#*%Ti%Yobc@x pZz4;xe;֔ʄ~`P9wn-]/5Nt<sc7)aCBh[" X ^Uۡ 5tژ ~ +_ϳ v `&C1l�\ǗMH`{5ev0ZANc]On7D .iv@|-hӫ1M0TxbD W?<] +N9$с4�>-`5ާF�aB{k]Ҡ:�?xK16kNdm7e)HPGҳ(Rę�Y9 [RGM4E7Ixj#U2P(^ζn!guk*|B9b="$c58_OY{yΓT^r5Ƌ/ IGR/6{ 1ص`r<QzebVyG_,vR- OI1P0mClӣVKX;d 0Vt[eWrnmZ)D@ɐbL؍ AX6S]u^.ڳPcv>9odجm<Დ:1F=$ޘBocP]rMخsXVK?'$ށFz\\ha:Z+Md/O 1 (-d5?CL?9;`XgySkW~[Xf^8N[Κ::6Xk)F'Zԟ._qrџryQTvt,�Ӹ5R :.(Ks<X)OSa̴y,'^ԟa;:,%6;~+AK >^n>Zgud#Œ?3$mŏ93ṅv4,T̘\2mv +L%ԶLGl +LrON_m>-`~Fʪ$(?Ӝ$TVo?t z8T5%%FN?tW wzE~JbC߇a"q] ;/QBa 8.^r,arƧ~nusիo|41e"fqq EE3ˎX8Tߗ0k)GIsDs:؀$GtrDm+~t3jJkW?9|~=~{;_7vp, ~Zv?9}rwGj>y0ؚBrx'X:TW͛oW}�NNO̫on.>\ݷ߱|͋=|O䇷M7/?yn{zxwa{~~݆/>~a L^%ٶvYmbx؅I;dr$r6?հ_X~`%.9M}c\A +(?j/b<(L݀F?| |Ur}vKO_!:x`țdHo,}UpMt"*|'*NFy@R2dǙRlF$puBCwS,c.Y σ˳6U +HSQBCj SshbjZʴbc冣g)U$ N _j<ȬyF < P,X&BR&xd"| !T(s Wm͚EF`X_n#-x&M0UGPGy=-lR*g,�Gk 8(u84@'c|锜滿/ z{Hy&/@&R;7O <a?>\gOC|Z ⅭOa {| '1=G'(]+!9:텎KRUٍ~A)/4tnuqMgCH/:i.oQn9+73?IQ"2wI'4~/bcOϿ 狯A�b[~E:(r'V18xΟrRx' e:CI>ϲ׷|01S#vuuXEa)\+5z`ǧl<іl'ngڍt?¯!tUŽ!p +E +w@K + orEM7�,2j<|Gv2j:eŤE:E:ZdkO%_7bϞ+ˊ]5F$BU#ض�6BbsǜS\9GKrD=z<ÐzH'z[P*�6p96S}:%I[sIT5QS+6mlTrr r9׸cUM(ZgpMJT 856[K``SJ1jUM:K`;ƺީ5ZKX3X2RYW9-4՘qj#sUB2O)P!ڂEm(2"PCѸfU,"UUO.JB%96гrZǔ3B=Tc w"lR[sIt g%,2nF5sߘe9g~Rw zHvǐz[9)Tui6T j ZZbRTUy%( +yzWy\d9yu1i.Ȯ1Ø.v!K2`k lET/-mIIVj8kȵk͹f,/aM`ZQšuXSF\C5\ۂk9 9k!Ԃ!]- (5 U1rFQSdR،\kk֜kҩkʦɩ\S x2&r-9zXc1fkԄkLG=B9 E5qEQLmبY45ȵ'�T" endstream endobj 254 0 obj <</Filter[/FlateDecode]/Length 509>>stream +H׿KqG#4[lϡ.AX-F\r -\BfywD-I AmAߑ->wp}^py' � '{_Ȼf\]^|r>��8f|s߇ O�@ALZ珛*s�Ϗݫo<w*��h?I+Օֶ>}#��H>?D��K &� l[c5b��mgueڽF,�Ĥq3yP](qPfs<I{cAr!r!G^s|n}?Eco0ƍ+o^(m6LԛƓn9C9CY]?E;�ϽFL3�@k>�ͽFL3�@k>�ͽF^̔Jac�^#O%o�@~ȃhuyqbiJ��/x)\1pl��#� I endstream endobj 255 0 obj <</Filter[/FlateDecode]/Length 756>>stream +HKSa�g)IeJt\MheBPr&˫A!ۼFg$9<XNF_teٕlO8OFV4yOD00>��X} V֡Ng��@~x򴔘߱?���} V5;0|��k{ޡ:,Ox߂42ss<O/zM��PddOcjΞ;bjU���imXM%n4^r@(ɺ-ϙc1/zh���h1:|136ҝn��=|{LNn?)wv1���vrt?`Ny���v^v?7U��@V;1Gڈ}{%U��@V2=0G`>2+��� K3 sNx嵲lH���Ȩ*0{Zvaiym���!hŲ=.?`zkSF>8p[u&���?7~֜i؅?=5s\2/���!2,=geOc.r76ȊL���"eDWŇ5$wxF}u`X���M1<Z$w\mvNýs��.OKe}nv?=(RFKxhYuK�F endstream endobj 256 0 obj <</Filter[/FlateDecode]/Length 1333>>stream +HPu7 ,AYδS~<T!mZPQá6؏՘ BXwy$P)ttپ3-v.[߽w?$���â)Z"ӆYOs%},3сl���f ږ*G $Ti:l\����$kc4ixrw{R���aĻ?Vl����1>6ww?@h#"{15^V���#z BhXVSg���FNԮuԘf_d4Xk/g���F.SYS DcV565>���n0nC9y<}>���`Ri ZBꏈZ0m|��� =L�AhF}۟/I3o&Ŋ),4���^sa^�!Jze~ޠ+1+YO)MEiK_4ʄq|=���է0?@GF!wQK. 32 k5 4&ulL!ϻTz4k(vO{wEuIhH���?g#S={ٺ +xRkq)Dw>_NĮ%j}Ƀt6;Vā?}XyP&M"~ ����+Jc]i" TCD {<^#WIs݂:g1\#cF]~UK)flߏ���ླ;�ܨ_ +mD3FunIԜ#~qHp99.%=���huN�! rsS,HD[)y)CY<{pnx|鄱JkiJ礥p=8&hHc���g.%7�! k1ܽ3ƖNԶq,iй t(\<mkak3f&Ku]@bϊ+U)fmY)2<W����pw'KWzB?$TϽ#ԦLԺ蛂O%9L`kC]7?uq| ';Me% Ҙq~-���dv B?DYIZ.R#,R^9f"&9e\>,)YO̢Q~]�� 8 0�$ė endstream endobj 257 0 obj <</Filter[/FlateDecode]/Length 2057>>stream +HkPTFVE@ITJ4FF% N,+: (&.+T؅g2buȺ@D8BvK@w\"Key~30p}"�;WS]ImO$('ޱ+;l�?;<sYg,+8ڤϽEd&o j9`Gz?oWj8u;Uk5m'_0ə���64Wz׳ؒG򳜦@>+kÉEo$=(wH)߼G_��֮C˰??v9ύ�kfB_xbwcضƲ obYMaF81$!e4s _5���Xo11`3}̟?0t[s*7a}ރYwZ}Z!U2Ҽv2F +|���YZL3 Gao + +ˮC-l]K7___dSY풶(BI'aa%6W>���0Ht'S>aoHJ3s/m)DͱDwL bY6'+p_4ށ#���/XU"[0X?"t1֣$:EԖ"ְ?;72Hk8uwĠU^OIJ\cm$ ��,i,Á%/3ULS |FKtf;qYކ-+kS5yp%'N22~G ���,h|s[s(r (o3ݵ^ȓQ%Gԩpm Tcbܤҷh���O~3"ð?X?Xu4$dݷS诒q׺bqMĐ}��`XBrIHf%0%Ҽ> +x +D;#bz]5 ZuIPĆv>���Â݈t0Tv]os6ZÅ#(cYNκ,}i$_xbWClb-xM?Yۇ&;}4��lRhv~LzU5:0}1 IX܅83b'j9`GkԦ({f9*2ZFD|U��!oѼwut=|q/{Y0\X?Ww_F^nt}=Is~ҫΙVV.IN v +>���ChΨ䧿1&H +ď܇u~=;-bU lTuƤ|cdMtz+Qݮ!Y+;/NuXG1[>5g+��$%USܬ={Ϙ|RW_�k+7w:o܊BV}󔺨F8?7Z*MfN1Q}8QgŻm[˩nHqUAFΛ9 |���sou(~| +ZSJ?`(K2|4 +=n +v찯(h7\saiN| =]L ְ1X-S5;ixd7wܘ1e���"cǒASTdw(SW<?`($Sٹ%Mti_?7:={%i$ΰ=CY}Ol(ͻx߭RI5_/@4���rgKd回3[E:lIYd@c +."C#D{=kSPyhgHt\l99M<_ ��.hU$wdw쳩a+ۿ?`R+Dz@ Wjw>YwEn4눮$Mi +ެ?h#7I wHXZL+V)S��Lv@jOc{kfK [ľGgcg?RJ%//>`�Y endstream endobj 258 0 obj <</Filter[/FlateDecode]/Length 2320>>stream +HyPwo8UG=kXcA 2* U`6 ++7F$!$("ҭ-պxR[-Z$x!</0VS1gѫM?6;\2SH/Ƅ{ +ܚY$��N̘}%⚀>Fk'oh4qhSjTq~{̞yb;;+QU6lK +7 n/1˖f��<>.{DZԎ�]0l�HNȒ}e3?:ؽ|u`)@ݗK.fG?$ +i*&#Kјaû��xn%G<M٥ ,z;ccH8"G#6S& +z2# os"N)}]AXTDU 1Ҽݩ*;&\nuv61 -�JN(ܰ<woCXbmbm'c= z"C}}RF)̞:텾h8FZ}5#ISߌ%{"H{Q]7[VǻX)ҺG7ѡ>&/]F#��mo+4QDXL"\݋4$a6rJ0q]H'3$ +TZ&</D;5oY~LX^i$ % kNF3'M!A��O +{MM?2$٬Oa@oowYImIG/yJN["HGHtYhFm&\',TʮwSHOl7I_O^d�� )'Q HҀDuz.1^NS4}5>pOY|wIl}QL!{z$?;_)箃nn|��x~e򍢝f{d[/۹?@tfsY@DN|#k3A9;sQ˥Dx+B~-#.7`aVsޡFF|��#}==RʛJkSXOWtq<OЗufὖrɵ|EG1ӤrǦs߱w'_)%zjdjk ��a.U?Ҵ_ka`q90y#"HwΕ>iaSV۪숒=pZvByN6+iP_s��B風Cw˼4DZ)﵎v-%I* +T79{!l'R8WYEB((AHO ��-xԣ. ڽX/b($Mvkl Y@ Q9;~ݴK(oniq>z4l`��O%|`}蛬~ti̧Xk?Xօy f\氀އ =1DDwh.wx!3u4pcvޟl5Y 260x��glfFB~y;Jv,%,19v]AzCLtY +;be>E*M"}96:}c:6 �@BVCTѯ?@h{ ɾ=_%n - +v'M1l.۴00@|uԝ@[>ެdfb1� tVXtn{mqJSYnnF:dg?wC]H.+ET8A~wJ*~IN栛@wH|-��:m-hg߬i[a.+w򺋁w7qDףFL[W*&QH"}L۾nެ)S#�@'Ek,lf_ UKj r[L YEQjҕUw5 9iC 5f[?tY_ +w]R'ls`6 %!|C��q[հ:kXQ2փ?�UeV}N{g?߽ Ar$J?%Kp͌_|KT⚇!_!Rń{Uv}<�H1^Ȍ*w~=hSa.tJףF`<ID5GL1gѫnWr<$bb[z:}l诳Ą# O�O= endstream endobj 259 0 obj <</Filter[/FlateDecode]/Length 2000>>stream +HkPE. +UciŘD5bcņK7II#5HQDewAL͚ۘߺgۥ3MEe39%a:tZR8H'w=i#0}l/� >{=5v9IO˛/*hN!cSDP4hX~9QrUk+rDGO]&:;1��[]&lxv׈/z�?h⏞cg\J߭ #|-6ztр>`Ɣ&&9*݇Q_@Ύ ��8"R12#?M.hRm}&;nI/ݣ OƲ6IS4и洼Fڏ^V"g~;��Yb35qx~N#`}532/P'({5a{pt5%U~sk2$zA2F /6-.n%;��`Dh +mٛk{'#EϮOGGa�[Z]֭;zʂ.ݭhOo~2G'({k+~|54}q��eK ,3nmk7`�pXk0K5Ww"!m#?0Ժqug}IUySYցBBf=;w<�)طgi<c&thw(`KXs9݉uG!;VGuLڹϧe/ +Pr` "ϟO�7SW_iuz˪5YN�<<N1DMeow cW;D3]{妌7UV�sfFAq:bxV>z 7�<<-}^;p|2푿g@y=?Y0eg2Җy&S�rV.qe." +-f[?a�[cJ/W54Jԕ3E7'EwU;^�6rsOjyx1+d}�F3I ({ԡ{ p{*[)jiZ0?15&m�0NQ>^h9B87Y~d%xIVPxm) 0X;U/OhOoȺXԲ?W>6.$ni�0/<F2gٺq51`�0rxfNPFv,_ڮ ID<iN ^y +Iя,]En..�0ߛb[Rźd +-Tfo�ν̻@!D9%] gX;-)xｩ> Ύw4�8DZAy2C9?k8,#y׺c}BZO:a=6PU~!ʣ#?5c�ݧ"g_M� ^] ZAo@aY !>ZMQK%9hh)c�0ʈL,l WXoaڝ <G*; }H9},+'컊qu�'̺+ݨpuO.-qVK?A٣ +5 Ԅ]9Neyg#}Jd}o4w�qAwٖFѝ<£/a�[N 3?hXλ[@H"<g7غ5F|ѼGc۷"r�h\s/ș4# +~Pw%`kܓeMU': !|%DmD_ m2T_f٪U+HBǛ^`SVG}9N~7jd]Ւ<^] ca=%�)D endstream endobj 260 0 obj <</Filter[/FlateDecode]/Length 2206>>stream +HyPri<kt3QRmbFIU4[5TP + A{W|A +8j`I&|?3?xgޙwPx,&Bk7OFTN~K-k?t]83=&~V9_%��`0Wkn&9]*o{vxx@?N< ʈɾa8&�vyfםrMbuӵҴ ;?GJ_/,;�YWZjyY?a=�1fXndwtn :q%Ye&;ΟJjBr<wL�/pqt$^ua؞wOBs|x$`KeQiw1&w/¾61soT|=U+ޟ8g/OޱMnci;nд;Oz +�mzAжBSAD_ 5>]-&|I;&.47M''{{QUcgBx"y5ˉ 8]zl 1WVa݊sBŦzѕ}[6o佋j͏Dؘo\�n{d\˞O}k?�S^2wC͓Մu;t7L^j#& zE2@@d&T;n�-3o؝c}D^w7�ǒ_i-Bhm"<yݯ1.FP7^ՙ)1^.'W7(sb]?Fʞz nl I_\!Bh*;n&9?j 5+{ĤAP4ݸqЛӦHQhэ<a=Kxw#`km0򒦘>B[pѵ{>:V(M̬}{ÓwDЫxQ^DwĸX7 M̻a�[Dcx ;{sBm<Qfoݬ>X̺yUWn:l<p q$&j(j;}eNl1f:5Pi/B,'t} ׇ6^1ܳ~긗I*2�~1ȠW73,xg<w�X@2ڎa+x0ws!*}5K|cKzà״dmr<wDop4mYUxz.l¬*AӪB-=HAmѴMv.Y}~Ax}A*w�UjU<ӬoT[yw `-K$t rgRTN?ǜ){ FY!?o/^wkU=yVq1Aխg曻OmoX{> RX WɻvzlZBRu7_y03N+uEk3B/W@TQcL^a#& ʔQ<sDrJ01AL {<od(ռ^ +S)ϲc},Geזa;G!>V}<WT#Z{Dm=(*rh$?Aw\Mr89|]Cxw`-5 ho8:Z< }t^;F ľ?\6&}ޙ ! Z?u@wS+Y.76"'9o {1cɮ/4)[ ,Ҵ %;xw`-hm9/xf}ѱo<=Ɯl?'!gHFj}n4m=W7 ޞK.v>܉:Uz"3L}c΃<.O>9ݵ+VJ5aR[yg"¾` h;gg yxi&cQU]K?wϤue ylw}Qg<<_3K 7xw`MS)ϫӎ򹧛yD[a0UrP^B!|K�} endstream endobj 261 0 obj <</Filter[/FlateDecode]/Length 2489>>stream +HiPTW?M#2$h\ 0qE\AQY\@A- "IwDDmh%јDI*N +O+ $&QMoKݪ{9}D7 &Ukݛ*˪Y;AGGΞbl 0S##P0?uTץD)As`⟹ϒmhJ YN +'z{�}L3״[N-uN! ß�GǤ?HP2;ODTst-hW?1C.7n2V2Ǎ!kI =vAh[GBJ<aNtu.N*KͿ2X`aNT#iПs F@piŒORW}0+YV֯|FcnU{ +2ّ;NoHHOC $팜`-F]ޯmc?3YȳvT{Ҟk vq zzuNjFڪq YFʦ.|;` Rck 7N{~Ot*=kjqw q?*póCSł2dQnV@i2Jbus A~>ς[4>\1+V' ,Ǽ;:iz)#MFz _@۠`9=9qg5׏E2mh,KEBA�g�Mdu֭Ӫ<,fd(Lfjh|xks]t'<P_*3߫ƓmIl˒wm?0} {KsrISq^NNοxg\_<BA?�xxżBxPCqe275N")%yd<l020y$EELP2;)E+hwE@.s A-{o�hJQ5)z$+EҜCn[;;6h\za!drLi?0m1!p\sAA}6^ Ϲ&>WHZ4N"g?3o{d{tWs}~^ߞ;~$}vAb?QE +FZAA,8[ )I.Ɋ?0g}o>J0l7(Ȅ|m?_S�H&vAj?&ExkΏǟҞ1 "d;@ޠ~!hUrŹ-2 pY`Ю Z~ Qؾ5n H FWAcW1悥g + K�j؝uNbҔS'i?'ͯ$-rG{aH(+=*z}5 BQsvAr?\c׳ȳw(}hAyYT4g[uT-]_Ļ$U2%y'ĝ<ͿXB1y +M/vL%a?0mB ~~m+ڳAA^%ǽ��n$[v5m,0[yYҢ?e/kfӮFB.ڭ +X }!O`t=Kl7#.O{6  `\P[hհɻ'iIһ9Cnfvx%I\PwYwZlo@LiwGy.KĪ+3Tg�  �T�{.8dw4N4 9ii ; ,Ю#(Kstc&'OU7.]acv-y 2- +hβP8<R펮+_q*3zZY1p@!+h踰mqJlȎyvgA`2NݫI:I|GAm�If}|Wc/2j9 #O)/3!cUs fƴsɌYoZ7{A'\%}vgA`x +FVF<GAmF pŎ T%V3{=^`c){L\MS#A0n3fj:ҩKm8�whw I }IwmAn�Tsn{T1dmjFK=m,.Ol6Tx%ߝN#]y]O, N# .P@p稅 'v] UIKzD&rW<98Qa 26?cj8o v`oh_et?k67MHZ?DR<hw `��# endstream endobj 262 0 obj <</Filter[/FlateDecode]/Length 1021>>stream +HHwOkmP#Z 1GVl?+Mnl`Xm"NSǥ$\EJZۚцܟ}H7}_]tyfVs +'G* +��::~ḭϘ^_{$koY5۸jajzE+4SY~,-kyocy#c<Z-;v oן��`fQbvGZe^_6}nrcws̘ ;b5& ՇKo!i#+H]--Ԟ��@Gj-ڷ !δEp?��Y<ƾmwzZo!OƉcscK45~W{�Jzrd7 '!89^?�@fޗ$k"BSG]WjB��g7b-B d8X<wLMY��2#;@2}?ħǾzU6K{�5ޞ㒽=[}?9N/}dѮ?=�a{o!3Cޒl\>�=/߰V2{?VlFniF��8?!*:[BG��^J#DE`:훃Aӓ 㵊Oy+翉}?hH��^ _m{훃Aӓ CNΏ[s��ǹ"cdNE֠2dKȩ,0h^Y ��#y' {kBl>\Ǻ��,s߄o !sO6u"5\֞��`aR#;=skBl +9џ��`~d>zmA ْmcScKޛjN��0?SCdoWҾ-<[#р yP~ �` endstream endobj 263 0 obj <</Filter[/FlateDecode]/Length 1128>>stream +HOu 6 +%f 0Ukknl\5<Gf*c*#9'<DiNDlRYVsG3.} pwRM/+ f؋pWN-ۑڏGڧ!9֟gn=,cSg(��=/=ӷ7LjlSu_l;i/��`npTp}.}S??⊒x[%=K�s`߯}7^y> +rܰS��׃α_q[Ab{x6Az�tmH{{sei A d1r0[Ts{g.=S�@d:~o! =ӛi��`vgZR'IvXlw\j��`vzO;sfk@ dq1zжU]3#Nz�Pu=7Ň,| +x&=c�@C-o!=o iK,��{SR_0EV1m5_y׺kHZ��0jz?=-}+? 6e.S׬L:}oKbX�~N^SYFF <-[*-Mk.'':}; Usu$XsQz�`tKz//$L֌den1Y^RX?Bm?Xţs��ytŽd{'oh@ ^{QY9v.kcҳ��=S= ,}DXL&KO c eOgC2 �xt6y: Z?HISՉa1S"ꓞ��x}z},}D y1IfG?fgk*oN퓟��޻.Na[ ?ȃNQzݛԴ_zad[9u2(=�0*Sҷ@4�IF2 endstream endobj 10 0 obj <</Filter/FlateDecode/Length 610>>stream +HUn1,V "OyY gNφl6TvftWONsM%iJܻ bwEKP AjV6dxVk2DYzniWMz͏wo?S%qC"-A}ԑ[Icl8XgppJ/tt|'L%!Jͭ&&}Oא?kZQgaڶ<`YbZ Q,dgn Omρ)-TP ܝoFu*lAuT;Bjb[%=ܫfٶ FxL +j&p* + TLRt)p+he[r#'SZC 3J~(syԹ>u1h}l fHQ Xr`FL@eٷ4T1Ȏ]JKqꋒlFw3%kƞD9pu2 G_`-i0HEuda,*wv r!ec(G1UmF 1nsGP' 0�m endstream endobj 11 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 20 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 482/Width 52>>stream +8;Z,e9l@m'#_b94G<X>@?25VrNH5kYEu21+FUJ+>lmO0`gH%[,7Y@<t^p*;-H_n7> +i@>$emr*Uf@n^XQai*lMrX!TcNmhIY8+cGU)e1q!)Msl43pIu]VWeY+m#'WqA7gk7 +r/"$g7*ja[Wi,';lDPR0?.\u1-+qf?I0iP/F-M"C54/UGQmPf;HrR!UOlZkt;'JWt +;"Jem:h\`>3_I<mPPse40O(.>,tkDeEQ'(k)El#/poHTQ_K5u+_0!3LW>+5opRmPJ +-P9?#Y;;Q+<F;2nU0k.JVlm#m1k*4LpGl"Xq,m8!Wc.(2pW<gh'OumuFj;%:Hg@$+ +!Zdk1H0%KVZVgL<V93MH!^!J!ls+rUeQn5\U)LA&X3R8>SNU^>HH05fSS+tNpYs]I +',8-)Xh=t1<L\BuGs5g>@<An+7qhNa)S]\Gr%Y3*csSm:;<`W;%nWD'/>u=3:S]gi +:-jr?Y9V+Q!rrDSdaS~> endstream endobj 17 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35418/Name/X/SMask 264 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�ac8?@J81H + 0PVI);:im)@A@I tT%΁$q|>1ך!mVM U6Nsx!gKzDb'k)|@b!|[}佦ڪ<�� ~=7_;gg&O��^C5_���񍽆X.a���񍽆X%w#���񍽆XU~s 5�� ԿX0e-;phG EO:l^᲌goH$���%WM&vX#stwʺE���]hm?kF-[G6{\b-ej#q ��>=KESmU^[c#lo<λ���?b#!QÆ?���Зo=7[ +cUe��zDGd{���𐽴$J"4]3��Cg\iT鏆 {���gbPE?8^$;b���2~NK@uX&c���ik3>*"YSaeo��9KW}>"{'9|g܎o��vYqB4"2p_}���4̠?Ȭ)*~zXg��cbe%PIt̟}��|'Q@@%14%rY˾ ��LˆnJ$?o|Qns~���q\ٽbPI(ԏhvߐ}��5<7 +u +NO7Ai���4a3*[ Ce��`F{~qc k J MOeٷ��Qhm bPMOe8?}��t*}vgdPIw[axnʾ ��~kp:uk+<%^6i���LE/?c^kFȾ��L6on=okT] J uʺE}���f_[KܔJ@IxƆ,>���3 4/w]K~K}���f"W| Uk)Se��` +3w#{e[}#��|mXfHܔ 5oM7��ASMenuM0?S ˾�� ^*Zm5]7ׂ~[���f vWT[:?V7��PZdC@eGJ~z'Ⱦ��@eə(v׌?#qS75j d ��2huf_?C<- G^w��p\)kmvs$hwd ��2v9J_?㭊]7E���JZ8sVxY;&wdٷ��裼$]?#qSvc5Ųo��PQWbTWwu}"V���O--%̠?iaȾ��@Euwò?v?:gs��6w^xtfПϔ%˾��@%;+yǒnw?\pY̲╅/>�� .}'R\*|'mPIPKs~W֋߱JLH���i~{%ľ:ZwY?r%~aK\4\]6™d ��p(?m6yCbK̢̒3\'VӱQӾeU{ޞT?��@J;O8ZlOi&vo$]Z>;-ӴY4sxMd �� <Xp7ҰR\&o F@5񴴸?sMtDfkZ57 0t��CϿp?ͭ`bт)hv38.J>Z2m^鏃-?<a]Ǒi__;e��bkiuߕDvlmzn?xh)YН zk͛G_a1{?ӕ# r8bC["R˞ ]Td۴ SIif.JSBZZY(ud#j;s:Ф<~=~wV] {k)RexdDSCƞGg|nb/R-;wax}X:o>8XUO198kM+?lq:!B 8uu3k꼽Ҭ%ҧH`E@s@F{gF ȹBsHw5rǔ޹?H8:ygwx8:)80>)9,^Na?]sQuV17/RyT6:*WӦK B!PŠ +axn]*IѸ?H+CuYWL߷?:s#L [gq׻n]e-ɓU� +ftk�e57G%ָf5"^iOZDL=jbQWO!B tf{Gz]u6 nD\v7wie$<Nó);DgzW�5�pMT+[+cŻ]ªE Է[L̯�!B!}]=Yk]l{0ϪN9 _?pچ&>lIGr"uc D{z%U{C~R7s^͍+VJv +!BH\+Ho>3 'A sCdn̰Ee#ї�U\Sjeϫb*2pczvk }s!Ic!=)Ѕ?H0FS 2EEq:Wa6choJ@��<͞;ߪjRv2߈Njq>6h dUT;E!`4@ܭ8w^W8Ij.MTU!TueD߹? +"sSûf[7x@#a #@/,W6k=t7D>Rڍ7Iq0VK{mB %4qS~*fdm/]IUݻ_;i?Px>ɬ^=ӹ?t?9%~ܒlH>W8[�*�O4,Yk{sUX.>%?<N޼j5L1|O!yh;ZA$ңQ+{۽HO"6#f%ݷ0[g?AZ>BķJa�� vhf4vqEܸѾ_OwwP\<!HsBFYNHo")5})h8;L|>lGoh%^˳Lyw4+m��X3^m0i?v1CT.=&sBfR2+*:sžM4O悞&BDYQ2R36JO+3(Yz4#i\_ ==d>yUPC~8�75yf{5W +;wd Y",N۵aḍBnӵK}NO 'kF.3 Jm.!?öp;F~)X^}ſ*Cn2綈f=<cҺ%`l0}BgJGsisғ}L+'c!d(phM܌ԄVBWL꼽\(6w'lfyNCAݵa# �Mއ!Ɯ[JT];,Y_ܵpCsQ#;^5w'7�<bPj+]?e?/K6yR5E Ǐ-:o0; B!!/}ۨ}0] IcCTNj%P{߽1\R9UʬQGwxZq<*'nfRg߿^l 0JJ>!\,i"Q7#5{|ߒ^DQdnj8K?A2K8/ܼZx&Zal(>y5Qi+]?+_*W x(2b2fJb|::B!4�RN,!S!?R_'G=-ܱpGjǥϘ h'@/@K!ƶW:}Vu4*}}kRCׄ:hIzr;m:訫B!$1Z ~XwدӨ4 oAŽ":^(.* QdP,%"hPDT=$%7A qpÂNh=߆˜N :[|E ћv,H KfeC_��d�7u;,ퟥY*oTUVB +T +%⌔bmb'ܴix OMBW-t{l@q֞W?&19p5|]{6z`M#@VڿN612٪ǗRf(Iaߍ"oVrxDZOztU7u#>tFB!4L(ܗߨݠФ�7V?Ae|qyv' l@c(@KdFGa|ewCvyWYĹwFĻ^^&mO= Xa&M-![}Tq6oniTRxE{hv +*�ixRl\ͺqζ$F"%3O]O0o=-;&BaLMz)n٫p M2X%rI-Q1#;<J?1.Tu++[.&Ր[jEDJ 󪋳"8 GM_[.ݟ.B!ҝ +�{zOՃp j?|Ò!tO u� 6T4@;ϕYRUM +[nH\O'{DF?;fZp?֐O! 9|<o[!4=TNiT l{) ;&&u( sjXle%hU۷:iV'{Bn(ztU$mX<o>L42G!TDt/6FP=;{yIF4`=r/\j,ɺLw`3\M�@&z2/wmkqk%y HKIj4ӣ4 zH6PF6 WCTvdz+ O=D~o,A$nYټD=[GY +3LE@d8Py{ۯCǒ4.i;?֣ژ3\u�=5Qĸ[n>8vjRتO|eINzTΑßvva,{!3n<0>,!v&.6[&4S}BP*aU$@u8\s泊զz/k#n*E"\Ufluca8'!gETw m.�m٣p M2Tcv ;*#=\z@6@S|/~U,\_$+.&&0p<usb9 t>M!4̟^o_lv{U>NTz^P*rTwsjH/F|>!<rj`o&jxQMyIE.`z::1>^Lj!4d^?y~Tzq `w(H X{,@b F=N�e�a�ӧ0:Jwl@v]W'=͕N$35o{|_/<؁0m$b>s!FA*"Z1{7ҧnڄ]:?z}C?tb�T�\(-iYaˍO*N^{wJむ#v +Q9CkmnFc}B dtSTz op rPΎI^>p��R6f1;J NsU ϔaQw/$$>sB|[%Wg$mM>(60pB_Y+WGsb}:B#ęUݶU}o]Chϝ# ۽g E4P]騋J'a0zS P hN4sU6Vx,n<.jiz]5)l{y.9"qfj'!!yzx[Z;SAW[z˹ڮI5":3T3Jr$Dn 3 vD35یQبS<OTd\̻HEJ!Du:{]bhErQNE)F Sg> O{Ȟ{TE N9Uw4ɿ/=f* m!:Y] +rsV)]X$:*ە$.23M˞TԨ93!EeY/guo<y~@&vIEG3�@p!-c,qi�gȸҔNi)R(;=u4aYbXU-+Wz:eaD:g#L5[ZDj` oDP&aK +nq\oE?>yN x)3ǽTcej\\xNZR63tdtFzxW-p�l tt? S.e*nv _Xs7a pN 6t;EQ]^N |)mchfZuߊ_Ȏ«R$'#&/{Qo^g͆)V1S [Lk}RмCt^}<x8C�x%<r@Q\7�%]55*U/T eYZ1Q#*TcΌ?w`=Mػ͝B3,aHj c&_.g*5Ԏ@TP>h+ ;{oE \ �h +4:>)[h-w}෢)$A]\49qw}HV#*g>vDT۷\f΂)V`bhH .2ar.WBL6A?FX +b~kWct=(:[P-|'}�i3 *Y5WLw&QP̺P+,"Qn}97$/=ySy !!cwoܤܩU&OFOփF3ՌSUL +[̷/Խh$2J]-z("@ �h% ~|U8b"uqYW˙ub~"H0#G;fr>aPYTvLo{K6A?#}z?uIkEяQ3@�ZG2unLRZ!)+9yԠvh1}f&#H9M_zv*{VnX, ;#}+a L)椝+B(:�YL=a'/=gnڱgE,bYV,׷QwdRN!nRKJDMĶ�ήd\biF!PʊNSD.)hI9N%?mb(kr1:SuIWEQt`R[[�E@s $RtZ\7UTZ'k(=nU 8U3cN9yaNsz|a= LLHMDqD׎yNե7#8C? @XkVvDQEǂ�[y~4U ~+NSXT/^){"lީL>3?;>n!voܤ q@OE>0ɛ$}V}Bj`  +A>duDEQtP@9: uU.JUSևuW˙ub[E&*lⱊCYG%Z\zRjϱ~]B@Vt; &JX\Ub~ۋxҷEQd;T3�.FG{\nTRZqNRpr 'LKchi 8ÄQN> ?]{zP'5;A? 07Ă(Ri 7K|ӗ(r(5"qxt屰=u&�t:s 棠F$h$ʸLo27H61=e\ EQ-4J5]vU:NTTgdb^}Y#ʭ/ɈI_t`-kh f؁SR"q<>wv/}hC?(SKrO }wPEQ +Pp1^:ϫn>6uWܗRXܿofar̙f &#HOFky.]nwL,6ZMnyro (kj +p!< پ>cs<!^wwhͪ>3?m_̌ >q-@N'=Mb^ħG5%ݸkv mhC?3@o<*�e #XqVK$bbźD$F\$J�Aeeax3dPaU&z(Q6ZS%gisc<yiֶj;���_T^ԆҖlKi1a.DuFqx+VVȳNqiG7eD4s +W2s=5J!HHio!^ºa C-BT`W~/���U? BX/[qao.aycieӍWګuSʌc~Y&N 7ljBʋS#"cyWu{F݁ysYw"d(Fc| +R+)���U'!:?BZ" bGV<צ6n\ײs۽蔫4}Fqt.V + Ԑ?vK. s G[EbaA8Ye_s;tC/gމ?!*Kk>w���+ZVkIps*M޷ %\LՖ*tTȳ2ң̍ +b+qw 6R)JͷO.׉?]p$z^��0'ҰIl*4Q4]6)z5v-O94)<!oo,#L2qHXrNsMwixBPPuDU+eb���0FwΏHBOLٶ9vL9_ϫRmeɟxG{xϞIQxyd,'2m-u3\<oTk;"ebxNhV<gXzh%}VNe}�� C{ h +4Q|QaȯWqQ-k,bCBH/'Swݩ/[e?WNci%%I oyխ)A$S1^0#AeUu%/Y���_Mʋr_B 'Zu*Mkysjg[J<Yfx KFVα>X4÷ {|?6:{O ���0_g["꼠=[X</ɒVUT1Z796u@Ē0=m#]( kA`Qk֫S 9���.3<:vO-<]wNRӯ.X˵` bDZy{}A>=4Gw7?���@v}SX5g󲒗w6<'b̻t:BO.#"΃)e|yqfNt_t vnW޼Ws���AB=I 2q7rѫUʗ3Y:^y ֝S˹[LO8?m">1jQjF١\���a[EH[-}1s +yYFqhȢ"ř;M;; ^ޒp 8>���@ +ґ?UVR]ɦ%}/h`u?Eu"-@aze`/^2}G֙ӹ Oz/#jۓ5ռ̃y���F|V$ڿL;iВUmRGvMc7}O懓YߞX_ }֞od}f��=4;^_8B{"8;ͦ;;5+SJrN=>1*C+WԞ]e}f��Քȯkers +>It[;%twЏ<m;:>ogtK���S|%ɺ` bDBЩʛsW=bHq).���t<^i`m?s7>ss$ ���ą#cg49F.؍TwbsXa��� .w*x+'Xw#AE{Kϫ:ϼ���q8"V2FcFџC|Ye��� }-;@{.kĺ?8>ko5U<���a}A)ǟͺ` 11[%{ Yi��� lk<^a[$; bKe%6g���WjBh_HYw#^[w^b}��0sҾg{ľ?N5^)hd}��0ў(io`]?s-+f&.GKo��� ,Wb_ϳ,24Ƞ_yPW<@ڨz$1ZXg:G M&:t"ԫZ1o ,rщG=c=8m:}b3 +|Q^w}WqNi8��ZpN훅A9X6vW/ԟs�� 4I4 lih*B,c@$c;򿏭ޡ=��@hY) ڷ +{1K+ݮ��%&k(BLGKܮ۵Kk<��Ή*ݮCOQQ܏H*G?��_O*1K68f#WNiiڳ��{|vrh&BlCNbџ��ʋ5MԢݫo!ƌ#:%.LNuϴg ��xnWǎ; *ph$BRc=M�'Cޜ,[AH1k0B־_ў��ɸUG ڷci+>)>= �QSsn^&w-B 阵[Ww3$L{�U=4L-j BGFY{|1��י/_|?ĬM>�@=/>.k0ۃAH1{9Fy:}l�� eǼhۃAH1{ WnWD��ņ2 9hB+ 7k3g$��xUu A B&ݮ$��x<*f}k? .VCO1*ݮwN,]=+�qڷb! +v{Nן��md^`LAHRrkcg&��h^mAHREW}ο?7�=.<׾-.VQ)qa򾷫cGhN��hHgiBZٛU_ʞ??�@˛Kr2o +!坿>@ +��Z=mAMA b42)<{��]ӗ}}S?i}?Ĵn޷J#hR��M'{jnڷGUGx|.dOӟ��er/yekB-V⍍{Ȼ]{�,~ kB=V^@MI9 +��Zvv~^![romZG#*��h?#d_yYoہAHb1guT+{F{�ɞ#o!mmE suԞ��z dOغ@ 3"7>'ϴg,��hSSy>Q7~_>wО��=Cd?}@[A 㞮 yҝڳ��s ϲo!31GkRƕm% +,wLIӿWn!Y\W}�`uַ?AB1%ٻ79r-]2hΛo]h`e~x=}q_QFyL �՝.~Lr9om?b6a( ksVb3s��<7I\VҏoP@ OS8N6d4ƺύ2K.R={�۪=%SoP@ OK":w6nוIjgzoWO39E}�`5[dvV 7A%]b?CxPyцy͕3��Rc T?ȓH\F6n׵Ѵ9{ Nҟ��X]K{X%މ|P?l!Ɓ[#:wn4׼WRժ ڳ��vxCy`=} i˘!]tis}2Gn;˷#k<xOw}@9/Iϫ]?�01&i:Z$dr?H(Wg<{Qz?} 5.hyKg2��fWW oP#wZ;u2ʨ,t~ѲDqϧR �Yɞ}0'mEo8C)cޝ[xf߂_n7g3��f%{V]$S;oJ6fDݮ#��*{OyQ;?T?Bx +wGS]3��QZ({VUb?h[?.95YN�`+ C植AGp]0(8/\;L{V�`WeʞAGfw4N +S��<$z <8%M=G3ڴ4զLC<$jtDZ%jxJ1(V ="x<bԌZ5Fdvt&˭c>f~vgó\mIN/ZOǽkaVu̾*;��;w}vLJ;1)쏦יv6��vuvmɛv;`hG|\ؕԾ�w娷vG%m\Y]~(��MڸvGŦ\`meߴp��hEJW06ezaA79}q��S1ҟ UAL +MdV8k}�`OT:GNĤ?s;#9��_~Nzs9;nĤ?_VAc?u��•AMO1)R֬}{x7�pmGbRM@+Ss+׿�7%c-Kz2%v &^\zQx��MC>ғҗڝmWbR#bs~yd=�@^;goۼQAL +y<rZk9k'׾� &~]mgbR'(纰e}�6+%/|GAL + ZJw>��n^^؏mwbRkuy[{�A%l1)IbTy^qlD��-7j*}œջbR/ݛ7+\&��4?Yڝl +1)oDw/7O��koItN6Gh,.IwT��fY<$bRQ#E]��@KLk.6 G.zk��v|%WfmaN3>3{Wiw��vf_vޓ`Ӱ?IaVrruݣ{�P%}7%DbR:rTGʋ?(��\c^?Ias;{.�@slא.siݹb6)ROqd~O��\פr+J]wڝk*1)쏖2%ZF0avW��\N"6|UJvךAL +)/X/M ��I%_LcM &rY`cghw��6mfc]~W;tbR-kIYkd��~jY=xr5?Ia'F[{ W(��Gwk$`hyi[5y�@SηS?4svF +1)쏖8ku|}�@S۟h챓fĩwj`Бiy96t��Յ ݢH upV]K��WJWPzLK#  :W�;JonnG4bRzڤ *xK +��Dz8q_iĤ?tX-紻�or=8W[Ĥ?e WVyue�;I?|tΌTbR]`cghw ��wjM)=%}ݙAL +#<,.Il/W��n^~H vH^N8ׯMϱ?C/Zz]g/خ5��v:kvWF2 <V빸C}c.rGi ��u=H##{yW,˵e?>bS[%].�@:/9-$ݑA9SƌڷuwY93Vc~=�u~G2fF?H&6&qNfS}ћ?�##=Q^Fq k24Ng֭Z|N^k/ �@eKGڝ[%Pv噵n}98G��CzGgsh.$ge\;$s|??v\ˮ"�@8w}Mc2cz tiޚ2f\ԽW>?zK[fv;n)swݹ+p͗MY[$]^|G��}z*Fz')^g2yNcpJQAp7~tr{$.j:*p{8[2V��撞9IHhw J$ҽSga͞2_ˋ6ef?o#WOHġ�0kq7#VFkwA]-&~gòs7e^c8-(Ys6gY.˲.huiQ+:^@DRki x"9GX[x/Njgd{`>.15(*=wޟģ~|?�<{fXdڝ;cPI`w:?)*sthw�<[Ezf`o;w &=�0_޴,hwZ &$*]Ork +�`SeIHhwZ &:m]myUv_�BgAKLے-ݱ?IaVΞe풋{ �GO};=/c-g=K.�@jM"}24+݆{c=ivnӸo~�BHZYNvmĤ?Bπ1V�@hwچAL +#4%.m{^.=� =eh;1)c޳VP4^��OBzc/=eh;1)yv-uq; �ވYa?bR-,;o{k� xL,鋴݅ &-euPkw� xt`7 c} ox�>WSzbfڝ &bQVu]*s�lYپ ƒa0ïW=M_Xu�qnYjzBĤ?̱/>U��NnY .8a0Gunc{�GzΗwJzAApĤ?2ٱ>�/jF_`һKhwY[Y}b~�:Av7?Ia'*s9�|<'=; AL +Lwl]ϿK�!EEhw?rv?\^t%>�t<r> CջAL +\7&uy|Fv'�:c3GqcRv}?Iam\?W�G5KAL +lcJ}r;{�q.dg?=hbRGƟ G�@nr㶧Ps1Ĥ?#~s=h\,ߓ�#w]yڝ &|o{/OJ�@^.}pkw :GXV52 Y�.8zK7/sf1XbR,uЮ �xprz}#rߵ;AL +# _Ko.^ݝ�w.@7?6.B[Ĥ?MH�ܿw䎧z6jw +:G8*?\^t%�mrkw +:GxzqÂ(yڄ)] +�h~ڐMKyĤ?m޾n~�M4Ymvs?Iao&*])߫�ɝ{-w[vs?Iaq{<>#F[�yl2}M;Ĥ?𖝻o{/W�,w:ݛH3AL +^iΞY�W.x/^k΀1)RwppO�Gc<%pzĤ?pˆ]iն?Ao�%XU]bR%:yj8Wv�,[] &~|]�gW ]n>1).*~U^۞+{g/�#r8Kv7@ V?}p$we;AL +w2;/).U_ \?2Za.@`D2 2^'5 �[Td 4gkrUlU|Ea橿g5c^׹z_މ± �&;[{Ir;�A5&VGOX0刌Ԕ̚ݽ߰?p7.y\c�Lܱroc^}|$OXe2S?u?c^Jʮ=:RDr_ή*˞}$aeK=uwڦ߱?p/}c +W];ϗLi�0C^gY7A1; +n<FάY.>o{קkw5�k>6.B#x?H0uVFubzRRؘ?i]ɋh׊3bi} �&h*)w5ٙ1\#?HgkDD.R}ǽ1'I.tmhP+>�~VyqV.-2d6p718[-(2++vf ʠeRºBRJl\Ni{ +fG)b Ȕ!qf, KBKe\~wޟM +<LzTtk,/ez3fwe߂dž<twg?~yܷbv<ek9W�/u;wW ݝϚ9%[ѯo߫NvFOI3(Y^^R>x\̥~u8CGget_Nce5e<A7<'IQQO~߻?m^2X!:9ZWcߗ�/?ϲ؁kO; w-//;}Uz $u˲*+*cN|}dkWTshQ_�@H}QOQ.w?[Syc^;к){?+[mRb%,/oYS�Wg'Jo>oa&wokS8*ٱm'w˫7*u�p+ZNߺjL?Ian L`Cg*�FҏjH_Jojw7AL +wkfr@ۥū�FlxBFyxǮj`\νҏec &/eU*-w@�7ؗjYҋԗIOjw5AL +]w/�M҃N +Ѕ?Rhx 9vU{Gs2o?�h8-}89/-F}bRj 'ț{_֍/=Q?^a1)t~qۡN~<;��zҁ4˒{xv' bRd` +Vl)>Y2E�PhYu҃] s?IaLMK͋Wk�.6-Y#;v,bRNe랑دh�Н^AL +)&%PW �@wh̰=vuM{ ?Ia=>ɪ<~TY��]Iz`vLbR ؁5eh +�Е>mZApiw- &V}ykv {�g$6$wvlbR)1)qVA {@�cg^+~XAL +=ipzUW[y`tE��wB`mi35nĤ?&J؁OWlѾ!�Nqeɽ;AL +猔wwyǵ�[_s}9#AL +cmoL�{�nG7-f[v"r?Ia@ Vqb^a]�7 VQ_ ݡ,bR7w|'+ �jJ+W[݉ &mϯycZ֘S}c�@g˙G3Ĥ?x\3_о3�zWf%H?,ݕ\bRp1� 饬@4Ddc[;kc 7/ҿ;�D6=vec]OI#Ĥ?&CLuG|Y�P?Iam^>ݶ6�EzGGzHH &7ziâ./YXY.?C]\ &(+o j#�"C?TzgA1\AL +ngn[؁?WK�L�K&f[vtrzc?wUR_o?{}L -Kz:Ac=fn􇵾Iw +�H4y"sza؁֖y{O½SebgĤ?3d=,o9s G2WE〛azЌ�_L>_6Vۀ/ &/N7p?}�?;Dz$pv_AL +^/9ʫݞ~m-G�Z^h˫پJDӀ[ &/qoBe;rly=mIolY\-=ebW N+5�MzBBzcpDn̩`7�)s˒.v?IagD}`6Hҿs�Dl/; bR0伴[/An =Ub)mZKi<�b|W +z@ &rF{<;QGfO>[3R &D'ZUNPgcmԙADNWomm֮Z[XUFGEZU" @rIN 9)Z[+j/v]u 33oK'l31|9'dq g XT?w'6*y2o>A6(raОI2`rzmɋitmQ*ӢwOh @Κ5uV?I!zyA0h")0`b(.ARKcb'ԗꣲ̌ZqG~ E,]@JӞA2`rŪ,_uݝX<'=}0 lRiњ:DOu3)v#>k;g4?\TErhK :'fmsoͤYnǸn9A�+dW^Tzad$9"ҳҢwOod<0MD)h[ۍ샿RK 7K <Paѵi-0`jd,{?s5?¼D#.BD A:=];A3j琰-iL,2fk0 .;]2Hp~O<H4沨Mu~AǠg5ق Ѯ~2!гh59 Z8I^^e8'] 2x6-hJ#BB:DAϴg +8X] { +{4kOXo1{&ANyokYGEwȖHyzC[ kf:!tW-cfi {2i?\yKy&~f>_/pΚ?*8`73:x)}_ |y+K{ 3JШԭzW|}T +Yu?K;02]W8 :Mniq6?\vmӤ43noǡ0u?βh~],At lldҞBXZWA Vw׬Q*' F[8-A~/$PAh˝Ycx4m۳%Ftߝg3g'?qx|}e|³Ĭ]S;aי&hVML'\KaѵE3؟p,3PS#h-m<z|)%kſ#kstOqKfmLw _JMriɱxx:%S.x:=5x;Gp%xw؞Sž&=ygqg\<<rkyQeѵ72^ ҵA8k7qomσ&*ޤ0?K +oG#{8W%__U13W!I{VEx7:GԋBʏ^C#l@`rrV�o<C#0'wP{z#dײ#z|ڛHc`Y$FDO?eFc03!X{Oio~ˣ?7( [ }OZy.c_GY,IyǞίEۇ!xu~F¢I6P  +`rrFHӖ 8k<,*7`m[{w政Wؠ652³w|?\[DVOqeߕ9g΁;'`c+lr-hGczb@sfsg#lO_O k6ӞcHiC)Y*~ A ::= UNXCA~U5̖l R6 +x>a{=g07 +yc|Qڨ,?/Bc=#|U2f|}e\3޶_JFho|2F> Daѵp(�B=Œw{s Fe!gXgr#i2qw~z;b8G{ +˝HR/n뭀>6Jo4PY[xN2өSaɾ^J"mؤ,3ҵe=`e߇<ddnKwFZl'YIwaR$)Wg 6 A ?> :`ʃAw ,w*Wk +b'l9%9}kRK~SO&h4 +Al=ɣ <%}錁ܬVY}Y'9Z7XpdON,~?-䈱:%;^3?)X734sɚ]A)Z :A_Cw&ЗD}uZGW;+XU r|CeyS[}VIY˜+zGlu&Wj kzO?^6' / 'm<w?]wf YnV^o?gC6뀎@O5 ,w*Ws?DM ْ aE\/^O &yP<8cȚu*Q�CA@ 0p 33C3ӬcVR_~d۴#oh߫T{~W{^yGb8'a[=uvU nƆn.Ӽޜu07#RF@1<+]y8 ^UԢ`J1\ov5[o2Tik@={tm#ML6hC+7!gu襟̕0qy9[<Y?S֯~֭ EOZqK7v3z�x߂4P4vDO^TFB<32Peu]GǚNXR{0ۧm(} 5b)t~ =5 Chb3_^ ~ }X56yE/|K5/ QO7M}SVRmթ5J^M}BD=je,w-GC +Vos/ +җi1؋'ZW2m/+;f~編`'h&pr oF_;i\)ICC#(#ҵ ChbK +w~]SXУZ%ɣז;kvTIg[`k=.Th;ŋ fAO6?fSi?$-g=sGUp=q0/I_X1-U8uZث{YFÚZ]֗R%9Mu{!{)#KCyd};P'P/P7P?kA?d?=~uͮ=˰,e5oaw,{*nrB�%"l7͌V??5NbL=-V>z T95&P74ϕrgm0t!Nkq-[N{\9j $=H'_&ryZjɉ =P?\HuRCݐ]j@ @1GKnOm"!PԵ/˿H5~ +Bfd(MLAУ[w_ٌ7&4)�uHDFd(MLApOf34s8AHu`wyM@@WI(1H2PPkA�41F.TP[l?h4%"@c +z: ]"PP Ric,+_Fd<|.EDl@@e,ޫF8ɘn!'"HY}F_ō$]s"FPU_F6j2sJ_LeI_ }̘o>V;ˏ馲*@37#ұSm�mA~.ǐϐאߐk A +41$}?yE/3VbL:ٚMxY*rz?%ZsҽcHu0qPog4GPԥFe3ek A 41;Wtc�7*vрq^p괤:Xl>>\N/>A^[_mVNU�y6/VGpl,O̴\)|O }aZOQG:=1ZBWhb2wLe"[pپqT cҰV?ҏ{56l\a 1t{]#ǡ)hF {pλx1=%9j͌V&qܜuij?X-lߣ~6zkdL½>\S~ōTzxF>([8?"wk`]PdHcGTonAۦK\*xd)_;P:F=&&P7ޤso0}[w^ <SkA^%PQ@*\AŻ}hUJ?-Q qה$cvT y9[<s=cYgE0.uhU3lb <]z{8NQi:Ο4胄ڿ}3#sjg`:kGd:EJ,"XĔ;kk>9ptS(u8K+cHӗ.7ᬮC@ƒAYKanXxxe[CUz|s!{$|3;hcG +�tIakA^EPMDQгf5i&'?^U }k?zհV4S韄-qqKC_١/8sBa?_W?7?}b]�arGm5x!{`,iכ�C1yԤ, WF<v +^ӒXˍʳe܃(Ybqc̺R2[W\,])"#�3= *(Q(1le+3FE}U*wwz8$䊽^ Tj*G"z㈒t{CVe3$|V?N,rDTsa-ȓϷLZt/3~{9&Sޒ"~m?ӷry#XOilLoXGCWeS2јg#>Z;Z0^W}qbz.YPRS9jԧ{K]+Tj*ǂJ##yf<u}gh2 )2E aKž_E=P#`==+ɘ; +>|c)ٌA/#m82DfeQrH0ۯ;݋gگcm=gș怗gY γK^~w:)Ǹ%%AynT|A?U?zzr||a{4Rk # +r܂<9{VzPe?s h)YQ}M l9ՂrK:׾}q0Eb'=�_9 Qy@?گ;ۚ?cCgb.A9&؟䮼7ۢUXQ{^,}s`mr־P?Ue�A!w PRS9Z�oԘ18,{roME5:2|<28Sƒ"^YA}#| +5&ncuVa)Y+ ع!^Vvb^Ds4&%.{)Ϫ/;z&PAotZAV W9.yj Y? qC&i/x&/ ֐o>ǵ>ј+?,#?{~'<0; Kd9gl/cfrxFpQXsD\=Ix7΅.`Yt=AWt<AǒݱGˌ}L0݅mS5ZZ?hB]smzG[FEfNEֲVjqoP~<kΊIJf/<tH>\VVYY3$G:"oa_y_3O5k7`ZLoev#zXgyԣOIJoDdK`=%@_5NDPRS9b<KtOgvm *Cs6ogK^jObfh| եMklqNʢη<+kf5hxܕ#q&>o5fm).>d+IRHScSN!{>^[ ex}/LTsa"kuv)U㽽{<V{/Kt'֚&PRS9b�;yvR";Qs9dKw.@uuΏ. S˦Lw5m#Z&AJMc`7g5?̏VjskV*Gw-U,;|B,irgo>p<dNTꛠa] Tj*G]/&|:~VT_{"g7#܍w^ T4{K: 7=̍V x6(P9޸!oP5~yvVcaR'Z>?]4t�=@kPRS9s 5j n]IƔx ƭں x4n+B߫H}'ZA<??T?B6[_}D0ސo7]#OCg)w^*BYk ΃A>\lY죂f`jtŽ=3'*̛1l|(P(s0,r +ug7&'{M<=6&#wqyo\cA8(P(s5d]$;ϙ3Ng爫's6Я8\'kMAAh?.`Q';g+8lgЏz A' }CXk A87BU#lZ [={;3q~/~ A]*5 k7=eK?V0ݖ~];yr|/<~9'&$}H/kTj*A(y=‡ .J[S} 7 ^ޣDGXk ǀUWp ѿؗ][a":pb-*jL֣cA p hB]ڄ:,rp?]8J;9<q8_3κA8?Mx٠`ތ\;cFqݢcg\0~^V/*hgzc)" QQ\A r!7 Vw;R~Cߚvc1!P6/$o=gm~hRN"ۭ5Zi0f_bgڽhhhhhi>i^i~+*B6$ 9%>9ZIESݥ>Vv +O|L@Jrp5@qħkYF]r\{Akȭ&~?¼?D>\@rӠ~Bf1$43ǞYe3@ܽ۽vC}X}XE6ח]~$m?6A֓&m[o- ѭ?R4oMih>4 +jshhϐk=C}0RD^&T[oI+}/o2_d*?45imօGt󭫞URC4'Myyq'^3:^(LhTs5<M[P+p1,Elnn75>bH[MYS$'{X:}בi֌Eqxcy=gC)Bo^'叭I^to~,{w4_9 s5=[L EQ' 93 aoV|Mgۛ]G;@vy3c6_STEt/n?d$!x >#7at uM ,Xʼnĉ&N.CGv+qJqIs xlOg/6֟ll1JTϾtΛv)[ԏfi! F!x tN�=l8۞֫7 +,,YMjJ{M5FQ][Va}ك!  ~D6�\ \gɾܰ>)<{G b q(AA�F6�\Ah%&Nu_(|ն#%U@}ĺL������ XVVѝ;ħV' +ciY^(|#={Br O������9م"TWS`OZ9g | ����������������������n@y&NuM}\_', Dv"Nt/'aL+9yC}DJ2%>2?b<?R2ioĉS&= ''1ҤF':CmK= ݋cYYn(dr{ #Eq0q{Τ5 lΛ=kkc)KK>h7p/ٗ3uםG豖uMW#ɡ1nHFg+*e˞M>CrQ^_-1tYSu:.EPcpڧIV+x~"sH7EGHIzpz?۴N[IYmh4f>>5ʤ6l>{6=LSUzA쟶91uWc)DϚmy'n 2>ko@F f<wL=只Gcשּׁ^l7`sr MZ\ݏKrҒtUlQ/jlj+>&嵂cV;}O4oD3̡}OgSߧζJq;W5(VUa4kx>,;~<{f?h{rv-zǢ]_1-yi!3x < ڟ.)*1t%.^GYp?BGZhGZ\U~*AaҪh%~>>,8(M n3Ot ʂ#"l?F,^&T[oI+\X*#qC{mOE)SꪫmgOY7 }5v}y=~05)ً<M_kxH%B^&N ܃ÞM>uYmGJ|y'K&NjA_K2֮Zd);ԪS٦>T3xWʫ-cC,[| Ǣw, +Ck`opvCkS]M SCKT=l,{@|Ӿ-^e?s~,w)\OL7"1$Z2*۶}FD˾~@(X۷^cGNk�,zUhil3<U;<vO ues/Fi@^wʼnĉ&NjA >M=xܹ]rm˾x e~Q ii?qmiqѲVoJ(o%v'Y72eB(<v&`{'mO̢1!r@CHԄvT[oI+x(%pz|}1(JMl7pc_�_v.u5*$ +,AP[,f-NL\6'N7nsY-P Ŝu9|/swdrr8ӧhg?6=^~ɎwnDZZđm;..{x9{{0# xt[pG_w5ȸR33c[Ǣ;w.N30r{tw]$-׳ңwtscɣ?I޸qTؾ .1\7/oFn}zV.{t9r'L}]`ifzznS&Nbjo<X޽ƶ Y'׮%KS Iͻo4bmߚ34-_@Y{0lTo*~yC)6 uHc5am1;S7lLlO&oꎤŕ-msC^++ + +[v+$U;7m G865t:Ռ89:uڂ93oxZ5Udx:jz,\n}|_9Q.;c89f<IQ8CxϿ:V[⥩7LkSwS3j܃fǢ{m=xtP N+:P?~'1~ U/+c?G]ݵ͏}Y[S}/ko҇yDT[<GBg.=mX9���������������������������������������������������������������������������������������������������������������������������5-�h endstream endobj 18 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35871/Name/X/SMask 265 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HOu̴VZ54Is^d 5[,K4+ jERy`({][/EaGda=vq}wm\T +�����������������������������������������������������������������������������������������������������������������������������������������������������������������_%Sw.jk#u=]Vw_��@X,=u>ixwÊE{<j}W6L7�� #R_6иsǢ{��¶vSuuO0Æ��Ɲ;u9cMeȩoڏg‚��eOm?[T^S6o1!��]rz{ykk��t3(.9%2O\(ƎZũ)SRJ)T*Ӣ}- )Zխ '|=lyaE_J)R*mU+gx~=cC}oT<LAc垕;V~ўkI1c䞜y';Zj~ߋf:_ּvY=pasùܳ}蝷K3}h{.+hܹ}a/|1Ϲ߳sA2|쉖]';Z?EElYqnpsǹA WYqnpsǹA Wqs{; r5Bb�;FH3�@y�H6!1��f_#$� k<�$}g�d �l5Bb�;FH3�@y�H6!3n�~w*֍��K $|pWܽ��_!)��E $|)RkE��p&k^;iĸ[�s[R_5iq�?Bw+_x6n6��AH3�@`_#�@m +� B"��$AH�d?�l!?��M $s#ch �B-{k̯ZCg��D^|riA(叛w^Cg��DkphYw q[��&y]w~δC�� f7^=�4 f+ʖ~˯��d0<(M{//y4o[� %KGQG��% �l.^g_#�@m +� Br> ??aS궛e=3geFf璁غf͘lxU x]5OfA#:ǛW+W wppp |$%z'Poh-VsM{gûjmc}UώppppXqR ?��k<�$}g�d �l5Bb�;b[y̬l<xl<�_AUyxDAYar`Jm񚆻;5JM25oXj+wG=x mmhj>pϏݣܦ-_3s|k F n'2��{TY=rW͡?���z/z)͚FBl?���z7z:O��ލ,#9I��@^CO%ex}A��ލǎYk~���kb}/g$)Za;Yj4:48>jvJ +[?)/��0.n24SǍ[<_l[Z��9NK? =}Sg2[N&G{wXN��Хzwz wޜ>Gy^��;@o8x!!2���te }���H{aq*i5}���0N?4iώ'���wYrP?O7jz��;>;*<5<t'��g!*m-xF~M_G��� DreYgP?Rb5 Kao��Er-4GrٖJsn9M���·˚*,N?4%7jz���!5ǵ.S2mQaz��`hr]ZC@%חS_O���l}Ar=-%JZǀUEn+-\]���Ff/-JlIJZ}+euni.���#wXNWx.mlvYXk]���FvRs\,]@@5m#eHO��0gTҶ?&l]: ��6"X[iWM Sx޷��okrPMl:6���#:gLտ,}Qs|m���FԤ9o$PQ{Դi|/.z��_r=F@EǣuժP��0^^T^_5I4hν��H|+M(O봾}���Fu/Thh+ۤ9}��k+M@UǒH~XO��0ظ]xO0?n\iiaz��`^6\r?VN㊫ܔ���F.7e{kmW?C>Ş}^7��AvHuyMF@%[/4 o��06X A@eǢ L���70*?7$|===R;��T##c]uA+'z~Y(N���i6_:SﲝN���5hGJcTUX f6iΛz ��2[ +xx>��@I?MI{({0uc|vvHo��PѮϞ{?#hDqmz +��"9d="J$ƉĴĬIłębΔbаVVy~-F@5]| +<\��4xƚ5Co?5OiV천s +_ٞETXxeS჻Aw#Ӛ?IsV��SXhxiJ<~$7{K|&'Dи[~7+G\)  +nLa!\ 8*PubAVv]Wwdd O>CDG|,Ӓ?t? +ɟ8��ST-qގO|\!j q`#eB\zgʛ8gץT7IfvقPFН˚37}/��@W#FED'zX,H)^L\k^vQn3I7+GN~zMR,<']7+o͜?|jJ +kwq̏>��(o` +a":<BE qbb#IRۙ.jߎLvZ+ͧ֏fi7L_ygDjدӨ4 oA#+b]Z\VEe,u)Q@ъ +E $!+,Q˞ q:(8mri9FKB|Ppns+V>u&[xm= I?9H!nlz52?5#BȀ52 %eYóJ"I7dQm)Z^B呸 6z`*�7t Ma_eE@EWN^] !v(VG}ޙGG!PbD p0O9j+MM<pUCդV1<^<n a܉}S(wNrpP@/@ɏ�{] ٫䄸/-?bv#Wo׳_Tv }?B!̟6(%,ta/CQ͹HBj%N[QT{�< ;|\ F,Ӿ2gk)rM!LLn,߸Ʉu,|q Md?P{ʎ{6>7ZM 7^cz299K˃Lf,3!8[mݨQ?Eϐ}L)!}<߬tO;u7<*I^zWٓ&C ~Dt;_SpV9i!ٜkdce t!Pt33<6::SB}})I2VPW={ޔ̨Oqo))e_a@\ WLZJ=`U/>>mǎ([!nܤ;�ڽKɻ`nOOBhT*8}pcăŢs7iʅ畁G[=ɝ;&2�E'SdSJƎ$iahO5#Oz�e6:':b٧~NB7L�3&L݃;th<qb hOendQU[UQ8Lz"מJ9@[s%ĸ5z\vZ:q]vm:(<q Boj +󬧁*Wj^vb,Ku77\<zx>$5pHg<Z (wYuhNm9rҷ/JQBVM_f!r5*B:t*/We ]>"B!d0լ빆8%+9O!:l[Eq/U{[U*n&7tۮ8;c><*B%RaMWd(6::Sjf)vDdPfs9HS3b9BJp]MM8|h45\¿-m}¿[MF)ctOe@=DP,^JM>>csdgQAѣ"Bz7v%[�J +; qcZYn2QLO)ov?PO0>�<!d[v,K^-Tj)U{{̈y`BHY ,p?r*Hf~qM�Uﺘfm>2tf&& 大f +.NeGYA31kFt~| 2BBu3%tUxRJ +BOܬc|8mdڷF4z׳] 5]cyy!I)WuZdȞuGF4)I/6t6e_Svbˈ̦T+sUe'~lB056`ߦͦ\f1}k(2nT |%nܭs8 A=cxM%{.~̢v/@?!t]}ҥ|EV|.Y1Q.ߛ:v'|jBH{Cg&)a iBa#XJ2\l}7qh3�Qc!{ٟXRd Yl`${ď= :GdlGMgp_)㦱Pe B356Saj7j쁀ϳN-_$?~ʎ5+=7pJ}�8N縉aTG(mzIN'FMt2 v{g}_9+P //.!zAt:̳?8D)?N&f !nŜk޶yOX@f�;)wqM]dжs@=ɇ쏾^ !՝[Tz.eTgޣb8&l.)mwpR":)I.Q)R $rKJєftS3uS2RӔxu9nG4{3gclM?M9ￜ3?;~w20��ЎaB +vM9(T%uڝRPv-@iot'qz/妥YKyTe^>Gwԓ^=iL ��0#CC9xL$_g=p(Q!ֿ1ʃ6qz7/{{ɦ1 oroKw�}⚸y(4]*(0 ��140aiQ]FFTΨn/J[b+Mz]Tꉍ<S4MWF+'RTvnEV-^}ɫ|g|��tܤ'MKrMa9bF<woBvQUPFɱUADD)vFiiX/b(2')%,C΢,sf&-wl�eMӾO> c7E/-*9U`Q&&lFi!w}ҩ&24{!2$Q`?ܱ?@ߴ`}bѤGߛ*ݺ}l��>5Ϟ#ОH$y"wSdz)zI4qbv,'?X¹D_'=C<<}n��qW;|] C9<Q,5  Agg#*r#JC1 DmF�})7GsyNJmڜGMŒ'dN|�C124#>aXOn\ۥ2Mc-ř N{IrҞϙԋYxOkq�}&rM/W;y'o7Gi|�@oY4#[PiFLcIfrAw=֨/-iT{/Z2}}doC}*%Z +.&Y"'{aG!"a�g�-ε~1+3;<;* )1IgaM [Wa>0B<i+zza>>�@!hʈAi :(l0@!iFM~Bŋ*""SRd[tH*X�x;]wRpϫB4{sM7�>T [ + +'ߤग[rQlFqDΔ =ԁڝ +.iMFB?A;Uo%'jbܕW��A},h{úAYq +N5cK4jysq6H a=uֺSOt?WYQZꈨ=r"*2o��Ҁ4w5\O메gjFmLSqe[ H "<YwX�t?X6g8]ը(LS~ ��:bӌf09,qWΨn<qՋJOO͈rߡyԄЫ.,1t蓶&'1Nz~փk6�w&=im2vQpiڭI:\Pdݿn1ߙi/O>%g}ϵ` )9ٝ,òX>�ۜLm>>}dq{5)矩>->>;%ߑi:)2oJbfGa>i1*p.{=ݮW?r_�[ ۏNA'z*[27*5ڭQ *Jw{oX�x7m?X"svfIvo쉪U°.�c340/B+1G抄rIvk\(,oZ2<l a}POrmĞ no]:�`7VcǑR׏D-Jvk\){eǂj;S]A+rƾ/fFxa�F+'RzTMAu&*2ow]n��3܂LB[2b"OR;$'3V1R' kX�xwm?X[F7~UvŒB�_ןV_`/d<q?rIvkgZv QrQl; /@"whgmџ?@0Jǹ+*ua3ɒW�@?^4ҊBW2I۳۶Dr}r;ODj+ozaYJlgA~5}q!@㹭ZO +Zk:T*Z-BժR*Ǣ"rz 0$�ŕp`k^VZRy z|f;~!4 qk?�x>ڻ0*J:=fnBռg�04f0[H?$hhnJRFȺ-f*r68Iy tU.!}vR ŻWvB�EVf74k0)Y{,��#hwػۥXٽPT_/=쬯G ֙Nx"Ž3+f �M[^O>g~Lt&7�x}-,!o"Q\hܔuEJUƥOܝ3Wm$Br /1937�SWpEgf;X/Y-ȮXżG�xѓNHf쉞S$K~=Rzqgg}=ONiM'\g !=)5w�GHvL=*p4*,=�HDiپ_9Y#HϳYʬm +|Z>>cEu�ԍ戮Rr �/9kZݠvt݊$'y�t-+Vv:1hJFPjW⊛uk~>=Wmt:)Q �!/#+,ޙ <iTxXcr�{&i)bÆ^}!g)nܭyIdtD2wB_gbYnfj%`jEgRQvTmMI +=�: +"9UnfKIQ Y[./5KfH3+YM$?@a{rZ%H?)8/nMU^ ZlG;�09b#/<㯧3[?cO?;ĸ-)ϋ!<mzMR+<=+�Sw`'>=gūwGL=#�dwB3>t`Y|7/Uʿ<<wtDy!4&Y&)SIJ01. C, h{L�]?y +\gVBR dŬPJ>~Rt;QZu!4vb1l?�xyX<Yͥr}-$Te^޼?9`lݫ7-E4s]C#9ۙ"J 7QOXNay/-Qmwqj!뢵X{T�pcPePb�ۉ֮q3Ou}LS݅/'Js^C)r '<s0%Z7tA{ϲF%ے�x݈h;hWAC$]rAYƫ ᖔmBSB}>�^ ?a$/RQvt-(e�sj7wБSEj]Za\As] 3#; !I""J~;4;ɋwFB�11K[cWnݦN=.�^KssPZ)JjM]*71ͺsRMowB;MU~?d |L c̸c9Wh +?r+[XЇ#F^vt>yFPW׸SW-4Y1hBB߲<'9;�S[ly =oay c-xG'ڴ|HTBF1طZj(4k&(!n"O!w$.w?W'+q{ }ѵQy tLOgYŲ<45d7V<T\1آrQO!/&!,\;�S/=҉*wl+gk{lݽLD;֮!ɖ=ahC<)swK *[G[ !XX6jKp䝉?)bnt*To<8->r'ɸLGg΢�Br&[ukרΑ dvf>DB_'bvLLc YZ%j{'<.mj;w{t ܼ{u_( NRvk;~@z߇yNx!,w$[; �SXǰ@WR+:?{2R埢M56-_!>kBєTžRwuS\z?߹wEZ̓B, Y*?Qd̃0~n5. Qp\"jFㆀ (P+;8di.;&8nqNbTohWZWTߪCw9ߗ RR{yUT`ih>P2˿CEg +r Uϵi\,Jj5zo A2Gr/,Hb8,DD;y<nW^[cEn6y?+=jA3;^3<E^0#cI#Xyܤ \|U5s3/ة1nMPC.{! ̠Sn&'+Bt{ (AAZ#|} ;:r?-`uB6Wp1d/5|ۋFM3V.]n:߆(rY*kܮ-}Rj6dпABFrPBbL#9oL͆b<!թ{p##PvztsL3> +@W\PUI\,~h7H6ӿAvqt{((ws~cl}}0EWo:uZ@ gzωL[˜ȍ^;6s灧3+7 +y) +JrS5Z +-G;/Zͺ8I^�Fw s,:@B|)K*EW.&⁵=B+ty7IC_IxXd)۳gLF<9]d*rvRh6)m  #Fo�3Ƨt{(&P)NN<h:Nάꘐ?&zrJzqݩB�PwcI14Vp{\^%h&wPCnp<iN,{w xTVFIoAbIB܎F zꘐ?x[E`[ߙDžQPctt#\:ŧ&pe .*D))UָT oA;@-{AA +% `@1MLavrF{򇧓3k:c?[ύ*J>j<rd0A-} "6THxRII+#d/v{g�3;AAޖ-^ۉ >n4%x +Mke֩GZ$*ћ-IAS&,믤uB.aْ!&M6{6iIMVE"wP#xӪMkϘŪ9eO@A'|8!'#> J;]AFii9?o`ހu5t],O+7=?$6ReXo&jD} 9 ~TĆ b܍WYVy|YWJ45�2l 2<6&;pY 0MsMGuaX$,MO IT  !єKQaij$X]H 6+HP7^匇9Oꎇ?YG1(x{�AA\nodDZ+(Yk3|_aZpO>ɰx$ #l8apl@ݣB, Rb*gTQ;ա]nV7׽9w3AAp6JXqt{(&be2QENb0-xX@vJYB`3@w/5\oa;<貅?S|6ڥ\.QȥwU9:GtFUbpm( iK|GAurIR@L|ji'=dyJ7@s AG nph:X[m5},MY!+VUƨ:?޴?򅣯jyW 8 0n nO5J)G鯛/%�*++.d,]nwՌ)9c_"H=]RW"yagv&?L/@;y  C2J)M'4?P#QLq/#s)R.kaO͆ aRs8e+猿 QLCiVW)_/nǗu6v5l][2TC��dAy!Q: HSl۞4kv�]{=<AL惫-bkgG|cOh^bKR{&k4zl|  trН#2?P#UL*fٿyd�<)'mrF `g)//%9) G.J3JrY*_~E}qh<G6jkcm'G4'TQ'E5Z1uxr,"AP 6h mvh3 +x?3ۑy>Y9_8J1E3I\�� {4uOоaicl ٯE|:ˁ GɡlGojc_T$$hϳ^Ŕ㚢?;�@(xRv}X A?Ķ|"7lKϑeܬzm%/u Pd6&=R6�n [B VO[/w =��'^ظB VO[!1auW'Ui6��Npnо]iC̶% w8>��Ip֙eBfMa3��}w'{AfCO]ROfm|9��Cc>u}VVr;?N0=Y=��Z" ڷ + !6M*d^)ҟw��@r,sm}?@?\<ټɼ|z"��t8di'Eo!wHCeo] YS��Б=͘ҜKqYɳo!hci>u7?=��GD= wmB ~y;"��x#ɸ:wJ후A 1>1*HFyē3��<\#G0wh$BN %?ugYS{��}6[AH 1qyk{K{�Zah/ņh"BNPa,��Gen^gڷCLߺ݃!��x.ޟeYoAH 9:dx'g"��xj|^AH !f⟐;I}.�C([ۃAH }0}rڳ��<o,W=4@"ֱROfm��EFn5co!+~~Oƹ )3��__V&|_߾׾9|w?2צ+EQs��f#}_kB&OG,՞��~l2?y[AHb!Ⲓgd\ʞ?/�}.{7Jciu7̉О��ܬ~=RSo !͏Xk!OƅH ��ZGs^KҲXK +^9B{v�ֹQۑ& Ҿ-,Vb7V??�@sSSo +!-Kb坿:B +��Zio +!-GptIٛ]v?G�@.qu{AZs훂AHc!7,"}0,��󯢱}dO^?-A uj5gAE{<��M}]vf7+{\ҺX]Mj]g*��hռgގظ A r5{ +*g*��h{}o!xe^g ў��a_xȾyiOہAȽ#$&̤y]eUy{jg+��hiGppt@ b!o[W>ڴ!+��1[Ѿ{ϙ0,pX]`X{�>:^@@ Cuߓ΁,��AA_MZ_VrBstq{G>.^=k�m +v,{ZVR?|fٱ*B#ϊ]SѳwHY9H>s[z[��oz;~־??&߾ks+x͒b…Kgg:ֽwtyc'Uj\��DqR1com 1?;rtU <slC8 �U]}e{\6Җr u±qCDcOL^'i^��m9㲗o@ m%!;ROG55􏻽3L>�m2ǖ0L&V?o^Ojkw6w)u|VD{�`5J+=,X&0ұ}fi,F6̋{֭US߇Ѱݫzꎯԟ��X]K}{X'3~SW C Y][C:vl{?c/La􅲍ڳ��xxco=} yӽٮ9:wTz12EBw+^Wkդ4K]�@wFnyգo�MrM&wczty;<3]׿Y|?^cڿoec0P묷խV[ͦ.͢j[/,$Uѕ!0uVjt*9*^�ގbFZ+D%n麤|ڸ,TP8{O9Oz]\iޥ}�0ݕٵ='ns-##s\g|B �go֎~;b;ľ }_S_xc}ׅG׸o3��~;b;Uz({y }RKr=kGg��L#*=R3NAL +ekk7��\?JzVVAL +c|w��S4[9-h(31)쏎cε6վ��:WY31)쏎_zSѻ=5��Nw:#Ғ^s0펷;1)쏎 Vu|}^�$*v &9s3:Gn�TC Ĥ?:,.6o7��NឿԔ} N &y [yZެ%p�i?GxRӝAL +捵\5@smߴo8��NsòZW *qz;ǃysӒAn˟Ծ��8]?%jw?Ia<G捱JjʛW~}�pc3ŵң]$bRE}Q=1{�s/Hoa4bRwbUP[X�]IO񕜗ޔpax8|[iv��'~O26gDbRwb-X�⩖%=%N &^Yv/yÛhx��즽iPIKv*1)쏮WS-T<E�`ҋKyjw?IatW)xڷ��h?:cj'c:;s˥=��߰,\ߎutbR]gʄ򖷎'}�v;k`?jwӱ?Iat5>��Z +Vhw Ĥ?ֈl}r �gIbl1)쏮ٖx?��&'=OdS?IataKgݽ~*-E��L|~tN6GX^9^n9=��@ϵ,eMq]l1)T$뀧Y;��P* +gOFM &}RKr=k}��@w;Ēm)9;4bRݧR:sN��k=?6 G1D޷eڽ��@wi!}VgDbR+jX8^]qa~?��դߤ}w\zO{M &^[W_{��uJϽaڝk*1);1R[n]*��t5-5%.;5GhĬJw��t[IM\ݵ&c~oEk ��aUʹ,鵵k:1)yaYLM ��V{sZr׮,5Gh;�:8Dzd{pop &ZOMx*.8Y��<(1鳧R'wk8` 7ok^��tVse=k%9;5\?Iaހc=^K ;�κx(3b;5\?Ia蘽=cgDh��uyӠC4?Ia舚7rո'j +>��:*PtY+ =ݥAL +C?~}�|'p &wb)x~��p7SM޲K[wUIiwhay-��ͭW[Ĥ?evjTT��Ihdiwfbeq~25Ic��d)+ WbRrs|_mL��^~p NȶQӶ08ku]�{2?Y~PUŧHOgѲ�%p܂hwdcW-kkf:W!sDkv=R]|0Vw��Kz訯vG;sޚ2-uvwX癜%?S~=�uaGF?}ի]X:g5Ùr};8�k;_c&Og_}pKgZ~hw� |y*}!v'k|gg2mb\Kbފ=�a΃8?F15Qcjv:&mR;xjFj(RIxqhA=Y/tU03֨vA}f^,<|?ޑX7T q4tsuP%Cڔ: }ӜG8#q= v�ǹKw!aNmI#Efͬ/2_Kc'k+h~ƙo\M?2{Vy~6-xA-MXM5G>�3gf;iw`8_~'iL$NVyݟU5c|U-v=ɻ3R��撞)]ޑ@||Oc`ʷko !ެ-k}N5.#E.O<;ehw�\bH \6%B0 qtOϰ?[m՝o�<E1>]cKvf* y)G1/:`R; +�`Ϗ/(==7ڝ?Iaļ5=�0ǟ>,5}c +3}' +�`ӻʥ_gc6-xAտ +Z��s_6+6&u8<GhJ/VPj;.F� tIH_; &Z,ί".Z��Ή1'zEĤ?BO17Y��GCz$ =AP7bR[Pv]vt[��GCzkO; u &e/oW#s� Y^2Ghj9U+(9ɻ3B��OBzc2GlJ<;qQڝ�~_VEKo Xax<bR- -o+K� xΰ,w AL +#u5qx0կm�ux_7 AL +#MXMu/Zi� \Jz"6cq7“a}-ҋx{�<\-K!ͷ-}Yx2bRf&~]9�<nM +Ce@Ohw98SGH;�S -Kz!ə:\tĤ?~�<Ss˩a�#=P<- Qx:bRf:9y7C}��=_ kMxzbRfiJf=+� +@R OAL +<?MmW(]�ǖdJdꝄ &aWxWVA�@㹐AL +LNc9w:ˎxsC�@Ó{/w?,kz?Iak-.݉�wxl7VhA_bRf[jgwv_~/�yl=bRf8*].F�@ùRf>7݃ &aX5G~�ԿϜ=ɝ۲Gڝ &a񽭭ݥc~O�urkwGxvWެݕ�s"i^;5h8bRc#ePYW_Hiޗ�w1txܼkw Gxvj+<~xG(�<9㥞>Q &^/շN̞ݝ�'w<qf-k-hxbRgk(�<?/ifOro41)nZ+7\H�ԝmrkw +GxzcHݥ�S+541)(*ߧ�'o+?,!h\bRH<S${~�j'wZm &ކJ +�㱑rM@cv,<~�&YO,΀1)t9*8ϞeTdY�=rOJ;-Z3AL +by=u$g] �> i1)ܵb䃶?Ao�%Xr]bRkPkpxCv�,ލ.}bb>"Íj.�Mۛv7@<J'/�#r8Ev7@}^Ul.ݿvv@8v]Ꝁ &LL7_�NnUa.@`@Mx=OK1�rwWf;̉|)@zPg6]Z=s̓{�L&w|Srwjw� kG5 UMqf|cj&iwMԢaQi#ǝ_Uw -٘8ub͙99*`"C\Mq2 +Ⰸ+RJW@K{riӞVtJ)cA2KPy4ynΙ}7ηH>Utvyĉ{VK2߱?p5y[dY~?_gWmp&qb +~ؖ:ӯ ڠݚT{�L"?P}RzVVL˷4V,4kS=7_;#qmztwZF�|v_}y^vùĉi#{ G?c$!Kn该UEIyꮼ'J�t{-]]p6DE]sٽ|nڈKdnxaF̟`5U7 x? ҿͤGO5V5g<p6L| z1c/|\;)m~o ?bx`3V;չI�7Ǿ }Jjw;A;75g#>67=AQÆ]< [&e>QZ ; +.n[^93gLS�7 %-=:,ovy7iٹ~cqe?e0C}.Y[^]axxkCpPwz_=�nBjE;Kjw:Ai<h숞. m[WQÆKY�җKJjw9܃A-]V=W_ O=>,#?6CN�781opqjGG[>Rѳs']Ǫ-seY~]kUhw7܇AL +cTfkvTIտWnפҢBlNJw<�8љIOJ_jw6܉AL +!(1d|d}|TҏUE &UXY �`_eI/TY%=p/1) {K^xhq3C�M҃o7Ż\nbRH7,ٵ=9+~�{('OpZ8n?Ia`-*J3qÏ})=]]0Z|zJcŎPwͅ��JY+m҇ڝ 3?Ia`0ܙ=k8晡�P5ӲڂǤ``Z9<|zvX&�pu{ b;fa`ʪ0A']]��IzNnIe# ?Ia`0e$X%tb� lj o^AL +펬VSHkxLw� $@q9;΅Ĥ?0&Ϗ k�` }ҾDpiw- &'r>ӣh�` |;鵅;fcPHv]7�> ZvlbRJg%[Z'jR�p-Z<'Ϥ״cPKz9=:d>n[U �mkʤצGkw*"4,sݫ�/CzKkAy] & [ W^�(wfw~\1.E`QIVEcM^wy�$4?,PsjgSMv"?Ia@wio I_�@_ު+W[݉ &m?[g[~�Z??F3Ĥ?sV+9ӵ�pi)Osiw%""tv,8�㤗r;AL +N1bkS2X�٤Zl禠\I#Ĥ?$cLA7�L?Cvc۳ջ`<j {l߇G(m+O�,;?CGڝ1)8%Fɹ<wh +r/AGzH Ĥ?TUEl~֜|{@d %-rD. &H + w GK�dMA;l$To;'M}L,Kz&4*3Icݷ<z==vCњTw +�HWnSAL +n\ 6d:6W�A$+IL v_AL +n;v~�0C<~8JĤ?&Y r^xv7SOWmհ?IaMr6?k{IU~|HnmlnAL +n`6ic�KWŷB{PT+"FX-J4&1i^jLG|:>(*+^[%佰{wٻ +kmNm}U4i&4V@r׽r=mϩ<NL  + +2spN=|aFU9zJJCص_jGk�ќyAscj3 Y T0MY ?wMA�pM]Gs ֳ Y!T0f5 +_5[9�Zh.|9Xg@@I?@ +x]F&� +h>М`=�JJRT2>]Na�kWKZͅd3 +??PR*(l}�lJJֳ ?PR*a�Pm,�mlۖ+Jsl/ +3ܗ6AO~({�8=NNL(Ww_ O74-Mz*~R4>b9wڬw6+!�p4X"rŢϣ8s[-*2!8dTdvg#?9C�)EWjUib{� .sK H(WÙ uzzv9.$y eWq%VYIZO{#�H͠}D>)C`!\9Yʜ :C�3ܢ>sN="= �݂ſc6sw3`0 \wt?%36}7md.fgMе3?`8ʢn_=ˋ�VX{$jYr*HK+糃_?ھýs?`SY4)H{�1ҢQ1� '+!8d ?0x?moy[(/_}?`8SYb_<|CK}LL}z� 6`ײS&Ӧ?>'-<|\N}iGkK= 7pj f>~ge5K}Lz�8jk ޏ61F=>^[s~]ǣ)ܪ9c,(هu Y7rZ3B%>�}CJ}˛Ǭg `q'= jetUٟq</ԋiӻ=Ϟ?JR7�gz55WK *�9 p&Ӑ?PVBXrW&ImD!p͜_k6g_@?Ouطg!\lD9BvY'/?Nt wrFfAz!�]Q_RWԯg� (WՋ>E fU<2`[o �{;97hi9~$=Lb�`%rV;[99zՀ^w˩ rL}7W }u}3kKY A%CzahU֢ZB[5ME> .=rR7i}V-:gɸe}{uEA ++ΧgSIy* A]vD*dﱞC6~7oew wssԏf + w()GR&<y2fIYqy+)mE;rAZW/h. 8傳}WнČE,L5{}Z^/~MʊGfg,!efƪ}Mu 1{?=hDﯘ95~ <8l4vpf!#%�JJpߟP\M;:FrǦŭ[  OM\{+xEқo{Or+Oy8W}}vE _;k1wwKqzW|bVS^۳K'�oWx ڶbRL�p()3G:o%ŴӿE띏ڿ#Vk?&ukdm(7؏͌˘3M\yv9?(هx"t?SNMEm--_PYbK! +lz?m Yc�.O}GG}z� +cuhW<)er*njڧsx?I{Mfgؿ_U );4ЮcG9e֖w+i]p1'Ƌ^x:ɻBJAL|cUFM܂1Ƅ/JD @~DvD_Ez�D*e hXTU7"j+YuL}IOƽ@נ|`?i(}ϙc3%)?vPg/0)K6,{=U:\>g=*otb./z他Mw_AQio�YGr7h쪫h+r +!100W@(hY!ZD<S[U[_9 :C<UDhUY6-ݑ>x?0?$> +E~}1_9 ŋaɩ+ZOtjCgQnqP zXy.wUi3 s{KW猩ݟdo)zor:*签F9D:B/e6ZEЗZGo7==kj`Sz xq`5E)U-t{uƲ͋T17RWQ}I_k?6jdgV +jy A;#*J?ěA!1i' h$XoɁCkp/K|Wm%bqPO oX0fo4_O˜;e_B/~^pNcs1/7{ ǹkEv`4q8'X/FxZ˽v{UV V@?mv5zWIkABZܞB0W̨\smUܽꋂ\}R&a}/`쁂߿`PXW ?+`u:Xnت='ğ꫐R{1jh#_!`5 75 B1Ւ=AhU"pu,}N}=0.yzX979u%uJ<h95m55/7ozz(XZ*#c_48̗EV +K5Rn%~@qOXy>۪{H%=>cK9{JsJ߹V0x= 뇇S舴dCH1PcɁC6.o=;92;`̎k?^C;עG㠦WzKHW]0Khjs6?fNs?$_t> 3.i~ r_Twd<S>K㯩p괰/Rdќ0xҹ/HY r_'^@7F !@`0UC^1xcPld|SD^h>ɘoW8ꪃ$>V~;[JO"Wg-kjTȿ?WOu^Foµ?cWEAC?^LKц�]x)mQ[ !]lR @!HeVnO7l"_!DP7W}d>, F`) ȋ!2;=k5~{>|݇ iO("B:i"`8$>;}ji0t`w(!MR@(2?EdO{rwʩA5 B�xF%.T12֑ Ә)/ӐZDCHA<o"*Ns`N+cyf^<|} =`i!@!@ e,ٷJ:͘;o&^'"ȋU +B4DRxbHމ}-`)N3t6scphv:e*_b 4dS:t<-*XBfDDRxHNo>NJjQH=1K%Xo⡧ǔ)ܹlhi%-Č: vIy9| d E]iRC>C^M^F\c"d`)LX+}]-|?<Q=!&GiI@2knu$R o!۶Y5e�yVY4^cd| X9{} (7~)|M }aZOQN򘴖eGNyMH9Ř;kYS Z|%7wYc&Q:t},Vfڑʽa MVN9;w7tsi!Q#=ɘo7ZQV:7{p_0?㹽~OXU3A +N g}?!?nw=*`gd`鿬*JϏ: +k6oz'}^# &WonA_T#4cRn6B +o}νN] W}חW%(SW[_B B +oPJ|j=fm4z喸Y0qCKSGl mŸ`P͙5E).shU@E鐭:?rs(nPTIޖ4yoLdk� ;�͌*tvȦV%yw"p2n<&9SP<I̐ZBi1GCM1!(Ԅ6>|`eɲ ` b2ZL2M'3I>&"@OwǾoYy=۠9Tyk9cVzcYy/X<Fwfp{3Gaa07T:yg]`nVcʕBbrml>\|/O}5K?$/ǣf_nCsVf"A':gM5t.S38(1[:U㬯lp5\'XdfriP\X5|>|yO{/:Ge( nn{S#ûvb=鬯?Gg,Azb̏0p^E:ÜʑXtvSu,s*?jYwtxv_q2iWo/ATJ*Ts;~HҼ~,\>U? O3+W9C[6 ~{9md* k7"KTycjN~b{k 9l>֓ga :X2.=6Zyڮ͖ylܖ=Y5Kw i,,}ߗ$/mC#t @_P*69jv<,,8p(,1ϋoIEn= k1cz^qb鞐qз936U>lAvpUGzkoP4E>vqMNλLk1� QЕG|k.Y_~{&NY3[Wkyvm:rkehw,e1{/JK8*̿ (P)-w~X~t#s|Q+X^yY!0!8VIApL(߻js$?;zr}L)M�ou'dc%y/u^Z׊a>Nq5z?2 QSwG2uw᪯'\#^,rP\;+D>̩{m/;HWOCWI/AtA BJIo.]mfK{!I:ql|tkrA:X?@=62<"j%M<WSW*XocY)8۴i9 L7&f.eh7z=*<+ :uZAt6[ +Wk<4~ޟ3K~B1\nq-I|쨟a fw\Kjsb4<<i&Rkp{e,^27ޱK0=buyo֞?;z2{l|Wt=AWt<ABJIcΔ!,ҏ,Q;(XoO%Jg7 E\K\u|or1Iƒ.;^25@1bv喻 zrwVfc鬽61핎/<Q6yJ q:%RX<6=~kjJ/[y˳ѕ_23tV+A+rՠÂ2Xbq Gة[e( hAsx|?)U5am>Br/%^_0;Śei6Dt|>|r{受}&Ux{<S;"2w:k=C$fykdX˗>G7s;KFAj- +!^=Othyy4dEֺ{^&H25㻽yݲ%'֚&g(P)1�x*|npL3_. 1 ?{ 4CZXq <O E徎\fS{[>?|AzY 2A*%38?^~ZU㪯a܁FyG.Q`<[m +᣶O1qh waN膵v x4(P)5< Ņq7ִٍ & `'x"y\>(LfU TJ@cSųk;6KgA%o_l??IdgcV�z.%A +AJdhLnCCєrmڶxhܛ%0z`I ~:?T?B0h,_\_o8G&<k9ss$SIΟ xrPRRQ e3"1K19 X [ߜ޼g&~:8G'U̙גe8o֚#CJIE Q\l,7==4ܾ=܁L3k0xzPRRQ "$in-_$DߓS=s*p^8yAOTJ*zS$aX_\mv?-a/}p9pn8?"AJIE !qgL0|YU0.&7t: Fct&A f0Aq_%bekh^n/.C$&U3f&IMUG*I[}}ޢ{yYk4\ӪnƮY72F> C>_|?3_@ 9scabk4 _K۾;;SzD}N%m!K[B?|?#'H @dWӖ䚜 9e;t~t95#n:c7O>,@48Xo3OS.h֨: ]Y?/PtUGZ4zNqh�w=? &aOyng[S$i.n>E>R?_3η .!�{p]ug(WokC<i23G2iI5ciiZ4cei[@ /z==4ɯМaP<%nCA'G}~R_|{ A"alxߢkL$ P@pEw<5@]1,*;QvU=9N?*?? ><P_kO-ZF753zP 'xlWWfXt1~@5#Y/lu5@حlM1G闵4TOo4~yz9~חO}~\*g*өOԯ3d_cP|F�|`+ ӱtebkyo=fKqÕ6*BsӍ3 i=eKG(b !fAKSGz!0ر?LAj #Ep{LmcsuIV5)oZ릮?m܏/ЋE'l(~j_HuS4SƢ8i!]h3!^P'BLnqLU򞵚?G9ǣReK>I\tT[<lo%׳u_;jpBd1&z?݇GSTET7՟T},C<^EX8{I,?LAj #Z]t =Ϲg Uye5@\'m>Фl%I7uwW|yĥs}O՗wVMݳ33h.m5ƌfc\"WWmybcXjqLWY~Q&-V|!  ~D6�셭Z\g k֨:ʳX7f0q{kT  hi^u�V TMzN~]$z/96N@D W������!LVJ-[|j/3d١My^)Ez(l]0gv_ڦ\S������!e,=5?w^r+N"e���������������������2L `zN~Ezt*?<$ .۶UIUwoq)~L%9ԬQݧs9F nA?3m:+9x`Z}pYp0?&X &&ND]R4 ?V|,۷|BscCvSؼ@1UUgB)n@s>,=+x_ P[~6ogߖUz ۝ߘqyE].I1~+4M;4.j.0H;QENKZ+8M)ZҺ<6ߐ)7֢ci+vӻM<xXa?ē&3ÚQLZzXZڸ XYZzA0O잼.21p0 LDB!@9!#gM 0[(=|00=%s >~&3_[kUKȴ;jk*7ԪMر-{_]VMSq:<Ps["}M ^wڽVwLcpc,dhXtzjqSܡo 3TTFĠb6<v<N'3mcaٌ3xFӱ;&F(fHV+}g /-> 炾Okл>qM{_#YtE~UB$ʼn;nÆ1//6w<LfX<!<v,HKo1/Pl:.bu2iKĔ?5o/ǚrI}McL4eOh|RVQ?&?3ßP� Q.馘Fc 9|h^cqvU򞷧q<ĆG]a ksvU K@Vw *1f پD+j-գM23qQQIYR|8_wmǺ|kc~[qK-9mX=V'mLg?uULc0i[b̗S'?-'VB ELLFĨH( O**3tX- +"Ƹ K[׶Wr==ܼy\GPswѯ7?V#;cf5e z(?NwZehr,ٜܷ7M˜kWJb^ ꏞeS[]U臃p=zD{kq{e<2uԿ쑦Y#C-;:t41tc}Cg='ڥ'өχf 7tw>˘$w-̛9ז޹0b TL_ߴivζn\⢢胖!Sd<2_*(^5E#53LPW6ʴ #j:Kfg^ށ=ܸ+"VW|IaUު8~_[**ƅ51͌0Pw߹osC3C.TA^^t?v̛9F# // {332enأxvvL/.*Yƪ}K$xf^Kn{t,cFpo {ܟzzlO_~[(<~㻯rn\?l}yN}׷ƼwޭWJ DRv<Ug,}12JKJcDGևL3}2_zilYX9yE3&3~ړgc +z߯X"jŷޖo˲f]w}7δx{yOMZj5P[]UΫPw;fԸ@ߺnp7 GshfL.Mt%?扂+*.4K|qkj-2sߞW6l( v?lm ' {xdzwoC-}L!kC ՏmÝ5WtS[**ƭ[2c kudhQ8N}~G67\Op;Sզ\9w܍eӢx_{擮o>XmQiIIgw XO<^_|z8}&1K\5V#ꏦ f͎kؿ%>OJ}7-( %_DA|Wa=_[8m⤬2���������������������������������������������������������������������������������������������������������������������������uI�t;@ endstream endobj 19 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35982/Name/X/SMask 266 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoeࡥUPDY ]"H%"TUPA+hK\,µ&^\a`Z <OrB:LΛ_����������������������������������������������������������������������������������������������������������������������������������������������������������������t츨as͂Ɵo{|nWʊ ��n6ՎV-zx٣TQʪQI��cPqqtǺ $ ��,<|bQ?_0p`��۰~N[s/O=<ҲO׼]RTXt{��@@۹ys/ڴjF��8ؐ;Ԟ5NlyrB短y5W O5�� 0srqθw??9{oGf=MXRJ)RVkiѴu8\7binjՑ?*u^<K)RJ Ңjeň<qɧ=gݾ7}bI9ϥcǩv{PXgsZAZL=#g|чu}j֦?2♎95lYt-w 9|8k7}6O^W= +6K/]_,|8sq6`@{-/vqO֦}SQ(;9;= ;>w Ye߳lps U9;9+c8sq6=y�H7!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� ksO,I��!yxyxҽ��o!C{ڒ�?I<5c괤� ![6-J��N'y~oŊGtK��t!y6憟6W5>��AHsҥ|ꪫ �<�[V�njW�n!?��M $�@D��H7��&|cۻk~h �SB/l}wͤM? ,(H3��b/<1P  \N3��b584>]/s[��"y֝wu~ ��1f6^W=�f+kmscg��BқyT\iiy ��y2~�Bb�mykB��H}+kB��H7K(,(?y2_z߸{m0>,_>47^{f}}noUn=eˆFΑ999o^%z<57,s [j~S~cϦћz8G9X`ppp9n?Ź��}g�t �n5Bb�;FH3�@8_-/>':8�**xa1:mq6tF&xa4:f&a{0[ML&c'mjxN&S}HqI}yFaa3y3{��k-ڽO|��k^-{[UE���.Og5Y��kNT[ȿ���liӀ6C_���J6Gq53yKd{��@hc*/-{ݩ𰰯G���6 }.c4`Ƌ7{-[&>t|VqM]ߦV(/��0.o27Oϛ/;gA}93^?4w��w@%V-YkXO/qb@4l���SP᭪j@txݝ.���<lj=}Fz��/ jЃ���ܷk^���g->@@Oѡ?=6���59l-rЋ@Ԝvo\7T��>;^㵓y1G> ���>FFvAz {埻7"T���!vo4 l"ɕyS5mh��� Hqg};^tc &MM���·:m'N?]#]njל7T���!5WgD@OGre4 Ǩ> ��,2o +=OlH w��YfH˾)t!;'5-żY]���FIlH"A@OǠGmZvV]���F첝jz>?'〻,٩.���#k\ܖu{l88I~=yl��� iJg{,:g!o��0?>T7zӽ?X$Z5MWy6շ��omNMlqU}��6?'c۲]sT}��uh[ (Xl,T��`(r&= +>;��HRSG[cK;Vu]aIS}��N"SRPW⶿>���#iZ+m=uГcde澥>���#+qd9?6XrbŪ>��fNe9UO1g_?߹s��]5;g?W=GdJh\=o��0oeyFKa��Mɩ}[���F wW#z[$f͙1S���d%YYowǨ��@^ݳg]/z[DċfyM:N���=8zLrгC#o֔5{WT ��gT%?'}G}G���z&VzW-Ɍ/VS��p%&/fO\ϙ+/_&³lʮ]c +2l{k͑{'��@"vDtBuuBXAZZt +[[sgNz{4'tfX?7}GdJ8]}|շ��?EGE%?X{`\TWUk+;ɚ}\yy ?oZ<޹C~hZ.. ё"B8 +QR|_[[ M_!_qCuQ[��#"[VV9[QzVh'vyomZy+>m5;}:q<Lۋߡ慨��5j0,~KMQSxVG}'X}_=7F鸰BԭzWR4V<L$??gs��z4h�'Df_\-[?C.$.7Rε3zzsX><LL߻3bU ��)SŶ5aeysXywfy[s|ﬞ}"&e'Vo`޹UqAwy9GTWtx��Q<6F{Yq(3cr}iTSg'ZP[PDt,ֺ2Dq (GEDBTDX�e.UTŏ'g, …y>@ >(&dk.Y`g xP+z;ϫ^_)a@Lj__cQ קG!YAAV] +k3՝_}5@1SǺ'eb@CEoGPV‚2!k%@jĂB!4 Λ6Ŝ:uר2t4x#D}_=*Xh>*z?uWBsG~nu=K@! aaf2y'*DlkTo%[>} F}G˹]9,hmu]G4_X+^T'9E&T/!BpX8 B}|̸Ir!KJ 6'GA6JO{<sј ]A&/iU9)P)5EN:B!DS##zx0aǟp ]㒘wך +wh$?VR<://a@d;8}4lZ+  +&Y>mG\^fTU.g![yRBQLy1b kTJx/j핞6]5z*)fl#8 B^MJɾk̋2 5ާM;GU7L7:sS~\1B!n7bY\grC+gkfdLSƮ͐<ErU '~4͞: hv5ygF>m})zoυ-�\-vB}NB 3ccX0ۘLgHO;^Yz{�g<7 2؊&?.2O椦ϵ{mֱfI#mt +B t#LMa,8ǔCs 9gQ>t("{ls l<IMk?ȈO2!@gBĻae1?B|9up??dgU޽5aJO N}6 +{(7 ,iѶfQrnk\h9?׉B7l>Ex`L6SJ CS[vVRÇ</lƃLĿ%8u�Yr{F]~~?-!rh&ϝ +Tx7]NʸVyQP t>sHgt@avVq!?3sնoƘhSUbcςB!6L_&uR/`ǨFu׸Y|>` Z93v>LK|4ؙA>y$'ټzu8_]HcĽ=ߝ9<obᣗGNhS|/JNɥQ~X3B!+̌p`vż B$l!gu}PN}]ia�98ϫ0:S$WuZ$ud$a@0}}?* :M=￦ J\,紶d4 zxi/!,-FplndgUJd2_.EԚm7z?�o5!cQyzHN"ba󜹽C`%&zl +y>\5B!4َ˝!6x(-e\iPw {e +)64�۝M$?1y?< f)'V^J҆n}4A&L,lyR=[xX'*d2 a BWw&vx9?#\}G5hdOP F}.*OH&wa@(=|i4++rSY^rA|!P_320SAMg##/rOE(K.z]` @}šn9'3^̅钏ƾ 5ÕK.nѼ:k6ΓdQ\BXÄ4;S:?3\,hyT{]eɿD& !�5]3$')Ty)Ua e?L=%bAS<XӞ+]c E!kXd) &mQ8U#S)5>On1s}e�wg`O")!Z?Afk1[VӾ{Y{(B׋B?} V9e~FQ(kg\n/uԙ B) Rup(Xԩ)E PDQ@a0, + kd ܀ްTZǥS>lNQ<!W;Nyv?WXfUx;0e1+=yڜ=v-Hb.�NIn"-ޢ^Z9Fϙ5e*ӯBh8v8j�B!JAўߥ_FG[eryoC|Kq:P|o ^D/@H5dR(\8ј8\*O&.dBi.cX<cؤödSK +.=j`wUn/v}�߅Ѽ>|<Sӏ}X?Q <e(>7Ţ!zfL`ysx{2nF\\|A3(M+Y;f} g|/ <;nC>k4*ILS;;C\3dBb98,H__nBq^V-*w]S[K^M?�ωQ }(V~iUqۖRKcwiQa#zO71Vs!];)"|0=ɳRw\.RڒuMKgt9aȼLߐs2Ccs4|~kWdm >e2_!Ͷu.0/rs i{ƨ*˟)ft4GH=�̛٭:1POU +$?H"Er)Q{KN{S}ԁ0!j;+kક+tBqg[ הDz퓆uQ-p|w`%)JsUe4@OAP&h))y-դ3-&3!Gc`<rsDM%}Ybu徨DwL;vq_@hJH? @jhӔ\XTs lȊk#t4YYCF7mNx?E!}Tm]5γ^K.Txg b0N"<Tݩp M2dgQҲq#ӌ|TN ڌG2}!4$3q-+aqCNbn!-~lU2ЁS10Bz;IKO@d 𤂺r�=k7"}>TZ,X7{U7#xgY)<i-[un M('}$^9{'g]nRȣYLB rz::a_p"! +a\,5U ݊-Ώdvf3ưj�.w7 f09 +zgvK@D%p|w>pZ:.aBhP01�l,@F7S)#5ʍA,j|imz�30M̽A+;?Ա?H")rJtG;Be1}!bb98,>[c&N-ʍQE oU&?Szu^5wV�w1 f(;�-f {IԵ?f#nq{ogci$!P_�/ǵ!͊8*ErrgPEwkc7yIȤc?�ωޅ`�|H!=BoF]`i* -{K~CϕqϦf3}!j#YSU}rqE (ͬeΏ�63߯0C 5Kr t4:@]O G2;39%:RO@f  bq3"i1K +.=c<o\cRGj�Q sʀ@ͩs.2~MLE{ڹK@Wikiqf|<覝+tB!œLƨ^&>[lX!�G\J F!}op Թ?H1^}*LBhad),m ^kY1[ʉ[PF){ڕ޾r2~Y‡RM.ȳga0"txLUG4Ǩv 63P?V/\ 40/3a7ʊRNerr_4= ;ץEӆ] d_= ?E 5?z;$u)m8nml8_!4 6 Mk@&Si/Ne7 XܱZEt,e\eQwd +e�zdU"!#$ Xh HmUD|\LQnssNN(Qn;wq9ꦿmQ8OdZ�7EQ$Tv4̽@tUu-ۊE2ҊXC81c$X|D ˊ?P[%*Fz<쓦Oj/3k �;삢}VC ?#2m)ִ lli. &1eSHC)_WmlQqmнWPE_~!{M?CVpN>nW^wW/MiA7Y×nC_r7Ws*Ic\ nuT6vt �s?36&~r:>Ei{];Bx=AϘ#`vcQrT5s"eBWi;ZiZMOcXjWNE< c(o4M/u$`@WV 3]vo[0 X<vrNfn /=^!^v*FvW-Q7yv5kK@N?O($B@g&!A-2F|QcWwBL-=At`i`1nF_t"gD7=JS7:=8`�h|PDr% And$jq iAELMat]:b!8^&)VmϨEVy.n (([S2q[zy bH"6~o=oI)$l &X'gI71s +# I1WΥ=VTvNWL+1l(uPEJc)aР?IEԋO9p23B#6>G{c9]~̿R[JڴLp*!Ojn|EQڒLR-$&J?CBǪ!f Stg)HF-##0, d% +^vjFxDYocS >gwEQ}'T#r|}&_CAԋ.Z xx 4ifs N[P+g ~ߎqD#wc"�;h?$W HчA ȍ՜f;S\*ؘ2z0?\YCC,v:+\]Xfٖa7@@3wEQԐ$䓯NI?CB_ePΈ>n3ޚ;B=Ӟff0o ve96/񐣦cd1ɨ{T7WF$`�;EQ]1"LOhr +y=K FK<䌤]BmضB/cl & |ߐ̸RUݎq8*"NXH:F3w8T迷((x\&n*H󠝑 >O6r\Wݖ,=.0g4qYJ )2aH!j;F #٥ܟnuzXV(Ž(6[aDn >brq^VQ %9煼{43Y!hA"§J3<c/Pux\;>/\g'(j<\wv6?ܒ†&uCi7͚bhXymovavz@pY1q튤s[WuBk6@(^;& "w&F?CC=HE+�X#!o/}-ΰvs^ge*QgT3oE< +�k过(Hr#$F?CC10KsTne>!zA`|1vyeSH*m 6g_zUm_hgC)}~PEQzֆ�F31&x1;Kֽ�GD{n]̇ y3lẙ?PvjFxDbL+V]d= EQO9NryRbc R\2q{wBOR!!o6c`L[ ~~FGR&(~5uq%!*JKEgJ^⥎"CA.* PeZE"d" @Br�n#uuY,hGg${(Y/g?߯;D3k7�d;! ́?ʒBw5#?#AE)uB7@%%n߉L0s͉Zc7N婕:K/j%WUqʧ-{j]?}kj̕ +AywkLǚBwBATSbgCore`@a2i8\A[<1!Ӆ?/.S)uݢ_/OxyYӎuV5Ι͹u/6! 7ۼA$ÔXf^_To +qrHѾlro+ԝ5Ankb cf\WH߱ɇU}e5%6ks~hw| . ۑAAOT@ίv@DAE)ba3Yf$!DQ[ ?#5F)J5>wv"$DF̒\Ks2*eU]Η쬊U4=vq7> AaoIdtw Szhql8+)!2غnIf:3 tgĕy6óXX`ފqI%JJZ/}n^hѤ֓.�HY  oN9}\S)Z(EK3Ayfj6ຑ&HUs"tc ?i8ətXDM$p)S+mZϨɗ\{P{$g>&P|>Ad8R\W$k!aJɁT;]K na0FEu7<+ʭȳO:˄X`k!vdt9ETJug4^zy^O�6?A.CHtw rV-K;_1?&﵇ փu@o/,^ޜEtRѦu +~i_ׇ_r +?Ad$r.*AwA0)r%eɉO۶ AMrT;^gl<LSy6⽍[^ *J~'^q/Ƹ)@J,GA&@zR9@wA0-g%ْS[[^w@VNُstH߱CC Ͷ- /r";mjNԺufbUk޶؉ٍ  LYK7gu?0L"59X"__`K NŹ lM98.|AZ;woZh5712~[Ѻƾ[ةG8=E/\n O۰eIwaM MȹJzqt!KiZ(E~>5luZLv:߷eNק>ҝ9�*[9ʽiqv1=v>xod--45:;+c}lQ}g{.# ȻLO9iuiY`=xDw]k,JdlR$4GJ6v!S|a{ .ؘ52ay7/\^mTFoݖ99u Bk sPQ0,Ŷ]4pI {,`�j^Vo4S!o#~wucF~:9XE[%TK[NIgLVU ؉y  .%.Љtw cbq2R~P([mk{@YW͕l糥P~0fjL\OMNzQ]JJZ/k ~ta$3==_Ao~9R'/5^AwA0?~{n>"wxZJJQ!6Z=^s8Gٰ &$}i +RѺOi OCCXj u"  ~twh ,J)QuTi<98<kA)eJUjǍ\*g+ͬf" qXV)%Aݝ3D D׫(ŝb79mUB yJ{6Xv,X�MFAA>%�He?05L0Ҿo:{N�{�r韃  }-}H =kPWAjQ[[vb$18I5 D'b FVڌ'Q Yv.E A":Q&6*ޜ?v6c)Af~_W|wsΣ}?Y[xe;ʹJ���"Bq=k0b1;qIoUET{��v:Ii0b!٬' +.k4��࿬!^ͪ}?;˿g��Os ; Ҿ]#ty8kRkg��Or'ؽZo1{z{oXw8>��OwYjI}? 1dFy:ū=��ž; 7 bUfsUs�� CX[ڷ +{ 1:vQʹڄڳ��5irȝ}?@bcׂJWץ��{@ ]o!Hk_2>v6ܪ[=��֭ۧp^@Fr??D|7*}$5��t/4JwKo!hcڦ>Mw>[=��;'E= wmB yίl��(w\ZY&2?&E;ݮ|R{�u:js|MB e=E/s�� w{2-ڷc~ʪPy?= �@ϸY6\mڷ#$&؏|Zh== �@Ϩ)<c/;@zE{7wk8<>H{�`${ #o!m'ǀp#;[Z=�@{o!m'XjI$w.\��ChKDۃAH 1dFy:X{6�qb߾bA zg+]'VG��hr4f~0SgrܨILӞ��gMoϏ{훃Aȃc!68vͯt~]?'�qda~ڷ,cB•{ug%��x4n^A|{^֠ұK+9K��5eA 1Sikӝ"g&��;uoF^5AHc!o>ʹ?7�Ñ=.ܷѾ-t.fs}oUGM՞��>ig'. Ҿ-t.fb'RaП��sdEi7njm!|13��t71훂AHcfg(ȺlП��cdoW>ʕ}}S?|?Do מ��c]:{RV Ծ%<\?Bb =QhhП��} .d{dkB.fqo=S�@n>3Hv5o!30#k?ZSd==S�@>)]؏־!<|?ī{ޔP +��ZהPׯ^?Lvҵ.7<Œz +��Z'{u St-fbѾ3h̚W{�mɞ^wH훁AHCe.7^u^3��4'Lk훁AHCz'ChY��pOA_O4FVhBg@L8O~^rN{�{N{,{ZV</<38%iVVq~Ηeęk9}6ʞ��˾}d/ηom).ud}n导5c*s'G s58Oחh\��lYjg>uZ_=mt-WE[&qics��2}mm7hmȶ~ܠE3?S={�0 GUgd/kAzKBJWWNo?ZzPҏ39_}�`6z?m̒8Y&[r0ƹ3j?Zb-pYB{�`6W*?=,X& ۷Cʜ3JWmCh[Tl֟��]Kb|{X'ݙ;)5u@ıZ<ĸ<"kvuCW(q;/\Q=�0kwyڷ?!CQ}:b@͞}|HHԑU"σm;R +'S7iZiyu1�� IVZо47i:1$*u}=mwQv^jJ)Ҟ��o^}үQqh{E&Nsm|je��Yٷ2A1];6-)q_1Uwu7W˒M[]+,:UKb" +TC"U@'C)#pӵ6Z! +.qK%sc4r*|E˦O?ĉ!ҍ]ڷ��SIJJjw(bPAGe>ǃ%e]'g��L#*=T1VCǃ zcu|F�47Nm,P &6 7?xw��SԧX9eQQ]Ĥ?ڦbTy@V�`wJJjw}(ch{Z>x�ΥW^?LCGx8PU}�GJJjw|ch{5V��ե-}~{7uvG<pxl�WĤ?o77k}�Oѹ;<v &~ c,G__7�ݜ{Ꮜv &1m_1HF3=8��vǏ{J%;]n'bRHh<C[�]/,r;a踗gǴ9��_{[zKhwݰ?Iat\(+qou��B oQv y13~}�U9]˩n;bx8⣬"WrT�@)nYғ9EM#1)쏇¦{ު<D�jZk lbY5+<��Bz[r%ko31)1aN}�'g~]mgbR'|wFqx�@[+%ݵYAL +^;o>��Fz1*ЏmwbRkcy[>9S�EzPp7ov7AL +sX3'"-w,}�r~҇\z7AL +w&ܮkX�@W\MdS?Iata+gݽzvIv��nqWTdS?Ia=s��t%ʵ=VM &O%OWo֥��MZA>~2]l1)I.sS��`;’-Ic;4bR?1qo8Z��}ޓ`Ӱ?IaW\nyƜ#{�`i!}7/wDbR0*t?̟��t67@IiwĤ?e}}`@��}zp@鹗.ݹb^QVNeSrp~O��Yפr*wڝk*1)쏮>h��>5g[]k21)쏮<ol3K/��xXe-Kzm7ovǚAL +<*]ͭg;�ZdQ׮k:1)쏮fO}q�@GoY=ָhwk8`ZO/bq;ެ[��tSɓջ5?Iat%řoR\?��h]E;5\?IatX= WTiw��uX/c'ƨwj`nPy��A_qC4?IaLc9*yhw ��m/}p &gfu?>�A>Oz땭iwha+>YQq~T8]W��ZOɕ +ʤ;4ܰ?Ia蚸!SGiw ��s?y+- GbRҽW{f ��_%8ҽyiڝĤ?=*]ͭg;�j_HzJJ3GhX'{N_I��^~p vδu-۶ `r;.];Ok��&vW3 <;Gj:Va,s��sGH/-KvG; xvX:>"X'O^̟;�%=t[xQzII#rMQU0[-LX)?~=�uaG=ݍ`MdϞaW{8ܱ�??C6iw"> ?-Ңݻu5ÞmܮէA�ٔܮkGڝϱ?HWݻɽ{Og13}(͚8� |HHn݅;~l6h!qfgŕ^a_~cPUE�q@8Q  vc͛6#-"{bFWO_=;6JmZ;2ݵvvv;{CKEڸ%"([hKqIҸE."99Nu 9TegX]%љ?_{c$I39s>^W rgdt^󪻍۸yp61cI<k}�0-w3Fjw`8_&iL22Y r;Wk whZOmsГ>w~/�%=Sɿ #݁6 =8{sAε~k!ϧ||n�v7}Jv;JR?3|{bm~�g{\/ߞyJc_~Z}z,iݗ4�ˣK7HtvvbR!!?vW|_��%WP71)!Uu:8U��s$BEzFP71)1nYw +�|Fze܆cb{Ywn-,F� tIH_; &Z,.2&J��X铗mx81)ГdgWN/�@I*i1)0*]^0�@NC?Ia-+ ٥v�B/jwAL +#4sg�'}!KhwAL +#tbZ<ڝ�~_WDIo_ax4bR-0=o5�@*iYIS AL +#u=qP6�@:W.o݅G &&f,gx�>׽i+=4RxĤ?B_i;z{�<\-K!ݷ-}Yx<bRf shw� xܬ臫==Ux|bRXL.2Q��N,,Dg0“a0GVybG։-C{�Gz—yRzAAdĤ?2:m<oH��z*c7?AĤ?*I{\�?@J/hwy~8o/_?f�4Y)=owl[RV[N�M|j{sW"41)3==,?=;B�O|m] &agg{|BN�4GcV &av}eT^�4rɚ=hxbRf0*]/ݩݍ�s4y^}Ac0_LG?g|=B� grcTs8Ĥ?&Uf;.:F$�].w^vq?IaIOm՛ �pnV&.+p絻AL +#|w <�.vǠq?Ia}Σߛ�'w̓!<,]cиĤ?K~ֱ93�nU$ +w+ckw GYZ7oNޟ�Ge--Qڝ &~: +v8+ysQ�@ݖ-w\vi?Ia7Vh%ϽX.�_ME[ro%h:bRkIg_UPO�'o~P)ZCдĤ?s3XE^ro-C{�P7rn4-1)6,eN[y'V�@n zXhw>3fmC+�~rN/d `@Y㾌-C{� ?\)wZvg@u :{pP/�G^<&pzĤ?pǪI%?No�%XJoR펀.1)-av?[Ls�ufφr>kwt?Ian*Í}i.�)M}_AL +wkJm]�‘_Á{*wYAL +`Ul.ݟ[ k.dpN@p`@m&g& ō׺j0�v+wX <Ĥ?PVdoNt~@8{+wwmQNa.@``΀ +6oL_<uhKԥ[kyҗy|P^�ɝؑuB_@pa`MlԨfwʵ1-?o>c[͓pɭg96yv7j>:TmTo?c~UR,%q =& }F3�H٥So>cV͛۵}M˖w-=c|l/mlp:u`͙99@;Y8Ə)PQW(D(TV +zwڻR"e,b8usq5a$$`*Vh~?|%?hm|^!_WGcuY4�Dz`{RzVVLĄvT̽}%vF{=|7/);)b}GVoо$3ү6.Jz881 7eo5ݰt5ܪܼ)]vHQ>;jemiz$v5k�0A$|oivd8221q@Χetc.=MNȑj{fos{^h �n&=*}+\szd3&o8Mkq\~GSpG/5XTf�oߓ^v8 u>*k9#bQizB3.]wܖ5ej[RISe~[Ե< **g7i�F}[GWNt8>&w8-{lΐq7__g%~w~opОg#A8�K-t6Vn>tiypZލyy ஝kR_Ą~cr|kL%;uj}�n }yv=ĩ²v;гpݝ371Y.za?pl[9V־ v-#_p 85IIֳWMjk=ٳ{3/ Wb]ÎqOR0ʊ=nĸtu zOe�DҏkOJ_Jojw7܇AL +Wj3 #v qךMw<�8љOolC4-boߞ}1ҏS &0:<\؁H}�Np ײojgY/}'+yf�Izզ7Zbx_w4܍AL +遭FG޾Uk~�wdU̒e) c`[Y[.gꃦ|E� 5Vz0[0Tpue$?Rw�� ,KP.CNĤ?0nj w6V�pcY҃] s?Ia`(Mޏl~�p8s{KFiw0 &W^9_L��݊{aPJIB;#A� +f.ݽ0ڍy3F߱&ω9�Lkswڝ 3?Ia`8L/Z<2b=\M��kˤv\bR.˪*g?O^�ѾkK=wiw, &ᒒjmkSnz=n�+!=&}mo ?Ia`8M˴BM;5oe�rHu4yޒ>^VAL +-}cvR|й~�.ǿ;7THmNT1)hXR]c9wy;� -%UEwjw)4$gOvmW'�` )ZhQ1.E`qVuj]�K, ֝\*ݡ/bR'X/}':CU�W=oJzK;Ĥ?=,j~c�@AEGjw&`A[}m � gI?ͯ(ݕ_bRpyS� ޷oO^*H71)8ŘZ/=5t�MztTI?iw$3`w#�IGz{NTFAL +Nsy#TY5K HHHIiw" Ĥ?D=1NGX_>B<1)8U~mT9fެ"Hﬨ:E ?IaRrR"v풱�f;jKqward. &'fIi;nO_>`E%=S\}g?Ian[ejSuY�f^l>.=Uw1)AfQ;}j{ObW%#3]|1)ţ; n׵j*^.AL +nْ*Gk[�.Cdy͖|1)Irdak/�̾)/'maیNJ*b6]us;T;1b%O; 1)UM@3�$Kzc.AL +n5!/6Sr5�MzBBzc²  1)_AQg?\T[F3Mƪ5ѠV(Eq\( r[]={glU(.6UQmlZ&̚u#H[38,{LM]9,?XlQ�obqT'^P`]� @ȒG7w.ؕt9��߂zf< @R򒃜fC띦 +�7zpQHZII@*DE7X<�� %#Y(�^HJB�R"Q36Ǭd��K1$sfM�(D\xl|s� :Mw[x5ֵ ?);͆oe� cUz& @iǢ FNٸOGk??;nԈ=Hk��;L ߓE�t/GZoBZڢ(=mrG?ʕ9&EWc�9T1Y �Uz@>pg@PC�RfxBԡ5=I �HӢ@~I\� @(U^ҧ u^zb{?!f=ylxp%}�kxI|Zw5�E%[ >m3'Ǎ % p -)7io h1W-h3��]Íҡk 5�tJ1Uw!!~/q K8;K>&�A>&?ͺ�Н @PN.YZEQdpn͢_s5(ϛ971nRNωxpm? �|g5@wut;A1cɊToО^Y^{?@o0N++(�O,kK>&?)�x2x~߾֜מ:[QNO=˕?*SyuUDd7� sz;L9}?�W-o/Y�<{2Ӑ? _lh>zdx`nj}:W*o�xIph/5wU�ȯ[/7> 5 |Pp6ͯu7_i-Ja_�|j񗧈e];�6/jS +m'u5Ks>Veaˊ:y#m5Wg^m2[>Kfg�|I㯒_Y �Xz3gL;vM2!bGk?�x{+=_i;�|Os&ʹ5k�@$oñ)ڂ'-}W Q +ړ f] !+7nsXf??=ٿ%irgm|3t#KGzR!XlרV</7'LM]4p\.MXaWųZJZkX~r]X";~4ʼNDgɢw#� ?sGz;Ι4^߳ /9Te[*a8!^5ltGA [;jT|M9OYoGtTݱ0pf:+*}My#:{Ztپe  Nuتh4љg(_)kϛ#|R)hVqmBFuՅdO#z6M3%u@oKݔ@!�)IIL)hOy<[[2ȴ(#PVX=56fRqR){9e+8łFc)t~-t~&wֳΚwh[�ͥCT +:41e#?'g]+{*#Q^SsCXa�6:=Ӣo=PF$-d^�? )#E[>O/Ef}><]<ܡ9:5cUfk{7Zo>0n]ibLȒ4 ;.{cɣ{ڣ+OwIDa O95I:$qe{tǖϣrڬ%7nc]+{2Cs֪kf�-\įw?!Z�IIowZتC:1p['-|ԣ??䴞�L6:~5o\PW9osǬ}\csFSOʹ5rϿN^̍۱˫ʥs%)kT}MuBzhRma CSC< 5V`]+{:u=_~w)>u_r|,Ǻ�K @R7ΙA={_B!hZ+7'x7IʅZkPcp]כXy;]crKy8~y|1Ü\Omh{wXO(,1CTesg򣽶V'O {_2Z_c]+@\:<MsFj �ABY'߱/Ӡ,?XDcrftg\&{DpLVDIT\�YZhDAAٛinz{z{D .aԱqKjjj>%qaҦ}"86s~Us/A| hB2_ VUFb{k2U`YY+OM=ȪCO.gpg568R[,mRTu/D7YSX/[('N眮vhEJ=Uoi(_/q<߷̦<b/~W + x~P'wD(@=:Q7y1ZG_onNY]q'c*iUjaՕAŪtj8]ǟAMknk.r=i‘k3ȝ͇(X\oϝ +g&}B' 9 η+OY6duu.CėA&$1sLJ& +f~%괜:JcN;V;U|?'a%[;E?+@yjQ5U�qM30<u7+^*XQÚXJ!]nmC{޵| c^zH6:?Єd?tҷ?^ pZ NsY\Iy{fAMe uIMENϏAeÞ_7w(\*8XSPO>-Դ3!knN"=.劤UB])TV˵6@w2>A=":i7po"diH4P FKlk,J>Z0nU8`$OB_nS +.mOEދ{c}Tܬ}iqs# c{sC_h=` V;>⁻/ߟ4(c%Ş8-@9MA^%kzV;urrJOZe%ʌ J!9~l~A +'RP7P?PGkA +?Єd?K쫫ڪ- bO5π֐5[5 M0.niH H T\n UJn,k3Yƨ3 8m9o!z|np\mזMS"2Fpu/;7!fF2tå~b,9 vh/.!|ib^ȹw?t_  } @�2!N˹qXW3o[]vSBm iQ%�Pln'}lͲ?83\Z3 2R^2ut0nKZUۆO?^*hNP &N_� 6%={iaWE?[CC_ٙP'Nm E4!h"!T6rX& +L E}y ^H,EP P ȓ!`nztTAHӗCQPP1I(eP P ȓ#4aA,~g7t :p8M_HǑM@@'˯VQ*`aw~'"hweH$hB2 -JZU۠{d\K'Doc(!!H"hB2SRM0۽݅ϓ- !!ߓ擮??Єd?Ļˍ˕I3P}F_M"]s"DP |ULIX}1VgHe:E%}懝\%}%Pl.?.]u*Ȑ}~4g{zuks<|<']k"TP |Ud*Ci}?e鈾Zϐ>X>W\oq[cvv$Xn,ziaQAoWH ?"ҹە}ϐSÈhB2_k/%{ -jK#}bizfOǛAHwfE k +AP |QlX２HB)!T{_`c}Ty~-宥{J z|= I<-@(c>=ou׵ǻ -kP#]']d l9덬mz(X5TK:r8VgZF@_\ZA<5yXXS[4-pֻO.֏vF_Ұ&(\zOoX_D&XGF˪ʌ�gùxV:¥auҧ?QP*T>|Y(]?4q8zM:FЗ;:i7#_"8_:<|%]C4MHU?jG|@3@XЗumhuZmQ%7_fǍ +vlՔs<.ߟ4z0^]ZN)r<I5#^SoձabkftX[PTZ +Qn.,^ݳ^Q Z5x8Q[dv2p\,;}ϓ)ht<r>?ǜջ]gu2AiTKu9oN}qRSW!C. c=yO5nmm K([3웉|#l3,!YcWe07g17Zw<y].Ӭe175Cmx6g.cfnk\ks1ߗvtv>P + +?6gM5<Fx᛿QI!J?xӬG5xmM頯7"a'ei?"[4C7w\×wwr_?<*sQZZܾk_@4ӺjWMqrI'!M\qpR)I^wyW~n8bWq]vZd/c4S0╣[wtxh92*V `@cU :ڢ~hŽ~lr|2Ᏻ*WK9U[S? NGK7½%O<1Z5S?CXq_][gv>Oz䏣#e)3Ĺ{j)[rM}کϑylns8ǚ።I]DsǔA!]6C**P\&￑1_VQ{ci!U^x\<n[\<:0Ŏk)czᾤ=!pv, ᶲL|׾\[<C9v;osn%{,r՜sd�vJG(qJ}#SF^nw^DÚ:6͢?Z};}* +5({[qW6ǧ.aMA**G0~w'Y"}?*]5yߋ5WCmrB8]u:WNqbwW Ҕ [t<(o(][Mop1-cFwG&W!]5jeAX*ۑ?<yoTRdyN]* QPvrnXil5_ ɤ&i/DeBox�`@-j>G MYӬe )yˎ[ q[5xedeGv݁5X7˿wܳr\nþ&Q7(~e? #n%g^g^15k s-kǴlaQ3uIwODg(PSbV*wmtF$yKq�xfyɗ/!f?71}L/kH7Zyq>wO#(ȳkKۆ%D<.s%,'�߾_Ĺo~ӹs~jR@Gt}Agk(?1(O?:igtp~:X0)Z(q- ࣵ^ynKljXo5a?MzFPvvK#C)/<ZJ\}[jWE]K>xN}FiԵջ^Uw`=oev#:-1afzkJ\k9%nBOYu/'k(PSb?kpV”-ۿ}(2ll)</~bk;ZJ/'X8;Ѭae./:C_H{i]#`o cV猃;%Ͷ?jN0m{l\9I>߽G?Cv*EZ1~ dROi^SZw=y<F|O{ge@?ZAt`@@e7>7$./ސ%̟7CZZu$bk&"5;~oL"ޖ\oέuBC7#Z&ALcXBqW߮9yO`kxLլfU嵈SA~w qԶ~o sK׋pg\VznXk 'U0UMN]ՆfQh4e0=U{sҷI6`t�=@GTQbktP +cŽq-sY ~7M{uכE3$x?=[(@t}(AO`ޜ?"0K-qL߄e9'&~|pΟp\=$A?TT?"8y\n$h-}_xw{L<{6r,[)֒p?k ALE I4kwEfQh̽k{f⇃sy\y'V6ZsA<{(PSQ X.,n_]ܑ}=4ܾzGr3ݦY4&ysA*A.BSrv[/S|~+{OMtT?ԙ� +k+j] +C+ +"*xYAPD_"W(Dn$EoAR̮Ta捍KWs y~3ϐs!?ߑL~LA\ rOMJ[rEFnmٽEQڢ1D~oAp%? Ƚ5<,cRezͷ?Ks#;v|!'g O~"0nsy+cQg EwQ7~}ca|З&/A Y͔,23P}ALu䏯FwEQ_Kxàn~SߩA}CYcٻu%zu.5bf(/=֠<2r;O {uNzQ=1+>[9&Y?#J>S|{APpP6踤T\AI̔;Zkd5k'SRF56uQ&G@ 'RrB*ku4gym|E}QW/CwHh`Sަk,$F蚰yAv>dk\{VkdgCn?|~w? ><'ЫQ352 oJzTO=?�8==i ~*mخiZe̵?G+r=Gnck 8/K<Ѡir3Յqh?qU~pPJ}~G! +z3G#8@L:c—3I _g/=Cv>pF}n~@g-m+?' +8h<4Ƿrki4^7@<v!a9"9&ˉ0rf{}/y5?# }iV}˲6os -n~,v7y>Lp$%w(96iEqx<3xYDBaG\d3u1iV״jBp{KZ%a@bef }YLBs+wvܼ~=], tݗOuP=T<;i;n?d�!x N?:{;{cmw?,Bā6y9FNl.s)U9!JqQw <ՙj*NVת~!=-/oє}:7KS|? ci4u#Q+<z6;bs _bsPVrF&-WeYoAA?u�Q\{4iZJg<؜ABāw@AA}LN�pl1r"ы}1&|~������c2nWsj)Kt8DۤNtYdu̝;G6J������3(sa+bf(/9b8yD| ����������������������.�大3r :MyA|^oرcFRMuss +Ν?i$&4\iVa;dKL +yJ4jor"yk͹2u8yEUm4yNR_V|`قPskGvB&> fcL9՝ќ60u̝>Wc.s?jsfNZ@Ͻi1<]QW7hK$4u? {њ沲vg傼Xm\}(#l?jªhD_N֭qÐwM`i-:,1:Fx/4O[΃ǮII-C<q3I[kd5k'SRF56uQ&=Ò?o |8waw"=neH(dUU(Yx9>d)v?4s{gaz};Y-~-֨%\h] ʲre쏴E;tgӭQ#-GuGؼ +z%Z<x ܅Mk(!a=]i(qI8ǝ-LvNUR#T`نǮ3-uX0k6atTڮ] +^i)>156d{AߧUrΣw#|^h7md5Ҭ̅uZ՗Ϋ*eFROk5`�aGaqLǮEa1b1Kl3I X*%QSC=֕HmwJV-.aʸ iuWaٿqrkrQ +`}".2ʃ<ݲbkxHE>>Dm>]\Ӫ1o[p#Dhs-=FNjAo s#WX ӪhiZ~3|<ٯ*;߰Z*lNA6ʜq"Yđm[V` ,qu֮P)mAQ,یaɔ-,?vutAhzmz%Or4}9 ]C#K-Jk/P_/rj|êgҞy}׮Ya :5KJ}>\38&詥Re[]pgo2Bϑ<~šF! Ӟ?^e]Ʃ\DJOm^L%mޣwtnj_۱qS,u16F?˟[L]uUiXbYbw3e<943-᳌'}5_9yllW=,5Oֺ_K-|1SIȡ;G?tYj_[L(Y߳#9^K]_ܬc!y%7ON;6n3+$&Qekv=FkVQtDK}A~~|TV=?Nkٶ3P>4Ϸʘ)s?{WSQ1#*Pe y6Co<;r|wz5>rrSǎr瓥 t92|^~<7K,Lxb{K}??s]kyyyQث]U2X,Jik2yu}=Wg3sKX~e':9뙬[^-K{17ƵP>΃ܫ^Qx*,(HMm;2NxbyڕO]mo=2Zx=M]Lt~0='gbGYȣ܈#mlу~jǁ߬1SI{}ݚUW*e.TekgI8ׅpݖ3Ro/tϿW+*momo=sl<k|ekgcF#A2™v, !U'ɩ#N+7?J =6;keeQgLɍmnq򚊊7lػg~2Oû:dhJ{T=.&:? 3'Z^hww s{f {tn\~p瓰ݿ s#d|5|'ͫ%ڞ\dq_2|_hqt&W_}~qzNN*xi9ɳUm=(_rܢise ���������������������������������������������������������������������������������������������������������������������������/�m<B endstream endobj 266 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4333/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnQOcCtoNWX|! X?~H$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$o)txg< s܇'"_I>< D8rxrxr|lqx;){#~K<>~ 6Ǹ_<%_GO>58:58:58:58:58:58:58:58:58:58:58:58:5v4JyKcjއҘ&yKciއXZZZZZZZg.\moti]#wU>fWƼݥ_37*yKcbg]]CZƙթƙթ3|?ď6f~?MZZZZTگQfVCijZ;ݯ>tּJZ{JZ>hSikEq@5CڻZ*SZ*SZ*SZ*SZ*S;*V:V:V:V:VҎαզ4ұզ4ұզ4ұզ4ұզ4tnuiunuiunuiunuiunuih\Mj3\Mj3\Mj3\Mj3\Mj3;j'Wz'Wz'Wz'Wz'Wʎբ8բ8բ8բ8xvuhnyv\b>ƚg׫hmyvN_FicËFgb LzxۧљXsWt n2hN3h+O .?θ6x.4Zz Zdi8j#tէђېއ~4>z^gw]e}y={]a_G;w^DeWG~R7BoW&~]~/"x%o +Ǭ~rW z''< G~pCO1ŶzXw4zQ3]e_Vl׌rSҗw5ST6{xz͞{]blnB/3{6rK7w=;TvjvG,zñT4_~/rC^wl!Do=^ +_؆OzY{y'm>W.<JWm(Ī'b{N b{Kb{j mvMtF?alg]km3_2.4]ZZ\gmo[xǍmoXП8"+;Swlߗ}mac?}{76~ڣu\v~O˾rt ߶#&b[>nճ2b=nw5>b<nՕJb[%Ku֡U>oͷzt9fP}K>�L?Ox-B"^+^ <aWzC/ge>Wyx7Zަ<{׾]Z?wVꅗo^ .gC߽xUx#}}|WoZ.x%ֵ)/}$vjkx>N­jK˾۔F]F,Qۺ1o{^=ڟtsٜ&k (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQOxݖA?qTrYMC�2!�y!�[y!�[gԢ4v_8I5i(a2kP0'0f4 +i8l<J.K0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lй{Rzaw (h^FA?4 I}}?zzmHC +>ŬGp‡YUi 8>ʭJ?D@x"0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=F/Lйi:0BQc4 +{^Fs (t1za=?m7 (' ̀ SzE}Ӂ +]%l\*ʹ*ڰ_2oI*Xv{j^ Ku/W%RL +N<3mxxw̴}C_26lLq ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US+UѴԆmyU2,a伥!�5%/W%RKMѴmSӪDHSӆHIf<3mx^>zkauW8/ub^ Kuꯙ6eR_A*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tݟ6R!�^7ŒR#f>No+۝?އ�`_98yp>D~ ܯuIߌ:OܯuIߌ:x!�W~%K W}H$}0sx-&ޖ|~_moZ_ywys&s5u<!9`iqv۫i} /}?2qP5?-^mN?>6ce&M}@5㸼Cj}|u.tw7>. s?|w=TsOD[Nt߱wml}<Np3s%{7sk_矶yBVn\f]Y$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IR_ �#û endstream endobj 265 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4357/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HR%7 BÎ8{^iW_$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItC z +߇OCzH_;+!߇H_9CZM! +%C6K/nruzʾ+G?h>N|-~-V}~u_|e߇Xbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+Sbk3+SbkGЊC$*>-XC$*%άL%άL%άL%άL%άL%άL%άL?sJ>FW|Z%1?30#oveIlU{9qxEILU{9ove~\%άL%άL}x/OD'~4Oį43+Sbk3+Sbk3+Sbk3+Sbk3+SPkoͬp9-ӚCŴv>^Jk}h|"2C"?ւ2}|b$h>,2ȡ(2ȡ(2ȡ(2ȡ(2#rj,-sj,-sj,-sj,-sj,[iBC [iBC [iBC [iBC [iBC;BVRVRVRVRVΎ$6$6$6$6$6#vrȭ,wrȭ,wrȭ,wrȭ,wrȭ])# ])# ])# ])#;gWƒgWƒgWƒg׭ǃK]7q<FGo^x*:xo S~ϯ5~v{y hA"84WkȬk4ԧ+iFN\I3w(^FL[QC3ֽ^<|,~ +_opw#g ] |>e߾5_@X}}GC_X{}k>L>YWٛݲƟAӜћղF_ѫ(iuy]:[Px.8KK 2]VlnU',j]w>e[-UծC_lm6(V�}ٲIR}։&O} &̛]>Iy/v'Ò>|nޒ o~v ؊�oe-tO+K@6?F~Ȃ_lÕa~kRJŢ?Mن+@e;TNMj*ruf{m +Kj te{n5zG=`r8M_lӵF[L/,tAAvYS+e4G۲mihŊfF7g.vf3[KW^f01=DW{d׿߾lվ0:w;U@WPnLڪS(z9=ܬO'Qmܬgeݤ1<6n'@t#e[7[j<|FMBRߔf24NYڂ3>4iЂ4jƂ(L>%/S?}7DZ\ONgo8{X{Xϓ>xx}Lqjg_Aw5~C|t&yx}rݕaH9sL6*{+ˀ~;vAWVqstѦΫpcmN ̍yYvqF/;꼟6j1}\M]йS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +{}0B^FLйS+te +IkkΣR;lx> /}F!�[# >)u(=o}ä̙i2gRS#4'}0fyL`j%Qc6V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jI郩>LJL_aR`jR/h!EC4N4 :M2C<ͬkϣpYS!8 >ʝJ _F_'胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/V胩:2`jν>Zs/zM+(3`”g;|Q"ur5t`B=F*tct`B=F*tݗq [5ӪhZj6ɼ%`_gcNyU2,ad^ Ku?3-x+:w̴}3ӆ! +{KCK?Bmwɴ*ڰ_3mƥ2hLUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LU躯VERKUɰTއ�hל> h^ Ku/7ERO N!zOM#y'雱w̴y~>A]yU2,afڔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]ufnڔJxanKJ ߛ8]>x|lwtx}C4>s%}3>q%}3}އ�`_9ƿC~f,6\!ImZ̽㱷{[oV}Yk|~~x]+0M|@䀹]o1qAt{|{u;r + I6}չ}\.?>v%ߕcw0S]=m9/ӑ'c;sa|}>:}wq@̕߼ۇ/6ϭ|~x] +Y>s/w ?~fI$I$I$I$I$I$I$I$I$I$I$I$I$I$I$Ie~ 0�p endstream endobj 264 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4227/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnɒaK-)QSI*Tcٻw$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItA; +߇OCzH_;WCO"}>i6!C6!C6!i7}-K;r8}/}_'>[KY[KY[KY[KY[KY[KY[KY[KY[KY[KY[KY[KY[;V|Z%15߇VILh|Z%4߇VI,-feJl-feJl-feJl-feJl-feJl-feJl-feJĺ+M;]a#}hxdە%1߇VIl%11߇VILy+KJl-feJl-feJl?Qoin?&feJl-feJl-feJl-feJl-fe +jԠ.rZ}h߇KiםҚC}h|Bdv|'*m-(O>HMd#5C%v>rV"V"V"V"VԎȫ'̫'̫'̫'̫'#l -l -l -l -l [YR;K[YR;K[YR;K[YR;K[YR;;RWbWbWbWbW̎˕#˕#˕#˕#˕##t,t,t,t]K]K]K]K];WĢWĢWĎ3m&}v_קt]q}~?BW#W6(;tA]/}>~..3W9w#[}dR1Z,E#WkR۵Bt#7}$-=#iMY#g^r3羏UB%O]< d'p>uH?ӷ_*Ҙ>װdV{+z>ыg=7]`OנҀ>ᚲ_M< d<=;-w!z<+%л6gY*޷>ǂDÂ6{o??KgӆO@-#َN.el9ʶ@ [.9;ПorO?:?Evz?&iӅ]tSgd_?}/53@}/(76UH>įףsZߘ)5έ̫ZN}jٴN|ڴ%̅Z|F]0E'άoPAsO`']9'L4SҰ^1gX+]jJW;ݔm^?:eʾƋY+Tq>@eK_UN}v>'u_y>oOփU?o}rx}?$=x>A-C1a?IyTz0¦?t*asK͠?Lйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+tΗk1Sɱ߇�d%tKuͥLj +|߸Pf&5>a; +`j~Tr,æ?|*9a=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FVLLLُKuC4AC4N#i6<tH߇+x[Σ0Vn*5?Vn*5?!3 +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B^FV +{=Zs/S+te`jνLйу:2z0B>Tv.5Æ?t*arL`ՏuqO*`Χc6!Sɱ#_Vh'ľGcwG _Ն$v2ٸ˨Eu ! +{6\އ(Q>4!UѴԆm1MٸT-wЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]#vi Ca[C[z?溤!�Ya[Ci V%BR- mnG_c݆%y}6 +.pدJ:lmƥ2hLUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LU躿n) +afXRj]wއ&'vO�'k{C�-C4/Zއh-Zϟ^Ka1Zϟ^Ka1Ua,M\!IcZ㱷{[N >v.Ǹ3O >mᡛW0M?Wl^gw ~_c"#s௷_·}{5:L>_N1z} }ۻ:wB+,uq{]|_rs?|滲fGoϱ і 16y}L3;v1>>}:q@̕ ߼C5/?g|*d2_N ϟM?$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I20�R endstream endobj 5 0 obj <</BaseFont/PRVGMH+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 267 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 267 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 268 0 R/FontName/PRVGMH+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 268 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat; ]:3UhDD>WEy(쪫j&, TZ)AQAjEhe"b4}IݤŤޜ|y]svpuSX°^  "tӒ4#ȉ*\,z2h }u(ށ= + o0J{LUz:ϔ]/>:a<h4钍|PJAH5NůKJ$3t㛊xM{t_iy5>T>EG#I.T SY i)&A3z-:WZ. åtuX ư8c31bp̂K#ۃ9Nz~2h_㒝.;, '!u1&`D<`(;??0)^cr 9/ cP2& 剦#@`c~H\ r}y4 uœ^l'/K{Od( snLIv-I) LOXB+M&&[Qz`Wજu)vUaDeu[-իA ֬@j $)y=.h)X8=RǤ1YUxxO.{<b7w)<@na[Bj/۾_7 j#鉑aw# +n Gpy0-%2"n� +!1S VW8;gJ,]5?1394-~nFou �)8€!pWP jC^f\e^4-W1^ +OfTv:"bBNm+)z:'Yf=ˢP'8FtIU[~T4> zƑ1 +jxcUJa_0K]RƪᐇH(XYiճQ\Փnknh50&n5#Jm gcrz\hͦ+VV~7xtMbLgLcJ,B1o<r� =Hm\Mˌ e5i8X(Qg(n}ZId!z>ʟCFUk+b[/6^UCߍB#=['MKa3gd6dM*u|T8I$Is91F)3 FXmSI-yl[N~A3MFi~dnbCh 8#r&H +-+kJCiBU ~˖!J'ũ慄miĶcL(w&'^Z 3ObbN1KG%q:"5iV_%}v$˨;TP"H_`ry!/mv)R GvC[3;6ݖx �g endstream endobj 7 0 obj [6 0 R] endobj 269 0 obj <</CreationDate(D:20170110151936Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170110151936Z)/Producer(Adobe PDF library 9.90)/Title(Fig_WAD_TC3)>> endobj xref 0 270 0000000000 65535 f +0000000016 00000 n +0000000144 00000 n +0000058750 00000 n +0000000000 00000 f +0000760414 00000 n +0000178834 00000 n +0000762651 00000 n +0000058807 00000 n +0000059278 00000 n +0000637310 00000 n +0000637989 00000 n +0000179133 00000 n +0000179020 00000 n +0000060938 00000 n +0000097439 00000 n +0000132777 00000 n +0000638678 00000 n +0000674361 00000 n +0000710497 00000 n +0000638055 00000 n +0000059675 00000 n +0000060031 00000 n +0000060097 00000 n +0000060377 00000 n +0000060425 00000 n +0000178093 00000 n +0000173694 00000 n +0000169090 00000 n +0000178904 00000 n +0000178935 00000 n +0000179201 00000 n +0000185604 00000 n +0000186672 00000 n +0000199140 00000 n +0000213473 00000 n +0000214610 00000 n +0000215586 00000 n +0000216810 00000 n +0000217865 00000 n +0000218868 00000 n +0000220263 00000 n +0000221365 00000 n +0000222437 00000 n +0000223943 00000 n +0000226802 00000 n +0000241495 00000 n +0000245109 00000 n +0000246998 00000 n +0000249319 00000 n +0000249476 00000 n +0000249633 00000 n +0000250137 00000 n +0000250924 00000 n +0000251803 00000 n +0000252471 00000 n +0000253169 00000 n +0000254796 00000 n +0000255460 00000 n +0000256403 00000 n +0000256560 00000 n +0000256717 00000 n +0000257286 00000 n +0000257803 00000 n +0000258313 00000 n +0000259030 00000 n +0000259807 00000 n +0000260641 00000 n +0000260798 00000 n +0000263156 00000 n +0000265911 00000 n +0000268968 00000 n +0000271272 00000 n +0000272214 00000 n +0000273224 00000 n +0000274521 00000 n +0000275511 00000 n +0000276498 00000 n +0000277775 00000 n +0000278275 00000 n +0000279269 00000 n +0000280269 00000 n +0000281732 00000 n +0000282768 00000 n +0000283835 00000 n +0000286394 00000 n +0000289678 00000 n +0000292310 00000 n +0000294743 00000 n +0000296090 00000 n +0000296650 00000 n +0000296807 00000 n +0000297002 00000 n +0000297630 00000 n +0000298457 00000 n +0000299214 00000 n +0000299874 00000 n +0000300539 00000 n +0000301336 00000 n +0000301989 00000 n +0000302146 00000 n +0000302675 00000 n +0000302833 00000 n +0000303610 00000 n +0000304014 00000 n +0000304631 00000 n +0000305363 00000 n +0000306175 00000 n +0000307923 00000 n +0000310702 00000 n +0000312985 00000 n +0000315348 00000 n +0000316009 00000 n +0000318566 00000 n +0000319534 00000 n +0000320630 00000 n +0000321861 00000 n +0000322846 00000 n +0000323911 00000 n +0000325138 00000 n +0000326165 00000 n +0000327333 00000 n +0000328649 00000 n +0000329704 00000 n +0000330768 00000 n +0000332083 00000 n +0000335311 00000 n +0000338847 00000 n +0000340876 00000 n +0000343397 00000 n +0000343555 00000 n +0000343713 00000 n +0000344097 00000 n +0000344738 00000 n +0000346478 00000 n +0000347461 00000 n +0000348116 00000 n +0000348795 00000 n +0000349491 00000 n +0000350258 00000 n +0000350689 00000 n +0000350847 00000 n +0000351179 00000 n +0000351852 00000 n +0000352344 00000 n +0000371690 00000 n +0000373928 00000 n +0000374586 00000 n +0000375416 00000 n +0000376251 00000 n +0000378494 00000 n +0000381064 00000 n +0000383598 00000 n +0000386340 00000 n +0000387869 00000 n +0000388850 00000 n +0000390140 00000 n +0000392269 00000 n +0000393312 00000 n +0000394293 00000 n +0000395559 00000 n +0000396560 00000 n +0000397563 00000 n +0000399014 00000 n +0000400057 00000 n +0000401123 00000 n +0000402975 00000 n +0000406071 00000 n +0000408121 00000 n +0000411629 00000 n +0000413652 00000 n +0000415766 00000 n +0000415924 00000 n +0000416082 00000 n +0000416645 00000 n +0000417442 00000 n +0000418284 00000 n +0000418986 00000 n +0000419655 00000 n +0000422107 00000 n +0000422775 00000 n +0000423530 00000 n +0000425649 00000 n +0000426904 00000 n +0000428226 00000 n +0000429212 00000 n +0000430196 00000 n +0000431467 00000 n +0000452819 00000 n +0000453809 00000 n +0000454810 00000 n +0000456258 00000 n +0000457319 00000 n +0000458359 00000 n +0000460694 00000 n +0000463547 00000 n +0000466521 00000 n +0000468849 00000 n +0000470390 00000 n +0000477878 00000 n +0000478036 00000 n +0000478198 00000 n +0000478356 00000 n +0000478514 00000 n +0000478672 00000 n +0000478830 00000 n +0000478988 00000 n +0000479146 00000 n +0000480246 00000 n +0000480404 00000 n +0000484558 00000 n +0000484716 00000 n +0000485482 00000 n +0000485879 00000 n +0000486462 00000 n +0000487143 00000 n +0000487949 00000 n +0000488874 00000 n +0000490671 00000 n +0000495034 00000 n +0000497461 00000 n +0000523698 00000 n +0000525021 00000 n +0000525988 00000 n +0000527028 00000 n +0000528311 00000 n +0000529298 00000 n +0000530303 00000 n +0000531572 00000 n +0000532575 00000 n +0000533681 00000 n +0000535064 00000 n +0000561460 00000 n +0000562485 00000 n +0000563729 00000 n +0000567190 00000 n +0000570541 00000 n +0000572697 00000 n +0000575292 00000 n +0000575767 00000 n +0000575925 00000 n +0000576263 00000 n +0000576851 00000 n +0000602288 00000 n +0000603146 00000 n +0000603805 00000 n +0000604466 00000 n +0000605173 00000 n +0000605995 00000 n +0000606427 00000 n +0000606585 00000 n +0000606850 00000 n +0000607568 00000 n +0000608032 00000 n +0000620763 00000 n +0000621344 00000 n +0000622172 00000 n +0000623578 00000 n +0000625708 00000 n +0000628101 00000 n +0000630174 00000 n +0000632453 00000 n +0000635015 00000 n +0000636109 00000 n +0000755936 00000 n +0000751328 00000 n +0000746744 00000 n +0000760774 00000 n +0000761108 00000 n +0000762674 00000 n +trailer <</Size 270/Root 1 0 R/Info 269 0 R/ID[<66A61AE7091240DC882BCC429578585B><1EE31ADB2D614969962F61D5146EC3B5>]>> startxref 762838 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC3.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC3.pdf new file mode 100644 index 0000000000000000000000000000000000000000..663740b758a5af50be773629108f840332a3870f --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC3.pdf @@ -0,0 +1,3751 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R 271 0 R]/Order 272 0 R/RBGroups[]>>/OCGs[6 0 R 271 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 59213/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Fig_WAD_TC3</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-11T12:12:55Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-11T12:12:55Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T15:31:33Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG8tBcm1M8f1lUEr Qcl9QIxKq5WteJKkA+2Kr/Uj/nH3jFXepH/OPvGKu9SP+cfeMVd6kf8AOPvGKu9SP+cfeMVd6kf8 4+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xVsSITQMCfnireKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KpTq8ifpTRYllAmF2ztCCvJo/qlwtaHfiGNajFU2xV2KuxV2KuxV2K uxV2KuxVL9c/3ij/AOYuz/6i4sVTDFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FX Yq7FWMed9RtdMuPLl9crVIdVVS3LiEWa1uIGkYnbigl5NXsMWQHNk+LF2KuxV2KuxV2KuxV2KuxV jPmnWoVv9L0m3nja6kvraS8g+06wJIpBNK8SZGjpWlRWnTDRq+iRvfuRx1rWFvLqFtAu2ghcLb3M ctmVmWlS4V542XfahFcCFRdY1FmAOh3ygmhYvZUHuaXJOKsP1Tz753gsaQeX+N8ZpYyfq+p3Qjjj vZIPVEUVokcoMEYlA+sIWr8INV5Kt3v5g+e7fUrCzXybM9vdXVtb3F9G80ghV0ge4kaNYAoRDOyK 3q0+BienEqpx5N84a7rsiR6p5cudEY2guXM5kZVlNxLD6HJ4YQW4RrJ40bp3KrK8VdirsVdirsVd irsVdirsVdirsVdirsVdirsVdirB/wAyZ9MkbTbB+DXb3AeSJlqWga2ulFSRQrUNtkMhoOTpRc6K Yfl7qf1jRP0dK4a70hvqsg+EEwgcrd6LTrEQpPEfErU6ZZd797TkhwSMWUYGDsVdirsVdiqTar5x 8taWzR3V9H66sUaCKssiuF5cXVOXCo/noMtx4Zz5BhLJGPMsO1L835CHXS9O41VTHPdtUhq/EGhj 2O2wIlzNh2cf4i40tWOgYnqnnLzLqTN9Yv5UiJekEJ9GMLJ1QiPjzUDYcyxzMx6THHpfvceWomeq K8m2McN1Y3LIFklu7dIqgqViWZAFAJpuQWqAKingM0+tzceWhyjs7nTYODTmR5y3/U9sylqdirsV dirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVYZ+Yl5bMmmWqyAzx3qu6Cuwe1ugu/Tf g23tleTk5Ok+tj+ka5+gdbhvZeR068CWeoHkAsVXrDcNy2CxFmD7jZq78QMcMr9Pybtbj5SHxep5 Y4CyaN5E4pK0Jqp5oFJorAlfjDCjAUO3TpQ74qkbedfL9tYW9xqF4lvcSpEZbQVkmjeVA/F4ovUd aA7k7e+WQwzlyDCWSMeZYrqn5vEoU0mwIYr8M94R8LhuhhiJ5KV7+oPlmbj7PkfqNOPLVgcgxTXP OOua3E0F/IrWjMGNqgKR7DoQpq4rvRyd/ozMx6OEd+rjz1EpJN6if76X72/5qzKppt3qJ/vpfvb/ AJqxpbVIInupkt4Y1V5DvIQ7BFG5Y0Ph0r3oMxtXn8KHF16OTpMHizEenVmumLBDeabDFGscaXNs kaitAFlQADfsBnMwPqel1ArGXqlPfMh1Tqe+Kup74qpWszSxFmpUSSJt4JIyj8BiqrirsVdirsVd irsVdirsVdirsVdirsVdirsVdirsVdirDfzFurZotLtxKhnW+DNEGHMKbW5APHr+ycrycnJ0n1sV lijlieKRQ0cilXU9CpFCMoBp2hAIoqqfmXrWm6ZBpi26zX9mxikvLotJ6sCU9NyqlSZHU/E3LqK9 SQu50+lGUcV7fpec1OQ4pGNb/oY7qPm3zHqUfpX1/LLCVdHiWkSMsnVXWIIrj/WrmwhpMcejgyzy PVJLeSaW3ikmAErorOFqVBKgkCu9PDLcJuAPkxyipkeaplrW7FXYq7FU+8uWZWJ7yRRyl+GE0NRG O+4BHJt9jQgKc5ztLPx5KHKP39XpezNPwY+I85fd0T+xI/SVh73dvT/kcuYOPm5ep/uy9TzJdS7F XYqgdEuoLzTY7u3fnb3DSSwuOjI8jMp+kHFSjsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdi rsVYJ5/1rTZptO0yOU/XYbwSyRMjp8BtrpAysyhW+JD9k5Xk5OTpPrSHMd2iTeY7JTAb9RR7dT61 AvxRDckk0P7vdhv47EkZsOz9T4c6P0ydd2jpfEhxD6opEKV3FR4Z0bzKxLP6nDaKD+7ubdJ4hQdS AZRWpJo7g7gfaoOma3s3PxR4f5rsu0sHDIS6SXZs3WuxV2Kq1hafXrwWwNFUB7j7W0ZNKArSjN0X cdyK0zB12q8KFD6j+Lc7QaXxZ7/SOf6mYKqqoVQFVRRVGwAHYZzT1KvYkfpKw97u3p/yOXJY+bRq f7svU8yXUuxVjnnrWptP0lbW0cJqGpMbe3eprGvEtLN8JVvgQUUj9sqD1wggbllDGZnhC6wsr+88 p28FhfvplywJW7ijilZQHNRwlV13+WRjyZZfrPvRn6F1L/q/X3/AWP8A2S4WtLtY8oajftZyLrt1 6tnJNIpmHFWEtrLb8SLJrBtmlV68qjjReNa4qxi+/J2+vtStdQn1yNZ7UwMDHazs0hgklkVppbi7 uJpmUyqY/Vd1QoKLSq4qrX/5Ua9c6v8ApCPzlqMSEXx+rF7iRFkvFuEjki5XFIjAlwipwA+xtx5H FWUeU/Lmq6Klwt/rM+sestssTT86x/V7dIXPxyS7yuhkbpuTWp3xVP8AFXYq7FXYq7FXYq7FXYq7 FXYq7FXYqwv8wbyGWLTYFEgkivwX5RyIu9rcj4XZQrdP2TleTk5Ok+tihvLMEgzxgiP1iC67Rf78 6/Z9+mUO0sNw3VrMSIZklIAYhGDbMAynY9wQRioKQapo6WR9e2H+jFqmLqsZPYf5B7Dt0G1AN1od ZxDw5nfof0Oi7Q0XCfEgNuo/SqXNoZvK1lIoZ5bSGGdQPtELGA4AA3JQtQdzTpmu0uXw8oPR2Orw +Jhrqk7OipzZgE2o9Rx+Lpv037Z1HEO95XhLeSQ0/JQOIBZqBanYV7sRyoB32+iuVzycI5Es4Q4j VgJ7p2qaPZwJa+uzy9ZZRBKqs56mvEgeA3O3c5z+XT58suIxejw6nT4o8IkjTremAE+tUjtxbf8A DIfydm/m/aP1sz2lg/nfYf1IeHzZaQX1tJ9VuJEhnilYoIvsxyK5pykXegy2HZuW72cbP2lilEgW zhfzc8usKm0vV9ikP8JTmT/J+TvH4+Dr/wA3HzUrr83dHWIm0sriWbskpSJf+CUyn/hcf5On3hfz cfNja+YNR8x3r6peokMcIa2s4I+fFVLlpDVjRyfgUsFFSnQdMwdWBE8AN1z9/wCx23Z8SQZkVfL3 ftemeV/+ODad/hbf/ZnIR5OPl+s+9NMk1uxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KsN8 9Ti9h0uC0innlS7EzrHBM3FWtbgfFRfhap3U/EPDIZBYcjTSAnZYJN5Q1cXNbWyeOzaIwG3NldVV CPiIZHQEuwHLbcAb7b1UXNM4d4VIfLup2cqehbul3KpQSS2dzJI4UdAWflQALUDwPSuwo9zIZIDq Exg0zWwsgubW4lLPVOFpMgVKD4SCHr0NTjwnuT4sf5wQWiimj2IrX/R4t/8AYDInm2R5Bjl/pcen XTxwRhLaQ+pFTpv9petaqfwpnRdm5+OFHmHmu0tP4c7H0yQ+bF1zRLD4lXm67opNATSlD/aMryfS T3Moc1UyyAkELUbH4F/pkqRbXrP4L/wC/wBMNLbvWfwX/gF/pjS271n8F/4Bf6Y0tromlmnit04L JO3BCUQ02LE0NK8VUtSvbKNTlGOBk36bEcsxFmUQWKJIo1ASNQqCgNABQbnOVJJNl64RAFB6L5Y3 0K0r14t7ftnwzJjydPl+s+9NKYWt1MVdTFVGxkeWyt5HNXeNGY9KkqCemKq2KuxV2KuxV2KuxV2K uxV2KuxV2KuxV2KrWjjdkZlDNGeUZIBKtQrUeBoxGKrsVWNDC0qTMimWMMqSEAsoanIA9QDxFfli rciM60V2jNQeS8a0BBI+IMN+mKvHNFFNHsRWv+jxb/7AZiHm7yPILNZ0/wCt2pMa1uYatDsKn+ZN yv2xtuaVoe2ZGlz+FMS6dXH1mn8XGY9ejF/mCPYgg/SDnVAgiw8kQQaKndPKlrM0LBJRG3ByAwDU 2ND4HKs5qEj5FnhFzA814ZWAZSGU7gg1BHsRloNiwwIpvCh2KuxVPPLlkQjXz/7tHGAfEPgruxBo PiI267bg/FnPdpanjlwjlH73o+zNNwR4zzl9yd5rHaPRfK//ABwbTv8AC2/+zOZUeTpsv1n3ppkm t2KqF/dpZ2NxeSKzpbRPKyIOTkIpYhR3JptikCzS3TP+Obaf8YY/+IjFCJxV2KuxV2KuxV2KuxV2 KuxV2KuxV2KuxV2KuxV2Koe9sxdRqhmlhKsrh4XKN8Dh6GmxB40IPaoxV5Foopo9iK1/0eLf/YDM Q83eR5BGYEsb1nSJYZ3u7deVvKxeZFABjc9WAHVWO7dw2+4J47ns7V1+7l8P1Ok7T0R3yR+P60ou TS1m/wCMbfqObXUf3cvcfudTg/vI+8IrULBrG7mhjqYSBJbKa0VTX4OQUCikUA3IFK9cxezs/Hjr rFyu0cHh5LHKW6H5mtGUiiglhuK9wO5p8szrPc4FODoWKhgWABZa7gHpUYiQWkXpmnjUbh4mLrBF Qzum2/URhuxI603A8Kqc1+v1fhx4Y/Ufsdj2fo/ElxS+kfay4Cmw6Zzr0rsVei+V/wDjg2nf4W3/ ANmcyo8nTZfrPvTTJNbsVYV+YOpyPNaaJAxVWpeXzAA/u43/AHEfxCn7yRS1QajhT9quCUuGN9+3 6/x5t+mx8U/dv+r8eTKbJpF0iBok9SVbdCkZPHkwQUHLelfHC0Jda6r5tkt0efQI4JmFXhN6j8T4 cljocVQ+s695tstOkuYNCSaWN4R6S3DSko8yJKeEUTyHhGzN8Knp0OKpFqHnTzs1mt5ZaaLdIkun uYP0dql67CGNPSEYkj0yT1JJplUJ6RBUO3McWoq1q35geebN3gtvKE14BZyypfRm44m5jsFugn1c wBuLzOIFBkDFg3QihVTbyd5w8w61fzWereW59E9G1guPrEjSyRO845GFHeCAFo1YB/Bqim1Sqy3F XYq7FXYq7FXYq7FXYq7FXYq7FVksKSceRYcSCOLsnQg78SK9O+KvCHm1ODQbWW2kIVrW3SNY4Xmk V6fE/wACyfCFpUcTWlBQnMXq7mzwrvruq3EksttMVtpPTktnaCVlVKAMOHoqz8iwP29vkGGNLZKa JqNvK6RCKb96SvxwSooAXl8RdVA22+e2Cmdsf1/SZraG4kgQtaGJqspJZSagggCvGhFDv3rSlTts WtE8ZhP6qNH4fe6bPoDDIJw+mxY7t/uTTzHa+paLdKBztSSxpv6TbPuSoAFAxPguY3Z+bgyC+Utn L7SwceKxzjv+tj+dM8u0VVhRgCPA4CLVEW9/fWsYjtpeCBzJwIDKS25BrvxJ3PEjMTNoceQ2Ru5m HXZcYoHbuTaDzJGRSeFlNVAMZDA12YkHjSn05rMnZUx9JB+x2mLteB+oEfamMGpWE5CxzKWLcFRv hYkDl8IahO3hmDl02SH1AuwxarHk+mQeneWP+OFafJv+JnJx5Oty/WfemmSa1K7uoLS1murhuEFu jSzPQmiICzGgBJoB2wgXspLyWO6u9RuLrVb2L0brUH5mHasUSjhFFyABPFBU17k9Mx80gTtyDtdL jMYb8y9W0z/jm2n/ABhj/wCIjL3VInFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqskhSSvI sK8a8XZfsnkPskfT49DtiqSW/kby3DbxQrbNxiRUFJ7gCiim1ZD+vI8AbhqJ97cnkvQDGwjgZZCC EZprhgGpsSokWvyrg4An8zk71w8meXQBW3cnx9ef/mvHgC/mcnelnmrynoMPlfV5Yrdlkisrl0b1 pjRhC1Or48AUZ5kiyxNlVlKsAVIoQdwQcx3bMQv7MWV29utPTFHhUHcRtWgpTahBUewzpdBn8THv zGzy3aGn8PJtyO6hmc4LqdN6bg7e3b6cBCQvEqlQTAFqAeLcqivY0bIQNgFMtjTvUT/fS/e3/NWT pFpjpvmXWtMES2F1JBFCrLFAHdoVDdaQsWj/AOFyiemhLmGyOaQ5Fk1h+bWtRGl7aQ3SBAq+mWhc uOrM37xd/AIMxZdnR6Fvjqz1CrrHnhPM1lb6XHZvDHIwm1MScZIikRDJErcfi5SUO4U0U5ganCcM dzueX6XP0ZGWfkNz+hRLKRTgPvb+ua13lPTtN/451r2/cx/8RGZbokTT3xV1PfFXU98VUrWZpYiz UqJJE28EkZR+AxVVxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KpL50iV/Kesliw4WN0RxZl /wB0ON+JFevfAeTKHMMAzEd2l2t6e11bB4l5XEFWjWoHIH7S7g9RuOm4G9K5l6PUeFO/4TzcPXab xYUPqHJjCsrqHQhlYAqwNQQehBzqAbeVIpcCAdxX2xKFK3lmlt4pZgBK6KzhalQSoJArvTwyvCbg D5NmUVMjzVMta3Yq7fsCT4AEk/IDc4CQBZSASaDJ9G0/6pa8pFpczUaYkAEfyx1Bb7FfGlakdc5X Vag5Zk9Oj1mj04xQA69UwIqKZjOU9Q0z/jm2n/GGP/iIzMdEicVdirsVQOiXUF5psd3bvzt7hpJY XHRkeRmU/SDipR2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVIPPOn2dz5X1WaaINLb2V1J BJUhlb6vIlQQR+y7YDyZQ5hguYju3YqxvV9Hkt5ZLqD4raRi8qE/EjsasQT1VienY+32d12drOWO Xw/V+p0faWi55I/H9f60tFK7io8M3LpFqWf1SC1UGsdzbpcRCnQkL6orUk0dwdwPtUHTNZ2bn4o8 HUOz7S0/DIS6SbzaOsdiqaaDpiXJW9uIj6UbBrTl0Zh/uzj3A/Yr/rU+yc0XaOr4vRHl1d92Zo6/ eS59P1sjzUO5cRUUxV6hpn/HNtP+MMf/ABEZmOiROKuxVjnnrWptP0lbW0cJqGpMbe3eprGvEtLN 8JVvgQUUj9sqD1wggbllDGZnhCP8sf8AHCtP9Vv+JnIR5Msv1n3ppkmt2KuxV2KuxV2KuxV2KuxV 2KuxV2KuxV2KuxV2KpL5yggfytrMrRq0iWF0UcgFl/cONj22JwHkyhzDyfWI9RikSe3NzcR+ss0k UBj+BI1FVCs8TPzI3WpFK7VpmMHcStRtrPV4bp7mRriaP1ZJFtiV6SBfhH+kcAEMfwg/zfPHZABv 8frTWO4mmk9KWzkjiZGLPIYypIIHGis5+Ib4GdpLqGjXMEjzW6erbD4ljUEuoC1YFSSX3G3HfelN q5udL2gDHhyGj3uj1fZpEuLGLHcq3FmbjytZMKl7aGGYULAkKg5/YBJ+Emi9zTMDSZeDKCeXIuw1 eHxMNDmNwk0gZyCGKUNTxC7+24OdOQ8sC56lkZQlFYFo3BZGA7MAVNO/X8NshkxmUaumeOYjK6B8 k9t/MinkLmArT7LRty5fMMF4/ec00+yZX6SHd4+2I/xRPwREHmGwkDFxJBxNAHWpI8RwL5RLs3MO l/FyI9qYTzJHw/UiINV06ePmk6hfCSsZ3/yX4nKDpco/hPyciOsxH+IPUNA1fSr2wt0sr2C5eOJF dYZUkKlVAIIUmlDlpiRzdSDaaYEuxV5Xq+tDXNeubyLews+VlYNyqr8WrPMtCUKyOFCkdl+jK8xq o/j8frc/RY+cj+Px+h6B5X/44Np3+Ft/9mclHk4mX6z700yTW7FXYq7FXYq7FXYq7FXYq7FXYq7F XYq7FXYq7FUPd6fZ3cMkNxCkiSBgwdFcHkhjJowYH4Dx3HTbFVD/AA9oH/Vttf8AkRH/AM04OEM/ El3lZL5b0J04iwto9weSwRVoCCRup69DjwhfEl3lf/h7QP8Aq22v/IiP/mnHhC+JLvKlceWNCmiK LZQQmqn1I4YQ3wkH9pGG9KHbHhC+JLvLy7RRTR7EVr/o8W/+wGYp5u5jyDHtS04WNyY41pbMOUHg B+0m5r8J/AjOi7O1ByQo84vNdpaYY52Ppkhc2LrmjWhoaHsSK0+iowFIXrJbsKhXIqR1puDQ9V8c jEkhMhTdYP5G/wCCH/NOS3Rs6sH8jf8ABD/mnHddlexvpbB3exlmtHk/vGglMZb5lQK5XLFE8wPk yEyORKOtfM3mIzG2g1W9WS+/ckvcGSilSWKepXgVWrVjKttscw9XixwgZEDZytKZ5JiIPNPoY7eG JIo0YRxqEQFq0Cig3IJznibNl6kRoUHo3lj/AI4VpTpxbr1+2flmTHk6fL9Z96ab4Wt2+Ku3xVTh m9R5kpT0XCV8aor1/wCGxVUxV2KuxV2KuxV2KuxV2KuxV2KpTr3mfTNDksY75bl21CVoLZbW2nu2 LrG0pqlukjgcUPb8ASFUg1782fL2h3Ulve2l8PTit7lpPSRALe6PBZSkskcq8ZPgdWQOD+zSpxVV tfzY8myxaUbia4srjWBEbS1mtpndWnmeCNJXgWaFGMkTihf9knoDiqp5e/NLyV5gjs2068kMl8pa 3hkt543PGOSRqck4kAQSDkpKkqQCTiqZ/wCL9A/39J/0j3H/AFTxpV1p5t0G71KLTIJ5GvZkeWOM wTqOEdORLsgQde5xVNZEZ1ortGag8l41oCCR8QYb9MVeOaKKaPYitf8AR4t/9gMxDzd5HkFms6f9 btSY1rcw1aHYVP8AMm5X7Y23NK0PbMjS5/CmJdOrj6zT+LjMevRi/wAwR7EEH6Qc6oEEWHkiCDRc KV36d8ULIp2mTkUKcWdApIJojlQdv5qVyvEbHxP3tmQUfgPuX5a1uxV2Kp55csiEa+f/AHaOMA+I fBXdiDQfERt123B+LOe7S1PHLhHKP3vR9mabgjxnnL7k7zWO0ei+V/8Ajg2nf4W3/wBmcyo8nTZf rPvTTJNbsVdiqEsJY5Zb1o2DqLjiSDUckjRWH0MCDiqLxV2KuxV2KuxV2KuxV2KuxV2KoLVtD0XW II7fV9PttRgicSxRXcMc6LIoIDqsgYBgGIriqHuvKflW7hjhutGsbiGJEjijltoXVUiVljVQykBU V2CjsCfHFV48teXFWBBpVmFtfTFqot4qReiWMXpjj8PAyMVp0qadcVdaeWfLdnJby2ek2dtJaAra PDbxRtEDzBEZVRw/vX6fzHxOKplirsVQ97Zi6jVDNLCVZXDwuUb4HD0NNiDxoQe1RiryLRRTR7EV r/o8W/8AsBmIebvI8gjMCWN6zpEsM73duvK3lYvMigAxuerADqrHdu4bfcE8dz2dq6/dy+H6nSdp 6I75I/H9aWZunRrI7aSGFJixaC6eYpWtVdJGUp047qOQFan4vDNfpM3rnA8+Iuw1eAiEJjkYhfmx de7FUTpmnjUbh4mLrBFQzum2/URhuxI603A8Kqc1uv1fhx4Y/Ufsdl2fo/ElxS+kfay4Cmw6Zzr0 rsVei+V/+ODad/hbf/ZnMqPJ02X6z700yTW7FUu8w61Boukz38o5slEt4OQUyzOeMUQJ6c3IFe3U 7YQF36Jd5F9Y6IzzlTcSTvJcMgADSuA0jUAUfE5J6ZEG9w25o8Mq933MiwtTsVdirsVdirsVdirs VdirsVdirsVdirsVdirsVWSwpJx5FhxII4uydCDvxIr074q8IebU4NBtZbaQhWtbdI1jheaRXp8T /AsnwhaVHE1pQUJzF6u5s8Lvres3M081tc+naSLFJak20r0UCjgAxoTz5q1anpt3IdlslNk1G3ld IhFN+9JX44JUUALy+IuqgbbfPbBTO0l1PR7iCYvbRGS2IFONWZWLU4lQK03FDv3rSlTu9Hr7HDM0 eh/W6LW9nEHigLj3fqXWtoL7ysPRAeRXmntSlDVlmcqFJIHxr8Fa9DmAcvBnMv6TnjD4mmEf6KVI 6Oiuh5I4DK24qCKg750wNi3mCKRVjptzfEGL4IOVHn2p8LAMFr1br2oCN/DMHVa6OMEDef45ufpN BPKQTtD8cmU2kEEUX1e1UBITxZF34kjl8XU1PKu+5rXOdnIyNnmXpIRjEcI2AV/Tk/lP3HIs7CGm vbaEVd60bgQgLkN7hQSKU3y6GnyS5AtGTVY4c5BM7f8AMt9PsorK00uSf0ldTcSv6Y5liVKoquWX fuVPt3zZ4tBIj1GvtdFm1Y4iYi90qvPzH86XAj4MloUrz+rwbPUd/W9YinahzLjocY57uNLUzKQX eo69eRTQ3l3d3ME5rLBLJK8Z9vTYlQPYDMiOHHHkA1HJM9S7y9pldQqkPCO3HNwo4/Gw4oCOO+1T 12oM1/aeURgIR6uy7KxcUzM/wvYvJQK6QwbY+s3XbsuavHycrU/3hT+o8cm0OqPHFXVGKuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KuxVZJCkleRYV414uy/ZPIfZI+nx6HbFUkt/I3luG3ihW2bjEioKT3 AFFFNqyH9eR4A3DUT725PJegGNhHAyyEEIzTXDANTYlRItflXBwBP5nJ3rh5M8ugCtu5Pj68/wDz XjwBfzOTvWT+StBaF1ihaOVlISQzTsFYjY8fUFaHHgC/mZ97z63gFu93bggiG8vEWlei3UgH2ix+ 85RLm7LCbiCUBaWflTTLq9OsWEt3HeAvZurSukbsSZUeL1oouPIqy0AbdhWnTY6bjzR4BKq+51Ws jHDLjr6vK9/ijLnzb5aWSRLXQ5HiC/uppb2dWLU/ajUsB9D5kR7K7y4x7Un0SG71i9uDDKgSz9IM CsBlKy8iKV9aSYjjT9kj3y6PZ2ISo7tcu0cpF3SClmmmBWaR5V5c+LsWAbsQCSBT2zNx6fHD6QHE yajJP6pErMuaXYq7FWiaDYEnoFAqSTsAB3JyMpCIJPIMoxMiAOZZdplkLOzSI09Q/FMw3q7dd6LU DoKjoBnJ58pyTMj1ew0+EY4CI6PRPJNf0O1f9/P+pcnj5Ou1P94U/wAm0OxVDXf9/Z/8Zj/yZkxV E4q7FXYq7FXYq7FXYq7FXYq7FXYqhdR1XTtNijlv7mO2jmmjt4nkYKGmmYJGgr3ZjQYqk13+Yvki 1t5Ll9Yt5LWKGa5kubcm4iCWxjEo9SESLzBuI/3deZ5CgOKqqefvJZs5r19atLezt7p7CW5uZVt4 /rMa83iV5uCswU1+Gv4YqvtPO/k67uTaW+t2Ml2JDD9V+sRCbmJBFT0ywfeRgF2+KopWoxVO8VaL KCASAWNFB7mldvuxVqQSGNhGwWQg8GYFgDTYkArX78VeTHl9b1DkQT9fvtxt/wAfcvzzGnzdxg+g IXVbE3lm0amkynnCSSF5gEANQHYg0Ox8euWafOcUxIMdVgGWBifwWJg1FaEdiCCCCNiCDuCO4OdX GQkLHIvIyiYmjzChLxW9t3YNUpIisPsipQ/FvT9kD5/PKZzrJEd4P6G2ELxyPcR+lEZkNDsVdirs VTHQ7EXN16zgNBbMDQ8WBl+0oINSOFQ/bfjTvmo7U1NDwx15u47K01nxDyHJk2aJ37OvJNf0O1f9 /P8AqXMnHydTqf7wp/k2h2KpReaiT5k0/TkKkLHJcXAPLkCVKQ0NONDSSu9dhikDYn8fjZN8UOxV 2KuxV2KuxV2KuxV2KuxV2KoXUtLstSt0t7yMyRJNDcIFd0Ilt5VmiYMhVvhdAeu/Q7YqlVz5D8rX do9pf2smoQPHNCy31zc3Z9O59P1VDXEkjCpgQih+Eiq0NcVUY/y28jRW0drBo8FtaxXq6lHb2/KG NbtEWNZQkZVfsoNunelcVUNP/KnyDpxtzZaX6Btbn65DxnudpwYW5Gsh5b2sXwnb4enXFU6n8s+W 55nmn0mzlmkJaSR7eJmZjuSzFak4qoS+SvKErQs+i2XKCRZoiLeNSsifZb4VHTFUzvYbia2kjt7g 2s7KwjnVVcqxBAbi4INDvTFXlIDi5vw7cmF/fVYClf8AS5e2+Y0+buMH0BfkG1juv6dLHcNfRKXg kA9dRUlGG3qUJPwkUBp0692I2/ZurEf3cvg6btPRk/vI/H9aE0u1iu717ab7EttMo+ySCHiPIBgw qpII265Z2pkoxI5i/wBDV2VjEhIHkQg0MnxJKAJo2Mcyr0DoaNSu9K9K9s2eHKJwEg6vNiMJmJ6L suanYqvggkubhbWFgs0gJViCwVV6uQKbCo7jegrvmNqdQMULPPo5Ol05yz4Ry6sutLaO1to4I91j FORABJ6ljQAVY7nbOXnMyJJ5l6zHjEIiI5BWyDJnPko00ZyTsJnqem1FzJx8nU6n+8Ktd+dfKlrC JZNUt3Qv6dIG9duVabrDzYUI3NNsyI4Jy5AuLLJEcykGofm1osImWytZ7uRDSJn4wxSbdeRLuB84 8yY6DIedBplqojzQXk2aS78ynU7heN3qLSTyBhR1TgRFEdh/dR8U6DcV6k5rzK57chydpPHwYhfM nd6NknEdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVWTRvIhVJWiY9HQKSNv8sMPwxV41rF 7cWUupXCiMW8d3qLSyytTiwu34UXYNWp+Gor4jMaQ3dtiNQHuSxfMN/I8H1cWk0bwI0jrPHxEocG X4g7fAIw5Hwk7d8FM+MprHq+nFUV7qD1nKxmNJFb94548RTc/ECMFM+IIS309LPXl4N8MsExEZ6r R4SR8viGZObUSyRAlzj1cXBpo45yMeUuiA8xW7W+oLcAEwXdFduySqKCpPZ1AAA7jxbNh2ZqP4D8 HXdq6bfxB8UuZlWnIheR4ippUntm5JDpaaZjVlUVcLUVqF36fEAcBlzpICaWOpWdjaMbe3eS8enq vLxj58a03Uy8VH7K/wAa5qM2izZpcUiB+h3GHXYcMeGAJP3qk3mO7LqYY40QD41erkn2IKU+45KH ZMesifs/Wxn2xL+GIH2/qQ8utak7sRNwRhx9NVUAe4JBav05kQ7NwjmLcefaeaXWvcgCOT+o5Ly0 4mRyWcjwLNU5lwxxgKiKcKeSUjcjbeWMERY2DX10sBA9AfFcclJUxg7p4Vfpv2r4Zgdoajw4UOct nYdnabxMlnlHd6P5SI/T0A78ZP8AiBzn8XN3ms+j4vQcvda7FXYq7FXYq7FXYq7FXYq7FXYq7FXY q7FXYq7FXYqsljd1IWRoyVKhlCkgnow5Btx27eIxVjY8hae0k8rXVyrzzTTsFaIis0rSGlYv8r/b yBxguTDVSiKFOX8v9KQUS6ulBJNAYRuxqT/ddya4PDCfzk/JbF5CsTEvrXVyJaAuqtEyg+AJhFfn THwgv5yfkxrzLo1hpmtWCW1y87vBdCVZGjJQq1sQKIqU2eu/tkJxADkafMZndLry1S6tpIHJAcbM KVVgaqwrtVWAIyMJmMgRzDkZMYnExPIsNEZjqhT02UkOm2zV+Lpt1751uKcZRBjyLx+WEoSMZcw3 ljW7FXYq7FXYq4kAVOwHU4FZLoNkbey9SRaT3B5vsQQv7CnkFYUXcg9GJzl9Zn8TIT06PWaHB4WM A8zuWVeUiP09AO/GT/iBynFzXWfR8XoOXutdirsVdirsVdirsVdirsVdirsVdirsVdirsVQOsa1Z aRbwz3nqencXMFpH6UbSH1bmRYo6hAaDkwqTirGPMH5teXNDgknu7TUfSSBp05Wr27yenLFFIkcV 0beUlPrCuW48OPI8vhYBVTg/OfyKzTLdT3Nk0Mio3q20sicJIvXjmMlus8aRvEGf94ykKrFgtDiq Y+XvzM8na/JaQ6deO1zeHjDbyQTIxYRvKw5FOBAELjkrFeSsASRiqYv5s0JHZGmkDKSCPQnO4+SY qsTzl5de9tbIXD/WbxzHbRmCccmAqfiMfEbeJxVjHnjULS51zTooXJkt4bxJkZWQgk2jj7QFfhcb jKsvJzdFzKT5Q7Bj/mOyWJhfoKK5WO4ACgcj8KOTsxJ2Tv8As9ADm27M1PCeA8jy97p+1dLY8Qcx zSjN86B2KuxV2KuxVGaPZLe3Z5UaC2IM6nluxHJUqKDwZh4bEUbNX2lquGPAOZ+52vZml45cZ+mP 3srzn3ok48pEfp6Ad+Mn/EDluLm4ms+j4vQcvda7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqo3 dnZ3kQhu4I7iEOkgjlRXXnE4kjajAjkjqGU9iK4qln+CvJv1b6t+gdO+rVLeh9Ug4cm4knjwpU+m lf8AVHhiqoPKXlUCcDRrEC5ZnuR9Wh/eM6urM/w/EWWVwa9mPicVX2vlry5aTQT2ulWdvNbVFtLF bxI0YPMHgyqCtfVfp/MfE4qmWKuxVgXn+4ibVdLf4kWO3vebSKyAfFamvxhdqHrlWVzdFzLHHvbK P1fUuI09Dj63J1HDn9nlU/Dy7VymnYWFwe1uUkjDJMnxRzJUOO6srDf3BBxFhBo7Ma1LSvqDj0yz 27f3ZY1K/wCSWPWnYnf5nfOh0GsGQcMvqH2vOdoaI4zxR+g/Ygs2TrHYq7FVS2tbm7m9C2A50BeR hVI1P7TUpX2Xv7CpGLqtSMUb69HK0mllmlQ5dSy62t47aBII/soKVNKk9yaACpO5zmJzMiSeZerx 4xCIiOQVcgyTjyj/AMd2D5P/AMQOW4ubiaz6Pi9By91rsVdirsVdirsVdirsVdirsVdirsVdirsV dirsVdirsVdirsVaZgqljWgFTQEnbwA3OKsI8/2k1/qNhHHaT3MKW95DcenDK6/vDbkDkqkfEten gfA5XkBcvSSAJthTeUdc+szlbaRbWbiQiWd2jx+mQY1Qo4Wg3boPi377V0e5yuOPeETb+XtYtXY2 1o8by0adjY3LO5HUli9epalelfbccJ7mQyRHUIldG1aWza3vbS5maQMsjJbTxAqxNONAWWg2ryrh AkDYU5IEUSCkl55R1uJv9Fsrq4XaqGCRZBXiK7qFb9ok7eABzc4O0ukx8XSajs+I3xyHuQH6H12j H9Eaj8JIP+hXXbw/d7/RmeNVjIu3XnBMGqRVp5W8wTunPTrqCI8WLPbzcipBPwpx5VGwPKlK9+mY uftGMR6BxH7HLwaAyPrIiPfuyGy0K7s4fTh0+7+I8nY283JmoF5NROtFGaTLOeSXFLm73D4WOPDE ilf6hqXT6jdV/wCYeb/mnKuEtvjQ7w39Q1L/AJYbr/pHm/5px4SvjQ7wm3lS0vY9chaW1niUK5LS RSIv2SOrKBlmOJBcbV5ImOx6s8y517sVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirs VdirXFSwag5AEBu4BpUfhireKrRHGJDIFAkYBWeg5FVJIBPgORxVdiq30YvV9bgvrceHqUHLjWvG vWlcVXYqtEcYkMgUCRgFZ6DkVUkgE+A5HFV2KrBbwCZpxGomYcWlCjkQOxbriq/FVoiiEpmCKJWU I0lByKqSQCetAWP34quxV//Z</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:c18d0876-404a-6a49-8c2a-945305551026</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:03801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stRef:instanceID> + <stRef:documentID>xmp.did:02801174072068118C14AA247F7D2A30</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:19:32Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:03801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:31:30Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY3/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 2/Kids[8 0 R 9 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0629883 0.000976562 422.157 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 273 0 R/Group 274 0 R/LastModified(D:20170111121252Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 275 0 R>>/Resources<</ExtGState<</GS0 276 0 R>>/Font<</T1_0 270 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 271 0 R>>/XObject<</Im0 277 0 R/Im1 278 0 R/Im2 279 0 R/Im3 280 0 R/Im4 281 0 R/Im5 282 0 R>>>>/Thumb 283 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 9 0 obj <</ArtBox[0.0629883 0.0 172.8 129.6]/BleedBox[0.0 0.0 172.8 129.6]/Contents 284 0 R/Group 285 0 R/LastModified(D:20170111121252Z)/MediaBox[0.0 0.0 172.8 129.6]/Parent 3 0 R/PieceInfo<</Illustrator 275 0 R>>/Resources<</ExtGState<</GS0 276 0 R>>/ProcSet[/PDF/ImageC]/Properties<</MC0 271 0 R>>/XObject<</Im0 277 0 R/Im1 278 0 R/Im2 279 0 R>>>>/Thumb 286 0 R/TrimBox[0.0 0.0 172.8 129.6]/Type/Page>> endobj 284 0 obj <</Filter/FlateDecode/Length 282>>stream +HMN1 9/0;NxKBB]p�T\&[{e@\m7DH*@Āsz(7{44?s<,&cY#3=R)Xt6(3YP)+ƚHHn5E#)]< t^ pQyE,?+`%,N6yԎcB{:=Awr +?pe DOL&~?QLPX$4AE Z`�Mvu endstream endobj 285 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 286 0 obj <</BitsPerComponent 8/ColorSpace 287 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 16/Length 139/Width 21>>stream +8;X.&_%"16#QqD/G%):LMgsP/rio3=&mFs0WCH#Y/lj0FkklKF/Up3$PAGIV2`Kl? +Zslp8+ghe7Bl"D7TZeUFdQE;S)upDtLmt2rh$>o;86t?1fTm`X]I*#'okfY&Q*(,f +I]DG:~> endstream endobj 287 0 obj [/Indexed/DeviceRGB 255 288 0 R] endobj 288 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 277 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36917/Name/X/SMask 289 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�aN8<"QڈDLZ3mZ#iQQC+HA!Ԫ, { +YkkNzţizm"W̗߯^C<hڷ5߁5���񋽆Xg)Ӹ93y?���{ .`?rx���o5IJ5CO<ƌ���o5*>f}���o5ĪJw[k��@|c!%?>9Ҹf&3ahi8nGq9|Ϛ^W���X_7ib͋̓q;e +w\?*��@;-@;rXw{ghы/}.A?��� +z]gċڼ6{cSoG#l\{w��``N?/G~?3fx���#|kl\b{���pO+IJ���8J$!ӸqB=���.w]Dt齪���#itGǏ$���M36ӶE?r]e?nZ>DM���brmqھO@Ȩ+N4r27��@gE +ֆw]D#ɇ ��� DxۜGN?QlԤwo��_M:t폌ǍW}��=&wYF]qt>X;H~0w��X֌.VɚAtҵ?g=/:M wuZw��X"Cta-9͠yJ]���V:O>{Wt=T��`e'M"zt5S4���KJ8tgw|_κo��!ؼt{[SNm���Va{etӽ?S{]gU��`E5+褧fT/4U��`E!ӸQJ?cuMWk&'>��R;L1:?.ZymGV(��XI #Q?^5j7��J+[TZ?S7��f@SC]F@'6w墐iP}��UXH@WǪꂉɪO��"l t[޶<qo��];^Y] "hzj6�� +jr+rUo!@v}A���VUT}I_._2o��]??cEUx짦>��@kM2o)i~iDw��ÜIrw/:?2SEެ?PN���}N/:?SҸ?s_T}'��:LyWB;��t&Vgt_Qu|ٯ>��@Kߜ[Z;鹋#,wK[��t7/7Irݷ覿HLՕ��@GC;={bt_ȧ,psV���ܟZf{!\���: +[X@#|h3>��@+<b?*< ?my=3yɪ��Љm[rg%o^?|KUv[钯&=t��ܬoGmUr_z~?Ǿ=Lο/Rp٠А!��+^~Ej6x_*6?`g !ӸոHÏ齹/oK��E[$w23͙&U?7;=O*m9#}R$DB!z;ʿsT +���1mP*.)C !ԧ;DdɝE*I9F~g̒/oJl'=aT���1)aPᩲ:mS;*L F@7x>˹uѿuBXx�� ֌5Z?r&]C>>렿Y@,7#ETu +5{M{NLi9Ѧ]nM&? uM��b)k8tl=sVp(*Ʋ%6i7:^?ecco)?yPg'E#!cjwVݱeZC*UD@<�< rBBr�"(b@QO;*͓-"A$/gy5r7޲Y˫2g���&ɟ_H~wh +NG'#뭟9u]35;cA\0^{oϙՄ(dܻYG}s���esUCT"<*wE݃NmG 6H`0$TsBk__Y1՝yE��._?6CJ߅K4w:ov!/o +a ?MwБ j^TD!BZa<"����X,73~꘹AE~@Pӕ,wie,MtG(dܻ؝k}yN����&L0>(JT7}uh:(KG�C1a) JӒtv]wGPir]}Dy=<tT����xrd{s\ oM]thyjc)`̆bpa^1/6hN`;|2ࡣ~ ���C) :47SNs2/d.zh{1ludĄdqRKrsn[GjaNq\^FLY˶&hKD/5%'IQ,=���@&Ko2R9JhVF9F$!Y9/Uq4O\>k>ќ}@cc"IM +/ L?KiIf /~\ԐҴWvM|:>6���V|rhs +YJ/Y,cQ_w5{ќ}ıru]~OO;`ϕKOcĢN:<5���@MrMCCm/94]eiǭbt֡槌~SПHѤ'ެRE,M;[Jȳq17=c���@'&89!!#Jy4)dܻ-fvu`*?=9; "q0:џ,bi.R.>7����hk +>/;4^rt9Z缩? w! lTj\")>.���|@ƍDYqDv;&zCsR*/%s3i~BYo;HDyM;WHtq��@ZIqE}E${:GyRv ;u;km&e_KuҴw/;IOy��8ۏ${7lVORw AKbل::iMǞf-0$&$XT xǛ3yX ���ΞZKM㲔wOqfw֡棸?�?8nOn=\e-"(Q��ƖD_oZGx\~x>9ZgUǡz?hYq"̒~VKKG{/,bQ)��~b7(+-KY2{i=46c!f_I.5*B.IufL���.d:_Yn?:ǓeG'th0BhnFB�Ca XY]>TuQ}ňb���ЇNv]7,'%*ᬜw?WeYwh lFμA3~'Ϟ��aV$gI!'%!k +ZSwzK|vm*zyA?Љ%x%緣&ng���dd$\"SWd,g?fh'BtC + EDP ,=-}{7Rsh���z`3̒l^z}4\;G=Kޠq#U9ct:k,v? YTT���1|i#TYvUX"wU=4LD69oN}xuD؜=G����Zb=ԜxyRaëk F+syEB�CAŵ35mTIoRul���PXE)?Um3h\滁> :;4�tN{G{\{W[>BC���n43#=<ɧBi( +ix؝>ϹIY'e} 39.j&ӏ���ԔL�H$Q'kb6ƍA*X X( b4U"A#8R "n;"ڹ\FGDbۀb}zI2c.70sμy ) b4wV^e-Z:;�&4GE*gFEBؑ%=���ϽБLNXs4U7f;-N~�c^ݰ:g?@N?VsW2=Ŋ׷x���$/98`iV[ :M=Mա}l>-iPA�x64yi9^OmcG R$G��@[ޞ&'|*u(SߩZG{6ys%5iQ/:CLYdKϺwdz~ܻՙvv��fн;{fۖ'1<.WzޠNk&n^h?lCԚ_ƕ Asmy��@lmY7S'H_nU^չ [P\CٙK].=ve3zWIN>���{dOR:oT~&w(?ǷƩ]͘(h\ ՅHPYW-g1yH+��hsL̲q3DAuIn}<C1w $ sؕvo ��ȮC6kD+͝12zޠNgv0IIs1Lkr£ DA*hyOnEy��Uf3ƍgx9GްF?q]1g?�~;&>/=>y=꼴œx��RQ>vˌ)ut_>q`؟><[(Ř37_8shLo:U ���X s{Mq?\hS⾰G�x>mp*PUܟl4={3|<���ԡ}{6uߙ26z(Mٷ +Gv.?9?J/c?�AٮDAX~TWn���̍:YzLSPYsg.my(Pnb̄r³tYx]51��YkǦҢFt֋;ƼV?wc;%Pnݬy gYI/4 ڙ--cD|^jr���9&vEm%u.<6Ƚ6PN5m3y%uͬ?22=u4y��^R7:).{=^70?gc~yW| +F0g%&!_t(7{sN?.I1Qcy��yQ?t۹1rA}ܳ u/_2A}trb {˒N2MUAjgk��xfظ!C?7Fy9Δ%-m.8Z;~qG#6_UmQ!X~wW,{O���uAC؎ nR8Nwk]ۇDhCr +MHz6=˦u9mlx +��+i f)#>=](/Գb1:r 6:I '?^[4 j6  {W���9FtcɑR8JwEIM![&X']ǰAN +i->b+�6QmkEm7OKxPX CWׇkxg$Kn5ÊMb{?w�6d+K\$uNn|pǩZJ/b(5XRQd<߀=R"y ��mx?uM9~<^ROmm((3vF 7?LӠp:lj��@fuf aDMV%5G w>8R +ŌW%ȍLW:ZW0~lkqFܦIw��`X|語e݇;GAꑇ 8#Kxg#K4!hWK[~ ~54 ot{m�� +VQ4W[zaGC90OǸQ6j Irᝉ?@,t]4 #߃l?雐q*~��@>,f7KJoVt/ʯQЃ{&B�9AJ߄{o66W��+w/UgWvaŬao1;;(>ȕ>|(h.= i]X_4ז��r;lӲh^Uxd=X:qm,Rᝅ?@,r< рh-ѱS5(C (E wr1 j+DQ ʲ= ^0tKRASM$*6bL"}~3{fs9GgdK-YoQ��`Ȍ DGs'C\o<+թn*@BSQ4ժ+73 ws͙MCC1s[o[g���l' +-h,]~Դw3s[ Z)v`݁/Ȳ,s=IAB(73_{[*|yq%-ZZۊ��Ɠx*~W{[޸sоQX)W>fOF='%B<ɵAR~zٺHqwK-0Wb3fZg���dG\܈a#˻9~OGH߳Xw )cY$2-2v{yy<T}|u{ďgrNe +��`^yٛĸRVoSCZox,"}GE^\ɭ/T]u�)ȍ͞Cw>ٺlzwT}6oQ>_���$s|=B"3:UKh�^iD1u�>Q%/[^3EOLps|1iNEc!}$\I?a���caoPNqQ:O]sqGq A�|R~R?(l + uA<ש*Wϼת qr!��ٌMEF8Z\_hpm/a+f~_]FD^Voy}X:o?5B ԝk~���~ +>뇜I跦Nz;QBj/h`uoh +rc2Ew>=j +Ӭf]:Ij-(7o}*���+=ғ]r~spGmQ8�@l+O^+NfqLCe'= lzN,]5v{yi ۳5Bz-l?jk��9/ kNղC;{[cBzL+|u_8 +i`k̞:v\s + pQ?h+劆ҫC.$D=δ��1DWKvZox +TwKyVUYw3|#+%'&8DHkzo?i۲;58��^n$)<BTURsak2}A~l;%PH{hg +$9s )r);jT{r|ټ-Jzh ��vdSXpa:^qNsH9x2Q]ju�{oAp4zmwg7뗬 +��sI\zP}^51[ fyB %;^ei."8{M;?B4y9 +��|cp2ԱB:9N}A[b-8aYΈ {MGNqh`iФ*s9;[@g G ��6חHEyɆM۶MJ BD#TEb]Ǥ$?x׸5{ԟKdzl�qwu%!9&~]ߴ$'ߖMt2#XwW4\ZNq4|rj=F/��nC!Wx0susjZwdG.}'DkNّu�{1?#BHA4$ؑ2|�Ç !Q˃1ߠq)m[WVb<A{üp!� &XiICj9U+�puq! 7j5 ~KZTQJAXďr+KKXwwJ{FLHNq#3>ރ�` α>`,?GlpN_5oj"}C[窩"&e]8E#JUœ͖A]LVyY$b=f��W89@9ݸm?f: eB{JL{�fmqd @hkrSJ_3�yq<D ԹV/\ƾ!b눋_aY�RBr\U]esz["k䍎B!Q�OY$"a~Dup +Vs5mϹKjAC?6˴/,�^ 홫4;6om@�@#tR8a_zHu8. |JC!2AKъK/(ƸIM*De9*4 �l JqcccՁ;_ΨQɕ}>|>yRbxw�!9p +(.t""6{̕e5�Lv5)4E9m6M)0 +� ץ(oYgOg�ټ] eʩ[Q r{3׏OWPHR^g&c?zdEe݃!t|SLvW1� nhs̝2l(QMnT|} B!i>P2{G�1Bde[gPvLJ1x#�V1gd&=ò9j٣h +Q/czz*ޟw7�A|{n6T,z2=+Q}��в%86Gz%Ѳ;c;,  KP/M?�Fh<nʯx[gՄ.-[]{}��Bc Lm^-+QTP,0KQ\8w'�i?E7ޮOy x;�@ǒMԫ/R\iv{bg >`�4B,ibVV+Τ[N[y=�bogfˎla(Ce͟YPһO^4w�ǔ rﺓ=\a<+->{�@esLGljʗ+Lb߹ sݙϙN�Fq;K3%lnބzNo}�F4SV~W;^Ԯ+Kߵ ֚2I:Y�]g#A.ؿ}[]R7'I5Rmj͎uy?�®E 6m$jkA-#ǧu/:: �<!7a +܃'l3A#unۖ��8Ccp7v8j08CXS?zcs@\<kyݧw�y E(/cF6:dջ��aY|4f怰I<~ xw�~7ƳcZyu1.6^-iߺ k��?t;ies6 eA߰9 l^+ޙmy=?�u?7FCiuVe~X&rTPP'��m1x;zUIʻy PBuҿ9?�x1b|mSa2] mx_�2f o󆾖QIw6'0ωPl揦;9?�x1bdXzFufXF~%< ��?ٸ樠\;}Z1!|-f3xw �^YPn>6esԲsoj:��ĭ+۵~]oZj,;}g`e6b0z߻[y]C, W뵊j_+c%ŵ˖}�3o?s}X"ej͡K<i6yuIz]ߢ_̻c`�i Kzrm՛TN� ֥Hb̪%2zj=6bj71?�xyĴ?# 4 cXv#;�<b}Xn*rRl7bs@(vɻ[`�8Ķ?<{}fYÉEV�B&k"Պ̤3NobL:K ؎w�qm{u҄VeeK+(o,́� &͢Wt9QgH֛ނ!|Zz-Yü;�Gczl#}߱ʹ +zeZC˖�Aڣ'۾j;ُ6\Sv,ś˟/yw +�rwv8[.HxYgZfO0@�xu]Hʤ1eHM8i!|)6jeMU{λS`�xĸ?HswͶs%vvfO.,*(S<IM\6BCgou6ڟsv, jͻK`�4ĺ?)$^fXɊ0@�hw + 옟~Dxs,VBd6f^Lԥ%?�hbǻBѷkkq +?-صh�h~+X9/ҌԚ +b[ԏav/;W!?�h:bYQY)KRmq \}0@�x,#< C,Qpshd*gHU ²,#d,o#AݳƙmΙ+Ku �<.lˊ-#VV[_b\;lo?5~GEya0&Ԥ%Fq״1.ADQTdSA\%* |3̇#1hwELb?;$b`#|rν>CgKfkֻ�]UHv&?"mgl�S8FvZsq!iNg+M|c;�5^AuKOϠ%{{Xq}YN= @{{[f&*OtwX"Z~:d 7sP1N "(3w~#i;יX_�Zg= Zm^|sJ?[qBv/<ZSĝyzg@�]'mCS fk<;-] '[Wyg&G9n?]^_ vaw@_mٴ4q]'|&R}]&mg2}[p#[Vz spw׮d/7 @4]gXrdoQV)\S:_CUӳ՘?nZ&> z:vِM+24<Ր(\B[WUzG`-E +2ƕl8eAxPCV&ZZǯ9Y!eyb <ӊ5Xې WC*^@o9$w !KfE�Ȅ4mtgnhsϺ*e0zע-4#eIqf@ͫK[#A˖ SvvGAME !ףU) tAЛ8+=<k?'_ z2J} mgՠ'ag՗.u7OMF;G%/izx!()mA+=B_+Npu4Y - +DK$5A;5-z&3֘kfW {*Ҋ,YjxHf9745]~w…mw]YcMIciw?4DqoǕS>TһݗUІ%Y0/P+$w<y̡Ew!4i tE ;e{8C1}'ww?o +>c͹v?9J#T}-,"p +fkHK֛Fb{v4w^aֻ.ͤ1o 8H7 &'rŗ +22 +;[ϷR]i2/B*yISj܂-t5%U΅lyK~?BmX#W4Y$6vV}|gAg436~YG[;r\":]*.ϋx?Rߺ4qk2#F{2Xs>>^^LT~�^,͉,OLD߽綇ݓmN�!B;I뚌1w�K}'{E[,L*VaCy?pd6k<ZsUT, 4}r^ MTuFl/&w!IOGr*_;I4krw?:60kxlҜN;TW-͵x@߰05%҄ؕO;w;ÿaZ>!4g< Ȍ:uQpmrXX9ohvCXqqlT}VRŋÃzA/Ą;_ 9t`s4os;#4+Z>!4gie(E\){<U?;s/6(;z ԜUMKm036&+>K% +lyrY!"WsXg ;` rܼw6B>3eTsX![K9?MDqѮO;7g}}lEB]^u,[֙�}sf:V͹tG`m:LBHNl3}UįS! &ti Ȍ:uYOtNHIw2T}vJ\ >y®#X'LY$y<WO/΄|Sw+*y!;r4gYg. >J^m1?_L8Ξ-A;3IVLUE{ge/o]>!y9Ԉ\K7u@@VI1 +*Z@0b=X)>Uc$3:UKP2/ !٫'h|e.'?^)y]Ҙ_+d7V)SIFT,ݠR!xBmWjXg{o/g?'W],OQ9΄{+{/&O!Pȸh~/w+fBo֕$ Ei '?^^]C58 +img~ W ^�s&}S25zM~E}p� JXm -Q<ZEQ":zp5 +Ѡ(Ͳr..h[WH;hu:bR }|3f߼/_w �+ڟu9<u `vgqXUEMM'JHGw!Yf3$H[SN�Թ< NOh~3~W' 76u%E4K?& Cm4&zEԹ *ʾ�-{wD ]O?>A*;ۚG%Grgb}Yow f"Bf*37~؅ J< I^�ʬԛiyڣ\` <ӳGՇ&skWmbh`@ΘIWl-6/݆�?sfͫc)gfM˲wR>W9/HJ1`}nV3}4~u/KFo��*hOg hod)geWz~ lMZi=-1AtzYS(3W)QŨ9��E{m GOx?n$.O - ص}ok<] +{jsN#왤7{D髋-*9��UОion}8³=ƒeonVBJdA}Xߵn9S>#LTd_g|Bl+励U��tXӾd +)_"O˻[f"St &ȻdSȉ}A5~ΟlTTas��ڋ%Y9Yw>@x +n wAϱ|+_GHLXwWl5=ڳq2 j_BR'��OSt=gOНH\\) e@SWe2sDrlwB^EgO49Lޅ�Bh/Fe%f)cbHϲop5!s.%_Yf h`TPٺ94gT٥�l��޴\ҷZӏ;Za <Ce'~KIֶ}ѳ<Ƃwj,Hv(߿:7Vas�� CYO- lhp~SWbT,.f;{LgI^ߗ:;i:6�@R㱎ᴽw3?{a3^ +̹{|H^4sygV,I+*'jSźYW^��:?ڃx/֝ `N}tKMN^AȿT{%&{]d1䐯"iU$_kt 6��k|}hN +\˼y쏎7mm.IoZʀ'G&I϶n͕\oH��SJ=Xg]`tHLR*,msK熋RAi=X#Fp//BIr.^*Ro6Wmwm6��*,Uy-e<@x +GDI!P}.v%D)< ؼ7obi>1P$HEVڭzbs��@ +=r S?:Gsrͺ +Lэ&&?3n9 ݾdi n\8`��8ZyV{Xw0o?ѱ﷠0n;2nd9ol Q_;˒[ߚ*}��]C6LJaݽ<@x +G>Ī)vmLi'v꽏Čn ͑%kVo��~+o4}WE{u)1ڿ?=f Mm܎C} IC&YNć$݁}�~z?g�\^a <Y<T.fnYAf{ccޯ!d{g=ɅwnuQ}9��^+Ӿcݹ@x +GfDϹElzWwe,.fW. 2mםҟ rus>5!Rp5��~4WnCS?:ODvbB.y7<!ϘKLK(Qgf=i21{4hJvou59v&\Ltcݽhl��_B{-"+1u)ggIhtBOZ_-Pg';Rf +& +rbbblL ">vE^DȾ��oM5>;4Ӡu;wO\'7*'[}O#DK%#DH_oכC\ri 9��m%n` ;@x +G2YN +egU}7IJW5;��cφ{/cޭS?:Oz\͙7d_=S@@n2I"lS(,n A"ᄶ\#[A"C P.>- Z*EKqm1ſv"`y~hS<�ܭ9u6n[?8u`m ޓ[!��ܭpc_tT`p&CǸu 5c;�@CkM׸OkMI>-=��x?*vK݄t=#<:bok�sqkҭfn۰?8erO+$߮}w�ۑNU6J6Τc4%V~W��njWW-v3ҋ/c��n&} +5EVΤc{rpd��p+ӧJWt+gұ?kGG;� %tJnpً;}cD.S_>'M/n ��7T&}Ni\ <k`Mya9syg3 ��gsHr?Hcp~Eً-|e?q)2Om�{I.Iv.!1 G;ik?gЊq<v{��uyo/Gӧn#\^\֎jgZY~y8�}?ҡi7ױ?hguۼyf|p_i`9�pK椕s#&: ='3~ ùR}Pj~��!ݑB|5ſl!XWvws=2e5?z|gv��qlH4z -שֻCc"E +W+Cutv +2Lnu7GNo{zkڹiswwgs-VG��}B36{AW|3|NcptDMɍOco9@nљwkPxo{"o~��T';s{CG>}`g V cη6`ل\&�VI_>smVgϰ?ߒya;x}�leC/)Z<sE.'cԝ~Nvh7 +�`,X#vpkΤc8t~a;XwN�Zez>ڭ?8 '.>*�9oͬHg[cp&9F<nM[^�KWFI832UO�#ғAvpgΤc8K?7 _J.�s];8-kh ?tI'; �<HZaaIpY;�ptHOap&Ù&m\b.?%Fc��nH'nXvpΤc8S\Jo+W7=7Dg�'nl*#-Cñ?8\ʳV4�@P0F’X?8lia;X[1Yk�U9ŲiۅL:uyrOXm�u|=BJ7ۅL:=< _� \(~tbl½ap&Z6Vg|ow�=#,KY9(n 3fxuٌڭ�DKճR#}vpI0\glC�|eIR7L:9:NJT|`�HKsKڍap&,#<:v��z.W |Zz0|mcp&,-{Z<Pfh�<yt ҃ vpI0/RGX`ͅ �xQt9՛L:mNy۪w�hg#n3fj31>);7T�'{y{KU'"4gұ?5pVlVIn"�]=0v|JKq?8a%vr;xnx.�}ah ?8a'vځ5+ʴ�h:5+佯4>gұ?̗9y}b�h|_|ҺEj7Mt%rK*miߛ�4y]n3+mlthNv+�ҡE~ykMtx=OdS%�wڍAbp&=L{O'w�p=^/vcдIp~KcvA&k�pTOw}%I͵ۂL:U}q@BE/i닶Sl/IA`c@ (HĀ !wv79[$E a U[ڱcl�|^a9y~q=�p펯y֧jGufUUjj𕵔ѿ�ޖ>׾)1)xvz/-�߅gόӾ%1)赤}q=�|=i}b^f}KR*�ꤧo‹AL +#ʝ{??tm�\o>3LzTN7oAL +/گelOk +�+7:Ĥ?gv:y; �훚ot?Ia@LX<mH_� 1)\]S п��˒>^-վ &KevڮS-׿}s�urot?IarOos_yI}w }ww_n�}bR\|`+W=gvLֿ�C}'}AL +_v߂n׵o0�D#]iM3?Ia-S + ja�&$־p1)%>m+ xݧc�ҷһkŹڷ� Nΰ?hUmڐuroI Ngjevx]-MuGKR2�Lzv1]_�ga&-u\гtovSb'LY{ &OIg*̿Y GԾ�` HߦpqbvU_[s|eUɮm^~DүҳK7N|881߷~N֭]cdU] 5l$ҫgo; N(p#]ʿѳ{\+̹>@{$J ؞E+o5�#ϭ~}gc NjIV̚;5W֖իddeνjcU$BS�^ͬIx8#bbRٞs\4uZ˿{C&y7[6cCVa]e>$ �LzTtsmEmC; D6vvիk1]C~|?kqgӾ�=Un?Hg綞7[SF.~f{e_vFL׮W|_Iy6֥Qmk|[/ }K 3p̜ۓO~@$:~e;#__~'4qZ_^,w^wܥ1i>o i܀}zH,˪=grj,} N˘GeG})#ݼiڵϱ?p=3wji|$E@$l+<&)=Tm|u>Zl9OMO=~cg‘io:�D ώMGda&>6]p.OjeEaF,8U6nX�Nv|E[VLnD1)܈^Ix[yjx�N$xvw#?IaF=rZL5>J}zxjIKFdb@GȬI Ug?}I>~cfE#] &}PkCmye L׿�-Kzq}]yvW#r?IabZni.@Cxϼߨw4":ȵ쪳.Ѿ�|e҇#NfD>1)ty9IL}M�4?`feNv' bRhӆXjKo�p:0۲K7Kjw2 &/s:qDh�u_rBOzPa1)tdzCsϯ~'�p{ógiw0 &ΔQ!y>>V�Lsws ^AL +)a+_)un~��`e۞3K +a@gvV]WR1V=�:ZEzNNsa&1)cY3lO߇_~W�%oB=ݵ0evi};�#|+NYeك;fc@$LbٞC�FHIz-OMca61)Sz[�p=|eoKIiw+ &pKz)-6`{Z?:|;�\\Q(=*-VSĤ?afiOjG�ޒY5PK=Ĥ?!>m+ZznQ�x7ǴуAL +Zz'Y[_AQg?2V#zQ'ʹ5:ĄhhGQ1Dv "Bٳ{Ť5K4Kikflyq-wf"a#sikLW��ŽQf3U:M_3| FM<ܵلk+�@O(N~*߃QӠ�oĎNYy��=KrjA@ޙ A�%}?~1;�g7,|Z_;wVBi?@)r,x]��RRY;#`4_g%CfӲ�rIK߆QӠm_lvg6㷶U�M?Cxq|j4l@i?@irB2^>9[�BCC9Dy;FMJxs^~~g[�|veSPB?0jPyn1z{�|=wdʝU�ݡ`4T!,V-_~�((okI3;HfpN6K'�NQ&s#g?0jPٻcXMEw +� ʙY˹g@O?0j)AnIh[^�u<sE%  FM",g"Z2>}�:;K/  FM$p0g[�(ʓmUyg`4MYh[t=8 �x(Gr,x85 xI"O~o;ux1�]:SݒYPSwxA�o4rӛcG$qg�;\(7\z+,FMj|j43:3͒fw �(Q3 I`4fe,g.p3} �c I`4"r$%S ;�rr"\ ޙ4?0jPE[CܒqA�@yMcq#xZ5 ŚY/лso�P-م qq3 +Y`4&uys}ߒ�||rʃ}?0jPp%ĺ%K=wd�qϽh*ۖ%\M� +A� I`y=nI0;�?FCy;�F_Ȅ#ESK|iL_3F#6c%C|tt�`ptVME�ġQVAOOXү0F~W2wO9PS"YKo['�``ўӾ:DП?0Jҽ4Y[BBqi p?@lJ]F{|EP)oN>zܳ`8= }Azx?@D45IbQ$�_7G3` `8[VҽL0öwKbkZޞC�_¶(V46m;CK�?ƚ$]25ОQgg͒F~voo^ʿg?WOf$u}ngC{Lwܴ߼3` `c=}]V,xU}T:yo9K&.dpJދK{O�thiiiyg @C P'@԰ ?<<^4 xgY4f> |3S8㶙o_G2fyiiyg +`@ 1ݲ!3'+|CS~6v\L +j+do�aw!PiOgh_iopw� NC(mܒZy@ԣ_ܐJcj؄{?֔q<}Lҗ2C8,Τ�ogw0FJ{K;C�iӠ7XL_ }vHU:?ܵfz:}�==…Q]zDg ߋі璘e''9uwǰZfVw�<Vwf�Q,xZIo.4Y[C6%v__Ϡ�e/g2gpn-�QKƏ./w�`4?"' e~GjƺfuvTFM+nt&\١xm:?O?'8)m1j -YZ1N9NJ#|Sgm_I_=mCfCø]�Σ{Ci%se3~'3LKb?wX4ݿY%7Sɾu.MrfGa:X=u}`9>"HOߴL WEOΥ"wC_{<ܤŌ~0#૾3u FyuRMu41mL`MDlAa !,Jx"ºrq>.0 kE5әc;S1]\ +r7=?=wv :=.I4?0c?U?}Nej@~^`<xYT[nvZ(e73/#btwt5[5Zm3rNF-[nmy7쿽A2o#13e x@=4t :VuV?q0w?0c?5AO eȒhXgGcۻyl"l/(YBob`nn:k#z+A{z>vL| 5[b7*r{pfU}nqN�9GkuLٵ4-?#UKAw?!w ?0c?>,>cc&ꢣ~]; S?K ɫ<8n?Y{Ĥ(i SiRV  +yrRF}Hho�sx^F8YUϟ+eXB_Л9GkuI݇?^E/C]Ѡ7H2;�A B@RS?} VB>𬄑'כzrX5lNF'1ԋ«&S|m9 +[suV_Ԗ +vO?i^A9:3}~:s~dxS{hȿPDh/Ag9,tGZnR,\[&QϤTzBYS6? -{_`ƔjYTm<FCxMIDoɞΟ!srVgΏ<bu2ӥF'͠/qӗKIkAB +w/g&Z\6d}C?/*m2<w +BSvYn>˜VY4ՙ#C`.|Wkj#m2@W1¹5  !;YBI_7,3OtX; [Y7TbRVSiRVA? k,+1T}N✈(^yadU?mHocoՙ#Ǧ_5)Xd1>}im#CH1fCUVB>𬄑'ٞY E z{\h˕f}W& Y; o{ĉ5Z8tdZ;,R&{g?jnuœdѝHQ-oCJ&4`)h,Z�$-(sm{8O)8Mh`.SSƺOȚ7a͇rBc,}c1~͹")Q`n~F8Gϭ[ f% u1 +rkS5H?8'b�3:z~d;'~*DCµ) tDZ2^@!+8n&eŶQsZRk*'k,M $t5[`\@sͺv\"QƿԚRFu|N, |A.n{C/0s[jcWtt{7-zJ715Liq ޳pt|:?#!:n@?5 B@,`^3zw~?>=1Eig,-}DS}N1(֓?ORJ?`뎒k튪3y5-ɏ6)ex)ېVj30] => +#!x|!=tRnVVnHkA?0c?Dx'PY.  L$E]IGfk'ҚE !u1'Yi>!MoE@5o(g`) Xi6їY _#!)Lf_$1 B +2<m-U5zbI27fwA=$B +2LN + ;@[ٯiH'DWӺ>@ý: E +?0?5xSE݌ǤN! +p7J!??0?ĵ&{׉2ܪ~}o&M"9"?0?&8Ugps<Eo/Eu2>u#sY]~vu\ C潜Mk +#3"3kpIk A + !@B-vf<_T[Ms$-koqUcN:8zj%$< vlG,AFJ^ 5 BOB ű5t#\~"ƢV>Xp ;j/>A-_xmɞNZS*CH#B9e& (_CYӬw߷X[@{c܃8~ ZS5vV[FMՈP&(UJ STtY.]VAB،DZ1+SM_p]qrwu^yi!dbN8~o\6Xoik|?E.zq$-wuns7#Q_f=i#ׄw4n'Rȹ`zgcrN)wgM`6r{ǵf5?f)-e]F"cc?7ȇxIЗ+Y?[-(\zt߷Oȗjɍ3{ˠYGߘ/}A| ?ktxFF79"9Ӕ7n|VhQŏi~8I.F7%=w\ +.TJدc.]m&SB9&[n=O/S ^_=_21 +9~o_!&$SE@^-shM)f@V=lWzGN˥Q4~BqëLRBmIn(znH�d"y<5N}^u\(Ǫ,k2ys?qƂ=ߔٵwp8N0 ͜nuqĮޥ.-ƽVUԺZ[mٜs}ڢy8K7o]uNj\ ]LN\x~LS U90<c;Գ0լܼ; mC7\x.r{Oo'w}1MgM&&Qb„/!EfFOc\l0̚Ik:YzJxCEr r4'չJgkX{-q ' s͟`NrsRª>r>rpgG.:Eʃm:6:žkp}j@!l,oG"gE !ֆ֔ƍkoXgy~ox_ӼwT`/'邎x|WNҵG^>],h211=_1`͟nj8|9]J8PO7׬Ania8>Z&yZsN;r̦NkiUݼ^xU?~DnP=Z\"7?ui!c=)LM +8Acj6=Z®--̊x.;*VdmƔNrc:;2\}k[<>K &.SUH5KӔ7S:GǖF oy,}^}`uXYoLG I.v4?-3ܖ4XOqbt;˵G)4 nsr誥ucUE\UlՈ??5:feѣĮ?_\Y׹ m.|l?2o8ss7M0111`ͿǸ`y7(7UG ^, ^+l(O +,iљ + {v_īryl[:d\YtP/{:Kݑ`p>&@?궋pеiak5`gs^tnS_{Arb[׽Us)I|r LLL5jq>][@ׂ6d S:xmUEt 8d`)@VՇ'm2XA>ޔްkG=+p*y +tAkR*N6pZ.y{evm5-ɍU2֥:3* 3wr{iOM+ ٵ$q탊4d-ܚ?ļ5ק'}E0HyY32\rǵsss)No3vȿԤP{J=__r8i#Ybq|?W|y&&'5jj3 .̊TJ},oGח.L7Uu+iXHr {4sҌU!.;s:1G!k +GKecyAաlKNs@ς?4nʡLi+_Wgx]t<6;]Y VUAϋ|4Xr;bzwwYrWWߴͷhKn311 -SE`鵈'}G1|<sd|\44y3ͽBf~ZI׶*'8tJ\AGl4u9p6rC棳mtt.uld{<q SVV ]<tMpe:ȱ"x^cA^jtyծw[KWbd݋:m +w,Ӌ##InO311 /SER+sゟ~9ejKrE.x>f'Q+϶L+ Q>m<Hn/311=OWcrje'WwgM{i=nU-}4e~Eufa5cDE'Vc$Ht 11 QQqA + ˅۲ +FAgf2`PIJJ7}H8@�JzMZ^Q$^G[6{/׵J}΅gC0vTq 7.g"�)a:y27Q[ao\^]3˭-ԅy!i~}AcE|= +!@JXsV}{w)/E} )81Vݠ?S_&V}@{B{?}ZNܣ}�ojQ+EݝxIዋtlUt򭋢p|W{$32|VmeK}60IO?=!|y"�)c۫<%Qs_/ +ވ<Q _\#jșN/~s—/Zw.g+DY<>ghsoߌAܧJr{ Bw"�)uj7;  v0.35au8O{ +B"�)uE +k/&Xz"X/9WK?'{A'Z#b*TU,,jV+gokjcC}~3B<6JR% +͆B뗺ԚoKg?[TotBRC>DA=!'ŽŸu|U5=q3>MuSxe#XpMaߵ1s1mv=Ob/1yqvgr"`˗j~|YՑIuRTw޽Z\,5A9 +Xp ,?'%5CCTMԤB'yx +Ezfl-׳[GT'ՍGuzR]{ !\?˙àAmy-e&-yNP{ {7(Oۻm͎vI*^3VFN6 aD动GuӨ~SZt!?c'}F�<0?  3@]V&cU%Qs}.P{ Pz=֤D:&fU<k5͏&=\<9>y:P=*EhmVՉ +zlW7:NǴYs}.3˻ǃ^g '7BϦg<ƆeM#mT~sːᵄ +N^n~Ճ">þ=?c*pst 1['(}.3kI=fkvKP_krM[&Vuo|8)| S-u:3]]']Cl=3-r[n_:6{Nrbc޼Tؚ?GI_Kc'[YcbV\]%3z6? +n*7[XO |>^~ZE9;Һi]zgþ3 fͦ9LG17N +uغ=c +-UqV]{ =^wcrUk~!VtlߛRW]|z'G+͉Y3D4zu5`QÆMl㠁;TX֖m6+`Y~Nu}J֓`!BG�0`;;NϿn+MCFѹ>-x?L +!B-Lh^ �sa*:AYk/Z޳t|s-������Џ + +qdy'Dk?ySXu,?7-dZۘ;K8-������Ϡa£.pucÆq^.l����������������������,d2'|NPVhKs,Krvlǎњ䭗,n]eչS&2M_J4wܜؘŎ^2!Mg)v@igVj${nNi'|.t߻X~7u:=QAA#]/xlfg=TI],Ef3i̙>EPB/ +_wf@iԘuQuqFZ=ߺh9,عR^.2� Aq2W'('?;E'ͭw=2Ef,/ x\L{҂Im33̤e9)=:DhR&m^=ǩ}}<c`-̙>سa]kr[[v^Uxrϵa+C=sK[Gsw%s汎 <5q|L/ +sbcK_OQ]w/ HH XbSq Z+C#h ɚF2"Zڔƒ,"2OL'NILLCM]qPwv5sǽgqg=s}ޓqx4{QYH?:݌Tz:?wCky^ɿ<2Fh=Y[S&}~DŽu㣶+#4<׮^m{2?-=u/)9ŷ=Z{h5:2q~u/95,6dYdn|Ƿʳ2]9/e!@?RSo'k6^qcB>qxD%#uR{8|oO#rmt|?6ffiY[w@_[K?_y=٣d:`uwuT6dh}Pԅw[c1H#_GIEѲ&`>SNrr}oi2&kߑq.-v}qBv/7eeĸv+xAmx1SqwEkQ('+*'ϧ<o3_!cDv똣;nx:U׎a E]_f\/.ݪ%L Zx4 ʤ˽u12+ҕ9Zi?Rjmn*z2q;2sg/ߜ ˷%kk*KE<twr'cDQ;ڐkKBQc;nܵo h/r9,N'4?xI>qx0[7jE5/7ee4 +][oz/Lƈ$#׭\m_+ܜ s)|5opoJ<8嚥GZ8<.٧3sϤqX5CեeVkIrbo%OJHP6ffiY?.tk AxD<ϋbcXG\oL,}"%D!?z6xUQwWGUp*ÊV.t8Y=q91V׬xazyGO=Z^}XM:P xx榢)|&cD9;oӫ6ȕ 6<gNgof伬?\OBlm-S;7b9dp$%颢။f4NxaKNLTlwXc[*k]u]113+G)xyC=7 +7|;Fƈ$&S<WwPT]Z?sPMbmn*{js<L߰[G){=te_^D8<Fr67ڣ^^dpəQ}ȑ9ȳ{}sH@w'υڑ앫Vzmt}uu˙5Tub~?8[uZN_f<+g1"^ݣwn^S~PG0sʽ[mPZŤ귦$%ṙMWsxaڿW^KjnKw|cfrNݫL쟶cbBP!;eǨg9-ϳ\}oyK1�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������O�yk endstream endobj 278 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36391/Name/X/SMask 290 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUCKK  -$8 ؈XX1X+cYH4QA𞆆AzNd=7kgE�����������������������������������������������������������������������������������������������������������������������������������������������������������������*>"۶enKcM_޼��ǣ3 Zr¥WlP+$��Ɇ7mt/��@ؖy#lsšޣ{;��BUi̖_?!:V[}$E.j:ǎ5'��=t|\[>pg8쫬t��@8՜d?)5?``R��9Z&O_1Q3fv~{G M]RJ)RVkiѰkqxp૞<5/x3RJ)]iQlPf./N;Sƍos_{FEm\<| +vN厕{VX={Z{ZsƷ_~l*+in>};|/x㟄nۖIs{; 7s5M*;gn~ 3/_~1ϹsAejmii[47\8V[}YlYqnpsǹA WYqnpsǹA W1o[6sǹ=熛g!1��f_#$� k<�}g�t �n5Bb�;FH3�@y�H7!1��f_#$� k<�}EI�@B6e L��K $m|`Kҽ��_!i縦Nt;��AHxm[$��W?I<[Cn �vB6G=X˶G&��W</YrWVޗtO��\! �nM{v +� W) +� B"��AH�t?�n!?��M $֎_xq�2d>[3dCO �;"[xZ?:� m_zܸ{Dz}�2\o?tF��Fx]ͱ*ub[��\&粒gN �AHnd{F{Wubk��DaysGN�Bb�mYkB��HU{kB��H7Jˋjn{dd<v\ټqt>پcE=99999ZVG-%jQYcʸYͯ_}}UqjOA(n%��py�H7!1��f_#$� k<�}bmii̬^:Z<�}`@ѩCdw�a^:8/QFm4(6N-iB{io1QCS`$iǪ,eg9]dqbZtVN_vM7P7>~f ;}^C,h=zUo}mu��@b!ڽxvK���h5,_���hy9Zb|B{�� Dst{]ۓV\5�� j-]|i=j���hK^N<5U ?SiM'q |ul~uO��`^bdb6/-Y*:<+Hu֝2��B;-@IJHV-CO~|i:+Eq\xG��`X~"XXWeki]���ĊyGC< 2��� 'bPAعnh���WPIYW˾���k$AC~V=���uF@h9cxnʾ���>;*"q e��)I*"wƌ1o��ޔ1V<T̆C㨴}���4QU^-F@Ȩ?;v}���4-˂]SbPE(k3z M7��@z ϭ * OO,,���S{L̆d*~w(u~Oɾ ��d'vٷJ7?1>vY+Ⱦ ��֪LoOoV0nyw��{>?Q׬iwߒ}��3<uZ?T٧��Ri<w`Sn/6���3mb-ݿQ?xVmx>Vo}��vض%vvٷ��Q@wgwF {u=ٷ��Qos[C@EǦ}_͞>Cy���"abP@xCYYd��`&%;vL ƾ75*?J׺ MκS}���f_bmO?C<V%;/˾��Lm|M}w {]+~[}���f"Wj9U ES멳Rd��` +Rfwن)T5X,ػ.zYv$7��]&5hF@UG4oxnxjse��`m v jOx@w]}#��Vw6dT2T*_ 7��]PPXdΑ}&��"l]u$*?R ׄݻʾ��@eə&v?#n{72d ��2x}{?E@eCx:Zj^Uw��p\ld(pV(hʾ��@eboqT7$?T٧��(cW'Pp1'Uϛ!V���)O{m1?⶧ih?P*V���h,;>?C<nCٷ��(u}dh.?`#\{ACT���* +2f0XS7QNڂ��PJE-ZEf0";)��PeoWJ]>?x﹎Uf,嫿<S���1I(Įwv?v4>osm5Mƌ}>��@Loov\\JÝMH#QbﶬԴCs /Y���haLߥibWc?i$XӚkgdi ���1!}"|{>I쩏h&vi$_\=_Դ\*sǍ1���K=n[ObG=k}5㝗`T3OG_*k/ުi۝++Y,s���D%t#%]:xp@4Z:7U yn= GϞ>c}8qS#3'ux+i��^zJ}rPGSXdUfvtu3g /G=k7+4Wr{IOx�� %%$hb'_=3 "K/k+vge֎EoevE7 +("@QP BNBNxA,Tn"]/]tt][';>3?&$g|ꦎڠH&LdN2YIּ3Βc~ro۞9cKk{���']ut>M@H N#eӚ^ +���@۩es2vv9]o*Uŵb[˹;qy3?՚Ç ���!Fy%DN|kNabBڶf{,?vm-U\27G5rϔ����}&#uCMG溉z*4opF4%mnVLWt-WR,4?Kv?o +g;]���O pc^Z_spx<*E\I )<0���@9Vj'nI +u +Q{鏣#琲"L(<G0ͻf[c{8 ���PP\>V|'d)*֢2m24 pvf|N*7G`摦EQ,=_v#wLlD0ܶn66���@iA?w>/NN}QqڞڜowozLg5ZEB|7Z6k o ��� c2z?u\W|z +g^1.ۊSw1=?xo UwXbn$j*y򧜜0����h38 /9|.SGY]?/dg~ŎtR]$w9;X a���`/9;=bMt۝)$?uK 8S~^~#yko/)jtvr����VE}C^0E \Q@f3!r);ƫZZ+fSf9>R_���|;zGZ^U[3]o=+}���\w!2FC*+ftO[ 8k.린Ry^6?{SI}e����)f(LH:џcG߿;X.`܄R���wLptI:w8G߿o 8ktz0t;PF:]k���0F]sO7yi N]D}Ě|F=sȯ`ϵF{H}o��� ^٢Yx43F=hLjXyEÆrɤ:���@PPϴׯa:?uu[a�Gcor+}͟Pfޝ-���zd=s2soR +8[t6y G'-���z,7=ơ٬޷š]d;}Jγyu38f��� uմaF1C4Pa�0Vwv9y_Χb!clھ[���X"{G[13¾yCCcĖv6|~۵LOpFl58mԏ����[[_~>2YaPP|Y][p$?B3!fjU"I ����#*h uktgw{�ts8>l\=Jˤ~����O@BB"sRclR?c vܩkwfH����hLcP{N +-wzcLշgi| R?���h}v>fckU7#lQ?kacpn[3F_yqԏ���WG{{5ycZH}C{I.*,{45rϤF!����0'cۖ?SPt4 uMr< =PIK~,jaԏ��� ]rpa-vI\Štʓg6 <^uUH<����W^]PPP`�>{tn{) 7},<"����SNvKSczmMζq'H [?Ub3s%3?|N����͛6')n[-zeЉT[rWԬx4T\&#u���h2B }E,|�3Vw 8)"1=_=( abl[5ԴUJ`J! +QT$EAV.""e шpFhlNxwg2Lʷf=3g8t{wel7_z-���Q\r縛4<mX63�;&87Tp+oIy.㸆✿3^���;ќ']Yr 嗔ľM$6ӹL<X.M.j5���@?ĉƃro7iNFt⓼a?B+g2kt-U[Wz7���?m[vyo\")?Yo/uc?�~V&Ba{}h ?Ӝf���,C94P^B3( 1<|W._="=u87-=z���Y6-kޝMhm؝Jeئ}?@iX]JZ`{I)Όa���_GwݯK)o5 `?@IXiZ~Gm,9oJy7~zE���O6Ú?(HsIg}ЛP>-&ϳ( AZqԍ%}a1/1a>��@I><g&6|Z*+CXzh mtuoS]c&���PÆsu<rO7q�唥) B�8o/]=qAz9I{`d=��%KCNw|B9 +Og&,7a;k؞Ǖ>E ���@(gXƵ_Js's=Y$P{#?ϝۏc,rMmkd+���PuR;<ܒOFXr +݆ Q0ޱ=VX/ ���E/># +M|K\af댄JbOUoyr1`_>;���@a Q8k%|JcO&ݬ9QSmok���@YJs?3{PI/c?@in}Ok84^X ���ⷓXŵDWqW Gzg%(ЙѬT^%pܗiX ���A{(q͊(gHs#KXg#P{4ayYv]O*#X ���dmH@mx4ony{XnT֙Ljs=r'iH9���@RciPg"P"{41~o-  _.j5��L rvDṷJs1t_Y^G' +ư�P |Kdz'ֻ���yZͫ3M祰w)LY^SvL:BU���@f(?T5|AyʤPuB�RqQg uFVqNv3{so{Tp~YyY,���(?,lAX\ +=/đuB�$\, +;##>X2eywdj J ;?.9 ��� +i ѱ=,V:\xyL.ĩ@GGN)ggcEzPl7qϮ1ųo ���7s4k~GMhqWiCXg1`hvQmm86j^߳:3;\-'p͊ϴz��@ti+'P披g3.S`}?@. G3˴zM~Ƭ^߳A) +w=CMۈ}��� ocGD-�ihq3,yc2̃rRf1ֳ) P{r6ֿk?9&/ +9Hs%56z0���Yƞ%;ם%hUYIyuA�99Ӟg|}m?hvҗ&ռxX]49;?%��, vuFKs +Q0ݡKau?@nJy¬#{>>?6z{O.cB~xz Qq߼#d2���ѮUk(_P`u?@n G3˴zM7f^W8Q;TsP:2cF>oI0eGW |_ۻ>ػҠqTZ���' ++gJ  ‰HG:zf2i`o"LjEy',Ekۨ!C{}eмwK0;9Ů��@yۏ"# ͓j fYCC9 썗$C PҢ==9L8ҖϞ5Ͷ��ޅ9T aeBsuA�9$'NbT@_QMYoDhQ@X(jlU +&&! }SV8z*߆8̨!wp}%/-Zc! { wqB]$52g{ϙJ~%!`Rdj**@DX)ee^b娟Q\$׍%j&F֍BP.6*mf{RZ/浐\Au2{F. ߹%d-=N,f.z!@-6A7{3#Si ec5P.~qv=ɶ謊&SWB;*4dD}1ir_=<l.n<Au"2܄?IE{b79FhիE!;@WU~Rܮ*n[.mQ@Cp^  ߏ{zW8�7$լh+wBKŒjZx@rYRV?D2#w L(蜡OzB!hjB)+3 ֐{܎HQ!3 S`}x.rJ׋/B!޼'$%l*݃Lo \U0?2SA&U[2 =>iWBK> ۭ!SiZr6-L*޼VRsb);E_'yjCLv'ҧz!z9M yaqc4w _L]ƃڈ=O$k^ !8?M _b^㕲ƑGfo(rk0T!RZt:Μ#y q[sЎQ_Ⱦ>,݆t4Z? y%F.?SAƃ><*nZ9C=#BcП/4{ K驕x<vl&1;=Vwih;VP)(nqD-I�/j ̂?&xY@iFgMlțFDWUz!{'Yӥ`vIwv8w$؀y2Ҍ^HkB~^1- +YWTƝ{t$erKi!�bg�@>$/PY 46vJݫ~s*y[U5B!頧sπ Jcne ^ۜTB=4|}>:?3:<71ީ0#%<V)`Id¼2bEV'C_:ժ_*fSD=EP�E;[jj}H>|NuVР?ׁDon ;36t*QlBh8554~̜2K`)l[o{7;]'Oz"tion%٩aL4]%rԈr,NkY[@COOͽu;I7tq G\Cc @.&Q}x:$'PU 4h2!D->{i3:]GB'說` Zd]=#09Kn\iVGZi v-`bc8|کz}\Vߔ#'dFGsbI)bVک\ff?Ji +?Txwepw'MGZw?ov[/gvkph h 8 + p`QH.&n:`@WcJ% "HBHYh|O =}y_6P魍M[Ys6ߝHfޓNO#>7Fia˙'#Ͳbױr&71މ&L@QF39̌ ܳ<VLȩʄkRT(:US5ikEyHG^Z.+!=xV}kzj-全X]p1z?}�bq>m  <`@Wc9!Lt|7J9--z!^P]O`x l41}[i.^^1AӓC/>{enBVQz+̩$UBNTȽ) +:LϿ[Sw}R1$Yv1S-A]>4q㱈g`_}M{]2sZSy3'O+6zrae擻,|XkH6PȘNkOѥN{�C�2O {�J]�v2jL *UZ2 +U@EDMT6YBYB$`d1!pRaZM>ιyt�k �c3p|QYdwyyPg<R>zy� +4A}ӛ fŰmZ8@?="$?1nuIFnAnV RFss,7{$gOk/g ' ]vxonzHd܆Z=k1Q-0T9p-A .GzQ&?t��E�U|E@D/  ȫț/ϋK0^E3t"1StFf3kmᠳ˸c?#Si1)'f-̡ 9 "nqh5 J~m ;.mݳ&ON%|iL Wc0p?@~L~`%ӊxeydw3TwELϚL^GKk`&'ڑ}/J +L҆9`傅I!C%_/=2b>Dm)-m5#;MqYWD<u.fjAϚ]&\7헊%E(@?@@6{ 3hJ>@v'A@?#AFϺ/y '}| x88*D9u,tv^|5;3ŭ +8+1;\Ν79<֍x֠$$_K\-fT-"ӭJ":?x/O0r"f?6&RT!ȽD\H#PECM NS#cXenN6ib^ոI&5TZ|}I~!.9Ws2[rOh O^JlĎ~kz7gBW2H.�L{W@2-n<BvA@7#ooM~aK#2 +"sزqW + w|%TKynfhmQn(_4񊺿<+J(yF}~d͐aί5V.C9߭0i)ct XD  țW C7˳ C{)7Gypu0х`lZvoC;\Dž{{k$ 4Ȉ0HegzTгu<hrK>lɽƤGC%Ϛ~aGsnjHfڽ��# ~[`HA 2:[Pq&DYv9n T@OS E`oi5 .;ƅTO754ԥ)'yӾՌF.S"yޖ2F>q\`ku]*q; ֭|}t?hu2908 Uپ'> 2:D<ruR^QDKk`" ꠯=M6yg&6X kmIu%KpiQ cR|*YԳE9 lz /w_xJ%^cR樴$G>]j9$v3XJ!ш;Jӆ1 4�_=O*dwyOXA)Yu;CW8rS3?Ət` +̟aK`oi.G|NWJ^h)!FQ9߬(HJ\:J/:VNeckD\fJzf>JZ[OCjucc5<q#yۺ%Cv~G8CӘr'kBW*\ 8|ט\]),I26D|<Nѧ^U�je򳏓EQ&h|: s/uF۱s\z^jhq65ƂFxZ^e %ݲw>+n?&S|[\'+|=8|#RdžוCb'3l&"XkJ]BwgOF5@v/`@6�=�`>dZe} dwy;] <vÖgőo&S 2:`jd -NWJ֩Y qwgQ82ox%rf>ZgufƤc2%AavM-Kf�DFT xDs&^NGB=B!"BTm)[Xvi+Rĥ#mDh"ĈȍL:{|fe;Ki[{7}"RCUo NH%!"3�NWlbϏW{wyy?K-vtY<cB(|XhihftUUllFp0Xp|~\R$\K?&;+|m+;JMf/ӽ-lt9@ԺRlKm`o�N!kY5?d`J`:R(7ww93`Uzr2akvmfoEG |'I\ 6GXIBmc2cHNs$]g} qurp>"Xijıa2^WnrLD0^tFO;DDؠ8}qKEFūʼku2(7wܖ5jEo5RHHb!��nAWyw X?(ȝfEzF8b*dH s^ͪN&ʥwK-%G)Svp`Tr{X^hYIݖ'6;Lؘsjܯr͏}?׋3NПm>F{CgWX,(5PԶekg5%Hٞ=Bw�� otӽCZvw x?ZJ=gX!E-.d,GkU~!;$I{F4"?QgudF7VBx��f)]72c åA͈?\$Mo{=X$44X-2EW25S=T^qTDe{CSE)&$ل>���x\׿g}@@kk2{β,KBJ&ʙM"=Q^:VgK#Ǝ#*/O>J|cFƯz7Zo:5z��QaݏەY-?dpZBbKWg +WM.ƌyt"TTe&Էcg֢4|~\RZT#ކ\$6KS[̺|5HWg=��p@b7f%ES &^~i{~eB5*m>'3- )'G$MSi5i/jZ-wCTr|97Bw��~tSg}@@CڀDLeDAϹv7c;E&=lms쬱1Gw���x=.M%K}N >h&ܿ94䅗 +Fk{-���oOНk. C W deɗoqS,XR"65e>��ft_f\g=. C W}g>_w_׹4U{d��Zto;jC nm@x2AAEV⥾%_YkۙYZx\t3:{3y ��?ytC AwC?Y#{91!mU$$>?/o;U֦|S�� nKg,YA^-\#mlaLޅ]:ۍ\#MXb���{:Y&,V6`~w@@W )xz7S>Tk=A/M4^ f>��fǪto +;΀ d"*kd{V::ٳ���\S_ϗf}g@@Wdz#@ϡ9n9 ���OHL7z +) %D->Uz��SuZf}W@@Y`!Z#H:#Im<CöÓY4|��p/^ޢϬ 1Y񡧄)~&ژ+::JDWłq?ۈHEur#*X\���;qe Cw?%zp>>{t#CzWa>w��w';bݧ ț4 GNk_>}��KӳDt/ țjjD._pAנ+k=^#_���iU뺛Xz~N0\ oJ<lm7?;נ6O,Ct0 ��&yH!t #j**_T|EGl|fɥic^c8iֶi]Z.I:ifڋ$ IU2F;eX(s#xC1]Q +Qp[ÝUEI^Z|?O� THwIlAq&{ϟ`koy驝y_<c?~Z'X^٦Z[ �@h˨ ao;a`^GS kݺ]VrZ;6bۺ@7M +R_׸\�`+,&i]7&LĎēVuqgqȀ#:{ 7ix]\O۩}�0ݕCiU=' `7 vKpb;\g_|vxֆ%w��SIJ.,X7RA옒ϔۜ1&? kuڑTm�TҳҷһoGbԺ^?wc_BQ8rx}�4үҳc;߮Ĥ?oߴv{.^;־��ҳҷڝoWbRp;6.ӿ��q%! ֍z;chqVu.FV�`k_gĤ?o~ڗS>~�pIk^xch|gԾ��8ݹ}W_;Ĥ?̜ܤΧT��8Յ 1{k0nw1)wӵY ڷ��=%_Jjw?Ia<<+o֔;(L~�4ҟң19;)Ĥ?\yc,W*o7��9^UIGhNw +1)쏎y�yk/kq��_vbϴIĤ?:yc_kr��⨯LaUiv; G}?*?}�MO7.N &qc#Co'u��Jzv; y7#IyL}�8Prr'ۉĤ?N+]-?Y�`7S-Kz2%N &^፺ICo<��vV0IKv*1)ΑYY[-T8E�`ҋuK; rĤ?:DŽ5swqxp[�]>Bqgsj'c<z]ӿ��h+в3|kwӱ?Iatѫcy,M�[ 1oI/FQAL +sV}5Mӿ��h>L%jw Ĥ?:{:1�@˭3__5KM &R<[O�II&{s;bROݽvrqv��n4i+w)Ĥ?cUyV}s{��eItob?IaǐI^ORkw��]zCJA;.6 G${-��`;’ol1)iU{]gtP��3 +vAL +#f& m~:L��Aaw~^{M &\=捱J\ *Ο��t67@^?IaK{fL��P;\S?Ia_+]-T8E'��,koٕE.;5G׈\.|!jvW��Yn+6qmlvךAL +묫K{˚˧��k ˒^[[ݱc:wKۉ8��a5.^赫/yzǚAL +k%g-g~o��QXlDwVv1)쏮w׏%iw��%=&}6$az1)쏮8c|[��qe=qڝ*Ĥ?^Vu ;�u@?cgEwj`1{k0y6 ��a_sjwi(acUj8^wJK��hK\ c]JĤ?L\W]'��}>ܸv1)=c#-Ş:O鷅S{�\UCKCC 7 ytHn�nn6%}%ݝAL +C_oۚ�޲4_^vg*1)}wKۉ8�NmJOI_iwfbUYс~.Ng��MzIIzJ+C8![RGn}am.\9Kk��.FIzJ+C= (>Y4e?7��4 +^+ ub$'u`8Gyc]#+ +O�@:+<5( VF#3iihFM(UkT4Su<5*x> +ƚNjf6a{ǡOA}_30k/%'펌tygp|}m[3` ~^{��H_<v7A7ͣ>w1ߑδtEA~�DŁ ;7?Hfi1;<w6i7.1[��lF~wIHq4DhҤVjܳ3=s{\=�;?3<B ؗ~**ewHWFfzpXghw� rٻ8?i7zkF<:ڊ{_!={Y=}S|k{fn\Xv#V|F-ʙ#os%J��5Zz')gNvF2ug2 BAP6fzֺ]syC{ �`.bvsST[kPwS9Xzpo}>!sddv7�u$1NQ݇?Sӻigy #ۼfV]~?�̳-Ѳۼ:]po┄^+să~NپqK��؜3]B}y71)g^+h*OS��s˒~ii?Ia8C^֖ɢ]�0Y/3]cp+g>#o-hW��'WFHqx01)h޶\[��>*~8<}q.,9A��uxpBmvbRΓa}G�y?G2 +S; &<1SX{,iw�y?G:DP;bRΔ~KA܎{ �QP{bR|V^!\`>�? EvĤ?Qv7J; �*KNވax8bRΖQ}� |O,鋌1݅ &l'vgw �Y~`W cpQ9c B��JI9sb; AL +neoPxs�?̲6/; AL + (h*:]��᣺tZz*^ vWѱ?Iac5X6HY~�}:˲ҽA &aiq֖T՟{��=E'; +AL +,\ӞN��z7>~v7?IaiJ7+3o�'@B})Mx|bRq0k+rl�4+=7; uAL +L7.~5UgRA�@9 +EݵuAL +L-ZޭޒÁ3yC�PwyKZE;bRhB3y%qڝ�׏% M;uAL +lw۾K{"�ȝ{݃ &aSX{ lF�@)?tn;oruAL +|k>eO(~�Խ/]'CA`0_֚"bs3T'�uGwr;AL +#2tHj}e32�Pw}] &9y2޺\fk�<U~1_bRX]=vhs{�7y}/1)k~JT.v|x�<kS&&݂ &yf/}}ޟ�іt' ڝ &yڤ +z Q�@ݖ-w\va?IaDo*~xp.�ލ_0-ZKpĤ?"UBo_Y:CO�NuU|P*ICаĤ?"W }-禍U�ɝ{-w[va?IaDA&^ݭ�~,AK'}W;Ĥ?3)h*N_�w,wz?wvg@:Nkm{O()[?Pg�]>=Lk΀1)7Oo+'ݵ�[MxQН +a@d}} �,rb@SXl3{>)\�e޵e]bR]b?{v]�d/F[{VAL +k smߥo/�D"rC8Sv7@ezοಝ �kPWE5V[cvij&h-21e!`ZѪH QA.MQ1v15Z:餉?vog T~5 +_繤~x�{`@KsSɹ~0�k־ `bRhIVfUfy@} �@Vz7ÛYzX.}?owT8NT8y Ҹ{}$kqXu12�Lz�{a&q+gə=sqaɯM\Kތ7ϴw=&Iw3�摄iY {hw?A~?aV8yA$|{kg�03; vLp}ڭK[hw|޳r\Y= �&^=)=/=+}'cyپܸ'Z{hrlju=qh ~ekj�0WGZ'a]b;qZFm9szOkh!i) w’h<5 ӾME?^M)͌xtD"Zv]sٴlFB;gN&$2"@ku5ʭ.q\�̤GOwJ|ݒFw<A;R6As+4 |߭oj*O}׿t-.ij˧[5n+6Uk�y }nEUn?H{Yvjn]fwiWvFXw[-3zL}MUǜ 3#w`93}@0?@z4>7uv~7n{8箟'Y~>왟}E_o][~d{�9Uv]ɬv#8;A)/DɎh^?]ijsǪֹs߱?0~`8y F>` }y:v#x?]S}nWCڶ%9pVfžxxSshd;�͆S7lNv#?]5<ڼl頽õO}Eyq/O7<g=&\^�;;8Won1)<^іh8)=_I?,9/})>bRxTc%ݮk 7h�`G_YQzRRĤ?RJ3!<�Պ_t~L)^bRh ݒFZ9RuşH,-%ғ] &2pQ8sطDd{�4I~TUprw,zG#?Ia-Mʘ.oްt�[*}8qHnFc@[[X-g곪_K� !=R0Zֻ]~9��HZ߻҇ڝ 3?Ia=Od8NW*�P2ղ`@{5p5,ߠ&�Ƨ0 Qr>=;�hOsw 7^AL +)2i-8/�@{OZ;ނm{ ?Ia}qLTw�%:O9;΅Ĥ?Ʀ͊]M;2K��m#^ v\bR(s ӟ__^�ި>ks҇iw, &4ʪv5^n�G!=&},7펅Ĥ?Бoy-?�Ð*:+}&ݭ0:ZpYo�x_+=!1\SĤ?avaگ80q;�살] & ][iUyg|VO�'=lJ[)=ݥbR+9*w;/W�gx.WHiw(B 4dTkq[p,V}�-~@_Ioiw'BO~_io �hIS]GzjlڬDhb]3Xͣ�pGbsSiw%Bbey! �WC"Vr;AL +v}(kq^nX�ڤjݮ+[EO &;yju?)�ܾ}WFAL +v7:s;/x? F HHHIiw" Ĥ?`Gf/%Ʊ˵"�BˍEGzH Ĥ?`W)%cl~U3ip?~΂܉AL +v4J[wm.`Y=-ʼԮ;h~Ҿ �3̴,2hAL +v̲Xkqe�f^,<%=ӥ~Eu_q�<EIhL1њ :*f<D >yy( wU!XkFMMhIW1"D^g3w=gϗJJ`Qn]/ɷC+� 4OĹbP3g@O?PR*pY}Д�bJ͕qq�A@I?$*y\{ �_ɖ ֳ i?PR*p%C ]Y]m �uhdhK#hm�OR!囪r維E>�U1îU4OX4@@I?<;j՟ -W3ݙ3�hnT:#g@_!T&.TV\^st� 47&,d>�JJlJJfɠeg�s|q4'h^`=�JJ.8+ҽ^s"^~�Bs͉ q^Y�%B�)Xc w!�p4n77|9zV</ +",m =z�p)BXi?"?PR*8y4zjZz�{1j%̓XE4ֳ E!T %C4H]m`_4�l</ 4dֳ E!T 5>1\Ii mfcQSe4X$r֚_r8NP7547꤈u^R4b,EY# I!�p@{g@A@9c(fRH\ƽp|?@~;)tP9΍^�Z#PA� U'k)pgGS{:lt|ܦ27;I?d�4-1=� %]]P.Tz:O 2)r%{�[/cB+9;0?PX˶=Y_7 5KXa Iz:1[rVUݠ\_�øSzEfSS5�U6Ew糝?ߋ[Go `16qOS/{�cgUmf=c�'+9r(,rrnC+),5 `2>q1gžh|CK}LL}z� 4@GG=<'=&fx:7k*J4= Wr*+nܻ~gu:5K}Lz�8jkԈOVPoԞ:x`nk!r)^M}"TYXi?~-42HS +} +�Y@Wם4]/4W\x(_=#˺�_lkKfW@o8W[_3hOC@9[YrEVp_'岒[!`_n4Ib_@?OfdoY�GC@9c[B9揩|~e˦c11{:vLfՕFL= �D}Ii2W_Y �?PZ f*JKtZƽs?�>I F8M[�𳦔YϷwf>+�XA@I?fG{& +猎߯]y8y̪:^YKj Җouz_XUY ╹3f%JS{0,/snXR}7{囪rtfe}yJo1 CJWC =CͽØ]�GpԏZ ;Q#V3ܱͮ߮_5͊ 2' GB׭҈PjN5k fFU}CnSO句^)KſSnmzrڒ_u~߫91|[dlQ}@DH'|еsMUE͜+yΥRŷ{z)i]dW6WmMwc=+]ф=߻M9ٓ0X]=ٓl�` %rTPZ3n~'&ѱC hWkc(+.rDZ91oL~}CpoPR(tЕEy{!ǖ'7 +|9rllŝ+sg45w?ڻ\Wy3G�O4e6/~>� ?PR*G$Uڿ)п?HF};m}De^pDZl_zLmF1+|crehL%7~iaOVO8f1dei]Uk6:{{yrk2_6TRNa=ƪ<zYc�ſφ3 1GWMxY2:~>76qS7qf~:rI_ {PT/D+Vͣ6-mxq"U& v).cXXwe% +#&SF Lg:mH?K A,7gsw9&ixF +>_o$kZo �O`<?+gW +s\Cf GkvK.rg6=mi=ʵTΙmgK|-eZ+[;v_ bvoi?�'`)F�MP}z/*ޠy ZI +z6︍ޖ뒅yq`UeH<sݾ,s=Kx='8[r9ȷ¸goQ^!)s?l.rUԩޢ^8)xO>ynOޫ/Aa>Z ł#X= տ>-�tOTq;GGDIRRI`O&T Έ鳞7;?Qd,̋)AnUήr75[<|#kZ/SFutanb)w$כVI?SEp6^c~Vlœ 9אI])&$bjg\/Io:+?0?dYq}~&G oym^,̋Șk* WKWNܤK8?y=#\K[a̷߳ba|pҡphss^ծFy/~W$M<xWN֜߷!Xtz]%j̣qg`)<fnA!k :)zvsS{;Gra-]\<pu=c+03N+Br!#_ KzQ^9ÎN])F⫲{]NU@?NUZU  1Ũ●*ޠ^z ZI^F�Pw�Ʋ¡-r9e^_9_~E+R{x\;0~ϯfg􌧥F1]۠y+1ʴS88kt09 5 cbKB�o%I+J%! <9ͭAas9e}}s7󞃽WNA#_r49/s%M޹Yq+䛫&ED5޹e`Dd |-]ssc<Ye &|\{띃#kZxVdx#Os䫫 9+\;2݀~@G cboG-Ϝ'ZOP6`\\+㍶a,_Q_l|hM99_]|E @s ^1܇oœL GLܤ+WK<>mn I|hM.rw7(]pmb*go6[',1(1v9ȕ;?߷1jmICtz݀~hkA?0?tCi]w&kyS+|t4jbrxhF\Ak]jj(I +8Mڤ ^wt=f߬ҩS>=\C>y?l.rw7x\kgmwrU<~h]+\X׀JVc)�]|{)3tRҕnhkA?0?D +gr͕AG7U{/GgA9w@/5 cb +2<$˟̷g6]Y z�]lR=G[2A!@ GDIRI.wp{,PpYb mm"X /?XF[k]gb4>AFt%.|Ws 聶&D S@gRJ$s^f=!4xyu:E ?0?ddJcvjں;"H uQm!@!@ #K2-$Gnfwn=CODf |\:DSPo`rV#mvK۴1Tz㛗s׌yu}#ͫ񌁷`mu&Fc@C=C]C}Cb +Ʋ&͕qI\}Gޢ}X_4[)17s%sYS:LKbd&vd$# sdM3Դ(C1CLc5Aq&D۠}cy3<izChCwFutښB?0?֩rv?ˋ|Liw57@{XeS"`X2 +1uL[KcH\)rk-05!_5(Ǡ;ԆV[FMՈ1*UJ +UT"7rsw {v]U'j=jE)|MY=8uyߙg99cc&O s1JOf{ZҘ;k%N؛;wr6zEo-#wVtqu.X72aɓq|d]ŻIڲS_zs^WMn͌8(]κ(n|~³X%OYh32sQUi·q붻/򈊤Gͽgu;*q)i FWI{/StCb楢$ϗTTrp>_[Woj(m?W+"q}muhUk#:9cGr`{c.b,9d=c1TEQ[X;V3;)M?J~S׸SU< ʷ*crrd{QќCU +�P �/ZlW~kevM6l"sd; ^Sҷ5۠9ٯp#kviJf,ݜf_8 c2 ?"fb'[ +b0xse3ݼO<lS*-loںhaH|^MEjI!b}o|nYJHC4d{ PJeYsXEeDc>J Fq?|j]ܭp[)+ dH[tr[ý}|Ύ\nua %Q)�OMM[o]glSԫuPٻ)ڇ+ΊC (O.ڳgy<)^RO*Ӳ$|O4~ѵCIE^:xu4'{^(HcZjo6No\BC2xY溕9ȭb 5%-қ xF^+s~pb(㴳TB-TYGdycjƪ~<kæc6�lz'lMq뉙frj {5˅@{kj<rFF 39\vZ1ٓ:9˭m}?ZI5tmX~/6(H_#PJ?*z|K9r搘?6r'9=g=c#+Fx<c:my&06'{%YYᎸzB_=mUKct8-quße0m>-!jZq{[1B 5{;j#{XcV]\79<puІ*,ϢTCG̬uTTT?h o1*!AezxyGQ0M<Gh-%k W +Q6>2C roQ{vK8U^2fC: 8 bNrK\?uZ1n80χXc:*Gf?MIQjWgENq־G Cs뜺F#EE9gץΥT<L;>[z$R7X+kdd-$s7gV<i? ]09XPU1{Y f_*loڊ^}U9ݜؤe?9Vj 5!9ѸM;y]S M b5 mFv)ϜM>R+ >}'m?Tȸ:];mN7RV<}R6\~={2nNL?Bea >:i+:.Ml%"bykV01e{Y'@Rsm?{$iJ=Ȅ%_:fc˔8z3+ի/~/ ~TTTOm?6gOBӯ]1gCNҕ2Fvr IX-Ot ;335a.;{E2uH1wcÞ_;ZK.l=ZXq^y89<"C6yj%|uùqOHJ3/kRnSM/joڎ 优[nTfJ)Gn=O:Rz6#4g ?7_R{j`Q-?e~a _pd0<?)d/[ +6sgpO9ZI* {_ۨȚX*v2r?7~'8N؛5lcd3Lp?68̯wd V5I<CTX#ߪ9z6r<],=F%WfWݫҝAZmߙ*w,ի##IjOSQQ .RG2ːsC_~IڲY$5 j}RU.tftk϶T+}.MlHj/SQQ=(H_cbregli̝2x +^%}5eD5xU~+ ]^=FKQ590\OFjRQQ=(H_ehBr87?'2Lp31[`0c$j 51Q "* Ds9<"ࢻUI`P?Jn%K2T=U0=~V&٩+ wTC3/_h_Xj'^O %,9̊^C~Vso8l -<~Nn\ë?CK}X>@{B?}Zܡ\}31xΧW;~{OB_ %? CΒo5-w>F/ޚQBlP_B{B_@J @(m'-g'޾kyk1G7?3H +9nr{BE�RBpl:uU ϵ굚?4F8A]ף(wP?R}'}B=!8?@в|5‡Ea~b(ƨ_S~ /ZNX <i׫o<-_' '%?''N %? lG6g9WjYp|ݗBğ-ˡQ%^ %? 6OƑOY5<*<ڿ֥}W>{h%HuN'tiuTCL}G //gA nJu=.jU-O|TQ]R]VBSbyL#bWcYfFdMIwf.LuLsGǩSb:F?Bؓ< +Em==l\FO_}vs`GuzR]Tg7]CK`*̥lvFYtrSpĄ\QZ#j˸uz&c!S"|Xxqg~<=3 AՋF:R=T_{ !4_?˙}˘Hݢt �]g X;A5@ixlkNsJEz{@ϐZek1G8ZYY:ϛ,\UwN<wDEAozY'zl@ {&�G#wNzukՔiN"Xy +�㱡lmZ|vD5MVrrţK?RG%Tj^}+^Auz >Cӊ[}3cc+kXVc؊Ԟr6{5|:=[tT-ǟ\۸%}_"%@HpE-C`cn]Kqʆr5nd|h5'9 +.R_1zk-izXE>+?Oה<ܰދM0d,?O_-=3/rk^F_?+:6w.r޸P5!X=QK'#ԕaWˋnlcΈ-cMPvfc/ssiZTNqB!z ?x͙Ks~{/l:ɱᘧ[cǒ|tu5O/Nҵ贺N5@U'I;RR5+ZeˍYot\[t]ߗϣ)sibl0Ls=�1G~zM.&`[]i3c+ +rS{Zb} B!Hs�Xjk<ת2)4er}G98tdOW7i!BIsk4`*BE)e=LL������ &.8xG'].d?ynNXm /#t:;KDZ:������`AC܃.pqeڜBsS]Ol'l����������������������,Cd29Y)k4y9Ib/ ; HzTϋ|ifVݝ;q2d5LsMLX<K}d,mk wvR$O\xp2)x9UN'ȫ˹豴 I2mN!:N՘י3QOmY9=BabQt+}q̸9uImifF=ߺFLsVY\cCbRYwRfm\fBc~:NِoeF͟4@/x.2Ea h:MmzNCǂMT'&̤i!>>kQlkw{6g1R7sVw"jf[krkkvVU|rkZ&c {tv?wsyY<[D繻 ң0?tIaXZ&+VL+"s<vr( +nv0ZA1z==BrԮW7o|e8%$`۵@@:&:w.jCWЂZCZbVDa`e~AD~ts4};6?yZ]i|qk|8yNuO~kz88Od= +W>~Ch3tʄm_1nC ڐ2Flߔ_ THHKUԸq**cnǿܖ*L+i))Jv~ϋ|'ߑqt0gh8+59Z֥E[֝~sRqDŽ+ϱR'{# ޮΚel9WKqӶAkuF=uD?TdZY5G˱/g[8%)IGmycy)}`ssd=67/h&<7k_sOl*GܶʑqIks>h3ϛ#QBc㉼GҢ-Akީ/d!lu,2*>g{cdgf) y\rO]wdPϢ_40V`!KZomj KE<`WݖJ'cĒa{Y8̘kv"QBc?nڶ#h(xru'K'䶜fLrac`Hk:عHZl.8.ZR>3#xNuh97hZHHKUԸq*q 傭GZ8:+ۥ3ʃgqX~5Cϵ{Sk~rtoOMNVjYm ?t9om@M:<w$&1bʉٟ(3UP߶=p|1pY +q3=]G&|W<|9d}<oJw+{2?JS^5r%"{fm "7[K&}K"^x1?Ws֏މdm}t;c>6_.]X Ms>U׶y|9d<w┡Ԡkcd<(;6l Q,-cǧI wG)zlu܈3h,o\lpKlbyuFٯy. Bl499\"rݑY~2u~qiy⹄w}u炭'^DZϬ咫ei%#K$ޮC݋6CL{8:>:U?<o9d?Hgkk3^ά7myfjLzR5Y]5=K%ǘqY~O7tY I9\ʼwelE}UM{Ը!=55Fd|9[xNuU˟}rsM1uAs8Uv7{q7%)!!fR\zjR+<[ h.�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������9_�ȝ< endstream endobj 279 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 37060/Name/X/SMask 291 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUKK8p24 FAZ'b1(4T +jVE@@/m�*x}|;ih,Rn!HfKV{vJ~ �����������������������������������������������������������������������������������������������������������������������������������������������������������������Jnj4n]tPc;+-+J/�� .O+sޯ>Zhq'*zbXkF��ř߰~Nڽ���q[1#m-'F S��Us[~{hYOزݒ´��"}>To߾%!۫f��كYw+wHahZ��ٗݑMr%=Lg\yefѬ2&dJnjUJ)RU%ZA(ؼ<7~Gt揊E=}/VJ)RaWA(^1'8'M M(ts阱*jۺ:;VYcuiɾm Fwo>ϷWW8udyN~M ?wk?1'vN~W?ws,~8? ~|]ۚolaQYq~psA _Yq~psA _YiE{;s5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&]<mBIڭ��tsUʡi�b5v ��g?I<'5cԴ�?b56o\v?��N &]&?G vK��t#y:̏-n|g\=�/t_WݘvO��K &� l>_e_#�@m � l1?��&� l1?��&� l1ɕ?vKH-��N?Ik&s:� Ҽȕ?nySg Bg��$rkpm[nYq[��"yֽu~>e> �ALe4f\W=�<W-,:Ы��H\y`qq֦_x~}��<>�bb�¶d~5b!��mOݶJ?��& 5r՝'Nl޲erK8s8s8s8E>gϜ5k/o<>9GtT ?7ז)|Iscƚ{cmy\xs9999.sV) ��\|5bb�f_#&� l5bb�f_#&� l5.kw};vo3�@k_Mw^Šj[eWim(P1(4 I TA(sr/9!q!f1Ni-BŦ6sBn}c?HXG"x ZW ��k͇⫭z&���_5ĺ.Κƭ9I35�� yk�� ˲6;\;rT{�� DstؕfB5�� )^xhdȐ^?���{ (驩ƝÞ~by&M8;L#\I>R2 ��usF ּh舻{-]0aط˸��� LfܨQڊ%?xp69O{h3\?^C?��� +x]ċGSs_G#bxw��`pN?/ƾޏxƎ/��@?W[ +5k}���|cP*[J���>gY**G4nv}���;փbPE?Nzu��}bF@8pxw1O��@ؤ;m/UD#UciCe���M۹!mg9GT.ӸV˾ ���WlSxPE?jN==7��@»,Tߡ;*GQez˾ ���ezoUPIH+!~jDg��Xcb%PI;s>\]���V+˾[qtk]^I]���VW]6bkF@%c x��W?Ww>?QhTjܐ}��17 + jkN?d٧��XR)g<oC_l!6���+-#[wF@5=㱌T~歮,6���+ +-=vC2pz^o��mn3*?v׺Lgo��i9z {͜:My���"abPQop]}e��`%E۶ƞ74*?H:Muƾ]}���V_b%lM?C<v)h.ʾ��J-΋G wݕCqS}���V"Wb)U3d��` sfFvٺITW۽&zIf7��X;&5`F@U}G-`zꪳe��`-uչV5Ohp_}#��|W7dT__-7��X]PYHD޼gf>��@iM2o"jɲ��Pٯ5;HؚL'f}m;��Tf-|gOE[SU,N���u&{o{J<WOC;��T&.'T7P^kxo%>��@Iߙ{"w, rWD77g[��Tt(/7Qgr?fHؚlX][��TzTjo[j:}e +�� ?]Lsٷ��(ng%`0<gye �� "[ղ`013gYgJd ��oF@5tzs)OsJW~3q��QbO]%0*lnk8x4[[>8*|��"S٨_ TJ쫃 X`#K/}!dk:(~��xr8?wQ4~cwv~U ?VزFPj'?>ye +���q!u}nS";L,V1Hz)s>r{iZiPl;qF .���ib/uyb?%Կί/մ_sP`C<mm~Nsouh�� Ֆ/ +k_(힏`bɚhܓfW{-5Z:s~?u`N4_͈/>�� $=wwԅJ#tep](3;Տo66h/ux?=}F:y(iqzqRNY_AQw  +!*ƋxIڴF(P%(TAbCA",.!R|@M*1(L[j0u; ^]|yZZ��� 0++FDDPSU[Q0}4}3^7>Gz?\-vguU/e\���H1\.R/u [|̴>9jV΍Q<,r���,"꣖sgc:_0М qT7@t&43X{æ4y0]^"���.j߸k7ѹW?CZ(jR?`r2ڶmOkz?"҂{k*LmMu���ibsE GuTx^0SƍgeR%y걐^uCN&_f<5:T����aJ=fm/QGQOfF~`$GpD$8=r_7^1bHZrljc��� X[E[\n.T(? ,-,XaVFJin_=)E9%;/t8Σ)JƮ~'tp����ji\YΟ$:Z_]:  )$)͚:MtϤ ۮU+A<Nv+uOsոٰJ˗ ���`{wǛPGUӰ? |$7?Q=}>N,PxB.jQ|=>xJTrs$-^5���͘4Q<\~ S0 |Wlvr]ʺU?+Inݫݟ1v⠴>Dw7���@LMYIvz&uOοóJ՛�C$MNܩ^UuTOfPU3vF&n:M����ciuw{T5YoP7dͅƤ?c&_T?ol$DFra}����cjb¸\A]{lU-DT~&?LXJe)U팝/:VI5{=}_6���Fx,\l-;H)Ҵ+zZ`l?x%cGz fgCD?/��� +ғB瓨Lkka18Gqr-nAGX{2a[F���Xw=EG?�4?LܱEW?X Gvlf����kia'+;CO$5(.}n,06tVzZ8WY\c ?-v[����jfTrA:ӉD~Y6N&Sի35rϘ���>>oHW7 ; +lD_a1㿀~ϼ_368\*en<}���x$l{9]:/"hn+06t\gҴSA'[׮G���0T+/PSMKZK`Mm:AxN&a[U$wJ#S\ss}&���SVGtm 5*0&÷eBQ}eMq{Zv 5+Jn&~o ���&+z 1ERa�tO[ΧaަLrIӮ쏎3Otz?*yerRUw1;֮3{g}B���x$ZqM7m:Icy} ORjv0Guĭ=+vOs +|/|۶-^c9>1;a"3܆ 17m��hD?Qtnꝯ?FOa1qb"QUG ؓS4nPEI/'Tg_Iҵuw8iΕN`f3����B&)wI +SQP`�L_RLW%W1VXck`-#yJ?m.xE.Gщ 21��� Oq|iׂνq>)[;m]쏡簓2ѵ{5i͌"iaN."���9sTŖW?D.Jjtr▔$wݝ WQlSVl϶Eq\4[��5'?vt#1N.;'v6; +Ǵ+=^ﭡآ" Ƶp1϶Hs¾gM?���ԉv^8׹:j��]֣]Um +ʩ`=x*"""" 9rpCݪ]oWAq8Z)*͛ζ738ߛS 9�]cPrċx-RAԦ9_'u*ecCC{gޏ���L -n˟e6xXa&!?kP`IL?>!b@=xߙoYS{]W U'Z<ۓllx?J���x ]Ivq[_^`5 a�t)(d ++Vgz-';ǣ=Ө>u8ޏ���^+DvA@. 5`�t)K`f"oW@.~sJ'Ý?xrrp��%ry c|7|M-G7E�KbNłC4޻UGEt6ClF:\Y4lM^>}@y?v���9O5u5qϰ^|L?X)N f?=HVz?'Ztj%I*Ç6z +o_!=x���0JK_#N젯XcL|ʖݲw)#$:xz|jKGEWKK$D̮T>>-n`G_7w9h0llx��ne؀t@+埱 ?X *y7$^w#Cf1t݊*!6U +2S3vM4cG%���I֘QEgs}~Yoa%1?k){X^3a#{FITHM65eDzOWh:ϛDqHjt\xqdcmH��E"%3 ;gjkBHp*wöv%}/չ {D]S + rd֊��x[Զ\7_=*U/`�^%Gjen>GETa_{mX!HoJz1@ߚ6}q��0{VJOׇ3kY_aSw&$<K %ׇ1ؽ56{'ć]ֹgOG��,Ls3t${IXe"hV.-9R?X=*\7iU<@2Ϲdok��̴͏t ())Fqh5Syw|meV]5}W}$��?|\I|-Mޕ?,IcW%^yw˩DN|vyBa(Υl5yԇ&��I?R\fIؿ+yג +ɼXssubnp}FITAsuy)%%7:��v!Jt_9'nŹk�xy?C]IY(kwqJ%IL͗�`owչ~EOXOa}` -U_ȯ&v5��X4;;Ҩhf5Y/a$4kh= ,쏾өT>z'΍`��@~2rAtbIdž}?)�-�h m[Ls#G��+}9euA^w|>F-oUH`IiL]dx/ϪLݯ"OOZ\ʞVh*L۲}ժ^4��`<G[{G7a1\}*? +NxZ#l#Us/G.$ u?޼=��/MX#ɅXsf k=yxo"j-z{JÞo,K)dokk���Ԥ =Nם!=}w7�Kcn!ĕTE3Wʒ3'L5S/LfgORRg ~ka��Ѝ$},Xb=Kxw#4?X$贈f=ʂWuxZve::;Fx/X}/_��P]&J_(;f-n&5w'�KdOt*7mMݑ%ׇl ѓӳܫڕ%˩̬ȍyLL6ּ2��`!GE.o^aC{pD`qDj�B[:v(SJzI;͝llx}�� (NV6szѲdo],|I#(vԇ-݃{U&j-ߤIP3dsz̚mG���*r +Q ]}» aeygwquzDSMuǨPj'xo*g +*(f׽ (rIxQmLtQu82~fμ3y^˧Y)͂"•DONq{Xj"]e+̓tq{���1Rk6~[o4wel@@,8IQS7hNL9's +&?|/fAW+?qGw;wi�� y}J7ؾ'MSqA2Bflt q__{{,yJ݅luގ#9hɟUo+5ouK]]\Zq��+"!7sĂנGԇ}N&|!ogcnOqv[D\1՟6fK$gu��]1s{wy3j<|~|oA�b!6,IkUVv|u=ݺ5{d|qܑb>7K1 w{7 ;ϙ0d1����ա_gھ JJg LU^#Y={,Ң}}EEğӁD?UodPH=$HZ|V��{իk.\B<Cx;y >Ʀ=zY_P=1wM۲=y+ҶbZCz);lP}i">O S.��V#~ց9WTsm߂Ge{ |&!>GeY{b,ԇ}MYښ%i{IITLܔ+ͱvAsG;/Oٹg��@Izzv{ϼ$jgv 6J}эMzu KgX"m?+G=*}E B zt ��୲m.Eb}rR3xFZ ofFؓiэѱ=y[J 7[v"R:.ﰼ]5l^I;W4ݣg��I*%NYP0~g>bqWS'cذ&AwY.9X{֭{ĝx{Ko}Q4}�o'E3DS%  *=gk��`Ŝkmwٹ/x;υy7 f=>|yPgNR)嫔y٩Io'r,W*=CD5jT{zQ2烯MOY6A_gLKڿwÆwFy%D: ���)Pe^~/V~u4W6@d#fIUDŽx_(e=fo#17> dA'?N1Kkz![q}&ډ9lފ����cָVϹje|nܖμ'X(Щ*U'Rb&w?:Kͥ x&)*B/"AWP]O:b���ƘI{ce\%8b,+S#|i+D_?c٢17.d߯IػgrJy��hSxaqoo?){i?#"mD:#ho?*ߛ+IAQbSCj/G4ӗj���vjMQ!}~T~Fb>i?#"ftƥ]A~M2|J"|[fҤ?Qq`kǎW�� +Ͼ~SKxZF!\7ˠ�GEuAfN!A~Je./xTĚ5]���'#fߤg(lwlCGvਈD +ɛ͂ogDJ~KK-6&x'^O g��7=l[?C}|a?##'P~bAZ#D#7_u..}7ZH<!$ P緽x��NBĎ!9WTsmw?O7vȈQdf+oBᑳ+1 wbhhf\Iߴ'(�#5όx_f1_HUdv舽>ٕx zWp1pJYv56E;3|Ix/��hdmwC 9ۋ~7u.{z,ir5WNb/Q] zQE6frrQ3}L{��[Y.'A}egӽ<A`]?#"y�?)wC{K/QfƝab2hn*/Ӭ5�� �=xeuwY?�hqt*Ks$6!='}/Ө(3 ? �JT x"uɢU1!Qq-"FD@cT!AfAtEdTkܣGO4st&j yeι|7n#]ޮ|EI>^T4Ύw$�HDZeΙy٧pޝ�̸ZAZ̿AW,>ρ6}F>w<�@YmcÜ +!b (+nﮂcLe K%Ʒ5Gxw:D,6 F E٩с';��ʤڐuvzO +'*�<Ts"H¿Aؗ&`UaI 2TQ>rDg\��~w 32X/tQ?�x)폱aOAQwT"kCάSqN%ױ}s%[w�̜G5ίΆ2AeLi0wiDoԔzE}?"NݽEfMJbhD8w�̌S1_ڇHQ4VY˻`�`Q>ںj=xw5Mb 7ʉuaE#˒REmc]|,E"�0qT)3 ߓ xw� 1n&V'~(&7Uu V-{hq�0134&;Z<G9^hܟwl'N11{Ds"N9* :ώwc{diٟGnuiҒw�8XK%fPG$9}w'�`~V]g=w|n&9Xt;[2G'~L:zM'�5t/wTO *LE?�x6?⃭/|Ϟw>1] 6}{b*E{e*ii⮝B6VV�ksM~ybÌr=ςyw�q (:s\zw߂>_7ѥOmjWK<ҩMIaQm4wL�^1 &{9Ì3:/bz�]gc<qZGxw,a,'r X!o7UԦyC��$lpd_Q-5̏e �<S6"EAn5;xiAUz[OHDڿP�/;;}oe3{>;�ǔsmj.ޥ ?B_q]+4WZv.=6CyG*�%?lˈJza>;2A=w�ŘF:ɽR_Ȼ;A><}W6ߩ<Nx(4)~Vc;W� r=Ժ3΄B8{�Ř`eM +֪ Br,%F9Q.lshdV1z֔$�߂* r_Xi ޝǰT"(nܫޓ»#A_ro+vUjv}AYq:Ki|j7whc;z�d5i7~w＃�0?nZAu7rJ=CK?q*&Q6Xi9t=�BUo yw �z-LP6w6GCB~Q9[Ih_[a(N#xG2�XYN-Y=Mw d}� sݪ#kEڇW9mQ}BdYxJ~L/$d7g�0\P41z{.?cNcr׶:O޽Bj)[Lt5auծ]x:/2T{ jLߟtjٹ5~]]{�`;S'(si'"<읳),#=N,E" )Yk].(%qvw}n@01kDk!|zՆuO\"j\U~c�/*љ5sfg='-?�? +2S+4W6¾c;QUQ{鼑M,;uB8 HNl)Yg3Sxw +�z9? Z~nW`U+o):`>MKKҪrjfonA&1N@1!A)ꪼRB-˛:~'Lmۚz8*W"0wYʒoJZl%;�[Oΰ[ DYuԇn*~E}a +7fRNcƫ1 ^FQx4 RJd]baQV[Wp jf:v_4qW3Gɰym{טғS6ov5̓k� SNYh _Nqgw'.ęw�G$JQe) +kYDT{mjί,SY޷򂄝çz%�@l\DJʚc8.]ㄭm.; +#WLʗ|Desҫ&˔3gT;�D,}5΅0W;HʯȖK K/хDO [ٰeJ�./PboO+nɌs,yw�^?~z#k^�#-;v{ɤJI6ho�t"igYBl#è^,<ʻ;`�zt3h2)ꒋY2jݨɲvޅi7;(Cu9e3fT;:�h{NR^V䨋{N?�x=`.=я}JO !?7m>QUSGw㲛^Wg8y5_ ;F�xcUa!^1ҁ_D �>3h2r4*sBؚyD^O,m{r5rDorHx +�'s66so1)gyͻ3`�`^=}R<DEXgzVz ++2hj+6/]&;b�h3&eɥ~P1;˓v ?�x3`Sd5=^ɻS@̇8Foǖ= ~N<cXż#h.Ra/眬brwW�yfO'ϪمzmIw"j~}][}'Wl(,n'qB:f,&OdY3גzzu2!vze�j^Ln{uʚϼ;o?ɖ:Vl6$h"zMMNuɭwI SIo\nJ M)%#z7}?*"MK9o˖j=6{͔tS@L=ߦbw!:4Ka<ɑ9ԋ{g0sQ]`Qu~nw^^uC~0fog\?$b1W>؞ӯ4O?ƻAЙP_Ska*eeVO, Y‰?Aiy2N v=|DGFfl\D\&ylU˼�d6I^-}S~>QR�B;DeMe_w9#r2:r$vd.DB:eYSe"s~n.yHޝ@(bBdpO~߃ao(zm]�By#'9,ˊ"p<qk܁a+W9t/ ?{-`9w'#pHdKLKf,~Nj Je6d4\B!@H?%<ؠcّvF 1n<I7kM5sm]v9̻ IL>{ ms#<R~Z=[Y/lV]IwCT/$9BMr愅YVhȵWHٺa孵?[wMrwqӗڢTܳVUVeq$QRIo< NY!BUCTJ8oeQ,S:{^N;%茰RW]{V,U$I1cyw�eXO�Bs/:0ԕ ئg~+ ͷ7͠LMl!EJz*$Ġ2 Cx3M `3ҸkV&i@hpp,Yʡo=9 Uz[?g:v6AL{YQ&_'ܫdW_?eyvp"@',eD}->Ѻf9octsB;2L,˞"1؞NC<:05 ,Tf?,gY޲B&z._k[z)M3teBƕDϪBJ ;,Yv)cH,u`ƭwk|p0۳CSygP�] 쏗;`,:g~<F;!+Z@TLMWL4\fTW]K7}9$K$Y/?ѳey;*J`PEsuD.GݪZW]Edz"X(H*r#$! 2D E+ZEj=?W xK~>gT{3yާ|�2Q/݂ik[DQ]چwu"-mnQ~;ɦ.BR:w׷gbyN#jmQ �&YAKꐎNm֩5rSbe>h7z.Rٷ!i UrfwWֳ=@NFZwj>�xɜ~cE zS +ʘLJ:UImP9ڪ<݄X9wǷw|HYi +" +yw0�NDTGtOw/k[DQ]̴m/4c3cNJ7g#uWYR?Zf:'½{�O9ˉ~U5Skwu<.}EƼ+K;{j܄*Y4}_X= "`ΐ<_ϻk�d ŝm\evF%;/[ШWD<}ȁ2U$Un?!~ݗOX��xYD:O[GvUU)iLBF߷ D"u, |]vK`d޼;P` B +G˙d2}yU��hԅD#E e˧U(S$\چw5 "){\#5sJiLofN7ras&��^ĉt#I6bJ^˾Q[vHffGw1g~MA3-=yw!@쏗q8JLѕKx'�� Q3<PuwqggON`g\p&1+EzwDHxy~Vnݙ��rWե|`PṴHTx|G<o%&vn;S,1F+Hui~ ;{?wDHxyfkRlj�0̏N^JתYjR+š3]Ąg|,JK:z'74jftbw;w n�'řv~7H{L+xʺ.F}m{jb'םI|[nC)lXJR$N��5wYt;b*֯ǔ ű!;ogϻ$7c{['M\"֓љI2֛a B +ǫс̿?��hDeAts^'5DTwҽbg?fH*JY/\Ӂ֗;Pa B +GL8U\Lÿ��U}+ ֩dXjT@+ǏSWGv6Ӟ6Mz1"# 6d:&\mA��_\nf|g:,B&;PpM̟w-W'fÀBCRӟu${.yw!@V]Jǿ��;΋bYÉ5UG?#)$q'w[b<_q;IŁQODцR?Zϸ@w#vKݧ1��0|D"S9תYhT󪃑냼gK~Wnr:?R^ߠw>~цR?ZWHz6Z^#w[�� ,D[nfzXRuxY\D:ի;Mxul;Xp`?+Aև!i[yw` B +Gu@Éu{ +��-~Q*1};>@\}Q&D/ۻ܉Ȯ+bC&hU*-b}8<`1nDHh}AC>Vƿ��"q"_It1ZtاeU*UQm:4wC/Ve42r s@}m{UNd$q_}QB)o{J}��EL9 /+ܨ"u?hs[ٟt|/!.;Y(?!m_¾{W��g8)\ry\xggtC=Nl<*XM+>7],$6lIy*A{��uJh{B)mgCRJq| >���hku>ayw` B +G9egE�[u}qW@($q&:-  :"HV@`!^(K{NK[@nJQa`;Z\"h+a*h=y׃6�hj'*Cݓi76Φc4��JMN(݄ԟhFΦc4>Sud7 ��M& tO6bp6ާv#��hlѷtnk+gӱ?^^&,߷/Pp&o~'��h,5[fiGz\[?8<b%F|jLoV��X+}<1Z6cp6,] xk G�U4Tڎtc>U��ܯ+B]{nk;gӱ?ׂŒqn��pvO4F_Fv[#f燖j�{%x Fgӱ?_CY��nU1&O_OtqJ?SG!��ܭ{]P>05Vt ?%u;�@C}s+!gqwFgӱ?t$1ROǴ[�@CUl[AJ:Hl:Y使X=�\֫tkĚiM:.?��nG:/Pp&|sKt]'Em�vV~Yz%ng$bp6C_Ze~oM(��p3S0M+]Hl:1AS�ͮT'ONIMfćUN ��7HO)VF2^g{mz^]ּ:?\5��P[zI:Hz<Sjy?a8G↿\EMf(��P5J4)wϴ\_qnҬ%_ٲ1I}L^%y'6 � rI睐.I\8߄qQ{<;>ְ?gi1<v{��_JMkF?VN_A܉~ _?iuwo~��G#J+ٰR뭚=vw-Z|5Ù;Ksj7�y.;'=n"cpql 7>.Yk{Jq޺�Dg{`k/&8�;[m{\-�D NS_cpM}ڶ3E5DLV&ŗ+^`ut6; +3Mu#ܽ#do11߷HFnl>s?#�ytg|n dd9% +Lɍo9@n]mmz%�3;s ҡy+߱ao~h[[Gx{u\&�V \>|sl^װ?߲yA\�O8c?Onn9Bcw+}^̎3{ڋ,ti7 +�`/-Z'y:Mp~_w;�_#}I޲vp{Φc8C)ϱeه[�mvp{Φc8،ɳ_�(N2v]JgMp։LV}~-q�8tDzYh7wl:[A/L.�s];<yo+mcp6yRS* �8C:Z5Yihgӱ?[`=ف>�G!y"aMp)V<1�sH7on\Ceh8gӱ?)&+sW3�@^H76햡Mp˓]4�@Ȥҍe ap6R2~_]T�׾^fNnߙ{]A�]k+<nh wt{#{a7yzPo�sun &*\Tu9�@4FY^h7 t;h\T﫿ڭ�KճRB}vpM\kl#)�h1҅5F?8aSbϱm=�@uYQAQ?ΦcekVyn�@Aݥ#l&?gӱ?:I/ +[�h~"ԁPҥ mcp6>Hi}.n �}~pIt9#ԛl: ='ڪw�|N?lo[Eh<Φc7Oy{?=( s1I)Mc^&6mj/hsu74*V/ew\ bAҩ:MɴәG:DSDwy|{|}��'}/u2-B?IakN^9<:I&�Bʡ1_}\bRf[bZg{�#=/}W8K Ĥ?̖9e{|o6�i{>׾=>1)M,z�+=?0{7 &aVQk~L; �uwy{훃` DmKso%� x.5fH +A?IaD嫒uKӪ%�^}ٮo BAL +#r~}~kYSp �s}ewߵo BAL +#$.M-H׾�;w!sj~<dbmA?IaDy5#آ �ZY޵7AL +#?%Ѫq7*=U:L�Nz[[z\\}?IaDssztڷ�vW&,=0wJ-Aa\ *177տ�ۓ \?F}?IaD2XU*>VW�&=-}--}CоĤ?"ې]rxtm�ڕCcH_ɛ5ہ &m+�I?KO +k `Sm>jj,Iѿ�I/}c̀1)&=o-�sW>%bo?IaܭEu�XUE ot?Iaຄ;Ԯo.�Nf.1)h?w �=%}Ӿ &ťVU;_�DҿÁ>^%}AL +_.s?m �Hw9CoAL +WCދ} \ܝ +=} bRhM\Z/+8|/]@$]Y]/=}  /2TO|P]R$?p+ >ڂJR2�Lz}]_�ga&-uDYzWFErt^֜o;ӭaˤuֽ~\=:nm�]=2!E6u̮a'[u*ϱ?p;&Ȯ=(F>_gVnp&qbr_ս{6>6ڟ;uئnSjwÁ[>($ҫ>WvÙĉ.)Z]` ׻wewihĥi1~|1+GVI>;bgLz881{*'eoUzddtKMi$!odxVϱ?V3y�L\dj+/Ql&׳^Y't[=>INwر@[u*uUҿ�ΤGO kj'Qx8:l6h~מSi??@CuIV_Ey/[{l?ׯվ�>ڷrnsNzU|<^k">63]ղ3nk[&_VQUrou}Cg|;sqwrpt?qq=;#߿L?R|Y}O12J~sǨ ZY]y>ޗ ϰ:{>oҧڝ il숖%ӧ4@|([tTTϱ?p'9c>PS~I=p }X[v#|?SSͩ{m ʨhwyߵ>>,U3ʻs脡7�Նå7gޣ/XYs{Uz֔zaЗ>XXalcb:�8X\XX~vw#?Ian<dyj >WSH�N$XIRzS~Ĥ?p/-վ�DLzRRĤ? D]Nw�ʧ:K?fj/1)C>ֺ-.= [-eғ] &`ybV>ufӱҡw�4I*9=ЋzG#?Ia +Z.5]}@ӥƹ҇VLbReyINg]?�hO3]3]yڝ 3?Ia z[kj6o<��~eI\(}0B!!s>qpC�@{(nYKNHIjw1 &Py>7=.n\lT;�O_&70wJv,bRe+^��$='}7cˊ> ?Iu}qP1*G@~l*Maf`"%(. e Z,bEkLjd+~^EBQEڲɦ&l&&@Z,}+y$@4 p�Kiv=oHiw/ 66p?2SN�$+\}XzNNsa') )% cڷ�}Bxiw- 6[#>箑�Ϸ=RzI_;vc@4-ӹg��CzL,ko ?Ma` .2]#l�.׮v~bSh_sޠ}C�{~9ov"5?Ma@Cd|w_>A�!%U)MK:Ħ?aX$SZP'�7>!fvUKiw)R\h6[бw�Kla\8pls4$ݡH-bSts3ppkP [�H?}VAl +}tV�t* KOM)YݙHMbSHظz|ͻO�ӝ;ӼnJ.)$ʜx5fh� ޚ!TTH6)$ b5cg�Mzu:<O 6D2i&\<n#$#=6.RFAl ++spC]ꙡ�H-;?CGڝ)$+R/?BZ|"!. 6Dd˚;OSup2uկݡ݁Ħ?23MiŘtrݎ07uUMR@tbSHdWL6h`g:c}NM F+MV>lbSHt<mG~.�Jkfw)$҂1x,ꙡ�IW_{F뀞?Ma Yn('ɶe/h,�prU+9~8\Ħ?L +}fzjO@r޹SO~uv߄Al +dX$S\Fṋ9ŎGi/�#=R\S#m7a@$/ӔE6Ŀۮu�ɥ{CZu6$}i@o?Ma ]]͆-nt\9X>Z=HolhJhw[bSHV ?↎\�HlOU0|?Ma ݼli R?G3FzBBzC 6d*wv7ކl;@b^~ .l0lqFu:?m)�H lh~*B?MasXq|WT}�H _^]|vGAl +6Y)(3�,oDn.l2,oY{(֜8˺^dlxm6[zA 6dgHʘt%xP;w/￤X@ {&mN6t4ۼyI 6;ͺ_uސ}]"?H"FxG}ܹC zx5oD'w誂fCVn;H.п{_vkwЗ$~ۛkO/87/Q<5Oc7[7IlRcPT{ OYvt6ǿ߱?` Romv#$�}듊ǜNy޵;yGeիn0vs5fbӾ$~@*fsԿ=?\:\^7vivvy]IT97ſ"ߟ-zsT10A~r;b;O2IOKӳ4wPE0NTz, yWd\4k +O�._y]kw sm?MpƏo/ 2WʥB=]o/=p+(�"cZWޱgNw +3g3%C~wB[vnzg~aS5rTcccȦͮ\>Jg7`leޑ*6'XK 7ihNW_z/`cvǜހtLMCp:g]>cWy~;Hr?H%x>l3S6~@*鹙&\<.ѿ�tOާS>wV; !;kk /ɟ_Hu<m"[P{,�gw)3 ~(U3� =HVy֕sۼnrQOx-8@*[(A¥ W @IH\ސe.ũ-iymٟṋ-?h|ARI^~s>'}֖߯(CGkq'W\k1?7Ԋ/%Ѽﲇ٦ +!,>Gluæ)w?8ho, aAۓC&;,#XO 5kfz֒kq6T&,6%t~+5<~gQ9GLrɀdm(~yI(y]m0kÞz5"U]P'F?"dsQob@;?TU>ޔ( sJ̊Zbl׷{WoeUAF{->$-nj1k<mJmulsB~|"e{~ӧvq޷MfE(@N~UĆT?#}Nz*(x6Nؾ;@o A+4ޠC#ـ ŧrUdS2V=-Wݸ<bAF�-ɝoo["JcWuAY"].fV4Xsom/gERB?o1'5zEu^p跩JmCaͭB_g(s U߹,%> A7a83AX|*Wlu&"g<tlv,emOVd6s 1mۨ2[($*:ւEо*e\�@W:$.'tLd6R }ݵ]tj~ A >YI.`S"'/.E|[bnY ~athm7=_mگi =`s%JK`%gi&Xߞ4hq/Ϗ&GEus`L\K?әl}{6-/Cx[#G @wHWT/HX<dX1#Mη4'j|RUC.jͅ9Fv>z[9 HD{v?`߰֓>!1+: +d:g% +hɻV oà|Z#}q70`!%zm:cաczC`%q5JUگZ"k>w%EgO?gn;#a|9x w97ʚ;kk@Oߜ3kHkAX|*w3ҜqI޾VV_1bC/Q4^9gzBmG"&גk>#J$�~Z?Fm逎@Oii�i#;OcPfosa#.6Tɝ`֞6J׶0`s9֖1ٽIaGbD\? ?YswoJ3|pZݭ3&En A<ψs~BZ`S,TIC*'Ɗi}̚ОY8ke.V'+6 ubNjȤ_u((:ƹ"lL {hfUBӁȚ SFUk2y p*Ej;IEZ `S**{o,,kk\dS2V=#X-WݸŶmǾy a혦/ۖ"#}+q΀mʢXj aҜ(nZb7wYe1XI;mH]֯ É xfh/0_^>COoU/P舴SŧrUPo&x~w[ђ|5A֐X{;owu-ѱoJΪtnjU>4~0\YH3>߶e|ddR}۾>ƉTu@;@5۱oEkq,X m yMLl㥌c}^L |*ϑMUog%YQCYzCI:qw@' 致ēŧrU�Av 񟅝Gsdz8`m-_NIF!F{ɬ +.KBx?Ntouz3=j[놜XZ qDԤς�dQt;J9ŝCoN4;[zR@HIӁ +(hhvfA ŃY:tCZi`S2 M DX%' =qX\͑w@/5 ,>ZIg"AHs&@漅5 ,>:&°Q{&ЛCR:0 'x&x:?T?djyEjgUaFw?# } Ib{mhiM"ŧ SоսCṇt@Z0`0 `=?<*ϨQ1u뱦=I&ƈֈP(."∀0 xo7ѓ&ĥƭ/O7}_Њo:{o^~v +ֻvR>RQ o~߭KGEmA75TTëqv]+xNz޺^n5ؗsTT(ySTU>}l]BSTϪY?;%dXO5፬9ܚxzވ�z3#*~o\FE孢A75O}%ˈtб\]||:[k9UY3lqocVRZBOTY[Sb\.b拎H#ճs'\hלq1**oڼy"D/cx\7~3?O 1ˇu".C4~Uy|w߾WIEo_m۬N A75O䏍ɓ{X_iO;2e{{榄0jو +s򙒊j00+|[44J%*"ySDgu[.r5nGxoaZ +rt7t.s}L<-7VX,Α;9m열&Ǜ3*GCq'kIņqQK)bdw>(%ƑǙ{ӠY䄏¿1_X.֨b_6##O>_W0^:?6{d'9WboPnj{8 gk\:'zd*])׋1gIǴ�V{/R˽K^ٌ/伤xH0) +¿J!*$ySD@^-r>0AcY@K]9:,h濅BfqMlyYFI(5{[u$r^>o.iUٴiys?q֚y,鲰Nmq` A|ӑ9oE6]7R+ê1Φi74r5Ζj>[W0gfS갓 c7¸`qGfYap17Tw ·@.SLk07:2.{vBN{� Ei)!$__|֤?LD|`h HڼyD1Ȭi"X[ԁ,=%x]IxnyuoX7wW8jԸUR志[tbW;;rAJk<O᨟Mmu!E�OHXغ*{C!>اѤ5-{dw}źYsULjŻ~7|{j(]`;5Ki)%x:6wbΝN**B |Z%KEEbE6oj3gGJ볓9ȭrjzB`>jф "6 yZ쏏c6r1OkIҕݬvpi+O<"H\X=ZG}?5?+ +v~.c=9L?~cX?.s|Mܥr{ zN|\RJ+2eJkq|w߾WI5ru[4>KHڼy*$IzDm,]/珐kx#Z0OJ훀|X3/0A|g9ژA8-yLľK.:iuXw$YVͶU e072y{dZab p7{U:bwGaMNbQYde'h𮫜f_fWX6*EFZ61 |U9 9TTT?hi 煉 QcGLPȽXYVXw4~|!= h?7zl}N.Z1(Kz gq`σ1冼>sk{>f6WN8a,l0(7QE󇳩AZؿFM 9ZDeϖ-w5zGiypT +)?_S:Ry>w|]z(yS4l\imvRP6N1׻i)dXա`8d`9@iV'8rY gwnZmqϋ?s8ubXCI+ojkuXλ6]4-6ihҩ{ϨT' +)}**E6oj\}"2.dAQ퓒_df)?nNܳѸi F5ї>#agܭ+"ryn4R,̿;9Q-\ '@Js,M`GLcѻJ{5.j)Op| 7(YOoJ{IQ͛'Ǧʔ)ȣ &rA^l* `5V79Z ;ys+6ripe7=։˞}XƑI!K=&WK?\q/w^de7Y>獜X+ê7yxZM՚t`b0jhj.UDP" H+gY#CP"H&3IFipq 췜} }{}^ <@.h7 +~o{~%-E멿x8�4dc|vJ#\Q$3>杲{e};Ji˄/!BPK)9xJ@~;4{*[zri^jY4v.}<x3=yg)+jTڏP.ER_ytge]?([ߓr!CNRg>]Oy鄶P2dn" +\{꺸코y@aaVre}o[k-gY0p~>~�_,1!GӜ;,ˋs<05܋ޭ7C1T+w 彖e\ר<3?9X.}TIb+Ͷx2�w @r5rN*S xڈP,=-xcB-NAዚ } ,Ƥbw�$'Yj0#囨[᧡^�Ҥ G\7|;/&ԇy/?&:U�I֜?޳Fh]�"c ,82FhKb݋ 300?xw�HNy2]Ewu9z_31b +I}3D8wO�^HNB�@ ` +-:+ >9~n+|*1Fφ<NA�?�7 dIzIl9HF33xqG|5dOw�^>u0!d +F=O}|(^Uq;p1�@I�Xo.cӼ s_OL ~+጑_wlj?y�A$�a+Xx|YIݬ:jӹQx/Ϲ%'|#x�| @r�HElsV<%~Qf.2F> C>_{�`~? 9 �@8lwc cEi2+%^踮;^}�{;CѥRɇ()ӟ|!x��0`O" ~8Q5?b#]P]] PTw?��d.6%_VYn4]3M?w3dg*V҉+)9 �)% %9zIl3~LzKf|>QTW/ՙMu=�@̥3gQ6h?TPMI!w4YkbY8g ��ze,d[Vy:J~tmϕ=�ՉEuQTW/o� d.9۳!NNXz-:QYGt{-]13? ߊXɶeGOK)\/mQ6ݿyNxŇg}KК;R-nQ$5,?75ˢ}A_|Fx4h3�-Gv-,V78gSEJsxсlmڞQ1RVhIFv!^_0'{:1գBnDkBNT30/:?Nwc&+cY~N"X=?=v}}?hJ*һMJ +o<F#mTsˀA}$ii_7@gc�t?:9t;Vp4qNT֛/3cI;lwcsf[v()_j:gs$h +Ƌ.L?O1i({XﳀM}tf,; |gyeog+^6tl[v,'>n"SkB{&,þŹHYBPIvT@OWv>_7밆nj/|A|ZE9;uкii?/ 1O?тhƍv}O󘛳KcGDeu5%9O&8%^D_[j^QQ6_;cgk{ O}y/4'˻fg�Ls5A):mZi v}Octfde/I5 [ �����@sK=L/- w֖U36uC< n.OS����� 4hn sARnщ:G{ږY<\˄   h�+';v K<i1Ѯ?<SXU,?7=p:1?NK   h2mΝ4 YQu5%r4G{{ˆ         ^eatXT1ە産= +NOvHTԱkͳΝ2~S[Yyq *5:ֈ:*:+-(*q@,!KcJD""::i'NR=I.8̮~͜g<<cW[^~2^8%:<g']UEڼ}=Fϑ/Vn3匟XLOoKYЗ=gbio*>Ar&ͦ|zjXn[l$2J[R_2U^z*/6CY: b}9%Lg;F}OQV`qv֨\;bՇfペӧbvJC>%ΟjCW?k\,:%?=Cut>Mbnu֏=Sczd_$̏36mݑ{_~A/VT</m4 + GIq9QMVKwL^Qrlx3jJrt"%sgul6&7xl9wl^_62<tͷ :홌=VKc}Cԣf�fMԦrCW:}?[kW#cxʒ$?}clVu+uG3BL6m|ڞ._ʒ'؞s,]&xy}!hW"FVG?Kr1^#Æ,1؟nuF Ib IqŰ0Aƪ?CÔڿ-/[?`1=t(1Q;l=$3JAARtLdA|o=˭Vm]qo_OPH3mZ'VܵvS+汵X6d oңo[ FE+ slNEIq=*w'#2k%k2 J?*҂see~m{H`l_oJYNHtxW|fkxbC;wlKY+>t(hbn,J27cuطGWcr\1.Lgnvxb w8vDFIwTjk#c0?"Rڐԗ˗U;FƞAY9ò?D"qk։I3s$O;js3ÛBQʾV[qabUspx8Jjѻq3: CB3u6\λR%34+]klV?7V'$:H78gH_md obRw^goߐkikR\1,L0dGhXL7J@閮Yod +2we2�sg͖34X9m\åZ{ ]980PZdtM[-UG<ϏU*KG2H!bN̜梑a"U䯺 [{7,!ޔFOߵv>N[<j2<yylLmbQ'b%W_8^9}J%k'oWWv>d o"-b6_[c^•c{UQl=YcnLZ/ܭr@ڌ~+UϷŘ}};||k "S__[hPczGߦ0 n_N3WPo6hOP%uJ)';ſ?_ .DWU&@EIqدD!W'$zhxCEYپgqWW6Uc~Ws6?-kmV8jNkl!_6dęX_tȑ0qsAg~~d왬WF%,ZA7겢p,ά'p&4??pFҩ 있9܏M|=Jf߼R)yaѮiӇ-u]kcjօpq6+_qKiϖ_J+uu{]rxN[З=OGk}zKSW?0Ԣ�#${F>[/Sg:%c�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������@�LT` endstream endobj 291 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4461/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +Hn#I DQO`ܛJEfd<4Ћ 22?>������������������������������������������������������������z +`K<i�_OqsNrXG[K*_rpPV>d+{锹߼V79}M[}ľz_�s5Ǚɱk3Ócg'Ǯ9 O]s83<9vqfxr5Ǚɱk3Ócg'ǮCÒcոX58V@cӸ486qfxr5Ǚɱk3Ócg'Ǯ9 O]s{f>FǒqXűdf6fovxqU;wfaűbVqؿf�j9vqfxrص_ >ćNOÍ5Ǚɱk3Ócg'Ǯ9 OF];0ӵr>]>Mt95 +&]j&]> ѵߩBkF5{@£k4Xͩk734YVrh8pdY5ˡȲjCÑe˩dziSÏg<ϦyN ?M~<vx 7E3nLf:6ܘtl1-pcZtnxq3׹ŵgsËk\מÉmlۚ'5Nlkf;8찝>|[;9|wrm2÷epa\2¸dƣÅqɌG ƳÃsǜg9s;<;<8wp+f=<XWzx8q͸p_�;ؙ}�o~+`W `ʲ\IWp<uL9$jzu>[`_zy>k`Wz+=)^{ʺW7>dlʺV>[cɺU97[u&`O֥:|]#N]eNzu~`>ց^B} תO܇Fզoo%H*u}-fUr~[A[.݇^֣}X(v+bv߇ԯ/oއ(ӯ,߇(Ѱ))85I}8d ;x#Qǂއa�HӱRF}8ƀ,F}8&lE}恟ه ?г +ŧa v$:$K~1tI w*)Ko[XxWc^R,cW62uxSߗ.l}:3V>J~'iG?p]H:nYߠ1QǂZkU5ߴ9Z<Z,*u2uJxC::(|+֔:,<j5E gݟĵԑF+ip9ujÝ&n2[W;ڥ1}|Nyt":ׯ)̚i~ y"ZT8,3"^zQ8,ouIÝh{+4e>;jn17 yr5]'9MX-IlsqO[Mܗ:v<Cn )oncJN1g6φ:tcϬu椞8;}͉<n{w^\_РzfLf&%1swp2)洂5~ "Vp0*߬b~ +7TekMjT?֬TԒm4,Ҝ&~ 3Eh+ӲLiPgƴS3v0.Ì̡~-qff) /0Mf^r mInc{o_y4-51S:JG\cdRK0|)e,_oYkfD)[sOָ~"CY'G04qO٦ƒ76LϛelY FxAoDxIClpysV5|L1c>ḓ\AǿfI3G + [<jm3hO3Vxmʞwh ̄ǎJvpA~{ߤ#(nv~›I@a[n5]݄f<TC9@&aMJ! ).syN]MΣG¦xo PA7V Pǽ+OQJ9Wci*B@5f<UI +ٌ򩳕5Q9qY1ƭRV2EŨrZ.HZQXϡ3.Q$voE|%KlE];u +֎Ȭa@nJd׷\eN(p4] +QW"q`#;fuXLՁ`?6+vD'MVm`c j-,C]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]0u`E]M H[ͤ0L Hk0?&i/:Hi߿<PMzO& +{1x0.UYuQa q/(HK}@AZPQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuSQuvTm\F[kNJ4_rRFدݴ OO.NYx%R)Wcg1'uU2,aȺ*fYeW('ube}3ˆC! +[C!އȲ*ڰ?fٔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?bYMKmJ:l9o}6އ�dZW%Ri UT = HIf<lx^rx=cawp^wuU2,a̲)ʠ +:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0U̼ݲ) +a´ݺ)qo78]>x|lw428ypixqp>Dn3kz_7kz_71>�ʘ٫J_tއ$Iҷ!jM3bmgk[ `l2:G̻eCW/5a>WLsOǍ^OczoAt{~{u;r + I6}qyW\>~o.K}\^~r;ʘ=RsOD[Nt߱wml}<Nt3s%{75Oϼk[!G.3G,I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$/�Q endstream endobj 290 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4213/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrQOs*$1!$l6Ve>U7I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$.=tKCzħ!=}D+!߇ϧf>6illd?d}(%!d_>vO1o2}Clq<|e}[}Czqf1[#,&bkęDl8g5b"FYLֈ3qf1[#,&bkęDl8mġDLU> +1E> +4߇V!FYLֈ3qf1[#,&bkęDl8ggN..bdB~BlU8P> +1?3f }H"FYLֈ3ڧ>/Ÿ(ͧ}]o4ęDl8g5b"FYL~ +Yp6߇z6߇֣cN߇VP1}Z ҚCֶ>)=Ze}| ?3Ȑ!25"BZDԐCچZ<ҘSYsj0KcN-fi̩,mc-hhбE :hA 44آA 3bvF[,ΨsunP;ۨvp`3.lfE ;Hm;8q'2VƝ\6�G]xtQ#yv1#.rc@n<ȍmEN =Љ:m/=Н/;y/~]_6ୠjWtWȸ~]mG%tдއ}j贾{-t_첾}5tW찾+)vWFeBwa{@M8EUDo"W&UtO>^ݔC7J2VIZFw*m^EFyv:JkTu,n=uGYz궏}x )]NRRo#FW?7⭤15\I) cjRx;)cKwRFǖ[J -SjZtd)VZgI=z=K깕Yҡxki!5]K5 ZV׎vtp/bZmFmJm3jVjxiLfմJUGt|5nZsCw*[N+NrZuB +,N]Pt㭧5zZjӵ}?]{?x JMqA-1ݨ*zO lU:s_vPtOŠZe<e<ŽZg;g;/’^t~Nk)G.T8rvRzy MwM] gȚ:σΐ5u/){4/<^7SY^yn,s<xٌYTxy𲙳^ˀV3gS=锇AfЪ9U8)fҮo̤]98ge}AF-YݮW٬m9Nng--BeRCJ߾lغB("P)5NigU6mߓ@l9 s!gHe6ℯ]AEʚ:R2' r< *he+ģ۸2K>cszW[)(*ҭO0]%V}Ovڟ9+>wPϻ`~Je?`9{~ZJ7?שlO8w~ZJ^v2ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0kihGMKd?}d%d?n}( [qC2ISH'~4s& |4A3gPGpn4J0cQr5y,McilOHLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs/KLs?Ϥih}4}0Qq4K~PB46߇B?EC ߇}(! +fֵppYs@4kT(aC |JF4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:4J:C>=Ɇn4MCSQbc㟤U5y,Mcil9YCwLwn;xd7PJ>M>\CvFi4{.  iteiteite_GmcAD?]"钊W쀞rul10v,Ӂ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u?c*ڰ?e*?徥!�sKz?i*?e)ڠ~ݪDHvn#y/雱w݆%7C38m9mK]_ Kuꟳ۔Ke :0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0Uuݦ\T*vMԈf>nx'ڼq>}q 9u]77k?ͨc8a[c>�ɶW_4m +C$o㱷{[_N ~,׸3O c+GM&|jy Krqpv׫m>>بx׷WCc|$yML}@5c{Cj}\>Rwׅ!19g+jv2|]]ވ܈1~Μws?c|stq@̕ +o5o?g|)dcts/?ϏY$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IR�) endstream endobj 289 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 271 0 obj <</Intent 292 0 R/Name(Layer 1)/Type/OCG/Usage 293 0 R>> endobj 292 0 obj [/View/Design] endobj 293 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 276 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 275 0 obj <</LastModified(D:20170111121252Z)/Private 294 0 R>> endobj 294 0 obj <</AIMetaData 295 0 R/AIPDFPrivateData1 296 0 R/AIPDFPrivateData10 297 0 R/AIPDFPrivateData100 298 0 R/AIPDFPrivateData101 299 0 R/AIPDFPrivateData102 300 0 R/AIPDFPrivateData103 301 0 R/AIPDFPrivateData104 302 0 R/AIPDFPrivateData105 303 0 R/AIPDFPrivateData106 304 0 R/AIPDFPrivateData107 305 0 R/AIPDFPrivateData108 306 0 R/AIPDFPrivateData109 307 0 R/AIPDFPrivateData11 308 0 R/AIPDFPrivateData110 309 0 R/AIPDFPrivateData111 310 0 R/AIPDFPrivateData112 311 0 R/AIPDFPrivateData113 312 0 R/AIPDFPrivateData114 313 0 R/AIPDFPrivateData115 314 0 R/AIPDFPrivateData116 315 0 R/AIPDFPrivateData117 316 0 R/AIPDFPrivateData118 317 0 R/AIPDFPrivateData119 318 0 R/AIPDFPrivateData12 319 0 R/AIPDFPrivateData120 320 0 R/AIPDFPrivateData121 321 0 R/AIPDFPrivateData122 322 0 R/AIPDFPrivateData123 323 0 R/AIPDFPrivateData124 324 0 R/AIPDFPrivateData125 325 0 R/AIPDFPrivateData126 326 0 R/AIPDFPrivateData127 327 0 R/AIPDFPrivateData128 328 0 R/AIPDFPrivateData129 329 0 R/AIPDFPrivateData13 330 0 R/AIPDFPrivateData130 331 0 R/AIPDFPrivateData131 332 0 R/AIPDFPrivateData132 333 0 R/AIPDFPrivateData133 334 0 R/AIPDFPrivateData134 335 0 R/AIPDFPrivateData135 336 0 R/AIPDFPrivateData136 337 0 R/AIPDFPrivateData137 338 0 R/AIPDFPrivateData138 339 0 R/AIPDFPrivateData139 340 0 R/AIPDFPrivateData14 341 0 R/AIPDFPrivateData140 342 0 R/AIPDFPrivateData141 343 0 R/AIPDFPrivateData142 344 0 R/AIPDFPrivateData143 345 0 R/AIPDFPrivateData144 346 0 R/AIPDFPrivateData145 347 0 R/AIPDFPrivateData146 348 0 R/AIPDFPrivateData147 349 0 R/AIPDFPrivateData148 350 0 R/AIPDFPrivateData149 351 0 R/AIPDFPrivateData15 352 0 R/AIPDFPrivateData150 353 0 R/AIPDFPrivateData151 354 0 R/AIPDFPrivateData152 355 0 R/AIPDFPrivateData153 356 0 R/AIPDFPrivateData154 357 0 R/AIPDFPrivateData155 358 0 R/AIPDFPrivateData156 359 0 R/AIPDFPrivateData157 360 0 R/AIPDFPrivateData158 361 0 R/AIPDFPrivateData159 362 0 R/AIPDFPrivateData16 363 0 R/AIPDFPrivateData160 364 0 R/AIPDFPrivateData161 365 0 R/AIPDFPrivateData162 366 0 R/AIPDFPrivateData163 367 0 R/AIPDFPrivateData164 368 0 R/AIPDFPrivateData165 369 0 R/AIPDFPrivateData166 370 0 R/AIPDFPrivateData167 371 0 R/AIPDFPrivateData168 372 0 R/AIPDFPrivateData169 373 0 R/AIPDFPrivateData17 374 0 R/AIPDFPrivateData170 375 0 R/AIPDFPrivateData171 376 0 R/AIPDFPrivateData172 377 0 R/AIPDFPrivateData173 378 0 R/AIPDFPrivateData174 379 0 R/AIPDFPrivateData175 380 0 R/AIPDFPrivateData176 381 0 R/AIPDFPrivateData177 382 0 R/AIPDFPrivateData178 383 0 R/AIPDFPrivateData179 384 0 R/AIPDFPrivateData18 385 0 R/AIPDFPrivateData180 386 0 R/AIPDFPrivateData181 387 0 R/AIPDFPrivateData182 388 0 R/AIPDFPrivateData183 389 0 R/AIPDFPrivateData184 390 0 R/AIPDFPrivateData185 391 0 R/AIPDFPrivateData186 392 0 R/AIPDFPrivateData187 393 0 R/AIPDFPrivateData188 394 0 R/AIPDFPrivateData189 395 0 R/AIPDFPrivateData19 396 0 R/AIPDFPrivateData190 397 0 R/AIPDFPrivateData191 398 0 R/AIPDFPrivateData192 399 0 R/AIPDFPrivateData193 400 0 R/AIPDFPrivateData194 401 0 R/AIPDFPrivateData195 402 0 R/AIPDFPrivateData196 403 0 R/AIPDFPrivateData197 404 0 R/AIPDFPrivateData198 405 0 R/AIPDFPrivateData199 406 0 R/AIPDFPrivateData2 407 0 R/AIPDFPrivateData20 408 0 R/AIPDFPrivateData200 409 0 R/AIPDFPrivateData201 410 0 R/AIPDFPrivateData202 411 0 R/AIPDFPrivateData203 412 0 R/AIPDFPrivateData204 413 0 R/AIPDFPrivateData205 414 0 R/AIPDFPrivateData206 415 0 R/AIPDFPrivateData207 416 0 R/AIPDFPrivateData208 417 0 R/AIPDFPrivateData209 418 0 R/AIPDFPrivateData21 419 0 R/AIPDFPrivateData210 420 0 R/AIPDFPrivateData211 421 0 R/AIPDFPrivateData212 422 0 R/AIPDFPrivateData213 423 0 R/AIPDFPrivateData214 424 0 R/AIPDFPrivateData215 425 0 R/AIPDFPrivateData216 426 0 R/AIPDFPrivateData217 427 0 R/AIPDFPrivateData218 428 0 R/AIPDFPrivateData219 429 0 R/AIPDFPrivateData22 430 0 R/AIPDFPrivateData220 431 0 R/AIPDFPrivateData221 432 0 R/AIPDFPrivateData222 433 0 R/AIPDFPrivateData223 434 0 R/AIPDFPrivateData224 435 0 R/AIPDFPrivateData225 436 0 R/AIPDFPrivateData226 437 0 R/AIPDFPrivateData227 438 0 R/AIPDFPrivateData228 439 0 R/AIPDFPrivateData229 440 0 R/AIPDFPrivateData23 441 0 R/AIPDFPrivateData230 442 0 R/AIPDFPrivateData231 443 0 R/AIPDFPrivateData24 444 0 R/AIPDFPrivateData25 445 0 R/AIPDFPrivateData26 446 0 R/AIPDFPrivateData27 447 0 R/AIPDFPrivateData28 448 0 R/AIPDFPrivateData29 449 0 R/AIPDFPrivateData3 450 0 R/AIPDFPrivateData30 451 0 R/AIPDFPrivateData31 452 0 R/AIPDFPrivateData32 453 0 R/AIPDFPrivateData33 454 0 R/AIPDFPrivateData34 455 0 R/AIPDFPrivateData35 456 0 R/AIPDFPrivateData36 457 0 R/AIPDFPrivateData37 458 0 R/AIPDFPrivateData38 459 0 R/AIPDFPrivateData39 460 0 R/AIPDFPrivateData4 461 0 R/AIPDFPrivateData40 462 0 R/AIPDFPrivateData41 463 0 R/AIPDFPrivateData42 464 0 R/AIPDFPrivateData43 465 0 R/AIPDFPrivateData44 466 0 R/AIPDFPrivateData45 467 0 R/AIPDFPrivateData46 468 0 R/AIPDFPrivateData47 469 0 R/AIPDFPrivateData48 470 0 R/AIPDFPrivateData49 471 0 R/AIPDFPrivateData5 472 0 R/AIPDFPrivateData50 473 0 R/AIPDFPrivateData51 474 0 R/AIPDFPrivateData52 475 0 R/AIPDFPrivateData53 476 0 R/AIPDFPrivateData54 477 0 R/AIPDFPrivateData55 478 0 R/AIPDFPrivateData56 479 0 R/AIPDFPrivateData57 480 0 R/AIPDFPrivateData58 481 0 R/AIPDFPrivateData59 482 0 R/AIPDFPrivateData6 483 0 R/AIPDFPrivateData60 484 0 R/AIPDFPrivateData61 485 0 R/AIPDFPrivateData62 486 0 R/AIPDFPrivateData63 487 0 R/AIPDFPrivateData64 488 0 R/AIPDFPrivateData65 489 0 R/AIPDFPrivateData66 490 0 R/AIPDFPrivateData67 491 0 R/AIPDFPrivateData68 492 0 R/AIPDFPrivateData69 493 0 R/AIPDFPrivateData7 494 0 R/AIPDFPrivateData70 495 0 R/AIPDFPrivateData71 496 0 R/AIPDFPrivateData72 497 0 R/AIPDFPrivateData73 498 0 R/AIPDFPrivateData74 499 0 R/AIPDFPrivateData75 500 0 R/AIPDFPrivateData76 501 0 R/AIPDFPrivateData77 502 0 R/AIPDFPrivateData78 503 0 R/AIPDFPrivateData79 504 0 R/AIPDFPrivateData8 505 0 R/AIPDFPrivateData80 506 0 R/AIPDFPrivateData81 507 0 R/AIPDFPrivateData82 508 0 R/AIPDFPrivateData83 509 0 R/AIPDFPrivateData84 510 0 R/AIPDFPrivateData85 511 0 R/AIPDFPrivateData86 512 0 R/AIPDFPrivateData87 513 0 R/AIPDFPrivateData88 514 0 R/AIPDFPrivateData89 515 0 R/AIPDFPrivateData9 516 0 R/AIPDFPrivateData90 517 0 R/AIPDFPrivateData91 518 0 R/AIPDFPrivateData92 519 0 R/AIPDFPrivateData93 520 0 R/AIPDFPrivateData94 521 0 R/AIPDFPrivateData95 522 0 R/AIPDFPrivateData96 523 0 R/AIPDFPrivateData97 524 0 R/AIPDFPrivateData98 525 0 R/AIPDFPrivateData99 526 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 295 0 obj <</Length 1003>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC3.pdf) %%CreationDate: 11/01/2017 12:12 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5767 -432.0078 498.6709 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -937 496 1 2452 1464 26 0 0 27 234 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 296 0 obj <</Length 12182>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5767 -432.0078 498.6709 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 12030 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD28FFA8FD %56FF7DFD27FFA8A8FD56FFA8A8FD27FFA8FD56FF7DFD27FFA8A8FD56FF7D %A8FD27FFA8FD56FF7DFD27FF7DA8FD08FFA8FFA87DA8FFA8A8AFFD45FFA1 %7DFD26FFA8A8FF59FD06A87D7D7D527D5227525252A8FD43FF7D7DAFFD23 %FFA88453A8FFAFA8FFA8FFA8FFA8A87DA8A8A87DA87DA8A8FD43FFA877A8 %FD20FFAFA97E7E53A1A8FD56FF7DA17DFD1DFFA8A87E5A535A5A7DA1A8FD %56FFA8A1A1A8FD19FFA8A87EFD045A7E5A7EA1C9A8FD55FFA876A1A17DFD %16FFA8A8595A2F5A5A5A545A5A5A53C3A1A8FD56FFA8A1CA7DFD14FFA859 %7E5A7E5A7F5A7E5A7F5A7E5AA1A1A8A8FD56FF7DA1A1A17DFD08FFA8FD06 %FFA8A87E7E5A5A5A7E5A7E5A7E5A7E5A7E5A7DA1CAA1A8FD0CFFA8FD49FF %A8A1CAA17D84FD08FFA8FFFFFFA87E7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A %5A7EA1CAA1CAA8FD55FFA87DA1A1C37D7DFD08FF7DA87E5A545A545A5A5A %545A5A5A545A5A5A545A5A5A53C3A1A1A1A8FD0CFFA8FD49FFA8A1CAA1CA %7DA8FD04FFA9A97E7E5A7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A %A2A1CAA1CAA8FD56FF7DFD05A17DFFA884595A547E53FD125A7E5A7DA1CA %A1A1A1A8FD0CFFA8FD49FFA8A1CAA1CAA1A15A7E547E5A7E537D5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5AA1CAA1CAA1A1A8FD54FFA9FF7DA1 %A1C9A1A1A17E5A5A545A5A5A535A5A5A545A5A5A545A5A5A545A5A5A545A %5A5A53C3A1A1A1C9A1A8FD0CFF7DFD49FFA8A1CAA1CAA1CAA15A5A7F5A7E %5A7D5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E59A8A1CAA1CAA1A7A8FD %0BFFA8A8FFFFA8FFAFFFA8FFFFA8A8A87D527DA87D7D7DA8A8FD34FF7DA1 %A1CAA1A1A1C977FD045A7E767EFD115A7DA1CAA1A1A1CAA1A8FD0BFF7DA1 %FFA87D7DA87EA87DA8FD047D527D7D52277D527DFD34FFA8A1CAA1CAA1CA %A1CA595A5A7E5AA17D7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7EA1CAA1CA %A1CAA1CAA8FD0AFFA877CAFD0CFFA8FD3AFFA87D52FD04A1C9A1A1A17D30 %5A545A76A1535A5A5A545A5A5A545A5A5A545A5A5976CAA1A1A1C9A1A1A1 %A8FD0AFF77A1A1FD49FFA8A1CAA1CAA1CAA1CAA17D5A7F59A1A17D5A7E5A %7F5A7E5A7F5A7E5A7F5A5A7DCAA1CAA1CAA1CAA1CAA8FD09FFA8A1A1CAFD %49FF7DFD04A1CAA1A1A1CAA17D5A7E76C97DFD0D5A77C3A1CAA1C3A1CAA1 %C3A1CAFD08FFA87DA1C9A1FD49FFA8A1CAA1CAA1CAA1CAA1CAA17E5AA1A1 %CA537E5A5A5A7E5A7E5A7E5A5A53C9A1A1A1CAA1CAA1A27D7D7DA984A984 %A984A9595A7DC9A1CAFD47FFA8A87DFD05A176FD04A1C9A17D76CAA17D2F %7E595A54FD045A7E597E5359535A545A5A5A535A545A2F5A545A2F5A545A %53FD04A1FD49FFA8A1A17DA17DA176A1A1CAA1CAA1A1A1CAA17D5A7E5A7F %5A7E5A7F5A7E5A855A7F5A855A7F5A855A7F5A855A7E5A855A7F5AA8A1CA %A1CAFD49FF7DA1A17D76A176A17DA176A1A1A176CAA1C3A1FD0A5A7E5A7E %5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A7EA1CAA1A1A1FD0FFFA8FD39FF %A7A1C3FD09A1CAA1A1A1CAA1CA7D5A5A7E5A7E5A7E5A7E597E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAFD47FFA8A87DA8A8A8A7CA %A8A87DCAA8A8A1A876C3A1C9A1A1535A5A5A545A5A5A547E5A5A545A5A5A %545A5A5A545A5A5A545A5A5A53FD04A1C3A1FD0FFFA8FD46FFAFA1A1CAA1 %CAA17E5A7E5A7F5A7E5A7F7E7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A %A2A1CAA1CAA1CAFD56FFA876C3A1CAA1C3A1FD085A5953FD0E5A7E5A7DA1 %CAA1A1A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CAA1CA7D5A5A7E5A7E5A5A53 %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAA1CAFD0EFFA8FD %48FF76C9A1A1A1C9A1A1535A5A5A545A5A7D535A5A5A545A5A5A545A5A5A %545A5A5A53C3A1A1A1C9A1A1A1FD0EFFA7A8FD46FFA1A1A1CAA1CAA1CAA1 %A15A7E5A7F5A7E777D5A7E5A7F5A7E5A7F5A7E5A7F5A5A53CAA1CAA1CAA1 %CAA1CAFD0EFF7DFD46FFA8A876CAA1A1A1CAA1A1A17DFD055A7D76595A5A %5A7EFD095A7DA1CAA1A1A1CAA1A1A1FD0DFF7D7DA8FFFFFFA8FFFFFFA8FF %A8A8A8FF7D7EA8FFFFA8A8FD33FFA1A1CAA1CAA1CAA1CAA17D5A7E5A5A7D %C37D5A5A7E597E5A7E5A7E5A7E5AA2A1CAA1CAA1CAA1CAA1CAFD0CFFA87D %A1FFFFFFA87D7DA8A8A87EA852FD047DA8FD045228A8FD31FF76C3A1C9A1 %A1A1C9A1C3A17E5A5A5A7DA1A1535A5A5A535A595A535A5A7DA1C9A1A1A1 %C9A1A1A1C3A1FD0CFF7E77C9A8FFFFFFA8FD05FFA8A87DFD05A87DA87D7D %A8FD30FFA8A1A1CAA1CAA1CAA1CAA1CAA17E5A7E7DC3A17E5A7E5A7F5A7E %5A7E5A5AA1CAA1CAA1CAA1CAA1CAA1CAFD0CFF7DCAA1FD48FF7DA1767DA1 %76767DA1C3A1CAA17E367DA1C377FD0B5A537DA1A1A1CAA1A1A1C3A1FD0B %FF7E7DA1A7A8FD46FFA8A1A1A176A176A17DFD04A1CAA17E53C9A1A1597E %5A7E5A7E5A7E5A7E5A5A5A7E5A7E7DCAA1CAA1CAFD0AFFAF7DA1CAA1FD48 %FF76CAA17676A1A1A176A176A1A1C9A17DA1C9A17D305A5A5A545A5A5A54 %5A5A5A545A5A5A537E7DA1A1FD0AFF7E76C9A1A1A8FD46FFA8A1A1CAA1CA %A1CAA1CAA1CAA1CAA1CA7CCAA1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7F5A5A5A7E84A8FD08FF7DCAA1CAA1FD48FFA8FFFFFFA8FFFFA8A8FFFF %FFA8FFFFA1A1CAA1C37DFD0A5A7E5A7E5A7E5A7E5A7E5A5A5A7E7EA8A8FF %A8FF7EA1A1CAA1A7A8FD0FFFA8FD46FFA1A1A1CAA1C9595A5A7E5A7E5A7E %5A7E5A7E5A7E5A5A5A7E5A5A5A7E5A5A547E5A7E7E7EA1CAA1CAA1FD57FF %A8A1A1A1C9A17D2F5A5A5A545A5A5A545A595A545A5A5A545A5A5A545A5A %5A545A5A5A77C9FD04A1A8FD0FFFA8FD46FF7DA1A1CAA1CAA17E5A7E5A7F %5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A7DCAA1CAA1CAA1FD %57FFA7A1C3A1CAA1C37DFD085A7E53FD0F5A53A1A1CAA1A1A1A7A8FD0FFF %A8FD46FF7DA1A1CAA1CAA1C9775A5A7E5A7E5A7E537D5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5AA1A1CAA1CAA1CAA1FD57FFA1A1C9A1A1A1C9A1A1535A5A %5A545A5A5A535A5A5A545A5A5A545A5A5A545A5A7DA1C9A1A1A1C9A1A1A8 %FD0FFF7DFD45FFA87DC9A1CAA1CAA1CAA17D5A7E5A7F5A7E5A7D5A7E5A7F %5A7E5A7F5A7E5A7F5A5AA1CAA1CAA1CAA1CAA1FD0FFFA8A8FD46FFA1A1CA %A1A1A1CAA1C3A17DFD055A7E767EFD0C5A7DC3A1CAA1A1A1CAA1A1A8FD0E %FF7DA1FD46FFA1A1A1CAA1CAA1CAA1CAA17E5A7E5A7E5AA17D7E5A7E5A7E %5A7E5A7E5A5A77CAA1CAA1CAA1CAA1CAA1FD0EFFA877CAFD46FFA1A1C3A1 %CAA1C3A1C9A1C3A17E5A5A545A76A153FD095A53A1A1C9A1A1A1C9FD04A1 %A8FD0DFF77A1A1FD46FFFD06A176A1A1CAA1CAA17E5A7F59A1A17E597E5A %7E5A7E5A7E7DCAA1CAA1CAA1CAA1CAA1CAA1FD0DFFA8A1A1CAFD46FFA8A1 %7D76A1767676CAA1C3A1CAA1595A7E76C97D5A5A5A535A5A5A537DA1A1A1 %C9A1C3A1CAA1A1A1CAA8FD0CFF7DA1C9A1FD46FF7DA1A17D76A17DA17DA1 %7DA1A1CAA17E53A1A1C9535A5A7E5A7E5A7E5A5A597E7D7E7DCAA1CAA1CA %A1FD0CFFA977CAA1CAFD43FFA8FFFFA176A1A1A176A1A1A176FD04A1C3A1 %7D76CAA1A12F5A5A5A545A5A5A545A5A5A2F5A5A5A537E7D7E7DA8A8FFA8 %FD07FF53FD04A1FD46FFA8CAA8CAA8CAA8CAA7CAA8CAA8CAA8CAA1A1A1CA %A17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7FFD055A7E5A7E59A984A97EFF %84A1A1CAA1CAFD56FFA876CAA1C3A1FD0C5A7E5A7E5A7E5A7E5A7E5A7E5A %7EFD055A7DA1CAA1A1A1FD57FFA1A1CAA1CA7D5A5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAFD10FFA8FD46 %FF76C3A1C9A1A1535A5A5A545A5A5A545A535A545A5A5A545A5A5A545A5A %5A545A5A5A53FD04A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CAA17E5A7E5A7F %5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5AA2A1CAA1CAA1CA %FD10FFA8FD45FFA876C3A1CAA1C3A1FD085A7EFD0F5A7E5A7DA1CAA1A1A1 %C3A1FD3DFFA9A8FFA8A87DA8FFFFA8AFFD0EFFA8A1A1CAA1CAA1CA7D5A5A %7E5A7E5A7E5A7D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAA1 %CAFD10FFA8FD2CFF5252A87D5227527E2752277D52A87DA87DA87D7D7DFD %05FF76C9A1A1A1C9A1A1535A5A5A545A5A5A537E5A5A545A5A5A545A5A5A %545A5A5A53C3A1A1A1C9A1A1A1FD0FFFA8A8FD2CFFA87DFFA8A87DA8A8A8 %84A8A8A8FD0CFFA1A1A1CAA1CAA1CAA1A15A7E5A7F5A7E5A7D597E5A7F5A %7E5A7F5A7E5A7F5A5A53CAA1CAA1CAA1CAA1CAFD0FFFA8A8FD44FFA8A876 %CAA1A1A1CAA1A1A17DFD065A527DFD0D5A7DA1CAA1A1A1CAA1A1A1FD0FFF %7DFD47FFA1A1CAA1CAA1CAA1CAA17D5A7E5A7E5A7D7D7E5A7E5A7E5A7E5A %7E5A7E5AA2A1CAA1CAA1CAA1CAA1CAFD0EFF7EA1A8FD46FF76C3A1C9A1A1 %A1C9A1C3A17E5A5A545A53A1535A5A5A545A5A5A545A5A7DA1C9A1A1A1C9 %A1A1A1C3A1FD09FFCFFFA8FFA87DA1CAFD45FFA8A1A1CAA1CAA1CAA1CAA1 %CAA17E5A7F5A7DA1A15A7E5A7F5A7E5A7F5A7EA1CAA1CAA1CAA1CAA1CAA1 %CAFD07FFA87EA9595A5A7EA1CAA8FD46FF7DA1767DA176767DA1C3A1CAA1 %7E5A7E53A1A17DFD065A547DA1C3A1CAA1A1A1CAA1A1A1C3A7FFA8FF7EA9 %597E5A5A545A5A5A53C9A1CAFD45FFA8A1A1A176A176A17DFD04A1CAA17E %5A7DA1CA7D5A5A7E5A7E5A7EA1CAA1CAA1CAA1CAA1CAA1C9A1A87EFD065A %7E5A5A5A7E5AA1A1CAA8FD46FF76CAA17676A1A1A176A176A1A1C9A17E52 %A1A1A1535A5A5A53A1A1C3A1A1A1C9A1CAA1A17DA27D7EFD055A7E5A7E5A %7E5A7E5A7DA1A7A1FD46FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1 %CAA17D537E7DA7A1CAA1CAA1A1A1A87D7E5A7F5A7E5A7F5A7E5A7F5A7E5A %7F5A7E5A7EA1CAA1CAA8FD46FFA8FFFFFFA8FFFFA8A8FFFFFFA8FFFFA87C %A1A1C3A17DCFFFA8FFA8A87DA853FD155A53C9A1A1A1FD0DFFA8FD49FFA8 %A1CAA1CA7D8584A9597E5A5A5A845A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5AA1A1CAA1CAA8FD56FF7DA1A1C9A1A1535A545A545A5A7E595A %5A5A545A5A5A545A5A5A545A5A5A545A5A5A547DA1A1A1C9A1CAFD0CFFA8 %FD49FFA8A1CAA1CAA1A25A7E5A7F5A7E597D5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5A7F5A7E5A7EA1CAA1CAA1CAA8FD56FF7DA1A1CAA1C3A17EFD065A53 %FD135A53C9A1A1A1CAA1CAFD0CFF7DFD49FFA8A1CAA1CAA1CA7D5A5A7E5A %7E5A7D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA1CAA8 %FD0BFFCAA8FD2FFFA87D7DA87D7D277DA87D527D7DA8FFFFA8FFA8FFA8FD %05FF7DFD04A1C9A1A1535A5A5A547E52FD055A545A5A5A545A5A5A545A5A %5A2F7DA1A1A1C9A1A1A1FD0CFFA8A1FD2FFFA97D7E7DA853527D7DFD0452 %7DFFFD05A87D7DFD04FFA8A1CAA1CAA1CAA1CA597E5A7F5AA17D7F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CAA1CAA8FD0BFF7DCAFD31FF %A8FD07FFA8FD0EFFA876FD04A1CAA1A1A17DFD045A7DA153FD0C5A7E5A59 %76CAA1A1A1CAA1A1A1FD0BFF7DA1A7FD49FFA8A1CAA1CAA1CAA1CAA17D5A %7E5AA1A17D5A7E5A7E5A7E5A7E5A7E5A7E5A7E7DCAA1CAA1CAA1CAA1CAA8 %FD07FF7EA95A7DA1CAFD49FF7DA1A1C9A1A1A1C9A1C3A17D5A7D76CA77FD %055A545A5A5A545A5A5A52C9A1A1A1C9A1A1A1C3A1A8A8FF7E857E5A5A5A %305A7DA1A1FD49FFA8A1CAA1CAA1CAA1CAA1CAA17E5AA1A1C9537F5A7E5A %7F5A7E5A7F5A5A53CAA1CAA1CAA1CAA1CAA17E597E5A5A5A7E5A7E5A7F7D %C9A1CAFD47FFA8FF7DFD05A176A1A1C3A1CAA17D76CAA17D54FD095A7DC3 %FD04A177A27D7E547EFD0A5A53FD04A1FD49FFA8A1A176A17D7676CAA1CA %A1CAA1A1A1CAA1595A7E5A7E5A7E5A5A53A17E7E537EFD075A7E5A7E5A7E %5A7E5A7E5A7DA1CAA1CAFD49FF7DA1A17652A176A176A176A1A1A176C3A1 %C9765A545A535A5A5A545A535A5A5A545A5A5A545A5A5A545A5A5A54FD05 %5A7DC3A1C3A1FD49FFA8A1C9A1A1A1C3FD05A1CAA1A1A1CAA1CA597E5A7E %5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F7DCAA1CA %A1CAFD49FF7DA8A8CAA8CAA8A8A1CAA8A8A7A87CC3A1CAA1A1FD1C5A53FD %04A1C3A1FD57FFA1A1CAA1CAA17E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7DA1CAA1CAA1CAFD56FFA876CAA1A1A1C97DFD %055A545A5A5A545A5A5A545A5A5A545A5A5A54FD055A7DC3A1C9A1A1A1FD %56FFA8A1A1CAA1CAA1C9597F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7F5A7E5A5B7DCAA1CAA1CAA1CAFD57FF76CAA1A1A1CAA1A153FD175A53 %FD04A1CAA1A1A1FD40FFA8FFA8A87DA8A8FFA8FD0DFFA8A1A1CAA1CAA1CA %A17D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CA %A1CAA1CAFD3FFFFD047D5227FD0452277D52FFA8A87DA87DA852A8A8A176 %C3A1C9A1A1A1C9A159FD045A545A5A5A545A5A5A545A5A5A545A5A5A307D %A1A1A1C9A1A1A1C3A1FD40FFFD04A87DA87DFF7DA8A8A8FD0AFFA8A1A1CA %A1CAA1CAA1CA7D7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CA %A1CAA1CAA1CAA1CAFD57FF7DC3A1CAA1A1A1CAA1C37DFD105A7E5A597DCA %A1A1A1CAA1A1A1C3A1FD56FFA8A1A1CAA1CAA1CAA1CAA1CA7D5A5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAA1CAA1CAA1CAFD55FFA8A876 %FD05A17DA1A1C9A1A1775A5A5A545A5A5A545A5A5A545A5A5A7DC9A1A1A1 %C9A1A1A1C9A1A1A1FD57FFA1A1A176A776A176CAA1CAA1CA7D5A5A7F5A7E %5A7F5A7E5A7F5A5A7DCAA1CAA1CAA1CAA1CAA1CAA1CAFD57FF76CAA17676 %A17DA176A176A1A1C37DFD065A7E5A5A547E7DC3A1CAA1A1A1CAA1A1A1CA %A1A1A1FD56FFA8A1A1C3A1A1A1C3FD05A1C3A1C9A17D535A5A5A535A597D %A1C9A1C3A1CAA1C3A1CAA1C3A1CAA1A8FD55FFA8A8A1A8A1CAA8A8A1A8A1 %A8A1CAA7A8A1A8A1A87D7E7E7D7DA8A1CAA1CAA7A8A1A8A1A8A1CAA7A8A1 %A8A8FDFCFFFDFCFFFD0CFFFF %%EndData endstream endobj 297 0 obj <</Filter[/FlateDecode]/Length 14140>>stream +HWn8;pZY]-lưLNc%Cd{H([nԩӬĖȏhɨ ?E5g;o]ŷE0[Xx +C7EF [:F-.0Qu u$PȝUTtt /ZuN�3n4| !C. qsy$L>׶:G~pg;]fMd4Gt|$S?#CJdru KapE7_ 8VzѻVK8hnr B�?c\ K) #xBaH`}K,YPgHrHR.^qSD\'E\DU 6 uS,圜/48I8b}=Qyx"Z2!횐^~;oߑ"cKYPKiԵ{5pjrpøJt͔@X*bILUQmiu<ZCkOִ=ښ軧5kF=X^MCNlX +) 5tyMoxm-E +,V 0hjӀ6hVjb)B"gMifCiϔҠTê) 5i듘sy 'YңciH3wza wItG3D`%Sׇ%4sF{U8Nx[-ɚ$ۺ,`ɖlDVljU8zΖ!sO3av[GXBo=1?$p`qS>pGnW i] Y)wCl{W3'br2 +߇6. WcefHaȰ@]W(<+bHy .Ǥ=G`gA=$ɺ$e= gvӪΡvǗрij3\ +g7M$B,9" %[U2|`sNj #Y:|l*yX]iX: 6~TV:>[R7o} pQ/mKE߽),(1 ~قެ6^Ty/T*'/Nk8UQ(afԴ1H1-łeayjBW6&QsNk[#?[P <V�AEU59n *a9g7xIxC=}~ '$$~tm:@qZhB<ޅRσk Aot{cqSɼ,%a^ ~O"^%0Cݢ: i*Ҳ 'pTM9 Z n +\r*JKS^xIΫ5oQ?}FlE]koKB79\,Dxi._<ϒ_F37M+iM`flo0X< w1`[UdmXFJ_jLb*a\) +Y~czq3:$b#F>0PǞ=A4*Mpr7E E`iޝrd#YR$\,8^ V[QPF%IڔUַr -�8Lw<[Wyz~osL8l` +Vx~5!G g;_'.6kڿxMl5K*R:ܼ@!te+~zM9v$;H>(IЎ+ڑCLa/m8XCtØ\| AȒş|(dӀx4)b0_fy0E`"̍0`σV) 8?BC`q<e&>8w30ӿ%LۋȔ|N¼%<W#1P-#x̵(Kds|K%ª(8 v1! U7dL/A`}E $]2ZXmj6-MW['�Ou{Sŷ+pﮉ@Vc}Ø}W#QJO {s~`8C*z%pSRbA2*>0\QWj)ME +(pz54qJ**jE豍DKʌȱz)dȢ hZ`ZE]- jh)PXTU}Bo{ =OiUJYf.d6v3 Vo T?qR +B\BgRۡ7cG.Qp(tN}v)|RkVժ?HBѐ8.\E3dd.,4e PFhLŻ5M<,Y6|U]UUL +30j3`PhUa* ^5%VY\z,|K&]ͥRk@# +[**{..KHHƨY2Eg^[զX>.҂%{(/:RFVAMC?}Fγa{ IF/= + q\LF0xFQBр�|;K屜NncbvI@ eN\A 1?M/CsÏ5'>:4Uvrj]nON2ˢ.VcGJNҙf'5Dp�P{+HM?pP|z<Rf*Mym nϿ8 e\Sﮮ9N$Ö�8p#wX�0FSЙDT+`Kv7}찠 ݆oW)P8BLl V|+mӋ}_^J['KYz3[?KŷJo؇t^u(9Ë&;q8qrK/Du@oK::<L/*x,8firu6< wSYp_T)k# fSԺv̭}k=:Ψ{`.=Zw'm9P̒+Wdn7hSǫ}dn?nA?soӚX8H3.AdLZ!:Xޠ-vaMךqIM}2(`I;Cb6l*c' +jΩ~|]d]dV}FDW2FgF{VYǃ/@X]P1HdjY<_+}&h=Y< "tKzPQK?zXvwX.藜g{A (0F8κD|"ׂm]]&_yBs, Fs"9#7ԼdDsHpFV\X9<VwġPv)(V%"̱Biq Ay4'V)*]w%+= ~Y!cat3F0?bA02h;'3*s.=r-QaI6d&ISC)#dCbkin-6-ܬι[~9|&@9!=%dm +A6u JxmSw2`Dh10~5W0g**h]QJ[6*jYv1dz37! w[h5pPfa1(ţJ%*ɡyܼ{L3C +6fz8Hc`A)si~0֨GUaiI5(^inu,EWQ ƹHbS*0ݬV01c'JAO~P at}\Jd a\ClmҘW8M0*76 im JrX +F KX@טaP됇 *ddpwdkՄ[år'=M܍77}S8!O|$,lǼ "`?Q?68%�Y'`V.Fv~ ,nW8qiU%vCXQ*?HގZhtfuF$_8U4xuYL +y p5WO>Lv5Ha`ي9s׳ L]' n#&GO2Sء +-6<rbk?z( vL Yyh`.f,~"7g{*E$dQ]Qo v2=U~]q2 o!S?-cQ#~pt0}ؙgwܹ͜ZBōkiUl?{T_f' ] 4kul\,q%ۧn4޵0UۗfZp'TmW41n1\"jo/#YBXa:8Skf9uU(SUxn�{_ul^�lj�wX jRWTi# Jk׋"Lz5\Mj3 SqJ�Adq C7v ,`XU v 0[2E %UT7x`/Y_ +4aX{f:) 1[,1ˀ7 V:H/jOǮUEuU4*4]!.4vq,'# $ pC.XTu X0尪/ Մi, O*fiw;d)=uԦ.b/?6kJ4Uk"ltM)c-&S̅ak) +a]W,yHv\Sx_0Hl{-nSX0ͩ!,z6\|p Dž&5]d3N8(\Z]56&!WU%?H Xzɰ@ XPܒnQIn]$=Oaj4hMlCjfz(,Ws #:@OD̀i~FbN iHl#kT MQ0D~ jFm0.ٰ[�}V�"甫ְHuk 1Y&tWlA!>>ÿ֜a D+ԚL- ʹ@4QdKti)-藜s`D |ysӦȥI5cT�oG/5Wsbs@OuT0>}We}w +{9Ӏޑw<1200Uۻ7!9a{07ǧ4e8NGsӤ?}o +m率_vr(n˿_}u''!fMc! ;lHr>Woh%iFf\"4:iU12Y^0ShgÇ31Ƨ &]yhlbZXFoPƤ hYŒt+sW]1ъ8. <WUNxj㯻0yFhyifF׊PAr.Ϯ.<GƮj 30H:[ i$g"-@'Iȳi&޼+Q|+#1\] +ceV HD? +ثUU^C\M,Rpm23$bC˞67X9ᝫ`}G .JպG.%MγW4$ukڹhSJLK)6%sHx*ny40^d=u%̼A\>۔}gkv2>tZn8*1CҦTqgĉ R61ɱ!SxdPFj".|&TZuEGRX efn9N S`SWFn0З, $jwdd +Mۛ[jyzN' y˳~TCWF"SU!/yV^c79wabY#2[ԤI&&B^W\QlUi"܀K^>nu!otUNt͍h Ck#rއ|ry*ݵ'f<8oʠrŅ) 6شL�;`UdG({GfeNzqB/N4##5f R50ӣVZ"C頮%f|Jk7�{)+3CyPT[p LՒ@ڃ B¬„JncdhJ:2MzFL"=s.5XؤTǹ lW㙪oHE5xDl- AWVj{hx ++8(W\EP-X'R@ePv@RkdoW8�лW4 ~ PG9P7M7�{*!U + qY>uys`޴m}>3pc=o"yݴ@]FlVA O$[׾PV.OEY&K;ևByBl3 h5?jpېw~#"<PCK+ +2t:}@z +%ZH> ySD*OhlYL2Z & +rj4 +eR(g&? }iKB4i N*!|Xd +-MKO(94OaݙYPKxzQ1/Z4Zʹ0Kbh Wv|' n(?|Lpl +H* wƞg,GkEms>`z*Ԉ?U1�I +V(.?oR@9v}\r2+R +:d<w[P;O+ӟŝ#[97ATݡ(xň(~{#^йkΥe+ч2G;v)>80=4Py QW v7a"<|`ŵԒu(:S|wvoG/bg#u{ Z;(p%&Rx17h.OCJNI261Vy;F7gFSse6~ڳo + p,J tJ[kFS&VwЈ^ѵb#TڞP7S֊A[[QCakd,;Sَ�Gbo"ֽv2$OY=GQsEmdag/tmcT|U%moCⓣн�2↚aӼYcSP^E`1X/ˈaTQː Gr\J|Xj%4d⭵GZtI`p~7 +܍9 "Y^ Is0޸';l7&1 JTYk^7QTec(XX,x 61Urprۨ^->^_G8D7s~zzB )ӢHi"ҩ9IČ>1+&"AgC =IF%q.8)aeP0�U7N%U Wv| yFH7]QrT6"k�q+?8% roU_W~n+ DPyhv=b{C%$3L9גp +T~}~OfQ-*Y\mX$ǗI*Ua} *"[ӥ\cvAdq;ndlP(oM2Kc^gۆpܛuXm%Hq yƞ8ds�u *A iz0&b~?uYDv*+w,I&&.D66 Q},u7-psL +ՀK!Tj!$WnHrl*7BI 7F4tfOngS9=Azqۤ3(>)no* ͵l.6t1'T+:8m;/g2XCG^䘻')*kUM< +H ^i/v_3jꌮ0okKQOU5z% c" i]n@ߦȡT7!%9ʷ?fpV.s @6ddQwWx9~RV|Ӄg )r[ߛ8lݙ>S8!/#UQTK%V}όg"r8 +*5쑁:,k~<wT`LjDTÔ#A7gwH<jj3) *AMͶDb%@bMu<G2>"F}~W0E}Mzar.!syS=uT:LͶUj!W!ԘclX9 Q>YemxPƏR/rkW!J"sZ0eKJx.jrXP3{l`As.Vb"sR/0īCYĒ +&6K!q-@bP'}qO-;qe`DWX0q*\ic~/8PE5E d.>d6[>iEJu("G1D)*$Tދ"c!ߛby٬HЃ': > +T /'\KU1`RmM}[_4~P1/ѬTwNlxz#n[yvwuHEKuuܖd)u[ZxHa*s~dnJއsqlݻTǪh;YtQPiPJ3k+QN ᒱ%1| I;=_ķz�*bl6D;b @ov +a лgl%Ut+|"56 %78ZOJ{뾞qT+G ڇ4چ Hb˒]MDɜ~EGZ;^;xsg9Li`rvxE+JNL'yzVO=7iqPMMIb5U%̣׬qT`|:Q#L5,EQgW%ď:/f>'ڭa;If<ƅegzLJ%P'} 4q,=l$<<�\D']VuBwpwzC 'uK>-h _+"spO#ħ'4=0ct,iHKȐ'jT||&'"r/YŻIU^ +Ǽ}P6L-f70ցƷh?'xT;S+8綮mīr\�k Eߵ6 /u,Vq(gռ0_gLWP2X0WsWO4DS J 03}InrX I簆5,]HV]�p1Ѫ w)K_-.AWVP˂1&KqvEԸx'YROJlKXxb"^iؗij2hO?d{[svrKv -Ax吼%. }[�A[23!Ne1/pz>(S?\d'ϭxIxDS{QcMſ{)tonk +oYHwvG"AA fy+r =dMHW0JH21t"M*$Q@(غ@vHY&Zj'u.,7VArv1r/ѿ*j H/ԕ ?^C"EHQH[`HM\MFBs~gfgO;EPI8GxZ㸭(a !Ll9iBO<;G ؕ0˿QȯVbh8*6i9RyJV*"~%vBB5^2v}hrIq_q'z? +�H(OM/yy9 +mCa&oh+q,)h w~yG D 'h3~~:尜r"CQv{ 8V0&o͋@δo0?C{fطEm:;/~ځ;^S (RY_ GH=]$U94nD= o =9_aV¾ 9F3 0Z.E( 8p)_}[MT  +Ho<{H k.GO!5˪Ri鬰zH)ůC"1P�CJZAjNC%UD +>%OS@h)BhRO${RV'(DV{,O ?E`߮<$c\BsH28@lEJƓ +k˨4D-I,=Ǭp`_&*&=n4$`0SJ-I.+!GDhd5J_�8?mtc{G/;ap|hNGq;ܠS^&CΞY|H:˯/Xn. jX%Q][#'dfv8]Lu^ǷAav SYϿJ3靟Z;� Gr Kti?'e䵣ɣRG>t'KU(+ _B2yQ ?#k =z cܩ41 EoÝ>iP}!fHJ%ҵ׬* t'lu!bvyB/WA;~Qڍ0=aY*|BP[ՒV^՗M,D| /"/&n"߆/pBiy]YW:PZ췕e:fcqX}uiKLeۦVW  +>f-zQ$:kMB2A:0-K^hV:Elf ۇk1_e4>. ^9|Q"v7KWM(_IŎ^߈=PE&&33Fk'prK[h1MNn}يթ$Ki J4qNpĻ_:1lC+q,U c{nq4>TдՍŰCèIy5šaE0VnC/ͼgj+ՓՍr˅[hcOeAI.?k *3-/3 +pO_H'ٺ請yVӅAcDРZ'  e{:M;fЪaoƹ#j;vѓoFP jP/ n[hO!V~K;e8hT65~XZ.Nš/t[W\3ٕn.@ieW8D[xM 4~X/c3hnxG +T1];nv W�*+5@w'Q +LU{:SqAHCS61 +6#(d<$CM:jk +T/ǹc tG"06߅M:A ENj޴YM'B̀z; +#ԇl':xt3e\Yw0:=2ԯA Eƒe?zTtZգB pPX|Z `ǪT (hQ:ª-BsᇀNBN=U|P2ec f uPުnR6=�$~T9F)Sk<YWtuj#'[rx=paBg'Ó*G2ίl(>RCSkv+vl3Z9:k-o4bm>x'jITKǵ/˰-uT}7*W򭱩1 YͭR*}'wQZLY*Yc3oR&fjg_sYn:kC.ߘAS=+2vOw>Fgbng-SYM+޼fQ H/\ŝLlvILccZV/ȏDSb"-hbA?% ;e0wfyg$f%v, |&O<^Uop7*ooϙgCpzțt8jx1Z8sv̡@{n饃8=I;Vxp:%l+tPdœxݤsn?|-w9#HxNw}fj'8M ʻ�>ˡNG=s +ޡN1ԩ$c,:sJf_pK4ŵPqa +܌*ݯ/#_$^k=clQ|fl5{SΕ@#7Gi)FpUӋǹkq(gE`V59Qs_Igx DΥӸ7qxt%4^aAߠvF\C:�6:}HC~$YPBϵ NRAs\zB![[a<C3ch~eHuKeHk/�,h:"XƬ9jJSi XF,t5:RAܰN~3M%ROjzk"QZtC�4cw_#ēagȱPƦcHjx-F˗]à[ + zˊb\VN`ߢx6awsغcCʀUL5Lu;0Y|K?6uc>TLQ܉Nfio\uv0_2a{V<42UI[�3Zrb|A%R$C~. nťeeK#+ڏK,Ow¶K]|풌0J=KMGf>5sBגGM0GWO"OKjϼҪDwGEAH۔N*XH 0/TEgw)`L1qDa~ $ތ_DLdqQ*.wT^ˎALJt'S*Tp; +&ddxh. jK?:ť4)°#鼄 >|N%i0 {.q�YQֳ+[A"}~ʥ#[ ~[>fH_xkϤ؁h)} %Ď %U LDT\S] +]+S Fv|MU]Y1w%!O4y|ʫ'%,Gz%XG\�q|09IrGdհZqt츓10zl9*-)*7hV$V}YwV:l2u$(͵얁M"z|;]B=6@MoH +) Nxs_ٞ_JCP4AQsG'X sؕzM_GpXE)2ZxӃ|=,!aN.Pﴐ#.mX4ߪô,[ta{ײN.ܪˎ?ȼpYT:+Of}AʶVh{:Tx0cO~/hz^U ^y ʍNcŽ&=+Nb'#J 3V)4w\(/L.{$wL +ݳq�~1J4=|  1˨)Xy%'?O_-g$hAtFc&�-$ endstream endobj 298 0 obj <</Filter[/FlateDecode]/Length 2047>>stream +H{T�BE: +V[[ogi-Ūi+XTD:Pi[Qq MHr1)P{9m<ug\'y~HTZ ueYA!|D +/'75TuU?}0_! ް0NN Y,͐ݣgioWqJ(;#J+|1k|=yf5ϖ%c>.vMBk3/>]<p=AjS$_$yGXF`i8;9[o'|VXgYo7~KX"s{ }u73p.VûBhf/$:_e\kOVӡ8{:zyx>jln,P~Y`ee~KX"eBqsy/?a<- :Mgm~CXԯ$̝ u2bQBUsdzNN6c(x<<!\qq=Wy sx7R�bmGb5{ !bT5މB^kgb]*d y vz(ڴzw}uw-U &?fDnv4Y?QV騉"v]Zƭ޷;p%NZ[nE=kSNLޭd?蛮sX^sw!p(YJa?5rQng*We +o<$C +ȧPsV~6$n%G fw؆{!p(*,!BwLMgX挘}sΛO +z9ҍ}\zgKXW7dʻ.}w}Ph9_RͻB8ԕ5Fhs [DӮKKݸuvcGN,0?7MŽﰵ2Ⱥʻ.y ^!l5wک?vFuv]]*J5~ތdgk;C/O2oŽӝzׅ$?fD{n5G|r*(NĻBﭰMLM+f7M3teJBpز`QO@.Y\zؔn镧YWy�bh,;n,Ÿ7{!1Y#6쉫iaeʌm[GϞ:l$9}_tu=oNX?p [@L`_LM%U!3?RHɝo6e5dm=GN(P%'UrF}fD09ͽ"Oعu&JyB5l#VvմGVSwJuCy)urrpjWr+`~Юgxܚ�bc`[?zH~w?!>ADm2gUlƅJjrIf޽aa#fLz$m$Vyzcޜg\_ynuw˭I &?Hvv$fB!|%R`wdE=:$ x/D=旼3nQ:;S[^#+}(~e8;۟pk 쏁ne(KO*; !љ@It|ѩ/~N޸|'s^*kg*[X'k Y7Y?y7�bcp;k~n!ZB-}C==(?3o xgL(P~YuϝBv[@L` Nu(D1(/B!9ρnT/ָ/F6.3v/#^HH1N<wX' +uwQ &?qa oּ=w ZeD_pE:1 +s'X+󕧔ɲ%k{?O6 WA9d_W'Y2~wU &?)եE!�D endstream endobj 299 0 obj <</Filter[/FlateDecode]/Length 1487>>stream +HkLSg+jl˦,nʦλ(-N%8L$e\tb8"tB2@0"Զ@-M bF7p Fݍ]6?yY<OK=pyZ"g%j߫ߝz11N2uڥ6tٚ-y6߀7//- =t>LT[jY^x|D{`{_fOkGA}f5-OP0{C8��+ZOԲn1rBB&sy@[fCУﳯ!l/jO(ӧeSg{ ��< ;m'2s@K39 sCpjaM{/ƓNCr1t"֋xw@D +,NTgw�竈$5iLΩ7X$exZ=nEsb,?]"G?hOJ++8h͡{ ��b !jCt6uTsG5&]cbFzk>qK$9‹5[Y$f` "ù&E(X l S�� 6:hNQƽģ?Zx2;cSZZ|MVԙ MV2_kkhݺMܻYHp>o,7p��C!:j8şޛDž].~wحvxYi c44LZ9o>͠&QT(8o&(t X;YHpY[}m {��@GDSـ-#oե/UfKCجD#^Œz[w&|}o(N"R?\#$'פֿ;���c"~;:2i;*WN.1'",ywH?S4kJ2w4i{��]zܻX$HpMQ2djÿ���\m/3Ew|qR,D`qlQe ���Qip?,D`VT;Q���\Z$O_ݽ"@D +kyoYBӦ2C!?���87skbǻ{Eې˗=gxw��zv\ןݹ@D +덌]D,u`=��,X*2ݹ@D +{by9|1���pƈVzZa "}d0}��0XX)-Hݱ@D +'dk ��kMP;zw?^I%9mfe���xZDl{$Yr"xwP$sgOSJ���xZXMѬޭCK�j endstream endobj 300 0 obj <</Filter[/FlateDecode]/Length 1182>>stream +H]Lu%iƃd[,́[1ZŌ-M3"FfA�#-8<D;E]&, +&`w^v_E=ߟu?;ps>1f8n^Y`o,MC%�X&(TsFHqEh:= G;�\OwDd'wU?H0#xa#m=�B^mʨ)\ݥV -}^v��P__9}c]j%Lay,7Bgµ�rssKG Pa` +C]{7Fwq!EW��~BUǗ-_j5LaiRWKۨ-��U_&+-" ?}v6/��%Ɗ[k;Ӫ$з`&~ؗ1��55?GzJJ3A)AsEox_~��0KzIIzJ+A!E6NN'ǎ!&9s<{qCk��5WzRIzJ+A=O=lyG[c,F+W۴�њRfmѣiui.:TaY[LCs۶/{�`]C #KOiuٳ3ga0yS;�u99˵ 572kG`*mqw�zkw"f?ؓ]!K\fuin2wP��sǼzM;3NdYHȂșu4u[??d5;C��ޑsMB\ &\ WEYFKUŁ#p|{8."�u|sDeoWB\ =;Sm jpmlfD2ڜv+sZ7_fGM^ȿOfeWgsR>�?J0VL_sdrNcJFꋶl9f_x^Y}͖g=k< )�^39 慄S[yv|2y>㵻 @[�s endstream endobj 301 0 obj <</Filter[/FlateDecode]/Length 943>>stream +HKli4.`Adb!kFBmQDfh#i#䴮=oSDg- =ղc&dbYbu}|gwv{jc.Y|~P7]Q]3xAl+3sO0vn̩~#߱|]kп>�VdLl|YuBDye㷆l +E�pχ?+Jggz<4;7\_;�pH_O.n4;L([nZ[OzS]ڭ�f,-}h\= +"ouڽ�CjxJd!;Ҹ?1dikǟw �`/$I_?KG~ӛ�ח]'K2]nsik:|~�#T6n4䕯6~㋷�C:25a`?KSٕ?sGhw �`tY-q0aT~ᯫk{�?t.#-q0aե9v_M�uҍap?K[es$=]�׽H/*b;ۅ`.nVijF�Y[Sv0x̥qo[<yw9�w-sI'Vi7 C\Ɣ.25mu͝ċz�£q1҇X'n47,(On� <>F2}蛟v0t̥qp"Vn~��z#]$k`.MkKIƅ+?w�G:N.H`.-'{~ V>�OI6>0AM>6}`�>. endstream endobj 302 0 obj <</Filter[/FlateDecode]/Length 932>>stream +HoLa74-qI-ll\#b+JTB#6EiiC㒨K2:=:cVDkbѨ!a+ji~ks{O 1^kל5*l| '.Hśz1B�@l Oi_!{\sc;݁�8T/=0fz'bSvrdz]3/ WA�@ M*{"uE]?Mai؆bpmHwd~�'^~4餇VP"xAl +^ *D�KKϯ, xAl +nۻ{�roxAl +n.4wܦ7-Gojw#�?-nv^xAl +~eO7~8.O�Lȗ;_v>4^s) ./2[n= �urkw 6 E{KXΚ] �ڐi;5Gph ;u'\ޗ�DtxfG펁Ħ?c؆bM:54,M�;jH:kw 6,̗'՛�tlݜ̃ecM'ػ}y �}CFxm2NAn?MaψL -,Q�-[sNAn?MaÛ +ݿ>Xݥ�_by7kw rAl +#4^}w5} +�9)7ַRAn?Mas=<K'.u]^߫�;-ZoAn?MaCkgkw+�KK^/>V5D;{bSJ- +�gӡx}vg@FmknƝO://YF�iKy endstream endobj 303 0 obj <</Filter[/FlateDecode]/Length 1355>>stream +HOu/nfgQȶʨLr\2,0Z!D.;R /\H`RJ�t·G6Ώ{{='?ޟ` cY3a5Ͱ %UYL C1^so}U}k�?}SgOs +()0bg[��zXk]�^sBs%a| +��!F/^~ QR?`/S0ݭ 徻��ݞmQ^U6�?DI3"DYkCb�#_agQ/s()p"ݚ.r`�EX�()J8ދw�`9քRRsDI�W3"Diknngc�zAG=} @>?9a,ݰ5U$~Y?`106ܮ�zvvz` rMvtH9TY;U/', <+L��J6KZ ,/A~?9Fj5K + {?aMika��JDJ=[dN|'D)jl7u[a%L6Ֆs74�PXƩgo; clum?6>..KM?9ѩn᜜zy4n1: ��Jrwa׭GU]1=f(^tPvv6=Qhc,+|i>9έSqk��%pCT o_-s8KGAjڊG,Oun|}]p׊wj%m��OF=J}Zv-p<l*m)78֭U>c5O/]yz9GNc8}�<ٟ:-*wa ;Vx/w>tF;Cwi69ebo}Gœ%}Vy7TLwkB7�'g<h8A~s"48~߽#/|nn$Upgψl :Uݟ�<ɕl!z-Җԧܝ>a rKHSG]0@5wUy{|}E06V;�<p~zs` r̞>NUqѦ]I*cUE]ud&|z|X zwfbo:�'Jތ>Y?<7 +0�+ endstream endobj 304 0 obj <</Filter[/FlateDecode]/Length 995>>stream +HkTg:CJQ7P(*bԤEw&"PR11d3"G0&M#!E`{4gɼngr6|_ߎEb׮^oVqz}iIѾ}d 2�xxȸ hw7 +irFHXTWazRѡxd.;�EҏCIKMFalm}~3zE�s둦ғҗڝ 6/#;D?�sӾK?훴Al +^(hJ"{`.[g7BaIFbW܌G'S]c}�$=x?p ۋK(lbSRRy;xL�>h<.}XyDQĦ? +ySkɵ_I#ڝ ;?Make|*{;�@> #w>"}ɰrG3{��!ӘL{\OzPa)ʶۚy3zE&�|x=tZzok[mv.bSȥ}ذP.�\;:Q{a)RIML.�Bo̠{r.}AzO{a) ̍X:Կ�KkxhBzNNsa')Ö\'6r[�bXliw- 6|֏�«勥jw, 6|))3kw�fCzL,ko ?Ma 4l5Dt<.�>W:|$}&ݭTubS2'.i�)˜,=VRT|Ħ?6кZw+Wh�1j[Wiw)>bSP\&6gd{{'� endstream endobj 305 0 obj <</Filter[/FlateDecode]/Length 1000>>stream +HkuOnvnb"XdP"x+ uG] ss:rz1'ȜSDpeuΙ;;{ζFl3!_8ڦԥ4ayV|/xϋ}1t<3ƛ2m"3jX煹w颷 !~cyDCNbdJ�gqkr/E?Ma@;;>4]7{#�LGl&vd 6mm:ɱM7�LgLsZzjUS,D0?Ma >=gɋj�0䅍eO5ݕ.)xE8Z{H-׾7�@,ɗ^ +'[iw$Al +^J{H_M'~Tw�6A'9z7~Hd5&ut'`r:օԻ`,]R{H Xw;bSȻ|x~- X !.`Wm?~pͿB �0ސq}bWo*6=m_NrV˫w �vhiδ5Uw 0-%&r#�v2Fz&%<Al +^xg9y'k\N`L̻ w0)AylIԒ+� }/:?Ma/*[W*rq?MaObN\}�G֗Jl_m?MaOLJI{ �z#Tkv 6S]lZzڛrv|4p_ƢotxK}v/Al +~4w +mqgI{=yHo=2E?Ma +B3u~Iտk�xFg �9 endstream endobj 306 0 obj <</Filter[/FlateDecode]/Length 1605>>stream +HkLSwT.bPi@t&jQx[$ +b%Nĉ"bh==26nqQu*?,jLy_b}C-oM<$ !s`2='lm;$*W�<ͱ1/ho]�ϊ4nC$s)�s}{g<DIA�%XQ--m҆͞� ~o,k@{x^Jt"o<}_7BbynJY]8>zS{�.>佛� QR?@IB<x[t<p/�>W߶<X<޻ ?%&,}+uKb_Œw�=w@@@5oO{ ǎEj4TUe'oPQ[C|_V�?kbT44x"b(ZQo HXt$^vsD/fIJ +JSxE�[44ZgH{ $$W0*6 6p?@e-fZo � +E[if.{�..Z]{z.R :I[o~'S6F;&ќӼ9�b6lTɟvYS'cDZmUnIlNs0t)r6E%�dMتshy�_A@5eyqW|v2oP  /c,u_s�hiN% Vh[BeUkغ%%qA,|Adsz}o �/135kwtA{䧧GԋÇw^֊rMxBfrJft +6+y(�x6WKsL{�5}a}1"$3ߛO<x Lq("}]qmeѓsx/Lٹ:7=�}CJs+84Ǽw /&;  %KN#fbt=Ix?Y,G2=W@.d'?@PoFwz^;h~s0Zf W<6l�tT _�7$yjuosSRwlJ>;^OO9fgv5dni; �:Ѽ�< %c֊rMt*6; UA=0g_~G9]7v+�xA@ió%Z<7fikw%#=uX).p^2qԡoKP_'4m.2Ͷ/ejL,ύu JQPr]x-4ËJklM#bϤ~uŗk+ v]&[pߓ6nR� endstream endobj 307 0 obj <</Filter[/FlateDecode]/Length 2689>>stream +HkPTǏhqĈҩI- (FTXnKX$0 W]n^={9P`Ԙ6ڨA~iuتyf~Þw<@j͋ԠIw`ϯ̋f&A,WýYFa`xz9 z2u\=1acF֋u[[ݶ"C><ozU{I}\n%1wTstcBǼLM]H?)c,+X) w'?lZ^O<D]$6&{Sˌl ~;*/�A!  >GbOY mٚ-P0axգ$mKD }利=<ogmB}FV2Z omeSsS6|>lh}Z1;9z]u^TfpE 0jSY*m? +: A{7t-=J0 � >+G.hx5E`< s7CUhoZ%%}6jͻ<4�X1i_T$=�g߶U>xc,/7Iߕ̼MT]wG5>t= S_^ I.S@M|=jqAǑ_Ķ,PՌ0OH0ӹ-fyCuZn^XWwû ҄^Fwe^5^4ZU +??դφ>1MyJOgVR<|J AORbAoe4;�A | +W UYjqǺގUuB<WR-͊|b<̪>FwCl +y906I& ;Yk0g?r4F۳3YĢleHߕ|[ʧ%FuB| |t?ђHi#O#4kk<U -?1^#RYMj"}s,7/Z Y[ĪlS_r t ϙp Uu w$ցNV}D^C�zT%T]KZ⮠SxfE>nfzs!6Jܼzc[M檱tV,}^ʦ96Z?W<_(=H+b?|sk] A< t'+#qqg`),C,>aKbocJlCuZnԓ0ƺ[ M�m_5?s�nVY:*}ߑ|fOo5w~cK~CO3dV\=},%FweCQUuB=WR}NRDZ<m5AnyL_k]; yF +HtC#8JIs?| @2EfV:@p8^ j߈?]Pij3OYM`ölM<Îэ a 9/ۖ©&ʑl12#U,AöYT?]ov̅h]tg`w?<XG+ %~7N%D7h\6x= ·/P舴S@pX~`:uڽ-Kb|lz1[9Īl&~P߸ -y>IUOk"u�<W,cd6o؞l/Qbh9-<>H]H.rϰoFJsq(/"cK|_-x%탑S7S}*#!JnnJCp^@7FOUPUkf˹5x<999h/<KD0 =&/}FETdBx?te }6NVӜV:<KU+aU0w >?Z, w'5V fdʩ۹/ +zp.3]|  ItCZiS I +r4@GW%==qhSlA/5  >b|S&E>!,=.s(x2?0?d*K&{Z?!Ё٢s8΋6A@ 뢭UBIׁjs6nrWjUӠҚD>OA&9TQz4];ׄ2hwQԽ34{8ZDOA&oz*Q^0臇̊_$d {b{rCOA&4& yEu"L4׎D>aU$9#?0?mXmLs"ge,`ϓ^Xkct7HYk-~v>1)jGH.>'TF?P\b;A8p\sNZkW<W�S< endstream endobj 308 0 obj <</Filter[/FlateDecode]/Length 14679>>stream +HWB}<@ \WHjE8b)T"f&d&d&⟩EY^wO8V6ZͳlP<ok!'Z]~~QZXWJPK\^=Urϱ3\gk^JWsЊ*.szɒufKpK>x1e} `%j=z/TG=,JS6v7Ɂ \2vfZnU0'k/o$[o*?;T?�  TM12qꠖ季dvr/=QE*U?SFU$ß W*р>{Ϛ^ L U&i=dK|B"Ƴ*{{Z7> 2f9C7M Q{2d0ɼ�Z-{ LTm1&7 ꏃGOP$'NY`Fi3ia�Ouy nO=n6,<Qiytې %{ lC.D|`oC[]wmC[ ߆(xކ|cqD! ]89v!> J΍.SL8%!SiD;?Iȱ(F3e7 m{Z:cBrת$2/$X1t P}S^<cs13郵TdKŤ{z:->H9;z3X*5׉-ƨ,~k]V]f V|g߻㈛IYͨ4d't;B͞rJ#end>|齹^f .Noi(5zl? +ER-|@৭P1.S,EqAc͟0uZ=|]#X_xdobX+`,g{x۝c IMc'2i_(0f225nݻ-N~1*4kW"֯Xb?gh&JvC}"Y=\2Hpe}őQFQSR},k)ak$:xF'F%J^dmFLIt2;eit+!-.Er�d"QJUw7߁Xcs|ei)&k }R^m/~Rx;T&P)u+[7h޻nxMm#+. .uˁSBq5) AZ,W4llE# p]%u$ θ,g{jWX}Ǣ(X=[ X-F<Y2 $ӎܻ._ē+g=kbM�ؤgl5Mhm ~C&b;$ +5 5\4F!2EA-ct NÛoh?4[\gb d}ÜʥQ';wT6J`^InejS qK 1-ab; i͆2/ S~c3wsmș<k:z+Yg)|Ys3f,ˋ]rg[_V*]8z,Uy:LJfzCn;ʉ6Sv] \|UD)YdUwmx$n5% JB^ S0%n1өe.PǬ<عqG+TG=~$Y;,?hB'`^7pgڪ̻3E=kiO2fSѴx7qRI6~3NS}�bqXI{/>cOGcH-f!@d6[ +MsŒ4KG:XGA۳1I`:xD+g@yёeݩ#JC 和W't9 tudG\eHH͏c碌csaNJR߃e`(y@4QMf-SQ%9U's-A8R' ^/herQ=|X\z6c8t1# (((D\ΆB-gFK)FŻ~o wT1#*RP)Mj 1])^,1*/DK"掴ӒNt睘*p 7pޝ y綑i\~hܵŲ5ǜr:T# ɎvtCe�.~\OPZYq Ȯ1/9C]|0^۱/+ɦn/UijVTbXz\`/-)SHxE .:3֪g[ .sj9ǡO&Stb(pYd';1#G5a/䓵UKKHo$90vKl0|dtend[lAۤzQq3K4|?(< +JˠabrHSoZL:iE_Œ,x?RE-Q}-ߙ`ePBPP=)ɟ N:7C8O*˹w"BP# )v=emhWICG!$$ GAhh5dLAV!�i(0ǘ4lDiQ0EFk>4Ó}\W (Y-打F>k?W1;OJ]a/CMN#cV#Ü0|uK,<{\ls6 9@[�G.wQ1a E琏" X .Qb8eÛ>n<T |PJ{W{.Yn1fF)& i4I²1J[d*;έd$c!LK*A978 2VJrl7+a 3Vn{qWZfw%5PFƃ dt!tÊ'K3aXSuaICVi'<aH0B?UD@&@Tp$Ȣˀ\ry۝?X˩S9Wx;$X=sm3dv]?c) +X4L6 [S⒇[K.j35k!/^`uʮ k=fqϮZU.Ӹ!6~9TzYK̯T{}xӸVgśV^eI`z鬣"]=Y5 +$=PTlVӽtr,\@GUxOy./Ӄy"z�BӰ>pfԬ(E/>N<ǘә,Kj]J-viQ& pa08N7i8;-\Gf)Fv�>=ys%鳸\�qYf שyxN)8tq5;. .ɘ(ح6}^¨#dY٫Sd J7zKRx'`V.}W{R 5Qc"ǖ<.Tߓ?B!C ۅUvu6hۜRqSkS!q*,88){Jg>+(R~'%CQUw<&0-�qC +j@af8\L~J NqGxĩ-쿈^*_Shf[X<ƹ`Ӽ n 34.ak;�z@ +ӷRKjԪjvrKDE@IcT˿VKU{\c>F[6* 6,BN=?</5ͼ/P)H>\l#?'RcS?rr>YӧpWL/JF`4J$l� 1R-X+GKJ!}$ 땔 7}{ؘ16_}_6,qc(:`M,m1FPaBш4JI@1ay:3| ~.[\t#ͰNƼ`(u<1߃E<.?0E̒yNj>l pT4 +ĝ=Ysj&D�'sQ`�^I +t7՘�ƒ>g-f66vGD߳`y>?o+mיPOΕd7ǎg 5⫲}6H8^08к \@B@"e@ssȹN^Iy/{\ ;~aQ`%&xQtM 1J Jd-`-PH E$J +jMSv0}DpQUm(9^{upɹ+A ݕϽ<αu'ڼ,r-b0j[=jk- H9@Zr9Ym9nqP.I(e-ye90rAt;)ll ) +Cs7%lC Sv$e$<l~3ToU"JjVM灒ּhӢlM$`Z9.ڟC7T\M] yn{kW~cpmo !49K_x˅U[읛s(*ZwyWa~ZX@LBSdVJLFބƲX{lp sxl . L;;Oi<a]H.Iz#*;$˔c1RjVj淥SZz`/3Y!0Xq4ị Jf]CCD'fFzą9܏'~Dv%6ҽ$Mu6"sAcg)2 .',+ߞ|EJ_/3+Rv5n-Y^"Z>dk ! EE"U.~h =9<Cm4 ;hå9R1 zv!kA;!BBw'zekʺ+mcvZ�Δ:>9jWJ12Jo8Ǝ�>]9 X>r|l} SY|XV/|7Sv2?UV4^|,;=]8J2٫ HvX+|o +>Df{a)Ŗ1dk q1(AVKbe�x,r~I:ܺ{2XAc) +o*K1iZ|4zw%+ML]9Et0L3' a=r  BnZ}(M�ǀx=>LR!Ÿݾ㪪Tp 3]w7]* ýjq5Y`l-0փ;"Xu!w +9ds_:>hojinHϭPQM^ߔd2zg/F,T k4'G>t +{r8Eݰ!Z +zA5+R{d3f*|tT Y=ra?q:q\25kH\4xÝőS hp 9ɲCy:NX4�?⹒NS4O{E)ZhLL#{85"ESJg9 EV^}b\N.w|vN F_֗M!._r3g=I~ XL_Z a/r2<&$gq'd!o^`Af*vyd7TJӷ6zޠ5gHAWTPdHAKP{PZ[邐:nH(įĉ삥5 uGpZT^ LL[ B)$Ob ;`#u7c^A'9'P+g�fe3ӕ6$Lrc(B/(]i-&4vbgW^L}"@Hh)PPiJ|F! ev̙3YE MQІ~lhÆI͐5#Pɮ^ZNWW  f-l@;T0=M0D++0,?Z1Ŕ3 A&L*dZԴTICJٰ1V I($W7Kl} XO, .#L|ǴHElߋŵiULnyt=j̦@T,6nS6 "߹hn3P@RpKF b&L3\ոɥB蔞<)61gɟ [Lǽ)nYvғn2UC ,kYLZiԡX8;,<?U x`bIx0 > m+$^yx8u jt�F?oaLՄUeǁ>Ҫ&Laa1�Mi{YYs0e1u >Rt ^oOK@eØ<fcvi&Md2Ϊty5E9u(Gj%y;qav>G̠ܵ@$ʀw Kp]<&P<d%#mT!>4w9aȩ)B%8%=dNN )NN)ӶyeܯrJڃ\4HCwlW< `sZY&d UR KDZЯ%4]|Y*#{T!9*97w/@&[5Ap\9"6C*^ymB0I1, �L@(Kb*.$;FwY7zJ +Iv!ߋ,uc8.m_G +IegeC5f +,]*[ +9N +H}kwj3p.N>4HՐR!0iFbKv`7똴%HE;wЕcNq&9)SfRf +57fѭeq4v<N1z?15]ZԘ>RCȊ<i:Ίϳ7V [ۙMx 33KM +MFsϰA:vM *uS{ƒ2f)~#'(FBhv%ka^u)b!]zĻkWvr@M�"\a f뼞I<W@^Eډ ElGN*z֐7 6L+tc=(y ^k{.pnC 6=y S҄.; mj]م<-V`,v~}F米ަۆi*�cc\PP$*3>D1m<Ǧtw6`j.Ops);Slwǐt&o+\vVPbO–N~66W<<jQ|rln8%%-=/ylø ) UNific L16B9:l[F` %TF0AR5 +MGbP,Xlw%́;bB߽ќw5!TgJSW^NJ`}u?{/1#aXb\. + N +0�%FpcGD"3"d kSXڃ1O&QCS3 bb + 3iqe"\<Yzq n&c:ױJpwNM+vV<V.,դ�^qfmHiGѦ ɬt`8a7mn%J;.n:%&ط:)ljo_a)r͡&^sU-t6p#/RL:`̖HؑzӲOm=tN?NS~^V<_lm;}O<穠@i}T(zYdg]u &Z 6@jYo NL:$CowO]5=ۥf6 m2܍ް'FheR`@φCT}|zn3okrZye(mZ ; }EX)KzJ-ځs7޲P"\4j�!Clg�q[vI.XRY-BkB{4h\,|dCW v7fRT^l9?xߨfOftA\ _ W-bZJm>=۟`O`,xsEie&fS iW1 r ^D +N} (0F[pĨVj%qw ָh9Ft^c&m2#GsH*7ey&jx0 n|%Ͻ4֗*0a@+[v/#yy vuXEv苯[C ]hvWA"|eQD5V ^B_?�,@9Pn�{<FfH`H4 +`8vaL�x^^0p\(m6D+.Yȳ& 7.3b@-PD8vz^q@403Jm"Xgak=^L=6 +yP,u8UF׼i!o`,\0<K OCH :HK�) +"T{_̙s<S0{4mz,-ѹ~n 3bLZ@5;AұN3/^i݄oBxp +Ú;jHQ<ׯ1QZm}a1 +I7̦ џc!)aʵrҸRSY7e`N!RG;Lku1~ąӹçYK5%k<$bo7=TL4Z`�c[#e6>z5 hϩ^| **Qc{e쥷Vٷ$+'V<ςō'(8̇pZ<Ip ޸Q.cxbpjdh D NbCM|=M˶1cXx;xEX)sFG@EGD%Ֆ1a g‡|oϲ0vMKNO/L8P}1!Y\wT%DOpy.{*4 z:d*g dέe!v='3F/kW_ګ_eQ--ADx.> zdQ6OTVu-֪ 6FX,!/ot?MbdplhR$qs6%#ۺt;&shPZDa Egbw_a{7'?u8+-sp ?q[ƞKb"l&lL~-ׄwNx V[<]T%O& @SfR˫h\<*:"CbK ~ +8oZ욠zNPCcH"2,k[7r5PW|K= ~;Ege +du,xN4+$B"` +pi0@ SzVrp~ 11|W3tkx: ,k~82@ fg1!xl ^|KnAp{B=FA~t%;Ԋ^Q{x:>PyL:x`vb{eؿD& "o?bcW c.)o˜k6 U1`s^.y1}e3d7#+uaK�_cBL%/<Gi,ͱ/96_7!vK?1u;51~O0f{)ԧ/&{$l︋4 uz XNξWu6ygPs>@,?F[(o{:ȣHu͇ts#_01;Rh]}CI6?1NWS[PtX ճ~HEcPj"Fy{ETE:UM.y%n6C e~R84b%Z)TP_>a#$4,$ ?}Hh%na@?e<WXr«0ȷ ZkOqQo]*y-pZVȌ-G˾NxțEO=q +%o;; -jvEx4\Q+?b&"FfFhI=daNs\.``TeQ- ^rz(& #y@W\??ט/j4m<8$U <\UwJw` +_ӈNp͝fa;;cM:292~ +,u!'Tx XQHRtw)GoIM*�y=d#Vܼа>| 1 {ۃe�?5UL +?-hP/= g(ER+>:4bk:7�b=H' Y +QG;|˛yfXwn@?_xjdu nɥt`6jL-ܼ[S4'jR*|UZhh _d|S(bG<Y-;: Ƣ!-b` +{sjD +U9l*89lxr;�eGNK 7?q/xښ.MHWhL %VdkGTZ +4 Cr[8yАDE1�Q I k= V ;9> v]A%'J\bJ=Po�r?4&DY!6BҢHwʳ۹(\C9i0ER;$09c}?ܜ䥽89MOضֱ&DaO:R!jR'& Lrbzy㘋F@9*y2<ێ_r(c +Lp}MF}-B 42ݞŒD=Ԁ 6=xp^ iB߽%Ѻ&Y^[3K x @@D( $ +"Z}[=d�OϺߟk*F~#M � +[2YPd:RЧFO5ET%#ECђ1_(7(t[hV qCq2pX QGnP F�E??5\՝2[-Ee]S|ۋzVvȥ~ef.-�G'y<u s_ȂʕAoN +=B*kԓqM;8y3T0rM.XA S 4}"D<vb +Tsi9w8)< v0E?%%.�S3m< AEPJ.ǣ1?Aˌgvt�1dX2_[pEԛSV0r.0_ːIU_vv=`;pSj6 \/?_ x\~+c .W Sx%\_ :qs�_{xI !qvzVL? + +=\?#e] m�h[G{{mG^4XDs㩫ȕ2@jrc#l|5p*y)%-滛_\_Y \dLXxp[8`$SXRc!A=OETɈ> ẄܹC-<|,YM} +3hxcE y}D +{S0̐W姁6krM>SK@3�-08OD``(Ӏ ~.)Fˀ71?ydjBRj2ΝR +ȤC�4F 4AɆ�qŸXڲْ!S@mKBxog͐OzeoإM{M.Tx>+6˸'~0MeYF*kI߻=qb#n:d! +ϱ:έn&|?0^ڠaz7<M¤f8eՍڛΓ}KW4 VЫ>Re՛xۃy}t �sY4f1Vh&A'k Eg�%4NSL]D^B2>##ժRvU% {; @V0MhJKݵT!N8Z5|G+R ORV101!XȔn/ƄKfa* n!RE[A?T=p'Jd5٪=xag(QUG& e/ ƦL > ([fʒTlqdzᣆbÙh![#�z p`&eA1I #vS*&tF +9:yo'bGjmc2Y].)WVj^fmIrׅr9g|nyTSTK*(yZ$2vIΞaגeˈi5Õv"zµXwt%.Gm ^իeV!i-%Fm# 6?kinJ~W֤n !Yq41|2% ĹqyMCV}w Y& O-1gD +1� ;җ8L|XrV<e# 7-@IY +g %& B..:ɽ)ʲ˝}2qLZp̔)qlC{>ϙL!8ٿ9w6 +C^ {eO �1g�~Ř֭پP �|;B^qh& fC"�^; +�5a~@ <X&׫MG.]ŀH"\Kb~Qgܺ鑯įqgm<M3J*&U̙ .krG=Q^iTM:-IWV&2B[dfej2#'iWh@鋮Dj8zC.aV*Q}ҳ,~0- g?P NxyŲȊhƊZ呶kC4M1gc7Aw8 |."v crp2E0gA}aYaI߻�t!`XuL~7`Jg okZxxJfV5+MnN(s`=(�/7$]=�QCH^k,@Ƥ:B/mLӂ<";$7[|WX(Rd(1 {KE3U1=bp,/j"*<-jR2e~^l@Sm!* M@VG`.dB4AŒy.SJg5۷zҪ+–c`׺RYT 닩<eWv~9T ړeW]x6gbĞ8LQ);m8 "=(]>~JA9tAtO]}5vE23KX8[>D6b 2%#\w(<(ʥnLZj[4J/6BhRM4wwYe ҿ,f9ggPSW68o#ub Ki.j>@dlB[͟itoRuw4)8hn/8Q AUa;%K}T  Qe}9] Շ(J1!1_ C9W?j F5B@[*P/Q6@\0.P=o!X b 1#VBBZg(k@Q�A`T=!- dPBj_"37BկgM]$K)5D2hQ!\iՒ3j)ԗ/э`1P5`m@†�2fЎ�! ~aG:,S-7xN<jS p Ŭ9p4vCN'vrhu<Wl2X(4F_݀�] e!:>C|8>K;JOT*;OQ%=Г2�$m~ endstream endobj 309 0 obj <</Filter[/FlateDecode]/Length 3486>>stream +HkPTǏA[ǘ::hcDcb@kTZX qAeYn+ hHƉ&1Z%^/N[sg]g?v04h cN4xvRWrq ٚRN{joX8~5;?+3b5{_]$bdlS2g NEtС:zF]ONY%gѠ/G`2m#ߤ?'Ĥu2&_~'-u98zfcQ>aEeThY{XDG`B/hsmoA#̀w")JzOIE5L3 u[ҷKTTE?hS"d҈y{ul$v~ԍ7Hѕ/V,mmDs>WG5SunrơUOTy1XF.cĖ Ǽi@sm`ΖF#[ɺ7eoO<~zk'lfэ= z`+#J^.-1-ʓmpF792mp|\c,UV"-OtolIbJ860qiZɭw}p*WQƴP`O_RQ %c)uQQ&QOZ�PɒtS?ڝ]ꃿA_c{&}5AnIa;c_Bʴ k:PE]fW +e ;K^)k +u<` Aj%yYͲ_Y]Y6cdֆep-us +^ksӱ]C nrc2Na8|;™ث?rca!ۂomYEI Km}x7g}kO +.߿ƅ6H5x}..ru� h ! <k.QDi]Nx)+&w}Z[lmsSSV3\6AlɚLJ^9Іχ/n'x }E0qO4 NxjFښA-pcZgZ s +u܄<grVN^޳߲_xn8JG|$α%uI%Դ1 wb곓;TT sKY{C/Փ33 x`a~vf@>TF<UBMO DžVU, չ|{Bb㴓m|.X܈xa߇k-u%~Yqh{î谑<3ʹЁ=5TsCcϩvL6xla^9kOjEfOdWN?q, +R^ݱ-:D=.TT]?hS*d+Bv X4K<FGd5c/K3:<i@c Ï +A$KF"`ny0 <i\&'L|ω-bVN;�zWCT9<((Pm,֪uGvaNNIaiqo,k}Rן/h>\6˻)̛TG C9yY%TTT?hW&0yDQ_y8a=()#w +s W ++R'[뷣}mδ;ȅ cu'^ýt+P+</~R3 c<"GV=x;anzZvuXkT4[<ƩS<W{*NtԾu$:.PQQqrF& ƚ:GEu5 ,(ע踍\W+ǛM?QPxJh7k11i?Ѹ'ڝμܮ)|MK +cԹmN*?kB}Poosu'uSQQ m<];mNԔsV3 #Frq+{-7xY3x5qNE<(D59e[[No7v7ܴPk$iސ|Q?|FÙ˔XCB}PoR<ՃAßcsmхyуUϝb-7᧓tf:YBX'Ot;%2 U+\vec-J^y⛊f7T9:!_.(C6zڣmX|Ś/a?HJ7/kS[,\<Zs[Qq?ݨ5La{}\wFj zzumn@/kz*bQ_R8ТAß#(i9㱑o3!gQO#pcX'k,ep3wzc9-B{mRdMqhN;_6!Mq +@!KtX.`\M͗K +I:ߦ۞-Y3rlaYNBNul(QTߞ}9?gWn}m/I~, ު0غ=Gg@F>i[y Vτ'%3:s o%KIZl\΢gUL#kpEѹ78 )E,A'љ&KM]Es4iy%i?|`oIg%v7T-MM*ׅ_=8!~% %Z^\#7BHt !TR#sHO<A5uԥG3mF|apu&s.<fRP 9A^%*S#l)7⋟o'Bւlȓr4-/#g^"�y@.]O]Be(zg_|cW\CH*WKuήc~y&Ky ~&}_!r|(!d?Xj\BȶڣRð}s9r?isA~G<$!$u,5uTjri)o<1r^L֟ +IBw6J$Ai(n˱ ;R| ^tϋIꠏ'̹f 9BC`_�K> endstream endobj 310 0 obj <</Filter[/FlateDecode]/Length 1764>>stream +HkLSg_`∗MKDe(^6tSǦs. 6שPÂ`rhiBE'U(8`_q8%C~1Kt(Ge3vo/_KhOO>OٶV,F{=i5B{v#)E/ +}9a^7CԨɯ57gM�w>k[‘Pa[o4׿~ޛuq;;~5>7S}OAG^H @%.gB곢[/V:j:oB|_w΅LP_7{Bh=?#s;>=(ů{blscC}~g 8Bc-J-ESW/ +=.VQ03Huy.O}H c/@>KYtYzꤪ/Q@g&MuSx BXc2Dߪ*u3,=LS\xJ}M'Tg'H,^BhN2LQ]>?r,ՏHR}To;CmK`-ΙK٠rm.H1cU~-->*[5? CqjB(?)+UgQÅů[ړ ՉEuQTW/CmW`-<%K٨A#"]^y<$k㙻VMũZzQgHFyC7}]??ۂT)T&թAzhT;mϐs8>#�X^8J>\]Y}联}/US*x=MpP,JտDQ5gio׽S)`Miu!>գNT]M%P^gh]cp8}F�<?tcZEIEp{זw؇BJQg =O\y|⺥y]*"!Cmɪ}~iߴՃH}#/z"�[R<&;v83T'(}/3זzYeSqXS^jߢ9u5C>jo_f%i}]YكnZ?c0chy\hgC</7!,,ua.tl7Ld/:WdnM#~_[w[^.K<(%N3 =~)B VgmИ+Qa#/:t=.]AueJֿ4-CB!z GyX8g.!?m14رÙ:Afn]t%gʠZ~J{ =~]G>ЖU>!CE<UKOg['*}Σs=Z$˻fggYY�sL=m_2Mη?MLi +j%9ֵl8B!4`-,QL/ +=O]q3LfM!BmLh^ �ka):AyS"HW:g k-������`ǤČvֱe`j&\tPUǭZ햾m\i�������;2~S? eqPёS"l���������������������^8 0�}Er endstream endobj 311 0 obj <</Filter[/FlateDecode]/Length 2249>>stream +HSM""*D+Pu@'(܉_ +h 1 SC<Q΀B!BMPzt:U^Cq"qɳüa 8V+vuZzw (P`JK#,Vtl_x}E+EshfyJ}5[gϜ![ZϚW9O_tu% "cu]3`2؅ZMZ*vnvꋌ%%anvuꤿmHHdo\oΛm󚵌2I_Z_d BW{y׃ndzs8W4Dϝ'sfðUsַi޲<yeQQ]np~+R5T+ڟU>EO:: c@8.N:r6ӎ~ػP4뉴H\˄3鋞NmӉe_~aᨻ ?Ϟ=BG!c+9:r,ѦXIGu;S#86'dxz +1 瓄uwۓ1?~Iϖ,dkk:ڐhgYػj/ﲶ4n\WIGaB1FHZz&Qߞ~|Etpfy5ʢiyT ohnכNf0z:MxFtjp>񌌽G5㕋0iA{4U8 ,OZ.~d?(K !c-?m)4WF26cX0M&?"ITon0]_-BG!@.ga,&r>S9 OCoػ6UO{i!!Q:;}{Z+{:.*%G1d3ylkՔ퀌;֖Rire8JrpLG{NUJ=e$GL 2-fBjQW Cޣ,7O~jGhP,?)둍IN7a獏\7Zx[W%+{ +3N* + om , c%&!_ڮ)kc\0=&?>L؞KlnE+ِ[U6dFEm)b}iv5W__9'd2TsgN KZPڸx5[vqpa, s1^}\*m_;cў{;jU@=EL06ڎEsNG{#cPYi$uu ;o|tPs@| =(mߖ"kR1,&abقOhkZM]7J�vWFyFE2N%98:,Y rs1dwn9$(mHHNjk6aԪr%|Jt̃n}cUҜ?;M#0QAuwI]-ͥ!LB&cm-C6A|Zŋسm^]?sԟ=h|<z2cS72mtйָ=h zQ{[{;MGIºll=yؿ$�ҁ[36^WܹWAƞ+<$ĩc=75i\.!cnt;f[Xb_*gesT[樂�&c̙Nm ,z,G2_SgPʕ_QA=4<lB}}]&=5_ |7>;8_\<]]Gñ}Pq.r56߽I/dLbmi.xD8?h3t)?臌uUoWnl[R2&Ԛ/Ȫ"ά'LUsԐ_U\z<;z2!g4WcG!c%raw~f:-e`lsxW܈~˕1LX +ljkq0t6(_EƞΏ鸰.)sƦT\ttH7$$[U^|7} +Fo㳼C +lU#4y_Dwꋌ���������������������������������������������& �>\ endstream endobj 312 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 313 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 314 0 obj <</Filter[/FlateDecode]/Length 456>>stream +Hj0�DAO7䡲yk*B �������������/gKGL}D8= g1`sadg9/}drcÔc/>crdc/dx.^NJ]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR}0Kj@4`bYM+fصbf]+fصbf]+fصbf]+fصԤыNLd,ŒfF'^vZf)v얹bYge_Ů3TZ13MŮ2 '>2_u~b)fصbf]+fصbf]+f)Ե[Pf:]te6`�<q endstream endobj 315 0 obj <</Filter[/FlateDecode]/Length 606>>stream +Hj1EO+4S כ΅-4Ƙ=_;?*SZ}dZ#S/f֠AO>2Zy5ጎL9:"25rtDdj:4su<fix񘥙1KhѠACCgGΎ mcQ;SwǢvELڙ;͌ ;<63vx$lfH<2wyne8qp+(Qӣ#GG61ȍc 7&oAnLؐG@'FN8='Y@VY_ YqmpBVEu\zpCf[ǩ i}}_:{Y]pȪN_AwdQvWwdUtW7K܁EY}tqIDWuI_EUg>D8%k:N}|pKVd7u}dA;%u>k:}9o߇wO۪'(sU᝔nDt}xGeR>2n%]z]c.L[Dy^^k~>:}`�2 endstream endobj 316 0 obj <</Filter[/FlateDecode]/Length 815>>stream +H r@ CQҚ8IŕŖ +t6gx_exc9=J�"z߇p#!D>0dPG r1qr51qse4qs3q�s +ŧ:t'AHh~1PRP/TR/Ko ?]9~hd;lٕ;qap{G;4!~;ݲdClcCZ5pw45NƭNg�]hղu ,;;vEs5~ofEa ;^_Ɉk#_л+Yp9wj{kW{)oㆼWnZMFʏ{9oوeack:)}l-AļE,̎Y>Z>-�@y{S\7�Vz1a+yxpK&MRvkrgRvrRvKsGҁtsǍt}-G _6ܡrvo-'uqgWN¹u䎿uS@CAav֘fm9w$,&"Vm ]GQnduYF.eiYɊ.fYYքfIajg9aqjVh)iYJii9J֓] +2T '-�n)/<`KKNH,c;\./Gswļn:a <%^#2)ŧְ"SR|zܹ・BH~=p7Z$4C'�o endstream endobj 317 0 obj <</Filter[/FlateDecode]/Length 806>>stream +H˒0 CO{Sj?&>yPfrζ=fZKvDTU;Iޣ?o}dng/lYGniGwn i۟on nm/Wۭc]ͫ_2 )v6iNIsۨW=ЩOόPA|Vᰃ8SƣcD(޹-~bwqp^&o}U,K]Z}PM,8:{Zlc7`ɸj5KGOeKQ+0 p)s_q6zpә}=P`R3OW4LmeJ҂͹ ylL,zl*v*%e9D=X3"3c" 1*#k(#ztUhM$aqBYFD|eFZdJ6l B7dm6 ^s>q6x]6I]\Ca'7bcb{ޗ+uĦNNFfs R蹇хY)¬zataV +=00+{]B=.JFfs R蹇хY)¬zataV +=00+{]B=.JFfs R蹇хY)¬zataV +=00+{]BϽoR0+]}UR0+}UR0+}uR/}~F@h0:S_fj38I ao=V'� endstream endobj 318 0 obj <</Filter[/FlateDecode]/Length 602>>stream +H;jQPmp^9uv)􂾮+y׭T?})=XT,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~\a?s;]+6lGW҃EW*`cEMTr?s;ʯ[ľgn^Pw« +\P\?!۩Za?s+2hA:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT^��X endstream endobj 319 0 obj <</Filter[/FlateDecode]/Length 1563>>stream +H[WF>w|F2I ALQox^0HDDQ!wOs=3ɞ=YQٙ]5tCIRn'CA)]T* Yi/02Sd4j !e7!H+ @R^0J8}}Ч_0aeX'rBSAۿ6+e\愪?,g)?BDoBI,ƿAhU1/al#ŊG->Rz ꥓LNbVfϴ>kS+N}cʾ L13uܓ6SG4mHBuɍb_G!8/ƃb=9@{SS5V~yOG>ݰyU>U8[VqQaW4c{J2vEES[V+ =3Z\bkgAZT|Ӻ*t(<ͨLFAœU.=|{o·G3faMNzbsߗߍuEŖ6:_P#,lZ:H0S_Mݢ;Zoq[u +8Ja?cajT}6s)ֿۖڰScr[?xi.[ /nBW4Dj5]~n +R:Nr9tg}{q>E1 ɽl^izM+$ޭnj:U1W !4w*[\ݮv[OfͨoUnJW:r,tԼ3qo1]i=g7|w?|e9or-@XvzOcoiUm7BW뫖tw٤JT6w2Prאr5d`NiBb*Mw~t&4$&b[,|Ǒ;~Y?: ݸ=XN7BM=VbEtPsX~+JG4'Wc\ڛf"_sh\bwqD1>u7*۷Ł7jY"Y&=}^:H;N̋[}XxeIjK'韦#H嚦u ~cO$sz7 sqNM}w&'jzVS)*zOmEMcAgؙ|VQol1/vlXZS,ƨeXgS n}5&6ī&yóy֕᳛_3h5u'SչWMSM\8g0a$6ȼ{jtp%Wt"IgxHx#f$?$}-?񜼨tJڵ_������������������������������������������������������������������������������������������������������������������������_ �%6O endstream endobj 320 0 obj <</Filter[/FlateDecode]/Length 596>>stream +HAj#0L@:d\Ӕ>>#y MB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй8NE׊ [Tr_y^�-G�dSɱæ]+6h/#E />}OW G>y?[<+:lwKٹ"`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT`�vG endstream endobj 321 0 obj <</Filter[/FlateDecode]/Length 844>>stream +HmOP^7$l^,j[YC9 d["P Y}a%".VF Q BQ BQ BQ BQ BQ BQ߸nP@XHe+"u%#OX"э61a/ЕB15]Ɏ*?&d<2U3#;f(b?b_$vPc]N9]A���<ŭi/*<kX0lO{znVy8ԹYOD3oeĭRݽ r=0XӫgEQLǷb۽2 ӊTT䚐LeO$eJo?2_R\"ac_+6c\s=ExIdnX;Ӿmǧa[/9,7yh<1-Lp9[J2jVi}z���������������������������������������������� +T:]5Z|G[OeX{k{ɿ֢rtg=n:X߯? ZC׃Ɂ/g~v;8`-|߆v;<9<> ?ӃFumԢz~;o1J-y-UjFVm+DQP5<=×'KfP *;CnK9 q/VGԧ�������9 endstream endobj 322 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 323 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 324 0 obj <</Filter[/FlateDecode]/Length 557>>stream +HKTa[~D TTбMDJaeZ-R2W5 }:*BRmrQh(;\~ ^8p9A������������������������������\2Q7OM|[\Kj*.�� ^?,d~=ion)sT[kqσҨk��cgaa)3u!Z��xwfޗ岒W��X_os5ǂof/ +.��wc# ӓKa;& wv +T}��a<1k,v=:e#}* ��h:3NV%םJ +-mtoOQQ|JP[Y$""""c p^ 6Ww`qɺvF·v¹ rE8.O^w~fuhpq{ULTH333DEEe}p^ 6e{ƛgO֞g2ڽM9%K}?=6gZ`�&4 endstream endobj 325 0 obj <</Filter[/FlateDecode]/Length 412>>stream +H*a-�$fben$.@Nst"I12sܑN:؃X>{zkjdxbw ~xd[2.q~}\5}VZ'O7GW3-? d\r?Oes|2.Rs9FRqkD��y>�;F$ �73�@kD��y>�;F$ �73�@kD��y>�;F$ �7T}O= +��_pI奎Գ��H>OS�g" �DR;z��sIƳ+H�i +0�DA endstream endobj 326 0 obj <</Filter[/FlateDecode]/Length 429>>stream +H1KUqᣩP"N bKBDdo uЖr sA.cc uȑ+:]9<r|d@j/\wgxh8]>Xy;X&��"xϕo�9A$� mյ5��iߨV׈B��M��H �6A$� mH�@4奇ӝ%�NIQ[kk ��>qCEx ��5zus=?Z,��\vc#ON?*x��9A$o?Z,��4s/v-p��9A$͎'8 �LK}E��\?=�dQ�oT+kWD�)y endstream endobj 327 0 obj <</Filter[/FlateDecode]/Length 708>>stream +HkQgkRB~dPA[DQ5w?*4jv3M.]D+˶Ul4Z[_PtSAߑǁ̝~}s8_8(hC{)o���♚f^Qԓ?47+{szu]w{Wqӵ$gf:ZV:;>>>C۪ǵ~ZX{5??`T0p^ݣ1Zxz{ .a��Ǽ#>��y F}�� �� 65 ��@lkŨc-B,3��ؘ m6*or/L���d}O}Jn"%���ȋy ;ѩl��ܘ A=��@nk٠2?YLg��ܘ *-sVS^o-}F���Dp1=onj��@nkm~t8[vnڢ,ʳoN'byyTt_&j~w9B'���/m*ɴ9tvi9bw-ׇ+l(^s��@_qNLhfr[Qx$*;cWU+叙L] ��f2"7bhKc.s��`y9YpKC+@ �Vc0 endstream endobj 328 0 obj <</Filter[/FlateDecode]/Length 700>>stream +H_KSqa-+M +*zaJ2 Ƞ]vZIAs$h.ʋQ8.zw]w/8lgWߋ]|J�nkS߼?{N9q٥���<}I ���&;7K$A=|���VIvS{Φ{���P#LvSb]R>}���<S1.f7��@ngkLG,=5?ۧ&���(e-Ed UwS]Lt-Xm ���JUwYyiZFtQ߳7u���|ϩL-LRi~H���BMX&M$qP|m}��@=#`GU{v>5?.��0S 1e{GjykU]���aXK3&iIuhWt��fStS}Lo]~h���B?I[u��F#d]H+i쏽=l9úo��2iyҫY �� JnGیIvgn9[o��nWLS '3]��_d?0�ȝ endstream endobj 329 0 obj <</Filter[/FlateDecode]/Length 766>>stream +HKSqsպBɠA E1/"((#+i(ʜ(psS+-w:*6at)uU]w!jď~ssι^~ޚ ٫1?ڱQM<62��Xɝr7hL4]n|I[2oȾ��JrS0A@IC<L<,>���+̿XI<}PICY#M}���V"O>C@UjW%ﮖ}"��%4TטmԷ +Gc~B���VpR쯃KUӡDd%F���+3I}U0* f&3q�� ߅g"n2*)^=x:kĿ˾�� +FX\Vou��P&k y*X{[od ��==ڗ_TV?lN6b_q;��TfLN>E@eC< ӣ鄾"N���-+p=F@% 5w��L쭾 +C}[e +��# =vaؽJGw[��T%V-F@5th/Oɩ]ٷ��(951*oPMO Ŀ˾��@Ell?\Q_}+��r;kl?ZG!��(b2V=k3T˾?K�3| endstream endobj 330 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 331 0 obj <</Filter[/FlateDecode]/Length 1650>>stream +HyLgT@A'E7%L2&.3ٖ%k +%^n"rt"(RzcPQD(bKƚ?H{1��1j+dn!fW\iY4. gzyZ=OqHDPw:���SU+a?`<tȯv'4w4HW>_���P?5H+d UWt)+X֢UdvҪ���p&Mu&1V4ctX%I.2&dQ׍?d#����8E]t!^SpQgaW}Oۣ龈V2!CR0����phKJIuԓ5AW3ws6o,?h(/?4dBi cU%߷9����YifnѸ5h*U^~Va�G�;?=N*hT7T6qA^\c>g[SeZTn0���P'Q/ (\GwVԛS#H"(nT'[8Qj֨Ϟ5i^^TD1kn}s O ���<=uuHCQOQW`�g@w~>^.9k揨dsӛ먖\x���p&Czit?]rnȂI?`<3"ϭ?|}%op ����$nEp;*3mg;_?4E\[3*fޡ(ƆַjW{a#���8!F3Թmi7<{BSv[_?Y|2g|WYcS]Q-ji60֭;uxV[���hJ +];E}dS1x1/k(V:1>k$%z_m.t{7mtT����˧9jrc)z^)k6k̽yIiIf!ClhVyc o���AyJyiGLW+1_yI?y3Rq静d(SsGMSfӓ>gzir=cךkY<���PP\k*jV3ILϧ2m-/&Nȕgڲfzp=32ĕ\kL^[9p,׽ ;5%���!{Rt= }]vZ^i?ɋlkw,?< +JyK~=nߪQY7%���c=osuP'z +8{9 /.˨UtqyV8^V}w1a^[^R.b��� ^*QHW"Z~꣎0#Ҝ,k|/s-w(:}Xx2=kOfMKOHb���PPPp5ÚMA6O^dƊuJf6t.6L_);wqq���W79CPNj5RqDDp_ �ᒟ endstream endobj 332 0 obj <</Filter[/FlateDecode]/Length 1398>>stream +HmLeZR Җe[/KMCYq Ҕ"qp E4; jVeu9pT^sum{]R +𙡃?2V=᪣fmhpn==Y)Otr1p ��`Yo:Gz~-PҐin-9irtCΜ5avUTl{��$}s*>~ t9qtҜm-##ԖNs;랗d�� Qgx"G&%CN臓U{")J*J+ژ<7��aN(i>C'd6WLtcy75WSլgPt5 6���]+$DI\/S5ZHb!gܩ.UvJ, n��XhѓG}mXW'F}MPˏ=rǦ~}}쑀���)13w*gi:?{3mc!gRʲnwGc1u~:��@HHϔ-s9wΖ&mfT[xcʶcS]>6sWe&GVJ��17*6nU3*o=UBKMY~wgܗO|i@��!/1R{Mt{J:[7G?l4A?9JܟQsݚaf��#2'&#=۵q=?F779nW.d ̓{h=0���tˍQ]##7[FOx{Z4Z췔}^?Jj ���2z~tkj KH�C ;>M5s'8���!"T5ggN$(WKL VKbx*,gV&kŊu꘱f��^n)_~e\\Ap?FhK3gyR}f��^^M1QJ9͎b?1$ns::B?})���<z!4K;&:RF:h_rRٟ79Jfե%% 5[���xv++-- #=#] #|sLujpʹuh\kpf���7'͝r桱}r1,X&|@|.r NȨoARb���z'G5o{"GzFFh?_re,ƺ-9fT +0�S@B endstream endobj 333 0 obj <</Filter[/FlateDecode]/Length 1408>>stream +H{LuHܢrJn$lfl0 5-3pm!R3$@=\rRpJK:al۳1��3m'MGn<4u3;ݵ`ߧy`{Lg^~a-fbR/m���� %OdK(PA�;4vT3sǕaM ����\2sD=XfNڱ4[e'cUN& +;[<RDoY���<B/|y_ӛR<pxʓ]sW3\1S]y���[ eQ>*[(VenB�9?zߝO4ͭ+DA}͍j���AQ<ru4\)<poxuLݠ6\'x:  ���8&!f1a&\d4~1�W[/ +q۞4&xyx^���8'󴩪H+[(:36VA|}7&0c*z~���xe%d?MY +-K i^B�?h21.Ư<!Y+���PV13OK(Hhy wN6H\DoNysMr35��X% ?Ĥ1eQЍ<+4zeawK9ޛXKM{O��� ʼc[Z ڥ~2,?@Nl?uȋpE?hnwGuax +���dlRo֡׎LVK5 �̟=}뙮^=sKab.޻���: (,Br +A ;{޳yˊŖ7Fl .���!WW&U=% K( 䙓?@N,{w3k4=;T1v{ۢ?����,ݮf):L?j's +°A-*ibKP]Q{g��� NiTOKf'cA3+㝑?@N<-kfk1jJT���XQ6[GouYKΈ嚏?@n4T ?_clKe‰���@˘;;wP)*ᝍ?@nD*R*pg&r;���䊋ǽXՓs.ᝍ?@nx$gCsu^uq%���϶ +ZYr%6@ 0�0:# endstream endobj 334 0 obj <</Filter[/FlateDecode]/Length 2688>>stream +HiPTWNDG15d qDpPJD6 bBaٔMn{o`#tCXtR:1"*Totʤ! J~pN>~WN9][@9&癜pN`q3)?(tnh(;'zB!lŢ6Pa@"(q>әZxghd弭C}_!B!X(-&jzsYu{ߌ%>Ug"h$A&VI&>8륹<S[Z\ckD!LvT|Ar 74Rik2Z衩@ :{D!{D6l]}Eo{V?f(sY VN ;9n'VXŢdU"B(rm>3r3 EArTTk $wt6Ggvԁw#@,Lt%ol,#Bm<:OcHL#[7/Oحtآ$z-w,22h%);qhs s+j*|3P S�@(#!NY`eC=a$B!*=y<AFNWtb,#Q> _B{i{ؒ5<K:ȫ| p5',z"˸7#9bglu&Y.E χB!0g*\O2ZQd}szx)Q2Zel`g`@vO?A>mK@\!rbfS!@m͚ZUqbN[UIn7-՝t=&>΃ẃ!BÀ,4 +e;>?[NeWrKxW.'e}?+SvKo?4MCz}Wt/[viK=Hn2ʎZYIMِ==bUv&L4;-B!~;ILp�3yc6әbsbniNvhu[+k]S4cCw%;c)rUv9�y GcT֝F]{B-T(2n$7+,?1aiBhy-~@ @!Р۶-s{|8_J otؤϭdn5B?w2д L ?cL"|P=u;d@>|3z6?j2uQĢub)rEqc<:Bۙ`jb2!zZRN'BF移0u 9-d_V}lQn߇y1?^g8n�5�QԹ^ڮO*ip;~&~¿~I=au?9dХ4~l!z1{Lirw|ArYbѩJn IW#_R^xL}M}%roL2E��M�ngNǕ5 i^;s?=k%Yaſ?s3, &&C~B!ӣ(ͽvQI "Ώd:_3i?IѢ.c>S'hxMak'ymC9P p5ř=u.6+J%܎I21CzDlM.,_Ng!|7͠[Lg_Ӱ mnOvZӣ(qϕKh\^c9)r(h9sӡ=;OoD.]w;55{eaδ@!1b񋶿S,vdWpLgJ'hѽ?ϛ?qyLe ho�8 yjlrz}VMZإOdb 陂AVw1{L<:qxzBrndDX fz{HEKub‚a[0 +Xg_KlO*$n +?h%O4Ҽ[}NXT-OLXjŃZ6V`?L!zsEyǞ%UlVI`:`@  3g>Ϗ)r(h H13ꑻl~Uenk=-V(r1n~?+u{g{{+,�,&.E1}BBN 2$>wdݯL3 4L^ h?k9|>Pp%^~ȷ#Q_N>߻%Q'kW?ٿf-fv/ﯪP*KLfuqe0dl0 +F(`'<:нfj=XkW'M3# W,o[=>1P ZY,VeMDO'+nwQ(kV߷jMsgp*-.egURfO�0�~ - endstream endobj 335 0 obj <</Filter[/FlateDecode]/Length 2440>>stream +H{XLr -rɝt3ҒNHE[tӖ$**+Ԍj*8d7mc8iwP>kLW?>�!(c aeMF�9#[x|9g\Ж%3mXiwL~wM#˱~ϣ]hGx� %?GKFk6sV/IR3&QF,9akrxmnrl� S3`X_'BDflԲO(+5?^?A@=CLZ`#DOc>~2 +T4sgkQ8MV_@S4~_Qx:%4:(p:%VsSf~B CLta + ܜ;�ɴy,&{;vWЉp5@p}x=VEjOg%IrFyȥ|y^oRE ٺuz;8 L~B}$'C'yuJɵ$߃alɴyd^˺Ecg\�KZHM"j8ϊ;ʍ +ə5wddD5E!LdYA#� ' + iXu,Јsx V�`ѫus_9PWRMd9łS2brcCo+Bo̕$!tھ? }惨@^e1j�@Ahz'!q4@ŜJܑx xҎ/mfi!p@.˩oQp'v' E*hwA><C](zgH�TI`gnq] *6=*&ۻߪ/ Y�Ţ#N[mмۻgZhڝB?o[ŹBڽӳ#n1<)gV/OeXҥ[owILrBiIX;or䲦9�!V/==Kժ ~PI_Yp ğ3GH+wP kx��<XR:xQ{բջ]ҾMLJ_|;\Μ>!8&w?A紻 +Еa3⟞’iwM D P)݂tW|q匸ce6 c*I0O_'!gZkܻǕH? =vW?Hɽ;%g#�<ݯyްE)](#5*=*&t۶+la MB=Eۻj%}9v; +:�IsKmP qPN4JlL՛",2_Mreb +} {l+05BI1/-y]ߔ2; +: x6t-Јt @Emhqksސ$E9#ױM$wKżbiJ֓y2j454}B,98K\�Pi'n!M?s!@]ّv`[\ ^�;HbiТNlh.;,R +m}"+&?+h.ų?ÓEp!ɒWD yN]K� 4 >s:,WHhKȷ;*1ٌS窽!%IrFrcH2I67n V̳C!:zL{!7=v߉;}v'"ƒM镒kIa0;/Hbi@ޯ�qmNۤ题W"KN<<)h;gٜ`ajF!t hE4#>@@tq$†LG A<șЫa\kݲ\#j|MO3ccVDQ@_)Di!CN{D 4]B匿.ߐ<ӢyƴӓCyOG}[+]S포-HұK"+e) ꦷp,01OD"j +ҿvҼ9OM;gH@tux[@xL ?5�]�M韲_ʗ|}׽QWXΈF!/9TDnOC[`9Ӊl1eggv+yYhwu'gkΦݳ0̇G p+n�~)sFt\VZ*/&zi]=>XBqy5Z*"Tn�0�g endstream endobj 336 0 obj <</Filter[/FlateDecode]/Length 2694>>stream +HiPg$r *Ա*uuK<@TSD@<8?CnNC[]W@]fUmL}>37y<~=[Ҿ 2&穩 ry&jxY0OSѹt[�E��nRN7.?ސ~cRmM=yp^Ȗ֋pX\A cF{QȠq]$I ?9t}7ԩw'E?�u�ƫt}BoSGutF ÿMTdg1ɧ"Gl߮|= F~yÂMjż[+$=H=8v fۭXpQuL~o@@sjFO_d^W&OŒ|QRŽ#`MaXPci?;dwaela<u/=p Ȼ=W)Ə~BQR@ p+gކnu }"%҅7'E3zg|5h?2d V#Y2>ciw(0Y +%.2vAQtp)X "XО>rZo|Ҙ\d?Q(R^EvfY'lCCLBzjnsEs􉆠NGAŘ"h*Y:=O]Tj<yOs@G18R&q>Вpi#]�ߢ6oܗv"6F̻Q~)N0#_r6GcZZWSAWSvD gC #=jq{Hg?Pah LvA +)%@{gU:s{d3{V.<Ej*᣾;Ep\+N>ze.o�M456v 'g wta{Ӽ;y?PAI, E.{诙i~7@k(rm6ڈkILcō"eM1{&sS/:A?LL5^KN&yNr=<'ѝv 2P [iw EPp5 =} +Eb KC[+a>7y)YqΧBg{lz201FЎ!y'A˲ N$g:S?QA<*9@\p!PE?��'SyV`9Myw*&>aw钜poo]*fshPciGmXs$幾v CU|oOlEQv� @?@K.tJhT9}y禎#: F}"7u&vݙoۦ1p "h}%]>9~]ҔMHwnAbB'JoʹPE?G+ʶ�\ hOzQd5u=;+e7_(EܔsY֞޿/aZm07�Uv!'Tq{>I~s-!LS@>7w-G;QEY�=~<2XϋǾwnPzBT+Q: 74/=FnUm-`#F;=--2;6^W҉L}|0ڝ eü!#Z2g8PU z$ e^,6w[>84>Qr.qOqcccM[jcn&@ͦȟȑqb]k3Er[|^6sڝ eD~仟]2I;QEU% 6�4x:Ay77,zٰwKYBy%#lW'N$lPrT}^^k} M uuq|Dt5@*tWؚ?3 -ǐ`IK@CY0/sH\"G;QE_q�(p5 1ǘJ|ۦm5bmmTÿVt4ؑ%Qc<VϚ z }j vZޅ<㴻0uWoզ(̰`\�.OxAiKkMRy~X׸֫ژ[fӎbDMMnTw^MO�m|8ʼ?yCF>.7&EQE?�2oǵS2Guj�߶*FPatDڼ}iG||FovtR4ƏM;CULVuOk%fI~?QA& b.@וxQ<30lM``8[x?N94Ԧg&Yu[̜3Ѩ6#'ËX]kax89Y~�M8{V0206 K6-?x|Â]Q<G(xYþ,+ /Vr?O?9رȺ%P'/o]<{ʢn"ɬp&c)ah>v qo^~=zQ0 +(#Q*EAad2@y#� Ò endstream endobj 337 0 obj <</Filter[/FlateDecode]/Length 2196>>stream +HyPE@G11xF4ImTb 9<Ra7REUK;#ߙ?y�SPkGG)t_jS/ViUF1hT-BZnvLjEsiJ$<''2h~Y2nUs7\Φ_ <u}os(P3&=��o% 54)42.Z+<&f&67Yv:/p!M}sB.e_PЈjz_3=Uz6Pe΀ Ov7Sx.��>DEvW|4&2VH7VEqd{§Flb^ hDzm JyOd(/N~ngRÍ &?qZ7Lq|�SaDF}1q?h7mZXP͹xOQ:L*[&ȆCɑߋߵcBTXεk|niɎbT"(SAJc_3i,L:3Ӽwy<^ΤȈيJMU2}3Gu>{ ;kG] ��}t+Dg‰K|-ף~W)pS[. ͷzى.Y-_U@,jz;9WY37Dɗ)Qf޲Հ*4BqUvPgס<4(p.i +szI��YK&%[I%ѝ"O{͛NhIkI [#]ޝI?8ȕ##MzY=Nw?1f)]sT-̑!!vc;���x2Ն}1i]n>Q(JKٺŽ=iޝ%};O:@ ?2I8^*?Z{��� !2CcGú)ٮ<Y&&zAj_0ݻp4F/esn H_@ ZUlOTkAjmJv&#����XGSf2>Nn>rٍ?u0(in&y[w@@Jn0]m7mt5t<*]8R�� 1C6JifAPifz#pl yJ$6SA~{zEzj���ba $\v`d7m{ekju*Y}6w^2yb<߳;fAWݻ\?} MoJ=GO:wqzz���1npFus[vwcnckߨ[6yb<:?-񵳅c׎vqҜef1{$)bRÍ 3X3m��kMg;DB.]#3<miOyz;ļA=ۿ؞1 ,JizmM<~F͈ /* ͷ��9kJs37)a 3Z۫}=z{[5 -sw�a{" pp +pqҸ7lg!-c�� F7U(*or,4r_Y6o3bfb1񇖳}3W{/G}2VCk* +WjU���b'j 2ԙ,}p~=l޲{"腬J;ʭ]ѻyD;��X)uZe+UrSAJc_+Ysy|B@S?z7jTh{;��}-}*/\&ۮi;as[3_?ۄ(̶%{;��إ{<6b{98#fY/fH +mFyQNt*=��h1ҳ,Y/fH +QS Zi=5��@_wnɎ`�դ endstream endobj 338 0 obj <</Filter[/FlateDecode]/Length 915>>stream +HoaJSVHRB R6b* CBEdfڙ R֩T!BI,Xhuco17;7<ųbMaе'e8{ZvirX$vUŎ��TvǻG|&{uKS��1/CM 6QspSͳڷ��Su]?(wJjw Ħ?=Q7}�4ҟң ڝn +) _? F1S�iEk`lN7Gb֞)'90y�_SR?ל>VM 6a_4-�"/bVQ.7 GVVm#o1s=�5J\qrh7 G↖d91߫<�[IOދ7?;4bSl[o;��n9weM#DbS3$˩o;��nӰq'vwAl +c٘*oۺh�mgHOJ_jwĦ?*Zm zy��Bz5jj?Ma$ǼC)3o=��nw`c6GT6^:\�-q+#jwĦ?'{gχ7��mҋYQM 6\k _y%_�EzPpBm 6\~ǥڷ��-gZ6`HewBW?��7?aov'ۂAl +#(2��زYzpjyz'ۂAl +ul"/�6c endstream endobj 339 0 obj <</Filter[/FlateDecode]/Length 900>>stream +HKKag@W"!deF +%HL$0@ (Ø263l&:e +)HkZe�Qs^}wW=�+U*hj-EJ3SzLߡߧc=Ze4w|sKW;[��@,>ʃ-6 3iqw5-T|��KJZݔ-`p0a\5NόI7��͌5#ni?IWIk]~yt��|kKtkv4{%g!oxr]!>��mosMID̤qXM?Jn��Iv[7J7T̤q/,Syぞه;�@yw53iPWht+��lݷ[k2fҸ?bq>}-��WZc[tcMLG)RA˿B��ϩs-|R`  <-��kRS,V'`&#UQ74Y&��JwL,͝'V'`&#o싼ש��` +ZEwWStS4K>Fc �`><oF:6T+T`&CF?$;�k*iKnp0!#<Kyᗃmo[� +tuǤ[$̤q9|1ID��7#[o]Hnp0!',S^X>><"��Dwj<3{wAtC4Y_(-��d%\{%N'`&C- �~ 0�^j, endstream endobj 340 0 obj <</Filter[/FlateDecode]/Length 1211>>stream +H_Lu$mJ%ZՖ2[@ԭ&'4ElK! f,s@AфF]$jc7ٕ^s<|NXF@ACU~D3 +w<'ⲇ+B~ZeWs67<Nd��2ړ!=%}3A1+sۇΦ��I/I?IOJ;c32?oe>q(vNub3^T' ͺ�qgNH?IOJ;c7Va۫?~TE0}�@0ԪGtwݱ?PU_ъOm<"ӞW5͞ίkXw��%=P'$#AɎzD)$fDH~Lw��G/dݍ`&2"B򹺲L[TPY0o?��*hޯ1A]ŝpi 11Üe~ݹ;�`?>݉ w"çe<޿HYa^Yuwk�؇nIװ?NeLðd[}Ea^^<j-9��w@{~N_ q DGQ[aV?^Y*Q-?f^:uu֕fȱ7QfwKAc륔e/땹qrm.G��ݳ4BzgK8hgu;?ͱ!,tOgﾶe2?97hvs1ɎBz�.g{) ^NXu5>T.>A=0?f?m;fM��kj5}%-6bT?o_CAoث �`=͛ +k8011KB㴫8esƷtC}~[��s雽3KB}01R*J }ý{�:@)ڢ]ɱ?0{JTG=?6Uv*�u/~uX)H)^ ꏣOG+�]jZ9Gz%4+Fwajb?Ϫ/_k{ �`^#'MG|/;Sc+a.yoF9Aww�J'/zEw?0�(l endstream endobj 341 0 obj <</Filter[/FlateDecode]/Length 429>>stream +H׿KqowwQgKtRQ[u5t!lȜBjQ~TY{[ВCwtSs<^�������������������������������������jjsZ-Dg ��H˧NoK?s^  ߸{PBҳ��7 _Jҳ���|ayOWW��iU6]<q2||_]n"_[߯JL&��P[kfFG_/ɉKI��ǧZkl̎=;} ��Hh!s>ZٵwkR({%Ia۠S4>C=mGc^v$'� l endstream endobj 342 0 obj <</Filter[/FlateDecode]/Length 924>>stream +HKKa',sDDEAia- +*F˄ +젂6m<twF)`N$Y.r[TFy?>;\ܾef7ww1W�tn䰽xzԿ`lØ'c=Z8m'!�G!v08̦qxSEQ맆q�xtCjBa?M+M {63�@^H7Ga?M5)~u6k7 �~?mndh7 Cl5EP_l~��a1ҋ=q0m֙;aTm�~vy#n4U"C@xqv��geItbg fax?M +L]XظUs�5FP^h7 l1.ꆾxQtXu�񽫤4އNh +l=:A�1҅RǿQQfӸ?1 jq^u^꾶A{��=ҁHKAQfӸ?/&{4kv��z~IJfI](&ivI[njZ`�=y;F&i_kށ�{ߞn;MIH fӸ?tFwS=Y�f-Bp0aIV|xؤC�^3m*!q?MWVU?;wdj7�0~>۹VU Bbq0ar|o~�Gyyφ/ilf6nCo\v�7v]7^} ?Mh��7_nd endstream endobj 343 0 obj <</Filter[/FlateDecode]/Length 927>>stream +HOqϰ̰e&m qil&BbV\Tg2 5?VJ2N'8V:]V[ Xu/I|m_{%s%ib>zF<v?d\.^>*G7^(GޱgyBcF*S\wͩ]y�|};/^sbS(}|iw%�8X,}ekw BAl +=z,R/�չHAh?Ma=M]Y�L񶦺W͞'rߵ; 6.q3μl�Lpׁ`91U[zbSsf}sbz�#wBv <Ħ?g8x]뻶IG�'w[qڝ`p%廏vfiw)�`F^W7BK>bSu|gۿ*S�ɽ;ށӵ; 6^ś>ϋ羚 +�ir~kw‹Al +6͒?|Zn�mYz gsgjwAl +'\د߯�};]T 6Ds\߳�o.w߹;-Z3Al +b;Riw-�>vW@*Q]g-�rkwt?Ma૘IkЦݹ��cz_l,Y#Al +Qq$ZPkbv}znkw?Ma{3W2_9}ww~;erĦ?)ix_zO>p^oTLbSUE ] $Dk0�Pkb_]ɃAl +_�p endstream endobj 344 0 obj <</Filter[/FlateDecode]/Length 1393>>stream +HoLu/q+,L"[LjIE= &awqẁنL*-hs=x& T~o={̍L Y\sK5%�Bޭ򘫩y ]}>/0-6s38m{ Oscf:t\nXVmxSs2{�@ɨgކԻԿ� "jRvf@ۧSU?xZl`\R,XBcJZ�@&.g$Sߦ_̻A<Y:_ +=s ڵCej3�QRϖ8yw> 1>/uoFk4GED<Ȳϴooі�Puzw烘?in~m6%v؆*V"Dy��Jϕ#ԯ[gxw= 1=NuNe)YZ!_9UŨSu} �ԫ1wǃذ?#*UH @QzƢGIn_""fբ1Sm�zkFgo 6de BXl3=Ni^tٴ0zWcg,xG@e'�@:nQvYx K۱+,3] UxJI7gMo*;NӺ#xMeNX�qGkGLxw:~7N@D1O==ݩ[/<sSCW_ !2k}nv=� '0벏ۛNSt[iG?xp�q7;gUxaxP"rۆކs��94] q9[Z!oNe?[Of ݮ3L\N� .͝Ն'yw8 "j"jV]Tzim17% <g}:mܡ25{�@d58ΦnDIDZTep[GR��"~hP_RonDIW{'x��"rIIKޝ ()0 Vcz%=� Q?,8] ()07:o粏��"3FXj _emA2 _6 �D=cG`/νAް?%SRUn}�4>XXJ}XŻA?%[Ũ3WO�B��c endstream endobj 345 0 obj <</Filter[/FlateDecode]/Length 983>>stream +HkTgwaLD7q.)DH- EYҍIJ]T-iD?f&|dN$ǡ XH#-RmPp<;R4g <w1/oӛljySjBz{wmo֙Ki71;y(s�X +nt#w֋\>d؁Al +ɌHd:S�bl6&녧`@4փo}zJ&�bgi齆Pr]Ħ?PH]_ndv]��$='}wd}Ħ?PHmu׋l}��6fI #ݽ +muW29 6 �Okw`FzNNsa')Î`{YI=Ѿ� L}+^紻b@tFB[{ö*{�*C&펅Ħ?P,mu'uwI��!=&}7펅Ħ?PL] Kd܁�B+ޕ>^V؏Al +Ŷd벴3{O�x=/=VuvĦ?#(h�::w 6 孵&yS~O�R1.?Ma@˪Md46>$]ۯW�I縱{ĮIiw(Al +m6߻�2O7GJzK;?bSei'90N�τ\2΄??Ma?^#O{ �xѳ}J?m?MaT{^_}o�x䬯^ +$HJŊht &fo}w�7q'y K?iw$Al +#'ݡ]�rFnWw5w# 6s�Q} endstream endobj 346 0 obj <</Filter[/FlateDecode]/Length 1028>>stream +HAluCyA1E.M@fM0;LYv-`:77ML3*ACL: ھۻu;4Ap�D :<- z 1 +~I>`*cX6t5=4~uT1}/###=$}݉hIwsϬ1==˻[^={ӻ۵o�ˍtHHiw!p jױ}mQԾG�,%/Jz݁O7jw p;)UM~NR.H$C܎Al +~DӟϜtsW&ֿO�ة3Fz&xZwObSu5?}71Ӡ�ʙE陵m)As̷|N^`rKԖ{F 6|JjiCJm+M~8NĦ?$;<}Inl{V䝁!nAl +AR2C;xunbr@0͝xqH`ovw 6y9l}򻝝Iоc�K1z:OO; )c_0_sO +{@0\a#qd<=$=e|?Ma jvF|줛rUo5;j; bSmf|8{|٨�7.^?Ma ъnL_'B,~?Ma[;=)^2U�_  +]/)آp#}�} \`MZSoN^Ѿ{�k:V/}В&`Ħ?`iw湃WK^d@G; X()ئz[G]^ϮԾ�<XIvJhw`5ϚϢ'Ta(w)讦7o̡ R,W/Ѿ� �`) endstream endobj 347 0 obj <</Filter[/FlateDecode]/Length 2562>>stream +H{PSg?:]]mmUkEʈhE(0)b@899 $'E`\kkEeۮ[]ݙݙ&pB31|9'R><zvܣsmPMy:yÓ ,,w)xř-hi|jT"'{@}d$UZrު1yP3gAtzW B;pE#wwb`S}^8]0 :2Nѓt  +äz]AFXX0g9CSZcD%0yӨ$AF۲itz=sd4%+= % i1<םka@ L[IA #í"=TYumsڳAF XZWļqO|?w-JHdoOcгFuiM0` '3$rHA"B{717=hQ.G?!�AϠkڳAFX]oadCg9k'r�?2K[̕6~Na߿KG!e>!~AǠg3A\ѮS[ kZ jO\G{ <lڪPT[lO<g&m!hDoa tW-kai 9z2i?ܭ:x~N gqΖ?yh A\i1X라U)}_ |q+K{ +JЪ5mݗժv#O?0 Yۈ4ݟeW8 :Ţniq5?ܱvoӬ$'q_P7O@/?9yr0 Β|/Y< ~z=3?ܵ֯|˥mݍFE[J7&y-'7q[LסYّg'I~L;3$FtgSU- k'$<s^xB"jbkآ]U0n HzH+ f c93 ={X_#0v{s=yqkwvOE,LLw,j|״X C&[e.vQ: :fI9YFlψ3`OYs~OuKܹ(a|yB=oWsjらᵜ!]l8#ViSm1Ty|Z+{e8c4@v?pGyeڞէc{}iʱȼpFh_<-Ag'xZ䐾Az ϋAF�);7;#4[M53_~Wm߯Z֛F&9 N8Ѩʅl%ucBRiw|U=+*3C^e amز&äTe%q0`yR"d2'/>'8|PSȾͽ;][bjT噛د(0Tmw>\כNOuŌ'`cr=S]>ǔۿ@b*6Ҟc)kHycm |4rm? Diq0`yR">XsxRU>~[fH֑Yu_豽37O5 +lǬy#zGyegB"v\jvdo|;Cʪk;lcgP <|n%,-od>+:Wއ'?]OFJ~ ,O*W Usj9xq{_o52q҈gS + r;FEyg2&KӂlBR"gL0WC~{b*6:{<7\˱yޚ<gOX'ϥ;IO! -ʶFݕ{RGCOt/NβYY莶IcUQ¸M%X۷&l57;#*V%0-c9yya%�Jt2Zme/97?~ٺ3 s|bbP}ri/dl"GMyܹdMh^ +e[vAFx%FV~ A<ÿA_ikAXT?i3B=g;nw +$"dL=6 tRs]ka:YLFg~I8bJ` ɫzG`r^Wm_My~&ڳHPo.?Gm2@Wʂy5 ,Og�ݠ endstream endobj 348 0 obj <</Filter[/FlateDecode]/Length 3310>>stream +H{PSwh5>W]mUAR�"@�5 b@H&$*Pֵ:UѪ>fgvfgsq6XK93~]@c|ofƚ'M!+㒂Ι--6uFԦ*pyئ.sɟsK,ʘVtõk*Ӹ}E$w4'{#|2`vVQrzV̜6<k*MuGlls:;`'rv|˦LH} /OMs il˴sA<He9oM#hh !!ݙ7 O2NZYX [3// cj ͞i]iOڤʳۘ :ug�?w_O?j i\\ T|#Zu-g<tfJ$ѧ5<e5tүdOȩ&}7{sA?d?Nzyd!%kS*q_|]o<s<*cﵔ䘕.]8^n8 xfjΚ䚏 }Nh7/71b`2m+fc[[g͏oq!I3+"i+ V +sR7zA +#7?GsA +?d?o +alsukG&/#֖9jJo JNg>neSteKbf@M99~2g[ kaQ +ZRmkmph9~0.EW(9= >6[+wh5VoqZ3W5 +Ħ*}f(TWz:8b?&ЮӁ<|2@&&/ +hΚٵVRqcmV~qOMH +"2|ʚnT I5IޒJh3gnPdOt .IMsP/]kvFS5??F\H뀖 = %[h' - +9dM(A< ȋϥ<) oh. 4PS @2 Ge'7үS` YƊ!_h, DPP Hq$kB;k )>MW!sA2?d?,b1:;_]!- !lvW!sA:?d?ou*t|agT:AV+@;'D @@gxbRШ5!c!z<"PP {[DbUų:XNg1CquE3h hb2^V$2NJGRx@|2WKihb2Oc\PdOͷI8sD͟k22DYt7ˆ3`wvFiB׌K8x8k"VP<UJs'nQkMΜ5]%h|mq]crjicMTIflr"ak .W|M~Du;!+ !$.c"fP<Q$-<?ݺƁ&Uܡ>kH8^s8a5}/iבso&y+s +A?d?t{ {.�P1w}k!|1~M a\G+VqL;dMLIf̙UifNjGF:W̟Z8CF9VllitV2g;B=�-qt;N89ԴPRbVlFOܢ~2{>sB/xǯo2Wk9{^n8q/ w\MpGz94W8>hdLsV_$V󿱷v'}HR u Cgp]c\R { ]C @{jw_(BDq%q + +q K;d0MLUMUZ@3@W_24Wh7gQD�_f]]2鳵 蛗%tP#s&AdhW5@Y@S]p�=QҨ^[In+s2ʹɶZɛ@*gkd*EfK,ʘ<LT9}2Nڙ`oʐXU,K;k.o1v΃y^]9 c +A.3 06R]?%^sp~k]w أě{ _k"Vߗ{K 32A&&4@fbd]&>^U uk?b'Usvᨳ nf+$mšNX u>r9#٭=_ ۼlK7?%bnm dϔ" qP_&fX kU@m_8sp?@b.,01"/PXG7P|nMLvSA}NAiiͬ,P^}ѝţ/l~.@.{G(ţQ0`zKz}'z[X" >_==؏,׾~n= sd0l\b˺90eN{֮z_M`BOU"[qƇ?@u<63@fR?[q]dzF4솒01\[C7sޖ建kB3$NP<lZ@ƑS*w]yk^o0(:P:GP1GHǣQ0`.AwlOg'jGӽa^ z#xb KZ>H ҏL(:X|`Dv_q5틀@7Ei@Gђ^[t&u1 k6< _iűUc]:2YXytqP ;jWMq?5e㢹0{W6+2שZ>߲1;ϫ:  i/w'& (! �-d endstream endobj 349 0 obj <</Filter[/FlateDecode]/Length 2439>>stream +H}PTOk-DF1MuԚBbLU51Z(ˇ|(1 *첰{½"Bg1($tI1\6("go{9]'dj~Tua6M_~ 8/y ˩?((z@3t3$ovH9gG=kҫ>{qO('fp`Vo\qZaZw K%>~ϵE!)bQN,irqdw9x%'@}IKQS{Fam0{t|htY=ǫ™28M WܾFq_%,v-Y^=uzD*N6a*2Zݼ-;*Tr$ٮ~9,1x|VtA BnHS 'Xr_ocXA]gPC?@X,^^tEjUkrkSC +a( uϹU;lvC +oy3RP4W}h=*=+ :~获  +-7JZ/;<{gVž%44|Νy&-c$]bM}\33l"~'GWO)F{.y'�s#.YxO=6*r3ŒSxk cٛYhEoѭ\¿g%>]A_[A|Z +oI~t >"OvL~^.Z?u> \f&VqڅsF+ F1 +͞5eN *Nr:Y@Cuy�=?J]ڜ,?<dRzux<nYs꒭lڻ{m -ޞލ̓YJReŶg_K{͒RUq  +-7AaX,1g{[i8<_5Zz|!R ٟ:%<ڼR={~5:S#z{-?~Dn1aEߏ!<{g;( 보ݾ;y]]6=rBK5/pdN~T=uV{')"s{$˿c.ko*%ū6H˨CT~#eKy뮯0'}�RlWÛ{Y�@7t=4ACBKT>w</̘1~`bbޟ੖n,} xвgܲڗ2- Hufa$舷 nRx˜vܟ6jHsUJWːK +Z?5{Kxc5Vznxk  +-`xD�Iڷ-Lq?fG +N-wOy @t}fE*A +-E;duSyC,|猃p-7Fuq<SQ Z?B<{m~A]Bq[z=1A?nnD%s?[A<8?(?B<9m̙{H]QO[^˿G&zu;/ZrP$ A AfL|`}dĶO&_ſg&D]y5ޚ;9 zZ +?x:fK5JGnvӉʿ&?g;P$k§6,1 ?(?1.6m )}&ϩeȿ&t<cWW8V'oM!A A qXXd▪:θJ! b}6 F>ꅺ~5DDABKA 7##5%i.k#~ $ۇ=Ь{gގd u@=PuBxk އA'ԏI_; M.lď߅ ?6ȴ?@??&G.oZ +Axd|f̘"8}hWnѭ_ſG"ͳfY|#?[ Ax?(z+F {7zQ\c킢YӦu mGmDͿ8 A c :L!-m +V2|"/|#kOwAb Xv +}71y@?9R-^ +V?. bY~F~3:ZjLn >ȿ O!'1A `�$ endstream endobj 350 0 obj <</Filter[/FlateDecode]/Length 2389>>stream +HkPW ᪂UVaX[ +jW, ҢH!*J- hD(Pu]mgw:mU췝~?m,&$y~3{{y眇A6zbLHX ZTmwh Iv tA8}wf1}сYήr#>Nc9e k =: !7ze--GNS{|  /N>C< g:B6�HLJ�'XVxhEU_htv y<D~㺖«:}ZOz'7 _]H|7B@NuLRHω+ 9V34?3)E +iF:>}KSA"#g/g{ue~=AuZnoG}G Ӽ !͇Vu͓KsAŝ|gLtFxaM*)z}.k"yxtWNk£|Ylޣn] 2YHz3WST?Òh~4OoL/' c1>#gEJ1R؞E}+"+_Q}m&3Dxjl'yʣZ +UU=?eZpA Şz_ؠo*mIRoϧ:1;iRTnۉH >Cz>#gat: + ̛j3~aFIk^]4~Ňwɫ!궳k౵>V~vCu2*+R7Nuܮ8Z4Ə 2}1|sEÝ�)AlGjhc3~)4gu6}D\gX`  9s�bzt\ޢС|ui}Meb}I$^Ŗ.  &F5:(FZTmw IZ2������.#;w:)K<m>^KפE_I-wk%N*������bP0iV{"LTjqʻ,Q6����������������������-<*. +3r;Z mU1. <#~;^P0C-˹Q34]Ԣ3]Z=W\QfI.X%R靽U~CZS96c$bKLv:Sn4yF6ch~~02Ժ/.R7a_:|0Y|#O@?OAZ]NGޢНx7];�\3\[$*m1k 4Wݙ[Krs'墴5l\٩T#=x "wc:4//):ҹ<v]ގ_eu٦Լ ^o t͍ݦur<v/OzMyL y Į]3#UCΪKtےSPh(޾&2g >ǦMbYB叆#L},^ɬ7`%lY| Z.K5kx^H+46h[ʣFNqO lljz 1&ᵂc&x<Bu޹3KKrs'}\5Ny: +yl'ޤ:5<v?gNg'\c!arF_ah;Yg1|ui}ǎF;b0ZfCfx?]KoFл2Z3ㄽ}Lj+\(r\`0բ,80 Ŋ5O݋sB:E +^g$oi*1Hu,KҪkDEG[KƆ f3ヽaiZfLUqQeO>ֻSR^c@tt'Қ@??s<vvgnQ}hI@0f,&qՂ$NUmZ Q~٭U?<=xWNU}mu{g[3ヽ*j=#i͘3h uX 4uiUӷ6Z{0oN({3:Ɯ/gNg?I6y9Lgѿ`,A+"ٌWNAqY/2Sxe5<D\"46X5k6QK{ 6ch `+@gNeS=#(x8`� endstream endobj 351 0 obj <</Filter[/FlateDecode]/Length 1130>>stream +HOu$^*_/3JNĕĚ !5,K'%8swM*Wh >c' x>v?y߯$Mֶ*yG2MőwYİvt cFPW:*r=/.y[9}鸳8b!Yߦ+:rB\KߟFXX ax>^Yqpsw\JWmVG#өQn'M:.:Xi¤~ b<N}7.61^B'8RUz=9Ɗrt&V/*3׊5qAȰfJmSLJ]W\M -N+F#6´sz7=_{8M.,:80Pg3kdYRߛ<٫2}grD-bA1_w؇|fl4WwWx9*/jxlj<-7&H@3Fի~mi=)-}#N nycV,({0֬}yq﮹#XIlUțHq^{W;4Qѱ<myAAMDb}V9 OK_؇Oם3UU#S<jϖyuVɐ6/rtPt vu\)GG'wKi;MR;臹oj*D_Ԭjʼnq5[>/3d5%۔k5:<br9JU(qq:||(qaanv:e~QwO)#ld;/MiIe_Vs\c*:u<)6N\F=?~^3HS!B<yuJmUb=+v7_'GmK���������������������������������������������������������������������<�cH endstream endobj 352 0 obj <</Filter[/FlateDecode]/Length 490>>stream +H?kSa8S +BPKl;X$JR, R  +7ѥs4WT 徜<ppy1<k@);W<={w3M5'>ߺqu،sUZA)׮g|~+{__^/}]8]2A8qrQ_t`cuQly'sp 3yxqgkswǗ¹y'sp +},> dYs[uS&s'g3�@kD��e>�;F$ �P63�@kD��e>�;F$ �P63�@kD��e>�;F$>O5'> +��#ɰγ+u�?d睭ݺ�I 0�]CB endstream endobj 353 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 354 0 obj <</Filter[/FlateDecode]/Length 165>>stream +HA + �ASOb �����������������������������������������������������@WB>$c)}@!yNO }P>R{SGC|製RXy] �u endstream endobj 355 0 obj <</Filter[/FlateDecode]/Length 535>>stream +HNPEO?#B x˲{4̾Eū[{Yq7G>{^|}$?[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&%IL1#SV!biGu"&nIlMؚ9&5qsLbk1c[ .oz0bdG}oc߇=#SPĺLnbG1c[ۼvx艧4wFؚ9&5qsLbk1AS9#ֺcZ[G)}>2Mi.3LCZ>rUנA9 #ǐZLZgtddj#"S#GGD񘥙1K3Wcf,\Y2gGΎ  :;44tv4hh ڙ;3uw,jgXݱ-ux$lfH^C�h捹 endstream endobj 356 0 obj <</Filter[/FlateDecode]/Length 617>>stream +Hj0s-c^-Q}a3.lfEl`/2Vƽ\ʸ[rqp+E |(O82�G6v1#.rc@n|ȍ "@'>^Nj�ت>Ga} �u ?@;@}X +qm/@ f[S@i}i +.}pf+vX+5Tuҝ!j +{CK͝%j\%) )-ݔCJj` o:J*j:J*j:Jh oeF:\ÛjaAQVZOi{T+= U)n*t6Huj[:y5.MR'J`LT%0IMR&Hlibo*D9J"S[2K\2K\2KZśBC +BCۥR;JݥR;b3b3[b+~iZ&7"߇ˍh}i.8Cw%'t}i|)K7Oϋ}~.@=,;߇n-K�/ endstream endobj 357 0 obj <</Filter[/FlateDecode]/Length 848>>stream +Hn0 bkmP$Hm?Ռ=Ҽ=ފ{y>v0؛ݨ'G]-VܦD* [uO7QisCؒQ)hYQ( +e)V:9=۰}Jl}Jiz} >kz۔b[20j{ݨ_ĦnR`1a"Ŗ}$rTlC#[b=ZEؙGɜ WvdN);J!:73vtlf*\[: mJ .θSJ;6n�k_JUjع&;oUG+nPͪcA}U ӧH,QLZc(,! Tj!B#}/2þ\pbo9�-1K +>f4l Hq�vCؗN16}$G,mg/?K)�UBaw ݉ƫ}YBF`ֶPz^cho[~O*\נ +dōRK̊*$p-% .nu%eIC[R4kwĒtUe[ ̊DT8ryhiCVTuQQ[]_Ln3n~fԖ?a5~V߇$ym~6Ғ6cR|V۰6g:ӤXmڠ˄σd`U� k I*Gl[C229̤>Ia};0®4v`&]i,_�& endstream endobj 358 0 obj <</Filter[/FlateDecode]/Length 591>>stream +HJAQ#`b!UgM6Kbn'xo1Br}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:C҃Eݥ`QA?vw)=XTO_ +Cog>B@?t}%φ>K|~o|*BpM!8c}F?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}Fgy`�I endstream endobj 359 0 obj <</Filter[/FlateDecode]/Length 601>>stream +Hױj%A3],d] +u0mB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй_x*;Wdkņ-y%=XT]|J Tr_9O%NJ+ǁ|)N;x}¾W G(;>Baӿ }_9NE׊ [RvȠ=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуEq*Vl򯜧c3� endstream endobj 360 0 obj <</Filter[/FlateDecode]/Length 780>>stream +HNPDaK_'!^ ~VEt61[nҁ) +s%⟴_ KqꟲMKiߵ_p*bgpnñ?I/= %~}6[^vRgW%R6eR?A(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]{vrQ)v�L7ŒR"oqCxsexdxphxqqjxAZǗ^:/:~b10އ�`!ｪzR*I!GLٖ|_x?�v?mu\=w ~m'Z&&xO@䀹qv|Ӈ௽+siG cÞZ?ӛG)0xI4y=!5>~:Ï?9>: `� endstream endobj 361 0 obj <</Filter[/FlateDecode]/Length 490>>stream +HMoA`&B&./XOTmLۤHcLXI5~z\T/pI7yV*MJ$UqWK^ا`JwTz>b/r:G]З#jxD^ǞQRmuXyF7">e~%RUs*eN]rˮ������������������������������xdE7IMRlO`%3tj⧍mt2.njϺnEǗk񟯆_;r8 H_iGN{w;9k?jG! I ów| YQ.eF^˚Yck]o6çβ:=w-?C+C]eE5Tf/4���������������������������� �iyS endstream endobj 362 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 363 0 obj <</Filter[/FlateDecode]/Length 457>>stream +H׿KUqᣙP"AEAN5cu2 ҢҶA쇒 !*^ ١ #6\tgyJtL6+��{-Ӯv+?>�Mt9y%I��?v=꯹dwޛ��8?=GG߽&��"q��Ŷi{(�@}P^# +�PlH�@"��Ŧ?D�� �PlH݉f�P?^|~s}e9e��^>{~FEusX�@{ N2}iq&Y��T"98ݓ2��RH孯>p��UH{:.^p��)A$dwc'O2�@?{p-E�O�J7 endstream endobj 364 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 365 0 obj <</Filter[/FlateDecode]/Length 711>>stream +HKQcs@(/:maAeEIP6^P6"%3 +[CBAbږsCJLbig(hrdGx>��������{jDr"e濮.֗۝A��� 'Z68=5:~p36m����Ա/xo���l|]���PU<:ޞ;_B,]dBaf3y����>>3Z \>$ {L$l����C2b{Ƕ?_+<d����(f)1{)i07{ˊݫݭD'B!b9Mkrn"b?8]Ϋ] +vًݓl'!BvXE?42xݶu#pFOg(!@1΄,49ɹ +oUuaxqHy-ﾢdO~D,`J3գ FoߌEZnulX=wOwg}=S5uV5TPfAooZ6< +vv~3Qc=PgQc=@W>:jèJ3TB?��XTB?��XTB?��XTB?�~ 0�2 endstream endobj 366 0 obj <</Filter[/FlateDecode]/Length 334>>stream +H;JAv6V΀LPl+Q`#pnuH!`8iյi=a3�@l3�@l3�@l3�@l3�@l3�@l3�@l<mm>�dR|vtP��dR6} ��2)yVs�� ۗA{�� Ng~,.> � <66edM��d2^=w~]}��c3�@l뮾F�@l7F�@l��db��fl�K endstream endobj 367 0 obj <</Filter[/FlateDecode]/Length 569>>stream +HMKQq,\jUE殏} +F Z ed}b189)-[ ~Ghyy=]0fsr��bqccVc �]1 龇ccM �-1 W3S=ז0��5"?>ȅKM �{ v},ٔ�`AL3wu<��51g??}|c�E &k?8d��Ĥ}nok}}G� zs_GJ�'g�ll^#�@UkB��64?ZksDW=;ʥIsLML_y>woAa=)GVo&X/ N]9/fr< qFar!`F%۝KeA,+/C;xǹ޾KW昞lzض;ʑC9C9ضեŢA,��{k>�d1��FL3�@y [�Ŭ endstream endobj 368 0 obj <</Filter[/FlateDecode]/Length 705>>stream +HKaGYATPvF]JҥJ +Ȭ;tF&N?w, 覠@J;c=N\k]w~؈8(ާ?0mmY] C<��y fzKſdg��y`OnF���E^҉}��`n5D806;"?���̍#xm'ݱrO���07Jv-7g���s#멛*/+[}F���07Ƚ6{.?:=^mʪ!^>iy_eSyJ %<k��`k}&9i?&{ҟ{g}$[���igOH0igš}ĵ ��f0Pd8*^T[)��9?BUiwp2���S]Ybs��� +dm{���D}?Ӊﯣ��� 'ȜFU-̥_���92ɜFUb'[6=���j.Ӻ +?nOkO3��@g7X-|{҉Em3��@푿YkٜFU&21m_ �~: endstream endobj 369 0 obj <</Filter[/FlateDecode]/Length 730>>stream +HMKTQƇZV"B(^B(|d*GMSzu "{x E"z ќ`fV'~]w +��룓]J|\mv$X~ ���B|7?褴?vlc���&e|Ǎ5TQ���L<N C5tR ["G)���LXF{GmXJN���L&ei褼?fM'.���}gMy ̶N6> ��HmͧgtROFT��`1Ǯ )PC׎ ��D,챼etSNM~S}��^򻝉'o3:Ӟu/织o��0ѮEtT?Uy���FK0RtͅBU��`ֈ<tT?C=bwk\}���&) FhRʼ{��0Iv#Y[ZLwv}H}���&+ZM@W +7;T��`K]ַ>E@Wo��0&.{]U돺nL���&؈SԾatU?ͬzo�/~ 0�Ÿ endstream endobj 370 0 obj <</Filter[/FlateDecode]/Length 993>>stream +H]hUc"TPX܌ TA*zKnt,QVPfפYb,m<M|Vyf/eU٦݅2/?PZGDOsR�;N6eaxaFu6vF˃tk=˻[cv��P*"&?^?W׬=&��3k{0Y u۵>s��}~]&?)Ƕ {N���~E*Y'='��&t8P$G0B\='��$oI=OW,'��HO>H9r8p??t5��D&[kbZXç&r׹Cݺg��0Qı'9kf,FiY}'Eݳ��lR4*B@=p?:SvY��L4w&?PXםr=.��QZ-,r_7cuK3Ppy��L}'Um 0L8g]s#m#uM+u��P$GI\%jUFI|猝ۯ8%Kt��PS$?93*W=AOF)ڙvο9챫&��ԒP`o)%꬝ah cKWxR7'{٫ +���5"k咧.S&9z476u|/v~)uG?Ft_��`Q52)Ir_:wo FiYuRxHYo(5K}ax�� $i>KT:p<W.W`,FmN?Kj[Iɟ<P:=<3Ⱥ1ioO7��-$/ͦ=KoQBb`>`C�t! endstream endobj 371 0 obj <</Filter[/FlateDecode]/Length 1693>>stream +H[LgE8"3S7l +鲉e4q +8t8D@ +-IAjaHa<0̢مN[.,j['ynm^7>]]GFժJ4jY==g۬+}1:bhRh9Ul c mwiK/9~���xFDDPSUѲE/k0456�[L(o^OJ|}Q8{whNoa\vCz4iū>'���H"K;\.Nb?u$7XѨ?T M?<>k~C@`��� +ԙ9I`N6m\HG_?`UʛY|p PA0cmzc<"���͡ҪK=a7<p@]hLaⓕjgk 1uH*Ϗk*0vkʻT͒���5EGƺz*<? ӘFQw2~L?# []vl +uQ���l84́zX/QGQO(LZ^c5%ŵ5sG`x =X9lI=se ���`#=tmzn&;+ EF:g''V%-ȭ+-<ͩ/}o=SRZ!I~q6gL1O1-~wN)BUwB[)IX����V]dNyrq*uakQ6uEQ+o3{P?s< |8m+7Uw.e=1"_���lBlD u_#ݗLRG풧}0NHq|S_xTɿo(St7߯炼ժ;sfS���Xo16n~TɫH3K쑧 4>_ 4ÖCR;V YQ(?���F98"I!u_֜X맻QtES{t_}C?h" ϧ>*[wG1)Y���`)n;=|MǕ) qͅp1"_Y%+Җ)z[|ŭB ���`VN^-q_ Q'z)RVHφ8egX-ߝk#?���0 SDYziu&7?h:Ef߽{ܺ>/���Q4k3jka�{biV.Iі)iEޭ47̛m#���EX +}4F" +I2�4Xu+g[ WUuTg5N���̡Z}vgst}tsCn,`o̵l3>yK{jUWWk���`Xo9|)N}4Ĝ!N-nrStY����?8(-<m{J(iǔXeꅊٚyΩ���0$fz3su˥ש&V?ޘ{ LCWwQ߷C?k�`[�D'3 endstream endobj 372 0 obj <</Filter[/FlateDecode]/Length 1533>>stream +H{PTQ9>Ҵ3e>1ݕJ߉d(�r1x,>ػ ʂ +>rD0tk& 7sٻ̞#�e#qDҹS|~senKGQ{ܤMw,o?3Fx6c u?}Q#7%a���V}٩7p3? 3W3W<t㥹YfJo&G30@���h/UO?/78s٫",nX.OI-#~���eM 7 g[{8wB�gb6k$_L͂1>|ޞ^���@l 9fʮ1~$s8=y +19+:rB|�A1lI;����xWW*6fp,_qO=yswYe�?F6YM9טr/���!V_Zl4,SԜo,q;wb[^Vs3Ǝ{ ����-PP^Sh T ϵ9icUł)@zE +qɽ���̛lK!.٤ nQcX??!{����TISߪ|84|9u?xKL {w#:Z+.����7QYT{p\ +#ԝ+Y ; Nr���@”jYTZR?Fv\3urwsdpMYS&Uw\Air���W؜jbK5o?�ZϑgIunh3ɽ���41;Շcf2,/I: GP\D&زǴޖ{%����ԯWo&uWCę|k25�mf/ 8]Itm)=Ar��� !2ך>5S=9dNtq3??^BN}e{Ges}^ ���<zxue/7 +)c8Ϡ�'&/}1S ս{>5O}:nar���..4_5qm^qoRSKLz#s82:ē{5g::٨&j���<ݕy5Z0ewX@}2 +ms OIsCYd> +qF]+#&]cAB, *6/7U���㭃BA&N"cRl٨={cc +W~rD9N3詪0"S�QR9s b/c?�\giZ0SoY#AG ���<|xSdppWa_91liZ- -_?o�B~5 endstream endobj 373 0 obj <</Filter[/FlateDecode]/Length 2353>>stream +HyPTWMӈ5&*.(%ƌ$Hf$Ba4nTvQYѯD^Tqc817}hJ"rU*骖}`,fN:6Q-'bRª= L]9{L+m?B" �pyX*ﶕ{,.kx*8az4/!9d#h2LBiv?-<'KB[?SSFx)+YF2їp@[2$pZu}�sڝF^ 13`mo+XlE|֤ɴWBi-DT'D{c<1Qk3NOF,OO &?:L!c'G@" YarGі`1h0—~ըxhQ~ k| ASiXL5= cCM/}A|j~BjO{G!zD1 Y&L/P<Az~bU[m5;jwokٷ 8">.>T;E[P~U7t=/n&2D>MZl%X}.-VV ʨ=2E s9t5!B}X$E3gA֭o164oȻeK?4?wU='@툁P/+|eϋ]l+7ؑϲ\\GJk=�Bօu9y'O6B%&B!̳;v ͓ i$/dֵT$=BPz|Br ++?z}|d$is4t}[ WL4obګB!qoXQՑ|Pqz6Jv;=9$|5 ͜wvUV}sƽ6B!dL2V~.H ~egU<PĪ< yhXž7^_j®p}NPK $xp,Ӡ\o\ʸ",BD0u %Ac.R'T*o-\1f3?_FiA 3dL?> +Zql톎]^B!KB�ƽ;-X=7Cq>lyIg S͸44rㆁvi+_3lv:26|dbɥ9u/?O9{B!Hg}^+?پ}HұsI(P]iUk(`ko)p_:NX Hs{ː<+O c÷o9OCxp[3+C!ޘIcƂฏψpmL -/ұLcg Szㇲɤc</r~*, ҝg> &d.\B;a@Ɔo˅S]+.SsE~*|!BaĐS;߷w61~Q~*l9X5gM6)~ pύ}H!y26|d$a3gj..xL3ii !Cbl2@srwvkyڶ^O v%i3d?ﴇ+ӪX@ᪿrFO{o!o1oCߡeߵM}[UyVp[ޝ! H?s:?U>MrŎ3d?\8!ף9XqmsB.YM�[q>Oޯ7VWnkO0I�ҝkW$big!XL94WK Xu!, MN΂p\vV yʻ{v՟4GO{d-B; a@ƊLVc3 mU +P >B}H33X`!8̥dyi*l喿w= ˅~sCN/͑@?Po! +;ˌP{.Uv㹿>MZ +>qf3E!' 47%yՅ8jWA(s3NL+`Emy@?Po!?c- PLw?Ȝ=ɔdzxVw$?5)׋B 0�\BLdLޑ__Lh^є1Qt�i2Ng2U[̙6yu~fjbHy?b %竗Y + [_8i6=`�'9J endstream endobj 374 0 obj <</Filter[/FlateDecode]/Length 588>>stream +HKKUQ ZtA5ЈT.s IMD4Il`,P2'/yT9ɨP4Y;HFXmR{X , { {vގ_!3�@ؚH � l}m5B��A,(,;ǝ}wqŞ4SMr!r!I1yK=]']w{`wŞ#)J9C9Ck?H��>ib�f_#M3�@ky�}41��aLμ>o3�@k$5kcO>͞�@rHrwnۢ��$}ތ~(��f_#tϳ_ޝ��$}]hh,ʍ|(-Y5Y��H6wWwO.N��H6}jr(w�@Q-s9BCcu~c%%o~_ov5|,C�W~Z4g7gR=g�7?o �[C endstream endobj 375 0 obj <</Filter[/FlateDecode]/Length 2290>>stream +H{P_V\Y/Ubo bR[ͥЊoD.BTP[1uaqYPAqW@A*qm21u{Y(њDf~͜;}E7WZp<>nr:Wen1/VMyc$UAD azF ̢f@w{FG]L*<.,lt6u5VOB=IoМxl_PTT*��1kLp}knP$ht vf9Z? U"~ +e3X=۫u}0CvN1 +E ]g-}Hǧ���GӎτW[}!_Oo$b9Ò7^y?(W*E?wsqe=_:1s騠S;X  )[b?��3͛rǣk'Ω*ÃaF(ǎqEub4cayי]|^sO��piߢQ%YQFRg׸|,]>,WݍMToYrBYs7׎/iX[o|xxvu( meO��i ڹ~(}fZI5.8inZ7G&!=>#/Xu?헯P?g^=#{KX,#։]91&AZuv)HzX���D4ՙ;"©<73׵ƒ aVؼs.Ya +v Q3,ud,(WkI]jsziṷy眄Na0o]l{ ��w^{=qӥy77ӗESN)|T?_Μ%_84p2x{ g V)Krh3àTՕ^Ҵ>`wv��7_=Q· +$ v4rΚÖҺKϥ6-Q^J7*yg f +>I6 +֤Hp? קN5bKR#c{gș9oކ��x$cMkM}̇'A߀|;%)m?Hu*^{4/'3f>rC'i'ϒoK ��2|A)rB^{z+^VH?{BxH)Arll fHn$΍Βw:st +��6Աhkh3Y&GӪb`,5!vNCr&4cf.U ++wr‡z͞b]z��+NÆS{2T:bՕMn&:?_B('W +/Xi?-"Qkt7*:SZ4W��2g{Q U\ۿ<|H +"bT)o2Vk1?~v\)%jLO;{ ��b΢$ڶzҜX^uNxAz?9i]0,G2Vk`& +m]gWi2}yy#�>Ύ^NejLzu3JXmAǂώY^0[ 3 e?f@^$ZBT_~_|$ ��}˿mWg6KkջV}L4Q/Z{n0s`*JϘo~hS2��WdR)͟9vGD8rǛV6늕5F0k!byAn(T.{XޏXՒnH{ ��(G +\q+3M egҿ<nLaoy[.eO#]?#I^)FY&f��x*Hst0d*c&6ә-)y'<J,'5 ,7.{`gϾ6IYsh A{-*p ��?Gλ%v¡&ͿbUӛw?-#ރx~}G >wfA3`� endstream endobj 376 0 obj <</Filter[/FlateDecode]/Length 2016>>stream +HSƿ肗[1bM:IEm4 i1�Z0 QК a@ \AD]vq]P'fR1{tZX4jny|sy<DaYdWV<Uv Gǥ,V{E 9aʹ5B*}��J$2:HE{5ΆĨ/LaMDh5me=,�a0Ӵ`L{ +:_Rr �{1& ~?HOdL`hgZ(1ZͿA8\lJ'b R5wW�6bSP`S͞ + �L OhRΩӗ<Y|擛Ӓly@ pk^XOU?�X3[_eLkxgO&u/n�F2tG^q%fƒ7]TJ%i;b HĴ?fd`=14|[U@�{ǡ9Wi/ +!J Bw:kS`͈Q?�@Lkٓdl3ι0|+�A/;Ft{o5 B_KdsD�oĶ?fs9yȉ<b.)J}��q?b-7 +3ʴױbv[a {hK xw�`WڭJwuNx�),37[7ֺwF2壚q/u$ZſwA!O1vXw'�Nĸ?m_#egs*#ֽx%�0<2UW,[V]{oƔYGip^gٿxw�D렶˼3S'z�#H??*Q>yT_n`(.~+39D + +BxwٻR]#Yuf~\-':yPsvַ}�G~8e%v=~Ew9>/fp仩�wGTNVUM{aM0c¸@�h͋޶%\ac(n9Wk_OQoCmj]-�wGrwv}Ӥ&�!|3u2fͲ|CQ]cOwn9!nTJٿK9w�Wd6H{hF8t]0��~�&S"FRn}rI}~tZOeg>{yw�1fbiS|˼2J%rZu�H??zTƦ'ʴg^q|39D +Byϯ) [ =΂YQ3mC[1?�[0k/3%ye7',3Eb]ɿA kk<c)w�3R5&.5{gU*"؞6w��ܟIAL!)g|eC0^ђC D9!|2u˩ڿw�cU׶C3ϩY )��C%QԯRћ93UK|CosI_==΁T#mb̪C0t榤�:~R)smÆ2l~N$I*]BX@w]WGhF5YfW߉Wa΍x�| +YPNRhsIqM0|ug7[R0K"wi,%{ߧ{y]W3׬NYݖX쪉'r o];�@<:2e],V?A[s`w6^} �" endstream endobj 377 0 obj <</Filter[/FlateDecode]/Length 2140>>stream +HiT/8BPc֭Y#iņ֭YT"�*%BuEQQ@f@fT"/FB$bGSĞc[ 29g>BI$G:4d fW5F7 �Lv}fo]v,eQǸW,s׫myAo)brKq썱~sQ*6`uۉċ1Bӳv/Sw,c �cNSķ{&܉ �cF^%QӼqAeܡ֢yc/I-BӖq6;'w �zτ`޶Rߩƽr՟JT!VV0i8hJ+q򾅝?y~KO($y�]B8|R͌ an0Hofywek.j?D\eͻ.� T?6Zzx^-gàQ"࿊o!WSx�s^…m:j+QJ*--y�X +:i2m_Vq4y^-E;ueAR?||T0lj"w +�z9a;V势ӊCGsx2`v ?n޸Av$RbnR0/c$yvi X9c} Җ}?Ϲ; +R ]�ml}w<W+wQ+.2AU|B|x~֧쏰K �;5C)C'Օ}ݽèLB@b󢔝%';y뗴':BSM1 !T+~R+Ѳ9{@�wk`.JlǾ~δ=zbP`aD�N Y3ouT8 2+ yP|F C �{9C)S'-˺jJ#\.B�&¢=Ǭ"9߷D%{7 I6˭#]X+~7cpcTSlܓȵl-X[,i+GK4.4VLj-7J5) C3ņ8y� s6$ Ug2{]Gټ?w� Ga7k6ܾu9QZ^ld<Wt&jÏZ7-D_{Ҳ9-. +Cܹ� scF3hO4w" +d̏9z_PԱ;ʼZpQf$k}Q7�B&ћV6΀@Ap#P䕵=:'`\ޥK5J׫=Ůeqv5=�B_Sk;�}>+v'-^kYkB!]7,"bdNhF~?FmKUlBkѼWI܇B==Fy +�2 K!$k.;QkjPw2 +E);c'dwާ&v*skÃh]bD>g=$/|fs@wfNsRQVLR?}p;䏟]k ;G5/(eC^LAI3yxXޤ9%v7 +S:VmO,%\C@cwϼw"H^֩2qhP�ARTbzRZh7칿CY0ORkS+{`:"Fq _\U)2;CkJԲM](%|&<dOgVBhJ~ZK3E�.m;,[4'FFz?{";^~=R9ܾ+ :vol:m{jvgrFone,ԏBSúO' (Tɾ<#twh'ɓ]t` U*22w"k%K'=/(2{a|jyGz߿+6eyB8XűҜ<y=˼w  �g endstream endobj 378 0 obj <</Filter[/FlateDecode]/Length 2503>>stream +HiTW',Tk7:`ԭ" bQAd\jAT"HKB ,jQ +.ѱUp oQjkwfN2&~c6+@V-Ї4bCWMUL>}\JL̴EQdJ֊#nF g8CBݸ~74@U{y'ކr(=Y?a 7Ox&&4p3DåRF wlLL,j!߇ +&ړj_GX t!UQLz1;bHQ /ز?s?<MʤW봿 u^X +ǍNZ!KbDcadY[VҦVx߿!>"KeWEӾ ?0YwOƍ M4/[8(7dBM\l�<ٳHmy ՅeV/L)o)#Fz)zAAr۩7NB&}BCK)'_ѿiT ΰC֎zl_50(HM)$yU:A~Xf|sIF;GdΫz>ʶ2{7><,1ffF쑠yE"vdoWg.=;b-+B΢}ܿ^{U̐!79) LF~c7Uc҅) RvN>\g%  żC}}Y` >>#D2kd^YpҳL5lw*BWSݫiT QhiA&/xXq{/jx?]u�ID3ť} sφ!KKD d<}3o�=D!HϒX~UFr"| +l <oE> XZkQaXtgi`> 4-D)o ٣eLj˃?݌gC3B=ҳoI~UF/L.Q{(~Vs8Oqk)#WLZ )i7¥[mbj4V| ߱�#NEVi}9ʧ]GBWҳ;/ +:W3\ +Lʣ"ewT+ tn&攷LYjaw �B}BoV%}KUu +=jxO]M Id RySƘľ&IbaSq%[QB+!ݑ~!=D :珞1X «-<egs&5`9ux9M Sov7# +J .�f-C!:nII :珞۞<Sʤ=ZVy,-姁W2z\<< #JRy#'I" Ko/0k!T - wdWu8`)8BvrSIs4g#@#5w)u} сOh~$.:@*\%8ox\vꝄ1�v{ !PrTUү;^QzM")lҳqĢfSc'*{L}U&Wv-)'߹rX},B۵ǖ?N ھ�ҳ/s)�sbjRCW^)bk +ݻ$YƗv +򦢓Ok=~ak̪HO!S}nt #IHzv8`)8>;#teg,Ęcu\f�zl;_CmMM7j4,1xwDp +bassFkcadٟu>|5;;f&=BAtsL N/pSpx}znP"ˎIٹ5@kdv[ͦ%95Y�ĚXotЁ~.[&e>-vX;6hwut{DAB-ˌ~'+)2&FqDur%s8C @`OsBla|_QfG*Փ6m5]�ͱƬDžKGպK)ןM)eR2 y[%e?>w|}p?V><هv Bݹ/&7v'8`)8]$Lhxsg �pCNb73K-@!ޕ ~cb(.OpSpxs'w9h �Gr endstream endobj 379 0 obj <</Filter[/FlateDecode]/Length 916>>stream +HYKaǂZ 0m(lҤ *2Z,P(MqbfL[h%CI"H"4 ~_˘m�+gtF}ϽV>sJ*W?@nYZ!Xg[^ZiC^ăor:��Jz'ޔpa5~Oվ��$ϓ̩>6MAl +c|R3=鎅5w��MNc'mvw{mrdH4�@ޖ.=)}^ 6ڶ@Wyi� YH/vCCoiw?Ma8c#=yڷ�d12K&kw?Ma8Nug,.{�=H/jwױ?Ma8gIz 7j|��n^LvG{ZuZ>}��HJVjw Ħ?q %^k~��>\^_m 6m_G49O�0Ѥ/>NΗeţ��Le҃KNw-Ħ?Qqfg{��3&bSXT<|[yG ��(?*~ozۄAl +=5}��NOw:[m 6G7;;�� >|=? .~O��1 E@b2p_ok~��ios^?MaowYƿe��68{\ڝk+)g{0 5 ��"&o ;Vɱ? +0�ڇ{ endstream endobj 380 0 obj <</Filter[/FlateDecode]/Length 1002>>stream +HHu- +DQ3 +rVX?9l,[uW9~s[չkWA<_ug.`u}N|կ3s^]md6� VN=B6i򽍱rG LET<ܪ ��nd1ҵt}ڎ4Yl|/?١ ��nW>*tmk;fӸ?kgru?tE��ܪ#pP.`6j4_y~n��J:&={sz[]lGu =Wxn~��pۍrg +fӸ?s8;{anq��p~:4-ɻ&��n}_-{h%̦qjhbӱ̷ӑ[�L}tL.`6Cϫ{W_yZ'��+7TK^j톺4=wm0#c޼7q~e��p=ҩ f>~i75̦qzaw{um�zV2MW-v4}ttל_Ln ��ג>x.k7U̦q{^b9C1��\+ +IWtip}iC3��\%]>I[2V;<?Gi hb?^Zh�rCGO)V=l|/(mbq��x6 ]j?HqR_:2ɣYQվьN=K�K:t*=zN$}n?X)['cgkpP|͏i�<.=ݥFp]Ue9zQT<5�t(<n"Juow?td;VgT^bR��;ֺ endstream endobj 381 0 obj <</Filter[/FlateDecode]/Length 1145>>stream +H]LuU(FZ9̲�^tLAE<Fn Yڀrtp4I9(r"Q=YЅU[̫7GpCu!;G9 +�͟ûku/'a=Vhr݃)[hQ\{Wg~cClG~fTݛ#Ꮁ];�X8;ҟst3|_GdLa\v\Gy׵\+vnRGÁGOt�ppq0ڟwdko!f?eի[\ X6<^ٺ1SN^yՊuw:izC-uc_î\+rB[&fҿ&Qw��[`mt[ |;|OcpvBWnB=9.?傘dz{zw<Z8k۪K�� }; {s7 j uʔML n�ږ%ɮ+I>܌r~cCla_OމXG^'�lS* +ClΔ>wClaڷ]可ܺ�p_V7IgD{y9f(͌Xww +�߼}oa;2#3[�paU~?2ݽ�r˥+yM)ٱ?8'?ZzvZ]�0tDz,(}8̎9fI"VhpQv�5uɳѮnsұ?ScyرB�G!l)4ć9I+Q}Vϓ냺�0C:r'?8'Le֯X Rtw �`tֺu cpN:<ں'O}ڶ�ҍtDw?c+$Q"�pQt#8Qw07I0[M8bN5�} TJzQ򼦻];c-To80z6�}5|(.sұ?̷[&Rѥ�K]J' +i[�\. endstream endobj 382 0 obj <</Filter[/FlateDecode]/Length 952>>stream +HMoTehZLܱqaba)J` )Qm4 -*&u]Uv̔SK6Z0XĤ&-s/s :!=_/lY0ZN9yjd=7�O9釮\_VB03&kb!V4'g<�<=bA?- ̱??K'd<w��}9'jw k!隣߽{��=c; +aKaҔh[$9{Q��zH4~y`v7xb)[ZWз`ft~�JO>K/hw gY]_o?݁�zG҃Ꝅp??lw] N�3vIvjw iUF %$�=rS9omow s|yǣhw"� zol^+w]*BR\\آߋ�ȝ{`~ARo;gM|vF�љ9?}AR~T +~�OoIW;`KaLkͥ^ = �urkw (G7jw%� <+;5X +|oo]W%�xwᅶoiw ( rw{�0srǯ kw (/?iG7N�=۷;›Ziw (?2_5샟+�QDz_)( GYcƯ %${�n;.\SPb)ӝUܶQKg�} endstream endobj 383 0 obj <</Filter[/FlateDecode]/Length 1127>>stream +HOuO;h.(Vvt$ +W [6r&bJ ZH4�ER<G)?% NKݒS�ncyDž/·{/c�P13Ryn{JJ:Đߺw|kYe#X޳k-,-E{ +�XuMh٪}CIa$ʲL\ +�MzZZz[[`q?Hlv%-ڷ�[7Wܩ};IaHEMW�I?KO*ot?7͗AX\; �Izyã7:Ia@}Z&a[ �i{/G{ZV@8)̪;^3hK-�cot?s\w[ �0fg礗ot?\[ZI0՟}w -{о N +s-)Yo;–m�po?zYޫ _k`�HDҿg-Uo=~`⤰?0.N׾�H3oA泤dh}C@"8 =} `bd=7W<Pggc<dTA޶\ �N&=;s']_�{aѷ67ڑU_]PնXaVܟG̅ �N6cQqa;&f0z9Ro-];~}�'~h-|1uoN .MIߩq}m4gdK'_ҿ�$ҫ]go; vLg3g]E~p$)l"Vjj�p/.}?3L xԖ32>:);`c}x:Q]� $ʮ {cH Y軌T-{MMKjrZVi +z6�ΤGOYx-�) endstream endobj 384 0 obj <</Filter[/FlateDecode]/Length 1220>>stream +H]Lu@<e5,nEf$&jh"`2S9 =)Gtm8E %Ec9g{]vw>'V"hEO)Bm^Pgl.L|g.tV>4of +}s1 /9r\N8b +Q_'˻듕�,o};mHv? t~@eQsimv c_2)_wGoʻ?೻F93꾿f;Ifޠ|7$p4QǚGV}[!O?̚պo0}[T벍H.Pi?&}a Nc`KS 3;~ + Ys,ƓT}穻ژ>�#]{USzTw8$X*~pɦfګO̞o/<>~<?ZnKoUY0 D +6|goap6 KQQ[60:�k+vQa<b?+sv(jk@0~ﴎI_Jon),Ug{BN䴯;�ѭRIKݝ cb3V&xg#u�Lnt<Za\b?Q[iOKif (%x*=a\b?/?LQ_G/{ꇛS�]zf{q]; f +\u:f|ź~�iJaäH c3˷V3G׋@?ݛ- ; f +/N4{]K�`9*%wT'}ab?k-ɪ>24Ҝ=��ԠqDOzPw<La PvD̞i_Qo�XJv}a.b?Hy֊W|w�ݡ򭺻 f +Nx]�z/ݍ{ f +D.><<jMN��^pJI\),׾ik +�O7OH:s f +%%9k}� u endstream endobj 385 0 obj <</Filter[/FlateDecode]/Length 728>>stream +HKSa evS]PPQY:eDEsvٍ;zIpfn5?UtўDʧ~agQW]-.7_$cӱid/k#GG;#mM?���J[^ O=JL^w?f��;wLM򩭪���]55޵-��@73+��@Q,2tNb)���(5g,ɝF@NL5sZQ}���>;.x*$?wT}��� +9;-H@NF.6��� Dogp#0e7c8ܢ&���aDZ>,4p?<rXLƲ��� Dae'ƂitP<��� DƶNlw׫> ��,0Љ?N?,}��𲇁[.;5QF@'9+2untS]���^f.$gxҰӦA]���^b,!GEk捙W}��-V?>B@71<(Ӡ4���O5kIihJշ��xѓ;Ur )=Mm}ϻT��E]cy覴?M%k�xO�bu endstream endobj 386 0 obj <</Filter[/FlateDecode]/Length 977>>stream +HKwO`)q#hAE0"T$(h X"2-md!~=js fZТb` +]/2hE~<}9�?ۼdzt ~wQe^_}R(o흢y]k[[޾IorkG�xcg^Hiw, 6ש`$;n��/Bk$>^V؏Al +[U9)'y>yV�$}EzlgU9ڝ +`:yw3ۊ�?j] +`ܪ&lmȾH=�㗦|gN[Ǵ 6-KM[o99XW�IUg}A/?Ma@ʣ;Ls'z7Կ/�`.OWc?}+-?Ma@{0$2ҡ7�ej$JOm U/L`O"ynTl׾3�`gI?U4.J<kM�ⱳ&Oz>Ѽ[#obS773hߤ.;gzbQ'펄?MaK:q{:n}^ҿ?�{Vz7bSNmNG�"##=$}݉`l-w93V-_fn=.#=݅Ħ?Ur?˴�0 +-s 6WbS)'wz]n|#}nm̭ZށlbS7kJM/><tNտO�i陶x`z 6[},hݎxPN`tw]Uuw0)p͢<t_L^`l\~ٚ /:=ZwBf`鱺Flhw_ �+U endstream endobj 387 0 obj <</Filter[/FlateDecode]/Length 1313>>stream +H]Lu8`.u "5E/liòDh3\$ቈ ,^΁pDYmn(Fմz85 ֦M^s=>s{Ƽ]R哸珗 &ԇ1gzܻ۹zL +�T_M<9u.;�Ӡ@(OU &EF,�iv`_<HUOK +w,AP6?Ewu>}�@hn5(7_j;�APq[%Du=�pA굺)G `?0zUq%iqȮۣEw �hF\q*{< B3}l�}!('(/(7 I`4RjLakZۄ#�m\|HV;�A�=H7G)4=98�@yPwV,FOz}b3忮Wo�ІʅXXny�yֺ\= Id~(r=%�xSo[t>r;� A�*Hu}mՊ,td侃�`e]j<$@@hu^p4 9Ƈܮ[GGiΉA�=Zrhu7uJ4Spg@`8̝:e\cᑣaݍ [i,8i?@)+ZV7"wNX}@pўӾ[<]?wFc9&EE=E˙+=s}z>a/7Ts :N~+.{tћh-Nz\> ٯ]A<oewq#�uiwL=}`@hqN;nPߥR[3)a$gY*91wl>*:<Au%�>_'eu Ҟsg @`:Mվq[}3D }E\IyA~9~7>[=;c� a0,Sf5ڛLoKt}ѐA=sXM60 �;[� yר,?1>7OHG~le:B҃q);?VQ�d~bD_cgLX `O wYFosuvvG"<_^X}-W�nzc endstream endobj 388 0 obj <</Filter[/FlateDecode]/Length 3104>>stream +HyTSwTˌբej3֩[AqS=tjbE@d@XjdՈB6e{QCCڢL3Zڊݙsf.hup9~7߽_w1=y݄faNBg#{L D�ꖴ_C} V\8ZԮm V@Css&%2k cx]o2,΍$ 6b7s! +A* ^n~پCd<> R(;oU:U֡@&3K@d_e6  uJYKALݲ}w x]#hէ }yeOw$%eHP +nJw'> A@]B}Z,7Pl?׾KŹ KTrYz)A 눷 L^7~ A_E{X\^] l͓lǖO9S5uqÞi'rd9Jwh#/m 2ϟ+04%M?R['m֐)gg=UU5X^%k;cŅ]o.y*4Zu}Gav5!6>VЊDb8Na'?'Y_QѨ`*awؾ''"ywtwվz߅ 5/Py2AI6^#])\EŌ͂""hf| <tV;(wYm[]n"o]X'"/14&@.FcT8!eǜ9[,COa؜ +tҪly<Bl!/^$%Y`hkF<_Fs8ON`vF7?WMeBmTCGKahd?2^hGFk?iá#?4(Q/8c"UZrʳ(wI { Je@7u(gzv#}G5g\~fJ ߊ½L~ݝr4{5vy }x:g^%}\0lԱɿˤhWja @$ }1i8/slaN,Uu'4V y5F1, ̎ V2e&瑦IU,]u$vXq|o=2Ds8n龁g8 f+th}'$MZVdz/mQgnQd߿F:d.@w'x+-yЫsZ+X�pdm9[!V$z3Zu}B1&m:u^$b-r)I&9k#)}~yA1pegM/̋=Uo34YɾZ|.ߍ23%><bZ,}x:?_Jz+76g@} ;͓l<^߹w UrG +(IkŹCI6V㳔qYϛ1@8| sX嵌<am]dU6wPuY\c]|#?�o.p{7g z5ޢ]hi@]+1R uv#͓GHY”\Xu$ᚬ /}HZњzb8uj wE6Ta'?wo$/ҝpY`x΃Ҳ7`&ئָ&2֢]cj-IUfk)@=+Wyl ۵ +4O2wOoqn$tYL1ӣ8"y ΚLrX嵤K46ܺStI*o_lAJX춺P%AR{]. A&:PGPOPW%l83?<A,=5yܰGuX�V$z3Zu}B1f:ucmIh.04%q//e\MITY[>)`rn" P[}iUGbt.LϓoKOcωC?\ȯdsޢCѡ߰]@$73*9ͣk$ݱfMqeAα<uM'4ˊk^O}t_1}?26iYZk9 ;''c{UƌsFg2}L4R vnmJvM#D�'x鏃-eKFCkYЗgsӐ2>y%/8c"U[cfG+1LNCHןq h9_"*k;aI '% +|w#^im`'r9 ,QflN}<Ź[Y/=xgOvߖOgCߏN#n~خe(@$/Z qE^=Ub>{6h M)ޛo Cc<hDk7&k`A1)I&<RF8 ]aJ >` py)} z3J#Wyl 3r:l׻KBa4T-AS.EPSKKQ ٤Sӌ #¡ j.CMy?=c> ]sIK^K}'^9̀u_(' u ^1Uz/֭;iH>%ٽ)՗uJoM$ی}JmS\HXB${=ґnU8t8@{Uk]Q?sE(e{<FC(\Z̔)Ja]f% G*nwP8~QZ;(s0uf +@m| ʬ{%}�kV<P.Nhf?Pr*�vRJ9IF_#-?�VSRrL(XgjS�R o endstream endobj 389 0 obj <</Filter[/FlateDecode]/Length 3506>>stream +H{PTƏ +!:$&&#ZBJԒbT.rp\$+*²r[Xv.Utrljƚx!f:MyKP+~f}9ܰ9*&1 ][~t7Z;;uAGNF+7+]<;IjA<ybs-pYdj +f_Dc?C?HjAãriaoׇ_@9Y +GjA/4qlゥbHu"A<i.ojbsFP)[Ĺm}]i{mox\"r&jjp̟fTnXg3==3':kΈ� +5#A@3t }CAj +oI%xjx>٪㛝ex\"'ō#+tHߌ] ձoto`_?rxǝmӝq1P3?(?|qn>ި'5Lh`OiDu-L_u$A<*-mkicY)PSxX]2CMZCW|֔ϻa[ LM &ܽ۟甙Cה?s +V1Dj +oBuOyzQVU6Eۓ3ҹmﷵnSkXhF|:&7Y/u1D ++Z9}q,WZm3Uã7-}XC1E uGkԸMnI֛Y8e=u AŹOJb&vXɎo?]^0B>>*glfQ (Z}wlɟ +KXy\iBqNY\&8M7k=M/wρtl3Ks;p) +BA $P)^-vs{Mܡ-N˙ͺWWԸ+%I}>}acn;@/~$RAfTeՆkP+{kTb>n9E'x fLIYm5$zy͕3ZSjz{K3L^ +ki?w:M{߈ی[to|DUDU?bo ?yK-SMK16 9c fj<]XkЛw3"}I'#/731!A6ϡfMV*ջL>^^0unm>Zlrcs7j./E`<*vaOu>OsxDny^6v79?&$,o^{k}Sl?אr3uL^G+%.z)כ@n!Re]sy84s{+鼖smob_wtxMwk%BBMmcbⲞxk䠞|tr V3>!>nօ>k"{m:i="ڟssD)lڻ`roⳏ>|bAAjKYPqf/)Oia[ER7ah5w(Էh<c32B'eb?քi,,re][Y~!]1!AVh/Ͽ[9I1>_?Kt7 GKIt}I~cEvОq93;[b֋;{`>-ƒyʾvZ3xλl.l!><m>CuSFU*{brgCG[aNxtsي9<Ȯτc?o`+\F۟YVEC +0%e;A +u(n_J_+j]=Q9F+Խ0 +# +m5?ϡm>&{qڗj?[>.X.+XCy~˻ڊq>Nq9Z�2Q(wG:ݛ4 =skSE s&+ǖ: :C܃>.XYץ( Cw PSx�y䠞8TTʟL6`<j`�Vm +J㉜0kߓr^%=G5?ڗ3*v!w8-g<y]Z{A.c#ڏ?ʾF%t}Ag[Xk !AFoID̋k96n{% #/Ǖ[7=='?"bh˟OHX#W; /#OxZ?/[)^ͬuTO�,}myyn\|�5b^g=odx\/^8hƙt\xS0AOAo5OăPSxXS:茌+&>{L^G=c5#?Kq>IړzRzAT,I#*2D43g D.Pmvͻa6,APA?ۡd~}|}:6* +8Vf:hq%;5l9 L9dRC88C„98b9'ֹ1utDf"yhD=\æxBAGGP!|T~E_qe37қ}VϚٍf{q]㾢p=<]I+, e$M'[}8AC**r.$ 﫹,d s-az\ƝnExqOF|18[{Wrk-uAe8 zܨq8=5{}ޮ:Վ-h΀3nȉ]69CҮXϚ9.?+G^Wb$Mx\ʲȊu/d&9d(۹X {/K t@GkMw(P%Rb�=|+Y_ôy 4{_K՜!S̺xle7r]X~@< Mgol :be VDX.ڶCEv ﵆W">7d3g:61D1۞ r ݰ.ADXAJM4,tlf)�go endstream endobj 390 0 obj <</Filter[/FlateDecode]/Length 1902>>stream +H{PTe? @̲&J̚`Z)h7 X!j) 쁳d"!SQӌ65Q췜<3f{w}P0?x.cI?eT9:*($F}~@_?K'W !F8g<0RPT_4'_ZcJ>B[Oq;6NcUZq'J30<lC>@?/{r0Pz!zdP⃝4q̟?7ʟIn\Wk4ˏOB?IBAI!qbij6wƏ'F&7B_̝'̛$8?(=}sϒiby}]S\8f\?~Wg<t4-!7JOb  RɜUvoIkv)&=v$)~,͜9{{0Pz!H59sί~*R35 .S>{0Pz!dD,fWٵ2Ǒ꼖!Ql/¾|_ !B`$B1OwRFV,,?ޒ@>3AI L<=kn\;Q[vùʱfʟǍ�|ȀlY ?|Hrc #y0Pz!j&nQv)M8ꬥmľQ3OGP׋-o*m7ٽ@?(OiۄiYm9Vg9&CG ܵ-mjiGwB+dqqtON_ :+:ިl !)M7٠cGg8QU+~_)[vBHw/!RL+6řXYŖI�znzl ! ).='bp?,9Ts#Ԣ9s}qOĄ.a^.k /SGm*̮gpO\8a>/ȟt8_SOo*AF.j<1 A9oL\:|}Em)z.qȨ,0^џǃ"+YIiy 5G'v5O){I~$y[u@=j4Tk^zEgƠ'>3P2.5ܩtf۶(?s?l>.bVY*M+J~<~imwΑn}Ϩ>_GPEO>އ.t^ rmǦHjnr\3M.ygQ)ZnLqR95Zz!MoYGZ3n6EO~3ca';auo =&Vu1of.6<L՚?{|{Lx7-*NKPv)M3 ΰC0޼4ϦW'R=q1SM!fn.g2֍/,X?3Ǥ7}fESƍǜÇry-,8˵#mպp9"u0_PdYQٴ%J9[[m-_~~`Ӯ}'LXE =&34E5Q+ ux'E~w#ttl3w3]Y󶭪*t%zL!B䀹<%w`kjiY+?mk'z\ a!b# !%�I endstream endobj 391 0 obj <</Filter[/FlateDecode]/Length 2392>>stream +HSE.^P+uEVP +e,H/h@!r B.o4nl:Vy$&~fΘa9'}mCL,Md${cIkNNސg<ŒLIY`i����P\wȯSvyPKiM=S8.6,t/:_\RUZHTh�����`gژe_Ma}-B|<?SC*Ŵ�����������������+1YyYW?5^h%'zZ0CR)TR@'oȿ}͑=. a:)UTWm=bήR5Ϻ(ke˗YE)2t)ZkHc2~><mk>b,2v,hR[/okVb%q۴vL'icqQY(k˿r,(3߽�؟ }nH3omc�;]j4;lA]n+;9IHt_cOWD* }霢'[Mτ!Ofdr6Mi2v,'c=1?bV1NKxt~ɷ_}pm?lꏺS'b8d ".j&q7I%vW:Ėsp3W&bdGs>;mq>>--^VTWm1!cs[vG7=#cǢSTbhQn^P=j<>Mǒ>W>Sw[;!cp5'B;˫9nno-(3 ϻa^:AuMFQfSQh gdx4ׯe Lq$Y<^l93?茦.؈A8kbAYZ sJ6Oke,uc-d#/@?;-zcfQNސOcpwue~^^,4p+?t]cݩh<C1̔R4XqLLjA/ֱE^Fg 2g2R雛J#BBuPż`vLUsv[#+/ S!z{rh4/b1Wmke,C;{z?|=g##9k.&f +au4Z+?}KZ&v:?kXqԠ{ +q 2grW6, ϵsl1/S~*glxRI=ݭ6O0!lĠg_{K;Alk\X_j_Vզ+~]2?(s]dTXi0K.Z̄NސGɀKon*1 ϵ}-cԟYyYizCڞ~1 nugd+ 9oGFr +e=!&}e,ȫZg0:ew_32gh<zGToϵԍI̒@�T( 57K)Owwv[Fy2vLY8,_K ץ92-d:ګ{{ӓ%FLjYgl?Zw)l0}@Zsܐ18{W۟З"� fT&W\i?on* a mk>=b=Z5dxuy]dۦh_{3I;u2ݝY}DY%DŽ=I7m7̩jG 3{ q:|*U7l97p?ΟgkmqY8NޛN9ۯ�>Ņwu)SwWW7?//{6R i{Fwm̢. yF^C*0#%e}ooOVP S2gyEu=o`Js\݄!tz6M8`k~Q ~s@zp=6 kǬtE$媮۟7dlNon*xh�?hQR{4;&C.ľذp&Ԛ/r璪@z; ӣo6Vefq*N =<>3q(=!ou˒l=-�CڞQLւ/ʄ}-Ġ{Jjs gAw6q,2Ow7}KS7&YEƎӼ?1:T +ga^LJ3upcZº~ݷI,"c�������������p>`�'g endstream endobj 392 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 393 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 394 0 obj <</Filter[/FlateDecode]/Length 334>>stream +Hj0DAO+Ø8U-������������������������������a|Yi\1 +dp{1`տe->Xemo,v7rciG<9Dzɑ}dodkŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TZ13MŮbhUf)V>Xa LRl}0Ki,Ŧ3TZ13MŮ3TZ13MŮ3TZ13MŮ3TO`rjE��w~ endstream endobj 395 0 obj <</Filter[/FlateDecode]/Length 552>>stream +HKNPE!Y=Kur99z˾6Ӄ# Nƾo{,bcG"6mLJ"&}d/bb?ؚ9&5qsLbkg}}qшc[7$&nIlMؚ9&m*98>;#cZ#SZ}doJkGv}doHkGa6۟^S2{0Z>r I܇3:225rtDdj#"Sru<fix񘥙1K3Wc6hѠACCgGΎ mݱcQ;SwǢvEL٨#a3cGf͌ ;<6aV.í][<2wyneN <= +82xzpdoAnLܘ=1y{ rcF=>:1z|tbs99y zzq Y'ol~/oi]Gvy7:yEe}8X݇��-׋ endstream endobj 396 0 obj <</Filter[/FlateDecode]/Length 756>>stream +HKTajtAB mADhYVFCQjtFFAD^qrJ9ϠCŌ4K(kUY|',Zͳ80�RVM(1t娡c7J_۱u{> o?V7+ʞ6���'JZotDRwzWQZ<���GQK0H?3nl}��jmݚi cƒ=z>���'Y_mj<n"eϦRVdY}���NYIL?s$Wm��IçH?.%}r'��8BMyEf5w*W4e�� uΠ? UpyFҞ[Ct��77W? UPO 1=̷o��pd|XH?|Щm}}#�� ? Y8?+Vj+t �� &k +t,_T2vt��@{;ڿH?\_1;��$'^ƣ? YPh2f��@%{vehq*mPtGOm;��$S{kv8 +@vjݧ��t`f5{PTyd^/}+��DުHS?\< }+��Dl[4C=K1[��$J O`�lad endstream endobj 397 0 obj <</Filter[/FlateDecode]/Length 812>>stream +HӁm@ Ct&hZ#:S&0__S^BUS_ϠaMqw;+}$C)!K'6IĚbjo0L~) [#>l-vcH%%5+/)5U (9&C jRImaǠ>ד CIn}/'EW"_M E0&I%' )񵤸 Q (ė*fIrJ\e>fb$:.|! $kGl`Hv-uuf$;983f.8:+]fG_"iYF$<= Y̲ А6 X4g{VKWLHzm>}4uv(ЗH^g5獶&S'I7֚OC%M}DKʮ>Mqd]}4(B/U8RukTŁGR} ')/x-_ (<>v}0LWUЇ V 8>6j�}�Fաp}0R(}P}΀W>?Uu2{@4b+5 /]ɬ0fЗM2Gmݠ6d&B8mJ; +});{+m3 m2N3(6gi7@=mF +#|ڠ=Ե}AS:ci" &mE)W PH56[�- endstream endobj 398 0 obj <</Filter[/FlateDecode]/Length 798>>stream +H rPCQӓ$?hP Hg<zvNDVuL{,ktGidYivtWydaqGy&tkdaqxswdiyGX,-e61k[9&>,.c.q[,/aĢo' |F~'%f~V3 )e~;9 ?R2SI}>,4<}BcE}>,53S=̲:ѧ˕v- @\$emKF^^A_^Eo@ݘ vc:ʀʄۗ25Taۥ*3z;~c{Ô<xsn 7g9>^?~Z=}{K/\5o</ҋ6`v-f~|_תZjr&g^Ckq8mzX 6O=y+sK3Nȣ]l-¶USKTwfQ3IpCֹ-X6F?X'zއхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ†`�2F endstream endobj 399 0 obj <</Filter[/FlateDecode]/Length 629>>stream +HKQQejSn"@ 4$O|6`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:C. +ZKfRzٟz+.h}}vJ5<]G+x[?v["ݭT?=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE\a?s;]+6lGW҃Eە䣀ݟJ6#Sɱæv+ +'<]x>BaۅW#z~ ��Ki_ endstream endobj 400 0 obj <</Filter[/FlateDecode]/Length 600>>stream +HAJ$@Ql(Rpx|#/p;ǥ\AzйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +Ttذ_9O%NJ�<@<+:lWKѵbyq*1Roq|yJ~^9.|CG0hw>w+W\ocEMq);Wd,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>=�6 endstream endobj 401 0 obj <</Filter[/FlateDecode]/Length 670>>stream +Hn@ DQOo:URŚy "!OCLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+tOtRnTj[t'& '~l/*+pt~�Έp5Ѹ_̧h.|g>r+Ũe|WҋQF܏~�ΈCRsja+I!Bfm< ?ے|~ +^j�gRu >ҷrU+/ w&u^}悄[Y+on~ _?bJWz(~n&=a~ۏ?!5u?7ڏ_~qY~_^M2SߕF| xnD[6"xOG8GG}Ϭ +i<<X#za9kJB[:7Źm\sUR2۪#>fI$I$I$I$I$I$I$I$I$I$K�o endstream endobj 402 0 obj <</Filter[/FlateDecode]/Length 360>>stream +HAkA�sYHAIZc<%M"M!UL v fݴճ;ff�����������izm^%hŮdlڴlmna.ۦnBo6/˛ا]\MYeEYft_\foW{q1n7!$WuY_E> ?C4O<<Aǃ!c ]}Of?k<㮉]8'%izw%NBl0Y=O ���������������������������������������������������_S�GV\ endstream endobj 403 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 404 0 obj <</Filter[/FlateDecode]/Length 293>>stream +H׽+_Al:FaE̗bE (t)I&=uEq6eqOzwn���������������������������������������������G zCQ-5oŵD]��@LOGt?\inwlfn��# W/a:�� VgbϵgOW\��DU!w~\wzOvXy��@RuXp!ى��o�]B endstream endobj 405 0 obj <</Filter[/FlateDecode]/Length 576>>stream +HMKQWP. "u3#SPmu6ɴ(D"H* +2YDIm~GsAa +9s]p#sd7?}k8ػS��$қp8^l9?Q..j\oOOqi\Q-D}-mg W`_TwB-""""q'mkf/'l9?5rt1qvsRsepHN~1c1g1ciaO Z CW|znZ}Z>:'':l/3΃9όΜkŽǚlzab̞==Kgyp ]ܙ]Z}ǗjSzF{>3΃9όA9g3<s8Jqqtӯ63<s8پFJ� n5R��q}�}3�@kD�f_#% �7)g�H>�;FJ� n5R��q}�}lZ*wU#�I endstream endobj 406 0 obj <</Filter[/FlateDecode]/Length 428>>stream +H׿KqܢE, +$A Щ& +i%1Dw\x*BdsCF|/3_wy ,� [7Kλ_?}җz ��"ם[��8MI~sd4��NDJ��p _U@ԓ��8BI~ϣ7Kڭ?k˩7�pH{MM]zljM��D�m0(�@m.5j׈B�� �PlH�@"��Ŧ?D�� NQ{ygR`��tŹI �QtꏡkM?L �L58oκv}.� {G]^�@Fɿv}ݛ.�{ �ް endstream endobj 407 0 obj <</Filter[/FlateDecode]/Length 19276>>stream +HWnܸ~#@ oHE]S؈]A1Gihco [9߹Ror}^/ޛ7iv羥u=CgHo?$\b�bu�js˲HO~><ߞj ڮ~mʖrsv4 z25� psB @5 ;b-iǦm~9y/@J`0ːG�c.�-VdB\֮ǝn]Oۺs?}VQG]퓟jLh]J_|۱V ^R/UQҸS$5 tU]w̤4dh .v@�!S?1A"o?jﳃT[Gؔ8qL'ݾtS C < 0 ؄KG_ +񥠘9Sicm]nqauwT&Mvٖ/'V6W;zjq-/(?gm8W{ܶX2 Z4)) &i6zzu^uնj_]uUy8dS6sNK/g7`5oʴݙfA4Luur@|{<&tjm;aW ӣ6J׺Z\AFWG& jCj]uZAq*_k+!DLTOS_9L5T=:l Nֹ2: q–j*AAwky~k=L$v)kRg2h+ѺÀ> vfF·ܲiRoPV70wU3@nnmWn4mw_Y +Gݛ A˺V; +UU 6qռtc ֻNpZL&~ŮG\Bzg!VqtՉeX6锫h>vo< C{e;miU'C;"g-c\Rsv@t@W3}Ǹ!j4ͤ]!vjݙ~qoajm7nG{alw؇p" +N΍qVvLͺ5s$~l^KA7o l<qw>O8C+yT5,"T5+lX� P)A#`T]V @wG-5 +4fz!No" +fSDr (5\t(  ;wl5b؀kW= =t9^Aί`8={yG`qlZﭻmAi1hRUoJgzwͣLDU_תZ +NkthR8f?7�3 ”1wua24/q[ pO +ip{w6Oo۶5i?- Vj\^Z:� +0d^k^Oi,;~wuoB6 %4X mۛOXA9<y3) )37&0~)�9LZ%Ckϼ{OJcoVIg^g.+<fXK : W$&l'Sp`AA9w ߙ819X'8qA0!F$& IIFrRPL р4ܣJӄ49-fQXB1,f KYrV8  X!| @2$H,ȃ qHB00 +y(BaaaD4bQQHD2$J,ʣcN8<\'<y! +&Hp!HD*2BbI$L2RH)cTf24fqqX2$N," Ih’ (Hd'I&Y'ESҔAQʽT2$M,"hƲ (Ȥ7^R|ZĠ X +�Or'N|<g , *R1H%D, @&(dH, +OYJU'!w^b  2RCSH|闀3?TP'q_q +|`EQD},d\r ҝ b2SHɒ-`�Vݶ$^Ո]wn6Uuu%fF-օQ�XBԧ@a4(2q( +ESxPՈZ"c4U-O"4(Ž(K5 +4P[k(^"֣DI2Ǿ#JE7�Ld@ + jP0#ȂMm"b $5)HN%RSrT\"k8%KRcawQCz~6/a.dvb(EB!H̲ � ^-D<A,t+URUT**T$QY:%mJ4RRIIZɂR%T(iPR?$Bu$Iz&kMR35E&KLʋduʒu% +5eI$%ꡆښRЮbD^cT*YhnQ~0azokpn`3apksv 8LȊ$jrMĻ8\ܩ[;(Dg,%BM/<+睈Tr{KJoSK:jU#+Uu- Uteoڥ' ;$d*e4IT&a)n7YNͥةܩUYTTL?ʟ +0&= t ]iѣ&p&sbԷ¹&& .#hgP./PVN`m+pv[d/XuY|x٬_aܻ_ݔkzN&/A1%D ~Bq) +܇\\1ಡm=Cq( _RwK n6~z]-y]9_xmKs|<_\ߞo.3/㛱w/׏_<|/'1fyUUK6 fiؑZ*\=;Ȧ`Vl56 1牞mwd19WXj/Rh仜3:gIsKڄ>=Ed�h;! "v4bV`t3445-IRzQ04HCmL943d^0՘dX8 O4)ky"sO3 'k +sMh+F^v"-3:');$7QS&HC3G[1g%~tmF.€6aaaY\E!ΨNPo! +\qO:s%=CU\Mҭ#FҬ$PB%v̫ĪDTԒB>DG+Bę&# QeZ(%BBY0osէzod.W:s8o*ܘES(}.к\SS \'S9"E.¤GV0 SK bh܈ #IU 4MXJB,@EVX9DhzQu@9I&&>AX]:zb hBKQ)=2e Td mFaf(O +&Ňzx>޹x>ƀѐH>b#5mjMkE1t7}-O>?O~8|_oǿϟ}{^.\ïC|ԇ(?3I{t…N~(|?]㓾|+䶇ڙr桩 {{?76ncW.tf?.lďioJc2HxGs2B.X4@P +C PA)9!O +?}>&N`R26) hI14/e`fѼbTj`1 "B*&/ -cƋdp Bdh :iAju:$aeFj\3G,f7 SYa X +vj7AI^$ +av8Aѫ[Eel̎ V T+e։nNݜ2Cr"dKioxYdGTEuj걨"3ÈePne0o̻cxFץƢUXK^`O<hl ʡFTV,J K O S!f(0΃y `i0=J)-lBьv‹zhkЃІu!"b!&qQb : BbdB܈A +P-rP1 53F}D]yȟ94UaGTvEe@;khh--E9bg{1BotCBMYUЃ  n  6|jC$P]�?`ROyt ¤l\D2q,/z75z8_)'a8 +ls=yٷ;ޜ}@=Au_f!A7gh@<l\ ۿr< {쀗肳p '?qpBccjEV L4/lzf8gJhD4Җfv45uBC6#fЭ wG,,P`;=5DsdMhǷ~L%ʦZPg�iJN  e,%愵k88g) 9(S q́$SL0eȴP0j@LbLԠQQâȨ128v9 ĨψjI[f$Nk2~F3#,CWobXCV׽rs5.yS>}d),c_Wێ~qfgXɆ + ,˱ o E)Eӓ]+V2kU:UE +_\T|]mvۋWJ(eRX6V[ ,oZ\bB ت^1}~i:֗4ZXC1iNJʘҔqLs9M2&>My;'9%ɟcj,@ƌ; "wS҈M<A t@ΐbSI +Ĕrs4iF@�R~*m[08k_0+iSҫ()=C7sϖDv?cӯ\W$?6>U#x' ^iKCAz0Ҧ+M%D{>CD xMS9x0%T'LTHa%qGmINF M"}"8O B�u$:R!I\_$E~dRF9?]raz\gdiODrKMq[5]nNJckm5RCKXYf~c澧ו>ԕm[K^@KҸcp*5LO^QmkmZ.#@~ASI +1b!z6iCΐ1 1!n +63hC ;o!kj1^zᅻ3N.8뜳C%#K8a/ 9}؊P2n,%!‚s 3" 5Oj@&Jm)R4NRK=AaJO3orYN=3uZms=Tz.8LΛ{}w^Duzm>+F"H? LGprr$V )Vb1WoL'(T#-5#p,q<L!Պca5>ҘrXȨ2=ESH3X]""ӐHxI$ 'B mba\Q0"eNw!H=ԛ*yƼhM{Rή(&|[5uT\{nlb}>\]8qΤVU)tbR)eUΫ\svjsK|δk9jMsk:rY +|/ݵ;6nZzE/Z6qtܥe!D^R{dm.CO;최s7ؑly20?gc0_c-x-Q7ovk|O~zٳn&^F˗޽W?x|; "0's||+I_kzȖ{<Te}`RQAqhP*\ ..jAksĥ7<5^xk/";sgbe@@"QQ +uktX_,bD`qq"{,/AbqK9C5Cq70ܻ:(.,݌HYP+`Fyp8Hnw>]YFE`虸hgU k&jA]3`AdH"C(q!q,rt=BbɈ8QKF*!e<o irը"֋ERŌ_0,*ݞOKN)M(lQ� {gZ#t �O,l@6}4ݢ1XTgiu;E)V~YP7*Nyi4'uXX-cW{.ip~sQ;?UW]~}Ġj=s~A/B]$ lMyY)[`(H.Azճϡ*[T6Ԍ+Xa,ҳThb<TbFyT]6 +a3;1bu**dM +0fU)/-Лt쫛):_;VT]a`f}S6Pms +˂uϸϞ}uhQU9DaVuӱ!w ~nn & +q7j4xaRz!5mM lp _QkKcQTSDnc֫1`B-`0WG+ƀqH9*cVxުK^F L(9g膢,,?QKWQ 1`R HHD8bD-FEqƱGbDgǎ!cLq1qGo^霯2/xϞeu?L/~_Bvsyg~)qH^g>f~>_ӛ_MP3'N$:tõhj,OŔS]b~^ߠٹ7 tUӛȸC=uY^-́ǿjĈfG]_q +SL)Q"쨋붷N1YD+7Nj;bdtZZ8nN΢ݍǸ6e:Xq&S質L}?TҠ<G\㡡+΢@- }PWnF<]@-54ncdG]7E%XTvkҁq4թ{<u50su(Ni'7'+,ȎN1z9NR3vJåQ1l7z3QS4c8mfdG=8xKoW-emfdG=8YASI^m6z3bwrs B5z3^;e冧>,XqԫьN#F>joҫGwxIIww:s�~d}36N4'X5e?+ȿ?}?G4_$RnJaSQ7f7x!㸡VspTGsQW   (BK\~sn$o^1׮%82 +�i"!#ƷU jgof[뮾2@pϭyϛFS>^K +ӥ9:t@0ד:�vHBP>ϼx~~f޳_ga*z}Sǯ'6ɐᑪ6(.,}򏚒5*ado^�{ÑHwĝr|ׁrS"B)6Ҩ=[RvԘɡg>Ul}gvA ZhQCUk;n?xְ òd6;+PWAP]g030JSA&IƷ怠H7l0�2v$gkߞ\q;CX|ߌkyr:bQ/=4V(J_IBwY+=6X"sD *{'dUf=Fsj6[V HNŤWlp!aL;+�<iтu?@z]t~CQf]jx3騛.3yGu+p{G 78O1�]9(Jp68Tǻs}1eÞ$v xC 0{aBd JnA ƣ=<'A sI7y#Ε,pQ색z`\xhyYnwsr!Qj�$rĦ/,5R[2yeK؏%[@! 0*+lM7VaCN9k[s,` f\Ec!0]^Tƞoӕՠ|%qp."%x*+,7Jp5ӺkUW5o?G}zCMVF[.DJx>gn4;aդT,RߡF9%nJ]e4Gh1XB["9!y ch^ J3;@pӝ5k=wK٧@b2& +Mx=(p&8#rܐkn김gvqc9f4$<,&A'@N"@c#MAOOD>E9BuS#f dLTd#7p5G|ڄ޵d^|?#p|Fh: xk J0N�Iϒoz7l>"~?8dcF"OmD>JگM!'^+4dx 'fQ�NXeu@'ڪ�"!P.ulz§Wr™^: Їjk4ۂcQ #jsj3�Ұ0Mnl0Ok_*=ȟs/orY2B 6lT(~JSk^O55H);ӒKKD�fE$`3aҏ"@OgwZMFR\b'`6GO/3Xrk"oS`]O^!ĉ[AFIjU܄}ZmAClQ�¸KEDC-0X Z,Vme4d`Z(ȁ륢JN0g3ħ P�&IZcn\;蜍W1=]@ĵU!}؝.4oM1C(p΄% ΄<% +ޥϊ>gE~B(ߞ*1uy~ZJyv +$ZjyeSگM=GIِ_/ 6rI/:$irj!sv%-bYa| @R*no**hr<gtl +>+?xlQ`p?mWoVcNE'loycRT[h[ZcH}䌍-g(e�$I ~D,]GAaz NWgCQү +mj)2#I)zQͲ1ڇoYrgGyV/͈ +W,L]$8Еg�>1%ZҤ1aR'\[*cnHΎƈ~|O0TGF[y&WL0K-0N8N:}gi^[Ul*<X }N'?߾|,WR}Y{fcb4ǮMTeSQu<BK0`J"5jQL8FQ�2?v02ZשŢv!#Y +bs9OQ.R=oP{%ho0fzˉ?y5n2,{xݢ'>j6d 81;Dž^޷ev"�wEv=!g[`tL 2'qD!7v8;"� -IGy6Z67&\<=һ~z_jǵ,+=th0 S;HV龞xCQd}9p/ s}J+!kZZƏM;]\΃>qZ[YPWkF 6"ܺ:Ff{\tj?S,&ҽ<nz~=?n`X3,gK)A&!ځX ۡG{oJo]kˏAs0h+0 +6�Z*oigJ &܇%[Bޜ.Sy> +aCnYGyp~}}S`нTܟ�ʇg2pH Mڏ=_|s٦FUjܨ)`#>&CvA{OT>JGO 'to4*{cv{Z,x0eG#1ڡtvʖ!؏oͦW({]? +f-IgpR!VS;ٗuHE0\w +:q$GR,@XKЂl7$4`!"x̟<88ϳdpSvG]fn\pq'}Ɋ$5ucRp=#b@d{gK 3Z +C3zqFT0 oc=R!A\X ZL=_ߤ -9U>>n| o7Y$F7`J`1 -FS?]k3gSg7ئ[f +M<Swx+F蔰X\#`mbm|ͫ :E4J73X4|${Dna4ѷjMZ k5CpaƮxB{  Z)<>0u~0@ʥWк,@=yY _ L܇ k02)Lgk 5{ǑcC)"!CP| _Rn~ yZfn lrرf5zAcټQkcт]Z avcAVIF>EzyY|1ߊ&qWnWd[=vUݞkO~A�MŒĂk3esߤl@D_JQVhf%>TMzG$ǜ=oxecOs?ci1. Һ-HL C۬ˠ} A:�BH~{7&[3Hl f.{1jg G(BRϏN.Cn_g!,V"C"[CviTjҍ{z&j5?])R){:ak<=tm++_OXv/Z:|Г lu !so,m/.x*Í |@p6'V Epf7* #MyP1tx_螤3ضOկj9佲4#/@1A=g? +L2+6�7auO5\ ҪXCznJ0N�tۺBnS'"B<E>a#gpWGㆶ4Qmh G;ϖbj{mf];hGj6|l4vC@;4ϭ(7hvgpbXA6gf<v銰pD}@/5XIy \AG�ٚaDp!8OُW0%(ڃ`WǬ�k +ҿ^"] ]xz d +k+bòNѯ0|E? .?mv\$jT;Ѕӻ3A7#Jpf/-OGPzkU+^anvaWWg]8 (V VŠMi<?SZ-y(1@7g64#B:fd)؍D{o̖glg.k>5WptUF:^y%0iٯNO&0iSLo<jj> + S.�PØP] Vv0Z_v1kMh_!bSXSb|84v'Vt1tɊ/ plU8]@>0rx[g x;UUZ- +נZ -Wb&\7x.jW\4e[�Y JgceG-:23m,Rv!YܬէUO=PNc 9>Di8%P6\(!`ƅCYmK+Ed%E8L ,((mkXΏ#.+8dv9̗ 7-ë!cUu@C|H(*86Tkz4 xy g|]FoI͢qVcQ +Q4Uʷ=;rU78:p@w:KHroCBrV h_lte=O0h񫎹@yTTY=$9C4"Ʌj>ٷDvqY~4uZ:kL +5zp/؛{),RA.vRdhX9ҕԺKGH:;`X=W8YRr, ) +dSH(~r3)w}nB`*Y`SGcX5k8iSk +qF NB/ie\t/+;vI(iN`֝wpDZKEgPT{+.Xp?i8|?vZQG`a⣩#ؔ&.:ӻ&lErX:y˴|d+A$'QQ>+6p;NozU>;w9JLd^yayTk#W^f~xg [?di'=G~#mQVa4uF=Z?LGHuTu>%i%% [:}@Fd*^g}Ǽܾ6Bjb>a"uhTG{I1vS(0el �I�BOvC1!FV|Vyuźq0}FQG;E>qHW-JюjͪO<g. +uG2pI)cJۢxD@ +O/0<?1-"z}c!WF?J$xYt~;sڭ(S=MRsP|!8Դ^ᐪ$Bk*W ]A+\FS`axgܥ�3B\V[," +is3=Lwn,(D]@ȯ^GZIO]²CK Ltdf +MX>V(u f7;M�sҜtZsY;a4չ2(s4V\ SViٟaO)_?P<:+g>JPR�(u1_`' +3l'ƅB}Q:Ȋ.|/m .[NM 9�8Wl2fd)a/e3]1o,�? ''SO9˅gܽw +v ,z1x6u`ӮVƒTKP=sss;Yb/Π =u]�ЎE-,'ZNj#t'Qz-ɨ6@ǧ JT�UFʼn=2afð=p7lqoR p�_.+@aīˢ~_ t,]Z|cα93d=A8NpI٣�I&r IzczL):@7v,)1U} BUǍ_Cr'IzuYc5=_G .s[xyNJZ_ĐNd*$|L#l 9[X(sdst QقlFpWgF.zC\[Ԇ7 |GIB,MS. C֯/�D0l68Ah/6lRKiIy+rdŰH?iF�7X�Yi3anWNcJ麶/,xFnp ° [1)X50$#.Sx5B2[*A1r:KY �< fkzD(B 3$/q-ʊ)$HnMx"N"6H-@3KSĶBny/g_2^=�b]=|Q_Js9Yߎ@}�!Lu u@Lzri\mOt8G\0* +8ʯ�{c�! /ߢ̱*qO3MkZRMB.='I#2iPt&4#}қ6h(={`p[@[=^U%wY[U_px<WKJzjKxj)  *bb`!uԙpM`>Ħ:oj \$V b Nlȡ%qgkd} %_^AЛY̜B(&2e*AQSqy3__, TW-=&w>#,|koo$@Dza85;sȡA+Iⵅzjb0K3b¥1ca DĞh%|@NA6@R3riNAR� F:,#%*N5ol$dF>8D{n#; _ +Bɠ[1guUEl9^^=VE`wwq)ʫu09]Kc5Ezizo3<pj).)8Hn:efqgw([|n-r]Ins}vyY�f�==W ^I#Hvb>R�9 ͕U Ϛ�n;Yɧ \-pH4N"- +:44�{ّgWM'|V>IV+t-m1,J:so˸Xвyj!+ +;-5W{aXt%pFDXEX3 Ud. v8 U˝U3U|ܐ ]>)liwSx"& k)ϻ,W!GqZ#w y܎_?CGXJk,="o%Ft4SNu#즼 @v ]Dz~$,knd(ٕ`&edM3$,VŠRuH^22eQlMiP곜 D^Z7ْ2X/v[F`"33BZ4)AUvn"`W`) -!FN1,:ϥ]<eA@BYJ;0A+i  .�jU %hz!\t Dɒ)_<Aic>h??yDwKG%5H5+ @;3Ri D,J0DOd bM F|w^ jL!^D_`4/W[sk@ToNnTӖ&:WkC}#'2uì̄y<ӹ ~؞"tI}z +|Hzͤ-:}jh}|'q|}>I/=),tAc| >$rz0 ;V,FU:/t@\>[wcEcqRZkD˅⎠�X 0wP_'Z0hTYҸh#ڷ} CLe@Yv˼_f[' +) m='6g]9sRd4]:G39IrI]ZҼD39IE%p}9']))F@)ȎSg0Ǿ&9%)hPS .hԷK0q:~ߩ5ڜ \y \f$ [pDi +65Tsst.SH! +%aDXP݃r<S#I Tb`4L 5YA$Y,-W3z +CaWB g!f"l;#e`N*̨ZZ<hTr~g}39iO*u%CuÞ[ <8teXKL�P+?W1e)Uuy`3{HIT�1wSgp\v)C {28J]{]884T>ҝ˃ iH0eK:|Nӯ 2m+#7Ӧ4 MxYe}]g(BU-Zc+dfw0�*z"BHf'�e]Wpk9:wȞu~Op"O۳y<냈n>%d#Zv6 +)OI%fc|E'$h�ʃ524x࿊4eZ>LjTxtD 6sᗒ6,OmDkqRx1Ezx5 RĹPzvC?Ձl ZU<hȌ`QQl +Zv!\m] q9d2n'"V�Hb`1sV &!t�Lq25њ60J5]T JӣEJv 7gQmrn(:3n9TeV҅I=qˌKuqpH*qpur�씝K$%Q8LhEUuύ�8|a3`m?kmn^qmcvW}e#EX '(dt[rTakbp$P7knsVNEI5"ȗ�mLdD\k9\)~ 8}U{LUE +J:C-bYyDZ4q2VRãcg=!@l :C,{@]c +ߏ08*t A$lx>& %.1OcZ=zrm4 R cwޗ^4pNhn$t}L�)'!:>bEsX\dK?2<JKyww­ݠ<Nd#`w 0+*Uu-|hr[k88LdueNކ +kUP~:BGOgXâX)Fܱ7+謰YJ+֛8TQЄ V;{-.ɼ +9)Gh^E,-Ek3V"FܷK]t[G�!֟C0Usq/R> EdQ`_rQdD%_0MThУےb7ofc'Ɔ4Tzi8uDš&F P�vZYg6Ž8BLL"81>Pll A?뷸yPϑ6ʌ- GAQ­͕ ziPSg1wY"N~-9vp:qQ@JQeҶ⒓-AJ`o1@X0.R {ZbhS\g9$x#c[�^CaT|I)̈ h2 ؙ>.r=0\Jq"gn4WL-g"Pc)Nj*OKzgy4+N=B^_J?$z$:L>ȁ  -WW&t{ۥ{ +$fA5(bXjO;q}'ɸ! .g.g.JtuG8|z'U7??> ?q/_/RprR 4P0T0�ÈJ  ++(*D(;- +/7t-u0!}P-7�BsUW*d ^<P70@)b=0Y�+) KbK4է޶T�0�@d endstream endobj 408 0 obj <</Filter[/FlateDecode]/Length 1711>>stream +HkLSg00^6) +( ansq!8@ġ$0MD\MZŻz=P@'ȥ22/0%?o2d[r^slif+ĝtO"cMe]���&gHxb4ѼFsӧDNJu���JHBm[{(e +L4wS/���5Is{J9 >ΙJ z816ԯ���`>⭣gDQXWϺv&ܨ;+'ښ���,J̪ψJPPIsW<(I&FrafX´T7S?���H&w u|-&fO.+& +}^dzj!pB:M?���Yhhv|4kYDhBB=7x1ʟ ݛ[d:G{{S_���,9Qަ(Ds<Hkr FAJgkᝩJJo's����fƔ'A1dd5Z h9L$mRo%-"nA?Js[ޑ{@gO_b���?/٤Q.n)R't:޼*~X"1uen"f3坍 +-9su>gHUVb~FAȓU4F1���y + \HT +iϽnucwh%.B�Kb<o.S'3Dtg=?g$DqV{���0M`<jȭX?vӓk`ܝ`M4sDڳO/_:z|C +���Sz|CCekuw: Y]/4Rđ]?ղmwHAP綘fgyE����p3hz:W9~m@Q#'|[qt1)K3JͱH+'yO����SX6Ĕ]jH|^;`-gFfe}3$.SL8j]kk���͒y~']9.YS5YNүwС9¼%` fLJj%keM7:wjuSp3+=wq. ���-G +v5VU4uT] D_+ , +ʯy~Q|?r6H5XQGA];%!j\ ���zyS]5fjσؠkY9FY4O\5:k5:ќh-aOe4*䷖w*ekR%OUl]{u;B@z|k6���+KIvn`h>jS +o +1<}|7Rf/?IެbA~eDP#kب{4{7+ =^���^'9<A.8K3QR=9vDj:DFz)dE龚r@Zt(5d28N#ؾ_k$ф+jť|;g�+��Lp endstream endobj 409 0 obj <</Filter[/FlateDecode]/Length 620>>stream +HMKTQ;VlSZB#RvhEDfF0uhًIBE +E >GPH{/u/}|W+]>j-?v(�$`in˥>��A{+JD��$3�@u6k$�m c5B��6$)l*+  [C8zdz%s L?j]oȕ#lv"GwwMN [y?ל+G_WWu7;!rQ?>#sIQY|?HBGsCg<96|*J\9V{PzV\9gבsC9C9JcalW ) +��l<I>�Dy$q�ͼF��f^#Ig�h3==5+wۉ �m5``iշU��/q0~Ή̓>��ėy;|^{O��ěy{3H�x3eWZm^|ZY��7Q3]h3� kDգwSR'�w endstream endobj 410 0 obj <</Filter[/FlateDecode]/Length 755>>stream +HKSa÷| Mы +ШeEY ˗y25íQw:03}9q78��8xoE+YWUK];R8{īc=)K>zHiyg)'���K_;l6 ȎXu=ܗ搿U���ԞF`YT$.4Zu@,d$74u޳c!l,m���XBxbftAtjbrH̘ɍ ���Fi1>vSZX��`=jtT��+WsS}U��oy��� oF@vL̇VxY<���H^y-+١z$���T.cwF^ۯrU���!گ~v;M@vxFqd5 ���Bf45U=6gBƢ��� Dj/KFYЅ?+nU���!V882?gxF}2c��d5ɽ3⭥?g{Ғ#;<7U��{nn{nw8Is��d#'8#q15N\���l!l,"r??45_��fV8i&?C]{sMy��]�fߪ endstream endobj 411 0 obj <</Filter[/FlateDecode]/Length 764>>stream +HKSas% %RZ1o "@RtD.9LMw3ؤM$MG{"$xy/8|/vyxYNu N> 3;np/6���t{HA@5;dx8)6���ewXWvjvxcx���t_6?\1dZ> ٷ��(c[d3ꏎpxW]Q)<���%vcT?ۜwnA��IO!5w *&cŎ^ʾ��@';E@IC<ٴ]}��Nҋɹ7w!3x#c[��Љ_~s:UL=Q%D���-UU;mGPS"F���<-A@Uezb:H���:X{KaT?Lͤ-��tJ߂s;79~-c[e��|TV?LJŷ5��P&k PY5;ߞɾ��@e/:_TV?]Fʎ_G��P=.LJ%5w��l^X_ cT[ FǮdl;��T&eۭ?ngke +��u=2=L@uGq[_ 0�1 endstream endobj 412 0 obj <</Filter[/FlateDecode]/Length 1373>>stream +HLu0j(V\NͰVmmBLskmMP!p_w}9H, u J?lgoÈn-پR +��[b[l7ܒ׬:3Fϙ6[3{6Aٵ.{,_��  ?̮ub}}c +��*͗:OGF&g_�� eW<Kg5 }]��2?~3-ޗ1153ٹFmk ��Ln{BrV\FF@Ȝk|h*^:=v��$GI\%J2X x? +m_lO_Q424��(K:돴J|WSKpiT{fQ c`kf��H +m,9lRZlͥ/?0\x?ouw(U'av���ϑsv^K3I΢`nJtۚ:KKIR9kQaa>��_tF35J~%yNxW7'`OLuvWG /2j_;_��zVr䧾,uˑs^]~P=7c:{׬Rcyj}EF]~ԘMȫ68}wFf0ya!:)��@`$y<sd)̭.ʦ KWvle#֯`1_8ca)nl,OhYM7Jq!3؈!<1��T$/InP$Wm4ϣ ,5"$!wk$GowdNT[˨]�� {9+9a KE@0)1{?b8g+ ���bEq!ݶsY/MCEy[уk=j[r PqR.[b-2>ѡ<"��ߑ<l5w;v$sGZݓE@x?%5[Ydi5*ζ*S{d]T{m7G|0��7cJ.|*7ISeA@6)Vj]YmYMRΊ!:*��_I[2T"WyIr %? =F65ʚƍtcQ~òQ.=ʄvuʄ90��V5CwyN@WⓍKOM}dtAuQ^y iofwuweJ}xxN����x endstream endobj 413 0 obj <</Filter[/FlateDecode]/Length 1590>>stream +HkPTewY012iN%P֤NE3*x8R %)/J!²Yg { +jJ˷> { ̞3;ȌsTZ^]1Es"ؠ))%d*+4pENG"3.+#Z^cC3 MtA,+~Q&W63zn5anv>6���S!.,l0qM娍ԙ^?iJ߻sLoln,TuFn-ޯ :mO;���@z=.lDTUAy +my]v7u!mjNq11Oh +1v&YW<pvr����@.r9WR_h=ܬߝoOW)G%wHy(]?h"r&oouڳpC>����ʶg)PDK)7E̅?5܇(Uzv1ć/*h;9I}\����Q91ܯ&('yQe.'?OĪ8M[լcwP���jE@)ZA4mUoY Ms=؝ǎd����b*LӴ)N(us=)'<}Y Ob^í^kP{&:N#���L懯ݬERJɔ?�4c7 +ҹCM=/o>c*e'%H}f����1$}Z^m-Ζgя/osB�G#VY31ħ^6u^.���esÙA]`k~}/"GXH4\fi7ECn)cq+C>7���@ڰZ'͒%1C (18ﳣ% % {NhO:dR���&.r93ޫ z{֡S_=Q~Vh4)]O '#}gI}t����|`LueΡyx?=be+p$4[BxN{bK!>8&���`Cwg=jY*fB�Gb1lL.U7\.Xd?azDO/���'ޚd1wX (O# �?hZ#9퍿Oo7OΕe4N-���B<O dev=TH?h,H3>=Y;6X+����1#F2N{fћ湆r/Ti푧?ػE2eԱ{fӴǮ^&����Wǜ_R=44-g(PA�x<{vx;YꃦUs5J^&%����< ggfЩ߫]0<Ϝg,*s8C`9[ G.}?}����XAKj,Cs!1Rnd?hb  >rgۙ޿A{�Bn3 endstream endobj 414 0 obj <</Filter[/FlateDecode]/Length 1569>>stream +H{Lu H[%/SHIʦ�I* 9@D /11.s;X:D<c_aclC=;{>���،"y_D}` zx_IGyMpqFA{k;5�<3{yލg| ='k=ƻ^���cyOѓNnc@r@XФwW,w[/ys7{���(d,^^Z2 5睡?X,Lqgug ]{UեNN���ЇєnSakF;�5c,V\;Sn~˃qa+y���@,c gK-م 7�gA*o;=mCj V���^N̠SyhsK[<cAkZu`dk'%ã*A}};n^zsx���G̲CjMGJKflܺ 'cA<*hn,w2v~ݾ=w���@ѡ!,gHTe-VvB�[£9l\]&^ ��� r>H&Y +-_F9 ?hdec+~{.2ɬ-���:{wͺ]*ԒU(P~Ӭ?/sok:4ot  ��� 6f,#SG!rGD7c3?#g1UteN`̨WwĆ: ��� .vL17\qx%Мi6&1�OW8 hMvWkd`���836vASHzmzW+[(X;3-?FF~Wmiy'ﹼ���6Y"aQ_.~d s]A3cL!e}ݖ-[F|;Ϫy l AItT.{4~/+I���-g0ol@-qqW+^;S zu{fRy l ᕴ]՞s���7ŕmQ.|q&9#wOws'sWJ zVB�[ûdgו_9}:ː{G���۳ӼXRDPelQ[rNPr)tnLrL_r)Ld ݱnz؋nQi;|5���k>,a::sg^$C<ek�<?f3mlUvUkK[{O���00xwck +Oݵ-0P9Wmj Mc} cO7'S(�<?hQL3~MߛxwA<,^���p0m[b_`ԖR+;<y)s8ƣCI|T9 l@c|X5q^X����L endstream endobj 415 0 obj <</Filter[/FlateDecode]/Length 2429>>stream +HkPg\YZT*8TDm SEc ԍAeU$+5x-rAW {o r;D1i3j4!Pmλy>μ3g�襌q>_ҫ0]dҫL^%m&Q|$߲r)Fu8ه=h{zi{L{MwE&I#b]z~~krG{B!Jݷ~뗄7 Չf6$C ц�FD}vF ֿs_B3ioB!^B/:q$9Y ++ms⮇#j&k{o"7\d2凪:L*9~!BP~>SaO\r F;]|'PDoṭ<7\ze|3ત_:<2B=Lj. IJ mQ3LVE6wo:uYr lJ0k.\+4Y䜺~&LsiB!�<Lx/ 縷d +27O,,sEːB%do?Ȉe&Zb^,N7ɠk1؅!BNN>!ƃcM:99)㪤/3u@Q`ڙG\.ѾPh69<P[΄" !wA'RI$Psϭk#x�PD3ʹ_~CI=a@fMVk6u<~bb B!BvC>&–+4UHjD5# +w;Hج  {!XFwNj}.T0Kw!<f7>g2H8kT]T1a,׿}NГv^䏷-9vWFfx6F-*X>G{B!sw<!6|@!I3Ol.;Xٵ�Ow�ZCɨHvl|ٛVSU1hoɗpLOY@Sw*2kvl,B!dC}Hs-H21ެd4< "K3#hg V%~,k$ͪPQzp)};\drKsE˝ψ?!eƿ]JɽNX^my~߷&@!y#X} [9􈖄/"z?{NIy{\! nK]yg=}=n|l0B!@JLc^:܇U; p3˅w< ~iw}\L;`@B?etMBĨ~a|C Ś WNgUZy�7O)!m$l>7;L磗/�`ޖriY}k)gxM&i]Afe~xѷu<+i=䳹 E![޽w7l[Y5/;ݹS[jn<+(ejcHΰ䍱3dKJ2>w=F~Ѳ:4{?ey*HM BWQso*SV猊ˏb|prd�ݞJ 7hgȖP+Oj3v~6dh{ _*=[d63FmsόGXZ_'dBPL�vDG2%r;"UZȧY/ͣ_!etw63ig֔(eJ}{lC]g+#!|xza8*dM#"ݿ!Ћ9۞X(ݕ2:qH͓uqrd�|uk|Ar݁5ǔrU3&Ӻ|Y8tL}Rr$?zlFf=; &Fۨxv,uFrwYBn5 "xY[W3tndMΦn5yߖNG8 $Wd8CWLFr5,k +',׻Üv޳!:Eюe|'~?9{bB\]'.v1/{kP_%woٴO뾘~Sz sM ECr5^cHoٰ,3G>N%E~l)V(RUZXh`�Wf endstream endobj 416 0 obj <</Filter[/FlateDecode]/Length 2288>>stream +HyPg_ +-j[QZqbDЊ" ˱)ZGpS(BHB7 ($Z,8Jţ:zC)a;n>$}f3/ BS ?KLU&蕒v=IrtqSTc/$XRjԢs5BagSn佛;U=cwg-]ꢂtoxן!1y{MoIB~kv&?߁# +0ubw,5r,Riktز3/8�3h ʌM@̞=rR):Y|"c|3?FD┴]S7.kgBYW&AJ_H/:B/^'*FSŕ|o1ojM}H+c~4f+hwX (J s'wIǡ9"l^5Kރ;\G|"R~|'!9z\M( ߋ1>?w D,ڝE?^ؽ2on5 OJz*ynfsE!ٳ0In +HٵkL1|=#lu*Ż 냽vhM`w` jHeHip [d#_;]")!S2^ ֑$ټ2~;`jAǝ$Ѱ'R٠ w1C'[�H3L@RǴxDmx�3.}!?cs.`oL&?;JLL^Ƅ97Jg kMPmy[I =vlt0VȺK+=Gi/B_1n ,16$xC]+ĭQzgغ;yI݅n�Zc!}At31; d,y,J c߽:c"h8o>׃"-fg\ܛ8C]W2jFv.Cil\wOٮ ZCb/jf'%M@̒I)aIZ9AD=#zٙ#M0f,싈ps8')ƍo}5 <g�I1�r4u?|L~zrztxgBu-]bݘ(B|q_S{T~Y �'ƶ Չvwl> H mg 9:}ᴏ!,hgEE>)J[L[USiOĽs:y. (51!=A\&5@@Ixa _%-�UjBVBqX�GF:+5Ѡas\s+ܿ:f3N<IRζ”; c޹Uҋ=5G90_\Tof>jRE3 zc]E%ʾ MU:5&<\5r+ oI_?8:H_Yp d$Z15w~'?_x`Y#M&șZVg]~bdWo|\}xr;@?Έ< J]@@'ֲ?&F--#cH96yԴ'B+.Q>kz^:9,]Hrx!:Ei I:9uU8�;"r>8'*?O$Ytڗ[Ջ>nzFe^ ۝D:ʴ5‹ +_xd 1H/H>Qp kS66pi7BOo8[gM[_/o淹Yp�ʣ +F~ur*BAmz;Cs6B uLW^N!ЙF5#S .pgUn(0e0N%8v79ksal=*yh9B 25ⶄ/HO.3.hќhyИP*Q�3cl8 hwArdQ^%0..tcg=e*cG 7qbwM>.M1&Ψbd7k +U.$6q0�Tm endstream endobj 417 0 obj <</Filter[/FlateDecode]/Length 2252>>stream +HS]n+H/ ƌ[MӨbDkH)Q h0"Rĕ*WB]X\DQ[11"flbloݓNdkU=|f>yyD~- +&kC[-~`PF�׼m+LΣAD*j(g�`898иQEͦX̌*+l.1k̹6S}qUî@C$Y?Ah 'g3 �-枣ZJ3jHVx �z)#BsPeN{R6>SItyz3K$N;~_yoS U$K'{_lgJryg��qlǃsIho�~Sh͢BFdUzd5zٵ[?&҄aڣm>m"�<[.>TP*?Rxz6}[`K??�3ByтRrT[L׫~+ILh |[5AtaE矷 ?j,4*XE?�x8?Kndgk.|p6iͻ6�^ΎϻȠ`AFbPYE|^nu%ur][,wү!>ޖQBC$ A?�il )JؾS3?sF5W<}�P 1GP9=>~SqqEAyεZzƥckذ<+XsDOgy߳? Oc66n3JJdʮd$|4��=i^/?3ݿ(/_V,=4SItߔPH$៑ _ٻ_;{�hl_3ʵM-q ֩]x_�8;:қ S۷I_:S:a>UD璉ay&̼y{@�z`|[Q֭>Kj5� I|(5&838<Zٜ1/uYW/Sٔއʗ>B~e[q9?�x<?SFqk^4N_vx_�v M0▄9ݒ24o[lbyR+|ǘa*vO$-s =~fw@�C`&? i7+VtYGÉj5bc �l@@Iasߧˇ:Dg5EDѮ!w*|=/tD3 [A{|�OQ FyqaW.qv}�ZXE g΢;w̩*ʓJk/iw&1>p頗OT?@{g'>Ҽyg � {?G괊l)QFaݗ}�a=c=P9 Zy3%Nc?ՓK&R/S %lG�<9?&o +eguzU 4Nիe99�z2˿[Ы&qr43Χ '*K oי`'mZ=c�S`fڢ(LEgXrȕ}x �/3^n YQ_"mt aOq{}3laoo +!;o!x,:NUZ�x! r@NM\wϬ*ʓ<gtCVMO1?g@{u '5B;[�t[`fJrk+ϲD,֒l3{&zȠ`A'Ijrӫdg-=`Oi a=\2zy_>*)?�xz|Xϴ9:UQo�D"(iE(?33!^aǻ.[5sHs;UawBޭ̵.3�O=h)J9xQFys]X8 +qѬަ(̀cQ_dZv1t-X D B<e{۠}qoR%3�O=]\ٹ}<g[gê':G�;gќi)5&ƽh8X,]N#1%6x頗@H. +_O6񮼳� `�5H endstream endobj 418 0 obj <</Filter[/FlateDecode]/Length 2589>>stream +HiTf6TTKX"Ph6 h@. D("Aa0Ȏ%(Zwڴ65_y9Gw:~r{=V=AL mL_ k^�JIv @~jXpZOlRwĊ^!˜Kґ{�hYEѡ }幼R8]?ݜ<d¬)Ҏ,5L5o]wb kθZL +_GϖAD@Uv݊l~kT_}VLoǍ]5PE>γ7&rmL1;C{LPR~MsƩ|x8>#d` vӦrSV qQRZxٸQ&pn�lj~(j<o;ywr N~ghιZms  H5-^>>y1kYj!wL|4zƟ-!3GQHK2ӀT sڻCO*TUqjκ ~n9}L0C_B8Ia +&'Ī܌VyręȨ(]\Ls?n Gw̛Ԝw~AzB##o3 |ܙgIRf .{F$~򸨭f ,m8hEf3w.n[ H� d)4g^U t+iL<v9׉9DqrB­yg4.&zƟkr6@y(:T̗*H^ HNZhνq +c-,p4=*relRH5^WV?4J~(e3ȌޔxЊA?^j9DRQ:W}*Dž�q7ld +!MM +V="PDk�D3EQEٙz$i +?mυ3anwEB~鰣sGwn;}x<yw-:Ϳz?v0`ρ"=BOW~473}/䧜Qs,d=c>)\`y- +p)(M!|K{>hF +yEc2"bэ,Aiax#W+5g`Բ}yC== ݲX,H);ˮE~M `=DQE+E$ h#mfufw~~zH DǍa`[l~՗Gˮ8}~񈥥41˯*R**sEQ}ތ2OvH{7 lnLڮ{9B^rciJsmPI223 30Es`]c墴|uPIwWz~a=�ܵsEQ[O(]&L{7  {GBfwot#5ly'߇u˝mbaѰ<Ap#{zs",wkOUHlkô /v EѡhCc7ٝrt*@[ B}|jB9]5^\8Lq(܊޿oB?C}*8/p8餧B­Sw :ITk7@("VNr1@[,&Gvl[PHp=eTH[.<|6V!3⽟@D_W_}L8r\FrR"W +ZOK[ߊ5]�(}%ٞôwm,C<iuXl Xn_{1䈮WiF @u>ʙOh+Ía'FcKibr*d65"/jvzgo|)@%,CQEbaڻ6k,M`Zghֳc-,|P+ o)EQyio)>Hϫy>[2ۈݤ V&Xeљ'+jrW9[?VĴViMbV(:p?�d'iI?fK{)ٿ4w2a@3aPJu399x,MR(hREkH: (>>~apXh1DXI}bakKS &w-d7@j9(.ʣdHm= mB'5Z.]x?{:}Mއ'f`�K!6DA!ΨTw:iZ?'EF5 o3<BQE$gIɈvk?mDpnOi K|". ;֮H*r?ã͞VBǨ& 011GEq:v8~ɍǫQ5QaK"F(C�jS_ endstream endobj 419 0 obj <</Filter[/FlateDecode]/Length 1845>>stream +HYPWp ZU;hՎmu0U)"0*@X $DqP:+hѪ%5H]Hr}f9/y_��i{6<AXȽS<o,5̚Lbec2 a+e6do;2y+}Ρ:R5MMS1}{.{@~( Hc%*:0ޚ���@7wr@ȫ F1gZsϽavܠuC5s4  +:hvV[3\}\��� ՛ņ:J׼έokQ?My)a2|̚?hGNcڹV q>.���\=YLHٔ?g^2~8eN^h8׋4(Ms͜}=G!}^���>=Nvu!7F)˚§s#w}3I^Y mlSbN~.mr{ΐ~y���D+[q_Vje#+q;GP.|W@y <mWx(I1ؙic>3���|zwƢfʟu�KZLC|t?@l?ho[De,=kW<Mc��WlżyLKqXȹV[}e3cy)57cЬR-{(x1vXPUF>7���\=]ȹ"egQ2jsS1CW &¾e +TdQNnYdHx���Z.YE)q;!Dv-$g*NCXsmvB�1w֎ɉ`٫;y4=o꘱���:e~mlx9T9I]$i̓gYo mglbbAI [7˿ˢ7&.}v���nNl6k)ݐw=4۽̙?@L,?CaBH~)/xg~ާ/��t͚zy eÂsJsL4(O9 ׳TV'hjXp?#/O^z��etv~lUes<6, N)=*"VQcLbbA4kX͹!.ip)Tx_���KG#OM\N%a +7;rwI1S &ҠLGUz|wꉆ{ft#r���s|fjS2ECҥ7z֘´w(�?KRWg\: K���wdo{yj/QUߢQm }s*e)ߔUR &~AunY쎆ZN95���8ٱ^6<>X*1?#k[ ^{�[&}VuYDlHUZwҘmBr|8{���Xд6ym!AYdZ1.c:fD Q &"<9z 2io7W���&R) *KPȘ;m +f-i9�oZ&@s6Z{`DaĘ衼��ce׾=;S9(S/_jp 嚸|:Kg(k�0) endstream endobj 420 0 obj <</Filter[/FlateDecode]/Length 1478>>stream +HkPU,ȊHVe6c5gLG.ḧ́E -/Ei-]3$e}YvY`K 4^p ^K glYc�N;3sr:Li*puL»4<vtlAĒJD粵'_y1<5-ڢzllmH^^yr~Kf~z^{eEjofL[0ݾua'x#҄���֯g7fb)?q1UZӌ]Lu{+9C}wyMRXS΁8I%svcWLS ��@OOXϲb)\1ښ>nae잔^^4m:|,L_~¨ok8ݮ-T-oN5��7ж$ml]/f;/$CKK=- 5Ec + S'N k"?jVuaZ=9̆OJw¦84vX:"u���菛uW~e=˻ S?zou_zt{?α-12J;R(h%}uN8QAI +whw��`hN$֫x@۴J;\\W\NHvn\YU)v=ˌ"J���\9`wNj"`͆@v^W21Ds]vJ//]1z4w/92y=$6��� G?�.7SIpGgOiG}Č:(n眓ί]fk[ʵ/.��� ssNgXv)@쏾3٭qúkK-)['T*))jBc}o|:>���/?Y/FϻӥS?nD<g5lOůL[6pn6p%i���.?rNo#₸wT` r +G=ß[!г*D=r%F??w��@, gxw` r +G(HWnp*\��HIb`g=ʻ˥S?/Bm4;{3}y���bg,?֛+l}wK "`w\:bW[t5u���b=`]awK "` LXT/��ÚE/ JR)7[uFGE}��p"֓uM-E1pK?m_>�� 6�֓/ywTa r +Pk%��Ăݢ*j)@p_aLo=��Xt4~{7(xwa r +.UgJ+���V^̶RH$0�boT endstream endobj 421 0 obj <</Filter[/FlateDecode]/Length 899>>stream +HMoLa"Ċ`C TBJ՚ȞxFA$*F m:Sg4^j ;!Znh47; <s۹?Xnj;eJ[U_1Ir,]f��gE>j7'i>:;Jƿw�"nҸ?rkE] /j�2_&=\~jz-`{޵pK|��M'lHl4[zTF_E �� h2%w7 +fi8o*��IjW˵[l 4̏lr}^Hv ��`l> oTo%Ҹ?hZCc=��o;w6k7fiYS&߼2��yA{?[,_mg~nS��mnnO[BZ,_v]ӽ۷�\I粽KKk4mo>2Cǣճ�@|\<[:͵YVɮw�\IZutKﴛk4`,<>XJ��؋PmݹڭYGp.RR^��tNvn^q0KβrC/#5��_f]VxLq0KV]OT2I~7��UQh i5p0Kւf?b��`cҳMmҸ?6Ù��oe9C5MҸ?7@{~aRvC��[5{3DYg˻:@#�-�}5o endstream endobj 422 0 obj <</Filter[/FlateDecode]/Length 1206>>stream +HLu ^ҖMEIYmY.C\$*S$`0~1BфGԙGm2[ge"n_^ߗMR + Ř:=24gnT7+c弯]JXgu?[FY9[ -5?��f+\Kg@zLw SjۿXHst ��gE[`5 ?o&U8ԧ��Fzk&/j4Nax4+R7itw ��w3H(}%;A)ڢN5�TO~k)ݙF ~w(=<ݻٺ;�F/#=%}3A)QcyoPW�`42 T0~^ut#8漠z{�I]H?IOJ#c`ӫS~{u:~\&}�@uIz)qitTV9QYU}S{�`\C>%'itٓb179/-y`b(=)O�qcyJEk D{+~M}�0!ks1ݝ )>?㋶yn|fyiq][��s܏;<A#ݝ r/2?"bV&+䝵߲-Ö�8wr'tw!nbN3d\aW-|߭]:/nE��;_=??Gg'jB s=)lD*7JmjE Kc9,G>qerT:ڬ͵n<!ϛYU'cu>�?k;@#d ˦{rX6 iHȏv Wu-=^T�_3^;?;4 ,_Dejt\w89~zdY̴n?}{\ �ofE>܉AB%mΆGiILǰ?_C=~�]J?|'<LAB%VscojF.tw� 2}0=e`�|9 endstream endobj 423 0 obj <</Filter[/FlateDecode]/Length 917>>stream +Hkqɏ҄ ڍ!67j 1$~b9+\,qDg0cggΜ!;cY̅q7%W~|>z>oc,؜3MiKhֹ,ߋ|<f\��Ǎ<Bu5O5ocqabqi_uƫ۵[�pGPB"n~4{l\6UK4^�5hte?Kǘ%W:n�%uv{̥qeyŎ#v��^Iz,ϸ?KOW]Ez�>HySUv00̥q'$<?==n�>ȴdO`.N5#;�tCڙ-q0aqFI֛k{�H} Fmޗh \V)%o=Ni�#t#t(ap?K[yS"=m{�H]#(o n4[eE]o}�RW׃w va?K}�H=}۪Ofh7 C\.5U-Mmpw�RGC1҇P."n47,>uE>~{~v��?QHgQڭq0Ꮂpp �8bt!n4wL.6ͱ+/�@t .H`.-yI~t�|k˙!=xD6a?Kp˘%|ZЏ6|hޢ?�'d=8/]n4䙇^C߳SU �{UHfި$̥qi]ef]{*;~ +0�0MP endstream endobj 424 0 obj <</Filter[/FlateDecode]/Length 926>>stream +HMKTaCM^W$0J + *EfҋRTfo(TЫqcSBe9 jes/EDes/}no,@Psqj_Snfr fvh3'8t{ZBڝgٝv7!�}rv4bz!uĤ?̵rm"}v'�ܗ++_T9MZbRf;<E�{˽?qv Ĥ?6fiCn�sυNG݃c0_y˩%cm 3�z_řro5,AL +|3vZ-asS&�urkw & eS"N`k^+�5V }Ekw &ښ&:>Ԝޗ�Rtx펁Ĥ?c<^ojݨߛ�;5l1pݕqjw'�`k_u|v}bRs8ޟ�!Ӓ;^R)H1)' +vڱސoWߣ�'w[qڝ`ƽݿجݥ�bu{2 &]ǃWw$~VO�&:FݻZ!H/1)[Y`=o;w{�{r^ݖ!H/1)o+?K?ݾZ[�++{]|zvw Ĥ?pʹQq#�+r:nVkwt?Ia j~&|#vHg�?]~zLk΀1)-ϑ`tv�~J*]&ysNkw?Ia-N`8R߷��˒{,w\vG@c��ϋ endstream endobj 425 0 obj <</Filter[/FlateDecode]/Length 1384>>stream +HOwL87DؒlslSa nf8e �e@R$-8dK6`,q F6a�KF`-ϓ|. p|0<2[6nb=6?j]m vfQs11��k>eg7iy>!܃s}FETg\$ �"guy`\!YѬPǯ��/y`6'4:^}�#vtwIo`7}qSxa�d3.z-�q` &$+U.t7=�Xow+-0[�@Do,js.tPM6%��zvY?DKX?Q7n̜jEʂ4 =IJz?5 o3�?%#6*/wx?Zu[?ǣ9xb.v% �_gtޝb@D̙ѰC|z%Xfq~|NK*; �OWY[ޝb@DA%OwtbUf?1YJ~0XPV�'ʨ_wTz"baVn)屴C=v?Wy͕.侴A^�J\ce a G +̦fsT[$y;c6c[4P��rF=J}Zlv|{ǃذ?[_M0g}vUļߕ�;m?ql9u٤ε��rwoŕN4FʻA|Lg/:hg(mol;r\k㙹>=<7Od#3Sq7�=pzzT/ g2q?T>7|Up7hV0h]v^o6;� '73m3W^n<K}ʻAs"Z쌡1yȑy^Ko@axh<j7p5%��r@}9ئ c3Om9Vj=P''\NtF� ԛ{pDԄ(L[p<lju^44w/ ,EUNV]�e&,u S?`)Ve2iGZRw��Q?]n ??jGYe3N�W�Y endstream endobj 426 0 obj <</Filter[/FlateDecode]/Length 969>>stream +HkqOIRDP[i-63,?ñX3#sv{vDč)?+99W=}LK1PD4lE[OqΞ>w,Y޵im,uwά"<� %- 5.j/)dBqs3:n�[5H/ +'Al +2m:s58^�}Oӽ8uZF~c@&-vvw>\sHĦ?i;Be>c=ڝ ;?Ma ӊ+K̩Nk{u{��tS ECNĦ? S<;Ku�ȅP1OOzPa)dꆚQ57�c{Gjw0 6l X*Sw�d% ?Ma JLsލJnӿ� Rcn:'{ ?Ma &׭6]x?T'�@&I%c~9;΅Ħ? +[FNts&[�2SfZ؋Al +RoX(o˵�Ȅ/K'Jm 4,X؍Al +RTUb◛{;�cg^k~X؍Al +4nI#�W2x&}&ݭrHp׉:x^�>uXڝ 6 ~<yw?n}G�ߐޒyjw) +4\lKooy8{�ċqv\+=ݥ(bS2;7{76�;X /Eaa*X?7�+Ow;O}%ݝ(<?O�wr endstream endobj 427 0 obj <</Filter[/FlateDecode]/Length 990>>stream +HKwO cТvQ݆E7a81a(3-F/s(EZ_9<R2@F/z͋,[sON̙m>5?:u�׌\IJO1E3Lɿ&!~^Erm^g�D[ 6Zݕ.)xE8Q['K �8K"D?Ma+ҜH56[`ćOt6F; 6/[l{5wr Tݜz7bSœz ?@HHHIiw" Ħ?Eϖ|q_@svaW?Wr/k#�a }.L 6ޞgj:ꎸN<Gd_neoj몦w 0lήJ{ԻU?`Kیijqg^}?Ma|_h'[R�J{Ð + Tk"]O2-^Al +~Qr:ح�v]Q%RބAl +~Rx4Oufjؔ/}hvo 6?Vkm'K\'d �jH8Q[,m۰?Mao>-3ݎ Ggi1�%ݰ׉D>4]?MafڜIs.;{Y �<<Honh2]?MarBf{te_ۤ'/7rw>Ħ?g+֛dd_E �oJ}gvwAl +~WU 9�EzAAz"7ڝ|)`mdOD �Q endstream endobj 428 0 obj <</Filter[/FlateDecode]/Length 1930>>stream +HkPTeWn"^r n5Y6dfT`HrIqSRb qQB\…݅ݳg, piM++QZ㇦OF p}33;y}.1�޴)=KKRb�#Zuˣ3`(H/z}wo CywһR;�: i.$WFQ�ÁB�-K+x=�ן'SW<H=� OdYx0):_�|\u.<j޳ `?PTofn$*<{�/nҼMLp֜dBՁVn1և  [v}އ�;zbiE�ŢQ]^SlKOH j_JyW1snOe5vKgQS p'/zO,ⅱ7\>T|l9g33`PvQ �~i5]~X}�K[Zd+-Y*N (%hdC1I|~D{�׏1/V暤`U)|bƴ,+)9)]և;|ˆ6t�ǹ$^8mg |* RE#ʿ3 )[_bz eE&�cgltR1�FR6*'{5T |s䮭K!|vqߟ�>~=[�< z)7f괿)HK* ,5ժVB@sOv<3qe= +�u(K}L{�x96++FbLX55~R(z+eh)wGExֵQ0)m+/:7wx}_f&I3>�~ c޳hy'= kĮxM?bNkc: +~U˙.LU�0/3FJ}K{�xi(_+YյGDpݦT[F Y;W0M*t}QRJ6Loy�oC@b_F9QԈm mkii{ûVfLd4�7lnP�< |=,5ժ61xפ'$ Slvnit=lJ>k5Y ʟ[#vlC3sWPݦ -m.X;f[hVorXo[%uu97?2%68չ7߷0ʮڛoڕBrVXj(guƦ1ݻ(-Zn.sX8)#hwj>W6~(v$:?GxS{g\\^m}fMWv<`suQƲ}P0:Xs\:+x ^=c>*m+rMycK}ќwQ*Q.{]:ko&]L3//Q” 'e=3jXL٨oDFg޿�/ƙ!ԇԏN�Vк?eSlh OCEe9IׯQFrǤkצn[Z¹U:'FQ_z]8Ef1ԗ̻Y LR~vmg`SoM[i g&e^Fو~eYcxʑ*:+zY{4W>崚z9tƨg/A/�' endstream endobj 429 0 obj <</Filter[/FlateDecode]/Length 2908>>stream +H{PT/@5_jZ6m|$FqO< X ,{wٻK W 1J4>i=LWBFsswϗІ%,3wU9RޢFSwzm-OsYQ|�Zލ;YPOJ]N9\ M!&hz~\Y_W6nɊXSa.o_a7eP30<s}w쥋\uG|q?/;MQ<c9!�A|Ӡ_ m4Ǜ% +8hsჯ7<ߖ}8f>}ȷ<i,>r^ԖxƴqqcE�QK筍t9 KYO<\ D)$A1nջN?_T8b7L1hj̟ΏmdĒ+iapsq2:?|VfkɄ#} /MH6h/ܻd :襇ޕ1 ~ܘvGkz݌̦JfO`OfW9-u*\jNÜ ֖g?;X{izF}\>}Wjk.+\IYw6MErVpJ!O+߁ +&= ]!Y#]k@+MU%^ +͎|(_#k0hYSg =~)Y%)C]n;|?|#BKVʌ 15Y?+NrŏtΧ5N]5ms>w7KW'ǖ5YGEwJ'./qۇI:*?Єd?&_HnCl5Z=nrUfSbj'A +IPs)\jNy`;u\Kі/n_Ns/+4lțkcIߕB#Q]<~/6}bNoC *A]2t#/MH cy92C gCIcl.yS[sڡƩA? 9VjU2ht|7�=䭉GK߬OQU ksmdH]]ÚXwVz3N7W~ PO[@A&$5qCtK+cw?YS;{7hl";E.'ϟף+E\; 選w5P\4~kYSףtZik U0WHn룽`/]̦J%}W +cSv}":hݿDTfL ]@Z�V8&J4ҧL]y߷Twllc0iHꈝxѺ;h i,515z~Cޱ沜̒h&ޔboBN\XO<It_kzָJ|j׍ +I0Rvl~A/+SP7P?PGkAhB˓zwtnܡS<U͵9Ak(m4_J;a\ќJmCJk٫Ns/QK`8m/0+7A__ќ=>ưOLq8Xl-t]ohJ_)6so:WٿcPFAs%whLB@w8\.cc%=M,go$!uuÿhB@*沜ބޝ? Nnlo{ډŁ6uAFhpBΏb>>jm7;\Yn:״`*ҰU6uu1.Kl=ʧd :p/L|UkrM\ܷn}4̵ܹ- +5tlD| Žs9YP' +t"MH6AHPZ(g:ԣ<nIC_?j8 \t"?MHA q +f0NMW>&!iRElckAhB2+MrvˍHB +8PNPYҵ 4!y<;RFk/c}_B8>AFIX}WFtM"@&$C ϞIUTMj}1o!"HcFQwOWpCE +?Єd?ddL]Ih2[}N2Rs=U B ,G%O\Q1t!A&$U15s-/.QK:9k~ںUxRZq΢-#?\bi~U2} M{FyZys 9ZCMH#ۨ+}.r:Hy91r}KT7~5qfhZ;;.n~tGG(&Le`}qPzk\cxg< g-u+.-6'FhvɲLݴx@^8jZ(u{^o0v(ŤbP_P5Rd(#?Fp>\hUOt*ÈR?\6 \4n1Bߏ+n^ޝh<mD��[ endstream endobj 430 0 obj <</Filter[/FlateDecode]/Length 1776>>stream +HiLTgeUEmiS1⎈,*UѢUѺT6E 0#D-Ȣlw#H׊Qqå:4q)\'9 L9|@qӗ͍mz.s',jҹ9f1lz��aл;7pzPV}Ez"oj CӘOS`G57-k E9>r3e v?|:qau\;���.vv,?R!R2[Z}3% 5o?�^)ͼyu߷E�� 7lDLI +9cma@xKM㼌>O 'ݖxbAunMV;YZDQW��`sLRMQiM:7O!z;5�f:-\P_?lnVdh{'���Ɔ7NN"jU!*`cQ.f2);E(S*;DA&2|���X;kk6ǗڜYqp[r?k猣Cy4J]Ŝk2cYSG���sEcXS_Q{ww<[((d%27˺82D֖j���̆9Yn R8O?ysyG[=/i?G2^eɃʘ^bl޻��ɦsg6y,'1W轾^1QKqNL1�WYiY[ ��QɲEz([?w䡼B3 c7+T"}d%kNcx��YwFy8OQ1QИs7_>rK^&K 7<:uZp6( +2#x��=P>툋:zT$6{?kcQjX2G^B�9?\hC+n^��9Ə2cܥq޹ˢ@swo"Ʋl̋iMhQ4F<+4Ʌ9i>糥bNBX;��x]9| gQڼ^(K>\T2I.|rAv +rb#p +Gw6[ZVЫ[wk��xiaب:⇥>\ais#5 ˻�9s ݙPYw8+2VufUN��_sxʶlp:qz[KR_|T-:%)W?�ޜ9Eq.h7ܯ?`k{U���mXI5xa^wӳ W/GP.|0+֙gNB�91sXV*.?:k|äשj{W���9<HWsFo~}97ƗH=)�?̥ЬWjmoIeʝ%V��?-9ݿһy(I#ߡsuTuHMzrbN-G!_>˛��qwqe#K(C'TN_+u�ӾbFAfrG 7?hRfTU vl/�SK�i0w endstream endobj 431 0 obj <</Filter[/FlateDecode]/Length 3393>>stream +HmPTǯA#cƎ12`ӨV"R|UTAeyeew.ݽHML[p]q+3<9<qLLOS83|]Ɩw.bbbz˞ooAl<}~F_+mI:7$Zı} }ֻ-Zh(_n+b-쉬ʘHhFc9T:jiq́أ^?i'pv\S5ofnCmX3c:N%4w;�QQެ=;PVh4onFzxyNntݨ>͜h\Fj]=cyYV%X69Lnrnmi?>>wo|^lRǏjxM ^K3/AE,?cRR(ᾕg`.XH޳ӵKy/(/傑E* 11 '1`c( _b.O_W2}`x}v|cX&X/lک=[ =Vژ79Q#!;๣j^1W +3l&ȡͤ�ۣo;t98w Hʓ>Hj>�|֘\+r貶6Ydv~kݎ,&> 9U&:vv|[Z:y۝͚Rl)F̻UF9投x!wga\[4-k޼s({Jfu 5Sk21IB?p>f46?&(l kfuen?^[-/z}nKZhb&D6a h',×V;|M j, :D$Hs?SSWWl*D택sf- ֐b7u݅gE!V)^߽6JM'y"i^JRBO[|擎N&&ᥓ5їmu^&&g+l k15uM7Ni)YLU5r59ye?i9*}ȡ̈́q SX|Y'o^Ͻ?ϲUo:n'W'6{>㤝\DZi&%հT\ Kc9rcsDZ'ރATVdUvz(?>D?/61G$_i5*?6TW6xm$z^:/bX"c`V@A.mO"`8Is?v.?1&X/:q[MԊ#q#|0mN}<3mHi>x[f4]{iQ[=[E]Ou؂jF(Q&Cߡ!(}65 wz:H3UFl*{ W +kK ڽ9޼mNritu-\2M P bAN;o. ⷼʮT=;L�/!JM*yTo񇷵}jncWQЦEN[rk+CcR|EU g{{+JRwǣw?1`c( _Hʡ˧cia}8\Zon?l-΃i|xN+M[כ2i-W/mw/\em>&X/z{]ҽkZ5el7zCs){T' }~{G;{1/!{c*<<.zv@x5qţci8@6qcܮGy3#807Ώy{71OI^X;ug!yi3:\\;!qٛ'@J򇷺vO:6))9J/jtbٯx<1ڴAy }~B_g7{q1`c( _MUG/O}4o ?o827\'`NUhhhܮ-J3K? ҉5_S9 +5.li g=a'_<t΃/뀞hfOS_R烯NۨzCJyC|tƼy۰WMA|_rjcwwzot?+{-3y SNkM4KgbbX?JcLRc'_K"F-z/m@N39ݖhG=?DC|x$k*z {k!.k=+m<yx&"=ck'&,UBaJ'8Idby{d4?>G/1>/չMjW;xxͪ9`EyQH?܎Rwv,# >B?)LLLCi"@qx}@Pz}8)0-Sm3NZ'b +g;԰NyoBp>_?/QaG! @):`EtCtPEWs2JԖ p]wfdX6BiTJڮ!h^:tny^gx7NiwWQ �#ӔjT-" OWy/22V=Mu_Q~8M.=~BY$B.�d#Ӕj(]WmMPk3rwȆ,S"ʜ/Ssm7/P({;�LcQ9Kߞ~Vׂ5+DŽc밲lZj#~Oy俁hkQ�Fr�ўe{tZW?7.PxD3~j<pg�ri?�T]]1h kK{6{XϝA�L Z8UC׾mwL]⿙!wG'왫Z7w� ?02 5o>k_" m/zw>;BSZ3�i?�뤸=>gޭkM|+M .kwX=0ɝ)�(<L`ME6x~FWW }<89Ǵ"pΆ?h[Q[%D3�œA%�Eg endstream endobj 432 0 obj <</Filter[/FlateDecode]/Length 2077>>stream +HkPSg_RzV\gG,JUt7.R. +CRZDX  +Ynx!]*eZT +LM%$v$9y<x ;Ϸ}^P!/g)b ": ]M_p5wocIP,/f@PO/}oAA;H ,uxnXXF?U}Ӿl6Y?Huhg>?SR_?b?#BD�p^2c'>n_zs{t_zj՛N>,@=C.dZun4 <w-wz~BYtM7lrE~^tLBgTgUYA%'4=<wKp?ظV,ՏHR}Toؽz]$.l0rZ;A^;ELV*MҢfnX]=? qaNn)U4uњ!8z]/? R^T7ՑIucELBCB^Y\r_kdI5+:A�}Q7 V{x!,??߆� =AK/oAu湛Zjߒ})g(8>#�1p?B>;?J$l9R"e*�}sva>t봞XL÷.Y|b^K�wJ<?ՁZsNT/o3t8>#�1p?btl4m3,ZME㐌oqUy +-6]8z?ܲnzV!UAyݼXAҼiTŗ <W~L!u8\^dξI=ک`0S:{hi_t) Wfi4~=ch4ߕhgC-2tRN%9%E-u8))~6gƄ?+dO3cZfSqQ>xk&5?/ho7s~o;þPMg73MCi46Jg4|h^3D3>t,pa?:k./Mq~gky.99RO1@x >Wbm,j0C&E~ꩺ{St>]GO~4>U+vͼ=ϴOh�Θ=#mK0Cw?bc&m3,ZMqy6`!B(o]ӃX FT"a]f@mᑕξ7<4t,(K BI4گѾ �w*&uv,YfjY*]������x1JwvTzl%F{b#niЪmTxϞyrHC������x9Gn?7!F, qgR,1l����������������������YI$t_m6 76Y/],o1Ǥ~|趔 8b32ѹ'CC=d0E⢖C|Y/fwZ{K|sc$ xYYCMsmׯNt8=- +ʙnw%ș=6p"?/|$.c Y9=Bso=<jonĮ$ 7�sֹZuo`9oؓ괃dsc$`¸<x;/*T0'[sDŽLQ]؋gIr^,joiyoA߱!_Ʉ=Uzy(;{n2VWlk`rǿ:9)i~;=Š&mdL&3ӔC; u˖DwQΡXaNwv^߀ �VZ endstream endobj 433 0 obj <</Filter[/FlateDecode]/Length 1842>>stream +HSu/= ">¡S@ꀚ8 +:M hI1x  q3*"2 /NS:5MSsO.ޯw]üo0e^]ƸϙˮWWmp5WKqnGO)i$7v]߻dlmtkNhm.umulAz\>6VY%y0qWmu2@Q9YOQ(?gO84|/~Y~;;H|on:x낽io*o5ur>ߟ|Fґ|/2qAk4;Y~ `cNۯ?O}0Qe 3d ֧&Y<1)ޕьu)( d#*"R?Ta}uՆ!oKR&caa,.*ivV?)?RWX5 Bֹ=;vנoa\ǰ KﱳMWNk 2@g2ͥŪ8=؛G]quf3ZMz`O&Df#dAWYr|tka!!=d,eOBÄkqNYMHx~v U OkxufkQ̔HQQؐrsia2@rb65Qºv}uw0TNx>bUli|G[k KÂX1)Y/-gMu3§ +4PE8`,,qAS+,x^_]J/=1>hm./V ޼?p3<jU d@{K{dִqd,M6ݙ=;;jKby 3-?r)ѵ kv T ԩ=eiΑ1{KӾ&Y<1)YX2֥,HaPᇡgU[UR.;)1CҴ7o;G{ c ?g.AY~,vl&s]=t'Yo?η5P><'\EC@cO}w蝈?7Xs-x낣7³#NoIK_yd,=W+ۼrROnWo'u>]T2ZO,u> ٙjG;t!оq|;5&W̦ 'Y<?+%߽=榤Uy9 +OXV۲q +2<c +bs:T) cxr cY<>4`ٺ>-7_k5Csr9QW_�1<_Z@ƽ91d X͠w@)WzE}]MHwi d%%7}6阢PsD`C+ScS:?^2vsض59r57Pgf1ႌ'/ړ8ZˎIzw/w)WR!cirmuc 1׼K=G; *+kڳNGckSxZInW">.!5zA/Ц%wY#Oy3sؼŪ8׊;J c07/_:"iǖ7.{~1~u)s<?:;k +~3d|Cr?TOcN9[>L������������������������������������������������������������$/�8h endstream endobj 434 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 435 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 436 0 obj <</Filter[/FlateDecode]/Length 518>>stream +HJC1�D?Vm@LZoC&e8������/V4Θ{އ}i|zY[ `տ˰VY[}, ś?j>>>,˱ś?9+d]VLSk4VLSk4VLSk4VLSk4VLSk4VLSk46I*V>X5`bՆ0Ii,ŦVLSk4VLSk4VLSk4VLSkoɩIbY%{NL{;fR%s1<)Ŋ+>oVLSk4vy\o8ďO57u~)fصbf]+fصbf]+f)ԵKPf:]te6*]{iV}Bk/1"]htm\|:Zf_:ht>X50[k MYj3B? 0�De endstream endobj 437 0 obj <</Filter[/FlateDecode]/Length 580>>stream +HAn1EAҌM<v4RYW'<|<FytDdj-x̫1K3,ͼ:4xҖyv4hhѠgG zv4hh ;3XԻcQ;SEL; {x$lfᑰGf b/í̽<28p+s/ílGG|zpdQ-coAnL=1Ɩ||tbЉG@'va> 'd|^_x r.o 9ՀLȩȸ~ llz_6#r>4G>އ"˺}Όȡjȩ>]d2$|!ƒr'$t0%g|%'}gMjf7&'Ԩ19F F%u7[f5kMUoNv԰9mXPs=kZOdi=Mۓ^4nPvӸAi\Nyϼ->jzț]4pRvIuK^L7e-Mܔ=&&oTvQadJVY;~ 0�] endstream endobj 438 0 obj <</Filter[/FlateDecode]/Length 850>>stream +HZ1 t +mg] QX;e˷_Fy톊TIb7"ƊL4^˵Gbmf; +6X<G X#d[,%[d-ָ%Kd-f^fos`FY ouDQB%QA16<^ DNjAkޡ~gK>?%_`ʊ;iRǀNy1`Cn]}SޮG +yLoVDŽz/Qoac1k~z>GQ!c.7z% {͢ˀ1r + OTהP[zM#FMw5iR۔zc&1p[zo&1}pz{.9 P*!KҨRo&hIjAPX0[yVa}AqԻIZgR/(x%<zɰFQԛuz"ZjP)ah+DsX`aUˇJ+F*Ya z!ի<`*A} X;qE}X{pH}XkQ:L} XPӀNvC}-X<t_bBQR_/BEZS0Ezei6K}JX�z =a3!,&Q_2{Է +c°!>R3 aMcq@}rX؜S.7)p\>SnRָN]Xଘ1G}pV`P朜-Xԕ& +*u/`vyOSt^XD]GvbXIؑ~ 0� endstream endobj 439 0 obj <</Filter[/FlateDecode]/Length 730>>stream +HjPO;$b98h[t<FMin}yʜ5i|Zdm" |ΣҲD^wtoW-(]S7zS-c{f*v|5ȈͷǠ۵tM}4s綾 ]yx+ }.G<\x5hBUÝ:;r<ẶO6xo.S MLn>ueOf` +#ц2)* 0Xk&gmms; vF^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B^F(te`B~`Vݥ`fݥ`f^ʂvי~"t Á?/i<uHȯn]; rS) rS)i!}߇hS:2z0Es/S:2z0Es/S:2z0EiS�YK endstream endobj 440 0 obj <</Filter[/FlateDecode]/Length 597>>stream +HAAй aܐaBz}墾I>%=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:+?Oe Ttذ_9 +V+_ɧ:O%NJTrrʿB;ʼn}>Pwq}WG(lW??!|Ttذ9.e  +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй 0�D endstream endobj 441 0 obj <</Filter[/FlateDecode]/Length 2153>>stream +H}PSWc-bQvatke, *e+JU"*c X. (1.In ;|[?XB3m%'yȝ937g!�`mV.]F,ԗe_}Z>hH$x#!iIɹ,+^AX'2/z_^C1=\h³⟣3P'0w23(`-��0Xd$/ЫJ]]UmSز$8Ӛy,{ n� [=HNS`>[]+;sj=��`/ZL&'ͫWq&I6!Gh/aݍ`akA#*NNCQ:5渹6���vȯ_ + g~|I:uͯt'9zn4$u'Ɉ-uVh<gVvD?��>xea�'ԕ}ס|<a8b9o0}3D0EIQ kˑcg7s;B!��`лtbw_RG8Cm+>9BmAG2'uɊG@RѫUPjĨN��tT^TW֦-1O9N6?{.�[SIJ_:v67%z��HKU;쳑7 Azf4iZI2�d|jTrB*XGزIH훺~9yoZgc�� Ը8Z^ZAVHۻq| +E~\z֜vd݁^e~KVNL޻%B7_d#زWrmɭ3cUt+n/���FGN8^jբny3p䉅|d}^ +XD=bH#gIzȣٺlR`>#nq齗.��*>3k?8ǎLws O<R=g]Xw2ʼnzY(HLtytqy*RSv߾v|No$^]UOo[a{��Xxc.Wnjr= 3w;*2ys&L좽u�{Au!w_'6(`ȫ-u#M]W '_B߼gM��ý{"LΡy#::Gi^L =7<`OTr\Y~ށ}|_ FlXZg13v-Uk=^`>/ᄴieeNZ0; ��I7ۋfCJ&HǮ;E5j; +27;jsY&%&YQt;3Y\ԩ���~6/x&GbbW9 {z9vBV=8auި䊹#6b:{qi>|׽7|n\$Q~yw��,rxge<z4jF;c6r%pA.g:`o.d#=*ŕ +i|'<iIR+ ;;FۣިWq͎��xyvM jEHh۽8b[}4uQ"cڿw2'ժ~gp" ytqD{{\^;S@o-0 "bѡak���cNvFOd9툍=ľg" 7/XwDž45>DgSR-* O>j=y'o(?3+.: ��kv#_pPnf-qirwt%n�LF^'FlPW.]5 3>s4!I?6z��O.$!jB|pGM$ rϊu�{f@@{Ԩ|oT.x7]Vv~^2~|~$RZj�YϻQʋ}ѨMQoa#ƕNI{nc)`�uI endstream endobj 442 0 obj <</Filter[/FlateDecode]/Length 616>>stream +HQA[qDZ*N篨%H>,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй8NE׊ [Tr_y^�-G�dSɱæ]+6h/#E }/>?~%^9.|}N#;߮|+.p7Sɱæ縔+2h,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйBK"=py)Tk_/{xo/ �@ endstream endobj 443 0 obj <</Filter[/FlateDecode]/Length 1323>>stream +Hn6zHD+]`:-@H̘ 6O*L[g64YI_L<v/_�G�WkaqV5| 6e Z`2 M_Gm߾p +����`gx24{{lsͳ^W[0bq&?V|;kv%Mw,jh.eg>JcȜݞס~ Nc돧~Q*SϏV$>SmF8 /g?x*SoOu^x',\e1= o7>_|JmV ŹnG|OսnL5 ̧ [{8n]'05+m`ܼEǺ{#ougͮ/νWW­{ik����������������������������������������������������������������������������ϣŤ. ~_rɇdx?*ƏOt0<4G]w= gq>Qx|:./{*ʳM~:q; h2,a7 ?6P;W;WHvR+5|l0Q)]Ȉy΃fE; bY~�9�U#"bI.|$JY$csO0җ2 + ovߤ,/BrWtR%ehqx0閍'RPY x4Sz<,W+"B, Ω BLS= +fOr)UYAei)GȚWjevy!m4L892|L6{$s%U,źKY$Li3))2=摮cٓ.AfG;+l1ݞּR-;8/:w,U?q*GeYj6 TT&B,TYt.Y*h]Ә(ύ7{rƸT/[^imu͒IE@6I$3Jgm+7Y00g\F=fIF]Әgy7; +t/^"=m ՗~7ӍETUzZy}DWtmMh6\_C,${6>dz<RfOE%s]g-M啚m6/~c9>: +ߋVxP[hoL+?� endstream endobj 444 0 obj <</Filter[/FlateDecode]/Length 1819>>stream +HiLTg?@VIIֵ.Ic5պtPAŅE\\P$#*.Ȣ,( +iRm*2*[[y*mb[c'yr8G6ɛ&Q0LJ �[c黖[aY 7Z)/<٭-}V��i:ycs9eYoJȥ]t IBXf|OޝU�RGcXp*>y2fPt)A +��Fw؊9NikisS'!|]ޮJ.5O4AL23.OnO ��mY9S-y6VFs{"#NȻ`�{V|ÃJ3[-��F{z vG9̿DG_(I@=w�2Ä2ںJl%w3 :s޼ ��vlLܻ+ҿ~Ys-B6`4%_01|S~{cw|Q1VU]k޼ ��rwgKf̔ {w.3YmGUkblͿ B}\KaX[dja^Cε̘eMR{OO'�g6ltaώE&AWoj5h{ 2Ǘ1 rxw`b{'XA}1!"#�6Gr>-%IJ9xX. 5xCKN}A-҃ww�ØHS][V2k+B7�BJ]jJгD~M Új wl}z~(ʚ#+ ]x��/m\\XA{\樣ܻ_%w;<Zɩd}`� vHvĠ\|e< `8$>5��kr6/6(.S^߫ڐrKئx^-hŖp΂4(UFXgi)kz_ρ�U8i2S:];/ %`Axj0ﮂS?DZ2Q{^uܞ䊰2u��O:;Y>gSFQ qiw +>8ΉMPOU?�xT:z4:{jY��''6sg-Lw - ̻`�)n+oEʨt*VU}o�}CcƸ,ojes\m8{hWY||zU1QW5j + ?ȍPe3fw ��;Cn~cƲܭI,Q<]Y(3{Bxw�6sIB9=1sJЧ9�@8;:219&EykI;|7P>9PA}zn5RdRAFAs9OaEu}u}v�1m(%qQМ1tK|=ƿAh/T2K%Zϻ`�2R#eǕșJ�9`G){Ɇ%#;[̿Ah6V*ߢ$�07 kI7KGoާ�(N2<l8JDz9~ R\lq =K΢ ]Gcrr+~vsIXUav =h)�; endstream endobj 445 0 obj <</Filter[/FlateDecode]/Length 1828>>stream +HWe_FL=RK;*4jZj憈$ +$+p< 0+:#hf.yeͣS3�./w_\{?�Oi Y얨azMRA~׉Y! >8!nIsFN8Ⱥt.ny!� ?mN,^'(L\ͦ?2Fk?Ӝ�as|6ԋlj$]1gOìO-a,~2] Bh)EZ{A�k gXJgAlR`,?YVsUXG�P98C#< :G:-E瀰.{G&7;kx+;�ǞGaLS\8ymF.a*tq}��P=ؓEGmtYr)?beܧ{A�s c".F9Yevcd}�Q  j9ʉr'tF瀰Is˜.w�^wGɊ;iY(wR7FQѼIS��x P9ȃXn}3Q|a}֩]iy,c�/SUbUs&݈ +v}�7uիP]8h|dܽp9:).s/H;�/GuU޸o,ѧ^tiF�ߝ߰sSƕ6=6Ly: B{7STLeοkw�^w^:t_2U؂]��^ ޵kzX:G#F>Exߑ ?h'{@�zNb9Zme.>Ƞ_l:��5ijw{zDYV]ۿ8B!4,{G˜k�P=?Mdm,J<E�ҫ7۵:sJsbϘ_ < +B!IFa?;�GH},:뽪o|l34GlP5rt}%�gaO3|[2@U-5LTBZUȗz53�T!rk D_ ;SZ~μ�A=z+:%zʩb]Ys!gעs@(ti<uw �jLj":co,:=S:ĩaC`Lڶ"}2!jQjyslsN@i#Dw �jO'K_x[gY׌Ҫ_^�te[VI2( +S$e9s9 ewL{@�Lg~IL,W%:6hj�kt̶,[&[sH/V( 0sL;ʍۖ:)?�9Bb&*$֙-q/x\�^3:!!e)R)wL)"s@%mcڑ2s;�5G҄mULUDzOώn,*85S7W,RU`͎{pWʒ;%?�Bbs\~<?5: ٓox �jAVIGvq[9 1Ev5V9{@�vSw6Op͸%r Y"W@k,bɒIGSdUElodS-./>!?�=Bb\e:&)8c0{]}|Q@�x],cS``XΡ_*D#ї!/ R.4��m|of endstream endobj 446 0 obj <</Filter[/FlateDecode]/Length 2160>>stream +HyPe_r&UI딉IcL5"**K\ Q@nE +x!KEh&Ƚ4p7Gdwy <j̕ \Cl~{5BQ F yٯEUև�"{r<$ļ^ON[ވb˝!)u p|-73-%ʂuv@�`zaT[;+ +nκH2nm17cºҜuAw9 ڑjqaл̳�cWZBKuU3 2YbcKZ.+^%mfE m:3�0}?Q"ttU|:'㗿b}T�hkˤ8hĽ#]!^S9 ^SZ-F5̀A^gYDC@u}y($Y [/$ve%|9P.v MXg�f5ZC$Ug];#>.�f{+kr߰&?;!y80F qg7 pO~{uV@�`<l5>\+**ޯ6dŞZb?7%]ZͿ/Qyvn%9gP]pҾ{č}ƀBUY ڮϬ3k?�,Kr``7wHFNLMǷ%*ɧ7Ug`>2vlܤS`zZX}wWeo+'}""vl!y>eg֢�>fJ?{o*NGDLxwtN|xE\T#h(6 HUG"2?A d' p*M0';sN,e M\.(NJt}#d-ܾڪ: +q:I^Ena9Z8i7u<!u)RC2l?lH_4q'6}'5P#ϫV}]]m%�jX HVo݋iQupst7PTl �!?f]9b "- d;uHE)3j!-^mzZ<J�F +-^Y"n.>zT㢥rOBgަF>f "Sr"֮r"MQO~=Ax7qeC= +4vꡂ�cajJB=<u=r@ '{E硘ez9BgRwi. RaYO�Mzb9,!7* .O?^y\r5^u66I5 ) qБg4+O;b _>@|ԒTܿ{u@XWT4605$ՉKj:GN>"zc}XVSHwwEhbB6 烚~=8;,A7L�!;L2V:/LFs#&kgk7gOQ{oZԕK &T_BZ8i߉P ͞*˼alL\7 ғݻ<7ُ +|g!Ԧm ʽ{_oҜ(MlKnS~cr#:Ly@}N>os]$hd\Ȉ +di~c>/[nT~C! 鞥0Y~>9/zobOwe/&|crw'8_Tge!7.2NG f!&o@z6ew_<0~C!k鞥]ֻ�>R/)._gW&zF$kdPϚ686s{BO Ȏ$5ik\޳vO~"_eRBH+ݳ{Kײ|%?^%NzoZLuf=sbs1>K9|~R=:?LE'_;Bp{YoY|S3= uTO/o$l-,Y �:$ endstream endobj 447 0 obj <</Filter[/FlateDecode]/Length 1852>>stream +HkPu1icv Ԕ@ABR4KEAq>0(g$DEQ,.» +(eeMXUKȏiiI.yf~9<#r6dZ +wEHf6sѕ_7H4Q"���Ds|7;Iy)+~ Toѵ c~E[ݯ?C-ƶ{y(D{63!~}"OzzRT|J ֱ-2/s��P +]ܯܳޕ j +։l*:?~X1.[c콣Dαb^X,;\q$kY��qf'qL"]?nPyL{M#-9Iw \d|f.iw<';:Uw7��(c{W_Ew@GXuϫ=mD;y0[qcVA愒&m|l<.ES{׈k��PwcuVݮcRfl9SFVd5V{Ezv9IM'ʾt2ޚ= ��j&U½*ە�QS':;a٥1n;D[GƉ^-/aX4$JņsRʐQ5w3��OٛJ)sds>rKڎ\.zHxA)/9)Xv6~UX ��&k^x ᝮ/fnsb|W/>>Wz9s,H۷qwsQJ?|z۫{��}/n.WDMj;QjÉ:ie3׋` ;`+oGUFtp�HClA=*˕QS}gy;#yvߗ wmnu@+4qws0�0)_vp_-xu8��2|#lSt+ ?еW?R_;Y˿u6okD/YaOfo:Wq7��*pO:Jtܛܟ;\i?5?߾w*tm@7g:" +2aΙGnf+3>wltGo9��v,~Kv5Ltw+?еU3Yk5Ǯ5^WsLA[⟐4Ϫ]]}m8��2ˈ':#V"DM;^vٟvkC7!zJ ;G')3!~TTxg>'9��@)t-}) +QSCUc.,{|tpaP[h_¦e8ȏ ]p p��P܋2mV2DM sc<x](?kYE0 |b +19xYK'5',ߟ���FO]IZ! QSGz6baDse([F^$`dFoTx)'߃s��0 ^L/OJ)#(1ڝgۉy7XItښ{`j\;'Ѯq%s3_88��a|~J)%4od9q(,YO-zk|'Rz{jM:OZs[Q~-��VSJ6f5�@%7y7NƮtpK欽o|)w)HJ[| +��ͱg|bw�: endstream endobj 448 0 obj <</Filter[/FlateDecode]/Length 1608>>stream +HiPeAPr" +8GoD&4o<AN<0ka`D9\Ą]&# Mi|a6N,gR4v|r| E#ᱠ ;3}agvyn"Mjnj +of>!K jY=7H/tY;d%��T]^ N"R?ތٻ{\\̓os{oe~(2}dQ):Qi). 6�zpU;YHA .o\L_$ޜD{cc֩6GyEsS_K+$[ʿ��p";5فX$H Vۜ&}9tR#o1l+0퉉qUK+}i*/ln%e86��<vאVb>"@D +3赚ۦs}8QN}+)$ԞL-[jU:vGΔˮ/��~m# ?,D`Xs?UT[kzϬ~W_<[(ufos?6||k;l��x̆cw)þq'uDu/ws펊r:,P:տ~~/g��w=C:$$od+"D`X}lRU+.-^߯/twuO6|y(!as��bzY^a "Vf&f]|+L?OkA_m4Z_ط9_ưW_ ��^N\Y80w +)gK9GFliwK9uDt,].q;##s>S[8bs��z[N\w +)'b8=z0~yC6'ks #'q3e?#<ُ6G{)23)V*��)ȏuͼywȰ?a=zFDN{11QΥFYJOL>$O9GO7wP%b?רU^36m���([Cz-`7"R?睝jnw~֛ + j;8z?2VggPPoϼ5?!;;tCI!U}9:zQڳ\H/�غMq[z{kw?a]Ju5ߋ/y*]ph~}9T=碃;$��`-uaDl{ݭ�)jλͩ/Wo$:U���z؅ܻ` "J]��yZXyޝj+?a}.QTS]pw���<ϽSm"R?O¾{Gw��� VgWh^.%H>r6*Uce]��0X +izwD`*s3ĻO���^뭀CN;` "_ʭ,ў*e@`�9 endstream endobj 449 0 obj <</Filter[/FlateDecode]/Length 1197>>stream +H_Lu$mJ%ZՖ2\5p"F@1!iH"@̀ (G#?8砢hA"Qɲ Dɮ Tƍ<x8%)e�X^SR=^_޳9 wQf]QTG(B~ZeEC&=Fw��0MW[ӊLaW法v{\-��f~{]#eݝiUb?PU=��f˕ݙV f +#0m͜mt.G��0MzIIzJwWZ! %c&ˎcihoY�`ȹSOS$ԚGju0]Ok1\*Hw��0|(*Hz)1iu56xcaa/vgmMCG�|MCKO;$#%-ya}a<Iar={S=��7I飗rF?H&,4Tq ̺WT}F<[�zluw"?H|ѧ_v/ZtaL ӕtm Xw�uyܣG;SndqpLW;pZ|?Q.C��ޑw| q>A6!qVl}aw^_:uw�:VL9ڻ7?ȝNDR#%-h!BCU3juĊ)#&W2?;:loQ[Rfeo4G˵X��s]}Ѻ;k;?H eg+Al?{YWyíd?/6%�yIxJH@J$eͷCۑɱq-#mr}όM��ߖ }x ;Dwvbt8Օ|�|ڷ)(.y%㬽2csoݞ4q]q�oHϬݝٱ?0<{Eܫ��JI5W:̍A1v:iDy]�0u/3sc3a+Zup}�0'bJdD�Q endstream endobj 450 0 obj <</Filter[/FlateDecode]/Length 21227>>stream +H|WKrf ]o$@Ɲa#38=.xsϿىh|)mz �?L*_Gْzs5~ +~>x2N^߀//x?0I=ޚo|A Եu Ę +r +ox^Te݂mU5}Y T E#򜫕҄$y$a'dyV݈$Y \`+d2d4, pe0<_pY6LƓy +lsD֬@DaV6soa9tAA�l**c�WĬJDC 6lC4P ׀) +xjAl T.6t> [߫&CF-nå0uW6'MGD%lZ䆽l(RϩQn(6d0G* jB@x!] uCrqtrQ[cu?e% -uUޑ?~_xLe1Б[!a]c81Uȱl{ ÞC¦Рk L ,,lfh J~ń[vŪ1w")f0wUTovk?(_ GP&|'Y0.F J{vNd-i$q+2*p95rAl#C' ӟ,芊O]L?CEEvO.ei*iHhQf Eqz xW("z4'8lZPzE �Ώ;N۷k@YG{#X儵L~auVR :;׏t20yVU2r̊O֩J�G�(!Xռ[w'In2 $-  +2ড6 aBCAsm?zMlqtcW.66v.p똞ǂLȒ0@.ԁ\)]'5PF5@Yk$\1a.5P1%SQ̞`~pyE-L*_?}0~ogh_=vѐ�"4:#.Pfo {}1x,>;o$_wE-(w(boߟk;,i6z;lz\YDߓ] | Xd]OiÆ0يoYK+,ϓ xQ5PVX=s퉧dEWztN.P(P0|Fsd6[V9Cw)ѨݢaA4&#�Os-X8 Qairˑ<`vh Ʈ* +|Av$ pm8|>ueIV'oC"EDS@ګVa_mn-M,Q]X1KkH)zvma{([q]kLC#O6|~loT`~ +ϫgȺkֵ [c7X6c:sZXBsҷ\|XGveUUܮ={ϴG;Rd]A04(,Wβ=[!.MQU5UCaBlUC (g~]F)(AIqgYέR 3Ԛ|GPc`9^],`9>ԅN0Ѯ(6lmĆ`5T;_5C$ cRJ%ƣ 4PV䨽ܶ>/ئ1hq 7n^=ۊy[{%][8@z|o8ps*6Kwbw&}}7[]g+_']4݊@rTf}NبI![X\ MG63*5ozgkE-B5=҄JS;?>g$ taC�{6 Wu?!dWA8 "9. P*C{!3vuХƕ(|H[͹r9@ew({&&%@=6wUZZD�Yz?jNclLR{4kq˩EkzCvèV+NjۀXp%io�Go,oC {F4Iö{gE`1 'Bu-(CQ WYǢbW&q$ҰfL]@EЃ +.ܻǠp0mrxSդ8ֻ s6<]ި^V3"hT`iT+l@NO*wHq 8-2'ࢳ(c`{t +}9wd 6$R֗V41Œpc0ݾV^z@>} pFDl f xJj6uv.PFZ;ʼ }8&wá + +c>Dd?X-un[6پY豀qCX~ +:`{ 2!ROxcǺ۰=NCKSM6)"{|O:$�k6[gURJE.1DVFr5f:lOEQzpc%�ą&ZwVQ|+Y#-/z$lGa̞&r]/+9)iDmvdhIuA`jVs[![}<V7I鼮+Z +�W˒/t=vc2.&o4S^Q7%\MC@f0cYZ]W@Ԏq�H9~u ?H$֣�߁PQrρođg?:v=^2S@h]ؕW<QL\ؤ`# + <X#Zc-es9~& +3 hgnAojJa[Ѯ邏oli~c-9aj[Gp5XHa_Cwە�x>Tsak+7tpV>ߎަ2\!Ӈm@K kڲr۔9.=?mkzݯ/Vn_l  cܨ}U{_-Nut^hhe0}�"c3Z_ 36<�=5[n,4C ln{/e*[=,bh<s㥛?2͎4PAB} W?_XWԉ\8݃mp}!lϼlz L%`G}?FB9*\ 3f| [w!l-kղ Q��3 ubUpҍ1,R;c$rd�*Rb4k1v> ѡ1+TnrvC#'xڏJMKb yt�\8 퓙3 z.[hR{<bq3{b{0&F~OOke Tؾ*{)bڍ1 5o<] +\\_dqpSi +\í_L |{D* i�%fTLD&G&Ok̠o3%7PLYJgs5x̬CkKr-6GyP#Wg 3t{b/EߤT05=IpVX Zpԕ: 틻Am[]RS%-6V>t,gN6kiqx̋ضruVBu>/v/^!8^|s s#=S;HX1mrÅǫ$2M'tf]s;59{,j:SXw*kko8?4N{ұ3~!nȸʵ}=KᶿZW<Ĵc98ﯱ;5G:[, õu5$ok3 +c3=\x;l=~ 9G c!Wm[}ewxr>8xF7*sC +du>~ूwMVй, 2`j6we'3,07jSF A +vYw\t"@hr[e6lQnAGY;:1R,E`5|ϊO<q#@3!`ˆ|kRjQ|`ƅ[>:I/uK"�֎"УɓAvA 3.W�:A\pe{W3.Q[myz<`n�g]a]Sk]HЪ3/Kt6v ::Yqo^�.4F O^?YX?J# <T[4G�- +̼]?{]USqFjjݘ +L==0�+a7W 0ZyK@/G~y—{p: +Ezd^6m6NQl֌#_ iP}Es_"$ءí1<u$pegrcmjX<Z�Fͺ%r*4]3cU:0]Uu]m+@Q |Ӥ\.-/<tfJZ;<n;17FU�\dO�$A~ߏy qᑰcR.xRG S*b/#ɺx3N="p;,\n_;+=^_sS:A4}& |U�QfZ4�c~[;Xݨu%)Ll `yVeV|h][&x]jr�M.*^W}o^6LB +Z}o2C�Z4nY <j $ `;WςQ\O4 Bl ^YrU)#�NbC#"�KeQ2p*e +0(LŞ׬+Q|uRm�˨q"�5MGp[}4[3 +a@!P6έʁY_hZI�&_e^f<nu3Bd-0B-sl7 wMlSc0yU~Tq:?E00߶sKtWRGvt_g;bi@3J's)]-!Jqq=hPZ"Ess~U_^r!}Ws1�C"S]]拹QMV'דf.9AZ,Jjڔ0j\s<+M0N,=Url<Y%�.Sͮ. :&xk3`1י2C2LWnM.kGnBs"~#N(-\H5WRKw?QKjajɶ(01'3p=ui^b k [E4 S)r_pMQ*Q#@Yw:_d1,RzY}_Ts0aiª񽏨KxTd=*YQ޺U49xra�dO `I"8({ ejs̊E|4tγ7ΖBܷJ8e:2Uf0G#MQ *O{׹^$^ +ژ1�4\MRl3F52azaWmSU΄`XOɿHy?].}`0M{QތG|-Z\/( V#`@\?�uT  IƘc|SҞbmv5.-WM^l*�81Ւ>#줂|�B씄gw{FmA}զ %=o/F/90 *bSC5j#@k`bx'xv(ɕ ̜ruoaccΝ`je7^tUwPj9I]jG`w+�p%3\''K kŮ}>@u0VL⠿Lzj}X>홸)϶ɲNF +dr#mX)g<[ťiMqhGQrǫ矘o~q\H\MIfojQ؉>(OoIGlT8,бyy۫Ы d`15 D4y*jvЏ`>"r᫲WG'81kXSfQ7eD@�G 5/DE8m^k\_Y^ >&% K؎>%9P&AiazͷԷ>O X攇'1\H~SxJMr6$njYO}L:Z!Cf >BT~9 x\ +vZ,3^gAŠ2S{`NK}M#"e઄XQ,SLؠ[~R ܂d`-A7Dt}b^PJ mK\xz>Fu!3>A ߯ 6F#Nz%`/:l"\men4pisaX4k# !4Se&^ܨ#peuUVGZg?NyVk<8k {>9jQF/AG*s�K3?|$ջ `T 4mUwcj Pr4n [6aJ藄ڨ�Ɠb�'~0e@b1I v"ˀ_�RHC9QTZ18lh;ߵr}뱇Xtz[Ʒ Vv w| xp!"5d2 }T6߅Nju1BuqAiLܱMٞ${/jqfܾܲtݖ}?k[F 5!p9cQi(nUګ"|R'/q|>Ħ*!B ^^!&I%]+A& =owY%hT^s(xEX+Omu䌨-H�&.2g4|/*cj+_%FjCSӳvQGcg57, 9k_L02@֊P|nYj ݚnqR:nc]ЄpJA`'7m68^}UkGoBVWzn g[5V"l%ԁl8z7tu=:eF86K`�,!B4-`۪>E[\upMBJ1 jL&E979wt~*<ƗfI(߮FTR@3%1 X^WBW^P)^Z4[QJ +�PtI=Ƶ?ZpSW*n:;30?4(r[:f92f1e fy5z- +HA9+aw$&=T Fٹ T?Ym2RJ Un{Im Lc&WϚK:fY F=(Y r_T7HP41HL#,~҂dAX\O +4*1<�/xzlڿ�J^Xnr3ƻo+CyV$Zέc@ugn}=݊w{Jz[<Š/ēbjq&'Z~=uIc6BAAw%tWIv8 $ֵӠ Ю]OK�p%H)8K\'{Z`D#rHl8+è7rPEvџ^-4L?{%V+atʾUSst"CEF̺<W~mo9V ؑb{5RY!L]p%Щr}UQam%a-\vAGla~IΤ~*ɽ(:g?j#<.v7aϚsYr8'8IhH].VVvR~<%0 F(%ókeA$Ξ47Ewd𓵱 NZZ+∀m!/ʰylfGػ6>�FdIO_.w00pݣ,[>&=גZ}$.`g@X ࢹeNv,9;߽D9�866> ˗e{QMCvdocSm5e=J0Nb(;|r;sH ֊8ji5f[|k^?ޞXY(af:s +VC +6Ae`+䴺/ߋ}a3աˑ6P_:NfrW=+6=�'V^DֺdQµP,Yi�` 49u6 AIAR¾:uE ovY`Y; `޽˾{* kqs3(o P^Hgc,.:_Vu"FLq֊vb:l()]H@jsEQ'5C呷^CeԵ1`|ZS�(֦R ?-geLa>nc`YT+oiYUЩ|SK#hllrc&LGf7Y \]2i/pHATOxV(W  U̸5J @jW}jfo�QX8;+1UpS�[Q<:iё˻ <g'b *]>lի<&tU!}ƯT[trE7ji-856c,P;µY]K/o jx'F:fgê߿^|" +B=ɞwFB?bG ^g!\e 8�\'JZK- @/j `e{/Zޕ,൙NWyoO8'�`k`m y!sǬ*puY3F>zJQEæ[ ^tSa[J8<9[s8(ޢu6 j7'֑cQ +,&Z&V ng5q'ە[mӉ>gkK7/\i׏,,㩷 { +<iqxL)es̚ƣfs#,px�iGwkr9 ے7]}%EpEY�9#Rˤ@e&44OhY{e|tv캖Jlxxk}ڝBŇ'+'94 +/>狏ʃdOI%ԊT…TʝDagڮ˔HQ2 m{x\<U5#7ş冁da x,˻hKvZAF/=􊇮ѹuEd'%+`~$sO\/<8'Z\}\6 z''ނҖ[;$L:2b(&DWS[}ak6�JH2n-;MG7۾ FNwߪYweiqbqoҢj,2x< NɬDX $heR�u&\< ݚ?I<D3x=-td5x1m1#7/m)7Ҧ!V59W>I{`h7 V6<:HZ? +t0`kE+c^]tuٙQ. UT0ܮ.''X0~ZmoRcc)ϙ3`\v&d�=$Օ #Ybb X/(l6a\u ~Ը׍i-må?d-­uϝ΋Qpl=cxA.7ӫ�GM4qt,/0ggzK]%y|ih1u" +sd^Z.*!ZȢ6y9oF�.]˪A(2jIjuv||Ŭa2<[JXN;1ݔycѴbDžpC}@\U]7!h=} ᇵjWOwu3�mg>f*W~'<GԐ|GX-"Z�Ef{cz"УU >u\[ή˒*&,I5Q KFwTQJ3ލD+4Gwi\G`0ؽ>7ǼV]Gp*Ο]da>R!1x�r %"sJ�u?K.1�Kr<h-gLd{G9Gk4�Ӥ$:;ux�vޚʁ/I'-IT,VlWۑE7 =6=wH=D oW$xqjUsO9dN?| ,]TC;JEb{M7,@�r^$xNc`>.Q?vV +# 񦳚kXګM�m7TN}iqT�#?Z4=??or*<8TUO) fT}-csp ͘Ze}E I9,[tWLYdemNʙ3 =`+`e'nC1e$l/�yU֔`SǀD[u7&&L?gV;778]ՄL^ө|}oX5z`|pe"- wļ_a p_7{Sق^&xzs䏧FAy~-4G؜CXԀR^ɹ1]5b@C*ٯd2{ G.4s�h|ʓW™Ī۬S=[[nE*Y }wzV԰,lNDhZ([TT%p%+;YlpEsJ`ae�.̰"pd72:W!;B,GkT9,oM2+ώ%nl}d2FWͳ-PZJKWpKzk1`Aj+;<!Uɘ̕q%@@ϣNtͥW>ݟrIZ;wQZ9{|ǩEtUj#8d\\{Zܡ8%k�l_�B JTK͇oդ4]kŝe , -"ӎ~On{J{) eK9�&*"�D>8"+0Fe 3ƒӣ7lk\3Xg&ׯY-VA,f6+~Q@ʭצ47_g ;ۻն?vs[&٫K;}Fߡ2|apvUtܽ4ZBW-+tAA( + ť8Ьd[Emˠ>lqouSó:H>Ah<QVkbBѬh@QLϣ΢@HQY0 ++.}6` 1^%.X=Ȱ| ,P3 +xd1mƜ _cii=�+-YU0y1`dK}+RkHU^%Il.;jY6)Pi*gl~^&Ue\{ezٲ*;}]I3RL{*O]oKG5D0ܓ<>?Mcp>u. +]$8q> qMɤfۻt憨'ApM>>ۿ2% %B"Dw3!Vu ]ɳ,Ss1|A]WGv _Ta41}oS7|:MpVwkuE`?壬K<k&v[G9Xy*]K)]ˈ\A8Ӡe1� ^ ~x +ڔ,$}*{p)GKj[z祖* 6jd{LdJI5 P:btO3&f'ͯ$HpOx2| cOpU @Uк8y+&(3˯k'Uca>_g]QsL1&C[{u3nSÖ{v~3)�-Խb<Wg9z:eGvUU8\7IKo1r7 s/r D yଛ;8gU(\|y׎}3/@ u�XIHc{'[ϻ2L`\}yM-Dl6#*gVn\%ZA:2_*ߦfEʏv|"g*S˩2 ly NYs;v(RAzعv35Q)0(:A=dw2ȥ[ʩWgn!Qqr$YHgţ3Kk<zLut+V׫ߝ&ޟD&"z�\MZ]B=O +8rڪ4WYFP#7[Rq6p$]6|NF ՝(w ̡iwg+'!ˏ[ԥPJM?%JbgL|YZ5hI#ކf̬-[`ݶ3}˞kcXCtQ)?Y6O*[ +4=\n_Tǟ\CWl: ĘQ 4sQ\LΒTɾ#(K˵Κ@l.C?b�Zi=Ym ͎-p?'tWQ],4Df X3צD]aK �| pSϜsOb{W/ 1]p>GP2D ,n 3s8HP(.\iY (pjje<nr7 E)z2�TO>.BJAnq87-s0 w7wjfL-H^hre8Xٮr$nxA mYIWl~<s#ޭoݭ +\.{`OHnSc@+[΄k+ GKkGQy֩z~h]C^C27VE&KZOPpF_wRƯzsP0nX +6w oFaYR5l:@B'F } ͢F2)w &9@ tt࿙q(;ZΌhՓն쌱ᏮoՑt,W C*6TO*�pq<\Aۑ=pNu>xQv &?6?ttK +u% %,_,0貪$C4T2*L:l]VY~Am' tl~pЪ8 ϯ\27G + 8'E30`mS{%wpz#etJ=ZE#z-�;eXPG3\USO +$Ѷ +X"UOƪH \kQ�`k^{uݟvߴj.n Ĵe+pW؜MGg mm 5@_t{4K qY(ep8< ]GWIUlP>r&jw*0f6j,5ױ/'+1(exa$Zͺ8[sDPW(gp5 \0Ƶ;L94~ +Xw߅W["g, @{gv{mc5ML6׮ߗ2]C{l%-&i6545 KTY־L4ɐl]<)-.:ؠo ū/xE3 [+܃+u y9QIfm2B�'{V[~kz[pK:[#?o-B,`#vB\[=%e?2K$ۇ}M:;DL1hXf{;m%30f`Wk0j^֞)?4Q7 +gYc=] ڴ>ثRU?o&4^)b!$ \J}*�)w?4g1v ]~*' %Rp,`3t:Xn_4_(R8kܺսS&}D6^"<Oⶴ% Ł)=N"y=?%пΫ߂Ö6�X`oV)#/;}Xr{o:55ټzc*U)VU|?59>f!FB[yM&ȹY"y['<?Ki/TV3£-x:EB[vvMi·|3gsL?[Qbc-Y`= 8]-'i̻Ux1dYMZvVS~;OZawgVlNBOe:DM`-Lgݯ7N29Y6.Цdږa):\x,`Y` m%3-0DnX;JMyu13M)2LkUmcq߄y2/p%ZEp.q-eL=y%0U-^j$Ma*^ +Lӧ/z7F_ô(7MjîZ<ԵƔ'´,pyTr͡p3dndok:$Oƶ>jİfq*^\:Xdw~Ow)U?R qW=w>'@Q�!+rF{vKX[a3qO=2yPFVY>0?cPko|Y ~W@wew*kbbٽE=K~{NaEd)qQ�k1SUvBPj3C*W��v Jӣ%%�ت}f]T5M_kC3 Ruq#یA~l\ )F*G HnW*t+h^ |?y'͟ 52 ` x6]7]a5[xکB|d seGy9RւU7/%gysm$VE''Za2Y1*^ ϥu5N̙H[%l%0\2>�t7 Kk46@T@zM2P1+-憎zz/=:+GR2 +̞6D`+@x\eUX�ˍfL]}nFp}yD9lSٵ%;GakLԗ@d|B.=Z!/N<A.S!!%h=IzdC{k%6Ť?Uah{|nx!cX aWv'EH1KseڙOӛu7hj�۔H>�ߝJ]/`x'9.,I̛\uܺd]{Ϻ p88m-)߄>dQQ~/vFmxL@U-7pIv �#=�Ϗ1 +X{IwJ緭Zl^W/uA`ɦFa1twsvzOZ[HAVTʫI䆝@w"4 s[f2dw&E3!d VvU"Ch}³X8 Vw ~a]ҧ*kpG~ϮABY՞?vPx^f +0dT4VŖc)Ն: Ϧ9Nr`�*ZPD R9w*n4giI6|DʘkI $+W7"XpIugz8kҌiWjS\Iݗ9:D-(#rub\MSIq.tjWFŭVaD<%.&bR^2,<t5w7^CUO5v،j!E-X7b� +$HjvhU0ƣHl&Mt$!R*Yyn!9 izw%K"Şi[l8IPru�L<[�C]ʦp?؂ %<[߯nTf:A!͔վxurU*4~mw-ϧZk h j3\Eiyb. pj_ '߅Gj T$" uVb3ǬNc7+`ԉ Ґt h�348�QaRH;=jbps?32V枼x*k\:7QH{"<˖lYc)B1l{*{PR<n{\ɇhZ,?[~oEۈ*! ! {yi59@e62u+T 9[!,չ`xY/jfRWUj6toI&Y]bBRy3Y ۳#U �(NKķ,E9 ҉ lg(cv 2كoxӴL]1'p9ͬ!uDGebS_1H;;7aǪ~&dkNWm0`08xq w KKvLl.qBV �vmό{~m-�tm<D|T69;ٵo1A˦2Y;͢^y[[B=~4S{hҖ/@*:cܭ4X*#xN~6ɜo9`I<dcY +pxԮ6'@& 5Wҷ'7̹x=9]{g:ZVgmuՐ@ =ڗfu> rS0 +ШY�O:Yk͟>>/5%%4WHz{yJAI֔c.wPg?1Zܧp(N'Dh)jO\]Mw FY/SK5/:WFl؊=z{dg!d+ }Qot.ݚb+fZ+`3|#>U@ȄNBsfWb[Mgy^kU�Hceb;Kjco Mo0pE~Z}W,Kyw1[8/wmc:8jglP}7^[ěKIirkW$控8<Rw&[%Dz~O27334ę-TR~e֏>3 6�ea^?yܹpyL o[ JZW]dyQja-馥=[ *ElUFXmYck\%w&#Yv[>R B%.s1т-cVx҇ow +ד#߼s�FpE9ڡbXgpa@B 1o+ S Epoc\gM,mA|%yX-q:gOG|hdD?mxC0)k{bx̐53Pf^+c! P8ix|sb< QG<_ �~2s۶c6퀩MNxs "[c +Ofƫ^?Qtp8OYލu,&UeVj ŻAP#%%dFqqKp(]8ήr~AEnh�^Mmi�}JN҃na|ϱuK~w'(nhnC6vHd,]&s�& +Q}Hΰ8]G%=Gnfa%g;- 2-5,:c�  G[Tvma(-_ j!suj",D+ʃO#Ϙoݰf<mUhp gxd#JWV_/Cٰ%lD +Wߕ x\E],,%8jPyb 4!RJmԶv(ΖzG18)Q~0cdZs~5ӷȿ Rh+c8h'y5(o, @c/p5 `iz!^)is70%9+_k{rA:܏J7)jj3c]ۤ6P*8~%{EFa\7=2gwU!i*m�Z?/_w*G�0[:�['KzRS`L9`͜}k:E'T1?I_=@U(!X`N vُ]i̻yʺuDDlo _K]e x>jPXfT% A'@8?O\܏r:hS1M随a jq; czCSIJ +Nk`4kojV`6º9!*;WJ|hjW?",$Z#c\ a$˹bcvApT/go>}-:6T\}& +F'(px[<2g%pPfٴav#Y 1<}Y=@4I/:y9�) +;rw 7PZ<M5s< x/)Zݖ>VA.卡#ݱԨu MŎ0~'X;oY#nk-߻smi -orʗ0 ]-V е/`5%�{= P>5Di|[+'V5>kʬ ce6<"`k*SoGfs6GqD\ХbxU%Hg�UkVM^�}=Pt>~lcaO xNx# >bQ �,*iT˹HbxOϖ:w˥J[R1�,gJ[�cgugcNl:gм"© ѹ7056G; +#$` {^9_fv¢p}`sx:g|I!{E뤟n0bfiA xs~{qv[<hP�73*?%X?lYs^sl.pW Fq-Azi}�2k-M~H>NϻK#t`Hg�OB9xɺtS�N}̺k)q :t`Ezw[]p-&f͸ŏmýI\~IDg1O%C[) XLaUS%=z^+k0TӛZBl5 GТ~oQX[K#Y9k?Eߵknپ"ӝF(=$#J*ۤ+.Ӡ |c9ޢڲ!"JYz͏9_>\HG,Py)rEh!C2 kəz>& œT'ƱFAXFsG7 +ڀIl `q]Vh֙GCa,-#ǭ퐪|C& K2vx^N <+rUd-xQSTk{̓NgΊ3E3j pGOoϫƕ!Zd L4Hi!Qij46MTH";Fkrb M 0\u+]|''sf˜L {S؃a!}"f,᱋gR̮ J^mEvWRĴk#cR.{ (~d`cIwYg�K!X/M)]Ig`XLY9@xR9;bhFֳ֥=OVq6,g[ i[X'J/5ӧbv,>jo\x}-q5;U`eI$j|�9]=S\mRV5+[fWV? +eďgU^>b1rNSy: ]PLre�Ed}uOewp\ă6cZͥՅ>LGnnxӰ7a:J!c[g}+�+ endstream endobj 451 0 obj <</Filter[/FlateDecode]/Length 917>>stream +HoLa񗈒DX $,ʂTJmDzդĭH( ZL[QjO=4Di]ѪXQBH%<�?_pfoif6|c_|Jmղ冱O~{ߵ TTwԷ>q>e��tDz7D/ڍÿq0,Yܖ?�E{'h lGT5%]nta~�G!h.nF4I=t͟=n� xґ%h7 lG0ܹs[?צ� 8⺫[`6#fHi}d~��'nǛ<v0z̦qƫߥ4�ϕnd_)0 iV.PQ�I1ҋva?MA8i �_7ǜw va?M5R&k �?#m뒥j.j7 lG)L71Sn�9C8^h7 l.ѯ?_8:�;UD'[`6gA{�7pBڮ(L iX\m9oo ٦=�@_tA(L iv Z$󇗳T}��=?sI8PM8fӸ?TTՅX{�~w%:AtAM8fӸ?쳲<<r_Fz.Uk7�0\8GI̦qXw>_�jY2]E<̦qi^qqڝgm=�L=yo;E-`6^9sݟD�&yT&i74+�૧ endstream endobj 452 0 obj <</Filter[/FlateDecode]/Length 925>>stream +HKTq%Qm,MU-C!2 ( *,H1LIWB%ZXcG41IX-BڲyQřyw|;Zl<cpҩs vl5J*�Vrޟh{,ӆ; Ξc#X޳k _jڝo:ϴhw#� rtmԿ=?)eU_ ]~�{|; 6aى˩{]ߓ�.]{Ad?MaCbQ渀_ݕ�,,]apu)o=<Pޗ�{Y+>rAd?MaǔmKLm񃦚 �{rǻk_4{}D$ʎ 8 #�F +v{xɬ݂cpٱ�#ww>MSbS3574_\_ߣ�'w[qڝ`p%yR�ܗ^\v zĦ?HCз۷_O�&:ߨD{MߞlnO{W][߫�;-ZoAt?Mas&ٴL[�?783Y 6Ne~ uW�>˝.n `@܎\Jg�]~rRPk΀)u;N[ݵ�oF-]=bS -�rOjwt?MaTx^\�1m] 6mxh)ڽ �nYr7V 6MN0e7غE~`�v! endstream endobj 453 0 obj <</Filter[/FlateDecode]/Length 1384>>stream +H[Lg9&tdfb[\1',B,z%G2)j2(CˌeBN%2D#ec^p9$$>']7oO׶[jSXT:xiMʎWf9Lw İf_딥1RSc��xQv_n~'?57W%ѹ = �$XAK=.�q` j +] %�ԷԻ#0�āx9黝+N隻̶3 +}e:5Ҝ^�P3Yaz�b@DMqְNjt۶k ^ܷ3?fg?`!]Dcj ? �fS oskyw?1Kbҽ<wS0Ү>~�P#WJw烘?s=NhlT1!=wY:smϷ\kO� j:B=K}˻ALq77|g1k7er؆-]9EZuqOnV}W�ɿRn<V .Dt;mWho8GJKrcM5CY6sVCo<ZVjx��j8&zUo5x8фd6 T>RM{LddPzVo6�z-YϽAlȣΆ&A`s3t;{9-a;&,nYs �d%Kcԫć<,_7焅"6*j晋sn9-!5gK'ۛӺx +̇WљX�P۾^7W%to2ˉ O?3y/5Z]N-FKѧ�(qԧ;~a e4v3@\ gt ܏d.Ua9}�ԗ^'(.@D署f}UڲZnv}||09tv +7�`_CŨw` &:"+'uح?8sFQ4>^�oG%ݬtnPDMX$ﲎ�DDuzww` j +<ԣlLV�DC5ԓԗ; QS?a[ i>1qK~%=� [T] ʅ)0ĖguOJ��"1FxJ=ɻA?5ca 0�] endstream endobj 454 0 obj <</Filter[/FlateDecode]/Length 965>>stream +Hkqυ͔$1BI&#ɍ3cfeͯ8ʏƜs6i37bڥs!1眷}U}}߯쭋L6ku'{o1 E�=O8mȶ|P˛93 !#==˻0* ~{�4}{9݌Al +ɶtc�Cd8+;v`@)3umކN;��N1uECNĦ? +S+L艷z{|�HbcOvbSHUokǵo�H/U' +e ?Ma *N-}��RIzNnw% ?Ma rڈBi~ۥ�@*+ _xIiw/ 6TR\k <}Mw�$Zi앞\؉Al +U >uWh +�LJ-Ov^bSHr{7MҾ� >̟$^ݱ%g[ _ +տ�_HI%zFMca7)B ǜ>z�C+IIiw+ 6t+8V2* +}C�p?^2JSĦ?'չw� -2kv"s?Ma@t(׌W'�O/Wj1.E`; +j~ٱU�߉&8;;Al +f+6ם@o<׿/�W'JzK;yĦ?mYPMuU�_,Dfb`s\yC6i�-k6ݕ\bS_Tݘxo[fh�C�j endstream endobj 455 0 obj <</Filter[/FlateDecode]/Length 983>>stream +HkqqäP\rF[~F;]XS2k.lb\5̏:gmgvkl(c +WBI~x|?|^_5+yNv^3{Ro͜3 !^cyۨMhm],zSlLJ�#=;Al +n2irim}9R4F�h"z7bSpyrt8wW] d!�v'Al +nX8yzwk"�ˇ[;JAl +n̑6wh#�`7Uzg[|Al +n1TT9w �=::HT6WOU@[bSpKLm[ån'c}NyHb +w=)ݬY\,;]W6K,T<GĦ?ʂ1'wпW�A$+/:gĦ?&[)٫}�`oIJN_;)xIQ4y.Ӿ[�xۧӥOJ6wĦ?%#SM1@ �otHYSUv 6f-5w/0%I-iCcNvAl +^4f"s:zr}w%3�aFzT{vAl +^R3m׻ЋKw �wHْa`,4#[�]gvwAl +^Vt =Ӑ�px_hw/Ħ?`-1'@t~*_?Ma'vOf_=GV횠Q`M +s=[}�7/S X1W 6��,^C endstream endobj 456 0 obj <</Filter[/FlateDecode]/Length 2261>>stream +H{PT?."`Li5xI4iqDC!cF1BK*7񂈈va= KU.ƈmU4ߴv&f,EaF;;9>I X��N26y!OX%}߷֕#�xZWwJ{b: {�K\M=s;k`$LYĊ[VIB�9�Z{�#zysL<.jt7,ꆆMcZ< ۖfu<=�\CoSO}w/`@Q==ۢnT)Rc66վCC�R#6fOM=�F9$y �FUpyո~uf热C�嬦Mcg! �x(oQw>) rG5(gJKVKC�NAxF$�rIwL!y�FF?W8ogXؤ,ccU7l~M`tX( >/�FGDZxW٦ 5�"?w7ng!}'m;~CA�”+ڢ2?>7�1YeZ߼{ �  +s +{)4 kcMަ t٠ �oM g'�A%׼{ � 4z7P&s䧤o5d]0^eV$XV\s�`x|X_1wO @I&-oqk??|(ZH<r/BB˖?ڴgJ[K쉭 7�F;0Y ҵ<�p+V0 Ǽ{ �_3i* GXٚL#<ll#&o +oJf(,\t/*U�xcW-wМ,FU^~uSA3:<k-3FY+�?ɧI2[-AQ"(G6)gkRpcZu2~uy!{k5i>tf��!_?[[Oɯ{�<@U+ 'z+Aw5�,`/0K7qv��ӵabz�^ @$W又Y'/}\1Qiќt fʎ沈E?:/D޷P_(|.YUx_M^%&RiVtXVnju(|Qd +\3 ^}~phwiݹ~t �o知Qo.#{�o$*Z%]kG2kVT'7<+{ϣPeiJۛ.I:U\cz(x)'ƩvkGo:*m/㍕n E4s5,|?}Ap6(eCν:yeE2zߝ{U='ɗ{�A<Ii#?Cy?Am +_FOja 0R<lpE;'w JZm0 W(3j{ K!Ҍ@s]aν:`xf (ߜY2e!VM I_ν'� @$W,M4SSm?N'·SfקXCӷ]}dVܢ3 +9^@_E +[6-+"A?Is~[[J7j[{5[ MǾm+k?BY?< 1%ߑȇ{�IrEx @˩4'U\uӄerr6eʇTZ>縟Zܪ, fᣲֆ%Fט][H͠>lTzVt\OفΥ|Bከis-2ek5Y7 ]5gu8Ŷw�t-Vd8F�p'? O+*K\o¢n}(hmTx]ReimV&cO5֔fjtcr.踞.MJ:~h/.QW{K(&yp<:c-r5F�4W80,[&ߑ/� endstream endobj 457 0 obj <</Filter[/FlateDecode]/Length 2780>>stream +H{PSw/XZ_vܵյ<jTFD` *D +A@!<B Iy]*`)>ZauU[ٙٿssƍyI%sf>3~~p~I+)?A$c|)44o7cgkwMJpYc('g!% *`5險PoVFYJjc߽B$/oMY]dk)[S xwuaF<Źfi N p<;|U +_U))A�J+kA<h\2Oϲ߼ O<k`5f 68EsP1X_8YVEm{\'}~֬{;}a߻Ӊ"5XsdtHh(r~ A#'9kA<h\2O3~HΌa}Loա]\k/ +-bخXU~O+v (M]:4oKHZ Y}TpoIj= 5=kXm;o@t[W6DA%34!bU + +ǚq>0(+Yki uecNhZ-%s"09tA_>[&w̱&jYﺇY `OWU*'gL$}x]uƬ}myFo�lƒЫ+YHI +~`*>#gGs5s9ƈs[r8feSMl=dFPPxem:Ýg_1ִX/l12-�4.`y[pNC?2@~n4ѷ[x +t-#K6Vcա]?bQT/{4oO=R+EfN`nA Eg=ULto꽤҅V]؞LCĹ('<(tA~NYp=goZM5^W]d6m{`rc{m>?Xz=y`+enx`:A<5 4.X ]Ub_1܅ݵ j&YV>͑xOMQ4AYgmn )IuҚz~m댕_L,(DphR,'@:#a[|f2| O2ӡN**ҵ 4.X"{mZ-{)01u틺Pٺ^H,x#?иd?dt=71xڤlAHӓEQPP1ikAh\22z$Z-.C݂HB +UM ޗtm"KAFfFD?=kWHmjtM"@%C PEjeZMA܍.~) yu@+@㒡@ w1{/. !!ߓK??иd?Ľ'/dy>n-O#]sEPq<ULN]M&j|K4@:oc+mϏrܲ6Bjt7K);$3"ȳy y yN@yPW6?/hP_oI) +_ݥ?fgFP'}/0 )Po$g2R:vSԥ6I3k A 4.' {B(D_W �719ԭgbJIcSIZHDy mŹ)y@%DE=1]n?&@7ֺ)}oߛ ,ȉĬZt{J f|=jS!I</@y(eh}gѵ_VҧN0 +V GRLª 쾷Ym6{#fU*yDhYƢ9Ʊ3`m&tkmyΡ?fER&aj=@6-ARvM}9~/ḉ.c,|;1k? |oXo߻.֖IYޑ^W>XlkӾF}T&L𿵷 VG҃q^;aO=no!gLQ7ޤso,}WUR/A(SW[_5 ?иd?_ZŮU{hUkU?Z҅kq7TgLts |׮:8z0^_R(+Y�̍y/wE-+yCh¹K;4~gAH 2<L0׮E|8,579ωXdruIC!Np'F;j/kBA.cW ?oYq|7PC1E +ˊe=AzVHJݠàmR߰90\: Vc 9G1 n (:0tţx$(NP �Z= endstream endobj 458 0 obj <</Filter[/FlateDecode]/Length 2900>>stream +H{PTOxM5V$F[kMK@ZJ/ + B@.,²,@4[D[/$LI=f -f8nauor/t!}CFQNK?p?i+T:ʱO`]ڠss"grExkc}Hh48¿:Q/ ɟ e.U6g)ve#5sڬ.M;9J9lD~~ܹ IZ:, +7gοJoU6ω̌ܨyxוuCKR\Io᛻Rk4ZU.g|\J-g +AUAt- F[˱EwzY[`txCye765g͝U?n폓+ V>^$'̏s3ۥhw.֒ +7?mB}oo ;Vz?H<S{QZϰ";{0XkjvCro[C:<'gY5!yCDۥ&W?W!]6C›SG9O+}]/WQV܍ +]AvȽ-g Zڭ<<?AUQzx WyxvrN>[33z?�fYȮ6#IЇ?ڛe%?Z<քI濹ms3nHc?O5];.9-aߋ=ʥAilA?(+< nu yGhmuiW3|ҤMʞq{U]bqO蔶 +ʽ;O,=ԉKGio[oq2!cFGW!K=}0V,+UFhff/9, +7WKUu +L5FhʴwI]5E})|StA A›|nHU|cZ{xK\xS ߬~qhϠX?@__ϡWWP{Hܻ +k:aɏ,ϕ0n§XCV9l۫N!<I˟w񍞫9}JxAouZA7'Rq4z\u^]$șsogigV|B\~q',I~+57 q?R333ix .XkHdoq)|`?;7ޱK apc uoҨ5ߩ D:+ :Xk !AMci^P㷆gG?, +7O2Yrf׉E\+<mdzټ䃱3vik�CsL5|4M4Ϊ})+rfJ*ǡ/Wt(qYj7gNWEuK9?`?Ĩ]+ʽV_}ލh7ᒫlkdt^Wr^͢2\Ybq  +o +O§q5hs=#5SϺ?E/8q+RT06huϯ$Ҵs"z({KtqCr:?7~fsl$sߟg[o̘^q+N<o f9J9̃R ${<H!?vCK +QjEAS7ԯͼt{I"kufetZ<_þ% t@GkM1?()<u~7-`= jaAҝ -M{Q˧m Mfa8舵 x4PxSx9w 5s4{ ]"stWҥx|GvgŬAjyznXk ǃ7`p?ZYQn;IN-߹}Tk?}K: #03ʇV x2PxSd1n"<Z?"g0pt.lפQn=ѰuN: 胵F xrPxSdAȰș\Lyzv- a{bك:ٲÈ׉KL?聵& xzPxS 䥨YƊ쀃e[{diXq/,+lԟ <PxS ffoɝ{H]k[OU}L<=#ꉺ>Z5wZsAt>?()D`t<.7w'x|PNmI@=b1A?g% +rzI_uDǜ8ԫ︁:ZSA<{PxS ɫ$!AvQsU?_2/`g?z|{:^ZCAt?()DfhD�8UڀM?ɾ|qꁺ>Z3At=hc '0ţx0{5C[sӺy{֮z�,^9 \ =>0(_3ṼsPiPg(ţxhc '0ţxc+68*[~IF?&X.(A +P< d:�0�iA" endstream endobj 459 0 obj <</Filter[/FlateDecode]/Length 2255>>stream +HkPT_v].*d6,! +M&Z/% FD0R\ +^^p/k%j^&[K3No=:d{o?{{<?+Cl(ZsV3�' BBPAQ^cu1N'DIרc7jFJ$.A1=\ nAY +x'\/SQg%y7.ZSGy|R^)g7]CY�")f=y u' +HWdkQ*]|2/oaMFO姲Ķ.Z3xSf8,|??Dy|Q(G'+t!\�w(ࠠ)̕kX9�]c#'=CD$;W򣋅GeEXgLZC5wiѩ)| <o]&\5iPzM30ͣ '74:�!p? *8tqHzwTuU&t xl{'LM۴UYi };E"?q٤UfnΧ<Qfb! +5 M@\()HpXlQ*j/Ke~&?սfnBkӵΎ[ԏΗ?M'< +<h>4׫h4_7͟@xS/7<Wv.QpNU]j4wI5x'm8_VKYqSSKw֛採+o>eNO7T5};DqS4Ǣ<iq%~4_3C3.xRWc4?:>b9EEO>2,&38,EwٳrʣOuu}{ZpNq0WW|Ɣ[t⡸(y'(MgмPg5g?tHYO}$4bi\4ᜪ2iE\ѩ(kLWn]1@ӞyzK5>nӗFe'+OS';(xL3C_Oh^�g̟vm󛌂w?c&#e9sscEuo^ AA #�p�ge +DǨj,+sac$Q͞[  0QFm� WkX9@DXNzI0������3㹹Vy%K6(ߤWbF]U,K +������0 kQ QRfni<;W8͚a���������������������2K$bˬfר{29.^4 H؉Ytdݝo—1UTo + vw`XJnWiwe}UUue3K:Eg&˟bU[/i;|\1h?757$wq<77.Re.!J-MLX9퍚&)f=N5k05JJPAތ7D�3 ֹK^C<ַ'45]2ߞU=z߄vxiVN3XшErrBhVyOQEr3D!155wi8ػz{kHWd|OzעT{sd^^#wOW_Kx9rGV6^!<_!vڱwp�1X.j/260="{rVGw"QAI4ݦ ̾dž?{˧+*7َyU[sw`{*+Ʀ J$7k=X7'_rgÕio^gFɝĢTFg2䏶ߨq] x0{A{4;Uppk"1JǺ?b0YÆPc[ݮil+#/l",p?>1vȞζFQQA +^ӯfw;5ΙÖ/Z +wT?:{mc%Rn?cHpآTԺ1T0ElǨ>=66 hO �m endstream endobj 460 0 obj <</Filter[/FlateDecode]/Length 1469>>stream +HOSgCXDET(:"ˀ9꜈qYbظVedGpb7ucE( - ~,eY2/Kc9(Ԟ~7y|{> }CutuT')ϪKD߂MZxpwAt|9ZM7!!zʴ>kduk)Ԩ憅q)-pXP󝚡up{e=)-c.&F;[- o2gvU|9QQ6wZ͏AL[k{ʽ_$٧ .wrvx9]]M{B.:anMu>dV122rm, +_CƁj,zdXOyKNؐM ^b2?mt! QޟkU%"!1SW{jjEYtbƣ#"'q`}zWGq`׭6\Ms(Mi:m|7o~si>#c&CXٽ[F&^ݜ%IJKf?b"c(56lsXn0[ +jbuQ^[e˹ OkJ$q0|a._m6 uBlLM.7.t}&aZ%=d2d AIs4֠OOUVG3ta@+o gcә]վY!̖T,f{Ntd>dxSho^_#cuGOݞM&}zW9Z7uX$b=oNe +`f]>#c&tn=C]}~];ZȵWQ2N1XϏ*.tm-s';7=d쿢=D!!=e*H>d"˜m5#V-LʊX|n*NWFYAo�/b}VSrՇ!u\zZ%MiB/ fLR_YIg:ͺ6O&,ZČ9,w[e{'7_{"[ZOO\ͭ{Ty{sA$SEk&!28d;5CԾD5S ٞ 551tMgV /ѭުS#*E-Ǐ%r=g5!6nr2`"QT{ww~Bv{s0b59e8zr\2N\9:̔/cڳ=^??jt9c,2<~i:]hnkBRV/p^)wj{<s͊Y1�����������������������������������������������������������������������������: 0� Bh endstream endobj 461 0 obj <</Filter[/FlateDecode]/Length 7462>>stream +H|Wʝ }M!f421hqi)J)Iz"HB߾K#ۿo--5Oxucm=ﾆ<}_/CW̋NVl V\/Zk|_diEv[:lsh>de#u%`b Ӵ5 ]F*V*Es/y핚յc*{T42^Ԗ_~ё +˷͎A_mrȗ3_a\Qdy)u2t|'d|`э&g)QR8 \K``"E-EwSrVHsND zR B ɖ&0E iRS@h_ n' %IS[uJ+ Š<kRJ-C^Q)m hɥ7UEQ+c~=9*^!wehqeaPz eTZVWZTm^xP &[A;\ +F#Jkz}XW X NiY+\@{ڪP>)zFn(Ġ٥b܇,jW$<gU[g]`Wɲ"@o +^VKvڼ]khO.PVyY`|ӁoS)t6*)+S%Ch} _oĵ��`9c"u)y|؞E8-I}Ι%!3ae;cccmp״ +^\IyLFT!HҌZtI\Ko/%fs^*wuLBkIjb@JkEYJ#</)t<+B-\NO緯Ow}?雟~w ~?=޽ﾽqgCq|?o@_6n߆䟟^Y-ؚ)q;97 +`5tbL'gJDC`ź,EӇQՄ=_0y"�C +tE 0Е5q<-PKvLο:(q圠߷lNP1Pm܍`1 �a).J0IsY*PRptn]ZeX-kr1]qĦ[Sʧm':K<`7O'Mjyqݠ̕ »Ƚ+5mW bS˱[O x<M8_x$)T=у&%A1ȒS%T&*Lv&I5>lØ#hV؈$x5D 6W.YG/peg[� ~\`8?@I6<\SЂe.X] 1Yڒ[0n&:6FU<O\Op9K8٤!ㅙ*K[ۉ㈖ fZ`Iڊ,ϖ-LCAfqRJ'_@0v̈ +p휁�!_׹l%dw @a/ +bؚ5f{CRe]<2ږ#bX{0`97=Y5Kv,\ɾ6k[h*\`qJCUhY76OӪwUIsNc#;/8|]*qfcRE`2}ڙh.ު ZX'�q$FZCђTNIsq>zv]-jd9u" V5^U�|233.Yv;x"ndwJY 4^V=oе.f\8'Kة \۽@ +o+8, GJ* q/4P,Jٳa*Jْ.zW 6'ؐ 7ʞ P-~̊JnQZ7Tq-eҲ=dZJ1jcp6⩘U'Đ\QCj(\8=vJ#u!|elun Fj) \6`(̮ O%gp/ٸ] C{ra/{B IS0z:i +d3ڸΒ^՝tBƉ +5Mok̸<i(y&NG5jVxc.)o�cZ�[yvˮu}q9Gർ`\RxL +(x`s 9d1 qѶԗ9=#8v8<qຘ= +9fJ 0sU4Bqn+c i&YW+`JE..0f'W9OH$ @cŶUXpc:(y%e<wDŠ#jqmXT`g&z`C|r=yfP4�%C,@1΃>BiչjJU[ +%'^H!˹-ONq~q$/?%P_'N ^ۀž45fCZrXH rcKzNMcFR՜, )]}BC^_B4!@8 6CWu"�0V&yhP!NK1!H([/=gp:C& DdF2s,a4` 1*Ar'saDMrAp2xZbg*NI{C" P\DQ0X)$kG*&JQ Xݵ6}ǁ.IEcU@C"\Y  64!_6:4ܐ C {+` +G냳{<|ɢh=ySsRA@(0Q bd%yWS'Ԫ} $\ql6s""Nn@+}?G݅!LT!J+JL'Ck +$ +f̼<�Y`ڔpo=IQHL"Fo;M+i3:#UZTAΒ9hMI�(+j+ɢ@KDMH,U0Ȩ > 6NZ}̵ +br!\4t+/McV{̍YCTjyC&2|385AIҒ�%}̎WY%glHرK%nj'Cm I&K.1x]i0>zh�?$֚(a-$qx9`C-Rd]9F{,TID.B＄rS/⚠7VlC-@$ >6\@a* +"bTkɺ2b/(g߈2:Y#BbiI0ISO* /g\?~Rٳ5u?\&0N2{UtއEYɷȉr`XP^@2\*!O"{-uœf)),VcP͊zUIS!b$Y�iE(ӴE1X^ +'?\`գ7V2,nqRY-EW +ug2w8rZ<f&Z +*5vFcKu$ZcS_KtV-l3t +YHp.'W1J/TY~1J!RT_'8!gX!(k?9vI̥ROz0t"5}tV#)V6ѻZ .EU &g4;RwqsA;M"�zԈ ;f-Sx @rѷL3�(7 lw0ۋdgUPK +z=b`m6=[UB PCH*~(G@ b4į|6I9 JKo�,PҼLLp2 +U+B%"B1)bԣp/Îbu!%2ž|5ڇɰ( *djc K2\+*TAeR* <MT g)R,ZCť%ؘP/ECVs)8[#ȼ7P I06xj ZؙVSVIRƊ9v +ďv\Qt"l2rgt2EJ-l$ ~K[;|q:[8kJ/D#H ׳P} &eڽ [H^~DK맘kZdV)͎!]' <cie\H oCzi!6[)-z1paⲷn& +iQ](K% +g`6$ 6Oʻ`XfnP7lAhjF>#&$.1XQb{ V"@,-1m +6RE"EJ} RBj~l`aƭ6 rMaR>ܸ8Tpzpv7O_w?OI߷9wnwO|~78x}IX#?ŏ  <?zzq⟏}|r~{ӿ:g{xro_]oGOG۟Y;__>=fvο?}O G?ϻ)υg`e8^Yv}caFVvwkT7s/Lɯtlܨfb?u3/NoFF=s1o+ǟ;x-..%.._,|n>g~|8lLd^Ny7YV;έ{vs֘oFUS֝;})i?!<d[o;)/>*ɍ|t?zUNf*{/quv;zgy|G۳ΖEz{Q%Ƶރ{{&`^{R'vodySb^xƸ1z/I)>m(~FHMKtK›UYp%ܞ}7޸&D #KrN׳D՗E7_OU+|}ǖʭ}Tz釽kʫYg:3'l_]_r2[gi{2hWV l%[򇏗y;w츨vb'g9$z\dFFDl~Çv텯ubOgQe|NcZ$Y׿t(>dmMG۟gqNЗ3܋|dou[Lj\JKGao%،,[ˎ�Z_ˉ#I~~.1pۻ1kG':RjPiJ% +”dR%R~o9;Gdgǘo<uqbL) 1 4"5ue~E b†~Ǒ3L]x Udy$9Ҵwb^iG:?/DF +rDrPPoPKis 2 YL?!J GP\f&nua%l㌼Ra<vmog Y@eae$Y̦4N[7vJE󶔱K +(pղϿfvi%!DLNGRḻA5Jjg󧼒ĝPP`SNF_ff\| + '"{Kfq<�skC+[ ciD IsH$៰rQñh M:k簪lD&eB!|a_ ѝƎD~qX%NnGWP,]G+{4B}pWW~j/K(꒱=,M:GXE2;UZ3ejj#&z?0yPa BlMpbcgҎ̙TXx%QEE,ԅCZ(~*`BʩRf-agЌmh,m5N_ +jsI(*&PG{%hb [š]%,WW#>@i:M!.%ޗX`4]{ + ?P$[N2Mqaz}sV"VH'Q)NAv Uðhְ8?啴-uPTWr24-63PFe)[3@8ajk@*M4؍D8* +U='0kPRBs F"ǤǤI:cdPdury(:Datg#_DD-֤y n KъEh=MPGE�](__^BQAdiD<ЙE<<`v]<`nՅCZ(< ˀ�`DvFGh7~ ):jSuPO> s� N- ]aFfδޯC_H<Hwn`8/%K^-;cEPXub#Zg$ JrlP݋!M{7.w&fB&!+̚U_  &H"%ˤʸLpN̰g h<A (։ @,hg(h]١ggXv@ϰTAdiD<1޺ RiN* ?cιm`P6Xsm#b5%?Ksr͛}sY5^2A/_oPK,VH3).plbTKYxҔc3$0TN55^&ZH|> 2VDLhfc)u:&/bErfV`JPXB M␦*VMya4Z= +oD7qq4Wx}&zMf%$PXu v}93Ĥ +sj?$y>G&!+O!(pJH"% +ENYւЇJwQa{)q8\`S qd +@aW@>1Aav9` v!@규#c7~8RJzfX`˻Ҏl~J.eN LE:e2mÆojI7-V`Vq6_w%{Cn>\=y,"Vs硙EainVZE +2]7xE_BlMAq ccmV^Xc۱} +f*i-$Xw>ZY +`e܇Ќ&h<R'c "VXT;�K +-G&|C'�h endstream endobj 462 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 463 0 obj <</Filter[/FlateDecode]/Length 92>>stream +HA��  +{���������������������n +�����������������������������������������6�܀ endstream endobj 464 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 465 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 466 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 467 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 468 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 469 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 470 0 obj <</Filter[/FlateDecode]/Length 354>>stream +HAo0`HD$hܮ+k9 :,HС4#ݸ<d:}{ �����������������������������������������z7y~M;^enY,nvy;L۩^;!lj |V?ngmeZNyvgyQdlY\\fVWٯs֯lQmX/!q.>y1瓣~'S81cYyn0 +08nؖ.ݍ'dؾa>{��������������������0� +& endstream endobj 471 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 472 0 obj <</Filter[/FlateDecode]/Length 3928>>stream +Hn8ş@M-$-.)bKZL>?"JF4[uI#)fx屗RyLys%#ϣ$Ʌ\߇"/4EkǧZgӇ4Lfg$ѕI^mJLdO{*9yf#ff-и%7 ^ c7>ǜ3}w_-8?\!}YvܑVlw,Ք( "ƛ[NpBrZG +Lс"O$I&tB�APrzY 1ḯPwӕfLNibJMoL5JŽet 64YxA/U&moʊiIPLSa<nxQ+Hxp;&ZY8&plJ8C44qGָ +�aEưcɛdcb"yCv-+P% aZ{/_+ni b-;Yp@ݱc$- µcsdePMEEXc%$mSMYq3ǧ%IE# oCuYng%4C WjҌiYo+T3o4+\[JԆɘ7mTW¶*+@kPyV:H_Pq٦(`=3ܵZdX8ĎplJC44qGָ +�+ 2,\r@PXĈUbw79D}+0Zźrn0+q*T-IKw?7I @#T@+nP[z ഞ|~x_][\Sp;6duώHo *&BdUqFXMydgPJ\JTp)lcݦB;B+*T/tY7{1M xc.PVSv*"f;'›쫏@47A WcT!W&QW  +WKˮ=6@jB?yՐ<A7PnNtJw";V[dzՅoxk_Z%qr.�\dbU˯3etQ}e^T??p3IMbv==^''m2:xŗE\,1'L.^s7eg8v/7`X();Q@Parl$}K\V)cfzxTf;(BHҰv ]Yd=77]\(o _x.⩻1*|Va5V3[THj<, Y2a5Va5V3 _P@Mջ|=@ CbjY8aʨ9SVzMg;tx*ykПnkTPi. 4EOp J vHDxŗE6մLҮ<$eHZ!cYnA̫wOQ@ѫP(RZI*Aej5A^ijגBl"I u\ +qÛ$ X.g5jҐ; +wY4 -;T�\z \2Վ13 r1'y*a<_^x{V,PCĕ1S~طZd4]"idnY:T*r.Ylg.hR-gP:.a6mV*!Gm +FspvHŹ=jA7atT41 +ۨzP}u�Z();Q@Pe\8000WF͙Kn:Só#`=vfaRxŗE+ן^Z8JnF2صD)*ߡw=BȊ-Cd텦0 +.7@EջiuH_ #C9A/eWuar /]|M.+TPvտa6a6a6MP 2n|sby&l/om)23jCdz{<5NQi$} j^K"iȁbo9PI]]<h*} [؅P)V1Bv,1|@u+6kL~:f/3KAQ+kuUSw)F1MLS# +Ʀ$1ChZgç +4oc߁U"M^KH /W[&҇PoGJ\; T *U�W90+`DvL<jPV:. '6&]/x.ܜ+3TRQvHŅ*-"F z{?$!=*%xHH۱>R.SuHC<"/0Rq.z"O]=tP}^jNETd֌us~ DxQ&q߷1.=DrkzUO�pٴ +I?ANj c v^5Hw;c~&։NNd ['jkLoMѰ*|?fLXw*\/BﻂػšvK+(ۙPC}M!JᑎZ}Ӿ"<\u҇6r.Ylg.hR-gP:.Bl2kk ^af70s%$M=p +<)$DAg]GL�߮ߠBR9q̉L7m + mb;c +[{JliB㤴N"2ՄB>Os`֞1fՔU،o η +R^y<蓨\SZ\s)QarJ! ׮EڻYZW)﬊_OUhn\<1{U>ѮbyjJU;(j<&(6vNRl"LghE2LWfd0~Zȳ &xnX2+Y]Y9b9%iaWCɡfilT6bjzEK|ĘN;@u *lΧVpSoV56 +^,TZ +unYU%q̵J'm U_e}SiR^+[.JUeۊ__PyF= +dFwWI[Vrכ`V-XF?"YWov:wċNdx?i^MI瀣([Iov8~5\\ Zzp].9l) +CZ o=C$ЍV5f3�>0#0!eΜ{̣j3\'"1 KZ٭{uwT3geDN$p(?~5PqvC0` ;",!^4*>v":kXU4Cډ[bm (ח[u"d9Eyobp.Uv1HkzkG#ыj2<zzWTٚ\Ӑ@ +C4>R�]B,8r)H),i BF $3^00prA$b@D3 ǞcƩ0tP, 1 +D'1^R +3ϧc)|XRXd@`�&ZP endstream endobj 473 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 474 0 obj <</Filter[/FlateDecode]/Length 701>>stream +HKQP^D "t&IJa muase e.R25t,$m9$뾻spdG||5 �������������������\n-5k ɹݮ����Ril,L n^'2G : ���<lL["60����ry5-9{ ���@>q锶2Xw/ ?_x���ºH|VqF#mF���@RU}(N<8q~J��� \Rgmg} ~*wFix&B!&xxfy5uKmgiYB!;Ed lxdM#x_^ǫgM$Nn5zL3Ǥ>wxw`Ҟ֭H[!upLy!d<ht ]X Y~X ͓lߍGw:DlC?;̳:ɏ>ˏ2󨯯v5>_e6V¡nNwgu==V}=VT<?*Y]vK.jjϼ ��xA&G�w endstream endobj 475 0 obj <</Filter[/FlateDecode]/Length 331>>stream +H;JCA;Q.{a*+oe#E>QAA W6\bH4V}0L8��jv?h~�l3�@5"g�kD"��e׈D�ʦ<�M_#y�(F$ �P6}H�l<ln>�D|r��fD<~} ��"Iynn��?$qt~��?$כoR��bIsg}z߾Gko�` <ి&��&"g� /Q��e{Q�k �踰 endstream endobj 476 0 obj <</Filter[/FlateDecode]/Length 513>>stream +HMKTaX0rժ65.5wZ> L"hA H&aSqrhS]82V 9r]pV{' dQ.=Ucg�?�o1?��M &�@$?6VW&..ua-��boW}:8R(ta3��Rf"?Ο>soڍ.l�@*^^o~~n-��h?I{>5}8f��b=勫�@ALڹGsGv:9f��b= $?>v_�ĥ{>>F��K &� J7g׈�oZF,�|?I'PH+҅bpL=-- f<^(C9C9;?bi~j.MG3Og|\iЌ'{r!r!QbI��^#&� ߼׈I$W� endstream endobj 477 0 obj <</Filter[/FlateDecode]/Length 624>>stream +HKKTqc vEA}>Т (DKhS&k'dR8tQJ+AsN#9gzx9́w��Hܲ5x~ ?!g�x(&3�@k$S*&`{8��&k+c'�\I}ʾ훧:��%wķU� 5qn[w� 5L]}lee?�d׈s<9{�lquRSԣ%%��&GUO̗3uV~̪5{wө\xl{yJwg{o\:��g& sAf/L{[C!�&sZATkN=Uދhռ/ �F?HsGc| q>�`nœ?GgLϣβy �T.^;�c#uP� A1x.IoH� o74i"]C}r +��ya> sAGKz%� �br endstream endobj 478 0 obj <</Filter[/FlateDecode]/Length 760>>stream +HKq&ꡠ!TdFL~ Cs:AE~MO8>a A|>mxvx=�4Vs/~6*[ΞS}X`g��� `WgtXC~ٓmo��Dg=F@{ֽI٩/&���eitQ1/ζ��� Dw�GpaQ~>]}\Y���F{LBN +˞2y(\]���&{|T!wٕ2:)쏪 %kG]���&seU}N +_5.���TbY3:)o=ɪ ��d6)h~D���P{}F@'qy+=I���Ly{HKNA@7Qj뾻Ƨ ��D֛cY覸?+pn���L?DroI{Q}��6}o7ܥ?RϚU��`{JGHGh(tX}���&ɷF䁠?RQj뾻YT��`;:-Rߧ���LؚI}xWd^{��0_ᥩt_tZZ|c��p9:f5t_\j`~��km endstream endobj 479 0 obj <</Filter[/FlateDecode]/Length 871>>stream +HMHqHJDeRYzVAAEs]:%k͵AQ霚=/E]J=QxfAe۠ ~;|���˙iؗ+~'fEuG>{{URuc(ѝ�� n65x{!a_CNm+=s��_v]o?`dntg��p]FLlOgyt��0N7%;><]wN���sgHZ0ҿ0YURyk]n<;'��ɬ+7ҿ0Y!ގt��0}+j4Zc$zC};'��ɤo Ugtڣ|E��i%>;ӥ/xf +��`>o<o_]ӤY%.u'ytJwV���ů^>}7?`TCNuX_wV���Ζ* 뵢ug��0H ֲ?쏝IrUP;.��QV%؎jD 1lkN7[w^���JϚ2jc49Wr/\ڞ;:��$=J*Wݷ"/0LlxhE?};t]non;>��"no OWIj>S?ܡ5VCkRƻJ_Y���cIߛ+=qRҫYяG+W?m_T﬜2PO���VI<ܽ"[IaҳptG{S޷'ۗXND񙙺�@ �mb7 endstream endobj 480 0 obj <</Filter[/FlateDecode]/Length 1704>>stream +HyLwoA@98`D Le ry$D2Q@U +-Pr" aTf5x`\↲?ק C +y%?ג}�4kk NaLث KegޜB-�3z}zRz:5K&����0gy k^ο:O_^%O/v5"eYI(#-eΰ3dH$+D]w˚k���L,IK^VC;J]UԕR)LN.i͌bX'/hPzw!4RT{SXǁvG[;#���91$%+Nѧ3 _BAJ\3dNgLݡ +mQFJ>'���D" +TWӭ$kmeLIUf>7dp>ˇ0 ����$< PN=3ye +y߰&:E!Jzj@36Ҩܚ4ØG���0;C*Ei@DwxZz}$&׬iޝ61tHķToG-].V˘���07?Ԝ>MS80Yx̝{#ZtjJ)*^.uޞF:*���Y <a,ҒZiɕN>k=:9M}P4*\g;����fEV[BZNӢmDgkcêEe7̙Jaٖ;[S)O_şSƺSU xF83���9j(ݤh~k?N=E]Z_MF̑%S5(dw{-wxkT)zqݫkno۷|l����aG~{x"gA_bȆ$6R{刿36j+\n*(r߯+A +Eno����}Fӯ +ՒKS?`"ˌԼӡ;22fp^R뎕l`ISV,N0���YYZbauOz]D:XO .`sj˟{?hN.>/_fuϚckRt0���PPPp5MQK m.0e˲Ūr٣۹@k���W790NjRv eYt8+e==u\w~>.��� +vW 4^Zxh&4;F{j7{ c>/���x%l=@I;%d2nƯeU^7Qw,0���`GuuQz0z 4إrO7/e֥I>3���x$rv3unPݸס;d3^欃3h ս4/jVNW)ۛ����c2Q׼v=UEGcm,``�Y endstream endobj 481 0 obj <</Filter[/FlateDecode]/Length 1396>>stream +HmLeDe.,ͥ-{mJ'*HdcNLTLȖ/"MIP^CE<Ñ̗ADV}0Lk5[\1#N9ݟظsojR𷰌et߳JZm?W*7Jso��?XDn裖SX)顕Wikm^ѣN}cy[cCm?b���"#=srz#sxOC=?k:z3.9_ya(QAf:��@L hΑsq;?K<Yf4ͩ.sGeKv��pl~$~##̖ڑ]_OF(D;Z^:l֥>���m""SݭoSi* <:QnOx|MP䮌U+���m:-c] #M_C΢ A\FoqFo֣Tt b���tC{F:Gzg <S%?"]Zűoksj!\쬈����5"fHH$tpw?^_8}V(sZ~��{^n~1̉xj~j)ovJoZy}x���pWGE3W*WmcNI�CN5%T]Ou+SO~��g}v2kc Si/cɎb/1(fSPb۳,rK5)���\t6icFLa�Z[dG3[C6oR%96'6-���$=i+-M #=#]\ěuQ~rU]fWΟF.յ���nvJZݍ}#zcHW隱k�o;*Z~⻌ S^p~ь~f��_a"GzFFh=orf$ jꈐm~���Z^c( ge' F?x{>ڧ]JL7qBj���c\=)=#]9uۅ92^ˇWfoc���>ɔNij}jl'8-uډČS/o1ic}~��.9b[ccg?3cޱ23[CyD'S 2]��--a+GKrK4tu&rfZ_{YܩO��6o endstream endobj 482 0 obj <</Filter[/FlateDecode]/Length 1404>>stream +HLu&h?M!a4\e (Mdi $~hI}{럜d#?mW ^?|}{nDikLHm,c qM4MƖ[=Uodޣ7~ y_gVj^2fcR|y���SVJo(P; NW8c�?:{|VMlϻ=ӗޤl���uOW[_?G1(\/oGsS[x���{vw\й{% K?@mxt +UɝqԔyǧG+T���x֚ ]B"Y|$Ԅg7|1<{D���%6:D%N훒hK^Vj{SR_uǫ9=~B/+=#���-CV]MrrZ:Vj#x aKu:76qy ���Tne`suߦ=2:%r�Ffj1K%}7`8mNv9��fh>"tOSW�̟:u MW4ޣ���pgB]B}h=NjcŁh. +÷|[T_޳���uNH% +#SέO]PA爱Z+ѦwCՇ���@u/:sO?,HZ˻(ixCIzY~{2Q���*#:'J7|(ik8$tn KΜ���@]jOM;򿾿=Gt-ӼC֯^" {/=2���PW[eǘyKxPP&ocZwV}yV3���uh<^GG.F?@mɨ/tӄ=[ql}2(���` ^A 4>)kad|"8wa�5R| YETQ{p6Mh_Y{n���Uu4/S_{Ǘ'CGqo"FJ?N$HaEM-myJ27 h4G���r& CY% <.w a�R~8Iq|/#I]hKeKFr>=;���Xrw ( +k :;?\»Z)uSjɳpCawAZ{|���P?tgi1ްY 5_n +�JdV endstream endobj 483 0 obj <</Filter[/FlateDecode]/Length 26164>>stream +HWˎ OQO}Ɇ<a$;"ggw}1$VWeEFFFkX[Kګ"֪$Jت6muml< +Yf*werUUQC/jqNwOO_>O?!^zwӯ?/~/O\~#V"/'\xl6r98xpH-ZCѐڨ-"ڴ6GcWZ7lkyP FF ix,? +2�Rjb%HV,qaM;R+>{H#vjpPu �B�E*^3KҩR,J kcD%$2b%Oj"LJȥK8Uqg�7/'X(A֙Ye&DspoƏ +hg⎬{:ajX]I4tyT ~_<,�Tr QF l*1E/rh@ge�%׳5;ތ1d)7 /vê}Ԭ.%\l3N&'D ,:ӭ4bw=RRfʈoHDWqw|,4E2 qNWbt@�Y2W,&X=HO򝥯%;dPI- =)`C}BE%zX{K2A>7f߲Jp\[`O ̽ PF$q1ۼP0 |fv}8v^ٍu4VSMxTn0ZuB�g h󖁪JhgqS6TAbe ӎ lȲ`V e>&"8bmlUFg!VέtzTwBc\xKl\oGi!;9L$ 4%T%5L�(:.ԘC(EYjZ_yKȆRDL:SѶ]N� C^OkzQu m2mlL 1׌bD"/=!a5t92/[sԱFk+no`@6YxtȑC5fHBC +=rϺ9tVnȳEF<JPio=@dĐFMO+*A#gDQl&S Έi#MvyȽŏR4nKf0' (΋"1q'>:J>Xl [u4 @ljx#fy=f0s+49$+~|T{ɺm/~G ~zjJSOn/Gy/xK:oCw)[u+lr100i;?.ї�dmhڔu'HFo~@ dz])$YM]yD&z])"Fց*#<فKXR$HFr䐝l!ΰ1mP,mVk +I t||@4ۛ1@wJ~ kRv2Y kٶ�ۻNSO�Qfv/,(0JƖS)B:mpɗgn C"8VK +K7碘M:?B/Ē�ѧ}>$"n nbJAg6VvuWגN*U~ hm~$!@H!+݆sUO&k0Q( NZȳ'H'iٓQÎˬh{0lWH@t3jSsJ?T4o'GA hs>=/ˉNg#.UK/hS2ӂįSGa8cҪwQޗmo8/#[vgJ@;2{7wQ,cdZM@FƳ*+D#:#|-_)nq4QB՜ny|x6AJbpD$s/Qʡ1--ߞTo|"A|"R6[N S䵼0n۫5|CQ#RejSQՁOvG? }Pڱ,_E^Ա63\a Poàω'~y܄M䯊~,_pzkGlkp}XfPqL:=g&LL˝b`Gm@+csM96/TkZEH[ %,XbǮgY}H ѭ^|6֑ϯWml%{ùbxe_U.[$eVϭ(TkδO^֍aìp78iݽVirBF>IRH69_n9~‚ hsf(9t1<3amMHPq|93EGM3eYɷׇoW. U7& |M*v3b2U-_A(CE^nQK~yu\xvLĎH`m)3x;Șz-ϑrXfI,8Wu!sP"vs)lU"hspMءh$jrmp oZ30E2wqmA `[Z7 c >Qm<E}˪BxmP5bUK(Qѓ`gfXH�J$2'(U'431ĐY}kUGISԔ^ Lz7Y2lxhӒ}dmS<Rs2ᣊ_u11i=%!׻=+:i~wO[jJ?_9}<;Z>O9D.R{> 9ս~t 9JE1\N<Xڳ +<+pqP~: awzz'WkC7ћj~\tru'lշ�nFvŤѿׅ1eTf)=>gT't/4$=nɾx]\M~/2NBޥ͚hD IR w'%\@_^I0oBvlL_tz_uG|jݻ˻m}I4EPpyY'Zhz-Dscќ4"9[DjN/t d6,AMuCJS@cZ:Bmܷ9^MS$`B(`2HĖQ!XC"D>舶x4{ή$!'|cJM-Bh] avm&dI:̈́s"ׇ(bNi&lnڶ6^8!5%jI|D] Nc*:] K08"Rt^EԼb.MpXӥc]n!kT4#MCsC#Vkl~" ")+U"?_C)B2֮oe$*+M/$ɻ:ՈkF#,&^ESͫ -hil#j =]l`^�{T6K tui \z +>0$$#v5583$a#=-ǧ#EZ$g܍]Cc"8m̭G2_0m@ 5YŁҶ +6),pR�0X-#E@ x(=bv zBW`} ED冂jR3#Yw{)4t\.(I1`VDpck,ӬsIYq"-rôn;A *P.ooᾘ ¹O%˛iQzư/yKE18ZB@uq1S")}nl<ܨ`i*}䈹GئEXڎES&Y&5I77^-BL3((IƸ}},=X6e"cKÛMFư4 NG=BttNߤSR8b9aS&/lAqKI&e'q(NlScy@T ]ɠ>R؃Û:M)H3O$AM$>C7jL 4D8$/5;#7z.n%jov1avo +i pr16nOWAxο^fܲf#3eAylCc]s#_}[6ȻBPuK)M2Z&_c|YTT,ղpu*:T1~T.zHO5驢4=31lG;7g76R}A˿9l6sL;g.vKi_^ <<vU__]/_ϯ.Wrf77W[gW>^.ڮ8jyqv.Q6z^vGONcylx}}vsWѿn{}w{xS~N?M>Ln.?v}a(^tj|5Ш _kDZyM$3*,<jV?"j靾 r8c APePrFEt%fTIs8w؅zvMCr?+(oڱiݝtaW`/5tx Q6i.3J5AN%i%X#@pժ+�Sscn~8 ɭXV^XYJ} UdD4ݍ5u7CK ;~U?9e'01Hb,Ć +r dR),@DrG 5<k;RJQȪA5:똻lItKU 0݋X�bL e >jMSK"w BDs pZA|djwOl5Z5U%�*־*O[C.*oH4M +"/g䉰:T^ vHg9CtkNWIP`{%(|E@D1HHb*!*c&ݧ5U.U=M·S w?kqNb`v7;n.ހ1Dk`,VI.lˬ9KS%? HY*[ml>eA6zNH+] 5$0: +~zT³ǁ yomKv+2!؇rrߤBȉ#c࿷{|BM + 6&W[`p^a`^nߓ,:[w*m&4OѳSX{t'qO!>NWWZ +aQDC g8�W)-!֧^yf:h,V:Mx5}rfF{g7.n3s=Lp qj fbx5~Vxi:b2rcX)S蛣o4w<8 ܢ �H۾Q!cfZ wXҿ`g4%w`ďHͭTo-l02yϐ! +@eYo-ʄשk"ATe e(Gz[- xW\w@.J"0K}JD7Pțzs`FDC/ٖ (>vqPp U]}4-&]5m-ھ$�jf&S,r�t`)$ϢL7Vnc`e<bvH7.|%%BE|,paLL!x=Pf&_!R'=X ǰ!yؗic,^Fޗ.ZKMլT*b+V2JV(W}c~EΜX13gUd#?3>&�^hael]u=?,}pߴ-UKR/ό2NݠQƝ-:eݐi!RIA^T;J)|iOSZ@*,/!O(hEòPw3c6?}ן___GriGu S!ai"4 "%Wf2 83+qQ^:+FU<b=0ab)ikـD vпy[4ex:-\UWo ,j܅ oO[a2l)SE +lh[3\2.([| QjP7K)PP{Y9{T:PEYϻ@B_ˑxTg2 z{洙< 2%X5]5:g{NT A..!g�IJ4~p|iQEBz nﯳ4ړA~&S$#:-1Ps#IFÀ8i@'Ss[6X"IJ&eݷ5SVLHTQ�T[k@V*tϖh5ԩ s0+I⼟Re$U8FVK'D^ :.֡ �`OQS7I H}K˟)Ti9c>Pnmg(&m!'G\Q-^U2Sb,$ZRS) RP+$W(<FhU +V(<VK p!T#5${ie1eTY2CCWQJ�SdI%On08_`pIH&Nv;`{D<Y5Ş,c= mAq5lTULe0ِӯMBmv &0Tqv>=k+M_lNG/`vc`l 3=,i0%'kE`-Ebp- +횎T=uQs sYnWT]؟C7n&c[sZ�DaWגsE&HOYښcҺq候} tu<_2xբS=kXpBRJ(xH)(5dJ-FqjhR2{j|{ONP*IH�D)mb]k.~<- U ,)v@塿2B%U&V)IRz+Ouȑ[q&eS0 ZZaۃ1sapxip$瘖sCdPNcadtmRqًZO8Lzyy󾩮`~j:0f1۝zF<@fP?sZ.72y,mwc*-}A$جnj= Yj9kpGLt÷? azq2xq&J@'S㌔Ū@ ^Y3W<78  ]bپ4B^_ g=,G|L2aZFXf<ӨlC"&04ޱnf` d뱲IWTN +9Uǽ(S/i;:ᔫehh?L7;z\Bf͌rEuœf?h7X)NMIeZ @>25&ves'Lkr0")R#(,ca"DL&; xiξ=:UHXK3_oZe#9Tҗ.?5J"DrYen$˂L&ϕegJңS8;usE9jK +αcYͥdeZd{^.+eo"$Ovw+(3 Ct t޽ϳj=pU:]i1qԙ_{BٻřjxܧNNӝ3R2% +l&3lm5tAr!K~ZfkHз2 xtT+V%4F<~f{[.}"5=\D GjpDE&x/aJkL p(Fd+)dvLDG[xU XA1v1iR8SES,J?f)M =YT&M7i!4ȧsŠكUgm]=8u51.}o=w>)@;&R)qF:EUfB6 >v?T\}0=`)4uT*t^AFi+y(݇vCG,=yO8 [V5VC9C)Ïz6ӒDZěКE.xsIBs|ۦ:]1cQE'�lrRX�q:D p2tq$/+yOg`Mlۗu)6UQrڭ\QDfRg̐U$b.k8'Ed6,߮Җ@Ȳ�do�BC:Q6:wFʻQEXl'c>.Aggps;m HsG^nϧPKlxE}<Ж!*èALR}lWz?Mƌ ;$By!n턙MZHtw9-qJPQ4&i_P*b 1>*w=4ݻ/D}XRO@z~&z)uNm Xe8-OyUymؗ{ R Jz)Qck(YFpFL]ZGy2BJe4WGF2(|Y?P>)L9֥rJ6RIt/zOɶg|[|BSrfDm9A{> ,q3@3p;_`m)!Mk ɬd6Wpۡ{V]pMv~:!ewkg`f / +2AȤr̂ŬU=t� ] p$d*0p I)ݹQ_ZE^&[׼f;{yyz5frkŠ / @=m>|n!pDXEf(2b + 4K ISO�r1"54ͭ6,T$ Ңh`1eʂ讧G D[r<_ FO{9m9l-yYq/ՇLhC=;xuwZ9K}NK/k9n*!jn}ԑwQ7J =7F9+ϧL;n}:{5Yvy(8<L6ú]H9֒ތlaCЭ >_I[= n€j5ֵ)uo{T\|MS0q fsrByvF,mi~,+@ Jlku` +}V[Zs#u=?<ۮxf7RXT +.`zlA&ӝU^!,ĥr QG#6Uνx6Z OJ+3.GX;W>i"ܠ�׫}\oVJAKo=Źmd+۵  `~b?91p*ƄPE1LVܢ:6{] %8M8:)<0)9ap<6(;u5 _p�0Q4c7ܤZ/2 g(0s!} o5xR :XF-iꈊԆb&4o‹Ō=s;[ a!�J +Ao=k;Y6߅=[0Fc|%IRzP<X+RA/;0_<!^͂cRfs=/tNW3x>`-6 +/iRZ g�'uEpOJߏsx Kau勜J<3X;VܫE/~?}~o<%(W}7_/?O헯_oz]|}oeJ[9J7l +73!) ‰9bC&M ݔ5άj1.ҵ"UݷM:dLKn +bRج.mEt}P& ]=Њ11Ȝ'Ŀ4[gGo+lE4^M!k|# >l~w .EV]J*󮥝%'&dft=< VDՏ](rRwiw^LQf+c3+F0^kJ�Ŗ~Y/Nٜ?faN"hELHZP mG| "J,n#C@j ފ&�߅J;SL{:Ȣˏp~1{h%aǭ*0̣҉ʷ,Fu̞͢c^!{ЧbP}_ء(~#!<N/Ƕ%oU ҕ\!du=. +fAx̢eun}3׎zU"x7Tԉ]GƷR805*֟Ut[GEj e_rtl?&Ǽ 4o $]ג_p$*ߙ&1fYW>kWWQvaϘW$ƭA5~zƲ˦N _`7cuڈ'?hGY'vy#`4g4,޵,8~iFOhYUwλ� -(7KtAAsps+ #XOF=t :Ѩ!X\i-urQ % ݷP(فYC^y>Jՠ9͖ + |a�hiJڵe\#DRDcO=;a(*3bp1Bee [>OMڹIar"Osiq>Xtq~V(rFSx]:xRJ:KOl>hL{ۘ=XS`  +L͍wŪf>R]t_gDqR#O4ÏLx>NG$%ω=jNl~~%l`9E[; hJ'Ĵ -z62&M 2nR}=K9k{"Y5 6OFoP]"OZbWNFkK?uO ĆZ}#M$A:>G;;_w:ORlޓBfjc1{q46J~=ˠ0J~+4FSӲtʾgk){9 >͡3xWڬ1ݮL3& nqI8\փVs3jޫ /&3Ys *H\qrQ>w4+cֳnpԢe-t 2tG(^LJ /' +P ^T)WI;)h损@_n~y?w+]'[\[+%p~2"2#Yk2CLJu$V?f-OV| _`u#ary[4UG̘ۣ(b;_O-d`xdHwR!>{`R)D( &) +1;Լ\j;KWJ͇]SsNG26Ds@!#mφ 9 g13h2$QGc}x˳̍[i.SVJYnWҀ|l:ٻ҈11pܑD_nN:ui‹! ,nɮu* @x =]\}մl0G9> +�kl%a0([ +k5X3a }FS`?K)QbxDyAaX5QLd)x4b4Z U%֥2k6vw|-B36`i�s?}mo;kJ )�*fzeVoMfock(0ԖyQgQDp˔zGZvaҢuE)Nփh)gd?ZP5D_  d';/# +Y"nzb<Ŝ<p ;ZUSMo9-C+njEuۡ_v ;ǿOԚSVTQ;1wuV=04%%I:K}i+ˑqSQu;zIQ(@/Y~_Z=ozOިˏv¤jhۘkMTz_:$񸛴e2?V5댮k3֠`8:LŝzG%k9ɶ}Ϊ7y8\bnty*nȩ-IleH@aw-InQA|%B\eyZjL|Zܑʩ}3Tr\}-Nb|-7O?Ґ.%(|)RL|]weԏpburߑd!}J}5`هy`TIժ]8!vMƄsIo/QdMC$d}&4 +2nKNl>Ŗ11Jw^? #˦N\$(_PYPh7^a ߍ﵁؋G|v $Zӏ+QvUiH$XED,*E޶-F_i$RZZN5wwx|ȉ%9vl \a,b)#qYB)7e"#.ua=o\CN" 1 +ʧwsYm9qG5CUYy?Yes#9syj!"~, T4=՜RI|9+5{Lgݢ%x {I$+Xz9r%ao!qpv`nf։#TC:=˾\hlW=#^[[!w-I6s3=0g^#jo{qQܣl >(ف\4BIH9=.1ldtz9 Ÿ)hZ$֔!WZZXzQ.#|EɃ-uXBzC<~G物"&._L0v$ 4%̺Kf|)ˇERSa"=enڭ'_IZ +Qd3QFQD!֫pJ~ŀ&WrMmnLo/#e1p/+>AÙdHh$)ICgFilaڭA>k|!N2 <0_}Ꜻ}Mם3PxVfDL{ӬOuhA]2Ji>òg:^88% :fyzdMvX5?i-uD(ul@rhVcYZOMq Ds>)2 P+m} +6X5zq9z4k iJͪ dz'�vѬpmgLScVt*j_^�n+!:p#Evb |ߍsfqDxB>OM]4qǩfZ +Gh='ww/ Y;[nz 8iŴ:H(Α=B4=G 4˓*#`Ylݽ%3ݓNAjg6'ud\UhTĹ7|]ղ`.V~èu٬L8?x0PAq:պ:CRg2u*RWE'%�Jb61&X\W(IEQ-qwSLE@X8»H5IIGi% Ymrod�ޙ uqY֌1% v2躋L3|[P~(}"]Ϭ{B.E ?㜔BK'R#!׈a"f9<Md(yt՜q =p;꩘֝9jiUy+G٥l*{32#0 <{-ҠNӞʏ~vf߯~w??1=Ͼ7߽oy~q?nnǻO?7>oo +YO,?y:slpŋOϟ~<~n;]L2=z/xAwt|8}r|%#Q1 nbrNPO?JXQT_Dpm5b5mSѹ!rx�,J7ODk8݄~!$5S3 FȦM-afZғb +C ѧyf54=F\3W#C v4ZmBη̡Ft55R ֝O23WFe~\4A[ͼ] t\g:/;/7oIq=#mW + aOe~n5AT* ڤ8@@Ql \�_$]拨5y)$r/Ю915 ?B"u~4hGs.#!a\c Ç "_@`Jke +́1IR2@Hql 䏝 ]&!ctQE{3g!c%,<sJҤZ ' F'Y][ ̨g6^YǩwͺP#ZB<;t^#./>l9~NN6jq 5=7S~{S(㨒:<pB1<,#Wl?3V~pi^YJAGA nwzN0mGe$ʱKUYtdxA.(]ęݴ畽;~ QYl܋ecC DUi';6h8l*UN l0Ax%.3#Yl$W!Qn\%30:J`'% 0?GT%<mT9c^N0Vβ!?^{_mYT`�+#i* Vh\>w 舘HDYHtw2֖3Ki7%IC1h҅gCVdnD!̃>1&Jhur+<e*N,ucHbBzB 1g.c@kA}=j.n"tV<#E-,|Ǘ~‘ a:doXHPJFS^Y@1"=ØTC9˺q#,HTigյ›_g>[_F}g�M?+2}J($ݓd\ֆ;] R"&6m ׺CâRea{h,o̲}1NBEiL9ZZA`mX%Ehv.M<3>"%v7SP[Np/(vbq1>P@*a5b'L߸t BB63PSXWU c<zL!E|eռIFTbIIeji)u0ЪDDlIfp@UX�HLZZAK={dz,-d!$Pڸ 6[1$kttM$N@#6][*y+G;`NɛHT VB[ddo\UG<мTǶFi4bBBp_ҵ<8� +2AnXq|¶^j1c|9S74ֵ_n&#M,weL6q{J^26\L <�$0ÌdG<3sG}Zo8X+ɡb5*r5@3M=ɥ#~\AP]|GԼ';<.Ǔ8x +\L*2YØ8UvVpdO IIIJ|C2VnТW×8%>8%;yV"6jqڬJONyuƧG3MCſh/sdIn+P(Eb^ +]jιȦAdA|H�oj S6R�W'ew-Uy|nqhRϫӯ< +O*|MsSRb>kxcAK8沥T#נגqHqF7UBRHzٝԶn*[tFT{q`0O!j޲Pݐ){=젱oam\YJ`R6nͽκw5cem[vR!Z’i^1TK `3n^d|KN,4 .}d<jd'D#0l7e tw:ܩ^(s}?^_vFCҠŠ3 AGye/J\x]) .<r/=Hvr }=yqV4 %d@l FV@!%_Nµ.k +| ~uz[^Dሩ=R X=t懽 E"XwXi=לTK ǯ8$3GW\@k( snU-hrDhE.g|ϖI⪙ӮjYo!S&urEfJuyIУÊT'*TT`f1:G(£EI$Pl/KMZg@;uZ' "Օߝι2Eno;,Xh&,N *n_! u)Q)Q +S:x` kٹF!ZiYCۗf}&xلW-G31victdh)s*MG[*h,yE_\bW qs^!LGtr�SdMY)]5-׷׫S|9}k#Ykk_r_LDjn/钭S[z%q3֟șGX1:A?{~R{& +TN1]wx"hz"b-4Ubhإ(gO$i?S_ňdQ%)X&c}>;~{ eH^ݳZ]^4d*h{ۉ$V >o8[Ğ@<r@4D^*SMAZ5S&)oMF5Z&RXz<Y̸m">̫}¦( ֑VsK +sYƔ]_q3Լ!ATq/g|MյGm_PI fβ珺t25Oů4#{u$%+KN][H<pBHEUq +Z i>ZC~]Y|Fք}6)ͻυ#%~!;ϝi5U +&qlJʼd)3Eƛ~MB/{(*;I5i]TG M[CPaԨ(1or䭼j_>p+;m0_`CNЩ)Cr!EO_O;Թ2�V{EI +ʪg]1<`Ȯ##p59T@p` "b8Ǩ~. 4°)"*n,@kpj;I +5WX !t?+nlѶ1d38�|]pw*#u(ŠZڇr=] j4/ 9K +:/"oI5qo_5$ S_SE' 4*ژvږ5f9aQY%\1闒<|xYG +V{qh|90vR~5NE\5!,<WX0" +{ՇX ѯGbo~5ҲGc[�07DT۷FWiЉ~ڃ*Ԭ # +E&{WjOJ@BO\M`:T˳N+9e +sQk&C2cLfB`\A_Yl�'4gy \9Q֌Ǿ/":t.r7.oUC>h@ zhk4 q ubR岗#[@ٷL⃕ ¹8η'E@IU҈Dx8o}K~]ěBd0g9Q׸L8sb퀰hQvR1GQ @BU6 .vgs.kU{Z" 0E1#Rǰ 3y|S 9qٖu&g4_c 7/6]^+ K7ܧ<$jM0Z_\ȾrX<ȶ6?/O"yK7u:0հK8by)ٹPț�]U#K+m�_·i=[4,3U;Ń1H4=$,,ߪ<>rur92xk1i^^ (dlkh'e3jՆw ðSո?댥=lIp,}Z1ڋHޯ$ ]+4rX nNڙm oW�*%R҈tlNeJo_�,*BMTBnY V;S6n?,0d?(GʍH{?-Jv2@hUn#?FL$!%4t`ON^wR;\"FEAecWE/?! }#F%!i!)R1@qB`O D2t]ZQJCرU)\$G(:D/OoTe?ӈ2RUy>z;7fuKq1. O}GMqqwLݨ'hSv@˜Z\5e5\-c@4st �!t95gCSh S0Lw@.Ju1e}|$-3;9 WʦUL>2ܺ@Gƹ!�#WΆ'Tr_% ESj.>hVBi;LfvDfB&PJLyQ20C"HDyc.CD\\B2Doծ0w٭5"i GVSaKM>ek(m}#Ty 8І1U͕ҙڛ5-"h>Tp|S*٬Vϡ7:\JnDWeyRU+.u'VsFGuӗ _+5"Z" Ƒ l{'wå6(AhZ-&E(ٽYKN]LC-%GAضU&+bcX\)<W*^ Dm/ {j/EEa 5貋Nnn;6rjGFZ R.ڞ\(a禍E*^\3R//L=a ׺ TglmD!D!ؒKu.*IVn&k#|k3mnm\d9i{Vf1<4K Q))DNY3R΀dDDbiY0Ƙ;#t}q5ā+ش%΋Jx\lA\#V[Pwۅt>聾RK0wh-\ ]&R=*�oFRC-tY g*=f+Dl�8( ˕K@jUܡ%vt(U]Vj.PYr=S `V!^f[_ce{.e˶mMXˆBYb&R;3A& &|ʕDOY=,gUldK _OCo<$DsCϢ�S^yI`ҳjPXJ LttoyKd\,*nX"v�]7y _>+ +yl! eQ>D,cPmU>`=TJ\+tb`Z0TXɞ[ +n?K{$a5G u5Uaл$=$uXH1!BHК\X}\2Tnҷܗz)үm؀>&ªg&Uuj=dʞ.`YS+&kSqu@s?9E†I,K1PUhޡ[g!y^+whXe9YԪD+V{$hx7Ǧ'سy<7Хx̴۪̣߀SbT P-,j�)'cY"iʠ}$*GC+@h} + ר&mZX> :w{{ZNPq2Z�I 'y%Є2TM#NASH"+0P;=Ra 9{E!aihѼyUdNӂXwà5mFR$ΎM\{QT6֫;ihe0 Zc7=]<h*lHM8&:8_e:.:PU7w%X#{f%ZV.C34D\TEu[6iK@A^PzQ~Ǧ0H,Bz]1(Lk؞QruQ{'?3^lxQ`d=J'N�-d*¡*0 L ܘ- �8,XN&[ƙC0غ:Ac#/ʥKm 8c)-B4K;逪I V2L $|تٔ|F3p{}V=(_7HMq[oUrkS^]BK@lTZX8PdidvI(/�CR*y-v]] cBla-$ _c)2 jO :T:lAEY)CFGP'=½EPE>l#YК§@0B BQ,KkϐX�Z,}fE*]$sE:]ܠLPHIA<z,N&'H/)]. y]w^T I[eXK` )4 _(�a+*i:T0NW3PiSUi{PW=Rhl_(f='Q^+u_$XH)Nw)xP8Q$v0K0zu-9(TR+"TV]�5 /~?ozt?{}7n?\_rÇN|U|OnCdgV'@fu?[=_}l77߾pwoCۛt8G"nd{ f-6j ݗ +m2#YSG͘i 1 +ջD p.PgvgB3-.E6C>X6.._:iV]4ciqM\%~Ob/+>4GHQd9M,nv1 +( `ԩ}.'!!y= mhzAu;s8TEjPmq a#ƺV >Uq)!KP]5T䕀9/<>}m;plljo֫O0( +|1f CWOKNv8,331~ +JC�Iπipy#0` +I&F`^ݰ}Dy:!H)y<A'f % DnDh:~Z z yw#c.ިp4op#N1K*-6 1upm +n6)T┡ynWjy rk0R&:fGn +pUV7ۓ#jDqDJ@b:VV܎9E Tۍ@:©6h͙ՓU\[0634k>6SM@RR<O+<FWOgR|:kr+'".L#Lt>Rgm&tfN"mI$Д#=z[8Tf vNmTҷUZ0b@QN~V_k$11ږLJ!xQ2ʌG5~fuF-í}( u7k`lmŐ%'d>,\Sš5\Ǖa#nN=\P`ǼղYF"/2F(6G#bfk 7<T aZa<g9":K~I!i�V\"2s}\=+<Ҟ'y8)6s5^`#Gj7=i,pV+š ^r8xJPLgĥyHwz(O<@X,@O +pr@*ѧ\+Q ^!4[\b+rt M,/Gaز =p^)؄v\$ԥ4p쐙|Ê*Dj)%NdigPKYnIGPod"C[[A&HlnQ)\4H)1sqn1ؽB]>Ί>鱈x\}[7-/t:!(,S>FUrLj0k(͒L%YVjLj>~TC=0_KQC&�6oz^1s@S(LP>`K 9z m Lљ6Б@kՀC-@P+JTa '3OTBU+'#qCEY<$S +jNqÿ.CGN8c7ȜB ]s9\(RATFE�c=kN MQ97HZM`@)d`>kgXÌÚ$zs)IkC1B4 +w}\tv62},a@TNyE\c e)'2c[;Q  u>BMQ~-*Ɲ n\y(e4Fͥ1+ُhM~&L҂hJrZC0袨P 5zaٶ]%g+Tn4؂$yfZ8o{df$ 4Tjh +1!:ͳR Կӕe=;{3WV"8AF!unpnh83bwpB(O ~Ƶ.VT֠\t]|QSp>⏽mт:I:dL|Wܳ1DzFGu'YdžġO0>mΫ|xW pM}Zs<eԆdnRԢf#xA[![6EN]>K$Im�GC4UI4^X>aaT9C~s0Wi!%c +9b,1xMx , +WR30Er<]ugay߽M(4Q��3rT7$Yν�@7hLGF]Ih9!ج葹V*O5i|t57P_$ +IeHBZـ1ʓչ G*)+:hV8E-䏢[CqnL[ѼF9pU{lYb A!lx0*ɤW?#_Q>ٗ_<xЧ~?^~<}Wᛯ>zW̷Ͽ~xoHggt/~wo7(@> m&0g<(~*qPm+M +YfHh;`�8:=QK:hh=r +<pN6:g lb8pxo"|k9F; 8Ju戥>)C&Еw;W|J4D" !v(OnwYMHb5D8ďw OrF<F(X9Xev Miq*wC۫8wSF6MW]/ ~֕8 +;\=Ӝ3ʍTid6D<:IxI!Bs-Ή2Ʋ+a +Sdut&_x`Ko-;yE +΂C HAᵺ+j)ɭ66&旲ZpPaǵ YOrM'k4SM>کPπ$w%1$<w xY=%( ~J]^pdZ|sNͷ:z2A1ԛ1m+Tjvb'nL#WKK +ڬ9J|$);b)+J`rZBqL 1ƟGW͋} 5j0!Y═׶y[L3}6Q_Ům eʄľFTw[ЛBѨF$-Y^e$8'el>zHI+RmA !N<zUid?F0#*bChLU`@[>|>'dNIZ[mQqkrn6∹Oċ%6Dj_^A`Jàhlu8g{OL;RsC$Ժ8JJ1}xXS%VlB;,yuiMMtl +[&uRP3h F; f%5 #vG@iPk)O@j'xy9vZX\nFƑ]7vL}R e`�v endstream endobj 484 0 obj <</Filter[/FlateDecode]/Length 1865>>stream +HyLg]\zGBPG +iX#Y@[P\nZ]hzXo*`ʻ qv]iΎd ys2K0hj ʼic>h_?VoEdoX:9LJBNv،וAOfyNw��KӏgZrDUlAs< z>)1J.vin�IAj,3ohLb~0/gGMGvxƙMvg8Y 4w7n/Wv��KzͶقFv);T F=5~QTg]rvX9g{&fy#s��� yF[VݣY#矤y}?@*RyCBa|=_[{y=sY 3]>J'T];v6e���^7H-!*2;> }1\Ԁ1/Z&L{2e7Z[ +l���i{yZ[Ծ<Q1mycؙSqն|Yk+eI^9}8cp_hB-*%mso0���HYJ:8i}jgnFyC̃RrXeG>?/T;'AQ'\o.zg=6l]~ã/���$GnmyGww fps6=H쬃RSƩ8cvj~>,ceX9~xrnEpoD0V6D-[���)ڲlY*^w٘/(gu?@j 2cʹc,#hDGnHj2Y8_pv%TFux\qW#٭X���&̼ʣO]|nG8l34p6q̼Sz-:WkK/oGDb^4\,w}pbpTF3g +戻���i;y +3 iBfUA~& 3΋r8(&,h.@NbG?hrbEypfҊ6���8yn&Ca\@S]]*UsbgS̼1%>geXz<~HY\CN'03io���Ql"GUvn~]&c=* &}C2/eژ=#<KtgWd%nM.Wvu��JZeǃ|g?=h~>Twr\l%j,F#��2dewP~Ysؙ\wTv_]pfDɸ7-J{���Ǒ1erҔLzpH + 3 ")mL3oYz4p37žZ���p.r9g|qhqh!c4i32ત?[ǓV-uc*2T}���й< +VWk'uw㳫P~!vA�W%A箫Yߍ&CO~b_/���t!U^FM!w Bmc"V LcŽE2zU!ÄEX]IOY۶}���{ջ7ШLkV{<A!p{L L&D).LkuS+��S`e?bۢ{&%/;l^<4%{YV]?Iv]z[ڷ݅{Xuꮵk}�RG�-!8 endstream endobj 485 0 obj <</Filter[/FlateDecode]/Length 4147>>stream +HgXg�,@u%FX@WZ]PR34A`i +8�qc 5eˮ ^I>3\ [1NU}<\-C:ȡUdzBvD4/;#fvմ*w|7ˏFo1){-?L]֐{L3T[OT|?ҶFXVUVz ޢBt}6[q32ky;c.%:KeES p~s_!= G̘ Fj7F!=^[U3 6,m +Y!O=mOXɉY9~ɹAȽ(q{X`i҉724i�|sGpbFLugA@ +dYަ;GJ/n+*R=jAy'!1mdo�/�+KZ;=: `"co!ȡܬT $p{^gnZ^xf=vj̵nҺ�T6A't@ugA@ Vl59>@@AFNa|lXb +.䬰k;7+/YqZsynfXM3WX+\ywF{4 +9=]y]'["Om2DzSԤ} �P erv�TwyVroE{۷q+hTAAdQR'ti0#X6w_ Z-͝﯑{^VT䂂KnVGUAVtmqKg5Ho_$M[$ +vz6>oz>xĥCth ~Իï-19@uWA@gȋYegtXq# tEEPUVu0e:|0E t>�o9bb)جX kւ lt}IqטH??`mpC yq،dnF[Ynfhuav|M13O-jwQXzDu}M  |na3+M5;<MS=��� +mT 9i(P/tAdwdQ=oAmߓn7Uk/e4-MJsp;ŽMH?;>60pr|hG#gD0ZuUqZ37+CPX)VNJM3s}1P$[E][X&uiuڳ’kOg5U#wKJ;|mn: 4X &g*g PPvvy`׮0w[?Ċ ?!OA%*9y4|NE&TAd +N +l<XtٰltoQH ۥ{42b#ũ GaNƎjVNrmI^Q=A 8W$ޭ_鹷J.dv\=*q&d$^s,%mY >)sjf#m۲ve`gsHg>XZi)ǟ1*եdjҮj�qNhh pb3� d#�˖^y}.�2(1/ Dc>r>=zqX5 9 ox55PK̜MZ pvQط[->$xшqkJ3S+EgYM2_WAsDgEwKz0a+8H8f>0I Ԙkd<1 +724iHYh +yo9PW1i6;rI/ H?H+GIJoFLM~ˌUQ]ML*{^vLIQe5El1P$p_ B沢+ݧ{% nXz.iǺ&Dzg(}> .(@kz3?`R%1_!V|; y +LMv/#^KTAEYI 'NO lB w{zٹShd܂K~v)VN[pR"( !ZYke> v:6>3ZGРy'@� І.hG3Y ϑG 8k,+>e罫?M#CBKcMe7rtA@Ўt+� +[D u(rr5 & ACAt*KJ,͗Xp3ۍ3~g)l |?ΖAU|` <Sx'UɄFt A-}9}-M2Hkx&b>: +l!P_R!!{@gs\0*W +rKGA4w.,Y>�ѡ )zMF|CQZ+gOal*$5Y_-m;SChe VLxON +=l 3i<Tq_pfe �]I�X�a${mr!ORE?dz?mBtv`d/<~ Ĩhʉt[Ev +n魢f.;KY.4*i͙~vD7f&mʿw-Z7DI�af@}o vb {@ =Fm `Tpr[~bhonj2;lvF=99IIN%{;$Lfŷ9NyZ*ЩYA.jkaXlzГ2ӎNFSY@4Z5+| KP&�HK~qv 1#bΜt%{@p8$ +z]j;˹ﭴF-x8o u4 ){d&1iƺOdUgR՟^jI5RA%9[;hd}`ʳQmQDO6cҘrl 3i&:^<?~pO?tZA $AQ }OO 3cA_MoaE0C]~bK#, +yšW`�;lw 1*JGNLt$Z,2v^ Ye/TU&95. }jq[^wzkUϰ4˫ĉI{i&m e1vU9nP!�OEIĬ:PE c hG.3[U_sgGk@O˼y =Z/oظf- >Ҩ gfx;[SZfvQEySyX|..WuIjP2gO[A\ŵ֪]{"xONɘ~ܗL{I}f׊ʷ<fPpPJ&@1΃�4Ek[-ӑ@wkazqاU�^.(xէ~/\^ꅀ l@={d'&:z2}fi]Gtź. M#!sgeYPߟxW;گUe-ڢ=2rLƴ#{͆zV6*k3tK}>[2TKSГ> L�P{�a${�/8̽AI�;<?<RR&=/~zf(:Ad +gbG;z g8FONvZ+) +!ڡa\j8hZ&5[#/ٺa ~w{p2{ҘrsRz==p +&Q?@j�t4�(ۿ5{rߓs`PK�m endstream endobj 486 0 obj <</Filter[/FlateDecode]/Length 2204>>stream +HyPC ƣ1֦f-DGb B*8 +RWkYfcW%˱h 66Bh W^"I8|f~㾋 (3&O!:ewisy]V)o9 o<pH#X5;2sTt\|E#O$+HԈ:EyB B)k6Uh0n<eY{i3mƛ}kC&BnOo��^}e[ $qDit{+ͽYn_`٥C:׮{'0oo#!RBˈy,rANtԒܸy qkD nS4wAFr@QF~e)_�˲>>>718hrBЁ.[ ғԈҼrI<WC;N!i:yPrVuDz)`oiKmֽ߸nmX/#?!]G�5m= } W][ kV8:jwʅ?ښ,1h:tNFV)>uRy\] aIwGZ_{010YQϦGu^;kw}F_k{htCMH4}}}¦/K֚ఇ{lӸh?ԪYpW5hF(rGN�Wt=?u+;=\3{I=gXBtaRƌ#W}d)u +gT*e׮뢥WUptQo&~O���:M;]^A.xaR9apUHlY,e#jy,/ge3)5m&ڏ&;L��F8]{0/\ #V2,+ @w`t;:,"O;j407Idؘ|i߸y]-m׻j<5��`z o5g}@@k⫹k^g.SJGyN{2ʅcQśUG +ivS/e x2E.8QtbN!i?S5G{xnQ$S��U@wo Y)?bXkE/;i{~M1Rzde]g)mVo~~NyRKHQ+"xˢt}[l])Kޯ=rOdBw��W=qtb}@@Ӊ( ݠ\Sot +'üGs4y;���toWNS tS HAmC%N#{6 ! eUt~C-- *ֲE|g��ut:ٰK aD2buuQWk^oYy?yvvHInfbR|&��辮*^RTtK A}rbpoی^(J fNJrQF3��uwh-kmY!?drt"|P{9w9٬rܙ/_{Cxj#y ��¼U2Y!?drNVz93!Qœ?at���\p[0]yv2p O*I"1<>y 1҅���\AtZRa !z7mu|W&1���\r#toH:h΀ <2k>5&u^B}`���1/R=׬ 2<zh,=f,���<q=g9ϟ;+ ȯ'=JZ{$z��:f}W@@dq4b^8BX*i#a̖#Y4|��p7ɣ^ԵYXC@^fHyG;UHhͮD_*M1�g`�b endstream endobj 487 0 obj <</Filter[/FlateDecode]/Length 1177>>stream +HOUu%Ig,im/%`k d/Z,oImYs0i".r!$t(*)s\M 9>_=Ruo*y]֯q9*@zT{Hol-Ss[ʼeг<QXdsg\K[&>s�h5U?w>.zVl`S.5UU 9Akr3Uet� ZM};F^>AU. +x=c%{{I� q5w6.*}&0%׆ՙaC,}{̀ � 8=gS?ʕ 4z˿zcߡ,, o[p� Z轫%C{X,`yJۮ߽`f87mc߬r-vk`_z�-VCO&wWD".6kHT}[z[/Tκ_MR~cK��8/+}& 7I$dF &&ժu"^{HfuUou`Oz&�tw*C{wR_3i9ALˣ11rݚx1,<=tße��JYo5&{[SRr[oհ?XZfzg3��N޷zJ~?[?˙>wci\ +x=3?g��FWg?n̔'Vꑞ��8ϥz}+ME N +#2ML~N�#>5&'uUO59}WzV�z=+MF N +#r 'S޶X#��/QzMzǛAG^Qݗ3Wg6��v7vPU_wI,~wV}*6��vuڹLJ[w?BX5gWKn��jޮzJv;'|5Ǟ;i�n{4&n?/.'CY]H7�\:?m )``�_x endstream endobj 488 0 obj <</Filter[/FlateDecode]/Length 915>>stream +HIKa +h*6"9f%u!Ttl(`=y +phPҝI4`P-jz^>/}gq_e qe&1͡=e'g$.5?Y7 +zsGl ��oyҟ׏Or7q{3f2 E}]ڷ��xxUYhr7a&Lо��ĻK&Joztv K5UF}iw�x%=,ޔpa-%~IҾ��īߍkI_n 614RMY5\Ɨ�7ی,7ۍĦ?n-o<��uIKv+)(o+y��bKmim-v3)X}1wc[�@{XqՅ}#Ħ?b$z9|o�@[`1ҋ%;W;Ħ?bgٜri|��笗^LGv;)غ-?X�"=(}x)R~Zm 6[)k �҇New Ħ?b(tԿ�� 7?aGm 6{ Ndyأ�� ގ#w-Ħ?ql{��$鿓572&bSΘU4o+�� EngzۄAl +9M/���uS|+^apΔkpUwõfN��iOJ vۆAl +Y{}?MO��;#Anl_nmQ_/M�`�L endstream endobj 489 0 obj <</Filter[/FlateDecode]/Length 964>>stream +HMLWKB4*jbdѮ$n4&FFpQcld + &&ĠQѡ8ϖʪmZ(v +t}o“c:]];w˫(6n< ?׮*4-w,߳|[ZD˵�|ʖҹ]@`68Xd7��`HפoݞN`6#3JsM} +��ܝ`vkmlG5&㑩^^��JKh7v̦qdκ2ӳw+�Jwo7v̦qdXd<Z~7��xW?0FnѶv[]lGf}T\#k i�w%}Xz[]lG,�Ƙ>vS]lG-;Tb.Ž?&FN��փdc/,Qo+?MQ~Pљe9�M=>"GU~avK]lb xBh�7A/%nK?Mгn|��:3[_nk?Mг8Xd:zQ]�US7g.IfӸ?t}\+?wtv[��xT&tK.`6C_K ��/>%㑩DI`6C2ӳw+�fkS+f4]-tR3�� ]>I[2Ը1>xd~#;Tm3W}-Cڭ�O)Ve~l~tj/cv~F~+s{�乂PjFe x= G^E you�]ҡۉ=I��0 endstream endobj 490 0 obj <</Filter[/FlateDecode]/Length 1176>>stream +H]Lu-\bdskl=@dCB̀ hy#\$4"[&dWV̫WF>!.wlÎaW)ەfr]yOwu 9k3GUFlfӾ8[&R y9XkR��ǨqKUu6ƂiQ68Jʾ[>sSMw>��BG:Tz@w1HDx洡3<SNjJu7�z.O #M<lYDD@k=)qWnۣC�!ݑ9?IB\6>)7L�벺\pתw^u�:?Y?w1Sp;jW=,Q6J~ʶIjmybՀq@>q_zz%kt7ZJ:E�~uIwvP&_7{ erdgﾾsdl 7Zj;b8׾M��%:~Ht774Lͷ8PքDE-GpRLXf6�믱қHí?Yrf.W>sk�J_ʻn2qQWw?v5hx.UiF�җ3<,YiPIw +�`|&Qwp{J0{׷-gt +�`Ǜƥ/ݭq0+<2Kȳ3Ѻ{�0KϮd4n4+9wkpa-�yIG'MG<ݍҸ?a. 3:gLdn�mq0+|ʌa35_��~HGʺt7 `Vӕ �C:'p0+Ü?3:g 1�yH7oU<eҸ?)*<5ukO3�@^H7:}-C?a^)Ƴ�~W&ӥ9YiVՔ3<Sv[�+k endstream endobj 491 0 obj <</Filter[/FlateDecode]/Length 955>>stream +HOuO6lwZ뢶'Y9[5r] r- NLCr{Br Xp] mL:-m|=~e2�gXh_P[fdҶ !=,ߵW1LE�X}3<t.<8)s.&_.7�ڳ8JD͹RBnĦ?ֿ!swߏ${�vU#Й,Al +eJ;zL��kR9«^Ohwr 6aN= a�酰}W){l=\p~\鞺K��z2[ ?Maإ:R)�Y&}ǵ crM'/?�?nBĦ?bpc'jw �`;%=BN?Ħ?tҙ׼wNyL�g&Rloiw 6a-ƹL}>�OXʙ(hz?bSh(7ov'�wofw:6kw 6anWӐs}~/�#w^dQĦ?*s훛v7�3?Onm?MaدƟ٤ݏ��<W wYA0Ħ?h]ȜOG\|~O�#w]yڝ`?Mal nbaiM+�Y }/v 8bSGs<ٙHz_�7-6ǾzSc,)쏍cK}@7�;>_kw 6yݦ۟] �J!}D[ 0�X.g endstream endobj 492 0 obj <</Filter[/FlateDecode]/Length 1060>>stream +HOuOZ^MybXșAd!JVcCHί,㔢ڢ +R\vmNW>_ろ!dfNʞ=+|;3ߛNtj|_��[}Fz9׾)N5n#d=Ԯ5pf$yxw�07 6MO>{f-�hfm>[awb/e�07v{ A~?MaxײWJL*|28*׿�ܤoAl +6v)-o+� oH_ohoCv Ħ?s!DW�I?KO&zot?Ma`ūDxbءL\�^`FzZZf@D5_}k�͜?,)ڷzĦ?pMѾa'z%]o�HK/۫}#Al +7N@i �0fgot?MaF[z*azX1~ܧ}Al +7*^c:δr|�/qm>)CMϙ'rt �/=D~^37 6mY)Ew�dzXWzX=Ħ?p3kL{2H'"~S ow?Lڷ� nN#CP<r1x4?Kqc9Of2�Lzvwo�܅Aܚj۲T@*Ul^@Ӷ%aV[ޏ Ueڷ�l6r[kwiw?܇Aܘ{x@9.v|_}�IJp'qc^U4^%9沴v£#G?w�l"z&qvÝčI:? V>99r66 W_Vϱ?0k߯.H;ѩ?3ͭڷڅ`�0 endstream endobj 493 0 obj <</Filter[/FlateDecode]/Length 1285>>stream +H]L[ew(M¦j ʕ|E`P`deC&|ZF.3a%ɢ1rK'!9'ϓ.hr=H�`-~,Y= �rZIv?#D)F햟Noy;5QW;Oe[9:t\s@ʍdw<:�@ <=φRM$e@6"a:ݪ,gLΥx^~ci>$?F?ZGA|Ǚo�(i*L`xP6$9eU>}e޺yˊMyq~qD �f7^,wW vyDfdmZgL=Nߕե-~0Zmj'䵝Mgfa8e �Fԣm5;޿NFiy.ǟXy;!i{u8_4:;dev�P+BJ9C9SNu4Di<D;{t�q_:{]H?`-.KCmfW:}�ԗ7nRRrw9Z?/-5{\,Uwkiy 3t��5.Ȣl?.R*Wj:j"|֣ޚGwT(�dN arw7`zl.J=0e��JD8onPDKJ<%g]Y}�(ѽkUuԓԗܝ h)z!Il޻ <�ܵM7 R?  +D$K9�P"!/' R? Pb?N_:̷:z2}��Nԃ t7; R? Kd]tW�8-ި>Lm(fP?DK@+7L>C?��?{c&Cw'6` Z +Zԑxq!;,W��6Dԇܝ ڀh) ;iba��,!&]ԃ] ځh),EΖw]YN��];\Q8w` Z +S�??^��Lswe ڃh)L⼳~{�� &BJֹϜ]-{ o� endstream endobj 494 0 obj <</Filter[/FlateDecode]/Length 26329>>stream +Hn_wkrgfe�A(r,D�YZuk;@ڢծ KΜ9s6m;c/9@FH^S`X=׵z_: 7o^߶=;+{|{۟g^|BkocҖޞӏ q1.rJ{ RnemdMS۾y-5dΩN=>,Z{Ysp̟i{,J%ƛ|T l>XSusQ.@f],+ ku,jmϩ�f�Va#}nj"wֈeBtJs|OJڋ= +,Ja_;[�l/urn{b6'Va/x eo{l67޽2 >J}7**V>@Rk+ˡj�3Y /$}*NQ{0ڇGTT0$kllߟnB3R}%oċzHx%,Ae R%3<@qnXa_A< Jz�QKHR(U8f*%gG8 , +\2bTe^Xouj9IQPmy]"lE=DR R#yhv4 6qQgjO!ze8}W7ܥ4y<͢o-5Q8yɝ%ZcʕGJڻlo)6 +JJ"ގ},UbK^voy#yleQzѣ_' ^Rt8A^UgC\s @MYBswm"XC8{*_H>?[גְ̩h (D<*s դZqK*<HO9N]3'F+R8lμՆ4r)ikITeofUef,Wb):-]ȭ2) #7wO1M㸅*D9|Bu~ +|vyncF*"=Bhs% <0Jku);BCb[k<t6>8q(AjH4D;Ijp<"!,Zis47ځ/]^0=T+fף!ѮQ*Qhy܌BvUZxBUѶ>ozZ#! 6A)GA !!+) |)$,ۇ//{uup>WzuۇixNy{&V&_~Ci{?󛻏WHI`sIF+pz'\_).„1/EEke{{Q%3$i!]gQ[7)|'^=$UcL6*R3<bЭ5z͛)['s$qC[mg`YMɦy:  !K+&Jdoq7<0m]2 B6HtbdI[ LȘbJKJmkx L%Y; gZP1E큔)u|K5‰$E&*.x7@[ aҵOűjH?IZ 1 Z+R^V0Wr5?%}mHV.r< I~4I0$#TETˑ M9eʔ h|ԾeĹJ[1{asy{&}BVR΃Ԅc1_6\eΘК6J<{@+G@ % ([FxYpA^eV4w'CWqPz}كo*ʷSkܠ^J3Lf BP$J\6Aje:֧{ BY�f]iO+y9j.1e 4N-loC�C)%#+KlT 5dyqDFT@O]r�{G4t4_:|zbm�d8n1E/6ԫ&j? +fu=2&ØdU.))FمAQF 1r-^]bPmφ*\E5-gP cǍY�OOX`ǣ$E34"fG +FklĨF`P&&(Z?P4 )/ k aUiQАX +DLiеjh(BBƢS"nSU:l0|%[B% m4UJM5FrA< N)VnmB3:V/ЗӗIֳ9`1JP)?g|K'i~j\N/PO] DrDrJdu=iڵSp 0LoJv$2Q=ҌHsGK ϠK+.%z*= []w%G\+rЗ^JMODPٶӀ~Y*FJW?jl_he{hn%hѵ+p!-g 0۾HT: +qҖVMGno!J=-\wʻcﻉ V9d8 "T0]yokfMYOߥli=�y 'p'`Tu~-O¯@k])ȍf<Ra?Ti�7GG77ƿ[0Dth[%;P +φ៪>@ocm0Fqh"]g69V:F +"y׎h^FTrDIPVĬnC?<5I";r!CHv !\Z `;۷(�fg䠩ĐoD *CVnE>N*Hj)D9JjVG辔?џ颻^~Uy"QWhiʫ3`~QHPĹEPv7>t3X1f_ٕdžo֪dHĕZ`)Ffl/eF/dX1SRJ'ͳ!ovt2ѣQ4^HWp]ujA!D<}8v7dwHaW3ߌ@=^ClOy"P T9$&2NHv +Fe?7Q#+D(6h<hUVma;e%Uxo�{2أ+G)n΄8=85i~S&{"5c9dF}rC(t M+ȵ<V3G4"<ЬO>ع9ж`ԺcUbSS̜Ԍ֭Yjy Z=i1Omo~36Tt#J7GԜ[ +m6@aەSS&֓Z[m=X&FVۛ4D-^s7h؁൭b#)8yhI#?2E(C_^ +k!J4i7G68i*S�IrD-xIEEn!lݱA Z}M IiG~P�U-W%ŏv8Ran@ y =Qlԇ.رg3{뿁yWumk7r>Jӝ +B"Ê{8/ 9){4��M~H^� VM~e@c�*%_)&i +5&<&]ݴeSgi`ѬT"o@ @[w)XI-UHs%)5Sj@8D\[vJc˯DztUzh@{5ʓ+(OwE7}-r@*�5'^zB$]'hF(/isfÆ/}DĘѬvz+e}J) &_a<U|2%Uޘ԰�] +&ONz͞E +%%`HpRX5H ѤLZIYVH裕{<"A 4vezqLlQ~iP6T)�N;nJtӡt|ݖg,(m8_W#2M4%;_=QgdupD^Ht%[Z*cy2g#"V}C-CR"E�9 ` ! /vlbys pؖڜ$[FSNM^ +Xث۝{.z_8ԣ.Ȥ[e!f01\Bir o'T4~jNgp <fZ7w Ix ${XМMc~O?Sێp%zD o*DNhc_~g:\<HU\A[- lD!�!`$h+"meVigxMG?×]2I@t4�y@a}BB}5/0>YJj=r]Q<3f3`Ʒּ= ~fz%/W2M17AMDVxөK&.55H߂ U +#f"Q"^1TjnCY.�B*GIUͅs:o_ n5ƪ`W�h9v7P S�: 0.rfbËcQ~cy ȏ,jd]ﲡcgfQۤMSG~GS*)h&- *)=a f7FW>[K~CzF'Zt)g6J@عML{vbrsnq5t~@@zM=n9|uoOA3_֏C͏)Be~uWvEd�tW bM R#<sJ ivwY �(>;R҆Б !'  +' +RSZ#y*+gY$߸(Rb<s=8R=cw/iǷWm԰?TQu; rDJa('pv!&)P5PC<]vvh[s,KVm&Ir@sKF9\�TH4q,L2ǮFV<r 72U,7t r\K.8*YJJUwWW9`< @f1HvP: _$ {V/UʸL|z5,4}.mHGm5.7Ni`R܂ <j3Ԧ}v|F6H4?pStk }?0|k0+ #e cN׸aF}MzGV(%L:=091ʉj b~5f[h`) r9 :ڸߒ\L +bz1"xFlZ9z| +!v{!H=۔UsW{/dIq: eM:G]F!GFd;}$ L\ ir|σ hW<y?|U%E9*rAZLe}ؽEq}&X} u>%BCv91ʴYB✞N@5&@MBG^jw @Y�CYV i#e?Bfk|Km{ԫ^@I=ZoR]eIunԍn+I)lGi̟ 3>.y 3f[a㩤{{ظkr}MuUfVfr2Q%.!I7`qt~)zl;t9/sZ?%LtO}A*R;Yj]K BՇ햫HBӇoiqkV(mŵ%ngmv JJ$wt')=@W)+il>3rWdq+}wd&B=/$q]nIuX"4 d�dD&bNN p3-dQQFߢXHҴe5i7ʵV SIyup5m&O۞uȝ''p^Ma{AF%E1'3xV1U-6"`sy<%PN Z_U/S9L 6yUV_IKm hhX߼O `­jn®OP6Xsojݍr۬wW:z ϑ bq2# [ɔjH"waS n;o|6{?o=40Z0IoV?$rU7Oek>}5'ly6W)ĚVMϭuK%֌'wU[AQjfD|# -LXg=艪P+ߓ4g:veW+Zu +d?W6 +7]7l}__>b�R&fl 3MV/wl sC9 +V܋/*PE6 *I_Qe\L6b|{(-ntO59u?GPKlUH 55PX\[&JD){zɩ-oJǬY +Iةa5vbܺlDvn_ƚ5N7!DlΉ}qsZeQkJYd0:`R>=:a&~;]LEuV@:4bǮݧưܜ޺cDy첕|yE? Q1n= >>#iu]֔DJuwW<yܣ&18T%*S^dݧq.hW/$m'Yr<>:gvǦ]4; Fg|qpH׮BJ;M +W!d>ٸy󹃨R՞Z%7[tI+ 5[[-oanh u +4< io�&w^myI zv{^b<mLn+ e5�VY-{ p`+CD߶jBfAvz +Kni(ӍNl6^ 0@'m+ fJŶ5H"}foS"T Babr&0 r~yIGE%:D1zI&]j&0!oM` ٶMk:5r$;G`؇7 +'SLfB]+`{z|ߺA>PkT5E$K*Hl5?:HVيK +Fmڍ<ӗ)V&x柟[8lj\zHcGSNzьGw5rt)Idm^4qTQce~Q-B@ (߰[}*[8@SD$Di6sLҔ`AI 6[]DN}+ЖjdMa13k߻VZt(sRxD5Rv~ 8}H'YIfiYɐ$8',Ur30Ýp–7^]PQ@�rykШU@h}JŞ7D!Bߛ1$ �QӠسH.@ ^s+M{شsӍC5r7#>$4H4X32[Š{$?ekqD/?{.8 p (qhHQڻ!i8`@SB-(1Y�hVCa}jI^Z +ϪFѕ+:eLj:pdTEqCպ`^ 5:Y{Zާy l�vgD…r)M|]A(5G% &y U:80щ},> "'ws4K\ݾ"WXq]܀ D-x綷,S0�<.ۿ|͹jٍv M7F瓍1Z8)hGgl/F!IGS<w8si_~@z#/p)C%9RH`㰡t*+ A{kx6HsEiGs<g:guN*}mecyjE nZ*B*3c`&j$Hs> ]M(Lt684#45G?+J +sWw +[Ww5Is&L r%%^<kvz$ xmDR+;]u!?|!NjAlX#9(*a$y(Y1S:ШdZ,eע*`Ju[UHzBwD΂RPn` b7ډQ"@yJu(eG`$ru]@b1 +tKn(tߣC4KlEֱL)T75 Bf8ISȢqӯ1Î5x5o 9n@ADubBuN@ U§R"6$Wi3#SG8NZB]+oYL]K,<'\۞bވ-wHnH5m58n&xF_T/$Hv놚6]Plq$#]"vr"th0<ϚXrS-$Hܛ%-hO19̌G5.`īGqvt\ب!ѭ?)͒Vzm(TKQ-%3r5F-wr;Wrs"ьu�=C,U;AqJuO ,oϿ/?7/߿{G_?{ۧ^?>|?>ݻOy߾/}z{G!؎[~o|ӯ>|Q+[c93Vu: 4fDLƠUfI0W[@ J숢etMOD +C'[IEcLh~XJ^+\_;C!DSX$4x40`b;MMFp.5;B8a,ajǘ6\ 7Q[!(aaRnAn$IZ7D +Z0~NcK(jNVmEcBK~,֦UYB+!CHD fI E96HY)&Ԃ3~Qn!?@Q]|\y8la}ӹ< *WH`^jj*yzIwrp="n+(bR"3s B(eWxXTejl~e9Z=٦nFz# &*(0Y٦Ajr[8qdEDBK*p@ЋY:˒*UMJΪV=EVMŀd76e'{YaZ5 5ryHy4KU@M Fj kdR +Y^B >SMj xpuTi^}Ԝ:mDߨQ;>5=?Le7 +GdlCHU4gR*<FX{w"ۜj#:Hܑ&z.[=/vc{PIÒ鲣 3)hUE[P׉\sh U!0{Xhh,F4if$AsG\7bVw`p-t%MO,L2y(yv*12ڻؽi($K#N[|K3íSLs8jsYJpb22jN�jzj"U\L Н=fE Z)dB�BV((wk+ҤRvT(R;N[z +;1v \C+?c|ѵt ́]a^k踦[ +ZY-hxXmc'xD )3 |C-~C >5(p~I61u!>kl~#d0G2Վ6D +4zL}VP1kVٸh;P|A9;jG*6lJ``khL]DzGLĊ~?:ﾐ%r|Qr WW{w3ggay^wurUDtqn D04еђq::޼1LCwbtm xoQ4w)RC+5v)4OVk4?VfxϦ곡n*@yQ#vOh6:/3%w'~+_9] DW=|G&;jl܃ :'uKAe}>$Ƥs7jLa!TuFWKddX#3d(<h-Uڃۅ0_I3 ]2KIVeO6 MjF>2]7ĵWi@#̖JoܓXUs ea#?[Y 9rU=nuFYp緈N*jh%[KߟQ!~bR@5#C~4"x ̣TA1|I9Lq, + �j ,n^zGl%;y3-E,7,U@FFUC�G<@`>A^3OݵyZ- FLī~:�3%SKb~g6C B5@{<#B 0t \Kd\#b`QΥ +hvMS0|:q=Wf.̂o<]gKFddl +hܬ.bct_ z &,Bŀj}宔&PB91.f!UL|<x32!ĵ&+p9mۑ_I.- n +%< kYnۉ+R{g -%⛢Na3 D{�rc! +ρ@}#`4H3Q싋ӥs=>t^:mݦځ0Ge4fB4&:g;4Ji!d*C0$`Zhv0lJ~db4N'8_ Y5Tĸvi,| Bp17?q_P7w,p`1-8d NAzl*ᩧGmt Ya2DZ+smJJʆ.=Dqə.a9:=FNF~b+k-t~Ýƴ;c `RB[^32;t_y?(ED:Pm<vo@{!Hp)zCDA=\i].3 _35E!mka:˘8O"7R󪳰{K>]yjYIe`\' SO~s9vxǯw(!iHGݓ2Is psR^4':^~Kd*}k ۫2b15=2 }N\_ +XhoءYQ +WO=}�OL/{[J"-O\5[ᲃcڟ�?#?}X7N{n?篤K$yJ7ɚa flݯI"݃Y~z8ܐG"{C_wnć]Ne$G)mr?S3" b6usm酴Dwc|.ԦeTS4*]&5SUNuǕ|'PY04S{=iA۶2l/N0 �;b1[#yFkoC|s}"S[5AAMaA"4vdZS%eYeYo \@_(߇]I P׿%U7o直sOky}z_>9cW0[呢N0GQ/e_#H34Z`QlU|#Зn\re‰RMæa4%zd,hTt<!Q843X'ل d׼]P{׻ v76 l~ink؈?l) PPXh߽CA|~L.jc#)!G8L!19M!V3O!7H> fEʟ{[a|,0䁿y_ H7!�@^m²x/ 0VL +--On\2UL  <R.%ڀm 6nˏ``WFdѲ66ӡ{P_b zd.Z [*CN'5 wGd*ˍG�WH35x1sj@߀}Va;7|)9@]YmKsp+ IŸo$'sNCp'Py=@�mKZ +P_)sѬlݤ@@�P��͢C)& CAmVy%rfh;(^ 1Z!;RGI8myDm9P_ܖКJοh |_.ʑy~_P b u?ⱎy]W 1~#7vyI N7 u)<Nz/]ϼs5ta@cpFCNaԆ v5<F<hR7ohPE}8q LzaEǶ]4*]SbN-ntH(}3}`>\Ԉ!7>!8MZf0} ,}d?(}7j7l�@2]D}=Gêr˅W͢ _yRp�n13ܥ$Dݍ^~f1pQ^B#v?.隘u.g?&O #v=5 )b޵wOKG3 [@kV| |'g۬LeG˗.<Kr*zZ?GşLxL]wU(ѱ"8bhoo] W˺а=M +TְC>Ea] [cXe'VZ3#n&7yܥ;|$KIn|BU/S-֔]H.,D*Ԫ�#kL +?yR3&zj$o + e8C�jҔ,Rک>ܣk?Z3i֢pxvdÎN(AzW_~?~?zؿz|ϟ~~×iW_w}wnf ̟htba#MĤ@GPY+5-RBO!X/낧N6\>%`^~"|Oro]'W`c\Go:ɞMI#!Pph5C >|^4YG`ԫyaC,JjrhVfN ih&.?Ԅ$ gZ +pR+P- 5D@̴0ҿjS$%AVpC=�r_!"#"GFUĠέsaɛ{])F#J}{Lg t;ɫqjwW)Ar@#i r +2r&l)c3J(28s|gun�ǭ,;F -y('M "14ܫscj3%ir(*ڥ69s(eϥVJ9.)ŏتqJefK}(1?3B\"EI(1D. +sy A8),Hxw(ًYpy>rԖEO +ZhZüC6WgV?[@ƅ +`e �-n y6{p+MItokaFy[rv2DؚL*}iҪ[To mc^jαI"14}]c'K`XIvr^>rݒ#bKpE)_E8f͓Z)X7OL}wy˓}#Ɍ9"`%^sDVUުI2[4xq6J-mބKxCR3\U DlY5BZYc?NhWW{aZ>is|Qv%s48!ntZ#F,[^hk+(3:=ϒJs{(*N5~ؤ=IqkoSQZ>YL rC7ŷN- yFOjʉQ]mYm-T{9/E {lVɊdЩf k8^Sܑ- 6s4<"Ӷd1z`a@V<*oͦy݅lU|.IW̟@]۶ɤq:DB6DlT=PʪfXMFHL!'wy6@ ]HH|,C]뛎(wiP(fpMrF +tzԞ4z-Lf,Ʒ)6+4&Kq)*A*v8[fE+~b�u_ܹ[fYXEoJsİ:V;//(|CSou)KZ, ;j"wUXKTqB$crw/D_ 0 \iSqkA5R~2!ɢ]H̗iwCb9Lo +۷bV:Ԏ4J@d>iYyxS]Q4?3k_Gy_nϔ3T.}դPuXL5"NsB֖1OR`TG,Ν ,kV۩7cز[MIBc-9S9)580}?)\Q?qe /1BٍO*]Ӹ ή@ I)(q~`(o)6QV''jFm4]OJ ޔ)`SH m)`T�fch +;MѸR^V!'(BS{v|c~B߿{!V+Ijɣ 锥XuR񊫚*(쥈XZېyRgfg5tPwW$̴S625y4 !~8q5C(G-$Z)0Nh,n"ZzG/W5C]Q"]DSƯ'csq7i*Erhe39 +QCTIBbO'LK +$2sUmFRBy,9f}ۧ*\bL9 b9"sv޼t5]ZVCnB: +xl)tH%zZb|˰DuĀDewWIfBKմZ$TVMڟ@cU_p3g6%ގ## +b\%Z܋!]A p HTi:2 ^=0T9{(A}"7v> ǜrv:oM*q+:itWH[dR8ܩ&3f)yv İ)IGE>8>jB3GбԀ1 Ă}WUlgr5S 6015mG_ْ+=<Bl\\"!ؿ,N -UeYh7mѴde׏.-kquPkUWo +_* Z6]?/ j=Y-`J(z뙗.-J!uVKXNj^ճʬqD_śuJ} .Z%8+k + mf~+pqLH[1[R僅6/Khc}ҀR4097SR}U^bCMaUZ~WUٿG-ofU`QLO3E]afdx-$xW\VCFX ňjH,匫8 xqmI;)%5fww|=Fc:\aWG6^IƑ 2߻*$Xa!}⸣=.G|DU1vo; T-hÙ NCBͰ]Y㮻԰<Az^C!ɷH83/4GP` pnClwەwٲ׺h[8ENr !`'͝yΉܾ(3g.d˺R `چڇn-WeU I0pǙnKnLNc.TzIIV6vR_5׆Fc}&!@0g8p*CʁI]*wm>Nl', ɲKy+@ajK#D~V\y%u?"/SWobS޳O( avRfHFq`''sXl \&(kSol7)DhRHp~/g׌U<§%w|=a=%}t)9a/\} dhT�ee#FɚYq ʚlwk`uB_:*t:MlS,‡>QG4r]$<3!(dE l^r4~&BM sVJb% T,ǯ5SΟ蚔U4ϣyzRL(m*JjS9;0AVY~*串eӌ]P7cwzWy*$ڵ]ao:u@.>thNkyRVCIL=LWK !2j'@M*hTi(F%vR!c*ʥDNA}bN$"JG�+V,tOI_=YfkĘ;fZBqPp k{Nf-5#ܱ+q'\Pg^7Dr\K[j_%w(J?MzUE!Lb !yU 7a)h+WF,F m[7@[d~d\t9o=P1n<qCxS{/nkvù18^}Ted>Å osއ1lN][C^4,ou|\>oAin) ; Z?NL̩Sn>r62db(|3OpN +q;yofpJG6�p3V43˜ASAuO<Ay9)Tˀ !8ValmT$+} &4tte-M}$ql'ϘeCWPwG.Ѓ}{H]M58hu_LJ_5?Ǒ�bR=%>5Rvlyo :qW"_Z*<=2.Ӈ|y)jlO/9Tݵ'd3vuŠ7PIA`D54sJ!GlEؽ}P7%Ȕ 2lyo)iFL:s+'|ճVrytд݅pmX?پSU AO{ >gp!o*r==ܬ6 +ѵ.hydgz/ +q6ԖxlY(E5jX笙f+-/B}%XӿM<B7RO<4 blΛ}3`+&x9W�ʝwZ+`QRϣ# [/ b0""6h]'2!N|p -fi͹'Gj ˃NHNkuh~7݀�{o]v@}Ղ@(GEʤRHnEB߳NEۍdRJYő< Ory\:u3 #wxpo}+| +B/{.4o#4m9X~KqZP3]R@…� +rxdIiK][;՗}`%.Y}Kf甿l޼Q|jsݨJL˵>W)i9f[n=wPӴe^Kx0x5<.a{R4@ MSk%|{9A]82I~I[NjCșcVA>[Wv2O?Di1S & EھExNѶښ{+ \EFMSBuЊV92^8`2Yϴ3y&oKWbs1&ɫéwjTt<5rlSגS'<ހ0v D}gyeY\q~s .n5lV�RȼD'3?#M;8_g$_We:9-�nxR}߬ˊZ#bxhl ,665[kQ cDSUZFqgLMcѹQоOTkX5tF=t8"U5UDv7L\]Y>L03Ru(Ka.i>#U'ߊCYr8EC_H4POjLإ/dIG/9 `\ٯ8yX+P8"kC6c<nOUL"R"2T_z"-S\SG=\nŮ%h!y2rB"r.='rDҐ 3Fvf UZK,4*(\ɛL4,lcԘFcW)PRw,͵Tߏ<~^>|z~[o~#{חӗ|zy߾!]zø_]~cMEkSAE=ЩrYaOږg +[ #bދ>OC78LS&XTݐ*V#jI KeQrvh$ȜT#sZ17^-u ]ocXeh&1蜪qHtݒ-ӻ txK}�Vʸ83AUiw +z9$8tS +ք=ec^$۱@Ī&BC95rr ,ixF=FMUnq^4?1;!q0iR%M*j̡5Dg`fHƟOϤ;.?χ"tーXYdb.M6=~$]za +x$@hm6R؈!\~j+F;n6d&"XoT9GuE,rҪa nCjD-sr/EE~j& +{y](~<bUrS{3Zq"F.nXx$F!G5 e}r]ǢNE v[}B/^nQ^^E`NnGn}$FR]CCUJH\zu>OLr_p0{yVћK:L{Evl~V+U(\ n>B) +(T2j8,:0؊"X1�8]_C[1kUV:BoT1B4GY۔Xjlt'Ii5rBw{SF=CW$.RA!ο5ꊸ؂1:qVFaӯ$1| Yo4t̎oT;�A},1t.:fdMw8ބs(K)A47`_4I{CHG3ٍEe} + +ܒKZIu!V`\jc;L_s#i+:,%rjPF-5qnˮal"AQku\{DfPZl)$0@Kj4d ޱ$�R X @hQ"IXYGu}")+\r>LA|8՚}וc(][X֏(PaNcK�"hWRZkVnR[k@ORgk;�)Tq§v̞yFggHPx JDk3wneGՕ)^V OyG4];98%ɴ+q̺JTJ|l#XBzhKQliuGEcH&D +N=;52jܷјKftZo{a%Yř}ps0%W),[Q>Q.),{2j\qe1q: ʞ|aJNpWRaG}HSS3g/w ֎m1 Գzd3g%~]j"kTkgcөnqE.˻ͺ^UlY1Yv3|KL5Φ;mz쾫@z-  rnsQzHs0 +̷kFS�`�Qw{cn") +1=ʎk^Zbw8fD,RԚJ4Jا 05Kl$]aQCMt?uE] bb|45H"7IhO)k2ZU;q1!;*nPFHͅWŞ+lFA?d¾ݯDnff v_⾒&=|4saBE!*́*iv5(=444MD_NKAYMͳIԱ Y&:[P,Am"o% $Hj\ǨRTNWvuM|S}>Bg)_Z<MzLbVe+* hOq9]tOL=,biMڂFpb}^>|z~[%UdWכ__>xzOO_>~_~ǿtz|u]\hm5DAQI+r(v%zY˚c3{HΨM24/CAuӎ]6bקsve& H?6jn\@-FvQ@:h*W(>k7i+/AИ+PAmdbfMycegQ'IFl>YEP$\wPJb(D]$36HrT/QC8Q9e+RbK90XOٺz.=jk{Md(RzOל +noH@M߻l  wCQa^�\U9=ӗsߧ30Y1@tw&A"op:Fل[<% JdRIOk]M+LK4pVțHsq~1l$7+Lbu+cnam{VRDeD/cы+u1Yp�ư,Ԯg,R^S:C_#Y)j(MnQwbŞun 9献I%gەrі>mCa 59Otd9\2krc%">"ڟZ6R`HPo6nCf_J�BpYrQOY{әbjnZr2XX�M4'ENB6"/-㩡 K +P?95\F- s<2bA8*$:(ل U4w$LJ%/mHRm AYh#q}eT TI Dhe$hE .VAYv%5Il�7{KJRa&Fjp /s"`2 Iӧ #C�|(J9-3dmg~[ `^EzƆ,oc2Z7:\ KN ihjJPT w%伇ݮ:RCv5eߠE#|H wId#xqq{$sfodŞ+dzHLѩ墴9".o4CTEm<*)F{9*3藼|7 h]C}a>w5#dIኯB#oh?ҖÛ<`١V1ffxFV"tcX/xcYJ6l{y̕cJ^Bs:X,FsޟDZ<w~o}%cMznd0a kQݚ21l`^iӑjvkl!yuk(k*Z]I R:Ο@5m[N-4Q]U)Pqa8Um"-JHjBL!tBڥ^U[,ĝVզ$HG + ۴g/n(XQT%.LO@7#cdHp-2P? /H^!2H.ڋ)ڊu9RYԤ]lBIWr,p] $)U L`Ia//\{=:]S*B2l9ba{Ab5h<j $BnvIe` ~>I#-7@iR%i9-`Td\PuWV;Ϩ؛l#,.}usXo3t7;vJI.-.ljPF>$:\boڽF UK+#=Z';mbZ?GL7y.qW/Cr4)a3Ϥrq/DFa _->)S�Ӱ?2@7FFA]QUl-n*DgzTK =R\N3=N$tJKHzL'ıJ -D-|$e'!>D"5crw +Q( +gIt 1/u8k +<SlBկ@exy"\24]LL=ĸt8Ig-"q=³-UXĦɉ1:(j;ͽ+8zˆDQέs,P%x q!6q`L%rYPҽ4D#M-�}M'}?zb,Z:GFhI_[*XF{IIlԏ@58[U3|>*&rz%s0K_Z!KRn%-?㛋ǧ\=<_>gͷOW?]|?~7>ݿ?|㍏L7/oO_N_=8_y|plO{%v޼{xM'vۇ/ϏWr:>aӫw.?<]ɷ;NgumWmViဠS$ DGK|L'iQIj�)GqNx3( 砊8Dn!B!rR;-D\5GiԟXl}쟓 P'LɱR%A"*~ڨ,@Q#2f6Ùtr+/eAJ?V-5d,&]1;`).4$,SPj59es68^, {G qP` k]N.Ot>;> dj Y-Q"2LڵhMriιfU>1_*B!W;?ra&P@dW2<䘃c7@T�>47("a*+5!U?jlUa!hN&څ#iLM5:3辕^ IӗWr &ԔNi6ŃseGpadIE*W0[HL%S:0V@EbIWJC8N,mJ0D4j" +ElJ7헓# +tESiU=A.ac�19t2b"LK ./) ?G`HۊWhʹ8 ]Bsp!Ő+ $L^^%LǬǼ+ϊRD׹vxݒ{F?ˍA E# �Y%5=ABXӯe_۝yy{CĖj[J?7ͼ`ZWw([~k D)Y2+DGKʹT֛ȰiUwG\5ߺ;?2-gƍ#q8a.MQ*rSշp݊hUW Gɽ,n$:fZ-$P(r3 a_T8h݄ g;yJTW C':szN.+0̘]SB1fH%滄P}*a9k,r1Ji&a񻼪SyТE:R*f o4u%}k%Wȁj�?⛭ٶTdUm񋣯δ8 iGy>Oߘ7V~Bf wsq\=j(KSm6aحVZ17bh4=cܹW]+^$iskR'4L 5\ q%H`C/Ӹ{~2sC'U:/ ?v +H\q9Ht(L"c Diy7~tTӋ_av!VV.<+=cȈ|iSObM9j:Jv9ϳ̻pBWnZ0α'XLHJMF*!pyakp4R=EpY#S1Id:*�h>@-V&MVs m<7Bm Nu6'NflDYOOdFx,Dm �b,RG䜔UӁIj%0iL B;&_"\jn%kwD6 p5MR30^ɥFԏz6KU1b\L욳yz.W诔~:N> r?z7Tfaa�ö|^ & 2%^]Ŏw +S+WE/]z.yLkܱ8c}<8`D=ϑyn,GS^0=wldGQɖz3Zڶ#B3л(ӡ#©77x4Oǩ O��A endstream endobj 495 0 obj <</Filter[/FlateDecode]/Length 982>>stream +HKwO).G`Fc%ʶ9‹`85Ӆa١bu}~lشHAMr}ȐZYPjraѽNwJ2w,Yu!ˊ֍fx ~-Nb�`鵴;%='}ݹr2ؔrs'a[�^_vH}9Ħ?+;{B=:~��/£K} X؍Al +R܄':Ɲ �HIe{-,ݱr &?X��C+NKIiw+ 6\qiI9xL�q?%=PRN??Ma@CsOpM%w�< -H].?Ma@C~c &gp=�ůϜ tǴ 6-E-g(66͌6�oRMYnlplTKC/bS- F~�駋_NgJzK;?bS;RNbn&�K\`SvgŸĦ?t,wRf;�z2Y_-TuM?Ma+ٷx�{@svGĦ?4g E{Sn?�MzhI>2H?iw$Al +^_X�O?CЩŭU?MakJ.qn];ۙT!�EzGGzHH 6/V$rrڷ�{vO?Ma>;6V}�RU+wv~v ?Ma +P=$fo~U.`B#}>XށBbSך+Lt861͌'�4`Lp,UR}??MaV1gX͢ �L5 endstream endobj 496 0 obj <</Filter[/FlateDecode]/Length 1176>>stream +HMLTWS IkRLC7mE ⸁FJ¢%85 .(31aM76%5ڀu5 UlRPa=;Ώ+Pp`NNM({H9%/&?ީq{ysn)hȈV"/ث 'ND_ubĤ?mrV&kf`[5 +N8`)bRpyr^^~q$_x\< +dMy8sWۤGl?W*ۀGaۼP|:s;]힘m:>i`|]ua=n[ۧҴg�ύ+hp@zDwAL +nU]z#vk5�RFVU,HES? ޻\} 5 .6jM*Z'rYr?Ia̘m%'ZF{w�ZǤ'tw\bR0ErY'H/:wrVAL +& 4p�zsH"شKw7+ &)UV۾?+xM Vk-^MJ?Ia4婦Kb5g �O{MC; HIռu>w +M ݍtwu(=7襣喝 H{t�<=;<rK" Y$#ܙHw HFži[;guK}^x_Gyt�.rKAR1Ɔ߾௹Z;L^p$3m ~rW~{dcTL팠p꽹wnA:"Wm+~ew׺r`5?H*؁\vgoݦߠlkDžcYxZ5n[hhTV jZjsq9s<K}"@uGBdMw{,9 ~h�� endstream endobj 497 0 obj <</Filter[/FlateDecode]/Length 3438>>stream +HkTT/ST,Vj1m@X  oFGތ0̹3SEњ41QijʷMzq"DðZ%g9g{ŭ& yzGr +cb)1$Q4ꈨ0*|;T{Un~-Ϭc>Zhm!XjZ^V_(rZ)A& _1t-݂ c MOp x-\0N^:yZZ?ƒ`Jc#}&\(AST_1Y;Acs_Mڹm4̘6mpM'ASFxOG]{ZHD] c#!m%A O!2:@[b%AB%2@ɠOClmU~ωZ<:D6-Zo2,Qz+cIPt A46^,<RvmgCLf^ErD~!| >AF\]VA8msNl(fEs f=kd코\1w/ +g!$KЧB^3D`8kl{24I.Wb}eU+^G&8[|GsUvw W%ʷ_辻k$6 FJ yٺR}CD~HyֺxhxƯR?=C®튨Y0\Qղu5OM^A餩VAͭ([O%x 7_O6[VEY# h@oߡ}w!d/QG\ALv`RHnvueza{Uτ=L[cLs/ruǎ:Pgku/:*ZkϙUcښ`==,GC-#c?sLF6Kq+ցa=R猄ϭ{ZZOn/[T䝬\Esa?xv9=QK(1+rD }WND3)n{@C A&++<@GХw  W)?6rNO0Tm^r+3p9 4HWGJuut6`%WpC}vN1R򜳓PܬdTrǼX]em*q^t%nJoC7[w6|qw8?0\)dh*߆cȚH7-Ǘ; y.dfEc!7{^((Lz=MJ8o~#r@~.g5[%fE.V0zܪAFJ֮yL ^bjɂ1|�Zߥ|F~ A& ݷt; AÕb<[EN[2Wo=܅�2OH-J\<!|~=C_YEܘXɥJ?/+<劍M荤N#=x >qJ˟[ljΰmǜJ?;u ei<Q}gZ=+ڮOIW`FF+IBe|{5)VlhL } 3Õb<&ڱJGJMIžگay#}Gjh J {$fsY(+X_ ΖM10]fkPK?cWE)E>jڽ5G_tH ^/ }W" w)U=}wtMa;  W +gG(OCk:*a? +(E=]#=ֶf|o$ϥ6YT\\j+w8pTwvNj,\LjhL0</^G:_Rljt%R?fN5q@O_}NZ⬠ppc[& {&[֮!?/*}&R*V9 VN2?4a8ýl<j]-3+ +3Y@-Fg+]Box7}D ߷!Dtz]E5y qqf`R8Xx]jIFs'|܅305EQč^REY$WxmK aU#Nqb%}$̗?Ԝa7?a`VҦq@I:in-1d5O+]5G_2gQ޴C +Eu G~BkA?TrZ HZ)[ W8HȠHo/dfEc!7u9_!J/o~ēw=P,q*J̊\6+gZ^AW(w~UϭPOU *M`h|'| DKSaǏVAE)E쮐Xv--R͊5m saykN'nΎCe~L6!q};Ϟ>99ϗgc5DlhʀyR\MejQ 32¬ў-^ :kWr0Qkq\/=NIB|.$䮮bnhkn])|S@.EBH瞿7\$/ޥs nT~9'нb/>3 +N*x0hay2-`#"Rཊ%0̭uu%]u)Ӛۥ+kh}^IҞn].R@06# +ܴjPn +ZS>Ԟ k +4uƍpp ː") Iʦb}δ^qmК'4 cM<sޞ<EF[BܰCoDVrwU~^vC ߕNf}`sx~N{`; ÷1hĪfiCg샚d#zqѫj{ۑ$ .EC(=Wx:i!,>NAr3?Z]ОtCI%i:.iԨEϤ:\t^Ei| >SHQc \ ͍K}xbt17!NZhs+ob08b)"?01/�35 endstream endobj 498 0 obj <</Filter[/FlateDecode]/Length 3424>>stream +H{PTƏw[jmNhm15*VD)^ "" +,ee嶰,]8{E`.bLQxtƩ?{%3w9}ys`.Ţ[.>ZްB �OV %ҝG_QP<:F=YA<Ϭ-IY`rx"{G95ԗX(A<ϐPS Ⱦnav:?kG@\n`MD_ֽI;?(?\&oa YÉ+J=<uO A AO1 vYꖳׄX8g{x=} B-PS aP nq6~e!Ao9}Sek  +5Yi59!u"A<m.~ʡ;jc9P#?(?#{X߹KDe){dTRo9{Iiak=&o1-a uzF]Q{ + +5ڂ?9(jFs5-nKwn͂"{<)ecDmqؤP`\mgi4By,lxs${HOJ;d8zF]˼B͐PSy7[?<|=Y=zFӘMY$u.;lW֑︦nQ۶Z:uODoNJamoRiZG`T0XY2\7{ )9w"k{MIa+ǡ^Q%s-u/DoGP{~ ;PS#`RbęC8Jqss^h=йZÎQ^_Uy#mE'?^پӺ[ۥF|ѲAQ3̛>íXS1y~s_>࿫Z\)c6ӳ^.jczxGu^ecqe{ +\Uڐ^JwR60z&d?G<s- Z[B8M<7{_n5™%AtE!MPS^w%>xh +Cڦ n۩]M9ahܥ9Tdܴ>s7?s+X66VdO�;Uy4:r=?qGMCiԆW 2{4O[j>3>yBk4PyE"40YS쩩犼j?Zn2 +kk/]}oym}>,c FsM;·yK.S,XY02<s\i\Gv<o.ֵԛw#"Ĵ$ '"_nNg^ߏuDoG`T0͚-UV4CK>^\�ݭ/l[kʤ܈y .XuυhlCCwwwr?)y{yr[ƒ}\ܽqNR@^CMٹ󬣂:|:sHrDrH\wyE +\UG{?V5 e1ųM-N@i2@]jJ{ xPSSo;CڙO(@*Q;qFa#LɟqT$H$9 ?y脅%+9sX??w49 <Sz[B:ﰭn\)ו05Z۔{GNF~6'ͺX8ex`]Z;QG%  +5`yݼM(\uscnېRopD]: QKߐ[Z8z~~̀α10(<7*,Qx<< ƒH-;uZm;yߑa7Q·0{ǔyxBegWI8]S){^'Zdzֺ>4?`K<Z/2l+kQPPw4>y G`T0/Z&\uUt/_WXwK@r\`7zw INfPԌ=Ka v7wy0Y]T7}w%#}0{tw><2Q*GiܕxjQ;uV&Ë#3)&ƺA|mhlu)~63CYA!A7xߡu5ܸNmb-T75#ݮklgσVf׿VWPz_d^oyOs +kcf\C9k9ඝ ֵoLS1עGϵ?l+{J uz{K;ֵOÐPSqT$@*vmv#=ȽW,;4d&q$G&WKSQARzB%1$|"k 3KVZ0jf͜Un8w?%+"Oչ&M΁9A U:9~Iw#NË~d%G{QϕZks2|7X{zm΀3,s+DUN[do>f(~Gx~gޜX +?XM2+&zs3)�=m UvEFd$ suYK(vפ䝐d >EN0M+`Лs~{xnF&U?4CA}�+?J$N:&Gp>iO@O;wЍ-Ӿ6yf; }}s=#_rrxs˜_;fKospp,?XM:aCZ&:őjvi̾A߃q}4~,I^qq͚Uj~~ho:tNdzۥM>c|fk.;@oll +h{ ~IWѱ8'C~z yVlM$C yM1X&·_%իJS!סm՚<g75B*vMeU-Q<�_<4GQ��"/ endstream endobj 499 0 obj <</Filter[/FlateDecode]/Length 1932>>stream +H{PTe?$=-mj&3Rr0)2G(Ǯt0@l!A \0@&W쁳ܲXEYC(XiFh7Eo9yf~3;vϻgG#56}wN5څ9<ceyJW`\oyEV]S^)viclN/,"|6rn8s f^e呄7=ڇ-[wH,BJOq]|T|R޸_gւ%6i-6Wk1ZA~˲;nm\{ Uݘ FB. JO M7[5uMd(oEҤ8\e@{N#UK9<`.0re*!dx0Pz=QsN!b0}/J]SN_!&V1CB'9GnH|L#af9εex;1y*{f~eU\̃$\<A>!R7ߥYz];?,ڽLL.=B_ʝGM5$\:?(=}sˊ"f51>e\<~WW<ʼy=sK'1b n]PV +jv׮v*&|Pz&r\m.B3F9?(=cq)R.q'\/_w0ENMUB?s xO3Ey?(=c2%)KڵZçlo|_ ɞ!B`$B %S*ͭxi~;7Qmd% |? ~ɞBa$B*Y?Ӻ-US olE?5̸2J>n矬_ڶd!DA77'/+B&ŁC{P+-Kz}=w8VF {!-x5"uYz\s7c3=XXK}rĦdw  seחe57_w9xG3~/~ﲽ'6sΚz +v?"\hceYa/ONiOګmy=?!mH#7f. _;VLW}~4>_>++cBAyKʠ?^/x\x7mjM'3KD~=?Kk&>чw=#bKNX]S g9z`ƆC_cЗGS67VSWED\ yAc +p|CjʤZgQ>85>џ7&E +oXZ4xحO<:99S }@?Z4廵~FwB|fdS3=ל>Đk֒Ok,+pƁgGA'sƮV k!<[lW_s.-ϼD~Nԃ5NԋQ?~/z<0P.OcZhpȐks#mj2_x\\xbKNԶ%T5+wsVVm*Z~ד7^uĄ8?Xu~#L1p^<句Q~6뮻\+zdw31_ڄp- +Y&a+PՍYNjsn~W|}p?9p 3;:qn?|tԃ3d$}f;σ;&M~OcZhpȐks#mjݹsv};rCɨw�1 endstream endobj 500 0 obj <</Filter[/FlateDecode]/Length 2546>>stream +H엉STW/7dE H@"j)h%Zf0Q% в5AdRVbqye�RvU߻/ZB57y񷺆/ }cL^_̇u~6꫹% u@1>Lr8QAf>āTj}Zba񄍛EVz;JOfsc````````'oC[>!=⢠yEQIK1\?//փċȧak100000000>> 5V�YSw&rt +$mU  80}+|W0^m˱0</*4 /]oɫ*, 1;   qpEIog[;кJ׹ (AAAAAAAAAiSi1ŭNibLB戻@@,1Țr}c|{@TsÂAv=wdx +sU;l]22K6G jٳj&^h55vLCVյ}:Q|J6sq1?B})&0Ӻ/3ٶi3MEWAY[n((/==8Aܰ^3flm*ϟ@Os[(</ޥ_JMiWյfZ|ix4B"{ +O[-Ǝ1)E$i鯎 +z[ކs25v.@OL<P/擇;uj阉~oi<nzaΆMG&<q#ֳ{ %'mz|=kC"ƵX}-Q9 ; n||l-W-_AWWPc_1Q-cعP5opQ3.L2Z'ڼVdX]#BmIqӳ^ /}8#!uVu|6"IBDe; Le; 7ׯZMhxwL5<"&ÓKm_12S&B&1Z4Vj1WƓ&أ,ds_{pȫvumW%2_ {YS<΁'$$`)9vB'j\bxH1uznume} +y KEfadEpG[@Wb@P[[ +!>8D٣.d~XY)HK{(ޑ8h'Vk9UVlNξC#;F|<<1%&(MiU̖ Duv_NAm|NQhdxvjua}sc74ڣ.d~|)OOmJA8=D"Չ|aAdԤ{og[%;k_7dRy/dߡx8X\#˫wQ<rrYS6QcĕP+֖n~mp{gQ2?L?,Vk%Ep(^tX15cK||'sb]ϽYϨs 8UQn;#-1 GYWIʹmEn=c&%<ƈ+Ah>9Vj1콖5e!t#ן͟ڃF^]cĨ{l*!~ew;98DAzE jZѐ~Syx)acI�Y=QÃEYӓv[ގ>#(5F\ڒ␻=k'S!Xoʐ`:0/ښVuR` +"HOGQit)ǙYB87Gcرٶi3Sx"(hzE xvRdRL#-p}{%gZMy{ֆ|8-Q̹lqiȬ65^sPc*G>E 4l5vl|==;b@P5cm'+Ws l3.LSQ/@fU.57^iYr1J(ɰ%Ep_q8ޥ!s02/zCu0X s/"#Fݣ:_|%(H1Wvw(l[>fϗY) 7,Ǝ $֖K'OC{wP4BRuLh;'%*rr.*40^xoɫ*, 16i}scVDⓗA5 c{{540hbj|a;)MwY0׌A2U.^21ompaεQ)v ЛL/乨crx焾ќǜ?_1W'oM;nn>.RLz;*{xt@`y�r endstream endobj 501 0 obj <</Filter[/FlateDecode]/Length 172>>stream +H=A�i&qU58 +w&*UJ&:'ZPj$.pp�$_OGNfW?:-gNh2jzoMjmk��������������������������������������������������������������� endstream endobj 502 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 503 0 obj <</Filter[/FlateDecode]/Length 284>>stream +HAj0DA +,</y[ >�������������������������������������gXi̘}D +^0x缏Y[K}_2UVw˂lwx'7ql[\~ēSXcÛ?9#lO+vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}pb샻6 f{`�<5 endstream endobj 504 0 obj <</Filter[/FlateDecode]/Length 519>>stream +HJAE~' Q;eN"6^EcgF\X9&5qsLbk1c[7$&nIl}3<>uYEc38=>uYEl,EL*bb-5qsLbk.to?~qh. š7$&nIlMؚ9&5qsLPkThspNk}d9#1M^wvYMiHko3}d 9~ڽ*}'a}dd5pFGFFL9:"25rtDdjC,\Y:4su<fixƜ :;44tv4hhhѠ ;3uw,jgXݱcQ;ux$lfHᑰ#a3cGf68qp+sV.ílQӣ#GGOl1ȍc 7&oAnL#G@'FNl='x`�C endstream endobj 505 0 obj <</Filter[/FlateDecode]/Length 25368>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-ּ|^3/ښ~徻^m9V&c1jn2lcsŵzr{L6;՚CdqkE͛Lަ{Z{/\d}~-{hɾ׊{ ߑf Yw!1;'wɰG9m!%=/Yr) g)Hq,҈بUɒe6IeZB1;Sw'q} r&Y*ȴjکK9iߺܦV[u|~%N?~߫;8wZEq+)RQJF{ڼ2I +Oc} 3ԥkռiQ +('a'd@חͨ4I1urw|5&7gq\݇|ciUz exs�&yCԸ)lږpN*F04#v0|!ՇTލh:fCHb-LYaļ~p]xM?IG{6{/ēcpU]o;eq۬t"Z$ T+u(<5{|$&m"i�"}{?T}I5PƉEjl PX~N`w|jeIYl/#L7J&{43فWliCO􏷿o_~?}]􁺂 +ח>|W?~~q]oq}X8jŦ؆Sm{EH.գ-#5=QhwjэVzM`FEwqȜ7iV2NXu֨9NM0KT53>BImu";b\iq,6&s+)|:ˊZxCtcpl'ׇ> Ϊ/}!3ΈD) )5xP8b4k};"@9O2uB-g( -OT2 ra�4TT "c +q znBq>2ZH1 UWOp~ "NW[ o�Tc *`Ek d L=7 yAc 1+G =|Gr?* V]Ǯ1E PT1Va7t!.&-Sƅ„x/5/?MYefw JM-2v%{:;/sÚȒş�rt +*+ . `${>a8;yH̭6yp1B9㗂~CH{#[km4{%<%dE]~f }�*]HB>rWZPLxȾ=U�]@,"n)"+=I-T* \n3,e)M`Ɋ*J='h":2kfw' z">Gfq8r1FU&,3XCZOL4SB<zX^$qV 目ׅe +�Rɓ r*qKErnlHC-+-k'!7OT7zeW?OTzkt]AN'NqyF IUjV#4aXVSɰXW 4RqP,LM %M"4+'SFEE.N^RbS&h=SKJ؁!t |BA/3\Zwuaeiq:-oȩ: 1 "Ek>pzD|Aj vElA/4^ގ(CUR@{@k 5 +<M:Rg#X0hzjYI |Ήe*Qz,"ߓ;;/&p w%SOAWШ塶xS/Vy0RY?ds!1[ɒMo9p 24pm)S<HovLKB-ύ1pxd)BQ;dǛz s>G9. �,C(u5c|`[e`W㤓kUx\SP45ENz +0⹊!*ңTjGk#liȭ/Cb.:;;njH_*5+t9z`k%T= M.)s^n U`ĩ]8^x$~HA-"2 0xԚX_4U,% ?XS3Nv1KäR.}-FC2X/Jv/Fĉ!C/9'Bx>ĩ:$R(nO~8^]R#Pg-#xd#X+o^OpnbH2T;H8U?:nҺ=(rfq1'rEeagW*]^dPL\l|�7tFbN<]6oN-3et�E`fldid1zyxH'zhBG~zS"°l'[MNKkRMJ5:$ ==8TFGLzB^* bU.$lBxy΢OT!6Ĭ˻jٞ<lE]w'=YדeUAbߚ,;3R*třEqrȺy]FOJ=lݗ�s' +x7DZTVA_|)SU%6 �D^7\3PPB}vNQ۪|4ꧮR[B,e.aW2�awdmT5A:E~.ea? 'M|]$* TzjDp-x'xWGSQy-+)n(&e}ıi}ӹZdQL2D=?3xHQfԮ5y&bk:rYpҠW,_N]o}yΝA*Vx<r]e]MW&%X~WaWLU12JV�yݺ}eߚ-}_k޾-nrf+ҝGmk6JL ) }P^UҸtl4@?]1[`h:i{AٓZZɎ~Աv@*>:nwE=|*<,h`.'aU5^I̅,~:¬KǞjʚHXheA(Cs70"D:m.\ݺzۈ>Zʥn~®mHΞŖh(r]gqƌ|ڑV,T\n7UVvb<xOLcA(qXgs|uS-4*=]�Ths>nF󴥂R1؍$#+2"*5jg CUөo9hW-`*GڨiUJ@W+^v;&LR&9u5YxtNԊ޺eE|,�[LJyP?V"va_^Zn]Go6-PɢzPV; Im^T9B|Fܾae-g*,úƤX@d +yfA2~tSt9!_$M9og_~I}>?yc4Ԏ3@&Dq+X5ٞ-"#jPH_R �sj +J6UzJ9X$s�5+Uf4FƊRa�I +[kڶG|iKnP,:]D2%Gw.6qm8*50G R ӟoaᏩ뿪߿~ 5CK^$R߾I%(#awȷ}nB';X#U ibϐ=E؂L[޻+~h4I^L~$QBpC[Ug&W(A-I%+@cP4'nͪA'V\5qlj '.<1 :23$cY7;Րm.faGFAon/wj +YGp 6ïg322bJQ _kB7KdgAJN%K ;(WƼFp'%I-}D<8X[.cҦt`Ҿ̐ mk{ +(>`>pxwsSxZpɽ#,LO=!H.FQ, r:Os.<)1c HeJ ΔF}p>p q %V2tRݰDЅ<DHqU!a= ^�9;sI?\^X6:U)`g6]<]M\2#K %ID=jє3iS ?BWnIe+a Ú ܧx(]_*&H`PÃ"kRM)N x+KX}#7 L0~-{tv2舟T@M /Rul<?$qZRR.`ia 6DƎ:tifƪ525S{U{=$1u[JC1j֝\}*n:tA_pBҰ(.X!KSM3)_U(VTo[If@ ZS/JWjHz +ngbX"wjX7U +L y6m^U3 %#(.& +>Vnq֞fj|:w-YyKƒJ1I(ڝZrf߬B摽H?`\$J|GҼOÁ`:qL lu1*"-ULr5mRzWW\M᷒Z薷R +U%Xm.*45(UtW5 K6V2Feg\n+1koLu>ꈭ7WϠ֥/ ܟMm`jmmar꺂;C<h1Fbb"4/tu +Q1�8׮UkXM}>qj[CT&"ٞm }kFeH+)] <+)tY:ex/ !]V8u +T1&E 4b֖|ΓS봥C#wX8y(d2°mWW#EQ_O+QW}𲓍3in7v +#K |64Ş=^wm?53x1q-*(f;ݸBUc䶠z{&Ym匑t]Jd OYx+ ^8hO'wgLJoY]=|7oooqO"uOoM_3~{'_<]W~xsSx~7n_= ͷ_=Iwzz|~חwW?}nW7m}xdzKE<s~իWWoHt8=j0p1nN1¾4 yh ШWZ#J_,g %Yt|T0%CO#k9թ5K[`{XBC(ZMM㘑,WU*4=D~/TQ6x}@uB\cwYmvjcM294]ɏɲ;)@ʢ9Y:/íI_o>Kgmf-D$z>={yw{If#~dLaRRr-˭ҪO"e\WNcATW֧J2` #3!4/xr2,<� Ne٩ ǖ /8eI C6s0l玬q +dL35J)d"ےw, c.5Tٔ$FlRnT sM?Oi]H}rXl&C&tɺ:ђ: ;*`Vw?ThR+gB"P:MeFd|>R\+q&%PB7W:r +SKkQX]eWli*ޣY[Ko�Pz +=NjS4 +5|pf ^ �# %dߎS9#r.-Ǔ)(9HUEb\'G`Qf^yǒ!{ǚ`Φ̃í@ox2Еߕ歋l~no`j�M\BVwd@̼~Hse֑+S@]tdMu0aEԞ˷&,s7iEWq?uA,x+ش$cfQVeV!EH[.H8ܮ|Hk :xWr*9pn=% AD 9dN*ܦ'qJPQK>$ 05"0Ij?mEZ+yv̈lds NeH)42f^*]?a<:*mYh!giч9QFU!KDmv 77cQ%Ts彌[Z-~fD!wza2fvhͅ5*yf[̣CҼ\Sε -;y !d]3!NsR\^TuY8J3Ux1KU/EtqorBU\ˌ㲓l95l4K+3�4Y,XRb|7h]Q_LsL&-|Ӑi0Z3k AנpݸTK{kP + *hs7a_(ш4jYǒ q~@DPc�݁wP^x_]}u' W:~d#0.(M]S0lʣ%cbu*{6Na\%ll7.ŸJ\~RN"ѸI|- 225%KpCk:L"S೔iJS`4*]sX=3>!0WB : ZĴ |7eIo:?-x eȳe ]bnSYM9鞔ZIL9,*x.=o0ҡ:BdHԵcݡXI_'<UG_YAbp"{e|{Fʇ@ruvzUWTezyu5Ta2Z}݌Z=S穡Jk'ku.em<q :\C (G)M.46ˤb +t}b| +,֭0ugn%Y]o-q[(|~@\9)8]\ݸo4U٢/n)Qcm2r?KΨdԋSjb"lk4,ԁjKlAED A/u> {X&ӈZK%/ +^r_W,}sUUEQ8m|^ �{6wPtXA*wVIyָ}&]wkhuT-|3e[3aw f�9f̷1&"(}N_KSzd#VV$}.$I<ѓĕ`; ϊB^'47X$dY-&-'ȝ" +d6e;v_U +;ed)OCP=jEtV =KGsTj?hP WpK<?ٯި%Wf}(+`be䘋l1x’ybE]]]eWfI`* \5؈Y&)׵8ZɘPHeIj|‰Ӧs8{JE,d=)iDvs*"@5Lm6/x_;?tpnqɠ`5,J`[e +"O<1Te=zI�G5 +~÷%3"E?ۗ7n7OOG4ן.wΧuv>};==\wz3?n7G}Aհ'y;t~{:=o.wǧ{43U}/i1Ȍq?%%�D\ Epg)Dg,y&2&)_c^0EER1^)&PʬYZKdgզ)س@Psv$ݼ$'+j!=+7AHT +S,6}riS:RAkbR=A08WjyP`)j-+e~jqa6\AiX]葴+B9)#I`:#le1-.T34cWRx4* 5 # ]JX| ܣ +  Y~Ţ\Lz43EdȮ8jjK)I^55PX-!<"2+Kk +J@Ay7Z$Jo2& +.!q^�mq+ce͐SjSn }N]ͮ2r@AC;) jŠy/*@:WFwFVD/) ߓuQqH차%J DCMndDL@/ĂxZ">ȘQ,Y^Jȃ0[gUAiE@k#)i)U[PW0P/BA!ָm 5 +^i+4Zzj�4<%Jv/BC4P'+TaL301t3 Mj#Jor%^Ʀb( g7PIށA_/V]&B$o ,~{Z +i!ӗB( +f+: W=W݂VuOۮYӓb K^� :C~8�-K3%&D(La/ګ#Knlr8QUQ=\c_2 +f/jd̚Aw+f,ꔋ\p^&шX [h´h4eJc 0O_)o,1f:\,仱Gd_JգXF,IAI +\~SJgr*v{$ +.]U e /#R2E"r(D5�d[5X&<![ńw<H`B ݰ@r7֧p![ Llum pԔGUUYvmϽBVA +c0zH +!ab,0hdU�+\Jj? 2貵N6cQ/6B6ŭ\!KJ5LW A@Jl)X;VJ)c_'*H`KrJ0s q|"r5xi~}9Q;!ðXa>:N&BIgL�].7st׶39i|6mX!R4[gŁ,ᗠ +MVl$>z&Mbkt3-Q(gPsFyvPӅW;N(Uk+98hBr�dO<cFH3M7Ҳ47uSS_A{8 tX #]BCOo906y<�IGXGDHV̐'Oʒ<8h�⏻Rkpt=l 54ҌL.8odx%èûf +J!Ŵ 1 pa-PUB}3APhRp=}l]lq !S^c|T $lf~bKMm:iMب^Vqޖ/Jsurl7qߊ`$!1(5.,#RG^⩯+ H|:#K+<YmqB47J)ƻcuT5D5ZCW5"»PUf�H!k81{K�ce4谼3W,E<+p2Nerxl! vK1aF0C(@$2A#ġ%{zۗ7n7OOG0ן.wΧuv>};==\wz3?n7G}ROGy;t~{:Eo.wǧ{0f .l +,<f#*#hrOP.)T&0hMM/<X!F21m1!!1 4tOq^4\_PT#q҉ H,u#k*9q9*A'9q=hB@Q/^C8Jnǐ84'42PK@R]CVFe""t^.ɖ޸^A>@ԻjS9쎫Qݓ$. `^ѡ"'Йu;<en~ HA )4ÓH2Gx YWNVgҤyiRjDO:as i:#"Ko̅>r Yqeq_r&ĢNAYӣ֋%Nu*DrC.N +ZZC_Z|| 5ki_g`Vjӭe ad?$(u’FF%_=% (gZ<[9I*oV9wukT(=0r:ؖ{\PQ:lTKHp0k$ʃuV~/ȡ>-yNwN9)"ސ@z[wO+3-Po& 6jtn QS8I>v}jGIڳ3o:?�Yʕ%,!d5&}[ZMօ[0Qb]XMizD9ce:%z<8Ta c@}긋nQ7fv yq8}Η�k=ֺS6omeڃ@J[/tfŚVRXWKRD?L Ӷ[UuNU8oَ cj`W<ُxz(Œ+X2:u7dYu=Mӱ3\/wH}eZUF2\QL}v]0Rr뒇JoYf.\hL~ `BaB^J\5npg]5{1WdoBJY6?OI_ۮef3{oh}m P:#Vl遆c:TiS+sNO!qrJ͚J?M=dn.r .Odic6UOt\]E]7biDZu8a\6*rX3Ŕw D]7Xi +TG},%sUyjcT OJ&$sٻKYPWDY8*YAuJNo+=͏U{Fb~QHtjV2~:*W ӘFKx֗r!kg~h+/vHc5}>ʆ: ]=_Ϥ@+y'>K"F' J4(npbX3YŨ,w!T?nEZXN2Nok'9%B^$=Vc:ujraA%[sF=(S%WE/�5o9 40F9o[t):}/vyY衺)?Ĩw6Oz[ p%~ 0;I_uO&^wSǯh6gO*4-P|Um5e<OWٿ6)8h.5vX?>^CХz(,ZLBy;F)7!Gh&<V9QR =@D|Y0`Z#/`M } +|x)HpL9l jW_]@?F%HoƩo_zN=$բ2 +G=` ku_GoQ OF 6*߰D|[^Z1r~< I̐:@Ȫx0>OZܝD +&�[Z9r[ 橩# +x˻hR!,7�;XȰUg4YAERbF-}vb +ẟhF쓳t菉xBFVzeGk(qZ6cadr{ 34B 8+grhŽz:<>2sW=3T5TKUG=a} YpO#,[o)T;h"`{kIzf'&9NCl١CAdx A +.Xkv~?ڬE^7Ipz52 0H +RE$,$@u*.b#/0tD&`PFˀĸ5L p,v.՘;�tبRNFN]'вNYua!< N>}qn#Ų<ݯƖsQNVu6[9=1碐Ni|ϺUw?|5eoAH?{NΓ. sKQ^eW<sn:\a.뷇MV= +! }@crr+RGͷ)./4cz]Dux":>s}ݥM~W)Ǭq/R_HWJW[=s;C# =欏Sp!i2lmnlZRJ·X%ӅMJ¯3Ȓ1_wY4F-tX~ ĉ,_a8(nO,ʢڻF#| f�׆3ViqZ6 Nn>Ʈ{|�[>, D_sDjgKƛ \!k4f˾ГdnB6Co$ ctO3$n*)~~TC)ݥV n_y +qr7tǁhC'0 9 ȕw�掮ȟ$sN( vǍ�8�%%$ B[@y?� ]/rS=�tn]1Pƀanx_oR &HMKAtPx\2/2QG.n]Y1-*,)8,U[2NuA˛ 4II&kD"e,$*"+c;pY 49* +l!"$Zm2}XOO§y83y)v>> = yj٩!!"I6d<w" @+͙7P tyIviG{V`.Ot}|+#'_Ru)c*2Rf7,w%`cQC MXظr&Ra/s'vo3W bġ lM[}e窓R>G[D3,A_|euY^I\!|$ Orl-}6' Suo4-[E]1H0k' Ț_$fג}t''M~'pl"VF=:L׏Kswy~s3[Y+Powroo==0Aٛl#05 g fj)"se(de(F�v6pvyvȠANg&Xn"mfbf"Ӓ(DHsU1 +dx94$ɦ`S2>xz*A$0HA+Yjh Ƅb$9Y^Y4/Ϳ[ _]/fBqk^]sO*=qI,ϊsG3t cLZY$Z`�ى\{ +!)J)g3GsEΩ*w#q{" \ld]i%^AX;[F~+,5-+$"*tm`hқ,7!ٍ7f {id$F@,IK7/)31r.= ڙ뚫0H2&f7 M9 +p6 NN{ B &$ܻ4 Zx* D ƌbN{x>@ a-#OZ]J +΂M@!#Heފ@|ҀNQ^VJu $GH+DVfJ8jN!t 9K<\I"Bw?ҐiםN_ +Ay;2Pe>Dn?3\p*FaC<v~J T7;| P(DJ|xsbN2w ٨Hdn<?5Uҥ8[?EF>Y՗ZH"0νHk5sPgرO2Q<5e3zK㏇cҝ{X9olUpK2|3\ː/-Z҆Ե,GRh}A*@xM,@@Hk'YGْP�Ґ@4gø$A.wbx)լuKR5>u [h ~B3wb@iC(SNPxslJ>l{$|!hw\;a<2/rL|.ʁBZ_ᥩ:խIu[9ke̓\>1p$lĠ ( +G"C+Y+3zf 25a0L5仦((4w#+!Qk9O&R uxv.g6SC<VF4Tz?&}{~obgnm_c`*kǎ\H${reHȄ!l^'J\Y f$ҕbf0Ud_.rqKnC9o*v_t1= VuloE6+f7'q9Gֹ_I#1VHߞLK$%VG3t +ƪgYTJnMHF>%bd}&Řq'[Ɗ_+i~mw嚞 gd2l,;S6ыS٬O(~w^^Yq%ĘwsuɵUE3xaң-d)^]YTu׬z|ϒΓXyi]6*bDEЃq yn&G1=,&+L#Ek( q{|N{WD>"msbƥl$C 8DjDZLF ߄<%.tWN4M7B[Dkk?ȃ%<,#v&p^I SQZ]*d%KHJNʝuKp|~VEY/@< xne +ZY<p2zGkf`~| , +I4LӒ}]Td,[XݗPl_:z^7 &<pe2p2P5$xty $qbI#~<<&>g~: 92*g/;!4{UqT4Ϊl\R׻[-Y%WIn%5c>1(&W|5s˭�d_yʍd?5.s\M5kSy:Z5ʸɵϲrJ Iz L$42qøMԏ 2"::KZ`7xQշĺ]Jhx6BmP^O%H p=:>iuw:xK<(*g,,~wo0L L ҥC{Ln]P i%#25 +>F">ъv\uKeV~ 3_MEGLة{cEAHg=KbXBl�Y R J1ϓv3X<`UnNO(DuaZ-GI8>9dT�5.fBO}].G\l_l;#5</F5Ba-<lӮ +}:YlbHOt{ Ҷ7w$1vT +� Ef Lآ&�k%lh!{CүDN|6NKL>j3 nBF{O!N> +%ʦNQY{JΜlVNu) ,}+ތ=֙+&C.no YSR +ϯή` +ex̀&2!"~YJ <&hiz 9L2p.y/H;|Bؐ4w #ږϚg_cU +UD˔y*l 1 RB=%83XLLSVnz*0J0 +4x&w]g*"QT:?B&ș(y-4b2H?@`<t/Տ\J%"qHd2î;eIaxW$!p(KB(tBr8eK_�>N!>A +eZWaU-}_�6( +}v 0v74lSXRhǜd '2϶%FZKduWD^вZ%XU=OrI񍊊qS[`.:N: |lz fF�0RR l&1kAXM?/XkIG�΃qA'�Ly鋫Z0Jvc]ShC=uhhS-M-P!xx_/Қ oB|Ш YQhئ^֋P;}P5CN{wV9EB:Wmp(^(' #wt~?%=q!oXgyI-( ov_S Șvm +Vj@2<'DCg475 ;f83`l ~fr?Ac.Ms Z;ΩbPr %�Lm] 6 zN"Rp:\Xy :DA};�7$ 4>Je*јh1̵c:zL6cqm7 .X877١LltQ7@UY2�^g`>j$ H)^:E~n dY4#*.mATc @`<#<qWgt8C`7x"j䉅rk:y!XnѾ32(ll5HzާuH4&|yrslpDGL:ZE:bs0}b>Q˨c#5 d NFXFuRTL1i'S`8}R=;%!Y +QFYKb7EXTuJ(θURO#gYO;kX]6UIX%A-ZfbgcC5P6ͣ!G J`l`Tl)ەUуk(?F2 C@!eڢxq Hn0fmY>WPrĆfxY?q؂H,I3Aq*t(A@xDo) FTndF"J+[j!׵{ F~v6ʠ�8'şywo{_?cL=vx?wo/?}|Z8<۟^ | |W+yQ}ˏ_?|υ9i(0䁼bmѴi`ӭCQD�m@4&"!9%mygg8-u_ABߥAHSD]vG~H {RrBf.dU$6(eX9iG`544h%/@Sk4TԢ+ݳG؈ =xH"Q6Mt(\eCg'2!P[s[~ 3W1n wziӮHbmp`4*bϭoI$'EG[P_lҦgfWZ5[,tF&p8q]<fH,Y -t9Ry 9 T"D@!˞~>YiHY)>,G'NҨ2NuZ]9[,\YE--{/N] B.ZgF(~1ꎞ$V;kc:"ԛ6ROV-m샘"2~T&rKyk|wE5c=KH1CQeF\Ro{ǵk7;YX1Gz l9֚'='%ms@K^fjQ!`1 +NrnQNV +ԁR.p_@0DŽxf%fL4fmQltnIx"P|c oZ/7AEYIq5]vg`?$HDŽb &HtXvI�Lte)T8$GW)ۡ)�Ƒ>L]\3ɸg|Aza 5IWj`XgA6?0|‚9H1*,VRbNn0M p*ΙJ$ 4/Q!f-E)"bv[)1+}9X7d\yC<ko5>I45ViguK>¸PpVP`כ?uiц{[#;{TG,߉.g!eDx6ΛX;�֐ӥ{F>WvXrbx +rjbAb dcS}E!y}y7 v�O>4 }p?ƸB;iK!7kF* +o諱yjJuUpEzY+n(+._@$f*Y9VPUjх!-nOylGC3{s&fn3 WX57cgp f@@q}K0SVH>r+A2L vB)t|๧3Nz6V7[) +*3"Z &;:ύ +W*:OI/dβ‰m{|ft`_sQٸ?je&n/rgLPɒvFko3\+ +UXZMTR9]u奈q@cUf 38rCyH)%fQ Y33uÀw|V ;T@a6 r ;P_[{<)*r"0TS7+I&".t5sۦ8Ć'4:]&$*Г4e+iϲ=}CQEK3B-sPkBmAyk4;8M=>=\-ϰi.1Kkp}Z~@7t咡�+�AY8bALyW_A8% 0v|GqS4�?JY=(O};aUp;ݜؑ^2|v`lTd JJ9\6%@!ecZK14gJ&ܽ"0Ye᳑nhS;0פG:'>􅹺90* 9@ng阖:q؋2Qv@Xc(ne.-'7d9}}X|TwLaAzkSaJ 6�lnkx >UPLxkԟ1ND-e +_,YjMXYb7hң7oh#px�[w9U +Ň[q c +N7j )d87П~c{jk0Erm6ļ}ޤܙ-97öJ8@0)Z$Tq/H"(j}Ib$ ]),[#"+y#˾ u^5N XE?޷gm +{Dm3u,o:iOȪWx6qTAàx"`}G&~T)oYZw +."Tm]!sB!(-RXJNcドS#ovcuy*)ٺc[oYzhZZq1 :+>9jՏ!R;?876I]*7!>*G+#An-"O=diq%{t=ofȢst[Q:X ֳyĻj6al:ӣUHz9%Ԫ(/7@APyٯ腻,c"!*-e�cw0zpg>ZxfhVA*5fEazrԛ u'WUt-T<NJi#6M!401F(GY&m(2׎z\5b}}t0?q/O˟) ⊊s5 e6~_x.'}AGTtL  o D,q䱞;DVדZj ӑعZl<h;tq5^HV^pw,Lju!Q3L¥ϻs|Ig+ Ȓ]uݎKEԄ!`B;ф1=7u[5vyޘ#cáb^ȕljZExY]Q ReUт%TU8.r8A޾ߔ`".:8xyeݒ6|1Tw:եZj5u8T 8*M"c8/ȝ4ZuVp)##tJOQ`s [(XyYq&0RSjGcn 3z;ؚ}QϮS6T)+Fkӑ +ʐj(,N lg0NCw<SlPWpwmlOTs̸hSUiEQQlDLTUH!9QqBE9U9cMoS P_daVZee +@u +:8i(37O3�OҊ+6㐐iU>)mO>-.EA+5k&]R4KE"cvmB|=/==]D&晛ФYT ⏘N]v,.m`{@%2}^(W#KqԖ}< JQ*C2cķJ5˺jƲY9<<hRvܮ)%di;s9lK#B&V+-W@h+E,r;f]jHC# J1fn>~DʀE7j_Tk&HLg4銏lqmGN~@3N9KQ(5R)>*|�Z%8Mk 3֕%FYa*fnwI5djaiT 978g6Cz\@'w 0fU3Z'<f 4P}r&C/ü0R&%׭tY[!*bRƑ@o^�rE՝|yJFlկCKH �aF}& ]FKUkZk"`pqPN!TB(,D<UY)"IJ><Rg7c٦Ö( uR+6 _A4-d\dpi%qMG,@[E_ICus$4+/՝U*x:=L+j#~M>~Cdv_DhM-I#pZ\lGFO:ծ@Wof.( yDzA@g$@X:OhF{2 +d1V="Y*DHS@v 3ː nQF%)uNR1#G9%wC@QӋse#Tk2,[H% SǶ=WOzҭ2"U6a#܋ W圫]BMMZ ʄƯRsxLS|nIA[+ji pO# +jfpty83[V"M$ӄDts)ʐ:J$C<zc!Uͅ6p"k*6e՜IR ƍRi׽\_|�N}16S瑞Ij +؆NTuU5Fau]rC2:E bf<<F<Ĝ~?>}vwۋw?zHkԿ~tzϟ]^ }O|{}`<%"ѐUj�yR~b<Wwիˋn]Yۛ⛛~~}}|OO?W^wWa~?}Ww7oo^~Sݾ~Mnc#}# '?m:eg__xj/OW:^bh)!2/e(5ځT4"?XoI1V3z-.lJ@$%p`mE$doaQe%gAC*% !'٣�xGH@'Tj4hۤt:mK +T"?9:\P129gQd{+kz}f:WROQTr,ă*?%C.6bd,%1PO6f;ɡ8[L-Oy9|p+Jl.1rSpWn&޴.gpZkj�||k/sKhcsYY3#lx`6Gn vse'F9{OZp.I龝4B7&!gA8<8H#Q,L>DKXad='Fm#ud +_ӟH=BK~㎚`F*HYҢ4{Fu6&ZxR"0pjԕެK,VV `eI ezlR'eś.i<<0Qyc#RIf6z^MNs7~RE22j#F-@k4``19LO 4+->V:[!rr]i5?!̕lEJӬ!2 ʱ5Y#@S賾rs3eRci"}:LUk)>rHP]~:tɒ覡!9& ~.uO8H/E$˚m _NCjx0U AARܑJs2)(PBwl\5*l_G0D;<i{j=[fH5<4Y;,ñdqI_qTׄLXuDa(j8[e}{i2EJZ9S[叙I(@sF<v9꜊UZRqtG%Q)yfn1W@PRhoz-?gJv[?hn -= vAT�o矓Gܗ˞^̴옊8I�E6=f+7֘qܷInrKfK1B9 oZ2x&UOp ^^Dg{"nVȥ=]8YY]75Ԕ7VWv틋]Of +sp m{#` Zҕ 8'0�x(O\Jb2K90Pdro=\xx*,l}}S62XzdWht$u.сv +$S3*K?]j~at܁#xKߋ:+ OL qljio�-aD*j6|Ḯ`6çZq�`dٛ52dFf3=ViD<fp*W/L<Z}=j.(".̑Hzz`d_Gms +[ЖMKтcmFvu�CbGۇ+`C=zVH ޣZ{$DW?ZԔv,%vGT>\O 0�6 endstream endobj 506 0 obj <</Filter[/FlateDecode]/Length 671>>stream +Hn0)`#mIJ$y'>~|dusgzV?�,~^h]QUHЪ"5^3!A 25KCB:ۑ=Sue/k}dhU_uhQٻwjvVo> ѢgG!%ZS;KUg>,IHњG58%E+ޔCs6ђ& +PBhImըkQc-j&/G`lP9y=EGh{mOOz 7'\:,(H}xkoMO8&`�LR'5qK& niGS^: RDUsI*c.Yz%R5萠YҾ.բڥZ S%쌰a6L3W:qTeyi8MU#ڟצ Tmyq:NBǩzBG4{A:^С<<Ot,/OsC\ L U8Tb]O|nW~ B\ʯ[B\#!Q5}">U߇#!RAsלYNtnW=ZN 'b9éJMuyD,gyNIty M2u#o8ҩ˼<v.#�)K endstream endobj 507 0 obj <</Filter[/FlateDecode]/Length 739>>stream +HAr0�CQL74CHH- |V>,&hy\z&&hY\{&'i]se,ua񽊅GIZ?m$eaD㚵 ],*~\ ݗ,+:L{|VYVG2Mo tײ`ڒeaqim +YXܛxƴ!bdiyl'}Q&M6jBXY^o ^軖%6\o]Do@Yqj&z3_rb -Н[xzh1fNe +(ok=vj?֚&x[S[6sS?6wnU3rYV~ބܦOֆf`\9ՖȩbNn\m 辯Ֆˬ}=sхUz2B]FVQ* +=w]XE. (OUi9,ﾏ×}wGՏ{}]|;࿓REU$ _NTG~=(SS9* +8Qc҅UnÎG%˪8JUq@VQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQVG�!3( endstream endobj 508 0 obj <</Filter[/FlateDecode]/Length 593>>stream +HAJCQQ"D"SHdɥ7K~忡 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +KVRz,*h/ 3{!>A% }\~d#<ͭϝ'rC8pw+7UM!8c}F?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:#קs=߫��3 endstream endobj 509 0 obj <</Filter[/FlateDecode]/Length 635>>stream +HAJQQ/ڎXHCH )>G`6l+Jz0U% +<KuWXægx]Iwpg\x|θ>Da}¦r>B|z9q*ڰKٹT `BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +8]KmWXær]�-:!�<KuWZjk8N%FR-#wpg\xy|z=>AVx/uߘcθKeA*t1z0Usу +{LUc`BS:=йT=F*t1zԻ��aty endstream endobj 510 0 obj <</Filter[/FlateDecode]/Length 726>>stream +Hn@DQ'+9e{ڪ{bGC1OC(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B7NE@\N|R,)%6ll=^!�+cޏ~x~O:Jz1j~p<WҋQƼ�1yJ}MM[~H$ 5=b϶5_xj�g?m>.e6}iO5NNwkM&?_xg.Ȕ0w6ŗn~ 1+~{~j|7ُ)0IrOM~@5cOuHMݏ _~sYc/ǛG\OWƬw4|],u:r~ta~h>~[倮+CynmQk𭐣 v Y$I$I$I$I$I$Iz/�^+ endstream endobj 511 0 obj <</Filter[/FlateDecode]/Length 359>>stream +Hn0�D$h+k9 :HС4x{mp'me������������������G+M϶7-$ܵ&'*4v[6¸~sЛN'U-i+{twuʪgl5<.ͧ&lQWӋ7a9O>/a7y(<~1*pc}OY bIIi㐏e��������������������������������������������`�i"V~ endstream endobj 512 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 513 0 obj <</Filter[/FlateDecode]/Length 222>>stream +HαJBa�nQs=AsQcP+H(A(44k49\}�����������������������������������������������������:?= nf6X?G߃c6��-ŋ7_oF>~(sOG͗z��8?n]��d[rN'FQG?�!U endstream endobj 514 0 obj <</Filter[/FlateDecode]/Length 629>>stream +HkaZ;S8FIlNL +N,,S9e"17Kh` 'p;<JmP;Xϯ|zu]U2�xo}vhlUשɹϯǿ߿W_UYY��yW~;=jll {@K��1;wq/5M֗i��@dޏ< {Em^";uX>k%ia^ sá3a\a ΪRB/[DDDD0A^.M4?> 5q<-DEEeusZyQe-3S֬\U^/qwo`yq9~jټF^=vuw7g_h=w0xh}ktOӠS4?AE1WΞ]q姙ӯ +o;:wG?,~juAs:|iPqJ?dr?eiPqRg1��f^#&� kD?�yg�|3 �o5b�ͼFL3�@׈~�71���� endstream endobj 515 0 obj <</Filter[/FlateDecode]/Length 411>>stream +H?Ka񃶉$({-9 ifJc5876zH8$޷,ovuW_3�@޼׈=�{H{~ҟz +��WDR[��LIy�eH{.~#C��p n0z��")CV|z��g")ysX{8&��N"9{ϵ֏o;Ro�  �i5��y^^# +�7A$� oH�@�"��yDҨ?foI0 �4ٙg_kjJ �䋗(GΓ^=M �B5s}m}ksg;`�*[ݡ endstream endobj 516 0 obj <</Filter[/FlateDecode]/Length 12691>>stream +H]CAQΦ2!P"(Ha<!b}U}E&ٻNWu]Vc9`yV,m% ֶ'yi`XnVc!̊Έ2u>@`[n%TaVݾmZCNLI-ek,RbS:l.&g<0~|VbO4q"j[jr.(cJuMqk1{u@Q\ZZǺ.r(t]rB\5i+b)JNFJcReey'2s=vX{w=E-6BTdssrr 8kr0z^97TW. +,Czp_8kr#shٝ->\MglK3VZuبY Q7@գelF +oD@V¨U+2ߍI J +$ TN7)QO]7n Q2uL:& +ޏ *RRSr snSY}aai@0>Q'  +ꡐ'W,q<d,'ek4XmB@x6)V)&w(} 1Wy P�X.->bk*FI8 pb4D?0`Em6rChJ k&艣„F9G�njh� +h=%:`-~MMS DB1N-�jD?}x[hqh +PX95h�]=')A*g'f9{,N53.&rYADXxiQ1 lrcj Ө^=. +f"2p�6A)MM;8: +/B&P-,|)P +رUkm(WN );o�.Q79�$4'uh;uhΨWhXe,ZܑĦ;ilǠT@M]3.0ʓnuJ{ߔ6,YPD:swڈ+]HsYB\TxĀIi(+4}PZ]%fO+1Gp˅s)Tqd8[:h"StlCC4e 5@ҨwS7XPBiX`&$Ǵ).ə2C=?RbCȅaڹ f჆F8� RFO;s;ax@eҘiQ6bcM5:BwC+F͔(_ -bEKн>%IJŽ$u:N){/o{֋\F::"5SDi{\F|#(͖s9Vib\5Q\YߊMҊjI67Lg'=ZS+Of^ǵ&g:_ifQҝ 4N>txr8audQ0S(<TK>|OWe(8#+ ch'"/ AFDVG m<f vvKM%:wDF^N0Q`e|c\Nu1-Ik-@VaKYM>Ͻ`*8haMEJߕܖfYnJ 2a t46J`iM~=[%;jsɰZӭ=3n-Ǟ2D +ɇ벮4+>O^0wlfj5eU!PM?\@�r>M^;Ia^s!x>]�ۦ/߸&o?W<}#>:<yp|y_GoN듧߱ +1X7}C50ɋNEo;>/NO^^뿜_كӟ_xvŻ'oשz͡'?:߼s><o.x3<y#_?˫O}q<yqy~t:=_]6|d=>oٽYx3O#w?Z:/�S Q{j_~x{+wSS]'شxvxQ~#fnXx0|К+7z{n[7z{.n8ֲۭ=||puvW|W{l>||p[kwg?xzjջݕP!vmnX)6v㝥4<lFMGj Gp#Y_T_ >~? |QSo'M_%D-"KAUKA0\n4AYI=݈sV;H#֋.WJ.a5X +T*A e3vZ[%L%qy#wiV'w;-bq4p^5G:0G!:%f5o3U-bN%C#cزՊ(j<j7$*i�GRٗGxu2n/KTqtUDk(>[-HnYg;Iɤm)8GmὗK_V4}E J0eY ']+HBKp7G bt}1O d @.Y )ADA'[~[v.5E B3A* {~Wbj"pf䫫ARF)A5 o792c �sD0HFe?Zsi<Um o;FN~[!9-C .~״QֵPu]̔kmUzHm}2< {3BSsLsp3(yW+zKj{PbjɞiL]G%HUʟM=Kwfnk!|V+<H~_??¯VAw6�WLm ufE2Z| Geu0[sm.INL۔ci&cؐqzsxM lbaPDE=𡳡6 p8@>0a t +B#56(HA2S_78ȕj-ڐr\N6+w0OŵR6Ө{\#TvpL: +Vt~@`\9(2U(='-kwƖROه5OxcZ`5ꦏRi,%U+NNz@%r8ZwT]7[IHpfv#|c޸? *#g4\tܳt\B/Dۊ|a0U#L:4Qy:,Ϫ=MayZAzo~8$fB$RH4'}A\w3hh +mg FTWy|F,z(BIf JV /,h g.:cZƒ97'+F}C_N>>*}5aW"eD*ԒTt~/~D1-Lh�:TtBʲ1"ŏb1z4H~ zJ̉}{ +ƕ&{D4];_:$Vf +XHJ,X?..^=s@I\Xڛoʹ?Qv$~ݴg(m- UI�$}|K>0 +6[& \.- +;_ΎAF!>0 \L'Ij§R'yB"?fsc+|I杚 q_ +g1t<'VVRTs[Y&w!#'J"?f&˺S ?N((*5hOHn $ZR#u#QP^ &k{ + +vdB>\ 6s ]19`�w"63"M멦Jc5/xClAuo5<j?%^?}+G /^J#4Z BPQb, JP +HL(F]B[�ZmwAizԘ_\ ۚVHm=OVGQ%G +*R[{=ɶKUAފG2/k=IuFf�N.d*8ڻYK'&0-sw0"4pbXrsѮǫ绦'&9Z8 Y�AV Hyܶ^oPN-Tr  1<}r}?MpV%%B "[>l3rAWM۠f@(w m 1,|wm+75l Ʋ~ edYsCt;-k @3ݶ4)M"%hq[aӝ/$W47Xq-E{ ̜N~6k׆9|gmfh3Ļe?:0V-Yk.ԓʞN: =hl,Y t 㶆KnPNvBQu ,JV0vөS}1K7sl8{5[/k�I9 J\$ grPptI⅘8|Uт"qwfP!e{%$PWH>Caxg+XcFUmi>+ȋd/lЊ0,W%ȣnCe}@(=ekUhy@!Ĩ\U|UC3n[m>P +uN]sRgIr3L_p%q['^!hu喵Ys+JVGQ%6&:mȅPrAX0wD:Qm-_9.HJ89!A?7S}dBBH& h-**Sy>D??X&}J]:ήPu|uOKEOK)8#8W +Q99_&}F=v+Q*> K6BQ|yu/?ei$M dBviC~jVI0M\ )W3{E0ڎq�pg6u܉4mԑtcct"TZ5Jl҉2Slny`{ LzQʸӘ_Gƿk g`O쥟/ tJz|xo~Oo?z+x;^z`ka<pQ8 {jBakuՄ`=GgDeKJCՔf6ät+,瀓Mٹ yP +AhD!kbjr. +I%]jrUX6fg !aأaP${dM-Z,sMGbw5С4wmҫ[ ԷL<[is$s:Q? P|,֌(_CS7_CyF+.o@ҭ"Ǯs=Slj1I•!85MLMn6JPy5kuʰbĐ01Hf.sާyE| e]IP†~{nm+ta ~VTCʪm ڇ7B9]z"I@K>:M Rny2YHyhGaZWU -:SwoW,,YSƆt-@U4:֡ЎsUEZαXU&G;F>B{ Sti`i3ŝO|@EPB5ۄYF>'BcƀkB{ `ZڌR$لA*6: +O?R6Cr vHKV)Wb!8Y"dC4"�&}M8,uqM4{q dk믜S|΄GX:yY+)S869&gEN̙t)\>'r?bTcG*fxayT:rVÖ-gi2l5'etLZ7y@׭\tvzV$mpvU.X^7tV8II~UvJe} <BՃlzΏ)jhߡ@c!T[; J1uJFS5QguPüzFѾ_[zO6|AYMi}J)㊬?a?r rWZ\XC^9UHQdY_!IapCмD1)>)7 ^vL7|@ϙw$~") O|?']zisz- +J8D ^DPա*馒]we16Hw6pKfujf:SSs^*|HӚVkYw֑)Դmc_ +phF"6>+ ;8! B2$^3Јek]WJddLl*RAGT3A=#nEWP-03AUŠ"׭e. vZ IYut^1U֪ \`@: +o+irW֫o5Nc:îʊhX"XiQSӗ�De&wjI{A )5iL$rfŴp: nzCs a-rE"o! <a ՗Ltm0iɐyY&ay"i,H`u<;ղRfhHKױe@Hں7W8iZ<P2 d֭"5)Q( YLǺ:a*畯~C}7 cni^Є陯 úT=OKu֮%sQԮԫ;05!h:?qacl$O}F<UMz?7Lޜ=̭Yp%˸]V�LR +Ci~# 4F0(Sݸ-grꆜNy, ͳY~shG &cc PhF0s&] +ɶ܏؀%FਹlUlˉq| IVrNnѩL:׌/Sy5i\uZ d6!'ݮpzYfZ}ez 和^!\fПSAa9ke +lQvRg/}\7T=M}=A;BPm,mAPA]9/Uxv/&cawcbe#Ѽ>=ҕKol(nJNA',Gbi04(mkQ#Og}'T#_c];Ti+͎d*r;[>E}Aov98ܹlx!4>Q^SE}f7{1~'"4=>ojV+.bGTtFz|.4V?p+Mx^^Y +Y<LDH]4P_"ДJ<Q ʱfwjAq]Ҷf:RkUw#6K. j.`JjcBfuC!FVd]ɚ>Siײ^X&C]`"`[,H΂9cvajq!.Hwи0a!hE:ґALou:`>WH2SHvj_ eLkAOky/qNY3Eġ/^`#MZGk}BR j]Ӥ1.4#G +G�="YMZ4(.qRVh8gv:nK�_uv(C@.߇^3MlI!g3Cr\l?!]I*nRLʒm_RvE*-9j\1! Gwsr"Ώ0@+F~LU r/UK,tW2_9.IV1Pl)tWfAdz&8 R*DWrK,Е5ṇZlz%ZV#w LzN#gw/�ǴI֖u�FhnIXuUn1iEtG8V^t"gGu"NEI&ޙjGT;^9v9Htwty2x ɶ|\GdX_8վC�T@.{xu/vnqJU>JZTؕ"3HBRX +:qULa)'N[:!s"vu*#U]I% 1Ha]i)> r1뮄cz@#eɺB�y7ҒAG He.f_Jh�& +:h~T$OBn7 +K v9)s345A!ȝcl7 X"%kuZͺa 5Ǩ-6!'XMMDJKnKS`uQK|]w.@TLT~ ԓ9T*Bs_Ț5?!.,MJ9m6'd+JjY+ [PĝZ(x/)PkJe 5 +n�Էzg{[ N +<L-gqҰg뱐( r+Cȭ /[#sLRgH&({lй| ,{9�$k$2F ++=Jq33_YLp^at]b;ECI* Q3cQ `Or.v Β8ĸesmtHH #�*\U�l-/WKq` dEHfSmx3F$JEŋlF 8GIhG9g. 5C_A>L!PkK7 լnP& w}68>96jr +3iu�ߗϭ8zlh3ɍHh!5Zf.>H +.C&lMPOSiT D@+MLc]mV$I͙tɄ&(1dт +Ǣz}6'ǵz +R1|t-lJGCLMB&6TB$H{$2YH=bAlWϴaFh АF%cJƂJ47n|oXQ]<%ְd p+wxv.~|swvy{C8'4O6Ao[F%s^hvWTG1Q#瑑5;FAΈv_e;BW7QPqc;TrGj-3(rB'&#L$TC+*l4{h1 <u8mZC({)mAV?h&M!v 69Ɣy}GC&H &nMCb@taOˏyvCFd! P2) DKb (4|̺kx`LL+xLQykV#0[dB{X0tn+|);TTcݕ#XD 5 i#u�~]|fJ,d` q7)ȍF2(są�yh9 ~G(qY(rMLL'66ep$ס}Ed _ +5GGdu# ?( eR +;[EͻQުcXyE񸑓 h艾['&Xˎyꌭ+[F[ !;3capCjӳ[;Vd Xlk+`PVyI|xdP |2S*u#V5=pBڰ#*zj.QM'Rv +]'#%FXs5HH5 9m745 +d^]h*c]~C:| 8Z!&_<?D⳾}(|~ǿ-,9k髾7.Ӗö֣No>5ETy}E|q:/y.7OQEe΁�2oMT9c!{jHOcyJj)ST86,lxI}:ÖMS /\n9ژjd #Ò?+4zeʜVz{^L 3bq[m½ae:و4^)C GHYSt'~ZӕYTQOCeE+ƶ`s .URBYÖzv"Z1O-^b~:#-pw{>a#K3E8]i -xm |"8zmo&fۙ,d9ʵ#..TTdȳhe J7/V~Z=D+iHpΆ+]贰t5/=>^|" \b/?|y;ݽ; )D-B;)C]wx˟`g_?<x~~vuywz緷W'7g/.Z_Yn/|ۻSw'нxr뗷W;<>zDp}qk|ӫo_g˶m~J6Cf!Pl؅l'ߑcʑXq+ 8(FL <%r~A%klfϑ|(L_xXH~cN-:wEs0˫{+DWdf,LT(:#LՀ<Bh/J.%yNN{T^MfY2!'je{J^t<9O)pS;Gy@R2dǙ RmF$pY@7gܤIte?;:A{(2N35Y>E'hܷF^XG#oe?dYᲀgp|} +eOօEYXlu!x<]ހ*d61r@>MU:"b@V HQ*ٹ: W5<͚MF`_.DVYo?Q|J< +LR8Sf5n3ǓI: Ng70zo`:{Nwy5;8]}^3ࠗOI.'a! +x>Z8Y$-,&0Vfyg"X+^p}=\8+UG;ߔ`泯KG"5hunn , |b?w=0;W\sf*j ;Ṕ˃7i\,'I\ͽAE `rQt/{n2-]u#tz<p%Q?euYEȽ`)6k't#ڹGc_Hot{A +6J2y]N:VDF6e�@~ i]_|74. +g׳ZG,9-.bv͵9-+ fOlO2]2" L/[%8)�ku�l9isNqslqxz#zݥ@5P*�6p9a l6[G&lMƍsM +Z19n\6a)Z3 +}qǪ 6Hj!�66:Q`Cul lo>ה溒kZUjD#&%aX0 b)֔2q!Eu52nK#!Gv18W%*"zE5mR6V=eD5J=O`&n`1.B9^;k�=˪)uL9#:XN5/Us 9[wf)x_XS`Ϊ[X*d<,im_αRƌ,sD!:B=kXε;%+.DlAS{PVZShŅݞW"W@^5UJeL5ͤT;Er[Ybc#lD5qe5T/-mBS(%TZ5Z\Sȵ\SF>ش1،%IQ+J\fkȵkM&\sLFL]^kхj]ոTܴO.ecE\;1 nJ2jJ%T5Zwfk͸tҩk֨@ + qk]5r ]9Zz9]`S:c@ۀ騃`؈"غ 6GlMƕѺ}Xř,Զ[u+��An endstream endobj 517 0 obj <</Filter[/FlateDecode]/Length 539>>stream +H׿KaF5xR[ 5xܬv B BEU0$<ϡ%ɿ!-;w3|Q�thRU5{o/�J $T�_!g ]۹QYqs_�@AHh}u˭K-M|��AX={"�� �l-5B��$}P��ɦFǎlJ9ӕܩ;J11<w.9C9cs<)qd$wMɑgP4?fNo;=cx5[\|&{r!r!iͱ0?F��ϾFH3�@y�H6!1��f_#$� kd>ٜ՟_y�H6ip`_g��}4(NO>ɨ�^5Se{סÑ�n5sǪ�[�D + endstream endobj 518 0 obj <</Filter[/FlateDecode]/Length 771>>stream +HKSq�T7M,D/*讗 + +^^dyQ!B*yNI|rnǽy6˭ V);:]y~xy~ǏOy2M,X>gGb~vy��l5d*9E:]Eg��F_CXγ6>c���d72Q]Uu까|oWxrwAk}ݾ>yW8/_1���.ٿ6w24'OY>}rx} ���idrC\k@<&7cu[bX]���bx#bf|+Mm?3��#{{}Sfwb2���doIFWc +Vcy���zN>Vbf��@Zw+GR|{ ��xP}+{V|h9W��4dOc*;-{̎��ʲru?`^׶Jٙ��� D=@jEB1wMB|Uo ���BFϚR=2]=1Cٙ��� D%ciXq#JB ���B$kS+_W0;��@N}L2ט+13=M6u\���\${iG"��BC.ˊXq>8+FcRߛ K� endstream endobj 519 0 obj <</Filter[/FlateDecode]/Length 735>>stream +HKq)- -R"%Zl1Q"O;umN 6S սN3jl#a]އ4 ��֋Ktnqs1=}FY?߱w-=?n˾ ��@gok;l?n-D:c]O��qWJXw~ٷ��(t}@ Qjo9֎˾ ��@G.m?ēxΖٷ��dg>& +6?ZkGm���:pP66@@Ec,:*uw>��@+b&H݌{P}���:y81qfoX]��褼|b5y(V'^xR3��Ii5+^ ޕ}��N +sW^.D��pFG^*|-o��V M>X[d��tL/-^'ZH-l��tP̙RMF@%o^po��Ё]e*k1)g��(mo EPYT{25}'��ʞNOuQ4y,-d ��2gy1&*5̽\//��_ �; endstream endobj 520 0 obj <</Filter[/FlateDecode]/Length 1292>>stream +HkLu8eU´T"fPS񖵹6W^ؠ� p98p.&M]R6{fq9g-ygmRF[Py4x25r6~Yw#n" g,h{VMNU ��gXޢ@& />V��ti鳋=yl]If(z7QX<?3#B��QAVf䭧3ЛxJ+��N|ЛLQZWۧ^��@TMH1_z���z4[?0x?g<$kj]���]Id5E?0x?g$yfz���zbhS'oi_~Vl4,��(S$_5a艷pi[u5WgL�� +@NU7?0Ux?vY ;*:}x +2"?��@ )ܛ9WrJI:_]]*ScqWۧTyR^yx%Z�� $Iո,Lԅʓ$g?0Ux?"wә#2Y__Zͳ>��_f5J~%yvXWWoL}/9r_dZ7+D>��?;pnܲ%s;sWDBT:z@LSuUMvfP8?<b|M{wF-:X_0I'��,$/ Fϸ?Gu7T՗?FCJ曒}Gm]aZm-ڞ6O/cguA|~ݼ{So=uC&���/,$DIN$^<%j`1jZP?7oN|WLy=_GRalY]+6VV��$fcnwՀӥ`OK4͢@O*MGX}i=koK+' Uy<���%Hя tm\*\>n дjlǏl/C`y.4U$)ugGmaL��!Ewϧdnh&?(>HN V6]4_G۴m96*Xm'���q$TrCn>batf*i~ݜ2]tI:*��2t endstream endobj 521 0 obj <</Filter[/FlateDecode]/Length 1818>>stream +H{PTew#3/J[YSx4/H*e :$Z hJvY{V$%=(,c6js, }Q,o=g!��4yVf&1Y$Qy%^t L=xФQqv^{gn~1g>֜P7wO<u&QÀ}g����>}-J#^rY5=.;uԒO>ﮟo9|͖[gލ$…k)\3%_H{4f���s3%rl:'U<Źq8qNCHT!1Æ[LCL͇Iw|Z?ܽ^CKk,be���t{8T?ksR?9 :"](5gZ?܃)@Ԩ1̓_l2F dU���8Arوs'M˶j9t΢#5g̺@Q8yS\PKKm���@;R)Tܓ=\[yL%?rjIBȐc\^Z?x3bG󳗍?(wˆow���D-]Qj;{21rn +Ny I[T-sk.og=-$foznd����Q+'8',y)iOV'K%bnM_ :^Ry���3T2TcZyi7Z?ٴ,Ld 6A +!Ɲ&Qצ:z����mG9|\.M9iZ?آtzoIR#Z<3О^?���@k53ME-?�l?xIEFoxKgj?7����bb'ܗT9μy䣖|t +Vg,p6<o%w4o4iu?gJaGo���<=<H2?])TΩ+\ -&1e$ +*?{9Btr_R~q(Go���U?tH̩1}g9Fcr[+p&æО|'XADWQjA8l?���9. +U8p)ߝ^ۜ?غ{?КmuIzGQB���;yJ}~* 3[ uUB�gb)$HpdʪKtys]JEB.ø5"| ���Wˣbg="/2W3Wl" Uek s,9hҷE+ > 4(6���Ox}v:y[~əKĹǒ̜?�frb$ +o[Ւ0D_/"U?µ*tc)A&A TC-��HJ)L6g;=\?f=?TL?x>&Lҹ>t['sQJEVᐘ[[G򴕺m i"#YWޞ?u:MK/EC=���A]ݻXrG"f9w>%j<=؛ +GJ=xtoؤYnTR>V3(~1t(\55!fsD_HT:���`7 0�*~ endstream endobj 522 0 obj <</Filter[/FlateDecode]/Length 1941>>stream +H{Pe{qqp*RZFY_#Pbґ]E}y�$")qbrDVT0@_rJ}L3g]ٽJbTW=mOTruZ* Wiz- On~ +�n>{ w͞q$w٣RiUEY5&j,SYwHL?SV>٠0u3!$us}$���IlS-6w[#dgEF:+K+; 7f,D|cNWٽes"���ЩAtpY,}&eQs'F`PXݷ;?Rn"Kl]f[.򥭋4]��`3e.ظnc~'2gרw83G+_3=)Jk-uS)s?Hkd'Ǎ}d��� qor8f標,߰;b6i'U +ZH}<e >ʵwe/r>���DcT.y5#<rMZYgg(p%bس.+ggJS^P/ K,R)���'e%͉krʟfŭq2bЇꆣ7:ڹDJt1y+{f&?H��Z^О)Xa,HÞײ1EuLѺ/oE{S|~|y{z>b���5~F85DfA+!1O4'.Z7 }=*ё$nkDp8{l"siCC;y;���BH@='5s_8 5�F&A9cAwƿ38kfYbN#"sٺ:L_bPg|?a̓o̜%yxhr4u����%ls+/M|0KG0̻̂'9J9ўD_zҏՁúǾfw'"'eĨhYAhQ$Jy_��t:WkZ<1,Ϡ�\;Mzr{JUDg.׾0Ë睫O-9 9tNZ^1?kcb'��I2%Mh,8RzugKzY61s^C{y#U[7YM^xO3aƒ$S|#+��p,hںL;Cp}xYTj_TgoaKt^?JK%_9nV��܄zm{m߳:j/,Ǡ�\^MM͂6<JAtpʧnܴre>i#ukδ9Hn ��ߓfhَ[X~;3+?=K&A{%9w~w) %:@U3% 3윫[/xgW��_ +dF+zrХDKjx6kua y3+z:An1yΨ pw} ��ʂi{Q۞˚#/+?۟Px >PF#Ԏ~[ٻm[4ş$W��Icsɱ!=vg5iK =+?Pe6}ئRm] +z.EG3%M<aW��@t玙2j3 Xz|G2WVB�Wnj{pxw'N>hU^;Z+F��CŠk?#;cl/H_v c?+4-lÝ9 0�`O endstream endobj 523 0 obj <</Filter[/FlateDecode]/Length 2011>>stream +H{PTwX&QƊ&%VMh'ltD( +1k HZƤ@ r`,YJzV墨4NĤ$ +ȚINQSo;mYd4]g̜oYCTSIΆmXZݧ&���OTnVwkc]⥖Fݹ"i1QV10xvyfםbʛ{vߩ"krt��h~ +&m]1{OkrII?ʝ\ޙ.��M 问|2őS?�Rl)EЯ埵1ߨX+r}��czٗ#:z"Ѭ1RHI?y-o[;_c.EgCg~kIO0�� Ea+7m#~{=#4Rl-u5?䝩1|Z~Md׆ u%՗G4K +#c |��Gۙݹ##uyg#4RkKf_;K;Gc"E46FʓjLYO~f)=��}js9r.Zl/<ƑKxg#4R~[ɢ;;c14:.6jggf2\5ܱ;)i¼}%��>R_Rc-mtW,<r lFjMJmSow^ƌݨ"ID}ѵciEyUA~~-2q+��jd3?Q O;e#{*o>LHcJ +j:wFƌߨճձs昦8s̰?#o��q +svGCfkYJLHM"F4s1Ϙ_$Zĕ,9MnUA~hPRx{>��}}ɱS.߱5|G<wB�O%+D0p+%wUmDab3;6Aף.-Rw��+3q)AkoKy8r,J͛lR?b5$[=#.b2\5<))&V6k��&脾v+qͬP;˩(3#Š<a };Ržu,y#iN :s +n ׄ۷mxk�a3n 0\ W wfغ>Nn~u߽w?TU/θF%u}]Y'}l.N8F��&ۅg!,oTY:ł'Yg&n3//j֪c=ޓzX_ȾzwŸט{dW(7GB1>��$eя:s~.;&HΞ+;(9S #sUNrC:Qߓz۲L݅xYe#g}9;6AS_R<|�hE"4FK-y;xgp*_iRiF>]5.=6[jr犂~&ŸK$ٴ$`ԛvEH^+/!L6w��:͙{l:1wA�wrT]6V6ypLvqsHj( +ot~wvxֈ)Da{`f\tte/'_\��7e{^ lTY >xÃY>,K<h4gHߔ=wl呢Yo?b<oTDmۉn_ޓō."z4eűQ�a㢠h3\! +kj:nkƪF>qs}DžJYcM"ٴ$]d*ҶoPzM8�<?�Hwϭ endstream endobj 524 0 obj <</Filter[/FlateDecode]/Length 2077>>stream +H{PT,tA CR!&dNEQ$JDA*rIQ.vmp{@`beA,)+iԐPMkI'1Iag3sfVD7µ]ETt׏"̢02-qߟ*>M4\k%?%�Ex Vj?YkA?=vy.3iOWMEoSͩ9fUmv@x?5E} x;ԓ~fTYwxm���_ '̂kqj>zEXʻL靌40OK}, +'<ψ_`=KSd*>}<p,Z~Xf/ޝڧpK8/jyl5(KHn3q��Ć9ncV~|aنَ3'5Ҭ{',Wk:O̻B #LcOg>qf&FM$f&����ܓMqIqsVNaJͻ`�) ( OKydo 2;ؿ[=ߑ; +G©6FnƿfmvNF@"?Gg0 ���09==tdm?qɈmAci5OW:g#{-t[ +7!mD-;C. +#잝U5 4ef��SEi?_˛^+xw`oHm0ʳV + Q'XH^zߞcͺIw1;)rx��)=3qrm2<Ա4X<5+7~[bFU^N}ûkGtW E'- �� yX+ffQw ޝ#RtbYFL$_ŪDID6-ȒyQ>fCu_빁[yG��H ++&PR{D?k?e?"ᙲu2?>cb4iu(QѭM+w(:PQ`cc��f=Us/6vm3vo_,G2^`fem~5ޝeψF+'":Eev_F$oH'��Ux<ڌ_ k\) PXK3RFo;wGp&Tg3?{E#;oXĔ(o/)��COtU^ЄfxG7͵23R:UUg^!vQ?r\ݿ Q��{do6,U[X_(WU.ޑM׵xwAyNNMDV9EA~U>ϐ� ;)ɽF16#?=.g|b w?\v%]r»A8[Tgu7;fego8:��ڙ'٨8==YO4,7.ޑ`Ɩbȸ>gU[n7{{N٨:~i{ ��svQi:Mvxw�xpz:S{{#w׃p6[mѿֻ_Q"B"*~N"77ޑ��_ +'Bu%r' `�07s2, +w<bS4 f\k\:ZWVt0%2J;x�/L\vg9יDA*{ +�w+cqb -otJњF՞kC,eř{.\wxG��|&g5U5=Iӳ]GKX?`=wW�se0_ў 2Hc4.m'za;:Eegy)~O�)l2=l ҵ'7(�e.P( H +V ΣʷX^49;7\y�9SYpKI=' +W%q(�e.cqٺA ۣ#� endstream endobj 525 0 obj <</Filter[/FlateDecode]/Length 1946>>stream +HyPeƿ,,)L֚)IvZ)E%A RbH2& JDFx,Ȟߪ)3y959QپL.iA/>?c}ϣ|H !ߪ‰S~72Ö-XDo7'/Qx ��n$A%E߬p+!lԵ1lΟBC9V p/9�W 3]~[h= Ἳ^яS[E]+˒*rWq>F �89-wXa� �8`nص}Ũ=UA*je{Ӆ9ZʋYސw�_0.ͣH]׺aռ; �G:}SOMDޝ BWTNo1QW~?elN&+E;>N].'i;� qT9Y!G*m%;fPwM$9}w'�8`~fTg=wNn[RKyQ3^ySly~�0;j4/d 畗"�\g9 eΙݽ [fSûWD]{UU~ÃS*�AUg:f̹/eQw�8Hxw[+":ыk|۪jGAf|sJZ|x$�`1r2ړVL7SvV`�pyu0g篸}[rwǂϪx�Ywc9ްPP萗ˋwl�8bָMP%,3?Kw�8Lxtڦ{T[It`u[k7YV=jkfFbc?;B�7[}|Eo!cf{>;�Wƙ30}Iw)i!:c{oC۵.A}@2yyxT�ufC01؝g(ϻ{`�8eA0}i1NkgiQr߫_wXn} ?yiL1~�pu3Ew͡fB5w~}q�;ξ?IOEE;'GD)ZViYiL&�\%.\8&jNg;%ĺLgR'xw�W^JQw纵;":CsʋZXY7a;z�f̂h-ouU;?~yw�WTͧfQn!q‰ꒉ^?SYѷ c�2GDsxE,署M3xw �רZԷ4/]ƻAi!:ku_UuӤ<+-~ϟw$�.TJA}&jr7ݲ4ww�`1l3uB4!0NɅ$MԜdYXٮ^hѨIL�Xmuy}ްn˻c`�\iEom{ KLosSoC܌};K\6̛VNk�\ٰadz͞6͏dw}R,JaQZɿ@DHg߬'ZLM,#͆mk'<5% ːYE]^;ews]_Ż[`�00\mL[Ļ@pnk}G+-9 ~=x:Iowരe65_?oz߷S;3ǩkc%�3fTgwÈj^͒eE/{)t�wbAQ[d~O.))?�8?^(Ƀ}sWύg CΙvf}1?dn(7_oo.�. endstream endobj 526 0 obj <</Filter[/FlateDecode]/Length 2213>>stream +HkP݅bClqMmzJRQQwAjTDl$" +.{^N tAGzhZ:MM5KFX1w�~<7kDdZ"~c=Ҡw)4>�myfsln1hI@qCN®hZEt fMEY%+W <BREt۳vUoFsޙ@̰s]:m(!_ jw>aՠidw)/+;y߉cpz\B:U~bY|l;SR7z�t?bQQi._+z1C?'uk«}[Uܖ8.40��NȺ%KTk{ؾ*P\.+f{w@�k ̓g7!É.㚥SϗoWzeC֧!^ �pG$RF^_8śo3[4E+s p`) #:ѩwܶ}E#nx%%�.D-X(`j㹩)_+O;C�ur`.L2}tyEtOۇ;v/ٹ{7'|ׯ^� +'U%mQ=Dwv.�t?cCHQ:}PzwBf t_j~LAevGW$,yżW�= k$5r3{v@�{ \v8q{M"޹B6w>ѹDGw޶vѐaH/G^#�0JѹA| e' �t`r !Q}ޘuwրi"|hHM#Oje>aΛ*^+�t?̙ۚGl[V|!Ϩawf@�\1;B;r!ѵfY#4oj"6,[.b�4&Eas~7g#xg�^ Bbu݅zޙByD8<c5h2["D",vk98α4ff@[fMJv'*E&UhÆ<9\y]J% ;J&hEε4͢W]S??z"�z ]sT&/ +~`ϼ3o?3R$;~L0ۺeT= #*fwCAϵ/Vdʨ E) #M z`9I;eه?ݴiNl̀�`9ٽh8Gt 4k'3ݼ;>Ch몬}\?=3@aO1_nMxmAvUꕗe){,8ۻ'�G$IUnc[|T9:5d l DNuQv {m()L?;#@aO+ #I);˪.b5H$L77W`[TfzټzpU~eD�}wWWO ɿdr{6޴(t@q݅]7̜Ebqo1ЏqVQRukk6YkL,BR\}VfϠ8:h 2/ݬ8T; @!/D>"r]Q627l])H^hVbg/l};87p:eGŠ-ݿodz=b57|?@3XEtO?M"4lwk%5e* AŅ,[s.IzN4vTFSNuHvswW-g;do4_}t·BgSz7=9<BQ#<m߻a/Z-j1v4}^a{wp&?@O7x_ bqg}FYURc|?JTœ]}ӸܽWC*GTO<sWYlm2L{h[-z5˂ҹm2Islo Sg2?32ӋJVUzӿ�~ endstream endobj 273 0 obj <</Filter/FlateDecode/Length 597>>stream +HUMo@W΁K +!T!T9Wgة[(iClϾWְ\Vou\G(,e/yT$ZSg$o>oջ <fhB@lbS E`EI|bS +e6`"4%)DB.DV;dՄckwDgCG;s4>96PS&æ{ ÏΑ@hu2쫙r JL*b/̄h_Ql^h_ -LKTSc-u<6(rui9<U O]-؍F6PCzBQ3|ܵU[sa'+rXZ73A6j 4Д s@ [F#u?֩l/3ҒI5=\ Cc:&1Z1ulAR6'@li.Pz)Gg?~HyKSWyX%ǡ?ao CiR9vJ ʙVφa%O =F;k;ᬑj)2ߛ�ExG endstream endobj 274 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 283 0 obj <</BitsPerComponent 8/ColorSpace 287 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 506/Width 52>>stream +8;Y9M]lCqD%#$]83gSI<QO8AT1HZ%+mm;,"-hnoTq.'h46613S:>k:?4G)>]Dr^Ll +1%hSJSVqFUn-^AT.5Z_\!b_KOPtnPLW>LrU;[>91a!$]/qrB"mJf)ie%Ls8rS^#WN +7RTLI%692=5Fjecl\?D<!htY*0e@+`<&Ncc4O-<oY&,`F0+,u[+4Rlr:mHi6dSut] +7o^^sW6sOf)V53(Ij9Z9i2f'b.r1^0:ulP9Sq*N7CcUr=mES(l]_Cp?HWMq#SK@?l +jRE*S<>Ep>X?(uSXA5e<>j*n8_qn]`-LV6C0/c;X)B@P!M:([L3rSR2R-q%jWL,b8 +P-algIJ1.[N,e#`V9FYiY'Y-,iF4?YVCK4A&PchCJ%./0lE!LW3HXHs/b[]9Q[\YL +gib!iH1,'ZUe]Fi=NXRq"273h;QAq59j[*0`SF$gDi@F1c?!;9L(<A[XUXUZO/f3Y +NH1PtQcXP]7SiQE7?)=-4.f.6&@p'8a%5di!(2;5FT~> endstream endobj 280 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36771/Name/X/SMask 527 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUKK F Q�Y"H!"B#jET jV"`Et�*>k>>44-%HfKVܬ~ �����������������������������������������������������������������������������������������������������������������������������������������������������������������Jnj4lYx˾lYQ}��qyxڝM'SE=dAkë__92��x ,.|SMs��ۊ|jԈ?��Xm4񗇦L=o;֯-)*,L=�� "_}ߓY֘<ٺf-I[]5#��xmk&&o~XZ��9ݗMr]%g=tbų+,XfL阱J)R*Jd_K6E'ۗ'#z>zȎQQYn_J)R*J6Ek}&S:ǂGfv %y.3VE\֤݃r=+w=-ג B1a莜<[vnKf:'qkV q~ps|پF>}iyj/_PXy_yscA ׆+5h;tH}We rcA2Yq~psA _YiE{;s5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&� l5bb�f_#&<}BIڭ�� tsUū�?I<k<Жv/��AL:9S��"y>Z=ܸ}뢴�l1wW&9jȴ[� tgmny[ �Ĥ<WZyC=�g�޹ҾF,�]i_#�@b"��M &�@b"��M &�@b+zgÔ5??(��8C &'ײַMS +R �KO/?Eq7umᣳS �D} .5=s+٦>n �3b<ϺގO7;� !цga[��!sE¢Zv}�� fgkiy��ĥ<A}��]<�mykB��ۡݕ5b!��M &? + +2<m\ϸo䜟ݲy^O}[lH-OV-^2sx?^#-:s8s8s{�/_>4gܒ.s\jkn<!  krqs~[<Sˇ7,qPJX\H��⳯ �611��a �611��aqP^>}VO۷\co,6a `4FmS; ]&a FnJ ;ZQ +xfDIR&aEz&o󓎰g<n5ĂLz<O��^C,h=rUo}mu��@b!ڽtvo/H���h5,_���h6}uҸ��^CuaO[q��^C}tis_F���6Q3C/٩iy2^ ?ghMv q\)Gu2* ��ywF ڼl{{ܫ(*s묻d ��vZ&h3yxm͊<t[g܎VhIs\?G~4���8/mu]ցޏGM(��F V|L7^��Ly≯]6}���|s(*6KZ���{E:*G粟}���8rN?Hr1<7d��>;*"q e��&Gv>G߬ͩd���Mڒ:Z\GT􆒄C}���4QUQ쳭F@H7;v}���4-˂]bPE(kS{ 7��@z T* sOO&,���S{L*{wu^Ⱦ ��'vwKFPIcxn[e��`fnkUecwhTһ?l^r~���qoٽbPI(k6oʾ ��źu=폴}</4���SJJs/Ŷo��0>N6kTӷ?HѺ gmo��0c7.?!.;q~ 6���3 +6?Hcx>}�� ^uT_lxmY��0{%ś¯Ș >���3)ٹsb5PQxFmxnu]��0;,nG2%l-yI}���fh_:kmd(rU-��_T5PlƋד$>��$ M5jXT!zYfT7��ݻpF@UG܎dox{jsd��`m yvujOX@w]}#��Ww6dT2X*_ m7��]ʟP`h4ޢg>��@iM:* I*++^���*uv  q;5h/}'��ʌcﵻ, h{]Wd ��nq?#YӠ.N���Q?ި3Yܷd +��,vx^7yyk&/w[��Tt8?/AgV?fۑjwxC[��T~tZ[jTNXe +�� ?r sٷ��(8,+pc]eD3ɋ>��@))k9pcnϔ'ʾ��@%oF@5tsLY~3a��bQbO]%0*nh:tۯk>ۛl%|��"毹 vW:0GŠiYigsH~n��bɑbG[Į}~f1Xc/~bMkZi_-+���ĄKbO}_ 0p#!څeb;f_�� u$vSnWyy F@5tt?Ų"mv��hV_V,}w?jF'i֒ O[6uqʹ3g :NxZoF<$%9���E$뽣.v\;TF ,kRUoYs礀t9~Gp9Ck{M*Mܜ_AQg߅X!^rQhc3QIg$eVG45 +aR@ʝV {ب*wѴ^R8Z!uPu{lw= ����CuuSgCQOQW}H&OaN2YCܽΚcqr+o_SjJW ܻ���H)|jK +P/ӥ؟˰!?6T׭?Ƅ-0s{eZ7V����N-G^Ӛk_,趿@S.QzݚWj~Pk>Cyko +^Q-4jH1���PZ ͻ΃<^ܓ%~2omݲ2X-^Sji+k/N;$=���m e5QY&m?QLԪr2c{GhyNsWgy.q1~U"]���_ pg^ژw*pʕӯ {?|B$ 8OtkWqoǍ����C[n<&J$;) t..L_}Xy񭟏};cRy$-jT<s) +Ʈ:ė3be"���?v*R;˝D_SUEedi??̸mZuw&o:cBgka\+n3V&4W#}n[TzW;_���_ض~Pp '-E)sz^i??*J= in.a7k,/:YShW דӾ=����қ2~yBS?` ;-mﲭ~5?bGHo:^;e+\؝Dm"Wx���@DYQy>uѥ~EeMwaHn]:BNH~{uS݄lc՜Vtp���@,9;=BMˍ)$/]k 8g#zQ^uSyk68;9I}]����i .BIU^:Rȧ~Й-- +����EΡj&E,AgMNOW. R���oG5~x51zZ?bp0ȓx6ly 3~ϻoM����6QR-uQr<z m::߿>ސ+K'jrbgH}g����[ȍ3#gsۇz&C}f^7p4?|>>>` ytV:Mk���HwwF]H?mi E]D}Ė8.ki6l}~UTR���/v|ShW><MQ7٢#1:l>++U4bQzisN2W���ճ[ +Шy}n+hlILSg3y.ożR_���WcgΆu:?߸^I +l#<w9assϺҜ(���1F'7uvU*H|SUgK +.:7b)'H}}����PPH٥o+1O=u�͞ gѦccq;?���5:zƴo4EPPغ#AO>ftF(jnP���@PP|b櫦]CCǢGOa�Gb5dSS՜*tNuUsꛑ\~����=ޕ:ƴk9w{�tg@qa[Yh\ReR?���^n_3ߴg.F3cK͊WKa�G"1$.6t^k7w^Ξ#c���� +uKͦg-CA]\^NuzЉT.4wu]g5Ru7K����C.iǔ2w"}Q?LXNtn[G~sԏ���wy{5uit4QP`�:ɥ:wKͭf}]I,����,I߽+- C=C]\"wCa�G"BP7խsv<Qũu2D���SnP1gi<,rN?\6Lgzً3L,jN};|\~����Op[څ u s.g/»p{c_TR?����S'OvKSc<Wܶ.{D1 8 +N}Qt9nʌߙ~$����F%'u[5 3gk�XGNӜvճ9[\mzj���P?i{pNQCj'H?~= L](klENW{Q*UA@S˰xJ"*(B M `|r UŪ(H6]O;oyL8VIs}=~ g/=˃X���z8Gh.zKdW_1g?�~:X'UҀYܿۜ4^���gܒ<$ Od[h~܄Uޝ~*4ڙz5���CBH{ /rMOֻ�<kDQZ{]FyeX���z&C*yeKiÌBRGs êӑ^eWTG?z=���ÈsJ!"<мBs /ݝ?k +^yq~R5ܶy���@ϲ`TS6yMG9k5/a?l2CO\*TeWY���zߔjKhN4ʖdnu;j2�Bnl?rR+uY ���z>#MIҗ^eY  A'XyE9zM4!<w=qjw{���'M9"CkI蟫4ߤ`?Bx?mCzgAޙ~:^qcU��{qѩ1ͳ?>4/;r2Q+ϕg?A|YWf-e+���p\{ck4 ,B )4�<9[tva坧Ms3.z]���\\+y<\BIdn/˜VlӐҵ#^ÆNVK����xb—Tʖevc +c>h)�O:aϵʃ,>$_NONzg���8D* CLQlRc?R?r&dBA҉4{˨ ���tMn5і6t"}>~-:%dMG|BZ+wsǥE���HǷSG2Yg#p4?cJu}17:l3��}0j)W\"o\D/4D]I?t.yCP/x>ן���Hv͹M/Xf Chu6B�GckNtX Z`BKrg���'/ADZb3j7 Qy;Xg"pD?N*x[2:W^sϚ{+���;?(@ˌ]4x<#A'IoQYy]UI+\Y���숻+ w ;hHRdg?Qj<bЩXMHh"=��_ҵW^+Yj-:c!8*[tI[Nԩk>C~z���`"9,u6m)hi;rYg b1]֝V+/3}Ǿc㝔Nlw>,H Ѻ)M Z$M���{:s)Twٿپ҉uB�{{sWwz}"fIc-:Y2ܣm$!kB&v)ߋ~?:uWQQ~m<quvO���lUYޡ[ 7Jd +#Ga_^NN\vGg#8#?=_Kq(V1U>nC\Bu>µ/޻79gw O$wχ���6a⫾N7К-{uA�{7Dkn..7EF5V߳1K?# j!^5UdhM}1T Ng$$Z$1d@"��nPgArp<D `2Y~aOmoY}_cz69͙^rj/nٔ q ͧ%|E~BQe٩�Ib°+\q#^!{-���<9ALde 1МaYg'2L}#лfX*=kIm?7y].]!HE +;Oܩv[|Iih6(ZyE;px7_?0jQv?D,=����x28la~|W^yuA�{rB.;ܻsA{?$3d?hRMH/sW9ϧ1rѷ5[3,W\;k9I}~}Bg"FB?��x^ixyPw'QDb-UzZю7*PDD9(." QD!`bGP]1oy3c!gw杉=3ox<INf5c&/ӗa~"؛t5e\ �nt*w;I:n'˼n)}Ѷ&O#+l!zvWS ޺k!ts鬃qvF|l#O.(OP=[Z>os\;lO_?�x>?۵)͊ Eu=s??T +e2"9kJc�wB;c&b^Z禽<AT^G{509 lR희ĝMMu޵˲{c^I/ۙo}^ڎt-+�Z]`[n:S'M$)Azꖴ~d)| + B!CvC7um_=ܵ?_84tNg=;fgL&\ʊ&=}du7IwR�x4D�M O˜-_4x9DE~s5b %OR~k977zu*f>&㔩0uB!4dT }wjm1=#m }9u]A;NݽɋIkѷL%{rq +=J϶f<2EkOS̡W^DD!ܬ(3N<kJM7~!۷fGCE}śfD?_5t1 tUUR7 +O.wr[0 Za+2Ig}}({OK%"S"u~].͌;6>x& +`gc f&&F!ޜϦؤFyVTB +24? <8-6l�@](@{<6Uzث[6|_\S5%(J)2//W58C#|V{6&I3G!d\da:3 dX,˔ΓƣIuC. |�:rm.߼9jO2EV'JҥrUrNN2753@Խ~ۇx9w-G>! IVd)Cw=iLd_<A:`@H=1U +JPK>(J4.񿮸٨U~n=V]t:TܡVg$'-kt{[<\ì|飂BH8N79ch溜! ,*}Ӣ=5Ǐ N:k=�(/P'qXb4uqmY5Ք[B ^KN<z':g.،�LqB!4H$"Q_ #HgPk'ʋTR4۟BORH;iVl5kgvcJحDҥra'p;9)kr'g<L !;`;a"(%̴ +2AG"t >mL?a q @ec.7\an_LuX[yVM5%zO87sonQûvY�3a(G![y8vJWr#~L2d?,n8s, +/?ghɿLQmx\4V7ᝊ|/DT g+ !Я4b((gK&hBO�:/dr Ig{Xs:҂ hL:߈6ԆJ.߼y\<QHmN$'-O ^;pSSG!{LHtG}JI:`@NY" +U7ʳT,:P;iVe鳏6Nm*)RpUԹؙ[-p ǐ>!dpB*h{^Ú1NsLs:}%x&̊c#Бk蹺RK)ѷ/{I)KO:s5K?i� }BhH0u}u ƚw3 F.ʄ_?M)#Kq {,@TIÑbޭD)w^Mḇwᦦ[&FF5U@ޟ@:`@hhz8 +JUF> @�Ďji9t]h I={!|ђyah+B zA70{j[,, /"KT1VꥂQjReBQ  +X\XDQDAfGEqd1QBBӖ·!&Ὧ>y&*]<A])s3T7ɣiwMomPdiPq':1_1Mx+ΰO?gӟ5, hG KA?@3ctb2I? =vW OPAܟl/ y(rw|u\z[6 syI|x(q9},&m-|s!nA m4e䡪9J�av; +F [BiwG}ohjm/yM)v6$&8 ha f&A;|AO.FƎGy=AQAeHDB#( ;�<&JLw׉wv5U*H;uhiMay`K;A+zLm,H%|E0ݛv7 XJg#/g >�N/X<y@ ӫ8A½t RΙTCCf26YiA;A(=ů>rPͻf_gH/Mp *?FJxk{(Hn b0@gƃ2kA>y:6ܮ>LXÏC K0$Fٹm.!ڝub58/PT]8T�\т'5вg-ibqΏ&>\+Bvzj036wS\HTaRG6>@@Zήp:m(wV! __`u6AR/u>&b͊sYٹ '`(Dc煉}PgtR΢Ep ȳQaK~ɚ)gI2n,7Y=GƵe Bv(#% @ěAnWhG$ /)i5e_>M5sZM!bwK@gc.+`q+.mݿP}�P�E[f?nģSX\'+ckk̦ҎNA(bb8"A2kѹ"+`wqHEp ȳQA|ߺrf2h,E.f@`݆8V{.nTea'4r3=ڱ &@Wѕk fD@Gޮ/\)OS(>�e�G`mO4\%»u"NsaVZDFLE 0l&h1#Ap +Hż[+6Έ{O>;yykաޝP}q +\�d{˘W4ıoGlAqfjPfleN{GX%`j8v#2"7I&o~d;O޹WV\2?&R !v?BQ�P͙c[޿wbAT$泊E)1Q+M.]3MLA[Svd#ȸfdCeg8}[]XVQ?QAdrNݍA/�tӃ :-lpic +#ɐ"siI1LZX<{ЎuQ[>(FC˂t&%΁A~?LR̿+ɤuP}m*ɕ((rf1Y?jrh !(N,Q"AS'"G~VZfC;xde_<c;,6Jy)=΁A~?avRN>zq( p)zThޏ5s7{nץΚFI#7N泊 Μw6>дųd}'A^3WkBWW @{X~-AxP-(UPrh uzFdkN wm';eyZcߥSx7y9f=bdx0whkj>#18 [zlo #}?dlA{K%|ȕ~AQ}�;�דBorzE[w6E|^! (R1>u>]=gA7 Gor]?,L1p OcY+מf_gEQ P p9@3򏦃6_R]'+FZyPgI@nQUgSZG4Jv a +Q@ ^ H@. *tTTOwxN Nz>3ɐyx%<19r[6v|98̘-,H)>X1oWǢr~FuiP&sVK wEѷ!i@g A3yc&<SX +;tT^!:!g|0b:0y80d0HGζN*"٨{ϩ\Q?nSS˲'PEI 8Xv/}jrE}U,h9K:w6 >�mp oQڎ"TY9tB'-p зAfdW=�EQt(*XP/h9[>S{,фެ9P(/(弬4arGꞨGm^ +s悭5#yHWk&I6;R;<?V +2qg63EQ}U4řLXdFOCFRJy2^V*?ȎC2XfM Ɔ#B43TtjwSwj@#ҝ }FYʕ93EQCUPp!̺ӧ;v]=rZ%-QĂ2^f2/yyvt ;$>4ԦV&hy)*Q/t Gms?(sE:QEUK�4m=|ɘ >K4s"FZp>skY#2ccF0{406t"of.wW<<lIy5u;Bvw?(p|$mSʏ^co쪍˫lbAK)'#āe[gۃՈ$ V2@uߖWP9NK@WC_庤0 曓XEQtp�H74tZj{vˊ{k9:D*j?#S=vjG':  Qa[Oˌ~s}M 5'!p ȫJg9sEQ} +T�4yf=B;*TI n']Z86(Zy\;I:V*k;Uy?)&!p ȫ=9bvƤEQ}7r\6͝xRbRo7kVK(rlՒyeo}?/c*p1 ,LMI (%K=nJ팩!%b$A^}l'+Ƣ EQ +(�ZΘ/Q2%}"=|б_җ8̇qLKTI׊*y%#G?(=ﴢ*t(C_&�u@GA3ygwx2M]#-6QJ +;+D'iI[v ;lbn;  `HanbJҳڵ?;yziI3@"0f;DԠ)n!i(m> oij{T,vgUbJ*mhpYc?0c*tq}#&0pJ*V=L*r/&p ȱ9̱.EQÔ +Pp>6w +iɽڸ\SmU^Uȩ(d$MtO>znlP3Ӌ~?`  b8(%֞Z}3ub:6y3U')DM-e(M��׎[w+軼GvGoVd7H n]TtZ̭=#i$#[~Vv~3CCm"̶yz3-Y +Ӧt b`@鉬x"{4di]lBȊ]T&WI +˅3ccZ񻾙{'Pgё$A((29�2O�hc*,Qz}j<FD}z9vQJmofN:K_GVk q&>|&HsrSN + N N +s?~4`1H iEQEߴy.�,"/�Jݚ:ʯD!:llB020xep%SF<e3@ZP~΀9ϙKmmp5{T<~GYa?$ 0RP[/-^@78% "-b@5 $J +fwnn`0R`)$8*p{% gdIs){�=RJ}{k ^#;w.y^3n%o2]7;5lrӗBn`bT礦jT#��HȊU*Aܿr ~'%šYwnܯ*/ghwl潾b!w+`䶨(zNoY쩖qzD;���iz#g砻t76}w^wPUO[j?뢮M#}' +KVL-8_q; V#L>�ɝ>nǎ#n4wv;2s**}q-Sw+u>XEڷJKy{=g3~ySw7Z*�`U J5TlW8 ?{Me>[|ݻ^a黀?HcMAh|gy^UEpqV{EE:m*?;SZ.}�`%㔺PpYU狙sٴtcUskVa黀?HӽKWg{]srϹ^;]v$Є-4=;iȟ��XI(.Cl^ovZk$N|#R_Ѩ>B$MӳI$=AwRe9<{{3[;g W|_l(>�Gy_y~Ngxft}֗{7z_;{X-"#UQg?`ϱ?Z7;gT7O�.T8pe^NcwG_ \'.3-+=vVvsoEb873^n[I#FzucnI��*T$?Й# UwE\U=Vt[X1 |mOKϱ?o#ei7[|�\crp<9{KR?UlbnJt[$�e*u⅞e3?J*=VAL +#8s?xOM?�}_!Mz+cΝ32]g:��8\Y鮷21)%d{o:y �Yt&d}B㭎AL +#x] Q# iUg6��vw|Ϧݫ_;Ĥ?n̔}jE�N+v;`1b-ug7��vuo{K^v;`q-O3=#o��FIۖt`qRw]}iߥp��㒌CRw]nbR7g={;)}�`_ނHw?IaܜۦTWMmQQ��0XNZt 6~w=Y<�].7_8t ?@e:w-tȊ?�*ݓ + 7uJwݰ?Iaܚa=v��ža辌M}twǭ?@m-uxj|ϳbw��&UtOn-quoJw?IaܺGwxx��R=RAL +#4Jӫ}S9y��BbuTZq6鮶31)=^7��ܳ^AL +#tR2S|ӹ{��^WJbjmwbR3pŤv]^�+u~{q@;Ĥ?B+(cߗw6o�݃ +3Jw Ĥ?B뙥#ʁqg?��R'} l1)[}?|鍓?�hkt'Jw)Ĥ?BE{��@[X_8VM &KLg)=��@[|[)=㤻$bRqWT7׵3��u@w]l1)Hz��vpwܔ6 G9c*5Tl��­2jgtIwiĤ?{fO#{�p93Bݛ+^?IaWǩ]W[u4+V��5o}W{O{M &~cw]Kw��]yLwsmUsM &~Oy*g|O��*tm-quIwĤ?=_(��&~.>RkM &v2V}yg��J^K.X!ݱch;O-S~ҁ93;�[u~@{/ec8? EQ&:MX`AL:"HD + +R89-mPe,U:j"ſv"`7yѦGxgƚt쏶5$g\88i~7��Q[&Zl9D3maf;W3�I~9}z[݀t쏶vＩ.M��\Y,n[?8zLևmު��בjO8ұϺOWo[?8cB~|E��\#P0~햺 3:bSX +E[�@sՖ_+n?8g'OWvO��)&ݴ6ΤcʯXkؾ#�HVJ6Τc(W-��\1OK[t#gұ?e\(yY/��\Nʊh7ӭIۯXa;xn)ڍ�rRIWt+gұ?;%9w{C��ptI$n?8'\̾Mى9Gt=yC䎬*��pI}Ͳ 'v+݌E=CVW?#y廿gq"��pwt)h#ڍt;WV /sSk2*�p/β%v#ݎE6"!fk@[ZtZ<s;F<�{ݑЬi۱)譝=1g5Ù\W�pt(|{ME.Zo̴>|k6oۯcl8S7kv��sf﬌j;xRzD\ni߾Y.}?G>H?+jgw�,ô[?־ǟM ;9 y93?뎩C!C[=۴[�p[o糞Sap}=f6"!9b;v|۽2A==^֦wgIiܕ(m*_͙}77{5ny6_#�?Q3>^|3|Ncpt^l rKk__q\oZUpG{x~��lyHw? 4Mww %OW.7ŝgmIP&�׎ ^A}1_[[xaDeEoɊ �`q0]y2甋-^Ok #=<3jO<ף(�y=otHo+cp&R`w;�0?X%uڭձ?8 &֕ߣ*�9ϭHg[cp&9̾Kv��ueۤ+cWntʫZ][-�sIG'kIp̿ %MMzQ]��纰gғg"]n~3ΓaOf6M�yґҼIMC?8<}RY/v.j7 �<Ƚh7 L:3M`aDA�C!}բǴ[cp&ÙbSXŕ!=�D?tcu/,nt(< uI M�Do&(݈_Aa>Τc8[Finr6L� zmjYҋ܉cp&zGkcH'6�@:y !cp&^͟Gh �}N?E:1>^fư?8|S[yUKkB㾗;�і%}ȭ\^h7 7t3<=o\L6dL�ǙHF:*8gұ?1!do~��>}˲ ~ ڍap&=&[* +?`~��zu F?8aў<τާ>�5Cznmcp&,Y<P~]~��mO" [&<gұ?V;Xj<�W2 $ gұ?4}Mրsm:U�s8v+yQvrI0ӭY +GG�}/}oˤg[L:.YqM�L ,gұ?̶.x2Q�#yy߿*<gұ?vo0k8V_J�S_l&;pTAcp&|IE g}�/w|RaCA`p&|J%N�Z.yyk7tw1]6;+C�sfozEڭAap&=|Gu{ �yG<KÛҼxN1c8Dle\Znj2a64):-MM()` ?r/h + t':JٲM?Z;̓OڰH᾿ss|y/t/1)q˟ZCʓ&�IVW^zS]Ơ{?IaD]9iڷ�p>oLaEit?1)ȳȽ~\5/V�o1Bφ훂`<͌*k\M Җұw�y7 &Ffţ3־�λ8c1ڷ &T1ok\O�_O:`{Z_*xN Ĥ?"ם[~þ$ +�6ikmoblOιY~?}[�vså@?Iao0[� +oQ̀1)ܓhN}$I� |l&ikbR' )o-� <(to?Ia-l { �,cվ-Kot?Ia7lשh\�e|zeg]bRҳܞw�"g{G|Oվ &+Nlk_�Dҿ>Γ^־ &/{`~v H$vÿQ p1)tdrѲ\DHrnO�_a[�`@Gzr|Ź4{ �@Vzw8WzX9GM3VNr/ٲao׼ڢc%Iw�L&=X ?S2Glso̟6IQi&F,Og*)/ϻUG'־�`G&Iߦpqb˪r#wႁs|eSe6/V�`"W٥US; NLUyN^:9N VP]w�L"Z8%=+}p&qb%[kMzr]fmSj^9{]_9:#>+5:`{7-\}$}aUӢ N*IuUW̚/%5Y CVgιZc$S[Q�LV@jfENv$)˶Stqo̟$anUT[Q?In@8>\S^ggcЇ~&7gVOɿﾽUĠEgjn�gڿnvsG[c{tFKYQꗝճU+񗿺e>Ϻ?vl}ok~oky-<3$о�F'=:h@Nח=A$U_>n|O?q?&.G w`k87uٟ eYulN֗O;Ai;,^vDw%+=g?QNf${�@v#|?SSYJ>ZlC)ؐ|Vf]b%+ţSht�%KoͼE^ĩm.\0pp]tMiIOϰ?p#VNۼ<Z" +xݭK+ &kw7ni X8}}�'~.?%})?bRQ=meix�pO,^#=)}ObR +9C'w�êo~,y\Ĥ?LXSV=g=�84˒^P[V.=_bR*K^Zlm.@!_;xߪw4u}veKo?�h:ߴ`ᨵ݌ &6<'A|?Y+=Y0Z!m[^� -KofCNĤ?dvz]'Vo;Q:F}��B<ٲKNHIjw1 &22;wj?׸(K��B#HȞ0 SFx۴ �;II)[v<bRNӇXm^�fZV9@zO{a1)tdj] Җd�Jk ޲9;΅Ĥ? +O+`{{<w�JY/6<s] s?Ia Tҷe?"'o ��]]ff?ݱ0B%v+W��7BzL,kyo ?Ia a}el��CWv|bRU围!�z"hNEd`8D.s*GSnLKotJCC,8E88 + H.|v,T~lƻiF= L>3}x; *dg{ՁT�p1$$ŷRc@Ĭd|OS~O�@|Z1N~gv; +%Tg)b?ʕ+S4Wj:+�?LoGu,:C[nް@?:t𦩿/�7Oo׻?|+-ىC`4v"oT�Л?$f?:3+=<{U�p3I>=FYE`4XEame.$�&I.+H6c*<u=䮉|֫;�6ɡ߹=vJ>H6cJ&}@ o<U�M?CFs|ҚT?; Vs _WtS�-;?CG3NC=\Jy/:>_- |ulC,E`4Xպ=ewsu�L$zɝ5[VJZ1S+ip1b>).`o'i7%ĬdiS4w{uT�&9 +{#WLQ}1M?Ko;Hw%wzC`4DԒQVi9O$O\i|cB`4Dʻz-o�phnJ/3?Mָ_)CU-�/#yL ɪ .NC@4IJ +vdDڞ/;Q :}ɒ#+ .NC@5S+m]lݝT1�K.LiFW<}Jhb;<R誓Qe@?; jҚT+5�MrBBrc93 NC@4%wO|\`M5MrBBrCuviv32 ߩ!{4w�k\|H6Buf?`sKW'E ש&<�k<YArBuV?`Kv_#y�X×me +&(R?; vY<Cm{�ߣJdg&R?; v/=g"׫�q&2wnoK\PM0v&iL)bO0de3  ƪDӷmk ץ/Mhӳ!wytunW}5See%Tg0XGG3sn+'c٨E)/K3՞{;*;E誓[SF� -sp__uXq6R?uYRy?7^_9lFOռIڷO�6% :e߯^k 6cq<[p9nAay|; b{%{.:s@`8},|/6>mʵk[1җ&ghaOS$;Q˴h6ɞ`?NEA-f0a+y4g֤jt>npide]aoD[u�C $ȹl|qCg߯ռXP:Y=Ēk<ͽ|oS #+{,,{:[F`z z{)_?SbC#GYu;+s<o]Ě{PC(�Mk5WXYu�Á \= +,1G7|{|ʅ'p^zis-̛z߀pi&-W=``d_eo~DXu�CA o2&b۫_2Ÿe.#c)>mXRI N7jCVq(G]4W[_ '&vj\>fy?:ۚG @P?S_ԏd�,}pޚ2YxzBcs+.9biZCnkk; d/e?we_Ug̾ZʜZﱖ:ڑ葸�wj?[i[oGϟn|XyV�?;pF;~} _ʹm2|u!س{RFg?7ޢڪƀ~bk6/$f%k%w6.Gyqe ܬ?ex5il6#R~klS6kM!PAYY!Ud4Fޡր^b'c5ڐ~XG`4?]3yÂA/|fEе]nyAG*^)X&(-(%rXH,ۅeogw9P`ejLmax\Ȼ{|^lڃV.~?ӕr1߁z>rF~h!SFeDX~L8š~8f ]}Eh +|۝((b`:kot^zgMU8o7qGtI_<tz]~4?0c?6mc276뒸xӷrss"^}=oum^EW:] ƕyv$5%}ʄuk[Y]LL N1毠?0[JoeVz49>xt<g0yxtbm`<i +@! kjb"&<+o4TgjB\nMN_QnmM:ɘNJ nr{W.YSpE 8οleL<wwS O\G*06F~+T}yn;1yUx|~rtH-@Ob,GO9vW ųw I85';bD!7[S4N^|ڮ)wi'=PoKT+vr: HjU?ǿUm?qw©xa?5NZ�*XZ)fmŅJogbj><Rz< A@o]~ē@! dtV/Z_׻c:C8Sn%']i*E/!g2̱6k+'%\nZGGa.ǃ#ܝy$熵y36本 ?9>@ ~)"Z4Gh"6@WcǠBZ #}4`)<V$FHGb1ن0onNS)XNOPZ ~5?cwMC&w$/67ou7n$迦i.^(֖]bi*?8m_{c.l9Yn z A3З夵 + 1'o~^SSn%']i*E/!g2̱6k֪utN0v#܍1ښhd遉9w?5\E_Rc, +LMQJ. Ǖ@W{A5  1'n~qDfH0ߚq+vMyz{Gԓ0NJ>ۻԪFpېHT-r7\Aoѡ +X\KXC>+Y#񃵣jhzL@#M_8w[ ص@O[6x:?0c?տy2 ט >V̟<A6ԕ֔:U._1)-{?�/;[_^q?D2&@YAy+W͂' ѱTB+LS6duxiup{w@!+b+} H􍪑ױY k<ᗲj8olXϭ384\SWnnN$konZZGML ϋKK+?9/ks#�!SI_i<0uEΡ/r/x'seRF8mV9x= Q舴[@!+*i%s[ +׾МmȝٶM:Ģ2kk"jb6vnur{B顽'dY_rހ/47(&m+m8׆*@Wp괰H申'7:J_fT36y΅>om,=�wIuN@/i #7CL1VՄt9WXYXb4cI_>`_71%~pJjU9ɘ6;:C+}6-SA_@hO,cx +8fg1~_Hg~ǔC^w/9qS8VRۇ;0WEAC/fi7�]< :utԁnHkA b"FSCccVtx +LE #ԸBZ⍠S@!0;c3<|݇ GQELEo;}f<t :;%Mv`) zNb~_{Iׁ2žw*=$b +2LN ʻT@[hA^6Xzx( ?耴D,S@_**YS ص>O>Dopߓ+ b +reѷN3onN%^'"hsqFߌeL 9#?0?gX}=^=(נU11hhbl h +Q+K| .,saYv.wci`DD\{.x793;9kl]A.JPuR񤊬͝S5N+{d1Z5"g:F=Qߨsm<?"rabce|&uCKǓ*6g-M f:Yc_hš)Rhkz:F]iS}%zRuemgu1**oڼy"ƬbeVǑ1zM]={YYJV#>+J1׍swlTT+-m;3STTcA?hM:5}z؈{+F0~=A+Ӧs?-J eOs0=%p2|0WmCۂ:.QQQ͛'G[H䂻gaLոHO'kkrw*g鴅\jp]Q:ZnVؚ|CU,hk;9fl0ǂ[5pYWDubq9|)~=5Ytmy4׏}|S;p7w2b?th5ue^8oQΊos7&NΏ͝^kvFy`q섺sLvr!诅s}cV1)~P9Z=f&2MԵ,LҖ{}d]j(]ϠNQ[ԯwj,m<?Wm<q|$?3ѕ[-VQja,Yxܐ1#"g85|wUg{~W5}l2ڐ!_.oe5{[lU`߽ q<1 'Vone~gEVuzE5L0^ShnNmN>GnS#.t{2Wv;|Íڜ9UZsSA!͛o؈ꨨyK - nnϜ.RמB3|z#5[TTP>E9G;CE5E6oj <kQ597&Nu.͈_plp3PgXE;k>5n@>|MvrA}%¸ک?S>ى+5">a 8X-9Ytޗ1?[<f<{&|>Jm;vJ'PӲX+mO:J;PTQ֚ho/ճڼyI4ZJy)TCV15+1hUG|-|VdmȀb\)'}.t;,}?f'o2Um?m!W>n Ϛc{|wG\DZif&pHW [e[2౥spXRן +Lg['gY>uzD]J}7ƺ(MS#Y[ Sܹ9r@8ul'k<^ )?8:8v@c O& +s nK#eMqL>[JW.?!j7^s 9&ծcƏd0ierq{d|(p7{Uڛ'L�aMNAee^8wyYY>Um Osm{Q#vAݡZԭ ***yW4`w3b0x3G<Gnk,|/ր6$L*4z~hRL�ߛgރ1>j#'F+fMvr-{ig#NSu^<*}&凱Xc8(GN?;FalVbֆTYt'.wxn]Ҹ Rן Yϱ[rԾuT:.PQQ=ڼy@AzVL<5.#,25 ,(ä|\W+ǝrQXՌm?9iPxR{.t{r+555n-vϴڍܝyU#uyVWж^P~$=* uBNڧ,ySD('wm3?W,LRǍ)<$#�YsXx _}l1 +OE<4Da"'@R򇻼063!MEI]{__>m!_s1>B*g uzB]Pg7kQQ͛'ʴK3Cʒ?˚Oj/M՗[I?>Zj6/LѕqXM};.Ch\GLnk,T:U;<|8raUfk:RWy aCRyU|by=X+ˤ  F5X/%m`rZ#3Ey竻- |zX SYƩڼy"Ůf\U$@,ԑ`Ҹ (d'"~EueaA5f5F(F c -h$(jP,"kH+:S*d?JN%7}Lm^_կ +meTj<VUa>w%0?us[bri^jY%4˻?v}}3z{>ZK[?hm~4SMh?BPJY>*`cdwl "t1_aڇ)/J֠MCpA][",,lWmkMV, /7?GO{� @r%bgasyb(L wkoFjea2 57揔{mBqoa$Rlɉ~w/�z$'Yjx1p1+/ }8s</甪2 pUB:+b59m\`y4&cK '/7{�7? 9R9(Dج> y�r]h_R>~XȻW�9w а3/ixaBTptШ5g``~۵q"�HNu2 IuQ9z31x +I}c"a>�<=<v[|VR7?}zf32xTna% )Dy̓݃�g$'!� o^ +^•%刣!OՐ3 S%/%y�كI�Xw.cآר[Рo?]IܧJk� uJ7DL[m[o7̯˻෹uq|dwO�HNB�:Eםz6X/9 +q8|"7w�$'!�`݌ +X6fENӪ*]p^RkՁgokBcA?Żg��?��V(f]&3R[ otk(94߇<n Pм.O>DJ ûG��@$�@w~c)ۖ& ~8Q5?az3>qFhzSݩ^��X4f'tBqFzhew f2z<W<\UUWR"p7 �1zeq%9zIl3͙{Vb}0C:R=T_3՛{�eK gͦl~Z(\A0Ch*I |]̎*)L=�&x'<ʳ0QWՃk?NT/ՏHR}y{ �\? sޞ9;9={f*S7De]өm5^s܍>z }8k�xzJ%;jFJY?F eGoeOQַm.Ւ&թJ[ө~|-gxlgL!Cah9{|lmYeȿ/X{ @~ bkB*$ z5ꖶ ew*[79~<T +I +:Qc/>#@<d*sqck&+@Y~N"X=?=v0dJ*һMJ +<G٨V Z}~iߴՃ"'e*tpuq )['*z$zn%;jF +5^k4k{|<S5&cҺiΌE}~[�WvvI2?б_q,'.vѹ"kckB{&,#mˋuBr^(;bf_nZ C|A|ZE%;uкi1.| Ppl;zAz\o*tpuq )['*덭~+9d/SB-5�xܝpU_rc +B+j4k2R}L{m|yo:/ϣŗDzyl0 1x:iNwѓf=2Æ+mzӐ!=7?湸>6k&+@Y~Nu} +֗`����� \2?:80$ s;[[VYn̈:<}G:;? nS����� 4hn sT S7De?۶z-]d AAA Vd@Oopt!KtdFGDܦLeUꦲbwKS.t  (shy.LqȐ;nUWS"pl         9[[:Q'*몊M ^sy/ YtpuzsE—祢+mt :sbu:7'.͑^2G͞*K;xON( ꂤ?4ǹxpj˓XUͳEKY'>ywcy)2 `湸2Mv_OQw܄ T.1/�UoӊڂHD6D@A@X]SG'MԨNCI.8̮_3g<89+DN-5o5K*`B̢1<–{gGJMw>?9'b mmkmcPE4wL 3ArveV\[bG}ӃӧdL>%O9ڐ5Eez;gO2e#c"y<VGGhE=>jn:kO>1abƋ'ODMަ 1<EB"mN;gk;fc!^^SM_;RQ}l=fC2|ϲ}؟-̚h-CSVLPza:C>龿PԦjփ;};[sƗ#cx҂Q$_dg>|ObF:S ˕#!SWsczUڞ/_JW'_۞}^DxќChctݎGcÆ1<O}D+ɫVbX'a!Zɬi,.Zo5?t(1^Mn<(d@%*lRz>'{XUx6NqZ֩I޻^_w҉C+w;)<ɗ=چIFkmu}(mNۥsŸ0>F?l[;SR)^GɾmyIY;~eM\b򣡬$9_G^zWֶjG$zpe\ûMYL7Z*-Kܱk5o:ڟƾ?WC$w޶Laھvlo+ƅ1ZaϵԤM|;]�??of^Dr +mmdG(|RlԠodPϢ?}!KK8X\Vj' ݙx^S%d Oml6ZksGFi]:W c֞u;%uD?Y:0=8dS{M erO\SK˴}1I\𾡬$bzb<5|yܓ1<JՑFɾ}}B%ZaaVj'>h]y +Sn%~#ct8mN('c70gl5Cˏyf(5=LySqZ֩Iug+]0|Hϓ|}xԽNs+ 91sJF0Z!Գ_ طZnXks3B.^鬯=}E#!csloKhd<YT],?y":Ou:E]|>cyَ'rO$rn5ڼo}sgusC2]:Ty^l_ڇ'Р 6|F2xb T]pum֬Ubޝm곘 %ir)\7^bk#cxCYÍHٯq^S^zCBl"cyykgVTji99햡^68}jj(ߝubِ%gkmu#GB!sv*}~d:^)ni6 oSA70y3Ɖm, >t<52W#1<GIg1=浆]=,޶9tO>o~dkv/`cqР c!gkx_2vobRuH]iys}T45ٷS7{~N-q*>㣞yP:7Qa31����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� �骾 endstream endobj 281 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 37021/Name/X/SMask 528 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUKK F Q�Y"H!b- FFԊ#I2AVYLAAﰧh=-z~_ޜWr/����������������������������������������������������������������������������������������������������������������������������������������������������������������3|\ζmہ'g,ɺ/�� .wϺ1w>jxce+x1uϯuo��@<jmqY��mGh;:~:4��X5nݲflj+}߯nXWVR\u{��@Dlѷ~K',\=us��ǡᮬqt纚ɽ?oW\6:��OrMe'}~s\ǖ_0.1"t}Sr&*RJ*Ӓ}- \䏫ƌ=ǎՕKJz.RJ)RaWA(j5Go6o>;T3fO)s*hص6;VYcuiɾm)杽?SW;HGsL'%n;+?w\Nk_5G?\7ō[7Og.gs{?w\sqa?XUuᖽG:Z?Eu咒gs{?w\sqa?(Tp=;. 9~0*\8;/8qapsDžTپFL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@kĤggO)˺�� y~vtֽ��o1-{;�?I<'5g欬�b3χZvn_u?��L &='ǏuK��"y5m?yuR=�pALzs͊š˳ �bb�־55b!��m?��&� l1?��&� l1?��&kkxbxm�pAL6LEEt�@⩇"-\{ŕ-w~�Hyn|e�87n&rg��$b2y>Ԝ?溹��d \]从?G_x v�@B &ao[~yrC5��rq<<o u�@o11��a{|!5b!��m?��&EEwIۦMO}G~EaժQ;+^ZΑ|Ruws;GmՀΑ|~ۖcʕ#²8s8s8Gw0L'XnhY_V3'MN}gcmƪ;G;tP999997쮑?��>11��a �611��a �6Fu_AQwH( SuʴM!=gr5&jTphjDP28Xp9UAX4.ZÄ:S4Gh'm"W{ޯgewˌ|MC���hZw��k%^VR_K���D/" Wh ��kt>[ikQa���n5DԴ&?���{ J4GoDŽ_?���{ 眶c|��kD O f8-̚5:za3S&Mzsg^׉OګIM���K쯁L4+EGs^ف?ƺ[���^pe4&O֮O~yq8?υq\zG��`D~@h55pZ.���iqC<&?���0=V?{㦱��@̷6?a}���JPI?~}{���)vUR!���L43 ſ3L}���fN CTgOĿ{}���4mbe;,??pwmGe���iMbm 4Gj9|y���i]p;*G^moȾ ���mxnVPIH+/~rLg��cbPI{ƈs>A]���f?˾W6JČnse-&.���3s[+.3E?1asZme��`f~RJG^}S]���fv,Эf`+8٧��R|gT2?=5}/O}��Ib<E?hFexTWn}��w؎)v Twݝ燲o��0NjfT2XЭot/d��`FCu}b= [>!^[0g���LE/?cYk32Ⱦ��L +wjoiT4X<uzu���$2ٙL@Ix>[S,>���3l_>knd8\0[��0]jb͏'O}"��),NXegPPt`co��0#{kIꏘɚ\U}#��UtF@UCx*}';uGo��0溁J<W+C-F���3+Y N?Kzf3��d+sgPp>_'N���:+k]ʆ돘ɚpf˾��@eڂ[ʆT5U+��PYRdlPH,Yп}'��()ՍoV&~e +��.NhQK@u#œ&'{[��Tt<7'^gr<fٙmuT][��Tz\`[jFN[e +��NK[c)3MsZ~0/e +��κaYE F˳$'-}.��RR. mM?`ٯS ^���X=-vV¾Ճ0M}Uu<f)]yO��JbG=%vW3?dQp좡wv\W}77N���QE'q_#vW0G􅀡iZids$7;^���Ѥ$/gQ4~kwߵ<O,Fk-Y>.д՚L~?9i_�� *,]&v|M{ZhE,FY/uKKMGo8a_�� u$vSYT쫹<?xܟNk:RS\\��jV$SxKv#m0hDZxxY{38.5_`a?MX#gfWOWSo +��]N{+;Ѷbf)]ש;/W\憱Evvꮏ[</7}k?|^iԙq HCmNղkA;z[Qh" +EĊ +(H$7r b@E@jZwԮ.͓w>3?&$g| ƞ4nܠ+*<���t}<=uuӳZ'Kzߍ\D"D[yISΚ#(-ڃ^:G1V[,&ݓ<���IdKR/儗 6kO?П ׭?E0际~CVk"z-4�+���� hhEE5u3_?PkU^fÕ*%P~c 5s���!FqMGDa]bLԑ=Ŋ9"oey"X$m-]4GE5/{���t7}k,uTRq^,p#aU5m#J{Sߗͱ<KW>>oW]���[ + u.KQSk c�gJ_rEaEd>}G`j;ꮗ-ֳ9C8����݄ }[)oR) +HcC,fe"Ņ??r)J$)gIցQLǩ?nضo ^_W*N9����uʌ*|˝DsqiSUEedi?;rsue\NvlFuQgGXA0}+j;X7Wc}nv6���@z'u_#ݓ q ONݑ<%:N}{w:7?<"25Zef1|=99kdF}{0;���@xc g=?|mDD$)=پحo-}{CfOg:~ Uq|3V8{5)rY���#6l}?ݡ@w9I|wȂ]oi{hj8՝ގ|����MCDJ"Z\?tepɎ贪;Ǘ[k}d]Qa���)q^Z#B?NRY֕- X%jn;Bf}]����Z$W _DJQ1n-lY~x/}?囻 [v!}���lE$bU*YU5aIlka�gbCfK/괪˳w==cG����607gY"ꣴI +�tnNh\<P~|"6wWd ���` 'Y?obip<QG_Q` 8[tflGV:x읾:V_// ���%64ԥ.횇Nٰ):QW 8[tu~s-f[{���t?IӸ1mz[p&?F(/Օ\</~R}䌋H$���:e숑~j>_d:?gWDwA'0-ڝ>gL3|:���@H$:lΡKuSmV?cM}0Tǩ\n.QRY���XkkM=Fl8=?۲3iLY<wF\ټw6\���X@|LF1}Sa�^w? wqO6ϧlceJ'���:_nR~SŴmCIcL<u +8{t>)>"|ʫ4B?���I~V~StΡX={p&?<"01e9Ms aS޲*Cg����"nnZ#qMC,K�gʜ;5ն3T2H����.s֨4 qR+ګ3qT9.!x^kg^g;U����E$b'Uֆ`㖡.1\N٢!3ܡ~����|dѦSƘN7˞Q1{ZƒV@}Q����XT.˓<iܸa贝 C}CcI+$honesk*=#n���ߞhh q uMZ$ #(1}#x/}\1ݧS~.����0=tjLG%~^5)k?�:Αx$VX8}xv1Vé~|X���onf3=PPP`�8GtV|q 6y����<#KO ^QUl-1鸢U9;G:3qotVnX#x?fG H����Ё>&WqL�Xc9{Mb7QrTu,D"JDҶ#J.͌N QOZs$/3K7(|?3 #g}/8gXA�x5?x)4ZslOt80^N����bN,?t%ݩmЬ"}vRyˣ+;)?{-'Ajh.s<$؈س `{-���Ёn*[?emU|,ǰ<x6j3n8<?iKO']{/���qXѨAi<;JԧbZ͸ri=Xna%4+h{&0%m]SlxyW[J$W���&o4{X,k0EL<ey}&gM65 6"Ìf\gofzxNڹ>(_۱z���M,yv>.3Z;FFQ{B[֧7E]Il߶ss1eRr ?lJ<4ZШv=M/fʾ���x7Y[=eFÜiuD//WXna3z<QzTjxKwR3-)���;d $;<?_Sɼ٤sUջƯO~,qۮy L f2%OUh{uby���[g r_">2dMZfzSGybw賲t yuh'{E���֍fϡ=m1na+Ž;Ɏ,L +9b4D=2kP;RiUf_M?KؐU2_! FY禫zG41ۥݳMxvJtQV? s(!h�� $il'\Ή+oܾc}ӥ_=ܵq^|K}@CGGշг#sKRhő,P_LT~}V|iނֿaI +7O'GJ`J,э=C}y`V݇���:49͜8|l<6_q 4ʺg?dwˈr߃QUH7IP|_=ˣs?+t\f.,1֜_nCeGwvhӾٳۆ���:3O[>뗯Vay8+IŞ〘K~=, +g 49h9=۞y ,%ޫ��0i]k$ՂZ^AIV +w{q89,|%89 L<FqIas?ZE5k-x +��׳7_DJ`y@ף2/Ɯ}Jwuy\s>7X?eQf.m{*6:S/x/ ��$1712O*:4<Ql~,=[4j2g~cr"AUŸH`J|e˳d vjy<��0JbߟLAIk<U֞Dz~q@LS٪?D!*9XI ٔ#05?DgUI{lɃ��6h֤ɴ~Aw~:F"|Nk(dު-Q6_'$ !Ҹ%ʰ<-㝍?[peŞ6e:ֽ9?5���ޚ? NÞI/de]k`St^I`< +mHD)>uflN\;1ayȿ΍7]z#/x;��xENͥ];?EԙUrN\ChsF'! #-D!,\;1Frdt;wc;嫕^��+HhΔgӦǖ +jk|{&RSƜ}.)yt;eirޙL1vtAXixd8,w 7��9}1uy4o7>FxOq#J矹1a,Xo=)2[$hٮm'!:R":��6J7uEy +jm~sl:P|)Q|y<ґwB�Sec^'4 + +{ZfNw��UZ(J +LPWi&K;[335Ost%; 2&X?<(+hhĥ\b1.d*fHtEDQP\#ѨN( BM7яAELe\V@MI*NM_jh_}~Unխz{ã3A*2P `=>���6DGG2k'I w9%jW|AH|z1Ѽa,T}H:�`/z^9U(Α$~<aSt1mJ;lTjH3/>:��`id_t԰òLYqYCKfWa;->ȎuB�|!ooliLw]/,d44i'*T9U$#QNJ��ӳ'YI;H~ļ[<W^c i?LHYzy#C'W>/x<ȱΎ+iyҽ?DwS,K_h}cZg���Fs RmSVнBuYj4N%*o؂n~arD_N$ڝo m^齮?ī=V:{؁*Kr2B?q ��Ю1w]#yKFNuo}b ژ,8}Kԓ:U kyhh齮?Vk +Zj{A|���ƷGSVϒ_fyϾ[L6̃D\*/H[|+-aCMr8_(RSw!iKԈW?a���]o:e>dL[:m,=ÑDR~DeyY{|T1_Cni{W Vuӫ2���НxƟע̴Vyk\=RiY=h0pdYRT^HX=􏑑~lhoRũů~���=@vm0Pf*.u L k?lJsۅD#/h`u?�L][&St<MN2命9 Z;R %QFN(k5j;a ���prp ߟHl44;#Ψ4TSwQƐ+>tq#)^>BC4O\ˊ`q,EWLFsj썌p5p&H5k^7̓^[|۳45n>GXq i} k��o?0|Ͳs߸ILqLk}XaH}T{aHy,ќn4Drj; +IB^Z{|T:Xv<aC>?Wci��x^N=|Xvhܦ^'9kYxG&2!$w\ +نNɯdr𙼯} 112%qxocAryoCH{Nf��x*CB6,W_jT7Vv\Q|$m~uA�|^(${5ZI&>S')(Q_ԧ%?n[sh ��bNFR6FyL̎>[/ A珤VT4W6[ZN>}]<ǿz��`3|^řiFգ)y\NAT gM;]%:Ӡ�[ZoRݫ˶/! +5iIY��+#"&u@qk6Ռq<>_Bt&>S}KLl>(e,]i{Oity{0֣�nX$">SHQzUzY-ߟrЯ">SB!J4uA� +_pVx"#bE-��Ynd{hhbIzQi{byz^'Z9^D4?:ˠ�[*ȩ}yy �.P v#Abe%F" EYf`Brώ[DPenda?-1er!}U~X@HMIbY��vv?})aFNuziq&f}uEzzxo =w +Yg`PȤE=gw~{1��0E,'=6 In3j5 WoZnR37-/!4/dR:|֛>({KrPq=~g ��e 8g.IݶuL<+inS-=g Anuc3!YKwUn";۷lOҩjI55h"1�+AdoO<ǿCbWHj z:ʤ +SmW;} V9AQuvA�Upm9o2a\"FKlh\zF76jVP7)5A2 0;" 3&Ks ZԤպզ:qIy>|>yVIy3��ҕNF>{QϬW\]ijmH l)Npu3,�ct@7SfNsUA[$>j��x!$3:r"眔FkJg| '{xT-α`� '61 s}��4ڹ1ci_|eT,Lش2S_ţˉX?IŻ`��ᓩXP_Qa=M+u��g.Mq#Y +K_cy\OսGU& l^/O +�`Q0+jF y7�a{#pCGԲC,uGR+?!]RB$ ^Lλ`�1~Q^tD44͠ e_$>o�ЫKׇ{C]h0%̳FԦu& BTrUw`�1fnWAXgй9nG�):R7=7ʒ5FG uD>N̻`�`ǰ{5W|4d^DL }��q ur"P~{d]iְn$aڣա>^`�`3)?+ΨW]΢^[=}�V +Kޱ \brpwUsբ/e?%KQ%Ȼ`�8b$웚>#g>7got2s�zvB5[",iQ8ŲŬW6Vnx[R"!|hw(WY�Nq01Y:BLL]WNл[G�h8;:GFSjLt,2AswJ?s"(LJ>Y[<w�ɈuLOpeupLGsIGTOvzGwx=�e0(E3=(.8Ur :֟>7[]yw�XtX(*fӭ= ];>~��J;H8Tm`X&TF\޸HſGA_s_(`�dĺ?svʾ>GI'Yٗ�^ MKXoiY6\(M+j4vv~{ِ.a.;�?G% uWvVfԝϾFAU۩}{W��x t؉}|>6j'YܫV=ĥ8Wg?O# ΌLUF Df6)rEOw��8;:҇#GQUoR쑳yn1D9>yeƿŻ{`�tľ?:MzչsJmVpd@Nuޭm;�� &E- +pL 6 + ,ˎ9\Y~N!|5^.K=Xhy_ Ͻ{`�tľ?9ɣ Y?$(/&FDt}�gӽc' +㐕6eIP_SfÍLˈd^{ZI\ ;�GT,/^/OmYMfNu;WWW� xXRb^5'˼3)w!_/O<lyY{ޝgcLn4WYgV"֑]�`8J$oߥe:hiY>>Q\K:–cQ {ߣixw �{3T7լ\e]MfΨSi:�+,6ńL5oX~}:<;$Hſ@['VF5?�x>e0^o]D&A}yx�b~(E=uA<$(/ޭy`lʕDroBe9{c;�Ϗ=akٷ^kͰ{sμ�Q11wc-cyS&nUKU<GM Qab_] cO7k}|3Pկ �Z3{7[퍆WĦ){2Hǿ@[g]_ϻ[`�b$ahje*N4h89�Z C_/pݺ7a[g7II5W˦~X޼(-?�x1m03MzEmL,;BT&hXЙ�Rן".rV2X~屩wKNpހTmy/n'ͻS`�%\ʾvɤm3:pAWj�DB#bBB۪wl]`)ϲLP|ۇ?_5+ ;@QFTqG2"Se;XDPZQ +H IKEn  EgZ]-ApZ#+gobh}EQVcH{ ]^^){O+�96_0 :>e|8c&W$ͤ?e[C,5 ŕnJvYB(%NA~??kN$f˵$Uc2iA#6޷_'sti y/*2 Ok9?dyte΁(J1oXҧ#F%0 Hae\HQ%_ӽL8n@7qfO&vVrׯk;j9ٰվ�6HzSY1Q"'s.Aӟ}Q=gSDPd0hADู3'/- }'6FuTm]y?y^N�3EQU~`a.Qh?r0BTx)_\2,`2]s63ʴyU.|vc-wEX)hEC`@^3ٰ5*O +r 6f`łplϞ11JeLrK9MƂwEсo 8车w20t=9K@(+x5{]ټ2!u+VBԁiӪt]r?+2 Ov?ۙVHq'(nɜ(ĥ^w20t==b[3hZik +$S'X.W7ıũ<kRy PEV }<K{g 9K@\QpyUu>h +yc2am; E_FDW獶{'97I@QjR +2i ?d`x^ 9}qe|av7Evp"#!6P%4o? }\4F }EQK$qSgwz^K@"T{FU33r!K1K&tާVr.gnA2@B֣(jW d>9M{W Y`!$%│c -LL__?4ŭ׳D*,7"ÚoM6%E;*Ӓ^ +:*=W +9�<gEQT[k L{G-D_ OZqܙxtaՑ.\wIPR[m:tUE$:̵&iqgv(*}PD23,GQN^ˏ$syg)?mdɟ9sIh s?{ԚG)}*[ A$u+VB9Uܙ a5>w{5@FQ~9k?=2n b@ikS.GwGy;@VfQZͻ ;h(ke)a#31<̡$Oyq5\%}PFQ}Sl[-#sn b@ l 2靸#7?z+12ԠG?|f]lCYJd0ׇsAX{z*]5 2H~Zf{;ւI6(gu&;f Epᨏi]m]f;׿S@)\].�ߕD)2ba)Ab;rx ti ye*<*X>$1xKya2i"d(`pk JI}I +Q7 l{_{ݑli~RDR/&u$UwTtyf.HEQE%}٫sI`vy`q$(L__8f^Y?^ 7C:*_7~ڻHd5@ Nvḟ,>_)4^*KKG㞖=[[EQ-Qaڻ6lƎ6.8۳TQYXKϫ%psYIuSg7$>会=T&oHat:뭩a#{")ەټk~<ۙv2ŕ|EQE{Z{�Nܖ@SiddOh#&# 7E +k&31mٳ2$ԑ/O+<zS#A,ccpvX Jc [KM,s?SQEW{,R9woK{6ɞ6 !x8]0zzr_uO[eP>P!l<{8d Va™ `Ǭp)Yb<j{9~5}%p� +bBVbu>ZVQ*xYBIHǸԪ*8Vd<\fi /y|b0}{., ��,5Yw-@l1Cmʮq Z0msIʟZ*ݗ6jԷ{t7QC<IdηZUӽ~8τgߙ��ygie*3O;~Vx)NEįKBN6dKv&nHyD=}jRQFG&ܶofUrZY#��XWڳ̸ɬ;Va <V"EZյjs浄~g Ms <g.ݸ]r8¨Q\hZ|Vp_\!�}��]j,[֝o?r"2b'Ω~ʹ<ݺH ~C!dЖ#Ick\.T<[h=o]0��6# ҼFv`<뮷eOx9g|jSY)j?[V/ +vdL2dȚŎg4[҄ }Áhdu��`;n iҞe )/oe f=Vd1[ݺ~VȂiILxx̄~Uiw?eZխ&A|vO;(BT{ ��l'B{ue1;a <v*Q^l(M4GO~MH6M<X?Τ xhm`m[GS =sdDmo=;VB2��ؗ%i~e)f4f=ޥgcԨ=~/3#p@StHh*;vFV}AV'Gw{\7V|��>? g�)DwByb}XHȅ)mGIƽ?,nஒ/1d ;ä$.bſ y6J +*VǾ��Ojzyګ` <ՅlnN[`y~FJعjU9sɘÈşw9&Cđ< ᙝrH῜|;+EO7�?i'Dt{W6(ʚ<tBZT#jj n2MFmT))f#.s2 w oc>l|J-Br*v|T䘝^iMl6jdlr҄_ׯk w_ճAܛYCH?��Sָ +'2t{׳h=N/sfRF@YedgtknsʴƪٕKʛ'>ٲ~ƿJf{[->>{��y*G:n >6.'Ox=&>:7Rg"\S"BJ9͒˾+���,*Gv%#/(.'Ox}g\s���[wǽho.<77Ox}.Bor,OQp&Gt:��=Y#oIu`tbћOwc}��تG%оκS?:EMrZ��d, d^ɺS?:oU ��5=Iug+`XF^&-e]e�� +ڋe9'd)ڞa <2]HqE��VV8urG]mϰ?a9ܴ8Ny3ӏ}��ZV�!9cYw@x +L@Iu,w>���km5^6#뎶wOvt&U {��ڃf<@x +eyELV2��J[E?ڶy7�)[ȠU��?ڃtRNS?,o zn=Nĺ���h!*y')ֱ-[Bޒ{��� V`]`XyVu^4]���U얙h. S?g<nASɾ���l)EqYw0o?a=g|JéF֝���`m ƓޣǺyZ&FϷ1^���F@ҝCYw/?a]a"OYS~)݇}?���X7sǺ{yO=LϺ#���,aЛu +)"&yruNq=×}O���X +5ozS?ƌB'zm5Yw��< +Lm>S?΁c :USv���,͗kpw_PdGu]ZntZVTa(dnI.SY!L".!O" #h)ZY GnG{5A;zLx?ҢڎtutWN ��ժIռ8/ꍵkNAƨ`wnn��pv5FFv[#멤f r�I~5z[#/iӊޡi��^U0&k'o\Ktn|=;mvC��W'Ӄ}vBzS#:ƬϬn��_cr?Hl:Ğ[$vK��u/VJǴ[IM3,}Z[_*C��S.mF5t6 4Φcidlr*ϩ]�NS{6JiMwqb3_?v[��k_^IMЗZvnwm��p+S0N-]Hl:g0A_{ ڍ�VW&IW͌TΦc +2B �&I:Hp t ;=Ywch>r'M-n ��7UW*}Ni2?p>gw k?<ODi�9K ndcp~E uwS9={2ﾏ�@+;&]>i72ұ?pwF*mpkp'Ew �D+{c+=:v773Lfӊ˂_3B?�#]DOig㶦M|5Ý^9s�<H)wGM 1M='3>1ý=_M�"tG3órv 륗eZr1YS?щ̖]黵[�v'Uo!ڷ~ļ;(6.771^FdnxWz|-?w?r<R.3ɞIOf=�Koҝ:i70[?4N7&vHTdl[^?6˜Q~eb$y�tfO tG@|NcptOmgƏ(|Znz_>-<q�׵Q1қi?rۼ=3(wV+~��)eL0Ϣ5?8\hOOya.c._}铹ڍ�VKg:z<O@S��{s1җM+zkwl:;l.9\}PU��{ޒY%}hwl:{̘<n}k^�nHWFN8"*P-�{IG'Mp^ $Pv�qoKO^uEmiΦcO=~>F_��~HGR +i7 ul:tJ`v83-k7 �>Sh7 ul:;_䥠SplN(�C!o-Cݱ?8Nщ=M^bo D �ŸBh ul:{]LX�7H7b%4n Rt5�_{&#H).;gӱ?ܭ2'Ӄm�;V[.;gӱ?칝^ v��b+un2*PX9�@ 3FY/nvxmި㯽ڭ�UӒC}vpMLo {�,c 7l:=ڍ1GJ|~~��zU9 F?8aav��zTFz0t6mƒcp6.-uzs~��OC M&<8gӱ?af㯾~v� r/$gӱ?4ycjs=<z�DM0?oY?8ae%ʏ !�^V^WolbKy*Gh7�O^6vPM"'gj?s~� G0fv{PMSIwbyv� bۃl:s>/s3>�ߗ.=fsA`p6~ =Lni=-N�ꏼ.yyk7 t#et㯹|hFv+�[pBT*R mhH + @EK+@ ! +DD$B0@Bew&@"t#P 3`~6ț>gWHA?IaD󓂿붖;%�(Cnx|G7 &=nPQ|<En�nADymwb. bI׾�uCVF~ yZmA?IaDEuwkX �~﯈dzSo +ƒAL +#93v6JKQ�@IoKKKkGtz"'-�tOK̙}K>bRkIEៃֆ�pm􋕅iGgswWTW�W&=-}--}C^bRmLޜ[ڷ�peynh^Oֿ�',=[}3AL +}27ּXg�ߐ^~wǦFikbR-%o-�>$To?Ia࢜-j=S�`Y˯,վ &evy-{Ծ��::eg]bRԳW3{i]�f_?._6@.=m+.xܧv> IJ8_zY6@)Oyoi`�Fҿ=<M=?Ia= ̞ja�&g&־1){`+WNH׿� ow󤇵oAzĪش!k_JG-'.+5u67[dҳ ՛IJj� 5iV׆i>?\+}I}m|?:ym�?25Y65nO?{J?ϱ?p-*6N]۴<V>_gVn'cr:omqq߭[>hU Uem$ҫu^GvÞĎl)V\4Qn3ڶٴr{9:"aUZln=ۘBVI:J/Oz1*eoV>^1kVZ[WJJ֜9:jnynb <Ѿ�`cW {cp[LL\~tl͞2KkC&9߭[?ecVQfH&=*}G; Ї!ZgUZq]C~>ݟikSukjo7�DX^SUn?HswۭcStD (Έ\2C.7Ʒ5Rw`?SH3{io�Dg#\lv~d vK񫫓de_>~BW]6.=m_NH׿�IβZTnWO;An7<AvD˙ MKTl{L׮~9^gsCc%�"ecM1OQ.G`b=Ӆ˖><I1guƄ??>,n\Jܞ?:uMHpaZ渼۴;AV^ݎõOKLzrU?XZqlܦw�qV:pvw#?Iafܕh u^G �HERzSyĤ?p[4,Z}<xvg#2?Ia3d9r<?׾�`'U>tcVy0Fb@g1QkCu#q +L׿�`-Kzq}MYvW#r?Ial:Wom*@;w{񁹿WhD61)tk3z<mg.Ѿ�le҇dkw3":Dy�4?`#7Aa1)tiCu۶g�@8eX:҇ڝ 3?Ia evxAX�:/@OzPa1)9݃VۙE � <xȜq ?Ia 2>&;ߩ^��$='}7lͣ ?Ia  +6� eYV}5Iv<bRe>aT9}) �Йeswڝ 3?Ia eF#/k+�@gȒZAL +ᒱ-y־5�t/v'^U3Hca61)K!V`}<�cg^˗~XAL +'s9߫}}�z_gcރ0B"ʠX/H[aX'XT$ p 0HkDa&gF,! %xiQDs/[qh$=}g>3Lyl?; -e[Јgr7�\4[r3Tc@,y84k;�.W1Eu"v?; *$f&k<S2R=�}Α;Q,SNC*Vh5PW�@o"Oa_ El0vTkmPuڗ�H>|W[iPїV%D@_Uo �NSO'L&c +~{Dy_;�.tْOvީ:+(,M7ŮUޝ��w$ɥ@bF`4X +y*"Ag-�bPhUqI>H6cJƭkSo?�&!#=5v]lKJ]!�bL?`Evn%'6橾E�Ė/NnʗRڰo4y7ݐz{@l8I]rg}@BNCU%8_?_.`ogJFj7Ed\iR4Ow\>`O +4MrEFNQ}9M?}4w +�{\iv3Wyݡ0vAjQְh?\vV�3W$_f9:뀞?; "yWϵ<f`NJ:?; dgTy_͘nsl ɓg*'6?; $13Y+z=#bTv}~1�),M\Qm70v5S=lw]:wG@gqm'3 c ]!>%N= :u&Q^箒Qe@_?; jT֏6C5�MrBBrc3 NC@43W z?]`M4MrBBrCuvivS 3 c!{4w�k\|H6BufWiYk"FlSIk{5Hag?`_ϻY/V}�[wH.,*:A`4jyϷO+yvܣ:E`4Ibf5?bTvޮƹȬ -/Zl?`7I+j疈>y;wT; $TgUjƁ&ٻwCޞ[5MT7HGxY1!^^_r@uXq}435q3˚ n_Ɏ4]*<R:w"fw%{.^ ??+N{gMJe9+==Gݴ[d$FA�7⸊fv3E{zmvgػ)Nп>9==}W9@0V5 7βN6ƛO. KzzXp33ao}$â%�㣗@W/{:kB`:;&}|?OW/X3ĊR5OwH:_LP~7:Dz/":cD`cX:̻dQOh?Uct'=?KnY7SG̽hoK =}V-@0=Nt>0n\9@{4qЋWUyiHOE@uc7SG<kZDzϪ3 fזlΐfذ/ߡ=/re|kn?Vq͞ -*z߀pk"%G=od_eo~\Xu�AKo2&bZniƥ_]b wcqscU0~B ' lw{Vd_eoeUg0N0V宯3b^rP0ewmkSMAy +@d?eOZw̽U`0V%͖ѹWf?PܽMr刞 Mޜzm2ת�\LRFWUuf�*?~UfWN6VΆ<{Y _~|-\/7NF|=jyʳPil<үw;*|vߎk2m~nae~!.$f&kk<EU-Y:_â1o-㨪q"+>}δ_-/.vy~geW1EuNF#m߻)?=*#HcTZm04I+.8JXT,a#]y..;"P`TmQӨq982{o~n]zI A:sc<S蔫(7~4n5jdʡk"=\\)l;|Am0PUt[koF<ZGBo_ k1#cnk}jX$]Ӭk6;y .MWH62En)62yxv|3ldzB_2U7tz] +n@A!pHmx+Q(e ~rTeese!q+yښ9:K3Vn7_G'y \J + 6%ϗC+^cg&?{'wf%c9KdDE O´`$swtCƃ >}Vӝ.]4Hw?0CNj.uͿ^B6MN^אw6=Ano`s[wkJV:܅\8spyOBnޏJOVB>SP&`edk@w?Сq`)\?.fApWэy�e4i1P/dtzҮפ쯶kbՅPcmilRo):z(urv +>*fnΩoӜA^kU|`itfwpDy(2;?\H[SABĝ@!p�RtUszB<0WASe m ^L7l)j)ths?Acr{(r�|߰Xg11\ZBd?τuD.�4syemۅDlàRZnS/zŪCQ椷W@Ų!h^C{k q!ROÏdzv*?0?t+$pZ~,{ N2ۥLR}Z36k"@Oߟtk:+?0?޲̰!v[m0L~CaiJ ͆*fVC[E:ɳw~vps|ҴYDJ;yߌO|6/u3ᰑ3ګ%V] {+N6쀎@OWh#;CLcѧ?g뱘/ zƼEP/dt~=tQik;W۵UqOBvΦ80[9;xM +giz)r1WGU4tYɯWG@{MgE  XO&g%;x2>k^vC +vO6;?0.mwG*Zy4`RsDO|\Kk zҟ)m_c/`}x1}?7X7ц賂9u^5pcVؿQnT_<!婞_P !d/ Nگ1o(d2CL*荑zbX +X=MτurYƚ`f;ܱu `툣_ese!q+y֚ŭ雱XIL<- #z)|s}$w, tjuYɯ5]>ҠQďb7(!*ǔzª_iD~$ӛ˞REsn})VJ~sJ~wE9,t e,Sq][1qT}waM5TN] ]p]=}m0w[k2Cm]}pNoYL>d7ӡFٸwOu\>1l"2/^gecY n: +wS^J]ߓSs##M3F:qw@' Gh #dUHWHzw~,_P,NM3$CHEgS\ tC_8ܽt瘵njި܅ϡ}Rpǫh&7b΂]<WEACemCwt|F:ҡ]lS J[@G]{.P͗GO>:jYS@!>ǧ2:e5^J&|߇ Bs6 @ȺBkA&3?0?d/pK}V~3D(ƿH1BkA&;?0?d|Y" %h2OL} f~W59 $AhM"@!@ �BniGg dAϔ:Z"`) הwmW?Doxyo-^.DlS@%<ճJL7*'"/(;QW1VmMj5bIQ|/@XaY^,{waf*ri`5F1SM_;K@+f9o<k]/>ɑkq/*}稨|Q?h1!>9re6s@c غtvT:Udmt>{#-tHO_WÛXs5/#1N}wda򞑊F}ΕkTT*RV\1Uqu -N9[ktOڜi7T1=eZo{EwjM bTl]SOۢTTO;)93zB|wʗE6_j~1K#W f<叡o\!ݣȮҸyisUdnw,WGRQ=P_m֤ORNQQ Q͗7Ɗ o5W/:b T6Q8/hNZ(M{>˭)) zEVͨcp|y#uE{zvxtۍ}Oo(^m'8rU7+Fi3Ob6s +�KuP[736JcP|tsbØGs.Pvlc[x3haI\<rNF4..΋1_X-V^Mv|#O>Y[8V:?6w:zCn\(q4cG={$#jB:/f b.].׍18 ,crB0{+]{S$`^P_RQ)uUQQ 'Q͗7jC'?}`x6|mp[:^<آݶ[Wk<6 Rw8f{}Ll!pHxmYaI?NvW}(ۦ /2y?푣&zg}S?['|tdfvfGxVdgmWXdfWM& c*]M Xol n9n\lѤ Mǖoq6͏͙\atO07\<yW-17:*.wFBN̅t)!ԛE>;2ذ^yIE% +s+ߗ{evTPQ GQ͗_t ϚA*B]6xqkKw}{~غT+&ů`6f)t,آ_>P6'9/?>ƣҸ7MN/xjj> }OI'?k[z:q"cb+njc]oy[zn8Gz0.t)%Դ6w)w*;PNiϡ.U5^**+R6'5 g덧ZWC)+{qN6Bϊ i?6&q>YKw;!/=15yuxj \"5??Nq<L39!7} 1ܖNz]m׫{g'e'_*]J+2mbkq~{߱_iI5|u[8uzD]*}7(K[#x4PhH#ks9{76tt\Hq+cG@ݱD?iN`9'Z;X;9ܒ4XOd|ƒ[V"αi83j0KC:qmӄ\Ul҉?35:"FxʳȮ)]ޠ9·rq/|[aݨ>j0;_hA;AEEE6j~с n& /?=!LQ; +ߋ5+`GrR d{ZwO;ȥ1}Y,exG.`cX y?3iW|lJ q +a,h0<(q4QE򇫩AwB.,rݍ˝![4h nK-=HlR'|ｪ/}=p?C TTTE6_jqn]fi7GMv ,(æG+I-QX͌?:YTxgvg\4H5>n9'[֋μخQMrrqG|$=* uBNڧ+RF(qqqNŤb$3K#T +q=ƀI<G*!l<G_|jrܭ?4c"ryi R"(Nf %S<GHcXҵ: +g P=+O_# +:C)]TTTmԼ?6UM'Rv~:px~leKF_kc5ѸS?;Te'_6mһ-cp.3P2NT]&I8riгov:%5 vzyIaCJy]tdy-;VM&yٍ^KZVGv +g7|iH+OWgb-7QO9-ԗ5NEEտ(K?v/3@0Kjd&P5U&R$Zl44.EDA."ae쁳UX?8,rd2d%ryf~3}aj"~AcɻGRF07UA3z޺ +ʄZ:OQ0GwyݏN }9$7E[,|Ms?{叝Gw_F?Zó!3b2TڏP*ԅ[ytuߓr!Cv.~k?\0ty>e!5$uucgȻ Do-UV&L, /7?GO{� @r9" q!͹ Lm1Δzq߻%ZL2i0kLPۚuzֽ > <϶|_ﳨJ[odGI}Ļ�}5쿘 |o)]L)oK#LxY{o10לh.Es.0?%޽ �dsco" +oKb{M�< R]h?W\>~X`ϻW�O$'Yrxs*{ǗawE, SQ/jkcE = +�xz? 9ɒ�rd{l牄u͟Ef}`!%+$ E= �xv? 9 �y26*8n6|ؙgdK>rgSϻ�HNB�@޼)>8#o%#!OՐ3o߼{�A$�,A^!eE$5֟.9xS34?ODP ?R<\ƽ��$'!�`Y)z ڟpq6B#;n ~)�I�X&SBVpӒY/v\.˼rG6VB~=6!/C��ӁI�X6SrT.8+󕐰j%s.1 _3��ӃI��n+{'zM&#R[ c??hrVZK'" ?#��~ @r�;߱mˍqJzz?ը\b=]P]\_WTw?��d*>PRYn4]Y?de*RЉKf �1춺eqvzIl3~TZ f}>QTW/ՙMu=�@LEP6h?TSS!w4iS?Zcc慠fXޞ� =؎e0QW̓+}.?NT/ՏHR}y{ �0_? S֖9:8<} -R6De]өmޫ.Fa9|o5�yx<=l%ے9#Y/$;Ftb[YCkDkKAu$m^oZY -PoafZskkVYn<~(a9$^cٚ= +I}'z\NŻc ?X?ՁQ! "5T'`xlgzg:ѱKqL_b~o|f +ezл\q5\\(+7<}~h_5 eO/OuzP]3xez\{OЉzcE{&clXmɊ!e)ʄ\/5۵ > K|)ޠ5& c}ѺiΌE}~[�=lmlē[XeELDZؘw +[3csc}a[ns, +GaK 4|iW ~,s7<ρtz=Kϧuzh]_Sa=C�z-=>>y?::98EP?gq"EP{ �w'LXmNtAP(Jyƿ[j++t>]GyHZ/ F<3i.zҬA4zpkU_p23fKqL_bl]7�����62zC^[vL5,R7Gk#fW'g�����Ask4A[ R6De?ښY2T˄   h+og۷ȍ?Ԑ%:2"]yS"u6/'-`Z?NK   h2mϝ?ӉirǍӢrr< AAAAAAAAA$[`mCC&De]U$'+} eAO){[[8FLYcJ';uDN·H}͎yw SsRc|;{B]P+{ :)&xR yq\/\b"^5N+j +h JK"ŘaYvaTDd O4NS: ?z']2~͜g<<5v}ص|,vOk1ʵ+7REͶf2E2^\_2ЗrCi:g20Os}m#V̚șГu:;;P.7Wt+xC^(l_y) ٧)V+2~RϢSsRRuGRw\涬~dZ$Oжg'-MՇwgvlb|GʼnQ{)# ~d wXZۼ==&C!^NL |[_`hG3q:H;  <b{;{ru62v=7 3}-+ mG{~mRYmLXb _؏. +EggS||k?(= ϋ[l{͗;fH-MUe}&cct1]=|c}&cבd"*WGF)w:;֝,#x?$K Y!cٟnF 2WW':cX c!Zmi*)^7`1=p(1Q;:(d|�%2tRz>'kT]t&Vm돕1Z֩I޻PʁCKw:)<-=ڊNz -K]MmHm9c\c̭)-,SGɾmzHY;~eMƮl49O]G~zזh϶G$zhUlݻM7Z(ʶܱckwObޛ!c&C_{uem{Pm_;7 Z{j&w˛!kƉ3?<BkE62v • Z}it1PQcZodPϢ?m!KF۽TRVj YxQ[%d wch1XjlDDjZn.3ƅ1Vamܺ‚Y=uD?Y68#(x]SG͍rOƮlђ^ck˴m1IZg4lb"5~yܓ1܉r[Ѷ}}|%Ntư0Aƪ?BCY۾TRnbzQU*7 WTXskMۥ3ʻs̝=GS~zWvUn\m,mk@eeLuj&ZC*'  B2[)+<yLrrdN̚⤑a"UlW}-떺<njSj;uţ!cstoFkd<YL]8q<W{t<\:CEΎrOp'rn5Yۼos^ߋꏚgusCrn.Cf{uzyCƓWH`]CnZ+zyimd<(׮z -mk*vVeIII|Է޲kyoO.^H1܉4Y@iaAWRw8g (?=Cr6s|<5G3;d2`1}wd$cSDZMVyBXY;sv"K$sC6E!|5u^\ڢ5_Qk'Ra<CYά'R_{2(''Pj\ + Gp'^%Gx_WK7&p26}p񃬃M%kC8rMW}xrڽ׊r!u]nZc|/ɫhnm_\k/Rfӷ\e|[=[gu^kӗ1����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=8$����7 �����C � endstream endobj 282 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 37170/Name/X/SMask 529 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUKK8p25 FAZDhZ@q�"jFkRҖ8 ZgM|0}ѿÞƢޒߗ4=͹Y;{5w2�����������������������������������������������������������������������������������������������������������������������������������������������������������������\&gWtx}߯fy$��9ю>uWZr_QͳUck[7>��x(-|}ci��mh;6a><��X5m^3ge65~֕E}/ox8��|ٸ#~M&-/_ݵ5s��ǡᮬqlS{?`k$/xLZ��94Ox~c5XpX_>dL+˔ORJ)dOKdoPؾ:ww珪e%}rRJ)RaWA(j5n>Θٝ?*{sez|dqu4\v+ܱ:{Nd_K6Ŵ s'}{kkh‘|/dĭy[}E=pz éܳ}P}f؞MZZQXiA[O?}1υYqapsDžA új5</*z<gsDž=Be A2υyn?w\Nk<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FLzyδ[�1皪gƤ ��%y>ܲ3^��/sRsgN��E &=|){ei�b3o]{As¸i�@/1S|öW��?Iy~s}~%i�?bb�־u5b!��mîj?��&� l1?��&� l1?��&\cg챳Sh �b+x}Z^TBg��$|`iA,r+/o^Bg��$rkovm��8N &yM7w}֔C�� g5gT;o�8g*|ǘ��HĤ?<4M{Ϗ/w�@F .g=D�ЛAL3�@V.Z<̾F,�oUm_#�@b2Q\Tiz\uUSr~N-uq͚Q+NV/>rDsz?8džիGirUΑ͋UF~Lpps c0C�A>;m-?bc{-guKq:{נc;Gm<Yѳ#I͚259rC b1�g_#&� l5bb�f_#&� l5bb�7yqxD%b"Aqj2mSHb3MbԚQU4"HqڱUEY¢qA'֙$jhE;vl"}3sFXvg^CO��"{ 3'c�� z +m���^5Dg-EI��kt>ۉT5��kdyzWĆ?���{ J4G}Yń_?���{ e}��kDI ]edN|x-̞u;ta3SLsSvHM'ŗ$&���%M&vH#;shυCoq7���Fi9"Xmg܎Vj)\?~4���F8/-=~@~A��;@o81!)2���f#|``ڰq{���pOΫ&PYʾ���ثPI?~{���pW4G)~s]=���G3"N/Κ:MI���7=PE??nΘ &���hZbuX~@@j.K7[z7��@>iTs3nY7��@ӂ,8)vU 2!p_}���4(6dPj./~|,g��cbe5%P[[lj~6I]���f/˾]9Jg~se*.���3s[k.#]?1iZSd��`f~|JG^}C]���fv(ѭfpd6H?h���L)1~3*On }_me��`F}c+lfp<O= ud��`F=n]F@5C< =vw���̨Wwgw ź~���(`7?cKksd��`*b& KK6^+Ξ*>���3)۹sZ5PPpvgx]��0;,fG% lm���̤~鈯u.?U:`7e��`&bjWPpZ/^O$D���SXefPpZ!zENL7��ݻghF@UG̎4oxyȾ�� :{;]?C<u}7��}]w{MF@%#G慀ߒ}#��U ?K}r3��d +fPHR._˾��@e˛#v?#fG7-ME��PqN?C<]m~;��Tg8.tYcT2Z80d ��29D@u+u?٧��([c/Ph Mߛ V���](֓bT3ZHNuy\���*<Rq}u-F@5x}-}^o��PQD3KqZ0d +��κaYI jNIK]"\���/Yb?3?zOUaA{��Tb).YI{V f,!N>ב j>�� *%Ub_N8?GeWs~ߗ~_j{h��D bW}uk9 ՚nN1<* &ʾ�� T;ݚ&vo 70K^x%ֺJӾ8殮.+���D%KbO}XvYb|}vҶZqrmO4I��^w~;J^XD쫄7vPXC<]]~YO6MKcE2ٿ��@$k(_.vO-vv?mD+hֲŧ@8^ #~/l?#zR&Ͽ~S��"vKw]) Qۮj?lRmٯ_sg\zyW_AMi +Xo +k+vNh"ZPjW-`!9 BeUPzittT7;.!&%Ɂy!'9|g;<)~<#]ܹ77m5s���r%M3)U1Ҕ7?`0㔩I$7/oz%c{t?>ݡ9Rl}N���D߿V[pq~:!-<,8RIޗɰyow|õYk?4׳^g PA����H{zx4;=`}3IF4\^]b0SΏ>ҞG���p(jƵKMsͽ2EKO Dwm"K$ihZr3yN���Fr#s^m^<8I^dUj%M]UϩH҅=[<NG���PBB)Q.2(GQZ/I`Xdaû?%ʍYDQWǏρ���/o}R\<d)+}n_ R\?`swuee9/fS?r+RKaֱyTw4loi]<ėEv83���@@ʌ*sO (Wf-_r D.ΌɎR+6Gy?²yfSQ\+n;Ndin56>6���fXE'Qeio4{QNCHŇ<1ͷzY,LUFѪ^nyO-SnL`S���oꄉrO;[Kوr'q f[_տm!+1ӱ/w{SݺWҎ-avuB'd���`G.άP,S|.vo>?ݤ՛܅hVki,}&Ru}tOK{v:jNy3!"b=���l|K~'z?EdˤFy +Q:/.jpvr����V5Do96RåR '֟A3eK0䔭vfGB���V, 4:9UE%qK{?Ь<Ӈ~w},݃-e����t"hO -ev V1Y 5Z?->]Nfϴ' }d����1y!\n6P.|Z"N`A3~BVQ|wDV$+X̚}3>3���5HRreFC;{"I}}Xh?heĎzT:ti~<^>Sc���˘#Nu_s6l"GXH?hvsG7Næ'[9B���?ļpZ#\dieP&g58kb%oJ$祋G=*<$ }t���>qqvfbه5of?ڂDwB�GcAFk˺0ӝ< {yB���ODDyjMלCk3(7ke+p$4TCyNu>'_u ڜB���/ r~nܴ4PMrk*p$#>y)EWtkF9uD���+~f1t7`(O= �l?hf w9_Z6'4sdz+���zCʧKYrkg*p$4^"wŬuaB?���<өU(qCySwl?غGb㊚c9-{ aSز:]g����I6z~44Me_Sޡ܃=[svN{|uW5_"���S<3dөe<<48ϜM`,[e)p$a_q+fu9B?���nE/s疶՝Y^ +2G"q;;Ϛ]ܑC1B?���T%c"sLicFy;NЖ9 +严tG {{=kK~����f~c!/.b9Qcx9�=cAZ"Nȿv4] ,����̑Xv:4?3P\uB�Gb %ʕu_3<89K)z 8����7z em\_O5 ׻�=Z?VT&?}Dv1V)o}cW���c}jKم 7�=gA:W~M]w!<or���cn..W/^1-Mq\q'#?#w~.;)X+x?eد(3 gQE+ㅊ`c,hUQ&^iEb0H ޾E "LIxTG_б,tx,yg;s<X���KrNzBtghA�x9}?DS=8yһ\ [[7 ����U+w=8NHi{_e'0&,Om5]ss5e5����<DZ+#5;wgC c?OSIg9=y!%&Җ^���``ZwbTڝUhnEy/sVU}*?t.VJ/[W���Ԅh>jkO2)84,?հ%Bi͏ӴȟJϜn���``巎DuhDu\Bi5RMs a?l>V)jz펺-għX���Yjy梦rAA`X|B +-4ufB�c²Xn[DJ8ٍh!]gZ9���OW?*UΥcu(!"Wң{yTDs˨,ӼƆe<ջ(zXቌH���2$3!~^e'7x64U(/y  A_)X���Vdo`RYv)Jgyr;t~uH>J`lX:IYWVtsƳ)άw���̌8;͛}4 +I:JG߂\_w<$TI'DɬC+Cp;{}(Fb&���0Pc~.YB& t١ +]gx\;}DC7Ռ{+;�>C:Ebqj}&Js)1<̚���0L,+qbB9ΥTMGw3U"^j}|Bs ++��QmA=Ӳy?YW��� L`Cv3I:QHhn)dդpݛOfٱI`L 2Йd7Eu^%k 7g+���xlm&u~Ig}'kzX-x\xx{G%h]NA�x3 Љ9yKާ=~G&Riv ���O&!~JɅXg}CdUhE/댄Đ]gW_tc"��`njJ9"1i7y7zNh/vjf7zOۑ/|#06?$Ϲ oR{X ���^;d<uXk[4woАGY $ם}=t<-Y6&o@`X9?nze���Ve$5&zFqnFFf<ޢ2Mx)=.F`l Xlq"BK5�}.ܿ���̚2g b-t&[ؒecR+N2Cs#4F`l  JpНM-#1HXYf6��gOK₂ƨ pҫ4Cs[§)aD}xD3#CI '66Y=xބ|O6��`lƽG6ҾuFC39 5u߾A㈺]亳 orTymg"0F?DJS*YKo7zD2тg:���73#N$jy)BB@rA~g-Y6&g7"reAG4ٍuB�cec.w;߅"B9Ys��@5ݑ{'$)2i&*TvGX=Μ(<w54LY:UNv3ۭQai,[m^��351!M'قe~4IUwmX~Gk~vB+w�VCF%:@a{_ _,T)eOdfpcc~&Sz'Kl߇ ufO}X��~d԰dՂ?0Œob4:n7hcO5S. G_ߐzD6@_Ԝ}oe8M1AhQ*?b76bc }^���Ӎݤv/(g:鵝kfhM!9g|C7HYg/>nK{D6 z3sSSr*/;C{?<wkΰunv}`���0lt +JO Vs+{XɚVuՕ@5ĸa`KR%b%dqD4 4%݀@h)1F'~n]08&3Wu>^U=w^~+L|�o#Lϕʳ`9%>?W$ N#}!^{fL?>LmuJwYt"p! -,c&pm0OJl2ͧlŴ�s2X&j#vBr*5,@0 =V?|wx-UKw375BLӓ?KW]J =l;u*}�xg2!�$g 捥3%e|~qFZ -,I p`Fz 4X35r!Eh?W7&#:ʺJ+ 5J +~Ś#Dn3x;1ٕ&3% +Qj3gG6/B !<(/wɶk޷KE7&!#BFFm +2:/ +]q~fyL@#L-Crt&ou )3҂?_haHq,wzj3�us?eBZvm9zxU0Okn*-ײg/f\<?% Yɩ6aSŠyq%l4HINw: J_Kt+B!4['gC_,-/<J:ZNJ;oo1\~<Ar6;vg2Ӱ&a_ty?u3dgsh{֬ΐWw E5B!en6 \׮!/dKDyb^̰i/@3yTa!3γ4h^bE2xogz ܬاǥA&]\8]쐶]~E<ɋ9mBV^oG'ĈWKRu׸x6Cu�wyM})zO;`@\V rV/"݃!7?ЩvCZA=WyqBh\0y*/LK?ƍ5m;?rգ J?;ßK.I!ShgH_KŷNįpAQԆPBY^t!8Fw\d9<w`3ArkW6xwuI ~Vys"Q,\A;`@چkoṋGTn!esg}";T +r +;D9`_|݆�Es17v@{8ϊOJ$iI޴!cXd9֭iyqGםgg(XMuh()vP\O #�XigEߑ<A;`@ڈL0rV}ӡ;#\|^}!` +|]t,LI\#)uh,-z12q@֓/E3 +H?⌝)@C YV\CU_kB'+yG>[BϴInn، PdT_gsXX_ޢ#�J>f-؇#hgH[qe*XqGr#Ten6")S?Znϭz_Q(;F-+UT=a܎9: +wy#M;`@ڌce7C>{_~�4]JE!m6AWWu:$XP +Q:V)=f)(gU7^';(/v3J7_*ߛ`E>b +3Êᠯ$^ܱU\t?Wh۹~Ś7#G;&TYa>i;M'[HOsHK7ch1B7sLgZ8w(\|3n_`mL|n[x2@J?h$ZO~N{&.?z0LTkꜗɥ+F!8x +|hbL'Em.nyԲA97B@#3|HN$7.?z |obm�0!`!3$'* ]!{T77d[gJ2TYgGvk3 Gs u' 9r Qah5B){_Sǟu(^21cJ[ "xJ$A$ ^Av]Jwarhc:^1#KLb|sΜ~= [6O8: 9Zxbr#s$Ϣ9sB- 3 �?qi0[Jzte��x*͛6RF} z1Kcฺv'Bfό>W|<wVA�GlL%mgOse%,]� ME=Ti%mn ڒ?RM?#Bq~XNU?�[53$Qsx쩊Gg5 ��ggXZ⒳}UZޯ^څ!|Q<rAjcl ddDt"6P~ }�BGG~{4E/ vo:Z^d*cJ}_KVH?BQEM3 +�([*;v Mt|tN�#3;;NF[>*-uUHQ&.6ƥ6=Me'Bf{@"Iۨ;�`\otf9$%/M{s��hM.]i;c(r"eߡ.YFMAFF05ˆ;۳-՟<rl5?IndY"Sz;Ay_;�Սg޸3(I̮RQmQERh-qDys/d6jSR 3 �? Kؙ ~#[#Gmڶe2{�&iA4gT )ONr4'}^̻غgԗ% kdr+{_I+6m&'k<;�Sl0wVdfZϤ7޽WoW�xI74}E|ovJZd-="_qNel[uMtDm; 鼳�OVOJ;ם=[%l3iq1o{�@Ƶ+hZ9g]QUR21Y:F6]-M͟5J> 9_s;E^=;�dl8x@yPٶzKbeW~��gd2N&~@1˖uMrWaD:ch;&5h* xvәMvtd1QLy BXc6@Yr�,ƍ>]٤CT˹՚x?�Щӣy/K՜cLA/hZzFy~΅ V/Ý R~%Qg*[5Ў]Ѯ3�?-ߑ ߏl;~86m^̻Ņ��#v2 ןNὔ;RE9`)_d~T QDr_ B1{A?�yl0ㇰMpQb Ak��lqu)vnɉKr32d55+6F^S $RH//I=?�elr"j )mgU! yw��CNiGsvƌ8g^Pr]wqA^7N!jijqyw[>/c<V5 嫬gnQ9<w��HW71V螝s,/3<؜*5RjÚsOpMtDr_BOc,s=L3�NG&St˸iۙT7BT:9~ +�:]QoRؼ # 2n0Z6_r5&6F7xWD)g9翍 5^};s�tVD͵%321J|hho-b'(hkyiX*$K([COp; /"4DlG;k�tt10b5u5ήfCh<9�xia=ã;$ !߶uZInB/hLqpUȈF0w!(ן~6}:=;k�ttܨ,uB*TTև~�;g i3R! +aWީM~` |*H?@mK^];c�tֺ@v-՟aoN;~�0iU S۞X8Gthܗ.ھ-'n.ӑ3)6[ϰEDnMRgo,=磞i3*gUODπgܼ�wtᝰĎvT.x?yPgǟ$"bUZOT`=ҮzDDd=Qa,r@ף^x̺[v |f>@~ϛyĄvY[hmNs]>1ѳ Di化Ӟr.挕3P5<˖'}:&|Ɩ?Tmv`#@.f) HW`Xa#~aG QzUKhv&91g({$u'O)0 ȇc 3ME{u5rQ57`7&8s ' +C]֨+JTݴ`xk(jvPE;kS\{b7)0 ȇcN+ʲu{D){ +bpX[ǩBL^.ghg-˧5JF�^Eя)ۥY[UBw +c  +6'Ss?R~N&,3a2i1b[Y|a(!C#ktYL)"<cFq��!�EQ}~Ŗqi?sk0sTXUvJp#ަr&Ka�Az~}74@r4~eBPYMU;(Y0^C gQEAJ7rEd%0 H0A\VݟfMq-3j#qq8<̅;ya\TW~ E?I1k(|zђE!wy99O%.ɸAv. 5Bz'f&&0yhZ<gרԤ +U]ָzvK@S\qVpz-�o(jg rgC`@cu8y'>r>hmQ&4y7C 3gAD``?aEL^5U=/J|W۫QfGQMK9Czgb t ctJUxW{]Y0 i 1[YɎUHBZG 2cS}/cxØ[�KmE.ϙAc;3x,w͵BqFvA+YGN9V,_eiKslFAFQ|,iBz;li ?`pw:UUEW +mbR!�łq#K;SO (տ Z]sl@/?QEܓD*i9״wu0]'BaC&tY!ODVHl-͈u++etYVabQKMz/y$@EQ5f҇2I^ˎA>?^o:Hs/}avFn.Y{tH1i{4 +5](x^\5QGm�R/3EQmUJ-dN0 țv)QNybA9E|D)m\{bPrG͵" 왂" Lr {b~FR= u,Qī^pq�П( Wg;m1 HN3a~̶P{3:$N,s?~ W*{`I sj콒ՃeE~GSSpjl]Z NfWY##A˪ճ)Yu(x ى(vIUd.Ph1Do.'Q:zǛON!v}jF.YJ^e o6D.+]~5?)LmvnboyП(dz.o~>u0ڻ!M%uoj +rėnu�Ze惽}{:|3i2ذ/<4=G5JݧG_-u|* XD.(Jr\?Rv/i }G{}"G31Ҵ]?|Q1Nܰ6R~2N_??KA\L^9YY径Rω?gj0k(WmOꁑwC[ igLg0*`W=1k@i>R:w�o f["F)elaO$=Ls`�ҟy((}5 j2<?b:a"hb{0]nzXRxioT83RzwH3p%lZulqc;qLResm0p(N('dvaڻ!nfLD~{a(%s2N.o:`&eIF'@UrJTJ?KK7u5W$IW{HP2A?5(ᦈ(#f[Mx6MUPm(`D/UhDEU@PXeYw" "ŻQmm7L +Aw9>.2󼏺12]��AY\Q~qӗݺg pfEYLi>KH,9s+mu jh>rnzfؠl,2$%Uzu~WHVqߕ*^>ܮ" o��֫6;IúxdH1}z3WALXc74h7br[ߑ]-:Z8m%5m::Hxd^yekX)䇒߽w�vv ci{ +��<FgԿӰ?=IM-Q+;|D?˂|l:7)tvc'kttd3&ފ%jYe֨KGSu^rV#��,Yd/E8|p9&퉘;ϋ܂3^9_VQ|\j}Wy2? ubokh'"+Oflư]?~P?X<��gowywa RL2=s*T?~͞4 !/7g|_?ȗ%ժ4Yؓx~7)~O��z6$#փwK"R?^e,Vɺ"JLw +d) ]Ջqn:p^Bϒ.9T\7Sc62&__���2JM=K}˻ +)~c95Y<~f}ȶ1=&z9UZq0^jYt2]��5?uhYd]/eHA3iƚР|;[۷~&=-;o3)23dd*<Q5wm +W1:���{ _gywa "֦TsmOzFذ~]g[<k6;=l.-!TuI&#Cǽ^>܎���0zumj8/uH>Ocl庒x}{hqS;t];ҫW<_\4{|ꭌ)���K^|@Jʻ)&9b4W]L6? ၁_uގ{d>>KeF��rPS"Fvkփis_^.<fl>m*_4TySsNk7޲L���tN'\)^�)直k!6Ӝkbnv6+$пt?%Z�� 'oΡ;Z` "zNe<F|{YҫU2QSusb2/w>���oN|)=ܹw@D +ǛYq4̅qhrc/>+p=�� TFmyw5@D +Ǜq tgLCUNw9��̖]KeQrk7(~K?:9nx���RI}7ܗw[D`S <[~#͓�� Uԓuԛԟ;` "xŅ{vf ��@D}Ļ"R?N),Q'W[iw���I_db\Iɻ"R?ާ6��&Qԓԗ;Za "<de;���RAX+K )1=ߎα7w=��T4U,H8m;]mͰ?a>q9z^7��ŌQ/e<"R?}-*Y|���ޚwG[;D`WTΉ/JY��x>>w7�)s<.}��\v9ܻYH0!C��QQ&dQ` "m_Jڍ!;���5lH=86l N"R?,#Աt���]ğ1>X$H 9&ޓ���<1АϸwH?a9OJ5m���jS4dz`` "rdkugyw��ՕMGǻEZ1~`޽���`)P%{E8)tJcUNڕ4O���`nosݽ"@D +-ҏμ;��ܞz8S-</"R?,{ Zŝ{��\רJ;ޝ+*D`ttFw]��`./*WzP_5P.(s(&:l e1D:nV^(Bϥ\z(T2(*-h+a*h=y׃6}>ڭMgiI^j0) ��WckKh7vΦc4nsF㯻rpDf��pT'OuQoMhZs 3Gw�{s1=3 MhZi�{%jJFgӱ?^}Bs�ݪiLMٸvS#M݄X%] �n:YۉMΦcf{?]vG��/Vw~]vK# :bzoҼ#-�J[%ni$ap6Cϰmwm{�OGЕh74Ұ?8ebSɩt<'w�ۑN .P$nhap6CW%IDw��p;WF"ni3?8/xݎLp��p3S0I+[Hl:4A_wڍ�fW'KW͌TΦc +3Cʉ�I:Hp9RJϱ?C4:gk�j*Wl>I[\_1A_SQ;pĵZřǣ{�܎QҥEj72ұ?p⼜E٩ _Tp^&ܻw�CJOڍt.AqQ{aπcy\;9��"qOJ`p{1-ZY~&_?iEe�@HJ.n"cpzgLճq[f;NaRy �DKf.pgGMu)='3뙸ýR<_mT�"tG3ӳrv e:řEٙS?I-ven� rݹjO?Okkaiľ{ek}f`_aܭ-lK+YFezL[${+g^gy6=]{�ߗޮ-;crwn`$_7&i.nlܐп: 7m-ȍ57Pf]i{w �`/̞@ G!oμQdݚ{1|-,#\&�V[>smnJϰ?A}�ا|1?פh7r #}ԝ~Έ3ŏeh7 +�`_-vpkΦcCrA_w=N�ϹH_7:fB_{pYAV�qxKVE::1*sc{�p˺?,]:vpgΦcG&|CsjS~��%dmK_;cp6]zY)<͡!�׵KO^ uEmiΦc'gn_}~��#,(49yN_a��~HG:z44a/sgr;Fiw � ;tntwIe<{ �ҍ etDe?gӱ?ܫߒhyvתⴛ�J"݈]0gӱ?mAQVbVN� |dbAa8v?8n;Qn� |۱jր v?8~o,Bwj �~.tbL½ap6Z%4*Ӟ7;�aH6½ap6tu?:Cu�qzzJCn$P~��>mt!śvpMG fsHuO�@t,tA(gӱ?2,cz[yn�@OIFMΦcإeb^.#l�wKۄl:}~2r5/n �}?5W:̡MB`p6NS6 +=sZw�tCwnvz[$h`�_Pzp-Bap6^Mj%jX&�c^Mj 4,gӱ?ɝVE�@4<gӱ?)yNT./n#�Tغv{M_Bޢgt#�}B kRnIi +q<<ow�p??WAV~rs-vfli0res?ЉRҥE +&*\pA_\2jgtVI}{'m}y! ߥoBAL +#: ygi}+�LSR!׾51)ﺣ6{ �q&7eW7 &=n0U~<En�!Z7 &]V슎N׾�UcVF~wX>5F Ĥ?gyI�\Yu7 &}n`UԸZQ�@IoKKKkGtz27-�tݹGΈӾ%1)赨}{|{ +�:m{Eb^wi?R]\W�'=-}--}C^bR7o+�ξH2};~bRff5ҿ�',=W}3AL +e$Y;|־Tg�_^~w&ikbRϭORiZ�N}X`Ok +aUslt{ �,c՛kbXmwkuo.�N~^zYYF@.†w�ٗG}OE ׾ &NbTl]/_�Fҿ>.^־ &ozh^|I - �Hw/U p1)tfRq@y.N}hrz_�_a[�`@gz K>Ƀ�I-s?3Zgt__ysIgrdv-M&e�0lcͦwo�Agzv©܄yߟҤ}+I}}|;6im�;:%Y6`N_?λJ?ϱ?p59Ȯm^~Dүҳ+7L|881ۿqիKcjH*Ɔml$ҫ>WvÙĉn.ZR<3ڱݼl֬9"aEZli^}$_{eSc NJ uΜ/5֖U+e̚}>@W)K mhk�0A{CҫY펇?H8+&K.m >ٓt/$anU\=s⟨ IJn)31?H3쑟&3+={wzq=C:ӟ`TZ �_g{>^v8:w՚46GW;2쌘=/^I-<lx?(ޱ[r/|[ 3x9/iHt&0I9;#_|'4qZJ^[$]\iό)_w cↅi!2Nb|8�DC3-ʫv#2{8-F$ȎXy�mڸhoߝ=s4lz4Y@$l-~OSzT9ĩFVYOK>a?pR +gܱ)co:�DsSS7gݢ,􎍵u~\SVySn e6/U�d/>O⊢Iݍ &qGzq7\w�p"VKMFalJLn\B}qt*IKFdb@wr%슎Oky�pO+I1<ovW#r?Ia;f+`{O{�p%v[vW#r?Ia<87s\6V&wKVĤ?НƬ+:4_}@ә9҇Wgkw3"ۜDy]?�hp_,W^v' bRn}҆Zkkn <'�pϰ,鿵;f`@( czl��CyebAL +dnzqq +w�/.\%7*wFv,bR5!k�@(II޶1yĤ?JӆZ>ɆY� +,z_Z$ݽ0B;OZU겖�Nk m-swڝ 3?Ia X9W +�Н>;Pmd紻b@dl}TwG}�{^Y;Xca61)KVAuIvd{�1`Hiw, cc8h)8# "ĸeNL:HEkA"vXQLj}wWq?:CNZm~ _5&Z{{Gb>//'4~e +7g�|H=*}&[|⤰?026䎌ߢ�JBHݝ N +:yJo{fN}G�ޒsޢK8Ia@tUZg}zU~O�@|\9F)wKR$qRe񷴚 +�Ol%7KP$qR樝!㣶?K}�~zV_IoN$qRJ1�7=o.MݙHL⤰?`غ~|Or;�NwjߢOOn-AwW"q?]Ve[9M�iK;Ab;户& +|־Z Ia[IwG"?Lxf +Co|�HL?CfwhL?ܱ.{n3Um�EzGGzHHw'A՗E�$/>W$#= ?]ڱnn9Zp2y35/ߥӱ?]-\`/~�pccMY$57]{c';"/Cy=fs" �gj^'],C{gc'iM2?KYW=Ggy@oIa d半ʣ� }bJtgtwqR9[_Y�8%+V8?⤰?OVz_*S{s[�ķ[8]隗uwMIa 榫Wsbfw;N >} #ŵU+ &⤰?o.ʝZ۞.I�s}r o }Ӏ`'xtS";3ux]{@|xH%S'=ˀb'x5~eEfs2w �{b8)ij)sUc8fqx=ESJzBBzCwwAԒ&3p|_u؟`/ V_,|?,_3[+ܳ;�A͕ +8_⤰? ^]{|\>o/(0p.8)82w}>վx^=xAV\(qRpt6y^̬=q2y'c3'ɿmktwpIaiҖLU u13WQ �K޽zWN5?镜]A{s]XԻ}S NtSwoutw{O}=5E`a;FVvDnO~QyNQ1(\3ϱ?DWe-:E>"�CK޹hMP޿1Knk 8-팟U59F_պI:6e�%; +t{rϴw0Ďqmgxf +9nA\Q3ub; rX[޹wݝ c?h^_rר W^V<:?9f;Ve?HW?=]mbg~/G_X.WI޹ +5EkX{~G bL )&�FޱgOc Ñ9=9 G*+<zh7y{=$kVPF]t^~p~;,Zw�CA:wc'g҄_~hɒKv}{SG<R+{@ΪY5BOG87)j_yuw +0ds套'>g@\4jԗ}`Ǟm/q˜'Re|{^ckme_U8N{u>]6H{{ +{wkDuw 0:&;A얘ҋyţeL0}?Tj T@ܛп}*%Uޭ_ 'nzݞZ}nצ:}|DvssT(lj mW�z'Sީ6~znb<>k숞 -c)gEK\Ht7R a{f,�gw)ﳡxOޫ�t`f?Qu[j[#y'pa<7ޗ}{ W a}`CڻЅArGm ;\Q&3Y1>ccESύ~oImƐqd϶_4ߓ{n \UsOl-)uG?'|-oJ?}kjrv(lrjEQ꺋NiKk>\_-R, JZE3) GI! GBLInBn^7R|t>Fk;Uowg֙0\)8M.|F~=ߋL[]ёۘALM>KЂIzx-(BU~7y2A&$,+[1DY^gfrklXSީyzp+3W ;ӣ[(B"jwOkzy舝Oܖ~̀\r& 7<]/ZcAv'C[9HYoCN3/HiOzhg8F-N]+Ǚai LU~2/ :z|һA 4!d<Mr"G|uAIRG|@+lQz}KvJd</l$@H_E 67yxvN"CrE7dMX/^ߜ MŽmqvy1 fI +q0wH*w SkÆ{^s(;A|hBŦiʪ�XgWOl{6y~,44Gz}2Vrkwf,7BrF|IrFg?4o~WO5?c"6 Tf>')s,TdFܙ3+$yx< 4ѝ2s[";2@YK+ykǡf喕|c2Ux W@&$ n' R蟳5Y~[{-xԓ|X/>s:7e sjkcMnqܸ uu8z{WGck#塧b˰�}}x='wj<rq;F6a>w= z͢ Z<Ơy`MU>D}W;9kO?K/Ct:[ww�?Єd?^ +}%mA/=0WJE$?6::>w|ܐںqɭEa rq'E{rNh3`oeg(޽{ci87b͍]Y�kej0Ni/{ZI^#F}Q Aտ!ꬂT&C]k@XS1-Y4+)4*`%E -mǯvsEdx{W{5zyo$̯o>oʟR\V?߉9lq\?ΕsMo,GgN5J!/D(@==)wA}z?_w#MH i֋(I~왚6::>w|ܐںqɭEa rqx.gyk5A@xߪB,vkߘ\zyHWV@L4)e`qXC+q8K|ߕB#C]G:loC j&G_O/'MQܣ:\ EgNgsY.Ȝ[:7IXcu. +ClMKzyOlAMs`ۘmXg&R|ܶ7kv7W~N;6+F_l^_Jڠ^z<`R{笪J�v){lE}5^̡r9Kܼ^]5A_@F@q_K\*He2|nj#!WDIĕےqpr]j* MQk%S5>)&5 �4!d]=BG_fLKlM7)ge7+5ccǦBe%E a;yS^38X.I%#G|C/LeǪ>es=v膬_PֻRZ/eƂ~f4&Ow}VvlKȋNMKp rqwwvv庙s/|8:⻖_@&$,]9W8u흒%i+}57tjvj/KWwfr".w?b')Sc;FYGŰmW̄c87&LG,7<]]W{}[Gr{.C+amșFq,w;(-F} ƠK'{h4s~w_  >Dd|P &K�Hr zzwnQ[\迡ﶹ{-1ّŁ6we�'E}koަw]Y&:<ֱoyHnQii߬s( 5]c :fp\]ёuƜwvA~ON0hQgxk@]<<W\u"wP7|.?Єd?DDePGWm){+POB}zfA&$C φaIWE}7gJ"UUE~EuqS_kjuVm#ZbjԒF@XyHVTe嵰,]w_(h<0qX5W3N/u jų^~όs#,CA 'Ǥm+z=tcTwAsO">CA '/7J5fuNKD(> 6?!]Ya8$A +=A<yFO2KVl%^ƿ'$.Q8"A +=At =#' +k-٣EDGFVd SD2۳Qb珈+q Is{ľey#=BAV;MK2!|=}<.jRX?ٱgnV͘pwm]DZ uzF]QA +=EdžIǎXTWe_s[{kyq(M&7:?'+a~֎f`4 ༝i4޴HˁՂp| ;#=CAF5IKlOqFO5rݖTfO%ɃetDr~w3> --1%}3@AFXXy@W"?XT4P{QIa_SwBG8 gA@n}1D +=E0GX|x|WCּqfkc}zoYcOUr̼ehU[R)y[w@t^j߷=#'7:|1ּ7r_]5 ~s_/ov?^뭴0lVuB.7>YƘJnZ?lN~|/Ҍ׫؉|O14/GݹW\^v|E_$$wMk| Ʈ]cp\�s󮽧 rm' 3r/ -l.NQ[/3D  +=E0<%Ss}3Wvwh[Z:On3/_[ +=w }1g]s醞{ԟ>.Zkʷi.\wEzr>GC}Ims[ұm#q1qߌܼ@XUn~u[R?,7,C]ɚT)\+չBJS[cܵ!uu)g^;Ps2Fwn3 vڽðWgپ{1|mջL܌+Wen#G؄g »xzsؗxwZ"BzX )٫>3!S гߪ|&cɏ[?ܷ8T.Urb \NrQ=n$:/z>}y{{G_ϓ`[eZr|jhkT`uyuâz_%x +9\[Qݕ܋f]^Q7||Oav&jP_xN@n4C]K"t!S K1Q85Q0S;}? יW\wE +iWTu3YRyKzHt]+'< Mu_>Uh)׊o|{d?%vAN38.ukwMSrmѬqkز};+ǛEID#[}xD4/}6CAVHQ] Ҍ9F%KakŃ +)Ƚu7E=#/G3zOp%/;4a] 6k?6OҎuPuZ]ӷGu�66ڭc4irݖ>^{uR&dhnK*ww]\"й/Jt WYGn^LAA6" +SGvôs= W +svʑ*6{~+*D@ߛYwD9}EM;y./;-{i#ƚf=aIq`W'@!=Fm/U@s[W] zwfaumeYlmp4`  RBnx? uC> A܅BOl:7"qnkod/om`G23ǡHq>'s +Z DFޕk) tܓ5x|oCj?:3UΓyےλ˻l58>t=+ \wk !SdI qywmԠrAϬ-(LKM7nLJ�' !w\?=dXiGZ?Η_;^('�hx~UDž +X#*u޵(eoڋ$5OĮ ߳># +:Cy BO(i _AQi nq2h)%0h4Q+BEQAlp#ڴt߾pQAEE0c!b!?JU2o`knSTA Z7ϧtLU1OZm9Tkc b5elcLq|!X2KLF_"W4=+̊K)6qi9EdC\$GX0{{@<jr<;@d@ 2? 6lAW6]{}9^7M'Jγ=:a1~u#+i4S.6~0PZ;揎|18鱠ݫ##ɫaWϛc\\ VSŇ9H> af%~vWavrQ{Ǐ'w>oE=ƽ?[7=wAzL_ #UѦݓ wy pU{"'3DBqJ_;K=Ք+aEnD#. c-k+[]l,dlY/$ ! %c�GamlK<t{$DNfZEZpK\g<=w~ٖ/[sGSz͒-D2!u0PZgCIRt2KL9iDvOgUEoɈw@ͥ흄ϹM"*4ԠO/ѽKy8?(-]+2VB۷ئ* |Fy&'h/rc)]Au}~@_?&'ݫGҒ<9f&x"׬9^zyY>Z +6EJ7'WT&(!G !%yr D<񁤷Te̟Vfږ>[%" #{0PZ!ڤGxieqGTs;}զ=Gɓ|$_lϝW";=Hyr0PZ!+&J]UWmr3뷕?3>OjϙWWvMߢ{a$B<#&Ikirf1tvƃ~:&~5%O}I{`$B<>SO z}~&Y)~&Ւ;v?E!AiIx&I=Qu655ec{ɯ oOtB\%1<2NZ/j*ǻjQgoOD$_|_{z?(-JcXUxlOw;꧊=;(KDC_!Ғ?!My1| x?n t]χΫu7ѽ@q?(W酮$ݪ^S͵k5x/Y267_.SLgw_7o` 8oi4IPަ*74\<Zy2z/z'4zPdFCrv?J>3%tW= BHk9E +?m5;NcU]#~o N'0PR{__sw?Aj)S)*\sOAqa#>s u]Ok Ғ{mrϬv==;:g썺T˨1UUOE>qca|fDѡ];>\%}|s1qv_!0K'z D{6^-jzdj +|ƉJ#s+~(GPRU2֒:^mgZg0>3P"Rxs?5ΚNc3ݗsqeoIBڭURfE9[n:Q%gO)H|Nx`U2Ɋ}b7:|&Oz0Pǽc͎lORݗsq'J7kIF5-`OޛmpҒ[MerQw 牖jHƺ~^Ow؆^ؿ'L1qԣǧU<H-S{XfBy9LCJoo]-jz\,WfNj0|veG~oѵFQ:$>|9xcXօnYV@τ3(=d(V^ͮo);X)eٺp 9 sC@] %r5zܔhӮ%eZʻ9UΗZŎ ւqa}XWtڢτsE(ʙUZ8}WkЮ][omfMx1KO5Ӥ &B!bFQRKdSkUQ?͵c7sv; ҠWB!7s5m*? sj2X5p2)((jÊ inى&ڳDcږ8UXJ>+5l>=?rS?'�^Uj]QiKxYjYVzǵ.eDFaHAl4Mm5?g;gx!38ϙC>s._���7#j;6+K uErlxXy@�������������RIf>k )IK\=-@Z:7bmn3YQђIs9jz"6;zwhNT}:^^Odj4mHdLZ.m2v?מܐa,{/ vGKqol[sŞۊ$?1vkcB[va6 G g^~~)�O>elimcpIiuY~srBZgr囻'OٺMU*)qV2v_Z\STcsܥnZ{LmOƑgyu,G|'}X}h߯>|br拷c?*+m4#cxyʚ(ܽ7֧tq~|U*i\s|?jΞI⼳YXg%S{m7繥mݪ؞سh.Y^)?D=mTDm*gݟs۳[פq[,/G:''Dip?o?z̆⬳Է0_>b$77V˭LƞpR|?Lƞ#yBIMqF.89_J굚מ23\,d]t[NLk?my+2\Y;%ūz,GΛ%FJIWjLƞ!O + b"&IwdYn45V돥qJk޻^_wʉS;VĿb[4⌶!cx]R[g?;:FY3\1/[MDWEd>"}[~dMƞAshf~-/M  T#cϑwbGhPl_lKIY/OpxW&Λ-ՒqRŲlِB:pm<27cu+'F(ڑ]Fpǧ ?WS:s>/o6O|YQR uE>2 3"ՉIJ}i|)SWQe\;2 3}!y.~cIJQ8i!S'MISO<1IYgɳk3\1/[MD=WE@E ]־ adL97g2 E :-*oǶTuif#u}V3ÛTW'&)ZdWL #d#",\? wKWX 7K�閶^5323خwS"L<E*?3/jDIi"J:[[sHP4.^:=uqt{sc TZX-(2W)+<sR+ kbp #aC&ז]Xoߩoas ԾR[}^Ib!ǐ9+_͋*dV,\$hǏ +Y}hA}U*I\?]E>L&"hwWϻrnpo?jΞIk53:Q3}եgՋuK12v_!!}*Fd{ 6\:tͺ.ck+ةӔ&Mվn~Z=~tQR/q_1vhOfzE륋l}d o-/Mk ZW\=5,*ʷgF+c&z,ot_dTsbWŵcVybGM}!c%$ښsX[q)oGƞzJaGKvp_Y\k>5vƷ8??B<;扷c6VWfHP]:q|SVgFF #cx?GY@o^k(MIZit[=e9~1ﵚ}xexH g!&+dvdR}@ޗf~!߉cT45/7gasj⋬jnU"Gb=~J0����������������������������������������������������������������������������������������������������������e ���� �����������������������������������������������������<$��w endstream endobj 529 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4388/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HVaK3cK3@E?*�V%?~H$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$邶)K|#> 鱟'"?_I>~= /cΓMllde>b+3Ǐ˗X>Elq?<|e˗XQq?<|e߇5b"FYLֈ3qf1[#,&bkęDl8g5b"FYLֈ3qf1[ۈC Cg!Ym>XCg!Yg5b"FYLֈ3qf1[#,&bkęDlE~C#fab!6Y8P>tbbg.El8gO3o|/?Aik_?A?h3qf1[#,&bkęDl8@48mӚCô>t>Jk?}l|J1CgPۿJO2>iFkeZ?t6Rk73Ȑ!25"BZDԐCچZ<ҘSYsj0KcN-fi̩,mc-hhбE :hA 44آA 3bvF[,ΨsunP;ۨvp`3.lfE ;Hm;8q'2VƝ\6�G]xtQ#yv1#.rc@n<ȍmEN =Љ:^z-F_@W xu}ـjXAW~ү+vQa ]4!}::g]YCW?_E;*{]IYDvG065.\7!kBGu?UM>tz o]RI-`ZFWTRϖmZkUmx(m[Gi|>ZQj=ɉr )i[HIB^Mmjv#JJY0WRʂ1-Boӊ;)cŖVI+c'RJX2%R’)YηfIknYҚ[tB╴Z:ۢ!-ζhHsѪ{L;+vb:ht fb:Aq3Zw38@Vj:ƫo«;OʻoʻK@6rj6 -6 -6 ^s@v*;aP Z|=U&-v:9Z}?}H?y zWnԷ_)QW\P4\>Sn†z5=ï!WaEkeKϱû~ꎻA$;>K.;>K\tqv5XOoGH_h)ӴV|u-x[q7[NI+jz=OneC\GogK_lʞ h 5$}ò){&d٘E:ӼA,JYuZ6gS/'}۲94xM Z"z]}]]ev.ŴEy٨e7F-{ ]!_6k۰_lֶ1My᥿C٬mZCc [L=E%Mʆ{V2e=VKC+Ki%ߩl:#-ܧi߬l B*mDFK+K޿~Kʲ;4G7߳lλ4F_jȥ8-mF.H1L 3[\6s-N]6t= fݳlM %_6i]teCZSIwP] C7oM]I-yZjlRte+޷NlБ{:^wp\'97;֙NKuҶoWg;wݏ +ھuTE[HCaNiy*@>zoMy}hhJWG/rHWv<ͤW:@,S>ħ oڧ5u}9h@Anjum55u~Ww`]G q;G8NyG8sn N!?"Do9 +R3UycpYd((((((((((((((((((((((((((((((((((((((((w;i`%Zn7Qv3i`%^YsL߇> I:Z<t7ǐ%$_cOf=<.v4kT(f͝JPB4߇ѿ"}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0}Q05z-M-)(9u8Qij +"}2ȇfnW 'M{ֺ*?e] Ku꿲,x+:wʲ}+ˆ! +{lއ(lOپ>4)˪hZj6eS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`BeU4-aʺ*?庥!�sKz?i] Kuꟲn6h_Z\V%BR- ^Z6nGOce뒛y}6 +.pXW%R,q ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US[6R!�mn%F7q}hx|mwyg[!W'ǭ6C4~u p\I?:}lއ�`Ua,M]!IcZ㱷{[N Xq-/?gI^&j<79x}%̽?x E𯽏G>6b�O|;O%1r + >e&|L}@5cCj}|w.t_e%19g+|`g,u{!r!ߦ#Ow|>anc|yO|w3s%o5/?gQ2_N ϟM?$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I20� endstream endobj 528 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4421/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +Hn#9 DѼKb2;MT{~,AH�����������������������������������������������������������S�K:x=< ?'x}}</9xPѦ6KC6H/_}2#7/q8|eqK_2ϱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5Ǚɱ5ǙɱqhXrLYS}`&q,YK}`g'g'g'g'g'g'g'l89Xa12fq G7;86,}8<8&,}7;x`,g'g'־||?Q77_f^Oq[s[s[s[sZhfi}`:xϦ\Z3'Ikc>0IkHxv|;TؚQfއz h fsj} gY GY GY GY GSÏgiSÏgiSÏgiSÏgiSÏgipcpcpcpcpca:7v:7v:7v:7v:7vv'''''ÇoeÇoeÇoeÇoeÇoepapapapaa<;<87<;<87<;<87<;<87<;<87v8։Y։Y։gq2X]6[ V,:O}?gf֣]V2sT=*n&"XuV[cɺӜ֛`QUǼ*XuTQ Vcԃ] +Jjej,QQ~I *jm 0(6[j:P,zmhn@ꗜzn!(mv A跚ro#W~Aטjp%lӆ+Abp%d q!%v o)(lҖKAJI~)۳=tB+iϭ0][ ]/MD߆eH +õ]hѶa^aF.q|mFyuffxڣ^yZUj(,|#x5{6hhpGC[/GFz9hT;&r8}e{owbe{okm^1D}׋5&R~C}3$6m`ER_Ӥ;.1W4 ix .xx}8lϺ!@} y<>V^{wZ{Swa=u*>Gݡxaɭ47><xzS)?FuI8\W&vKgA.F}ٲ5}uB4.Ks}J}䲔=ԇ.YtY-O}처Eԙr6]Mcu>G/t!Q_,h5H}U:seI*MʒvUi˟SE-+&ԟ,jɺڈem;OSOQmhjiGOSxMJy'?QYغ;W*Kwt"TYھZZeq H&-ܦ#8VqT"[Y/k$ەϕMW~뷊e;?N0l%q窆/,\>eK_q?iYֿk Rֲ̭k ~eksܡekx@RxLRtNbk\e6ԟ,tQe2/ [o]<C˂V[R7P{x:woRPۡ:} MQ\pt[B#uGnօL]3CއzeOu=0.c߼Ƒc~1<6Ṃ7^}lL1/w1::AjdMcڜP7(NQn0`Fh<70:ۘb# b=iL t$;jW2V,a$XJw-q1C`=CI|A; Xۄ{M_e!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(/T}0DVͤ!4n&U Q_u;^"?c> iw +M :M>$ +Wp߃Y/N@/2T$2i(H`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:2E{`νL}0DQ^>s/S QԹ(Cue!:KnG՞ _oiAE\0pLlG׃/JSƸ [5ӪhZj6ɼ%`_gqNyU2,ad^ Ku?3-x+:w̴>Dai}}V#vpLi 5Ӧl\*+T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUTiU4-ad^ Ku/9o}6yIC�UɰTyS4-AԼ*jgԴ?Iߌg KCgm[^wR+UɰTiS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`BvӦ\T* MԈٸxc}�q!�W!W[ C4>s%}3>q%}3} C�!?{UiKv;\!ImZ{co135}Yk|~~x]桇W/5a<?ǯ9$=?n5*~|>TMx<yo~r_N2@^ަ>b1.ꐚz_ ݯeCc\]G{Gc'-'be:߱w8>wyl|;q@̕y/6ϭ|~x] +Y>s/w ?~fI$I$I$I$I$I$I$I$I$I$I$I$I$I$I$Ie~ 0� endstream endobj 527 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4287/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnaK3KKiwyVw$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I4]z +iJCzħ!=}D6Jz!=i@{cMlld?d>bWfS}Sz7_>v|-~+>j?nCzqf1[#,&bkęDl8g5b"FYLֈ3qf1[#,&bkęDl8mġDLS}*6.B,K}*҈3qf1[#,&bkęDl8g5b"E~C#73ptov}*>f&/bb]̼~ҹg5b"eۿw͗羮;h3qf1[#,&bkęDl8@} +Yp6߇.iaZ|?s>t5Jk%@Z{AZ}(W驴4PfGz 5h RkCW#v>8C rh!SC-"djȡEL 9mȩ,9x14aƜZ<6آ[4Рctl@C-hhtnP;-jgԹB:XQ :Ha 63"f\$̰ن\ʸ[wrqp+N.nel. +pdE <(G8 <ȍg1b 7F] ȳF^Ë�zxh16>/> 6мu}ۀf@\ Y!O}"`%4?hZC>t6tZg ͋]YCb@{hR>GeYE4)tV>Z愮j7'zM\~̇VќQG} +a͈ݔCZ' Jje4Zj`-Fyk6[QbA- :}ZOzZmeRr9-駅x)gH9F`L cZp%,+vRƊ-2VlNdJK.%S:o+]o͒J[5,VtECZt-]mѐKZUҵV^te3Zv1]iٌ.LZ.nDn݈n o9]c|z Uo;]a|zo=ojNt?f~Nv>d|Nx=[Q'Z=߇^z<QYݤx=uٍAUZ)G:͊߬mJ9}N1:^dWE;kp�]F5kVz E)J-ߧulKLw-w+Eٛlٯt`cDOÚ|ݱqjQ6}tOo96soO]>Ѐ/|5操5%}Æ|OHo49B3̩ﺴFe\3J_wQ>ȸ畾j:}a/}etHGeG;X*}^]3V�;ŤĚvLOJ5蘐DSv!Rsv!4^a7~_-FV]TGLK C?^uG]^_YϤH1`gүx;$#o|K+!Av4dkNvn*] ̘ut1kTHކu^l޺3ho]I`׌Z\frcZ\1J.ua+Pɉ3cԑ0ܹƭL1nuMiFLskb42* ] DHT#ѥ\^P?r~Ա\N!3yq}{39ϟ=29]_*9OǷ?'f>Lz v7TLx; 7yi@n3 ʈE~S e~s ݕMcl>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI^>ZI~郩hL>Zfͤ郩hGNzvП1}JPH4vt3xh7%$_cOf<j.2kTj(_f͝J ?̿(!}C #}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0ν,}0QR3ٍɖ~JLJJ&v5y,M݀7kN)M>}&|JɾC6߇R߇.nݨkl&:i (ijwR2{@s *ҮظT-gЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]#vi Ca[C[z?溤!�Ya[Ci ܭJZ|hv;{mx]r>4=cagp^wdXVݦl\*3T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUTGvrQv�o,7ŒR#f>.x;~ڼq>}V!t u u l}lއ�`ֿCҰ~K-W}H$}2sv<~oK>ީڀݟ261e}eGStx69V~3dI{Y?x "co1'{}{5:L>_N1z} }lwuHM΅WpY0?>&we[͎^ϱ і 16y>ߙ;nc|yO|9虹a;>t{|1<f}eGSO\f˩g$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IT��u^F endstream endobj 270 0 obj <</BaseFont/KFRNUR+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 530 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 530 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 531 0 R/FontName/KFRNUR+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 531 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat;]:3UhD@>Wȣ)ʮ +,.V+m*Ȃ +`EEb�!V +."FG MYLj1g' y![—l9(504\;-I#8Ź΢+W^p-}ݝxp|&Cݽ/[fLUrooiovF.$T1鴞$~Z :NHw<y޴G')[/7 .Y# ISxIJ;PIz4bΒhHK1 z+ "`_ku0 6{ c1,öX$͒ƈm0 &l^;mtuU,2j#tM|نKva섳x|*~\ IdH¤8<@r^/ơd\S4D3?A3VG ȝCY| n~4]9Q2F$$3)?a 86fEfUށO^r27Vl!+[+o^Vm ZnR\@ E37w@{WOƃ&ɦ&dUğ\DHLѿ]lWml=lYqBj&nzoJғ#Z.2gY%"8~-$ADȃBW+p(lL +yd>[Wd~A \>SOӲ|io.!9J70`}Lj$Y߀;_w|6-W01 +OfUw;"<=COo+)z:Xf#͢P} 8NtIUM?*=h8m5<cq_}lLj/ì|ӥfs)za}E H@,mgIbn7^ 7~JPUĈs1u9.fU++JxܻH&vS^%מ|΁?�W|+6Ob ɥҲʪ}\,(31Hv9m Id!|6ҟCWƠ*εMŗ믩~\ʡƠMqIGR، .YdgzLCJ'cC?iN4'F+ofdAm:%m-niT=ǡj4R^oL|#ssBwx(5\`2j[tѴ -7mP^lo;t[(ٟPZⷭ>XQLN +w8fZE>:)eJ(>tBY*k*9Ҩ>?;GHQ{3C +pNB_�^v)R GvCAK|-Mř]ais}S<=�6k endstream endobj 6 0 obj <</Intent 29 0 R/Name(Layer 1)/Type/OCG/Usage 30 0 R>> endobj 29 0 obj [/View/Design] endobj 30 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 272 0 obj [271 0 R] endobj 532 0 obj <</CreationDate(D:20170110153133Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170111121255Z)/Producer(Adobe PDF library 9.90)/Title(Fig_WAD_TC3)>> endobj xref 0 533 0000000004 65535 f +0000000016 00000 n +0000000162 00000 n +0000059452 00000 n +0000000000 00000 f +0000000000 00000 f +0000777022 00000 n +0000000000 00000 f +0000059509 00000 n +0000060009 00000 n +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000777092 00000 n +0000777123 00000 n +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000000000 00000 f +0000774783 00000 n +0000182771 00000 n +0000777208 00000 n +0000647791 00000 n +0000648458 00000 n +0000183077 00000 n +0000182963 00000 n +0000061687 00000 n +0000098870 00000 n +0000135527 00000 n +0000649174 00000 n +0000686211 00000 n +0000723498 00000 n +0000648525 00000 n +0000060422 00000 n +0000060774 00000 n +0000060841 00000 n +0000061123 00000 n +0000061173 00000 n +0000182029 00000 n +0000177565 00000 n +0000172853 00000 n +0000182845 00000 n +0000182877 00000 n +0000183147 00000 n +0000189619 00000 n +0000190674 00000 n +0000202909 00000 n +0000217123 00000 n +0000219243 00000 n +0000220803 00000 n +0000222058 00000 n +0000223073 00000 n +0000224077 00000 n +0000225505 00000 n +0000226572 00000 n +0000227645 00000 n +0000229323 00000 n +0000232085 00000 n +0000246838 00000 n +0000250397 00000 n +0000252234 00000 n +0000254556 00000 n +0000254714 00000 n +0000254872 00000 n +0000255400 00000 n +0000256078 00000 n +0000256965 00000 n +0000257843 00000 n +0000258517 00000 n +0000260153 00000 n +0000260821 00000 n +0000261737 00000 n +0000261895 00000 n +0000262053 00000 n +0000262682 00000 n +0000263166 00000 n +0000263667 00000 n +0000264447 00000 n +0000265219 00000 n +0000266057 00000 n +0000266215 00000 n +0000267938 00000 n +0000269409 00000 n +0000270890 00000 n +0000273651 00000 n +0000276164 00000 n +0000278931 00000 n +0000281200 00000 n +0000282187 00000 n +0000283159 00000 n +0000284443 00000 n +0000284944 00000 n +0000285940 00000 n +0000286939 00000 n +0000288405 00000 n +0000289460 00000 n +0000290561 00000 n +0000293196 00000 n +0000296579 00000 n +0000299091 00000 n +0000301553 00000 n +0000302756 00000 n +0000303318 00000 n +0000303476 00000 n +0000303713 00000 n +0000304320 00000 n +0000305009 00000 n +0000305929 00000 n +0000306592 00000 n +0000307265 00000 n +0000308117 00000 n +0000308679 00000 n +0000308837 00000 n +0000309366 00000 n +0000309524 00000 n +0000310307 00000 n +0000310713 00000 n +0000311354 00000 n +0000312131 00000 n +0000312933 00000 n +0000313998 00000 n +0000315764 00000 n +0000317370 00000 n +0000319796 00000 n +0000320456 00000 n +0000322819 00000 n +0000324908 00000 n +0000327121 00000 n +0000329697 00000 n +0000330685 00000 n +0000331760 00000 n +0000332978 00000 n +0000334002 00000 n +0000335202 00000 n +0000336495 00000 n +0000337295 00000 n +0000338344 00000 n +0000339730 00000 n +0000342907 00000 n +0000346486 00000 n +0000348461 00000 n +0000350926 00000 n +0000351084 00000 n +0000351242 00000 n +0000351648 00000 n +0000352272 00000 n +0000353100 00000 n +0000353984 00000 n +0000354854 00000 n +0000355555 00000 n +0000356227 00000 n +0000356969 00000 n +0000357401 00000 n +0000357559 00000 n +0000357924 00000 n +0000358572 00000 n +0000359072 00000 n +0000378422 00000 n +0000380206 00000 n +0000380898 00000 n +0000381725 00000 n +0000382561 00000 n +0000384007 00000 n +0000385670 00000 n +0000387312 00000 n +0000389814 00000 n +0000392175 00000 n +0000394500 00000 n +0000397162 00000 n +0000399080 00000 n +0000400631 00000 n +0000401602 00000 n +0000402881 00000 n +0000403870 00000 n +0000404868 00000 n +0000406325 00000 n +0000407366 00000 n +0000408428 00000 n +0000410431 00000 n +0000413412 00000 n +0000415261 00000 n +0000418727 00000 n +0000420877 00000 n +0000422792 00000 n +0000422950 00000 n +0000423108 00000 n +0000423698 00000 n +0000424350 00000 n +0000425272 00000 n +0000426074 00000 n +0000426743 00000 n +0000428969 00000 n +0000429657 00000 n +0000431053 00000 n +0000432945 00000 n +0000434846 00000 n +0000437079 00000 n +0000439004 00000 n +0000440685 00000 n +0000441955 00000 n +0000463256 00000 n +0000464245 00000 n +0000465242 00000 n +0000466699 00000 n +0000467736 00000 n +0000468791 00000 n +0000471125 00000 n +0000473978 00000 n +0000476951 00000 n +0000479279 00000 n +0000480821 00000 n +0000488356 00000 n +0000488514 00000 n +0000488677 00000 n +0000488835 00000 n +0000488993 00000 n +0000489151 00000 n +0000489309 00000 n +0000489467 00000 n +0000489625 00000 n +0000490051 00000 n +0000490209 00000 n +0000494210 00000 n +0000494368 00000 n +0000495141 00000 n +0000495544 00000 n +0000496129 00000 n +0000496825 00000 n +0000497657 00000 n +0000498600 00000 n +0000500377 00000 n +0000501846 00000 n +0000503323 00000 n +0000529561 00000 n +0000531499 00000 n +0000535719 00000 n +0000537996 00000 n +0000539246 00000 n +0000540233 00000 n +0000541269 00000 n +0000542518 00000 n +0000543545 00000 n +0000544678 00000 n +0000546036 00000 n +0000572439 00000 n +0000573493 00000 n +0000574742 00000 n +0000578253 00000 n +0000581750 00000 n +0000583755 00000 n +0000586374 00000 n +0000586618 00000 n +0000586776 00000 n +0000587132 00000 n +0000587723 00000 n +0000613165 00000 n +0000613908 00000 n +0000614719 00000 n +0000615384 00000 n +0000616091 00000 n +0000616889 00000 n +0000617320 00000 n +0000617478 00000 n +0000617772 00000 n +0000618473 00000 n +0000618956 00000 n +0000631721 00000 n +0000632332 00000 n +0000633175 00000 n +0000633982 00000 n +0000635347 00000 n +0000637238 00000 n +0000639252 00000 n +0000641336 00000 n +0000643486 00000 n +0000645505 00000 n +0000770245 00000 n +0000765573 00000 n +0000760934 00000 n +0000775145 00000 n +0000775479 00000 n +0000777235 00000 n +trailer <</Size 533/Root 1 0 R/Info 532 0 R/ID[<6E23F9D64C6742279969034965FAE50A><076BA29198C84B56AEA3C34F69303324>]>> startxref 777399 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC4.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC4.pdf new file mode 100644 index 0000000000000000000000000000000000000000..c40c021bd00cc762d2ca694f2592433154a0a03d --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC4.pdf @@ -0,0 +1,3484 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R]/Order 7 0 R/RBGroups[]>>/OCGs[6 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 59597/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Fig_WAD_TC4</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-10T15:40:29Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-10T15:40:29Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T15:40:29Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG8tBcm1M8f1lUEr Qcl9QIxKq5WteJKkA+2Kr/Uj/nH3jFXepH/OPvGKu9SP+cfeMVd6kf8AOPvGKu9SP+cfeMVd6kf8 4+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xVsSITQMCfnireKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KpTq8ifpTRYllAmF2zvCCvJo/qlwtaHfiGNajwxVNsVdirsVdirsVd irsVdxXkGoOQBAPeh6/qxV2Kpfrn+8Uf/MXZ/wDUXFiqYYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXY q7FXYq7FXYq7FXYq7FXYqxjztqNrptx5cvrlapDqqqW5cQizWtxA0jE7cUEvJq9hiyA5snxYuxV2 KsZ138xPLmk3H1YyPeXNWEkdqFcRlSykSOSqKQy8StSw8KZkYtLOfIbNU80Y82OJ+cbkfHo4Db7C 5qKdt/RGZY7NPWX2NB1nkidP/N/TpHYajYS2qclCSQuLgcT9pnHGJhx8FDE5Xk7PmNwbZR1UTz2Z xY6jp9/E01jcxXUSsUaSF1kUOOqkqTQivTMEgg0XJBtEYEuxVjvmzUmhudHsInUSXV9A8yEEkwRS rWhpQH1Wj69RXFIF2ijrWsLeXULaBdtBC4W3uY5bMrMtKlwrzxsu+1CK4oVF1jUWYA6HfKCaFi9l Qe5pck4qw/VPPvneCxpB5f43xmljJ+r6ndCOOO9kg9URRWiRygwRiUD6whavwg1Xkq3e/mD57t9S sLNfJsz291dW1vcX0bzSCFXSB7iRo1gChEM7IrerT4GJ6cSqnHk3zhruuyJHqnly50RjaC5czmRl WU3EsPocnhhBbhGsnjRuncqsrxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KsH/MmfTJG02w fg129wHkiZaloGtrpRUkUK1DbZDIaDk6UXOimH5e6p9Y0T9HSuGu9Ib6rIPhBMIHK3ei06xEKTxH xK1OmWXe/e05IcEjFkN/f2en2ct7eSiG2gXlJI1dh0AAFSSTsANydhhjEyNDm1kgCy8i83fmBfa3 W1svUs9LZCksB4+pNz+16pUtRafDwU0O9a7U2+n0QjvLcuBl1JOw5MTzPcV2KuxVF6Vq2oaVeLd2 EzQzLsafZYEEcXU/Cw36Hvv1GVZcMZipM4ZDE7PXvJ/niy1y2jhuWjttXB4Pa8qCUhS3OAMasCqk ldyveoox0mo00sZ8nZYswn72SyyxQxPLK6xxRqWkkYhVVVFSSTsABmO2vLkv11bzUmsHdJ723gsC wYFbWKdQlAwUgSMGl6ftAb0GRmfUI933/jZy446wmXWX3dP1vU8k4jsVdirsVdirsVdirsVdirsV dirsVdirsVdirsVdirsVdirsVdirDPzEvLZk0y1WQGeO9V3QV2D2t0F36b8G29srycnJ0n1sd0vX v8P6zHfyrI+nXSraagsdW9Mcqwz8d6iMsysF3Iau/EDDp/V6fk262G3H3c/d+xKvPPm1tevxHbsw 0u2P+jIQV5t0MrKd6noteg8CTm+0mm8MWfqLz+fNxbDkxmnTem4O3t2+nMwhoC8SqVBMAWoB4tyq K9jRshA2AUy2NO9RP99L97f81ZOkW71E/wB9L97f81Y0tu9RP99L97f81Y0tqkF00FxFcRIizQOk sT7ni8bBlahJGzCu+RlASFHkmMqNhnt5+YP6b8t/o1IzDq14wtr5FDemLYqTNNG3FxR1HAKxDKzd dgzaPPhOH1dOnvdtpiMxEfn7kPpiwQ3mmwxRrHGlzbJGorQBZUAA37AZroH1O31ArGXqlD45kOqd T3xV1PfFVK1maWIs1KiSRNvBJGUfgMVVcVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVYb +Yt1bNFpduJUM63wZogw5hTa3IB49f2TleTk5Ok+ti0sUcsTxSKGjkUq6noVIoQcoBp2hAIosNng e3nkgflWJioZqVYfst8O3xDfbOr02YZICXz97yGqwHFkMfl7loIB3FfbLy46lbyzS28UswAldFZw tSoJUEgV3p4ZXhNwB8mzLGpkeaplrW7FXYq7FU+8uWZWJ7yQDlN8MJoaiId9wCOTb7GhAU5znaWf jyUOUfwXpezNPwY+I85fd0T+xI/SVh73dvT/AJHLmDj5uXqf7svU8yXUuxV2KoHRLqC802O7t352 9w0ksLjoyPIzKfpBxUo7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWCef9a02abTtMjl P12G8EskTI6fAba6QMrMoVviQ/ZOV5OTk6T60hzHdok3mOyUwG/UUe3U+tQLVohuSSaH93uw38di TmfoNT4c6P0ydd2jpfEhY+qKRCldxUeGdI8ysW0FlBaLy/dXMCTRA0HxMF9RepJ+Nwen7QA6Zrez c/FHh/muz7SwcMhLpJdmzdY7FXYqr2Fk99degtPSQBrluVCEYkADiVer8SAR0oT4A4Gu1XhRofUX P0Gk8WVn6RzZeqqqhVAVVFFUbAAZzb1CvYkfpKw97u3p/wAjlyWPm0an+7L1PMl1LsVYv518yR2l hJp2n3MZ1e5cW3FXq9uroZHldUYOlIh8B/mK9jkq4RxEbJhHjlwg7q9hZX955Tt4LC/fTLlgSt3F HFKygOajhKrrv8shHkzy/WfejP0LqX/V+vv+Asf+yXC1pdrHlDUb9rORdduvVs5JpFMw4qwltZbf iRZNYNs0qvXlUcaLxrXFWMX35O319qVrqE+uRrPamBgY7WdmkMEksitNLcXdxNMymVTH6ruqFBRa VXFVa/8Ayo1651f9IR+ctRiQi+P1YvcSIsl4twkckXK4pEYEuEVOAH2NuPI4qyjyn5c1XRUuFv8A WZ9Y9ZbZYmn51j+r26Qufjkl3ldDI3TcmtTviqf4q7FXYq7FXYq7FXYq7FXYq7FXYq7FWF/mDeQy xabAokEkV+C/KORF3tbkfC7KFbp+ycrycnJ0n1sUN5ZgkGeMER+sQXXaL/fnX7Pv0yh2lhuG6tZi RDMkpADEIwbZgGU7HuCCMVBSDU9GWzPr2w/0YmphpURnwX/IPh26DagG60Gs4h4czv0P6HRdoaLh PiQG3UfpVpbVpvK9k61aS3ghlHXcLGA+yglvhJIFNzTNfo83h5QenIuw1mDxMNDmNwkrctyDU+B+ ZPXr3zp67nlr73BtwCCCzcR/UkVAHzxtachMswt4OL3DGgjLAAbVq534r70+VTQZVmzxxxJLbhwS ySADMNN042lokI/eP9qWQLx5OepoK/IbnbvnMZssskjIvV4MUcURGKK9OT+U/ccqbrCyK/sbXULJ rq4igVbq3LGV1QACZSSeRGWYoknYONqpxEDuzfVPzB8q6eGBuxdzBOaw2o9XlvSgkFIgfZnGZ8NL kl0dNLPAdWEeYvzQ1W9kkg0n/QbIgASkA3DVUh6mrKgq23H4tq8t6DOw9ngfXu4uTVE/Skvl6CaW WfUZzzaUskchZmdjyrKzVPd1777e+YHaWfilwDlH8fY7fsvT8MeM85fd+17B5X/44Np3+Ft/9mcx o8mvL9Z96aZJrdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVYZ58uVu4NLhtYZ7iVLtZnSK 3mcqrWtwBy4oeLVO6ncdxkMgsORppATssHfQNZS5JtbEx2TIY/qzaVcEqGX4iGXhXkwXkpFKAfTV wlzvEj0IXnS9UhnjZLVo7uRDGsjabceo4WpoKFSQBxqB4e+w4SnxY94RsFlq4EouLS7l5vyj42Nw gVNqJurcum5Pj2x4T3L4sf5yF0UU0exFa/6PFv8A7AZE822PIMe1LThY3JjjXjbOOUHgB+0m5r8J /AgZ0XZ2oOSFHnF5rtLTDHOx9MkLmxdc0Sw+JV5uu6KTQE0pQ9vvGV5PpJ7mUOaqZZASCFqNj8C/ 0yVItr1n8F/4Bf6YaW3es/gv/AL/AExpbd6z+C/8Av8ATGltdG0s08VunBZJ24ISiGmxYmhpXiql qV7ZRqcoxwMm/TYTlmIsyiCxRJFGoCRqFQUBoAKDc5ypJJsvXCIAoPRfLG+hWlevFvb9s+GZMeTp 8v1n3ppTC1upirqYqo2Mjy2VvI5q7xozHpUlQT0xVWxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVa0 cbsjMoZozyjJAJVqFajwNGIxVdiqxoYWlSZkUyxhlSQgFlDU5AHqAeIr8sVbkRnWiu0ZqDyXjWgI JHxBhv0xV45oopo9iK1/0eLf/YDMQ83eR5BZrOn/AFu1JjWtxDVodhU/zJuV+2NtzStD2zI0ufwp iXTq4+s0/i4zHr0Yvv3BB8CCCPmDnVAgiw8kQQaKndPKlrM0LBJRG3ByAwDU2ND4HKs5qEj5FnhF zA814ZWAZSGU7gg1BHsRloNiwwIpvCh2KuxVPPLlkQhvm/3aOMAqw/d13YggD4iNuu24O+c72lqe OXCPpj970fZmm4I8Z5y+5O81rtHovlf/AI4Np3+Ft/8AZnMqPJ02X6z700yTW7FVC/u0s7G4vJFZ 0tonlZEHJyEUsQo7k02xSBZpbpn/ABzbT/jDH/xEYoROKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2Ku xV2KuxVD3tmLqNUM0sJVlcPC5RvgcPQ02IPGhB7VGKvItFFNHsRWv+jxb/7AZiHm7yPIIzAljes6 TLBPJd268reVucyKADG56uAOqsd27ht9wTx3PZ2sr93L4fqdJ2noibyR+P60ouTS1m/4xt+o5tdR /dy9x+51OD+8j7witRtFsL17dQ3oGjwGhYBGNOFQoA4ttTei0JzE7Pz8cKPOLl9o6fw8ljlLdQDK TQddzQ7GgNCaHtU5n2HX03kkIrS7BdQuWjapt4SpuPhDKx2PpHlUfEPtCn2fCoOa3tDVCEeEfUfs dn2dpPElxH6R9rLc516R2KvRfK//ABwbTv8AC2/+zOZUeTpsv1n3ppkmtK9V80+X9Kf07++jilqA YRWSQcgSC0cYZwpp1IplmPDKf0hhLJGPMsU83+Z7TVo7LT9KuVltZON5fSoASFQq0ELBhVGd/iP7 Q4UIFcjljLGNxudv1/j9TkaSIyT2O0d/1MzsmkXSIGiT1JVt0KRk8eTBBQct6V8ci1Jba6t5tlt0 kn0CO3mYVeE3qPxPhyWOhxVQ1nXvNtlp0lzBoSTSxvCPSW4aUlHmRJTwiieQ8I2ZvhU9OhxVI9Q8 5+dns1u7HTVt0iS7kuYf0fql47CCNPSEYkj0yQySTTKoT0iCoduY4miq3VvzA882bvBbeUJrwCzl lS+jNxxNzHYLdBPq5gDcXmcQKDIGLBuhFCqm3k7zh5h1q/ms9W8tz6J6NrBcfWJGlkid5xyMKO8E ALRqwD+DVFNqlVluKuxV2KuxV2KuxV2KuxV2KuxV2KrJYUk48iw4kEcXZOhB34kV6d8VeFiW7g0O 0ljnkSNraBFWC2a4lV+NedF5VWn2hx6DbcjMXq7negrG7uJxLNbXcyJJ6Ulvys3KKpADLTirty58 uop8g2Kb/FI1NQhleONYpj6pZatDIiqAvKrl1UAHp89vGgplaQ+YdJe2t5prdWa3McnqU3KVFB03 I+I7/s0qc2uLWiWMwnzo0fg6fPoODIJw5XuO78fYmXmO19S0W6UDnakljTf0m2fclQAKBifBcx+z 83BkF8pbOV2lg48VjnHf9bHiAQQRUHYg50pDy7XHd2qeT9SSTv7A1AwUm0bZarfWcEVvD6TQRinx oeZJNSSysoqep+GpOa7L2ZGZuzZdlh7UnCIjQoJh/iXYf6Nv3PPv/wADlH8kf0vs/a5A7Z/o/b+x x8ymhpb0PYl6iv8AwOP8kf0vs/ap7Z/o/b+xEJ+YfmuKxWyt5obWOOvpywwgyUJJ3MxlQ9f5RmTD s6A5klwMmslIk0g77zd5mvnD3GpT7IUKRP6KFT15JFwVvmRmTHS4xyDQc8z1ScBUUAAKqigA2AAy 9qZLoVg9vZl5f764Idhx4sq0+GM/tfD1Ne5OctrM/i5CenR6zRafwsYHU7l7Hpn/ABzbT/jDH/xE ZJ1qJxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KrJIUkryLCvGvF2X7J5D7JH0+PQ7YqkFv 5A8sQwRwrbyUjRUFLm6AoopsDKf15HgDd+Yn3rpPIvl0xsI4ZFkIIRmuLpgGpsSolWvyrjwBfzE+ 9seRfLQArBKT4/Wrn/qpjwBfzE+9LfNPk7y/B5X1eWKCRZIrK5kjY3Fw1GWFiOsh+7BwhIzTJFli zKrKVYAqRQg7gg5ju2Yhf2Ysrt7daemKPCo6iNq0FKClCCo9hnS6DP4mPfmNnlu0NP4eTbkd1DM5 wXU6b03B29u304CEheJVKgmALUA8W5VFexo2QgbAKZbGneon++l+9v8AmrJ0i3eon++l+9v+asaW 3eon++l+9v8AmrGltFabbrd3qRNAphUGSY0YqVWlENeS/ET0PVa5r+0c3Bjoc5fguw7NweJks8o7 /qZYWUinAfe39c516anp2m/8c617fuY/+IjMt0SJofHFXU98VdT3xVStZmliLNSokkTbwSRlH4DF VXFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqkvnSJX8p6yWLDhY3RHFmX/dDjfiRXr3wHky hzDAMxHdpdrentdWweJeVxBVo1qByB+0tSD1G46bgb0rmXo9R4U7/hPNw9dpvFhQ+ocmMKyuoZSG VhVWG4IPQg51ANvKkUuBAO4r7YlClbyzS28UswAldFZwtSoJUEgV3p4ZXhNwB8mzLGpkeaplrW7F WmZVFT3IAHUkk0AAHUk7AZGUhEWeSYxJNDmyjRtP+qWvKRaXM1GmNACP5UqC32K+NK1I65y2q1By zMunR63R6cYoAdeqYEVFMxnJeoaZ/wAc20/4wx/8RGZjokTirsVdiqB0S6gvNNju7d+dvcNJLC46 MjyMyn6QcVKOxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KpB550+zufK+qzTRBpbeyupIJK kMrfV5EqCCP2XbAeTKHMMFzEd27FWN6vo8lvLJdW/wAVtIxeVCfiR2NWYeKsT/sT7fZ3XZ2s5Y5f D9X6nR9paLnkj8f1/rS0UruKjwzcukWJZizhtFB/d3Nuk8Qp3IBlFakmjuDuB9qg6Zrezc/FHh/m uy7SwcMhLpJdmzda7FU28vWHqst/IrKiE/VTUgPUFS9B1WhotevWn2Tmh7R1fF6I8urv+zNHw/vJ c+iezXNtB/fSpFXcc2C/rzViJPJ2xnEcysjvbKY8IriORjtRHUn8DiYEdFGSJ6h6vpv/ABzrX/jD H/xEZlOkROKuxVjnnrWptP0lbW0cJqGpMbe3eprGvEtLN8JVvgQUUj9sqD1wggbllDGZnhCP8sf8 cK0/1W/4mchHkyy/WfemmSa3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqkvnKCB/K2sytGrS JYXRRyAWX9w42PbYnAeTKHMPK9VW7hdZoY7y7QyLK8VvJEnpiMDoHMZcPShSpG5PWmYwdxK/NbDb zxTSXBivpD6sjrE08ZWkgGwX1FUKvpfCtduXu1FQPejo555ZRHJaPHEyMXkkaMivLiE4qzE1FT/b 0DK0m1TR5oJDPaxmS3A5NGvxOpAYt8PVhsAAKtXNzpe0ARw5D8f1uk1nZpB4sY+H6l1zaGbytZSK GeW0hhnUD7RCxgOAANyULUHc06Zr9Lm8PKD0dhq8PiYa6pQpVuJDDi24auxBFagjOosPK0saPnyD /YYUMexBANa9K79x9GNXzW1wRAzMFAZzydgNyfE+OMYgCgpkTuW8kh2KrXRHUq6hlPVWFR+OAi1t P9G86+YtJkUw3TzwKAptLgmSMqqkKorulOVfgI6CtRtmNl0cJjlR8m+GolHzeteV/NFh5hsPrFv+ 6uI6Ld2jGrxMem+3JGp8Ld/YggabNhljNF2GPIJCwwPVdVk1nzBd36yiTToCbXTKMCOKGk8g4sUI kkT4T14gfLMbNLlEfH8eX63ZaPFQMj15fjzeg+V/+ODad/hbf/ZnJR5OJl+s+9NMk1uxV2KuxV2K uxV2KuxV2KuxV2KuxV2KuxV2KuxVD3mn2V5BJDcQxyxyhg6uiuDyQxkkMGU/AeO46bdMVQn+F/LP /Vosv+keL/mnBQZ+JLvK2Xyp5bdOI0u0j3B5Lbw1oCCRuh69DjQXxJd5Xf4X8s/9Wiy/6R4v+aca C+JLvKlceUfLc0RRdNtYTVT6kdvCG+Eg/tIw3pQ7Y0F8SXeXmWiimj2IrX/R4t/9gMxTzdzHkGM3 miWul30xtoRFFdESBl702Knevw/LoR750HZuQTib+odfJ5ztPCYS2+gqWbN1jRrQ0ND2JFafRUYC kL1kt2FVVyKkdabg0PVfHIxJITIU3WD+Rv8Agh/zTkt0bOrB/I3/AAQ/5px3XZ1YP5G/4If8047r siLC5nivIlsZprW6uCYVlilMbcT8bbrwJACcqV3pmLq5iOMmVH9bk6TGZ5BEbX9zK4Y7eGJIo0YR xqEQcq0Cig3IrnME2bL1gjQoPRvLH/HCtKdOLdev2z8syY8nT5frPvTTfC1u3xV2+KqcM3qPMlKe i4SvjVFev/DYqqYq7FXYq7FXYq7FXYq7FXYq7FUp17zPpmhyWMd8ty7ahK0FstrbT3bF1jaU1S3S RwOKHt+AJCqQa9+bPl7Q7qS3vbS+HpxW9y0npIgFvdHgspSWSOVeMnwOrIHB/ZpU4qq2v5seTZYt KNxNcWVxrAiNpazW0zurTzPBGkrwLNCjGSJxQv8Ask9AcVVtC/M/yZrZtksbxzPdA+lBJBMjVWJ5 WFSnA0WGQclYqWUqCSMVTH/F+gf7+k/6R7j/AKp40q6082aFd6lFpsE8jXkyPJHGYJ1HCOnIl2QI Ovc4qmsiM60V2jNQeS8a0BBI+IMN+mKvHNFFNHsRWv8Ao8W/+wGYh5u8jyCzWdP+t2pMa1uIatDs Kn+ZNyv2xtuaVoe2ZGlz+FMS6dXH1mn8XGY9ejF9+4IPgQQR8wc6oEEWHkiCDRcKV36d8ULIp2mT kUKcWdApIJojlQdv5qVyvEbHxP3tmQUfgPuX5a1uxV2Kp55csiEN83+7RxgFWH7uu7EEAfERt123 B3zne0tTxy4R9Mfvej7M03BHjPOX3J3mtdo9F8r/APHBtO/wtv8A7M5lR5Omy/WfemmSa3Yq7FUJ YSxyy3rRsHUXHEkGo5JGisPoYEHFUXirsVdirsVdirsVdirsVdirsVQWraHousQR2+r6fbajBE4l iiu4Y50WRQQHVZAwDAMRXFUPdeU/Kt3DHDdaNY3EMSJHFHLbQuqpErLGqhlICorsFHYE+OKrx5a8 uKsCDSrMLa+mLVRbxUi9EsYvTHH4eBkYrTpU064q618teXLSaCe10qzt5raotpYreJGjB5g8GVQV r6r9P5j4nFUyxV2Koe9sxdRqhmlhKsrh4XKN8Dh6GmxB40IPaoxV5Foopo9iK1/0eLf/AGAzEPN3 keQRmBLG9Z0mWCeS7t15W8rc5kUAGNz1cAdVY7t3Db7gnjueztZX7uXw/U6TtPRE3kj8f1pZm6dG ppbywQpcfE9vcvKVPxMUZZSnE0HEKRQjfry7Zr9Jn9c4f0i7DVYKhCfQxCpmwde7CqK0uwXULlo2 qbeEqbj4Qysdj6R5VHxD7Qp9nwqDmt7Q1QhHhH1H7HZ9naTxJcR+kfay3Odekdir0Xyv/wAcG07/ AAtv/szmVHk6bL9Z96aZJrdiqR+ZvN2maDas0jLPftxW209HQSySSGkYPIgIpP7TbfM0BshjMt/4 RzLEy3A6lR8i+sdEZ5ypuJJ3kuGQABpXAaRqAKPick9MqBvcN+aPDKvd9zIsLU7FXYq7FXYq7FXY q7FXYq7FXYq7FXYq7FXYq7FVksKSceRYcSCOLsnQg78SK9O+KvCxLdwaHaSxzyJG1tAirBbNcSq/ GvOi8qrT7Q49BtuRmL1dzvQXtc3tw0s1reyxwyiJ4FeykZUWlGC7KzFy6k16fQ1FNk8j9iYJqEMr xxrFMfVLLVoZEVQF5VcuqgA9Pnt40FMrSfVdHkhcSWsbSQtXkqjkUJICgAfEQeX0U3zdaPtCxwzN Hof1uj1vZ1Hixix1H6m7O2W98rqYgJHV5prbjxJJEzkBSxp8akryr3zC8bw9QZf0nNGHxNMI9eH7 UnQIVDRn4WAIKmqkElqjtvy6986QAcw8zfe2oZp4YnPpwuQJrhaEoADyIU+J2HWlamtKGrNLII+k WW3DHGZes1Fk9jqWjootLRiEi2oI5OIJ+LdytORrU1Ne5zncumzWTIWfm9Li1eAACJoI/wBaGgPq JQ/5Qr91cq/L5P5p+Td+Zx/zh82vXg/34v3jHwMn80/JfzOP+dH5hmmleatA03RbaO7vFEiq3JI1 eZh8RPSJXOZMcM65F1GXJHiJsc1mo/mV5ft7Qy2Ymv5yP3cCRSRbkbF2lVOK+NAT7HL46PIfJpOo iGH63+ZHma/VorKL9HW7Ch9MF5iCrKw9UgUB5AgqqsCPtZm49DAfUbcaepkeQpj+i2d3c6m1zLHI yxlpZJm35zSE/aqCWPxFyfGmUdpZhGIxx6/c5vZeEmZyS6fe9d8lArpDBtj6zdduy5rMfJydT/eF P6jxybQ6o8cVdUYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVkkKSV5FhXjXi7L9k8h9kj6fHods VSC38geWIYI4Vt5KRoqClzdAUUU2BlP68jwBu/MT710nkXy6Y2EcMiyEEIzXF0wDU2JUSrX5Vx4A v5ife2PIvloAVglJ8frVz/1Ux4Av5ifetn8ieX2hdYopY5WUhJDcXLBWI2PH1RWhx4Av5ifewG2t xbNdW6mqw3l5Gp36LdSAfaLN27k5jy5uzwm4Asb1ewNpeMV5GCcmRCdwrV+JOmw3qtT+Azfdm6jj jwHnH7nQdqabglxjlL70Fm0dW3wf7RYhQKBabMSetfbfKz9Q9x/QzH0tZYwdirsVdirRNBsCSdgo FSSdgAO5ORlIRBJ5BlGJkQBzLLtMshZ2aRGnqH4pmG9XbrvRagdBUdAM5LPlOSZker2GnwjHARHR 6J5Jr+h2r/v5/wBS5Zj5Ou1P94U/ybQ7FUNd/wB/Z/8AGY/8mZMVROKuxV2KuxV2KuxV2KuxV2Ku xV2KoXU9U07S7Nr3UbmO0tEaNHnlYKitK6xICx2HJ3AxVJrv8xfJFrbyXL6xbyWsUM1zJc25NxEE tjGJR6kIkXmDcR/u68zyFAcVVU8/eSzZzXr61aW9nb3T2Etzcyrbx/WY15vErzcFZgpr8NfwxVfa ed/J13cm0t9bsZLsSGH6r9YiE3MSCKnplg+8jALt8VRStRiqd4q0WUEAkAsaKD3NK7fdirUgkMbC NgshB4MwLAGmxIBWv34q8mPL63qHIgn6/fbjb/j7l+eY0+buMH0BC6rYm8s2jU0mU84SSQOYBoGo Dsa0Ox8euWafOcUxIMdTgGWBifwWJg1Fdx2IIIII2IIO4I7g51cZCQsci8jKJiaPMKEvFb23dg1S kiKw+yKlD8W9P2QPn88pnOskR3g/obYQvHI9xH6URmQ0OxV2KuxVMdDsRc3XrOA0FswNDxYGX7Sg g1I4bN2340PXNR2pqaHhjrzdx2VprPiHkOTJs0Tv2deSa/odq/7+f9S5k4+TqdT/AHhT/JtDsVSi 81EnzJp+nIVIWOS4uAeXIEqUhoacaGkld67DFIGxP4/Gyb4odirsVdirsVdirsVdirsVdirsVQup 6ZZanZPZXsZkt3ZHKqzxsGicSIyuhVlKugYEHFUqufIfla7tHtL+1k1CB45oWW+ubm7Pp3Pp+qoa 4kkYVMCEUPwkVWhriqjH+W3kaK2jtYNHgtrWK9XUo7e35QxrdoixrKEjKr9lBt070riqhp/5U+Qd ONubLS/QNrc/XIeM9ztODC3I1kPLe1i+E7fD064qnU/lny3PM80+k2cs0hLSSPbxMzMdyWYrUnFV CXyX5QlaJn0Wy5QSLNERbxqVkQ1VtlHQ4qmd7DcTW0kdvcG1nZWEc6qrlWIIDcXBBod6Yq8pAcXN +Hbkwv76rAUr/pcvbfMafN3GD6AvyDax3X9Oljna+iBeBwPrCipKMNvUpU/CRQNTpSvdiNv2bqxH 0S+Dpu09GZfvI/H9aE0u1iu717ab7EttMo+ySCHiPJQwYVUkEbdcs7UyUYkcxf6GrsrGJCQPIhBo X+JJABNExjmVegdDRqV3p3Fe2bTDlE4CQdXmxmEzE9GpJYoioldULfZDECvyrk+Icra+Erwa7jpk kLDJAZFha5itnkNBJMwCrtWpFR91RXpXKNRm8OJPMt2nxeJIAmh3srtb3RLe3SG3uoFhQUUeqp9y SSSSSepOcvKM5GyDb1cJ44iokUvXWdHZuC31uz/yiVCfuriMMzyifkk6jGP4o/MM48oa7olvpTJc ajaxP6rEK80amhApsWzJhgyV9J+TqtRmgZkgj5p3B5m8t3FwLaDVrOW5PSCO4iZz/sQ1cZQkOYax IHkUXf39nYWkl5ezLBbQiskrmgFTQD5kmgHc7YACTQSTTAPJs0t35kOp3KcLzUWknlU/aVOBEUR2 X+6j4p0G4r1JyviuXkHLyY+DEO8nd6Nk3EdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVWT RvIhVJWiY9HQKSNv8sMPwxV45qt3LaTalcc4Y7aO81AzTTFvgP1uTgQqj4+/w1BO1Mxpc3bYjUAg V1qaURvb3enTIYFdyJjxMitWWjryAT01ehIrUeAOCmzi9yOTV9O4oHuoTKzJEUjcP+8c8QopufiB 7dj4HBTLiCFgsI7TXl9M0WWCakfQrxeEkfL4hmTm1EskQJfw9XFwaeOOcjHlLogPMNisWoLdhOQn FC9C3GRRQ/ESeIZAKACmx7nNj2XnFcB59P0ut7W05vxBy6pdm5dK7FXYq7FXYq7FXYqr2Gmxahep HLGHhQFpiQfs/wAtQP2zSo7rXNd2jm4IUOcvwXY9m4PEyWfpj+A9I8pEfp6Ad+Mn/EDmhxc3d6z6 Pi9By91rsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdiqyWN3UhZGjJUqGUKSCejDkG3Hbt4j FWMH8v7FpZ5WvrtGnnmnZVaAqDNK0hpWGv7X+3kDjBciOplEUHL+XenKKLf3gFSaD6sNyan/AHT4 4PDDL83PyWxfl9amJTLf3aykDmqNbsoPcAmAE/dj4YX85PyY35j0Sy0rWrBLe8kunkguhKsrREoU a2IFI0jpUSA7+2QnEAORp8xmd0BeWsd3ayW8myyDZhQlSN1YVqKqRUZHHMwkJDmHIyYxOJieRYcV dSVkUo6kq6HqCDQjOtx5BOIkOReOyYzCRieYdljB2KuxV2KuxVxIAqdgOpwKyXQbI29l6ki0nuDz fYghf2FPIKwou5B6MTnLazP4mQnp0es0ODwsYB5ncsq8pEfp6Ad+Mn/EDlWLmus+j4vQcvda7FXY q7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqgdY1qy0i3hnvPU9O4uYLSP0o2kPq3MixR1CA0HJhUnFWM eYPza8uaHBJPd2mo+kkDTpytXt3k9OWKKRI4ro28pKfWFctx4ceR5fCwCqnB+c/kVmmW6nubJoZF RvVtpZE4SRevHMZLdZ40jeIM/wC8ZSFViwWhxVMfL35meTtfktIdOvHa5vDxht5IJkYsI3lYcinA gCFxyVivJWAJIxVMX82aEjsjTSBlJBHoTncfJMVWJ5y8vPe2tktxJ9ZvHMdtH9XuByYDkdzHxWgH UmmKsY88ahaXOuadFC5MlvDeJMjKyEEm0cfaAr8LjcZVl5ObouZSfKHYMf8AMdksTC/QUVysdwAF A5H4UcnZiTsnf9noAc23Zmp4TwHkeXvdR2rpeIeIOY5pRm+efdirsVdirsVRuj2BvboswBtbdh6t T9qQAMEopBFKqzV2I23qaartLVcI4BzP3O27M0nHLjP0j72VZoHoU48pEfp6Ad+Mn/EDluLm4ms+ j4vQcvda7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqo3dnZ3kQhu4I7iEOkgjlRXXnE4kjajAjk jqGU9iK4qln+CvJv1b6t+gdO+rVLeh9Ug4cm4knjwpU+mlf9UeGKqg8peVQJwNGsQLlme5H1aH94 zq6sz/D8RZZXBr2Y+JxVfa+WvLlpNBPa6VZ281tUW0sVvEjRg8weDKoK19V+n8x8TiqZYq7FWBef 7iJtV0t/iRY7e95tIrIB8Vqa/GF2oeuVZXN0XMsce9so/V9S4jT0OPrcnUcOf2eVT8PLtXKadhYX B7W5SSIMkyfFHMlQ47qysN/cEHHkjY7Ma1LSTYsDGWe2Y/AW3Zf8kt3p2J38anc9DoNZ4g4ZfUPt ec7Q0Rxnij9B+xBZsnWOxV2Kr7e1ubuf6vbAepQF5G3SNTtyalK9PhX9r2FSMXVaoYo316OVpNLL NKhy6ll9tbx28CQxj4EFK7Ak9STQAVJ3OcxOZkSTzL1eOAhERHIKuQZJx5R/47sHyf8A4gctxc3E 1n0fF6Dl7rXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq0zBVLGtAKmgJO3gBuc VYP5/glu9T05Y7Se6hjgvIp/Tt5ZU/eG2IU8UYEMAfuI7HK8gJcvSyAJthq6Fr6XEvp2rLavT00G lXAeMIwZFDD4WA+JhVdmNem2V8J7nL8WPeFePSdYinZ4rJ42l4tOV0y5DuRSpLA+PKlele/ccJT4 se8IiCw1X6v6d3Z3Vw55c2FjcIpBJIHAq2wG3U4gSBsL4sCKJBSG68raxCaWtleXCCnwNbTiUD4V BJKcW/aYnb5E5utP2l0mPi6PUdnx545D3II6TrgVj+h9SohIP+g3ddvAenv9GZw1eMjm4BwTBqkT aeXNenkX1NNvYIvhYs9rccipFTxQJWvY8qUr36Zi5+0YgegcR+xy8Gg4j6yIj7U/sNGnsbcQQaff Uryd2tbgu7HqzH09zt9A2G2aPIZzNy3LvsRxQjwxIARH1e/rT6he1pX/AHkuf+qeQ4C2eNDvDf1a /wD+WC9/6RLj/qnjwFfGh3hOPKUF2uuQmS1uIlVXJaWCWJfskfadVHfLMcSC42qyRlHY9WfZc692 KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVripYNQcgCA3cA0qPwxVvFVojjEh kCgSMArPQciqkkAnwHI4quxVb6MXq+twX1uPD1KDlxrXjXrSuKrsVWiOMSGQKBIwCs9ByKqSQCfA cjiq7FVgggEzTCNRMw4tIFHIjwJ64qvxVaIohKZgiiVlCNJQciqkkAnrQFj9+KrsVf/Z</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:0d436a03-65b7-7540-b268-c1c29ff6da6c</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:04801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>xmp.iid:03801174072068118C14AA247F7D2A30</stRef:instanceID> + <stRef:documentID>xmp.did:03801174072068118C14AA247F7D2A30</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:19:32Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:03801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:31:30Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:04801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:40:26Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY4/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 2/Kids[8 0 R 9 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0 0.0 422.158 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 10 0 R/Group 11 0 R/LastModified(D:20170110154029Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/Font<</T1_0 5 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R/Im3 17 0 R/Im4 18 0 R/Im5 19 0 R>>>>/Thumb 20 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 9 0 obj <</ArtBox[0.0 0.0 172.8 129.6]/BleedBox[0.0 0.0 172.8 129.6]/Contents 21 0 R/Group 22 0 R/LastModified(D:20170110154029Z)/MediaBox[0.0 0.0 172.8 129.6]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/ProcSet[/PDF/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R>>>>/Thumb 23 0 R/TrimBox[0.0 0.0 172.8 129.6]/Type/Page>> endobj 21 0 obj <</Filter/FlateDecode/Length 271>>stream +HKN1 D9/nqxKB@|$h1ec'z%'�~ 8 8<~lX:B"j _tz7,bk-~ g褠eSYAyM(W$Q"5{h,й E=-{Y F't2Xȣ|IOaaҬ7U" + hu „^mG%D|!ci:07+1`I}%�^o endstream endobj 22 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 23 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 16/Length 135/Width 21>>stream +8;X^7_%"16#QrbX4#'DaMrtC2eu;57gBHl`&i(hmAH"!L4u?Sfbt\_Z&Hd+CQPhl= +q+$8T#)V#f8.7AAUIh>Vc4IMd3)n#1aWR9HOhiVTNHW8;CV/iogAV-hhHTFL!5"iX=T~> endstream endobj 24 0 obj [/Indexed/DeviceRGB 255 25 0 R] endobj 25 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 14 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 37724/Name/X/SMask 26 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUUK+4#Q+Q-J#1"!*8!"(>Ԫdd0$ SKoGQ ,>iilRn!Hߗ4=Y;{%w2�����������������������������������������������������������������������������������������������������������������������������������������������������������������Un˩ߎ4hX꼁i�� 3[~?w'/T E5K ]ldڽ��~Р̉O?v/��@ޝJ1K#�� V?듕d6e'ۚn_|`qq��~SmͿ%UrYOLlYrlCLK?�� Dz sYܶ5uk%GޞVk��@d4hHrƣݞO=?ٙzzo7f?\fRYybRJ)X%{Z%{e綷qݞ=bdgX2﵁=rRJ)TؕmK|1wߛTVcTվUiܱr+dOKdoPuwgƩ>_[3t{ {L'$n٭usk?w\kjry-߼O{Kc A ǛunohcK60;p>;. 9~0*\8|?w\ +y.x&qapsDžJپFL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@k<�;FL3�@kĤk'>Xv+��@ &]E ��?I<6M��.&yNjʴ�?b5Dz {%~��N &]qJoO%��. yTVhme˪c �y^;7��a?y�[׈�Zm_#�@b"��M &�@b"��M &�@b/lp=^B[��C & 'hi(��HTRA,︳9OOO3��5oz];}﫚>n �Ĥy~)W{_w�@B &\:fZv�@B &3^rҡ3��1y$s/\܇�?-MC��t# �f � l_ٵھF,�jGg竉}RYyV,||99999o,;X&Wcڪ_SUus8s8s8s8G=ύ7j��ז}g�׈y�}g�׈y�}!Y=Ky�}tɶ泹:#��_5jg~ݿٯ3/EqFh&N\jhbw 0DH*4&&*vwFpe3%.t&ŊKLgT܀Ȓt|?3p9s}Jr2c���&OQ51c��{_CWWV4=!~&���tok"Ϲ ��нѯqemt1��@F*c_S֢=9F���yrsKdPU><wH}}y>i)tҒt ��yIղ'>f#>zme|3n|<ÙE��>wA@W3o_Wgų_VFy:OpX:h���ta$'3Q]l̺���HF@wUo'۷+��@GMF4[Vл���4X y(J<Tz���Ф82ē?5Oۊ]���Y*O#(<ऽJsл���4L4“??/л$��� 8ӧ!(<#ʚS}mz��� l%''dTiۖĕz���,)Iҟwi'eWf);cӻ&���(˪s-ǥO#(xgFPfwM���PJs4ue?`$GHvhy?��05Ǥ/ Ɏ H{먐7z]��El`/yl ��)!җ 0TVE[j ��*bgIy$ޠw]���fvNs4v$hZ=#. ��?П?`$-ǴmG���h7J?6uZEѴf##u޵��/#hZJ^���̨i$0Ng*qS���̨ZseO[F?e;b��_҇I?F?۽ްz��`&ƮՊ#j-j-z��`&+B0ЙRkCFzYQAzA���̤BZY}FViK]\9o]��HgKYHQ?֦ FѻD���S8flc_H01ioGD ѻF���3m~=R?`TmЙBs\wegB��̠$;#v]0!#0iw���fP]N=Qݲ'#H՚50=SԌgU fB-Qo֭w|*/SוeWXr*-yǾzO+|C"}W55'&w� =F ULUWx9' >uYoNkNsܺTw&$$߻fė7._8~ʩ~NzO+oR'uJR/�GӓJB?&.k<z {?@͟9Km'=!~33%ʑ_^[|dօ~//;FA_u9Np_Wʺ\EJ[_#ϓGNl➏K'ʼe�]/+?p_Y{'tr@om:ȚzxuMIǞR;u;siۆ{NޟQUaJY=L-<d>2/S۔M +e=d]$�:f>]j_Y{CFʇG*\+z kh5likgEY0Oi~rR 9d2oG}i5zI�f| ~#(XTk;z @SkSQլ:DUn4_NdcLr)Ⱥ~unz0'鷢-I?#:+RiOOлT�[:u(&-9] ]wĽ+#k<L^OYWY߯ŹYc<?Cr�>򔨁]Gc|ԒGw�=/>xΑ-_)˽ߋov'oWfβ޲5%Λ9Gv>yyx +bMG't:YjVw�>z⤃KjJlW7W/o{dߚpߏynQJCE<b*f<ջgO?J�ҼOگ֋?`4IeGϺlѻV�?O$ZVoc*Zh{>~ɾ>~ʾ*]O~G5uQP@ +Xh-uAgVE걊RNk (`u +%E$dyEPH@[uԍXǶ+Na ,9{|@sG?G7Xtw龜(RYӘQuԨg<?x<;<g"b{ͤR[?G7 E)<96O<jVrߛQ/~s>- I.^^R#`n&w\_Aʨwfҽ9mC9O" ŵQͯ@^G&-춇@ sJ~s#^WGg@#.KMKvOթ-�z_ 0k"= +*gU|O= bO?r*Yn8BmASDPܧ_Aʨ3<^IԩvD'" O #}l >648 Пj%1)UЯ*<`Pf%%e׳6&rQ6pI_n4Bf %Y<~)r[ҮIGF?iwy ȵa$zv!ЫV$'(?7*wؽAƟgLnZBCt*G!͉ù(|~_hŵĎyw, x&z,`0t/bB~Lt3@Ņ}j75-ie 9ˣ( p64얀w?! K'ZOУ u; bo?@?6|g\M}Wm@{ÓiZFq%6i~50C#AO&Bo:rw9HU)?F<6؞:Z"QnQ}{ϒUQ\.Nل~pشtR?^:|}FIH<_P}E9CJzUH4bP 6;gxdz\YrW!H"b~nD-mٗuߢwJ[ֳ}qJ2vˬY?K4 }Ko)YDȃ)T[/Alcݳ +.[}D:U! O[A̧;eM>j8{6n<q'myd$õ>~%I%$5A)Sy|2_|Ki$]b| +~* ǽ=e*QB@ += :b` sp DeI}n0tƥSn೨йy<(CCV %m>h12WWm'Bkat5O4e*|6l֨SHaܒb*3fHNȣcҳyDzCfZ@ Yߒz.ɔ$ +KKlI_H% CXЇJ_o]NJ~ڜV.^5\B]cok*H!!|<'X+3'JAaƯ#%5ވB=oŅ;8#_uS)?{a?9:r(,=S5 }K}.75QA^!tA +m]\z_" 'P/Joa|7rQDxIYR}j] =0K>z ;\q{QKlF);F+" 5fuP%(To VC]U;9d@G{0(h]ʖKY5?;b븻*Dh_^߹?e59CH\a[[a˔b)!lR.H##x{x[_WOW pGpQ(@  8 >P[>Ė@^յkAɠ@>}STrJ2%uхۆw?6JB5L?-Wg҈&uyFpwu%֯\ȯ6$~~KBY yA> ';| 7bl]L*{.n +G%6{AOX#{?0y34gkCDJ֦=_Q4m <5>NE8+_kY4 XCP(Gry@~ GbO'{"ٲ�A%oVIkO@l})[}i06|1*6e-N1bIҦ?&,{&q�= + +e+!>f6ryB{�z=2pWSihʒޅF?de;{ހ{Ζ40M+W<o=<`ηw3r(JLT9 ;$vX1<W bOLRX%3kU%Z'b1.eL:03&*ubI7ę +h\D%SDdEh腾 &@ҍE3QTR.#IE9}:H\k.S{뼧S)wԟ!HgD2ƥA�[T|;⥌4+n'?o�byʨ�]=l`g̛ux*&JrmzPp:!B~QϨo;�:}g<z}s~dgK#Ԯ?(+q|6&p ЧX־4׷kcj6w4{g7]>/ +�x" +}Ԭh^~$gu-@LXp  tZyHݻǁ3l`ޯ @8:8\tjy3׏ԟ!HW FΫgn + +v^` 7z MCrfbc:IK?�Aɏ + gKj5\ƾ,0dhIFҜ,M?UL_&ǒ,)�{$c 791yyx &,uPFDvw{'-[)(. ~m�K"ϹSR{!sKC� =%ݍhW2գ:`yѢ}ױp�1ahdޞ.f줠uJw �1e7+WJym["[ Nƞ^.z =2DB^Y˹ȘN 3~ K׽Ŋ5oꋎ~՞˵VB)9~qХqsvfg.z6c!롞6㩷IQ^c�xAC>ZlJc(:z|�mAރf!Nֆ3AeXVV [jo N*A,ۂK=>wޜn紵>du[�beJe/{y&6EH^Aٙ%o6潹.z6K!lRk7�DI&yώ*@LXeBQՅsmyP?z+y>"*2m o.O<_Ƿ5{qW "|L^;bN k}Y'7={e3-6z ŅDӮLX6{)1é�X۽cgg{,T?A٦HT7b/ѯRP\�3n<P*Ni.&IX'[UzOpw7zҽ/ yN"i5| +־?^|߇)ϖ{z| c'e宼MhO7GƕF&ZcߩW.[Z%(.i;{_w{p�X=ðmW[ ! +Y)o�ăG_V}Jz?&^߇mSzWU׊2h/�` 蚭Pȴ+62Ke-Ą-kg0l[#ռ?)Sy ޛ9o-K2l@ 0w&Di&ovcswp�D*W +]GIkxyqqrbvƌ9n9f* b`Űv1۽i_�%5zKאDRYӣp�1ac@Zg1Ӂ?d'O:!JssܡNtA+r_s=A�O y +ʕÞժE~3*"j [*MEX}Q۷ -@"lnZ>M }Bk8as9|L!0 +?гnt3M$?pwg>CfļyA-&1'�')f0[H7%u�<9?VOf"EْZ~IAٸqi3?N(e5s{qwA:g.%bG*2ݟڀ)(؅<mkF:ɪ [Ь:!6m[CiNJx`D^BZun]Lbr H'WBC{q~)WfB5fgV= [aL+(/Po7x`gH\]"i+f-#Oh~{;oL2aKٹ::|�OJ*e Au-?QԞci+x`? ɴyRM&{%]Aq'F{,OC|*.<ἐDRmN?qxG-2=vTߘ5MY?͇WN$|Z "О}C{o4+0Jc+Ҫ_2t D.7�bAI<.M;U{AϹ2?}`V{]F X1 5Bi {$EEx<*MEǤқp�1s =|X1{N-??4(+ ç%%M&Z1N6qAE⾁ +)"4t7mdj5AQ$1zʪیfBT=?U]\Ϲ={i�:9;3U|hxW| +!rE^C;:9F!FY0;쩿̉ �9`,VV]K">׹3hw7-6 p)gu('BؾraGKO}wAg]PoB=�\975k,L(BCٔO^'J`A4WY Po 81ҝ %x7LezQf:?� yco崙|B(r~S7䝙a!êQ[z �^>+T gqY^vtvqa꣱_z$3 yx28W+K;9;PІd%ϲX7@=JH1_} %x#B~ss~3D xϐ5p- HyEϐPY/l|n2.GXsj.%DNFu;4b' eԯdrl찏yG*heRDN͏R<.F\$R?cApO^YAѠQ7y;eY̸*3B*f.dlgKfx{q(o'SoG +L >y_n{wn5/4u.�!‹3(֬;cVS(?3}B6[y9`,R?u)?1Gc30{ɨvqtT`g#o% 5<kO1Ĉєw:A}q=^Bdmr;ϞR?l+Ъn?&>ϽNuo?k^NL{2~SVu!Mƻ+@a[ؐߎrN{"~>-u|o_7)?�h2an<\;_zI{Kڋ%gd^?¶rDHNړwE2U\rxOP/ _ƻ#a�߅-ѻ4fzGIy/Ą̴K {ZB;=?A`Lb%I|TwGl )dBNjʕ,EmLPt<z7ci!{?;I9HyϹ'.r/u93`kHmԍv2qbz^2 l[`ܧOK [9fbFbѝ!MF}vݍ0�[CjLv @){"3zd΁-=1LBR>);rQ;sIj歂ؼַBl%`kHm ץNś̳C ݾ=y/aoggZ?t}C\|?H7^zE˻#;`Hqa*kU5UĈ ݇,y^7_Y#+/kUbp!Pte@޵}/"4zHOc݉0�[DN)Ԫg#aoMFmG''K²Ϝ.B(e 1sOS~P4ʺGV}o2ޛwlCv{5>Z-΅sKU5-[#oteSO)͒WmC5HyIi$Q+;9KWWZ}!`Hu g5hU^\bF*Ux/_͵ϐ_{ʰ}!$&1Gs)OPJ5<.ޛԹ)cX vv~yB۳gL5#cbn#· 8B+ 1_&qBh`rTP+JE>5+QwG;`-FAnk/%g1C?zo<rҴ%Y[fwSypXnh .ogY&w/Gk}BhRR4߸;cʂCZ Ҵ`-<+=sЁ]P9E ~GzۉoQbzs<`Vy㧲q Bh RX hu3#Sr2ۋ$7=;X ;.fC}I}pY=iU + Hd;!B^XLШUȘB[ra`Y #I=]/Ĝ!އ"Mk`-'U[><rgI} D 5ccyyV4f v[^|}+x u^i!E)_V+J}L1mx_ƞ=( +U & fZIFkU%ֈ:@[HEActe]/Zk'K(3QKW]zv5Io93{>ϳ̘7xgHJ*Rd+\ay9˞[tV)o|oH e�cu'8'l ~m{]Ԝ��lڳP_ڻ?lQiQn7wW13$%)T[{{ǚp='A$ퟧשo~l3Z*gTWC#mOr? ���h$ ՂZKŌ_gNņ}sygHj*Rd+\ay9?be{N*;a ;?-:D7 +BԷ,u)ۇ>HG<=��{K֨=Vqi3 yJrffiIMŊ1gsye{ +y١Z_mzMn z%<S=x{0��3聼A|@9+1 ;u3_rdmړn^4qr2;5{ms!>}199BFZoCLw_U aw޾ ��Aʧ:q?Rֲ4Ǫem;3כ'sPNCMcKOzw9dT(:qHʏ='A*gO(XK*ٺ{<*o��<awtSXA{C\l)O,<m? )+s1A2#~}k6+zwHf4nm(9.��QqRStS>05itwMe2FݣB4Ti7 +e1vO>#{DRpyȰi{ȞnM{<,A���+Q$7tW<3nS</ת U +xg$ADMy޹a..7X%n�� :;Hr\+o .oi6GtL٣?^ex]Kط\]W Ǖ��yXc )+bx{K?N Rr(GLi? {^w^) 3)73;}~Z=J&Q���/΃bWtp_ w(7P~H!,٫?3폎K{%g>c_bl޳F{��mAhk1̹r*MO@<U)?j,٫?*.VnyNC<U{|_<��l%\A[_l|Ox^:uS.s ٳ?&$[e�c.'m{֢Wt��=:;y^c-ضe�Y I;à@,)"0Yj<l^P}�sWOz7~P'��zў_ы^I3ψr兴9Y dzX=0'd유3~gS.|Wy?��~=E>oᩝk  ={N4_;@.'2ep$r krՋ(xևmkǑ7G���]x[ߓ?ߋ\0: dz "2Lv25EaMK:sw'j~y}��@C>{ƥ\)P^Y? 6/'b_M5.t>?B=x3rn]Xy|?��}ok\|`∑-D>oCd˙:ZVS];@m".c[osN/gtсA2޳kA���{ɫ1A2ӑ注]$fwVA'1(n7&gZJЁXޞCXVyڤ "��k&_ eRˋ;.ĄX~] +A}rflAOd+Xw^)_l{鎋f=.߮٥{��� b|Aɭ{so2Μe5Xʽygz*[oe7-wp!qk#irN_Wy2��]4-4'`K]f˻6&l2&3 +=-b6#\S 6A99}yj`߾"Ww4P���Xe#(Ws8m]T3Ǝ3m2; fJޒ;@l O Ocdx[B8{J}X<3pRe ��B>a(_"  V~{vG g2b.kcon r~_ZNDfs:ŕs+���*7N9g5z0SjvϼEQq"+w&AgecbRz.pxgjS/w=RCy773���ҁ|_HY\W=mR`3 =+[/3  I!j45)NhxG"-r 1)5`FZve]NS@P.oԶ c7odߙϿ}g='\)IʱV6|͕w;{&tYp��At.NnF76fel}q8{A@3Pǜ hKX] >KNBC\D��ť^&& + mɱ#۟x kvb5]A:@Ov"?3lN?3 W.eNe��aW+Xv\W!<N>Zȣ=. gbїqt1gj/)egX`"{mAHY���^|'US/%);#L>oc, s⽃ 3LQx*N8s赪[/9:~7^|>:2݇��� +͵1QnܼMES\gPpU;<=+~w%Qj2e\M aC_fgT.)���Ҍqo=3۶g}fűwyvz~pD8ofЪn vp A*e +}R~��0p bJaCqfkAƝEua W(4{>A?pgl5U�*qX,]U9K{ ��|C=qtyזc~wM ]1,AsC#"m+3鵪Nvv$.*o���v c]>}EG +!ӸC 2gpz-aB?*ʅ[<I-omC���̏kI4&ov'9 +Zhu{"y:]A:sãRnsm)?FQ^,n* ǃ6��|y (vJkntJ^l?Z~J~w}@@\33Z}ٕXVykOD`ox���47?sO=6lB&_>Aߡ>{@@ǜ^nBXpƶT(/K%.z0F}v̋s����QkM/<#v66R;^}?&}@@ǜ_8NyGt,gLu'!4Ա`k4[{Xo���'J"_wv9kU~y\˺Ow"n ]I-輭Ջ' g죳4Z[;HD)ϿO:3���-}7% +Ym9|(.T's:AsġܴCe9 Lg٩匕kn[Nw/Xs9%k���x)65e¢?4ɶ[gG^&?wNy3)7-N ]9Zљ[Ɇle˴Y+���Ӹu8a}H++fsxT>o4y|w +ẕeeZ L+^͘AUb/=*h%{c[V}���tk ˾敫%㿮4vNq3%_޻t/?$FH?&m5˧3-f`"3h[}���UZ*|%xbxKn&N<=;1ܚ. ݋I'KPUe^d-ceZu}`޾7]1Fy.fܛC���B"܍^l +^nE.Yc늜G J{t??y_DٛgkkO*+QjN+we���]9T@^sJ{͕]o[l*Bޞ{0҆ ݏ9I'K-TUd\yθqÒ^) bʑ_*^���@O)1;v8< \*&y|} 3{@@ǜmO`pֆQg[LMݓ0LuB<_����ŷ#ݳˣ$ߒw[kB|IQvwY̽HB<7+Yge&t +ȦV;r71oO����MC<,ت' L_Xen5y =XGi<™VTJ/YXt~gMDR3���Qo }^w"XiVzikMRo'CJ;3΀ =$& dB*WvI8*"Y2zLQ^iyw���WȽk>I5lx5~[/(K׼wy?~! eZ ޣkJU%E~Ӧ<&1`C92H:ٱӪ����5YB$:8\TZ$tz8Vg+5Z&a!$]Y4Ԅ0U dZQ㨐@M̼!<g#=*}***={*|guswG@ $:a_c,쳯&ղ>y-I9J{ +*6_ɜ;ˋ6 4TM��:^]i҃҇ҋҏғ硖zTUzVϓ^R欑־+?~}aIE%+U_uU}'.FŧvmL-oYɖU=ݲvͷC+z[ vO~_L8]x*|ݗ{g]{��&'=(}(((=)})))=*}**4mI*xĎ gU8T.3Ces .q8v ۯ2r]u᲍{n��:p0o_ߕ~־#hc;f̭Gȶh^3Wwcq.��Ucuqg'^Vn`Ku6ekXp7>{�ep1w;`XIx+|#Z?sMYGN~�];0NzxE7j Ab%ig6%8W,_c9h��t6 9u%e=w`H|׮mZƍi|c+hԼa^B�~g%yi w;aNM p?Fk(hY@Лkjb��:Uٵ{w;aΠ~&ŵEݿuYw;j+[s.oGʕ^'r^}4}cO|]<�tşL{'w�Mr:N&4c*/.Uy^3M|?r_Nf7fiWgUk��H(:~Yw�{-=uJ 6.qE°6?8y[.�`*YDzWAV?l^ʨ)ws?.:XQ}6�`coeTFv1푿˦D~fkϱ?.lvk#e^>�`/ZriUlvDž]9n:x4J�4Gwdn[η+1)쏶Iٴ䖐ۼY9 �),eIFzf31)쏶;+ +Vej��bUүҳ]ogbRm75/m��ĺ#k$%hwݱ?Ia],okܰ �@ܰp_;Ĥ?.Γ^^!]m��bէvvbRW8z,A� VՕ/}*AL +M^3|>�5-=Hjwz`x=g +- +�� +͝E +m=RFwz`4W?WۉWj��ĊcINȘGc ǥ2};>,�`wҗқ<?Ia\Wwh��nkĤ?.@Qayh�]IOJ_fjww,b<.Mߗn>�v><\)ݴ;?Ia\҂œw��FqI/3;;V?Ia\.O%%j��ͩKΎUbRѱrk;|F#<��v!;_/OX &w,~2.65mY�]O$8jQRvW21)Y{~}dy�6C%s;:ֱ?IaD&[!뽩g>��N˟;:ֱ?IaDWZInJg I�@vx7wv7AL +#~6ҙ=sk��h"<ov7AL +#^$?��MOz%ǵ;bRwsY>ϱ2;��v~qV8ߩw)Ĥ?<_|w���neI=_>.6 G*>:XQ��tU;4{ջ$bR'eӒC>o��&}'w\M &~gyp8O��hoeIvAL +}=vU~?v/��^>/c iwĤ?WV^;>,��D[Ʋ2=5G�@zsY>+^sM &12J Vݏ��"&u +5G().򞛿S]�@|)oGzNkM &qJrS<��\d+r|͝ݱc8 s[>ϱ2;�u~qV(ݱc?4!d`lBKKvƚEk!QBdR[$,!e a]7FY +&T@#)}tR-H?g"8cS�:0òg)\v[t쏖GAϱڷ2ʵ�:ZY'VNL:GK]rO((N~��p_a\_h7)Ihy%겍h7�u4t]gMu +gұ?tZE~g}kw�:S^5jMjg: 3:Sbe=AG[�^t}T:R'ap&Ceak7�r>ҭ߽66: 32VT]�jSҫ׵DΤcꗖ*T3Y��p5Mz^zv;t}[Sv|?��.+Yw:ݟLbp&C_Ve[�_^:%nS?8f |u;�@# sBԂhnE½:3Z? 'Y%lϮn �� m>1az+EV(tV'xfMjWyg=Q7��Q4jmjF:+ٰx=kex,r/L�-͠m'F:3$UVn`?ᅣBǏn�.LHI׶M:0'y\;aO[Sӻ�pq +zO?Hf.(o{Ѵ?X-i7�<_U:éO7_cp-qn( =PW7cKspy�;ß'>B|5=d7B9o֪[g[ROߊ#�7Omv ׹֘! m6֠~_핡~K7^;Y5쏍ˋs}[b֜9Еng{i7 �`,1vL>]L>?H ZML?HHʞ}o)VfI~VU[%�#-KzsNS~NPqަ zvv?l1iIB5&�.TO&;?Q}.g+vLϰ?"\ߚ҄=�0)|]'].?vVe&^gVy +F�s*s玠]Sot{H޸gN�{EI_nZxvpuΤcC۔X[o)*8+�IO|(}hWL:}<K.,�]7tekcp&^, +z? �J,Kz(']m>gұ?Vew깯j �`_ۆcp&~f3T~�G!Zv8ΤcOY�JG'MC?8aOYsv"v��vv7햡IXkuMUom�"BtFvxΤcWyXS_=v��Ron 360cP}6�"{Osei 7t{0a/T//?^o�#}NH/cp&WLi'O?8�@ӿNqvap& KrBA7Fw�9 ҇p'i +7t3o xO]n� rP$}Nh +7ts{>y{Ei�Oz ]x1w/:9ھW|+x�&X ̵S(gұ?2qC �thB`m­cp&< Ƅ{�/xٿnv4I0O)AW٣@�@;ZfpMB`p&LϮO)춇:jw�rn(gn3fNJ \UA?#{�h~-?8a~iIB5M�45{?&n3fN"�Ye~;Acp&l'Yქ9G�hz~?Pn}wykMt ˜A=Cn$�]ؓp{y?8 ˋsޓc; �h:^[L:3tSVE{DUNV�OzψWo 3?g}g^�nݹ7v /n kpT `@P)qt*u�[$p3DiPȥBBȍٜ\ ДK^eF6ywbRYWm^7�WNz1š2wbH.C7}ڷ�p=U\z] Ĥ?ϬˆmC{iO�,xwoKoӾ)1)䓖3ZT; +�+z'K5>s훂`HNCj58,)׾�; +;MQ%1)5j0ݷ Nվ�Kkv^劻oAL +#y̹*׾7;W� LƠxY6sHbHn#^8x% +�ؿ[-}=<ڷ &y[Vqm' hW�~~tbR={Ux?fY�פHh_k `H_2=%ح,(Ծ�y~hOk +aWު^�`Y|%\].1)\'>5ZAud&=,}\5I?kb7ݿ<[ }ڷ�ٗ-Oΐ>nڷĤ?mu"AC/�$#߈c.Ko܁AL +7ojݿH8; �DzW.;(}}bRhoV]qmso1�$s-ҿڷ� &,q֣S� '7m8S]y`+t^CHCɿg#[5![o9cIw�L&=+}[վpqkfMx}6[3NN͛<%uuQMO3|{^اϾB66-jpGD{W> +E nϱ?p)ˇ3}3�Kή\~vÝčYL=u=zwZ3Z5CNIW#}ZzVVNW*ʲz}F /;qLk读JWfk�0otGg nLC=ucK7aGY1敏}zt]�yVν=y�k|Ԓ7hw<܍Ar!}&\x7xFtM޽ݟXT>k6�$%})p?ulNhA?PP=o<wbr 󀵭G37�$"}CҫcX3{:g?^vFjJEk=??e2kg]e{wmozt>}He^ DyGDT>w2yOc+}=瑬!?isGgo{C(gȮ=nG@"9~Gsjw9?2b~E$i?9uVUȻgown=DL,͊Q] nM`'kx᮹SSJj쬉+7< 'o:�$Oyjlv#?[sMn+E ne6+ʳz;?ټvy~ƽ:�ٿv/}9+ڛݍ &3*UEOw�p%=Y\_AzSxĤ?pdX;߇w6Ufy�pEGIKFbb@W<G_x"S|<svW#q?Ia,N>Km'h{�pe7z"ݺ.h$61)trӭ׽ӿ�IzP"TSQĤ?ЕX8eGiSe� =;ڇ?-H|bRjg꫃��᫖i҃dAL +^7)\Q{��әR%Y] s?Ia zekÑ�wvbR!EYN`xcKe{�ĒZn[0Aa1)҄5O\s~�ҹ\^AL +V+qmxo~��7ߏ{Hy3;fb@=4f'�@W^~ Hiw. &xe~#OC�+HAs] s?Ia ^ƮοV/Z +~g�ˆh~XAL +TXA՟:i7�nh/5cc@<̹* Ft$G�<˒+ l^VAL +6 ״pu{د*;mL4mFk6+ktтzE"( sp9xA+n]W]Hukou@A9yWb 95y�h ɭSeJg*1?„X{p շ�ŷSHC*M);6T=�x|0ɭE)3ޅiP/zўm7r+�%SW8/ +B`4QZQc^]�4)+- C`460>D[./+:U�\:^SW3މip$GVjB� $8VI>8WuV{?# "";iG9�@<88RriΕA3ލip'INN}T�۝H%X2BUg#@`4#rSVnuaw|MitQlw;NTX[TFC�xs4nʡӒG3HC;zmLn\9_8I=;HޜPWB!c]n]n6̪t7 �p ɝд=Ug (c-6ydPw �ck<>u͢`<ipg~õ zNS_yG}n٠^*:'?# Gn~,VX$W$_r+UHި<)HC'9/kE*fW�C`4x7ҭT}n@I.Br5>3h 1?Iϩn]I6_�x&ɏKG2GtMcӄg%;{ 7 �5;$Gw$Wi@k?# ha?`;gyP0\ciӯTgZHCJeɻ{v` �XFed1?cFhɥy+v+�+ɥ 3 h c^[o~{|pKn.OXa>Zc^?LH.H>8~PYӠ0F``|VVfP/$͗  +xZHCQ [5nt+Tw�i!MpR1?`$cStm׿<Q{�5d8uRෛb&Y?# F3e>w佦w%{TrL1?`DQ{}.~[@璽EY3t͒-f>W]bQ1[K?`TqEiݾ_q{'#S]u +#v_4mz}iS\jCzb k' g�tu#dhNW_ud[;HJO~gŖ=G `w0qi R7ognPe+:s"+lS=É$�KZ{utqY2c뽬^vؠ?тbg:uո9ݚ{o 7IRq,y^>deWv̤{NFҊ_5 \x ߖ[mx\y9B;9k󪒝t*N|EjSNۻ5-L:HwmmIvS/nh<>u ӑdeUg LGۿ~M:AC+ 3I11lEv}JveWYN4]xUc=6ewi<6U_cڇ&Fxu=lg-'=#|0lGg%7#m xt ֹ[;q='NXu�A'o2S]wy�41+{ L=bҒKVT3wɞʾ=mN06BSb_z<rS^fu+fI\Vn>дɞ孑U@g08s&H?`޻?q~TJrgI11{o`Z'ũ}pd_w^~I}U +]gJve.6?RbRQh.-=C�zn-]h{l˪-�xl򫲗[z=ǘqEi-ۮ-<GсúZIGkW-t{Z7Kk/zps]y~78)\K/7e얿-S[_[Ǐ p6E�o'{(({@0F +R'gn]K>3`׼5Xa1߷VgE<{{mt륥]?Tiv[~G5uq꩝=Μ8R_GpQB0@�5G^M½$)2RWWTkNmsY0F% O~|>?<&ٿŭr G#\�{YNq"5y( 7h}qd^]/)>C#BIMA?ȴ{0y�Л[ :m]n@ҠRHՎqt7׷96e+WB(/f BtuT{nvW̕DRgӽ<bc^t6 \~sm|c +|=,ߡuPjuЀ3]Wܤ@Czcy3ooci+ȠRW,kxq>y7<ўD+' 2#wO߭.}ؚ3 PZWG_8j:Fs֡;UE?wyCmL/C:U@MRx>[고W<ZL`ʞe&fvt?--I_xUnQǴXaє;KPK +sŌ2 ~\1~<x s%T<yn1le95[+9wkXgK65k A +Ǣm ;Gob4 ~ٱS4з<+c)JXO5p&1ɚD*3&9uY5/q~ԖZ we:Oȁ0Yˎܭu(Gbӌƿy> Aƙuv{Mxi#7CH #(ax:;LzSy7;c)8Nc8y;~aQɔj5ts~(H6x<y")r~<W�&=[PΏ<?-X9pGB_CpiEumW3ZGo(zoJk4O\'rU1XW?^eVM9m{S,0O{H?9ls[PΏ b(J]?<x߆ cQx=񺺺PěA!1s*jNfKV:[Z8yfܢ.yp¢)w,5lvn~[]2s%T<yn1leޓ~f>˘#ݿ!X:qt7|w6x;?0?w?9ge2o| KU ǵܷd4suB_s+t {pyD{cZR58BᄫnΟ+ !])Tf&T+8kn@?{W4`)F/e8-(aR+Gw9}$Q@.K_~(r^~՞jc[[ Ȍ͋D!@Iu1}g:8W565[Wo}W=,<AJ~sC##+)˩*\EICotm舴dCH1ZciIx+,ycNgs2kWT;Ty&Vk&Pu\O,EFcm5txtck34썏s Ց +͵;To9` p7/k=ҟ6Gt6ƦoO{lM5[+í#/)~u6[1FSԽ6 CZ2@!-JCƫg}ݝ{dӷfwm'*VB7]Nut0ƾcֆТqdR =jKk8~p&fմ8?Χʢ}{7<1J_nC9?9╅p[t7Rym.γ@'' +,E`)F PYqH4ϱ{wU|H{-|]hi"X (J:7x"}T}(e`) T M}wn=AFjAim"X,DTJ<+ꯧ>""hѶ.ԟO=$B +*_`}],} =?=D!CHA<ǢJ=˦S|߱|:s_\(F\{"4`)LM]Aq,}=f WseFYu0>u sY?p4kbHӓLSM%? {E)>ýr5 B[GFcY(m/O+cbBg$]p?F'cScNfu1Xeg$~*P%_Fy^( +3l}jߤZCCH/)XXwd;x<ǡTaiIu4HK8˘#|6A˿N|q+^c܃8~S5Ī$4A)Z. y).OaEdwe] "QCdh&"mL_zYﺞ3<9|?S DX[>wGV?:cx߷v+w*cM dbzT^o:Q%SLLςL-c/_"^r߳ȃ}$mmdfz8$W}.,~:6tVMUR}Mh8$װv|}1ecS97}sYjน&^{GYFx*C_C<N\{ws/M̉&ek1cDŽoD:ڤj gdȹPz#y㰯P6{ɧzM ;cr>v/Cgqiz]xm5F,xokI w͸orIWTW21C#CN;]mØ~\1`-Z m̗Ǘm}-0.kłV\5rh4]\#+zlwEEP)g>Ufn):�{_~* JfpE 8r>cAKm\peź‰R` AJÁ+-_Y˘Y_0^d)͵[Hz-T{X`19=3m2x^E7uqjklwl3"y޽^asnX3nޢ2VcoT`?i؉w{(]{OZo%Aw!eeI.wbQf211bZ0@!qeg&^zd}T +-/${{[{)y>'AWOt.آojx>|>|y{/wxy:-%t(؎ Vԗ<5FϼZw}X`cR޵N8+Fd) @lR%8np_zܻv:PM;xJy$vmt[L-czI7X2-덧+h^\#rb!~ZGpשWK4[6qsE>Q/vZwIH}? +Zjoˀ>㸓\1iF,k<) 09>IX@ >q^\SR˶5q4Sw21mq8'%SoYւ*-%tmx$o|m+Օ; +V$ԍqD/}[Q:z&aPo_d { -GEq0 6ΒN߳k4]s% |�!!ݦ +yk8tQRAo,֪4{0'X'^,v}JןBKM>u{PgOJ=Rw%LLϺL-cH\EVܱ1Zw}^VXZZ4=?7ނ>^rfW,nUE 9-{M_$ .CG}<9[L�/!+;q(Z??oC=Z;Gː9;z6Vz5f] b x7N/29(ӳ#/ -dbbRF?X h/Ժt,<mY7ΰU.}l.t@tu+`9S^M̵{\A U1ЄU?h O۱Owqs@[BMQ)S +^qfZW`bb/S Dԫqqѻ:=䳗ߋ_ +g#TasMɌ$#`O0s}բqqd#J1G[?T<^͜hn o8cINF,Fxҵh +bPCeU{U uBPwJ>S_1`-Z ǺꌑӲW?;z**4,& Kpb|E>7ym2mc3H絘1Ϧ]֊ǜKy>+wʶ7૓|S7Ea<!%g^2f4Yj~-+ۡEݽo91+K| +YW~oez:B=P_cKu&&&bZ0@䏰ٜI.-%gw #gojOrx$oU g1{~ZftxmU#*ݦ*\m'{;$s-M_nǙ}tf.4OW{ t V9I"Chq̑E?G?񀱽A^j_T 3e+*]wO;8#ZF_b"3+kbZ0@Hm- DK0OLL_?K +O[ƁVW^%͚&lϬj^=(.1fZﶀJP&ME; ŀx(wbxA +*mqYvFV jj4@'iQ_=/ *=3 p}/KK<iw䄣dV&OTk yV(T: +~*Oܼo-t\i>hNh^hnh~x0"�9%|\bZ{xPkea]WϺqy夃4jU3 !@N8s})패y:, F3\k>n <\|МUaD�r™r';BX1?bZ%hoXn|;D$6\M O2T/mECs eo?g' A0,B@N @(_}VԊ!&Ãe!)W/9U,F}={§+Y{qIT{ްbNi03ԿGuRRg^{ F '? t*2+螿 -V, {/K3qHye.:RG*O{_:>xx%a˅hgkh݋1RE}˪<q{  S&15&Yz2<4ې1B>% +ogBh_?@EHWypA7=ּ?N}~P_?'޳!#NogNrMP'YLBdkȹ폕@r9Km=9VISĢDl@'_ۼŕdUk(_xz5zR]Tg7՝{ #/ ҷ$xsjܵ͝6XThk'T6BhKsؒ{dUg3\!} Juk4bձT%YϹmýB؋y})~+\A?[c1)wܫҨE-WUkdzm}N6:Z-zv\uw}eG/hQ˃W\ND]hIu[c셛J<;~lCnzt̟9w 8+sG^OGt|_jEюs&ý3hh[]g~1S?ՁAuP^T7@3#z򇻫+ J %ϰcfeq:5@y#b.[$ 7:Ihln]{ڀ;9Yi0L,>io?աRB"i O9K?�l?/o50WFcs?G?.WXg7y㊓Y{wwV?7GZ7A}67@c=v?c+t^vM{(cY5X\#xd((MTh[y9dO*JU}ᥥSofL?_tC:i=~h_#U/F}1|}F�ETʞ? rk'wNK}r y3;Pz<:6-ʈqզNT7fITWůR +_ `/˽ܮbt}}}.}>}}}/}?k֠uUwǔϢ>gC{y} [ǎ~[󚿷OkC͂ں=4φj}c +(_ϊۼ�ckN;(wgi,5F>? +vo+yywdЀݮ4kZ:B!n? ,&9}Kg׿+ +Vc4O7 >l B!s?CnzwS[DH0k ������$GE 9DRh+؟2~'gxVk4ܫ,_L~\i������e +-O˛E{qPv%;)qJc���������������������� [),ck«fAW_k4ܫ,.ʘ?s6e~R/rs\󼩼m]PKO*3Tc4^NK}c ]?=}R;7^XZx`2񇯱efwϕ]7|knEErTpzn*hĢ}4f1;)q=c3o/`S1p,&Ae +{fs䨎Y}imy~fz?FxљU ڵiP:Tk.= d +2 읉71Oέϑ2Ez,:""$Ty o;|z,/tK~2xǤ3*Xtr偸QFI<;zAwlfq !}:8 3&O'npTJ%;SvC!<R`/}i&uq|ٯ;!%&bVQC"h & HV6D \*,SG'Iii4t)9+ή_3gs/<LݕmGzEg^WgeK*72Tosqfov8οh-s]lҏ9"çǤ7UZ1wYGuǓ3˷ ""~0~С0<w>N?>bho9 +MCjvߓq]h,P'8pd}Ce/+Chc 3 5 sO}Řd!+d"u٪ߞ!TL/OTSmi*-cvm%1,LV+7K~k}=3YlLIղCfG?&\=vuUF&Ö^L?*)Y{7.xl{h^gj++ 5|rpC$ܷ80Z+9~93DGFjߑq(/( 9Qڽؗ-YOmJMxV~cmUG=%oܢ*)wھtٿIye6Ln,-ME}ػE 1[Ӵky;=lQFēYL~=FƁayB==C/m , <}GƁAz,nM5[wQ/Q㞽XdkqvW%%kڑpLmeE,:j\0vz¡=C٪#־!Ci}/+[ڔ񼹾6gajM=t9)rlՏoO͙( ^2[( Jz۸vwUqE5sO"!ߑq`: g&q�Xd°^TkQrRwHߠDE)SRwz:OP>PmeE ""AxAǷ۟tSeMb;~|wZ +CCS.k^{2<-y5=o[X'k<j8QF"{35u 27Ys']{L"ko{?=oX-WL?gmxr?ZϞIS׽3{G|Z(^uƟ:篸1CH2{M25icd<FG+{n-с=[*k^Z͵59"ç/ݗg%{?yc,ood{L9VV$~%}oJMwixLagC, r/ׂmΒq6ȇ)-}S_{B [fMN\M vU_r&qv;z4N^7;RQt0=b{p_yXڊk~#="<^:17ζ_4U.<oh<yb]yWW$$N#c0uca-󫗺k26,<сI9<JxaUIɊL_:h1r6-_f%)A}Rs6gz%}ӣߘ\R{M;jdx*ģplUw}V[cfrbd �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t��8b* endstream endobj 15 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36186/Name/X/SMask 27 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hoe + �&*dq- +P*amTA[R\D 4BĀg)<9{�����������������������������������������������������������������������������������������������������������������������������������������������������������������[D7.?7{;Isu_��@X=':g7o~U?q_uo��@8F jݥY��e|}l w^��jixwnuctB9_>ش|XII��e5ƚ&}mQSm8쮯[u��@8*dc[7n62#~~˳j ��OZqSyE7Ẅ +Ϗ?x鐁sQ%ܲbRJ)x_6ȋ>珉{~ zţz/*RJ|WA^=_=003gw-eQ<WLYܱr3xOxo(tUo[|w}݂=]_2j3s/akqy=pn王Ùܳ} yw]ߛ׭T,|8 !zgshOoZ^谤ws{>w\sqq?(Vx= ;.9|8+\<Y(8qqpsLپFH3�@y�7!1��f_#$� k<�}g�| �o5Bb�;FH3�@y�7!1��f_#$}<gzY֭��0�k^u/��AH`{끬{�B7q͟9+v��8AH`{롶κ��?I<o^¿ǯ{y-�peW?4Lͺ'��!5k.nzfZ=�g�|i^k_#�@kޱF(�|?�o!?��M $�@D��7$另k\YA[��M $Ic>]Сt�@*q{?[v]t�@,i_yޱ] r[��M $idg]} w�@L $i<P]_`p;� &ә+Kt1vŃ��1<,-*��r|ɨу��<�ۓ;ľF(�|׼c}P��&{<Tsߏ?O^Z= jX=2 Ǖv9ˢ- $UZ/>jD9Ӿ#ppp?=x/lkЩvSqyGPmieR\1#HacUEIRU5*;:*nq}9ҾtΑs8s8s8s$;۽ckSeRᩧ.Lz?>g9NzgG;_?��-!1��f_#$� k<�}/=[RKVdjtmmV ں[ulժhXg-UDT9p9NMfe3Zٲ-oTs~<9$_L>o脿g��^C;~⨳��{ 1cEGϡ�� v ?Vh��kv/>`wg&M��@lc!5;N(*L_���hnp{=~��@lc!Zh{~3k��@lc!ZU-z4p_?���b{ (IKu'?1AEcg]S~?r~.|e{v~ֽ��N?m^zn}_+oZןqb��лNˠ?mF!.COy +.yi1%顟Gȏ��@>ehN]���Ċԩޏ|⇏x��/cF@cUU��2\=N:VL=���xYRN"4{<��=V"ug;L-���N?H8}P;n('�� d|N+?HdK~(ݶ&u��� Ķ>."V]aw]o��Ur4G걂I']置v7��@. ִN˝F@ШJ0T���!:L=T:iESO,���K{LD: Nc��io]BѺtҹ?/t���[Q&wٰM t6Z\f뺠.���+ \k~k:U��`evQnǺ OLP}��%%N?N{ֆņao��oo.܂5n}*ߠ6���+ +=v[2jqz[}U��`Ef;褻eTa>U}��Mnt]|m��X_r=F@G3ïIO>���+)ܼyT5v)註@[ъ-��ʐ;,nS +-uhvԵ��z#λNz]%AӸ>���++Sz5y3$>��f&M Օy誧H޵2o��;NYy+]qRDWWe�� +ꫫ[<7?C>㭆緪o��&{uMF@'GAӸF���++]:?V'K~z3��d+sYo1#wymN���*3s]Cz돸M)"`z?1k婾��@gcz5Uk��YVTW?#]r4>S}'��*o-3T +��Nx^O@w}Ǵ#A���::(KbtWmJgl8Q]V���5w{-F@7}|JOU +��V#[bVПr۾4T +��κ-?`;FϤ$Q}.��Vy&~V5?x-ܜ$��Ķ+rg%e-vMC>- s#[o%~C���1I(䮒0:on=x4֍w 4H���1E!Ur_l=@*qn +q==A���άrG]Bߘ۝R[],ėg }dտ��@LI/Ϧ{="΢?`WŸeR!v!CT���QMv# QrO9r_%l F@746z?}|7qܪ,*���f{ nj{%]q_@4;}(3n|CNJ8xr3P/0���_YqwԕkE[V},7V ,ڼ9u}\Qb*@l5Fմ5 +e2 ϮD,J4DDD*".EPBŀ˂x!4D3ݕ|?3?}f_YCJq{O&9kC3xN\00T5W{y9����=�ooF9ixM/2)U MGh㙛Hdw}77i,Y?Sbޫ{whČը o%���E$ϩUޠd%3Gc?=nt j§̓] ���X Ievj]4 aBBZHnMN/=%Z$bJ#���PB%,c^J#ԙʐPڲf=%Xz1cҼF%<'���@O8~dy&zɫpcG*uvvt#<l.mn 0~_0���"(Ln^EyjC~һ + as/|}`Z?t(ړ~}iӯ U}t́���zWoՉҍdocPvLsJ]Y,2zd*RJMgiƶ!O +rc3j'Olv���z'>o?'<ߑByre֢e(@OԯOeg%Tj\>,g89<W _$WWv2nݾ���+)\!=p(uvg4艤iKyNy/ho;ucK+jYcj2l2ɛF���oFwjI<фmc #sJsS>xK1ƚ3T7q/���(PޡCG(=P~e"krD[ GB#SIgUMڳ8ƪ9e󖕫=>����e՞wtw)7E'M6s+Nɲ4r-Y.ou+f"]_77g���(Ez;BYlcZv/V-p54Y%{pi33V͝'ry���liu|~]9~uj9-:knY{4}Ǔ?*w?\9����t0YC 2ПrҪ?jB�Wb9JyNޕ9����68=c~`W+rR%�QYN~jEƅWOXKBUHg���TYQrre<D,p%4KOz~a$'Fr���enPQ{YMg?ز/Mr暍aA(cu9g:����ݑ3j)Xf ՊKrm?غ2z&1?}i>Zo8����]203ߕNou(5_Q\`&45?}g~mN*)))v���ɟר osM[PAsUB�WbAKWv·U=s��� 9_Xf=vgeB�Wba457 +Bw\̘Vh]���z8JjNLlo(PQiEͶYB�WcAǃ\qKk}y_U_)r ����$7U) +ֺ5YfֆM1{(:S+g&O9[)>f;Zf|€@g���NY1Dw9ws푧?ػSh W+2L.!Lr2����3g=4z;{?�:fAKz~^?e| ����:;}fya 3}mRJ?Ef]'L5?|~����QK]v_RJ4|_;rA8ͪwQ緌W���Юy-7CM{(p%޶\'0ۢKO>���=Y{vNn\*2дՉ)L[B�WAV*I;#?|w{v-'3ל:���� xN}M CZ*9b đ#Fozֿ'xza9Y~����cb| 9jB-7rMpJ7@9x~25Lvtb>}J����eZvo,5C1:vOj?h"s-bw*Ѳna ����^sksK]cg"~Eyq�qȍgM&$v-%J< +j9Eb**("r*.\r,XPSQ Bщ }866*y3oflMYFq;yXULL����Hy1Dyr 1wT(|{~ˍX׽,����=\Rg^B9&BkքG뚝gts2Ϛ}ǵ'ҷ~.���0geD6&{VyTaW3KnB�kã$UHSGt7&~4���0@y=+4% S(Tie?9&͜  }d]%Mߵ؛+iJj3}󘳃���VŅ-\NmP.\+O==勞]?�^ TEҪ4~Zn.͠V)8ylgd`۔x?2���Sߘbdg4{;n ; K'U|3PnB94Skքxʄo8<4TketzԘob��@?V/X(GyrEFv!V[N{z&B%('n3XcT+(n>0{ڷ}$Xa餻Ut´2~���`ؕdg4{n )O\b,_ 4  [F +4czپsꏌH&uӿAuann)���XLrCcx@A=栜By%Ju̟G^B�k»gW|޳\?UzN}c���~TWJ/]Np|AYz"ט=+?hR'k +$M9hJ1v>2Vލ���QAA~J<wZ+R$>++5"y`{v=ތ^:#%x;G ���fB{_q4rݢ)6[P>7�g 9Гt)ޞ^[V_^%3m: ���}=}ڛ$O\)O<$6?hBE Zfsj# O!!Cy?k���0=abCCҾOTYr 哐܄i<sXK7tŭ]1:3hB)zMfj9���K0pi2Gt4- �ӰAؠ(2A] k(:WIs{c��^1 {Qhϛ:;P\X;#5A6t/gWN3BSX[-x?{���x1qa#}^3%3mxg$&?hҊD}qЈ ltf)R]y���xFNNL~dW@ҔZ,ᝍ?XZX}(ϭyBs9h%We"W~ ���+&˄]xF+A}hd<!XK΁L[$?߬KB `VeR^elޯ���bهs^-oE6\'(P.ᝍ?XZ .SkMxߟ/ +zy���)64t(Ncz>PQᝉ?Yb5m QI}}Ј1V>뻖9k��h=GѾ6G.>:rH!D`,V(js4%Z$'oܨѼ_ ��Y47Ճnf; =X+Kwj}\g!*ղK^3f~=���Yezuf]r>|ߍ+e Yfr=*:~#<_|�� {6hܲYkc?"yg /mm١Ɩ)ejœC^3f߱Q|[{yЈ t}ѡx/{{3E��Qس}[:as~.]nF; q%zƄjN)<w,М(j}o3HiSɿm�� fbžͩʚSGp472K 'ShݱK?dgǾ͗߳᛺s߭:73cutމTO0V���D{tOٷyiM|<͝16t>);>_$>NQvvp wזÆYzpd"&]יD{mY[(z^Sm��ƮBWJn 1ݳ<*u eFڦSɟAYz ʉ"ck6g9еtOz��rurbQAAli =5NCB/S7xgOJ$"*3}?4v_AQiՄP/\BA &"45Y[r \=f�@;1AJf~y 5f_]U=/O}|>ʝWkwf*NҪ\&(pYk  f;$Z%_IZi}?ۚ2N<&CG +GI?{Ҫc.[n}|*r {zVL*<lNp*jjLèzA2zpH椖K[N(T|NbUc+ F0G(K=mGv_?AWe؆xib^<|�NԠ<}mĽܝ]zA0k+H-æ;f< ]7)I\ѳg:9wӺ(-8(k[!ߞV"3TIZՋ p3z.)㒬MK{?Aۘ �W[Iv)^[NQp!!L~O`2YwN=k ⤭s=ꫯLm.{?neRr k=ʞ a䚚ѽq$ Gw -6Qo͘sx ?{^ab_8/4dg;fʿrH #"aIǧJV +EՅK=U\pl&ef#~C7" p֧L<;]VGVŋg +AeuAPqҖ!A~ۄϽoc S|6C־:ha;TfwP 43is$׽;ru51?!m݆gQ&U%W2w;kXp,wQUxYV5k1֖VtZ 匴;b`NU+D?<T?sG5{nC7?P37vI2{Z6-Y Baaۣ?\Smć}fv?`XNCG?̄cڸl֝!EYg~ߚAY BIr<݁:#SrG`ih*T0[Io^zb)q1->Q[1A}̝sC}mw7`)Hź 1AU$a7*jbf{+3!ADaif[0g4a`ң k?˼ TA(hfg=C�;:mpMa޿T[l-LX  ~"Bm0W0_0g0oXg^O +J!iUdl`ah [r>j=7$V5 +E5'1f5#DAG@p;̑ +%/ W Xw>JTfU+Ds<Zo s~̡'qi`0A: Azs822[ž}!87uwA;|^{7$3fm-�-C ]}�A$OesNJ LxW}F$s&:%}A7 m$g`޾& Bv +JugԳ6�~UJ.z(~Iڱ>^A&W'<_16}VھPuwA;|c75foQN6p`5{Vxz34d} H %sBIVL<\sb!lb ;ut ; uӡT!r+~ 𥳐N #GAt#MT[cEGK Xw7j}7qS*�W/p+>ߺB*6v A8Þ岜r5u3GפsntdUhD'}eXw-MlkU8UEդlﮒ'EE0 XF ⹸M m*EYgkN>M�y^3FWu6P'iƞ N@$|7`wO0UϔPDM1Q. 05Bt'9-UMi NEt8,u^*Jͺ _Kϛ<^{$̰ 깶%;\t6#>SW70XS @``�.娖N?\˾>6ǫacHb?`Qhį,W)$~}ʞ PG5'un qSL +FE C~2ҷG΢^6Q@5gfc/>[PIGʒ&?1!5.̼�~Cq=lqNnۉD%2*iK.\"Vb:V )cP[}֡ +sJ|?:mk.y?_KxUyIN1+C"pαr.3HLrұ۰s >NrsZ#<~i֗ +I<*]XWagrMP.rX޼EA+hl-$GeIoW.Se@p7 yUsw7ݭ];vdG*|HYHA+X mA˥A4<t8/v>9.&O(;ȴ;ǫ:ڒh$?QTJiR>~r^`Q'&oI!)hKwp]m--OA2LS/ABJ&H.ި/;c^vW-d3w@*[<Uq[wv�>aw6:cE׋Ғ<8uui?wAWHmtX*LM(뮉)2yfuƘK4i"?jb Y'N .Buڽ7ti@\cQ> a4RoHS|\OCTOOtOm*erоE QAt<OS0K;�i =]v,s_t@̏@á= + Of>~~GwYЈɚ%VΟ%eMr1? ҂ӛhg"Ek~2e (紐\dl3rifh jɡY@-d?&I^Is/k7cg*J3_O?1?n]Ӧy��?{W[[J/(-#syFy?v{h%?< +*=.~nNQ83xϸeC OF5|Utv6O7S/�z-4WK_&X=|0> 򖣯 fC`XxMZ_}xT)k�*و>vYdӾ= ȓQAƮ}>s?h議1-m#r0-=60xB[052=NB`TQ.9;%5Ra[O}T\_ɷ�y}>2]fҾ9 QaNK +ٰ7vF/&p=yܑ-5W6:7tG(3$sbM74\c kBÁfcu0f) CP}_/_>!#~6żu66yotԡCL?'їo3-I+Áf ɲDR%/ʑ'mN 紎mL5|8CdX�|ײB%#Wy{J /M\�W+J:ۅo lKh2FSNYEN��|3v|ۼeI$Xxhzth0ayaǀ&K{4Dp/a\+qۤuxϮOdT af;[+ewޭZ93w<Gh B_a~7 ~k`@gC]1(C9D-i6Pz讉ɮ +n"h Α|}-O&M:ATɰ~|3"soyP8îy_Y_8[acܞb��y3' +fz7yvԩL wD9_gڙyy���|3mֹUQ_snrJ&H8*1<lB&w>_bgplڣ aX!O/Z  rAf +3G;WgsZkb4y;ޑ-53m@/[]^AuXɑ4z#D.EN�u�)Sn?<vchUyBiTP?uUS¤䨈)^^:U%s`]I;rhp,m+xY`䗓 Od$2￑3'W*o+âջ,)2b"sUod˥7bYi?Pa˅E^: ى+ +I .魰1wٺ_xCN*2\, *I3Rr㖧~5-: W /5,GE؜ygT0]c v o!\6tt0|<V96hDDENL�"Uk֊{ ZEbW"qmuQ}fpHGZT؎(1=f7# +n;ܙ{~t.><,/98O,i9.Jq/HʶogY֌>\=KD +G]{ؾ{@@w&P*["XHhQվttYE +wg!ѥвnS^#ɉl6F%91=6$"ۤnEwA{ x>lfkÆNkl[Zo:9i-^aBvZsҒ_ô4-}emCsɖ^DnnASO kS3;,njUεE#F4ap?t8\{LcL&J2PٯF2|g ?@iHJ6q5<g~/;vNvٹk`®]FvYWd`8S1Oi9֤4ҊM&;v4{g�wظt'gmCw^nnW=<{z:3B|Gn* Ǐ9&\vj,w,a(7)6?/YpEk*4~g>{tu|Yh,kdSڐZ?PVY)š�I13{4|qM]y�'JZJ(ϝ7Dh̀TfX4Rl _ڏdĺו{8R;|]IoAyl,K\[](NY {NXp8%ZiZtU4Z\PxuB2]/*<7ZqE]3^/a/=N8qcFTnS<Wnzx?�yY0o{?f)?ݣ 䋅c�ꈽlMp ."JȚ)NDDiDүWz| QZuD +9DnATIa#Qf"ſoU)TVlW7ʽn*wg>7`<?/չ֟;MkcȮ5յwQ܋ ^qEZ5+VDq/S):"b"B}4njNJcx~1F}vϳf^K��mg=K ES%HE)[1vS���hۯ SnN#?wtsGv?{M��9'۷l{@@&}K +Iߌ㿮��@>0YB*ۿy? FV���hO铻z~NghzwHlQJuk+���-ƎHwl=; ȇE6#v$^c��IL >0Ы A><HŒb҅$1Wx���XIjluLk3|x?TOzwghu���TFyɉ=+ '*V'I#x���xӼgivoR .|raBfşxOdA@m-��{oe=x ꘴gCۼ.ZӳWNFf{.FG+D҈\���MW! ؗ/;Mgʺţ[h8ڐZ]���MUGK9՛l?)YIªS()MTqIV{��T2B*HE]�XbKĻ67o[w�'5's_��4͝Sݵ>*tO?3@@>xVژoo?ffMbyp 5��@TɃK~{&P]m6i.֦f+NCZ􏦭 ?ݗG;q_��4#]sɚ&guޱ1޽GmФ[6GYIª ] iYSDTu=d��@S\ * .},N?;v1ZmQOѱ}J + +3紖.Dnhyxo<m?=1��@{w_W9{_؜c ;QFB83QXѿg6S?CևnO%Y9d��&70G* @ݰ9 Q$:hNAm>eQF犓]]��h>ž{WG:Fp2s(bWӚ=eF"V[ 6��W~uc䢄aSn8y4cݮ҇ ��\Elyo{WWH{ +GyLѵ;2y���͝,>[[{B}qVPV#tl:eieM;#uRu(^UlEeGkDAO*{'6<9(8uj4fG3zw~J!9>/Sc+t}n?{��]@ώH :;M4>/8.}W� N~U=+At +|OՅCk��aw E9#;>ұ?Na OLE�Nz-_;>ұ?Naܟ7v~\WG>6��Vuew=)3Qsl)>'}w�`UMUQ}zUۭAt +ܱr:O̧K��X'cuO;*D?_71J} 'ΗM� +՛'/9gKt`x0ysV4T.�*=sFx.)gK2ǽ9��N=GJD?[Wgiôw:��՛/mY'V :p +3+.O�T'U_/n+bx8S}u~O�@y"un+bxxUۏzSw��"F@_KwU?Na<3ݔ6Q� j=Y@_JwU?NaփMW{/y��"E}sUz鮶2)7b3z��")ǯIj+cw̢^ʙ=��T^ݛ%V :<W4Kҥ|��n}kEՏmuSSiU��HQ=xtwxݬ)ʔ;gVJ��HѲⷪU/JwD?wi~.]� T\.|Mu :|#`/_o^/��۵LWew.D?Bc#y<T��,P<otAt +#4L5Ώڏ��?>2wND?BVqt��BMzS,(tAt +#tN0<Ζ_N�� ԚkϪ? Gh*NT{;6^��UU*N^?NaV-(9|ǽ��@~;u\[S^zO{u :z/n^�@::F -'ݹbܪm|O��,T,"ݵ:ckbݚ9[+��әsU tAt +#|r*#v|_��ҍ}%cϐXݱ?NaȬF|yMtg��5`UIwD?k#y<T7��xPMYlyyTnSᕸdQu~~,tw��.}v>!sxF)l7=]mC�KoxRSG/`x--3�j)>zl`Ϥ;5Z?NaȘUwlt��[WūU ݥфAt +CF-(9|ǽ}�Q}u븰FtF)9/n^ҝ�׹u*u[OC ܪm|��UTO=XE;kbݚ9[[��*ݧ3窾-FSr*#v|��pt#Vp_3;3Z?Na5h0]n%1��uUOh :o;Ϯ��z}NZz`D鮌fbٰ꾨ؑ~.dTU;ΞHw ��=N~zts]$3?0J?ZAc껸vgC�kICU/*Nh {6^naguْ {у)�^2ފP$ݑюA"9f4T:?6hgtnY8K{��ѫu몏T/Iw#$r3 6֨w;Ve,>?)nk4W!?�Ӱ0^WGǞ!݉A"5V^Wqp>}|fXwbԛ �@ԦJC^x'. G+=tLߟ?kMc{�=eB|ABOXm^TCŵs;?+~UlSU_˦�@oT8kB|ABfƀXcwJs'+Fqc/|K}VeE*o*E\M鿷hln>m6\��6BΌܥ7z?H$e~JjLd Ys~�iߒ{%a^c8RunFkM.DkF-⅙h UqD[ vjQ<XZM/O֨2|4](*=wޟGO^VK��syb,K&;{iLLga83w놨ì]Ylv_]=ov7�uj<~K'w i #3'�y*-_.ŕv$T{&?3-q<[TQ��Tuynꝇc eS{ +�`ڼ_oECĤ?BCVϱ`qᙼ(�>³/3]?Ia)our|�ۇbHNqx01)В3geu;Q��$ֲORs>6<GhyyQUn/ߨJY]�u蒏Oz'GwAL +#,tE�=# 6ih1)<urw�>44Gh9yke#j� t\;9vĤ?BSd +$khO3�@𓾐H/ϖ24GdvjzN�UK7}R&w Gh}՟ZV��뛵m]xtbRc0S$(~� £c}Q;r@�;G&&=s:hw,{]s�! %] &a^ =2իu�b c05[lw��} V^dĤ?>u+(?-`~�lgY=' &akf۞ �XakMxrbRYv_L?�@˓/=ܳev'i?Ia[(k̃�hy2}NB`0ӔOw?tA�@AOdiw.Ba0Sd +C�@{/wsiAv?Iakrzڝ�h~7W &a$c]Twb~/�+ZYriojw:?8O-:/J�MO'}Ac0i;>8e�4[ǽ"w~\kwGxXs:ul~O�ur絻͇AL +#<-vHۣݕ�#w=pZ5h>bRcZ孯v_�ܵ/w>_{jw Gdeo{]>ߛ�'w"pKkw Gxm]*S �x|;^,\v?Iam{˛o�<;>#g;-AL +#l}+tWxI= +�h<D+ۮYBsNA`O}LmWhw)�^+OD.Aa_? o_Wثv�6rg!hYbR}Vh~5^W� XVQ+!hYbRm)~}WKkw+�a׫n{EhwZm8o{/lݯ�{}; C;:Ĥ?!Vϱ8Y�.}9Z3AL +biֱI] �ͪrvW@~xtܷ�`Yg6ʒH{S#AL +?0r:T-߻�=.9}b6~Si �s=&v7@~)Ž9u]9L wfv' 8?Ia5ҲK*.8]Wp"wWR1ڝ &:+o{T͍b�'w&;bRhbg8.} �|Fg ? hy>͚Wy|lI^N?j4 CRǁ'Fdrgjw� k~'"۬seHzք7&'=4v }ymŔ}U �&zdU~<0pwo?c?ڷunS{<LBھwɫ�LȝGpb`L?t߷]~]۶.~QT6]$rWV[훏 7XeCh^.±uTY桼(~GYa7Q(ZrіkXAZl;V @@N9C.$.aа -VQ bo8u0N $n<L }z2N;xRzV\Tm|${c?N}?6i!fcr؟jWj^z޷; ;zly}R`&9rM;Ēpav,jjYb`v3d46CC|;Uʟ{=!?@KU[J?*M~Io85pTzU|ֹ۷ߦ4Ge[eg$'%w8-6(|b;7?78sLu�FjgϒSN՛L4qZ}{>/N?Џc7{k{}^ٵԯ ];AƥYY7 pẅKNJjwe J"={Áӛ q%YWu:TԔ͛Qmίykѣ7!9fuf6L=a?pXY@�npP7dv]ĩx֊y*ٳ9t:RZa/avo\O;W�NʡJ_Nvw}Ĥ?p;R҇XHIA$;�8Qd˒m-Y'p1)ܮ^kxe~MW;�N"((=)}p'1)vwt4o=�8#' &ֲ<b-5֯PÂP펆?Iaܕ1ڰͿoU�"e;; &]vԱb�4Hx8gz7Ĥ?^^5kG2&h��Z]D19hw2 &F(j<W$;��%KZ=Za1)SZѲh,=��A.bAL +m塜N;xHt}]W.�$=wd:0 ҨR}�@[R!}72{ ?Ia|1wh�x\\AL +mԡvu8xj��IzMm}dSvLbRhI*ÁOE6-}Q^� }v8k;s] s?Ia."or]o�h dύo ?Ia=-[|?h �p;>ܿ +?Ia=uJʏl*١st�nL˒[v|bRho}p㚊iw�K}w;AL +oFJ5^<Ч}K�@K|~pQv"q?Ia@Kfq�y{W}O�@s\?qi%;AL +Z:Nl- fP>�b`v"?Ia@SVA,Z7]�|0òAL +f{m?Wѿ3�FKlDzJJ3Ĥ?O-\e[^Yտ7�@H%4|ɤdDbSL\>eNԾ9�@\;WּyvG"?IaI|i1Awk�> R`t2Z8?@�-Jbx^FAL +NsƳV 878m lղ>D@?Ia{s)MӿG�$H_{H Ĥ?T+fv/-X}�H -I.݁Ĥ?dŹ}^90]ly\fZI�AL +Nq`k]0+f z{�f:[#=^%}W?Iae +ep3�f^~)<)bRp^+c_d{OW_g:bRpAoeOl8Inn#5EǥW.8?IaM~1;tTʪb?Nءs+?bRp{ʛxhON\'=2>/v &7(Z_ک־c�˵S=e@s?IarBG۽�p:AU#; h 1)UJk oPh5�3_-9쮌aVX8xğ7�IAz--.Ĥ?v=?cF{3f9�EzA$ nL7kUTv�p_AQ]w(RTLcZuLpL*bb"UB E/tAqJx/,},UPdAbƶF2GWΚu +w39ǽ}O[t7,6S'XU�<+hZUsE}�`1>h1W2Q�<D<ѧl��`a7 ?XULw}}6^ξ� -h@I@dOs}Su-�ZYa}0P @Sr|iIlAwͤjרT1}Jp퇝)XC�=@< u46n5 W g8m!�10ۭ-^DK[YE�Τ.]{w� 䎪Ȓ<e2c檊='C�bj"+XG�H^" )g.n5h/6E ?q : �0+=XAQk ݊,^ƎRE o7nƬm&0EYp.6u�}!{�1ӄq[8]NҚ<M?<.u�x>!?gc=AB>Ç gIcFhQK# +WPx^A�$*Ʈ{ɺ~�<_"?Y-� 6`koP&w&tɐHF}[TY&mk;z xTdR(?5u�ޙɿcd) @?m\ܫ?1{Nt]r/_^Qݬ;XLTYx~`0Hwzd�)ۃT1/ך4n6Ryϵ?ms? =s}/�CH.ǪLMd]W�|J~%"{�O4dרNuXM,m3Wz< VjoNϺ�7Sy�P/ qOiw|cUVP_D2yO kf˺�<o!3�`Z8MTY&=a]:e2lҨ[# k�oqQU xe��ޙɗ6U(d @bP9 ީyCt%1J aC O{IWflh5om7&56"lֵEilPFWlS +\?fmN ֯}='Vn?}lVrqJĻvM^MVs]HwƯ`]wɏKd @bP叭uvow/5#v5 ~n(Rhi,qG١^oh1mo(ɞnֵWEk=%ԵXG{ !Jy$i'd+|.^yp6M[A2R2ڹ͎:0qZ:ͥ +/<֣w?2r[TgX33Xߕ?F$\ty=2u8 �O|ml!mKw�AĤI;F͏96-Z}ƾu(#PVX/`G'HO4k33q/k4&G_<V7(8ec٬BZܟɝfߞa{QLvM^0A>z �OA:+7v_d? 1i(Gpߔ?_"33hM5YSRz.}rruBVob !L!+N ʈzl~TYx_pXkX{5ܹ{WwӟUumzMif7y)Ħtѭd_ vg7j$w��$& Ex@!k.j.<^ʽ}Sy1i>zo8u?MQysqqU'6Wos6+6\SvO( n'Ac-թs4=}gct3eݺ?sl( +uV7ͬMme-,7ɗ=)SfÿҤ;>@7."߱>�$& E Ƀv(}Ase檭MF<^Zf78ڭfu"u\DюQGR,}6UaλΧD϶[[s7 vO^"O yG`/}7wli*4wUoi|GLEƄW a<e>wXX'|>fu�b-_n%<�$&C7jhZ/`G5]hS4E9WH슦ju3ڵ7avwH]IDj-3uT[w\rh?{-O*32kTT/>h5֨1D0*V5DA)rf93p<HH5Zm|%1(-]ijfu$j 7{[sfϝ9cxI!''bpDJ)޲#7Ns$H{#hkAR +o/ߤ'>ke|5nbͷ2!ʂ8* +ݵKzTw]!P/zF4( =^N])5f3\n̝W޷!H_a_洠'AWfmqf`H)޳♌ F~ m_|IafB/~Ȧ+tZ9igUDq?vjMĤnb{nNtrzO?8Y￶룮qPl�ʵjsܠ"wk3X˽{ hoW <9NFo^17蠗~VVƸ)ܻ$VmFu +O=; ??z`E@ϑyVm<\i>/͢Z $,1'YKaлx~WJ70ZNFC:g uM#H_�Md?oq,0{kGb? 3Z8H6\x1_熫j+MwAVMx +_YIIM z~F}yi5qmW'OO B<7.~ݨ ԩs|[U.kp^<)reX"ĦS!{:v@'?\�hkA +?0?z"psyRGݵ85JGzZ>1ݢZ̺QL_c#_'~Sij V9~l>դ UW}:-xs&'bFMVΞ#sC06ElOuvrA<|{A}=S)sȚȕXC=#v+˛{WRWJߨ@&͢Z l-t~OCo0E  臶/CJ[7 pл=aѤZ̚o;ȟ*"4[jM`~yr2<Lwg-o:ĦSB9:~\'X]<H <Gd-+2V +G+~|6먿'NDTfM;}fѺ~ ,Wstq<s<m"H_7H<ـ=͙;!pW3tXtX6VCJA^B-olha-Ś>?φzPFA[җA!@ /w-`Dw粎V{]t�z�]&u`H) elS-^[[4lce1z,mM"@!@ !(&|#_B/DO4k,{5 Rx጑'m- GS|ߴh$sᾟDjRx;9rucفQa+"3ٚX-)3 Ԕ +dDl0Sdu11 ^A^p^y!wښC)CJ# 8H ټgʹ:;@?uF sZXO+f|gui?'0)߁;WKoDL}{b,Y:8*DRx +dx\5}|ߐgզ=g B_=X˽7?"HOGp}{M[["u`H))޿?|e{o`]i{߻˄LMW z6~/ g9p/)9CJ##gkwf|GǛN¸;[]XNp亐{[>W ]#OΕtJxcفQx85Ԏx԰.s.11)ɷW)X-'G UdMۿ~1zŬh]޻X˽[|sPhM5oLZ磊3SRV?V_0d}za6w4? + +Q-O>_^7X>xx8TѾurVXߵw,vi⵾QLhPoQ1̀߄}z wjM;Z:[9m?AE1ӜNMw  +6}>pЧ�F|wZG|`]& BBZ0ĕM#^ 7?ܛFxeAKHu ݢZgդA_~_) C=ٕ1Vaɫj$,ϪMۦO;4j:sJޠ2m +y,Bp7\<(3 Aɪq2Je+*VѸN'QW#.^r( r083==w xk 7 6Uf+ o!m:"ؼo~y/i{"oqM6&ߟ]1{?[,ExC8wb)V WsFr6ق^Xk~ՏCSj< @-B!Iij*Gq|o^z`< ) [Žu ^kC"{%a +'f)?K"[ /Ojχ/nјUҾk9T5ׁ<5$iZu\ջG)u=5ZuL7#kR^{)9=W7)=7W:q]ve^h5V�y$~ Zq\glo+A*%U叡x~xk4Vy28)g_)k߲TuXs;Y*Ml) o)ԼC4? \򇶮<&?vG8࿐< JںɁ^{k}֣yNVzoQۖ<r8Z,g}QW ;|<mkIm=D]BPRRjИUz]9L>'ϥϒ珨/{Qv^tܜ }#sսZŌY{zK7P?nAvp]Gz@p1.ܶ&{+|#Fye(qt{ْu{#\ܫ] \;DI݂3۩OCc?@k||wO9e=(OWuޫf06CJIjwƗ̕'1d sU^/03?1lCIAX^{` w +UN酘m7(_^-<S/ؾ[帉}[!a,x }d +yoYຽlnkTK{"[mA9&؛WUf>Bhon~_?(uޠ;omՎ `*%U{yNV OS,>Q?e ?WFVg`dX~:*Hs {Dp:cY)'qzPs %fVx}<QxدfM }]tġ˙A<*GJ+޵J”$gm|i?R܄F.I6;o:~ǵ!I~;Xx@YDG:"*_2Gg@җqoHr`?. JjCH 5bUڪCCnfi{J( 3 c} BJIcqi@Qۖ)ԼxL7O9X"s\Knj˼&Zݎ '@6`7sU*XgUeffsCb:$_.Z|.ÞWGMK:xN}ZbWWmm{5X+^P:oO-n~a&%T&[=<}ڷ?]A_C53k PRRb裎|ƔpaY J6/HEWd3{gZW>Z$s{'[Te@Pv3j'C_BO{F 9cWWi ow=ޙ'yV5 +ct{ْ1HhgnkykĬv` +T16󲝺TdEֺ{xow\/?샾=,|}6I芵 x8?T?Ƽ'>7,V)SG" 2w%“gqTQ_b>.;c񽉚mdHl}N@?ZA<TJP&s'em;~zSS)ֽ3˽f>GH +~Ϲ / @/ ZA<>?T?:8mm:`;(=ē2pC_ci$-DZ%B?wCuS腵f xr(P)rxs|<CfsT!帉4|L7?4%[Ct}@'JAJIՕA( 9m]/4|^j[ Gb1w\[u1kmAJIE mBFwn_7ۺ7&8ߖ ƹg94k-1PRRQ V2.۩K#-# {esx8W/9ۡKA *%P>2oǷ~h9Leb8W+ATJ*u^7fh\^x|p^ߞZ4V7p8?iJ *%z{Po_7isc{oMωD1w|)s+tpDD@JIE .vuT&6[߁{W;oǘ6q8s +87!sAArjLGb[ްJPutgEdPwRQ`z,rQA܂  6v+jwێYpyơ "9pf|~s.A3V󹁪UTO^qg!53ή-A? +A r~,;ulk]<uES<]~|ހ _!�!AP_;e;􎸡S>|ه16VW/M}}@4tŸQ>,o<M~`EXjkՏ \gK$vA=yl_Vz>k}te~=<uSә^)x'(-lsYYL?Ә1w<e;׋OfdorOTe[]jFv,^{2\w ?n;My k(˷]OuG79I}[?pH(f/K 1 c"CBm^y|� c(rk6:ӿ{c ͟@PO/o8 #xz?�{z*kϤbi* u^Q|kwj[Y~+MULYϻ83͏Iy.R_?> g! ;^gGX=KZnMW]Jly5<vŽltl(mQ^0~#=43Wİ~b M<h>4/<y! ^cm@mhu^gPxelE~k</(WW^u9?fO_X3!1ޢz.znh>4/S;$cҖ:<^`H~/1.mVdy_ӨU3kxVrOW]Uzg&ՓzW 7yŝ][I\w�9i'[y|t^:?]GץSՙ,;.!O<3:Y??x{ü-\hMQTm]c~VnU]lh:k-)/:( gCi.k-ƾ1ms<\]?lj2G/ت+ijw  ߢu�^tscMY~"kӪT?b뼣M$\MAA 1:knQ$);%c ":&ja������ cٱ|,PM_]~זZKqnfM������ FX7,@t5Q+xY e���������������������`!NٮU?P[SwY`K$Dz8uyɶk՟~ߤy56Υ}Mfs)mZ_h_Y^ގ." ffr^W(ߩ+ +ykվxx2sTVw0jcVMݦ"[ Ѵ4zo_+,HV60Ϟ}1p+;ofHX')=`7v=wUЮ,M﷾7i(/fn`DNJHZ(j+D.}0D;]k]LY/::Sux<|E"c(I6EG'vo$imzO‚بC?פrY۵UYÜ?hڦ[<^<{޼<&ٕ˔C Hƌ|L?ʎ +4̲r} 6Y-ߞh⾑.1cѢ8_}A1BQRSQ82P5pNweS=!sX,~8 {,O=\]2240?Zk>. +`J*1£ X8Db=;2731bi* v|Šc\RBi948"( 7M?<FUxqU V~./Fca6bbS&[݌듿  Çe NZnu2G/8TGVus,Ϣox zMEYSLAںDuV0'ZmuLAvdʞbNlu!O֘ E^mX8dn`5Q^ߖ#>2 ZKSv9Z `u cŭuYضͫUx]~ix +WUIO0}lJr.08[s"=}=V'7iU_j*0ǖe㹳ōi<9k/&myie 3g[/}T߉̘?~FYD�^7V\(bD  1$$T* h*@ R*ڲݶrH1*oLj ֶϓLtl9g9;95nZ; sFWGGG|3ڽSVZRw=VW{X}ms}.qP+*g9*VH|hǬ)SCO=5eӏ'__h>ܔ%|cĶ-K>?2v\^tUQѿO~j~—r۾k횇O4֝vQrrsr"jv| <iP:hwJ0[3ts$5]Hힽ9/772aTgO}طsǻwmNC\Ғ{eg1ҥCܛ5[[UT;}WCGGMYG{7nڵ˕ٻsM ǎkyp67bdY;/_d߰99pW[Z2h$yƥ;pbg675 $-{{e&Gw}A:c[u1sLѱ/37zM?oL:7m+?/\G!999\w]dۍñرy˰چ '_ʺ~ѬУL|׷u8WY-srLwRS^6=쁲Ғp_#<O=&ݡqzѢ>6 uHlCFԚ7FN4}.v VEcjvfD-gV,ߴa^3"mG 9BMҸ}k{K#kkCRR|v:9>VzxOuM1${͟C꼧3ϡfMW\ooTs/#3a<:9;LQ8~vWM7>aq6:bcM.`h$y|t8w]39?//s)BmQ~hV;y$mY<ro\!<OpRrTU0jtd_UɻDݷY~WϬ4DYjmr +9IChV���������������������������������������������������������������������������������������������������������������������������`�9 endstream endobj 16 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35762/Name/X/SMask 28 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoCk8&6K⌂K)RnqS׸rsh.Xrq"*COi Mi˖,t4b>ϾJ>!}|~yg2�����������������������������������������������������������������������������������������������������������������������������������������������������������������U={N&w|__?<}of"��p̅~؞g֭lzѲOh{YI��cRee']��]m欁'^sM��j_w,Y9v>\y~Š��xԧQuf??ӹ(o`��8˞gw_[=I��(g|oa߯^? ý7u̺U?]0S={RJ)JYE{ZE{E<Θ93g 䏖Ƶýr+RJtWAZ}eF~./޷f5KGÏj}y=G\^ٞt+ܱ{h_6Hno>?޶ Δ}/h [PGC=rǥ=gio_\͋'n[Pվ=7y.>K{;. !6oz zqmE;t< ;. 9|4*\:|>w\Jy.kjW%_3w\sqi{ �n5Bb�;FH3�@y�H7!1��f_#$� k<�}g�t �n5Bb�;FH3�@<XPt+�� C $mnL��J $|6=t/��|AH95Kn�+dpv'��Cdp47ߔ-7OO%�� +dpW,/w$��_?I<޲eZ; �/-;O �yѝ5B!��AH�t?�n!?��M $�@D��H7wjkh �B?{%��uO?E\[vU�My{H;o8�e!)6ϫw��d4|6=sb_[8�e!<4ӧ}k;� "{uu}8�@F ,o_?e:�AH3�@m]]_n_#�@uN?��M $c;{tnV,}ټÝ⪼,gz>F皚;GWYtWK˜h$u&ftS,v_q9ޏj䓓99#ss7N,t}sDOPGHu_$f)v֟m.6oZݝ/܅M c{Z߫+މ~ +k4cߗ=9ƚW^>D\;M-[;GtΑs ;5=#Fg\Y__1UwV-^j+2a5tlk]^:;*Y*"rQP@Ps?A8.ǩmv]mٟ;ӝʐ۲9JC%9&訾..���{ : ��k g��^N<��6t�� /~[ßM�� 2U4~>?���{ ~e uy��@b!=iܚ"��^C 8Nʯ��^C,N8:i��@|c!V{~;k��@|c!V/y_F���7bQŸKf?<CD3EkCg\S~?aܸ{~/yp齟//��.n2Ě^$;οyT{0lT ��wZX3yxbyڝMs^WhKż9^?>ׅ~4���/ uy&@?Gٸq?��ȝF ^|N hgҸ2��� eC}wl[���஬֍?(/[���([E@'9���sWit폦w]=���K3"N,N0QI���>irtE?r?X>RM���bdžQrr.Q_c\U���!\Uk>itcEN\s^W��� Dx]N?QlԦo��=>m:9GNS}��=&wYF}q4B~U��`e3^O;%GID[&w��XV!wح<+̠u^]���V.4~o5jxo ��ʺMߍm5폍uEP}��%%͘N36D/汪o��=ol'آnǘŢ}⫭ެ6���+ +-=vC2mwz;}wT��`Eڀft_W{L'o��i= {JT}��%wct_<w]}T��`%o91{^t_\,LuζM}���V_Yr%lM?C>p>���+lvw4`od(T/M��X_et5P̐ϛD���Kej +@Z&o��o=M]  [D]樾�� +ks;[<?C>N[7��XA]u&?#SR4n�� +wW@@gڣRL���E7ٚ꼩t6X_/w옡N���*;{]  [D~l6+P}'��mI/:?ST{��@g]Je[=F@'CG!T���:{kGt7Tzdg9O���ZoEثUn"_JT}+��&ɽX{  [DG-'KT +�� δx?oP!.}շ��T+N˿2OU +��κ*_J +*wMIK]\���,^dd"g+Nz%d��褼0rg%,wpC>-ޫ}H��QrO]%U0:nim,=owyew9F|��"S{J*JG칐inZ.ĥB\4}Jsw&�� ޝ3[YB]lV1XQ=^B4.⋎%yT��@\I/ΤM{}"΢?`폤#ǥ  +!nѣU���1Mn#(QrOҪr_%|q F@7z?|7 q\))zB��jƗ;J>|xKá6XyVoA5} Rf%{M<xzjL8/ +vj֮j"uv +VQ\UD) +R+ 9!T-P+յ^Z/lkיY?7Ov 8̼3}~.F=I7���]>3[Lq쨚yW@o|دL;=qC@˞i Z ~Ζ# qieqG )07���3u;7uUD~\~c +sZoFO9 }Ζ')ܝ{i_`ƪtr���E^պKt9>:>�HɼtIzݖctb{Tʹ:w=eZ"g^��� +\mn=ez,zmT 6ejE:#-Du[:IՅq93$aY}XpV8l`g^���ǡ:U|OA~֠Й_?ڼnL= 9!:3sU_&p=���zuzCwmT|qN W=Dz +]W{:zG؉xNӔ,]Kh{!Kw����) Q];n/QGQOmK`ATYXV*<!㏉an+_ hw,kc ���Æ3^R-JWa?swue" c<_GV4I{̈iqA,cjN2���@Q|蟩Aw[˺ɨӰ@OԯOeЪo̜4Sy:k_lSx\QlO\]75���@ϰ-xMꟋw{c]" vӰ@OHK]sۋtep߸ɿVWꔷ˅_9խ c<xk����9Q<9PQ7өn S?7;=lVI8g >BЙg}P#4c +nɧg%d{����NDCCC#Fj˩fe̖=xv\W:N$̠.4gu;iv|͙���Yswj +ꧻS7mKxRҝc@|vPԷ 筥n{|Qa}>}ľ.���]Qߘ:zGJ>a)ogPmoSoa�AgZT+?9wDhΆ2wľ/���=mtΩ~ѹs.Ҕ6tfN#ICDHY\#}���L}jX'@˽=>ˊmW[ H=y,U/O9ͽ3۟ow2| ���`> 3M"1^kT%�?NsJ3j|Ο܇_cb���ٙY7:Ǻ}Y?@JYy4jg5ӭgΏC5Ib_���[fNlɃ4'UA3;ws_Si"a/cH-+HI\"��� 5яƺyj2⋳W?@J_Jt+Y99J���t u uuP 9SQa�h-7[}gpi&G&���:zƺuZQ-IaR^u<i\#*9͗<<ľ>���M_cggoQZ{vG6{1ΠJ5߯lr;)oƅ ����~Aua覅vk* 5?|x~<W~f:wZEk߾b?���Nn~i6 [é{T?@JЉVAfl-c8MSĊU}~����ABBc59;Q%) %?}{6.fY)gQ埖����^zźiK3;=?�:NHvֳZ;p؏���C+-/=Ӱ=>kDGgC7-dڽG-#cT7Ib?���P<nu9;?�^I퀫}k؏���])+Wpm157QtGvgoF/c<W6x}wNZg���;I<_jh 䰆RN^z^zvwq~����6vW,z57G7g#~.f9~],ʘ���sSW,nuOR;sa>STJ3j,ï jn؏���:ź].z5uO?@j =5li= ƪ 9Fg���@">N얺mQτ~Rcf/VΩo=ߝd9t]U:�~gaT*JOkSV-6Ƙ�* +( +J%jp AdU 0 ΰ/Xp�jD闈s}hajB!d<띥NzfG}1g0AH !O𼤒+V?-(UB!mz3%E~/c剫+;A czU> =c=_zIU!YB! SC<RsYOY kPrذ?b 3 of:?Mnz]y !B'_Gg}) y6`n)Ϲ嘄M4cjp9 +{O:I[^mZ8}C!afCn QNb~qfI!a�2ݍ =mJua4*]wEB&ϛ"ٝ5Q2g /ch ?3O}"; .OiǕ�̄B05XYXFXYȷB!d``Q6`+bO671SG ~5x/_\>4sHlysKPzL4cr Y%FƱ$.�Ok>o=G+ yZ/U~P!By38k3-HkO68􇭞^]5R3 c]-B!_k[ Y6l&AUg5}W<D{-}<-͞ך:ג<w7qvV-4XCq+qLORkEtr+Դ!bDffSz2U޷])kQfp6LjN(?i؏;$ϼ;\_syo)"0 +sFWʙ;z#S0S$K4czxg<ce8<</&l^X Ҙc;u<T7eMӪdwظ @BO@�?]5Jy ?? ?tOk{r:N؏%_]%%0o\5sfFxzVVZZQ}iԨsx^3\R|S]q%y4e{K_z^z\ENf3όBO/5RQ6b|PqX,q_b뭩cyi9W0x}سq].a܌+fh d(n;5tH[SyZ='6D xua x@|z+m0 K7K95;w?4 !&vQda?Yw%.lr @. )񶳱}|>dܥT%hϜձ1q?>CL!on( @54_42Ey*ns״yjFԠNo~׳2�jwtU]Ո %q3l^"B~LBsrԤ=* 7=fT_>|+t.4{zs29.TcXFh,I(S̓0I4c3-Ggp_br9Bs(=X$_/Fہt|(^OwͺŊUw{Ú(\V{-~MuN!) !2|2c{TȖ1l7W )Iy*nb^P*Ϲua\dsƑ,sĘ c'EU^]XKvŒҥ6YjU%_=(dV�\ZS5.ćxy Dff_B!`طzz Ob?kPY6$}Yע*Jv3lC٬̪I}؁.`N1THEF%o0|_\9\Url%e%uhCW}hPJށ3_G-\0_B!L +iG- Xq+}_c[_V2.StUzŜp(E 6G0W&H4c2?FZܧeo)a̻#.kKr%@+;[֯!m`Mt%s ڇgź*7fuch d(X jifyAV}j0+HuTwqO_B!È;n/R^tmtS_YYjI:lD16CmmiMc(jٿ5WՁ$ZeΕa<a"WB{{ 3QiC6UbYT[=]֬ "p.߾wú:K&~~Q4%>tP,~m!Kssg`.̸U:,}d]w41`.ah fX[2t"3J +t +jCyEeK>"yPTgo7@FpQG2rD@ QF}İlڦuĀ IԸ(JKPKU?^s5fNighy"X:ֲy߰y C0D?Έ!3W|\ k24x8ZU۶u#F% €}F9c|7J~]9>D?Έ!S/bC4�n5J|4MxP�۾NJ 0�mlaO`e<U{\#X1tÏ{.3Daܝyba;>WCS<^dJw[ Meo}楥DxX[X1 27uKsS؇ZVŠOks,C*ݵ<W9uAtV dݩ2#Hp#Y庀"^Q;ʤK] q# ځnl?_Sqzk uV{n2�tj-}:Q X a +8YFN$z愉zǐ}X{/b7-\>gȢGJ =073en"Y\;=R^~ QON<Ǐ@?5[sB7_@L=w R4̿$`~.j䄵)% ޔ=-aF@q{%{=L,X~]7sB(8tlE3##ϒ{?$lwH?k_,] +pWe:7Xifoc!JAϹG#Яujŝǥ[vFuaS:j%E7<ìYgP \/wXʺ{?VMqťku3J=^bb>&I$5b^% Z1j` +F?F_.州]X6uXǩbF~sC +CAy Y_;OsjT@gl(ޟ:<�c?sji΅,DsV>A]WY[X9/r?7eg;3 V3VCt2910;{ ۺ'n (79ڣs.3CLI 6v) :7?C>[W=չ [ìwAWѽ_3<?!%=)?ܮMsذ״{B-YZNާ{JM~neӮhUkY [edocCN!`uKzDDE?}UWol;YqάBhJӥG  s-/^Օ +PQw=W ?C{ +3{1_,Sߕm0oZ/QS֞Ce BhpI3dϧ;NhӜڼ?eIzQKڲ^~dWtcW%�g%WT333F65hpAtR_Sil*#c̛g~ #3΋:aNA1aZ135ի{ʺ{-+y{?۫b|ƢCY{Rz\O<([+j**lUFc#> 8׬T_UɯQON<}&dɤY0|oN|:JӨH r._&>e?PIlg^_2wK�ϓMgղj9-/}s抆똏 @,A|q]Nd$T\ 9ieHS�c﹤DMuAϢ<w;:l]b{ʘ߾{ƞ!F}fʘp>^4U;m$PaYm:"{em:<hr_G5bMer Hwe賓7S}pc|amBX,mJq#'U=s_#=`*(+)8TڻHoOJO;E +I-DM780o}QAtf;a Ҽ;SC./hwOy,^Iz{dyF^uAt5?PG:3Wlf_SH3x\8_ceH?u^^1ixуDbci <H4rz1INմxI%MA>OL[ JOHj?a~/:P "BAK^K0R)NUk~EyeatP5CIAqD@E,@TQƦТhzpdwF\L2M_(SL*q*5׆V=={_1Sy"ON ~R1IM + 5޽3MuucFDDCG-7wGͮdeDJżovD#Ż%ZQ@4S\#>iH R%i{|g�?#G#n^h1P+?vtAN˖CRԘ N6ڙW9ƛ)$ec~W5NօJ�V;(b2$MWj0 :?F;e@[8 }XԲ*d"U_>xf}?cX.0:GhZNsl]g#]HH¾73H6UnyYic0� +] ?> +ueH R8EeIz{.;t'‹R+hhVnO3MVfeR]EFٹKa53ACM ::`v9 ??=v\%u‘z!!]!# .KO�sĿS b ,Uֱttv>½1" UaExZ%{+ He9b&٥D jCha:3a>WZ?TS]͕ߚ₻h-q+NjlÿSW*v !h:KB)7w^#LmN�Wx7ﺍsF[Zţ|"SRO"ds&{<6L[K + "z'i40�feZwsOd /R1OfAIkI|xUe+g>`@S |>' pۻA4ݥ95X\n#Lo(�H҆Au&c +֨u*9U3ٗI)~OS[a)HKu}r1s\4q ),̟3l,&Lcf'^+0+D;;0@ȁFUXf2i׎(t?3BMt_҂uq{?T=[ 2~ +vF (*=Yg@υYo捶z1DW^Q>O"SfrΥ"V;;.LP=;ƽス}]]ܫt0ŦƕVi-j~s&9gl`UaVL& &59tyK4k/+m Lպ> =�@-\/T(B D]?{bMQ 57P!Vz3}d)*# sn_jQQIT3 +$;?~,6 qc`h13AO[*"є9saRpb#ٹK=>0𫘓K +ιfOsK;> 6PԤWhNEuʡ |_ŀ9NƸA~g!hj=uP^z,K{8@^yƺ�{z0PhU/FE?+Jr(ӟSS UY[#TiĐ?DjuFdV|>VfgB}CC}Dܼz :"H + 5^ǎh`̝}/ +G|7H_Z1pL] Z p=%p+O,+A~g!hjan +~nVbO�?@gc"\]c8"wY422p:2CP{2D,o^)^JIIvȈ@^yh{нvY5Y|3?g.0 @Ofhh� R$tt.t>tNt^tnt~TՅCuzQݨ~'ԯ_e#Ż#c +{'D;Eo<_&r'D 498p{?&4UǬJms|]G LE +]�ʽ:YmfҾ/GΟzَujh8]u +2<% HR#uKżRS*ozA^%5^UaVvUAVoFy=}<܉nw'~_yw87ՋFDUz列6F_d~GE]q\b͵۶[bgMUkWԲ6ATnJ^cf."#RbAmue=1\gsq~<kU"uV?ׇV(wB !?G\v{(?�4<ΘpoY:@cK|.[9g[M_寻7}3v?п`l? ' /}#Kףq7mUFhֻk=|[O9uSG*U`E~\1 +sF qo!Mc_SEvg*^y��@V}嫋wY}H(B.Ǜ$ckˑYs��ȰTjvnɮYҷ qOt<=Uz��3ej4ۄAHx[8^oO?��]2M)}LI473՗M.=�@׺x`}r7 eKjd9��zҷcb�\u{ƄHB��5 +Ɔ?!6_|DRI9i92SKB��5O5g;@|h^O?[M_y��/,C|jゾ7Gd2;G*g"��untCzK BZ7-|[ ��8ץ{&|Aҷ#hh̴z^��SE^}ۃAHE s?cm|��ï(}F%9\9F>u;g$��qpUo!W m)|A~N�Cu7<$}k?i[?<Qmg/T,Z*=+�qrro7Q֠Ҷh>y ��:Gv۶̔1=FwLS.w��s;K_.*~c?i{?U.e��ˑ~v#imA }1Zl~?=Rzv�|fzKB-.+98\��wR>+yMA 1bxx?ŏ!=C�@\,yNZ+}S?i?9)bi��mv\)g;ҷŨcb�Y +��|AzO%t,FTBNa4Y~�}]ܝ;AHc=Ş ��uucC~{HB:#Q*!ל]i\��{ZδLo!6eü :Gz�3~z_OYr/ہAHb1Jpw9ROHV��ДiReY)'{[vҹhSߞG2Bg,��h웬@ƽ[f?FQʔkq2} =c�@c3w~}-}3?| flZ×ֻ,��hno|gҷGa*i-=Jz�z/XJ4θ#+FSeʷl[ƈms˞;o.=o�0^y�AxbM;6毝͑OMz޼2' l#nszF)Z^�*G{74Ą;ɟ=04Twڕ/4?>p�$s>ٺF?O){wYR֯{?ڕm8~Dz�`TG*s=#oO@ ?S.eKC[;·-I` �ќp%oOA ?,Yyp}-GSsF+{J`��*?<#7_mRFS.l֎o?|{9�(>~OKAuvݫm7w2Pe6ϯEh^М*;ZupS,�(l.6{X$rӿwOEOF)ړn.mIΕCH̵俕N= ҿof'~7��xW]I^H|c I_;A<1}{{Rs $izGN9Om,��xjW\3uQ�Fii UYI2|{?Gh];+=D~.�H{J~OD q\n[ƈISԏ=1flO?S>_z6�wۏޕA<1ִ}˚渿VWmZ3Lw �yoҷHmTPěB~cUzkCuSyqVPV#tKl:eie֥:iP<U jGyx |bPp!4iEʻ[ژu;|}��Ԕg?R}+At +olE[𙞞�G[G_=;YGߌ^1˨r!] �.>l;Ut3)쏾[R}uVv�y$dM` :w4<53u6;��;]SlS*At +^꼺J&K��XՕD?g)y �UTUUn)[{xufO�*R=[JwU?Na߈72kOz/Y �`7OV/uit`x0q9GsV;N.�*?savZt[ ǃÎ^GG�`RڲJգ]n%SFq;�`w7_X)V :10ե%q:��J˼")쏁}q"w;��Ʉ)/c{HAt +crw:/��ՏM̕lbYnI%}�ln,zr/;۪D?{LWgy��Es{U&鮶2) LORJ��mU?L +j+c<k{��>T{ ]At +cLY޿J�vͥU?Jwձ?Na +u:I�@+cOf?Na s~q:}�mkPt7At +c'uu'��?Ճo_d]?Na oh4ݗfJw���vuîF9a❬ )쏡֑tw7���Ғn֔̓b?Na UzG��@iԹ])쏡c+2gzz:rNJ��CMzS,+tAt +cD-ixmmg;�ZSxV(IwnD?Vb~F:߫iQҽ��PZ5=J]b^FtAt +chEbZG 4N��lߎ{Ԕըޓ^?Na 緯Pg|d��`jNzwW \]?NaFvU&zI'��,TeWZ?Naƌ̤09. +��KUMtAt +#p*춣5��` }%cOXݱ?NaΤF|53W3��kv5No;)Zyg{�Ւn֔̓P :X1^'dzHw��/gSwk(`<[і>ӑ;V?��/_pҝ*D?/jLSlk-8#!��WkMYc}&ݩAt +CFb~F:iQ=�@_]+1/#ZKC H[QP=ut ��Dqc]JD?<}e:'Hw +��VsT[Ͻbt)YU;LW%^�먞R}]YC;CIamO],-��|ө- ES*춣5~�~Ɇྒ屧Hwfb7)}h:ݒWc��TOP :Vegf ��cz'9K+CX!7o/w&cq+gUՎgm]�=k~zx3]$3?4| +?r^#껸v�kuT/%gHwdc`Oe6mqYvaX^syq,^w��7q[~q媟;2Ա?H0g +G1߅LO�]+^Q}zI FѲ>e(aMYv[�e󺺲<N]ٹnCG~h0]?=-A�i +CI{Aq"Ç {ctwϞߟ?kmƈ� tt'<=+K=)݅ uf= z[מ]K+I3 WU%+Y G��Qq~zH %DyX0>/FFDsϸW➙m<]12\S{{p+{[[(Y=Z}77Ο I��͟zgavZt2MiLYV>~د<4bvUaƴNAun`6Z⒵KU"E,VDZצDDɹHNKC F)qMn㲞vt yf^̜w|?o wGJ/ˮ]]{ �`.OeIz'Kp/;A)ig9`=vzGnZչ}~z.˷ϚM��sݬ=K݇{?HdsnGfz>~)Q f�<-P|[p* ]EG8u-(�y+wn:O=7 ?Iaw7~ӥ͝i�4~_kw &Z>Ǟ}Ņ +�O* OKHhw &:~4=Rfڝ�}^:-R`bR%u[ +w~o�BWIeI缯mx81)QVx*evw�B׵C >><JpbRg#}vT/�@[ NC?Iav |^;jw� ۱v~Ĥ?Bɻ]-A��ڮA?u &"X%*ly{~�FFiF.C?Ia Ym_.\i�wjaZ-ezѰ?Ia[ޯʖ�^_U6HĤ?B[YEIy�>݅G &$7Ř�>yMzOg,<1)3*Y.~>Q��CzA! +AL + /̉vڮTv�G' +AL +SsW"oy)K3�>^߼' &a׭\|ۂ�гeeIvJ?hw Yo{jN}��=w$J Xnsn“c0wre~�Ş; AL +<X۽oNe@�@;Q@Hhw&|v�i+† AL +Lq}¢ +'F�Ou] &a^b#D�@q8yAhXbRfKr|<<E5"�|%>ɑ>L{Ĥ?AyPiWy�hxrn=GkwJF־/kw$�7#^s8Ĥ?mWe{�p};5h<bR9oZeluEN�4~9] &>&m\K�r'sqAbq}̒M~§{�WyFiF &^&vٮs5^�</{.w][Ĥ?O]Ϳֽv�wO7ڝ &~Z6 +^9{~�; +|)\S4Ĥ?Sr}ʁ9] +�+2VKtĤ?{\O�WSR V4-1)+ھvU�@<1UuTowGxdBv_ +�۵ir_]@c-iܺ +�g/\_3AL +OOg{؎3Q= �e>u^kwt?Ia@_:v<2'Ik�?Q57Ys +a]IK}Zo�uj,Ia]bRM�Y<XY\x`~@8;,<(Y#AL ++[mO흣'iw/�1Yq-Ĥ?S)u1~E �HvפFiw~i-ₓa�'rwn-u{ bR"vx.prr�AL +u5fR l'\;ߙ1B\$^-'ٳʷ:Oou.!u~<UXػv2�Lc_@pa`M[oG~5)bO3yZrIiUwxזLm/]9,WdW./{Ga`Lg[άM|I]]~#*yv? SVvӾNIǜNzjٲ^caZ2K7Wx]&4�Dv_;+V#8?H0$/'4?wcVh7Z<<1@}z 8n@(X@hKǎTQEM�9c!Ј)SN +tM!lCx4l@@B *Jz!f6$\͟=Ͱء;]W{ �&>=QYxp:%=p.qbߗwKg1꩟Z_[s^U@sM(%oq?f .׌$:>7; RSjĻl{ajkP&9vmM;Hqn<jj[hv3e46CC{~;U[Bɟ㺿7#<<@Km{w_�7<Ad{vӳ7f4Geeg\w ؗ[;tXQ#P涍_kB<ϼ>c<> �7T>t8_7dr?Rkeu?|~t]׾r7G^]^8�I>??piOdG4.ɹnD-S[jJJ5*l=�7[fI,Pu!]`bmj;|aͫ5ى0cLJ{t$O>Ao:�'zNhw8܅AN:XwwfhYɆxk[qiy?DO:�8+M?IaVe|Ң>w�pi%=^NzS>bRUr.;щW;�N"((=)}p'1)qo!#S3�$_N)(=p/1)o~m�nO7, NhZKֆ=v~>�h>,~hZ Z㕅5~�4HHD0oz7Ĥ?ƾ5+G&j��J]d1wjw2 &r`l]5+E�t;/Gkw1 &p!VQ<w�@{GBg`@[?o:[_�Ж\W';fa@[.dj�Ж.dIߍLv<bRhkyA_zܮh8�(=y;fb@[2c>ٮVMӿ�5IIn\AL +޹Ve$ce#�h gGv$xRzNka.1)9]}^{�ZåvEvlbRhOW?#Oiw�܊O "}67zv|bRhO3 +v|<S~�/۲c6Kiw+ &/k?Vr,C�:woKNEr`gߜxw/i�Z\ %=ݥHbRВ_1P僣h�yDzkf銁 &-?n-pù�hv"?Ia@SaVQ<V ?K�3۲ɇAL +z?l+;g�lvg"9?Ia \6-߿տ7�@H-4lTDbSL^eO־9�@\9kIk^G#Ĥ?$ ]xqcwh�ŝ!}kw# &'<}z_8P�/NDK/iw# &=gV0</<c bYՑDHiw" Ĥ?D2cNŊe#�Mm?=݅UbRpU/ޞx^Z&.^I_Uk?Iaɲ+|p�.ǭ%vќn/ۣ}�0ӹ%n &5*Ǫ#ֿS�EzE89*}y@SĤ?rV,|oTt '+/3]|1)cNCG7<�p7鑚m%'W-8?IaM~ƬNq;|t*W~N{yn1)̈́^<ȧ}�pO-.PKӀ`e, Ҿc�˕ 32Ĥ?VyQv?ܽ �wT~Ƃ[#; h 1)UZ`k /p*i5�Ųyܬ[P`{? ? �g~J7 h)1)]YO[eH�" P Jvg7AL +&eՕF,cM̸ı28j)(FT 4(vY_/iAEǤƙH*Nj51[۾>_կ|}W[_DPn��lgz^˂S!�07PyFq]�EqƜx?= +W%B�b#ufAs˦s��H_~Xֽ W%B�bc1ϧTUa��օt%{�JLHHit:%Y{!�u!ݓKa݋�/?PZMMեfQQ^ehos?XRf-}v~�`]#ݓY �-Asר ipuNYȉ< FCs9+|ty?k_�X~j@z?YNg݃�O?PXIҹgt;rrzj\(.<tZ_i3A\/:?xG�>hUd F?PXi+i4ʋ=C�bH&yI�tMUG�bet.&IN0s="hFl<`'?/�3:NsVn| St>;{7mvmțy7�^GI @d v?P֨Eג S6.WMk= 07N+ m>8�_"=Y�@¿̦Lܟ:sN|X؈&qȐ$Mj幞B�ydxeke��/ƃu3Icd`/ Fz$mAσasg>:r[)9v\{GIdFmYZWd1X 9ԍ;/ypvT~ +�|<sPE:fK�Yz2i([As<1!.?&Nv9ƽZo�X\J<t;ۼbk_�)t i([+V..O*:!�{2HZ\JӋDZW�ÕtZ+O$ݲ�X-5#7ayI +Ňiw\vse-Nf��OC$}fԔ^Y �XZ6=NW$Ҫ.i)|6 m�军<MVmyI [׾o�σu3IA@?Rf-ѯz 7:%Ρn\7ִT[\5 yue ?>pE<D{U~q-:쐠+,5*ͿZyQpeҜ=%L~Q[33UԫZ"2عy|q1yR o־ �{tHz$] {�;%VU:5#Ӛʢ%՜16A+ zyuJ(oFTg&O'~Rߘ\{R,pX[D{|?Qj6bcAQϟ{17}:=PYJS:zU鞤4u|]q +sb5H?Va�7Hw?G'cyI{�A@?vWPVQ2{yYqQF 1(kJAT>%kfAs/NxQ)ߘ&FF\:^+Ý{3rU[}w?BXGVe.=W;+}F(HߝK(>`�k9:ު]+� JLeZL>|15~,274iZ hKj-HlkԷ˛&EyrM9I A;'~q4X39+cz]r%叞x/1B̺Wl/IJM}�btFz#m+Na�%?Pb*kGkJ-;Gȝw~>&܃{#bEڽMiEG9X3:BVmyuAŇ'8<,߾H- n7-)z#כ+)*h~OLXDž˺WMy{F: �Bj-ck`k TĮ9Żz3FE9yޠRxzS$^ϬWl4MTWjyWvpZ<yL/7}>3 噦 f9AeΊAM{\CeQMu ÝN 껟T}}:O@l4pˤ;+Yk�[% )h0y˜LwZ5r3 +Qh~O?A#󷼎~{s*K*㎡;G:o}w}#BFm/IʺO .WUw$�b}wV!}tZ�*(1-WYoϊ52cIPߒ +C-ʎNk^LoqPy~'^{X ޗdž2m�\;}lғIWWe?Pb*[.ފ1OtX;[t{T5 +$4ZMhAш y +}.8T1MM,/=iik\wx9s{3u&ܦۜv8WjӖE*s`9;}w&4k[>͑Y�zurߘ H1za<s1dyg3SSmvP<?t^ u〱2FǏYUy3s} 87k6뺼{};o(TB<?D3(؆>>LF;;8t ȣ 2@&&ثΛ;>ς">;hXCITCr_+_T}VQ-VzA:U8g@pOoZJogO }o2i1XQ9 4NcǸP1q!TM[[tkt@ܿ t.#`Scɑ=C.iKvVgM~"cIs/K ZQRɦf[cQ5lc+uRC}7uNc'ggn{h|F)}䴁?XDzO* 8B?P ԰ m8W`-sMY#x%~YR +)ܛP?!!G%H+Ŏ_L0iVlU4~@CoŴnu@@@aL@yJ�cA| uk4l<53MKI~7.!YjV6t^΋'*@7i}o-vV5vl:4geQp p>W*uB +V\8YG�2FG[ >kOCo⬵:IDm9 hb2O+K %NrtG5t m$ ȏasA+?d?0-%ҰN|ߟnCC*B~Q̠@@gKPGU2ԷrOב@{^V y��yA:7dMLA-#$T\|W.?MDOEQ tsA�41qaӍ.+Bq7v.!I hb2>dS>ɘ|8!BAs~nv6⹇ b[k^uh@RjqЗIQ{kcL7Hi͙ǽi2!}NwjB(UjӖArr~=ZA\@9#?dު?i}q$p@_U`ӗHQ{keLߐQ=1ujgL=DOD߃\\}A~*g qf(_D<D@y X+Ehp^]5 +5 +^G 4qI+}c{[D#<-h_> 35BMLcsEN|W雞_ODts lLΓ`gIR ʛp$<)wY!~!''"S<ML#QJi}g8F礻S5v@?ϫb'558ruGu ,}ܦ۫9@K|lc +~-V>}* ]n$߬ptO1wd}ไ[swX*žkNH +^{]. 㹹beQQ#KX+Q35S0A_.c_PolN_Usxp_L0l( ;>pU&R7ܤcSouYT+d O!n~q/?dި?^4kK;V,s;]Gt尥jG/Wc3P㆕%Dr߀;|cD{Gu~X:v]U*oeVl-lVgA]PeM5_ț5ٰ^utޏ1@$�ul<+ldFdS9-K&:Ӭ$\ |*u¾ +V`ok慽ppEkv}5d +hK͞ {uz' M5-w zf]WKud2' VwtvUgιB:<œ>$Dד1{!ND@yQAW>: PK>^],۵ղƎ +{}-J2i-Z7cBPC]>ޡ.7>pD a5(F; [d+>SiW @@?h oNVxZs/h-Y8=J@߲1I] VW$i;h/GLSgM9{۴C|f]xhb2oW +WU/]Wg[vq:+fu|7&7ӟ[U|_41+Mc_<(3 G<b4usflŊwu%#t1("8r "( #L@15Y"F6Uf7 _h;x-UM|SDl3d.\x@p_GJuQ5&m[qqHRc=e9u+rzѥ\S4ɴRF}v X3+sӷwĿjg.OAte(P5D|WwxȾCdZu[#0o}"GpD05>7nϛzzg뵔1p=g>=!`\4E=4(Ǒiڝ?bg;%\Ty;zy(G08uqdkYrH6ųvʵwDÚ: | [xgEZr,Yx'OdZ=(n϶A_bnDWG0_~7OU=4y+ +"{8r[6$b?6ּˍ}la/=sX0]S?3zZg@dnQǃ}l0k<qd +pa//nziFdC{Nho6ux`U' G<ڏ] V/$ ?Tޖ?�oOgZt)򱡱sZq|eL|$sAP`  \0>\w9:*ʶ4~:v +sT=<âZ{ۛ8*x?ri{SB@_ Mkd w PRSyc*D*%zXE/<<$q{F$q$oJH7!d|k?{\&#ǐEy#'sEL76.y1,'�Ӿq|lp4Дb=o_neI1-V1cU �=AWtAwOD[(P1,6ss=*oOkGo̝~XZ?feF.p +c+r&-2{aOZܣwu2iv,/<tCE"7)σ/tD:*9ֲQ&WGS#%8t.)|;%[^RwJ2 F71B:',,|чo%~# ^\AxG_+ц,_wA6 DFM(fN>/d!$ƺeVz~9ޑw-8(Zo7UYO(q>C"r͟F˶Q -Io3x/fm+prM$)Cd(DZF 9zۚ?dG^*rTRVF0@֕gOo-dEֺ{pGxO?钴ͩe=,|s::28Ϡ+&PRSyc�;s{iG! w%ᐩg?.B1S$Qz~O @?ZA<Tj*o"rv yɞė:y:6^^ww5⍻f9*xy#>˶=c-t)sKx/t@7k PRSyk !ߤTr yϱA<.91{e=4"^M}T kPRSu/7TNcxROᣂK4}}>2:%؁Ct}@'JēAJMՕA A\J>K07Kn9YdZ GB)w\_C)EakmAJME Ǩą68ZzMZή7~?o˹U.V$:`E :Tj*^%/-r`jl92+;~/.jw#cAAɰ]?&7[,d'R?}gRZ#At&t˶fNc`雷GĂq}D?gr(P(Deyx% u5>#q1.Bre#k-9PRSQ ˤm+ő?pJMm}AЧx-Z;At.?T?x9j)K3?#BjV]P@_V`*5 +\LEM #MujۼXw7!j6` *5 <1$veȚ zG+]\ޫ 'syq5@@j q޷'tU1c۝?᭑-N=Zm^c6ߕ={>?x}|1r,Ygsa3qέf!}8߹9^˼Ax?:;٠@\发~IM+^=-*G |=A\Xi[.܄b_HzE?{o\^9Չqn8ݶr-ʺe܃8~H /Q +ZX *°: +8S1 Ze/H@WB4IxAvն;>ZBgg_} b.|?3Isn!�W-1?{jB"*NM}ldIOBt@pDy$H x^Isv1n2<۝RojH~/hysCω=7z~cgHc`ɺ3K%a2V<+eB�cx<WԪg3Om;H|XSoR4>'MҢGυ9e! ^g Cp9OKLr8T[SتVU:/5<i-~#"5.<}zc,|nnAqM@C>CoV=F;C۹8y9M"i{}LOݷ+Q./iU٧_}}J߾qEP]TIRݶ1xh\43{eSrָ<ެ`ȤW` ?vnA"9SsۨYM#gX8(7WՔŔZf.ɝV,UΩ|?>I}1Sd ݏKߡߣߥߧ:f Yu|} +!x g0V-}~+onpC\<ᜦBl=>6\߽|ښB�cg^wQTH >CϴOh�Θ:џޜ*t?T &-1\SmMaZU鬮 :AAE6�\PˋueCK%a2֜:쾓 '`K/  FhF5ڷ*AYi2ً4 I\2������c99{\UYgOc"g&V~,- c%������cP氪Q3kc嬩Ț;s;[&l����������������������-$(pNq˕:EBtea-ӹ =?l߽9ck燄2BV5]*-Y=%$ra:^FFk}gkM"y`kdᬷXmFGF=sm DNN�srTw$',cGќF7G2tE-~Zx My.3!{ӶJo=~J�{LsmNc#A&36\۶}\aVڻ\\x W(lf 9¬-lZhIVx򣸷2Ӻ&2Cn<m cz|<fݓ>nU'N4qO^jǹÇHw1pD^6TnnR60< 2a"}قE友#CZlZ7`KrYUZ5 Myzc\Kv{d/(ZKqyձ-kw,婏KYY>pMcG;:fR>TFVʪJ1< oO~g;!~rFs}5Ν?<T"a&CoQ*y 3x Zn4hk]K^/DY`p?&3?*-Yns]`{;<^Ʊ٬ VsuWcqq踜p9uZbCښV҅Ė?:LIﱩFOk x ܉ c\ gkD,36lr()΍=̔wy8P-#LSH͟!oq/}#5!G8Z, gg7I!~;gvNqcN5gطN׵;2< K$>ss:c~H(0j)cq078UL0?e^3v0>g0Ғw(\0B4Y#21p'7s׵!#akذɡ ?@֏h/ڦk;hĠrcq,.ZvS[*4m?R8yCM"i{\S-I*ά4qO;<wjߍ־}MT4%,0B8ÙQn7J0\|5Zk^pK8ٚ.=ʜX̞1!,oq!S3^Y˕қf:biIh)lU*(|O>xzcVe ENM,Pe`$p?7ꋹ T̵G;Lz <vdx0?cU#i{Awy^^것!K%fzkNj kU�{BW: |^^Oh*$U!ܥ0CVD>XDgt[ww۽ziؿ,6Wc*t|=ss2MzorDp}юd_xWޭ=˖u[(,{\r}cx*/++XKL]8rT29&۴)S +F#sk+W_xq(Ǘs륩ӛ$BES ֖ ]l^c&Ɔ 4;/WK+5RɃBmLS0钒3+?.vg~S=?~j:ۿP<Z95TU1LǯP=Qծ]g|C|X2'O'9zb(5tw{ PkMT=[jnٚh|Q[.3w$NHz˹o~l[Û(xzBr1Gϛk}7=x"X9ֿN={|Úrho{}咥mo+-_ֿRJa<=Sqmu4>mG?sVA���������������������������������������������������������������������������������������������������������������������������<`�w endstream endobj 28 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4263/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HNcGDa'k{έukˋ$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$INhSH4|-> 7tCi@ǐa?e>Da?e>Da?e\,H_rxʾ'G?`9'G|}_7?!ݖʔʔʔʔʔʔʔʔʔʔʔʔZ*S}hĩ I\C$.UYYYYYYYJ>+L|Z%qd2FW]Y7*Ȝ^Q'*̜]Y߇\[K̬L[K̬L[<OxIs?&12%n-12%n-12%n-12%n-12m#jPf}h>^ֆCl5Cl!Bb>Z|Bdlm|J[ ٗAR[}5C%m}VȩEVȩEVȩEVȩEVȩʓʓʓʓʓ[iB[iB[iB[iB[iB6Bs+KRs+KRs+KRs+KRs+KFjp%Ylp%Ylp%Ylp%Ylp%وM+M+M+M+M+ѕ"xdѕ"xdѕ"xdѕ"xd#82$o,92$o,92$o,92$o,92$ol$WEWEW艍#:6~,~^u}@:u} U与IpdnN-C={# +W3tVú;tRٻ}*zWIorN*zVAoq)zUї褒WuyStNѣ:F}J-:M>\;m-y V ԽcoEux{-jkkQw;G9m6#n{v$vs O]$~k"q[ӏ$ʆc$Q6'$Ǝ[&1vҎ7&n;J-Q"l9z{.iϫޞK*,6=Km:Zh׻֮;+0f˻L컢˾?-v)z'Aq}& 趩O(11z?`i?FxwQoL{C^EQ6;#u*{RQ?qF:s מHb)=9o(%~·ԒL'evӅma7ܵĆvKړ~QR`MOajJlj'~YXSeO~!)Yk+~m]o)yLjh-%LxO/+]]ĄlcD.&}B9}L8f?7J&}A+G[^&dWhMv̈́#}bCLxK.l +[X#MKqU–vjG75㐔 -RDUFtg@_K+ =9]͕х]RtFXF(tOF(tetaFhtFYF,tD,tetaG7\@W|teta+]ne)20#YTЅ>C].,E>htaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FVO8&ER7evS2߇�K|7|7|KϤTQj {w]'HԤGpUˠLMj +|9 +8YǘtajcT,N1*Ya taj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FVOLJVOHJVOHJVϺL +^OzM }7}@d][„\Uj\Uj4Ct]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzS.uvsQѶ )ǔtaj[הO*ge?pq4h I9 h]TP)dXVe떷]ԉW 7C^Y6ܼQ;8e>DaGqpOYVER,q ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0USg,i SUɰT)-s],IdXVuS4-AҺ*jgҲv;~{,^ܼCC}W8/uƺ*?gٔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]ueݲ) +anuS,)5.އ&'vO!�w}\yqrj>DnOk?=ècZO%0NygW=_4mwއ$Iҏ!jfΎbmg~;56`cY?Ƶ Oyj'{E ;d088kU2|>بz<u|W?)0xI1}ݹ}~>n ?\l{we|h˅|<>ߙ1>>}:q@̕vyLJn/ ϿyjG! ~|95>~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I#� endstream endobj 27 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4279/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HN+DQ8ئ;*q% +%ͼI$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$逶t +6߇tOC}D6J!]4| %I>Da?d}Nv> p3)>ZC>~~rOy;'>jn~C.qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk[bhEJC$NY@4I|%qi͒ʔʔʔʔʔʔʔ+Mȋ0#}hđ}e0#/$nY791$NY'9/dYYvyroxKs&12%n-12%n-12%n-12%n-12m;jPft9[}hm͖͗5߇![l![}Ot*--hfHMdl!F͖Z"Z"Z"Z"Z"EV̥eV̥eV̥eV̥eV̥m&th&th&th&th&th[hneIYjneIYjneIYjneIYjneIٖ\Ibg\Ibg\Ibg\Ibg\Ibg&Wܕ&Wܕ&Wܕ&Wܕ&Wܕmѕ"xdѕ"xdѕ"xdѕ"xd[pveHXrveHXrveHXrveHXrveHؖ^ '^ '^ 'q}m,~^]_ׯ NQ-0NQEk 7(AQ/ܐp/tZ!}ziz9W踲u}䜡 +Cw訢wu!蠢gu!蘢W}*yUW/I8E=}$ܢ#ޔCҦnܒw`I-u`I:&ZZ׈ֺ֢FusD[lP#b}N=bk=qOA"-7i9uPE⬷.g5w0)oM $ʂcZ$Q'$Ɗ[Z&1VMyG䔖<J%4rTUo%y[sICW坥ҢgiEYm!wZuGw%YiP :믧|azӹȼ+|=sוygٚ 33ͽ]鳚/;Uh4xd96Z=b6\=`;7`=\=8bݯZ8dݫX?9fݧVpsժ빔\w9gݭ;yyLuxk$;=vݡFvQx{*궐KG跏ϔ_Y|Dq!W46^>"Z_.cAŔQ.k=Y# |) #G隷#}q o%~މ:h=pɔV{\6f:qLk&.u lpvY62_7XҚkZ~SS`QkJj~q`Wu󃗰u%6y_.Ag~GwPF]]C]џD]]ƒ菺CQFvc1<GQFv]2y]I]et+ ?et+etaWD?Ut1eta݄?-t7etaC?х +AtEeta@ +0tUetaEt]C"2ХBVFv?9]E7]ž肟.6_6^at/BZFzttW/G\F6) +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=h[]}T,NG!�9߇�mՏ|WTQj {7'<IԤGpYӠLMj +|v9 +8Qtaj}T,N>*Ya0BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+$ S+ꇝ$ S+쇝$ S+G&R/}U% %|:5?gY<gY<a |"]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzCNuvcvQѶ !taj[O,GevCQɲ;kv?S~ezROدÝ yv!L6.2{~�AvQ{6\އ(pywp>Da#8VER6eRA*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tح6lOٯJ:lOn}6އ�dOگJ:lOo6h_/[I3xiI?Wv^\އgp! s+?c*?g)ʠ:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0Uvݦ\T*bIw>.x;_]?-C�}\Ѹ?9nѠ[ZO%0wI?:>!�w߽4qi>$I~ Vk3sv<~oK>ީݏe2>2~ztxmr&s>5uy 䀹]ؼqǢj:?-ױao^_r/}^&ykTS>]RSs8.K}^/ɹ>]Y[7 і 16y}L3; wsc|}t〞+'l~]/ ϿyjG! ~|95>~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I#�f� endstream endobj 26 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 6 0 obj <</Intent 29 0 R/Name(Layer 1)/Type/OCG/Usage 30 0 R>> endobj 29 0 obj [/View/Design] endobj 30 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 13 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 12 0 obj <</LastModified(D:20170110154029Z)/Private 31 0 R>> endobj 31 0 obj <</AIMetaData 32 0 R/AIPDFPrivateData1 33 0 R/AIPDFPrivateData10 34 0 R/AIPDFPrivateData100 35 0 R/AIPDFPrivateData101 36 0 R/AIPDFPrivateData102 37 0 R/AIPDFPrivateData103 38 0 R/AIPDFPrivateData104 39 0 R/AIPDFPrivateData105 40 0 R/AIPDFPrivateData106 41 0 R/AIPDFPrivateData107 42 0 R/AIPDFPrivateData108 43 0 R/AIPDFPrivateData109 44 0 R/AIPDFPrivateData11 45 0 R/AIPDFPrivateData110 46 0 R/AIPDFPrivateData111 47 0 R/AIPDFPrivateData112 48 0 R/AIPDFPrivateData113 49 0 R/AIPDFPrivateData114 50 0 R/AIPDFPrivateData115 51 0 R/AIPDFPrivateData116 52 0 R/AIPDFPrivateData117 53 0 R/AIPDFPrivateData118 54 0 R/AIPDFPrivateData119 55 0 R/AIPDFPrivateData12 56 0 R/AIPDFPrivateData120 57 0 R/AIPDFPrivateData121 58 0 R/AIPDFPrivateData122 59 0 R/AIPDFPrivateData123 60 0 R/AIPDFPrivateData124 61 0 R/AIPDFPrivateData125 62 0 R/AIPDFPrivateData126 63 0 R/AIPDFPrivateData127 64 0 R/AIPDFPrivateData128 65 0 R/AIPDFPrivateData129 66 0 R/AIPDFPrivateData13 67 0 R/AIPDFPrivateData130 68 0 R/AIPDFPrivateData131 69 0 R/AIPDFPrivateData132 70 0 R/AIPDFPrivateData133 71 0 R/AIPDFPrivateData134 72 0 R/AIPDFPrivateData135 73 0 R/AIPDFPrivateData136 74 0 R/AIPDFPrivateData137 75 0 R/AIPDFPrivateData138 76 0 R/AIPDFPrivateData139 77 0 R/AIPDFPrivateData14 78 0 R/AIPDFPrivateData140 79 0 R/AIPDFPrivateData141 80 0 R/AIPDFPrivateData142 81 0 R/AIPDFPrivateData143 82 0 R/AIPDFPrivateData144 83 0 R/AIPDFPrivateData145 84 0 R/AIPDFPrivateData146 85 0 R/AIPDFPrivateData147 86 0 R/AIPDFPrivateData148 87 0 R/AIPDFPrivateData149 88 0 R/AIPDFPrivateData15 89 0 R/AIPDFPrivateData150 90 0 R/AIPDFPrivateData151 91 0 R/AIPDFPrivateData152 92 0 R/AIPDFPrivateData153 93 0 R/AIPDFPrivateData154 94 0 R/AIPDFPrivateData155 95 0 R/AIPDFPrivateData156 96 0 R/AIPDFPrivateData157 97 0 R/AIPDFPrivateData158 98 0 R/AIPDFPrivateData159 99 0 R/AIPDFPrivateData16 100 0 R/AIPDFPrivateData160 101 0 R/AIPDFPrivateData161 102 0 R/AIPDFPrivateData162 103 0 R/AIPDFPrivateData163 104 0 R/AIPDFPrivateData164 105 0 R/AIPDFPrivateData165 106 0 R/AIPDFPrivateData166 107 0 R/AIPDFPrivateData167 108 0 R/AIPDFPrivateData168 109 0 R/AIPDFPrivateData169 110 0 R/AIPDFPrivateData17 111 0 R/AIPDFPrivateData170 112 0 R/AIPDFPrivateData171 113 0 R/AIPDFPrivateData172 114 0 R/AIPDFPrivateData173 115 0 R/AIPDFPrivateData174 116 0 R/AIPDFPrivateData175 117 0 R/AIPDFPrivateData176 118 0 R/AIPDFPrivateData177 119 0 R/AIPDFPrivateData178 120 0 R/AIPDFPrivateData179 121 0 R/AIPDFPrivateData18 122 0 R/AIPDFPrivateData180 123 0 R/AIPDFPrivateData181 124 0 R/AIPDFPrivateData182 125 0 R/AIPDFPrivateData183 126 0 R/AIPDFPrivateData184 127 0 R/AIPDFPrivateData185 128 0 R/AIPDFPrivateData186 129 0 R/AIPDFPrivateData187 130 0 R/AIPDFPrivateData188 131 0 R/AIPDFPrivateData189 132 0 R/AIPDFPrivateData19 133 0 R/AIPDFPrivateData190 134 0 R/AIPDFPrivateData191 135 0 R/AIPDFPrivateData192 136 0 R/AIPDFPrivateData193 137 0 R/AIPDFPrivateData194 138 0 R/AIPDFPrivateData195 139 0 R/AIPDFPrivateData196 140 0 R/AIPDFPrivateData197 141 0 R/AIPDFPrivateData198 142 0 R/AIPDFPrivateData199 143 0 R/AIPDFPrivateData2 144 0 R/AIPDFPrivateData20 145 0 R/AIPDFPrivateData200 146 0 R/AIPDFPrivateData201 147 0 R/AIPDFPrivateData202 148 0 R/AIPDFPrivateData203 149 0 R/AIPDFPrivateData204 150 0 R/AIPDFPrivateData205 151 0 R/AIPDFPrivateData206 152 0 R/AIPDFPrivateData207 153 0 R/AIPDFPrivateData208 154 0 R/AIPDFPrivateData209 155 0 R/AIPDFPrivateData21 156 0 R/AIPDFPrivateData210 157 0 R/AIPDFPrivateData211 158 0 R/AIPDFPrivateData212 159 0 R/AIPDFPrivateData213 160 0 R/AIPDFPrivateData214 161 0 R/AIPDFPrivateData215 162 0 R/AIPDFPrivateData216 163 0 R/AIPDFPrivateData217 164 0 R/AIPDFPrivateData218 165 0 R/AIPDFPrivateData219 166 0 R/AIPDFPrivateData22 167 0 R/AIPDFPrivateData220 168 0 R/AIPDFPrivateData221 169 0 R/AIPDFPrivateData222 170 0 R/AIPDFPrivateData223 171 0 R/AIPDFPrivateData224 172 0 R/AIPDFPrivateData225 173 0 R/AIPDFPrivateData226 174 0 R/AIPDFPrivateData227 175 0 R/AIPDFPrivateData228 176 0 R/AIPDFPrivateData229 177 0 R/AIPDFPrivateData23 178 0 R/AIPDFPrivateData230 179 0 R/AIPDFPrivateData231 180 0 R/AIPDFPrivateData24 181 0 R/AIPDFPrivateData25 182 0 R/AIPDFPrivateData26 183 0 R/AIPDFPrivateData27 184 0 R/AIPDFPrivateData28 185 0 R/AIPDFPrivateData29 186 0 R/AIPDFPrivateData3 187 0 R/AIPDFPrivateData30 188 0 R/AIPDFPrivateData31 189 0 R/AIPDFPrivateData32 190 0 R/AIPDFPrivateData33 191 0 R/AIPDFPrivateData34 192 0 R/AIPDFPrivateData35 193 0 R/AIPDFPrivateData36 194 0 R/AIPDFPrivateData37 195 0 R/AIPDFPrivateData38 196 0 R/AIPDFPrivateData39 197 0 R/AIPDFPrivateData4 198 0 R/AIPDFPrivateData40 199 0 R/AIPDFPrivateData41 200 0 R/AIPDFPrivateData42 201 0 R/AIPDFPrivateData43 202 0 R/AIPDFPrivateData44 203 0 R/AIPDFPrivateData45 204 0 R/AIPDFPrivateData46 205 0 R/AIPDFPrivateData47 206 0 R/AIPDFPrivateData48 207 0 R/AIPDFPrivateData49 208 0 R/AIPDFPrivateData5 209 0 R/AIPDFPrivateData50 210 0 R/AIPDFPrivateData51 211 0 R/AIPDFPrivateData52 212 0 R/AIPDFPrivateData53 213 0 R/AIPDFPrivateData54 214 0 R/AIPDFPrivateData55 215 0 R/AIPDFPrivateData56 216 0 R/AIPDFPrivateData57 217 0 R/AIPDFPrivateData58 218 0 R/AIPDFPrivateData59 219 0 R/AIPDFPrivateData6 220 0 R/AIPDFPrivateData60 221 0 R/AIPDFPrivateData61 222 0 R/AIPDFPrivateData62 223 0 R/AIPDFPrivateData63 224 0 R/AIPDFPrivateData64 225 0 R/AIPDFPrivateData65 226 0 R/AIPDFPrivateData66 227 0 R/AIPDFPrivateData67 228 0 R/AIPDFPrivateData68 229 0 R/AIPDFPrivateData69 230 0 R/AIPDFPrivateData7 231 0 R/AIPDFPrivateData70 232 0 R/AIPDFPrivateData71 233 0 R/AIPDFPrivateData72 234 0 R/AIPDFPrivateData73 235 0 R/AIPDFPrivateData74 236 0 R/AIPDFPrivateData75 237 0 R/AIPDFPrivateData76 238 0 R/AIPDFPrivateData77 239 0 R/AIPDFPrivateData78 240 0 R/AIPDFPrivateData79 241 0 R/AIPDFPrivateData8 242 0 R/AIPDFPrivateData80 243 0 R/AIPDFPrivateData81 244 0 R/AIPDFPrivateData82 245 0 R/AIPDFPrivateData83 246 0 R/AIPDFPrivateData84 247 0 R/AIPDFPrivateData85 248 0 R/AIPDFPrivateData86 249 0 R/AIPDFPrivateData87 250 0 R/AIPDFPrivateData88 251 0 R/AIPDFPrivateData89 252 0 R/AIPDFPrivateData9 253 0 R/AIPDFPrivateData90 254 0 R/AIPDFPrivateData91 255 0 R/AIPDFPrivateData92 256 0 R/AIPDFPrivateData93 257 0 R/AIPDFPrivateData94 258 0 R/AIPDFPrivateData95 259 0 R/AIPDFPrivateData96 260 0 R/AIPDFPrivateData97 261 0 R/AIPDFPrivateData98 262 0 R/AIPDFPrivateData99 263 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 32 0 obj <</Length 1016>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC3.pdf) %%CreationDate: 10/01/2017 15:40 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -770.2788 76.3809 1.68 2452 1484 18 0 0 183 218 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 33 0 obj <</Length 12448>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 12296 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD28FFA8FD %56FF7DFD27FFA8A8FD56FFA8A8FD27FFA8FD56FF7DFD27FFA8A8FD56FF7D %A8FD27FFA8FD56FF7DFD11FFA8FFFFFFA8FD11FF7DA8FD08FFA8FFA87DA8 %FFA8A8AFFD45FFA17DFD0EFFA87E7E5A7F5A7E59A9A8FD0EFFA8A8FF59FD %06A87D7D7D527D5227525252A8FD43FF7D7DAFFD0BFFA87E2F5A5A5A545A %5A5A2F5A7DA8FD0BFFAF77A8FFAFA8FFA8FFA8FFA8A87DA8A8A87DA87DA8 %A8FD43FFA877A8FD0AFF7E5A5A7F5A7E5A7F5A7E5A7F5A5A5AA8FD0AFF7D %A1A8FD56FF7DA17DFD08FFA853FD0F5A547EA8FD07FFA87DA1A8FD56FFA8 %A1A1A8FD06FFA85A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5AA8FD06 %FFA8A1C9A8FD55FFA876A1A17DFD05FF7E2F5A5A5A545A5A5A545A5A5A54 %5A5A5A545A5A5A545A7EFD04FFA852C3A1A8FD56FFA8A1CA7DFD04FF845A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A7EFFFFFF7DA1A1 %A8A8FD56FF7DA1A1A17DFFFFA8FD055A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A5A84FFA87DA1CAA1A8FD0CFFA8FD49FFA8A1CAA17D84AF5A %7E5A7E5A7E5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5AA8A87D %CAA1CAA8FD55FFA87DA1A1C3A1595A5A545A5A5A545A595A545A5A5A545A %5A5A545A5A5A545A5A5A545A5A5A53C3A1A1A1A8FD0CFFA8FD49FFA8A1CA %A1CA7D5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5AA2A1CAA1CAA8FD56FF7DFD04A1C959FD065A7E53FD125A7E5A7DA1 %CAA1A1A1A8FD0CFFA8FD49FFA8A1CAA1CAA1A25A7E5A7E5A7E537D5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5AA1CAA1CAA1A1A8FD54FFA9FF7D %A1A1C9A1A1A17E5A5A545A5A5A535A5A5A545A5A5A545A5A5A545A5A5A54 %5A5A5A53C3A1A1A1C9A1A8FD0CFF7DFD49FFA8A1CAA1CAA1CAA15A5A7F5A %7E5A7D5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E59A8A1CAA1CAA1A7A8 %FD0BFFA8A8FFFFA8FFAFFFA8FFFFA8A8A87D527DA87D7D7DA8A8FD34FF7D %A1A1CAA1A1A1C977FD045A7E767EFD0F5A7E5A7DA1CAA1A1A1CAA1A8FD0B %FF7DA1FFA87D7DA87EA87DA8FD047D527D7D52277D527DFD34FFA8A1CAA1 %CAA1CAA1CA595A5A7E5AA17D7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DA1 %CAA1CAA1CAA1CAA8FD0AFFA877CAFD0CFFA8FD3AFFA87D52FD04A1C9A1A1 %A17D305A545A76A1535A5A5A545A5A5A545A5A5A545A5A59A1C9A1A1A1C9 %A1A1A1A8FD09FF8459A1A1FD49FFA8A1CAA1CAA1CAA1CAA17D5A7F59A1A1 %7E5A7E5A7E5A7E5A7F5A7E5A7F5A5A7DCAA1CAA1CAA1CAA1CAA8FD07FFA8 %8430A2A1CAFD49FF7DFD04A1CAA1A1A1CAA17D5A7E76C97D5A5A5A597EFD %085A77C3A1CAA1A1A1CAA1A1A1A8FD05FFA85A5A5A59A1C9A1FD49FFA8A1 %CAA1CAA1CAA1CAA1CAA17E5AA1A1C9535A5A7E5A7E5A7E5A7E5A5A53C9A1 %CAA1CAA1CAA1CAA1C9A8FFFFFF84A9FD045A7DCAA1CAFD47FFA8A87DA17D %A17DA176FD04A1C9A17D76CAA1A12F5A5A5A545A535A5A5A53A1A1A8A1A8 %A1A8FD04A1777D7E7E535A2F5A5A5A53C3A1A1A1FD49FFA8FD06A17DA1A1 %CAA1CAA1A1A1CAA17E5A7E5A7F5A7E5A7F5A7E5A857E855A857E855A855A %7E5A7F5A7E5A855A7F5AA2A1CAA1CAFD49FF7DA1A17D76A17CA17DA176A1 %A1A176CAA1C3A1FD0A5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A %7EA1CAA1A1A1FD0FFFA8FD39FFFD0CA1C3A1A1A1CAA1CA7D5A5A7E5A7E5A %7E5A7E597E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAFD %47FFA8A87DA8A1A8A1A8A1A87DA8A1A8A1A876C3A1C9A1A1535A5A5A545A %5A5A547E5A5A545A5A5A545A5A5A545A5A5A545A5A5A53FD04A1C3A1FD0F %FFA8FD47FFA1A1CAA1CAA17E5A7E5A7F5A7E5A7F7E7E5A7F5A7E5A7F5A7E %5A7F5A7E5A7F5A7E5AA2A1CAA1CAA1CAFD56FFA876C3A1CAA1C3A1FD085A %5953FD0E5A7E5A7DA1CAA1A1A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CAA1CA %7D5A5A7E5A7E5A5A537E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CA %A1CAA1CAFD0EFFA8FD48FF76C9A1A1A1C9A1A1535A5A5A545A5A7D535A5A %5A545A5A5A545A5A5A545A5A5A53C9A1A1A1C9A1A1A1FD0EFFA7A8FD46FF %A1A1A1CAA1CAA1CAA1A15A7E5A7F5A7E777D5A7E5A7F5A7E5A7F5A7E5A7F %5A5A53CAA1CAA1CAA1CAA1CAFD0EFF7DFD46FFA8A876CAA1A1A1CAA1A1A1 %7DFD055A7D76FD0D5A53A1A1CAA1A1A1CAA1A1A1FD0DFF7D7DA8FFFFFFA8 %FFFFFFA8FFA8A8A8FF7D7EA8FFFFA8A8FD33FFA1A1CAA1CAA1CAA1CAA17D %5A7E5A5A7DC3775A5A7E5A7E5A7E5A7E5A7E5AA2A1CAA1CAA1CAA1CAA1CA %FD0CFFA97DA1FFFFFFA87D7DA8A8A87EA852FD047DA8FD045228A8FD31FF %76C3A1C9A1A1A1C9A1C3A17E5A5A5A7DA1A12F5A535A535A5A5A545A5A77 %A1C9A1A1A1C9A1A1A1C3A1FD07FFA8A8595A7E7E7DC9A8FFFFFFA8FD05FF %A8A87DFD05A87DA87D7DA8FD30FFA8A1A1CAA1CAA1CAA1CAA1CAA17E5A84 %7DC3A17E5A7E5A7E5A7E537E5A7DA1CAA1CAA1CAA1CAA1CAA1CAFD04FFA8 %A9847E5A7E5A5A7DCAA1FD48FF7DA176A1A17D7D7DA1C3A1CAA17E367DA1 %C377FD095A537E77FD04A1CAA1A1A1A27D7E7E7E5A5A53FD055A53A1A1A7 %A8FD46FFA8A1A1A176A7A1A7FD05A1CAA17E53C9A1A1597E5A7E5A7E5A7E %5A7E5A5A5A7E5A7E5A7E5A7E5A7E5A5A5A7E5A7E5A7E5A7E5A7EA1CAA1FD %48FF76CAA17676A1A1A176A176A1A1C9A17DA1C9A17D305A5A5A545A5A5A %545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A7DC9A1A1A8FD %46FFA8FD04A1A8A1A1A1A8A1A7A1A1A1A876CAA1CAA17E5A7E5A7F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A7DCAA1CAA1FD48 %FFA8FFA8FFA8FFFFA8A8FFA8FFA8FFFFA1A1CAA1C37DFD0A5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1A7A8FD0FFFA8FD46FFA1A1 %A1CAA1C9595A5A7E5A7E5A7E5A7E5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E %5A7E5A7EA1CAA1CAA1FD57FFA8A1A1A1C9A17D2F5A5A5A545A5A5A545A59 %5A545A5A5A545A5A5A545A5A5A545A5A5A77C9FD04A1A8FD0FFFA8FD46FF %7DA1A1CAA1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7F5A5A7DCAA1CAA1CAA1FD57FFA7A1C3A1CAA1C37DFD085A7E53FD0F5A %53A1A1CAA1A1A1A7A8FD0FFFA8FD46FF7DA1A1CAA1CAA1C9775A5A7E5A7E %5A7E537D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA1CAA1FD57FF %A1A1C9A1A1A1C9A1A1535A5A5A545A5A5A535A5A5A545A5A5A545A5A5A54 %5A5A7DA1C9A1A1A1C9A1A1A8FD0FFF7DFD45FFA87DC9A1CAA1CAA1CAA17D %5A7E5A7F5A7E5A7D5A7E5A7F5A7E5A7F5A7E5A7F5A5AA1CAA1CAA1CAA1CA %A1FD0FFFA8A8FD46FFA1A1CAA1A1A1CAA1C3A17DFD055A7E767EFD0C5A7D %C3A1CAA1A1A1CAA1A1A8FD0EFF7DA1FD46FFA1A1A1CAA1CAA1CAA1CAA17E %5A7E5A7E5AA17D7E5A7E5A7E5A7E5A7E5A5A77CAA1CAA1CAA1CAA1CAA1FD %0EFFA977CAFD46FFA1A1C3A1CAA1C3A1C9A1C3A17E5A5A545A76A1535A5A %5A545A5A5A545A53A1A1A2A1A17DA17D7D7DA1A8FFA8FD0BFF77A1A1FD46 %FFFD06A176A1A1CAA1CAA17E5A7F59A1A17D5A7E5A7F5A7E5A7E597E597F %5A7E5A7E5A5A5A7E5A7E5A7F598484FD07FFA8A1A1CAFD46FFA8A1A17CA1 %A17D7DCAA1C3A1CAA17E547E76C97DFD075A53FD135A53A8FD05FF7DA1C9 %A1FD46FF7DC3A17D76A1A1A17DA17DA1A1CAA17E53A1A1CA537E5A5A5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A547EFFFFFFA977CA %A1CAFD43FFA8FFFFA176A1A17D76A1A1A176FD06A17D76CAA17D2F5A595A %545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A2F7EFFFF53FD %04A1FD46FFA1A8A8CAA8CAA8A8A1CAA8A8A1CAA8A87DA1A1CAA17D527E5A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A847EA1A1 %CAA1CAFD56FFA876CAA1C3A1FD0C5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A5AA1CAA1A1A1FD57FFA1A1CAA1CA7D5A5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E7DCAA1CAA1CAFD10FFA8FD46FF %76C3A1C9A1A1535A5A5A545A5A5A545A535A545A5A5A545A5A5A545A5A5A %545A5A5A53FD04A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CAA17E5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5AA2A1CAA1CAA1CAFD %10FFA8FD45FFA876C3A1CAA1C3A1FD085A7EFD0F5A7E5A7DA1CAA1A1A1C3 %A1FD3DFFA9A8FFA8A87DA8FFFFA8FD0FFFA8A1A1CAA1CAA1CA7D5A5A7E5A %7E5A7E5A7D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DCAA1CAA1CAA1CAFD %10FFA8FD2CFF5252A87D5227527E2753275952A87DA87DA87D7D7DFD05FF %76C9A1A1A1C9A1A1535A5A5A545A5A5A537E5A5A545A5A5A545A5A5A545A %5A5A53C9A1A1A1C9A1A1A1FD0FFFA8A8FD2CFFA87DFFA8A87DFD07A8FD0C %FFA1A1A1CAA1CAA1CAA1A15A7E5A7F5A7E5A7D597E5A7F5A7E5A7F5A7E5A %7F5A5A53CAA1CAA1CAA1CAA1CAFD0FFFA8A8FD44FFA8A876CAA1A1A1CAA1 %A1A17DFD065A527DFD0C5A53A1A1CAA1A1A1CAA1A1A1FD0FFF7DFD47FFA1 %A1CAA1CAA1CAA1CAA17D5A7E5A7E5A7D7D5A5A7E5A7E5A7E5A7E5A7E5AA2 %A1CAA1CAA1CAA1CAA1CAFD0EFF7DA1A8FD46FF76C3A1C9A1A1A1C9A1C3A1 %7E5A5A545A53A1535A5A5A545A5A5A545A5477A1C9A1A1A1C9A1A1A1C3A1 %FD0BFFCFA95A7DA1CAFD45FFA8A1A1CAA1CAA1CAA1CAA1CAA17E5A7F5A7D %A1A25A7E597E5A7E5A7F5A7DA1CAA1CAA1CAA1CAA1CAA1CAFD0AFFA87E5A %5AA1CAA8FD46FF7DA176A1A176767DA1C3A1CAA17E5A7E53A1A17EFD065A %537DA1C3A1CAA1A1A1CAA1A1A1C3A1FD08FFA8595A5A5A53C9A1CAFD45FF %A8A1A1A176A7FD07A1CAA17E5A7DA1CA7D5A5A7E5A7E5A59A1CAA1A1A1CA %A1CAA1CAA1C9A1CAFFFFA8FFFFAF597E5A5A5A7E59A1A1CAA8FD46FF76CA %A17676A1A1A176A176A1A1C9A17D52A1A1A1535A5A5A545A5A5A5359597E %7DA87DA27DA27DA27EA97E7E537E5A5A5A7E5A7E5A7DA1A7A1FD46FFA8FD %04A1A8A1A1A1A8A1A7A1A7FD05A1CAA17E5A7E5A7F5A7E5A7F5A7E5A7F5A %5A5A7F5A5A5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA8FD46FFA8FFA8 %FFA8FFFFA8A8FFA8FFA8FFFFA876A1A1C3A17EFD075A7E53FD155A53C9A1 %A1A1FD0DFFA8FD49FFA8A1CAA1CA7D5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA8FD56FF7DA1A1C9A1A1 %535A5A5A545A5A7E595A5A5A545A5A5A545A5A5A545A5A5A545A5A5A547D %A1A1A1C9A1CAFD0CFFA8FD49FFA8A1CAA1CAA1A25A7E5A7F5A7E597D5A7E %5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CAA8FD56FF7DA1 %A1CAA1C3A17EFD065A53FD135A53C9A1A1A1CAA1CAFD0CFF7DFD49FFA8A1 %CAA1CAA1CA7D5A5A7E5A7E5A7D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5AA1A1CAA1CAA1CAA8FD0BFFCAA8FD2FFFA87D7DA87D7D277DA87D527D %7DA8FFFFA8FFA8FFA8FD05FF7DFD04A1C9A1A1535A5A5A547E52FD055A54 %5A5A5A545A5A5A545A5A5A307DA1A1A1C9A1A1A1FD0CFFA8A1FD30FF527D %7DA853527D7DFD04527DFFFD05A87E7DFD04FFA8A1CAA1CAA1CAA1CA597E %5A7F5AA17D7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CAA1CA %A8FD0BFF7DCAFD31FFA8FD07FFA8FD0EFFA876FD04A1CAA1A1A17D545A5A %5A7DA153FD0C5A7E5A59A1CAA1A1A1CAA1A1A1FD0BFF7DA1A7FD49FFA8A1 %CAA1CAA1CAA1CAA17D5A7E5AA1A17D5A7E5A7E5A7E5A7E5A7E5A7E5A7EA1 %CAA1CAA1CAA1CAA1C9A8FD0AFF7DA1CAFD49FF7DA1A1C9A1A1A1C9A1C3A1 %7D5A7D76CA775A545A5A7E535A5A5A545A5A5A537D777D777D777D777E7D %847EA97E7E7DFFFFFFA87E7DA1A1FD49FFA8A1CAA1CAA1CAA1CAA1CAA17E %5AA1A1C9535A5A7E5A7E5A7E5A7F5A7E5A7E5A5A5A7EFD0D5A7E5A5A53CA %A1CAFD47FFA8FF7DFD05A176A1A1C3A1CAA17D76CAA17DFD055A7EFD1A5A %53FD04A1FD49FFA8A1A17DA8A1A176CAA1CAA1CAA1A1A1CAA15A5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DA1CA %A1CAFD49FF7DA1A17652A17DA176A176A1A1A176C3A1C977FD055A545A5A %5A545A5A5A545A5A5A545A5A5A545A5A5A54FD055A7DC3A1C3A1FD49FFA8 %A1C3FD09A1CAA1A1A1CAA1CA597F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5A7F5A7E5A7F5A7E5A7F7DCAA1CAA1CAFD49FF7DA8A1A8A1A8A1A87D %A8A1A8A1A87CC3A1CAA1A154FD1B5A53FD04A1C3A1FD57FFA1A1CAA1CAA1 %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DA1 %CAA1CAA1CAFD56FFA876CAA1A1A1C97DFD055A545A5A5A545A5A5A545A5A %5A545A5A5A54FD055A7DC3A1C9A1A1A1FD56FFA8A1A1CAA1CAA1CA597F5A %7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A5B7DCAA1CAA1CAA1 %CAFD57FF76CAA1A1A1CAA1A153FD175A53FD04A1CAA1A1A1FD40FFA8FFA8 %A87DA8A8FFA8FD0DFFA8A1A1CAA1CAA1CAA17D5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5AA1A1CAA1CAA1CAA1CAFD3FFFFD047D5227FD %0452277D52FFA8A87DA87DA852A8A8A176C3A1C9A1A1A1C9A159FD045A54 %5A5A5A545A5A5A545A5A5A545A5A5A2F7DA1A1A1C9A1A1A1C3A1FD40FFFD %04A87DA87DFF7DA8A8A8FD0AFFA8A1A1CAA1CAA1CAA1CA7D7E5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA1CAA1CAA1CAA1CAA1CAFD57FF7DC3 %A1CAA1A1A1CAA1C377FD105A7E5A59A1CAA1A1A1CAA1A1A1C3A1FD56FFA8 %A1A1CAA1CAA1CAA1CAA1CA7D5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7D %CAA1CAA1CAA1CAA1CAA1CAFD55FFA8A876A1A17DA1A17DA1A1C9A1A17D5A %5A5A545A5A5A545A5A5A545A5A5A77C9A1A1A1C9A1A1A1C9A1A1A1FD57FF %FD04A1CAA1A176CAA1CAA1CAA15A5A7F5A7E5A7F5A7E5A7F5A5A7DCAA1CA %A1CAA1CAA1CAA1CAA1CAFD57FF76CAA17676A1A1A176A176A1A1C97DFD06 %5A7E5A5A547EA1C3A1CAA1A1A1CAA1A1A1CAA1A1A1FD56FFA8FD0EA1C9A1 %7D535A5A5A535A537DA1CAA1A1A1C3A1A1A1C3A1A1A1C3A1A8FD55FFA8A8 %7DA8A1A8A1A8A1A8A1A8A1A8A1A8A1A8A1A87D7E7E7D7DA7A1A8A1A8A1A8 %A1A1A1A8A1A8A1A8A1A7A8FDFCFFFDFCFFFD0CFFFF %%EndData endstream endobj 34 0 obj <</Filter[/FlateDecode]/Length 14260>>stream +HWmoHG5^UM HsVт76I?~gok0 9& +س<;4dy�_4ڇF |z0h hFCw 0f%; 1 ѫFQA|2J-SȋF37rG�L$EPc8pLY\z &a}@_IS죘v#xl|n}7~raԴq ,$3nw̾ f`;#zS[8bU0&-4,0+|x'a:ùs YdB%eIQ4;k8a`urxq2Am:=g$t l9=#ނ�{ q;9aO)pQsԥr%*"(2cX ]8bI݄Xʡ3SP&à7;QVìnx)o8_9l5umF]JM]S `|檚UjUsb᪺ +H n/EWE]U1Ihk\`5ִֶ5kF5X^MCNlX)φװdk׼VڞxMym[^Ʋ=XQD^3TuZ3Zh1Q3*5!uVi5=5T*jJMk5մvy듘sy ;Y#zIHSw"S?5$f`s8>La4WԍD#ɚ`$ۺ,`ɖL"+*KvԔQws§Qi9N鵩y,a|w809t j#+C۹?YILz[)s(r>!nE�v + ɔe%kr^Kk (h ; ġ̴%%oeSV勖&npA4|kz2tH60{0l*S3ݦUՁN./#>w3\g7M$B̫92';}*?C*fpZ&yL׾|[AɃ++5<΂M;'Go_N,#'߇@qRHL}i3\2N`rEQbA ier+*>^ Z83Ɖ{p YGli,, [ΫUy}D{o:^0�hhA}23=iY]v1_=8ږv |gƛlgއ:r2OCGA8Uo*(ܬ3g3%Fc.~\?/q `~ni/f`V(8$0IL/pU qCxKItRdPBL]~̵> Ǵz4Ucc:yB!OÈ7ؕVaWtEB/uQ_<ųYpJ.\9?E:y^vs]w&8՗ZIfWh4䅑,z& d\* [i~g=^1 F"ɑu {Q8ji{Fт>[srd#YRcpq^.N/~}*~$mJ t#K?A7n=s&{}c]ŇɻߥvDFʅL0SPSi?ׇ!J<? 5!=3kȥ3ȚΚfD鎠h )_sy tB[(+[q|w'0g昶{v$Oԑ|)YxW#E\u_<<qzb?:G1_/bI.>~?dO^L] +'cʭ菸f2Q~t>Gei?6kTb&z*Bއc4N 3!4Ĺ+-pi-h8L$̫^s{ p!lcf-GYz�!@t|P(PWVF9DgQAT^Py33?7>)C9֓tWc+AbGS+i|:]N˛?,,p\luMylŷO@lr&]1'_. 7!.+|fF+1j^ZhSu< ]8|J)^Rn< +Cj"RKKJȱӪz)dȢ h$V$`flZ\- j94hj)47,yTL{doz =KiUy@2]l-<f 4�%~ONdCws܇eЙ;s3 sTخUi~Mqw2)l'OZyAW4ϡ [6bEs"ޭIey-ȒeG[e (ZYe0 8c uZ^-2L^c=^iՋyuCw2+ +Ioys0 +Pvňʖ +ޭu˪4ҋj0R1*yљՖE)`#YKԟA> # }^CKBoA4O(ZP'@#:/zo\a<lxLͿ/;co tYWBEw]ۚWko8 fŒONҴN3 L%67(丹W'LgptH:^IŃD`\3O^�-z7ao?>~.@܁jIxJGG?41aJ[}m5QQ� (R/�s #!$VOү)n?{0R-,g=p8< +mЀXx4\sQ~uBz`>b VE~dCN( J]0<b/=ɿ2LJZCZwĔ=< V(;qTyTOv))A@v%Xss2o{iy5[#{0Ag#F~%YvW 4�$tx.~"j'燳53t68  ]opr$ZW%G-dfDx,RWT ?imH gIsbSb1"VY== g�̞՟ek%}..98|�Vf0\g|>YԍIkSR,$X r;pCY=G>s'\!l@~>`!_@ e>4\SZha(݈= z3cP2J*l'6\~!Ljߐk?Juu z "OаhMl~x27t|?=֍_A%,~ڵ9tMپ=(e,=ݵ]dfe&e; XLcZ9ߟ^œgrS ٨[A4hl)VyֺϽhO@GЙB yq涍Gj C,/!}7Eb"LlmY +vxhKNؒ]!Ct o?1+-.f+FLB"VhL @KE:p9<#h@"Tv5HȪahx:DgUOKZ}o|q1vf!8\Ï-I8eϾ~; +"8D@Uۣ/ c*w<4BS&:WY 0G"&VaF߫#£D,LN*#.b4q: \AmPks&I͍׌s:)Jf#Ij3va˷NBABwdZ?M'ub`ZK!7z{mqiYǀf~u zC.տVͧblԘCNzr?&S{z&i,;Сr1"` +GA1p؉g윤 )̾u0d6y]fBkuT,[P{ξow=PsW/xX_|Tfs?q#.ofe L|H`A),O#K4t 5ל*yyy{\?mWGͩAMb*okV`1>zO '@hlgx֯z'>6u>!-Ї|1U<'9u.9"n.-b[.TxN+s*4%4;F|s` yBtm-ya0ȿ ɆA΍\$ttOdb=wh +[J0@C|p\e_HN'Llu80c,`3c<|U̧8KE[]ch�<=:@-�?jȆ' D!zjH"/xR +)\ J@PIə)ff#W,pHhE:B(v$I"*z +$2toQѧW47 ,{pA[H3{fknX5\8}ʒ[ b6V+ʥ?7x&{sM9fyRw }$.  ʟ|"I]E\N bk:`vY !ʲTwT: x6@+Zfrդ4, uI=;@J(L@H <REv] m/`;˨] L^>rЕ@4G/3W7�=L]oiO&`QpPn@F6*[ќ:lT3V)�GIdN- Ka0hXtp3`ua"]B!YMB >-R[66V=RnFu@9[]u?-&pRuŢi88*L-2CzFai{Y/ I1S]@zÔ*߀ӊ*֭:/:UR=bV1}\Iq 0Eۆ 0i2KVzLN`{+;BRF¶RkgHtEbb75I }#̴[8f�78h@"Yb*n \(e\q�AO%ϯ !=%JՖ1 1(֨D;(8�a^} JSUMKC4NV ۬[5u4$Tm[ ͆_bE9ag]&3,1HIP͎ȫ�ʡ\biS7{ɬ* a"kIWR?ʂod7~b~Mhq2Tgr7S'2.r۳f؏V4W[][;RejI,(UJA^? I9(�k_s�߄Idyeڭ$ ȺAo9FvaL8x!qSc#'[t 'V ζjD1uJ9ձ`Gw)qb$߰0j"$pnw$`O|<;w3G6<stu% ̇ ;\{Z)4F$�VEc3+Df g6?7Ή c!TO4͛N>[!DZ@ޝ@Nn+"ғ@"bJ"^ +n- +bpl87@ΰ:І#<H~G 7%- +$۪]q3(6 +"xaCi.jXdWUѐgVMY`:ݪ R +)~^Ѽ.kg_ݿA qw`8};0kpo)9^L; 7w/罰מ_tr Y`qҗgaW�g=ZMN^j Vő +#uvA&v8-z q{.8LUq/-;�ětv<;s=cr\=^Tm]kb@U1;S:mK2=r+K9 dWgbgOhg<Mo~hN"]]`q7 m.A|NT�w,:AZE%{+٥;Fξ̔Z%Z bWVR~\h$L\ܸ>?<\)63|gIt>dɤ̙Y4yE7 ¨Aи=IPx<<!>aylX1ƢJmdkJh1X&s5"L^aWXnF?V˿}#F|2ѠF*"CocoZ˗LZ†/>$Rx })T%_X@qmx"GP=Eh)Qm~D(AYZnZ@*<O2Z6$Ws*0]@-pLGZd& +5"-R+YH`2%-ȧ6yf!lXXI!/ j>DbQZbk#HU<0(Gsw:x_ӓ#b&`dd;NEjqK/4@IpxD%k_;R`rO5"O\why +KP/IX,GLi3x ǻɍ Eݭ�U5 yDbwwI1Nap(e'{egWTvk_MiW$> y}fa# bDa +Xzz�ԭN7unl@7ZsC=Gz?dfZ]ۉ/^"^KOT^N6/xI?[12P7QRsﻹYbDS ˉSQ!?j)bpT+ȴ'xoz]C#kur" i״,h#n+j#L,JZ5=V;$6Lvs~\RE'})-:}${M)gC飫bSx4t2]4Wf h2]~W-3wSIjn ++jU'\:4a#3hCr򚙆`*(X<z +o[=�?f&i@>y+]F2;me{֒8h2WR;7?&K|`JNrs4;Pyb-T) 6RrDv5z}#Hǁdh V/uNJ|͖}&^RV05sD$U>=^rpz)?K()5c=2=9smg)p4J8dMZ6D~9+g5IqH0+GͽɻJ:6 eTqD%H(w‹" a'F|Mm"vҰђxCq_۩3; tliw::bSLۀ!|E֌%흾)ǿ:^4 C,)f8}`=K*ߓ /ǪeSۤj0l$רkLMO?9Et_i_z;dQx*FCPAZuAn/Zʿކ +P+1onPz3Ùfiע L_`W*%qR&D -F,m\ ݱn5lstD'rL;<M΀{4CyŇetWcǎ{R[n{|xdS`Uz|ѴCBo"_OV"}ff%!I7٩/p!V)#1 %t3HRuzW>Al=o/ bJ841X>T%ڵirCU)gԠj4/e;쓛 "K6ektgkED!ɓYhOE?_<%H?jH"S!? +=i eURkƱ^딢<Hlr&4T_+ଞBtBJ/ Y\*ظǷzݔ= Dr $ F&iyN$[@e*T"Y1% w+1q4mBW6#kY֪t5u׮Um淃:lx$bJ~5{FW_{p!)ҧӲI;A$'HqLqymȕ%TE9W/}r"y#0:ol(1ESю<XMY*EZQ4>11!߼uodcy(Lѽ)yEB˾>ȽX6"gjl7&CBe#W5 l[YjWu 2~+s~7𹭼<ȷ`Vz\48Fr�A0iá{Ca<r>#}c-︃K *v"L3&v?ƾ.)bTXX#i:nDGƄ07U׉\pѩL緫>m^Uz#B8 Of/�pD6ΩƻǛN{Cۜ]^|j ṋ{kLBql�5)7N#DgyZn/X6#)}''kYN\2P:/#.{Qχ#9cYRz\ ,s$Ww dFTf܅olg%Nd2Wp 6H[ne'KhE&vh"ÑPv›?$)s)^-E$(fdϭ(�;"1t~C.t~vr H H'كy/K铏L3$ K>Մ?2CƞrKڿQ %O2 ԆLkq˵3ld}TD*"G+3gyt#50mV:Y(tps8݋pV4J*t,r%BaP +gFcrj& W_De1s$cJ ԮG&Toa=ߥEĜtsNE!-bnt;^jVX_bJɠ\T !oM?'Yh)' `)ؚ +S/3GtV_Xk"B͒Ϧ IyO{٤;H\Ќ +WC�j?Dwc)V]3R 3vfCo4~,goL"khP{.i۝dK;a݁g{,kEA dɄ$ʞ0lҦN}^iM1D(#�TBuOQ="tlV̵5؅+[gȪ1ڮI S b!6_Ѽ'|rthVUD0fZSaJ\foX$F`jF0}{Ɣ6EfVrJrx=J6z ˞N'}z�0VlN|.CY)UXC-|*5'}Qa]P*-28V$HRc_ij 닯}ks\$[=[E-啉Oi%hW/lKA] O;(NH  +s#, +׹:Ͼku|JOEY5[`C/#h0y-ox>E޺_xyUP>]#ti`_+(Nn~L4r.],N{ԉ2y!, eFXbe|O[ ?p Xi\wߑi7f5/ĖKaPP&1q|98`e>.$D/5>8 + +xߪOk{Ǵۣǃ12Z -b.R4ۡXs,>I ?]VlqQo##Fn6vX ]ms-({RiмJ lqy2b;&>sf7Ҕ^<+i F׎ϣyMVKl`^9ăE}>bGCd:<4S9S/ Sp.{z%5 p9ȃ䴫l5m`K(kN]='d>mI4WױC^H}ޯ^P>\F_v-jTfRCVR̨m{B{*"svSUv]k11tr.T^1;ZFEF덃�փ* *Fn8X7-^dd?0 ْ{.>XJB~3ZDPj7(aK}\#2eIU~Zb!/̨"l)ƣ1U8uH!QiL݉67p'] a%F\v䗏)WI}Տrоy + +eӚ#W/<SBcvgyq +ՔsS+B^\ULÂU旽|8?8'/Q9Bﯿ|Q_!/Q̻YttC2Y ! Y_DnPxepF<@ Q +fjJ &rBʉMD[j ߷P-g:QJ`Tgμ \Qv'p.:it+FA=ULyԌ kl9~é>ȧ-F H 4Bڅ{ ;\IA>>hD� Pu 2-Ο;l=ƒsZui4;~AvH܀ ;0ǾC:lXC 1)JoK䮁܄}Bu�[CiOpXDP'?7XEmѕoqЈ:R">*Vb|.Al= j'-8i^Ђ@%iqb@A-θ=J^U_/<~�(Tr7kF }V;VGhN-RfҴ +%ֱΑZMkh#OI +彔~n zjP_=Q:`xXI=Tv)VN:xe_g@9gW0sP)Z$uK/7o>Ub(C& AV%�6v4oeП@IWl%;(UkkDe7ji m%a[hYn1+~*V * rm,ai mu +X|0tz,AVP:3.@gX7Sf47%tT ~|ƺE tF6}=b`E``n!Nhq}3;B,u286Agai޴OxMCO(X0t7jj'u3)Rp:_^|7 N@OW*F�?X�Wh/&# #MvS)7[ULPUed^% E7PoSz!E[ OGR([;u T?X/ 1JxSmTk_MH m8hNT>23?U+!Cث_2F|&، nkW{Jƶ9!#cYuү."[V³^T1 }K19[u!rOKvɨZ""_ìUqzÀ1ՙl gqn?eFK1SIEĆo|*qR0O=EX[xLoYֶ #$E$mT\ ҢH Z/XX9%fIvfO;3spROy|sbx,J ;lpa^'wKW*7zs9^7̷̳!ss=VLMasg]:D?p@q=%=1s2[|~H;xp#t +K +1:W|[tD;=&5r[K9Fwտ4/S?ijW-YNSAN!&;S�9;E_Tӑ99j +bM;EϸE⚩기q"HUnFS7z_~H,kߝ#lQ}!l5{SΕ@%!{?Ӵ{#Xvp9 yܳM +Xo@\/t3�KO[B<hc"^e\սV`\tf~r0]oqu;c*X�f'Ԑ?+ԤE6uY6{KU0wr+ tg̘0?M3ďuKxekOzf?B,1kz!4#uWFv;<w77ߍ||Shq`ԓڦK=y!ha[X�z!3�.𱻯! C�ē݇`gƄ-ʎi +RģFo1\2PW@-Fe5d R-H zι>7t? _)=Ic\v&+/MPOYx0H'4nx:w]9Z&tJ=FƠi `ƽZWN@.(zUJ0ɐǂ۽ 粲'Gyvm_`$#;LR䓣ŤAܮkIӣFԣ'l9`g╄*5GEAHbA)U 0TM +;Sߔ0}S RP2gl ?b$Iw#1._|x:\WEgGu +^ : ZΕ/6*W_r 0:_jJJV뫏 n St,;Ұ z^#?N% h0 {*q@g+[AB}~Rs-9O7/Z3.vc å4Cӣؑ�XD#wkY�>4L4M55 Z'=6cgo4UuegJ>RWO,=J"87darxŽ8}Y|a+W}Nc$Qm1MVFZ #$e; ǔ׮w%Ciٵ,nB}�}ᄠ.j*Soi3lat�SS>%BR'S9l_L3R|1 +b +J(عz ǣ+a +R[%ۼ^䩅y_~~t%4ӡwإ zRs5`E Xu"- ] კ*+J3 +ē)p#]޶Rؾ  +m/C'"XK04/nWq+OSѢS txפoeQD{H)o +(! + 8I#a{V=./U SºAr5Ȏ_JPRtl 99F@�}��מ endstream endobj 35 0 obj <</Filter[/FlateDecode]/Length 983>>stream +HKlTe%V%u1E`ab +T.܊$H@”!,tc KPn=dCm&5 h5a# ]r^W.L[/'ٜyM~K%tJ��p*jKɦ]:͞bJrsrdYpYYNcy2QYݾL<6n �g{$vALLʍ{9ztojoK>w쏧{%kK.Ukf��\ubE{зһo"11~Åq}߱?m{tv}_g��\NOEFÑڝo*q)g}זG27��׌tVzv@VM .PݾL<6_�kгojwĥ?S.Z.[ �+;jz_gdRr|,yV׫_U��np? cޔmXs[e �~L답_;tRcё]>In�`_Ox?KaM~hא{~h=yEv�`dvۀA\ +c><y<< �m?EztCЧڝn q)쏱+[ERMj;�-7CTPzۂA\ +c|J+?+G[T[�-}5ϵ6aPW{+x-Z�`:KcfQ. `G<ӵo:��3 p۰?KaL̷-KR�'/kZm#q)쏉Y^^#A׺o;��z<e_rFRWT_L# ;��~쌟evgۊA\ +cJn$M%7��2A_jwĥ?43~Vz;�z$�6R/ endstream endobj 36 0 obj <</Filter[/FlateDecode]/Length 920>>stream +HKw9/Л]-FAA9FЕXl2mG)9XGbAx|o EؐNֶ;@vjzOy|8yw1}($Gܕޟ?7؜Xi7|NX~~[EY]X[�\}cE[HՅiGp~q{Q��i͸t 4_:j|YV�@.>J7q0MVPFb>��RlrG&Y'f ?qko?��Rkh{h(f ?qr綾k��fg;VZp0M)YZ˶uK7��ʶ_rӹ~oLӸ?ђJ]ge|��ʃ1*k4#eMUf|隐n��QY͗6VXiiw3 {��@lޟwK7Xi)9dFzn��aˎm5?k4#\n\(KoOt��%w~P*^?q냆}g,5vK-Z��mK=9?j'^?q+˥�@="\?qDkֵi7K# ��bfutk5`XQs^xxB��eq)۷IV3iJ6s'{�5LNq0MCfuֲm��]ʶ_r97j4#Z-uVfw�z7?Q%4h5UqoInkB��l֢lRi?`�L* endstream endobj 37 0 obj <</Filter[/FlateDecode]/Length 1196>>stream +HLu0%Qˬl.5aK@( .R!bι@ȄXqJikkr ?,Y}df>_㏻~^W3RZ+��>spҝj=5_2EHG?yϵw,W+Ot��o}?|IجPIwY?H,!#|c{�%ʯ/OR3aX +CF5Ctۻ˕��F;ǤL$׿ܸ\S��o\{v̐PaX +CVHMvm��DJw?H,!+}oA\v&-��έB%ݝf  +zp_"/��Lv :+G*<B4+?-ݕz /*Jw ��l=J3͊Ab)PQ0ܣ ��a߾ L434W{Z^8>+ϱ?"CJ_c��t?ّ-ޕf W'Gx|N<"7��\HѽP>_#͎A"=7W5L?8 e;_ȓ�y9^VlG;$mC^\Ɋ}|=>`xKw�vl}{I :_]X4KfD +gG>+�)t] +;$RS;KN:O%xNW �0竽.}Q1AHHp>X pޚ^%GWÁd�Py,i^)݅Au2W>7ApFq5~Ը^Iū][|�b;NC]^'5yڶ!/n:fZ,jmZF-N]0aBue?5_Mh98u׺Vw/}3܏f{k%ҝ�}={gCmit>M>sDRm =zL~o-[ Q`۳HKf>5$K�yE)7ީ?N$}KYٷ9TZpʿeDq=r}-n?�Bg endstream endobj 38 0 obj <</Filter[/FlateDecode]/Length 934>>stream +H]hq_k.ܸPj%\ "SZ%q + ۔12OŶs2f;(Rrg_3{ޟzݝ]eL*Gr2(`Fm_ɹZ8ի:{TØi(7,ߵV-Mx'�{/UX<ٲAByp߄L hO(�{[˛Po\]+&Y5)ES��wtS/[On4;Xln6>|>+�'m[/߸?K3{S~,�~>0_tOv?Ҹ?Rzxk,9I[��{#=)Wn48mhdAv��y^xZz2pz̥q`myf‹v% �`t` +a`?KMC,Mg �uv00̥q)pxyo3iw �`txv0p̥q)u"SQzm�ҍ wn\h \n6-^M�_Oًv.ؤ0 siv_SߖT�ޕI2ۅ`.ncrpi}]0Ko��>H' va?K_ֹ򆿞n\8�zqtbټp0SʣX�C }Dv0t̥qa,EڻJcڭ�Gov0t̥qcWY�I ;Nn4w\bjBo�@OZc &v0<̥qe#^]�~#=Xzb6a?0� endstream endobj 39 0 obj <</Filter[/FlateDecode]/Length 948>>stream +HkekDA JA,h +ke[3}$hX& Vጒ T/qɬMWsqVq¬OtQQ{}/^[/}dm-Ջl_iO $&G+i�6r'ʵ; Fȣ}U5n򥡦�dCM?x= }Iʾ}Ffky=�ȞyrZj"Al +Ns+HwƍM$7!� xr7uEaWQ;gv'�wwl~/{_/)[uԅZ^�bcFh:Ħ?.kxj~?�'߼{}Ħ?NgOy%�er7z^s )p8~0P'�.]v 8bS\[fȉ_4~ݕ��] ]?MaKo-}J/�߭oW/^Mݳ`?Ma܊bUoɴ_ߛ�ٓ;}rߵ;bN|bjݝ�r׵c=+k'�࿛v v ;Ħ?gގӒ$2nl٪ߣ�sOEbrϵ; 6N+ĵiw)�`nk-]a"k)�MuON,dGxxݴx]^�<\r17:ޚNVwAl +#^/I;;?V�Wdv>FI5Ѽ0G_�'Y/Viwt?Ma`G+vW{?x �Uz endstream endobj 40 0 obj <</Filter[/FlateDecode]/Length 1366>>stream +HoLuɅ G>-M9E)#PI«H +BDS(J8?~w ;h5�KeԳvf^`ɏɌ5'C 듄.ϴ{ �Sk1{L3׼Yj$]))}k�?꩟==V�?ʄS]~o�xQ/ _o}#/DIYynlaHw�0qGq�?%\)\-}{�[6� w9ɑC/�@ uJX&<` J +,*?IQC; �Hw-vc7QR?sJfPQ[ �HyDITk;%5V${ �&j&+5o� "lgbak=WFҢ?Y¥K0a.�(,K}@^?fߎ*ϻ25-i3|/{,kOb`y_#wP6�(6$ގ.@䘨bJ_Rkzޑm13�z6*w<a rL'%Q=rv  jmͽVӭlw�@IWxzw<a r\Iu6u xQfc{|4]L?u ��J@}zB$,@8J{b8ZP#q3k>YH;DG=]werF, �Ӄqԫu; ?d68y/]BSCMgy;ǬgKwm�gCQVJMżyIX +m\=5b\6weo|)(:F: T�Q[ۯ[mU<]nWbV;̷ Z=w%Ž:eR6y[盫P477?:=_Eo8�?7q1hOyw:}Z>a rKg'hD=19;^5\ ^I]k}�'5F?˅Sɼ}N@䖴^>^T4oXϞ9|,Q>cE^k =}VMK{�Lƨ7[ܻ"טJO/iuwՕ?~OSUF7�L =yk!w@ؿ � endstream endobj 41 0 obj <</Filter[/FlateDecode]/Length 990>>stream +HKLTgJ,^څU/mM4h;DM#! uąd BgCy(T\x ;n9)s?oyv_>d>-)1.F.޴||vO[,U{~_��@B_(>rbQ])'6qq� +ѥZc'NIojw7cHУB"((=)}(NbSȅ7/w +=�7kI?JOjw5r`<P}KE3�PH9 6\n3|a؉�M҃҇РvG?Ma We[G�Ʋ=x!ۇ_vw3rxySoF몵o��&]_#=4_a)adU]e&_|}�@>=Z:Sov.=Ħ?yM{o7�@>HߥG҃] {?Ma-_A'`-�&ѾSi/Vw0 67U\m��nL7Imv>bSp/ߒr'%�id,9_\؉Al +nܴ%8ÉKw�[['.}ݹaESHD]OvսU^�\>Dv^bSȗ-[{nܣ}3�@.mlN9vnbSȧPFW?sVj �0ή#}n٠ݭiw ${B)'6�\7FzDo5nĦ?oeӗ99]G�THo];-=dꝊ4l>[ie~ȯ}K�T<vv 6-#kM^\}O���mW endstream endobj 42 0 obj <</Filter[/FlateDecode]/Length 982>>stream +HokgHB$V,$4 M(eCjhiPIU bGLe"ՠ NrN Z8>J>\bcN#Fzd[OLش�c3͛=;,Zo!Xr* ^7ZqCѼ]�?"=%}Dj; 6MSL$ݞκ �5HOI_Ioiw'Al +fՕ.7wυ3$ �RO; 6/XҲi5'9X�Bh sSލ㵻 68gѾ +� K6H!^q:^ w-}w�KSRnĦ?%+#Y'.@0=jg2nX^FAl +^3fwo +;@\ZoL=?0Cw;bSkU'ߗ?\ 7R?c=݅Ħ?UwL{jӾI�pN퓴;:Z 㭕w �-z@?Mar* M8ɡg!y!fv 6RUd"tM<Y�K4u.%}y?MafՕ?MӿW�ADzEEzFa_,ڳ>tIN<:Jno#w.z,"q?MaOߖq/mb% �xz=$_HhwĦ?7G˛־a�ӻMGO4g?MaN˗wޖw �*7Oˀ 6OZ)oCw{?dKhBÀ_ 6ݼشtؙqCo:j5�37W3Z/a`x �=`* endstream endobj 43 0 obj <</Filter[/FlateDecode]/Length 1599>>stream +HkLgW Dt[bpf1q7xEN(0,:^0m*""[eh+2(nfnq?, i=.&}I~ isNϟPnrgߩ3gq�IyܡFa1ќ*�x +6hO}6j w8MzbӾ�͇:19/X,S!L%pVYAy}�|̓VpY?Pb*'׌=�)h Oa>�^JLbW!Ej<�lPr=@ֳ E!T 6+l{ykA�]wh<`=�%B�1ʬ5uOl]�? ֳ]?PZoO*HRxݦUs v*GWvoǖYC�/}!g=� E!lZML)iȣe+w<w{`?@Bfs_ʗ~pyc*�<A4勩Y �wB@b) +OGpD)᪫s fl7T,;#3~�{qCv}EK#/hQ'/]ju]C�]$\Ix{�5w V(_5{٩(*47ے[9ik\C�@;I*8�3P2W"?Mg޸]ͫ v&;M^Ha7ߞ:|XbF ɓ%*S$/V-_Hd\>(i WhVd9SWYO�|鷋l4k;R&)ɗJBH``2WWF9WB�C. =m˧ޣ�tAK}Xn#"48љƣ{b6ɺ)NYGMܪ*}RJUn~ЬnVF;Lw(� MԷ 59Ǭg ''= k[.znFf)<8*vLdo�*7(ߖ%ޫ�`pԧԯԷohOC@Zٴ&aa}^o(+[̆k#\C�FAYH;ͽS "XW�0{H[[ֳې?PXk(Gt6 YZP^˗J]C�a.'JXY�%AULzf�Z4}\]%;i_>moӪV ,ns)9{mt�m Kyzdc(1GlqV`l8~nXM|R063\hYlhVS|nId1\ թsBfsҙF%zIߒR}wgKjm!}^t[oV]0yGR5UUbn4DIӤwl 8œnKaGf" \O�=> endstream endobj 44 0 obj <</Filter[/FlateDecode]/Length 2770>>stream +HkPSgj Nu-^֕[ufZ.JGQX/VD\A \JVn +CI IRpmJݺۋz֝~vӞh<Y/M38y[<p:3y1=(17eLI ^N#[brV,^Ba`xz9 z,u2{21#$SajqcNnnc(cu.p="8O8+d897\S9Jc^21R-Vm)i<+&=Pc4Ayy3RB`_te&i[c"'=TQ!h,i57@w?ds 5A!  !GJZ>bMGUC 27axwTao'Huk% g,B0۹F.v9ն/m%.iǔ`wMC)?=R$~DWT&!}Wz*}iA>[c2^~@Q>WϠR+C/:/ 9TıÛa?~UV }?F>1 B-ooKVqe葧IP/~t^'|�,'Ļ{>X39,\ 7e"t@g7]R  !+%MG*}L}`zҺaܴ NH\omqD|mVEU`mJ1eo+b荤.ph3!iHl.O}k}IߕB`WM̳%5|} BoQ i#CH +$kdP;vYjрRFoQF)ؖ:Vg?w3Ai[Q% +c@nob:˭ +eOlnjOG +>g ONCѓ@Q/Ng76IkAB +wAs}Z*ayO'gZ?Cg'3jFA۽EC#P}~3iaŤIEFz A¥go9:+?0?gEOS-uhf Ҷ?/J2\:eʭ +Fۧ'J] s5 }G +QJk6%ux:_NqztueEnGwǜCN%{90⸉ڬ+2yu?/VckKM aof s�n $~G +-g;~Ho⩀~@GZ>0c qm#CH2,{k$QjPg2d{b=^Yqo]yM֮ʳZybJbk~. +%4\?W%arV2-i q<07u=0w{^!]!ZO\ Rh*\yNT&qײy<l;z~sY;k2gI6RfZI{1éUQdQöETc!X 5pq~GFz<XF+#~7'^INXս;r9q7:"e`)\?MZҢS;/6wzҺskU46rR0(X<T3~b*$4 +rv?6fHu.㼁c{vkʂa p̃~]y0c};mfUrk1~PP +YxG9R*D:Q9F}wvPN CZIR�iڲ@{ u9"OfLW3fpKedQy0Jjj0_w3)0v?OjV TwMV27-5]wt6?g34sYaw̖gER#�RFL/S`~ۗBCwtq:טfA!p@hi۞3nR"]!Co@R$ZEOeDP*Vȕ>!?/X zPzAZɠR@ǯRŌ24łZk@q5pփ@ DOXETFeVUtK6՗peoHkA� !"*~L.D9p w  B +2v̍,ԵΗt} cO!pι~qEnCCHcFJ(Ś鯢v[(RM6zGZ[7c$ge_c|_mLj=09Qu_iڭkEyQys ;pIkA !<џ{J +J_&^dz1o~/c7VcAz8u1_M,hsf0T, k'6ͻp0oۍxS303(]W,ɑi3ymG@�`� endstream endobj 45 0 obj <</Filter[/FlateDecode]/Length 14620>>stream +HWy_L,a kBв+R.X +Ug&d&d&?]ϽC.)/\^>UϱƺRj>O{i5^͟sR]~h_Bdz2�&]% |0$cТ}:瀕+]nzДV<5w󯕦l>nLgRdB_+a[SHV-_H+NAo0;T?� Jk }N{ cjY:Jf,R<W_ a!lT!{H2J=/ (+tｲI<(I&v2%ZQ~ÿeY\ecMd5=B0e8bd [.`o`Bn`J~!sdM`1AR-{ LTm1&7 ꏃGROP$'N92ݧ$wcӐf@j�f{:7jzqrmYx&6!J6؆]߆VMnUsۆ~ ]Q.<~! (cnC.D~xRpsBd|tїy7F2|WNN3m<^Z`㔄L=dG$!Ǣsd�݄_.ܶ9k ]\Kj9c<x.1;M/bg3k1d_I,#r#4zFv_Ϫb \'NL}׺Ӣ߻㈛IYͨ4d't;B͞rJ#end>|齹^f .N2oi(=zl2?P [ |@৭P16]10UF9|]#XDfsN1KVsoo|tN1`ۋ&nO /QDwE3 7܍'FpkU`ͷ^~]+Hp>3ix%~U&>b}ˬY.l9\F_qiTT4KZb^GɃè$S ֋lӈi4Ht7zNpugJi4!sC `vQ@3 ~~= }l/=,;3d |‸OW[`ˢ߱^lb<7Յɦ:ѕUWY{_7U妶W]b}da�nM sPn>[bш{89\rɡ~.IAo{3.>˩ryV߱? -_#~, L_OaG /IwؕNճwG扞5Ic xlҳE6̚&ܶw!1byKRhD K g`9o'M7Lu-1 +ܾz*fD稓A;Vz%0v7FH25}01ӝiu4fCs؆ 򩰱Eu|L|wE +s\㌙< +b^yKݪߥsGXk OPȌZ:C6`moTXbt_9f.Pˁ B)}n{.GY]+;[dCnBC/T)t/[tja9N~xcVܸiM_?I#&׍!YBj!(k&xfx2F@Aj46d`M܁TiRz8 LTX!y`�FvxR yⲻ#p>X�9 t?$٬rBӼ~$;->*'{wdLw,rtp^qtdYwj!rIƃɫ3nJR::#~2$n#ؙ(m3LT`i㷀8%-< +D/)UtxD{qTuɸxNճwGɜ:xeNԉ,sZtT5-;+Mjd 5J8? +8dA1ӘCe c)%BK>u.d}Ü +TJDS;wL@{zkEv7\Z-kH 1-Lwމ)0r ɐwnZ#O-94 &P4$;ځ +xӥ  thqZ‡?AAh[hFvtGh= џ~_ҟwG@Ą(ߎ}_I6u} +'NW;-қtv�{ mIpF:+LpљV]$8묥JuS>ǜ`9E'Kvrn>|D[36r,N!U[1JF3g$ۭmܹdQ#åC(s#b&&7->$IX#£,f@ .f*W?.P%V_K[,b#qYт%a@=k]omI$Ӣ߻A2:{J?'U}ALo =pUs%ʩE J>]Kϣ!^)' gp_4 2Y�cp!G|]ypOʊq^'Ķ'N^I@#0|j\ V<%KR'?l\)"G$p s_ +a /xq!4K�m:�l z G]|L-C>$oxc8`Gzh"py\qB䃒Us,Sq\ofҐ&aƬ>Mq`$,'9F�{QLtǹ d,tI%r]:캌jl9V`I_B›ӪgܕY]I T?a];° 4l@ֳT]XҐU O�L~PY!?UD@&@Tp$Ȣˀ\ry۝?X˩S*� JR>gі1cOfץ>C =Jjð5%.y4z89]V֍PG�캰lFXUrn=lǑ?MeMpظׇ7{muYikZƮ:!_X*R^ߵәQS]=@2ݣ^If:{H;/.5tTX[]zx{Wa d_'Ob;='{ 0/[ia8; iV]QNͺnRé9ɲ֥be�ΉxÝcu9]m&jrjndӓ>iQ>iau +}kV_pʝrj1JWSȟyNݪ*X;k%NXy,:B :;EpyL.$wR +6ay'//U}P:.rlM=S $8/A"x;$ ]^ujZkֿI*Y!76 ‚t쳂"7pQk>\5{c 0 +O7P~Z nG@B +~d^/AHbr܌u:fcJ6뼰<Cyɱv9{ l>}+įL;\l'ھ$pJd{iI`z^4A/[Y Ԝ�1FkTǵ9ce+ݾ@lb,dR E=2A]niӯ6~›^-e=?*+H!c_OQ5} +wU"Yގn4�IDZV +#.Bz![Gо^IiȀqsGzAch76[t/V?,cu*.XHs=^?Iq +3W %^I? +zd[^dz=X2Sy C_,4Z6ֽp GE!Kٓ5܏1'6m+Od�prm0 `5m�xxNw3Yim`,{haao39iwD==׫ֻv \Iv\Xq�QcN{,*kg8E A>�[x$�**XfP�D=7Wp+>�!䕄Rϰu\⪋`+嫋@么+ ^IN/_a!dpPTHT`qF 9kk ӗa<p=nj@ yU֚%]]K<NnS[w+"AI"o!> S߂$.C !GіCQ5@d˭1RؒW&z3` �C,D|0�:>w[hO60>0=oHBNp[I^v7CV.n|(m 6--TjHr[ +^1:ZycpADݕK(Zh͐趷v7w^^J{?`R@s;3UgI\Y޹9ή{Νw%7jߏt+4AldtxMh,{M۱0v(ʬѠ+ɴVeKʎ1RCLY<F#fŸ6o~[:v 2cGъPްd?$=DD<a~R9nF^n!hT,L\{ׯ>LDAlWb ݻJbTg#-q�9g4}o.+ r²~Y}A;/ P4dB8CIعr(h[cŸenA]%+IޱƐPTd A!һ\ePѓc1Fj:6\CH(à׫i'B+.tpr ioXƸ6fIh`~Ly㓣}tys)#]T{iJ/˜1#'7P60One7xӪ>e'#Yen1_;*MYɲC݅*|Zj-u§j1xaN4lb1,| +CjM hdD-f [R,痤cʭ'DZ>J!wJPI.~WrkڴܕO^PDG 4CM/~PH*~�-Fէd� +0(z s$Xk +zim }8?L0uzwۚ<+i7x_c含 ֒ j=1ɻ#BQPXR}C?G3fkܺEMy1I/wR`rJ%ܰOs")Xx/ Njam}tQNǫ0,Pt- {)�ۭwQR? Q+eGJ6SlVB|w^NYNWII%9pճ.iQ)%/\tuO:N7^9ƈ�rә,KZ9W<`UXNCQ#+4?NzqZtj1ేS#R;5{Pl'6a}wime}$,;sߓD闀di5 rhRLl '˳mBr|"OF�AanR lHvsLd>}KIhWA Zz;T}EE$T~d～E7u.2qJjL.X:[A]ZN$ϐ,Bbd-v2= ,?Rw3Et#|B +E�[>njmvPv<13n>]iJ¤+7"+ҕ6:_b\\G`g y/v>Q þYN(^{3A x�!@A"+Elٙ33g`BF'/6CJL@'RzjfB8_9^5 MqfRC4[;hpX@lkx,S>ΘF0iSӊS{cj4'e9(eRƤsZ2 &𢠓\7,1T`>ݳ(3H0A><.#/jצU1u.K1Q _:,dWDM,pc~碹ͬCwJ ,uY\J3 PsU&K1Sz<(Jt(<d0};'J,,n1~ǢogIO1T9w?%޳!fa3k%_0:S +b`7,JW%l;ぉ%p&$lxe5aJY1WW͖H0iK� 4N.jeeyÔu{ǜb7 bJә7`{c=an,SdA@cX.٥Ț69ʬ;zs|IkԡH#!:5ąw�1p(f ',ixIw @ӒŖQ儭K0#U4>a;9&"\\<8:@tL-9rh˕+˞rhrrA =ޱ]|3h +RiųGLf6TI.l@ZtӂKhsheц^#P_Qܽ�1l8q堋 {q &y:0ǰ(20gxt,=dغv@!sf޴ +v*)j'م|/8M/J}Ed)l&_IO ֘)8vP#$oJ/+漿:) ީ87H UC>J=4.-3۹dcҖ#݃AWBS9-ǙLIa(8cZ4ޘEڗѪkWc; z\viaPcvHz +>򤡇F@;+>vܸ[-lngBX7e1d̴žf,5)P41=.f9^75hM +K0g]P~," UڕP{JSvRM,7<t;y_"J{(6lr5&zv' >\Zxqj'v7 NWme;rZCF,P0aL|H+A,@{Em$¹ &&Tp }6NiCKjj6h[weXVβzbv8lZ=Vث g[K`WrZCJ;C8t10NۗTeƦ}"sYG<Ι|LwACvvә �rYA5v?< [B;YēF^F ˉJᔄX@6 6 &T9m9,22Lxme-P]aJ#Pfc4./h4^@@cac|ޕ0 ~7JKFsP}+1OJC\y1+nhďaqƺ0W4:gF*DNK7LT�.nPMXʋ5bMQ8ci<iDqÒ;L/)?g;g? ƩpgmóF{ƕ0u T\2+95`Y6K[[X9�"ҺTZc�{Ła ѦE&$ҁ؇EZ޴v>rM+ ":r@_餗D.Wg8`F뤰]6Ͽ^6bxkR SWæHÑH1ɷ˻i2["bGO>Ӌm8Yw;M)y=X-f|!=t-Q>,eUzawZ'kHUf581l ]>wl{38lp7zƟ#J^VW^�>Q5ܾ=˩?k=Lx2r[h5B`p!!H`c,)h\{VCCsNsҨ#u~>m%bcIWfɾ] +Bɳ5;ritbP_3Hߗn HSAx}嶖&fN%?r5|-\-k+4Vn? ,6CmNwM1A_h7{(@85{C m~Xe%0[yҵzQ˯ʛpl"#%ߔ4XR\(>ꃺv^x^<X_܇e$^lڽWM{7Yc}ۡ/n �1.{v!y8%W^5QEXY,x y|�k?�T @!ڃ## n4 \(8aKe2pevzzJraGۈ pd1#6rj6ܸ|\Ba~WMyI?Ӥ(1{Wxc 8~֪S ;{M2l*IdBIAHVVqW^f]+Hsqҫt-q%>JNPք%D@A@pCQQy[/d:uN-34i.(;1ѹRJ)-3-Qʷ-jLV@7{ 6߷\ 4\#ރ~Ux(eIW4IJ#RkǗ`*V__X'L!r]Zt<N9P~Y7wsxt<մEtpE*Qn}ng@ǣ]]g:9/u%ptSѭC{$kW<vTbo7 ;ɂ".#M* `|w$gMӫmahm?wgLo `UA9/ܧ1^z| WDB0$ZpޚdhS�TM"&P!J3ݮxm?LA(L;xrVg힌&wl ohD?jC5/xcR7*\dX+wjOW}ODZ-apրrC<mѺte@Z*Z@tu|5!7>-=] S5-My 83ڮfy}Ŀ7r־5Q= +Z"l�j:�mJ&k"6jRdYx%1Wz 8)r:Ҁ Ϧ%48,pv6K1q$_+]{$Ȇ(ˍKf%x+)Z[kH,iv1r/R.FpQ/]x} `&YeWw!:W ܋D4 +<RrdɃ½&噐"IqD.V3:0@WqݠI:Vf%PR g<){0)uֽj: ėCb3"; d<>7n`ww p9D9[DLwD܇ur1܉٧loޯZh}FĜ(GęphBןwy<r6ƪ0;.p!,{|x뀐 بVeyA}&Z*'oWaDؽX X>z9]q`}Tr6*m3vrd�62o| #6~I!c6<|^ y~?!jP +4mσdbFl񑗍UzV'bG%۶4(c~1q&r= &h0ؿdM'&D�$ +]_wA=_~dC<D{}$6 Ð?+qG6DءPS2gXjIe#CHבzTK8T^;2׉僼1*H,vKc|PXHf:RI/*ˣ8zJ5 B "m:˂czmP oAQQ\.$n,8%&FӪJ%1;f/Wief5Y+j)} +nRJuS&fl. T&6fu|5"7 6m븛A^[IL4%g~<`ϊT0h\[riQ'[V%aq<y|? yi3d7k<6ic!؀tLBX-]jCޖ8̂T_}K2/|WW2lU5Oyt&CVLrW`{>TxxɢIbJS#|rzM|RiA?MM Uϐ$:qHdmaU@}A44΄(U!IOOsBCeV2%pCDڂ/Rm�pgRBQ14qYGf+,^\}(G�99嘭2m;:"vL*E6Z 87Tۋ{)9f77?%.,`0k{҃�S8*%ʝSv`5՛-]vc|Q_Ep'cZ(O"8Bpdx@ 5,Ӵ  &^6VųtSIaǒ8%\�q +χЎ/k첈FTtG:Ch~y\M 5rJZ)d\UT X2>UI6+9ey2^06P�Us,9E\_ZMoMb|lGp.x}:$e[1O @#ad߰M{v WUt{5 ʆq,}&>bfuoGp?x0~lu 5D + ?O" Ss)GW`2~q]<|d|\0N>-N'ȗBng?9^e[K $@H A9YA9 +Lkݧz�W:/Y]@(Ҏ~ $AW,=A6V6\B%V+� P|.`ndC ujG|34Ϳ֤bh:X NG/M'87+2֏BSdA5?7N +Jm)4%2;ygΠYqNWmc+meU{ p殈ęN4hɃDO+sq(ٗiVf鞩UO_.{`,\s4wFГLF:D|l!N 3lDk^<Z*:eJ:SJ}h((\SZ)IrV� KXsp^pD.Rت| V^WqECp*rp +H"mx.^?r \)./g6xEJ CPҟq`,#XKO֙՗PNq%*VY&G[*w )( tŵi5?�gn-|q˥v1fґl|p*JT]-ח3 Հ£}dH8&.IԇCSۍ%aHf-Kg�tEIl~Ƽ(J~ZSp/rzS#yJrWr,H#cU eYȳ myf�$E@Klӝ L1ơ\䤙32@. b à-kl`Fz#5$@bUa?7Jɀ{q&O>d; O OyWN +zn}ZOzk@w3s[ :S U7JX͑ D n?=s`VSxO:Vo癗P=by/#%#O +w- <FJ� `ieM!:Z::-p!+!!bA1Q6pUcqnnFٛiP*<99 X*eo/5ZfZVyhQ-Y<Nj{1np!:Ư:{FYViy)LNV+JR[M'&$l`Oy6iopIppu!r g2D:30pn{GdMU/gF*TCj{cgF2J*?)G f; K +Mj@=^C D3@oQ?e|)27v?L>Az˭:(T]Ʒc]J74OM9‘hW8~jk^G!f˲~m|~?ALW엘mHHO79|M. ~p崗hqYj&ڋKٴ`y|o[24dz!MPhhiőJr_=! Rtt_LB{͛qHcU{;x6uh,~*%fčEOn bLVyw iƟ -1q]!.@ZD +|.Ƈ(h*Y RIfIÐ;XdLeV]E04dSj*&}o[ +6Fx Mm^o3!&,1L}@WN459{A8m6Di,ukoACWX`5ǚ%[F*8!b8NcwO[O7|Cw?@RԢ3.BȩJ.)^+ϒ ES+B^>[ e0Vͣ5iqA :E$OjeFH% T]MAYL..#*C1h]C.1X6Q<Zf9 &8_yz|_*r!'h <t6Lij0hf)mXo&t>.wκ>Q|FiCSr=!`]:쉹7 +�4>R0JT,GLv6LQWs\R[׺fd$+9 A e4E�xhX=|D}I/[*wk_Ə!r!tvp7N`زay| 'E$8{= v֜HrdJb#3;eF+"ao8n|ur ( +Z9 aF@mF"˗koT1s[NY_nJ=FRR'[4cߵ.9uζD?V[.ǺbĞ8Nn ;"GR܏JaS.LSP�6|wkw.墅]~ +EG>(: R,$$K8:;C잝D;>q1|P0~21\6!rM҂Z4Q[jڴT MhR&޿{`Yxgvfّ[7 + LT~-i*=pyV:QR~RGcT\ϖcٳW;bC{7BЃ+!' [S Dl邏j`#KB A<;!TS]-![D!/~!j!(i4վކA#d>e7-wgnLËtIq $UwH]R$-o^P >ӔpuNO-X` )OlB�'~c'F| a=@]%_4ܹ=FFB-o ]:PcxĮ^pKm%iv(S<Ej�l~yHd`bSN4Lea|R̗l Ts`% +*M_�P endstream endobj 46 0 obj <</Filter[/FlateDecode]/Length 3451>>stream +HmTLJj|!&IMLbIEkTZ EK}!B"ȋ)He쬊TkJs<$&jBL M?7~IF/%uspy<F3gq/7ME.4>i!'4酑imuW[zU:_M\MH^t[(r>C{4L$N |OF>Ҵ㘘F}չQ_gS > ~ 6&sR=1#Uf z6kFv=UzU[YdbЯ_1_4*ݿ)&{A?Oh4 t-?Zew#Q6N>%%S*>1N tK&窽u.a8!+8;77k8TvRh/rHڱ =g?Se&K9 ""dD\^7;k>X^mY4[<xF-29UaGP0uڷGީ6"˒kf5^"{׎OZe*(CEK{ƔHֻw?%ɺJ&Ӣ}úo6Bi#ym:�fWR![Rmu?q'9,#6?svqk79/W1uYgCy9cͦk�ۣƢK2-&Xgy*1io\mJ=m'SVZ.oBNN(wQEǙT Ɩ7JyͤԥoiȟZXZg »yzYX[vdƂɎsKD\y.zޝ  +kxN=͹NĤw S~h3nJ#c|bq٤&Z{suKONᏣ* ໵ξvU#57Rq +e@-:֫S oV;|9/^:t&7-:W<5հbȾ&oS j8Vj1` 5L^YUΊWC -;4Z= +*Mw`/OWs[k_ww_ M&&Ugvq^Eg6oޠmebb3bF(`iUxt|Fxzv |?h=lX>VfOqI!pU.ϣ+Qcqx.c"U(jO g~"c?-LIʥjl8p=m~wc+͉ix>yOSk +Wz?_VLw21k _Kӽ,lV0:#K;F!`vkۧկ?X/B5Sx:/*} +c`a<]qQ"G"`>mLԹG+jsĵKqȹ|nIGr>){q0D^<·@kqVlUs}= v׬y0>,P[.O[JOS9/Θ<B + }Xm2=Jo^6BiOwsHZ:@o#vTB|/ƕ7hK{ ێl|`xɅ ֕[W�?/^ Ch)g/q<g +GRC.`xm _ph Æ{x`S߿`vmsz_0`-%_d(ӽ#`)-dbbG?l9g؊،Ճ8UR?rysI0(7o8&K`-RAۑߛwBT}oAkb&K2-_ &=9"d|ު<ѝ7e +]N߬߼tn4?#<6xQ">z +C8<39v?s91$DmPocN_jXw?\xD5ȭ@gheԥcq)N@u"yMIpFi{/4.)KDV׽W;UBG' }~CLLLCPfM;$]iO';tU-eiXeJ mk񬌖>ysuwwaOzLަ>[ fn<.:Nu@?_u|_u +P<R-7,َrys .e7z,='4ៅ[~O+4*{)J##<yFgyZ̡wwR'Dz- [dryNh秕(4&sR^#yE~xxB:qmHhu@m;n=og!>r.}(jr!yX_+5[ց{(ƱGo0k:T/ +}xOHq(uةEPQ] +Y[f)$Y,L, +54N)]i;t(x-(׭{RtQ>z=jmQyo4{sW,_ĬN a) 7S/}QG>\IgҤb�WF.܅s{V_6s6w$kT[gI?KX*6?oVfǿسoZJ}ɏ !Oҙ&c4?VVҢmU;&4}ހ!hۮ5DZj]/~RB>A~3LDҤjH'vj7nY8XTeyzE\fߺ:5G8A^3KDc4?֝w'C4S+vhSk<f=y,|X%9?r< r"U"JH5=7|3&,ga-L]`?r ˑ la4Dɮ.j.۞7Cey17_5\ȁthvpT"um)|fO =} 4'b>ٍKgfGa RKGzZ.[7񡢜]vKr;WwŒ,`4Dct^Cσ:|Lcc-��ʬA8 endstream endobj 47 0 obj <</Filter[/FlateDecode]/Length 1702>>stream +HmLSg_hő27u,s?�Sa85DȐhd-Ρ!pFNDDֶ(*ďes( `?~7C2+}BCeY'Ľ3NZM7OZoo_HA)^?ڟS&N up~}-E)uwVw߾u-kͩT{kܦ4{vVeKRA J}9WrRAXm*y`.k-Kd;RA J阌""?Xglbxx!uyJ{p_}x1-s<0s}PJA JiÒĻ)5ڜFnwG],}p +F<\dR2oR8_"FdTE*6E<#õ>v7~/~{R92wˆ`Q&k$bjw=^wȐPm:a1]7>;'{Fvy J+f;?Q+3g۪ŭYCQ}=E|FL3z]l;'{ak&,Umxaܷ;5?(uWq"I%dO]j³I1\m]}(rk?b{l'*{Rϖ Z-{^27ZfC >Gx|f`?,-=3{uǭ{jyѷFeO 9S9rƾ̙U Vs֬/]/,r9;/︭VW(3J%lK&(6,b5wtAk"iaX/֍K 3ާ<g>9cIAd*DXO|<cʁ6y?|Gy0aIQ"r2Cg GϦGytwZ &D^&PT u~Y݃ucsOW7d w,*4Xzy?|Gy8㑩))||mxϜGlM/w[,ryXu>ԉzQw 뛷u}rΔ3OwdU8\Obplꫯ9?|GyCeƣӣł4MzeaDAvb3^IƎfMw<x;!K녰$?p^p]\uF!p:8gSw̙ Sǎsw,*4XzY] gS|ّC5{=e@9cg[(#o3}E⌑ώ+ �ϻ!&>z1@z^[쬮-)RJ}!U>lh; d_4XLy;;sAA$*4LL8RJ)zاa}!U�fCF%LwI!B䦤o\:h|{)ۜaM(NXL7lz]IT?r !B!C dݎȐP~m׏ɞQeM!B!B!B!B��I endstream endobj 48 0 obj <</Filter[/FlateDecode]/Length 2248>>stream +HSSDET"VZWQ/CEe˲U\RրB!B$:::V=ن 8Lbgy2^�މZUƇ6ˋ{[i)=,@])-h [ӱ}~]d͍!)VUn=s oim\<kxaU^g?Y ը3,rꋌ=S\"qzπ`2~>h5=li:;uS_d]() u]'mCB"z2}vϭ5o׬e8Hr"c꫻t/.>w/<9�'z<q0͚W̟Lo/٥[w\Dǵ}vY\Eqq(Sts2\oP) lÊ[Mghn:臌 IXHĥL8j68pP姟?뎺k09{+4(x2_R#m +}Tsl052csBfht1IX~=yolxBr {n][KAgu<#cXjuS%?Ƈ +hզB#i)]>V<G{!cժ1™ />vOc7}C{qp5#ծmz32>s׎gd=RWa\Iڣ鷯OE}Gqlfytd׏&klAY:m oW3J۷%\ؔa4 |$}G[UujzQt[h {�LuXp>G!cѦmHcCBuv4_jֻpǐ/汭YSN{2_ңo[K˕1<(9c\0=&?:V+qޓٳϏ2-52K)ǟ/G]:#80P {<}A⳴JKG6&&9K߄7>rhm_:U);u3;_X<h5};lH`/7 uvHq_;u81Qa/N\)-50( ew,ZɆlimp!c4*mKNKӍښ9!ߐwC8~w:hX<;B dL?[4֦Rire1.{Qʕ8D ,:`2̆аvd,EZk{ͥ}Ǝ.˴JKG6&&9Qgy#׌S6GK 'z:}[relJuǰ`LTDg > :h5=v(aX򊍊~7dJrptFY0 +{  +?ɣcn3ttsHPې(f|][;Rʕ4g#c)ժ1:WUQ\Jsbp7 D&U_%m3vܵ65f0U +u4Y&ǯ2>ڼ6.^|Fƞm󚵴Fikؠ�F{cߗqր'⮿N_[9l<{d -@G\[W96xwo?/]Lֽgck%98ޚo 2\!!NmjLr {`wVG߮0l-Z4v0P}8+%}z70gtjK`)/ ׯe9ڐ1]:ZUzޘ/?Fg:kk2陮bsؠmIY!Yum-2ǖYsq`Lz9 cEgkSc'Asנ9<2N[7U=mI˘Pkw#,+g:k09fIsC]~Eqq˄\퇌ȅ=j;o|Dۭ괔a)]Qs#F-W0a]+Y:Ƒdd|{;?b͆ºNPc|GR"cs&mߐ6W{AMV*n!)U0|?~9ߩ/2���������������������������������������������p +0�]\ endstream endobj 49 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 50 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 51 0 obj <</Filter[/FlateDecode]/Length 456>>stream +Hj1�DNi}hv/9M!d"3�������������p~)}Ӏ}0xm]a >sl2샣[ (V-yYş0eXS<9r,wO},q)l]ŋ?>`_k4VLSk4VLSk4VLSk4VLSk4VLSk4VLSkbYUf)VmfRl}0Ki4VLSk4VLSk4VLSk49>zщ)>Xk`tbe1`bnI)V>X{^vZUZ13MŮ3TsqN89]''bf]+fصbf]+fصbfB]E e&ӵaL}0_k>.� endstream endobj 52 0 obj <</Filter[/FlateDecode]/Length 582>>stream +HAn1EA b &Xdu^ <Zk/Tes|Jk쀴>WCZ}d ݫ2ه{PFk!G^Mj}8##S#GGDFL9:"2E,\Y:4su<fixҖ9;44tv4hhhѠAC[XݱcQ;SwǢvEl#a3cGf͌ ;<6.í][<2wyne8ʖ;= +82xzpd(Q-x{ rc1ȍc 7Љ#G@'v0z_K? '> pwBN5 'Td\ץOnl:7G|hZ#{ntZwù"˺}9+Ta;Cr(:ǡ1.ə.;Kr(̧LtTשOnɉz^;&'ԨcrQI]f57YdYE^㝓݆56,s{״ݓ=Ai\NNr 3& �dN1 endstream endobj 53 0 obj <</Filter[/FlateDecode]/Length 838>>stream +Hю@ DE:}c;R|3[m^$SRpL'T&cTRśQqKeS*yJN)rTlKyWsIeRѳlC.[ꎪekUQ|Jeg=,eN/{}Z-FZA +o[v"_Pc~c3} +џ'}}#+,!^z~Cf/OLvB?zμg'OQfCxiMe: +YV&a.ɘ>ࣵy2̯eyjfdXzV*c=|)kU{ç~}-@?uǾ~8cWtWV:8qg27Eyhz|F8ch/INBG?;t 4S^}B }H`[C?O+J a%A?R)SZ6کOGxR6 wF\2:ts_a:]Dߏ.'}kt@l輳et蜳=g{`G~wv<Nu<5Rtl8vN̢Nu4 +tr<Z.Y+et0kfsz2:B]FV` +=wZ.Y+et0kfsz2:B]FV` +=wZ.Y+et0kfsz2:B]'�V endstream endobj 54 0 obj <</Filter[/FlateDecode]/Length 622>>stream +HAAQm<FArFIuE,*t3zйB> +,*t3zйB> +,*t3zйB> +ZA?s?+:lG>nzOzџz՟zտK=/|)R#xC">c;f~&=XTO%NJXazйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +KVRz{,*h/ _g>B@?t>Av% ^]qd#;Op?ܟ �L endstream endobj 55 0 obj <</Filter[/FlateDecode]/Length 598>>stream +HױjAQO0F`ZPu.MMϓ {n妊KF?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:+_Oe Ttذ_9 +V?W>_v<+:lWSɱæqǕnv^9.|z§ +<P<BzupWSѵbÖ縔+2h?A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTG �) endstream endobj 56 0 obj <</Filter[/FlateDecode]/Length 1554>>stream +HYWHys!J�ك nжbB~>BXz>}f^㈩TvS ΚdT;Dz3&#w=؞v]vӯ-?n.C Qr#nL_ٟ΂��~x^~:!;/ARqzROfdbcp q'ѝͪihh +Q a`j ~GbxՍv:֬X˴ң^:d,ghfeLahѵ筡t*^1khdM&zi|f<g~N7\=zP?5QԂb.XP'hZ9~,U| ?tl0P3*g` +g*.*تVlcUUb;?(/*^噳j1sՊU%eQU}kī7ӧU~1QjmPtoKO$_^%*ui{Ԩg(6x76[~|su5.F z%j5 YZE/wc6s +;8ԒJ ̱5>j(_NNmXc8~G$"!s^DT2gLr/Z${/2k5C}nIJ^'^fL,Q5MorłﵹޫTQJff^⪟?Ds?b=N6 ]*zFT7ьۍDUƻe7YjޙL"woqle~ښOh%``v|=e,-׫^}q7V-l;yOF*̧b]C.4dgB&4,L@O.΄ ǩH8Uc;/R53B{7+ifVaϻ64-ܿh>׼turLszEUzIO;ڬgWNhys\ѣiwqDs1աu7*۷ŁS7UʃA>G^$Ŋ=f^9EirtC2Ey2˔Rz`ܿtً;$E;7{ R}w0ם/DG|ndd#BJܭVU>.+O<{x _䋜ڍzf9y޶KmrFûԚT9Jh]eix1P.gYrCr_4<2|vsk8w ZSw2e=;9h4هݵ<$g0$6lk5:rDywCһH˱+\X Qxj[NO҇z֠&v�������������������������������������������������������������������������������������������������������������������������o�v endstream endobj 57 0 obj <</Filter[/FlateDecode]/Length 594>>stream +HA#0 :֛O!?s =XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:ǩZa˿rJ6++y y*9Vtk-Tbh'0s\:N#;w+W\ocEMq);Wd=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}FG�:G endstream endobj 58 0 obj <</Filter[/FlateDecode]/Length 844>>stream +HaOP^pߐh”{6nfYL̑l ۲OWKqCf=sDZ{{N)Ap_sz`v/M{r_+4W}i hҴ ^.qG73R`gt#U[)H-#ȞLF7X +G@@^/dh+9QYڔz6a7GLnQVq3_ĺCV{WiNW���FVɔWT՜sW*TVab| S=7g2M/\$e3oىK{AS Glx EQ?VOn1f<_lJ4L+—Sbvf\J_(Z]J|b?rHHj뒍v1S.⹁Ft!}L+{!+xp.Ns(Y||G8כ,??ss +.ЋK'Jgs���������������������������������������������JeJI~VzGa<j^gػ'f'Z\ot8/nj]7O_|v/{IZ;N':?<>4[F+<7庉Mu?{[> +?Z5^ZOgVllOf+M#r^/ۚ S3!Nw7F͜Fcjte'ڧ������cG�J9 endstream endobj 59 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 60 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 61 0 obj <</Filter[/FlateDecode]/Length 558>>stream +HKTa[~D TTMHJaeZ-R2Webh 8TivA\F;; (E<c. �����������������������������X(+&'/L-'ǒn7E]��/N fSF7߽~cgO[kak��cw~~95m!Z��xV镒܈+��jaazws]dϗ]y99Q��ёř0ʮ ^tv ޞ��DSzXz|t'U* ��X23NU&6NTՖ+ ;6 h|5 e""""e p^ 6CpaцҢt'o{[NGDDDD;٢0.Wp~&4^ڊ`='%ƙ~u ǢϢDz>sZ8sd̞磽=K^oQۃ>ǟo[yW�\4 endstream endobj 62 0 obj <</Filter[/FlateDecode]/Length 415>>stream +H׻.DQ�JEG4Z;\@qK!":Q(PHxLq +Ddr2ɜd%Z_;Xxx:ٮG;3[++_3:8Tk$~c]2΃q~}Tu>kݷg'wקGWK]߽ d|?Oys|2΃\s>U/qkD��i>�;F$ �63�@kD��i>�;F$ �63�@kD��i>�;F$ �6}z��> ϛES,��| 7g�#}nƫ�wDRy|{טz��rI͢i= {`� endstream endobj 63 0 obj <</Filter[/FlateDecode]/Length 429>>stream +HױKq@!II%!7\A[r<t@DD!u ;.xw_^3|;�Y^gNiM��Dz[Ov˥no�A�@zkD?��Ҧ?D��M��H �6A$� mH�@돝Fڇ]�@ vr ��[vQx>0��ڽנ<tϕG9�IC\t��D=_~?8.Y��4"?*F �:A$@vSqi(i��dX:C9-�  �/kkD?��v~xP^�fa endstream endobj 64 0 obj <</Filter[/FlateDecode]/Length 1098>>stream +HOUu񣻈9J˵&,M/[YC\\^Kk7?bbtE.\A~ δZA[mmiGC8\8sܞ5_>7}>﷢K6*?'?��`>׮FlcM\uJMJ}l8_92;>Rs^kTGsNK]ۥoYT{(g^8v1:Bhux}[tE>YY#[аʨ}װ]dRlQn&[OAԡ!mS9ظڨpFvrh1_O/Ӟc.mNXcT~M?N5i5[&{k-38Q-G|=4p^/3n'cw?-: ~ٶCYz*&]"%yq,ϏYn Ld&e>6W'\ݴdkmt}JjfP:g23::c!3#չKah=yg9,|}EBjů޲KoYՈ~GQ_rK)Wr:gK)�d���xאM��̍~ ل��אM��̍~ ل��` +SH(g���s_<jr;=���E+wxj{'���EQR8 +��ѯ쾋-o3���Xp~HV?��`Vb渕d+W}��`V}g[JD]ds���F3*|j]꾌v8mO?Fko_Fyys֩pbYT��%Li0eb7u?~ ���TYm};J3s֩XEh���V4ODBaN2b^���2#4XſG0:/��ٟcR endstream endobj 65 0 obj <</Filter[/FlateDecode]/Length 701>>stream +H_KSqZVڈ.:( a+L""svٍj-hgs$h.ʋQ8.z7~vv�`k-3��@Û?OM^}���jrӓLGs~Zu��UFAh���>FA<_~϶t��#;-EA槯HoYM���Pj/S#k +SOG}aL ���JY1g՝FARo +Vh[ko��R]V^Xe0E}l 7��@)s*K8Gb~|?~MY���&{LvYb>?`lI&n �� ']vaI#2|Y}��@ٙل.E$2tIͭXުm}}��@:B!$Ic}?w��ٚTL4GT8ܮ4��Pk0Ic`Dm���a7GعT?`=ܥ>{Φ}16��0.?`'KN���¨g |dxf6��0*{V~MDG_6yL~;ѩ<��P%;L~ 0�򒝇 endstream endobj 66 0 obj <</Filter[/FlateDecode]/Length 765>>stream +HKSqsպBɠA E1/"((#+i(ʜ(psS+-w:*0ʺ* + .;~;s4koįcwmqL|wD}���VrT06;|mf?5jKM��XIvufs:()W'z1Ge��`%鹗ég2*}z)cĿ˾��JCg*_\ *ڽO��*svPUk1ttɾ�� +wvuwY?|as:Ecv5uɾ�� +"tR_;xBt\'F���+XLC ӑ7<1?d��`bwyTV? {ŷg��(m}<eTV?j]]��Pbw/*+6C[4b_1;��TfLIƾE@eC<CS# }E���*[2fV S\{J'81k��P[3TW?.zG>��@IG{{y#wnٷ��ǽGjw?[j^%c{o��PQrr|u2)?b!@)}+��  +H#&V���ewO׌8+H4{J?��(nn W +HT3z*e `3-�.| endstream endobj 67 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 68 0 obj <</Filter[/FlateDecode]/Length 1658>>stream +HyPeg!ͣFŬQ " +qB%DKEPG uGp9TEe/, + PDh6 ʟ݆jca~��'e7+od~=O3~([]F1^NTWhPYJr(a����:z@u}G^"6p;#ïՔ%.ζ����T.QOQWQ_ % ?ya1/yf;Hƪ8OM^����$qfuTzƨ*9M&y 0wEw)1I cg ߘ>���Cn~rSaY?yaqq _/^;Rz����kKgTR'(qW^6k̝?h{{}ufcU򇴸1>���=K3uL]q ѻ>ّ]rBTwVWY2ҫ]w֯c)StR����T?couQW=?R4C;}ք,t[v`Fy\3u,?68MM<4l6hyxX����PȨoAPSUd~?Myۗ9 ^},?&E +i{^*cF'.3?(���IODԽ.ǻ,09%G:W*{-к%g!y<����pVZ2DvzXdlٽp4ejEhj8BŶl;3G#*Z����vzB˩L۩noHuќb AzwUK珄옚5;DKIu8e5 ���`oG,PuIDzj_Av4+FYVuMu<} U]ƒCxg���l q{:zj}nD ?(JTyC^K珏#iկ<zOՇ^X����vB4fЪhXJBcIpNƊ9#D5d+KqLW#f1i!f?ߝR/b5-V82���(Hz4zM2m-/&NٙqZI2뙮#4=[Q.,^51ݲ"ٞ���>Dti=nK|hn{Qa�{H=iZfg3O2d9'+ufg*dS5=S���H7iFMgu"E)pdwtw,;.>O2КLPing1ƚ )Nd8 g����Xuu_͡~+T`Iwa�{8÷{:iDz7!=b,iݶs7k?����:zn3qO?AHݴ.7K %O3xҋJNRuԇThUN ���𿢾s +Zx9cXTfEXǟ �Qp endstream endobj 69 0 obj <</Filter[/FlateDecode]/Length 1415>>stream +HmLUu} YYl[h՚ -Q@J["A1  EwTRlҤ-ew\:~soS +x)O=jߖ}2TwgrbU/]}h|͉Qas>.��͙휺$s6[g7֒NHw?db +R7Zyww˵-boz ��`o5luz^tҊ'{Z#*(é\==&X ��`if?V*,7{:)]z0f.\ֵr\"Ho߱y ��`OSIHtn!"#tĨCfIvV+jj7(W5v ��+ 4tjPOiEdmbطF/VV.QV_;s��Frl\tM]Ǖ~ugEa}+1zUu\w@D1{f��zH:Fzͽέ#tБLdZ f[c\D7JT-9��Y=#]ӹuqٓ8ȨbbI)ˋu%l.8g&}v��(J>%sHHU@CQ⟊#;yl=n��EE:RHoHH9SCVT@2|S/~ǝ<(.'u��۷N;'JHT@2H^ϻwx-GFڅf_��C4`59;ZƂ@$U3ݡ<WN^Tno^";���xW*7٪FȬ,q]ǷqT+>l���<3Ǵ; }{mR?Sպf}J{m:f_��}x-I-#s!5W:Gzx?d63%jEJݨQP���p?ey=ݒ{HH$dE?`%}<MKG}ͅ61f_��_)+|;!zk(XM_2E^8n\Qx:s f��?Y6O^n03iJ,b;!DutRݷ+R=/ԩkC̾��OSZ/듂kw a�^_￨4>W},SV7'��kݲ)wEOx!(~z@VӗL&:ĎoU�B3 endstream endobj 70 0 obj <</Filter[/FlateDecode]/Length 3293>>stream +HiTw˪ T :jeqapa:) R+`,BUg)STV&t8Sux%_^y�BG)%Q8tOA�H}k-#zB$h[`9u {Lg^޷"޷/c4 +A!Rhc'uz2 1tgHL4?m{Xs,'\ BfʞS,S3 /$ &T^TVVt2Iڪ['[z-!⦌XWZ.~Wji+]g&haK=P+fJ>DžB!JFG$BrKEQCUI܄ &Tp#O93uoKنra=}}WB!{E$͜V8S?z;Tv s\KԼkBMӥz7!v*xO$>= -$CU ĊR}w޷lSB M$(<4 +$34P?ƅ>}PwӊT!BCUR{'yp,1Ge sϤɋx-mo&ՅB!KY#ձt\Br ++1& &T1WVo_yfϭ[R"B ݹ!4sv5^A&87wpju6~ ;Ba0&[Ӧ|+p`V7M7jcGǝXotfs>c&e g1$浂y2nXgBN\4l\ȩWr+e<ia6j^Inƙxi)~Ig6~˪㖤nhGmֶua-Y-P?y1#M@_#l{lg?* +s3J?`2G7<ɝyߋ*sS3ׄАelhK̅Mv 7L:|9$gK8)$+7T_rs$[9r[c^li@ݎ]>_UyZwVl]Y4lV[Xb_/ŐKMoY*]]u7u5+Bvu6>yVs_Of~H*]¬K[ϥ +a_k32υq_] +(̋C۴Ya̞-n4 Q@rǿ 5'aw7AMe +{\/ʻw T 31yS%}zy6I<:=;1~|U:G7ԉsn>1|Q Z/2Ggɝߜnu;�9P,�@ qmo{@ӳg$ڜ>V5^ƴlTe-5dGdWjŬ[>VZ#b${^8uҚ� mn\ vV rD052-_. 7ywi"1qx%9 lB H;Z+Bz|i\Xx@_U!4`$s X<k6l_Gg;2\L\ŒԽW2rBKWګc]M]~:.I 9Q܈S.r|CvX>FvKvLvZ8[ǒ_U{]sCgCUE;}wA+2n2+dwg9{Ĩ=[jVbfl!9䍎2GK[%X0+a!9 LJ0]2 Gc5xOwQ+޷Çı`Y~˦MӍۻׄiL)ag$x˪yS }e +84y]d\WC*Osiшn' ��p7.�E�e�GӍ)R[Sv:two,+JdVoɑG6 tk|MGz0"||E_h<'US ~ A&VS.?.{\e\Te!+ta)̛2.]poװĈp̓/2=#V +nGoXzWSW-Ij͟( n�T[�XNgc9Wh�`Ug_gɛ^lmQhW6zVswu✛q_\o.r,fT>NN{;3n4T&`Ku{5oK H?`2g;~4qNҩy(VpE!ЩTEd6+S"LbKMtt͒;xH+I1-B Qpe{o]<$t!ጌ OA T$2J]ZإaMu +W6!Rܴf`I[luZGNzb�hoQ,8#hL�9 `(` \HK>#:ur5Xf`QToN{ߏw +!~eEtM~w^bm\h^p+Ą<L*Nˏ#H`L?PjYʫܒ/bce*= +''7<,:4_ҪJ7]J%|YcK}gOB2 + g�;${4h>,̗_:=eEfe/ d=E4:ê)INabM1q~Q2rx<kemy\GLU=:ϗƣ$7`mc8'Ó+Ø�ffIGn.}tV)vލ&k7ƒ.EzXLA�vx1�^a ?2V* ވk85$-9t3ܱ#ڍpX .YehUr2:w{:9C\8ws{ %OhUR<:-5h/i0aUzlm,3cHƛ$}V}ed_ɎB~<x9J#Kv�gj endstream endobj 71 0 obj <</Filter[/FlateDecode]/Length 2910>>stream +H{PSWO" 8`1v+jWmm+|VZy !$ $DtkW("ݺm]__vdA$|ܙ9' o'z5[mpq7)$2ttBD}5+pqM{y,6Tq$T](807lqc ƴʏi{RM;R4lƙRaɤ=37mE2j 8P}dv=oCsǘ腤jޑʝ�BٚA{c a_-;s^Kz\Iߝ0̋؏B:-6P;6+-:fj GbOW_pԏڝGCF|a@^FL@0tG﹫VV1<]'ݑRa: : <) &[6a[-+>R**7҉BL|Enܻޡf[ei]b�x{aܹP +oOX!trs'I11NepwYͧڍKoa`0v!97o̍r#†9=JG}�ޗ] PL'xmj,:S[zφnmFx1G8;GLwzv_'ے|~`#@Bڲ/FհaTH]#u���!jUi;\Ir|k%#=_ gz3?f"7|!w^}#,B!C{L{=+ε6Dނ`^Huԑt7HJf=ڣ`V#4Qģa}޾b.^bq.S{t9ejϘr*g5ntOQjE<ub +g3&+ L +B/岬&;ɴO= +<7h6a=�:v0zĽ V=kC,,I930ޯ-{;#ҿ[S_7#%^ʢJ.*qwFK(^ Қ[}R6!G1V[XB{D"/8[`=x#m )qT,n#Z߱iv:;8DQ"j]JH[MꙂc/7"jZTZGH.`g`\H [7`.Wn߷1kSJ#g4Tv `@&3=L'5\?c&N_9}>gIo5=-ay/9}p\ig7kTn ME(!5~J ݼrihP��)h=c n=\bNJ +N{N"VzSR[oڝɝQUέȋc I^ٌΰc;<+]si*_#k&B{"?m2l49Yʿ9`@̉ +Yucc˺A_ϙC$_R;J]U tG-;[ہdW1f#9kZt@u;.%5әwx5|_Es5ExBW�/mg$¬1랮#2h̥xܹQ +k>lw% !q~+Ӈw 5r_6Y\*V0mǷ'Nr=r~�O�_�oOւ_gvdGIg_9}>? +*REYՙJaΎ๪| gG`iIn U) +)<~UH0 EF@ȏg}ꕒ*Vv3):z@@{#g>^͎8܀:xHbvÙ+"^w_;|gmGMZχw}\x"w~Ԅ}ڴC1y6|YIc-+!hfI0}G`0"ǵK&iXYPu!^>?ܫ̞h|=+</i?ScoYYLS{{Μ$T"+\7O/DTE<l7O* +SO/T}D 0 Ƙ)_&_v-ܭUKxm=AŨg>qT,6?s&d_˴%ǺFCߚzϘ[8k)ΐX?/XhGz6ɋN3xt!.O�`hFAmZ_HDyӦՃ8>N$KX8e8m3|>QHjb0yY|٤D|2pwiwdi6Iۑ襻C;yԿ cJi%]Lq6T_*2奲f +nl[CZ@n>UZ\jetuD`'g};nLx |=?G(Ń/g`xXWYv!58q�@Pb3 J| -ݦbC(יa7_k]\,;99gu8)aSAm_Q<GPbOLP"}XP{過%r<:޺Ԏq6hcD0 \l羵oM@-SNeG_EuvF .MLb,n}D2}0@�ދ endstream endobj 72 0 obj <</Filter[/FlateDecode]/Length 2212>>stream +HkT8Uqtvv=V6 +i;M)EQh;D)b4ȍC\K"`GGJʼnTBkvCiI9y߇1F$yO?+`Z44!aj3#&G +fj%NmfLϩTvK~يy,8{gb&?&t-c7e=[{znu/V%7I-[7MrF佧G`zz@f +h.Cs'ZpnU4p<<XQnv0s@il$I{Ґؿ߁,^6?Iʟ5VuU=a [?"f[G'~ͼp21+f-s?k'{?I$F*;e4b㜰3�}?[qAoxrf'C뤒6USzJ..TA +.ƺ3^f$IG٘foOOH9 ![˟- 5R1vwptlx0 ϔan=Ndb 3c>mLDfуeyL$h^<0uVK/6dE`S gʟA_X{8 A8:~xO+}u!:DQ{6Aª(( $Iґmxۅ' P 3a1c-k'} zvwptl�_9//t5kTCo!{3gf ǻ%*s$Idbc:~+vdhrgCC׉}Aqx`Zūֻq +}Ue3g$s}N"o5eyK$IZ:t|SV>x1#˻wV!BAJ.1ԙasϴ=q�{3KYF~_}|&~$I߭!+:=dCjq@C7%Yέ3Nx Aw# Yȩ.)<ioIUV=ޔ>ڍJ$I~xsuo>+'E {BZ?޳}%<uS BO*t�Eskg^=l Ǎ٬X0h\9<?OI$nY4cW=qS]Օ80;Zz";,gu61; +-t,XÚ9X}}+gwT\=oLU-wEP$IטXF޷j +ٹ3ٻ3 B?(tķiJ赪a7\{(l[dШ E[s$Ir0)79y6v`'/r6kԟUv7 ,㑜x?q=Th[RNT'O7I7.X$IY7Q?=׳bgt>ڶ r?zǣw?{? Eo Y=i㝝tqL$Iڏ5ឰE{#gX6G,fg z[NBA܍=mn'DQy cZ4V~{-ܧpO/\$I$aVN}MVx(E )G~uEg!sՑo`w?n�jʏ/[$S"W{MiyH$INެS iJluwq)#(p2ą~}sxA^_z_KD=س + k s { + I$996Rk,hD{#/Ľ}!; A^˘XW먖}d}נQt~#I$4f1Y- ;%;&y~ rK>?^+E {cd/mDMwS0Os|XC+?H$I|[3vA'mTHu? IdϮx*B] ?+�k endstream endobj 73 0 obj <</Filter[/FlateDecode]/Length 2127>>stream +HkTTr\`i$mWb*XT +@1&* ( VӋZbmM"0 Ü + 0t Jv5i +py}GI`!`CLc'RJci<l /tq`#{U3f}B՞JsO{D:pViw�T7OzY4qxe[=ϲ~"՜}A!xVm&[_P/W]}kD?(\m\la{�xzpM[N*4uOHqojo=tsc b/A-Q$!p⪋#Kotai=퍞 gKQw5i=?�x<SPӋbcgSAۛ; %D4rdy<\B8kw@i:!s2ߢ%(˔C.sgËY�|7r3BEWKg=a)MR?=5+ci!͙:@֑6h1Ӗ}=w'4g39?�n?U{ޮ&Y|!MPV a~ˈ7gg acB'% w9:;y /Vm.4i +CX� yYkI3 :u㱬]{4gPF/!ׇ;͗w"pKOIג625?�r_9~oϮ$B9uׯ32<Yǣ$4#3{@! i"7GR/Vm4VO w �ǏISIEDÔf뼂B8uTFZ;HKfD t)ޚҳӒLsżh;�GNzB71V恴4wo0vnyBBAwԏu8om3-?�r~Z~oTYllXd[2= b8MתW@ܞ(ޚ7&<z@�`hȭPOT=P,ϲ6ȕu߶ݙDu)=BxXEH_KA*;W-dS�0t?VIswo_ cB\uޞٛDO9mAs]YWϘeu?tܭ q1b!éw +�K8uGzL=_vkϖX!l95B! mĜۺw"IyNծv#<uCֻ�Cc 'z5sbLK͎CibJ*> WA +Aktu&̗nm5GY� rRīڋ֋g[VB8_$;;ć=6{@!:Hb/ +~d"=ך׹xyh^7U[]fG�0|?v͠w%[m;1${9nF{@!H>A"Vy&zӴկ{VzK+hnzspJ'U kE3.rg禄1- {s߿1'3@!AA,Dk^LL\<;&^'@3 +߬w�uCa+K筥9%^l>}Կ)9pq;!qiifə7hم:͵ҿuoo8zw@�`dȽ8TxetӈۤĎjw9u3B!xŚw +:ٍf<CYY^$*KZi^f;�02?ontZLuӦEjTEsg?3) �ܰ endstream endobj 74 0 obj <</Filter[/FlateDecode]/Length 1794>>stream +HyLg(u9uN6Ϲdkg@Ei<1&CT@Q)GPPQhE8d<@p[b?TΎGy䓐_i!��ݠ&rʹgNomM"66D#T?-^:=R8:r 6qg0}.9oa=gfb'DtA7t;Ix{4Y;MD4驥 Ome??���: !3*/$:wza!ZV$*%t^?Axam7BzɖMgvmɗ$NyoLy79s5.Fgg?7���:Ї*uV#M2uGٳ+F&~Z|rxMX +5Axj+IVrkʚ}\L/] ?S};֭0<[\xy��U6@c g~d\$^Wb#}dҺbytF6:S%Z:Y +f̜E΄䈓 +ei5*I:>8hm>CY4֢y~ukIuԒؠ�ų]Hs7ltE ��ƭ!~CO{EKesIrı/\-_.A2Y _֧8Zm>8dEJRT}ݻȸjT\"k9W}\X]E[,%yx:$DBY)‚C=R쟸|���.<i{-N'ANE2q9_6LׅO2a._w̙DECȮ]C[{fܷWv8oC]qȹ;j.)W+Db>���:Pz:j[aZr<7ғ^#X|Kʒ#{7YoCҳ8 噒ܽy[3{?=K���o[]XK]J"ZFN>-[2 �)F.Q^32��z;ftoz' $Z<נ4gF媘ˬ`��ަLsUB1띀/?QZ3ȥ>Y[2q\c~��5%^ w>A@;3o#G5{~$/]R%:m%Y-F\٭(-��RGYt '+͌amiƳbX+Iɡ^^ U|<cҶٔ[2��L]Eq'ٚ4ݿdtOC@{~$'5YJ n3/Ƹ#o|c7(3w2��՜,Pfr3iҷOH<{@U}8?ڶ|4<f�{��T9Ke=cħN7|/⃃fm^nż>6{y$'P��LaVҹzǨB%GE?9nWz ��`j&tiK ub= +1o|UќP��L͝y9[I-W)8>Ci 4�� &tֳ?S +qlI+RGX���B}W:gYz>C@L)NGv�5��@OW%lAn^+�) endstream endobj 75 0 obj <</Filter[/FlateDecode]/Length 911>>stream +HKoaVlJBb!jC "8hdX4ZTR68% Q=Lv 6 ZuHlt;}m}s_se;we[(p#s1=,ߵo&^DZzou��0zk=nW:)쏑v|@0s�Tn͙ 612NmqWK �:_JJjw Ħ?FRty/ �i4.,=eO;bS#QT;_q��L!T:Vw/ݟ`Nwښ3M�`3?7/&at[(Z:^�uҗқbwG$bSlqݷL� fKo>[aCMF�WIOJ_^n jwĦ?f4yjv��GǦ,im")쏱h 6_�5ҏ 7n/+;TbScxxydo�k~vn_!=l/;TbSqNՉ߬� +xLSq6Gj,9m\܍|J>ݹA�]ҏiwĦ?R{@"o,п��h>^<_M 6:Y +Yq�@[gEG6Gjk f�@}7<p,ة6`Heeڷ��-CݥbSw8r +?��`yrv'ۂAl +#f[紻#��v7ԗwz'ۂAl +(*?>)� endstream endobj 76 0 obj <</Filter[/FlateDecode]/Length 903>>stream +HKq dzuA +!x Bu azhP ᶾS74CEo,E[iMV*T�\fK=T>VȎ;KV{}ww-2IqgOe_[��SSyE*4Px��5;M:_"`p0;JHnK7�\K'vt +I74̤qVHO~߳#t��ȕ2]pOt{MLGnVd8�l}[>%&{53iW#_RF��mkujoI7T̤q8?ÒD;�@B[k2fҸ?Q۔gŦt+��Ȗ- ݷ2sҭ53i.Zѣf^��Z =_J7t̤q8n3`ELI7�#I7t̤q8u8$eEO^w�ZRJ{"P-V7`&Yŝj.>Yn��7u +=-U ?Ip74 eN +�u~oֱ馺3iUFrt[!��\W:1;V`LnLƑbgG��Φ<_=E-ufҸ?dVd8�^- 1閺 3irjuZ_*��rVPwftC݆4YH& ��.;{ +nq0!)~ӋMs��p- ݫ2[t#fҸ?} zl|_��\}˫[�jV endstream endobj 77 0 obj <</Filter[/FlateDecode]/Length 1223>>stream +HkLu�?`4HKZ4Ջ2a.H#تeJa3rn 08D +&.[[CM˭_F "?o8gy7u5cIܥ]nسOBY>ת-Z+FtC;RA��s岧d_Lb# Y"=nŽ{�I~- 5DWXf Ѣ7'}�INT~=JyWh=υ<%<nzǏx4;Hދk/�� p8{4;z++䇵k;.-5ƺ8�0/[ #mTwٱ?56Ϋ?/qFۖ{��WDGTw#Dκ{RRWoMr;IQ?��HsYSTw"&?VSS6oXv :Uw�|z45坈 Y̊G 9~p/�<~<4~pWT݅Aw"V>/7,!(;\_^Я9^{ߗMUǨ#�ɾco-{HuY0Ol __&4^--phw3gytG[mmnXg6̚+Uw�{\N9;3<?39"7&d]}ÿ KsuY1ج��")UJDKY|12j.ۅϏDDA[MWog��uogU%*>L zIVbI8Ke'PO��!Y`$QD/gYg}Kvm ˞; +�`<,O5/-xUyazb?!h> W-VS��|,?DuHaK5c�@d4 ~=pwb?cg{ugs�ߍ-aW맺031RRTYҐ��՜$쓢<݆{c#/dNjr>Q]��Oe<aný?П6Z9җ=S-�Ǥ- endstream endobj 78 0 obj <</Filter[/FlateDecode]/Length 430>>stream +H׿KqowwQgKtRQ[u5t!lHBjQ~TY{[ВCwtScgx'������������������������������������Zj/o4~k|N_6��ttt4P@ vM<*$=��{sQ^$= ��nn|[l6tt$<��VթJs'Çwե.Ujld��HչV}-nzIڹ271~1��X>wg==6 ��Yx8S*o9?[ +]}3_zB-IV|Ok vƛq+H n]/$ � endstream endobj 79 0 obj <</Filter[/FlateDecode]/Length 925>>stream +Hkq5j#J+fJʏ0df + i#1k#sY6kl4.K!?rݺُ>OW=9gocW��ӱߘ;|l"q)wJ<w,Ø'c=Zci_)in�{>HO`6ÛKN)yv��~~_<0Qe?fӸ?)v[9_Wu٩l� I/ꫮHG[`6ûn4ONi7 �u=p=smPo4o}hYu5�@zu<Nz߷W. i6>;mu*S�>B. iޗr:g|mi �>I'֜9NYfӸ?pFY~8Tsw~��C }t"WU<fӸ?0cOԾm=n� zDpC n4{l(Lorzv��҅9ڍp0a%mZ�\O5FzP'}n4,-v}:ӵ�Yv `h6a?Mϑ`閰Ԛ?�ȓ_:p8XYIpi߼nТ@�n1vfӸ?r4_n- �`|iLӥ-{?MSDSR!�`{/k=̦qkA~ƨsQ&�ߏݟywq0a}5gWEZەE�yq${xv{>fӸ?#ل]O^T�>yoVnl/Wڍ�gKj~l_�n endstream endobj 80 0 obj <</Filter[/FlateDecode]/Length 926>>stream +HkqXȅr%→C؈+.FdZT 9'~'O}+"cr(67vw~ C{>}z6eY;Ğ0Gޱgygyzq1��.]v }Ħ? sщ<jN콤ݕ�Gz?W:]k>bSQX|zj%�ｼ0EG7t.c9湑'g&�OJb!k e'ҒZjw'�ϥxs݂cC䛷ݟ�&w|IՖڝ`.c͑x0p-<�:wIvx0,\SbS4l<sʼn>yq}sv�~݋[Z>WK9bSf`} +�d`P;kw2Al +ÿrǙx7߫�1&ᆚ+񜢱bQfyNwiw+�^5#zY݁c{{NP,~�|KUڝbS4⡆'0T߳�.}Խ `\sɷK˴�ٛ5k>vW@>) *w"Wo�]. 흢 6O/oW3{�Lxg펀.)|ilω~hZ^ݽ�goX,xⶢln>)|<zhF٠߿�Gr=',,bSZƩmV�'rwߖ{ hĦ?=+J:{N]b.�?ywk2r�G|`�?Z endstream endobj 81 0 obj <</Filter[/FlateDecode]/Length 1395>>stream +HoLuqra mAģ4GMT梩C?^)  ڂPj<a8w#:15Z""Ii}ؤ{{={G1CZ:eit8��` .9Vh7@,áv CѲi}$sVYr.{]WSVO3k-f ;]$e��-mh]}X?Qs`Nr6GsZvQ0gMѽYm �e{뽲t3R]@DLX`p90sp?җX~�Т?#WRfԕ|"b> pIC |}܏_z4+v59n�zSFgoyw> 1Zmܼ93:vi+95Ys[Ew]�@ OZ,WZe�,qa "p9? +رMV{t#c՞`:+w$E�NORjrEAa #zLKn)rԔ㰘SM2;`|4TZ!6�0F}Z,WvԉY2m9]t3^Dڷm^^>ga|gmbgݍWno�34WWyw;YX'b07 ϔzebż6gMs/֖k)7e:39p��5\XOyw:~7N@D㱴?ž z]>zsO0V}0qk;}�peV]AӰ?Ѳ7hG}3e4:9x1cdr%�@Nfzl>{z` Yy.Yuꓣ벓zTA嬎f=`"˥vw:�w޼Ȩ.yd2vTMjpICkqYH-yϟ߼^�_-/(ɻA}?-/==՝4r!� "ocԓfw}&@XUyqU_k�DBHH=I}ɻA?-CRy~�ߥ�Dr7-zwWza Z +,"erƆ+Ct{�� W:eiHyw4`bόa5l]c{}��VG h)&61S.�_҃JhͽA?-[by~�4 ��'� endstream endobj 82 0 obj <</Filter[/FlateDecode]/Length 972>>stream +HOTwbZcbKiMkt&H78RGouQ /#s)$o/1jLƅ,ayw.S+3/|y3 + 8ᚏ0y>x!y]k[xӷw,z+c�/Y'?޸Ia)dʵ5ّ}� wb؃Al +ٲvÉ=J"��Iznהާ{K;va@64#k +��i,U]%}1{ ?Ma j"Iw.}�@6~2]z3\؉Al +6ri> r;�&[Kw{BNsa')’bs>}f7�L^ݍޗZ؋Al +RT_R7�LC=HKiw, 6\_:о�}<W0K nĦ?K3+֘ωx�H5&Jiw+ 6\[ +^7zZmw� 魫];c w}ީ)hwcX�w&/1.?Ma@K0RW(ooJI=�[jw(Al +Z>ضqO<'ɉ)w�ON_ +a9ULk#9Ɔ/п/�\ivwĦ?mq(`zR;�$4xvgŸĦ?0?Zğ<T!п7�@H=~~ZwdkvW¿Ħ?0Y?/oq<,Ӿ9�@H/m>v`vGĦ?0싆='Y9W�oJFE?Ma`2mi-<ğ<�[ύdQzI)�g endstream endobj 83 0 obj <</Filter[/FlateDecode]/Length 1036>>stream +H_hu߁́t!t'-΋UPDvVͶmc^L-eDk;S;9y6ϱbӵ*"8BOwRT}.)3)C�ͭ8iA9sʘ/ژ8S衣Gڝ{6˹ݿ/z;,ZnX ̏e?_ֿG�oFӑ_J +=݅ bS?TxټS&p<]zbG,Al +~~T%w �]qjwp3)̵On1.ҾO�l䱐vwov7c=R g29/9C.+/Wi `~Sx!k<'+/3])SUd~$x5@I퍞^)Z8VĦ?$/}nfMv�$1~={M^6?Ma h*wo+oȖv@0]:SzyvAl +ATm-w{}v X.2v?Ma S^ZV}�+'76:aT?Ma j1-=>Ⱥ �H',aT?Ma {tDz^ܯRo�D{&.`Ħ?ts-5Lb0%'9�EzAa&] l0:džD۷� }0%vWwAl +XyuMJԿ{�~>9]azGwAl +6YV;cMM8EC>xnlb׆G op˗r;~HKv'l&mcMo!�K{ v +5% ӱTbtL<mqoUc׎m_G0=6ܿ�!B endstream endobj 84 0 obj <</Filter[/FlateDecode]/Length 2541>>stream +H}TS/MNcҭzl'tE!Q Ѐ(ŀ1D $܄RDtJvV]:]ſ׳jmNe79}||u~oQ"UsKPXXRX.6JҢc4WUjU~ޢ~}MZ[2VRp<AQo{%s U@ O0`ybe/<gkUG.[C ytu$zSwGL oa@,O,|(/o 5"tH.o$GI/kзxv'fD`JbE^gͦ2b|XnviCxI +Mx\O@/!2>A̹XU](}w(fpc0 x${bCI&A7ć5=k2jp.Ib*.qk${oӕ; DY;:?o"@J*Qk /|wAפh0`MtRyc +팾'2WJڍkC6AuGNG!{b/-`L*9jhflsrK/q#Ե.[ʝS!7ET^-H)AFǣ?Dnu٠cg L\=4XV],sWsM  񪂹 Ixuª?I*At +zb@ i?<8dӌ'6Zio 1@)eini {j :-kQݒ>;d創7b M姤e0ͪ;BxP0 NЁ0JP2}1li ȓ.Ark +3AHSk7)ydyuuZt̔`@鼧lTZ:i xؽ}1RnTLx1?T?֟MWa\qF2S/tvЧ{_WfRZ[g vJ*]Wdk[ q9)M-2$sNe2+W:=SJ]+;v+J>kHmJ-w;H.v@Gef%X sۜÜնTʜ毿,2)䚘6i[ ]-?Gj#3j`-yKC9\*>X|>mVXBI$]c_f쫓-8-[F{O%}V>C))LCotuo^ Pj<tIl@`RMV�o<CjN)Gz#d7 +b{y L]ПZ%#@=FWp:N߄|轘qp&eX Z +٪i\G(`}ps]M|VgT(2F;~ A]E= }ө+x3?T?ǒE<C/:?:zeVuucvx'@`o~v.TWy=1>N?9)G)'9<͏<_y,]x,`:? +'}V>+^vEa'y_ Btz%>ē%Z^\PO}vjnf!?[s<u=QY㚶+[4%s8Wfws6T)m3= {®x~8R:Lv?�sgEZޛПY)b2Cc[<y BӢ -i#KH5Hk,[^;� >|8`Mso$jfkb̬y:k:̱U,|K4|q -W_Gްk ܌M9}ϹD9)$J`w߷6R +y B3@_6J'yD0` <!*No$ l6?5Ԝq Qƻsw٫uVk_r Hgw7Rpd,ړK"*e0bwV!&;ݫnGvAƇ%oW, y BuBx:x*?T?2BIS嚭Jq\;2Jz_0VyFpkm +Ng\;?rU}qTU=w#@JAQ8P,s/pf RhQKYl,{Fܷ!ȳέ^O>Z"C\`RM\��h endstream endobj 85 0 obj <</Filter[/FlateDecode]/Length 3537>>stream +H{Tw'*تG]{jꪠVGT c" @@m6b !!$$LH2GUUgp[o_tu۹nÎ# + {o~Cv-FRN<0ajbjzDuΝ�-?c0wFSƤ<W2r`DVv;F&帻KpNO8qf37g ߆dE mL^,Y#ҡ{m,kmS EΌ(챞>Io2NTA|~L4yzzF$﵍ N&o"/$AC>C^n$FżGJd^qZ9,ȏ|h{_5M|̍R> ~ ~@ag{ZsGR2G=\[ҽøhkn*e LV%duu4ajkA?Єd?v̈́~y|[hQ GAM4yZO[ZtklU {sUܤ5Drv?{i[y1D8{nFFq̳asɎϦ71b7ND赶;<}#l'Mdy]RȌ *\vܻO ɽ)[n~e(@X~p`\mybe_kWzu:<j  lBC7?qߤ5.U[ +0=) 9lke$hBGD]Kp=~.$f +||c7W1!VoMm=pհҥ/}a)T_t/JU~ntz!HbD7:ʚ^n~aH@�RMGBݶΓI>1RO[(۵F}沕␇ICu_RUТA\?S+ d;E&u\pdh +*O}t>?^v_뀖b=(u"&ⵅ ϸL_wC@⌳ +I|MTkA"?Єd?D<,~8mO9m7&$PY;Yuc3|* TP P aFF-ο?~Ag6 -45 hB2{9qҥCMpi= 7?WC@=@]]2A&$C O%^1iݟoD9 >?I?Єd??D>Jٮv8ɮ/Dy~]kcD!MHAǛy1&ϷS?3Aŏ+A3~nnVkA4!Y{V"V37bJ+sxK|QgklW>Ǔ_S0ɏ37e, m?+ #\r]JO5WD357祐|hB@i %0TW_S+uɋ|Qgkl}'%&J;e/15=hl7T]I8ȴVGRF3u"<(9ZCMH#89Rra_Qϧ,kM\dATYsǝW')MD'm&C{|滶D@Tt;eZ> UCa~Uc}{۴DPuF*^A +3J'/5@&$ DQLieo~4%;(um=bnw_1jiw }TɤZzcs.Co{I~^F|czF$t)Z)U2\7ToNV4b^')"]]N򊎶p&vbYpEoX},•!LgזȂk +¹fuxK%:e"Y^ jLf N%-e+xޅ`+ #@o½ν.9'(']J鍮ccD.]ůahB@Я*\B|daLz4Z(F?ݶu_ǦǍ*O{瓨+| ljkJ =w\u_" +Q+U[7fA_=FxeE>-X�fu|vIOgȫr&)׮Ȏ>U:\%m28p,y,Lp3FE^N5.}uge)pV0yɳv|<cCnf=LKE8-pT'$h ?{Yw3υolvxN&c"{d;!Of"P MCMVFq3x,-K?^[" ߽} D7=6ʴVmBپ%Yq }>彝rI5 aiK6}c�=5Q}CpC*w}-{/(8o]ID_꥗^B43DAf!ẫ!yuoiGggW,˃QAX^@90vQ_Eρ9 ީLy_kpV 7\Q>7</nsخv!jHumouM&&B潻 Yw^LLLG?I#B"g!Sҏ*Jg[tr>Β8FZ<MG\}z=O tvQ}}!s5c=jglw QfЂ -?Ym9em5ʽc'26='ø}RTZK~'>?"ΝLLЏR_?~Gv~[I1mu4\m+>31,L #+XG$e5u魆׉yA\b S[t!3q<BXoVY a4G? CX3ni<# Uݷ[ 08ᜣ}0Jأ s_m- X juJigx;gh+j f&换~e}B߭1{ЇfnHQ`bbN!12ҏo \zmoPr/j W +L .e懂1'٘ }E[ܗ\X͕֢C-6\RN㾣:G47}<p-jl?�ٟ]d?c|trZջOmGc9v{9c-NU;2w远cpk'�]+< endstream endobj 86 0 obj <</Filter[/FlateDecode]/Length 2288>>stream +H{PTZ56i.4NlLb&ޓJj E""r rvᜅ]b$Ӛ(v2ӿi_= lA3=~9>O"t#Jҟ<T}#%t =Cע߭6d|4e6 Os^K?Z/7U'ڮ9#DžA+niWqOuGy| i8&{:yF4ON=˨w#n<_5ksYv4*χB[Y,Fj|2<gHw\v{S8 )]坝ehTﭩsY.z $^^(c|0Agro.z7= [0?2ԲZO_uΪ}G\L9H #l{ho:ǵOzθܼyGl#?:?U.:,nͱ ||?::7rQ?=?]K 4 mz:ջYD?@OAoНhBCS[ѱiڍMx`⼂~`:v=o>E>k_fv裋=6RӦS.c۾#UXcˮ-RYqwJ7 ƠWЗt0yl>Tq.yX9tWl{%l3[{sGMŏ̔2UxW }+@Gt}=pB:D1"ի' E$GK*ۅw}EtG>y6OUb}fMDo~9kZ +\WZwρ}7gv X]f9nhJUGbEu&1'|!qtg[yt~Sh^quXUA+ۭtRE7m1la/d_,%拣v?Dk5 =E P#}=9~`0ޗ8K +݃[lYM/? +c Ӓ:PX'њ&"Pǰi%pW=]Q&)U3K<sFK r\xk-gl.t@7Џh B"PGO04vc.YU-o%~_XU/%c۠| +zYBȷcԻxk{UʼCP/$hxU_?]3O|KāCt}@'J;?z?/FJƚlѸz01G|/Lz깚85%+ $|7?z +Bǘf4A{P[Zޘ;P¼ZQ ,:EBH@S_&/2]T/|5*R|LwhD]Q_9S5G^?z +Bϫ~Ukވw*_jm^\.w&wE!+EAF70&ԖgoR_g K;М5q uD=f-}!: ZFtZK>}ɤ85霃8zn<Q!=COAAHe%ji|L\aXCDPuA}P'R!g`)?!O~]2X2n߃&UxT\TR=x_y~:>u@=PuB?z +BH,{_˜UW5Z.z?ZLk\ -{FGw?K5hmBBSB:YjIj|߈\ezD^_Fޑ GzXNNQ]I5I/TS5 Ϊi0=?!]1hE4;o͐\Wv|1O9<9I|AZ"m9E~g&<0peBFOk'o+31zO$w\eq^wDw!N6LZQ"wEWq^ŷj?v>d "'&~yC*L'*S1p�iȠA7~GN!u? +68G_�W endstream endobj 87 0 obj <</Filter[/FlateDecode]/Length 2331>>stream +H{PSW /`T: +tfd ҊeA4u**<lELyB / VSݶtY?׾K&Er|'{;{2V%بKeشv& +8WKO?K,W|ϨȠI;ͭ +{^Zb%sEyyyys!{gڧ{m�8$ c aF襢+' oޯ?.}?<G- خj]]SsגEGpn҃ ֖L4Eqxi4~ngyǞ'G\ƳLM %rY"x_sc_ƳozkIhR r'{5t熙i4qi4~> =]cL?}H>EMUYvt_3k.zNJeObKWNmzI}wCdݫ2&Os}(N궎C%_:,Z\#}1t}F�3E$NK1U؟E}Qav}o5_8 sr%IlWQ?2Cvԩ;1 5_y\n]hG㓌o~wJ3dNt=]}cb֠:+eG[+R4 c>#mKǧ+C쮟*Xőv}N5..v5i;[3dEQ}#> chf>>E�pĒ`zt4G\ؒmLM %rYrSw3WAA�pS__6hԍV( +.XA{G]4%ċ#٦  9&ڧ~m�82TC~"㶂,]5Ye������ܘsAg^u.K7^KǤEY ڑNyk?;)t������AӘtlύ3SsC;ԟ]9sjH䊲���������������������x (ԬS #-U1. ?]Hjy7?~lԏLܵ!L+oΕUo_4KOHTX8+-xCPq샏mQTbݹ= [k\֫n3s?ӫO&l;sAn+l"xf3;mmb$s1ՕV( +9W@{x~,Yfyj ҷ6Y^ =MJ}, wR &+`z&ݬS _9}*,O )Ҿ +<v_~")jq{EY'26ֿC6c~A~sm^ø=H\Vw$5olZsW 5w5RD<>O!:|(& +YZ!WfP `,|߼nǵ{wVvFoe0Ӎvo+ؠQYEvk<]M7z1<]kCŶYQ6Kuz`XǞSP]|bgcѧSFkmvuGS!M::Ncx?W'cy x/0Ak4]*:r5Bϟv~`L݂1,h}TlwDг2R+<KCFVQO*la֪>Jk;<,( Z̊'#벺R1}qbYIvיJ:Z' +k7h'=džiV1$rĶ}]*sP7[(XsSw]SU\JS(t/Pƫ1?-L>~/#EMUJc9oxk$z,^iw-':հOJz:-/cWj6v://O|j9x=jeJm{u\WfGMdk.J$K:ڐPo|ejn(c~zecɗ(߫X`^'r<66gTX)8\0K<,CcIt+J}5mUupouQ(ށBwh/ګn3j=nD+qO +0�~a endstream endobj 88 0 obj <</Filter[/FlateDecode]/Length 1095>>stream +HOe/$4T.6`@ɉX RbvR` "H\~8M*Wh Sxg;χ>g<ϣSx/-5M ]yd~Xmada:e]>Sc$ΆڼkvcjŸxS'jȮ;=u<zw<$|7p3meG\=w/KUr" ߨt*Nzg6Re`˦j 6J !ʕ~* 1Zg$?.4}6VA'kaAU&5ƊrLĭ~Vb=qY̰f7v«SCˮƺ'C̕QW[t݋zn5xͻwDyxi;n9ED+p yNgM;`ic%Eθ903/ _swRSGu(M]5Œke +zQ-xjHA1h}@ھN�qyKzN({j 0֬Eo}VcUߤOĨ1V[5U \WrXS6Ko"}"M2VL5O*#؇Ng7XU[G^G8>[Cꨮ9|D:&PKzWc]<wu\҇mXG'wsC`W;MQ7e!2U<1;{ksJ,mj^ \Gw=;;j=W07zGOn0n{xktݓs,a Mf xiJyEq6cgOYKS 1ʥ֦]`C;F 2ģ8}ܨV>+Y׷[21"dZj �����������������������������������������������������������������������6U endstream endobj 89 0 obj <</Filter[/FlateDecode]/Length 491>>stream +HMKTahm-*pk +2PA}L{#l%fHmDA,ZXnќ`p&8}y1&¼hN  /g:<gF:&=߻WUxWUsZA*ׇ3޽}ŅGK=+;]%ݏZU%<9>硟kjX'KօKo}·Y|2΃q?`3SSm;,v6?<{~w9g8rOyp W߳d9'<+}F#pd9'<}H� m5"g�׈D�f_#}�H}H� m5"g�׈D�f_#}�H}H� m5"g�׈D�f_#no֫> +��=Iժ�iDݭ�i_ �GB  endstream endobj 90 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 91 0 obj <</Filter[/FlateDecode]/Length 168>>stream +H1 + @Q锶Cpj*9!l �����������������������������������������������������`qq~)i@C"0W4#}ߩ])ԮUjWJ(d7}.e}lq/T`� endstream endobj 92 0 obj <</Filter[/FlateDecode]/Length 530>>stream +HJPEO?Ql,-*x5rZx{MW_G=5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[[ԺLS>2ELmu "}dXZ)bi1c[7$&nIlMؚ9&h#F}dm=#SƺL;7C>2ELk=>%&nIlMu=/?qh7_''9&5qsLbk1cZ;BsZ[G9uǴSZ{}dZ>fv}d u{U5(=(a}d4pFGFFL9:"25rtDdj\Y:4su<fix-sv4hhhѠACCgGݱcQ;SwǢvELRGfdgfo �a endstream endobj 93 0 obj <</Filter[/FlateDecode]/Length 677>>stream +H n@Q 1lF!k;Sz0VM ?^̰;3"l^.ʸ2஌{8+^.6� |(#. +< |#.ȷ1b o|Nj�=1"@O }Q6z: ;Wz*%q$+>'D4"tZ:>8ꋽ: +ԡػ<ݡлrA$DMgУFzBjw'DMW?󰄐УڟzBhQGM}^I:iŨIEŨIEŨIjT/kQY5^ *,GuQ=VڞzT+mO= US\**W:yk+R5]T%pLI8$U uI5ؤ[hEB"T!rJ#Q****^V RhV XKk(Kkhbgbgbg4+:+-{Z?律?o&T,!Ӯ=/]|'yG/Ls}Or`7ɮqXdԇT셠gqsc~ ?_ غTfH?!�=EW endstream endobj 94 0 obj <</Filter[/FlateDecode]/Length 937>>stream +HKv*A Ӽy4 vɖҝ1i˟L-c/Vױ1~&̺ JFOƜmDndRxI;$`4f3u&!w4b1A)/G8?bgkVw& !/b<ķ/g34Z}m=&;uE[0}$ٕz-Y~Mfb 5Z>2CHUpHj#auJdSi"CRjSD\{LkSUiH cOI(L'+B˪RJd{Mg[Ij<NQY:G9F1,}aS4w:'0d +3Xƀz;bC%hCo5;B}c RׅA^|+W[lvM>vI/Cv-y1 3l&^ ikemٴaᴻV�f eʋE aн1]ic0Ւ2\^h0΅} GZ;^gH<r|, +z[^f`"a@πb&z+":{2<[QlӈRV@Tt5d%NES]C +Y K5U-_)ceTEMOۘ*VHP`~7UA}jX-(qT +=M*X9晈B5sXGYŝ>o-8W" nMDZi븏[#цkgo[QW;֩F{et!@�֨<tZwZ0GY}ϻ}ϻ}R֠lK'}›1٦A9cMiVg1&{`ٟvm{2e~{`f[a{{`f[a{{``�,@�, endstream endobj 95 0 obj <</Filter[/FlateDecode]/Length 590>>stream +HAJCQQ"D"SJdɥ7˧<,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t>/ +ZKfRzٟ+.h} ?~6<tsW7>wݭT?pw+7UOЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XW�L endstream endobj 96 0 obj <</Filter[/FlateDecode]/Length 604>>stream +HAjAQmdP-W1xI<O=:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуESٹ"Æ8]+6lW+Uϕ_ɻ:O%NJTrrq[ľW G(;x}¾+O#6+GH#o8]+6lwKٹ"?B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t7SѵbÖ<+o[�u endstream endobj 97 0 obj <</Filter[/FlateDecode]/Length 783>>stream +HnPDaKVu &o{~$i,1c\r}۪t`6uIC�'W%R7EROܭJX<plGO҇wnu}zx ?ߖ]ἔUɰ9Mٸ-OЁ) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`Byݦ\T + vMٸrN mxexpixqpjxAZo?%}u 8uS҇Qp˜cxe̟C~׿dtއ$IZ#&lKޮo5ݏei26}i~x]iۿy9~ 5u<)9`2m5.4&kcǠj?xǫth~;2@&>b1:OBq\Es.]#�Jb endstream endobj 98 0 obj <</Filter[/FlateDecode]/Length 489>>stream +Hk@?ܛڤ?V|խSlMCd΂vULۭFJ {h{M..G66Vvl~`_Bz~}Y|^J#RJ.[٨KbD_l9Jl޼CosM"#RUs*eN]rˮ������������������������������xd*E7IuRlO`%3tjfVfBz:Gaswzr5ɧ]Ӣ3μ;6w׃uq=oOΚM~i5Yr+d*I`M%BVZŹUoתYQVC;B+v}k[fZʊfs)Tf5M'q'Ԟ׋i$'e/-����������������������������'~ 0�<qR endstream endobj 99 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 100 0 obj <</Filter[/FlateDecode]/Length 453>>stream +H׿KUqum~X AK. 4fk9٠6)$M`hQ*N5w/ýw:>yeYn\X_?7ʞ� ]㞿,-l-}=��?qϯFFj?jg˞�H|zoumygf|rٛ��O{>?��Ң?=�>5��ix?Q�"��iD?��Ҧ?D��M��H f131vetpZ,��"iSWvT*%,� @EEv޷ �\58nZs}n�` VN/� ?=}>oz=}e��sϣC뫿kN � vZ;W~=xQ4��2A,sɮbDO�` endstream endobj 101 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 102 0 obj <</Filter[/FlateDecode]/Length 711>>stream +HKQcs@(/:maAeEIP6^P6"%3 +[CBAbږsCJLbig(brdGx>��������r lvgn����BIMo,NOt8_+rF ~����uq8tK<:n[����f5l&_r~./7E����T2ןsEcldg~����L.ebw=5CG2 7>����LF~rޱG4����YJ&qv~_+͞b*+*Dw% B!X,rN�H!#N׶j]bd/I!B9V9̟9^l]}a\l)z! +';r7jL3Ƥ:9Mkrn[U]3^?yܴ|&n^˦߻=Ӳ_-9 ,j>jR̼zaћ7c[[<:&Y|G@Gy[26Mo,߅]ݡL}XY}Xgzz`g}t0j>jR̼���Ƽ���Ƽ���Ƽ��w� ̮ endstream endobj 103 0 obj <</Filter[/FlateDecode]/Length 330>>stream +H1.DQ BhVL2�BB/T:#؁]%/ſ8_^[o&o?u �{L� 63�@l52g�kdb��Ğ�bs=�^#V��A&eR��0OI?~ ��=Ͼ�A&ev^_~��_2){> ?+�@ ^4i_F�'A&= � #A�� ۛ{,�@lL�@lL�@lL�@lLy 0�-8 endstream endobj 104 0 obj <</Filter[/FlateDecode]/Length 1062>>stream +HoSeʲ05qITf(cSq:t%X҉[1fFFeBD*RM{4v$W}v_s_��Я_n[�ysy��(^0_<}z*l ���)019|՟w~+XVag���o+g<iTGMϾl;*l ���_4zy1?}$<Um�� fwiL~zw���31r"^m�� fb<vXg ���y.[F{_n ���y~bCv��L03��@q̂��-M`���ōf6<3+Clޢݟ 48a%YN ۧݒ7'ϥrV~mӫ#<ؿ0\rg۹O$G5+o}*g=v$W=/1=6Vnϕ{tPCcҫ#468q+FP~DaURuPu{7^3oڧ[ʝ:;NZw 3qun&BSv#Hʼn vh?DoGE旳L,&GKP>cbr%vDns:$wpm\~3W{cr<ɌcI2ҜJdڵg$8,qI<# K#5Zܲ̈{Òm]:zָ֫@-4(שּׂ2tzC!ua;AAԑQo; `݃NX-wÜ=*: 7ܚ*)|D ޣ\_SYw. loq$eegH 3_}Wǥ Ro:FE���[k03��@q_p��̄ ��P`&g� � endstream endobj 105 0 obj <</Filter[/FlateDecode]/Length 707>>stream +HKaG EEݧQҁ찅tB%u'5mΣ,IAMAwzЖ]w~<=pPK'+`d;:< +} ��`l5Κ-b.[���E^>hI<?���̋;(Ӊ��k0|L���07&c펕{��`TsMF?nI=���y F^t$l��k0]usrvo.VVJ*}>u`2xU-u'���/f20cG,^XK޻wݧG7ܮ���\Nh8|bݚ ™=,_OP��x=fLbUȦ_K9���iů{\vG '��Fj*+WVP?/=���:/]J +G3xNy���JTȦ^G��@^&9P#0[Kǿ=���d>9PcxnڬH���ȩvKUq+=%]W\z���!l2<' +?ڞK'!g��#ogr9P5[76Mdbl ��tꝦ endstream endobj 106 0 obj <</Filter[/FlateDecode]/Length 729>>stream +HMKTQƇZSi. +B{ ѢlE7a0>D1l596VH%^G`fV-/���U}vRk[OC3T7Y~s=T7��@gG01!onQ}��,k?jN>W}��^6]vs~N)|G|(cQ}��k!(wYX?[)I}U}��ɶ\2+TG[~Tt��0-=n*cxeMp:4���#褲?nG6 ��Dr]tS^㻇86���+]F@7!{+շ��(ڹd6?j=T}��v}(,ݧ?j1hw]m��0_r=F@G;_z7T}��IOZ#XQh =V ��xM0C@KC>VㇼS}��Iɽ]F@'#Y{G��0_]V$ _T}"��tvvYr ]kч''U��`7SS-r]  c=bw ��L}Vg1.e~�? �ZŸ endstream endobj 107 0 obj <</Filter[/FlateDecode]/Length 1033>>stream +H]hUv :uڹZ@ѕ::f9-MFmgG2%MڽĤK=Y2bU|m)^d0\DOsxxO)�HFC_%7nQW-NY޻F&XugLʊ=#��@! zdKK]ժպ��0ڕLb_,S(w6߽s��0;6۝&?ժ:89��Lfh; -ezd44{N���[Ow`<FI`φ{N���Ij <I}-+=*��t{ױe:Kt +��`VGUMd1LoUWÃg��0Q|YdzqGCu +��`h;BKOݳ��h.g]܏?Pr[dOmUq��ht{~3 uy��L~yysɥz?>'B=[ܮ5u��$GI\%r&ɵ{>"ٱ\Et��W$?%C$WIJx?P(r뱔ۤ&]��]&_SJr)+C\Gv;ݦNˣ=_}�� II:Ks, +EԶ1 +_J"���X$/M$GI}ZUIf0Lk:9(BwW>��BֿJr+(YL9Kf`,DoSGGK>V.+ݿ]#{g3~V.7<:)��@~yj]M:o(:GM'|{Nѐ0 ~f٫_c%cl/�i endstream endobj 108 0 obj <</Filter[/FlateDecode]/Length 1703>>stream +HkLSwut:MY(4K/07ԺMQ +Na:UQR,Z+() +2P2_*cDaqӎS)ԶtO򼡧%&܉?r}`&(}&i_1V) gź=W c����b1Njޞ@b3^`ikm�bY蕿Ou<5s9eĈڛ?١1I/+HiQ���^D2Ǣ/Kr?` a�orP~}2>wd Rԗ|>���XKC:ک!W"mgAPzsE^sGzsR1JԬSyg+o���P]Щn]ۼ:ɶ*tF-ֆ/M.Z,# Owl~9c֓òO����O9,jUDC=b'b�o1^2Uwvۻ# 6*v~2v���_!Ki/QGQOm.Lae%lZG?uzhڬkCy]I]a����!2:omV&诹Ѿ?2qE^q^b3e,H{yVfaf<m|bM'tKUmfŹ���<!7ku&Ni+zʶl: x~}2./'B7ÏGTN/4sxD|H\fu~o���<CO.Q>QqŲ/^i?29mCO⍟1iUY_r_L|=%b2ϩ ���pQb$6nԫ+S?7;Iuriؗvtg{>l#:cŌegy>"��� QPPPQs^SQ"G x"]߅F{?h6OBS(:gUrƌy���� +uNV@1uӦɎ6&=?6b9"4W9oo[#q���8StuN3(j!jx}IQrAIB$+4* Ʒs���"jzkTJ&Xpka�o曼qO!t +k 5���z$dtF]Z=ZC$I_%nka�owLv"紏ί>ʅ=%p~��� +ie3PTgkwA%�?hąfYpsZG'TGw���8d�kǖ#5BC=D]D}DԓYʬ[//:42yٙ +|~����]BRQV4\-nKSV13<i/?RjLǬJ1���]+eJy~)sy+c^(ŐL(3շ嵅f&,ܬ~}Q����t:ŐbP1o7?VuW9{Y(2~ͺ.^)K s��K�u(Hl endstream endobj 109 0 obj <</Filter[/FlateDecode]/Length 1720>>stream +HyLw\2e1Y:DmfxLaf9 c\D@@Q<P94C7<toE7Dcܜ?ׯ <+'}ڟ5/c�`)Ut'2vl}uh= Kpv,1Sk0l=3}-uGh2Wi9 i`)^b���zS\li{2T+-U?x3*UYD_iG#=&fg���@2ܨOzJ'ښju{56|4 wk9Оo];uz/1a6b ���b#lK0c ?tSa�kAY?T){縚 ƞ64/h���(K}baswC)`M?\c1EHgҔ3fh[Lm>"���xE99=;C UK闋m;=?�&ȶ aIc%l4׵Җ���}9Ӫ~m^{xs#=kՇN⫥5bp[NsۏZ3 +͹=%%+޺g���V5gg&ݻ3 CUՑ +#]f1u�ӄ?hRs{ꥃӒ zSio)dusg}d���`%zUJ;oLPP$+ ⳣ5j9i9uE`Zl{K`g'��Kj +k_*rmBӯ[)ʹp +X*I~fI8C΍ +i͇^S>>���xɄի/VK: +Ǎ K]s;JwCa�k"whz}PEbk$nxVc��++B-Y[Hn4� 8F1ye8F_'f7r?NJ|<'}���&0ի/%:$AKƞ1vn䚏y'`m?hT{ƵKA(+c���^>3uc"4,:G?;)XB{>RzE_߼:jG ���"7ƍgl}wnt4ӑK=C]`p?hRKrnUe 34֫g䲓_|2_���ڲh-'Z-ULqX7_cRB&b>˟=%r%>6ngh$xMxKc���-`u +Y]p.t*AӯlHY&H7a�k#A_]RtFI0? .gd]_x..b7���XشoEI3O;i FMMcM?%8s{d2rSV]q5v66b;��� +;1gs_ʲ'bKHN?�F1ڏWNF1Cs ޙ +@b=��� Qw+GjZ*﫦9Bo �C#A#1l}za~3h{ҖBy_&O[ ���LnNNL]o 9W!\CPsm'�6 endstream endobj 110 0 obj <</Filter[/FlateDecode]/Length 1986>>stream +HLȜRZZk5*X�Rk7*" +V)J@~}9Ţ;@&fJ:~dc,kt!kmx>HO'dK챴 ȑL΅9*!DC%-$oc���X`!5-/]:pXopl-=6NIt!]Dm4b���{k;PFw)WĊK??=yGNM pG^3xi���k;U|*wְg*_w|WvDgx6-] ͤ1O8P {L���<ϙK &i^/u85+JDu%Ja+x' 7+~&9[.gyP Ҍo���q^ WS- uxa�xxΰLDZ=B9hw[TL���<Jr9H[nohNwcqtZ%HHO6UN9[ϙ0mW{9 +c��py>3D^^, p?ZLdOY/>oL=k2P"U_?.S=1k��pYEYϯ4'�c+@pO0>edi7#ϛ4o#f.JگgX²@G��g+JsLntэ;p%δ̈sgm_&z|7Z]_l3Tvs���0(r^ +F@Lԓ7TfcDw$JiVZM/EϜ]D1Am5n~ou%qӧN}���N+虥Tbk#_yH{fRVF?8Q<}'f;KUѵBo{!)Y X]Q^l˫I)>V���͢;|U#W1'�7~wMݍqc 9욹,z| x2K]Z_df,nj��GR.Mk׹9y,DI3z~K#Ro[ +GF?8٦ ?Ӡ-I1o!6#m^?);&2��0d?As;v 7p}Dt'(|scS\/HbJJ7[��_.]FCkF I3Ԝ ~C|}Dt'^}qxQ^z4m&h4Wy>~1YG��x(52JvNSZגW7dX쩍>lwX%EapUκ,L ggBY4^~G_S~1rOR���|gRs-|Gt&%2Rc+JH[CDw!જuN[%]o:h<SBt1hBfI>ǻ?NK+���?V>Ey1s*4<tS:Fki;,2ڳkN^sɨ~Ps3μAm=&*uDw̯>qt%QW/S: ��pO͝G.Є;'*|Ew 0YT~E}{W(YMZ䞟qsJj3U^=&:D8ͤ=oo��Rivf/ +WNto;S%>?`X`!{|cgJVx}*JygHD#ֵ %]ՠ JL/�8ҿ�x endstream endobj 111 0 obj <</Filter[/FlateDecode]/Length 574>>stream +HMKTacDY7- E9ɭBԴpS"-heZƢЦvAhdbs.x ⹣*DWH: �ܱi��ٽk�64<ZP3tNe:[%r!rȑ3űY̕;e7g*Gg!r!r$5iQm��߲&� l5<�;Fg�H �6Iqc]iV_7� l5` ѻϥI��H.I0rjKC�䲯lS~j�l5Bp!~��$}u׾->XYY��H6;Lql+?��;F.f^�l5BTm{i.'vظ9Z8D/ܿ2=Z?d~8oFGcnz[.C�W-=M 4G=bǙÙڵb? �@y=@�!E endstream endobj 112 0 obj <</Filter[/FlateDecode]/Length 2488>>stream +H{PT] 6D)LUlB;IEX)B bFH rg;rxפ*$Ǝiݗ[ui<pf} = +Rvj=幗,0z{͝%r%Di +7g훉ĿIs^ S ׾6#9yƹfI!@sVuV -koKU 7r*)E-Afpk^R&}o*6߅c|ޤ)W^:P :dDHs˰_yxN*4?iۣX;K_uAs1ag@D~S h9q~wX !:P DPVv_G:'Zo~ڣXzm{*]:PAN[$ޢzoܫ:V[u6ܝyAjFy2mN7tNGqB—obSTp17&s3Eh0 B5g.|=A-k=2o,'4OY!4*d/?w=?}#JpSG +%�]ώF7jԽxA!NaajyrmeE7ZFg/:nb`uBCy2RV$emsGN&LSqYޞZN#fW3�i-Ɵ{9#yoJD>wAa;qDo2(<T5ԱMe[`8İ8 ˙ sBHs^ S ׾6#{?d{)N4u`Ys<}{x5~'mR~A !AL j9݁ Q}9]~G<q_SœF7:ѿ;hgb1Teeyى:':U.7ڳY^�#.Wfw֗;3jb7f Qg9zJ@z[)wKW8p~ DFT:P Lg<yNs,6.OvY3BӢ'XT(`-4Ei{|A?SXiNk5^- 9WL +dw><cvSwMbmBX,ujy{F}&?-g?CWAYeͺY{$u�_r2]_I_&FFc3A3!n[ee~vλ9ս|Pмr3"D]9ժ*Wvb`m*8/q>s'K*�x1j<-=~t5`ajz4 I;vLUѣ8ŝΏk|! ~܄7Xg!"a-xa�k^9�AQ3> 1%0>9^%ыϗIzڱ _~_=lO,aLC0D?P婿9@>6Tfn壶]Sv$Fb1%W486V+Cm-+rڟ fƛ07`~U:P hɰ<C^6Uڔ3]D#ybEY.A`8 "7WNBomC!>_1 0g,C0T?P\v$_)ag]^�M<i{6gA-k9m`=1&{,`HFNuo3*'kH0/ބҜHao484CRB,yemg ísb=Az [85Ňw/oݟܯp2ie""aˋK15Cf<ճYj׊>;~w/A`fl kV@j:ez- U,\޷ U0/-e](+|oNЅ]Կkw. `Ÿq7A'̵mF5޵SmOWwۂƗ?�Uiw(+مayjUfko#(ܹ{q.9j=OF K0Y g"8̲-oQޑo%ŝmMŨŖ !�^=Td_6 z@p#FP4Qͥg}87?h{ܶ`5+]`?  fsYNRK,;ר {N}Mɲ'Z+},պl2u0/,?`�%m endstream endobj 113 0 obj <</Filter[/FlateDecode]/Length 3212>>stream +HyPg zBW  + P!U(R!! r(#ZtE\k*Jv<PVWb|f>3 $<o//惜,96Mg5m +jw}-�o'��{Im𣲼8$$r,b }g0 0ttbtt%KdH^۳}@ +nS0[@X\ \ߣ_oWCReDx3˫r(a0o;?_Ԝ0{jr^�z,\=)sLfcw,եz0(F;6B8Nl%h 햟U)aP_ɬ3u" &#ms+*`0hK` դff6ջz-8Г7fLuwO7I +;e!ʹrOOp +Yc`~ `splQFY'r2<]TR}f]vm,z[ș}}oaJIQ' Tg?0a 2R|ʓ}};��Z�tqI?4{Zy_?MHag5?/dٓk09   +4kb ++�\uBr* Ց3TsN1)$nûmz\Oꌂ ?fg=4ꝇ^ dzV*v. + +%K*o FfSUpOewqX,fρcR=:fL1+{vZĬՒLVP[#g3[% lu[SŚ iƠ8PLB#53 +/hS@F2EÎ^�e{�Bh["U,Y=)yj~._Nb5p +-@OQ`F=ƆFx\[wg[ώfͬҼv_>9r,�<'vtKԑQTg?0Ѷ$*T>~ 6tU޽ q%WGaubnM97Tᙤ%1Nsv;�4I`P=k&9̀�㌘ݕMh➑RO|{x|<N\ь^޼1_�m~`nm.2Rkqt' y %9rRԅoRN�#nO'- [=6 o+ͻY/tB%#y5<<?)dٓ:9"|,t#د]>X +̅Sƌzm` :`6i +?k6^dKxoN K?.(Ȕ}"ڒ(JɉvFBU꫏+Tlv_/~Wdۑh-��<'g +4S%9Tg?0.ƃيl(uh +� 0UlzF' sBO[uIe9HQ y{e)kE啼,vi6;BJ%}26c OE`x|[J7;{jmvkFUǥjNXɠM7wMLa$dc0CGg(b,9獞;zs@<C}}V6+:ꎍ]~ʈ 0N9b� ;;٫,'#(;N̕ʋdk+&'Cmw<Udv42]9CwgEwߵ<@u&ymR.A¿u~b/k�;@^�A�\;m0_2~<k5_O 6TsD=f-$o-)ݲT +NkK 2ʒ6/cw +#Yxu#9Q4YFӓ +JkyD W(Jr +4)|A\N9.'<?Yώ)cGk1M:z6+=T,d�z+H/HއDu0wȴdw$?5y7? ߏKk {DMf}lv(ۣBst QGgD21V^\('x2׮yf_>)'7@ +o)$Te9kR>݅h*[Gl@繏*O`m,p9`�p(Yb_V59EuhkKCzTecB.'udXĊ @3+(PB҂" 1-4 +40JӦ6iL4sn +CRKzG]_['x!{ΫMEcX81]8w1,SX:O\[owzwilӲ[Tn}Rp2wݻ6ۣ`ߛhl 4| ͻۧڏMwF3@t"pF4H !B1Г6kH +yYV(-&e`LSU)#AқHflj4kcRbJ~_ϑ>_Nn 13ѳNDҳZY|~q- Ek7Enh{>}m +v.0ZL{;Tщ{M+aʵ=$[߃8K_�oߛn?@{A@cce>VvW> ��ߠ{�޳{$z:Zpy���5zWF~LqA=ejT_<,1>��zKMM?A=Xzn3U+s���lU<x+χ ^7^l���x+5=gY8?�q#l#���XWiFHKgY<?<2쉦z`\_���{~3,G$0T\pk2s���u߳ +g YZxgE0٘���0ru2 Krf|Cy �`�b + endstream endobj 114 0 obj <</Filter[/FlateDecode]/Length 1037>>stream +H[luDW8DhbDpPW.C԰ ͜Apa*.dDX׮owa8 qT\1 aL@1B"ȝ>,lbK>7[z6oC�s2ty[lgܓ櫹B&z=YkmbjrU3��W^_HƠ2ةC5uXn�7Z>X}[?I.vOWg}ϩ=;�@j-q>}[?I.v*ZW ҟ�� 9;VenMA $رŚG\>O{�*/{kBy;C%o��c#{+?}K?I-vo\uէg)��[߾wԾ%;xb`w8p[?O�d_wG.h!ǮCڐ%~؋93��f˿0Yz?|i Dx *��ioAHs+v=&G|Il��ût+*?|Tv^?|S kV��p?o1=Qyײo!C}]-)3�� {4o颪MSo!4wYޟg,��T纸uB@ $?=\ >=g�k [Aȃ cRŃjiZ��0H?fuɞ־ K_w-Z llF㞕wqI��v}gid<[?e'K.~hGY- M33:d]&&bԞ��]"^^>-YFF 1s<Ul8k?}xdh]��jfnƿɁsoA&R7[|􏡲J`/^}F{�`W}=X0vo�e endstream endobj 115 0 obj <</Filter[/FlateDecode]/Length 1165>>stream +HOu:r6AzU[eMlcD`]MQ`Br9GtL@G\A7u?Y= wRdp׆N;O\]zX{&UԴQNFUK +��<@c_/{iZ,߉1s*WD?yK }V[ �b3je\X&0 yqd橈S+vVfes�Cw.ge-`&)ۨ{1ZׯYz<mnj13F.]��,>ҷ?B'#5MouI,lfz:{TPr8϶?כ I} nnUŋc��n1yܿAdN3&-y +v=𪘞?v6VdJ&94  Kd��n4r$8cL)+Fib$,]|SY1?Gٞ9g^ �]=ޕfD f7ˉ׎-[}1-*i v&$=�ԄvH]oFbƄ֯Dva+o$Ow3��vs#o2Wu7+S[YU;Hm�n.!owY?BMI󁜈31X��Pu5gfF v +#6)e3{g5��v1]EWgw?B]2[��Xh] Y%͎AGK >'=�kcѧ7;Ss֗eCs��?bG v +cnJ6րq廮ҳ��sTUnb?;I��X͝dG_Snb?.qf +/wi&?� +7/N|nb?gG{)_)=�=wKr+;1? %e<�{XޣһJNߋI g:`A +0�CD endstream endobj 116 0 obj <</Filter[/FlateDecode]/Length 905>>stream +HKTqSBhaV(t!\4bj! *oE,`ZoPu&+lJMPJ_xμs~}?μ<VKep,/[Bge,Zlw,߳|ڿ jm3`wkݡ�HVғҗ}w;Ĥ?'Y~?.׾��$_yҗ. b79cm�d#NAL +c2gN2o<��fbhS}A &kbv8ޱS�,]#~JAL +kϓO kz��Has]dbR޹h7Ɯ��m҇ҋέ:1)dmv7��mώ^~cVeWc?>��Zڑhcv7AL +[Ks۟Kʵo?��Z~>^f?Iaxlfuw?��&'=x&ҰWM &ὅ'Yȇ;��D6|;_p"GM &Ᏺڍ~��(C%%WV&aǼl&>PsO ��H1TN?&aOQK2׎~��MNS6_XaOڡVsdv'��W{sOM &= }:+Ӵ{��|Y&}"]{M &ԢuVS{c}u~?��5>=56_9"ok0/C#��ēs.ݹbHcv8ޥ��xEzMvך̰G�mv endstream endobj 117 0 obj <</Filter[/FlateDecode]/Length 1014>>stream +H]hu&M0r^tS IԍB葬nDJ)X 5<](K=Jly?i56ẩ0pU+T:s~^]{J1 j܋_s?XV$3ٙ-J�`l`[Usҭ5~~1Vȟ`yN^��pw] +tcMLGoܪR{鷩Nf��pV|b oҍ53iu rs/O��kQ)ݳCjfҸ?j8y\t;��];Fs=im%ڀ4|xڋg.t/��n~;w>&T[p0{US�[tSmLM/'(��rUW- 3i2Vkԩ_ ��7{u.勁ЀtKmLW?[m(��n揉t^.چ4Y_{؛]�Fttz>n?IU\WL`t[��l`UU[3i ?湋C;�w[] +t3mL[Uʋ-\ n ��[h9;{%L[q0QڟO{f��pwBf_osҭ+u}R|YoQ*O9ҭ�ݧ^o͸?XoӆGUs/%b?[ǚʙ+{�PMRJFڎZOmƸ?jrzgm�+Rgg>I7vkJRs(>ϴS?J�`LۺGKm+]VF!_3Gq +&.}�>zb0pB]GzGV3Gqzh5|+ /� endstream endobj 118 0 obj <</Filter[/FlateDecode]/Length 1151>>stream +H_Le0QK4m]ԅ-6"g- ͩ@[v!ʟ&zjkHRok# -�Qu/*�]-9T[`¥UTT͝<2%Yr:?,ϵw cKȹi!�D`(]Zwb t6~F6PewH|>?̵畯;U�OFz = 1Af:WolKDltJI\{{lߘ-ZUlh,ߛ,+ON ߷l{E}r6tlY��gזGw]g3=A̴WFA ~6.\}ÿdWV;K�� +TJfw?L$4R<PqS-_Nݐ/w֖#+wy&�}I߬)}ALIr: +Gҥ'�* ^yqҙ1wַ$w +5ytU(�\v{9!gNa͚CO9 -��1^1G%J]c;aجԗ'=ߜi>~ٝ��>i>'"=pwb?̱bnHY��<swctw v +,->nڴ[o�PJG v +,OOWAb�0OO<pob?̳/�y?G5Vli ),NQ' 0�y~}v^zDDw!2b?̔: {{r�ct8z ^w!rb?^Uv}= �`}m5# c;a Π2ݝ�pQyGuUna;aX<O{�RqP^cy?0[;I* /S�z'/7twARΗ3ջY�[vx,g?�? endstream endobj 119 0 obj <</Filter[/FlateDecode]/Length 926>>stream +Hkq)QrpbW +&ɬ…jf-Ŝ9ll~}i/P#$.4.;w_2̝6$ؗʂCs LG +nílc�]F@SL}q:�F B߱?MacgMyˏ' ;�>酼aLj]�s%郚6B?MaeEiΐ۹kv�>ڕ)}dnB?Maا(V-4|أ�/=p(VI}Yen/ZOkw � wN?Ħ?upkS{�<߮Ϫ<8A); M5͵u 7ۤ߇�ɽrv?bSZX9(4|ѹv'�@ Al +nOI~/�h{lvbSvKٽҸW#O6W=ߏ��}T̻kw 6a e{Gj_?K#�ٞ>G|w;`MGnCv�Gw]?MauՉy(kJ�{4ApĦ?co.ݗ�~kXMAl +#<妚SW/]ײ{�wr=?|wAĦ?e恍8jw'�;(\v xbS[]2S޼iH�w(9UGfhw +Al +#|-1- 7d(�﹛w-ڝ`y*.  �i endstream endobj 120 0 obj <</Filter[/FlateDecode]/Length 1152>>stream +H]LuPYˆyՃ67l5L4HA(#$M eIj!8g(8BYkQfrEFu~mLg?p|Q+�pk2QI3#>~Kc!{;Yk-DWiɍ>H=�,/z<AvI'oAGJ)zJu>U�@dJg}7 N +#e̹?=m�DđFכ}-Nv IaƭA;S8 +�?Ϻʒ N +wآ\v�kt/~ ᾖ N +Zֱ;BE�\De-ព N +K7T{ �PSw)UKb'%k*3ˮ �L㾀g\,qR޶biX7 tgW } AnTks߽#  Zfl%}`⤰?pK8v5zQ@,ѽ\},}`⤰?p35o1�ĒuqR䰧e� f<Ӕ#}`/b<1Cy?i+y&|g,w9cg2�8Yݷ{T ?]S mMŗoz*H߰?p+G [Յsu]ҷ�lag2t~ĎY@T?XNqW:i}�'-qҝ{b;ᭊ>s6%)?''&;\Y5{:G+w�Dj2}+'c;=]ywAo,Fz./+KwĆeL?2�'}z鋶_ZƔY鮇}?3L13fݙMu;D#}JZNų7�`q<7Sޖ4鎇?H4"K̹ z1ښ +›d*91qӊ`MTm�MT+j/vDݿ �@ endstream endobj 121 0 obj <</Filter[/FlateDecode]/Length 1219>>stream +HkLuF7MheJg[fPmmr�g'* LM9t(%ƹ?At#9,A[)zg,hlx;fU7k@MkFH"A8cWa|mK>8#?g.N^[߯]r%Xγ~ڑ_~ךi��%y"|pDzUu$I_tb~jܐ:IIV3וQl[U`>O%5j mnw8�XџC۷I}a>Lib4}~%dL}3IsWfo:eRP}d:?+|Sy?ٲeGLvO j|$'%9%;U}�@ߤiқMeʻ fM=x[oz}+9xV㬎<>4}9௓' +&O4zsJCuZĬ.%ESqgomx{l梴~t:�җ/a=b?0חռ<;�QIOz;Zj7Uw7Aj֣ϜlvL'/Uw6Aa]ir.ڒ�34TR (=a]b?/Yt FQ=8^vhX)ᨯo@v=�"m=ҏ; v +bw֫~z٩�N=g" c;x+>+Mr7��p9u`wb՝ {`;D*6ĹۓT�`>o#YoO`.}?@",(;:ahK�0.}?@,j=zκXS��Izn6&wo {a;DEr.KU � .wF^)$͋ꡉI)�IN՝ {b;D,[|c% �Okou!;՝ {b;lguau�ă)׎?HϩZ)̗7Y7`�I endstream endobj 122 0 obj <</Filter[/FlateDecode]/Length 729>>stream +HKSa e).(ȨV:eDEsvٍ +;Ipfn5?UtўD"s/81^~BhZ\l9ID#Ѥid.iGC{{[2%?���JYs^ -LO<HF^xw��ȝF?ffVU2���ldGMͯF@sŷI=���({Z9cvx{���PL@'Nd7hR=���(Hƌek3U���@3'/B~v'�� owmӂtGy/W}���mo1|.Lv1:ܪ&���a>4p?|XJƊ��� D~eƢitP<O��� Dڶra?#05$W}��=&wY`*H@'8LW ��nl`GHh��� ]VyYЉ?*OɄaL���,egtRg+3.���/[\|nc"_~?Ai���ذ}F@'q|7*U��EnuW=v,&覸?4 +?R}��wXw~.?O85o��z +u endstream endobj 123 0 obj <</Filter[/FlateDecode]/Length 979>>stream +HKyERIvPIPxeQ -VXI3դ3cϳ1Ij.[DRVdG5BDE/^~ܗ91�ƇB2Nhiciۗv^|觟 !==˻`}5~,}7�xy_;Vkw+ 64s +s28ɧ�|AcZ״cD7@׹mew�| ={שw*Al +{wco �NHIiw)Al +ZцBy{o/о'�K/uPC/bS2q#|> h�9SWNFKC/bS4gg c鬛xһ[�VevwĦ?-?Tb?}]mw�OzSWڝ b<}'9h�Bh8sSmS 6h='o`�PpS; 6/-\q:GǺվ;�XO\RnĦ?%3+?'N�S7d\H/iw# 6j7 +;l1&v zh@H 6/Z\\vnCme�+%S!. 6*=gvm<ؤ}�C;ճ;x,m(ʗH:P}Ħ?e+L8 �;D3j> 6؄ӱtM<V�K$u!%}yǰ?Ma`2׍=LmֿW�ADzEEzFOad%'h0uN&=2uҺvaB`�ND endstream endobj 124 0 obj <</Filter[/FlateDecode]/Length 1277>>stream +HmLuxlZNY˥/Z,{ApHY9� ʈHjr<z 8Zʂ`Jk՚4zQPUrk& +?}6vÛuy짌pYvǂxpcyUp;K>ϷW: R�96˼${EnnAt +VS4Kmua�?=b.zA :pWWPtw r'&#Y@.At +ЬJ{x 0О";  )؜DeǪk�?/JPÀB@8Ȩ>r|~l@h {쪓zw#E :p7sbho]zO ^pwp'D?IFSqs5�AAG|wpD?-SYs}+=�c%6; + )dǹQyǖN�jpKe9w0ZS] C$w%s]= @Nt<yח{ +6�L,{mH. +j3U-tklnQ]mtW</o{'-q922w0$#1`]΃wVubyU;tiw~.0_%;Kݾ-ujl ?~P?3A +dyd�Si2G:P|璛;_k1ݧ-RlV-w>xjRw%s-]&P̆ݾ-!n3 [D2/l\:j &)d[m_^06de7tAB5G}_\2=V?0Ymտ'KɌDwѹҕ=vtG a>hf=Xơ+R$?ܐ$6'V_.`]~pgd~.gkջo2Y w9׾)əbODF꿨)h;[L6rK|b٣(�#3p"1_c& L^c)qwtowM51S9+;g)zޠ�/}F endstream endobj 125 0 obj <</Filter[/FlateDecode]/Length 3123>>stream +H{TwX]N}-mm.ţbE(T(D !!!<&AD費gZ]_ٞm{zn0B>2!{焹~;_gYo|$ m>|sq A?/�VQ|1_y6͒ۏQvN_@``xKQ52띹v|R2o!' ʎ$T{ׅW!)to@ۂj:N <$Ш  Gl* 4|3 +ATl(TjWn~w A~|;̬݉`mm*!Ξ2<x'8'ۥ}οNFMBd(KЧ~;A�ƚo&iSV&ow7ELfz:  w_]=q  _ +OUu13On1qw7,NκUAd֕[2g(WΎȊt]g j,7;Oa-U7hwֲevau4]>N9e׊Z'*#Ԕ"|ؓԦ*Y\<س&w:W#}X$mmb.d%w!xtz]@9?0|)<?r;K(ӝj&֋&CGGeŦRs68MC묍j| |I+ūEñx1u1Sw kՄ850Hr{IWik"62E-+M|c<<:DIh ${0oPX :,66n]n@AK)[&UT_k%)slj(ʅVjkxu^t$i$/("`wHWW# m-9$h3FU?ܜDqDE^dO?.IjҾ? qR o&~E _ +O|}] Ѓç"oAm m܅ѕT%;y[ܜq2^ʅK$d.=:d~jS,ȯ>`fg:BfKX>mKII(En 3=Ǔcb>S~F2u@g7]R2w�x?0|)<?@.hmZsl d3Ĝu2uu̇zU,Ԯ*w]N:;.]Q5ms*)c{#%2~ɝJ&b8_elO0K=^8;?ZQ `p>HBܸtc# A|y2-Go/'!] +>w@k7J(E.<qt֙\ק(5EX/ 5rB<9eu-asgۯ?=y|w߰hg$ZZE)oOaimfߧ!ћE/Fg'yF`RxHo4L?'6 +ꅊ?PONk*Z㺆ԔsЯ'{gRE' bcƑik"9w*+?ʹOZɫMNcۮ(cWs ?+*ww[ɿ߯!>8g%uV`RxxzĉSН&Zgr]3=5EX/ 56[KPגN<7k`_tpR΄喖DqA~bvܛ{5ᰑ;]9OJRkxo'޷!XAYFOo]͠1{Zyu\<EWepY]UfGuvu-w\, j,/%L0+,U"=4G40;'UtY+K{'{K`4g"<O~ \D5v: g(ӭ[07~@GZ+N]H_4Z5J뚳4ʊZ/0 D:Y+'Jvw]OC?]|tuf�ԕӺ)V䳂9rZPk1BkwNIw뫐GcΞI1g|'ŸỏC:w-F� _ +Om F#+j4ٯ=s5"?,ܸ+*ZOt[ϫmmaĒ"Hq?7OHRǂ8`|Q2ƺ=عBfo2LHs#$CPJ$WUɍ! }yIN&Al݀~@G|kA +?0|)<?27k6/kc|> +xgz|3\㠧ouV vEV[K.C\/.2f%2 BCCxrsse}L]E9Cn ;>Xg&`M(q\vHR(0%˝4I 6 e^b1ϓyfEbPrGGּsyWg]lLg36Y>[5']O}꼖(?\4ʾUB;%1 :�jRj ?= キ+bGpڞ7O늭M#BׇpԏwgsH.+0_[L]8Lǝ+#%SO;eI_(>k~O?er+N7>}@\$[ʉi}ufJKUIsAj=䃻4u+=ey G㔹uV +JK ;*m͜WNĝ3c5D{--d +@6p{2rnw-{@�srXP( 9]�> endstream endobj 126 0 obj <</Filter[/FlateDecode]/Length 3530>>stream +HkTLJz5hccEkPx 5.nVXVv]Vv *PDJ<Tch5:v0Y9ϼyw /Σ00~u u-B90NJW/X_OMQu228xנEp"`) oҪ&2۝QXu!6"'`) x)'rCgև+j }ꜫKoI~DnSbC-djrU=V~[}<*5y|F̟a;Y60R/Fi]2gl^+"ꛫRwr +)JX:d|Gmr| [ c%>ؚY }Wcvj${7$ En+du#(gtkyD`|w A + 9?e 7-׆�71aO(vuYw}DiUN;s ְRGyTn 긙gkr +[*Ҧt0dlV E5Z>;=;HYKi]2w_EDK%d@޻q@BRN!H�G!S$L676kbm?U)~n`8+c-c:V\*w*0x)_W[2#㹃(No7;Yb8҇dlshV/J0~v�<Wpk{8= z9'q: {]rxG� 㹹/"B8mp7j`kK5ya_ m%:M:aL탱t>plP2*ժ ֻ},<5%Q7ὥ'^ E|V9Ur] Csbjyv0A|  9?Ыj8txN�Z|bnuG}*GB_Nc3qR&}vrǮ(3 +4wCxhU{Zi].jE`i̅u ~� WK[O +;ٻq^da~clZY spk HмN?܉e"U pLIZp|lM,ثX06Z+on-y'w͛`>\0wzw4)uwOw.5&2~?Ŀr +A +e(3Zzjxm2tX?ߙ+5|U zmoha&'A.ji7,By#k=S66?OP0UW{j}X]o@{)'s ^>k9`rƏs3SWN3s缝'P?=1^O)D)!g&$mEɀCNocjM6Ra~Njd>VZ<t ǹU;87b!4NaCsVmh;C߉Ҫ& UĀ|6}biɷyT6Gv8 0LKÁJ>707:smm1_6mC$I]Rtx&>>wRNW{f.>#2A!W _/; +5yc4.cl,?0m`{/]a cۜǀvd2H'8wIwASMpxn=<xo#T2qŇSMn{7<'r)Yu4~p`am<xT&9nx kU |~iX�o,vI]Ru;yDKA]߅7aN33ewAF:?0?!,R^=Ѹꊄt/Z +xǒBƇP{7 #>")W2jCYSi7邽}O c%?EשNdL}aO�_B?NDS_'MWQ49};kǖUf[@ +3pz9@AA  r +�K1_ٯӭf)ٴns+c <h`�2iݦr2xF^ɝ0 [BJܦRNܙ{J?LN LNcԵOg, ڳ kSD@}tB< ŇK~r + +48i\{:iܛ%񠙅#TnIV<0s3ěɏ xm^4"/"#x[?TDqNIZ0rN45_�)}7f07-95L/J]{F`|/ 5t;ovGZ6HU�uuu'u#2r +[+ӧ 6 UM8}GӬe- BF4tX R+<N_-$(T=K%X %$>$FfjvYoyLfw&"jvV +  ZP`!<99-|߸Mrߟ+�̆wJN;9Qkr5k%�#trcp~Gz(G_qgֲ|G͕Nb2okz^f7bEQꈿuKxV"' +P TTzQ9Ic +w-hdOeai <=S;~b+F1 e)>Z5κwG,%1Bߗz۲ \zcokNokީYw0zZ kg}.3CҮdsQm͜9oڃ.QjĞwg3. +]86wSfV,?1:r0t[ATTzՐLc3!l-I~Dl*j޽ Q9I^H7E Nnzi H*c b?HN^lzZ AȻpd[ipo-% @/ [A;?"?輽MUoAPS*=|Im,Z)Jeվ./Ok{,AU$bϧ}ljJ~0�Zq endstream endobj 127 0 obj <</Filter[/FlateDecode]/Length 1836>>stream +H{LSg?h@pdm:MmY�ya8tDȐD10m8A'[)=ipXxw\4*q쟩ևIB>OKH{>~ => >KJ7;l5r(?OO$QC>@?/ٽJvezZv{CEtk!xwTeOqX͍Nn5In? Q6͙;. Y] ٽIy:?(5|Xc-X|(Sb}&6&]m>=/g+d"!AI"V́b5lM7ULap _/|Q +wٽGy0Pj!ghuQ7kg.,v&=_|d!k`$BȬDEZ<ՊA͔a%qgiq׽Ý|g}Aa$B1IlƳco?:MlM\s4ݙ;e,_mcMQv/B<&1⽌]3GWY@ӥ'T ʟ~MvB< &1B, R+xT+ƺ+ʟ$�? O{"JMb +9R|꯵2Vs:C ůkr56AQw_.EvoBAI71bQI^b7;b|j^쏳jD]Q_FQ=@>0PK}%,;3,+ξk#CRXtҼ̖o!ɣŤM_mNU~)|:eZSw|5Z焐) G6hPbC߮G73w\uk.ZaθcK{0B:ʐDrmEge>VlA]n:U+k^\z%to?(O)O=u\p?L;έ4NVL9Fryae [c+\vj2S+5Z_>g?GPAP/ >9cI|fd]~]ƷUӕ].(W:=J/ 4oOPƋ-YjnΚ[3AWa/ Y3;x?(r?"Cp)>z|cvn2xqHj QEQi<f{ÃڄK?83`X?`_,k¾PϤk. mwxC^LPg;z/c1!7?U Q +ٍgyINJ~{2[wW +/ڂ`]X։bݭ{~/o~/~>zLgh:.|coN32o={~zFy sGiubLjK+[{&) BK³XG۬ujm%#~>zL<3 ǜ|wXdHhcb*͆ZW9gSLRQ/k Ɠs~w]#5L1Ϙ.zܬGQ>bNd|w#"8%GowLٝ®muO' uB!`n(O]ݫpXK2]+,+٫G AA-$2$T }s!BϿ �{ endstream endobj 128 0 obj <</Filter[/FlateDecode]/Length 2392>>stream +HSE.^P+XUN+Ct 2\\UuY4 !7ED?ttvtmSPLAd|?3g{r^0ߜ> _ma9{7d}~,qIrT:W;5M�����c* :ew +ěK3b٨AC%U%%Lu�����vjY6؄hR!χyͣ<R[L�����������������aryQŭvYR\3!K t{zݛ2_1XEuVookOHxܚ;*ZXV|IXdl"B54=F!z޶3-"crȏ.w QѬ"&ogWў3t6ʮ+'K 329 ϯh P熴=q&?0UJ]嶲s\DڽF^LyDt)ҽۯoL)rAzw!iok)Z۴O!cBy:#zE/|W G /ڦ#/L;}*Pn6zzC,b#WkQwST"aw5ACl97 DZy>skWh<#s3o7kr%~/oEuVS2v<mwzz32v,ʚ+MņeգF^C*Tz,).s3's2gQSv2TV|O<53Two4 a6w)`zFƎGsZp?Gu˖3hr鉠H8tO/^a&Ł̐18:jmqVR6%bZ0K?ӹ_x:<,au y;wWWBG݅(?;ݝƊټHHa^_[˹.E +TiZtF cp&.ؼeH2s̎SNwde!T{J8DoOBA;yeZƿVR<<(vK|6?ғ)뱍1oȫZoD5&nfgG Q cp&w5!mc}y@\;q(1UY̧bFw./=jF TcX̶Ɖ,U]m<w1P!E:sd<,<GDZB dL? Tb!Vż`vLUsRX#++ =P!z{@w!MqH3o;&zZbs6m^'%Scc,WRuf Svy稁>#cp&cwTJy8\Kٔhi, O~ij^ztwgmWXP[!cT;%A,[DȐ]<!ۂ@vz}<=YBTuF\Ӈ$++ < S);zE* + +|iM,`6LUnwe͕]bfJ*޶3#ՓAƎġ7ڛGDؾm^7ӧ<WNO|_qL|s1V̜6mԠ{N18#G=L}oZ5pSzɖs|=Xcn /Yu (U/w&v1~Xq..CN}ؾyy=[ZUjH3{t8V'o5R(mt{{[E}ꍗ=׮18e,ր4+;yct3TZYXGwj77qylXF5uAڟo+;$-3@NfL;ct{G{Hia78d 7b™PkKJJ'LE~\XSQP[]+?.djXP8d U80;.K i{F2Y `|ʐP&ky#SU[||l8sL/c}:wX(?_ +5O)b,2v< QѬB8GgWyH6!JUzM \d1�������������� endstream endobj 129 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 130 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 131 0 obj <</Filter[/FlateDecode]/Length 334>>stream +Hj0DAO+a U-������������������������������:<Ұbps& Wp>4 ^9c<k˰VY[[}2cYo>Ӕcˏxrjrlwx'Gqb[\~ē׊]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR}0Kj@4`bYM+fصbf]+fصbf]+fصbf]+fصԤы>�a~ endstream endobj 132 0 obj <</Filter[/FlateDecode]/Length 551>>stream +HNAEQHa0&,4䵹t=i?]6c>XUƮ񡈉uYELw=>[7$&nIlmy.??//NCuB7$&nIlMؚ9&5qsLPkש֦rNkGcZ#)}>Z= gvY i.WA=ރ!ֺCj?}8##S#GGDFL9:"2!Wcf,\Y:4su<ficΎ  :;44tv4hhhڙ;3uw,jgXݱ:<63vx$lfHᑰ#a3vyne8qp+sV6(Qӣ#GG61ȍc 7&oAnlЉ#G@'675rd|^rd|^x/qu={B z'ȸ>>AxCf[SxydW>WK�( +֌ endstream endobj 133 0 obj <</Filter[/FlateDecode]/Length 1545>>stream +HyPeGA#uSLFB+-�sBSc9X9`wUsXC %'0Îfr4n1~?3?{<yww~_!+NlF#$'>-wiDc<x;dKnxTuEڈԨNs˜?H<u)Oq#F]B~S=ڎrGDDD&11F0y}犓ReˡMrGDDD&+}_T0)(sZMrGDDD&N[eSξ[H6I6#"""R_ZSR*ocmv8^3VTaq,"O)1-yqqC宑H >ܼ9�JAJ-E꒵0=k$"""R[ai7]BAJ-`NEԠj:;V^xoOAJYH2e-,W宑ԣw^b 1qh1{TxKbC2ͷ슍<Q7e.kC(Pw%;y|<b~.GaAߕdZAJYX wD>1"`x"*|Ϟ//`5?8%U8gTrvg֍q#l\=f?V}̃0/6B}nԏ}ul.q()Yg#()^ږ-宓/ŢB_iCQU 6]}MٱVӆ5UzqN+DC0 Q*Dɒ`=QA]u޻k?}b7OD WAJY +5@+wDbcutڍOѲO:i~6ZCXfcalRވ0QW'1u?0XMrID;)'cYH>O{F!JC s`7sy4+.v΋<9)Zzǘ?HI̐:.wD$! EGPk-5tC3R}Y2I=Ls7}DN 3u?V.޽żsāĄN\kzWLgL:O+<rDeqAzftȋ>HfM~ݏgk1u?&hߧ6RZIA"5&HQ^B҆|GT_W9q8Cr^ {y!xb4]`qnhV"|}څDefz><%gsc( W7l{GLpo}(Q7vb7_ԋ1t?023NZM_]+wÐu A2_i;_ lNb=7=po?#%Ǘj:q G7K�H; endstream endobj 134 0 obj <</Filter[/FlateDecode]/Length 858>>stream +H z ݷfmJFK$ǃ3 RcEqj*wY^z$,zV= ‘DDIdQ̫Jy!zTSϣ0dqoJC򴩋,|ad&u/Ze8lPq= $Ht/[m"HpL2 -d %.T/sI>S|>T/tHer\^wT0wE,GT0zBp|d< 2#'cyߏ1_@| #(cȗQvjBb,*%aN+n*s&~⬦:)_T~3|iVz5qU+M·|^4',=2_fa*|[/\J|*P-6Qw)7ar)w%ݒERG/:_v)y#3Ɨ;7>ar:ѽ$k41HxSae*f1 .dMvA؆"AXHlB+Kcg|%Ĥ)l(4sj(&0AQMTΫ4'Pp 2 3%tGQ짶W>+t+W~ +슣.ot;Smϐ)ǦvRl]hq ݁?C ݃ Чݡ0C@ tfŽ}8>3taJ@2]<t+On ])t1з;n ]%t97n ]-tALзn ]X!tMC&3taք ,3taЕ}Ѕ5@W.:3ta `�; endstream endobj 135 0 obj <</Filter[/FlateDecode]/Length 621>>stream +HQnTQCӃyk2oȮoo_Pt%>N>x4Lbuc:؋7|{H*z1lt{L*z1lt{L*z1lt{L*z1lt{L*z1lt{L*z1lt{L*z1lt르ִ?s=Uƚ:vG~  `Gc1]vKU^S/|w4|Å5|c;ugz6U]O2Ա:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=]`�v? endstream endobj 136 0 obj <</Filter[/FlateDecode]/Length 627>>stream +HQa[FGL#:T}@Pw_C:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?Rz{,*h^. +KvGhG hnSoG>B _D~>M!8n妊F?}F'B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tG^Oe ۩Za?r,*Xޮ^%TrJ6'_Vh8« +.zM'> +0�I>_ endstream endobj 137 0 obj <</Filter[/FlateDecode]/Length 601>>stream +H\1O@Lhp5$A:[o.<~|ǩZa˿s\4OЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTokņ-y*9Vtud#�2KXaӿr^S~ ߟ䯧c;Dž#G?וn Tr9.e 'B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3z[?�3 endstream endobj 138 0 obj <</Filter[/FlateDecode]/Length 670>>stream +Hn@ DQOo 8UŚ.y "i聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j=F8II#n~d܏P%p|2q?6C�!WT څǚ_% ߘ5\Jz1jˆ1{{U*voT-l!I2ģVȬ1g[/UK sYϸ.GVQ_*xšVׄn2«R\09 w? {wx?McُAմ>GlUiJoŷS xޏ$',o?b1:ǿB1/.K k~T_|2T܍hF[!>mQ|W<,t\VyC8M𑿕ԗk +^ +9<\&|[|G,I$I$I$I$I$I$I$I$I$I~ 0�/' endstream endobj 139 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HAo0�|J8]7J9 :,HС4 I;|~~����������xt{=/"YIѺ/][5"Iٴiu7ۢ&P/~.ۦnBo6o˛ا.e|U&ۇ z]첢,Ea:_/N.w˫Q߷~a:m]V'Woj| q0̏y`)c ]}/f?g<㮉]8'%izw%NBba:{�����������������������������������������������������V] endstream endobj 140 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 141 0 obj <</Filter[/FlateDecode]/Length 295>>stream +H׽+_ ؄EX- +gpJ&]uI.SWd9v/P_z;| ���������������������������������������������4Ԩ\4m񢸹v��-ӣcc^ϝ&WsmdOm��@tt&}깐9 ��Sw!��QU4*ׯ#eE>X,<�� Bn +\Zj\67;>~vH(=v��%�tB endstream endobj 142 0 obj <</Filter[/FlateDecode]/Length 577>>stream +HMKQWP. "uU3#ADk6-)D"H* +2YDIm~Gs)p!s8F /<7) +۷O۷o>v`8?w_^ ��H̗Kq\i:?U,翯]h\wWWqeB1\*,aO Z +ަVυ.7GDDDDN 7{>:t~fz~sårJ$ګ7bbbƲ9=-kaoX3^?zxvsk_wj\tsKږ>^fsNa+sotn~nc=zF{>3΃9όA +:^Zm':>,}fsN\s>|gy0q?ȕ>h_mfy0q2g)g�H>�;FJ� n5R��q}�}3�@kD�f_#% �7)g�H>�;FJ� n5RGJ~_� R endstream endobj 143 0 obj <</Filter[/FlateDecode]/Length 416>>stream +H׻JqAcmRP(KHlmvۈPx ,I#*l+H"0VӼW/� 7/_e?wox{j=K�aH{ϯSo�` guy%��DRU~~pc=��OIy;|v.$��")yív-&��n"Fc\H �['(�(�@"��զ?D��T �PmH�@"��զ?dTzhL'�@_KSŨ8houS �Pͨ{-Y{~"4��2A,s٫_y��}HK7ߋ7��?!|qvrwc�?�ޯ endstream endobj 144 0 obj <</Filter[/FlateDecode]/Length 19269>>stream +HWn8~G7/I$:Fl ,tF-ut<n&$aK.W>NWN|Kzΐ^;I�rMw}6ge~7e}T]y>M5xEYg˛-v`dj�D1,0ZS<0 j6I0R!w H h8" v5nu3\uJ}mןj nV3m^<u*AތfZk`|.֐ƭ|BLRsBXq{!LJCfKm~ݐ| k= ;)xyL`udkw[}3qFFow5Ц&J1_ŝh�s +ʀM~E(_9F?T6,kA8ZwMenݔ.imkr/jeseܨnh`zҦK3pMsidK," |"-|Ƕ.g(5*8 +|U9; MWCjgZٟ<9! à}$vŬM[SCh:n77[;$4AW}MO@qY8=;`t˪j4z;@ktyyvP6VUMg'ANTD$Z9T3L5aCöΰm+:'l6ݡ ߨtW(z2mƺکd`w@b,uv_6>/0[4P5stת&j#| ڎ_góʵUUV6@}oӨ{d>6H^jk_A`ZÎnlԬѳ+ 8ūߩF+Fo#G鑦ڇmdHUzX8vu;bY=TAM9?;*]k=;eۮ:+x`N[>;A�pߎ=YuF>9Ԝ;]'й]:L!Ku۹[*M`У+V:p[Z ᶴm!h@λ)ag[c*oV)gcA=(3g`<Dd}\OaY^f;�k$,<"وp jFtr\1Qx^Ht{DN|"9R;B +n=Nn66z{yk%rs.Ǩγ7ɫz֛wͺ^ l˻IW=v=V^jwUE0:;&mL&vwԼyu(UZ5">ix GGGw(Όs_ +`Cj 0-츣}[\<:?޿izRg֤}OT1l\Yq zni\@8+k +U ,9i,{UO3ʕ9W~kL6/v̧}v fӯI31�&pA}ߞx_T~R•{L::j^E^di 1q�dSg_ '=ǟN8^r ߛ8Q9589.&PH@B$1IHJ2bJ(4TҘ&4i0#2q&d1KX2" h ((8H4Ȃ<($! 0 "a&afaHD#QED$8J4ʢ<*8SxCqq%yS "`"| +)bTd"ĒH* d(#ɥR2d. /1i (汈eIYEЄ%A&Q$N$M$O$)K4L{HeIYE3ьeAfQ3IP�A/ "=v)XqO +~%/!x A XUcJX@ŁLPXOB Abe:/g~" +TCNWM?2!(. X- 0;A&d^%[r&BmI)U6`:!l{JۍZ 7�$(OhP eP.D񠲫CUETWhWZpEhPQXkhD(eQEGe}AG|oP0HaFDЧIjR`+/5Kz ^)DpJ"?2څ;7.m^.]=ŰQŁEGCeAAZXy(Y( +*VҫVIT2 U$RI@euJڔiҥJI")ɑ%%J:4PҠ@I&ICQّ$I&M֚4IgjL,02i %JRj,(,&IJC :5]ň֍@ǂTU 8?Ka~B h/0g&=Zq}I.$g嚈ww7qww7qww7q۵qBZS+6sk;wQB$YJE,^2yV;2<RJuԪF(V*W`%(Z*[pePKK Ov1IT&1)h*iM6R oB}S*KOSS$~?@E/Y;jaLzH7H.GM$MĨosMM2]F3\/_^P!t0WSgɨ_Y²˹w;):+@+M_.YczKXAn1lR6y^7`t5beC ۸X{0⠯MQ ݇⿤֗l;q!Z~{~wsb<lwy=߲9\Zg^7c/_܇??=K'ӧөᷯ~y:'>~^N>c?ʗlJ͖Ӱ#UڹzvMi+k6LmAOc=ncrlՎ3_Ѳw9g tΘ疴 C}9zڋ�v CD +viҭ͋g0ihjZƓH3 a\)i*GT3G&)FsLGifȞ`1ɰp'hRQG2D枎٧gO .0V.06D Z"ftDO SvHn${Lf&bJ33ڌ8N]m0c,@BQހ_CՇ&.u`K{ȹ [GYIb K슙WUP4%2}H6|Wd3MF$ʴPJ̅.`O\]1Wu*Wq*T1+4%Qr\tSu2NrգEw]I^]ŭTaԧ+$꡹G+(b4hZUH Õ:MY~?#*`Os:I*lQsLˉM|ѱt@ )ݗңRzJi_e$Ag2ڌ8%x9 + P2M!q>}s>}E!+#--}0·9]G-jۀ?՚t׊b麻1n]0<?I[:>}~Npo>}=߾●ϟ?=?}\_PfZ͓0 rP2'}V.m3etCSÃfolƮ\<=>S]8).$d$9 Igihd\$9Mh +E)M(š&R +2sBƟ~|L=.ӥ3emRA@#L3%ci_"̢y2 (c$D4TL^8Z #E &00yu5\"tH0ʈԸ:"gXn48,rQG +n,THT +q,W` 6,ل9 )`Vp+ L!*˭2՝f9ėE;zd#平6Q%Q5cQEf,ec#,<a(2C wj؍KE% xbCbPK%j@-X$iAA +$*ABQL `hDa5{RU(A] +[PلAA4( =4B+4C<DBL/ң#&@t<A,ԅكjZbjf\QX�? rhŽة슐`v +ZZBSr c讇�; 0#u#;@=A-8l$ՆcI5�~Х+lIٸeX_ojzepRNJq38'-zo}9ZgoM;fr{n z~BLo^x:@w+[!>y@/=g<;䅓N~89ኅ8Yc5j '&6h-_Zp +B.i-tEChk넆mF̠[z3XY\!wz ;kɉ-.!oJM �Ҕ($iAeA;VjYKX VkS+P+ kCמqp΂Ss)PI0e) <aʄiEs!fCa<Ԁ"bŘAQEQCcdpr"QՒHe3fFX�#Нİ>c{~;~k /\ii?%˷So}%ȔSYƾ•տ9n#P̃  F XcS$d'XiօU. +_\T|]6bX eY&eQk&@zZ1b U]1}~i:֗4ZXC1iNJʘҔqLs9M2&>My;':%ʟc"j,@ƌ; "wS҈M<xA',?K� )9hҌN@�S~*lZ08k_0+iSҫ()=K7sDv?c?_aXW$KY`J[84%fy`TDڴBjTD{� "0`k1.!vP>2Q[sSBe +)9 6  t<}' 2M%҉̔ +MBP,fcG4*6 :g$O~&(_jz펛ݪ]r6wP[kkZgr7Smg3=m-|lے8:5cRDsj^kBp9`%JxTc у\DM +pP�!rSPAN?yz�Ez{xΠSGwp;s΂ ԏ.ᄽ3 Cm س�( T^t4<}R(QjJLS;J-M)V>ͼIe:iJzP 0:ocU7oyթ뵹DPi +BK .2quұҡX)tO[lH_c FOQ.d#ÖM|8a8$jHq OiL9h,`T SBbƢ)Xx,H .aHC $u60cPe xX2�;odM{cCfw=Um!gW[NN[v:Mk= +h7A61ʞg+ߜ?}2ΙԊ*NR<y+{ή_-rqϙs-g[ͷV{}_g_ο9 \T$$$be;]ɶX۴|%7_Sm}蒹KCΫmSs}\vzk9*6>nb#dpa~Δa\4F[Gߕ[n| __?=|/az+/_ 7s0N>J1*K_`~r;1Mߤ,iZU!1*FKg"|E\) + 8G,\hDPǺ! {9:YʀE +uguXX�pebh/=>b-i\ssoB560]).,n{KYP!A!ہGjǴaݓ/}Yh!B3qΪ1 d A;W8fM  I1.IK6c9Mbq,E},"ޠRC:m! T\ٯbk1UX/Hpc +n#"\3Qes-,:8}qnј +V>ۏHb.dr1YuPTb唨&YE)-& Fo|A j0汭Y=A`!J\~XF}T^zYl ~Ac[sw3EAD)Ͻ˨MMeKb {ҫ}E 'poQP3>w`#E0XK>gP eLPeSyQL}_P]lPaVUX9%|-o"Ub`Ɨ}ՙc[9s+a,ӣ- ~T^zYl62} USEdU5Nq禦%UDt􆽼=߬`LLjK&uw{RdU#! l+j-;ci,zȭjz5\ Aк`ә`0WG+rU_Ѧ8FxHm5[YW)#q&T+9gfEY%0D-]O2J`V"4.dG:D%B6 ǁ[bhAq-xE3lǎMc6qƹ6q?MΞޖe6/x/2;mӫ_闐9Ͽ?\f$4}DJ׿K|O_~'7 {έ,-`6rz+R/4:ux@.HUF:-HDhI=45[!1٘.B(E rZQ)(x.B*d(-f+}]J+{^ �xw=z+{TZ([׹EĨM8T؍o U4HW΢B-Ildl. 񴁈[l2иvuJΤ 9(ctBvUȻCսBdcliBvUHV/x:ʥ&d=xJӥQh1lmo&d=(vvPQ+M{P^Z̶+M{PJ XWބ\ǾIh^IoBvkԇk6J{U7Zig̿HnxL$il S$궻 aI)V=?>{4Ⱥ4#_I7G|324|I~2 k5J4u-�o!Խʼn0g1`:2 -ٍ4c�|˼6U�HQgQD>8^̶]}S 2pϭQ۵zק(O&G7AZxƢ'u  [-tБ {o8[|7] xL=u=jOI'x<%CKB͒qۗo1).^2lO^�{Ñp|Dq;>IC)[! &HCx)Dl!|Rkv }fynUłL0AsGøv\x ȼ2,z˓AmMA9: +t}e랏XJNB*Wȕ3 + $;X"A`\dH S=!d</".ɹg7[a19V\QΡ4#ztH2IgRc`dC&x\Xn7վNsr ~̪5_0=@cho&`^FxT!+eI:3Ju3O�QD/�{�űc(Jp68THdzbʆwx;SJJ/K(u(+J`s4H#a=<Pº'AH sI7~\Q`LL]]o|k^2 cܥJx9�#Zzm?qpϕ=B}ͼ%uVl $ +\~r“UPN$,UCXv=}z^ZeK}9por`A8:ٙ?d~ݪ+%KB$qQoLE.b17,<²}{nj[5+;�^F(@1c+�'zeaKr)'Y8N<F37 װj&gPs;7u.{?R#72VVy=۟ۂC?Ѻ5)fv`33i׭[2 >5 ?Rk0+5}SLZB=r=N)XEyݕ }n�KIP1(yLrd)cdr0Tȗ<BɾO>Ab6ʤLM=FWEN|:Y9'(/p&% +%wOe{&g0 t<ʣsm%V Bg DS7MRl?_<u#v1+SȆJ'őggِ\ 봌"1R<[OADmªc@V=>INJ ]7C{ =FȺQbmKQK;W̜{iH¢<uo_;L/X`Jh-;Ȟ^6qp4+٨Pԧ1ڣIɍ٥^!Wx!zQ{< ̈́)3� O^!2T,#n><|Le ۗo뎔ܕHs8R1g{WH�qTQ7m[z6 {eD!CF +�x.5!=ӘƴcQ1� +ųXVuVUОC"A\^?'_AٌuTyMC�Z c16s.Lpt-<>r.amU)cv+]bZ0Ďv">hv"#6&vSdś_&3Ozj�NqM0w!;Ok|JQ7>ɰF +nB83F}ɬsb3㘳Jv[ ),ςr JS@Bn6Ξ ԳA`{E'<{GYc*[95l}3ংOe!$%5▖( ҴF' cr`@4`j?7>,3WZM{* +ۣ +m9GbSbId?m+\936#Fxzkի1gPjoCU,cԴŽ6"V(AuoIX{qQQ6|Z)cTő7|:/o0nB[$2T40KU0N8ƌI;Lo�L+X v7}A:D8: znw/=) c@#k g�_9v^n-;]Z"8p  J)PX j ƨ1'@ ej0_Fqi$Tӝ{yb LZωyr<eo07 0v+G)AX +k"ڔ,zx&tA9G>.t>M-%]p̽k~:R}M3DN16Hee=Cj@qvdE�zDS?*#}'Mk5r_"f/Mғ!] ZdOm~J&WTiבoqڒo]Dz~Ärx'EO +!TwW m2[J*y{gpTqt4,xMK6oyheUk/OUo7o̶ +P$ә|/MjRA-S*a+3='jÑ!cOAb|~hz}iv JZ%\`-f `ZC(Wq2.e=Ek$wsta#/J \f\޳5>&"Ǻ_T7=;q-AXps}lYV +`+OΓjO ፠X3hbԬ:֮˸2F� CQ `ݔCeK+_|+ٔ Y{Ia|րkKk]&A +tq8(HQ7ׄkYd 7a`]Stfv]tvLz5>WcUgba, Y dko.jZ[ӷEؕ äzݸvZҼ&>=11�SuWnnЏB'w<UKoΣI)Ɗwl k疛zp6mS4ڹ)ʽOF7>*7v"͢u@k94oi5nw1KTCO~wh [ľQN;3SLys!&nǴ)෼=Dڳ Wz RC ^[4 ~3˽g_ e&ȠLQ#G.' 3q֞p;K| R'h^*Y|f-[v Ah0?1J"L\h(!]н힑Or^2918Fvtu=܋국<F ;L_g<] +cg2sfiV>w58dW(,7mco'HtPL YsP†Ĕ%l>*%<ul=\Q|,WWIk[k˽!;Q)[¤u]fH T֦_)(YB4/SW 6ǰ[q:8HÌ]V_|T狙Ŷ ,LoȂ0>~nw5sg,8ČЪ­ryܻZ+3vqYm4CMs=Ƹ8)O'A0{õgF7Mw[onr'ZeO^0ٞb[[4ɪ]5*6O%d1#phުڭܷZ2 |_'o?;SB llEte;i<hڟ?Y$/)]x(/~lf:9Ehh9m ilt04X+ڷ=<|z%ch +!}V7ez櫅W L27\P*}7n1<^Ye",7LNu1|*^^Hs9*o~~%Z4QҏւQ6ϊ/]]�^8Ê%ap[5?{^b{%,-)"\-y�xfYl xnBWAS<[TCg<G iu]S\f<`FZӘks$4$ 3]@ ,n UjzIxsRuY.� #{ֲ+( (®,4#9b'I\8I4|\ˣFb{nV|uۜ`Np3;n{(kȀ\*td4,H剖uõ0z#Q^k-BGt,'X"t1\jv%kB֫�Ak+2�] 򙉫2HJtC1J= +x{^&IkCQ}O*~*|5(d+ ]9(F؈\VN{V+D "N]/y Tly(M&sm{I5}#syYJ/Lb+0e/J2%YH@ASH +n/0XG +˾qKYNw-.wŵ0%- ܀n'cp̜{o`, FƋIugX꣫mG!m2h8EL&!};9 >cp)¹􈸬U{IU|WyC &FClm0qkJ1JwG:83jaxFy lu^2IK<vn[* Wx N}wDAr_c u%Q˵9eol*Qsy؛2{u{t2AVmv?;]kv Xz/k9vK]z�#'-l1 W_Q#:onGNV& + �3sn맿ۯy sA}?k*[:ڎr+H"1Xy!kԆ96�PW>~+&J3(!˥=m#_^pp  i-Z9?4 ʯM'y^8:`L5+6Q`W1b;r|zώ AM_pkigx<W%gPGFAK*ރ3W>dp +輹Hhud N$w#:W$@d,rnKV]oH? eK'MLFvkQ;Howٿ�,6@U,pJs7LR"G_04AHd3]sN 3cpXhٯS &}a'uE`J|Nke%I`<,8t%G)Y{BOy8IWctŢwU %Eu1 vWHWl¿`[wrbո{FFvlZDgu G1È>y)�OAJNٛpKOG GcT펄>1hL- 'AHQi8#ߢ=w5�n+ᳯ+M6xF?sQ{R( c`<~S`}9_ۯ4<ppn6CHwlM>~ +t xY/Ʉ~;ڭ(],6#۹6uan*Bi2W E}ZZ �ܤ0|.z=,[," +f>0g ;n,pp"U@_ x<J0?<ZG2C7_.bSpڧi 6mᝋH&yY�#mkk-Ge�^:BiϹ[Mh NJ,`){~8$?<CԳ|A IBmŒڻz~̤-Ji3l}btb*+{]7;$2j-C3Od+{^ow ]zkn1�8!=G3$ⁿ]w 6bp371`tcG޶|qa%nRl-FQI^ngAVo5OX\G}`w2*.xӓD#&EF-voz gL$^eBPlIhߒ·a{J0ƽiw'Z6�CH, +HX걨^?vX�y(rZ>9V2'y7XNFL;6^il# +tzo6)'81Xg\*7~iuJRz֨Wpa͙9nx }+@(%sNk!C=k=<wl U\$|L# 9i,<J97(?O[_ l#$pj/E,]ϝ 횧5c7hl"4)f^%xD X?� UA 3PW%6SďMi|[tC[ 1DV"̾reE @;+5mqB̭b߄:3U1 =xW^?"Duඌ°X+T`,r:$tPi_|$n_QQlj& V<$4d�DA^}+aIFQefp nQT5)=ʡmuY4G-˸nDƧ16Ei-_la ~%Cۣe@U&�#`w`OOE$_XBt-jWo@jn! i?Q4+C:yc TQʨX�\ o6/"d`)n6h >,{0ӼhܕF.<#m34LW ]N M[O:[@r[i5n[-k'̍ D05T^0ٺ2,3mN?c>:O0{KR6ɍtV=>;elM  T &k`OΠ~w$P}plwC׺?H}?#hn[�CT R5܏s T7hY0|5Ҿ+rj؞07ЮcZަ\0l� clkhx@dEvjmM5wl+ ,F[BqeT�yl 4hĊFLHo)(3s4g 'pH胠%�V֙_l)]F�E⻛Jp{aķMw/tǪ*8X^O=VCz@U1&W%,rE%ǂ N9ZC2TsO0- IMΰ}Gfqӝ_<~e)8m:SaR}iݭEjp-7^9.~9x\b�|^OY:§FCkTtʻS~ +B ; +Op2s8c랈nQq\!,(h-gGfX-SDO3]x6#p`U @bVnNleX,SkQqY.R>6i<aP_ %^vjN)u k ]G<aDlFu EI[s&;PuY5q&\g:qE\D"3z!p46uX\9hBpI1~^Te<2T \8ov<jVipx5N7DG_9ީ~ḋn"ϥNܘ1.q=Fkoa6{`/pEW*fX4> Lqyq +`v&9sп:V-;n?@H!aBCǎߧ$zfmI-Ա8dݒ]0е[0S䓜][AA\[�ՙAJ6.%i,B@%SxX/&w f#&Z~9*)A:qAqNXU|X!'nJ+Ъ3fW UTV*&zm8.q/pNy1".5EULiiaoyGC}##(ɶT:̄yìҹ $Zi_I/=)$NKtEI[t?$ OzIA z;="}^b{R(Y%=|HzIИMr?8DzU<\q9nݍ5MW ׈ mA9�``*MRGA^Ӳq‚gѾB6#".;w-g,w?y ?m et |N +hsd^ >' 0%)i >'qNbD +ksbdj9E3qkR1>hX2mGHKX\^x%=Qi9/ahj ^A,)zI +敐7 Ӹ+WRDjJH]JY[maRJYz8 |A `AȩlӅfyXɊ*jZC$`eȂ;|Bk; 4�شl'y\ZCeV[8{.vp*`+xfsTV<T%Jty+CE +@a9P4T39x) EKƄy`2{H+cV 3rN nbL[7طg :>Mdp*+Aa`3N{lfs\Jw.f.m °-5թSZB ̡Ku0VG./S-4f +p6>Wa׼RQ֩DUx`)W 롋dcTĚW~Jز*K%y2ɞu>MH9 \gڷ4y 9rl-;F)OAJJÄ+zqUG*}\=CbF(:Uɫ+zv QUe'8K̞_fSZ&URٵ=n yXزhOJa:@-ڹRT! +bͮ%a,]�.X0SVc61OеZ1 ˯; [!H,‡c.e7(~tֱD FZv|B 7Ɇc$j;=׳NέW"NR}3z<sErLJgd5,rXNTŌg0 x> UvQG힄sL.. 呮!-Bu9l立_K?xVpX׶݇olOT$_FPvlSNd)8\U8X>_ 7SfsUJ-I_mrnyn<6%2"UT>Nz{쾪rCUE +J8T1 +ƱuDX4q.Bãr�cg=!@ zRcncw +ߏ0(* tKA50[d-PKxQXb:t<6n%ݢ(7&_IO@3Lp]i'լ`_Nv=鵊!vM(36Äoу#9d`"ا](~kKeqxo[ї9AEU-miWYq{xww[OUŪzR4-6+s>TXJ$t^騵^ 6Vp{\W,;hɦ)S9@]euω .;N�x?:Ұdm[[:"K]t[XzM(i[? SwNuއ}ڠ-: +L`I2|At|9C(a/__{Wof'܇`gөL-5:bpY-AW PhndBAa9ZOk|cuf̕"Q[RPL [%U-;C'VBq_%k2Ssh +#u>b";IuTn;l)Rp!V5,wm.aOQ tnuk9I05."Ukni4Z3fhub;h6/mS +H)�=2 ؙN.rU0\O*B qVZDroS|QIoI0%6kԿDH'tKu|qoAӾJЌru qmu{ۥ{ +Ҡ*ʃ‹04SK�s_V{|->}'V̦).KgE.g. +tuGE5xeWD=M7~?O_~z?ϟ^>w? ?o@??|)!d`нvu ˥z? =uwBe 6Xz�@P04Zz X\se%D � SPjz`a#C3F0F&,6�fb endstream endobj 145 0 obj <</Filter[/FlateDecode]/Length 2477>>stream +H{PSwW +�]"Z +BEũ뮣]WPy( +(I <ZJ%ꬕ?7t"K03ss >s_&jnda d(ѼJV"22mmIu +WɥݐS~^T! +Gx^,s5kAB׳nǕ^7ŠA֡!cˍwkzs<'6wsPıv+wx"b,ws&@c`5:EtZ뷌f 'qsX}{߿Ek"2$^Ί @, cZ\$"^v3~tz9O"vtVM^M:կ-�("/Nĵu} +z䳪<\X +~]~V/;Gi26u_{xBw^ |xܶ >64X!П|)UЯ2*?k4;@n'DCH+7֍Gka$e׮IJ2m<"J<mp-|$ Ӷ)thNiΓ8X ƹCjE*5++X ޞu_$ _?Y^ >X,NADz<gMF"ˢW |"oG z?g$aгp ւcu?iB /B~hyx -2q3&M-}ņ 羷,O+FxD ~߁z@_:ψ?A=҄yCb`?K`:њru~!MfArρ IK6[}QZpOQ!A0!7]#+|zӹ?{EJi b~'9~0ɫF,riWQ4{۰ddT ^}_`<ܿjQ:)X/NN>I9;\M3Kx}EYCRLCI>3N:*bW߷y Zke +~ +Cet{^y gLN2g ry3_4xHnqKnJc_JV(A9su=Nގ +~?Ep=Q~Kȿj\S+A@'=l߷zSOA-#K{1͚>|MqzΊqk/{TEHB|qxs?(X�0?t|;fmi]2$' +\G AAfZ $Ksu9Vcq DeIq}$cFj# 6vy<1("VEΈNCVG0nB++)BS坕S<ݫ_?s^JHOn[\זZ<8C`Bӝ.NyD1y:1_Y{ж?R}f(Գ +{)eyо?|]+p51))}<>ȫ /u}(v[5#ʼn-墯)#69TYC*?Ԏx{# +k | W#BxΦϪN8tvO'@,A|8}2yF?GXQY5Am 7yl,դ /#`{" +kfsE?o 3^23УO*I<JJkRaX=zwq{*\rut &ǔDˈTz! +5ZwR]ʼs~ &]{_ǖ@CY_k2p 掃 +ΕI.qsFRUO6SW+#LI#|DTA(A8щ<Z.uZ(.Bq%?��|@N(?Uᕺ !CyiR)U z;E rEuO,L1 Teڞ\]L&7~K=5p9{5t(~y͙}CLEg!cb\!7bj b\{_{= brWoWf=ϲ?vA5}Nt5GM>*O "6ۨMߪu-& ( 9@n ?#${=4aކ�Qt :S?s&/</t^{Q!d ,$yznA3ЛԊ[v&0�b̰ endstream endobj 146 0 obj <</Filter[/FlateDecode]/Length 1202>>stream +HO[eS,-\9Q0"Aa؀Ad\6YqP FZ(B 6ƒ1~h̿>\n9MP<=yO|y_Eю7_Q.y~_`~>*?G ;��= d??y\]))ݵ���~ڽ{���?'g���mSנ���vs|~ z��mГ wgg<RUP*[|☞y2v}3J[[S},Ow-O:nNW[g[juLtwq[G6S!"j[ e1v2?b.kdcDFKQzCY176Vؒ<g(̚Μ<*]BL"'Z1T_Z#-eT9`ʓENJaMP 5:C+ϫ>wfL}MaVt8͔qnD!cˋ6kȒmni|QLx[q}sy9:XZs,ߛss9W/%I }WݮEܮoq}}1{hz_D]juܞxV.c^lwh)/{_2Kޫ6&2Ԙ$2tuq6D#F^X{[5i1SLt}RZ9LO8L9[qn$s_߿9`HѶCA a.%6J^ǹ<lKs2֋Q{ [/&uPuPC >wam5fY'> n"(>v\ޛmﻖeΘ֝.jy~^qΈE/bM语﫹~(M^ܣF[UU#6iX{"¥x7%Ui,+ <SYYVD=Ћ���oѯAO���F=a?��h ��mk3��ѯ!XVVFz��~ 6*Zbqo~f���^k3{{Fo\\Yk?���Hrפ�� ѯA8#-���~ ZV]S<?F��נUbX󸾿RRk5��F[WC ?_c@C�J endstream endobj 147 0 obj <</Filter[/FlateDecode]/Length 754>>stream +HKSa÷| Mы +ШeEY ˗y2[GQўG~8W��.VT[.\T_Nf \V\={^f"gC.q;���8ܿrw2j|Y=~?=?Q��o=VSQR".^s@,%/4CMk3#R>4���6}?]O>NϬy=s��=v?yʋK6q2���ldwi]XJ��� |vbK��@V7p4/oy��� jF.^ +FxE<���Ȓ؅ /ZYKH���Ȩ.0^vaGלּv]w嫞 ���Btp6x]6$ 64تz&��� ~֞؅޺Em1ҖU���!2{Yr"-=]XëFhEL���"aO"#.vbx_Sz,���G<vbO}f���Nsk=%FS?Ԯz.���' =r/+sRk>!ƢiU��d񰖚X D~FNrGޖxJ ��ɖpGpU5G��C� endstream endobj 148 0 obj <</Filter[/FlateDecode]/Length 764>>stream +HKq)-JJd?! BQe2(5ݜڡ(ι4!4wΏؤ%{!uh/"<t|;e%'{ozl_%Kם:4wh~~շ��(cF,FkU6c`���La=K2 _bϪo��0Qʉ| '"یNǐj(bo��0QZ8[dep|WYV<���%wct?[wA��Iw!5w-:FkU~:BU��`;|Bs)'>���&ov2:CvFZ8[��0_~{:]ꏶD>QD���#TTurGPiOO��L𬷷X]ꏂ+)b#7��`i&M-rUO01?r쯪o��0A2n dt?|p~��rw"W,_ܙo'T ��M,?|Qkr=+Q}'��^u&,_t5XI!^OU ��31;=a9]/:x77��٪X\_ ectW FƮG���:{k`q2GժO��Śsk?{\P�� endstream endobj 149 0 obj <</Filter[/FlateDecode]/Length 1386>>stream +H{LeL\L+u-lVN͹іYf exMťp.s*HRZU]f-7/459ޯlg|��v#_XG1K>I ƌuVMc{_s=i+��/Mo7v5w2*tKܽW���_T[j<+Ϧ/p$,ݽW���_Ԟ.%^/pn_;XDN��'Nrdے \uN^?��% ɏKe׸?d>:K 옱a#ݽu���$9J*We30|#\Y.:&H_п_?wo��H~)$OI|g?W?VgPg\*VXRGm4ք{���D^R䨣+\ufi[S51OYw*E)}RW mr >��W$ȇ$Oޤ9Lr}#lǺbSꏦ;  ���h 5$GI~,v䫐5sf0|C{c/2)uf>'-u��r6Nts̕ƌ} +S2qO]o +**,1V{=ƲwFYSI��S#yWKXQКYOt1lnVRk18l5;ncNIXUY 7J]kNN7 +��x@%9 ng(SVx)OQ#!/sKI(kN#ST{y���^$_e$Kә @/(>;=INX{Eu?2sCY܌y<���p,Gvqo_tlĪ/M{G=2 ++MyP\n~􈵤e!yD���#yZխ/W)9svAtҕEx;:Ư[yY?gkz?2R :!kJ5[L;u{���Ƽk'*sOߙd$Om)KW Ss=iݭiH(:fi3t}.d9~/>6i��eIe^%yjeAAUT\7|ȃݮixE0Pַ~}y|zBȰs`���:aUo5}sβyM#&?UeaOuXUtwo|HLUoٜٝ2/Ŕ 9k{��K�ݞ endstream endobj 150 0 obj <</Filter[/FlateDecode]/Length 1562>>stream +HoPu(r=aY֔4Zc4h`I$q!T<ŎP;0Ѧ4MQy}p5}x|sOK;Ӕec>iͪ8h+K,B&?+�:4p )܌7x_luBնB?ؽjNcMX1ػ���#"S4L@uv`Oۋ: GafAߺ`=;zm�+VWc1߯ǗL3 \ˤ'xj����M{xe6n3r-&]5?ۓe۳kyD":b?h^K[m3n1c-#kT}2����uuX]k^LpUo G$wyEl~A{ht_=&2V'ۓ"|}����xz)Wz\?@I<?|bÜE[M+[5bTr���@R7Ωﰭ kʏ3K[5J|<WƓ䥬F/^RΝ980H���HjI<Go쾃h.e^zqn-44QڌI+vn6e$y���T55KNZxJ" 8,/Rs>=Q#���H{P\;J]Ԯfl이z 4Ą`V-pV5 zJBk,dM����R(؞>:ǵ}<,$R4ac7,w4Tmr���#p*`dws~ mica�%rQ^bÊ0usT���DrtƸk43f6w&KW?@I?oX*/M3CwkJ���:z)֡~.ЙMhv0[Llc-=G���9s=C]:M17LJ&ݐmͩ]>;���;nLqm2M][AL0~($lgNy)���+/15cU}CCc0qGJT?@iмźAf꽦ir���74۶SP8ͽS{n*$?hp9fA巬,!C~����=2M[Gqd.g7z +(f3ĝ:[gu߄3V'm"V����z")2_44g46�fuas [Bzr+����<>\I=kB9-6[-/F/hLu7~ ����[ k:zA]bekq0cgj r_�Ol endstream endobj 151 0 obj <</Filter[/FlateDecode]/Length 1355>>stream +H}Lu񯆈Z*,̨HeMpj * +[K0Xiz|Pl%]@PmV9$Çv߽_ng{��UJE;Gٳi]j{tL{qDc�,ܛi۳ 0m!SRu��SWIb옻so^ضdfC=UۺJup`ɺg��p/֝%SW[" #=t}|uԤʻ47_I>\8���>Ny:#/7<Sk2K�XIwUUqS{ʼa��`T([my?z&5 fh?qlby+.z6`GZy���qN/,2vK{R3>pr,f&[e{{ܱEǼ3t�� 3}rasY,+=#]??:9<k2kuUY=���N_KM:%,/1%΃ٱj'#tY;m",zF=��c5[diLfgiji8~&+)hqV ��hUYmtIU['Bce7qLt m|D'%DvZ/HL=��Cn[g5vJ_{7<]GRar5;=mm1|nst��ħ +^GϩF'""]նim]6t��'`lcHHVOu3qLtϬPM;BQx2g=��gfhȻYKPp�O!o*ut;Ͽ_pf��hՖD:EzU?`&Wʖ?ؖqϻ,#ßO?A��@tQqe`{te1o%C^hkCe.Pրmw3��fwEƥ35Y=qV c1 =?d<i{#u ��O*dcHH,ܷQ cDAr_>[0MZu>..J='��`nl.N[wVE]l6{%k$`?䭩m^2'HL=*��`Rw͟`wmtvdUg=w:4y:z6X9L���[: endstream endobj 152 0 obj <</Filter[/FlateDecode]/Length 3929>>stream +HyTg߀@n(U .ժ(VT2 +(UIJʚl eQ@Ngqkp3g:Z)Xkr3S /Is&/7}G8GO&>%e'Qf6�[+U͢sn9 ɹ/)Chtp.n  ZT#%q\_ MSX͂ /VPܣ=BAD��h98P/o[mXL;DP])i.TZc +  EEQgm1r9VV%i7h?<2~Oa7OVs5-CADK)Cǃs<wôa@ uBmiT(BWu3NL AA퀓z4<C;Rm[ +.I~_!C-L,z8d"mCAD17D+&o!#L;DQa=w{;cSU!-iQ3  MZtr5k@}2Q#L;DQ%voD%; } Z̿id`tAP#hVR3;dQ ˍih+?þznB!A?AA~M{1NS!LD[Q\^'8z7 ;592! a?G;UJL"#L;DSCNEM4w>/*8fKרsXw"@}t~o h ;6)=[@I-=L;DS`Nq)0}<u$)m`ϮQuj)\Wzۢ⫋ϧ" \(O;-7J)),o3=]]rϽ�9֩{̊�?zG\K2Te +AADkICǃs<ߖ1ih +#-hJm?ylPhy}l6n=" +2{d !wԋno h>3 ^q>I\) +`@4Qn\6ose6/^3:uPAE {i zWo05{EADn6]=U�`@4*n ,LPZviB0ԞQ;OrU ;!W*e;  &�P6P߶;WK oOcy0 E>F;I񙏯H4!@E3JwFos%71Fod b`!q]I쉷fU砗O%K>:9-;9G$%a9L%eTDW>vW7k2vcNSܫ21O//i)ssD%RaqU=PU9QK*I(ω,J⤞q-NIސsc}&2O +oK7݃L>#V~@.YJl3gw&Ʉo#b1!1G"ԌXM$KZU-" [>\Kv8l"n;v 4M + 5s?%0ŧN:pR݅woeAn\uI^2ҋvHebvb;de?b-|JX\O,(.(gY~He` OgDM 3 xn}<u<ד+lyἪ/ 맪zxa~ Ӯ4%ܲ?3B?=댴NSǜWBSG?^zo|EH#%'w [-'OQz!!cs-ݮx׃?b]8c(ae fgeٲ{ =I'߷G t w{;;]mZ n_c&W~yҍzk&?YcTIʡUi;V:XG;mC|Z<mv9;]vßo S;jrVw,}8~I?XM7 {AיB^K `n=:.(sw\dgltMDs�5'&oQfy3ll9x:#l;&PE'JSe97W}*g=Vp* ùxRs�AyׁO~ +Yz1 ..3}Zz“c,5U +Zg<78|.y{/f^祿W|z%6E9òӒ[R zEww B|#8~ i!FD~EUqI@J%"3@(F 2@QA5n ˲,;0.[C1dNsNLRЌ3rΜsocKaG<We<@ !ǐ/3:J-_8_kmCdbi׊'眾M^I¯$d`^;}wcRy:b |܉Z%8$ԗ&k%dgumM<99o8qѰKRNFb4S n$ hzp�J->ӗ]e.W{4�?>ʂٺ ܻ_yZb(0zO RЯ! i^X!GN!{"3-M"?&ßv0.̍/b0W?jQ;R>Y~%XQ|l~]t@um5Yɤ +A(VN\/rEՏ6R^`o4[va #{Q#G%/y!0P#1,L'%:09+ɎYy١%Ȯ-%ÛbA +ڒAҴ{ݟ%#}{<CG6GNGn0U/0bfje& \�hh h �#{qy +{U+a zn$d1q_`ŚntЙ;`/ַa׌]O-;K?.fa + FgL^~냃r;kXy f;}s"0Fь#/Ǚ 9M?"-6f?sQ>⃂4q/ 7！m9N p29sUdUW[A`5 s.[q2+i?1W&%)ȹn?Gdl Vdq+Z^8_$+|XF5aЀpZd?ޔZ.3}gtgbn1]X>LrJxy1y?QH wԠ3@y%Ӥv/^)>G;w\i|W3YSvs@3e"2*:iuvZMl"~˸¢+fF�wJзsq,WqBmdn=г`~IIl3_iQrҞȈ7N{xځQQQ(RxL`8~vzc}ȟã֏Lf儜Xmam6j T 85Er9m5KslV 0�  endstream endobj 153 0 obj <</Filter[/FlateDecode]/Length 2497>>stream +H{X?MGzrgk\ZѩȱPiRJ:!S,hfW(CtQ.vCuWy<?z^fzo'=07m`3+w/*rANJB\"(VH%wLֿGeƲLuMZٍ'lp�p  u%t* G��JT� �@}>;n$4 +-t3&Ϛjx?k-L9>yxQs>.;hЧg 6=}dYOACEGِ4EM-yȹjwTh- @ߒ�d:Wo q^aAC(VDv(4vRi@tHp|\[7j4dX'LbQڹ뷎c^sү祥lz:1|3ƍ}($<RHbGowYs29l;m[!c}&k[]dM閺oB7'{c5^/xO}  gG'w_(i;h<cjx/;֮&_aIը~?;AO@;P;:#ڕnvUk8E)#yvșAR4P]Z?1MAWG( +rOn?m~]5M#w lx2ID*u:f;Ѷa9rE5 o_jgM2zvr|A&>14 c9љ{ ~q%хpMRsҿ G3AX}tjVE].H*e$M/gQ%,IINCH?Yn;ƴGk"{sեH{]\)JjHm"{np F!ͬ[1oGFF`n:l&&f',IY,+э݂P#\oMa?dJ~P ӉBAz?8E@sD5kWpNrS/:R/r8Y2.cOaA&YAQ_&]$+3va2Z"�j79#74x\w=f^wؐ` ^TQQ|AbQj.85^RFpMx ;L<\]`Xmp?sA}9�qPY IGMjWr&Wga +,{!1|߬#wmIJ 5Y8l2[C]eۿi3䌤|o@:ӈtB!/qH$+ 8Zwtc_ԹSj֫\U-|Tϳ]fV`So3Ka�e>݇M{^  DGGOGZF%fꊵmmk8ūE%⏺ 0s_ S-,A_Wm:NvTpNq2?P}U?,WZ_aŷ�7g] ҤcҴξw(M.sjJUwt  'Q3𢫴WXk}*^gIyQjNëmبf><$al=,W$ɳO5rxOےRFp<s )#Y:~OۃA@z'@sx=uVe^e.2.j7"yA-Na؆r3=}OEA!r,w 憻hg,my̟{!  =H^8+.?P}]?b&6AAz&D H^X}ߘvva92Eʺ3մ AAɥd&/T@;`@ui{ =%ܒuCAgQ"됼@;`@zG +EWo8AAz eE٢zhg(T͕;  =J 9G)PoK#RIu  Z8'e& +COqIYw~  ]d�$gr(?PM|J(f$wjBh{  tQjrmhg(KA#MtgH=AA(a$wd%lMPWoB֒4vmCA*/9#it*m2� w[KţxQ<t1@�ɓ endstream endobj 154 0 obj <</Filter[/FlateDecode]/Length 911>>stream +HKTqSF( +.&TP JPYPQvCM,0(J(삙45#gL-(5/tP ZTQJyf:3xs}F5&@a%UǒV[q|nYi4{ZJvҞ��`|xk{@&o?DYjgݪ?�/?r\־E Ǖ"6U{�1`]l3Y2t?RfU^jB��0>dW7}?:V"{m$I{�)$IrLAc15?7?Wѥ=�io!ȫ<H3M}.�L޵ o!cFeڳ��ֆȾ}{?>V=2ƏB��QCnjήо9;9,YK  ��󓒛g;׫BFp*y@~9 ��CBiA $إ,80Zo]E'g%��HoEŲqB]8Qw5|ڣ?/�>o7վ1D;er638P��۵OҢ7c!JP??7�@|djߝ UjBbG}?ûӵg'��ϯL׵o !nCݩ)O��@߅;57c\y͋g(��͏-idz'iBbv^V9 +��#{3xZ_?Wkڳ��Dk˦=d[AH|��4" endstream endobj 155 0 obj <</Filter[/FlateDecode]/Length 1250>>stream +HOu9,L.kbaC]VA44aY +rpΗp#85Y"iN˶ Z?!>0/~9e/3, =vqŖ*D��gr_w7U_9|9wm,}C+ϱ<ϵ&w{oOP=S�n{큪o!w#�K(nvO6/RU��01.V7r1r̘+/��`b4k>Q};?^?, h=hP=[�xT!N侖{[@ dz1z&1g,��/WL U}3?~" l.3��uϕ^gתo!c{pC{Ƭz�Q7gr?#o!3ǨDQպ��`vKiշy8QrW_sY^hIܶ]~ ��G˽Ag U?㶕:mv\;XQ]ju 9mADjgz<eT\��k˧~V}#F zL lUtC;v,c~.��Fu7rr@d6D*/wJԹ^oYճ��m)h=AD巁?lI$:j-joC/d\+W>�0_=Vg@/dd߶m?ɱ+}x[DqB[)3��k+:S~XMr?b_I U~s~cbr)7D�(.焎%ZEAucW F-Y:Ku>0dg?&6wKpo Tb��v{X-'r 4LlZTc _ 8[_nk-U6}HMeYOws!ˬ|�𠻸4r|d|J {;AR]^y,bє?6T}ӛЭovjG~ �ZoӼo�w-sWeYnG|)?G\zEs uC��<䞕exzD z?C%Yqiowz3e ۚ"Z]ymg3�Ϳ �&I? endstream endobj 156 0 obj <</Filter[/FlateDecode]/Length 2229>>stream +H{PTƿEvDs)$Mf& m;%d4*058Q@]1Q^س]lniF *m(L?/&@Td=<=g3X&avc]kMBUw|E`@ xH$yI c[w%K$ho=SY7\ +7Gq;cgWqjG':c͂Ȟh�8sX-'Jk,QOeP�pgsw, ~LJ38<^DWW"C$h: sܷAk?i+ 0nhnwGyuO-龰SC=>Q$an/O�w9-ݡvcFB-@lLd&EAju zǖ XU+ߺ]$gCzEQߨw�[C7 yNs~92Ϗ<nDJtI3/=wm>/�¼9?dgNזYz!C=QOgϞ*�.)C5O�WJ2~XĄ3WWs5;vnϓ{=#mԩ>^U0^ %Է;Oϰ\_&^0UYlyfi/cFݓΑ/a�9ͬ^PZ]AX gb[e X bJ{jX^!t 5yc]e T8+c9 y9&"/"?"Oga�bYeG~#-O]2$@*}l�ӓ$-$Ϲߚr{!uKS.0U#iw(uG_jE;: g7˒Mk,X<�XZYoTT߷hTU\0Hwn35ߨ.Mr_a�b>lѿi(_//}{-gb; i5,6'%i!�^ǐ Y%>""/HP³g3ma;φbZGӔղ`֨V֛UGN& ^ ȃzOIc3�<xi!!=Cv,g &\P2tE1FAAw{y53O(=`zrӎ-yﵤiR<\c3 d/΋%#gldTF;ӫ�1( oQ~ ΢$΅?y4!d2֤V6UG.OߟX=:zM^U /1>*>;=:qT?pA׼BUw{|P%č7OOx5dC gBĹ^Rޤ'/J +cgbՄ{T?pA9 7 +;?;{DG1l/O�DJeIlzWݪ@_EOB5~̂zO{zߕu A$u΋)@LzZWXNƚͭQ@\`=gM>y%!29izO{C"}%qdOYܬ9r>+`�qA[zYz-qdWlaje=o�C|fӤtG0> z[jIm(/>I�΀&i]=†\*BW &&c5/,j=u_7Z3�̨S}+yfa =w^DkŒ0r־f`�3%Y$ht۾|3cw[N +s}dEӃiۮ=LTE06`AC4�<,81$mWz &&k:ɌBU%j* q�OܐxW/Ս <i;Lн}Y/'辠{BBy>@2|Qo"\P?ؘrF~ά"VXܴcx ^߶}IPw6ћwAv螸i:[CF\6wp/ғog^ӑ]#�P2 endstream endobj 157 0 obj <</Filter[/FlateDecode]/Length 934>>stream +HKlaϵ%Vl7"ԂHѸl- :T,!D\*H5mEjgTiƌiGI&EEP .c)<䷒n|3bTvstbgx|&X0a!nuխwOvo'߱|]krsoݱ_>�`-ҝK|bKiWl�6]픾|bHh0$o�y#xz7cHLJnS?zXܬ}�œVWYw3)m);2UE{ �^dsّ)vbS}w<l(i׾��~#Po~xc蝍Nz8Xn�`w'GĦ?zggSޭ/}�0U[XTzUM 6{7}�0i#GTM 6{8HMSK3j;�)7[•ϼItN7Gdݝ"!=U�`\kvAl +o<NPsj{�I_JoFHjwIĦ?nv_OԾ��Iқ+NLpӰ?MaϹJߝ`L�[IOJ_WDbS,oPyoYo;��nel˥'<CDbSW;��n# ־evgAl +2n,oӖ}�pmJO.vgAl +c`R~,}]N�ҋPS]m2)쏁1A`5ڷ��iɒ~{({vWAl +c퍅j\ޠ�&}(x<tavGAlJ"��Tb endstream endobj 158 0 obj <</Filter[/FlateDecode]/Length 900>>stream +HKqo dҩbAXPAdHKAfa`\ \fK%C i٬nAv/o{D3=v=OAfS*px3��.>J7Wm]M|*[0[ߋd`{��)]g==&f ?qs{oL6~� st5`{jd|fV�@ll[MւiG>ˌbK��m!uƘϬ:S%d-?q9i��5G*[ 44Tx#��^d4ۿ7[ 4.znbnH��~Svln6LӸ?:$WM��o׶{I7Xin)w>Y��~PR,^?qkEx ?MƦ��f6=?d'^?qoՓ}L��ڷ}mv\9\Zq0MF;ןL||'��5۷}פ[4`ljY}sK/I�\Y?bVtk5`{cיyxX��Zp>'Ǥ4im\gz1% ��Bҍ17}nvLӸ?l\gv|7��[=kTJ5p0MVICI͌w>n��Mq6i ].TWx?��S_ۡctS4o5tztC��S׶cٞI75_p0MQRb|<$� �&va endstream endobj 159 0 obj <</Filter[/FlateDecode]/Length 1221>>stream +HoLu�/0#oV6롚J'm--&8 tXox"C0\p4Y<ޟn?x"D 0]wTX>VQ|M`n荇V5|,k-- ͊LMW\[_'��G7./geR-a@ +CMGst߿Vu��8wTwְ?H V\i:`ݦW��xSjRݝZ Zх n�QF}-ݩEHaW0fu:mwZ��&kXx +"1CugjRޟ(:ց߯R1��LvJ+՝UHa86tP}��0/9a84VuWjC~U^ c`}Gu��0Wx]eYeq~tXe* +^�{-1N,VݑZ GGY;#4+F,L){�]B\vO57~RݑZ I)AO y`>O4�ЮtGTw#w3_6OT0fu9m2�@{:2w ՝1)U溶-iVbSA��.qz>坈122+YJqR6/ ?•�@;n'9%Uw!b'M0< CrwX+OrTU+lh]cm>�>7w,dB< O: Τ٘ӉQJr|Xd⥢jf7̕ue|n6s(27-K>@~6tl^��Oe$兩@-g2yNc_ʮ 39$7$ ۾c2?C+TY1pinSK�e_7ީPJėEݸ).}sgJcsKNU8m{?QM�WϾ|7>OW}A%mNsA?5wVUv•\�<W +y:h-Ouaz/Ka{76mv�< []徥0=+�CT(% endstream endobj 160 0 obj <</Filter[/FlateDecode]/Length 912>>stream +HkqOk.\8J XLI%帥VHsnid_ (iN)12ڝώOW=O}߷1nF1^k6L7O+Ԕ��Bode]1ڭC?MI}v8\+-|P�~ғP;tFusiXxr[S�߯G+JWon4>V,\-�J⍑h `..,3G4v�$demC?K³ <=�G!]pfv5̥qgȖy4Xc�,tDz4t sivo�أ^̟~];Te:Ҹ?q9_UV �ҍs7JG[`.^W�-2*=`.n;gk憴]�WiQ1Bq0aAsL7�@>H' v?K_餁u+i7�~Z.X|j@fg?KpP`q�‡tAމdV?Kpè]+6=:�@hBH nz4wlM(o;�>taSNFw?KpGԦ&a%�蹾AniAAQҸ?27uC*/,1N}��=msRnz4dk�/8Lnsi y]~F�£h7 }47r0Zۭ;~ 0�}`W endstream endobj 161 0 obj <</Filter[/FlateDecode]/Length 947>>stream +Hߋy ֐RJm.~lPc0~"6BJpL{L D11s]?:gew7\pAj}_ȅ{|z8ϘF 8W28>-wT;Q !{;Yk W^b[^u~�'^v!8bS*޾ \߲S�^Y#w;b[94ܭ�^F}̩=m3[7>5_�w;)w_{<)-<HM/;�ם ˝_{A8Ħ?a[㞌|ta~O�#w]yAxĦ?adsMוݕ�]ջaU?[tv_�˿f õ;b~%ș/l~o�7}Al +#ZV.6dw>O;�_Ͽ=-G7+ombv�sh5 hw +Al +#z~X;ԥ㩬v(�yˌsNA~?MaDme7՚.�|gWw=a2.A?MaDƦ} +�\}no8HC_bStӐn9%K{�qKzNW}%ݿ|z Ħ?mJuYAM=~o~n�|תʽcevw Ħ?Iѡ +�gӿ `u9tt}g~�ޓ,)d +{ 61fUʽQZ�{=~\i)s͕Po�;0]9s;[�+y endstream endobj 162 0 obj <</Filter[/FlateDecode]/Length 1397>>stream +HoLuq('".J Щ-9w;B8t`l1hP*Z=)Yasv J~<ܛ1&լ]*` +$pXV��zY~}#/Fs=0ƒ4_bzV2 �s 8D/�a Z +LwX.[{�� [Ge oR?`e1Lq6^l2�� .)}O}&?-y4s[w�� xON/0[�@Itf[GOq�� ɣ1 �` "gHfu٤~rQw,f$#58W*Anw�@˨goM+Կo�5;w<戥¸?;ɠL|Oe% Mtm|wEo3�*w)HO~"b‚6U<HFm+}�ȥԳu%;ĄOlb<H@:vY_nnM�zխwgoyw> 1Fg}majiR_qvٞX}0]R,~l-묋�E2@=˻A\q٤~m6gYYA;c6S%1CN~:s0W{ B]f�hxWbjRYrb@sr?<y/G +R=1X*)M2`(s{޵6�u3F}ZTvUs0ٰg\6M:tYДߕmp FH&vd7��jDaozWyw;y \bgi49hg}|ب&L\ŅT> vn;WOn�FvK=Sޝ_?4D~~*G!S+‹^? GV(0h\}�Pgԃ>a eoҎ=3eUd5<%Ѭinbl9�(IQo6]OVhW᳟_dg2=Hz»Gq}KuHo:�u=y{Qw` f/;]UnjCNSy->VS?z0� ?ZS_zzww` Z +G@:ftW};�\4:ꫨ7yw7`|̋cf_KEW];_W�5 endstream endobj 163 0 obj <</Filter[/FlateDecode]/Length 976>>stream +HoTu_ vaW6.DD b0u(4mY4u42v4&23!3B^b &ZƤvjwO92>?w<ǘQ}cֶZӹ+ǝ[B==˻PU;ZA�$+S-'ŋAl +7Rv e{�x*Nl'oh7)smo ߆;ّ�IzPR24&(nbSȧ5+N_GA�4Hzj_nPf?)[i_mM7��hxiolz^a)Xlc]e/=}�@!5c3] {?Ma Ԙ@*J'³W�PwDtNOzPa)z3DNg��$=7=uFzou ?MaMuG}-Ouj�Lg݁\iw/ 6uGxv1i��w䕵s>vNbSpۆ#5?9'sZ�'5P\Nsa')֮Z3v=y�ٍ\}ܖZ؋Al +g~}3�@>ܟN<+ݱ +}[KΎuw�<o6Hu{jw+ 6BZ'Bi'6nտ�3a5nĦ?Ph3ܚ|ifV�Րޚ)={Ꝋ 6 |ٱ.Ӿ%�`5N8+%=ݥ(bS<U-oo*{�?5pTv?Ma@3w/i'pew�)髓Nc/Eia=& +ѹ>ҿ/�Q~0FzJJzK;QzC� ` endstream endobj 164 0 obj <</Filter[/FlateDecode]/Length 996>>stream +HkTw_*ԈBu\u h(Dm44J6Q#(H5LJ8sg½3ŢwAFIB$$QKh\s"%7><Ɛ*sf4Y׵'k~yoE9tk9�Cz{SWڝ$k?msM=qXD��!}4 McAl +AQvrtő2�ȭ KNLH7)I]-ON;�&JU9nĦ?$,6bdznQ^@~^r(GǤ`@Lپ8iel/C�z\]>D@?Ma |a~vݙ[ }s3t[8C]Al +AUrtm>yڵ^'EwJ݁_?Ma *b}X/`gkK|u<^ 6 e96S �vz4@z^ 6|i̜d+�v^~iJ<?Ma *#&9w;u +�;HHHHhw&bS\p]S�&=rʂڲކAl +amc}7h [1_�GM Ihw.bSSfE�ǵ҆ڝ)Qybۗ7~�R鏭s x_bSԱr;Vg�ól,jUªŦnM=ev_ ~wgJ_Ե6UIhw0bSʗs%�&h&,]h?Ma &o[f嬗|pu Xd\_hwO?MaEt7;`�dž endstream endobj 165 0 obj <</Filter[/FlateDecode]/Length 1919>>stream +HkPTe#7&GL fM3f#X:.$*j\ՅDDn²{]%%22c4:j6ǚ:O  rfy}}Wړ8xj"9�R|M/E󵗂gp(h/:t\-1w[C1i5�2GsDœ8w@@ɩ?@N‹v:4ﲟ� s}x҇?Pr*U[t/ t �p-_N (9QJ]L:7zT[XB�Zɵϱ�5{LT*:NCАw5 WEtoe=k<II}Op&;.QUD 1^eW<: O K|yf}<�F֟=i [oQ� UEȸqw=d1f,j9=)Q#�N>2VE"{!ܱt%%owSC�Y$GЬs~ԇ$�p.k=@?PXߏeoMzn'I8.Qwu h&3WYyBz^�~>E�9C@kU G_My{5)h6nޗHs�<CY)=@?P(_oa_*E"Nrn7( 1>I)C8&K4]z\�<_~f}�4H/Boz&O!N,U&ñB�OCJx 2ȍ/�޽r/1x +HפG>\rp搩h]a~EX)OM:^wGm`IK}qqSYHO vZT4\?v0y +�W3o?k3Y%�#{g2Ӑ?PV]pa}@#(pi q6mt~\ +�F}JJ}4Ck<l6~3! vViϏdx2 6fߎ,zH}ZԢA}�p5;֚HƦϳS6kҳ<r`? JZꋺD׃XY�p7K[}!+;֒yrժf/,V}vCtPk?�s㥙Tꅾ+^d=o?wE}Ybo( %rU+L0-1ܩUzL0M?ZZ37)ҾjsMrC4]XZ~pۨ/gi/m3:{%ժ4z]SzW65߉cUV;VJQ?лw)}Me?+hb&1'G�Z~ݓztԇԏԗ?Pr*W EsDOV:3oOYeoܟTh矷GAхCД6cA+aVv4VFH}WIK}1|{7 f+oZe(_La{&#bX{ڴ9p<CB' Q+(9 mkk4S6*ki(g}OV!\YE=GOZ~4wdPG}n�` %rUH9?|ahݴP2QFj;7/ڭ;u( +5ʟ|3Ђ$/xZ3ٛޥrلs|+rHw*?;1-gQs~OŵcE]ЯkNj,5YpSxbK�0 endstream endobj 166 0 obj <</Filter[/FlateDecode]/Length 3229>>stream +HkPT^hxf$ j$&ZE2jD\lTaW@Y,;rYV.휅"թ&6RoK|y.G +r|s >k,;:63^1kܾ V_a'x�@\m,8 sY/r7#.ezCSW<ʅeP*Iģ>C;G=P{xWh2In????˥5Y)iQeZٱ})۫YY憲>yWC{ξN 2@o$2;�A Ӡ_ cp +txgɉ%&_4it_><Y4Z^r +}cK_pºݺ0ci _A/=s +'fPof```lsSηL *&<9SZbs6R 쨑O9:]z<3+n񯠷HkA b@Zj1} g6B/=ե ώ}b>guro2ʖz.2s̱\):)rQ{n`or[ZgXoN< +ϙZOSvI~b̕Wb{*uV2(\nR,[]LOCqzEx\W&OZSX^{xH£g20uO̧fgkw& +wz-ٓڻۤ7]xɲ>l~Xڸ؊RM 9[|lO;>RۨoG߃:l8dIhamS椯~WOߞuovgD,\<HQ]N&k3ZG@"Njg:,߸ez-a]lecC,t=F5 IWyj@Ͽ:2J\V{ /O p﨑OGR +kU.{H+"E<W;̝oJds4:Օyq5  1E Psbe4f|%Ix+*7Å +Q-ۭ+9 hd0< +?WDϢc3]2i02k"Wq6gVYzƑ~WVq)l AF*БϽ$A!6aR},FU43O |h\o 2-}9ːq=u}"4uŀ{/>]J; iBH.=:NI0EZثc,,sCR/!+dk(\>AFh55 #b{AAϖL<砯/Y(wV)ks~koOfgڜCseP*Iģ+kaևgf>}GGaN??b5_n)h/}8k+<&C_ثκ\J])fH[EUNRvF=:/Ɓn@?#ZF 1pȒmTSN8;}/4ʬ54&mCuS"zwI=Ӣd_c/MN/̋7g1>?kl. z|8hez- ;j?Z_oNlR +܁5p0Vven x//!|IYN9~t[[w0(NWEt!aIS �2e-qzwa<lΞ7-^Q!'(G45B.S:uR0OۛG2m#g?P{x硩+<fkkogNuP_Rii8'p8W=guŨe!O;Ҕ1^u_E=*KWwmW:>A y:dWCҚE 1p+Q9{۳Nm  +w�}*!US@Cxv,elmeAHۖ}(d`) T M}{@n߭@ #b +r/YF5zxA.PE*4iM"@!@ CClEk,o~]<x_ C ,s b +2t,RS6dh_9t C=yqĵ b"P(s$1Xm15{HY{`^x^v5C2:9LFSnc%?_ee7e5oᾓb@崗4^lZS'mЗIY{kgju<*1'+:27W|YI%W}Z5QJoD圌>ý۪O6F(x1 +L[V\[mN0ǓeGS;ϫi+=p@!u+]ǝ~ţ\i (ogP5GpǣQ0`O.ڷv0g GLcb{c" &ݳkF|[rbb1(>9ܽ~AXk(#?FpѲvvM+Nb T&pˊ֮`= >GN雗ںnU{s7/ l"yy[fϲ+Mܰ`23Zd/}݊ 3"ѫ +cd1XCԟ{ΝkW޲nŕ3*C@4gaQւv}]Ȫ)$ ֭>g 7!e\͠^bMjb> +s O r&78ݻa~kgl68?NY/g-C~'}@j@q1}Ӓev2 tڣ}V=kW=8n;S] �-& endstream endobj 167 0 obj <</Filter[/FlateDecode]/Length 2112>>stream +HkP_MLĶQ;Mx@2IZAE!&`�41$bR{=/!U؍ +L*F4mSڮ?0~v}\=�Ŝ3fPW45z<JSmӳl%=!ǻlrq1$>f_խ7KBy6.s/ qy6KJ|0_E=E N8iv"3:ߟ}d3Ȝ<@d3Yդsw=WT1ܻ plIe i1\=,hή̬h)9gS\pd3.߳#5N<@Rj plK9ByBRTNq ri6}]Ttf_p'@L{]Ɯ6oy + x}$ K$Xy(vˋt8<\|19N;@~ҵ'xv+PAZm:2F*3qYߕs*Bqs@(g4V�2V24/_Ww#hc>b0N>ڔD�)IjZAVB(n)g(o(w%@|cj\x2J8+w;I]pCXz 6xASV_{Yr>צ2٠ݑ\8vTo^q-^!|0umy;77wT9z r^wcٛ�1kXyx$zt3 vˋ\VC,:�LJB៍^+O!0R<1!cUFD;K_xJ8㩿(kf'2KbSu^7f1涚oߤl@xuӜj{/Kwr<\|nFcF\PoB=�#Af߾=ns68 Z#uR/]s<!$ѵ5P>Q 7gpPo>Y:+ܝ <3mOKkW~$/J}< ?Nue}BR.=A9UZ?wfГ8C:w­r-�#A3(\vSi]۹*ytcLGU U'BԤ0v c)GgNJyG(!k\J8S[j< &x/xϓ6Wxϯb~z:#![q٠m{P*- HyE4hc@| +G3maJ?z%=׮dL[}l39 eSWŇ !-Q~Q%Ξ;R(9PʥI m˕ yu%@LDzo>$%Vs_}L`\`כ-!4,'ɼSbϬ r~B=ec�CLdV7Z*n\X]]q ?om͚sKUޏՌ^1ZINWyg,~gw|]c|9[8ى\z 6"a _?|︓g hGFCQQxiNQ' B8R :zs)؄z;+ 1' <{ &"ex"yb3]ӽDx?{Ǝ + R)_tD8]BCa߉'(lUQΌ 7{;z +�FH?˱W\6uR6ug>,0,ccMjCGo ! sv}6.v2ÀEQy~S#KYeH?㹒q.>Ϛ`wL]q/IŒo3LUɿ@a8ܣc5KzFGAg?ܧǻ#a�b"ڡӴ{3oz'}^IIZ)'?vj>�[� endstream endobj 168 0 obj <</Filter[/FlateDecode]/Length 3120>>stream +HipƗ$BKP<I&4C3s0!llm,ƠBJ1 !i`צ},7JWw{H<Wqm9ܤ>Ig6AD!1 F3Ԩ= :k-Ϟ.8MC~DaRj±WA{cω6m;\ +Ͻ:s0f%&!;dcO^/]~\QW<; j>W<gKϡrH?9ጪD]2�&G n[pd&qdc+1t_c[Sd,r5lsj{aL(,&gfɰk,+~2S5_ǵ5O͸;8ortOK=ٶxƺ-wYjbnkߺu +c %n.rky=7m-!s^CIďj"-Ke.^3m-CRʾR?0[ f2|6cx,E |P>|>|_g5O<V\7lVpNjac:_^\C@YCcYK 9k 9j3K{ 3Y^7 +Q(vZd/'j| N(!pr3Ü.BNRo+A]j"-Ș7,,duԳ5ss[C0\_kj>~ZMe|N.Ce٪r 2}yνs}!­3u׆?!7fh3lVj=$]x *c'<x~{InɂyM||s9#ֹ1c%)7BԢEjȰNJԛzvHװS?ly!`p'{q 3_.SJe?qPwضG"J4XO #`śұwb|6\ggꙥɽed�K~\ZG򚪥u&psWQ/ڝyk"kQGs=<>'7ZXoI[)%]>kԼ9Oo ;?ES/).ק&6x%ߋ5W旧-q{~79-rۀ.N$M|7Y>,΂l~j.]uOƬػm(?bL�/#CWH揽+Gh׆)gwQg#H=$"h/Q_<s~y^';(}ޠ;/QW<J[H<PM-`iǠb:qft9<60A<X?@S=7 24еom{RC g)+w3(u:cؚ|pc([{k{�T +)D}] U~UA܃hj?vu:][>fޭ],ٺ%|s)S ?uׇ+| b,<PC'?.6n+1�΍gp׆b¤/"ɱLx4twn,߫]A_ɭ} :CZ4HrN؞Щ*٣~Za.m±Wy>ڀŒ/eL~[K A{+昃q5X[Xg݁˜YnS>5Dl*r縎sa9cKo=i"׾ X+ϩK}Kq_fgvrVOz^=t=AW׈yk PM-G&f?ΰJ:A{ڭ?wسqkSg ؏}I3MNh^^[V=ky؋5qKρrI,7>Ζb*}U:vN2= s{Ii![IDN3D5ڄ{1L܎!y!`v0A٨CN}.ܺ{xkwJoK=_kti :Е&PM-ȰVN%)L~݉8jI͖>B&\6}mω% D AOrk CZ4Hf0~{iUa]!ho7F}O#cr0.|g{oN[A<:?ES J ߨ\ Cꬁr EU8 \^{^}h^,AjԺsm)vZ=Ki 4|s܎ߴoJ@ȭU ~?ES qi"9o9XX&&r>wOY I_. EqD *U FR8`HC(5xFESs0:H?C{FJ*byzKoc%7z0ށHD"}mfbN-0_V+Sw_(zW?A5WҾ8·^SM_/_@wRֈ;?A?̀ؾL⛯G8|UKߡǕ1;}ND`t +QmSv6o_ޱNe[mM{/vbgOѣDD50E:to4~w)Fs6z@'Jo7ozK`�P endstream endobj 169 0 obj <</Filter[/FlateDecode]/Length 2028>>stream +HPuǿlRbYR]ap*;LJKBȏ -L% 7@ٳ0Lm&`ϋ;>yB.u<{y�SWT^ 罹X%1\ AI sMl$AoKu~!{ A}P~V H4Zh!t!= +-mR^}=m=,& /d}To;տR[@l@|ps˭S-V,kg_M`{@IuRTw�wD�ёL%?T?a2tڟyź=_-cښݭ&ex`T"x'7eK}-bFIkyEş?ߑ/],sYSys9D�b~le#&]M칣۪UWnJ_.ޓ;pxpNݚ6hDhi|/,_o+=!d(Jս!TeUWK +[oT"aש aPUv4}gx@_RLz 0pz<!'qm͆nǞbR/GgH~/4ՃB:QnT?3F88>#�!?CCY7?DY{,wE5kBf#2r|e]rd31ՙk*"YR3GҼiTf"Յ3^'3qpx+}F�B)ȣet?-q1ˡ"V]#__q؆&߹2$lE;6GN7S{t7spqi4yi4# oqp|Oy,ArLWLwEbmz-RdfiKcK,o9Zs$6}s{Oyicd@i<4.Kv΁C-ܻQ26멠3D3.xH:9%MrL]ZGFkwcBK'$liN_ڬirf63sƪ;[婟~!{od^,b̔d ]KקtA,mRȮS̡<gCo q}&F|SpKŸӕ)lݸ;<Zs5`zu +=Skw}Q5 +>CϴOh�wh6eiP  u!9MZBcCEVݸV= !B[ڷ-<发aa_UlɏX$b'Lݳ]wLD#$b)S!BI4گѾ �o)U:oJ$7>LMw{k�������?fWVV΍#W]d5o{ry1V۪ը(.˻S.h�������?2>WޛϕG˘-{|o<_^X0]*1l����������������������XFDL5~oo55&RsAU##fcڔ!;%~fP8a2|OKK![$n VuzoCCI]2&'xߗ|fƋCU۟7\8ؕI:chg7+/,Nk>m1 ͚ȿEAۧXf(GmL[&*5nc;5Ui},Ls=Q}/(ȸ.-:M(dи|e)6^Q`Z 23G?i=_Mk{1i+_kޤ6Ic7٤̾'jՕҗo5=5B gxwۛ_IJf=rԍc,̚7u0gm?B9Dȱ!;t~ltGws]Ys;%�ϛ endstream endobj 170 0 obj <</Filter[/FlateDecode]/Length 1839>>stream +HOw/GDPt L s"FA uatDMœchAB EceYӦ>ʺlMWr{3aeo/b\Ps6stvbcX zRȼuI]gE9sIzSos\#c:~Iӡ;߳h!RXaV6g=ح^Tx'?^1*8~dL{yM߳x|ᛷ u^ckS>Tԭ6Gә\~rqG%3dhw@3{ǿN|0Ve 3d ֧Q<6)ޕU)( d#*"R?;Tb̀tsU[?X4t\"aaa,.*v?(?˥vmCٱ:+׻<whN[R%9AWc{hd Ǡ3ؚsq{7g 獺=F?ʍ]QJ{sޗae52ŔT_ !cQ'j3<14LYiʄDg7o5\/g6d~1e5;RP6`3[ſ5K!\1 uJbjخy.pƳ׻<sx +}Cr gN Ϳok)s!c0+&MJKә\CMu{?PET KPy \VVRrMfDOc|Тϧkd Ǡ3ؚsqº7g 獺=F?ʍ]QJ /h94eb82O͙=۪My^cG7gZdS+]W3ܩ]}rÐ#c$֦} zx|mReJFY&Qݡgkl;^U\.[)1ޜ-Qޜi OKr$2.kP">A:;}qhN[5U +zdJ`ܵ.;++,HDH/U0ZAɏS{l͍Ş^48u6['-X9خѷy52m,o_dz5*3ZO,u~> do 5ՙCvC:GHhB߸/v +qI ocws.i0oΣK3~ʯU7xw9wEqAA[wNC%a 09uc̝CV3f +s-~zT:|aV6G=J^ `,&2,7w֞r!c$jujU+;zeBKWT')/* C 5ՙtM8L3- 6`3ݾb2&=VX8%}{k0mYݑ(Wc]VL|8 cE{[sc}"iAN!2<dgT=:X95QO+JJު֢P,+,X>4cbG!c$~ޣjAi˽]>sS^tL22o"ߵA>}^Ƃ&K\d웶nxYk]|q3VEy._ηkVWH^^mR~oUɿw}m}2������������������������������������������������������������S�8h endstream endobj 171 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 172 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 173 0 obj <</Filter[/FlateDecode]/Length 517>>stream +HJ1�}j ¤9ǹ������lgYҰ8cpu&?Sާa } gm2UV!>Xem2,vo>)7?œSXc7rd7c񻫷x'+vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}0Kj,Ū abYMf)6b׊i*vb׊i*vb׊i*vb>2SG/:1ŒKv\NKc,Ŏ;v\ OJb,Ŋ}fe[Ů3TZ13MŮg~>qg~߮GM13MŮ3TZ13MŮ3TZ13M]2ڰt>/ӵaWkN`J"]{i}DkTk}@l5`Rl}G'4eɪB0�ZCf endstream endobj 174 0 obj <</Filter[/FlateDecode]/Length 580>>stream +HAN$1EAiP0] Ǝԋ䗞%ŵȣ#"S#L<:"2E^Yyu<fi񘥙Wcf^Y2ώ =;44hгACCώ mwǢvڙzw,jgݱwǢv#a3c͌=<63H#a3[qV^[{yneq-(ӣ#O >= +8ܘ|{ rc1ȍɷ 7&ؒN>>:1s2d|^�oAe7!׀ 9ү m]OaD·G^N}8+r.ȩnWЎߩåv Cr(:>b,ə.wKr(Sr&:멏[r"G^kRS7[19F F%5jLN0*1ޚ7Yk߬nxs۰nÂ^z'{Miڞ5'{Ai\Neq9=->j(̫"oRvIe`L'e1=m[){LlQadJ#Ge)}g*ofI��} endstream endobj 175 0 obj <</Filter[/FlateDecode]/Length 702>>stream +HQn@C)QFzҶlW>R晪y.Rb4!ƪiC\5uGj.:/XMmd;#`5vFW7Y]dE)#2VSGt=yj󆜳 W'd&XO:\Mt~ ҝv3y|@Z^qW{Gw^q>:181`MQs|~\?NHXS{߭ kz~\?NX3,b9Tƅpe}aXG|!<rq;[A'?W?uŷ>_rm>Nu-5e{Jo|\fw1[Ɔ"o<dp3TSoa1g_۽'AQ)z2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2B]FVQ* +=w]XE. (eta.sхUz2)?�ʏl endstream endobj 176 0 obj <</Filter[/FlateDecode]/Length 625>>stream +HAAQm<FArFOJď =XTg`Qs?p]+6hgcEMǍW#�2I#�6sW#�sW#�Wy)5T'23E +|o<]x(3SGpv'=XTOϤ +Xa?r?+:l@:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?y)=XT=\J4c҃E^qA?GhG h/oCK ?}@o<M!8OrSEX!z!=XTg`QsуE}F:=XTg`Qs��&m endstream endobj 177 0 obj <</Filter[/FlateDecode]/Length 597>>stream +HAjAQmdP!* 0D]>IԢ?>~x,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +鱗sE q*VlW҃E+_ɻ:O%NJTrry[ľW G(;x}¾+O#6+OH#o8]+6lwKٹ"7B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zۘ 0�OD endstream endobj 178 0 obj <</Filter[/FlateDecode]/Length 2377>>stream +H{LTW /1*>( lwQHb4j2؈(XATy]D^*=3 3p0uͺ+V+>Fk7 ;`4̹wM>p~|A!b X5%|5e 2kuFyc +B:_/=.g cỦ'φ ,=NL9\C{dh= LT�A~=ҁ7&1_ɜarJ=$.KrMBα+ImֽTr=왍gI oiTEG P_EG mFM(EǛu䶙[#Khg#(kPy淆3 ] QdN<~%cCd/ey͉ "$glD Gnrrڙ%wig5_JFHw_ў9ۓ yX@L< q!(aܡW!W@ޣC^2ڙ%1Ny\'<6VߙD{t6ΤZ՗:F}G2˦ O]Ag^<9.UBep0/4 <J\gVEYywv~: �4g)(Rv9]a5n8B; a@Y?3ueGub7<ݵC ٤<\jy˭>]ADLo|eyA~(tc76FjZCH"{d$y1N~}yiֺe_G#tk{[BEӋpLUO{~GkwAD"|c =<i[os}c+j %ɳ37q,3n+,tPX^SܻGiǚ+3-8^|HV]چ7 ?iU{1m)](I;b~'7XJ,1i|ΎT+/AlGxA<8@ #nl<זXf6.7$5[ �73 +9|5Zd1?.zH`XűCgGG#{4|̝psJm}2չ͖-+?pZɩ[ 45-{\].mTvJ|=oU'')?p!}W U8>UEl ۔ ؍ۨP mVy7fC 9#֐7hg(1IY):| ~kC [CpM\KY3.B%#ES?a~ >#X3ntX +@n +37'>ic5%R<?PbRKU]|?8>1 :?<nn#XS?dѸY]v2 -�~; X 'X#m^r䋃yAԤTge [KN %<oGj=}l:?ᶷܱ{ X]_cqq.kѡ1!/@n/ g:?Pbs0Y)W-3U'7?J[3lph>ӵ:w(BMcwZ걗NXP?A ?tOi x9? vA>0 lI2y&%4e${q,dX\{?gGDQڿch)ukBpq?ĄmXb*Cs|FEA �c1lo+"9vƚ+Aްڐ/hgr |(5z״5{MuelpQZc~~2Ӷ>wծ[A<mwԮ)޷7|'7* %?ı@VJgBV)wK_t,/;|Վ!{+Ђܛ0 pu9 I֘I3T,uYY e/mJߩܯ//Zl L۳4VxܟO](ζиBi* fu+vK%9#=O ݚFu +fJ�< endstream endobj 179 0 obj <</Filter[/FlateDecode]/Length 620>>stream +HAnAPJ! fQ`nB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +ǩZa˿<+:l<}G�dcEMRtؠ?uxJ-<u\xH>J~9.|y}gpM#k\v+W\8O%NJ5ǥ\A`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:g_w\M!|uR1^~_v>no`� k endstream endobj 180 0 obj <</Filter[/FlateDecode]/Length 1318>>stream +Hn6zHE+]`:-@H̘ 6OM[64X?yx~4}�.7 4ҿ&\,k[  ӭ e � +g}N7+����eiv | 9/rxL};s%M,jh>if!'K~9 bE.nQ{xϳ?MaфJSOW�3.?ʫ6y%^WgG=ak?i04[]4?^KGd;Lçnot -S 3{ggmûw= }2G9Km`Egݽ/ugξJ/οn/ᙾs����������������������������������������������������������������������������w夌./ʇI5Wǃz2*:HXrdp}~REǃ3?V_'6OUitsOڷ:T_=3ݏi|l FaY#&zQ$T|p_ sst + +}[<7JEN"e|Ke(U EΣӶŬQ,BTG;inZ˄29SBhӚzV=tFc赣:;OӷܾhZ:?曥\RG@W`02%ʞdKCf\ "eY|ZXkG2XABPBiOJB{`R-̠v4ҬH3TDzD.3y<HNjHLZZYR.V.L,v)J=uZ$&wvM:u.̠vwpƕ]~9 `6''L1N.\w4K7u< RԅbFwma5_ho,Wq3]}z>\qevE2+/E�MmI6/[ȒIozZꜥ9fwmaݬ]Q$˦k8գPswCaNXyBYeUڜiS|N7+\)Fo}+8͟ giOJB{E^יA"JŮ`Of~c5>:?xP_hdo/L'�� endstream endobj 181 0 obj <</Filter[/FlateDecode]/Length 1994>>stream +HyPu@ie$щiV"٥&`5WJ !aMn*貲k*( @MfB1Wc6M|ٿ3HQ%a +w0v[}U2qcu 2%мΖ!5=W}og$sg;^мaؼܝJ=36�w?JxIKu>ф +VdVox{κAs) ,!;K\zYvgjG �;œVtdN9EylD h]o9 +!{87ȿx~sB=K>; Vs^2?G;aݴl|hg CUϲs! B{;[\[ylJ@>K?<2�duբ? w-M~u)O! +LI@ 2|mOϋblͰ.0?'Gpo?!/s8#> ➯B<wָ +cн!UW Ĵ^d UZ +9seX%/w 1;GLq?wNB!- =E~ܙ l:A3ψz.mww<w?di_)F*<nsZ7B!gԄ +qj {Ia3:mxė3qwq㖸IpH>X:jϏ{,DO{mg(BaI{ޏ:;XܿP:y>` u A.M 7|kdlMY{Ez0\BҾOrxoIl?}\?w ܝ�ʸ?n{(o.uŗ`-5=^#$hZbwC!'8ʁIOqGRA9o39y lL}�@dɎ;gu=ހլ?v>%UΟB{_W㣢):΢v5�2J?%N6#yw7%̫0jv{qy\x4!? I9YrAP3jcYmdzwWer93TBS,o2{=}kp[zsQ4A!%դw1"N|J],Յ9ӹ; +�cx,_2zqU>_Zc{=;}?UnßwB]Gʅ+6P"ڼ/ץ|M޷V�WQA5X-_ю;hz_;_~iT_iGJesBYPʉn@uS2{MvxmmѦy�(x<%gS\҄ +QqY=ŭD]Km[!uJsrC)H[TIHK9/ow(djtM{7#J?,K{U.qy[ǎ=Ʒo_3wK$\BZ.έ_ӧw0FwUGA=ࣝy)ܝ�עcRozŚȧH;[|l^^¨ʎ9 [BrÖPP39rCE~EMlܝ�עٕ逥y'u{GlNO}b<ռΏ= UfS:}XL^(myѡ#>忭|Ep�(>u! qw[2RszH]t�M3›;/�h endstream endobj 182 0 obj <</Filter[/FlateDecode]/Length 2074>>stream +H{Pׅ" I0ɐKghx#ш7P PiԀ Zњ^o * hڈQDqt%o;}s}b"��n"}l'c{R}:NzpXYk'CL׼ź)x_ٌO h��ǟNˌg+k,cy|.yVSE{�]A~8?% ){6>ļ5f=_,���?Ƥi㒢_:gV]&]D_rBy sX?ijt'[32=\tmO +}敨hԵ:gn.[W���9+<[y}0F89-\~ 5λH罃 ȃH>'t/eg쌩JaHo {g~]S���݆K\i$o=4۷FKwiy=?q+Vcv*֘q6AwmtHg(̢)5^9U$V'���Ke"c_<dKG1cBp,띖Y_{>AwO~c#[:K;#h.;+;ê>?ѬTK��� yG-d=G6,).Ӿdw;?Ʀd'ثZw#EAw54(SHR^)���x[# v+#~A~{l}@@ QrΩ2-g/##[OQp���ϣ`텹["y;~gf>M6%HJ^'gk +g5?\V'o9[l}DѨ9XN=Ct�o���\^ e'F]6o>$Gdk H)eciAitvU&2V/h~>[,{zv87w����y}i46A{pAO/.a h^V*\ᗯDFws���őS<]q}>=Ҷp1?A#7K3fcvf^Zڨ~NGn^"���C^l<Eٰ!^ݨ^)=y\4Ut<n {ݎe3Kߴ5 T2VU}C,8a���@M,USZ8b$Fͥ3oHJ>'-?d`A,9h7k-β*nmOIUķfѢϙU)���<J(.5d;RSg!M%w +x<$͏e;^>_ Smy;B+���@_\]:vdsb)s|W;<>sz_; <?CevA{ttY2f3UI^җ{~}���-*Y-}vIsZ]AOsto1䳵iLѠn$f3骏���`t5ĽJa$<H!oO<{vF޻ .?린r]IsttYS ۙ+{1FegK��� y|P烤U~a{%_7WԪ|<nw.MkF?!֣AVU{~"?���_5r\I%4-px2xrPŠk5Ug孥3n=Ҿiyoof:v8Ѭdy7���3LPds +/yojf7W�/.T endstream endobj 183 0 obj <</Filter[/FlateDecode]/Length 1727>>stream +HkPeE 3⡓%8$fG%dHG3MEvqa\XEQ?qeAtcg?1BٵBI>~ߏoO` cOj ,ˮ }1[=Or8���61Fv(f]I}KV`w{_·g k?b障Sw]E8EAf- -JJ﹕5wO���h-s_.ӗA%-`ZL}M{v w3J;AmTNIll|?Er ���WWU̻I<H.WkZjӁkx ?`bf11Z`|Uf dqLT43D#[���JcwFޛ4瑕6ԷԻ>}41SQ_ \n {k֬ K$?`>lʸl3HLPGGvBQ[-, ���}-71=?ASޤ>^~m3Za›vAֿ{V /&?(\XCIү'Uy-tV](yҒܤĐ?).̬/ ���/ ^:" !"#^h6գԯԳԷ^.RTRO Hw;U#/,W^*xyhaxl#,neM5u0Z˜. 5r`73'H-|cmU+q_bSj��zzzzzz{Zm83o?1PDݹn$ۣGҼZ!N>10o Eiun���kgФo3ϼgް b;Ӻi[ƭY3~_Om��VS]m:CF �ҟR'wsهfp-��Z/N6 0o`@KIL=駭lOgru ��\;bC=<e@, %ۢV[|=w;?ramiw0��&U+sǼgHmm{xx2*F殝wm"xG0��mS\"u;Y@L }_k1c<?i+W J{[?L +B}b���kTzJ]sz, &?p'g`vvuuΎT(=Oˣ#B[˓&0дlb���viLuj3�O4d4a@gGV|D*Sƍիgɛ]y)rx���>Q9*\}Ӱ b:3-^v,<#n^za {��RQ<޻_ bL=.[Sbcf,ԏ=鳹}GϜ#ze ��`nLжm#.#.[LiىtQ۝~��4u"=xwXa@,)?nX<V\ 4])}G��Xke=H}˻ +bI;aqSKۥix 0�&fX endstream endobj 184 0 obj <</Filter[/FlateDecode]/Length 905>>stream +HKTqEZ$MwlSEv +K(,(1!3'SG386 +Z]~6vne=>33zǹ�5OOMpnjɂ9inKy!GcmyYL' >zZޡ}�œ.WY2)쏡^Q<Ged{ �^]H$xv{Mܽ 5{{o6��] E=үubSÓ{tyIw��S}6k,?Al +cx&;5`׽Gڷ��SuGKJjw Ħ?/BQWwa�4_O:اڝn +)K_T:ן6q��L!~^PtS?Ma̦SݾdLѾ��S?77IM 612ɾ 6}ؠ�:K˱&Q.7 ȭ;S"om �̔\{ YM 61:ՁnݫMw��,ohwĦ?Fgq~?;iv��WtU'}㴻DbSW*ҿ��xc[f/K;TbSy</Ip;'S�5\9ؗڝm*)8Tyݭ[E�ҋpӑ]m2)Xz,wL }s�+zveI?.93FM 68'݊w��m҇ҋ%+m:)I?݆Oi|�� !(ѦcHF/ѿ��h6|(wjw Ħ?k~Qֿ{H�!CEn+�C% endstream endobj 185 0 obj <</Filter[/FlateDecode]/Length 910>>stream +HKqO bzTDbAԺX`HECC4D4A8n4 lb! )"->/xwySҼ5<<$~T<e߱w-QYSƍmo3Q�@q|&d-?qͼ35 ���}<8rՉ7Y iFj3N]��=HXi(k1iwz-n��~o4T-bM?qx'8{:$6���= ֆiw-Lbvzy95I ��x-_;t`2[ـt��LeqTq0M֡`MESo}��lTvOq0Mޥ;%n��Tvb_Aj4ɧ N,k��bf~9Dq0Mǹw. +�� +ec[esҭՌi_8W7{�J2o݉ҍՎiN_1Nl׀t3��_ǃN,g&X?q#8Kw�znكHt[4՘;[ I�%yjiZŀi3Nbs}x?��[_CxOtS4Z.rjtC��[|ϤZ,?qh, Hw�?5Sj,ni1`!PʌntU��۫E7y,9ni1`!RWH7�,՟ݺzPņi'5wS�߶o endstream endobj 186 0 obj <</Filter[/FlateDecode]/Length 1217>>stream +H]Lu�?`4Lŗh.LXEŋ[K#,-yBʩ@/ +2A<1"/Cs֤vtqNoyo\.x/Du<�@lBtl% է3^xRMu/.zs,g\~(2?Xu��0Ɂ="<;AzNSf>Ҳ[}��0]sV8L;ӨDOaPpنYp^u��07 ++eOɾRݙF z +7Ֆĸ][{��ܚh]idT8a)+M:oX'/ԧk��R/iX]idy%%vt~chGC彸r}�ݖ岗v;JuGz:Qy0ZЎ(ajv7 &�qYv]o:|"IuGr&&u8X"V'nc}Tw�&> @ny$=IMNSf>z-]}��#CwmaJW݉ /kԴ?ЦE64[dWA��㙸Q=l{;Sq䉀f3eNwʺTYޗ!{�`>9O8ƳETw!bNW&_1;dlgӜ=Zmak}hٜ��'F!]d2d؛bKD䃽=6N_:ejnu-mO>*m?Tޛ:$�Ē%;kLėdwcwuxG:/(3J^6Wtlöd�/N!dxz\ua&yNc_ڧWcbg 4~{8!:Fl]=ϲ?|[D~eߟn�׽yo60h%mNKYi|װ?|Q{ s�@zy;j+Puavxǵ)]}k+ꭃwgUw�@t^m^DOahC}௺��1bv0\uan?!8MK}�>'= 5_dϨ:̍Avl;YWz#Tw�@dvТ׿ �Q endstream endobj 187 0 obj <</Filter[/FlateDecode]/Length 21278>>stream +HW9] <cWy2937@_=x v4ׯK62eo{.yhʜ|)rU0aw& ²s7mPhsϒr%\իpҞ`R,oCb[ h\::υeb +V&H0}#VN dY'kJљ0p9Je~4L (W6׶^_ Fmu'l"mC.QR�.h},dy�^j7~E72�\m�/l$6tvF)ɤ-g<5)nN‚x+wT +w-@6'!a,izbjpX�ew*`zB@SuZIZKߠ23L3𹺟 :X{?,A~M1m3#^^ . ʲOFi#�g%U^*faa1@oFg&xXI!W+ ۰aԢZADcAҢ{ͪcs(ʯV +m* +E9 drDPs<z|:l'oRжb a/Іc@W91P?&-Ip߫xrvʍ=@~0:t~ԋRZՊwW(uE5AK81,/\A?z[/-^[8IO7pLz1�PGE[�`GA ot&0x*6ܳ9@:ErP-�(PҖ "Tד[7IkUgQ׮f +=l8`ЇQ;Hbsջf,n"bX0QXEe)|plǂdyPj'(}`D"l2޼v罆Ɉ}o$pnњ& PLXJ <V|ypLA{P Pwk ~V̤] oἭ Oo= A{Ϡ 0ayϴ/v=gےy::3inG](*cq_k;V2ltw N6ģHPO-%vwX$0k`X@JR10sātb.PhV▰z]Ryu[ns4 soz0M(>spurbYŷDܴ@eZU>HA�beݬ~{^eHK\h/qaqP5Y0f +AjHcMT=#2#eN,B8)P1­tbTdi4Y=IaDPB6*G t]d]Y9;n`]hy=F=݆{5=XݬeV9مbgS4`GPNϫ +P/wmL PV-ZoZub"P3}>!1ήzزG*DoO{tD3{9{  <z}.80[vqU5g[+` ,P, up,P1 ~]<Kf(˗q0G\WKf/КuGPc`1FVA +s,&ԣְb_E m)![a·F �Yx-?6*�q BYIN{ǵy]cƐ֌(0g {"ۊSy ֽwijYn~/8pw3zwXjQ[xIp<(eQN�#$kJX?u_l~=ۼ�/f|+Д(~<k_vxVE%@ݟgVn cl>tlht _Cݍg^ 6u9 N> JؖsaP(uʯ{!BDu}6Qf>'?kt.ԿXyWaa^�X,Sԉzҩ sߛwtLX1˼a3w>mtv�l kshe!+1 ++Z;褷-hQ@JpRDžS\LHL彺 ?% Y3( tmͻ{SM<MaX){bcg{, fK0`$&Bh�Mui8iQp.O9 c!OHʥ]يϝ~BRzik*HI] rZ׿Sa>b8x.n2+'* }!lO-к"ehR26KMp-fbܚA?p ޷S})8 Jڂ)ۤvðshcB6 )b98JBvV'.El_U*V6\A\To�-5}m࠶3n^$7{C l7XؒZÔ, h.}QoE=B"ڊG0U:樗67 N{DxQ|0)�L$fYI(xQ45O졑af9`"n$ixy򳸯̭IF2z�R)W;}?6ڠy.^KU^9aycZs"6_.Pd`ԊzEmZ[Z~eZ Y/|Nψ" q+� 0XDEHn 6˼+̎XѮn)XiU_XIxkA毿@]q|ǢCq4bTw 8`9b)f`_ ֕(�׻{£\HOjb`Bԣ뢓{\~/(+g]}2q}t[p� ?_ӝ Z8? vi0Vyw 'iu I<}i0`m.c Z2t3kT=~>vV| +)4G1],o8*y]&JOZa`Y 7. 7,gqf|`F{Xךٹ{\b£tlt?ك0`cl^ok(: "g5"Ȏxj&ؒnTmf<*nGfQOϫXsdSC~^^_(ޱP;  <�$Ƶ WZ`naLo'둴F|)Y"q1YP2siYF&~pr\4, .brpgWP]Lpx_hma̛gg4sҎ{Wj S,1| +cd_cGj 6(&8W9$ty +Ip@bEA{g"m͑H' >V ~crĨu6U*b} M<d:gq@-v(o-jI.g:!c\_-~ o}& @^2h4ܽ{* .NԁnށEp&Z<~(sq +>�{'X+Q7M!EH@L4hQ?erK+"a4:=cT6~$,7r1d5AϘ=5m'jľ%BtTqt8ܾ޻( %ad@ N3NU%P7,s/V~K! ZZ3vVYݮ,#%ɍMp[/<W=.?8LZ :9ٝ t=[͖?Ggנo 5m3 c +w"f +&>�#|g{j{E:W]ҕi ]}i|9oT<o, 'ɳeVNoGs|K.6LYC0t3viaF_ʼuumL} +-ΟZ8[vvtԶ|$@^md{aHcSps! +N^Tc۞1?&d�[ə3_a{hҎ94"`Osq-\'rھQY`%|$G7c{cC$;_;iK-h`zS;A'K<�,ТA:A |%mEer &s]r VA4릵ԫzcA~gQ2?ms؆y\5|(jZaZG%<MG%ZV9oT�k܂N XZx[#9eLC|N,uz_c,U/ ItSpu_ 0 ^.6 t@f jםBmc;n4kc.p , <J ~>6¿`Z&[i_Pm$ +[zZ1X6fj 68r>< oNvj- +W_k�c`Q[0c&u05a{*`8;譤�y*{QtڔCGѳj:ۥTQsSmoGR঳|;7" + ?}W,r8 X1 KpeI[MN˘G%v�sΎnk|}.{�x5g#�]E#W8&ɽZ+|l툺VPwf^s%�cQF0`O *8q`G !pڐyZpY9j֛j{ s�V)+DUB6Wm:ZQ8WMKõ)U@F: `7OuKfQ_mfe/MJjc�\ЍG&"rG5~>fJ:v[5JU.�!a 8乥"�%z+;6 H!Fu_X䗰;ќVC,@a/r.c,^n{9X//3hn  rAG&Pf`[7_{lr<g?˚rYv;[x]5Dz8,a"x1`XXܚ]?Yoᝢ+ p=A^#V!Lq=>hP%_Df3!6vzv, I4Rw0&wdJ5Z 3\OҪ ZЉ)Nj-\r۟)V5ua,~,9 +Md'ϾiuV)&T izF|ٯC^IbO*̇J2LWnM.KKڜIj^=ێ,'J6xWn:'CɒZ2\G4jI @S[7y- +L 'FOl~{¦i`b [E4 ߔ9/8{삒<x ^s0Y UW(.s Ӵsa�.Q9= +t{<j%Wdn ++SLO> ):({*(e늍sΊC|4 q.eW=Z٨,!0%>Bwo؏½dTy[xV률9@Z0WTӥ:t ޵Q0e=Ű+6Ū Eg ˿)+*9U>?4Y.>mg,/p$Lxj$~ \/[ !0u 'pw Co1TҦb]DնK0 9u-:L$EWN "') {7zE�A¼ѦXWd�22,2ŪQ /֫8G�9yępz{vB ,Ms+ k@V=pGQE9}m/^|_s{t+�[[XUbqg\eLk)@]J]ꇰ=h,dLxub~v|4تoZlcWb`G? 8]!xGSƇZ�S(V":MܔTr + )*d7Ϋ=6}VLG N<E@uЉSupwt![MHbҎN Z>xO~�Z&�#�mtU.pF. +׸v?w!QX ]ਫ- +C:EO +m<7aQ\ Dd<&`i6n$oJYO%Ѭ\$eu5bQGh<{ Pas$j̀-FԚvhQMg۴vikSk0Rf6Dd˻Z,14=�JpQ"#)`s/(!-gs=c˃}߫m'<πQ` 4+/CY'}�`/Fe5Lnuҍ0}m_0RjmO؊9ɠY^|]G�zC*eu-\MZ(9-'[y =C Ѷz@+ՀUE4pmyԅ>y?Vȃ׃$D!kI6V+ |A_(ћm#9lS~9 +`<!{R sln[dQs1FI2g(9*K*vxq_-\޷=zKvO\8->>_{ h i6Yh=Lv+kISͧ=W}ݶPvA(;;.(olo$&7Nc<Z+=lܖ0@^;اcAn_m~vz2^*ѯbd6Q F"M"-Nn ]@ƿJ=76c롙|EAS+V̟`P~;!2oY�]\9+^į[`0ĦN#e7U/$4QmHku6Qj̙}_9ӽ#9 ϱVմ'5AjIȄ(9vEa9+Of=0[m&K@#ߪ>Օ[&AFj^+A +!jF#fu o;|P8eF<le#'`QGNQqV-?*C3(Ƽ6Drm2lL,i b}}YWhฑ.< jbmRT*^P^Rc#b'uܗƋ"6Cg78?M^%n:;30?4(p9f)2<{VH5Wsgyά "#Oi^٣9{4hdzXʖj&KE&6YM!n\Ͷ^+"AilYR|(QZ, rgS!h\(g?Ab<Rc:K}J4*18M%=6a_�/@�4Wt:,Cuk9xgn +20P*ڭ' <&Ƃ[�*B<)gr~]Z5IxD1gL݇w$[+B Ӯxeֻoha:g Ne !U|VyϞ" Tܡ'@RX}Z޴\ +M{Ηz+oqwLI +ʄS0y};R(}.p*S1$xV0Ys%htCZLCȪaЖŎv&^*)d?|WZD):((nڔJc< +ҐYT9.}2Rg~Ou*ZA$t?i0-gg9Gx] R?co.jC:g N*l!N2'kax5[2ep!e^`9Q}dPr g!/e##<K \dvºi +%"lsy1T f,{Bɚ4QV!0CTf#dfɋ|TvKĹV" + U e .]d1,5&*'Dr:(Pӵ\n k~DuSk-S +cj<(Qw(+vi#J Q[q>R;j˶T:Vz?gWD5CsnOP"OX:,a̯_-`7b\}'yx]zѭ+ihqRLg}o&;q5nC B^2Lph3h{0Zj7;(DJ`9u6�$ ԏ{ +35.�]emG͚ecPe*"wɷz_kc-z (oe Ѕ^(g-ZF\? +- -QgYߒkB߅(Cqz^;`?j*v{(9!qO~4gXH"ÇSgJ<-̟x,*TǪ +;cy֬g2 m32k7+r~ƺB~avTǵ@}THpO/$`'\5 |]KNA>U!c1z̋wU[Y<:irbQ˳</AOOaFWo͛C~j4DJ"ܴ~NܒY;.~ۑ +??vc2(&5a{gp.L?- 5}u*| `ߍd0oE~yJ�l7 J+/hq*<\gx N> A?m?@]u<3ᵇ&ň+6C3ye ZR٠\'un?>TKD + "u8sƩΙ1]j}3OB2275g6p"3|.A +quMh{oRϼ{ j]MU'MY >imWPj挎%h w[l2㭷M ǾD}$o_]7O%#GК0J biF_g{9#;S)O%]Eڞ}DpKArG"tDLfZDW�KgǮkαΟz0> +%(G';;A)~pOUɹ9맊HOJ~x"DOm.QE]Xs)2|6,uҊan{]X7+�8?ҍ}(=~>l +`2'T<Ԕ_c.4&'u3mp+iSI`uX|~[&Kk(r ձ/ڑ�3tۥHWӀ[}aq\J�}%󭂵[jŬq빠m}u\�{ӱ"9h2'Ǫ2GKXMt98> Z8УzT�a2Ӯg-G}s�a=jdc=ڑEhv >M5mM2x +nQqs71n0?O4aV0,Ӂ +[+LXR ZQo]b&|I" Y`NvuD=C^ZcΏFy$vs<Lƣ.|  0@G+.ucs |pq?XRBuߝQc~X]b|GS +Ufy9;+Y 7g?&';Ƥc$/P`ȽtБ&r+Er R\zg\cweS%pI(<S/T78wA ˢEp +dDXN11}\°]kfoT}\]o4'RY3p6B@ւ +.sv%s=' vww?8%A`x[%DGAT[�ٹ8;6E߆DʸIBI?wM(`? \!|tU3P|DES .L;v_`8^,Si ٟs�v}/" aU[`cAz|&LŨpKl<(+gt,G%GQO*a/oW ;J-mXHzEu^uY�*+3ȃ9Ӕp[4 9OhdOlJﱗ$J m)xrxf}s�GODBҒkcd.3�~mhI/LYhy&iS@cfz5sh4[QEk0n+D;nO0.`'</H& m?oRs{Qac<s,(G[b| Kk]l|;K$\E4Q#rn6�_HfulqG41蠼:: ɒY<z[L !?5E2y][e-{btqnb4*ߦ'אָ�xG<ꢎpŭ.;s!d-1LYr^_U�W~*cg +z2õ0-ּ +9,+aLCˎ.xX;oȵ7$8@rV5Loiqv5vò 'o< qϽ +K/Q}s/<՚^8Ѷ{Oy|UVGIdAJ[t^{ tۗ�klf%iW+~.f$F7q%Q&%ΩC5$$y$g%^ڌ5yv,餇cO|dsFj;"N`:lKhQIڊlPdKJ ʜTvu[<\1?5v7^9(~Bh}s`!va@v~%cYQ_u�Jhig@<*n>Kz/N F^9L0Kn<j.|Q*>x m +\%Mi e8� WjYD�8"6< +s. NnX׸i �M_][D7O'U +62<,* pcbT +9Mq˦23fNRlo̒1!eۈ|EEz;/K//zy%Z=K5^L/=ct<Lx:[=&>stjvYѦ\ϥfo^rP~&Ǟ!J}<<$דP"ޣ +SIǛQ˖l:ܽ%x` nXo:}'&@c>CT;tkgg|lz8zXw-Owa3+J fƸ �kW2~+\sinXѷD '6KcigLm‡PKz>EUmV^YWz&a:֍awiZ7mlQ*[m/\HG<D]'xSh6ěvJཟN4M11׽YvS2 +P3(HkS4UgͩjXE9~a"z͑S @٭56%Ks<% r΍2MKTedKBَr<T|~z-@}9�df? 65v6Q>ť7ϿpkGwZ6^uW{>hqt׃u)Nq+$CbXN] %_7ޱˋ]"t8*bt<gCK猎7+˟6tBV b E۽TUR;0ߞ;guo^.J: د9;T8|mޥvSQ}ʇl]98F �G>Ljܘ^r7t.-�a@" p1ڳ:MUғ{�fq|#Z e&B )y XۅPh^3ز\\v<-l!mǚ,Φ<{%ZAشκ8<a~n bs?p6ey (i�bFxnB] Eon2 ӂ\u~=.AԫN#y*8.q^` n +ڔ:ʧ Ҹs5W VEQ_< eM5-}7G+IvB>'' ü*9O96F0mZѐt<&wg%FL)  zdtZīI~ +Gz6[t[x&8:`cPo7Ga-1mrv>÷-N`;y�l.2m +FCޤȫ ! ȼ4?w~n1R}b Y%jbw9Y}$mɱbif {.�ѼN/?a?$XHk33Y V6xeɽ`I_g�%#kS b3K`X [}FX]Y2.T]uƒўW›57.>~N-F  +Ņ)u]9c 涏 +Lrw(vSZ:ǭOUb4g,m {WRY?5(d3h=~E�}gUbn ԕh'!Ŕ +.ț]Ҳh6uLj=/@Sb^1g ؗ1hEvkBllpg<_jQ{,w!Jh*~P~sSe +.8z0@르Xa꺓H�Flvuߪ];%%5ji 9M=99TTyVҲW'Qb{DeOީVMT@j77V*Ջ-9dO;<f1Y2$YdiDqa{> 9LߚtJ kֺrWa/_0K:KP[H�"t%غx2N'cXQ9U4ٓ�WkIᰎttHH_ړ6y֗q"NsEy �4Qyp9Lw62@'p�pS?*1(Z"YƳ`�#Wc'W5f-ʵn-% +pDԻT`ΦݶFKn+tרXV>̢aWHPRзI4eOf +l +XPc ~G3 +Z;_͗ؗ֓LhǮxR Ұf\{Cj2\3Q8T`?匣5pZ4lb#[dhz(Ƴ�#,)Hc`W "`eѬLgemG!+sMOFA 2+Th%X{={ŴFav5M]fcn)+Ovfq'- +:%eXq^e?r= 6'lͩZ+]9|$9D&'gs^)Exn +Gek˟MC&][X'\NLChuBK, ]oH'>k'A>z>.A622@:wF�uhJs +.*ePt&j `jlk^$ 9T^ \,bL�{gsYs_5�K΀R10st`v3�g�Qխ|ɔ5W[X\? ~NZeY[wwٻg0lmu +pCE0ww_߿=ܿ,lD ZX.o_Y'VT%uM݃@zMJ^ +pQPϴ&,+,gHW�{<M6:_ rc9#ff$&/xZ)ՅnjFxc;+7`2vVkϞ=q_%$֚CX2:ZL\cyҽj4bEP;LG_-<3Tj?MVd*NGaQp49Z&tϸ_@Cd::m~ &&qܗh9l(JƏmq-,9Vv T-9Zk(bZ¿eO ї$o!VNa^lJtru0h�}skod:;2�o)&2 c x1k\T2v[;+<{K*Z\ ;4M&>*E8dй6&()qٜ7, +3>, s B�7nXXs i5l�Io1A,UHܒ֡.YAݻt]ntwe4q&qO/׉o*i\y�ϐ9C϶dqh,˔Ce׏Jট3lwoM尳"Pk{4ؤr4wpXQɴ?fʵM] +IQ8ڌ6B5l.6m->ԩm}`�yj+Xzi 2 ]NW3k/{puE ڜelƃ@&p*ÅX�}A{s]c"yc@͂o~[{}�o=t ;˂AԴnA5E>RV͸Y: 7FggBolxURYZ: +pb *mi.YsfnE 1|]h8<[{(RjPmd }<c Qi5q/X�PEXb_W"yBfɑ�z-k=x]gU7�6*$JWngphq=3HKU7 (HyNLl*hD>_�ùޡбN4HfNUkhN=Rn2)6 5rh7؎nCX,xe׏܂.GFE5W:dN8^􈻼@[R+`&E&ߊdҺHE Rzs"GE%y.EǍ{NƥO3lsN(0M!5G៳ +<2WamYcuIv�jG,a+=t`JJvxS`ԠUκty(+t;GZdղ7"oOxnOe{J8[�wq'=o{$+'w)@*$g6Vpa-ȞJ/Aa^xV>I|Ё ;ieаS58oz߄'g{rP|l>n[P.T1&cZCasu>MwSr"3w҇DeP ~UZ%iv%߿ M#Y-&䩌 ʽ -2=e5r5a#{-ZMju)!myk X䢸ozvq{ x7n>D [%jND^23\fF7@k2~ Q9o ?>w(UaR=�{~�\Z+Zq3$*Eή-)~'`3)2^"RpGKi$w%X("ͮ% >sa '>xugTOEVdW3FlOųލ:Z0fJԚLRm3n%@vf|~kٜ(uEm&9o ե?XBH@=vToGgɓ#tuzS ^mJ;x2^mxBa  @"4ҠV<Rb2fk1 vcNweK"j訯dC�͵I�B@|x\R<ۚ9Y�3�8mDcQFd4O dIaX)o~os%g>OqΠxaSjJ 6؋RÀ]ˉXʬ:52kaB *Xgu_e\R->mp1JwB2T؎luԐry%䲨4Y +袎!J +Nx|ٌ[<U&/U#.F| 9[*[<U|:$ L/n$|ӵ8�ZzaJ_-ۡ> +jk޸gv|kiw'y�j.rkcN:4I8ktMx�OvgN+2hFJ~$o�hr(@>ae4X$QzIQq6oΊ�Qo\�˫Z2W\%EԮ6�M+{1>j 9y�ӧ*_[QT-o_DUvQ 5AnK5�5ڗ;<?wt +Шg�O[:i)zpJ!)'}AU1(⎶O\}+Y* +J6CB'8C <&%]Hyh͐lOӆoc0jtbr0>.6]G}sK0FHV OQu}ɻVZwKԑq?)2D߂Zdcb䜷<t+o�m-@XY"j[XKDC; ]bW3¸]I!xe>/weºv9GX;hN녜?JB>M‹S/d+sKɊlYk e+.Ǫ~π: +Ь['$)jJoi<|01߾Y`9z5p1%&cY'4 ӛk3oh`I-c,զ `vnDMZ=s@)ETUN 6vlc\#A?~/5xRpz~ + Lg1Â-8Tx/҇ίp !z\sί\ zw<;V3{V +D,S@>YcҘEoOSXV,2v,'g K:r3bCGSݩ]k'ۈv`]6w^71S*>RE܊mw&B=V/8Bu{5H=-SxOvLh0Ui^:=ۮ9q+S)ތxT 8S-%SgamA[Tc%|$k)HC[/AF'DFQ[127`w4JJgM 3k7uV :,Z9.í!SSV˳Hd,]&s�&QcL(ͰZ8A{TXYk \r$hf.23fkfŷJ-L)koe�nB4bRTђ>5vp< iM`$޼8w|֌g ղ [?o�:H6x *oj̡\TYiEBW-b=׵EҲH,ȨǾj&'h-q&$@ ~ڒ;<LE֜A¨ip39NVjT#ov9.5)7Hk}BbzW6+@ 4vw?az!9X>EA=.%N2LpOKpR%T3`Ë subP~Y5ʄv֋$gR?7j^0@C>Q SmGR.|[c�.y<`Nm1եq,Dz.aa${4 '|W=d,\ieXR0lI͜NM|xT<@A+C|_TQȡ$0'׳cn_+]Nٺfuw{&%`2/<ڏzrJRR\OQfFL +jZv,bX<~7U(o{.nv69\Țȗ%wԤ;?eWN@շB1K\鋫A/pY2M͉`Q\0d^6~ 6-ыFt|;ki K3SC{5]:x2G<>ndt`zΟqu SN�v6aά-:%3�9`)ipe n +#PtYp;H3[�OLV[~}^rR:T3v,g\ >~}"3<]Cwt!&bQ8'^#E ziLz'ʢ9i4¶Fq;ז,?9]ccb-j#k7>zvY? ,y,i[э `3 ژ apm*c7Ħtu؜*\o)Jt5G+] 0*_tm[96A +7( =PuSXG?p10K�rmYTԵ `is%{;ȧX.wzLr*h9S]P#-<ʅ+[m|:|:E# 4x]@ 2�hBMmo;ꄇMVb]R`f֬a}0Q(+H؃}O; =4]: RY\q];h5yֹ߾\{:.<�QQPoSaCD�2fM(�Ycؒ# <-Ŧ J=@X<? U렷3۾tj=j9%n�?:xN +*qd2ژ#-`\Gd׼Rt[<5(\[FƭN~\8Scp�kQ#!ϑYs:B7=NJ:C3eyH5v/;#(Uu|Ou(:OkWq0/=jLojս,Y}-ߢ˱${v/JkEأ)ɢo-cj郜+�Հ�ˬ>S\@Wb:u]*6EY}#M}1855QV-ߔjpC#%hŅutQ'o!?Y5L(oqT K[/ϧ^. P`a3*LQyĪ/}XVcha`I \` +q.4mv{ pwSq|2?}HX._/_xoZKkuAɓNgIiߌrՅB58<5Ɨ|jEƻ+y[d*tHxpd'D)H\^Wg*\e0;+E�X<*$~6;ోxu3@dwMu[KR}^5پcnn$|^7}W[MV$)tVpj1]tE*/Kz3Xʪ}w[4~tcVsfgY,>YZhsãx]W_{~x�Zf={br`|JQbk ןMluc.Ɠ%A|+8;_dɷh3>HH]W\Cl/27L2<>W⛝Au%+/f=E OqC3 0.<oz$Wu<{f5=]a̪8:vt#v&\.rkAkӴFs'0 �ݘ endstream endobj 188 0 obj <</Filter[/FlateDecode]/Length 917>>stream +HKKaB@AE%)DJ"JABi*$-);ea1f#eQi :hRRq}O~y.ufz +&*ff{%1O~{ߵ #+|Tmݭ��Om1ғšmȸ?Mpev fh �^/HOf& #`6}+l8ޞ ~�G!I\ޤ4i3HWu|zVNa��iV^:"=nF4wJ*95G۟�GH9[e=fӸ?isޝfGg�'n\w[:2i*{yx>\n� 59ޮY`6ݎ?,~ގi]�΂H}1OQv0v̦qX㫭j}[[Y7�@>H' va?MpKiQ Z8�@zktbţQp0a5eu}�!؉lVa?Mâ ѩRn� |P#}Nh +l=篐o]pv��҅Cw-n&4{D`+^=_o�@H=Fab?MnKMn�@dAmq0a3%M�'tയtv̦qgnf_sCk�&_GC'H`6N{o.x}v�IL{onB4;8cJxU};{�佗wF!t?Mך)k-v�`[fvZ̦qd-`�c endstream endobj 189 0 obj <</Filter[/FlateDecode]/Length 936>>stream +HkqX.#\ KoшPl.SXrk2۱sYّ߯{߳(sbC0 o|/|WMTL�تH(X:QvYptCSrH~=,ߵbqτݨ+o<9]�'Ľ+w_{|bS]3iw$� _5XĽ?쩭$� y};5H)S8\tOb�<rq]aܲ^֯gwK�{}aBw닏m1H-)h7<Sys.M�ߓ;Kuerߵ; 6/N9~mݝ�]Ul(ovhv�+wXgK˷tcFjv(�LOD!ڝ`+NY-] +�}׷=xz }Ħ?rpyxw[>�Z'wukʣPSx~�~f117Tv!H/)Y(s"/ܸG[�?}rGl^H?)9oԴ4ݯ�};:wvg@:/6U`}|Y�Wr>WF^V^kwt?Ma@ےs"w +�ջ[}Ni)|Q?U:,�po'#w(X:E#Al +_tY>ބB NU]�3r]bSSnAv}jI2Ħ?Ṟ~qo~H8r(g� endstream endobj 190 0 obj <</Filter[/FlateDecode]/Length 1380>>stream +HoLuqrbKmBģ4Tlh$(uu "C[J-' w;*DC'ʱFKPZ=)|}ؤ|zݓｿΌeLP:C큈n1z Jc:ty@ krneX6��X*ԻԿNGcwQS?*s{ed_A�a2y z]�@M*+KcǸ��`Kmdw�970G x\ 7gʜxvmpA9/�,z�b@D;;49f72 \{گO430C5]4zMf��5{#K7b|˻A< e]Ncƒu y&:#W�ԳQ;ĄO" +ny=wǪ-mi��5^(,-1a "`r4le?lKguOs�@ O;̗AY]@Di}=ux"vȑg{kW1%} ;�@ &{ԫi%;Ć,EyN,1cz#wlJm@ Qv;k}��JWaw? /&OFN=qگkgמS4zQ~? ",o3;js2`I�(ŶlWWyw;y YMN +no[-.ڀԖIgMo_n.so 7+?y}g˅p��%BD_to2/&|<lY;v<a=ah^}�(Hm6]AӰ?ђk#?/(1@N< ܋9m:fv��J 1Fn<{r` Q[a,< it:wVDzw|0wxd +;�@ &zH޼̠,Yl;f,Y)v9ae`bd5?G^}�M!ԗ|ɻAy?5#(+-^Y=~�'1Izww` j +,ڢ$vF]06'�DBHH=I}ɻA?5}Uq0?d$�Dr/3zwWra j +/enY �D0RXd6hP6DMX" 0�W endstream endobj 191 0 obj <</Filter[/FlateDecode]/Length 989>>stream +HoTeWkQXNY 0|4) cIL  2FFbXl +Z櫜C3C)%d +4P`&AB4m69΅1zsof6f80Ć{sS�_҃҇'ҏms7UBfz{wma[;k +�Av/dpECz7cct8R@df ��&ӁJڝ ;?Ma *j~hw��ҟ'HݤŰFӖ 'Snd=�� }rc#҃] {?Ma+5l2ؽL5�%LOie_w0 6/5'kfmm��^HH}=}Ħ?െhSI}��^x]:Kz!\؉Al +^Sƴ&N9nl_N�$&֚ꖾ\؉Al +PXWj뉎[�g7v΍ޑZ؋Al +Rruyk{o�O2=&ݱr>ܸ^Տ峵�xN͑>4~ݭr鵪Ms+rSU�<Kcǎ&NIiw+ 6\[^7Pω۝w�Lֵ/coޠީbSɡ]n4i�0}{LKzLK?Ħ?%:X,oojY=�O`j魝'kw( sm/i�sھP)hWδ%76r �˕]HOI_Ioiw'- Y7`OX�&4xvg"??MaEN|tᾐO��!}G~uhw%^-_/8Tj� &3Kg�Ԧ+ endstream endobj 192 0 obj <</Filter[/FlateDecode]/Length 988>>stream +HkTgwKVp!.qtQ$Z/BM&i 0MBi3I2I4x#Hi1FEӕ:EZcs>\j&gˏUs2nEBy]k- K#8�2z~ +'\ݍ�d+Ҝq�Aù>j^FAl +~3{I:=ɹmwr~1/$C;bSU_+n<{7r/No$[KzH ?MaJN$6GnоI�a青L@Ħ?g{#E>_m(ԾK�卍Ko/>MbS)ZPM<2'}�ӯsC3Owxnz*Ӓ:x�v^~iMIJhw6bSyMsxg[�v>^~:]Ħ?ˎm]v�&=rҚm!އAl +A}SnY6p5R�&k571,ma@Д6WΖ7;4}�?n4I6U4C?Ma +ul X[^*Q[eb@PU$7}ճv= ^fJ>ިt~RÀ`@P^aw&&־@o /wVHhw0bSOWh$Ňn}'©hvwc 6ob/>wP/ S\_hw1Ħ?`yMg3Ʋv;�Aۋe.g@zB 6[,{;�7#}pu~):RQx?Ma&&]uC.7F?�txO /)y?`�E: endstream endobj 193 0 obj <</Filter[/FlateDecode]/Length 2232>>stream +H{PT\Z6Tl1IkG$V7%B 7eA& dYXvϞݳ,UQ)RvNlM'6xIyY6\]lww7p^},H0>R =?/.v"5�IRs$�A\S"aOu2/Ǵi_-�x9CCb{!�s!ݓEψ}(?PZ-[ΰ }zAY֖wdc?^O{P~�9<~0tO  \h?Z.KHIYS[ث#59C�oZ戦f3o'/�,_Ǔkk^!}H?PXMEU MG/' 9l]$o;G�Qm]pG?PX-}D?C^$Mᵤp}�IyS=rx-[ؗMEU.Xdzܝs&<$8$l/�tϽV]A +!o|*B׼'<&^ 7�H A@9x{ۅu}4u5 "=~tI$'\x~Д2Gg �x~黋Ll`A@t)pP18Uٳe8 i.M4ȫ͙AnVl�w$=ZL^3:朮w`;ס}S~tkYW{ܚ؆�Lʔ[da5Xl?� _F=+Ib%�l=4�ix~nTB#(p,#)zcJyO%b*�NI[diOC@Zժz_I$c&`d(w)i>@l�/6N˺[� kox3ڎ&K%YR*JW:oqӑc*[xng��c!]>+ZKIb�UkyEwGݦL5�0sOSV%hag[�qopJej.`?PTJSfgk/yw+͚3yݧ[SBsºr}Sr}ru]Q,{MYdWMuZK٫m ސXƤֹuبb;MY}05۔[do;]�x:C#R<;GZ{Y� y2k.Ygj?OQ<(cx(;4;sポUaҖ^Y#(: >DZcHF 7Tybś5Ap?uݔLY}`?~LW4Q*B|Aj(t;t)� ܩ?Uj3;(3M5'7.?Q2e=u0B.GE6:A>꣭fޠ`34&O(Xz[+3h} +yTkMY}0=yP]J{S*SPog 7;*Z�x2(w*glMzԔ?'"y<[Y6z^Y2~`;G1I +$d3 ?[O/UXAR;f|lCn�vlK[i2vN3{֤j*g(={u:`,ojw�pwHg7]BT3��WNBaWIWa)%k11G0c#)y*}÷:|/H]`[Yhf{+mU%6_Bs>W7gwu6뛒mSv{)u,b:]Ub{oQkdoZ=^yD:Ë<?(?0ʼn�pWH_WJzt'p5?PTDZ{Yek_oάn#>4V7ηT͝] rn M)E̚Ksl̔Xzrcs9+MmUB.j;=Mf~x,EZaz?8{>{u:~yݝ:y!Y|/eҗ[*2| +0�j endstream endobj 194 0 obj <</Filter[/FlateDecode]/Length 3016>>stream +H{Tw[Vjnˣ>"X@+ P6D !!$$̐d"V|,g}m==gwe7F I9o{}@C&6gfef 44w7cgkgMbط2<^gc6H5ɚ@oVʦ2jѶƬߣ\Cuߦ'{'OM(vQݎ?xwOUx8awK3蛦;U4{j/s0fL+Mu}=i HpAtdW [g\:*?d?^ei=1j`S;Z_hEcKi@geqMVn10~ѻIB,5X_Ȱ<'NZqm8MtUݜ82?d?f@M  aM oѽck6{&Emj &e_,o~ާ.2Ƃ.p_֯?Gx~ZHJ[HS4ys4X_zOcѝ=C>Tu +ԑ!o'׵ 4>٨xŏ VB>VDmkVFz|`^<_4-\xMW$; 8Hij?h q8C׋Zَ{hX7{j?Y]o%_Y4$8q7n~fyM#;O6Zc_}B?p|P=fsk05CU06Oӹtmzf.|Y167+eJԧ9/5x/'?[J r '}L٬??& _$/{fc?23)q-QiRJ:{:quNZFwl{B^nR}Z3+dִ׼ҞW zmQ#1Hw8XmO2M/h򫔦 QYu0^= )YĹ8c3Y:I|cy[p=o%4y=cl*c-E̞F yh&/7֡qDA~wU *0] +uu #;O6ZHV7g(C{DDmw-iy & "DXN> z QlIſuONGTVFzT8G!-O9?3yi%˟9}Τ}>A\ stm\,#?d?+vՋ]=L=qX{\׵ +4> +FI˹ku.l%ԃ2P\(3?d?dxcj(%OBIV{@m @@=@]p]@㓡@SG$6}ٺzrA-ZcEq?Q%^uM"@'C !<vJ&R8A y=?5 | 89ᄖ!{:)ãL?Dg]il_XCOcuC#O̷%-c).Quysx8cSԝe4t&SADIYu+ꏹd|f C>O#4<~hh&/sFu%.wN'ex,175Uz:o?=EM"g mFxk A +4>+�BuCG<@MHtE-lEAhyhAdclc+ϐ\h|2Waɝ2w ɟ[O8wvVeLa~ow)r/T8$ i_9ɛ8))O%ҋ8$4_?ľLMd}3Z.ϵ2jªx9ZPiRJla_Wpv|ñ_ۯY֏MO ! vJJ7~K2wxHP2<P س~w_+Mޖ3Zb?뽜pbQƶgΗZ*<oXc{2xG<4~}T]\kݾF yP$N'{3y#zyEIxTazuG i)2}'xtѺ>۸wq.?d?_!e}>hU?TQ_UV]h6{#$=6=nhEO<-[avرsGdπ$WUձE@A>~qb5 + (r} m~6@,LJ앋Ev\4"`?'aJL^2u'XA4M) }|`Qus VGamb=cCmVڽ mFXgW +Y ; - keyCټAţt +*?Q<G1hc '06 :j�t�sc|PϛmaL޸hLL$ׅ7[|7ZPbڕs|P;.'vP|'@ + ۼlK7?%bnm dϔ" qP_&fX kU@}-8sp?@b.,01"/PXG7P|nMLvSA}NAifPP><iޅCţ00߰"(}V^Q<G`8?� �& endstream endobj 195 0 obj <</Filter[/FlateDecode]/Length 2664>>stream +HiPg1Yk]STRZZ$J\hԒEŠx'7x GDDTf`91ḵp7UimIFk <OC?o>yq7?i_|@{~pr7+9:vJB.ڣ"K~/˪KuW=׃9!i<| Orbi[,O\깞sYiJ¼!=&1Bz^3}[xrGRbNz8et5.^+_}+YOM2Tӂ囏+8`A.I'o z3kJRH2~GA:k)_G)JTuxJ8)<R/" nyگ%}C{A^uG"֋;H{hRi?*Uj^ӈj9=�&Aȷ +y<#RxgW<�5uEvmYV}2|kZ˷l=cVAt|&s^[  +5!a$h<?{OXGX[n@ߋ5 ï+,ʍ[m`p?wW 6¦wW҂[eI1Dž/G1y)rQ>vi5|x<< +eqp3mnpTsc絯۪/rJ4+MS-]f7kF]zrAOȺ%ztm,K-$ ?(?�/XZy/>7N.\ot rl)>!| X?@xG")zexFZuX7;WݰO رQ9h[ͳT%J]ӧYyL1wޔP/WsT9~7@#P)|deʼԻ_~bg$@?><rq9xo_kHo +Z~Lf}DE(HWoOK[FFy{3e'�۾qN<7*f.gD&֞18ܟX>:-ջ�R*' +Π7莵  +5/^F?:%)C~qStqϔ 縖9уG;M U3VQ}ܛ�zs.Ay/Va2bui~۫ +$?tT>}|+Yʷm̝_j`_q/K3ϲc*l׫joZɖ`n#~Jc񭞵V~~/[t=AWXBZ';?(?F\"ScW ޿}<6 =_ =6ɟ8ܰV꣕=hcT1wYh3٭uSkEO(r1B{i\`o=o(Ǯ/ӾgE/G0+t[)ׄO<D25R,!ыdn=~Y%H^ +!"wC;˲Y'&-iY{X|}!:29O+&PS�}3E&Lر&8x­Y不04bm̞tnf$h1}OK>wgMnzbi  +5s8Pxe/rT~Fygz=<>E[w>~Xk WGw0"j6-,K _d'xV Ս7W+�=R^_^Xk g7;[۫ +A<//ES-{.}KNXk 7P9mݑ`ihnf9^>jWHjj:֕AI +5PVpBFk]h}oLtm7-qKF32 tZAt ?(?B˲!B͝{e }TOED]Z{At-?(?B>6.|EvUUA{gA?f|k@BMA zӵ}lD0-aKOoI6z^grP)D >wWmof[s&F׶%^[P:A +5O+ '8u1}Mpz.JP7!{!A A/" Yy "Zt艍{Acz@]PԉV` +5 < +-ȉmէKDkdKūr5m|uIZAAm1N|#~#Έ_]Z˾WW8O+ƹYk��P endstream endobj 196 0 obj <</Filter[/FlateDecode]/Length 2219>>stream +H{PSg?Abk*u0 ש`gV-[EEER@"DH $'6e+luVYŖY?^מ78iBjNH3s}9|ߓ xFWVf�<L_ʪM$nry||Z ;Z]qZDLϵAާ~rA*Y/0֖MWԷo?yh)wy͂{A x-Qє /iڻ)WlJQJY8sѣ ]mC>w@ hZ]8׫n4rIso׏Ѱ$@*E}�G&YJ +-A-) B~i9":')6=?G*„n=gԍZ&WW+ "]~!E>P?/F >C3w#80 3o-.XA7Xv*u?G5=mUB�!9lGM47YoH-eS4>'M>hoP_?s>f! 3w#>BF&2;34UJ"0㠃 ,km˃<2Iwǭ*4Ό=M0QT?Cw 7@E+xB�ގaۗ tڧNpaWEa>}yNjocW**L?כ]&iw*W/nYʘ*U|a/N궍Cm?sHXs~33)xJ wcojZ�^iGtUkxvT橫*{'MfML2h޽jV}~R7W[#ɮȯ%2Lt}ݏK:Y٭,=^qgC̄-QѴΟW, w:]KE:SVX8Ͱzuk:!vD xJ !:E #_|u}&[E,`vLEN2kHTbV)zㅝLy  ߢu�]Xձpbt#Me0$ĚAdlêAAi^u�] t + J$gMq*������09zСgDqd\Ul5Gv"_B)T:������`A׸{GȘ;q]늋J%!����������������������eHĪ pn:)6N J$ݼu +yz?4' +UO2\vAg:VYYuaHK$z:V_ZgoJ:˜dz5֤^w04Bcoq*77Uj}2fjm.gu]+.ZK|lf$Y{c/kv /xYD={0_7)ޤd#lᣌ45dNIv|ZE%Mpwd.:)ZҺ<8a3)œ ћ.167M6}mc߂׈cX5Y?[|nPa{)^ λ<B̺wp 6X.wu\"dm`fE"Go\ddi$Mm1x~ s\[>R6hPVVlmǾG|NꚪƆ<C I%(^'yV0ulmIn_)<_~o{Iv|z40p?49niޯ? +ĬR~cߣ/l1|c9)xk9bt#eb<_1*t<O;һ2le$Q~:ee>} U SBEc h:o[$įOB>x[W֟(#>Bf:#yyJ)``GA{{lhRm? �n)H endstream endobj 197 0 obj <</Filter[/FlateDecode]/Length 1467>>stream +HOSg  +E 3Ή'e hUFVp'vS7!1f\r{H@qiM,%WZXH~?ɛ}K}f gDU<ÀyEayuBLկV{{PyY#`YO9hg&.;,4TGUqk2Lvui&YTL8,w}ZxUHf/SaHN6TYYبzoej0C0am-Mj~ՒvZ.ƺ`nLW_kh + &Nr~QCƁaul#-]/}ޢ=dϢMYP熵I^{2vraXvCs)]#c&sVz'ZEa+ƺ`nLW9^stj:[#6XtDD?2LvOu72 ښCl?۴g3ߒ5ߤe8,w}ZK}wod r:gxHKk[3X̑ꏘ(D'J9=uG[%̔R`(ظCƁ3kcq�Xl9YUq4nFh1̕!s�]+!났]^RWW=",fIV<O.GTkpId5MKF2 ?l:}!Keg{koV3%HS\iIO9crڛ7Mڣnϧh 'LP* }<_² ͙t9A7? [hPwoX=g\S}ݴ"֧ WfinV=ݽi cdž0WT! +}ؿE1۽ gm=2+vCsr'T&/`FڸI�^Wz㩹BC01u*^QA[RR^PUq<&tytMm\.YuZݰrCGKNk4 n:m\3uIX[ϚN\KZsr憌IUg&'Cq80:۴FԄ5 _k>}Iꪪbάb^𹭥I]D'O{DjBl8d DqXs~[3}˂Y2U]=1.QZ-!=uQ"^M˗?hk)o85ޚ5G_gRwG ~<u2+Wqd?[}zNwf,�����������������������������������������������������������������������������_ �Bh endstream endobj 198 0 obj <</Filter[/FlateDecode]/Length 7415>>stream +H|Wݪ }\x3I3ɡ-.-@(%N/҄зh;>q &%Mk>M6wi{^?-9$Fش5s={%+j<0C=ڪy'h} iep�^tg/IX\NzL*ˏ]~m[%UWc6!Z ye@^+{1}qcPlPK]c'jr8fO֍a3?}Xs-7 G_EPy({GxkƭƠ[DtZ8F_<s2M`Yd. }/v)h& +.^``Rvdq)%sz)Kӥ1l[HfƷUɚ,B +Ƴ \;PVdUtgch+ŢU:Zv{ӫkg<b2 j]Kv+]lLוZ6)R;tW?q<KC;=sD4ٟ }X .z3sPvZ$clvܱc:/g?cKV; +{lU~ik(Cٚh(T lSJV/dأU/=(ת0ۛ8*Ζ%8-!Zg>56-O<k2c@}7h"6{\7 >BѾ$9y<&R7ژm=T*ɟȺK-cE~xrrM{4贈ZJ^1 nE4"TLT(YZ>+w.d{6Kᛇ}۷̯|߾O>_|޾6ۗ|//Ǐ6o}v{~x9pN.p :M~qIg?>srG+dahm2~_:�7{mrvG%@ 6RV�Npڏ,~4]:=M&:4fW'-k&h t0`ow!<W@@qc9&s(h3,~T.ߋysOXG%蓎8bۍΈ#3zw¸j6e-`'{}$T�.=[c HTs&;;^&l]+*<ܖ +v1W) jbJRe?UtDE`fԗp{o YT4XxZ $ \bAn#S`n ZX8~\]DS؀WajV;AS 값\ +Vcch*@e\1 =5At p#ef0WVO@.Rd`(b[Y|pQPc h53͖ +'ߤqQ! 'Jj#Aѓ9enR|]rCk<[4 +� 7U*8r@nO~C֍lY<:e*1]WɚƉ3`c8;Ahm6j˓+Iku'K.H>'"FZ=W W[wU{̃t|hzWro: ~]>/lm5#ceq'F*Xz-f+QvcrL=)[M+'ڛf�ˣ1)FG%ƹ"˩HK.hd֥EY<v&A.-kC uً0N8b PƸpI/MYT�J 6@ pxl%h<lqn9-`?[<'�yi ka)=P[E.ýssl6OZ&W) IFeeu:^ShBm5\K @ +Є߃;9Hd&~Fc4%ݘqpy`դ1M8ʃ BL Ɇ?e`;_ gyICxq@^(ok*8AֱZ5i]0Kؚe+t|ȝQ<G e !؛Lf62`0H͌Q`'$)6דkx+`áTS;`C/pZ)F5K4~^scl8xA0X:EAOؗ5sf�G Vd8m1R9;##n`ޅ+Yo1`H׌WpAƤx\]F7\pq|14諞w#j#Ek|EKrMžnMz]V3,l +)h+d:t ^ +q.�%ǭa3w葀cdmaΐ'ONgp�cq!m˼A6s,}zvն#EHs<$A2hސvS)*|}9n:3Jp:=*uA\ĥbRv'qB,�<`&Ja|A8.iàB YqbptE z'$-wŃH}̣Hp=т&άL(zVTe-1t9pbR +I{C< P'DQ4  +v!*m$42;,)T%;79n8 *> +ɮRJ +b8Iuak>]:+u R:p�=V"13ѭcmfc))&1Ҁ:OXhbW'>漬tHŌLeFR4xY#DtjЈ@UP\^v/s"�N=]9k~RLi dl"{ &ۭ$0 t2@WZNV<�8xx# zY̬ hSr"/ATޠ iքp9/5J2xHV9sIE\iQu%=v�  pBJd^M(']*ɇ̈17MLa̲t׽L0%ǎ ԛǃ]˃jy5@8"o:$A=G,3UQЈ_H,_!/j2+s`cnihңJE[&ؐaFkb lBCHDqw1h =Bj򑔋\Dtޑk΋W}cQqJhڧ|&ߚ. bf\1[V!#-;6Oƪovز,d#u>(teClj̦hY>2b Sd^Sg1dVj0F\TyδtF[X^0�w V1\l"H�Fn60^0`Lɓ.$ˊg͊>+dNQՓpi,JRO1HUe]eZBX'tTy 8TD+oʥzjeBe٠ Bs&ΖjE@n8:3 cAejѠFNL@RAx +<db|RT*1zZ #:K,+la89Z *f, sQ߷է'-f0 91\\- + nybT1' 8WU09Ī&pIb66|*H5JštV=h@Jr5)MT&$KhrHUqb띄*s9k*Ix&ϨE,+ISr*o\\_T?�!X$ &$U-F[۠Fϔ! V5#\KjT6#.P$F%^} Jh/2U2 k|O >Tjd-eY2*J�2} ,i.d+Ե\(|I)Q+2k% 'ƞ*dq ٨giTJJ@` +bUdUSWfH�XGx%tYX2Vc!ǚ=py֕cБ8S4dNi|XZopRĕWhERТ_huO%c`bʡ! T׌1JfdaРe@1fNzTI iKVtBK8j4^Vx@IaZ^SZ%Z^?`+ +qt"ox +jǴFfxrư +[!=kX69NSQ -{"XE,Ѡ] Mf9:EM t 1k>s[ IPƀƈ)۲�>t5 +b`u1S�2-wN=P:+6R E!26/zBd WB_IIoES$_ogg?}b.7nz2F2x:7]?vs1_gOyt'u+\sp૳O~~-nͻ=o_z<:[nl_<󟻫qŃ?/us-|oՎϺwk~fʫŲ[]mڞì^}yLD˶{\Hŭbq{``bW8t1'[G�#xwxwd`h^6/<G_=^陸Hqy[b TզVb15ODŭbw-M{(yz߯ێݸXح.yQlw; Q1O|>|jM?P#3M3+ƭh��d`.f>4e+}Sxx'o>zM{;ڻOjﮩpR{sMVz:tۓK轙>޳'w{'w{_r/?7[HK}QAEIuE]].3{7훮wcK:t'$GG+InT.}u(48Wաp@݅5/χfg v|jÊ)/հ(Y'{yTmwf^.3Eu˳[ݪ|v=m13E_(vlr o@O|sǢE;?$#Pwg X*w(>ݾQx>ts璞аn78AT*Ӎ[G;0aYVe3<jaxx" 8H0h6ݸ|ݎ➁̝v, +L9.s\ v\Z{KsՍϛW[SΓM^΅`m$~A%AU>ar0PʕdG3hD%lP+5rc`172cpsu6vt,?i W*uiR <z7ZP a8|])* lHt PsvϹ(m`;>Cl N0;4K{@IT+n ~1 $Ya:åz�+R?w6b^{L ψP~Gk[eP~E.t`Ux:"}*S |՜šڴI֘0cR ?R9$s9Vg7Y9>/.J }mU4l\ rx3R؞ĤMG=BH\+ff$ =|$S)u'p->uTg'9mIψ5"VtֶlEL[Q"NrL\ . uHf<^#\H| Uk!!"nN3zŎayZW%1BnI9�t6_/{/yXogޥ֍7oH%>£H}d kTqᣏI"`$$Q tNϔ9*fE!eZxfab mlt\a\ ʫGLłI-6=Fr%TuzD acb#N9^8#bEF-V"6k<$"Rh9~QQuqzV6Ѿô+Ld +# ),lEnDBzJCIg3mϤKa{F7'b|SFH\+f$ =|]N$p{ +Fbs4e)ݧnϦu6&e*ϟkD mFGٌt!7$bDguƀC2aFKt}hX ?qs+HdO ۏՒ-IrK`z<73j7$QYf˵"c>})ǤK}e0i(a:uG�ex;W*ɯyMHK*L[@ъ'fѕ\VNj/C- o:a~< 6܊P؍6;Nl$JMY/ q:Ұ;DM6_1Phm&_.A;/yyNhmOZg|ϳHD 3Щ{8oc|ۉ,6L׽4i?Zpچ[ۼJȢ2]<vo & G=j VC3V^Z@|hq}dZ +XBRQeab -uHn/?d{?{!K2 WUSK-6=2 kcDs +s&^OH||ByNDAHBB+&N[d$^Rh9~$Zq34b1?D2!T6b2W6' ;knH56%8k̈mu4p`Z2qIT%D$JA!q`cp[|J WfDP6&m$7iGW1fʄ <yRcsdF 29VriU�d/.wdRwￇasளՒV fѕ\_v Ԅ١]xa/<ܪ%[-Vݸ t ncj;J{gIwG`rM,$!eZ +[^&VHr rH4}Fl0 CUUdRoFm:G C$ќ=]5W�s endstream endobj 199 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 200 0 obj <</Filter[/FlateDecode]/Length 92>>stream +HA��  +{�������������������� +�����������������������������������������p1�~d endstream endobj 201 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 202 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 203 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 204 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 205 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 206 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 207 0 obj <</Filter[/FlateDecode]/Length 355>>stream +Hk@p@KZuu)vZN86}_||.^[�����������������������������������������'yuNOxY웪NIΦu3ߖzW?ä~s67MuStу h?_nTrVmzٻ}Uﳢ,y~:_Ϗ/aT|vUͫmY] E! k<<h4Qa_nVo Ðb[Pw7p}g#����������������������]Ap endstream endobj 208 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 209 0 obj <</Filter[/FlateDecode]/Length 4080>>stream +HW]oY)+m +$M*W!lP&YsøسB =Ŏ3 dnV`8}Lq7ݓ[|g||3HOHkFFlSb'C#PBvq=?i}zC=KZWJ'!Q4HiOBO S,F{LPkUV'RKL;B 6jEP\\2Mth&P0W%FܵjD+POcC+ؚ݈搶@DdCW`:90*B%l ۽E&sE�|>;j RT(|W 8\\Nah>x, qv�Ӫҙ"ƹ+ 4v +alÑ┼@֡qˁdRXQ*֤h׶?6 ꮢ+c KaS%iZ]M5@c-Q[x{& #:UmǢWk),ʸ.BX#Y/m +ZRt{ Ј V`I׻NC$K}CHr d~Г{ Vk\I=odyRafTdSг%6cRlô1 ^ß཈z|? r[ +G.w޵ (uԎ.F`h=E -#T{��%Vr!Mb' +%/au(8A qƲ;Vr.]+;aSݵ+c KaS%iZ]M@c-Q[x, +ZMA\GtmdmǢWk)qyZ^C +MO)̀8ȂxroߖMN,HZ`.onn%m) + ~K[?$;ꦎuO?Xbts*c +'@pm}f%QϋzS2 +iU l+h8$4Faz Zh07Gd)Ŷ{$Kt+-攌k2cd>2q ,L…;d'E͈\0(" @D:ə1qTYBi ӍwbCRk?z Ed Z 4 ۰R5]?{Q߽)mwSB>jit}~0xQGt9]9FI#=ԓ0S�&t1ӫO9}Z]XݜDIN)Gک7>qԠJ�CiW<Q]}L1$zU1L<'(nUa'h<B{ET�>S5o}4LpBip3W)#:m]7.P^L85%0)_~8FI#=ԓT AT}Yhri7^1 ،80FDN΁D8D?_>&}:ah~sy\&ݗSgXT:@&⪏$_�3J +7]Ӈ,sfwK~s5]ݻ@4f@B>jit}~9Bź' PO:̷)o�a56C-1{mRֈI9RՍGw1e1܁З]/;0ɽ}Ɲ6 u`A240MMaPFoPgo/a==/}1jd=yh:&yE9VR!Mb8Ҿ*�b-*FE̵Sk rfUb .GrXMATQ/FVQhfHVħhĩDKKoX@*q|kI3AcAⴂ|)E 4b,mKCHp]_BcGU'R̤V{(Lx#{LnWlGI*3V۷5:a\SUq92eZ fn TAKS6}%RޢԎ(To4C=V*W@:Ry88Y2^}zbp۩ UqǽF7%G +ᾂ<rXAIF`H +"iqqofBp2z?>o~۾e]^ԽzzSWJMk +k(|@H!dYSk*AW>5i|Mk_=5>0JM㫶u1ide4 C*vF82_-zw)r@4f2>z �,cH +LGR�� PDB]Y*&(ziRVL.bvDs$2 gXr>8߻'ůd0ӳ`'G{2&@Bt3ߞyK2 +ic+Xs^sO6eRv9]$x.3*B1@`(2KB�: Rd \EƱ<ܦd8 ` 94 `ݪ_>�<Jc|ގxw]@?XbtK@[ +"E2?I}. Ʌ0!tM{yR GT +o@[3g߼7o4~xQp {*S%dJhATJ0i載 sJƵLRGأ( tPaQd2(. yr90"5#rJwàV7@'goQ9gt +1N7sIO_R''j5蟰:aj J_^E=njm_D}rK.4@QL'ҒK}R6R * C%gf rWp_(S]H'0R@M0*Buy' +Jwū2-L"Cv<Ws[ փ~l\jցmeY^Et֦%ƌ6i&*!}-mĎgƼ{oTo(fU�$BթnzںW�Zt<mzc%򦃞Jetb|C-2tjNe ,<Ҥm?dj&-5i ^,1T 4�i.v5)\faf-C]֖{A/l-yJsSs]ЎN) [4jLyPZD2_ >jfLevgJGۉL,LrUV/[S~_naFyq-1d:iuZ&Ѱ;;0GK K<#{ZΎ_b`:YXYh55> -CʠQZf6m~G4jW[׵ae_Dž&N2ͳbRa7oJݜ˵{yg9E?X$4V+O%.�mׯ]OXJ[OTY�:}D'A}na PYO0^="pD-!f]- hC ™1!e0VVP^G uםaJ o|̅+h%ʪ4S!L{cB2~RfSNݠ} {�K ̒!x4/1�Wtׂ'O4+^DW^T xR7Cqr8: O BTQ* '?/Ɩ@okɰ >\ZpT_ZK`"\M`7l]̉|dSG>&0�NaA=Y68S$piy@L 9gRWd.v�O@4)Ał"FȠcG JAq)` +`.F (�x`R1FrlXJx@Ϝ�r-�O endstream endobj 210 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 211 0 obj <</Filter[/FlateDecode]/Length 698>>stream +HKQcsF Q9!BnMR2, hhԅ_%MHɌб~~#%&\g8X. >Ȏxy{!��������������������*8]"6eSjt)znv]����re[+ SU7]֙]����u쫪oLٵ����PTQW����*Φ?.kˑcN|19lf���@!# ĦLxv||C���O躱k&yra<?zY���Pjt)*3nOYO0η+JݫWD[[x.B!bw|w`WsqQt+~{{r&B!֎|Vs?w|sKa]t=nv L1)&kXEc}Caxi`#I:@{r<˿P[l63.z>zr{ VVc6旅;=>[$4%O Y|G@GTy44Te[kˑ~0{>z>zy3c=gc=@W̳>zf]F@GPNyA%3��^Jgk#�+ endstream endobj 212 0 obj <</Filter[/FlateDecode]/Length 325>>stream +H1NBAп JXhA> Ԡb$@&6nM:b/$i_q{ +�`qzMV?w �P6}H�l3�@5"g�kD"��e׈D�ʦ<�M_#y�(F$ �P6}HR;vS��A$)w~[��eI,r�.HRW"9��bI󲞼<>\�m<0I��l?$jWoc4 �5H6|o�` y�(l4׈��(||�} 0�း endstream endobj 213 0 obj <</Filter[/FlateDecode]/Length 606>>stream +H׽KQ%^+ILMAP ڍ|4_RBۚ;nt|L-`}c_WQb=v�K %�@D��7��P(?X��XPL�@敎zTǡ{];� c?X��?HI>_<sv<��sݟқgC;��l>.~Yk*N�@F %ύbv6Tq4�� +i}ٴ:�AJg�|~{T��816F*�|?HIc<Z'[3b3mz>|y5؟X㇛ oGC+6=B3b3!r!G^sK9#}}9̼*wֶ֩{ KJ/zBtۑh/r!rU.9ZyY + [Bk,N??HE�{��FJ~ 0� endstream endobj 214 0 obj <</Filter[/FlateDecode]/Length 624>>stream +HKKTq +j]Y{B.--MR]DfeD:EM+m + +ϑ:*jye3ށ �xٱyK*~B9��&QLg�xHKNUMoή~<�ěFY,01�HWjoޤ��$Fٹ+x|V1?��M^#:]h~?��M^#,-y��$F\y'G�d׈[/zz\`=� 5zsXWhUY:xtt*^Wz/:σlύuӧv �+_33YfGo6|/B �MqSUVܻo twv n^?Fү4��{F )7 :z̧|� sARs=G8ey �,-/j`zh8r��0 r��0A1X.iOp�`pOYE?:{_>z��,i"k?W,)J�w?�Mr endstream endobj 215 0 obj <</Filter[/FlateDecode]/Length 759>>stream +HKq&ꡠ!TdFLtCs:sTTk߄yN3֘O|>m=B�Wo׫7r꓀&c>%'nN7��@.AϞY7b? ц&T���!vzr;.7{RmkCM���"6W袰?nܗm7��@dG>:)X}���&eh=ea���LB+cetRU"9Kw��̎M.otR}w��lͱ-rIqOvV]���&k?螋gNԪ> ��H 'gtRGC{T��`Cr]t +)@X'>ݫ6���vX_ne.?jN;o��0QMɽmF@'c؍xΎ���L鹻a{.ꏮx|\W<���%wctT?ZF:Fê��0It`H5@Xmw.T}���&ahTO,]Mn��$鏉N;>���ZM@WGg,T+olR}"��.45wYl돋_ �^m endstream endobj 216 0 obj <</Filter[/FlateDecode]/Length 870>>stream +HMlq_"3x\Bb&< )"d̳]lVBجePmjkq`!N(mBi8J~;||>J��8vK]Mųf7y}<̥hsGwF���'Y0տ`wŞLwF���'G?;&I?|V`}ԝ�� w:k0Y/G,��h?;َ`DLlmI<;w$9��Lv,kPbdGvK;B~9��Lf_l:x'~+%rv4ģV���&gZ0IQQ׎ם��dҷW?`Tc[j<_<w���FZ2Am=Roiioe���&IߚWc4GvK݊.5ѝ��DKݎ_0M!^z;+��zK: #ug��0Pid [c厫Hw\���,+*Nt18A:czĝ:_u���&͐)?`tpܳv]m7Mwt��$=J*W7¯0L8y`G>}oxr-Ԓ5b���ES-tU*W5]S8E^׎|h٨ +kru��$UңQJzC;q_ۙ8E-^T*T[s>ZPO���қ?} }aaҳptG{]޷ǛT/O[wFee� C�]b$ endstream endobj 217 0 obj <</Filter[/FlateDecode]/Length 1720>>stream +HiLTg&uVKh*j5MJ(*j] .U0 P6نm6#TqjTjSDGSԟLcKǹ� IC>}m=zEVџ}KX\a=ʤgzo,} {LukFU\\y$ M:_CCF[����,~_MQ4a)S``>vq+ΔU+.Rg;٥Lڴʼ[/wǤf:)���@);e<q+\~�c^gT1]7x/ ݸrZywE3lɎ*M<ƞVT9^f<1���('=c妗-YS?+t聾.)3*Љ޽qCSMvMzġo����]4 +MK-Ͱ 6X#ؒSiq+ܔ8[nӅ%[̓T Gϼg2����YT, ӳl٭/j(eʄX?j.,p=S]ק9���`u(U~|qejI٩QwPW\mKBw|W-\ĉcjK ˺mC4eUiӯ+^ns���XeUSih(OK F�[1B25'C[{y]UY^w&zv����[ț<Th^EyjsFo +9g +9g}wM_D88'Uƥ_���JH `ZӋ>bYN>͉ GޞgJSs]$}eH)Fi#ZΊ݃ YLUOBj)c7O'Thpd����- 9=Q(Wf-_rXݺ1>%)T;q6}L +q6bMv|6<Hpb{UO7{j����Ƿ'=a;QA9џ5{QNC�k$=BUu|o?6~ʤˊ4ZxWwS���XFXlD\ˊ(O@W۵^6b/ GL{ͤU\)zШ K1"j?HS8|����fD9?b٨QwPJ}JΔ܅H^*6bߵl @$g1VΫ7���XցX;ΉrӦf.%XR~W߷U ���Щ(9UwIJPj. SaIy lMG͘]KX1wXΕ}c ���Йz-( ѧ)/\lrB�[A6ep'%3_WR-}^���Ttyf CB9iMۛ?tFNhzXUa3} ���)<&MkOcF9'9fX'+wo&Tf{u5V'[����ACR9ه"G:?tVYk E w.ř磆���:m{ u/qg,4]X2/9 la[�N endstream endobj 218 0 obj <</Filter[/FlateDecode]/Length 1448>>stream +H}LUuoWT" VIњ/E_k,I 5גH@5Z%][+o\NAݛrETffL?ٚ\rϙg{=γ}0zRkC]-*mջ 3���X͞KηUtQq<ݛtWwT<Ho򂭜f�c點ZŎsM&{Vʓ~u���'Zf?vsw(�Mt)VrI]<c- lRO���ޏgt׮1ǺA%jV$4ƪT 6tL|G���'U*1[#gf= + OdB�%qW\8s7cķٖ˜դR. +���<TSS}~>"7w(ڳ?@i?h^|3 :ԙiO=etxȽ����q`tQ[jl3ڻ)r埉T$4[b,ڥ"эv}ƭX) +����%q|~ s(hD#O_tfm +NiFzr +����pHONkkSޡ܃pw4iՅ3ŷڿ{2찹r���/s˅Dy}sܕ?@I )(ޫ&,Ǜ{����w;X|ZJEgnضURΡ4k~ȸV|gy;?`W���pG3祫uy +s 79ݙ?@I$0gIY!X쭵}yr���No]k>֭ C3fKYI&4'm +FASZWztY%?O,{iN{����"3 -<H_(8s@qk]3(#j)_ s}kJr/<-##@}����fe9sʀ1Vv\Y5`,fZq[x4]aC//W���Sy{3o+%rޙg6)'P)Mz-a[-Si~qr���lHL|r2U[lٌQI"E~B�%e.gn/G~iFSO6ir���t4192]3Ho~15�FA/[%jHO[\.Z���tKy \}yT D /W\/L7˽���x+?ѳTUhlK.(InB�ДT|&J|? ϼ^ ���<Kŏr +ӦS&enB�%Dx H4cOY-FG c_`U*�x +0�~Z endstream endobj 219 0 obj <</Filter[/FlateDecode]/Length 1742>>stream +HkPe9#V4e$9%b%0x%T1EN + ,{3)!<p4{qivݖy>=Ut'dA|,{mQ<k &"/a})Sy5֟_iqݫѮOg37*s$xN4��{u +KFK6j;WM=գr 1�ëЈ + ( ?ooD7hKY ӑ]K;#�� O77jI ! 3FMi[Ydg+[b R:3#?|L)z״=q#f\ceS;鹅骑,��>W9l(;)?\7<q.O 4w;R) 4ReNA[~<~u'3PdlH��Nxx0u$%ӜG>{栜By%Q#/#?$y}Vֻ\̚ +6(KN}���;o1R~tEK.4}MP^Y  AY]X!o̽@STZ!y-���EyVScQ4 Ҷ̪ü8{+7{3tM6h9cwK& +[)zˋ��WfPO0x?bZqUip.|5W7Jߝ91��ѾO4u*Ek?Ml,9Ŗ+h2sz.v}��I}O{'q3y$p$?l5z[,ug-:H]x;4yYy9���Xȋ#p<{-[uB>`?hT eGYeR'f>r֠*1-=�� -; {Egh[:;P\"UFHH։TLK!4U4mK>+9>~��IG N 4R.'p❑?Sɮ.5TȯX nXʳ"]\x���xJLy`$۵^VfhfUFhf~Cs-K.Q++i'5���L0 {'/)V47Lp<HRmgyv2Ơ.Bޯ���#E̠V^@nut=%8{4񲽳gnX~)cIM'y���xTr|>8J<#38"{�ӔcNLC# bGuFZ���<eBi?߮-rfi:Bᝉ?c٦9QvhmsдyFMi[%1_ ��򘱬}6;evEJY׷sue^i;o'3tuŀyy��!'p̠.ԮO5lhn1h]Cxg!pT?hV5Wm{5o$Kז_~G���C {[٨ܶxcF⪐?xg �J>j endstream endobj 220 0 obj <</Filter[/FlateDecode]/Length 26165>>stream +HWˎ OQO}Ɇ<a$;"ggw}1(.s"##Ubl< +Yf"2d9*m,˹Z???˧/~˟zMj/=廿}ןw?'}+?+IKm<zcWk<8gj!XhHmXkmZq6%R~\UjUް]>B*6-3x*kC[k�,_K iS[ą4He s!EAAtC:ت6LU5/d,Tf@sSEi<1q͘Xvd@՛dgLKV)EґKC pӃ �7n_N"$P 3 +LY fύOlYtnAp" Ɠ5iޝށ˻˿ym;-xY� @R$}XzUbV_>XGJgkvнcRzao^UY]Kk D%DgLNXt8^[ 'h z`5+ސ1YJSI1hЋd\-< ;,(> �Hd3YLz;K_-Kgw"UQ9:+[z�S+(K# +EJe}<)o&̾e6Cط +ޙ{ P5Ha*cyap$h *nkYaյ�Dϐ$ -U!BfϬ#}lzr?8{&ِeQ +6X}0Mb14EqR/2٪tCX[y-)(8F*ǀ R\C^ykwYsHhdK(ũJjP0t\?1P2?byԴ0 u 0mR�2@@e0)c9 X)D^0{BjlE)Sse^c{{i3NW72ށ,m>1R#(AkwKM#67G{J,usMXA45gyj/[)=G[k~{>(Qv! VU.GΈa*L(M> KFPz{ #c[hjç`N@QZ+7Ec + .O|t|tPi +B)6ՆHfo41 \ye$\|˧Kt$l{;H{3'UTzr(u{A<{iC^yPKAު^qMgkFǘIٷH{5v|oup%{lKD;eЦ>F0j#O<m@p$sݰO!Ro + '6+J7ZT_’"Ar4#d3wipVgoZSHmsr1`ތB4V@M_#, He\3@OͶ&u |2}aI7FQeǠ0ҸHr4ocLL&>>t_mƱZV\½9oz!'>>-A qHh(w4S +: 'ͧȮd5%ݥtRGh`ESn# BmqX)68z2Y HχZE^8vr@=x@=wT?lH̞*v,>Xf E݃=gӽ\NGt'_APLzSZmy;Y|8 @yH<Y~XNt4<q9ZzA&~d56>OwssV[fl{y9ҽu=0Pݯ;Sp-ޑQݻٽ=ŏ`A6@ S=%wj2 0=UY!: lNw9"t{<cų R舠ӄ#"a{AReii z I +)r`"!Wv;T^+rǏ +r-WӞ⎪|;[H7ҎeY--Ea fz%d~N<h3Ȼ& DS_{N Tz-sm Nt+*IZ'T̄)iW_C@r tE~lnUi~[~;@U3gF%"stmY)r+dÙV,|صZYa+rCt_�uU"o"[^pnc!oٗqV4IfUs+J&Z3k䓗ur0* k>pwUڼ�Dæ1yuz3~*EW[B$ڜ-J]8Lu[dy<2T_GάLQ0|fkߌ'ygpx[. C͇%;_&#F݇猶LzUWmDiMEjve;x`i/ݨ% ?úd.<χK&bG$FDfm)3x;Șz-ϑK]]]_F&PoLꄾ\�bƛ LѮ[\[AkC1֠MjXp]au?P\"тeUE! hM^(`%(^R٪&"/!L"gKJhY4}{qK nb¬> Ū#TO) [)}@ȍ4n" (ex!5@D%"hkۦFNνӦUM;Kz^]LLqɫwnʷroi~wO[jZ?7ժ_9}8?^>O9H.R迳>9ս~t 9p")ǿK{_Bb + +UKcp!*vo}w{ijmqpb2;&;zZonZ;DV]KڳgF^P9sl!9#;{N-&ۦ tm~q$8P6k$$I#3 ܝd"sVz~ajBvlL?t:]ί#j||}+6<'a[oM$&\ba<ڬD-4hNDN-"si5'E2Ԡ\gG(ut޹os<H$J00A +Rc(S! +"ztDF<>gxng>scJ//7csn@u-ڵ5"X ̓%zh&.g*r"<VaR憨mkͥ0 B:AƺDP-2 IcyDE@kb`GD +"2+5e܁n1&@Ҏܮ@7ː`*\#TMCsC#Vkl4n" "Д^F*mNСlL>k׿ 2]:zXLnF}4,Whٵ54I:r7ܚwQxEeRC\,3eҶ @zA.@W|la HH*=IGPkj<p8f4&HZ']Gp`ͥOGDH45DFq۾[r|)ljVw\*\M +ؤ4[KX`9kq ZGPz`^7c'$(0;n%] +H)w̌ d%й5nQZҚiL4 ;F2:ZGJ B˼Ѳ/:L&aO dIpMQ"K�5oq=>);Gs^yXH@.#f +՘<ԍ',M17۴KѾXc{*öBb ˤf4 <bˀS4 +57A1nc_+Q +!8`q< %u`-957 <aciX=@{sX*jqI*Dq0!�es¦L36ۂ`E/כ!ƞc~׃!9M{GtގSՁv'Z{Oszco�O79V wP?~@7$\Nݨe4q$HipHi>jvGWr]WKuIr2-޴`b\mʢ^{FGv@z0>"O[{i:p[B<Dg̤噲 uwϡ,oKPt|ٳu"ua5zi.9KIhF lz7Oϥwd/Cu(TT91<Їdg*cdَw(n[oS7>m|6T}F˿>l6[~y:]^^˶<1o[pqv{{g5?^j|v";wNJ(RRڸO}1[뫋嫋Ra㙵;zҝwG̛gūkxڪ_9-ǻWwp?Ct/c7E˯[ӉF�Z#b2}P<So"LUaQ+iQKlP5*32/ڤ+6N$ 9m.ԳsnXAxӎO# `5GИ0|cEU&U%Dٔ!\L(EBB9hc09_N~�62NE{0L(^" +$ciZ4,+eK*INgNWɒ16BԸራC/cL,YDfMT%%Sk(uOabfYHL"rș6If$PJi&g4rVXRICJ)Asev $UTGTY%iN_ri X^kgJ([`=Y?WkRXBys"C]( +|&JUdŨLԬ*PFs?mEpd!4*0T$H:T^ "wHr,F5W'+ވ~(Y0E=xi %x5Be �X +,H@f ؤʥ)z#P6xJ8n0DVߺ>GQ/ dP4?kqNb`v7;n.ހ1Dk`,V3 .i (Bs:A#Ats`r۳֐$H*:W}Q +t(罵-uȄ@?O`Mh| +!'Pf| +5%(4ܮژ^=zocp~{Q88sy~OnݩӚ#th?9DNbeӝLs=8]J2^_}6.j)iGm � +_OFߧ@;lZz +G렱TZ=ʞ7˙흙wh;Wެ λpQ\0QV7-aLD&-AA3 ʢ{yX7z㑦%ԏ7xaP>NUfko.@ZkjTrl3Vs2k nFA4akA7cJfSw"Ӕ(j܁?"5RT\\dʴ=C\+�ZO'f&n(^<@PqSI΃ؖPabDm|:7!_qMlޥ](y,*ޘB!onŹ٫g[HX ëvw@U4TwѴvԴkLeOȍӁ-F<V39Xm僩!ݸ�| +]9:TQ3A2@k~q ~~-HHcj$î+,a_ח붟;cx+y_Tj-5U+Re(B!X(Y\ A9sVWbŘX'ouWٓD̴ĚdxFks݃uQ(藟wAK4w̲}.L.V5/kHi<3ʨ;u>GwuC*H=S&yxQ+ $am"kJ[D<Mj$ DLh<1 BbR<e̓zu_fb{}~埞83yۧ~Y3dO pМ2D"�\ $`ExLbfV/e>s<5AGBxmė} rW]qS=nY䏲9L]*QnDrɸzl/DA5,CA)BetS@Cf < )~;̾/GQ՞Y +_4]f$xctUw89Qld,$u+?O__&WEuI + *7IJ8jO·0Ne<ꔷ@͍$ |w>�LMF2C8^m`mp$)!HyJvLYϻ2"QWGGd RnmX=[K ϣPc4̍:Cì$~zHWZ/ex5dNHz[>ƿ ڃ,�=5G[RLt`&S/"qA,i,PW@;X,B1_k<bs9FxrzV=kLLhJM)$H'C)t\6PRcv W)d[tX[u,%Y +xPִNdH=f<|Qe]ʐ^F (L5B$<|!%!8Mg +g׌{:4mפQUI +0 gCkNf06 ٕsRy@>m#0I?Hu4 (~o;i_O_�߃unI^Y2, 蚳@̟|*k:J0^SG5mjd]Q1waFhfB ߸90onj!\]KfΩ߷˯#DH^w#?9d �kkQKW_ǁ>fiKCp}W~Qʠh" VNՖÏKv :rbn8`ur +CJ)t!ݻܒ)Yoǩ{K=9fFJB$!#Ewv $`T5K Zܳ@, +f3VNW[$I@?)"GnAǙ:N$,jjdžm̵{n@^cZBo A1:yUMIg/"j<]#2=Mf}xnwzA,kDȌ;s5e<䊷AzL`B7 f欉1 3}ʌb}} +iןL3RA.{g\i@bkw3yzfVyM~-Cd,\V1y iJaiR@NV (Φ46xYn5\&_S9)TʛN!= K4Sזj3L4q s53-- s2h `98:5%9k!,�wL:4֘ؕ͝219~ZHvxv26Ƴr@K39@`V>X ]bZ/%|?N9jÏPK_X@*e&:nfsj>e, 3͚ K<W)YHt{(K>Oy-$>-)І:ێe-7^iWE{%R[μGM&8[:e<NՉi#岲QF+{&BdqW(ѱ":1LBg<h:_u*(_[f`?V~@T yq(5l}+/^KGbUoLcHmYG/ReH�~G4YdG/*dZ�'bD6yA]IfDtWU+%4Xm-%3_1򠉬cҔp +yuHj~98[B@|:Q I!=Xqܦ%݃SW3ScPxgsn`.ş[mSZ%oV.dCI1m7#AՇ 6a\BSW@Ad$q۞溒R}h9tғ/ΰeey]c5ٟ9?g=-8zIOKy +{M@`\tRx7W|.T9DZm]3u:!_t &8.'ňq)�C$`ذ@^J,CAGr'l4z}yQמr.nSuuhʹ(Em&u YE."s [On*mI ؉,| `oK_ k0Įessg=\vI>0tv7WѶ4wF|: +V7HX7^Kh� mI\"z0T.eveta@OMb,>Nt5 D|7 +EEcj2oeʡ"srCNܽA %u D^׾gRب'Qڶ^Jg7^5݆}iXl�,u0yޯk;ve (kuzex'3 TIs|dx!(ȋ—3o i]*)7Jd`#TOR!HmNl{|ƷE7!:+ a9NF4jG[7;׾֦kkݔifٰZ8z0Jhe7Wnk% a*TjwȭcBZxv&! +jҮ L*,X̚[C7 q Рe�Nbh{M֫ +, z~J|ڝUeuknW`+Gv_.�XQ惨;Ho�wXAUth&O>a�b*#iP@Ě;E@ +.N#XCqIhK:iH5M -:zvyO],zzN%0Z@o<T9ږzؒ\}/ʄ:۳^}SWwxOdr1 +&K/K?Qvv?G{E{�~c#>|ʴFw>lg_QCHir=.d8xc-n9:@n噴5ZQ- Zsj]ˑB>^7ƹG4 cKi=.ߺ1/w1(g1ot҆-Mb{f^rzgUu5<Rcókv#umO=K /Fa2^XUKRxh@\*׎ q{z0rmsZI܋Wn5pD"A?rϻs?O~( xgUFk${PASFL6]@/x &!)p=3 +bLu-Yd-Jsie1ɀ(l^Z~􋣓zLiCjpC]*]1E3< M +u" /y" 3R�x^ ZW!k4oђjJ@)Lm(fRO&8YS9vb`D@ֳsl]ޓ y cd;W$e +'ŃEb*􂟱hتL,8&l6B7t5iLs F2k2Y(%pp(Y7_$<wp[&\W)3sCjUͽZW?>o7 }Sݾ|}O?|w~~5_??>_WFتt3Ώx8�A!xS/I<dt?@MY̪"[.-]+I\}kߔC`δI+6-n޶[De"LA){BJ1Huv{Ŏ]tAՄQI7BZ;h'Yqg^nեɪB=Z9_~bBfaFcɓ`H4ȎZQ~ߌR,)~כVU~n1;b ]l4]c$/Q[Ϥ?O@_^_|񧏔 b?24 Kh`]HZ1Ŵ,7Vv܊ț]Z<!(N|bY,I9<u2}- +U7r>bl+[_ܑV"]5rOV׳Qxҏ`j,j_v]G;v7}87Y^%QzCΎM5~_ !o| ,Ajs_^ro[EwuTP%gOcBx@6̝O-T*<Lc\7X&qxSkIRD/ALB3X?k+ \tGʊǎ ){]36:0oElj]X.1% w- ; zx9vZ"%Zrg.@#AC%,"q"9ee7?~P`\&܊8#Sii4j"<&,cڄ#pre\=zIgzBm+"*{vpeDW%m7(F5hNe0(c|�Z{vmrx&wz涾|S6 jʠŌ-?\PYYC/VSS.4v.t Fws%u\F2V$]/~sų^?dpm҅Nғ&6&e.T7#2߂+fs]�FEQl.j*#pA@u'm-Efsbh5_qI#5XN{$4s1Z 1-**qFIS4<p_O}^HVM~%5͓T1>S֟ĕ`y,!zVFF {P{םNSod>9۽%&fLlfͤ_F<)(s2LR+Դl1Zޫ/㧩hOsL+e6+jLm+ӌɂx61{5&+G\9*KI ` +Ү<8u=<gg6@p{] o"#[*(kYjfFx ]DB ;á& +E/ayf{` T6fUy=D +y)ж;(DW=[g&_(JW>Fz ܦǵHPd'S~|nzdw -{Um&Aꈪ~ب\3Mq23&(3NowStFE=4/�"/R@"THϞT +",<t;J|B 05/.=ҕhc!arӑ̆ ќ.Po#o[dz!thYAL LI~zlbh.s֯rKRە4 4-E.4bf :w$їӪNo]djm1[y]e?v:!COmc_5-,L/arO{-n}!�[AI %š&b 9,k;fXn.O:Fʪ~T:.Qj=E/4i|M="n +</CլEd!uLګMDe<? Acn X{-E/1~+~Z8$H +ʯnEhrUCD?�b=! + >e^YT2{Vch]s +ӻ 8(|Ͼl<Tu駹5|CnI9KBVgAۦz1'OF:GtΟ~wTS$|NP{1EQvW]C黯C+fƔrNu@]U&mz>7MvIjw;k_ڊrd0`ԴFh]x"|RJA9>KgVOk^㇪7n@�"#0)(6qն#o<&mLAMq#ƫ:ڌ5(/N,m+Sqe&@QZdfv<X&}G]:z16C[%7rd GvY=߮:4{]Fn҆[q_ɆP(;WYgV:4V(wrp.U:2}3W_"e_ˍ:{|ӏ4KI9 +G/,}'4AW)]y'b!X3|w$<Y`HR_epqX$?ifk%U|xsW;y.NoH]s1!a\D9K9Y6wy>Y_@%ͬB}36=R{Oi@pLi"䝗xk;Ȳ!Ƀ=-ԡq@`1g)Zzdw{m "8ķ>".�+`"cJݡxUR5IV.0J-B6=DicVg.ᅿk�=%F61r|mIv5=i.WX;X<D\P'Mfmȭr}fEXϛ):>aHBh�-\VaD[N@1pMPUV{V\#寸Hγ\Z`ov=K;շ5.MO5T_J͹`izl}g, +::#,{pbedIi5}[n\-zb4{a;ux5}ϲ/"&7ED@;q5UϼÈxĀV]sxM*eL{<Ù׈)^zlGBh9D=1�H{,ʁ;Av9'PFNK [|4^NfDgJ4F1t 5e:UV+0V7¼{T_Q w5wy}g'<yb?ɷB$MoIo.8rz$asQTyHwY۾vɨWgRn74@ruT+h<5clj*Q6\@1gU\S[帛þ#"jY u9[;(lxNf3әFvf=-+Jә6?͊^EN2Qߪx$)IgFimaڭA>kIH[ukGTòg:^88% :fyzdMvX5ꖺ\":߇ 94ױìMŧ8L"9UUU>|=F8=B4fՄvVRghV{3&`O[ө1+:RFL//�7ەAZ|p#Evb |sfqDxB>OM]4qǩŷ�3*zOv'_w>iݾ~Iem qҊe}uP؝#eCw{҅h,z�h' vUF1ԧ' { KZgp'iɝ|\ gXpUyR. +:RZgU˞h[^|e"T6d\|`:<`jhOuuue>fԑH] (İ`Qr]A|lM/O*zl뷿SuzMoe*ѕŇ^Әt$V&Fi,N]ehhS0`'S>Xͻ/ +n Ewgf ̺HK[R3I)9"e?Rr&bÓjDVrpG]yӊP ]X=s1ߺ#ǾCo<*/bH=TU[][bxH77c4ӴlGO2qꋫ}<{{/߾~wD4dverM]쏏g߿o/o<~7oݾᇏc/U߾}ۇ7~ջ><g'w#_{˟]L2uo=|_{A{wt|j>:( 7P1J9'?JXQT_Dpe7b5mSѹ!rx�,J7ODk8݄~"$5S3 FȦM-afZRIl{a1Zءӈ<}߈#r. +xW#C v4ZmBλʡFt55R ֝O2ᜋJ#[Nl +?.fW t\g:/Oo&dzwwy+,# /+uq R&,|*:d XDJ&2DK!%E|yuuv ?9Ga_7C[_v=2 ?*V@%>0|( rH�LIpL905 7IQJI#"%HhIH`2]@iTQlތ:Y ~? x:Om 4VuE*s|3ꙍW|,ǩwϺP#ZB<_FK]^mrl +*AjZ1{-n *էPQ%uuc y/X$F(#ٞ3^V~p<i^YJ<#TuZ7N;=hq P#F2vs%,R:@JG`ti.״ו'whCb٫p/-Z|~YqL4Q}]6[o={=RF?os\WO903e*#ᚫDtqS^'Y,i Qj-yj>` JY6$´G[c*�l$iHlJ#ϝF{j+R-8u]DL>kGqMhPg tYjQ@q> O̠lRaG/Zsʬq>Ogn ILH^O}"R!z hq6oGScإM3JL#<QRERO8!] 4 Yihk31"(桜Rgj(urY7b +="΂AvFX]; ~[3ɬ1Q�)vA@i& +?GLD +I$Wan)eT e[õа(mTYX^Y=_R R(<( ރ)GK+DиͱcCBΥRgGԮf*t˩vP9Ūb:Tj*Gq@ +lf ^'WU cL\="2كjS)`klFYZ$xJ j5o" +38 *,o�$kЅ4|S+i/2{!~솵|=2=K$| 6o'5:^&_'Rm-^tüባa0'dI$y2|- 2}7~`ުHthPc[m !dq`}Z9`$@`M+WR׳[_M).u헛H]� Ek봷͇/*$%;G"Rf@Q2#ã>},‚R}Q쎝WBNlhQ&^? { +.>5 N<ϧ4,� +Lkp0&>@U]490 3܁*YČ!):)b"PthX�풙"1ZPjTrgħb^'~'JF]V_6+Ձ氺SiDь|i>}eaw#Zq֮WU)q~wYۊ+=JBڿs.i!b?_%YX[)fWvSsަ)fH1P<%OsR*kk8N$8͛t!h$=UNj[7sƭEg U#z8 ϧ@5XoY`\c}n󔁽OTyvط6.,m%{0z7^gn-^-a4/u +x%07 +gXn%wqygu +>2\S"EPO X2G�IP釻yT/n>É/;J!iЊařE XF2%yTEX‹鞇SGM;C@Ξ?Ճ8+W _b#B+ ߒ/xwZfcx s JKWF:-/}spTQtMbUs";B4kNYW@#^R5׋9 49""3wg$qLpiWUhD)\:j{^TK"` ^3zls%༁�Uas*l* +0b3O~b~#bsQäyz ϗ 3t ӝ:-|ϓwN@k}"Fw7{D,4 ~}bi�(s<LF 0m#VEr>l+Ȗ#ۂ]1c:2NA +Rj9nf&ң^Y4<Ӣ/.긃tAQJ9A&#:9�OYۦ?۔ޮrpUFGǬD V//mm&["5ote`) =ָ͙yhowۣH_=?)E=Y.s]s4={1Uj R3V'4_)\/bٿCsWV,KrawƏ }UVxZ?M=†yV`C]Yhb/{U D�ط\-bOW9 lnxl슩Φ - ӷ&#Śv-VviyZZ=Yԁ,f\}~kՀ>aStvs+Ӎ9%B]d,{cJXQBijY h wKL3ڦmڣ/礉P3gG]T^ +W @M=:⒀%s._qdfJ !8m`Q{yNu | -僡WN?.[y\G[#k>B[\Tʑ LqGhsN~ 4d ɚ*`vsy8d%XeN2zהIS"MÍvI=o{*ȍ#Ӧ- ]vKY0Zjy[jWDe79lV^/uލJdU\E! @Ԁ!'\⇧IB\�E ~EWeճv0dyǑpTib 8SfwO cTN?gaؔw~h}7bw5 $ؚt,:R?ԇ +RCMqh^Y�E~;NgaE\-C9lݞT5Gڗ`%o˚87 )/Re"zv{PHBmLS;m쨬f j.˜KI\#q8^JJi;W)vuPZh +"su+, +CzRDW#7B~i#E}\}YFn"X[4zT^Aj]"b+5n'%}WzW 'g0V*Ywg^E9 {uy!fN1{ 3xw!0/,6�Rȳ<Du](kFcm:t7!X4 w=5g +縄:D?)vr-[&J|z +EֈZۓ"fiD" <P �%Jq.M`X!w Cyk\&9v@X4`siy *KPx39W=e\OosYc؄ɼ K~Y8l:3v/QݮLZ҃_S^5~&Ql-K /?d_`uA[mdu']ռ:~jXnhU%GQS1TμŔF(MQ[MD*ᥕ̶ZN/4[`- +~T[Ǫuَ\$tvPĿboU~yWWNѺMDgspݵrCִWp ~tmG265H25}RjCMrtaةj܃uR_6$s{R}~Q@ lE]WP׮EM^TWB9Gzʏ 7n'̶΄7R+�jk~Ւ)ikI6I2/pxH�wu`ˈb*�o !,bHO wGqރPG|G#tnvFy =w۟m%; B4*K#&w:0'';K)hql.Z[z!xnZ^d, +t]sGac2\rѫ!]W1,1Y@;h%_?Z؉) 0]uNվ AR'#C]G!W!zyylF##P)4w?ۚ;va9r.~o"ye UOٵtT{�,s!LjpTuF] l$I ^w\;{k3ٽ5C|$֏׉^8\ MMs4$L=dR@Gp2íD*})fƀsm%hDFr..*V1`/8BBra�5 0rj*x"Aվݒ�IZ4E)KH[SƱ5H;Hbb5s$Z46R%H?sQe&em`X"LD üȱ6o!"gl.)b-! ]ukq2#+ǰ%^5-I<;C1>A.aLUsre5F-Cg +!o\Maqw F*)wnѕtXjetԺԅtΤE0QsKr2O)`91r7]*i%a)aԊRjr[қ#E{RrymQuꂼ&6U]҃~@qӴ8\/x +c.i**Q!8FTؾې&`?T.@M6?(Nz(gqP3" G]yMwJwvO 2*8&BB%SeP/UT7ԇL#|+mm\diGVfz-"U ^eD3 Q4,9&b]CN~ЂKthNBubl:wAMB<uiniYO]9n:W}xr-XE_;7.A.& V(Z�CjU.a ړaBTirHX;Qo6*qyWSs9J>J�3x<N*5Hͱ [ Pܵ#v4s #mWQ^ 77`ܙ 5ti0S E�?)Nd[:n<C;g'Cgx| a%Kw}�̋H3dQPRJ74TAm§H|]"Bf󄄸`,|*Z!�/WEa: uҎq<B~zMFϽ3l@5 +C5U)uR4aXӎPއ 5[HO8fV%ɨF IM8C{qT`㒩r}dK~+AVQ0JG1"z:N +{e=$MN+uDs?9EI*C1P +t\Pm ի<�4lԶ,n ڢ=~aw)ܛy{tA:U֛Ķ**;`/-C �ELqRȢ#dnKB$M2Vъ m>kT>V}_T, :=,\L9QI-GBPAGY`'LĠ)$X E' +,�zeT`{^QqؼfN6/B*K1'eA,h'Oa վ2z &S(*Okj_>ċ]i6 +GVt4JNMH;[$>SS=Ψj3uY3VeZjvv_խC ^`ɖ  M&& \ҴI[rmCW@ClA/=ǖ0I,BzC9(Lk8݂QruS{2^lzQ`T]J'N�-di¡*0IL$&n̖N�xXN[7`uF^C 8c)-C4K= 逪AQyiR%KtI/XQvll6e&u i_U-)Rx<~[H-J.q-|*۴G(5V16, =" o^$EGsjg:e g|:ˏH3>cXZj-_,Q J2:¯l�>-ʗjadɂ> Z:Hpvq.iRbh%=| 8PS5tq2EC!1';bR#O9l_ѵ~uJJچ,:?�H`5bAsu +sH tyZLBS3R:\o]8<^{*<> +TQ2{,rO +[3H 2H_;~S%w)xP8$v0[0z -9(TR>mnj,nx �z}e�/@צό˳'/K"~??;,4}�9_X>_X=>[=h/\߾޿z/xo~y]:rLJ~݇n>~x>A[nO~۴f?i$"L~$f$xP}/&c;ӝ !*8$dʙ@PK@[Nlҡ]hFZx_څN4KfE2vQyzN!Iyy@Z]&44*ƧrA *�5El'岣Wq'!6u(#)J #i햌Yk1$Jg`ԩ}.A}5Z, {Tƥ܆,!BvqPWi? om+3plljo0( +|1f CWOKNv8,331~ +JC�Iπipy#0` +I&F`^ݰ}Dy:!H)y<A'f % DnDh:~Z Z yw#c.ިpop#N1K*-6 1upm +n6)T┡ynWjy rk0R&:fGn +pUV7ۓ#jDqDJ@b:VV܎9E Tۍ@:©6h͙ՓU\[0634k>6SM@RR<O+<FWOgR|:kr+'".L#Lt>Rgm&tfN"mI$Д#=z[8Tf vNmTҷUZ0b@QN~V_[$cb~q[--RBdYk 2"B[[!yO P*uMZ;@opU%aO+2"=Uۊ! KO62}X¹#Ck+eIjGܔǝzy56e峀D^eP$lk^% +G)*ox´xrE$thC�P1;#"pgREd69{;Lյ{Vx=OqSlFkL;:Fl r9o{X|ᬠWCAp񔤡@Pg?KQx,X恞сTOV Hݽ�Ch^җn)V;TY^vK°e{ q +4R HKXi!3UTz=#R%NdigPKYnIGPod"C[[A&HlnQ)\4H)1sqn1ؽB]>Ί>鱈x\}[7-nek :D_ǍT{s)PV*cDSfI,zJb+cD;b?vW!bcPXV~%!�[^7=9G Cީ}&(1Aѥ[]VY=6LHj!r_EKZ0ÄB*znQ + 䓑8١բU 5P#FuN'G1ʛrdNf箹. *]sI"±5u'QTɍTޅe\$A z-˦Iy0l� 20}5%0#8Fs)&hCJjiz]m�#0CvK;5SjQ*XBY + XDm&iB]GPSԽ_ʪqf&wJ"Mzs)B +#ZS" B%`?/-Dl@vPL (<Em)TvB^XmW,62 <It٥'"b޼b?/ E( ~JM!8&DC�yQ̣}gvFJ8(0(9DT-�͙1gF N)C<wd_/ԸvE/j�#*K-PNJx=Kg~9xxY^wulH4㓚ݦ8]CZ}IH�dїL5:CQvMmHV|!U0M-jn6d5Ua#]4ԕDZԦ@4NSeD%eH3v6N%3< qR2 )aO,ׄ0y%>S(Uw:ΚwKhۄB/U @ i;Og.Gu@H �tÍɔh|dԕ# -ke;HK�.YGWmQ#qc) Ea:T+Dϛ <ɛy_XptۭrouS4B(9tNƴNxXAhJ�Wֈ@%!P†anLx3,) EJ̷/}x#){?}W/޾ O?o?~o^?}×xzt⫧_ˇxx7/緯7틯_>Wo?5е>)Di[ @v&d6q'iT +0?r,�{��G#TC'JxI#�BC]T;�ΉFg -]㝺�Mo-v''U43'eH@#nO)?H!nwN4㝿 IǓ.T`@]<Bp1PȞk9="->PNbh{c@yH ea?Ϻ\a@#s{'ˣgrbzsP*MP'Q' ܲ/)DHx%9׌DroK$Yh© u`)_ql1 C+pH"pĎb"9 JKY=pPaǵ yFM;kSM>کPπ$5Jb\AIw x9%<8?`z/J>o1A>b7c6V&jvbcx֧%X\m.Vl%AO|64~ +#('kC@4[y:A"$k@6o?gcu,YRL,LkDhzW>lzSH<Uӈ%50ݶ=}(DҊzЅ [QI'7Zur묈ʆoS,P_2Iː6u^qw >`U/w<Xb#ABh: ~#77STuFckPU9Ӏ@T͟Ĵ**7tMNIݴVRZ͍l}ƚ("{̅`ɫӥL35H6n*0/5(l ups,5ӌh'H fBt}ĪH?j-_hQ$/O2vYϏҐGzJu365۴` +A-cxrGd0.xRZeRY�� endstream endobj 221 0 obj <</Filter[/FlateDecode]/Length 2300>>stream +HyT/a$%Bk(b r6@FkTQHR12 ۰ || ("2,imL 5Ԅ~/1pe缿s?s;<?&MJpkVzZH](7{$mlQE.D&']K/Cѥ*C Ѻa)|enNAAn?X3{_<1 4SlD9UNLp}',\dr?9}uU+D3hZ8u#M2K>m" aϟp>[ީ  =FQCK;`@7􈉤߿e619Y-==d}?…vpR#Zs7!_w'$%°߮#Fy P>rRRV 첎x:>,r5s%>?p$)]*,LM(w_ǝmlgݧ"fQ3>=Fk&*6r>S@ja*#A;7wi"?79>K/;jRlz/-?;Do4w {Τ?ffZ WG9޵ _h3pyvi`uO7wqǿDNތB3VzHwT@ˌiw5 GkQ?mgȕߦJwfq3 R<?>qZ$?}溛Tػml?@)yz+95Sp!gY%REQfh# e)~ϧM=^Ѻai}}Ϟ!_>B;`@FRZST{溧T ̶/3iѰ~z'K5a|۸n@-:=q _?|AW&/[!{p~8tUö́`/ g:?(̏oe3}|GYM#uo;ݪ(eF%ϫ۩j3!U&_V=͔m,07=@A]ciaA0ka*;>K 4vƹUff2i?}HRUYl=}N+;κoDI/dYoŃ̺Ul$dp!?ľ2Xg^DWAAo,%Yq6 >7?!+|A;IӰ 7oOLP[V=>>qTY+H{fݫ[ pH-]':?b]01 ׃_&jQAZTEkU' +)l3sC4b47)-.<B�>|9l9`.3=GM۝>MMU_f|. + #6$k.;ηγ5z?<acѽ6?>c" +Yo+vy*RS/Gs~EdwlM\IGAA3 +|S%l;¯=>7f [�Ee{Ùџ_!E8!W|,Ԣs0ߋqw}5Ax|+,09�9"Z+ڙbS7=g|Jf++7 +3>bgO  NQfCG;h{|l13 c�%ˎװNl?ǴC6YWhAzrgAy魫8>IGig,!tj~8g$oO]T|!<{ 28ZaZLw;?=P[ aލԳ Pk�e%{4ѪV{`U+D??ʚAAxcVdڞMA^Ш,Ub.߹)3Mb¸Ҽ֩K%GՍBAx\0- |Jz|ENtnyrÊmF3 Đs� NRe(+O\o\دw ꚵĈeBA^$ʢ8]oZTFt% b1t?6}%_r/SڳMגJhBte3he$m116 � endstream endobj 222 0 obj <</Filter[/FlateDecode]/Length 2352>>stream +HyTSwoERpFJˠU+Ȣi݁ZUQ(LRDe(e',!!yA6/-2(# +cQt<׼v\9^@WP Z07#;F=M2!=n6{hnH7ƍ=VҐ9&L"RLzFӺ�M UvdO=^ sYFvw{-jhz4@v;Gؐg8iB=hˬ~XkER y'i1^nAQCA^#B>6.[YQ;Xrr wm[uȽ@f ?e*ٹ+ձhg\Qp!nBD(cޛ'[# BdM$DamC ǝ./vjcd^}`@DgqU~7OnWNWB듅y8ޱ?Ai;bS+$j E9gխI7wsvI͠}`@> XB#t>2vWsNq]QJ2*ᡓMaDAÔh¼ZYg}nr=ꍆJFNڷ +P1 ~)‹~w%n�{j=')Kё(R۹Κ|A?}$*IN*KmWоK�./}`@Rg9«=M"ڙ7$;L5@f.]2|>1E1 +<Κ34 +ig%zLax^6rwrоQ C UUɯ*Ͻh +�;ʾ.RК.> EA^).W?ciQ5Ji '=2}L{7 D�'k*}`@chch y6o[I;diwVl12'\8y<$_AK!].9Β|{U‰;k*߸c-o{ 20|Og(]X ]:-9uHm|" πtNΐ)rvu|cx w(CD& b1b3<53ig!Jvf".9Edm]W,SX# L<t1d:yllyw'~9^"ځh$?Q %Zč~,EnU|luM$ad1)Gymb,\^$x:jj_[Dڷy<?D2%EbYhL~/]DYةHj5ܜ# oϕ<ybFVYAzMT2jlLު\`Eh_ڷy<?L;@FI~I]QhgZ _ifr3uk Vޥ= /a rď˷$nb~U0?~d倫I@ PqA~Ν /� 胂9˲Fpfڟ S8#(L }˳k!&g{`U Ah ?rx2&ڙ>TjhF E9i%&W;v =Cx? AC3m'¾͕) \NSOߖkkr-LEz4 dӾA ȓ1Aܜ5yfs}T@Ggmܽ(_R֦HߺwdF &b3&mbHը{]<ܢ^8<ٜ>APZ$eM|lDm;@wt!"-Sp̧FY*M8.g"0|;?A89m`14Ji -#n:<BA?gۮNPs}ڷy:?Cv3v龦@Vڢ>2zyr8 jBmiEsB2j%x.pĸ2AԨo6EwW) ߓ~ϧ>-ӵ347y6?FZ ݁7*owzuOc`@SIƩwFYZ+ +̓70 +if! 0}ش [Rwkҳ2BW.dSoنԋȞB`�m(d endstream endobj 223 0 obj <</Filter[/FlateDecode]/Length 2843>>stream +H{X?3ݨus(+[I\6Mtt\:T35if")LڕsX!M+fϒ?<y~}? X?’Y{&[JdQJj?<{S'D5킕@[Ц'kȻ~v-?3/%6fzj|>jBQ5t6:0Y1Sd\T~tiK薞Z׏C@:uwsSlOO#6c0[;{V"+@s]ZiZvߪI(^fj鬄C 1F:,]3'OUee[Rx()--[2[G\n~Q}5<Onfw4(7g~xsIᶴ{ (IQ!$_NDp=8ϡr@ú:\"&&uN%4s̛e�5n[(uu;�<lJ0/=->|0؏R!v(wߩj֭q (r AXƃnz{)R0uZ!AtLã-~.f:|5+99qǔؘ[}G S9L[]L&scp[||XzVyNNG׆Uc)a]�kb)+b?ȇ/ c610Po/ES"]3s4J[h\wU^'J><8-T88 GE`6chkNt�jRSVIecBswm~'|=pBf':S_~\a5#m<U =|\=^+:ә(MB O?,{1HMntN!?�~8 ]l=ZKDuS \SFQ+ 8MUEypvr]x;4wyy;md8\ͩkb +FSAg3PQR{>B)30FCk!̍Md9bJutboRI Ǩ 9VzTXn ;^E$IœK69U@ w ݽ|: 4y,&oujxRAH=*)vp??łb @}(L9tj}.Z{[bW,y{Xk'ް' >t67뒬ܓ8dcGVJ0O߷הw4bD1׈;b0ʡJ.mN> ϵvj58-__-uKb+]d)E+Ê `y X<{XΖڅFư¼Y0w͘%=`7MT=Y2|ݗ̜<E 2u^2}[3?0KADF $g&g'5ZHM6R#L"9f`=o>_(k,Z`o.ˁdL۵m �!nJ;=<HU0@p#?K2BO=dע)TҜo" 2Wrr2.Nז%bGtMIg:-;rOr)v�g \ZLn??T0 {mło:BB _?V T!5I鞡&8�%n�A�Wv|7Xn6b#_GoѸ|k@@Kg[X֨R0KzQzUb1}Xnݐ +yᙻ!덹y/,@_n 7DM򯶕嶵WfH;jR/>!踾m!^N6-N&5u~-3X^6k4\τԻ +M< as$@nO18!VsA>DHo/Z&s�e*乨r+@/m�5�$ R��~ &1\Εy"~x!DAKG[̟~s^~<9|!#T^*~Q]SGu/>r_AQ-ó]ܩP wMzHoHE܎2v^ +nRaFJY  [f +_&%0P&Ej-!NĽY@<EA!ffGB5IjhELEAZE]t{(ԻKvKȪ/-Q@\EA=MuNyQ)t{(ԻK᫔_, aZVڅ.VS49$mlL.k]"KSHNJD Q!8tY|3<U*MoȞ��k +gKdBrKӮxv0){�|]r $ž{[@ ${nx${�lIi܈Y@ $?Ӯyw'{�lg;u]M}-f{icURZA��i) sh[AV4ԡt2潕=k�@z,[AHv:[lꔧm77ՍϤRwZOB�|l,{y`iF D}ޅ=5?-va`+tUUf;GFC ulF>�p~ endstream endobj 224 0 obj <</Filter[/FlateDecode]/Length 1187>>stream +HO[u2̰65Ġ#+o|ިq&dĕ]d`s uh(>X+ ;ǦӲn<hdQjHH6P.wnhMN~W}~JERK?E;%-bVc=:Y>ת-=Xxg;��Y{^᭪z@ FʐiiޗsUۧEg~Q={�HUcJ ALE=}|8wUt}Lޓ\�T3enGv>%\yɮߡ,U]&<~ۡU`��RM4~߯]X@/%==)RV\"ž;?}yߡ,^_ ˯a��Rodz%zB k]݋%a.EܾC ]Q_Leߢ,2jѩUb��R`ۈ)곀?ZgsvfZ2]Y|w9|P?߸Bǽ]~T:xiyon7d(��xeLS�*dF zLN ">%k<d׼$çUd��n:|r8vkcM3s-׭^~m,0qnQ?�0+gy߻w?;2pW_zcބ?SG-!ճ��CK(o'UA}[JF?T?�0<jMŪw^?BXC{Ep@ T=�0K'{vB[;_L$XcMs��h +_{ջ^L$gcMy`ۈY �Y]UYջ^L$^_ 6)��tk䀽>_;1S˪.n6:숨��QOz)yt6y~s��'9$AXm7].zv�`T׼[rʽz){\yz +3Uo��nqܣonb?V/T8+秺_S?�0 +7x{zۋwQ?6 +0�%g endstream endobj 225 0 obj <</Filter[/FlateDecode]/Length 910>>stream +HMKTaSHFئU- +E.z!ZhA j-2RNA fP"i"LYF`2B]!TTi.@s> <z."LƢVj(?p[sd;sZ��o=kӥ?s.iwy?MMm=δnGpv{�I_Jo^n)=A &\()ow�ߍJonPA &15]-7w��|EAL +cjH[}�vdH_fUS;Ĥ?zm[}�oɾb 'Bo<��~s`oɾbH7HN;�_H/NΦJ21)X]gk?M<ٟ}�<UCӴ:Ĥ?n,soҿ��h>^<\+cH,׎}@�m}ҋҏtbRuFCuBw��-҃x~n6Gb-9ގ?+9}�26TvBPzQM &xWB)п��$`y~v'AL +#fڱOjw���u׎,8UM &፲HF׎}|\��$@eIlb?Iaxc^x=].�� Y޺5&Ul.6 wgvp>��kw(lZaNuVchv'��[M/fMvAL +[~qVi��^ҹ2M.t5RÙVcw߉ g�N\ endstream endobj 226 0 obj <</Filter[/FlateDecode]/Length 960>>stream +HOHq_ +!FuQHQ%C*:ZA)e63mDThIJd[d_{x<=>~ރJy$' GF|4GJ= sem~b,٧c>ZoTJR3[%��L_A\~eqtsMLGb[t[X|'��X,kootkMLGb-?A V��Xftr❓nɸ?IHWe'O�qZſ!]!ƚ4YWzHuZu��M_iboҍ53iu_?j]�� T)ݳK}mfҸ?+>nqn�� )Z2޳{j̤q${ss +Mԭ��6Tln]p0xvгo�|GuV{&T`&CFݲLܧ[ҥ;�jI*SZvL4Gzo{<9,��F'}EtǤ[j'̤q9PUނ,��73}ٺ[) fҸ?d[t[X|W��)+wZvLe?9;<!��~gvyJ*'-v3i\Gh?)��~qZſ]!f3i֕RV tc��TSWʹ+fҸ?>2\.��漻\'L^xZSva7sKCF?3 �� >,-J;`K}6j|Hѿ3{�t{^RݲLF[kiz&_GHs)Oiӫ|w��xTWƱ{7>I7L?~ +0�-a endstream endobj 227 0 obj <</Filter[/FlateDecode]/Length 1187>>stream +H]Le�0R 4-Z.Lܜ +S#!leFaB#  D Ë3iBǶVI[D:,]#MO}.gy At΁䔐Oˢ6`d,g +Ȩ/YI@?Ӛv � +]z']%݈MB}M D^g3COe9>y/K}��l!nh>Ku'bkXw ~fݢp21TTA�g⛊CO~Uy'bY<j5#) |WnKy.UQ{�xlyd>mX q<lYCa_ۮ�dޱ/R݅AtG=,$"2<\$o+{%Wx,F:ڇ\'|ol;[bU=5޿3Nu'�Χd$W^3yN&iLLy=d;9&7]f?+xyȨ/Y,,VqUK��rBTPK$hmsuپxҖb͊y?.忯��u_/fCi\K<[%cwy"Uv¹<�0CBƊuo<̏Atk/#<Cxޚ^�0>3nؼ;c3g96 US��m XVuLa!2%i:[4'+�d v~=pob?"Y��5o]F8,A^*N}s;~u-�3}RyLuLa#p^/>��P玦*6),;sD}�#CHa{v՝?Otn8_c=��#OTw f +CO֢Xyn&Ĩ1�>&#]?SDfQ3#~}�~/do4Qe)}P_ KTw� MK ui; )U'NcK��' endstream endobj 228 0 obj <</Filter[/FlateDecode]/Length 919>>stream +Hkq+jD2<A<!,bM(k5gSVP$,99lww_9nt/EF2Cyg{׵ߟz~T,vIo u-طmrl0=&Lt w,߳|znx<k}P*o�GAzBBzCsb)쏁/rhU3;�}jĒ#[iw rI‹v+9�@! nBR6dG\s<u�z BRvl<8UKU`�>^Tq`vGwRv 4UެyЫ~u~�\uNfuvGwR?!-}QZ��z=+̓>w`}v7RήM뾶�;[IX +ÞQE ۦS�{N=v'!b)ϗwqkvv�ΏrEX +æL3R�{/wtk]??Q7(c>N�WǮr_,m;j/E~/�t{|v xb)28œ/"�7*_}AR-/>\O �ܩrs{9X +#5QQ]M{�rkw H ㋗x㧖f�G?dGԻaKa5K[;wv_�z#\؛1X +#uov'\JxϷ{�<-=?xwAReҮ~<vN�@;^/\v |a �uWd endstream endobj 229 0 obj <</Filter[/FlateDecode]/Length 1097>>stream +HLud֪?9ōZ-m~?0̙&Fd6wu=nk`f3=Z9uB|m?Rd/ŏ,WVǚȯ[|Vw~哒g�ZV.wt ;46Bn?ܧS&h̸`U(�`bU*ۑ{ACsNAv?p}j2/MIw)�`&Z.nd8)w~C} +�_*hۍﬔd8)*<|Чc1c&|�2V*5 Keb'n$-_O[�2Co#>qRqǺp~�N<\. N +UDxl +O7,�:}}'ɢ `'`mIL~zWk�6Y;- N +xnM{x�Jeo Y⤰?p͒uʈ T.�ƤY⤰?OOyVt3;j�Snxy�y⤰?pHe2 �no2S-f&N=?i\x= �n﮾q㴾ҝ�{`'L{I+:{ujGM٠ﯾ]�`'L]/$-3]} �np^ɳ{ +?Rgqvx rn׽3?PɓV|R6+k_|)'m"=uM5r;zkdzYs`KΈe^hf�pVePҷ v̲o<c`> }m%ip~�'9Qzۊo>Aw/0g +`Ѣ=| +<e+E.mi�p}WyIY}oo>A~_gwfF5 ϢW9b +uŠL==|_;_ �@ endstream endobj 230 0 obj <</Filter[/FlateDecode]/Length 1279>>stream +H]L[e-4L.7uL 41au& +84:AWd+:`Ǡl %N.f29(^ꍲy$$TyMNyqo �f!F{zeTu }HOt@d{;:qUUr旅Y ߞsL5o mG=ԅgl��=.ʠ^-nb$d Ҹr.'%=>D$cKc'ῷ�,dA?x'kӴ s0 .i+g}[[M_p;R^;.Rk �Eԟ^^vP?$IY~x;'0w'%M?A;d4禷9녘kf4|~}V;zݤr +W[p��-3z4[SN{4}v4Rg}^=Ho\Dfu a8̴kO5p��Zq?mpw9ha j˶_j5@'=?ƘaXV%Z:=Wۋs��-l ,drD}bI:QK9LJ;Yua/�HJo^{bpD+!A|a=' KW;[NY^{?(wz=}�=)ԗ(ݠ=|pt4eR�@ʄtt4Porw7h`|chs� "#$%wg6a z +,{4�P\GI@X(~N,E#4}�tCP&j%A۰?=ʲ,qꌧHE�8QR6uR?rw4h`BZPɾ+?8?��Q>|^͠} d:S7G*-���nw,pԬdDOx/**z!#{��boyD_bDOxXZ)ںO}��`1Pkԃ] )/kWt}n6��HwCzo-A_?=)|M��4VR*ݽ?f:etX�@<}<zq;o�X$ endstream endobj 231 0 obj <</Filter[/FlateDecode]/Length 26322>>stream +Hn_wSkrgfe�A(]r,D�YZu@ծ KΜ9sƦcԱձv~z{?xyˇۋnzvV\so׷?n^zyyÅ>ʯ9-m߿9@10引,[ɚnmd_'۳w|Ǔ9+_|{?YN{'}Z/ ? Y-JL7}9V6\̺YڭVq +�_m9mu62Xg&rgXl D4^p͢R'7'/nZ`sY{k[Ƌ6{`3q+O^0{ }y+})w#Ϭrb%i $5nYô,Ty@||ľJbyIM=#* *GFQk5l6oNB7!· \7F=q$ a FHE'/A)Rtƪ z!&@LWc�ҽX2%EB1S)!8< +Y`iXTRH-y˼(:<csFS;}Z<vR/0Deَ*zV="'^F2{iRm⢔(=4nA *B3pzoV%ҹKi*yErW JMT&N^r'eIV}r呒:m.F}SmD-xXAĖ G=V6ʢƙGNq胶φ(MN%5fIE2#bpT}~%MamCS*P8s!ωxֵUI<.'Uy (gSaxfW̉ъ2(D3k!!\9ncZYU7:=X +Nz4r+D# #7wO1M㸅*D9|Bu~ |vyncF*"=Bhs% <0Jku);BCb[k<t6>8q(AjH4D;Ijp<"!,Zis47ځ/]^0=T+fף!ѮQ*Qhy܌BvUZxBUѶ>ozZ#! 6A)GA !!+) |*$,/o^ قQO/~uup]yx뛫?,KۋWww7zûW댲?:amo;Q6lgpYb L[4_]\6:WMU8CIJMBu[{֋wg}wH;z!Ӏ`dTِn4~md?0HܐD:'jS>jH6C`00mA4\Z6ɔP$%{v6W(W=hBat|ŵA֤;e#KZ�eBƜ/SZVj[d(`t/Nf,ja8Ӫ $M>8 +A}/jDH1_xc_N$):=4Qq㕸J }/UE8NLb^򲂹) kGrviHLIP%*ZtHhBeρ-SLn@&-$Uڂ(V 6nw&O*CvƔTԵ4UBަ߳�\9jX<-YH@*0�. K΂ *K<bs/ gU *߂O9Csn{)`0/T TBړL3%s#s[ o\[Z1 +eu=!< 9樹L'8 +Wgl8<`KD^Z />[Q אm\fS=?u+#Uc�a|@,nMg M3CXP(x'Șu ckn*WIĦ0e"K�aDĄ˵xu @><pՒ\6+ z�{|]`@-| s?$)Y.e1=R0j_c#F5s,ڔ61GY LyY�Y[lMCĊU$bD HMk&UEuD:*f'Hτ6gDqa.*[>mRrl1 + WInLpkAԱz_>H'_zJ>[<)eLSSgtzц.$v|ZO 3}&S +IӮb&k8IdzS +'U%锉ҨfF@<Z*zmL]JXq)S!A͍"&U h_hSm߬jn@ehѹ/%G\+rЗ^JMODPٶӀ~Y*FJW?`BK}t@-]ǭjJݬ,BLM#c{[(ww=ϭ^s4q=@+ȅE#ja^@hUTK^T{�O>* ODZ[[_ֺR7xl~&� n +-nonm"a=16жLKv6i Y?U}P۲a(DFmrtuxtE, l=9;%íYݲ~6y4_5kXEvlCґ@$35@6B+voQbAS!T$3J܊|j U Ss�&})?u7;EwDNw,ݕWsKu+gO~dR?'s >ۃ6lo|(_G4fo!c+Ʉ={ki;4HUɺ+&R>R6.|l_>GN_8Ȱcll%Oȟg BC 7Fcd1G h2)J=ՂB\ypoV@Jnۯ� f#3:z5s&E懕ArH8MdJ)ǝ65Q9l% 53=n`tG +8_WQrmxѪdÔw8ˈ9Jd+4(eGWR 1 +qzR9qjLDjxr/Ȍ\;WPVZ;:]AWБk_yZ-gPiD}y|Y|hsc+smzusǚ;İ9![ {Ӗ;bTf$m(o\Gvio,9=}O<m "+nZ0h++>?L'=ڄ{Md/nT7;hZ;ͽ(ok[F,ISp=HnG~_eP:sCibnlq$" UT�DZ𒊊B6>cL%]V@ӎ9ڡ2[482HeK t'&pŽ݀{6بq] c f@ٳ FW.9)o,|;REqp^AJ+=k5T!VsSh,u-L/ʀ&�TPK R+MܓkLxLi˦Bs"@)YDހ&S ["4 +>KSjh-VՀ6p !5,_E@i<HK<SM HkZMו'M-VPLoZT[䚁T��k<O*HO^=]!+~˙7Q^&H _.Չ1YVRLʿxreJv#1-Na9�jX+WL:%R=JJJ{ඥk(@Id +tG+x5D}37hR $1<%Й(DӂlR�vܔC3-QYQqFX'eсhDKwz�GљሼJ<QUdK GDV׭&;f[DP?�B_}qos2AvAB# _"]%@ऱ-9IL`$W;!\>>pG)\I^C̶ab +{O<4Nv hitW;N32yHnҗE-QAv7GI(;C9 >4~ 9J4T=!ƾ'lty�;Z ``Z8C�bYCH XW@%DxЭ3~/y ehh.kb_`}ݳzjyffo߭y/\{: bK_dn cc\o:6ӛS㗸M\k(g/kRW+F<DD%:b'�3 "\9�8U 0`u0Tc9f"@jzU5,�TsYn:*-8.f5�u`]H(hǢo KWY:w (eC54̢I;"v$U]S.. 1nSM[@TRz +?-͖o3}=NBE -Sls8X)(x*j #2ڿ Po-3ݗ{{2sk~ >ԃ5?g…S@ˎTU Ȅ褯F-4AZFx0\rXB/0+�r%P(Sg}w # 1CN8. O0FT�QWZPIqQĄy.*zqn{^ҎoK$ a; 7*7(+F}흩v64N刔€QN:ozC3nMSryjćyДX &E#&M$";rv :�>iXj'K,� +B ],'hhB/R^ٕ ߀s$$!g]{T<�A20GE >J[!8XI` +F�kF%@|8CNBG*=5L:mY= Ԁ! #TSjS1 k"ŘޒT~kl>}[bߺ{ e(T?=ŢzQx0:=dqEI[b0 `g9�H@s E/8Z@>SlԒzM *څA$vWoœsd_Kuo9J鍖u0NN*>>J9_$i'3u=X(8|WvmyyWS*gx% +Z)qq׿)saǨD}H:g�٘D2[zh8gOgϠ[K�x}~`,n +, {raq)q"h!~ +-�ܻNOH5N|JFs%6zDS32q2q݊>>x*/LߓdMƛV3 1,Q olh$$o; + شR�@Iq7$mE򹭞<`@=gY⚣eaLRl,"VY*6vW݄dCO?d)#` 8uU] `D&s.}:<\Ag"| +!ݻKnVgA_/A6⯞/"GsE$ɿ1`@dė+&K0bAEO $L T g +M 7IbI恦%J3{^(b%Ĝ"kI"[oOh1Ҟux!$y(ëA6An"đϕ9yRr'<[@h3[ȎkՉa^I+T5E@稨k a\8G}tK93Is/AC]>2BEATҺu$ /P *~X UjW %ݏ~Sp'bKsB#P.`W;CUKgeTG#oCa.T;>aAVeo4rZ0$ꭺ*tH֭B|fYo/s}n W\(d\sWH!A__Qu{~NAYcch,OHkDRTOxlJ ГUQ< Ḯw"ϲDi}=XשF,􇫺!K|(ňP%^bvta~X%aӯbC8QWְAbM9AC_j9+H `~<$k5@MvzbCdϙ"1-*#f}Bm,fyA:ke#Qn_& UrFE}a8O B9ʃv=O7<{kߢfnIt\B^/CqV%ݝ@Jq)՘` + ./tp<;)Oԗ5o㋬3ekOyh fxDx oLÉ(HJ0qCLQ*;fRֽu}s=]:|o.L2(Fߣev72uצ;j�utms <W8EM#tRs-�󹠨Ւ1;�Cի}6zJJc&:u9QL;n-)}-hƅg 5a/NoK?5A mc~՟ ]kօ/J%@zCK=v1�iAnq" _ H9kDY;`W 1{Qfu +صv˰Em64(SP"6ܼ{ �/|fT +g xz%\i700G FN Xt<AG]#ibh"п`ͻ|0 o +<Q]ɏ38fByN`P 8,MDp0*qFv'/ 4] 53Pe2(L G!mgT([e%sZEkY _n\њd()>_V˞ݨq Nd~=1o"q{ fV!n1%6opQVXi0I(/1}!SpW V,CP '>�ƉRl7[gx4Q93eSP֑ᴴ%fN[!S-}s|t9,< EJO,Yo& bO$2?|#Sy-©9AƷh wF4LDPkQ':H@YwI!1rQG`Xq&'@{uK^�׊yzuM7e/%gׇ)f]kvs!_FdF)H +BGS_NLteG�U�K`B;R@F/eqD';L{.8 p (qh$4�\9u $,(vvw-gQ`8L/]2IrkQ+a=1ZYՈ6yZ�B _Ũ(Nt|ZkԲ=Fg}_S45O3Wn̗WQPN?Ŝ= k4Dd`5g ,~tb=CŴ5]\:1W`kDfAWl97s 2 TE9 �ϻo4_Azus9~Gv]CQdmL/V${@<Z>QY* y$OqƼ>02\azj|WPK++\=PI+#A62 8l38jĊz~|az.ޣ)>4 ?\ƺi5ϙeNYӄJt_[YxĥXfciZb +̘p"-I/0ŜAWJ95S& xM'glaʆR܆7*jM-bҜ<S=Ȯ\I<pIgOEd`v%°"^ѤJENW݀v=z"~#6"+2gx&r +r8pAFz 34j2ٰ5Kjbh&J)6:b-^D*$D;w"gA^)IO7n1eĨ` <Pa`:I#Pp^ q[:bw ilM:VKn(t߃C4KlEֱLOZCl!WWE^פ)dѸטaӚw":1`F' RS)J+|˙#s-Q.ַ,UL G + .mI +oDCܖ;7EkxV<Qs /*Ko$;uCMNH.V{|,8.qhMX9l:s +4DMRFgMu\,pvr@$`rǒ觘qfF#Vdw^�#8S;:odlԐVƟfI_+=6QUjŀ(ږ9#kc+9h:V̞!]8%P:,G/[x!܍O/~_z/xo߼x]P{ÿ_{߿|F{'?{o +bek,| >=ъAƌȲ遞, 6yk8v<A }CQԵ_P]m~)3V`%?=`z<e/=Sy*RW+ +׎P(Ѧb),]A< |KVrk w@ӦU# LJ8b[b!00cLDp~.(E0K @IEW)A7$ +-?P%L_5qLD"ñuf%p|pk,o!$sjhyjS(rx7Aؐ (K_WO.Cxȼ[Z�˾\+K$0/5lS;o9Z@A\1jB9SvL!W2m+\~e<K,j 2]Q m6GkaIlSREl#|Zёhp{E?@ɬIJlӉu\d5-8"q"8 E{s|,eIY&S%zngUbf獦b@ 2՛m2X=ЌR@9m J^$b<*q@ӆHsk5Q5[Ey)L, T/p|©˂&5>e:o4/OfjNe6eQ;>5=?Le7 +GdlCHU4gR*<FX{w"ۜj#:Hܑ&z.[=/vc{PIÒ2 _AkHD-JN4亘C@`L %ÂDCS%f1 +IE-4#' ;Jlm)J}Ԝ씭vhi;TIU@3té1Kw7&<<;t M ^4A�v%-på)M\WϹ,% a^mlt{Gv5K'�F5=t5_*.&XdZF[V"M2C!�O|!+h5BCiR);|*H;N[z +1v \A+?c|ѵt ́]a^k踦[ +ZY-hxXmc'xD )3 |C-~A >5(p~I61u!>kl ~#d0G2Վ6D +4zL}VP1kVٸh;P|} #CۃEL6%0h 4."U#VlbE?ҟb w_i>vZ(Gr+{+;Rؙ3Ӱ꼊A:gStKθvj7p"tZhIM[s}˸Zpno;M1Q7(TJVӻ~M];O+u5+3lv{hSPq7 <P^u4 G +;Cjt:wXwpaT(7M>Qt!k!elWrhߑɎ[. CnkzRhY5D{LsB}/Ѥ.u楤H^FZՃ}2Hs' 5#GUO n.kna4}fy 7UI*_^ׄI|,�z_ gM:P}eYR8[D'IGpfu +5([?1)cÑ!FTHV}<?QyqΆu�w^Lv#AC^"jݛAv #!#hc ]0Oə<# U?pڙʩ%g1?ֳt!GQ_=r!%2OI10XFc{h(Rl)iT帞+~`j +fA7�J|PIZ L%#22~ l4nVPz1iZF\S{K!^KVB`b@D{rW_b(Bum&�E}Zq 8yss6/$@JHl,Dҕ@N=R3QݖҒBMQ0yzH{M"z؂=�`@ 0w(Eҹ}P^~:/}@}nM@#J2T{LVnC!C ~3ԝ XG42!T0-} US;uLwD?~21BNsiyHL{Ŭ*bID x|Fw>!8/;U8]MVh{m JWӣSkk0Kdו96%%eCNp8eL~MD0IHq#v#?wv?_:NcZS۝1L0I)-kTL"_]Qx`(6ĈP btA$e!bx"ދD.Z_O ssԯ鶵x0eL'W}MyY؎@Y +ew<g u0.'`;<;ѐ4$I#I$O9)/B^i|/%S2Uzn]'xiJLwn`dz`{7MIt(ԫ'̊>'=|-Y'n-UxpAQvVK�C]ɟ>[ucxW%Scd3$A,? kZnHݣnyZM_pWS}7.F2أ6Jtm1E:عBڏE1>�j2 Vrs۩]omo_Vgծ +Ό*' :uEyRbe(,Bo{ BWW=FGzѴmXR DNd6房'�i1CLÑż\N}VfKxWB|>׃v& w;k2 +t2rx,َͷ.IE/pî ߒ*rxd`wUJvUJ9'<~y>=/ͱ+҂HQ'[$ș-0xSN(6*tUKt V}f92D)⦉aStZi24D*:}ʐ(ÓlvՆU Pdk^r]}M`dt[ ?Pi5~lW6[UD(p(f,Uy4^_b>kl?BBq5#&H'ΐMY$`R3"SO R0>BW} x�}߂Ҽ[�xpsZU6aYN+&㖧pIHy.*wy݋MD)DTm6 +yiymGv +qB0?#{]?|hBPGuW DO}ie(/1L@b=v2GA@ t!ؚ;#2 #�+ d͙<Ř9H5e LC`Uo>m0stt>HpO,b䥿Oy9Y?$7O\9ImўIywz[z%-zXկٹhVnR t @�vefѡMo 6AKq<ܒNwYrSej#f́$IֶZ]<q"6^M/nKhMJ%t[4xSn>ӯWBd<_?u/̅H�b|}EDJXG}.+iCp;R +ؤjX纔L'=ԗٮg^Ű[18#!0jC^m SQ#H 4)|yzp74(͢Ѿ_KSw&ML氢_cۍ. .)1gΎESK:$R>gToc0�jĐx&|3j~FY>D6 t>՞a}9zp~C«fQa)J~7ЁURoF +/yM ܌8(/w;fgtM̺o'R^; ]}OFلDJ1Z;|D ޥB- 5+HKmVW{Ps&2#Kx%dqiA `3u]7�?Z.G<-ֻ[pX/ˏ*?AÙ(ѱ"8bhoo] 䰿W˺h jP zFCxMʑ] dR?zۍ{BˡT65%cR�$ jU1kL +?yR3&zj$o t�.Ղɥ)Y)S}*:TG$~4.)7f6En;Ȇw8P&9̓+/.D??~%Iؿz|ϟ~~×iW_w{wnf?,1 .FI၎4Գ6*5-)l>=˺iS W;@O X_$0&*u[k+nϮ +0KSEw{֣7AdOMI#!P=pkAyS2T<^W]gQTÝC@0J³:IfX|9Pޓ#'cNz +ǟ׈<BPptCh* Ւ }]cJL_NUŜ8")IDB<>5h/92:Ǩ2 ::qU~vK=ı蜥K{Eѓ,n' y.zwH 3H@M/R(D&șTͼ*!LDBpNC#‹unVeۀM -y('M "14ܫscj3$iNvMJ9Rs%ܜEPZFhlU͸l%2>D un.w$_ Jb y㢄 MrӐ}h}$<˻%{1 .GڲI,'#-!rx?2.DP�+[@y39Cni#w;P{Dfi-g'cH4p"ۗV=ojxH Jmc^jαI"14}]c'K ӤN;K/>rݒ%f)_E8f͓Z)X7OL}wy˓}#ɜcEJj,HUdY(ն0ڸ H,Ebڇtgo(xE^k.~;?9^ Pzô2|Rs|Qve;,s48aP鴆GnX" Vk 됢<K*1}KQU^*kI3z86qk2ZC%n2}:ij>w"B7ŷN-P<fOjʉQ]mYmmNSp-$ ~LɠSx 8^Cܑ-09Amh26uy8=Eهm]bÀ,]_yL}UߚM ."h]?Mm3Ie ۸Qr?@) `5r#l0Ȟ}G�-t)"M`";<X to:�jܥQCkJO)$Q{z衷r3s1MI>Y1)\Zf?lV) d'W1elsU;w,?+C-Q4w.ߑZVR +c%q%/<%¨KV,im$Ҳ6|TJޭcTb.AsRRl WWh~})LNo$XP{sY]FVO:NǡHɄZ$v!!3_ nW2*d4o]Ŭt4)i5H>iYyxS]Q4?3k_Gyu?oz!g(5+]I +kX 5"NcB-cz\#wZ*Y;X{IVV۩7gزȭ$1U婀4}?)\Q?E\-(pLnz!{WL'ɮicgd tx^bƬ~ y~(操z#Ͷi' hov0@)IIj0*�14(dH@ "y}!DO㏿Ho>Vu~Ŀ=GsU0}RB-y_NY%ZZ'uyUSKky; sF9ٙ*NBמ ;3fj | MlD` ABU_ S(G-$Z)0Nh,n"2zG/W5厡(F.l!ד1칸4Lڢo94˲MQìܡ!{S>A[x?fb]R'l+ݺJ 9>TwcIa o힣楻ԖҲtQ cKCr%.[eE]%uDži%HT?>We~Anٔz;DD\%Z܋!]As;F>%5UiZ2 <i3CQPWw_ J7b'ck{L;w> ǜrstޚ U8W ʓu -r)7>y)mnBxHxRsϘv(sZO tD_]\4x탃&4sK pJ,ةyU5[! x&W3ěF6h_3f?MK4axK::*W|Wd{ؐ옔*r("?;1$ڙwl?*[Z6q<?/ jXm`J_(f뙗U.#\ʴ!u^{( `Bݾg˕D_ś|S!]Z<,ϩ\*[pV֜c~(0-_o@-+&+u c1I #[h>yiarpoףdvE+?î%={4ǰ +6ZVW[?\⫸ Yfx,P2!CDuT_X ]b5#?V&hEb)gřQ'nڑS Xmh7Y51vuUSꮜ]dE@+BER J'B5pćLU[dia{у/KEn#c9өuPs>:dW6n Ÿ-"65-Oa>k|;J$4g5ܖŐ{9ܟnRJ>m qo7d7O#;' rD\ ɖM;ŭO [i) `|0QnqJnLNk.Ԡz~HICH[%vzoC`3 +ň Y 3r3?mĶvU%A=v8W`(6~|1؊+L$_'9j?8GxB8THk2C28b3#f2FgS C&g  [1m^F^[ߑxOOK Jf{-[ѥ䄽گ􁴺ʓO.J.Z)ЏwZ6ro9;k;b_ZYMOm G o]0ʾ9-D:*")|(-UhD#>E<1^b2%+m`75Q +56G)u{PJZRRV<֭-1Xw$xk}OYf(rf/a2:O3v@=d +޸۝%h} t"ҡqgyRVKIPyE9=wIPq�/e89ķ|]}D5| +Er)5OS̉$;ZDS"@ʤ SCRwOmWaL] 3M]mxm(9wŵϳ $SؕøECt(1|l||!?TsCn]Yci+^ jIg�eXOaSBZH]1i"$*A&B4Lݧ1zP qMa)D3j8z<#Dfb8qCv鳽Nvӹ1^ }TeU>ÅosaØ6P!o7u|1\>oAn)K7 Z)LDǩOXL}\F_Gob9>7?DϪ?/ +qtd +QQ9ۊ#rƘuh +3z'(QiKȘnxjN b^cm]"^я+O84|&0p,k1QnG&ceC=1Xx,+W^?tu'k% Y7E;ت(Y^}P$Xs *mS졑cK}8[ǐ<?|%qxeʋ 1}ʗw2Tsxl8,鮝:!{F ;@'-RԔ`yClE8s?n}/$Ȕ 2lyo)iFL;s;7}ջwryZkhڙB8?6ZT<AW K 37]@=ܬ6 +1@kcK}/E8'-ރ%[ +xGazֹjfc9HC{r?__~ݵOkj0MTjoȣV,L5X4f偣qr'Ꝗ&XfQӏ1,<։g?Bĕ2ef4őF"%Rd>b?Mx7#�S.NT;ynA GkEɤR*n{EBgd 5ӷ%Rɔx(7<. AsDV-<uT^sˤ5} ή}Ʋm>G{/?m:Q9$< Z#)EqWwsLDҰ5#vq\\-7o:>?f7Riv^rD9>-Zs� y5My҃9͛I%7O(Y*YKֈ{|u9A]82&/ +,yVj#g.}2]ٵnX<qg0>0M9A‹?mLO@H{&<HaIE+5r%^8`2ǛoؙB}<Po[Wb0&ɫéoj|(:^]5rlSזS'<0N Dmʲb +.5V�ƪ3D'?#M;8_g$_W󎶿'-�n͡xK}#e&.ŖksmDq_W?(v(Yʰ$o˥#¿3i ׮#ɝaH gQ1d jq[[cokѓL#*R_o2""}a"5ǀogeYDI+FYep!Nxt}=VT6ʒ[)ҰBڥaNxR d¯L.}! M8z!qNdz~ZOMwYuc|z^g,\LV +SlTG?(t.v-A U|5\ɓ氖MF'E͕v9i0ܕ@ $0cjdimgmQBD6Fi4v*{gR{X\Kt?/_>z+^?q㷧_~o#;+Wm&|ҢjR;)NͧTBe!>j[)o1(z/<0MƢMt5/|P1zPOJY*ږsFI52Ze؋r. ~Mc  ۄ<w!]gnɈ]:<ľuVʸ8 h(Uq) +�$90R&)}0`$AݎŅ'V>01kP#W-PΒg3H W-W&AxN4{kA=LZcWIW 9杈 )#{xL + >_JкzݧXYdb.M6=~$]za +x$@hm6R؈!\~j+F;n6d&"XѯT9GuE,rҪa nCjD-sr/EE~j& +{yP.y(żXfD +]*)2#T:akIbB;A)j uMu0'/j +bpR7n︯|t/sr;ڇ@it/uryJKnb6I f//#zuiXIrs.71q�؏㔓txJ1hU3 +Of!|K*5x7zlJ],�DwƊ5AQSh Q +N7@!#ԬHmJ,lt'j>eP*kn-(%zU8H\Bhkqűct ++[qL%d!W 1;R S�ͳ@ӹ|P`蔛6u� O[M8DiBԎ-_ +xۊLs v`]L'?ԁtXTvPO!VC[r _[1Pq.ժz,Kml'Rkn1:mEd+ST?@ ʨ& y5: US`"?iMk Q-\hiV,;@skV:B-!RD3 ˼4먮QĢ@8bKν@҇)ȝ'ZSr,Q8×mkE# zl�]*^JkV!v+~7vHXܚp +8)Gcnٙ%҃G&)^¤Z̝[QulGE&ׇU;DM׎n'NI2Jgyf]%*el%>&[еRsCQј� Q;$$mOdNLw4ҡ/[iFjVFt Dpqf7[�\=LonU8ܭAT.)Y>ΧBȜrEHՙmP SrJ۾2c?Շ ?Ś1(:?}r i-#>3zWL^r["5\K̓9\djy̛rr:5,ՅzyӺv.wWXD6ј,K;>XtKΦ;mz쾫@z-  rnsQzHs0 +̷-#Cw)jm�B0h=Gou7uᔅeG5/[;M@x"b )rjM%rKm_rgak. +0O^weG 5c t/Evw78"$u>TlkBpVTŨ @=#M7_Y'_{v)fg'!mMv%rc434Hе40)磹f~(T" hMnZHCK\LL=t^ +ojMMhX2_6قbi Zny.i @:5W'=FrB矆kAP=KҒi[4gR,3X1Pi@krԎj{`a+Okuh4?/^Ŭ/_>z;I!x˗݇ߞ~I??t|2"G#hÓEU$qPYFؕYd-kzdDO!96[< !nL;v1]bΑ/]t d 4#Eبq%KEE] A\Xެަ5ׯ=CcB'h%+k7kb+;:%M2bX eb-.vOr ~řlq$BE2ClӍ$HJUu'J3lRJ,bi3KjKO5&BB2|*RzcF¿0Yc"jF"op:Fy[<% JdRY/[q/?I� h$9Fb8PE"ﳪv_J�@u9ػjXUش->DhŊ|4ǩ ʆ@K}1{,\2FgZ!u/H]H /2F"^ɜh/0ԅgv=8dT2Z:LqWC9cr?[-tK9gtM(<[ݮ,i +DIyJ'[/Y{]k. ԲIZKEE�z+Er3wm!|)+ef)Gݓ?mg),3/H5e \iN, G5םpBD^ZSC":pg9pŕ!j$8N[,vx"epcmňpT#I*9u/QT) K*ziH% J\*^ (ܗHRm AYh#q}eT Trl卤^c"2ZPbplvg,kl`5t# @`f_rvT1pspK`}n:/&-@T0}0=4{0ʇ[̜C[2Cvp᷵8 Ut KkalRK8&Cu$ᤜ9 M2@ Nw#5dWs(h![ Z4·ak.k?D6;R#A353/{n̮!} +3ED TR)yrsH1f}u#Lvnl<ӏ_uttA:6>P׌% ʆ+ +)оM!tT#7y.K5I-C:bX-dEP.FNJ^ey(`s촩1v'h+(C#5tZYE漟DZ<w~o}%:ݸ7`PcU־Qݚ21٤:}CGח^G=__c q͇[CYW1MjH͔ TxbkIUUFs_Y&r<Ĩ)M'-T<b!4h/w$G=-\UHܦ={q#oJbnR ?t0=݌$Ғ! @]Y +Etu^HV[͑ʊ&dr8=Oco I9O]:HIigK +˷|u{GDZ=E+d-ϖH*D!6^Éˣ0.ߨ~K"dO9oK*;�H8ij42r#4)eQz8b CEai uXwexHg<bo=d(}C̕bSHriq=N$B5$7x1T-F({nO wڜbZ?so\22] EѤPr 3Ϥrq/DFa _->)S�Ӱ?2@7FF M]k.ߨ*@a7zYr"3=`%)g.fb +oX:Kf %hH=&^XFJ -D-|$e'!>D"5g)P>:%:9cF_,pJעxل_ De +iB{q#puZWWEzg[+[ȱ+LAMcupQv+8zˆȉأ<ٝ[0YKR(HA2ClJ'8? +Ek Je{i"TGp$.Z\aN.YGͭ~=4'YtФ'Up9 +#بY>j*qf 3|TLLK`B6ܥJZ]Wot{tpc~ӫnNKkWO/No<\x8MO>oon?O?~÷on_xx2^sz?ǿ<޼WwoO_=<?r:<bOo߾~ӕ.(|Ϳt~xwO/^~^Ӷz`m:E L{xetrdG;pLt<,,'R@Z +}TFMŖdH8aJ*q AW3%4Fs�E$̇]Z gu˭=YL  !+~3Zj5XLMnb)wNR\iHYj6sٰlx=p7@*zlc#�KO]ڵ.t>O6C4ʖ(cMK &ZA4N\0* +/ "*\{r 1T >!UľL{&9؍x97O: ++nd~XDGJM@*TB56ܪ04 YS46SL=o%W)!@H@5 #5)iMRp-n4uYҡfSʕ2= vS;F. U3P2XRҙkw=+&-,-K;L}\MD(M0rr$Phy`5JT"%l`A7F4NFLIq}yA(rlBstZyFko%d?7>.Z 2AB;e*3UXxVr%ʾνuKz +"υkO̱Z:6qp&Ǝ2c8_0]T&=4$'mn8>QzǼjCAصp/vLlUh}1tHw2jnpj/z~.une(7Ϛ%,c9::2Cwjѳr3t[Is#&a1G:G  Ѡ_[cqLc5ӨYmQ[8n(R8Q qY%] ܱN,H99,c>/]QGRAKfRӝ'x}?$k+əJDSlQu,E:0-5Q(Ҕ̥RX2-**G藳'{=-D3(U*W[2nE(S̚ZJM;w3Fp@z wgIS*tNC<¶;}hE7lZb\Y`?8? +%杞(%T3Cކ8nS^r!{kITڇnS~y4]oyosQ'׬$B>ʀ`: 7DGb^Iڭr/DgF{^Y˝-%^U((bDt6fF7%J v91Pdc.~ES|hP*d{".I H]@FoxEft>d*\ցq>)]wEH;<ڤfn�P1j[Bdp ۸LߖP/Vأ7mˋ ru>N8?N%<5 c\-0^ +sFcvE=gKgŇ`kR%i/J#{ή]OG"ܻzr�Ƃ3+fW 8L֛RUxt&=񽎃+ϫP8FYW*U]WdvD{:)>3_eo̎Rz0G峏|t@LR6L@i()UF +Wˇօ>6{'' +\<p[+y~]e=hڿ+CmJTVI)bB3QQA<gA)+TvV}8tj +,k pny +']ŠU:5~0�A! endstream endobj 232 0 obj <</Filter[/FlateDecode]/Length 983>>stream +HKiǂ~rQ em&u\DY':38EHӄ{8hQ9T1I+Z,͹ADH?~/s_ʗItfNmg񂅆{{w=޻ԴLS⼛bCʍ9#�CzM).}ݹaau9OzZ~ҿ�[>KXzNka/)dKq}tyko�RnvnbSȦm k~.}7�xy1oY5 +?Ma n_iN&ZRnYj��_zk +?Ma 懋Lu샖;�>֭Cy֫w*Al +yw#o �:v"8Ħ?%˗<{�>XOR]; 6-+ +9r/ss +�U+ݡ)hDmɴޭ_�ܨ4FzJJzK;<bS6?\d:=QOGX�^vg"Ħ?OƇv_� SǯH?6Q+\bSS[|*Ӿ9�@m^{\D?MaO~qKRnhYw`*%}Xݍ�dj +gdڍ?8�'{K?MaofW`s v!�k1i`nKiw" Ħ?GKj6ndD 7w2=݅;bS{fdȫރ 7 `=(S\_5]?MaBѺ|yonnӾK�mtͮsu|Al +~6Ժ)7idN}N͹93nSvbYh"ɶdڋ ݨ7 �޶ endstream endobj 233 0 obj <</Filter[/FlateDecode]/Length 1157>>stream +H_HuMAc?WC[`y5*"F͜RSR⪣sk wNisstIz1`1%k]]S|/9=^p8}3iqma =g{,yXU ܖ X6'% =}VlH7!Px�z<\|Qu|NCSlɏ{Nۣnl#ۮJl;:々?'ie:1IW�p&ɏ~w2oJ6?i\/;n7 �gcHHNkLip-Y�27V#Q߬:ˀ;E`te6ݽ=  zRrU,ipĢF]骈eޚnJT}�߭Mu].,ipJ5y=POQ~�' w&:Ţ0: N4}Bɡ9�ErA=심iteM|{=H\&BW$'TgpNC.RƝ?^S�P+i-93 +X +?O,sZoE+�ju E&`NCn2Nx(SCu_zA�ՙiQaeoUP} X^Ecْ7(5}}ao[[y^~B?nώ<fF+w/_uD`8˼z+ +z7s}ggDwuҕwh;Ov4$=]I57?O &yMb>o蛠@gr]V}7fG3坻|ttD`8cGwWh?v^cdН"Ufcți$�%ZwUtE`8YѽR[ƣ5ʲs#y</?aX &6ʮ �ĆgyͦltF`:ꪧ}~N{BnSdg/eP}7Xg=<U@R#�>< endstream endobj 234 0 obj <</Filter[/FlateDecode]/Length 3454>>stream +HkTT/"hTl%AmJc4XcA4"Fw hxKpaxFS^003ww ZB5hmctY~=Hpa~KΞs>:3?9q%1مmʟ{2<xk"c{ҤI]LhbښmNwY}5BfJr!46%R\I?@z]s} hcc k +v5}iU 2р^j�o\Q8m]@& +?0F;flq`V;yci|ۉ0^GO嫳YVLLCl oRQfjC\SG\-d٠c bdЧp)Nl`y? Ms%ɫr\@ݳ1 +A^A=i?0\-*eSy'V\c${<cd",BOkgs_!24wNEy1ADFߥ(/!wY.+\ArgCLtx)&u*t&} O}mW WCg g[6Bkpk Jij,jZ u xطu RlUT@&0?0)'yekjJn;ɟ&kPFy&7)yuNu7޶xH$+9Ԓwj{bf57 *t]&FI1:8-Vc5, +ɺdCU'mfKQߕ xeV>?qw!Dtz]{ c?REAor=k`OyuOBC>yӔC֒_+;L?Qcړ{(24C-#Txϝ-GǹN řAht7ysޕ̎ถTh犪9υt㚋TT,-7 c=+#SC^4åcBe=L4@w?\-n@AN1V#MNѽyoQMz՗́G�Srt:ϊ h_2S+yuQDvK*F^ +q|$Θ˄/KXROWUtW^t'*t_W~ A& +-/"#/*~E  wٚY^|z|sÛydr"<j!(64M^J`. ;x.I=Mt17 1 y!"ًf]Km'OZι7sw:*ڞ&{oJ~Qnj́1| +;B.]isߗ!:Ȅ ĕ@N1}e֣Ы'6Q0`YC:~kJLb3ZuWDy13&m=/(�XQ׃ɕP-썄Ӕz0 QqRĞ[bew9dfs<3xmGԵpfQ ta,DTp}O sfw?ɯZc]}](vѺZjp v$vzဵB%~S{wSBcS{^tmYcrBSK:|NUQM{l90^]C\$ +jRBs?VWE!aE1i펓G^Өdy t6UOw;q}=uv+*݇k#+ÝǪ=5աVSI*ܮ9͌Obwzm'ӆ;.Svy`x(Kdkjyg}^&qƔτiamZ5QEGWJLlJweqΤu} § ⼉ +uƵUAN +췀g-vޡgݔؔĞ]{lg%*Iyv]m10]j%QP(;"ϙ[[~]n,C&ݝ*9du/q+o \ʠpp1's1?;JFoMIVE^̌^BEQ͞R�{(1م0;#Q^Ɓ(8M) +b-1ɲ;M}qޛzpcV̭Gsͭ]&w;~Wmw*<ddܝ\kA\c?eJpZ!Ւʬ]adk7;<@VxV y]a<yRD~Un {dOZY0ߑTJ\]z\ߕ܌ DMMGp!xtKSaǯAH)d%ReD]5hj56L\9۳;ww0 B+ 퍲 +l'\ Tym߻ I*qܔ~қuҘI=C+$i95;w^{@AMi<fϤ.e+撫N¬CIuk u0+ bTkr%ʳ}v L%?e,8Ny9gngY17mU?^gzs0df,t e &\G$Eǡ%`oa͗5q՞[+V{L&f%e� .c.TDtq61>ݲ5fVo9F:.Ξjw ι̜|Ce,)65nk~]E/$Ͷr.s&^ʲs?b?g>-k )r5=nf=?+#t2L6焟03 G[A/Џ` ?pDR�rR' +0هUq=}m^UK3*x'nvϜT\a:Ow+.MXL P&y<k^Ex#Gi2ͱ{%RN!~?Qw w7&oz!'Go +?a0K m5lZL8HP f1~ 0�!| endstream endobj 235 0 obj <</Filter[/FlateDecode]/Length 3483>>stream +H{TLJ5>6Uɱ5(VD|Tc|. ySp݅eewv`f(PD j<Thh*s_bnj%[{5;.ȽCy}gݭWJQP4? 菠{A*iSα_̛5u uMd(0[N̽}i>i݇ Dž- ݣ2A@ OqSGX}ԗ'k@lu�to"P<YFP1څB_mzA;)x?Ƥ]�@'D PR@Vnst9#B6PX-BCAQ?0?{O ,<}ezjz9AWAA 1/-⽇ JWDŽџl+OJ]s_wkfmHq̘!7ze$ +%dR\0U)>yy O +gko I(J +_.(Ւ~fqUqNCwnM&{<.X枷njPuo,>0z�U h-~zx|y݈ /) +:RHDPRZJIY@F/yvcjl"AXfL#G82w<~DUӠB=C]-Q:?0?2~y@?Th/k_ĉ$~-U)mN^K"@zwAABO׬!S4CI#R.6gM +cO#֤]XΟb90soqottNo6OXxQS"L=KO_H׼iN\GfvSTKΛ vAtM/ϲ_g]9zÝg*-z1q#痹&~7(~!|:~m_>2c%ɾ.JZQ`m7/o8<M6 j)`) 9.],3&S7I`~ȜV]N$+?NL;Ynr~& CĻPR�u3uG :<hwꊂX/&M?? +V?VSSȽ']<w0'S 7գa\4g1e[d:{�mwjPgڍpnClq?c?}7v^ԝ/27bO*SYz)uVKs%sWnI㡠y.~^#+XF fB슇#+ӧ]߇,E;?fLڌ;vTě6³y|BW3~W[{OgNA@]z7)~3>?0?TKKո,M'|Awu3~}kxkkR=AWu\M1|t9/Ks?y4cҼX০W?Q w|8Yk@{Y ^K̋>k9\_r+F sSw-}oպwە"]$ZMx=5y "SEGGPL&o+  %5xcK C5[Cd^}^_]~g7$QN5b.R2w +5cc&|*sF!EPGv 8џL Áb/ar[{ݘ%=ؼރNLH`h&czi݉ o t  %X4Za̘!_ssccq|ںa{Šǂ^;<C ;ǁ<;*E;w~X.<jp:sEw3+F ̼]Q)4l8xZ g:k ~l-Y8s{ٍHi +Ǡ']py{> uM_C7iG*B惎?kt\� {^a8\pP@ +tof]0>(ՒGP hI_y`Nk)?bLרN$MsaO�_B?NU[-MV#n8^,Q1Si*7mmȞ29ܑ(�u[=K[ `()|�ٍȲ^mh)7vHe673H )7@+W{Odԟ{;=)!+YS ;c}\C [N78m޹nL']{Ģ?=o?i&MV fpչFJ +_9^Wk礯>a|hRBnǭq?77y3ē̊!4ϧW{G\Јb܏< d$LX3!v/ۗ8^DfD*)[$4$ DR*leL)%hĩs=^ێ={1{2Q|eegիlعw|6vS9+alpYtXk/Ȩ2 -6WQ$dU9]A_ݱ>É>i$c8[?j^7e[<\6K:בo:8-k=,Wz[rj}Cy-PP#dR}x%s) Z}?_uECq>Փ'EC=;wDw4ܫ^ AO ]Wٍ¶+­P_ ӑ;[V:+k9Nbx#F2Ls[a?+oDF&Nd^wAvBfNVe{~Ԗ mθ6uGEh1r ^y}Q|矿?[غGNx{ އl}0usCe6<h zJW1AMAt_񅴬qh#C͠ڋ:G{ YRիeLhZ]zR{XN,:Б)芵9Οtɘ?יQe'Ey wȮ-gKi,R[S4.~*6H{ZN|>enzbi|`�$ endstream endobj 236 0 obj <</Filter[/FlateDecode]/Length 1879>>stream +H{PTe? {i9Lvo/Yݤ!@L3ZIh"+xOX.gt0]Eb娨4MԤb 3췜} ={~O(B24=F}.1s- O UzFI0oVk\vFN݆)Zdc(roTڪ_iW˯`^073L?\@ɯ/㰘:_\5Dȥvanh Ju.07|A̋%\:wP{vUnQɲC@vޓ3bѡ8ߖbN%9=AiI?.N-iŏ-iӍI{Osy3? \=%1="sgkj<<'%gc2xs.{Z�s { !JKb D{YZ+;C,S1u2B"˞=BҒ?>JΦ_g}v<v38\̉>tfY# A?;pRg~kJS/,M:yxW8 c2wq?(-cRAJzx]Sg[͐&ٗs|[kۺ>ʞ%Bw`$B'VeN]G7PxU6>S,ɞBwa$Bω]q}WU̘3?oL${V!r`$BHWFCtV}bpXΠ8r-v~42FZ ? ȅҒ?!㎷b(Ai;bj8<'n,gu-~/~ t׉E#[JwG]s5qX!Ԋ㍦ y{\≰ u Z+vMpf?EзiǞ/]pu{N=?(oiqj]yp UMӃ>?fSyC5?!wEj>WW:,;c..8ր8g{_}9U:<�}ګo߇ '*[BoAyK"<,߉ca,FɰQZbR 3Gݮ?(&{D;ˊ^bNą3j<So2&?O p)>3P2)tzU۷P`e6-]?}?ն"{ 8<m:+4ϴ)YmP_"S;JcmNN ԇ:Q/FͦB_П\}>AK!O#jTu%<ZeIC~2=>"j٬k&V wӿy3GpΙudeԃP?uwnԏ>Z .?`|]Gϵ>ת6 Nwe{}|2W9 J 9f/5@ч +Q'?_?ž{j@= =j^Oτ)k5Oo*ˊS3CpL(M UGoܴm)g>sCK0'_l~/uGfi}5E`>zL35M;~9})\szMqlt/|l+-eZv١*G3 0�=x endstream endobj 237 0 obj <</Filter[/FlateDecode]/Length 2505>>stream +HSS_NH\PVQiunqEe,K5PE,D"Dn\OiٵNSo[;z '`3 I39 ~Ϸ{DsmclP57#ߚ^t@1槳aX=EiD se`rP\b@`>7#0T-vRDm^^w=]CJl +W?oCg>/fuS$6ϣ(2a2<r9yz4Q"4v= Ӡ_ A`ˊ,?Q&s[DAAčTVR_Z/o^I1ĘX2i2Rɿ:92K\T:   nx&~Ý "]ux1N]绢lAAAAAAAAAŗZe'Mwz). '~|>ZQ 7l|{PLsc#A~ddxs B]2l'k7U̞}'ϪiUvsQc$.z5|`L07Ꞙ{:gﰛ{BPRDd2|Z}ۅ p# [tJ\TMWMUҼ| +{f�~D.]ΞsczͤK~ηNJ0==zomII.êNgF,GmkJRubq0SBj5v_~)dEL/*ͣNqo< {i<س�=a3?DbӓR*ˏ}'MVzl6ƈ'N 9>GԣC\Y2?xE-f7;訿Ȝsᾳ'i7cۯ6nof*LSذ˚C=aU]hƞi}?ZhC?>:ޔz*#9"s?x<"|mII|w~ӺpqځrT8! u{7 +;57o!po\pLE iKIί+ jxp?Ud+SY]Q f!al\ї5Ɔ]FU8 +A\V Ϩg %!$:|>qJ'jY +.?RDy{ t)2'| V1a}lK#ĈZ6vvTp룢}PrE]cXH%Q=yJN8p4-5j6F" +cߡƞCe1F߂1fdSiDMXh#U|()9}wF&˄OֱsPcěS +vxu!a6Yl>/sݚ  +V'qFF ]uj$Yy@ڒ$h15 s0U'o^ذE+ ?^"ƈ71Vh^+?B.1?vkՒ(8yJ@/:Xe!y31omg3m Q>;#7#J%ڭWH,sEIھI3<ƈ7Aj/ViI콖=e!b6}]hl5n=q^| +ɰ􊉈|j왔GY*5�֬\hH,8t9acY8808ߟ&X2!BDZ-H @*~ ߾-ubq0a. qMjn͏jn;;*S!2_<1t0%oqjy9^(yk\<;Fݛ[=x;CL;/$yE3iוɮnmə4^3jxзǓ9_[UVt_uem>Q19z=IeG(|0Zٍ3wի}uj쾄(2쓃B__67!]v1V;vkعBkŹyxm). hKdWs9&T-,jIW;`&Jtui<,8[_Z !֖C,9+Öq{:}(/o4Qض,dāڶ֣ 7 $Ύa޽QXƞVȀReK%| *+a =D憱K~ZVX'S7j2=9=5F _a;+HNquYG0LB2SD,]6=o}T4aε ƆaAA. Л̦/\=97^ʜ=0ӯ#E=_G?7 "]u]b=nPw��@: endstream endobj 238 0 obj <</Filter[/FlateDecode]/Length 170>>stream +HίQ_9; +]q)܃j6ɨLgo#*67 ڔox#pΛv,Kb>h7[_mۋS^Ϯݫ.c5t)�������������������������������������������������������������� #� endstream endobj 239 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 240 0 obj <</Filter[/FlateDecode]/Length 285>>stream +HAj0DA +,<YX~joA78��������������������������������������cN4fLa"Ss?0x缏Y[K}_2UVw˂lwx'7ql[\~ēSXcÛ?9#lO+vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}pb샻6 f˗��-<5 endstream endobj 241 0 obj <</Filter[/FlateDecode]/Length 518>>stream +H1NAEbP*߁㶙h:"qibsLĭ1[c&6$nMlIܚf<>`đuYE٣Lƾ=qcGV7v6>8f=>%nMlIܚk<\?|ы^~qhͿЈ1[c&6$nMlIܚ3jtYZMwvYMZ}dvY Z-i^cwP ckG&m>ȩS##"FFGDNڐK31fVc.ͬ\Y1AfG ͎ :44;thvǢLEݙ3;ugjw,F  ;36<vflx$Hؙ [2<weny8ܕq+7= +xdpz(Q#=ycr{ 1c76r|vd7�Ծ endstream endobj 242 0 obj <</Filter[/FlateDecode]/Length 25362>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-6]ך+{^^+2!՚CdqkE͛Lަ{Z{/:iq6ܯew-Z1}O۽a;L>{aAtq6k0=f0v("[g%K6e\X9~6f3بUɒe6IeZB1;Sw'q} r&Y*{ȥٴoZznST}+έ:OsFzx՝U[8kDL(FS%=UZm^i$fɧѱP>ℙwkRֵj{ڨSNְMzuU^Uud3*+lR` m]yŤAsAY\:|h!XywZՌ exs�&s5{geHaӶWE7tR1y[ >nmD3\leIĽ6\Ek`zT(m|2PkI>oسY5s~qh&Dt~F7d)fq֊L ᝨfZ3D'YU4oYNDy+IO6ȯ)2N,Tc_ Bƪ%KwچlQ\z[Q2,6ґOCT͛i%=Jܙz@+Eմb_~/~>}`@]Af?O_O?}Nk~֮v}>|q}W,5bSDGl6=l$і�ڃhM#N͑31\ hvh.&jY)5Iy f&|B3AN`GL#5>NF?dnv9~8E=ϑ['qYRKQEt cc?)X>|O`uV~7`tF|&JN 5cLԜd6K \C+QzyL�t?&JCS>U20̂,d!� f.ȘBc\.Шr>2ZH1 UWOp~ "NW[ o�Tc *`Ek d L=7 yAc 1+G =|Gr?* V]Ǯ1E PT1Va7t!.&-Sƅ„x/5/?MYefw JM-2v%{:;/sÚȒş�rt +*+ . `${>a8;yH̭6yp1B9㗂~CH{#[km4{%<%dE]~f }�*]HB>rWZPLxȾ=U�]@,"n)"+=I-T* \n3,e)MJ YXEM ^1ZDg[f[O(8nG.٨ʄeFkbUIT|J]׋D1*d_|L!R +P?y<a2UC]e<NzIHN׍mieyzd<$ʸWT0ߒ +Ru-+(W $I%Zt{ qGkbHCkT2,Uh>z=f=uIʉ@D:TlQxuQW#(aXÔ ZRvw]%a$D 6]]DcXzpZyNrCLq<iHQ_4<$_zкڂ]| $W*(JPUvŧ!>Ztt :(OeE2H=4L)ڰZGq(b߫}bJbhu΋I\]S14jym9˺UbA)T;:&pHDVd[x#\zLs<n%{<}{*қӒPs#a #Yipy''ÜO:}QN{ >$J] i %ؖD~(8$Z)xsMx}1mȀ?)(|wZlH#yr9ːأ$oN.җJ͡,]0|Z t/U1HAK)[B;qAW<`W8RPD9=5_꾄.BL9^z)&M8E ]2~A0�b>myѐLq֋݋x'qbPKΉ)^qE/ʠW`T"i)98n{Kr6H0J& P.(f'MS~tR )RIuyo=iTSr׹,';pFvKH>|D VLB:AK}޻\uYcpesrrg2[ədx&n!(2#mM#M7$}�V/h-cYo*DX,Iji}mĞh*]cC}CE$>< ((KhͭbTs'[ngUx0Jl ռG[.zr_.ͻIlnN�YU}$&}Y2(rřĐ՚iDd+U& 04>wD\]OSHʴ1듋Rϴlkb3�`$rX{Ae?K*sPҧ:{[MA*SW:j7B4x]5svaO߲@Aݑ׬$'t]Ԅ:uA?rB$:K$-ժ]2Q#!\> )hQo4T>|KVx7kO(&duVıTsp2D=j?f3xHQAͨ<_LΫL`FκK{2bЉ^\qw7YdSjhb괈džw4;|ޘ2&cg }$&FDzhݚuxVsoͷ;پ[ w%W +fcĴ϶/ݫf[3ROh,»tCo`GLEGc~`oEԯ⽱ꃠ{WH-.hBAAs9F[wGjn",rHu`Œ Ǟjnre9N-atxri=kG#H(1HwEFU,ukv!8{[DlQ2 3*#QUY|8Sn6ۅ{oý?TƍwISz<u㋛ZYS@63zݖJp<b7J+\ȂlP25Pև]iHK1%rV?ʸ-+j=t TLEƴUR�Z_*Q܈l2$3i%﷜ͥ#fD;h>KM?z0~㫅j-]6:7-A> +`! m܃8R|Fۼ sNl-ùSs, +ͩF� +<3 B@Zbnv~H/ '?qb>ǏF k+ҠMGqtVJ, kqHlCy[F4#84s0S n37o#EXTsxR7Kcl(o z2L@PBx̹(m{"r[bҢGZ81KcEJѧG׿s7T[GqU:`>?d?>?fj1"+Lz]H~@8KQzL/<w}nuB';P4G(d4b <pU+K~?n~@ +?A%z?{to$"&d 觅 Jj䪻 X\HZԫG –HcY(E'ny+r y#}[<! ⛺4i235YZȏY9԰%y"wE᷹{[ݎW;-Ї#5\�-õW۳qXCL:hLZoi~ 6aLY`JSo@8Łe^BF@IN*V꼺&@m%(Ԍb<6e'FOwޙyIrzCÇ9}[p#(LO=C"9@bnX -w}Tw. VyB1Z\#>fi[D]t-; ݫ&:bqz5拀-.UFl: A S<BqNޚ֞w9x 9;s$c揨f +,C>OC@jY.Еi(%ݽ 794K3 ?0+j7wy#IQh 5 ا[yQl]_*&"k2M<Htf>ު9nߧn8r{ ̟WۢGJN +T"1 rO990I8R+HD%46426DƎti4͌Uk]UjL?~>$1խY^5ׇo.3=З)\9jd%*{TST'ek +:ShF"cPժZ$B3UsZ;e* gxT{P0)IC`^>pj + /e! +y]cӈx+F{*c+ucwjUC< ,tޑDs,ڝjfwV!wa^xd\(T$OÁmni9؋r32[5FpT +w!VS»jj.UdzD7Rh.`sDP*4VwiAs9f/ЄRT$EnFEgHn+!kn Q:fmÛ#4){q$'g3,V[), I?ryn^kXeH/+?A?ă~#`d)J,&,"Mc"AZM%3{Ung[1H/QJJԮ,Ln2 qBKBAq,(g]#ULIQh'0A:ms^fe� +Y<Lx0lHmmtSaiU5FL</ {R|x!4<9 kq&p]f/8&."ElW*bT^\~$m㯜1B ! J~áwh0ſ#':Iy},J~|z퍃UR/oZՎbXݾX@V/VwٷV/Vߧ_Wo>!v?|O?\pstz?zs}{}O~zO ǻbKE<s}իWWoc \S:bpgp1nN1¾4 yhШW#J_3gF]:Q*_vΫ5xԚ%-wIVgl!QI?qx. ]k"QX\v>qC^!Wj1ػS@ +;1!^[ҮGdٝ eQ,cF 7ԥgum3OIO^^Ɵ_/:ST\ rȇx$וgӄX)  rM { &K�i2SYvjCfc}Ex,ji*PƬ*̽#o&#k\6Y;LR +$ȶ=KXcM:4+k6%ۅ[p4U nuSSG:`d:R9I)ᐃk"]Nd8s$r46N +*ʙY]2#2MHV).@&%QB7W?:r +SKkQX]eWli*ޣY[Ko�Pz +=NjS4 +5|pf ^ �# %dߎS9#r.-Ǔ)(9HUzۢBYIߣy§f^yǖ!{Ǟ`ΦkVN_ J8`E?fb�v.SzX;k2 \f^J?K]ȕc. laEԞ˷&,s7iEWq?uA,x+ش$cfQVeV!EH[.Hjg]y@t$ATr້bXc'f{a2E#L;pN^L+AEa7oA`*0X:@\jP$fxMcC9^2#R-:$8!Șy@w|fpZseڄY*G:{nXBfn"oǦM 3ge *ZfD!wza3S;JB5*yf4hxGyo(G;.ԖM2,n\eJẅ́8η]ķ tYz(,{+4Zf(<dAa Y2pƗX6e�ПɪfI՛Œ ܤF +tfdh‡8 ]!=xt +8ۍK$?'?թkPHPA|͟*X)N[-92A9 O4{ 508{Lpi� }Υ->a2JS(8s4hzعXʞhC.m [1ۍ>K1.1Wf t)OKhYK|- 225%KpCk:L"S೔iJS`4*]sXAQsKz+!QlՉkQbZN$˷Pi{zpZ 2ٲp̮J1)PxtOH$Z<Z8tFPZn۫P]Y$pK_ڱY,Ј$/xRڪߣ 1W˧p"{e߼{Fʇ@ruvzWWTezyt5Ta2Z}ߌZ=S穡Jk'k}.e<q P`Rd+\hmI/7,4F$,EMX[aDdu}ĝoyD`*=r9wqewB$6V9fҊ"šD6con* +:Q/N"dSxͮӰP..Qh}-/X. bsO#j-XE_8*%]Ŷ,~,ʫR:JSDͯ/q{5�tc VAҍbY&JY{8,F0[À}F8mc)ۚ 3O@^@5cV|Sl"$Iخ:ʘM[1beEO2T0Q{=@\ cN (qRʪIsmKAPOHBb}rI*0AFlèQ-hUSF6rZBhŪ%6u[%S,aRPʢ3ҞB\q,Uǃ| m3s8j  zQÃdmJr~q, 8 p (qh +$tUսgX>vfgKN bčTD'4m<^sOQH~o ~)iNT `5Lm6/x_;?"tƱ4"C14,Ws *$S0Y|YRW,EVуc`�CBCEglg& d0^ gԽ뻿=ça{xw<=>n_oӇ_mq~w|~<_cޫ~'Ǫ>[pdF8ПUbt-m "GbAI) +u:|H}hS.+m?lr ̚%Yaq1Av[m}MA iϕ^嚖\鑆BPlS3IXmL3)1uib44ˑRB<;<!uGJd(HKJ5W 04̆k}V3/|͡ PB,>1-**qѴ%J"⹦WB.eXuzԴV8\dŸQ,ڕN`~\c8kҕ$/t(LrN O̊FX} p<)MAȫb[wG8yܣ [M2~.sv[ ~c۰CF}Bh3:3"V{UEVn;eǿ0ݾeoݕE>Edd3~ZvZIp濊ÃT7*"}Q&}b<AXd(v +mvZA,4YYQ IdQ5q:Ϫ@yE@唴pd-Q+1I$m}icC ?îWF2M踖>5_d ?C_:R* hH uh<D0fP1twu8 +DFN^Ʀ"@ΎTgRv 2l1e?kNLno[ P& EPX}Tks)u[k?02sKj1%/dRb~ HK2LI 2i8-q s'w"g0p V&EMYB'c44SÌEJk$A<pK>&N[viAXT[2?{P9׌95\+ +I;qD/t=r<5baeL +IsBxMTNSܪ[WPub/k8_MǥEdHŋ [%p 1k�ʶj>·p$Mx:4# [ " =' !{`{nOB^M Bluo )꫎\k޶{ s3 8\ iqay*\<0fI `죁N\E^PFs+>JKmkl"/6n]W.sVi ӝ/!H_Mr7( <.nE9Pr9|%N$W~{aPlIW^If\?g,b n4<ѾʼnبX>:.AX#OΌnW_ +:!Q+Am%g9ifmǰ.kChΊ=Y/QSHN|L뛽+kzvB˙%THΎbPi_׺=9MxWdEa33R5Lm<0FsSͩkYVúא\f tD \šßOo506y<@IGXGdDVʐ'OΒ<8h�kpt=l5 ٤L8.ndy +hva|fzbZpy_8 +a[)&CCd})4w >*l1!]lq !z NwxWMB.̶:+ в~RKϓUb 4`zY+z[T( &V0%c [߁KHT/^h5qU]>,#Tg{IO:dœՖ b!'VJQG08YGWCy->\TkF_DzPa#[@A\!k81{򈾁J@ce�43W,E|)Vxd+3g>Ǖ!v5{i˗b 0FhrJ9?F'^ +(f?j t{3_|n<P�ǟ}yv|~|jlO|tp<OOxi|p|z>mGyxW[ϾY6p150Ts%P`V!ӕ#|SvM2Akjrd汝I6Z\Aq_Mm?n YKGE%E5'Ќ$B_7J]A3Ӫr|rY'{&`1ȣF{ JsM3-.%DD8Z&>6x4.+\R +M31|eF> f lvZ'M3IhV:M6J\:rރ7P'sSOU"v<T#A.KwDE24O" hKǍΐkdu!MʚVNE.WvTf9ېCK1,R\H{A3ZBw*X-1(ghBLj]<s'ZY9= +Nahjh8_PuB =⤀EjO8$6EQNG#a\W~M14JbՀ %i-@Z0gn:a#/Q0(gZv=9 *o%/^ Gg+ +g:lٮsi(Rrz%;ymDѰrʗ[36tVԧE05֩N~CT݉HO.i{d;m[~4]Dz3f1sGI33o?�ʕl :C,x#M'fv#!nUDqua9Mgjadl +һDK`TF9*5[޴m]3@oyָ֯N.KnH e%άXSP +Us;&i٭*82[#7r5hK^Z>%aڍML:$U7dyM]3\/VH/e˜YF2\#z `أ5֔YfNhL~`Bk3!Vu).O7YnMn9m>?W*(yJ\v(S7܋辡ŞbQ0Oa P:#ݿgl၆cܩTi]+wO=! +rlRJ͚J|zPC27&'UOt\]EkiDZu8a\*Y3Ŕw D7Xi +Tۣ>`هUyje wJ&lsػJPDX8*‘ B矒zPoVa7zF"R y5Lc-û:-V#d缅R_Ѻsc4V\V6i!xuL +[WkI~xЪD" gy! *53e#{.$\ꧣAS=ƩNEr !JϲJ1:bV~iΨE}~UKՀ4{SGYԜ_hT'-H :@,XP91j;dϟ=zSYh6c-i17Tjx[!hj8<+y9Bth24z5?=N~5=CE5?Dh2 R Q?@= <P,m#a%Р�蔈Zݞ% +S F~;fW�8=B"t#Bh/ ioMD�b%Pwj=Q8M=S$?D~1 _SNYV\@f58&rݢE%lYUĿf+:8<b|X 敘ChO$Xcj>iuwJ/3ҖW0AXj�0OEQ^E +q}zXB5%;~7j$o,3J;m3hNƯ�DsSvK@+m4�N*vTnpwe2c=MFKO'Z7M#4m{ڟr/?Wpv'kѯ*>Q-u#k!Td6 A ?`0n>rB=nBGf;)'%M,8 >d6铑_ P*U4(<JE^7Ipz``6HXxc7Hd\|Gn`i1U�2ʙ$ƽ�EPN^miU=wԻ�BXy85¥=dC<Yya!< N}]/ԟjH+{Aԅd`*r<Vlb̹HdNkjoUzW]6 C;g]ot.#Qy%D0r.* + 슱2+\;[^.1Q bb3rbֽ¢qjChL8q-'ya6_:MޫucCē1q!:@;=Lmr}:L| yi'u#BwN(_)4_9l+$l G'Yo_SpC|L<尵9IkH)U+.beWL+  Sl}P^^ifѤjaq�'2}a#@G>ựXjI˝wWTQ `�~t MnZ [[4z@@csGebOz]v/9l +^f@cֱ=IJd1 _%=zw*AgCZ'4=c0#=3 +[G2EB=}Nj };LDž +4 +*e�ifĕ<l'�& Wݪؚ;n>"x HXy �σh8DzkSt*MEގ6 tÓ$x[Zp6ugvDn_:+Bۭi'G<~xH?}vpʚ䖞VTmQ1`)Mdڒq j_lH&/O2Y#)c !T)X۹#bH}QQ` h%qܶjy[zx>K)K7nmOзSN QL>H!ha$i(Xiμ9Ȇj̻OL<޳:ou|;^yg? +K�VZ4ad5l+A#L0h2B-C,4ٔ +{̘38iE{jO,$]M`m`+{=WZ9rR5$aZծ/#+JXE +fC$q>�x2ck8v< Mp`{Am7(@2/A`\;h@'.`]7}\{;9is<cdVO4*t~ؗ!af3~^{;{J^z+7{{S쁉d9u0SeTMɘ+k5F)'.C1%�6iń˳#uE5 rJ>3rtGmc5S5DI%2F60Qx&α!yH6ӻlW1 "A,6Z1RCDk4&|#YrJϢ6n ^bz4,*[ӭOrC~Ts@MbqD}V;ڞS�cjjȢ'Iʈ�N"S`IWL=y>0}.JuNP-?4g}D۶au''dc%5lJ+| +2gƒ߁ޚd6'P_aǮI՜lYN/'QnCdLf) n$]L1K`EOc, tX$k%52$fI]ǏyiN,yeStIX\\A41+),L__hʙT1N�q +/u)d@6!)ޥ�1Seww&b0f@vSfPuKky*:T?Sp<o" +A*V0xw?ow4 $pʏRK6$9GZI'>׵R6SQˠ]v +Aky]J!/[՗<O;tg(LtV ʳߑ,y%rx ֦w& SW1 +1x7S<V~ KB!R8#% sܾVgF@'u"$.E 2)0D̊$BqFJ|?^klS8;ǎ}2eq)˝}_< 0ycs\ _|i5<6%G$g?BhrD{zWkrgZDZ;Q/:ʖ!=%1 rëOf] +LpD_h#J#Bzh>v›;eS% qe# !MD[ d)8~QcTtU> /M֩nu'H)]-ety &7eK$g@Q8b^B8X FGЃ'5.T a +i'5EGGƾY ,\y2_K u!>hd䱊0L7{}S=skS9^_\>vmF&Y˔+EB& a:Tmze00%3Yh'"%[}rqD]r]S) *8)ZӸd{+h\1T?1t$9MJI!-dBdgZ")i +8ҘS 6V=HjTwܧh@5!-1dT%+71(<2Vb_ɐNlݿ[g-d>^>c$adفEm^lrUfxG|rtΊs.!ԽۨK*R3 l!K)|}z͢}wf 3xtBvKVa#*zύ($͍Xs#0!<yEd3^Ye((_)*]CG`eevڻ&9)TMl3.e#aJ RK%j~`5b(V&]-q# +pi8 +$r_[S F,q5a3ƆO}hR$.Y: pOFRtR3mw Xk* +z)4X|s+Sʂ׃8w_6{�k+?]`hVHa}zpݧ"gld[<wBg`vTķ燯(闙:U'*Df7>AA^/ENOrrɱp6"[-g;FS ]zr?.JMG\GE*9.0sVe㪤?tjT*IJug/ άtF7Mm䫙C^n 5 Lu TL5S-Pn$ЯAvvYƘl Y2&QM} SJ`HM%Ի_f"i3o ~N)WƗ9]\l܌B樾%֥RB/jz*A;s/EϯSYF{_ EV>ceaԽsxpdH`.Bcrr~m]-L+Q�1VB]fkil'X@|51:b+_7?W:[ZRfCeROP(]t|srszB&e_? rl>z}n3oCfnK[l;"cU)c/'zK72mgGpF(3TcCP؝zYbZA|1S&֯DLN:�I+m{SHxI3J}`G�[_d̤5\#5-gC KvRt~&RUwFӴqZmgt!R3gπzsS[ 9FW? h;H+(+GE_f)__OwD`UwTKI`铏^f카Xa7rq~Gpe j$4:ZU:V)T3V@ZGe)/p vO(v%�0¹Lu[LV qF뺯7s3! il@;F;-5[c_cU +UD˔y*l 1 RB=%8 L?OSV68vURGa2`0<e'iV)3nL碌TDH30t LR3=Q[.ie�~0y5_f0JDe]OWwLιS$!pQP脖 q�( !}B}.)=*iMO_UlKd}y>ؐNS(<t*`oz5eUi>d%ʥh sC9g1NwOd52m=5Kj3+{_ϓH*yKoTT~R\s!0vJcK5{v6n`3^ۥBo~rXK:u^t\̞!h76Eq16sXv6TܲQh1I  +hPGHʎaI`<`4}:FhϊBs%6^v*޻ʙ,ҹm/(ދ}b2:~G[#ipX7B:5g$`=,MjAY P>|VwOٓf[ cUj)XM , !~a@< 4 %O̰mO7O(RKS3#h4q̉.jic;VBa,X\2>vZf'HXT49H +1*d5'F!)즉Q |Pr\X:y`LGf,^<Aō?-?,8Mv(.8d :*@` L=~ k2dʼN4uYV"H#K[!'#al!g&kq�@؍<A3&yb!š@F^ֽhlיmV66oҚ $E=uH4&|yrslp^DGL:ZEsļ'`|QvFj8T@5+č"%%kbL^7Op.2{vJBTZ˳ЗZn kaQa*8 Lz8Kzq]격n"g,YDf +o203>e<zryɭv.XX +Fݞy]Y=4i42 +)ţ M@rAX7{l IlhC-8DȒQ`1w"A(* HrȀn[I ) }ʓԭHDRv2E}|]Q1봳yt*@O\n1B}xՏϷ49m߿Wۏo~pۻ޿~scvnwpO޼m1o^-.N3DtD9y$kMnu"��m1,9dbL偞ͦ }Y ?D +E $#>BCZ ؋ȐhDS2s #'A)3EȩL;rAEA3|901QlZ2 :Ep~PZt۠{D3,Cލn;LF(: 8pښL4O\t1ξKN;=vEm$$xĠQ{n]?l]8D0F@dCZҸʛp2QmAq@e8o%,+ggviy>L(uzPh#Qy3y`0"Ts,4$x[DjFFX'iT\:-Z.i +-mn"˖P'be!Nd-3#FԘUuGoClbj1q[x )է@6GDALm?o*L<5;"Ӛzh ^2#.)·ڵf,vh# +ˁN= ՜Dk͊ɍדJb{Y%w g0Xjmm'P97('{H +nPxe@)HO A@cP3Vg&ni?:~7Jo^m<P(9PH-Ηsś `,DI;YDK$IcBrRMd l_$�&Ns2_RP�jtHZB}&dd.dT?G3> s0f5z < :5_`AzFR&'H%@;rXAsB7&hJ]?FLH%tYڗXŨע1 B> ^ N!jo5H45ViguK>¸PpVP`*WӢ ^!FnwY}'~7]bBˈl ؝7:v!ǧK-: |z i8Ġ=4 Ʀ + B*yo&�n=8|hX98&.~q:=w^Co|HULWcTn>}%"WnQV]HT`e?uUԳ6sh&ī 75B[5Xق=H0g3M̒1*fXj$nH>*`(:}V0dX\=A4RsOkglo9R<=J!.2UfDnAMvtUtq3_,ɸ)ɝe?X(nH=hj:$Eq!VM܆_@aΘ%G팀ފg`V0 +0^ vg #r1�õћF)r I9 +4gq +9mRJJs=Ag~g"h<Qr$(w| &l@YM@wơ +yw/HST +E{a(o:WēMRE]j8y!Mq OhtPi?LH @UГ4e+iϲ=}MK3B-sPkBmAyk4;8M=>=\-ϰi.1Kkp}Y~@7 tm7Kb7fa2_\tw�3$MNk�(ad>Q\vWm?Dws`G;Cw<xhفbskBS-++WDrAjڔ�+5Wlj-!�М *rdF CpM;^fz7#G\o_/8ck b� EcZf\Ebo9sG�RGq{ov2~rC~Nfc;KM7{ǔ6SNuH,gw[{^Q`b[{u%j)UHwg5mbgf݊ޠK +l޼IWWlY_3gq^�W+ll- ;V>- ,w'WB.!֒waDɅ"Ad?mly0\5I[3[ssom5qzaSl 29I^t-DhQ3|3R/hH>RYBGPMV&Fk}ꆽ+~kf#uX_=@ !<6 Hf,%9YPuӞؑUqm⨂A4yfEF-MJX{I?S "Ѓon)$tȊP.iw̭: HĶ8JEbbjK*qP:-&&OQkN uR)hd>x#o>#v'?WgiVk1468괮#lU?곧H}~pnlHTnL#C| +mUЏV@ G.ZI1ZEzduq>l9=2K.)/z`(БE;n鶢t>])@gywlºلubG"K4sJU=1;P^n>44_ wEY9 DBT*[^ja- +-}խUk&̊7]+NZV%xFl3Bhtab܍P"0##◉9ɑNMPd�jR-0Bc ݉=_9`~9>!/D&<C+*,ـ uR=25\G5Ǒz$Kl;[]Oj.toFOLGbkJ>}W{n.#[{߭'4jK3=co{3_D0A.;F>z9J%x +."KvEVu;.uSb,2 dDb m=ycb [Nx"W'Rk+[MCu|jR^Jk1;L%2+2ExY]Q T·hAVB*dud oo`".:8F +.eĺ~S_) +ud  9/kR0NTFRu +ZHp-saF/qpg[]8UsF>{ԢVt{:xXVc@2B�]eТE݉p=>WItҝgۘ +T s *{bp*=B<͙) +)!'jV<N@(4*g q +|jlӔ5 +U ݣ캌[}NBU' %}Sb&}@|IZq%f2ׇ2%E(h&c u٤+TRaH|,SCڻ@3^uӱEdq<sQ4+Q +dY\ܩ9kCMl(] jd<r'rA>R)ReH]V}{C36FbcYS^Xv7K:"'_[M.5UݿÚ,"mǔ}x7t)"U^БyDj呔*mEYnnj[ iH2!Q)ƌ@ǯCBFjdP3l<]Q-_Mɻ 4㔳HRY#B[>7?*` Pz.\\T^?pK-0c]Yn,vbvwT:KFFssmS:GDzx�cV5Cuc@'i22K #eZ"|JI!b*&Ui 5H?,WXњdԈ\ >Đ +j$g 5i\V.B`%D +V?O.D*xHOɂ@TSEn"b^]#h~6qS;m1lɎMLٰX!5;hHBk_qMf DZ&]7t2$!U4T7GBMZ2b1YYXô67Wj1QL`e֤ےT;b�EZɌvd4QP +t_i"0w,ۺ H t&KY6og;/ HHh#2y9J0 +4)j2 I�eTZ$C9rS{79<WFi:B&Cʲ:]0lۡc{DQL *Y.R[E`#[6½p^ιڕ-Ԥ;ILhzX+>:J0{ .ލFR+4fWO{k׉1e( D2MAD7꼯 <D"1ϣ7Y_e\h7(fpbS_ͩ$%y`(y{l,0(hO}陛IvPmD[WU#kȸQYO{]+7-Sۀ!fjoHWO?~s{qgB=ӧ\^ś }O|{}`tz͛"?_<˷}sŷ7Wz;ӓ/nq}~quw|~~o/O~WW?M\kć_j yR3<yquqE_\_^!S]5,I|v*7Oyů>>`a#UѦSm-Ov+>l)^!cB]QHE/u~c/Nk waS�&)!`N#+mX-"${۞*/-<R)I8=��c| -=BJ:R,1^oD&WӵG>$R{X-)Pm\p+K@)Ƅw$�( rW3FϭtK6nY%4|9U~J\Am nYPKd'bgKmv?CqZ5rdWZV<# ԅ ^]bbk'7PQ4XM i].⳵љ!�,^ ԗ*fG4Kl@9=8ȧN))B] rT2Ru4]};i:&oMBpxpNG.8X?8|0GzV;ޏO@cR#ud +_ӟH=BK~㎚`F*HYҢ4{Fu6&ZxR"0pjԕެK,VV `eI ezlR'ueś.i<<0Qyc#RIf6z^MNs7~RE22j#F-@k4``19LO 4+->V:[!rr]i5?!̕lEJӬ!2 ʱ5Y#@S賾rs3eRci"U:LUk)>r?{$d.?:i dIhtЈOZLxn? +l'V"Ie6t/!er<D* )kH@G` +(rAY6[.Q/Ҁ#U4=-3v$ځEZ,X8ʤBkB{Q&T:0A|5-24UâjM̤9h#Bz\huNŪ�-)8ȒR<3Q7S+ l(`ZXyFŸ3%;ح4SZFDZ`1sq.9hˇ> 6Ƙt՘sݚޖmSrh.a.#H}u_q,…7- <r'ք\O_^D}"nVȥ=]ʨ,r;]75Ԕ7wS_߰*{_\\kG.H|_W{.A>ror6AKv4YF`KRFvvK"4:=+5I&9%`?~j,l}}S2XZl!.2?b'Dv$So0UIK? wNE0:@zRAOxkJB&剉!Zۋtes S>f _X|SRa8azUk~=w2isEہyyL~5{˫&yܞR ğ(".̑H(ɹ|Q)i}%oX6&/-MǨC(iGՁԉ~nw m<^tX{=j)TV#76xj9Փ]8ꥦ[Ԧ`)8Z zJکP0U/鄂=^mkh~}Jva*_�! endstream endobj 243 0 obj <</Filter[/FlateDecode]/Length 731>>stream +HKn0Qn-C2 + +}?mNhfy+мUKЬY!ǵ|BZ>E!BNH] =Sy}p24+V_:4)=ݡYwo: !zV?.Q9Wx'D"j̷% =SߧZ4#>tMb4IEhQZhEehEehEr4Zؠr4Zؠsx=+mOi=+mOzxA)nNqA)nNxE'oMyE'oMyExk +L(c +L(ck[Jl[ċSSūRKʬRKTRoC +RoC +RoCږR_;ELS/#ڞ/Xgw!1RW(1#JWc9*yjpeCR 啪:9\KU+Fs<JML,VZ̩Z^*6s`Qn.gy:ZNuTO5똊[i ~5ҤM6[TIn^(;VtmUk$KGbY<a;^;U[KD+ڸqmUqGޯ>75q>ZSw])ZQ>o'|8^{E5ܾMts -^&^r]qu 2w]x*{o0�\ endstream endobj 244 0 obj <</Filter[/FlateDecode]/Length 751>>stream +HN@DѽbB +_w?䲧G=z79`o۹ Y 19 Df:~tPҳ/R,zus_Xwmn0> NO>'OA`:)n1q2t4!t*'O5]%}K94}o01nmb:tD@'`tHg`etҹ^>HH`w^>]tv?]tvsDg|:AtƘX褏kt'YM|5=.ЭN`?-vtE=(z1Fs`5{LQc:Xj=VtE=(z1Fs`5{LQl_Jk4tkOj;%x(@?QKGv.~T^j2Pp5j( mީ(pj7eۧX5SeN:Xj=VtE=(z1Fs`5{LQc:Xj=VtE=(z1Fs`5{LQc:Xj=VtE=(z1Fs`5{LQc:X+�! endstream endobj 245 0 obj <</Filter[/FlateDecode]/Length 592>>stream +HJAQ#$+h!UgM6Kbn7,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t>/ +Z˥`QA?v,*h{ۙz?uw׿߆>.|? +ֿ'rC8p+7U<M!8c}F?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:#SٹW�t endstream endobj 246 0 obj <</Filter[/FlateDecode]/Length 635>>stream +HAJQQ/ڎXHCH )>G`6l+Jz0U% +<KuWXægx]Iwpg\x|θ>Da}¦r>B|z9q*ڰKٹT `BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +8]KmWXær]�-:!�<KuWZjk8N%FR-#wpg\xy|z=>AVx/uߘcθKeA*t1z0Usу +{LUc`BS:=йT=F*t1z0̻��W,ty endstream endobj 247 0 obj <</Filter[/FlateDecode]/Length 725>>stream +Hn@DQ'+91$ +Ū{bGC1o4t`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t3\T +-t'ŒR"nƶN +>e?3Xh\h.d7c_% `1{Uj7Y6m!I6ģ4w< ?ے׼}|}_۸>\s+=<tuքnrwM}Lsg]|iޏ&Ǡj?ǫW~4NhLr?{e)T߹~7%n?׸~t%wezGOxK܅hB ~NGxޏz߱+Osǯ>x5s%}4ύ_?5w r}tsۮ5K$I$I$I$I$I$I%�-t endstream endobj 248 0 obj <</Filter[/FlateDecode]/Length 360>>stream +HQk1�= rЁrgWԮSNCh':{ݦ>~䟄$������������������miz2YJѪ/nyI5ծٔ0zr6uMeq+q+{h>pZnYYU"{7f'ٛ ^^lc1aa2fmS'Wr_n.>D?QxbT80?]w!qW.쓒4!<Mg���������������������������������������������V endstream endobj 249 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 250 0 obj <</Filter[/FlateDecode]/Length 222>>stream +HνJBa�t &9;49BDPDumN^H=ȁl�����������������������������������������������������wG0ϒs=z^\��qx:_uV;��8ߟi���vsz_NMR �j:!U endstream endobj 251 0 obj <</Filter[/FlateDecode]/Length 633>>stream +HKQOĝP.ADip&J +,膛$aV\*ɌL*BQ֘!*EM-jc~9p}{$�[]glݙ(\an\]mm��Duaǹo!#7 aKCƆګ>�� &Kŭ-oXZO��"fx3v%:j*kON>|S,aN Z -fu77/}='* \/Iwi1to]/n߱|ߎ}⽶\MqW Ƣ΢Ʋ:9-kanhٴg<qcC퟊3?VXY^/q;]789~j KyztʮRo.<9qXwmٳuG?gY89~j bPSކ?g(9Q;9;|٠SlU9;|٠SlU9;wXfj ?5ΆټFL3�@׈~�H71��f^#&� kD?�yg�t3 �n5b�ͼFL3�@ �# endstream endobj 252 0 obj <</Filter[/FlateDecode]/Length 405>>stream +H׿/qq?sV' JN4tam a8RK\?5qh;GrỼy4t{׼ �+5"q��y^#➧GRO�Q.L�|^?z ��")L=�|^?8ٞO�Y|zz��-<=:qըVC7�DI=--}VSo�TiDFk��_{?׈B��M��ț �7A$� oH�@�"ibOY��<DҮ?צ.twu%X�@\ vQo �[[9;ϳ _ �U@ endstream endobj 253 0 obj <</Filter[/FlateDecode]/Length 12656>>stream +HWn\ }}7r HkP$5UC{FrqxՓEzuYiMEif⣵T2JikmIRjnil-d:M*"g a.V .jmRuK(%-ͳL[j!f7>$UljԖPҼ./*3KTq AԚX6/j]jRYt]_j݊T`*BŇ̐TJrZV҆#..Teܩ{%SGl y)k2YRW<©`?[O&tY؞g.S +wx5"h9bV9YB5,B'jf}tCQ Wꋉy \iH Ho>vED�JJ Z(@:BlݨFDZQg�B& +} Ř\1G*\m0 DX=!]027d ual S| /Z>r c+8Y@ =e(hDb.y(;ݠAPd�XUK?ٌŨ\rmBxAl2@7Ā~(GPjb CM Lf#�4f.24n6=Hp m�joH?ݣ�/VAph6  7�='SR;bS6AGأϊ)Kł\*r 2QL<ze{YV`{.ScW0bW�G L}ͬllZg dґ`\!BD A5IP -" Dv40*@դ2 .C3' A# v]�xè,H]ӂ�It}Gh4'd-Y_i C9pGӈ; hRF�5m,cܫoʹV~qP;W(I%;%.S}DY:G#.R6\PLd4(pA�1(f/'k_C"5/'ΩHRs%sʪaJSXsyA hano 0P`BiYLgINѦ~I(3ďDI G_eLwc@##蠄 2ja1u+ޱk`N0xs2j4P6p`bpkJGa-G8SBvTl+{c6R$]JAE/n &&Q-ލS!tR_LOba]2tZp*ۆNR(3dPvi$F>j2XƉu2RNAlEFHo5e-;R -&ss(ϷW!:gckqKg:~⨭ҙ:I(q Gg]WGL>�<�)>|OS斁E!x +2]ObqNI^̎fm�0+:pÒd|z]8]D[C=D-`mq:.1M@}4F>/TЖuM9A+-2 wtJ g3 .}n0K䦸[%Aq( +<",+񘾙k+-c셞J iir>^` 2"1N a37J \52`&?=@� +>Mž;o g<\<p�l#Gn8>QN_|{}<Vr:z{,y9;S¿Xh o'ׯ=>]ȧϗ߼8; !>0g$2:b'>/^\< Gˋק'׿|s{q?61%o>{x7_"Uu*<.dlOnrz߿߼Hz_ោ{˟oޣde᧜Ψ +`i�@$o/[kX+=aE~z@Bd 2/ǚ< "w.Iޱ8q% WV;ckqkֺ7;<>nXpޱ*ǏnaXū=&q6Q+=0֏iPCÇ : }f==nqb'T>,q]GlG#xΫڬ7,B=s9?irѝBSoq՟"*UU1Bh;Ͳ +z +N*iV ?r^4s_qםxo\=^)$X RPw6˰smZBdS$~܉!-a Bu)e5mHysvRLw5DZZutFb,w5Tѽ*?}pn[ 8#N#p$^9,R �zwTQif/^sLR`;U]-Bn A lgr?10'ۨ{ߺeEW8dw ͞p幂)^p nPكqh![4F ` r[(%R:a#{}3hI09(DuocZaGץ!SA\hF;H%{aCJ[$-hv($_] HixS2ޔȌ5�̭=G7њ3Mj[iE|}!q[ePԯ<5غRk2{mqն(oCO h6䯸}}&4JseE{ImJ ¾Xa#3,NhϹ3DU'nҝX0>$` +c%iOXV +1аb< tӂAά٣@A.͡F 92.(p$'mLSxX6dܯA`*1XQQr< r|l ~s LZ|@g&37BH,%)Hx +Uf@_Ume W{\8%7jBܵ>5>k*<Ө{\#Tvp7-t~rQdP{OZ-+�=;k� jM 7頞%U+NN-R%Pc;].؛o4pfv#|c'޸?@Ɇi"g4\tܲt\^.= eg)N{֧W $ߎ0LF|uXU{g Jj!>V[@n%5.KO3A|u7[x VpoK8k0B"3͘`C +N7dP yeAK`8{t/֤}D}hNι9YA9܊[8$[ք_?4iihPKSS?Hi4haҀFsMС:C*/k.CL= zJ̉}{ +{i&hv9ߡҡnev=l%b38K{ V'5 +? |b}J[ ?� >}%A~ Э .pܝ/tqgà\P>0 \L'ɾՄO0Kn, J ύ\(lH(;5A}Rk+T>fXߪ?R'a.5>IZ<?ˤN0dDI _pypYy +H ; +g uz9V:p(Rob/~v%>h{4ϳz:{ \tCWLe'杈 uSz7M 9[w}[O~{oa%KBw4f `YPT@Bd*Yl.X+-K1Scms lkZv Uy<Ya)8BYWTA}g::!:?1܃ltQHYIYT,k\<j%h7yYGp]nd["O W5^EW?5AL^ JGc!^1ε GXOLrH$ +TՄנBmMe.yܶYoPN-Tr u\dcxZ/~fh7ိ\;DXb7D>|f0rAKWM۠f@(w m 1,>|YVo=#j eM< ?22D Ҭ! ˈ5V|W wQn[ld#%อZwW˰\ +[øVVJZf|j?n~S_iCݜQ.*&Ϭ�m&_qYwYLJ5bL eN: =hl,YVmKnPNvBQu ,JV06%J[$B<`Qҭ5OsHhS` 1qF}ŋ"qwfP!e{%=+С-^vA +֘Qux[geE2XrhhH۫|QAD@p҉> WΞYu +>(k1*thmիأΩ u@ ?PnS~;cWBZ}oV'ZnY5"2ݜ6Z,=G!A&hLΰйoC.l +|JQ|"ZV: ue17#t@4KVy1w`<UQ !OMDQ}ҷԅ +UWT3rJ<R۠8" Ҥhn%JЧ^ P+qm$_A&z^Z}ƻB<LJ, +A);7tbvYT;" !ʕ8n L6 ,BN mO*ixT9Djg3ec3R}݆$"q1I@K?%_tA .?>oӿ3w=~Waw7+֌l y< pG,2"(2֬ z ψ} ()5rmIWX'sZ<k=7*b^9ЈdC"]K6䪰l^C GI0Ț�G[1Ydj5:+ 2<VCi?*]eڐW'oyҮ+Hj9{u~JIOӡ vY QPקn`- +V\߀V7[E]zc+7_Cpj_CYlrk֪a!Č!acr n\纩9O+%˺R^ !VJWl_*KLUBovsckEȓ*|t( +Je.Ñюgj/Z(5u޼ůXXW#X !)[6htCkի!8:޵CclOLNv @}'-Q)@HBg;}2:L;j =ó|ORǐWׄR;H�] ]!T m@/ufMrlHU5- +e%0eRBphD:fiD}LpXpi"*'u _z_90 Ιukl^Wx ESpm2`ksLάt]3R|N~Uu䬆-M[Ldx38j C9kNo򨁮[DEjC8IvE]8o.p`W(,sydG#Yӝ; S" ՚pu1BS߿CK!Cv6b Zųjؙ' +\[ ҽby}<.l(n^ʛ(NRYŽ䔑)赸RNHIerّȲV9)Bz#` yb$Sx}L (SxYon:#=3.3=HrDRE 3=>1o~Oo?z+Mx;^[:8; qlƽnաCUIM%glYkcml^6uռНuT 5 !3; `# Riƾd$kMDhmm}*W yA.vW =qIC<ekIf!Z׺ΕT3 U$XVfzR;FR{ Y݊+Z`FWgK &8AE֯['2gu\.iA4 v^`b*U ,u@VV�Wj WHu]ٕs+(JDt02"/R'1MTՒQ{5RjҘI�it@hU/SdE;BeZ"k;8`iE.C yy@/Ja`80!CL"Dp9Xy.weАcg ) +IZuuoqRҝySd@ Nɬ[Dt3kRPh4uuiTn+_oEڇnNM_Ӽ 3_AIuzLl]Kƕ]/Ww`kcBt~xH"x j +o9{U[zKD)q3=>ȥR$5F\0ia&?åQq[g$5 9aY\g+ЎML ?aL.mKQsِ*ؗ!ܞaS0u_#ljҸ l$=BN#8]0[0%B WUѭ;?Ol)r iA1u٢hMO`[k_عn( zBa釋(5{v Xۂġr^V_L<1}üFyj}z뵥+>PNXĴ`hQ>֢~G֟$N4F4vpW6/y^1T:w|$0sps!fBh^})>*lo0c"ODhz|zJW9\Ďl]-]zifW77!j_ )Sy*/hD)y"<! Wd;)c]a]9V0@⺤ɥm~Cu; `dGHY+l, +<l](Ͻՠ]VƢ .t9C&xȺ4M5}�#Үe&tMDvY*(#˝s {:Е2@} kC^]Nc?qaB2tʥ#!ڍu|eԾ.5ʼR ׂ8^TНg4-C_G8> :ZMAXͻ*t1Ic:Z]jhLGhzDiP\⤬^+p&Υ[[i򮚬 yvԬڴdwJu!C&\/�OH8¿|R1~4pF*d+FFٝP?Tݙyf,>ލt/=?�EQ�#V%Ƚ(WM>]M8i@%]UdiƷɎ!^BBʘXbgLuK�EUT|QeS�K':җ!Pv'rKaK*eZ)Xe#Ѻ9a,TTJ/P-@7~&�_]^urU&^ئ"GE FLD;֚9v1(u7q<xt6}Gd_kV4?qbuS[>R(EHU2:!eRТ€~_<Dd% Q.`J"DURDLP,8o ѣbh%\5L2$_k*VWDOa1u{151 bDv�,.a+�Z "�{T"3g/rl$F�VXuX4ER*�'.Q녊A%W)J| zZg ]pеS)j]0BSEČہfِD¢K{SŌx:mQ t-V,e b +)J 8s"(W)F> %-rHv@]H,R ۨRN8Vҿ )`W 4 ;v?:@)F:)HhB]qm358.p2.�M]E>ZEiZY"1XA܂Ch�%nQf�SeR/'ЈGI=HNJBKT__Z![80N\hbEIm0 $!M lC4Ոا@C֨ lP*3@tlӈK6{fNg4s)�8D5~\Rte*2LAZ! l6Ԇe9D TDZA;&4H>qPQ@oylYIKh^9%曶 (nPtHZDmpeq�sl(Y.Bp%ǕWFӚ*tN;KbqPg>ΙBD"&$++: . +*s +࣊6B5(VpNPy 4!08Srn4,0[7&16F*%Rԣ"ŐDK;9ԣhXa?ՃPl eG)nِ;jl%"zCl2RCG$#$ύ͆{Lfk� ,TRk>dLmZA]ɦFln%lrzmaShv,?a]l/Orp~u{pg'4nSZ6to+Bߵ24#(bi`ud 34#`Fv[1]v*:nvMU o& B.VUWib;XBF`AY&6-p=b ޭ W1@sWfcMLxҥ]+A<1vCV>$4?e)2ᐱ%%]J[Cmi0~e< jFQga2u| фWSvhg C;T >&Ջv`HΚfWa 26T KE(F/qů#CЅ0K씚CH^ +`CV}n&Ը7@]6% c#Q +!TK^vZu$=q"EyUL/)S0!uq4h$n?K\tdF8Re rlByV7:0/j##BA2:XE񄺜şG<A-WchbM/oِt,bи] &hu_1 /ZiŚwbg,UJo$66=`cyI�iimEUvE,ڦ~I .ƤhOMTe1E_= 5oFj.; SnC9)X1 /d:G5asrIo$kΉD-l`B]3vi{7vOe6zy~,Ձyl N{"Jq|nTq~E颋q:-ǟy,WOEenGa��<[c*eОꂲ?SXJTz8L'YڟryE|s_biOPNSqf8^JOp1R,3Kٖ@,P3Jy|hMBŌ%sfgpDY"Nmtp@!wՆ g*H?JL(OEa+Cs +.NU^SBXbCzn+qw[/V1T}&BHnו)|~.˂0m&g|z__I>WYɷNM]&qi'j*`RYX4숅I} 3Vz~D4G8C H}D.GtئYO_. >S.z|.nOp/owB{%Oooݷ.wwSIܜ9!-gܝ~Nlu;8_ݼpunn?+ļ}W?޼8\׏!,/N~x|b_O.o_ﶧwwܞߜmgmmOwe*ɶE͢n@U.|Hڷ!%۔#%c1PpHI_ 'VB8>7=&/El0 .ތ",ƃmpQ1 oo# )pW%gW蚼$tRM _Yt8MW)RoY-ğ(l$U)CviKA.ˆoHW@/49ywy:<?__^<< aXLo_>E'h<ڭ&_߽05&FeL+6,Yn8zv>ojaZEȺIYl̓Zl0ȻUȂumb.$eB>M6 "!gy RH";,pٖѬYd֍f0H^_Q2�at _uu=|ra<:.qk~~v.sY'y?܍Cx2>&8<NIoyٛMnؠInz'aakr1 !uzi:u<tΧ@+^d�ηpost2N"L^^A;$URJC6_zt6Oޝfb>喳iz3 +)_M,}gt_~Bw_.<$K�z &WC"zBȫI`:)' R3˚,{}3?:b竈]WGUµYv|:ƃm9 ֛{vXH'y#/BG[(X{H/i\ή{β1,3=̯fqw4k'sZVL^a +[n?]EvT]pӛ,침{[q޵Zs9kD [%8m Yj#(j8y9Ņ۞s+KS3 kzb i9 K`3UlW)aC!ZD5NUMQ5b`sܖvHu*7J אk-qM!ךs;V/D"xהڨDpMS`C6`k6V*Ȯ1ؤӺkkXC5Xk5-c!Eu52JQGv18W%*+2 +B-YZΈRi*#:kVe=L\R!bYURmD!ZCm=˪)uL9#3 +XN5/9vHjpg- ,E5dNpV]R!fiTs9JYsJP'xWXkz BźK*Q&`sN%ZZM/&EU5ڜW"Wȫx%WESWj3YbgҺT*cl&l[TJҖęM1)d%k!،s\kk +֜kZȘk֤ ֨%Z{5e5ZK\ȵ-昌#л 3KJ-  kRP#NJX<1@n45%M&(nkȵfk͹&fl + qk]5pw)Xj"Cm(:c@MtTzC*D!lQ[sXř,V +Q[Is@\h\{:`�t" endstream endobj 254 0 obj <</Filter[/FlateDecode]/Length 712>>stream +HOQ |.t ]j*Gc .Ll +}`myںF" ugbﰷMމ'9t~9�N=fTJ?OT|!_{_ ��@`Nշo ���@'V];o3���Љ~nmn6O[��Xm���@'3��%#>5��^={:ż]���tbwX_DK:{Jz/4찬|MMkkaV3X*G!pq-bV鮀I]*ᑖtYMMLS/<</?> 9ȡ_ٻx:kS(sͬJϟ 5HfU7egNUlj,T]?Ts{Gzj8#see W{ޡawϫNjcR09We 9Arí9js{XVv1G]7sIc9G5W$taw���ż���Ƽ���Ƽ���Ƽ���Ƽ;Meg���wc^/��]k@Rd���.5];d|l}:|`���65‹繙w���� endstream endobj 255 0 obj <</Filter[/FlateDecode]/Length 770>>stream +HKSq�T7M,D/*讗 + +^^dyQ!B*6F$a9<XNV_tegwЖ]y~xy0#G-S^LӮ8 #evىѮ;<���L%7ǻHSH��kT#='g|l���ٍLTWU|.gƩ<(^[T}|_joOHb<WL'���KL42MSrG9?r=Oz?£-f��%{Z+.l;Q XmݶRWv=4���v@Gb6���dOc [SS<ev.&��Nlv5?Zn5晝���)?`%nv���=7}$7<���HԷ?`.WZh<���HL4B}s/ZQH���H,+{Z7V%ym䛝 ���BS +d?{\d*wĵWupٙ��� :i) +}(cՓ|,. ���B${Yb"ɞU;<ĵٙ��� D\ =(Xq{j}f��i^wװ?`%q&_w �� ud/;㴱?`%Q輈k/&s��KVbΊ-f%�o endstream endobj 256 0 obj <</Filter[/FlateDecode]/Length 733>>stream +HKqYPZ #DK ":jjmDv(sB־~WjAl!{!;g va]އ4 ��W^}\*f W۩h9gM|{ߵ#vbxc-#.���w?Ou> ��@K'3*˳ce��=!.EG XV26.6���Uvv.?Om6_rd��,fsیJGȎp]ٷ��hӱ*cq񮻣Sy���ZK0^EFfò��㉉#2^ui/˾��@'5)v?z!xJmɾ��@'B1]F@%#dnl:���t"WМN@Uc4t=d�� ]]6?F29*F���<jbpР?Fycmo��j:fnF@UC<bfl_d��R{In2*isڦc}#�� +PY^zO}&��7PQ+5돞@gnw��L]+ʚ1JN +ʾ��@er*n-]/*k(o��#� endstream endobj 257 0 obj <</Filter[/FlateDecode]/Length 1301>>stream +HLu?K?ôR3VlԜ""rl3MQerܡ-;@SPZяY7?}2n-w_|?}?륔tUv+/Ϫ3Ï9q3{ﺧ}payI}��- лGRі3ONz���4멩<|ODR]i#+��oMxZ=Y {+V5ܥ+��KgpЛLax{��У3FOj3kv9/iW���=YS+/?0?wo-kbz���܌,0u?c%5/��?&9k|j\9|춟uU{w iu��$9J*W0Q1絸Wow$k,ij.2x��)f)U̹ ]JKQc^ڦ��JFJ:N)UG\+s(Ku32)ua]_6]#���M}Hԙʛ$g?0P?6.u,!ZKR~oQtCh} ��&y(Ir䩛gHشg@o2}r_dQꨫ껒iZ�� Ȝ.(km9}e0ӓwG7X+l5oU&G^ #ci8Z=mp~:)��@hyiN7ovwj+?1g?,FCBvbO;NZ1(k1MΪSkL-.˲MyR7Ng8+1O ��F$'8Mrӝ %yJrK~ hh5(,_?6\M;_^ cIAHYU}Jw[/ޟ�� ~-yt6g7RF?'u)<Ȼ񗟽\* gI���֊ aݳӭWfɳ5M[モd_2:{ǵS;TD?>_Hc���AGPs_{]rRtz{?PF|BX׷Ӛa?rkM UNz̝ƕyN��`(.|T}i{3䩝 bbd:\c.ݗۺ@]Z\+łQKNLy`�^-t& endstream endobj 258 0 obj <</Filter[/FlateDecode]/Length 1560>>stream +HLuω2R( +ל,J3a?, f8( !r"~QA6珒?Mx}뱽g{�� +V_? +ױaSȘk{X6%b9{ք$ͥ[5`լ +uIUWriO_z}z$g)1S~?}h'���L^sn kk\iJ x޹0ye^u{3W8m(<5tB=-k{&SM^ը͌#���Ls3lI4LOSOQWYeQaɉy9ju> GGhN\_l|i_wB^a*l}O ���016S8uT|IꑶuT![?3uJAU]Ww6߯ +<=ˎ���bmDT:FU%x={٧:E�1c?h9UQk6+c :y{����:zG6~zPh LDX'g-qg-絽l:���`PP4lj K\N,msa�Gb1-r1^xMq}h ]%>.���o;zGʾdLЫΫFUoa�GcA(a#5ݮ?S&v.E2oD+>/���7LΩA4S˩<aԭMxQo5yݻmU%J���RHCTNڞwձp$R.t2C=5;߽2{G���U1? zM`'S/a�fy%ޟU+YME??c3g%}f����)mNΠαl!"#$[: 8GMAK, 3Ϳ  ���`_殹:cX<lKr[ 8) ކh=c֦W]HK ����H]C}c<Mq zM Rp$Rs2=wd,v>΃weϗ>:���PPPXO7!"�Oz LF9кs,|N +;2}v���l@ꠀ}nRp$?hu9;^~xC:���ơI.#g ㍪_ ׊f.[bbf}~���Ѡ~7;=:#ˬՒ5p4?h>9YKM 4ުө:\&O����u ṵiKC#uSa�Gb&x?qG絽[B~����#ABB3ksw�{p$?i\ەiצR!C���g_�F/6 endstream endobj 259 0 obj <</Filter[/FlateDecode]/Length 2127>>stream +HkPTgw*BZg"d1ƌK'1b4 +" `@E,w+x f&@fZS +~y_vcors<hDuJQt)&8ϟȴ=vQYhBrXW^z֋N{�{ߵ% û~k4ƛMd\{���8pnbg?y?w%֘?ٰNj>oz^8">����<畮]mÎs8`�5e;z&̞OןL���OS8\-71k8lSedZnjOIUi3=DʕYi����}rMr %o^ضb +k\GkK/>y|>&����fr1+q^1/g\Ӟz$? +k_9ZTOw4=EˈZ}17y���`*7i)WLˏ鎜kR>t0p֜?瑢Jݱzu9zbo ���'Szg<#<jE5֜?i77a*ⶽ[����'~)Ű?5%֞?l|Nj6%c{i:MY���#!\_;t5'r\`p=pmWe֪:g=���ٶFs.0+_8$[+;a�["1s{q͞AcUu2T��sGj4EPV18 $JnF+ LEł@3]L"���h#9sKmy%!dY37a�["ɕ׽Qcgzzc4e f$���3$䐖{E(|8~Ɉ58F#uYgzmJM$괊E���0B,+"ECB|Ź �OF+&?yͺwrF[{~P2e2ّ9D.JcF���~;~'uMnn4{';ۓУ~-=.}q\\4ل +輤L?9Z6}s=0D,&usv䝾z:?`2ஸ5av^��Y#><h~N`{0'tp?e8l Y-mX_Lu9a7疱B~Ĝ?ӕ+;>DkO{cLPE%s=:J;&K;O\\90AryX3KԖN\釽Y0EzܦkN]z?2pa +���,Ӻ+$ڃBoQU^n[w5g|.v2޶T7c/n+q>©|=ۄpѐi{T++gq+pNἒ#/a�["r=!s:\Dw/ϟKd>}~s^g UJ?Szz>;t ��9{V,~ӿXӨC®EکC'WGtyFDž_y`~$~ޜ7V!UܬVJ?ֈ=peTUQ3É57i�/?NkJPݕ${ %]YOeE4e}셳^w��>x+W)k>y.Uݪ#s_%i(^)6t?|_xɥuΔ^̨,<$VVi?Ǐ{^8U3Qר:KSd| ڟiZQzu}>':UIÞ^'Š&��~M{{%M/8ute5D=1yMEfjўG;ӾѪwLwm'|ݷ6a�apG*7mӺϕj+zVKuokMqw5n%>ۊ[qҠO�Q endstream endobj 260 0 obj <</Filter[/FlateDecode]/Length 2615>>stream +HkPT:4&^hVuڪD! +x * o /E5Xu]~Yqݨ5( &hDSe06?g9/<�A`b=y|=ȕ^?j3@7lQv+ &FYۃ>=u} 3ɥGy(S]7¦38cP|? / 135)TDɖsF_.(男2]:e`wNHy:W-]*ag;Lfdώq^g g¨ѐs%{yu\|SRW�f<<>#5bż`H(3(o߳\dCV$9aKxl9u=k2ΰ̜ʮc{b(K F 䙒 S>G  z Ȁ@QD +'QEwmW]O ++MVlH9,27盪/z/cY ץ1q}Jaz5>C{gS~Nr_ƣ.^Ӷbg:u0a֌Nd= +AZMipk<ܹX֟ڒ)+cN|6μb\GuFA| ,~[�Q=M +í%&|"UqWx  v sqO8f~vn@_w蛪b1yYl +>=bD%?PiFyvYO}�xUSݳ|ck;A"Y٠$zmK)n]{us_ޙ\M1G:Q l ԭx' +X i{0WRvŎ?rQ! l#FBRQfN>Ҍu-cYY:L/eK?وak8�CbZ �/K?9#ߨ@)^!sqrb=6A ^߾$*:{*/Z{(;1`.a*"d˙ʣ$h< 5ѡfդ6|yh韀P `=BA[ciuWi[_lڹoX<>#3cp EI=o:#xlh~7t}G 1ￊeoS|O6i͞d!,yu&A"|8m%NbdC|T7@&zE,HCXA<=`_DkZf=Qk^~Y?j]Ga0sjRYas [ڋl{z~ϳYcWڻ1  +v  5! g{Y~g]3qڇCXg!:{j4ɗ#kd>z] i6sVU|=q# }@`!h}ʬ6[e]LdS�d- &K:Q ;l2VYuI{F&=2w괟Dx/ړQ\�#XU'{4s/>_DKSIA a@r}qžu^} w5#=!auAX 9G/4qnarA^y=|Li"W-kOv]xWM"zm3!B4ص/N)A2+D?TK{bz!va?ͱ>?kaq#ڶ k"C^wrx' +X(w?Vo+4-87cCB==ze^ *�٠i}^;>gW)f0eXgptVO}w[bׇݺ1|4oY{-J)쨋SY8DE ~o.Aх FH7cRN^,!/g;lQ7.JJFuهa-h"*r]Ϟ2E3gu{j,rƶ-ɖ5k} F '&& +^ AϢߚtkч;j/?,&K ֙aM+c^3E[�awYC98'Y{Ի"+{ҢR3%113'Nۑ" 蟳&MC_ )̑CEm)9}asuӇYwE?T?q1yAX*9uZׇvWv>k8Uɠi1wQybfUZ꼬83&J$y{!'bFx b;7?GO;,JcU,buF"[81=;G�awYKL Ĭ]W@&3>ٕOX!( ]pfPFP=; +F(#(JI3d1hA$p[aP9 +*OI* �`Yc endstream endobj 261 0 obj <</Filter[/FlateDecode]/Length 3798>>stream +H{4{ :mD(Sh̘::EDCWQ1AD.i0۾$nt픊ZgӉg?:cMU;Z?X]]k?~wV/g)#;5TMv1{L*Rydk9<g-?)ci߷Fe<;y`5@[(xY7rL^s^Bφ'M~w�A,x=䢒ύ_ Aݵgj%F +� d@#?t۶1VSwv}^W]kVLY;\V. +ZF^ 3A @'GM*\!9W#ﲏ>q:d>J~7syq^'i?4#:6o?ˊ#_"bJi>8vf\_*j?i+_#gNy4;=:qwfU) l >ӛf.KOID$ۺZ}i6\KҼ|YKѭ@ ۝ְ (pHM޷#__vno'/s{U%UߴwH +ۊ3d) "bc !eYi2Fp./irYr_4] w%LEΎ<e:pD@e6HoNJ7dgm폑_Dcم;Ŏ�cr3͞V/R6L?+NIt`>AQ|(ɿ&6RIa[_\JiqhF.}w^H9%,^A@?Y;~~#�.En>}$MŦ 7<|F:!2Dh3vsWˎ,̖ID}rXJCOr3al;@I3# iwpDgWj̡acb\ˆ&7Zޭϯe/;Lkp߸fLee AA3f;qwaqFJL¿ؗ PSП"yGhn+N( RFt|Cg z"uXJMˆ;bT-1${zEsM@I!(٠?^l.`7wȈe9qȿ7 e[=]aq[T䮤Y(]Io !v Wu͏Vﭴ ��&?+7Npk᝾"}?jQ'ge`l`i_MְY,&щ?09a] D& 꽺}Y=[X}=I j(AYlwpEQ1I &T{�jRSNOŃPbޥNb^>^?p (Po V @.PR}uDᨫ]f{<<F 3fOqR{ƨaD*v쮳Hҍ�963UI_ #2|hwpFY ;4T%=FzV6yڰִ9 jU҉Fx>INe, Eb154m& TQUV/ށI #L9ZYɓJ +ݧ{ E;ky=NZO!^er_E?çy[E@3?ɥ"ܕs s8p'g2?K'4o~AI-#ٿO$R1,'5"7>@P^fuV9ƽLMUv f@߾]Ŷn!B&_]Tsw_iòq@H~'\ˤ]p Ev  Thg:ͱ`� 5'4RyRmqӮLፁLn(M?p(>!+khk2@>`80uDXh<Y-W�}ⴤB?+?sd[<m]hLV.L@V{E >S!(MSO6}dVwvHdZ{\t#4daD{T""*Gsr: 3ieV`'A;Z(٠тvkV7AzY7Ŷ52Vn^<${}Lv/Ӡ( J]LQ*. FGhk)UTqPJ;"IXB@ kB,1ԺPp8D_!?NuΧ3Ͽs'۫Zؙl? NP5@Ag_GڻP z{ aU P. > hKw=9Ϯ_Yh:WrF!m{?rtj +M,2=e(1a=OjsKROp1:֖*"x#|p7΁,o`% sHwgAQfjL)⿼:E֊_{b0S<bٻ7%mZr# ۇ7@փ^kBD2(%5IwA�"zƪM�HI|ʟbݫZ@n΀~󺾆vMRo5 +ٍgZTY%|잼CIkS}p "|LdPȐ`x^ ۴Y֖W)^!kw&V|ȯ8;Uhs3zqlIZc6>q׮/wjOuD!PP/`+ڴIb"֞dٞs "9x} +@)5ޔWJ=Z}3;"uUG:ټbB-^S+rTJ(9 K=Yh\+z-[ 񅵞`| +.Sexprp|>  :^> >_9<p.8yUT~DsVf4=< FtNjI˪o� +כr'w ^w}N6с +$s  +;u ֻ ̑|@I v;,~L'maʖ6jLh|dۥ۟Rv<_<s?.\֮QH-Pܤ6 sj*,qY~FfY^F <5/0x?suD'}c}?C7<X9WV̡mN?ڂa7@M(7�|Y?c0G +X{$I?d/Bv,#I}L[gەta��~ k)xE-:s'[uK`kSn[p|UW{M2o fk{s3j<Яv_bB_{E=%G=9dMWI:Z\�j Vɔǰ c=c 3 +Y{$cS3ѬwAAl1"|A;X?yjZ);�op endstream endobj 262 0 obj <</Filter[/FlateDecode]/Length 891>>stream +HKTq[E( +"jcAETP JP")7Y,4E(4)14sFGV`[dM-*(C1hBZ5]d8'>~p9g�k-lMQ|Pb1g-o3k61Xg-ؘ-ޕ=��I1{`CC6k?DtY[yP�r9 CL후AbN-oyU{�M0=}?=VS_�/w\ӾEȼyM;g!��wߓ}?;V g!�� wrh"BƎUp\M_"oX;G{�5Z;G7?cpX}qS{&�XOek B+Pr~u��Ǜ 3 7έҾ==VU/߷<О��`zk.l{ڷCnqЛ?�=;e-3\viA dء,K0귟nkH��_ܑ=4eA dءݾw<<?'�^̏о5L,v+ODͦo3��1ܕ-}H[Ab!ŵ~y ��6!}=VƠ2ةt{[wr��[WjuQ7NC7[=^Cn�=)MӾ-L.vg{zjN��05p׵o !(++huTП��`rd{\=Wo +!ܤ!3�0`�&s endstream endobj 263 0 obj <</Filter[/FlateDecode]/Length 1210>>stream +HLu// D-jrǚǖry8tt2$ă<;~~L[Bma '+Wr!Ͼ_y$NÖLM6v%lF\ϳ\KnJq'?G�@pk_IBfKߌTZϳ)ҳ��ڱ5K~ }K?Y?"Yks[)��m ;!3^[-ZGL��`zWJT{mQ7G#Ҙ힁69K\��SS{Z_C7GCYI<=/=[�hn+Vv2DZs6"=[�d<Mp[GԾV{[v2(?-13��L;=F>L-ҘY'ݖa ��&:V7ه1Պws| =g�+G j?r{o!M5vHz�qj/ۼ>o!c+řv ]=+?7m8^z?.=o�лQ[j˯UPFF @ֵo/|GIaa&鄻qS1[gg.��zj?K$hڤ[۷/ :KEas��dNO}H62/_􏉢WiWsZz�W&6fAJ""^WӏUN;6U^Ŋ �p0!LM. B̿̕Y]"?&ٚ3]U'g0��z3UuZc T?HDxxP%'=Cu5t}k;m6=X9 �^+K^7JAnuVgP߽AM]2Rh=͎!2*"bڿEڼ99V'=�Ћ+7jKAnuk׽hakhG[-7U+ U'I$m9\z6y �ݷ%c7=J�ϛLi:&Ĥ^sl4J/�D7 endstream endobj 10 0 obj <</Filter/FlateDecode/Length 595>>stream +HUnAW<%!"wAQ}j^g9NS宪Շ:tvqnNRcѠ¬%g,ĹՒ>ջ5# &JR4Dr +Q(Ir!l&L- 3yh<S&Pe<ruHL]lx¥; ƕᦋM1L4iSMú{ _]&L.5 _Ƣ]>H}!4*Rfp(㻺ˡCH\kZҺS#[woQy us=զ;w)F2p5p׊6R9 I9hZ#ޒc‡(lA 57If#Pϲm#/ L +lL> + $Ah�G+؂7‰]fw[gHQCc\8[` ZC3M@ovԁa,)0vFL@eyns`$+-oAvLwvl_^O�0w endstream endobj 11 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 20 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 506/Width 52>>stream +8;Z,e0lk2d#Y!;27FEX@*[G#`h.=!,q46t`3aX7bO=b#`6leCYd<LVA59MqGIqn(N +Wbq>tcE`tDjjV(IGm+3TlrNt(*#*BZ.YA`Iq%01umL(`ZWi;+L5n5u=koo*:`3Id6 +la$[A0KHe4G@a'M%e9@l7Q@JcTo/V]?D8eF[b&2cQEuj!AZ>CeD=.r&(m8F0(-Y&' +EYRPiW`kSIa>g@TAUFF7ct?q!\rfFBZfQ6.ajXQCKBmUXi`17:]nd3XWk?L5MfE]I +M..G5H'3T;,C.F+:$6bl5rb=2;,pe)p[>4%D0;km^`OV=Se1ITkad!F3nM&H<n:*+ +*?rS8HA(Y>gZnXBb0s$u($`t2O3l$EWX=_1as*C;$[/\eR&[b>iH$^GLqRfrBPmJ4 +ZKRj'aZ)IYqd)QidmF$>7'B:QQE$$EQ7ao"Lu#f_SMkSGF)Lc-Bg0?dfJ\4Ie^pH@ +`YfJ)%uf^De0cjsb0g%'Zb<e-'tR)pc63,q!/>X\Y5~> endstream endobj 17 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 37931/Name/X/SMask 264 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Ho�+XYMiF- Lhmn3΢e9XהҖ2[{-01񽯶7B_ ;OÍ[{?~rNsN*�����������������������������������������������������������������������������������������������������������������������������������������������������������������_5S͗39rz֪��5+8yտ}z^Z]K ��[̻[��s[U31~K&2��Pn<>ކԅ]ڿΞyޗ**N��?ҧN}Q ~g?]޽"CNl;?�� 3#r[ޗ/R��hXWW?rϯؼ-TۦGSkkR5˅B!D"Ӣy- )dž,Z<K&Uӝz9B!D# )z^Z˫?)arh~iskkR~Y.vǝPcBō9Ӣy- )j^6g/^_To+ُn7=tW–9<w|Ը<sԸ<Hk$_\o^}cksEos;f:ˇYԸ<sԸ<?M޾뗯Ld?0>պ\>§AçA,|j\9|j\+\>Z6ŝ_05.>5.7Rg!��f^#$� kD?�$yg�d3 �l5B�ͼFH3�@~�H6!��f^#$� kD?�$yyڸS�`B �ϳ|?_̌\;��>AHN�ϰ|?_̌\w>��Le $~ѱ0;;%�� +?I׬Ms<+ �O?Ia?ko_0q�644?F�@;q|yP?��AH��f $�d�@?� �lBRl޽'�:!)۷oe3VΛCf��D~5)ɟmzt�`Ry lJs3O��AHJsӺ&feg�@AHfF}0-��sgsK;.9 �̦WW.ױbS� e ,[9�BB�O<9߼F(��v=5Ba��H6!_@G:gU^*{}6džwʢ?3G?=5ǁ;J#p`[>{EGCۊEu{tn<g=N>_Mmhh,znYM*bQϷV;}A{8r3lQ|RY{{G>sw\qok}MA?`@tQ}mGuxㅱca{D~<9~hWa<v];9?a^*8.H"(HF(2 h/"PHhJF!W. Rds!nvlNd Eǩ3-v:Ru_v-K%{Nyv' 39<ʷnwx{$%yC*,`dC:3Ek84DX98q}77{f1g{ELUaƸ{}W^~aA==Kt͡&y).AopypϏHΣRbgos~ۡH~7C"mGB̉,}?KLoDM\Gl7n<79U|��/T ��kP 3��@t#A%\���эp=��D7bŻo5s~;\���эX.?=s��kGjXD���]5Dsj d��kv='ו���h9qe\|5�� D80kc=��@l#!Z5+saG���m5D'zK̑ygT뱃gmx=&>|[^[?*L���KL&rŹD}gbnWzc6{�� 4ON˥ ڌOHЖ/ozmsӵY3;?Nۥ4���r;;? Vt4v?r/���DF4blj>1f���GPضzp���`PkG?aX!{��� VV@%1`>[���m}"? +_h;o8���D>9Uωc^ ���ƍ=? +:+"~X1BN���д3F|f1~Ci���4V]F F*|#ic=s;��@<lvR4T?~qMN���д~y}!'&L��<&rYVsY"*/0L^ò��0¬q"<s*si󆽮j���QW%r*oY5 vQ^���fv.X]"?[_.{/���3`8V?ٸgx=ɲW��0Sg$߻dѲw��0]/ؼ=4T?F,/ 5e��`FœǮ\Fj^���̨OCCӗPPT{p~!{7���30+PPc}î{S^��TD9L1T4Tx~Z{{sr��LʶnPPcTBἦ7m��xWaqi(i!OT~���fe??`^lo��LD*W/@UǺY3d��` +lm}$T?7w��o=QgKVi*XN܆sWsC��̠a*XS~OQ���fvTs90?P^C){G���3,TXS[<Q|:3E���Je5EPY1x;vL'��˛"rӞEB4m8-M%��PqiݎEB1է.e{��a\un<FJʗ K{��LB[OP]zMxgf^��@I?]o{` ?R +{?`4ٻ��pQA[3 ݗPMvXs]��T}en߆b&\SsreL���*sl9u3wZ~4`_��@Eu+fI "+vIK}N���JY,1A$#yT%��@%'EJ_:d@51ݎ+{ڪKŊ#{u��$rS"W|sP9D?j=to-W=4b��bOnkkS"W|utA"gX<`ږi5#yP;d��KO9\M;#0HrK^g5u̢׷|/U)���Ą_AQwkƣoY85Cc#EbmQ+b� x"(Ƣ *r˳>˺%rF!FQTQ|7c]da/c~wn~zŌPOՇ2]Qga]?F6_'<Ӽd-dؒӎ}Z����6zR?QGQO=>x"s|k_/Ncga߲=����lY| Mt{US\Ë آ?ΒQʯOgZ0fs3f8N˺tf#m;)���@;u/x:y9R}b荤1=c!.x/~"ER+ +Ϙ# ;jW4K=L *NVwr���l�Q'=DQӱ@o4H^9~׷#'>cbz}aR}ġg����HFW$%~:ɩ+cQ^bӔ&]Zz����6k\7];5HD:/eصB7fß.ܫH7 wZ6)e C���l/7~DdNg(5܅-xx~w{^c2O Q-cV};ܒ���5#k.o&:SCx]2*oTiacSZ^,xF}ނ;���=[-zDE=13r2 d9' +gu5v[&Gz;u8OtZj|ܴʜCZ����6B2d*o[kW +ҕCb]͏z;deԏuOhCgEBMsW4?}PhKtB*%~ ���`3R0P+= 2l-/&NK/1>5)T)6q]zceQMvUmJ>>wj~5���m泦O}q>Q[Oj{Qa�[$=B+McӝC~&LsS|=>nu����d4y|nD6n*Wq734B)Л vi]ޕ;}!3<BЙJT+UG ̋͘ژ_d,0����,:zGUϠ~gȘHwz_w:"'{$mk|,<����,:zzq_=ILݴ!36'=?ֽ˒4\/oԬ3}D"k_���o:vP ĘVӘɻF7=?LZʊyf39־.���IyuNE@DvyiZ?t㛺w,}Ò#AUXL^Jvk���Rv> jGnꤏS)u3QuFW)xn{m ���`ou ͍CEOZƴ*yS['^`Θ]*Hh?ROk#&[����?| + uaPQQQ'=1AgE|p*I3H?wbk_���G_nk(3t=+N.ZkXO St䥇技s^X9/od{���DF}TmaL9dǨX\Ioh?--K"k_���cgZŰuj5_QQa�x:13[k= g*o}u���nYl]PNku7U[a�{bN2O+Cʽq|�k���;Tq?V6uOxn) +sC62^#X^z>?I#E.j���:V~PP(5܅昬1Awn4 /m���#qߞI13}=?n*`O̹ b=o>7,/;:Z����tI'nhpΡ b=11YL_*HџS++M}>v3����k|ϚNCAb-uΙ{6-w[ՖZNZhg����"SI-;S=1xVoT?5~i����)uKg-C秚9;?�^q2^Ѭټf3CED21v���@gIں%Y Ry=11sT՟ۦ4ڏ���C)+)~ǴQLZjRꌣgU6{cu��/坅"!l`E]uVE, R+E5H Eš0a + 0 c$lPqo;pnL‹s̗w !=[z3 3\5F꟝ M2lywKC0Q*3קz!B|BrJG {|kSB ahRrzT m>T!BHa_?=SJwe2_*2idJ7ܭ&.bRB!u\1M=ȏ�<O?&1: <SĦ߱8-+A!Rdk'G2 X3$`@A&J{wc3D B|zǵ Sz3 /$DλVv4 cQ+{oL[ۧXz-!榎+mWzޫT] cPrid҄LzK.}| @.dHB!2b"g\BIoV!2dfn4 U55̘<{NMy.8EZ\tPO Bh"9DZ̹qzNy\4SWڡ?z3T@{ 9M*2kZ +=֡z7!y֑p|2 +[H~!9BoA&h|v!.bRB O$t+ +$'̄i*Ǹ p[+;\EzB!4̸Z!#}ل̳$[( ̇<Ɵ4ĥ}r1Br.8z.!9X>ݛiǒX/w-WiϭgXQ"B ~)n._b<=+a@A&{r];gܾ)cI\GBoF_Gƚ` [` 6c㐐1ӲO,KN\J9RmG}.XK1 $|ǔȊrn4Nu1[!j%\qQjA+tŬ,nfy63&wYQ訙Iaa&a}tݶkt�lz;y ^;Bw`I\GmI !+i?CC4m[AHVk03zM [&FFll\lgN.@zC\Pл)ǎG9B{9;'zv%wkS-Օoe7|#=M>6xdWS-^6(:}־پys)k-*_9OWb5:;[wոQ羬Gq枦Mt5t4D>m=ݵ9RJnk.3pZ{)瑬*t&AιP6V+ ޼EaΞ-,А7BÚ( EFyrO 77a=rZJ2dpG&R'v0Mk,]!K3WsΧQ7T95QW$w*'=[iYdTbԿ9sZ,n&g�u��D~��} <w�H_yGYc/}"5<ӎ# +qCwC*T 'mHo 0ڱsւB8 ̌A_.4u%IPlhOIN4Pd0+G{Mp9/-.iG2 a%,56ځ u.6f.)W r|VL?p=$Yʴ+Oh=-!=r?.l!H*| 0�omnɎɮۋfTrڭ^*lj +;C}<8}ko'}Q1Nv3ǎLom5`ZYML 3$gYd~$HZDeN4P! p~W|w_}G]!Gi`�ƎEς ˕_6oP/oLӢ"Ws{Dd Q̘˔a Z#ശ*ڪO:#{<^y<tˋG]u3I�`Pq~۰\J<��#�LJ;3{8vۯ,E2?e*֤FF8i&X` 0z a}|u6_l+ )?c A&G*=(J8lBWhcM`i~rur~'Yh'#K#8BzZE>4#hŨK~5yq 7xpGe ^uwkx*"(^QA<�Ys9$$AJتZ׮nRkKיbgwG%|;μ> �o% יc3WK�rߝk#Wg7}q=ϛBcK7s=|EŽ:+J;Ywt)dܓ'DS3aF25EyU}.%aݴ MS.yFEP>մ yG!5jrp-:QGZF-N?]gHD[ù)l]*y"Aes~_# +Lg�d�*z z̡(zБnzRE}Wk <!""MJ}@~ܬ.dH_$Ļ =p`'p Mi;kA|C=y8a,ڎ&ԩqKw~ qy!Xccp< <hy.bqq@0Fv:Fs<yShҿʗw6Tx;$3!sO柼}x?K=h%8[o,oSҒSτ-8wO`ќ߂r~cȡ,+M)gv#ncsryGYSX;NXs:>2D Qz᝞z9_KU]HFhvB;z/�w}`!�bǏ"z?骋޽A -+b`6; vpq&+ۆE2F?mCeP\AMrsxPTIq}f1jxnp'f3"C2u>D yד +pD-E嚩Z5䷽$¼!{-� hD$: :#KhDPA;3 JDnK+dž93')1D/Ik_T@Sf<ga0>THb\:ysh)|;.|\ο25C{!jIāz5P3Cv"6cҡ5Ph MP<wƒē! Q?l__ӊl2 +'ijM[1oN +P�Ù蹢['( C;vZ75 +3yX +D?mD a{-#?|:S,514}t0gt8g^'s\_̻߲~ `0w'� ^CN1nGʲÂv{L`I{u!j## >z !!aOShD[Qagw\>n{lt6}vf̄�>]û/r7av atk=Odo\\L<3fd+ 2+T|Ōxmh+?HKr$in{r:,CF +3seⳋ{g@v  x�<ʘ)|HI/}t¸W2J A|Bu>8�b~?Nv qǃU +yM"A%vvſz:%z P�g޾n(,Bv̹S 4^e M- Fsd>n.. ;".Շ0;oPzLTLr}e>]cČQlpA:ٙߝ_{Թd0 %o~7^40Nj" d6o]MkX}_`0ڙm�ʗ(h&{rirګ!e%:72.0)8ٓ{5}]]ZȽBzțS5%dyGYSX;HCs/]ptq U%>m<֞2Gn`ލp\:ҭYOdYd}c>%7xߕm"=[v<xv z8żX[ {@T*nMDuO�<M\x/G|x7~Ny0@3}`0fi P#Ģob[h:KG緫S2;hDSsyCrp$gާ�;r{ނ9z #~g,[ȉ>H)cxn+{ Oj/+U쫮O~_ Ù+Wmhyܢ Cϙ6]mݦ3}?,WC#h|6]u_)vFi͔#v 6u5e[;Z&Zdr:EL 5qܙ^�% + ~;DZȭ৞=4Iݧ DaX]_{PSw  +֩owGήU" Q X]Z@$$$PnxVE>; +'ӛֶrAf2{w@2Qq}2\2ƅЩU_UR?EQXKHwxuO +< jN>O/>(9M"YѬM_9e >}|?f&FQܽQF{GxӋ2[prp OfͶ2I׷ZbEQyrG񺨳"sZsxG˨QW.'@_}?z7T9T$rח4 =}ʒS >!{xo\?'4PŔؼ9#-^#.Ԥn:EQ<ܬ]a4kر"p~�=A^&oi'bnL6Ѩnݑkxg'|tDoKEAۮQN 7VĚ5ςQZ4@;THȃF[W*"aSz/Bȵ?E?F+vy@̍:xwf+jdܴO]!7ɮؐZeA`xƍ<%KIH P�EQt8fR74uJ)OD=gc6>+YRng$8hT=D qS÷#Ph}6O$fa89n w<:%�(4e" l{@xUm@/go|nz@fK  + 5*^Y^`}7H E祚ZLw@{ʞ¼a7 #;SP__c.GQ5'kݝY.^D{u[ >[N  ;|wIWỼ1X%K *nko|p(h/!}RWۖ2jP�n @^pq�_i@>.1KiݶB>)a{c\}p4Z2ǾLG2f#Cg;(,@Ƞ>gY^vIit@>sO@p^BX#|?dy[FujNW8|Y3\i&l1>Wy=s 1(賽\?TSzıcllhxz�CoTvVzLO5쏇gjB9H3M{N%Yoe:(g ̪i eo|ګޢpp܇:"?>zVzi8F[;[tߩo {D" +kJWg6%";΃NNW?/qUkhw?kǂ=!BgΊs9{wͦ=_>뵘ԫd͍91%FQD| Mi)~S/hg��};?AoMĚ4i`wsw̽ʅc{1G;Fڒi^ߑwj3lFQ7Y WQ#w@C߫Z̝- GNHiw?k_V'w"Q\&?IiY7z + }1yyi-\SJ3_ bb$ܙQ.ӭN > "?Пi7u>3u?G=f^nJ¨W*]$EQfOm!fqN}g #+rt_`Bn3CXdk*FHFٳ0Gs6glB +3 T((!2 ю &5,l$>?wڝcT*.jȨ6^Liq Q%]HE}zcEQE9:AФ8-+,1i20K !Z3N*.A_Y@˸?X~O{0߯?:0HH{ƲHZ~|u=~(OWEH7QhׂV!f<P㹵n}b=hw?r]Nj5ʛw[y;{=zea͈ưϽmsEQ}lu@nޑf+Ҏ�Lz3әm(o@OU@GX&dѨnl{Zw\b%qSgHR.;e|)(-!?7j* +sMpK;Zr![gUJdy[; +tL&uUΤ}=ЖZE{4NR][+͎z(]}"!]-:yiG U ړSMglR* nA?Q@ܥ a^uWhΣ=r*ԪoǪC&(jجߙ[jXHYC ~~iTƯ8J¦%*1Q4MڀA+5QASXDP0F,e6yYRaEe1b<MZs@L?uy]pqsѾB9ٽ٧Y&�ho71<ٲJ[Nȃ#\Jr;hh&7wzK!g'!sxth)N9^V)9Yˇ>w�ѷA=HݫⲚEڳ!Vs֩&#~w& g3BTS:Sp:|Ohr!F.$>=HNj #zr_(ݓ' Vw]C'`(Y"B}8Nv?3!nȈuq1hw+~h; �ϣz"7tBȟIm}wW3ht/m<B8p%X.Y cu$U4I4iSw�^q\m%7!yS:{]@f͞K9!p!L!{AsѤRpZCs.ͱ(.d8]8ȕd~ǟ fXwmX_bajJΥCuA!dgE$!Ws2n^k۬#_ecKh?s⟛q.X"�}TQl-I|J<f +/FZZ s4kb{B[BԚBIFޘ#YGUU쾏d|+>(+;�/G[[݈8_Zq3vNIc?Ҏ\dgUB&Bj/'+eسk˚*i?5ܿFApxz[qZ3JGHBX{7x9e0F9!p𙿞lߟ:^{?qSZ4̆Xֻ�Fy,#WD!ηWq '&O!J8Yn�|B8xC\R;SYGXQNۅY#k(J*U=}ֻ�F5$gl|~scQYCoqwr&JNZkװ5!_!1*NڸՍu}1Wr2>WeL붴/9?�e  ?VE=̌S]hhz\G}A!|syYE%5/u:z̯5vݎ_="9o2΁/c%J>g3KOHBpdN;o JNGux(9!3s%!]?}:}ѓ(d~gN=Rz@�gJs1)dwTGpGrG\Rknb9^ϺGU6Bڽ|̌"JN~i(9DA}Lb�=PŜb:@H)'iSh xKfUa[= \Qew`u/%q(d~O\}z@�RuQro 2rMSccOfz=*6Ѭ`WBGԄmdۖ=E^1?ׄ\ zcHzKR!ihϰpYͱߤ;Mݮퟢ{@!ԅtTodtѧEBtr6Wi+Yw+R#Y�C.vUqߎr_g\OY?5iMh B] JN4otm"mh/oߧn4i-?�?'Χ(7fziϲoReݻy)wr]!= "oBԄ,xtCy.{.QHΧ%)?�=? FQt"vU7fojwUEB8j:HUN<̲BH]^eh{|Uz@�bL/$ 3FBT7~f=V{t[}= PA#vƹX!1vBܘq.@08.ԘQ|{U-|/^Wew +!pqeT NDzqѢztyEq!Y� CALPZק{j϶Mp 6PfgݣjJt!AMC;O*ш]|[?4rD_dHX�Cewг]tܮϖ(ekÆ b2t!}3̌(9i%vi;bC�w 3a]+J轴n_'rR�!i YΫu]]?Ќy}6_C@1A]nN0%vU* KFF~Æ% ^J;ΏTS!Jwffj,M͈R.{Rl"??uy\.4I!!&i5`tA}$*. ..D +5ЌcN^IpaWxߌ31>3~M}Y?ı!N2 g9=8uUw,}Ej8y���NA@_[7cgKܜYdMC-Zev٣Ii5mwq,}P mOmwsAu2NQ=jPRke��jLD,zҏ>ĤV]W1wGM{zaV_wq<ӈt:PڟyHY)?Z5��jwr lYGܰaEj- 2׬ x?~$S?&?Wo*x1=~d{\3Q)e{��QRB)S^ιnjQ?-+(1UWMhri?c8'? $ +WY]Y|Bق+9ʓ߱_d3d27{[Xׇ* ���gѯ {~55zݝΛNO +7nUhrN;Rϧ]Оf}W@G3sTr4&zZR/W6rGL@φgMX_|B.Hȃk +3Ԥ4յmHs��q kݺŶ%n]QҞQ${߬h7~wOq Ҏ?%{}݇);c}G` c̤bUvɾm[G-Zy25w՘}?EW,5;g u1ܶEԪط;)ΦO6}?���<-BTI{/2<W&=f-K_'~;$ɟi5d\9Ϭa | }όt[l\g}p{[+*7}*ڶk6rY w1iN���xh'~o9va^j\Rqڙ[agv?Ib8` BJiNp c<+ls 5=9{K?&䟅S|VG, ���[M gMI|n?Bakn!g2"xJ$Ĥɻq}&M~p��ަ9υ#ϳ"DED _m x`<;<h +/e}��6u%iUB+Ǭ|<HYIwS;]}GVgDꁾa��mЌq|<J{vh7rcIiN/LH.쏎 "zWp*,��-):kì|< OV,p#7UV<)?x[0ֿ7~>Kc���+i";�KNFi߻/)Qhy* CNJûF7A]n,K*c}&��])P]Y7-}؁25Wq~GŽL2i[d.��Yzzu(\fz$zUs摟[k׽I\ KB ��@nV$ +]GS_tS" ۮ33��؜лH:Y?+DLxo"-Wl:hd}F��M9ֳWh߲|@HL2i[/J���bq%֋~D]gauD)j���lL9C,3DLꌨY]K��d;HhF8wa? _^(:le}f��WzJu"`tGFuK>ڕ �� Tdu~=^@cTfֱ>��J'H*nDL辥ɟgv[3ɓ �� 4޴Gu "`tgX Te q���yZh;](?1gCwE>��3 I܏u "`t:9|B*&<��;ڗ7r +hr!@쏞{zOShg:���5;{{p@ǤrFդ\��+ړ/S +r-DYa}Wg;���_?p2˙{}Xwa b +u +-ל��7͚붾LdB) uaՊ`g<���<Z9d/YwPa b +sd~iP-b��EVu#Nͺ S?4kք>��uڏS#Wj!@٫nT/e��Fb6-t<?_JL_}qGb&g6BSqzhL U&(A<a< (*xaD!mFMuP855#g~ŮoN,(hcp:c&x܎Keq��HQ5ix6t쏎1o\T��)_{S.JYNctU8\9K��SS\6Mɺ`p:=Mt^qut��𷫍o1Mo.N)RH��KP{0ktut:G7Q鶟i:Y%��'׿&"b?8yv0cZe��MN=S_tut:G ;pٽފSM��5Vtut:GݖOWå��@gRz5t{ut:G +K4*lGݶs&�vm|Wyat{ut:G盐M7M*��:T^8tsut:dɨ3M��eP:cp:?F ϭN$# +��:ʭI3U"|nN܄Z|p|/��*gg4Wntcut: ^mԘ΋_6Ζn��7ט&7tJeΖE��I5,1 ճ +I5?8_3*3MG2�ɪ쳾I5?8 ?1]{�ǥ{Qt ;pٽފS �q5VtS2bSp��^WJ#Ubni0ap:CFXBWa8궝7I'��<]c- &NcșM7M*��fa[nUtY{2LGc|W��x)ի̒J3?8!kzD;m�AnLzt;ҊsjMg}�n ߳r+7^tyD5_ iۥ�ݮԯ١:z%`t:G`H.1-Ww�6szNh]?ct+\e}Q%;acމQFi^��dOO#`3c:/;i[S_ ��WFV]ݖO\cUZu%DKl c�^ES 㰻{T\ ߻cBjTOa=]Pj;7V=�uļGKm ޭQ5,C܄:yP|��fax܎4Wntq X2hU??'oզ78�>_o(V߉7w?8\.]ڥYc:bwJܻa\n)!�@8<jM,t -7_M-jwsl]#gwui8޿ ZG��ިIbp}}{>m;1&=wfq{Le<۷qWg];PTtwwMY>P[0lS &�Uw&f. +n`0S_w?4H7;frd wi]3;@G\J K4 +rLGc|��re7l\ 3?c~{|*:YgWFsϲ?[|D�ud՛᫦bpV*{amі츇V8NQM8@O��[hg-nY|ms􇽆Y8r^dUK7 +� uUg./<sj\t��h.2{ך[cp:'WQth3�XɱgU_Tg[cp::^p~!,�8Օӓ¤cp:ZKֹݱ�XWYaI t:"uQc:/}]^]��ָrɐeSۆGcp:zR'xLg7U_��QPIenڇt8֨p?[UNt��sj{t>NcX�XǵCQ1}۲-C?8aMa ƖLG9Mg�z|ot~NcXװӌZǫ6I7 �yWe֘KCWĊ7 tk[\9~x��U[mQcp:zmO �<cp:3P_n� lxWonZCYx2Nc{l-0K-9@hK- XID v@+*R`w{n} +,:$@K9;_ |;O<~Y5i9�8C'kwn%XlO],v�# [' +7AL + W#c�O@z! nB˰?IaKp0z_v$Q��zޞ`Y]a0CfŅl_åOiw�@ϥRFeΌ&y6>g?�@/=̷NB`0Oyc~gG*s@�@2g>$1)3MۼW~={�~yrmZOzĤ?9A+7PZVwMC�@ۓ{/wCTz@zĤ?5xiRL9wp+ڝ�h{f .1)CK{�v>YkɽOw=h}bRfÖ}oO�l+<>1)M\bw{?.�OG 1)v[sr~O�Zur絻mAL +#: H{̪=J�@둻%w G1v_�Z۝_ݮ1h[bRѣs-!;{�pWyv8OvǠm?IaD;3&Ymω}Y~�ܼ*\v?IaD;3z۠ �q_&w|Vjw +GOfm +zT�4I+۞/snڝ &-jUޓgR�@=PEOw G[`Ki)�՗9Ek/1)%e,۾<߫�&[VU, vI!h_bRmi1!{.Yݭ�vr,{:F;Ĥ?7Fl_É }b�>˝~ڝbR6{Utk&,�{r>]{ &1rؐ?QZv�w #wZ+AL +W'YVW�X?^%w9ݵnvG@:r5~^߻�=. k>kwt?IaY!d.}<wv@4xrGJ &k-n{Z߿�lo"o$N3?IaZmفo-9R2^ ݕ[p$X bRh̟tپ S�ɅS8{?S>hp|}O䆗ى�ga'C-U#U+saLܒ:* {vMe�0Y%A^�ga&y1wޓ=kԤ9S{##7 si1{lVjw3�l*{jhj~881z{p<I-\=HޑV �`*wvv7 NL_)u;vlsa@qAsr~OI䮆liroo>A@qa^qVlmsΜ7c9~R2gQ~_ ޑNsTs?SU>"{cOs{NUѲC,xoSϱ?\Om#ʅ l�0)]?H{c\\\I=~/3f͞$G;vl?p#2[Bw%HVв䞮hv8uF; P.?SUBW}鏍g`?gֶC)Io�Dr?K?W]վp>i~l℘ҩg-+{sLQ+#׎ +~ܗcsBw껃 kw8�D/.;:&|Oo:Go2;A^#\'ׇyW]IB #Õ Ć>1=�M}c~.tg[!?2eG4?߲y.q>͸%uUpwוOs�T˒YtUu=B#r?S۴j{f+75)λ1gN]=LJ*{}ڝ�kyrҤ NM73)J +Ǝ3DJA{^ڽ�N^&Fa@Kħ y!{zL~�'eYr'+7Ծ݈<bRhi N5E =�N"wQI7AL +a]pfv\?5K!a K1 & pN""KJ)Mr(+%=έBr+vJh7x {TJhd ʸ9$Ę}~j.1)ˢ게[jmZ� KھE &p=ڸӽ6횢w�4IJVָH?jw4bZ{c�AL݌ &pvMu4fO־�@CGCN`c;f`@$JLJU%珻i�Е.oi_dvbRf@n}[� }{`@`k lhp�Is>m{4YĤ?Ii~2/K6�Hjo˖=yĤ?iGjЮn�D?=O+p;R;fb@=8cf]6'�@8IIm\-}ݹ0 c~ϗk6z]^�p>;s] s?Iav!��֘?/hWJiw, &4UjNҾ�~\ݚ\w +?Ia+=f+h.�r,Kz$yv|bRjS]~ߏm<S5F�!utc?y5NE|`WV&]ڷ�܍o.)R1)hq"o>-Y�;v8}Mhw( >_}-+$h�p;SW_ &M}GYWm>8K�[9kYSW[݉ &mS~W�p36)=%}ݙObRϯ]l:Xۙo�>\S+4wAL +"c;r2o�9Ko[_#Ĥ?M{cvu뵝Ӿ;�ķk>*8R`@4y`px]>H�N/fK>*^FAL +,O ;@|5Ų :&}݉`@4zvDk=(o�7'k*"!.AL +*uͻf뿎/*־I�ćk;wRzkw p31)D!>Ӓ�fk;>TfUC.1)D^ӇYATX}L+$H,7Ihw]bRv}GYWm>�0KE͖nAL +``~{>?wyK^`: &X) 񚍧o-�bȱgW~$#Aa@,yY}@l8o.Ihw?Ia L*k;o�難KJG&<i`@,ʮ\,�!{ _jwpĤ? +|%iv|u= 6ե>%1߳vvwAL +*)kb kR=8Iݮڃ/Vl(0n?Ia irKg['J b#F[U:];@t^~pvgAL +&bm9uv }p>9%=Ub).;ot%}|5d$L2zՌl_%G^׿�z߭Mbi}2_M^_ٙZ_9%= }I@8?IaD*>xR9ڷ%߽|/{BpahM'-O'>}[_*+ggLq߰?`ٮ۾ѐ=k˒^‰A1@sS~Ԟ3ǿmKqѸ[m-_~zMfs$ﻣ1{] :r2{.~Q‰A1-B襤o{{\߱?`2A +<Tyn}'fHa{Dq[M?z:0"qowZB70DcfMz--Y;qRb}=;cJ~@<daudyG3GkK�CgJ'=`28>M*Bܜx!uS86qO!20tEz$&ޑ9Q<)T+[I|IRpkӃvuk{#߯Ykn"A"zV6Ah0+OuWom,:x#\ |=/?{Tr9*ňҦ$MML5 ܀\n`u!,.{e6@Xj5&&kiNyi +&(,{]foq3<9sFug=;ozANynӳCk8%vsI 7yduNxoD(B@t,] _|O> 0M}jx7/M$N9Gr{b SOVqĢ,cPDо +A^A=4XVF=h2a=}Z)!x<`d&ޢ B+A�ЩĪ +}w Tkot ;} ߂{f[#;5A0 3PBj ԝ +}Fh Ƚ.ARKЫw,Wk^'zޓM{vJ9kb.iFV w3 囑m.6U\ ;T反G2(7mXw\d}=vA]F-d{oχ=+s-_cY^Pԟ?/.}VEO[wnԝɼ_1{Ua3+~-䟛l'#3w@'Bp0`SMUx#3`.b~/UQBu"߮0pO3Z6~~>%ua:x4JS[ +%v8QvY<XCl>`t6M/yv2c(\,P2n[Cw*KVKH;䞰ڴYBߕ`�M|}X#C %52cvХw ,wu0䈒q͛!V8փ�>}gKS^@A$g&֙;EDCF9%KeFc'/Bq~Iۿn&yd U QOf01Hne{-]9]g!tY ySx? 3VmZ 3XTS? +M?O&"YQ ѓX6+yG-m6^FP֮ :t$y?s4 g8QXξjNN^3<7_,6ԉDn7"+;/g|e@6b./Cwtzݥ)KĕN5<txfWϓ~׏~A&bq~Ą! M?f$*cNkR:*a5=#HljO留׿Rs4@>q]wV05 V{`,�팎bYV ^xoL~dw;Zi]yٖ,?Cwuު-՝GW;T [^>VLw[*oFg3Z1=ysa-<_GOle{) s<[Xw({Y>>3yuq^<gO'~Nv ~OQ ރY}?]x PAX]lZ`rrR o"'5~'c4%wWPd<w\7޳ػ^ v4[;[7QpdfJ誱?+"j̊rDw~zN^0# u5l&f" $3f:+ՙZGW;+T{:Eh)x6^g6̅=H|;KjS5v<h(pJS[!d`z,_U@ ԍb(JwDl#8l6l}Lw>=C|եUe82?ܩ\!,:N0zBn~ai،$VecfsMVU#^JGe 챦rx.6C_)9?2+;6P,A3:ZK1|V07! ΎyQeV']@ #i-u A+Б!Gb6:?ܩ,%xPha4*ktGcͯ*=^[F3AVI, +?ב+|C}vp~{eM}Q3 ʌan1|hÙvFK }W+‰k!tt-:.d:˝jǾe.:3!{"_Ð#JFvWo kܹCO;zDZg,XM.O$|2zKEM,N$rf=Dc9,xq~w\Gk6 q_S{ ILd>%Otg@ZٿweǫctN8{:Z2]N5U#6m&qw[y@҉~Oj7 nw+R%,ƕ<`Rgu5/]YCwsfnYԖzy@+  scxo\/(+rZ$IPk&BQƠU|.D^ +,nX};;0�E$!Yh44=}׹Iĸs>{̽z,f8{pHns9qr@%YjoB?A!T:SV[AFզmz!]2@&',[S, }KzYYz%AM TurkQևdotQؔ՚Թ Y]6M ĎMR6炮#3xޣu@Kw4nUն�DTUvj>}P펚kP'QI, EPS \Yy׶[]=ng@]@}U$]2TA&'C "(gmhex|}_zqVt"P <>&}::uܲ| WgU'.H& uPP eb[^ս O'dhAQ<O cPkA�49 qMF,g4A| i~{5 r ")+Gme;_7.J?D_uSTs>Kx!@&'W1isПo.OJY/ؚX q<*Q\:b;eIӗL .S?/&[֒q y y!;C9MN# (;W娊sHWl:8ʌY,sWcv*w+>0]}I"J vcAA/*) +:ZLD@8yE@Ǽ32LA6~I}t)lAö́< yMD@XrpR+yʆ͗RSc}o&OOVRZ/H$ ׻/k +A?d?r*%ۆc>imͬZ`ܛgV/,j +?z7}xNgαrbDo.O{xAgGs!^ԍ=}x*i5qMA_NK֌Q,v)=܋5Ę~?2ݯ +ݻA_qVbCԳ8c1Cdm a=YYkbGWpNxFex}Tel9Ѿub˨ SnjqV)^B%Zyg`rOUzƔ0 +&ܛt <2t痥'v:!os~&![PQ@vՅ} Ы[[6{mRQw+#a.cF%e|/el }#w蹷H1W b|.YS)ϩO\!FU}b.Ӑg 4胸^}3jN44Щ LY0SmJ8?RlVA Ȳ]@:@LڷQ Vx`Ak2xƠݼ(zpXYwb91r$[.soy9՜:vX֒1D +/*wACD@RS?..fXxe2ni?akl-%J}K)^t&ۊmگ?3>bq>pxK~o U\[ tո{9j5C=gbnZ_Y[y![z4ze*p5yＶ+E:H�n/} pC%~ASYSTlۊ MNocVxM"NA[r[C4岞8|+#sSƁI D6enGh}cz|t'a,U}=@qdz>R?'4Szb8P]"fUkk8 *٠m7Nx'#c|e|I9^>/!?I gPU[y{F?2steȑu&Vpl3ku|/}G</(a<1zƼƀBe8&8wʘj| R?hO # D:wTLSe94I!.Sgb6 GokRw^@uRm%_[yNC:>G5Ә5y]d#7a˨xm pG"~7.Y#U?2fIh\\^ +hq}){NVtї(=Wt(q>>0_fybb)S@`. AC@_!#q_=Sm)-reWeΑ-v^[+ v綰̭6WѤQd�yK[ PMr<486RbcD"xEr HAD]W@@D²]س/7b5&Z5'NU_=]Wjo938;}s}�o k#/5ڎWUuc.7V`==� ܀/ +ާ+6W|sKq\okp S.?CXÚ!s*MMIUe2kS9Vi~<y"cߛjdBoE2MKA<GPػL<A虭G"_^ hܻ <IW+%so??Un{c#v^#?Z?Y(>24rkpc|`?7r\%_[_{=j5d%rOڳ7xq +:*ֻt+ :ޠ;'IPH),? '/̌y^wLcMA=["έRWm,s_,1kv?0QUuҌsjYQyd\Y֜,q˭zUi3%O7/qx޺,r.7(7FZ-\u?w#uT}A4Wn}ÉuJ# ~s5?(?ɼjN;n<PU[>ɉ_gO[ ٷ*$Ʃ떋}moMJ1w:m C%9&}?䊼 >9-d۱)#'8ow1qx~>I +#I8]nV/WEm^{u.MsrCQ"k wUW'-VW/gN\km3?(?@L.onkd=Y~`?gw$F_Sg*ɼHbbD޾{S˾%މ AO5M^ٜ_\8/SV1>_{~~U>#c rFcɅ [%:^臵 xvPH)C"oR*W[֏y\7kٸCX̾%vBfZA<??(?S�V#ƕeaxQ^  n[wB+;P�z.脵V x1PH)x7!K'u"kDQHg×AJe~tZAR ᙸۦ/Vվ埰~zE7*@HD@BJA ˤ%P`ko7^b=QWu E;kѻR 3mFGF{23~yweNFˁA83SB3 +u|>`ڏ}/M<;ASDquD=G!qPH)^js$޼w66.}oMtϱ(wGPLcIZKA ?(?qmKPuX%~.=7aʗ}Mpz.ꔢ/@Xk AoJ䞼oN ]žwDMQꁺ>kR +At20l&aZ�AdZDZ-هZJvQ˥ ۺ # +(@]Xk R +Z[N!&|# VV/g߫K yE~gyGYk E_ bZ//p6 ?c8N(*zR{VW~fwR\]{\A=-Zi(N72+ﳟ4Ʋ#[i"3̘Wx19A&N7hB6WǸQDqݤRF/vپv폎TC{ZA ~\X{̥ߎc&ʗ}oo /7tB5 c*-B>Wֵ%¾!AWyw8LJhrV4 x3dAxfݮAqX8xDOzrCQ!zGO-ho^QY# O:l;Sg,'>`�gn']Õ+[St7/!Xz4k!gD%rËu-շ7\̕/yqny0g\g;Sg,'1c8k =p&Jݼ?=>Pa3[;Ŕ.6kj,i=nN\s1xƥڏoxoyp.hùq~b 1 Aaѓ7sSJw/i@gk<<n^ZĀb\(0gyIZN|ߐw"`dS`?}bwp 盻3uXl3A5&^nPh<]EOcM)Y_V_w'IR>(Ҵ +r`[{o7.]=}}jღл=TujU<b~.>0(iӰLrj2;  *u+aӊ2\\U" DnBM@ή]gw:zT?>6Bg0|s{ &CҺ翛@  +Z?0KE[SSL汭h }{;o#\7u] +MnOǠ?r19Oh^�[̟ǎMuHZ?&=yջve2wa@ ?o^?==٣.͕y DZY ~ٳE fD @L>5�B2!/t$њ q*������|_&C/]1yalШ~K%4&_������Ny!k97>Jƺ[>=WK*uD����������������������ಸsxРQέV8G&T.,+t?T0F΀Q**7ϝ=%d}D$?_Z?;,_d5;'KY}N~iWK]IVskM~?۽*wQ2| \*:&izF1ߛ LAU}e. {a�p>/Ϲ>]砡IqηǢzuoCe99ԻUjƴ+`qf<=[/+{O[@c .KE榥s'v57My4v-HOB<aLI_+O? u U/fq#)L!&r'J4 {U'p;G|^rX|pν֘ ̲ӏ Z,{eG]U9hzUTchZ446oX&^3%ț +Zo{`ǾƝL8TYx/_K; 8~^:}Mmf Tveu14v=7ch:$]>^l9tGӻEFp05^&2V2`fA=JcK{e8ec#S- d}mFYUߠ}j*TakWe34v <ݙ \J~w;ڔel?dۭu4+X*@c'}llRmD]mhl(̯ A~~u03wZ#/) +!) 3qt^74+w5PT% F%ƮCC ycK-NE[okۯZĭbWwgsەfg? >Y!΁`&@fZCک# L gџVk.,3nu#<8 unm*7砱k"(mk5|k@CE,<6" IVUȻة\0E,] ^QEch fv22$T3s L 9kyIQ;ԋi;M}~#yh7r34v kk:z8Ӗ#m[2i= ZxcT 6Fgz`&߬?qOXĊZDG[#?@̟rrsA~UZHAc$?c?G=%AXx!!  ٝ[U;;hdۭ~GwKSYO像D^RBy43G]GSG{b�U[zt646اB0Y ji<;`?\=hz:AgHq uo#9设R\<zp<kx!Q<k5FKz`&A} q8v˜sume%G>GCh{1cn ٵPh^^9y qnn4twsعa{6m^uO9;i\LWex͐T:>7-#!Asg϶E}W9h fy +yIQW;h vti`<^O !k54!Y0?<Ъ}|nOwUm-mtli骩v sffB=‰޽ש2PRy<&%ѹp&xWA<𹤲0Գ:N01 M\ zpAWÂGAc0p(&^;Zb]tԧA[ʄs-{N砲rS+z[R ;~y¹ݣ.1~qDYd\_'JWyI|_:,z*a?,?~j.4�����������������������������������������������������������������������������������������������������������������������������������������xH�� endstream endobj 18 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 36266/Name/X/SMask 265 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoJ1S0[c0Y-ltl\�fℭ�*B+ m9 d˲do w<ǕٞSx'Ss_\W����������������������������������������������������������������������������������������������������������������������������������������������������������������WEQP|n۽[jK ��ˣ˖GWF?:mO|vMʚ{nҵ��̙3i9\t-��@6m.sGeƌ+��BrP߿;х=系ȵ? +*KKJ.��;=O?<a֗_ZVGm{^/CN77=t}��@8.fz/ew?y+swR��yxx+DמZW=m5+ڶhEEeTp,ki1fxWV~sGڭrt' -v5ez}`Q5㾷2sEpFIqs<Z<AZT_0gcnnz?qߋ{:+a˴$]-w\sqq{6V]-3o4ٹu{YqqpsAew\|ed g{~P4;x< ;.9|8?(Vx< ;.9|8?(VxlY6王ܳyg�t3 �n5B�ͼFH3�@~�H7!��f^#$� kD?�yg�t3 �n5B�ͼFHr|qEҥ��0!;t-��|bRҵ��IB8~;r��B狙 ֚�FBƺ;_++O$��ư\?/qPoGF5�_B2_ݱc� ]Yk c��\5Ba��H7!��?��AH��f $�t�@?IK/.3J,��|G} eZZR@e��p^ϛ|ǂ?Y( �(7y9u|�:!)Ϗ.[>UK9ŕ� ²��AH&Ͽܸ$osל) �Lo1#<AC), �AX&_ST��c?~�HןU��۹{k�nBiΣO[O?Q}~tdWc.rb6}|n;Ԗ?Vg͎_\8?oyyq;ڶt~֚8z8sot|[vɉҴ94kmY?Q[9gR~SC݅uGZ~2Q&s|)tgoCs99R8ظ2Xꡂ3hRu6>4N<grV=-Ot7uyq|40wMV$$iHML!@H8 6rbW;1`C|`#TEҪ*FHJ}6,l>~I_{1| b#D +_#Zznu{a3.;mLNNwv\ 76˩5b:{so??,%EO5>Ryg"?wG*ܱOJ1ǎlm:Z=7Uث֋C Aߗ#jgDݕ%!q9UhvتwvY2SӴP31)rHǏ!#gu΃<8#<"}z[A&}0osFB~Înfh8X8G#ׯZr͘([\[^ҒW/yR\&&)11g :_hQcqi9rTC���kP 3��@l#A%\���p=��6T ��kIkn[5{��by `Ͽ}%�� ~Nm:��ku.}^jwi��F^C벵X"~���7b̬1W?���y Jt~o?L <G���o5ĪK/;mGu9��@|#!Μ.3gjiӵ g]v 89)%:]<Y+L���KL4bkϿ z{m[]R`q77���"<bͤq㴵+n{\Zh^CGq/ ��z=??/:Z mp`>(��ȈF@{=?LL7��@4O??sѲ��y3PIpY���ث?@4o>s{d��z\>PE_r_0<7e��D>9UDZ*)d���i'rZ9g- w��ٚ9F}"?+Ge���iM"m4TMv9z܎+w��r`Ki"T ���ig耷!y^ ��D,b.* /6J^d��`f?LlYe(T?\0<]5d��`flPIpxl+ZSu; ��z=k-]vgdx(lt ��̮2~?gs^ ��L^>@%Nj棱w��0nOy-?]��`FݗdžD.@5n\n���fԧ;ew* ?J -ٻ��Ѡ.u^OB 3sif^��TD9L1T<W@nn���̤bǎ QY@E+~sSo){?���3<s?PCL}Ow~!{?���3qPIQ[3he��`&"jW?pcK}qx~ѼT+��4.8S<UKJ6?7Y���fpx׮)"xFĜZܐ/{G���3hn(t}%r +?uY?]#��z]hmPIQՠߑ#��U%*?6."^[25��d +'?HcQzkGI'��>ٻw]*?skKX���*3>m*/PY!B^=��To8\lPIQ^5h_��@e"owTEOpU��P]`f��@E' 押5`CYD9˵Kvm+��:϶G,Fj1],^_d +��>믖 mUHG-{W���r7K:f0fK.��RV<?WL{T��RRYC0T3!}Cu&fZ'e��DyJ*λ)?SZO\5{3[ {}��?<(o1HLuԘ4jWNH=0Qب (�JJpU".{ςEX@nIG?_:,5Ceg7C~ ːROQWQ_%ˈǎs9cI�c+TvEx���8;*ԍ9?0uX&џXR~̛3Y&����uӏgz�0,[ڱ㺶ˁd.cU/)2]]m}����vzRz:z_S_yE,m0lL?hrsO*Bsice/)1ѓl}����,`d(49e}W c'>01O)/֨|AUy4qO/3gHVd|qfh=ɝ;c���,9rGU܌8Tx4Z^}"j/Wr |QRQݝ/yg]8[ϩ߹0fO^U5_?+1���VGKga�G4E IϜ?)܃q`ʵ?���p ĸZm꥗ؾ hx?LID' 9g_ǵA^>?4ҽ>ּ=����Ƿz :S[~F 8*yT?hsk-UgHm%yAy����vzX#jzRXS^3(0V7-_!#>G]# h?e&7^p5���ިK]DC=#b(VQҦ1vǶ#QԐ4<����lꡆ%(0I? 8(.(bZs%D^OQ4x n���F0Fy:ؗn'xtעmn?y1]80[Q7˻_iy܌gou͇9uO5GΔz5c?䟪ЦDZ���FNjn UЫ;i$)έEչɨӰ=rӇqig4Iy;7GsU:>w ={����!rCp_ꟺQ.QYuGk߬ߚ?<B2wvyT=7˻���{b=e+FMZ=N~z +8Q'~> _:?hf|&(ԏZbE|gL{zayqE ����"6jFL4us #M &{4{wΪw1Vʩzۚ���ZswvOrxP7J⧚\?tgGN,Tt9o9S߈ ���`I7ixPzZŃy +/?2A3y_+T;s4ϊ75���,b%LdzX*̧^w٭MwҼΝ$~%C3m}����;c&y^+=zS'!m-L,}1'9Kϟ4gW#.���8)˨gZDQOZ#C'^`fL?`87 +NUJϡ|cO*.ɖ_=ַ���`1^1uO*k!"#tp&?h֦{>y)|gz"p!~����&n)RI ӬoiEkNĒM\(S7o7~&;[/psc����0z@*J;S}~Ωɘ^z}p?UެՉ%fi(cZmmjJk>~����D"Gz$xPDSQa�9K4ˆ5O{+[? ���O ,j254`Τ'3@!i +5\{2&}[?���DONiHePP>% +8?-`N~<Wz[Ҝ=bBB����CCOdct2;=k*lzjYxdnn]BV���@5h uɿ +3cڮ tSa�gғ~erS7I3Z4},ZlG���ԺK*V}@}UPPS&/뉞ΤA[?f*ʍS]]I�cm5;nG���Đ$1·:zRSt u�zzْ.Hΰ؟ǒ.ZZVp,[?&���prg_QQ^w/ ʸ nmh[q 'hsj�� "uDmYBPfavW86`bq]T,'=#N󡩀ȼ/9k.]U8ΉHorK64K}Vw=wYNu={*:-;{���@`Fxz2ف}S:"YKr>;�fAKuhI 7- `j[^q͠Ϛ{���@ V,g&2>N;S(P١YnBb1sg34ݍ}{j c>n} '^:���xAyLŔb"MhX"R#f +^&\UW\{YSެ.UΛ:�� &x"f(5VHZnr?XsrI3=Gt|=csr߶yH{��y̿Qy^Q[7F�={(?T63?N# b_թn*NzR��XLZ,_;$ϗCh[5X׽eBcA(mQi7=wOSX{Mzh/H3wa���#_&SnZ_90ò13knBb1rVSlJ??| ckg2.֝*^Z���d԰pz5ߩ\dy؜Ayr @ػ$sBOw4!{hlV}kw㽼���`G"Ku+)n_(R+; aOmg σ1}أ3[39qS_e���[TrCNUd&x3K]`J&&BWWVrEhA؅twvØq߻K,���0fVVOyqsCm Z537Aq{.:#hK{P6kHQ[z)~.μ���x(+H3ך'o8z>fygNvi@Q~LSlXSg볂FXWC5:ݯKe{��}Q[z\&С!_b,AC ?hKi}v{}} h:`I"gg[����4|?CWÇ!WQEi흙?@Hx11ZigI�c:ʢ4^���aiuq\Ҳng:wSne/�dzV6U}ZNMŹs +���#\LZ 9"(P^IK $ǜď>;{%40:-;p/ia���k>eufʗ?+t[BߤwfBûdW +ˊ[y'4@VuPf{[���^z&U)zCx:JvWVB�!q,kPz_x-ߥ3sA%7��'bq5(6/7D4O(,9BΏi+ߴM<hH=bԪoF:��HrS6鲬@o.TSP㒓?@hDKͲG{m sdc] +ߤu9/u m�� #GŒV{WI�L@t_9 Qƅ`=o~lޞ陶juOI_;V��cFŪZs 3?ݞ\m'S?�$M'FN +MD3v͐uʤS^*-y;xo�� xlHùE7mІ{H đǼ'znr_gOGi=Vt*DgH_l4xo�� U$bT9&FjnYݚ1I?scwBH&R.++_Cu[ŗhݎ 2">v{+��߲9FmB?7eŭ*eE[*Sk^)vmNfҪT2ƒ.b"m��>cYƍ# i5ߝʭ4,hXִDaAB5Cч1֡QR@kiԖ^(HI3��^6"[/SN/+nnow1& gv G(F 4?hfYߩ>1D1iX4ZcE_ 8;j���|L95m?IסA9LBcL?֩n<lN}wdA]/fFMٴ>#xo9��2L7p Qb ޖFW6& +#V A+D! (k9i9&%qcuˍ1ǖ A2?}:g.?OXkZ-]32~}shC!�)Lw˴#C/ ̫e?c^6o>O����b1ھ֗*Wrp%+i!s_T8w,q@t+?\yz,a_3Z_Ty{fǺ6�����cQbd#Q^;yWO('!c_})ЛcNCHg!b6;gw\O:Pϗ;6X7Sszmh�����7g Ujz9:緐ߧ/[r/BC8D:A�PBdyFPQ]wL,?h_WNړJeR~|oRk'f7tq����tבg~xE]g +os1_ߎjA:A�B~UODOܾ֗*e1ݶx欧1Y|onjt Q ikee���ڨHԐ:oV < ]9y# K:@�g#"7m~rfia)2Cvoj=~>}}bW;X/P\ Sq��� FM5Xv^Lh ݕMἱdH ##9i۶ 3k83aiΪTI{1U&E1]2j9I%a���1!!vFR[/{҇.4n^L.A:@�ZJ+/XE[L`mˉixƮpdlq=j + ߨΑ?;���ELQhOԒ/P\ֱj}7ڙ#-/8C2 ҙ $J< ξN_tQBGtU>hI'Q$񇆃[dg,5{ +���0KDmx*rN2=eR򻎔Q};t*-ecs1c{^F `Wp }r=vDt4fŲC~,F ye ���<3&OA'"'V1t5#B`pb2Ńtց:.8﹓co'8v^EZynڣ""twk6ujW"kx ��� cƢl oz&LA?_2t0.9tց &=-W=w_x{I*U'><}`/uPųj܋_f;rVcXDD>w���a?l8 + .K?wCMvOVɷvجo&9 `j$FF8r,fke# 9ndCHޞe)ݺUH{)G=X>;.~O|rjޜa���4)Aiױ_~'}HC~GU{8}f3sX{DW-6O)mvѧR:]L+j_H{)+0WJ3,Ȼp|s0@���+66H!AtrϪZ?l:ߥtd#S4l2%xp,O wp/5w?SGZ-!(OW#A ~wU/78���3U;s!iþ~66AWˤP).;yp dp8(4֢Y» =Ͷପ:%4ɽ ]0B<ҌFy문En8 +���.&l Ro.nq{lJ7/BԵbU3 `!}?s>%TIj؋OU+^L>'Ǫnɓ>]ʊh�� j~۵kL2[=U~Ӽc]#%G,; žA:@�#B#CQ!+o8KAq=,wך\<3>J=$Ғ�� +\&MFPs؋lI~|#B!i�!(E{tI|ٹC4N"v^b<\ݐEY���b(:8xxBFcϭSv +ɽs 8?D*W2?PpI<#^f*߄?K]Ģ.Q\M?=u\ң �� X Ga%9_aof=MAkn|::�9lz2?PQ63+TϬ!g\Ow S)+NbڄpSc���g5FIO WǪۻw3Ƌ>}~0P[F:@�3BKb6Rٻ~GCq3 [*ڲAEܥT=G4QT(j%EǎMWzb3Cmuݕdcku:bWY{yO]1v &��=vyߐw +l>|+ڟ4 ;Ø๊]!gm$/*0`f,c6hw`}Ĕ3Rwε(!]P)0ȷMXu'ܽ ]mmp_�ɑeq_&2%]jx>vn@BJiA6=)ԀV:mKHs%%w.y7&w1݌ IL-\}&# D|i) (}4nV 5]p }8LFنܹ%w0wۥQ\Й&M 6l &;+'!nd[S|94!c_ ϕ~VTzhw`}Y1nt%wqy�OC7UK/(;7pg[. O#h An`�AfݬC/<)KmgU|a/yY{3uH_Yp fmpV*u2<C_¿4 d^oZG1'ԛB"~:+mSyym>=qADhiD usg%3|<bz7.Ib5 +@M?G׷*BTxڝh S?GWN9>�d~�-hUS6yҹJF|ХԞ<ۻu%0r ѡ}yp6"gr%YB2/[~dU!O/-6k=1ʹ/v>ߺP =+(?a.A^)cT3\bDhgf-�Б;񪦀U?Vʫ }$- +McC# A?�C}}3 +,u@CgVJt] !YB2 l�C߼y92FJzA^)8y߻K?зo+�a7@1eKɍ_& G L=xT>:nN`5~q8! łq&l1^u$l?¬S +IgV^JylGqt젝_=iw+?\匸)<vzT|dAO9ϛCCȓʪ]E:ᥤ|n'`= }LdPfhp3=VbFd͗fV/+=噭TYY㞨ކoM1�%^}7|wI?Qp ȯh FK}RQd5C]�l�Pg~}jj]>r1U^Ɉ:Iq%A@v`Mt` +p=,ǚ. <ƆF0\@5Z ;Cw.KQHu)Ks>et+\?*|?�ߝ~Z +FCtIF Dnj/<]n殤}}Ҹ v(֣yF=՞{C; Nߓ^(l_.O+<2uۇof~sX#Aá}#é@s+x1f&8 +ydnO}R/^YNdm/ʹ�Es�}U)匸UԻ b4;RBߦU��W�Nb=dl+Y|w7y*A,ͽYl].Jycr✒##&ͲcM`p9 [Xx1`lhڴc0,ф0-ﱒg^|hiځ6D7i]\V[m]|&2yǶ޺<9QdӒh��aTs-V3q#hw*?b|䙞x@-XP&AI7e[>4ZTu%6:NERiә+U+erIqKX.+L+J'uWobclUn!!l YNʵ.`Bp_�lgi}0MA'5q&Hi4 !::ۅ&;{ cy%j\۾|\W6/o΍8Q\P^pf B~QZߙEY|DpM.oZ*慴'#Tʭ=vO/-6{=h[mvu,3iMVeNaZg SRfI $!$�"`)7Bԡ>i;E.~| $y$j]o&r>gV9;�}F)wi?Hd4X+z?:*e!c2vƏsUd搫4fXpBӹM뼩4Vl[sҽuCkQ\,Kzv"SMG4Ԫ:aUZqɤW5ԍLRcfQu tPy"@qBHVI2Cz҉Ӳ?EJ8%JSէ֝ nMEDoPK3%QT#گELMt*"|W~,bE3Gx c +MEIϭD%+!6$+1n;?u +@Cv}ELFJQ%-4eif&"ܳOO4ZSߟbRRTYc1΢}0kƿZvFR=W\|]Ӈoa̴%d.�t}{A@[Ǽ g{,i3aLq0Vw0vvcecb\ӏ]:ʮnľp3qgI?s+ VNr4M}ǐ6{ G>(3ƹ?}ѴpCӢJaɒɏJM]Q +&J/y w/k<X3e[XjyZqeդɲ=b۵HeMfDZ=<ܶPU]@/\ B xɯ,GAFϟ5int |1щgI~_b?tXx?r{_g {{A@['KҥJ.> ��As_+ϡ=. -s,E x���нPLGsYT;?\\4WXx���н*_F 7:a׫t}5E��� 3=?10`:g)/0E>��{\/*=}޻?H[���loa4O{@@G ch,vZq+󇩼H���xHFs-p&A11[uI���x6h|*{@@E,cyPk>+��h M}d</bdgfܪ3K���&ؕw i?&aFx���5+|i2t)A1&1ĨUT?7��shuI[yұxum2ك ���c5yNsn N,ʒצ��]UNS H#1@#]âx���19>k?;t<b$F&-(K���>4h] ޻t.bƒ~���A14:%?skpdLY_z?O��m4KүMU#?k lO~[x���ж{ܞx A:1g?O&ɕ͒]z?W��e4i^'ӳh~!?s "`g+���n^ywZ?<Y^~VVl��ތNyMs ]Yzl`_]y���𤯳]iN/2΀ ]sd\,[z ���O:5A>VNt}��m$']AM?\X^YRK}��eNQLs Of7Y¾'i9g{|y6{FVk}y���bW/ۗʘWx =19S +Y[F/?8'jeJ^ V{\4[tI>s��΢Org;oHOכl-mJkds��@n&p'>n S3iG,n?QZ ^���:)d蔖~^w�y^Ȍէq[VLJ{R��n4Wc4@@ "|VgLyAh5`:_̋; ��8Z<ONS ?Fm2} +3jTu)iy?Z6q\>29 �� W%%{I?Ό)owǎǍ39G6 eleuMAt1��@,.bJs $Hwglدۘ*;7NAV5]l].-jk)n::<DJ!ZW+<9 Xv>4ZNEc/nobҙ ~?+0-&FƈGu;*ի~?W6WS^$-ޛ6ȉ��a$E'_w;AQ_7+&Oe緿p~H.\7y(s,= }�`~_dd 7ըwX-1C5{\'0^ޖl4=G2��R=#PJw?K^Re  ͜uןcۨFu5Q6�rC}{Bt[X1KOn?eev]og��t I+<EAt +,e\'o4��9גagO|bGɦIAs|0; �.Nla~ D鮷2)6èq;T&}�񦂏Tz+c轷S��;c7HJQ鎷:)ދ]:ֹvJl��OթU㭎At +oص[{](?Dn�`W?xGߌp<eT]u��U{M'OUJw?Na݂kƪo9i�n>zס>t`K2J}q��BS~1N )3/oHݮ'��ՆU]'v :`b F~gmyl=�T_㯨V=*v :~upxiM�͗.pa蟝efyw��R=LAt +ۼd~_%P�`UΟwCێD?/t\E}�jT?2_At +f QF{ �\o_顾lb7_y��BbWٽ8GAt +#<~Թҷ��ѹ8Q㴬(鮶3)y,ZsZ �P& 鎶;)v4=n~<E� F~zQtGGxeW:>j>��RT6 TnGx}M{5ҷ��)_t~[EnG~rА"�lT|Mu :~#`z_ʗ���ە{ʟw.D?jgAs +��`gUyX'ScFiwknt��0XBw*>9. ql4=G��MzS,.tAt +c-nxk]#ҝ��@+>z/6)쏁3s}OI��r8wIݫ#)쏁H0Ny||?��nZ}3{*TIwD?ދ[Eo|�@]?4M&ݹb5ZLwU�� \T~˭.*ݵ:cӲB߹fWB�� \nN_mj礻VgS'lz.Կ)��WCzCx.f{ S;VwSgB#`z_ʗ ��JݭMcu :1V;KV��=0Tț-ݭAt +cp[>h>nm��Թ`^SNŧ?'ޭAt +c9J6M ޞ�R7>!ݩAt +c-nxk]#�@_uU=3NS2vfS8�.LST/ݥAt +CF#(;m>y}�j9쭫S=&ݥAt +C΋[Eoҝ�\?4M&ݡAt +CVnM~UW��SrKJwg$b5-+9*{nv/��EzK;#BGP|��p#V\Jwfb7!c0n%1�� UOH :a ++r KG{�ێiz'طmtWF2Cl;?a̲YFMN�=]FH Vϔ>nM*gx ��'Q3stGF:zlܝaZa1n@lE|��"W 〯T~H V[sUcG>d? 4=7:&Iw� rJ{]%nX7#&}mXk=ez8Mh3f6zta(;=FK8.UKM!58iֺ'=s{sI޿|#9O~^2mm�~F[V9=ߗ1Jq jΜv+Adկ[/wx;�~ܕIzGSw"ac ak+`{O?k|vJGyK� |3{Y)kw!n`N%dwH<+Fnz/}ùfyܕ G��IH︋7?H]yZoQ٩սүGպS|UX=IS]%K +֧lh-Y ߑwm; �` "w&׭sRF-";Y%׿W5�?2@ /*V^n{Nx�\A%}U4 zIs(ذnilhS-oSr\D?av7�urZMǤ݇۱?SRkeZܽ~H'오O��TL@Ug;w NIpl[6^?}&JK; +�`ci[GZNzIpgbR0j[O;^&R��86Re亷~u;1)gh)vmߑ{$+V��'}R{TEzFpwbR.V Y��维sPgީ; &, �p8˒>IϜm?1)gyf�:_X��unwOm?1)JU �<#3򖿤i1)yr|O>qI�8ϡ5{GO; 5 &LCl)v4v�ܶ1t]cp.u=D��OBzcEQZ.Cͱ?Ia8W9Cmhw� LZVf{O=8X`Ĥ?me=W}xc�],n$}_,FĤ?hWUIV~�Bvw?Ia8_ɍ /z�{^LjYx8bRfHL=>s�! 9] &avcXUE_��# ] &a=+oy:mv�IH/YG &aFc^6WN_�߲6m~(<1)X4AU_?nv�\90.N z݄G &ay5ol�r $1)wi�KW|?ڝ &aa%wfoi �|~fre$"1)3EwҋrA}�{r.ɕ"1)suN3Ϛ݉�war;vv?Iam>.:ߋ�ѼHKLW+݃ &afc,ޢ̏b�P)q=}bR{-mZSyK;>ݑ�wqGg{A`K +֧S#{�P{};5;bRg_JmӶjw%�]MU1)1b[-\/�=Z]m;uAL +#|DwVf ='7M�Ó;^+}-1)~�k9^UN� |r׵uAL +#į_^�wl"w|tۿ1)1]\o}ߣ�9^{)bRÜ!V=] +�vAsջAL +#|M~}Un} +�ݞQCPĤ?W1/Zy[<{�pwAUw[[W(z~?Ia 3%-V�ݝLZ&sbRHظ,:`nݯ�};=5wiw΀1)4)vmn>w Y� r>gZ3AL +[u] �BrvW@ztg�`YG~ے<ӕvG@k:.rT߻�=+v &nW} �?'{sQ|Cn>1)*ѻzP9s(Y  ުDڝ &[=1eܙiN?p"wW"ڝ &;:!*`/WN�N.2Na.@`z 8n +\iU8چr((u.! dw%` !@hZ AgpIosA<7߷jD4uH>xplUWܩw�A'gϮ.}\]?RY7wî[2XCޝ;mﱲ12�LzV$!}Yĩ:9Wl6SfKKs‹IWkhk8Ew3�vdhjw?AnݭWλzcd-#gvѾD_*=;ͳ·3?9;vpI7;OR kUxCMj= �&^؁Sҳҷڝgb'³*.*H{_;zF/^2kVk}@s3'f?*o'E�H߳z881徏eol/ˌ]G>kK,Wz~un9+}g ׎/:.o^w펇?H[}bb\J8= &w'E7Ѥ=\%œHo@,;0ϲOcΐM LMu3sۻ^o0Y|4=f<im(=ݒKRo�Eҟ? VIjw;AZ;ݺj:;t͖Ғ + W[eR mw]omϟ78SoNo겳p�EΖSNo2y?R7Hq+~ܨ.폴5ؑuȮ.{�bI.y޿^; N˳ZvDYYW `څʼHLHh;~[2X!A9�{eIo՝ Vrqj֬YcNڢgKK = Fnz|Xp.襁'ZӾ ٽ,,Hsiw8b 857kgȝwwUv{yxh}\nD%Ǻi�dMrj7AL +7")}D'�DS,Kz]QVzS{Ĥ?pzX[mg+k=)<�8vg#6?Ia%]5oONվI=0evW#v?Ia,(˟=Kkz{�p^hXOh61)[2X7{-}�$=(}X**шmbRhIcUcVzR� w8ڃۢ}݌ &6fܮr.H~� uGܮ0Z+c' ��hKJ{%7Ja1)[p$譯� } OHIjw1 &ro(k?z0Γ.�$=wp:_0 Zȕ: +]m��|]V݈hiw/ &֖seg?k>�;Hz)ڝ 3?Iau6ZzǮ OTO'�@K^~[X&}ݹ0=sRʠȾC%�%H{Aߧs] s?Ia _uor^~3�@K8w0gn.k~XAL +minʧ¾/I��7>xWVAL +mccV~hci�ؑiYcyHiw+ &;'}RpI;�MJt;AL +ykfR5ݷЭ�EǴAL +Z2=;gd�4ǹ]ޚ^v"?Ia@MSZK9;p0٥�kZldKiw( 4ujK5A3�ДfZvw"?Ia@[ks]J>g�夗vvg">?Ia }Jb8Ysy'E�BxdE%AL +N1a͟,^˜��q`柤ƿ &'sFƳܦ�nxQ=\1)8Iǩ;p+Qv7bRp;f|w}7O�/[&ZVM{<CGڝ1)8Ccuႃ%�A@?}=݅%bRp+^=_[RM >ݷ-3|y\AL +NYW=#hK�ܮKL/^Wb4u.Ȏ؁^. �3,LvI,eIhw]bRp.Cpi&?Lw +�HH Ihw1)Ă9)V8hghh{OW_g1)ĊMtUcB~Eu_q� ZV+65ccը5 6:"QA "o1B%%e} ,U0J}DFqRQG!chW;4D~wg3u{YpWT-�`hˮ\y7ώ JLduNwdAܝ�։Ǎ-'.ֳ Y?Pb*6>qB; �XK)9S;L +Q,k.=/ma�uyC#L5,/ +U,_AnY3�`\&͍8u3 y T`B]:i|r`�e0ˁEf]e,3 y T`Ƅ/J +yKWy0o�2|9QhThn]� %B�k71ҕSUNjb�e@ڨj`g@@?@ Ƹszӂm� 4Nժn_М`=�^JLb ׮Q8S~�GQP_|F  +U6YC�AXYgg=�^JLbg3k �Ze*i<`=�JLb\>m1YB�0*`=� +Rkج\7*dh#:b_N㶝YC�04]J}Oz $%=-˨Wv Y(9Q!ʂU|?z/mUg@B@Yb.8yulgZC�1$V]ڂ=XG�08_>U#{!,٫{չkx!.o@7{� ,kxMFd+%Vo{s^`_sOvzطh#z;vDm/=ޗ�``P?S_'% f(Kq|vb$k �^ΣKt=@?PCQ#kT]m^'@eu>`KB]T]YHx XO�bw350ؐ?P]KߞGڧNLbh&^y~Kw4I<۽?Ю. u[(�x>Z7̦>F�[\ v8r3#>Za^Dՙ?*TrU]97eVԚi)�蟇ݦS*Y@NF{ҪEor>z\P叩&x3%ʺ�cb.Noz;Ӽj + +�F}JJ}4Q!>UuSYf9eA뤩|rg�&Iԧ4�j(Kn#ڏj߈:iE&]K 9uNaK\}E}lx{�tG}I[WIzf�ZNw4Vu鄎^!Fxz hNzaX[�?Z7̦5F#{ C@* _>!u@`XQyW_H +n龩ڲZMfQ}uⴀaϨE\"{֠H6}J_87*ΠL7Zjr _گ,hėԧ<}&I4aN>gVխ{:B.yFN&2ᇶ`{>~tB�S Uo7n\w j4g𶊔%%iKrAo47v[\>rZq>A7퓵^M_{ekXA?59ua=+s^RW_P<e"Pj"_1׮ן)skB]xxmRw0�[C}}[l:ah#%�JL5Tc|¨nGnڣ< Fr=:MZUQ[LqN_zQի/Q–p˳B[J}MNóECw6'tڊμk]L'>oHxŇ1�[Xqߞ>Y9_lJL5#ZbοLYkGﳽ2mz>O폝$u^}=Rה:Mv晲cȏ&X&}})sg$stNާ7L^ԗJ¨4oByD}&clHF?kMŭ2�>~ H�`I?PbgU]=*c_= ܫV=Ӹ+~Cyze3h.KҔίszYʓ{,LȮZP~uFڲFAsb7s= +sksw:|Jb'v^\ k zYeApcy y~ V_oc�%A"%iw*4*d7Φ +_5*j�5zhHӦb�<jUH$jxqE-r첷مvwH/IFS/Cv\ty;^g$=חq:̘:euqaa >B=/<gU{l)5ݽZSwg9m/ODU92 5;-naL..| bu/Exu=-"yqG`)fo0|<'A ֛J8Vmeۜ9$OŶN;{I{Tُ=�ܣPK- Y"ӏV_Nmp˳wy6XcWG2z A•]eHkAb +wϳޜ䰧)8}}3;|)8 +Lklȋ;^yVu>m;'[[5//YWg(w|=qeWkmuO<{us чõ,LX+Ykyj AF:NPx=񺺱 u+q#;CLcځ,)Ґ<u{zuV EhrE<n"x7c@gVDqz*g34;Z- ,}{1_:??/ i-9;U1pÆU�/gk<Io2R}qvr(qm#CL1lC#_ԟ(jEcm̚+\덃z=A./'W[-:|`u: j'~ @!|/:= +-t- +pZ-k5F*w_{*dhR :AFhځ5 #b{~_Msi`8Z M^} plDɑ[ΦLvMO\K5Uk%EP>}sèVu4B8EtC;/m+ % ,r~q EyI(dR6GV]elx XLYmjM(Awbn@?#ZF 1pݣ6.󷗧M,=;qߊZ¤kjP{K>vFmN8+8K_*-[X3Q9@X +&|.eph=c&ǭg5] +TH)h%6K@_Z<o4H8|Gq"ҿ?|bU Ӟo7~DCwŴz A/i #Hb=ϡvwB*˜?<5WBj+,}1uTft'cR0}-&WVW3F*|?ܫ?d"N8Ӫa>]cw􃜾d~Ѿ| :̘EZ2A!N beI^`M=<H{.|]5t>%MZ2RA!@ /9a3414|!AHK=(9 QɠS@DŽ}ATLM}s9TAo:d肴6dCLA^,^*FգkO ;׃2\4+6gq"iM"@!@ ! a\3clg鮿dD.DWy~1kDLS@ױ0-2ptGc~m +_!o}!| u+q!@!pW7#ˎMll6I53N*Qx4/eK?b<3JHCtI ׊|<DSH6б2V!H51>PLƘJZO0E'+P)Ƣ߀֮T^JnDb<EA>C^xb +w>17we<o|2q^ZbjHu8+Hҷ3hN~DϖU3 |>C^b +wƘȦg/V# ƺwMG:' +,B>1kIyV _^e!!g&%)1CL#Q6j_694Ic[S3B/_#_R ,}{3?\NUٍ-}cEuYvl*^K {TpG7"sɡTZ̘:,}]G;<ŪO1OKwW#KQr$kqZ57eش83?|~ǻXRw?ˋΏ̘'XF_ϳTc(7l~Rq|pOL d( c[t=HC(poҹ7\߫ʙʘ{Y뫳ו2]=..۽Uo q-?0?^[Tu P41]?ꬦk˶H Ըacv)3߄<sND{[y4hoȋ ",Z5H3r<hFc$՜ϩxi+1ޣVE4 ;.ꂀ +.;0{Q4Mʉ&iԈ46=idt":9?{Z<r>?G]cuB!xǔGH|Vk<͈:M1e5^H]ClWU^S鯯*Vmq쉆^Dp#j˯|^ƶ{8f@W^Ocnl&1f]fgcn^5kj",wB^XkV釖օ=&A(.>JNC7 *5U Qi~{;xnIz|K~gBtNWEh_O~ _~×|yϣG`m擮<5$}Vuu;=5ޘ{\ZR_Y!?Л^S꽸quJuErbBb?@%MO!qjǝ/AZWbV TjpC5sڽȌ~|r|2>6[%+~ZH|vA#2S +K5>Hcfv~kҵ?t @c{Cnse)3͠{d+&?,AGrMSqc<6zk}s{ˬǒy75qug c; ?GgGBAQ'o 3?T?4(y_]7L9kڮ7=W Gu̓Me_,L~-f \GN-2nߒXYAUeIRxuر}}+$|#X>2D\9Xn#\ܫWoܕ yk"hmUP{L}hSWo֩"ރtX+zqAtw(P-Nw  =Csu;k # +-N6# "1ְw LĎJ|[X/`/{i_(w)߇Z)[!a,ָ }d +e7N[5=31f"\kj"s}}h/ޘ?ꄛ/~/XQ�Aw_!o!AlA +x?c{8^>[9OG*A>X?U=7)22"a;{!U3I9u?e*g +6-μcepb\={SB@_WCoF?̿ @JMc۠UE:v/%}c+_H|.yq#12I[o~ǵ!~ǷM;^XxD,#?B_W:vﵜ8YN�,G}Ai38#ɬZ{FDbo ϻºhB^Pt}AgtZAt*Dzʬ𣣷v/<{LpO'Y +Fgf6 g9EGWxc [dlۛB` +:b%ȟPVYZΚڼͶ?<tP>\KOؗ|?`?SvZk ^ְvUtF7rۅt|<>=XV:+kfsTjp}&qA7Z-ff :Tl%<_[]7Oc58JJ/'R8;Z4AҊ^s_mط +P>}>Cns?t% (Ǯ5^;~lc܁):J_Q<d+Ib(TF*{ ?2=T bVrXp~sH/CYܕO7Z@p{K<y@7ߜۡ#k? ]6A*vOύH%Fd.`݉ȌhjQXIO$.R8}񽉚mQy=-@'=x4t@GkMq(P5 H=znd9̭xy%kW1{kt)'sK/t@7k PRSk +Lot ׭eX  +~{ 4.>@> h^Xk ;W,Ƴ}_l+z?<< f-ikc{_8�z.脵V x4(Ps 1Rk-ֶ;DѰL%C肵6 AAceV#~_w;j;~c {oL<>pm/hm@HD@JME k9qc6#mVtİD'<q8_m¹A *5P?Q5m÷~_k;e[;3+'!w\qsW`5 ?T?0Qo]!ng.`雷ݩq ;BPRSQ r<ǮE0bbK.ޭ,`0NTDF5JD*]mqXv^`E*$mH#SI?mnn=p<{>|{DgΟwߴ}v󿶆z)w|1E7?C>,A!�!AOӗ'5.<{X|#_oCBOtAMLYgU4\ӫ?rw15+Nv _g ~Ay fNtϪjq&<n=ԭxG,].dQ{jw2 _~6 W@H @ԟRs#~Q-Յ$'K}~Sߩ|? !�gh_?u$Y0=w!'e-Z##WwPlO=? r$Kؚ3ɯʡ9y=p R_» =!�g4`eKz!6rGA.+ڽqTJʸ-XU\=? fEU5*Zu\7ʇ}퇢/OJ'Q镏oԿsE%ʷ m!�g)0//QaQP9ec!!*ZD. +{ѯK']$'$Y_yI4ꮿ{c@PO/o8 #xz?�8^UuN7vHĚڻ.(* azV&{6 {,|v-eGҸiԇ] gOgyǮ'}a+l+2 rY"=;Y-n{jB[Msyߴe*Ӿ1oXu$a0~E~^7@<v !a,٧ 7rv{Ep{&| E^Vf''ʳ2k [4IoW۶{G/꡺>ꥺ-cиh|+NK cD,QF̚cOU+{5!=ت$dEv`Vޠ7To{Dų;IZo4~w3n|1قCף>t?/ݟ5άzT?>Cr`0, X@gڤ6;}R}p#lWCϳQuBm=$\]ѫ:j󇢨>{$!x gZ\Z�{}e4m rw9Q򓚳Mt +} \Vhku  m�8 Gckq]S'.XVQv"{c RAAhF6�AK +cS"q[BT [2������ØcGw=sz)K<HI}>h՝yUIҦ_3O)T:������`Aä[qI)w<jnJ)Q6����������������������"IKbm-ZugCUeN@S"a'_W]ը{wGZ1y +So֪Jʲ2qv9Y0k+:1bBizgN]{MlÓYSdWj&5i*JYjs,<}i޾P-WX 2}eqz&\ݭCiC yڏzΙc1p٫ZuܓwEosoE�~L;<]QնhJ_0UFkʚ {68"#>~]U"~ +"TE9e{YDGFw֟n�/ ^b蘄h-[%Oݦyr<'&uX̴&4eE7nJIע U/q'ӷG=1pΙk~'Ҷlr]%!|X$bz?7s{gaz}6Y-ߚkq_˲2YcѨ8_qVBJSZ-4:P5r6OmMM^. +tz`XUM?մfrwQᇣݦoKzӢΩH rYIXxԝ;ٴ> szYFӾө&=G,fί 3x \ >]Q(p+=QxA}_5o?HsdY˚4uwW%xQ8 #7:~K۶ô>G౰h>/+:rXJ[ ?6+2 rYKω%4kU/ڲTF[P#є'[o9e=HܰQG]`/XǬ^csNNZʞbNlt#Oc׮3{ A#u+r½==pسW5F6QauO\z&yՂ%pύ[muRv0.λISwE{gx \u5WTE1ۧo?7V�ۢSaF@1N$PmձeFV%αZ JK[noۂ "QԘmdn^ 4}<}O~6bt|+ʸ՝;g=`+-.uTKs'KJ',M]oolX{gxb=G,ɮC/ȸnߊлQ{f͎R垦[õLG>@ٜ{mlxzM=5eả~<g]wwϘ6}p^SOӛ?:>xbh[sgbSM?=2d}Ew4ԯL|862/YL&#vH b{m˳Qdc?(~Okݾ/v}<vUr + +w:ڎ斔d<1m߰1(_DNeG-w})J3[u8 + e ^qX/ϴBܤ<ߒ/c&kvyd?TmeL̺8K1F?'=zxTȍɉN;ҥO,xkd<7/ }-/{^c\mQxWt9XWf;p kz.2f2 疰OMKϾ֫٬{_.O{ 16ƴP>KZx*.*ʘMi?2-Mx|~њgg[-ڞ[/$LrXQV>pn˘[x߸ҹus2f2h_ +}G~dQyKUmޒw۶l!Ɔ:[kf]{]s/ny6w:ڎ[g~5qqSkcǯp&=z;#<vvsHud<1ussE^쫪Ù5[ur}z~}@Emem7=/gY[R:NL&wT=.$-O.}8eqwwsʵF]3=P6'Jk?i[(.*b\p6)0iշCRGL^IՏ.X+G[e EZkS]?=_ +<^l^lUz?s7^>g欌2���������������������������������������������������������������������������������������������������������������������������b��Ql endstream endobj 19 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 35850/Name/X/SMask 266 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HoUb ldR8۲$pn@CPIiiԶp2%K|2'c= ){_䓛s9~yG�����������������������������������������������������������������������������������������������������������������������������������������������������������������|*Dgxz[I}��ayl纻R}v]S3[^UzWʓ ��Ƿfώ>8zhSҽ���a۹ek棑᫋k֬;��Bm=\칱,rgNs㲒L&��|gq]_y !=[&�� cYjgcG_p_R��sƏUp'Uˣ׶o4c͙ծ=R,XRJ)RVki1t8,,-k3%UJ)RxohyyW\^يnV珚Mz#ˢyXw&݃r9+g=- ҢrޟZ`+#Cwݓt<+au$,g\sqqsV'ܷjl6}p]L ^zi1YqqpsA 3O/0WF>?:]۞))ty.猋s3.<gs9be'0g\sqqs �n5Bb�;FH3�@y�H7!1��f_#$� k<�}g�t �n5Bb�;FH3�@<~2V��AH&y}w�db//& ��7?<ën�/?<_lM��n$y޷s=뢲[� AH&yKùO:&��_?I<7h �/o%�@:`_#�@D��H7��&� B"��AH�t?Iqx닛&�� NPGp%L�+B󼰴,~ڎ'g&��AX\G[ho�:L5kV><~ +�?h/V3m�pAHngw<Y=sw-,-��v$. >yٻ5��"<ϛ3g:� AH3�@{y}P��vx}P��&?v۩[Ջߜ)tEwloٞ{-C='ɿU˹Oy}zoбq6xsqm}@g{m~:۶]3ČGڶުy`8ܴt͓թÿ{jcQ{jؾaӌSmշݯ}lj,Տ9PM7_[8s46,-sxd#-ݯ+_?)qB 0NDkSMiF"on\`gyPARitf$V7l}>˃>{xzLg ukMhw4ZMY.?>bW_ٮ=v^u_wz>ܴY7KMST_TgbU8o'%ywrg +um,?;㫋^?#1I-+yNLyb=/F<$5_WYrb5ߧǏ*:œ_;GCC{֪Uc̸?{ wQ`#~Gt+#{P:WMoO?5Qz׋usˀبOԻ^Lsdgw79CCoxw}0GC :̆߼{䁽]49a|{v[gNzb.>ҩx^~:gOxΈ3הLd´‚3)_Y{Q#G<CvFXݟtB4;;6؈.9v0? ���"A&���፼p?��7d ��k 3��@x#!R޽;{mmk=���፼H0}J2w���D."A+=M>hi,���D.ݯ^Z|楦)��F^C벶^l(/>���D6Y^斉7=���D6•?dmF���l5+ˡz֫~|��kG3fzK-~*YiʕKNح:.&fu㬯 -+1$���%L&rf邅G|`~c..3:Pv7���ysZ.&!6VywkfZL;;uuzK�� ^ODƂnk[{cCz{��`|DN R11p3���2'j Z~���`X? a\m>���f̠@&1^wn���pDN@vuk@s1z��� L4d'/_,&���'sZ|GM���ẻ"W-@\25Uk ���b^/VoN@T6B~���(\6m,r%s@s1z'���(ʀ:d? \1[|>#1���LM1˲SI`X|hk<?��-r/*D? 1iǫʀlj^���fjlRdz4u۵^��0^VK#2?Js:]CF��`f75Pڰٌ[f~*���L)%yO2?^>u'��|#²M +?رD_-uۍ ��9,ۛdžD.@6#Kv���̨Oues2 k4F��`FzUA-%ki3g��%rchbFkw3z?���3)߹sklPXK~}Gmle~���f_"E? .k[���̤i}W\FLbgݪAMk~���f"Ww*XP,^;;��La^j/m<W4Y^?h���fptϞ$~^V@VGtNҫ4[#��t4[:_F1u]TgF��`uWۛGf2d? +5oj=w��0 +5@fzc}}axo3s^��@jL >޻7=��dv</o]z29JRki*2zO���iJw#2bj8o'��5횫m c1d8o��@f"oW@v{u/?7U��h<6?مs*,w��љ_5*? P#:']w +w��Q煖#=/b&TSuѻ��Ȩ{ՕJ`<c׃ѻ��țgZFd,'} F �� %/bG}qV7;VmݼzunT["ZxGDPCn*r“' +[ +Rm9qC<I<Iq;]hx&jb����$Fn[ja�{cA󅚻Be?J#���luu6Va�{bI |_)LMѽؿ>���M~*LQOQWQ_禆aׅ֬gyt70V+s���%;PGmfW6eF~^.0yoƋ}����@Di d S[{~},ݗEPSqڱG���`ը8YuԳsߥr/`?ޘh4\ݣʃt_h1Vgߌ 7Ns����X}㩛xhV$sk0`0-?pl^fJ]"4#*bamΜ#\Rq坡שqS���ؖޟj*:4aԃ?ɢ c{|汴[ƍ +UcF!:s̈i:^ {S�2S���JuM/zW1آ)e$Woa:Su #}쥃ݡdBy-5:����6$-"ԕ:zy?]ihQ>N?䦧6M?3<|٤n~:+���`Ιkh.vz^/`k + +E|z܅U!)w(m!c/jxu#���Xꡳ*׍_m:ɸVJSi k%M/=c"GQ/gLIGs���XE+Z6 ThNJ�o g*urbP[ϙl8<Y+dߥ} ~���`6,P]j/QGQOmNA>}Y~vVa>uv`__"8W}yQ9Wʾ<``���J t*FWV.5-?I6#-̩.?#)/;?R|Vbeʆ'}bcOWOm#���Xq;ĝj5SUƭEedi?ޝI'Uzۤ׼?V7/4;G\uw]$B6wϞ{j����smO@^nQ۳g^i?cyShkڳH7Ngi_ϔo&|y[]:����{e8yvnBmDTniS? ;{@~rυiA3%hW}X"tK>eZRt7����]:zGVJ~ĜHu2aWͦ&HYJyeî^]����*9;UۄwG RMa7=vBɕzjX92D"q���,sk\Z(tl>0A3;+n)s[3v����:9徭w͝Kc,5At`4ǓYCʠ蜓q;>/���%$~\)@OuN4oZ?Xbp0դx"ޭG����NSP<>PZgLVmꤣK?�,Ќھ܍Kn-̝ڼD}bHD ���` 'QPuuRG: K4+{\2'ƠT*���:WSCq7̟>yVluъ=:X?Xr I ( -f%c~:' ���뼥5-rc:^hN% +K|<5wFR>{X!I>8���@;QP4֬qP)_SQa�xhzo7;Y hL���.Ϝeiv7ޖj+`O:c VX -壊|q_���Xc'T% +ؓ?lveV~\#&sn֟*3 ���` C$zG.4bMMg4?yfyAU>?���9@C=ӼoCCc3\W6+wI%<]/GG����&M?ܼkswES?tL_ʏn~OsW1V+A���)vr(w4~j=uuA>9wzo"NV ����~5}qcjN즫-m+0)Xo@_j1D+HI7HĮXﶝ +Zݼuwv\'z}qL +?'tl%𥳐Rc(h.ihZS}_1����+j gnt ;msw�|?Ot25qA{Cu_QnDw@����GwP-w mQl_vO3Pc&Emwi~ѡG���H)+W4包}P?@j<БUUˣ]rc39[x���Qr3'RP6 k.UR#zϺ5AwNqvYP_ =����7')='"G!<&*m'6=ؗ{D����۔@bXj:rkɯi?a�A',oYlpXc{����b e-9F-TƨgV]' HbFAsn{vof35#���pzם}Җj:=35?�;?dik]Xحbr3��� 5VjSR6 uLv H cr{ߴ$Lt9ƍ{,���=7jWK{5as\nRc#+/n=r<u0fSa_\.���J1U[USnRkwS7+t3;x���)NuaXqܪ?e~`�x2VS8wI|׽0l���ZdEQ(t[_c�<^Umk^~U޳��:޾*^'+-)eyn& %<k"Q\׾5O|693x���o:;Ěj:w;2wP s 's-N05ݚw)jO=���_jK7i͕:z%8G/a�)"}[*僝'"��@?EO3qحgVR{0Jk+\5_Y=#���wol(4G3I_uAQW+a�)#F7TC,:mg���HCu7!>NYw �;o?#Πˤ:f}e秩F���HۮS߸ZycQP>xAguWak\~[^2���Hu^wu yvo?FL-{<q,=+���K7\ B-ی>N-ܚ̂zuݷ%4+���HI]axW#%9I H7]"wN 3g���H uƩSԜFRM"CEySme%{DZ���HK]Of{=k+ + 2m8E>WKF߀A2!���@"MtE箧vP=ݗ#mSڤ0ь]0*T{v{f��� I~:Cru 6Rm;_qyvMxE>z0c���:njڟ{:zwa�)cHf4{: ߃8NVۛ<��oۻuOZjUgb]A۶9u0Gn" E޸Şݿ s3;Cy���|uYg;NA{c0w a�#lK,AwX"c_ +e˱���h4 K\A矧WƚM-[:;kX͕{Oj*,~2��~xоl/*e̢W_qGb۝ mUIѲݑS_}x+лm3V}h^Üs<4Y���srvDZW[йg;b�B+-5~C;ڴoyspD8U[qN}cȭW��Wfd?xS&aK_<㴇|y_yՒQ27`{?n���n~8#m. 1fA{-8 yvJ 7G<3Gpritw<ϫ1/���}{⮘ SG|CaΠw`�_=Pa}3L7?}RxG5[aO1G|��1f;SqOP_ϓy/9VY^Yspڇ][/;*3 !P@TPе +XPD`@ET"RR m3u(j5kY o '5H29w>=[)C;jy{/ćd @K9ډHOr%\r%prC,pN }W+bșG?N:,fL|c6O ,U3k<5UOrRP@:utad0;֙. Kp_G'J])rNꡀQ {BǥFy0vA#EǓ7128Yx9'vfFUҳ夞/=]+ci`ӫeE"U+$2 PWxBn)g+|8'(;yLnfDYvD8=)*7C=xD __p/oݮ4] +`6,[.%f)Sa>i뀖@UQP>bRVRu*t5GDݱ`4�0j l^ +\m�o;{ W}^vRC }uB/=9q]IjQߊ +K,^V)r.n1. \m*b ୟY嵌|<> Wӣf$GFmgf;G˵),=<,ܯkrr~ffyk,T70[).0<7iY~ӇO-Ɠl p#wٽ{د!c3S-pAe=j;/KnW]YsRx!hыؔ[#C|%m4I{DiL3kj8nVz_M讱UmdEղUa)[p#1|d7> +BNc/wýj G=oMgӑNA2^}ڹՙ*rۚ]o3p0ѯNy  +y vf/̴ +ZJd&ȃ#0 +n23's΢F0c$H֔kVUY l$[.^ +V #7c4K<]xԢ4-ũ,;}Z]|:ٜd}p^|LoxQׁ}PAő=m{C$;t:Ka^BOoæ v_LE3"P?p gtլE?4l+5m7~mVB쯧-,eKLa1zE~<2aAb|: s ~ ihJ6%&F?w 3$r,G@@j֑8Y'Jb2 { #Y}lAleFjV<?/BHv.dRN +-_G'AM Q* YB. +#?Ve<nL`tFg;3k`N&\;L>�?9O�+�psog"[m� +�h9L½: +xvbV~^Xd(װ%m;ڃLא.We$G>ADfp +k_MWqʱ͹ߘao7 ^C5紅ic NkȜ,|1,0IᄉdvхFA T2(R(CmA ENTRIj=m2 LI`<m:̙ -W% |]<k'۫~ jfN%Tg^JzVk=^)7>.ɿRoW1tyz!.K,w{ES~dst'JN+I 70 A��κŻn3~# R{�Ia%3{Th@Um#w!.`ߐRV^w^q;z^̌&`tYV'{ P39f.=+yaC8>!\M88e私3 oq)^t�s45VMU8Z +D&gr!bTJ)p~3W Y={HĞVB[#'3GlEi 23fy}prVPCʑmR^r+}_J~ro|=<yKl3/ C]"8`y,rK9uD\myKe@'ꪰqJmD~DuC>|.߇>p?oj34)~*v]F}|(isA!lftZQalS(?Q>Je�.yN^_0w" +O~UFq_g,#Dm$z2jNp)TVUPW<jV, +Vx/LC! ` `!VX_̎Yx3?>s{gDo ൔդ 03c +1zV=^`n_8=Qݪ.9 iY'#9S$>'-4+9YIŚI|(�3a''"00*rZVR|ZZ--WUA%,_N{{*L&wG3�dkTEk 1΅pKPi؝}nܹn paž@>kbì =<d(ǩ/7.=͟}33x^}x< χ;6_=`<\|[* Ͻ@mp^F/-b] fqI%c=E`mA|K+D`eߘ}= l{đP(-S]y/uD\8u!rD,P+du ൔށv;15>;^fI1}g9?O~``{?&/a4z6ۣ[\d1IAn�+.N>QФ"U)VHＸ; +qU^ѳx~K_:}C3.*ٲrzP?ZwuO<߁ O Ŕcn*YH.y*Yx`~˺)-UŞ-xZ`ĸ~=z}/ K9f6 ָ{rv8<+pnGwbssпjvpjtw; h~!'!F?\9QU+d]u8+)>4)2…d=taJ_ I'XD{ӻ\_.͑Ta`m?(-Țx檭o\K3jOAg7kk?�G/|ž`{gd%m.j/Rz42FVVP Ã" :>i8p>cƢyÚ-\|ReRR sSC ]m|+|>SЯG/03{wLf\_#̺ӐP:cL?zτ3 +ɏ )R2�(axl2w &&;읛PcǽX!<n?3\_Oq}9ՆZ~ADk�N{hC� zϙc[rS?crKl Hnhta21.Xs-a n]݃8 +ZZiOs z~R;׻hFGNCA1E@B3s +]͙W"aЁwNˋ)/:E~Yo +U< +Zפ,rx7wIGz�%F{A!,8k+QVP8ӠoD5V_ĩIֳQ942*VYԙ"$`[E0f=Xp?_φÖ9 T>dah}yXFF!}cG6hޕF]p^.2 h;=�ͮҨoė=ϲ$Yi.+yFMM>ϪaʼːP:kL?EbZygֻΝS3X!yNp.9vuI9烌g= 0"]P>}'ڰK]:b_ Z)W&0S>S>,ŕL% !l. w{sXwJg)r4G\1u!YHAD{"!BA1upK,Y6  '%,/,:̳a]?(=]M\tB%FADbn*7.S令 [2oAA/j,֝Bo:)%Wn䳞qAA/Jb +rZ ; 1 s6<G}&s  A9FʺP(t0 *7IgAA탆 + Bz{BAQ =)VY~A/� \Byv@BvjKGA[[ ByyZ)-_~A2"Ύ r: [S5gAAlhҭR+dFo]̼P(/nz>8~p^l4^j&ֱ fԂZ$NRcbl$j5\v.. M"V'BSid$ +9gO9g}Vp59��ze;ݒ57 c��g}}tdu雄AH(ISa!?�@P{_*}?i;zo0Y��zʙ:!_v?´,ghIn,��=C2Cҷ,ؾjz}!��^ɫK BڏG`tfvYΔKD��нN2Nqo!GCXz s��tK[ݺg"w#}{?8zN\%ֳW&UIF��=.W'W;^}ۃAH{PbM'߱n|��׉eZbCo!we}OQ ��{7O'o!w*?I{6M~N�CuWgIB<Q7gkնk_֯^'=+�qj\>[֠Y??->`+��Fk w,1x# kh5oN,��|sr+jl|A1RP޵e[ZM��5j mg-t.FSֿK^"=;�@nQjKB:%4;P)w��!i[ivMA 1bxrR?_z +��:XY}o +!5Y."(��ۇg[AHb1;aYz/~3Jz��|1j?/}K?Z?´tg)B~�}}$e9;AHc< 7&=S�@nV3[^!t=FQaZzQ[)B~�=u+DoAHcI\_\$=[�@>/l{@ bv.JV��К)BjKs/}@ b߾r7Cg,��?KC՞b@ CDi2KR9 ��t$BR@ Cma[!;|f��}f @ q[`t9 =k�mj/9-՞ܙ'el8ܜ8P\p’_k?4yyǚa[\y�Q{yQoiqv'Ur_|xuRe}񝠨p;NK\��ޕyƽ,}#HoL/mߦ>E˦7xm~_M�fu>ҷ7_JU!wֹ9NAS"+ �Q)O/pZ냢oo@ @??V״B;"wISJ�hpwFKނA|%q?'=ߡtfsOH;&=�0b7_>i/B'i5kTGmK2Ʃrik?9 �Q|e୻̸ҷ7I߽49UYݩ~~[_:MsZ.O9,=�0#jKބA;CҖ}'xvDPm_^K^-2KŖ= rڟKI}Ɵosn<�@ݺI^0^ԝF ޘA\[eGÆ{̷cqҿof`̯5zrurL�@j]%ֳb�Fim W+Z]lmq?GXMklE-#?�+g=޻һ?7Ƽ=%eˮ&Gv}fl9GƫUHf��ڡm}{A]Sa?lnbM'nwr|�@oN[%&;>Tz{+Sw7$vVn6^I��͕IU={A[DOx&jϦ5~s��޳w7=15G2�@/WUUY]DOxnIf8>I,>�uM)!nW3JxoG z +sKiEN33��_wʕqaWUz{;SkGs��_u=>=9AQZzsw�WՕfUTU DOtދ)oov61Pz~�kn=нOw=yZR]kϻh�� +7kKs/fUQa;W?ByaCg9��{Usw/=5QaZz?-8 Ia"B%0V/ +Ni9h)$FRH CQCA1@ɅCwsddñB3Аx/xP-gaw}}f>a~~dx9��NRus[MYt˭tڹQWc{K?�vcn[;7QVt:\UZt*(\� ZN^n.-n?8pFGwqO��DK^xtt쏇gܱa},U�@Q}l4= +.lbp: Y9=^}W2H?�6PttXWQ^�-T~Wk^eJV[忋 +fN~�-4LU}'j+cp:#t3 5=g_� MPuq{ttu#`zۯutg>��Ү̛(hcp:#r >��RTLo[ϑ)f?8Z?Yzy{Hg?��R.4/tut:Gے{j?�4?wߐn.N> cԛ3_αK7��H;xz{MY0:`z͗���Ҕm +FIX'NcGQF}u_~t ��Ӂ=}3kxut:G؊W?0}'{��@ީwEnnNY _t��ET'`ݰ?8^雗&@t��s)Iw雖nND Y<Y:Q��>eժ{7&oN/H'��Bs/~0tsut:GdWXhzZ=;�@WnN9qϹjKV��*WdMS}K vN:cp:#rr۶{|/��xXӍ;lϑ)Xݱ?89}̗s��a?|CiU}nN΂~h|7��xPMنz`t[c<wQwoݗ_'��@`>5Rtȳ~>`:Nڻ�oKK;,ZtSc4kr77n��cc]=nj`p:CFs?$��׹ʔ$կMK{J4?8!#6(q;ON ��z|{uYtKc rIPi�\>_ufwnhap:CV~3I+��܉U~EZv"ӱ?d Ɉ ~W[H�;z$kUJ[ENc-wLo}�fӍໂlϑ)Xt:z�ZUuJJt谠,hˑ ��7=cC[n۪P F{~znTV9hn ��7֢a⭌e.گ?6LCxc^8={�݃z.o^,X*ںr:wY:m GN +穲T��bUwpG.'F:Ըr?_}|u\i.�@2{t$${Φe3֔[5޳d�{gFi92\%{׺vu3Ú~ec95^�b֔`KMu.׹Sr~i#`z[Sߟ?kGkĺn�Ď _ǜ5/H_cp!/LmЮv:ϖ 3ʷna]Ijw_*K^2^G��ިݟI_cpᾞ3ޜw?$$#R^+ 7'=Ac<ݍQU8&oYX6`~lo&�w!0΄I ew2fN r־p#%-3IK��}^3 ՛`w6IRi.>nv[|sܱ}!Cgz=qRr2쥖n�@_.PdV*W.kpmgwmWUϓ�@?2Ի@۞H7rs}~zkQw8(#(�~N7??9oxp{NcXCf舘xN�V;^eJwt:5t(q_xx^�O@/3ҭÝ?8aMTR�K_2./+Qq;ӱ?%hesƟ.-�uUeI^EQtpoNcXٯ<O}JڙNuvgv]JQ]̦)kƥAiX4dQ B7"799$=enuIZ1J%$>wޟ2ɧV||nvw�B׍#KtHmx21)3˵z@V/�@; &zZMo}S'wiw� رvzĤ?BӨ9/{^/J��~cԺ(.C?Ia&=5KmWH>�8FjQvvĤ?BWy#=4�(^<wzfĤ?Bیͫ_F�p/IW&]91)"_.?TEV~�GAzBBzCPsbR/z]��slx?xvg?Iaaٖα=�p`O*<=1)3m=*�^" =UxzbR昔a'yW^jw��} qJlĤ?,u+*;{��=[A?ovGٰ?Ia'FʻGGiw�@c.}/RĤ?̳(z`~�遅jwjyN`}s9]vv�ߩ{@@P;Ĥ?4?ͶZj �|gKc6oE=bRfjJ++/C�@ݓ{/w]QNv?Ia{D�@ݻu4ivv?Ia-`UXߋ�D݃ &aYB#EgE#�}/ۚy2x>1) Y=otH�@p'^sP7Ĥ?Ê|{�P{};5;bRᕙo[Ŷջ�P{3ջuAL +#|K_;zK�(c%AbMb{Zk +7|K&�/ Ԣt &^:$ v۞R| �xz;EunAc?vw.͵�Ps_^}NČ%1)4-/#{�P}V=_srϵ;AL +#<u7*^ݥ�vxIsGw G} +�x_4=%k٫ &Žne>s_YW�UfY>ׅtYl/Aboޫ7?B[�UQ>n bRHؼoί.*B_�OrW `sz[9~޽k~�#wYshڝbR}kLZ�wnJ;xzĤ?p_AqgR-�D]bRE|_].;%˜p&wXq]&Y#AL +z39aί{|8pߣO{؆�}bRx\a �HoV p1)<)-(-9sa�'rw=8)S;㴻�ɝ82ǽfpVMz@88trwjvYykw+ϗYk~@0[ڷv�`2rosr;� NMw# +OZi#GGN>"rURˉ7OEc"+/f�0ٵ%%rվpqbڵnc)(i+5y'L"vk�`?/wvRVrggb'&3)^hָ7mԨZϱ?$MzYk7<'4�Dj^;+VÙĉ)H-L=pU;Vw\:mZ{k9wxh�==#NsVs?SR>-{cOS[ iyr!>h[sTרuIQYshxw�)Cȵhx8GEFVޫeE҄?}<ilFs3Z,PV>۲.o;A:}~P=SR ^~'BޫS,j"j[¼Ήo�Er?r +'jv8uZx38:5n|y93"4x{ ڽ-ݧc͵cM)6E78R&7?SM�nH;: xOo:Gzo2;A̿/ ݏzܻC׻uD #[pw7@KZ3: * +: +cV[7$ N$p*f$&=w]NaLR \z!w™CC|n2>{=k?)�7i^T<׵!w8-^|IvDkAnHlw5ܪ,Kz<9LT+ΩC.Y?NHZ[2Ǧ~|Xܿ-Tk_><M�7|hE(ޛ-?]pqjwfʟP}[BMi~~>u�pxojw7܇AL +"9cTЅjYw{zM?IaAX{ӻK<y�pEGIKΆ;?Ia=_3qyGO�'ubhGI{?Ia,.IuO%i KN١K C%i wc@{5ڸÿ6�M҃҇呪=ҏ wc@{qVl<ϣ� =7އ?OUf۸5s7֐}�tTiw2 & T<.Z/E�t]jw1 &3sU7� wpEOzPa1)t珵s >]��Izaz0 :Ҙ·uDnm��f}nxiw/ &gi�xa|ףݹ0:ڣì v]8R;MN�$&!ZNsa&1)tsFZÁE6/�@{>;]9Ĥ?YRVv>o��zCܘ]*ݱ0:ܪW[}}7�egshw+ &H VIdSU]e�p?g[XQtf5nĤ?yn+?]9R�{!udcz7Ꝋ & 9'9Z[վ%�^|zdqv"q?Ia@Ko y{7}O�ݸ~0u֌;AL +ZOb- Хe} +�)髥v,/EbaDzFXѪh]8r`}�AeIOI_Ioiw'X;n<Lտ3�nvg"1?Ia ^,ֵo>rϣo�>j~ljWDbS{Ŷt�D[CIkvG"?IaI#cvu־;�$k;>xS`<2}UWRg.\�HLwbxI/iw# &y2V 8?hڑ�H,;'[V]Gڝ1)8Oޞ`҆ʑ }s"R7韁BĤ?T)[X}�H ׎-J郎݁?Iaɲ}+yx@ٮL,}3b AL +N}k]:+f.5>}�0I3K ;|Vi*Z|�0KYdsDFaXpsI +�3HHHHhwUĤ?/TcE6Vnn#G^$AL +nfv١u>?١ +?bRp%7{" >=Xzdbq~N(|@yNdN.mY?2}eb[凊۽q �w^ 1)UrP`1;tJd]$K_l-˗0^?Iaze Wb3~�p& o\zC{ &3e2_~S, Q,~?Ia<ֶml?;�A`8)=Ub)/LKcZ`@W8˒>czgzGAL +&yyECvÚC�:zwa_,MbiƮ;[.A�:)>$=?IaDyo!�K~Z3]qj +R<,/>;U%y۷sо�t'r3w/81cvh"o1n|ͅ+jk0QCUnkJӾ�tt"81]2xߖPS/ްnՁ0 o_QQWl*T9iHŴ#X M' ۰a6 3 ̼ٗGU JUiLƺFws']zF'[79s{3{H#A&ǗRO=.C!>UhUF:Ћ𵒽?v t k@ + GnsTfW _Dft[A{;{C8ГcYb\ /3@a4zˠp~|wӣ5,@oRk`t } /ƏMq=c*mB/.~J|:&nGoκH 6ęH}OaB .3A& +<xw”jp3k[y=էq6W)3fy4s9} v�{ !vv3f 9o2qgO+ F?"s{=1 LɁD=ХlSLG +{t[n怎>Kd2ٓAѢϠ-`+3cGls" Sg:IƧncBdl@W-zـ> TtשLޢIzW.C83AL24i #}O/Thn>;dA^X8gԝOL>x$\aJh ΎWj!2 :v ȳ.A"S)+g G-FyU)rkyM4fy G;o!_^Y5{ N  .TS9M3B^꺑92JuAsGo% L|z_9H1h`h_W:}f&%2U: gK֭i_;,,X +k/]Ckڲ cOF yv3e +vse{#Iu,&$jnz0tċ+m<O"A^='bGZpuA෹_ښuٳaM尴W|ECu]{Π&&(7nuY#'W>uM^hI/`oG+Z_6/~9aI5hžg_{5qO(UiB՚ulӕY)_+ r@~ '@|M%g  .TtJQ3-AVD?ɁG�O|b-盽8c$0g /�?PD%RWߌ5?+쟡 +o nP Ŗ> ZBl?Ɂ79&ӓrg:tݧBr8 ʝgB=XgWq`p)j7AO }1"^dMQ s w Ah M\DהcJ z #V3I/]]\>ֵ.6|MUv> 8I#hso^Z3cwa/^'}3x{P:s7]s"gt爴t)n_H{@o3�A \r09&B`эßcnӞzܘ-B6&ZYZkt FCOϜ}þ E[Wp}"s{*ʜe_#*0>WoQ4)~zvW]7$χY+:bQ .?ʮ[b/@oiݱ}q4`p)�iЃ6ĔRX\5?/Z.S#թ{ }s2..{6Ce t[Y5dז:yڻ䍑< +7eStĖf횢XX+A*1p!Tf$+0l\{k&٭3<8"?0?֕ƻB7 c |?R*em =~1Y9#ysƺvC&k_ӰٶY?KUTF3Uhs,a+Ml*PƬ-3Jɯ>+îw[<5 +'~#y Dm#KEE<Y+ej:qAsSoNfEeφ5v2Kdо`st'U6N#4dƻ/EOlhaź^ R?rS=Bd&}VrфB^3j~Yz߆ ӝǴh]]}u##Kcᱭk9a2?# a nUYVbbY^ìo-5u]s"xf|x +Ch4-&E7̇Vĝvxxse;H|KJ(J.~˪`޿seC +tȁ%pֵ  .Ŕ/Ө(,&9$щFcfcfQ#FA"hA6i.ꥀ�ujA\[d朙qM]&e16Ք;^-ռ5k61`&sdo|.o^޷$9ݐt}; X[ @aZdN/0@5x1n=.gimWM2Re|)u5b8n@@@w= R1Rq-8o/VN wofGR-eKpl&X{SEZ�hev}R‰׳" ?Yнh~YHX []ׇ9K;اM%Mgq^ r y +Ed)RI8ɋ*Ѻܗ+b+؄aTwqMUk:vO}}$v/#pbǢtuX^U֤G3?睟u5e)πPt:,Jsv +՜v!N/y{>S dnw|Z+}漁0aU]X 4>IaD;mlc<47Fr6U}̐v`S{j\f~.ݐ.rSŏAۮqx/_"wI/.Ȥ4w4[׋[m$ݥ/7?b0 '`H)� +&1 ]? +7&} ~Ɓ7P6Vǂ�PӃ~wdIaڛNVvn<0AB"V貴W8T3Ԭkpaw\l=D7Q骷pz\vS`CEN>IDisAMtN_!}q }U3UE )P*-=خ&[}rH6B^E + )y<AXKkM抭Dlur:Bݣ2A!@ g,"ҺoO5_"Puieؽ R +x% $T󹾺sezAh82\O0A?ݓ"`H) g(UnmWEׅiΏӶk\C݃"%`H) 瘛IXXtMbCߵ:Ԝ-H R +oC !?Zy``ciE{[;m*>\}ܙ#O fhIO +#J2OQ׈q u y Ի= R[Gr}q0"ώ:Vh9Ѷ+bQɞES=?wmg>'iwθ $nD 9A@=C]Yʗk"U`H),C~d.zaƣ/vCe6}֡ T1!8FS76Il ?;L:nZBCJc:u\Mm/U' "=Mi{DX}UMtZA'_)< RxȧrE Gkj&;h[v@#Ѥ_S- 74otp5 ֎ֱrQ_o<0^C֎-p36!cUDVNۮ63HQ{^M_NI5/XM|K~qk}Vc-,IYĬ׸&s0iY,+Jxm3j`ɏV}jr¾f ";jT#K9ɳ۫?,LXJCNxz'7bP~૝4u!{]W"` 9X{nw_~,?0?@\N eam4? 4Vn04h܈1h]K[G8wQASUe+p]4UfYfs]!}?@Mղ]*!֍<?-�33u5K :t΋FXIi6ׂ1ZaN͚{K  {ÍHM NyIP 7xqGdOs3M-g ~gf)_ssvL7S|s7sc]{!)ڼF| @]=/:7AσCJmOD Rei->^Q,}5N2q1y4k±-hە !}נAw唓<+́(̇ykiղ N&ʗo�>NN/́<x >77+oc4u}vs->7MJ^ϲW};jsNKL[z3.år&KO>3(:o+ C ))}xo@a~ZJx_>Z}Vw!d|I>n/k߸ i'?gt +>b) 餩?<X/I2Lx%1ͺIv77f+V+1ѨWT<U<`ŃaFfz猊}P]5*jDkSmvWмoկj{zs7ՖZg\.|}"r)3MIw`wap=5un\.Mlaɡ'Y%!zHpH6ɔ}'A~�-dDg_G1/X>>>{u/۽\.C?Ukϋ䥛f =9GxZ-|O8|cznͣfdiMqd5{Qbai?jݹ-]�FA9 Q`*ki^<Q^52yk"$CFo^k6F>c V`;yHMXރ|toi PRS[&ųw!'^%X^yYaz^LP]' ("\k3[70Yx? [<`~rI9Z2NCqH\#+Ǒ!+?׭_ΪJ؋﬑en@9(Xo,/4@yoð6{XVj "~Ӭ(yޠ;oeEB @JMoNxM&07N4MU7yh-W'X 3+HX?WFVPf_lٵk Iym?w;$UOe?\KtO$erv`GޛjAoZgsGA܃GX~S~lxfyHKHrqw N!i˞M)պ1;,#m?|=?/)7zݱ)d93vcb&qxF=`neE!-V0fU �=AWtAwOPRScXP<g?sPހ `*_/Z?Fw.u+ 9myӴW�:|\{eVh:7 X_]8i]C{�m?.'o |u@\þpgmmVXW6Z6ZK FksBy,#=x!o%:>]A_/Ocu |CJMf, Ƽ`w A|޲ݛWgtJ>ZDrF{sV~7xC"a\ +O(q>}"rF"[+U ǙNxy&781܇l\9I9qb- w>G+#/)}Q'XU|}6m"kuhtG=V>ǽ%:dzMБ +]6A6>7("]gEaޙ0CStzhrцQH&iƷjai :a AO5MáA7z"L~=s닝Uwg#Ѽ}zZ`ks|. ܹ-@ @?5LģCJM=5CI)[7g&<zO*XSpoNo".du zɔG? ,A*5Ug8^b}u$!'wx>(XoxDWcjC{_?t�=@tZA<?T94Kݭ֛7ZNkZDQ@g"AZmY8tZA4(P(w!r1Z5#}+Z$mAAed".ۦM k-'M6c6R?W};kѶPRSQ ?u-'Wa'ؒ+V�Z#AtƤ-{*^wA䛾?6wq{/M<:׷G)厫#ǴP CJME :f=Udݗ|ά[[s8Fg%_[]_>A*5輌\%M,ץ[v8!&8}@?}Jʣ7!}AAKqS8>{(OAn^Vo7ƄOB(P([njn96]G6Klhz!/W38ߛ{vyq96@_Xk PRSQ fpqƼѢoatR^]M<q8_3g TUz?_;Z.J5vV~c'jZ.Yͧ$>(0ϠAă,\ӳV pҩgV=ZNigYLPD0PjzwHd6 +|n- ;NW]it.Yqq<Xkmwl{3( 0 zYU8,.LR/B{{r�Shs88O+Pj + + ~5qK'(@aXq%8SVmuEe-f/H@@q vjY-Sk~w b.}fs=|٩B2YI%fJ=}fpOjB9t(5qHH^UG˩>)6Fv;r3)?<x\s ;bFgu|0dLJ %'l۹7F/wv_k@V{5uiYH=S޿%=L&qxa0~x\[;rcaGR�΍Ιʻ2bz~?M&I{ץv ZydգoM~D|nnq~ �σ>ެcd3YK:Sԉ͔z}1xp=cf m';j|L-?wiÜ"<CշCe#D|uA}P' u[�q.-(>cԛ2]x\4參^p..*ᜬꝻzj9rCEBS|WIUm3ɠQ^G|{b>?~d~}PN!wfCY;8gzrϘ?ecǧa'sɂXs:qR; Y׭^#L׀BIݣg>|FǨ 4&!3 "3"?古mriLM]rY]yvu +BP(UL?|2hFkJKm۹7F.^HpvytIĒVP( +Bf`5ط!,�:$L|ym9#ܔ2AAqcW=&Ò%o^ bW".y{?V1JGAÀaј&’;QϮ=ƗclAAAAAAAAAqYIR tO;[[ĩ LL_\餒#w?ʨ?5ѵ#NzߠUWm꒑$.*ԟ+_wKP[ǿԵZQ'N_4Z=|(fj5͍gvlq=f狊aQbr'̔nl#^ʵ1)(jkvԔˁx_z&G0M?B'V]^P0.݊Fׄq%(e)3 +ds* + `'[ˏ߶d +Ie/:0;xƛ'݆yzz.Ox-+eOK.?~x@=6\;T԰揫N<Al:D|k%w4ېC \,3a߉GCX<;+7 2u~olR2h,jmCGVBo=FمfAdy>@5S!_edSc .:g{סLjP[Viٳ^^P0k~L?(gٷV+;\S!2teI1\xe;1zR6l$]Xa}7F/w}TÂLcijJo�X&Bfg#$x>~*>ꪭ}zUfSTrMHdH();xoٟs1V+ }H^ʻ2 KE^k7h'dž&i VcēQU}H=(ڛa.dfp?yv;D@rzw`Fx.5zD=Wԉ|}s1{(޷^E�}l?SX ֡/'̔zu"KRq$k׮-̑#}zӘAOFիg8^Na.dfp?ގ]O\绬N*<_Z*m1;XN'Rs}uY ̥ϡ�2e/ҼC/Ͳ?_V]do.!D'1zx=*J o_IkE{s9Lԅ =on>ⲒhܫmX=f':ζ:ieņjeӴ}NcɂX:qRZd&i_1`w$njm 9Y O߾jk^uU"ş'݊fkeX+cvR7{KclR}.&֖J#'I1a=LM]r$g?(jJ#(m(, w"t|*CfgM~i~[76\S!2]x\.1677辎^;518q 渨h=vol9z'S'WҒp\X怑2}TW '=/Zu�5K[?G ݫ,AmdZwl!+-a9ݼW+[)ZR(e_{Û1}>p^s\9yNBvS:Wgsoܻ?Nh[{Uƿ}(w-{ٰ;UQ^^1#w+drtMeeѦW +p/sehƗkg,=uݫTj-[Gyjmk-@[H{m8{, +U;5SsCm#<Y%%1OU<]ry0]sTk:߿==3lyu~Lkh]9BMDݻ+BPiY2' '럸Vbe3ۚyYO&'á 9[%:Zsw+ 1I2~Bq5bo{pehzSm,xbxӋG3j*ˋs&#&wocxjz;y1bn$1~ ڗ bO{k/{N?eUi*Ur7wp| 9>7z>z' b�����������������������������������������������������������������������������������������������������������������������������A endstream endobj 266 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4136/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnIQ{Ymi{*֍Yٓ7I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$B!=Ӑ>|"Jz!=i@9CZM! +%C6KWxNOQɷX9}Wy'OʾG}pʾgVgVgVgVgVgVgVgVgVgVgVgV֎ġ)15߇VILUS;| Z$4߇VI,UKKY[KY[KY[KY[KY[KY[KY[ɕ&}䍮0>Jbd?gN]Y}h|Z%_3'(>JbbgΛ]Y߇\%άL%άLw[3~Gw|K82%82%82%82%82kԠ.rZ}h߇KiҚC^}h|Bdv+z*m-(?=Jd#5ՒZ{>rV"V"V"V"VԎȩ'̩'̩'̩'̩'#sl -tl -tl -tl -tl [YR;K[YR;K[YR;K[YR;K[YR;;RWbWbWbWbW̎ɕ#ɕ#ɕ#ɕ#ɕ##wt,xt,xt,xt]K]K]K]K];WĢWĢWĎ3zm&#}Y|^ z@ oqm*2du/;$, MeH߇-:G}9k讲zWA{覲=j^M`EtSY"螢:n*7IXEyǫ$;nکwv[FwUR[-;*l{m#^Ex{6y눶YP#fAN>bn[O#n=cD.iPFW~_M(o%Q6iÕD0 WeØRNbҎ;cKv[J-Sr)LRy[i=Ks+gI{n,VykiMCt-iHKkѮ{i];WbZiی]L+mѶim3XfZgߊL[V*GjZe㈮عw;74-o9uB[/Nh MNϷwA{oۻvy6hl4[/o?=쾟k~-g1Ӥ;.ev4 ji= LVٱSu ʎ#aEe<}-X&ի.}]&Ogo3ȗ-?uǔgǧا 1~/Suu?iz~RQßU>G9Mԃ~ 'e<ᐟWS?Gwb2|l +5DIйS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU/8O^Km9JKu/y}@?!�[uC�GԡT {z;I3f׃2gR)\v>_u>p_v<_r<�}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU/=)}0UAդTWS4^O +K]/>C4߇ h?/gi—!}"wf]{ofNBp; +_?D@}FT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0Us*tcT}>йS:1`B>FLU胩 +}0UsT ӨԆ-TSV<*y,aӿ<*y,a4) +Iwi! +9Mx>Da%C6KrpFE6lל&eϥ2hALU胩 +}0Us*tcu6AT*.x)]v3lr1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0USgVERW%Rܷ>@}IC�'W%R7ER_/[I3nq$o%}3}hzx ?-y 3a[svq Z?A*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tݿn۔J`n)ql{CvO!�O>nއ�\?ڼѸ9nyA;ǵ޿Kf1qu 'l}lއ�`?ֿC~ҰK-W}H$}2sv<~oK>ީڀݏe296~{Wz?<tyE OM];dI{[?z "#sUb�O|;jt~} 1z} }lwuHM? WpY0??>&we[͎^і11y>ߙnc|y~N|9虹]a;>t{}1<fsmGS/~n~.33K$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I*��=υ endstream endobj 265 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4286/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnVDOĦb<P - _$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItB:tJCǧ!}D-J!4| WcN! +;M߇(7Yn>~7,G/.?9}>*~)N}~u/.?!ݗʔʔʔʔʔʔʔʔʔʔʔʔ%1"%N$N$Nm K}(K}(KK̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[?s`r~y&qd%qd2'fWč>tč>tč͜^Q'Q'9/di_[K̬L[K̬L[ͼq?OW̧nןH_i3+S3+S3+S3+S3+SF ʬp9[[|:\|:^߇9}:Z|"l-CG ٚC-}J4H%2#ikO#'EN-2EN-2EN-2EN-2ENmL<KL<KL<KL<KL<K[2c+MBc+MBc+MBc+MBc+MЖʒʒʒʒʒ%5,6,6,6,6lM+M+M+M+M+[r+EȂ+EȂ+EȂ+EȖʐʐʐʐʐ%9DO,:DO,:DOlYb3W:yw+]\w :q{B Ju/nH8B:-zZG:e=|9g謲WAw褲w5U>%sG!:Y}zKtNѫZ匾D'u̻$s:Sneo}]iSn;FgpI=:&񮵨#{ĺڞ' .7ʻHۋNcĸ6ܔwҖ񮹤k^]sI;KG萶wum+2+|Yi:ʅGtKOhr\uߵ4.>ޗwtL <Q{)ļ'g̻Rױ Sղ' Tӳ/;U/fF[+TM'*ͻW?ù]睬g'ݬ`*y[yyWks)/:lM5gݭ֝˵]J^vyڪx$;=vmӼޞxS>מXx:;ЗvF6(!ro!}*f[]蝛cmhA-b: n]H`%?$NN*dR!zL-s\~մrj"iVC.A~?>2*j>2Z>N>22?])}dtuM~GR +vQC?v^%ezу̿х] ?1K? +]]-?-1/Е\!@W2F5 ?VIFfIDv¾EVߣ ۈ]]9_e.k. tegAgНх�].~n8t/@W8F:t}!1=Н]NvF;G7/1uPtctagc˻ڧх +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*Th[j.uT,a[!�9߇�[|n}~$R% <tSR&7 ?ejR)lI*ZǤ Sne;MQɲTT]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10UGR0UAW٧ta~OITV} ~}!:VǿI Z%| |=zl=*? nrU< nrU<>D@G 0U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LUo9*[ʰfmKmoNI*r'(ZG%Rv_;AE/]mHϙl\(eT�F:SUɰT+˂-oB9{,nއ(lywp}VC6lY6eRA*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tXVERa[S[z?纤!�YUɰT)hZj6ueU"$Bev$O%0^Y6.y9އ0hop^wuU2,aβ)ʠ:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0U~eS.*vXRj]wq?MO6C�lxpk>D}Ÿ:~z.QǵKa1c>�ζ;w* {di*IC͜ńےwjGmDzk|~Q?=O?<t69VOMw.9`eqpvǫe>v/}\?2Q5xoF/S`>F/5c)v]RSs8.K}^/ɹ>]fG?c і 16y}L3; wsc|}t〞+'~_ ϭ|Q?=BV?F7?rj}h%I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$G�Ws endstream endobj 264 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4444/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrF DQOsz-J+ g=ڤl60T�����������������������������������������������������������/@J<i�}'_Oqsߧ� XG[C6*qPV>dA};eŗSluh#)F>bn#ss]s O]s O]s O]s O]s O]s O]s O]s O]s O]s O]s O]s O]CÒcոX58Vm@cӸ48613<9v13<9v13<9v13<9v13<9v13<9v13<9vofpc}~aƱdVq,Of18v*1<8V*^˱kɱkɱk~?7Sop7ɱkɱkɱkɱkɨke9mlqXϥk95 +&]}`5qԩPQCMxtSԵ gU GU GU GU GU,SÏg<SÏg<SÏg<SÏg<SÏg6pcZ4pcZ4pcZ4pcZ4pcZ4757575757ls '5 '5 '5 '5 '5lÇo|Ço|Ço|Ço|Ço6pa\2pa\2pa\2pa\8;<8w9;<8w9;<8w9;<8w9;<8wlsqP{6}@fo߮ F@VU`deY}fng!iBrͺZg +ݬ3.2Iy7ʺW7Ia2mgxL[i= rn>IFAN֥G}>,ȻSԩ JU0ȠTJ JU0~@VjMZz98P+Vb@X^7<Ъ֧j@Z7թ@P*WwMzm7tD~#A` +e*8T +H~3Ab*]:0PP(YCAd 7֫٤SaM9֫٤CSՊXXh7֪ڣsa=:8`Xl֨`Xl7֩ۢ]rx-lSݽN@z +/hk>z +]UO*[yz]T;zGbsFyT`XٌD~Pd BQ~7K] ~x>pX0rۓV~D9ڄIskD6(풺 ٌ˳rFZD8dGr3pĮ f}İ?YOYYX;b<^s_gis#gaDzODç*&q"~}5.|+< 7тXW}2ǙP򕦇+忨 W*%|E7D|45 .PLlsq\fTc Rդ0$Z(x'c͈2U9O&{y^kBlF.ɠgc56)}:K`#C,afX#G@F%XF>�٠�먗}Sِ$qF|~)鮯|'yWf5WӜ+pӗ>l#җqgc<׌#!Z2¨hƽU Uɖ/~#EH1ob ( |ģ.ZE P;A-r'=-zW|s*sY2X;aeIȁ| %J+g-+Y #> U%uCVDF }h!ʪ|$jJ.C~?`,Efcr%1c{G0S$bA\d4hW&$S$Q?|0%iM|د$6l>c%Im~9Y]ƍ8ߍuv$XiaG8C3VZC]_#} 'Z,4Nu> -qm۸h[CߤE% t&fMhJx/% YaꅡaT/ j>rYhG[CQB;꟠^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇Vu?7zahEnV?&zahEZn^?3&iڸH.߿<#`6<K +{uzМ˪[U!q? -}�iP/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu C+꺇VuS/ ^ZQ=L0{zahE]0Њaꅡu ~A䂁0a³^(OcUd\Ke⯙VERK-Tk?[w.`Wͫa[%dXVi]ԉg C6<Q;Xrx_r|}h;KUѴԆmiS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B}Ŵ*ڰ_2J:l>@漤!�YEdXVɼ)ڠj^pZI3xj?Iߌg KއC`! 5 +.pW̫a[5Ӧl\*+T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT3vӦ\T* vXRj]xc�+x'C�/އh\ouxA?=/Q?=/Qǰ>�1W6Ͽdi*IoCfńے|w:˲mm\3N7^vԄynr໦_2$=7|{?mE𿽏G>�<v۫S`}lL>ׄ}wuHM΅Wua!s.}hˉ|<xߙ;㻍szfd0>}yn3V }ku3K$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I*K�| endstream endobj 5 0 obj <</BaseFont/KQNXUR+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 267 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 267 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 268 0 R/FontName/KQNXUR+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 268 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat;]:3UhD@>Wȣ)ʮ +,.V+m"Ȃ +`EEb�1V +."FG MYLj1g' y!۶FG/rPkaainwZFp9QsEwW-Cy^ +%[0<;\9гMT{_fr<ևߠ5&]JI4Aci= IItFx|]7:iN5Rp^ :-o4Z]F]קwh5)Z/I0%ѐb:W@DTva.l3bX0műH%ۊaM։wYd6G x 6qgT yA5$Q`?IiIqxȁ<_/C J3h g~f@!q-ȑ;̳/`9yY;r<CtdNI'4]i ?fR~*Yqm21͊ZԵsWd oNٵBTTVRx*F˹@"gޅoMГ͵LzMɪ?n_ٯv${levpmv.6'GG޹\djKxEpt00[AH&.t~oq.WpPH9LUIKl}^DRx8?.}1d|io.!9J70`}Lj$٤߀;W|&-W21JNbt;"<=COo+)z:Xf#ͦP} 8NtIU?*=h8m5<cq_}lLj/ì|ӥa(zaCe H@,mgYbn7] 7~JPuĈ1.fU++*xܻFX&vS^%מ|΁?�W|+Lb eƚ}\,(31Hv9m ZHDr庪.ҟCǠ*ɳ%~\ʡƠqIGR، .dgzLcJ#֬!Ÿ4'r7 2m6Ԓ_ȶ\iT=ǡ4Q^oL_!G%:33zQ7*k<dԵP=6yu5Za8ӨXY~oٲtBqjaH߶OlcEF39)tGܙTV^iML}ctxY>*S 婬HR.HQ{ӠC +pN"_^vIR .@vCᕂ [76Ӗxj 00�| endstream endobj 7 0 obj [6 0 R] endobj 269 0 obj <</CreationDate(D:20170110154029Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170110154029Z)/Producer(Adobe PDF library 9.90)/Title(Fig_WAD_TC4)>> endobj xref 0 270 0000000000 65535 f +0000000016 00000 n +0000000144 00000 n +0000059818 00000 n +0000000000 00000 f +0000771729 00000 n +0000182233 00000 n +0000773966 00000 n +0000059875 00000 n +0000060346 00000 n +0000645891 00000 n +0000646555 00000 n +0000182532 00000 n +0000182419 00000 n +0000061986 00000 n +0000099974 00000 n +0000136424 00000 n +0000647268 00000 n +0000685464 00000 n +0000721995 00000 n +0000646621 00000 n +0000060743 00000 n +0000061083 00000 n +0000061149 00000 n +0000061425 00000 n +0000061473 00000 n +0000181492 00000 n +0000176963 00000 n +0000172450 00000 n +0000182303 00000 n +0000182334 00000 n +0000182600 00000 n +0000189003 00000 n +0000190070 00000 n +0000202570 00000 n +0000216903 00000 n +0000217957 00000 n +0000218948 00000 n +0000220216 00000 n +0000221221 00000 n +0000222240 00000 n +0000223678 00000 n +0000224739 00000 n +0000225792 00000 n +0000227463 00000 n +0000230305 00000 n +0000244998 00000 n +0000248521 00000 n +0000250295 00000 n +0000252615 00000 n +0000252772 00000 n +0000252929 00000 n +0000253456 00000 n +0000254109 00000 n +0000255018 00000 n +0000255711 00000 n +0000256380 00000 n +0000258006 00000 n +0000258671 00000 n +0000259586 00000 n +0000259743 00000 n +0000259900 00000 n +0000260529 00000 n +0000261015 00000 n +0000261515 00000 n +0000262685 00000 n +0000263457 00000 n +0000264293 00000 n +0000264450 00000 n +0000266180 00000 n +0000267667 00000 n +0000271032 00000 n +0000274014 00000 n +0000276298 00000 n +0000278497 00000 n +0000280363 00000 n +0000281345 00000 n +0000282319 00000 n +0000283614 00000 n +0000284115 00000 n +0000285111 00000 n +0000286108 00000 n +0000287575 00000 n +0000288618 00000 n +0000289726 00000 n +0000292339 00000 n +0000295948 00000 n +0000298308 00000 n +0000300711 00000 n +0000301878 00000 n +0000302440 00000 n +0000302597 00000 n +0000302836 00000 n +0000303437 00000 n +0000304185 00000 n +0000305193 00000 n +0000305854 00000 n +0000306529 00000 n +0000307383 00000 n +0000307943 00000 n +0000308100 00000 n +0000308625 00000 n +0000308783 00000 n +0000309566 00000 n +0000309968 00000 n +0000311103 00000 n +0000311882 00000 n +0000312683 00000 n +0000313789 00000 n +0000315565 00000 n +0000317358 00000 n +0000319417 00000 n +0000320063 00000 n +0000322624 00000 n +0000325909 00000 n +0000327019 00000 n +0000328257 00000 n +0000329234 00000 n +0000330321 00000 n +0000331545 00000 n +0000332543 00000 n +0000333768 00000 n +0000335060 00000 n +0000335861 00000 n +0000336912 00000 n +0000338262 00000 n +0000341458 00000 n +0000345061 00000 n +0000346970 00000 n +0000349435 00000 n +0000349593 00000 n +0000349751 00000 n +0000350157 00000 n +0000350780 00000 n +0000352398 00000 n +0000353328 00000 n +0000354021 00000 n +0000354720 00000 n +0000355393 00000 n +0000356135 00000 n +0000356566 00000 n +0000356724 00000 n +0000357091 00000 n +0000357740 00000 n +0000358228 00000 n +0000377571 00000 n +0000380121 00000 n +0000381396 00000 n +0000382222 00000 n +0000383058 00000 n +0000384517 00000 n +0000386152 00000 n +0000387580 00000 n +0000391582 00000 n +0000394152 00000 n +0000395135 00000 n +0000396458 00000 n +0000398760 00000 n +0000399766 00000 n +0000400738 00000 n +0000402032 00000 n +0000403016 00000 n +0000404035 00000 n +0000405505 00000 n +0000406553 00000 n +0000407621 00000 n +0000409613 00000 n +0000412915 00000 n +0000415100 00000 n +0000418293 00000 n +0000420394 00000 n +0000422306 00000 n +0000422464 00000 n +0000422622 00000 n +0000423211 00000 n +0000423863 00000 n +0000424637 00000 n +0000425334 00000 n +0000426003 00000 n +0000428453 00000 n +0000429145 00000 n +0000430536 00000 n +0000432603 00000 n +0000434750 00000 n +0000436550 00000 n +0000437527 00000 n +0000438509 00000 n +0000439799 00000 n +0000461151 00000 n +0000462140 00000 n +0000463148 00000 n +0000464601 00000 n +0000465662 00000 n +0000466722 00000 n +0000469027 00000 n +0000472116 00000 n +0000474853 00000 n +0000477145 00000 n +0000478685 00000 n +0000486173 00000 n +0000486331 00000 n +0000486494 00000 n +0000486652 00000 n +0000486810 00000 n +0000486968 00000 n +0000487126 00000 n +0000487284 00000 n +0000487442 00000 n +0000487869 00000 n +0000488027 00000 n +0000492180 00000 n +0000492338 00000 n +0000493108 00000 n +0000493505 00000 n +0000494183 00000 n +0000494879 00000 n +0000495710 00000 n +0000496652 00000 n +0000498445 00000 n +0000499966 00000 n +0000501781 00000 n +0000528020 00000 n +0000530393 00000 n +0000532818 00000 n +0000535734 00000 n +0000536994 00000 n +0000537976 00000 n +0000539008 00000 n +0000540268 00000 n +0000541259 00000 n +0000542429 00000 n +0000543781 00000 n +0000570177 00000 n +0000571232 00000 n +0000572462 00000 n +0000575989 00000 n +0000579545 00000 n +0000581497 00000 n +0000584075 00000 n +0000584317 00000 n +0000584475 00000 n +0000584832 00000 n +0000585422 00000 n +0000610858 00000 n +0000611661 00000 n +0000612484 00000 n +0000613148 00000 n +0000613855 00000 n +0000614652 00000 n +0000615084 00000 n +0000615242 00000 n +0000615536 00000 n +0000616241 00000 n +0000616718 00000 n +0000629448 00000 n +0000630232 00000 n +0000631074 00000 n +0000631879 00000 n +0000633253 00000 n +0000634886 00000 n +0000637086 00000 n +0000639774 00000 n +0000643645 00000 n +0000644608 00000 n +0000767034 00000 n +0000762497 00000 n +0000758110 00000 n +0000772089 00000 n +0000772423 00000 n +0000773989 00000 n +trailer <</Size 270/Root 1 0 R/Info 269 0 R/ID[<012AA874649F4396947867C5C9BDBB77><D18F2BBB7EEC44EAB8B2B30C47905B18>]>> startxref 774153 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC5.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC5.pdf new file mode 100644 index 0000000000000000000000000000000000000000..1c10155a282554061eacc3b29df3994f1dcc530f --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC5.pdf @@ -0,0 +1,3572 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R]/Order 7 0 R/RBGroups[]>>/OCGs[6 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 58216/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Fig_WAD_TC5</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-10T15:45:39Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-10T15:45:39Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T15:45:38Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG8tBcm1M8f1lUEr Qcl9QIxKq5WteJKkA+2Kr/Uj/nH3jFXepH/OPvGKu9SP+cfeMVd6kf8AOPvGKu9SP+cfeMVd6kf8 4+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xVsSITQMCfnireKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KpTq8ifpTRYllAmF2zvCCvJo/qlwtaHfiGNajFU2xV2KuxV2KuxV2K uxV3FeQag5AEA96Hr+rFXYql+uf7xR/8xdn/ANRcWKphirsVdirsVdirsVdirsVdirsVdirsVdir sVdirsVdirsVdirsVdirGfOuoWmm3Hl2+uaenDqiqXLBAizWlxC0jE7cUEnJq7UGLKI5+5M7TzR5 ZvLhLe01eyuLiTZIYriJ3bvsqsScnLHIcwWsSB5FM8gydirsVdirsVdirTuiIzuwVFBZmY0AA3JJ OKsZ1f8AMbytp3phLg6g8lCFsuMwCkkcjJyWPb+Xly9syMelyT5BqnmjHqkA/Mn9M6la6ZFYejDN e2/CdpeTFEnRwSgUBSePTkcty6IwgZEtcNSJSoBlx1rWFvLqFtAu2ghcLb3MctmVmWlS4V542Xfa hFcwnJVF1jUWYA6HfKCaFi9lQe5pck4qw/VPPvneCxpB5f43xmljJ+r6ndCOOO9kg9URRWiRygwR iUD6whavwg1Xkq3e/mD57t9SsLNfJsz291dW1vcX0bzSCFXSB7iRo1gChEM7IrerT4GJ6cSqnHk3 zhruuyJHqnly50RjaC5czmRlWU3EsPocnhhBbhGsnjRuncqsrxV2KuxV2KuxV2KuxV2KuxV2KuxV 2KuxV2KuxV2KsI/MW7sPW0u05L9f+tLKyU+L0jbXQU8qbjkrbVyvJycnSfWxm4t4LiFoZ0WSJ/tI wqDTfKAadoQCKLKfKXmyWOWLR9XlLu5Caffud5fCGY/79/lb9v8A1vtZEJ373V58HAbHJmmTcZ2K pHfed/KdkyrNqcTM7MlIeU/Fk+0H9EPw/wBlTLYYJy5BhLLGPMsavvzfsVKCw06WapYSGd1hoB9k qE9blX345lQ7PmeZpolq4jluxq9/MzzbdLGEnis+PLn9WiA5hthX1TMRx7cSMy4aDGOdlolqpHls xm7ubq8ljlvJ5LqaIFY5Z3aV1U70DOWam+ZUMUY8hTTKcjzKnljBNPK3/KS6V/zFw/8AExmLrf7o /D72/T/WHvmaF2bsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirDPzEvLZk0y1 WQGeO9V3QV2D2t0F36b8G29srycnJ0n1sZzHdopXNvDcwSQTLyikBVxUg0PgRQg+BG4wg0iUQRRb v/P3nPT4VtJLmGRX2g1EwqLhiDz4tQ+hyoCDSIVXcUIObTRwx5TRNSdJrYTw7jeLHNU1/VdYZJNT lkn4hWWGVmVFYDZvRQiIP/lBc2uDTwABA3dXkyyJIKC9RP8AfS/e3/NWZNNNu9RP99L97f8ANWNL bvUT/fS/e3/NWNLbvUT/AH0v3t/zVjS271E/30v3t/zVjS2j/Ltwq+aNEQIq+rfRJX4q9223/wAn MPXbYy36b63v1D45pHZOp74q6nviqlazNLEWalRJIm3gkjKPwGKquKuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KsN/MW6tmi0u3EqGdb4M0QYcwptbkA8ev7JyvJycnSfWxjMd2jsVWyRRSoU lQOhpVWFRsajr75KMjE2NixnASFHkl+mW1vc6baXE9vF680MbyhRVQzICQCd6Vy38xkH8UvmWmOm xkC4x+QQN/5faOj2ILJuXhZizAkinAt2HxE1Py8M2Gk7RI9OQ7d7rtZ2YD6sY37v1JOCDWnYlWHc FTQg+4Ioc3cZAixydFKJBo828kh2KuxVGaB/ylnl/wD7aEX/ABFswe0P7v4uVpB6vg+hM0rsHYq7 FUNp/wDcN/xmn/5PPiqJxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVgnn/WtNmm07TI5 T9dhvBLJEyOnwG2ukDKzKFb4kP2TleTk5Ok+tIcx3aOxV2FUl0fTZRpVp6N9cQo0KP6aiEqC6hmo Xjdup8ct8QDnEH5/raBjNbSI+X6kfHPPDMILohlkNIJ1HEN/kOKmj+42PgOmV1fJsBINFS1HRoLw iRT6M4arSKAeYpxo477AUPUU8Kg5Gm1c8R25dzj6rRwzDfaXexuaC4t5fSuIzHJSo7qwqV5Kw2Na V8elQM6LT6mGUXF5vUaaeI1JTZgoqff5mgJoB3NBl5NNADqnkVoaAA8tqGvbx2xBVW0y8Wz17TLy WGSSGzuY55Gj4dFqDQMy70OYmsxSyRAj3t+myCBJPc9jt/zL8oyxhnungb/fckUhb/hA4/HNb+Sy 932hzPzEO9c/5k+S0FTqBI/yYLhj9wjOA6PL3fcv5iHepD80vI5NPr0v/SJef9Ucj+VydyfGh3pg iXGr+Xw+k6jJp7XTvNb3scSO3BpWYfu51I+JT3FRlJFGi2A2rfoXUv8Aq/X3/AWP/ZLgSl2seUNR v2s5F1269WzkmkUzDirCW1lt+JFk1g2zSq9eVRxovGtcVYxffk7fX2pWuoT65Gs9qYGBjtZ2aQwS SyK00txd3E0zKZVMfqu6oUFFpVcVVr/8qNeudX/SEfnLUYkIvj9WL3EiLJeLcJHJFyuKRGBLhFTg B9jbjyOKso8p+XNV0VLhb/WZ9Y9ZbZYmn51j+r26Qufjkl3ldDI3TcmtTviqf4q7FXYq7FXYq7FX Yq7FXYq7FXYq7FWF/mDeQyxabAokEkV+C/KORF3tbkfC7KFbp+ycrycnJ0n1sUN5ZgkGeMER+sQX XaL/AH51+z79ModpYbhurWYkQzJKQAxCMG2YBlOx7ggjFQVRlqKVIoQaj2NaYqRaE0UU0exFa/6P Fv8A7AYnmiPIImWKOaNo5F5IwoQcUkWkd/ea1Ys8DOrW7iltd8ayeJDEkrzH+ruN996bHR4MOXaR PF3Or1ufNi+kDh70rvLme8MRuZDJ6Lcox9kBqEVotATRiM3OLSY4G4ii6XLq8mQVI2FKgqTTc9T4 0FP1DMgBx7bwodirsVdirsVe5+RXD+UNKcbhoFYV8DU5zeY+uXvLt8f0j3J7lbN2KuxV2KuxV2Ku xV2KuxV2KuxV2KuxV2KuxV2KuxVh3nqf67FpcFpFNPKl2JnWOGVuKNa3A+Ki/C1Tup+IeGQyDZyN NICe7Cn8sa6lx/otisdkymM27afKSqsPioylQeTAcgRSny3pouf4kehivOh6vFPG0dsIruRTGJGs ZfUdVqaCjKaAcaj27dmj3L4ke8Iy30rXVEn1i2nkZn5RlLWZAqAD4aHnXoanHhPcnxI/zggdFFNH sRWv+jxb/wCwGRPNsjyCMwJU54Ip4milUPG4oyn/AD64QSDYRKIIo8kjby7NDxaOb1m5Kg5gA8XY AsafCWA36fKlc2w7UNC47+/9jpp9kgWRLb3ftU77S761QzL6csCKWlYKoZeIrXjTcUHY19svw9pw kakOH4tGfsqcY3E8XwS/1n8F/wCAX+mbWnVW71n8F/4Bf6Y0tu9Z/Bf+AX+mNLbvWfwX/gF/pjS2 71n8F/4Bf6Y0tvavy6JbyLobE1Js4iSNq7eAzmpHcu4A2ZHTIpdTFVC+keKyuJUNHSN2U9aEKSOu Kq+KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVa0cbsjMoZozyjJAJVqFajwNGIxVdiqxoYWlSZkU yxhlSQgFlDU5AHqAeIr8sVbkRnWiu0ZqDyXjWgIJHxBhv0xV45oopo9iK1/0eLf/AGAzEPN3keQR mBLsVQerTSQ2iyJII6T24d2AICGdA/XxQkV7ZIMZ8kZkWSValoUdw3q2xEMvxF0p8Ehbepp0bl+0 PeoO1M/S6+WPY7x/HJ1+r7Phl3G0vxzY8ySxtwmjaKWlWjenIbkdqg7g7jY9s6DFmjkFxLzuXDLH LhkKLWWtTsVdir2/8vFZPI+iq32ltYwfmBnL27uQoshxQ7FUNqf/ABzbv/jDJ/xE4qicVdirsVdi rsVdirsVdirsVdirsVdirsVdirsVdirsVQ97Zi6jVDNLCVZXDwuUb4HD0NNiDxoQe1RiryLRRTR7 EVr/AKPFv/sBmIebvI8gjMCXYqgdZjjlsfSkUNHJNbq6noQZ0BGEMZjZsaTbqeUc1yrj7LG4meh8 eMjuh/2QIyw5Se75D9TAYQOp/wBMf1pNePqtldhpLmR234OT8DCgFeA+Cv0bHNvo4YMsK4fUOf47 nS62efFO+I8J5f2crQdxdz3PL6ywmNKRMyqrR/EGPBkCtvxFQSQe+ZkNDCEuKNx+Lhz12ScanUvg h6yKu4DsFJPHap8ACf1nMrdxNl4IJYD9k0JoRXvtXriCtKbXNur+m0qLJ/IWAP3YmQHMqIkvePJs 1p/h+yghmSQxR8aKyk0DECoGcwOTvMn1H3p5hYOxVDan/wAc27/4wyf8ROKq0zSLC7RJ6kqqSkZP HkwGw5b0r44qklrq3m2W3SSfQI7eZhV4Teo/E+HJY6HFVDWde822WnSXMGhJNLG8I9JbhpSUeZEl PCKJ5DwjZm+FT06HFUj1Dzn52ezW7sdNW3SJLuS5h/R+qXjsII09IRiSPTJDJJNMqhPSIKh25jia KrdW/MDzzZu8Ft5QmvALOWVL6M3HE3Mdgt0E+rmANxeZxAoMgYsG6EUKqbeTvOHmHWr+az1by3Po no2sFx9YkaWSJ3nHIwo7wQAtGrAP4NUU2qVWW4q7FXYq7FXYq7FXYq7FXYq7FXYqslhSTjyLDiQR xdk6EHfiRXp3xV4Ysl3DodpJHPJHG1tAirBbNcSK/GvOi8vhp9oceg23OYvV3O9BV+tT3AlmtbyZ UkEclvytHaNVoAwpxV35cuXXb5BsU3aNj1KCSWONY56yEgFoJUUUXlVmdVA/rtgplxLNWRTbxsa1 E9uAQSNjcRn+GEIkOqOyLJRurWG6hMUoqp3BHUHsR75OEzA2OYYZMcZxMZbgsTurO5s5fRuKFtyk i1Cuo7ivT3Hb32J6bS6uOUbbS7nltXo5YTvvHvUsy3EdirsVdirsVdiqrYsiahZsRX/SIV/4KRR/ HKdQaxy9zZiHqHvfRec67Z2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVZJCkleRYV414uy /ZPIfZI+nx6HbFUlt/JPlyC3ihW2PGJFQUmnAooptWQn8chwBvGon3rpPJ2gmNhHAVkIIRmlnYBq bEqJFr8q4+GF/M5O9seTvLwArbMT4+tN/wA14+GF/M5O9JPOvlvRrTy+9xbwMk0dxacG9SU/au4g agsQfpwSiAGeLNKUxZY3mO7N2KqF7ZQXkBhmB41DKymjKw6MD/nXodssx5DCQkOYa8uIZImJ5FLz 5btdv3sg3B249j06d8zz2rl7h+Pi68dkYu+X4+CW3VhNb26XRiDQSAPxIdXiUoWPqfEwotN2r9Hf MzS9oCZ4ZbH7HA1PZxhHjjuPtQnqJ/vpfvb/AJqzaU6y3eon++l+9v8AmrGlt3qJ/vpfvb/mrGlt 3qJ/vpfvb/mrGlttJE+tWX7tR/plr0Lf8tCe+Y2r2xluwbzD6Mp75oXZuofHFXU98VdT3xVStZml iLNSokkTbwSRlH4DFVXFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqxr8wolby1LIS3JZ7MA BmC73sB3UGh6d/45GfJuwfWGF5iu3dirsVdhVKNF8wWV5a2yvKFuzEnrLxdY/UICsiO4UN8ewocv lp8lcVHhcbHqsZPDY4lmqaCH9S4shSZiGaAmiNTZuP8AKxH0E+FS2ZOk7Qlj2lvH7nG1nZ0cnqjt L7CkTArLJE20kTcZEPVT13+YNR7b5v8AHkjMXE2HncmOUDUhRdljB2Kr7ZGe9swvUXVu30LMhP6s xNaf3R+H3uRpR+8Hx+59G5onZOxV2KuxVDaf/cN/xmn/AOTz4qicVdirsVdirsVdirsVdirsVdir sVdirsVdirsVdirFfzD0+zfQ3vWiH1qKa1RJQSDxe8t+QNDvX016+GRnybsH1hiGYrt3Yq7FXYVY 9pXluybTLVxJKnqRJIyqVpyccm6qT1OZ+PtHJCPCANvx3utn2bjyHiJNn8dy27XVdMVYorhvq3Ks TUVqCu0Z5h6UG230UzI04w59pDhn5focfU+PpxcZXDz6IS/v5r4j1kjUopEMiKQ6sSCdyzAo3Ecl p9INCMzFoPDlcJEe/f8AU4WXXnKKnEH3bfrQil/hDLRiCWINVBHapoT92Z1lwKd6qBDIx4oteRb4 aU6nem3vjxLSYaGiyara13UtyUjvxBI/EZia0g4TXl94crRj94L7j/uS+gs0jnuxV2KuxVDaf/cN /wAZp/8Ak8+KonFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqxr8wIIP8OTzemvrevZr6lBy obyGor1/ZGRnybsH1h5rdC6tr2F1jvbuIOzco5IeCmUlQjITGzIOVamvGg3pXMd2hsHq6xt57RVb 0764cApxmnjfbmX5NWQCv7wj5LTsKpUCu9HW1xPK7iS2kt1UKVaQxnkWrUAIz/ZwMgVdlqKVIoQa j2NaYpItCaKKaPYitf8AR4t/9gMTzRHkETNDHNG0UqhkYUZTiCQbCyiCKPJiuo6fNZTlWHKBj+5m 8dq8W8GH4jcdwOj0WtGQUfr+95nXaE4jY+j7kLmwde7FWnRHXi6hlPUEVG2+Ai0gphH5g1+Mxenq d2iw7RotxKEAApTgG4kexGUy02M/whmM0x1TX/lYvnKlP0h/yRg/5oyH5LF3faWf5ifepP5/87Ma jV3X2EFr/GE5E6HF3L+Zms/x554/6vcv/Iiz/wCqGP5HGn8zN635Nu5rzyvp13NIZZriL1ZJSFUs zksWIUKoqT2FM02QASIHK3YQNgWnOQZOxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxVDXemafd oEuLeOVQQwDojj7ayHZgw3ZAT779cUg0pfoHQ/8Aq3Wv/ImP+mDhDLxZd5WP5e0RihFjbqEbkQsM VG2I4tVTtvXbHhC+LLvK/wDQOh/9W61/5Ex/0x4Qviy7ypT+W9ElCAWcMXB1c+nFEOQU14tVT8J7 0x4Qviy7y8t0UU0exFa/6PFv/sBmKebuY8gjMCVOeCKeJopVDxuKMp/z64QSDYRKIIo8klPlmQKV W6rTZXdKn2LBSoJ8aU+jNuO1jW8d/f8AsdNLscXtLb3ftQtxpjRQtcRqZbeP1BK3Li6mIkMeBXcf Ceh+jvl+LtMSlUhwuPl7LlGNxPEg6wfyN/wQ/wCac2m7q9nVg/kb/gh/zTjuuzqwfyN/wQ/5px3X Z1YP5G/4If8ANOO67OrB/I3/AAQ/5px3XZ7V+XRr5F0Mg1BtItzuen0ZzUjuXcAUGR75FLt8Vdvi qnDN6jzJSnouEr41RXr/AMNiqpirsVdirsVdirsVdirsVdirsVSnXvM+maHJYx3y3LtqErQWy2tt PdsXWNpTVLdJHA4oe34AkKpBr35s+XtDupLe9tL4enFb3LSekiAW90eCylJZI5V4yfA6sgcH9mlT iqra/mx5Nli0o3E1xZXGsCI2lrNbTO6tPM8EaSvAs0KMZInFC/7JPQHFVbQvzP8AJmtm2SxvHM90 D6UEkEyNVYnlYVKcDRYZByVipZSoJIxVMf8AF+gf7+k/6R7j/qnjSrrTzZoV3qUWmwTyNeTI8kcZ gnUcI6ciXZAg69ziqayIzrRXaM1B5LxrQEEj4gw36Yq8c0UU0exFa/6PFv8A7AZiHm7yPIIzAl2K uwqh7C4a4gZ2Qx8Zp4wpIO0czoG2/m41xLGHJBaloUdw3q2xEMvxF0p8Ehbepp0bl+0PeoO1M7S6 +WPY7x/HJwdX2fDLuNpfjmx5kljbhNG0UtKtG9OQ3I7VB3B3Gx7Z0GLNHILiXncuGWOXDIUWstan Yq7FXt/5eKyeR9FVvtLaxg/MDOXt3chRZDih2KuxVDWn9/ef8Zh/yZjxVE4q7FXYq7FXYq7FXYq7 FXYq7FUFq2h6LrEEdvq+n22owROJYoruGOdFkUEB1WQMAwDEVxVD3XlPyrdwxw3WjWNxDEiRxRy2 0LqqRKyxqoZSAqK7BR2BPjiq8eWvLirAg0qzC2vpi1UW8VIvRLGL0xx+HgZGK06VNOuKutfLXly0 mgntdKs7ea2qLaWK3iRoweYPBlUFa+q/T+Y+JxVMsVdiqHvbMXUaoZpYSrK4eFyjfA4ehpsQeNCD 2qMVeRaKKaPYitf9Hi3/ANgMxDzd5HkEZgS7FXYqlOnQXwiuGguEVZLm4ZVljaTjSZloKOm3w1+e XAwrcH51+gtHDP8AhI+V/pCIa+ltW434UIR8FzGG4sf5SnxFD4bmviOmGGI5JVD5filnm8MXPl3g f2oW8utCvo1E70cD4JArCRKsCeLAGleIqOh75l4tJqMcriPtH63Dy6zTZY1I/Yf1JA6+m4QyLL2E qKwU9ezbrsK7/Kpze45yI9Qo/N0GSEQfSeIfJpWVwSpDBTxJG9CO2TBBa6LeSQ958pRiLy5YxL0j QqPkGIzlo8ne5fqPvTfCwdirsVQ1p/f3n/GYf8mY8VROKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2Ku xV2KuxVZLCknHkWHEgji7J0IO/EivTvirwxZLuHQ7SSOeSONraBFWC2a4kV+NedF5fDT7Q49Btuc xerud6C5ri9uWlntL6RIJRE8AaydlVQKMF2Vm5l1bfoOneimyeR+xMI9SgkljjWOeshIBaCVFFF5 VZnVQP67YKZcSKcMVIU8WINGpWh8aYpKE0qv1WSv/LRc9P8AmIkxLGHJEyxRzRtHIoZGFGU4gkGw mUQRR5MV1KwksrjgQWhfeKamx/yTTow/Ht3p0ei1gyipfX97zOu0RxG4/R9yGRWevAFuJo3EVoaV oaexzO4g4FFd6E/++2+44bC0XNbSsCrRMQeoKkjBYWiibC61fTozHp81xZxnqluzxKfoSmVnHjPM BmJz7yi7XzD5rtm5R6jesSa/vZZZR90hcZWdLiPRmM2QdUwHn3zwBT64/wBMEJ/5l4PymHu+0r4+ Tvd/j7zz/wAtjf8AIiH/AKp4/lMPd9pXx8ne9F8gaje6joJvL6T1LqWeQSOVCV4UQfCoA2C06Zqd TARyER5OfhkTEE82SVHjlDY6o8cVdUYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVkkKSV5FhXjX i7L9k8h9kj6fHodsVSW38k+XILeKFbY8YkVBSacCiim1ZCfxyHAG8aifeuk8naCY2EcBWQghGaWd gGpsSokWvyrj4YX8zk72x5O8vACtsxPj603/ADXj4YX8zk71s/kzQ2hdYoTHKykJIZJmCsRsePqC tDj4YX8zk73nlvALd7uAUIivbxBStKLdSAdSx+85RLm7LCbiCVbItinPBFPE0Uqh43FGU4QSDYRK IIo8mPv5dvlmKrMrxjkY67Eiopy2NCtabbHrt0G6x9pxoGQN06LL2XLiIgRSjc6PqEAVvSMqk0Yx /Fx8CRs33A5kY+08UjW497j5Oy8sRex9yBBDAEGoO4I6EZsHXN4VdirsVdir1v8AKEsfJy13P1u7 6eAmamc9qT+8l73bYR6AzXKGx2Koa7/v7P8A4zH/AJMyYqicVdirsVdirsVdirsVdirsVdirsVQu p6pp2l2bXuo3MdpaI0aPPKwVFaV1iQFjsOTuBiqTXf5i+SLW3kuX1i3ktYoZrmS5tybiIJbGMSj1 IRIvMG4j/d15nkKA4qqp5+8lmzmvX1q0t7O3unsJbm5lW3j+sxrzeJXm4KzBTX4a/hiq+087+Tru 5Npb63YyXYkMP1X6xEJuYkEVPTLB95GAXb4qilajFU7xVosoIBIBY0UHuaV2+7FWpBIY2EbBZCDw ZgWANNiQCtfvxV5MeX1vUORBP1++3G3/AB9y/PMafN3GD6AuyDa7FUr1C6trXWLGa4f00aG5j9Rm 4otWhb4iSF/YoCe/zycYmWwa5zESCUZbahYXTMttcxTsoqyxurkDpU8ScZY5R5ghMMsJciCl+o6A kgEllxikqOcZqEZaU2p9gildhT76jO0vaEse0t4uBq+zY5N4+mX2FICGVmR1KSISrowoQR/nsehG 42zf48sZi4mw89kxSgakKLssa3Yq7FXrn5RKV8nKCKf6XdH75mOc5nP7yXvLuID0j3D7maZUydiq Gu/7+z/4zH/kzJiqJxV2KuxV2KuxV2KuxV2KuxV2KuxVC6npllqdk9lexmS3dkcqrPGwaJxIjK6F WUq6BgQcVSq58h+Vru0e0v7WTUIHjmhZb65ubs+nc+n6qhriSRhUwIRQ/CRVaGuKqMf5beRoraO1 g0eC2tYr1dSjt7flDGt2iLGsoSMqv2UG3TvSuKqGn/lT5B0425stL9A2tz9ch4z3O04MLcjWQ8t7 WL4Tt8PTriqdT+WfLc8zzT6TZyzSEtJI9vEzMx3JZitScVUJfJflCVomfRbLlBIs0RFvGpWRDVW2 UdDiqZ3sNxNbSR29wbWdlYRzqquVYggNxcEGh3pirykBxc34duTC/vqsBSv+ly9t8xp83cYPoC/I NrsVQUjodZt1B+JYLgEf7KA/xGS6MbHEr3VpBdRenMtaHkjjZkYdGRuqsPHADSZRB5qEF40Li1vn VZgCY5z8KSICBWv2VbfdfpG2WRxmX0i2s5RD6zXn+OqC1e70KcCK4lb1V5CKaFJHKFhStUVlI70b atMysGHUQNxBDiajNppipkH8eSREUd1qGVWIWQVoy9moaEe48fHrnQ45SIuQ4S85kjEGoniDQP7w qVIUU+Pah+W9fvyQLAhoepsTxFCeQ3NRvTf4aY7rsm+lea/MmlQC20+/aC1DM4g9KBl5Nud3jZ/x zEOhgSSb3cj81JMm/MnzeUCi8VT/ADiKKv4rT8MH8n4/NP5uXkox/mF50QHlqjSV6Fobbb/gYlyY 0WIdGB1M+9kHkXzPrureZ4otRu2njWOR1j4oqhgtK0QL2Y5iazTwhAGI6t+nyylKiXp+a1zHYq7F XYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVk0byIVSVomPR0Ckjb/LDD8MVeOapdTWs2oz84Y7d L3UDNNMWHA/W5OBCqPi7/DUV2ocxpc3bYjUAgl1i4lEbW91p0ymFWekzUMqsDJxdeQ4emGptXbwr gps4vcjU1fTiEVruAzMyxlEkDfvGPEKvc/ECOmCmXEG5SBrNsp2YW9xUd/twH+OPRF2UZgZKF7ZQ 3lu0EtQDurqaMrDoynxH3djtlmPIYSEhzDXlxRyRMZcixW8tZbO49CanIgtGw6OooCR8qio7fcT0 mk1YzR/pDm8xrNIcMv6J5FRzMcN2KuxV2KuxV2Kso/LGWnnS3ir9u2uGp/q8B/xtmu7RPpA83L0g 9Re0ZqHPdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVWSxu6kLI0ZKlQyhSQT0Ycg247dvE YqxweQ9OMk0j3NyHnmmnYBoiKzStIaVi/wAr/byBxguTDVSiKFOXyBpKCiXFyoJJoDEN2NSf7vuT XB4QT+cn5NReQ7AxL61xcCWgLqrRsoPgCYhX50x8IJ/OT8mM+ZtHsNM1qwS1uHmd4LoSrIyMVKtb ECiKtNnrv7ZCcQA36fMZndB5U5bsVU5oIZlCyosig1AYA0PSu/zycJyibBpjPHGQqQtRbTNPZSpg ShFDQUO/uN8s/M5f50vmWr8ri/mx+QSW/wBCmtzytFaW3AHwElpFPxE9d2FKAdWza6PtEH05D8f1 uo1nZhHqxjbu/UlasrqHQhlYAqwNQQehBzbgumbwq7FXYqyX8sv+U7tT/wAud18+sWaztLlH4ubo xze15qnNdirsVdirsVdirsVdirsVdirsVdirsVdirsVQOsa1ZaRbwz3nqencXMFpH6UbSH1bmRYo 6hAaDkwqTirGPMH5teXNDgknu7TUfSSBp05Wr27yenLFFIkcV0beUlPrCuW48OPI8vhYBVTg/Ofy KzTLdT3Nk0Mio3q20sicJIvXjmMlus8aRvEGf94ykKrFgtDiqY+XvzM8na/JaQ6deO1zeHjDbyQT IxYRvKw5FOBAELjkrFeSsASRiqYv5s0JHZGmkDKSCPQnO4+SYqsTzl5ee9tbJbiT6zeOY7aP6vcD kwHI7mPitAOpNMVYx541C0udc06KFyZLeG8SZGVkIJNo4+0BX4XG4yrLyc3Rcyk+UOwdirsVdirs VSrUtCjuG9a2Ihmo3JKUSQtvVqdDy/aHiag7UztLrpYtjvH8cnA1egjl3G0vxzY86SxuY5o2ilWn ONqVHIA9QSp69QSM6HDmjkjcXnM2GWOXDIbtZa1OxVlP5YRV85QS/wAlvOv/AAXE/wDGuartLnH4 /oc/Rj0y+H6Xs+axy3Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVG7s7O8iEN3BHcQh0kEcqK68 4nEkbUYEckdQynsRXFUs/wAFeTfq31b9A6d9WqW9D6pBw5NxJPHhSp9NK/6o8MVVB5S8qgTgaNYg XLM9yPq0P7xnV1Zn+H4iyyuDXsx8Tiq+18teXLSaCe10qzt5raotpYreJGjB5g8GVQVr6r9P5j4n FUyxV2KsC8/3ETarpb/Eix297zaRWQD4rU1+MLtQ9cqyubouZY497ZR+r6lxGnocfW5Oo4c/s8qn 4eXauU07CwqRzwylhFIrlCVfiQaMDQg06GoxW1+BXYq7FXYqhb7TrW9VfWX40r6cq7MvIUND4dNj tsPDLsOaWOVxLTnwQyxqQY1eadd2Kg3FGj2HrpshJPEbEkqTtsfGlTnQabXQy7HaXd+p5zVaCeLf nHv/AFofM5wWaflYP9zzHvx/40fNT2lzj8f0Ox0X0S98f989czWuS7FXYq7FXYq7FXYq7FXYq7FX Yq7FXYq7FXYq7FXYq7FXYq7FWmYKpY1oBU0BJ28ANzirCfPlpPfanp6w2k1zFHBeRXHGGSRP3hti FJClSGAP3EdjleQFy9JIAm2Ir5b8xJcP6doFtGpwQafMHjCMGjUENxahJapGzfhVR7nM8SPfFVTQ dcimZ4LT0pJeLTlbCYM5FKkkMO/KlelfveE9y+JHvCKttL1xIQtxa3Es1WLOltKi0JJAC0alBt1w cJ7mQyx7wqfo7Uq0+pXNetPQl/5px4SvjQ7w3+jdT/5Ybr/kRL/zTjwlfGh3h36O1OtPqNzXw9CX /mnHhK+NDvDv0bqf/LDdf8iJf+aceEr40O8LJNLv5FeGTT7l0ZaOjW8pVlaoINVofcY8JXxYd4Y7 qvlTWrdhLbafeTwOx5oLeVnQs1Voqp8Sb08Rt1FSN1o9efpyfP8AW6LW6KI9WMj3fqZF+Wmm6nba 4zXVjc2y8a8p4JYl+y46uqjHtDJGRjRvn+hr0kSIyvvH6Xqma9yHYq7FXYq7FXYq7FXYq7FXYq7F XYq7FXYq7FXYq7FXYq7FXYq7FWuKlg1ByAIDdwDSo/DFW8VWiOMSGQKBIwCs9ByKqSQCfAcjiq7F Vvoxer63BfW48PUoOXGteNetK4quxVaI4xIZAoEjAKz0HIqpJAJ8ByOKrsVWCCATNMI1EzDi0gUc iPAnriq/FVoiiEpmCKJWUI0lByKqSQCetAWP34quxV//2Q==</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:11289456-5f33-ea42-8710-309655687672</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:05801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>xmp.iid:04801174072068118C14AA247F7D2A30</stRef:instanceID> + <stRef:documentID>xmp.did:04801174072068118C14AA247F7D2A30</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:19:32Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:03801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:31:30Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:04801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:40:26Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:05801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:45:35Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY5/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 2/Kids[8 0 R 9 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0 0.0 422.158 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 10 0 R/Group 11 0 R/LastModified(D:20170110154538Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/Font<</T1_0 5 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R/Im3 17 0 R/Im4 18 0 R/Im5 19 0 R>>>>/Thumb 20 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 9 0 obj <</ArtBox[0.0 0.0 172.8 129.6]/BleedBox[0.0 0.0 172.8 129.6]/Contents 21 0 R/Group 22 0 R/LastModified(D:20170110154538Z)/MediaBox[0.0 0.0 172.8 129.6]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/ProcSet[/PDF/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R>>>>/Thumb 23 0 R/TrimBox[0.0 0.0 172.8 129.6]/Type/Page>> endobj 21 0 obj <</Filter/FlateDecode/Length 271>>stream +HMN1 9/0qxKBB]p�ď\dN2^o`mζH4^ ?R6FT P̎JZkd!ew4^o&"(:oXZ +ߧ[xlA"0HA*rM(M,s$(ZX݃ .¤xeQ1P BnTyNCʌ<—8-Гr'0{] z0W!~/?D1\c,Y$KYDCA[_ ]|/�o endstream endobj 22 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 23 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 16/Length 130/Width 21>>stream +8;Y!<_%"1&$j3gHcS!\5LIl.#4RgNT%1^`Y:g8sAZ-N:Y4l50.3s?>6I#)@7=Q[(q +2\]g`_Y9mO^oZY%)3Ce.8Jc!J8S'$6HBshb6rG>mhEE:<RlVF_8gKem!'H%tV#~> endstream endobj 24 0 obj [/Indexed/DeviceRGB 255 25 0 R] endobj 25 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 14 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 34871/Name/X/SMask 26 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��z <8E#LMZThLELpDtZcFш$&*WA(h$456P{KӦQA+ ovϲ33|x]:瞘 T A���tmkJsӶ$^���]: X͟kzO���tmk謴樴G��еqHAcG{F���tmkhT\5h!"U{9 VHY83T_��}iMr::Ꝺ\M0{P2V���ߞB'L{9P\P\n68fO&G=gj:|i���8%y.¶'3@QAaK;aSw^���hs(]osghׯ7��@{X X>S>���Wµ?w${���k^Ui8d*.���UZ^8\cW-��ʊ Ir���\2?1B&"���pW?NeWKWe��*,Yo)5 Gd��*S-p%#Үe��*:zQ[Fk,{-���a x:q:&j���pf^G +jhJK]${/���Ykx/{Fd0-{��*UH@/c>ϮZ. ���9T2pohG���UJp6/hza޲w��:>+Jrk��� D\?MƁbsx\n���®* WUٻ��4 26>=  {=��n4o,!:���B@/SDjW2V��kծЋCҢ +xR~���ݝvЋ#޴kCU.��;?+-GDچсW��C@WZqM^j��QCЕj9gxC���z1OLAl̨qmMqJ\zRhpob:-{G��gⅉĶuf5]״닊#ۚߪ3PKw��JKz2w.Vڭu4[̺3ңty7-Ik1ow`��Z߯ +#rޛVtbߣ(p݃Jk{k'��@g%f<Xn)tգIY%z +C i(?'GaGuO{��4Gc_/Uw)铲ӷNF\ 3zZhsAa{��tG^(؞4jL뵿Yվ ~+}8:(@zVSBrY���OϞbgEG+̹ʝڟm/>$D7ߕ!#I[ʮϟIU��',ۛWmS.i7Oݡ7O,z| zN0=i?i|[̺�ٻ��?W=VیuڍsL5~yv͊XW*9\yI[kdQVb>Smٻ��|Į͛yi7O\[i Y/DKu2*ڤ&WZM��53iO[64'3ڦ\/*Ҫo~1\�a gSl.=iOaLPٻ��5tx}~DCaU6XIٛ^%ػr;έKI{#,u]?w\��a_ rFQ- _%~^9A͍ژ=.wv��t/bbey{ޯV+]rΑZݱg?+,;a=́rd ��/hDX ˴;9f:*y:z5c^wAG'I{#y_޶JX'{_��?}Dx NDJMjT7X'Dl- cv_QM]yoP +B}:8ŪǥԪEVȾ/@ F! RQAt8uɅ㙪B$~?|9y/`J:?|$.%ן���O\&M&۶ :E<Ҡx%ar?BO?t,I=e*���djsEBg)ӹZTZ-1Og}CȢbVфöb3��ᳱ&?\@RJq#Xy㽳XlSCȍSם`?TtJ/c���`x=e*9v¬# Mp@!.~7&U:0497 K,-Q%e∰9?М􀓬 ��� G'sgʤ ,sUyiUskJ~~7+8r>O\F�CQHc)WBuR~}䐡ו5+lUxd���`(KָCfK c_v|wz>'DnJ9#eΣyg8t/p#Р#fvt_Wk+ziίy���{ffd޻HW;ib:4BK]G\:'覜ӪkLS"WOlGJ2<wdq+9GutΥ���0 +4[oŦm* ܯK;Zf~c/g%3Sj7<)0\wШr-9W5:YQaFu��0,A.^+͖VQnޯzrR/B2\_הd7 d'?qsttMWG:}iU544g7=p~G∐#t���pR($ D3tgᷧ3~~ta!YqV#Ѳ̭<IHJK9?Ňo;׿Ǘ-Qš¤ +ƒ M��=&E{yVIQT4ҳrab3fތcq&#?%*ycb~ Y^IL)b$%}] ü-85&5_|!1c/&hh,';Y0��̮_c)?3R=Om}⍄dr?[#)6?3 gȖ]f??𜣡͊DAOsHw@1\.J&qbBoy TrhAݰr���_ss23sTEϹ2Vq_~N|n7!ȋӐ&zǡkf! +MMS_2zLy?V&{kt19 S2j˯Z=C|Gu^9CR޵ +_ +��tOzm7/-ijg5M|飊 ˸?-hG�C$^GOs=J\T9Ҷrd6XLA=)^}$a+\A��99|$:|qRVKϮӪGUޫcƚXKH+2"r#msZhNz�=#e4&ծ?צd]\5S%'~vB;*%~9:��td$KE.cw~8yO3۶r!Eọ̈̄vQIک/;JG<C֧bjiQ[|qm��/#O EIA.=K5?ZދLt_>mT0ϦɆ㏩+Fii_+L +\/��9G[;uJ46bV)gr:jk-fEkj~ `*?:NM3(x\G-99( .k c֡��@W"K%)U\ʛ~KK3_"r~E #U`*?^ͳH:ݏv{9t?A kA��#>7q X N ן%ܽ<@1a+,~E 3섏?Tt.V^.$\~H*5 iP$Dy��c;/Vy +QjY:=gϨŗ[6x%8\G"ziq?Tt>ִ 3}߬"W\/'��pښ\;(\ձ*wtlM!"7gYҘlˣNi\0] a\^7 +I+odb# A��LP L%n_?G[Yz4<)qD1|+iF߭mY3?Tt=6 9QTlC+Dob"<A{Tǟ.&*!1a+pàpa"DDҍRJKމ}ոqr9wzvuΙ堞YZ>=�@x:YkS~pӷX|UgB +gƭ'k}@(?޾A%)AL3bAIA��kd@XHrbfu[y` D~?ףӝĎG�x{}gaFZ<'7Hށ}"��X[Z9&Csm6#-H}~X>Fq +woYWi-oKg;rW6 ��`uN~^ogy&}Ofֿ]31YT ?l_rmv +ww&Iʲ۾t^\9@ e4!��z!뼾Icg7MaHă }ujtzOWgA�x >7ƚΌk}P,5��:VV}$)drE.G;=c7a? uz^}/?P@?{}EJ 2 SM "; ��}||슲ҶFƝ+;\z̛i}EwJ6U鞆�B~iI%;N\4 ��BcYBn(oQ#aσ/>!D~m|YeS9�B1 ^*S$x7:?n75HvLg��]?~8'7ͻOE~VB!|h=.?@t~H._EY:Ԃΐ"FfEGLb}��U9qh׷6'}Pu[UY>D=ŽY]XBI1wt5,i$s �\Է[E~EBN]U_sc{"`B><.@H?:־IHQ67fhomY?��66d̯ȡ*#]:ɫZW'?-\EwA;{Uqˆ�B9 - gS4K\iK۳k;���HD&>D;r3|3񔿽Z+jB6tb s :7M r'Ka}��qL6/_Mg}UEy_[UZ }rE._�ByCru2 7RMs +]��-Y:{Ɍ +wPK+;+T~[ -dAh|,*U+?@tΛRq Rzf=(kzwP�tY,-,HL``RYfB\CgM#/K&\%R]3 %I $DSTUWMszI!��) LZmJKZ繫tU~z]ﳴEj]ٺss@H?5H<"-Ue,wnsa}/��ѻgO|;ɎrPVEgV%6$I4Ǫ@Bw6E9 $e>)N4gmy߾u��VݺnIetΨۆ^c/D;BX9C�!`@ 6ȅX+Ӭiոg8��|xrJ׬Q>mtϾlXV Pȯנ?@wȖ?RJϫ6͛Gډv\b#��ad@XHrbtTܭg5;BL7"dA!j(n-E�!0]. rWM|i<Mvg7`{�֖dΤ$!x13fC<1|)bwA [;?@C6sɑDf}W��]I:o[>#_s7\9ix]fnc�QJ{?=n�Ba^ 1hτϞ_ʦ93ۋ}�t >՛]%֫  7jz6"`[A_Fٴ9Ts6OrA~ m?1=7ڳ3��Ғ̟2$qL+z-y~L!^w)WI&?@#-$^ ;gYBׯ��Cw&+-Pj\5fL+,g;AͶ{G?@#kkH<hH+d-�\8 . t5k/>eՕӍ4Ҹep5SnLFEAAMYE!*"j " +5ݬv7㾱8NȒs-SI">UϏU=fxW;'ޗ Ǵ՝W%D#VHˋokl�@a( Krroؔbq{'O#9p9Oߑ =ܙgGC�.}2 ] ٩mNm3�x?ML%d'ąfzoƖk\>FND1Kb|�\7g QfKyZ)v;>G�_ǘI3_Uj»^?L =Bjc͉K?&{IVZ!mܡIZKl'u��120 / gK-Q? +?h݄ٱ@ٷ6DAF%}kIv/AʷnRic<�ބs$20pxH5+)nt6{|09@u둂mIT�YΔ\+QJJ~:[סA�`F.zUrmz7+5Oҧndcth{?�@Mg9\m-i+s#kl+�"r&2bFEzK҇ϫE`f'!e }G)t̉?�@]g~)%7K2E*?m5 @#۶8|6s-opN@"q`wmfLΖ/菾-I)UT IYIH{9M;>_�p<psח~Aܣs*3zGcS|w!|k>Κ?:?�@}M ri>] 26F;{4�eIK2:'Kա,Wl5!w}Qh1=mS?~W i{n*WK + � zzd9ct~j)zwllVGgٙ8l@#c[$:Fm]� gD!~Puhܬn1dAFIoBꬤ+&}ug_*fѹ44`p +4?FNRtA:4h._qU۬$ GY2ҫ+UH_jv>5\3lBHmsw.p ++PJݧ5^r#K>r�zzz95 =!:#h ;vgGJ!{L@Wc!;DUcs"<{eJѽ|/mi6q^K'dDHK|XSҦѼ,Ww +!JWBڄ�Ljt +BkN|eك毦x;jqГiLXEH{ Zڹ'12xZK+UFzg +qW, $ٖ=BC�]l4OB<7t=#by!zm-#E + yn] ⻆6^9�O  f!CwO >'CWOs8! B[}UD�]%:d8Bl(| 漶:wޡzLe +ljNL47N'� :T=̜&:k:4nVyu B}^̖\A�]Ev:vK0Us+Y/Zl,,}?w؛6H}Efm ivLT bk?�F N|8R;T-]3L)Zύ.ln�!=ߪ%Kr$Ur)ŒSAo?4v'NClrvA:궸1 ҴbER�ށ@@l,,ɯ&Jt&ѹ<%\՞Ww!M[ʣb*ba$`wAw?VG|) i;]{mmeAh:e*9?$;!.9tȏ+ot|3ȝB6m*=^�J0E*Ǝ�'g~w? XrSmڭ>*qW=XAdF:'٩tg +mQfbPd[!PWS[#?";%O*z٬HDg%EF+ÞqLTe\ "\4HvB`=˼+>Fd$6|bir3% +TDļ(Z8&4;!Pl<mS5fJnҝikDRȚ 7o<9-#p;K&MV5A^m 8Cy<bn2D=fZΖ;b~G՘a�D1ap8sܓ + ɸDDJ4ݦ)=k%b~s7iN!)3f;oXq[oϳk{<.Z6:)u�2+<=Xg4ep#=׮F"HY1_9m $Ŏ <*iq?El,ӖΆ2=KUO7:7Zwu῿�ڪ̄?֜yF6::`Q/  lVN_R86m_v`dx֞&&t(wZq\͞:nC l��!(JO/-i1m\4O)H W~no2 s7Aj@'im1)SF!-[zL  yQ{6,qmU Ih��!*HOQFb B 4։mq,6H.onk|UŪ\AQJ$=ӊKV9kd�@Z㭈tf)[ Bp湓ѕMAnJ$O>H {δlL*`σ|eO1-Jt|= �p{KaR?E CvS/h Kk #F}dwHD;<O&Dp=lݻ��]^솧$l6fDH߳(Խ O+K]Je{kl-ߒvYk [UIk؝/Hn&XW߳��4i:wq4/ccJ~ҩ R`A "i׏i{2|2=?gMV��^.O%ߜ8u2"`,yA.,N#r;^PnT ZАf@A;IawkD%w)��>'۰>@wtg# bOSɁpn| 9pZIy,+JZqʼnsʿ}# ә�s|\|?a]):w`̑|AdDw}qC>".\lj)RZn.DL��xwKǚ}Xc B +.OSn4T&/";/Z\dQ\h֤?Q.ρ%qbvOۅ~̵mA;��޿L"ҫ`DH7^ljN<ȁ>m>]Ңkn^Ȏ.{Zzc Җ߉��_6=Xb B +Gwqg6 +Z>m*=LuAR׳ +v $5*7c@8�أi,ƽ ^DH"ҫ 7CO%/6A +;�uM>ySҷ{JB؇ggYC$^��.x7폹A;@x[ϟulAD nߒ*b7̚l=#.Kױv5'IԚS�֥*D~6zt."`Xm6H}Ap *'[@FR9ĢǛXMDojW*TI~xRrGa Q| ��ZG XL[+b})D6HCa`DiˉuJnT ko#G%fSoT wfDɋ2��h;>x`ZDHaḾl.P72:mpAʭAD4q n#3!Om vτ;MF + ��ڮcL{I߳Y] g$cAt)`G;Ų9-_a( q(SY&zZiUcu\ +��=Y w,"`;;Ň Lt#/4K#w.:V8~L:^wJ%-俟��@~Q9~@x\|?agǒld:]ӄŅ}7"M5N jφ<.Z:*Ȅ�� +Fy[?!Z—7mxAN$Q6HE/3>V}-hJ#YDF)f߷$=ʓV9k��h.zi^@h) # Y$7On&(gB"IǾ[JVd߽)D{9���ʿzs}b B + 6|+WU Weɚ={6hX +p7?-=wg>ʷ11���/zVaZ%ܧeN0Q[8.LmlM 긴c&-XTRqOQčbUDv^ .A@:c8`6֩VΥsb>p/|9>a=0qs_y&7? q|AV̙צ{ -y7Ӳ;jNE<"UTw +��OR]|ERSh 9xu| q(dUT&?Ϸ.[cB: _xjUB1cE0|kJ[m;gBdr��FU59vZ?@cYe<kwKWjԉBq^Ut){;VKyv¾-˻"y{;k-(E_u~FHKU6I{�gq- CDOa1l,[ِuz&pL~YqG $+3+1K}O��<8a_zTOShlA)[}噻[bՓ޿c8IzT6FOŵ��Mi٦SZw? +AiۇsWU|w<��Ķ,!7DOa@e#ٻWl<��J~T^LvMLSP)ذs<եA U�p>++9AKSP͂w +chy[<W��w;IZ_?jrsnEU�P>23!\JSpr2F g~�䋛q!ZO?d)z<?�*'2R/ck z +Dn5]:7HT�Pni9Z??qn R<}��@c;n7~%PFSpGr!3sF��1l1z֋?Yo3K ��h,`QZ'?;sn^?yF��h vA)[}>d=w+>|\Af��ZM@RD? DOa)$@��RMUΏփ?T87-6 \urn��!Lts:AAlKwrR�>v|wm7DOa^+6bĄ7T��S1}ʗc=Hnp{\ U{ +��jǤc=JnMAKu_��<:A2o!bSF3\y7LO՝�nndw3PĆ >hHq5aK;=9:A"2 }޻ ��NλM[j] GR|t15wKnNؼti<a|=hP*7ȝ#쮺;��*zxȻos]}6O_-*Qs 273.�[o=l;ARϧ>߳?' o\uh˪;�u3{PGy7{c M%^[{Xٞ>[wЛv5dGFVAndS#��<GGtwv4t9׆_w#AR 9sw ��Uu|knu臽 -[K]ڷȷY&n2qb8l3_)/ܑK��S|E#v4t/7Ae=\٭{q$xޑ7֭гC{}+whg}�@}T)>cNż oO{닝!D1;O?0nLt5s.hnz`N�Inw3;?;c۟i)c+/w3"^_9I*NlV)��<Ƀjzܵ=A-mZqW~`~\o9{�ǹW,k?;םke徰 Ǝ&Qs4^bwVJj\[��ҕ= \SڱsyQj~wh.Z5E",�(tεDOa9OSYU/��<woL4e]A/_j)l3w ��?tt59ۘ_?Y3],W+ژc��qن z +Q@r�y5T3��|tWTko?@sW08 +l24]�BΞ} z +͕Y-loްOu��)n[fBkg?@sup-_T7��Hg "2׻)4gCD|!x<E}��_<6&Tg1u8nIcJSQC@QDd9,W. +ZcZFXڌv֨cz&:T}f>\bԔPAd +ݰnVwrC7�r-rdNr[ 2 WB|1ڡf7hb{pY m�jmIs))`-pf7lV0ޱ?NlJ4sM-q; 244VO7&ffͥM[D޺]q}Woto6�Z5mF?La�x^í;,zi+-v@{Ь7C8w.-p29>ּԈbVق gO@{wipƶa] 2eyc?%Ᵹ|WΩdv�\cmܯ"S�ZÐU[mf=o:�]s?La�hM#"[ +,gi~e5ܥ"S�Z[eV6)/fiqQ)�m3K7jQkC;�G 2- 8-n)wGgLL8yƅܝ"S�ZϠJDΞz\:\o>�cRlpd� ]ak%7D� _tm˼vrK)�" ^7]I4Pães}Ŀ� ]lL"d� ZJ-V],�� лpX\7d�*XjDePgw��;yC5O#�W2h|0#ǡf7|[jud��K.tF)�뒑Z9Se27�{'LzD?�w;Y!.�mr'Ad ++ cSwϬ,O}��AŌzuD?La�pu]F(!bG6vUÉS!o�h .e^O 7uZ.ڻ}'�2pqc�О[%./-^ۧSS �<\jf>)�geCՕf]9.f�?kk{Ad +@{5fo9%}7�W%?rw"S�ڳ˽yz՟ئeO?�s**YͷTAd +@{,5H*L5I �ӛMIcϱ?La�, +j{X1k;�_ueiv1c?La�ɫK+ZJ׮%O�@K]sl?Ǟk6)�2zfu�G 2Ӎ 2@VmdͥVo�g%Ad +zU6잯¤S承/�i*.lۿe"S�::ZkJTo1�ໜKjs0c?La�(~6MI9h:y /_#��g'2սb�Б8JYg^=q�<VDd^d.)�rfMϻ9�@W%0vj_%~PW {�Z9W"S�:KF*kLt^We�:bzcuV=doLƿs=� W&w9Y.94o�Sjr v3dOjYc�Pw qY~o�C.Փ7&9:jh%�-eeEdnfu*&kؿnbW"_?˥WP�|vϳ|YOM@~>Mo S";A\5];wVLM�f%.wzGޮ0O�W1wφ>bWk?l>P�/3K L<ءsik?}E"3୾Jxo�/ǘE*}/,N ǒ1eǪbw5@;X$'r=�xy^[lM ;<֞3C@gм?>[}c?HkW"_?ڹ2M{eqJ^7{rj:gWYwH9h.ۿu}D�J<)_AUwjU1&U81ɴL&vƌ;1-`\ш[b2p�W rDVMݢ"(4im2VE+Gi+Ǖޗ3xy ^; �9r-wg'3zR>0ѣ w#pgE] 0Q �M|ߛ7&۝7iJmd[妥Q߲?�<=ng3?/�ׅ<{2Y]7.ҖϚxa�1gj?_ڪ.Ct nt= CZǞw�<!+}h^:%=@|^f|r 2�F>'ɁM=erUч �So?~$}a�GkJbWj?[3^*�pWk=N 2�kWd �R9qɼnsSD?�:RYnM0n#z~uTm ϐm �<^m^ԻH* KtW&; 2�KK|N]nRleܨ?sj7!"S�1<M72'0}V[1"S�бQَE#y�+5 2�o`X%>/=ٸJ/�ǃ< 2�b VXbUGj?�᫵<[ٽ`��|ciy#fxE8efwAd +�p1="f, X e()�p =+sR?{uXe9ExqMГ;mfAd +�\ˈOguγ誣j䡢;q(*ޙ.?La�yfꎏPH.xl;1/-&?La�k<\ 5hh(ӬN\x?TېevD?�nuiۯkUA~{G@:-e`��<_%:{l^,`*2OGjvD?�}H^ѿDוj[xK�2-foAd +�+*]u4ݨ;#=@|oJ5빕IfAd +�sG)+ISWݳw'�GW#y)�p_>[5{Cng㈬MfoAd +� LUWF[ƋQ�>q1,#v;g��+ti׸S!~Bc0{"S� +5I]u\Gޢ{sR־bD?�@./,തrʘ {3ީfG 2{"S� `o%<3nd}o>c9Q!_h6ܲrٛf��yݙc;V:*'c0Wѭ1%1-?La�~ho*Nߵ�Oc)�_oe^ꪣ"g2ޤ<0�t>fwlr7;[xc~BfvD?�sF"V˞"{]]&}jnD?�<\Bu݅/3kxފafD?�Ŗon4TM}Kt:w e!U)�ܼV>S߂:}s6M|:x#'S)�!h{U{}f;Wx:{<o#M'�ඡ=,Nk:W?=@|/:^5X0?ӷ 2�_O}[Yem[ +?�ٵTNf>s}L%�̴e(VJU{<D3@f7c!ަAd +�ОחOVRYE߉| 2^:e[d��MБJ{$[qp[ ^;d��܋Vmߔjlu�\=$}n?La��ˑΝ]n6e+f}c��ϐҬ~M;V@|wݥ-m{w"S�YN%'E7rNkAfe{Ad +�E+y)wr'3'q;j,ߘmﭱ?La��Fo%o]u4UZNV.�wS_5(�DФFN&4ՉISxתa4QBDEA] AT rÞ]vAT-%\6d6^1l0f~d<}}Cٵxr Tgy|j0f �h #|vrEWЖ\<H#ǨuSc:ͫl[$/\9sORL k}��QDG6]l4h Npwk-C*ZnYqc��Z!@0nR#+g׊vrdV'fmѺWIXoU֩cmw�@kyi>;G&�OvY=s}bOØܗztȒ_xF>.0۲tiw߱?��qR=sNtXgy':j˽kˈҺK)/{j]1cQwHec��Z!@"<l˯9Wx<Mݸ@?ȓO<L"5ouI^иI>m?��O s'ԷI*lkP ^ P߯OߔZ-Wz#k^/^b��g"HHݩ)Q�OಙŘvw4^ѩcq;5ao#[GF¬˞V�gv>+6]݄w?@2ƻǫC_djOcOKOPG_|B՟݀&{?�ڏׄJ2"߫Z1H|D)S/&u_Ԟ )F;!.*bۛtۻ��Q=RZ' SߡO?s<=uW +xj +R7ԍ^Y#l<!ӛ� ]JKMbQk|[tQo2P뎰?ƯCi{̪eV3';3@߰?��`i3&5ܭ +ϙ"O1Hglu?DOa��<ER99X}{?)](29 z +�i/{|fe~9GU=)�'"XJ-gr) D͙,'`LK^ z +�:I+U7BgG@K;NzJ.?��xI,+Yz@W}hII ~ZwA�-ղ@iØY_\l +p9.6&A?��ä9 C\\Ԗ{;#Sv6uDOa��ښ[;:ߥovTua^ZgA�-dXa?k.G?ƭ?<ޛyDOa��*?Cd2Lk?^'KC{]`ͳ z +� ]0WѩDIq| +v>&iqS��=9VQߴۊPh;GRmEc47)�^y^(U䛇Sń»%Cv56)� Y?+\Y;$cZ|+ȥ444)�u]4ZhM3o]{&ДS7ݝgS��= K]ݫD\/ot= |ߝK)n1(� Z=K./q)rY xm 0)�@{GHkPͫޟz{'g${SwA�= ٹkbZXn |u<6arwnDOa��ڛWM>,ʳ;U˗LA~}Y/:MݝYS�sp)ڴ3P}O93]{(ڧ#Y+)�@{KkoYtEs͵4͙kvwNDOa��ڻ~+Gѥ4|{:&6gNc}()��J äyI#ĆJ{΅cRgO':;?�� :zпݝKS��<깨Iq>:)"B*9L?��"=r*=tĞ{i5=yd=�Qq }l'.vEEwUO-:k\wA��=dP_V3wVGTڲk3 z +�gfn~Lk+s:bm?��mmvO5w*g ];yIe88/"rUUO+jS缎ohU|N)񢼉Q1QB $]H"F +VawsƞAJ!~3n>} ;Ě��7Rlmg3 ϰ0xfJ5?k +��@هϧ}~=hk`[#xcap3ʇi 7Ě��fFnlrJ, .zFVouXS?���^sb*Y]ByUϴ08H=9, 1Ě��?S(Zΰtk[8g[|/eXS?���BoJp{kMQbg\\!OObMA���_#?yڬ;DfL\L1OWbMA���kk=wz0g]<W/c %Ě��0p~ˋ:-SUOMyr\KV3?k +��rX@e$VMCs/X{#;EbMA���01N'XQ>fg_Cɇdhch ���Nj%%d}t)P304f$\75��]زqRz|,s0Ǫyo9ljZk���cšH;]}4|Ԓ|`~[>a Ě��UTfeiًyaHggb0gL!ݭ\'5��_ҴzF `;3aΑ R3}d;T_W+n뤥qvA��� RCm Lz㳞Sa=ab!jIAP->Cʳ3qk#[#C���X1˨d7KgU0fzFغ@@,1{SfV+[~qxa)}?���,}|*x$n.,+w-͎94ń1VckĈ3WgH2?U.v��eh#ᓋ|~ja[bk˭½)>2j4g}gv��ōm#{z?33^XuXjrr}[( A���|IO1nkf|TQ|m 戝IG<Lz ~ +,+s- k->���ÌD_J7p{{ˡbgx=??PFk ƞ=2O3H'0AD$ED U.µ +W ��`ڣ {'յKh姍=wd3j3ÆuS(o(9Z;6ړ1c_zQT%Ψ,I/_8Y��� yjŽ3A{CoȬ>+ls&#sbi3Ç>y\DD/=&���LuTN'M1!biN={dNC@,-:XRu 5bQ^ay���[RB:׋MS`' .ekƞ3b t =04)/vXRDC���>ϊ^ҷΰ?9=WihDKה4|?Ks(|AJ|ZlJKE[}:��:LITIzFigԓ P)`(سE@)n‡2^֯]{D,N16n^׍* b뵌^VR`oSc>Vi+^*y_p^;3ɏֈ=7Eq.LL}y~~��x38F,l436[Fmƞ+bM1W"98S(ۧkɊ}\3G#9(Qo{T_GCLY(l+raX*o,6^#ܿS`rʒto^ow5nZBhԭsI:B ݧ/��o2bNu=Ǫyo=g5VJQ{5\#JCCc;eY >=1HWXc.(| ggy>ݏRn&uAP-GzH=cQDc{5�8w*G#9FGW2˽E n*سD@)q%d&tY{muBN~&=u`(QSIɪM\Wyc|J$%ǗE :=P!Jyr?^ߩ1Sk_>?��"\s~uRzӳ!i9 s96;w_xI4w ŝ?:z5nJމr{;\oM=(~5uq<Ǫuյݪ۲ڭAG5X�`mD@Gۈ$KUd5XV+VTtgg:;qm7^p79s^[j]mF^,Kyʼ7ayy|\}2 7k5S[  DD<[HR4yݽl#V{g @pU4eN[w#=醊\CH1H^v.V /`R&盖|Jљ\CX#fE9V$dRrĪ.uVxOP[bB2(DV$IlsAA7%"xyaſ~9E%7q !7ЂXR.D?0䔈gdZFj5UŰ"~LW +[Jc'ϰGЧX. عi%Pxixi? +n߻N{ϴ__eN;}is Nj7--ߔLCS3'(cF΋,Os,I +kv }2h/(vogeP`@IXAAeη?gW[[~`)LڱVgO>ڻu{FRj;2{昗ɧem {߆vPs iU&sg opl Ӹ=*sU +bFѪAQט1>пMU0}v�)PW6j!^+%a}'.p14y9Z<k5A'Tp@uH{B!,т?}- wyԟ 2ZF NW_c:]+3k;179%8F75Mw9�qȓii|/tx{n%kh/XnW$[UigeEuןZ=? pAf<|кyFĿ>:=#pA!,ޭ@Yԥs& _hOS_իTSzh癫cCFg:NߤJ|q79R&A33V?՟eP䛫Ʃ61=}akl{gx;|%aOif+yizA1 L�]pi&5qHzڃ^B@8j|2aѵX eh#P8@Li8!3lop2v -eh4|o%}�~V1=~SaQ+`*yJr3y?LVmg )1ٓ]9Mw=<ևo.T.Ȳ䑜wC@1AA ѷ8(Ӄ$4"и?"~\CHAAxm"tx#脿jm_ #5ؒù  }HB;.hߺ](t Vu?0?A❬D]oujR߇:0l^&G!@  'Jˆ,B/+ ~(< +rugCHAAY<M8M~g] :~} <sB + 4qئ9(G2*Pc[$Gp7 !1 &FWȕ[H)6W weˑgf~)ga( �q/[ڹksk`)JBI'ϙ+Rwϫ2⻎HezD e\]|AE~v栍?6o]?TBLhQ03F!FJ04yU-I>?O/JV^A3%9j*ASUVmX˿v~lۺA[u?0?co3z/T !_.OANCis~IwR&ߛWcNR- !7BJDȶ~[{p;y2vIh?5*Fg#M^w9:=jk톖3 +ZjGWs8Nuu3++>JE: akI*?'yog{x'Q ?E(~;i*F@Mk+mZ >ouˊ~V4450%Iɛ +utl#K,uEreNl\cCT}"z!ʦӳ/ 'o¾ 8V6XķV$:۞) !7ЫrKm>_T#ЩS3VPL75v?{cL8� 7 WKx2Ӑ4v0ǃ9|"m|"˧$밤Պ]apabRC9 +4δ2Ï&K +3ϏoWiKԔ56 5nt}t.u[^7?vU Psǵ +Oj2Boޫ.] RX]upPeGZK[e{4~cd-Yحڂ]jٛ--T1O)F|`o,K`/4uo/_b a]�dζW=d/1ׯ3gwu0֒^\Zh{sCAFWE59{(6@׹2U#"cJR(5k^ӹ]PKI>P9na?#ͫs[NC`Vc~_p.zcVZ`|˟w)'ρHաm>696S 2#̫ptTޟ>4h9ȃkpw u<Yspr+'rײY?7x^5?ϝu; 2rLJZA$j˗K|d5 m,?0)?J:W!Ҩ|!R8V𙟹v>.5dzqMnA=͵''N;yQK\MS$~p@nHjv!pm?dGZ||>q.|BfpMu\n8{,^Z®[}spKb ȳ4aEg'e2@?gO_`SHա Vp¡-~46'i}~Yӡ^[`u hGfN 򌓼Pz-_w`pK6Y5+}?8^뤋<WD5ǭL�FGsyXRrXXipsY\?>vmx 2:M_Miu6ǙůaoerYs~SB wI&~>2ic(Z(ptT^jap +J@[bk rZ-;II++y%^:jI^-u?Ч4}{EM8A_Y@/̃C8:chε_ceg®9ES !± N}c! |[wti; q\.#" ]9]+BQqaCRŜ7G>=ʐWVW/m- 0>H7=%}> |z3k~AgyQ8<e*!RQ|[ކVw'ϙ`S1j Ը<[v1NosW?}R9jf䓍[XUOCP0[uh/ȌK2?ˁ}d$y2vzē +y� gfȿs2FN 26J 'dֽP\j:ƚ]M@D֘;ѥCuihj�}s.^> hhܣ)]$5խrK:˗�Z=dQr0OB{qH~11~?�F?4nΡY:I[`LL3۵CwK(솹 +(U \[n H9>Mu!oQ/'%x~9'`@)a!/Kաk1g#U3e+PSNog[&7 nKO<[G k~>0*(U3S:E.5:kÐ~v! ~/6-UW.ML~Hy.rxÜ!`|Ӡ`pN$!yRp>c[|mYWzބiPiJRqr&\QA: No Ƃ>_ЖsFTu1Y/E'|`Q&E"DESmi?S  1#j57{SYhr9`@N^ќ?,z,JA-}hZohuh )_颭7Cb;hryMFs.cpFfk륩m{O Veh%c^lkIL?0)^dXrSj~AA1SSˆ\K _=Hs,T1F0ŋ 6kM=ʐW45_Dzb;H⥭XGs 2!(B6^|Ai0MuF0  ΔPBb ckv㕳ReuV?0)?Ay^T춓Oo,C,`!M_?L  kYfWXN#=HԖ/?0)?AyUri*<pt|;RFY4h +,; QI +BUi>nKA">&a|D1gf皺Nq^~o{{=zx0,1^מrO @A4(/:US=gp)#m +WAASU'>#=:oumО\aL?ve}"�>AATLa_'r-lѯ^ʛn="�{1ۇ6H!s*rZׇtVD(T(\&YAMum+ρfo*dӃG\e-E`lT^[K!w<Ik;thNyc @A5О q/O9_[s\l7`/D"9m{C&C(5FtMth8\R8 x g:ZNK:cXpnЖB�\`-Lsq!<BiCOX]Q\�c>Cǔ/# 66u)9Ò^ +hk#<PL^%l655uʤ5~qǎ!&운xGGYc,]F}n=!�.?s 9yUEQ Z]3 ;3GV!yT }x,ɦA�H(Ica-'8ѹ+enkT_[ qǎ!㉑h"Vѩ>sֿ~Zgӽ w!jm0_٠~f\8lN^Ugk\FmjVp]! c{*49T*}wQA.КIϬ>hF{ Nhzk#<PffsNR]iqۈ  &h?]]@3\~$P }ZPÙӡ~w'A"A䣥  I&ڧ~m� kd=7XvRYf2������SS99>'i8Ő%^5=FϩF_d)תvʮJLXz/=������S 9 1@157rǓ^FD +7���������������������8  ?@(kO_m ,Dlnl&F;W{ƺv�QK.gikegxzڻd0N$E +;Ku]yUE~f =v'壎qQfc~q*'LJ~Zerӹ@157τQ>>Q~&jm0޺GA^Yuy^~$} �SYs\_ ~sg$h:˹(+ˋ.7WNc0IhPg gmOdg{}o5.?Xo5^tFvR_u46NIcLxbIvʤRv +:4_<SU^`q%chy{G!d*(Hj 䖲&!\ @@YwQw8{L;## |p51-ΛO:IJ71!oink_+˷jrW +LͣzFqM$z3F0 +lǘ?m:x ʂ# =4Ƌ>zOSkQ>{ME5JT&N֠9<˗R }9<kZGӹy~ҧU՟>bK cXM0Jߕ؏#( LLvX>w5Ҳҍ#U & +Z;&c~L|<<߹ }?yAs_hm֖i^'l6[kj(IkX*'ѧU}CX ɧ{x 6Y.t|Y=ّ".01Xmfk* +h +`T"=>z)5<%kżWUzs?N|[݃=7I1qZLŠ%lu iP).2(ЯU? `1{ <-e[:t<`/Ns.01X>bǓc69;~]]V'a, }Z_u %1xM!lT^v*=<4sz?I,A~/_i^ZVf; &#D-ɠ8]m6M}]쾖#EE]`b?iqToP�Q{T}ތc~\κ\E1?,YsS)pg4$EPG"AfUzF1hjDRq~KyF1p$+ +M!q$e RɎnFZVW|d*Jn[_Kߚ$gG(cp|ég!fWnvs/ww(fNl_?UVa�.jJ*մ)J3۔-ZJ[5Ԭ0KְK9� +33ue[j`G`L6糝ힳn>O'GHIe<ʒcmekN*1LL䧦m[_zx#u޻5;F%22b֭?~aִǮ#w^+ +w̩Ӻr<-x|f;ƸRw  kK'F<?4;]kھlg[JBxsDZfhm>vdߞҹ7n6nȏ{gfgK[Q[Wo7F>kabG׆ZmQ%OǚO}qAAlvŶxTDeGyn4=1n>kz8[\ֽ& %M+3PYVW'g{kܠW 37 IC/ 0FfeuܟsOtǡOj>pUbC2ywm}t`oF\r;Y_>5䵵je%G79BMQd9gۖP'w=ˎll꽖?yJ,5=+_\R2>C͚}20)H&/_._7%pV'O' %7*R߇ ΞmqN uʵ{{$7/kol}[6dgq DMocxpZXj^5=5Oy?z}+oөC?|\D" ;z)\j-9%\oy'c��������������������������������������������������������������������������������������������������������������������������� �{1 endstream endobj 15 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 34138/Name/X/SMask 27 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��z},8~)P(K @IH(U RZBLK@ .B!’ 9gsrل\6 *#RKElEnR_Ҝ+!d͌}3 ݳ3e/<3W4[JIU��byn;;���oܯ!eeS/12���oܯ!Vy/���5ĪC9q6$&$9�� qX21wnȤ'+2iG¿&=Y[T'��.=YA ּ0Y#|yrdOpe"v��oy;~9@;r|FWEuPIѪ h���xo4񢦢lwpk냹 ���)աŽ8s&0Ϙ#q���a;,$��9[B@YXB���<}h Y#h跛{��� dYI=ahD��jN? psǍ-z���WO@)od|E&���p^D@p:wrr*z���;"*nn ���5>ziF^ ���5{]gȢ{l8}plj��/N=>{׆7��{tȢ{<}nzmE��=GC7SF>'z��� ȢgO0w��v''=1^4���ti>? ܁ٿm���{,zJnh%Eo��tu)mtm#���d[U\6���(JoEotRE��NCM@ǜ}ݲe}���V? cx|%`h26���EoaYݦ{΋��`uYDoɲ��ʆ$&JxÖ=|>mJ���? H1+n���V5yR6+vwt���V5SH%Ru z#��U͟=T=AC%z#��U-NO@*}ǚ{[��E/J_ge#YYD��ͫV'I_1lsj٢w��Xю?{L󜨯>^��df? cGAC���Vt$+kKk܌4S��,0gȤkyv& +��`5Φ? ctVR[Y���VSd_o/ ��jǏ-? hc𥠡��j<%k$XYsysD��̶LԝKCٝ"z/��dMV\_U'z/��tIQXWu4`x. ��`%~GU9DYAC-z/��4D Fϋ ��`WcoE19u'!z3��U΀]? h< O%7��XE9\~F <;=Mxk Ԥ>78Vo\��`yN3X,,XѦ{ΟطwzWn2M^6)7xەi_$&$ '��vim1XO+= eb 7yG^G.��j+_xPmuH?/ +]kx>ߛ73%u0 +��kQ?sm#dSmP?6\iiSR��^Gw{7@ lEBoƕ"]3ȫmU(J< +E6r#GAoN~j0��~uJO M4YQV>u폷Gy.!Wr=O~gvH~<5y }K���} FN 5ZiZTw1cv$I z.~C\?U3~\v쫪c_JMJuqI \ **zHa]Ϫnj cRpr! I8"4'*(*(Lױ]]|2]`0~^3d!~;���Ѝ5"_H_DE&1AeRa4?c"=hcyᴓzCBefCLz''2v騷pr����D_.uu]wT??\_#\=2F?ݍŞd}C<IQ&>{SՁF/t=4sCs x>>A���g)rQ,ĵ{y_==mlh driYCS:~ɌS(Jݩۇ'���,D愢?I/; +ָ9:ӝ?f-mL)+_VoCts{X(2lC���[`"J?eRݗMwC<!_YT(MCZjk. { "HA���@_9dzO U?@[?^A^v) Z!:2aғ7tt4}|���~;,D@t?Ц\UrMu:~^25ȅ@u,NKڈ��2|zO *N+g=EyTh kAuHSףA���/8̞S�mx1dC%9aJQ)kKߒ&A���X`HR->X +#YtdH Ct "I_j8��@9:] - % Yi +Q\r[Z ���g:lO^g�mxeK *e rOrIkQR*4���lOے=I,%AAE0!f���Ty-=A^vXTH/=5Hsɏvr8>^���xE4OaG7o䲼L\~tkocR\Җ)���z*)ϜiI7^ (<OVAL +XP ���!s؞暵h G5HJyP)^kèV&#X��%/Rʋ;L�mmOeOdAZR " +C� x<c2ML̥/>]=4o0T8'2NА9g +L +3OػgR]FeN7w\VqV,'3jD23AF�Ћ +\jV?@[?zwmv StYLΩSjޥ D;wI= + d J{>?urIֺؒ'jع?8Ծ{C:G*cd7-5G(g) +[^;&4H C<m۶d4{3E 5})%ĩIUrI  o$2H uXJ7U7 "d�zlHZnkG6mѢqLֵ7N;6''>d og\ щmD׫vUD"G"\xw&R!@tʗrZR9yC\=>c}^/r(D"4V eלȈI~>>ƾnz;sY<dd2h�ogn;7?@?f(@N\+樮uGVxǚ>w�Jt (ВJYѷ]{ EAÓ?Q4wf7i5]*\7]$jIF<<dm䘳eiŝlxp*Z8_P//na#nfMV!Je";$[o:bz}ϕ8.d7sYMHMPOOG Я)BJŗM}7&Rfe5H[gA2C/x::꽘} i;{6&Dz i +קJ7"AR֋.kQF{FF=wlX]ꢤ*3N^]dj27#RKRy-&nzN+8ˬmhM6Kϕ$Ϣ?@?v,%Jm "e 4]>?v{ғ<k,<]&ysݼ :4k;WHtʗJn|/鰍zgׅ]Z8_P/]r_OMy�& ʡ B\VюV +QkkCOXp@�T!\r&!!P+ {R,xUPmv*3<SXVTR]IKqȧG/~NGmao|)e.Д&1 dJy5<)"cvV, di~ud�󩠩n(ĄJ�mzB&R_�{:-s�u{LԀqF-; ͦ<ǥ[M]լ+AE֜C>Wr\;3U3_&<4SIie!,eeS[PRiQ$p̎z)rAngdR}kȞ FQQ7\(9 W1#scb'[\kޭO-�o?@ {]n$"C{no:bfEOXh[<FcDf_<Z VNa^uAvPYzڡحV-uuS=~N+ڴ6]@w1WS*B|4 j9?0s z C:X٪9g}N,`0 +8[ByflGFwiwDxy5G߉_g\W¥ܧu[t&E+^u8npMtF'W]j~!ZlwLaNHyÙ`}c:ZI6v}l\40}mPU%*PmϬ--Q$p̮~VP\kB 2%ݯBAzx(~T0?\ee8h8${ϡ;3*qF ;b?]Yv�ġMA6՞7l՝lYw}^Eo-ja.D@gİϻ&;K9ED.ÝlW%LiRp!W画ge})Nݶoa9X&+x2XP4AEv0K#K=LQ$p̾KiVZZ \tia&dDoCiJ.Ys ;$טB ͆X-����b/:\;ov֋Mٯ~t͛ޠ[Mͨk:*5O*k>WDZy!3'JWp.MI)N۞O:3"|Mjhq‰�(o=<]::)y88[?͖`in6|kL;j#cX� 遞6h +QR" K?0x"QUݛ)xy,RB=̇b=H8ybݙI"~n;!ZL4M՘90Ђ<}(gj'5 _خhv{W{ZM;0=@ {Pzgڢ~<mސD@?G=$(DM$^uQTZlhE ¼4!+7(7 ;HK{?r9i) +b-rFϊ<.#ӧ>O 1I 6J +4@Q^b:KՉF%SZ^^ǎ@uC-]-M)bq` ,`7< jj`:d!D¾w�?/[vG:87^ &obL-�@p@ @�~�݁3 t ΅L.00Mcez\A}Bh~_4Yj_ +yu6b9gMCo}~ML<'􋞰]O":;cѶx]98(U8¨lhј%Bmu.b]^ź^Z}E=5%kYW:KBos](A7"\ Q?G7Ib`2!DTY֋œwKSߝX,}VŽY{FAXC$ FUf\=#lCPۿʜtw=VqnNI `Xl* &(?>  5ȕhe|:X?Ed 3iiC HDu(q`X,mp` F3 ҍҙwgnBt>14]gy_wC'J[bܣjL8\ +QFrb%0h gPLȥ\JBU8]ݷ7]tovJ83" aῳ,c2oZ?zz?-UK&~C!זW3\@H?`W25ZV~ o|'+zGQI?HNp:犒wc͘{!V~utn<"ehGޟS{ zf�x ^˺2 +L߯Lےd~C!Ԩ%  $Di R=(fMj/WeIbQhY'~'6q!Mñ#@H?D˜ҰP;e __sgqG];fjUYi#c+Bw|V| Q2ת' Is7H'6q=?� vOrSGg͏f"9*Oh $wAԹYAjB sL[4!ZUi:OmkL Bhl2ǒ-@H?Ñ[ ÜֲhDz}Lf+=R̗ !Ƭ.{?@v[9YjMh-z[Ȁ�r-U#r~gC 5 3rTbs'm :ցd|0[R\ѩe,wB}Lh%]@H?$'e. hgOvؖ5.`~?CPOo48tL'chTeAkajbB><t(3\<ziGH<2 +kwJx̙쬋C<, ~fݺ&_'֨d tK=p^JBVwoK  qKߤcѱY4hjX$<(ѪtnnUƥTܿBb'/vV9ZwE (> rV | }"PkYĄeΈ_Xjto-Bg `Wa8~H hA�!fd·Ndƍ۬U3<+wlkITX!E7w}�!'F.B-k*^LwNS=IͦNIRk $Ӎ +!R1}%@P?i4ج /6H9^=zIaCUJ#5mQV\!;9mQj pC!ONxϠo{@P?Bi R? R<cm9ۈE"bߚ|<~"YdODpo5#'EOj.UBMnG�E,&;CClY'UGS17Ϡ?(oq9_f/X .]GXtH`ի7Y6Ǖ8Qfh]ngʹ[΀U%jy3]s4jEs=졃L3R dzV޲ӭ}GI$}:l0;!},==l}|_W3Z5oU~vfλ7e#LBq rMEj<#FҎruo&&@&=F;evj*qZD$=й?@UL՛8Kb:eܷ\^U)*VzZEIElLE*/~A!䧏N+B7֨Wzt{ƀC_&̖6.3iǭ|#1P[6݅lI#?J}q*ЩUQO=*;Ҿٯ̈.}!{d^6G�6y]4#.'о1ijC8 kk{һd kIq%;CCleI*ն8JTGV/,v-!n'!Ή4&A�'M* z0/nJ<<Ct6/v/т¦ 7wQJ|rEzq[g)N= Rli}!G4WlFL�|@&-dxݶuk9G%ޯKZ~*Yv}{t|O:!I!o"k{'O+WeT5WLKB -IB!ͺCWR}A/~f;?$Ρ?: r:'z፻`N`׿ٯ(;FM414:6:F;1XǫPABE.K]RvWhb5Nz"Oޟ0,3~ޭ?K io>̴J SM[Vs凲;%,eM��4DE秩\fWZ?:?ϙGܤDU7t;:,\aڒֹ4~^Ύ%͊ ]&-�y.ļkqr|AN N&⽢wVsc|~Ѣ7 `ۭ3kޗmktzbUnM;Ǭ6b-eca0>3%l ׫w+'lq}3oxoIJw��\u #PlF 斡?=y6Ϭ,-BUZANMO{f(5۷k6P=? T4bF&Dgg߭TV|b 1Es$)y�Rt,0'qsRBk5Z<Rȁ cݭZͥģYM;jz_2^NݳUb?w4g=n<?!f]IVJaL'?~BvU,]��5U䤞ܨs$j_\nRBF<q!Klt#iM{d$ݨ)#oN-2_ !$D[4[sڐ9;؉sJһJR��9礟ِALƇ.(:Hm~!S(I׳u,ש/֤UNYүv_ġՒ:I�9*e]=ShQRxcNr)ہ%v21+a[ǽ-xxRiH.R:��Xy7s?aoj}p!֢*/hqvwNS,5[M_7$[S0>eD9��}:EU?$<;rdwLuGv$5V+Fٻ#3^6leNʉC;ɿ�xԗ<BGL J +OkVshQtD8trOdg[9o~G%$[uLqN,�uOwO .n2()<XQteƌ)t|� ]-\(ѩ4VW6��3mX?<S"V%:=O /Iwӻʿ�xtg[L J +/bZwwAN,{Z��-#cjS?oyA^:I �Rl.Ѿ?B:jeAΕ ��kS]_QRxY.Qzft��Z^WSͳ?.Ѿ\, +J{��%9 vwA.z4t�s*- ?*fŮAC + �� Q=-٨s-Ž%W5;n]/Atg�kHg%FͲAZ~v\ ̦��jndӍwAZx>bUj ��4߿7?B@K+7A��h[z;qO{y1WQRhiMt��^ޝrApx[DI5&nlL��rUL.nwAZ˂ߊjC �wf Fo*()Iz}�sE\6SQRhmn[O:��XW>g?~*Vo;��sw{u.?B@[qO:L��WٚytCDI--M ;}ʽ�0W7*3LAښGjgbnz{�`ߒ^Ya? P{1wwjyɽ�07!oMwA +^K��s؂tf?B}!毱M]�8mT$ӽ%9Y/)yg3x\=��HaLMXӽ%>A꾙%�@n5yGrLÁ 2":{��9U検جK1IQR0fFLxfܻ��礝ޠn?`NDY>Aj]��ȡL9H J +A4QR3o7��V8+n6?B9d&jsF}~Uu`? P'1ըi$5M`u=-q2Ċ6 QD4JXv78" e1ƨqgb T۩&QsCTx=ȗy��SllbERpV6+G��KԼAG'?3k *g''��b6wwDKayH1i7Ȣ�ѝ��@Wىc] Z +@ i+zěD��]w+t ;zA\E3"l; ��@WȝӶ?,Ɍst h)ek rQ;�G`Aۆ:A\�)AX۶Af '��xʗ7?>RpEa9A j_!+��xTVy)owh)*eڤl|Vt_��(ؾ?D8:A\wDig.~[��<sqf3wEx:A1J;0M~S6Hb.Z T.7��x_ h{Mݹu)/7Uaou 8j֟z_c@ |'Ita�u)^, 60rlʶhˎc@+ TKPc��U<8qT>M3?%m8+&[nTN$C��c竼^<^?CÚRca@k7HrQne\/+G��9n6Xymm*`?-Ǽa@ 4WWk1](_"K��[uQfC̸kpw2i&/ތٍ>Bt��Y+oVOiՙ<%evBa?aOIUOKu<<в%~Q1i>�3 tw{} ]}uw@Ҥo(7Qcd*v-N:Xx}VNdZLBw +��?)L&Sit$?W>j6ՠƱ?Ӷ VIURCUt��S~:[.SilӻT|ОB~ Vr]{�}fJ߷w\Ǎ ڜ:+,@:XW+Kw ��#gcgL1~.[~g:-AR}\0,[��?NϪ;AzW +G��~̵K Z +=WXf3ZM"�]9Xc5 Z +=ͨRlpdB�+Yeb-("'e_53��}qTkQ[?y %M]�ùԓ)9b-?:حZ6_~".]t��pƚy68kDKa'=&^y]t��$\b.ZW?ГyMtV}yh +9��|X{>A\+Rńd囧'��,A0^ZgM.hz'бʷw3�hYEU95XS?O$U__ds˹ԓ_W60_|OZ [{AwTiR^ؔىcr-b1]v2! @ �Z`MM)3 Z ++ߕ;ޢoszmX_w7�2ta}~ Z + $ٻ_b.F6_RSj;`�WܥkrvSߵ?�<*OFΐg=a/Qttv�tl ?s~e-+޶Hd7F6_� +w̸w*h)�]) 6x&/:/mZ}?�~E)gUkl{+, w<�88u`= Z +@wr3Z65?O/[޾?o|L}?�НFZ 6r[3=�8cv껓AjSL{Wl( � FYIk&h)�,>ePlgԜ9Mth.{51C}_?� ȭ $U_iZY(@ܔwٔ껒A�,EWOg.��Zܕp\Ld-Y۷R6}Yk1]j)��zh;#h)�dĦRzٯ(;El4MִNiMb TSDL(#CP!D)*ȵ³rQATMWTڴVчC>?3?v灿PnD}j/�rзz]x7?�jC}9||��ՒQջ'cES�\w)n�hm7*e|DOa�pe/,xGڜԕK? �@kY5yw]Ç=Ѕ?�:RdFocW51?)F�pЇջ+d=]y6XbR;�ZڭՎ)�1ƜMjo]\lzW��-fuDn|V}?�)<u bej�ZµB|B{?�kg{*vC{Q��jv|Lw?�FJrW=V/֚5I��VPrDOa�pw^!>Ҭ]Q,Zg�댦\~mϱ?�o!URwjPw�S󌻵 z +/&EvzO{{�#~LDOa�Уi;+Qߕ[峧~S�@s/R%א4S�eS%CܡXo �9RP|NjDOa�г#>P{XQ⁂ �_vIY2S�ڃ,Yϔ)s):1�ʜvh;A嘉RRn5oFZ[�/p|sDOa�hO {KZ,oR{&/pl�ܳj<"kLmw?�ߴkUk|_w}s�j:ԲeDOa�hFJyCj^(�о91�m_?�ОyJMo2'�گRܧFjA!;׬~=m0m~s�"9*밚/+A�OBdF3h/$b9_m>�)!7=I+6fE�/vNW [5;VzH,e�@u*}lbCWEG�7YCHڗ A{o{t&?�ьў#-S,uWKF}�п;⌤ Nbj쏺�%m|v䥪5w'�+k1m>bW͗ _(4eyvp3�Wbe27 +�}*~wLٲ-ӳYe}sA~�-cYrCW"N?лck;AZ;~[khzuw1'&ޑua�@yfHi-yڙqyٓ+�'wǸ?vzv. hN$^WƏu3bqsro$囊rRb75qxH3VأXULgv~�Ї+:ܹɢd YA<zuh8 G}Dxc4<yگ]�Oݹև<NcWsO ,]_ .߲?�<=_Z윣vG/�ׅ]}=>]am߰?H,5m~3�x<jVߕ5:{b'&{myawH(1&O}3�x|NsMRPؤ� �}p7&{9fba=�-[piYVbکNJ +gg�Vc@T@~a=�-k=2|.go�z؟7YMzA�bޓp&"0^m<0azߤSDOa�@cJP;`nGY5_ P&} z +�Z׸MOZeVg"nP,zA�Q\CCjV3C[k]3w|Y?�2TZ`ع lT�p7jDI1r?�moqX.}�p ת}V zA�~cx{Zڿ\X.#:A�9t4;ءX*l'?�ĹT:b9 S� 'vjS7�1.`1ʝ)�﹏GIquj_ܷ^6O h[7 +u)�p ^!>Gk~YXjZ: 8~`MĦ&i2ښjA%PZk"H4% ! *e \1pL.Ltq{WS|^x<'\U#^`z>?��2܋mvQ;'y_Zc=/K z +�\H[5b},@:7h-7Y z +�\S%~aUbblk#�ݧ494'Vy z +�\[vqn!X|O*?Y^`=�eETκsw%�WRx:Κ `=�=u+eskb:!}Um,Nu?�gnX-7,mߛ�<ز޼#TDOa�@zˮ=i< q1ƔIZ7 z +�z5gb{ݟ�<<MкuS�г"eڑ{W-[.Ku?�1N1LR_|ߥ�<m0lu?�@?#+Srݧ�tC.Xm?��}R[ C*�ީzs3ci5)�%RTa{ǡ �甙GCnA�WP2/{Fb  1nA�URJsSg YP] #oֺۣcS�2CHli/)8}dԛT>Z7 z +�z͋<阺CM඿l"<nA�.WJ%9q곿>Q).{]nMl^u?�OZZlT޿ެ-eu?�n*35uگ7#?#}lĆY z +�z&J(]^ŀ_~Ϫ7zL杲?��flAlPZϦ>#ɕA/}ɚ z +�pǨanvcChZ0,պ)?Q z +�pKߖ>)=O}7|SPw3@7\w z +�e殏-5¥l_7 г_ Rw=?��8ӵK9}V7ih^-[.;ES�y*b޼#T}W-8r`Qᕲ?��tŴMgjſ�=ztuL}vv?��]jLn/8/O�=OӺeE')� +}X=P u+w71ntݱ?��<+}Ib}t ްXf<DOa��ְ[^qRaDmuI\٭?��< +p)*3li/?հJ|z u*2%A\95Z*HNVYͧm3~?��C`B\#[ڮTs@Orb]|bW͒invsZYagض6 }�x\^dMV+~)*=W{ӛRlnA\1_s~ʃ|�x," [;dK3?�WwؖUbA\1kVV[->^^٥ϱ?��!`k騺C~/J 'wvO⊱rRr&N0v(65o|~c��ˠJ %9$uzTSe5TFbŀiߑ|uCW q9�;Y'-Ȋ{J\SZ)6Z:#y;-m Rvnޞ�xq+wqJj ]twƏ :GC}o}j>{s]ߛg5�<|oXwZjRla{ +u)=g ݝK u׭ϔԝ~ +[[&x|ߺ??O*ݓxi~W�珻7 = *֖w?@j|â};Ւ٧A}~=?_쏰 /~�zfIyejliqxq!X|D-V$uv/jOcWԷ';cKT=Dx]s�(H-ia{m!nA\5Vt~wŎa/yq(Jc&i4ѩ6 x1bjED" YY`A+TK\&vFʑtfO4}f>_󤥆jR9>>�@y)KU˕ +r8.td877 wweGtk<U)#}|t��E+Y7n݊  F_AC}"S��Wtm駽Ku˖@Gi{bwm?La��\ߎ'+l_#@G*h R~`��~JZ|T:t=1{8D?��[1I  +v"m%xٷ 2�puS?^Ql3a!"ОĴ폩!ξ)�@W0%ИYjp)߃.fg��t}Tm˼XR|w}ݴ.6fӢnAd +�L^P}B6lx_ֺ1 ݜ<�+Pp`L=>nvǯD?��]K1QZڲ?;#K뒉.64魳?La��-49TkcK$(qu¦:q)� li7* JaTeo9o)�,< ^6PZoUs\-rqZ\:m?La��d3z{nYExxF_p^b_arz"S�� X6Q٘۠qJS*_PZo3�@f <[ZUk rYD?��fQ]PM79|^D?��S㔵] 7̡#N@sn]b~e��t'ɫzewxlznNnD?��Yޢ|Rj!f5ӞsTfD?��ݑұJdNqس+�;K\aC6,)H*m4)�{1WUh2:ocMwRt:~pލ?La��ୄg%o}kM珅T>0c}?La��S.ϕֆL$B~g7%��SBc><iO +yM?La��y+!ƭpKuQ{*TyqSޞz 2�s6/i+4v, w*}^U!J[嘼@;d��@3Xf5w +yTrֻA)��KY媵R͹|v +98T˵Ȝdc��yo aOM-5s_]9T덕Yo��IJm~^?|]Wjmz7 2�0x){L\^J'Ǣkr-Ad +�ﵘn"sUklr>š6/ޝ?La��xOP6P{OϗVLӕ=lCnAd +�]уJU +}Dw[>uP=Ad +�JzQַ~}HW|Dž*mKwW"S��)kzho1E\ж13ie?b��cJD|Yn|a[tׅ멋jӶջ%)��:ˑ3\R4C|8׃ζ^zw 2�@4FNmZ{'!{/\Õz=nAd +�PC6jm{~/k<BO}7a�� ۵ke߁!Η>-|ݻa��s5x+a cZӅca{0ĸU� {3"S��ζ^E媵'># t6$|?La�� saSĂ[;1:ϝ +aُս)��0x)[F9TkcU~֧׈wOнqՌ+959ĚSWgȔ~/߰?��p T ͧrᢻ1:޽'[6ckE&E͝#+)ѿVVG;��a򷕭:_yPKu5 J]1*D(p%rp s\xD*Im?ӏ8*#W+|Gw=~A֪S?fz/?019%gps{!֐  krbo}.}tR:yCN@  -jEP?A>Y0m:gAl.fy]@r^aoog!<M'₂߬I\  1\.V~1=әg { ~fB7z}pc?A f>S=hwdnFF\>51?Xӈn +~Epئ�bگYypU_  ,"fe;}>_?#K2D^f{7+?] N7z==fɌܢVt:;0FmQ). =}]ȫ{H/1)0;ƛiM!nv 'LӬ7)Xm;ׁpW_8cе,Qפ<Ybh(&X6YAA^fGUYqGhx^v,[-_5im:#li?<=f:!ŒYl" 2r QgVsYW^?4tc&iNC0KŒSw_ŢV-yaq 2)ڇH#+7Yez:97NT(03=Ʈ'iwEuˌ<8AyKyy,zTȍWEƆBEX3B[#(Ѫm  ɁDuD٦ԕ. dFA|P/`[c#e_NyN'NT=Zy[yꉑ/^F4Q^IҰ"gHq\NpEK5F +%jR f +30uOPT]G߈~CC֨ +C#߷ y>D[D^&=yXgDAƞQ+jskldh.P2c<XGЫM}Q3<q7Jj>n?B;2uNu7A^곯>w&eIiFVF9ThG(vPU꯬&M} şЎ g:0w!/^V<6{^S _n{礫*94wc'zQ@A=6Ĺ[m?v yO#`Oc<O'ܢrɊP4G�WOjy$Gs: uv|Y*՚ȫ7\:{!g�^| ¨'o|<GZUY9 s6|],ofF^Rvgj!L{1b,#IQ%Ȓgo}GnK{[rzQ@vlMݣ}rŴL|4Dze0>X6QΖIO׋mגɋGjng$hV +2 CT} +zS>A-ʛ.576Jy?2#xϲCِ(:}&`s325v!=[uxzZZAmi&rԶC`v:Xr8k7i:]ڞ\v˶o.UDs٥1W{fb}\(EYg5axYrVڢ&e_Q+ b_D9gu'>n.u7Pde:CO1H +-Ft14_YejKEi'J-9UˡsOXJ;Lx'Ezh w`kG ?FsUah["K[6j7GPaК9)?8g b_̊[Gz)_~sF~ /a;+rv;n(1<00GKURYliOd!9Po9ʝ2ܵM:qnw\ʯ0;R*}zs֌y-rPVsh.O[=5v;3<`-p O@~Ar K%}! ]Q y9JqLkwt‘Ӿ`xs^, 2ݢSuH~剓`M%qíUbl,%Mdm~/#EQ+s=س<Z>?^aIVeYr+S>lW%v}! YEMO~:cw  c<=uܤLy=N :?=++nGt˨j]ն"NeUE<Ā<D4<WM½yS_ѮV/|vq gs{߸ugD&EmǫM*缘i0O]hh?/7lSmоvJ9eXix#m_*ʌ,r<&/r}! ܫFE>V2'TD*+yYS4$!aJO +$ǘEQ/+Şk5} 2'2* +&__ woz[ +%ch<|˝hcȣsKP/_/ HkOH +")MErΕ2j5 ?KXohbouGtcsBxYcd&珄_x8? ("_͐*M'|;}Yus#9'8@w2<=紌{aߌ̵oDsLk[Yw~a{}\1Udr`<wSWBbMeP;z}_Sε" xGCWw9%Hʽ>;-cӁIeč ^mRVm/x^sYM8K,V&+K7BPL'VA!j6y*?2g)Ք +u^HV +P++~ߌY+M^ - AsK>ҢN |dN3y'g4VY`]m5=SK|عFytR+Fy.E-^C]!m6M߹ A^$B) t-|Ɩ?l`)^�- Y 2_U0.JwBV%,oRJ0!44ă78D7JbF8 0Ֆ"�}^%T7yԚXG)-KM y,LIݔHSlj.[7a@k GԚUuC~ؤ(  _z&o\?0kWic\    N(M'1Bʽ^g GHEhWOAA})Q? :ểu':c|R՘> |o(WgOAA.tWmnHu;_蕽,4v3@@  + Vٮ=IOVƽ~5 +4  ;1JBA7â8kK^g~r`)  ,NAӺ?ZW~dhY\9 >AAPEj qm+M q?0?|&o˛*jJ5XS\Q\1Tfg!hn`(AyvDz̪ GvplX�lbr{O#2=K\ +<uO]ẎXkw_tkwwEAF8y&/hݭNZ~9llb=FpG@04y>E-^<|/.>FEԢVq M !j*)hkøί=qmܵG$F%'lP|^kw byy# g?"1^>ýwgsz{T79EpGQJ5ggavWYo(]vC{ -cZ_rFch׹)V+ڮ0ZRho˛ s8H? ee?2C Yt]<Rn`ü99%D&*Mo$ k;h0P{ +"YY_jQx0> ^'i31UэES٬y TY,J|lLligX�"CS̾qȁjSJ0~ޛ ,+Eɳ6Zwm:]yГl fO`)^U;:xЪj;)ʪ9vnC]6yېkhܵ5c97oQa{e#AsGOTohךUuY@^(e]\PAUVȨ(uKf:</ gr"?V&{BCC|^^ r[Z}F;�j[MgMoEJs^3simUoyg$=X :< +c45+`ټlMJ[di*ڻg» x} S\ǣ"!{nth`�͚KJ:?SZ4'$OLm_ؼJF-14:&&/'zo\e}m]\o&{}?}~hb̎z=G~Eqqݵ̺!VqkGtc ׸A(K99dk`f{TpDn01Q;٪oJ;fܶ�=ꩢLOeE<5\IIksVr-WYDp?+EtύWV}FsݮK��@1 xM{`<}oN ۗRz^?|eg/)9K“c\"gmY9CswP*)c"8 G\KTS=X-By+m̙sD ~cl'Gu%mA3>/;?1%xr\C!g+מL E*|lbB Ifa��|f mɣX5U]ǹ/RO +w(}4?'}[o,^_3nOI-9!עcе_v@q(/XًJC<9 vΚ~/}ƞO?vS<OS_+I\a=h/uZ];ј:񦂥S6jkm"y��aT|&/#F_m?l3Jp7P, ?h+ӤAu/A0 +p4b'0TLhK={i@׵}&"7z(m[h?Ԧ7ߖP]ymfMў>Vq}ԖxTYyu]muR9Fb7Ik *-gL?���]}[7x7܃f΍;ɲWٌJp7 X{^cѦJs~8ΘmG"Wp7!gXD<W^Z\A>mp5!~U:?оU!!:lH:ڍGm= 6Yw��@3-y}/=̏~2hn.wyM%Nə?(qyvm췣?-ɊD5?C|7lg>{bDZzlY6vʑ}3قebG#=MIZ˼'BMhktv47:ܗ9B?P��=ˤ֖lZcљ @ws';CqS=:1!'y y&]Kc&l�хv~Kžw 9mJؖS5{ʴB^G5\3nlȩʎɜA_i]v_;Й[՟OTvJ4V"W ���g]qv޻_>NН|P}UrN';ǠYL^gǎ GLO bSYi{4ٳNo75ohy/%L!z͟VW_U`;xow.~렵[1^#5mGISߡڞ΄qů{?d|L$!2y#+ 9ud~]q|CD棁>KTē+��P :A៾ޱ^T}7ZKz~%g@xRQYTzmB? xwr*ǐS S{-���c莏Dh5$ZoQsVt"N?#16 {e]q˜O`j*UW8SW{���܃O b7{{}v䌥F*_\O +w`D\&dȍ���W2wO~_+t㭽 I*=+iO +XC���SbLy!Ҧ/t6ӝD0@y?����Y9^w\?Q:oǔO +����h?z  Cgpr)9“����wg`eȞ%,OZE`~Y9CO +����z + 5){wj;/qJ @xR?����Гxc"VctكU?jld'����=_2v`~]ˢ_8M)o+/I����@O䭘%`emػǷ/C] RI����@OeJZBA5^Ơp(% <)����I֧7^_}P2/f=?_hbwxWS=5irq#T;Yg8g{~:���βܝC<L]T}x<%Yxz71-w{11wܱ괅akEFdw-����xKQM󯖄4E\Y-ԄW7«_?fο|0`qx"$`Uo;v:+N�1sx]I>s:5nٺ\m}?gYA +xW,Q +JHDGAg"^4 FhA 7[d +++,EQ$:6MLR3Cgo=i.ˬH7 {=s3h#kǸ ?9]?zXz$OTsJ5@<JTvJ?Z?OI?fqTc<ΛB�R0\HWܳnsMeE<>_\./o,uJS' \:mXt滞/CYǯ=i dEH7\w"zPWFRJC1\رqs�%.sWUmkSM#g<g >Mg.K'_>s ޿{A�#!mi"ϼ\:mXt滞=</ѳ WM]nk1!xK6W&PC;nng] hP�4!ܜ.īlmӠz+o&|/! WԷ+!*oT(<8kk<y"?^ AAk&Ө_ �_1\ :m7 V*fp'cr_ ������/*8gOD:!K<tr& ^0w[u>g}rD������9 6%^:.7Vao J)����������������������qLSZwG׮\֤'/,0BJvxU}/mvn +jXf]([Z}U}]2xIı]&YxgV9{zZx<6Y0c&k9S<~c|pdÊ4X^/*u.%^:._:Aτ ^oҖ&2t $-za-<z};@I̞-=z#f;gk}N߷ȉz[fӍ} + +¨wn WkB˙| +>* + 霢V'x~B hdavەһMi:x,/Ozs9sГ>4nPgM?՟Dzw8Cn+<$:x E;Qc9T(-&)k#Cq썰 %?ꏕ'߹t9Y7c[ko9ktY_U9ucsSW漆XSP_lt5Pu;J1ʦ}^+g`M1jJz'も^/+(} u7-Wu{}S!M: :AZ5< r7kx,V,Y<^4k6stFу(8ڭNO}[@ft>ufI dB()DEL +qݣ\c|*hᰚmiwox,T,"4͈JwT ɏcyqY_WQ߮#%^-zm_GScYAa%q^{۟/F] N1'n &[C}{Pe+'E]`t?y6єRTp~,c�4?맢XU,!#V,c/w[m[!kN R n{p滾,dz35wg}aE;{whm(9x [Sw[<)Q⹶{^uSx7mq<'c۞SœRNj̋e?v\npcy0':NJ¹\ڬ7&sXPzY'?ĹWUr(1s4&䏇V61'n &[C}Ve+'E]`t?y6є7P�ݖVGw[kXXu +5_XU,inv@:mVw}S-M57<nohv_,kﭐ,0JxQCB\*W,J0RBT*vD~͍ya˓-[9QfO2`ִ邇}c&Ma&GkW.Wlmi밐X?:: zWDSZK x 3'0މ% !&3Twinjk/M`( +pnh5X~ߞDq5<ۤ-Mol =tpnJ謮>P3x xDT�FlmV~cOPB߸_~39(<̦WNIYxuރsM2q}іO /Y{#z.kebX: Wt*0PcPi*70Lm}VĵV6+fpQ2-7D6[ϝvcOk5hJKb鼢AשK#d_c{DPoB}lm]kM|,޲nb mmf~^��?6HjS"J!]1A1m`A\؀e4ٌJhE,"ZWPD}pr;e\__mY +r{b^' #@7ؓT7#r5!3.4}oG{;0k3l)~ǞVdmw.M2Nr-j{Kb?ި8{Lឃj},7Ojٱs1n$k_O?Í 5<9k{X9ޘG&Ѿp/x;SfXWX9|~}@x<Xۻ- ϜM*SP7ot55c�����������������������������������������������������������������������������������������������������������������������������*J endstream endobj 16 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 33382/Name/X/SMask 28 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��N8@pըiSnn2?rL4<A1RPD/D�Ye>ʂ + KN5yu^^yJfWsG|w5gg>;]ܯ!M{nҢkןNNQ��ղ-;��۸_C4J_Q/ ?���mܯ!Z.⭾��UmϝtV9�� qh<*{},aÕylrheIGn<د} }6`qzll��duU6f)FGܼs~,},kD��@ +ֿ3@ҿ2wƋ:{̙>CIMJ}hp;h���txsblS]u-xk ���)b8v,0~{q���"a-=,ǚNj��{E@p<{���p/ǁdꏀ8岟���r? PTիguU{���p/oyFGqksA'��֊dꏍ΢??~=ћ���pW1kYcEyf](.\$z���UE?%VӪI&���UyȢ}kͺzU&���ue?I@cE$Q= ���w4hپ<}7��5dѾ?ҬuY��<Y>^P9]���q]? E;Yw��ۚ<?Ȣc,+m<~|p���Ц,:[iâ��?teNU]ZR6���(JF@8uvD6���,:\Ͳ���E u?ni<8Z<���kѵdYLڲ$\ՃD��0�teNUVfY+z��ٵM?cUW5jγ��qF@#U2'kߊ��`f ?^ 7OMJ=��0TDŽׂϿv7��՘#H%\HStOyz��jq?Si\Do��0'JW*~%kEo��0WҦJW`P���,2t!z'��e,XG@&]Gߌ4AW+ ��`F뗿 t9pPuAN���3ښ9LM΢?t;;��hwV2?;xREO��0_Iw1nl0ZV���9="t}3ҔʊDo��0wM? 8E>kBV���3L"—vCV���q/? Hc~A5S'N=��T22?R6^?{S���fWΡ? H8u5G+ D��0di?_w^��L|$rе��I? HcnaVW'��).k7"ry��,TG_w_? H8'j ��`2h3e|bl xW܎3{_MIz{NXw4K���Lq]W?m kԜgl<>smWn\皽")zoqqaG'FT=��D&Zs<tQJ[/Z v}=3oc&'OQZZm;7?>UUkڎu놭 θf��s{կTXQ[ep?T#:XȮi$?E&?ν=^YdOM3n}yt[y_<xwІœ&$��gU/;|ĊFwiɪp?SS~n\ºU|n|h|{yO ꐤ?qD](G_8+Js|AGwj{%_ԗ -^N^F�_�@.^.?XyqmV_Gqk5~G5ug +VYC9"n!Xh@h HBHB(DbhPGAEKt)ŸGT4 9?{w]}e8K�cuuHB 639s"!@p_`r:ȿRm E)t\糁>=!BH䢼Liv,G\ȿ"f2G *b'!4!qWd)Dqi=! :W̨-콜 ]>o#Ef0̸_B!4HДV#@@P˕sO 63@C? 4NSIp&PKS+쐃.FiꂄZUٶ_Аh՞SU qo\&+),9`ab{D!E"Nꭌ @8;7~[菌b^IE{q֤{?!lK%i!wsuЁE#4nt(nճٔxaZ鴝ZB+erW̝ޮ!":W%'z)*_@.2 ;ڽo:c푰^mn2ӗ'#bzYJUq'bwXZY`?z/Bϗc >z{t6G7�4[RNy8GdLA{'{P\M)v0jp012G!P)DU4+F\zi߼oާ?eLf Bn{\-K{iGY^}ij%q 5qInl6%j6�:<zsڍc=e<P<77)aehigъ3B!/Mz=˻ܤ^ntS1 eDN,,_Ta b$ݜ)ݒsML</)xwz7;6y q4!136IE O{�[췒T.K[Ϣ3Ar2q.s^lMeS%o1X-ux012!fF{ڏa!zCt/ً.Sqs2>K)::>_P#'zz\Õ�U�Ci-uA]WP!xOB^yxorx:_؂>cg!kh#۰?x}ςͬϏH}t03[ b/}C=gv7SA)i=ޙx�5;�£|o)E]*㱄q[.: [xBB!Xj"G6c m~Fw/?<�gR׬r/Dlon/ۍݿw@u3jՄN\{$s"F]c}=(VJ% B= =mo~z-?>N@+Ȍ lΈvo +" ;4W^ o +e[ϚDY9GX;9ad)BHci+?x1q"qӰ7bOTJwxm@v�gǵ!5KϻPf1"dt؍T* !F|v%a mcB4uhJg%{y>Y�u�#PhVq"&Rm|%"Ny8,#z}~~f  }Bxi܄H[`tA XDzl nwd-`;L+Zn/'/RȽ QIlΑN0̜BSFG&KyT;6O* )v͹bFmG( +v,mNv@!"1$G߳i_a m (ɢ d8,Wb/F�hQf_b(G[Ŭ]cW͛C->!XD@9ϊq@,H,NSHMޛqznr�/dV~U$ 1G9F!8#2wA|k6? +@@`LFpJk"u KCv7}ByIa6'#b<>f.egsCb?�zjg3ęR +2~? T:B>9lHg$Yf)Dއqț�5'_0vy\!q¼y) x,ױ01!##X9gN0@Qŵ*JjkkĜFAcqߩeUDD7ef,w fD4uckSs&i|y^۹yM󊴏?@,n=CQjLAFA0o ~듊݉od2R–-wݣ'���6Lr(W?i ǫ];Ʌ\6ʁ/#j?m7&G +c׬sޛ9���åY{WE?ڦA +Jkȇubls ϯmHI3S?޴۰X��"w bhRAI2Ğ[q iRiINqW&*cx>��.3c_A>vsG' ZA3ر~bcD]jݜ:y}uqaaǢE��:IQMW�1A22 yFT?4&OTߙZ+W(oY[D7t��m HʋiL}ī6E`?i�qΖY{)OZ+|T9 Q`}J�� Εم3YK2( BOuC`?kBhi快ȓްZr6qcx>+��Q5G 2(w̍DŽϞZ*N(ȹ.|E̴Uzv��pV(;f?@Lw}fRV w`v5ERKՖf^hҪpG͟:Y��Ω9)_ЙcPIݘY1qN/Z_߸I9{h#X��xIyEMb~V,A'IhԩuaV=s3j}U{?Ȕo_ nY ��4͸h G"AiV 7*&I;SKզf^`Ҫԩ)=s��ゖA?n` \ 7O3M#nӗcO +7U(fPg ��&m ~"~OBȫn:1boMDLF_ϮA435| +.]X(�Wۥ>b C +W!4}ߣXǜ,.ɕ_[oUM&A?dX�t@Q�1AΆhJAj>f:=Ο))_FRBdD1C<Y-� Qɾm3ʟ8=Wiҩ\ a9DQD-&䷄{Qܿg_?rqvf}��DW7?@La[JU .O fD9гq..nIn;ub.cx>i��bC$  &HSU- R݉aߵsUE|X+ Ĩ^ʈۅ~ٙ�h,w98k v72:4zQlfİZn },ޘ|Z+&dJIk97mӣ�.YhkO�1AFm$jU ؿ11ewf #nUk,.W޳6Kش{&D\;7ڍ9�)]|FC?l-  + R~$sί'KJO +qkd:-t%{sf:0bJSY�:o%c &11 HW՘t\oI {U#*&s>U|U+qc)zmXfԪKԒs'vfMlB3ޛ{NN*�+9F[p8~ 5&^U)zDˈÉn'җo<-3:8I3'JͼŸNP(IOPNY|b' u]_?8z# �=|{[hI.GPA> ؿ1F჈L]MTa8oB%V**/?UeioMIQ1$i䎧8')z۠]]6.\d/4˻5yy~nɉ`mfbs1q:~? k/U7UE%aV83˫Z7>.su?}GVh( R$=yHv9<n]6-tl5ه&yQG^�x)xF{7nC' }Adq71of0N@[Jta=QE$эT7髢w܅niX9+WKgN +b_ߴʛF/=|gFD.)Hu\RiB2+%P0cfZm:uMJ{jRo^:Ԝx=f1|ώdz%:7ǡ8-8/.V3-<\0}؛m9FWS 4΃ +3@H1?Z+0O'"IӐ?>&Vv5gi(?rhph�9]:?5)ڪ9nޭo"^<guQڇ+ٴFɸe.,Cm.0&?ϩ<3ü0)Q(Y}d;=l3k aͲ堩Tg+%44+?Ƈ�My&aiP߷P(Ǐ�O영haw+h\69e^w 0Wd# 1\ASe>~<#U;rQ݉(GevuqjQ~|VFd} +$oiA.w[;k, p*X̅ +3@VFF'&UC[; c]+PO;3tw?�7kkY0~J0YTG³v/9[k_k~ġݙ:)m[K{5Y?}Y3٦J-a?Aq(L7+LJ!h+ɓ|dpxكf6YA_K4‚9ʠ&U$ύV#T C:2I!`s7('�;�d(E Vhu4(>?g5Յmگ]Z C\#/e3n/i.aoDMrY \&IW`Ωĝs~0xsevuIZIA⡕1*CBfF˅{ tryg-`6Y +u@WSKd5ePVTy99F$J4Gji5=T Czpd3U#Hw +ip# + 0�p5Sl;eud2Txf>EqTPk- +v~3rL~ڟQ>eYut +Mc1&w~I2XÜF*}gkJ ZReŔ}u=yv>UYF#c42"#USPJڧW#N jaX -7l1^f D.ZV.^Z ACu>, *@QAAd$YI_9N$[s¾D@!HW)An`(2 +B}XU7@?@W0@w$ b" Y3NVY1F/4mu-zu\kp`p0pߩ𗂸g}IY?Mjo_otR:U?c~~Iqj[H;Y3eR{9.Lb7SKZӛʋKOF1K +E:J[M~SunCeNMEV%c|"^A⡕ qڹ1YQQ 2Iy*aaJɡg /W3-[&Ó+ŕBc'lllE.e%ܼvXXM\4`m̶֙, b!T5lӇz` V\gb讴fr0XL<<}-m],%"XXrEL]CҷF%MTA�?ل&UC6β rnq +BwU݅y 3@ !bE F�.%j,\?�e]<OdTm:tV QٵUSl&'}<MX +¡`gPnP‘`qO>gO \8'VkgWڋz/ 5W.^üuE]0wY ^x,GgŸhp,6fQIz tfO<jͦlىBP(ԇV(6X@3�ElW�f2w�&l-YV_:f;{/'{� +{CZn<h�|b w wA2ϳw?>QsssX;9DvEYj~CzH7yqI&:mq2Ll4jH4ic""Z@(&EnrXeaw JaU.rӨoԀIxofλ3U){Ew^|e��0xB L =VWر5z~!zжQގu AW�ѹ9l8M0.!t4xe}?cѢ;W)��/ڶ+ 3RU +Y/2w՘?l)<K��~g4LJ3ӂ4=n=Gco&l*��8sAJ0F5ūb r9ctw\R]V��0#I9ESt̴<n=G> vRڴB��sSW3RU +YXS#Z_Pw7+cx!v5 ��g:h.Te14m YM+mk~vO}z)ᙹcd- p7t;U.{ ��*=b|a舞0stt)UYr1-A��PSܭS +[MƮЍn;s~=?z|zJ[eR7[��l)<e?7AAcqkCYfgo$M 'J�05ZGeLk?X4Q4HGeq��"J=ō?FnKߟdk/�` {\}?F7`2^xf � 撮E6LK?0I rbF`��Fz]<q ߶MoA��Y &¸߈L0-7yNMo)r-�`n=?F~lh3Si��_59;[L0-`,O ,l]�?nuw`Zr=[tspo3��ZUS ?FA3A.JA��>}<%t<(SlLϥCu4��C%?ܽIq{xSEtI-|Kw��-8?ވ .4ηj�s6nق]~<?ZcB �и6e}6/Q[iiޭ΢A,K�xu>?N>}qk +^Y۟ r%�|^${o,4C;{Żt9H��U;>j 5;~*ާ ��</='sJ0-P[cx>;�6$n3o+4'7zF_D ��<[+\}LK?0\|b~&ޭFf �� U ;~SN~y1/닶m)4��sߣdSii]/w? 4��w3ؿTrQ_t��Ԯ3rG)ڍ"e�Pmb8PiiF[ﱰv��{K+ ?F`ƻwFGfw��z.CQY\8WwBd�Pk U*(w`ZYB~/޽:Bd�P̪"r3ic/[�Z>ּ O4wC>yxo�@ Nd'U(`ZDhou+e�"d\y^r+P )KCw��Z,ws”;I0-Z 7,n��hѝ4g*7`Z5 aɞeq�@#OfR#4jcocAW/}��i *`Z5 ŘBV-}��I &%]?F@Dl5{Qd��FJkcM?F@ R%[d��F\r50E?ekd��pJ<DDewflw�dw=>3;H0- �۴|��p(|׽#@ii'ALYAAjzo��Cԭ?CLK?m +7Hҟ˾�� _AUyDTXl!r֭6/xZٱ{ Jf5A4TD1"&rp1C$gu&..Bj;-?G #~gx4YV=}? vp 7(+��xTJBǴ{6)Wbl\)6ן��< +'W4I;z4u)gAʖ pOdw��Lx熷]A1 Wl41%h<SڑMßuϱ?މ a 6ȏEe��㫘^ o[sm:qd%vR.o> .J7Xx~=Se^Z?�Ixxvj9q ?<DlKϱ?bDe"wZ8o�dK6{y; )LSwLnILtګcdw��#<U3tssSaU?a@oo茄b\]v��[\+-fOm^xqj/5w#Avgm w ��-udmgɄ; m7Wi.~C*z!q =s+&+GT<]�@K86sx=2N?HkgЗ&k}{J)8d:d=6@|'��ĭ܃|vzTO]>V-Ʋ\SaZG|)/*3a5޲ߏp;;9f S��5WOo3L;pZzj:w>Ӵ?_G[h ^5M)P-U5eQvٝ�yH`}oUkLҵsg%3tşc#x?Y+��e䫖= 㮝꿗uq‡5ef?@G-GٗZZ��S媰6cgL9hϱ?QzRT?4*[��h'6ز̧ z +IP濊҇x��~" +m?@G-GoOU;;�{}w<2=nrhA:kg)Ed�Kڍ9b=hqr{<�@=űTDOa#r_1fw ��MƖd'i{A:ao5��4ǟLئ,SȖlP]L�@8p&2ðAW?Б*1f:o)s��4#lLW?эP\-s��(}*SH%4uhz"tAf�г 9ڞb=T<D@_9Tk홼3͐�76ֽӴ= z +hhi^'4oL|ICS즒-b|{<"jK$ �zP-U+1ڎb=A + ֲgz|NܐR/=s,E\S�G2eGUk'ن(:[{�qK$o?�<*O.,=-KRsxx;�Z~'n?�!QVvM<ZkJmg;Kt�hĻlA|ڛ z +@k d6W8Tf�Ҧ6RS�Z[)[ĭr̳͒�4ٱkwAu(%E$x˨{�M1sǴ7A4|̡ZkoWO$Y[ڸ?&GvNS�ښ碱s6_YN�gpjmn?� } +T˿m>.{�dw٫n{ z +Lּ;Tw2$ i�Yyw٘[ z +l=VZs#� \-1E{'DOa�pv-W-_,.v�v%sGX; z +3rPݬ\Q�h+?2q A�g䫬4 r"p$D�� ψwӡﺋ?�87x9TkY.�vl ]wCS�Ye+{ĝvbִ�Zn=RܻFu DOa�pv }([Uw,3Po�h +wYׅ?�ߺ͞a>sT\+-��N7 z +@{7JtfNq.`.5(I4FIZNLFL:hJ�o!D r[=9BAX.(h4j(`6ռ+GNu؝<{�ܬ /Sc#gŎr)Gk �GEY}?�&n 8cQ9yw�<:)}߱?�/"mψz`j-~�Cܠ:1R�_Xiލ#ەj|O=� >l){A�x}<@s)[usƉ#�\*4A�#dIMzByR3X=�J,K-u軍A�# +I[?bTʍ瓞~S�@{)MI.0e;A�zy\Thr)[GC�p?'wMJ)�F$i}Zϝ*I9�½'3軌Aɫ*֋ᾢo �pp~[{ F +@wb,)ȼZ?lAv[�~`&er}?�Н<Z^Ca �Z5^.1R�;V<^_U֦-��Mj֖Ha�FFJ)dbo(�нTKc%)@Wb?�tg}KQS r8?e�WjI)boȞ͛^m{O[-;�^މ_޻HOT@Tخ|/~3j$bkȳ^`�@<RRAN։_$нT%9^xz{6m8Dέ`�@'}h5bkuԭ�>nְ-/軉A<9 |'?�Lә/Tleo$K*V~W�7t4)֑mαF}쏐u} F=WlWg�<RD֗\Ƒ{(�i;cNA.bH=nFhx9c�@ǘya{ܠ5A/S�+ C;XS奥a�@yzi#c֙Wk �0#"tv/- i>zIGWfL tӃR֞kY{]"KI|~fMY{�$~acF+jrL\_7 �c8{&2ɴ;A<)f-ѹ] wGpڡ[[(jz.xBvw;?6}hwxR<5@>q=cY{L( 4߲?�<tAٳDI߉_�x+{h}2~aoI[aٙ|g�p,S*4#,?KFq3 iIs �ިsKK:1;;@-J?&{1z= F +�:Fu`SO/�,Lj )�Xw~:T^Ts~CM;ܨzM64{zA�tߕRζ~m4Cm<4sv X2Na#�oR%)@#'\�f]d/OHa�@皾NJUljmKިo�@bkq#b?�X *0s)>3u�x+:A�t>am=f{wÊ?(A�t.zE<�<Uow F +�ȷDgvֿ?XY::A�;|K58�Û2lN`#�bdž=:.z�qvThrb?�@!N[>v0V ZMU řE:A�x^خV'c|C�΅$WJ>]??��2~v\Rl7-&5N%椻1R�y.}SڪsSUB2Gms/J;Ha�g +\bkR-nT}gږHa�g>T(׸TkSI�:^tzw`#�%{jgʒBJ�:VՆw F +�ܔϔ)JUt9uد(; 16$Ll4IcZM(цh<h j +" ^쳰QX#DSăeڤNǎGƩv3C>90]ZY3YDOa�@wiT˼-<w)7xrs2hg=�sHlSjNߝ�<l6ٜ9BDOa�@^z^_o'?x|'6 UuS�к%msnD= +mHv?�0XJ6gPϿt~ߥ�<z 8)�Џȍ :vXιe۵Qt|nqVAj z +�I*7)׏-[W%Wx8NmU/f=�&%o~o<\j<{$I|1i.v?�@ */m UtbF99TDOa�XG)(SHj9Z|C ǘA�_p|4ǰ[5*yxTȍCnA�i3NIeܬSѝ @ "'.)�h[͏K W+C鎒 g)763@nDOa�@>n4 Jva;$mYÎ>6pd?e=�mנS-.K=u4fUuPXToA�msIkmʻޝQ(mͿvro&G))�bJW*eKŬЖ\?U4R>DOa��yge|-<k4De@[pfϔ>m~m?��INU Tl9/w Pnpջd=�P31{KZ^ZOt?ΗS+},8>LDOa��<eTXn}O499o!R|Ovm„*vMDOa��c`ius8;7%Zw z +�c3?W\vXVɍu^DOa��(ikN[.iTqjLgnA�QĿ+}lʈP6Ѳ5w7\rBDOa��ȍCv;,g</?ivk)�4RQG׮P%QCgQRDOa��Dp|h,-<ʌ,rͦmťZw =@*I[Vڭ睆-1�!b}BrZ5\StZs[f;b_Mh?gcɚ`RlܘR_K6=X�iy9gFk{|kkmӰE.Rz)#eIGy�x  e[ Vv;,*l{]?/&}Uv[}HP69�%`wYN(;}D;}Qf8p=?/i(r(ʏTa5~FXN-Xaϱ?��-˕̵ N{CRZ J嬲7ֺyBuÔ>iaw�>n4=uJvaf]m\Xe:CY$0 YZ5x?3;{9Y3bp`a��&-Gwխ#E=p/-eOҺi Ke46'=z}n i)?E_տ��<+/&*Jg\bu;yQ~t&S{wD W[G.ʶÜD��=o8,uCw?@*Ǧ>Lik)R~=_oܽuˢG�I-<͊2D(Uպ?e{CѸ61(d_Ts�(fK+m9{s&"e[\_i +jJfϯ~~sW`Rl-w\gՓ0n��b6'uղ5C/]xּ=ma_Mv%+lUv[XT;⃇>��>KIbxXbqN< Hn}?�� K(tUprn419o+Z z +�kFe,a[z;`hI&7I[tѺ S��_{()w[.iq"yqw|ZYDOa��|UH\Ȕ_=:ʹ&M5u[[ ֡*6ADû E^"^<\si`gZ/h[]L]+vͲty~?+1$_~76UD@K;`LNZ�]a}~o}hIg= ޮ~D?��m/()7Vm9F%\JvhD?��mOؚ0̡kO㺾FD?��mM ϖZ7%RbD?��mQ77'6f G??3UA.Ad +�Vy[|Z}=u$>:~5孳?La��ںqu-Pk\9m> <o]R7 2�AƼ}+7FCz^ ͕ws8 2�WyoJtFsbBxf2X#]6�@6ֿUV9춆N(cܭs-.oAd +� *1S-wx{i{&CՆ.ѵf 2�٬])muNu;{{j8ۮ1H�@vWTҋxf̌@;gnAd +�<6JY 6޼wU+w5kՏAd +�ОLOYޣX])m/v=Nƥ5fw 2�ho)sM5ַwP__Tm2 snAd +�uY8RI 0Ӆig{(ڧC ?4W)�@{69iIEEtEs͑\Z)�{>*PY`pM֮NI~?Ķ{nAd +�ה?%2+iMlʳ^8)}ݵ[Ad +�S]=\>2n +U租KK1K)��%JrA}y"vwtʳ^Gd��)еʼK5+Tȩ"/؃#��ٸ^~ U!2{uw!��枎$U (\]m ?La��p_eAڟ׵2=ʹ؎{+mu9)f 2�A-TO;檠WEwW}],+iݱ?La��hzWzy_3wX]u}��⫄^v̮^MxEеMCAd +�nY"!;1#P|Es{D?��x<(3 GwT-ӢmNQ{71)��Z;;W.mJj}<Dw[?=XQ=Ad +�ʪ %(mmW>;#P|Dž::=]?La��в +vL73E{j)=UD<Su3))��ZǴGtevKu`']fŃ1ikDg[b��=USsk[y>oevG"S��Ρ#.L,\|{6:~ ?La��d>1azѡk,Mtx 4z9f 2�?r~]fKTCǸ߬ 6)��?eifToxb 1naVL3)��xcKWQz>6i]O޿'3zXI 2�8}+I6Nƥ-ɹS:yo ��by[|MCPGb<ߝ;ucz#K#%䨖SSrY5==r/o��=CO$=2a>~ ꊬBvZ4CVrt6%Z9;��וi2$#A%V`wLjlk]}|s}Oc'c��^-ʼ}/8{7y hQ1X=&C;@bBQ-��1s<S]k{*OtWFkZ~DW/=xf.Sccҷ/w<"gr��s8%ξwV_)VR0K|gF"zaw mkWrl28}#|LOo��٩kmuevm?ޛ2~Eueq*HIqbPD5&3D' +F3j�idE[vYiEqq2Q3nP嗙im%=WrϻwTP53? Gd71aiQS5a[CDȪ*w \=>?Adb4'R^kooqgx|4Ư,O?=Pxu'MI֥R\i/ 2qx#1"w!xb/yqΗ$fi{GkǛox1۶S t佭ǎKd;w|f-ʎrck=algAWuovTwTqe[G#/ʎfJn[_tM: xme6Yq?=l7f[  ]Ɵ !}ɱ`4|<U{,154-(XrRsP$uk\FC  iVYdvW)Sqkjd|jXt?0c >]);1 \.5RA|Qա'oѫ?,`[W#cIMt?0k_6 NjNk?mvVAAۈD٣|5=[}}%|(n`8S8I\3#i+]w4oh?SӚkAS4Y]:Zտ0u'$5& +%(Y3K -ҭS?ѩ<iƶv=yz7Mys{ȦV֤g[=\YWb�=Aa>$5622Eza +ӽpp//-l͐*4X$ie?"VP2uNu;E^*zǏvi -5 QU8.-y౺;>5fjI)0uPVމm: .˓=N{|u62< [<Mc}pp8 ~CJD݃4Z9Os@Inr7zf%iiDN}?G]>_GIZ3y -7'e0wFs*恿]὇0oфI<WV�{n.K`! 27u Qc4AJv62^DL\:t1keȧy.NlKBySe~ 1okhbt;myoRwċ. T&Ț G9C|�?YϿ'Ċxg >?⠴Џ7.g?e5ۘ3#hCK:|ZK7dW<^`q}?IuoƤTilϋjΟk,b隓A{#1SM(s'1gufGz"cky'ԄgAڣIF3:0mݍ<^u/]Y`8S8�%euJy4kO_oAZȐ)A@ԶqNumL N5@r<}s5=MmVs^ zpgfpnk/?jLNy <۽A_N@?xDɾ~9S?HWb;Fn.K`bYnzMC֫R贍AyʒA8=ڻט%BVlU1&H`Xal8Ad|ZĪ{+n˾9c(Ic1 g?^fi!C5Srm.Oۘ@Rŝkl-OmrS[i&/މaE?3}`mc,۽ A@јɫs?f[@?t_?0)ƃup17u #3=6dςciM|6zKƶ +y=.;O(s/QSNuA#Q6耇)n8` +3H j> w|pZ: r[o噌}msߪQ,7lh?K uLz/CA& +h!o~N}W{ԓu]@L(R缽.gQ˒<)EQNvr銪} x U{/wѮ'oZלXJLM{[BXrsAkM?Y5s&ՃY"'i= A(pSk q0ٱD<a>LÙQ#8 tbOC/ּWԚ_Tzר1KBunkypFJГ?re-E->Ak隓=?z|&D!&ZXoqe@#%m?,^sŋ_AQW(𑌯FmMm1mcRc +$ZR0:$4 T +,yݻww 64&d:Ʀuқ^oJ$wsg߹﷫>+*ƴPGԄ Hj?Op[o 2B(7zO?_K[:wA! הptPh;]f?Yw^NZF( ۭ y8UͶǎ)$0zKnW{YtfkV*^��'ʯh`/3y|-XK UC 2:Ϟ Փ yvT/uT92?"\  ŏ?A,HY=6zM_zuz]j\aI>  Θ]bU twNJ٥C,8]R@AXW6߲1sNJۥB,/`A[ǸR + (eᓾD#|o`o~`H)  トL]U膿UWlk̢̗pgwy?0?Ay"27ƋG+_u/}4ؼ.  =DYa _PhVGm+_ /sy?0?$ds] WtSL^z;Nopi̝m}<|5}͈;`~OA`NeN_ӏ&^4شPgCJ#,4}>%.kLS%/Pub1\bsm4`p  0e!M[׏}6:4 gCJ/.0'Iԣ9wPdTeט5jA>0U׀yE.J|}|ӷ-F·RxXW6FS~VT,?X_>~ݽoA3 .駍7.d=\KSw9[R +OtS2i&=:wJm]/Duɢ:Ku!?ih:_SchTV]}\o˚k8Ɛqm:? lkqZʐײȪ>%-X 0A]f|['hjxs} y٢@O~o1?}Sט5j-^oo_<w+ /4X:pF̪d_׫u fbU$~\~%4_\ -wj.Zӓ7! ?b7ÒWl~m\u/%}3E!DzĤ#oש3VY&o:t u;Z +~vMƍHlm9D{W},h0sYxW}T͆"cK&ra?@Cه,1r`[qu� b7VۚgEFUf\yMah؞MDjs{+?WeѴ7�zߡ:�z饩{j2~šȫCAouLI v~Lc?*+yi+ywʕ07P۔;'^]i"oAy>ܵ(3xt2_{__J!?s<`H)<ЬdUYY Zzjd_B?iY͢bܴP n*įoMoNNvA.w;r%9>rMi�?h6Y:YnSW<Zf[9طɱ �99Prq\)ap{*3*ݹw%Ay~Ȗ;T毌ռ1k~O_}Xy՝D!4/sh]K9|rpV3#yC}ggEƖL7.`L˥j˃{i^d|³?fW>ϦjaO1?] 2gkyϺ?c 0 =evwpڪ TYu=JJ¬ .{0ɿCA?cf{r[{ +8[} )4_Zc,csg (M5_lt=q>~]dEDK9vC~@a]zn i`=n@a.Vf\UZ4)a<DB=Q5P\ثmo<s=XN*❼-^,2CAFiDݼ4[1f_l):ͺ9?R +O~�nY.y?@WXU[ȴk~7.�ݛgtsD^-y@I)^[z7GMg뼴s)6c:xO�_QfjU +v78V~nFrƖ4"'hj )wpn%S[u6 ֘94uQCD�b2QyPg_ RhTkk=;juaź].qzKC䨊(""rEBL慼!\ֳֵR=fgvfw3I_7gsOUQ?)`9:Y1A]q sH㊃Vr~T[<γשV&WtYs$b__9<^6 z_z;ll=���/;PسF^bB]@  K 8!{@GL"j\ڵ׳_kl?RC+LqgHI fIz0Mvl=Ig2a F.b#}=?-Zj>,zkW3<?z7g3ZL Cψ��> dԔnz {s9-W^nrMQޢaN@ +ņثU5i=cٖSwtoqBN /9&Ixgo|y?ATT bɯNi5i^hA{Tb[j|BJ㊃Dž|ޖ��@)Iiz=ͳW>@l''_5]1R?<#l .LJ`'oP?*Jӳ~ +:SmY-~jEm!EۆUuTSdݯ.z]$޶siLAsec=duW?яWW_qV$O29DuG:W}?/ZhjZTqYrEw���ajj(czW/#ʗ^MN,S?)SP]QK>0~2LbȩV$ {.���cp&;1$_/5m^4_ײd!@Gaz{uMIH{<O֠n.{FpQA{��� //c73QBH)`h<&tQu,Ϗ,����ggR +^5jk:X.+>Uw 'DJqf}%HR=����<3"IVb3B_sWqBH)����plzF-u3vĨۮ. DJ����UTr> +ݡ/hrm ʃR����ptmgyNqxy1b Y?R����/,̉r7oOkvӄH)����'Fm)?27^#?j:7Lf"?����TӼB.(3]]o Y/R����菼gxni e R +����髙<{TӋBi N"?����П]&f+⻅>y+ Y#W^{śIJ][V\eu;jS||wKN\:3����,er0ȗc-B@9ӦwJ#طwU{ccRe ����@Xَ7Խb/q5ӽZ.dm^psc ;8pc?4%E8yӝ8sg?5%#Ş3Hbeb;-/*d]DAQ˵OLe~Ņi*ݝ1}Á9b_$71\q(6?Y4Nlϰ_Fu?1b?fOΐh+>eE p>>8c�,}pχǧLNè:!kkxPgk [ۣ:/7S]v_;8g3~~Gar.7,WoRNJ?g z-_l�M0G,;kj <}&}pY1Am<k.&)p_o&,,3m:;jtǷG[u^nP`m^4;jwHI�p� p$*˗?]X;o?Is(˜(dTQj=C^a>Ybo?fOrh+>eEx) �����^2F-ז8 \U{r?_f�����:5^MIц&NuY&   8QQ޻"#r/4DgY08VӪ-Y5+.n}&/i  s nw,i;8ԉnnbLAAAAAAAAADyŅݖF:Ri;?)aaAQ +TPkDV 0 E%aee/HAqt-it)~͜g<<oSYBjg o[.4Ug3v%wQHdo1>}5%M! jΞYvGs韌mV%-lח'yR=^9g}fã%cy^^XZ[n4];/^oUZ"|֯X)LGc#җ1Yh/nazqxa4b` 1KYz uG6R1{Z$4w 399~r[{^6bD륊]&êӧ"rvss>%ΟjEׯ~$YYtZnJk'봵ض^.g-#{',k:kkQyDwc\̉mjwwA-g o]}/_Dwy{*;ͱ$ ?~L=[Ο3Wad]mms6LƮE[~q6rjm!^Z=&jS9+Zޜ~dɢx|fy9399~{ay]g2|-:n}M՚#!SgFdz W.瓯d:◯~tɶ{cqW~qc?bCdi!KdEOwtZm81W;cX'AJɬ}lєl39n/F_u➌]+͖'صnmǚh%-vhl8٢vPG__1- ub"cL&]6߶}qh21.k{v]EɁDYɿV&cPwx􃶢,[]GAz=s?}|g#%!Qd=6:]M7ZˢK;wm_/3G}PCƘLt=5U}LOg c㣘+[޹?S>^^'͢PM 62v CMqJ}ir9]WY<72v Ϣ<8m!y{_SZA..ɼs$xfdɤKע3۶/ S=*g cڞ};eEb tWD ΢=ޞCd욌uWrn57U{2v u犗w[;Un_m돔DeI&Cnj㩹˭➌1m7)ZҺxg d#( Pi?;Ғ}f#ǍoKmny=*qFY07]9s M?gx̘%) #VNMbhl8٢vʊ +C|IƘTʋ0pŹbN̞褑a<Vlۻ7!ޖ]h?o1>\:b2v=gzyeDL+=ʓ'}$W_<^2}wJ׀ 8笿oOWY<`1>dD[m~W뺩vcû{]Q{l=^cn]Kۣr@՗+U/Ũ}x +kSI-D^JOl .]m` RJ_c]uVI[z?7%U%jU`,MjBQoh|)FƘLeIbJymtTq�q6]eExOOϜR]ӌ}곹3w[>:}*B䪯ܛ}d{Y%$ڂG󇘻wڴfq)<iGƮrjQWkvx[L"I5w{^RP$řYؘꎶTeNMS]>urS1WÃC1&yGIP|緮7%ĭvz9e+x̡~C$y]uPSZ!ω#Xhkx_2ndZsX^az!ߊuv}T47۶n45{>N-V0BO3U<,M">,h]_2�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������@� + endstream endobj 28 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4144/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HRɖakL A<;ÿk6+D{E$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IxEBzH!]iHOD>NrCڇM}¦>Da_r|!u?Wθ){?!~u?W'?į}~t.߬L%Y[K|2%feJl-ʔZ⛕)7+SbkoV߬L%Y[K|2%feJlH|"%}hԼ풘hҼX]KK|2%feJl-ʔZ⛕)7+SbkoV߬L~s˕&>0y%1?oN|$6}hƼ(y%17]YC߬L%Y[_ O^?'^$Y[K|2%feJl-ʔZ⛕)YrZ;mӚbZ;گwz-5C^}hּ!2Z;]*=A*њ!FRkvKj>rhy%15C$}hԼ풘hҼX]K>KbiއvI,@IbhއvI .y%14C$vx $3C$v}hμؙ];;<m]3>KbfއvI&&y$2CDV}hD{DF}hȼmM"#;<٘M">Idcއ6l&L&y$21CD&}hD{D}h¼mYMB +;߂MB +;qXEws/>'*3zRQV?JO(~韞PWx-/}||ˇ>$};ow \BI 峞 |szo7*[旼i=oUoxK?^Msi"=d~+훡wLpַEod~!ۣ_>Q/|7,=N2 C?z`5z7/Nwzfy\7݌^YݏVpzNéBeʡ:\)޾Kp4z"{}P#sm·@Si>+4qe WPo2'|4xb=> <qUQp0O'sUGG'_=)+Ylp(t8g@cm={>yؚ}Fl=/ Vl] B̺̅ :<˾~H}T}LUW^Υ2hNOER%<[TM#C>A_}-! ZWއc_҃ +SѵԆ-\*`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`BRt-A_s~*9/y}}@?}F>`_wx_?^J J | /^̤R| /̤R,;LUWI*\O%R6%秒cЃ +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +҃ +Z҃ +҃ +˗{ _>D@_tx_uzI7 :އ\[Σr!,Vn*_T*ǿ~'T}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}SٹT ZjÖJz0U_?Iݯ:?KuJ:lל?ovR'9>Da Cއ(l_G;mA/V I~' jwTE0!!އ?d*ڰ?f)ʠ +:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0U~nU4-a~U2,auKC�\> ~U2,a~S4-AUT =O6nG_7c3 Knއgp! clyK]_ Ku۔Keuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]u̺nS.*eXRj]l{Cxc�;zC�omއh\_<oyA7k=z.Qk=z.Qp}�m;g* {Ͽdirއ$Iҷ!j-3gco13?| ,cZߧ_/<5L.ho5aW,s/]X^~dcj:?-ױaoF)0>F/54}չ}<.K}^\l|`9vu{!r!ߦ#O;scgXm?Ӂ/=3W3,yLJn/ Ͽ_yj՟ ~|95>~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I`�?l& endstream endobj 27 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4235/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrXCO+N1Ȼa̸} Tu~$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IWHOis-NC>w~%>~MÁH&V}V}V>C~q'gn7?'G;~q'c}Td1u݇t[boVĮ%ެL]KYx2%v-feJZʔصě)k7+SboVĮ%ެL]KYx2%vmK<Z>Jb܇VI@Hb܇VIl*MKYx2%v-feJZʔصě)k7+SboVĮsJ&dC$͉+Kb܇VI*{9xEI*ssʒZ]KYx2%vۻŗ?OGO7?wDOHx2%v-feJZʔصě)k7+SPO Yr-5bҵw5!BHtZ-kCm>J/-f_A]sb$uͿh}GъX5U>Jb܇VI*UIl*MsZ%iC$6}hĦmD$}hĢX4U>Jb6E{>Jb܇VI*=sZ%g"5sZ%fC$}hĚ-ÝhȖ-2E"[>Hd܇l@Fd܇,"%sZ$dsZ$cCDv}hȎ-ٱ́hȊ-Y1E"+>Hd܇@Fd܇l" sZ$a--Ұ65B +vjQ>دPO+,yh3"å#CGȧTݝ# 34d_S}$|8yyhzFf;NG^Z"#/ٍ ȬKAl%ȋA,5AWE BˬUKBleȋB,uBWą DFYw_4N`N7d~{| [v֣vfOrF2wu/hC.u ;t(7=u4Cw:ߞÚ^<+Rq%A5c_lM^|%<'(E?*WF,F.G?ۺ^cf/ z}cηVӀ~1p*/:f<7cs`JЯ:f@:ÎW3A?}>&뎙G} "2 Я<fL?1)z̜B[E})NJ>cQq }{e~7_SX'XEZGU/ݥ/q?T4?J7]ާzr{}1S}+IcNyk:r{}<}-OB/) u{|'46\2_1ȍTu\8}veOvt`q^Š?jw*7UvqݸTcmO@ħL@SpEOzNt`_=Q:]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTKѴm1SɰT!o7nC�#C�mC�mC�|9ϥTPM[/p)J#Ƨ ?ĤRI*`ڟI*\۟J:lٟJ:l@*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]\J*hp)?åt`y ~>D@>A$] M ߎt"+[ƣrt+ +?ӭ\T*0!Z!Z{Ё +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`Bq [cvi CWҁ +~^} +a~4Aw!?gqЗQ RT)dXVe떷]ԉW 7C^Y6ܼQ;8e>DaGqpOYVER,q ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0USg,i SUɰT)-s],IdXVuS4-AҺ*jgҲv;~{,^ܼCC}W8/uƺ*?gٔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]ueݲ) +anuS,)5.އ&'vO!�w}\yqrj>DnOk?=ècZO%0NygW=_4mwއ$Iҏ!jfΎbmg~;56`cY?Ƶ Oyj'{E ;d088kU2|>بz<u|W?)0xI1}ݹ}~>n ?\l{we|h˅|<>ߙ1>>}:q@̕vyLJn/ ϿyjG! ~|95>~4̒$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I#�.s endstream endobj 26 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 6 0 obj <</Intent 29 0 R/Name(Layer 1)/Type/OCG/Usage 30 0 R>> endobj 29 0 obj [/View/Design] endobj 30 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 13 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 12 0 obj <</LastModified(D:20170110154538Z)/Private 31 0 R>> endobj 31 0 obj <</AIMetaData 32 0 R/AIPDFPrivateData1 33 0 R/AIPDFPrivateData10 34 0 R/AIPDFPrivateData100 35 0 R/AIPDFPrivateData101 36 0 R/AIPDFPrivateData102 37 0 R/AIPDFPrivateData103 38 0 R/AIPDFPrivateData104 39 0 R/AIPDFPrivateData105 40 0 R/AIPDFPrivateData106 41 0 R/AIPDFPrivateData107 42 0 R/AIPDFPrivateData108 43 0 R/AIPDFPrivateData109 44 0 R/AIPDFPrivateData11 45 0 R/AIPDFPrivateData110 46 0 R/AIPDFPrivateData111 47 0 R/AIPDFPrivateData112 48 0 R/AIPDFPrivateData113 49 0 R/AIPDFPrivateData114 50 0 R/AIPDFPrivateData115 51 0 R/AIPDFPrivateData116 52 0 R/AIPDFPrivateData117 53 0 R/AIPDFPrivateData118 54 0 R/AIPDFPrivateData119 55 0 R/AIPDFPrivateData12 56 0 R/AIPDFPrivateData120 57 0 R/AIPDFPrivateData121 58 0 R/AIPDFPrivateData122 59 0 R/AIPDFPrivateData123 60 0 R/AIPDFPrivateData124 61 0 R/AIPDFPrivateData125 62 0 R/AIPDFPrivateData126 63 0 R/AIPDFPrivateData127 64 0 R/AIPDFPrivateData128 65 0 R/AIPDFPrivateData129 66 0 R/AIPDFPrivateData13 67 0 R/AIPDFPrivateData130 68 0 R/AIPDFPrivateData131 69 0 R/AIPDFPrivateData132 70 0 R/AIPDFPrivateData133 71 0 R/AIPDFPrivateData134 72 0 R/AIPDFPrivateData135 73 0 R/AIPDFPrivateData136 74 0 R/AIPDFPrivateData137 75 0 R/AIPDFPrivateData138 76 0 R/AIPDFPrivateData139 77 0 R/AIPDFPrivateData14 78 0 R/AIPDFPrivateData140 79 0 R/AIPDFPrivateData141 80 0 R/AIPDFPrivateData142 81 0 R/AIPDFPrivateData143 82 0 R/AIPDFPrivateData144 83 0 R/AIPDFPrivateData145 84 0 R/AIPDFPrivateData146 85 0 R/AIPDFPrivateData147 86 0 R/AIPDFPrivateData148 87 0 R/AIPDFPrivateData149 88 0 R/AIPDFPrivateData15 89 0 R/AIPDFPrivateData150 90 0 R/AIPDFPrivateData151 91 0 R/AIPDFPrivateData152 92 0 R/AIPDFPrivateData153 93 0 R/AIPDFPrivateData154 94 0 R/AIPDFPrivateData155 95 0 R/AIPDFPrivateData156 96 0 R/AIPDFPrivateData157 97 0 R/AIPDFPrivateData158 98 0 R/AIPDFPrivateData159 99 0 R/AIPDFPrivateData16 100 0 R/AIPDFPrivateData160 101 0 R/AIPDFPrivateData161 102 0 R/AIPDFPrivateData162 103 0 R/AIPDFPrivateData163 104 0 R/AIPDFPrivateData164 105 0 R/AIPDFPrivateData165 106 0 R/AIPDFPrivateData166 107 0 R/AIPDFPrivateData167 108 0 R/AIPDFPrivateData168 109 0 R/AIPDFPrivateData169 110 0 R/AIPDFPrivateData17 111 0 R/AIPDFPrivateData170 112 0 R/AIPDFPrivateData171 113 0 R/AIPDFPrivateData172 114 0 R/AIPDFPrivateData173 115 0 R/AIPDFPrivateData174 116 0 R/AIPDFPrivateData175 117 0 R/AIPDFPrivateData176 118 0 R/AIPDFPrivateData177 119 0 R/AIPDFPrivateData178 120 0 R/AIPDFPrivateData179 121 0 R/AIPDFPrivateData18 122 0 R/AIPDFPrivateData180 123 0 R/AIPDFPrivateData181 124 0 R/AIPDFPrivateData182 125 0 R/AIPDFPrivateData183 126 0 R/AIPDFPrivateData184 127 0 R/AIPDFPrivateData185 128 0 R/AIPDFPrivateData186 129 0 R/AIPDFPrivateData187 130 0 R/AIPDFPrivateData188 131 0 R/AIPDFPrivateData189 132 0 R/AIPDFPrivateData19 133 0 R/AIPDFPrivateData190 134 0 R/AIPDFPrivateData191 135 0 R/AIPDFPrivateData192 136 0 R/AIPDFPrivateData193 137 0 R/AIPDFPrivateData194 138 0 R/AIPDFPrivateData195 139 0 R/AIPDFPrivateData196 140 0 R/AIPDFPrivateData197 141 0 R/AIPDFPrivateData198 142 0 R/AIPDFPrivateData199 143 0 R/AIPDFPrivateData2 144 0 R/AIPDFPrivateData20 145 0 R/AIPDFPrivateData200 146 0 R/AIPDFPrivateData201 147 0 R/AIPDFPrivateData202 148 0 R/AIPDFPrivateData203 149 0 R/AIPDFPrivateData204 150 0 R/AIPDFPrivateData205 151 0 R/AIPDFPrivateData206 152 0 R/AIPDFPrivateData207 153 0 R/AIPDFPrivateData208 154 0 R/AIPDFPrivateData209 155 0 R/AIPDFPrivateData21 156 0 R/AIPDFPrivateData210 157 0 R/AIPDFPrivateData211 158 0 R/AIPDFPrivateData212 159 0 R/AIPDFPrivateData213 160 0 R/AIPDFPrivateData214 161 0 R/AIPDFPrivateData215 162 0 R/AIPDFPrivateData216 163 0 R/AIPDFPrivateData217 164 0 R/AIPDFPrivateData218 165 0 R/AIPDFPrivateData219 166 0 R/AIPDFPrivateData22 167 0 R/AIPDFPrivateData220 168 0 R/AIPDFPrivateData221 169 0 R/AIPDFPrivateData222 170 0 R/AIPDFPrivateData223 171 0 R/AIPDFPrivateData224 172 0 R/AIPDFPrivateData225 173 0 R/AIPDFPrivateData226 174 0 R/AIPDFPrivateData227 175 0 R/AIPDFPrivateData228 176 0 R/AIPDFPrivateData229 177 0 R/AIPDFPrivateData23 178 0 R/AIPDFPrivateData230 179 0 R/AIPDFPrivateData231 180 0 R/AIPDFPrivateData24 181 0 R/AIPDFPrivateData25 182 0 R/AIPDFPrivateData26 183 0 R/AIPDFPrivateData27 184 0 R/AIPDFPrivateData28 185 0 R/AIPDFPrivateData29 186 0 R/AIPDFPrivateData3 187 0 R/AIPDFPrivateData30 188 0 R/AIPDFPrivateData31 189 0 R/AIPDFPrivateData32 190 0 R/AIPDFPrivateData33 191 0 R/AIPDFPrivateData34 192 0 R/AIPDFPrivateData35 193 0 R/AIPDFPrivateData36 194 0 R/AIPDFPrivateData37 195 0 R/AIPDFPrivateData38 196 0 R/AIPDFPrivateData39 197 0 R/AIPDFPrivateData4 198 0 R/AIPDFPrivateData40 199 0 R/AIPDFPrivateData41 200 0 R/AIPDFPrivateData42 201 0 R/AIPDFPrivateData43 202 0 R/AIPDFPrivateData44 203 0 R/AIPDFPrivateData45 204 0 R/AIPDFPrivateData46 205 0 R/AIPDFPrivateData47 206 0 R/AIPDFPrivateData48 207 0 R/AIPDFPrivateData49 208 0 R/AIPDFPrivateData5 209 0 R/AIPDFPrivateData50 210 0 R/AIPDFPrivateData51 211 0 R/AIPDFPrivateData52 212 0 R/AIPDFPrivateData53 213 0 R/AIPDFPrivateData54 214 0 R/AIPDFPrivateData55 215 0 R/AIPDFPrivateData56 216 0 R/AIPDFPrivateData57 217 0 R/AIPDFPrivateData58 218 0 R/AIPDFPrivateData59 219 0 R/AIPDFPrivateData6 220 0 R/AIPDFPrivateData60 221 0 R/AIPDFPrivateData61 222 0 R/AIPDFPrivateData62 223 0 R/AIPDFPrivateData63 224 0 R/AIPDFPrivateData64 225 0 R/AIPDFPrivateData65 226 0 R/AIPDFPrivateData66 227 0 R/AIPDFPrivateData67 228 0 R/AIPDFPrivateData68 229 0 R/AIPDFPrivateData69 230 0 R/AIPDFPrivateData7 231 0 R/AIPDFPrivateData70 232 0 R/AIPDFPrivateData71 233 0 R/AIPDFPrivateData72 234 0 R/AIPDFPrivateData73 235 0 R/AIPDFPrivateData74 236 0 R/AIPDFPrivateData75 237 0 R/AIPDFPrivateData76 238 0 R/AIPDFPrivateData77 239 0 R/AIPDFPrivateData78 240 0 R/AIPDFPrivateData79 241 0 R/AIPDFPrivateData8 242 0 R/AIPDFPrivateData80 243 0 R/AIPDFPrivateData81 244 0 R/AIPDFPrivateData82 245 0 R/AIPDFPrivateData83 246 0 R/AIPDFPrivateData84 247 0 R/AIPDFPrivateData85 248 0 R/AIPDFPrivateData86 249 0 R/AIPDFPrivateData87 250 0 R/AIPDFPrivateData88 251 0 R/AIPDFPrivateData89 252 0 R/AIPDFPrivateData9 253 0 R/AIPDFPrivateData90 254 0 R/AIPDFPrivateData91 255 0 R/AIPDFPrivateData92 256 0 R/AIPDFPrivateData93 257 0 R/AIPDFPrivateData94 258 0 R/AIPDFPrivateData95 259 0 R/AIPDFPrivateData96 260 0 R/AIPDFPrivateData97 261 0 R/AIPDFPrivateData98 262 0 R/AIPDFPrivateData99 263 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 32 0 obj <</Length 1017>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC4.pdf) %%CreationDate: 10/01/2017 15:45 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -792.8979 134.7134 1.68 2452 1484 18 0 0 183 218 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 33 0 obj <</Length 12448>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 12296 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD28FFA8FD %56FF7DFD27FFA8A8FD56FFA8A8FD27FFA8FD56FF7DFD27FFA8A8FD56FF7D %A8FD27FFA8FD56FF7DCAFD24FFCAFFA8A8FD08FFA8FFA87DA8FFA8A8AFFD %45FFA8A1FD22FFA87E84597EA8FF59FD06A87D7D7D527D5227525252A8FD %43FF7D7D7E7E7DFD1BFFA8FF7E7E535A5A5A53A8FFAFA8FFA8FFA8FFA8A8 %7DA8A8A87DA87DA8A8FD43FFA8A1A2A1A17DA8FD16FFAFA87E7E5A5A5A7F %5A7E5A7EA8FD56FF7DA1A1C3A1C976A8FD10FFA8FF7E84535A54FD095A53 %A8FD56FFA8A1CAA1CAA1CA7DA8FD0DFFA8847EFD055A7E5A7E5A7E5A7E5A %7E5A5AA8FD55FFA876A1A1C9A1A1A1C376A8FD08FF7E84595A535A5A5A54 %5A5A5A545A5A5A545A5A5A545A53A8FD56FFA8A1CAA1CAA1CAA1CA77FD05 %FFA87E5A7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7EA8FD56 %FF7DA1A1CAA1A1A1CAA1A176847E7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E59A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1 %C9775A5A7E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7EFD045A %A8FD55FFA87DFD04A1C9A1A1A1C9A1A1535A595A545A5A5A545A5A5A545A %5A5A545A5A5A545A5A5A545A5A5A2FA8FD0CFFA8FD49FFA8A1CAA1CAA1CA %A1CAA1CAA1CA7DA87DA87E7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5A59A8FD56FF7DFD04A1CAA1A1A1CAA1A1A1A77DC3A1C9A17D53FD13 %5A53A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1 %A15A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A597DFD54FFA9FF7DA1A1 %C9A1A1A1C9A1A1A1C9A1A176CAA1C3A1C9A1A1535A5A5A545A5A5A545A5A %5A545A5A5A545A53A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1 %7DA1A2A1CAA1CAA1CA7D5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7DA1FD0F %FFA8FFAFFFA8FFFFA8A8A87D527DA87D7D7DA8A8FD34FF7DA1A1CAA1A1A1 %CAA1A1A1CAA1A1767D777D76FD04A1CA7D59FD0E5A53A8FD0CFFA8FFA87D %7DA87EA87DA8FD047D527D7D52277D527DFD34FFA8A1CAA1CAA1CAA1CAA1 %CAA1CAA1A1A1CAA1C97DA1A1CAA1CAA17D5A7E5A7E5A7E5A7E537E5A7E5A %7D7DA9A8FD07FFA8FD0FFFA8FD3AFFA87D52FD04A1C9A1A1A1C9FD04A176 %C3A1C9A1A176FD04A1C9A17D535A5A5A535A5A5A545A5A5A53FD045A7E5A %5A535A535953597DFD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CA %A1CA7DA1A1CAA1CAA17D5A7E5A7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F %5A7E5A7F5A84FD49FF7DFD04A1CAA1A1A1CAFD04A176C9A1CAA1A1A1CA77 %7D7D7E5A5A54FD195A7EFD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CA %A1CAA1CAA1CA535A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A84FD47FFA8A87DA17DA17DA176FD04A1C9A1A176CAA1A1 %A1C9A1A1A1C377FD055A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A %545A5A5A59FD49FFA8FD06A17DA1A1CAA1CAA1A1A1CAA1CAA1CAA1CAA1CA %7D7E5A7E5A855A7F5A855A7E5A855A7E5A855A7E5A855A7E5A855A7F5A84 %FD49FF7DA1A17D76A17DA17DA176A1A1A176CAA1A1A1CAA1A1A1CAA1A153 %5A597E5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A53FD0F %FFA8FD39FFA7A1C3FD09A1CAA1A1A1CAA1CAA1CAA1CAA1CAA1CAA1A27DCA %A17D5A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DFD0EFFA8FD38 %FFA8A87DA8A8CAA7CAA8A87DCAA8CAA7A876C3A1C9A1A1A1C9A1A1A1C9A1 %C3A1A8A1C3A17D54FD055A545A5A5A545A5A5A54FD055A53FD0FFFA8FD46 %FFAFA1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A2595A5A7E5A7F5A %7E5A7F5A7E5A7F5A7E5A7F5A7DFD0EFFA8FD47FFA876C3A1CAA1A1A1CAA1 %A1A1CAA1C37D7DA1A1A1CAA1A153FD115A7DFD56FFA8A1A1CAA1CAA1CAA1 %CAA1CAA1CAA1A176CAA1CAA1CAA1C97D5A5A7E5A7E5A7E5A7E5A7E5A7E5A %7E537DFD0EFFA8FD48FF76C9A1A1A1C9A1A1A1C9A1A1A1C9A17DA1C9A1C3 %A1C9A1C3A17E305A545A5A5A545A5A5A545A5A5A7DFD0FFFA8FD46FFA1A1 %A1CAA1CAA1CAA1CAA1CAA1CAA1CA767E7D7EA1CA7DA2A1CAA17D597F5A7E %5A7F5A7E5A7F5A7E5AA8FD0EFFA8FD46FFA8A876CAA1A1A1CAA1A1A1CAA1 %A1A1CAA1A1A1A2A1A1535A5A5A545A7D7E537EFD0A5A7DFD0FFFA8FFFFFF %A8FFFFFFA8FFA8A8A8FF7D7EA8FFFFA8A8FD33FFA1A1CAA1CAA1CAA1CAA1 %CAA1CAA1A77DCAA1CAA1A159FD065A7E5A7E5A7E5A7E5A7E5A7E5ACAFD0E %FFA8FFFFFFA87D7DA8A8A87EA852FD047DA8FD045228A8FD31FF76C3A1C9 %A1A1A1C9A1A1A1C9FD07A1C9A1A1535A5A5A545A5A5A54FD075A535A7DA8 %A8FFAFFFA8FFAFFFA8FFA9FFA8FFA8FFFFFFA8FD05FFA8A87DFD05A87DA8 %7D7DA8FD30FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1A17DCAA1CAA1CAA1C9 %7D5A5A7F5A7E5A7F5A7E5A7F5A7E5A7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7E7EFD48FF7DA1767DA17D7D7DA1C3A1CAFD07A1CAFD04A153FD1D5A54 %84FD47FFA8A1A1A17DCAA1C9FD05A1CAA1A17DCAA1CAA1CAA1CAA1A1595A %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A7DFD %48FF76CAA17676A1A1A176A176A1A1C9A1A1A1C9A1A1A1C9FD04A1535A54 %5A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A537DFD47FF %A8A1A1CAA1CAA1CAA1CAA1CAA1CAA1A17DCAA1CAA1CAA1CAA1CAA1A1535B %5A5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A7DFD48FF %A8FFFFFFCAFFFFCAA8FFFFFFA8FFA8A1A1CAA1A1A1CAA1A1A1CAA1A17D7E %7D7D7D7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7DFD10FFA8 %FD46FF7DCAA1CAA1CAA1CAA1CAA1CAA1C9A1CAA1A1A17E5A5A5A7E5A5A5A %7E5A5A5A7E5A5A5A7EFD045A7DFD56FFA8FD04A1C9A1A1A1C9A1A1A1C9FD %04A17DC3A17E5A5A545A5A5A545A5A5A545A5A5A545A5A5A537DFD10FFA8 %FD46FF7DCAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A2537F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7E7DFD56FFA8FD04A1CAA1A1A1CAA1A1A1CA %FD04A17DC3A1CAA1A153FD0F5A537DFD10FFA8FD46FF7DCAA1CAA1CAA1CA %A1CAA1CAA1CAA1CAA17DA1C9A1CAA1C9777E5A7E5A7E5A7E5A7E5A7E5A7E %5A5A7DFD56FFA8A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1525959A1A1C9 %A1C3775A5A5A545A5A5A545A5A5A545A53A1FD10FFA8FD44FFA8A87DCAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA17D5A5A5A7EA1CAA1CAA17E5A7F5A7E5A %7F5A7E5A7F5A7EA1FD56FFA8A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A176 %A27D7E535A5A7D7D7E7D7D537EFD095AA8FD10FFA8FD46FF7DCAA1CAA1CA %A1CAA1CAA1CAA1CAA1CAA1A1A1CAA1C97DFD045A7E5A5A5A7E5A5A5A7E5A %7E5A7EA8FD56FFA8FD04A1C9A1C3A1C9A1A1A1C9FD04A176C3A1C9A1A177 %5A5A5A545A5A5A535A535A5A5A535A53A8CFFD0FFFA8FD44FFAFFFFD06A1 %7DA1A1CAA1CAA1CAA1CAA1A1A1CAA1CAA1CA7D5A5A7F5A7E5A7F5A7E5A7F %5A7E5A7E59A884A8A8FD09FFA8FD48FFA8A1A1A17CCA76A1A1CAA1C3A1CA %FD04A176C9A1CAA1A1A1C97DFD115A53FD045A7E5A5A535A5359535A7DFD %46FF7DCAA17D76A1A1A176A176C9A1CAA1CAA1A1A1CAA1CAA1CAA1CA7D5A %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A5A7E5A5A5A7E5A7E5A84 %FD43FFA8FFA87DA1A176FD05A1A0FD07A176CAA1A1A1C9A1A1A1C377FD05 %5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A59FD46FFA1 %CAA8CAA8CAA8CAA8CAA8CAA8CAA8CAA1A1A1CAA1CAA1CAA1CAA1CA7D5A5A %7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EFD4DFF %A8FD07FFAFA876CAA1A1A1CAA1A1A1CAA1A153FD045A7E5A7E5A7E5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A5A59FD57FFA1A1CAA1CAA1CAA1CAA1CA %A1CAA1CAA1A7A17D5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7F5A7D %FD10FFA8FD46FF76C3A1C9A1A1A1C9A1A1A1C9A1C3A1C97DA1A17D535A54 %5A5A5A545A5A5A545A5A5A545A5A5A545A53FD0FFFA8FD46FFA8A1A1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1A8A1CAA1A2595A5A7E5A7F5A7E5A7F5A7E5A %7F5A7E5A7F5A7DFD10FFA8FD45FFA876C3A1CAA1A1A1CAA1A1A1CAA1A1A1 %CAA1A1A1CAA1A153FD115A7DFD3DFFA9A8FFA8A87DA8FFFFA8FD0FFFA8A1 %A1CAA1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1C97D5A5A7E5A7E5A7E %5A7E5A7E5A7E5A7E537DFD10FFA8FD2CFF5252A87D5227527E2753275952 %A87DA87DA87D7D7DFD05FF76C9A1A1A1C9A1A1A1C9A1A1A1C9A1C376FD04 %A1C9A1C37D7E305A545A5A5A545A5A5A545A5A5A7DFD0FFFA8FD2DFFA87D %FFA8A87DFD07A8FD0CFFA1A1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CA %A1CAA1CAA1CAA17D5A7F5A7E5A7F5A7E5A7F5A7E5AA8FD10FFA8FD44FFA8 %A876CAA1A1A1CAA1A1A1CAA1A1A1CAA1C9767D7D7D77A1A1C3A1CAA1A153 %FD0B5A7DFD0FFFA8FD47FFA1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1A8 %A1A176A2A1A8A1CAA1A1597E5A7E5A7E5A7E5A7E5AA8FD10FFA8FD46FF76 %C3A1C9A1A1A1C9A1A1A1C9A1A1A1CA76A1A1C9A1C377FD045A7E5A5A537E %53FD055A547E7DFD56FFA8A1A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CA %A1CAA1CA7D5A5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A5A7EA984A87EAFA9FD %09FFA8FD46FF7DA1767DA176767DA1C3A1CAA1A1A1A876A1A1CAA1A1A1C9 %7DFD0E5A7E5A5A545A545A547E5A5A5A7E5A5A5A7E5AA9FD45FFA8A1A1A1 %7DCAFD07A1CAA1CAA1A1A1CAA1CAA1CAA1CA7D5A5A7E5A5A5A7E5A5A5A7E %5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7E5A5A5A7EA8FD46FF76CAA17676A1 %A1A176A176A1A1C9A1C376FD04A1C9FD04A1535A547E5A7E5A7E5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E53A9FD45FFA8A1A1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1A1A1CAA1CAA1CAA1CAA1CA7D7E5A7E5A7F5A7E5A %7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7EA8FD46FFA8FFFFFFCA %FFFFCAA8FFFFFFA8FFFFFF7CFD04A1CAA1A1A1CAA1C3535A53FD195A53A8 %FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1C97DA87E7E7D7E5A5A5A7E %5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A59A8FD56FF7DA1A1C9A1A1A1C9 %A1A1A1C9A1A1A1C3A1C3A17D535A545A5A5A545A5A5A545A5A5A545A5A5A %545A53A8FD0CFFA8FD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CA %A1A15A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7DA8FD56FF7DA1A1CA %A1A1A1CAA1A1A1CAA1A176CAA1A1A1CAA1A153FD115A53A8FD0CFFA8FD49 %FFA8A1CAA1CAA1CAA1CAA1CAA1CAA17DA1CAA1CAA1CAA1C37D5A5A7E5A7E %5A7E5A7E5A7E5A7E5A7E5A7DA8FD3CFFA87D7DA87D7D277DA87D527D7DA8 %FFFFA8FFA8FFA8FD05FF7DFD04A1C9A1A1A1C9FD04A1767D777D7DA1A1C9 %A1C3767E5A5A545A5A5A545A5A5A545A5A5A53CAFD0CFFA8FD30FF527D7D %A853527D7DFD04527DFFFD05A87E7DFD04FFA8A1CAA1CAA1CAA1CAA1CAA1 %CAA1A1A1A8A1A17DCAA1CAA1CAA17D5A7F5A7E5A7F5A7E5A7F5A7E5A7EA8 %FD0BFFAFFD32FFA8FD07FFA8FD0EFFA876FD04A1CAA1A1A1CAFD04A176C9 %A1CAA1A176CAA1A1A1CAA1A153FD045A7E5A5A537E535A597E537E59847E %7E53FD055A7EFD49FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CAA1A1 %7DCAA1CAA1CAA1A1537E5A7E537E5A7E5A7E5A5A5A7EFD075A7E5A5A5AA8 %FD49FF7DA1A1C9A1A1A1C9A1A1A1C9A1A176CAA1A1A1C9A1A1537E7D7E53 %5A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A545A5A5A7EFD49 %FFA8A1CAA1CAA1CAA1CAA1CAA1CAA1A1A1CAA1CAA1CAA1A85A5A5A7F5A7E %5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5A7F5A7E5AA9FD47FFA8 %FF7DFD05A176A1A1C3A1CAA1A176CAA1A1A1CAFD04A153FD1D5A7DFD49FF %A8A1A1A1A8A1A176CAA1CAA1CAA1A1A1CAA1CAA1CAA1CAA1A1595A5A7E5A %7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A7EFD49FF7DA1 %A17D76A17DA176A176A1A1A176C3A1C9A1A1A1C9FD04A1535A54FD075A54 %5A5A5A545A5A5A545A5A5A54FD055A53FD49FFA8A1C9FD09A1CAA1A1A1CA %A1CAA1CAA1CAA1CAA1A27DA87EA27D7E5A7E5A7F5A7E5A7F5A7E5A7F5A7E %5A7F5A7E5A7F5A7DFD49FFA1A8A8CAA8CAA8CAA1CAA8CAA8A87CC3A1CAA1 %A1A1CAA1A1A1CAA1C3A1C9A1A1A17EFD145A7DFD57FFA1A1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA17E5A5A5A7E5A7E5A7E5A7E5A7E5A7E5A7E5A %7E537DFD56FFA876CAA1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1C3A1A153 %FD055A545A5A5A545A5A5A545A5A5A77FD56FFA8A1A1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1A1595A5A7E5A7F5A7E5A7F5A7E5A7F5A7E59 %7DFD57FF76CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A153FD %0F5A7DFD40FFA8FFA8A87DA8A8FFA8FD0DFFA8A1A1CAA1CAA1CAA1CAA1CA %A1CAA1CAA1CAA1CAA1CAA1CAA1CA7D7E5A7E5A7E5A7E5A7E5A7E5A7E5AA1 %FD3FFFFD047D5227FD0452277D52FFA8A87DA87DA852A8A8A176C3A1C9A1 %A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1C3A17D5A5A545A5A5A54 %5A5A5A545A7DFD40FFFD04A87DA87DFF7DA8A8A8FD0AFFA8A1A1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA17D5A7F5A7E5A7F5A %7E5A7F5AA8FD57FF7DC3A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1 %A1CAA1A1A1CAA1A153FD085A7EA1FD56FFA8A1A1CAA1CAA1CAA1CAA1CAA1 %CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1A1595A5A7E5A7E5A5A5AA8FD %55FFA8A876A1A17DA1A17DA1A1C9A1A1A1C9A1A1A1C9A1A1A1C9A1A1A1C9 %A1A1A1C9A1A17D5A5A5A545A5A5AA1FD57FFFD04A1CAA1A176CAA1CAA1CA %A1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA1CAA17E5A7F5A7E5ACAFD57 %FF76CAA17676A1A1A176A176A1A1CAA1A1A1CAA1A1A1CAA1A1A1CAA1A1A1 %CAA1A1A1CAA17E547E5A5AA1FD56FFA8A1A1C3A1A1A1C3FD05A1C3A1CAA1 %C3A1CAA1C3A1CAA1C3A1CAA1C3A1CAA1C3A1CAA17D535A5AA8FD55FFA8A8 %A1CAA7CAA8CAA7A8A7CAA7CAA8CAA7A8A1CAA1CAA8CAA7A8A7CAA1CAA8CA %A7A8A1CAA1CAA17E7E7EA8FDFCFFFDFCFFFD0CFFFF %%EndData endstream endobj 34 0 obj <</Filter[/FlateDecode]/Length 14260>>stream +HWmoHG5^UM HsVт76I?~gok0 9& +س<;> ~F^רo]Ʒmר}c}LT<$r0!!zhv=;OFv +y}F�0vj C)Ktk[o7 ,W)Q_Ft`6>>?]0jڸf_ y)q-aNb|0x9 C,Yf䲤(5ְG}:N<VI6 u36oA m=c8V0V E8Nèy9RAsEL1MNeyQbEhnB,kP˙)(]a |gƛDZXd(aV7<7?qt6. W 0IK>UsUU{*JpU]$K7̇ӗ.Ҫ$4U5SKEkZMkӚ5d j'6,[fؔgkX5Uk^ymO׼-DfcY("aԺfͨmw|H̚v|*X^5jZ{DZ;IL9R,qE=y$$;FpM)rMdG3D9A[L\0v" +d Tm]UxdKL&@Ǎ@%NMx;jʨ9`(<[İO;5h䕡\[ǟϤz&=t9S9{HY dm�;xJwdʲ59APfZy𒷲^EK7 I{PX{`{w=TV$e= gnӪ@v'Qӻ.&CDWR۝> !g^3b-<w&kxa? RAπՕVg{eڣ/'IW`ryC8q)b$.Q}w'0ݢy(1 }2^TO/MkwԽPSZSƬ#X4 -CUa ]m]D>~7/ |mOWn4C>XꞴZmwƬp;`U ØяmrwmK;pM63eC9T! 7nׂ֙ ~G1{RU?  MN0ss?^0w+ +i$*HbΆ!^%cpCդC: )]2(s&TS{\?eyIcZ=xV\ZgOZ<!YЧa֛d\+ٰ|[RY"f!ѺȨ/,e8%NpSr. LFv; 9஻DKk+MnkHL=s2.Ks-q43ߌ #o:Cgb(O4=uhAQvjIW,o1I?8d/sN}?vd> rSI6v:ё |~7΃}j1Ϯ~ ;" j#B&)\(˩ÐF%O +5~dMYf]gFY]tGPI4߅/9: ?-8MsllsLg=Q;o'H,Ў ۑCLA/o8X`#t˜1$d'/_&.l1VG\3k~(O?Wv:Ʋ i5uc*1v=hR!Nof1P'^ܕHd44_^@&ԇ c/ٽ|81,=u� :>(PV +(++|3[UĨʂ */(<m BJIѫ1f d f#4Gf>]m�l}.SKk?M_8.Yr&Y<6Lc]ٌ[Up9_.Rѓ/^l QY>3˕5 qU/C-x.r^M] +lJ)lZzla!5%NXilmSo^2dчz4+0`wds{45]`<f&XjnU7[= * +Yd.d6v3s To Dq +B\BZۡ;e +9\2NP̝W*l̪4&GĻWq6ߓ'Ҽ+Є-Hr?$<odɲᣭ2e¬2`UY Va[Eez SXaxJ&/E켺;ʼnA˷T +z(bDeKEpVߺeU\E|i) QqSݼjˢyRd}XGCO X@ Bcw!Gb 7Πin-(JT0v6 +<_r֝߷^ +".Fm͈Nmpb''iZkhZHMROZ֫m_8:$}{/AOdȧWGD=ԛW܋0^F?gaѿm +~WZ +D@$ak<{%gף?~O|zP�̶Q(D CF@�RI[Rr9 xOh'7ѽTpsr3N8 + 6hr,|qb}<AC@ѹz(:CN=0c1\+"?!'K\.gÌ_M`& Cj%{y;sbvFd+Z8<*Ƨ +Qǃ  ,9Wyz4= T?uݒC٬[k�:<T?O:?78[h-竒23"Uw+*C6ƳĤ9)f ,UVxt3k�tfOuOԵ>CsA|_o>W+3{ܳ�>, +F)S)L 8סYŠ +dDazAZ{ ?kANW Zގ2_.)JT +nď +x@^( g6 Tm. |n}&oȵ%պ}ɺhpukyT|'h +&Z6Hћ tK:>r诠Q_P_Z:e&lY2z�h2{ 2JV,z|1OƜ OG/a3qlԭ[ZpwU<k[HxGIw^'AZ#gLS a\<θ@rsƣ`TV~_pR"[ZO&I6_6ʬDTr;HIu%plJKi.! +:q #&R+H}D "�W8ib4 HGU*T?d04q@u3Œ'tCuc7aJ}~� k3GpΤdQgqAdD"BQ헄KU;)T},N#X+ 0�J#UcQ"W&|\jL8MC.r6(mk59kƹXW%v$5;Bs'n! ;2-:1d0 țGUp=V=˴_Cc@U3B!TR_+PS1c6Hj}ɡ u'=a vP=k=4P kfx|xM#k Mߘt83vNR}WhgNf:q~2{.s3!:\c̃mx-i=jg_7Tr|̹}<{J}WT*87NJ&>x$0[oӧvD:kuؼּ=.|⟶itݦC]1nG75z+O'rVH}43ks< +F{SZ~:zBRChl*DAD:Kޖg-z*L•9KE#C0 <DE!6[<ӰKH߆dCؠBFj.::'tZry۞V4-me| >{82L/$} +& 6: +FՁFf1ch*{]qѥ~"pT-z1ROGx�SɞUo y�dimk@~UC_5$`|IhF)VqފRURed%[RLPD +�3푫]UH$"T!e;W $M� icr{Z[7(CSo+tpNȉ=à-=57A.EWsYle-eBfRӟ<I佹<O;@>OUO|X$.".oq0t̬KZTxeYjkN q˅LX<Hz Pc3EjR@aooE_ؤKFUCsy hO$m Ca)ɢA;.6ؗnc}eWi&/OJr 㣏 +.ˍ74'f(fa7 #hNh6n d#$�2r0lC4,}:u0Y.tѬ&U-bWEULp#:-Үuh)ctκuuCpb4hU&z=,x˩cd zF=׉}avKoiEVWqLZ1GKzp>oim|yA4`Bc]=&'0Hƽl!W[_|ah 3$^11^pRܛ]$K>df-dltD4_tm, +g +{7h.`2?8CGhh'̒f`YL^ۉjK JISkhD0t>O %Ʃڋ]s +銦!x+mVQǭ:AZmtw-f/۰ v$$~fGU]yP.ee4L)dV0}YLzڵ+eA 72?}r&8*3Q9ݛ)OUKˁMUGNh3GA +.eﭝ@)OD25ˤUEp� OeNvֆҵ/9~o$2<M2ց@ԅxdmt۷�p#T Z0&) Ď-esk:}@Q+g[\Girzo;x 81uFoX uY w8J;m['L>̙MUQ9K Æ=# �XXՕO_" 33`N]pwlvsl'ƍ]O pN '`VI +t1%Y/H7AD1_Q gؿIAhCG G$| +ZmծÏEQeVvTmΰ!K`4h{5,^ͫ*h3e+զ@,Nnb) ?݁h^w_덠ci|>ם?MXq5Ay8{Ϸrg/ \ׄ滿r^׎kOGt :|i9,t83ܰ+3Şd& +'/OȆvn: y;_=鋁Cibv:;ƹ1�._/*϶RG5{) SNUAЏCΥX2ΫVyǃ3 'v{37zVml4qN..k|ڶQ >W'\;aSHM - +٢T#pg_fJ݆Z1++)?S.ke4e.n\e@xR3$tryLe2d`," +jaӉ Qh\QͤfO ψ]Z~(L<}S^Aư<6 cQr6 5% X,Pexpdd+,7Od+|y#Bhb#aztŎ1ӷF-K~JI&-aԗpC j|x)<p>{WdBϯn,6pu#(_"(d6R?c,-Z7~- x['-O9Lp._{MR8?- }_t{o,$j +]S<S36,,bۤM5"H-$*;ReEVQ/I[TP1{S2O"֥[$8<^C֒/)E09qh'|Pt<v_U(ݗ$Z,i4{X<a`עZm x<tl"1'082avΓ=f2Dq+*;y~ʵ/d̴+oEʼ>`°BTl|Al0]g,=IA�c V}sU'[:\ u76^ڇZ -Oסb# +=W3D//' /EPc$ٟĭSg(J\}?^")ID |ǩ֨S18ldZI7L__!_Ñ:9kZveg +U[ +%QBZIe+9h?._dS)Ǣܾbs x]֡U^)<r:d+leeiX.[+~ʖ;Z}p~Q$ 57T*ٓ^@DQG ŰٙJa`{ QY!hyLÏYV\,_=-K^l34 .Dvz|D6вWkIZD4+ۇ%>N%'V99v[䈉<~Q)k9"͑c@2 +4BTjh}]:ĀccE|>f>xE+Vɚ9"Ȫ JSj98GfZܚN׹˳r\a tK&\-l"Gˊ3~Q[$8G +`kqt$F]S]Z㕣 ] |2*kf |F?;E0ÓNn# Z&jj6;ihI_V`kԙy:64; C)_mr"kHڒN_/ro!ߔD@uh>`0dwc2qK)ftmR5lb6xkn5&"{ӯ/j=WU_Lk!g \7-_zh FoC`W˘7FJ_Z@( =RL]܉k/ bv+8)w#D}v`.Z +ia9:UfKg9c&g@= 2:c=-F]n[^=X<xnNS`* >{h!Q!q7+>3o3ސϤT{p+Ĕ +W IIHSm)U:=f+r}wS71RBP +m_{cZ4P3jrl ~U`5VMO|%]�55a ɬE4اɢϯciegbmdVݩD4IȲ*5x]H|vX@{Հ` ~y/كuJQdlHI e*큯cpVH!e M }mlr`I[~n"U9ro#v<`'J2LL*86Q]+CjבجT`kUºۊk*cAg6rwuZ%J=KӋg+_|=8iي$ʝ Id8Bɶt`slAolyAPɢ~Ќ+Fb>Y 9ǼW7S]ǘe" өhGwjgbi`Qk ," +wj o7D2NmüL^CP"e_p^,RE35Z!f!Dٚ6{,WT+`RǺ Sz?9?RV^vee[~0j+ +=.XL #OjU m4=VZ09xBّw%G;GhOc_`JNxX*,,47I#cC u.`TUL *L_a'3UgK8"u +LTM!m./CX5n7ͽ5&86 ʚXIټPcvDs JXKIF~ӑBٔa_ѓ,'VZ(nӽÑ]j,)\I.F؆S9QQ+a2FL#* Bַ E3R'2+Uv-A铥X"G;4L~HoH(;KM ПElqdrcVV{]:!T:i?;Pe9dP̼G]Lp^ejz%juR!c`%Lބ'~jM&F586>*l" z3T`ükS6+,:~8edEaV+@QuHul%U[O:~9{0(3#ql бvmy5N+}tޘ9iVq1hj#*ARhrK"bNGN{`{dR:/5+M1d s.� rb̟CmtlM)ۗə} A :S,^fgӎP ${'ڽlRt$.hF|I!�"x�+ʮ)Ȇf;S܋7SG[54(߽hPN0ϏI5"Ԡ[e~2_d PeO6iiU>^Om|q 4q&n"k� !̺(Oe:RRKnYLف3dmפR¯h^>9uG +4ɇetXa "yw30%R.37,Y0uyih#tq~cJyq +3+9%c9B{%\eO[>] a�e؂_+6x Hv@GK v,yp}w*bfjsߡ>rh œ>piBtװ.R(ʖHvIf$ұ/E`>]`k{N.-\̞ǭ"LħŴ۫e'Z'TTĹUv‘v\ggIT`ɿW ^4<[<]"o]/i<z<*(.ʴY/b'7@c&~CzCH \G9.d=c_ ‚t#,2 \'~zlrmg`D4.߂;4w Ob˥0({WheWI?802bQLxN<o5=cQARĂGZT cBnG}sb1)bP\,`_ιGoԤم.+(zzc#^7;OA,n.9̖fqRk}h^ H`ָ<kuKl +|}iJYtu4kѼ&+E6`c>g b1!}snܜ)==ےArU660%5'pО]lnSᇶssR?ء�/\KpWy/(gwC{e. /KFd�y*O3!+yY)p^f6Ŏ=K=uv9{)*@.5]x_9*/ҝa?LOg|#AX�Al#olxp~MQt 2F~l=w{,%uIREo-"([%}`JR쌲FPl?LcfyGH:$ΐq�j{Dˮʄ#g}O;qq⫤̾Z9h_<rӿiMy}Ɍz)Su1]K󳼸H~jʹ)u!/?*&a*^>q|(|!_( ]H::!,jɬa/"B7Ch<2d8#s(lW35{C%T\9a!DCަv"- gpۉ\3Xe(V%P3Qg߈hn(dt8A4:*&VtjRq~J?ac|OSLjp $W!½$ cU4UMj"X(Һ\BRl r9:4 cn iB$~JncߡCuT6ҷ%Tr@Cn>\ӧj8ZCa"ꀟX678kh?Dhbi)KjwX1>W@IS6О +by/EKhA D81gvA%/銎p?FR`5A>+AfdwP)3iACXiHs5O} +$wT ^JL?[Fz=O`5K(/c枨[A0ƏFM y;+'khc/3؜+A{ϔL-n7h*1סk +ds�;2Om+]ŪQ€5fxִް-,˜Tw�Zc?d6}ЎV̀:XS>JnY:e = +(dMu)jK:oT_>c :c#mZCk㾞MP@1"zM + Ƹd Pș�:eߠth4`@ o'GZ&ѡ'Pt,vs~J5C5œAs8\/aPi'�+Q#V�͟?P+4Q |ـ֭Ab&2rߒբvdƷ)"ODǭc}QB#)k„ |y،{AumI%X6q* +үSj4'j*yӟ۪!Y/TM#]uh>lF@=%Lcޜ:XWcjvYiY*uϘ>VݜS~˧%`IdV-}a֪؍8=aVLUKD38 Qƥ)_Ҥ"bC7m>8)" ,-&NW迬Wk[J\"жx*X.KiQ,xgv$aw~'坙w޹x8q<s1<[%хY6 0_ѓAWwA Y99+&&9ų.j"ڟLckָ?{GΞRNr9dvt-tN?$Нswz<:%j+tN-r:wNܥ #;sԿ45+,'tտ)܃} )�"/tHsȜ~5Ng"MqTu\ظB*7w=/?$N^H(Cοǽ)B~=Lџi,;f@<yY&zGQ,طU a yDk:yq%Ɓ-!Hl~1h|2sE+fC .|\E^l:f 3?ׁHЮ7踺1A`N|�]jȟ jRhCzXкt,e=ʥ*r`˻u:zH3A~fLGXM%I2D'K~3ܟeĘ_~T}?:+f#eZDG;F>W)4kbXImS}z֭j,i�� zא!� IC cBMe4 SN._qn(+A Ճ@Vw2ˏYx \CSׯ +ʔ[äY1@.o٦sN~ʧD,Uc<SwIs7P;ki-VgsO#cP0^+' F=PP*%dc~DŅsYȊ#J<;^TvI}]TgtbRЌǠfnWµQk#LoG63JBZ]ģ" $۔N*XHʅEg*KEٝow)Sd](Qr361QUݻ{XEXF/>U<~\n:c/Ow -wAXQ?RMeH}U@/O5N%%FwAg7TO[):ZiXSa=@ +y /Sёx@H'oJn=B{ XQֳϕ̭ >?]P O|-;P1҇`@r١QJH�,[[J� �x&Vw-Oɓ ^ٱ37jw3u% ir)yɫ'E |%XGq|09braGx>հZqᕫ>q'c豉rCE&@OHY-jHyZck׻4Zde >>XpBPNkةނfش}U`h:{C +)A)W/)}Ji胘d1Pnt\=ȕ0] tuEZm^N/S/?o:]VpBF;ۅ�J=D 0ۆE :t.lZͅZu̎ +OSGurO.oJ)lky +b,%Mϗ~\ӫj)ahyVkҷ(v=D7KEzUh䤑=+*JPa cE\Ddǯ}%()y`XќIjќAtF#k �|.F_�/ׅ endstream endobj 35 0 obj <</Filter[/FlateDecode]/Length 1041>>stream +H[leii*4Q/ 5VH)V! p+* `C vwf3tw%eVj)&b<4[XL4޹!BXҨw'wk Ѓ+];`5>(��e~vIF.+{{hZ~} +!s%7(Mһw;߳eNfwc[d +��7PَSc2:|hC]N*<"Z橌߱? =XsKF�L~UqT{Ab:NgXH.[��䧳fT=/v8)CdE~�z?51uP/qRpjѓ26��5pB/qRp{6(qC8= ��5[YoN N +n-~߫��Dߜ>ZTIaYԞE&k��jf: N +n8+n.{� N +n69k�v68?P.8)"J1#Z� >L+qRpU6e% }sW��֯+"RIa�{-Lm9Z8 z]~7bIa�J^idX';k~z+{�&iGv{A[ZVnFf}o,vp{ڥ_0uc/l�pv׊ N +xEI}Czvxzߑ�0%LbYkj?�_*oomc=5|qemq�o[np*ֲ?�YeKw'VkԾ+ S C�`se}e'`6ػQ>laoN]λD⤰?�̦l5& }ʧE+e:淿�x9 endstream endobj 36 0 obj <</Filter[/FlateDecode]/Length 1024>>stream +Hhu1B 9pB3]-RӺziitng67N7ߡǶ B)u|kmއ |_3(4V#DY c,,{} !Y�ʨbwȎx�P^Xkhk?Na�gXhQX<�M7v(xz<GehӋR]~ҷ?fowv'xz]] bCIˡ|o>�YO]7D?�dmZ4:oPjSeY[%[At +J//¾'=Qo�T,IsȻlڦ] :@ᮩn3=G +��BI _-wX{At +]sksw#};��^ݤOw'7D?�IQzhYc9�?gwBk7?Na�ԥblAN՗rPM��魱.{=#D?�;C"fWF �`=lҖgE!�;LmrSOV>�ɲFu!�KuN']ZWy[��ly83zAt +@xs+9\k ܾhw� reDmb쭻',^�ӥzl?Na�H4) (1]-UWz �0j_pи{S�մ͋̐qFMW}7�S5D<Kl++=Uf�މf:)�.ř! +8u<v8Y �q_u}ϱ= :@}è7"fqۇST�_u*¾~cҟ��lZQ endstream endobj 37 0 obj <</Filter[/FlateDecode]/Length 1261>>stream +HLu?R2m,~D?rg+K*ID Iɏ@D?JsP67/0F=|m?vwy�4mkȲ7I7 '(]�cmwbWCmQi^{9gVn�}dOs|~7� E{}aKauQi?�hejvK֮7E#Կ-�Q.:|y\3R�lGĞ �7\G/:K*A�o~ᮠzrItt}c�`9WsGS Z +x)]a?kP�qgI%b-<-j>{p& �w^y=v8N]?�x5;&?5-w~�ffpDKa�Vs#El.&.T�v>BW?�x%"2A9WnS�햎*+ABJ<ݦCQ�jkno5o< ;5Jֻ-Qvxz^pK;U�9;V } ܉_H?XS]vK+A<=c%GXPghd�$)>)ۿ-YZemI#�GM_e7?''.RPe6m$�Yo˸N&z3+}�>cDk QvxjE-u g� ߬ĕ⠣tܑe0}@l>bÓϓ=e*�f|bx<d⨸C7 +�m"?2oHl~Ѕ�FFhv|Q!ZtԾS�h;o*id{!RXu(ia�șmq-wfgKj +�ngX}paNФ".R3"{eͲ01;hF3EVuY`S]4wEO�O2>~5d4H;g%ӭ ,�JoM\BywxR6<]QkğAH*N{�Ɗ>.sܯۢ#Կ]�m da_?NcOSաty聈"xA�3p)l;F]hK�@ endstream endobj 38 0 obj <</Filter[/FlateDecode]/Length 1033>>stream +HhuV8bB( TЅ̈2 v tN-YR]lL7wvwܖ́GNEa̶E>|/ޯ� %}.K^=eʿv̶-BsZ=?q?[z}�gY]+Vmn@fU}iu-tg dB\KG�Ǘc4ޒ5. Gh &{0cD?� 9fl^|N<E>�)xy宄~a�Zs3vKn4}BM 3<3ߺf-O)�HW*V+uP_G'6�pY7Ye 2�1 _:r[Y"\eV_L۔'"S�Z~C2NM}�p L=pϮGD?� 敻6_G�pK:t]?La�@zL+^lk.w֦k=[;�meu`�Z4'lLCs??S<`�SBVyֿZ@+=FH )�c%GL=0<8_>R{Ad +�*[RLC;n.A @ vԮ'D?�@YhmcV(^HCwʮ#D?�r+zS6Z_~H5Y)�p볃!#.}H7io:b "S�<3KTG>y8Z׊�֕)�pʺ爵QsS#�;ylp*>`��g{ҝkW{LC{%N|Z}?~m-)�pg(u"6`y(�F<C endstream endobj 39 0 obj <</Filter[/FlateDecode]/Length 982>>stream +HKWc.7e?5X~ HrŝڒfT +nĥ W0w~tB}TL6'a7AjmIljp|Ox~ %٢ۊ?{FBa��<ٕiFkǦ}z+#UݗwFH�%uWh"XoM�].QAL +�bϔ⥢<|8W߶۠vl+t]<�ĮY!]yA{?Y:�ĶlQd9Vdᠷ̿F]7KOU/RAL +�b_R ԮW 9[R�xEU?Ia�9j%Ky—uS�;NJ6�eD]||]^ՔdOeg 5�'qbQTd}߫#htUĤ?�\+KZw[^}cP4?rU]f��JQ{d|W~kmcUĤ?�|/m],J/ph_w꿷�IvRcDUĤ?�=2m;ag 2MVuAL +�%4ST4oڎ꿽�9';osbR�>/nI'*tYv /FO/ﱴ=Te��J[0)K}nu$ybR�n%V} FZ6_VAL +� x +]뱃#CuӴc<8bfz=~?Ia��[Xo 8V8FOc p_zWϓXJibR�Z(rt~8t`Gyd^)PAL +�b �V^/ endstream endobj 40 0 obj <</Filter[/FlateDecode]/Length 1400>>stream +H[PevvȅSVZ5%JDS ACښ CrD 9(gvoaA4`"Aa# !Tӌ76޵/3Hn3`ݽyY'#[&J1NLV;3 �,}g~u:47Ͽ crɽ^7 ��l˩6;1pE�= sSBS?��QgB[1^}A7ɳBsS?��`!}-5iۿ7hk�))4=��Ŕ 3M3d_؃?e(obOA��9,%v;`eiZՃBsS?��I9ܮU䝶m+io�Uм ��xR"]]yGo آ|]mJ/4k=�� /&̗[Gzr�fl7mBs94U&5aST'?��`1Ju!Muؒ]Bh?&:8r7liaTB\z@r65ٔ'3��XgugȻՓ{-~NQ,4[z-cа +Rnzs��VDogb9Finvn vy-5YBs1y_v7hqglo'tA?��`)xhZՃݳw @̮(nd7W'D) [j+|t+;:դJHXs��Tfr;3՝ӄ�貶a$S[(4KרI0hرx`wS9>&':��KiEv&2cnwkc?Hz�bctMy D s1ܴ^S#>NTjw?��`9xlS^|'}@L.iUҸ0A@:F:>{FaGW=sW<��,Uq>L";csz Fj<U]Ghv?jL pfϴ+ugH}[]&`ߚU[jqghU��`>)Kų\ҪNJ\~�e/{'#{"Ԟ>Gu> H>s<͍{��1u*w@�Z <7ԐCh^Ȟ-oCzLvbIuMh��7W*'ЏK.h0t"uYA@ĚC&-Hߚ&peqjݷz`?��ТN3Ĕb#]`Y9&%A@`� endstream endobj 41 0 obj <</Filter[/FlateDecode]/Length 1033>>stream +HLuYrj֖5 7 di˃D&R0sQ#I9l ^=qB (`*]R@?7W+˯i}/M="5vDs]mN:z&ؿXQu{f^��@jKD{`›4q><]왶9N߇ؽt�*2+Eߥxu!0QvíN� xNO9!0ڛ Q)�@*ʩw:-34q{"0xe N� U][,j?J~WPMbxvm[`��7VXlO^L(lt;}R�tp[uo߬Z:KF`:y.rQ)�@SXl4-Lc| | #pδeg]졗r}Q)�@)x +LcGo+vl=pyQ)�@:ʮzDtfa?~x@_!G/wŕ *�HWn_ui|w,jA~.ׯK],xR�tcPLclr`y> \?;.vKu㍳?Ja��T0@4nߴ6KJRL,ϵAT +� +/Om{~=fv~eSn !eV;6�@58xD +c~_,cN-ЄۗxR��e_*߸}oƢLqeYi&gQ)�ʼ[n3ӱ N!k4O%cQ(�r,W\־HvR�u-[=7:u8}~D?��WݛLTόqσ;xe�K��zu endstream endobj 42 0 obj <</Filter[/FlateDecode]/Length 1016>>stream +HOu񏕘6[oʭژb GQn9lI  GN8=|aMsrb.rZ9sU-TmceMB�15ުa+8!{vZ?��l3ߔ;g̔ +� ҰSc}k<SNp!S)�@{"_L_ۨ"sL ~FD?��KsDywss?1 &GRdod :�׽!L2Ru7<W%��vޗEcWG[wT+M u#I)��9[c uRSh޶={d��~Xto|؁o#yUwUgpB?Na�� w_ًS˙X,PYaӁWe7 :�?[RNy>X3d\{+X<?Na��prfye6VX} At +�so Q ۯH_CxqD?��yK׉¶C#1u~XΣke :�|#:!\۹ޛ"8V0YQD?��oV{[wttst`N(�� c[_Xa۸8}b"zCPc��`<nDz~kZt7_}E:k~v]?Na��.yV0H{혪{.RSl~lnܷ\vSS��[*V Z;pg,]gj~l8VTvKS��:Tnᮠc}w^>*Y,#.�Z endstream endobj 43 0 obj <</Filter[/FlateDecode]/Length 1595>>stream +HLeN~Rdr˜%\gy(F&8"w}ׁ i5kfqsS;4~o/=7!h9$u7���.m15kE$)氀Ls}d��>ƻ1Mw\Ͼ[t[` )���3+1dz9]+;ϕV 2��`_n~$"rT/%p?7Y,&ozf?���nʎu2V1Yuߝ^\`59lVbճL���p;a ɫ.ϧwo~zN?���nD/%X*\ o[b:y.zF?f˄9rXXVkҪ剑QN֠���C@HnCl coCD0?gcy^RYp0ʂMj.H|u���0=n%ɪws&ưtmb}ǔd/l֪=F siu���l;kKo)z.r|N1]XU31ܜ5C Yn;jEp?���iIztXp?ge}t%>2Wl.s|fH|x՛4:���3Е}Bꟛ +[aݙi1m)L;7[Χ}cWf5���YȪz[u̵ +|nGZ꼭G@'`DLp Bv=y?hH;>��`|XNFenHq??s`c`m=2Y #?ޚzeҤ>K[ZTR|=ܳ?���Əɱd8NFq?CÓ?S%3(m;2֙:ٓ|a$ܜ9ld +YОt!u(r%9(Nw���HzVªIf:r=GÓњWwXYkLF4o1/W~=Eݝ>C?���FM̨0Zq@W6:ix<?6>jWk: |Q.5hx?^*>Ҥe~pf��7I +S]ƲF35܅cg b[1QhUVLmwO ҩJ\v1:��D:sEq[3ϕF^m^ek?&hb--Nj(kyxgh5���rF4ݮ={!`]{*qE@&R?FOJT䭘rT?w$OQQk Lyn~oQTϪz 2VǑ>%z),sYeSDqdDŽ'&V}Ī<+$)*./1-{c,7sGXŋՒ,^u~'iҔP;`'�5 endstream endobj 44 0 obj <</Filter[/FlateDecode]/Length 2644>>stream +H{PSw/*SlqvZJV*QFZ@VP AyCxTS+y$ܐ䲊.U]Wl/:;әݝnwܜxn6|&{~K~'ǿMLFdX&`edV!A"c &SK۹FIRoW/]F``1ws6`]?٘ᵢ0Ģlm)z%а~}7EhՆnJ;MSZKg;e"ZG͕;jNƦVY/kk6P~Oa}ʬpF+y΢ly)A<auX9 lJn3МqlO.&iImwA <h=Log<QqD,3fͳ8# w \iJ~6?-olJ ~)X;="uu ̹RuCAeAz(!(.68L> lgO :t1|:?y 9Z̵}ё4USg1_2(26<M@;keG>?1g6Kx�lc}k\|p/v<X3uA?ⰪmG̪3#l&9d'9S&.l̈́w9̤M/ sӶhm,=89_E,/r^VR#+\c+l+d](CGU* D6dp]ACIfZ/em]F9kgoe;?| +w YY ZU;Ъv#}Ŕ,9ޒ'ƓњFZmp^}^+cfwM2:,vs?`0pH,nZ -n%mPv#~y,e`;;|?c&lzWay'ƫU*9v^/04F1B*S@>1sKEy>E?ruՏ1Z/! c] meuOL^?5PZsC Y[=liJ' +yᵢ0ƎT檲WV2}f&8=m~ >0WQ׵ A@1Z+qwZ?@?v^?0c9XK-Ms`'2诖EkwTcnf + +{vQFJ_ai+L㼦! usA;_Ew^?O(;R`)?HhU;쑀bJ쳶 Z'm9Wx%v0o~{-剿;ƲzZy-CASpI^u  >ǡeڃyϿ8fJ'LrZ Ng[]<]s#^l' +!Nțec.L%ES~ۖd<CCk.hv/s we`]&/.]p 5 A/?as=?"}]cckmfҦg5$VeKlxq~\b\<)62_Ձ%*t6^ccPTX +7pmIKƶk;UP㼆}[U +xyJ/h:�+:b/;rf%}R{Bk\|L0Z /S1%K]pL]u?'~٠S�iJ?f]O3JM∦&h<Blu)}_E_3'6ɄaZ[bB~nD6flH ǤΪls͕Ъv9J^3[.uCA'QMsonN+E#&m뙠Q  2>X!Nk(Ã~Wƽ^ +GHp +yS@Ad(f$y <x;{'nVOshc   #G}L|eh lgOAA6^vi-v0g{η@+`)  cJ u0 ʯLY`)  2kҦ47{M;ߙZǏWѽ4ز̝  eqF`Umq+YbNx{۶E槅>o|?SD91g6[n %K5Z+\y}\i9\Xqt2~DP\A=S~Df3ԉ .^ Ŕ`g '�} endstream endobj 45 0 obj <</Filter[/FlateDecode]/Length 14620>>stream +HWy_L,a kBв+R.X +Ug&d&d&?]ϽRYΔʗ?I.V/*Ac])WtW㧽uB.?/z_Ug}U.szɒwfKr + >x1ehѾRsJNJ{UG7=hJ+JS6v73 \2vfZ~0)j/o$GUE�F%Qҵ>=1S,o% gwΫV/F6=TL$pҞls|J`^$o$pD;fPb_ϿȲ,&yޚzya2R 2^-7i0F!70 %g`r9o2&ao H=qt&MG_q@z)'n(`FSi3ia�Ouy nO3=n6,<Qiytې %{ +lC.D|`oC[]wmC[ ߆(xކ|cqD! s ]89v!> ˉ][+�6/-0qJB҈v#~cQvf2� n/ntƄUIhe%Y +1t P}S^<cs1ճTKŤ{z_| sr=vx#;gUT +k[Q_'X >k]V]f V|gi q$,fTrtA :q!fO9%27A]{U\/ nB4=6Cc(s^jMB> cV(s.JQ\Иe]P*.wzAޑ[,_9[V%X}+˹޷x>w:v'rE`R 7wlʨr;~DwFLz*0[/땈k$V8e4ZF]FceV,L l8?hr4 +{R%c-1~D#aTEvi4_$[= Nf'8ܺ3a%4!0(YH?Rg|q>6Ǘ_fߙbb~q@ܧī-0eC +?rC1{dSTJcw ZJ*rSȊK1F]þKD]2r\0N�C9ZKT劊mhD=a�PN@$A{נT<}OQ +XПVO/V?Ovo'0Œ#cdCٻ#DϚ$BX@<6Y"EfMZnnߐw<I%cB C WQLx30BK7BZ&ͺWYn_zG3rsɠU WR#$A>CBLKN4:Cf9 lCT"\:b>r&Z^J;"9kqL{K |enҹ#H5^|t(dLg!o0KC},1:ٯh3e(>=e#ꮿӭT!dTIhtfė-f:K'T?<1+vnQAfǯ$ Vp@d]!U[5ywx +hYgm vTƌuj5ZO2u&@4)=v{&i@,Kp@0�az#@<<q8q{,�I^l:lV]Vf~ Xi{XƝݓwIH;h{v2;ILOh H:88:;ud5H$ՙ@ 7]N%C)A?WR}?\zL6ߙzlu&xI \*{[@rp~\"*: +<\8y*d\|<ٻ#dNŲRDW9\n:ǚKÕަz N5~2u%HK٠Ei!2~n +k�%BC{xWomܾz*fD[ +*%@;&==5ZAOcr-Z5wtb;DPd;LezrsZuDA@҇�:4`]H-ß r-4b#v#4ZOr�W䂯uOXѻ# boǾ$~TC嫝Z]PaM:;s][LD8#}&XXuo%ʺtƩt?cN0C˂%;9`~a|I>|9Zw%^zGz#Ɂp[6\K!m mNЛSfYsDQPj 3DŽw3EJ\x֒`zI+Z%-b1~rи,h}0$X|gi݋ZPP=%ɟ N&7C8O*ǹrw"BP% %zh3B8HH/j NC�FP`1i8وҐa݋ּo8'e?^Prb['/$ }>5~+coiJ]aCMN#cI8F9a/Yx^Bl%sd �6=]n٣.c&!E׷A@0\=4żqʉ o.}P!tA*N^驸?a.7RN3iH0cV80 MydŨMrZ@H2d.qP v]J5z|@@$ۯj{JXiM3JP,v*xp؃ٟ0.aXqCz z6s Ya.,i*' Q�&?^(̍Yҵĕ <6�$AE\䢗;. lНt?ZNU:%ih˘'RO!XOQxƊ?araXߚ<\ZwQcY+yXF#�Tv]Xo6S,v ժr97 i2_ +`~z8lÛƽ:,޴?z-NcKgEȐ/_)Z).P ч`Z=Se :*J=ƫ0`~/Γ'\v~ӽҭ0Y4Ԯ(f]LE)z_t?ƜdYBNWRrmmK2I yqjNO1i:65M957{(I͈0|:˂5/nnN|sL9iߩv`p|O<@nU w'P_F!x^"C^8WRE߼ u&W\B|;Hrړޗؾ~h_S9䁏pɦ)N.F: AUпrZ + օSaI T:{YA8(5N1o'R(P?-Psc~7gW!Dp[?2/ N}em1eER9nF:G31e%u^wcqټ؈ S_; zǽPD6ZTcVUNMm_8%Ͻ$0=/𗭬jN +ZZ1ڲٕPnXLLp`agryim}ɄH.D4bIw?M۟Aݕ|X𱇯(̚>*e +T|,oGVd7�Q"T-f+`j!NJ\y=ZR#ah_4D d@`th gAkza-Ek`i1:sF,WJ8 әsʤiw2-C}و,q)ļ/bs-W a^M܄y^X%ǘU6'2�8606�LrTL<ƴ0=kq4۰ǰ;"M�Di|]i΄zr$Y?v8_1=_@j񢆇 `-Xp< +v�B ,3}t�"@8FΕtNwJB{g �s.qE0Ek\D]TPr$ ƗlnBxL8(*$Q*ոWPoℜB@P䵵N087v ʄ[jkM]DvK] ]|e'p;d$os_QUKW]oA]E!ڐ#hˡ(w~VpIVD)[l+D!g i>NackNQ�j-q'gRd՞$_'8-$y /d;zzQRSj +>Dgn*5$-tq +1jW%-f{t[l//ؽ0Px h)̙_R*\.ܬbܜCQUgsλMb SRb2:|&4ݽ&ck {g;deV_phЕdyM+ %eGrwIV!Y,#Rb\P7-R;xg +hE ]\(oXP2""0?7#]/4*`cX&.~=W& +w@|%mі83 >HΕihw9aYYs(xWxh!twUu\^ gۭ1Lvsnϲ_.$c XcH a(*2]2lwmtCc1jaxg5a F.!$wlaմx Y[ } rC89,c\S]i$0dv<QþR<W~4vpdz%eNHDvG(d]⃧p7Ųx `iUbddQJi>^-`@rƺXS|S0'6h Kb>`!5& ^c�͍A C_-e)K1ؓy +"-TOQxSYL%O됈}w%{+95^ym`p`'/(#a! ?i($ i[Xx`d +w#OSDiw�N|=g +i,5ĴؾXWUmwXk:_mMTI@Uˌ1rckɀg z( S!۟#ҙA|xULwCzn]j$;|)u}0g9nX9,<'5>qUOy(= ъW;Y)2ݣ%)6U!>H;/,ͤLD(EG֗ynYC:UΧt/\@cDp{9L%t+ipz0Ǫo,(ϕt֟\Y}8-JEcb: é)W=i(jR°wztѾ;մ[tld6?\m Y}wz9IKbК9 t~)&6YG6!9{>'#� y0 z7WnK\G$9R2$ѫΠy=C"C*?\^O^ҺJpC +E8%~M5&Nf,a?tR`bgHJ!~2P| " :>!^AM?-76;(;7Q%aҕFR}AJo1l.y;c(a߬cSgRgBBK! +H ME. W3*M$)3gfΜ0 # ͓!%k&G])GDh3!ȯu@&[؀wj3p]!Daz` VW`4X8 ,@c<c)igLA^ #LTȴͩiũν1L52ua)}Ec9ZxQIo` ikY\$G XiԿ5kӪ:FzԘMX/y m+"ݦl8E1sf֡;\ :,.ALN%ϙfqK%)=y%S +:m?Pc2>ޝ?%{S c7'~ݘe;bY0ڙ/c کCDq0awY`y~PgĒ`@V}8V6I2ql0t�,~E˜ fˎ}U `Mbc�p'5a:=ch}ny1ޞe7) 1y,boq LdMGeVOٝU=9k>$5GsPYEKJw~}�A kI4<ऻyMxibKGڨB|hr%ˑSSKh{qJzp0r..ASJcR :mo_ ʕem 9li Pخy4#&LH Z@jc6_-Khi%494hCUfG(/BrTU rn^M\j̃rElPU½ۄ`f<cXAֳQ<:T2l];]Iv9`oZ�T5B Y 릁pP%\۾"6|/$ BҧkYtT(D +s_lqf\n}$i!dC`Ėx љto21iKȑVQw+)ƜLDsRͤ01-jo̢[hյ1hxޝVcm~\cp k.01G;|Q= +y{ug;nܭB3!22fZaO3f(aTqu4U +t%d3.SF(?OP‹*YJ€F%);)&SB<w׎jd%=^D +6Wy=yP- +8[y;j'+QٶboUF!# oAm0&>VzszP "6\܆ZQ*Jm8\{>[c ]L5v~x yZXB�+cgaM1W; -+U3%0 +L-t%HT:g|Icˋx*M2ScSmx9,#]]yS>wz@; !;;LV� 쬠;-,llI#yx +H_pJBK|[{,_ ؆qKSz6t`bmruض2J.`0Lݑk(1A4OW/X1rJwĄ|{{%%9j C�Ͼ`!l74~^bG°ĸ c]+V3#a"'%&*�7(KǎDg,ELF1֦(c4L8ܧfA&@ g ӟȳuaSEy6I=PL:*ȉtcV0,x-�i]XI1�½0 hӎMYp"yoD[;&vK9v ]/tK"x3MouR.c/BǿTqSjoC1ML5)˫ZaImG^]u4-jI#?wewq{6,y{3ؐwxSA^Qr*ϰT-L@$mk*pbUuI.kzKFmdaO\nw/+x/T pgnԟxQ&<-v`!0@̋$SZn.eD!9'li�B_:y?}\p1+d_[.iFYi К4Y:su1(JKs_7 +n~Uv ؾsgr[K3`Q͒HQZEu||zG+A ?X!p6' ;L̦JӠb4@@ ! P`FQ?Jqr<TZǨWMd86wFBUoM`,HQ)?J{yA];i<//U`À2V/S^TG+=,ﱊ>J݃_K�=a<+p(Eˢj,A<w ~�صXr*�ix|ߑm7i|q찥2O�82;e}Su%aHQmDV]gMP9Y5n\>f.jZt 0?p&$ŸROiRa +Ngژ=Q+E<J?k׈)z&rzm6_$2$Y q$D|+8+y3ӮCX`xJҫt-q%>JNPք%D@A@pCQQy[/d:uN- M ʎm~LtRJ*tL/y=um~'cM ^=$W Wws`辄_$!d-{"MsҤm%㸊=q8I<Dj\](j)_:<h֍]u3|,G5m7f}w[hbqK.{ \(1+Ttk,IyĚe'(i ȄHӆ +]:);Y*3azp[epAc|w9mp'XU΋F=)A4=n༽#f'4! 8I8&ڠ@/U TmRL&>gO8x;J4n4^%Y'IC+DEc2G9Ϸ=�gMw=p͇J1@/Y%ʝړ~bU(w ?1QbVK~5h<Oh.m6;efC_MOfKE/oWTMKSyBo*/k}d=o`oMTAh +euҴɚ $Y-*^I ކ#>gΤ4 ói -$ܟ 7"|AiJީw4 !ʿ+orvsYy{ J +0oK~]܋_oz^& ~V0zŝkNo""M)ԇ\?Yp"Iy&HR0뵋U w\7hR#UYAe2TdhLJ݄uo+N;C;0C'،N'MF~�;-\w*G|ah}�jD&4edžA w0>G)ۛ/9Z+1gQ"z(q&CϨ Ŏˮ. AbK!#@(<: $�a6AUY^|@ici`j`a'֡�h-A#v/)V,^7x`d\*X\xJL\$? Ȥ #_R!aH �υ(iaCE0M>(yp|ecQCɶ79 +&=ǘrLoFl c~1�!j � l!8/C } ;�}>>B0]PnO'Q^6 0Jܑ&~ m v6D>|YZRR;}u^&6| %׎l 7u"tw op  +Re~]aÒ7)hiҋs6RMCƽE-ŵaoβءm16~}{[Px7B* I[ gc wɴjRIL&Y EoY+YpM+}Z>?xjdBFl+:iy- (C_MHbM 8M`:pזgMIhY{س4# V\9iEqvɖkU@9G-1h tXA2%~Olym qOMve6}VKWڐ%'4 Wߒ̽ 2%ƕ:[Ub{l?e^8IЄ*+D؞b.^0^hҪ+^_TZ~OS�{H3$Np:3R=)byzXP=a*"c? 3! +>lU{ӜPhm Ѿ`Gl0pTr@lD/\d!PTpL=Mc\y + )WW}j/@{Nu9fLFN*$J 'l`=n|V }lypcO ̬�}|a /@/T-io/Jl0Br,锸]4XMAfK&X;6xe`GQ$t"ĉX>,8Cu 4m)å&矍U'fRء$r }\z!,74Zc_(WiCA #&V ++<Dｪ<g2փObR +jpN@,m^ ,W/>}h#eA(NQF*>>&Vey[X:_;\˶^N< 8z|sA̓m)PHGŮDj67@ӞU*^"!pK_Y?ۑ>n<Oz!4L_c_<5D??nC6`=ď>8\ +ƻ_/a"v+D"9_/8~4׽y'O>pwl#t :ۮ'pChԁ%  $ , + ʌD[=dkNWR]]{׮>>!Di#c_ C bqOЭUM1WP ++TFm�l 1X2/PCZ4 ME5èK /͊ 2cĔ%=p}P͏ƍRv!xj N33pe?U1r�`Xg[Y^&+"qfDA Z n}&jʜA9!JAf|cgjS˞8*>;K�לdĴG>$3�c3+</$rȃe`ty% њOʿEN~R!Z.? + +הVD +@\r1�_/>�C\a)K*U.`3p5mx\%\}^&`/!E:j +o %!Ye1 ^QƥEz?hұgߥ߅g\9 ҳuf@S\U(< Q]B'?_'E9]g}qm.zu[ _r] t7\ +mUhkEyzi%|nC5`A<h..KhTvcl EX,R@pK]Aů8mB31/ʬT�:KaF!0e)kҤՇ\* hg&HY4vC[�6�*i<R5zt#GSq(9iƌ o~< X0~`;F !mU y2`xܽɓob퓷u;!^c_yZz/](7ĥaF;=bͧR@s$G[nϜ:oT(^|;N՛ly%T=zbu|gK#QR2$XcYihFVmiz xHJ,BE>fGxL2\$ؤG\GŶQ|fT +ON<x5 +,|KMUހ�/b<Zm>hj {,8ǞE|[i�~񫱽 Ξ撚ֵsm?y +c +T6G / [;bzu޺Mb\'=?\ݠ%r0lf E.E*pp `#^DSձ�A"Y +ڞ +wJ2;NcAgB*ڪl=PE ,pOY*_y̍x-OPr+ +U} ͓Sp$_b/wٲ,g}7s6z~%f[r9luFaK*_=`9%Z\ɱ"R6-l^f<[FVr ? G#9b^{HS2T:DbqܱkgB±PrfF/b)XN+#!ol=)4_D .q2~Ӂ}.CXd.Asޠ Cg3FwKo{C"2B~\}W{K"V: !J7 +s~TƮ|02Y8SYW|5 ٪蔚IV<aMw}'yvCSƯtی{ t S<M|MN^*�xp q� l]n}r~,ذ@` fɖ +NG&;pfT*(=oyb <rjGFz3ʳ$CʆWOV+CUc{zM~APàN&m+ɓZ+R&%-+pWqud<S z&P eP˾dVMOY΂6À ,׷f^1>p/z#\El|HɁ"H�݀ /S,,/Ʋ1YjJÛ :KlߩF c\/`})"n{bn;@> tSǷ 0%z՜+Wֵ2 ch`lrCtBcg#M*x� |i%(5=Qln(KǖJ/#sAs+܍Xi"kfbd6ȀI 'E5`e#Y$EHzNHlj_\9BVG`*DAD$j[9+̜;–S`׺RTVa&wmKNvA-Q}ᏕDū떋n.-ȎȑRAmؔ  $ l@]6`ohaB%,= +΅%1½ Ύ>:tP&!3g'|d ߾̃o `prM҂Z4Q[jڴT MhR&޿{`Yxgvf5vd薷vB$ScEw4twwJ\(uq9"8p=`?7׳%ClXŐl П: +)i<} /m2Q4[@@"Cώ 8q4TCk%:x;~ %@@Ƌz`F&`J8!t&!f7nMK[)Sb|,"adku\$0ɥym)R z˛T=4%&\:n 9/X`Ӱ:۽('徟piwBwϟ)sW wnqPcv9>W*p1Rbd]e8 �_1c1ħX󔓿+ F1Sx%[4@I`�w endstream endobj 46 0 obj <</Filter[/FlateDecode]/Length 3340>>stream +H{PT/Q1V&6ژ6<jPZXS(C PS. ' grݻ*apC 1$QGg:4m_rƀws~39{eC8|%V=xދm-Zt:[٩E4/ nO2=[e)u%.ܝSҬH T#baaaa=S4-w~6l. &ֿߋ 6;9l3poPѧiFkc:y}TeFZP2x_b{3?EYoD/7ǮƜy.y*BSArs{獅 +H +!:Nwm/IY|x("l1Fӑ }2{{)ː5jV7i]jhX3k4j^wXtAi7` `4{'*)RQ s<,;3)N])@;eV C+Qe^]S&zjbE1F4gEt+e3b6Ezp~|[RV@a#jgߟ;D2h0OsB,S}8g4XA�o}Kaaaaa}W˦ E[ڶLj`f*}əbK~Ʈ-`] =np]bf,Yc5?ZcSq2g5ԥAnmqpʃsǶ> 73ad +@E*ʦ_.=X*;.Ʀ-}hʗu<�c�uX |<g_]3VeS-X2kBR- j:a5�OF&j^(Uޏ;U|]%Ы?N4�ssL ٬eIX[K ի*iQ7Ϝ;=,,,,ѳ7 + +<ƽҺ[zmci'/G,�ϚSx)žCֺzt n皕[PsSGO;rAO6Dײ3lÏy�Zy̺rzhاss*39<gqmN~rHy):'ϝc;_L$j͟h˥OII<`'g/ǒpgm091+7oP7bks U4q@R:e(nT}Ƭz?<,2&_H}FW1eݭ2wk�?w,n󰞘iEp~? NKi۴e½VL'< }"5 +-Ox@Z# +P?pRx+dkC׫A>dxܮTvQe>a]TClכjg9ƀqd]z'` Tݖ)�;p=i`=~Gf"T\^\ȁ.ͱ{?05v}8{~< {51~f�:JYeIaaaaaMn$(u6x;[uor{r~?pRxBq0^-~?J!5 �+lM 5GB-qJe}%oz?ɠAbrS?R 5[^':؇ZXc  +N.S{xn(8:tܢMkT49"(r8$H<W NK kҠ>fun +XaKmBtAnӖ sAY8פ"78Q? +IU۔0<?@4 +^XA>TbmI^Ⱥ;;9쑵RPsS -k:X.{56mkmqE]e?'l6lm$=938|)?*hux\q=4>Za ELB(@M;9|Ρ^̏&IGHYS:oV+v E<2n|aբ= +'w}4T[A~榄eփA:~7%8|)?v7? fL>>c9?l^cjC0Vy?hk4Д/_ﰡOS;�i>cp~5]Wr NB{IPvWC]x茰|d59Ý?U/eu0_;&%Wٴi'S>WjmkhἘ[nXXXXXowhtgHOj&x9aK139pJ6D|-d\`iv1I +Jvh�ꌬ?b/Tf5x45]9v}#cC]lmi1u ze~B8?mϥ (R 1H:5͊u)5m(56m8}8E=6"XF1bEvt:I^~ +>oZ=6Fٞ΄%_@FexdktUgR'J˵?cByZ0R=i0Η\V��>v ?X+6ltnp"zY?0F=fz]}Tu|;?}ilî��4 1z&yL6[)A`4z ]!IٿޑsQ7n)ʋ:��@{gwZ,m]ŻYfZ1?jac@}MΨL6l&��zm9,]6r&B5<UnuR˙?0Fz}i{J+���, ӹܓ.Pii#r���xWIT&2{ f$Is@`4���гfU1z^:mۡ1y%^h9H����k0 =\zf)>$^O9Rԇ{1Ҡ?�_`�J"w endstream endobj 47 0 obj <</Filter[/FlateDecode]/Length 1337>>stream +HLuǿHqla[8 $Z k ?"tf HENe"=ܝ6j)u2~Z}q4qǣ=뵽>s>_۸9Y52}}Sնxb[C6QMV<eqs,ϳ<ZOADDDحoOO{\[W=y9ٲ955?  ""b98Mvwxz]2Ľ6xFM'-.w]<3ŽX#i"@8A@DDP5b8:uUZ +~NX{h,5u?  ""b(zf}~cW>^}PWwJ1n[GsSY=wïxp?~ͭt\>XQd0"""o8[_7t[Wj/&;#ij#@HMLgs2Wy|׻CYSR9rv@A@DDp0)9u|b"6_uEF5? X 5:;-]<~A3JAvNޓd DʟzH>#=~'˹,3F n׫Z(DTƎ\Ӊ讝/{.#rlD{@zt)B9F63N[֧ur);suj"f6g\e4{.#r,Ǒ!}izUQ{Rq*C;MZg3$+׫Z(|Zկp+}K= qdH_z>Z*wYd1獻+3٪!bU9ƕYSZҳ|,5˾oOȑ߳G9ӄLeX}X9-TU $9ph^ѵsZn߾=<W9ʳk˙Z1gdMs\ܘqoCdgY|KB5u9M^?ެYgwVOQcso69}\-͕]VK}f8ys@?M*<Nen[ٜu:7WZ3G2H9A,[L9yMm�"P؛Jg9:yOKM�����av(,9Y7Û%^*K^0?NsدwYO4]ٲe|/sF[����CfC*w_oysǵ/++ - ����������������0iW�^Ah endstream endobj 48 0 obj <</Filter[/FlateDecode]/Length 2248>>stream +HSSDET"VZWQ/CEe˲U\RրB!B$:::V=ن 8Lbgy2^�ލZUƇ6ˋ{[i)=,@])-h [ӱ}~]d͍!)VUn=s oim\<kxaU^g?Y ը3,rꋌ=S\"qzπ`2~>h5=li:;uS_d]() u]'mCB"z2}vϭ5o׬e8Hr"c꫻t/.>w/<9�'z<q0͚W̟Lo/٥[w\Dǵ}vY\Eqq(Sts2\oP) lÊ[Mghn:臌 IXHĥL8j68pP姟?뎺k09{+4(x2_R#m +}Tsl052csBfht1IX~=yolxBr {n][KAgu<#cXjuS%?Ƈ +hզB#i)]>V<G{!cժ1™ />vOc7}C{qp5#ծmz32>s׎gd=RWa\Iڣ鷯OE}Gqlfytd׏&klAY:m oW3J۷%\ؔa4 |$}G[UujzQt[h {�LuXp>G!cѦmHcCBuv4_jֻpǐ/汭YSN{2_ңo[K˕1<(9c\0=&?:V+qޓٳϏ2-52K)ǟ/G]:#80P {<}A⳴JKG6&&9K߄7>rhm_:U);u3;_X<h5};lH`/7 uvHq_;u81Qa/N\)-50( ew,ZɆlimp!c4*mKNKӍښ9!ߐwC8~w:hX<;B dL?[4֦Rire1.{Qʕ8D ,:`2̆аvd,EZk{ͥ}Ǝ.˴JKG6&&9Qgy#׌S6GK 'z:}[relJuǰ`LTDg > :h5=v(aX򊍊~7dJrptFY0 +{  +?ɣcn3ttsHPې(f|][;Rʕ4g#c)ժ1:WUQ\Jsbp7 D&U_%m3vܵ65f0U +u4Y&ǯ2>ڼ6.^|Fƞm󚵴Fikؠ�F{cߗqր'⮿N_[9l<{d -@G\[W96xwo?/]Lֽgck%98ޚo 2\!!NmjLr {`wVG߮0l-Z4v0P}8+%}z70gtjK`)/ ׯe9ڐ1]:ZUzޘ/?Fg:kk2陮bsؠmIY!Yum-2ǖYsq`Lz9 cEgkSc'Asנ9<2N[7U=mI˘Pkw#,+g:k09fIsC]~Eqq˄\퇌ȅ=j;o|Dۭ괔a)]Qs#F-W0a]+Y:Ƒdd|{;?b͆ºNPc|GR"cs&mߐ6W{AMV*n!)U0|?~9ߩ/2���������������������������������������������p +0�C\ endstream endobj 49 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 50 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 51 0 obj <</Filter[/FlateDecode]/Length 456>>stream +HJ1�DX ٽ7!26��������������)}Ӏc0 +_1`sadg9/}drcӔc/>crdOc/dx.^NJ]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR}0Kj@4`bYM+fصbf]+fصbf]+fصbf]+fصԤыNLd,Œd.f1`bYg.'X1`b{iiWk4VLSknp‰Ol5vji*vb׊i*vb׊i +u5N׆}0]k| `�{ endstream endobj 52 0 obj <</Filter[/FlateDecode]/Length 653>>stream +Hn0a]UK Hb_wdxV{(V}|稔3ҚPHk_tJ>TZS4Pfw> FkC5HZshSsJ!>BL}(P +1@B,}(XP +4biC)ҚQ14bhC)܇RCkD!܇R;sJ!v>B93sJ!f>B}(P2@}(YP2deC!ʚQ22ddC!܇B5 dcC!܇B s +A62 s +A&>L}(Xs @>,}(YP~ C!1a|Me} +x^={E.>^UiAo쥏J #kùIVAGCq@n?}?IZZU$O>d|'yC;<cጐg^:y}ŹTմC?i'>B'[wU0Q08뱪?`PqUPy;5QQ�fKZ3Ӫü'b^Hq|0�Ϫ3 endstream endobj 53 0 obj <</Filter[/FlateDecode]/Length 681>>stream +HnQDAi#@Nlw]=oQgy 7_v*zq:=u7;^;`_OkVBoi8UDh8TGgRJoe8QMd޸OO εqG7Ȱsj!y}۹2(sbi9nl羸qqWϥs;;WN>iANi[Fk W[hp;\bX<ylM{sz#Km~|fQu|޿>Ig3-tTr>dYC{~ { +sӃUO/sUEOOkU[%o|(+UVQl?^Mbh(Mbh(+>lS`ŦSZƖK\zsӃU`E>(:1=XEѹ*}LVQtczsӃU`E>(:1=XEѹ*}LVQtczsӃU`E>(:1=XEѹ*}LVQtczsӃU`E>(:1=XEѹ*}LVQtczsӃU]�� endstream endobj 54 0 obj <</Filter[/FlateDecode]/Length 622>>stream +HAAQm<FArFIu,*t3zйB> +,*t3zйB> +,*t3zйB> +ZA?s?+:lG>nzOzџz՟zտK=/|)R#xC">c;f~&=XTO%NJXazйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +KVRz{,*h/ _g>B@?t>Av% ^]qd#;Op?ڟ �*L endstream endobj 55 0 obj <</Filter[/FlateDecode]/Length 598>>stream +HױjAQO0F`ZPu.MMϓ,{n妊KF?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:+_Oe Ttذ_9 +V?W>_v<+:lWSɱæqǕnv^9.|z§ +<P<BzupWSѵbÖ縔+2h?A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT7 �B endstream endobj 56 0 obj <</Filter[/FlateDecode]/Length 1555>>stream +HYWHys!J�ك nжbB~>BXz>}f^㈩TvS ΚdT;Dz3&#w=؞v]vӯ-?n.C Qr#nL_ٟ΂��~x^~:!;/ARqzROfdbcp q'ѝͪihh +Q a`j ~GbxՍv:֬X˴ң^:d,ghfeLahѵ筡t*^1khdM&zi|f<g~N7\=zP?5QԂb.XP'hZ9~,U| ?tl0P3*g` +g*.*تVlcUUb;?(/*^噳j1sՊU%eQU}kī7ӧU~1QjmPtoKO$_^%*ui{Ԩg(6x76[~|su5.F z%j5 YZE/wc6s +;8ԒJ ̱5>j(_NNmXc8~G$"!s^DT2gLr/Z${/2k5C}nIJ^'^fL,Q5MorłﵹޫTQJff^⪟?Ds?b=N6 ]*zFT7ьۍDUƻe7YjޙL"woqle~ښOh%``v|=e,-׫^}q7V-l;yOF*̧b]C.4dgB&4,L@O.΄ ǩH8Uc;/R53B{7+ifVaϻ64-ܿh>׼turLszEUzIO;ڬgWNhys\ѣiwqDs1աu7*۷ŁS7UʃA>G^$Ŋ=f^9EirtC2Ey2˔Rz`ܿtً;$E;7{ R}w0ם/DG|ndd#BJܭVU>.+O<{x _䋜ڍzf9y޶KmrFûԚT9Jh]eix1P.gYrCr_4<2|vsk8w ZSw2e=;9h4هݵ<g0$6lk5:rDywCһH˱+\X Qxj[NO҇z֠&v�������������������������������������������������������������������������������������������������������������������������o�T endstream endobj 57 0 obj <</Filter[/FlateDecode]/Length 594>>stream +HA#0 :֛O!?g9߆,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +Ttذ_9O%NJו�．@<+:lWKѵbyq*1Roq|{J~9.|op ZW+.p7Sɱæ縔+2h,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>g#�G endstream endobj 58 0 obj <</Filter[/FlateDecode]/Length 846>>stream +HoOP>^phR̢&ee1 2Gl^]h/ LDZR<, +L{P*4ChҴ ]K^0v/M{P*4Ch߸R`gt#U[)^[22>? In("_ЦWs)]oV3!?f(i5=X?,uPaY~'Ҝ?���ƭ)v|o9Tp"ŕ%8MOܜ4psEμ5g'.=qVN!s]=p.O?Ə:aT>xr0qbWEZ*C35CPRթ)J. \\>b]NBp1fE<ӨO#x2c?Ou)_cEp6sNӥi9Yo^P&8Oܜ 2gRi|���������������������������������������������Lrпlo+E4v_aMV[&8z+t~|;ƣC3_vwǻ{ݫ^n NEd,xwz^~ŗF#~_д_A5c QNhE-" +k՝zn>04ptP}3zytk6MԶ0W*s-⮩Dlgڧ������G�-:� endstream endobj 59 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 60 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 61 0 obj <</Filter[/FlateDecode]/Length 557>>stream +HKTa[~D TTбMHJaeZ-R2W5 }IEoEmB"q λ8'�����������������������������d,k0=4I߻٘u]��@;v<X1;49kS-ۊ ��ɱ/=Q��7r>L-~͍"�� F{{ƿ>{3:EV>MO|Yuy��@ZX + qLmP wꢮ��c]cy/U폪4�� f#p8Q\w~2YdW/oޞ堦"H&DDDD$im-&_ EKW[y r_"""" 6֖̻\>uj ՔWs2Q&1૎k=}=9y- [>]{>ܝ[w o:|/6u _z5sְ>'�_4 endstream endobj 62 0 obj <</Filter[/FlateDecode]/Length 416>>stream +H*a,,K,N"H$?B™Xq0o,^{]5}MWOwT*nu`s676\m|_oꝾoOb;/{~ dl_#UM噙֛Tws>'<9>A9q WH#d9'<$g3�@kD��i>�;F$ �63�@kD��i>�;F$ �63�@kD��i>�;F$Ezz�O?bY��A$EoNʞ�DR,{��qIt��H>ζ5ՎG^�w- endstream endobj 63 0 obj <</Filter[/FlateDecode]/Length 430>>stream +HױKqdzNt%/"H7k /" B.AA G#Pt:o~ZY>w B^/{fOno� �)A$� mycF� m;Q�"��iD?��Ҧ?D��M��H v`f�pLIͭ_[.J]X�@(Ǎk#O? �v55sey~bW�pBy|oN͂�Ф?{an��8?{=yz`{�Ф?{þ�b+�p  �׈B��mgQ^�Od endstream endobj 64 0 obj <</Filter[/FlateDecode]/Length 632>>stream +HKKTaSt3 2E]e +Z+t٥I(LtF2*IY}M- sT9 3=̜3s,ޒķ'��3~üFXLX4W[v}DZҾVuuawԞ=#r!rIL!r!r;Hg L�3Ig�p3Ig�p3Ig�p3Ig�p3 UU3guz4?3�@׈ +7CfG� kDA.u��e^#+ ~]=?��ͼF=w=j']��6aVSQ=q��DyJv׉WΜI?��ͼFXݯ7$lU��f^#̜5[o ~ 6Ƈkss<:/zc?W+�fdA)۟S_Tӵ;f?mVb��xRAʏY==/{'N)Jy.?^ _M�OׯDPG[h;6114y9�´5ԗD5\y˸3%]�c endstream endobj 65 0 obj <</Filter[/FlateDecode]/Length 608>>stream +H׽oMa�DT"b`6HH FDhB5҈kDDPK {ϩQ2b0PbwpMoo Ó<><LYIӛ^#׬Zz +xz��9wv 1x{��rCF<ϳoCOB�`tGF~X{UO��0݁R 8sW= �&7NbY7�0r [^ϳ�[eA,yXZe<&��<Ģ?Rg=} + �)Ch+mg�Z d׌۽gv]��Lz Ģ?ߘKŮл��4Ub{'TiU]��LĢ?fW;y:z��Gjh׎---\z��?M?bk}hﾹ�?GA,Zc XNBo� IyY(҃ڳtum�� A,+ۊ{z��I<ϾbU:}iy��yM �K endstream endobj 66 0 obj <</Filter[/FlateDecode]/Length 1277>>stream +HYLTgophlTh\k4t hդjqXK^bCQđ∊+81bq ȠPZH6qF4&mPrHH+ *$9C7sq^�ƎJ?glsGM@Bx˵+WW}>��]ՠimq;2HYT}>��]u^<?eK]Z��xijM )w6DDx?:~W5:z5CR^&č~[6}[ORwcnYmN]O7mxkء]gd|23hL|:Lztz5���u?+mBzz͑_BsKYJH9rjvuR_-wj5<<O]\5]濩+r^mÎsZW���yۛ~\[26K" )Z"RB:FIAZyŒ`;d ի��xЕWDhho.i*6H|׍;~<~H+��xnF?+m6iEYgQ/g3jY, P:��.ГØkQQw]uN^Ojg.:i��tAtXn;CD.+5f|{W ��§ЕMܖ{MǧSmMQ~(]3QR��N1/@@O^Rv^w&>Iugxk{ r.rT��SRh.:pVu_td~X*xʔ<Dz ��LL艧X3aQP;&T}<5+��xjcb|艧KݯY-dbE.^Q＼,dA��9=cֆܿW(M yX<X;=eǴWzVn��'wFz?zEJqBS)EuO<p RY^vE��t؁&OԺ?gcEkM)z+):zz���e$Ϥ?'5r#eBEN=vΞi��.Ge=H̵>sz茩}2)S{홖IU ���g?'Q[>j8Ysh/[K)SlrlbP�z�� # endstream endobj 67 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 68 0 obj <</Filter[/FlateDecode]/Length 2006>>stream +HyP.WQI`8Q ֤vR9Q t@L"nI]ه}e!! ,xAhՙ$uWTh mgwfq{�τx[#W~:Lfc>u_: 4U:9M$}vh}u~hP��� $dh3H;n)D̛Y߇Q#7%uqsq��fIL9{,N9H}h{a*W_77?���@ +d sgvz?64.EaͱqSl���0B|RT5pU8G@sO l=5kD&Nk}rIyAvxX)|F���pR3JS�g1^Ϝ5Sw9%DBk7ۖtG>YnĘ.���$jYUg: ؛!txi +AF$}wSJ%e|7= \kXoZ#9R˖ +K&h���yԕO*s7ZVv(uG{K +ֲVUp`Ѐ ?6+rg8|~{ktuy$2ۭ\}w4cόͱq~3FpK���ԗ3J45c6E_%=sC鏈$O W4ҷ.ڔ6q.i`UeYIIcSHDr +}g���iiG,h?|?l&wzG"$ޒ@cQwڷ0oF-[Ds(80\%���#JBiP7?QjT-"~>WɜDV)wgrۉnjB,y{RzG]rN-a6yEo˕���2j5%:8ՑQˮX8Z0Йǁ +:E6DSN|m{[+duNѮЄ˄B\7���FNsĠ4?M 9+8iY_G'SAT{(U=a{K/ +>mkz=#儧%$]0 7f6���~ {J?yC5jem l?gṉX3͛tENp*u uK.yQ4qr3{0>+)i!_qYL���2#^UK`<=< +וLC\Ks~<E;&<>ey~7^ŔFլ&pЋԇkOI6gxZYmhSs(g/+���ğ#H1q7*n#7ũF櫙!z?w>MhFȳV>YWݿjx|4IU<lO]σT7I}X}ՑQ$w��1&k(C=RZvr3K8<0։3+U}Sѱnwߣ%:Fg{?H^doF[8Ȟ7.[.|u} ���7G/D9#ز7T +cVE,'g #?g7/ +dyD W;]Nt:k>4]p)c5UHfįrʫa��pRi*J?h?9e/4=xCKBtLC.EƳ먢ڶԄ7f^I$i`jQi cߘM/x=g_ ���|=-S'NF@tl|6HSmKөaQDzK}w"5EoS(!{k_L| +x_���55 -/�9 endstream endobj 69 0 obj <</Filter[/FlateDecode]/Length 1796>>stream +HkPeu#E +hMjj%fTmCZ&DHCRıU{`wӻ b- F0!C,Fol5~pCG_5|g}D�75i#T+Z' 1Z2i]TDum*(郩:,j+rϝka󮬕ɱ>/|> ��;Bиw]K_nۡ?nٔZZ*ԟ{^,Nt4^j +{T}&q5Nm+Vz̚<>��^2u띶ŬX�@y~J>rx8hoѩ:$[?$m",��qv6s ?O eA~,ؗ{/LNjw-4?=ìqm8X5h�ާ��]wa G$T5ȥʙ>}qօDӽnޣ?m+r +VWM̴K=x��mZ~7.^,Ee +=g$:$q@BJ`hfiIq���ߴXMt$L7xE5n"T9򡍛넒g֢VE1#x��M%CoX*%b y2m]BTOn{i3Q{s~&:w )_//S��o*  7HMLm=x$H8:?>Q-q9s>//ާ ��@Y[cQ G?@,1mװwl/XfOt,Փ:"'Ԧ{`䧽ad]*}��%'McIo0bɱka;75v/&:SgCԋMFvٚi|BtW#x-��ԔP`>xV6T>b 2 "dD1D + 1VIv/amp$#}�� RڌO" NCX?wB +{5H[X)3ֽ+GԸ*/,Mꚼ=OC}�� Eֲ*3 BSj~X8X']H/gԹs|EӦT�.eUUZ ߣ?@L=3oykMAΪ~'c%Dg +GJr&{a#-l4~USƎ'�0?Vf8�1A|~*4 g +xޝJFTW!У!>ު?w[vgJzrc$Hx ��ʦ.6 _?@L=ׄR~a5=]+G԰➧^iX_П`W+N+6$Y4Jy-��X)G?zA +:{`j=; '"5ZcZʕy۶{o3h@_��]E?zg RP/g  0DN9y4F/^3(w/^rOи$Hxu��@/[ʷkGmXl+YdD5+N]|~r^`la갘+TYmx6W ��όF�1A}*JY]EZO׾\vYߘwe.8.7/�\  endstream endobj 70 0 obj <</Filter[/FlateDecode]/Length 2054>>stream +HiPwo@zUrwٺ(Nkd)tEEzADX"*(H�8 +$(ªE]v{>[tvf yg 9;B��`ݪfYY5'yMfH�?{l>vQ Mھ ++-s#~tDmoO|"RbM3h7*NIv g��Q QVBh.'y`Щnt`~"aU5ՆV`LsT`Avī Z_Rʼn"xEGa�pK?@H?5YW*M u7+v ƝD=J7۾˩㕷7.Q\)=q4pnmaޞ�Br_o�!`Syp[7*zDF3㬬īz/"3#E7c �繛h�!`ԗzf&ET QV܉}-1׫sl^cPܑC't$ c�WJV``XFSw` 6O~(.nqŌ-Kz "XVMA"/wrg�XёrryA&BϚr`u;|?jn-=Ov _ܤˑNzocX?��m`tƝBaYƭ k4T/+))uN/u꿸eMYYWu Vy9oM}e"X?��,)ӟT\y\JfC"+ GF߫~s:7CĠUw( +%ccFX?��v $٫;Gr0AߋN}WLif?<{R.W5 ōiΞkm- 9Mp$�9xz +>u�!f$k1蔝 oCX5H:OL/uoټ1SgUOwVYVe&;o^J3g.M+O-�M, hN읆BaٽH +Ɓ) %'r=Qk }iw.x7L613%'r23|:FΚm�k'7 6A +%iCZ*&/_=Q闫rv?U+KY .B$Kޢ)I֔qoМq $֑{Rʹ+F e!d +$2n~M~lWu?&ZmRu4+";%=.|"zuHX?� `oQ $֓gR+yUGBB8f#Qk Y9a]{Řۦ:xMxMASd?w,u(w+ذ~yϜ5x>úk%q_7wB/ZrDL7,wo(t|iIl^^#=wϬu.\D&D,fx{,c 5UT^ʵt\{6Bq+tDMD]'뗻l^mPDݥWVrGv%N&3Ǝ/�,whM``Xg?*u51mew!wrD?!U |,z&ī}MW+ rR"6]&8��6ubmvr(UR-C4 +!*ȸ蛬tKq"{Lx孡]bЪګO埔gfuؐ% 'gŬF�g"Z[0�!o RS>bG!_r?#-3QC?R\(V}FQ(%Mq.(cWȳ 0� endstream endobj 71 0 obj <</Filter[/FlateDecode]/Length 3006>>stream +HyPw߄CŃ"Z-"BUUN<@i9N9BB *UjQVbbw;g _&>�DD^&Y:\ B^g} o ʮA|3-~k-a^$e +u\+:6(HkL7�*"ﱃ HΝ:lF&6`( #(B6H6F(NwY蒞V>#!* `?lWd*Apc(⨍*i4[ (]r#'K'aA.!x5xCcmhGhҢ#sB +DP.-7 $\AQ$b,/yz\%Yyq.+`P)y/Qz㿶"C eR|.T yW +Kh.y)~,Jntf%1Vi;Ӧ:.ﱆ J3%g;ШT8jX紞u9b/`(Kc|5ZsjEdztD<,Rf`47]"k0+-$-:<geV0EW CQ8'E="Jbn =P\œX߽fj+mJW+忻(HBnP]8=^{{ynJGSl;Y)ƠNݰDaBQzw QT[^UTˮ$;]?[ÛuD A*6GAQtdt.fj}.C8s(y&Ŝ*֩cG0B =<U-4}Pцd""Ade.c JRxQPU}<bvMAa(˿ޢR+mvWF#(d{dO<^u3+"iyOKu\UNBubȞɻ7nbFEt^NwQTAlgEd_[ce==쏑mdt\AQt8Z PAidPYkv1op,JQzjbNG-']VisNgR6^QxFM)3/WƓ` J9.L xnjhD@W7`?F~9'd_)n( ph K;Lc*+-"ٻ^S&wO"-븹rfF<?#8GGeDEqZ N6`5g.LI=v## +6*6` J]K=3Pg?B}T1E7[J +:PEJU8R:)[vB[j]%>y&u1uFV\sΟ3k sXD"3\ 1 O:0Hx`CcFuV/ lO>2St@OԄQjj@WQyKTq9eeRf3ӂ}sevAnK (v)p@ +#kG%F?^S_�~*Hxr8W$$|Yv[]HN$(4gJ8vvfaVZHq�nq/u$ƪx۬ÖS"g8x}{Ma w}cxm٪㫺k#-SeW/)[p8UOaJpY.k(G%`BR629`9k6, ̘ sMgid*|ll"Ud}YoLmמ(kI`XY=4G10Z]4TUeFThT*HR(}{ +DQgUYv c^Gv:tzЕi=EQT~2 +]��ʽ4h+KqtJ҄9{i*fj <\:Y/g>3~.r2kv1)vxYK[W`=ZG<i`Kcs\ݦDE+՝T~Էmy% ]Nn"z ݿK}DK[j﫶zeMRy])mWrS$vJ__ҳ|z{i:8ݯFaBBъUuP2BL,R sIr<mͥ0ב"I2G<[B6 ~~c6dm5ecL%G}_QX8R3\HErhv{,gn`��fjEdCdG!r2DރD퇈u:L;B/$z<>F8WKzJ#w8Ϛh\BR +7ճi6^Ǥ n\(y{* KiV Ӆy0nА1e҉ +YXFɮ㾴VFd}uf"֨obwڤ0փQ<(?(mLX{T3XMY;bL~r; }k=nTϡ?f-h��fTM,נeEGPWvjIQNޘ53ت+VDX5'[��� zn?yRA kwc6603Ք(5Ƞ}߹���3w%(K?`RDk@���#W[yF`4n5HN_ؿ{��f*h=ggHCv֞H/: hS�}VT endstream endobj 72 0 obj <</Filter[/FlateDecode]/Length 841>>stream +HKa1B,%$PrUQFb6X dS-qjCZtX$-*F"]>q=5�`Ύ!wbjϮ7]clOޱgy^k2N>[3o0��KM_gDZ[ie4/?d|0L��&LCs 0tEo1��K5'7=?J?/+Nyqj�ZtYBCb4ֈHA��pKe?J?`ʌ b~]o3��chC`4q4ȫ��IGdE_4]}kL/A��8p)]n/T[D2AʺZ:; �JdYcԕrwj[85q �ig{ +]Sb"6kClLܦA��7^.L-T1?(o6��5U϶ĺȭ?J?`qs|A ��,ǛAnZodFiw`*l4H��`/]M k7`*=%{z?t�6zB|ߧW4А/oãf�>"3uv[8Bbc&K5 ��Ϗ᣻䎮J *TGIj*,o��͌ "ivS8RrSA#*h��38%d|Lp yc_GJh�~ +0� 1 endstream endobj 73 0 obj <</Filter[/FlateDecode]/Length 878>>stream +HKa]u2"Ha 0 Ҵay`iiĶV3wpnHr[QyU<3yK?I1S\ؒZh2U} 7;,Z8 +uĝ V._�@gpi`A(bYCLB� :X:ِ(-�Qz d@Y:fB;��F4=z5 :,]w��[]C7D?JqPq?�L 7?teg?Na@WS%_�(&ZZ/D?]Rws79=��FvlʾdjbG7H ?��Ղ}mn>j] :#mM] T}��TuN^/= :cM8<�HÏGH) ޖ =�‹e-[#&A[ӣ$x2Eu��kϢ e7?Nan0��~ϗr5U"JlKw2}νڧ ��WSD)Ytزčοܣ��,At +Ft~jidUw��+mnB)A{yVƏT ��žVY EtË?92zdn��`%t{d?Na r(dvP��`җq[zS7k̦ #i[ +0�Z;� endstream endobj 74 0 obj <</Filter[/FlateDecode]/Length 1235>>stream +H}Lu�o< d!6e* qt2HmJE&3ʇ1D rT8{;9ALͶZaZXb;vb߽??r��3Ua8`L-rxw[t\AGcy彶ql^cШe<�rjۍlGDMa] R`xGnWU/�� +wK2m j +, m(hk+# ��79>coE~cWLRl8d'HnN ϱ?)l䯞)��܋Bf[m] cZ^]a= f<jF(jd gJw��wR/6e9q?}ߖDm1s M<y篞Xt��p7.oE{6wSkJK:5 ͕FYJw��w __a}Ga@m[7HiS~A~mt��p'X&fǻA%!ֻ:tBa@9Zw ��=2J\>k)@ U-wP;׊.ӥf��g~!Vޖ4irtB 09;QsDwb1'jZ)9!T>�ݔ$+ mx?NhPx}+8#?gg3&mk͕E6z/L#p/m}Ah.훔��&3r~O|ٿ;A\1cA{YaN폔ûÕ~+ÓYDQwLqҝ�djfkow|?eh(i}7?qϱ? T>!o-)+��L:nhc⊩d:5ˉcŋ5%En�k;Lo{A\1f]Ig'cSw + Jw ��2Skc5OV4*/��Ε/ts j +?-^n5XL>kw ��7Mk_?iw%aټj;�.5Wշw)xE_Sg��S_�T endstream endobj 75 0 obj <</Filter[/FlateDecode]/Length 1037>>stream +HOUuso̭-W+l0 q%V1LI/$[9rcƌR]rkll.ɗ~ȟoycbk||mڬi-Nļю=oiMWŌ_zIt߳]9뵦3ޘIt.k��7;{AT +KjcЯ]��MDO;AT +KYEy57X�uod]OZ+Q),eY{`Gw��__5b_?Ja`u8,C҇ ;�QjM%vlet1Tziw6C~7ʆպ)-skA_߳ }vw m�O*|[ڝ= "fگcmlGk�XF$q xP(Q)�ƺҌȉ 1?/g] �2#?Wv67AT +̕rryOd/-9]8�k;+ZQ)�/ie~Ϛhg}W,32}u:#WQ)� ojBo:o#f0>Kz@:ee~?Ja�XHkJ3}qgn\(^+ unIRGAT +B{h}kֱ;�RQ3?{=,QQ)�f!#25_@z@9W_|xCD?�,ghx2ٛ; +[=� r *`(ߨvٷ@�rUrlwx7D?�Ȳ`)fSUٽ�}Iw u{ *@C۴@48pݜ[Z$@Dc~o%�ٖoЪ[[My]�� l-u8; *�� endstream endobj 76 0 obj <</Filter[/FlateDecode]/Length 1007>>stream +HmheB((՛AEB6VH+ʩhOs:8lkڣ<<gmsg`͕dJ|Wxn*6|ys)Fn˟l:\g6GW�ߌac9Q|ߖzh $#_=� qs(9@ \c{��n'ɻLv :`:Ylv̓hd:7�@egՋS�F׏xw� -w̹Q} :`${p|7Bţ[vU�`\X2SݸQ] :`>Kd}|Z},7� o̓wYBzRT?Na�GLwņg�` F֤ʎX25r_sk^Q/�PٰtڻAt +@IHOy3B[}x�w,{?Na�Usvecr^n�R$'5} : MΜ+>o=vuyM��BotٻAt +@KHOomhlg�[q}&PD?�WaX:K�79_tAt +N&}VZd}X_�*ڻAt +Vl`oӅ*)�F.j) +8 :@WL85M!}n3mQ�uŝB{?Na�لů˞>i[J�Hn_{?Na�EM:l΄M}T}c�?iU}[m0)�WEAgz<ͪo �^ѓk~_S�=k{SduK57�o͖6O[b�8e|\g{[hO� endstream endobj 77 0 obj <</Filter[/FlateDecode]/Length 1290>>stream +HLuAPaJ2*M2a:t'b _$iBSBe(_|ޡBi32Zk/1w_ݾw{Q�uanͰ\6BTҨo8q #c>ZMJeblIZ`xs9yFu_?�0'F9r|U]ù�/QyluW?7H| t�!gsX.ֽ7ɩnl,ˎTwxz'='\�WSR(;3i�^\ݯA<=Uǎd޹cZ�toK7U^iN0|oO'A<9b g*- �ٻF\jTl9=w7 �+6v+ ;A<5~~VѼe��2W*+;'�˾{dA<56=s\V�fd t|bu귙(�cǫA헞=*ܿmq1}�^ci;|�J?O |euC2ՕS?�<my|vmR�qaSXabUl?Di]{eѬh:v|qZd/8"?J(3gW-Oh{�dd p{vbʞ�o�piOMV3G};A<)d *=ߵoZng +2B]�o1}[$nifQwXMYCΑwxR$FM3[� ̘cvHПyw_�xGC O"w[ʝ=�#bڡ 7 �y?yMdg+r�<et)e�x?N(o1?�`p|O=jj/?�`p-99A6*ֶ[%j}�gO7YȆyzA� o~Ӳa]"o�ΗMӫSDOa�HzCc/Ε}si}٫ODOa�Zˏ*q�xĺ[{_= z +C`�C!U endstream endobj 78 0 obj <</Filter[/FlateDecode]/Length 430>>stream +H׿KqowwQgKtRQ[u5t!lHBjQ~TY{[ВCwtScgx'������������������������������������[j/o4~k|N_6��ttt4P@ vM<*$=��{sQ^$= ��nn|[l6tt$<��VթJs'Çwե.Ujld��HչV}-nzIڹ271~1��X>wg==6 ��Yx8S*o9?[ +]}3_zB-IV|Ok vƛq+H n]/$ �6 endstream endobj 79 0 obj <</Filter[/FlateDecode]/Length 996>>stream +HoU+&\z| IcBQh4pAKBSjJͦM)l_zi2Uڷ !1ȝ+o΅H3{}0S@!xzoc{"63|0+)MYli!}Yl߳]?Ζ1:;w滮#;�XYie :�$'Z=Vo�0wd :�d:#o ٪o�j:WrYg?Na�Xc|bּ gjj3�u~;{8ĭ`��򪋖qړs+U@�Ԙ=s1є'D?�@{2u5xteoR ȬT]_su�CNj0勧39v_Z9pݒ�/-ŭ'NoZ&£D Y/?Na�@,/y8"Ny"U'>V~HXV S�L9EMUO +g"F_}H}nt;R%)�*,2ֈSn}5_`2=WS�|3}}ed[ v;~>bY?Na�@>r7W,R}/X8)Ze,\ {S�]r|dDO8wvnnW7wCnzFٻg�׍ +CL4ߦvpo<a(<�dsKTO�?u:�d7M=ce(�wp&wռ"{S�fGC>?PK;w:WD?�@{O8wzX=DleoAt +�ww *d? �d5P endstream endobj 80 0 obj <</Filter[/FlateDecode]/Length 1014>>stream +H}HUw\wl= DA "3dm&:scZBe.fi>sűEi +*ԭEo&c3Z0~y| +qԋXӒ!DSὋ&>q +Bb=;߳w�@lK-Uk': W�YY3#ncv7 :�J,HvˏX�ޞv :�z{bǫF2XoߙKc)�QиoU w4ީoIǼUEf��HȍSr.Uݹ�8>/?Na�,,JGDՖ{n7z 1NdjEnݲ?Na�<-Yl/ EKg/Ə-},iqv7 :�\mD߁MI;VWW>$ݛmoAt +�-yXꐕns'yw :�ry_>i?nrx"xmAt +�d5}'f`N-oZ pۑמ}laQm?Na��jmu[}苁7w3@wSV˛=.D?��v| d/cOƩg~%]y) :�p΍Hwb7תiD3OnAt +�o_#vk7ȷb\] wyߘQ;d��܋54.Y~6KP�yt;�^-+́6)R: ݝgnAt +�_x^V 2p:RPY]{1twS�*Xƹ\=WubٕO}ݾ{c��ܯ%^Qu^#7oPX4:7� +<n endstream endobj 81 0 obj <</Filter[/FlateDecode]/Length 1422>>stream +H]PUa&RuNdMfRڈm^р,"@ ®b1iAB,ԅ͔]gfxa9/.ޜ��Ht\lB>G1pcͭRs)u +-F2AeśoZ6tfnZt H?>{ �keIj?N cL%;*;,z| rM8?tqZMJVJ<?ܤ 3��0QB2K]ko1^0\nEW)5[6k6[yr��&R`+p`gksw;�_.mk'5WS='n<):��7Ya.W;�9j]-jJj?9ƢX6֩V![:b/+kΡ��\AJZ ;slŜ~sb=bZj?9f6]}ndfl^NGR-{9��%$nwMo }?+z�r㞍]-RsLF +Ÿ){j;AJ嘿��a~cnV?Zz3V_(5?l ya363K;3dw%ŮG1o��dMk3<h}�r&M άOu#8 sAo=C?b2kE[#xAk|[��y3p5 |aXI_螆-Q2s#CUS=� +Qx=)tk�NvS;RB4DnY{G գ +xv%?��EB^''�,8~0CWԬ rMKMVV޵0+Q+3wՕiA?��ù!)pwu&R-D 6TwnU< ��xrluIC{iwBɠ[K<Xrp@@|)�� ӗ|&K=#R�mk ė��r[ t)r}pH̛-5/��(<'T5:?/Яc'x#mi?)5/��*85*զڹ0ѺsGl1Y@@|)�� wd"w%O&4#Pj?_ +��Le!,jfݻScg7Le3<XtQ4R?��`J$Ewn\0�.o endstream endobj 82 0 obj <</Filter[/FlateDecode]/Length 1010>>stream +H_LuAQ]ژYm-ڲ0,-k̚]Ձ`̘1L+&9w>'.jsY@ō-#碵I^w~V +ѼyӒ2|噊 X(n~G&!3=v>۽v<��'K?( '9SϲTߏH}=0ͩS�(EQkC#c2NǏcD?��3U/W<v\cw%[uؒ,{`*Ǯ?Na��fʍq#eIs| G= ܊k֊-6g��ҥbo6Ol_\nT_AۻKw7�@\{9+ۿ9W-Ym)�n~o]ZkoEB㿜|p2=z%\N?Na��t4d}gq?J&֩3ut}4G :�YsebuYioM௦RedkD?��پFtu[Ҽ<*^Ws̖G"ƈ[D?��^pכn 98صA ~Lƌ/ :�ޞ-C2tr٪oOMḑr-�kZ >hZ2<1*/ w]2^β?Na��(8Oli?O'"w(iDMgs[_D?��^vG#9Kc'2Uߢo=S)�ߜ/%׆U^R;v |ѭS��,g@ygPMe[?D?��òq4Ǯv=6c-_VGvAt +�?wr?'*WQh`dO;nd��n+Z$JUOZϧSW :E��I endstream endobj 83 0 obj <</Filter[/FlateDecode]/Length 1023>>stream +HLu!mšm4ukZ?]QMIVhC!nvÁ8,fdDɠeyz}{|"gKL\M%\wl?j}>{ǟ^b�{'otPFt]B�c)juW神kΙ>CqؽgU�-ujOp +} աd��KrˌESMP[ +] +6-��wn.ygUwW$?2/ohk|YvwS��ܝJ_읕9cJɫ2cϕ��w/$WVh j4d*HNezu9{c��{f@Wn_xR}űC3ew :�;vs߻[H7H[ۺ%[vcS��wzCVbm\vjngwD?��;O}P(|oЭҢKw\$ucEsd]?Na��0&y_fK혪{.S_(ؾ!SvSS��eMY9]f̚"4?(ː��牪ڵ7XᡛoHեE4?Na��02[ ڷ/v7ȱ.߯RBwSe7 :�@|Pwqڱ_T}S6o?Na��?k.~@}:XO5w :�@|e{ C?uN-W߃=ٛIoAt +��5{"S=KSTwa?>|魰?Na��δDcK-Z_pN,?U靰?Na��VzIrvd^͓$jrfFKSq<q#t6+֤~��h?� endstream endobj 84 0 obj <</Filter[/FlateDecode]/Length 2543>>stream +H{TP@#MZIZ6jM(AV +fE% ²cvIh@=gҳt]2+~|;?cfݹoǔ{ofc71(0ycħǽHO͘MAG}uS*a ^O7~d?}-{���xʪVR6k #W?nhd Rf5:S{H���\xDͣ{V{ơdGKF_hO @(UNJG9"'{UA{~���s2WEMYs^?icB{rFl +re"]6{IԄcؠ`7uWC����D/2ؒ8rV64C̠LoYU4A??ɭ>���Hx?%o߯0_ +?4+l% w6.Ud?E΃���LԜ<?Z+}僕"Ы$O0OD2ޠm2乱L'zB����^FRPrvsZ~f=4xy/eWUXtgz=rKo٧N9_vbvm 9坱e%59eٶlj���l*;=<.*/󹧋9MeɈOCMM~^$L0a?kQ$] +���NxdzmiøuuZ98jsuJYhs���2|*>-\3{j{-sY%ZgyZ#ku#"? Z,9Hj)Ɉ!����?54K>>1NWqͬ:\%jٜ(I~dgQ+]{���  +]cxڒ_R6J,`@~2&fit60& }sMaQ>/+3*"jXf={RQ6?=ܵxDͣbsfKYk 'oj* ++5Qchi.ק5:-:Z-UfU>��0|J[B2bؠ{.g%qB & TȚE1⇓1 '"p"nK5Cm.* uTN_?L \{uVXNʩ.&A{jێdF>s/cԏ"ܷPCSD6y*km{`g ���Xyo6Gc}6p*mQ!`@;9zJ|j ڼe$69F2 ޶&įjYV&[*gt-{Ɇ@z!V,uoIq+;v~N1C?V)H*cX6m ّd( ��@\ݵ"9y-%WN| <k%~Ah-?OL8kܗ,2;5ą4۶t8k-Jlb?Fhk=oھgﭵHi~g??X8ԗ qtB}g$[gGGi.ϙl8d[{b=b{���SCI}cr]V,s%B & D :42%0jǢYJ[!]C?V7LfY45mVo^=2ƜXkLq,HfTD1;ocg s BZE;:+5T<\;a};+Bc ��yXrH2ڬchי8$ 44]5xq[_ok{1M0^1su=oQ⇓1zYk28g(aDm6g\ugjY]J9mDsF&9���9Wr˲ɹJFY(Nst!@Iΐ?槇:)Ĭ>Jƛ +9Zi!V }1騞RQ=u$Oݝ XC3&`K '>-ֶtonQsEkv���l!g,s:{_`wJ߃ɜ=JL 4 /MbNS%* zF*3)'cɉisQB7GXԙ?hW82c(\WIwOEjɆ@@1<ܣ;J3��0cBTӋ>ۇ@z!@I,W�x endstream endobj 85 0 obj <</Filter[/FlateDecode]/Length 3223>>stream +HkPSgjz:jݖm]mЪtM."wb\C HNeN]Kggo{h1uy罄s؏ѱ,^`s=L۹kDM6yVἸ]YhVTe9/McQ&7glD&ypչQ;oq{LHIsH0w`y١0?'-F6HvګS<QRZ2Ժ )ߖӭ )yYCw+gqU<:̚M`` 1w"qjZ-$`jHtYX19Y'HӖ9mK;s]J@{"~ 6iG`Yhwy/ 7B;!;crZk >qKhȻ2<f_TŻ.bl/uO?0/lo, zyh3${p54uїs.~jo͚{#-8d&/kkdfz0a~85^o<ΕږV<>.1bPўHdwFmMVlhWn??I؞/0"! Ç6 +!sc<?"LB?6rebS]6~'5U@kK͊h;(BS];#ޗZa3CbilcɻCsP )ι7`%!%LuۢEo>΀qir?@NPhþٹRF )5*re0Y]j%. /Abb +BD5$.Y{Ժ.d #fA!xYHmConvBhMx%;InZsZ*Wx>7%9163yeZkin+'27$lm)e,VYT)`Zع+!Oi{۱뀗bt,MŢ-n|AKd]457ƷN*'ǚ1wC@2  / S_6CBB:u?0?Aq;ƃyXv#.$.W`+Ǐ B + <̉ݬz[ t7`%#�  \ #6 }Ӓ4߇;wsF[Tɍ`)  2$t? 5p'pn<{B + < k*S2 7j:~s'S@\y?0?AyZ3BVNioy?0?&& h3},w*Wn Րbg^v2\{™onֺ2&XNP|Ayz<|t]rN/ɿN?lrJγF!pU-#d{\!d!ǭ2:3씱ED'eYWU <AeI63yn6dupᗓ&s1 !+x?6'k %NjPދCi2Ojը+ H "-j)hίۂ픩\CHc$s29;lHBq ڬI}}# G/Bxo^9Ϳwe{nGde9E!pEQB5V{ga5'mNУ]$ d{62:#5M9XMnWIYTa3Ԏors$>B\R=nɃy١p}j aPۋE[yS}_?d&/+h kb0?RF kh 㙹O;",qni3jS<΄uekgۛ 4 1Z=b#u˙z Bfk@߄}CAF-p}7:Uߝ| L`)\^+C*vz1:xЪ[:(ڦ;V,2]e46wMUXGNm[Xl_HܑuyӠYy-jYxon,mka]aVyvE,q�no,sZfvZbB<+mSE+Dތ/2c0v-ȩ67$F�X[&8Vw2 +fni'Kmo31iŃ[ fZFOuY@[hj(|3Ag163oA0m*4bizϹ=_KC9OB +WqhRʪ�-=)w}<tc#h}\蛜`,}ٹ-:(ÏA.Z;rfjPbqU淁N~=S6.,A} am4خkW=`~V<�tdĤ@ay9@ջa~71M:Q<G(fϰfHתo[vB#Ӏtw (N`?d m%= +ž`=ڭd,nׯG\Ck_? +Ԟ92m6_qeݜBX~=kW= /&?T'xͪi[׭ +Mkff`3qhMa&~Pc7AiD\n(Y Xe>t3mY{&dA1Hæ+. tţxQL}lۜĴrӊS,і9/x1 +=6 Y z7kAϿKfn^vڕA`T! Pj_uf>ۗω&P$n㊳kfen.Ӏ̃a%jMbl\y$bӊcǺtdc?x>DAvԮ ` kEsa|lVPd&S|ec<#6wW tţxS�- endstream endobj 86 0 obj <</Filter[/FlateDecode]/Length 2186>>stream +H{T'M$ca=5F9R`61$h<0 <<T_ZvYvwve"BD$bh)β||ٹ{{}"_e|"7!7߹,=)lgӛ; +9'vf-[RAz9癞k߽ngoۃ}̵Ρ짤cTmMf+;pEϠ9*͍u9Oo)IX|�X-\ߐdic>wu=4iN6W<>nP=P$^m; h W6o0۫jG}i_ai4vclc54oW57sYjȸc^&qus[ n-jkS��A\.k1\\<KqP"fsvěiA6ʢ'mS e:^drU*9R ҹm'" +RkEc(C*j]Ύ +!f~L[ZJ?{���&Ww>}Nt"k7+JpYUkoxƕj~0mfG[oF~߯Cr# /G4͢ZHe6rLvtbkk﷭ BImtvmQ\0C��=̏ b̵R rϱKyp7:Oߛc@)U>Iʌ[Jgu Qڣ+Ju[ǩt{-Mҗn56ChA.uTmMU6扨Oї eQ].^1h78J4 -ɯ>M7h]~4^?ЙXԙq!\hL*T<.[n���k2iz%( GT9?o'_T  cBS#kF;)l_x]z;{]:ZZj8ޭ8MSa;\7GuN +W9_˭{hї}w7=K= 퇵SY;67htN$CJi,*8<`OTk.Wɛ߬ހ +,J?w���aeFzW}L>ީݬ~M}X?o'/:w�/JS"҃o+F*,yk��s_c2&^߹Gy?l>j/rxS<?Įel5q?UaknPzӍTcZWz���<w*Ru𦯝 )Ir_#\7S̏ bo̵:yҤ9J ���,K amzɛ=۪+Lr# LgX>.RJ����w +dRe"̦>/L4=j&W*<7e:����< ~'la"qirxS����d62vdՇ(A7L֗sě����7IjSOS0}rl?o +����S=s.Q!~-\%gě����Tbjl-`\<Kq<>\Ξ7���Oₙf#n.2gxS����"y#X/{Zah c ����*v0'ʟT+r鈸۫'?����0y .ts{}n!OǶr@ܕEOcT)~ZWst _ +Fh?j3gerc���Ζ<w{Ȯݬ_@]T'g]ymjz6o0,Aw\jUaOHqw+w.==����벟_Jx?3\WqWfΘ?L5{:9i30�! endstream endobj 87 0 obj <</Filter[/FlateDecode]/Length 2120>>stream +HmPT_β I#* FP,$`f* CMC*D :YPYaaae"DIiLFmD:I<Y̪d=y?}y1V_3f2#EE3~ ;Ϯ)MapZw�c>C~i +5q47`K"g4ZO}�"?#ә;VI~RuUqDZqADGsr5@<1TvV~z|/9ÑSԆ"ΙB�`'{憺j +9y&|c|ɯlkDQ7i1a맵8uO,?sx9U4ˬL9#g< g ~%A|s5yVY_w~?"|,?srh.!&nNԸakG5!xp _3/x8 + )GtӟW?sտamv^?#NhfcXu.Uo7jf)Guz׋نk1!xJ5SCo}?UQfg4Z?_#^YĎy9>>v)qK)k77U;TUYK  h6�\BחM'王8u.OrCVdTI< AA-1QFm�Jz}?xv<=;]U&������`PQ|ر>饷, tM.~S0+{+QtMM������9xKvmJ tј^eӛbw ����������������������ś㘴:¬ܟ0f$%,bej\Vz0{&#y^ +`:qZhjrKHBL,k:ViwouZYօ٭˓X喜Q퀙јALvZZx,,**}_K0뵿o;{z3}&}G#OLbSP44m>Y~ G==M�X~0t?|cmKz;zזRrKyWrkYj;s:@>W_^DԷZ˗_3EC }Xl‚!ٸ=aCo>>~|̈́QU/pkrMr\̮SHby'jZ"UJ9ĝCqUۣ7[/ts鼳fNf߀׷2rؤI7ES<T}#* UK>CgGAyԬg(^d$%V<q͌c)Ԝ{>>?-+ } 1K:l?k*ɰRKfC{j!ߟ|a!mFm3.UW#86n=<ߐ݁1,|Q4o$&ѻ24w G#4%{M{ گ\W%X,:trY)ۛе/ߟ|G<um?R$ 2V*d.,<#1n %3 +<mRm쨴q ,u({iMueO9^iI/-^ca ?W|OTҬ�??<' +k:?rm?32TI^z&z͔J8%4WvZ:;SZ0fa¨{5xw"5sp;+~e sݞ:ƍ骷ca1,dɗkW WZ^\e€2ߋd{fLۯhjMEE⵵2><e%t 'q[T:;*mǣ#"-ZC;a/oGZSA@ԋj̣g0ɯiNy?�vi endstream endobj 88 0 obj <</Filter[/FlateDecode]/Length 1096>>stream +HOuDI4T ḿq%ec(R` "$ߏ〻CEDkRkG!c{o~uVUҒ]Co2nn(M%+<o;'[,)nc%q6]S/>x?Q@vm!fOĻASi+/;8깳xYb+WdXFGTQF6k5t4 36*[ˇe$Dxj@g[cWL+ʅ[n;߾e쉍:e0Chɏ _rt]r5}8bJKqQN/?cy(Ϝ/m-g?4cȠ�EO{?ﯪvx^Y6/1V[1[^jkB0u+={/?yD]D5Uoj缾g\C.spOLS:륦'FիI}Ơ~{IJԓ[=kkN ;-Q`6֭Y~ouW}>XIlT‚y_ɽCbbN s4P"!ʊ4Xe2yl2?z~c:}xby[W/Wl-*mˣL2+1/]ғ噥{> m:j< +:mޱmvMg_*sYj:bYVmjwOjdX:jĠ1tܖVzy=*}t#lu#(ڹ w]9˒:fِd^KgCmv.91~yDx15\lm*G=?TZ3h!C<SnjZoU;}}/nYK���������������������������������������������������������������������/`�LU endstream endobj 89 0 obj <</Filter[/FlateDecode]/Length 491>>stream +HMKTap]-BrR$BsSw;W"A((?0fB\Oj0.x6~^cBDR:7ً<4_ھ7R< <><bO+boTT\3˓G}tv?}} dNr/KnXSafw9g8rOyp ,NO?<u}u0nw9g8rOyp W߳d9'<+}xG8rOy$g3�@kD��i>�;F$ �63�@kD��i>�;F$ �63�@kD��i>�;F$>T> +��mIks> ��׹IG{e�? �8 endstream endobj 90 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 91 0 obj <</Filter[/FlateDecode]/Length 168>>stream +HA + �A锶PTy2Bl �����������������������������������������������������`uq~)i@C"0W4#}ߩ])ԮUjWJ(d7}.e}lq/T`�b endstream endobj 92 0 obj <</Filter[/FlateDecode]/Length 531>>stream +HANQQ?"JdCיhUoy\7\7_]~/G>>۽HNlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk֎8:$1#+bjGVN#+biGV1c[7$&nIlMؚ9&5qsLbk6ˣÛY1ߛuY>"6,ELȊ؟XHؚ9&5qsLbk//>EOħxh^6nOO<41c[7$&n j9>2}ditSZ{}dMi~>}FkOWʷe>0Z>r ȚڻpF&}dELȊZ1#+bjɈXZ#+biGVҺ$#bhGVкuYC>"v:uY;>"v}dEȊ@2"f}d~0�2@J endstream endobj 93 0 obj <</Filter[/FlateDecode]/Length 781>>stream +H 0CS`R qNeij�"Z<~kHDr1qf2orG!|Y,F-Ѝ.\Э/0>1֠>2VN}^ P.>| r8u!|hДK\M},hC )'rH70ʽ4އQ>or+C�(>;t—dʕtc*F:އ1rCALƀPIvq]ȑğ$w}Hd ?9>r%ȕj}JNfGL_JG8'4FBÙj'wp'\213Q `:A +9E_J(@'}8˄_N)9U4qvo.:{:z5:Y<&tvq2x.x=FgW{cr':#xӽq?9<�h|, t7g1+g)Ӎg!''gx'SO,ltsAg~&gT9tqFg@@wpg4A=g*WCױ1gD%gWFWgv ݓ3Fxv2t[f�9ѥ)9Fw"] +Y !]誤cr+]:y9A9 5JэCgr.fWr:K�t7 endstream endobj 94 0 obj <</Filter[/FlateDecode]/Length 659>>stream +HNAQ0(8uMM84WYS2tFd~$ۄ=<֠͢U<:6\5_<:_4 |?ZNW~Jڋ-he?>Ӽe};4[i#G30;}a첿>A˟sr}:LU k [Rv.A߃LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Us0^6hsSɱTM!�~!�!�[!�[-<_J J‹KT +|w\]xy(3J`p'=ϤS.iXæ?e<KuwS:=йT=F*t1z0�(U endstream endobj 95 0 obj <</Filter[/FlateDecode]/Length 590>>stream +HAJCQQ"D"SJdɥ7˕<,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t>/ +ZKfRzٟ+.h} ?~6<tsW7>wݭT?pw+7UOЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XW�a endstream endobj 96 0 obj <</Filter[/FlateDecode]/Length 604>>stream +HAjAQmdP-W1xI<O>:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуESٹ"Æ8]+6lW+Uϕ_ɻ:O%NJTrrq[ľW G(;x}¾+O#6+GH#o8]+6lwKٹ"?B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t7SѵbÖ<+[�q endstream endobj 97 0 obj <</Filter[/FlateDecode]/Length 783>>stream +HnPDaKVu &o{~$i,1c\r}۪t`6uIC�'W%R7EROܭJX<plGO҇wnu}zx ?ߖ]ἔUɰ9Mٸ-OЁ) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`Byݦ\T + vMٸrN mxexpixqpjxAZo?%}u 8uS҇Qp˜cxe̟C~׿dtއ$IZ#&lKޮo5ݏei26}i~x]iۿy9~ 5u<)9`2m5.4&kcǠj?xǫth~;2@&>b1:OBq\Es.g]#�c endstream endobj 98 0 obj <</Filter[/FlateDecode]/Length 489>>stream +Hao@6w7$[Xp1u1ےM#1Kp(3 5~Y`07fk̞'zݬ7&x鋵H/{g%l% }?/Gez _%\C+o7wȹ&x}9VZ2ߧ.~n9wXe ������������������������������<0袛O2z2'GI<m'a2a8UNet'W|u+<.:>+>{>~ΛptӼOӷyx4}}rLv+~]n,^$iwm +]ȪNq.m[jhÓzYݩ5}heYɦzu߰j*=T*jO4����������������������������?�@XqS endstream endobj 99 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 100 0 obj <</Filter[/FlateDecode]/Length 456>>stream +HױKUqᓖp),ȡACPDS5N:ܶE("$V," +9p?;\<h ;s|y,~$LJO9W��ײ{\a��/A$=NNg){��;"z#}tM��lD}t1P&��"q��Ֆ.7׈B��T׋kD?��M��6A$��jD?��MIx57;rbY��lDҮ?fe��dDѮ?Nl}uJ��hi^f{N_i��"/>\?U2��2H:o͕/o<X,��"c7>te��dtrϵg~s}N� =j-�� endstream endobj 101 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 102 0 obj <</Filter[/FlateDecode]/Length 711>>stream +HKQcs@(/:maAeEIP6^P6"%3 +[CBAbږsCJLbig(brdGx>��������r lvgn����BIMo,NOt8_+rF ~����uq8tK<:n[����f5l&_r~./7E����T2ןsEcldg~����L.ebw=5CG2 7>����LF~rޱG4����YJ&qv~_+͞b*+*Dw% B!X,rN�H!#N׶j]bd/I!B9V9̟9^l]}a\l)z! +';r7jL3Ƥ:9Mkrn[U]3^?yܴ|&n^˦߻=Ӳ_-9 ,j>jR̼zaћ7c[[<:&Y|G@Gy[26Mo,߅]ݡL}XY}Xgzz`g}t0j>jR̼���Ƽ���Ƽ���Ƽ��o�Z endstream endobj 103 0 obj <</Filter[/FlateDecode]/Length 333>>stream +H׽.Ql.IRUIc_i0D"nupXL3<Oo-.5w<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�Ħ<�ĦIjS��A&%'V[�� 秛˗ڷ��A&%㷽Y��?ȤvpS��>?Ȥә '�0 v<~;;k�A&y>ݛ9uj�A& �h8kda��v>kda��f�A&�@l!�A endstream endobj 104 0 obj <</Filter[/FlateDecode]/Length 471>>stream +H׿KqG/'j)~PC-%8UT&"MBD^G!A!w4=wpO<_>o w�QVw\Qk=��?$|y֫�1HWnod��4-<|T?"^lb��hɻiO ߿}].v*��?>߿}x�ФI'cc}w{�1H:'Ow>Wd��4D>ዩG� ?}* �Db�|A{(�5jՊ{(�DM(͏+k#oܽ~#SX{Y9C9CӚcK +C9C9#ZE7�^# �6g�׈>�ͽF$ϑ��KVy endstream endobj 105 0 obj <</Filter[/FlateDecode]/Length 689>>stream +HKSq i)E 2u ܔH](IFL!V٦õwM[V B7Rюursym @OtgR+e}}gu='#��@נv +ħH��� 2>fOM���b_֝ +2Sc��okк +NN���ƾ-w8R-&k��@נUrsMVةG���72ܹ8+764~���75h\&;M6«3EIȯMyAbϽ_T���kNZe=+wگ|}J$j ��s߽F@kZf|E|\*^ 'ZSMBZ���'zsb8Rs?z��Xj}|ZL:N��Ey^nT{���TEyO=���*IO=Bb&u,W{���TJݤ?`J˅L���Rz7@(p]uo.G��@`Pc`sA޾ءL���4 +z=Ӯ#LrUN\U{&���lʊ P1}&+eqi~C�; endstream endobj 106 0 obj <</Filter[/FlateDecode]/Length 607>>stream +H9ka�1Fxl$~A +E#?uMH634^BDD:`Xvm,^xyS/I��gC/ώ;COV||rYd>%&��zQy\5xx^juY��1:24?{sQ|л��7 ba,>Llt3.��gX,%%OtU]��V>bQW;G't&.��MTG>bQ^XoZz��M<N?bQ{{=svYm��Yh>LZ?z��I2_┟>K_�\bQ?; �$ʳoX늻6� ʱ.�M"R?Z$y%[ �MA,GqJOˆ߆�5A,G_T͆�Ҩ?zۊ][BO�hZ+/DQ;2wgU��jsZAT<\,_ �Y޶]FQ'ew7_ �d endstream endobj 107 0 obj <</Filter[/FlateDecode]/Length 716>>stream +HKSa�SP^D/ЅbT* +@(^DhaFDQw]93(67SĥgۙgdV !IAήi;|?\op.4�TWTj/T/z/6^;~a_]2��jR��sd-rwCY ��s$W4UiI+ t ��+W7I?11WD��PQwsf2e~��@E^H@&q6rS��C@&co[}y_XV���Ռ驠? |QT-#cwEo��P؃5d?38b7��&8V{,m[��Tc .hw+*E��Pd:8י}���*Fd?3& ��_ixgRN^���̅d?)OM23��da2? Q7>"z2��2efik]e7��"z_i'1k ��%X^G>Xkk=&CFz:%z .)*G"xe��T,27yO`y]2eol]2ïOG?~ +0�W endstream endobj 108 0 obj <</Filter[/FlateDecode]/Length 1739>>stream +HyPu.�╅Zx$e r"xBkNyP!)"^,c"v8f4cV<0&k,5;{:_3s;gGѣ7XP ����h{z45+^ej '~n'2_.ki&:b_KƍioPrDJOyP$Z23U6G 7_3w0+m`qr +-HFsޚD)q4M2>"Q15A/nݨP���8 9G@GaKqSuO#|ekm2k`gNth$MqphV܊<P]-VV2Ҳ*^m(Wߺt?z5K2x8����<Ri`SY5_?k5ڢlw{,L#kEDNڳ\LT90H;H=H9H>H|"HF%skL o3~H԰qk'"/hҌj|/ԁslᄻ3gܭoݺw-J] Ws:w7_>s"UsdoWީ]Wm^fuڕ : ;���Vr$:%3Sg)+mOcG$ktQGRDzfȩUisBG���uNت? ?I|G?V~>[EZDtny:Rk$/���Uuʕ:^!dӨ6FUէ{#zI;WtNt9AG5wH*[T���pi\X?WuBRYC95_\%[YI/Zlb=[[7>!uݬ] \71* '���@vR2id4k71gXRi9"U{#87ek)fŽ<%,i7՜ zCN}Bt~U| O=@���XN,H]X}F/%FEzLpN elj]rr4,qk 8XPMh���&glFٳaps٤޳{j9<<!dpKsUMRr5]-7��VΝ]meu5Cp+>ǃ-Qnb,t~Tf5TG���7 麧m6B@<<XZ&:9wEvaCQth���hK<ﺧm4/C@8ʑou95Y +$���Gi?_?{z,2FAn'knV A4h���h \//la+7+u5{RG ���~fV\랶V7 ,7ȍ#q}*>��'mqr랶F{2U&7/7Hղ* ���X0V~1&.l7 TDq5H =X��|nfW4o<,+wnR*G���q0&m�x RE^Ě#ՙm +tPx>^��7`�GČ endstream endobj 109 0 obj <</Filter[/FlateDecode]/Length 2889>>stream +HyPw XS@BZ[- +*KWeAhE�EVĔ@@.rFhյ(Ѷt|fQ VR{; +f??z}B}F>9lcp^m,BCZ+�*C�.dV*xY}3g2é9sk"|7^8zvWi}"LIQpCNɼcGFn z|d0!BiAyS? qt OsO~4H/}IV!s1c~-eܷ%SUzP{4C6t7lrnڹ*^T_{}vFZHݘ99ϟAfH˾0}+6v0,p6 L994WaZ:/+t!WP!)PK|10[&-f'Dd-PJr"eCBkB'xg2B!Z小#?ύ@$C#(LS dī�jԼK2co5DmQ.iȽK)yPdV +P:<_npO6ݴwvg3+JyzimSn(a+9顂Wp:%o4$ĒqIK-v`';l _0v3&osۘ찰1{c)H_"NK]KB/T+/ꭧSEnW|wSȵt5nYgVUI9=V7I:箺.]u Y楿6퍸i|nv}}=&8x$Ή0"BA~7(ݍهm?迱 ++dn/])i;{dmddDКdGe֝U>37v7l1Џ켫{]!}CZ%Z\rH7ܫpݴݗtiKqA>km=5 ?s **!-U/}fVtVe!68!E{"{2;vAF(" !6{l-�kTJJz=9jߤQ{ +OKM]ʩ*G3/CvB_��]@V^/i�ߛk%vKxoZvB$oo0=BȐH3Ӷdװ?! +$= "zEB?._jWCw׫I S{V*巪(A+t8/o3;jbd<6γFtrB-'3D%m@c`ftpEr wR�R_k;R/ʁc#߻cs>pYI٪T/ǻxx9IG!Qqs?! +Ans^ +Vߟqo�{~pQ iguT[;?B!NOWMȐ` ݽr OT<6av3]t*Jr +Oz0j<0f0~ b|D-@cp)TR;m 8 ^L[rAHΠN)i$zmYݏBCB!Ub C18cobq1iAp f2Wky<ꧣ8>l1oL0f0~T AtF@cf|R/1gh:�`qW-*^r2ĆZ-t&t?:B 2:C#(@cpgwJI\M}#�xoyRRަfgF(A!4�N%M)ETdH?l܁W,9s3ɂ7@u}#C74\}Ϟ椦DENiadD!PS⋉EldH?hjeJt:vk۴8��[IW6%Y=Sn +sr6.#oA! +*Nr` CAزXr4HK"]0F!Jfw&{q*JziT*uք=`w9|8ݏ"B/PRȐ`;IHI|oBc#X =ݲɝͬ ZNó&AN*?)q9i5kN`7fB7Jz%F cVZ٦8o(�#zQJxjZ.m~UO}U\u͌Y[[,:K|\,tDG{*`Q@Mg;5?Fp}m^q 2Q<10Ne`|?&<<Ω]~?A,;{ULX;L97W<)='")ۇΞȘPMAYZA\@}Q0 +F(T�W|hc '0<X9ꃜ(? ;S20\bxD[uL t%vMyzӇ.ς׬zo.9o{V߸s[kV͘tb؂.m-'TUtK fd&&G02;!. 6 & : * jr b b \\ l,,]$Q0 +F +�?,w��E* endstream endobj 110 0 obj <</Filter[/FlateDecode]/Length 3275>>stream +HWSwCd(7qk\z"V(栀,VE)RAApIdS +ĄȒ,Q(=֙RS 3z3K}?�̛e Raà´K�VxO TĿݓPꖥ^��A��m�S�.e2]WsfOk,T6> ^1 y޽3XTdБ_U~S®Ҕ/XW8SF +%⚴#/+K  Od/<䖿?}NNcb"#oeD6֢Űl-`dR#eV݉-?F4}"wh;#O/]d|J^DQm{w4Hv'@'}}ɿh YOd )+.29qO/{ +*Ѵ+o!JΜ+;y0/}yھb[֮U a5Lk + :k HUK` tf7T]ut%SP}s>�4v(a@ YȶlZ5E%y )~-u_T7WvNR]&!2xǎ14֢`7 >+Q?8}%?F>P]GtKD]o*E?r<��:�\bbs-|2>SB^m}J Jsh`2}}O ohE?]cdn/ꈋR!_O.BQtY1@p#~:>=gpAEJ漦VRxS'*؟Od1藍#_;ux_ "O~(}zon)sf:=JL!D&~Oy= e's8GX&E<\T-yk07h[Ͱ?]C;OQ-TDMAQT|OOoc tg4_jAU(~<=!1d;w*pC&곆 :+kFˍ%?9Tȿձc/HYLx$p2P|VFܖdʾ{{8u41"& vRf :곇 Z\'F̉1@t rn&!zi~(r<j�� +&ι Ƀ<;Sү4K[/+/-8\>'q=[+Wi gAF IfGc o3Ԟ!i7e(1'^5xseȺAEJƵ<O_蓇9+:E|qV؉7X v0l0t'lbltDNE%AZwR/PE^�5�#Jm;jy= 'ª{/6FۖUdpIV)a!^>4֢ŚFhS H?el@t u^h[$QoE?5l'7;%3ְtJ8fsϵʯSJRWTQ\B +ŁN&%l @X˜]&'yQ0~�K`htV 2dEQjy~��qír`2`yTU&WW(R˲{ +;eʾW5˯RyU*(kosNdO dadpa''Y1K 7 o +VjEfXjZf0tO>eFDߠCFD~ u#(f/@M�vƓݢ7L~ u&,sސ"dPwL`g2Oi(ʯ +c.HZ[*KS' Weo,z >`AMzTmLq|ht%Ke>ك ZL&`jbFGch!s(0d2;c`8Sf6,&N`4so@v7q9 mgÂv&]<:<gXZˏ*)?tCA4u\!%[(Q�@v�.�ᖹ;OTf<>bc'5*[<Ws{wOԃݖ|לP)^aZAuܐ +*/In|UiϩoTg F""*"*+хBJ-gMk9Urm.wa[EYh+m[ifp{OWPz!CP<&f}EWV\IQ胎py}^tmT2[\zLŒ(W(rnjd?G8f1zXN+ZXk8'*=Vr\b8WQZ).cRYZb֧uUh ++Y^EnwH{tƇªч9cA.�s]c9raPhK +w2[1fΰwE#>|\7n2k}̾.sXz;-i;qa;w69,.["{P)R1J"@gzY/-1+_d =xūziI6k`OVQ<I+3't6ӁO|-A~Ζ;tpòqϒop5fٍ&c/>{Pb{ґou =_ CWQxQ0L>4}<]M6 +'G_��=hwIYf'L!�u�5A�w=!|Gª ^ l(~BBA/fG ZMAaU?*NAݎR%pIAq}knPkp~ajZ<]y9c?؉؟[Ww;*A10[O.`BVJ +0%x>!/'~r_!`/kbh4Rq9JAğg =_WwPk͙2\pt{C=<B,G8vV55 e|A��7ܧ endstream endobj 111 0 obj <</Filter[/FlateDecode]/Length 550>>stream +HMKTQ�;iQIߴ0EJ"j=B.%$0HefeN9*}ɨ];JFXM Ϲ=˼p$�spDkb>�FV��ao +� lY".;+G}Ɠg;n67W{F Ur!r!.d!r!rvɁ6X��� lY>�M_#Kg�kd �6}XhjZ?W^g�k`O�/} /ݻsi~_�/}KM}_3?��⦯�kP9]Y_��F4ƪ�kکr��qQͶrKKrٴ%yApq"}6{Pii?I��_iZ.gu1v]kX_ŕ��7q7�UH endstream endobj 112 0 obj <</Filter[/FlateDecode]/Length 1132>>stream +H[L[u�Z8xD/lΠ\p0 † (%:6 eWN -PAp�[28;|ղvNNГ?_9E�+k.۴!]!$S* + }c1`GWژ?C{6쾿O_qK<*�;sH6I0Qo-ZB''&l=#2l>hQw, �qc?ZZ$.?yB\yp9f2?W�\^`j)k3~<n8Q!{GdI>'_Ϗf\;?[�@x Uv:"9uy.G43]-ʟ��.MB0Qo-ZB''&#e㦰-GCfLűJ+cuU9 �z\_wG\y6-wԶ‚xX6ny~$76&{i>^ob[odXɩ [�� od=Jŝ-%>E^,JםH^w%+GD-4��4<Un:L05<'; KЋ_}ߡ?Nd⸧3]��t/E:}`}ͤo݊57=M3�H7nMy6R*E4N ��('!)Slkg='&ە?{�T>6_lM34ޫAq9��e E-n?F mU r~ܺC3�HsK{`ZVx';~kA��eǵ}me/;`ZyFLδ*�)?qLK?p'k + 2gA��X}-[uOMw14w#0F4lq�`uYw,G։q?Fne=hڡmʟ��hUWR2NJ;`ZcgWOA��XKVS#_CKG�l endstream endobj 113 0 obj <</Filter[/FlateDecode]/Length 866>>stream +HYHTa1$C0"A(!"Q h*2DT&BӴ\s_(,ԜI3K#EDK\ Mt̻mL~{ΣӭtuYO$nZf\2}3#:ZGuC��1:Hṵ{ma`!o$lf1i��d:if̍^#zAd + -, ��qV2\",FHI 2ԙ�683UoD?X]isX7�ݰQIq] 2[&6՜ �>rVFqgD?`+ae[-Yj ��,fS=ゔe-{lz �Œ>u5PAd +~;Cԗl��o3h neR(O:A ��G^eR&nkOM6��s7w*PtSҩ"SXJQ}}r �LYm>eRWfzٗ�`vڥ"SXv;KM�MXb/=}hP{Ad +%*{qu��ُ 7j?La`95z{x�55,j?La`c~�G֮LSu[N)hP'n|o<��f3EM)h%`_1g~�'Em%Mjg?La@Kj +MZ zz��ۖUj_?La@KN>{E NJG�L endstream endobj 114 0 obj <</Filter[/FlateDecode]/Length 1021>>stream +HLuQnrQ[ӭb :gM˖+F)&:X`"u#$vcqp5?­96]?J|oi}Ϟ4t�,HS+`!U=q&7d'ޱx]7Ck +oN=��4験`:ueD\��4`{iB4G=L"9�P|3@H4V"dWf\*x[?��* v_uil_K o���v6PF4V$ײE��OC yXhjy}޾A-�� ^ʻ|ED4Vf65_ѩ^R}��p=];=?N?`u9Om; š&��0% /[H0FD8m~w��\wg?N?`f%[Y6��02cby؉h{h Yio��֗폭ULBQp1|f;�@, lEL# ur μ[�@포L+ + җ��¥qtyi,hQyHQ}3��_>h6X(W4u5uw{ǎ{?M,; !Oh7>n��p?4/4/x@:Yq׀˒7%|wѓȣ̟st0E1q1ꓪo��귎o33?A9YqiD[ו>6B4!OxZX��^\m@G0;m;t(sЉ G:X�ݺ~t,rӝFr +0�jt endstream endobj 115 0 obj <</Filter[/FlateDecode]/Length 1169>>stream +HLu�/!DZ`T,ԭVdYn +ZRLo0<@wHŖ[?`-lK+k=5ؓypуl?_~ 0C$̚ĕ'5MeU ߕ*ݲtQb,K)ˌO �JφXmniw!9DFڀa@ r\s;s��uDmʦ^c#aA dum{Ъon'%ةr]�@~"nݳqdVAH#M]#.,0Aߗ=1j ��m {]fA:1ˣ-υ#2<ogn]vKC;efT[=e#J/ފUKw?*}Nx{�|.f7NcŘ訛EGY:޵"633#@oE`!ܿo��g{v{kLe;A[.Y"Zj6ίN7sU=r{�:.d1rC;~F(=~CsADn8fnI1W�@ +pھP,xlzz%�@~<[Pt);A$}9)J~�z?)>Uh)IDnt78|Nۨ�Δ4VDKa@oּ]Jb�N{jܖvew?Jw��gp7ؔ Z +z;MT[\>>]�N@EJ[?W)Y!¥3��f ϕ(;AUsiWjh'T�@ve.i-Ph)Yd:Qt9#L;�-R^e_?=r(;+9.^<Xv��l*OU?Tz 4swU^R@o +,eO?�RET^s[+9&=nS@k|N~ʞb-%"(&Xdq/LFOo;�: endstream endobj 116 0 obj <</Filter[/FlateDecode]/Length 1039>>stream +HOUX0ҭsk#tHZ) sJ2D/X +6vU\|)I\f ʭXke[Mxg^F�"`#ciw:Ylz;Yk;r(gFqb%;$; ٣X%k :H(xQl)I<2}A'f$lW@]ZJ{ײ?Na�. r*d,#xZe;�-8}8ޯS�"ay[.<7*Q@,wYnCR{?Na�Շrfx۽˽mϫɚ3B#.e�i ^͆kF5L<�8Q[VhB{?Na�9y)"bɗqOU�4ww(hZ^V\0};lRS ծG : $*Ο%ǎދ|�poB#x7D?�ݤ+qjX�~(]H,{_?Na�P)v{:&{hlb(&?�2R'ﲵ=ޕS�TK,\#|!��٧f.\YgI)�N;Ln˸wlw��D۝ wFYfX??Na�peb2vp-�?/.wB{7?Na�pTQ9&7vW� unX,']a :^*NL_橾 � n~VeI{օ!�'[RQho<%{�\%.pMX?Na�pu*uZ� ;]6'/%D?�ĊG g/xotΗ�`=P);nj?Na�%O^խkdos[ �0]_1SO@�. endstream endobj 117 0 obj <</Filter[/FlateDecode]/Length 1061>>stream +H}hUu@h$8$k6[%ukΉ ]n\{{;޻;7{76pes&R$ _;F8?!"ne]-M�@Fl*_USA B87�@}VСJ{OӴ{MI?�$r*a鼶C~�;CtIwb?�$EE~&OR�`~9[\a}ױ?�4(x]<o�6}ϱ?�`l#IQE7Z�&+MI}?�`&v!JTgZ{�0ScuOPmb?�Ѧ}KO}4 o +�S5mnLa�0E wU{r2]�0;jU>c3Zs:=�d(xPY21S�RbM$o �7!}?�` +vΛBW�{Di)�VWh{ �[꽺?PU]b?�X;Uv1vo�ѽrb3RmXE*öBw�k=CWb?�Xق[ABy�W_S*I4O|G�[)t%m_7�kU[*;A=S_QEe�,ݽAۚZ'6Ttēe-Z~bxOxCi}IN�KپV|>U3A#�c&u&l̚*]Y1�I1/)ĝKI�+q9}'?HfAr蒽{r=�0{׋#Aa#,mk}ꊞklsnR7)�3_ endstream endobj 118 0 obj <</Filter[/FlateDecode]/Length 1243>>stream +HkLub԰b>(f[e̜xX-] 6=a x,P(˹ !MJxZrjj�u~2;?swz�3E->Ud1ѭ9T_no�;Xf½\)F O +BBC@cg)5˛l{,Y>ת�/ wr%e;3G#;A__=蒻Ca_V5ο�3f+bGuG3U^`gٻwFGK礄܋aa"iҋ&;:ߘ∣`Z~N/c_1PqY?|T�IxTd߶c o�p.gl}Wo2y?H eYJj-~[w su�/夅[e6'$]�Gndý;GiH7*JNhC(G]�?V%mڗ+e^jw׾~ }2wy KM=>�#㧂7 0yMb xEw �_`ɭ92$e�k&Gʛٍ}:A� bs,;F%�#?ⲓ}A� {>:9.7kU}�>Ad1Y3}zA� g65~ZQ:Wm L7Y$Na#�hO{;S} pNK}1"cO?��\ .Ǖ_#T8�S_ۻsܚKGHa�e'2VӾakwǪcSCHa�>Metn[֨w�:f}9.)�ZrW׻.՛ Gy� [{A7Ha�5KXjJ8S`3[,Y`#�j<1M.֜͝[.W�PS9kmz} F +�2Luz3W}PF:q`#�{5W]CovB�֕Ku)� SO7ik'\ S~:廭uev~��Xl endstream endobj 119 0 obj <</Filter[/FlateDecode]/Length 984>>stream +HOuQ[ζn-;֦iXc-Gl: PIǒ F0ֱ3MB~=~<%ڢBEtQ7Mwe>yǟ~x~_?z:x��Ǜx҉ykŗB�ѦQUTOS}M6B=�{|5lݥޣ]uO:| 6�sӼբz L}G�ގj?`�m@,G :s$�T4pm۩bS�0-,5"/|>_`+]nCKu?Al +�Ǧ݋dryI` =?4nAl +�KE{pԝ:s&�o NTAl +�ς*@Z=|wp<R<�$}8&?ynxr*æOqELݭ?Ma�@b{rh9-=5V=|pNJzyW˺;g�7t ׫-{s~J;3t7 6�m ]sS�;OFjnAl +�o}@7Two4߫�;uf [Al +�^FlߧOENWW�jĦ?�^7ŢA?@{3#o"-?Ma�ݞvկtmk0|w#fdž*Al +�5%O:W>4߷�Eݤcپt ?Ma�@XWWΩrk8{`?XVC#e�䲸<K4Fkit#y.Xnr]]QnĦ?� +Y-jεag4 HfRU[U]Y)?�H endstream endobj 120 0 obj <</Filter[/FlateDecode]/Length 1201>>stream +HLu/CpMkٚ`D+ Xcd!& !"ɯqBr`b0T_A3uh={+Ph*(kCbǧz+üjs]Ɩd.SB<==Vr~�so'!B|"Uy F Z,1b|WsУ rNDO��K>m3qJ#c|2\ǖOS�;^Ue;.o9ˀf}.gA�n)|U|6\j)nX л�em[r.DO��\9Yk'�=æ0eM v9?��j^@(~|'&nٸN= У[duY=�V Q[\cw5@oΧ&9=�#-^:,ė}�=ٷ39_A�`^HJlզv~Bٗ~ooǗ9MfA�~%!|Q[tdw7:nnA�Al-ҵZo'@u]S]ڼ?B��<g…S'wdұ'&B=DcJ[]mDO��`!v4~jgiF;4s־ ԗ,]ˋS�`&% bl<>xc*|?&!2y7ǥ­)b?>l8_3�LYo<+ˮ~<oKG"٢wcK6KAƮs�I $cv4P3w;ݝ_8X6W9N6iϾô?��aMvISz?]_zٹF A1VcyaөʲwZnhsRR�0[H^+5g*|9Z=pGg-Ճ-ejD YPFYޟ$2-xJ�0$ qeY+jvRA]p7g.W#N:dӘ^goYxHŅNr`p;�\WMUުZ{v`� endstream endobj 121 0 obj <</Filter[/FlateDecode]/Length 1253>>stream +H}LUuÅk.Ԍh\FWWPH(hN2(TAx87 ip(a=@>�=͵UʟEq +](O(|)cj?yBd$r}Ќ Cy49o8[^y1Ḵg1z3�DJYw U;=o77Xatv{fC 9+׬j=d2+~௞.v +�`<Ks?М߷={~l-.WjC_ĞF {X-Ǽz!$/g] �`7'A9hoqkj`W:[ESeT.;/bOOڇW1>*䝨m2� K+\"ϏtM25/ն~B ڲiC[c,jԡYO|(�|OxBsj3mMwAZ]xj||쬐jMGKXu]1� f)K]Uk`Uw;B)�OPfq/u5V|ڜ$7&3~l:{٠#�4梌YG]ӭ.ٟE3ddj4?eݬw&H��<QHY)m:dwk|ժ5D`2Gdžo;b?��j5\ɬ)TDү; b?��.z&Ky‘eD~zgA�`*=#FyV* y8{#0. V[}A�`l*XvWΗ:S%v=kқ}1R�&dVMGjWbZfA�`* +J[WwOW;K/?B��LU~0ZkQ?;W. \_+vL?B��Lu;M .]l_*{b Έ֝q1R��#W-mo6i J`<.s*#�0 +?kXfM={R|U/}`%Rb)M F +�`4K6z~tGlwL@`snv;b?0})�J" endstream endobj 122 0 obj <</Filter[/FlateDecode]/Length 653>>stream +Hk`�01/ +<xPP]сQq![(ݔkݴ6sfR{͋B54 }$mG(:^2 .HU=tX{/ZF��GPtf~yK+w��`}̑ZRk;۷Z ���1C@u{=���hj<9H@= {���y9*p2K���Q!? +?fVU���43YQڱuI���oYzJxM���+K@~DñK7��n.PމQ(;ٛ���P7o>PE?v<*{���r"N~ٳ���7?PE??G��'o}?`a-F{d��@T쏶'DQ ���5ea/PEsܷGa-��WTyw= ���?B@ql{7zeo��NjZzeo��*;nY�o!�KXa endstream endobj 123 0 obj <</Filter[/FlateDecode]/Length 987>>stream +HKujl Uj +dRY, +j ÆĆ\VbvmgzrΎ1l:ԋvSФsQѯV{x~?9bMI�Cm+ɗ84sub簴/\vN˛7+x=Z��VZsǐ΍kٰJ r*{ �0B3J{tYa@ O8ִbR��?qnyѻygOܥ<?}W?Ia��d{kdtvTF{}V%bR��ٴyawܕtUe9?(k)`w%#Ue��ѺEu9߻Yw?o89+�Ϟ c}J;so:ݿ({d-ez &�{D8Soԇ?L|#UGĤ?��7抪+7q1OOTK_O5%:WAL +�_mkܳ߱ΏH;`ݿ)w\c<X%��uާđDw/OԵGQaT<<}8񺪓bR�� sEEWڗ>wͤSax7ue>?Ia��)IX_N4se,_szfz &�Oƾ`w/R vlu"D ��mmVQ|{ӈ3c22{nfpet:Ҝ��_nmuVҚ\ ˩]\i_|;wbR��\*}?)"{H;JUĤ?��vkK71Ǻ0t?ɕw &�?ࡢU~k|\:k[@?bIG?Ia��Z'm{ٻӧBg� ]Bi endstream endobj 124 0 obj <</Filter[/FlateDecode]/Length 1314>>stream +H}LUu]/5цMSj%[+sab.-*A,MB$ +X3"*#g.^8WED -gsiӪ͚fuMˊ{ǻg{m=,LBUպ<ݗ@e !{9Yk��bwo}@^:lWz.1=A)��γQaivޭ}u'U,¸Z;xS�� IDmb~=(vL{.haL?7�{DHѬZ/٭W~P&ua<'axS��S"DqSu]Zw;mmw^ls6/'ɬ7GM��^3:KkZ9TU{pqgPuIoěB��3<ϮkSmWi|!P U>aiY>zC ��3>5Ll,'2sj"'md xS��xVbMuLw\{0mﴇ=,d}?7�r̎=ʙC/ ~?07XƧ +xS��3n||v||Kiwbx΍Ë&i_՝?��otT=M]; {1<ώ=lDlfħkGBdk<5.ެw�1n]aRSZq$<Dn ՙ0Wg1<:zUi |WEE?PmsV7L;G��F~E|PI{pcz/U]u5bmΚzv!>WS��c[9],bD^l=n)W3A FLE^{ʼ[l?��0iY>٦ڮꌙ!{WлٝYUq5 bĬ^creo欩F="RbbM߬Ըx@��WЪ9bqC珮r?QS1#7.;OJr��W1ji+.7chz|FiWA<4(w&-a ?6a"yzH, +=s��dƈ*Gmnյ"bϏT+MqWAܝYO:A >9.-6K߰aw}Wi-V˗=�#0)T|TWgv싗C=N Ψ?li/ɞZS=ݟP{1g`�*[ endstream endobj 125 0 obj <</Filter[/FlateDecode]/Length 3038>>stream +HyTSW`Gdd8ZJ:cTRAQģ.Td3aa%@B Jgtƥ9uqӿ朙szfÉ>$h=w$wM~WJZ '4wP{fzqlu06Z;Mhj`#P,;+Ki^yt}>71ɇ>!~13\.EAd>+BBhK iŸy\Etנ`2I[_yLУ'{ 3 LL]E[,DK.JtFFεΦԚe"gc,#ws|c2J%!W;8 EMouƠnu522.UX˖N}^E.M۱ B4Y^JKYy-׈cΛd;h2UkpB_imx~RZy[;C&$7kNOPy[PIH(*EKjUDrR4Khj͚+0̪*AVhxB(Ff%xXr8֬>f/ DA\Ä Y9562<7J gÝbG\>WV3;j֙-{%iw0G:Q,vSUZK?_e $wLjV m_kQwm}&g:\ Tzu$Lb +kd(*FE,-2@  ӽ{ ~u624}Ǝ[|]sDN1ZcMIiUwJ\f=?G=ˁG�_.k-DtțVyf"J{?_۰o + >Gُ*V*9Rd+5H27[\0։Afeufy XPݱzYNNl/`STU] >m0$c?$CQh |j_X`0Ōw$I.)0>Z; 뎤 l+a3_IhUV ƧiʹR @•rWߘ7.\?u[# wˍYKn+_Ӕ7۷N(1#cS&y?dCx/fIZlk|ʾ_(�j,+a˕Rtlo5'vS?N +,L~э9SB<CRkj'z1kx @Adݑq&3̙SfZw#O9mRnp?0)F�irl]oVnvS4zsxVjm_ߜl/;j?1<>*\ 퐪vי-y |a.gnwS?̳pPk-$ |Xzs>Zl`STVvƒgc +k +)궵AjE16Urƃ^v,rJϏO^ٯ4_76CQ )2 e o,JǾG\xym 3,Ii+_އ ^ɜa4 +G~t}CN1/79蚘0hf49پ_d w",Lq4^EZ y}k!UơE7L愗Y{0Bk&2\a62;m9 HY]zsO\T@'t_?0)Ƃ~`1Θ }?lʛ͚+fjS{}8qQ�XVѽu͉alIҲP{6wJ ?/XkEm5G ǎ̵%X/H} 'KU>\~! c8ky iN7 Yѯ$%s wQ2:Z0Olcx@>QR2]=W) FiD^+t0?h{PF^PVv[ +4 +ԀZC{dC_  W{%=Y +7OǞ™ ;h֒yi⠒8ϰJ3&ޝ\f=3#vߨwaޱNyؚŮN,Ώ"&$>E{A1ެž3Y uU3gyBS�΁_76s18?{[R\~! ˋc=:hO9?bCd5n̙l`S.m\mjݔ5}k~Q/j2}kYچ.5űo.WY:CU Ey,p1ހQE)5�6NZ~4}ȑ] +ϔ#c]8[  M F % Qf ؒ( jZHK驝F/GQ.?4֓ |y^kCI'sQc9��G(hwƞх,1Z+٠`4g9?Ֆrf7k ًzCSGU_qiI)ٖpz+nI'߫^od"Jޣo��*1}$dJ8BuL?0j��� = ;gt(VzFBfm#y`4���PL€h+$9y? ۞7 ΋#A���rmR@&{Py`�S9 endstream endobj 126 0 obj <</Filter[/FlateDecode]/Length 3423>>stream +H{P[F[m$Q3VѪAR +9*oyxupݻ;X_ G[5&>bf:b׮;d;k~?Nm!mRiK ]7:1^zAq2;;Xf'-YP~.G@@ACl}U [Cc,sy < чrCp+RC`32V<s o +AA;"ZA=8Юj<p,%`.ÛSc|bƐr&[D7{hoGi 6Lޏ{em <;~ *]W +߉3ʩmCB 619Y`xSx-tW4XrN=.p]}</ `pm]]} <+ɣ ` w>2Q~3!PI qy~ !Sʷ1x}(1skZ <?T%)꣤=lwЦ{uuk2;h㗿͊r,XW9{w} gDퟝ˒ddkt7m٢`xSxэJz]:sNN 6}7Glnx!W_4t\+Scjv1glloo˙ sKavBKc^^ۏ0m);Jnr%T%[߬5%iLl-6^.}:̐kM6 $\뭼 O_cj` +c|o˕I/:pF6rz*W8>`*5&+9(%l|4Ȓ]Kuzg<:kNƤ%&ܷ  -`Xr8VNT%sǛ)7'ԫeu8?WgZugGŒ.|bd v㛋~}7"m gSS 7??G8vQPsG}R]j4 k֗.j{أ^AW|X3~c~3#cIkVbVnjRL\dT%X%\ T[Z*,xYnxgCMOY $~�n3>y Wh4U,3g3Op0t0.`Z4is" ^ٶR[JƸhZ'}i|IC ԝD4QPfHV j IWR}/owm黫ض>719VO¾]6P;Fsp?r a^mnu|)˞Wii)Z֩fۚ9ȃk76u6ky޳b8sJF𹟧>7x^*Kҝι]  %[Hū̂_K$=RrɝD4词[(OKg+@*!S#>^+17gC=ͷ}(LV4\<6މ,~c|\cC ʷyPt˜hϺ>|.|b;Cc;scJZ!\|,0g}sߥ~AOa+9}O~sj<~OgVATk |lCTE]$]]}l>Fza EVziY6ߟ'8\ِ讋;p{%΃||vU]Np+9o+M�Z8Qnia<cz=8 kUm|{߃9uU +c|ĬCAaT ݴj/G2cUҝC4QP搪U|hl#QZZu/0 +})La&QPn)l!F>`꽊7n~Om.I7PfMaA_P*KR@llXZɩK(67g}qc+YMƮwH! |[c u'̺jusv�JZ!MK﯍3u5vrBƚ&8b�5k1* +bqF`zڧ{Q!KŶ~I yj_CȸPJmd =2:_wA|Ghm䤃1e]@ +n9*mFw ÛiC+skÒUC,Rc.zovvN?`̓^;{W}q|\D#/?M"w'/~{+o5S lp6\&,`֒9R{ øPJa5ծړ}JWiwi`xSxΜ�h`'icӉ /0/�CF() +ER +!eFͲmhDZsymmS$*HVECw'Ƚc>.v>?,K>oA#6:}tp#Hv9�3 sB߳we"!X碷MyчF/#@*} ~5!/8/ ;z$\qWtz} A)ݦL,I}[vb2# w{!uB((E^d3ҧkroBH`Ji0Խ-ʓ0.3-b-B{uvU4GAe U8.rK5r7 >#jC2䕑q6kG_z [OW~ָwq!|GYޏm6\Qͳr[w v +񬚀sInP r[[*p`S�zs_Ueu@])Ͼ՟PSv. =*4sГx}?Xi^Cs֤XH}?0)J?u GfݦbIg&ܫ #Py(K;A4ht*lT2s-mGXIs֫-.ŠJ{D~cIx.O +9_ �CD endstream endobj 127 0 obj <</Filter[/FlateDecode]/Length 1412>>stream +HLuw)n-h A +q0L�H&!PB#! +tzpw<#/Kڪ񅱱;~x_{{myEj0��w<4v&|{TKȹ($]{L_n&1}s{ۚz*z���`GZ(9~v.CG6(讟|���VL&ݓugXN&S&JH)���mȊ"t^{;qrqU{ω ?)���V:#;US3eKe ?gT?"���,OWtw[;Ē5ebH)���H=OZLaj}{G9UV1{F@���p43Is4(Ƈw%ס_DJA����GQMNWCFab!dA"��� + +Otg+0y]'f���Ty?oewq컅2fǾjj1{D@xlcC}v06ܙC J"X4`4Fk󶸹|���pt{N4ǕݚnFsgGtkb+aAٜئl(7=FzNh~yIfFt![���RPiWº_ͷŊ+<]!foB<ݧ p9g6i 2zO8P5�p΀32ts9%uǰZkWI\̾?? +bwUs/H0vvk<*/+gp%Ћ{5 2ƐI21B@XVWk愈ׄN8|I9g4n$eBMߍ_O'Elk!�kUQ}\۰Ep>>s9Kx5j:ȭk^Z:=F \.|?cbWkAY\S]58|I9g<gM4(GT;\{k*Z^?$,0f&7yXo^ QX\kچCB$lt5zYpƀs=/ sHra+Mө^u1sf=uאcVPXo+MBnkBSCAF]km]I{K����X܆ JL<7^3r c E;ZO |7��'�C endstream endobj 128 0 obj <</Filter[/FlateDecode]/Length 2393>>stream +HSE.^P+uEVP +e,H/h@!r B.o4nl:Vy$&~fΘa9'}fGmCL,Md${cIkNNސg<ŒLIY`i����P\wȯSvyPKiM=S8.6,t/:_\RUZHTh�����`gژe_Ma}-B|<?SC*Ŵ�����������������+1YyYW?5^h%'zZ0CR)TR@'oȿ}͑=. a:)UTWm=bήR5Ϻ(ke˗YE)2t)ZkHc2~><mk>b,2v,hR[/okVb%q۴vL'icqQY(k˿r,(3߽�؟ }nH3omc�;]j4;lA]n+;9IHt_cOWD* }霢'[Mτ!Ofdr6Mi2v,'c=1?bV1NKxt~ɷ_}pm?lꏺS'b8d ".j&q7I%vW:Ėsp3W&bdGs>;mq>>--^VTWm1!cs[vG7=#cǢSTbhQn^P=j<>Mǒ>W>Sw[;!cp5'B;˫9nno-(3 ϻa^:AuMFQfSQh gdx4ׯe Lq$Y<^l93?茦.؈A8kbAYZ sJ6Oke,uc-d#/@?;-zcfQNސOcpwue~^^,4p+?t]cݩh<C1̔R4XqLLjA/ֱE^Fg 2g2R雛J#BBuPż`vLUsv[#+/ S!z{rh4/b1Wmke,C;{z?|=g##9k.&f +au4Z+?}KZ&v:?kXqԠ{ +q 2grW6, ϵsl1/S~*glxRI=ݭ6O0!lĠg_{K;Alk\X_j_Vզ+~]2?(s]dTXi0K.Z̄NސGɀKon*1 ϵ}-cԟYyYizCڞ~1 nugd+ 9oGFr +e=!&}e,ȫZg0:ew_32gh<zGToϵԍI̒@�T( 57K)Owwv[Fy2vLY8,_K ץ92-d:ګ{{ӓ%FLjYgl?Zw)l0}@Zsܐ18{W۟З"� fT&W\i?on* a mk>=b=Z5dxuy]dۦh_{3I;u2ݝY}DY%DŽ=I7m7̩jG 3{ q:|*U7l97p?ΟgkmqY8NޛN9ۯ�>Ņwu)SwWW7?//{6R i{Fwm̢. yF^C*0#%e}ooOVP S2gyEu=o`Js\݄!tz6M8`k~Q ~s@zp=6 kǬtE$媮۟7dlNon*xh�?hQR{4;&C.ľذp&Ԛ/r璪@z; ӣo6Vefq*N =<>3q(=!ou˒l=-�CڞQLւ/ʄ}-Ġ{Jjs gAw6q,2Ow7}KS7&YEƎӼ?1:T +ga^LJ3upcZº~ݷI,"c���������������<6 endstream endobj 129 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 130 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 131 0 obj <</Filter[/FlateDecode]/Length 334>>stream +Hj0DAO+U-������������������������������:<Ұbps& Wp>4 9c<k˰VY[[}2~cYo>Ӕcˏxrje9;#8-.?׊]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR}0Kj@4`bYM+fصbf]+fصbf]+fصbf]+fصԤы} �-p~ endstream endobj 132 0 obj <</Filter[/FlateDecode]/Length 530>>stream +HNSQEO%.Sx+$2Co/s #qsvZ+샕bcǓRL>X)&rsvZZfo~ />VpzQq)LS4[+LS4[+LSv샹Nk^cUZ{>Xf\!Z5OW_?-ٻ}\}Fk5JZWMZ15`}RL>X)fS;H4`X}R,>X)fK;H14`}R >X)fC;H3`ؙ}R>X)vf;;H13`}R>X)ff$3;F2`$Y}0>IVf$+;F22`$}0>IFv dcH1`$٘}0l>I6v dbH21`$}0L>I&v daH0`$Y}0)샑Haop H`Gdvԥ>ߐ#7}`�pp endstream endobj 133 0 obj <</Filter[/FlateDecode]/Length 1104>>stream +HkLuAnxOp +ZU [6\S. \\%r-6E@<ÃvF(!X[ht4e g?o~/�0%jiqWkx&/d)6���@@_u%󵷠��pydX[nZ���\p\?w2Ѫ)t��[m^ژl5-K~���NDe)iW~��2w772Q$C"��?+GXVw��pU Σ?+WJhVYKޓ#��^+WO231f:ڂxz2QhSd;TѢXN��`6M$\ln-&{9TK?=qFKvU({G��$40Hdto]nn[ QB#OA@Ob,u���fNIѱ*o[:U[ٖ<ؙ.Du7+E@WG1n͛��]xvc \y>3|=*C7q8zc\t?'+%B4u߫˶��@G췒Wˋ7u4(TSɡ Gݝ;OzGޣS��qk ջVح3ڽԩZΕ#O=`[ѓ艳4Dʀ=��&XyQRW{qՎNQz{c@@Oǚ3<"{U��BDnZA<JN8Ƌ14&;cC艳X;}Wٻ�� sDګ n5 ^Z5pgS/0T!Fospz?R"DScww��V)b^X.> m;v|*n52'KW7J?'C[U~rF���'< }F?[eiA-&o#Mq+wOr<q{`� endstream endobj 134 0 obj <</Filter[/FlateDecode]/Length 775>>stream +HR#1 DQB6CR ttTjA0s +[!)F]r1('7.ӒAGۅHa΅xaB*rs}$^˼>/HJA*#bdc}M2>X~yhr Cf7 +#/mYKA2Qry1\f1j#/UE}bQxH}en>˜v~ԊpPV·у\2yKLnvԵd.fwwQRעՍ̍ .Gd.t>Ύݍț*νᚲ[Ln+h"3kgBef w<d& 2$-& +.֓{&j5+32]kdIw }/[Eנ^;Z uBAѭ(0? >ݿ5wk,/?:>mݝ)#a7u&}#b{NUn׍ 4ݟH@r Htݧс +]it`jäl\j-èhZm)/އ�l\Lr}h?ca>A?mCcS^Vҁcicq?AVOS+tݧс +]it`j4:0B}Z>LuFVOS+tݧс +]it`j4:&^�⎻ endstream endobj 135 0 obj <</Filter[/FlateDecode]/Length 586>>stream +HANQPA!DЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуERtؠ培J6#7^G�d#�6sW�[/*J |åL efnw҃ELzpJ6#Sɱæ`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=؛`�p endstream endobj 136 0 obj <</Filter[/FlateDecode]/Length 627>>stream +HQa[FGL#:T}@PwC:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?Rz{,*h^. +KvGhG hnSoG>B _D~>M!8n妊F?}F'B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tG^Oe ۩Za?r,*Xޮ^%TrJ6'_Vh8« +.zM'D> +0�_ endstream endobj 137 0 obj <</Filter[/FlateDecode]/Length 601>>stream +H\1O@Lhp5$A:[o.< +~|ǩZa˿s\4OЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTokņ-y*9Vtud#�2KXaӿr^S~ ߟ䯧c;Dž#G?וn Tr9.e 'B> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zK?�{L endstream endobj 138 0 obj <</Filter[/FlateDecode]/Length 670>>stream +Hn@ DQOo 8UŚ.y "i聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j{=0B=ZFLuOV躧S+t聩i +]4z`j=F8II#n~d܏P%p|2q?6C�!WT څǚ_% ߘ5\Jz1jˆ1{{U*voT-l!I2ģVȬ1g[/UK sYϸ.GVQ_*xšVׄn2«R\09 w? {wx?McُAմ>GlUiJoŷS xޏ$',o?b1:ǿB1/.K k~T_|2T܍hF[!>mQ|W<,t\VyC8M𑿕ԗk +^ +9<\&|[|G,I$I$I$I$I$I$I$I$I$I~ 0�( endstream endobj 139 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HMo0�|J8uINUQJ$P̍G~Z����������tNw׋ɓ3;o*7e,&͢*f׿´~ eSWm糢mu^x&l>jA7}/}E<=H?enu5Nןxcn 1_'颼mX/!q;`ܟ<ϲlQ §01u%uaM&萔t:wg:\4d/ ٓ����������������������������������������������������<*�;V^ endstream endobj 140 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 141 0 obj <</Filter[/FlateDecode]/Length 295>>stream +H׽+_ ؄EX- +gpJ&]uI.SWd9v/P_z;| ���������������������������������������������4Ԩ\4m񢸹v��-ӣcc^ϝ&WsmdOm��@tt&}깐9 ��Sw!��QU4*ׯ#eE>X,<�� Bn +\Zj\67;>~vH(=v��%�1B endstream endobj 142 0 obj <</Filter[/FlateDecode]/Length 576>>stream +HMKQWP. "u3#SPmaZ\$HD"H* +2YDImќ)p!s8F /<7) +ܷOozp~hN��/o=dr~2\4_ޞ腢Z*!,aO Z dwB#""""q'm3}^n>6r~fx1~j\l28$ NlaO Z #{Gn=3?wnk=m }I'~vgyΜknn[]4kX`zz߿|ό`3<FMM}|}뇥3{F{>3΃9όA9g3<s8Jq6W`q9}fپFJ� n5R��q}�}3�@kD�f_#% �7)g�H>�;FJ� n5R��q}�}lZ*wU F�l endstream endobj 143 0 obj <</Filter[/FlateDecode]/Length 425>>stream +HױKUq9I[[ +6T ]ApH*uiȜ)R" *!2Ѻjq;;\<h צ;<pS*@b}7n77\t=L� ��Dsz��D��7A$=OW*Wήԓ��8EI~ϷoK&˩7�pB{~>ԛ��8?=�[}~nQ�b\F��bD?��M��(6A$�4/_^N0 �cHǧW/~%X�@:4|IE�\4slkW�Dr=?{}e��d=}Yy��R:`�l?޼ endstream endobj 144 0 obj <</Filter[/FlateDecode]/Length 19270>>stream +HWn8~G7Q$v3;i&AXE;ڑ%WCҖ=mkZ9߹P/vs{Tݽ9g /^dc_^64%|s�J.rCݵ嘥~Uoì{}u<]=6xeY˻,Z,&b"@E-@0Xv$ZMmUt8< #sN>,8ac)- Nd8A.VִM߭0d]E=6i1LDWO}+?c6Skc*S50˲n qǐe:MzH0Sʒҹv�EnbyʭG dWu$r=]9kVߙ8+sgjMAx.X 4Oe&B0ł+*C&bE1kxZs(zΛ1۶ wn*2 x9˗vrwߘZkѵ<X \L{|<.*$,Z "!8?%,7&YHfvV`L@Uo}ۋsK"|Xȭ?.<됅q4>ꤏmu[[nDZ67;O}0u@WcBM?P6=pFTuhT4z7� YB{vڐ^=tɺ1>bvWIxQs"jfګ=>3uyl weC#4@ӌfczTƠ `V4fD; Hlu[7mlVUf0"蕱[yfs+FIFL tOEsrjm@Ujj�@[0Yu-2V޺WzְK76pl6fYǕF>ʠ#7QH[Kl52)=,N:=?ֶA97{+ZL}<u;eۭ�kx`NWq>{=A�MH-N\Ss闧z9.=ڃOT[Ϫl`ңi_^w0roi0OFO#Cp(yy79tTѮ:{U_g&{% }){Cp6IL{<$!ȕ015d8�poE@$MUݺv}WM+8&j8KfÀ(T*$J O{/DiCId؁vc`a nOY"1:9^Bo`vwJ4^ݴl]=`;<]N:C Ƿ۩B׻*֛3A-oKf WGt3UwV}ZgͿ0o4Hp5g8a}!=> avӾve/}u]33k־';6n@{}ii@8+k gի <ß-yXȫN(7H^5 bۯiـFtn߲s|(vV9=cϿr �0Q/l b8v,l : +8eד8>D�4<8`?~=^f< 1# _X`Np3B(a$"ƶHBRJ)4"*Дf4-fQX8`)e,g+#F,"őD%QeQQp ss%W<)x ^8&1Y<cXIYE\ +,Hp )HD*2BK"d2\RH)Ld*3B ++b*R\a+RJUrU2HpB$Jx'"J$M$OLqJR4Jy"J4M4OpF2,xg"d$K,˳"+s,rǹe@ В_zo%إ`'%xR?w +k >sA$@*!b "Uc,!?d)VAAz!I@be$%gү�gP:ԇB~8[_/^(bނ KA3dYLf)Y%l*ۖd"_ի2Gڀ밇vz쭫+6[l7j.܈> +AxCT(ŃʮFUQ]-_j}zXA1vDYbQڢ\G:%J)G8Q- +Q`z CRXPÀ"Al"hAg&&IDpJ.5Kz ^)Y j;h!x hw c~.Fu."Ar`L_wVj!bMhfp+XIZ%R,TIH%)iSRI*%MJJ$GZ(ФBI%'iGeG4')Nқ6Yk$)2YbP^$ˤ-T+IU)PN$) W5t֔v]#Z7m RTB/t/ eK~_v x ].p [cNmh ufBV$ Vk"MMMN&n jmṊܙF %j<f)QjxYI>D[T|KZ*QX\%uhl%O•+{C.U//>IQT&!S)ĬM6 Hq M.*tj.=NNʢgQT�d쨅1!h#mJ|054yt55agtqF;#̀r~zBu=o\CO&~f +.J\�[p7y 2^Ng-!b KUx݀> / l`7E7woW[_jpǥj͉U+7o[\-k|piyߌkqǟ~|-O>?O~8|߾G{91C|Ħb*_YTl(5[NÎԲWiF6b{0ya?9Ol#ɹ²U;n|F&19cNž[&T h/"HG1h a)صKK#4/iO"Nϐ2Ѓ*qAZmSʹG`Z1햦!{$BYptxIiG]{:fgv?YdVk@[64´h=1dL!썚2A9؊9+3#h3 8u ÌEG  +( + vFuwz~ 6WCV~Xf֙-g"jr.n6f%)2,+f^%V%BUD!u&8\%4ID*B)2̂q~>{#sw\թ\ũ|S\,\ZFEsM嚚j:ʡwV."u&=8zuRiPR\jCFOdIrPHǯmРiUm"ł W4gb,jĪ=!BӋ$EI2A.'6 :NFA< +v_JJ)}-kPb&kh3 x f~(0+'@y`W6ᮇ,>}o7ԯȷDʧ88w)xotTko_+yƸw/W$ݧoD|y:v_>?r~>C9iM6O.tCpp[|'=Δu6M]؃ޛ9~pr[6OxO va$~LsP4$Eu@:ƣE8r`4Ţ)H4RjRJ) GRs19wNrN8fIF0͔L2a~L.3ˠR3ddR1yxah34^ %3cfh"@ohթHs V! (#6Rꈜ9bI4i2HoE"M(W+T HR"QMhV+ ^*-ذ d`v g]ZP/08/,NtTw|1rI$]J{s"8*z[DTG8TEFUU(r(;,~ 6`c7.5¢X{2A;gnP5B-8`Q:Yy* +iG0GyD0-qs`M[QJT u(lAef{^Cx_t~6 p 11GK�#SFg +DUjyYqE5b{0&BdC&ȡ +;bz+B.mYCC+hi M-;ۃz lŒԍ�p!tcHV%itCR|ʃwl](&e"Icy~vVYJ9+VX/gCïϾmk]4t % 4; 29C{9dݭnofG}섓Nn8䈓'+d=V,ddWV~9fk79+tVB &4 i"d1nM`<b!fr{6P!'' ۧoB?Nd*Q65Ԃ:HStj9UX-}diW,a-XM@0' ]{9 NIp΁צ@b c<&4`J)FͅH PbcE5.FF ˉ` FE~FTK2#wZcQ3aBw~8^-]4pͻ0 /ߎXBO  SNf|q/8_gvflH0P$"Y$==JtM.:uVTށ/.* .i]v1|I,RƲ5Z aagZ\[1٪>U4WlFKyaƊ4BYyNeLi89& f S&<ܝ1ic;)iĦIL tΠbSI +Ĕrs4iFUvߩ`?U6 -k嵈V/)Ut~GSO"1ӯ ,ɫX_ ,0-FyWF`<swH0Hk"mZ!5`*A"g� 0O5MtO;ND(-9ѩ]2_MÊ۔NBZ f`p:>DfJ&r|P(jsJtʅqMV?[ˍ/5rvnwv;v(ZKK -cg3ng޶_WSO>mIQzA}JfSa|gIkIp!qp{0O%YK<S*tx1A.hiZK8N(p�)`ϠyHx'ş t<="wނb wqg)ߣ;8\px9gAJGp^tJehኅ6dzZ Y�K*/ :gj>R M(5RjhRCzJmÔz+wWfޤtYzfD~{J=\]pV7ޱݷ（C}"W(]4t%JAq8W:zWXQ:B'Sȭd6ЍoL#'(TaKp>0KC|H$8Xy 4{40 s)!1c,RfH<$D0!^ÉЀBP12W�<�hSEuv7BO2=Fޱ!o3;r*趐+ȭ'-Vp;mv lԦ5 eς3ՕoΟsLj\B'V)uRVʕ=gWίa9ǸL˹T=W毳/_�J.N_Sw1Y ۝dmmZzE/Z6qtܥe!D^R{dm.CO;최s7ؑhy20?gc0_c-x-Q7ovk㯯>L0~| o~quzA9EZ%L׿/g0?f~9&oEC4a-|*G_#Ȍ_]%3j>Y".JBaqQ Z{#l.x4"xc^D rgbe@@"QQi:yy3:[_,�ň[Eʼnhz[\m1~A + 4.p9R7AMqi7%,ÌP@#c>]YFE`虸hgU 2MB z AU&qI}$$%ıU&ud8Ţ>lsPoP )!*W J.zPʵ*,L$1JrӑSaq +b +. +XZ(]C}X2SyQL8lhL+ ]Zwu1C:(NrJTˁjyɬ7V,՞Kn V%g.X?w,>wz*R,~ĠO-|{9߻"T a"VՔNqe禦%UDttHU>"Yl_;T0"YG3Є2~y&IJ멼b (Ό>vc /@.60ϋS|>7*Jh1i0zKLᱭCE FwU?wz*R,~c>p*ȩ" +}lb}PesSSYŒ*X:z^ޞoVs0&` :Pлik*QP4EE=EV^5n Qh]m0cL0nqRۀqH9 /hM͈~b#]жgz Rث[83ust,ՒY'G%ǀrKv#"u!`KkG-hE] 8q"S6c&c8z\c8z{{͟s^go2_<kկKȿX^i.b^>N"%% ֧/o[zjmDVYp0\f^�_MY=)  lp:xQMn]c]o$O*O#$OΎF"kzc K̚la!eo9¨SJJna!eobVn +.BF=^m^;{wEx=*ElE"bTY?~|BGi]f*lgQZƤ}PGF6p݄x@-6hF:U%]XTvg҅qձ{{:!;*]!`QBNnnW4!;*$+l<?qsi{R<ҨR47JzQRtc(m&d=(xKoW-hfm&d=(aAR +Ϋ^IoBv؃RNnc_$A_c7!;RQVnpb5M{4b3NƁ';x=4HJֽ6}>En;�vYğbկlS�4AKAfJ9*u_囑KR#̟kq\P_98P*@9ר+@o  %.ND>N$o%'nx\!X@ڟǠ:"Z͠q6b�K|n�ڮ}lԻ>}G}T4 49Wt_ E4u=�Ѱx=djd(g{{ +Q +`d+Q{JU=dW)2\Ln[߾|[Iq0xd}u$3y_GNBM +1A,L!e7 R]{e3 u[f*L}eA Z;5T>³&A敩e(XջO\|jk:Q+\+۸_||RrWBT^$w"yj cG`}fPo%;qMv!O=1:ˍ!rv=ѣW@I=bk$sH6{|GvQ'hwȞ_TldV=@ԭUQe�*Et\|DD }352YYD,KM)qPꨛ.r%"bW|0�x' �,?8EYWB<͔=S6v%c3ޙRRz]F鎨C-XU#ȟAb [= BbKz J `b*z[s*yXmH.V£Ѿ�ImOߍ{dJl-c__J`K%>UV↪vzd%`X¶2̸ƲrX//[cن{ӕK |%V])\R"쌋}Pg*uT[euS۪_5BQ|^8)+ [K9ɪv*Q_6hUuF08 }5!v1+!7Ƹy:>c䀇|oݮ9M63ICnݒapI(XXńXA ۗ`ҍ(ڐ)qbM-ʳ `HsXL7@!@9c#K tNFJ~Ys)`T&ej7*rZL#M*9 Gy@5)Q0/q{z-ۣ0==YQk(8}jd>] By%nr=ŜMdm$ogBٵ,=>𬏙XB6<V5=Ȗ/5<;ˆ2NXeu@ +/8t_} + j>VRYL:Nv Vj  oM6B֍k ^ZI7bܣOG,K}fz)[oMUGkA<.A\+YF⧤>}4NJn.:lēы:Io&L9(0�yV +Q픡ƧjfU ti Fc*g_н߾|_w|DҦÑ=޻Bզ okEI+  ڮ 2JW�Cwy4(P(ŲJ r95l<y +`f3@mkIsaF.vS6nip)kJaMXdӂ!v}'(,__Fô!!6z&+42)ק<(}SpZu.k*K  P|_SڏI5Rhvű1R Kfso{ǜmW^Ha| n@Tw{%q诨 ]5B.=;B +\T9*ϩaŘ7<x6(&)D ^-6 <I[�K]m�ɐ�Sv�x45]gA! +j8}TVUhCT/|8N?R[N2&i+ e^a)0[^ >V(|jzte+- +E {+M +s"RM*|iy~!vZ$ပڠYnmq7f\Oej~sH&`Z ` z!8Ui[4t{ OahϷ/-w5�€Y,`=�:̱r mR Џ!c8`PJ"QK7F9�2?vf-S+4SM#qΠ쮘?xe`Ju@}N{ߐ )-}`i[<J J]T ]Ѧ4e�fջ7~{t$ j$@ /p8qij-w*c];{?бȮם?xl r +잎A.=,Rc#{/ bQy?iZC4=Q'0S~iʥ $ ɽϯNZ'{2m'S2 p?L$xӏwXV/@nI!d*; MfK>vQVW-7~ ؓ=#å#WĦa NEijo^\y[|@(#Z{yx}{dUh"D3|iP&p nVQ [>9A&tP i[| sEOӿS&6\P*:k4kBq /qܯ/Z&Sky]GPJX2U19:ݡXhn ‚Dc˚R�[yrU6p'_u<U{To`,ouŚl>@3f9жv]ƕ6�ط978b�/[B^w[ɦLpw2$K˧ˌe_[Z{w2azTx�ǹ@A^ J&]k"L E 뚢3�늠3 eJ4sY�EG={coP{bՠ(W$+_~hw)Pe~8-®O=\&EƵS4ҕ 0鉉Zvs~ +?AHQ]̮zXzSwMJ1VtW=e[X;뀳a\n3MQ݌7@\|ʍ_M6bAU1ܷlC\ˡA~OsvS=Y:"|SwFc"5rݙI64_e'|Ϋx 1$pv;M!~֞mKؖʍ*L +ra#yX=J/C7pnEu0`98t9ɥgAYcU=A +>5Vg2C6k ު@L0FQdbDC =Tn| ɉa_A5ˮs^Tm1bؑger\:wTG>y�3K+Ay0$;Ba_h{Sw<Ad� +#6$,aAU,ci M'x`MXo +^] ىLB&- +7]G�6MDyZ>roFfڼbO}:_<-dajWFK4v{3m1ص;c!fVnպ>X쮖naToj1ƵO}:B>倩{L?\4BԔi_zuK;*{MZ]qڢ=HVPx*i%ykDmNVnmշzY;/>~v~ߙJ`3d/+1GM�F)"}IqCэc3 )p=GE!(m7HL/gZѾ'8�)+C|Uqk촒)3_-z\ f ~<MZPIqό2< (vgfb}v*8Wp."G?-FQ}tO/ѧ׺~TTyV|~.ʝ ޵  nV$.1~0+ +Y+=X<@+`iďh-OjFT#7ceJf[cw& ٢2:8�}.8ҥiL 23Ԛ\3'i!YvOW2�b`0vkRsOzv`8c]D-mg@vx`x?IrZ~?I: Z0ʾsⳮM\cu$IEq#E?^C-RyhԠ#gA*O[EuXZkYw:Dkme8М4kwR÷+Y8^5p=v% Z<\[HL\1LDRj"]UqT2饇0HZ +6}}VSiAq&[d8꥾^ΡG=6F庎RvЧwodݳζpX!6nqvxKbCn24'hTOQ!\'sVz`r[>o_-{Tԗ)"(E +J@R8u{:R8^[ +dr +-=ռkq)+E)umI8hg|t>4۽d{cm|4z4^lL <R]>l{< +iA)O�\f2 ?$\NiΥGerKZ +'N0IL/6zgk\UQC>rױYQ 3Ƚso`b7(L1OZѴwROKp�' +'N+AJ^%́.x dUޔKkt ^l۵ _-M]DXeg{^˸Q[ճ <n(`\OrH^yclv=XOw2P Ő]Hp5t} f_?~pfjV+AXSiv\YFF; \3690$ ;_!5ƿdWAY I].\?n˗c6`$Lo9PgV~m:1}2&XXcjY!ь뽊܏yp={vLnX§op[L;ó*>s:7dZR9@M<F l'U0EEB _$cpe>fw#:W$@d,rnKV]oH?ݍB ϛlWin0j64n#_}6 F +en_i&W]$K<h)lfbk ;ApF5a K_ =65` +ܤ/l$NL)o҉vm:)�'#(}>_֖Z2'jSQX>yN<&3. +M`U#C38[,wϨ×Mv.(0f:OX815�\){�n4T{"(|ݑgԢ:-Œ3)* p}DQ[ڹ`c~m%|3x�ψxg. +~R*5>aY/bjp/k{uQ]m!f`页#-G_O.>"=obZbwؽņsİsY|{;F. A%_;S檗!(/\K@TO8<EG@Ep+=ܜ%5u@DaPFlqt-E=�CjhTPuGZ 'G(WXw(6tEL�}J;A49|ƾձ#s8/˼`ͷs be0∰ kVR(u9wӻ =7a0ݩpWIQl;eϿG^xH8_}z/!ISRQ{75\/^]=sMϗA ߐNSX Wre/]{$5мP_ B^xh{L|Ev .4!<Q/w q9�' hD<Nك?Tr a>1n ^68u^`>.<L0Mpqň;2- q9a`V`Z HXFOxzyؤȨ!M2Ro1 2ܫLj-2[20lOIƸ7-<\"z(T +^= ǀ %WNg?06!1J$+A֢}( Rs\|`6MR0uDNof`8'#+BPF/C83AI@.93=z|HEdrΩ#z8sqg}'܀;i11'?%ù'[\ ]>z&eiVqT1Ȁ빳]TypqMD&Ō݋W�saRÓX9HdjʰfʞI:OP|Kyh+вa0F~jYDwWh{g-N_C|ھ*f';Gܖ_VSz +^N].*뀒+* P$C�Ċx9 (ګo% 7}#B1lT?-&%G9ͷ9c׍Tx:f֦(m-=!֯dx{AH<`驈+uKUZ\\XX:0_M-1#<ױ=R'jSqrHG;Oy̓a*J�2+rߣeZDZ ;M5eouԞ�f-r7ȅgm&I�)tIg H.w+=-&mp9vijhp* x;["z_uPFeͩ:~{̧Q fo<]&ªg4߶d`jU^"d= OVO޽=_AZǢXgbm `H{ +Dfva^&>+�FwpB[.RmfWCu^ߑ &ԡ !rb ϞHP)Εm!|hkS(>J3:mXшi@-e#pF�xuLP� }б$֐:SKmН�;kuhZ|w> }0T ο~;X_vnEpXU멽j^H*�EX;)GUkHjIFEza:ѷO\,uǯ9MgJ7L +/M򹻵(78u][xnS+/9"cCyX,4ki0?p_QGHPr}`h`*._Yy`~br*QsOAvAa'B2�N_x8 |l-*:e�ͽȌr Btf f6,J2[L ԉm ke<wj6 +".E&G0L a=AN)na (G\C8v w¹.=i 4zrb;&<΄LG#=Ȼ hPcW/D;Ʀnkwx4+'M;)ϋlC?_p$ y؎G +@5\2ZB�v ₿F3醈U ;;5я~׭ V^ԉ3#µQE>h-09x`~JFg7{Ɂ` ./VbAa $PcvˮH ~yyH8B0=<8vL>%a-i%w4wp:bPg[k7v fxⱃ|w¸apK<<C= a:?Hƥ -ErdAPPD;t$DCK/G%5H54( *2QiZulJR0]d:@% )/fWVcu`枀ɜ\z4-8mc2q6/C~n9[ʑ7{>RlKL#pOL01*`pH;_%ۓBⴔ.I7]Oo_I/EgC/؞2׻ѣ/g!%'R]n!:s/؞TN$YRB .ح*~i-u5B[qGP�XJS9kZ0`TXҸ`#ڷPfpd_$e!C".,;~e O0е b$ڠa\IArN+?tbF$>-\?t" ;I^̗Oa rNSRLSR,Y-`?}M*&G@S }\h#)5ucz{k�gw*6e9MmA+%Y/I8¼#ac*Q1H T 0飋T)+1ym0CJ# 8@�O;Z=(399 btPL#5Y\e\_\s YpV"RWy sgf"㖖�1_$K_pۊ aqNlcOtyڞ rN`ʙ +Z^<8oeH;�j8/=sɘ2!QfVz%q̪#pF -_L}su+ݹ<A Ny%3 ,#qi`l[̅$Wֲ%:z@|[^9v<}EƌDfV`*7*:a֘Jt0/,|d=t !qjXSAJQ7 +>-RI^LgmRq{NF™-.$MB΅\2[οu +S@R)i0^.}gՑ +p<W#O~Օi=mf/YaLh`-*Zd<,jluA'D0ie\)nzaZbfג0C�~b\ Kj+ +j'x- CI; [!H,‡c.e7(~pֱD FZv|B 7Ɇc$j;=䂷NέW"NR}3z<sErLJgd5,rXNTŌg0 x> UvQG힄sL.. 呮!-Bu9l立_K?xVpX׶݇olOT$_FPvlSNd)8\U8X>_ 7SfsUJ-I_mrnyn<6%2"UT>Nz{쾪rCUE +J8T1 +ƱuDX4q.Bãr�cg=!@ zRcnۋӱ;EG:۠-2D<j(at1q|:Вnуwo/̤'&8.F`ȴjVo 0'ZVaWyBraB7r20Au.vy?%@n~S ߲8KKyww­ +]r⋬='bU]K\)_9y*U U%@\:tZ/N+=.+t{dӔVaqة2[:Ą{xwst^M +Kz�<ğXiX@̇-Zyh%K,R?&U4حR;' ~:Rþ mPqp +&$P U:!LrO/E뉯=liPMLݛP{cCz3|&@RT8 ëJD({�Qg4@Ay7d2-'5oq1UF�[J(-|Glaw^Qꭒ͖ ?bzPWr|.ZT,HNe}Z:*vl@  {|;6�㰧(V::$a*5 p^X4_3LL:G iJA՗VDtCLpz'Q*G} '�!r8M-g"Xc)mr|Gsr^_J?%:L>ȸw i_d%ydhhFn: 6ź==YiPmnA}%o=>V@YyxW>XdfCoa |\Q3KReqIh:#xz\h+&Eo^~~?g}>?}|Ϳz _~~ k| ?/ky_^?ʷ~M 5CLX. mX詫L_a΃:ʟ(Cl�ؘ z`ֳ�6L¦ ,,-!fX T P? 570A` �b endstream endobj 145 0 obj <</Filter[/FlateDecode]/Length 2054>>stream +HyPg_Dj +تuG[[V[[1^SeVuZ)%7rr y + T¢h:NqZM3+;y}F>3v,_?dK+xM���7q)pF[i\^%!pLmD9Do[f4mc6�KgJ ּ2gз ���#-]Fǎ̩P䔲Wܼ[w47<^&`kbs~��`ph948;=+o"NwfX'|OxZx )H͵dgF}���`ܝ]hצv؍z*k6ܖN+ T=>U. }���`}F su/l6?CטDbỀd.XSniW)��峳!Q=>K;mE<Ү-_fĭ~7tDj??Vvb_ -��J[:(Oo1\+j_s+On~72Wv0~C!3g���0 N\IXWֱ9WtXE&?ߛ{ZuIUekB٥BqV ���֖_@> +v)'lGWzٓl󼥥$\kE�s3)% +327&mwg^ןY9/kG���3NJs_Ayv6E[-= +_RV0d5km)U'O]z^yF$'���s1vheE|W}U<S.|idՇDbgvkJ}YS^6љ}j_xG ckW,\ԟ���`gG_^H12sU!gv Iѭ95juN5(g%A+Gْp@n��E}0>-q^lg~69΢)R,N!U$u!wÒsMTŞCr:j)n#���egij82b!_*^սk9rk*/e` }|EmךM֡M/QW]g;ʍX9u@n�� iW(.䀇Nű9wr~ҿ~0jיZ̝$W*WqԙiG#0.6 >>-a\Z{˧L]��/NAGFjғTv_)I>_%?_OZёR$Q9{nH*Kubя]VT#[O{Ǚ"K}ےwf9\*Ig*;2ll��ڹfM^쩷 *evv?7mlD9ֈ Wv&6diss2L=#X^]ٔ2wvJiJ#yǥ~Dx8Aqrɔ `���~,윫䕷;c +?K#qMA;zH]E�sdokK|ƙ*ō3=Ml>sȹw+&пXr8>U]]bޢK9=_9Cd) ��iDưf2ULK2tm\,~Fx+JHXpa-E2Nx'V|Tiғ{;��7qlq~]5jIkwCoYeۈr'=" B? n]ޖşް{N_sɈ/'jf;lH7{ouuZt~��; endstream endobj 146 0 obj <</Filter[/FlateDecode]/Length 495>>stream +H=kQk[tXQGW8V\ZDZGQE6#/uM6ҥ1P9\$y s3<w9Է7,֋_OH];|܏]��M9ig==QԾ\8S��yiw��+<�m}\��q[ � n9YK + zG<;J3.\C9C9H5G-BC9C9;ԸA.?��X5rb�f_#'� n5rb�f_#'� n5R192myVY?� n5Rs{%|m��˾F +fn:Y<yxy1� ]5bwpT~`��;FV?{0q`�612xvc-mݴo� m5b׆{?��f_#VnLU}TN q�y endstream endobj 147 0 obj <</Filter[/FlateDecode]/Length 701>>stream +HKq�mXfh2vChQqAL~ % bDU9qg>X?Kz{ey;_x3y+ +��[ܱ#;=ӸR~ٹNsP^sOQݸʞ3Sj$uZOgY��`2޿J2p@ik=nt}9?4p���7*^]9~dblB]8֮mj.{lR]���/ĨV& ڧ��l?Y#Z{?fe���Xa;YXc=���(y,zrA���Szdaǂ}fE��@YYJ,=���(6ɠ˸T= ���daG߸qvٹC&���=daGwu(k_UEћ���Pdasda,gM���(R#)K9szbY&���cda&sѳ���*P?N vm3>u_ ���yoda]WO)9=%> ���ysZ|,QsRɨz6.��TY]#'?��T#YGqX['z��غ~ 0�mq endstream endobj 148 0 obj <</Filter[/FlateDecode]/Length 635>>stream +H=kSQcQ[HT,5CIf;(آԊBPI:8\|1V]x@To]A|h"=wp(ypgȹo8CJw;v࿙wl[Sc-���?te-GW* +���{}?`aNW( ���aEaΥ��@@klѨ?J7v}���lѨ?b7Gûۤ��.?`FѕJE}���\_lѨ?).O���\gEW +��಍Ҭ?s=>wD���g?`f1?IwJo��p՞4d\մR}Z��ઁҬ?),x^+7��*q4F*#[y0hMz#�� View��䌞8I*#=~d";��\@&3W5=w��hMlҪ?yfqZ"��EөV6i!��E3LMHv}HTz*��sؤ]Oߝ'"0�#u endstream endobj 149 0 obj <</Filter[/FlateDecode]/Length 1169>>stream +HOUu+qD`iӭe3-[oDtJETri#Ӗ7z\^r{=0^l +td_fhmd]yc{tg{9w;/I��Ђ39Zg=FK#Dj>KݧZ +��7'~kE㺬���zc++YI@< Xޭ*Z +��7NCI8#r_Y`��RcA@< d[)??]}��D3H@< k- b��ГRIXPu~���z5'eݪ2���zn'{s/>H��tioVAE#u﫡s��@/NɎA@:6Z Z ��y'_ <-}<nsv{?r;HNHGIiy-J��{A뢿YJ@i( (Ufm_~iu5+m"{KzTI Q|2���:푿ʗ5Λ/3F/lT1bsy��� IA< ^&Fq8ѮG?w͊4כRWz_(D{B1( ;E<fCRSW*Mb,2VnzY:/=#G��^:KDp;ϹMm]ZKbkDzҷ-7޼uoz{+BݹQ^M\ܵYn_;fH20~)~tmvZzO�� |]^OvW59 -o$6i(nga$M4Hҭ̇>+~#[yksRgEx���եoX?.sf|cE? +l Zwv}j!eE/NS��[4b&I.GSvt?11g#+K ?z^ɸi0Qӷb]'_9/UC)90��Qt/Īv>q]2sG}`*><Y*iz#W~<5r{3^eZigD��) +0�} endstream endobj 150 0 obj <</Filter[/FlateDecode]/Length 2153>>stream +H{TBpQ+*N=DgfEc(*jE(R \ %YEq꬝u՞U]OaJUy9w~yD`+ ̠SWV).+:s<~ &TW}9එo@j<' jyw68ޕfI9+Ds5g[U[)IͅA ���@Zٽ8/"8s97'U/`Z!]T:zeZ~USt7���Q4Exd%n.{Yң8/s|?~`׸*N^ksvD핥Wj$R,̞b��eajw}TU/U~^~<s^ۻR:N; rR ǫd[YX<��KΡNK,ñI׏T*.e4}AcNTI/))̶f���w%F?/h*Iv+A_h C���2ޫNQ +|鱏EiUEIA5qe r4FrTR`mm5���wmY�@ l,|)h7Vvra E)<tLdckU���ϼ?N<;|XHDII]fyI ���<w%3F�_?~~쯒c M k5DN4Ik\ R���u/;-c?ug{ݛAˆ:siFW +���<94̜ii'oLM5lX4]fsrl��c ǓMLʬ.*˿b RBt%EYb��wc+"$)菧oqVvLd RLt]dW ���&h99ڑ3yF9iaI?/O?$ԯO4Z{��� SSr9I4/_@˃##nwٹc$-u"'#FaciAL*iU]T7؝;$F*/TL0e RZKV\Ʊw���<B!;7 + |(auYj\K^_ wsH~T%hU)?\U:Q%tnK-{*1a;l@ڹ|0i6yfu]kI4~tN]ѳ2o+>fTJ6 !SXUhu�� yF4gt +602wtENFpPW!ZՊ?*:r{{zӦގ5 -tin8]eB6Dլ$/&* bku6zNi dz)FV[6΄;]fsэ.2��^8B\E4eQ䒥;l+޷wne~N|HZ!ny'ej:zDҁs{OC[ɖ9aDmkj/z 4]G&uu cp$NZ kypC��`PY('g3|)|k-6|{Fynz NYԊUҋ쯾w21LmK&mu<MYѩD 5&$Tt?O3cfR%k[%RBxU5A�e%Hdcwz{hT +忛GKǭ\%a1[xuφ 0*ʖݲBBbW,{Ϙݷ!o?Ň܉s,,v`mM#Fiv<H3:ڎ통B87I[VݓiU)oXOW^,9S{n}?Oeޘ;]-uD5+d sc{zF)1x#Zk:T'UaUi%l9-ֻ; dE`�2_ endstream endobj 151 0 obj <</Filter[/FlateDecode]/Length 2890>>stream +H{T߄,xA:R[m7Ee +xp*QQT  7rO$$&Z'H(j,-_2{U;—>� t ||a@شl9X|/'-5Xf&|A!s⎚M6]FiGezI6s+\T0)_[%Q/+З Y y\^s"5ܡ$'ƾ/f{5N/- ?foq~#a[==<tzw`0`; 4 a{M +A &r)-{coꝶ{_g#>g*V΁ J)OG v3RH,%FRRƓ-OkBz?\{Oڑ3tX�Z��N(&9_V"[<0C >{a6/W.,+%]idVvZ'*А ȫz7m<(/{7 +Uxv_mx��1�%k�� + G�HW&}k33|9x{w\"ĿǸ^Au?}Mbj)VQ֠aI]E8\l  r + +ĜSq:[JԊb-$]D&?k;SkXۭrq㜟G\T +T-̊Ԃ{/n譍}\r#}r>J5y•�ϯuψ7{BȄ8} ,U<+:l Rmo@ HAo'LO0ǏvZޫNZiEcEa@HWk �ȭ]S@fk�J�--ˇvG?qOz8!˃q?TM1,cL|lc 1EN#]DG~k|_ߩf{W$ EX۬Q􎜡t/{qϰ!-Fg]SjJX8}AB5i!ZSDU@ aamh89n^^. +BrFd׮ ~GCQGMQT #wl4H[\Z,lm7AהQCa۪O'# ray.[O,"fPI>/dWg +8#ѷ[�lHK56[4r!O>dT_ A^=`ż4Rӑ@Bݥ#uJw/}ݵ/?G�jQEBr |�\V/8AT_ A g'' +'vQ˲n2饏Mf4ydnm )85H|4"^)|6c*7ԩXW,/w 8F=]̭zK1v}Dϟ +EmM zJ+q$?sĎ?�_-" r#6g %ܦVAW23σU l7*D,w/4nSO(͇y[?GZGƓH|l5dGTTpJA3}D8e<lPHyޡOW?6ELzO(rJ$YNH`PWҮk.ys1g7/Ņk H?#hEmwNt>} EїA)j/=q$? +BiGS!JAsٙꫂ x{Ҡ!+r1[J5)"Ŀ~�? E_GBұWt&q$?1i<h;Qo3 + |�$ MfMmy>O߉P+[; Ӄ?G9fgUbA)Րh= �&U ;39)6 \ڨۜ/߁PFRr;NprH`? +J\G~sltvr  Afɥ3z\mzRyeh.Fރ(;[yg` G7D\6H^ jH5H4;#AS}u0p`FOaUzYa=Vmfy%z).m�pEyѽ}t2H`_'DL%+Eu 9tNqVj'l7)c :"v`2A>Ӡ!դ>4rk"𻚆';0,QM+&ByWB2{!xHeYff4;x IEat$ҙ1;~Ob~Hr*@_qV5ܑ�Zn1;6{u9rX̆N'#"<Q}YY !哶Tp-O &*@'[Bn47Elnֱ%5ZI#1G(�18;kj~%fl^L +9J+@*?^ @K?c!gۼ[mw'6d�P2aJ|dz;>J{ko./I!˵Dg'B*ҤG�-P"ql[mN~ �j &*r3,t-uj³%wc~Ն܄OXv^ 0�# endstream endobj 152 0 obj <</Filter[/FlateDecode]/Length 3025>>stream +H{4y3n"**(m)^咖˺d +! ~#bdgLFwkPhOﶽjm{k^4L99?~CTIjQSφAF:d<Vc |+RG=9y'.hiÆ+ S%%yYQuBO'Ķ PPh/;(X;u2"O`<E8Cy_<CtG=+D1=Y|*t7??5!i USt= @:A +B_�f-PE?d[;e7'?F۠ǹE~tOt(rAd=W1V&MdTĜҬ4_AI@2φ:fw&cn)A;!PEO~[N@ 쏑avqnח|eyl!Ak:,�<6+jH?/8C! +=3-�6PE?Kݷ$?ycdKvyIx_ꮶ&gGM C*)<`o=OFEdī-c-s;^jw>(|YiNvp'D.=4yPG~[K.weY"ߌVUSu|!8@Wzf#ڀr¡0;AX¾f_ɕ}}Ƹ4D�8N(_󭦒9-"W`ȇѮ +C7@-@Vv (*q0md09 , \6l[i!*1~~I!_ff'[gzW3s2FaiqǛ]AO[+Z;E=-!aM^լؑPpNuEnh{|r5"W`ȏn +$ ROwKWhH- +5ANME&�ꀑXx خ\m;!kCu3-Q fr73ի,73yŢłB}]HqwynW]mMwv7E=]V]@=]E|J-PE?} &dk}ᝤAx춡!wE? pA}N(9vL2u5kkBN%zBHN# xNZs9 fdq (f6 .=tKSX@k+{E h=֏ZsbGd;jPP (*k[?ksD?Rq# ?9Y؍i4uttB1�w[{ 科ܸͬ+X)[x2$ݐ.UAi<j.ϿAzKnoݿB_vo7&Y8ޞ T5r @7@PEUIpܗCu+ߖrK213wZ ŹǾSǚFλy:nL3f(՞Fs`2Sn\v'BrbΞLqˊXRfⴽ)n"CAr勆i>NM.=B[W+>Q0EJi(kw2)LJP !:{:xy9G$?6[hg?W#].c;5Xr r͖!i4 πu عK).0P;0ÈE9eR wzwCw6lK1&5(ۮikeG?ɟF#@^~�U;[� +leNBQE^5>2\1;tijP/ϔtP:O:}aȷ+c=i4?4r�xyJο<?;v'շ?z4~ /maр/ztvLRXZt-^%g9,` p#Z.T{p{EQE?dOkxls$|)RV||JkƄw>!Z% rutwG\2ea ,6i2,�-Wޭ4Ȉ$N +(XHw"h h+jӂAS0�7�Qd@QEяir5dRU~5&/6Y|sqޤA41 Dr]cl2i~k`zk/uTqq+KH%.#"쮨MT(0JQcMG6uڛ;{Gt\ZFDAEAPv#]9>7yjfz[zuͺFruK{6;ԣVue]xnOLdgzx>|#=Z=ZȞ򔭪hA[Bf: ezY���`|1 PfjРo=Hl{[ْm)7~יv)Ik"BBw>ds[<5c$˓G}tU w2!'H0w8��&9v[0Qvi<fm_$ʳ#<|nXc:q���"G~ԠAߞ{^)gC^W/`C䟽7[Y|3'_��woGt^?eE`:>ݹ eKjg{+ k{TpVcJV4ȴ + ��}eg-nk<3o2杆m40L _J2kbC)J4nM \8F;b^KW=-���4?ifi ߦj KϬ[9+Ȑ +x{C� endstream endobj 153 0 obj <</Filter[/FlateDecode]/Length 915>>stream +HKq'+H<]ZR"RC lђMerƲg[Dg,K-cftOh3ecw4Um;<nqw6^%hZu4�� T:^']f^dd !e i'#'9/뗯w,߳|z>Rڭ]wzo�=q7T?d^pP&zii4lZv? ^92}A^Zs�t펛JL&xd4H4��zP:ޔ$7`*bGC< YSӺ]��*یErh[NuESi7 �> wrY /u � и,(Si~%lI��o9sSiFsAzM7c�;t2Si~gW9 }i��&^M}2gb4"0-T �Ī䲬SiTBQ\O j)j3om�@Uw|hL0Fo)9=_M[A+ �h=돸´PSiVbə07m[A �uǶLDSF4Q~y4��*y돭rw[q> �xm|(K0%F`<f.tyd=��xW6E~E$`*x%eEH =sf�2Gﳵ{ȭ?J?ًA;rm4��qU72w`*^,\+ �}i0OnjdzL9K{q*�X endstream endobj 154 0 obj <</Filter[/FlateDecode]/Length 852>>stream +HOHaԱKtCD JA(h!*Z0h.3MebZt6' ߶)")((][<ܿ<>&G4o`qiK~)bxo"dGܱgq⾁u&^י 8��Mx2smh?Na`#w^ 7 ��$ѣ[G :R} �EyiC + :ta+\ �DBqS)l4swqcl��n%d5?/.e@,\t:(l)PfS�`tPqV(b?$nm9tZ� :Xې -R�Q}70 d@Y{-KU��:O߈gJv'T9,.Z�hL6tdo?Na@BWQq{U��>L)TjNU��XT!At +*$-#/-gT��@P]%Tr<ABN�P-0CMv%@lR=cmsT��4=蜿,= :c?!q5p!K�*U[dG?NaH)o= L?��*<W ~dD7-+AgUw��� Pv#Hl +o[\^�� &|n{E) ׽ws}̜NQ��ʄS9Yv"M?0�D?: endstream endobj 155 0 obj <</Filter[/FlateDecode]/Length 1243>>stream +HoLu�_"3`�[\<pt#-4b2cC:8 +t(LTVh=~7~? ܗ{G\)anZ%3L7J�YZ?h>L* ])Xgq~k'[#7U5A^( ��6 DMa 5UezV( ��&kߍf.{A܅ms,[b��f~m̨ц j +Dl"sAnF)��̴W'' Cc5w㛥ld e=�Lʘ[,Aܑ ŭbo|Z��`\ʝc5w%6HIkbܾ>R��`&\3?6;AܙovTҦ{zG W3��̷A\1ɱqRuqOM gzN[89ܝ m}bѷ {�"6K,A\1.CCݡٯl]}oz?_s 6Vl{_ S;��xP7o36}s<u⣢Ŷ-޹1GP A;bR�/6{~6{DZ?;pM_^mוZ#c+!��ܯήoe OO~bю>,n#b@�~ܺ,f mNNY3 z]q+C.�YEYȎ5^c#Nqbn>}Кܓ"? ].VK��pX6{47i2Y\lQ'u>"lbQ;9w?f5pqǺ��qd]>cNf9_gCI]+9g>^wxm' VLw*Vw +��2vuoxM~wbΟћ{ W_yU(Vf҂Tl~cY;�{tko M2NcWRڲ>Sφ?9ڢ={�❼ fw{A\1z/GOKi4٦$ |5N}C8ԑ|�p? �# endstream endobj 156 0 obj <</Filter[/FlateDecode]/Length 2031>>stream +HYPTwO7A X4L4LD&)'KQqML&E@6Y١oˠ PC"A-8&b?Tf.\_W]>9#�<SLNz<xyZqM! 5N6-ɷIޅBȅ}Ȓ�|?K�:+_.{Gs1{n_Ysut0 +⪖+kMp)ASe�� 5kU!KqOlt]gN?|Hk@(?iCaWQ|:CXٱ9~빢o^F|>���6.7ZuQɍ%y+X`Xk?B k@^=6 >nS ���sSSڱa#e,תdlqʛ?5EݩnHN Gpq^ +_ǑN䆲0̓Q&C��� .]F~~3+q]n6~k1 'TW +菇˞JrOh9U9Lr\o Uj;��/4ypt-?zTa[;e +菇׌5H$5ȝ;ds0Q$|N���<`ifFnHّakΫlsʮ^l#m {O@(?AJ$A~:֚͆FT);; �� x iJGgghۥ]^0]䷿eCǯC�xtͽQB45ȏk,|2ʄ9eWѩx4��s&S:NvgKPˁ7%sߪPx,7co}  Id *[5͈k1 R ��ig-^[\ve=GnWhxH +;yK?P@<ӼSR,MQ*]aW# pY,y��<$Ɔqj??0Gv#[s^E +§{ww!X�B$LTJYgNu<>z��&.v_r)ZN Zݙa#* n7l_@(?~\.{즰yu4Y\[(��|v:u{"YL]q%깢o~wSu^DRgoNq͞Sߡ?P@<I)K;"c63'M'Z-| ��##ɋ5E + ҟQ6oLGAw\qߞY ONKGJ-˓4+ Ҟb5  ��0i^~vwLZP^".oJ_]˩؝�Bd~ȉRYlfwuD{�а&Oby|&2i ?^ZO"3w$`C5cl$R^4 /q#Ɏ [7�3lNYDv޾B־�ߍ> _?VQ|�B16Z8QFE5Hl͐l[ۑY��0Y]B:lyNzNb{ZOwq=i:Np,WV�B1vZz2+j 7sfaA2C�`2{Lq)OݪS]e{ N"3!cMe  $c UQP(;mGD2G$=,x��&&&N/UJ^T=CjlZmpoV5?@O3fAY\��F,W(ת"7#G69|nu ro*$g&kG� endstream endobj 157 0 obj <</Filter[/FlateDecode]/Length 1016>>stream +HHu.V*`-FP?j[4lAD"h%a j%Z[5:]N{_~yKc5sn*D0f>>_>~K4=*5zsfbFi3VĪ̗tީw9~9S=};ts#n�`6?iD?%MW��.g+i :/H4Z͌m;�KM ##fծM"mg'�F?KŎ :/ ;��dS[S%[DÑX2c%rϨ��f w;#!D?UkKҖy€/k��q*>p^D?e[>(tc��\'MÁjD?eK*XW&Jw��;Z[*D?ukks,s엓ԩ��3JD?Bz;V4,x^}7fT))PTT[s,s|;8чn?@7;i~SS_z@B>f޿eѶC{ZR񾿶879>]w1 �:pDnG~QS�ue첍oDz| � c'VE7At +QPY,_umpcMed6l{Z}BW#{ʷAt +eEyط`*tc'F/ B�rSsyJ?Na� wo;=kv,;JyB/+V7At +\*-7:!2.~YFu|8?B*R)�sƗ{9M;�dx6Me�z:QvfyJuIJg]`)%y|CD\S�S endstream endobj 158 0 obj <</Filter[/FlateDecode]/Length 1019>>stream +HLuύ!VfͥLiDV9QR̡Vhcfd;ܝ::H-WR!ЖmM +e|>=_ߟz�ʎ+hCo}Efe��h6kndsΜ_"w,߳|ת�sE<=Kr w?mx"7D?�d[Jn=`S�~*L~xeYٗS�TzE<Cr+@|2!+D?�6>[8.:d��T;29Avጂ\[dO?Na�~y|\iR}�HU7uÝ\ՏS�bIօ!^-w�0R<dFv#X&]luϔluo� w=/zAt +@zh>+dz>N]��^8EyψC)�lҦCnݾj��3eߍώB)�.9p)JUu7� .KOA)�⍽`q;{vkϨ�` t]";S�ɳ7ž/eo~fwy{�*;6i0=c�oӄpjk~9T3�Pm'|c�|*v�;BqwS�Y @X_E�x\N*3FD?�Ļ4)M)ʏo�x]sS�t6#`Lo@Y�zO+k?Na�S.vnv@?G=�;4XUk6)�:-1KT~S�:Y.* :@W>Y&\ꖐh_]3 0� endstream endobj 159 0 obj <</Filter[/FlateDecode]/Length 1281>>stream +H{Lu߁K %E8XҬ4L#xljJj"Tj$!rs9!$/"5o`Fc䘷\ޟ9{gYB�x|*8m/ X9ASڬXob #c>Z x\]T܏6,�sltě� >rX1_nVWo�ޜQS0?�QIDqy|fYy�6(A_Ma�%Oſ+Mz{4�nlTkAě�dh3l3_�o�/X;A)�*"1Z09kӉ+=�6x%ɘ+?�&DC AN[w9l_TeMWwxBҶw{=� ⽌6|2&;A=c"^NrQm�vȩ(שMUzo�i3X]Mu??fQھm[5�VT,-5[k�#t+nbwNl^wt!xp`�3A\bw̑Z$�_yTxK]30 @ZW$??�&5dGޚVa|_ 7A5L|@_g�<qE|َNrxMUQ�x%]caކa.bǑ~}ҝÄ~c�o5;qh�ǹkݳ>HA37rwȘsW_?�fQ3h�߭3?{R?$b ׹WL*Bu:\6Z{g\o {izO�IbY1xb o�\_MhȚ :;.7Jw,ut”PSO]3~3<Jgk~&UΑwS,fGN񌽬dwH1b^�g'hП9_�x%a:'~4{=�#b`7 ��ygMEz�nLBQQkt8Kˣe�x?(oQIyW�`y endstream endobj 160 0 obj <</Filter[/FlateDecode]/Length 989>>stream +HMLTWmXӤJDkBQLMhjJ(EBڊ#Fh` e^J?F %҈-(B&F(.̹:}Hafz[Č`nYl\ ��ΐ7Ԯ Dtyp1g3K=ž7n#d�o'_4׾0,&*^6WD?� ݾJTE#:0Q\Xm݆|2Ǿ&o^2SD?� 5&,<v^; +7�k8M٣AT +�Rk-3̙(N6]a�ԛY',#40Ծm[<(k6^a�_$J+rF:wJC֯;�QGI~ө?D?� *ʈuoߏfO}�pmΏtSo?Ja�@Y\Tkv޻Z~"J@*ͰR� DŽMėC-#PݾU@ZS_?Ja�\9_6Zewe3d@�|0o ĝzAT +�RqzǃhjWD#N *�PloFNY!�|6iN *�gPXk`Kʾ�GWԛl= R�>SS_ȿ�> R�N ڟʧ7}UI=uܩD?�7j?N#N|7?:��sPj%'V\-/>sD?�`XF3{}/HYS9}Q)�[f\"&}Q#nbfwO=�S�{`C endstream endobj 161 0 obj <</Filter[/FlateDecode]/Length 1021>>stream +HOUC Ӳ}Ֆi?8mslc,wcXHc %ȅt[:H1 /q~!K$[לd¥ZsK8Vm|mKUe E5Op{ɐYcxx�g }k]|{;P}_2A|d�e <q z}gbS�0q_}`; +;%Óuz 6�_7WZ׫فϝj[3߄ibS�`–෎ O|tBϑn?Ma�]}y RzU�nNTuc#^?Ma�}ҷ7>䢥s@N?Ma� +kb/dxLX�G~bS�`_N=Ԫ?6WlO#[dž}E?Ma�TO92<5w[�:1OK]bS�y{*Sϫrmس`Mc{w 6�._4wVHs4Rbn=3Eu2oOebS�>wnUOh/ӌ_M~,UcY^NuAl +�+{wm;dc p+GVg{l]e��wˬ}V-;[0GKb2} +bS��·OХą1M(X>bS�?Yvd8q}UOw p߆_xRcKd��5ψ"*U3ffF7U&OK)�Ni{2tqH.]|(}يu-Al +�/Xwb^.46>-9%Óɺ 6�\_ފO49W_ M$!u]�HD endstream endobj 162 0 obj <</Filter[/FlateDecode]/Length 1394>>stream +H[LSw?rAq:%fcA1l:olNƢFf|�eAD:(KK=pNE^DEq:]42a^(۲=Yz :}M=/K'WCjYS/u��p'YJܠ[״�\ڕ뚯rG4ѽ A<=��0QKrcHmg`F龤fx[: f��L_Mv"h^bx}5$7w7��ŦcOv~٬7�OkxAn?o +��<;7z<W~D#=fm*7k7��U$Gt];7zw�<]_wk9iiVi5V&|){�� %js;w! ##Ys�FW*^'7_Rz7|uEjvFx^Irg?��`,Zc\9Y_nUϝGl",oOӜC��䟶d%a\{}w;�07^9T,7Ws]6QVO��L*]=s[BYw�JvCw`{r(1f]cY[ٰt wtLw8;{ޓΡ��T7{^OYL`(ySˍ"S}, JUӾauÇRss��0V$1~8f(k6 9B@#jjB! #ҙHqujA��鰢`w^5o UrLu.{v p(xUsWRT~kan��eN:R$e{gQn5k}�J`7(A@:sg&[b|&"o)L{wExgl^YGIҎ#z*��>/:#?5qC'~�L݆:tNF4Di=IGs}K{is6!��?^O$. οRct�$rB4Di~=#F+ یUnϡ���+> 'j ?]M=$dJޔDip5˲5*2:3ⷺ/��K8-C}Oؗ.0\ÙT܌ J,oOH`賉°Eml3��{I⺓F�Ab!rxS?��@)ff!y\E, YS�SOV@@)��`�ĩ endstream endobj 163 0 obj <</Filter[/FlateDecode]/Length 1036>>stream +HLuyb5]VVEknJ[1W#k2tVL `"Ga9X&x=`{!t]k.KJ$?瞯wK~~+Ͻr^o8 Gi}D@WBDⷶw'JZgoSw,Y޵�VEs=m&.iT}Ovx|ϖ)�2Qݝ'7PC"0ӎVMw㦹N�jFW$h|nߜT.At +� n,M]m:?cō VyҝAt +�,.ږ9>81\3d{unAt +�l^-MuyQ[UGr|k=[v%%iN7 :�HFYP.}w B;'At +�\i}eч9:~U%K d[Xvu)�@ݹ~Vˈٖ969XOvnwq)�n,u</ߴ^X{%oLe˻aJf��x[e Xg(?:Z\v\f��f5iv?S m+084�@GVo7dߛ=;}R2G3�@g%n8wA dlsA*?Fa��tmxg[Tlu[ \tXuMO" ?Na��R.ͽ͋4N}b5!D :�H%dYSQftah@KtS�Ts"vN +LL6W?"u=,� ej_S|?ۥ{(R衆Hkۛ^D?��ݸino8n[}(R-#ѝ?x~`�~M endstream endobj 164 0 obj <</Filter[/FlateDecode]/Length 989>>stream +HOumm6Vٯj+KV4f#n +FRh6 4BKǃ={<[|9lꩦc.ꢋr.p\9=~ 3< d=(��l/͑ߕ-ՁB| 1F?ٷWu^OI?��9b%?11oKqs`K.ҾKubR��\WvFcK;{_<;zdmWK1)��v/WtQap`&&Ĥ?��6R'\i8u| +3 ;~nyKubR��OҝF.Uayz[;d��@E_//C;+1tl|UubR��ŋDGʮ'n[aWUt^?1)��]Ne-Vulw^4TPwwEs}~gUw &�9Q㴕{s*_wenAL +�7x(l~28u겴X&W%;W��ݓVzyy|}ŕDQ[C;c��S+>޳Gid[ۺ^Ս?Ia��0=h2+<;XOmz�� +o&.Jw\$#ksUw &�nZz[c^s˦NJMYb��`f|N :XgH>7Oe2U &�ybh2+/΋1cd{ӒY;b��`fenX,*: rw"Z"9i;ÖԬOW��7Kuer]i<B}{=7T & %�2 endstream endobj 165 0 obj <</Filter[/FlateDecode]/Length 1938>>stream +H}PTU+ȗIYZP:9:ԔYc)ER!ajK .⺸..{e"ȇB94LXcg4[g͸wιg䜹}/0�ɤ ӥ<~l1a*%p{2YfZ +5ԋcrɹM��F0եHᛣ`9>lFg5 +��WzZh0~k +'}ؤ۳N��@OX"FQSUF⟏koa\?x:9A@ B���+(u.^U2^=0"~_ ϣϓ>lLKnWki [#j>l UU9I ���R9'ArC13h0n%G>,8-@@b(~:N/M^gܮx[<>n��oRH#rGG5s+K]T==sl왾!���Թ̪ESž!ttI�>(gj,KW*_[З_o5��7)LaضzF[B^9\/.uQsSe=d%,Y9I}C���]dD2żfoV6;~<o= 7.糛}imRws?���|_ tQrl.G@ F{gIWۗ%y'ULd ^s��a,1Vnq<%FMǣY{#^|f^-hePI,Z ��`7}MHSu;.Ow潘 {~rkIZ2OuCSk/L7w���iiyr gxQ?}47Z{ޒΞi(_Y|z{w3,W-���=6LxwhZOÿmC\jO{M4`m/CGS-o_c��5z|&KvAєBvNi?PXIh#RV~71l& +B��0YZϳgK?ڞ WwN8'-5y^6 .C6#.��afwٺo7c582O{N5X#rs3{쐎 +Frb;>0*"CR#1nnMR˳g8.}弢~ޮ:4gۜ ܼL7q+5]~,# =3rxf>Y;ٓZjl +m+%i#UB5+tdk#߁��@GH<Fj*{dʤcCߎu5jG~˳-ke٣;N}JW?{#Aѭ9w[<MWknsOyVyD;ub۽UZS)'s9MFzUO&;gOOʑxf6^"k<C2=E&|W0ծMYo,[H��t^gϴ˿ιv ;0-S<'j8`叵=Luim0E 2Sp$+0泰EL~+di4CZy`0]l7/^G4g{Zk2䗛B_dXFrHϱ +N;ٓcFzF;Keо��9FW{ډ1~ kT=]?`�_ԡ endstream endobj 166 0 obj <</Filter[/FlateDecode]/Length 2818>>stream +H{PSo|,Z8ZVD]`G)_Q!B" W<% n^7"`j]kne;:`"Wݑ93{~'}ᷱdj&A!Af'.E9_R;?ϓ ]e''%vyݣ) e dJvRBsez~|c4Gj32ֻהc<+Bf0w.ǝ*?B)뢽`/鎴]qu' 2rL C.t_^&S1\: 6 ?V߾SKh*L:mQ[s19&ߚ:23&],=% +<RJ)@˃g~v�~6CEl*`*qwMCsuvmIgBڬ0] Sص MEh<Aw{f7̏uH,ޣ?p U4 uCJ)e_Hv3t֛=3GڡHafNAԢ1G묲ks>'X[z.YḄa.ite 蕬xg}N0=R&ˮY] 3*۩ +q3i;Me~Vuv?0)|*I]) +bwǒz_өiCg ܘR=i*<tSViodj˗HWEs4sJ=u='6Ifה%fזZT-m9A F>po2݌F#sCO Ɏ{晒n6zg|2H;)캸 cC8hj\a'Z9zDewP].׾NKnomf&`d4;sa2Xv̪XmM8AwY]oT%}abu + ?/b8y[ﰩ`:[S<ݯn.=c;\iuIʢ9cyQ`Kð+�?퉞G]ۤuJQ ̵6k"#SxWCvmoS Am^̪.�Bݱ=&%ld>Y6yCN4ޕR4;& @Uл#ܞ S_ʓYՅvy=W Æ\; @2XiC`M);Kg*Ca;ru1uNtGڡH^CA|>ts?o1~eEMm.uN?0)o)Y�_ V$r:�~;=Oyyn ̽>'ؓE[[zC|(MK ρ/1]@:iOF;b05On)Hy֛kkZNޘԫS{P%NCAF+h?WkcsO?7|`S XS56Mubd&M:T5ѪڧΓv¸)ɻ.05P0s L}-?:./)5g):1;gǂ/noJoTQ$q2H;4W/47&0z68tZ/U-a}3Y% Hpw.t`߁11Ad19=R4_uw;K?\gßb A5.{oOGjǥ>S@ڮ8�>�<B;NjQ 6qkŊv;3W6o̟<HFjN,S: O`ț/flczSwa% + 0AdT0n y`:_?j2s  ?  "4Ep6o(Q�@OAAxh5!1 :/7^L_ǻ5XDy@OAA.?:2,yBj�4XXQ\gß  \,opfxt&H1% +?  + A0"(GKȿ|kY:?AA^-n#v +lэ?AA^yٱINڟ|w-Wȿi|Z?4ج(ßWpo̟U[J)k~Pm.x(gkkQmDA^q)D'.ٵ._ӏ$e h)?L}*A^ HYY+(Ev uR;|U\8E.1;+LO{EA^�?[v"ݮ*X;P'ˎ`?Fpi˰y݊y͉Q?))Lݴx@uQ<G1XЋaƅSAmǛf,`?N[)%Q0`O.ڷv0g GLcb{�'7 endstream endobj 167 0 obj <</Filter[/FlateDecode]/Length 1941>>stream +HWu?kR`5P0V:zr]]D EXI S +2.DnxISE k;=[|g߯s^|g>/"�~̋ǐI=y>FϦ<hr +}Q:ڑ9)~��O uPeg.l5W^mz|ӑp"!L4Ͱ �[>3 +Z W +e䱼��<L*8{LMױ] jniٴχgm#*YКpnB3v.Ԩf-5 nLR�,4)]ZSr0o}v[MK\HWЖ<]sʢ,+f.u W~R;х!+9ч��GPܲ0'mnV$ +k(9۱*Vá0l{U 'D:ר%ɠYSnlI ޼��;@!SmKj5wےީެ$*^fP.*4"?ΣR5ŝ +cqy ��prp/SzBڒܾvT)~ci.^FP6U}U( +#A& w8wl&J/�1{$%.wa>j,|F1MbAu9E '}vTZ#4KTgl.ە1Cy�pD-i3$]y=puTCTɠA�raz- Qha rvy|k:惘5 �@>8;:ҜWRF~/d{yӔ.39͞]B"I\KR]�ra=4H+k͖sдl>[~+��e(J~7B!-B+O-{=ˮ2!;|,x?VA}ze|W;݃hKd� p�%]ICE{ʯ LVd܈-5 4BkO6Xw6iծ �pqtyN Tl_0o7ݫszQy�[ +BӔD?@X',"]!5HGe=2˓jʕO~7��iժrMzuom]6+vYYuL?骅A}#ȏ5al^F(x�@;x]IMzU'MՕk#,{!|8i+?@XcZ8e5-ufnE�3->n\?PϾ>{:zS}? Bh?n4w|_ժOX&X/ϱ%ܙ�<7DFU_okw~HN֐_4Dv?I@�9 '$-&Ci2N4=Qlvqœx#�c + +/ڵȤWgK:W|r4 oc?wE�9'&Re$j$Ʋ)C-�; +zso('ec6[߶{^J=Bv$Z/#F�ra[NN^JU c  cBv��M8RݍRM}G=8<A @sm(gATU!m0]oIlkB�^ l6]m +)t$]!~do"@N?l g Ұ ?4-f4Ȟ_� endstream endobj 168 0 obj <</Filter[/FlateDecode]/Length 3213>>stream +H{TckF[sIV4Ū5Er(  +Cv]ݽ;쬊$[&&Ϟ_燎Lݜ=vꕸ57ORNa衏.0rRT7CF5,? |})EcxὖwKTӒ\ӵYn %lKCre#Nfu!#s9dһ]bP'6-5:۝, {'y3wװ5KlT\c͢kynǔO�ߓʷ pz7%^Ozz`,g5.z]SCųتJ~7;< U1E_`]SULvPtӱSQ`aϢn1?5U#""""\?=m_=Kgǻޜ)2E�tꋥU >uj&Ank?:8ەcƨ8]!W xb>mk[]n(?8<wԩWa:mk9cAm2PT8txriǒו}!{@WT j;ڒ5CO[D`7JMiMԻZXo27�z;j=?zf{4G9tsz! +͜Oc AR0Qf[j6Yev+Oƶ$+Y7\8=""""ѫPjG<>%m-5}s9i< 1 +<k. ^3,&Ci໥fһY[븶f16/e%k\`Nvgvr|>P?I7Uq=o9›9q.´-#U9[ˡsm:<q` 1V3 9+Z`16@lSE$1mpsvyi~NSRq{'rj=/Ԝ], 1ǢmP{Z<6϶nրoiq1Z5C ~Z'Q}QjX:WO##t,.E(hφ'~?β4If~jphat[{k.C_ <>9K?""""׺ 6$|Ox*}i_p c< _tSeO71E5*L&t1}x^xM כc<*m*0Y])hNEI48#]N^]ȅ.ҍQ*&y?0JNC4{КHq>x68퉤{&Nnh?O}*|>?""""y)(q,_n=Sf7G4|?QwP<\?1.֨85 �+V#'Q{8t8)kG}ML4`t2;hlTi$G}pt>'&�/C*i14api(w貁E3`lKQ36?""""'ƴt3׽ݛUeg�95xA\NoΎi ]T9%x, 3lXjJnԋG>83yʥ5fu +R"XX]+ U럙+7Ly˙v3W:r{DDDDD/^ L<چ%vq, v77gF4|?Xm:x\i\,>i}u48|5+iӼ7r#(`OT3o\9~}aږ?rW b XD#cEuBМOc졖a�?< g̳xl~j{$+~^f'S%Aw6\pG/[:D4|?v?9"^><CN4Vf[j6w2qئJ>ZÛLtK3\e 5F7^S9[5.։m) +2ׄaMy>@c:vW�AwLN3W8m'VVl?ʧ5x]-e7""""񯽍y oڽXt@On&x}1/ǴEMAk'f#Unk~P?\̣>3hGK=?r%xTWk: u}w1# .z;ˢ52$΁?$C[}ڒ%L~ ]̱ qDsm:<uV5PJF=(ěnclw9~=5>hD¡V#""""GyIQP?r˼9#dJ7WRK4(V�,!?) 3Y{xܽɧIRtn$-/Zpk +?׿kA�`UPqvEHIAER;Ԃ(imZZ6yFި8E餂-XnN\/|Tyv.m]eOԤ{7=zhhI��DtnsFXI/ +!9Wyj'}3?J[l$A��ht-.1X2D6Vsz~0ʛ̤5r޽wf��K϶}`AϺB|Ӏw{̤5r��h;i~;~߽^w3R(h;̤�� ʶ':E[_53pTz^k] f��ukT?Ke!UB?,W_zr7ܟ`&���bxS+IIwC,?wmʽf��PO]8 Ƃt su;#_9Ҫrg4��ԛ-:TK[~}QKlL:9yy}5�0? endstream endobj 169 0 obj <</Filter[/FlateDecode]/Length 1690>>stream +H{LSWCWA0 4 &(:*N  +(Q* :^V(Vݖe˶?(,?Keo=55zK'$mϹw/!�$.%W5n/X+@!ڂsbK5.QD|ڷ` @!V )LzʡoО\KOGrm.D�Bmv 4u7{G`-{InZ5֬6;?<PL͍%j=U]/ +-Bmݍ?wа/孼'#rL.C�"28^mh]2idyjz@B=P4?wx?:Y\H($n QRPIjt:=HFB"CZf??-|u4"5o;cXnZ{|˾?�Xd@ÎaHZ5T_Rjcr�Qc:CeY)`kho | s>5F0\Rӱu&cڦ.y?G_1D_&'I4@Yc2 -R0ELZ*bt|y?G_1D_ŝId Dyד_oJ0U''RHwc!~&cekt*6&35v Qg5'zW9gXN{A�S!28c]mraVUXuc\2^~mQC4lYsH]xpkt^R.}?Y9v';79qxK#<Pl6LƴM ]2iun$B!N_i?f ;R~ {!}jPCiJsts3dqYB!N3iF5ڷ`-,JRcEB2zL0k-������`gey8[qr>K5+ ߩ~jK"ٓYPo|������1h;j*h@167{Y|PDz���������������������n0`"+ޯV oiZ ޽sU]W:?^t4\_ED%"OCJOf%$/*߳w/:VU,^e25M^Ut5wS񽦩pH}QAm։cbmn,ׄUܪ.|0 !8?sQc(Voаzg&~^}3Uvw6Hdc竄4~20=}]jmg&+`v*^p)Ҿjl|Z)jgFB"mBMc}s85/h=}whb/!tK&ݝ,8=_WUokqP϶82^<G!4`8P hsm`j6kN?swL`�i | endstream endobj 170 0 obj <</Filter[/FlateDecode]/Length 1838>>stream +HOSgC/C/P_'05Ή"^tDMЂ\B􎊈ˢ1N,sM3Y֝Cmڵ~y{C=}ƞ["1gӧLe7;k+:N%-G[}i0+csZumkd_g7ٚU:=.j"dfq|C=^+%KwrԗC(*UG=12ٿO8Nw5 |o޾mA{V]Z=CܩK:52?59K `hwH3얇MH|0Ze 3d ֧kQ<.)ޕU)( d#*"R??T|mtsUYY4ut\"aaa,.*?(?6m}:+6<wdN[R9gc{hd ۠3ؚsq{p0{獺=F?[]QJ{sޗٲ-2@MYbL_N !cQ+a38.4LiʄDg7g5\/g*glڜ뷙 -Ϝ%AH Zx\19JX׎VʼQH{Yi\h}Cr ofN ?]jm.u!c0+&KJKCuUƄ=d*%?(s.k+PrMEOa|آˣkd ۠3ؚsqºv0{獺=F?[]QJ /h18i\82OWZMYc{gZdQC+]W۞ܩM}f#c$C zx|]RJFY&#Qgkm^W\ήZ(1QfLA~`|g9؉pLbW.Vtwuxh([ d|KBԪcd2d Ru4f)w"z|*w {}Mce[SCg*% f-M'_,|dVۼtK7z cg:?q<ltx}ꪌA1#c$ooܧ{8$o}Y{+ooeGC٩Dȹ\L0{Bj>ת'W;d"]Ƹ ֥L0}[DXۺfmz[Va MZ4uy}Vt,ze˽h-xQs.1!U% +Z . ^SqN0&1TWe5cd2aΔ fwd9Kz` `ۖQ[p@ƾ$ӇEkzCJ{dy?/4uzskJ=;? ./.kڳzN[s}`\aV6Ws>GΎ!H5z>6ί\lU&/vYzOy3q𼹊8_;(_a4ho2Rt8Eƾi.߹i}:}U\d?+إR~~o5ݭ «8K*>{}S⢢]"c������������������������������������������������������������� 0�8h endstream endobj 171 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 172 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 173 0 obj <</Filter[/FlateDecode]/Length 518>>stream +HKN1�D)Y`]Q������oV4Θ{݇}izY[ `տ˰VY[}, ś?jO>>,˱ś?9+Odx.]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]+fصbf]$fR}0Kj@4`bYM+fصbf]+fصbf]+fصbf]+fصԤыNLd,Œ}f.f1`bYd.'X1`bž2b׊i*vbn2 'xQs]''bf]+fصbf]+fصbfB]D e&ӵaL}0_k>ҵלl+D>-5`FOSjcF5J]mФVNj��uDe endstream endobj 174 0 obj <</Filter[/FlateDecode]/Length 618>>stream +Hj1 .f!P\/f Zӟm?ZH܇RS[D!܇RKsJ!>B,m9CsJ!>B }(P +1@B}(ؙP +3bgC)ΖQ13bfC)܇R 3[D܇B +s +AV>l9e #s +AF>}(r @6>l}(٘P1dcˁ(P21dbC!܇B- daC!܇B@ +n}(Ru ˁ(#݇PǾWK>@O,R,nGk(Oٚ KkAya2yЪ}@H.Y53+AxP +\5H> f@!<2uwE0J`ѰLc+}Πv0z1hj̢kK-hFѷ-#%Q\C|ro9 ~tzBgx5|סYǬn$o͛ 0}me\bۼʨ2}mɳ| 0�`  endstream endobj 175 0 obj <</Filter[/FlateDecode]/Length 686>>stream +HnPQD2٦wa +z'4Rn b(c71}Mtiž*1  }ab0KĬsG_#f̶$1c]gpIMBGy7b&:|[ۀE*f7XJ@=}2LǠ3NLoBD3foQiiR[Xyc婸D;V +P}Z ,}뼋!NGLK6OEk҇N>_\16jboZ_t/3=>r]> Ct._O +;}6OEk }6/es :WT{*ct0U +=LU`B=FSz1:sT{*ct0U +=LU`B=FSz1:sT{*ct0U +=LU`B=FSz1:sT{*ct0U +=LU`B=FSz1:sT{*ct0U +=LU`B=FSz1:sT{*ct0U +=Xq�ɘ. endstream endobj 176 0 obj <</Filter[/FlateDecode]/Length 625>>stream +HAAQm<FArFOJȏ =XTg`Qs?p]+6hgcEMǍW#�2I#�6sW#�sW#�Wy)5T'23E +|o<]x(3SGpv'=XTOϤ +Xa?r?+:l@:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?y)=XT=\J4c҃E^qA?GhG h/oCK ?}@o<M!8OrSEX!z!=XTg`QsуE}F:=XTg`Qs��'n endstream endobj 177 0 obj <</Filter[/FlateDecode]/Length 598>>stream +HAAй aqC-vE}||$o`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTܯ|=+2lwSѵbÖ弒,*X>|~%v<+:lWSɱæq+ +'r\>Ba+DžO#\yz_y~>vpWSѵbÖ縔+2h,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>?m�� +D endstream endobj 178 0 obj <</Filter[/FlateDecode]/Length 2322>>stream +HiPTWOw(c\83f̨%1"" ) Q �:JAmz"ج,:QqCAgtȿǖ YзOS~<dq]HH)WW0+'u{U<ZrB!(!' AB=c3~7C3k9g|j7*]!YeKo!׳�_ qLrh۶QO\;}Zʎu̾4Ƚ@ߨ e5KwyA4,#=>p=_�߾=4Wiߡ{N+1§]QQw!~5A�^]K& -a Ɓ6O/4�Ç !kܖ j'E'#k5'Bm{ލ@�^l4) } uNA/D�#DƖ1Hy;t7UuT{N~Вȼ@Uu + ~mJFv4U\߷=}ף1e;$&(Ruxh#Gwa}^e& + @vt/ �/? rJ# ]A,z�CEݗCuzg]q23\9 YJW?܄@AF~6Hz}SVV>x#0=IPIwQ]/$ҕ1 7üt+mG�SL($ɱ;Ǘ*uՊd!!!HXTkw ҡq H $jNOԩ~]ŭcy) ݕ-E+2┤:FٚsܦUBMmsMuܿm@v>6CFK�뷆+ٟS6}VZ7FfHe$!# c%*Sާ8vg")Iy9uJ ^`ht7HJ ^]2�XhܮI%3R_?dҟ �!oB*)1tmk#z=l R_ }i[> AԞ!'ٹm;jaK@{>O՜_A�SEy*msD,֎ESyCij696H}Z N|s3b$ _-9B-JwTFzEMSϴNHw!K^w [/ף?R ɑOD|>y#}C lA6 ҺCǾR�^` DRy$IY٢ ]�Bi{MF\ ӡ?R$ӎ|>z c`r(_={SplLmC*�,VO!nֹk{zɚKNRG/~!֪ř`Hr$Q=O?eD {;x.,6ȃKrn0k qkN|V0 Q!ɱd +:;5ZΦ*ZBM[iU'%R0U6JҞ]l^S#PV={4we7.<Ѽm/iHV Ұ}wyҒpOM/Sd=S(gmB 6r֓;NY .GUk NFi`jL1ʶ{q0v^GO3;14"-E>/ ϛGY`1@@N#[,8X-Jt>:Vq]bSA=o6?a;}woL($ERI;. ^l4F`-6^o8z ٺ_$M=J5]R4w5D?M1/ !sYkC�SF|$]([cw;LkϠ?[rFV/*_C>&6Gfq3ʊ.$grdMw(Nv- !|V{f&c2fB!Q/-yYɮv?xKSjUy6=4;qLrpV٧S]NEKٱjYVD7Bh6v:=M �0- endstream endobj 179 0 obj <</Filter[/FlateDecode]/Length 620>>stream +HAnAPJ!)# fQ`n=yZ`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуETtذ_rJ6KW>@˿qd#�2Sɱæy)Vl:<N%F :.~$J^}>>~3 Z5+.pWcEMRvȠ=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуErSE{�Rlq/k?/yGH0�sk endstream endobj 180 0 obj <</Filter[/FlateDecode]/Length 1318>>stream +Hn6zHE+]`:-@H̘ 6OM[64X?yx~B4}�.7 4ҿ&\,k[  ӭ e � +g}N7+����eiv | 9/rxL};s%M,jh>if!'K~9 bE.nQ{xϳ?MaфJSOW�3.?ʫ6y%^WgG=ak?i04[]4?^KGd;Lçnot -S 3{ggmûw= }2G9Km`Egݽ/ugξJ/οn/ᙾs����������������������������������������������������������������������������w夌./ʇI5Wǃz2*:HXrdp}~REǃ3?V_'6OUitsOڷ:T_=3ݏi|l FaY#&zQ$T|p_ sst + +}[<7JEN"e|Ke(U EΣӶŬQ,BTG;inZ˄29SBhӚzV=tFc赣:;OӷܾhZ:?曥\RG@W`02%ʞdKCf\ "eY|ZXkG2XABPBiOJB{`R-̠v4ҬH3TDzD.3y<HNjHLZZYR.V.L,v)J=uZ$&wvM:u.̠vwpƕ]~9 `6''L1N.\w4K7u< RԅbFwma5_ho,Wq3]}z>\qevE2+/E�MmI6/[ȒIozZꜥ9fwmaݬ]Q$˦k8գPswCaNXyBYeUڜiS|N7+\)Fo}+8͟ giOJB{E^יA"JŮ`Of~c5>:?xP_hdo/L'�� endstream endobj 181 0 obj <</Filter[/FlateDecode]/Length 2042>>stream +HiTT?D+*APD\j4`NQF1J$bPU ˄6>(32lLDU+'IU 9}}de iTݢܺ`ZbYQv4LG$]Ki_N#"|Uin +Hjy{>ԟ*Ӽ}]ɬ,(w%�� 4}=B&b󘽷!PW եeAQZ˅n"1FϷ)+.ʣJ]PÞE.M� 7\^~@_ݣ4ΖO6qZc+GcMM=fr6{tU] ݻ��]Uf4yfDHZj6鍲ud|xV-g")Q UZ:=MXUii = ��M[$-e)S|?xEQ\ZÓ 򏆈DAϜE~&6/BWzQZuaa=`t.|/��~ZFٹ0ރu2"`Y\! i 2X2̌A {?/;4өW>үr"ڜkR��xz\vmύsc})|4m1n_o#S g<i`Kuz{:ͧs.+nfٙN��x>^d|? ΉR?i6HkűjA~Dw Q>ݙc<,2a/hOUlfZ#]{n(o ��}'[׻?2ڳ@xZa6jH&R'{mLV-6͉,Xߐx_ Lw8"b[�W"iYc B +< g.S{J-u4tg:muQPZy͖ƞnO0)'�ڻ?Re)l˝ulktjَS>C*ж& xTvk폚Cw~yJ(o=��/aO4Ԛu/"`H 6j56Ha {9V.^B:>\fwwjc^tl?d ��j$z."`YxCT6z=QWQ)A.LqhpϜE;v)I ש]-K}l-iO1n|�� .VeGs?A"0#NmΚ3lhnZɋv|o^b7nTiN-WF!wTn/]&[�u㸭 돥1[LYb B +UPA{AjO{m$ǫ <}G|ceaAk;zAW^M]Tʃ哛��`*t1g} 2Єu-"`@ʊtdpTm :tir151nsؒ܌5jH|l_&M*? ��ůYFg?!˖i,uU Rm}b A'QS&NfҔ$?Zʾg]۲Y#ʃ*��疌c]cXDHaqnVh{*$e)#Я*U;5{Ͽa!Q7��{wmWDH=c)]׊˪)>?3SSZ>bCBƗes}kUn^k}#��k[?!{7H ANo"jL>mj|{c&n&sEXU?Upq{$NfeA�� O= ^zyRcb B + mqs!*m3JQ7ᅟV-OʊRg(:WJ>@�Q endstream endobj 182 0 obj <</Filter[/FlateDecode]/Length 1216>>stream +HLuHnҚd,IftJaBHD̰?S:Fww2xBpwtc$i6g[$Okye*�yuƾkkQѕ9O>VGޱgy򾁅` 1C] CEDH(H;/7s_IT aکc��Yw֧?k76<Z"7șwz!7HFl\P3넿߂'1^Gwk/8>Q_՝�LSm-cZ?7$</<v19o3_?w׬ܤ!"0 `^Ȋ-DMgkÐ]};a+/Bn=�1h= z +ޒR_sM!B9SC+;Vx*0-/˖y%KDEG髻|"T.o ��߇s +̗e=o:P&mj$追uQB' kkW#57s&f]5#3qǫWG ��Uf֟?m 2n{ukwo}j��˭N֝?BjȻrNS�k&.tv4zATIk>񪼽?]i~�%cҞ&֙?RzHyDo=��bl@YGQKSP)(~0n78]{{��|]u/DOa@5A2M=ĝO�jo.2i] z +@n,!jn$U�`[L'DOaW rl.q.o?��\hkkN:A| -e;=u`��׎Vj z +ƳA,<Uu��m}vO nd=_$7H|M{���o:o3_2^d=_%7'}N.��[[ӛOFj z +̳A1Fg#T��షHm(A|҄pr��Xl嗤 DOaA 7H2^ {�K�jA endstream endobj 183 0 obj <</Filter[/FlateDecode]/Length 1258>>stream +H}Lu�_ +d654H DZǃ�F.M;쐻P8VVk=LZOKKh}aw'~?/}FIN@f ]S/}$8f`(o>{m'W%HjSiF;y;%n"��x:ݖ1Vw ()xAMN#��j5/W> ()x] RtJZ*wO��0FǶ9 J +HlBsy C+��*2GGrɾ {?䐹 A/o/�� +=GǦ@{?7 P%J4o rw��Ul ?{߱?'fm\TZJgXk?r&?/~A1ϱ?9\9(6_7��J捼VJm:XjN4+G^:뽽{Ck ߶TW]@s(Ak+u >!ww��0Q7fY:uT?Kb0+!WP +A4j[*w��0?olwtxSZktNj\% ͫ!��ܫ?,fKs:A%vԻĸ J3׶Ai k}\{�{qmMxEfortxKlwUra@9Ѡt}Miw ��ax^5?;{[\eeLa8vdXڟ$?^>nK��pPwJx=i2Y\l7GGq~q"FrV󡿯%K+SG}Ӻ2D>�s�Ud,}ٰ!RI_(x zkQ +LƜ]I'>.4.씿S��͞%m&4/5әZ=/ u}8&[KrVrw +��T[o:wx?eT_Q^^kfYnc`&H/L,+��e{M{A<1Uv/ŧYre U ]ek!��9FkcOp^ߍwmα?0S,{3EjOW-��K× J +3J[?/��/T WAf�)7% endstream endobj 184 0 obj <</Filter[/FlateDecode]/Length 1017>>stream +HkuX*)A&Rh`HYCf4]JlkakZkswl2٘S$attSDKQm/x}従64_ ڭFŠ̭"��#bǜ? \0ۯ| };Tr6`WnFdw ��51TAT +hw?+g��}wX"`b@6Z3_ DxC~��pxo`hw$$*g4dw ��w\N6;AT +٬<l6yl�uiX%قuZbIH~��ug˥Z3\!ݚ4~:Q�`j\*AT +~c_epDpwwjn� Z頻W)Q) O[XVx_`&@5 +<`|SR@ڢ]Oݭ}kf;67Fk#ŞM;�TzjhQR�59W{ _ϿW:G~w\Xe�_,,+^>RqdcӘtXw77h]~\ҽk[ *$[~nrc7G|!v�stىC+ *`&<up?319dE{w:�YIط\R�fR~MqN;>ԭEe:�dQQ?Ja�iv ޚs" uyc[Ç; *`6ܻsV|zـO vF�iNG<(PQ)�*Ŏ;1؎M�2x~}d�0ڠUwvoϥS =w>�dn|n?Ja�e[ÁCŠ&K={z~`�zE endstream endobj 185 0 obj <</Filter[/FlateDecode]/Length 1015>>stream +H}he{9&B¤P)esh0E3f2 IÅi6t*#/lΝ=r/6wf*&e/%R:;v4Lss.l!1$`Vmy°&-ܷQ}X|=w=@$<|QpC}7WdQ�UNwٴJ)�M97e|^D ��*|*^vs3$h# nߍa��I9a : '>p(hV]o_Qk�+i]&p`7?Na�6IZG AK~h\&�HV.{<{VX/?Na�V}0 ?|>.�viy%LC)�g/첧_b��ʍַ&˾aօS�]R}0/VWw6g�`(l{wRzAt +@ݖߚu/Q}'�`-ϐg?)� oN[Z6T^�r#jYvX*lS9o� ֬v : VM۲4'w�ܯk\X2]ll={lj�MEhvX*o_o.u;�{qe_D?�~5hz[LQ}G�s4WpZAt +Ny%ٽ_ } �pk?Na�Qfцul:]0JM�w_^f4)�zӷEy1hzۖ-�rzo[gS�t6ph;:|x�$(>kb2)�Gט3 \}Co �oُ[= :H[�5 endstream endobj 186 0 obj <</Filter[/FlateDecode]/Length 1290>>stream +HLuA?J,G\8m&BS%E@'ewfm Z6}`49~<_㏻}^~Lz@cRzb B-��Ye]JALaq_|,ko�JxUle5V^<Z{�snw|.?�EY:;m7~q<;H�N˵Tb +@-Y݊1y[ivZXr b +@ vH6g͕m�\N[eYs] ]S=i%7t�0MHT^v;mͿ׼7R˘(Lp+r5�ΘM DNUI?J,3j�,n=/A=G +9Zb�@ Zxt4boPQz!I{@dmEWwxs⢍3ˡCC�fΞ+{_& Vlu'?f^/憭 �waDfE>ّ6X^>1cE~Z[K'-j:>?� .V-+ʮ~?Xٹ?`Ȁ^Jdw�q*k!S�abϿ ߿^hCƖP^ҝ�g9bwőm3oϨ._|s,~gD0m`^̞<c,%G4r/8&ҵ? +k,E{<oZ7?]8oS,?^;D=&K6gUdNco*blD+qtS~jֿ�+n_+^z4ؠ]~&8u;A)  #gusaXy~HĨ=-�f;`\97_�:'3vZ\lݞa�yJTq`No^d?4zxisN=�{7)u(܊ 1o�/țlBʒn �u"͑gmm^X�㏺Ѳ?" A)�_1[B۵zRT7 �~vXym|[??�o|"|ӯm7n\WH¿ � endstream endobj 187 0 obj <</Filter[/FlateDecode]/Length 21278>>stream +HW9] <cWy2937@_=x v4|f~[m%Mo:e\n� +?v_Xzζs *�mYUs vzUnXTZmUlmKG'̖] Y!IRo* B7_,2 43DxM 4:[�8?аUL vE +Ub+ NmSs08r?8J +o,k:1AƯXbFx 名�`zN(}[V=匧&=֩TXw%Xw_¼ڜ +Yκe{t~&$6̕cv5M~ZL . }U,WoWXtʻYQ!IktT@b怘w>WS_acW˾ǟe?h}i<Ucqwd0 pA֥Z=AYV1w àCkBŌ , 0F6H̄+)djaa6ZTX+h,Ȓ@BZ`Yu_3yln�TY +V9°ZMX(B9GuLHj{~NtGOmY +5Xl0!e>s`pL*' +"$^E {O<î\HF׏z`VXZQ +%Nb:xI'8BQP0=7>W/qk 8ɺ18zNtVBi R#*VBh @;(ÀSO"Ut"{X2HǶVj +Wڲ3>Uzz~f"Bp J0 ,P^  0j[lNz,%M_ ƕ= + L4ŐSX,J^OHMÛw0m-Z$ K' +Ԕ/Yz=?({vSTjn j4 3M= 6;imGP!(yO&,Ů1c[2OCGg&;-ڭ@ @e6smJN4Κށ0BIfyx j5 н"qf  (]I*Fv.8vRAA_֊V3<7RK*?ymna~M g.�NNPs11ȘXyX'0H\l@vˠlsͻB%.,& z U@6R�i̶CwD&}UޡP҉Eg]8*8F^X 4흗&8 2') hJF(+kS6^z L2o'X;"hpkwҪ91Bw6| y5tW�7Q)*r}xeStS@TNLj&/6?UC/[Z_TQV}2ޒhf/bق9µAGef.,{klaE +eAve#&|կkg,e>j5Zj,v*HaN>$PzR쫨-%w+̢Ш u_"n6]X_(+i5>wҚQ}dOd�z[q*ĺ.-[-]XMnFn!8x^ :j~ 7nG彻 #é`!dMo'a|Ԍo{8O6[Ts/ъQQLX MRA_<xs]s |чΞ w0|#u#+z>lW߫@.t!S Rs.7 jP~/DHo&ʬ9Җg΅<#w0*L2ҋxʝ:qBo^:Uadu{iԜ>+f0Lb=pr.dz ~amq17d%fRqXk}<J"h_ Q|ݡ޼ i8Wag;!"kVmywoǢ) +eO`Llepl$]A ɐ[= '> +Υ)0d s><iRKY~>[18^_0[=! rM�iv0y?)XS+bANwj gR\,MvrrzWf@➳＝4ɽZUUMJP:fn,[[3�32ڣva4g<A)Q[pPPZ<bnvNmLfb=E [~?g3C)@z@B`9 +Eb\VXx4ȚK^ +z]Ӿ1%voՎJrNwQ?8T +}E-=Lb@WZ#$xh[xSeczq3u}ЋKt/dg d +@›f %MB<gDx1蟵4w#Û͓}%nmޔk*Y J`h۬jZi:yїfJյ2rycZBsZ;mb]h/9jR+Qɶ2jIʸ ]^Y:]?#V� D^<`l!\7ny5gc%E4;K[#Mm<q#VxmuK . lq>cQj8Tw 8`9b)f`J]> Im ]lAx58p=.?ؗ++g>%lp}t[p� +;;Zp? vi0Vyw 'iu If]4Tf'I- :K5? +Y_RVShpcY6pTnR{'nzUwO51Vr>ҧӸ�֜!8|PtYȸy�ɚ}=VKl6 "H`CfXgP)_=S,Tczk?_FG41<*>9Av\T3u &k6=Wv; E==b LMa{yxǂ0>j 'y�I0k1"9 --ZMo'롴B|)Y"pbO2siYF&HpA89C.{gHg '[z9|Y+quB`o' U c<;ۦw3RdE*ɓ}60L^owf)'=bEB{g6Α0OA}�-QH8U*CS+�fΫYuPc6`rb�Gp u;fh;loդHkSF,Z uo^JɲZ<M;0DX뤇BW^e9@X`i/3JMSEԖ6liV 3_&t"bO-Fg.UA)Ec\2Sgzœk5ub_.BtTLr޻0 %a9$@ N3NT%P7}!8Xƕ^m\ ijiΐ +^ޮ,#Eɍna| ,FYق�gTeҪn|3kdIn9:}K@i۝)g+vd:v@(+<SU{3x-[ _vIW,v_%s|<o,|  Ngˬ}}%~-[0g=X儧3u M1WmӭdLl3ƒ9L9j`nlj.S姶D,'>o#ݳφa `.ii?V1^mO YrkjkdwrWr-lN1i.Ru2n+G�펒`k/#1>ro$y^m =_;)K-hB`zS;A%}x�Y0EW9t @nzxWO0@LB# .>hyMkWG9"e r;k<P,´ooKxT%K2sߨ�k܂J XZۍx[#93BPZtD}EwY{77ߺ3Khkט& mU, 8ȥ�p:_ 0 ^N6螁Vծ;?c;Y4kc.p ,Xx |d`Zsal""{|JCHoMiU8`p($q2= >< oNvj% +W_ `cרK1:U]*`8;[IKT~)gEϮ(oR᎚kmQ;>xZ7%�#\cw�&&vV?~"G3 πpH g |zao XfߜEY($lh%$2kmQo;nSmgGwp>z�kt� gZ#W8&ɽZ+|l툺Vf(;39 (#Yl +f8l8m<@ YPs-qpZzS5~rN>*b:Ú%"lQ{ѦUv匊<*oZb}Nְ#_L@ F>*hs\j6j+8+{i,5��=Gn{@ +*@oZD(0f~ U\.~vv&} Rս@@>$zn)>tNMRcQqouWX",%jN4嫦Մ`* $˘>m즗۞y ,KcBwjБ .TPk/Csϲ`]lخcYW00dad,}nͮKg,ӭ):�75b�zmyК&_b%A +l62kcWyl~^"D) }> crGT0a- +xN;ȵ)7yٚ+kraXSǒD&{VgbLEg`I8:+0x+4b|ء4-t%?viĿ͹ۣrjw֩}s2њ,%}DԾp 4z'ۢĠybDwy,l|a-Ud M</HОMyskS.()yc 53RI^up/2 \ +<M;6 -uݣm@7s]azEvAo>&@r 80${oAB_)+QfH0K;TGQZg\~ڣe2R* 3Z# |'vZ(LzLϹ^g^ +ژ1�%h�seJ5]JJW�]U- ^S rhxZP}p&ܰrbC_%(|Cw/JWIz΄OB+pp l,ΰ�Srb +wG0Tz!N!m*ZETmD#.`SߢdI[y;  rBqQgPd_ `$.Qˮ/mu|L&`!7�-c*p"c]!OaqT}�]P +8`'?I9gh'į;) +]M d?hC�w(]6g-?5G0н�%P[UjX,pwe^Tv-8Pb-Aaʱh; )~3)ZʲHƔlhW)gǧkK`ZnMa*ή@>k zU' +p ̮M}4e|E 08b%˭{MI%r(Bvca|m:zmMt4ݟS]_Z8UwwL}Є$*XĠڋ,$'e਌a= FG`Xm^`@kgs山/H +r@9 \0~hxS|&e B>KFSh2aFK]a͊JRvP\#}يf�_Gu9;kZI XNmM9+a׏%P?zMkF˺66#%|hfSL}AYjC$XM g%9";b(O{z63<vb F̰NB=[ٟ5q҇ �b\]Vw+A0Fɟ Ø-X kŷuW9TRVؒդ2rő3m;_�P X[UDgM&1G]h9jn<=(|>HHd¸ɿ]}dcr €iϽ KaY93na[6ua +藃Z�b�'%0e@J1 AN;nt$qrb.q1j7w7r}٣Y./[o4osˀv �NИl5dR}Lx10|Z:xmk[ ew<R]Ob{S8ʣѳfm S }ʭ>F o9anmw*.k*Kv1<`aSՐ lt!+/ ޵dۨ{~o>vW$4j ͼU|"ESrE9eJl4Wy]@r@5 !ʩ=vQgcEFpΜ5c9kYL02@kQYM -O\pRf[tL)*r;cWRdvռq:o" [DO{;3+KX]e21ld䨶d/rѪf4iVYJ3o]xnS:_i ^/8ruU!mcn28=2J1 jK~ϼܾhC$&$O!}1ɒQ Gޗ~l|_sLkf0i.)%ObUoz %U9:�(vRG}i(-h3tqS3TU"N즳=KA Co-Z}�x~hį[~5:wJ 2q$=GS FٹlfT$omR5Nal/$I5-ɇezŲ@0..w}:rr#z +$+5ߧ@T2cPDM Џ J#{E7 +1DH\'8ɾck|}ڈgq_, +݊yskaRl,~Š/ē"jq&ץ= ^4 .GA=yv{}|WI%) İm< +WYfO0Q'r,ɷ:O*SdA;4cH0X +O՛֛K!u~b[_o-N)WA0~{�&Obg\joN%x9a0 +&#Py2}H 7vYu6 Q4tK%gJC(E'_bTZR~GA2 Bs1ڥOFONE<}.'m%l,ǰoOGw7tѽEV՜^mH',:)<CYY=Id? &cX v4=D]X ,'\ J6ŀldgs˵:AX7<|XDm!/j vb`<=A(Y&=*zJ0 w,y +ni8JdC!ӷоj,A4tK0%BڿD%@p696H@|YNGj -taM׏oj͵e=pJaLP a=e79m$V`^ $j!GjGmٖ*_ZLȴVwh URa C%UXeP옋#$�OkBo"3:u]`% >N ͤ<|'-{(WKf Nm^ym[K`'"\;ŖA Ԙ"'&9``Wu ovmPȽYl LE.Bk}EoaAT=-ЫcܽE߈TAAS޳2=֙T4+[5~t\}h<TKp4C^@eҵa1.|~%'42iُL# XdpT)5 RQEZ%XOag 6Ϛu@Yfm@bmfEnuosXW2 ӎrjI>�%LD&y!k)0"HQާ9d}"=&Bp7\y#}3C\7U +s+G'MN,Bby;;%)iR!̈jybW_R7Z3[2q>kgOz;ҵQn]xۤ& q %%DoROS LLHoo5O@{fAi-3N% bؒg!H߃t(c}`wg"Dqvf<x&/a@K8myاjp)3WhW3aU#^Sĸgn8^9s3&; ]mbOsQXFfCnPdq%Y! mQUs5AU2)Q7K;' +*[͜ѱ3N}[} -\fؗ~_2ોCf dDZx&T"C,Ԉ8l~0v$yz*CX鶤KYAH۳n)!AȿT("?Lٝ(Ѳ*�au-9S&ܧ|ڝUb�$~Ga'(ů`697S|TIS Bi %j k8cv}.EcԆENZ1m/ж f_|U�GoqB׏tGa]]0؞Z= qE$.`r~n%c"=9IYx`L֐؜OcDPS} \0qME.!v:ECW;`&"Bn4]bp+;l9kC dCbUv]@5}=TղKqqbqo:_^!<\3YDXU{˽ɠ.GD zVQ + Lf,=zwn`RZ:G헬`G;~Q({dz@RI&O!؛z->nzV<ƭ 6>p:P]ak+UA]W+K̄2I$!հQy=K�̩nn4_g^+[c(ϙ_n|.g? X`x_!$Q՞p{ţnLuno.:^Z537 +>~ 3vqT,orv;hJ!jq1,/0ggy%K{csd٘tD + WN:dY�Z.zhU BWRl[ڼkҵl.QeG` |J^?7h@wYNw H1)&O`R{ج~] +AzV*c&[ZPvayե{NDv'dP62NvTB#$ (� O{:hJz @?;Wu\gƽ0^H0I! %lx`tA+`tW +#"6hyj;ikoyًe*m!s"8zNϮEd<LjKw�l "So#8וل.w`eue20 ]% m]#`aJ-mXHzEu^uY�<_z`y0մv\�b Дf"6M M=2D 9cA=]9m2o7PSB?u6 ϑ~`H`HHZbceϝ 饳) 7<=o>m�h,Lѷfqy2#hp�b mŁhqgA 祔7tՄ퇔 C*s~[1ʸ8L]^u c�ghkR1diKp4~gqOr֐<jD._�M)1Ϭ-h&WGGa"Y2XOc룜)!>fhrX߼7cR&9okq lCeU8-Q&܃Q۴r_]pγZ1bv�37,e9)8A+ +OQe vLAOfV2滞ŚwQ6e%s!,rihq cVƞ!"HΪ&--=ήyX!s-'!]v ;n%gTZӫ'v)j0(2)0~ߘ,HiKnkėn`͙mQsr�$je/t}H847*!9uFDܚ k[f:ώ%p Ol.Xm4rGdTVi"~L^M�v -4 ^[ђ yrQ_]ʮnG+PV0nF+\/s\Xmo}uz,.9 bNpܯdܢB},ӂ"Vk�`c\)�-,@TGg)@i|+# fG ;;J%ۧs"/z ]d=-al'`\Jm2`c r"�Gd=\FqTGaeai 7uIk˳{`JF2PE\>tL�rWa6)N@|ٴq[f,)qt_jӝ!<Y_~ &d 7bQܝtr@t½ZCWo~c<PwRE?Ϣd]gɸ gg _:}/GqnB4rBnӀ> W=՟4x72T8ڴTLb2 V\p#K*d3D;x`zJ{T\Vbj0x3 +tْM9AжMSOhgj۞ulVS Iz\.6LBz;c&`E AwtYr J:or.qv5+(fi,lS`ɳmU +VاHʫ?+>Bo]$LGٺ19Lܔ>S轢99? 6JeVA ሇh¹DuR=MԆxsCUtn]iӉ)4fC7+="QnUby^js-Q\bJ9u^1+W(b?Gӏr0LD9r*=2Ѹ~TuigraVnrٹ1Q&iʰ8}IW8QzoOo�hS/܌=ЦF2 +VЧ[Yn[WƫuϧT\�7z. v0ndHvV˩$>;vy+YDgSE �Ul{1[fePbBFNH*YxA,><t<WYj3P~'~?,ֺ-ދӅZIp7a<?B +"һԜ;ܮtw*0Om+ȇIӀKΠ7مqe lH?pV$tW3.fX{VgXzrq,o]aRDHs52OkkW[vkKَG;?#> X4GxW6Y'/ }Pz?qVڙ.:,t%@l�8My à5mSd?{ZPk.U;OW%{z5i6Og# ̺W]AQG\X;{*w܀q߰(˕쵩%^~9 N$A]y#]%i5gƈ-@+#w$ĈI;E�CN x5O@37dr�RφtC\ߓ~ 'sBY�,wmScX( U_S3fU�Cnzg<rv'�EmQSwțvyu7!@[_Ώ7yaߍU9C\B@3qT ^,Ο7=';x-96_,$q�"'<̞ǀd� imv9P,WL?3<+ ݻ8d{m*AW^xz� 5a~H˸+7_ՅcXr`7JxSzס ~B0γ+=g,AQpIN%nB\+RU�>TlW= ;a/*Sa_T9EzlǏHHʵ2csBm9$p=ҝ9UEy ݜCZvצp[(b9C\,+&A�<5�nM ,tt1UTͣ *sϐu2D)1zW_ůw*on>A%Gcu+Y]w `B.[uqy@:dF- ! '<;_=}#@*Z?t^ZV�a?^lO;ujccWYƊ?Q%z%0iz,ƽ7KfD�C#k,͓(n0"pGa!i[cP tZא]*EfSc[gtUڂ +p B[.[U|]ډp ?}}0&{*sm4)qB})K{</2Ncn=�W6*.'#NF([pzGT0FE@$xL�6j՗*s̹EAMDzٴV2�}It5*ՇYt5jJ*6<ii2L^3rjub�cfa|sXPk}gz21]WՌkoH]Mݚk& +*GqTWmVlz˓ X7exv`sD?i7 *<@_Q|c�lb̑<ɳ,S툶 dE~i)67(c<Uf +ѳkgt(Ϯ p,-e%W6L5EAĸX}bP#ë,xBBC.g愭9UW2c <wD6'(,n+em|2bW4lmihwd ykq+ ICI{hWQrB"e?1ڡK$ۇvM:;D41hG/G٥>׾C\c_&�8}CH.�V�R yA!Vڅ4Q7S bVwXZmA,WmQ?ߋ!'kaМ Al `l.k6Ww&;v0Y +9fNnxp,5\/c +r GIc\Tls1Kp].<{y@-6ݵNyhwy׿'|r:<rhAXK<<tdߡξ)U׼{(XIkS.; +Xdo +`oy9F+An,>| ԌϔR+-ZנrlgT`^ι^w3g;?˻$ZS|[F`[ rb`Pc,oQW-F̲jǵ哝gzj[m* YŰ6:@>4? +&GU$6uhL'@o$n29GMS-5%D%:G[~ %ZLK>3d-0jI4ѫVMP6Own2LgU-1eD&Pc77al/fX!J\&n+bggOwI4T˵aƠɄGŸ :w%%.VeZa|`Ƈeb^zz4bChM k!uRƘm�> ?ƻ{;Ú;[:%+{{}5[]rߞVrݷB�!#<6:�Ae\"+ gHٖп1~Oe~ȶ1ޠV{- svV$j asO1=TN+*LɟK6=J<zGѦS(ם҅ Ҧͻ܇:ͳ�L OR{~|kR/m{AfR{fe/ξ֢A34,AxHRQ%uK ~?r/(p||o{+WsT<o Ypm~xߏzk-~5rxgYPvV5h-fG֪w7]gAƨV[! Wm \*KQ'[Znv^̔AŐ8-%c,bݭh?>VBP37st gk]4@T r`>{̳=!j<&�*qK +[D2OW?9`T�e~ksTޗVUivʭ b>.ðg&�c)ʼa%:oiMG `8;:Ii̩J| m֓7ѩG* UVZ&Eۆ[.m&a1" Xz67\[EHJ'ӛ�ӋqhKj�H?�$[ PZyCJoN$5o%qɸw{m�&Rq<[R0"1sVTu?,8uݸ- 3q2w9^Y<;)n�`jG,a+=t`JJvxS`ԠUκty(2un6{g#`^!ZF\X lOs ;.6mijVr³r9HTDF +Q"S%5 '3)U:paq'ް/}mXlOm-u| jQ7 E5dLk(_|.b'Õ)ΖpJSNDxFU.SlBj65ٯ[$7 p$ń<Pג=cY<`%ѹZ̼Fׁڹ&L|Rb%7BIܗ9e9Ġ-#rmV\MO7a7͇(aDѶ\M K\fPT̨8^hM^Ə!*֐AՓtaLJ�*CG�c/v[KkE 2vİB[ٵ%l&E^7+b^D[ +h)Md VաDבAWGt.,D$ #!ϖ.@)ӊPjؠ x6޻]G�cLZҚ)SmM7�Όo8Sx>5$49 'KB G0y]x@oJC"!Wc֫MiB[OЫ X1A6T]wF*GJQ^L~-n⮬p\DMl⸹6iS<�T7vWv�KR't[?'�{]xV=4'h,b1 +!5~?, ؑ9 zZ>ePv$;@,)7{/]7`#yJM{QTjw9K^ǣFf-lZA Vߧ Z;?fP)2Nԣӓ<O +<[8-XR.O\f<~>5RA]1DIs! /ϚB 2"<}$ŽbU=!gKe+wGOG#B$`�g�ZCK/L鋰y;҇BXC�tYmLڎo-m٠q|=D#14@-…ZApva__&<ig OiSyH >үY5 �-CG;LBlFV5ـ$\�7)*z-YQ�3 `yYK+丈ufIz`/5G73'yTk+jkh. +1u1m�ԱFqg4Q iKg?"9Ccz>\~|^RI3$/o36Z=`V >"p%KC}_ISbyH|�`AǤ )O?4<ip6s}1c,_߂WNlX>ݦ@∺o~>*a)һ/yJ:Xc{c:r3':Eu[PlLLtVgc]p(+SQCm khb+!~_lF!>LLX6n9Gh2}7i?Gɴ[ȧIur~AxqB倵,]s�cn)<Y:{l%XPG43BuK$w$:^M-/f6^7 <G�4D4,&az|xm�-,:,=T4|c\Ӯٍ)#[g(J)ĆՎT~k$/Y[oTO>t̸:fXG +cEqq2DwU9~3�_/gjs3OJb +(G5 v57#PQг�~ +żY \\plОa�BG}fZlz +;#Kbdp f<fJE|G[[m$XGʼE7'3^|ϸ飧sbWَ*=KtA?Pp[#.tej#^<ݛjzDAtcg +cy +c,m1v jd0%`q+%(((7j#_SLpV`rFI 򬀽1A|fs~^SX]?%CY`r0dJcyJ8jyL$~Dڃ3P=j "S 'h + !KpmkPA]vLͬ^YI80c� MF_*6Zߧc.B9lě_.owš첡Z!p @~Fz^-[O�9 ;6+7-H(=%C^̠RZ|I7UW"nׄH1/S[rG(cК3R5 o&>'|މ*Y͙j N"=ǥf;%8 ~MvOHLj:fY(nnB'2W=3>ۅy7Q;!i)�N*}lxѽ~nU +|"fQzd}^<#'F h86aț_j|\#ޅok<Lթ-:4.ڞH%,`d?|W=d,\ieXR0lI>Ps9ٜܩ(hy%w bQ2/J9Czv+}w}e]ux)[̴:nOuV sW&GXV[IJS) ֈVWa] ^ՒюQBMxEխp&K>7Y3#Ұ (v;@1f4}qC<.K9Q, fƯư%zqo=s-MtBb\}&y +shO`uCgWf] ,_=l"^1{ut &̙u6ED|2 ;eB1ym[~dJ. nifbI"WZx˯AZ_Jx|Ǝ+]ZޘۧүϱUdpkЕ V, +kDUA/M<I/$VY;?-F֨8w㓟'>{lL1<E[txǶV=�.B0%<~1@= \;Q#5>l&4XSUU#8Mq,ؔN|Q:<PNz+z3�B εm+<&A63ep$^c +kcrS.f AN 6֑,rdaT�^S֚WN-gV cGpeRsR({D?�Ľ/hA�MhMMuZ[]µ*zx<—ZÑAW +̚16:uewi4�{v'9+^'_J0k@""k&6:ۗ TsOVAۅq:#2Jo�⟢?yj?l[s^@s;@3v �[r<ۺԙ42BiWd +bsufۗ[GZ- ZX�ϩ[zXwTE<L/[Zsøek3h,4Wn Ǹkȸu xj#`- +;za;92"kֳBG覇0SIi3[ghCl:oQz|ge=i/Ei*F`GMMw8o[t9DsԱctpRI}mWY{!#Ym]eL2}q`ǰzJWS7+BŦ(/z^/& +;ER Z[cq׺Wr}.*-]WY=+ e-N<a}e+%q +,l{B):X%A j L1i V!僀n.זpnj;CfO߱)4+Yy9s^?vvC-x[ w p .(yiL8=-QOn�?2x`\']CF/ CMxw|q3oyKR@L#c� 9s,ěh�1p9E+ +L {g�Qf~<v/n()tk)ײRϫ7WS�8bm֍kƷbɪ$%. +ڠN-FТUxIb�VY5CnOn#3yjΌX=R5'Y |nxtk�],gO Y_Xi#J\�a-43m=nu,إx$?v%g x4Z:Mv�?ߝkQ#T)[洖ʲX@Y|3n%Ŭ0`|>8yh&؅Mjշ V"'VZzy p<Y57GW'.x}n|NÁ߄kEn-<vm܈}D/� endstream endobj 188 0 obj <</Filter[/FlateDecode]/Length 1001>>stream +H[lU Dc<x TbbLAE4BxR(XS ԦM)nitgf9SlLRڪ)ko&MQ=|u/_QvMK{ֿ7k?y' B=�pfh|;\kx+R�=K!_} :�SkٗޗtNNvll7`ѻn'QY?Na�{lkQj6y":6ѷc\ XntCD?� 3f.6J+nuؙ [;�ZiId :�8'Z<j2w@0L}V7zAt +�2ᒥFU!gk"憎}�u\Yd :�jܰlV< gi#�u~?Y؉Y`��pcրk�1~zc#)YO?Na�z?x8RS,{[@fSyBS� 9ϟ>).y!�s ś,Y??Na�@~vz4fygTD�2|2So<,)�/{m~?SI.q#e :�SXSWHp)7ri#�Se} :�lif\{FϚWI�&/ozAt +�Myƞh:j+QV0ܣ?9vHS�=Vvk/uJi%�'6_, +doAt +�˂DM�^jݳ?Na�@K.]U;;/oT.{S�VTo{MCkG'g�96W:�deԵ]/-1TG}'3y;gK�8 endstream endobj 189 0 obj <</Filter[/FlateDecode]/Length 1009>>stream +HKw񏓝t2ֶjQ`+)N,2C6ݦdfcgh!҅.iKߣypvLL.څ6. h[3 +>'~|?Q"�N%Vӝ?E\B|<w\=W}_;s y,k'�d׮O +zXw0v+0\P9[m1)�0˛&oup +ɞ:]k1)�0O4Qv6=>k_ +@l5UĤ?�\Y5%PB7U7�g#w'Ye1)�0zo-�]??ՕWAL +�̗J%;ދXCnoxHvRcDUĤ?�>2G㜥0Ue��{\)jPoM0n`OrdFUQbR�`?/I [k=+/ΈX֏Te��JV}FNJ}vuȼ$yۼZU1)�EbuLp0O-?]/({ &� +oz]9s{ [Dz{lZSO1)�ǵND,O2n|&f* &�xĵ ׁm9do3t#}ޗ6CK1)�Jޞ/_ [ݖʵ)q3dNf{,#� w7>i&_E1)�s +߮8׵"`3e,@?Ia��by [߻78tkInץXc��[/t^jYnL_WUcuAL +�4]/Z29tg `�)ž endstream endobj 190 0 obj <</Filter[/FlateDecode]/Length 1415>>stream +HLeCMLSisE.VJ6e1~4~ + ?S~w܁:~LF6(Bh?nevM}zxy>{>pBAU +fCO:⊪*g]l%W {L3Rw��IR 6#w~E7מcMyC@<)��o:NΘk;ڡH{\4Udjh[f ��Bړ!6w\i�ѮγͭRs9[^KZ+XÀE~4ib>*��0 +VMȏ=zK;˺MZ| rM(/tpi*ErNJ̗2JA��B)25W4u�skM2B@䘀%KUndgs��0''I6nm~n w}mG +c +fX~go_rZ?��6SfC?!v b6ͭcu_I"ǘ4uƆն}㼣Z 7-}9��pe)[HAk]}gu{]16 kR10@USRwn&'Rp }9��p I\M^EtuW2�9CB~9B@f#JbZ.c{قǿ($?*.��fúܽ^vC/}6�Q;/ٸM Ƨʀ3/_?E򢟇?��`,N%Bu2}w-&@lFH4Bjv?wgE$ngtL9ӚhPx{Oޝ2;6nr[GMBQ[}>o��xO+sV^/ #g~�Y0:tzr'{"4<M<1*ڛ~kA.=#��x#'4V;ꋏ`bMEI ?e1~LR@__l_Wx{<��,|9W;݅�,D~,YSԬ rMKUyy+rפŪ|eY:.��؋9Q"7zOʛ.0ۜÑPtԌ ryHIvV`' +YPڶg?��@I|�ALbq5yRxR?��@.$m ن.kij ܍3?V~Qj6?O +��MDI獆Foj_!;ueYKf��fDʎFMl?v'=l#sRxR?��@BHd3 W4S�37cDē1;`�t endstream endobj 191 0 obj <</Filter[/FlateDecode]/Length 1017>>stream +HH]e!޲ AD1p41\!+6\A]M'kmsdÜBlή?=zUwn.F7X[fX`,ZfDS}Οd<Ld��H[[|}aK+|^VcB�HV u>eWMw +BR=lߵ��'l-f:?g:?.֟tS�TqUr%PԒHwG`δ]7-r})�@Yfiz$ڕKs5B|oܝawKҜnAt +�r*XmGI="_kWrw)�@{Hsj8uZ}.ׅ+.v :�Hu5F’Hq> \VbݼD?��:byM~OnP+bn8׾W97�@>mCҜߜT-3I +e;6�@7KlL5Fppף<^cNǟ-dhsi)�W>lowⱍ{&O~xzHn :�YIΛetMi&ws2xD?��ݹ^93([^sqf��xuϯ̦ oؤwz"n :�u/e ੸ ܕ{?9 e��x=/z;{,KTUPA]gGae��xQfYXh$R=4q}_[۽?Na��lm  +',iNܗ{junw :�ۊDS4nʼn5wRxDZZnAt +�ejrQХ7qv'p|J}/7|D}>d��/k3zƱ#Ҝ0pB �xv9 endstream endobj 192 0 obj <</Filter[/FlateDecode]/Length 1008>>stream +Hke{ A"E#/BdT:)+%5MMcrh--l[;s=9/FjqNə3=ۏֶKPi߷;/=G}E:eO +B={ݵ�W<(nZ\pGd��&O^t=p<pT +3u~)iޠG1)��noىN7"K0Oi<,?Ia��65o˫ݻP +st:M+nAL +�71g6Cшl:Wr +32xi?Ia��pҊڬCY++[yMuwbR��ܝs_Nm?yWEvtc9c��M̙'? G=ɕoU &�Ҷ vkC^ur,+Cٵ;V��diu?=s!akknAL +�ѱ꫏9*;R7tw[>RQc��`<I7zs/qTLQ��Ab]?zSwEl[RT7 &�X7au"*_%nAL +�TAik24x7;/b;{آ2_Ĥ?��[狂Ɗiｈ * WJOT��uN}'6?Ia��0~R7ʶuSTv0C>g'yBJݰ?Ia��0sĦCwxKM{0܇6pfĤ?��cQ/=luH;zW׏.|aӕ &^ 0�>| endstream endobj 193 0 obj <</Filter[/FlateDecode]/Length 2198>>stream +H}PE^TӤ%2Ӵ⨑ jjA (@.yQ^D" qwȋ F(/6M ti;}'pGgdg]v_ ��qIV1#S$#EUQk޿ptǸI`iroWQ(L/<|��"Ljխrદ΍dbaoA@Ykv{φ4)-j*>(~9���asV-{Iytg߽1Lǝ!I1"#KAHC߼gu0!���XۨZQ6^eU0o s*H_{Y#'LYib9<���:X\ae̶O)=1/1~sKs!}I)k��uz#=F;[N{e||з= (k}s9Xv)K�[l?<���(O*-%꾖m =3Lw%eYKsZ(5y7p> ���X͌-1}3LwWk7tEK +* M{ =A7os��aM?%۹o030]?UMs5֐L0dAWsR##6)evv# 4)d��q0|?o^ \D'l#?:4*j+?4=G!INeeu\c¤e|g��Y71{m/㻏a{~CFc|oIeړ> em(Nt<),ܙW3Ҕ|K��rJ|*w|qOA4L箜Ikҧ!RJ#ƵbQqe3<��kMT}n{rחP+(k]^$G ˫/&;}d"c ǚ��0 ~aKncSw_ ֊>V昻(kS B%Zy_'Eo��CI䭌jQOBԇQ+"G#J1wo?P+x忽$zۤE"xѽ{ΏxfܺҰ:(I*g:hi:&k-¤e@j:},U&[kȹZz��07̏| + Bz+0kl5bWlQVF9{&q 1 ~<mW #AV625g6Wd*6$ZV.4tBUJʫ%ʼn?37[\uTzz \Fh$sL\-~��{͋q7[Y7{'|00s5jNOdI:$+-Jx0rYl:/Q>LQR%0v\](b /Ow5D�]TVr|ٝ_~Fjg}*a{M5#^6I ~!Yd@rnp7XiXFbz4U.+9de]G<E'WuO 1?@o͎344dӵjg_;xs�A@Wj_u +VV~?.1w?P#O T$w_De%/o%ۨϧ|r'ؚ*nԊ ۴ȯ:c_hى1֝0ɔŐ8J]$;}I>!ۮ#w}3:e<=*-m<fN��fGje1ʁ5x2x /a!fSMG $9_6 *ҷMgʢLk4B}Ұ(եy- ؝lKgˢVrA|ȹ},+|lwyL^Er>J-e:�'�& endstream endobj 194 0 obj <</Filter[/FlateDecode]/Length 2737>>stream +H{PSW/G}c[nm]m+NeDZP-5 PyW M½ܬ"h]ZٙvƍGo~3ιs~G0%3$e_ +4Ph De\uwYS&00{~~]M҅V5;m3|󢆬)b'c曚|UZ`6 PP$vg޽"eL_Mr<.ZgםڟJC{sUxm*wؿsrAAl+7Z?_gN}qӡE\CH +E曑̳zlcV\4X[Z&e i&/8ٹiWC{i~hv:Y羜?GAGe4oɃ^?or\CH +cψɁL&s2̷@PZL6EzmǼa9[]b^Fhء80^)A=xtcn>-O\l? |W Z.fZ6_'TAD&ϛuW?0<t{_X U6fQvoͲ=k{<@'mUdo׵ +8>k/w/nch*hfȳ2SS99[+E>|A]KShݭ +=y /Ⱥi\CHǶ<oHts|5dMx$_͐ޝTm٧:sê߂7VMM + sH|Fx|H &,0*Fb__?& `oMqH1r 2B{OAA(w[3CeW]^غRĿ>:Gጉ\CHDz1CA)KdM1;М%Z[fnG%^YM1D獌!j(M~)Y!=EgO͙O'@?՟/5Ds߅}@᝺5L^5[S)v84KFyq:Aq+ U tʓ-kt!c{?B*u7?0�" p*R(JL~t發bBbYijj͋'Š{-# ZwxxI6 O%<`";Zk  Q9+'iǹӅʹ#4q睠PJ  `AfBh;θ иݹ  ΥDpſfKFhU_ B + E,uliuw4^CB|h0!\wCHAA.f ݏ:՟;?f  8gR@A< ,t͊+85`gzh86r= !AACpi#4y$s۟=_ڗO 杺`)  _RfJ^J 6-1`)\_I04y5z$|>h&/]j;Fo]@˙>g)*kf}" CC$kKWwIun5`љ @_y?0?4žt-̕bwϫw%.{2t,1=9w֗{EAF@a&Yi_[~=ltR%*V.v&3UYeV+ 2p%&Uh_Bo1V ZE!pE*Kk ]Jq*_CCxd +lLgAqMFC~Usb:ߕ;#SΜ- !+|>4= Bw8{*jFc+M~n`MεϩbjE:Z<_ަ&%vl?RBSikH:wђ'ys7=tRI?Ṡ ?|EZ#4y]h~ˆYiZʬVAnua<;Y.5in3jfȳkFڏ˙uͶh&/5K?{`";XX_"Y[]<]T5Z5& o{ ȋ+0D^kʣΤxx˙3E!pEzUڦu*@m.o*?ZL;߃\VcSq˒FrBߢ7n +;&s2'xBܤ.ϛd66d؏]XPVM7SڪȆu5yl<qӡEoS1r xVЪȌKX/2Wbݞi +_ r*M}2Fo�Ԗܡ80j9NUej#Il.]o36~uӠVGgaTl(A!Pܘ"eŲ g$%nPZaжnn)oX.F(ţxSKx0jc<;ҹjuzn׈ (N^���QB endstream endobj 195 0 obj <</Filter[/FlateDecode]/Length 2581>>stream +Hip#p 74 mA  9ƃ|!G!_dY_+viie&덀xo7}w};>FH`t2DJ|O4{X$"m Ƒ¶>ٸzCõ6sSRQLK'¶y6XoLL]vt?o6'H0W6~r0s]&=;k 0U;Zaϛ96 sQ ڬ_somu{oϯH؆fo?+3>!4a?ڮepw WE-pM:EA#Q;tf+|BP%BC\rs01^;P.; aH_~fԭb2-m>ηqUxޜ zT^IϩU }oUrӕҵEpa/:?\a<LM][C*Ÿ{xLrLm usp%?A'nIߓ?~vu{UAVPG%;A~sC>jn7&}Bcw[UkK_]בikǁ<ˑs{5$Jup~ yp]mmb#uIu& 2?8e!jqȣ1G0/^߃1u- .OA,J 9n{2䴜r~Ի9D0^?Q;Zu/0 +Qlš- +&A.{] ժP邵[<o?XoOdC;UGڬ>>h c<o~pyp +GZO@}}lm榥-Qlo .r{ }k8Cm! |[77u0NfwX@NzNVNG١`R�IΨ"a.L髍35ܤS6(c l5?lZ0K@ v@X^v}B`_7.q3B&&S:g=虗ur{ H~!F9e&na. 56Zʙ`ReP|a9r~Jʢ'icfG9?'$-|8I Pm +co܇kiK}\7ԟH_Gf'w6Po +<?ŒsSSS0G-=Ad`NC rS{+ 4=gJ@dGʯR==PO'J6W/0\ c:e$ZѸyLjN.fO �tnK1IRu 0N\cAXzq;Kyj\/evW9;WXp%v]njoi*|vp+Kkb?o! ƺi7 ܾ4}N0|nWK9'P`1 (7K.+ +ߪ&Uit mn(x"ehq/$PީFjvOq5\|[]ow-uڎxk%KT{L`?IdZ/ѫ?6 sJ<&xe<Gkcw)}}!|ebxWzބ֪xE~%lpE;ADP|{&J` t^)gJ(M %o{SERTQ5^ ">ruP|j:M~?oNs%lsAVA9ƺi1m8[Fez{ Hp&UcewZ.#''mELcsAV&&S7E^~ujkBAYQTxۃϦw+|v0Nʙ`R1;k A;Kf˽AA1&qiBgל`-7sim@xAAfe1Yr=q'3%^z;˲?R9`R  ̄")˨z凳(ݡ/8wMUR�#AA`gtR*5˃Sv*evϓP +AA K#\vrC5BnE!P}`R  2xm2f֞ʱ{;tfK3F(  ߤ.Z] zo/q5嫿4!e  F~b9r%n)^C1 _  V@aɵٶn +xzm)D@@A +0�b endstream endobj 196 0 obj <</Filter[/FlateDecode]/Length 1977>>stream +HPT_Ϻˢ5AQ-@t%@g -+X  l.9VhjL%c?4wLyYvm#gϰ{,>_jluf}?EN76΢E/d�KjE/wC˗{a'+{m `Z_ZV*}~ZBh|a}vaugk}5u's} P'н9xvr}?401w2vߠ8TP0&|X!B9I_>z])9$u+sPV6(J% u~N`nuKtIOJ??Ǘt%3^D! Q{iA[m +5^ٖ%uumz6?ׅWUX]8\T9XoHc5Ru4TV*4:gxq.GkLs]@ +|叔X dlїu Zo<b?qp:_}U6مjHhUSxK~]_53t~#x~&Qu?wʎ4f3 <os"zd_׃FRˑ?6͚@c {_okB_88D/j|w+-}; őI׼5~]  i (}X&ct6!/{[Cs&|m鶜z 53Diɪ8s>߼Ƃ5m3:O#z�xどؖu1T8WH8MNJ}YѠMkeB!]o PBBX][5XLaa cE/B!cLӨ_ @+N!/;s8:'cYr ������T燿cGë,1dN ]Vݮ /*A)Ht������82蠧sSb5;n\,KKbJ����������������������2Xmql`koz6=)YeQV*;w??v|unڒnHsf3^^nVDzoh1k(/{,>??6͜7+c.j<>Y4anvX/-MoY15>f4jXJ'j}iI &->QMGp0q?EA`Ygn-ڑG}0z`=wת׽I﷑̈4OݳeSw9cjm&W#Y|Egs>E'.P3OBUE#s7_yUionG6]PcyAX=h/`bOzhhع~PA^mGckR+ݿokpM|gj KD-!cJ}`9urkCq)S.qwvyN1==(s->4م U+\Pcqtdu}G兩fqx{<̗JcMZ'%|\}CAPWwس T:^;{5܏37 +ݤhhպޱbr5˗3ڏ̝4v0r9 +c=6"1+2<P-=6dS&Yr)njo6CuՊ V˗[%[8xgN> dD>y23c&+޼%DOnSh 5gNk{H8k}YѠ Rĕ?zl__zmz].Pc w~`�A endstream endobj 197 0 obj <</Filter[/FlateDecode]/Length 1468>>stream +HOSWDNe0g@1N4@ /nUYM݄8ǘ""Y6˲d,."kaQ ~{9{a8#hd<$♟* +X{?&r<;/d~uNZޟߵ;2-HCmZys<5ua=d8K7#aµ|vhrߞEYmJIKİrwWdlîCr20'Fֻ.+1u+7dkmV{ߵ#r1cԷ^sNWVFT(|NUq*w2 +cmiB}i=T5!@5T}`<,<׭NS_I d% _<ZJC0ҳ?Q/|* +X1cݯVhYtjG#"q`}~[Oq`0֬]aC^lӞG,zlSJ|^=ja6~9rE1G{kٿ--]eocY0K?b"c)=mqZn0]Jjbs"(o,E`|U%ҸE0/t:\d6&Yd:bia0C:m9r92Ҡ=7=h4N,%`6LUl̇KΎJ߬K&0]'nҒޜt 2<G7[$\#cuG۞M}T(V9Z7qe~Sb0}\>oeD1:Ձ>)_pzΟsm0sW՞Lk + +X.^S[dwWTxW\1^0P +TC-2,8#7d3ڒ$-[.ZJۡ2|M~K5J "2ϝ՗b%OMg}I˦w@Vޔ*`Kt6sרϣkjsra̒̈z<\WvRwiK:k>q|5jinܣe<2_t&qvU:t(^3tV!:߮3&&bZ1ՠ_DRWUCtfkr/m&m:~lCzWb!c&REǰru7,!y)؅U t>S_.ed|MӞ0r~_V _cܧ^cqy^zoLNa.vwG#/_*BxKU=ߣow}F|b�������������������������������������������������������������������������������&Bh endstream endobj 198 0 obj <</Filter[/FlateDecode]/Length 7415>>stream +H|Wݪ }\x3I3ɡ-.-@(%N/҄зh;>q &%lmܧZ.mWsH}ˍXo;ikuq{2KV\xaއ{l#<U%Uo ZN 8'zi#=i +X`θ_P/:U $Es%PY#5۶JltC477]􋁼PW1wcpػ^;b 6 cSO34徳q#͞Xmթf4%~=eZo4&#]メP֌[ﻍA/$ӵp(!xe$,t\l#%'^RL4t] +Z/̋-:UhsɦSJ挅2R0K)cٶ[͌o5Y&nUgALvw3ɪZ忁%FWE}u@X{WZ$xpdԺWA٘+lP;SBv6z@y旆vGwz戤i½?6'8@] f6I ٔ/ct`_~Ɩ> {w(@  1{P52/P@ئ^ɰG^Z{PUa7q?`U-KpN';[vC, +h!}?Okl[x@dƀrn&*El޹ +ngS|Z}Qm[ѝIFsxLVyn1z2T?uZZǰۋsv ~iWNd $c@5,.iE.zEP|V\l27ŗo_wo}~??}_??߽}s; m/+ׇ_?߷_~mp&$s|ᮻ!\t. ~ 6]*8(y|HI?4Vl J݁ڂeubDb)op+T CJlF8YAitzMt7hDE12N8#Z +Vq_KL@`.Bx`rǁHrrMQ\+;fX&\0!ϱ +J'qĶ-?GgqlZp=O(PHP�\ze"(A X~}M4wwLغVTy$%-<HlcRKŔl _Pl8]' U;./dk#h5H$<AłG 8ĵz)pVO1D1;=:k[լ6v2a%#.'ZT$b{j@F̀a#-5\PM[QĶ0=ijcǞjf-=@2VNL I8d:C $fMN +]G8'sܔ (x<h.�n#Tq<2ݞ7L="xVuyUb.65-m ;g$#*hqvBC9T lFY'CW䷓"O\U`}ODz 9bDʙ&Ѹ@t:}^njFmi?NTZ͒Ẉ0$,>zR"yWN7�GcRJs'DRS͑`\*ɬKxL\+Z׆ean pZ q)0^88$� +{mlWmKx>rZ~xN�#X'x& Rzl\{&m8LV&R.~uфjhq9  ]wsL92x;4!hJ1 +Ic�qqAj@P ڝw(Μ$9 +83*�n.P6Tq(]ck[<j/-LW4`;51V4 ̑; Fy +.B7Wmd`ɣ48O8HRl'?*8WC�v^Rku)EAh2X'@DqT+E`uċ/k�)@܍qhcf.s;FwFM+7G Wܳ&o%>bB3O㱃7[Oɳ"ኃv9I-3&7&o3 +chi xW=F1Fs`a)䚈}9ݚVg ,g8Y6$'RĝW#t,;3/@+]H[K[f3G s#+rY <-1ڒÜ!;sOT8ImXBږyl*Y|ߣ ?mGj+~A/)-8yI"e�Ѽ!S<S5U.YrtfBtz + TlkP k,K|9/02N|E,Xd?yp9L֕#q\҆A@Mz8z'f+NHZG$\zEMYP < +Z& +c @is8Nx@Nr.@$Q-@it)V CTRHhdvXZ)SJvnrp*4 U|ܓ] z+ApoRÀ =}|5duf/Vt�{Ebfڣ[{+NRlSXQMbu95XGŮO|yY<:ʌh-G 9Ԡ"n|} +D4[X_D�r{s .@PE LHUi[I`^db5܁P1N ix�p2FX=@qYѦuE^E j սA3"ܭ r^jÕeVrD܋4p*)v ^K&{�:&jA2 ԅ& H PROTי'jcnh-˜ee/78DO=C{'-aKH=7Ï)j@{p4bD-4u)I*{ UY"g  XʿB8_dtW$X8eGL!1Ìh@Mؚ *9*"ꑈG1@cAzRm90F/#)| #ז PǢ┠7OlEL$N 5]@^ڹbA@CFZvl$lU`/e_Y@Gd}P'ʆ^ Mє:|d,FȼcȬ`jqi?,7cĝi,'0:a6c$@D�Vl_`paY'c]H Ϛ}bWL\k UI'=_XT c  ʊ94𵚅ȱNzm= >pVޔK/Z!9$ʒAhMϝ-pYufƂ +A,DN*T7(x,Z�:Ub*GtXV*Vqrq 2TI Y 裾oOOZ X`r +c�eZ@PJŨbOFp&ar3UoMzcĬmlPTj.Q rCXgzрjRt)LH0@向ZĀ; U2rTLğQY$!W2"bGE3U(߸$h/,5N/�BIDA8 MHZA)'"Bfm*=kFԨlFPs;]ImJfG@"^7dD*ep'ג/Z<$|ZeU}dXӞ ]Vk)Q-Sԣ&}?Wke@+1J DAN=7IUڇ0F2QҨl-ra) AZĈ%&M>�b]J2谳8d6& lƜCV#5{l+M#qh6ɜ .+ъ(vE !J8\+bĪCC@+N'cj>Abikc̜!V'ʗz鐅0 +}q%h* *>+t`~K'K$~V.=fX1D^0b@'Վi a Czֱm2Ms7ң[EYԣARDrtb5d2>)b}(5昷p�+8Se|p?vkbi' + +peZl {8uVmD%8Cdm^d##>'*3 +u2֓yߊ0I4 )U;S|1.ή~:ŷf]>oƱdd|to~Wbh_uΞ5OVWgW-[7wz߾^xt6nx?wW_a47[>kG4u~ߏͦWeڴ==Y򘈖mj9޹[GtͥlŰpbx;O=*=NUG8+}jl^y"!;,{O'!.8,1nrjŞ|OG?>Mݭbk[G^?[͛P(v_Gq[Y?\;x˿"|l6wb~!}@> +GgXf6Vˍ[-~� �>́\͢}in1WTz=lO|'wR{'w{ ]S{P{כ~t'{3 I}"gOr$Nr$^ro~;TꠋM\6W/f" R mǫo7]CgǾ٧D/W=tNHdVesW8fvM!'\PipޫC\ ?jm;^ܳ3nXS<>_ aKQDO66͢\4ggnUz`Ecf]Q>Ax遞l EK-x1!ˁ)?wI/Gϡ<<ʱTPn}n+˻}|%=3anq؃DSUaw`@nhf.0vyœ5;z=lEq`lq=;X@W80v+s\ n)@988{k97]'f ?WRH/[K xw|xq`0+5Ɏfш+KءVjz(**Fcxo^eljY~ӊT^=R9yn<:¬p2:Rڃa?T ~ ) lsQw.}'@~65avh`<,V�cnI$a+uf +rŗKkLV~^lޱ18mPimJ\ֶ<:&]xDuDTV9CkMib1aƤʯf!~!szIVr$Kof|s|^]3'ڪil=&sgҥ=I{<vq%^yWI{H "+S0;\O[}ꦩNBsڒ27͟kD mEGيt!D +䘸<A"Y].1'Az.xDG"!]y$BBƏEܜf)eöF$ ?|Kb҅ܒr�!l:/^v^ހ/ϼKoLߐK|8G%g1yר +G.EHI1$@6)=s�T@uyT?B4JqXj¸@D* WXR[l4j9z?|í>J)ѭ''æ&GDrp1Gbi[D<lxHDrIG+< lFEE}íi! +WH> +G2 LOS.Y,Pϋ܈B_[0ۣͥvi\f۞I&&n2O<B$<v%^yWMI{hH;i ]ySO47MlLT?%ֈYی1BnFIbg9 r!= [dv%:%ɗP%"0~,4WlIȞ.7%q[.䖔.Ag_/yXogޥ֍7oH%>£͖kE}LSqᣏI"`$$Q t4́ww*1UU_摖!U* +aOʣ!:'+=-_J \[LU5:uymJS m0vI9/<.^d|uawL{hmDc*6D+M\vD 4X_x<;<k6ͳg#&fSpQYm{Yivˡ 6 uyEexd@MM%{@is&!n.g<n 8+6,2y"ȴH$LT _uXj[n? :^~Cx&d**n<c-$[l4j9z?d@p" +;OL0\ 瑄!VLHrI,ghDb~.BeBldlNFEEw~ i1jlJLuUq֘9,ꄕibS'B >Qeʷ㒨XKV4I0SC32ȉx$mN9M(IOoҊcS ;eA8x.0k7صvce"rF%2."Ҫ�^Z]ɤO ->7]g' %5㷭ʣ!:'+=4S'HH? CQy(- +?^|yUKзZ*qmrXzApw3?Β07 vXHB4JP5Lv@^i9 n`ʫ*)X ɥu1܇H99z +��s! endstream endobj 199 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 200 0 obj <</Filter[/FlateDecode]/Length 92>>stream +HA��  +{�������������������� +�����������������������������������������p0�e endstream endobj 201 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 202 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 203 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 204 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 205 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 206 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 207 0 obj <</Filter[/FlateDecode]/Length 355>>stream +Hk@phAuO:u:;DJb h'id>>}>p}/-�����������������������������������������2oh:m;^燦Uoy,y3ک^:HCr~zż(]_7y'mEREw>$yQ$|]_$oחG~Na:C6dYTEy|v&lVч٤]K.>}>xN&1i]f/tQBvvi[Pw7p}g#����������������������$Bp endstream endobj 208 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 209 0 obj <</Filter[/FlateDecode]/Length 4081>>stream +HW]oY)+m +$M*W!lP&YsøسB =Ŏ3 dnV`89}Lq7ݓ[|g||3HOHkFFlSb'C#PBvq=?i}zC=KZWJ'!Q4HiOBO S,F{LPkUV'RKL;B 6jEP\\2Mth&P0W%FܵjD+POcC+ؚ݈搶@DdCW`:90*B%l ۽E&sE�|>;j RT(|W 8\\Nah>x, qv�Ӫҙ"ƹ+ 4v +alÑ┼@֡qˁdRXQ*֤h׶?6 ꮢ+c KaS%iZ]M5@c-Q[x{& #:UmǢWk),ʸ.BX#Y/m +ZRt{ Ј V`I׻NC$K}CHr d~Г{ Vk\I=odyRafTdSг%6cRlô1 ^ß཈z|? r[ +G.w޵ (uԎ.F`h=E -#T{��%Vr!Mb' +%/au(8A qƲ;Vr.]+;aSݵ+c KaS%iZ]M@c-Q[x, +ZMA\GtmdmǢWk)qyZ^C +MO)̀8ȂxroߖMN,HZ`.onn%m) + ~K[?$;ꦎuO?Xbts*c +'@pm}f%QϋzS2 +iU l+h8$4Faz Zh07Gd)Ŷ{$Kt+-攌k2cd>2q ,L…;d'E͈\0(" @D:ə1qTYBi ӍwbCRk?z Ed Z 4 ۰R5]?{Q߽)mwSB>jit}~0xQGt9]9FI#=ԓ0S�&t1ӫO9}Z]XݜDIN)Gک7>qԠJ�CiW<Q]}L1$zU1L<'(nUa'h<B{ET�>S5o}4LpBip3W)#:m]7.P^L85%0)_~8FI#=ԓT AT}Yhri7^1 ،80FDN΁D8D?_>&}:ah~sy\&ݗSgXT:@&⪏$_�3J +7]Ӈ,sfwK~s5]ݻ@4f@B>jit}~9Bź' PO:̷)o�a56C-1{mRֈI9RՍGw1e1܁З]/;0ɽ}Ɲ6 u`A240MMaPFoPgo/a==/}1jd=yh:&yE9VR!Mb8Ҿ*�b-*FE̵Sk rfUb .GrXMATQ/FVQhfHVħhĩDKKoX@*q|kI3AcAⴂ|)E 4b,mKCHp]_BcGU'R̤V{(Lx#{LnWlGI*3V۷5:a\SUq92eZ fn TAKS6}%RޢԎ(To4C=V*W@:Ry88Y2^}zbp۩ UqǽF7%G +ᾂ<rXAIF`H +"iqqofBp2z?>o~۾e]^ԽzzSWJMk +k(|@H!dYSk*AW>5i|Mk_=5>0JM㫶u1ide4 C*vF82_-zw)r@4f2>z �,cH +LGR�� PDB]Y*&(ziRVL.bvDs$2 gXr>8߻'ůd0ӳ`'G{2&@Bt3ߞyK2 +ic+Xs^sO6eRv9]$x.3*B1@`(2KB�: Rd \EƱ<ܦd8 ` 94 `ݪ_>�<Jc|ގxw]@?XbtK@[ +"E2?I}. Ʌ0!tM{yR GT +o@[3g߼7o4~xQp {*S%dJhATJ0i載 sJƵLRGأ( tPaQd2(. yr90"5#rJwàV7@'goQ9gt +1N7sIO_R''j5蟰:aj J_^E=nԿWr6~A7ɹ@A ^99?;M3xzdp$wcxՇ`ZV~Z)1}/ܮS|ݓX +S U*HgIɮ}]Til.Jun rvzЏKCM:,ˋڴ4Uߘ1pVF8UgFxf F.>`[}�@8wzuIGF7fL^"o:L-Ӧ##/&CiٖsMU޿x?(v/|-QIjw'&m!P;4YlɭIC_bZNsQtN BEEZ)v + -)F<*_ \[.溠I!Sh 6(n󨡴|[d@|f| +u(C%#Tŕ<npdU֔W[Q^kyK(r YuZi<Nβ̑g<ȞfͅLVS㳫Xڲ?k8 ei$6դQSGں5 -<)Dw67L;ї4^I;߼) LwsT.&S`?g|NF׃DBW~3>K@]�pۮ_$]-f�tOp<Z%Xٟw`'zD.:C᠉ZC,Rm=X[Zp @3cB<`,�;̡@;Ô?@ snH+嬽VY~֯Vo a*68;($:�xɓBME\N:IuE,t<zc .hBCh^@c�JӯO*^DW^T dR7Cqr8<O "$8J&?/V>(Ua|:7$&Wi@lS/h!v?vrK9ql +3! S8-}) +qiy@,$As"DԟK_ѓq�<f>!|L ( )b 9K|@}H)H9.ELL> Q +?@x,8"@j{,D`]XZ#9,x@Ϝ�ro�>O endstream endobj 210 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 211 0 obj <</Filter[/FlateDecode]/Length 698>>stream +HKQcsF Q9!BnMR2, hhԅ_%MHɌб~~#%&\g8X. >Ȏxy{!��������������������J8]"6eSjt)znv]����re[+ SU7]֙]����u쫪oLٵ����PTQW����*Φ?.kˑcN|19lf���@!# ĦLxv||C���O躱k&yra<?zY���Pjt)*3nOYO0η+JݫWD[[x.B!bw|w`WsqQt+~{{r&B!֎|Vs?w|sKa]t=nv L1)&kXEc}Caxi`#I:@{r<˿P[l63.z>zr{ VVc6旅;=>[$4%O Y|G@GTy44Te[kˑ~0{>z>zy3c=gc=@W̳>zf]F@GPNyA%3��^JgK#�v* endstream endobj 212 0 obj <</Filter[/FlateDecode]/Length 326>>stream +H׿.Ql.IRUIc`D܀p$'gwxߦ�|>?w �F& �F& �F& �F& �F& �F& �F& �F& �F&%{O�<_Zo�`A&%oo�`A&%㷿[��fdRzw8<}��dR|,r��bIzy]۵o�` <-Ko�` y�m4t5?��b{5?��Ÿ endstream endobj 213 0 obj <</Filter[/FlateDecode]/Length 476>>stream +H=ka෍:ɩ.PWbqjŏ +v) HED4)44 :;?(wHB]o 酇s]jk= +� _��y?D��țA$�@"Iϟ]~86��8I]yzƏ# �A19qލ�#uam,aܩ��C n|}J3gK �6Hzo_?|qı��8I/ݑJ �6HzhpP�P>U%M�"��y[9^# +� oF^# +� o?F*۩W/\Lj+KK7pT9C9in?BC9C9;GQDO��s}�ț{H?~ 0�C endstream endobj 214 0 obj <</Filter[/FlateDecode]/Length 623>>stream +HKTacbBA}^j-ZDEE貉!*3΅.VFi'm + +#:dV+ycˁW/��"fCe! +q>�D}J>�D}8]J'S}�6qt`$?v��e_#Rηn\?}L��ė}ۼ)xQ~Xװ*��f_#{{>��7Qv}o�@׈bs<:{Ϝ3�o5鍏̪��7Q԰lĽ~:>{hIpLP|_[]=>?ʤrW;&֭eO��_םl(LiS#>89;N_sad+��Ye lr}m-ڕ S `flƇ�:OhEVt25agr.��M3M}GUd��ĹAvUy��(pUP)&G�R"Br�@+{"䣁r�@ͮ#JG^ϩڹ �fW�gb endstream endobj 215 0 obj <</Filter[/FlateDecode]/Length 641>>stream +H׿ka�JiV)*AE:8(ETlcX$K-%"hKt\Դw7$d|G;Cc/R_'O5u}O^TwB{uo��@,SGx)~̗b۞{xE&���dWSL'Y;ֵ 7��,Cɐ/Mݛ���PY}M^WG��?]Dq>ٮ{���r")3r$Ft��@U^8?olu��@U>|?`+��BJqcaO}=ԣ{���v{?|OԽ ���;! h쏎Ƞ^KΏ���)C=ɵU7?��JYDⲺ纷��Rl0ENNVg'zt��?Y L]��tEiA+/M��t%)~0EPO"4'ҟt��:_)ZG̙TbK>�� F(c(1ѣO=�� tu0J8Z9v9�m endstream endobj 216 0 obj <</Filter[/FlateDecode]/Length 629>>stream +H׿kas *b2 DZB-(t$ҊVF1`KZ$"f ~33|ge��]a뽪O!9߱/voz{BP߫ϟ&7��^Z٨?^7��*JH3CM��`XV:靼u���9NJOvXz'��F7I%bVCU|nRz'��l?NៅWjN���Mm?n1Οj*N���vNh~���qnInO +��`۷"tҭ?BV|w��p�t_:'���)=zpNGuN4ג +��`7H@'Ac$߉Gs��={rNǾ^���&Q$*_V{��L!Mqv]��^*$hدkI��0RiNǰco<zLz2��1޺KM"h؃{ S77�[�:t/ endstream endobj 217 0 obj <</Filter[/FlateDecode]/Length 1439>>stream +HkPUeIǹTZ؄AcѤ21qS"Y<{yvمeҡK`BH2(^=O[.xa| ʈ ml"~:�}]Bf_S+/w���X*trIw�kX@ )I=IT'PFZeKu{|ggN43Yɠ ���`kSH{j:M:(9)ݗ_q<뮓Kꕲ[}L3?>e`9:8X����v306Oo&3`1ma0Sȼx76"dǂ?����Ҧd-9lVXbn-iqa-OUVFH_K���ڕMVڅ�[I.1>7?4L/]GO|-ϐ> 7*gO���`J٨Iچ�[p䥽wu֘jaʧ*pBly2Q<ZE7[o���UkZX;^ +̶xq/vCܫo 4_Rwy?:%���uFHTkau;7ΕxՄ"GLKsy7p_/o��� zV5۲eD[wAЦysT-y 59CeIkfG. csʗyux?!?*5U~vQ)VgN���7vGiqaXd�ksr""Y4=S]55LMP-;4?>+<vW|dyAVړ< ���tV>�k$2!;̊PrTߠp2^9xwW~.dD]U2g<A���%A�kS`|/'%EGFcRYyb'9&HШ7ҝuȵDBh*KNA���pS6ʪ{9ajLCLafP2SnS\qh���Xhi*菻gՉg-C d_)<'>>���c׭iiʊ~"֞j!o4[{m\)ʊA���`<)*D@=Nr4 wti:p "/-<��=-IQ*c~JL+69-/-x ���ھp(+B@Viɦ kkmtgAd磝8��i `/7yuM.m_~6`\be ?5'4���#q_w3O� endstream endobj 218 0 obj <</Filter[/FlateDecode]/Length 3807>>stream +HyPw' EPb(+*ZO(^"UV++"" 4 RCvZEuZ[q7tf|k|>3do/sߞ ?CCȻm2B.J4!Bh}LDw@Р<ϻ"ߥ!$ ?lY uAJ2R` BhbG{Z�5 7�,jGg ҒADntۋBwXЉϋ$\!ݏ5#v&d´ !zSYǍ2`9dp4%tK*e]T,B؅]!C 9*!OCȻHg mh* !Y4DinND/?nF�vHAf5J S. L`"s ̙f.u!/ cGeKb܅ɉ\>ɏ]ȉ9QYǎNK ?29pĸ`f>Oږ+`v*0ǂ 2Bh3<.vrO@chgW`DbAE C01ΙZt:8L͐vFWUR(V4 +}SM: +۫S˞^b=o !c1OX?Gg>w$kR43ϵT4ʒOV! .sPQzܓsG- r3fG'9AD[EZ?>ᨅ] r3^ ܄%TsЛ36-s-KZ2E{v~CF[ڍSFp @]@;"w�N {CCk=V9Y)cqߵn#%q6" BI3gEFYzNg$`ZX !4<J*-H` XB^XN6H`2ڸִkSm lu] OD9F!jO<۾G2è1@}hmM@7@/�ZG<=|Qwgu_S'Qvm u~C !n!GڪUMVđKbfG2?42o>8Nk+&0) bHc }1|<B 64;$$?.z>!+#^:th紛|7~{)ocț&QTvK.�m�@k*=r[װgvN_W%wl][Z|A+S e{vɊ fznB;8$at:aW.(.-^@cxgL*((.(em\ N6'\?B3)gdk i+.Zο%58CO#r v� >)#K{ w0r)}f_WҮMU~o!j !-V +a4؅G><E.`ݒO`,6D]P!%:O?NUZBՖ7A |[AcM@}aiJ$'і4` !scXŖuA�M8;���MGn'C`2rOL۾>ަÇ˿s>B}jB9P7j񂄧p)Ik'OI uyN/u;I0r$R}{bS+?>x;3A%dc[[dgH^gQ}W47O?s=j⋞_Zoe˽g P�Tl3(=TaXb܋Zw>|YñJVu;{~!ϓ䂪sbn^Y;8+BVҬG2J߱f-uZNa)` #̀NQ߹JIqUJ\ ۛ, wstߍ=Fώ<6곀` n IgըKg~'yw[,qi&OV5ө>ަCDkSyD7/#!DMdJ]psåٙɉ9' $[&hMe9,��;I0a3`@S!vNVR?~55y%( P*0hKRWD*Vd"&H$%_R@ +iU,HkNMi3s{31o5P_&:<T07Dk<8 .hCoꑔXB;Rb_˜'F X0ZPVYé+NHȼg!HVVj IgH7&H[*K9uyDˋ\os.bX30ଗvc|\Ԏ7[^ -,| ,[:|g٥k?0s ^!Sk-taT ]AF<-y9Rkz;FN,fO@-m'M6m5nwR{eT ilhۅ;Y-k$dk/ƹ%pzDYk @SeYciJ +q_dDJ7O>E7f/ u <|D{ڱ{mVp�vqg`ZX4KS0AOGhj:#hVh&+Ԕ0q`?(jP&ª{i:|ti+یR#H>}jQI +ްً}W- PU4z�t(&f `$XmkIg0bzcB_=%|*Izzgݭ><$oXBc{1UCW]$%W؍-RASE12( ,/8/3d~v a8Hۇک(1޾0iǰ=6'ܚ(̨G[L9jQbHQBpRfP!30 . @R~~z'O.Y묗vv $~M.KNN$Anh#r6:԰fT mBF[@|#]Bn$mX,d��C�GZ<s3'U]; Z0fH(ۂ6~ CL>m7lluٔxt>9Qإ{{{e_qE_紜0%?},<jR;&Iw,둔Y4ޑkOޓ\ ~iK$Nne5 5g5n.***֒jKԲwWݐVDfX;:[IbA%pPYj Iyf(:P SåD//w|ֽ +Ww',mV܉y%pPUvIb&SS5o,DD^F`f|s3`S<`@.0S�5 endstream endobj 219 0 obj <</Filter[/FlateDecode]/Length 1674>>stream +HWTeaDQ\sIhfM$ LFhYDPL"YATM(#\Qң$\~l^:-\ޙs/x<O#Bh[JB~oU$pw/C3ƪaiDsyՓ5ۦ!mb='� < D}NweuUj| "M�ra;v6H%mֽs'x >{�^te$o/WJyBڣ6"g8۲K7JI~o=wGoVnz^�x3쌥}`#?B[QtWd'@�9=߈Nty\5mqshN ngg#Y8Q6 Υ<ښ"Sg& D�9ME W-Z:ںoҌ�uoI6 $AWjOrBmYݿڻ 5/DA{:ʺ ǵR� z$[6M+B%ot!uYör1q_JB2- rdbf1 Y�OQ$A3H^D:g79_BE?�ra49A2 'uD�[u6$9*d?͍dNg!<;=@N?^>D0q5]*_w`<^+O?<6wB{fWw/oHRr4`I u;'QaՌ7B`u?;?@ؗ}cf~k K 3z@5idךyǕƕ/c!Pn~qmfuc_1r'K9 ^<C{!Qttbg!PKkGD�9O-mn`<J%2|ٵ.ahȩsu|zwjV+HtwBtX�ra w$WsA 6H ܤ 3e*ښ4U4j9:{$Aw(— CtZ5?@طt'4Y\C lN( ;S%23~:<u:O/90ԍ7c|@V?߷? A. 8(_diF&,Έ$+cn9 +bo!Z/О. +p@AN) +F�Bܜ]{#GM˖ϝ`ux`|;1BC4/.�!$U4H =_ *Ҵ)ڻQ;ٸnxKߝZeJ?*,ikJBrfB݇e~o=B. +fm3fAs R7lDK>ݸ+M-U%lz.i(:o(§QE۝D�YWA +>A +'Ҍ́A [{񃇐Ըa";|qJE;]X8!9K!ժYeێ�/_�p endstream endobj 220 0 obj <</Filter[/FlateDecode]/Length 26163>>stream +HWˎ OQO}Ɇ<a$;"ggw}1(.s"##l[%F_F em."(C龜۪5z_>sÿ|z_ wؤң_ۗϟ~yy?=~o_~s*࿲/c1I|ŹƃCjqR<Fm֦kX"~UV u#?biѹB=cˏ>򵔚X |=K\AӎTƊ0RĻIn ?TsjnHZUX>@Hkf k1':X׌5lLjJTILzF̴ImR[)4�9q >=?N zD+@%:s>hλ�mt@LܑuO=0;vT�A+b<\3ݙ8*O{럧߶3ق@P$5J׈W%fh#Z謌uzfݛ1,&nXUžБKTMtFZ(E5{pXRG@ +VAJ\CY #4HբC R3�4K1*Iղpq,R*鐣⺥p>,rBD?koI^xT~1f[V\ n>k}᝹�h\62fF̮K2jꚺⶖ-Y]NY@@ AB�m2P"t@m:7qʦ!*H,`ؽaڱa YLjl$CSG-"#H0Ċչy\򸘂S;jRhy ٙ o)X _U>䕷v>=FRI�C%s%c(7KM<\y XQy +#ڶ! aiM/#ʡm^ a:暑r@RH%q�'$9VΝ25g[ek:6SH}tyc-b3 S!9r2; I(p4rpHass41_Y7g{[ߔJ-]yوBi4;�blW}Ҩ bZ"}hy6”2d9m .12U٭6|Z dy1pS>&RGGMaaNw�` TmSm(damF3g?QF~OG?|*d]NG¶#GL=syRI'R#Ѽo<K 䭺G QtAۘitit}WÝaVg�WWLͶTMS m:o 7j?cGH2=G. , +.<p"nx~u@Jّ]@%,)$G#9rN6ygؘa( gu65:go> g~ ;ML^m%? +5� ;T5l[]a])'[(3tS`^v z c)k!GS6v8d3I١xf%i%ܛsQL^QjzYrbchm7yMC1zk+;}|JqN֫ZS]kI'x}~TKV4U6?a RnÊ9ъ'|ʨPc'-쎁$yGvIިaeP{=s6+t$Nwu q59NvG# 9JOó)ioAVct0~`1WiջUo|˶7ӑ-[ Z3% ս;_ +o2Sz& �Sq8(RjNs>V< %z1M8"t(PƈoOy> +zQ>tP -)Z^r |eCL!w +)ײy5)'t>(XՂ +x"]nQ|JX.аlaPb@V?S|nkM? YB>7Dx>uz"8KLҙ;{%;*<!ڀJWY5雦Qe;smd^'2KiAז!bAJ6Y,lǏ]f"!1Dz@8[G>^!&U 6֊})WlEkY>dR e;ӺF>yY7. Zګ༦y +wZ9 _ND<lsJX'J!ۘZ@?R$j~U .D͙ѢŌτQE6##Au~g6͘pqg'^^R0T|L^5i2l>}H>phQʤW| QHOTִH>Yd^q@1{h@hW#_m7c O0n" ᒉh["4 82&o^s$2tWWW_55Y}}dR'X<7޴f`veڂZHozWƂ3j/\GW}/* +a@mBU_/ D!'V� 0y d O<[RB-Oil ݋\jtCf)m_.Vzo'ManuJMBn|̤qe@)ǫ9&:-MD[{67ru6tT7"n]bb|K^Cw{V{kTM{{ܚ7VW79-/V Gzt&F=GȩE˯[ȁSH<(Xڳ +SV8FPZR? Qݰxc==ؓOUk7j~\twru'RGjR_ ͈֞=?4p<|8༌!pc  ul1I6e8NؐF;_oh%x ǁY#$Iad$K(K$ Scdr~r~wW˷o/[)9 ~h4'0 +f j5ϽFs"r҈lK99`o<-6ٰ5rͦ?[784Eq4&L/ }4E*&Q } R"[Fb TУ#69s;NWzyټuk!lt׮b`߄,E3q9S]1GDzu67Dm[o.!5%j |D] Nc#*:]K08"Rp^Eo.tI7bMvvY3ըP D]4h* AE]c=twq,VV2zTl|utf eY_ Ȭ4$ruЩFVobr0S9eѼ@ȮќIJ9ּ+`/ʀ`i4.Vm�"ȥ rc 3n@BRI:j]S11A@::r�k.:"*\Erݨ154&23|$[K< dP#BMVqmj<lP^&ٚ0X +YKВ=R 8ih <'(tEiq/7"PP t@J޿cfDX n/镆ըw{mBW֤H+Pdiر5ti9$ʬ8JUZ }9aZ7𝎠(7p}ܮO%KMkbߏi^zư/yI18B@uq1S<)}nl<ܨ`i*}䈱GئEXڎESY&5A77^[gPQ4qZRy@Vyn([dlqadl {Htس8 JGWTKxM:%U!# (ۘ6e➱�+:~߼ 15ɉm +38v>萞DK?{ʜ{pxSpx}Ҿܷ:ɿ"$rzF-##AJCCN{Qs8zZonZ Ozgfi�'j W3u<=JԃY}:KЁ[l$ <c&-(ϔmh+xex[z˞K`P +Ksɱ]J@4no` ֻ}x.c%|=08C <O*ϤE ><UG S8S#vtCqz{i|iui3Zaq8˻\g~{wނ=W+Q޹sR +>vFr]F_ }՟2X_]_],_]̯VПϬѓ쿓8b<[-^=ܜ^fVѿo9޽}s)?g'{l70u/_~5BN,4jEnxqzyeL +KE�ZOZz/'XdyTy&]IY wҜe%!ivsӐ\E +ěv,x9DŽg�9dw<=ƄeEU$+8G<7"/!ʦ< bfB)"&ȩ$DkpΑZuBTuq|.r8؃͕gBAT KJ`Y.K^WOr=SwJ޶ƽG\W|xcb<"2so*4,YZC{ 6ȂLl@byCδL2#IUHH39AǒbMzGRJ +q$=xp7d:.Iu❴E^&`#H2EX0<SBFZțB)<V3Q%SD'[.FFgfMU ʀO-U7[i+ȅC%  TQ"x pFJ\סJlgC*%n3xg)5:I^%FCɂ)5LKP,(c,T`C2c&ݧ5T.U=M·S @qq&z4E9x!+; W0{8q0v?P x +ƀYJƂgv /XU5ن胸OZm3hΡ҅ mZCX#,^YGu*<{9ֶdy"<}('7M*8B1V {;`7p+Ԕpjcrz1E=ɢuҶNkO=;Mw2t(x}ٸM4r*`u>a|k}gF( Ris+{ބW7O`/gfwfޡo\}{k/:‘z63G]npG@[1`(\3*a%GS?~,&)O:B8Uq뛭9FHiqsNQi[i- [8fyip׏*LY�vV(OS8q6>KܺJVRqs)Ӯ r_|�kj\<][ݢLxz+d�A-N]&a;b[B}݀8~5]y +t!'Dzc>i7fd +J8"m "ыb3nIWPuKGbzJeHP"K2 .j +j~J>"7 +pnN2N,ZHZzc:]#ntWR)Tt]�RFI@ի i-`r"u" ӎŪ�{ }^_~>qe+h}"PT*H!b%d%ގr%7M.WiZ_Yc:c~]eO:ro0k ́v^ƶ.EXL_~M-1^M(O2ɺXռ!(N~ lޢS @"LEC/̇1PA(m4Ue[.2ČV4, %I~7|0a3Oם| z,o{Qg͐=+As�.Rr%h.3cUU3bTY##&f@ l@` iE_ ߂5z^u¢]xOTe&?25^tFϺ5%rꊢ;Whp1s;NeP]U / $E0zIGU{fy* |-ӠW>w9jNɓ [kUUQpFDyrԭ?Ac}_~~ __Y$+4'J:K=tg8O82SR57d4 ȪP�t25 x1%o)‘`"qX)}[3e>dD5^1HEaBlI.Y3<n@ʏ07 { t.!UF*^cTJkEtbJՐ9#o +0h��8ʚN5nI0uӁtNPk! BuV^]c1|vV~lrruY!3%2A+5 e Kq|CmK͏6\mmC`nձ�g)B5~X:I!X#]Fu)Co +>^:{5%0E8Tdd6G΃+]3~_2]NnFU%)T3 I9$$fW +bR Ju; �*lَӳ& ׽$&}=}q|l׹1&Ixf Ȱ<ܣkS2VR."(Ю+xMSW5;vEŘ܅ +1tn{l=V5@pu-i9~.!zq]d%�9F-^=~\ڧ- AW^E)J'X-:U[?.Q/ȉݳչN7()ҁw^sKbdf^f,%ӻWjƷ +) ժĎ@[@\&ݵ؂�{P.hq(mT((.#[]+:]e2nE$n=TgRvp:^O%=3WGy}i 1wI0D9VFF7a&E�׋nty;37A@: +s@jg dE8}#3wxX:+D2Z +fۓ߀p&wD7|s +V*3a2L]25H[ +z՟5ss,1*,[MC 5 Ap[}vCrHN.*-nIm9JX6$b8Z +L{ff pqLf+>~N夐S(oz܋:b,C/8N:_[F/#t3Ө 4a(_H\'ɬo&|Ԕ_|�1#H[cbW6wRʴ(!k#"5a2A+/AT`jBۣY`tj;^8U?Cn/}bQS+R9ϩIT/UF,N[4k2,\Yxf!t ,=<莳Z7\̯@zn;\zMVu_J=&Hm9V<A7sl8U'N\V6;(|}DH:*%:VPDg"@ {g{XMu|׻�b l [[ ]Pm$6|ǡ\pȒ_ְ¿$7~*z-ՊUI%3O"5Vfe`*HM!g }K#dRi!H� +ttyJ&/+^Uł(l| c}]L(Δ:˃&ҏbJSyO/D*u!I簾<ne3\G1(F$F`UnǙsfvN]dLfs[Ayc +1I7JoNQkYMó%8݀U:W2L؄qE +M]JW@ġ:l{JJ~]KO8ÖubfPj +𣞍d|dq'=-!+5ysѵK)\mP}'ǶNWwqXԩ|I3�ผT#ƥĮ~e`:y) q]K}dXG]{ʹMaԡ)ƦvkxF8WQ03d z+ 63pl|l>Y %%Pb>c'lv7/qf͡ΝnpI&;s\F"Bܑ([12 aQd{-0%qA +0jzSB2qە+C8F馆1#=6rP,sv�z[;afө0]wK܀+~@*Bk{g}>]9rpCzQ'i2y^IabdFSj_<{,NKp(}ހ{{w)c޳1m{gJ#J.S顖Q̀R~&U# #pg#/ +_V;ϼm +$du(fR=K {8iSc:߄T&Y8QdqN`nq  \XeJrHwS~jejlj�*zv2( !v^},܇DS!riYڙ(XYBgKL62`1knU00Ƶ2@n-85YJ* 4r(}jwnԗV*5Ysu^̓Y}vb</ PO`Em2ߧ##uܭcuVѡ{?h%BkBe�G#+2;=BHc %=- ?js< #4ɂ59XLE>=tY {;іzW|j9AQS^gh[aK^Vs!l(ZЧnzN^ݝV)>}Ӓ%s+d,!x,woG}xudrRlQ)ӎaGΞ}E 9hn#]^|>46n!D7#`E>t,3ẵϗgkF9~O0Zjͩu-G +x'_ӔF'q/-Y|sƠP]x1K*z46 +ЂRۚ{aU\H]϶?^ٍ/2ֵ=.KlX1{Pjt{cW-G.-Kr�q\;f8F/jȵi's/^:x>Ε/OplĆ{?.7h'?j-WlлRAAOqnF2v$bC1_XOn(15<fC (Υ^6$yig5N/N2L +qsϫ!uݯtM`#W#�L+obX0'7)y 4̜bHepwC@�[{-h ^=TxVѼEKZ+:b2I= bd1#lOC}9Ao[uVwzO&%?_I+<%v ~Wk廉ajHh`0yWT` ݬL05ixˬM{tgԻ0Ihd|^wmRp]"=%U5jѳ~ˇ_O߯0O v՟?__|}ˏӷ~|[|^o0__|_aV8?2B̫CHv +xEFpcNbX'!Ivdg7e3oltH$qU}S2%:Ӓ[x&ش6){nw0C3AO#rL=2 ) ?ۊ2vW";Dic&'i H[῟dŝi;{ѫU& +1ki|I6 ]%O" ;FkvFy}3JT]oZݟW?`T{&抃X̊Gtߟo֋tn6gYDDQo=?}y}ǟ>RB?x>)РZ/, w!ŷkwӞo#ܰ_oZIq+"o*wJk9 ht;m-f]('avl)*CW1v(߈CnȁӋl~qG["t%hȥ?Y]FmK?YiP&n|uxEߌcdzG= b:;6ub<~%-9i|}_txʽ'oݱzQBٗ=ۏ 1/0w?IS)G{0q`-Mqau-I(A9iqXHxagu1SYYرN _`7cuڈ'?hGY'vy#`4g4,޵,8~iFOhYUwλ� -(7KtAAsps+ #XOF=t :Ѩ!X\i-urQ % ݷP(فYC^y>Jՠ9͖ + |a�hiJڵe\#DRDcO=;a(*3bp1Bee [>OMڹIar"Osiq>Xtq~V(rFSx]:xRJ:KOl>hL{ۘ=XS`  +L͍wŪf>R]t_gDqR#O4ÏLx>NG$%ω=jNl~~%l`9E[; hJ'Ĵ -z62&M 2nR}=K9k{"Y5 6OFoP]"OZbWNFkK?uO ĆZ}#M$A:>G;;_w:ORlޓBfjc1{q46J~=ˠ0J~+4FSӲtʾgk){9 >͡3xWڬ1ݮL3& nqI8\փVs3jޫ /&3Ys *H\qrQ>w4+cֳnpԢe-t 2tG(^LJ /' +P ^T)WI;)h损@_n~y?w+]'[\[+%p~2"2#Yk2CLJu$V?f-OV| _`u#ary[4UG̘ۣ(b;_O-d`xdHwR!>{`R)D( &) +1;Լ\j;KWJ͇]SsNG26Ds@!#mφ 9 g13h2$QGc}x˳̍[i.SVJYnWҀ|l:ٻ҈11pܑD_nN:ui‹! ,nɮu* @x =]\}մl0G9> +�kl%a0([ +k5X3a }FS`?K)QbxDyAaX5QLd)x4b4Z U%֥2k6vw|-B36`i�s?}mo;kJ )�*fzeVoMfock(0ԖyQgQDp˔zGZvaҢuE)Nփh)gd?ZP5D_  d';/# +Y"nzb<Ŝ<p ;ZUSMo9-C+njEuۡ_v ;ǿOԚSVTQ;1wuV=04%%I:K}i+ˑqSQu;zIQ(@/Y~_Z=ozOިˏv¤jhۘkMTz_:$񸛴e2?V5댮k3֠`8:LŝzG%k9ɶ}Ϊ7y8\bnty*nȩ-IleH@aw-InQA|%B\eyZjL|Zܑʩ}3Tr\}-Nb|-7O?Ґ.%(|)RL|]weԏpburߑd!}J}5`هy`TIժ]8!vMƄsIo/QdMC$d}&4 +2nKNl>Ŗ11Jw^? #˦N\$(_PYPh7^a ߍ﵁؋G|v $Zӏ+QvUiH$XED,*E޶-F_i$RZZN5wwx|ȉ%9vl \a,b)#qYB)7e"#.ua=o\CN" 1 +ʧwsYm9qG5CUYy?Yes#9syj!"~, T4=՜RI|9+5{Lgݢ%x {I$+Xz9r%ao!qpv`nf։#TC:=˾\hlW=#^[[!w-I6s3=0g^#jo{qQܣl >(ف\4BIH9=.1ldtz9 Ÿ)hZ$֔!WZZXzQ.#|EɃ-uXBzC<~G物"&._L0v$ 4%̺Kf|)ˇERSa"=enڭ'_IZ +Qd3QFQD!֫pJ~ŀ&WrMmnLo/#e1phn9XLgۙi:PWL+MgdY븢;I@4[$eb0q0(-,uC5gS_C Rսu{mGTòg:^88% :fyzdMvX5ꖺ\":߇ 94ױìMŧ8L"9UUU>|=F8=B4fՄvVRghV{3&`O[ө1+:RFL//�7ەAZ|p#Evb |sfqDxB>OM]4qǩŷ�3*zOv'_w>iݾ~Iem qҊe}uP؝#eCw{҅h,z�h' vUF1ԧ' { KZgp'iɝ|\ gXpUyR. +:RZgU˞h[^|e"T6d\|`:<`jhOuuue>fԑH] (İ`Qr]A|lM/O*zl뷿SuzMoe*ѕŇ^Әt$V&Fi,N]ehhS0`'S>Xͻ/ +n Ewgf ̺HK[R3I)9"e?Rr&bÓjDVrpG]yӊP ]X=s1ߺ#ǾCo<*/bH=TU[][bxH77c4ӴlGO2qꋫ}<{{/߾~wD4dverM]쏏g߿o/o<~7oݾᇏc/U߾}ۇ7~ջ><g'w#_{˟]L2uo=|_{A{wt|j>:( 7P1J9'?JXQT_Dpe7b5mSѹ!rx�,J7ODk8݄~"$5S3 FȦM-afZRIl{a1Zءӈ<}߈#r. +xW#C v4ZmBλʡFt55R ֝O2ᜋJ#[Nl +?.fW t\g:/Oo&dzwwy+,# /+uq R&,|*:d XDJ&2DK!%E|yuuv ?9Ga_7C[_v=2 ?*V@%>0|( rH�LIpL905 7IQJI#"%HhIH`2]@iTQlތ:Y ~? x:Om 4VuE*s|3ꙍW|,ǩwϺP#ZB<_FK]^mrl +*AjZ1{-n *էPQ%uuc y/X$F(#ٞ3^V~p<i^YJ<#TuZ7N;=hq P#F2vs%,R:@JG`ti.״ו'whCb٫p/-Z|~YqL4Q}]6[o={=RF?os\WO903e*#ᚫDtqS^'Y,i Qj-yj>` JY6$´G[c*�l$iHlJ#ϝF{j+R-8u]DL>kGqMhPg tYjQ@q> O̠lRaG/Zsʬq>Ogn ILH^O}"R!z hq6oGScإM3JL#<QRERO8!] 4 Yihk31"(桜Rgj(urY7b +="΂AvFX]; ~[3ɬ1Q�)vA@i& +?GLD +I$Wan)eT e[õа(mTYX^Y=_R R(<( ރ)GK+DиͱcCBΥRgGԮf*t˩vP9Ūb:Tj*Gq@ +lf ^'WU cL\="2كjS)`klFYZ$xJ j5o" +38 *,o�$kЅ4|S+i/2{!~솵|=2=K$| 6o'5:^&_'Rm-^tüባa0'dI$y2|- 2}7~`ުHthPc[m !dq`}Z9`$@`M+WR׳[_M).u헛H]� Ek봷͇/*$%;G"Rf@Q2#ã>},‚R}Q쎝WBNlhQ&^? { +.>5 N<ϧ4,� +Lkp0&>@U]490 3܁*YČ!):)b"PthX�풙"1ZPjTrgħb^'~'JF]V_6+Ձ氺SiDь|i>}eaw#Zq֮WU)q~ﴗ9$EW{ "1v/.W\d C2ĠJ$7YX[)fWvSsަ)fH1P<%OsR*kk8N$8͛t!h$=UNj[7sƭEg U#z8 ϧ@5XoY`\c}n󔁽OTyvط6.,m%{0z7^gn-^-a4/u +x%07 +gXn%wqygu +>2\S"EPO X2G�IP釻yT/n>É/;J!iЊařE XF2%yTEX‹鞇SGM;C@Ξ?Ճ8+W _b#B+ ߒ/xwZfcx s JKWF:-/}spTQtMbUs";B4kNYW@#^R5׋9 49""3wg$qLpiWUhD)\:j{^TK"` ^3zls%༁�Uas*l* +0b3O~b~#bsQäyz ϗ 3t ӝ:-|ϓwN@k}"Fw7{D,4 ~}bi�(s<LF 0m#VEr>l+Ȗ#ۂ]1c:2NA +Rj9nf&ң^Y4<Ӣ/.긃tAQJ9A&#:9�OYۦ?۔ޮrpUFGǬD V//mm&["5ote`) =ָ͙yhowۣH_=?)E=Y.s]s4={1Uj R3V'4_)\/bٿCsWV,KrawƏ }UVxZ?M=†yV`C]Yhb/{U D�ط\-bOW9 lnxl슩Φ - ӷ&#Śv-VviyZZ=Yԁ,f\}~kՀ>aStvs+Ӎ9%B]d,{cJXQBijY h wKL3ڦmڣ/礉P3gG]T^ +W @M=:⒀%s._qdfJ !8m`Q{yNu | -僡WN?.[y\G[#k>B[\Tʑ LqGhsN~ 4d ɚ*`vsy8d%XeN2zהIS"MÍvI=o{*ȍ#Ӧ- ]vKY0Zjy[jWDe79lV^/uލJdU\E! @Ԁ!'\⇧IB\�E ~EWeճv0dyǑpTib 8SfwO cTN?gaؔw~h}7bw5 $ؚt,:R?ԇ +RCMqh^Y�E~;NgaE\-C9lݞT5Gڗ`%o˚87 )/Re"zv{PHBmLS;m쨬f j.˜KI\#q8^JJi;W)vuPZh +"su+, +CzRDW#7B~i#E}\}YFn"X[4zT^Aj]"b+5n'%}WzW 'g0V*Ywg^E9 {uy!fN1{ 3xw!0/,6�Rȳ<Du](kFcm:t7!X4 w=5g +縄:D?)vr-[&J|z +EֈZۓ"fiD" <P �%Jq.M`X!w Cyk\&9v@X4`siy *KPx39W=e\OosYc؄ɼ K~Y8l:3v/QݮLZ҃_S^5~&Ql-K /?d_`uA[mdu']ռ:~jXnhU%GQS1TμŔF(MQ[MD*ᥕ̶ZN/4[`- +~T[Ǫuَ\$tvPĿboU~yWWNѺMDgspݵrCִWp ~tmG265H25}RjCMrtaةj܃uR_6$s{R}~Q@ lE]WP׮EM^TWB9Gzʏ 7n'̶΄7R+�jk~Ւ)ikI6I2/pxH�wu`ˈb*�o !,bHO wGqރPG|G#tnvFy =w۟m%; B4*K#&w:0'';K)hql.Z[z!xnZ^d, +t]sGac2eGOwdТj]#$KAL`9Ў-nɗϷ>v8B +vWS/\$dd(:D//oTJΟiğ82R5y>F6nq#i̴ Xȹim|w]0 Z]A7A2”VpMeYg2ո1n d#I:g`[!'~4]N34:GCC&t. (3ܺ;<%RN03o/D#o}D7cU't!w~Wٴ}�}]Sg xȀVP TuH$i,A"mOA:(ڎЭ@Ank#Ѣw /A$*3)k�8q DD3̋kxx9kgsytgOɐՆ@U +9]9-Q7X=nL癴׺3!Hޅ6jR=eAħC[*W?,NVZH08 *9]KJMZnԙV35 6:jxԜj\9 '}ևti0.4גA z^fjEа{ny,At0uHCa+GT /ొKz9ݯT:9ne]͘_BEb;j0d=] +w2iEZS'H=xgqP3" G])f R;'L]a ׆ Tgmf!D!ؒKuP/UT7ԇL #|+mm\d\ #Uh#{9ZObj!()rbj*'ΏǧgMc",p5q\+FsDcӑ*mqK%uKs͒zIݵşm s'w-i%\C{2 JE `H Pje5LMdCeZ5$FQZ(Aʼ+@՚Ss9J>J� 8 5Zj\V.l-`Q^0]U46E�?)Nd[:n<VUwN45| a%Kw}�̋H3dƨ?Aa)?n 6]NGT$.e p`3<!MrD�‡oq>{ +yl! UQع5: i8H?|T&gzRޙh6  *${J~<*C.є!Hbú-v'AV%ɨ ƄV Ր$ná8*qTI>r_2%_J}C ը.A+#Nk1"z:N +{e=&{SquDs?9EI*C1PMW!y^+whNQZUVOmъmo0Z<d{t& LMb[ypJl/-Cl"8h):H9ےITƪ:ZQاpjѧڪ!@v.rO, %u|TrR )i~"Tjѹi; 1h + VDC|j�W]*l0=W(8 YK7RɼxY {FBLނ9ɔk/ӚW~kŮ}4{̼&Akl2uQgS$-gT}E5뺬VeZ Q;Fu֡ wd d h&T5hnK&m uȋJ]=gK~Q=! Zt0!'p<'j?jP{2^lzQ`T]J'N�-d I^&&n̖N�xXN[7`uF^CG 8c)-C4K= 逪AQyiR%KtI/XQvllL>8=ҾǷ[R<y![f+)B\Z"BTin%P 6 +V16 , կ{ 2 Eű@߼HZ%oa80&t It]vg@}ưDiZX,a*2:¯B!E?uOzs%B>l#YК'Ukߩ>c:+%V@K,Achb. Ĝ>>G4JASr_ѵ~uJJ@IcmWhI$_1L:GRe8ϼB-MMS3R:\o]8 xJTpKy|T@_ue XB=B?{mg|@d_;~S6K~ߥA|GHa`P3*"L}[D)v,n�^DNIMgO^7D`wYh=mq|�9_X>[m+}z|z�_Z=?[=5W}w?.wկ_ūotw{׏_?<o7+?}}n_Wi~=x}{h$Z&H͖!H@WxLw6}+gHzȁ.ҡ]hFZx_څhRs(';8NH˗.aU}AbsG9-FDhyL#�21Il|*Ѡ +p[SI'岣Wq'!6u(#)J #i햌Yk1$Jg`ԩ}.5Oⶸc]+ev*ܸې%D.*J_> p/_=͕b2~F-@ zE/̜a`i.\GeƁ@`FQ1S=cЏUAVih 1i1m9.cl7Q!BO[(O')s_C:og1:L>dU<3}ȭUTG@AK:yz<2wR>~U^ 3nr)fI帾U&7wYF<BzJ2 u +_s"Z9DByF\ S*fvS<b{r_HQP057nHiHX_[ +z9hjx1^QѽУS8U}Ӧ9Q\@z*k a0:_FqfMs!⡩] +B"tZ8ڈJL:\gMNyDd^ueiޟ]QMZ$# I-1 \rSo #Ωj^^+F ( +Oژ}jk\~oLa"nkE*RH{#:^ 2Q 6~9@QFDhp+1<itJiCkGh *=iX&[Dj[1a&YK8W}Tqh q�?iX툛S1p|04сˢ {߫aH;"v9B CVYNΒ4_�|mH�=fxD]ƻ<眃zovpt +s9<v \{iXLjmZ.vxO/Jq8>4'qiҝ6E><Г!:J)J$`͖2׫C-ŊbGjS4nQlBz$.\fuW +6I?u)+ :;d&߰5 +ZgDʳĉv{:Ls) <IwXl}[$tc "b;<-*0s+>P)%vn"-_裷kY'=O^pke�\ ݭlmAB:븑r|n<ejT%~v,TEXQlv~CG J>Cl  +!ﱤ51d`Kk#S=d;=&(z{ˊ +i V 84Z+hPKfp;THe_-T"j^!a|2'0;ZC=U97<t8h1FyS\)5"Dk.iTP8֓$*ʻu,|$Ae4)ƹ @|Aff?fb4%$C{HIB\"M1U0㢻 s}c vrv[-JK(K=Hڡd`0MjkQY5dpC)[5Bo.EY~DkC6Ad'ES0] ~ DEW-ʎ^ ˶*9^٦2p#_'6dZY}ۛW's6%Rq)DŽ|7"J1POWy(2^Yt%Jԙ93f̈! 0#<eH2wKλXRPYrwEM|D{ۢuJtɘO gc{܏"/N C&`|R_{W=R/ )"8,&@Uxh5ʮ Ɋ +EFB*l杺}H@kS菆il3hD7 }ƩDsa3BJ8!#9r49<�YbX &g`�y\Y{ -qPhte(=Ss;mg .oIB{n8͗r$CY#slIUb ="%k-j$n,#5%H9Lg>ʐ5:`ycЕ'y3 sqnUSVtNqZE ٩ܘ ϣy+r^ (d; Ba3mU|I~FE1%H ~ŷ/c$o/7?~~||O>n_|}xś?>F}7'<zYGմ_5G0}X8m508䁬F3NwV$j;]']n7S~E գuQ4�cjD 7/pQwˑ*x9茞}SὉ$䢢*ٞ֡x|# )@sBW^)E'V4N[?݉fu7a#px?ޅÓ +L2<G">Bb-`uڝ'49_WSI mb,ޝ(O6!^u6GYW+ hdnwdpyPNLOs*7RP)`4J$$[Z% ϵD`:'28Zxt"?TmY8ᒺ a3r7-ahaI~Sxر]>W$@n gaa^i~)1*,!7(^vig~bG;y9FI+ (=!!s=Rlٿ_ٿU><=gV bF +3/<Y.5B|cV$*9$A2oy&FO]a$Vdch5~]5/Q2 \d WBm}gln>@ʔ uMʧ4Mo +Gjd&#>6P/cQCHZqTTSd> +"VNB0qTBmc� +qQ&iڦpkr>n}z|Kl$BUMdo^SF`Jàhlqu8gvB{[冮IЩu}8JJ1xXS%Vd/B,yuiMueFufQ؁$4=LXqB8 -s^sI.kQXP\nFƖQ]7fvL}R e Z FEcϾU*Y,Y*/� endstream endobj 221 0 obj <</Filter[/FlateDecode]/Length 2389>>stream +HyPgpX;vQV:-Zuz"(Z<8E@tp!K@D{HyE +bb~g>3=WCbw3e2t~'3^xq㉚͹*9dŦ ١k8Y\tp!ne8}{7o*sz Hfvu#}D;Sr*5ܦ*ZOj}O7L*%$}!�� JXi#wwRq1*i 1jGO É=a愭v +c_lKw760mDj+ 3Ixhm8Mf%tRD=hS*`~&CJ6"?��Џg%W?C v}3sSSR(=s9|^Ew3LeȀdSe&~~FEQ$1jر_Tʅc'uޏ+O'r�#D �� S[WryPb==@;-v6]C0~"֛k;F!\ݾB{6ߡob>Ƙr8d({؅xyYюQ_-/{꼗-}D  +_ ��xykI?C Z :?w>s<;̋H;JEE]yP0˚(?P YFbw؋y+KjsK1Nȅ~ +M|Zv>nB��8p2"CT |a0'9_xxr:{|Y~K_[վ; ?:xOdP[$5*lVYymk8'7|MH*M��.-'b| +1Et~n?YΡ..Q^f%F"v/w#{~R1#F-訏do4HkMz؆?��� AcE|_D@ 5LaNr_ONW?z?fU^yvEڟA=?= qdUfؘTlV-*"~T/p)Ɗxn��Υb^ER(B@ 5LokP egc.Gj(.7= =vgulJ?: _y}"nsIt`pEJB\m[+C-{..��57toF.d; 19Xsn<H;-v6]U!#M o֟c|,JYicung>g%Cv&㘱ΥҌcSOj}ϛ96l��UڠΦiehhݹnC +E|EZJDw?z]t>t&L275}3!ڹ5Ԗ̛]j;$52bv.?qJ&LrV|GrIv&Ek p]��䥟VA@ 9 U,ÓC{I=)eeך=ެ62/Wd'6~%?i:Gc I:%aO=̲>!���zR"B<51q8vbFT]&^M~2g?r|+uo{̈́ܫ H2_>eN?D +L7w=ٸQѴ 3#��F}9T[?@gA) }5rU#rsҳ6(/4|MHw���CT._۝1:Ztp[?muz5n~1.g. n���LJnKgĘ-_2KAhgdgRqZ%]f6ؚ$홢1g +3r��eriNnF@)Е%V|{,F}zf:7�[f% f%תds��&*)@xp.?c +t{x@>]XݹPg#Ʌb^g\rVJf<��Fe,31^dLQbU6Qǚ%jUɘj��f;=r"?c +eGr骃P' yT:t&k��]"l?l<?c +GmhX«讃�+��4kj endstream endobj 222 0 obj <</Filter[/FlateDecode]/Length 859>>stream +HIHq1BB PD I:EPX!ˤ{iL-"Z.L]mIQ4%rtw|s7fN�a,2ci."yclOޱgy )MXX?򦵴pHo3��zfr`48VVd�1ڢ,q$~_4 +-KZ7fFv ��_O?^9Bn/T-׻K~pX4��*yb}1L?ϊ ��`Ӯ\)1^}A; i��]:D-TLpl��?ۙ"`*=D\KɽG��0?}̽1Y4YQXwn= �}k X#7'!|cɪ /yOz.ݤA�� O{`*-oZ��Muo[6fLpMɬA��ͯrGWF*TG9UY֗4��7"HnS7`*#"k�ٙ6E5S4]+oGJ! �4F6R4 L]vygl��8)S';J0F`퐷6iJL�3ޗLXHg ~ަ^&hm�YdT64MI0F` +M'i}�uo5`*boȻ87��g3Y\tnJ��~ endstream endobj 223 0 obj <</Filter[/FlateDecode]/Length 960>>stream +HKQ6h"ȊV۳Ţ,ԴRE,3j0mrĬg"[ƈ +?.;˺Iro6uD)P-,wtY+=rp_Ea��aGCy34q36>*e{..efo=��Vzɥ[*佤?N?Ҁ!cx]&�`K#*^LPM4Hױl{�ZfEi@43! [T�PiZkQ<GI4V!hsx݉��(t]~еWH4V"XͥufQ�@AO>LA|%fDvƫ��Zs^ByXh\_f6^X��KGyXh<$>;m_��+OٞM?N?`efK7<i{��@,53{H0F'e 9NM��/g[H0FDR[xq��@ow_Sܧ&;H0F. 2_7LW}�� U|5iD4HAO4HSU��zZmb?掑`: J3N\f<Z5E��''GcSL# l VNR}+��){֑5T=4v%(X#aD�r( 7`: JcǺןU ��ۓfˊ3{G0+n`OU]]W +N9l_GD DhX6N��_9`V\]Y~lv֘u>p`T}'2b?kA?X2V-`�{a endstream endobj 224 0 obj <</Filter[/FlateDecode]/Length 1159>>stream +H_Le�rҊ%#"�tNTe2lS.kJH7$b09@% t˭R`Zw7F/}n8< sB�..(SEBwoRfՁuŒ'o[J|#yy;'ﱼ^q`)؛*Z坟Kֺ?��7 o;} K)c>g@O m11ݳu�Ž)RoT"ʃ$zһA[Mr\oKZu��p'fҢ,| K%Ew{Ė ~ rRqǻvi%��g,^c#!ԄD18K?>?WI'SZw ��eF|ݳod%q-֬> г]5E~OwFi'��⏡msR|} U1F{`S2?j:emj;+ߋ+<#k<NxG�| *L&4YKt6Z:3?2hV£^>zy̭u��0?ٗ1uw,X\o]\P0ݵgӫ��zcŘ?ὗՇ=Bi~ϱ?`a9vKG2��m$iVcmk{/'nYsw3DwL.qh-�� +vNa?`$9#OSKB�\nZ_?`$a9ɢ8mw ��7:Sbv[ z +Fѯ8Ư ��n6vԡ.S0\sFy պg��PO-S0=ɢQ-i5��̺U9TnV)URafPCZw ��F5LG՝ z +Fg)<4O^1?u�� u.A,<'EԹN:w��[-b=t0+h@q\.(׺s��t6~WRWU_ �Pz endstream endobj 225 0 obj <</Filter[/FlateDecode]/Length 1056>>stream +HOe@i%[+FU2p&)ÔB 13jC +a( scJ7!Q+r`e[˦rU\7WA"B?eՕ͛j�Nb\HKuo*�@YkwJMa�I"&/Yx{[_Ms7z^x}; �Gu)) $.H~([jכ&e`eK&Ӝflx9obRKg-U!wolߡvtf[Ƶⶃe�o%5cN7_4cO9رAFvia{K] :2wJX!){ŶTԳC�۟y'$:At +@8,*{YIh-ȕt�,bSD?�ss|]!xUu�pȩkKD?�ۜq욠}蜵I�7 +͵{v(HRPp4F>|S=[�9?x!g?Na�geyZڒ֜[\=N)�\&3o>�祡^]7D?�fO|i|k<>�;&e+w%�nMo3\ݜ*xVnvv%�bSD:E?ަ��*|,Zvl'D?�#M^˸o ��LMSAt +,,gZNfĭ][ר�@vv/]F)�n3k2Q=&7宦/ + � n_9_-JҋS�˜,Ul�[+!�7K(^%v=w2� \nnL}2 D?�ğ �` endstream endobj 226 0 obj <</Filter[/FlateDecode]/Length 1049>>stream +HHuOAQQP"#rjElD_vᚣ$s˛s-r9λ޹<7z_uNscZ6\`? [|/xs|KILQZի%ž"!|||WS B=;6޳�K_,V �g?)�䡢WpK[ 9oZ/�b35K LAd +@Iqd9;]j��xq1M{"S�sy唱Cw�_K+"!ew"S�kp.fimo[?�uN(c�RƲ58կ[�nƥ=>D?�bWoQڕa] i�Le%2�ܻE6ZO�BM]ސD?�hCj>Mu7�,5D?�jՎ'H^;�ṉڑpg"S�dvWb<8xt�\O<xf_e"S�`}W{Z}c� gK 2.,yK4tw^�OaϸSb/)�vrǦgŗʁuFFNuYo�5߹]mAd +QNMW \D7�4`;b�`Wi9`UնĕRO�{5dߕm+)�v<?K^26P}}ŴϽUk] ɐgi:F߱?� ]V%CSӵo`O158UZe(YYؑ�mkpщ;{Y�] Lo>wd'TYt⍱?�`R3ŧou58{2{}d Gsn|%�-< endstream endobj 227 0 obj <</Filter[/FlateDecode]/Length 1246>>stream +HLuABPa"\-f[k˨95f3W;3^X5A0_|A!b*-mC jAucxutUoSaa矙hUlJr�bij/*N-zȫB�;MtpWs';MMmxRDؾm@�w/<c_s#ّ7w^S>]#$7¹SoL>>�06)sD=3습׹(�Ī⓭] I2G"jBL?�`|DNՙݖ0C;Sҏ&;w;}N~zGGKqO�=5ߕsUo�ЎM#n} NHd�??;dA 45L4Ym%E|UzScGxCj'O#lV׾TL?|@.6|;A<)A ׳i[.0䄫�⅝Ӳ_ K.�nRqy?')".z0'm=O??ZL s�;Sc.CT~཮>>} ޒFse003�ٟ'O?Ծa�x_OɛlvUϰ?7ı?N W �.*g(3kOzo�YA&{:a Z +�Gкhk+6N!I{)&LGd~X?�pKpbU\.{Ww+M^a-�eX޾uKԿm�x3KM>vX?��L{Qd +c;�\}퉱/R R�^q޹|r@o�ܚxbq#?�"®zounQӕجXR�01R抍1=SSv-C{kc劫`-�kq^}rfüo�V'7DKa�ěXז"2o�ٱ=|Ug?��uܛ:Wl(ϛeWm5:7�Pύ֚Ϲ R���)4 endstream endobj 228 0 obj <</Filter[/FlateDecode]/Length 1018>>stream +HOeXn܊zX-icYtL+-AĉQ)͡9a>x)ӛC0liNٳAkju{ݟH`;-% uߝ_!gBq;] 22AHu`J-\!F{H +߅�Lxy[]k`�03oȭ3t_.87NWc}`�֞ S#-yWڃ,݉�Lʞ@h]`�3w;b6n`|]h=zM`�43oȩ.wZq't'\W\[zĤ?� +{J0f}:=92$�c;9`�LAWۿl]+[NWbR�<U|]p[TNݗ�tcWrĤ?� @Զ]i޻y]Cu8%CYg�3g2Qb{/ƪ?Awx\U +T<�$O +<]wyw\Tu1)�Hn+#{WQ�il=zM՝?Ia�@򛝿T+&] +yxC 4Ս?Ia�92O8UW5/|Jw߹22{d+f��}Q {o%{ݩw9եTw &�I["5>|߇+g+�ptdSi1)�0׊3bQCڃO?cP;X{Y-?Ia�^=hxogքw-�U8?V}Y4GubR�`Y]ivE]ݡow^oMQ0�Lo8i.x;~gݝ })eOnw �; endstream endobj 229 0 obj <</Filter[/FlateDecode]/Length 1121>>stream +HLu1ZӚ圣\kMFk]bΐ%8V*@d!`Pqr{w߃  QNKFk?h߶Cw{ {y Ǭ+s�ؖDeL?ui T�z[dr@w4jo#$�(7Q4{[M9[/ֽlyU>x-"Ͳ?�X6-ށ١;~q]ckvo xb?� -}9Q+R߂1_יow7HIZ;e#�Pmj{o"rJcܩ{LWJ,N xb?��{roVvʧئS-ke@8ڷQ-/0M1R�ZYfm[; 0xoKxb?��dǫȗ{y|1.B~/6},&/)=?��hyUa~6NL_jZ{`DzZ F +�p#w?#vɇշbˮw5hfT1;d#�^"]u$=w_ub?��PIڗ�#^uTHa��nFljA:F݀Pwe- k)�H=PO~6uob?��Tqܨ#3=U-i8 MU<mZ F +�o%"I>6uza-jzyZڵA9?/ Gn|e1f�B0}jFzIS}%u.E$X>=b9%)ܘfFfҒU%[c>��,E/*W]LyS[>rYjnA1qw/=ҝ�(7Q[>\Sl-ޣY\e +b`L;;z~�Bryv- ;u`v2ݼK$㲘kMdʭs.4RQXFc�AO�4T4 endstream endobj 230 0 obj <</Filter[/FlateDecode]/Length 1316>>stream +H}LUuIYe57 5#'-5E Pc"*0{@S^Ul\[q;ޟ=9wG [=Udd3J=~Kj�7jҫKSfQ)h҃)% ^G_6z=c[g#QFs,γ8ײ)�'LSVnj ug[BzfFo*9Hhpp\_S=cիC`U?��aAΏ⮺z1S1C;h~3kctBc:izΈߣGt + |I=�_'E+ޒ$qw4:}t׹ whv3b؝zcpXX;glݾ5wS]f=׵QZ:WSz/O]�2G<?ZwFH�uϊ׍;lٻ}\?3%q6|#{|ZpgFʾ��f+\>Mmew@@FMZ7h^ĞF f§ёҭe%T>z|�ek,!/6\!dij[REFB fMu-ڴq`hWRଶ[sP��\qD5KcmwAG{B F3B fMxHuXu67zsu{8?��f0>=N).p'u\mII\('C|s[Y)h>J��bȚJ.V Y?do4b?��fcOzPw jTJh&J��(*ͮsꎿ>]N{"|]cI[wX)�Y N9cD⫏ۭ9OhJ��.v{rxƧ{.^>0n"p;ےfA�` x uAmE.P7y:w蜄O V +�0P J$Wn&7:_$vb3:b?��M̖ĐZ)X#p+~v?&v'AFgA�` \;Wɫ)w/'r<K[C9EN V +�0P'LS7OhKuSYwIf~xHE :X)�@73{Զ+M''o8N5<b?��V0")F_! ޫ@o\iZ��9 endstream endobj 231 0 obj <</Filter[/FlateDecode]/Length 26322>>stream +Hn_wSkrgfe�A(]r,D�YZu@ծ KΜ9sfiulgu칧ޞ~/^?۟=fy۳W^^^>}pϷ?+~NiKoN}{|;}6%y/-W eVfيݦO=uk%;?eޞ|#+??,Yrۘ<e>ziL7BloTbjGfU1\=dֵnvf[T�Jm3�im>7g5;k2e!tw}%t͞jke-�:Q=yVvJ[S<Oܲ7^=Xi|r5X@[{Oqyfs+qP@HK qݵov:d{澐#U"Kj:GhQiP94:@\S`}sR q>LJ/6A#ex 1ET/:y O9d\p4Ves i5bB3@),9/ҨJ/(J Q0=KĢ7 h,X@j XEVyfs4ڱ +ޖוz!/v\TѳM<*(57FhYL#j,}FqZP1矉^w{*]JW,JPj2q;)KJǀ+wh[v6Bh@$rhr:X%ne<!^ǶQ5|7=ʍ]pr%E'CUU}6Di%=w*�Ԕ%t0}6K*E<u-ij kʜV™ }Nij2PMq9y`R̃dD9 +s3gNVqD!y] iIqS֒x̪8̔YRhuZԻ[!]90U0<@`{izw-T!My`c[#γ|u3RB++aHoPZO_㡳 ƉC GU3hF&z@IRp0DM1p e1JȜ|ꀑ鈧Z4Cu v2W:}DEf(Ւ7K_%!]%!)dQJ1X8 + YI)=/S!g tMWǿ~zLJ뷏7(OW~ûo^\|wwa_^]_՛o/ޝ}xZg׷wkۉr$]$e8=za˜ߢQhWJTjҮk^d;>CJ,߉+hIM&ʆ$0tk-m&D$F>IVXVFie)4iC%I$R%.[\3arD1͸2E[L6, d|&)Y(2欆~R4R'C{1u2d|VÙV!i1ToD r?{Q{ %Bz3Rp(&I顉  PHt|q.qRH fBh􊔗̕`\OIp_۬f?K\OCbM*Urd=C@B(;|l2er%(4o qDr^\^Iw 5`,v~ W32g26e5D�Pi2E +Vpi ^r�ePW]IU4~QO8{ZeP| +}tKi),Z֞d)&UMLS"7zwV( 1 iX 1Ge0F,? eU:c~y(]b$q}} —dv8/n4 +K^QA`�Bgqo:Co@l '-ƢņzDG>쵮Gc]sÔLtUJ%=%6E7(Y`4#$&]ū+UL�PKYeŠF�c�j0h$I*p,-+4Q17cԦ>J>abC`UoB4$Vƾh&-%AEhmZ3tZ,#СP5;Az&8#`ux GuI֦P߂hMcSQ@e*Opc[ %E)DR?@Ѓ'TʏߒI)e:;Ӌ6p%CSz3t]uOv39\)L"ӛR8"F.ILFEd44ҜR3hcRjĊKJ!jn)p5jFsB*n{fUs,DED ^.9r:]膾4Rjj'ʶ {U1R �_+M�'m:nT{TZffdjC| uG@;@~nC C\A.,b |AU ӥNn:D]~Py M%Z7$: ܸ֕i#eC6`pShytt{x~pcky C艱)L%`Z N lf?ږ cG&u6*l3 >ck+wf Hed)H%7H މ(nH̪=ɣ]*#g2? + ḁ/_I }+2 `vLJ O"9lQjVT[NB6auKQ.W'p}f[[ ?/7% +=A[P! ea{C1:J1S c]I&[K{q|@jM֍H\5 +pllf[R9jtA3e+d+|B<=oboxa7j[L'y=znE㕉t GNUQwB4Ӈl7JzTv~H0 5t7\.r 5? BCi"SJ>1ag+@hT_iq;RBČkƃVm&\FQR&[ G)=jrrFLQӓʉSS7E`'R;3Af1h<'7Jڹ +\:cj9sJ#rk C_ɜ m K;֜Q%=5HiݚugeسMԶ7#yhCEyK:KOxcxDu{Ѧoy\q A]Y89er`=E&h {qlj AC-i5GIv^ +(6bI׏At;*S=奰֙T]Mvsd#fX2 $7@ԂTT`*շҟvu Y5ܢAz_/[Rhk>l7#vسF}H){X0ʞo7zuYOcA(.4ݩ J-2b Rد_^jW,@ ` l o=gz!P46ZQ^yn6\cceM[6:{ +揼LjL%T�u7QT8^bRs@k 8Cuui$0f1M4H/GJ[G XjHD\j<ijtXdzڧz=" �XyR'Dҥo +yo\[μ26gFj/?lB}wN$OjR֧`BPS/SRiqJ +UZb)䔪YPRVڋ-%`]sDRMD%`U>Zdz!@hjP&)F' eON7Imzh̲Ҧu5r:)c MD#Z8|HV GDW%剪2'c]_J�|F>"n714ۂ8 %Y{ [/ �qHXb*)w<'m <Iod=䥀%Q? G@=JOLUb U{x*䑖 vB[H@K㧛fqt#lFu.j1p| +{t>@1=>JGID9S=em~WiMB 6%>g{̃T(��K*F fZ.!Pn5qt3|))DGg Dv'/]3.3#U3c6f|n{gg[xr%tkzԱDd7:m_C9[Y-o,PP/]1o&%.C%?y=@!rT\8:1Vkfqv3jwQiq٠=5�B*gF!F;87א~K@XʢFֹ{A.1v~fM45}w$9rvɏqZnV�I_-oqM^o|cԝ!p賵7?wit*JnEoYrf ĹJAn+V)7wP1A Mׄzk\\dЯ9.%m8"_v<W\pl]D& @'}0h"ڴ 53:-j:~i.X�-B +8##%m�o�!rqH |)55zv�J"% &3wQ3,u3vv|;<^}&9l@ 1`QA\1#hLeUip*Gry+�gqkR U%>e'h5b0)Dm61n$4'i %�@MsR;h^r~ ePf9ACh*ٕ:2ȮV#! 8좧9v '%= +9 +-ZQ +*xNT@7X3 +/3]?rB&8RD)'`ԹlC2nG1dИu ^RY\ch.)0[g/|0ݻ?`輅gt( @1Y.hy/eDƒA!@S-H2%@il0;@Y6.E9ط*�b]՛h P!.4 "zۼ p\$8^QROo$s@րqr +ߨ֠U~Q|"I;IAx~jFPys l˫R9+�)UHlN}(My ,>Fu~ BC +9Ɣ%BՕC9{:{E\KCku`at&@T&Xw`Y ؓc ;KAS%o!MUpot\}FdUwB].S4Z -ћ w?iƏCe5O1t}cVկWxar$[l7|Im!dɈh|sgC$&Yk߹PdĦUڸN!~nX-mHl9Ŝ(cedx Rkj&$#!+%.lMlü̆`(ݨ J�#2pI!Ju=>3VHdA޵&^r:[Z| 2hAx99+("IB'p$'#\1Y (zJ azf8 Thjз MK24- ^W؜B($'YOz{b@A8, !uxF^E  wD%~̹UΓJ䍕80):GۘGv\NÈ/LZ|(:GE]c9꣛8\ʙM}uBJ- +:Η֭#^xQͅZ-Tb rDW xZ.!~vf;["{IrtZb|?? .+v8 ?y;p15ڙ :,|[q;Ђi&VoUCntW=G4cB~|vC_H<}EB&ʎ^oB +姶 +_۫.t +Fc|Br\#}Ze+W*NNNl&4}ؽQ|%JGƺN?^?_W6ʄlg?\ y_@C(F*; 7ź, ~I L[dnDe rjVP7Y1Ebg_hK=XE!Ywm*,h%'}ΌimQ)1볐jd1 oD jչ0Xk. ^vvn? 7I:'^0 +no/n7 Y$xMPQ;)}x1Q#\4wMR5,tbz*TjԎ;NdV_XYuyI,I8dx}9O~[_d]w)\{b}[Gۈ\6#Sg^x;dNԼTFA2PTIbU 6]GKM4}W{kUuaAI5]t,ӿyկ6QP`,oL̵[i]ݿ)2h"GۇoY0E֏l^e ?+/uѣ/<PR3y֩ye)woIKmA3.?\I ~pxHl'XJLa  +Hh?]{.|VjD/Kh4]ӈAH rX$]\fj`@>@A&=X%oً2E UĮ8^-jצA)Gw�olg,ـݫXv�HקH+5RT<u8+Nf?9-/�1,8pX&_ *8zIC,kcfa~U:ެM~Yĉ6{$wem,D : @`V(Dp&s}0h?߰;y!O0J٘y*GaJP? m?:LF*S,�e,\zgr#$DدOʼ^FoHw:&PqM'f0 +~nv) /o(JI~@x Ħ�*d9u*Z8'` 6Nb:W&VģXwI/-1sJ jޞsSaY(Rf|dU:}C7&g?")( %HQ+hN E4EcO{P5GH%f ZC:AcLD )ߗsפƀ, @:j3!u?ګXr8ǽVӛ[m)h ~-9>tH0Z˘ "0"C7NARH +<rbҤ[@,˔<(]ڡ͕2J/s# +?aB'{wHACF !ΩK&a@.۷k9Ca}jI^Z +ϪFѕ+:eLj:pdTEqcպ`^ 5:Zާy l�vgD…r)M|]A(5G% &y8 tp`@gI|*E<Oi }E^#6 b˹%@[&mouY *a�x]. +2׫s-=o'oczɵ"qܫRA:R^͍C&x395q +ӫW><G^\YR Jr\ +%g G0�aC%,U;T<=W'VK [smL駑6M[םxm-u&T#.]2MՊ/ܴdUT(gƄ;oL Hz!0O-} P̩)B5lphF3h:?kf~{W6`6Կ!8WQkjLAvJK={ ("?H.)@?ڈ&|W +,w<C~CٶYG83sPTÁHP7cx)tQɆ YR+LE3uUJ1n"rW!% +ݹ9 JAMz50v)[h'F�w* {I%bےsWtqHch*бwV]rCC4^ڼf+%d0xPԀ:` B,rtd&M!M;ּ5�)։ [4:T +JT\Q[ΌL8kɎ +v ܷe2u/e`8RPHp9\l{NMWx#! ."մXeě≚k}Q Xx#فjtFZtcőd,wwE#oʆfʉdәW&j”2<kbM击c so;E?33ZAװ"{VǙyp%cD67K +Z)BRSE/-DqXֶXiyX3pEȭ\͉ D3b T|)ц)?G`9Bozn|~x0/W?ǟ_=Ƿ_߿~x峇w7߼>7S+[c93Vu: 4fDLƠUfI0W[@ J숢ejH韉xO$.�{-%)x*SZWvBF6%$]cLaQvмY[ $7_K6i`R*v�ᄱc s1 F9l,YN�N-J hw,&iW(h8G9Z.`c:%Z 5.U6X.Wey V,!5%M/SC[ eƯP ΘEfû WƆG�WFYRtzrCв^MdD$T^Y"yeݞ%yIV�b1c +0i_g/YbQKHPEjxn=Zs@k LzTg*eKꍎFs$HHޛ(HfMRgN+ "m(Ǒ=, ?/A/ڛkKg,KʪW5a*s;Z[5;o45 Ho۔Ijyd-fTj�2i;fP:"3,U46D]:*EK)`giPz 5HN]4@.oyCPyx2Ss*)}Gz1g*Q8r'c@:r!G<R5*- .KlW#aQDJ4s };H_cJjM(dH +_Cʨ mhV2uy%�dB$w`-$*1Q(M(*m9IQr>gk3MU]d$dl3\FKߩJ)NY1桸٩Ġ`ho_`"9.8m.͐N1 h}΍f)a7­neˤ;ʴ^:p0顫yTq1"3B7 ,hph +x Y@BHZHqS@JE)u-fS]dm ZkD䳶0`5ytm +ZC5RjY\Fh;#'dHA-'ƞ�Noj ]AAYK:Ys`n!D=v|!W g#(^EA H,Zd)= Ec1w1.g+[B>n^NuF9-#_Yܻ^YݙLUU z9U]uƵV@ZDKj^^:tx0 iѵ5"vYFѤRޥK lY| +<XKQ@Xaۋ&Fտ/y�YDj=Y8PܩLTӹj׿Ӆ3UgDg n"qƏj Y !?/sd@{Lv<rr[wuN떂 F| H$2mcTknH|&̀tɨ3/%E2Ҫ[ABC<,4Mg<r|bpv9>Xs >_3[+e8nrObmT&ՏtO +[NoePUd8o!+>g>G":I:3Sn-}FqI 1D:dT0Rc%0}D+t6F.mdz-߷ +_ʹTTUe A}zO<<u!h%1mTN}.>qoؠ9.>h 1-p-yrMb"6ۃwGG9e5MM*\` VctV0 vPJ^Hdw-y?M(dqѽN3%50T\Zbζ" "ګRC ]T o3fP.Ȅך^k۟۷onG~'w'U*@`em'rJJ2趔o:8CkݎΏ�+<pѸ# D/.L`;_ywnjTb{er +bLpno7l:*q iK c*#$t:tK|4Gb+fPN%]3vyAܱ0lFm8U=M][38dX%k)))(pjp)#'gk"HhF9?ׯEӷ; wӚa'D!NJ my\#}b�C)!Fdc")å 1^$rwzJ0~H{/c<kzHOFϫvRX--kwe'?#Oqpw4O=Oޡ!IwO$}2IyќJ{-`%lʈ�W,p:Ks}U+dcuv#ޣͿibNgOD)^m<a`VtFi<�\>1i+o)ΊT,<qu{os|Bj^ +Hc8OOdC؟t~.`+$kއO.u&trfYXrCujj: u|ݥv1:DOVk'n(ε~,=ߍPYPN"ks|<"<vUtfLU!8ipqWv+ϓ+Cagz[¼PO)4:ҋmʜJ r"1G8tF�/Hb2wd o,rꃷ:4] ŻL5{le5]<oYiMwVsL#d%Tǻegvl%pIm/J|v%-`@]Tߐ%VVJq>yqO˓I~h5^tlG:EJ} A|hrG vV񍠫B_k_s6I 'J7MR Ӕ< +O!R VE`f6j% t^ztC3_6ןo:݌#L߂]Mq#`#vP7<"BC1cZϣ ~R>GYg1 0 Đ7)DZ?qh"#*j8o[%* ߄�z ('tZ1)`<KEsT1˃^$h&J$hQ3Lk-?ҶSs]cG�N:=O zK/Cq|a2�뱓4?j �2oMgx 9%0Axi,7_f #mΌO)A/ayn[wߜAZ' {ue%/}R{ɒ$' y~gV暟9 MݟlCeL˻/i+B~Eu@-,4hzk,  Z][Tvu:ˢ퐛t({E6/hVsH 1kg'Hr�OzhB}q[BkR(;ޢƃRw~J'(GAe.D]73\{("R:f>^Cu_1L`8ۑR&5T;"/<ץd8٦tv? +/�Y9Q.Poc�DOIkd.CAi-X3iRg5n|wѨXPwO9;uv,ҷ X^ !D(ΐ>kzp}oS#4i%V3"Ȣ ި5\&<N�t -~ C.^5 K>vPpu7Rxmjf)Fy 1#<kb}<2 l{"4t&$VyRq#Jx?.,nY5@Zmڃ3qq,_»,!ˍpLs]hu�۟Spa5r8am(݂z\~TQ DeMGC@;t|{k:_,&Uտj_EcXe'VZ3#n&P<R]=|$KIn|ޫ2_-tB[) \X$$MpP)x^c +P`8̓1+T۵$yCHХ,3pL.MBH)Sѡ=&uI1h- +hw۹|@62Ρn$_w-%7>w-OZ,|?~Nkz߻s3fAIg v6DL +td Wi!uH =fC)^O;Jm}J" E4Q"^[qK}v\U]rr-۳% WԮ&{n"O :eO ]3t,~ϛMe$jG P:ҧUrI2L"凚9�<vBS8F+ BST_M^S"|`̴tD.II"B:4\DA/ՐȈȑ9FYvFfAMֹ0{]!F,-]:/Lg t;ɫ85wѻDJPhqD2m|AND!2]Fĕ-}lU a"\gwv^skdF8�bV/lb-nC8i|^-^#[TE!Is>0PTKmr0MFPJϡL\=Z+, 2r?Fcn=g+I-}HL$"`ss&jPM(+%iPC#Y((ًYpy>rԖEOfy>aއmЄ q!X͛əbv3tOѕ$0#Wp8-Hk9;CItlMc}ݾ4yV3GjPEm+BPCpM;Ya&}t]zI_OdN-7Kڴ-1WnJybT[I.VRe1GJdU孚$͚oޯEMDb)>$;Uu~@H+2U^s(t5ᄦy}bハ-sa J5<rkIJ氶2_epfXYRqcG^2|TXMÙA[*q;-uC!)-D-=\,EuFo9-.B>1}RKPNԍB`lmksj/煻h'I]�kehNj;DZl 2h#G.>lNdecrl]^PuAti +DеmL([ʰJYl�)`)D;"hKiSݑ/bhk}P.jŜ\SzH!1NsփFɜmJ +I2#.1eJiPD%;�-f+~b�u_ܹ[fYXEoJs̰:V;//(|!)F]ʵbIk#7A0t륚Pn+w <Ntb]dR.B%Kdrz&;"2zq<} ?FO&"Y 2nh~w#U5ǿ-P!}*fImLI#Dt!HbÛj1YB<ox7K1( 9CEYWM +UXf&v7:mmɯ+ +A .KuTkN-BgN9Ö͇Gn5% *OhxదyI)nAfv#x4o ߻Jf7fD<LvM&;&K($s5f-qȣDY5liMt=) dHTE{SkNYNJ"-PSQ)4Eq̽ C2OQ }Eڵ>Ǐ '}9BW퓂jɣ wtRO,:xͫ*(쥈XZ)MG5tPwL ޙi5[OP]%mekb&i4 B >Xm֘B9j$=nN1vBD fqˠ(5>z"pvO,w uEi6taaݤa (~ˡYhf</u)6ߛҜ bI6뒂< \e[aU@(9Q饠 +׼SNX`%~ko7/ݥ|MЧ1[ +e'+qɾ@2,+*ɬ;.TM+(EBeդ y,* }tsȦ$q$R /^<\ +"-t+9\7+ JӒudI;Bl8U=Y4&^fܹ@v>+md2oŹ�XPfNiK=[MikuCTǓ;դ~,%WC9؞ +|bؔ]#ykLp5#XjԄ[TbN>ȫQI\3!TdL6015mG1lZidd7[ZUo"M뿴&; Æ$PeǤTCq1O<)!٭μcKV٪zYP*|o#WD]5<U]ƾ@4]ϼzͥtEU U$kMDIW�]=[Dw&* +4zgyNUقCozc.n_0]K<N*]>X8PGB+^=G 1|@K {3'[k/Z1t?ve-o}S9{VѲz0 l_ uN�0_cj "j6A+N9.l:lt^mmݏՎZDjC9_:͏w_2Vw",]=,ҰbFT>q5#>dZ'K]߫|Y*rs-˙,NCݿ!q)oioy +,Y{ &ߑW"̼�Y<[~q� }�.,!w.GVYmkK$,|{!$$yJ\99O;%jOl)n�}JrUN[Lo_ yr6Sr;djp]@pCJZE"b-kl~d_`5#Q(/FL0UA].wmN''* ɶKy+@!K#DY~V\y`%uD?)W1T>rG]Q8ʼn@^9tG0D w|0I5=Z8679؊vn6/lg\#|zZRLpW7 6uka"Џ.%'~U,o~rwV*p2N~Ӳ~GdYsq"ʚlw|j`?yuTQ=Ll!QIICi Bs#9)^cv(Ynm魏bPa8JIdEWݐyno źC%[+}: u&J4ˏwES6}y #y˘�!C0Tpƥw]/QD'CNȥEc?+,uZ6 MZ'3-ʙQKd4O/4R}t 0|)!Ռ\K +#CV(ʕDNA}ΘbN$"J"V&X茟z5{lۯ +czJi"j CnC6a .}e8'rǮe,rCЍ[fSs܄?I-8r\K[jQK<(J +zծ:E)Lf !yU 7a>Ր ЃADk +L!Ql 㑕(MF'6q*7Mxt_ΝZ* .,x]l[ {ƌ:um yӰtɯ;Z1e|K pSM_%iOa"B<N}:d 2db2z(=|'Q'zVx_yo0|W@#WV 3ƬESAwO<AL[BƔvVs:eC եrm0 }~\y¡ -/4cYr<*6L+=}dǺ63fY+;Y+؏hҾ9=U.!VEyȊt胺/&q%/̯ZH�1Ui㝒e^z5HƱ`:dY+;Ƌ/HP^ܞ�S+Se'KgáFNf!Lw s0*ݮN8i=(Ɨrxd3,™ u{! G]aM +~KM3bݙKTi ޽[ϳ]CѢbf)UW Y=E5H]fQ ]\{):őF8m.ٲ,PH; +k԰U3AEڻ,/B{}%XU6uiꥂMuxhU{E؜fIgOL6k<�,{;QV45Cߏ0l~&EwadE РNdV?C-g6e)4cO)4A,'kiUŻ｝vqZU3fv $?]-J&*EVqP.z>$[h(HU\Cٿp�[n'~mo Ǟ[&y4[<nqvuL #4m9X>ڣ| -hәi A@emxbI(GՏ`%1YsKf璿lyY1QbL˵>xW<%i9X"�(;iΖiDM-7%~O&(~jGUZF| #~8_aM'0Ԧu}Q`sR9va1ʮu>P釈; 1i ^GDme~B3YlAz=%Te+Oj/Z i /b(ǁ LFf?ތ~恚<X~޺݇!5I^N}PC꒿.Sg"伶:\(w:mX&$owW%{Upw'a�6V!� 8VnNO<s$w=6owl[p۝a,37iw)^k#J ACauR%э^.uY?IvH C M<kB%UC30ݪ:Uk}[#팞D`:yTzAg 9,l}~;f8+"LT]1R/{X qE7m-E+"0P*Nѐ,. s2Ɠh ~e*v Yh qusBp #c+N֊~j$#T%ΰڐϬr=Hgz` Ug/:QG4vk ZHJ 5\h20<.jܰKI3䮜<j 4d=S#Kk;k3*T%XM&F1jL(W);SJZ*˟]/?~y|_,]1Fח/ϟ=~{|/%ewY:lg5yU(awMqj>=H:5P.+ QL|aDQ{ }id?7Um9xa7䃊Z~R"RYԶ;M4dNL-47^-u ]ocXeh&1<Uj?StKFL2,u'�*Uƭ0H>GC9?N!P�P/'N(ݔ5aOX샱# v,-.=)wXnr4<FMUnq2i~0 b;vB^ a5%M*j̡5Dg`fHƟgRXh_RZՃ>]ŢLG"snJA%o $ SK'i"El:F cP[1QuYHU%3I~1>z+jfIV NpuR]E&j4h -7h{,*/LV7ـVhȴv`F?߅wC9(]*W7'R mHRIᖁU' [Kl 1JqTӐ_ַOXoӄy->i~QàVPtyw{}e{7۩>7DL{CCUJH\zu>OLr_p0{yVћK:L{Evl~3#V DQ|2 [ +0(Pɨ$c+V`�t}& +v=7VlńIBKWZXqQ� +ѦfEoSbd=q7ϝVS- )+zWX-wk9eD)3zA"BKo[.-SXg(c$7/! fjr o%20CLLhxr=No9%J{vl`PVdxOb=Ƣ> + +ܒKZIu!V`\jc;L_s#i+:,%\ rjPF-5qnˮal"AIku\{DfPZl)$0@Kj4d ޱ$�R X @hQ"IXYGu}")+\r>LA|8՚}וc(]n[X֏(PaNcK�"hWRZkVnR[k@ORd'w�SL=℅O/=t,82<N& +fʎ+eS<*2)>&hvtws>qJiW>3*Q.;d+7rGŅؤꎊL:!!i{J%%vjdոo1~J3Rk6K $3pV*azsK0RƹnE ̧rHHT Iw>BU = .<F:(άDl'_S2핔qE>L)֌)Dљ}MMkm1 9Գzd3g%~]j"kTkgcөfqE.˻ֵu!;U"ggYij/Ʀ3Xu5w6if]f&kI�iܕsCE @CطfV`oLAVK$.oAD9G�},6(;yi݊nfHSkB(\j*>KPsXsQĆy+,;j N�{("DXaI&i<%wMf^j2U;.F5dgXō�ji08ʲ?BS{M1è?s=hkj+EݗaIO?<0S@Q@M@kow;dG^bxf7術wRuSlRulBBK{mr0ۧuIҩ>ׇ%<1*=4t]TЧYJ4Oޢ`=fJZ<v\W#ݣSXyZӿC(\y/f/?~y|_,Iɮ^_<>>|xx|OtqgE9yD(( b^2ŮD"kYs#{l&\|z5Ie?qcڱ٦PCu|c \̤a)F͍+\(. +Zg� Z +gf681~P%< uE~?QG=.YaX+$YGXYI,i[%ŪO(skyps~e@.D`;w(%1.jdn$ERBϭC8Q9e+RbK90X@Uu\zQ|v-7S8k>>s67*}dMOP#7x1#)i|P /ݺ+~NH@~wG#ə0A` , P UV80@2Urյ¦h%8@+VC8N}\P6B]U&Wd1溕16=+ +xCD"\x1H,8�G~1,.< Y! Ha{@ʩ[8j'e[h9kF ve\tOPX%:HzMS2%>zx ̚XsOM"X.*�7[) C9sh KY @.3KN1=i;Kyg1yΘ(FF%.e +TNsRd9$- 2j@p);e. Q3%alt +bP=+/k+F#IRɩ M~zLMXP!]KsG¤4} ,_(PRbX@D +* nk]G1߈,dXec+o$7ւc8[uf^dKkIl�7{@LeՄ+^smsy0lL̆{P>LT%WbҖ3^0K`\Z cC7_1r.% ' ihjJPT w%nW!CD AزoТt>$ C\pY$ّV丸 œ1ssu`v啬]S):\/G$Z]إ⍦vJȻGE59gsSec~sM4Z?Сy} f,_0U6\UHqm +#9sY^JȯHj*mc`zh'kl(Nw1:Vo,c@cM;1G\9F%91ʺ/b4$&I#G{~+ܤױMƾ+:|y>& ց34:RT>[k>lZxWoRCjO6#[KR?Ԯ*ԔF0jʪ6M}%$F5N!hh:!miWf qAmu(#<(mB6ًyPkuEZĥ f$y̔ e@ϒg8W,RbwGʨbjTV<5i%ۇy 8\8Iyb F +HL;XRXmDm{=:-)b]!k|FU1Xְ B N4]qF[!{y]RAGz ICUٖۤAɴM)֋e*2.KCeú+F8{q%C;bmFNfDK q"4O'.Ǜ׈j  6B٣u|b{ԇ}璑iJe(P&Ґ=f~f|&{&ZtU7 +cj9I2GYIŽ15miZStFU�b˒S-4H9s90S8}Y7K(-A#E12WJHm%L^nI'!/ť8i5!ߥHH93&wH)y&ODP32GgS,,3&TQg'՝.SHzĤC@IޯKt֢*3,<ZREuXa +JlJH#e,}X F@N:\:G@ + bcTB.?Q( +uXkP*,KJ8#q1R +tr:jn#٨>)/&΢sd&}=ծeWQF QSU5Ib2.gZ2.EV_w?zۇCW3^}wsuw=Xگ^z:t~Y}O/n}o~{stO?|wO}|x{w㧗ӫwyw7o>ݷWO{xXW_?Wx)qn:xtAk]û~zk;U5p@)^@dEߣ%>g4(sͤK5#8F'<sPEfi g!Ԑe9".КP4jO,>d%C*T Sr,Tc)礡6ꞛ(j$Qf>]f8[nz`d!_#iRíAbhrLs +2�NC(<VlΆg둅Rc|C)XB|ծMoOt> ~UD l^H0iע5 G w:FWP�~x=\o~�Qړ$M i"e3y1nŚD5 �}in6PXq#E$U&:JWjBLUI"VY9 olΚjj|uf}+)JA�/o@:M)LI ,l3hAp1Ȓ5rEUap8#J90MutaŒ\YY7q haqlYڔ aD4j" +ElJ헓# +tESiUA.ac�19t2b"LK .M B͗e#0c+4z\}x.!9ubȕPORM\/sWɞRu</7 +ųE-Qu[rTU؈]y@콭x.^CxbֱQH71vcmŹrǵ䆁 +Џ<=006n$U8o;prg8U2 ͭ{heүD<u'4tfUFÆaէCQ vW{$ss-C߾9~l</a ѹȜՑҮSS쏞)?ߚNK1 99jxrkd +Fjj +Qp#G L<ڗD-dub!=Ga } +j]t8:ͬ +Z5<!!tX=]YOMT&wbC5ۅ7Ng-HיhA]9B d.Ēi9P]U<C]?mI%RŵAʧW/ܒqc-@8׀bRگna俛1BͅD{88^=%MWR90sݡC+¼a; +_dݵDQмO-15G)00z<6aw>?7C 3؈f>\7Ob>DpNpˣ´/\ e �}:錿f%QmUL TF֩`&b>kH:n{q'>627ܻ\oI.=2@F#CO5C&0(QrmPȹ"ws ,/ECRv'uqHZ-F2J|+2C5!S4Q=N"+jFr/$])&=6s(� ׀ZQp"[?`DxYo^^l qɍ܄q,YkBV4J�-G9[:+> %<[(Q N}QACpv}E8x$=ޅ|ە71^q0K4DeJga£U7َu,]y^±6RVVPzݐ$#B|6KN*~Hgv s>0/}B`*AdgJ;EO77W<U̥^>.Y8=UU $b)\筅F&آ]1󋼔}(Fk]n3dW-MJۮЏb +ʮ9= JQ] ^+W# Pp`!4\`E߭u{U>VY?�[kA endstream endobj 232 0 obj <</Filter[/FlateDecode]/Length 985>>stream +HQLerb.\m[75kVc0Mj ő`HÆV@6Fv&#=1x`s\MmItETWO<}yIr<Jwm dg:�r+0^9Cš+sO◥[,bSn?Na��t;;Wt)ǎ\Lb7&Ŏ +vAt +�5[v]<LTg7DKCšAt +�ҶEd:du +շ&W EdJc(�JAGX銒`͍sN椬S��/~E;m|ew'1}3At +�%[\ =R |1iYoD?��^q'1GD5աߠTՕ: :�܊MFm&]PxS=d}e��x3ݷK2U}{s'LYOD?��^wߞb5 +:":[gߤc%>=*(��mBҟ8&jߥOtLw~('��xrUm^V懁-kUߦx_X^K)��OXCGxJBcޔuAt +�[Ш +6=}Ttۆގ +YD?��nq+ǎdnmP}B?#v۽me?Na�� /&+C +}$ȑdd�� +{ +߭Ѓ#"ӵ"YD?�� +n1٥sv!aշ+?GX3otz :�sWcA:.QbVα?Na�U�~I endstream endobj 233 0 obj <</Filter[/FlateDecode]/Length 1179>>stream +H}LUuCZPf)-)[+X0"aC+RL1!F( x+pm jS0jfMj-ޟ9#y~E%|q~<9hǯVK'b$?s(iScYֽ%P?*ܣޱz]-�`8ѣ.9;̽MM[Y,/:xj;c#�`Z/nKS{j$XZJs=,P֍?��`i^<>`'&mJt_=A��K8|[gf$5mq_=i#&7PHa��6*Xje{1E\P_Ha��ێt+o]s)o~|uKb?��pgscVb3]1V56A��gVI {7jzغ]Z7 F +��x2/mb%M7?Ȣda#�gH5]'ԷX<‹ w F +��KNVu;Z\߃!g"U{XX6͛a#�M^gԭמ݅~nR{Xpv歰?��@UY#o_4zO|'xgoj )��ILe2=t{1 /=,^FD ]-ɵGSz,.[a��Jwy*eu>5Lt7N٠0=њ zz߫ {KSsNJ޸ZlwlU��Ê}oHt4V6k bw zL]qQvCR_g[;��%/uny pLU1Mmg4WVciY;��YfepB讌wg4g"_]Dٷ#y3uE!AOI{\L͚NJZ;��uvC3Q|gs$nk9Ƥ>gÜ ��K;ԧ'mGf[�8" endstream endobj 234 0 obj <</Filter[/FlateDecode]/Length 3421>>stream +HyPwDAJcFŬf1&%1FE `UVA{Dpv瞞Qэ&f5[[[fwpl!F߫7{D*0RˣR4?7@C{Y6rĈAjظQQCTb U}nĒϬc>wAA[PLoH9yq<:["mdGm񜹠 S{v5|}|elt3ϪAA^H]B1л=y~(lc˶ o#F Gr9Sط7kGl/_=ZN!kX;\L=  |ٴsBIwIw^;\qDݡ6Zmq=[3i?<zL˪-g ALwSDM]  uLmr4h6YÜӌVG گ?Ҧn#yP  ȫ˘`l\"-t4<W;@'ږU<: 9cFZJ''}> ܱwͺ q^:ڲyV1A{QM)m= 2<I4 +ZׄiE6lGHeOa/4qRZyĤcBF'-|jL]%n&2n7vyo"CY5@ԮLomPq@ɛ::r$7 '|Pu>ߗ:!4RPW2QdJ;y,:6" CE_S +fۓȳ9mV\Q '*~匨9E5^RB  q]ALMڞCfolTPr]7A0:i#{{fe)a4a @*kGEzAl[4pf{ ;B]Re{?H ?*" ܱ&Ǭ_OzFEВ<Q '*.CIټ/ya_,OS f6@#VX/.wW'#ME&Z4Kocs,nqP?^"|,:J.rg(utw{sAcZ*BD)ZBqz 6$'[qD6l(G3A_D|TywjΘ"-e歌Vμ2etcM(3 78QIݛ,J]KMgSf;hmw ;}<fRint +׽A,YЯN[7񹟹Hwm8POb*,yKꨘ\8p3ˆ)+2>=:]H. 2O:.t:W+7e~qFCKa&{?hX @>˅AfIL^wlEE^MHu3h|mß:wÜ5C,UnR;*ݗ~ x{}q.܍cfݝ<mrwm8P M! uw"2 +Lmi|3Ok1;.ؒ^Q3rw &v:k(Y-aα~k4�qy7=]Zj@)|ϫ*9E9vuw Q䙘1%Gu g1%s9QclJuIC6١@N c8~*UT&ZҚND^^^ 3q]Ȧ v7iC�0e$_6^ԇNTkeM_lk4gck77@-|^_|f^$z,! 䎊{Ysbgי̌sC6/7gm"Uze["s@5ժd<ǎK]/.gK+A-}Gn-glcc[P {}#hg<=A\glE7Ԛ_W`6�=P '19k91-w[&f=6N|KlgtVigf:.t:WkkZ@ðZ=~\^[n}~qGM]C*|V=ҾLື! J{jhF 9p`$swV?І <Kh f遀S[s%^OkwvhU"gLhPVkv]O A_@'@a”m& +rv5MQ}~uP+ '῕Btri*A!TA"=0A,+մڜ:Ŗ9ͻ^31(¬?k6) +\ =wXsr}!g'+Upܷg$A<Q|9>!@J(8jMy~]JkIXaޝޜБ96O~u-_A?l#ߊ*s G]<,K͆^ܓ+u!9~43p7yNTok 3X1cȧ̼ġúvs߳@ ߑRCydQ6+y*G~OCA""Pqz2Bp=ע.9wTאQR%/459.:JvJY2Yy-',pTٲ }cF!)roIݞ3 # >aqO9mpIpԩw{S̱ X#V{|%${* ^촓/7 Y@ ET _`z{* ~ʌWxtWj{E(ERݷNvF ІQiv"S#8bin�npjTm\p$/k}Ʊ^ȠȦ30;&F(;JP(_X-6^}jZmo @ Ki6rcVPQ?+ !?�KS endstream endobj 235 0 obj <</Filter[/FlateDecode]/Length 3313>>stream +Hip`⃣zڄ v +.!0t m71eɲli򮴒�1 +! pLCh.]62ʚ}=}x%q. HϬuDM㠩{%&y\,&iӃ#h4c>{-o  "z i<۝ f%Vtj$ww×  bu}θxuL.nU@m`R@A3c&4G}YiC+GKAAON' 1>/:Co٣,*X`R@AyX^90C^1v:~m_홣@  2u{ qpЦu+C `Rx1 &[Fdyku(%+e<þ&['->A'HJdk";q^>UzM?xtr,`"ݞ5 _ +oY0J+gZM,yN6^%8ASLΎ&zhcʺmc+ bD) yo{$|Ժ~qF%=c?C~SI?O~ +fuaUz ȋEԱ:+?h^{;mvЦuw?0|)砩{ϋ Y(<X?Uzz wJ'_˓^{3?|KS<9[? JzoX<Cl^hiڪٍC^~jr:WاөWm:K[=X0�/q!4y3aS +VSu6^3~Elޓ~3V=OVVMo~\ƭ}<̐WU6 jǢܕO`iֹo}?Wlf8Nyj2#P8>d2`^<hG<OdƦ J +#5zgEC/^cB"&[wADT`w:MZ{+Ҹ O/7ЫUu8S5өw3VY& bv[~}9M]^5IU)_e8hAeF0Xmծ@հܚ/\\PIjUfu1Qi|?�޾gi9+*oYY]I%yrSӖB!Voms6]|<þDPK/M^ߐsB^�f\'㛋CVS06G_ͻ-% -%Sʙ7wΝ rxmBiTxp2^{}C~y6$ %@ڬnү_/Sf)h6mos" 5EE7m665])~2u{CyMmyM9n}Xg?*́<x >vzZhx->sEV&_fEY Ki(<w5CA^yDz _T:LrMo<9K?B2xkyhg>PD<tةM9Y54L +%X3Ys^&s2>/9ĐW6?]M2Ws{]JĞfB"g :knpT = +Z.\جn{H! /] ÌV=J.S=KAK#S7T_P8%cuweݶ1MN68[^5 +61]$ <9S/ށ8ۼP޹b9i%SqI@g3CXjyXjX˷ZV=)#u 1sK7¬.'  " +Z4׎#:<8UEuZ '<9??d~0Q)?CcM9@ _loz`9Ӻ]PtofhUf y)@6麒ˆkGXjon?Ч6^ڪw\ĺy\}p>x<xE@Xks[s; -%ScXmnpH! |[[Jԭf#%�Rrfw{rv?0|)�<0ܔh6-BQH573 jXu!V >(1L_~/})ٶjgAm];2~AgNqFp0ƻ?|D#&[əFQƨ2AvfX'ܿǤof~,ĕ98[ϡ-|>)cɏjLjԚP/FU+&�?uF3#@x  +V\Fse�ّ](ţxb`'3@m;?z+;A7(N`0?"TڣՑ({׮zjOg-0(_6m7@|Ww.;=uũsՊ;lZ҂Mv`-,ܲ�\mS7-^2'ivB ֭mCVj#yٖ +Xv]y.du @?@a޾~^Mޢ.9Jg̪Y55 Y_$4nxQ<?^-_9R''>ei`>pc+ˎa˺W +ؠ˅M*eս[ \&�jڸ$Y K78Rxv4z.4w˅O.aW\A|Pԁru+n uc�-{A!9Mʠ=(L@Yiű|sQԁOٸh.Hon&Ct̨]55X8HK37/] ]۹vP</̰A׾~n8nQ<G`H��M endstream endobj 236 0 obj <</Filter[/FlateDecode]/Length 1480>>stream +HLe�' H [ 4Sdp`9̕@ah(AdH`8{_<3xQreVJZ[[5/ x{wl{}/5 g/'r N:lt;5#`V=|n<;m:Ao}Lk9￧l2D[lNs<ru $>DkWəq]K.Վc=��`g=|mpdF)q()<aij4K̝M-Mu׭6٦Uvz��0:Y%]Di;H:X!_I\?%eO +&RJ=cY ��@ff'& Nm!}W 'ĆK[-L?%EcV"v秢X��~IuAN7/ 6te+_"y J���n %EyI?4{ 0$c*?%���Fəqn8H+unȘ̾; V?' J +���vkMƒ3F2D(9G@��� +5FmL 1ѻtp9F@���&_#M u_(yyaq}8KΚ?%���̈́nD=}[$wZQr֋()���hh3s\4_ud)5 QR?���[EM拟虞u"9D@���f/mk2&r?jY#<P)ܒ5Z]b.w]~>2$kvZ,/i??@����oƞc$>Yl'YĄGwp +:); K|wed<j寚pw���Pe۟g;rw9SwZP6S#cNO|o^s+Rkb_x=?#2w"9�π=IHzcU"]| aw#@!w} >>]ڑ?G�c>x$=&lsi{+>tQ| aw#2$9uX[ͦו^a|_;nm7!ğu׸_-!4YkB@X]56`(7^a|> }h~i<==^ ?__YwcyB}t,bcs?s5'a|1ac,76:e9n#6heĄGsS\ + 0VWR]͋^C} Ul:2g`� endstream endobj 237 0 obj <</Filter[/FlateDecode]/Length 2521>>stream +HSS7$A^ +"VUN+Ct+*2\*PEyY HM@֮;N}TmhLAd<gs =sv 3jBW/f/ԁ?K] +je j:y>ԑ" e@rH|bg>;-0tʶvmN~w!B:W]e_b````````,݀ A/O׍yE Մn?A"i& %ЧA}8 iC.w&'Ρ`MDG   uIIP]qqPK~-DQddx9}ysN}YY(8tAAA\ LLvnR kb=nRهuF         n7EIeLkN /H]@|\rtA&-|`̀#Y^͍vф *;dKjUZf>AU$cCX\5\Go6ǐ/ƍ'ݝ3SR%%Apn+Ud*|fZ+UG6wt\TMW9|5X=I\vηǚ=}z,wuQQ�.T׬vY"l>bZ/Wͦj@j23SH ^4XC$w"m8-Pc}S[!ERvqjQzY"?Z.]:qXG<c{%p}z|3kCȊMY}gu5"{};m,=vl+-ׯ #S? {,9Ѩ1j^;KM]>rgrM^+2,辴CO"Y^/Wn}!8{ wm~Th; +dHhcBj<?2F݇m [o hxwBE iկ_12_hiw!,~Q W3v8,dKg}m(uOW%X ?dBxF7 #kH3|?'Pc^F϶#)Njn`zH:T /c\Vw$J6Ic3B%yn\�ޓCĩCG@ӂ_ZvSoT͒ ?j>~`5׏tz:Y([ ߄>r\ȇ5l:Tu+3%\.,7꾛4^}#}zL֚oe 'yΨ Y>e9\/-]g/:#:B@&L k-9=A'RwV9kErj`z+Oψe?@sGLzECn.*Y$֭YK 5F<aRml/oDZI1u!\Ò<lFRY.3C�c:yL\4GvݾfxFY]QmcdBzU$Lk9Zd180ig$莶s#j67>2v8,dKg}m(uOW%P||rO zEG5vOJrQУl G݀k 7ey'#V&l +%w{{F50%IqBVvc[^=THP>H*x1Q4UVDN Я۷V,=&8I!\`zGwY(\ tw^0nuj~\8σyGL,;F];_%[.] Ս9E3gd[&M#-pKΛkw]םYՈs﹵_{rh5sW:9ƮKH@]"C^hfskGcjzL<Į[5ȤfZЇ˝Y/ΡLt/@C].7^in̶PcēP5K2`H*p_qPҐRw»8zC-Y0Xsֆ Fwuߜ[#/`pO͡mYʴ^]-3۰.Г;ˮ;}Hy)ej잘:**(*0^%x/Ω/+ 1ΪF켾5V,,ɥnU]f{{5*<bfjxLkw~G첐`L>e_jf&A$aε !NЛ̥/\59~h+foWRO6'$=Z~1N^._�s@\ endstream endobj 238 0 obj <</Filter[/FlateDecode]/Length 171>>stream +H- +A�)@ٲvE`h5 + -0x`_MǓx٦Us_S\U~Q1 Y܎wz>tbl�������������������������������������������������������������� |� endstream endobj 239 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 240 0 obj <</Filter[/FlateDecode]/Length 285>>stream +HAj0DA +,<YX~joA78��������������������������������������cN4fLa"Ss?0x缏Y[K}_2UVw˂lwx'7ql[\~ēSXcÛ?9#lO+vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vb׊i*vmCT}pb샻6 fǗ��<5 endstream endobj 241 0 obj <</Filter[/FlateDecode]/Length 513>>stream +HJCAO(%g9;C.zuo9ū)*Vbkśi*Vbkśi*Vbkśi*Vbk7/&#V\bcJ1`Vܻ>g[+LS4[{=~^xEŭx3M֊7Tlx3M֊7Tlx3Mn&ڱ:{֎}WiN`Қ}pHk/gkK4Z;w*PfqAkZk>s4i샕bjJ15`}RL#샕biJ4`X}R,#샕bhJ14`}R #샕bgJ3`ؙ}R#샕bfJ13`}0샑deH2`$Y}0샑ddH22`$16#샑dcH1`$16#샑db?= 0�Fi endstream endobj 242 0 obj <</Filter[/FlateDecode]/Length 25363>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-F+Zsŵzk=RѼ_2ZcȐ,~~y4|Ykr%S'-5n}݆%^+禎wW3 ~Gg;,.f9으&9{_0|z̾dݦ,ٚ+zflVj4Y9)?~ C6Z(5Cvg$s^DNU$Zwz#Y\moŹUi.WW7swUgȝ"՚Q~dJ+-sĬ04:G0yM]ʺV[v^uЉrvINVث +ݝlFeM +Ӑ+;hq619K>+Nq{"`\8a`> Uvd&yCԸ)lږpN*F04#v0|!ՇTލh:fCHb-L +E~p]xM?IG{6{/ēcpU]o;eq۬t"Z$ T+u(<5{|$&m"i�"}{?T}I5PƉEjl PX~Nݖ-}7Wo6JPFB:Riʴy3dҽAA;Y[;[(yŶ6TLxۯW??ӧ~L+q}?_/?iׯY[ծoׇ/oPlm1&XR=P{�-?^{D5ݩ9rF7ZZ5͎ !sޤY-T;%b"<Yt;)/7,QՄϘ@\}&=׉숩sqd ̭Pv.9r$.+Rj)2waܳntall'ׇ> Ϊ/}!3ΈD) )5xP8b4k};"@9O2�A=Dihy*ާJFY 5 �L@%ShkEtӴ5[.0GFi3&# z*)nADj 2 `4j,cDl@qCC!/h`}!F<bǜH.Ve5ʡЗ6U;!**.$eJٸA/"E?FTI#,ЬV0�_PƮd`?X"|]�Zg'x%?`.aXSYqSCN[edO'>g')9.fS:~RoH�io^|k~v핺zﻄđ !ùُCӬ/UQ^kI#ZJ  W + K%B-ED]6>t'r^e +Ye-arFE5,^ $+(+Vwˬ}ݽt@e 8Ub Z̳j5?1IҔO az6YEo^)TJA>'O'Lƻʙ~"I/iS麱# _@;OlvW<]Pߐ]@?[RAQu:8D랖s375NHzMT)qh òJźj-G_gє`l1.iY9h@ m5*.*pqw%l u2AXPk?$Lz"݆ +[/Nt0iy@Nai@>' ) +_Kף$KZW[+bz6*T%vE)ʮ;ZkW\'xhQƗ:<Ƃ)ES2NEl{],ScQ̽y>y1ɰ@k+z +z"F--ǛzYװ[,(є2!c[IJl~ yUop٭C}o{OcOAzcZj|n$#wij + N2!C<$sdIT>i}pa�gD!mے/:'dX"|)rSU/ 'P.V<Zid;OCn=P{tqᗤ]ީqUER94_;�^+!)hrI1rKc'N5l*6G QC +j(''fuKݗ٥_)K/gq(!"q`v"y\Z>&Ru@lׇм3o5)z1V{4$N |94K!Nh!Etx" +<Q$-:#moU.#)"Xɤ;E줢iʏN*8bY*. :M'fumm v&D)I S3PMZgi- bO<6 GY6',zov89A : E f$ibƕ$eE{ 2M%U;I7)-8׆7 /'ZJ )cט,ơZQ;nH}TimkT*(4eI-'ۙE8ͩ�$f5jd{񖋺^\Ks[ez 5%vϲ=VE,`9+,' -a$�LЃD{u_+N\N;Q&'})DEUez1듋Rϴr6kb3Hձ|rKVU栬Ou_uuXB*SW: +Sڞr}lw ppWaNn3l-LYz_xn_E!\ҁ9' #_#"iV͒وZnDAD| )nמ3QL<(}=c-=7-jDL}g;*g%/ڣQYk|1m^ŴiM䬻g)V^u0}:vK9+nUΝ ˞WC/tU y0)&cP}F_1Y(HHσ-`~ݺ[o پ�ŷߗ3[Qzl@L);}Q^mq\zn$X?] c`:qgBٓ7[醞Zюˎ2ENwan$_{caGvz\˧"  `Uok=Wsq1{!1]K96QسXz\Y R0:y\vri<k6#HǫYbB͋ȩT#v!:{[BlQ1B 3*#IQY|8 2va^<h菕)t cFh*=^~tF%@ THE6dEVe}OG\j?]>P-c㪌۲oh-lS 29Hh<kt VTdI0i'6 /Xi0rT2a|,6AE,[˱o|­kDv dROq< nBb[y/ QPk=;6ee8bsl9L8H֯n1nv~H/Ԃ;/?o&>X*J4eV ~{eԆ5ۣEd$kC^KMi`ps)\ℷA['cQ,?9T*+jYo z3 LDPFxʹ(m{"ڶEDkH^Hs.QFi_I vonOV׫|4EW1|/?>_C)0낀Hj|\}cD[9>~t^'Dz"YӣT~Bf^8`g*b4vy߽E:F;m~ޅ\˯VuZ觍(Jj䪻 T\LԫG!–XcP4OUԀJ~k4̻H2X4ԝO'Kq0@~\am; +( ;vi($>"m Vʠq)Z-P| uP-/&*ْA< R vXa G8͋[l8)IEH߃QW"VB;$vj.;10֦ʐ+>>| 8u%̏x;JkS!;} Q.Hr:Ouן?aj5$yQFkd*Q]%*؜^ |pU>P -q KbN 7"aj']1n[ k xfhsH;羯MZL^eq`RU238t4Qrф,N)M%QM=p_PzھvsWol7T5[YӶtۡ69WWɤEQ5AS?oS$:DlS7IJ˟WےGN'?&EbPJs$spqFJRi~mliellu+FUkTtԘ~N5UQ}HcBy٫[^5ׇo.3 +>GIˢlu7b1/C5e@}IAP^B7fm%MAW_@Wj<X 婚cՈܩboB +#:5VhcP?/,Fa~<k4b8+;} +nc=sb+DuU R. ܬ #cI\EYئ(d1!;5 B摽?ظ҉NmP]IB:f=OΦA`/ ٪1S* U0Wvy$XRL!=^+W+%RA屺M +D JeRug)%U{P#PGȯMHױh"޴0@_ ;?l0`mh3'uh sݔ( "v?eG +Ož_Y=HHc(DIlvUEp=ۊAz1DǏʐVRv%$e`jwibm_Bf9@q<@Vb`MB;Ai­-'iKFp2+Pe23afFln z\WLe'u7-@gx=oF;#3 lmiX35{-^53xx1q-*(f;ݸBUc䶠z{&Ym匑t]Jd OYx$WCq-9љOR.`Q7oo~|xo_v꿵Ͼz|zh>]췗?~ 㻇?}ՇO#W7yכ\~ۇo??~g?=Wxx}x۟]B.Ѯ?ݯg^z}sV+_"w/?~{p5t0fwiC6emFP`i?3d5R(u^|W,gnaK=c Hj55w cFƳ\wI]PEUm] +RseRة>ڒv%? +$�)g 6Z$Ey.=;myOM|zG7z!4ɘ¤ +Lo/Z[UD> $,? &ǂ-ܯOdF0gC&hb_d0Y2|%x�NʲS2-._cqVN0P2fmG pWay3Y!D rݙfjR D%lY]kҡXY)I.܂,�q稛:~=)#Pב(5tMO T_M^uu%u&˧w*TT8&ФW΄D7mGJq7-ɼ PZ-w\čB.bKSͺZJ5�~S_Yp*ETQ˅3kx8h�Pn@.%v +vn<,lHD~,u͑@R/kʊMr̓E>54-*Î? ٻ.8Ts6X3reGWyW.r}56s ZA^Yv�2R!e]ZGdL5?wEo5 8f[-\5)gaO3I/K.Zg[($3V,]jg?(B**tA +W;ʋw%.MǺ;!5߃!,aIt$bz^ * +[y GuP!ZBW"IǦ6ãmke"bn! )FKk8[G5sB@- &R1m|=٣u#eTDD6k<pyM=6obH5Q>(KU5c$B c/pƞQe7-W3۟A<z?$ͻ55C9ڹv|7oRaq8,Sk&itw]V>z'MxH{M@RdC!d ]ܛ\Pi2#Da$[zG [0͒!3 +) 4MV5K,M&E5ZWT藠# 7_t&C>iH킴ykPn\%=1N^3B +:Mǀk0ThJqjYǖ q^ }}QsL1c;N`e/w/>u' Wt.F`n)) \Q~DaوG#%KTlF#¸T%voK؊n)\qُ2__=Ky:]G2_: l _)YʅKl]anfbLSE� Qò h.ȏ[È_\ )/bN$\k2t$E&YJt`<ӂL�!ϖ.cvUMaZg7{RFjm&9D2尨A|4Jr^6"[z6R׎}bF$!l|CVeqZ>+-3*U>\ 0ӻ*ˣ +OfԚ*Fw>O UZSo<Y;svq-{K?Ԁ{"[qBoLza!6@g')f)jǭb +, ݭ$%|#P91'+M`&1[V- j ~sCF.VTzqJ ![Rēmv:Ppw-o@裔h!rtvO8{Qk*b%Q)l*encQU^זr<hQB"j~X߫sn+HJ7W27ݳa1I3ZUi LL@}:[՘b>'%Iv)=Whr؊++>pP|ᤂkIJmwjgE@!hRVHl[ + zBwNRu 2JeFMh@*2z=3F+V-I*!ghsҀ*=\P + +c<k譎xoQ#d0W\K$mW=o+ #I�M@B'p<WU+ :źSigvv^reTL #n$J5>iSO9:{JExEKI#nw (ejyQۮ607PUu!dkT&')ɢJ b~/z�WR*/R>gK<3Ag ^pĀN?_/o޿n?>?ۛǻ5 ]ݼ=?_q}{;m>ܞOϧW7jٗ^%;9V)~g܂{ 3rه�k1h[ɝ8UMbLQ烧](EEr1^ieL(e,Ae M + +j�6l +JH{.״䶇bM4:z&MeIo=Rl'fI9#M+G9YĔ PܩA;R&CAZW*�jqa6\װܘk鮠%ƀ:VgyV)oq8D%VQ;,iT54t)~B=|"+ƅ,?ȌbѮpk 3)]s`$yQԠCgbt`x:dVl6JoIml +B^ݺ<z�Vn4sceͰSjS }N݆ͮ2r@A!՝D"h˭*r|%ر.;/~$/2) '$qӲӢN +6UxD7Q2 i "cFSh *.dJ,XM̢4rEV\H$2yV+x.0#SmB^ƈ@Oʶ$ָm'Kjy'v2V6ij7FǵA.&�JԱTY_@C2HC@ 0rQͮQ 6j6-wj56,%`Jܬwv4:A_�g)Ys d`t,~|Z@2I(lEꫠZNۺ_Y_TT1,y@$s>@ AZaJJ(Li/N_pWg8QEUQ=\sO2 f/jT̚:A(f,T\p^'шX [p4qbK 2)۝/ʹf̩^-VHQ#}i +cRH煠:k8/rjtV]2B}vü|YéjB>.-"C*^dؚ,!CYPUq>%iӡ +~p/^xL8� +wc}zjb{[8>OMy_U_uZe];!l `0jH[S!13LJ�f tR +p%5,-Bz0[ITZn[d3A}QevrwrC68J5| @Jl ,FIqw+ #e+q" +H`Kr@xJ2s @0=<ckpw-NF\bq ty"tf`v :RС J^:Gwm;/Q> N7o<uYN/EuV~jFrgX-X ]spгZδDP.DuvpӅWvȝH98h»r�d + +y ( fjy1rZoN-\(MM\2m- b|z+09SL8ǂ�=${$*HR<xr9gEܕ_Kkl.P<1dIggg&equ#+uTW@c+5sd4+J,03Qx WOX-7!B&KI̸Qq`ygc8 amƨUKp;jra^DXōZ +ݦc0-I^9nŠB^0)!|PXx +\BzPƸDVgq:{  Hz"H֑%.^ 9R:B]1:2 k5ZCW5"һTU + +YÉٓG T�j+s坹b) DK#'X8[96MK[Hh0BPʁ $6 84(8R@7Q^x@ۋv{䁢o=˛oTe{χOxzrLW7oW}ܾn_Nۧwi=x<̲Y)#D,i7 FyxoJ% ZS#46<VwH +B/jnqt[fXH n\:ҧ8o/v/(Q8$f$IWQVj 5ٸV[̜8xT4!�ۍ@%N7cXT oi v(!b&tā290T鰕uYZRMpl+3i0`"P?iyNB$iQx/$ "ԻjSywO#ՃnHvvY[%$*π4!yiu8_PD\:ntE_3o' iRք<r*rj0Lن4ZBŏdꥈ7BG[SAzϸ8lA9 DbR;zBQp +FSC'Ԁ9!'|,-RۈM}!Ѱ/rr->Bd| 5kiaVrӭm(1Ho2zG<t &|r%0pA>WײqIPy+~nZ?:kU]P8`[vCMGS.!`k$uVeʇO +6Ȧ>-yNw:N ސ@z]wvI-Po& vPiݔ=zp<Χ!7"қ) 4u;J)yӾTT.e#_iBfi85 mwp&[ i=+MVT#[},]eSݽ$BO^j< 59WW?׭l!5~3`m΋\~]wJwY>vhFj -󿇕/tfŚRhwdۉ0TLnU9'߲Am_Ed]- nm mb ! Dnz@})[2[h#-.xdO2s FEc{v _ jKq>Ϻpk2vOmWdY}VA9SkDY%^t<&&F -yK/I=+Td 4d3NJb^xI QmkgWjT`c4W1ɵ&>”~b(t]͈N#Ҫ P͚֔(#UD,n$Jk]Z>b Uo-KSh6a;5U0WTt'Q}ldP:ԃ|[ +g$㷜6ɽU̳OGah޽i܏|o!sE<-֝;ڏaN#HD)ŃgR =^K"FÓV%dg8 YP1,ŨHw!T?i4Nvr.K@ QzXU!wd֩˅F%KsF=(3GS^k6:ʢ4@u8nAMЖl\9�fƧ|ˉQil~&'&H`v~$~ɤ:~BkIyHrl>W;WEVSq]?ͳ61Cd旡YkA|\Oq9* +!Z7EI( MR `pOn3 (=@@D|,UZ0wU-ۑ0Pǹ|@x)HpL;l jW_ +WwJđT7ߴl"9y]$YFf-w +Z-56y5-*d`*"50]A#ەo5R@{'Y00 xƢV[I3S}D (V'-%Rȶy*.Tu'2) ~P ygEԭQ`idy5VFs2~p'#|S_]!lpP}Ȭrs-0h2_z:՚i l394*_W<%\U~ UdjY۬ a�9ITp 7%qM:"4,vM9)QodQ'a%;)H/`ĭR1@m׮YTz.RuzI[x'�PMUDA%";ruL[ߌzhV4 1Ev�(;wlKK6&޽t��ʓǩ.$JEw Β p `pb,zyHuǥT3նGet_% . ;+U)r`cE"sz\S{g]g~һoip7AȘ>z{vrϓ. s TQ^eW_y +.@ݲr`8|+{pCVz@c@o9Qσԏr<%�EAoj/^}tg"dy mdJ]I1egoa cdK;߬RsBJas]g'a{<n>PG<1(z+eSe)IuX+@JXq+#2e.^IpR7FfJK4&UEݏ8 Z%? ߍRLZ̽H?zo/k3Vir\֪ Npoʰ{|v�3?,{{ל՛Be{qgW5eI2V"!K*IׇC[T :7?i+Ԑ)V h:)sTaz<.$TPQU-�H 0#<r7tǁhC'0 9 ȕw�掮ȟ$IG2ȃVd�x$ŏ=@!B,F |\T�[Wi*xv 1 e$۲Ԃ; {>{#p p!8]'2n=L;;K |?/-|@ˀ[W֬'zjKal +N&KՖS]Pf@R?7yyHd A&Hy5@CC�MGlE+}䶅Vk:֓ē)$g=E^jNL6v^umCn|mEvj:0grHmG @ 'HC1EJsA6Tg}dDy3}7?]�A;W|] +0Ԣ %a] 2XmgAF!C$6nbɦTKdƜI;/U{|Xg'qjnS~_d:ϑ! E:EvE~y]yEW*W4$"syǓy[K߯űI8l”k j˼FѠbgy1D �6F׼=< t;Yb+I #.zQA{ľD4ӟ#ggpVV +[-ۛrϠdL|mf& ۈ| ̅t *hʾH\Y6J9Yu(ݦ1M+&]+2iS H?jȴ$J*1܇aU3^g|pe$ C)Lea eqxЊv"Zl1IκDWzuoWtKGfPA%Eܚn}{Ӡ +O;j# erSVE=IVF,�@v"{Hʸf̫vQ@s +l]9x#28D޶;9$+YagoWZkW93lּ$58 + >vMdpz9 +t.&c2Mafv#bY.|;g!h�&"Y+I1%1K`?~Ksg+c %Kbv* YM)50gazDSΤqSx9SH& I4.� +(m831Xӄ7:_@X SV񟂳!PRپb+yC)_4 S~ԅR]&%<J<Z=?S,]D_'5Wy4yuW<CafP e+k6+L5):QP;(N(_ +_))\�Lݶ:<C6�R>YO@!t)2n�OO'bV|$9-lҮs0RZcs͜:m9va/; >hkMY?ahy3tVC4L@'wL2Kౄ4u-<"9 B;&FCл&^<5j,'ډzAQ$4$ 0.a˝^}J5kGGT@Mh,`3Ɩ&,B_d̝)PԫFe5--)m�{.4_i :N(/ ;Lyߧ˯rଭP`xiNu;A}]VNl/;5פO3\0ɽ)[z 1=eJL1><uhrM SeM;)>58 +8 6JHeqZΓB]*^ݭ pG&#U fϽIߞ뛲[X,k#m44*^\Y,2a l{t+Y)t̲E;p)z#\PJiW/]LO1b%[MFYMFc%qΑunWRHj i!;ҷ';IIkU GbhtU0>ESl!(پw_A1f\ɖ"Jtg:+n'z# [&,j|bb6+S>ݭuVu 1F]rmUr79oe YJWkU5^8-w^| +Q5}nD3 in-BfA Q+r'˟I*}@GAHQ*8�++C|\6ѭϡHAmjbۜq) PNFZ*Qf'VCz7a<j iDUMV%ښh0`)ȭ 66|@TV%Y%wa{2Drgik\;UQh ?OE;[V'47-ѿe�ح_5_9KwEB dt_׃>>Ve3T$<&=?|DGyN, |=Vt'?Uqc/"ħ�9X-߿3C~)z.h?áUj=B8*WQqq*W%TV˧zhVI"U[>{Ipf eD 0Joj$_r7�ĥdakjdatjr#~ 2ef`xTހ1A2nr,RFj-4 MLs0.g�uL2(ΩNXg f2G-. e}iP(S R4q^}'-z~mΪG0rO(촊+ 췟 #ӴG.t2}w[lc,naZɈL D"B}2[+Oc+t>b⫩I;XzYغ0֪2z/xDV/3zRLD V$/c5-/zDxic�s$Q~C2[v[*ؚVfBO}Y?>a#.}l_l;#5</F5Ba-<lӮ +R,6~}h$x'g=duMZiۛB»HQ;*�"3`&\u' AĨi8Z^Ð+4~Sğ4:-ҥm;SC 8|$-Z`1)d@Gb^D^9*2kOIz3'ӧj]JK|ʷ7fϥu +ɐ[$&;+k`V#Ԫ ٵL oDƷ:"D/Kx^dp�{B#M/ ]e:b3]}y' I(Lsg�1 mZRP +%Z,WSek( _ḭ.}eyR笒: +);Ϯ0NJwg}'u"B +I #dʈ鉌rI#(1 f̫A2[ȅT"D(3zc_vΝw !-%~$B',L`S@ItNqULk|8Je["@tESi�c|L);LJ!;5(U.Efz9.Ap{"lѮYbDVY^~tG:V 'xUϓ\R|bߔ3}: NwS^Bٳ�l>vIEt.wP-|g& Zb|}�Dg`@x%y@W.)`:h▍ZGIpTGE<BVv/K䉽_�964E}Vx�-1"TxTMPSޝUd@h|A@_G^v/C;:LLƸT?#YgiR AL5.೺{ʞ73ܚӮRMT hRygh ag,xglM||BL]=Hu8EcNt!TKs9UJ` 2;APƢAIDP�^9V%F ?~P.@4 Ha7MGo2hLc:zL6cq= -n<iA\6X/p`nnCp&nЩ@UY2�^g`{ HX'StܠA#Ȳ:iFAU\ڂ$ ?qc @`<#7y^Sgt8n D0 t6BDfS̼<Hly\ )=D1!LCccC":"d*#=1%j?+0R@ɠjq]!n_')(AXcvx2w=p!޳SjZ*vc_ +V 7Uf`zԓHYzӎVMEu9cɪ$d5sP }KaP7(Ȉ#WNn%cpR0*Mȃʪ5чF HA!PH(E\hx$' º٣de`MbC3,8lyH$|DÝٸu �DQi <@FtZLIgTndF"J-JڌBx_ͣS�zBu +ë~7/~}uρo߿߾Owm~/o}xӇ~swoݾ_zOny/?kapq! )c&y X[4mt+Ph`969$#c-l6le?H!EPp.�h'Ahp^DxG# Fa8 JV,ENeڑ#X * ˁA`Ӓm )J k4TԢ+ݳG؈ qg1|n Fwa"5 +GY I{@d'ܖg~b*{ q^r9+m7%!#s"a!j)<6"Ғ-T$jcb?�D-a}֑@tރ6=.4-)B + 4zd?*o&/ FP`S}ȳ<Ґ R|o}Xb=OQesh!s*dX,[Z^@18]ό<PRcV=Iv)tDƩ7#lm$<TZX1Ed 0Mr\HLk>6z9b&xʌkײoܛw<ۡb +(,:4&Ts5+rgO&7z^OJ*=*:fI ߽ 3ԞnCc`ͷCL E/DCᕩ\ =ᾦ;a BJ C[iڢ +G3 +(zDB@B!t;_o9 ߓj"$~fI-$ gKMn7 3v�:15S~JqHR*CS�ҍ#Ek }ȓ7ߧ<gqSt j +΂l>0|‚9ͯJ",VRbN `+vU3!Ihfi_bCZB_RD6Sj'1b&W('x%$sn:xG%"vXn->\v@!3q.{#;XCIa^^_M6GxD{3ק:jgNtw= a,#RƳ`wA.00J^.3s˧ScW{l / *H.21{$Ϋ| I�xa^|1IsZz Y5"uVQ0}C_SSULKD.ҋȂ.G\uGXw"QU!RϡmR$.qlqxce <"-?jΞ ޳c41KƨpacŪ;[0#XF[aEdr}J=vҳwiܒH|W(TJ~Y6ynDWܗVQe|J$$wNl[c壸5#꜓ƅS+[5q;cJ3^{+Z9P(x/؝-�ׂFo1{'e䈓G*c89)�v[|FJ)1s(G7a2G˭瓰LQ%� +9�g7ML�R+ vտ MQ+셡\O"6Iw䭇6!6>A2!�eTT)FCO҄]Og">ˢ8e7-V$ E{. C f v?6r<rx,#~e N] +7ipo.  T#ɔesX�cwt7;9AՃrGsQ^�@%g-^ +ME`^iS\\M0Fl�Cs&d+U>6 6zMJqsC0WWzsi ÿ]|4visW Ky٩K 9nq_,c$6SbXУ?Li;F`!7moT;\{G + o3)BW!Rߝִً%u+x.=j*+y&9_]6W `e}Ϝzy9\;[|g�=28t[qkB|slޭ_ x{;S[K߅%.m%p&mlΡϽTrqN,'{ѵ@8DPK忠K#\JQg @7Yɛ]UL"]ubmN~TO%.j~5kT. m3dyCYL{bGV/ǽ +! +ctŷ?R6)b%OyȊB}!+Buܦ52, ]rk(E.}@86><5BFmo':9)/<YKn\X:FHx +xؑ;Jvh\ZӺsVȫϞ"I"R1- )dUA?Z5q h%pkQyelo=$HȀ.ܣye6@Ge츝3ۊt�U'U f։,E)VČ@ x +Dj~E/fKl4 Ql){+<c3C{T +*WF`t0+ +ӓth;Ch[qRJYnJuq7B<ʏ_&o$G:5iCvIc5Hw'|^>~ !8WPf.ׅ"pr^tTKEHp \@RGC>,}lu=Fa=1;ƃCW+aX0Z# _5lW |ʟҨ-ͤ+\'<!\Pk9*͗t)@, YQTiOMx +,MsPHZc獉?26*n9\yH5޾;jo 7A ]IyM*Ǩo02*vPd˿/:+ +?AaTQ^-HQJHU"1L"_yvN:+OW:(9-,伬I8QMK)Hj#n΅qÝil;wgWͩgsR#[5HarXetZAz]hv'63RK _IG'ѡ~HJwnc6+txRw6H 6H'9f΋Q4éV̢ +(6gg*SOZ8!М7@)[]/MS0+T-t2nU:Y VF4 Mқǧ@Av\hk'iŕ hqHȴ_ʔ'Ԗ\Vҏ5ePjH)"PL ; i6Ux!>MNJ{.b"YFChҬD*eqGrt~E; ZX6a=|w>/8jMƊ>H(K!uX1 %،me]^F{O5{Wc,FCH~Ilq4pnהVukSҥTyAGJDJ\VGRޫT_ "ud3O[l5!XD3e7v c e"Z5NAu$X&ӳ}tGiv~6i#'2ЌSR|T#%JeT + +l01@pqI�>NSy5-uecQt)qR긃/ZkB ٶM)I]C�Y  T0/1x.Ifhu+FV$l +T)q$ЛD#("=@\Qbu'GkQ#2sk0 C:"jث|IDפrvVZX=\)Z1z<C4 +!=& >Q=OUauҲzu+v :�MmX7ǰ%;J73fb]J W#M Y=W|5=6FtId @cVWP 7Ehʰ6dug +p`5Nӊڈo_eG1YݗZFnKREhA$3>ۑQӼNFC+'~%� +pޱl6DF mn3Й, fS3ڼў̣B,d#Y#U`V{ +(s8+Ф̫"22$ee[QIkT ȑvN8P"\՚ A+*tcTbmjE1^4t f9Hmle"U{9jWPS$2aܯ{<(1ST5<[hz7ƊyH8ӈ¯>\=i=B^'̖H4a\ +2dP>Xg}}s ܠȚMY4vf|5v,uqTu!חS_LMԣq?ygn'ځCExU#l]U(c"F]g?w9wNQol?Ͽ!1_O>ӟ }HkԿ~|zGO~ryo/ǧ?_>r7on8ܟ_|uW/߾g\mOO틫U|~߿'<7>_]pl4%r!"~!^IWdg~ys}yL}~wo׼?$}xn<uG# TwDNٷ׷WB??N8ڲy +`x uY2JGv M+=4"8)J`F%܅MI9cm{:,̶d {#bH$!${��U)JxmT^MHaѶ@!sså,.ߑ8`'ܣ/]YX=6Ӂ,ڤe!%T)"p 973$eA-a=&,M11HZfjylˑ]k[9LT֏0Pfxu@E}pc51,u9 t>Gg^Sk|�P[{P_ftNʚf,ū9r[ .;G +u5P}Hխ҄wwIzO6 9K|x_A:ba2!\zX #Y-x?>5oKgԑI+4~M"N +-u;j1z"]dJ"SD\G9ٴ^hI*b˜c©a:SW{g{.Qz.XY%<7AJ]o'|"G E H%&ӛe +7Ixy79m@EJ=0hȠ:dqXgp.rN2]<%Ь`ZqWl9ud`2WY+M$(֜fmH"�!N2XIT0Vg`M쑐t1%MC#Bfs<Mrk2(t]p^ +X%H&]5AֿU;a "ƒ#ebS$+PflD!kTؾHҫ`Tvx,z<hkxii8wX$c( + E,R6PJsp4dT 6r3P>8yqr9f:з#KJSDL)bjc[ Δ`~2ZzfOAj%'ii^Ņ@V洣j,,xcYTcukz[Mwv1 Ve(S+3X=;]xӒ3*~KmMEDoRč +P\KB:){M;F |�5%]+7,젼']U;au{!`IZҕ 8'0�x(O\J`2Z90Pbro=\8!\)1hPĂy)^*)-цvFϩ7*夥wNE0:DzRΑAOxkJB&=C{յ4N7y/9D&. S>f Ŀ~ySR||o�l,GxԯNf6mq ζH#1[x;?/ϳfoy3G)U[Jy.y_E_ĴI5!X4n,mWPh1$x՗a^|VR]O@ +X=WORt_RnQ$.bnWˡJS(HУAj[@k;U +; ӎ�x endstream endobj 243 0 obj <</Filter[/FlateDecode]/Length 886>>stream +HB0 @ekV:nA,4ʊm:A0݇$lCP6L!IHނC4=M"9H +vR!٨ +}a_!DuDO,l~h"ߨAlA)Ӥ>p^At`*I3}p<^`H*Ҏy ev KA" @p>p$g9/ٍ ApV#>Rx$g1b/ً Bq">X($g)/ ى ÑyKÁr:R{ۼZk;["K]t99$<u%6/>P=ݑtPS sY H-,3ď,8)D'kfCy"N&)uh`.ˊje)҂Zzf押^9Ы4S6gZzf +x*@L鼑N 荚)CԀީ9L譚)dRzfJh/=:Ы5SD/]3e�Q +zf +"b+6SJ? A޲bI ͔#zfՃB( +'{za蝛 +ڠKQ/+~BUnW>DZGʓh&]:.d/x.QiE~ٷ۔$1ru1S>fEr˲c݇ܦhyLw'#ǚ>RC,={eƆWzy9a =i\q)82,NnSȲjFx3"罚Iq&u6:ģ L{1`WNv&K\`ޔCMS� endstream endobj 244 0 obj <</Filter[/FlateDecode]/Length 586>>stream +HAjQ&_#4>ק +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй_3Sɱæƫ F?`?wK[>\) xPfHOpv'=XTOϤ +Xa?r?+:l@:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=շ��}s endstream endobj 245 0 obj <</Filter[/FlateDecode]/Length 592>>stream +HJAQ#$+h!UgM6Kbn7,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t>/ +Z˥`QA?v,*h{ۙz?uw׿߆>.|? +ֿ'rC8p+7U<M!8c}F?}F`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:#SٹW�x endstream endobj 246 0 obj <</Filter[/FlateDecode]/Length 635>>stream +HAJQQ/ڎXHCH )>GOxƩZjÖ2S+_ҫoSɱTMeJ:lwƁו[ԉ}wƅ! + C߇(l+#_k [θKeA*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йoSѵԆ-eJ:l+וw#}/SɱTMe^6hTb$Bqy<_I}wƅבCC+oRy*9KٹT `BS:=йT=F*t1z0Usу +{LUc`B 0�ty endstream endobj 247 0 obj <</Filter[/FlateDecode]/Length 725>>stream +Hn@DQ'+91$ +Ū{bGC1X> u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]2:0E^F(t{u/Set`B׽LQ躗с) +]̧{9)a pb:IۀsDz~gOx�`όy?C�!W! ?kr+ͨeX_IoF-?~ C�g=Gm{MM[~H$ 5=b϶5o_x_j�gߗm6.e:}i5J7h5az]Sw Sre8;kv_c ~~<~21~�1?unͷS`~?Z7pjx>!5u?w.eۏ}5ns/>]|`5^>w!ڲӑ+^gw +Fz^w>-t\ɮ0m:7scp]/}]\fk:4}͒$I$I$I$I$I$Iҝ} 0�'s endstream endobj 248 0 obj <</Filter[/FlateDecode]/Length 358>>stream +HQk1�= rЂjۭ]YbH9ng=Nn> A�����������������f7yyCS*ɼnUTfP/w!jj b^_?oKm⳶TE7>$yQ$|]^^%{~Nte4l^DɲVYEB:fv.}㮝'h2N>i]㟮݆QBvVi(=,da2O��������������������������������������������?)�?Vr endstream endobj 249 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 250 0 obj <</Filter[/FlateDecode]/Length 222>>stream +HνJBa�t &9;49BDPDumN^H=ȁl�����������������������������������������������������G0ϒs=z^\��qx:_uV;��8ߟi���vsz_NMR  �H!U endstream endobj 251 0 obj <</Filter[/FlateDecode]/Length 631>>stream +HKKQOęP Ix!n8I4i5Ab(ʤJQ1-KX'Ԡ&l!P8|<"gˆ kV�_͎/ڱ3+2ק7o,��/<8;5!#C-~��]cnm \l +֬-��|}6= 66e_;*JݫNv7du[DDDD$g sZy1l]|GRB/[DDDD0A^ -ܾ͋7?:!ύu[$L>~W7:0 ~=k NN\be{C?mpgR4s8 Kyztbo=1zXge֍jO=Aib.uwL|13;9cjDWtOӠS4?H~NY8 ?5NTtom+Xfjua)u6 �o5b�ͼFL3�@׈~�71��f^#&� kD?�yg�|3 �oaN#�ȵd endstream endobj 252 0 obj <</Filter[/FlateDecode]/Length 409>>stream +H1Kqq1hkSCzNҞCzݠN"JPYD zh4qȉ<S/7~˞6x;>g�ly=�{H=H} +��wDRtW[��MI磝Է��p bύHUs�� bχۛv>K}��7")\>mN}��M{+<0_J}��4yvb7�pM=�䭾6F� o6׈B��M��ț �7A$� oH�@ꏯsʓg�pEIX_Z}ޞ2��johϞ_~}s�p{ e +u!�5 endstream endobj 253 0 obj <</Filter[/FlateDecode]/Length 12657>>stream +HWn\ }}7r HkP$5UC{Frqx+]=I_7O[Ttqo.>ZK,+d,斶RiK:tߊ/2pv۠\Fb/UͽXri< δm&qSCRuJm%KBo"8k{m@бDi +zn֥&EGܭH .+Z| I$(e.ma.=B2:LBXFϝ:xl^2utɆЙ&e !u# vd>kB眅y:Az/Qs8+Rj*3.=n5%{.TY(bj-tf'(N7up+kxI +R&o4PʋiWDZĠ +{#֍Jh nLu`.d20P/Zs$@+#S ~C`QV()J_PO<J)#2V8!ٽRe�ؐ)X6@xF1O(&2} w$L\�EUX q%Ɗ)'J4 ʶ?,jP�zC ׊r$&&0D 44j�>!ZPm� +N[@k"M a +vl!�0= Bi j^?Pxp#q1e) k#f:et=2+\,ȥ"G"ģW67ljx9BNX=%=N +q3!vu8�yP1Ʀu&0}LB* /DTuܢ)␰@`GK TMn*2D9s;a+78[�< 9-(! �DwAsz) Mֲ.0^>S w0 &ujD ˁ P26߉̽<LnEI7Jw qt +.\cZ"Z85Gx+s4"e�%D,L@R,!lx:l9$B\r✊$U8X28W45wj:iJ�I6fp֐ &ԑ6$ym +Ԋ2 +zAx(Hp)1^tp94b0JH aϙ�A*3FS0#7W*L* eW v,Fo@Nx0rt1%t`o'Hf1P�7f#E2ХT`b}8B'(e -֕.Cm$9SH5h7zFbC&ӹllX[Y+#VaQSֲ#@8bjb:qmh02|[ɨs6Ƹ4p'*鮓bxquuCy) +@r)q7<enXW $Vw$xm ` 㱢 9,KQxȧׅЕL5 LJrY 6 "ӔXkdGKzj. L�mY8јTR"{GL72p6P6�kOnUd2ت3[,Ͳ"雹 bܒ[<^:Ip֙F,w**0,#6q3*U#! +oco TD C.{ 8"m~A||ŷɳo%ӛ7ݿNޞ8'vPvr~{Ո|z/on.\|yͻy  c{pF"#vb3˓ۋߠqdp8=}zryq7g9 ̑<McS~w}%B^%O^\\n/˓_ҏO6&gͻgoI=J^~:�Db^l>zܟߓV䧧$DN!r}q# "a[7\0ye5;<>na{;ckq5 W[rPz(k27l{rcqVu;mo=|xܠӠܗkoF-}BeRGO̾u8yx>80zò/| 3 +!)=EW)r9]U-, +=Dbknޘl#gN3w)ỺB`PP)ui ۻ8V +K%D6E͝hr p[RVc؆;GkIlw+q^SAEUGlYY fr]Cݫg +~?ټ�*;j9ԁ8Ho-!0w</JsW5{3e _۩nP|r[ 2Elg;Iɤm)8FN%/+$"wm7$+̐i.NKp7G bt}1O d @)YV;)AKDA'[~ +;.5E B3A* {/~Wb%n8DFmD!j@ %HƛmDf`n=RQŏ֜iGU2H+[yۊw4P?-C .~״QֵPu]̔kmKoFm}}xfG$esp3yW++zKj{Pbɞa|.wG{m ?w{ Ƃ!|V+<H~_??¯VAw6�WLm ufE +Z|pi5bȑqAټTwc&91mSfsL0!~ >#P  {CgCm>�a=5aD*EPFb6(HA2S_78ȕj-ڐ9.QsgEP\@(UF񤊴#Wcah|Ǝ͕"S2sX|v'olY!dޙ}Xhļ7Vnh fI(Z1~w2 un *hk<Q}"w|d=Qp4v-6;2O6L9\%$j/BtI(;Oqڣ>5 j]] vI՞f2*s8$_POW+h\܂r{X-wv)X: 䓾 T~|g{[zY0oPpҼ$C~憒n0. Z٣ |&Ø&Cprv +Vd}h'GE/ְ&?ALHp@CZ EگH3=E 4k*9P}YtNŏbѠSeN,?}s@U0pK{@4AӵˁPFu+ f{,MX%]K_T9`I\Xڛoʹ>QIݴCPZWm'w^p9@- (cngd4p|(|8zHib:)N&|*q]rf9l0UOm|~nBaKGDaީ -Z[,򁮠0G'V +> sIr9mY&w!#'J"?f&˺S@<N(U8kИЭIzց6dDB}~{yO(!)?@7 q}=v#l*br.;7DmHgDSMw5i"^̱؂&Cj.5x~ +'^?}+G /YJ#4ø!g˂T|e"vPe.pB\6(mYRkKd[*ֶͣ�OZ¾ +ӭ=ԁ wLdۥFJpͪb]Q+)F۸Zw=:u#3B�'yH8 +-7l-*: m *`ZU?uFN !Pu]>x|xbC"Q̥&dE�Zo.h*#uɣ�w7ඍȚxsrjmamKS<: [zA'3D lZ!!$ 6ӭ Z|(hJm56jGlkضh#w%`-e|˚ݶr6)P#f,ka!JfmfXF4:Ttb -)EmEкNwPZR`Ƶ2Rj2s;UqpMzDuV4yfh3I˺wJt`:Wz8dS/g:l({w +maP9@cdϲz@ncN_BurKm>m`)WB}T1Y>OUƈ/V"`׬nޟàDEp.GCj@.^yȧ]50+^15&34h  P- \.y 6^?@]!50n Wƌ>+k/EC+F@W^# +'G Nr,jkUhy@!Ĩ\U|UC3n[<^~uN]sRgIr3L{|k:rڬA ba? +I *5Ac"ͽwu}r!f+T PVm(21Ǹ҅.(q5NN;(sTЧ3҆@]ZJs+恮JTO}j": .dgW:'"ȧHU %9_&}F=v+Q*> m( +])n' +23 "39>`/W(Jɘ޹ ˢAu9 VWɊ]7[&FRiB!`l'6f 4<PzN9^F^:q6#Xf>6c-՗{m8\Lb:Y/1Jopq $ Lpx]ENIC~_z>?ɿ~|^G/x%{+~}yBlX ֐.q!s/B"CP9lͺܷ rBihR,fN|p2);7U=s3}C"6AV^0dM,BXMZ!XmC +1d`;O {4LꚄx p%CKEvH[ c:;u>P Yzurg+bCp.W!꧔4`7Śku}k2h huCU{gJMM<&Ir55F* 7o`NB̘=&�̥{"聯!X+5Jooխzyn5ϊjHY5!Tf7Z(00K[<hGi![ҭ0T&2)( |V+2RSxͻZ~8%y.؝(:`]F:ڱVc]k^19 +hgpBhrod=-l:-t t@ٸCf=<D(q Y|pMh8Lk^Q*P5;r?HBRgT'Qʆt\.!_U2PYb S^*J, K@chF . &rrR7.Pwms +ϙY'66uP4e +&V6ڡ(@7~9.d[Gljਹ\ />jXGjҴ4M= 2椌iZk&躕KQN6Ԋ nWjEË +' vU8ٯ +Nڟ2q :GVz}T=U:sݐ;%P W#4;ht2jkG`aS)@ɨU<{y ʵ "ݻ.JqWX^(kKɆ65"14;@)e\'\ANJ^+zTT+G!j^1,k#">7r;qYW(F@b:ǔ2ˎ馓/?҃?H9$WO$e_tA 2?#?᯿?~o_?K/tN߽EcYG6akHP*:4]E4Trζ찑6&ul^W YgjjnKiZ2Cj`m3 : mKANMHv٧rŐbqUг'4$ASFkFu\霌L5ɀ\EU*hj&'c$խJftu& hTdu"pV]NSk2)ku+Z5K Rdeme9M +zr5iTgؕ]Y1KK7 #3 bj u N{@U-IWs/!&D NV2MoHVsn!T! ⾖SV=${ސ'~:  ; 3240!,2O$ we ]rZV i:v PZU[W&=-U+ݙ<>J̺5AD7&% +!+IXW6LVԯ}a̭? 0=TzXvڵ{.j\zufz>!M79l/ˆްvXXρɛSѻ_5k�Dr7ӳ\J!y1Mb]oĵA�(f3\e,|\NRSݐ)Ϛ%y6ob(d`LaAmȼfΤK9ٖĈ5 }91N/A2)1J6: Ye/:6& NK<F#d>N5 SL/\7+pUݚtʖ2(,gϠ̞S[]W-jNִ 놂۠'~R'hG-H*+'jώYa7npq]l$W֧gP^[r mP)HL; m-Jwd ;LJc+yL3^Pk* ךzeّCEsg˧O"3;wm/';cJc/;/2DWMЪtEʖHղߥjɜ{+~}+UA`> 1KRig "rA3R9ձc N 8(K\7T_`m +NqƢ`e[ ZElU^m,Z(찮Bc?dˆ׊K4Y0;{*ZkKdLlk>Y0g Ұ1.]Y-.ԗ14&,-H\:2 ݸN\ +i]f +)NKR!aa;@Z)�r-i3E5)k`|FӲ8e ,}Ckݐh CHдDռBc4եvt$y_]G$^%N +g@\&Jܐ'j:IͪMK<|T'24j~Vu_pD}i?AFQC@U#U2u{mk#¿m H* ts<3#-*H# PʮoQ0bU܋rՔHg } H*[YE[i|"Q +u!$h9pY%v&_ +Q~ PQEAa=\=u DzN#}ew.G�qRu�/I.X6\n>HEխtGmU5 ]'Zkʼnm*rd <QPmʴNchXw{ȃGlǩk~O)qfu@'\W9@>e^;_C+RĈTY,cJR&%-* 'ulϳHLV BT{/EUyʢ r K=1h*!Ye ^D/I% +kuJ4ZgS"v�LiPKj*!M@Je(R1sY+-Fn0`\WES+" }u^^Oqć w}u +G*�]*>e +-Tj{9UD̸m! 1 Ij8-,WJyq_8%_̘@wJѢkR +X*֮z<*rşb Y"dD݅DJ)"*U脈cŜQH-;ʐvż@~ c_Kyjc1 +^SJRnCM[,&ԥ&0S'cm@nUhHZ5 /cn-86 PUJa 1eX-rx۳t +)H5U|21ą&\fz@&1DS} +4d50zr9; Dg6xdmtH3P #�JTU�,%NWrq �YHfCmX3JJEċUln2H3)W +%n; }dp慜#[Bhi\E'*i$nEW9U"Xr\ye;9@g#$Lo u-D$bbAjHAIIB-�8 >h#TbTX8hQL3./Fr;1pccc<\2 J=!R IScJ=֭FZ=^P6: ɡV"7& !cP*5q{D2iH<AlWa`FH ZB%eH&ԕljnoX(<faֵn/woW7xxvbN:宵i=Aw=n/4k] *#O1"6]G=#M02`h5;o' +]>.oT;_Š)zۙi(b\u&&#*%Ti%Yobc@x pZz4;xe;֔ʄ~`P9wn-]/5Nt<sc7)aCBh[" X ^Uۡ 5tژ ~ +_ϳ v `&C1l�\ǗMH`{5ev0ZANc]On7D .iv@|-hӫ1M0TxbD W?<] +N9$с4�>-`5ާF�aB{k]Ҡ:�?xK16kNdm7e)HPGҳ(Rę�Y9 [RGM4E7Ixj#U2P(^ζn!guk*|B9b="$c58_OY{yΓT^r5Ƌ/ IGR/6{ 1ص`r<QzebVyG_,vR- OI1P0mClӣVKX;d 0Vt[eWrnmZ)D@ɐbL؍ AX6S]u^.ڳPcv>9odجm<Დ:1F=$ޘBocP]rMخsXVK?'$ށFz\\ha:Z+Md/O 1 (-d5?CL?9;`XgySkW~[Xf^8N[Κ::6Xk)F'Zԟ._qrџryQTvt,�Ӹ5R :.(Ks<X)OSa̴y,'^ԟa;:,%6;~+AK >^n>Zgud#Œ?3$mŏ93ṅv4,T̘\2mv +L%ԶLGl +LrON_m>-`~Fʪ$(?Ӝ$TVo?t z8T5%%FN?tW wzE~JbC߇a"q] ;/QBa 8.^r,arƧ~nusիo|41e"fqq EE3ˎX8Tߗ0k)GIsDs:؀$GtrDm+~t3jJkW?9|~=~{;_7vp, ~Zv?9}rwGj>y0ؚBrx'X:TW͛oW}�NNO̫on.>\ݷ߱|͋=|O䇷M7/?yn{zxwa{~~݆/>~a L^%ٶvYmbx؅I;dr$r6?հ_X~`%.9M}c\A +(?j/b<(L݀F?| |Ur}vKO_!:x`țdHo,}UpMt"*|'*NFy@R2dǙRlF$puBCwS,c.Y σ˳6U +HSQBCj SshbjZʴbc冣g)U$ N _j<ȬyF < P,X&BR&xd"| !T(s Wm͚EF`X_n#-x&M0UGPGy=-lR*g,�Gk 8(u84@'c|锜滿/ z{Hy&/@&R;7O <a?>\gOC|Z ⅭOa {| '1=G'(]+!9:텎KRUٍ~A)/4tnuqMgCH/:i.oQn9+73?IQ"2wI'4~/bcOϿ 狯A�b[~E:(r'V18xΟrRx' e:CI>ϲ׷|01S#vuuXEa)\+5z`ǧl<іl'ngڍt?¯!tUŽ!p +E +w@K + orEM7�,2j<|Gv2j:eŤE:E:ZdkO%_7bϞ+ˊ]5F$BU#ض�6BbsǜS\9GKrD=z<ÐzH'z[P*�6p96S}:%I[sIT5QS+6mlTrr r9׸cUM(ZgpMJT 856[K``SJ1jUM:K`;ƺީ5ZKX3X2RYW9-4՘qj#sUB2O)P!ڂEm(2"PCѸfU,"UUO.JB%96гrZǔ3B=Tc w"lR[sIt g%,2nF5sߘe9g~Rw zHvǐz[9)Tui6T j ZZbRTUy%( +yzWy\d9yu1i.Ȯ1Ø.v!K2`k lET/-mIIVj8kȵk͹f,/aM`ZQšuXSF\C5\ۂk9 9k!Ԃ!]- (5 U1rFQSdR،\kk֜kҩkʦɩ\S x2&r-9zXc1fkԄkLG=B9 E5qEQLmبY45ȵ'�T" endstream endobj 254 0 obj <</Filter[/FlateDecode]/Length 471>>stream +HױKqAC^Km9$&&-*H +-JEbTI)ibmAߑ.G//wpgx!�@zwJ yw>O�@AJ/; �AJǣ-_W3 �*ԳυְW^?|2)��iw/ +M�Y)��q~^#�@ܶgkB��AJ-aG5qNw~5r/136qA9C9#9?C9C9α8F��{g�H}�{g�H}�{x19ydW, �7ypm~q��^#JsO7?~?��˽Fn+?� kn{wϟT��#�$" endstream endobj 255 0 obj <</Filter[/FlateDecode]/Length 727>>stream +HKqG 3(2VvChQq)!^0Ɉi1*T\۞=n{+KQw|3mﳧ <goIxQ魖vW,εh7#G~ ��`m`Uzs,4���*0bf\,/+}���(m`E uK[оPzr;Ț~]plzh*2 ��KmܓeH47;bu}}Z==?P��w۷jXSrv"tE:V߰=? ��k?P*ңތ{nRZs��`k\Şjs'��VZ؅?���O sȃO/���g6vaǒ~D��BNvaGd:Ւ+��@H]ycMn#��d"4]3;o^u=���&!0=9/���7%C)ej., ���yJ4E.QX=���fvaH~^FX���X7P s({*E��;va]7HY-9>=���r{vapFʲ蹀b~ +0�l endstream endobj 256 0 obj <</Filter[/FlateDecode]/Length 604>>stream +H׽KUa�S +K9CCEbCѢf544Z-Vxv lQZ D"m{s>x7<& �l]Vݶ@)wsc\9 R]��2Eq~VKckSi��eyAqwCo�odEA,ǺlV^* ] �$Xybr<>6��?EHO<6��d>KbQ?Ύܞin =�fOA,jG`wεkC�(yADjǺlV�Pto #?Sg҉�]_Mz1P:>C�(U+WR? 7v�PX6lD^8]ۻ9F�ٴMz=ʋ#7Bo�({R?34LZz#�@QujDQwg�CFo�Nc4־]-N�"9yj &cmO{2M.dOC�(.ĤQGӕҧ;b#�wZ endstream endobj 257 0 obj <</Filter[/FlateDecode]/Length 1229>>stream +HLu/?R'4S@%$\Zl6m+֔$?*[ajwxCNrieM!WXm=Éܥ_{˜srhQgZsZ<0w/=S=o5{[Z ��`D[GГcQ/ONzU���1)@@OzI+t?/YY0V]��fφuSIo1x,Q[_k+��јnM@Ozuv,&ֻ��uy$\2m(��hI8U^zӴ^��P}I8T}pU��$PWzڼM}��$UJ@OSmu#]z_���#YГp#Q6٣z_���#[]$X`ʏSϽ W��0~٣ܦ?Ǹw*Z;Y��="PptB��QN5x6TQxJ*5]׏ǭesÖMj] ��5Z +f*lTS\hqal)e|B?> +z訨>1<3)1~h*��i7MwwAxꅛm[H#cGPl}䍗[mCRc=3+2o<{c^ވY 3cG��w˭O>C`;d MEO#t;%yn4+-1/{zaP{8:O!Ztؒc;|w[լjS`Z]X��&9O(]w==?]\;V٢^^F0z8zrAy=,!9B\JgpĮ_:!Vnz*W-[8��З?0|nfTҬQ=?ZNzzzW(c:!Y 5!ϾÆl;|!D0W/̊'u.-nT2/gGٝ��n}.q"[;i|j-:ߡkC:cZ+U[fڞ;$nqfX_u.x{GiWۀ\](9sŰq �//3 endstream endobj 258 0 obj <</Filter[/FlateDecode]/Length 2412>>stream +HiTSg'XPp".UdV[w;D +(PZP- Fd C I!L@[bGi>NTTT9op{@!лr j*Θt9Y(gH2iߒϮ{en K誩I�4¸D0Ր6FH(j7tt\6Ɠ+'<7roE�/gi#B!:N %c@UwPSfώd7|qAy:<? sp.ۥs dMDzH}?`y6 HQ⫧nh-�nZ4ZTS(N/9K]B!DAvˑ\:##CCRwȲ.;ڽ551gF[۹3H !ϕLP%NVzх#z$Io] 7yݣ^ Plh::Qnqs)I3ړ˜?i2!)FBSQRezѫh^S)>%d"W!c˪ÍZ"5.;N~#v4zLm[oZ2m%o-S+']->GZFz[E ,dԄ=1Q˒~vN3gXk0vB!GEZ(}/E1Q+ܜ³i?c=6͑Wi1|n.XPlɸUƑRLJf1ўd$e�?u? +yx|?*=5ͯ'Bj%+OwLRS$JJE s0Y%|0e:G!X} ld ~RVںG♶.O.&=[;y,*([8Mⱈ040h|I#K5#N=\PJt/t0k8ԡj7J#r(էZ&V& +^32ڌ B]M^="T?Oia"!TQE?~~>MIe׺w32z|s'LLz'9 +�~MUȼRJzQ/yܠMM-hB>փt{Z,q#/+#|=^]X1O-Ϻ΅uJRPٓݿGV�`$aW_9#yIEg͑{]5f2BVɎ_ /#pr҂IyP4cP[;t:21e*9SCݾ&c@@M<(rX廮[Pٚ /Wx0bA {B0Nd-WKw)OEI5hoϴfJѿc.��4LT +_xK$WII!vzg-vC I!BBa۶3+v!/zLIQGt'IwP8„{JJٚpqI/ɾԄ}zy\9wSQD!Pfb@G;Hd� ܇^p8p3љM7,DhŧZ&:v~;oOs!{wJC*<8?3H"~ wl'{9ɭ�2~/֯I͝DWpps7v#B=Σ}| A\A~ރ=qIwwBV.t}D&K?|܂F!ǂ}|;=|,/~zxO܌x<]){3Eb;oѬ*OCj27$I1y{ F8#3?>|k6 };7ޓ1. +Wā*'(e2GҌ]çt7B./&0|_<RG`@Ǜt*)sF}܍3+L=CfJ-K~d0t:B.()4dMk Ab|ޘ}C_2�TlddTkYVorԔG!E83TTvA?qq\A;F�)WqV־W2[/�!P'&:.7Ȟ ^_;AR $D#Ť{t(Vgy[R*#P?w>wB/�A4 endstream endobj 259 0 obj <</Filter[/FlateDecode]/Length 1553>>stream +H[Pe?B%Qtli +4mDTa"sh!08qZXvww]DEe]Қk:\8<3ߋ}|` ǶK %ݗ�=bW6MB5jM z,1lO%}je8ߠx��pZЍ�9ACЪY(xu1מfT̺웬ӗ2, +}&��8JrMJE5jk>,7o\n -&YþB9;1`�R]^zX-?@N#;WQf6;J M+g<=hݶY="%'9y9A��0\֟G?FA +]8 +gA4MѵlOgl iTw9t<ާ��F +TV=�9AΦ9Ī5"W9[d-C-"~6+8 Y�)}E}EkD?FoVSUW7,&P`[U{U+ RnxLJ�a3NXenF*џf I߮Z'ׇvnk }vx[8~$joB��yU?a 3g%a_oVL3o"մtݦl&]lj}_,\:w��鴤ȭ*D?85HZ*lfC_ooULk'h _nQ^f{Nݵ=)y ��xp-R�9AwHc7F?:OlQ28&_?uCH(+��<$t '{!5Z8SlEtO|fv}��/g$/.ij 6I쿚]^*`VOD/o' +�`L;#z߼�9Af*p4D='4J~Ithr׬|x+�1v독?@N?5H~oQll#ߪܶb7&j$Xl�pV䅠?@Np,Bl>oP S 6G`v{q֤Pu`P}��d$%jz rpGO {D4p.rIo׵vMb_eɷz>i��b;凖?@NiX-ۜ Ҿm1DŞmɟL샯l ]E^O�SyW-Z�9AG"\toM {*":3t)b-[IvW&臘hqVϷWi&>{��Om{Ɂ9koH2YvธaSD`ۢmVCM2%.kiafRle�^ 'BgH iD0�v2 endstream endobj 260 0 obj <</Filter[/FlateDecode]/Length 3511>>stream +H{8?Lfk!ڲ颛"=)kH + B$D130iٕlJ=]N7vyv5}^zy~߯�%(:,p/}2<_.;1|NClzo還Tc#fmVK0;ԕ� ȧ4 ƭQ^u} 8dr@.rn e ^ +Dя%m3@3/.XM|7>MrwmQyl` lq^LIZuj>PO Kc dUAd9Qç` ({}ߍ(g[ '@^ﲔq-犻)[ue8'pCm1G; HHF'z41y3g2IFy&KhW9˸J4H[!J[Q8�]�W�䞜1e(|A +H4*UkҺmEI#gR(]fYx (Ҿ`Rw?Yci5g +;=(:^UD2ab#Cquo>i鿘-_zeL6k_MBtK0<X]80RV_a ˌ٠ jc+hkI,1>5q:.: `:U�M~��%)`4G 4nymrˮTyB] :k,.-?̣e'/<_/18X-gg.[B1 AWcLU$yyi?#I89e<"K`_McB=qCp> NCQ-u�`�{w�\OL/+T\Uz6Wwv3#aR@3rmV. 3&齒Wԕ. *t,JN̉]/LPPД}Mnk,W*S30|.iTP$,!3aۼo|A@d -q'm!~$ǗpnXt|(T*-zg,Uyl.v{|qzw}1YSzUȩzfLmUD4M}YA*DhlxI!!1PO ~[\ml%]}sugLU +$_<_R(qa "S`y rsA)J(%z +P3DHQ;'5+~d)=oX^Dl*wt?M~ؚ|zzj}AG;üa]úcW Ѷil, +ҹaU'^e,ω]E"Vk҅F`o�z:JJ8L:n?C68%7 iAQӳi p-I*0T+9B[6iu6m%8{B(/;㞴 X_i-q+|ϦٴffihsHfnΊ-%i) cc "gٳG`@>`$_-ٴf-,]+MLa|X/im5uPSVE2&K5Gd3jFD'-(1% p  p=yq~8+ s̔T}ՌHZM{W]:R 354S_u 횐K-ఆGyϮ!T\U?|yҼ|l7Z汍SZJ:,!##tBB4wRWA"p^׀vXXE ٠3t5+Oe%%I#)HҞd!l)?deD􍾟 (R'@@353XkI +З>Nh 3ojOkNyq~?mg;{lckXrHwX/ťؖ7,Llɪ!:j}AGWMIo▐S5 0@ /yl h%~5].i<VY3LMUYct*VYW(/[.̣VzUR\ʳ22K~4u(ݠ \ġ +cr\Zd \d\Bĉ Jp(۰ٲ1! +[23ٖqHd[Ү<Oi}ϿįMTMԻ8Urenmo]eY8#â0-m c%%=yh.ɊeĚfDEGFT%7J 1:,.0 @pϟ}>Cnod!` ;|=͝nw�u;^q/mty:oW mu[wmvey獶dI/GgZ6[1dgiEye<yA y"ΨS&N5HWqBN}hC�&Гp1YEL>X.WnjbS(nZ j,F#5or0:=]PY޷m4ʹי&uoh027pq4)xq45jű$F#9y +K?@gs%}پ +ٴ}TWg8;xUȨvlkupk*q $d{'sq( n1a0\6]lr?Ͽ݃aNp]xq#Aw'B!Oսi�C4-& #,|"6<@@7i�_M)S�H5M"?2�Ӡ2E:0M6_(s!xG>4߫?j!$38<Š�%!)g[ + cj?- Ͼe=UO6䆪Ut:u} Bh~:E'?pus<X356&Cۇa؅ B2E5"Vg)B!V+ +xG_BVYs3秤<M_6<V>]5&R<F)B!oaӲ6U}i͙ +q麯s,}wAAn6L` Bǡ:\<.5N_nϴbжc9D7J&hBͩd&%NGS|ti8}dB2=,Bg+B!쬕c봋Eӗ33X}(I䖺~Bhe~`� endstream endobj 261 0 obj <</Filter[/FlateDecode]/Length 1031>>stream +HOuf,3x݅83&n Yipde:P20H8"PYYK O8H@(9!;c\8ſK]!sl$6y~ۑiD_{mMLz˟=Nc,R歩:tu/ߠ_9y}tw9se +均z^+ɾ3S[Ɵ�� l摘f \c_Li+?X@Nfg?z_%ldڏ5wq}gbt[��uCQ"w|,Ҷɧ# ?_ɤ}j7|Bm �@D9-7,wjI KGIv; <3ްۧ{'G.2��y"y&&u z9-ntg3 rѓf �@y=6+AδןA��0I[SiJ2 =a �@ +c͕r?LѶ׽Sgh��LʷL0F`>VI\q4 � |ɼ&f,$Kݶa�_N8N?J?p3o4hTb��E w|SiˎJ\A��X~)wX'w1T[V rj�`ywcomqSinUzeá ^pn7l�@U'2a+L;`*bx4ȵ>�ї,VF'kB@y/ �;}(۾[%w/Tۑa+L,vi9 �J.c%'^]4k,<iA��X:W+9w.;^h SC4��KczM|m>$-T;8I$xoL1�.|"V6}'FZ4c`� endstream endobj 262 0 obj <</Filter[/FlateDecode]/Length 853>>stream +HKHTQY)jhPD bYFF֔5X8G>LFD1>i|I98ERn +HJ'u]JE=9 H3/FݮϳG-1&=��\_趧nsZ^ޥ}#Xܳk%64;^�`~<!:u5VXQ)l`qO_<l��g~$*Hn)_D?ђ BM}}Q�`cEL=u+6CrSᾕ r �,M=|TUQ)l{~q[&k ��޲7!Jth`J֩RLWE}}̵A��Xe9~QSQ)l6ssI_ޜ +6��賘f.eVZzXټ7H�}YC=wz?Ja`໓/]�~Nf: *t<Lܛ5G�Qy +>?D?,m3d��gǠs\NQ)`)?u+M�|lp *YJ!�HfFF;zg?Ja@ێ-,fo=��F1=\3^=jAT +2;N\~(�^z+[lz_?Ja@6AU ~Q�l7EzW?JaŬlsw��<=V'D?`bd:mg=.y~�e}~O}ޑR0Ajd*9V� zr] z??Jah ]mh��? �M endstream endobj 263 0 obj <</Filter[/FlateDecode]/Length 1197>>stream +HoLu�_d6[`8LN)SK5D'3K4OX w)& (=jͦT`ZVH=~7;<~? ܗ{ǸIo]# Y Q q!j>{-q@iJֺn;J��� izCsfDKaW rZ%7ٯ(��,VQ˧/˝ Z +̵AOg;ϵ4��[~g} Z +.(_'koxoz) ��7kAsE܅?b]J��w㹆d-pm[c?yrx{��|0sr? Rbk+6 Jw��smxtq?6y:ָϵAfP'��K=9㭺CKc-5~Hl-)��̕=cḱPDKa@)@lW6+��̅cDKa@͂Sa۱1V��`?m P;Ť'Jt-7z>/9jiXP;A*: Gg ��fǚpl]yuj6(:6OC%Oz<*Uvbj�ŸOtl?{1ᾟ$$m1^VXsh '; ߹>R��QBxtdDMo3_7U{ĵA:uleJw��돯VيC jIP@|ݬ?qϰ?5X%6ɋ��ƝK#,hD-;XZJa@=o2 -=9w ��ޚ'fQ{3ܽ �xJjbYG:1?U3>[W{��59=Y͞ړ4%` c1Y.w5> +в&}J ��ޘ;]tWp~d&c ٨%EKnwy4]04VkWGJXV=eӠ2za�Lo{d 's&[<̲H#8J鷢`�N endstream endobj 10 0 obj <</Filter/FlateDecode/Length 595>>stream +HUKo`W|G8x.}!T!T9ʫUE3ԩR!3pVW.Sw׭^szIUjV#T_8װZuztx$;yaФ\\ƖHN! +ʅ$XMLz +d%a&gwv +ĒնL~YDy"::ps5ȧpŦIZf̍aݽÏ.BH}&/cʮZ[rUw^Rfp=!BQwuh</z'<BkZҺS#[woQy us=`d`Az6Zq\d!CPq +ߜ#ȫdAnyч(Kق']kn0[#9Stຟm6= F40)(M;DKS('[Ac+؂'‰Qaw8,"yF#釔c]Œ<Kq +A?10j650 %8|`=xò,?#Yi1ME犿��_&w endstream endobj 11 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 20 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 384/Width 52>>stream +8;Z,f40laH$q4;m3kAiXYL5a8ijG`.?;/C_K)*IpcbO,?"\(9s9MUVO,!1Hb?X'`n +CQBB=jB4[0,9l&m%Hg*=b!pggo?O-IFN2B"pMdK:.ZEE`-qZB-kG55.9Y>SK0$im3 +(o8DY=p[]Xk#U.^)4>YjNnDf.Z1+!`ObndiUfc:UiDckJO`672HcQeoWR[EaC@>/g +jRe-@_J+=7bUHR\-)W'7QN%d=V_snaI?i@F"Q2oHnOcL7AP5eS$YsBXQ'9N`/"E%A +jMQu)&k>Y%]_ceG$ac`JER)7S<IXY[C@3-$a]8(\$CKB:N4=p/cT(!Tc6MW!egjqK +afeg3S@EpBXj<Vh]a&QNc^ahOj^T"HJ/kb6@Yc7%hFl]-!9+FiE<~> endstream endobj 17 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 34192/Name/X/SMask 264 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��:8,x[1ͤjڦ#*fZc񈣂E!Dx!"lpY]xK94ƱjLfښ1b"ryo`e>ߞ5tw3L ��g~ ]951Q���ٸ_Cwdל4=?���z6]Qu9{m_5��g~ U)3:���=kƍ5zh."x4xYQrrzusQFZvAgP;��xu_- +ͦ4̩R;ΏVN\ -_g[O���h_Ԧ#t7C ntSz%}xg'^gkFK_���o }@Os$qsٔȱx{��swlJxm=ou^s7��@gDq?��bЊa=H>���x\Ƨqh?*[Éb���qք"KUb.{���<.pBGԱAe��fE@+{熕w��#)qއ#Ɣ+ }2;��sj +gҶG 2 +-'e��G2ҲhE%x+w��#'ҏЊ}8r���~Tbɨ?uAk ���2Њw(W2W ���ٲ.ЊgDRaRbͨ���*κL@+ZGrzS^���xdex%n>=Yj���ht2zVwW5=ue��PЊU)֛քuw��h$[Jղw��@Sܤ?GͰD ���BT(zZZJzmQ��xU*ZZL[t-⣏��UWA@CZ~L^%"{?��W]bC@+Zu fS-F~���:^VYa;h?<*p!}mCdĤOv:yϮH;Az\쒬zOsE~/(pv?!Ak.]b\1u1ej>o-z;:>���z98Дca~XZN]⥢+S(חW}:*9&lڐu?68g#cN46i%<1ٙ$���4aoKfUcr²T/! Q ĥp!T/Mc8XB9t��x8Д4QX}א&o?S}ۭ]3~c#��xi&9%_,:|AVDzL;𳢤uW!udG��{Z^dUZe}̋eP_\`<m#��2Дcsg6ocr~'qld_i)gy��[1g.Mi? Yܽ٣e7G[S"u=ͱ_��0>KhI{g(Q,W_)3:sӯTON,X��^MԛMG/ o! n|?w8t��ไ?%̸]~_tf<T(H.>b��g' tKデϟ(-fj5t��YĆt<_iDzTjU7`@~��1t}}\˗cdijDgݙʭi'>r��N;w ZQz x)^+ݚzg0N��t(-&z>-Llʌ}B5wLߖRncg=��Юx*ZҙX-ELm_ٙd,��@l?Zҙo^s&uK=tiŜB'��hF9t?)̵|q62^v7t\⻺ʬƼud4���"xt?-lj +nsB<ݰN=r*ގ?"��~FEuqؕhQژDM0&w[9 QEQvQ;;[Da@-(EМ*FԗJ@s}sy0q3OIRQG";a&YӦrO!oGZa&&l*���Jx\!I_'9w.FښʍDZ&쨖R|6k��!W\%Ek8\]d])]KrÿOUJK>0?hۯ���i&_Q.Bk]}L&=Dҏy~JS=Molgk���=Q&71k}SKx\~Dx0_MJtkOpb s[n�]f9XzR뢎#ҼfDʚmƮEUMb����\,8_$g.?@%' G#l^ppeH\)~}鏭Y +#o1{G4&<i~(I|3'Lx[hO ��� 6bEV\@K?ΖT !Ox'm6f}L##!P4yw"T%U +~ZҊذ1~^i<���W.a2EL\qդm3+f-& #jr4u{ܴ+(|OTKD(&4j\/rqt"#t ��R!a j0X u?i!s9l:Dv>[>qwTcauɝrKJ + hdg=FG +���R")?`0Zk:/Yj5r32^{P?хoESͺϬ!`.eܛ|)djl���R*U_�]7ށ*%UY_w]#{=yC}rJZӃw͛R$:^tIg-K_?8rzN ���<tH*䗕2Uc,G„a(M1`NNa~Q'oe>jW'㵽h +i^Dʚذ1=琭v&���[Tt'8/̌9bEg;_?2K?=c_ЏA{.;rizđ6&Ǜ4F(z\i{xcAIrdvUsfV���-&=˙V"##ffDTJ_tu==:c۸ZJ1k ˌr2Jxs&)^Ct9=*ciƋ% =M韥i< !��(΄D"~Zj}}>3zRA!_!mjęlOA�XzPn9zEZeOTKK'웶eJw&Ot/��� o|'hչ?CNorŖٴ!3ڥPδ(TFU%ژХ$AlƈQ&ʕRQI$Ci��ᦦ=<k7t'wego}菗;d#'֭X\QwʴKuuKv>_q G)4jDe$ ?p7F'��0ٌfOe?@_?~9#|H Ӫ[ a|jBڳ N:S'4BNr2-Ȏv~^ ?���5QEI26?@_?z-Cѽ^NlqrJ'[RW'Om|$I%/G7ĄYAV#,���tŒ)=m8_!s(^ΉR7HWvl22?83*h\mag-=Ms7~w: 75eS��кfOD@m̃=(QΉUHE]sƲx}}lAa}d\Et9z5۟��[9GA@}F Aa{_ +!Rup4zebsÇ<CV2tgS��zhO/odyvArf{?#'lA5n(MS 2< ���O~F߸mŖٔ\n%f{,#j6ǕsGHogZ!\H laoMtfS��7o7-g:8q 1F45u4ZkNR bh$Q4@qADAjXelq)V.9Mz(p>o@xL仼^gǞ/Ǔȼ_f:lG9%|W9Gb=Vv��"_>ߟHo޾;/w7{E )M7sZŁ}n,: g}��~@HP៵1#z< s;r]lYڋbZ#VF-(+舩+,7c}4��(~קcOZ ˯LJ0e ;plX_77՘yv*'-56tL�@9E'I�@t^5ee?4YiQ|ڵϙf|]1%1(׷˨1-��1xN߲*yP6ϔT<mh,s1Qѷ +p^J ه._i=c ��"}g ki GM(ɤr)=ۉ *"6 NQ{\Ӈ��$ů+G?A  =73uz]K+&qYj_˩Ԥm!ܦL%k1�WxR) +5?giV~'cݳDMrgi[ςs&Y8[AWoLI ڵqcwG%D�+(O\@?nonM)YA$X.s1Q'Dr.j*O{Ds͐1׷ߴ I&��B)y: k7h4G4H҃6Zk+9ur'REm<pdzM&c}-��W*yJ {Dn1r  XDzU3}b޲Y;zĠkHq?R> ��`d(>�1At$-_/4ȭhGSOi3.3uHJ'3j똱$JY_�� Ns +SMz 6dJWс߻e/s1Qz4G +Iw+R9mp^y 35&~秣W-\LÇ8J�� |UU5ee?@L;y^.F7.j-Ǔ:;lp^P,ߎTǎ FCX_/�� +u꺸Gq<Wtb_g^q]ZA[&YU<ywBq^ˤyՋ��P:�1A0j(PQtPoXL\]It1RF4MkwP%N߿wf:)SiP;W��bR y(nCB|u WblY1qO:E=qՇUE$sM%'Ҏ 5~>cc�ъ +\?vNBh*ϊYSm ןL;q]U?!6tD3^X_]��=B Gb`?砅,T(koR $*DpA~[ hN%k8\*q3z[[��DܩK\�1AXƆo]D|YA.Fʘ?1짦":Y1BZx#sЖ钯y}V.ȆCa#6.L7ذ��^IQ]bx Bat. +$j;K[#^+N(i[Z~NYcLI :k|iP;W �EkYeŤ1iK/ٿ+1eZJT@pAdS[3qyeYԗ 2RFGM۱~!$a}9�X3) t 62ĝ&M  a=Q/ѵ~t`_WDWU7u oUq<گu;z,f}m�tW쟄�1AXYB<M uٿ1;p':gRh{_<뒎ƔĠۺzռi $a}�t;C?,wB=HoҘy.XNEEQCa\6ߊXcmx%buN}4m~˥LvX_��T"xK7eot'Lso`o@ )܉N%)6+&2jL𛐀SNϨheq+:U\0$n ("(`#"*("BBLnBn"&cA+QQVG9\G9߿|>[UHս6 b i#qf�,gDlAwh0~<-D5>}EMEBs�/S>G%f軺ĭyLd_37iXt?ZxV; m%$?Lq&\!nnCQS7@m@5>O/(;T#wDj-W(>5.T(2 +clx53 G8؏@} ʗ_$kҿ(S]�P!UϪ{MH@.Y[Eۄkȓ4G&G_sAisGLaȥB54mJ� +.Eܓ6{Z}G]M$=UThmIᇋVYx8p0c~1ܹ7c L|-ѠUP}a'F�p1NH/:~]XUE*_vN2H? L6ju'0d@G Fҹ_th3֚a L4chӿw(n%^�g��?)ǚ?^nKpc2eȿ+8xpv[+kG 4h1zv0]'F PCʛ*ѿ_(۔-\p3u<>j~qW.IZE*Bl.9-Iϋm.|d;l -+?&aRoCTiAQ(x�Å?:=N4tuIZZ*?!&=<[a�Q{>>r (?LOS r ML(5KQ�Uk|SŢ{ _bEgPOQ`0)1~,C\l-=o.9>o钖Y޹AAΚ vÆV EQvX;(?"CHŭ5B(TZP ߷M.!b{g :FX{D!H&=.O6@O5*&6!@C<h?ߡfWyRZdfb{Ϟmxf_x'qa@gQ`0v Yg5 AWҿ(jZR]R(%~kcSj4WDj)gɤb!y0a=1H*HՏl@ "lKT ʦSY 3u%bDcFX}EQӗ|?X&i]6>*AsK:$VpvCa A~T` ƌ4YQAZaK}ؚxOx ʛ絲g.(2׼e�0;Y<Gv V~MT]j-SdS|S"/z΀#sALI1VGuD[]߸ffP:m?URRyjBwE{/3B1,rxV{][:R&y"x|O FY PC+#*HUk_sWG[77!o<|gYmVbhj#(T�h9>L #cU+}V|_8A7f%% :| +`x8lvL\Neg?cEu4-P&}G/wq}9̄T4hsa(j +J8 +RO2yY7.H66_JPKY2mfzxnJWz\ ?!$*T(2/M}TXp8{<#o&_}8M?c@&eozG#hೌsY r^#Gn( m�h]Q%;EޫJ])̸PEU:%*չDhhڜ}_$ +Yy~3e$p#Ї}Cʤri1VDAm;#T(29@N)l^PE{JU 0)k6S†G~Q>)qyVЋ`}dl.IzPAG*Ｙ]^阛yoϩ$e%'d''erp?ݽilೌwPw.K]O#X.k˩` +A: , KW"RA%QQ@xzgS.=geF==|>32:>異sтӧ&Ӵ1cl0>` 4MjiZT`*cIlˑIRCi|ۋ~FyV%j��v^CTbѹ=DW|iN4U1AOz>*|VLlzNkݗ-5Ύ{x)PΚLvdUYzBm<%dEiҫiI*dqҘ%#rb uI K ,w~?މ]w ݾ 룽vߠvuj+W7-[.ZRdh 9Z6{-6oϦNƷ4O4}8:z M1ƛq 1ШAo}>}߳ѓ0۫`H fGCzڤ -uuNSI#:;#4(,[TuÇɕ'=ٓY/Mό}uc85̸h��[LhIjE5Q[ʜܸ KP]1Io1Z'?:g~X`1Q"ӖRK?ʭVؘ?ZkZѲjMǍ-.[q}nzE*Ib]Tw"/'~ ;u.7*+lyFS+\'ՕSNe޹TS3{qdEn(\gҺ'=+S$ZP!ʋ%2?_~Kٟ3Kk7NC`6Mg~ɇF/ s}E@R_{!J7��T_"E3I JZF$]A$[Eɴ&^CkKzJTȎS )E_v!tQtVN3Ct~.x 蒷ԥ+t5Ѐ~ 2ѵ`NHwj,q'DT[TهoƨƘ⛱Cx⇨~kJޜhKq;eoњ;cf0^+W1A32'?ٓ 5۫3=|fiL6y(nkL],cI#^{菮 ��*b.dDF`�ErY[VYYw1쥿~ZrYCevO���[*O],&eIi)u1Q~sL{?YAΧT;��+H/-|fak쨳h���:|#5̆h&?iш��tUEruwi%LHC:e7 F���(GazJ[RLHC, tg r��t5E) Β�sv rV$)/ ��й +岛 SMF`B^eٓVhw1��@Wߦ1^c=F`B^gyvC A���:^b6Dy[4FA.*A���tݟa&?MYuj~HqR忛��*Fa&?0! oƬAꊃ + ���`?V4-НgzqP>��oUǒE`Bޅu k/��sX.𮞼 NA���e_]lfn.> +W5R4��@Kľ{4/ۈY4͈[w6��lޯD֢?0! AAnA���Ͻ|o[w ih/"a2��+oVvSY7 ihO"=N4��yX`1N4 Q왺{@,��Z[j0LHC@G}`AGA���Nk؛w i(bFgA���㪵jmT&?#m˞{ ���oqu\vOf==cG���5N򔺶[4t->sKt���URXrE`B:C)Y{Tc���Aw2n(ЙMΞ3n~��{Қ4t6{TSw���Ut41GZv;�epJ Şj~�: <8~&45m6IqI:ƥwRQXEJP`D/\\,j1M j;$h4 {?3//>Zӕo>&)Ȳ;Z;ɾ�&UDWu&)ȴڼ{8wϬX,�[\8/Ha@N )k,qwvi��oiXgZ֗b? k-qh g̕}� [t.&/e֕b? YoظAϑ}� ө Qkd#o!6k$qX4S�,e9/:A m{5lSd��P0_ܚo֏b?m6}̆ R1��V\]u#)x#A6gyd���OqZ?QE1RVbl'y��[jZ'?7k 9<p>��Ip;lWVdA]�e[N7�ٝ��@Kskiу.d#_ 6HXNBqVzo^��%yn)UHaW4lus'ן/��h ~Z?/$BݿLl;'��<n3ǟm)JE)��q*n{V>1REblwX-6H} +��%cj]c#_%6HZA��q\Ӹ?&ZE<1Re~!Õ\F=��Qo6Q;ƌ19y<vВu$)"|ݺ?;| ѹ-b|U4ٽ�׽m6*jA;L3X2 ?\Aiu^E9Ϗ<ݵ0.F(10A<v_�ú|[6  jxcΟ 0Pl˗0 +Av"ř}lt/�m9;A|)G-2bwMjIKv[G!��Xq &f~WҹCNضu`SyʳAbsSv r3)=�q^mo Z;rMHl Sv X~��\%^o5yЮ]4)n~9uLJ{0LRB]�@s՟/f?]2~?HKg7&k~}~>Ͷs>ܡFO[#z��n1B3iM?iJL\V`<$?Z +wIKxSӓ��~ȭqmwxcur(+C=bTgf}Me꺩QV}lKv��CmIj]&imԾz`WQ߱?,8kq]Wٽ�9jaO}?7YsY>8*zGn;Z!bV -��439= ޘBkqϹ>k;ZP<hn�)=%ᴞw)&!)+rv/��|DZb#֤sHʴ;l�]? F +̀"~Fyd�jJc  F +Qhza}�@= LHa5[$4;U[u{��$}o?@k%MjrTx�@sƕ|vg^JHa5[c[ͮv��3|tiHa5 \6C~��p27H5yHamnjvrs�̑Eb# UVfV*BMsmдw3�Y|i=!PSb?JE#Ts _}e�)vX?)1R@nG)#"ۢioEo=(e)i"ە{{I(ܪz9nHa�x‚nV]!s!Kw7�2vyUV[;AGeeUOG癶WW}RolJ{�|K ߵb?�<.-~WS+nSI�h>Y(5~e#% 4[Ykhq~a:^z/_ߩb?�|k[_?1_v7˚Ҹ?B?�z,DwM{wc�o ls6ߣb: 8~*BS5N:uơMcSDL\)%bQ1D"r78U UJ₨@&:5r`:T3yqxu9'8KK#Fٺ_E: )obBPR�zvJlj|Xlf=�X}w'h)�=mP)"+a=WU5޶?fE߾7DKa�eq\Kl0n' �۱.'od-@qKc-=f_?�r3N<woߕ?�60hn}O5+�� BW{ 'DٵIR�C*[_}�@O.ͩug/|DKa�&c7H Ҳ,rf5!�@OgP.S}7?�`mWyHu3 r6/5o� JgRzDKa�V\tlȦ;,.�CeA�k6z;I��˃4.d-9LDztUɜo�T2�zA�[Og.˦;wK$N�|.pqc-{i_(=#Y{�ʃsW:u?�`kܥû,2;p7�t +4Th)�c{9p^!+f}7�w.|wnᲺDKa�e.kK{r#k<ל9_��ʹuױ?�`ܥ)MOu7�7gvySc-@+ܶΐgȦED�j8{8_W7R�disz׮Ŕ'�,% nc-@nY*o7ż �Ψ-KOUwh)�ZږRzE656W{z-�i.93R�lPikցJ].?}t�s.IXe?� c?Z,oT;)#1�I~+PDKa�-^ '%莶t^ kz5�9;ub-7ɰG齚 �xYw5" +uw?�͉0llM9�@qܬ@Y?�VcB#t&4<[wua/u_?�Л9BuQo+LN'֊?�^fcQ] ĝ;&N}�&J"/0X(x'o�Sl|$CQbqK"ng?�sFmxGKKR:-2|"�zxguڞ ֞ĝwl_d(g�@_5Iz?Ӊx*;*D=hɚR>~EMbYcWe2d�g3}O`å +pt(7 �Kj[UIbqO*66I�g7| i_vʧJG~[3Mveo~ [FA5m ]?RdߧOg�<�w)qPq[(�蒶(a.bH_{NyחGH-z�yeܯ'N=Umc! ݝɿkFew(1Ǭ:?�뼸v+;9\;Y +�mc?Vtw:Vxuc~ҴǷ9SJ#kTlԝL[|V{R폤}QdNozI�C<ikluBߨ$f "d7r?5e\dAT}O o�`+&DeN)\;9K]~&;GQ4tiJ2sk4r�fi69qҡc,y�]Sc>a[I!\?iϰ?�(Y"oVb'`6do{Rϰ?-eb?�<?͋<}E656WO�-d1?�k8yJ[2}N\_U\=vx!^A�t7)+dc}CE4�l~d+?�Pmצ5爿m�X)7ِ:t +h)�NoIa/c%_o�XU~Ӕp\ѡODKa�@<ll,7'7�\mMOR�\C_AQwlM54v:&SXMR j�^hP1EPQȲ]8gYQ\@@4Fk�ikǦcWNLә]^dyJzU1�ryJ~ a�;_ �7bwk3f�titG_v^;�pi`�bH%e6߫l}�K=bf?La�Aѡ|ko=e3O�\9pf�5,% ݥ=,㛺Tm6{'D?�@> G(;7)}.c]^kg`��Y>qF/<Eb7}@9[vf�ޭȥ6y4Gˍ Dw"� wvwAd +�|Oy)kKb]ulut7Ad +�|S`T2m[bJqZ*'ǧ$hjIN{ 2�흕~Vߣ[n7L ߓ�<zuNd}bwAd +�|ss)2{6ՔMߕ�<Z5z[c�)�<>^{f?___Ot_TgWeO5})�\/x4G9ZFM�~*v.1D?�yjλJ#k~ָ{hmnAd +�:%g<b'D'�ϸnAd +�:7)J 4Vv9.:V|i 9�t~=b(Q{~4 O.ok%ٍ?La�<F/Q'=?K<)OmnAd +�T2\m֔R0N|poƝ7;m[b?f��G*C:D}~;}9M?La�FvG4G˿+ c0W11-?La�~hQaWꓶ"w-�v1vCSfw 2� UZRhZge1nc nAd +�ɳuz!7k!sxJw},,5&vD?�k LIs64htuz794yݲ?La�@ޑzT;]xW>6(qͲ?La�@zZ7Tmlj4Htcobz"S�е;\Ym5=*<9߈gz"S��ô+_ug1+wKF{).>D?��2U{4G{ܨz/3M)�=3wʪӍo×,U?iqsOjz"S��3B.'2spE#�_/ w'evc}㲷[d��˓1C[q|kY [M{4yow 2�3>~zơu?La��k-|G+j3u?˓KK +y=)�|R! %Gkn@gwaRc��<z£/]u|Ft:ׯͷ�a W6vߑk+'QK:WVD?��?FPtkkGs֖XO/Bm;c_ TfU'*\M~?��< +a1.zJs\Wt:go ~ Dϛ4W?7�utr\[^tGʶ4f,bz^Wl?aWw�XR{4G~g?�_9V3]?/&m烻ww�0t RCn+eJ,:sb\Ҽ푣T FG.|^c��濯:sVߙ5\œ<'nA|1 co+K?);?KnԸE}�xBWZ9.L �_~vG /ߧJs].9;̙LP@�[u>rjvv#kaǝw ٯ;0&mM4ih'MG$qT-)U(!.E.Q8hui\0,I[;tWӚzO4|ߙy{t{ws5S[3z?�<1\I0ޝ+C>N@w4u:3fhۺuɲ;5[&`{_wGjm_B^Fz{ۢEU��LI^OZ~Jb'0kaw2?e纏Gٟva;#d#�@wIe+5Vq�DS0b4:5̹k8Re>?��5DU}ێ!"ZaYoA<5ۓ"K7y|&o +� [ѝ4ǕRQQi- ZX7 V1 {PW]֝!7�0HIsvսI5ߕ  GwwRWt}?La��<EAJ}K.>))M1aLM}ݷ 2�4>iXt\֫~4© #xŸ&D?��gT\˦k57OG/5 [ 2�TmC# r,C"؎G5 sw-?La��<u:ѝ/343 ct|oAd +�|9ߒlY_X$7RB.6|uh+w 2�h.ڄ)[Z}ؙy|xX].6ptow 2�hnF kuTS]<</6k!^nAd +�u$e5ް](G?ƍW0InAd +�\PB3V*ʃάĊ.FD?��ݠr]Sj#O[ݿźD?��21BYcij{%p?jcm7�@˟/5ە wK:2bm)�l-⵻~Dw:;6�p։t-7tۛf��Ȩaʊw(5E|ŚzD?��2 I^LVZZR/]y4e;f��Ȯ΂"]SoO7OG/㴟7a)�@K5)xI> UtCn?La��Z :i˥B+DZ|{ݲ?La��ZWvյyֱ;(Z/U3]f7 2�hڅRm7+&e<Pkv"S�,pÜ:tM׷.窾x+nv"S�GToZvͷbcwR'ڕjv"S��Wچ)voR&ɵ?:O|/EiaʩAd +�?u~DS+?n +Y|n +d��nlʷl5GW؂wTHܴnAd +�&O}EԪù祖ӡ̋+sRAd +��̷;7)B>eά˱9Ad +��sOGG֪ٓwVȣiؑ8D?��aTeg+[ ﭐ9E6��o4o~=25͟0D?��x0#F(iQYqp>dWV~`]D?��xpi)~Q9*ʜ htMsM_{c��{56Z`?T!o> Ϣyѵ욙iq23)��NYC95**ӢyQ{˺��.Ej~"n ϧ+D?��h<MR ׽5OEL\mo%Fw2+)��ד+խAz`)cL"ǸMۛ��Mc5q+Ew]x mnAd +�B8e+3[ײkjOE-y9έyY��Mm@%:k(cp-{$vaCVcvC"S��<Hlikj?}!^ծ}?z��Nyo*]<( HRF45!m:ZEgz@8TAKDD\XX}xvEE-43c}:Ku٥y7y}~ߧ&Bޅ=��A3ukg?MZ|g?PT���@[K_ne6/w/ 罹eI69~weO��8o*;)''d{B���s<**{z||VzR}1 8a#Z|G?PZ?!J&+ +v4��6xf92Z"!NN7yG2҇DxX|7?PX}侯q $tX!ܻ]CK?���løTN(]gr5*?{dxvF{*HժV LYf}y���9|"ÝK\vOה?:c61{ -8/\Ψ]Ѩk��m c6Fy߽2 v +v60 k+z#^vfp$mX*?κ<���˨T<շ[Z0pq>1W([\޸Ͻ79Z��`JS&63{xa`\QVq#Ÿ!dE!| ˾j +ג 㹰 ���f$SV]χW?ëyrv Y[{0d~6gNJDFyΥ>&4*du-��7ǨHO*U% "{³ǃ:[[Z[w1FS[|8az4(kgfgS7 \/?WWk,@8Y���x٦cŝICyО-L{2ҧ!l彪Lö1myX<R���^O2ǻwl濟#$5֚i([+V"nR<qXTܢpc��kT"}d ;aK-Ԋer5]a\ r'c)#��SAI4j ZwkZ6{>&4[ʻ:I(oKs?���{/U1g I_k\ZQE@S VX?|h,z޵EQW_KxquUaz }Q9:qGEKrgr-^ LozgVc$[6F*+=[*Vb3>g׊=��1<b>%,!ﱡog4525eO5X#:g&?ٵfS7H[}lsyoGϏSU H.dk Ud~,Nh蛿O׵v$9`$\+2|/+HjI+J7?>P$W6?(ג{db6O!ΙI$x��Yr\C_m(6}6wVz#]Ufm=?PT?Ho<CҧE%£w,AVdc$#>}CQ;18o^C_T]g`5NjYD/|cM0UZQVE4 ]r{֓NR{��~"^Hɗ߆kI`m-?PT?eHOLzqW"RyVdU=w䠇a,Vbz4UɖFFquޱw .0Mo*ߙ)/&'K#Gk#g$c^QøpNZ1*ҳ9Gٱ"kp9��%ƒJrd?:S'!j&EeO5Y /2kZ`Iһȅ=?6z)5!vU;yhz=Vq)NfLsuUL -;c/ cLY 덳Q4Q2=z2�'Z(IdB7A䳹AR]'RsӃsʧ{�X1N+$|S|yC@S F sf^ܸ7 5-!sә(} y|eV( tuiq>q#9VŸ5ecV2L|Ƚ.7ynr-qg5 1^Ǚ$T2gIx��}%2OQl(J-v({*[3B8b̔9o-5>?U) 4=`3tErn7wד?G֙g-7?lg{>{q+LMylompWN K6d���cd̚Nidf\:8~P+Nڮc[VVuW:JQ +x/!C$NN 9FeN]Պ~L?X=F p| }?ceQ-{p !'gorf#5693ڇ)UIBQ>X^Z6u%i'O޲djB7Qdi7)}}� +̲hvh26.CA< C,v,Nʙ|  DŽ28yCÆ 0j3]m;jWW7s-ZK,Ma?]?6vNk|s" `FnA6{Ce>! em|UЭ M8ѣ6*K+B?4ҏ?h15fNaoRLe= ]Wꓶ +mu]/)k?�g},MzqO?BʓC>37 >6U:3 x J'eqjv܏w]`_8`)^T2<:/K,+]ki6NW_3mvn,M>{P―)=;a'1(A]Y`Ε:}t] x1jBDfvG0:-vldͶW9҄!I؞/4~Açk4yy[vzM8\8}E;7 \ծ\P6޲:ch:{2A)/0ˢ]dig$ +Zg>h%OU.Thzh9KTX4su%- >uSjþٹ2VYGkj_cavU)LCRS]k_ Ř%jL]p} ]8zGT׸E M7f: e]*p2]o髖'&$&x2]4qϓXaZ[jKy ~ V7='<y8x +؟;fv. +ŵGS9,:क़=]cr[tdo 2xkȟ�+y}cBdzJy'?0/  28 N|՚pиP?B  }1j/t?O_ ˕#z4݉ø  ObU]֘ti5v[ n[^Jp !AAE(JO~~d: 4ܢ5^\CHAADA7ݮL_f~ g93o5٣R@AiJqJ^>b5/~|/ 6%k癣R@Ai 'ٵ:'e{lD=?ظ y4ĴPF!T1&e A[byrKT<Ô*(Mbwe|.k{ + + 2 U8i\<M?<rhSr5 !t]E i'E9s%FF{͏[!(NtR;L#:(SʚmWAd`x;EtA  62)`)<&N-۟|]|T2V^A31-id)}Z`_{:wmsRr/ !'UuYc·9Q~Y{2} x&>eM?ަr&ܖN|?gCHjL%dW_EnM vPn5mv_#E#-u毭俘M\vjUcG_u 4y]]j%Zvb?|vgfata%/u+EMω{~. 2ߚ'YZV6а&vO +b+/k5ֿa<3iY'W68#=MXV~$X4ּ;y<XJcnZ'X@"Pw +r.v`& ,-fVӭ{e||O~Wz +>^ϙRx�*mWWnctm U뫃Qt6y h܈e{70΋=vMCAs5OT?h4Mʒ@Y]֔}?@% +Fe6U!T2ŕ1[3%kA) Ƌ̐XͲ(v-ȩ4h�X[6ljtXK'e#yN~ o3&eɃN<c ՟+, 5!0XNf]֦L[wΜ =AÄme1~:!5[V=_eJ^yRxYsɺv/Ӡ(4W3lHlZQXcDDȍ "GT 50 3=hԍ&&z5[-Uo/dL =ꩢLO##Q-DLոSs5v#i[r&|sxdP5T?mTs64GAHZP`s_|jl̼j5OUKs'p&nϵknZ':;יPnv+[Yޕ>7z^y.] ��Tfv8ޜ7/V&~8Y^Pr/ǫqjܩҼ|p[~hխr2&fn[}lW,TO06 {qP y₸AϺC>+]yP`Xi {7y? yƓ;9mkH0r:䒏uj, cRBNzv {I��@3mwho='~OŊ)jNzR"VH36]h=ߥE C(oKo­ޯZt Ώ ]9{~wcER!wp['nZ7M06y3;U2?9aj! +<͑ƕ;O}ij?>GGc$}ufY}j���f3Y|U"w\Uj`7Tr~/ǀ�ci>(;o|UGcɔս4+ + r2mҚPݛp`#]-VB׵e0~=Kk!x~Mo)wIy9b&thr>jKc<m~ryr<kFoS6Hscb涍iN.rZC+wte:ɥ��A<wbu-&'vc |)?ΞXҜ|p[md,P^d[ʕ,?›o3HQ ,"+YvP`PL wOj8JcO^v]Rh_y|'U? bFgcT��y^z{%e<"]@ n3 |)?UqTb$oGE~[3jfЈ%y9CN?217ӵؘyZfqvΑ}+lbQ&fޖxxZ7C`%͍Y��G1 R rs>\n*=%n> —cTNH _\7ϵR=˞X8gӵ?kS]7U~+P0na/ڍM:MGd[4֚^GVO49$D:$mGutDWG,Nɯ滴.i;/S?̳,PFzÁ4V*W\/-w7���Ϛ17qsjl/;Y}/TrN/7@){%'G&'ʼnèlYi^38SN0hy/%JzVoQd-Y؋TSl.Ўu ?Q=QvCUƛTә~X;{&ɴoYQji[$O"G1Ҹ_уtҷ?$/; jW[b4С_:\Q��:LH aoQuZ"ݠ;8k^X{KA-fK>U|0CN(ak��C"3\JIqT=I}?xޜ.g IJV5[KkRt|Z^W_4L; ���|R87t {ߛ#<ONZeJVG17 基x!j ���xy'i)Si7.яKw xcWÁP%g@R1n2C{5P8G����L#r/ -QBWs\0JJ+9—E����x7cث.ku`+q;;LK����7;Tp.5۰T}w +ܽC,%g�@R?����  ` bEt[q S����0O^<s;CC.g}?����$^:)]Z =G{)3K����@Os:u\06]Y/a Uo(/K����@O`cmG6BcLK����@Oerj^BF5^vXUc}?����dffm̛~ʰT}P‰vXV0T/c4XQ|]|Ni:+wk4w3ۗg~8����=Ņ[xa<n~4hy1讘>i2 +3;ntڒU}2ccw͖9����Wr<YE�FW,Q +B0Ag*^ +F+*Z87+,xYaqee=(J�Mt-q3NgzӮ]v"#g3.y9TSO;NH/p,DVro_*l1ܬl-XuoE{q'+58Pw`5@<!I&X+u(Zrb—B�R- a㓥{b+8ڭIw?GW.H]! RgC|FmʙR O03so#=QMsO󲗻u67wZO#pLǁ!,Sh"V}Y_#1T1bK GtO@ +\:mXq۞.GCY/] d'DI7\wz{ORIC-l]6g'髫|fkSM#g< g b>bnK_>s YM۳ʧ{A�!sA2O}8s.C6g8xmOuz+نnK5@<Z!˭+)Uз{cs|hP�Z$۾v]/[HOT&/{\gsSyATW5^BAAo_xa*-<8kk:v4ߍ;V $YAA+&Ө_ �-Vo*Ɗr8ړ0_e������F1Gբ9BO/?Fפfd}v.%TQ{w ]S.t������(2wO\צ'YŦJ!w<[:{PR���������������������@sӔ;x>ѕK5YiRIRɎL;?k vf\<ڭijiر. ɳX}En,~imXə69m-<̞&k=U<~xfxpLX^).Vu.=Q:/^8Jτs^m2$3t $}n-<femҸ]y8zGw֤oCI47̦k7m./,R#4d\:x.\UE9E'NL-z<ӟmQv\hG6}౼ ?=t5`BOˠh|2pvTpؒ VdXu +) swlvsLPu!RϚ#;Th8\$|ydYB߀Woc7&ꪥ1x,?[ی65<ښƆe7 +U*Q6JM{wc,1jNzcBB//,}FMuͭB0tkx,?,l;kx,_<;ustF=(8ڭIW@ft>ufSR]yoeS'/G_]rUa5ʪXYTx83mݮ?jkBM]GzZ:/{۾.^R ?ѿۛttF; f2l %⧈A񆍜uSpZGSVOSkӂu?@wr>OuPqˇݛ6fk:2,\vY@:m/=|Ղ%m^"k=UzAg;wߴY~g>J|k@^6u<~bxْ"E]`d?%#e/wsd}T* ^q΋M1x,ƱSR|i9wftݺ#^<!ۛY'?g'WW-r7?Zu f2l %⧈Z񆍜uSpZGSVO@GԋX=m}"cyb՝+r~cy;\9 g5fe$:M7O`$iќ\g翡MF)⹖b)#5N_#ujM%LbW-׌ظ<)ްeXx,1Y{ 1ʥZ;:",'E󲗻.^+A%є<&$l1=,*wbR8*#Ao5+]ǯ[/JS!.Ju47[$r <{з9yvx G7 =_=BR1:k ޯ8&|5;*=c:]n}H1$oo/mu eR^opE{08c.KY(/ްk1k|(U߮Hx<z6.%y +&*<YMLSO{[%,ͩZN[ͷBgr8( $ f^Z��_|QVXJ:"&AFT)6 hEF b*XfYfZDOǰ(j+](V`f 6Y+3sYMaޘ|hLYJZB 6U;~gqI?=VvzUMB2v0Z3f}xb'u/#HMѶgguW?&zĵ+jjCj`"!U3&xqg%hfГGSkks>ɺ'szj)_Y}HJG(w_CncfCowVomۓ}-óWO]v*ns^~,zN%7[wgge%EM߰Tw_l:z߽7:¾lWX9^|~}}3w4Eo;6n]7**ӣު%㏡~{bi~κYr ���������������������������������������������������������������������������������������������������������������������������0?`�1�л endstream endobj 18 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 33574/Name/X/SMask 265 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��:>8MxVS+v j!1֣0F4XEIik Y*r-:NLژLƪ?ʳf+"C.{=Awqh7otb_M/��5Dv$g���۸_C4Jؿɧ?0���۸_C2Q¯���}kVEGLv5��o~ (qtBRK/Qly0y>-Ho{6.[.7��.=YA ̟>G?tpgpŶ2v��k>M 8P\S[YQyIsW_ %>s]?꽮+>���*8s}xo ���)q\g<C2���Dž{lUi���iǗPEpZ%{���:F@K���iޢ­T:J#{���/-C@=o1<D$���q^'wI'{���9gϧ?pdm6u7��*^r(< +\\M7��:G@m#G/Jo6;7�� TѶ?2J3>B,���^sPEstSxOe��c oTѶ?d& [&ٻ���X*[犒ZQu] ���5<7}Ϥ5{w��& UŇƘ_zqi���hޢ?1m {���Zܦ?Bfh4E[do��͆.UVj ^U���{TQd5\6���4TQl(: cd��C@@ԃCl>D>��� PHGBfh4wbN���PEGa[YѠ��`uUtٞAC^>���+K@);#ד%ʞ��`Y?4R:٩?޹s���V5v(J?%z{WZKF��� Y0A\��RL?c`i��`UKS(Ht���_Rꏤ}C%{'��m[6Jꏸmɢne%e��]}J󜮮8S|){'��L@%^w[AC���Vt,+ktk ?f?$S��,'/{T]Lس2'{v��j͙B@%GܶdQW}[U^���VS?ϣ?<{^w[��q2*?v^[��]XJ"I2U\���Kыm;${y3M��JTIJY}<W^���+i:A@%G4��XIqJ",שyAC {/��U:Tih~nѬٲ'��XEwemPE16kIsxEf���\-.UD橮q^({3��U4kD-J;ޮ8N1]^ד8^mcK��5<_k_6μStL\.Ctf_:zTHn111��XWOgUh_L qth{c ;'g>RL foΞ#:Y,7_~}H}mtؼbUkcvn_e+K7+,R^oϙ+͚-M.r4QÆAC��h׾ +v~O#š;vp~ѢW47z%gϊT> s,+jpW6ig~k_]\^s��@4\_ ^UoQIF3W/Om" !jz4!BQ[!*V_AMi@2\a [A*HQWKUBPj +"w$�Ej+uV[ܼqh"<Cr{2y$pySFN$]B=FHMtT{n_DUΆ]Ӈ$<[٣zUN4}P0ҹ7m^>M4kq~\1q nvNz/E3+ju7ܿmq*SȲ6.4ehy���Fj+] m?EZ)_@GqvJsD5 ZU����TsR?a;J 7I{|ȭCX:[7V ���N(dSeSQvVq4@ C_v#a5S $j ZϮ︘/r9 ���ЊRF�ݕI> +6/=?E35xp0}nsz/J=X:f3ê;1G3y)sL턕��� B)^ͣQ>')i!tNsxײ5Zm!raO_npe */Ř<!u;U%cTC-,���Q$ɉg)S|Ϋ􇾌q#FHtr$BTgDBtaOo+LQK2h���Ll&)$x-IJXᲐZNkh3#F,ȓ~+'5FzCԫI ŒL�s[X���xkclۧmG@w#?|homZ;lmwD):jir鹝4Hõh��� ֖tH%7sfZGҋCiφh, ���o҇CiǂDQk;;=kɜ)]G73%���=5Q}T *`&eyX<˦AΨx ��7~n{p)mc@y5 +YÒu I uR��in-'e!c$q'UΠA���pYۧm$F@AYrANmn ���er#O 9?@_??fG$_8Պ5_ gYXv��غʷ/ۧmLF@z$ Y\ R$gA���uX}G5cΙAeέA8D5sE lzy��&O[3 \ L(dwǙ47cerxQӇ u331 A'#}6x,7 +^do`uRHHDqni´<nC&l]ۗа���t>͗>cqdwcr'#gRvȰ6z͘0qs:[BvR)FYnj6on:lqn]<J\\<{+ mt!kpu^VofNmlch޴ +`}pSx’l\!UK2$Y\q1ppvR W}$_5o>ٽ? }��]*=2bpP G5HJhGhc l$~VٛUŚ`XVڵFVu@&|{SAD%~D^O^G5_6D>DuaD?2n(wp:heur k6siZ'l.OK_ne]eOn3i=͚41u88"h|us7XxeFZxjȍ9k<?&j$)Cy&%\aE\rzy97)OIQ\ZkV6|OnctWVtJ)Ok<Tn0>Eߜ0 vCY#��@ QȽ}(qc024(%DN:'Á/\Ec{lO}f{;UF9щDǚ8ǝ|Ns<Se$:[?7Z*+J´j ?TxPx:TƝukٶTS,s7S:'4T{=tZԲvİ{) vS2իs>��V'Ĺ*d7> ѱo3TĬAEg΃<8?!c'x!VUA)r Wo"J#"" g ɛ D0 [ A۵:]qˈm^٭ug7>?Z�ꦯToHbDđC>)ҪLЊw!n �>�{|{һR x~g>[Ysx^xhw)&!Z}mgZD#b:Rv1 G4HV(inY.,v$%w뽸# Jrh۳XKݍ{xvY-#eT$ cBCl Xt?!,EÅ*1 G5b9 Ifv[~PoQzWɍ]K(:5ygˠ|?m p~B *^時|[$}7C C+TR gz*?>��/K\'vHzZ!z<bS#2q$EQo7*`5djr*Y{[{iw<4 >_p,b"`:@!db4"PZ @L? S q[8lH6<^]߶QQK=z(>}痬VVtB+"2G+.@L?cl,DC5ȃ 7Tr*Yh\&;7tѬ63UBE\]Z@LI! -ִ߽8\cU} +^oɌ#_�l6ݯBLR` &ߍ rlj{Iiuq=@uCꂿR{zD)oSҢi UB|~bm+5kNPo\"rZ97{zسWD G'ŢB\$455 Jz틟~��<ɝavGSajUo(+eD%a|-BWBA @LAFZF5Hs,[nj)x}E4$Z%,57&$xܶn0a +p,-~!z%|@LA&9soW3'fCfrWCp`6Mtf0#Aj[V.t;EBS$q"1 ^"-Q'M\ oUgJo.yQܦfsgu$0wmR2-/,)&4Ȯݖ;{EN0g6XX*!1Hyf$!A! RN%@^|esv=<ڬK1Җ7}vO Ji</+NΏ ?bС{,+`ła0e>8tBȤ5Bzi=b٤f'�t{�j�/pC<vuWu^(?'WkP*Iw4/?+^!,+%r +t0=yZ ]3K.p,bjLh-7 vZn޿aꝍΫm`BGp3MM #`JFc쏶xg$ɡ@J7&'}�� �nE[BK(V;bų|G.yYń2][_UXIuC;Bw;)T<ku)ꬺy¦ +~)zӦWw +IA)jnO#H3$IJ.]}viJԉ9qG칁6Ti~`&. ͚9FZҒW>BhF/,@Laz25QO57ߋ8@гw���z?ch<>wAkطZhvugiTt\]p_ExVu*p_xQ^c잿7=mՔ9yŒEz??6g͇'׵Lv1G9M_  fb0OPzcGp>b+@n�TCK(VATtu{Y]&WnBw +jibwɨN ۿae̜8  +B#2>Ogt7- jAՇSp@@~ŜF+ɭPHV& ++IkJTSJIJFRt6dfH:3he7{\;QgӞsxv>cy3>�)[^լ/r[ K\h}:js+/eΥǯ>49``:4=z�T(َi(SsuewJ(Y)v<Zh֮/vТnU%U +!4 +VRp1!$A>=FhjgG@ O_ip/1�P}Q:Q//ot]D#}"'癭eytF|q1NΔŖa(y-lՓh[Άb bh|ncwEw$s<bހݶ1<,MNp;kX9%ᇧyPw\̌AS]]c AF)1p8L`(3B6|.n+(~>:܈Us>>t[n03'l͛AJCflGib b9 J.HN(ʰ + :}yuqsY>yKsSWӃM<]qr<֖XDO56 d;]5DP<C7CpwE5AeJ7Mz$I5>|Oqwj،r^ƹؘE1BݰtXѠJ{|"_&ەmI7Q&?YB)u4` Eя5V� #1BMO"Z%nE&cuQv1F|mBH![a=vlV*Q 36Q*2 +e< fGN(n^9T't4hut$^Sqw|qeaVùc{y@qXYX10 yh3'`*ygvDPlRA<杺]PE- U<kTWɊKIpX0,M$uQ]*f6N9ML 6ӥyyklۯ K +t04Y2_hi**(a>>ZNۈ(A~6HGg?YpI$*0>dSe't5 hE?QXZ& 1eg֝Tp*3R.eFOKU1'>QVgN;tЀMΝڇ=Ix9:Q\Vuݼr6X1|e0& tF6h B!ښ0r0>Ǝԁ @o �_NЗ=ҝ'ʞSi0gIgLsX8YXׂ N1 @ +*•"mIT{(~n2;P@@rhen%~T^zQp˚}{je־�â˼Ww4vǼrK6St5VװUE٬¬i %őe &b(<szs~©yNe<aG);ҬؘE1ң~z4r3LτNM MPIsI$q,:3 99&969<z9s+JNt-NM%ᥟ (L -eDI"?wi#Y)e3*W7JE3A}nޣN={';nT`(sl\6[tKEQ[P<9e�Uރ� 1UhGAgxʃ<##RKzl_խ2O:oot-P@-<[wJmh=ZT8,yCHƨ^at c Ny{q.Alޣ+1N'MABKGL;)$H \ysu;9߁&_灦k$v"bZn83֮1"Sb</mF>+;)oΰs_YH+vSLR!x7u,#y4d;]~: cԥ}9Z�\ h >I 3i>^��nZ_j7ܳ Q*?KH7 B6(*"oȎ�Q*?Q)<M yz8Gjb%mLg㭛hY, + +Rn2ss7AAnZu:QP,mlNo2PPyI^@O��}lf-q9k4Na]t'k9YM3fDyk Wj-+>C�@<<Se6LK[d36m|-`ƒ?w3fElNX}w��ݽ ͆+S릾9YtUG9ȑNz!!=GmMxU4HJ忥��olQn1?ZiljGvLxy\{oG:֪TG忧��nܖb)1?ZgH]WuܩD_t,5὘?i_A��P/O<h(54L+j 3ӂD=4==G ko/快��w',yezԺ +Ґgw}u?6|s2wsxΚV��гIYSʴ̴:?yE\/=o^��KGRjuSLʵy;u?Ϛs8PL(Ή{gz+cp6v lŹA��Pxp*ط֢Vf54m a&̦1..kvLxy\9+sOM .Хllk(>xC-��;#Vl;`j7'zSN[f޿m! �*5䜋fo?f6Ňmt tЈx^?~|Шj4l[��TgͿr `jF$IPSdl-Ɋ?m? ,JA+�`\*?l?81xhҬ4��:f_,L7`2$~2An:ELo/��Õla&3d>H +^tC4��ʨu m?L?ГI_ rPFC�� 76}6qiz㖼6�Uc6 ʏi\ez}b��3Ec4O,eE\8ZK��0r8Ɋ$n1dX6N4Ū4��KaWx*0d\hR��Ȫī?<#&L0F?>J Gi��GoW,O '/dL<}hr �Q^43=bhIW; �LEAݥ?L?} oK,A��8ͥ??<VfFfl e4��zٜ>qo&</}[]Et.Q �w]G+G[K0F` xh;E4��w{#~g& *ޥ;u&�g?7p7?L?0x^KK��l^!+d&+zx< �@ݫu{[Wo+dsrWȦA�� +f;R]?L?0Xrb~.ޭ4De ��æU 7~S& &)q[ + �@<l 6n8)dpp;wSd �o 2[`2P̋xϾiQ�k b踣iJPĻv(��ٿ|^b5sP4CwvTxv��}?L?0Bgwnsf��ѝ e:?L?⽻׼!To<��js6`nLPJ.7Oshy��ԤՖ\YV`vL4Jڨ3O[B�-qK4J7)L@O(�@ Td4%8%d ' -V*�@iM%gsb`2٬OY J�PR5.KVNLP }|д]o?��Jj/EY9n$d5 q2{4)�@ -+ +3V9#d7) M+}��j,:n#d5 ŔBW-P��0j̆)Kw`2ZjJ�� mn<M?L?f)9J��b?q&hNۋ2t5ȊJ��l -?L?] $(Oeރ8?7Xl5rKa:"ުP3Y4Լe%hxc<9\.zYɶ Nj{<V(;y#>7Rt/��Ж}8_DKaU4m9y~o  ��MҜHG?+Q6HD N*#��xܲg6cCG?\'˚6Hu`=�T4yڷ)G?+R6fˁY ]�RyLODKaU)djeܪz}�pjUcDKayۿÍ?& ��չNMom8A1}GHɛGg1}Wl:5)^N eT0Pto��(I6e]d,޺apl96O>٣gc@ mHe(}s��aէ>㮼"C= !CgcSEK +eb }E��]٫g8qfflhIKk%��~YGz+okf7qtYj7}:to]t��{\/WyrUhQ/waWZ;hAvd*, Esw ��ur۬ߒIw{A#=<Z.d۷Na@^X(M5uUŢ�ֺy4Wy=xNc(|Tm8ۭs.lNJV[t��LT3l>cNin٥=doĤ.2dRű?R + qyf'+< FK S*, !;�vjc6Sɔw8c ʐ ӷUq~+m5ӥRT[_g)��<ȝ/{Ne;A-];uQc<ϟ[9:|^�~n^D6}1qwe^6&EG}Im -~[ #B6��Z5,/= ΘbcV(^^$ǥc͢�x""o<0RHR7M7g~�\gAc񤺿DKa#'f+,Z}�/]:n5 Z +r|t�/U Z +ѢWe.{��oT$Z3b-sP_!js5��8+J<P-R|#eWE%��N[SnSwh)tdK3ٍ!o��PO=Ph)tdac$U_Ti1Ԙw��fSVA:BlSEw��Ֆ#s] Z +%-1&g7T0nnhY�Ң.œ)R(+_:h՗*p6p87fi�К +fytuO?�y//GqGX;<jl"WǤ6E|gdSj}BDKa�x#Cכ[d1~ܐ*eaUn�pe6Šq Z + +\#6OlWݿnVO=S|Qnm#շA饓y)Q/&[bJb�@gC-CA0ljîGds}E_s.N�WD?�%PwcM6_y4Wt3˚ּ?B>}N}KDKa�hk.mS>QnMmge�gܼ?f'뫾?� FKɛ˦\}q=<�8y#h'7A4""-j;'?H"Y]ڼ?wWNR�ڛҦ*|ɾ�19nI7d-@)MkR}�<eoĆwVKR�DnKw!iS?�R.3C}+DKa�±z-š|�� BCr Gn +qSIR�]+KdӷӅA]D�]մ3Ϻ>?�L&%[W~1U{��ˏEcz+2o#h)�3lZlſ �=(.{v{"h)�%^,Ưlz~�@[U8Xy{!h)�l=ʝ~b֬i?}q�QDM$Si$ +5U'DL(n!-( + RT ݳg ^ЪiM%MF++Gǎ9l}f>/v3�Vaj?{] z +n.-NhyƳG�=ܮ5V| AS�<o~?K]>SX=;�ZSujiA�OܒqRb^M3+^�r:2b>S�<_?ĩX+9O3�@[Q]di{A�O5r<!PwͲ/�Q}W2ahA�Oohic^Zc 7r'�a]Cv)�/ݳnpbzf.o�x_3G= z +^v/W:k}S�%82 +L z +-bmj],I.q'�.;,ȱkA�=kr|Bo +�hUl7fj;A�zu4X`.w*ֆy!o �xSE;2} z +?JZwL7C}�OuS7hAmW,˕ޢo �pX^q=c=x9zZhyO.,�3Uv/)�oI+䭡j88O�.S�: [,)YjE77�m拫ۦh;AjpTR-;ƛ5Q+!o�fmN)�Y�)ʴmu"ΫfqΖڮbOo4Iaz�äww+_:m*|Go�Sb$;!@Q2gS֖\d�@<Rr~VډVN �\6K݂jA=wŮ{X)e�@u .}hlS6V.�<oFC 9!^%{/z�pFoȓO)y^M@2kSvkw**W�1R=3#W2+>_;Wk6B9g�<_SWsi>qwLݶ#ǧUes+A�mc9>rCnV"N?cvwFW + PcIIwWʲ�ӋFKqjgU$"^??'F>i[ݻvvgL( I-#;/V?ϹʽZh.NKti)+{�/N];DR̗n!fcdQ-oko2NcwЉ^dA4}ь.ȽsUѿ�)ވS Q2lDfg;䝛,0s;A)>'9y{6) ߲?�<0HZ^vdg/�<=> X7[7))sJ[ �ڟWe.o}�L_dCׄy4iz�nȪRVԩX"&ge�x8^d/GOj1?�m?RZvʢ�1hYp~a=�mkO+eJ}O|D4�<w~d#ǶS�^~OYhr4k㭚 o�щCԛoAPNa=�G[R99Xi�V /S�оoYDM>Wfmo�j^S6S�- JnC:�횅KW z +�:Fwpi)1sڳX,>S4傫`=�kܦ6 r>o�FO5w`=�o`8)ɑ?l7' 7$)W z +�>\ZdSWسUG�sXl!W S� V`1C>Yn8X @kG6ZrW= z +�{1R==Nke$U[X^h#DOa�{5Kyb;d3]8-q.$;S +eW z +�KY޹کXo4TMc)JL*Ju ?�Yk)NIX"e@:YD#cN`=�/Bb-/@/}q�$$j:MVmj%j"FTj^ B* +{aρIa/!1T 2mIc'^uS`qykb?�&\i=Rlmg$�ߡ24`sA�xRJ5[ߕ�<\ JG~3A�t3rWm-Bk^?} ó_)94w?�e(p%7.a +ߛ�<zҼʶ9RHa�@Q*֩xw'�%.$Yk<)�"sjl;Rl旻O�~8K6Ѻu1R�й!m(]riգ I{W'/ub?�7RJdW_T~ߥ�L郵nA�G=ilןݧ�tK.m_Pm?��c{r*EʑU{{STYкk1R�`<1!RB񆑞{2É�}ʴ[#z۪~Z7 F +�k\梀2z1}Dw,�ڪS7'i2)�0(eeoDZ�vp1iSZw F +�GlȔ1%>s4Y|?M},lC| ?�ct|?iR!W~*s7XhF?�o|YV>3ҩյl Qort|?e#�]O҂Wjedjtem^S3}nA�t]#RfZ+MZcp ScCVO׼U1R�е-+'צje.t5z&Eh))�jVʶ\SЕ\7Eyb?��&\iMsL{|0gjyb?��w-mw7[UE|7aZ8Z.Ha��Lۺj\/Z/gb8 ѼG1R��=H~W*,h9p= 0MqSde[d#�'FJl#wűj\;[#ZA�#&gkl=[.Zǖ'y?��tIR^nK.mWyVUԻ=1R�AɦPu4hX"w)czw F +�CmR\wzo@gw[*,A�&mv*P#W>*Ψ!YTiջ51R�#6DJ0Ӈr@gڰz{eqޝ?77IZT%t?�0f;ˬ'e{ە`}LNWo9i6xkb&Gxn[n΂ӣGMۘRҜ=>��<,/$ArmP+~)W{򚲝-z ޘgW ϱ?��SR)}K(+>{CvG_eLӻ+d<ao �(^7Qa=&�oyUz 0bWюHնChR뉴K�Gϒ{rC%蠲t#AS밞RF֜dI䱿v~>V!}�xnjHX+/6(%ߤ zٵyzw #~~r;t'ϛc͙$zk�qvOIQ}W];=Rt~r~}taGQCnp:lg{&5g$!�cTGb\]�oR,-֜ z :-͝7?SUbv;5noonQ5c峬ww�xmu}~Ҽ9HxDSll +UC_Ԟ ޖO>) y_>�tCVOvUX\}ȂSR'/-۝޽=A- w  Rq?__ϱ?��Z8ZZcύVC_=%2~w+)_nKY;th?-=UwܔwLJ��9)F5˶˦ y;fgnA5ݻu6%Xm/is[*E߹g��o0hNjv$!<I|'Stݑ2P>Ha��EϸR5g^:_< D똩iZ'8inLtj\RQ/"E,k>n pY=sYH+X㒨H@&vF#=j}3swC9o3~ݷ 2�4/zKrT}5aYKw�>^ٗb;#V'@S0]K~{`��x6?%<ysH[Q4 c|Ž)�,r|yo}hLgW7ё!)�@sEc7Vٚ])SF1\t dkD?��ͅOеŮKewGq]?bjD?��͈AmғZͿrGڳ\=ͳ?La��*QioK7%:#fZ;~c{g��4W6_vxc<].t%qv. <fvǻu)�@s7hÇjk5uœŞ_4퍳?La��dLeSj2M*ؖè+Ǽۮ󇻽o)�,mʇ־kUzՋwKA>b r{"S��_WRZb5?|;~ sl8Cwz|4�@F]So3߸93>3r"dFUY3�@fx.GwT׫KtW]yXqqD?��bcڍŏ9s:bQzD?��-�;{t_Y,0._~ju"S�d%]rtǕ|q6' tnD?��-MI+ 'dRhu"S�üAJD1x*#$e.:|^D?��-ԋULAtEsؑ?#QS)�@KR8eo=НW,` 8tWF!e��-O KR&֖/hu"*=n}?La��_"ttDwSȯ,-\dj:d��^X8Zّ|o?2E|GJR6&D?��>A~JHVSx| +9&^Z<{d��vg NWDwUȧ|e}Vw 2�gCG*i-_|g<])WW8vOA)��̍s<].S[Fxo Qs?La��R3So獺7EwW4U-Nnuw"S��<gBF(]1y0/i;,<][V7 2�*&Ww\/p.Guc<Vս?La��[=˞wN?N|Ebڹ1^3)��O#g{fh=l5=nAd +�ǽ˺k.^-<<Tc��_Lή[kÜ'sݰ?juW"S��4++=St +cLE cŝnAd +�1igxlrT}l'/mc%)��kNCwU/'s~{gkp[;b��iD$enO B^xaC6imuC"S��< +pԥ^4t;&fn?La��H8lVnM(Co>-veݰ?La��d)ֿi`q+k@Z:fD?��㝭m3SsyV}aϊx3Wf6VD?��E贸[ )wb<9w4];a��@,ok5EIY!t9x印?﫯+ꞝǵ#3qqa3f ��0dzz!w +'ݍ i0 ?`Oy*3 ၳ*iG[ݱ|+Vc��-x[ْ|oG;2p矫k __ZG~pOg~��x|1__VxOF폊9A7 ?3"גO��4`LLk5wOh|uKun{PT/j}Ԙ&M#(ZuT�DPU\dq{At 첰{Q@QWmbigNfg!]]ػQîxg;wng.; O43HgY .L$ +-48[-T53"B�8'k7:.ўMՠ@A':ga|pOu3j&Jm` D '$׊+bDPy  BEژIkQa5i'/=;Κ :Lp +Ceڿ7Ay}xkwk}QrVkhXlUugcEl_F ]Ӥ״=닄mS\!k5luJ2{;  Ho6Wl?gw<<:y15JiyoAj2i?0|-Z͆%G3v2:Ξo)  2ZK3xSw(Ʒg?aWt _ ZP6  +ꑧ_?u?AeD&y|iٍ3IԈ>U +J!ag[WG<SL?*\_Aysyzp{΢83ۺkbNȶ?0|50HgMvU<e!j  ཌDURj6v}=#KqeoB<mo` (y8yhlXWw1(9=uڬ04e#z+0V'5Xȯʺ!<ઊ)%oеJ2ǻIɛ* M&̣hеԢ ='v\$N@A= Kemv[kVf/RY>A0NK=FE}"KcW)(sZ͆_zFFBO1&uFIQ<|V{i;k B̍u@wl5h<cU"xb<+ǘ{"]v\{%aT 8dMo`-Ҽ4UIe%o3^}nn_0Ad(5բ_ : V]:m?` (G&/i@Nس\|?d<ˁG�_A1ڑ $NYo,|yQrsVLvڵX|$yk=O]־6ԏ}_QhU3h2wyjQ8 LM_M)e SY}͢k1J`ڲŠAO/E>΍>;j sοo +MU lFrolַopBolƻH~iv̀睓ۣ>V9Kpzyg>ɏ~VYl'ZZ t_fiJ56Aę@NWUG8.Tw𽯹Zt2IZ}D1b "km|fUeM�F^},w)11m+D>?d_ġ(MM&2[}Di^(ϑ+4KSA;{#:ɬZ D_•5 {8|]'B7+lb|DQ?'sƁ?A>Yr3Fi:ǜ9|u7#g- ]rC1b iU=fw@,Mq.?W?)Jhqlַ Lɮy#GN`rA;?/e<zOl+ܭ]L)k]Y놹ݖ'&wr_k=d?AwLL]Nlup?tX}sl.MSm` ^8dU 799jVWITrZkĹ[Y �gە2EH߭?6MUϹCV0EBޕZ^4?V񣺯  lY©+-{_x_ɜc4 +Wyt.۾L eˏuOJkZmp\3]`Nv] =ֈR%KI;y5?jn_[A|SY*@WvzhYBPVv,‘C xmC|aΩ'_Xu +lc0/ {S}XUY_ġL&w\3ru\4/z$0n;fObwSu@NO~_zB~3;;/4KO2v`p0x m2ڵ Ys*6mPDl`:^L1`C!՟ӪzZY⨙$YνٷԢpGNhR6__{| 29Q}+i&xŸVk"}'O[*A HOl ,wt?jr'_AQ\yoЬYZhv7&Q]`Ȃ׀08 r (p003C0ӣ"z-hVcS[2&v=t~U*ޯ{ _1ۛr =r"]a5 Wo'KҖf Jy jT&Or4y)?P]*y{71`w2 ա/: X_d+*g{bPsEp 5Vp *O9Ae{&N^CAFf3Ipou\Xթ 16 +qIgKڌ6iת҄ 5*,3 UeM_Ǵ;rS[u6h/I9s8X"󩺊�0m[߁615ƛ�?r2ܕ\{+_:?gEZ\:rJssxGg8%β?F] 2M(׺+[Ō-.;٠S.5NvCPy$=MowX{Kݥ.%ƺV|߬46yDS 20-ULek05i3A{ |+M $7O >AEM q}z:]?K    A0neSot:@x.6.f>~1  1aJ"P +:#5g"bj 5YS@AilHMoh]bq h0ܭ�  x?5jͬf\x>Vp4hO8b +  ўD"�t,h5H;zxB= 1AA4y8 +G*wlAz{CLAAge~b�QmѴ(cs) +zHm۠7 1)C_mIo.g^Pk;Jo +%>k._̟+c)Ayvܥ"A[)kAK@Mq?0?ۊ<H ;Fa_ 3ɳByuQByϜc _OtS e{& + ᧌c6Z#ӄ#Oyp`)Gy M~%(?N.y&UzE]Ag܏(3@S댢V,wv~op:_b +g+(_XTB}Lʞ7 ✸EIYM?ajv6ExpG.GZ}-ڃXup&}o71Z&VT1ʪ!OuTp5i3`Gh:Ԏj>ߦn�Bin.8JoZirY~t~ScE}�2O.\{:LW-k8#XUpƳsb2uL !O+s㏏Ϛ Zěh!u6+} hx4`&{?=ʃHЖxNC8K־ƛ2_&п=AʗEn:YyޏΞS8�ZЩʶ{@m/kjf?: 5a;r߃Ʀ@Əlm~r3\c?;chcQXh5;sMyT8�֨訓noUI u7,q<Yo$'5*ޅgy&UF|֋0H7TkAJKk3?WhZw/P;U)o;KbO7l mz?Q9j?4V$MҖ=?gڲ06Xِ5/Z�ݔ6虳"oAy9ܽ(25d"w6~8M~=D!p6.YSɊ@g-mh1@w VlFSanrb}J֕E19k :t.7^~\S(Upnڜ�?5+n*;Շ:&~kp3Bj wkqyg ? 5͎WQgr8z*^BA +bjboBko\v\;Wd$/ g/`)̑ hm+y $]1[qq&_噚RAOsm( a6_ҍr.- wK}81K|:M^ڜPtIgz?u<giޔaO{7:*[iR)-Ippw #'Uo!ϲɽNl\&wy*i 1Pϯ9 +Ys(;ULcکnJ8X?7ڬǀq;Mq O 9"5ܲσ6?ۊ<.ݷ0/sB4ԄG2xWƊ.IvhJL4qah0&+`0ZryAрCƙiBGx$x+(ڪJUo!3c7|U*{E>(?9flqm'PSNʢ;~{wc^-_ ?If,uYw5k2X��� pbU +WŇ|,O[G<?MKgXmzuL~PKsP-LB0 10G(5aս[C Ws]k-(NL`OZ-(.{xmw<2|Hrs}ԗ wm'(l؟~??܍mk~yۨ1Wo"9, +1[]ǖXZ��}зuyfQb6\>_4hjhTkAV|&[^J^s-rʢDery?]HPRL>R' +I[_WWASer46z<Ϭb��~&g-Gƭ1]W%{m% )ۥT㺶;kF9"ᕟ@5? 퐸?{.-#'qa7oGw5C;E\}+y7'mb32O Xu3I7򶑉#&w<w��@0,~]w gˏڗLc1wDMExkwT>}GVc;d((?^Ox2NzIӭft?LcvZ~2NKTn NN:(Gu|DWG`PS@A(ݟ#t%G]zfMFbWTm}rkݞwh ,J>.vu7���gIE(7z>'¾3Xs j/ǀة]Ϭ^ڕ2ntY2j|Ÿ[oo6ٌ-˜uk/'A"މ߻^[TixICMMu?Yu~auCuΟr7-f }WTe?E==o?M5p;ݖjy#r<y4GP?<mɗ5tkk_ +ZvǸ\su"���Oߪ;|HnholWAM:7pMX/&w<ӛ3߻?S-,Iz-���18n!E5ʓM+AwE{&WNU|1<a&g5TiRkm}]s"u��� ,M(.9$<x%)=MvUQ8i05���Θԅ\U/:ĺN%'wcpqKݞ%)c7A{o;(R��� ʥKDrª%/t5G$ ,J j?����|Ȣu>sQhgäA+q"<?����'Ep6] +9C;tEz~L%�)����:AøΚYw$p8$w*?QS����-ΏcX;}sڼ J @����z7UX|@]c)����6I jmFtF.qp׊O*/QS����<<,-i%{꣹{����@oeb!yY{Rcn#)����f^}_h3Bno%CTF>4OX m <2.+7}$OL6����3x (l=ZhFqjm[v?ʴ ݼAg&=GSq٢Ք%D/nݯ W]+����5|_Tdzk_ T>ҕMSӑبE}iL<?,Hz �g p�gܝLǓv o\*^MYOɾx󏠀�! +?ؘ<Zޯo_taI YWrBY46?kD6/14{y_% ,? kmfT=VSi^8g3?ׄqyfMCnC5qTE{ ,?:t I04/L?q 7. eaT=h?䗦~po9]̘N4y\iM33pg5<iFtD2{T=<W^/ɴ oSͧF?i72ӵڢ&pӺh Y{ӻ Kx�θ'OuqD/ \s5lV>Nj=Cޙ:Sƅzj*=�rB� *u+PWQiunAQY˲ +TQ/KB )?ttvtmSy6p$3y8O#6){Lkm.TOWFfX@ to0a/ب^؃l `E @̳{`.?V^9̫Hc9)%\i����U!W%޵\ME1Ug#_J* + +| �����Vz!Mk<7&,5 }^B:i�����������������,Gc€a^hL}uMm`\Rv5?V^@ӟ{uNLrjn�ofibS9$5\,pOT kşQV3[z!MP#:֦MƶR^]JbY_[eM ](YG{>o7mfT)b<2t{sQc}{UE)7/^*sC=cfiߦ?y0W +K=rW9Lٮ<u0~\w$$P2WI?j[nB)3wNr +w1ioKYZ۴OƶIXgG &I_w*N>"o{NX*_CQ{lбlrxMC^DDΆ1DkTԇX27 DZE ׮;UX~1B^yg;r 3Wra/oEeNjl{*;Zu+ugض(-Gy#tbzSqQffy1؋@f{{|P1kYg<>j8e a.w*7<ƶGsFp?ێ؍Wfݵ3~ߑpk5]ia&TK`_|RwEFZOk`Lz2r5~GQYsDyj,a k3jl ]Ɗt'wmաh(Np){Lkm.Tԛ1UHcT/ֱY^Hgj d@թ55 A^ayܘ0g$0yGV\@CIkyyF/U\\PcQ@OW7ٸHZo 0y~ü!u]ޟt!1v;;60׾ +l85{r_i0X+kge8Y"/_D|.1yj~]͖'|`�6g_[sa 5 kٮ(ܼIZP5 sw2NL˸S=7A҅9rr&/LzF :U|⹖zD^07? Lޑ(Pzk@w!MPOOq6i7tg669oGr\<z|kxY0~lla.uȮ?g =Rm<+2J<Z"-#^>̯\QTVi/K-WggvWJ +;6莲zjlV-_!Ԑ[x)c/V9K,&,\uJ\ߩ@dŅ89`Wo?YYN'e> t&WVW3Tw55'C-Dz[Ώ#CO95=ge8޼9$T|FMi_"kϝ ruvftVWO~_qL5_e̞&iL}IQc'to='N}jජ%sObｘc"K=̙5QhΪ{c~=zxxq]N5uvtPciNPO;XU\>sW?rJ'INGm̄Xgkx}za 5{%yE}=o tj0Ki幹^t7{&)89s,b#:5oӏJ/,|鮲U2՝/ jd$`a[/ .:CZ:fw2CmV@WrXDP0zWԃ~}KIEA/=ӝRy{2rr<sSR%炅ڽ?15{(Q{ ;&tZ z2U-^21om@ Q9탊ʊ>f&՗b\:jGzNk25=1aᬯL8_'uJֹH>ƷGݪRXOi= Q ]f25���������������������������������������������������������/{pH���� ko������������������������������������������������������������������������������������������������~ endstream endobj 19 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 34117/Name/X/SMask 266 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hku[P*:"$s4+*ISe6-ȚYԭ=M)Q.zzQ/=<8sro}v v}�����������������������������������������������������������������������������������������������������������������������������������������������������������������_'%m[6<ۡ}-/Z\u_��@\139=M^'ڰn\g��ɱζ7mu/��@V,|dwԍ{bذ;��bռi\N39|0ENukʲn��{-kޚgo)!{ʺ?�� GZƩk}}ݻϯ36��jג挻y~OmIesｑ#F$KKfMJ'NRJ)RUZA(:wl}97<nKg9_J)R*J6Eêq<uy~њ~ߛ5*)sI*nv=(wܳr9}- SoЛ3}mlxDw\uu3sm\u\^4p)l_#T?X?#?ohymamY s?Z{<K{;. 1/y˞ݝnmnbYqipsǥATYqipsǥATұfN-pKåܳ}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈y�}g�׈IagMʺ��!<zUeֽ��p>hdz�Ĥ0i=2�bRí;\��p.yNNuK��!<y˔\[Oɺ'��Β?Iy^ W6uO��% �ܮu5b!��@Ӯz?��&� l1?��&� l1?��&bcg#2h �3bR,x:[6th�Z2Xs |c��*`syܶ⫽{>خ��(?Ʌ{|Ɣ[3��R1y>rhƚl �3br1\xI?ǎ=�?' 2�by��}<�y � lv׈�6Q^Vm\[<w̞~Ght +*o.{ +ppppz\O?9999>ǁ]/�ϾFL3�@k<�;FL3�@k<�;`Wg}o3�@k cFJ5_��}`ƚm+vxS��z}>8~RQb0bbIN2\d@I!r Z@l69 H6 N)[ZJ" l\ !l^|?3d\f_<!}zҡk72E?���ku~ @ 5��x^C,I_;<f{�� Xe4G繴3c��@|y zӧ܎Ąo���5Ģ I]K&=6N +'r9t#/{nv}c%=gE> ��y_ɚvq]{jUX6���+摑#%^o3^Wp G:;K��`@%{uHӮ^���NΦ?/ĉHa̘#p3���DVphYM/J���e?zx!YGQR���^Ud:q���Z6E?jgu}���p*GA-;vh+��[d;��bGFUv]*)Z)z'���wE?+%]3^W���pW? Yu5;��)U+z-���|? ;2^}@^���֪B@=㡬_)RN^���<Ȣg<9ɥ��@s,z^|U���? bDƉ^ ���]OȢw<M?$z7���tJ@4%7Tkzѻ��@Qu:YcMNoHn��� ?4rw.z7���(JPnE_ƺƱ)IE��`zv,Y{Wgg��Hx0+M 5²Y~���fסkȢ0wԶjs��0;Y,"GlqP>�� KL? He8xjr��L{?L@*cFˡoo��j?gQZtʺM���f5GSH%RSЪy:E��`Vi3gJ)YԵw��0sHXu,w,u���qVTesrrƋ��2H? cxE~WW'��m[IaL=��hV(2?vԵ��䌧? cEG>*zU���)! Sw, w��03d9Gi^~[���fS@aLVy&zW���=Lm_u]��]VLe%Gפ͜%z]���S*,$}Q])��0r7D4{/<^S z_���3z:B@&GQ}��o?^I@&GpnPn��LvL%E9#~ӟ^��4NMA]E@Cו��̢u?9{cL���fѪϝ~B <3=Uiwԫ-묽KS&{`I;m}$��� < 5¥\=ӳVL<=Utשxr[Gt C���̫G}cO> IJW/ܰz!}EG0/���E yxEc5e?]kLT4|{h,oWcoSWY1ʲlc)`j-y=4 c<uԼNړ)S���:'.CUuZ6F:?0qݰؘ;7, Me9ZiWVs3{uh.lZoՅBsqs1_v`΅-3WZ-2>Ȓ!F���^ .^[b l4/)J<cvLvCd/,Xɏ��0v]^wĺi&+ugN8_aMdSqsD +.ckGE\X HA@$$B  KxqֽXi=SuüL.yAnxrE;W鞱7] :9wBE1! rr-���<_Jy+,G%ir4Z;+UcGnc]TxəC|7siq1u꜅���CRN*IUST".;;<MZYpesAueɝKC' +wvG{w ��� Z:Û<NU\VH(Jt0B[?ho?GQyDJ~+qftȏ#Mϔff"o"v���TʦxtEźi~:1v V[;JMrX3rW5J~MȨ7���QYQjGl^6'|COO{x2A^BkhI< &qwh!'ˆ\-ǘwb��ejdz}^]MaFZ{޴>GY^V:6I{n丮A.děvz��`mzE�@<;Ai8fġ"%!7/#~mD K3z{}���cCiW?/U$ +̎˺ϨaʹA5%5Lh���ci R?//^)8+5ȃNAPir6^#���wږ ˍY'gEs*eӃɎA@Sgr%yV^%���̜I[}菗s jn +'9Ѯ&<T<޺ ���<z>D�_?^Ab-kD+󤥎lR���O ؝. /"ȋ% AU~/ UD+S(dNv^+���&�vƍG�_?^AՒ$ ?d 'ZieW ���\dp5ӂ$ˠXwOa܏zZeN ���؞ aNN[%�@y$H9zk2_J b���3@@=MLʚhs?zoNN EB�_?|&QRT~T0MTs���S##r胑hO9B-l[bφ0Gb*R|Kũ;*sD5yB@q*٩¼K\aMvgfpA�_?^$JŜJFAʗ]_͗q���D($GpsL 9c׭sL'پ/fR7U˳ e' +ê; WpM9#Zά]r"`/}\fZ5*gCMd{p6dCW; d8 {<<-S4/M�@<RJdٿ6ۯ Guu5 ��ҊcǓYxwQ) @թ7~#ɯ_Ԥm>#ytbƖ+f??~dL385n ]ETH>HM~;k{:hV4͚)R*a $ڃ=;]It V+��r9јanE/0h?bP=ӊ2RªYYtOԫq@݆-g֮li\oǮwU;I78݀܆x5UG4HZ4Ar h +Yu^;��@252~N3'xʹ XiEyԄNTkOboj<8rjGx6gN4ˉ 5OG*R\A�?:fzOe9J w] 3J偺 �*@@V�>x%oO/ZzuK Zejo󦁉[6fwDhnٍ~ơ^!o}蓏,4iFC{暛n‚\CчƷ(tΠ keȚ,T]Ѣתjۙrf_6Qf:\ҥD<<-D +|踱]J/aU2jLK7ԲxPE]ov(VVZo\uQQT r"!I QHH +R@bukk-mdt;{h}f?`|z>Ǩ BǏ Cv�?OZh|?+=-DK\TU[ZtEwCYU!odU\;wpIo6-52uA*,TDԩu%E +>eo/X:|`SSbc_ޓ,uZ>|\&ް6WWh~ΖF OO ϕ1#FZ[Sub"9eOtǡ[}w 9x`:lg>DQ%h VKE=f9|6!~˓>Cdw[ޕ;̩ �ʵ�/M), ?G= +ť:f[D\Q4<A^F=< dېiӠԔ9NotWm}S~s=챴'<� *b�k�<F�W&}-3 |5z8%o/7aeh`aMoaG췵IiTvGeIg"Cv[㈻tAߤpMdUTY)dɵBVVhL1Q#` +5|&tL-aiK\Imֆ9?o +mڬ괢LRc7E/~TjC]r>_,pjMK�.Y_l9oW;5 +q$?AbyVnmh[hE +lA:8>^Cg;G7?i>{&IæU?Lv|�#_ɮ[ + tMZ�fiJm#ϩw<nIU}P<lV->lB_u>})Gƈi}Ƞ>ctE{g.M^[{O6˛49x㜻h]Ü2|,ޟ~YCZ43}~{',_8A +|%iΜέ9eLU@#`p8/TtDEi +g]r�' E]fe'@ 쏁sX|`*j CsEcifu 2?_ (?reK-@ldU<6di'@q$J^;S(ba :<n0U i,_lѬhR+AQ}%y?YUb<o.&g>y HVQ{諮e?h(c8V +*➶Y6Qh8cq{{S}-q0\!x83ad9 2{e?2.ٚ Z(urfKz3q$?(jP:Lz:c6+q O/ /9G%yY[Ra2VsN MZ9Zj)#q$?s?W)& r=:gLrvA@%̌! [U2 RAC]f{p©ߧP}vC҂#AoēI\Ms#\,-R.rw b̘0 ndKŷ<e(#]>LH'EFrInH`P+)ys!]J5AN'} mOr9} E_OLбO|fH`؇JE ӭ3vCdV# WA +eCvBkc*aeh`^�n;/FTԵGpz1H`؏1i>`;KH7J vө.`<\]aw@502{Ɍ>6~3ϩcw"E*VBqF0H`ؗc@2ѭ$K08Wlq({fx%+?U/wܤ7? +f?~BQu2Qw<đ? BXO>i ` +:$78;S}m' +iߔrn駽a[m^+좍`Q(J:Vα#av( ucAMdFi4 7:0c&߸ћuC]IqvMVE9z©m�pEO˼<2q$? P6d9t0 b7ǩc :"́ij^a^*MQo`ڛv/{l5; /w?+<8q$?ۉ#A6-aNͣn`n3~G՘{w:auaED ")I)]H*馢tRILm޵N%]4ts;2cfŌ.ٿkְq|'Å`P=Bɡf ဗJd҂<RbWSvpC_<U~1(* cyVsoiP{Z H] ? u` pNf87k;M,3;B͎�6oE%Ex2@r8+x%"^wsb/ufO7Hy/x-s ʎxX¼w%&ל=$%xUĹ%.e@i4-'(WY?\u?:<r U!b7uOf߯ g A]mm3PO/Vn¼hRtTy&M+nAxhPD-e{?2B?:\l ;A*ӳs&LcS=O2V020 +!_=hjvaI[4򗎽ԙ=l@Q%=YmFsH R@0*yxeW6OcHg +A>,7;@RP^q zNaD q8w} GĐn@Q}9#7ڪ�B'?EۡFĻKD_,$o:Bg` +xy:;W((o3Z7Ijy)Z2n*s@Q#>;g$:ɗ uQ\Vr*vUt{&R=[{0Й�˾0?-PÒγ$B^hcȄ'̚`7bǙ%3XmQ� ( 4[|?:ܒT+oXWu ɛѢzd UUo26Z ~jfy7Յm[cy,)Z2Tuh P{�EQccq@h 7ȣ=Szc>jTBo54`T#YPO/Vrp~nB'Œ3i +B&,{-άh?xeiAF7EQt,~*ٙÝ?ZA-Gr�@, x6y +͜<7l}ܙIAAzQ%&ڗgԕIAy]A +:7m-^կS`h8LwEQt;(4 +,qI RaYWnE ȶ."Vճ1i$݉0kϙ +-J8 Q~F:!=*87i_ٖff8wUEו~}rrqEXR%~ }14%.e=u:f]f8@m(澔b/?ZA/w/q;G܊7 z>%TY,?: k,뚵k #{jB`܄xkx9;.5 _\+vN$rN3 n=en@/|/4z^:[ƽt~hh Pۊ(JC}ɎsEN{@OqGAp~c0`3fp_@!)(H/+Ь”c֜LW׹an8 } [n^x.Kĥ uGZa7l_ʐtBo Vi}1�WC�(JWێUȽaPνB;~{Z'2논WD܇{5hug+W}q`l8 ̅uˬax`%N8eR,jv.#6KwTifx,άyy-1g=p^O79 ^Ti<e1qfh o(:feJ2}ܙ"vQ,_`G ZyP}z\2yL+>ސL03`2w%&s2]WT)po!{[t5eߜ;2<xm/+-Mc~ ^ ;�NPEQ;~^{U,'K}g,\*Ԓya[dfEϣ;з�~M޿L˥eV61VZ,ʱ_AQRţI4F 6jMbmդLF8h cZQp+7^\J@1QpdLsHʳR4`g3<~}}GZz 5i[.<G}K讜,LmحY(:q¿M{5w>Nm Ues ��fFmuc 桶w}dym=®7sw4HIu>6!$}^#YSrBԉx(oFJzŗ3_]lxzhSи=s bgd k]{ koO-|q5y{I$x$i:��zWu[byV2]?5i苖Ӧw= MY6 ~ß &TyIv=Gr}cf[ +lRCwTzǐSVNUdV.u퉣}Km^o6nkoX}?~]VAKt'.��vk2T}~>~VoWGZin*\ޒ Ig\{gCT4N\8SzQnToh_๸v鬶JljߖaC/ŏp2XzKR$e.�০*̘Y)?FUȽό2mѿڵj`Awڔuָw$IL?�� +QE)2T}~>~?]\m!rM^F]W��U$V2]?5i?O,\)M [Bh+w5s9 �̀++K&mM&~?̠ojk{[<=wז#?$}ko -5榟q��X|=Bś-~6i #Z-bltH*0y<��Tv&Ԕ`ּe .6;S~?ߡ?fR.?[�� Iզ;fhc#(֫k.榥ϙ}C@x;w9s�4e_ؖ`JCE4䧜A��Q KM0%" hώרq�*3h/icL0%@W ~~Ġz`R �<uWL0%@wF}B4ȩuE��7eF]ZU .LI?p/Qf_;]PK��зW}^o249SP(] �@xL14?)) g*i��z_d}"eXLI? cD+A��]EoxxPh %Y 忛�P%4ZS< r<�w�;LI?783ʣKh��z^ͺXw?FQ% r"(o��(x;gxwxT棑4��=\0ٻ=L?8&?[ W+# +h��zQ;و`Joh0Sw6��?u-Ygn]:@S[ r&4�|0soY)izʲϋt:TO��.xS:X)izҊ]*�G]{j}?FH>V/LA��xxm[:gm?F7LBgHA��x8N^3*4eUZȋlݨݖH��n}xCb~SMi!nK �VjfyOm^_g�CWAwLI?3C$wA!r��XƀMsw`J⓹g8k7?&�5=y&J0%@_Zgqڎ}�`پ@~LI?§3w!`;��znmvvLI? ܵ5_'�ZQnLI? ua<��bYtiRAfLI? 꽳K��kq|ul~f彤?F@NWM4sug=��ԡ{I0%Dj27Hr��ȭ>/tXnZ孤?F٨ql/7}��TcleL SX Aژ<{}� J6~I0%5 Idn_AU^_jԴNi&Mhu=)q:XQcE@4Dd"WA/1im\Lj~=0yCT8/g4?��2یGSp7Ě0qT-|[v��lˢ ] z +Hl-ք9l?3��-T5M] z +Jlpkb8> ~Sv��VN,k{pu") { XV��ruU�W? P"r5m9;�PCcA< IKYw{�%]= z +q)pjP��@kȜڸ?n,Hwu )xA)+{j �3i~c=O4@VSV5n) ��Mcv†g\ z +Hlki(}%]�RiLDOaS vp w~Av_��$]״?uuu)x2ߐQ<f1_vg��.Dul|Mw⎙0tcEۣ=߱?3 Mɤ{�q)gl%ޮcwL~a_)õ ywFVSkq==l+)6o��<kiuocwLAQmQ#,}^ ggΉ}d��+o;[>8>ό3?'pZC>6�}xaƃ~cOONVmps qyiuxh7=�Oq>m6A?$24֍Z=d_AfR@~��R eo+'>5itn2zšZćuS㪥<Hv��R foVLxi35 [ο_}|>:=w?g R#]4>�%UΛ 7dԃ>cN~)ӼZ·sӽccE)w~,zT{8mM}deHe_AFjr<�}vkxid ?SfgǭݧE߸GPҖߊ@kxytX\��~V;{Ve .;*Sk[#Cv��0wϭYuL]c1~w\'ow7OHPUZjw ��܆ȣ6cwL9\N4ūg*%qn�99o7v)'!i;~'?sw/��F2 z +OHdϲ5�w8a79 z +͠ͳzfet�jڍG z +QhFe~�@҉KYfmo?@{4@I:b/U-5��\.&Vd$k{AګA^%Qɲ��svi;Aڳ#jN_y��3ib ھb=7db ljL�'y5ھb=nx</j~8ٝ�@-eڮb=PVgPs)46Y/4| �zVf3^&i{A0Blrn,pZw(fi�ЛRzutmO?�-޾76zwhz̐Lq,WoVFg$J�R?IQ?�<6[>~fCm{gWI~w's,WdǍ޹?�<F+SsqR^IU/ ̒�i]2cp] z +lDeqjԋ)|q8lkNG%C�gݲC;jWS�Z-s&Tm Qw:�x.[Ne=5Dw0zéCe:�iM#8y/w))�׊7j]S[d-5폹hQS�B#%,Xel=�1sߺw()�miXxW\PuOJ�.N5)qiNS�ښqJDn"q\<Pqd�wp~sG{o?� ܄U?JmԾ^{�dwٛ1:iKS�dib9VK� KMBo/.[{W?� [c3]=E��~Eyqx`hjeIm5J40"b/Gx+AAX}vȢx` +*GVчC>?3?v灿|.7d=]L,t|;y@w��;K&?Џ?� mN%FU�h- zwڅw#)�'OZhLnyi�@kZ2z|zA�wDŽλrSU]��-FyoԻWA�wyjO]9`�}eA�w:LU�nyzu @?�)6DbR;�ۭjiA�O1D.O3-^�r2*lb>>S�<MСҜk:Km-K �UZc=SX=[qGrl�w�<K:l m߱?�zEۿޚ3Q��ꇃ+)Ju?�xCY;VߣX.mm{7�<1L= z +^b'W8K)D�ݗؙoܭ7S��)ޚڙ={! �hsΤ[mnc=@m[޷D1*;�xS<CDOa�ЫM NRw젌@�<̱-G;} z +u<w{jϝ(J9k�WkA`E=2|&o;7�rȞێXm?�VZ`y(�b=-y2ui1Xԣ%�p>T\Ζb=-KU{|v}s�jtfe$mg?�V RdS*f!HmsZMbMɁھb=- bo=}�mW|đڮbOUzƤ=�!؄NVk|_T m*U,g%i;A=Zr* 3�h~ ޒ2SNRlCv[@ⴚkf{YOm_-~Erv)�S0/O8K"Z=hCW&q +ړ+ݽKW�f|L^-OM@2ogvk|:t-ƊųY�G;rڑ*Ve�ЯwǴhA5.yДUݮݝ�x<CJ;׼T,S]&FOS6-"in{}x>?߱?�yX5;'ORwD)�vwL,3wW߿&SwsJm)�4g"FJkliKά)Oϝ$^??mӣk7ifPWSt Ᵹ2 Ow=K*6l~Vs{#T`O_){�cPiF +=>tz}g7 �}8McL|S{wSfOjx' qﻺr![�bp4|گ*Bg]�xSIOݹ׆>NcwϞ.F#sLG;w|8|Էg/�G�i}ڡKy�\wRo} "9Դ1)aϰ?�[1S^o�;y@&{eyaOH(1&'M}3�x|N2LNRwHČ@ �cPW&{1F z +�G9#e9)!j(J(!9]KF z +�č +3e|m/E4�<cdF7S�^}GZ`t4kͪ9o� ՛܀F z +�ZFץXSrڱҎ97�͊ij_5S�в%*,/#w`g7�t bs#?�FJ YN%Z墏 Ao�vռi{yW z +�ZO0iqCe~U)>nT-\1v?�uY?cUi5_\C=\\Ѯnp?�#%92R硸ͦw>�ĺ|xy!s?�@NaäANR[n:Y# ΥCi|U_?��׆>auǜVs5_�uCiuT}q &D5ډM3:c-PZk"UTjW$APDW \p\`u7K:t츽+Gǩv˟3yÅ7y)�%pzyךdm.Xqs3Ad +�Cר e^*Tj-W]!�Ϲ wk 2�e38Gܪjͤ;ǣ~ofmkwsAd +�O(bƽT@:^X37 2�ީkT2#+q@jXY}@-ʭPh<`��HzЭٚn6I�C봝ˌ"S�^0ZYS}>Kut] U^c `�cZ>U[cf=a{_} S[]9D?�c2B)wGO3M�^fiXent"S�<9ʾu•UoUxKXg�+<cSTYfl~{q\F 2�۫aJVqV Z5Oߣ�ܿ +~y!Fw 2�_J%}<8+w.os)yэ?La�<BӖt+լܪ??!Oh;Z2og+F 2�rU2\\~Ȫ0 +wTYAd +�5LK|o9Th>y8N|6ܶM?La�BR +e{X�͹?&oit"S� ~Ko'e[w-�Yr{L?La�) Lt=߷�~z8D?�nwȵq?ݹ�[},xC?La�@gqRF7פhw/kGQ-�t>]y;^)W헪IЙ5~WcC,�t^Akft[Zk#`@gǠnz0VD?�s`V͊Me] lU~Ƈ)�@7c UlSЙ\9^gx"S�;1,Un|n8S^tWǿ> oAd +�pVXmnlˡ?f\ Ad +�`d-Sm ¥}D3@f7?a 2�'+&)92inLP="�<3BYe+8z`?La��bb3߬kL[z_=�^SjAޗ6@[(c��܏ R[[_H|w:okls[y;)�8TtkKߺ߀[y7)�7NܽS\(5/L|:TgRD?��# zkt[7O^*ͅeYBOw ޜwȌ+wXO;l- �!YhTMW瀎Tٖ[fboMpf[fƼ%S#}FLݸ"Y<}�xTM+|6.%ҝ-nA1{=T8l6�(u +RbLݪ`aޙ/>�owęeJѮuA1)˗po}צϱ?��aپb1}\;8 fN/Y4d͎̖@~ݒ%}�{ѻʆœ=s:�oT9ez%Ɣ;'Q5$-Zsw]$wȆ}=}�hO]k^*Ww=۴ƙD9AG|}N*U{Se9s{lsZ7�??ÿ��<C们M4˹֩A;# ZڠGLvF3=]ޛO-�qyf%ɱciL/wF}7pk֌<wzu>Sov;÷K{~W_2#G;#Ԣ])ww�@>ߖj;_Y6�*4ۅ7dzOcoK~to~ܞ�0U]lpG慙Bw@@ +~iEimh}Gghe΃:0EIu4&:umMՂn%FmĂQqĕރ4J(Qk],KĎ۸WL{x//gμϓ}yQN<=;�@!C@:tM M_oA59ےJ7y_̟NMpu<>�@[i%&.Qg7 o//e^ԬcWִߌ1 �~83 oRA;!];Wr}?La��܅O`em.U:SN fܸ?flyշ 2�p7Ÿ](qد}(ͩpF5 )�;$ֵ['Ylj@sЃǤ͋~{`��NJdֆ90]hj"'\} "S��w7 _o*/MTL`��?lOO6ެ7g@S~D?��EǠvd\X(;zg Z5?La��ZkNhj?GwD?��Qw]k7o3Hړ 2�h-eW\߃Zsȑ]xTb"]:�;3'VkjVŞ D?��2x:t:7e]+]_M+q~v7}?La��dmUf\B^;e_>#[!F D?��]astwLst-D?��2:or6],R|W|^UbMfv"S��&/yH_-ip5 ەa4%;f��ȮߒiJZAVuw+:lvD?��mS!Cjt;7b,0ܬ\g;mv"S�$`ӢERf%{_MɷU-�=QQk9+#¬wP]_Yf8,�- Deocǝ =mSMYB.g>{e��e 簝5z^]m}c6gND?��m݋~JR5]r꿭Zk'8?|sNe�� e8M?k=W!mp{UB~zd��?FPఝ=5]t7*禮4K)�� F+ӷU۳wTH\\nnAd +�1hU]Skf\S!܌ l6G)��\zn;G*S])ud]ٓ<D?��0L[J|^j^~qd3E|g<JٗطL2A)��W>5T˾tf +9jT1f 2�ri;v>2uf&0;)��ӡ#8GJ~VJ1M|EuPSk[?zD?��xt_e?)եە XNֆovo"S��|zX le YY.S?7%e;c��t س}==w`kY urڱٍ?La��4~{fR]CtӦ+D?��h:|8EI-߫ +'}xqLD?��hZO Q[D*cpOeacƅnAd +�1qSdsaw]2q]D?��h>/EMPv83rt-vU"x{Bڛ��ͫS %*k(cT8SOptÆigvC"S��&uZEw_WvF{s{f 2�@1Vܽx{oV,]9A|8_i};˥MAd +�2P Hγ/߃!ƍ7=ODӛa��@ׅ/ȵ9574]-Eoa=#ƚ +��<>ZIK`_M͞$*mND?��⫄kjmYng'hwʧa]BkeŶujvegִ7 ��04nN;-v!~G5_q|�VhYݪu"XZDPd 5 !< !$<& "Ucu/8sڞg #vU&9s;8|1ytW W xUVqR#5奛w<@A` (2+}AL(g W<ђMxySՙg@A3q.o>Ko]'#o\MJ黜?0\1|J"n1h/6 &i2<}ϷVF^?*w"8{`bFzewuhɼ3 S(Օ}`  2)%ȧipVkYߗ +=@!^?c9?AΝqwu䃻𮛑/>dl`D!GŮ%=XV <H芕A  or" 5`”ȫFJ^r?0t|E zAsr|[ N1cT#Ay{xw +QgS'󯡑NIe՝u?0tL~wm8x;^Q0־S~2uڀCnӝŎDɲEAeVfNnQOg󭣑ƣS丷 t WvP|l 7γ|KA>en&䌖aWSw*7變o3OXՍt W FTu_[ʶ&nC  o/,b#W3 kjdhKE)s?0\1l�ݬk<gﶘ&(r|AA~>-K=EwGό bQ\[ꋜ/ WK?$jdV&A> 2:?t픱?Wg\2+.2)r-#?&Iז~2EZt\8Ah[)&+y3MiwKuSپ"cu&oPVU8L\FF yz)l(Y4nhNUȯ:Q) 27 't f4TjW&1$[b"o*#& DA;i9!Ԗ |Zl_`)*ZNZw<)jv,p"?=h8ցw`54) U M~&aaCƪ8%1׋aY#: ~cwC5f�ɛCIFAO3/cuXw'uֶS7o,QA`IIN|n'#?(_P3 +Fߗۯ-[ 䃜Ⱦx +['s~{4y:3G�?cpW2juf;ܡ@-^׊b d'RRJ[Rه ˬBjQ9+m?^Ql/` -45bx%`uy?l=<OOߞ+2)r,f+U-Or@_n6^zfŹQGɲA~UaҘuz{Е1s9$�) eI)Rz'Yqxc<iJWdNCA+ɿ `V)_s#/huHi}D1b$LJc +LuۗX_0*+{OjtgLB|Xoőxn&"}LZKn]\ٰC|67-;[z}ki?^ }%^5V;[UJ]/X<VfNV29e>A E{ex3kf񭻑s?ܯ+_l` wvP\U]o0jI4JOTȭ -;X/IDt=uO02kZ)Ch@z96]Ԣ.9kEsaQ1 =(y,Ȥ1ɯ>AbzBbùFq$ޡM +cy^{psUXoﺗ֫dj=m?hEs <Ao:.0ԽK*FvpzGkk)BKIVjNϹ\jn(+`!U8ͧi4ysAq=삳սOڻ_Ϝc5@u h +W\aKjI4JOTȭ -;X/IPNn~ C[vBR]# =ҦkZT5n+^. ㈊IpAEcE&E/נ4Vݮc[vw݊hEै"Z"@@!N1!$*2ݺzktv~`Ljufx<~Ae^Q <ž%~>r::ur -_B$a}xoYgdg+5yэ{=mR2<k? +IXZ;yȵijJ % CV95W=ۆ x6[9n.g_'DSNvwW?0he?ӀR19fV^ǫ +rzw^OR>'9׺N_+|_@;=[ +ۿw+\"a]ĠGStePkҶoejByxIڦ! 0"F%gߔhÕJ}y / y !ūqMS@?&уIu yt=v:U:̷vDmhg۩K4ya);;i!'(Ah~ݑ\f5qև1=L7t?bP55gS6xbVZrJKzUbT^'! O 6x2Q ˉ APбo?~`)^3WWWk* kol\Q6֬QIsM57Gs%-65О9dX4p PXhs3J񲴭AYSQpr.bӳ#Saidu.wCXthCy:)5փ K~A_R!A\=h[ϿF2}^}A!xUHѕYgP]5fAw[[+|D7#Z@IF x֖\JdkhC׺q}ŁDKMA</hS5ikvvKɴZB*}’!u=wf! 0AdU3ޟ4y^|tr,LN`(^@Ad`0#g-atnq6.4K$ !AAbyDiw$;Ϳf*j% C !AAjy_'e =[ۅB^bB + ìpBi[Yp^wjn}a`{;B + _q enM}!_d~g`)  ,U K?˷X`Sҗ=sB + <+B6]2߹{*S[οhu,~4؄%nS_Rǹ-6k~S|yؐ?~ܙ̟i Q2DAQ�\�1-kĽ#fYRxHm)Ka9nstl%O'2^{Ɔ tei!D'eYY|Ay>& ymӾ1|/ǢA=cB +O> s &Jg'_~_b:Gai+ LHYBT[ +9!7=_cCjy2Sfx?|DK@DmhoA;!4= ~ӏXZ._{2=92]٢Rx(Ig5GiNأa ]$ie374o6Zau.7Gtj:z<^ݮ;%P;aϮ?s%ku/>JZSv<MʗyA*;ZbMtt3W^𹈭۾ *F>ɍ$f|¦ZV 'g4wJgʐG'{solȟƙl#O) 6c;0HW.`:[޵ƛ`& ,( YmyױԟoNMb+9SB +OWeЊ-N֪j<\}e567*u3'FUʋ⎝+~0h^V j.^U85)[@h{XM)SNYyP7p3?c?4= ͔DJ: >+sbTR֋|(5+sLpn-ȩ5�X[&dz.t#R<Z;/) y`Cg't}"8cCp7ez17GG7#֖E7myCA?QnS ㇣29i|:c74](�͚E\?G'>K˓Aw=61tɭ ξ1I \0T ޢ2^ :t.7YnnO,?4(;-^QY7llZݤDK\A(JԈ!AA2" #03= s#uDV~V>;fܦ = ꩢLa<V0n j\H&iJiܔx\˝w{V\{Aw^۱ʵ(y{��:dhMixrZ_k~O ڬe%g @xSxLY䪍̔}cL>TCʸ腮84D{YD׃16 {%Cqby/U>+Y}T`^W?sm<'wQ5s䔏7Xҹ&'wNzv {U��@3koh_(~OŪj?eTtTH )<?b9~ܬ-(}4Vm70nD퓶[^c EǠ%y>5P^W"44;jrg۾:fDY;{>+]`J';L<9D@9R`u{V_렭}Ϸ ߣ1uME>H :,d>?���/1 ,"j΂l6g(9?›'̏z7-X?3H ɔս4+ +sg +;5?1xCuoZMtX˃f^Y̊Ts6ܢP|Go?"tSms5%ǒQ[ !rG43(Yn?{in\B]"M<ZW޷Ц+՛j���^mPs-ƻ7�jr&Qe76(9;›`yE..q ul?.9r G: +ri=BiI:lU!k a[Cʨya<Vg3_jg[j{���^>3R;3N/Ctw5,l,spJ D*bƕڵAߎ\<47zRHb݈mscbCNҖoKco +ݧk-}t7ԝ#HWG['EGGy[ ֺwinl?CsWe��{1I-j %gCZCYw#o +O^ztrRpM<Btn]Ƃ <{H9b^r[9v {nlh?mf=Hf]qB + MчIQ].]Q0[̤ɯN.i;/S?̳,glH{#&++ y ��4iMwJ`?Gm'N?}/PrN7'ǐL^E V՛ŏ6vz9D5H]{T{G5[UktfaPOwjmiow,nՎuڎ m?ֶjyۍoRmOgBaӁůFoՎUWJsԏJ>&y<vC2?RvoK!ZO_~YDrE;���09)U';떩ƪPrF7'cțMu~2_xUֻoX&|c0Tq#^ ���C&+YM57 '6/s6ݵ,2A?#3v {u]iҸO[oj,WWF2W{���<OG6;N{vKt<Bɹ?y Mzm٧N{ vk���z;$2vkx1.VB}Wx +Ur&7EoWޟ���g $ +J]{9R}_jN \q )z����Y}Q乖YS'ot`s )����d|c0E}+?\LoT&{gȟ o +����<0?&Ɛ7[Y诟U~)Nh{ML% )����)h":,S<;v_"tS����'ڎEL-7>ݢ7Qɞo +����zg&)o;wEq_+P_›���2Y`جSu _7����=i)k{ &j{RBǚc����'37kKFkGW@B ¸J@tW}e$å;̷)Sm&1Beަ:w'8)I<`@s?����Y^c瞴u薩qq3X=DNwQB^A=#z]N[_j%6v4����éL3f t_J@tW 0;!ӑK6穏;ƒV>3owGa]i85( β,hY`D'x*HhADx ,xYaqee=J�ɇ&M봓[qҙ~L=Z2+=r<Þy<@<)q&޳E1h#kg{DŽ 6?9Sz z踂Xz$OTsj5@<)U*;Ro/7,:gx9՘z"澐??R4,'c\GScyA?G8/x<~9bUK5l HH9Np3j2?y&c|+l_l1 WH8 ѢT(p?vn@sUk>}&3 FQ3Ce듯H9꟎hս ѐ<g^hp^ts.U6gd:xOuz/ӳ WMݖk1!xK5W&PCW;p'/Us=Ti~^�O6)ޒ&)īlmӠz+f|/! WWԷ+F!*hT,:8gk<u28Q 悅AA+&Ө_ �_1R :m7V*ep'cJ_ ������ǜ(.8o_Dz!K<|J& ]0[u>zrD������9 6%^:4Va/oËJ)����������������������qLSVͷGׯ^Ѥ',0JJvdUO_۞ޒ01̪Xgާʵ'd$.cuʗvf}kZMܙnkdѬ٬lͦKCarinkᱼ8Q\Au.%^:\>IτË^mҖ'2t &-Zx cMvqҘ}98z'Gk\O[kQ }߆#'3inM]Qrx 6W[΅#n*霢V'x^*!Sh ^4(;;>wuX^ ?3'}i}ⳏ?okKzw8ǹCߑ UxHu IqKwlnsLP[M!RFؔIe ?Kssn +߀Wo,e3@;W}UZ<7MݭF cM[C}2Ayo+( +^'y{c#_);8KYL +xyaa=C40)osin_7Ӡu^cax>OOv^czrF9sk3ΔGqnpD+24n2d4L`۫( GTdqP=ʵ6]U +[N~cy + dlVtVsJO'hˋ-cj?Rբ9u45wZ +^g賷{loԕd0K\߃muSpoGSVKSM[ӂ^cy;^|ZMfhp8큟ھ  ]Gvzy=NpKτ7]EY4ٴ7kki޽6GcOܲz.从Nϵ;򃤨 Ǫ7un{NLo`J:˱ &q9NR/-fM $cy@CEx0s\O~&.sۯ\CG1bL:m]cOt &[C}YV-.06xhJc`xzKjxqx,Oכox,t+4trL z0UXt;%͚3wTahv')Y<2^-EY`?"& +WUYJ0ZBT*vD~͏<'r9QΌ2`Όyc^DMbׯ^Na!!,%^-zt45wZ /4 AA5eg OJEQQ8#'KT <BM~o:~rP_ +hQ*Hz?)nɰk8#?͉kx<I[H0<w!*`i +c7^㩓R=sYvC ?A} }~kws,PxoM]OKYxyFǏ%߽C3I+r9 +^Yx}[01. uSU`87ln2L=mְsĵVo+epQ2V7DN6<[ϟvcOk5hJc鼢AשKdEPoB}\m]&kfLzmanZ��D 0\ivQMAѮ@64EB -j2kjҙf,eQԲt/-Fy.Y\8'=3燥mB?:J۟{ٳ}}ͱxT}Sqr4M\9̽-0k~3ԡl5~Ǟ^d~jWULfU r';CZh[;'O7*Ϫof®},ثاn[=#/'~MMu<9{?7r8vITG{ý0c|{wt͉Q,߾is~at ߞWsW$u8!'zPc=~S8u͜X9���������������������������������������������������������������������������������������������������������������������������X~ +0�7 endstream endobj 266 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4137/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnCQOV.eP!!7I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ +%CziH}߇𿯤܇4'}CCR?9cNSv%>9jQ?9d'7'ٯ>x2%v-feJZʔصě)k7+SboVĮ%ެL]KYx2%v-feJZʔصě)kGъX5-UsڒXÁhIb܇$6}hKboVĮ%ެL]KYx2%v-feJZʔصě)kxD#tI,ЖĒ{sʒ1-sڒر7'(sڒX_7ݮ,صě)k7+Sb>|oo'pkOķ47+SboVĮ%ެL]KYx2uA7+\Nu9]sӵ}h_J׾>-kC8}h[H܇];~z'*}iA5mA*5!FRmKڻ}hUsڒX5-UsڒX5-U;$6}hKb܇$6}hKb܇$6p ZX4-EsڒX4-EsڒXÁhIb܇$}hKb܇$}hKb%5sڒX3-5sڒX3%5;vD}hId܇D}hId܇Dp Y2%%sZY2%%;vDv}hId܇Dv}hId܇Dvp Y1%sZY1%sZYÁhGd܇D6}hId܇4%! ;p RGm*؟1~DYdr<o9-TPU~}|H9EywsGȧTӝG RG׋Ґs$ w#ǓdK@;2}Ex>2Іnܰ w#//#/.#/-7#/,w#/ =ٗhmȋBeKq>HE'=0U;:iOo +q荅]AZ㽹?xc›r׋2r{xnje<:13y  zTP+:1cDZˡs3}[ :1ٵk3E{a*fb/~1Yk_btnˣ_cxmI˹èn;$ی3~1#z#4fFa, ? Fؘ)}W@?ܘ10y}ELP_ c@ }McCT4_c&uс~ޱDXMV7/Yz ]R6ӉgS;NEz3=\n3x}546=F+okگۑKC%_>Am5C׸a_v>%?y*տt*ڰͿt)ʠ :0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU_pMKm_s> Ku_}@}}}u)*aIŇ ĤR.;I*`:I*\/;J:l/9J:l?LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSLU_R:0UAkٻKTU/R}?}}Ӂ$ C >D W_nݍG!\V.*[T.eh܇h?LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuSct`B}LU躏с +]1:0U>F*tTuS?Ke_s:MKm_rLU_-`:J:l/9J:l9v忷B9GNCv.<د yv$xC5�"z AټQ}}hCvi cvq ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0USGVERW%R\>@uIC�W%R7ER/[I3nv$/%}3>}hzx ?ϖ]UɰT1MٸT-WЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]Ϭ6R!�Xo%FͶ}\>4 <w>~ڼq>}V!t u u l}lއ�`ֿC~ҰK-W}H$}2sv<~oK>ީڀݟ261e}eGStx69V~Ȓ0~5*~E𿽏G>6?b�O|;jt~} c2@^NwPMnꐚz_ ӯua~9~}L%ʶcW-bm:}L3;v|>r3s%;w|bxn噧 +Y9ǗSG,I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$/�A + endstream endobj 265 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4107/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnIQK@ؒ++8?1XL?~H$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ WHO>{< 龗D+.Cix gqH/9Qއ(lK=˿r}8QOw}pWⓟ+{}H%feJl-ʔZ⛕)7+SbkoV߬L%Y[K|2%feJl-ʔZ⛕)7+SbkG)15C$}hD$}hҼXZ⛕)7+SbkoV߬L%Y[K|2%feJlכ_4tI.~sە%1C$6}h9񊒘]{{sە%>k%feJl-ʔڻ7/> OHϽ"OHfeJl-ʔZ⛕)7+SbkoV<5 +}hּ}h^}hּBZ{}BZ>hW[ }Rּ1Z-y%}hԼ풘]S>KbjMK>KbiއvI,.y%&y%14C$}hмhμؙ];>KbgއvI@IbfއvI.y%13CDfvx #2CDV}hʼmYM"+;<M"#>Iddއ6@Gdcއ6l&y$1CD6vx #21CD&}hļmM";<YM" >Idaއ6 )| އ6 )| =B{};JWã?aJjx}|kJy{C#{ Kt)\JnB$5rz# o/JJ!z __@/FfIfGf Ef CfG 3+#o]/K#o].3k#o]-#o],3)<^uaɿ;2GF{}z.Ϟ`O>RO&ّ3l2B/Z_Wep[EO =gGO].7ݍXpzRíbdgʢǯ8\3[m>27|N-e. ! WL97G$s8*oʜ�N27I;'y:~O6 CpU\ :( љ욢{糿H_.D<#7յn<ְ݃H@H:1z0UsS:1z0Us_qz);ʠ/:=]Km򗼾>`_J*lK~>>ZC5އ0hkax ~lK^_`¦Tt-a_sz);ʠ=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=йу +=й/8]KmלJ:lK^xxxѯ;އ�l|xKT ;z›23xefR)I*`ϤS.e秒cSɱTM T}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}KT~KT~KT~K~3އ hw?>O3Gz"Wp_޺warSwoR!8eC4C4S:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:%OeR65k [+T~+v_u~*9/9?Ku9=+I;{N/<Q;Xrx/9~%vpKcv +_ڭ&ƃМa6ݪhZj6ݦl\*3T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUTUѴԆm!UɰT!-s],AUɰT!MѴm V%BR- >pI_6.y1އ0h}W8/u~U2,anS6.At`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B#vMT;7bIw{q?MO]?mއ�`xpk>Dy y^wI_:x^wI_:>6C�l!{Ui~%KӖ>$I Vk9;{ %Sme2>2~yg?<tyE OM]$̽gw ~_cyqFt~߷_·|or/L>ׄTS>ۻ:gB+,uq{]|ors?|滲fG/e|h˅|<z?a}1>w|<ߧO\ΰ=[3>2~yBVn~.33K$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I*K�q endstream endobj 264 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4206/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnaKBZH<"oM`$H$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$鄶W+SڼOC><{J{; D>6i6C6C6C6C6C=/.gwG|u/.!}Tͧ쯮!]Z⛕)7+SbkoV߬L%Y[K|2%feJl-ʔZ⛕)7+SbkoV߬LmVԼUS<-XUK>JbioV߬L%Y[K|2%feJl-ʔZ⛕)r+LbdއVI߮,yZ%1C$6+JbbއVILyoW+7+SbkoV>y{O'OOo>?'M⛕)7+SbkoV߬L%YZ{jЛ.r9yZ/z)j)y"LC}We>DFkއI?ZRkhEKL*yZ%15C$}h6D$}hҼXUK>JbiEC>JbhއVI *yZ%1"yZ%3C$v}hμh̼U3>Jbf13/t2ߦSlhpN'Y>N#}$DCd<:tn_,Es}P">~`|y?Uhn+Rd2_+Pd1+Ld/_,Hd-,Dd+w_-@d)w߭";}r-Y#kFx_Dq@KDAž݇GBHt!GDo:X|^ +@+i7><NA}x$urKxNebC@K̻wr p=\?=pR>C ~NH 8II8^H1We~H8 z*J72MtO~3z7Me~68_D'5z?Pd~+{g?e~'{ԏ2s�^ǁc~zU}a^V{u!/@/7wzeygG/.#ѮF],sWyT9u2W+7o!sj8?\l2{<'<eό4O&sS�zcŠS_+Ypp)s9h:[S?aЭش %O.t$'Dг +]ytBga+zz==|Z_B`BkTl1/ l+\f+iGB0ۇ^ ,S2.B$ۄ>{xП֠U<@۽k@frg9h7>u˝WnG_ oV{VlA7y#7I1X١y]syп8Cw3nx zl`¦ZjÖ\* z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0UsS:1z0Us?`Rt-A?fTr,a?!�!�q!�[q!�[5_Rj(UNG_xRf&^xPf&;T3TSɱTMSɱTM`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B>F*tc`B~KT҃ +a/S4._ +.h<  h\{#+GC8[TOoR!8"x"߂LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LUT}LU|*;ʰ{*ڰ%=`U?Ku?Ku= +N\{}~4Aw!dq!ӗQ RDa݆! +{lއ(lپ>4!UѴԆm1MٸT-wЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]#vi Ca[C[z?溤!�Ya[Ci V%BR- mݎ忤; Knއgp! c+?b*?f)ʠ:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0UκnS.*eXRj]wq?MO6C�l}\yq}Ÿ<F<Fz!�O߽4qiUx$I?x̜ńےwj6`粌k|~Q<3MՄynr_$̽gw ~_cyk௷_·|_r/L>ׄTS>ۻ:wB+,uq{]|_rs?|滲fG/e|h˅|<z?a}1>w|<ߧO\ΰ=[3>2~yBVn~.33K$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I*�� endstream endobj 5 0 obj <</BaseFont/NQRPKL+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 267 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 267 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 268 0 R/FontName/NQRPKL+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 268 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat;]:3UhDDR^RB*<fP6idAl\""O1 +R+B+[E#Mz&,&M5|☳!Km`XۛANT\gݕAQޫWB  ;N<W`N8>l!Eg◯Yaj~״7h u|AId䃒 BAИtZO~Cb"?-aQ';_W덼NoڧxܫN˛Vx#Rd^%($=yMvboHK6 zsY@dku{0 6{ c1,p, +fIc°p̂K#ۇ9Nz~2|/q.lwMۏ_0I"u0�I19gu}q(Ab@3C 14h,x rH Gܗ2Ϛ#ow 7?eb dЍ62Ů'u@@IqXdA87+j5SW{ g[nzYxjF+@b%ϼ=MГ-uLzUˆ'r&B}-.f}|sgrp4gs c+BUTCu;p1Am$=92r~U["*-22qLy<(tɾ(Bza3%Ug/#9z%IAW/xcP>.1drk>ߴ.!9J70`}'$٤߀;W_n>ゖثGp%E'NW*k;TC;BOo+)z:Xf#˦P 8NtIU[~T4> zƑq +jx5Ja_pY/0K]QƪᐇH( YYiճPn7_}p 7~J#f-+Jm#pF7֛MWnpƛbOn{GXv䫤vd6m$&Xi? uj5?MHJ*36UTפU$prH?PXG!qCVQh%-El(]kTI%m)xUsCR}7 +h ޙx4-8qMvG7Աq;Sc$ݖ5Hxs2lL=`uM'm%;Uq4F%ӗzDy̻cȚʙ#* zGwp3M U.7:-[v(M+Q- -cL(w'%y$eZE^(2)cJ)1T\E +k*;Ҭ%>;mT4(z\S8²¶B$)r-]aiw}S<5�6k endstream endobj 7 0 obj [6 0 R] endobj 269 0 obj <</CreationDate(D:20170110154538Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170110154539Z)/Producer(Adobe PDF library 9.90)/Title(Fig_WAD_TC5)>> endobj xref 0 270 0000000000 65535 f +0000000016 00000 n +0000000144 00000 n +0000058437 00000 n +0000000000 00000 f +0000739016 00000 n +0000173403 00000 n +0000741253 00000 n +0000058494 00000 n +0000058965 00000 n +0000621880 00000 n +0000622544 00000 n +0000173702 00000 n +0000173589 00000 n +0000060600 00000 n +0000095735 00000 n +0000130137 00000 n +0000623135 00000 n +0000657592 00000 n +0000691431 00000 n +0000622610 00000 n +0000059362 00000 n +0000059702 00000 n +0000059768 00000 n +0000060039 00000 n +0000060087 00000 n +0000172662 00000 n +0000168177 00000 n +0000163783 00000 n +0000173473 00000 n +0000173504 00000 n +0000173770 00000 n +0000180173 00000 n +0000181241 00000 n +0000193741 00000 n +0000208074 00000 n +0000209187 00000 n +0000210283 00000 n +0000211616 00000 n +0000212721 00000 n +0000213774 00000 n +0000215246 00000 n +0000216351 00000 n +0000217439 00000 n +0000219106 00000 n +0000221822 00000 n +0000236515 00000 n +0000239927 00000 n +0000241336 00000 n +0000243656 00000 n +0000243813 00000 n +0000243970 00000 n +0000244497 00000 n +0000245221 00000 n +0000245973 00000 n +0000246666 00000 n +0000247335 00000 n +0000248962 00000 n +0000249627 00000 n +0000250544 00000 n +0000250701 00000 n +0000250858 00000 n +0000251486 00000 n +0000251973 00000 n +0000252474 00000 n +0000253177 00000 n +0000253856 00000 n +0000255205 00000 n +0000255362 00000 n +0000257440 00000 n +0000259308 00000 n +0000261434 00000 n +0000264512 00000 n +0000265424 00000 n +0000266373 00000 n +0000267680 00000 n +0000268789 00000 n +0000269868 00000 n +0000271230 00000 n +0000271731 00000 n +0000272798 00000 n +0000273884 00000 n +0000275378 00000 n +0000276460 00000 n +0000277555 00000 n +0000280170 00000 n +0000283465 00000 n +0000285723 00000 n +0000287915 00000 n +0000289083 00000 n +0000289645 00000 n +0000289802 00000 n +0000290041 00000 n +0000290643 00000 n +0000291495 00000 n +0000292225 00000 n +0000292886 00000 n +0000293561 00000 n +0000294415 00000 n +0000294975 00000 n +0000295132 00000 n +0000295660 00000 n +0000295818 00000 n +0000296601 00000 n +0000297006 00000 n +0000297549 00000 n +0000298310 00000 n +0000298989 00000 n +0000299777 00000 n +0000301589 00000 n +0000304551 00000 n +0000307899 00000 n +0000308521 00000 n +0000309726 00000 n +0000310664 00000 n +0000311758 00000 n +0000313000 00000 n +0000314112 00000 n +0000315246 00000 n +0000316562 00000 n +0000317618 00000 n +0000318892 00000 n +0000320218 00000 n +0000320943 00000 n +0000322002 00000 n +0000323389 00000 n +0000326500 00000 n +0000329996 00000 n +0000331481 00000 n +0000333947 00000 n +0000334105 00000 n +0000334263 00000 n +0000334669 00000 n +0000335271 00000 n +0000336448 00000 n +0000337295 00000 n +0000337953 00000 n +0000338652 00000 n +0000339325 00000 n +0000340067 00000 n +0000340498 00000 n +0000340656 00000 n +0000341023 00000 n +0000341671 00000 n +0000342168 00000 n +0000361512 00000 n +0000363639 00000 n +0000364206 00000 n +0000364979 00000 n +0000365686 00000 n +0000366928 00000 n +0000369154 00000 n +0000372117 00000 n +0000375215 00000 n +0000376202 00000 n +0000377126 00000 n +0000378442 00000 n +0000380546 00000 n +0000381635 00000 n +0000382727 00000 n +0000384081 00000 n +0000385142 00000 n +0000386236 00000 n +0000387703 00000 n +0000388812 00000 n +0000389873 00000 n +0000391884 00000 n +0000394775 00000 n +0000396789 00000 n +0000400075 00000 n +0000401838 00000 n +0000403749 00000 n +0000403907 00000 n +0000404065 00000 n +0000404655 00000 n +0000405345 00000 n +0000406103 00000 n +0000406800 00000 n +0000407470 00000 n +0000409865 00000 n +0000410557 00000 n +0000411948 00000 n +0000414063 00000 n +0000415352 00000 n +0000416683 00000 n +0000417773 00000 n +0000418861 00000 n +0000420224 00000 n +0000441576 00000 n +0000442650 00000 n +0000443732 00000 n +0000445220 00000 n +0000446310 00000 n +0000447391 00000 n +0000449662 00000 n +0000452472 00000 n +0000455126 00000 n +0000457176 00000 n +0000458717 00000 n +0000466205 00000 n +0000466363 00000 n +0000466526 00000 n +0000466684 00000 n +0000466842 00000 n +0000467000 00000 n +0000467158 00000 n +0000467316 00000 n +0000467474 00000 n +0000467901 00000 n +0000468059 00000 n +0000472213 00000 n +0000472371 00000 n +0000473141 00000 n +0000473539 00000 n +0000474087 00000 n +0000474782 00000 n +0000475495 00000 n +0000476196 00000 n +0000477708 00000 n +0000481588 00000 n +0000483335 00000 n +0000509572 00000 n +0000512034 00000 n +0000512965 00000 n +0000513997 00000 n +0000515229 00000 n +0000516358 00000 n +0000517480 00000 n +0000518799 00000 n +0000519890 00000 n +0000521084 00000 n +0000522473 00000 n +0000548869 00000 n +0000549926 00000 n +0000551178 00000 n +0000554672 00000 n +0000558058 00000 n +0000559611 00000 n +0000562205 00000 n +0000562448 00000 n +0000562606 00000 n +0000562963 00000 n +0000563548 00000 n +0000588985 00000 n +0000589943 00000 n +0000590601 00000 n +0000591265 00000 n +0000591972 00000 n +0000592769 00000 n +0000593199 00000 n +0000593357 00000 n +0000593651 00000 n +0000594354 00000 n +0000594835 00000 n +0000607566 00000 n +0000608109 00000 n +0000608908 00000 n +0000609584 00000 n +0000610886 00000 n +0000613371 00000 n +0000614997 00000 n +0000618581 00000 n +0000619685 00000 n +0000620610 00000 n +0000734559 00000 n +0000730201 00000 n +0000725813 00000 n +0000739376 00000 n +0000739710 00000 n +0000741276 00000 n +trailer <</Size 270/Root 1 0 R/Info 269 0 R/ID[<0F7E081F77714ED48E313D2A51EE353F><E846F662486441F69BF7DE57A9508251>]>> startxref 741440 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC6.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC6.pdf new file mode 100644 index 0000000000000000000000000000000000000000..73d43d3a5cf4bf253cb6242f351ba6d7471231a0 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC6.pdf @@ -0,0 +1,3979 @@ +%PDF-1.5 % +1 0 obj <</Metadata 2 0 R/OCProperties<</D<</ON[6 0 R]/Order 7 0 R/RBGroups[]>>/OCGs[6 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <</Length 61752/Subtype/XML/Type/Metadata>>stream +<?xpacket begin="" id="W5M0MpCehiHzreSzNTczkc9d"?> +<x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.0-c060 61.134777, 2010/02/12-17:32:00 "> + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <rdf:Description rdf:about="" + xmlns:dc="http://purl.org/dc/elements/1.1/"> + <dc:format>application/pdf</dc:format> + <dc:title> + <rdf:Alt> + <rdf:li xml:lang="x-default">Fig_WAD_TC6</rdf:li> + </rdf:Alt> + </dc:title> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmp="http://ns.adobe.com/xap/1.0/" + xmlns:xmpGImg="http://ns.adobe.com/xap/1.0/g/img/"> + <xmp:MetadataDate>2017-01-10T15:51:13Z</xmp:MetadataDate> + <xmp:ModifyDate>2017-01-10T15:51:13Z</xmp:ModifyDate> + <xmp:CreateDate>2017-01-10T15:51:13Z</xmp:CreateDate> + <xmp:CreatorTool>Adobe Illustrator CS5</xmp:CreatorTool> + <xmp:Thumbnails> + <rdf:Alt> + <rdf:li rdf:parseType="Resource"> + <xmpGImg:width>256</xmpGImg:width> + <xmpGImg:height>232</xmpGImg:height> + <xmpGImg:format>JPEG</xmpGImg:format> + <xmpGImg:image>/9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgA6AEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qpG8tBcm1M8f1lUEr Qcl9QIxKq5WteJKkA+2Kr/Uj/nH3jFXepH/OPvGKu9SP+cfeMVd6kf8AOPvGKu9SP+cfeMVd6kf8 4+8Yq71I/wCcfeMVd6kf84+8Yq71I/5x94xVsSITQMCfnireKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2Kpfqf+9uk/8xbf9Qs+KphUeOKuqPHFXVHjirqjxxVoMpYqCCwAJHcA 1p+rFW8VdiruK8g1ByAIB70PX9WKuxVL9c/3ij/5i7P/AKi4sVTDFXYq7FXYq7FXYq7FXYq7FXYq 7FXYq7FXYq7FXYq7FXYq7FXYq7FWG/mV5i0vyvDo3mTURL9Wsr/05zbqGkaOe1niC0JWqiRlY79s jOVC23FjMzQ5p15e84+VvMUQk0TVba/PASNFFIplRSaAyRGkib/zKMYzB5IyYpQ+oUnGSa3Yq7FU PGz/AKRnUhuAhiIJDcKlpK0YsVJ2FQFB6VJ2oqiMVdirsVdiqS+ab76tFpkPpl/rupWkHIdE4yet yPt+54/Timlx1rWFvLqFtAu2ghcLb3MctmVmWlS4V542XfahFcUKi6xqLMAdDvlBNCxeyoPc0uSc VYfqnn3zvBY0g8v8b4zSxk/V9TuhHHHeyQeqIorRI5QYIxKB9YQtX4QaryVbvfzB892+pWFmvk2Z 7e6ura3uL6N5pBCrpA9xI0awBQiGdkVvVp8DE9OJVTjyb5w13XZEj1Ty5c6IxtBcuZzIyrKbiWH0 OTwwgtwjWTxo3TuVWV4q7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWBfm9o0Gq6LaWdzI/oX VyYDGOPFSbW4PqLtXmDSlTTb51ry8nJ0n1vjq/s7iwv7iynoLi1leGTiajnGxU0PhUZgEU9DE2LZ h5b/ADq/MnQGUW+sS3lsrKzWt/8A6UjBRQJykrKi07RuuTjlkOrRk0eOXT5PTfLf/OVv2I/M2ifz F7rTX/4EC3mP3n1voy6Oo7w4WTsz+afn+P0PUNA/Of8ALTW+K22uQW85VWaC9rasC1Bw5TBEZqml EY5cMsT1cKekyR5hPtR1zRtJ1OP9I3Udq1+kcNsX25tGzkjkE2A5j7T09l3LZEMUpXQ5OHPJGPNN 8rZuxV2KuxVgWvalLe+cbWFJG+qafcW0CxinF5nmjeR6034jig32IbDOVVH4/q/X8W3Hj9Ep/AfM X+r4M9wNTsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirC/wAxYbiulzG4b6ub sILXivEOLa5Jk5U51IoKVpleTk5Ok+t80/nPorWfmWPUlqYdTiBJJG0sAEbAAbgcOB37k5hzDvMM ujz/ACtvXRsquGZQ4H7JqAfuocKCETdNBFdTRLboVjdlUkyVopI/mwMY2QC9i/KDQ7ZvLFzfXVsh Gps0KDkxBt4yVoPi5KTIXrv2By/Htu4uYcRIPJ6DF+aHmSyjWzkhgle2/cmaVJFd/T+HmR6n7VK5 0eHR48sROzu8hn1E8UzDu/AX/wDK2/MP/LNaf8DJ/wA15Z/JuPvP4+DV+en3B3/K2/MH/LNaf8DJ /wA14/ybj7z+Pgv56fcHf8rb8xEgLa2jOxCotHFWY0VQWkAqSadcjPQY4xMiTQZ49XknIRAFlU0o yfXrJp1X6zNewzXDKWK+tLcLJIVqenNjTbNDx8U7ejnj4MNfjm9VofHLnXOp74q6nviqlazNLEWa lRJIm3gkjKPwGKquKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KsI8/pqIGnmd43tTfL6H AFWH+i3VVZTy3px+Llv/ACr1NeTk5Ok+t5z+YHlsa/5auLZQzXVvW5s1SlWmjRgqb7fGGK/TXMYi 3bRlRt85ZQ5q5OHIcwSvcKaH8a4oKIvJAL245xDl6rkhuVQeXTYjphkN2GPeI9z6T8t2L6Zommaa 0SRvBaqs6oGKiUBeZDD4d3Zj7/fl4cS0t11Ej1RyEY+qiSMWqVr9jiu/hHuPfOi7KyXjMe4/j9Lz HbOPhyiX84fd+Al9RT7I+e/9c2jqHCnfp7YAFtH6HbLNqNT8SW49Q0K05HZKqRXxYEd1zVdq56gI j+L7h+13HY+nvIZnlH7z+xltjX9JWH/MXb1/5HLmix83f6n+7L1PMl1LsVdiqF011e1LoQytLMVY GoIMz0IOKorFXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWF/mA96YNNE0UaRDUP3TpIzs w+q3O7KUQL26E/hvXk5OTpPrY1mO7R8/fmh5a/QvmaWSFONjqFbi3oNlYn96nQD4WNQB0UjKpjdy cMrFdzEUVWcBm4L3ahP4DINpZo3lSaX8wNOsZIhLBfNBeSK3wo1uwEku9T2Vl7Vb6MtkPU4sJ/u9 3uklBfQgijGKUrUb05R1oeP/ABsPke1jV1SrzOgC2sxZvttEEHQl158j8vS/HNp2TkrIY94+78F1 HbWK8Yl/NP3/AICSZ0LzDRIUEk0A3JPQDFWWaRaNa2CJIKTOTJKPAtT4dmcfCKDY0PXOS1WbxMhk 9rotP4WMR+fvTKxr+krD/mLt6/8AI5cpx82ep/uy9TzJdS7FUv1/V00jSZ79ozM0YCxQKQpkkdgi ICxAFWYb9slEAnfku/IblKtH0u6k8l2Vhpl/JpckaBIbqNI5WVUYinGZXU1AyANhnkFSI80w/Qup f9X6+/4Cx/7JcLBLtY8oajftZyLrt16tnJNIpmHFWEtrLb8SLJrBtmlV68qjjReNa4qxi+/J2+vt StdQn1yNZ7UwMDHazs0hgklkVppbi7uJpmUyqY/Vd1QoKLSq4qrX/wCVGvXOr/pCPzlqMSEXx+rF 7iRFkvFuEjki5XFIjAlwipwA+xtx5HFWUeU/Lmq6Klwt/rM+sestssTT86x/V7dIXPxyS7yuhkbp uTWp3xVP8VdirsVdirsVdirsVdirsVdirsVdirCPzBu7iQabA1lNFEl9Vbp2hMbn6rciihZGk7V+ JR1yvJycnSfWxFdSVwStvccRE0oJiZalaVjo1Dz322oex2OUU7PiY3580BfNGjSWkVtJHqlooubF pEADMVHKL1d0HOvEjkPiAPQYJRsMoTovA0gZpzC7CFlLBzJVQpUGoO1a7UyhzDLaxu9a/NPRfrPk rSNVjUmSwSJJWBUAQzoq1NdzSQIBTxOW5A4unNU8gylzGyzEUJNB0GKq9pf31mzNaXMtszCjNE7I SPA8SMnCcomwaLCeOMxUgCPNk3lHUvMmqatb6PHqE3G8kHqOzBnVFBZ2R3+IcUUmgO+XjV5iDHiN Fxp6HTipcEbjy6b/AAq3t2jWt9ZvPY3V3JcQxcGsrmcgySK4YvG7cVDOpiY7fsnNdqddHTyEZCR4 uVdPf8wxz5IiPEfsTWC7igube4kr6cE0Uz0FTxjkVzT3oubvR6aWUCUap0ep7XxUY1L7P1p9qP5t aVHBKtjazyXQFIvWCrFXxYq7Nt4U39s2UOzZX6iKdfLXRrYbsTu/zL823EhaO4S1QinpQxJx+dZB I345mR0GIdLcWWsyHrTVt5l1/XLgQ6jdCe3tP3wTikbCVg0aH92q8hwMnU5ru0oQxxEYijL7v7fu dt2Rx5JGUtxH7/7PveqeWP8AjhWnyb/iZzAjybsv1n3ppkmt2KuxV2KuxV2KuxV2KuxV2KuxV2Ku xV2KuxV2KuxVifnSG61UafZadHyuYL3nJ9YWeGLj9WuFqJBFIDv4ZGUbDbhycErYpdfljrN1efXJ bay9cqUkIu7oB0K04sotqGmzDwIByHhlyTqok3Syb8tL8ssUtppwaXmFQ3dyC9Q3Og+r7/C7V9sf DPev5qHcwvzr/wA4963qF7Heac9hYTzEJOjzXTxOxYBW5/VvgbelCfi2A36wlgvq249eIcgn0WnW 2qeVYrC5B9C7skic0HIBowOQ5A0Zeo265AuTDkHzfqmmXul6hPp96np3Vu3CReo8QQe4I3GY5FOd GVi0LgZImwYeo6lVYGORviUNQpGzClQe4wsJ970j8kbY3GrahfuI/wDRIUjRfSQHlOxPIMBtRYiP pyeMNWfoHrsssqMJI4fVbi6txKrRePPoaBiWRV+nwrmv7WxcWMS29Mh07zX6fscDVD0FD3MjfV32 Xof2V/pnW9i74w8Vqj6mMSTP6jbL1P7C/wBM3lIBWmdgKngAOp4r/TGltlWkW72tiiOqrM9ZJvgQ Hk3ZuOxKii19s5HU5vEyGT2ukweFjEevX3vT/LB5aFaHxVvb9s9ssjydfl+s+9NKYWt1MVUL6R4r K4lQ0dI3ZT1oQpI64qr4q7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FVrRxuyMyhmjPKMkAlWoVqPA 0YjFV2KrGhhaVJmRTLGGVJCAWUNTkAeoB4ivyxVqW6toXjSaVI3lPGJXYKWNQKKD13IxV49opB0e xINQbeKh/wBgMxDzd5HkHln52eW/SurbzBAgCT0t7ygA/eKKxue55IOPtxGVzHVvwy3p5blTkomw 5GSRVQM5iloSSKARtypT2yQDXk5fEfe9v/Jyxa38ni5bgTfTySqVUBgkdIQrGm/xRMfpyyHJoy7y Zpekm2kPAyMg9RY1oCzIeaqPmRgyw44mPe4+WHFAjyQkjgW8sYAUxggKAAOP7NB4dvvze9i74w8N qvqY3KTzYe/hm7piDsiNLsxd3axspMS/HKaVUqp+yaqy/EaChptWmYHaOfw8dDnLb9bs+y9P4mWz yjv+r8eTLM5l6x6L5XIOg2hG4Kt/xM5lR5Omy/WfemmSa3YqgtauYLfSrmSdxGjIYwzbAvL+7Rfm zsAMVRuKuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV41o3/AByLH/mHi/4gMxDzd5Hk FPX9Hg1nRrzS5zxS6jKByOXB+qPSq14uA1K4CyBp8zX9jdWF7PZXcZiubdzHKh7Mpp1HUeByginM ibFpp5LtYbvzJZWsjMv1hzECADQOpUnfwByUObXn+n8d76A8rQLbeXrG1ERia0iFtIhFP3kBMUjD ZeQZ0JDU+Lr3y0OPdprihKZLZo7NUjZ0NupiX1Dy5IpAqwUgEsq1B7V+Yze9lD0vEdow4Mpj5/2J BIsoBkkTj3cjdR4/EQNs2xyRHMgNMccjyBKfaBbiOxM5i5vcfExAWoWh4I1eJ6b8W6FjnM63UeLk schsHruz9N4WKj9R3KbKTTcEdt+u3fbxzDc8PRvLH/HCtPk3/EzmTHk6bL9Z96aZJrdirFPPGqUa 00hI0lFwyz3RYmsccLhoiAB9ppVFK9lbCaEbPU7fp/HmzxRJJ7gDf6Px5MomaRYXaJPUlVSUjJ48 mA2HLelfHAwSS11bzbLbpJPoEdvMwq8JvUfifDksdDiqhrOvebbLTpLmDQkmljeEektw0pKPMiSn hFE8h4RszfCp6dDiqR6h5z87PZrd2OmrbpEl3Jcw/o/VLx2EEaekIxJHpkhkkmmVQnpEFQ7cxxNF VurfmB55s3eC28oTXgFnLKl9GbjibmOwW6CfVzAG4vM4gUGQMWDdCKFVNvJ3nDzDrV/NZ6t5bn0T 0bWC4+sSNLJE7zjkYUd4IAWjVgH8GqKbVKrLcVdirsVdirsVdirsVdirsVdirsVUbmysrrh9Zt45 /TIaP1EV+JBDAjkDQ1UHFXgTTadPoNottd2ZuTbQxNHcXDLFxVK0KxsKMCdmpUfRmN1dvYro5nt7 h2uJbnT4prj02nVbqQNVFAVS6SKPgDuKgfFsaDsp2Pcwv8x/LTaqra1BcafJfwoonhtZAHmRFAJ4 sfjdd6b14gLuaZCcLbcWXhO5FMe/LHSfrOvR6g8ojWwmhCIaAySSSBCgqanipLGg270yMInmWzPl BAAILIvzdk1zRtZt7/Tb65s7XUYz6yW88sYa4hARmZVIUVi4AePHBNlio7F5fPcT3ErSzyNLK27S OxZj8yd8qcgBTxS2OuKvQ/yl8s22sXd3PeAm2tEUBVZ0YyyH4SGWmyhDXfwyUYCXNjkzmG0TRex6 e13DpqQ3UwmvImId2CF2QErG7AM5+MLXen8To5arNHVHGZHgHL7D3dx83RdoZpDeJpMYfMWswWqw Q3JjiQUVFVQAOu1Bnc9n44z+oW8xqNVkHVJJvNnmW3ufUi1Keu2zOXX/AIFuS/hm4OmxkVwhphqM nPiKP0381PMdu1LwRXyVqeSiN6eAaMBfvU5RPs/GeWzlQ1sxz3XW2qXOsXcmsXIAa8dfQQA/BBH8 MaAn7S15OD0PKvfNFqTHxOGPKO363otLAjCZS5ys/qeuYXDdirsVdirsVdirsVdirsVdirsVdirs VdirsVdirsVWSwpJx5FhxII4uydCDvxIr074q1bwiGCOEdI0VBStPhFO5J/HFV0iyGNhGwWQghGY FgGpsSoK1+VcVbAoBU1PjirGPP8AO3+H7iEwuB69mVlNCrf6ZBWhBNKcv2qHwrkZ8m7B9YeWefvL TeYfLU9lCB9cjZZ7MsSB6idtj+0hZd/GuYhFu5jKjb5wyhzHYpXRsquCyhwP2TUA/dQ4UEPoT8sN PhsfKqcI+P1m4nlZW5fsyGFSKnukSnLoig4RlxbsllmSIyKywpHIVZdyHaQ/Axbffb01H+1mo12M DPCdcwR8t/0l1faA2trmvD7C/wDDf1zsezHldQdmP38i+p/dr2/m/rm8prgfJDW8aXNxFbcFX1m4 k8nU8QCW4kE/FxBp75javL4eMyvfo52iw+LlEa26+5mkbj1E+AfaHj4/POVjzevyj0n3PVae+ZTp nUPjirqe+Kup74qpWszSxFmpUSSJt4JIyj8BiqrirsVdirsVdirsVdirsVdirsVdirsVdirsVdir sVYx5/uYz5duIaPzWeyJPpvw/wB7IOj04H7XY/qORnybsH1hhuYrt3z/APml5bOjeZ5Zo1IstSrc wHsHJ/ep0A2c1oOgIyqY3cnDKxXcw7INy+FQ0qqVZ+RpxT7RJ6U2OFBNC31DoLL+hNP+AgfVoaB/ tD92uxoaVzILr4cgq3gFYn4L1aN5CSpVHH7Jr1LhBmJq4XEHuN/o/S4mvjeO+5rkCpHGlPnTfOi7 M5vH6jkx/UP74/Rm9pqxnZGeXbcD1L1qBWJhiPLb7QDdGINXHHcVBHvmg7Uz8UuAco/e9R2Rp+GH iH+L7v2/qT+M0kT/AFh+vNXHm7fL9B9z1fMp0rsVdirsVQumur2pdCGVpZirA1BBmehBxVFYq7FX Yq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FWLfmBfWI0Ca0NxELoz2Z+r819SgvIKnhWv7Q+/Iz5N 2D6wwszwCRIzIokk5cEqKtw+1Qd6d8xnb2xT8wtBt/M3lx4rKRJr+1P1myCMpLkclZKgMaOFYDp8 QHgcjIWGUJ0bfPuUuYyX8udKk1Lzlpka8glvKLuV1XlxWA8xy8AzBVr75KA3a8sqD3PyzevLZJZz 0FzbQwsKCgaCVKxOP+BZD/lKe1MuPNw4cgmd3D6tu68A7CjxqxKguhDJUj/KAyMhYIRlhxRMe8KK mOWEOrckYBkZTsR1BBHbNz2ZzeF1KQ3EFzLeJbxt6jvQBuNSBQAyPQotF6np4DeldtqM4xQ4j8Pe z0WmOaQiPj5Bk0UfowxxRiqxqFXkTWiigqd85OUjI2eZe4jARiIjkFaMgSrvtyAr9OMebHJ9B9xe r5lOmdirsVS/X9XTSNJnv2jMzRgLFApCmSR2CIgLEAVZhv2yUQCd+S78huUP5Qgjt/LVhbxCkcMf poDv8KsQP1ZAGwzyCpEeacYWDsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVY95+WRvK84jjkm f17MiOJGkcgXcRNEQMx28BkZDZtwkCYJeZXmkaq13FPYWl1bKH5zxnSrhi5YkPIH9KqyBXPE779d icp4T3OwOWF7ELRourh4JPSvfVt9om/RE3wKQoZU/dVUMFIO/f2x4T3L4sP5wea+ffyr8yPcHVdK 0/UL+Wdi19Cun3Mb8yKmVV9Pi3I15Bab0oOpyueInkG/Fqox2MmTflV5N1nQdKuLnUNIv49SvnH7 r6nclkhQfCG/d0ViSzEBulO+2GGMhjk1UCbtR89z61p/kzT9X0i5ktpYIoYbsxlQpgmVRyYMCeSy BQpXccm8TkcjbhANW8m/xd5r/wCr1f8A/STN/wA1ZTZcvhHct/xX5ppT9MX1P+Ymb/mrJxzTjyJH xaJaPDLnCJ/zQ6PzT5mV+S6vegnqRcSgn/hsM805fUSfeWeLTY4fTGMfcAGUeTtX8z6pq9tY/pa8 YzsAS1xIaKPidqM4rxUE0yg3I1blx4IRMiAdu57PYRTWsM1vJNLO8bK8dxJUsUZQAC1AvIMjbL2o e+ajVjLi1EalLgkO/qDv94ee7QyGttvdsnMHmvzBGvBbxiB05Kjn72UnOo0ZMgLecnnmORVD588w WysWaK48PVQCm3/FZTN/HQ45RB3Dix7QyA1sURpf5qp6wi1e2EaMafWLepC7j7UbEmg7kGvtlOXs 7b0H5uXi19/UPk15s8xafq93Z2unXC3Fvaqbm4Kkikki8IPCvwNLyB6Gnfprc8JY40difuH7fudz oanPiG4j95/ZfzZd5Y/44Vp8m/4mcrjyYZfrPvTTJNbsVdirsVdirsVdirsVdirsVdirsVdirsVd irsVUZbO2kcSNGvqgg+pxUt8LK1KkHugxVWoPDFVjx8ihDFQjciFpRtiOLVB23rtiq+g8MVQ15JE jQBpHi5SLQoBxbfjwdmBUBi3iCe2+KvGItOttU8qxWFyD6F3ZJE5oOQDRgchyBoy9Rt1zELvIcg+ b9U0y90vUJ9PvU9O6t24SL1HiCD3BG4zHIpzoysWhcDJfHx5jlXjUVp1pivuesfk9plodVvbwKxN tbxBQ5UkG5HPkDxFCoQr9OTxje2jNMkAfjuenXdEmgmWOR1+KKQB9lWSh5lQpLEMir7Ak5j6/EJQ B/mn9jqtdC4X3OUxV+y3/BD+mbLQnYPL5aUL30uH2W/4IeHyzq8N8Idca4kiumgDGqtQVqeQ/wCa ct3bo0yLSLSO1sURoysr/vJgSvLk3ZiooSootfbOS1ObxMhk9vpMHhYxH8W9P8sGuhWhGwKtQHr9 s/LJx5Ovy/Wfemm+Frdvirt8VU4ZvUeZKU9FwlfGqK9f+GxVUxV2KuxV2KuxV2KuxV2KuxV2KpTr 3mfTNDksY75bl21CVoLZbW2nu2LrG0pqlukjgcUPb8ASFUg1782fL2h3Ulve2l8PTit7lpPSRALe 6PBZSkskcq8ZPgdWQOD+zSpxVVtfzY8myxaUbia4srjWBEbS1mtpndWnmeCNJXgWaFGMkTihf9kn oDiqtoX5n+TNbNsljeOZ7oH0oJIJkaqxPKwqU4GiwyDkrFSylQSRiqY/4v0D/f0n/SPcf9U8aVda ebNCu9Si02CeRryZHkjjME6jhHTkS7IEHXucVTOW6toXjSaVI3lPGJXYKWNQKKD13IxV49opB0ex INQbeKh/2AzEPN3keQeWfnZ5b9K6tvMECAJPS3vKAD94orG57nkg4+3EZXMdW/DLenluVOSujpzH I0FdyNzT8MVD3/8AKuxS38sLc7N9dfmjAcW4RosIDVH80bMPY5fEUHBlKz8/vZRqMUUtlKrxGZQO fogirlCHC9O5WmCceIENWaHFAjyU/UVXVaNVjQNQkVoTvQbdOpy3QHYPH5VK7DcfiII9hTt8znWY L4Q62ZHEldtZG7vlRhWJSXm2qOKkUU1VlPI7cT2r4Zi9o6jgx11lt+Px1dx2TpvEyg/wx3/V+PJk uc09c9F8rkHQbQjcFW/4mcyo8nTZfrPvTTJNbsVdiqGtP7+8/wCMw/5Mx4qicVdirsVdirsVdirs VdirsVdiqC1bQ9F1iCO31fT7bUYInEsUV3DHOiyKCA6rIGAYBiK4qh7ryn5Vu4Y4brRrG4hiRI4o 5baF1VIlZY1UMpAVFdgo7AnxxVePLXlxVgQaVZhbX0xaqLeKkXoljF6Y4/DwMjFadKmnXFXWvlry 5aTQT2ulWdvNbVFtLFbxI0YPMHgyqCtfVfp/MfE4qmWKuxV2KvGtG/45Fj/zDxf8QGYh5u8jyCnr +jwazo15pc54pdRlA5HLg/VHpVa8XAalcBZA0+Zr+xurC9nsruMxXNu5jlQ9mU06jqPA5QRTmRNi 1KJS0iqvViAPmcWV1u+i/JfOy0yLQ7kr9ZsEKq6V4yosjRs61p0kUgjsONftZkF10STZPeyPAyQF pF6MSwgMBD+7XmQWKp8IYkfzAVy3SipPIa3HwZJBTvf3aPI8lIgCzcqAKAB0O22xO+dThNRdRIXK hzX6NbPFE80iKslx8VaEOE34K3JUYUG9D0JI+fO67UeLkschsHt+zdL4OIA/Udz+PJMMxHPei+WP +OFafJv+JnMmPJ02X6z700yTW7FVO5uIba3luZ24QQo0krnoqIKsdvADDEEmggmhZSTyXMLjTLi6 Uycbq7nuEWcESKszeoEYHpwDcadqYGc40fgPuT/Fi7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq 7FVG5srK64fWbeOf0yGj9RFfiQQwI5A0NVBxV4E02nT6DaLbXdmbk20MTR3FwyxcVStCsbCjAnZq VH0ZjdXb2K6LjPDORPLc6dFM7JM4W4cSB1QIFMiOteCs6+DeA5HFN+5hP5j+Wm1VW1qC40+S/hRR PDayAPMiKATxY/G6703rxAXc0yE4W24svCdyKSD8qtJtbnzGuoX7JHZ6aDIpkKgPcA0jQAkMWX7f wg0IFeoyEIG23NmjVAvRvNkuo2/lOXXNFm9K+sJ7h0mSNZS1vLcsJV+IMOP2ZCafsZObViovMf8A lavn3/q6f8kLf/qnlPGXL8KKwfmd54DM41EBnNXIgtxU0Aqf3fgAMlHLIci42bs7BkNyjZ95/Wrx /mH5/nCv9caRQaqwtoCKqa9o+xy+WuzGPCZbH3NWLsnSwnxCPqHmf1p9o3nXz9dTJG9xLIWNAoto qk9gAseYOTJLod3cYcOHnLkPMvWdPF9HE9te8ZLpQskcqKVV1aodePijAVPfkNhmHqc2owTjvxwl 3jkR7u/z7nRarPwbxACf6f5t1eytIrSK3iMUQIUsj13NezAd83enyGQ3eeyaqdk0Ewi896gorNYr J/qFk/WHzbYtIJjnTjy18o842sk/Mp43AfSn49ystT93pjLf5O/pfZ+1Me0Sf4fx8kJr3nWHWtPi 02ytp43uZB9d5qBwgj+M71IYSMAh9iemxzFz6c4okkjuHx/Y7DR5RlmBXLc/D9tMj8lgrpDBhQ+s 2x/1VzDx8nK1P94U/qPHJtDqjxxV1RirsVdirsVdirsVdirsVdirsVdirsVdirsVWSwpJx5FhxII 4uydCDvxIr074q1bwiGCOEdI0VBStPhFO5J/HFV0iyGNhGwWQghGYFgGpsSoK1+VcVbAoBU1Pjiq ldSpFEayrC7/AARM+/xkHiAtRyP+SOuKvJbi2iuv0pa3QWaKa8v4rhdwrhrmVXFKkiu/fMafN3GD 6A+Zdf0a50bWLrTbgNyt5GVHZePNK/BIBU7Ou/XMaQouxhLiCX5FmjbYM1lIoqxMsQUDfqsmwxR/ EPcf0M2/K/Snu/MlsZI6xWytcuGqPsU4FflIynGAuTPPkrHXe9kvqxmCYRs5WQRtwFW4ynh0CseI cqzbigFe1MhrsPHjPeN/l+y3SauN4ytVlLbEE/5/0zJ0fJ5fIF79M6jRnZ12ZK74b17bZsGqCI0O zVUe7dAJZCUjYhgwjB6Ub+ZgTUdRT2zmu0s/Hkoco7fre07I0/Bi4j9Ut/h0/W9P8kkHR2p/v5/1 LmPj5MdT/eFP8m0OxVDXf9/Z/wDGY/8AJmTFUTirsVdirsVdirsVdirsVdirsVdiqF1PVNO0uza9 1G5jtLRGjR55WCorSusSAsdhydwMVSa7/MXyRa28ly+sW8lrFDNcyXNuTcRBLYxiUepCJF5g3Ef7 uvM8hQHFVVPP3ks2c16+tWlvZ2909hLc3Mq28f1mNebxK83BWYKa/DX8MVX2nnfydd3JtLfW7GS7 Ehh+q/WIhNzEgip6ZYPvIwC7fFUUrUYqneKtFlBAJALGig9zSu33Yq6SNJEaORQ8bgq6MKgg7EEH tiryZv8AezUP+Y++/wCouXMafN3GD6A8t/O3y60tva6/CpJgpbXlKmkbEmJvAAOxUn/KGUzDl4ZU aeQ5U5KPtkmk02ZuRMcEkdU7AOHFfv8A15Low5THuP6Hqn5K6b+51DUnjG5W2glruKfHKtPDeM5L EGGpO4D0qeIywSRBzGZFZQ69VqKVHuMmQCKLiyjYI70BBcr6EcjlvTZFYSuAKgryJegAU7b9B+rI aTbZ4/NGjSLNAKU2751GjddmSy9RndYUNJJWCx1p1IqTQsteKgsQD0GZeozDHAy/Fs9FpzlyCA6/ cnEUSRRJFGKJGoVBUmgUUG53zkSSTZe+jEAUOTPfJP8Axx2/4zN/xFcyMfJ1Wp/vCn+TaHYqlt9f KmtaXY+mxaf15xKPsqIUClT7t623yOKaTLFDsVdirsVdirsVdirsVdirsVdiqF1PTLLU7J7K9jMl u7I5VWeNg0TiRGV0KspV0DAg4qlVz5D8rXdo9pf2smoQPHNCy31zc3Z9O59P1VDXEkjCpgQih+Ei q0NcVUY/y28jRW0drBo8FtaxXq6lHb2/KGNbtEWNZQkZVfsoNunelcVUNP8Ayp8g6cbc2Wl+gbW5 +uQ8Z7nacGFuRrIeW9rF8J2+Hp1xVOp/LPlueZ5p9Js5ZpCWkke3iZmY7ksxWpOKqEvkvyhK0TPo tlygkWaIi3jUrIhqrbKOhxVNbi1trlPTuIkmQGvCRQwrSlaGvjirylgBeajQU/3IX343cuY0+buM H0BDanp1rqWn3FhdLyt7mNo5BtUBhSorXcdQfHINr5k1fS7vSdTudOu143Fq5jelaGnRl5AHiwoy mnTKCKc2MrFsr/LzRF1yz1rTgi+v9VD2zGn96r1WpYNQH7NabA7b5OAsFpzGpA+/9DLPIXnfyTof lqCyur4Q3peWS6VYbhqsXIUkiMj+7VRhiQAicTI2AyL/AJWr5C/6un/JC4/6p4eMMfCkhYfzK8kg sDqpkJd2DGC4GzMWA+x+yDx+jBjkBIug1fZeaWQmMbB8x+tFL5+8ozMoh1NRQ1K+nKAR9KDNzp9f hhzlXwP6nXz7C1cuUPtj+tMNI1azvZ5Hhb1Z0VhFFG5+NQAzFQ/pqf2RvuDXtvmF2h2thySEIy2+ PPpzdt2b2Vl0oJyxqR5cuXwPenSsWBJUruRQ07GldievXMd2rPPJIA0dqf7+f9S5kY+TqdT/AHhT qa7tYFLTTJEo6l2Cj8TlsYE8g40pxHM0hT5g0EddStR85o/+asn4GT+afkw8fH/OHzYzpWqS6n51 kuRKz2aGSCzj24BIlZWkWg39R6tyqarxyqZ9XD3ff+zk5Qx1i4v5x+zevnzZri1OxV2KuxV2KuxV 2KuxV2KuxV2KuxV2KuxV2KuxV2KqV1axXMRikaRVPeKSSFtwR9qNkbv44q8d1KC4EmotbGV3jvb8 C3WQJ6nK7k2aRgzLTswIOY0ubtsI9AS2NdXniika1uoysSxvE90qEmJyzFuC7szR8eQNGVu29Az3 Yh+Znk/VdbRdUtNMKX1qhWXhIJGmiVmIHAUPJVFRQEnlx7DISiC3Y8hieWyXfke8Z1K+VY+LLbjm 9SeVZKjboKDI4+rPNzH47mMfmboraV5xvRv6N6frsJJBJExJfpSlJAwHtkZjdtxSsMVyDaqRdcWQ TWw/vRlcnKw83uHlXR/S8t21x6f+mMwvYTUN8Sg+jTi0fIFN+LNSpNclHTxliMJcpDf4ut18/EyH y2HwT3mJArgFQ4DBWBVhXehB6HMPs2JiOE8w8ZqRRXL0zqNM66a2Tpm+xcnBmld1HK7LHEA00h4x KxCgnrvXsACTTenTHPmGOBkejlaTAcsxAdWaeSoUg1a0gjr6cUbIlSSaLGQKk9c5WBJkSXs9VERx gDkHomXOudirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVWTRvIhVJWiY9HQKSNv8sMPwxVKV 8n+WGaWS40iymnmlllklkt4XdmlkZyWYoCSeX+3gplxHvb/wd5R/6slh/wBIsH/NGNBeM962Lyd5 WMSmXQ9OWUgc1S2hZQe4BKAn7saC8Z72F+ZfLumaRrNi9np9lZS3UN2biSyt0t/W4NbcDIEAPw8m pVm8aitMry8nM0ZJJedfm75bXVPLh1CMMbvSg0qKtKGJivrVr/Kq8vo98xpCw7LHKi8IylzFSLri yCc6PbTXV7DbQAGedhHECaAu5CqCfmcgRezfGXCCe4PpGGKOGJIYlCRRqEjQdAqigA+QzLdOgLb9 2ZbcmRjDIwDympZWpIOJLMzBRIEqfDMSMOHKfPf8fF5ztCHDkKKTpm705dRNbJ0zf4eTg5FCyjWS 7eTqIBxG6kc33NR9oMq0+hs1Xa2bcQHvP6HpewNPtLIfcP0/oZT5Sr+noPDjJ/xA5qsXN3Gs+j4v Qcvda7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYqgdY1qy0i3hnvPU9O4uYLSP0o2kPq3MixR1CA 0HJhUnFWMeYPza8uaHBJPd2mo+kkDTpytXt3k9OWKKRI4ro28pKfWFctx4ceR5fCwCqnB+c/kVmm W6nubJoZFRvVtpZE4SRevHMZLdZ40jeIM/7xlIVWLBaHFUx8vfmZ5O1+S0h068drm8PGG3kgmRiw jeVhyKcCAIXHJWK8lYAkjFUxfzZoSOyNNIGUkEehOdx8kxVYnnLy897a2S3En1m8cx20f1e4HJgO R3MfFaAdSaYqxzz0102q6R9YjSNvQvaCNy4pzte5RPfKsvJzdFzKQuiSI0cih0cFXRhUEHYgg5S7 B81+c/Lsnl/zDdacQfQB9S0c78oX3TegqR9k+4OUSFFy8crCURdci3Bm/wCWGm/XvNlqWjEkVqGu ZQTSnAURh4kSsmHGN2OolUPe92y9wEBdLH9ejDkszxlokI2QxnizA9mYTU+WVTHqBdN2rDlL4Ll9 VFqKy0qSNg3c7dFPYDp882enLoJtSzoFenxOtP3eysSSQoHIqPiIoO2bzHkEYknoHE8IzkIjnI0i baEwwLGW5MN3behYmrEBixAqdhXbpnM5chnIyPV77T4RigIDkE98pV/T0Hhxk/4gcOLm06z6Pi9B y91rsVdirsVdirsVdirsVdirsVdirsVdirsVdiqjd2dneRCG7gjuIQ6SCOVFdecTiSNqMCOSOoZT 2IriqWf4K8m/Vvq36B076tUt6H1SDhybiSePClT6aV/1R4YqqDyl5VAnA0axAuWZ7kfVof3jOrqz P8PxFllcGvZj4nFV9r5a8uWk0E9rpVnbzW1RbSxW8SNGDzB4MqgrX1X6fzHxOKplirsVefefryVt T015bSaERW96QG9Ny4DWp+ARPIT4UO9cqyubo+ZY1JqYWOaQWtw4iVWULEeUgc0+BTQ1UjcGh79K ZTTn8TCfzS8tfp7S5L+zt5BqekcuYaPj61vUlgrkfHxpzUBvEUq2RnGw2Y50XisXUZQXND2P8mtC kitbrWpowPrFILNzXlwU1lPhxLhR81OWYxtbj6idmu56Vljjoe9qIlkqQsbBnA4gFTVTy5dlryPy wSFuHr8XHiPlv+Pg0mZunLyc1NIxdSHkEe0TktK8ubiqsCAePFdxQ1+Lw473avU7cA+LuOyNDv4s vh+tFCKMABRxAYvRfhFTUkmnWpNd81z0Cd+Uv+O9B/qyb/7A5Zi5uJrPo+L0HL3WuxV2KuxV2Kux V2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KsQ826Tqusalp8mmRxkW0V0kxujNAKyNbsvEiGT l9k/51yE4234MwgSxdvyr1g3kl2bax9WbeUfXbngzBgyuV+r05LSgI7Ejocj4Zb/AM1G7pzflZqZ opstO2Aov1u5GylSNvq/jGp+ePhnvX81DuYPr/8AzjP5kvNUN1pc+n2VvMQZreSe4k4sftOh+rgm vXi3eu/YVywWebfj7RERVPQNL/L3zJpun22nW0dh6VrGsaVuZeRCinJuNqoqx3Jp1yXhNf50dyL/ AMG+bv8Afdh/0lT/APZNh8Ir+dHctbyZ5rYFGi08hgQVNzMajvt9Wx8Ir+dHchP8A+dxF6CmwC8A v1k3Uxl8CeP1QLyp+14/s9sshcRs6Y6SBne/D3ItPJnmpAI0h09VUAKouZwAOgA/0WmV+EXcDWRA oBd/g3zd/vuw/wCkqf8A7JsfCKfzo7kx8u+XtesNYgnvkthDRxW3mklYEoaEh4YgF969clCFFoz6 gTFUzPLHFdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVa4qWDUHIAgN3ANKj8 MVbxVaI4xIZAoEjAKz0HIqpJAJ8ByOKrsVW+jF6vrcF9bjw9Sg5ca14160riq7FVojjEhkCgSMAr PQciqkkAnwHI4quxVYIIBM0wjUTMOLSBRyI8CeuKr8VWiKISmYIolZQjSUHIqpJAJ60BY/fiq7FX /9k=</xmpGImg:image> + </rdf:li> + </rdf:Alt> + </xmp:Thumbnails> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" + xmlns:stRef="http://ns.adobe.com/xap/1.0/sType/ResourceRef#" + xmlns:stEvt="http://ns.adobe.com/xap/1.0/sType/ResourceEvent#" + xmlns:stMfs="http://ns.adobe.com/xap/1.0/sType/ManifestItem#"> + <xmpMM:InstanceID>uuid:5f0d52f2-8166-2c4e-bb13-472516d6c243</xmpMM:InstanceID> + <xmpMM:DocumentID>xmp.did:06801174072068118C14AA247F7D2A30</xmpMM:DocumentID> + <xmpMM:OriginalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</xmpMM:OriginalDocumentID> + <xmpMM:RenditionClass>proof:pdf</xmpMM:RenditionClass> + <xmpMM:DerivedFrom rdf:parseType="Resource"> + <stRef:instanceID>xmp.iid:05801174072068118C14AA247F7D2A30</stRef:instanceID> + <stRef:documentID>xmp.did:05801174072068118C14AA247F7D2A30</stRef:documentID> + <stRef:originalDocumentID>uuid:5D20892493BFDB11914A8590D31508C8</stRef:originalDocumentID> + <stRef:renditionClass>proof:pdf</stRef:renditionClass> + </xmpMM:DerivedFrom> + <xmpMM:History> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:01801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T13:26:06Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:02801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:19:32Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:03801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:31:30Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:04801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:40:26Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:05801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:45:35Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stEvt:action>saved</stEvt:action> + <stEvt:instanceID>xmp.iid:06801174072068118C14AA247F7D2A30</stEvt:instanceID> + <stEvt:when>2017-01-10T15:51:10Z</stEvt:when> + <stEvt:softwareAgent>Adobe Illustrator CS5</stEvt:softwareAgent> + <stEvt:changed>/</stEvt:changed> + </rdf:li> + </rdf:Seq> + </xmpMM:History> + <xmpMM:Manifest> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0600.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0480.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0360.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0240.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0120.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <stMfs:linkForm>EmbedByReference</stMfs:linkForm> + <stMfs:reference rdf:parseType="Resource"> + <stRef:filePath>/Users/acc/NEMO/WAD_DOCS/TRY6/wadfr0000.png</stRef:filePath> + </stMfs:reference> + </rdf:li> + </rdf:Seq> + </xmpMM:Manifest> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:illustrator="http://ns.adobe.com/illustrator/1.0/"> + <illustrator:StartupProfile>Print</illustrator:StartupProfile> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:xmpTPg="http://ns.adobe.com/xap/1.0/t/pg/" + xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" + xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" + xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/"> + <xmpTPg:HasVisibleOverprint>False</xmpTPg:HasVisibleOverprint> + <xmpTPg:HasVisibleTransparency>True</xmpTPg:HasVisibleTransparency> + <xmpTPg:NPages>1</xmpTPg:NPages> + <xmpTPg:MaxPageSize rdf:parseType="Resource"> + <stDim:w>422.158203</stDim:w> + <stDim:h>380.658203</stDim:h> + <stDim:unit>Pixels</stDim:unit> + </xmpTPg:MaxPageSize> + <xmpTPg:Fonts> + <rdf:Bag> + <rdf:li rdf:parseType="Resource"> + <stFnt:fontName>MyriadPro-Regular</stFnt:fontName> + <stFnt:fontFamily>Myriad Pro</stFnt:fontFamily> + <stFnt:fontFace>Regular</stFnt:fontFace> + <stFnt:fontType>Open Type</stFnt:fontType> + <stFnt:versionString>Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895</stFnt:versionString> + <stFnt:composite>False</stFnt:composite> + <stFnt:fontFileName>MyriadPro-Regular.otf</stFnt:fontFileName> + </rdf:li> + </rdf:Bag> + </xmpTPg:Fonts> + <xmpTPg:PlateNames> + <rdf:Seq> + <rdf:li>Cyan</rdf:li> + <rdf:li>Magenta</rdf:li> + <rdf:li>Yellow</rdf:li> + <rdf:li>Black</rdf:li> + </rdf:Seq> + </xmpTPg:PlateNames> + <xmpTPg:SwatchGroups> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Default Swatch Group</xmpG:groupName> + <xmpG:groupType>0</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>White</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>Black</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Red</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Yellow</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Green</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Cyan</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Blue</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>CMYK Magenta</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=15 M=100 Y=90 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>14.999998</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=90 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=80 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>80.000000</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=50 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=35 Y=85 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>35.000004</xmpG:magenta> + <xmpG:yellow>85.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=5 M=0 Y=90 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>5.000001</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=20 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>19.999998</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=90 M=30 Y=95 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>90.000000</xmpG:cyan> + <xmpG:magenta>30.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>30.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=0 Y=75 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=80 M=10 Y=45 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>80.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>45.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=70 M=15 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>70.000000</xmpG:cyan> + <xmpG:magenta>14.999998</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=50 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=95 Y=5 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>5.000001</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=100 Y=25 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>25.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=75 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>75.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=100 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=100 Y=35 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>35.000004</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=10 M=100 Y=50 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>10.000002</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=95 Y=20 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>95.000000</xmpG:magenta> + <xmpG:yellow>19.999998</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=25 Y=40 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>25.000000</xmpG:magenta> + <xmpG:yellow>39.999996</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=45 Y=50 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>45.000000</xmpG:magenta> + <xmpG:yellow>50.000000</xmpG:yellow> + <xmpG:black>5.000001</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=50 Y=60 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>60.000004</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=55 M=60 Y=65 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>55.000000</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>39.999996</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=25 M=40 Y=65 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>25.000000</xmpG:cyan> + <xmpG:magenta>39.999996</xmpG:magenta> + <xmpG:yellow>65.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=30 M=50 Y=75 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>30.000002</xmpG:cyan> + <xmpG:magenta>50.000000</xmpG:magenta> + <xmpG:yellow>75.000000</xmpG:yellow> + <xmpG:black>10.000002</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=35 M=60 Y=80 K=25</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>35.000004</xmpG:cyan> + <xmpG:magenta>60.000004</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>25.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=65 Y=90 K=35</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>65.000000</xmpG:magenta> + <xmpG:yellow>90.000000</xmpG:yellow> + <xmpG:black>35.000004</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=40 M=70 Y=100 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>39.999996</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=50 M=70 Y=80 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>50.000000</xmpG:cyan> + <xmpG:magenta>70.000000</xmpG:magenta> + <xmpG:yellow>80.000000</xmpG:yellow> + <xmpG:black>70.000000</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Grays</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=100</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>100.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=90</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>89.999405</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=80</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>79.998795</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=70</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>69.999702</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=60</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>59.999104</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=50</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>50.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=40</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>39.999401</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=30</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>29.998802</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=20</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>19.999701</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=10</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>9.999103</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=0 Y=0 K=5</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>0.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>4.998803</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:groupName>Brights</xmpG:groupName> + <xmpG:groupType>1</xmpG:groupType> + <xmpG:Colorants> + <rdf:Seq> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=100 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>100.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=75 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>75.000000</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=0 M=10 Y=95 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>0.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>95.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=85 M=10 Y=100 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>85.000000</xmpG:cyan> + <xmpG:magenta>10.000002</xmpG:magenta> + <xmpG:yellow>100.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=100 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>100.000000</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.000000</xmpG:yellow> + <xmpG:black>0.000000</xmpG:black> + </rdf:li> + <rdf:li rdf:parseType="Resource"> + <xmpG:swatchName>C=60 M=90 Y=0 K=0</xmpG:swatchName> + <xmpG:mode>CMYK</xmpG:mode> + <xmpG:type>PROCESS</xmpG:type> + <xmpG:cyan>60.000004</xmpG:cyan> + <xmpG:magenta>90.000000</xmpG:magenta> + <xmpG:yellow>0.003099</xmpG:yellow> + <xmpG:black>0.003099</xmpG:black> + </rdf:li> + </rdf:Seq> + </xmpG:Colorants> + </rdf:li> + </rdf:Seq> + </xmpTPg:SwatchGroups> + </rdf:Description> + <rdf:Description rdf:about="" + xmlns:pdf="http://ns.adobe.com/pdf/1.3/"> + <pdf:Producer>Adobe PDF library 9.90</pdf:Producer> + </rdf:Description> + </rdf:RDF> +</x:xmpmeta> + + + + + + + + + + + + + + + + + + + + + +<?xpacket end="w"?> endstream endobj 3 0 obj <</Count 2/Kids[8 0 R 9 0 R]/Type/Pages>> endobj 8 0 obj <</ArtBox[0.0 0.0 422.158 380.658]/BleedBox[0.0 0.0 422.158 380.658]/Contents 10 0 R/Group 11 0 R/LastModified(D:20170110155112Z)/MediaBox[0.0 0.0 422.158 380.658]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/Font<</T1_0 5 0 R>>/ProcSet[/PDF/Text/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R/Im3 17 0 R/Im4 18 0 R/Im5 19 0 R>>>>/Thumb 20 0 R/TrimBox[0.0 0.0 422.158 380.658]/Type/Page>> endobj 9 0 obj <</ArtBox[0.0 0.0 172.8 129.6]/BleedBox[0.0 0.0 172.8 129.6]/Contents 21 0 R/Group 22 0 R/LastModified(D:20170110155112Z)/MediaBox[0.0 0.0 172.8 129.6]/Parent 3 0 R/PieceInfo<</Illustrator 12 0 R>>/Resources<</ExtGState<</GS0 13 0 R>>/ProcSet[/PDF/ImageC]/Properties<</MC0 6 0 R>>/XObject<</Im0 14 0 R/Im1 15 0 R/Im2 16 0 R>>>>/Thumb 23 0 R/TrimBox[0.0 0.0 172.8 129.6]/Type/Page>> endobj 21 0 obj <</Filter/FlateDecode/Length 271>>stream +HMN1 9/0qxKBB]p�ď\dN2^o`mζH4^ ?R6FT P̎JZkd!ew4^o&"(:oXZ +ߧ[xlA"0HA*rM(M,s$(ZX݃ .¤xeQ1P BnTyNCʌ<—8-Гr'0{] z0W!~/?D1\c,Y$KYDCA[_ ]|/�o endstream endobj 22 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 23 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 16/Length 173/Width 21>>stream +8;X.'YmnT)$j=,%(K!V=5ZO4;SQco%jJsE0Ln3/>>I<1q$'5s*n9K8kNoNpWDqMq3 +@X&m>e4S3#HCDgu\%mc<PM.jtH1fE,9ahY+`^L(FUBH7G,KUFmP$VSh0M/-r?HMd; +<13iD@<@U\C_o(C)O#BKpCI,a!;-6OhZ3`>VV=0~> endstream endobj 24 0 obj [/Indexed/DeviceRGB 255 25 0 R] endobj 25 0 obj <</Filter[/ASCII85Decode/FlateDecode]/Length 428>>stream +8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 +b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` +E1r!/,*0[*9.aFIR2&b-C#s<Xl5FH@[<=!#6V)uDBXnIr.F>oRZ7Dl%MLY\.?d>Mn +6%Q2oYfNRF$$+ON<+]RUJmC0I<jlL.oXisZ;SYU[/7#<&37rclQKqeJe#,UF7Rgb1 +VNWFKf>nDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j<etJICj7e7nPMb=O6S7UOH< +PO7r\I.Hu&e0d&E<.')fERr/l+*W,)q^D*ai5<uuLX.7g/>$XKrcYp0n+Xl_nU*O( +l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 14 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 40634/Name/X/SMask 26 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkVes+!3tQ:ɥaA>`APQ閽a4!ES9n +Q K.M(ю${~Ȏ] 2�����������������������������������������������������������������������������������������������������������������������������������������������������������������:\uL?\W7T/�� =]WvmxsM/2e}6L.zo��@kj;j߿oE{��b{76i6��Q߷ҙ_Οj?C_?ݶuVuUU��{NM֮\(;y#=eI��qwdmΟ?xEm ��\?S7;~uCnn=do.{)?sVVW;c1$6yOZ ݟy'L8'MvhnhѺ<1cI{hY<?}>1 _za ͟9+7u3L=`q?缧}-mӦ_g|E}ڲroG<yUE[s͜F1?}'.}UU.޵n݄sy>s MMc.vtڿmnhFY|θs|θ?(+y.g9rp9rp<V/]VŜq98q99kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"y~iΣM3*g׏5EOz= +~sꪪAl?vԡci۳J뫆*gEqO=GX=("ywl}q#Fswu2f{WzڱvAd?DT\8g)E 53sO|eE 53orѝ;kD"@*z~eI�HƝb{S^=~@#@*>=C^-z�׸?flC?iPeROPi<ꅤ(I jtFxQo r(rEkYv9Qtb&Sm&v*/lyv6dgwf~ks?�x &� <Am^7.?���<ݢu��/g%?���<ٮ}w~g��]q=|���ƾwUz$;Xתzt3]2#���yO?nFە4JRNpRUQ_g?=wh7ΟMv<)+ ��vN&iMH#y pw(:},J���ڹYSgUc;S}ʘҴаeuO �=cd*>qQ�K6M?.ʹ�ʘ(@ѣ�[0:xQ]=n\8�|U|T<?*D(�6rZC>BD@͜<L= +�aj?RV$<2M(�68Ǚ“E@ǎSG/Ή= +�c?:M E@+ϣ�FCIQZ'ja L}]#QҒG�hQ޿P {l̔_=�KU㣦O(�1+{5YE��~ gyc?6\Ȟcݵq03��@vۿ{Gr1 + [E���I*=Qj4j+Z?=���$z‰*Pi8W3��@Lw֝G@M#cE��iF);Œ�j%)_}q���4-qQMcn] u5>9g�hN' E�evYM}~F@McؖyRqG}S~{m�hhS�D} gĹ?7mbX\�Pd)+9�@Vcpci*q-ǧv7[u:ѣРN/mx9�@$orosű)ƹ?s}3&N=� *;v$b9�@&+Ymzj!;iD@{<keCY� Rڪ^>ܿPOc9qg=93\1�DۻgBSnF@MnUѳО۷皥7��LeTPc_WZZL شٯ'z�>ٗ@49Z�h̄礄y��al}Ɂj4P ;K(b���4%fnEN?F_"je��hIF^厼PC>Uw +w��@Kʏ~Uq/?& kEFy���RMe j5X}+j���Okr^?VǪ]BD�� .){P#<sr}u#��^^_3WJjݺ@h6{sͶ,COϑt:/ѷ�@E|z)}뺱AG�j\,Ij 6ܖ0j5XȧP{͗l ΧCmM\wikK>o<V.= +�TS$~}]y[uNF@MC˦@-"S#|M1*@@}|gRʊDѣ�KqZQAKlql[ '>'tϏ}�<L5:s�{IR[$jVqt25?ު[O~G}eo=[[-,%G�*&IbOm?fCdzۗ*ߥw?6[`מFx �F6o=�JS$lw@޿P!e󭣿zeUęi Ұ�n;v<+z�p?lIZh?&Oꏼw xRMioDtzPV@: Wrd=�BƁyNP'Ǟ_p>k?>)ܮ3p|V#ǭ[8jXW?X>f5fK2ZDl���=zVI>x{Rphد;嶊hL)+A`V"X  h1^ xVdEvŭFѴg046әV;/Ơuc3}o{>ͩ.+>tbb���t bX};ݼ5᣸f16/)i~zKS-H)u%k* q���-iNFS?꽬<TĻsHbǹ?MJh��� RNz?Ecf1&􏍚 Uw,gG"(s<4���@g{LnFu2er7hT4EEf;+D;���8W{hV4/C�[`Lޱ҅]{Dw"T~\.}t 8Ѕ+����ih#Y,*o3c(5I-!z0 DIvxAn_���=Xq9뵴?:1(F J,s�,ٛ3]y1�Л:#Ni a`MuhfJ;S:3LD(~U�6΍?^�@o<⪤ڲb̪?[@70k1Xqo=N'vx6�*^fUW�ޒ5Yh91SU0lcQzHLJSxw]%7L0N*W`uP �^=# 9zvYE'm,$]X8ߓ +qoK�FgoN0,hGZ=#᏿u@oo<]]<R��z vZKץ!zg06EͿ?yf}R;FP#6wd"r~�}d$w}��XB獭 )#MS=ttcF4GA._;E 5Z]{m(��s`yr!ss M'{?^7pl)UŹQ< gJHW QDR\#i֎ʌgv@>ߴa}�Թ{R#^s:E;f7T).K+\PUyZkCgJ_֍];4$QEu?$8O3���s-=X1D7_3_IA?$Zuս-!3X6?[nmI`JCUD#B;a���]l: |Q7WɘopBP޶ݔ24UV~uRY{/gsp@|(`m���=dH9ٵQjaXj_}?X+^{FN"]7"0mqp5��.bcX`g֕?X4km&(U~yFq.Ɣi9^2���x_ޮX].X _jMIzCי?R[ƜT}Ii] 4t#@o���sCw !+�rᤲ⬻@ך?"pdPo=RJe |gO&"y6���t"hKDj_ۖ;@_H>Ry^/<m?LW^i߻U{F&ĉ*^N$qbs99g��"݃ec<ތ؜^$"ժ +?|~KvMɚeK-`F '\rnB:0^މ�wm��Sݣ!+5Y^lNC�KUW}! l=]~MԪOO\1-(+躺Ce2x�TnmjG5wړ׶/[{v-|;ӕz(g}(fj4&zt< ͷi 8*/+ڼi"u��b1='6wʷ1eB�KT]M۾|/jpNFǕKNIi^ڻ|;@J9s t¾im�`,A[woo.*UasتKٽ\S򞟑MBG'ܪ6xު`cT+v��c-, ۱O\`M?X5%j-є$v~kJSxo[wŨ^�1\EHSfVMQZW-&>QF՜}% 3%ciA޻9a�`Aʦ4Uw܄%UeV}5ɣls1bH)c1xk +9`%o0 TP(uou6@H]%mMU;->g[ԪX,>"((QANeJGYfcg:r3W;GH<{ܭ�@sz=.LXj֮Rb'+ 䚋(M݋~[0p.xv .,804��hJߦIEs7`q}7~_̻ #ܣVs=Be\ŷw޿���`*X?LUgak5ZRqp-"Ȣ!rE��gHÜ@9SkKscasY2Tf|XywED {FS*Y׵ߤg\!} ���$VkǛK a�=>oRcw2Du'dt{A!(}$���Zĝ4=.%_5, +KN* '(MqSߣC&N?x���49Ʒ)3vofQ,љJ=~YkAE\8. 8/$Q��xDcۃܡ-}^ +ei+ (]Ļ". {F߽7)2W"x��zƷBΙ +.6,g�)qd22l8_yNHb)MfJUGz NGJ k7XUxy~+��| RC}vT 5,jJ 3#woEaQO&>aíw}x��ƶǧzK w�)q҇꼪8JSxUD^8=jLVۿ;0b`n9h�ea"V}GX�h#:3Uɾ͏ "Hlj=%jEx5hwS#y�G+wQ;KApD�)q`y|wVNѰg4 ~#ӦBA3zwM1��<$uuwnrT�)q'H?]]رnXJgOh׃1FXiQ +�C rHKLK�h3 d_'آ=Utˏ<JݤOV��2j:P:!= +eeq$މ Gk{kݸܞ }<;<v7N!>��Ԅ|R~ɎQ %׽~WE5h34N}~qL.}\;ss%?�Dap|F'k6E2wϔՊ["HCijsqD}t�,L}ְ2, +63ߘL|]AڒXJ<kG&O��l(nxBN^9 +ęRSZ|sᗵF=A1ZY=xi��pw㻼us`yPc"bh3iʷB>��` +",f;eџ?@J?߾"i. eLQ/n+伏;��A\='k7=?�Z󼉤d~X n H,i"3'sB*}�̦zk?�Ze1ESqhlOUyxدg@?׀�0Erbtc՝?@Jx :pk :n{\^\ؿ�h{Oݭ)"c@d_Eх̳/"Xa{"Fdr+.٫W*oe? �zJ?43�c,ڻiTɔ!Ki2{P08)(< ۹fuhy~ǿEھ=ly�<Ewg 9URxuўMٛ?@JxA~IjJ i7?6z"ض9G]k8tp-6boǿܻcO�$Iq;gқX�h^e];\ąV86v x_#եo[rT� +H?ORٝ (}MA\1ZT߹^dX0+Ů̟\\x_5~#?O�b s;Sʞ�msE*S7/ACN,CՁ φBi/x?G=lp"�p0}qbRQS笿`�Ԓ+qo"ض9K}<a|{gOMQԔ_g%ߏ �"Ӆ gY]Sǣ/aљJg,ޝ A$#~|}.1ILF:wޟ�$SxO\Y%`�K E}(~ RZ_.PQ f@ +*ƒ$(-B BA-k;ȢAsp/3 8{M-"qw;{YrǑ;m|wߙ{9} |XǐE&KvnH5Efc,�@2epd,^}�zA]Y=״ B1s7 ^t?"XǒKԂQ%�@ +& +Yu%LHan+@4TϙY@ًuDacm=�y6=w]7IO�Άy Bt(T~.q6$BP=)9J'<wW�'φ7nږ/*`ٓ?3!fo:֝ B=c9l|4ﵴ?czNjՕgbB|KϜb� \39tؼMñ?�RI-zв{Dq+ŴUC'I6 ])NNHi]^|dMrrT/�H<0(9I:p6?i|rAu1L$б * s1{X%B*=�lԆ> ?)g. ":}ѱ{ͩsƖV ��b1>vNYw$LHi)Duɔ@>-hf~K^㆓>{'1͊9Y+<Hּcez{ �<\d6ρ +HgGLtcݑ?3!)7hl;^}uȘ!OJ] KB9R=>`%{3z7=YX5S|0x�!.B>A 뎄 )견%\%С 1~*:=('qD&Ϥ1QA>xWyc\@A1ӶoQo|57:!Cz5;�:抲);Yw#lHm|CT,|:F`6/7<rqw%kn}i>!:Uv5f*;/Jki1h�)f~#}/u>n Ua<~!炐#B |MM> 4%teL J J +!sH`��[?rE;pF?ٛ\AHeݏ v3F^aP &Y0K):uP�lƖgh4̛XSa݉?3"1 )5W3KAR]nUݗX5oVXA_%~k�Ց3OrK^әw"HqPUWa1!dgIYcN)yCn 2=>NxO.BMrg��ki~+?"w.}fX!; k>7ڶym9iy=8[|Pd�`Mʧ@Sa݅?"4Ԩ23z!N{{EM3>$Z~m�U"\hZP_Zúa�gFd|xmlAXɺAodtOUY39{ӟmmgެS�` Vzy4pV?Xw Hy }34-.4c݃ 5LTS9$†fs7d �1bg_SqCg0@QpI޵ڲu+~)j:_ZmP_]u|RJ)<c=3'<3ك~ﭝ>rK9BS�\s\?c|`Lex=\zQr mӿL~=Ra$w~CB. :߳Ed>xlUɚ0Afp�XQg +YgLtc}?X_znƽZ/OURCw?ܗAsc;>niIK$u9,L}�`=z,4.ի`�G!szN{m5@>AHb݋ u uӶ*1e>«[fy'�`=pBEI;p$Kʺ_~a"mSEstGXrgݍ 5ӫO_ Cߠ/>-|liP3y�9]QkZZ`�GPRXR;g}hO,ܯu7΅wo<Y7uPMAZA#��K/LȗuJR7u`�GcdzW׽ܹ?R^_&vy;S츛κ#AmuʌKw'o%<ܡ MB<�d3?g47kU_]8’ݯ?ӹ?b9J*uOOuG/uTy!n4mcHN1 RThH4 2l (aGp +FƸ"ig4iluY\rs;�}k*d o{OQbP9r%SCHՓ_ 3u~vy}=Mc?0<) +ۿ0mzKX8kv{?2i̎kuOXV@QY۴s�}k?o]4=ͪwM<FnHw~=+o {l\m`0=6l3c R]N瑽לg2?0O 8F_4`#o}=vsapK G}޺[/g �ONm;I[= ݩa ?`0fOggn b|Aq#rii/MNfcm旕dGu>KBRپ稳�הh%:?v ;jʦed{'0qq9ѩ100QACKئ!֙뒛za8ŸU~~NF2sÆ33ogwʯo~ިʯc,N#Zߔ^&OP~NjӌC+>a,cf|FG3;JQ.G; ljC +࡝ԇ%ҩ ƒ'/~Iߴ#֢wۿJﱴ'hߥSg&�&s=+bu3?/inVT{gv<< gެLgx>#n1wvV#ruAXX[3=*V3w̛ccic9쀬v:3@߈>QVceRq_}'y}w�,X2J +lociC֧(5j]8_C�wϱ8Aڤ7:;﯆(Xg(N6ye�cIc-ԙ᫬={cuvYqxqhl:;`ťSCF�sg]KҊ:Ӡ`Xb>./,uD:;@D:xhԞ1|<%_ʷ^N�;?^Z QLKk2"^ wpO�g\8w/1jSߥ)Jߟ 9'�#u?NAױ1yB] :_[I�g޾m?P%\m>C@8氤jHS?0u,R 9 +�~~Y L}J<?E �x`ш=?0jK16]MQ�`WJ.RsiJ�1p@KqPs`4?l5,\z),�yb,IBK!WY +�)4Պ@K̅QXrrcqu�BVUz&#[%i/?(s@�@EzFMccKsk<nS�\ABKCznW&R)�PiC%\wHO`4?SvX~sq|5u-<DeG(9R_a\]ЛI܍>S@$nW*- +=QӨ,$aU�н_UTHQtSJn3wC#UK{;\�ݻZ΂>GO`4j=f2gL's�t/|tIg<gFkn[ML>uc˴e{S5aYk멳�tOo;M8cVd1'zϴnʦs/V�е%t׽rcR@i?g%ݍP+�ZJI4A2R3muMֽ6:_@׾7Y-8@i?H9O_VtɅsw�˨4|gf7M/+0QJ{$":_@dGƮJ}Eo`4j,}T�-ܿ oޢO]_[Gc[2A<OR�5 n8sc46?0j5[=<?*Y�ц%UX'v`ziO<GMA9 �: 4"PBi? wpO�Q5ҹDcNzqA_:lJ_%:gX&3b2 5#t!窫�h15{F/D_reux1}=(sP)]@'FM!}h^u| uV>7ODB#x:Yw/P-�hetb)daJW?0j5WYgr{9:s@:ɥyIH7аџ:s@n3VZQQӨ{IY�|Bν$P'A?5( QcDbU;q&MIjGR'J(ؠeb\\n"�&Dr9. AVQQT|quJ⿜C>UCeyyޙG=g}$nQě5 �ᇶOԷa(`x^朏>ן^�Zt^"=o-Lѻ^M�F"mJ֥B"v~z:{h]zґc.-T36u{N,Mwa(`x^*VZ]eo3@�ʃcᶮ u`K$VEUfWAR)#fyQ߄ix6X-y=uЪޙ옵.OZl떑ߕeGk۔i3V~u5Ǯ' C ?T{+ :Vv:hUx&R_4{&Z4<TXt3V} 싞>ߚ:h;cViZgz#MyԅYJ�z'eEMix +įb�Z{a~ƧݬwjM_'Qߔs'ayBQ<~o-`xj{Is"`,:h핧ͥOÓwjӁiIdcq ;B�䨇 ^g,i?~Zh =aNS1�-MW >;.)C;_'Og:J�s5)^7V?0<*ŔTtTƘ/u&ЂՌE{bd; /q6-yȉsg2�->CN3I[B4Z^ϩ?:h$z_Y>$;\+!oɓL ]!W{93P2�-"Xsgz#Jp\(UҙSԹ @ ONKCæ +\DIR[STV3˖Թ @ Xg]S-`xUHazEl37|µ,ϡ7vmrJ;SĈY^͇N gE ?0<KnBlu:]vw+#9꽧gOng�<Omn{okFKCo̍++nQg4�^:](nO9<.B"Ȝg�Aߐ i?V$UwӃY W)sH +*YnuFhk~Y>]i?,%K5uFc~UF+tN)Z3}Nk +2鏩u}FkC$aVbb,:?QoGjSH uPÙ4�޴z B"s].FcjPH];7Sg5�D\?ij 7'n}|)?n/z}<uVڕ):g].FCgؿ(pg,:$E6PHk*(f�O̮Ю^i?Ů䲾}y nU%Kzg=B$̢X6.*. rf-}sc}w|8`xU pi 3R6�zO\}.0Swc0N=?Y=*eR{`x-0G}Q6�D]mn+N_b2`li}KzyˡeUZ#~7 O1.`P\%Xgs�(2MmIN5I}7) ֶ=:٬7onFC$aVb]Xuvgn}XHaũ l ԅmJr`ZlύI?0<0voo�l]d[v`,<w_o�aͪuة~zP27 p�˭5tV`Sv ꭚB~31h(]Mo�*rх8iꝦi?Ů>]Y:ثft[wfDVjLc~ѱ^˙͍!g*tSc9޸3^n +l+UmEzߋ +.Hr9΂p!,"/z)`xGV:a}wYި{xԻ<-x/J�Mg(kNY:z)`xG, +/S-Ưt"^|G"4~4,`o%}ENS2% O#MrYjƢ=n/T%RHaKoKr�IJNˆ-wz`F8qp(1j}\VSZRE8):gV;N�;c v@^wx$ x?riٕ> V9N;ٯ(3/(MGjeiGSV TR"*`8D{]XXdVxF +h\:mNNLd&>f~ ?#rT +ۺeZ?׽aa%JPn>s?o>կҨh_&;W]+_G-=;Tb쌚%:2q7qbh۸G=^\¬3 sQu�Zker=x2y~ev +)-*aԽ@ 90c#W?0ZźKI}ǃL9y׼9_E�dYS|%xtunvNQ_5F'S:�٩^HRʎSV?0Z77fU 7ӣ޿񠹉z3Yz@f>Ԫ=skcǜR+g;�5oM|6xPV?0Zоi'o<=x23h4^w�2 TqC^Q`x=+E;&IG;{;�w6.(םc֣G7ϬV΁}}<ܚ1V՗p S2咣:^S%ɢ]GR;�Y5.b^5eMY`{ v3b99vXwɔ{4 bե-@VG-q[KIyw.y.q5y@Vܲ`EU"ϫL`=^]z{?Utf<n?*uʎHOQ0-4*7}8_K�d3uVpgUJukwCWΊ~^շT͡y�5J:DN&zӧ\Z ?١g?3v ΛlF,fVu}u͊/og;̊BSLIF0{E}ȻlӞ|:^ +Ӱ`d=YYNvbmru;G;P_o|uI{UrޑyL+ύ3fS ]<K /_Rw=�^$ʳߢΩ`dl#{^Y9ofzax4 |}}@&Uk1jf#vYNcqBWŔf6=ρs\)}.<k5=܃'<tBCE yoCeGc6Q ]HsṆ|�((.uFeLŭo}�2X}z7F:4Fo_v~w u;իΧ`i<^u^\4Ǿw |i\9CM-0uK'R>�%U곡ɳ)+g^tpTk.먻�B]u.,8#d3uVXC +ΠΥ̰`itsYjPy3E ΥGzs�S2_]޳Թ3 )9b,Sn<PY<qg+tps<i uR61%ԙ3 {%*EU'; �g u' Tc)~r4@ޡ\{uJGa8`x2U&oWQ@� + +ywqz uA!=FUPPkI2&$RgQ `i<__R@�G[V_?uR9< 8͈^m{:w,j3 '<eV)5PwA�G[u$~ҵکwAw({ϻRwA�GaG1SaxRgQ `it8zupUSe/e[_aa>@w1rOտ�ta%k鑞 +gOwȫ\iQA�GRMw7/aCoq_<Ÿ.<+7PA�GAse{}JAq9ykUCηPwB�G}ַ?y۳T&~IQ.w@wYON N1VoƏΟ`8`蜁gR-Խ?S+oMWcWaO; n&s�珴=J?-qyJ٨<s:M +t7wSn=?bu/77cՂ%euƙG޾YUC濜3QwC�{U*MQ)3y zS;E^y˒RM IOשGNk`itM1;\wݛ7!<L"QmXO}嗲/uS@z|!g0d>5k3uƙGLݳU_r;"~?eizWSg;:t `/%zԙ"g]Rsb*`qN+y&`<ݭXx.@AbcLi3 [p0 gد3 KNS;&uZQFk#^/DpEDDAEr[ga]*$REPifl&4Maw'B^꾒t_lޭJ,�aИ21d2uF+9x; uG=ږ3i{<ң+\+Xk[`ʯQY`xyj T|wc}VF;yxR)] ͧgPl4iX~ R`RE�kRQ/ 㝃pƐªWͤ�j=eUNRl4iXOH^*Yw{9cԝZ*WbRX)cǽ\`-$v'8SkiXc"RunTSwF�kXƘElu`kƾ$ݝ` epNHa]{S7J%ySwGսd}x%r=y}w`&Y?:[<iX׬uEݾPLFj索Rۙ<[l:3+K ھ+_<uwg~rZl�a}񆬘Bءal uҬHL W!89lﾣj>JFBvx9k/ux`+wiguT;^Y33rfhJY}sxӴC WOn|3 m*W4yRHxaN<=l_qS#9lũﾕ{:C "Xf4ism8<I_D#cO[mM,^3<Oԧ5Ya+}ȅ&RHḾ^/Am8x; Ru-ޘGŠ-fsQCf|o 04ޟe3*A,a;æ)w]I,al{s q ^>-k^ ; n]I +b?Mo`x3go֝?R/_�Ob]ʻz̖9(@7,vPÖn> $XNs:GiؖGzt~S Uպ*Iw}khCjijiܻE-ϛF'ꂇ'<<G!a4?lk<ؤFԝ`ɗ 9IQdcVwB;%Pz5}Ga4?l++vE*&cԽq4muy NQ䂿J9 I;^1`x7o`*5>O-gub7x쨙[Cvn 8fYl| +aW#dl'uLFS<ܨrˢ9OSwK[G ͦ ϰ`xLP.TSK9'_L6fRg4cN6kx׋_ UU!}|33uu3L1EؖrYQ:/$,HtisdW (+[ `xXt]Qkj{&6Jy4y'A?Z6LG_y|ߨ;}Se{c]`wKk$)~ ȳN +geݭs3g TD+)!&Ί`4?Е:ʩ&@ -|:'q Z$bĐgll�䵩I9QEm+3K�h47 +Sgd0]߬ RŠ2[$ i 4r.EJi߬uE|_�XL LLfm>=,?i=}xW'.{^_Ki8(giF;A/[$}3xI++v&9ǁnBWSwN�MMP|  OƜh1ʽ~ZH;dQgc(bG6n69{5l_F;8PgCM`xt9fC 1yu.h/(HO}{ ק_15RN�EWPBm`xt{폌R~BPb(F9Rs~OPd[`8\  OV9/G{FUØ'uwc"L \dԧE}{q YN3Krd6:j`4!pru:dn-+Pm>=cّ簧bC^-;BAAwO @< On.4-i^zر8u#uҧnHuy]jm:;Zg0^]T1*q%T@1˽\˲˞| \:MG Q*ֳ6N-:6 >oy3(r_Jwl<#8Rӣ;X#tEǟleo,'[m$9++A? +>m9Y8EYsl1x)rl|{-΢<hپ[0ֱரHi̘ax<K≚#�z6Oi,K[+'u(3ΰHiCuSIa1I8G{1T[4a�z2^ΣȽ|޲cR_&?!~J^7e9$cvs? :"GF|27v z?LHOWFL W~Lk{c"~(}IA.쌂`l/ޥ�~yO쾮'AR$}O[vhN~wGS^Zsi#X=5t6EPa>5>r }aϠ)[]`qZ@G?p=ḓ"?%Uۇ +J)6]5^ȏڠj|n7CgS$me: v^{GۛYǶ~iۙIy^Z[0`m>ǿ/X;3*ueC<zX'%f3>(}(}4:"i +sN˞ [|w W9,ߵWb\7AgT$M{'9 >yb<=Ѽ<f,iWf;O؏ʏofCT$MIǫ:M-л+rfǰr@WUӠs*\৊ ?p߰gztƒ,/'~(}INUiUAi0tVEcsZCzOGf[6? 599I 'n\Cл۞EM&♳#1YGl3Q(2ժ*_"gh͝WEaw濮j*Eưb9z{Oя@@Xe}>"i{+v=wg,}=GL& Pֹ|ͣuDQ~yC_%YUUAi0tfEqI^=9{ý֤A2@yov˵ :"jg̭b9 {C3f~Ct0 Q?MW3+qSC<s> ]ް:"HH^ 蛰2FS:i!~z}I嬂܊nU*t2q[ > ,PiK> -BF }n[^B^(ήK|ip/Fp* >"]O!q#uX_ciSP_߶ רt_`YkC+}6! : ^'#9{ý=9ίoYi8zKw=h_n-cI^id?p4?vm +JC3,|JWËz %E0]=|E| Vv;?f%)_`wVk tE|Z?M$g~kw|s,ӭ1g'>#T.|NAitE/.N0u '@XԊ4]FφGJ/3<})oCgY]5^ zQ *+tE>΃Of$zB1z68RIqγnb*͎;"J,2V|k?|E(Cu +m2#i!~i?>[Q~;tUXkr;j :"~={;9lNӅyAZćU NS3RG\F }1 hs:">8Vۢ*/J]u?p4?4igIvD^:εH Z%˩% !Z="-w;^ݱ|wQa`W\FYUn[�9_9zo{8#(b2lĭf!KN4a{~ 6B[$nOa{[+@C o=nv_s|5qe[=?p4?cJ_o͟ACoޔh/ru mDl ηHr|)ƤHimt\Rc7O<Q?=&SuQ.ݴ]l[ՙjŢHEXAm p* ^P" ry_rU*^l]wӦ%O9x9_umr|]oFC ϥΫ-Ef2+ +˨C+ +;K }mͫf%ݠ+?Q1<,{pox]FPgֹ#gn?B< =7c͊v`nkY`Jˍ̧.hO溣zmkߚM=#x" `iÇvL<G_S]Ж e%[$<hGuA[:7uFa`4?0Tz+ԝt/+f +uFA}ؗ[F+}m]uz( ~,I+{=iԽaMOPߌ>}y1}H +CO= iR+ 󫍗]9_C}3G[u>>g@,B{XO]9"7gЇ/oFO/E/E˙ԹV2E@˃?& % ėeǖ_}su:q"mȉԙY'7z_SΊC hLm d?\먠@ ݞFIa/R& @kO5)[{@I = }U,u-<O*NRgQ-1k_SynoY6u5n;w">ɝƮꚩ{0؟+t5R:IEݳf8^&”|e م  t]|_[S*ƛ9D݇p)I!ORP-ݱ 7#{I. X\|}KQ9`ЯJEw> } n<yrIJ=qh{њ\Xbq75'> ŏ}0Z.N=soqӚOηSwb܁liR[7?C}/ZY;B }cd퀜Soc7e%ƳԝÕu5;$li|'-r"hQhAv3^ B)eĹO?== [xKƠ>wv]?:{jrwvf|^H<s1sƷ\߰`4?ol]YܘY_ʹ/u?umlVNS[l3>H<Ya%0v%@nyQ8侀`p nGyԕPڙ`ΊΜ=cVèCY1ߴOݏA]_t89O9PH(ˎ7[8ȠE6ɦ;%uހߑ=j7\;2~Zq5`pDx.|C#uOuw'MS# M||k,yOu|W:Q1v:|y@]?0zekQ;u[2ޞ5mE:50<k@Oʒ-Jݓڗ1"K][SRg ԇX0E:|+VIK2SʫQ,Rj/k'ZwIe[ );jJ[iqWO}JxGqwl +uWԑ֮?͘/U֮wxi&xB:n\ c(`p<ң^|Ń&Se7=׃3FM,”Ԛa⤐']Ƽ׭{?^G%g?<^9xq}~ɜg"FZɳ3[^hXl9Y ;Z|s]"WC`4?H,QQhί6^v|uorN6v t!hQ1v-=`^؝$sFy$sꌁ}`i8&sqJ`GJ:,Y{ڳr$1{3ݼiz瘵éḢJy0uw|x}F<O+ȉ"m^֝r~CԹ`p\/-b?ִSgWڪdc׸@\\4*708a::W`_?0z-8MݡakM JN<vƽ9/cdy`plcdS Rh?ηwx yN Ir '0mn]y`%acE|~0uzN6v=B%.ޜ/ u8=BPg h`iTZR^|] }'b9ku@Y1.KC/dJUzK%':C@FO}XlqX-un ]>:C}+Oy9>}_QQ\w^<D1iMiMZT->#CPX@" {fwg,쮏AkTVlrsrzjtz,}ܹ߹ʖO.ފC�>I?�#`5C]ϲɸs5`.餩]px?BGIxԀy "tK&y,�@�Y�Ff&*ÿ8.DٸX%(]q#\ {>#C@3n�x&A�L{"?lz5|6l:BMrR> x>7c 9J�o�@�Y�D{UZwl NF9uM r@~Sqk`tFïU4)c5 0�~D܃?ԟd ~,%$ η'p@q#n��Ț krr`-&l6zn7K+ ϥ-s6,K^{H^+�w&A�F3eΐŗ.dSwԀ[r^,]&}"4y{~Z^5 0ۅDe60TO#Lr3̯460;<;y`=p  k`4cJUEwVl4 <!{6=!=X.*z ]ǟ'(W@{eqeC#q{?@\Vo'$'x)٭Ru+G=<r -{S;wO>ASnq˱\4P;wm--]�WNAb瞭[J3Emsm`,xM>r?qgoCiP&܋S,IJsX;wq5 Խ#p&?@\Լi3+H_8y?hT ;$7Y6 +we6l&z^7VRym0~񭮰Qrإ}p .$5eV*p4pd<9cO\;2Y7u4|r3-EGܞ� U(O W&Th/딐 y?�s'DPw׳l +n4Q=0�롈M{D;*BH[I"p{6?@\FJvR Sڃ~yIG0 \N(=|ȲIJYY .OqzXUAYn6]m^¨ޗwL6UU]IzF\0BSݑ_vw5n:i5�IG}pq[ó~: n�hE<0AϹ s4R:1uȵo@۠q?yͥ^uSDͧ;hKTy3KNP1M5MS.io:DHh(Y,Q]h-EV9ksrˆJ:}&s~IP)'ְl<LnK4Q/xZ8ĝm%V"�h5ՍQ9Ldܠ@=~ȵV~[CYgĵCj9sX^[bhǰ北Ńogq}YҫQYI"LCݡQNSMGNբ;ÐwlZ-k+DkoLaz”7tJNс4�u}GhwY2:Ws?3ePŗ.Bf4h+w `}!]ml&opg2ӠSDcCc6أly~"{D>Ku/4sӱe OPG@]aS^ܤ@B n2”A -- 5lmh*ɫ3I?QT?!ƱՇw;c5{5O;|Gpgs[ Z Sa/ևkeZz)?;wxv7qr״a/%&) dn嚃^F5{Ck"n3|=$66elb5$]orҧc%LStmt^9aCUeB11Q$e _\QWm:ML̽|�uFqeqsk&e#[ ^ jʔ\Ai?V44}X?@\gil wWW:iA~^]LeŸWgF-7�bN#P?]6IrQTK姎 ?/&utŹ +(v|ɉ4;|>\Oбg:q|kݮbn1"Q]cx>D:˽ީÝѭn(MɮgW"gtkj|}+' oX?@\+DYFBV*P6Z9/ vP^6F~GEuqMD&VO|V,RT. {qWaBB1"h?muE^ +{9?fvov+er{>+d盚|2J_(5"źhqy"O8'e>l<MCsKR/yH7i/�G>?4Fb?xUB΃t<y,FJ%k] nzڝ U3n<ZV5Pq=p"K0/f{L\Uo +QOh;~!Hr*K+̠Ln,XK2c_ +w86A`q\C ,J3V{ŏe#Qkui K($ti\GNP:ߠ=}АQ4O{u18?^f &cERck[(]+v'sg =z[+(&?~ۂn_$n^&p-X^߫|DwZ:y8mPs̋[[8z7bD]gk>3wv.%ދO,x;pQɶLCyyyY8 z]-}cn<c !"sX ]oվTmq&;Vl2j'R.Yj(póߊ +9RcfPu>M(A4ԷRtkq]6QًQȡn m=ǔ`.n Rf{2)Fq]CAן?ٻ'835[C{bX_\z8Epދ3VVDzQv>c i�73P2aEZC| 4d ޓq].,}_7r;=mE`l_8U͘OUyKuǮ+K"?$ З%9%K}h}S +OstBFY3m9=|ַ"[8zRTg$vc7\C?+咵v=̀͠\'f�<w|ɉSisQ`O1\c~Fhs &M~{/5ʼqPkKMi +v8~/QjipS̙LQY]3~̜J&yNO +~?Y- M[Y>|؆a?nZba`Mv2k.MXgԚyl}DoNv[4x#aF𼙌f0vwunčq,/uŸ>S ;Xg$(M'0I_ΨNR:hUܸ d l/0VyG92=&<<n;rFm +3~TA.@!Kލ{nlly](ϲU )jD5R c5*1|w|ͬ6?@]1RF냼<wf}U{:&wE(_`")pmZbzb8`5IvjQkyWc%I>B]Geky 4yyz=j<( &N@]G P+lɻ,w%51-m3r篆V]dĹqJniP/3T}!Qy<[YM^[βѨu+IJI^lšl}EvY^׻wkNiRS`Jݬnz[M#jm +j>2.g�ZJ}Zۻ%tfMBia8`X3?L s^S8<u0sNѠ*ޙz4OQ OpV1a/rXўI}P2ΣEY(u%X{?=)xsK* +Mp;e5wKCEsw2W9IkoX xk]9jD ]q! σa 8?Dlo`-ŴL5ss~Qn5y u%XʻȯE+F7X6ҦɮM,AQkZ)RC]s Ƒv]zlЋQf"P +_pFM04,Pݟ ys^gmM&{}تDmM;'Kq: +X<w6猃Z@Nu?p)J'S{^ݯ|^+B0JiV=Ħ#yb$>�,B$UӔV?z,\$ +QpF!dB`-=ȟߨ0Z#gVȜU(5'hpC2-Hh?Q(ڞQ1lA.ÊLs@/QMp>f/(;U#V=ʉjLLS¡ p!tA^.ٝk4jh|"(sGl燎L09{ޙ'uko\$cbѵ4 Iޢ-pVUo3_~\z|M,-<Ԅ,#ZyNj}/;bĽؠVP͛Gf ,oɚu .9ɵ:Q}XTdYȁ3 vGrݟsrʺjB`糝A=Gn? +:5-fC4EF#_U9}SO1t0xR4ٺ6TfK9;ٯAlyf|sWO~gܭ=AWl˷Rq˥u�sviTegºty"�c�Y| )کy;9y3zw:]9:<MCѠ=Ë6VC΁.+ūo.`~Ooɜ JBg`lt1;^&[6ج,c<V?iWsۅw#-`vDh(!M|%P~/~m,^& m,QxVO~ഴ{xkcĮ6Nms-Z5}ˇ|9͡x Gi*zT˛9/ԜU;ևuʹz8[*_Z �XK!0? z{5!�?78"GS~)~k:f%7үۼ ="#<r97&+6G3!?"AXj?*+8A<Z^:BR5;~]?l8+Z] +~Z{ER]eJ1h)YK/>1Ga@<> ]"4VGygu}fݒa>)̊s?.)zUmk-IDvǟtOnI19t=2cakMsMu>~wL ?"AXj?B_<~^5O:FJcs'/Wf8QK^AxM8g9u&iYA[ľ NjVJs>1ٺ:rteڂIO>0vJ%C4k~x04*ub7GNރ9uRMeGL{GJ8$kt0W9u\Gʍ?Xi )w?VNFZ_DRFmW /ςh|ic6!M_S5dΕQ;p� s^V,cuq8;Pm݁.OZ1.淥/9tj~ ݖQy}c)}8>ȅ9Z�4 QSKX?<g}<. XDfg*(o-7hj#"zVp ?>"XǙݒ Ɵ6hrj>${dKiх:qH+BO2 xx`)R-'Xt2}< |#ԭߚWg(ncbV}kkb -MKz½<8aGAnwl03XP7"gSBw悑PY}3_O4>EF#Z%x\i\-,.I샢qHCOxߜ߃9Tv}\>~}NoԸGx侓>AHyyS&X7#IlYFncE_Yqz;/7ݻpQN;*~׈rKڋpOQ4#DD#-6Gm.QO $YJ׵0&qPN]Lt$KV ~ii c.)vU8MF'6瀹ԿE7juxa(wp|%x σv}z\;ٯe7T턹P|ܶqe6:ǟp#ᒲ|$FD]4#dmfX<EnF.1~>gӻ^xA='"AXj?Ƭ\,4J=0A.i�<>͡xyf<o|5gR+U4apvt|?̆ʈ$ȃEs>O@m{ K;9Þ ':l=8S7 Ɨs:<〭s' a b?KռX.C|Qu̫mrsph۽Э<.Iѥ\?s +áKr5RRWb $~I>c\8~xi4N3Qcf4ک؊[]^ +VE4*Kݽ{},$<lBb04IIg4Ue@ԅsFf{|%4SWo('׵󂣥Dspa]{;VYF3ޝuVpz><u!"�%!| b1rmy?/Po;`9~U+<`p`ȷu3ufpޒ|]Nw;r$8}fp-CɇCt?b]c@I5#Gh;YS!O2|`>Z*Z.uvp鬽ʺ:ʩA;>u}d/"�%cݯK3Y?|#fB}}6OY燧q9ѩ簮+6FKQ.X:cvmEkB@I8swL/-:m+Isē)6 fFVMa^S-D!#RZ63Ob7!m'ĝ}a]S_$?ܝ} 4C~$a':vӘ¾9{s5ƺ@yq4{rrۮQFr浄+?@YIa6pyAے:WFIh6qM9݉ka_K\k-9o8S>WF!ڱ\[>úv'Pp'j.Mܕ[Y狞u"%ĝ˼v/n#VzYć}kZ|\hԝ Aؓ@I yHZ&m7X献+Iöb4q25}#v9)wkf3\+9˜/l?A(?@aIBڷ ޒ:stjզړen;ZAJCECTRd7:5y"ٖLG|P( 8Bf'N +mIAJsq}57H4Ke_f6BT.ktA[?@YIaV#wht2D7YZ?u] kӹ{,ǹ`B.jNzo +Pp;.f>ɴ'Eõ/,fChz6z@(7ct9t>L"{|}EJkβhMc1O"PP Nj%)һߦ)kܤs(dDV\k~&/BE}!NZ@"�%"=rvZ!mB$c%YmM:y t>9N }8Kȝm t`]F$?Ҝ>j. +f)蛫s%I-IA ;n'M\SE[82“{C(wh%,g"p|"=.B"�%踘Dcio֤S_]񑤐ucO'%UL͛c|/E:/QOsI_%_ZG䙣ЛI?rW &zo%�Q"�%+\"L.E>[mSlGef孛j>{~g&?%aao1GtnSbQWOΔU'ֲu1{=:s!ѮR{Uz\;{E�J:mYBKuUg=_&m)t,љ9h.y9I5bB/oNo|?}MR4sO|I{)!Q + ""e_Bv%7fCxݟ,ִ./y2oa_DgH1$Eճ!t̨*Gϔ'F!Ttf.9fBg(9?[k?٬7 Bg d!=!�Й?�����5$�����5$�����5$�����5$�����5$�����5$�����5$�����5 W~9v<çּGV5g�����y#+ٚ{lc`РK\�{^Wo=]~����/89T^_}g\l.;]:Ǐ#>k`9xuy ȑ}]c}JyݙC?;-Xc�|3k@[ޗI/15dnC?;=S>Xc�|PbN{^nXԭk~ϔ9:+s䆇[|At"Y$?5e )suV>Xc�ȉ^H{z/l V>н +Xjt]S~L3 i\LV�~?Euq�9 (5: ֈ: +:-(*2 U b! +ޯ@@0&qd5: ?z.]p�.~?3ϸ|}1 +91j99ktnX8ߗ?2.^u/vZ]9<O 2Q( +BP0[<4!rD >oo>\BP( +5ˊit^slѣ+'>b[]rYI�����Hr +8ҧU>,+k|{�����KҦxfj  ŒL�����������������p$n$e%ͣa6Ib\)+EE҆Fݏ_u=~ eBB^z3ȤFseU;mdbź*fW$Xl5Ma˘zMJV=gbШ}|a_6ر|ZXG\ahveM | av۶a#LǩȵoE,5>4VZr2=={B.s:EzoA4}UOqV[E~]͜˸ + #qOέfx㖏!?sgun>G6c<9e2gҗ]rYCaᕮ c?Ο ?Ɩkt2gVx&ʎ0\]YVK}=ql|k|?.]si3Yo`ul|R𳬺jy ;nEG}hFƎEQsmtVeAAS$ޔz$1.k3w%s2gQSVƟYswk"?߇~c4{ ^g9ޫQ5j<eLj0_#cǣy#?|cFƎ#aF+eA{4}wl{\9 O/kd?(K !cp.?W)4;cYIޚ`e  [#1h>*a 5K32v nnˋ=ɿ)?;neb4}?6GE Y'NkKE\`å!_'=Ǧi fIJ267Y ŒL낙1QaٷIYI(KpLsS$dRz2${yz +!cQK?(-1VobylTůb5)y]%lcMQ cp&}ZU>r<tq=nu̘(Ca<=i=W;PauYʆLTǐcXv ,U]mw1PE(96eAS#"UWmF˅,h ziC.]#cp&=*Td9:4L +329{ fDy<g~{$e%t\@g~z_^7:^z3^G[-}FƎAzr}FŹ5m%&Q#[cWJ ǶY-̤=&+n5Rh,w Z{, fDG_0~>YuՎAV %`݊V+<8c*茲bi02v�˗,34Rp1jQ VݫVvҵX6GE Y';Tte vX>'IYI(=ݑ18Ұ7 �; fD&)j(lB.+lm0d?\;dxqwƈHm6lwqjpZiI]9-]OUW:lҿ [c=cnoO+}Şk|l+v00#Ba4 7Ulsc5ƹ.y2psƐoaU=*_NٶE.[.Kr G"i(I?`%7ǐ18E$IYI(Ww{/ 8+ɓ~t6s6湻 s,`F}ZUâu?v+:Z]9[f Pξ̲̐EgcsSSA}H琒y1n*QcbW1|I=_ٵ8ju[gt9'3W=g5<8dt2gQ{ 4w~Moe{ש2^/\4:ouhkyC&3zʪq0t6(_sthVINk&XEƎr|sT4R/ o?)_)a0U5?}yBX`\d ����������������������������������������������������������a ���� �����������������������������������������������������������������������������������������������<$��Q endstream endobj 15 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 44310/Name/X/SMask 27 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hke[Y ٓsggTsҰg˂)AAe>@o*(zΥfV$mRR]ԛ"*bwtA\?d\g׽ {e�����������������������������������������������������������������������������������������������������������������������������������������������������������������ڛgڿoΜT͏+T{_��@,w/1;;|vxpl3[{{��__}}{T{/��@lO=HWCs5~hܸ*��g5wgǒӣ='w߾< +uu��'=?8s|o};golzu~9ݵ��XŻ_hwv0>aj��sHo~ϸ}fm\3fu/$۰ju-koo1c}-mw~"n6iMǖu #˳\ߍ1cLړ6HE3[mao_Qw떵e湽y <V=glq9iy_{u=]pw׊?_9Klڿ{ks׆9g}TKpOʧ^[׳oOgMFkqmp9AcғONGў[_(Fkqmp9A,>g\s|θ6Pv<rU3 s3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H.D̙ٱdԹv슟Qn}>MPv.-~y :ܾZf)̜U3ʭϧ{\1qRvۢ[_T[^_qȖYڲ4KkfMm<us.iM34d +e׍ +uu1c*>�'?B?k)>xsa}e?`#{tw(~ܿV3̉O{ڼayz<Խ뮃m;Tt "yblUSF3URn}> +e׏#\cfa3kjz}j:;8~B +zCX- +*EEvձWVlWAʰ*"e\A*\ +B +xB;v;әt^isE"O3s09yL0Qd4Ǚ9-qf9<S&7͎#%s"ȹ"f^X1?Z.X(_$&ׇ Bn wdȮ$c)=2ػoh}SD٪Nn):|}_@~Qgc}[�x.3t#7K>i u9{|=µ_72~sm_ZZ*._pS}x��uk�愅9=t7ܷ /p737AKx?pGn^F>Q3~x�`נ%thl%/}cXWQu>oђ9ǣSed}@WP7IJ~5 +b67ݗK/+L T�<} öϷ�*'qZRQOW�<} (p[ue��sVF/=6ӈp���l5ۍ7͝'g�pw+Gc)�[e&%>h|=6`1;@mjmIzy�~x�<Ԡ`Qs FG7kϜ:� UŹ]?F}+ub,Y:4OW �=w6y}i}$gRh-jjc^ystkIOr& �o'7`yaЩ�o_};i xʩ3ι?9=KEn�p%",\ټɞ7jز*i2Z7ǮC^ysT��0mՕ9W?w/M]o3���bn׻sج>>o1���"ihs3;4Lu�E#Då�*",IUA[c>5ש�$9~{f:�k0+TgPx,k +Zwm򫩪�q^ˍR�Zsy;7-߰?Qtj<�&nOwٕS'g�C*{Oc@+luȑ#LJXaɪ�P?=-pcM?_cE�oKU�<jw=t)pӺmgwҫ���!L~&{ZIUg:rTg��F7vȞVo֞ݨS ���B{Y[9hIqTL���i,^ ޑ(pX���^-$0Ѷ]O$8߸bX�0~|�0(V:zL{?c@Kzƈ{6˷�CG-e﷘�q6=}e?%!mh4Nu.�jK#:-V�d,)Z_~$ZwUv,spc6u(Ju�Ys[+v?5}GZmh�022u<7TG�z{?>?Ps~&Zw)L#ç�C.dR۷5A: �2w{j/?5}G5{6o&UWVg�ݲM'${/c@kyl?dOU �CZv2hxQ�_%9ǧ[rv3QQZl�0 :�dv-oh.pjl���^'̥?e@*N+:��W0v +f@K&s+��Ub,ttŹI:Rt۬<Ou>���o;Þ>?1v4ݭ<n|���ޤ|ޢ;{Zjjn��Mnk/߬b@\C _,~Du>�nG� g@\-3G�Fng}?Y�;V38�0e:7T�Bȟ_eoh1u׼q3pھz9-Tu�^̺\~hk~,{ZjSPpx�0zuY�x8!(㓪ƾ>(:w]3ВƲ:4ӲP;RI@33AYAS6ewaLP$=k2g.SkFnnfwT~b_:;a$cuι{jT�x_:mT d~XP{3af1WM{]}@9{8r_{ #S [*ڪ+,z�h N6%!YӼ<eR='�knNU=S7EuٳwuyWzN���HhW#?7V:vXzN���##lȧ?`tǫ[Zjk>V='�� O>Yn2uw&?zT���Ñ6Kx+0sO8I���#W{ 9_0#"#^p9N-aUg��0A6nw0C=%ɪg��05uvh=Uz#?r%ݕEg@5Pfe +3Ud{,z6I� }7&<z�&=M#.ۉEւB?1c@4X6mz�4BtwK޴$@(?nZ} Y -<dR= +�ʉ쏿 3=ƥOt0CnyK U=/�J¤գ�0 91mFH폢ʲSU �2| 7S{v6yW�Hj_̼N�&q?Ne;?*y%kG{xru=zl�u TXr";ۣ9IC.JM T[`ϥ1qMݰU�.'=ܬA�`,=baΛߏ@?eMڎ3e$j ճ��|nEStw0Fockv|}Gdz|��R4|hmόk~? +*Ps!UQ���MCG +ߠ?&CY}W;u-C6$F^OcmԦz$Mw?7o+��0qa{ Qe՛?6ozip[1O[9Vf̍7~'lkC35mg=)��@ ?Sw{f}w%LEy0zV=}vi3{���Aqa{sp^Y`vyl'quC8~"A���R<@TqRWa{߱sB{k[aG<WEEj�0# @zߥ!v8J?`1o&o#-)3=ܺݙ]G—Mw~�#'x(^(�S!_oJ?`%_v\O#Ӛw<ii]5 7�8_O{q9�8 BUs*r7#yWSݺ^}pX@?6,ϧh#Qf�@-u@p0yN$8[ݿֿN {*kk>5fdϟ}*ٹjſI_gKz�@e*6@pxάrr~KZC_drO?U+;s1wWNſc/[To?i/5H|[� [z�}_B|To|tE[紻=6s98a#eۈ^*�TrweGYmdu|d.}նUc<۶-_1K\|\NȓvvϿz'^\?�@/5z@6^n҄|tdZzwJZ];z߻ȈֽekJҴ]GL_�sy Uo+~pO_vW5=@'EaYg>wr+#fc�fCv_MrEH~Icq-oi$|���5Qw{& qźK/gߢ?`$?F/K-n ˱w?도EѪ ��[ +}.q7u?ɴǵj;Rdk'T_��An_rȨ}#/{[_'i|md��#=]޳W5ZD�W?I|sQ{ĩďU}e��+F=ٯ3,n\*JTwD15VVQV֥ F4c5UI5zj[Zo72,Cw{dg=SGIvOg??,oLw9Y%)3ԟ���xj=L&:/<tCX%쏶3S~܏ʏlHK:���SؾeV.?6YëJK{p7=\x}�&zHۖ/K}�ρoW3l)TWq 5V\x_��&h L-y�8=nٺJ?�6{쫧J6G"j%��`m LM(G�j6lg Qއ̵[?X?,oپ2dIX��P*TUZ|ef;g�~8Lt\_x~~4sU%ꏶ3S^w1DMB|W�{m-\ ;s��?s\Ș 3̶S?X?d,*-;4HU�@c +&t㺹�粈T';l%)mگ;\PQ\=Hƙ S$�� Z8eJ%Ey�$kn+ܺ{�%?Ɏ=kuCcx_�z ;��ֺ.jv_Ԗا`K,l޲bseqf$ ZIJ>x(޻-ʟ/.~R"+ i#/r;AD}+:}Gx�$gR/;�<}i弹]}Z}�22n6_ݲ|ZjB-F~'{4AL y^xjXߌf=#O-Q\iūǢV JSS (zNOVDݑ +?A���Tq{|A]j?�gpGz݅g*X?,1z&dz>x(,F./t]>YW8 [9���HۃT9SEuRE(kkFڥ4H&4ZtY.zm߄N *HHN>nP(x���,Tae"љ]N+Y3ڒ{l#Uucu365^VIU*~盰闎}s2&$R(ٞ\=Hd ��f{ǕyΆ=*n8%4h*,vj< JM$޸+*XP8ǹ_모qcJ_ +NQPrp!ZW@T9{{6!n`<4^Rdv +;JޓF&Uؕ!\Z<-iN6\[X'w _]-X<ypFYZϞWtxRDd x +J$ޝ5�n6SFػ9�X?L+\uP_`I e R, >=FnT 7/ +Sў_D_<hzMKV h)^n{˳?zIYKU=īǢňnZIJ_SXGfvq{H64ǺfX/"G/W��z(ۣ"ҢS�[bz#Je_=U rvmS4@}p 8jf @!y��냍vAC]c t6p|31.SfO~-]Qp`_%U!iOJ;4"Ǘ‚y�,̞ۃ?5wmYa 1jR%-{ &v.O۹_8Fd&_TGRm@+_39�^Vljd؟F�hkx.`U30gbjwyP]mKdv +džCKg޷}*N>�XV`hRPk�Mc`dxn_I8{,O. I╣= *;M-:&JVc1JG5)qVՎnnHJ/'RxۉTΤsl=Ig g='�4/>dz }N䔬}Zl HT͕7 Kk>ϐdw;r잝Ba9woC=u$u=]%ɻ$5/J3O"|�r1gNT?�G8dFӎ};Os<c''?JRƧ}[|*dHzŞ^mf tr;?Mffv{J-]t3a\0 `nDM,5*taLѪժ%5"UÂeEUj4vk6v:Z4V9 +,,<330O<dGH EEn4fT6 '$2>6{6G6pR�~E{%wu!'w+jKԯM$'0uM60Am7j.J~=w"RǛ+'BEVgu3YK)=]>kE#Cn6U>*jsaiNHC+;5eznEmpHw-c?:ݚ# 3ٶ47I!B :~g^U{Sݩ{hW = h?]LZlA6xMu�ՏN`cz.fP}(~{0XZoW{o&D$K`ڲ? Bc3=}GdV>98 HB-mS~U7Ѽ_t� @ @gBj}H` m>y:7Sښ^b=Rg\(W;rڞѐ %Q:ry}Xoxt ClTc;\[Ni�K\�'j75ٿ`Pszc6i/ #e0BBrPTDz-LH=zOxcX"$G&!Z\'E(=КhmT��6&Y`=#u)k|/h9<~ �;0U&5KHH~~S8i(*<YۂΈәwBTwfiS(mLC>t`j4=2n�d3gN Oim0%ާ/PQ^�:>yyy/݂ Cpb_6]t"eqT#_?ÚH M�\>t|EGt kfiNycr u'n@!u0|ȤIH,[ EEIiS([ hI#?$#8|A#Ƿx$Q{eiVT[  c)gaq{X3O곌 mJ'j3Oñ7n�Sn)WMd'a C0P"<[ EEPja(@B|\[ۨNz!'JIHF6խԧARhGlhC;^}rM; +3H??f'e{ EEhI{<z\zӑBݷZnʽ9?75?GEwTF5"ji^�Iu4Kiix.qj8ۚ 5ICY=ԄD⬤-5L HB_:h--eo]m.5ǃM#}@V6HE(WyJEj6"3є8H{)6UG.<=tUθ/  gJ+?6w\,stR\#8Re�ݱ5CS_%eI??"9g^u  EEPjM'd)RYsk&n[}8!`+겏\#/1oQ7uilR0o1Iq +7"<GP?T)6"wђ-orkMrѾJsD'<j?B,&O[Ph#/ S;e 3N}"F@D`I +5G݆"(TܻH^uV5PnʽGA iy)ͷwV�^~{G�Ts.-ަza [?<u>݆v{?= =l__Ml{Z:̤1qj?PD5yK] +pdY;oD n��w7Zwz'$Fh̝;;/nCQA%@x1ϖ/(}%N&0/}kYMsӷ86ecI[ѧO8bxPg:d ޻77ZcĴ¬L7""<ǜ&  E]CAH-n̴f;1lܡGG ojϞ6Eԛ"5Wמ+`kOЌŕ:mzo(';|6+?(I};•g`w(O3.TM\kH/] d EYowj\-M0 +'dt<E # w! G8Ɖ&ܓJMZf~8isBlu֗7g?ԄФΨg˛h|otȚ:t.G8BA- wT5HQ˽ݼTtH?Q?ž-Mg9o(jr*BTsey}F/1.MK>o?S(]NxFk"VchŠI#*U]AE1*+U.{)<z6vJ:3}}oE\eF};?7v3s@{c8Ń2:GzG!/9y Q +ɷj5t8YxTY̷#I?}^+cP +o#҂>uu{*y6TM8j1ְ`^ ++'Jp"+RUQךb}UȀ2s^Y/OqOA +cҎ�GaߙgݼvSwh#K\JHVnҝ3^+L5x="#ٚc(6\ &d�=AdDJzOl +IY"gNȶhOORC|_K|u(\{3ɫ? mR�yO7^^,A�i+xwLlSTYLU1]Mf'Cx#Xvv�=AdD:Nkښْ))~s#Yu�pza)1Ҋp(e+@?߃>\YqF ˞۱syԭ@^{y/6z zȈt㷾k>2wVcZe?*ǒDh=p袛 }C-Qo-J K 2J! )V +fS@oPD_W +3@6d�a3| [SB)Olc}qc軍Ov@gPC{ldzM:UR ,̧̦LW?$J(e4e851fco/((autttzp:+ŗ ;{STI +y+b[h�h_֐9`p#KŮ򩲘npwl}}ddK}ݶ}c達VcM(!Qt9 c,!3>jVv9wVbsQ?‰ژc%.6`lvBf'Tj-!<@CK=j�r{9V0{c{~ˡhz΃)}J]A_ + P'\9h�]AdC*z茥p\|}ܢ?_6?͏KI`gi|>;.".UVcM;Fks{iaJ{d3uN�]AdCDH,GV{90zOcQ?Ii$nOF Kwj ;AȖR̰ ׻ud󏕳f'L޵;{?$ D&!*{t줦Hw#Ÿasd4 [#q!=+y5^AȜ-yl)hD7\)?ZD@~B D&{12zv0>+rw[_#qLlurR_l5c=AӾQ%ZzР6 PW%myO~R:H:Ȃ1x6=k )ع޽Kz=urN2W BQ<d^XѼgM}XjXOCm|,-[߰pak}ݶ}u? 1j;k_/ +DMʏ3 _mCZM`?z*Y`i ?0eP__o;ϳnUR8?+=idFjUQN R0Da8o5jݮqyyWHu?gA@@^ woHI+Ԥ1ٞZe1Ut[<-Lɼx{d{y'ϻ!$?&Þ뀄9J3ĹJv~"]lQX=c?02U&<㵂̔Q8#ZVՍ_! _\h8}؃KW_! 6F@@dOSf1\bA4x`B Dt!o xG&_RHE@@d`sL{-o,;;3v":BxByĖW޳A#\9}/ht4<Wn'g*xLsAǬv":U|Zh3=s|y?%4hs+as'V-K/ʵ+Yc~FϪ, !uA=$\o3Lqe̦G(ts^Ʀ޼g +FVd[]<R!@C?BY8bw3Qo~AZ6?z#;p#;}`kd&Kbs`B +~Uyq?XST Dv4V5E%[ A/K$Q*UnAFu +鴶44mrɌA{{3`y?އ *acӵeFML9KK_kSR7%ϠCq@Rٸ`ZLӗc~b@k! *c6JMK>k=]b8C*G_X(1>گ?7< w/ ;QWjstQ@T,JgyQvoJ0޻ys?\RN*;<NK? z:tUQiqxk?02M_& izQ׾ҍy�"?o]0T+'gs#`[iзyhWJBPe?pEho'NGziz<EN(J�D$dW.#xx?Y7EYNMsR:IH ;b!/~>NLI,͋=Vit�hOJKr?zbY[..N +}$]gJGHVvAe!5ieI%;xB`dcar+b�hMGO8B!t5K:Noh"�@wd|h.{}YK6)F?$)  #9$w̼ +kcI}$ |1!|xw[=J&?Ϣ4內ܹB`d U'XkԵ/4\{@$B7Al:e4nqe1qa9i[G=rIRDIho$M7zidg"^%SU{�"?.k퍑Fo1?YCu]f<(<oU' gNx&̓ F?xcv^Pq^h)o7}a {L9mcpGGgy{0.=|Bs!^9{_# ]!n>�!xR/JxQhF3/l! +ƍX8˺C8B51Һ( wc03/Q5-F?IN!@  Fs脢t{ 7nS,wǣ ?&?{̛w}{_#?WR% �;U~x)͔{OR`Jr-K?{~Tt9;'4Ǩ'Np@`Qnˎ{OҺ uzCS ɽrOcՑ-?02l0dd\4P7!c_?.`laK} vG؇# JݨgZ@HSi΅w?02rNݽ+h@:~z_Rn zR[lq$o3|̈ plidpE1AP7I}C)w=vO+7G? +#~ +v6wt̲Ew-?02k [�xo|ޖž Q>w=L5ѕtA:-e:?b:[Mߣ1w-?021<d.4jZ㚪�x{N.f t`L8Lw=?;uigG 15~U+l idf&cqEPkumIy{ +U'X-9rI՗?`e&=9Z{'#?۶nw. pµ?|tN^}'s[Fji {�[{h�u%`kL#s0i#fn@�^G9Ew#dw[:h׮cvҬM^/?{l?n*8{#+loٽ[,tYQ{#>w޻"Y5]:1­`rЉGӴ2{#CfW[}lL۾.p:ޓOuy? +G4Hg +mYZiby{@`dTqܨMi� qΨˋy�G34ƤRUWa)SMHjdQ<;^?=� q]ur;PO?܅�H7j&Fr4?yIG-^p$.M[6 ;_z3{>Aȧ5)]{B`d){܃�ĥ?ݽ[n?WܿGz:l7l??\Ƣ?`/CI'F/18h&Th/&-?/=H\#\ٜ2>&4pe]E?bq,?۷'F/lTyƨm[DFnB�ԟCL+>{~Eu?(Vh'M2+>Ʈ_Tlj++Y80 RlSd.Cey(MQ 8t&1TDvw?ʎw_`Mie_ 7B~ +cـi^{gOIB{/4)+1AvѾ QA1VJpfh= Y{_!`FM- `dv7_z7;SQ{AHi\?dcAF w2p p/K8}@;Og>bq>>qsl] @Ym=bҸZJ >8]D5>4a5>lȆ鏴ؓBWdA@q^J:}S.Cu6EB� jxSQ{+"{ })N+]YUpзQQ/ގG.SA�Ae&M#^bҸZGf7`3p 4Qc#䝲.#/ڻN:ҋ<U0‰U#G"cQo3}N{#qݳ5[ nC�&jD~uEcw˩:Mo4y�3eO{qSGDd`' 맛9]OT ] 8Wo5jb,g>@HDZ ;΂<O8́\i.>G􇫪^yA]f;.&)6}+hMuFmew4姮-0%}s18ΥccyU=<1v͍bҸj꒜z w0p# #}}ƒ~`MZ8<c)y\ BlLeiؠ?`43'=*nD�"Z(_0X8]+K7 &*p{!]!?liWqClP)'oAHi\?<2tVw>x�3K9?md5dzq=eُ5n FJAD{C0eN@J?huwOh5Kbזt8`3rd?{M'*n[ D� Jl�y,c;fGcsQ�#~O̜|ok?`4AzKQ۽c9"�M7n߽NdBR`[ɘiTF<Wv.w3흦FJoC͜/[&Jd;23h3TSdO{a6?SxxoVF}i@ 0ga{$x8E.,SASյhʪ2h2M0RT 9l{({$x>y@gi1wEB~ [ew#8;e}r<] FJ1S.CusmƋ ܋�&cͳ5xwE*oG{䙯((CpwSi=M{i@<QB0ef`T7LJiUE)wecoUуa# Crڶ"{v'͢ôA8?$/Ӕ*u7+INzGޓ_9菧|QJln}30m ]xߗ̡,m{>:vi9٭x#CrpƙfNIi0m0,<u-cR{ì|3qҐxA]Z{-rF�FCPA=:CK w,[d{>9}<ű l4%!15k:Ǖ];W_@8%H[DGxA<on|j=KZF�F&k-)Q_y^j-xp&][\ 2%7l,q*:23B{Tz w0p;0R kTc!{ |ʣGͳm䙯`z P%SU[V@8xyxfNYb¼~cl{(?0OE{oADAU]`/Z#t dJE{oY,s8*jjoC `r*ӝKo3^dv`_?w&y;!u lω<tL +J@�'+Z1enf-N?eNjE$5sc #bv` +e۰1# -VN߳+?ie 0i>;Θ:mgN{Y BK- +D +񲹕? +/Sՙ b^ x1l~i; ,z|'y߇|f=||~EyaH5mGj[5MR;Iӌ8n*`lTP+ ~{vaq%1DMUhZLtvtNHsIw=j ,m{x(x{ J7ě8`W.RX�tL4Z5D;wWĂ ,֫.4z5\9wWyo2v?#0_-7~A?³7?TN!JGvdzkfr爵`{m@Cf%kg=]h^&N %gORoJ8|-})MM!F pG.éZD9z#0zXỌ/{I�.qVSyTD)JO.[w%m9i +i?:&4el>sn}& ? jR#[rv#"y=GB,wGECJaliU<w E򜦺Z)H�w4퍈Oؕ"w<=;*"D?:gQaժu*%Wj*~a)О҉"7ӗ}ݙ?$F5_c-~ +)lqڔ I pK-~š1ZKcl'M>s\rg ^GX;( + Z12Ui||ܻ)*D?<cUQk6_&RL{�o: 셼{g E1GmuuGir1 SJH;iyRdLxƀR5_Y}AI�1elgǻz&,+!q20LV=pnW=+U6ӧ?q{)2D?<`c/V.Nt�7%�WXpy7|ck~l=fr{ˣwdz*}`͎Iс 29#{Yl�7%�L<Gqg}!>@ZRk6b&WnwEwl-ݟBi�p9H\\Xo +EH4g2jGTi}u!}[ywQ?-LJ�<!_1{(q͑sF0&v ?zroeLxG`(sPHY�Oy}?u]6G?,q ;k:ػʻz�s޸sk�%�7Ee;({ +:M艓}{e%^ 2=Č&V - axyL 6O[:;AkM+ =A�@d +CK6PMt�%�Li,3ywdbVƪl3~teM 2,OlNp_~c'?z;Ľ7=Gth䟖f 2%cӮ\4FH>/();ɳ6#l�? !N-hW2ހ 2aj|-ұnL�_x@iJdE$ZwF2Vid�E#zWCWM;@d +7޷^eqC(]( @{)]D؎~;'#aY Al]#l#)dG6�aOHsg{jn"Sƨ�6E=|?ž+'q dNzhNn>i +H#?wy@3ԃ}/"xwN?}{͍!F pkp?>GRá#C51ZK#hN.8bC'H*!8BnT',5@d +w6ٷ" M ]1&3]6;G{;=޼WLN`(4m~|PJ ]]O9;#l$Djy'?"A),-d%"S!*ժu:7#϶{&3thm3Cjm$csێ0w )%cH]9|Y/ Swd'0zQ-ŧ +H-KC;χ<@"F)g;ɻgz6I% @>Ǟrsc-7w啕q-EР4/ݱr1c/ =R1êr-xK?Wrty +nN�(]T[Ww\Ð*jqW';x:?v%HsZJrwLRruE pw0?yZc훩l?<n.nu~3 #?"?rH 5!lϮ3˻[2�@d +ÿ"a6V-+6Xxߝ�|Iد;'jZƴSiI3I/5lxx"(jE1**. +)eV4(j46Niu?Q`wy~>yMf2?~~߶ۑz’u}ds!bL=Ta2y&o%FA8_T~NmޓE*=|:Lrrd^ڇwJ&Jƶ??DL $JI{D4۝=ӅwoPxRL14-K }N7=7zsjcP-=S@`Dk$f禕n*?AnYE!>]xLmϛ=4OdOI $FAݫ:盻*?An+UŊQI&yut0,d}ϖbJ̪>I$Hp 7ߑ$0DSe֡H2_G%(Q7k7,i, K"A`D=Ϟ{TpJm7yVdFU3_pBz +ns]#-7 xh:"مyܠ /cŸv.{d4&tq7ߞ?RHfw!5=j:ܣiz=|]w(?V\j{h;$#KƆqE{c;Ixb0 uN[vXYrO$oyimb? +PDψ?2W&֬{}bapZ?Sf{GDHpeiVwS[P?X\{wd:;zd6~`vغbiKʫk +5 9b64-K9 +i,.G,Q- +q?>ʾ&D,{wd61ү{ S;Cj0݇)$NG,[j;B`DG8fC4Jש8ko?{Ȍ=r|$hO$H^6ntG# FacZ;{#2FAt+'bEװjܣ #ZXc9{g$*ڌUgs/jMbHbvC.tܫwΈ i'P7DߞBjܤ ÃŊZm8d]NLe'LN|ks?붿?l*!զ{_D43h$Rb7nX^awL4}xFt/N<!NB3<,YYѡ?0" sm2$z+RBw)XYcpXG+Ƒ +v T'rܔSӼ{Wd4iwANJUp]fx <_ћNeoF4n }Od4bJ^R1R_ܦ 8J?7ך{GɥJjsn|ՃSBIy,E*͆5N+oSk㯔gb<{G>{ N谯lɛi|+A&Kn'KTp|kJy y!`"4 >\(LI 2A`D#B|YV)ͮJ-)4Ptr }I,�|nw2A`D?Q(mޓE*QA\s!Xy^6J4Ug Lsm,vz) YpT~zｐ #Ҡ?{QnLYJ{/q3NRH'KkI=)'C@IYｐ #Ҡ?/<dt +TSWھ Z}'qLj.BIiuqEdS�qC<ˢud;!#FANt@/^ܩ v#dQm}e)Ɗtjgp-\g3:>i|$ ֤ +%ܩ vCgo1{u[ şn?nGN#4o(Zϵ?;?v(6- #FA؏YŨVS( `{7{us7-C+c�Cͮr+xů{d4z-EҋtU*%ܪ 6c);k кWlh'GSG AΧ+nͭ?:ڡt:8$ˢ-aWwAVHPY{xWUpX3Xuy�`RNC;?KM]7:ꪮ-w x"EK*WA,mGvn1y)m7%G]8hC^To ϴf2C`9ssz'W??P{gb_ƩfqPvOE6?n-7WB`?ޟ١?0j7#fí +دӨ(;QK.Iؼ0i(j&GD\5((ʮ&l@ƣ�FM<9imӞxn7a} ps+pw%)J +poWak?;sb{5ɝf1'wЭ9y c +RIzc3[r?{{{x9֫+IJRɇt +pw{fk+CjHYYVm@?lIr'ޑ-l{/{@`''rP<n᢮g<M^r&&^+_1Ҁ2Iws^Ҧx<Xo^b;[_],wQ+yx�u"׮yP]ةg<9|1DwQA�W&cדس;mHlYe#a]{?Mr'仿mKN2fkL{LGG4̛2I{k{5-rEWv.?+dl"MSsLwOc?M0ƶhJYmy7 nf9wcoس +;hBwJsiJ k>dhk|t sJ*?'gu%垌6AE9ɝaY={!ӷg/2.NN}(KxK}~A.qr3\S)yin�#{Kl6Q;,S1 [3bCzshq_f緍T?>=' HZsLݻ菎vs/˝`e/ݿ{#,`z Oh]}yMHCI\?sw%{UiJcA|m& ul<=o>2hui-$`ܲk* vNr'NN{q잆4?݇Lwt^zjnd+)":d OOGDEDS~C%K%tIDjdV\Va{i\HSϠ?w ++HsIA�wYc"ޅ(w޻ -WqI0d=Q=a uh&ޘ{i\q1sIvF~wk py?fq#ۧ ;mhB,?ḽʬ} ?04yJ*T)(> X9VP"i!n>1tiy˪@ȋa!r2y5<cO;smu�Y#p~1=NCE2埻XlqDCv p`q;ix6ƞ!1̤uR? v簤 H{2U_[@S)->?04ߙբ;iA>Eq}&ovY]%\'5ȲCc9gx>ƞ!/Q=9j~kAcْrSwZI';A-Z' +ңy2cO y߾%䡱?ҋڎ</ęd?m쫝m|G{ /Ӡ?'ҘWW+(] g)g'q`; m'ivQ$Kd!Oȵ"x0XAχ~ؙ|}N)g5lo~<Cy3d;g5^>]/OeA {䃭x0XANSzΤDB 6K,8mR]h{JeSڻ?d(Lfѭ_?Z8}Gw{wz= CFnP&i냮4 +pLtdT]T#޻ mSޏ9Vծ\qa?z?ʑgVwӠ?k>??W}m +qA\>aϹgtP{ m+&';,{Wg-YgC6% +'r"7]B{ ̓Ӡ?khtR"inl<T;.gYm}o]:=;.<#W c+3vC~Ò{[hƞ!okUK QJ{.gWE}Ƭl +(U+菆f>:!2BWתb&Wh>ƞ!oO  + p)(3Uّy+NPN[yt)DYi44ȭLJ%r?IK{_{fxԠt=. cϸ{g޻ +3.|qgv:?‰Cya< +!)7h3v{We{\F&وӼ u%Œewl!˜oۃ&o?~EuX^zתq4ZV'l(FЉQRoER$U+ ,+e]%HDAF/mbFGݗ d₰zyf~̀9 :U;8Ba[߳w1]d]RԗD9E5nYP$=nҸt|} E#~Nh*pttYwJ�$3*C?;cKw&}9Q{8B)^d=wۉak߼=~EVRKk;c'<v O78Bps$yEϾ'Niuy,Ы-M? +ۓ9ɚ?,DL8mjnQ|?p4²0v?A}E -z9OKd9/ηuCkawOc߃w|Cxbr$A( d϶wJhD.1'UDwo=Gbޕܴ63z'm [KJy\Ʌ>#8~__g{wD31ȣ^;Q!A9jeuMZEf =Id8BaL-ޜZ=(}F0bNˊwYq^Uz粧5G3i##UlRK?SnEd:8BazeWP\}FF%Edy!5₺$jOHv=qvPSpٔR w}wCv\4~}FEi({Cdy쾳IV0 +OBNkd.{L GH!\< }&4yY֎R^y YްΤL^? zw xiȴ?p4¶5+zv9=gbd9q Il !8cY_4 ?S?z7!'yͭGބ?dz8BaD=>#ptsF(=ΎcO- �bg81Բ'FfD5 yhUfMs?p4·>5lǫ>Az [waOx {Fp!53XX_}s. ~GH!|>r"<yYzэ cd^6h~N໇_V4.jād?:ɦrŎ<HssA nUjg?߶w&aexR^VлGHac?7Mcd^RuHsHpXU#!34|i=i!ǝv;GHa;D9ʝҏ<<(/畷? z<ߌ*U$ ?d9wt7q}?!E{iM;<�oȼ?p4cV*R+^,->'#yx+=o7ov蚎{i_56%VNuZɅhFWwDoX6Lh ök7<) >+#Ӌ+u9?G]CU꺖Mow( ^Xȧ?:RF{[4Vm2"4/|f3 vߛVwGw~s_2x=k +f]\ ѹYԷ~Jk%Op5d~8B2ߙtCUgedzpx !wh!`~ ;9nkvvgȽgJ};oˣݵ绪7_5v=ksigigĵjUN>#x]>j;r%I"ۧĜ4iW<O1vgzfZ7v<c׋tϝ9`i?l԰q~<y';;#w YɻBL2LJC_?d?Bc\WB +ܻaױIow7iݷ#3ߗr^<Y4i1O.cK}Ibe K K~jt<v '%.=ښ=} +r +V<ƮgmL^i%F!Ʈv4zsg8BHĹǵE4v]/mw Y2ß2Jhr$N+zǐe`i?lӂ-^?>7#(V5tлHٸ$+ {�w Yvk\2JΨo<)ɞc! +Yl?$Of=?̧h!q:m+^!`خIAW|uj3b^:|a{QV58֏}4t`􃷊5 oB>3 ; +ڙMNNZl}DAʛQ@ +$'lI@ 0z" oię^:tPn}g>ٗ~bOU׬aEzr#Y%'|gjW0X^lx5>Ğ1)[Fz&6Kp>eD{r?w_gS+x&'`S?a,Rҳ40qRzhlfo_p?j77nx:0~.d�S?�LR)6q\$yMLNIC�9Vn?n#B= g/j+Hw Ğ`VٍZY^jw< N�lj*Bψ<p_P9o:3uU.�ä2 IՀmn_>🅱Ȭf,kn,m]bi@�,C:[g5s5`MLNA;p%#*! K ϤbO�F.Z'=[q"|BN,"@8JD7( tFsrҽ�#酤Qnd9. Mjw-n|/f5ch#VE7�y? qN1o(IT]d<OlR^w٤= <괔e3ő' <tW�b O!M--K&?@)hHڂ4T_ _'In365f�2Ko'YĻ=앸 <JU#ݝ \YIzC?ǡw~i; = (/$1ҔqgnGlpq�eGᅸG(zJClw!t4IZkK#��9~Η&TIMW%!6?0F&{fK+,=x?�cV~5K? +cB<lؼ2wK��5AgY9H|rpؐPԔ):x V,ҳ7έ& @YD<{jc5'גO? |2wOdVE&r4ǬE5KYӟI3�K{d7ܧA/BZsjtʋO? |LAr2̝3g賳Mǁ�'v=j|&.1;#{v)9SEz}~lҝ� *{6} +^ZT܃=;LُVK"=Tj\,t�!O#K+lԂr?SUt�~cLj YM- +]ʏb'/8V!(?Džgՠ$W]�% pjсqTǂMeuuJ �LGmb8Y枵#^ydIF0p_"]Iziw4tK7�ImP4 cۉ%zt�*m`pˆ1^yE+|k�^ך.͋('fVk }Fz=buT" uUs:/DUk JҴ%ᘩ>L0Xn+ >w|+Jh)BFNduuTGa}e _O,Ж괔#%=$j4au3V{`?޲=?\&-^琾0�Lu]\Ѿmla9C4(g8:8<rlY=굆CjP^8-/hrJoNڳ(~>gI}p̙2U{GR} }xDfAzACӦkQ0|-wID#ÎeI@]yx-i+^hHwa> ftU=ޟs5pEԤnL>StJt!쏠$W/%?/?&bzzJ_dxN-߈cGGmv{7{e4'?e^ӶÊ*cO۰#9}G^GvFuHBFn諫:W1k~?*<W'OnUx?Fzf}Fn;5x7ITi7!$|&pل=t[�0x#cMpze$}4gh;tmV);:8ztG7<ÿ?&s,|W7r ATAiIc&!iSNu5ZyhQ4@@ D (oynV`_]v +DM1FT(Li's{L^r3yss$/ɲ:<mCT'E-/sOֱٍ,FVw}v#,N̵jv<ɚ]% Yޘwɖ@�ԅZvsVhTf? ?P^  I|}aەfӋO}Q`+{135ܳAdh=v~w Ķ| gۚ =w �c$ځ'N +C=SOg$ <3a"T˹"džNJymVFȘؚdQk@{n9I2R<@B+)x/MN0oZO|fƁi? r?w.dd42e1F:L#ͻ_cx_scL sQe镝nkY0a{ZrqאOSn+SOJ+iICb$[/2SR&KEl٨{Ym5 cqg.剻&ZeN<LQUlcd4bts"y~a-KG ^1=A"S>|7CH1+?bN@hdo,V$=_--hUrM}8_rsn{Lr]b7G&YVėq-E??^I@Ƥ,M]?xS*LN}wn gQ.io1L$߹`iL PD>=�Γs"9ߎЃB¤Mx`! ,L |7)ls'EuXndWcOY⢉*36&*-~|m{6Dh^ec OeYCg.Js?]}.^gy}w.4voE3{ LY D"ϙ.o=/^gcb&DzЫ)'%ю2A>QtFr ˳<p\έ!u>6vZI48 1n֜FVRr3<÷~";,qY}V(y.7uA w.$rntuwPm8o>}vYG_*!wst ^cnRIQM˛!h+ 6 w}vjϘ$+ʼ,em&`asql$̇A&Y՟Y +\GN{%Bcsܐ0M78y`cL RfP@I1^.BA?=- 58'^_^q)˛GyG (- n/>p<^Ɏ3j]7`5/ZV$zbl[Su)ѺP0slej 4YP뺵B3[3f] Ʋ</OERݸ=ZYpթ%r}?9$Nf)h}6n+c;w~{+]0o(s=9g`!F9C\ah.?ܐ".egPebȵM_gijs!ºނHB+4zN|KLSóG滏Y@I=úuyp<mCTdc0xyX׃vɊ2/@B+)cyy[׭5[`YM˛iuRdwʷYek^.;wt1`t$q$g_Kz!3Xg$)i>&U/Q7:JY}ac^@b$ڬ'nvRP+?bX/z֒Z#);=3Ku|K}Rcj=o]ƚlPOf~?o9}ź`|&Q'GBf 0Q i;_kD6OD?羭; *?p)jXS?;wD򑡟2q޼'fLGLj;BL_Rd;EZ8?0a_%k 9Cii*xu^bdkz)ͨa"d_Hu |#F8`!.tzrxd;EWO K}x_C_|$>_i^CCH3]2aj@^im'o3L,y#a{(ͷq-E|\^f<Y]L0? 8?0f9]f8(v*' f&�SG>ֶmф|0!z&Q'#<R`L7qUw~? dFD |c!dcV{_|R~E]qWc\7DkfnbD4J@ A_#K!8y gzzF"ZJRI>$U>mvX{2S{{Os~U?zR&F]3,ld3 A7',6.Wm9[Mޓ;UXY\xN†^cbg٬+W4 -{WKuN1Y> Kԝǻbp�hgWp]3,ld59ˑ ,`YtQʭ&;EVBS�8֏,fAs&# _{KbO3TolMr K8C3م70H?$&-p]+,ld A7T~6x;M\1"kLwm 6q:k\T{SnSW4lk%M?_Yp$w[?"lRhG%)]CELUDmlBϝ8HzcoCě +],`,Xw2us1|&{Q͝#.W"jwv-/&+9SG>b:ɠ[| go.L))⪫vS}:_`T -ɳa `:݅#tYsO/O7*V@ A˞-Jux0Oi +~onWpFr$%Xlzui1k_:UK9CrB^5ХN:;r|ڷxGr"Θ<@-&&h;~GGG\W, Ү5B]^H~6R]1oc /Atl;+VmwR M3@!u=)ԲdAsq.MB{l(0?v" }:F<weαsx s`\wVZ�J6h/=Q[Qql6ݡ94_`OձOo+2ނkG,*2Y sTQx/)U>5W]ɰ*h"ȥ%ZѵC +>fFae?̍7毁g <X,`n$<<m^YfRW'/=8ə:t/[^ �`JFs鶞y1<0-?M Z"{]F0`s's5Pxг:*mzgF?QN[OsVr&5[U&fE<t% +~%QC_>XЗS,j?~b{Zx3X9ʵϬ } +*~` Sj^`-/pV9@>뱾,uzXu*g{ +>\Jmrց-͍L{wE{8?Rp_i ld1ޚ~`tގڤ!l8\o׎X4IO ^kA3g[DSb&~oO20#Tl u +zRye@ZkjFE!x5AH7lofGSs6+z 7L9|wDxCGY6<0Η?$y crk6w2W变^bgGvXY\U) r&a NzMv10Uzs?âCeCe`>.,~tp Q˒pT8hĸ P͙ڤ~`<ke{\ث_=xI2o#\XNzuC[YiTG3u<?P kDR=aWG\ '3N˅KZ`.aNj"MF QŸ')}/0 +=~qEt=\Ƈ8]Xl^ͯBOr~ &;#Ju~3w'_a l`~`N%?!x p6?lU:orMYM<H3Mό&*즺FCSn&xYs8"t?\.75\yyhF ~#撎5ܒXO? WYb߼88XN61h>08z`)'t ze`)8I3nC,2N\rXӣVZx%;;r{M +{K &Z+duטoeXE8~XS?"d21J|Zϰh9I3#n޴+AL?2¾kd[)pskq"85tH:7#oIJ@ 9Y9r:TM2bNZf6(π(V%j|DPX!Dݽ+ +(HT KN8v?1ٽ|޽q5Z{=x!gdUOnC$-s= +k[bجmY Qn!!+wǔr&Abp(؏NXq$rViSɋJY>[,i|Q֜}CI.^CAQ,�r2ȜLf(*xeE'/,&Xr�9˜?؁|+^ <ry6wWpa{'->KiyG"Ɩ \'ܣk^C2m lY0;wNY`5G61c\bҢsz~y(t8yZ`TVN {|`y̨qrxM}t=%A a\$RFSZ,>W/}<8=Ls=Kn<;;MCM`<9<tT΃ s,uV= dvik3}_ծ`U7ﰭP6kdSks|l(+ } pzZ6'v!˒켢 cDyqDSl?�\oN<??~ +İ>NV|ړc(0';Դ}sߍ@̌�n_9h*ͤ]g?0bȠĠe5*R ٴ=WZYcΒ$Rsts9nW:mg4˸(uGkq׬(<s.h3TzD`[`DMtqOWiGOpCΦ*ڜ͎ }^06Kƈ?&J.O"?0b@;Wؿ.ᘫ䅴yAIQi+!? R}Hyv]ڄ+S`~׻tgZMH66 7Cb FL>C܉ڠg!GuM*c1\Y2zMeU ?LtL1:8C:3"78p̵l ª{M }\DNdU):O+/"~RN4}zDgS?{`qbSy\Ӹ\EzӒgPZ@<W M ve*@9nuv @)(߉2:gx~c,`qUV\Nv_ekUYz3|gFڵC# İ$ӨOqN +ڞ,ArLhbzg=9ap2POpd1k # k.$F6T*[i;-՞dUm%h +Ah`ߠ +VvOsc`"BO Z!ȋS?{Y2N6o:+ Tc~[SCӮP33ЉyrjO|95B# �'^\hGXKq%}hAlߜ@_tE-E?De>l 4A.SA)3)|%IN9 t5A)SЮኔ?o3+Y5 M [A?0b +"^ p!1l61jWA_Ie,Mbk@_IJYJ?8BkZ3 օh6+ ڵ@ނS?�{I^*Xugz۸L{zؽS ҆ϥ^U?ҵG+0bB;WΪ;|sc'@2`Dl,Vϴxl7AX;\kui3ȍP7:' +}^fhRd}1W#4z@{b ?0b +"F&$15=FW漥A/J< VCܩAN<s*wGo_t%){u/5լa8:@{b-?0b +"ffDnp5*:IWc >9gݮ Z~&cGtثA _>2q:63w,)|0L!qBԻU~(MLj # kɶB٬l^Ü?ũ;*K/).9K|ӜX5q68WgG0+4D2XD,@?-Lw`jMol1Qa=! >3Rô¹9.H6X~?5q�$`QWE%Z_ +LP]]GE + +7&Z Ju-ED@^M"unvڝӍGm,䅂bgMNs 2mKm 19w/joU}mmkF 䜑6sI/9\W: =;#b~7*X}GsI+B R�����z ���P`?���5g����~CB ���o@H���  3����^!~���7kWK/Mxeno?@6g����~C|Dc~e6QEy^}pļa?���5#3>"&:zи=a?Y\/>0XgCa$yF|du>T[C[5Y<l^|Xȱ8 ‡Hz w;2ҫ?{F5OH%LJK_S 5Y<p r,ȳ!lobׇvJ,τ9Ycq@|#Ji{ Y[Bڐx>>XgCɚeidFx$(9M>GF[~Zgҳ=n[e\#gryIF5R|S&QeG 'EEs:::U''}JRo?#@ n~7& ~IP7ixYJ}2o>@ gA4R /FS(V4i44?Ep.�����-Էn}`ȮZ+XF�����@X2\-:mc~qn(͓p.������������������!HRm~r<vfC +(Z&Ou 9|[vDg))xB5TU4~| # j:Udeӻ3EǦIS-wl&zGV}Y5"rh"yow&V.I]r m{x'w>ۚeii z90VowӯKJȾg&g�i{٢;Jo&SmtYĒ妩M/ڮ�Oyh냋e'hT:G)R9~Sh<ԢȑS s_'g}!BI19s)&}i44)W_Ms/q^_q[yr bJ^Ğҽ1TJݶYIH%  4>ʼ瞒gj9_�,bʿ5c&_*Ɛcijoar#b7\.?H?ꡭGdoHoڻ!}E +?0s1EmiIS5h\%}cPGm3ǻY!NFwXxlwX8V/]FxѬٔAhys r<֟= +a$2d_J'gśj.$T?q2;~ACUQV ~5ȱ0##11TRtt~9S MsT +\:'cck-FCc +#?z]sjitY|~b{r$\ FG70THzOKnArz 6ȱ0NW,%yO?j2cߐc8;8E ݿر!ڻ*%5`. |Zx eR="k0iK|/ &m;jiv@ź`t?>M0\qTTa['yDeՖ +r, s:U:_.5[.e; 9s0_K&˿ 'L[0PU9]´\%OA13�tY|~b{IXPo\5`NM6~, [玽ojķȱ09t47گ֑ȱ0NW,;%{M;6d\{W7dzhFS{M}.З߲T콖j.$T?q2;~ACUQV J!S7M$_s~C(7OBj3c5c&C##SQlLn]0XZ$uNƀqhh`jJ<BATjKKk8t(&s2 M~4Voﶚ;Y!+TJ[e.U s@Ei ضfYyG{o‰sr9Er|DB1-ߜMޝB]v|FALHBq_dm9.oTt`^}(7OօˆYv1wտٯל8�?g&2\s¼s \J4%,j$eK-mv<]s{9IKڿw-yc|>u^sߎ4F{‚>}jBNvq6dhmҌqqk5K&vި9-ܞHt>~CNQϝ/'6kot49kM4Z@={0_X4;[7Ul.=\^>$&i<}r]?/3ftIͣƇJ$&[k7G7_9=䵹tI^&I_<_qdǎP!=e[t7|6{(5?tgɦ**FyYOz&}fwC sTc8Sƌ펓c'zT?sjٜyqkPh>;nڸQ|mvƇp^=q ;'BmmN%+VF {Ջ[x-Έ۵o'*g'Y!bWD\[ps^{#Ge1�����������������������������������������������������������������������������������������������������������������������������u endstream endobj 16 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 46438/Name/X/SMask 28 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hke;fL@ffy-52łAAfj:@U/J:QZefЛ +J ~:!|\/<;�����������������������������������������������������������������������������������������������������������������������������������������������������������������Иlߺ@G{7T{_��@,,Z=_~b}5yרۦt<D}��1&;u7֖{/��@lꋡ3?=;��C-o].~٦ꪪro��ν{ gO5qlg!{;W{��@t(k3W矛_vɥ��̾뛚O~CpV=d&fVɖkʚ1cLb RΎSN>ѶacY.wc1 Rx۔B.ߴK[Zo[yuK5e繹ݻ6{l9s{Z7cf=W_Y{;W墉N.t_bپu}+sWS9g}Tҋ +<+Ys_~ы[#ϕY|θ28qeA慇|CGIۆեs}3 9>g\Pr>W3 ?T\9][ sƕ9+éF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#端-o]8̽|(>'L(J_z{j7̙vXZrFz ϛݴeع#aeӲ375gɼ̨ν8sel?g~vؒ|/S/f3 )uٴK.q=.p^664~|6aܸlfƌdUU#�s7?cګZ_5jTVj}>wܼ6޾=9zg96Zs{N9F`O9vxÃowu[_Wr+.ʆv<ζݱmS:8aEXhD񨀀Z4U4VA &VԨ(j# j. J3mN4lQ.Q,_kgBs+NJ{M](gx~wo{e,]|__3�F $Ƈ8<Go5z=ǧs x3|l3als=""{"bd&Q3}bsc+b'~~?jH1gz/' 3Ă"%1I&%;/3L.%^DzReoWWr7^9-`fֈܬG?a<sg@]{ܻwL_~ŵE7a+e//%;ICE*z<ozL_ޭ|Vgj}'O̹p$7�CZ xNF,ƅ9{8&/;;Ծ}a<ubvuUqtKlZBV_\ZV(;Ϛ-bu+�ž-z0?aCC7Xܳ[P�35h 3x{H0yX ϿT�0<AK,^/1֗oZB�kqzdضz(<>bj9.�x9k +Ǝ +5o�SxpH[#W/Kmѹ4X�0da( {+?�"{#cU�} .%1I<h0-j��� mkt-%y9��`hc_'۟`*|M���d`̬�<YxpX<k� +,fד?L�=$t_Au�HrODED:K3Dž oTi35FsǹGlz)}2(&� ]݋U�׳;4IɲG<<f]<rvW)*r)ZjoTo}q�=O/-\ܴk QeW�TH@h[ۭ�ǐ{CEceVSMmO` ֿ5W_:�x6Q]P b2�^B$a+9Ou�PNgrO@+\C Q���ʹOv5JS���n2?)LG���3r"Wh}c):���^jipֺ[mv���੶+{ZnV},}}UG~wnZD1�`PٞFǁ Ց�[^߫)rt8�OӞf.^DVǶ7nޢW �z"1ZFq�ڷ9]/3?^IUZ:�fҸϛp̠׫�MYA~)4½|z*zqՙ�/sEW‚dY�uqe'Oݪ:D}:m_�uqz: +�}sҁ@1c@:h*J�ڸ0玶bN�Z?nt>_ Eu,�藅3EjR�ʭIIueZ?Fnd6/;;Pu.��,?;;Her?@Kώd>v\���YMѹ-&ВgG^cyf֦:��py e[КgǎS4zt�� KޱZdLA>1Zu4��a).:ƹ-9ӛyTg��m^F<?4ݶ}qUgDnvߙS�VtmufhIwZ~ul�jYUY: � ΢7?E\Uv˟UgX>ge�m%rWhQwcKѱ�Qu<�+;ڭoNu�x!AFnH8Z]e~|/%1Iu<�ѡP�^DjRs7Eu?)ߏ2T*?^`*: +�[mТ溎‚d�`Bg]ɪ�@Uu?%=MrnUWS�^F^vvsEө�rk9hUOڳ;:� ^/�~E].tPV5feQÑXj7'ʄRX&h!+IJ.`g^feM֌rs3wLu72O]Ao߯?1;?? tw$F^^~~M7�� $+{^ܑ3㦪��8?ȻΙ)^Bu۾zF���s<"Ŀ^ȳj˦$3��3NhFw2F?ֽlcm3��:v̧?`dc;<ߝo6��"=1A.EF02_1uCz?~�$#eni�4?g?`dcp4wiOT �=իlV=�\'e]r?`dCGxWF�zŒGboQ= +�@ݍ ;IW^#K�" g/0�(=*ws}zFU\uzK]G./{ݭ[U�RdO'9֭cP(գ@rvҤz�6KxyW?`t]Ǥ OQGL?^8fQ�߼ܯ㽔;]tK.T +�=_X83ճ�m7:F?By*j +R=+�&MV= Njn?.[殪(Q=+�� +\eB?6I���"=M#.-&njY1U ��`DG/XҖ=;{͜��0ܨ&gݶWaƟgv2?+ky��@<iN~k?`$GICUy[E)��0}ag*?*5)MwS=/��@]\-KGjkڟZ=U �=QEeU FuGs]s ^?*-6R~aۡbU�6'~8|Pգ�!=9}=(@?n̜*3}ji3T�)߁O1@h&.w;䶟~>Nw?`4<fG;"CqKT�`jXKs� %#.6whW;# ? +TQ;!πՏ��RRvڏU.<?Y_uh☱bkm~zi^sj˦1}Hd[6N'jZo<�z߃ĎT= +�/.m4!>|]S8`T]ev5,ZFFtD՘n׽/xڙ|s x7Ag`\ǡdD =xϽ"d[b!LE8^_+?4m5@�Jwdvl[z�t=9*ܻW[@i]s?[hu|sgB&  xΜmz�ƴ+Gm.i_0V?ٹ׺/yDG��y]h=YTg?,Rg6y~iO ?;3,-/;'��L<ٿɖ,M?`wU9m_w@#ò~lu 7MKO��wQ?]߻j,, A쫭ig984zkMɚHдY���}sj+qp.2<\4VYv#|jݷyOƋςW?|y;?䙸tֵP��>~{Ϫ}*'h ]=@_l]kڜ&ۯ{dz1NA}z$M[ #��=w{& a\ݽF/==W#_!Z]SwL?lv ��O*?ycڻU֬][mp,qs5!O y~,k'?��p27lp G&Y{W{e@.}9wGĒ)²~/5mQgi&So�{dwwbټ�D4l?owx?guܣy|7ܧCI/$~D�Hc|C�\CK'&?s0<zLAE~L�[ѪWF:P=-|Gk-߹j-FN-ncN>8?+@ Qn/^Zx1j@xD3Q(5'QkLIMM&J'&fL[;ݰ+,yF`}.��i~_KQ�)ӱ`)&C57?' {`fjY 5�DJR> �}=eVMz~VHsw-8{&= +1Waln}pp�ʰk>�}+=nDtL֞}G�Oa›|D�Voffv|ﰾJP> +�q T(17Cݒ= ^gqG7[X_/��6  "/vԊ> +�aap{ ?_gع;=w8*7}Dzstp���}Vm2~�?{JCI5+���+5W^!_դ{=+8{&=gˋ06n(����-Ø@]EvcM|/B�Obno.yRE���k> v{Nއ[?FYgܵd^ Z���hT{!輱o;sB3i]:ʍk9폸ݯ7���@s־`ώ3}$mBiRi(y^n}o���檯=>O'SϳީLZ?4QL~yqZG!D_�Ij +$�@1Ha;9{8@Z?r3To�Д!H>�mĶg�rUO?vx oʲ?(UJ�hT{9gD�xjn>Udl:ڥL]މɏ쏠x�hCO彾s�xJ8̻4yA�49?ʌ굗M[(f?�@Smz{a׎�D[3MPnWψn= +guRc{ɲAz~��ZEբ�bͿn{].}鍒m)G?8?bs?goZTg��Иa~=}D�Zٺ?z!f\%6*,+hÇ,g��И}$(� P>\0|A�Qgaᆡ71i]~ ��*\hQg��1ɺ=ʓܛ;w(8G߲d4Zͥ]9$9�5RAJ 4jR{֝\T%#�@]o�sdxp%W-R(�$!oЃzG?Kc)`Z 4—M3T;%_!LI_ mlKCވ܋162qg<G26U̴ag<ɒ:qYd̽Cbn_ /NE]<34Mic+ȇZ�Pu{onTZ ׻7U?9R�h1U;5yv"me/[wBXDÖOȬy-؆N_>!ݺ8\loѺ'~'M,{R,=ܙ.&$'_dlhc{.n,Q[9OA~SK +Q��JBi]�OKF5ܝfg J%jݩ]N +"a?%B换eS(blE3ҟNJY2m;WW* 潠f\GI?FHlo3Oݯ`, n~ꜗBڌXҌ$u@gRx�'Wkxt2d<TqtY[}ZI=D?DRÍ4ݵ&Ѓ:C=FSP;6u9A*}z_*Z占KX_6w L{½}1?m4GX�Ƽ_g̫?cjkݽ0ݮ!:t=Qbf-GU;�<E:u{qaM9ڝLDG|NyrOz;EpvJT5uhgzw!ې~DA} +Ksi`8 +_2Ck1,TG@}[| +M՞ґloT^W�s}u wtUju?O%;DysSƙæQ2F/�t?/w5Nqٯ?�pK'.;v$y:#O.;.~�EuqmP4 (xTxAd"ųU *R&8&<@QrUDWUUcTMG괝V'h⿿ ̇}' 3G$=šȬA{ҚWZ7;]E׏~d=*}z/@q8]@M! AbXCg?8GHٻ߱B$w%Nr?Y fi;t~铵}&h"uՕ_?G?y,[</weG G Tu#À3E;)yk7pcp~߮w%`qvuF`?FwC8Yif+Wuwf w7eԏG =o憃{v90NS()ǿs::So/~?$6ٱdu˾j~,h2EЈ^8 ڹ]:'@ks +HT@ds?B{E[ppeEJJ+;8{H<>$s-ݙ?8jQ]i})xTx>hfDT~O?t>*'*O2L]`uƭgmlqp{\Δ S-hG_y_>3ޝal[2I+]0:W!UG^v*5XrC(ª/1ܒ SEۓJ _1ռ3OD7Lv0}v D-uqr/ίIDӴW|.EK"/ 1P'D3ffNoZlqpoTupHm3K5En^"2-{5y{':P +} =!Bx^vGđ6L֦9b@;Og#WǗM}="C+/]R@Oc5D=$B=_6זΚepdXmUЂRoap^-rDuJw 0jC cW\j׊m[ߘ9F4Nq'PhN舑8b2O"2`9 '`+ h*GZ$m8_ ȤI;3gG:N<EЪ{nݷn\](?B?k+1`fZ.7JW 74C/S D +!M]$ba،؉Xǻ88x!at9бS00pj=vFO:G'Vkĝz+HMz=.BwiD +F 2in`C.yCw  `_F~WG t3 R:|f &)ޑq ')Cғ?8jCbSY^ޖSV@Wc]x}g?}֜Bzӭ-D\?d :g=ctG19]M<3CU',"'I3a4d)b9*YFG,\Z%j&Re IH8>Hޔ@?]B1i:е=z&AD$|!?R*cXD'zbmoAgk]T9PRX`-r;== [hѠI.Cəū6)gOb)J? +c FM8MxYǯy3dq?YRtx'J +A,z?.ZDzT'.aE<51QK%N$6AVmf=BO)6fӺzjp$݀m0 8ɛ=ԓ&n[4LQ8VlN(1px=h72zeٓdq7Bx<Vc@u:!X 'C?>;@zmLA}]́ N@9**C ;e6'fE֑?8jRC"$gvAVSF-8m󆃆sI4gK8w ?Ve+!lx{\Z|gao#smoj $}IF(3ܪwphg9rw$$ɘ&]KӇkF "*HfT̚1S=?.T]݇s*7Wr/w@'0J 4VP`bջ_ԑf$ݑ?8j}fxܝaTD;GG!;lּʼYS!xu5G%5�A+j~>]сKR?#p%OKw 1SeaD.^C =ImWY@WʹJdEPLa"0 s{� +h +ifVZ©s/5Oz~ظ ozsG3|?KGn>'=ǩ%_fћYݏPxB?,R[=VJ�G$W\ĕfz ݍ86b¤@y¿U"ކXB̫*ʲc߼QPU=u1]_MXA$%F짟Us5@@ �jtpMkFKX,<wK CGO$}tBq}jװ'^�Rq3fck? +J!K@&s�Nƻć?oQi1=BQcҾʒb;GNLIAw`XG儬]>wL4iCGL?oYލs+x@X?.=?{&@$B2Jؤ<a\C7 +Нc#FL3ZeKzt7 0B:vW%S؆뾡ϗS C.L&9mNp| .e5 IX�w+#y[ kV̮㔟:D.?p,qdu +E!E0ü?< :=B%#oϫר;|5]pK וX YD%;�V{jM{ܨo&w]c#V>@rrRBjh6٧ PWܶ?GL#C`2 @KԞ�gw"I>a<q?l1|OuLhE| ?p,upw(Q4d4j?A`XH|Nq)oDw}Ny'$4ߜL&äIF*-*KkAKfK~%Bva0YNϩ;Ë<=;'F1"7?BɊ?V?A_ pS!tBXw@=lK}Va5cw?,֕#<Fe Ɣs7A74۷c?cJju~Qae%HT_n([* +ҽ]G9-إ)Q=a1L?L?}hh;ˮ# h Q0fp^�9gӴ'b>8CTݻfm[(۞}z~([zGwa0,9x⡭Tܑj ;+RKg)̆Fo0f܎2!_i,B77v_;f ԖjCO w2&{"q ?g9.o"ޙ9^%Fyp-DBT\Cae2w;9UMoEDL^;OQlV@HZM8U{<s{'4ӫS9]bǬQGsQ+<X&tA4cQղby^K\/:<<ǂ?>򯘶+Zt9 0CMfumtWTrv4~U1Òrx^l xA4:)::9S_tFIǂ?h'N>A`X 3 $B <Ɍ^gip!?Yh +YuT%(: A6eӊc^w ?}cuV$z5A`X +3HvN^o.Ρ(ion>?ֲ[>nCZu4v;ddw^lGd`}>+7\L|Yς?<yVٺSvdgbK34gp?bL.??CnB>]U|@{ڨrEUˊ}{-q5#}8Q]v:H3'9 +},Z՟;PBx?VGw`+wM1y=D֜PT80s`3:KZx5=CWNF{GlYϩmlz]O޺u20}3C,H\k8kW7KE0V26$8/*kzm;WqM?^uIcx?A(Ô??X˷9s$W~!18b%\h7Ld}Z"ZLW^Xۺ ["t +?'ĭ\_#1y/j~Go  17|KJs*1HzSr Pw xkXw<ɑw5!{D0"zE%BcL 8Ka/L'Рִo]Mc܃??V  28[ C{;XK$@Q75h-EޮnÚ?&m[ZŝuD0"z$~|N]b.1z.yw?{PT#PGDMM4$XF&T�pQ*P+" +^vyM*tR[!{Xe|Bgc~IX%Zu֥㙖1U44;"ddž?&lGl6# y?] +.۸?Htz%! vzc]Vs-Rs[gUPO0hj8 ww;;1A?R/ICcme^ t4T.sqqEOX܃yɿ5 vzLc&ơ<9Y[囤Rw<C!QxpUraAZCT芌:ԺtG[ԃn㸢?H_UWgn;b=}h`N{MWEg0?WGxlfgUtfK ~<Y䎲"^븪?B41fྃ ccu\:]B;ŖYƚs(?$(G#%ڋё?#X3Cs:>$J{?`u\VNA{x5 wri=i[R${G[w9gĚ?ia[MFjx+ח\VbAƢ?yP!pU["4 K8AMgV1[DJ?.Ue&ZF{FNKSܿAƢ?~I RXK)pǽz>hჾi*F xG'?5=7IK #qex&J#Ɠ xjL?{M{y/y?$(G[AbI _Pl*9@ڻ0rW)<?etkJ<b1&<Wg=Vu+vht- b?H1 Q(],w&C{8FNx)R[Qߘ ŘG &q$QwdES;AG D6pZI}8FN %Vr/aփ bS0MΜ-hG$㳟Hw0bf h@l?HJAxro~Eg%x0r9&n=b-Eռj哨G[o&o &Hsx!v{ j {uHu>E{8FN#xMD%GM' GXڻ+% ;2o-Cۣ%OԞxhG1?ʋx&P15aƫ LJ/%;gAFWZm@#^Ioci.~{ jķ2.G2J9\9ڛkW1pAKM81D:ן7yA-j ~Œ?z)~&k-鏖1dJ?ܢ{v1J9\A ht%QbAԍ ͷYsiƼ3J5h~ב?EĄu!u FhD8MtwBwe/FN#'&[{&73Pb,FD{_8{ !DфF#&mܓKDDWă?z\/79Y/FN#'x&*Z473XvL^^wň3"Qc0܈>!шcq[BtkT.GWME}@{_t5FN j8Xl9(I7L'fh[!DфVM}L+q fAj `ڹu !9h gW=>ܾ }BLc?kf{™kn -C&w9?\W %W'FN#7 k4rW0pAG?.#}C<ߒ?H=e?lH+"tʔs"^D{G8+F໗s vLcspzkYA +};_x"(a=lu'ut[ԃ~pV9Aʪ(2g v1〽ai#hH=gEԥd�?hHLigAqwc5ь?V6=5/ٸ3dIH%6߭Q2f!~D{783F|Sk fzx2mg$hgcC0?: 9o FN#W\ܵ!VTA^#n秌19a*P344xMCPp>FN#g] }۲;g!VTp[wBwڹҾY�#wC#1?�8C<]=Npv9AJ//џg ZQGʟʿ)/ Fgރ�M@%mihjVMEke"heQGaZ!!&j6$N&6=Fks|g2IdJQ#yfOÔtpTecYCeY Q?l$v܁"f8Z:b^4+RϪ(~8j~?H]_hmI ǽhS�8i.{js,Nw?`4J\N)@b3_~49aqUQg4u@_GVͲw@0JDmkGqp B#S6]=w�%Kz^v?<-dי/lfoZU"d]/c+JbT+bk 1dY@$co/<%hǓ%s|Bw\?`4R%/Rh x5 ь?1VwK#Y?B'"=Eܫ?C�<Q7B5ZQcMarQҸ?Bqϒ y QUVǚOrEÍna4M.Ufopd}a�?Qz q™i Q.?]rZbe,:,+2wAҼ>߃?M`|Yﾜ?`45й܄D(۶鲃Y=C3nnG�?fBcCAT{/w%+c\\� NVppB#{޳($k'`� e9N:n +`rQҸ?Hcz�ppBC DCg7g:+jNjG�$T+�LǓ$G=6E<ziQҸ?|Ӣ!ϻO9 !Fb;}Zg,%1+G?)c78mǮnq_|uN#1< WfYBU`f_Ic,RXPwm-P?:|2vM8w?`4*7eRdq!UcK)nwe7;L1?_?P$|Y:0JWjI|M!UD}Zpmט:7:b~:돥&Z�ޝꠗ|iQҸ?HIf}B#9!HΨ#dٙkQlP; tَX=?}PFHawf%c^4v~O}ArF>/0Kb<_'<OkpvdѧG&<['og4(i\$`A�Wsp#B\QG} }32c>>s_lCVG?7BW Zs~qegzg䊚?b:kD}DCϭFӕ7;8<B|)CZc,41v%+cx*.Z2g8!HCd>RpnTYlu=+Ek0S#J-Ff۴(i\$Unʤ:pc1Ɖ܉$GTՒ[b<We+.o p U-y?9{?r Х:<^quxF{#teD#*X6.ym){SF>M~Ds=(rG?ٛa Sh]_"m{"AJ2,-7bA]{Gf3i򈚃B=g-^�8.@E,$cӬ(i3ДQh쎾qNAd5Je48Y;=^ħJU% n*�Wsp/B@&?|1хiSY2m(Hjי: R!z#Qƨ)`,(iw[ erp/BЀ*zN?s e<6gX:?21 ]seƸe?`4 B[fY" p O*%}{,cw2Z}>QߖZt;zYQҀ?:<^4v/8SNx!,/,/ͲKMu Z@p}ZD&?W2NC;: =m:z35yFEi$\ҕ{G}׿3UK]Opp3B@%?0^]+:#Rzyn9.W~ E}吩_{$ Mx#ҽ~>aց?`xKAnv*=auaKݴitIj7|n#% G:8#x`bW\L٦1xh4^("@iڈY)" cC ƆELvf ˾{f#,go&E.;L!Dp,7?᜶ o00[ 7F0S-/u|??"_&.fM"BgIoƤɂ-wl0]j3 m;bވaRRlxPu#ěP)ZH^ hM׊Sy)BL0Y +w P_Bi*R>{IƜ2g~daͥȬ]ڥ?!>_?ضowK8.phe%\j89#zd[?޼3Yv 1~4b[9&;n|>+A?#\JvI;xWĠ?Lv5n⟴ޓ޲G.:͚2Ϡ? %i\wnϏ[ަrh*Ny m[XNhQp?^E؊4nXuTP+|[VB<qǡlS\Ik?&;n| m_@F֛\*k9#8pNf ,ff(T{?L  5,4bYBzfM*݁ڞ95*猇{[ Bյu 17+4wfʩݭ1NJ?xsC3Tf_h &(Asxa-R1 +Nu+̇A`#ׯkG }GK yeIC ȈN{hYX2;$9K1NӶ2kXڻ*V~Fm}*ga41;#A?X˻J[H{Wi&ܿ 43h$?ezfnA{Xk%Pi[OkCb[xib*pn񣉛-G@o_eY a?t{BlI_~?=ឆam<CNvrNuy³9:M9Iy+~daĜ)猪wTnyx+< [;:cF @^O2eSC8G.ߗb_~й7ס?矴S8}=Ü%-S_Bi) +7&5GF7hg7>>I{GY ┩6k߫:<B!D}< H s&O:ṱ"s(;*V6Z8pI4GA+?؎4D/:R#|QC(i=| v\ m_@H$wI xLS\hy&<G{ ]!d@c$5.4-d5s^a>PRw$Mr2h列+Op_: h돇Atp6RtJ9<$5j% ñ6MME<BOb$G~J.s5s1`SJa`a@�u0?u6d9Xc?՜FՆR&&I10oӴRdD quA»b`N⏇;@ou3[~KC(iۿNoP}1`P ?Vݺ-<3л'cꋤs00[Qx9|qY1A"A?$01d.3NGIp gGi)1LD+G#Zr9c~5??-svLa b t #{+}d=!iy+~d^aB*{iTWj3iڦ4wf\|vDcJc(1Jx;!A;D c8}!'.!!.pyfJ s$:!ҴȡwQ -<{N#Z,ȄF4me2Hx)_B]C% C\!ސUSWx{%9dX\y>"b]TB9 +ߴI_gG3DB \\}UgC1dAv`�GƠ?\MQ&s.!3OH8~zJ2Dh9TRu*Z?|El^85o>?: b"dd8Î{`{dD r Ao3 w1SCk*#Mb;kj?EumN8(!0Hg^݁p}.xޠ:%|AQҠ?+4wϪ9M|B~%? $BxV,%;p0(# /YGgH鏮 8d7m n-:N}#)ON?p4z*|6>[Q%?V,GxVC}Y{&Ī7#Artn7u{67ׄQ'8J:8~6X544mMYZGh&Q\TK+ T- +“-AQ%,Q̴u :6~93¹|„ + PaߕCsd1Xpj?BlG1DB1 +eJw? w)T9޹Z~2̢3ިþ+Dzx,ܰgqǹ*g VHQ6c D<!xx;_%ꮿ}{j?px}Eۨ/.E +ܙtBVĢ]?cs<hw~�w $*)Q=QbV0s8< þ<#o-9 +31q%:2`s<6|pKZtx<ٛ|/w>V7s8< v.]"dnM {4pN(N5+0O|x1F='?͘ja4>]pkbأ폃e!3\'_1 |8@0^ݷƬuYiɵYܚhvc!ᓱe]9s.BMSׅC $R>)~/Yiiޭ̢9lVaf?s:}Gěˡs1CI/GcT1ݛ@?]B^w0{ʡ?pxcz:p< +ӥ'pob؃McyhXy/j/$0zY0pjg\$4$=s8< q;8B^AHnN :])e/5%f; &wz{X㏭Pk/uK(tt@(%z/WӠ?൓\Զoj6U͉aM&Þc*!+͢Ʋ,pgi^4A;<J|`+ᔺ\) mz\=Opl[ +6İc1ȢcA?R z)` kn0GUǃP/4mZzxӠ?ۨ`u7^o+0OOA ?_Ye,<ϹXWx^M~+?h; +sJCne徸12t!Op| Eّ%e/B)İ#WN)7E#?h1p4p?F?N~$<Azx Ӡ?۱~}3]z-K'^,;*:}F)5?Jc?rv#jPmAw8< CK +u-7Rܟ?wN1|z'5nygW60XXa xrDc1`O<i439} s3U'z䏰*$X.ZDVĀ@}T]1#im?S!On~URPvLSw=G1|q]RcIRNBMؿmGXX@<6Edw.Ag;vnPL*$#5*'JAlĨ�7ż#B4?Jk +A1f?v݉z#5V)?" !_\?{?G=-O7wW;Sg6#r]YGwH^_H8 +Z}ۙ_VAxڣ -CX?px z1O +C1uf?RԢGͥJ#!_.?lcv{:6pd<t~X?pxfG0/f[S_6##`;QsAy}CDZ""<uA$N-�u"zwx Ӡ? `*cKO)ԗMw7&a;jC|)?" !ν^rC~æH'HBӏb;iiMnJQ9 +G1ue?}@8{4{vX\14Yoh9e?XΉ9OpNϭep5# +G1ue?j4c>;C.|$?"!b C8Pշ]>LA<oR1wαC4!rI{m!A +I1d?&a$秼z_0wX(ebyNIJ-4Q7ڠ̶\=4p] Pk(h8< y ^7Em{*ܤz ns5n2#[mP�YvL}W5m7{Bue1U +K1ud?^oWkN`+;<m2试&O돨d+M8n8&a+jӠ?ۋfB.ו).ԑ?^԰۔'2%x  )0&삁sY}>|L{8< m3d(.ڦ_< um$N;mHl2Imm,A {7ّ4Ҩ(jŘ4ul4^ ;(se9{|8覈q ̈́pA?c8HZFJ\]{ Z?L_Bccap�4QM67"?0b +MРSwm;gMI>@H }O; =yй@8G3BG,A|Si/;_86 +1 mY !^SDܸ]]4ԝd~Hs|WAVQ"ov)]pŐu&B>FLA`ң%7#  ?&oPq� c&B9BģH?3Kmې11e1 +򺌐tTD ˔7)SXҟcΕN?c2mY{VmɅ?$z{ڔҼw!5?0b +;^nIq=ac!]tNe}H6Π9CGŘ@B#bZhpG܎gAwqE%뻐1-IFy~AOz*"N_]ҟ{WdDGQ `P8Uw|>1 +*SK 2Y߄A)lqBnI㠧"dX[Esa= S7 1w=MBx??Z2d֬A`XAQaȨ^栧"dXP׏h]Y28]k'?$DH/wh=Rx19? |vwEb}R#99`ӃqtUD| k nځ9o̥s:�?(9gږ]unQCqS?3e2ȫPL=AWEǐy xn淀 "|ϒI(<+Z7_wC5} +FLAMAyM<}CGb ã6lcG? +5Ivo@ʠ`>cV(t9諈?*TWC4ެo�mO]j {L!AHdA^ac F[jӮ$ס>SgY{tVD< nyBǰ|lYA<KhЩ굪r%52B<9譈8?w_|iNt^%sœGĘDJ?I?t�5:sxvxVXUza?cw8譈8?B>nԕ*ϱ{d E~ +#vhCq3L4G?0|g'j-r:!tWD 0]GFN>go} G$Ā;|E2G!eEz^bXYAZ|{T=0YST+"|GBv64]Yϱydxd]ԠtVnַ~!d(Z4{~m3\wGA*K,'M2!L} Ө(˭\AÈq570yd,r2?U A<{^^j-XxV{*<;HEGw3li9" BN?C.ߛJ4+"`q3?"U)./idQgNk}K˧̽`mTֻ,ez]#z*=KA.>vn,U[dxq?ͬw=G4)MgxhXcreE@KJy<?RCgu}d~FX:f3{-ld1lW;ks3jT&Mf~n<cIU\i^̣ {2q~Sl=}tlY92z6Π �8GWAڨr%%lD?ڏښ;c{.ehhOC/'g NvRßuoP@k 鍵3U[dxrca?vw~lЩ;bg[VnXBlzȕĀ?[*hK՗u$hE X9?0<3gVSr4?7~y[챦ךAEI?9}Bfy~#O^mMvGW �ց +6 |GgLsXۊ~#A%U$ס>?)JuUFV,"<z!nz wy|+k +WSXc +A}/Я.VZVzA%&S$ y#zd:_8AEG/p?wNfȓ?+<tEͱߠ`ad+Udl"¢TQSݚy|2ͯVUcO vC.Djٯ;?BmԶ|3>54*E*ꊨ#hE< +,싻.P(B,@B +>Čv|aF؅eϽo3?z~gk|8< 4, =۝9""iHѷ%sY4$"Gx$UqFaب?>6ց~_nza4ґbRd)K^Niݩ׃scg4piUžG | n2#FcC [bJ5失gb8< t̏ g +it<}w?ЯX3w;v&2Bmo +ovh^&'^ $<=TEHHAl6]FGѤZk|t)G<17H[ts)i0F1MZZqYRQn2]F/`HǑNd.^i^>d=Fc>ϰʸNJ_AЫv7L1 ԉp=F/`HO17DEmRBBo<F5k t$huj nꏷ�=rY0 O!= +tgUkH#N޼#ykwx<U7Ϋ/ޒg0c7#;adCrcu&UB6~ĭ?bK&U E/k[.?RL16"ҌCaֻ,`H(?jA{#(-ń/"X.H55WAH?bae? fbߘoEi?+0SVbP,%$Dw\$^+ Es䰑ٞoJ+=4?AYo-h0(ڢuY-O!]w +As5Jw\$^zUC<-1[7`i$ۃǿ˼&V +`:8< VzW5ז*{.cu c)Um[l?RXM8cX+wRWd=Cn_ezGΗՋDȋ@\ U&eh'yT#آGĈ?ZؤSt n `H_"nF^{×H|V}{?>1aw sV!j~L-rq}>1~ѸF Mg?pxs&MK|]O嚊Skfw滊= +iC?at_StؤS\).HykCAM{zWQ`4|(+j=Տı"qɨ*ỏch%ﾑ:*rq}@,}wO9[;akz7!?chrZr�JTPr5NMe뽬P.<YX4NQ8< ?|Fҳ {/N;޵ ϋڇ\<Q}(rq~ϬkQ#vbeRl6(Uye/BY}{Ot7X';+soPj!Yd(;@?px̏ Uk/bܢ{'Zr[C\S)C9jh)N{0/fD`'ΘsШZB^w"b,D9Q8�:sw}^ӏ?.gY$ѳ`睽kR#u1>C$IaK:oQGxA3t4jj5rk^s~X$ O +37=K ؈k(Ln*(g]eۇ|XG<|`q{س?(pGSS}٠oƁUQw.#."i?F2(4=[*jX߃yHNeh[sy3돣-xd?I=> z|gZ1Rֻl.Ur +BY߇}AI;^a?gRsW}<ph^ )G7@U"i?m Dm,m`}Fz3C::d>=DVO*]m~ke,ꏂrz2A}G?=D`-X;Z%d;14"!vwñ?l +V_Mp2gLO48#h{sc?d{8< Fn bͅZwbd^lT# U&W;#XS0Im?鷳Pa{Y. 9Ao?OO?n<ny{}p[6&1i:괎т 5NTD% h4 .날 ,}ܻ/54QՠMMc'vbljYAvݽ3䞽{#I ?SG&z) ,myzL1i10<ç?p/TPVZ}Jϲ;H6TU0T0/߬V_]ќgQ֓q=BgXпjEY +9~ߓ=0|aenWw>h9K>k4Kr!Itr"HGs?zd>]|Qs*X-ԯ\!_:K3{ǁ@ }X:Vl88*UBeY 3?d$J0Y70s<[ Sdwk+z^㟍}!o?`4 VMlTcl^>ωH|�ys7"_<Mǎ\Ѝ:?XTEgS"Qv չ1Ei^;G~6һO1ΝXaf_ /JZG5 $k<:ꏣhc Os7[(i )iCXh݈9bhLjBc%X=e,*+NIt&P<%n ;nuK#F/I ?.^|ф]KѸo46 {6> t:)*[_I9&T熒3h~?~c ~vy5N=U9[DT&_ +RcQc^QVZ3ur9}/rk/ЪPhy*ͪVcFTbV  cz:a~恏f쁞Az�wlN{qU?RQ}~kq-.#hojب36f [^/%M~5X&"/z㝤6?-:d(m4Ϙ4bJ{cn>Ŀç~Ƅy\cBϲ!f`ܺXnr%c;&E-CI폣h =/b2b +I0|iIJHc40f`fuD'O&[{$"JҭG*'%G>IzЁ@ _BLtZͲѤog08,{�㦐+=A98? ]E{ co2ʎ#I`p*̴=җ^{aѨ.{}1`͛盙ӭo{ cx>{l~5oh +Lf #O"O1 +Q&i hUwB<>çExR!ϲ;H`XVÁٱ pfid''cB'$SƒMzЃ@N[ BVvM%K~Tk] Ln;.2?`4�0(jCY6= E'!}ÍV%G?B3twç�ؼCAVuǵ֙HӠֲl,Jc'!}ٱx_Nj'|=i՗KL|�90|DJ(aُIՠbPYE+;"}ྉQȢVw4z? +Q +z#ZGz�Y0|Ĕh?TZŗ j?U-b<�aݗQ9 _SPMLzw�Y0|`p&އ }sm l[˲Ym<P1N,;*Ai?Ɔy!YYInRl0-dn>8/iq+폕7BkAi?NE)l%UGz_k +^Ki`+M(^v4|}�ç�σZ\ͲѤl:MۍYwһ&<*菗J?t +;?`4yf�g[G?+ zk3ie]K +p>n>Jh^ryc%3T>^M|W�w@i?@_BEo|0 +ek*/ #yv쏹ݣ{~CdI> k()#u} #}s=<FzGp꓉x +~)BUنb%#[?`<~ u^>jhz\}yVM^UCŷԚʹc®8/?U?S\|o`f5߻kXS LAwmGխkV[J"*ZN\p!\MH$9ܽt֡ΩEU>yo{֚18y9y=`r QU~HHSϝ8)IK" p09> ,ћ{_ ?$/v-G1bDQͰ+aHq؛}MX<{.)#KRpLDZ2MEНOdvt'}U~l1]vl&'ƥ?8ػ?O1_]"uiQ^ m-F1Nɓ.CQΰOv+'2=]m$C@`$w|Ia+GLRÓ +[ U=\ m Z ,krk˪ʉG:<|"j&zs<{a?yIO]X$vIԟ.G^@6?Pbt;2~v\~Xݩ|_fₗCyq1͹(ӅӝO4tTxWXt Ww8l{ : {zR7P+{a @apvrC'%ԾL<jQUI9I @ef~9zFjOW{ IEоߵG,Q'Ypҽc'xbK-ַz7+"p'o+V971)lqT .c5m$PƯmNexPo5.[ZsP+{ZIꆺO-g +,NXV¯X|mSGhՉ"jaZA}6Y<9آq>Js(P%*5;0uZBꗫgsgYU+tXs򉄨͖stGe<9sGG>c'] n*t?�n؁?9XɓmBxs}m^{r,pM犔u _*1 kHoF] ,I}Dp3J*?ҥUA^IZH/ zmS99~oʼn,+lp ~Hk\߈&,qJo<,ZGU_(*quX6R-afx@}?(eX+t .x(:a5`|cHVS?4'<  +[ S?ϙ\]|?j[?!YÞʎK6J yV� ernn>@&k\^ +ej:^ ׾:Z5.7 rkY''h!V}Έ[.tmcn$/t?{4(l-v�ٓD;&m8d;kS�s_E>Ls~L﷏n Ӟ?Mo)>JQ^<۰ՔLe49akN>>|(?<\&l)tq;Wy9uk4�23fAp*H"ntN،͖sCL,żYu : {\V#?PjHk*ϓjvGBœ$^ڽghgsUCΨ}/:u^NF}>b}~ПO'd*J~W_sbzڌ/ edm<5[Hϴ){^~bzoaf �ŻשP Pƈ$%pv}I*Cĥ[`~+X, %3nwѝ3AOu'YœNau}րc?hPڟ9b|ƔIeNZ(m 04|87P + w6e1-c_QQI ׭$ϖ0L$N>Ż8lxE*A1_1ms^I<4]+{rX75!7Z@64}O~ǟR7#Y +:1FHšvqц)ld tJ7-ʋ~퍵$}{XAv$39>t?o +{ +[ONǹ ǚ$4{A_B#55钪0z@\r77ru^_0-DėLm)IET}JF*-5QHYWXJ xvSA|r8gb;Q5CYDZ2MEНoޤftOs(@1!ݞW-R7]sg @aOa :-cpVӨ҈$VgjKAۋ]͍Uji{z$Kk~$;Y-UWPR#alj^ݦudg:H!5ğ\c̃�MfnVtU!R5%(hDPaCffDc(Dx" [GUV͸ +iWE?^7z]i,Px�%ҽY|05o$C&wLw;K>/iM?0]?2 T~7Ô]ox3e=E2r~ZmYЄ 1&񤵫ta++,yYz:nٶmT}_ia2XiJ"bEe)\sAۇ(gsꆡ1ljէ1b`():?'<?-OU_=~7a9.ȍu4Ef LfJm~OY͊~iϟ!f1}^} Igb[y3EpCK/58KuߣGAsU%h:3H&<^OCB;?Eo`9I;,ؐ}^.< ?GdNB]sڃgX] {Eb�s۠�gR,0W# wX94p>{H^e7I:p@ُ<ȍ*yٺ!eVGr)]f?_e\.},D`2c:ltZB/VTҮݕMWu}#9/?[N6S/ڹEl %Eg}{ ڸ)~/4⃁k$֥Vu.ò_$Uz@nG#>**q>h^)e{pABu)ץ >o"#4G}Q7%P$0 cCV<4f)' l1dFg<Y0vX˾\HW;y"s + `U3qw['dל9 It`5>}?^?xuk΁>J�`fk4~{ 1goML<'vnҥn�GH4f;iO%haZv9'u[+T% MLk/-kr?Ox bl[CƬd<w\kpHLa +7f̈Xsu<ًHVYi.=4aCi~ɺwae vG#!ƴ̶I`():?ٵ +%Ƀv-o唡72'}gƍW< "p} \y+|"�CIt+oѮmŒRZ7G|@;HeSƾQ<גA?u[6~|o8'O;r@PR E>uC]"I{hD``.g&"zѽ~qCIqf!'LS.e="CIt|HQtv {e$yҮmWI +{YQhA|Qf Inv!L"ej]8(  %ґLS๻{JOҮmGψs k+�T54]>֭_ {{jmڹCh[Ӯ2$)Pvfɴs fcTtw4$ \oWfh9C G͟Q`.% |Z^31iqk+Fh/G†udВvsQLi$m/Uqi]}KN ̕7J=bcNwS?ڦl!5|A{;9C G@n#cbj,W ?9G{͏[[)ޠ~$*" p!b!pZY֙knrmY]s*&{8&pq9XYn_+ +CI΢o+D`()y9Q`.L~2"_^vɲ6B@hdOϦsemlZj0w ¸-( %EW ;Wܽ?\LvӉK +\ +k"̵oodTVWI +4X I[ΎCshAGP'XFP1oGͼWI5 a|?0]?"x?cbj߲/e1<{[+Tu[9+zRr[b~Ġ}ĜӇ [r@\D`^->mf}!1fFlc40 ==7jRCoVo<<USn*ibkkUdDВO2dZ c11yDKݏ uWgb2cfE{߽9#S&u,r$j'yr9)sE5I{$65v՗ +pCR557G DE-SrY){ CIhCFu¸-U<�5y~5uqvTW;N퀏RźZ,ȣw< OC䕄rr{DEaUX�_3۝ݙa\CLrw&wwϹNZKf>rUhzl flne+[ﻮ$~:xȆ_BʴYPeʢ<RԢ_.=(57&)~[nQüqe\;?1R[YUJ³R:wReץ\RΟ Z[1]5e8G}5ȥ"G(~Xej ۮf^JУM W!,h 5ymo!&/I[_Bd#yawFa⯖^Y`Nš}So1D܄G%T $lѝ"D,\ܩL5I$c[[;xiqHeLB?g r`Nv+-E;e~>|x/'t*qD]pu?m5R7?SǴ1kp%ICZ\(9X e3دm7دJkU~%?P}z&[tmqzg k<){ӿd[\'`y0Ne"ɖoٱ�~ a$un! -xXVjQe3 ƂJ Ko^Aê%/<pPyT<<q]H͍ �Yw(vqF8'dGrدbcavN,j)n1@b;iA;|͊3݇;b;,'Uy41Z"#F/3fr/,\ܩLU*JLxtSbaU],_lӔza~}_'=7RgUi>q N3ܔ,pG:U}]1sdC e3d~`�-CT[558c񇫾0WӪ m(/OjOA<?ndvp0֓jY6d48yc6 __bg .T$ws|?,aC_$#|/^xX!"uf :cAW +M P?D)-Vt;!`t^͇5s ��[>Ц2cGMW㼴=ⓣY}6?h c7?0xa">;~lAZ%UH'E4q}p4mFvÀL0Y +q:t#zZ}yRMx t"KFo{K=<aŝTs2Zʏx̶ZG.?Eo3ہ(T8WV+o&?d4UyvҚl+657y=03^޲2t܂C`2tv`׳E?oXXOe]fеws<?loĐCnE^,\ܩLE(8]i}rʆG*fgGǭ{|0+FO1-<xuiqkH/.,"䑉Wg#yx^JУ[yr'Wyit9NS3խNg|,ž_͂nId֏U1՜$az m/,n 7=d .T"|\ ~?gxXN?-h nMc,|®ũױ~Ockkw }-|&(l:-\wP_n<t|9?D樶j>;V�_^o$&ZԹWVRhjrIE8{W}΂_3FlNxV ^GOD?kXX?V+"n{+0gp,y˳w*S?f%!4F> ?rp.0jd~覂z;: tvCw룅mSuUg;j9cAW7Gf_ȨvQpr^M +aJ&>Ȇe&jV?c' Q.yb?;ze(m؇V|G+70|}bs³V3fPE!9*TYMϦ%p$ZcaaŝTD_|I/IS{eDwO_z(Lv\ ^Rl^h;̏{~V|grtwkG!l댅;RY0U){{2 GBzN ѝ40Qtƙl覌VXX +Z]tYa9LD \ݱ댙{# w*S?&Cs7RSc|E>&}9a=OjԜbD(FI8kib/DiuQ4%}݁?x1Jk ! _AQ]w? QS3Iљ<M2U3(T'>yZBRRD޽w +H}"H@hm䏐=t +g0s/ _ߟM>PV};}&v+1vPYNdň>K2hW$feys(GN[ +O;NzW, _P&tZ_*\ X9aW؜j͋|O!ji]Iq2Oa9!M,dNsST>Z*\}P:?MWZ׹v]V`h{ awS߻#F%Ia|[΍iƋ#S0K'W*$+-3e9u! WNþ!-"}:^%^?J'kǦJIl =#?�O @oqh&\مO~:_Z_j48$,2Iؘ~U{f8G{D�<ɡ$:`E8g`3s,G~\auKBk| |܎LY@X-[3XE揦5o[|G7 ! xz}W%XZ5SeyѦg-2k%q=Y)g$^V&A &`ɉ 뽂3"�@h Q63\˪jgrҴSjϚZٹ'Bٱ!O6R+  "scz$6#ΊxzԫT.Pg in#xʼ X J1"?E&G$}pv%"y.jjy=yQQ3~@4 )?j~qe8aАۇ&2FKR5SkGǕ=}Uf$6|/ T/ҤܸCfsSeǖ?=~-z$K1`>'? /'RqD$^˪jg;{u~Q| T?l=FEa  3R+%9 m8X" ț3b\6NrW!o,Gvu*Ki.ah㙿7JI]>[hD Cx!u:I[]b{C"�@<:,ivˬ&ufe92Dz_o^f%\-:ベ/"xυ\{F2I^}aX?&5/v `v'? ώh_~c[NGެ- +eirѷ7Oe>:K̸!6i߄l7#$}u|S>>b!?oБgcea{SлiӾgv'?JrYSf5*^<l=}Eb2%˿UWkVUC8, )瓑c." U®YOLnI{+ ($Hݔ0՗x2G#|޾( ߬D[ȴiՉFd}4)/\25ڿ[Ikwi~L_}z>.霆x-7OCUx uKگ! 霆x-���� 5g�����ey ����@`^<z����P6�O���� 5g�����ey ����@`^<z����P6׀RyuDؽcIh<Ya1]v8\ugP�����P"$U+LX4 ݰzMO^$0^ϡ���� 5D7Uiz;~.f,\9Գh K� 797xsƼnkrF֌eDGϡ}.Bk� 797xsƼy=uْa!J__%U=zpƾΙpƾ)䍫N)6lA={?8c�?8c�( 1 Kvj,BNDgΦ$d~w38g@IkƮw– LJTT2pWϞw|%gOBPwz4W)/Ck8cs8cL4:ѹ ߧY~ɀ7i՛Yk,Es>w3B!Ttn@)TIb-w<yeD^[^0};2yeP!B0F5:\ErL;~쮰u~������dng,.M^ޢ*[A^:YJTT������7$= fcMElp-y7u����������������������Oz8~XX@xAFUQGA/CE% %DzbD@A@X""NIөT!Gsҥ *+5ss}0\*TVTk=ߺT[V 3ŭaЮd. + uWr-'osiiS:zxC+#"gjt}'c_4eI %)"lv|GWYYv}ص| VokM΋oפ[g5+VJ"ȥ%cLw^\<^r85M%{xBfRֹCXF?fO ęNUq&'O]nk׫F,WhTפ{XuTDUqnاS[xڏ䚢:K>NMIUݷ_qb#c"X %LȞ_|ɬ{CmAgcc?*OߟC~#cLK9QtM.kE̱Tt勗(TԞ;#sO~g9vd{gϖIgsJ;Ln.-hm#cs[x]c>kє_fͷ\Zd[zפ{VTz0!nNJ7'c(/:&Y^N|LNއix^W_ζ[vtcF\#_g2v=+Wg2vWHb?^:d[=Ze︫TR籎1jx!ې%2";Zζ}Sl+I1,ꏠ@d>4l39n/F_u➌]+͖'صnki)>-m5QJ֩[޻pځCÿĿb[ +mEƘLZs}mm0eQ9c\;)+* ';vLdMƮ\rOMEY {f?}|g#%!Qd=6:]Mt7ZˢK;wm_/3G}PCƘL=LYAʾvl3ƅ1ZQϕ-v\ϟ)@//fQHo1FSC]iSlR_\NVV$O@]93e[E+#"o.- j d9\<3Ugg2dҥm՚km)Z^3ƅ1ZamܾP~"g}{o}`P;&cݕ[-M➌]CݹݺNi#%!Qd=6:}MEYRI1xj)r'cL&5Gh5:Mqʾ.8 +TOf}cNsi>F%ִ4ƒC^]S^8,L.`r +3<Bf̒kftzSiw{[xDE+Y&n?n46lmvʊ +C|IƘTʋ0pŹbN̞褑a<Vlۻum7!ޖ]h?o1>\:b2v=gzyeDL+=ʓ'}$W_<^2}wJ׀ 8笿oO[Y<`1>dD[m~W|3džwy{:J韗GЁ/Vޫ^l]Qgצrs:[׉L<<62|}6]]Vm}` RJ_c]uVI[z?7%U%jU`,MjBQoh|)FƘL4eIbJymtTq�q6meExOOϜRY]ӌ}곹3iitWqlyU>!rUUܾSxgs}m#GC;8f#cdvU3-&|$ךE q/)(qbl uG 5UŹSTO\$gT~dCޣDk=Me q=,C8tϘ9oqh$k6ls1l2Zޗ'[)w^5Ʒ9i]]_2v=?--kM ^ϤSKj'oӌ}jlU*Gb>A mח����������������������������������������������������������������������������������������������������������������������������������������������������������������������������!�& endstream endobj 28 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4245/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HюDQO3p;M5DjX{=p _$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$ItB:tJ!4u+i!sXa}N&p3){|'Gu?\}T)}~˟}HYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYy?_$~$~л$vyhzQ:Hblj}Kbljp722ȕ%n-1?7jP7[G)u>BS{_LKއ-ekއ![}ld? ٚ1^2\lgA3>@g]/GcGRǀo#'4ƒv9J9J9J9J9J9%25Ħ^ zE2SCKLMe.-35Ʋ%36Ʋ:zRBcs,9C 4C 4C 4C[Bs+KRs+KRs+KRs,l,ugQ66,Jْec33 βؙYHbìl$vfiv6;%69rW\9rW\1ܕ&W CZ}Hpyb Yptm}MRQֶXVE#/;6>jG-[}yҺG^x>U!>uއj>UW<K{ZgikI�Wpv@> 4;[/8;[ϸSU>p*6"y[nllEG#tfzG̾[Vʴ>&B'Bu4:w1۠Љ]wVfЉg}}GKNú*뼄d]w#) 뺵.u긏plƃItlS}=c[=ZT^Iz Ƕ>u=*oQzpއ>#= b>#sރ߼}ϲ~kQkʫrؕuvxy/ckz/U}= bU?o) >R_qY{<:#M>=.Y)\dozqO_}VzmC9k>eA$f_oyK<>E\^AR]_B?~cVݕp:qY!^~ֳ.\5/+zzPWs[ɻ>錻 +2WԸ-yU)[M2o74l_$1eoA_mzv+p +re7tP&SlB;I,h|YA+jƕMsoqHt~vYɎQ3>YkBv^{F*6n{wa;_{:zctaB}.LU蹏х +=-u :m M>R.އ�7taN?!C.Ctx ]6އ0r>~7H7*].*ږڰ.)[ʠ]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*7O6򷹏J:7ȸx>`G}~]~&R%&)SJGAT +<r҅ +8c҅ +7e;Me;'Ѕ +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏х +=10U>F*T]s SzctaB}.LUo.LUov.LUov.LUouK]o;!:Ct?g.GHC +=zT> dR!x|UB7?D@G?}taB}.LU蹏х +=10U>F*T]s SzctaB}.LU蹏хNPDO{4c!P蛧g@,]T +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]Kq [kNi K[ҁ +n*տ*i]ԉ6ܼQ;iK6Cl?xwӪhZj6Ӧl\*'T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUVYkZk+5صw֚Vڊ;kM+vmŝZӊ][qgiŮִH׶vXk!]o7WWdG<*!?R [np#}lO>*&#pm?/~{9mx_r>4=ka_oEv-t<C$o3g>w Ϗ>|]Zq-?gN^&?j<79SS߭y 䀹]8.{}lTM<}|ǷWCczI6}ӹ}.K}<^LJ\|Wч8e|hˍ<>yާO~8虹?ܚ3O ~+d2N ϏY$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IR? � endstream endobj 27 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4383/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrDaK#eŶ w(g{|?nUrSq~$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I҄t +iJ!4ctt>6}ټQټQپn;eOQXv?CchxQ~p'{ұĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭ%fVĭf|"t/}<DI'X>VtĎ3xĎ3_˟(J51UJ5(x!ȩt>>ΗS}R;1ʆΒҤQ"' #19IHGrnN57+}:Pkyb$mл%m>rB+Y"CeS EVdal.24^Y\dh&-25^0+{A2Sl.si'si'si[fl Zhl Zh[EBc*B{ +W:SСm`qRw{ +7,ug`qRw{67*ug`qRw[YRwWؙWؙWؙWؙWؙmgau,7$n@rrW|vј=}tfyϬpygawOl# > {>zǼ}H}HǼ}HCG^y!C{Lj>@y}>8y}Y>Z>OJז�,~^y/м׵O6uF>A"}$A }jzp9}<Gy\,n޲Ra4t4wmgn.g;fcmfP>f;cm3jCfck*Hxd,QKxG{&qQ-M}ESx0M-`I=zLk[kQ_{hk}=d_}d]#IjxyoXr=;pyjS>Ծ4ryj% G޳ ZnHcs/ֽXgu~uGĵ܌\BK:9J]+~+ Ǹ|x_Iә3]}^3&58Ջѵ}^O]%N/I.͏ 4a/{g-Ջe%g '<SG՝_tէ q-V_uϺyZpQ[[<jgƯw?cF2RN7ZHv5ƞD³KyuUzYՑ52#M=vVEWShEW|E@ZZiZb_s$=e ZɮRk>7OMq[)9;Cta˸}K( [m=@]C]Bn*%t3&VY)IkEwQFteta)Q..l5AWqI]r]2џtJ7SF"!Ѕ-ykEtakS@)%eZۻ?iU]T-c\)>Rnއ�oV0N!7C.! 1އ0x }.)7CNGQ +;1h[]]R.5taj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV'ER7죒evC>2nއ�KяۼՏۼ3)UZN࡯ o25)6(S`.']Zg?j.LpJvG%R;_@V蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z>3)]ZAW?&)]ZAg?&)]ZAg?6)ܗzAw?wLCt6CtvKzv ?Bz"WpA֣C%+W?KV*5!:Ct:i +(if2q $ +}T,EЁ +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]Kq [kNi K[ҁ +n*տ*i]ԉ6ܼQ;iK6Cl?xwӪhZj6Ӧl\*'T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUVYkZk+5صw֚Vڊ;kM+vmŝZӊ][qgiŮִH׶vXk!]o7WWdG<*!?R [np#}lO>*&#pm?/~{9mx_r>4=ka_oEv-t<C$o3g>w Ϗ>|]Zq-?gN^&?j<79SS߭y 䀹]8.{}lTM<}|ǷWCczI6}ӹ}.K}<^LJ\|Wч8e|hˍ<>yާO~8虹?ܚ3O ~+d2N ϏY$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IR? �w*? endstream endobj 26 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 492/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +H1��� g ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>&��u endstream endobj 6 0 obj <</Intent 29 0 R/Name(Layer 1)/Type/OCG/Usage 30 0 R>> endobj 29 0 obj [/View/Design] endobj 30 0 obj <</CreatorInfo<</Creator(Adobe Illustrator 15.0)/Subtype/Artwork>>>> endobj 13 0 obj <</AIS false/BM/Normal/CA 1.0/OP false/OPM 1/SA true/SMask/None/Type/ExtGState/ca 1.0/op false>> endobj 12 0 obj <</LastModified(D:20170110155112Z)/Private 31 0 R>> endobj 31 0 obj <</AIMetaData 32 0 R/AIPDFPrivateData1 33 0 R/AIPDFPrivateData10 34 0 R/AIPDFPrivateData100 35 0 R/AIPDFPrivateData101 36 0 R/AIPDFPrivateData102 37 0 R/AIPDFPrivateData103 38 0 R/AIPDFPrivateData104 39 0 R/AIPDFPrivateData105 40 0 R/AIPDFPrivateData106 41 0 R/AIPDFPrivateData107 42 0 R/AIPDFPrivateData108 43 0 R/AIPDFPrivateData109 44 0 R/AIPDFPrivateData11 45 0 R/AIPDFPrivateData110 46 0 R/AIPDFPrivateData111 47 0 R/AIPDFPrivateData112 48 0 R/AIPDFPrivateData113 49 0 R/AIPDFPrivateData114 50 0 R/AIPDFPrivateData115 51 0 R/AIPDFPrivateData116 52 0 R/AIPDFPrivateData117 53 0 R/AIPDFPrivateData118 54 0 R/AIPDFPrivateData119 55 0 R/AIPDFPrivateData12 56 0 R/AIPDFPrivateData120 57 0 R/AIPDFPrivateData121 58 0 R/AIPDFPrivateData122 59 0 R/AIPDFPrivateData123 60 0 R/AIPDFPrivateData124 61 0 R/AIPDFPrivateData125 62 0 R/AIPDFPrivateData126 63 0 R/AIPDFPrivateData127 64 0 R/AIPDFPrivateData128 65 0 R/AIPDFPrivateData129 66 0 R/AIPDFPrivateData13 67 0 R/AIPDFPrivateData130 68 0 R/AIPDFPrivateData131 69 0 R/AIPDFPrivateData132 70 0 R/AIPDFPrivateData133 71 0 R/AIPDFPrivateData134 72 0 R/AIPDFPrivateData135 73 0 R/AIPDFPrivateData136 74 0 R/AIPDFPrivateData137 75 0 R/AIPDFPrivateData138 76 0 R/AIPDFPrivateData139 77 0 R/AIPDFPrivateData14 78 0 R/AIPDFPrivateData140 79 0 R/AIPDFPrivateData141 80 0 R/AIPDFPrivateData142 81 0 R/AIPDFPrivateData143 82 0 R/AIPDFPrivateData144 83 0 R/AIPDFPrivateData145 84 0 R/AIPDFPrivateData146 85 0 R/AIPDFPrivateData147 86 0 R/AIPDFPrivateData148 87 0 R/AIPDFPrivateData149 88 0 R/AIPDFPrivateData15 89 0 R/AIPDFPrivateData150 90 0 R/AIPDFPrivateData151 91 0 R/AIPDFPrivateData152 92 0 R/AIPDFPrivateData153 93 0 R/AIPDFPrivateData154 94 0 R/AIPDFPrivateData155 95 0 R/AIPDFPrivateData156 96 0 R/AIPDFPrivateData157 97 0 R/AIPDFPrivateData158 98 0 R/AIPDFPrivateData159 99 0 R/AIPDFPrivateData16 100 0 R/AIPDFPrivateData160 101 0 R/AIPDFPrivateData161 102 0 R/AIPDFPrivateData162 103 0 R/AIPDFPrivateData163 104 0 R/AIPDFPrivateData164 105 0 R/AIPDFPrivateData165 106 0 R/AIPDFPrivateData166 107 0 R/AIPDFPrivateData167 108 0 R/AIPDFPrivateData168 109 0 R/AIPDFPrivateData169 110 0 R/AIPDFPrivateData17 111 0 R/AIPDFPrivateData170 112 0 R/AIPDFPrivateData171 113 0 R/AIPDFPrivateData172 114 0 R/AIPDFPrivateData173 115 0 R/AIPDFPrivateData174 116 0 R/AIPDFPrivateData175 117 0 R/AIPDFPrivateData176 118 0 R/AIPDFPrivateData177 119 0 R/AIPDFPrivateData178 120 0 R/AIPDFPrivateData179 121 0 R/AIPDFPrivateData18 122 0 R/AIPDFPrivateData180 123 0 R/AIPDFPrivateData181 124 0 R/AIPDFPrivateData182 125 0 R/AIPDFPrivateData183 126 0 R/AIPDFPrivateData184 127 0 R/AIPDFPrivateData185 128 0 R/AIPDFPrivateData186 129 0 R/AIPDFPrivateData187 130 0 R/AIPDFPrivateData188 131 0 R/AIPDFPrivateData189 132 0 R/AIPDFPrivateData19 133 0 R/AIPDFPrivateData190 134 0 R/AIPDFPrivateData191 135 0 R/AIPDFPrivateData192 136 0 R/AIPDFPrivateData193 137 0 R/AIPDFPrivateData194 138 0 R/AIPDFPrivateData195 139 0 R/AIPDFPrivateData196 140 0 R/AIPDFPrivateData197 141 0 R/AIPDFPrivateData198 142 0 R/AIPDFPrivateData199 143 0 R/AIPDFPrivateData2 144 0 R/AIPDFPrivateData20 145 0 R/AIPDFPrivateData200 146 0 R/AIPDFPrivateData201 147 0 R/AIPDFPrivateData202 148 0 R/AIPDFPrivateData203 149 0 R/AIPDFPrivateData204 150 0 R/AIPDFPrivateData205 151 0 R/AIPDFPrivateData206 152 0 R/AIPDFPrivateData207 153 0 R/AIPDFPrivateData208 154 0 R/AIPDFPrivateData209 155 0 R/AIPDFPrivateData21 156 0 R/AIPDFPrivateData210 157 0 R/AIPDFPrivateData211 158 0 R/AIPDFPrivateData212 159 0 R/AIPDFPrivateData213 160 0 R/AIPDFPrivateData214 161 0 R/AIPDFPrivateData215 162 0 R/AIPDFPrivateData216 163 0 R/AIPDFPrivateData217 164 0 R/AIPDFPrivateData218 165 0 R/AIPDFPrivateData219 166 0 R/AIPDFPrivateData22 167 0 R/AIPDFPrivateData220 168 0 R/AIPDFPrivateData221 169 0 R/AIPDFPrivateData222 170 0 R/AIPDFPrivateData223 171 0 R/AIPDFPrivateData224 172 0 R/AIPDFPrivateData225 173 0 R/AIPDFPrivateData226 174 0 R/AIPDFPrivateData227 175 0 R/AIPDFPrivateData228 176 0 R/AIPDFPrivateData229 177 0 R/AIPDFPrivateData23 178 0 R/AIPDFPrivateData230 179 0 R/AIPDFPrivateData231 180 0 R/AIPDFPrivateData24 181 0 R/AIPDFPrivateData25 182 0 R/AIPDFPrivateData26 183 0 R/AIPDFPrivateData27 184 0 R/AIPDFPrivateData28 185 0 R/AIPDFPrivateData29 186 0 R/AIPDFPrivateData3 187 0 R/AIPDFPrivateData30 188 0 R/AIPDFPrivateData31 189 0 R/AIPDFPrivateData32 190 0 R/AIPDFPrivateData33 191 0 R/AIPDFPrivateData34 192 0 R/AIPDFPrivateData35 193 0 R/AIPDFPrivateData36 194 0 R/AIPDFPrivateData37 195 0 R/AIPDFPrivateData38 196 0 R/AIPDFPrivateData39 197 0 R/AIPDFPrivateData4 198 0 R/AIPDFPrivateData40 199 0 R/AIPDFPrivateData41 200 0 R/AIPDFPrivateData42 201 0 R/AIPDFPrivateData43 202 0 R/AIPDFPrivateData44 203 0 R/AIPDFPrivateData45 204 0 R/AIPDFPrivateData46 205 0 R/AIPDFPrivateData47 206 0 R/AIPDFPrivateData48 207 0 R/AIPDFPrivateData49 208 0 R/AIPDFPrivateData5 209 0 R/AIPDFPrivateData50 210 0 R/AIPDFPrivateData51 211 0 R/AIPDFPrivateData52 212 0 R/AIPDFPrivateData53 213 0 R/AIPDFPrivateData54 214 0 R/AIPDFPrivateData55 215 0 R/AIPDFPrivateData56 216 0 R/AIPDFPrivateData57 217 0 R/AIPDFPrivateData58 218 0 R/AIPDFPrivateData59 219 0 R/AIPDFPrivateData6 220 0 R/AIPDFPrivateData60 221 0 R/AIPDFPrivateData61 222 0 R/AIPDFPrivateData62 223 0 R/AIPDFPrivateData63 224 0 R/AIPDFPrivateData64 225 0 R/AIPDFPrivateData65 226 0 R/AIPDFPrivateData66 227 0 R/AIPDFPrivateData67 228 0 R/AIPDFPrivateData68 229 0 R/AIPDFPrivateData69 230 0 R/AIPDFPrivateData7 231 0 R/AIPDFPrivateData70 232 0 R/AIPDFPrivateData71 233 0 R/AIPDFPrivateData72 234 0 R/AIPDFPrivateData73 235 0 R/AIPDFPrivateData74 236 0 R/AIPDFPrivateData75 237 0 R/AIPDFPrivateData76 238 0 R/AIPDFPrivateData77 239 0 R/AIPDFPrivateData78 240 0 R/AIPDFPrivateData79 241 0 R/AIPDFPrivateData8 242 0 R/AIPDFPrivateData80 243 0 R/AIPDFPrivateData81 244 0 R/AIPDFPrivateData82 245 0 R/AIPDFPrivateData83 246 0 R/AIPDFPrivateData84 247 0 R/AIPDFPrivateData85 248 0 R/AIPDFPrivateData86 249 0 R/AIPDFPrivateData87 250 0 R/AIPDFPrivateData88 251 0 R/AIPDFPrivateData89 252 0 R/AIPDFPrivateData9 253 0 R/AIPDFPrivateData90 254 0 R/AIPDFPrivateData91 255 0 R/AIPDFPrivateData92 256 0 R/AIPDFPrivateData93 257 0 R/AIPDFPrivateData94 258 0 R/AIPDFPrivateData95 259 0 R/AIPDFPrivateData96 260 0 R/AIPDFPrivateData97 261 0 R/AIPDFPrivateData98 262 0 R/AIPDFPrivateData99 263 0 R/ContainerVersion 11/CreatorVersion 15/NumBlock 231/RoundtripVersion 15>> endobj 32 0 obj <</Length 1017>>stream +%!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.0.0 %%For: (Andrew Coward) () %%Title: (Fig_WAD_TC5.pdf) %%CreationDate: 10/01/2017 15:51 %%Canvassize: 16383 %%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %%DocumentProcessColors: Cyan Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 399 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 76.5137 -432.0088 498.6719 -51.3506 %AI3_TemplateBox: 298.5 -421.5 298.5 -421.5 %AI3_TileBox: -115.4072 -521.1797 667.5928 37.8203 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 6 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -895.2788 151.3799 1.68 2452 1484 18 0 0 183 218 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:-8 -817 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 33 0 obj <</Length 12640>>stream +%%BoundingBox: 76 -433 499 -51 %%HiResBoundingBox: 76.5137 -432.0088 498.6719 -51.3506 %AI7_Thumbnail: 128 116 8 %%BeginData: 12488 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FDFCFFFD89FFA8A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFF %A8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FD57FFA8FD28FFA8FD %56FFA8FD27FFA8A8FD56FFA8A8FD27FFA8FD56FFA8FD05FFA9FD07FFA9FD %19FFA8A8FD56FFA8A8FD27FFA8FD56FF7DFD27FFA8A8FD08FFA8FFA87DA8 %FFA8A8AFFD45FFA87CFD11FFA8FD14FFA8A8FF59FD06A87D7D7D527D5227 %525252A8FD43FF7D4B4B7CA7FD0EFFA8A8FD13FF7DA8FFAFA8FFA8FFA8FF %A8A87DA8A8A87DA87DA8A8FD43FFA84B4B446F4B76A1FD0BFFA8FD13FFAF %A8A8FD56FF7D76444B444B444B447676A8FD08FFA8FD12FFA876A8FD56FF %A8A1754A4B446F4A4B444B4A7576CAFD18FF7DC3A8FD56FF7DA1754B444B %444B444B444B444A444B75A1A8FF537EFD10FFA8A1A1A8FD56FFA8A1CA4A %4B4A6F4A4B4A6F4A4B4A6F4A4B446F4BA17DAFFD0FFFA8A1CAA8FD55FFA8 %7DA1A16F444B444B444B444B444B4B6F4A4B4476A1A17DA984A984A984A9 %84A984A984A984857DCAA1A8FD0CFFA8FD49FFA8A1CA764B4A4B446F4A4B %446F4B6F446F4A4B76CAA17E365B5A5A5A5B5A5A5A5B5A5A5A5B59A1A1CA %A8FD56FF7DA1A1A1444B444B444B444B444B4B4B444B44A1A1C97DFD0D5A %307DA1A1A1A8FD0CFFA8FD49FFA8A1CAA1764A6F4A6F4A4B4A6F4B754A6F %4A76A1CAA1CA59855A5B5A855A5A5A7F5A5B5A5AA1CAA1CAA8FD54FFA8A8 %7DA1A1C97D4B444B444B444B446F4B4B4A4B75CAA1CAA17EFD0C5A53C9A1 %A1A1A8FD0CFFA8FD48FFA8A1A1CAA1CA754B4A4B446F4A4B4A4B4A4B447D %A1A1A1CA7D5A5A5B5A5A5A5B5A5A5A7F5AA2A1CAA1A1A8FD56FF7DA1A1C9 %A1A1444B444B444B444B4B4B444BFD06A1FD0B5A7EA1A1A1C9A1A8FD0CFF %A8FD49FFA8A1CAA1CAA1764A4B4A6F4A4B4B764A4B4BCAA1A1A1CAA15A5A %7F5A5B5A7F5A5B5A5B7DCAA1CAA1A7A8FD0BFFA8A2FFFFA8FFAFFFA8FFFF %A8A8A87D527DA87D7D7DA8A8FD32FFA8FF7DA1A1CAA1CA764B444B444B44 %4B4B4B4476A1A1A1C3A1C353FD095A53A7A1A1A1CAA1A8FD0CFFA1FFA87D %7DA87EA87DA8FD047D527D7D52277D527DFD33FFA8A8A1CAA1CAA1CA4B4B %4A4B446F4B7D4B4B76CAA1A8A1CAA1A25A5A5A5B5A5A5A5B5A7DA1CAA1CA %A1A7A8FD0BFF7EA8FD0CFFA8FD3CFF7DFD04A1C9A1A1204B444B444B7676 %44A1A1A176A1A1A176FD075A365AA1C3A1C9A1A1A1A8FD0AFFA8A1A1FD49 %FFA8A1CAA1CAA1CAA1764A4B4A6F4AA1A16F4B6F4A6F4B6F4B6F4B6F4A76 %5276527F769AA1CAA1CAA1CAA8FD0AFFA8A1CAFD49FF7DA1A1C3A1CAA1CA %764B444B444B76CA4B4B444B444B444B444B444B444B444B446F6F9AA1C4 %A1C3A1A8FFFFFFAF847EFD045A7DC3A1FD48FFA87DA1A7FD05A1CA754B4A %4B4BA1A876446F4A4B446F4A4B446F4A4B446F4A6F76CB76C8A6A7A8A884 %AF84A9FD055A5B5AA1A1CAFD47FFA8FF7DA176A1A1A176A17DA14A4B444B %76CAA14B444B444B444B444B444B444B444B44A1A1A19FA558845A61365A %36FD055A365AA1A1A1FD49FFA8A1CA76767DA17DA1767D4B6F44A1A1CA4B %4B4A4B4A6F4A4B4A6F4A6F4B754B76A8CAA1A6A6A7848560855A855A855A %855A7FA1CAA1CAFD49FF7DA1A1A176FD06A176204A76CAA1A0444B444B44 %4B444B444B4B4B444B76CAA1CAA0A582846061FD085A53C9A1A1A1FD0FFF %A8FD39FFA87DA87DA8A1A87DA8A1A8A17D52A1A1CAA16F446F4A4B446F4A %4B446F4B4B4AA1A1CAA1A17B838485615B5A5B5A5A5A5B5AA1A1CAA1A8FD %0EFFA8FD38FFA8A884FD07FFA8FFFFFFA8FF76C3A1CA764A444B444B444B %444B444B444BA1CAA1A1A1A67C845A61FD085AA1C3A1C3A1FD0FFFA8FD46 %FFA8A1A1CAA1CA4B6F4A4B4A6F4A4B4A6F4B4B75CAA1CAA1CA7C83848561 %855A855A7E5A5B7DCAA1CAA1CAFD0EFFA8FD48FF7DC3A1CAA176444B444B %444B444B4A4B4476A1CAA1A1A1A782845A85FD065A59FD04A1C3A1FD56FF %A8A1A1CAA1CAA16F446F4A4B446F4A4B4B6FA1CAA1CAA1CA7C8384855A61 %5A5A5A5B5A7EA1CAA1CAA1CAFD0EFFA8FD46FFA8A876CAA1A1A1CA764A44 %4B444B444B4A4B44FD04A1C9A1A17C846061FD065A7DC9A1C9A1A1A1FD0D %FFA87EFD47FFA8A1A1CAA1CAA1CA4B6F4A4B4A6F4A6F4B76A8CAA1CAA1CA %A18384845A855A5B5A5B7DCAA1CAA1CAA1CAFD0EFF7DFD48FF76CAA1A1A1 %CAA176444B444B444B4A7676CAA1A1A1CAA1A17C84FD065A30A2A1A1A1CA %A1A1A1FD0DFFA8A8FD04FFA8FFFFFFA8FFA8A8A8FF7D7EA8FFFFA8A8FD33 %FFA1A1CAA1CAA1CAA14B446F4A4B446F76A0A1CAA1CAA1CAA1A75F855A5A %5A5B5A7EA1CAA1A7A1CAA1CAFD0DFF7EA1FFFFFFA87D7DA8A8A87EA852FD %047DA8FD045228A8FD2FFFA8A876C3FD05A1CA764A444B444B44A176A1A1 %CAFD05A1845A605A5A597D76A1A1C3A1A1A1C3A1FD0CFFA877CAFD04FFA8 %FD05FFA8A87DFD05A87DA87D7DA8FD30FFA8A1A1A17DCA76A17DCA4B6F4A %4B444B7DCA6F9A76764A6F4B6F4A6F4B6F4A6F4A6F4B756FC3A7CAA7A8AF %FFAFAF85AFFD06FF7ECAA8FD48FF7DA17D7D7DA176A17D7D264B444B4AA1 %A275204B444B444B444B444B444B444B444B6FA175A5818383845A85FD05 %5A7E84FF847DA1A8FD47FFA8A1A1C976FD06A17D446F4A7C7DCA764B446F %4A4B446F4A4B446F4A4B446F4BA1A2A1A5A68284848561855A5A5A5BFD04 %5AA1C9A1FD48FF76A176A176A17CA176A1A176204B76A1A1CA4A4B444B44 %4B444B444B444B444B446FA1A1A1A58182598460615A5BFD065A53C3A1A8 %A8FD46FFA8FFFFFFA8FFFFFFA8FD07FF7DCACA76446F4A4B4A6F4A4B4A6F %4A4B4A6F76CAA1CAA6A68284848561855A855A855A5B5ACAA1CAA8FD48FF %A8FD07FFA8FD05FFA8A1A1CAA14B444B444B444B444B444B444B4BA1A1A8 %A1A78183838484855A855A5A5A7E5A7DA1CAA1A8A9FD0FFFA8FD44FFA8FF %7DCAA1CA764B446F4A4B446F4A4B446F4A75A1CAA1CAA1A6828383856161 %5A5BFD045AA1CAA1CAA8FD56FFA8FD05A1444B444B444B444B444B444B4B %A1A1C9A1A17B8283845A85FD065A53C3A1A1A1A8FD10FFA8FD46FF7DCAA1 %CAA876446F4A4B4A6F4A4B4A6F4AA1A1CAA1CAA1A78284838561855A855A %5B5AA2A1CAA1CAA8FD56FFA8FD04A1CA7D4B444B444B444B444B444B76CA %A1CAA1C47C8283846085FD065AA1CAA1A1A1A8FD10FFA8FD46FF7DCAA1CA %A1CA6F4B446F4A4B446F4A4B4A7DA1CAA1CAA1A18283838460855A5B5A5B %7DCAA1CAA1C9A1FD54FFA8FFA87DA1C9FD04A1444B444B444B444B444B76 %CAA1A1A1C9A18259845A615A5B5A5A53FD04A1C9A1A8A8FD0FFFA8FD46FF %7DCAA1CAA1CAA876446F4A4B4A6F4A4B75A8A1CAA1CAA1C37C8384845A85 %5A5B5AA2A1CAA1CAA1CAA8FD0FFFA8A2FD45FFA8A1A1CAA1A1A1CA764B44 %4B444B444B447676CAA1A1A1CAA1A758846061FD045AA1CAA1A1A1CAA1A8 %AFFD0FFFA1FD46FF7DCAA1CAA1CAA1CA6F4B446F4A4B446FA17D76CAA1CA %A1CAA183838561855A5A7DCAA1CAA1CAA1CAA8FD0FFF7EA8FD44FFA87DA1 %A1A176A17CA17DA1444B444B444A4BA17D76A1CAA1CAA1CA7D845A615A5B %59CAA1CAA1CAA1A2A1A8FD0EFFA8A1A1FD46FFA1A17DFD06A17C446F4A4B %4AFD06A176759A7676527C52765276769A76A09AA0A0C9A7CFFD0DFFA8A1 %CAFD45FFA8A1A1A1527D767D767D7652444B4475A1A17DCA4B4B444B444B %444B444B444A444B444B6E99759F818282838384608584A984AFFD04FF7D %C3A1FD46FF76C3A1A176FD06A16F204B76CA7DA1A876446F4A4B446F4A4B %446F4A4B446F4B6F9ACAA0A582838384848561615A615A85A9FFA9A1A1CA %FD45FFA87D7DA17DA17DA17DA17DA87D7676A87DA176CAA14B444B444B44 %4B444B444B444B446F6EA1A1A181827C8383845A855A5B5A5A365A5A7EA1 %A1A1FD56FFAFA1A1CA4B4B4A4B4A6F4A4B4A6F4A6F4A6F4B76A1CAA1A682 %838384848561855A855A5B5A5A7DCAA1CAFD4DFFA8FD07FFA8A876CAA1A0 %444B444B444B444B444B444B4B6F76CAA1CA7CA682848384608560855A85 %5A5A59CAA1A1A1FD56FFCAA1A1CAA16F446F4A4B446F4A4B446F4B754BA7 %A1CAA1A182838384848560855A855A855AA2A1CAA1A8FD10FFA8FD44FFA8 %A876C3A1CA764A444B444B444B444B444B4B4BA1CAA1A1A1828283598460 %615A61FD045AA1C3A1C3A1FD0FFFA8FD46FFA8A1A1CAA1CA4B6F4A4B4A6F %4A4B446F4A6F75CAA1CAA1CA7C838384848561855A855A617DCAA1CAA1CA %FD10FFA8FD46FF7DC3A1CAA176444B444B444B444B444B4B76A1CAA1A7A1 %A7828383847E845A855A5A5AFD04A1C3A1FD3DFFA9A8FFA8A87DA8FFFFA8 %FD0FFFA8A1A1CAA1CAA16F446F4A4B446F4A4B4A76A1CAA1CAA1CA7C8383 %84848561855A855A7EA1CAA1CAA1CAFD10FFA8FD2CFF5252A87D5227527E %2753275952A87DA87DA87D7D7DFFFFFFA8A876CAA1A1A1CA764A444B444B %444B444B4BA8A1A1A1C9A1A17C8359845A855A615A5A7DC3A1C9A1A1A1FD %0FFFA8FD2DFFA87DFFA8A87DFD07A8FD0CFFA8A1A1CAA1CAA1CA4B6F4A4B %4A6F4A6F4A76A8CAA1CAA1CAA1838384848561855A617DCAA1CAA1CAA1CA %FD0FFFA8A8FD46FF76CAA1A1A1CAA176444B444B444B444B4BA8A1A1A1CA %A1A17C8383845A605A6136FD04A1CAA1A1A1FD0FFF7DA8FD46FFA1A1CAA1 %CAA1CAA14B446F4A4B446F4B7676CAA1CAA1CAA1A77D8484856085617EA1 %CAA1CAA1CAA1CAFD0FFFA8A8FD44FFA8A876C3FD05A1CA764A444B444B44 %6F7D7676CAA1A1A1CAA183598460615A5A7DC9A1CAA1A1A1C3A1FD0EFFA8 %77FD46FFA8A1A1A17DCA7DA17DCA4B6F4A4B4A4B76A1A1A0A1C9A1CAA1C3 %7D84838460857DC9A1CAA1C9A1CAA1CAFD0EFF7EC9A8FD46FF7DA17D7D7D %A176A17D7D264B444B4ACA7DA8764B444B444B4A4B444B4A4B446F4A6F6F %9975A5A6A783A8A8AEA8AFA9FFFFFFAFFFFFFFA8A1A1CFFD45FFA8A1A1C9 %76FD06A17D446F4476FD04A1444B4A4B444B4A4B446F4A4B4A6F6F9393A1 %7CA5818383835F846085618561855A85A97EA1CAA8FD46FF76A176A176A1 %7CA176A1A176204B76A176A1A14B444B444B444B444B444B4A6F4A6F6F9A %A1A17BA67C8383847D8460855A85FD045A7DC3A1FD46FFA8FFFFFFA8FFFF %FFA8FD08FFA8A1CA764B4A4B4A6F4A4B4A6F4B754A6F6F6F9ACAA1A781A7 %838483848485618561855A855AA1A1CAA8FD46FFA8FD07FFA8FD07FF7DA1 %A1A14A4B444B444B444B444B4B4B446F6FA1A1CAA0827C83838459846061 %5A615A5A367EA1A1A1FD0DFFA8FD49FFA8A1CAA876446F4A4B446F4A4B4A %754B6F6E76A1CAA1A17C8383848384848561855A855A5AA1CAA1CAA8FD54 %FFA8FF7DA1A1CA7D4B444B444B444B444B4A6F4A6F75CAA1A1A17C82837D %8483845A855A615A5B59A1A1C9A1CAFD0CFFA8FD49FFA8A1CAA1CA754B4A %4B4A6F4A6F4B754B6F4BA1A8CAA1CAA18283848384848561855A855AA2A1 %CAA1CAA8FD56FF7DA1A1CAA1A1444B444B444B444B4B6F4A6FA1CAFD04A1 %58837D8484845A8560615A7EA1C3A1CAA1FD0DFFA8FD49FFA8A1CAA1CAA8 %76446F4A4B446F4B754A6F6FCAA1CAA1CAA1FD0483848485608561617DCA %A1CAA1CAA8FD0CFFA8FD2FFFA87D7DA87D7D277DA87D527D7DA8FFFFA8FF %A8FFA8FD05FF7DFD04A1CA764B444B444B444B4B4B4476A1A1A1C9A1A17C %835983598460615A615AA1A1C9A1A1A1FD0DFF7DFD30FF527D7DA853527D %7DFD04527DFFFD05A87E7DFFFFFFA8A8A1CAA1CAA1CA4B4B4A4B4A6F4B76 %4B6F76CAA1CAA1CAA1A7838483848485618560A2A1CAA1CAA1CAA8FD0BFF %A8A8FD31FFA8FD07FFA8FD0FFF7DFD04A1CAA1A1444B444B444B767544C9 %A1C9A1CAA1CA7C83838459845A615A84A1C3A1CAA1A1A1FD0BFFA97EA1FD %49FFA8A1CAA1CAA1CAA175446F4A4B44A1766FA1CAA1C3A1C9A1A17C8383 %84848561607DCAA1A1A1CAA1CAA8FD0AFFA9A1CAFD49FF7DA1A1CAA1A1A1 %CA764B444B444B76CA4A4B444B444B444B444B446F4A6F4B9993997BC9A1 %A1A1A7A1A8A9FFAFFFA8AF84A984A97DA1A1FD48FFA8A1A1CAFD05A1CA75 %4B4A4B4AA1CA76446F4A4B446F4A4B4A6F4B6F4A6F6F999AA19FA682A783 %8483848485618561615A61367EA1CAFD49FF7DA176A1A1A176A1A1A14A4B %445176CA764B444B444B444B444B446F4A6F4A936FA1A1A181827C838384 %598460855A855A615A5AA1C3A1FD49FFA8A1CA767C7DA176A1767D4A6F4A %A1A1CA4B4B446F4A4B446F4A6F4A6F4B6F6F9AA1CA7DA682838384848460 %85618561855A617DCAA1CAFD49FF7DA1A1A176A1A1A176A1A176204B76C9 %A176444B444B444B444B444B446F4A6F75CAA1A17C828283598483845A85 %5A615A615AA1A1C3A1FD49FFA87DA8A1A8A1A8A1A8A1A8A1A152A1A1CAA1 %4B446F4A4B4A6F4A6F4AFD046FA1A1CAA1A7828383FD0484858585618561 %7EA1CAA1CAFD49FFA8FD0BFFA9FF7CC3A1CA754B444B444B444B444B446F %6E6FA1CAA1C3768282837D8484845A8560615A617DC3A1C3A1FD56FFA8A1 %A1CAA1CA4B4B446F4A4B446F4B6F4A6F6FA8A1CAA1A17C83838483848485 %608561615ACAA1CAA1CAFD57FF76C9A1A1A176444B444B444B446F446F44 %9AA1A1A1C9A17C58837D84598460855A615A7DA1C9A1A1A1FD56FFA8A1A1 %CAA1CAA14B446F4A6F4A6F4B6F4B6F76CAA1CAA1CA7DFD04838484856085 %6184A1CAA1CAA1CAFD57FF76CAA1A1A1CA4B4B444B444B446F4A6F4AC3A1 %A1A1CAA1A17C835983598460855A617DC3A1CAA1A1A1FD40FFA8FFA8A87D %A8A8FFA8FD0DFFA8A1A1CAA1CAA1A14A4B446F4A6F4A6F6F75A1CAA1CAA1 %CAA18383848384598484855AC9A1CAA1CAA1A8FD3FFFFD047D5227FD0452 %277D52FFA8A87DA87DA852A8FFFF76C3A1C9A1A1A175444B444B444B446F %75CAA1C9FD04A17C83598483845A845A7EA1C9A1A1A1C3A1FD40FFFD04A8 %7DA87DFF7DA8A8A8FD0BFFA1A1CAA1CAA1CA7C4B4A6F4A6F4A6F4BA0A1CA %A1CAA1CAA1A78384838484856085A1A7A1C9A1CAA1CAFD57FF7DC3A1CAA1 %C9A1CA4B4B444B444B446FA1C9A1CAA1A1A1CA7D837D8483845A857DC3A1 %CAA1A1A1C3A1FD56FF7DA1A1A17DCA7DA1A1A14A4B446F4B6F4BCAA1CAA1 %CAA1CAA1CA7D83838484857DC3A1CAA1CAA1CAA1CAFD55FFA8A876A176A1 %A1A17C7DA176444B446F44A1A1C9A1A1A1C9FD04A15983598459A1A1C9A1 %A1A1C9A1A1A1FD56FFCFA1A1A152A17DA17DA17D76446F4B76A1CAA1CAA1 %CAA1CAA1CAA183838484A1A1CAA1CAA1CAA1CAA1CAFD57FF76A1A1A176FD %06A14B204B76FD0BA17C7D597DFD0BA1FD56FFA8A17DA8A1A87DA8A1A87D %A8A17D7CA8A1A87DA8A1A87DA8A1A87DA87D7DA1A8A1A87DA8A1A87DA8A1 %A8FD55FFA8FD29FFA8FD76FFA8FD07FFA8FDFCFFFD89FFFF %%EndData endstream endobj 34 0 obj <</Filter[/FlateDecode]/Length 14260>>stream +HWmoHG5^UM HsVт76I?~gok0 9& +س<;> ~F^רo]Ʒmר}c}LT<$r0!!zhv=;OFv +y}F�0vj C)Ktk[o7 ,W)Q_Ft`6>>?]0jڸf_ y)q-aNb|0x9 C,Yf䲤(5ְG}:N<VI6 u36oA m=c8V0V E8Nèy9RAsEL1MNeyQbEhnB,kP˙)(]a |gƛDZXd(aV7<7?qt6. W 0IK>UsUU{*JpU]$K7̇ӗ.Ҫ$4U5SKEkZMkӚ5d j'6,[fؔgkX5Uk^ymO׼-DfcY("aԺfͨmw|H̚v|*X^5jZ{DZ;IL9R,qE=y$$;FpM)rMdG3D9A[L\0v" +d Tm]UxdKL&@Ǎ@%NMx;jʨ9`(<[İO;5h䕡\[ǟϤz&=t9S9{HY dm�;xJwdʲ59APfZy𒷲^EK7 I{PX{`{w=TV$e= gnӪ@v'Qӻ.&CDWR۝> !g^3b-<w&kxa? RAπՕVg{eڣ/'IW`ryC8q)b$.Q}w'0ݢy(1 }2^TO/MkwԽPSZSƬ#X4 -CUa ]m]D>~7/ |mOWn4C>XꞴZmwƬp;`U ØяmrwmK;pM63eC9T! 7nׂ֙ ~G1{RU?  MN0ss?^0w+ +i$*HbΆ!^%cpCդC: )]2(s&TS{\?eyIcZ=xV\ZgOZ<!YЧa֛d\+ٰ|[RY"f!ѺȨ/,e8%NpSr. LFv; 9஻DKk+MnkHL=s2.Ks-q43ߌ #o:Cgb(O4=uhAQvjIW,o1I?8d/sN}?vd> rSI6v:ё |~7΃}j1Ϯ~ ;" j#B&)\(˩ÐF%O +5~dMYf]gFY]tGPI4߅/9: ?-8MsllsLg=Q;o'H,Ў ۑCLA/o8X`#t˜1$d'/_&.l1VG\3k~(O?Wv:Ʋ i5uc*1v=hR!Nof1P'^ܕHd44_^@&ԇ c/ٽ|81,=u� :>(PV +(++|3[UĨʂ */(<m BJIѫ1f d f#4Gf>]m�l}.SKk?M_8.Yr&Y<6Lc]ٌ[Up9_.Rѓ/^l QY>3˕5 qU/C-x.r^M] +lJ)lZzla!5%NXilmSo^2dчz4+0`wds{45]`<f&XjnU7[= * +Yd.d6v3s To Dq +B\BZۡ;e +9\2NP̝W*l̪4&GĻWq6ߓ'Ҽ+Є-Hr?$<odɲᣭ2e¬2`UY Va[Eez SXaxJ&/E켺;ʼnA˷T +z(bDeKEpVߺeU\E|i) QqSݼjˢyRd}XGCO X@ Bcw!Gb 7Πin-(JT0v6 +<_r֝߷^ +".Fm͈Nmpb''iZkhZHMROZ֫m_8:$}{/AOdȧWGD=ԛW܋0^F?gaѿm +~WZ +D@$ak<{%gף?~O|zP�̶Q(D CF@�RI[Rr9 xOh'7ѽTpsr3N8 + 6hr,|qb}<AC@ѹz(:CN=0c1\+"?!'K\.gÌ_M`& Cj%{y;sbvFd+Z8<*Ƨ +Qǃ  ,9Wyz4= T?uݒC٬[k�:<T?O:?78[h-竒23"Uw+*C6ƳĤ9)f ,UVxt3k�tfOuOԵ>CsA|_o>W+3{ܳ�>, +F)S)L 8סYŠ +dDazAZ{ ?kANW Zގ2_.)JT +nď +x@^( g6 Tm. |n}&oȵ%պ}ɺhpukyT|'h +&Z6Hћ tK:>r诠Q_P_Z:e&lY2z�h2{ 2JV,z|1OƜ OG/a3qlԭ[ZpwU<k[HxGIw^'AZ#gLS a\<θ@rsƣ`TV~_pR"[ZO&I6_6ʬDTr;HIu%plJKi.! +:q #&R+H}D "�W8ib4 HGU*T?d04q@u3Œ'tCuc7aJ}~� k3GpΤdQgqAdD"BQ헄KU;)T},N#X+ 0�J#UcQ"W&|\jL8MC.r6(mk59kƹXW%v$5;Bs'n! ;2-:1d0 țGUp=V=˴_Cc@U3B!TR_+PS1c6Hj}ɡ u'=a vP=k=4P kfx|xM#k Mߘt83vNR}WhgNf:q~2{.s3!:\c̃mx-i=jg_7Tr|̹}<{J}WT*87NJ&>x$0[oӧvD:kuؼּ=.|⟶itݦC]1nG75z+O'rVH}43ks< +F{SZ~:zBRChl*DAD:Kޖg-z*L•9KE#C0 <DE!6[<ӰKH߆dCؠBFj.::'tZry۞V4-me| >{82L/$} +& 6: +FՁFf1ch*{]qѥ~"pT-z1ROGx�SɞUo y�dimk@~UC_5$`|IhF)VqފRURed%[RLPD +�3푫]UH$"T!e;W $M� icr{Z[7(CSo+tpNȉ=à-=57A.EWsYle-eBfRӟ<I佹<O;@>OUO|X$.".oq0t̬KZTxeYjkN q˅LX<Hz Pc3EjR@aooE_ؤKFUCsy hO$m Ca)ɢA;.6ؗnc}eWi&/OJr 㣏 +.ˍ74'f(fa7 #hNh6n d#$�2r0lC4,}:u0Y.tѬ&U-bWEULp#:-Үuh)ctκuuCpb4hU&z=,x˩cd zF=׉}avKoiEVWqLZ1GKzp>oim|yA4`Bc]=&'0Hƽl!W[_|ah 3$^11^pRܛ]$K>df-dltD4_tm, +g +{7h.`2?8CGhh'̒f`YL^ۉjK JISkhD0t>O %Ʃڋ]s +銦!x+mVQǭ:AZmtw-f/۰ v$$~fGU]yP.ee4L)dV0}YLzڵ+eA 72?}r&8*3Q9ݛ)OUKˁMUGNh3GA +.eﭝ@)OD25ˤUEp� OeNvֆҵ/9~o$2<M2ց@ԅxdmt۷�p#T Z0&) Ď-esk:}@Q+g[\Girzo;x 81uFoX uY w8J;m['L>̙MUQ9K Æ=# �XXՕO_" 33`N]pwlvsl'ƍ]O pN '`VI +t1%Y/H7AD1_Q gؿIAhCG G$| +ZmծÏEQeVvTmΰ!K`4h{5,^ͫ*h3e+զ@,Nnb) ?݁h^w_덠ci|>ם?MXq5Ay8{Ϸrg/ \ׄ滿r^׎kOGt :|i9,t83ܰ+3Şd& +'/OȆvn: y;_=鋁Cibv:;ƹ1�._/*϶RG5{) SNUAЏCΥX2ΫVyǃ3 'v{37zVml4qN..k|ڶQ >W'\;aSHM - +٢T#pg_fJ݆Z1++)?S.ke4e.n\e@xR3$tryLe2d`," +jaӉ Qh\QͤfO ψ]Z~(L<}S^Aư<6 cQr6 5% X,Pexpdd+,7Od+|y#Bhb#aztŎ1ӷF-K~JI&-aԗpC j|x)<p>{WdBϯn,6pu#(_"(d6R?c,-Z7~- x['-O9Lp._{MR8?- }_t{o,$j +]S<S36,,bۤM5"H-$*;ReEVQ/I[TP1{S2O"֥[$8<^C֒/)E09qh'|Pt<v_U(ݗ$Z,i4{X<a`עZm x<tl"1'082avΓ=f2Dq+*;y~ʵ/d̴+oEʼ>`°BTl|Al0]g,=IA�c V}sU'[:\ u76^ڇZ -Oסb# +=W3D//' /EPc$ٟĭSg(J\}?^")ID |ǩ֨S18ldZI7L__!_Ñ:9kZveg +U[ +%QBZIe+9h?._dS)Ǣܾbs x]֡U^)<r:d+leeiX.[+~ʖ;Z}p~Q$ 57T*ٓ^@DQG ŰٙJa`{ QY!hyLÏYV\,_=-K^l34 .Dvz|D6вWkIZD4+ۇ%>N%'V99v[䈉<~Q)k9"͑c@2 +4BTjh}]:ĀccE|>f>xE+Vɚ9"Ȫ JSj98GfZܚN׹˳r\a tK&\-l"Gˊ3~Q[$8G +`kqt$F]S]Z㕣 ] |2*kf |F?;E0ÓNn# Z&jj6;ihI_V`kԙy:64; C)_mr"kHڒN_/ro!ߔD@uh>`0dwc2qK)ftmR5lb6xkn5&"{ӯ/j=WU_Lk!g \7-_zh FoC`W˘7FJ_Z@( =RL]܉k/ bv+8)w#D}v`.Z +ia9:UfKg9c&g@= 2:c=-F]n[^=X<xnNS`* >{h!Q!q7+>3o3ސϤT{p+Ĕ +W IIHSm)U:=f+r}wS71RBP +m_{cZ4P3jrl ~U`5VMO|%]�55a ɬE4اɢϯciegbmdVݩD4IȲ*5x]H|vX@{Հ` ~y/كuJQdlHI e*큯cpVH!e M }mlr`I[~n"U9ro#v<`'J2LL*86Q]+CjבجT`kUºۊk*cAg6rwuZ%J=KӋg+_|=8iي$ʝ Id8Bɶt`slAolyAPɢ~Ќ+Fb>Y 9ǼW7S]ǘe" өhGwjgbi`Qk ," +wj o7D2NmüL^CP"e_p^,RE35Z!f!Dٚ6{,WT+`RǺ Sz?9?RV^vee[~0j+ +=.XL #OjU m4=VZ09xBّw%G;GhOc_`JNxX*,,47I#cC u.`TUL *L_a'3UgK8"u +LTM!m./CX5n7ͽ5&86 ʚXIټPcvDs JXKIF~ӑBٔa_ѓ,'VZ(nӽÑ]j,)\I.F؆S9QQ+a2FL#* Bַ E3R'2+Uv-A铥X"G;4L~HoH(;KM ПElqdrcVV{]:!T:i?;Pe9dP̼G]Lp^ejz%juR!c`%Lބ'~jM&F586>*l" z3T`ükS6+,:~8edEaV+@QuHul%U[O:~9{0(3#ql бvmy5N+}tޘ9iVq1hj#*ARhrK"bNGN{`{dR:/5+M1d s.� rb̟CmtlM)ۗə} A :S,^fgӎP ${'ڽlRt$.hF|I!�"x�+ʮ)Ȇf;S܋7SG[54(߽hPN0ϏI5"Ԡ[e~2_d PeO6iiU>^Om|q 4q&n"k� !̺(Oe:RRKnYLف3dmפR¯h^>9uG +4ɇetXa "yw30%R.37,Y0uyih#tq~cJyq +3+9%c9B{%\eO[>] a�e؂_+6x Hv@GK v,yp}w*bfjsߡ>rh œ>piBtװ.R(ʖHvIf$ұ/E`>]`k{N.-\̞ǭ"LħŴ۫e'Z'TTĹUv‘v\ggIT`ɿW ^4<[<]"o]/i<z<*(.ʴY/b'7@c&~CzCH \G9.d=c_ ‚t#,2 \'~zlrmg`D4.߂;4w Ob˥0({WheWI?802bQLxN<o5=cQARĂGZT cBnG}sb1)bP\,`_ιGoԤم.+(zzc#^7;OA,n.9̖fqRk}h^ H`ָ<kuKl +|}iJYtu4kѼ&+E6`c>g b1!}snܜ)==ےArU660%5'pО]lnSᇶssR?ء�/\KpWy/(gwC{e. /KFd�y*O3!+yY)p^f6Ŏ=K=uv9{)*@.5]x_9*/ҝa?LOg|#AX�Al#olxp~MQt 2F~l=w{,%uIREo-"([%}`JR쌲FPl?LcfyGH:$ΐq�j{Dˮʄ#g}O;qq⫤̾Z9h_<rӿiMy}Ɍz)Su1]K󳼸H~jʹ)u!/?*&a*^>q|(|!_( ]H::!,jɬa/"B7Ch<2d8#s(lW35{C%T\9a!DCަv"- gpۉ\3Xe(V%P3Qg߈hn(dt8A4:*&VtjRq~J?ac|OSLjp $W!½$ cU4UMj"X(Һ\BRl r9:4 cn iB$~JncߡCuT6ҷ%Tr@Cn>\ӧj8ZCa"ꀟX678kh?Dhbi)KjwX1>W@IS6О +by/EKhA D81gvA%/銎p?FR`5A>+AfdwP)3iACXiHs5O} +$wT ^JL?[Fz=O`5K(/c枨[A0ƏFM y;+'khc/3؜+A{ϔL-n7h*1סk +ds�;2Om+]ŪQ€5fxִް-,˜Tw�Zc?d6}ЎV̀:XS>JnY:e = +(dMu)jK:oT_>c :c#mZCk㾞MP@1"zM + Ƹd Pș�:eߠth4`@ o'GZ&ѡ'Pt,vs~J5C5œAs8\/aPi'�+Q#V�͟?P+4Q |ـ֭Ab&2rߒբvdƷ)"ODǭc}QB#)k„ |y،{AumI%X6q* +үSj4'j*yӟ۪!Y/TM#]uh>lF@=%Lcޜ:XWcjvYiY*uϘ>VݜS~˧%`IdV-}a֪؍8=aVLUKD38 Qƥ)_Ҥ"bC7m>8)" ,-&NW迬Wk[J\"жx*X.KiQ,xgv$aw~'坙w޹x8q<s1<[%хY6 0_ѓAWwA Y99+&&9ų.j"ڟLckָ?{GΞRNr9dvt-tN?$Нswz<:%j+tN-r:wNܥ #;sԿ45+,'tտ)܃} )�"/tHsȜ~5Ng"MqTu\ظB*7w=/?$N^H(Cοǽ)B~=Lџi,;f@<yY&zGQ,طU a yDk:yq%Ɓ-!Hl~1h|2sE+fC .|\E^l:f 3?ׁHЮ7踺1A`N|�]jȟ jRhCzXкt,e=ʥ*r`˻u:zH3A~fLGXM%I2D'K~3ܟeĘ_~T}?:+f#eZDG;F>W)4kbXImS}z֭j,i�� zא!� IC cBMe4 SN._qn(+A Ճ@Vw2ˏYx \CSׯ +ʔ[äY1@.o٦sN~ʧD,Uc<SwIs7P;ki-VgsO#cP0^+' F=PP*%dc~DŅsYȊ#J<;^TvI}]TgtbRЌǠfnWµQk#LoG63JBZ]ģ" $۔N*XHʅEg*KEٝow)Sd](Qr361QUݻ{XEXF/>U<~\n:c/Ow -wAXQ?RMeH}U@/O5N%%FwAg7TO[):ZiXSa=@ +y /Sёx@H'oJn=B{ XQֳϕ̭ >?]P O|-;P1҇`@r١QJH�,[[J� �x&Vw-Oɓ ^ٱ37jw3u% ir)yɫ'E |%XGq|09braGx>հZqᕫ>q'c豉rCE&@OHY-jHyZck׻4Zde >>XpBPNkةނfش}U`h:{C +)A)W/)}Ji胘d1Pnt\=ȕ0] tuEZm^N/S/?o:]VpBF;ۅ�J=D 0ۆE :t.lZͅZu̎ +OSGurO.oJ)lky +b,%Mϗ~\ӫj)ahyVkҷ(v=D7KEzUh䤑=+*JPa cE\Ddǯ}%()y`XќIjќAtF#k �|.F_�/ׅ endstream endobj 35 0 obj <</Filter[/FlateDecode]/Length 2033>>stream +HlUGV6`6őMDsFtPZhA`SֶUKIRK齽@ js9mZJ-Hf[-0Y=8I>4ǽ97�DE&_lOFJB9!3 DL:t7}j~6 s3G2t_ OpD!lM{ <P +M+LC!͔]pGP 3M{b "u#=;m<~R -.wC�;Vyb9ǴG/�>w~w-zh  +Jp ›PD?x*Q_Mk:/mL[>nѩ????jՕ +XN`*^+o8q!>%=HOB#͞-< Ӻ[fϽ? m&Z,XOjJEￕ?h4NT_s]B{n4<λ?6~2Tӫ'|y5/zQzD2꽗wLJe~)Rw(o ,CD|s`),zEا:+]wߝ7 ݷ)ﺯ[W.F̕&$ #?TR"zE(W*5}Q'쏯BAAaNj>ns]j4v'NtJp X͞+E>(qTPPLyTգ+n%|FAcqR0;B?7JppM0;'V΋p f=bqG;e+^R\ }%pWR@N/Ϛ>JG@Í~.RkK1ǜ#C^AA!_}Nj;㡷% k!mZ$woޓy7:2&ex??4<{w?h4N]SGW/"n6$j\#1=S=Ѣw]do^4!RP\?Z�({u^?h4N[6ú2T1 nCBƵ?>CQM=?+{]}#๼'v.>?.M+|y8?zCG?b!!VNVD t *8rޅs?Z?&Aatz;Ʃxk:j߷Hpb%n3)lDˠٷB6abx_)W[cb2hkN`ẽur!>%HUG*b!{$ʞ.zeXž&oHXx_5NH̏a=ҧ^ nDB­?. 5edfC[_~f  :*t?^Ma3y7,y17;cFhP*% +VOndwRf?^ ǟ 3Q ?X hnkcoѻkJ5E܉XK!>zXW7zk4x7vqCgjG0V_Mu}{-1;'ixc܉XKE,fϒeELV^L3oNc>? Ӑ=d2p=}y]}"PiLZ#y1S[Kޭ)gozfILCp8OUߺ=WC8`@k8]^NBAcx�oM^-0s"!ݧVgyCM{pH2< n'�l endstream endobj 36 0 obj <</Filter[/FlateDecode]/Length 2432>>stream +H PT�mFRdbTi}1">0ZH4 hZF^X` .+6k5Z-63Τ5N;a#]朻~otW'g{](~#-S,@s 3` o(hYy`= y"m.:8gN9>nk)ϯh}W ق!o)h2B4tw+2em?9ת,!v,2ɖ9$v zYE6̥Ȓ/t\ONa�5k sY6]f Ǘ4I#sE.E&+kKgq֧X2sglX7vSV&`,a` +ڋyYmMJ[N2 G/d<Υ`^:"?*^1x``8CZޮh?Y2K84ŕD#=(ۣGYJ,Lc.˴|q?bC TKHa`ӺEwƖMgìa8a/΃JVz4=mGqCahn|bmΈ( n/ Y=:}%|f?E^C~#05??Di|}UnHϬw5rU Y51͵O;㛍urG_yV ${#BޠhwzyBG:\GӶ4HmX-p&ra&^(Z78&V^ݯ/\zy,9[4k;9{փYb%{#Bޠh3'MUP˳pRo*&?r?b_-W�40 >@ٰ?|?>/*af_|yi2h/WF:9GKynEDspwDq)Eƫ[5tG;0ey???%8D,G-0lDHJlgI#3E.wGbm͢3$m:Ufx{|V0L$~{IG:dЮHҍ]Cz&�{ LjbYZ<?>*um99;"돍wo1[5CI:qY$_B<p4Ȗ +g[gc{ oc "Y<;lvyNVc`qA6$dGb|,\;<9 ү#;m ;4DF ;h:$ r??ԺEwƖMg<Qzϑ!Cה=?udh2h/[+ 6必10h4 7S>ppDq(ǬkݬUM2jKX:#6h+7>w1c ĺjUn|_y<3j4Dc} 4jΝVK`?JNj4690__d` $;$BR?Vo]ϲU5Zh|;RMɸ3zT?,G'ʫլw%La8G~+E^`g梃Xof_6yQ!O)}k漢HO&~#I@lq.G?G OZ wt?^Oa6C4(\1yaSW<hyBHxNdj +FtѰv}w8W+=zOy6#\:{U/9"4Il_#"QѠ*'Q5J5hk=??xð}S/szGy4gk g=|(T.hΙ.qpD^B~!7ޝzG(nio �?FZwm>QewY(?p|i?[6&.[)D2O5wu{7y~io5H?[Y:EwJ߷W84= MZ9K". Bz7Lk|$n!??be<l"7µ_agOM2Iw{%!9O"Gup=X^Y(.JgaXj0c�#�~]^ ǗƓ��y endstream endobj 37 0 obj <</Filter[/FlateDecode]/Length 2200>>stream +H}LUdtu j::fWu]g,-^|lDA-*M{^T^ DoƥRkR\ZitYVҧ9⭜{ρ眇/?IsտEpB~QGBa:*yBV"Bֵ1K=S9c4 s@n)R,|#4�I/v ſ9.l-eH-ra'l]M-BVa!dn?LrXU�fc> `3N>wJSe',r[;cC�GCc=ni=`iEHޔ&HBVŨW_<L |+(+\<?z{& >>/SucJX@s>@{F{;8< C~OdNgrl57%P0u{5-*W#DDg.-3Bn + 􇜮 +}zX>! xWbԲ1Vzy(Z,z=xDK]yjgAgV R&9A='<pQ,gzӠ?ːzt^Vw%I5,&d=WOe<-tWA#$B' +OO]T&r @/.aس..!O5pܸ +1LNc?Uŕ "sol2q?  h)nu0A[J>&v@ h6ؾ9m17]ezӠ?l=%j]}*Y6''j[kMTB M:GMwTLck<HoiwP/?pxG i-ӷޖ6R殹ź9)z.%HDlKwͩ?ndCt)1(|AiZߜQK Sc !XOYO\i +=UD_IȃF8#1 jVH ká^h,V18< #}}>\zLCޗvTGҵԏ0HwG Gu m7Dɶǘ㞑́%5w)OLs ^ٷ 11RnoWXH"QJ?ܰ]aE,]-tc�N +U}¥No?pxG<}4 i\xcbw?j}Y8{cY}7?hٰG=Q ac}QMY^`wz Ӡ?&梁$ 31_u)θXLI4z08f0BQ�?<5=оS(Kcsz Ӡ?57;!_xgb#;wΛEBƫ?`v@#59iw>zA(sH 51lx;f\m#O�\o6]<zA(o7&3\4İ)zy` +]l|<RhjF?շ~XZz7]k5P鵜o=& O?*#Jzx.`_/UG[: :;`ؘrSu^5iph{x`xob#wÛ_dg<ˌ]lA&bhm3菱JCo3=iõ0hviཉaCScOC2fc&Ƕ<a1?hg 7~lA31jg$=s^Gs[kd1!4İoS# s;jXxhP}&R|{vmz7k[x1q1@`mʍ`_zӠ?kHh,-67j͉aR +Q$7 O_)3>zCeƟ5mΤ }v)h|-�kM endstream endobj 38 0 obj <</Filter[/FlateDecode]/Length 2002>>stream +HkPTe25K_sbj#!Jy '5n^(/d(.Q01]s`Y\a]K33B\4TLyuʨFg>>{fُ2a2d@S~ #` |�*ꫭ�%u(Xc<:*U-A 4`ི͈>sL?szx=9rk$Bb a(*2Kk3;~̡#Wb["6M`>j*v;PyV /!ѷPl;3īcU>pP)j\e<nAOuK;1{Вyk^1wKsGm#B]e]o/k?X燯|xӠ?n|Y*Bİ.8QnYzDJ}ɮ [ !֡?n??L hΫR,Y/?pxǍoBzLL_enO ?"GG[L)ٱѶPG=;opC;KOUeI{�'&v]nj Ya̚XHϛ>]?Hj'|Wg޾UTzx +Ӡ?i>\ܟuI'z܊wX$Ry%GSm8U ~!?άy})OЧ^1&o|�'&v]G^XsG]l(k_ct@\M>t ])OЯy鳝q!�7(&nAG/LzDlaQ(Un6�Eǽ7Mo`Gi;v,W)M?ub Oͻ3 ~/>PJWbǕHòʲ}zx Ӡ?-jk=F^b;3H<ȶ3ņ0!#I=ɐ@�r&z?O=U;co}ƁPL4#^i̭(e?" GV'_4?gU+B⋟8K1Oпh:Y%B pb[[‡X% 6]*)"_Xnjy$ځ�=z{Cw8< CŏWD] pb.&wG͈[] +9A;:wzC`)R?w|bm3k/�(&V#Zƍc7"G!!G +lT]c@SAG3S O^Qmge<zoxӠ?ӠEVS?J?}ʑ<w |!?`jN(PoZNG~?3j c3<ikyvn +! I1qaV-KKs&,L):4HAh[ﰷ[+xo{??L9ʚgAoClkM>5Mx$}} b^av_0(m~UW?1Cȶf~c/im=?ҭX&�w)&F~cW%l?/~<] PM0j㚹'w4%Y^f+"i/O5 pbb?2W~Ule'ն*6x??r`&l#d@l?;lT{"B8 +TVX[&c0B^S}={q[KsYvIJIx@HSu'CC�>(<F2!�Z endstream endobj 39 0 obj <</Filter[/FlateDecode]/Length 2229>>stream +HkPTDlca`$db$&u"!T\ ‚ ( ,gٲ" e5$5\1FQqLꇷ]Ɗ^\?pΜav<}~�SUO,3zh١%dy2i+Xn(fB#4YGH˄lsB`󱘹g K*\. `vTB:dCx7R&$ D6lO9ȅUP \8j3l2xpr=:"]0O#kNrh7ψZ{н {?ؐeJM  )Q6gA;yU"@hK` OA@pLK�{2UqCM`6ָOe*sl ȵtG7G"4ONVCP1wz~6%̍l SMNE)%"ũ#$h_N d<ıX?Fdbhx﯂w?T�Ӆm9MՙBm`vN}?.UK`GESD{qެki}h2Ah!(6 fCq=a7ڋˌtg=jR[sHHTD8]?)~Dc>xļbNWf?ſB# B,]e/?$C!�8/j:Qz&FIA`fb 쩈2qG>n=i`=}N +FG;&{0)zG8nA݃:E| +cR ~m_<ϓ<(?(7v}Se?KɆP\Ih{AoLLj٠/ͽZ؉q?VJ?5S?tUuzn5QR?5zVvUDy8􏍄Vq"ֳgŴN001 \-uoGؑQ?_EvXςZA()왽[g}U?o~|u░Y3#zFRjy:4Sךyz +FIA[:y< 쫈pv5Y�7 +!/񏯢g7 + ! f}gU( kij(d=sR_,xGtPǏ]Y'k[<πA!b7:zC:V?~/Qvc=!{pCXGhO1|nqެ_`,%Xno!<^.QvCsk 8Wbhtɚd?|B�])yզ:3=XAH="<=V}]'*?cۏ7 $"~%4ϳ{u釯g? ePL=W=l{#Dl r_<@Q~Pio0\$$\+"GMן.TD{uҍ1G.?RA;mׅ?�pԢ*H%}`/h{"w͡ds{jI`wEτ=V0<Q=Ύ>V0 vȶ+?!gL<']栗e&/ϩ]YkyezSiÅ@B%"fB@90yuV$پٍKTrqM|;|<eB�ͳ&]#=X<2f&򀻻K, {eS޻sh]¾Q,1  OԙX:2y# F<ww~ࡹ`cnֽ3Y):.0Dp'_^7(?(m\ !wXDh&YWu#'PV#eȆ _t!ݍ+ cJ?�vfՔjub]?0ӝ!bK+xyx@|յ/҅GX07wʊ5}nJKCknSuhBJ~zٴ6}L;,"_4cc3!qެ`�K endstream endobj 40 0 obj <</Filter[/FlateDecode]/Length 2117>>stream +HkPTiKSIӦZCiE"0f$&p1(ઓ&XwaXF].{߅墮6cS0-JdN߳35 73gvg^̓5d Ȧ 4I, + �W]?W;:mټaC,T4*a +�Bb?45j6G2W>Q<kah~]h㷢]Cl~ی*׽d=D&FʋNH}6~14c}CCEgAeS㼊ן'd5B!~zhc2=G{D:v1L?,m ~p'\o+h6=GC{Oi2amNkG@Ɋ 0G]tKt[{;Fcw}&_G3WQKV^=?菁:uFej۬ *-TdrpE Io.Y6-uIGM] 8eRWݱ7?OEvC�Fe8ZWQzs'39]gHytLbhυb{?b`?h߰?p4b(k6UػTdrpEbo|w?/Y{F~.ǧGI p\ 䵇' `k7Y53%  r&sZs,ː0<L%wc))?c/<V4#_Y43% 8|5Ͷ.!i8nݝV/Ǥy>1kc^dLVHQ S?F?r{xer_>Q`ڬ]?oNq?~%t~z=#=("t drwLqo>&C 5>w8J}f[LH cY%:+.s;)dR>CEW6b'}.a(i?Ēgz^Y}\V;&=F#ւnAO7}T|&Q>;L`hd8J4Jl*Bnew=L;'c,z8*tCl+:R"9i,nc8M=l8R\_cH% xݝI,jgw[Ŀ`d{w>[PBPgi[ǟZ0 ccpH#Y0GI!BIY{-[?Oֻ¯9֙~sRj0nc?t5;V=zw|8J1=v lx-[bBR O;*W]~{_ T~e.ЇZX'w1ͺ-z/"?p42f5ymQspExWzoQ>@�tM-=?폖%�'s;ƵGI!nY ~r޹6_?r}ԉ Is+]6`(?lQnu{ޢ`(i?ĶZm!oqpE|(:h_Cu }EYϭ$?C-quQ!G �lZ˖W:% flZ-'{N8"$SڑKoՔ,`hl'z.lFYs?;]/E�CN@Cn`(t8J-Oy)?kw<Q5͞HF fM4GG?wԫ�_m.zW`(i?pguǽﺈ?wz~cፙ߄)z9.i9{i9saռHٝANl:�� endstream endobj 41 0 obj <</Filter[/FlateDecode]/Length 2362>>stream +H{PT4 ڐL(5$#LIT`EhU01|�y +,w. .*Q|`cԎUjm8QWHv=g3g|GXanQc�9E놓ssK:?DG>DJ{Gerr W +xik+,R+ ;^O(a k3K8_$蛲W-x4hmh,n"@2~/wtFΑpp}?aJԍ]3#hyQJTi(=IIft c]S V>MC�(:򞠽`O\xZ.{/No%ϧ^ynrmsawGu;A{?σ#wT* їAi!A{?}Z݉S3oa;Zm>$/g`ˤM_~JEZ--~RM*ot%Q|8bKu/_Dy>|&H{'% %>->7a܋$VS!8N"+}?pD4V|g5?d}FHnQKwُ'!tKGpo�Өe:Q=o0G!fN}h$1 8m/3Bx>=!m2Wjh"2V[3i ==.\[~I[ϒ1Sž!S� ڼŴwYC^Y9jX'kh߃||E{nȭmY&jup+gsC]xW#9h"1 x*Xé/Ⱦf|"^Ȋ{"#N?S+}3% y#9 [ޱJ="` 'C%Ǵo:RD>+Q}=3"{66�鴗޼ѻxGjD.bR5˜}^xCd]8bqo5kx~-;1ɝ{Jhg^)?{s%u׾]vsۄ!ǧzd#s� GL!nI}";1 _S_Slxe}*\?Oc<C?.Ŀr&yu;tvn=x~Xv<i>1 %{3{ޜ'G=D9J8 o8DЎ89g0#oگ$ Fq#hG].r8bJ*i[x>VRcIV{/;Bl>GxRc+�,7G8B{m ՐS^!{ڻlGL3?H9꛳{hߏmZe;Z.>?R!_G&:tt7hAu"uqS~-ri^�`=|&y9d;8b!3H`_Jl#c̬jdQ(ڝYUGv/ί[~p6&4'a2ГzßM2ooȶ?p4c9PǪ/;]=;Ws'q.}C&^#zi#YБ :kwTgd;s̜3EU1=d}8b璠6S_ wed}i{Ys]G}}d :]ٷ< Ja苯^.wq|GSs꫺ + i䘳rti1T^o*0)J2CqZ:]$Yk '[-8Y3?e,}4 鑮>eT¬'糱e#z >,`8b``NoiԷо+#+bS >yxGJciöу?bɠ<{Λ.I`&7,UWNJҷ99&TfWtyqr*'fKkfVY:Ocm*1g +=szX4Ak`8d/rʦ}_F>]cb?�1& endstream endobj 42 0 obj <</Filter[/FlateDecode]/Length 1863>>stream +HLö.qNٲ3qZPJj? +;,Vr8%G}wWNX +v۲46ӦK7~yj<޴֑dש_:N)?d"ZAV z4$<:AQ!Q$Uzjx +GBZHmn8 ]Eg%w^YE~潚D ocy+q6F$O^tI_g<WbŲ܇Rf-ys(3gZK^(m9hH̎#;-Q{t+J͙K8O; =1tUywiOߞ+UQ 혞<K17? +ic,ёX&S~so gCLLq??Wf~ s[+GCQ#S-?1qYZC+~;bfhOɽ}N-8[j<O]Bt菉kSC.ratLoUe(*#}W=r{R쟢aL'/{(ͽ+_1e)Zu]_M F|[˽'Ю"ou^='#txGw +Q꺖YmϽ'1MݲꚕB$?Ih=v%ɝ�Cr:k/m=CtXsl^렝- 3Wi [hߘcve$=xT-H�niOyWb?@Ԫy} +#xPOqo?pF:HZv_= [#Y~~lK*5G˽vﮄv$o?pF:|&e[*WW 2Bc~Te02#}?}2(vt/�CѱZ7Y{? 3ҡ?33g}] :Wpo#]y}n>Ctl^ug�/HK[f=<qa?%(݀~$n@h?Dj?0{73ҡ?K:_ջ\T76 /WȌx݀~Ƚ=x +1,!sZ]X4es,ngCKnKnb뇿~cΜSz ˳cT.'Bnǭbd=X{m@t"]\)D;nV}ŽПTPǹD_4ͽH/2yg~kí:}~Uw2DfS5p9w?b#ўS~y%V@;8#V7Wn#~o:ӪxMz^lDa}oys7ڂ0)cR8=)D:>b>s|w$F@=gQ%Fh? 68/F@[8-_₅.;+q<Jcumף?vK wmopS{{;~Uw2}~y\_&cg{{=V/}O&y]9yb "ML {evںoZ ^iUpϪ{ +nBuCGw2Q|qt).@�: endstream endobj 43 0 obj <</Filter[/FlateDecode]/Length 4134>>stream +HkTW/ ,w]u[U+ +TP +QQo#L yڵ.u"VjlcPȄp}ܹ!8N:d_ąi䭷JCHeW# Ƙ ^HH\nuia?caV{ם%G'2/0#]G'~ @Y&F4!4fqmEh GfQE%hٔH@ep!T7|4G +!BZՙU%V_pd|_`} k QcuNf1 Ot50f;Z)5қ=>jKn\}iCKhǏoΡ1L 5J/Q +x![Q ) em2fM1yž0@e3VMdO^يN_n|pC$Kez/`81m9y/#&fJ/9?E`eFT +.*niL⣍@6 ՠb{c;,9:^v![ГKXUq}}20 GJOG'8CN88?0aWI_Gt>>Hlk^Hov.zi18Sp@ckrpfh6r.\Ϛ<噾v%e)fIaH *f5s@&+x z\@n{kk֦ڛ;8#⮔0=Lza<΂RHn n>Zd86S*>=ۥ(u:w/QVgUdZm49hBDd(x L1G&Kq#cBW\%?`11 8Ək$3kt.{k?2P~D褤~<pŀxDU{66?IZ }ݟ"+kXrrXLqu ;+Ĭ닷}LUXpzOitz06F g龳eK +}U M=aYk*P K^0&= Ƹ~UNIr䕬ЪTw: 5+{9mtN>Zj= zb0CP1 W-lCO·Pķp21_9i?pX[Μ1wڌge+R<{8ߥhHC\k$y<-;&)4y2pw/);YjƁO K5"\M\13# w嫬%Ͱ^r wxOc>ӹh7;!ˢ3:pFm2ݞ_c5^ Ng9@Ŏu<{(Ϧ; )Xs_E>H ~7l݇8}Yn?Y$n&B}O崻g4`+N?>L(94\gmx}w/7$S)kkQ�2)jAprX*i$ݢղm?6Y[]+fo*kPp21#85de(i'm=!Ҋhz>ص{`@Ui{AΪz/"iN eL=CޙǓȿ*ikBM|U Ju>V~f/ˠb ݈#<Lح +fnBo!dXT-Bƈ,@h_}&KmA_ZT8g!8`;%>f['9-D{ + al#j?܇?#X@W +fcF?pXk3H\"\KE~m,@Tm +ȗ z=%�rgS@[UeBvsUi5b"8Jqxc[^ 癧yO07k7* c tRekm'Ϡ=Mg/}V)OάQwI?8LJʭfcLBmrioGW B_P uL?o[ +kgb^ƊSO{BsT#5f5)z~gbATv35u-OH|a\>FI;̍PaΒj1F]94y5V<'OY6917Qeޙ哣}NF\grq#qUՆ1= o$dPUL0O/2i1!eWdYcF?pRXN Vk(׈+Y +]myΦS 5qŸ-r?K6jnJg.zTk0{Wqtوv|�~d3!AWO)po?.wijV sY͙I,ܘ" aGx<:ZJmoe +J >6M,zbRpcs܄VV~Sc?^|<1%pLS0,kPj; b5S^iTU`\m}8m;x8 +!-d<뮬w7>t'\cW@GnbV& kv>;l"Q$ο}첎90?>} tdq +>s +jJHI={sO@{"ߛ=.OUYJ \ʈz<>'rY$=8涮b_bcѳsҚlnR=EpCC3ЭLӱ\|y|D 禀 T}[X~\,~8'^_^ې%/XR&tŌA]2鶴LIvٵ;6}mcj0֩G i1D={t۶31 I&GJV{֧58#\OϺ=q>8ݞEH`^!)ny]R{`dڝG*S=!o2Û{}\-±AOa/(qeLUUQ썑3֭N޷1CD5jL͊hdk6!=yZ-7 .KUWPwe1f)O|qv{F{P답hx a>A݅dչݱ's zcJM-MVjl,Z+ O< r%wnJ F||CV9[U#~gx^fNnVu&(yfꮍ''#XHpԩ2_ @�p(`IL@=m[/7ϬV:I͏:>pY $8�pZ/_¶D/l)ͥ>Z +n\#Ծ2uuźعƫ1 -BzvGTSx$n~ǿkpLFVjPJ xG5$/5/{^jV2^4~\ѿ_ +y^\~IB_3DHð!J_kjn뛄@,(s͸V+0LkyGë<z=;$ㆣ,?4{0O("؞vD(?5R&\F(Mgک\#yW>}$&؅EN?W^ 5ip^!^knkzGkF#C �0� endstream endobj 44 0 obj <</Filter[/FlateDecode]/Length 4032>>stream +HyTuŘjZ'!&UT* +Z%>E@æ,>၏},ݙfު,axTbwiOOGhs^N:N Qe9s͝߄=c白)uI(`_ZВaM69h**GhDh~yFw&>C-84<w"A ϵA^L rC's5ԍvnN~|& Ԥ:K}~Է "5]u*}E ?Ϗ /S <N\~w՞1zy+څsXkuleTǿ6Tc>; ABNA ,Oy\{Gn\7RgF V(ۢ8íKʒߐ 9Ǵ[bg 7) +[E<C}<,~Qz +hr,&ܹn ZJRы5gOs+%?w:fצK LBZK*Sy&|>3<!ABN^[pplQތ?zσڥW7~�/{"_jaw57H=K)C',^gN V-o_ "ts&.f^gE/?H)?"+T*N)\ުYyV~j<pMj/jqɌPwϜ@e`Y@AvY7Ys"$ԑӚ_pEQ(9M_{k{icGIRݾz"uY>a0Y)=)ЂG.ѺvjaX^!$ILQ(ցm<T 3TwU�#X(ZEduoWUkۜ5]'ZYYj֊e|{k^ \ŷa퀲7clG\VP6_j +o͏�p/H0<M ݻ$q<V$\C[kQX?R.N6{ P`6=Ⳟ顓 +gþ^̫2媴Evfܺ±NKQVƭwYgZi@eDt^0KR5{`h;;s G˒WWfM \&r +GWL }.8Wge-M$j;SK 7;3| +ggqː{'wpc? h:YfM#)ƒ8�h(P*>27X*928AHűwoE WZW8U`A:gp-m(r֌/ޢu'{i`;[rf6ao~m6ӂW|;ޯ0nU6|Fj3Fp/Y06^cGQ@Ms2[r 9Jp<_SV]OmRܫHC>gtjG:r䠩ǿ ,|υ0: ABNhpEPT[PKO}: nq3oUנ6WW" :tYk}-j}j[|ˇ; +s{* +V"ko>53t*Meɰևu%5[KX{<Y8sVs/{-<78tSrs:\|Ym÷'kM}%G 9싣?p|vϑL$򑺬1nq>o7R%1POIlW0>U50oUS#= x I_ۼ$ +ؑQ<'vCVaj?46]xR^i,M >;pA |F_5}n1.}Iir +{G CtUYT]?G_<$a]S_al4I?S`fp]a?)P_osmP'q ϚqCap]܁C8Nm?«җ.:T\|.]0n8TZu-<8T)zx0h,m(ۿ;w< S[m )`)R5:Q73_MQ7p^o;a̋AMz}ύ?.xCg v/ς0 ABNhpEPb0w?f(MeBZ|\xȤd䀰&"_IC(Sa4._afPf +{@Zj Myv菹σA_c !MeJqnۃ@cRQ&u#X .н;ק@6]M=KV]/ט8f"n)%lFdQpf20̹"0((oc]*ϖZzz˽10qSLnlB>DIxm=ssH;vRV<[jiI"}(;ou(gc(KVxh{;?hH)?�lVBXu7)w1j�kgփX@~,@ vՀ^wz!ven<qۺCH@utw˯eŸ\rn >�{@FQ(w24cy/};BNU/g3}Ez) R +o +# r\q9s6ݣחު�9? +qA?f6ܽ\<p#\j9><sg%GE>Xm/#^,> < )ac{%kk:NwIZ¯/n3 +=YP +=[m/i<eiZxS( )7ǻMyAƯ(zpe!Nӟ?rȣᄦ|kn7MuމGϔvIj/ 14C}z ?4ng]/`|+>W%?@?`+ڢ3;w=Ufi�*b2a[HsAQc,J" kE8}GQ(wˎhe&CRc0B:}I9ŷACJ!-99C:\L֘�?靦CG glxLX/I HGs~!r}K{ggq^fŗ!Ҝ+Ax0s.\~NN=ޡ= <SctPzzо֥A;p+qICTˡbF>v?/:,jWX,.+SWj +opK&H{ZJl)&9P*V?fSIǯm-pDz)4@6R=2^ݗΎAT>ٴTdC <wgQ?{O+^ڦOjxBАRx#݊'4nxZiPe n_#020TӒ817礝]D\',v|MiKI;.9mj {|3GBАRxx=FaiMfogo$='?O݅jm<w?*H;ȟ=g-\R(bWy:I?.=F-ǚN%CBYB 0�[- endstream endobj 45 0 obj <</Filter[/FlateDecode]/Length 14620>>stream +HWy_L,a kBв+R.X +Ug&d&d&?]ϽRYΔʗ?I.V/*Ac])WtW㧽uB.?/z_Ug}U.szɒwfKr + >x1ehѾRsJNJ{UG7=hJ+JS6v73 \2vfZ~0)j/o$GUE�F%Qҵ>=1S,o% gwΫV/F6=TL$pҞls|J`^$o$pD;fPb_ϿȲ,&yޚzya2R 2^-7i0F!70 %g`r9o2&ao H=qt&MG_q@z)'n(`FSi3ia�Ouy nO3=n6,<Qiytې %{ +lC.D|`oC[]wmC[ ߆(xކ|cqD! s ]89v!> ˉ][+�6/-0qJB҈v#~cQvf2� n/ntƄUIhe%Y +1t P}S^<cs1ճTKŤ{z_| sr=vx#;gUT +k[Q_'X >k]V]f V|gi q$,fTrtA :q!fO9%27A]{U\/ nB4=6Cc(s^jMB> cV(s.JQ\Иe]P*.wzAޑ[,_9[V%X}+˹޷x>w:v'rE`R 7wlʨr;~DwFLz*0[/땈k$V8e4ZF]FceV,L l8?hr4 +{R%c-1~D#aTEvi4_$[= Nf'8ܺ3a%4!0(YH?Rg|q>6Ǘ_fߙbb~q@ܧī-0eC +?rC1{dSTJcw ZJ*rSȊK1F]þKD]2r\0N�C9ZKT劊mhD=a�PN@$A{נT<}OQ +XПVO/V?Ovo'0Œ#cdCٻ#DϚ$BX@<6Y"EfMZnnߐw<I%cB C WQLx30BK7BZ&ͺWYn_zG3rsɠU WR#$A>CBLKN4:Cf9 lCT"\:b>r&Z^J;"9kqL{K |enҹ#H5^|t(dLg!o0KC},1:ٯh3e(>=e#ꮿӭT!dTIhtfė-f:K'T?<1+vnQAfǯ$ Vp@d]!U[5ywx +hYgm vTƌuj5ZO2u&@4)=v{&i@,Kp@0�az#@<<q8q{,�I^l:lV]Vf~ Xi{XƝݓwIH;h{v2;ILOh H:88:;ud5H$ՙ@ 7]N%C)A?WR}?\zL6ߙzlu&xI \*{[@rp~\"*: +<\8y*d\|<ٻ#dNŲRDW9\n:ǚKÕަz N5~2u%HK٠Ei!2~n +k�%BC{xWomܾz*fD[ +*%@;&==5ZAOcr-Z5wtb;DPd;LezrsZuDA@҇�:4`]H-ß r-4b#v#4ZOr�W䂯uOXѻ# boǾ$~TC嫝Z]PaM:;s][LD8#}&XXuo%ʺtƩt?cN0C˂%;9`~a|I>|9Zw%^zGz#Ɂp[6\K!m mNЛSfYsDQPj 3DŽw3EJ\x֒`zI+Z%-b1~rи,h}0$X|gi݋ZPP=%ɟ N&7C8O*ǹrw"BP% %zh3B8HH/j NC�FP`1i8وҐa݋ּo8'e?^Prb['/$ }>5~+coiJ]aCMN#cI8F9a/Yx^Bl%sd �6=]n٣.c&!E׷A@0\=4żqʉ o.}P!tA*N^驸?a.7RN3iH0cV80 MydŨMrZ@H2d.qP v]J5z|@@$ۯj{JXiM3JP,v*xp؃ٟ0.aXqCz z6s Ya.,i*' Q�&?^(̍Yҵĕ <6�$AE\䢗;. lНt?ZNU:%ih˘'RO!XOQxƊ?araXߚ<\ZwQcY+yXF#�Tv]Xo6S,v ժr97 i2_ +`~z8lÛƽ:,޴?z-NcKgEȐ/_)Z).P ч`Z=Se :*J=ƫ0`~/Γ'\v~ӽҭ0Y4Ԯ(f]LE)z_t?ƜdYBNWRrmmK2I yqjNO1i:65M957{(I͈0|:˂5/nnN|sL9iߩv`p|O<@nU w'P_F!x^"C^8WRE߼ u&W\B|;Hrړޗؾ~h_S9䁏pɦ)N.F: AUпrZ + օSaI T:{YA8(5N1o'R(P?-Psc~7gW!Dp[?2/ N}em1eER9nF:G31e%u^wcqټ؈ S_; zǽPD6ZTcVUNMm_8%Ͻ$0=/𗭬jN +ZZ1ڲٕPnXLLp`agryim}ɄH.D4bIw?M۟Aݕ|X𱇯(̚>*e +T|,oGVd7�Q"T-f+`j!NJ\y=ZR#ah_4D d@`th gAkza-Ek`i1:sF,WJ8 әsʤiw2-C}و,q)ļ/bs-W a^M܄y^X%ǘU6'2�8606�LrTL<ƴ0=kq4۰ǰ;"M�Di|]i΄zr$Y?v8_1=_@j񢆇 `-Xp< +v�B ,3}t�"@8FΕtNwJB{g �s.qE0Ek\D]TPr$ ƗlnBxL8(*$Q*ոWPoℜB@P䵵N087v ʄ[jkM]DvK] ]|e'p;d$os_QUKW]oA]E!ڐ#hˡ(w~VpIVD)[l+D!g i>NackNQ�j-q'gRd՞$_'8-$y /d;zzQRSj +>Dgn*5$-tq +1jW%-f{t[l//ؽ0Px h)̙_R*\.ܬbܜCQUgsλMb SRb2:|&4ݽ&ck {g;deV_phЕdyM+ %eGrwIV!Y,#Rb\P7-R;xg +hE ]\(oXP2""0?7#]/4*`cX&.~=W& +w@|%mі83 >HΕihw9aYYs(xWxh!twUu\^ gۭ1Lvsnϲ_.$c XcH a(*2]2lwmtCc1jaxg5a F.!$wlaմx Y[ } rC89,c\S]i$0dv<QþR<W~4vpdz%eNHDvG(d]⃧p7Ųx `iUbddQJi>^-`@rƺXS|S0'6h Kb>`!5& ^c�͍A C_-e)K1ؓy +"-TOQxSYL%O됈}w%{+95^ym`p`'/(#a! ?i($ i[Xx`d +w#OSDiw�N|=g +i,5ĴؾXWUmwXk:_mMTI@Uˌ1rckɀg z( S!۟#ҙA|xULwCzn]j$;|)u}0g9nX9,<'5>qUOy(= ъW;Y)2ݣ%)6U!>H;/,ͤLD(EG֗ynYC:UΧt/\@cDp{9L%t+ipz0Ǫo,(ϕt֟\Y}8-JEcb: é)W=i(jR°wztѾ;մ[tld6?\m Y}wz9IKbК9 t~)&6YG6!9{>'#� y0 z7WnK\G$9R2$ѫΠy=C"C*?\^O^ҺJpC +E8%~M5&Nf,a?tR`bgHJ!~2P| " :>!^AM?-76;(;7Q%aҕFR}AJo1l.y;c(a߬cSgRgBBK! +H ME. W3*M$)3gfΜ0 # ͓!%k&G])GDh3!ȯu@&[؀wj3p]!Daz` VW`4X8 ,@c<c)igLA^ #LTȴͩiũν1L52ua)}Ec9ZxQIo` ikY\$G XiԿ5kӪ:FzԘMX/y m+"ݦl8E1sf֡;\ :,.ALN%ϙfqK%)=y%S +:m?Pc2>ޝ?%{S c7'~ݘe;bY0ڙ/c کCDq0awY`y~PgĒ`@V}8V6I2ql0t�,~E˜ fˎ}U `Mbc�p'5a:=ch}ny1ޞe7) 1y,boq LdMGeVOٝU=9k>$5GsPYEKJw~}�A kI4<ऻyMxibKGڨB|hr%ˑSSKh{qJzp0r..ASJcR :mo_ ʕem 9li Pخy4#&LH Z@jc6_-Khi%494hCUfG(/BrTU rn^M\j̃rElPU½ۄ`f<cXAֳQ<:T2l];]Iv9`oZ�T5B Y 릁pP%\۾"6|/$ BҧkYtT(D +s_lqf\n}$i!dC`Ėx љto21iKȑVQw+)ƜLDsRͤ01-jo̢[hյ1hxޝVcm~\cp k.01G;|Q= +y{ug;nܭB3!22fZaO3f(aTqu4U +t%d3.SF(?OP‹*YJ€F%);)&SB<w׎jd%=^D +6Wy=yP- +8[y;j'+QٶboUF!# oAm0&>VzszP "6\܆ZQ*Jm8\{>[c ]L5v~x yZXB�+cgaM1W; -+U3%0 +L-t%HT:g|Icˋx*M2ScSmx9,#]]yS>wz@; !;;LV� 쬠;-,llI#yx +H_pJBK|[{,_ ؆qKSz6t`bmruض2J.`0Lݑk(1A4OW/X1rJwĄ|{{%%9j C�Ͼ`!l74~^bG°ĸ c]+V3#a"'%&*�7(KǎDg,ELF1֦(c4L8ܧfA&@ g ӟȳuaSEy6I=PL:*ȉtcV0,x-�i]XI1�½0 hӎMYp"yoD[;&vK9v ]/tK"x3MouR.c/BǿTqSjoC1ML5)˫ZaImG^]u4-jI#?wewq{6,y{3ؐwxSA^Qr*ϰT-L@$mk*pbUuI.kzKFmdaO\nw/+x/T pgnԟxQ&<-v`!0@̋$SZn.eD!9'li�B_:y?}\p1+d_[.iFYi К4Y:su1(JKs_7 +n~Uv ؾsgr[K3`Q͒HQZEu||zG+A ?X!p6' ;L̦JӠb4@@ ! P`FQ?Jqr<TZǨWMd86wFBUoM`,HQ)?J{yA];i<//U`À2V/S^TG+=,ﱊ>J݃_K�=a<+p(Eˢj,A<w ~�صXr*�ix|ߑm7i|q찥2O�82;e}Su%aHQmDV]gMP9Y5n\>f.jZt 0?p&$ŸROiRa +Ngژ=Q+E<J?k׈)z&rzm6_$2$Y q$D|+8+y3ӮCX`xJҫt-q%>JNPք%D@A@pCQQy[/d:uN- M ʎm~LtRJ*tL/y=um~'cM ^=$W Wws`辄_$!d-{"MsҤm%㸊=q8I<Dj\](j)_:<h֍]u3|,G5m7f}w[hbqK.{ \(1+Ttk,IyĚe'(i ȄHӆ +]:);Y*3azp[epAc|w9mp'XU΋F=)A4=n༽#f'4! 8I8&ڠ@/U TmRL&>gO8x;J4n4^%Y'IC+DEc2G9Ϸ=�gMw=p͇J1@/Y%ʝړ~bU(w ?1QbVK~5h<Oh.m6;efC_MOfKE/oWTMKSyBo*/k}d=o`oMTAh +euҴɚ $Y-*^I ކ#>gΤ4 ói -$ܟ 7"|AiJީw4 !ʿ+orvsYy{ J +0oK~]܋_oz^& ~V0zŝkNo""M)ԇ\?Yp"Iy&HR0뵋U w\7hR#UYAe2TdhLJ݄uo+N;C;0C'،N'MF~�;-\w*G|ah}�jD&4edžA w0>G)ۛ/9Z+1gQ"z(q&CϨ Ŏˮ. AbK!#@(<: $�a6AUY^|@ici`j`a'֡�h-A#v/)V,^7x`d\*X\xJL\$? Ȥ #_R!aH �υ(iaCE0M>(yp|ecQCɶ79 +&=ǘrLoFl c~1�!j � l!8/C } ;�}>>B0]PnO'Q^6 0Jܑ&~ m v6D>|YZRR;}u^&6| %׎l 7u"tw op  +Re~]aÒ7)hiҋs6RMCƽE-ŵaoβءm16~}{[Px7B* I[ gc wɴjRIL&Y EoY+YpM+}Z>?xjdBFl+:iy- (C_MHbM 8M`:pזgMIhY{س4# V\9iEqvɖkU@9G-1h tXA2%~Olym qOMve6}VKWڐ%'4 Wߒ̽ 2%ƕ:[Ub{l?e^8IЄ*+D؞b.^0^hҪ+^_TZ~OS�{H3$Np:3R=)byzXP=a*"c? 3! +>lU{ӜPhm Ѿ`Gl0pTr@lD/\d!PTpL=Mc\y + )WW}j/@{Nu9fLFN*$J 'l`=n|V }lypcO ̬�}|a /@/T-io/Jl0Br,锸]4XMAfK&X;6xe`GQ$t"ĉX>,8Cu 4m)å&矍U'fRء$r }\z!,74Zc_(WiCA #&V ++<Dｪ<g2փObR +jpN@,m^ ,W/>}h#eA(NQF*>>&Vey[X:_;\˶^N< 8z|sA̓m)PHGŮDj67@ӞU*^"!pK_Y?ۑ>n<Oz!4L_c_<5D??nC6`=ď>8\ +ƻ_/a"v+D"9_/8~4׽y'O>pwl#t :ۮ'pChԁ%  $ , + ʌD[=dkNWR]]{׮>>!Di#c_ C bqOЭUM1WP ++TFm�l 1X2/PCZ4 ME5èK /͊ 2cĔ%=p}P͏ƍRv!xj N33pe?U1r�`Xg[Y^&+"qfDA Z n}&jʜA9!JAf|cgjS˞8*>;K�לdĴG>$3�c3+</$rȃe`ty% њOʿEN~R!Z.? + +הVD +@\r1�_/>�C\a)K*U.`3p5mx\%\}^&`/!E:j +o %!Ye1 ^QƥEz?hұgߥ߅g\9 ҳuf@S\U(< Q]B'?_'E9]g}qm.zu[ _r] t7\ +mUhkEyzi%|nC5`A<h..KhTvcl EX,R@pK]Aů8mB31/ʬT�:KaF!0e)kҤՇ\* hg&HY4vC[�6�*i<R5zt#GSq(9iƌ o~< X0~`;F !mU y2`xܽɓob퓷u;!^c_yZz/](7ĥaF;=bͧR@s$G[nϜ:oT(^|;N՛ly%T=zbu|gK#QR2$XcYihFVmiz xHJ,BE>fGxL2\$ؤG\GŶQ|fT +ON<x5 +,|KMUހ�/b<Zm>hj {,8ǞE|[i�~񫱽 Ξ撚ֵsm?y +c +T6G / [;bzu޺Mb\'=?\ݠ%r0lf E.E*pp `#^DSձ�A"Y +ڞ +wJ2;NcAgB*ڪl=PE ,pOY*_y̍x-OPr+ +U} ͓Sp$_b/wٲ,g}7s6z~%f[r9luFaK*_=`9%Z\ɱ"R6-l^f<[FVr ? G#9b^{HS2T:DbqܱkgB±PrfF/b)XN+#!ol=)4_D .q2~Ӂ}.CXd.Asޠ Cg3FwKo{C"2B~\}W{K"V: !J7 +s~TƮ|02Y8SYW|5 ٪蔚IV<aMw}'yvCSƯtی{ t S<M|MN^*�xp q� l]n}r~,ذ@` fɖ +NG&;pfT*(=oyb <rjGFz3ʳ$CʆWOV+CUc{zM~APàN&m+ɓZ+R&%-+pWqud<S z&P eP˾dVMOY΂6À ,׷f^1>p/z#\El|HɁ"H�݀ /S,,/Ʋ1YjJÛ :KlߩF c\/`})"n{bn;@> tSǷ 0%z՜+Wֵ2 ch`lrCtBcg#M*x� |i%(5=Qln(KǖJ/#sAs+܍Xi"kfbd6ȀI 'E5`e#Y$EHzNHlj_\9BVG`*DAD$j[9+̜;–S`׺RTVa&wmKNvA-Q}ᏕDū떋n.-ȎȑRAmؔ  $ l@]6`ohaB%,= +΅%1½ Ύ>:tP&!3g'|d ߾̃o `prM҂Z4Q[jڴT MhR&޿{`Yxgvf5vd薷vB$ScEw4twwJ\(uq9"8p=`?7׳%ClXŐl П: +)i<} /m2Q4[@@"Cώ 8q4TCk%:x;~ %@@Ƌz`F&`J8!t&!f7nMK[)Sb|,"adku\$0ɥym)R z˛T=4%&\:n 9/X`Ӱ:۽('徟piwBwϟ)sW wnqPcv9>W*p1Rbd]e8 �_1c1ħX󔓿+ F1Sx%[4@I`�w endstream endobj 46 0 obj <</Filter[/FlateDecode]/Length 1818>>stream +HkPTe,dYSJJm xcQSAdQQW={vٳ*^DGAhfce^?3oNTc +_<?< jI{==:|Ho'wq,T/үyߺE #Fg)4S\,ڐ{�-ژwi^$0Z@ˠ&YCBm$]6߰G{{rKLs'}!-pn* '(#Իד +$>VΈ>Sulj?R$E8=SB@pwN! 6*)ûO< 9eӹJVjg R:%+m\c"1?i_S6$,QS?Ԇ{HͅʱFM1҅6E ;G >Cyltg*e:#5BnV%Jbgx j +xO¼VUNOjϻ_<JLՒ" �Zߌ!6I<r*ŞJFu88+us~=;A@$ɖ\c,^ |g܏?J$TxKnp*$2-GA,Lv a?5<M$ֲ%2ghJg\23X)˗Lk�/W/郵m9Bne-a>=+@@D5$dkbjT9H738K\tibʢyIuZ7= i__(`4' vX*"pg%U[viNƊ>.B2ca{Q3Bەg*tvHB7xQ j +x>IȗM?Uyt͕GQQn ~l?΋Gr>p6ӮWzGr@@P.CI>2ghJgVzzR$ֳƗ,� ۋ8)=r\W.vkk{a>g?5Ԃ}ht+I"r _tpaNt.ٖS`3�pWl?RYJڡ]L-q>~=')6vpX*&l?)1NMjuv}nݱ=Qcٖ2+N-?$]I,T{4DMA�5=9lMulg>A9F;n&Z}<j,es"ݼ.hS_'IȻ?L.Փ-fJx4v j +ـӽ"ko5E..kTP:aß9_ܾ(U8~,i%E>liތ[ugGNI8<|K>);l!/>dȩiC}?w3˦w}g{@[/f +A`g~,^L' |"YWkt)γmBi8|Uh5q�`4"!;F0&};`2V:~?Jz9IOR7Ƶs]L^>oВ?5$Yu(c( NX/β0k]B!ُ33oMKly?3@kaiZ?vD^HsuK %AA=5DMyFAq{ QSpy!�_ endstream endobj 47 0 obj <</Filter[/FlateDecode]/Length 778>>stream +HKSasӖQu#B/*03W,$ JB/ +MlLlsFEEtU])N >(;|p�[ �� 75y��T<��ȍ} *a��ƾ0���rc_Ц#z\hiol2W<��ȍ} 2֣3>liIt \겫m:��@^kt>/mZ<}mpk:8**S}l1zl Y}6g5wv{x_EDLV<GjπE>f̾ݬ32.rwkM a=dNV<3cc*<oH7jjM0L}1pl&ӆ7t++姵Gɤa1gcc?|D+Ot99!3#coFid*+*N̳&&<L=&c>=MkboB 6mKgN;k➲5g !B{ <=yGK5>5veg' eEZB!H}Mm,f|`Kպ \h[Z���@=Mk`u`UGKvC}I����1-42 >χ>X[uMz��������������2 endstream endobj 48 0 obj <</Filter[/FlateDecode]/Length 2248>>stream +HSSDET"VZWQ/CEe˲U\RրB!B$:::V=ن 8Lbgy2^�ލZUƇ6ˋ{[i)=,@])-h [ӱ}~]d͍!)VUn=s oim\<kxaU^g?Y ը3,rꋌ=S\"qzπ`2~>h5=li:;uS_d]() u]'mCB"z2}vϭ5o׬e8Hr"c꫻t/.>w/<9�'z<q0͚W̟Lo/٥[w\Dǵ}vY\Eqq(Sts2\oP) lÊ[Mghn:臌 IXHĥL8j68pP姟?뎺k09{+4(x2_R#m +}Tsl052csBfht1IX~=yolxBr {n][KAgu<#cXjuS%?Ƈ +hզB#i)]>V<G{!cժ1™ />vOc7}C{qp5#ծmz32>s׎gd=RWa\Iڣ鷯OE}Gqlfytd׏&klAY:m oW3J۷%\ؔa4 |$}G[UujzQt[h {�LuXp>G!cѦmHcCBuv4_jֻpǐ/汭YSN{2_ңo[K˕1<(9c\0=&?:V+qޓٳϏ2-52K)ǟ/G]:#80P {<}A⳴JKG6&&9K߄7>rhm_:U);u3;_X<h5};lH`/7 uvHq_;u81Qa/N\)-50( ew,ZɆlimp!c4*mKNKӍښ9!ߐwC8~w:hX<;B dL?[4֦Rire1.{Qʕ8D ,:`2̆аvd,EZk{ͥ}Ǝ.˴JKG6&&9Qgy#׌S6GK 'z:}[relJuǰ`LTDg > :h5=v(aX򊍊~7dJrptFY0 +{  +?ɣcn3ttsHPې(f|][;Rʕ4g#c)ժ1:WUQ\Jsbp7 D&U_%m3vܵ65f0U +u4Y&ǯ2>ڼ6.^|Fƞm󚵴Fikؠ�F{cߗqր'⮿N_[9l<{d -@G\[W96xwo?/]Lֽgck%98ޚo 2\!!NmjLr {`wVG߮0l-Z4v0P}8+%}z70gtjK`)/ ׯe9ڐ1]:ZUzޘ/?Fg:kk2陮bsؠmIY!Yum-2ǖYsq`Lz9 cEgkSc'Asנ9<2N[7U=mI˘Pkw#,+g:k09fIsC]~Eqq˄\퇌ȅ=j;o|Dۭ괔a)]Qs#F-W0a]+Y:Ƒdd|{;?b͆ºNPc|GR"cs&mߐ6W{AMV*n!)U0|?~9ߩ/2���������������������������������������������p +0�C\ endstream endobj 49 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 50 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 51 0 obj <</Filter[/FlateDecode]/Length 439>>stream +HJ@EOXIہd1{ 9}Ǒ$I$I$I$I$I$I$IxX"}$3F2yHU2}$s_с$c$gm#M}d_2cِ+qNɷxe>~>,۱݃7e>N-|W>~+wɜؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[7$&nIlMؚ9&5qsLbk1c[7$6<=~b_"E}0�*û endstream endobj 52 0 obj <</Filter[/FlateDecode]/Length 677>>stream +HN0DK/%صS'드HHaVeс"";Bb7?;'f{Q cb汼;&f' gF1cP^8QS񉽌4ߜއFٚ bzgּaC0W٩e;#frفfΏѣTt@ N44�rj"BN ZDȩ!C95dh! -":M}4fV ҘKcbY1LƲ6c.-XFСAcCcY@-РE4hC hnPwF-ΨB5w* F5w*F5w.EYP粱>ؙa粱>ؙa'.ؙa'.ؙagؙ6y2]78+&FpWM. C*>3/ <2p|([k}\5>.ZqU$˞xek ˲.[Ns>>"C*>>30~>K:}򧳴*lvV?^ʈzLJ|\e\"0++Br7L +>*yfFVٻeQ +M Z%%?Cz+ưAX�-X endstream endobj 53 0 obj <</Filter[/FlateDecode]/Length 833>>stream +H0 @in8根%N(hʷlY=w}̊aW3ysT P_`H :_My F7R(@}eQ[k)S V>ਭE* z}s|irP|ʕFt"*_ߠZG̉oO݇|_ uu&QW9*_"u}L| KJ_$U}K| %R*GZak4u}e#gk3aSz)[49AԻJ fr 5MU(g_KBMMpo uE*i]Ω&F hkx^e5:4.׶eq5<lm1wEb` w,#UM2^r(/qMшM%6w{<cSAy9R4GE=!TX+?)lB^!'bAN\'z8\ ԻY8 ծӸY.Rpߏ~,"50K1 ^f%J%,ݶ.%+ &>ŽDs蹛 Rs7C&n.LJAϽGRl]R tBےjʻC�|[хI)wy>>>.C`|]!a R<ږT]~غG Rs7C&n.LJA ]0)=w3taR +zf¤ЅI)蹛A`�1m endstream endobj 54 0 obj <</Filter[/FlateDecode]/Length 587>>stream +HANAPAbC& Vd.+.,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй_3Sɱæƫ���[�[o~})5T/23E +/<]x(3SOpv'=XTOϤ +Xa?r?+:l@:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTgz�� endstream endobj 55 0 obj <</Filter[/FlateDecode]/Length 586>>stream +HJAQ#$+h!UgM6KbndЃE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE`QA?v,*h.҃ERxz;[#4Wg݅G>B _sD~n妊[",*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйBy`� endstream endobj 56 0 obj <</Filter[/FlateDecode]/Length 1555>>stream +H[WF>w|x$oALQox E=!\zڞuV҇%f2='jrrӤڍ'E|giM53t~Ҋ쒳Rg.}vmBR +6D~˭D5Bs}b+d>?Q|w >؋` #_Ơ~6#+Uٍl״OC+?PM#T:Wc0z}]o$v։f"w]M&yC3 CcOG,`sV fުF3KWzt84iw{Ӕ8uzٍGf1(Ƃb#@{g:5fOn傁u]9mT8ViYab˪:[W%v ʲ*P^8"{=׬FYRU~ڷgMJq;{SŅױ{DUH]VQMΌFr5Yw#J|R퇍,6$Xrhw;V⯜u녹_rO%f3NBmIϫ Qڋu)؞tԖ1h"]<IFܶy.[+>(m24;̫zP_z;WIlWKEЛo unt~RhwW}'$%lEPÂ7|yuζ*7`4Abn+ѫԛ2~M'˭{3qMd h=NV,nń_b Z|W>\qїWcݒζ hRu5ulYo*՞f<5L֤]&Ӛi*4q>Aҝ4b48{r(<CGslu@?pFh_[hţ9m΋u6xyFѼfWtP/ưZTOOh.^`Qզ^2ӿ^~}spm3K+LE|=ѻ<OKȺWɫbe*,EOFW bN>o:IXkt̢<nJIuw8\y՝xНKכށ;MWw*#39Y7JQ!%6Ro+ܘHJU=zFogU΋[f]弼hۣ9L=jMUv4ž +tH< +_pLt달s)ry ^,F] \83ff;1ၝ6[S-]]t3xr UUMbs*<nPL:9%R<-Y4cOSrR,w֟x>ԈǟxN^s 6!u?�������������������������������������������������������������������������������������������������������������������������+0�VU endstream endobj 57 0 obj <</Filter[/FlateDecode]/Length 596>>stream +HױAQO1M vBTlKSzy}zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +sE q*VlW҃E+_ɧ:O%NJTrsB;ʼn}>Pwq}WG(lW?!|Ttذ9.e  +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>ƛ>/�_ endstream endobj 58 0 obj <</Filter[/FlateDecode]/Length 830>>stream +HoKP<='I;ZPA7VCJ\av{Yjmr ʌp6wnrNFѣeY,bY6Y55&ffd, ,Śa^X3l2kLDFeTY+0d+Q>2$ĒNJ_MGL_GV"y%la>/OLw^"3T`9Ԩvrn4R+ (��'qe{߻ .壽o3E, %HO5KWi^pwEκ5/\*߲9 ޑSȍG찂˫x$<E|u#jS[ b{%\˩B|N|\*|(|d:6e>7Wi>>%_䃫"!GW2l\{"itK<OWY?ҧ̔*wx55YO^Ь &ȏO5KWJC'\nJk���������������������������������������������Z`tMzqm\kn^O{78>kI{< 7v?ֺK&ʭO'yg?_ vg{.`-p3$~?9>8:I>;y+ݻ2N_պK]Mt;=?lһfsl6܋fڨl6gNw~]=ӗ+~ p!77;ŵ횦q5vywiZ�������`�7 endstream endobj 59 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 60 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 61 0 obj <</Filter[/FlateDecode]/Length 557>>stream +HKTa[~D TTбMHJaeZ-R2W5 }IEoEmB"q λ8'�����������������������������d,k0=4I߻٘u]��@;v<X1;49kS-ۊ ��ɱ/=Q��7r>L-~͍"�� F{{ƿ>{3:EV>MO|Yuy��@ZX + qLmP wꢮ��c]cy/U폪4�� f#p8Q\w~2YdW/oޞ堦"H&DDDD$im-&_ EKW[y r_"""" 6֖̻\>uj ՔWs2Q&1૎k=}=9y- [>]{>ܝ[w o:|/6u _z5sְ>'�_4 endstream endobj 62 0 obj <</Filter[/FlateDecode]/Length 352>>stream +H;JaЈ�+W�w  >PRX;a�1?a`{8<lMOY_]vwy3w`d9q^q-߼>oO{K=='69Vs;|ɸ r'6U܎_qOm&g{$ �PF}�^#>�fD�jH��k$g�53�@mI�6{$ �PF}�^#>�fD�jH��k$g�53�@mI�6{$ Ǿ�c endstream endobj 63 0 obj <</Filter[/FlateDecode]/Length 202>>stream +H1BQ�gj|3h :<P61~ޯpu �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz" �e: endstream endobj 64 0 obj <</Filter[/FlateDecode]/Length 1268>>stream +HOWC e- 2A-+),SnC%eQ&NnĨAuœL _,udn1nzL2yܜP_'6߯xLo���~ zB=��75 ��נ'3��@x_P���~ zB=��75 ��נ'3��@x_P���~ zB=��75xs֬ 2qKKcE"T'Ny Cȓyiy,){,~,Kde"#fUΜD~w9N̘(f;REfC9s]IF03f*JK&YV'*5`��<xԳL[P=jU[/gرfwL{\[ڲJm}{|;0рW׺ٺc?F{{t|{jOwpwgPW{V9vtGj=|t@\SgQU7T]+�� +d<9qJH2ShHJ⹨(fIM- 61>_di1ۑ:ic>#3"R"7w朱hqSIJBN(u+)t{D'O-TΦeMAX[X$BX)^_Y"V<+5yWm4To*7ۼŸw:TS;ZF oQfùu >?hlz䲋-M=%nS +F1˷n}F߅]#4w=ӭ߷7|ޑk}]{<h}�/ {mS٫bݫoo6ٽX]m;]sqz0灜_l}A8q�@_PrSDɢ%|bƆ*k[Ŗj쵨7L7-r}%x�0Nנ'30e8hWe ܿ}lݱJG�0ѯAOg@,4+[Yaim.<Ilqq}<�S_dPUe #Bz+lnD�0$'h/� w_8PY=G� 5L}[_8/^ HA4<j#)y�]# 2/-]0�xR拮=0ul!h3 0�a endstream endobj 65 0 obj <</Filter[/FlateDecode]/Length 949>>stream +HkSg�񓤉Mks[ŗ +*V]kRQ^XhTL[ukڱB%mJHmKeaAPQcy><~?pB8~�Jٱi0S\3%:>43`W.w=ێi`tw!;�|k0l&|IEkrɎ��=JloO/3c���X} f5oǣv{?lrI2��=-.So:<޲5Wkڝ[|,**g쏜7yJM*l368в{vQ�@d?`6v~%vۿr핍3 VUUiwnv#DOclVVVj,89=K +G-#7,}j�Vgٴs>}M6Y+;�(G4" +v墑ۋ}n_z~)sPˮ-Z>*dR.zO:e�]_sc<Ȧ^;%L@5ʴwoϔT0p#~&z08d{jP�,ok݆]ϑVq���PRJ`y���0gRg-*1ǽlE|z<���qd90G(ʧe��|:dP?'_keyH���(Zv?c\]=$ #P�,c_w=MUTȿMpCv&�jzp9�*|=DOc@vpoOL�Դi),�`#t|F4TQ?&×c>ٙ�+i(d&^^-; +�^?b@%ç5deg.˥6{�̮^C{/�^7( endstream endobj 66 0 obj <</Filter[/FlateDecode]/Length 948>>stream +HOSwSj%Ayp:M|ԡYg \"ZpC&Tȣ R LM5wS#vNbB_+9I{>W'߷a`jbidS孋sw~Α@c;o;'|&�&/soe un&~dc,�\46_͞%=�&ślI>?~x1_7|ӥw[k<ZvHoϗ2uZGoho% -_adΐ�`Gw=oQGCC40w��8YnVM|T5-}OIK��H;vY6.?+,��H+ٶkǧM|n?R% ��~,+w{,'vM|'2l>o?W7Oz��ue~x|6?D ��8>1F@G>Եg +- ^\S#�$= +SM@G]+=8k›.=�DdzٷYE<:J.rw_aȚe<Xo/Jo� Vo†J%3bPGz�zq�@V?D5�8ς9swc +jM2:I͑}m�8Sdļ;rIOz0t@kh}�iU~m:\R*=�Rj,|S-k*Y]iz?/7Oz"� +uwU^=s&Wz�_ .Sw]%돂2}-8Kz��P0>6eW~]A@W#X}啓'gHo��Нa7-o,z0J%L2 0� endstream endobj 67 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 68 0 obj <</Filter[/FlateDecode]/Length 1009>>stream +H]lSet 6{ʌl*&.DĄD#s#c,qcFM\V@6v2bpR`бv;i7` \,!$ +5ϩDӚ'<~su\B��r!#Od7}j]c[@,g__w}T95|FF���C@ %ꏆ#]o ��(ČHCt?n_��/;yw5,Q6WvlbS��@WB<=vw]%޶2;c*;� dD6gtI <p � JUOqxvmC]t?09v�-_rT�Sg^3zG@[|_p +�Rxv<0WW=�B¼Ǫۊ.Y<fX� .gTot,Z-F@7#Ŕal[@mk-`)�x]l(p%)K +D{֩ +�=K +9#xԔz �#?љJ_dxn1:!oKwOV�֌R�R!C>7z|@&'z6s6cv� e=BB\0F8޽@&/woʖ ��{E?fkymЙC X7lܠz.��\x\.;]/?+!OB<Ng���:!_'6LFNtЉ R��@#z؝?)G{cOU��-큾2Ss>G_Yz6��]刷 B۽Jd +[]G.U=�LK[fͳTO�Kd{Faaxi 0�Rwq endstream endobj 69 0 obj <</Filter[/FlateDecode]/Length 1585>>stream +HkLSg [D騢P0eӡRQ'̹ *:)0+RQJO( 8q1Sg%e/Yg}0O1K@^#Vv ]?͈WS.XJ>;��3}$w,f,�Ы GCL( wm�]_K?؄ċ}|��3'닕s>�@o>ڼ\?Uq đȫ)yvG* +��${˖zO>b�@Pi{yr)s_^M FaH]Nk{\ŅCLJ#9<֠mtMGD+�:-[#Q��l!]ۃ_@5Vzw08|hQtWB!3*[ݰ/ H8y {vifԴN)�mT'J��(]dZjy� Fo1xI$]l\p1Ҽ(yJIQй?b)]4�ŎuG�"tm6;ֽ*<c ͩ㥅){G7e1\v6SS � @=3O\*,��sd<+#+X/zM}kP3�CnZZ;">�lhKr/5H,Usrg폽"QwVܮ���(`{^jń1YS]Re9GC ?[{Gin���‰p{bW)?>i06h+΍ w`=H.[Kb\���EI,S9S?Z? +n&);.W7UUxuthwGq]e'XFP8[ml"6-���r/ۧB.l꾓= ۛŪf=wwƤNGV d{AO&���xB7^lOC+|du7{NO4y+BӘ4W���pI@Af[{w?UgfY~fMU%,&GHxd=yjg�����M%d.Bޅ�WCzIږ(]k?b)MH�� }q��V,&ϖ}E'Niβ= +&>ԇ7Ož"�x¬o6rb�<*o`H5qۛ΅�w,FY]֠mKtPHž&�xyr-R>U�a';V(?ɳǸxXW"MAb�<S#Wq؞,� �AMyۛ鞵?(9&ʼcP  Ul[*!^^b�T07kSʔSk?IږRNkmǂbc#�" endstream endobj 70 0 obj <</Filter[/FlateDecode]/Length 1317>>stream +H}hut6XV&NP +g`cSsNnː`nd;u+WPjB Ct:;涼KYt$%t H{_Fk~~߻ݏ[-5ev9IP}�!/<Z+6{E†%oMs檾.4;gBΪ]sxR M\|AmT1 r~nx$j9=?k'}^?-Q}]�1h2ƙͪ`Ó+yvUWEHB3Ks[;vscQ}_�bEfzgAe,#G(CNQS.s;+5Hԉ ��1|{|Aj`^?ESܺ=Q��fgf܋Br-f%z!G��=Ҙ Pv+FSտ~ޗǬU6��/ǹBlCW0pW}q޷?=K��F덤)\q/غ:d; WT1xվ 2.W��@qHȝj`pꝊ?EG&7[{GnI��q*#C� gYYm1ݻ?䨾;سu]Y?P�W,aw2LاICVF׷?/�bLaN;IU@2 sҺdڥI$mX{ȼM-S&Nz罘&NY�Dx@ WwE?&lZ*:4w.xxɪvjmP}�Ǚ穹n7ɒ=D?oi_#eIزgs�.rm+SEH"v4F~Ϻ7y�@l~<m7 WO?Tݘ&l>uǷ?.1�!cM&r\--(4> r_8vK9029Ŷ]Ok9Ż?2;� ?PњU@tH^-ħ}[V/ +EH").Zӻ?ƛU? +�1Df=8M1�DkSj/Hm}u|cQZՏ��I>yvOuo$_ �Ds endstream endobj 71 0 obj <</Filter[/FlateDecode]/Length 3605>>stream +H T܀� \"H $! u"^g[R娫AkH::v6:gjvZe*߾? `*<O$`<ćG]M,_g7Kme<rS~/ `0흞(q?oyʫ?Ӹv!;ϭ8zļ?<~; ƃH�Hŀq]- �}�7up3і26@s_]Ϊǚ[.!3LC|GD@'P"H*D! `# ǸxámxLLg +ޏoA6GHm10 |/Im}ؿg ^lxc8}sM [\K+| ԗ q"&BP$❹wlL̾+vbHW,&ً~K A =] Go9!p +P@Y'C Ű�3>^aI(Dj2&xd?G04/TtĔf`xq3sR\5]�#OFҲ"Z^"H*(!T0uC(u<gm;SK N7jdk\5-/zk~~dsB[c5?|u11+Iߧhou!ZzTFURLHL"$2[WBD+㖇VwAsճ!():P$ hF^E ub~ +_LF$1+DCǀ`|R;v`0lP}'Wyp{AۦynM[Px}鯊FzӇ#(#θ;4Ì_I2AmWnr[۴ܶut3\'}] Ùޖma7'sN`<ڻ9szɌ߃~v -oܑi| qS"rbq3ŅH d,+(^*PUOrl+l^ 엱iןVިUнK׺ŗm{+!ړtW.htD϶ϵ&>jK(g%UwZ?_貺HB~z!c<j>:)Bj~Ʀ><M,2ܬNh*=7^/~K'J$.qOaq>LtGJatu{ +|ث3qehhg-!7'!'i]а3? ?8Nuq5ce뵊?ڸUUm"{Ut[`wuV mVwCd{Vj6??۲n~ CWmC6G>=޼[;gHX<TBBdVR8ܯFAE ,ۣQp~)s7` $ꏈ%8ӹi\#}8zᯊF1зkD2m=l;oYX6A#0[paWH r.F>X"vxh%B ";,ʶ(1Mr;qoػW 6c ^S @0) bUncLޒLP_[DptdU?L]-1=Wc, L,LD J '\ _M p|j _ߛc gY@Lg_͕n+{?2?GqZOYPGO*yOݖkUXb<޳h痁)\N 'D_g Ə^hLT/?s3ga` +cX㪍qȶF&7)0bUĠsݬ<XN-N%Q&IBQb D<@8Rkd/'`sÇ~a`;|gJÞs{2|Ê谱?jL%k#Tb}{ 0oެE!=fch*wn%2 '9M }hXZ)~=|d R\`:lK |%R=ΫށL&?x6W,&Yc=Ț_1Qq_.t21rhJqHJXNS&cSY_`DJ=H9Ufe+Yy_}ݽsw_E y4<&5Nd]a=b JVyba%}ɻ/y8 ϗ@# ?P,E#cF,AÿH!KY +H&Ř܍GN<Pl^qeeoandC!lB!eb2% [l"gМ%#0?Jab?Z " TPUtEOA#y \C;5ڕ<4z%{(wAtq.DX YXc V.أ|CF9@~ (ӹy샛's0]iO5sZ){'FPj89.ұ?4cxg<7*[ߚĦ+bt^�l!s,JiR叉#&*n4uJg#}N5Gtm}j@mm>uUы?6|>B쒽r\$chvDTww\szݝ^,*oKl22maĘ?n'd}Zb|}*{=D%<gImKIۓ3$pͫ}Adz3Bҝ?H!\lw؟ +YSqԾsZ&ca?ÿ{|,):8dtVP%3r5A?Pv%m˓#?xm!db2%?~}RbyNHϙo䢭ݿoCt쑭 1#?nı8;%PJ=A͕,]CXnޑ<4zG}Yёz;!E*cVw7E([_5DW|.cݔ=&",p#=#G4rNc[/d'/Rc̥!qwGZmޑ<4zG+q 9nV+�E endstream endobj 72 0 obj <</Filter[/FlateDecode]/Length 3092>>stream +H P\jD3c04VQzP!!xA"D@W7("ײ7\imƩj8餵3m޾/߾geoGȲ0"لJo6hB !$*B $$ܟCȘ4"�xyg\*0 z[I]&xd(GAx hpCpWzvȥnQp{`xZ@4} ~),`h Np�=h0m^(yYXţ�dJ=Z;MrH/q4Gza`N~)izS8w 5y: 癇}}ynhM$ 0̚Cw,=Q6yo}woBFK$5&7ēc?f?f?ڒ��P/iv\ C{T^-V{7BX?&liWxfl=O$ G"Lql,=2F=ƯlGX@?y 5H$!?D>6 C%q}? F)aצhʮ,.=z^s^aLX ?z^#~N'bhrIΚSA[n+m$sH';@X?<$_ +9� `:]G g0G6)/*?plq,qnucI&޻!!GOxHqV-2nԝ$XYvH<;iY@X?ʻQ1> #8]Q2;b,FK>{'BX?Yֶ+wC ;0d~\{9L\g3Jmީ+'Z#d1sqR$kGAƷݑ;9G1�Hy/-&-؃9j5$r߉886UN|N~+C 3ӣ"zN5D5jսדN>76jQ]cW?m}TLGP?8]_L2kڣ,ʙsxB[K}-wq! YEvur1Ϝwtk3Zu,V'x? @X?YD+@2Q[�ޅ8:iU\~{?01p菸9Q&\3~Zu 9#i񮖗tS@ذ?%�@ + F{' %U -pjGVyo>!wD !M"F91?gN}FOL$vl YLC 鏭R>J-2Ioh(4l?ply,Wφ:iOy&VbaEisYΜ@2IVn%c:ۃؽ= bH-Ia"�y/:]=XQi(︮}BX8H$~[RvA 5V6oB~#x{" W 2M+yDX7&껣 -a!?:V 0,k5Cph.ɵw5M၌FN{^\#In5)G1L,3 ?LHekSx;;K ߳@a< fۈ1Ʈe +H{AXL~oǿ-m{KC!M +}{O014nt7pWFqc\ΝqAZu{nf +̣%-jq)(}iq �{s,F]�0\H,_d{c-s`{#5&~:=~R@y2uiuZݹ1Etgkwʲy;i%YA*MCzwz$zA^*(YkO,jdtK q6VŒw52';P|{s^g pO4o4}+bM9_:#܊\i?^qn6,jVDl} q#ѷASVqwڹw5MEqA**GdhN(?QP{W0Sho:!><9a(3KO2#B A?" +i/x4A�2tgڦF}$Nya?oGڲ~ƮDNsѣyf3 +Y4яb6:LRM!a4(@]t, `Ȼ{rhك"AXTr~$J]g-pN2O{_0Shm!Ue۩_}tlmI֌&/uG07? "m9ۥC,Ѵc&C5@IΛIR0q_V93x7keNvJeqL)>-`6,9[7_ߐq֭@G(A,YȬ>qdlryǏ )p:rrd?I؎?#a6d<6RTn'`ڳك%˗Mp_m2P;m1 +-/۷vN66,~`z}"!(U;Vj!WvkKK8G1H=@8յK7-?4 :fϰfXn%P#j0?Avap$1A}B?ȑX1rVG0S͞7S@yԾZ`�mKIO endstream endobj 73 0 obj <</Filter[/FlateDecode]/Length 2374>>stream +H{PT&<4$Nb6: + 2@Ҥ"!yk@}JE_m3ک$(jtҙf6uo qY v=3ec׌| eحy@C+3>73V%[NMu61<htE>(=ex "W<\j!Š1V3#F-@\ йib&!64m?RqW$ɸd 4´`=f`=7L/VCےXF`]dhfȀcU"mFA +J/%?"%¡nE"*бH:�:p4"�j$Y3gz5Kz�mjxЋh<kYB֎}Κ +;ASSvK 맦.qwoXQAF?bFa# q^eNq­t1g?$ƃ?D?x1 +`Gj<<Mצ?xPCV0O5?L� +;AGwlΆU; s=)a}軑FI׾Ybu.Äw:atXkZ(G07\$JSzmnfm~"9fqS~W1i)?`B\-v(oӢ?&GbԾT"+D <D?|cy5H6T?u{PX] "5<g{lٿLn!hq9ϼJѷ#Ey1a?!@ѻS/3?, }n3:iUJ 3=o{3w뎘ѻAGʏHHQkXG:OkY;懂? =(gdM;NzZB?VWnyz3qu=֡&󧙖E)k-I>wqv"|X?ZG[YFbe#w +FoMWδ)ʛ9dGX;EJQ; S c tȲ`n!?4h;'S4Z/^j=Z- +qe?s0}28_>Nɮ4 uA |CTrn Dn5?Cȟ}ſV$(J1Ub8Z$z)Vf]<o #`?GWXg KFQ?aPs~/(aJ ٝ~]"'SdE? 2C 9A.FMVjuXG#}GRXvSwX(|ȉ?q%|l(#B +V)G)D9L|=$15= +N-^SIQJҪ?9>LCĞ{sϕ&O0 G"0[t GAʙ)m㫺9[>v$w>|(ĕoIމۻRj +fO$/}&֯p䞣GdJ#Шi +֗Dߒ%7-#1nHPR,zf)N $BEOc+Y BЀ?uJ ?FQӨ|qoDߒ%7-cY,zw(mylnHb? ɣCl'Ǚk/Ä?h4j/`vr=-$EIkXwΫ7'zo(mK]{ӵ;= =]>揁qoc&w2n,`M5Z19} ͟go}OR_~!|oxӡFӹS6*> ݐMĝCǿ &[z&E +DQӨuQDߔ%5cwۑ;ޖe)I`r“?n=]>ɇdp?$8�'lWFQӨy@^~_))Jjň叅 ]SD oߗ /~nHb?nwH>%ۃA{ 7FQӨA0j2)<,�w endstream endobj 74 0 obj <</Filter[/FlateDecode]/Length 2293>>stream +HmPTcҚ4IN$N2F&1QH̀ "("EQ̮ +ow$BvWeؘԦI[)_43>Nw}q/9!%B~?RK$dXf(XfGHN#d&>A"|- ud|tp'v2WA+v@r[_e^r a*sHf.a"B_i!Qk�H<^z&JO7IlS4#yY Ɋe3F7藢�'܇ӟgsm_:7*B +Xߕ&C=G婶s5mkX`Ue=pܺ*_H'䏕nfhhBSo П-b+OInA߷ovä/!lzO&c* tppeŌ@?@ǜq=ˑD0B4ɴ6ݕ$B2Xߖ6\J[ox>7f{?<?5^QvHS?Gơ?-U&ewDB4<#QV|Aַ% Rl=퍇X96Z@.}AS-,Q1CS7*qmY6~VGu6k Yߖ6\JtB}b6g,z7Q֡m/ & +Sӫ? +K%"\#֩Mۏ ezb%J  +R9z@ޣ5dt H>]̽"[@Kݿa,8< pԬGcK \& g`Q)R >\/UnķCǽш};�?rW?F?HOc`b]N9,7&yG,!W* rX1ry>ܺ* HOkT@"Wi'LqWuOR-_nWH ~h pEVz';Oó?׿70oqX_POEiw\=3 Ώ߹syx?HSGW`S?|UǴǷuro3 ZMGO_11[|ImGK'] gE&/m%C,B?cj'KN#Oû?0~[?31S<#zڦw֬{XgѱK)ϫ?hj?]H=V GwY6muf}gbx|B K9{DpyMUq{AFtp7?J9tEwz'uf? Yİ=hAȜ`ݍ; i;Z:M~`5gH }>Q @(]�-3YB4JGz!CګLoM h>jaou V݅ƺw,ug' J_'?0믽Xb +(CG_%a{1` BnIY7w~o4ʽSGLQ6,X9C4J:qKn~aJ9P>\>a2-?2oX6=`l?8$ep1)>zQ?]5t+>3{ǁ?b<cE]퇲&Ç-5s˜MAS P?HofS< gF)4VN1- $͉aw+c{륢>YHW֟|dG 2ѳ�YZP1;O$<6pUoN [ +?f2Uu=T߿?eG6CSYQ?h[-ZCw)N ,6`ͳ5 0Ő'BfР?8G �WM=o �{\ endstream endobj 75 0 obj <</Filter[/FlateDecode]/Length 2340>>stream +H{PT+Ӛ44mX#$P & , +MHdykwKihFƪH?:Ѵ38_]-REݽ竉w8O+_߂Ӈ}g}{hU|_cV=mb[EF$dC(!b{`B(({BsOQ}`l{Hl(BvM8�N3ˠ?&,Hl-(ZZr`D_8 Nu"!:=}t94oU�|qU=հH|Ŵ`YjVJ{ߥQ?4APh}02!?5^?h(X{yvzZ1CATs1(%w)B(iV|vQ<:!xߞ4^S"v<%dA#?޵TA3Fc݁x�V-~{ץ +Q? +fKoO S?|{^0>}m;R]?JDYdCcCRx?i^;E0]N +RQҨ4s !'ퟚ>*qpO8֚ !G[I菉r&6 ԇY+>K3{ϥ Q?RB`Nh}bNIx 6}g-[xh}1l7"%X8 qw "! x{?F)Z0-þQ\8Jן7ԛ{zzv4qC'H< G̲g 1" @BLley[8J5#2?e6ڣ|}bMnXAHm_ +o\}̸i5!ls?J,f { 9Dxn\MbYgoC(i/MT5r{m}bMnx#}'yﶜ:g5^i7u :~jǨAQČ)A~:C7{RQҨRvyh=!yߡ:S?^!%zkTk9Qsf{-E> ;h0H -xCT9wg#@`_{yQҨI!l5}~3}^dEV4{-Brm{(u?:a,(􇘾iZB`޷y58Jf.`3!DԗRVtcVB0Sw.�{hs?3;1"hk<D9*?K3{yQҠ?/u+tᤡ F޷(⏜?9V[{XS;d/~A3CXLʰoj}GIp_W~t%h(@BXMI9wY5$8 R"[P7c=gC}^gՖe?p4GtɳszQL])kxϲwY>| +kz .={?珹pw8zgNY<. A8AE^ۧQL])#7YWgire9ƞKrm5?z/\QSSheX?NY(/g&]]gfӼwg% c 2oRL=I7ڲL;,te9i:0A>Ag-Ё[ y%oY{y<�>lk1h2m9q$O>ȏCV.tI1$?6PW.,'$jRSs jGao7ʀLC ͑ Z5{yKO3T5=^¦S}|jocK3`3!D.ԑDe#5ޚ{\ }>9Ju>0 tMrq^Z_�y�  7_9,{~l1xojtg4t.ԑc Ve/Ms3Br:(̈!Atz;y f#Lg7̒[BxҴZ *+ϯh2] '$mW�zݟ9 endstream endobj 76 0 obj <</Filter[/FlateDecode]/Length 2480>>stream +H PU&i֚Fu<g2djBb<"NWXD-xq_^k, ^A9eZ5*Xm;34M3{K`yHv9f܅7񴘐 Y"BVV𶐐_*o O|,G)L⧹/bh, pW?P$m;h>KB%~CS-i L~XK su�A]̄L8H +x&Ҟx2@OO× ]U; zoҺXoܘTQxyxU1NLk}Zn-ؙtwSL>k<MgMM c>!}#b�p?nmmj #$=B?]/͞k ǫ R/bOmX@?=?fŮ24;c c?g_0 ;Aߪ+,;þEZBc<窿yql*ƶw;;菾ۘU1uNSLȏWW[;Jrͺ vhHb=F?Bģ?Ѽ;C򒧉Y5q4{3A7G]O=1$ԙZN=o?n|/Z%^=m}?Ŵȶ*ZW[qo^P5M]{<1HSn&C?SO+[6 +W5q<6f,lX8Q#G>^A~?NդU;xADȢW,'mwTL:bZ0Yʔ./q +5GhM + -M]ExC?S>gU׷d잆Q}.)RN. \u9ޢMm͈ZVy(i7YHH,{vL߽R{s+z VrGM.Go?\Avݏn|8j# ?1㩟pʂS~}OŴ}^_:,f3 :px0Bx0q q돉S|3*S5Q|~.$}땥p}>ӶxygbLVՙ')awTƒ,D?^D8as?~\!?1qO j Ʃї4eW_}y΃ՆivTL_B^aύ7r&Q{H~ HAj_? +1$m%UV+zGGKiVԽ]滛2=7\&|?elڮ@s̛ Aas?¹P?Wc'j A ܸ;PmJY]^2#CkRNnʜlдc{q?w?aAWϮU7 [ |7GKkgiC[�!EW1m%?n$sE%rBZzn.㎒̅R͡?p4&G@blu*d}3#ݨEeGO`m?vS[U4?1c|i?bhjAd>B/ }gŴlX3 +Ck2=?v:h7<x=pv�ة?lQʉKIP;8Zs cgk﬘vr?>,v揄kUeVJM⯃{Dh{u-W+&҉?"hB?ǟߝ=<~jA ¬S~}oŴH] s插j8S:ѻjk^G=И+ʽ:g1ʙ?OtggTEBhi/5q^_)KFn=}:kxѻsdE{+AdIcQ&\pc F9~7{EBhi3tY~'ފi#ym]B<xAG ͞qblgގ~A#*Xm_%S;NTUѻ(C- !LdgڝE]1IWjwPK7+uȊnQB+ǿ$c--�#(;z%1Foz̕.b'?U[1+EbYez'`] +􋱝y;GIJC(,?+�v endstream endobj 77 0 obj <</Filter[/FlateDecode]/Length 2198>>stream +HLX蚶%bո5N7R'XaT"ɠpJ"J;;qJjk*BK'[m㒦3w-V}>�>}cc`s#֎@` +z2obd)C?L?׬w6Ujl5lY,!)J[HHr- $$(m>!q_Y?T\sipA˂S*[n;ʇЁY(g]PW\!dȭ["HE f*f[p@*$#>g~Xn,j*:Mi~7+j+�RݕMYO?pDGp=ywmy;^u1Ig} +'M6c?ZSenA'LqKu=zx +#Ҡ?/׺oYڷ }gh {'b=,GHЁK�$C4'YzrYo?pDG2; <m nb51c7yRAG)@pXfGlǷ/cwivxBֳb|ƃ?<}Nz;A;'b*r @\?!i@bs<i+u,=>6b|ƃ?V|7եwNۖ[!c?r0??'؝kDz9C4`6ܶ񄤲bŃ?r/5[ZO59g$sѯ?p}AjcT֢CY?pDG%Ep޵q`]]6\hL 'G\{mXÌP?GPto5^C4ЋLꦺN9ϳb6#dP{%2ֻ&r~F9ȷˊA6w1\o bBG_zmi%]5HO=Z!y_I_|Ly,DOAޟI$3?5CTY#c^{pd{s~q.4]gNb|6'$~??n?&[;XEǀ<YAfAˇZ#-1CEҲfNIߓ8" #|m5-%$'#]b_Z@:g z0Ck]?tt`D_VZGb/F =H_,TZ'5c!<jZXZW}`s(p!%C4|;F0Gwȳ[Kzx#Ҡ?[sb|4 +x>X,#$>Ka[Zh|AӁo}c(B;C+ԙg{;nGA'sWG]밳b|4 +H]?2ϸ]滥97ڤȴa9nO'ߐ$plB PL=#9wK8" #1>h84w[L?v:;]<;yURhûC p;^.qwJ8" #/JiKUﶘS?~KmeCT;y :? b +?8eЂ?|A>dSi#_-b<!﷘S? ɢφX=>ig^ #1h(tEA5r8{ +`2'B4菑),c<=ה/SwjscNkWbsf  +z"B?q{-YH?pDU6-ꏲS%Y+uJf,S=Qc8?d>ɼ݆s=}%B4菑keylox}`� d + endstream endobj 78 0 obj <</Filter[/FlateDecode]/Length 430>>stream +H׿KqowwQgKtRQ[u5t!lHBjQ~TY{[ВCwtScgx'������������������������������������[j/o4~k|N_6��ttt4P@ vM<*$=��{sQ^$= ��nn|[l6tt$<��VթJs'Çwե.Ujld��HչV}-nzIڹ271~1��X>wg==6 ��Yx8S*o9?[ +]}3_zB-IV|Ok vƛq+H n]/$ �6 endstream endobj 79 0 obj <</Filter[/FlateDecode]/Length 2230>>stream +H{PVuHburpwjjv,@BJ;ڔRYIe Z^ / @4mvm?ǻDA99<w`{s~aD5.al^elXԼ[Ř<3,b:rh~sS܁R-is&;Z`vBXA8OLNXZ +#,R!PiXFlRI$>< {1 S &K�`lMs^ 3W(@l陞+=;L �V}o:iu9vǟ�>>3wKkM ~mZlg\J υE#=8ipn\1`sy4 +m3S dCǏGB*Ki-!orc~ͯocs)uF\4 ^Cz_:Bu/֯>p(?k<!g篰wH?h4y7d!X̧ӏU>RLMo-?U?z.Vb/ vAO`#˥ BP?9v-FҐ?/ٍ +v`u)6𿯵{#fc(|nu+? S<AwgLqǠCV?&?n�K_P^owG?h4Ueִau)63?R=2AlHdܟ/q{X// r`oyVL.FFҐ?)0}]yRWjGx)K`}oRV^bK2RAj8"/a#hi`.$m>RJmHo-?]Q3;;~*?dGJ?xw-B`|s;4ZrEx}b3_^XROj+jL=[=rmŻ_T揁A-ފC=Ҫh)-*h=\>`K'5Ï<0d9c pgy|�dG%?nt' M?viM|b#߰E?h4enpf]s/}^l,z + -swɢ3n0ٍSZwܬt0@_?!CM&9?jZK0e=DҐ?(讣Ͻ:R?ڪ*2a 5GeFAJaAO`RK_,H_ i#qLx̘iFr7Q~{4ZŕVz|ی}S+$ÿmj,__M1$$E{%qZq8n+舳~ {GFKCPgvFr%R Kᧀ?Vr[egwsɂQQ4.pGqеi?|T!hwxO\}%S-/䂁@/Eʃa^A 6#K}MO~笔?$-+zް?!䏛-8[{,ٖzA!b܆I\4b)]cD{R?i˫, jxc#HqGs;9ܹY4j͆T& M'ǝwCO?h42*3զ.c/T|Ô{/m n<?Ew$gLxR<=�pvmFd[- / '~7�ҷ?| b_a57�|2)? 2Aųq5u'턽zA!U}0弁~ρz }'F?g}뤴?'HIn<&?�g rwB?h4ܖfO|}돤[ +@ݺbpzÏ1KHh㏢Geݥ` w=FҐ?psV>l(=}돒j;aub,5i=:~5FDHnqJ?�>ٖ endstream endobj 80 0 obj <</Filter[/FlateDecode]/Length 2305>>stream +H Pǟ $Q4F;2IkҌIDiZ&1&(G�#xe D.YYXeE]^a!,&j+I55&|޵4~߷7:}ߓ�'tO<,�ڙ&SYFϸ�xw=&JHg~90rU } ^ۼ@Y/3LbK %+&l! abIVm}ػmS&M`TаTr&d8 I,qCRሯ}D߇p"390eD(39"Xqj*w~׽+׻9vpy7ઠ`xρ]|.D~0}+28~|Ȝ|)CGl8<TB3G?u쬪n!ઠ`~b2?|##;55uhdx &̂ vmb&矽ٞ("{-> FLA^sA^d3#U;u�2<;M8{nW3_ +i g5Zw;*<W#xEB5saY,V^:N:/e*WyNB5l{k] Cq6ݱ#${~3 Mϸ�_mn:)e{1"~X2rFWF?v;? |)Ϯ7d?\Lj~W<z$#ݿIiGa$o2iňm6s(#ܩ1> +gdA(. c +B|c?4v &$LIwjxo@qAf2L 3̪DڽGaٿЮnPc(@wGVm!#~h1Ty{cka8L^VލޯƋKޙNwVχi>汎 xƱ;\ȶnkԪCx-e1"N[Bw[ٍ!A@pbۥ*U}Du?0"nncSl ?C.A7ǐD"1"x?һN[LEo=5c2?6o^j^]G~{9r/rxp8Cx@qTl8%e;2"hc}#VΦ"hw9([DOR>\3V=DO`>&$L…=<`l8MtТ,J$s?kjro$i7Wfi^ͪ*iȈc)ēn$92rn~OD= evp\Hyб,ݽv]ݺ= ç #r ?KZz@(e#r3q^-k62L =Ⱥ˧+lfQ92r&s3v2)r]JnRAc$r*C͐= çLyhmՔʂ�?4yE7?{GE{OFهGVv;Ge֛'\a & +ӱ?%8?+DžK}'Fn#44Z<jg?Oa]UUeabiʈ}pPifFUX7?RE+JٯufCNj&0"+j+KiwPG[u<rg?dF_}r?&wFsA'D9x[/&&\ryyћ:M #y}UyUabiˈcㅣVܘ?P5rcf2;2qtP?0u#􏧹a@_KAEMvA)`Qv;Ӛ/ϖޗar"\FݳR˻ٰdDC,sMeaVhw!uabï0mЛPk}Fg??ûZ`-S3241IW�*O; endstream endobj 81 0 obj <</Filter[/FlateDecode]/Length 2159>>stream +H{Puj6SͪFVb֌\RIVrv^pW@BDF (^0E&gqvw\vb<<}y38y<_1eaܧd]6! p\kV(9MBy‚9.ǿMrv? 3ogQvvG!]i!LH " "yV?D6Z0_L{:} +``~(S ~<x@pj43%s%-@: 3Dmf5k Pcgkg"URۀ}7󏤓fU<ĽXo4tGqm")0ca pqoc�ȐPq%֣ľ Gg4bp<eXǚ<[FFUBfΰw{L EJ!{j +rFۙŞӰ;L8\8#ڝia;sQqf+�v[bwEJ!M c3{jۙD~/ +;L8'C'r|1'C_lF ?rfk Ä0?(R +8ɩ2i΄p\4L?ҏ7Rkl%ll\| xwl3'^ +"i08U_ֱR]B8)Ce3/ǟ~&Dڟ/Z]$:X|,G` #AqyΎp!H)%X&o,8l`aؽ%OXalP+?vQG,p?1)S eؽ%"_&Vl_Q[[<^0}pQ{E{17o1-)ClqYYw1`фG!:e v_ Qfj6]L1tzʌ֩c?j +CJ8EJ!7_ c:h3}Rw}%\G*?Ȧ2%0Q{Eohl@I})MZ}`”1o4i+8)C)級8n;-MxHbLvW 欆fac-*F;Sn7/ػ-=`ds@Y7W2vWAAR?X ijtgG*:| 3] C(.ƮtNWic/lۭmjO}UbtPi<167}OEm}%\nsunscOx0]= "Hq@UسcԄg#[LK13;JlzÅtP8wC7V[JVvGCAR?êlQ?\) q3ub$\Ϝy=G 1BfJ&8+L'qoP+5ݩ&cgWSŪu{uNC1:(?ܣ/lOOS׳ŸxЭ +p?/\RZ_]E�CAR?,WVc(u8^#\x!???|9A޵ZKycr]O9WӞ1ؽ$B!=kek5gB8N}[x#{KM$>"J?֊?JyJcճn*>ZݩWf-KJK#@{g_mEg2mB!=fo_ -&`zۚu7.g[wp/NG`yOt ++L\8ΕQ/?n.xf]b�s H)$XqE;þ <pNv 2ZWbGX;/��e endstream endobj 82 0 obj <</Filter[/FlateDecode]/Length 2310>>stream +HyPL4ю#IQ! AbHJ!m9EeA!.ﾻ,zVL?zižݟ&S",a,3{ |H'z@pȖMj/Xio,xƎS?*u|q)`0S=ǤϤ״b<Ŀm|`QDw+7 <1@f$3Eiw1=Ibcem={A +{nD !`2!^OPȂ�=} "ճ`jȇE%`k3r\؎? +Wyƨ [_|]\']DFHA.em*Moc#y>k８i1=ddExRi{L{m&94r2·-w  8+1"#y@:i;6bZ:Ǵ"]1=F&W~oa>(-?ܹ_MnW5sgM?LCĸ`a.rd7{6b:95B^u3Y):b!@Z/'a @')w[ᵙ+i1>!CGJ\q=1߳J>#q?ov˩P/PX) +`C\/n.?m>+qyRh_{ú!|RowGL{F&?|%v=dr ?|a�b=.i''T"Ӗ29`c 5-#^Oo# OԻЃ_T^6hdEbQ@(W�I.rUݟ+vo ׬nYa 6N{FHA 6%s:62Q^s"ڝC#VW_L/?[|~G0ؚ?~`h߲i~'X8;DKбA9[o䪒>yv{ FHAĚlN\awndrC};YPHe2}C賣*Gʛ`xqcA?ԯ\T҉YNhW0;6ses;],0>oa]na5+KF-0 u}!R?,>#ޯ;hOy&{�!qL{prD+^ҡI:<jvN\hg僤_ϛiAFϜh<HI&ߔg!A<gA)EBcN%'޻G.Vtۄ:QBuSW}>9]imc,3[VN_"]aYfpzܝʼnss;4zicWGIs.H%-LWT[(UkꚌLUU‡EaY̎\j5u ލ?oD=CQSyhw#c,LiՍɽNg?0g?>8n+ZIn5碥7R~ʲ`":J"$.|BA)G@Y2{>1x|ă$:b>'%(1&gma`& ʵ U޿-cG̍nΎ\Oc0' ڛ=A(W�j-T73>14`%#Ě̝쬴oKXQS鴻b$¾of~pS`kBLFHA\Dxi1Ë#9V4vc[i|ҏb??�|J{ӚbZ?0B +8 X_>I{dg9+zI941: Jvu+Ĵ`&bn?۔bU>}B1[~^tI1uӡU܊d'`. ʻ<y>.nL?x>%/ʼnsIOJ@1~!?[mIrobz?0B +)?Ξt +iD#v,cF%|!hRs>cǵȥVɋ%!E_�1. endstream endobj 83 0 obj <</Filter[/FlateDecode]/Length 2537>>stream +H}P_(q|iL2LڤDP +(*o(�TDwnwo;@<^|kJR +hLLj;}!dp;}w!K$Og>\Ç/o_b=h̺6e8'+>ْ} dt +TѤ0PQEDk>MZU(9!p(ҩ.^2g@o^t]{pqqI_[�9ێp̓kfHc0#-/ޕt�-?~*K2ؑ|7cAb0�)@ L^YO?1g`#rX}+>{&,�_u<BD?�Y? r +HoTSEu(?75GYצ$`?}9ǔ }s=ՊϤ"� Q%}򑂭*b +�öxW*b1Hh|QG7�y? r +ЛHU5kLj!=l[z[A72<j?-V{Xar s'<9xoeDij?iI#[̴UH?l{?lgGt߇W%@@/\k2Pu<Iz>;z?s)ABop4]Җ48]DN�b~ztYO=L]{|.wl񏘮[z8G,'pٷ5LW7p3GݟxW��S?حN^?e-QRG +^}53#k @gnUۤ;H c;ʫj%=kß5%'΅tG�ekɸGE"+ܣ/`"e,l7/�"x/](ndFo,X|l;j'5\!=k#ux?�e:Wܙ%@?& ? \1}t?�jB6.{0xǘAd%()B>uo 0Y< HrZ(SԇI:5Qkd_v;Y4S:h\q3{H3ujbZI׵ܰ?y^͹qo`lɉs}*F*Dk DwH?*g# &Չˈ&)&3.vVXƏA:@ pܓoT5q\ѝN;?G ,qc lo' g+ƒ ]? RDk*-VXtg^֠<8U?�gάmX3?.zu,.�!MVfܬ? Ѱ]� DidvM,ݕ9%k%*Hro `Z]v ?y^ՀXg]�ܸ7pJj�"k0VQ-S+.�2q3F=1O^>MؽgB'y>5lɉs}mG ].k)“x�Ԩc:W~1#*E; �2 4ma(|}5\:62kHzހXgMuz5Q_Tdyu & +63Gw3}k}~kYTg^m#3^~_bd_UY5uC>~" >HIb CD}:g{SL2Pj2P<.Gy-ݑWEx*?ԁ jfK[2 ҿ?`@:NSM0~ܸ5eFcF~\~2=<ܫ?T5ںӆ5_ʾR+=Ŧv-nȎϙk,:9((~r\WIaw(.g.sCgU[RR$P^ڜ{<; :8/~Zaq['GU-xbaY_ Q~KdP貞J]{.Fi'@@~:~" 0ǿ+{9>gg2<@S?fM[FK>ǎ7Z_ñÕ>A%p ;v']S_ձ탟( }<5Q_b9{GUk;G ` z3w{GiZ{5)ƒȳ7NA{\Y�s{ endstream endobj 84 0 obj <</Filter[/FlateDecode]/Length 3586>>stream +HiTSW/` x@Z9cL{: + +(VDV+E@eآ $!,/ A&:KmXEġy9!,JI߁w޽7h#wt7ѹ&:O*OT?" f,D·s;KS%B}hJrTA嚋vp<ùLC*_2M?G:A?[!ERm,+ՈsuZB L_3T0m3(7sb%a+" M3q¤vRJ\ga`,{FM|WWkՈ_gY9k߃nqވ*dmĽM /0c#EE|JQ#gw)l|0}n#G!8Θ8hBR1gҬcXb*1ںNN"(;|T + tQjgiY?>.tD#ʀ\pHA<+pvR�8*3C{Ϸ$ƅ9J'7ՉVJXɬ-,X}*r2dM݈Nl�uOA9H{Y5q'_4e+RG\mm7)TD3:5?\Jךv7zm#7Kd_?4YcD:c[`1Uu4Zܡ]:R<l4#7[lc �JW@oK!oDfCOoRvìK>T$O7tJa.1ۃ?2eefMj~^nqڃ(tĕ.r ´|F o\[?4Y? avo9{IGֿ3a-R)o+=R8ʗ?pSL)v.OryCm9ԠK$bx >G2'Bv"ܫ[O宜ȑ|fAij+xm#t~Zɼ.W'Ym_EA\p q&[[q<)+/vF |ikd{1S?^!5|Ta \UY/}lHni +]c%J\b{%#Sv<R *ΨDzYmvI>kcl(P+sy[ĒRaXۭUScK&E ?^+/}&?pSLwp#MQP3-qaKB5UJfhaBcUA70aXqў_&VsǺ^Ku�gg/VקDﲶYa"|+gދJAtZ=/g#vOW;I_c9R)6\7*c`aOa58]HQ4Bl h%6+#|}RӾ: +cYF7b("/bP!9Xj~F$i#7qՁ5>ͭ񯩯M60&u*oQ>sz[b$6.W-LbqIar|O m?^?A[Wi|'c8)DEK 'OQspyh0FrVexqMfcɜe,[ΪG4 >mF#wPM**N֭KU:yq|τ`>_6Q㇝H2-`Ho|&ys8MLI{8-'14zouc;%F򏰟*֪T{;`@/?Zܣ?;bl8)%1.8ϪQ'x%P4Op֦ܷsuRmZ- +:*\+*~t[K\kXŤ0,s۰?An_/\:˳ N4y͜V#J>WUǁ=1/_eB[Sϲ6 +zJz[a$(Wq>07Rue VkoYܛ}>?pSX?�xts "Heg;I?TDߡuI +@\e65qD>Ez\0 ܒ>_zԨoX]"0 %IV_^aژ*L?Y6kJb;G(Ee2ZX8.{ kBb?tn\`8)`)ng f;֫_~b8w:R7VG'BQe|Ewdle}?1?0ΚYp):LJQ_gwG+.Y~T ѩ G ?wxΘ>b8)`&BUݾ6c;ǟ0Z-q}F/{q\Uo :1{X? ?-$(z-%BKAEQdVTYji勄b\7}(/4Mt5henn۪]ВE4W ="mk3$xca?~?OԩcF곤;BS?�N=ؗQHJ?0Vn"8t�pxYk[;Q+h^Дרo~&BS?�9 OXa}]|Em/ "3� 9lq8krraŸ;1]ynS};?ރtw�}@h + 7)uWH3v[w}%H3fOo$�8jvYx~-KpG +?#fK MQDۻBmg^>|g3 +9%Jc>&7cƪTԷ2QgyV厑{K}]m"3.4F7<d9ǬsHO?3F ֺ2#@'TP5^eLB|6>|gkapfPCf"cܽ%y"ۤ=D`!rvUc>ҝ\HR/ c?\@3W~/sBSɡ 2 yC>$[wIu4s4kG^]oMw˛jn<bt̉oa\4XHtG\q |7?r{-�%GlMltzAI{J!<iS߾:Ow?yc5i AƩFn.#�̇H'*PL(Рs|srG"cLE ~���oȘ endstream endobj 85 0 obj <</Filter[/FlateDecode]/Length 3922>>stream +H{Tǯcǘx䁭iԈ֠PESAJyDބ,y˺wgٝhhU hG9w;?t8.=v9s3O4'ٔGa+u4t2iƆ{I㐚1t@?5ѸfN-Q2zʔE*FU 3BEӗmq oޑYgTs8 FYxFkXQުOQ7igF^N00[)|3Phej5P놜k_yZFg{cy8Wu+_5YJ,roYs~[&/b�9pp&ا~v{ =#qΦp.&>;#Iҋ<_G@' "p*Br'jN! KИ" 4Hֵ5ZuyQE?I_!yIMj?1<\nq*r]Gv=`Ir6 ]Bh_C•y\c  9Cl}V -gxͅ~>p|%([`V/jm8p-YR8��>m*Z|6 cfUƁ7Xy;T{8 +9֦F~Lh/Am\Kڂ/J7߰y6 c>.k9* rCp6eb6ՄgGi +SciXr؝oZ.r6-`6x$I)+b0:;gqNjG;(<63XsCjөM5pDY1U^zQ_I+nXW:tS[ l0bh# FW;rƽ\OؓW1zFGs}?ml]1joاnRcbW'I�kqqBYbcĶFb&½WQV`?x+ɫ:%6L2uۊD=IƓ;Mל?x+>]3<CjөM5X;ꍏ.ȏē ۅs46#,Su(i৹k'Je^$q7,?x,A׹>͵�ŗ o 㰞izl+?46CpM.7r{ID].Q`'E+[n;bdnbaxWN*8()U|>I#?6Txm'?QAL^!#l'C0恿E}87~M8h.j,0(z\㏄%ڇic?c+ETl+5G(˅q؃GsaJIPtd6 fPڐ:w܄h,eVtWi#ƹ3,y,@N#9uL7,v68z :g·_)|> I%?6TO~7+qˆY#kpҘxa`X|JyA6+9?A6$-Kbk>)O|?A^b끜68 {R�l} k?0xa(ǩ`?8;֦F~life2H'Igs㋢L;eÀL0Y#mf}&LwN|//hWJQǙW\Х榾FZgg $ԦSjV|AnVc8E_C>dUAgI <B�UP:xe`!8FXkuڞ{^\W . 6hׂh/bʹ_x쵌#6L+,vZ$IOߤfȵY;sKV)Z+$RNm*GWgkEKc=}\7<3?qn?n?Q<`Gᙻg̬ʄqǗmpՉU~V .,"OÊ�v1[f<N�{P;~lI7=Ipe7N|"^_Ռobk$=>b3C?4r( ^ɖRNm*g)IX<,N?)\/i#MW>j){$ʶ~ڪos s46#[Z V힤+n Zyu(̢.=zx#|z!$&=/02bhy=Ts ><}K;H"k /J}$IϪw3{q;f?9bsI-?6T䏹QޱI X}Gc3tQ {yW|򴌡'BWFwVpl"yaE +_1maYXpDbf1mFLc36@Ƞn2noO{-1(3^,8:p +4j[gJ)=<Гyϓly'b:`m69_L|5k:i<}as27jg p"p#B8[1j:j*47R9U." 1{',%Jf:~6s Hf XPEO<ĻkA()@d(ޓ$\_@PF{_NGpWG=jH  <w}vdl'Jע}n͡&=#QR?SÈǞ~/`)~MUaiF<ƪgQlSu|$LCogp[c+j.w*>*Ibc`s$\9w`w}/\cMb(LG{M_JDNK;%dy+ȲY ɍ__qVھZ Dt|V sw2FIY6kw=+}zM&jca!r#<g-eA\M,:/O!rQhZt?{E٠`IaHN푌V% +%M*{j`_g>2';IGG3#3(Gsw FIA@ܝg:$:V+3' ;n8f ߔ UɡܻD^>%7W()(_kCi9Io_w4{2%^.NY% +VwF1+2tcuf"bIA y#C nQ9ûC%^*J^im_7;vè(H!R, + +dYD/| xAQ$L%gG8c.ӈMy{gԬ;KΛ}2\ aD֚m%4R'Tط [9fpe<x^4Lyw |<ɻG&XH3&< %D|Tdo]ZTU847p'5MTwG?�bi endstream endobj 86 0 obj <</Filter[/FlateDecode]/Length 1333>>stream +HmLeoԴg֬LͲ&b4A^3'R9yy  (B&Q A!V[~'n>~ccs_j ZC?z)}=K^N$)&a_y`*FK<EnHb*?~|ڑp&7%sʥc:tYg vr*\ڄ$x~VFu֗,=^ Te4߭+xer}|k_:' m^ '?L#ڏ: *7VEPh/Ҍ6hi>m:ͦR=ʗ}@8?�O@|<5'Yk,{jIz-Pi\K9NI%"b={!V wDE�<y8jmsؗU+#G{{Dԭf. Y T4Y³u QD^ I^U~r~`}>'? ozsX] ݕ#e9ݡ;qvЩ-՗=}xsCtiNtcEKE"$lq'^l"sC8�@<G"SOr9hCEsxo菤+EA[ K"2?/3E@s-aZQF>&)d˄Ǘă\yiߜ،=u.-{y!,?�O@<%Bz}~.gu@n,9|dо?N5_rXw v$ԈEn`~Fg47>x\FsuzgUƋ dØ#l$tA4dЮyg}F'[p2f /JY08eR/XZC[ ]h砽$hC\oknҿBC)1!/<#Y4oFӍHΦgI:yqEtn1C,d3To;KYE,N'FGUexA8r#$SܦM6hY?3KsF 9fNtOC�0?*ƦrQpY+7߰~.g%+炐tOC�0?0����� 3����x ����l<����(k'0����� 3����x ����l<����(k@辌EcSu{ n ����@`_Jc$v;tE ۹k^?<hb>Yza���� 5DOz֔],�( endstream endobj 87 0 obj <</Filter[/FlateDecode]/Length 1862>>stream +HSg𗄀A-G<ѪV@QQbbh52*k,UHB/T c֩wt qbvgL+a<wny15.qA6,K#CҀKCwry  Cy2<g0WBҀKCwry kɹ}ٮ=z$).Zɢ eo;m/woQx,x2,~XTMW|C}~#k}s3CҀK4 +KՑ:wSܴ,3e)3:z gL4 gCҀɂ3hBFEsU 48QQ{܄D~?SB{%ri2F!g2Fu?g:ym�ÐlˊTߐ~Mk '_$n>%fN{?P( +B(n;m/N|.?-/ۯQѝد߃MHdSQ( +BPVtN�ESb7? {g^W<Ӻ�����@|rRxo6lT\ՕXJ����̚uSjC.M�����������������`.~eKfQ(رVMe-;N-+2:6.Zɬ*U'];^<_?_/i`kFg޴65Tq-2njf 'ӛ͍..g-v#g(mk@Aۜ) sGiOl|{`=!->QT{I\A* n;mJ\#}}M�>CϹfKcVo#bta26\REVid +LсUeo?ꆌ{/zʭYtՙss}tos}2ʓcq;>UZ+nam K͙Z/t8߸tֱ"^A*&NM[Bc +0SϵdlpD |5&rϹs[4 7xf}: ϖcFb%1d,>W u vwd,.evmMBaAfGx;F)u}V:wj^A* pg}CB/V"hw|Afu릆K;|BIWj*ߑNgs瓇X<O}<iX&?MP8G.V$߯cAYz2i5$_4cYC o&;^b7?*{VMe}F#X-/ʏ~Cr^W}`}s$Yg,w^WåB7VcGFMh7d Rdښx2d.xnr9ej%rM6LfF9|h_6TcW[voawazI +e>7!c. w=y +k8Y*(mVb7>I, 2)a66[ +ǕÆ=9!X oǼĩxfR9 + +30,4g'.ZZr!cqfftTEoX΢6,aAS3O;^z-z#<j*wd Rdښx2ɒc]3ܴs +Jze7hlil982'Ju|}R +0�P( endstream endobj 88 0 obj <</Filter[/FlateDecode]/Length 1096>>stream +HOuDI4T ḿq%ec(R` "$ߏ〻CEDkRkG!c{o~uVUҒ]Co2nn(M%+<o;'[,)nc%q6]S/>x?Q@vm!fOĻASi+/;8깳xYb+WdXFGTQF6k5t4 36*[ˇe$Dxj@g[cWL+ʅ[n;߾e쉍:e0Chɏ _rt]r5}8bJKqQN/?cy(Ϝ/m-g?4cȠ�EO{?ﯪvx^Y6/1V[1[^jkB0u+={/?yD]D5Uoj缾g\C.spOLS:륦'FիI}Ơ~{IJԓ[=kkN ;-Q`6֭Y~ouW}>XIlT‚y_ɽCbbN s4P"!ʊ4Xe2yl2?z~c:}xby[W/Wl-*mˣL2+1/]ғ噥{> m:j< +:mޱmvMg_*sYj:bYVmjwOjdX:jĠ1tܖVzy=*}t#lu#(ڹ w]9˒:fِd^KgCmv.91~yDx15\lm*G=?TZ3h!C<SnjZoU;}}/nYK���������������������������������������������������������������������/`�LU endstream endobj 89 0 obj <</Filter[/FlateDecode]/Length 466>>stream +HOKTa q.Dp4!Mi02ٻHlJR ܈Xb̢EFF9y0̅.~p{~qbI1ogjV/Ϟ=|ri~㹉ǵ>>|dOsw{`dlldlϹӪ} {>:u<:\/};pd\9'2}vV[<^7xY0??3\߳d\9'2,:<}<oo;=Oes~2.r'29?Rs9^է; +3Aɸ l_#}�;F& �}L� 63�@l52g�kd��D�b>�f_#}�;F& �}L� 63�@l52g�kd��׸ �" y endstream endobj 90 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 91 0 obj <</Filter[/FlateDecode]/Length 168>>stream +HA + �A锶PTy2Bl �����������������������������������������������������`uq~)i@C"0W4#}ߩ])ԮUjWJ(d7}.e}lq/T`�b endstream endobj 92 0 obj <</Filter[/FlateDecode]/Length 611>>stream +Hn1�EOjm$kyK$\+cq7Gc_Wml_#w?^{˽?r#yNܚ59&qkbsLĭ1[c&6$nMlIܚ59&qkbsLĭ1[c&6$nMlIܚ59&qkbsLĭ1[c&6$nMlIܚ59&qkbsLĭ1[c&6$nMlIܚ59&qkbsLĭ1[c&6$nMlIܚ59&qkbsLĭ1[cy_L}19d>+^;L"~b~%/yfke/6dYE<s{@g~KOux@ٙq)MJqq?[0<=,Qc医t ![~d5dkݏlalmi(fvw?v['.4T7dXÉ^ 2ydtȩS##"FFGDNmK3`Nd.ͬ^94zNLE:KfyСًt46 �o endstream endobj 93 0 obj <</Filter[/FlateDecode]/Length 692>>stream +HQn0Dӎ^~x^۾gU~ }2Рb7iCC>[4С5BbnPwF}X;;T3F}x&gvf؇Aؙaʂag}x.Yþ< ᮌ\42sπ]>!*h.Cyk{5X-X%R>xoOgIwx;euX-]},Ė.+s糤˼)Լ)}H1C +5C +Up|t}_ %]>@:K�?�,4/%&̒3.Bq"#LfG'!}2eG琷}gG琷չNY zWzeQTr += ڼCu+ưЃcNp=W0+®Ѓ zhUYB,#:IrP +ʂbxʂbk/K* t&ūRTY>xa2O(^e¤cއc/Zi4Jي XMoPhGSoOh(*7r2ϋwkU.P&y}ezk(YN1zoVHgceJd;T181%ޖ*f>� endstream endobj 94 0 obj <</Filter[/FlateDecode]/Length 770>>stream +Hn"1DҬJ$@fmwOE^p&-SN9Dfzoύ+=BO4ʞc}Օ'g.|ՕPl'>|6u>8.]?q +~*:vF:Ot3/,|Ϝnt=]08TSg|og|L]{Ѩ=NLbw){ oa{ݐl/\O#a\'Tscv+qLrTcIuH3rb±8W?ƒ=,<X[vl;pιMGmDUm@-oTy|ܵ|_-6%o1[;k}JU'M$PM蠙%3?℗%U2-oUIϘ-_xد1֭&tӪ墅p՟T\e` +,ZsуE+t2zh]Fй:w=XB.Ve` +,ZsуE+t2zh]Fй:w=XB.Ve` +,ZsуE+t2zh]Fй:w=XB.Ve` +,ZsуE+t2zh]Fй:w=XB.Ve` +,ZsуE+t2zh]Fйbw�O endstream endobj 95 0 obj <</Filter[/FlateDecode]/Length 586>>stream +HANQPAbC& Z%u=xoйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tk-Tr? ßџ�]G�lrPQ^ .ef/<]x(3S'8v,*`g҃ETrJ6 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB>_.�/ endstream endobj 96 0 obj <</Filter[/FlateDecode]/Length 630>>stream +HjTQQ$Fi[R&ӛ_> :=XTg`Qs?Rz{,*h. +KvGhG hO|φ>n|֯'rC8Vnxw+7U#4A#4A:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`Qs?x*;WdNE׊ [`Q?r)*`cEMTr?s;Ǖ?ov]x>Ba3 G(;8r>Ba?r}8|`�u_ endstream endobj 97 0 obj <</Filter[/FlateDecode]/Length 741>>stream +Hю@DQO;RذD!v[uUzR5~!�OGERy:)ʠuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]3k]xf4kϬ&vm5ĮM<fصgL6̚ib&Y3 ~=j~1kS^`?_y~GK\y~\opGvW~eA܏ɗطǒ'闱{?O'rw?q?ArViA,zH$U4sG~߁ec\m;M/zz sorWM=4sANs]x?Nqdcj~W Ʒ>^-MُŏS`~,Lr?gTSl?[RSӹ~_\?ʹϺG�B endstream endobj 98 0 obj <</Filter[/FlateDecode]/Length 489>>stream +Hao@6w7$[Fp1u1ےM#1Kp(3 5~Y`07fk̞'zݬ7&x鋵H/{g%l% }?/Gez _%\C+o7wȹ&x}9VZ2ߧ.~n9wXe ������������������������������<0袛O2v΋'d0NyOdx5?nqh3f3[!=˰O&Vx\t|V||>4؝7;6`3}s=_yoi䬙~/>VV2 +YH۰?;<{zGɻUfq.m[jhÓNYk4ʲ̦zu߰j*=T*jO4����������������������������?�#qT endstream endobj 99 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 100 0 obj <</Filter[/FlateDecode]/Length 201>>stream +HA A�5MЀtAҙT}<<{/��=z% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX��mz% �ЦX�`� endstream endobj 101 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 102 0 obj <</Filter[/FlateDecode]/Length 711>>stream +HKQcs@(/:maAeEIP6^P6"%3 +[CBAbږsCJLbig(brdGx>��������r lvgn����BIMo,NOt8_+rF ~����uq8tK<:n[����f5l&_r~./7E����T2ןsEcldg~����L.ebw=5CG2 7>����LF~rޱG4����YJ&qv~_+͞b*+*Dw% B!X,rN�H!#N׶j]bd/I!B9V9̟9^l]}a\l)z! +';r7jL3Ƥ:9Mkrn[U]3^?yܴ|&n^˦߻=Ӳ_-9 ,j>jR̼zaћ7c[[<:&Y|G@Gy[26Mo,߅]ݡL}XY}Xgzz`g}t0j>jR̼���Ƽ���Ƽ���Ƽ��o�Z endstream endobj 103 0 obj <</Filter[/FlateDecode]/Length 203>>stream +H1@�754 ±9q\q}~�k�`F�k�`F�k�`F�k�`F�k�`F�k�`F�k�`F�k�`F�k�`F�k�`F`�y endstream endobj 104 0 obj <</Filter[/FlateDecode]/Length 198>>stream +H1BQ�gj|3hM \s��yw�_c�5�_c�5�_c�5�_c�5�_c�5�_c�5�_c�5�_c�5�_c�5�_c?�Q endstream endobj 105 0 obj <</Filter[/FlateDecode]/Length 1625>>stream +HOwORn[@nE0dT ژ2DP`Td &,qfmf(Dq>ix~%%ߧ�lI(3hu8���� g����y t8RӞ̔Ɋ + xIĤՕw\Nq񓥎XJC JjvxW p{ xA\)hf@ WaQ*%_wqs&ŅdNNh���-`O<뚛6xYu<oD,& +Pj55n~}_ʷ^j%;۸}\0~kp@7M\8~Lͷ^,ѐG{]ur۵;t^h2~1;UT 5<_Jݻ=)ۻ̱xHdi,{yq��lؓ83<HxfNVThWa3IĻ^B +%W ɚ1Y^ScJyR8J犽od-RPfJ*eQvu:琏;@o̢Y^b*ɥ%n2ڰ,+K2?T"}}e[ls޶݅e�v}>,=Z[~.NUi˒Ɔ|þcO385?òНACs6>ΖL^X3@o=,; Dk,es3hN|E53��`M?<5z9Tr}PVTzpٱ +/_ٙ/S9cِ\NG5v��z0=ywD,&+QBI)TK׭)/]wsDfayeHkhkqܓ~J��y 3A9rFͮ]5GtMtu5YF?9H$.��(k`Op5j5߃kG7om<x b"U +]\n���5**<g񐦧eydX}@\r#d%H�@Xxyӭ}s`[$S(i{A(_v��@`6^ipr +~)/_8~j_h^<B��o5vT)t{ N$�V84 F7^3:_W )Y��-&=F�xw$E΢a]v_ex +�7y ٞRMS=+ݴ0YEmu\[�7y c&˶:M���`0jU 4"k?&̞dY6��Ӑ?(pOI4wqOW/wis7ucHۣ՟;[l\%N�`8H$4j7fXYI"n �毩3Ӑ?di=zt:r꺉|P}S m./c-�lNC�kJ_!mvo<?3bg*^X7? m-ۧk�t߃a3n ��bs؊!MOޟ7�(5 endstream endobj 106 0 obj <</Filter[/FlateDecode]/Length 864>>stream +HKa<dY@v$P!Ԋ;Ҵl%VXsMPvўÛυ<| B^ej5=.7UWH�X,Լo�4mp X?Kְ j QYG�@S"'}G���d$%eEs���`p QW'���9I?}Ewr=�!#)Yz�WF= tމI�_j|.?&�t79"m} sڵғ�ݪkԛᨫ�N?`>S93'0;Uho�::yzv.q%q]Uz* y+*!Az �覦̪3uE?zݳ͙қ�Kc@<7&Jo�ttgԝF@x4w{Oz�i(ToI,)� ]mN@'qǔx70Ci�@+lّM@'(yYQYz��@HKο@@'H]\Y���!L]Q9>Ϸfm.��PbmRw׳-N@G)]���'.uh.wH��e{<unV|ޥ0i�4p(-xtb�0yF@7+aP&HO=7Hz +�ƾۙF8ݬ쏭7 +Ξ[# >t-�r + endstream endobj 107 0 obj <</Filter[/FlateDecode]/Length 983>>stream +HkuEgIb?F ʦq3J1 +Lb)62Xkn:\g9gǝǝsl:R)hB7v?Wsߋݼ.|y?PF7-׽Jiflm=t�Pr^Yz +�;,Ms$_ fCH6�z$|C�D#4]-gocCUitIO9o& +?K@|sCo \.y�I~;�`.Uff;=h?xwmcjy�q1_++JO9kl;MͅTv5H²2 �07R.Y3gG[#��`>gg}ФPk +H��OChU?N|\2>��|2˛* YW<X.=��`^%ceF@B]'=��@\]d_:ZꏻZכS{Jo��.17OE~0Zd&CG@KK'} US�@\m̵^ed4)MH(-^C@'�Yq3qzw锞 @oPUS�@+d1Te4+uɻfD86zEz�HYb{}Z4+=mo϶;-S�@DmGoU?Yx&:{wˑ{'CG[�@m[̈́fc4Q d1gN�B-|Lz +�R ˃݃S>ݨ?LID @;s&rr-�p+.;7o�*f endstream endobj 108 0 obj <</Filter[/FlateDecode]/Length 1208>>stream +HmLUuEAMP[FERQZs%ddVl*S.q{ɂyE7id^hoLojvCKss~+D'o/ Nvs�LW�)׸Bsm<=&4\m?ݙyD���#=n1F3V,ZMYw��0ٖHxK5 oS\RiI]��d_Ziom?`$^WVʦzW���#!s<fM,w;��lW0ocY0��<e-z8?xwVz]�&b}D=ˢz�$Aq@EY >Fh9g]WKU 6Rի�!矶v0Fmؚ'jyktT�LлwgU0 o"ת`[7fL} z�Pb?nW4[?*wGwNk`ݨ]ۗz�HAѶJΆM{"|;{wUP:�|GŢz�0=\;쥒~$:oT/#EW<6)Y*�0!S;]o-+F!ѦP7dȉIU>�h>qP;fQ�Lc66uu0GiS' Ϋ!'�\r|5�[fl9w/6U?GE];;7jkuFGYRt=k?V +O��Ybh{8|JA]r EQ9i~ss _}nԮE-m͕m!)R���ߓ;chtl]sY$,!*: =UW w3H5���>jrz>ṫb +׏z5'*|鏙9KES~{CN\ ��0쏿_My_0ѥ+xCggK[/rSi�_�! endstream endobj 109 0 obj <</Filter[/FlateDecode]/Length 1492>>stream +HkLSgR`QNtsqq.s.*ь &Qw!RQB`m Z*¡*uid˴̙- /!qzNraOw +CNK� B< nNlpycV#[Ɵ4{t띗_ +sVv3=f3{{oYtJ +写Cy?���lat{eSj1m$:Ċ=8m)E #fI4D7HjIF��a[ە&?@ ƌI0*}={>#!$�DbcIK}ysVv��a_Pǹg2ף?.^'G\N{&LwX{C]_lO`y~D`3'?s/ +�˽C� gV=i dlOCpj^SO3wcEX}| JD?*~o �TCVrTG�G  ByEݽ؞fgۼ_\?ӟx={:_=%qxU�`Z5g}a +�� uumJQF. W%7=|/5%{r6eБӟ`c>-v߱5Cs��"0Sw5.&Q�� ߚ ۻ-/{#O}78+FJs#Ҭ+�@Xu3YY��ʷJk= +&mڛ`ta+J Jr}vs��09Z`sh7;d *V(-kx�Z4TWUt�.o!_6gB ?efz)Hm;=���xﭻ&DӖ,ckSy_���@qq]v@Ú] jD'&0R+Ӯ$w���P!r뤵?ۗ�kt861 q ���(`[Ōh-a dB(lE{QO2QZ /Y����JCo"\-_7 jd<RAźN٦RF}e����E'=W#?6ykr>OT22���*:)_?@M$t4;J5;dohtZ-�@xU+bB~=asV_J%;,:3MTL^4@eO]8Q� BHە3c!)[?@M?>Diahy{q9J|�~D=ZL]WJUP_ �n-u^ endstream endobj 110 0 obj <</Filter[/FlateDecode]/Length 2361>>stream +H PT, 7*r"XϨ 6V5Fm</xAcmXF6MtjisLLg.]+{7/F ϊ rz.V_ȧ&Ç[y"cM'̬^ȥYS�[!j08?p;hESx5>w?xJlmk4ޟoR_;�ȋ'/>Ns�y{|PJϠ#[Lrқå45\8R+D驒@fVd޿\��ag=xwkͱ'~̑L!͜e/<s{H}*� SU!w[K1OvyíLQ%��ѸP[cݕ.TJ}.� ?|j1<_[yt;w,rb1{>`?t{�S³@.i� M7-&qzFw?�7[%::dFE#����X˜f?XF-MYZQ 7<?*jn6|"2!^e����Mϳn4XUԛsȉGO:{~I����=n?Wsn{�ت(KRLݯ_nf?x<"^ +���2<r92<Kk'kK>cC=R���@wbȼ{]jSqlۨޞ?@Nl?B_LmѴxi^����3{|Ρ?9$P|`9[jyx{B!z����tƇ86Uj>ȉG51 �?3۾rR�_d?8?ݷ:%dpϵu? ^�MT(>� óyM\`[ Nl�9Gq$=%�ܩ{Qh"+r"EZc?xBsGI,�З%-NTBT9{n_ȒﳫW}GU~`yx8;eT>`=)$N7\?] :qtUJ1 +S{T^wlT4% wk�r &`r #H $ J(0#S")@MA)xDZDR(bfEI1fS+vM|JBOėf.i}]bWlqEީ8,Sv+t{wLZ^?㭗3U6S1ָd֬Ue::uu/& ۊuϑ.W9e_oƷa2'ݞ7*sK۵Dz?ԭU.ןz+ +euk0v\1P˳bwƗMh\]C &Pl.S,*הon،Tqç>`, CaF7 I +ljoMQoA~Iwl8 cgt${LJЀ}9<H'<b@¾-¯=½ %퐁*Kb¼hCH-s`O1jTzE3؛TA½c:ߩ##}T!B oKnIK(!~b41H3ܟ4q@@&ha=Gjl0BHFqaIBrMJڌa͊ mv$eG{Y:9E2=\ؗg }"krr :_Kt.7Bg٩[\~Lu]C,NIn&RGH>{C?إi'k�I?xߑTI>cuQ0V?ڒ<3틭=zbH=fcs{3!dflKX^c9FX8ƒ,M +c 4񌅄0&/aC)NoX9:gm1` N=FvUR?"qvѥڏ#ɖsȉT#|叨xu(Jq_BbMdl##dKG2c#VGwf]peE_�+h ّԏf�vyuTތPs}>Ǡ�<NռU}fIN?ckX$cvy(biϗ&RPt/>}#�ߙ+ endstream endobj 111 0 obj <</Filter[/FlateDecode]/Length 486>>stream +H׽jQ!-6 Fc-lFl ؆4"iBbnVBj$ -ͽ(z:g +a۳i9;E^\>)0� 6}3�@l9g�5r"��kD�bȉ<�Ħy�M_#' �FN� 6}3�@l9g�5r"��kdyrbоw͝;_yFjNZg&as<ǭkhT0jAcwa~kNjclH/;,ݽ<G9axhY-Q "ϧ'&ٙ}tkrh+3as;qt�#9g :Og@49g ݷϟ}h5r"@_w6_ݬ�kD(l[~j{�D1,^,/O~3ŧu }m8`�ז endstream endobj 112 0 obj <</Filter[/FlateDecode]/Length 3191>>stream +H pw_!D% T P(!MZńHI`='dUV+]td-ٶ鶵[t$sIo^ϓzs=QQ%ԌǏf9. @k6oR󺒯*iHc,!Dd!p\+=I-D!fQr b:5Mnㅘ2N,ĸ1B +"@N!D O_!\ OVD6iLt{q]~ USpE6=.J_yxxZp&ؘHv}<<<O?JSxWV7ΜU^=?ڢ?K61-F[/9x'pA(aV �9UK<SN? zJ_<<O?JC*4;D_„Xݔ~5さbJr=Ji5UĵhC?5? I$w snFIo?xxxh<`n V */?x4JcX_y] +vSN?kaa? _о44|Uo%*6-o.)Ks�`8 f0�+<鼺…苇iU[<<Mt4 ++lX~I)mWVj]ȶGS!ոM(-E؈BuK^m})@1ob d5X8,tˤIPLGg4zH8c0#7 t9}=ёs\Nhj<<M[s{H1a' +?OFiH9|^*O9mh$RG<2B+CN)ȬGcP[oa e-%7m+e+[Q45/:4zݩSFadJB`XX2h(=/IIDy$ME?zT&я3 ԇ ԍ{8xxfò=*BK n)+?x4jH9~}=_)?!Z׭Tup-Б^ X돟ڤ?RCn[#o-c+"e6JVt iT9f;9f 9& }%XF (TzeYƁnFhVo;SIȞڨR{ssn`?1\>VさV3$06XP9DTtTT@GdAo C?&2),zWdpߛ& •θD'ؐXx̵l$o<sH=Q?7c *Q9P?u]%芿/fRӺ/߿#5ùۣ?KȂ@jwdUp<j +99A~B0=)zr/OZS>;wZ;*mliV榽h͵fUNȳ/]]򇣏?j ҙ-jMtĤCT6:&WP3@j�lʻ<6^㧲IuE;QlGbhmԲ+ „xU{*m7LqE`[' .Yui<y'u+)$_,5Y2hC?먔=@U_#ɠ^'&$q<KҞYl_=Jۿ{>Uw NQ?V8IN쩜6c4RTkuG 3ָ=͵fƮ5n ND`7,l,ǰ?CNQ)7㎸�%dsEsXD6AR#vV(o[;8Gw$FMp^k*+*UrڌHoq<uOVsh&"\ M.6?! ~HLcYGao<R{i(Ǔ MyT85}˯;4l)qvфㅗDQ?^}^TrڋXc.K|Iך)6ҵ͢ #5Q̧c?Lk I2.^W :uRj.5 +Pl[x_iYа=C Ukv(?x6jǰ(,\쪜bE\5أgq//\iɗQ QcF0d!Gôc}T_Fzt�ҜTz.V� `p0ՑiUla{H# 8G݈Q?ީ8Vy^wS*?!Z ? ikM̡7J׿{ĖHA 4Yz<f?42=п[z�D PIITwʶzjи?}Dn;GF,[:!6`_3 !Zٯ{0ORI% %4-:DADX4DRa4d&i-)MeCC-  CC%M֯ߝu^tx_~'?[i]հ4f/{X7QDE ?dȕbGj~GZtd<oةب�0Sh=+J~{\׍?p8RGy�N|-t~!WB$W:q =ooq*}G%M5Di# Ba?|B�@ +�%O�~{G5^wX_NHllǬ?p!$ΊOR{ F0SO9@Ͻ`<)鏤A~㏸A&82@?rX +C\�BU1S.Hl`iG#??b$w$Y8f5T5 ]y#iixA?b#wg%v5�Zo6i)tBu>�  endstream endobj 113 0 obj <</Filter[/FlateDecode]/Length 3044>>stream +H PT+HM4 +Z IKĢH1. +AEbD̂Jī +.cq@B6q=iuk<NG("{\=fq?@Oѿ_ЦOrmu4BaX'BueS +o2+ov +!|DB|'BƎ#|Ca +  +V{m.=s_Q:�\B-¡͢.*F(VȂv w; `u)`!#pyw;!vHAe`xw�\a?8.(woy4{9q� h@pazK;kyyybA{ކ#?hs{TPB>ފ?d+sSGvǙͽ}?_hnP #Lm<x +o?󇐪C�Ntw!yG Uݝkފ?:~fS5r測ܒGa&pFnkiX| ^?괓W㦊?p2 +'u;hnfm)fקX+&R-{p2M3W9uyqN}|H\&xr3%| >d?菎= gf۪uk`o^ߙ8rTHU"kwI`wC'.Ul鮳&&~9MsO]I?\B>;?^ri??yWc{iw\f»s qRGzBu9uH[IJ_(4<kvWL?lc&Ľĝ4nyﶳ&"+i�= =# sJ_t+e6 +u&jG/GK?)R2گ!d$s10wZ\4:z-'u⏥ObuwC<M1 LHO<g3tE^hzM*0Pmfwh b/B rQ|@r`g`3›q*ow9/:_z/!?~C[}+ɾ(Q׶?bo}/*ӞrJ5Kf  qoa@g THF?>gS ;,!D#1Eǵ>͝ALD}rMUzTW|'w) {x2GYI8geoQc` 6䞃>,?hn/úAGkt?fΫGU*M{Am* +Օ}_|ۛof?fgKsN}]vXL?$쏨QQ+9ڙ-ClIMV?Fm M47!?=͉~${Am<uѡqps7#&"Ra>9KߤJ;,&RcY']<k5Ɲ9̯ +vO.]@9k !6 / $菕"rr^{ػGn{\i}=h!3ʌ\UH(y B%b !Q'd8=6/d̻ȯ,577L?ZòA9S$Uޯ4kAH@GY W5{4_w2?p6k g׷Xя}?3cMoyը sMo +$b !QD>((+<#9z: KizclW?ރ'ѶAMi?VqHVA\V-,%oZ-t8R zAҒNk +ThۺON5;zZ 챘<CH?(.]O, T&s!>5 &X7H-dDV% #ߔ?#LmV@?y ǏgAywkb""(6?HHw6!$bG=фw kmb1 +l>_QP'< 34l?�ae20?tAy +8hVu7Jr?zwd`׷^>qJ,&z? 'ħ1ǜd;SœsT~X>W![zADfPxhipAX?v,j??\2 a4h{g A,+ޜN2 쳘qDIڲڽ>[͚~yŵӗ1ˊ?MA]a 7?{O8_{i#?BGIYdGyn>+AO90Mi/bJ{'ԷL?6x)xa΋?e#&nlAđ?h+ה9^>+gKD?WEO/#zAwp >H4O`"U>H5f1{pk\ +j#uN꾵_:ڴxl>3߾Ji]|pv= !Xd100 8�kW=NӤ2hcT0Ty ;׮W}uAЦC?`PTxvѿ0�\q endstream endobj 114 0 obj <</Filter[/FlateDecode]/Length 2677>>stream +H{PTc%1&kUbf (&MD&Q+ f>&`]GR5PA% +>@ԤSߩFMtGWD_ﹰݽw9\~;밿9oLVY^ֽ`Ϣ` zB\\:C"uk,$Ye!vb"EbH֒\!<\ |'~'XwfʮĐd +Pv>d; ])Iv T((PwR9BYU)b!~N-swR/XLuJ;wKi&h `)(7�:�͓L��5EM> "`"�B 0Rn m 9AAR!>騤 �ctM渴5;ދ??ΫA#Dllχ(%̳=Q\-n\o/~At@}񝯊88b]#/ȶLew&d&~ud/1wntXh5#[菮~>D]\[$}c  ;OWG/[spźF1 At跤aK<Uy|d/uM>vhvyG?l_a h4.|=?-JChi?hƊzi6@*g[*c"p_P0_|x*˼NH>!c<mr &É@<R{?B:vGg㈎fryD{ŗ8Zti_om1CpM(KgCsj/#m+ntȝ??%7HcG>xK0} [CcW| W^|Yηߡ?8;]8IQ-Ѯ{VϟFbr!#CGmD?㏐15weS| т?^ٜD{_o|H8"XKf?$YW~<y:9j]`;Ķ1Ch5{dJ?>IWޱ?S:뼼)->5F L$U,xo1Cp͍ߵ3+gVw4YC/<#YyPbp2i@^)?p4Z͸`R4`9g\1 `9 g<zoӢm{$~؁ACA#de?Q?妱 'F+,޼:θ?#ͣ�c Omϫf wGGifTꏍ⿹$ м?1G=qL"O-VA([a=P s.g(ݹmr.2�Q#jĩ?65b٢/2[B??ECOlJX Chi䏘<C�}%s.g1 X=UhqPBJrI ߺG Ľ?\Q.dy4FxGă<tƙo`/ ђ?zug98b|-�B?f,o|_})ߝ?qޣ?<?uHA0GO-tC(+++}o-A[VۗzUu1 +!�!叼~T,/d'Gw6{BW5'3:h6HC2mAV{`mJع~4=F-10e&9"X>˹x._�+GhgceFI%Gp_fynkZJuE苋 "D=<h\%9$O|<P复5:F^S|Qum1P#Fk4_$pp +?BY�tkAHb1\?uG${-.Q9h6Hu'!ydl{?CIh#3;Oc7 +Ѣ?"LK{w.λ_?909ܸfn +EE5{+_.r<#|"ɒ?.- 5RbG'#_`3 +Ѣ?h;V:N88b|P7{T6ksww8&Xx*vio,&w,(GfAL(%=a kǽY*>}f-VW3\,μ??Ǩ_N#WamLig.ܖ1uo*tt,<?.2Q?\iGGX??*KjhI|tp#g^*# Y9ȹxf^PLԶP=#I2#%#.xݭi.|_`a =jPs/�I# endstream endobj 115 0 obj <</Filter[/FlateDecode]/Length 2599>>stream +HmPT;FM'h4%h +L0&ƌfw$FTX݅]]PQiM +Q1劣NM5u o{rs93)!pZwfl*Mp4-AԽk"ĕrq2G\%sKmęш341|ފD p rs[m曩jcW6S{>YjU~)p{@_@ +m& +P*T<<ȕo SH/X%B(aIB[;/| ^0(&HjrG0*`4Th0N'Vf +(OƎMx@4G}]|7QK#�C?wLbg բ);޾f <{A4|j_IJ?1CaPU8 +bJ?!⎾y{b#hiVG:TR1�@9ϵTkl>ZlKG ?ZO4x^G*l t51 +`O?{g4V#AѺ?gTR# ?"C#qaO{OB9]Tg蓵 ?~D}.䏀g@gJAѺ?Fctag-TKvÛ?].Pi{-#IH_A +?s}FKuW;i3XhPK?!Rz SdFk0ޓ??:d'?h?~US< W-M #$;N[-3n^/EP?<=\KY";@r-?hvA珱{]1f! W-M Upp|)q +v`@"9[dl�EџA< ֢CyϿ?h4Q=+PL?pwD XmV˝'.~V_wЋ irÿ&1q2}A 09S MM>*--LvAJOꚪϳyg_4Z@km6_"UL?T{xGp$bHGLvMqϽK#tQ]7Jd7Ћc4vY\0B?;1wVܑ?h4gifUSE2G`+řx{}^17^7揕0T ? @=ޑYO\.;&"d7u"]"(ę)c)rk|<g^Ƥ́VZcKgO͇[/($VpEI>ȁfY!l#??g�R~:z0=D-Mcaa{7W +va!?f!yTD"⏜Z45>JUxn4vZgmN@%0iceP"&1BG +5|]"?٣?LFm=Vۙ][yWBڬ2w=˩)yQz\>pN (⏣?Q?؃g׽m<Vs}A 49N<CD 3;ei g]B{}r=[ZĞeun ]?Oaۣm!Y6>}A D<6NW +ajxGC<m2YW#M5'*6>?UWh4uS%0AAx4Lܷ%O+FK`Z kKu*؉)*?k?sX+]vmH]t׳6KuzLwCC/Í?q'?ݫ3G Vc{yr^4Z@Gfr/*؉)*,FլټϸݡҘmemrt$w +[D Eh!?&8Q9]/ _lN~A T*T\E\"S#qQeɢ)xog^lqAp=G`Knv H`GՓNw.sqBg^4Z@Gܮػ'?W"R~ĜVh�7V endstream endobj 116 0 obj <</Filter[/FlateDecode]/Length 2783>>stream +H{PT(LѪIMF#"%FcmѢ#"*j "ț}qwyê ME^i[MtQsz+<.9 wց0^{>`1W%ҼIAЂzohPtʍb 2G-NI8*Sp@,HL& >!5oI.|!ɥt�v˂i_ar o,Y=3� + _,_+zylɗ6[M{ຠIa}ql..zpp,}똾n;['V*Lh~6!IѮ |h/Mjo/k (5Bzz !RZM +B$EJ,\@tZ+ g.m:'e~KC F,GŨ$#F}l2Y}`%rۃ[ ԅ..ߠ߬wܡ?p&Lf/\RQuC0'!+YUt(Ld<^FW\珶㏦a7.Q 2ah �ih/<;Fa)_ :c\X58i&?C}Vc+98cx*^T4{SNˬ}9#hGŨ$ӄ͸A&?3ŝ?cx[s^3fvTRL1Hl%xlb< :udn?dnh2AF &-dXX?s{k7kR/{GY48iuwh7 +"uMcJin2}m/" yEcx_[?zO|#za>=ukҽ,r}fg" C_rYnj~y!1EUBk4q+X2/-9 ‹me?/nU=A==?#4O0?Ƙ7~)$a:(kRI9 e4}&9я1EC^tcLe˼^JtzOO=4G/>Ƞ}A2cKA؋}gsNْfzYHg+*Fmc$l? SQ0e^)iEŵޠS[6B? rc?F?R%@RP\&Aw^ 3_`vK#$s20<wҜX;[C//TTCA8Q9\[k6'4{?u_Aչ/b:JȌ*.(+Q~W#/]9rӈס?sZ=s2x*&۔XMU/Y0)K+T|wڵNYoqCo +IlMf6 ZhIc6x_.]>W-/yAۧ>xpεENU{3^QyJc3!2c!d!Mz_{Ȫ]SX/yr4z&yqR? bYŗ?�7#m8<ΚeC府ڢ;]زP/޳Юo1}Rhy2_^K(͉U+nUKB~6- 7Hh3#0aBX\Q$>chIe5Mpp^\#n1{swMBQ4 Z?*Z @?5T!4'RUGztrcA mKr=';yCRA{MPu:޲R.y-h`h?hQ5F]q;=lNR%gNksCyB~fb6e ?6,?!󽵄DW &)# @p>[X.N?Y-/?p1ӦIx/wzA 71~H1|1.ۏÜX!!wR]<#Hާrmq5GPACAs� s_։Ŭw87wjn u-7�Wey쬭G]sZ=334j?aT6;!Ci3ct?Cvh}v/})繙o) vsP,Z^XEh돬JyMRiNaJzXvDRx +{^PudF-`ԞKԝ 2fG=`rC +pS(hTzWYF_dqCUQSɿzqI㣌csYo-= tVqpn\c !!燷3UKt$S?"@Gn6~t9 ZYAinv _|cs +- 쌡?ǁ?*X逸e+PrџxCqUtEa  eC@WYMRy){c`�|U endstream endobj 117 0 obj <</Filter[/FlateDecode]/Length 2362>>stream +H{PT񟔢hM'I&NE3j#h&0Tm+Q@@|G(�Xū<eHPLL`5FqN;mZą ,|Pv|�pԔ{I {{Š@_w?0,_/֜v}KjB~_+[EF?: כהe,^J"%-!s!!/8*j`̊ལj,F2'> ! `B4ԂjhL%a8D_m#%C}E6y m6׼ +|Jhw&&*.<o6NQLN46Uy� +~\E/^l5'vMལ"is(S-ҿ˯E2C7>t W7hT3}#(#;Ƃ2~Uk7 a?}EojZsGA8.$;q^Qϟ�g -o̍羟jlfk/oD| +a䏾bћfe[)j);&mg&?ni˵x連LW>}p^os n ¡?X5cIۉ,pWlǣumOGྛiʊ.LYe6i-!;8Cc1[2K5hke뵑i3H8t E�ӟލpP&||Q�ࢡނR82 CYBQwGT%Cp}pvt{cfxBi000jQ-??CY=9{/E#Ӡ?` /)~KH�h Je <+X,q3$׵ɔPjHF?\+�|`当i[h;#߿^(9C򇦳*>Pt9`){aA?su}GC4z"/B8KcyⵌţO佋2K4671s/:ڗ�J5*}.!Lp.ۮ߿N,?o'9={iwQȮg<tZj 3c17A!?:wL?|{GA8%U6npƞLzBŽYWsEbב+ G4Xc*ǘc\W큘 +s.!L=mOw�i//oA7k/o#:zd?F<hY;vH{GA8S^`(/vrcQPد;Z<A!)<2|MI*{Ai+"gQw׏=1AgWlJ47OGOa tG\Xb=s.vZ ^8I X|'"OxB45mJ1q3s�gj rAH Wڽ#}lɷ#А׷uoP{@]  .a8Uggyfcq{?5i/F{ڿD5 p.*{dD|U̟=O<?r#} #g?k| ^?!?= xB47OꍺQZ8Wc#FOw2g8rj=mjo'{ FV$1x"Mi`Xk=?YQh{82 cd%֗u]5p?뗲D}y`7#۹ zHH%?Mqc/cXп QtȘ{GAen|ݞ'Cdy[gfq:@}vՍkQ`e+GA?=/&lusj #Ӡ?Fss̺6B8_cQGԭ2m]9t-d`` whH 1ɵ0[=/<0{/,?5Ly~)5￝|? �x;6 endstream endobj 118 0 obj <</Filter[/FlateDecode]/Length 2486>>stream +H{PTbLLff2I5N�GfbF[됊 11%/M_Ev݋EdAQh;i?1&fNYee׳{|ge{χ-$B \@˯\HEO3=Y W a;= 翚j`TӪ%BM(ɑȆTH(Mg;bio*^m_NfT +Ȅ`E͒!M]LO'B�[Sm_�%?^P:G^aik>�]6&Lgg8g3\-_?2LkEkW<!< +B~M[+儬$er[LEg 'xf==˞a5wMgs>?֩? R}IFȷa&ǏNm|LI/yiiS~Ҭz+$xC`B aψ9;r3g)@,ة;Nb?CK'(?h^ߟ{|9HpO,rcמ3U;6p!ǖkmfkdsk3V?ҩ5Rh#&8 };6ޓ̗C4U.&$ cr1?4HvRCiV^SlR{Tb83cwGì!5�Vco!'~zᾦoY 5VS{]^pcZv#\S6kg[׷ALة=N# +V?3uÄ{kEMdaG?pD{m>!^pc6p-5 =gv%_G<r~{i{ov=Q>?0jQ>ZܑPvx!Hpo?ߵe7\k3{]C %$t!#%9ʬͫɓavuPby!ѺAwÄ_{S["i/.ؽp/oc*bB}M;y'6'3O?j`0ү.w%? ^GAr1~Tw?e0= Su؞-x(?pD[tӭܷ1K&d^Tv=B6NȣsO,:ZB5X%P E]IJ R?X{m(}d'ɲ/0sx{?ރ}{D #Ҡ?<!TWSvq!΍?{6<~8ys7ElШ<zޒǨ9A.#gLF?sndj?,*O"i}qSعn߭^p﫺䨅IM.\n{ǔ#Pu>/nݛGAc'5VAᏑ#{LO"i?2Қ΍?#OfWKjlTI@1ؠ:7#NAap&*={D +#Ҡ?<;fg/ލ?d#j$1y{(:]P'NqwIPnCQwuGikrB0L-v/wc߰H-I<=  c*!G{D #Ҡ?<[X^ vkwo !a_<bEwHsW,=7H[ bco#@?a<{O!C46%:̕O>8wo !h<x~KŇ߾9d:\>? +?dC<BM.-J%a=#b"tis/ j1J{VK9AwGrBNwBJP Tb>``5 /4!w� ֲOQC4ØPYnhjC*B3ayFQseFOdy{-{M<s>}˙5 uHP?T&;,;iYˮ!/:mգ[MSCc_g1!O37=݉mGWlV`/T(@ylQf 9H?(v9WSΝl}Vya菑h(.3Xvi@϶V mD_K杔J/9 �!k endstream endobj 119 0 obj <</Filter[/FlateDecode]/Length 2279>>stream +H{PT񟏰F ҌɤF6igZ5AMۅHkL mbBy((yʂ,eeQ]"I)I5i&Sc2Μ޳F %{|Lq=�O6M}bs_ uy;?`LzBV  +bB ("g Oy !xMB†E֪I +6Cѥ.WԞ>x2 2!Nm@D  +!#ysGT<&4CtE'4Utep;r$M:|W�put@}VYܣ4z_6o +ƺK?nJk\C=h!7 ez=2#e +7O6Ӑf?uJ5XwXCi-EWT7$p1􇋢o~QjOs0]Go,Azr?"F2Gx?LtjΤj Uw8rg{<a9]ME]M%S!7# "„Bo @`3JxGN|[ eMڋaJ>[c!ϊ|BLsIP;)6?Z~' ZdL?8(lP_`LU[X/?p4HuWtK>[<cp-/qSXv'z\ +S2(?EBw8r2'j) yUwr,n}g3>b)`s`3 +P{緵W]?n lBp菺�;3'Bilq{5Iimo1 lhjʭH)ڢU9w;um|3\MDqw8rٚFY%!H^Kџ͵OX6]QEz"x.ǝL/D< +p\Ҝm`Ӡ?3l弄ps^0^`CؓG'NH})ZNǥOg3^z/x #A-A+n)|\V6=.=m{g4ɝ9b!Iص=gc^mNGN`ے?A[z[lUfM }Wc[{]&Eвu0ρ |`1p3|~_PWCilSFROwsB8Rw/(9o$'ꏡ_FGwzx #A/ a=7vI~.ZD2*N` V%?Hi'gDu?=*]!</]5Iσ +'C *ߥ/e fCCƱ؃+>&j;|cٶ`X?p4iYOa]Ρ?I۱; Pg巋#Y0BwZ95bcx?qԱGObY�ϡ?p4i4yߢی}9Ǡ*u^cm3vd:ȅs,o>KlMx/P{j?&?gU6XAw80(WCH=~,V*Ot+R{OѥQc;?:~O?]:4sǀ;P(1FwiCH}~g`3X uޓ"656Z }JBJ.w"dI*?6|O +DϫɯH]1Qs_jE "XcJٕ^Gp?BGG�nX2wW4Ԙ{ϡ{戶ƊT|y| 6M.=&>p[uk+"?x,%~uϮ ]PwXC$y~?}^}{ #Y;ոV|})b`_Rޢ?$drKB��N endstream endobj 120 0 obj <</Filter[/FlateDecode]/Length 2763>>stream +H PgE6 +h'&i F4h9AN P!\ r. { (*55#D4̴}+-vg?>E\@r&#d/!om.!&M.^ĚǓ{qPTʺ] HDHbUd!"7l1{ BZLʂILY#F@.<90b2pfU�sj=rc0()<�:SgcrnAUc^$ϪN~*i!]#獚funv{L5-YÍg7 YqZ넬S`_Nhawc_h'2w1H]+ L2?nB˥{8B&P 1~g k4:GH�a+xܟm;C.ı1iC?T֘VXhPi;u)ɉU2n<Tn̛k;=+;=pCO_=iE߻YFLGQ I9=O9=lG[`Y&ww +33Ws:;hs v9  ~ n/9?&dfoT״}ۻ]Ǭ/*?=x-OtlJ?{ޫ X?L_~և=svziAC|:gg#`݊� Wg<?ڳ31pH[El&9}\_cGq1lw?z#4c=5h n/9? r|9f}r~7_}8:pqiin+ 4cæ0=; w>YBwkin|#G_dҬXI_/:AzeZǖ5} |z y *uA?BpwL.Zwヅ9f}cskW.(2HXaa"#6gLWmdStџ=�r9}{ϱ{GH3QWOK2c^۽ѕOo n?W҉du* j7 *IF1 b!ab}W}}mK:& Y9?c�~N~߅#iT4s=!rJE!kA!c4׶THZYa8 +&H$Ђ9-QpyM +XCp`+�[GkPXߡ?p2?*s=!^O{ϙڿ^)]9?c>-Jr{1_J?-4H dV+sح?\ǟ#_낰CӠ?QvR<mwGŜ#jU9563פ]ǚJ:^y*:?؃Jܚr{Ǟ!F9sZR�bqdߩ <lOZӶ=!IdAlj_lXb?`+q_/ R6 {CӠ?SvP_GZŚC~Tk'}l/<ezV=>5##Z_8]?uTz{]L5q,YV}^ݞ\3Ǟ!DgqB�x'$Ќ kz5Q iTdQ BJ{6Ux/9Mp{1?piJZWW_sɏˋ1G̵/ Ӯ޼2f{UgN{z??Le/\Ycyzovm�*OuZy߻YcOW>IN"S +./Ms5śc9us?hRy+ ڽMQyAj.!c!&܌~~:'Ǟ!2 %?B >/z,v<;qWHaܳ\A#S؋?l"[z_{ 0L4V+;Q[؅A9k3{R�yXLڲƸkVkOtCɡ?l.o1섰!|0.= CSW.;rH"+lS^bWYo|{YO9q咃/ٝ?4c EG3~bCӠ?٫qAj]G̵/ Ӌ)lBf5v{w1۩&3UsH=,e%񻢼ӳ%apml ﻋcOoȆ}o�b!9[Y1?{o1 $=0<GEdZXZ>ӳVH-ޛJcG Gz]Upֱ��?Ì endstream endobj 121 0 obj <</Filter[/FlateDecode]/Length 2548>>stream +H PT/hmZ-4:M,PRĀqP1. +(Z"ϕ"A. w(BE[TдN؎Ʊ޳={o?28{o<Ps_3cx,@d0Tͳ֜ ̇*ʦ +Gb3m $A6Q_&ιZk$3Y|s-G~sk5*B5H/+xj, Kj*X;Bih'v6G,āQ:Cebn3zEV;蛤uS9AmFJx\mC}PmW;X@:\/+ݱzgBҀ?w M!fz (wd鏴v~EB+g g5Ƕ ?.#xY-=W 0 V5 +&J!{}#t,*̅(wd\iR՟B+$+|vxC~Ԣ-TbqGg{%Qx,~oW0RG/(}\.iOv*{UuMNϹi<% "O*o\/5GKzWҀ?/. +@2{ړ?\o0ً^Q*VONlZxG'89}n=Nw>h;Aܷ,o һ +u-!>ٶu|~Nd}Ska:\_Y9p9ѹj*8 cЃ5t+Q1;ϧN:?C<揆lH=AzGҀ?iwskMiMV"\ هBOY:x5ޅPKmbm;T;Q4;==AzGҀ?Ӈೌs3{>x'&FO[=<CDtn&V5hHމYz0RtT-}%{.X>OcǪ3u{,;x7H'g@ťq{ #sYuqobujn1o-iHijR>υ_*Ocv7טGK}%c2K g:e,?̕ސ F>i_o3&*zKHi+Zb.N%}ڒ??srW!uP|YȄd-ҹ/xNr֐Lڊzϵ?u]>b|aP#_xHc)H"> CzM@5<ײҡr +%Dl +!?L?0tX#hVE(+k͜KFEK:?V06靄FJfLyUXCd]*һXs6eƓк)6D;`=#_q{/!tTҘm御>B #H3Ω٦'Rp)YC;f+sq%Nz!2s֪ s?RmX@?7#G5nǙq )Vy7XH|G!Him!;^5~Z?BA?aYq/Cs矏^u@xf$x0l\V%u<wP#?`4)̜KjiIPj,k/GO"jMkG߹п?Z ?|_ -XX3{޺HktgQ@z,<wHkn.mLo.)Ӑ,QXNYQ!Xs]?t6HN-Χ?s- o;c8+svżz%Yּ>5}aK﹜Hin"d,gOdOCG 2WHD.Uq:~*~zJ?7r=ngfkQw,fdeNG\ny1c0(H{*}FJ~&h(N5>?${=`Q]F v_Cs:֩5H#Ǒan{ Dוֹ?ӿqNn9/7dmM2.3d)=sҟ0R ++ {ga�G,f朗ҏA_m4?9'h4[aj3I|?nwP7Blج++{һ׼m$啗&+{񽣚g<ϰ2*!(T) Cd.YqP 0�adc endstream endobj 122 0 obj <</Filter[/FlateDecode]/Length 856>>stream +HKTQ�NfNR8VZnb== IQ!(-S 5CDeoa[L3 +bΙ;ƙO(eUX81~&nk߫.ݨ� ~{*:�Ȇdq)4xd1p��kޚmD$R?���} q\���Hn5Ȭj3og��F_"{sb3��@rAVW:jbOf>Q"!��oԞl,k +mVi]n{1;Ξ?{:ؚ%���K_s;MꎘqLߺxdsZ+"7���Nf٬j7D=NswA)+{NOܞħV(;Y�R g Ynk{x\�0WK}v.[.: +�H%<c Y|CC }tFzziQ�@j?0 +}":R6m(�Qn)jakj@ +*)DG�i#?):Uvv�}t!Fg<�R<>:c(� ݞc#}O uEG�iB_ {F{gWsVH�RTɤ<u|(� K0}]U#�� nwU湹QGdžHphL���PSG~4BBW,?!:�O�[ endstream endobj 123 0 obj <</Filter[/FlateDecode]/Length 1873>>stream +HLuOhI5YͲ֪-4hdJY*h&cjSD@C'z߻}N`9N~BzhUqss%8>=su_xЄ(^ZNZFi+μ]eBXΩ<\>!'jŚ+T_YHV}$D%[&NsEd61=Um$J-Bs^RIˆ ҔU3KhV؜94$eyl,2~VqvsREw~Eܑ c;f{fBdξAi딾-9D>SY׏7?Y,XH[ pB)Un6[ T2&m2 9+.44.۾mv#s%;rtRW2MNONe#ǏM8�?޽vu>?3^Ypv0-=G.!?.DqYû&bV"Y]3LxzU־܎8J�ljTRܷvu{iB a _c:P?pz:#H&^Ա+O�?8Ne2;CdtY[6}?4\rsP?pz:#zo{3-x�#ws-7 1$N fCۅxA6s4~vXNO^'K^OͧS1.GcvOqH1$NIKj}l$BHǬXjHy{c?pz:#4Zl�Woq `YwuяO5KS7|0PtGftȨH]oR! ^#%{<!޻B⵰"gۇx 7C=׻*Sy +oNOnE |- ^#bS]iwċ%wN?TLPGo޻B]◚΋s( ]%nǼĭDUn'Bzi=.<u29ZʚJC/7 '$n fCI9)?~s_6=֖U $^[Cd\huG׃ܷč%wMGZ%?Ǎ=JWUZ[mkc)MGaɝ&-+ֵ;GpîlԻk !~8=X쓟7`C?b(Mbx!ŗT/Dym&bn !~8=n4mp;ϡ#�hGf٧8ҦqӣIo?JpIgry t2fzttE�'aɝ&-vP%n5U:v@7d5>0ڕb�~>eYwx!Jj͸>'Y׍??ݓ<X Jqdv}?,mݠwLHحj!)tk3L&_j 657zvf +LG [܁GZ٤WsxzQ@{Abtﵵ^&.ceYn~vH \Ӷѻc5跿�p endstream endobj 124 0 obj <</Filter[/FlateDecode]/Length 3611>>stream +HyP Š끚=]㒸& +ƓEa@dDaq@fc8{Ȗ+&QR ݪJj_[H2t}Ubk~~S""(e%V9s 13Ե"fů':#ZCj }%m$+8nO,�qk?mf釮ނ +b}!-Zn2a88F"IɳL&'2J䐷xM>3ld49KHq4  .$+Xތ8k)(Bm|?zi?S& ]#")ɺG<($vSq}=9B".?0l)?S8yJ2Pr\Ǐ"ݜ0NA-nPG*~18QDYSh=SWAco?$rIjoe+W 2OR\;H^7o^~ZL]?? +ɨ?ky  Fh&;6ۂ~␓43ingS9@H*sx +{aGi#ӞYL.G*κDr2Ҭ2K?8T@ cڛ-ݙ|` 16b)P6k]"pa~ 7 ٜ0ꩄ?y-4&|u 1FvB Z('cgGG?sX. w:}ebG܃ft&Et3k,]ٲB"^?02U~]y"x:DW]ECܿbyhя8.^1,<ݞS ] pLL-kk??, ncF]Z@ UKo\2.#%dz|CdXwSyL^Njk?Qw{ K +hxW]vؔU))?RvsÎ2#Z_CݚB"n?0"̢'.L_O{ZwgG>A@^y ^2İ/ ,%x S鸻> +]At,]833x:kV-}ƿ0֮ v>*=:BR3!z2TkfG:꫸Q/+QwXgu%wڛ;ߓhuBs['y֗gď냽&ʎt2MBTG߁1m߇ƽya/IvmIf]-ЏD?:Do b{eO\m???h Vv*CX7]\6ڙ('*<V-]xR>E}%ٽkD<.ӷ6ڻ;חݥHy91uD#޻P=Ԓe[eج >j +w\px[/܍9l,-hռk@Juf +~ S?spow+e4&)[i5pVzҨd]khO hxOOǹ DlxW2R1DܤM,uS?">`e'}آU&Lz=lf{h_/࢔)|?ssĪ N [zڦƮ!t_2uC+<Na +n/0:+ڳpM|gܢ|}+o,i)Hq{z^{nS"p +Ď+ ,16b BĶq"-_@G>WgXOC[lٱD<ڬ`ogP* Oq{88>&Qkci +w7t%ۦK +iBTG߁8B~dh_6uɯ+WGSl<9r%c- LU=uo-Dž+l?o2t! $6X?HI+ +XG~!we +i o v` + Z}yKA?>LnYL}qhI毂 'D/'SbV[!y`<VOߔժz:jNm)~;S S?i`v#ho#Kw;@_SD7賣8m9MuC}حΆc!/ݗei(Y8o-f82RaAkJ~~q8HgXb#F ZaTv]9C@dŽ=ԥGȕő͎xibCeP7tT[j/ 7v r68o}'xi3kK:]6#p,sT%Dm 9$롤*LJw-l?;441ۇ6c#-ѾLG/e-DR%F [ +1ND;91xSc׼4^AdJL3$0AA) Qle`FZК:[hsKy߅s7k."Bdoyit5vy=|8ysޝ|6͘s x)1Zr;1]jWT+:zb_@&2+9@W{EmGg90#ؼ +WMFyC<;)DZ 3PZtv_ZC @O$.9mcSkqUcQN4ȑ-.rآjC;?5gY+5$:7n?؃OST[S3Dq?/hqvN +# 2�8rq.yD tBS?ɂ?+2K[mOo"9&mYF+I>8ɿ0TrmwMG['GBtlQO�q<mOA"_[4nľxm0mf]AAmEMK󙟒 ?qȌ]{ ]cht2ǀF! ;ޝZAvϹ&W%î>&9}"g1:" .* I$x[{x{fn̴A싀 Q;PL8^A` Bm/ 򏒗/H j:f=蓁/T +4:XxO nQv\le$Ȇ(mVꚯZ#�~Gq`{;a FtIQp|$uz͗e"SzmwklM=`*S5{fa<R{0`ߤ~O of"iejzs,K�u endstream endobj 125 0 obj <</Filter[/FlateDecode]/Length 3898>>stream +HyPWqcMyTbb\]Mvct&1!^ ]#rPACr  03DPQAe+^AR٪c?w'{y_կ~y?~x %x3Mܬ},GNQ<Bj?"'&P(JG>6%t2Asfی"0f +TFb#{>N )vm \,Dpǰa_{zhHa]e)_ƼrtOs#5 u̯,if<]"_~Q>5(R(M&^cLaKe荏hn½$2E;gs5<G_)jmOʟ1K_nWe/rIѐK$sOVK݁Y8{GȱIy-[H?_)E=�Ѷv\!lqa|} >,v] $?�kT)0l:rK=N?jJ8.;U +d%qa0}&�|AҨi,WN4|1X?eu;^>1Y:>T帊}/0֨ju! K҄bԑ%΀D?U%PUo0PR<O 8w#gk8ǰS Ǘ//wo'1p(Dzd,1+CzR +Oa_ɺ/3v?6|H(R]GP~h^QAG: +qX߿- bב R ] u#6zN*UuZꛎ?Io3 u'))v ҂ )P1>t:F:NXvvy>{ ĮRItG +vq;4~iAa(YpVم`><;<WK?lsqQ⨮vvAa L{K:)ZwXub׌@0#fJP6':ҠԷŮA !W{92rgaMaKe_;rk`N,>% ӄ;7zRcPtχ[@╆ӊ: ֢7&^!z 3f?F~Z)Օ]e.|ĮA !Wrj˷<+ c9[=Ku`)98<�X=4wu-}�|GؑCXߓQ5'T6S̝BBÊ4 (/VB)9|-:}[:/YKk{\0X:AEvGN56dl5'}yRKwtz[HqzO[cĮA !G"~MNhtbM,ٿbv:ʛX׃? 6JZ[s3rtps@aqr"tŮA !GHaKe؀[+M 4j/حxXCu=Qmښ=ѲOܤ9<j#>= c'=%s6T1[bf{P":Mnr<7o&Co2ibv +sqfQm,Z ͎j%8{ {_0ŚQFU-ʈ^%m9ާ$a5⾌_Ud~ch=n.>X Y&w@-&#uQm·|7|(G#GP)kE(뾚545C^C5ʆ +46x!H$p^Е'Ze1{Oŷ&MhT+@2 +glV=7b_Y h{˱#U\%yzeYl .ؚVr<?l9&iw%Q[~ݥHegp ̊@;˒ބՖ%\IL]r.ol+9=P~hE߄m&^hOT06J +|jV筁 Loi`eTN7r (6GȩO#=hrQ.|lQ6Bp R؛8:#8u4,=1Yp> '4jsۤ+w5y,[ԳTerZ[-?y«8[uF|meo"r0OJa涅%uf֟@ۊ_ۦD첬+KWW~B\Ee·?ouAw@xӅ}*]7W6OudQ-M-&#cBjlL}%ilؖkC/HTt[@qfA`a岳gإ"!X[K-J@>u{5К͞09;0G?XnN6>WG~9q?Hm4r +GBPOx$xJ4i1ͥ7\ɸ6kdHj_='Tm٫W>9ߠ}G3Mlю7&R9/9>U[ȵ^)}ˉCQ3럿ZN^z@ K9Y]rUƵf^P.ј 1σI?bZ$pco]<o?~`5T<EϱJ*?v7i#JȸCN[+C4'`O|9\vP0K4Oq>}=#&`+k>0@9NROd= kg'AN`{Wѹ Qv .mIUYZG5wLLճŻШ9a4Vo1~+7/ςI_bZ$pxn "9knGfzU!^0 +{uEQ5BE#YēlW&Q?ˉ}_͇Md-^1ükGPyߎ>k= #+Xq }`zJ5S/cl7m4sԈ]"<7b:XA9ύu?R=>߬p11T^^&QnÃA׺Ax>&k?@x_v m1k;xQʝ8ϻn3qP2s>4 +4ԍew_A +^iss޺kAꑂDd|]*2?$bZ P88w,9CĴRt,]:F@O"]%WZL"#T Fqi_]_0y{ްjf?Jpn?~߶u0I({�rԊ2>9ɐzث_˳V#?Boƶte£Iޫe9@ZG}o@SG2@, Q]cb; W;}?Xшv2,8%{�pY\ endstream endobj 126 0 obj <</Filter[/FlateDecode]/Length 2494>>stream +H PTJb'tӆ6)Dq@Q BEFV OAX .wr>].c(R+D1ɤNt:6s{?+uG 8?a{9ߞs8idic4Mz 3kkE /5rI;Ws}yns ۣh=5y8|֛Ȣ=1[iޱfӮ4kª3*+̨(6Wвd8u6鬰hlLc?TlKf&wc_&XC_*={5רZw:'S]~9+ +-UJs}F:Ȗ9K,PLCŮ-/OMhk[ܪw9zq A]$ !h0/"+Ddi<)&~q?Ag2ICBEB3~dُE.yKd#SD^!t/E]sdxR\?D"V9Swwqwʪm ({9x_+ʢm^+D&{KlwƏ7* M ߿W/>[-\tnn_z?@"{uw}ypx3u`KQs/2UsVm'|HdW<{?TjQstWwR6<i \no߯M <:C%8Qj=M$aބ%ڵFĨsf93}w}8KsrKo+5]G%xI=hA)k<`y)58V;Pl +:#R\?G%fC +^h,=F`IE9^ Nj45-߭YN_L2P+Z f8DZ_!؏hA�1CoR9'y/_<䘔y;L^m1Z2v}d: ?؈9.3*dѮ/RLܱgq꼏isIU[k42W!ޝc{Ja%hѮ+ 4 0bpgАM;%7ͰЮ+8R W/aͺ6!W?oʰslO:_>zMdy+i-OʫM9Ю)8R?W烤6Xĵ/a{-*0JD̢^K,wQUzDSө%ynEyF-tN"z-~`X9α4Ԝ]&1K!`d.*AUVN?d +@!knghAFJA@܅Y,xxV+ Vt9Kv2TzRb֎&[!ri']m_hA)q'Ag퍸yFPZ9~b!P3`R_v^M#a."G6u]rS5k # $`4SG}!UCt5L9ݵ#i +Ah1o摍{;ھ!fl*i5#`?]+y?0R +xO'*vO7%eC?DNkRӍ¸iAhX7Y\]+릺(Tm"c{`}vQAH); ;rt?fmWa-m,O@.*lc7d=9qL; FJA@ܝ ܢu=iW _P:/]q54`}xMA?ڼF4lܬ6zQ< )c#gt3jBP9>z-Հu+iI^2\VB*WZ ȓR?�gpEۍ[ȝ]*[?!uTc"fQ*>J _jX<QBTCFl=5@# Rc,jtp&RW B@BA^O&#sIaV[_G}:⵵r_jHʠGY@IN<q#@R?)2!ZY;+ _P<s czf\YK}.z X?ɡ?XD"k?rEhy-mխ:c/BۥjE# R惤1YV\5Ƈ9"AX3Nڎehb`ΤԔ-ύyȏA X7>֑muuBi<}=0##zxmg7@*;{cD# g#�Tċ endstream endobj 127 0 obj <</Filter[/FlateDecode]/Length 955>>stream +HKQFl%(nJ.ʊ(1h_\ZƢ4@lꢈR34b4Ǚw|m([L** P5_9BŌ酽s0̙ s})$ٝn*ZXkxa=7;/cU=="{y>!>ksKӖ_̍Ydo!D`_2[y{ ~<x?㊱͸`Sfd輪 x9h5U-B`fdɉI},nEZjBty<h߫(8{τqyϹWcLȿӸ@ևfM3!2;"7v\j#bNU?g���91A%3��ܘנ��@nkP �� 75~��TB?��ȍy *��Ƽ���rc^$0׮gu/ Օy;w~��d$2oW廲l j}2u3�� #ﹳיm#}ӠSu>v`0ȨRg5vqH%:Yev:a uf^ed:B}=wv~b#~pf2v~gzz953tgH׃L}XY}X? X_U++d6l4\eܹRYA6.Y9>?S5uV5dyǺi 5grsG7bb~ў:kvŝE4Q7V{ ԘPgB,41  nj5mҟ955]G]{ԉ"> !Bs &lT{k״ƍΚm$'&B!D`�4 endstream endobj 128 0 obj <</Filter[/FlateDecode]/Length 2351>>stream +HSS\rQWuEV@ˢ"U\ĵ.e D";* P;zN?z D&13sƜ7q>^ˉ-q }/ c�~R5b=J$o*-f �����\ϡ Ui|P:V$9P|GQKcRG�����%uS"3+FLoƗ}.EiN.������������������\'1YeEذQplxqV,%!e,rY"IW=j0f_/5\E]mrKw1*\^wO쳿j\b3;L}>cH=g|Ĥ{v>=i\dZ>/- u_TY9&y~F?>ZCk>|ضm()oE.TW<1r"xvG{5|B.ֹ!}]~ַ%A4ZMy^guq.}[mǔ +| W WEjJJi'[-O?desl;K6ӖyصP#vUϤ/zD_|1񥾵鈣ꅙFJ`/<d ">zNT>mDlP>đ8->\#;UzB=bg&f}Ϧ_cgK=+j-c:uL{dZTWZ7oTZԏ}1MS^+̜ؿ313</7ƫ{y[1b}C{V}x}*ԫTWkyk=2vI70ڏ׮Xɬڣ/+NL~FqllxvxW 35,m6dtOZOwe<mk#ʂ92]$+<&~FQW<b=_0W ڿEoOOƒG(?>uB,}?6 +YgyvG{uRlRYQ_/vyIF1YG AiN.爺`nLX <#S!zgr8ceZ;!kdkS\ƟT 4_;d:= +GVJ*e=%6YM W-u1L}>(sGz6vwĤnlx*a2w2 [ + C^ t'q ٩l\V@:4?l!cװ*$OKkyƆw5PE?Spd",<7FE<Nʅ9|R BGN5Jz<2,\Jsr9Gsc2^YeE";:麇c&Ƒk2ȯl5/֬Ъ{9/GVJ*e=%6yU,mب}dja.uɾ=f6܉Fˉ{z|G|mMrDY0G?s$(jGLfKT]WDH!cTedV,]gh</3tb&\[uJ$lsLuv.vG{uR=*+}兌W c|MjJJX`.Ll>lE"v~lxv9>TEkƨh;m6=)sg#$ތ+g*B'?/8ƯO|)Q̞!slxN1:#G},co}P鿣yّ{[zB=c$/Z(3m?{իݛ=d켂R1Ã*o)SoOOa ;�__w{կQjc۶+ysQG,x$+%uS@??VQ,2wj; `=/?@g:h2鞮y^^œA ؈IݠN3p2BI&}cˇ|Umj<PY_yљZ~ĉ :л{[esHEa/<d7oTcqk~/-/{::NSxvwj>gFNCN<=zaꔥ$$:,xC1:Lu,\41/2,ZѨAE] ԁLd|<;Ì7Zz{Oۚd3_.1vg{ W?1ijX +]?(Vu{g~/ƒE��������������_� endstream endobj 129 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 130 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 131 0 obj <</Filter[/FlateDecode]/Length 331>>stream +HA0DA +38_T균|������������������������������|ku +a0c0+;} ?kɰVY[K}_2^,v7rci[<9Dzɑ}odv7}\k4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk|!�rrq� endstream endobj 132 0 obj <</Filter[/FlateDecode]/Length 662>>stream +HN@Qj҈@ wcH"y{{c#9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭce?Kol{F|w}|O?ߓG>^E|7b{!1|8#nMȎ -G2?\/y :q}%\>0Lq~ Js^>/ף~x1o1}9՟!ckcEK?:@R^ Ewt!H5d pBOS S#CGDN 952tDT<DdL=MmLc.L=Oub.L=Q}Lb.L=Sa.L=ULa.m СAƎ;thhhСA6Uʮԝ];SsW+{Rw枯VLͽ@Hݙ{jّ_ZvΌ @솝|Z ;36x$3l8ܕpW&c+s}V8ËFl6רͺ33SmFqjuI˾Jl}$_>/#`�J} endstream endobj 133 0 obj <</Filter[/FlateDecode]/Length 868>>stream +HKTa5*.PQdwlQEeTVZv6g3EKUPmZyaW-zoq0�V;?v%u*0{êғfl׷[M���0@磛tPIx5x4Io��aO% T9M/X(= ��@kK, +hn* 9wfJ��ڡ],m>?uz14T^Z* bcx� hXlgTF~iO.�zys�ҺDGTQz�=]9VkY� mcU zr&? +;nZccPWݝWw�Y^F@5U[`?[Bz� \4,�$_2ts&j"#|V9/;'Fz�ܻ\'�$ΎﱅwD}p=# ~j/8SGI� 2mF@%5^Jo_Yw�$ơz*M/�"1}�oʽM(ZT8�hfYrw{ �3ϑ͎T$PQV}"~Qz��VvmͶV?h(4&֏��ę{2a2`}1*9uwTz��NjodhwMK��ɓ׍`f=u[_}ߥ��dzv3U&.J��G]faǿ#�0 endstream endobj 134 0 obj <</Filter[/FlateDecode]/Length 779>>stream +HQn0 =q-ɤ5 +חdzܦv(C�4= (c3 zp[1N!43>ޟr ݌|4t3@~^du|b7.u*$ȓP�>My['+S+XٻeL)QM1LҨ1 +L/8S8GԘB{g@3A*L֪$(GsTz$A1v()(Z{SzEIA/,Xɤ6K>`gқU,`Kz^Jr[Y rlPfq2AIA/m{+-Ozisۓ[ t1'e9@/-vs +(4/QjyoM"ߘLc8&Hb8HzPqKPqKB㔸Lb9Pz+%q咺C/Vziщf.x>VWYVxPW`TpQ;Tb-nfC߳k=cZZJD#dzm"rh�U.`܇>GD* rLBu7υ}#` eg,g XVfx�bL\n-n?a;/LOڮg>_O?"} +SƶS=ۦU°V]R=۪ Vں-�) endstream endobj 135 0 obj <</Filter[/FlateDecode]/Length 615>>stream +HQN\QP2#X>+hו?^~۩Za??`?Vzyyyhg`?A?yy\Tz韹3Kٹ"`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:Kѵb~*9Vt<n�'G�l#�sW�[g;ߥPQ^K/|w)3S'‡ )  +`Q?v?+:lGcEMB>%^�#$7 endstream endobj 136 0 obj <</Filter[/FlateDecode]/Length 590>>stream +HAJCQQ"D"ESHdɥ7K~C:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XT}^JcW҃Eե`QA?u})W\ ХC7~|+k3x#{!on}<["Vn#4A#4 +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3z'y`�= endstream endobj 137 0 obj <</Filter[/FlateDecode]/Length 596>>stream +HױJ-AQG.6MvT< zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*tW6;ǩZa˿r^I{W>_v<+:lWSɱæqov^9.|z§ +<P<~BzqpWSѵbÖ縔+2hA:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}Fv]�2 endstream endobj 138 0 obj <</Filter[/FlateDecode]/Length 658>>stream +HN@CO/!m*$;fy@E<xw4wC+Vu/s ^Zq׽=0{{`h]2ЊewC+Vu/s ^Zq׽=0{{`h]2ЊewC+Vu/K<32%v-Ȕص3#SbόL]K<32%v-Ȕص3#SbόL!]4h#kEFS>`?7r~?ُ&ɏr~<_p+G 킛_1NeA؏ɏr~m.۟?݃＜p?`?g]a?`cm|2䬀Z*z��q<j-{W^?ٯeşq]g&WY|MsogUY&g֟^&ޏM0v?ꃿ1 7c^wz~N ns?, cOu5#_\vq/P:2V%|s7G[6Gnwӆ<W?C<_tg_|CB&xo۝U::}'| +h�����������������������������p�1 1 endstream endobj 139 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HAo0�|J8mWJ9 :,HС4 I;|~~#����������x:"od&Ύ7mNIgfQMu_auc?6tYQiCj/<m_}Wrzm{ؠߗ>͋"]_f2}?uB I(o<9zcA6nC4'ϳ,<A')Lb mC/0g,dm8:$%ݙ8 ًA{3d}?-����������������������������������������������������o�tV_ endstream endobj 140 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 141 0 obj <</Filter[/FlateDecode]/Length 295>>stream +H׽+_ ؄EX- +gpJ&]uI.SWd9v/P_z;| ���������������������������������������������4Ԩ\4m񢸹v��-ӣcc^ϝ&WsmdOm��@tt&}깐9 ��Sw!��QU4*ׯ#eE>X,<�� Bn +\Zj\67;>~vH(=v��%�1B endstream endobj 142 0 obj <</Filter[/FlateDecode]/Length 570>>stream +HMKQWP. "uHEЦAk6ɴHD"H* +p0fQ.'~GsIp!s8F /<7) +ܷƧ۷n>vH8?@^ ��H̗zg.*W'.v{2~+ !,aO Z +TwB#""""q'mf/Om9?3z|Q=_iXi$ƫ7;bbbƲ9=-kaoX l3^?zxvsk_{wi\tsKږ>vYfsNa;sO4narRuㅉ̾==Kgyp ]ܛ]ZcKkS[==Kgyp W߳q9}fr\+8>3vl_#% �7)g�H>�;FJ� n5R��q}�}3�@kD�f_#% �7)g�H>�;FJW� endstream endobj 143 0 obj <</Filter[/FlateDecode]/Length 199>>stream +H1@�754 582M \s�ny>¿3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�k,3�@=�|y 0� endstream endobj 144 0 obj <</Filter[/FlateDecode]/Length 19266>>stream +HWn8~G7Q$v3;i&AXE;ڑ%WCҖ=mkD9߹R/vs{Tݽ9g /^dc_^64%|s�J.rCݵ嘥~Uoì{}u<]=6xeY˻/v`zD1 G= 3ɀvS[&>]"#H܉~c0 N@XJ@E,Y0c˻մ5xw+3 YtpfO 8:|g{ F~?)vS_ +ߘژT L.i1$&5$tNuS̔dt/pѾ[X^nrkbC0ջ|kWgnw&ܙtSp=tsaAAP"cʐyci<^%x#0=Ԙm[ۄ;7OUWF\_rwߘZkѵ<X \L{|</+ J i))HoL߱+۱Z΃1U:_n/%"7JE'],i@eW'}W`hR v#BZMq@|Ї�mzфJT36VFBѠ#4AXCӆK֍S:(7N2@ƋQ3^}1 1Sc;N݌+N:fl7ӣ +4 hM(}1#f`@b꾁,nc +È`Wnm}-n%=<3in#|2-N/pgWkVSc 6Ȫ{ljֽBw+݀,-]_٘mgz<|&`;+_dlG:#m.!uȐb:HĪX6h1or!}{e;]e`fC7 "JNZ8yO|gsOͥ_ k>w#zS5o=HBlmnt?m=|4w�`K7v٫E\~~/(7`߰v&xOb! ȦI7QݮaO';`½ onDc^u:]5`LԠqKfÀ(`*M%ށJ4p$w2?L1pa nOY"ܟc>ts@q*yLzw]wK`t}_tpoS=wg_U'ZoBa<<-5\ŎZMNWo}[M[hG5RÑx!GGGw( }f+w܀a.nm}+{ôYY=Q-ǰq'KK{Y_[�揬=pQz3ْ?F^=ltB#y՘'mf}n߲s|(vVs:cϿ2| �p^l b8v,l SiWz2WKrxŎ gyp"CNy|Q}Wp?~=^*y:(>cGj+g8. &PH_s1p*d$'))RhD9&4iAKa11b&d%,eYG$Gq$QEIFYGETs)g<\pOx31ILcG1X2Vqqq "`"\BB +%LĒH*$/Wd"S\TXES*VBITR\ &,ĉHd$I,ɓ")S,RƩHe$M,"-3f,2ř2,,$9ˣq.rPdI@/ bO +'RN|g3V%DU@lĘB +"w Cq 2B%䧀,e*S;H/dC6#H,ĢT BO UC}(ԉPWM?2!(. X- 0;A&d^%[r&BmI)U*]= vco]] bQuF�)P +ģLʥBє(Tv5|jjU â #k(ڠl=ס(QҠL9/(oQ2�*‚)`A=51IM +l%RSrT\"k8%HNɒTXf]TpށE KE]v1ʸ8s(}y,`3@:W k:EsP6 3]AJz*iJfJ2D*ITNI2MT)iRRV %9ԢDI&J(Ϥ>I{<*;P9IqdZ&LM"Y]&md]IBMr$IIzCѺhX0t<j}`~)L/^[3XrL$vBoC+N3"\n&n&n&w2q6N(Wk#wjfnm4J(QD5KPK&Jy'"R[RZJ*@dEKe+yB,]vz~IŽ"26 J$f5M%m5IFMopqV@Ss)v*w*xU==>ď%`G-IFiCWp ɣÜp CF?ˈ3aK +5y +r~7 V]^6WXv9WbG7ZGrӿ`r28kLo +ȭ_8m\&,!.W law�kP>8) +ὼCRG>.=^Woo^nN'^yҜm?_.׷[6Kf]0<?oD|y:?/O?/gY#6GsU͢bCrvJ;Wώ6)?mc͆3iygmLڱu{拔0Z6.猁sܒ6bp>G@{@:ڎAcH]2Xy & MMxiuz`T1+% Rhj=2hh4 ٳL5&΂MJ;Zf1?C$…\ڊѥ1݆DKČ!cɍdoԔ VY u1aFg0Mf,:bX`(W@QH33kW2lɿ>sϐw9WstH4+I1Ta]1**"&"P3Ƒ/,qH$rTJes\=N\*N +7beԢd5J.Bn*.TC&Tzu 0ѫ7L:}RZ=47""CHzE:~ElMj)dP?G=cU{$Vi^T')x]%-jN r9Oq2:V9PRzTJO)$hY,3YCFg/cX`6CY<SB w=d񡞸=xw.1 h4~EpD%R>š0ؽHC|Zs|vZQ#]w7ƍkqǟ">=K'ӧө߽ק۷C?oߞ kLky?pS +_p/;vyh|xؕK7ݲz~ç|` '#eZ嘄$!,"1-ќ$)M(E)8P$rPJAfN@?OɡusrƱ75M54hidq0 KdrY4X%0t$# G˘bd(!3CÄZ~C;NFkZD`FWGKMÔFqGzE.*hB]ZMEjBBX] NEVlĆe 0c8$ +nz)yYeu[l7绌Hz'YRڛl<wUc"$Z<ơz,Ȍ0zrDG9 e[f(0X-uhĒؓa?[lwrQ,jDҁ$-Ҁ45SD%TH;Y=#i`-h"fRj�e=@a *P4#ݣ"F%#GFhEfxXE=B\zt87b={P BTCTB͌+k߃1r {5AMU;Ճ]rl#ZAKKhjQd�`!dSfDn`;GP|, ԿFO#bSc3B0)ѼLr޷sMMWuX)r}<\O~}m7g_i,P`OP-!WoAH+!['npC+/^7;>g'pr'G<1\'kXd$& e1[YZh5%hMuMc!͈tkBpt 0 +#Nz~ 99܀>}%dp"SA@S$-ȡ0boY#Kb kjmjj9am3YpJs6qs1 ,8S"L02h.D2l(SD5(jT԰q102jh ]N1*r3ZҖz x3֐zuoo:y ?-m|vur~mxr5W@3_m;rF 1Ǚc%(0@,61 >HfOOv)h5]Ӭ:dթ*ށ/.* .6+q%2)l,Z+7Q+׮Wh_zN%<VP0}LcEҼl2&4eӜqNLIOdfINI瘄Zej4 p1Ɣ4b$O1/3䄘}i11M*P;TǪJ5ZD+J*:yJOܳ+ݏOW|U./ l0-FyɂWFfyp +AS {OC^TLwtI#�9'9+R)wXIܑp[҆QBAb@lND'ӇP=@]�!h*NbTHl Eb6;?TQO\י?${lu3QR+-/7<nwVznSmoZ[kMR?;~j;3vmku<ucۖD0ҧ4aiJ =MZ{MB eȏ;؃9h|*"^9R;C1DqF5M{("\rBY<$<MC}Cbw_ٟ w${{-xM-K/pwR=wsbh~p 'Ş!T[�jY׭Aѿ$DXbΐxFI(DR#Vf)5Tj6hz<LrwiM.KթgNKRmԃJυiys}΋N]='qEHSD)^qswUU*~?EJ f#ܸ> iTJv~rFSpr8N%!I#Ztb,SS= U&c⹧┘h +)3z& C"KDdR /D]h`M,T+ +fVL2:;'zS3ؘy@iut[քӖo+6tFjӚk"MM̲gQ7O_Ĺs&bJ:O)r^ʞ+W˰c\s\Vm՞+~_ٗ`Bn�%'U付YɶvU+~XOiK./C9&&÷Mms~ftɕǎg˓Ն9Kqo4m]~WnB_~[/}ᧇ_fկο|Ç?`XLJ7 2,:M(c*^_ן4wb~I[O|,CR|U@_]%3j>Y"J E-hqtG#W<;ڋH{/B9+XHTTi<Úw +Xt\b䢽 jPX,isRι{P  t7=o +j2$8R;{}}=k-Dѳr95z&.YU7ZID/{jG }@Ȑ8c\zHKı]X2"eAǒq0�JHtB\5**¯bk1**L$81JrӒSaq +b +[@^(C}`@6Su (P|_6jhL=YZwb.db@AQ}զD_T$S^Z 7{A j01V,՞KnA\(9#x~\}lmO,u븟q/1('x-sfЋPAm [uSmwF}nn & +q7Kt^s(Bp + 5s +1s3sX XQ{?UWu̸ǎ} !Bb + +x>jSdUqK f/frUW6Yg# T`3gcds>7ZTUaN5QUtcj*Ht |11-M$^auHM["0FvCD1B-WZ,vX[yXjb Aкb0c 8)ъ1`RθAmi)"CW)F8* +D9h3p O$xTx X.B<!R-Fh<}Gub@qq)ıcH}Gok{L=ۻi:m/kYnӫ_闐9Ͽ?\f$4}DJ׿K|O_~'7 {έ,]fpm"K{;l5eTW_7h,ujv5ve42.yAhnO]o,7FKqAsiY# u1r)J*N1Df7;bSLʍSbw贪 0Nj~g㎺GSh5~][L.ǏOuY((l㩡YT}J�w͈&mߡ qnM:s1:u3Fޕ%*$zQW#٩_4fS7֩W[jFvNi4jM3-^YoFvԃSp7jqn Mތol{Mތ4,Ȱqj㴩W֛`ڰW֛)(+7<aƚӦ^ՍfdGv1GP+#_WM^7<Am uo)Euư$>?{?|Riu?iG%:ϯmKR#̟kq\P_98P*@9 �ȿP'f"`T|�'|g7֒�qve!XF?{AuEU[뮾 +z ϋصϰzק(O&G7Ap(E]O$@4,^AGb mq<zoԻ a2֕=%qpx .I& 7Kƭo_ƤxYe2 Fr�`5{ÑpN8sQu!tݔk!<a)DMCA,^1}fynUłL0AsGø]x ȼ2,UɇC]j_0rSA0Vz!Ɏ Cܽ@P!8|6W{e�)Aq +'#dܖ -B{vc<,L<~�WS#ztH2IgRf=X#D +K+Ǎ:=9EwӜ@ jg_$an %*k�P,q-XuqkKeYS<T.r%[+p�< Nˌ�űcSu%84Rel92{M�#Δ 5JwDhG%P09$Ƒ=<Pº'AH sI7~\Q`LL]]o|k^2 3Ks/�Fj̧=W2X +ecGRǾl +K}�!FO_x"镟3bָkYzyRE{6ܛ0X Wd~ݪ+%KB$8vQoLE.b1dYx5yúmu_5Bʠ>zC,lW.$ǦT/lჾfG5c,1t>M^av.:>f9!z?~u[kNS͠�Lgfj[{08$H ^Eb`ׄKLy0FnjemHpF8` xfYtWHsoCrj$G2Ln8G(sg9H̝צ}Ri14|PU8s5)Q0/q{z0==Y(ε NC^`n>Z52M. O߼7}Jb&63~S׍D +5>B`L!Q5=Ȗ/eNeCs'ՊB d +/8t_} + j>VRYL:Nv Vj  =~;7k ^ZIg{_1sQا# P֥ƾ}�3`ⷦ*ͣ {sx .w`BkVV)O9jc93G)7'%7 +dz\VE$ +zCr(`�Yע+DSH&:HOc0:?S??vxA~ݑIzG*z +i N +bMq׊hW@]1b%+�`]j&Bz1i9Ƣxc�g,)=7E6~N O^b!ħ P�AZ66s.Lbh2GЧ]n#XUq1dAY.MvZ0Ďv">Ȇv"#6&vSdśgL9Bψ>U`\8Gu.k*K  P|_SڏIk/')c9cnAؗji5so{ǜmW^Ha| n@TcKn _QA@=B.=;B +\T9*ϩaŘ̌ +˞,? BIJ,4|k--Qin' cr` v 05hpIGß]uҫ@&=@hQ6Ip#I)uA$cRF`R#<UcG[ơު+ |X>5mqMU(Ju[iVh.neoçhVG>vs4| ÐR?r >$(CA +z{ +'ߘq=)c/I&`Z ` z! ;UG4[4t{ OahϷ/-w5�€Y,`=�:L{htGh1|0(@b%Ɯt�;k3`4SM#qΠ쮘?xe`Ju@}N{ߐ )-}`i崏"?x@,MiA̪w)nH$ j$@ /`4Ԗػw@{t,u'�f>;cb68q kYދ�4꧘*#}'Mke/u6_r)'ICrqy'h=ڶ)8\QVJ}^G9jK{&]:@ &$oC8)|R狀HhْG*y{gpTqt4,xMK6oyheUk/OUo7o̶ +P$ә|/MjRA-S*a+3='jÑ!cOAb|~hz}iv JZ%\`-f `ZC(Wq2.e=Ek$wsta#/J \f\޳5>&"Ǻ_T7=;q-AXps}lYV +`+OΓjO ፠X3hbԬ:֮˸2F� CQ `ݔCeK+_|+ٔ Y{Ia|րkKk]&A +tq8(HQ7ׄkYd 7a`]Stfv]tvLz5>WcUgba, Y dko.jZ[ӷEؕ äzݸvZҼ&>=11�SuWnnЏB'w<UKoΣI)Ɗwl k疛zp6mS4ڹ)ʽOF7>*7v"͢u@k94oi5nw1KTCO~wh [ľQN;3SLys!&nǴ)෼=Dڳ Wz RC ^[4 ~3˽g_ e&ȠLQ#G.' 3q֞p;K| R'h^*Y|f-[v Ah0?1J"L\h(!]н힑Or^2918Fvtu=܋국<F ;L_g<] +cg2sfiV>w58dW(,7mco'HtPL YsP†Ĕ%l>*%<ul=\Q|,WWIk[k˽!;Q)[¤u]fH T֦_)(YB4/SW 6ǰ[q:8HÌ]V_|T狙Ŷ ,LoȂ0>~nw5sg,8ČЪ­ryܻZ+3vqYm4CMs=Ƹ8)O'A0{õgF7Mw[onr'ZeO^0ٞb[[4ɪ]5*6O%d1#phުڭܷZ2 |_'o?;SB llEte;i<hڟ?Y$/)]x(/~lf:9Ehh9m ilt04X+ڷ=<|z%ch +!}V7ez櫅W L27\P*}7n1<^Ye",7LNu1|*^^Hs9*o~~%Z4QҏւQ6ϊ/]]�^8Ê%ap[5?{^b{%,-)"\-y�xfYl xnBWAS<[TCg<G iu]S\f<`FZӘks$4$ 3]@ ,n UjzIxsRuY.� #{ֲ+( (®,4#9b'I\8I4|\ˣFb{nV|uۜ`Np3;n{(kȀ\*td4,H剖uõ0z#Q^k-BGt,'X"t1\jv%kB֫�Ak+2�] 򙉫2HJtC1J= +x{^&IkCQ}O*~*|5(d+ ]9(F؈\VN{V+D "N]/y Tly(M&sm{I5}#syYJ/Lb+0e/J2%YH@ASH +n/0XG +˾qKYNw-.wŵ0%- ܀n'cp̜{o`, FƋIugX꣫mG!m2h8EL&!};9 >cp)¹􈸬U{IU|WyC &FClm0qkJ1JwG:83jaxFy lu^2IK<vn[* Wx N}wDAr_c u%Q˵9eol*Qsy؛2{u{t2AVmv?;]kv Xz/k9vK]z�#'-l1 W_Q#:onGNV& + �3sn맿ۯy sA}?k*[:ڎr+H"1Xy!kԆ96�PW>~+&J3(!˥=m#_^pp  i-Z9?4 ʯM'y^8:`L5+6Q`W1b;r|zώ AM_pkigx<W%gPGFAK*ރ3W>dp +輹Hhud N$-]-Iv0OHr.Teodw{{5F(~�^#a ]5¨P|_cNR*XQ}`^)v\/}WRri\.sN 3cpXh/ @7<M$i)>B:Ѯ@'e Uu{KR [x>U$]}J9jgw־|h()*}L˼t7&+beuȼ 3*4e"=% #z_ �<1@+9eor-=joQ$Q;>1hL- 'AHQi8-_=ٗ+M6xFsQkR(c`<~S`}9E +x! w(0ۄCf`页 +#-G_O.>q@Ls1RkؽņsİsY|{9F. A%_vU/Co|Qk_V67+ px^"!1Vz9Kjꀈ ~78d�88 ]QU\H@͏^-wQ Pl͗�` wăisƾձ#s8/y`͗s be0∰ kVR(u>wӻ un`SᮒoQl;e?- +C/xH8_}z/!ISRQ{75\n/^]�=ssMϗA ߐNSX Wreu`ޮSNnh^(!b<=sD&{"~ }{7lhr]Cpws A%!=Ar){lNzU#<63fэ}޶}Da%nRl-FQI^ngAVo5OX\Gaw2*.xӓD#&EF-voz ѯ_ I/ʄ6"(ѾJf[;)vk�XD#* aūǢz!Vc]iƦ#$X�c%#(;Z+ +gn9:%Mc gQ$N9ImĈJTG Q"гF kqsc1�ɣs^ \Y_NE$7`Ng`"ca�pù'|uM8nVqTјQd\]Typqv&KbEQrw@ 39J0OIQe 2~fXb3eO$'(JA�ܴhٰ`wl,";+WV�佳R'܊/vMc>jm_Гw#Bt_n/VS{ +^N].*뀒+* P$C�Ċx9 (ګo% WG:+=bq٨$?-&%G9ͷ9c׍Tx:f֦(m-=!dx{AH<`驈3uKUZ\\.K۱t0}ŏ 5}T4�_HgO?!<1O(eT,�{N ˅ +Niie2074ojabv0ӼhܕF.<#m34Lg ]N M[O:[@r[i5n[-k'̍ D05T^0ٺ ."%H̴9UWpg\w4<-)ݥl(z|vH3mz6PK8`P䚬GA?9zjߑ@ɻ{dc5FcQ,3f1n궅0=qJ"U3aX;0Nly%>+�FwpB[.Rmj+̮ XuG.@PJ6�`15z 4<{f }";C;Whr O82*A�<`TW4bE#UamTCչN3y@8$ACǒ\�+[CBXL/QAwpjy_I#iMR%BV8[`}V⦻ :cUl,{߿{= ;JcAW!'eM$G&g>q#b/6)Yp0)ܾ4֢EvEoS MɖnDd�< .b�>pE~,ᾢ)'4U>].FT =PN*e� \-p Aغ'"[TWuH'� +{%Eّ'V|Bm(Xdd*jj5xԚmD\MZ5`7zzI{ZS +l'HQ:p" ѯ 纄"-9nQ:838"n.lA_/wM֮IFyҀnt4W8/rײY~|5'H.b/a=j%^ex@g 㝚Gؕ~UAsQ'FnFM505@~bvUM +?09 J[<(^aؙjB됣?UˎK $hoCB`93̃cSJn{SJUSZB *WuKvBn OY<vOrvRNw9 nAb\p!8lTg)ٸESZ!RNLya<Jj~'hhiP娤Ƒ;aU"Ra]=*@|^C_5VSYiB +,wS赑ĽÝ:L0tUXo'-b2'^7M ,Nۘ {{ː?Z-VAMEPD'`&|ful0M$ᝯJ|HzI!qZJ|.ʧ/Lڢ3!Go}klO +3ۓB.I79ƗCKlO*msL?AT!vni,o:NF\h+�Pi* ´?B|=c<4>3؈-B?pفȐ h<`w)x) tm='6(s9sRdE&JO`9']9XQ.IOK.O`9']97ȎsҀ%SX.T&KV)3Ac_}Gri;FJ}MXbŢ+Fv OĒbˬPa^ y0 αr(XAzEp6!đ@ʧ�k1:](`ʑŚXMqJ2XY/9DVH,C N)PN3qKKI] MV|ǥU8Tmſroy@Rh r~'<ma9'mIeC-QOYrDG2T�cq�EN5c^ĹdLzo(dp+8fՑ�8#b/>𹺕\|S}{Ơ}tOҼ 84va6t`B + kْ_Sj=EE-wZA\mu`|q>բNcF +�a3OsvUhj +IkLT_%:>y +Hy8F5NI~%7oԍ-몂O˱T(Y~ۄyܞp} Is!ֲondT@od1LKYua'8/f_2gUU6=}4% ;lI0 e^%]a E-.&ޢ+M/L [K Z;x`O삘u >Um`1V!\m]r(@}cΐ5[Z+;T +|8fNXVY2{gh;Jiy;AnG7*P ql16NC.x;y%t!Mߧ93gz3^$Z/8ʤ|f0Ov\2N)D\p g#M�[eg%M_ yIH<^l{[N"D_Æ~ztӊgumK`};T]/LKeh`8=LqmOUP#J[O룝Ր( +q=l8O)[udbyZ_v*v&0Ans^"#ZZ]Ju_N+7$_ZU!s-\Mc`i[GuyMbhZ.T8:<*06q6ľ',98p=ꖼ8ST~AQQL^ "lZJcJǧq -=xG6iL}asbL;f�cz;xIUl kFy'$&t}l)'T>bGsX;\'< ûwgD}_T]B6vpKNY|wwU^Uk+Eb 2'CD(ayK畎Z)`aDžyR.cVqlҊ=,;UUf`]pn뀰IsT# kH֖E#b8m~qIՁEAC0U{/^G}ؗ "N$JǗ3^a囸(P{=- \qi{j6~bo}Hv{f8:R#vZ +'dx59YI��eO &((FL&%[?d7-;F^h`\)eW-5U?+ʔ[@U2Xٲs*=X^}b%\2˽,3:& 0Rs+&d~YKQGe֜-A`oO[Âq` +Av]g$ S"Z彆N+F5cX{ 1X6h6Պ#`N2*W;B DgL$7k6Mh.\bVKKTitB$_0hYI[N!M.sxwtO`VAT%3y!`[yPxpfj `j=GVձO*<ٴ?'¡{Ѱ >(y%¸$Ctw<DwQ.j 4^Qmhok/>?l>W/+/?_? ^?ȷyM 5CLX. mX詫L__fQzOs��0tG@"Dgrm Ķq5e+Y=F09 C0駴 Fo݇>z;J#BѸ 0�b endstream endobj 145 0 obj <</Filter[/FlateDecode]/Length 1439>>stream +HLutrh S4h@=A$֘&`A@�@< сK`If+r[?'>Wpw>^n'!.##E 2Éyכ1:���D_FO;%Ľilo)n&OtuL}`"Jx�LF^.}��j"Va~aaMc{{[.3!jvUR:+;Yn7ict ��hBm5G'dKQZk LS D[Y!WWoRZB"��g5U?@,%5fYk n, _ +إY6`aI[^RIy�^$) 9oQsd RĔfwnw1e-.7Ve�pp]y�^CAL;YLΎ5}u }ǿO]nNy>_E.�8f2=x�^GNj]Fa?@,r{σI>$gO<Q9rޏ�@GΜo��3驶u}SckQzds/g?&NIkgC +7Iz�8 >ݻ#1��X}nQ_hk pLtvn^Ȗ,�Zk?�YhCPB@Y돔_}"yvn󤱫D`ˆT*����]iK,AYśLߧqscF[D%tV%G+G���pOi +-JcCX}'R"/x���J6k<kh^�ѳlj,3n n,GH>���X zU8.�1?J 9;vθQRN $ ' ���=ܹD_�g`KdݳjJ54-!}‰ ���NnkC,!z5!pGbYxJTźd"s=x���pByK%]lmy߾?_=̻!ऍ_C +7Iy���p=،J؞)0-آ] 3:JJ#?xCpZ5 XEys��$smT.l7hZ &u5e=˼NƮq& &Rp3]u�0SJz!Oj8 [㝦JUQ7�m`׉TͮJJUBWՂ("t�f�9ԫj endstream endobj 146 0 obj <</Filter[/FlateDecode]/Length 1047>>stream +HO\egf@ڱ [)̰UvҦ S6ĶF-iK1bK4e_\Ҹtiј1Fc;<7c#<a.x<OBJVg ��`mk��ژ`'3��1Ng���kc^���Ƽ;��y vB?��X~��65 ��`mk��ژ`'3��1Ng���kc^���Ƽ;��y vB?��Xd19`H^=W|LI5#WPlYʌL dCцcn KD%$J7AR$9+IM?G(S?}���;Y~8?z3uF|o^UdC 7?=oOw;7Ý٩nN~׷g&535UgZU-\w;?|kKڧ[<kvӎcJ=y`-hSsKzl =eY.,տ��Xxbs,)YW\rWHJ1ݣ,?(T +$\P(ERUT,%RSZKOJ]EX6+esQsU2sVٽ^lo3MsS'#GK ;:bK-jk[ҽoGo8UY /azN^=>[3r7ν06pn*{\yɱ?e/TѲ*i9Wze~Wjv_ u~a[g6G}c��~ƃR9Jeڲr=E6Le\*_eѰvܼ1:-|_1*ØD{{µ7vw{;:65Ǩ34[gDB]�~UNʼnߗ$+<wJͱcf&>2g㫍ֻ].ioa eHdz`w�`!1NgXܟ � endstream endobj 147 0 obj <</Filter[/FlateDecode]/Length 1162>>stream +HOu8\' 6El&J<Lk"C,]2%{ p8`V[mm?bGCc xs>9{Ƌ_B<@VĮ)⹘MO٭-iltsܶ䘸��ŋ3翳#븟9[EDedS=۳sľWŦ4h<�ְW|\]WLxvW4e#gn6ewPSLd�k Qb66?DGD¼|qܠm;s:QsbI+S˥7T�>5?+vAGm] CBDbtڜEr�|]An[fgr37;ϟ<SYkOgݧ "*<\u<�`_8~¼|tHemLʑg7$(HuD�bkf5 +ݷ_ׅ?�'%.^,)Tg�Ǿo%;m/'* +R�fkVu㚀=iؑ#(1cܵtW +JZ:� FIOLrޗ5 +]rLxqj_ch#BC|?&L+_NEq + Gh:;{ȟγ<7tb��H_w2?m +ew<bZN6nX9Whm:YEn�#Ttfӄ<wwX�U 4MdXx}%3a4.+)/u�Aw[oWY��r0-|=brx2� jUG��Ǩi_OX}W[i5&��Li W%-]u�޾75ST�� +=F?X? n\8mi8^u�U?WDy�x^Omݘ:�`uIWiZ:�)l[okT�gjo WWz9n0v8!*Zu$�j۹?/\k}1,8Xu$� +R nY?橎`m[�  endstream endobj 148 0 obj <</Filter[/FlateDecode]/Length 941>>stream +HOSkSJq #^cPqCW +Í`\PPcZ PUR-G&AtޭaizW.4VI| WVŇ}yғߦc<7 \[HO aKO��,Yߝ滺.cmwјv�� UT}4[g}!XwDz��� ٽ?Uw]Dǥ&sқ���`GF::_{AzUZ8[[;Yz�]}DΆsAN,� 螽v-�9#7ڮS$?4|޺\zvZ +|RRz +�hk[]V$?2jˌr:Jl6cЃ%sJ�-luNcB +_( @bt8P9s�@;}m}F@'һ�$iƈ97)3Sz�h%|\j/4i�"c4hw;[�@=|RL@7PΜ%= @_ =�h}t폼c#ni��eSXn.?P/kD6��Txhh|;~I^tHo��HEH6:M[��Msʞ3ߦdeI��H)Y"Ye<:lˤHbmZw�@2Y4r媲QrcV?�$O 2ӥ�@Ҩa_=F@GCB<-ͥ�$yDZv-�,nc軌N?.XwzۤA/�6 endstream endobj 149 0 obj <</Filter[/FlateDecode]/Length 1015>>stream +Hhub΅-M~`暮` KY0[nt:L؊c+wmnwsnswhpI+lDvws|ˇS).쨾0<dI�lq6k*Wzj{|bE~Zy]߱w@x>�٭b:y)�0UqHEdXtwTW�>ߡ{0UXոMd=^ɣ˖KOYP\yq?`TqOݳB4t̗ ;j24qW[�` +*UhF*U }'d9N�"JS NF$%r6>:4!��t?n~=<Ed>w?q:g��kTϻǦu|���jd9,]<l{sGuN���SEʕjG}?`tXJG;��L㏋kⱡ+v?`Lal-o ��`b/~veÝU/w0"ҼAB)� d\8ҹ2Gi~qT�(,(PHk#Ko�i=[}nr0](iy~R� ~5"�t\oou]i2Ga}JXw�?Ե`u|-� 徼d0R4|2~b[ˤ0Kw}q9� y}ioU0>t>]IfhhtV�fēxNz +�mA? f@SSVFX�ƙEz ;�@nBϬo _G ̤?^lobR� S -VUen_C!\0X~mg*� t8TcK�p?�SL endstream endobj 150 0 obj <</Filter[/FlateDecode]/Length 1493>>stream +HLuρʏfh +%kǐ[D)\9ҘPah14N<~q__GX:S?4Gmckǧ\c={;?{? I"n5!$eAfsvgg–=/̾koMs77= ��� =o^VimCsE B���@ ^ܟj޳*0U +}YQ["y���\b2}-';*l폔�s[T>6���RxMtsC*lGsg%<M黾B���%`s#Xun*lY{7.npu-(J +}v����WG㯓{؀H bckQ7zrhд�"3ۛD,1��&MpPӎ0Cc`{K/pCfK+�ggЮ }� ٹ畇V.oQ; ;mnՉc1 gOd 7we Ǧ"�L!KZ&o(Q��&t2=1rSY[\m&J"+(m{[\.55: AgO,t{6Ҍ`3wEo +�bxVY)+zGs��L$C,;؎^}i9qHF[||aYg4v/�SFI5~f }� 1l6}xYЬV/Ƴ2ܞL[ML/6{ �01$]_\.,��~] +bbҩ/N=t`3Cȫ) #[45B�I<l2Qٲ?UnoJ?N˫ͽ厼�M(��lh?=l(bl᳤àU_u:s:?zo2Jw sW.q @CÄ>�-O;�13iҪ5jk;}>V?d>`Szp4!���pRIJɎ@ _+4ן[Ge3GSY~2V?VY/n/ +���%o +OO~55z'c{twwU+: ۫_靡U?盼J5$���EՆGL[w/?K8/["^GG[\m~xU����'}Wycޅ�gU +2/JGF/º_ƒdު����,Xo ۻ]pF{oᕶT7k/VݔQ:VDQ/8 J 0�l endstream endobj 151 0 obj <</Filter[/FlateDecode]/Length 1325>>stream +HLu)jiSs6(ǦKp5bԡV\+퇄?8Ew<]RٜSH[['a 3=_Os[��ps̗ +c> B޾jwS]K'M_}ͳ zBi DM}@r6&ȿ]}akQ}E��[rNwɽIOݹI4!FLaEjF&83_,>�+,!kmlܶv0;?&P#Gןܥ�ܧ{&(�OWe٣aܛ umzkѥd̴ + ].MY�pCBZ]7e;?=iY:6|</Y]ķ6r:�W52r{4 qzwS]XK`MT ?Y5fN{>WQ�H!h^EAB4{;?woFYdܩ�Z_UǛ>�H~B`R}{q;;?JrD(XPf!gĸQ Yծ>f�ؖ?yS@עKcG35:1Q6ϼ<�"r{/~յg/b?`'VG'Mv_ߙmf V}m�ql}SP} �Cy{iBt[{!g^EA_ KN��Y{ȹX5-̞}Ȫ݊Ģ?wQ;kkd{�� ¼=BtkO^d^ENbI%9"Nl0G=���0ZV<ֵ}ʲĪ?yS@s0kӡ���fV +Su?XSXG'M<Bl)Y��0 {iBRQ鋯C�Ų?dV$_}ַ?zfP���YѽuK;W,)vaS갿Ӥ?f�0h.S$OW1�  {GkYG{?.ENG[Xx}#0~�Wiqm-R}�C@{~QR;GT8W4oILU�ĩ ˙(�YtstAzL(vs=C={نod\82[s�UoU>`�]X endstream endobj 152 0 obj <</Filter[/FlateDecode]/Length 2993>>stream +H TSWH KX ll.� + +E Z+T(uaDź/eZ;֎t̴v:ܹ/@ |#�bPxRUaU�.7ij{`~eR6 /gsݛFyR+#dNWGp}+駼c!\_ + uf2s%[7 =C& 5_+{Gq}/xcs1@5ɘQ}$;` H`ͬ(kjk<! u5ը\A)r4\x\_ + C�gԵ_.ܳ>g(d ї8NneJW(n�AwЬe 2/AkzI_Hם[| =/uӁcɆ[ H?bӆI +/A1nvԺ훛w $?f.g7U#!_=AAighDžifn[f !^ Mu7>9vRW,-  jFkǣx#k\ F#i_?e9B ^ khmֆP|vW2?o]]yMy~ sn3ߏms`lg172 3{ Z˨< EjsE +SeSF,@Viyq;iFa)3y% bwn xDr95<B=>\ƃspRc7Čg +~N` a.`h  �)ăBƃo$ K0� #rPj|7^m OkE)`!LBuKx)ܝ?y~Mg]Locy:MHub#2!??F]FcnD0?c^ Q޽,gGM#<ؖ4̉Ø%C̝CGeoYG5䋣jr-+"{cPllk(8|kF6r5sx![=g%O3G lyM�RH x~sbaGs^(4 c]F p{̜p0j!bٚkN`)3v&`$}gb|w<L s0+ `g�?n'TC '=3?\뢪 #M_a�yۓ:NW=nqbsІKm7%!xD Xj UECUDDF=#K?|$@d~5^ͱ_ݽq舯/x ۵\9I?(d0CB?.;mCϖHo_vxXЉA7}mQAu0P+ԭHοopjLR#|]|~|߲ oi:gk<-||>>'6dp) .o�98NUi$p\NySyjiX-1`E @�H/k\ i�YP`A�RS%jn +X(o5! +`y6@ih+m)YO`W_A Ѡ�gko.җs2?<&Ivƭ?<aCi$ꣂ3=4 +##$h3FHUà2VBud`۶i9W/B{;!Bx:EWq[c7QӍ=鏸G�|K0 f.�M ns <\kʎ7^zE ?b;G=8 NNU[Wt:j}7\BH$viF`A #p:hKҾ?]D +^0Щ9&YAle\&1$ݮ b2 8;Zg+??3pfOp=!NU=Lԕ$Sh0z)FnHp>T'v~@g`o|7q_ zECh9^BkZzK$v\/<#*ZPTӶmFzdžN LJM's�f�ǖsei\K@^nžO(zE9{zڠGx2i-qIGDA-tt՟>Q_NPEԍ"s!YL-5(A``ݶ�{Zv5t4 PA_;Õ+laދ)o \,M7ݍńDڰ Kr7,$eA e;&sk%%EF[wcl1zNOt:|{ t\?\i}y[TGJۛ'SGcݗQGG4! DЬ3]u_m<<9HMP! JINT whĵG?G2p@:~vt<ѱV:x)#b-C2yY/D˰X?/oBu'D<JD63:H9O<Hp5�JpZЊi7II4g'gSWΣy$retl;RՕ?8)Vo7ݜn #;&#M}gI4k4GHiL& p?R2u`Lb6e|" Y,1w3e)ץ_$GC2xg �lHg' endstream endobj 153 0 obj <</Filter[/FlateDecode]/Length 3441>>stream +H PT/j5F +:4^Fq`F$ FcZ=�5VmkǦN5&4&TeCE{x>A4SpÈb& %L"F;D;DMD}M_utv$!D;5s49|Cp*&|.RTEfzB#mY.Hqs +쓌&]tLMOC9=?' y;/lI@6=ޏ<W&ew&no'\2KV; ]O.TOmܚR>P+2ڿYedjyXZͿ7*1hX"8NDkM2巴x\`Ta,r9n2݌O%ăRĿxul,4B}}ݿ =ЛBDEv/%wP �6E"'>v''H-4> +GS?}g'\=NGړfohq8j6Xjw`C1#$4Z3kM|ƶ'L/S}?Zh ^eLC7psBۿ۟MGMN@GLWFgl@wyϲݰ'q3*Ifu$9*9I9g<-in9͆}֑26Zy"f݃%W֞Z?? ̩u?Y1=GK@vPmyy=6E#njŸ[!ۡw+p똃x=1 z!}x_(bs`,A0H($6u,ͼ?#HNlF]ib`jjmp$[V??Wn׀ҙ?S#?d\imܕkwIj`C!b" e̻:k˼GOG ܷ G[7xLL}ր'kWݚG'@(wpC_n DTLLc,x5q_ XwX:Vf~E%K9g+fvjI0}3cT*Q6GNW[;҈mq HW-c~( ?t^,<IFs0>=H[xO;m&ɒ?'|7.)~XÉG#ïvܹzٚ"z%V?YCyO+a;a +;a6"ñ'}LGxټ79O[-d=a.q[:OCQuGmё9CL~vGȸhJV$GbE4_.,<!j9L{&0v35=Mqoo0<b9ܳCI[;T^)pf7,_ʩ?uYGa_)jw#񇌫cD4S.,?4c{8F7V?g}Z#&f'mRq1SG!T5o+}$xջCFkPz(Kr]X"ŏd7.˲,WX̖˩:ZÏ*?G]jw"+{crMDk ?:yך?rZZOSϺ$Xy>}zJ ),?4鏜 '\=Ό>v'ȸh>qbEjaEѥщq.CgϧuLE{؞,k~�/1H<,PCx`Yw"+Y#݉%:: uͳ1X֎ Al }k{y{^.칰Ѵ+F.$qѪ?>\׌NSK⏚GU]/|Kn,6e8{cmΘ>7?ȕnl W  ?u}vȸhܓIg,ZU?KgJ<lK]cRdY\9ajT + 2{8Y(?3PxT|OAWCɼt=iɻ5hڽX"<?<8Uvi{tGL[^e]"sޭ+F?Gy6^!{<mC/8lRjw +zp3njbCC_$^6~?6쩌"k|}i?B/Z}3MW$�7cc5߳1U?GV;l{Ҝ>݁2ueԫ+W9wd^?.0[6+) +Ë2jh.?IVDR2"J9.f09뜰BAE魄aK9=[gs Y9s$N*`isU#yCHMr,uuUt&#dKq3 +Q`VEKxB?`4V3S=s'W +gawa̝TGcҒ;5;}v7,?N?=7l'ƽt9-/6y" !#EQ:b5F-S3ovԞՆVgda9qHT]h;{,8P?c.??~=<Ϳzʽq~a=I +)c? $?.7)s?ƾ#y`υ#ܐ-F-ch:sL&F}}{ڼa^@-5hc#m<ܡ?d4WyneHi}[fyXGd PN ?G)M R d +^OMVvi{}g6`yeQ1TMyz/;~ ?bTPl4N|t::F7zX-|#d�ڂfQ䏠@ $NAHE-'-�O endstream endobj 154 0 obj <</Filter[/FlateDecode]/Length 3028>>stream +H PTW!,51q&.fш1q41Jc\pqHpbTD^E`Pgc,2L4f1AP̝{MCTynY7$b :ډ*a'8B<+`�ʒ^Vv7iz_^?+SyRn|+r<8ɦv=}F_)Veti?z"{s>sTYec ZoL#!>ł2QJy_J!bAȨ )6?B| 0B<ҟOLGHGޑ9Ӟk"AQ?F%qeb[KV0=;ϔĮ +T  Zm +m�>]b4 Mm,WHI7`%l:Xq!Tt 06yI(�ImEn zHf0IXAmJTe-3͟w˂?Bf:ZzO.L9~eC??uGfqAPwc<#2]iނ?S_TӪd&DєEmR\ aSRd{wGnSRҶ/2ѽE0?Ww3;2@4k0G={J+KU{g9GW5F(XGSEh͢,$菧�~+ )6ϱ=hw,دڛk|[|6d$ojjLg߷K/5#$? "?ëh__&YkO۱s &2#EinJHm%3e?l;D^O? +<NTM{ǩۿw2?plm6Xޣ\'w;hZLKf+ݸ{OS8ff`MƜ_g& :L.M;@QZY Ҳ_}lFؘ?R߯}ՁlXi[z9ε4WUoϮu''gg8=C?L(?7 ۧrE^?w{P~7;]f䱆Cz@Q٠?-R8E<a  +۠?p<{7mOymÊe#} lcjjLgv@BbyA:Ҏ11.ƾ~kf_ RS̟_;۞O:c*AVe0mg[itJcctBpGx{aa{#qf\)ؽaM#7t?J /W?p?oBGsNH{hoiPˌU>hK/<m1c2<6B0|X:wJ?ژ?zC+Ul۠?pXmJpQj�!sy1O6MrzN FAyW C?& +g 2 ~8eT}ĴQmdG@ӆsk+x;8r0e;[Wy ڃj%ľ&:[XyǜB}Lu` KWG L $M 2nQW폥6 !|caD?$c} !0{qk{ +{vN[9$$}C?fA!i9rWXKU n/_Wt!)-C! S֚O0G??=H?rɮ=VGo^w}!x  QRt)VCwVRiv<eC4GA! KdjǓCիi{z45{�8~;']NAՑ?~p4kуwf њ1-jNS@'vεO{@a Pm:?=NV@Cz͕N FqS8muR+BW�Bfޛ1Gk'![~%ԗ\B}'bb,.eM%a4B0H?@4<U?4T}Mp8iQ aSnn7ct*ԥ]"%e~Z>qf Qc Ap?@4K㏊y/ +;Pw8iP[9鉂3f т%Ү9ug%}H{%fGM=X} 4GSA?1{po.[w?pZ o#d!C?Z?!sJ vù#Rb-}551nSom H4ek({ ^̄AiM#wt_�o"*;c菶wB78֐Ҝ#K6}Qf?X-A>G??2uÚ=iRkmi�;9?pZŒժuE�!xa.ɳޙe K.Jyyh瓶.? + ABqZl#05Hs6 k.#åD8+혴s.WţQ0pss@GhcA{s|^~Ú1zj8#îի/e ?Hc@w by٧7crhc '0�� endstream endobj 155 0 obj <</Filter[/FlateDecode]/Length 2902>>stream +H PTBĊGTDM4e ΨhD-(bP0\A"*@=ŘE&؉Ƌ6v:4 {շrJO:7EXm +!a2_BH&2]J @'dҟ [�!XBD GȠ |AOUK)Kpv.1%s_O5q=mԃea6ϢPP4\8oX/`K*2iDDL)dX))TXF _ 9I(`>�_D~/L{MT{CgD npuk +F&!w([7@= +T>Nim6?a7rPi~3jKi7} #9{bzxdAsc#@s̤d|.[G<OδO$ç=|jމ,HOGM_5 ڻ^(34@n!ˏ" 1OZځȠ._/@4G<1Y _a ýR9tLOGM3U~DhXP?R8yzE~2}!6(\Nfl4G= E 4MYz7H2?<h٣5 f)o򇷥=/( bxQӨ)ٽ=>9k?}m7=a�}!-쥚Ú/pgD1Ghc=w<QWWlFTo315#=8j5 rjN|px9C8?D٣5LM![c}&BJ3vMn}Ԕ%OG=GP+guR hoprx:۱Xl?yrڈC=8j5<gZ>KcgB|+^돗yN?|.[/N8xFOnNcqi;c&<(lCAc3?<s=C?Z~d<Gm�']ݲܭCy9Bi^QʠvWkx13c,!~RG %1ߗl'lIN2}R!"-M5Ùi؃'d8?!vA ` }쏟KxXz+2#Fm`m*^\Q[!x1!UAwa(E<ZfAl P-rJu#t#XGkQ`/򼳛{rQӨc{ZyІd.(*lxHO#J`%)C8?z:4Ku{-{Gnpe W5{ؘqpyC?[BTuuo% (<?yDb kh3z;AG<C lz%iamk6n>\T{7GMV,ܷYv_!d=35puЯ4~7nP"`a # ;GA. A8?vSd?أ?٣Uޏa rQӨ+GFċwtjx%6 5d5̃/eehQ.A?C=Qױ=Z_s}M_9^3F`d8R5pj CH*NdAdi5ƛ WAb]X3XBmwG><xC=Z㏲!�g Ei2yCi쏑 {[ݕj Vx͞?u9cuC_%)" pѡ?Di$h5{05`pYtGS"Zŏ(+Q?X* sT>WcÇs>] WS#;9>ii &S4Yf+?$.Aہ?ؿG6y >yHSj,{B8jcN^fC?xԨqw\u�zO_SsrVm*-f>&DK#$sc{( B۩/lYZ3k{JQӨP^|igk j?//m}Y!gMޑcͯwOf+\dK2XN :4x\ }kRS0ڡ9N~nˇ5};B8jv*k}2c\{Ǜ6yY"S2lp +c =&Bc$\t+ޘIBC�N\Sc"T5+cPc=W|?dG@{G~Zn,;@zGOf;nx~%T9uREhB3D`<j{>qR?p4VگyC8?F2P #-!W݇ +Yͯ{w45#̃,)D4$S-��5 endstream endobj 156 0 obj <</Filter[/FlateDecode]/Length 1868>>stream +HPu6`Y +Ez#7+4EKiAf^iF!(8QS!SSϴK?*1w.bghÏ=϶}{NM?/g얆<�E1'Z LC&*?fi..!ml<v7Kv[4gOb4\b'HW,M/a%D"Q��z{rpmu(<ӋoA dU0Y逘pN�H'$D��1V8wH? Px?.K&vKck"g MRЈiD"Ms;KC+> +�@b!Vrd$ pq''E:Ju34tHD"ꉓ%{> +�@J,uAyݩ?%v/?f$~Kqu"Յ1IAaB�0f}p�c݃ɂ’}5?M!\3ZQæ㵛6p°9f5i)]"^Q_O(Ȑ9K;C!ׯ>�?u/<|ў͛4l-ȏΙ.]hi?j6}}p{P''rv_&%-{/N ���xXIbO#lA٪A5H%N9,- WjJ6$q=ǧ?7ϟD[2g +MG<LA^���]l;\y]ܫ/tٿf#e\??BsʯNDm4:Bϗc3IPo ���;udE+'-&)SER,U J +ZX'Q}f7 Sxs���_,D[œ |Œ9s%YmN'ẇox\?x&u”io?'͑���ʕ#o+G�7UWuw0of`8̿nhjV*E$M���iV5!Z*`pXwtb{rvkD#PT;Bd8���DHDq.8/mruar99Py?vo~w߮'"?"O的޹dutEya�zNP'$Dc��tɓ2{m\(ۧ_uG`;?@e2bYYj6}3|#JzjlKEڈdUm'$I˓}m.}mRs�� GK*!g E+<ݽ؞bd(ےa4|I3]#^MZ,Z5/YS7ɉ/GLʼn:۞ݵek +b>��_Ńښأ\ޅb ?1톭=xpJ`v߼^,FR(Ma^Ԍ' }MU' +}��>&ǧل] ] FW9Wj3OTiLK3BHTEX]2 +tiҒB�SGGNVoQ?XRy!=y3ңtu%y$lBQ�c(ˮ۲9]s��x)w`rdۛwB�ҝRTf5ͦtfVxi ÛSc[�{۔f(��Pݣ%E֪[?`�谈F endstream endobj 157 0 obj <</Filter[/FlateDecode]/Length 2622>>stream +H{PT>D|M(`TD&i*eiJV1#*ᩨ ˂FD01 D6 +L'ImF9b۽0WǙp}��:!B+U +zFr 4Era,d!?I}�p@ y!|�(OB3~׿ Mp\D!Rے&㗁Ӧ =fn98o9CkՈ:U/2ैkqbR[p<=4qL)!D%�D_/DDucJ E76fԕⰗ;`w! +&FiSjpB+hmG-I3 vIn? ~[B[7K,̮3䏾Q9fCz3#(ia @WP36EP?"\g)}g59~Wg*;[a/ ?2 {9&h)i`ygFQҨ,/^}Φ2C=S}qPvfm<ڡ +ήd#|Vd5ý-lS~pɤ]<;;FM L/ s6EG�owFÞ+!q޼G!}珇(N Gz`�1N8?G_,ߚ=;;FM`KU>F|Y"yO %?Eᶟf9јPWf] vL0]as-GJ&\̹d:{AQ?V%Gfw}֦rY s1R<6M5Z|5ʮ?D4A e?\ܡj[&痕{FI6 '/^Y"(J<{7oU+XŮ?4A#If5%ݫNmQZ^rDQҨmI/B}ަJS;T0޻γb|hu.Њ0;֒ Qh7?ڐ>AYm@}{u"(i1+\Fbzm4?/ QR3keJHH]t?,N>A8Ob${?M~f9]+F`2T]1"(`9j)*r^g)ݯ)78G!TԲKd#ݗ3Fu&c{TC)8l]/X{lkn9>).Ξn ve֞> B ?w靡w_4Jf)<\j0Vnx@'dQy﷜M_Ǟ985)!~ߊ b a6?P?'|y&SQQ{AQ?6zz4n*9#�揵;o\}.ؐbob5b >hHG ,x\=1k/gi1^w^4J5ch|(7\M?\O<?v\tpea6QlQƈ%]gJr/;?" a~ľ?lcG>(,xteFIf';Xnh{1ٛ"?i#=F"z݌-N{y4w, z\Qꂚ4ګAh8G"@t1wwd“B' ?uأ6pg[޾G%Y7>{SwG�/3Y6O{ͣAg}hᏱrDD(ͽ,[VMxT0C,&?oNΨ1>cm#F`2T]1[?G0CԜ3 X}=KG6Vu"k^h^3Dtı?`rwʮOQ`*ja;{yEQҐ?A035mx1q$Ǟں t̳ ~u`eT:;ګAhf `e; BZQ?v2~]w?ݿ"Uڟ}yEQҐ?W<j0Vgp5GpKy\wKs*y]vŢ Ԗ_>GhOX ;/#AZ"9OGDU i޻3am}ZaJ}Ws,ghߛx+X/¿DDhqfUv2Ar[R?2`$w(鏦~9e]zp޻3F?/�:t endstream endobj 158 0 obj <</Filter[/FlateDecode]/Length 2929>>stream +H PTC#id4"QĈIVD(>FB(+BZE <0M+2Lɴu&cgzzn@VqWYY/xht^@lZ70rb^x#UbRl0^ +b[0CŶE)s1~FLK0~F9!../MJe7xԃhtbI@Q1͈b١2! eCbFaB;Iɤ$r{[D!¡H DwEP!IEu +M$ȏޢ*Dy!t9S&ugWAt"f,Z6S W>gf[-mS+"0?DcCC=$cc<Gte٬wte|?Ac?]3òErCG|Պ,;: p*ʖWU[U5o>tVhm^4)5j[ךY5S Ш=c<YK\YwiQޅѠAQ0} Rq7q!G|QMj~>aց?`x҂ Օ }/~ٳǷE%lRT}!8u>9Ѡn8Y?B1O\0XBAӌB c?` :4ș_Ib"9f#>CSUٝ8 4S[ d=u槾=K*>cbC@}?)F[|yKR3C +Uϥ8` FX ankoޠEl2I"C~c!Gc uxz]!+'ǏEX:cdyz߭8y?P^Ֆ[{2e$ + }JH]vaZ*ҋ%󇵨G6<P h[ _Wӕc^x{z6錃^c&{:<n?#YڃY)gR<ϕVԍ H~n&XG1(<hx_dM.o;KW̤{V_WT^_yC{yGωNbF'uҺƅ[=:uw FG G] Rd4xǷ;*k?zy 8'Dem^AmjяV{-mS+"0LN?#v! ؇#,pFk 9L_Rg8]vaN?L)$?"/"ԮVg]8{^ Y@M0 f3's'==m]IQFqܝElM^ +ѕejˇ^<tfFt u6 'B(xʩ(Cكƃ?Sؤz%0IюH1M?RXSuBue=s͠? y#r:՗,EqrA+^q<sK=~ئVGzW](DW_4M? 6Q? ^AR=hCSUٝ*d,dq&?}TBݤi´楼E ʁ}W%! r3}vwUJW^P[QJbҽ!$ 5d 0ΪAU?Xc!w0H "1�ϕs7%ZTBϼ$:*.\q4볹;O[OZ/R!0U|#?p?}ӟՖf<q>LޗgeY:4.zvkvy7o`,kT%QW,SS-Go!$Y 1?#kf<q}o)fkׁ?l|wIsp)B_`3;0 F:CF2l|=Sjw0ci)oS+"0|>bI >>7`HsW= D` lCC]裟0ci$z+|>ākBz7]9ZMx?dd,Cc+~Q-<nf, C\_oYq23X?0P{ЊU]X+,iɻ2 Fi0~<?|C? KJ_c<K׬_E-jşv\`}Fˁ?ڃYT4{m9K!K1]va2HaJff!S[55e<K_lV'a51c5!A! ؇c3 +,r}l.jqi5 [? N)A2j8; v< ?fzvq@Ӈ+ | \E8ҵizTd11H�� endstream endobj 159 0 obj <</Filter[/FlateDecode]/Length 2698>>stream +H{P#I|$ `S5Q5i3Zh (* +5PAe]C"G1jIii3szVE-,zׅlͰ ؟` BT9l |e3݁P;`$kvC? ,U%A/H:�AtQ]:�t W`Mr wbtPO.@?a�3_-= #PQ�ĠɈPm܉;Y;x׈!NRۻ!FmcǎASQ6 /7-WxKLW֙E ŘNYG7RXVzv\)c7ln mf C?RU*dzKyp]CX;)~軺?шØ+|c8,3g&24#?ϭpN*O>U hV!8RT4[X&zF!8[?Eecx{؛ĥyq+t]!~[8]c*&V^8!!t?ٽ? 9D nH?TxXǼsU.!LCh3`T_~fqEP叱j  s{V8]p0HKYMN@"q_kX? +t?d|Tۣa>^+w9ɑ}D^"4W?}_-&aǡQ}3DL,MycךP\ %QocB%G;(~BTy_S;42 m-6b;1\]/'Pe'Sp f%P*VNd㗊;h%hnQPevIƶOO?hdGPb;Bi;L?Go!. +OP?î6,ak=#Y  e}cdCعC?ZLx`Sjɾ?GE"4䏶iѱ\m~/}o% \NfNƲ,֪3(c(vi"![!{t?n-# CX9|uqT{42 zTZLwn䉾CsPfcN'zd,&gs%#Cx)+H?&<zݮZuw;w&tbFGNo?hdGڜa?z=�3ww"hsbNWEI7?U#FA?6vc`5q?&4zȚ Uۣ3akx=dGO�YNnD#456.ȅW3De=x |@;'cW~<^Ŋ/@쇓#laU icB&61G$f +5h? )X8\;E1LCh{ L/5]aw wGЎ?|mX]c]9%Le%/*^rda8ߊ? 'ilO{c<-EVwUp) +U3]ywM?hdG{EO~3 wGД?<lH:aH\;/k(U| EJ-M#Mg?/#8�i_M5ƇkzA#Ӑ?ڟ[?d>O z!o#zs"8?#X]y)19GX1f/ΞN.gYx*%@Zǿ-ыdUKѻ42 9MC}sM><2?#|Lg2ʳҏQ|Q[7<Rek.Js$U?D{/پN\qbH7=?u=sz-[;#1qfXECթ8G<r1_Qo*#94GG=2[h5I{42 y9̚}g +b{^#t?T٣%W^h5ޯgMCXa+vS*MQo4&a&p?C+(Pc_~=LCp^^'A%vrxFЖ?#bޯgO ?1 G3GA0$Ik{ TJ>Mld3^oG42 ù3'o,.ѳֳv=lvh\sĐ?4=-Ùx=;@%6ڔ4[nF!83b[~Y]^??!>mǼrnwYsrEsD@yNDGHWjåU{huuC~,|dA�CR endstream endobj 160 0 obj <</Filter[/FlateDecode]/Length 2583>>stream +H P+ZCujLIFIc[<ⅉ`M5ch< +X0r- +5(,ވ xŊ'^ɴ3}_ b}yf39gxqFyg1}9 ~cQ!vSJ Fȟ0ᛄ|!3;S(!;$B'2 'd2o7F2r!/І;B+cx;Hpp?ł8,4[PHV2dA +qUܥ2PB+|D_gv3Seh6po -0rᗐQ |G j+"FNP�m;� Lڞ,H~�v8D;؝5v?IλyP=o?i5^RSTZ:pAlGP?|xi.{C?Fwc߃PN)%JvcS8!DC>`ZRd7H͞$aGAu|O9(Bx"9oЗQS7~ZՈ'%QҠ?}s7sEC>9V> +ߧ@=)sZƃ?4mYy%utz&=dGW=~ 4GK'}]ƿOJ +Axc̞7?X_CupVŎ ѻmjbvZ&Dж+^g^}}Ɵ2XC?ڭdu}%%QҠ?켸'سs+S]/?16ڛxv{-ft-kXK#t4AX@qySf xn{(ڸC(>'[b#QҠ?WEcp(zB]/?1{υ)ޣ@lB?5nX%349etSa#Sv`I{?Zm_R�GJ Axm ϰ;߯}Cy#έLp' ߡ@=wtȄoAaG"h=v@Ϝ[pen +l@p;{t\z +{OD,zGIn}JCCf}1ѷ??ݥ?\8_o&J#H�]`%Ғe YnGKWGX+ve{G?p4Nb=B֊C?^%r݆ѻ-/0zn $ A +e.w?�j{~zTQ0ѻ8Jd"TO9${`fZSrS2bKAas:(rCMM訍n-\e7[2A(5ᛖgrYgJ/1绯sů ߛ@=tPH#i:4H +dݜ$^?lC�X Wc7JA1Pm_HN/v>H`!o-4|RN7c$kY OxfQ: CU8Zv}ω%QҠ?|ҜPpBC?^%$\߼t$&W?6vZNWahJ=lo1޸8lz??b\ Pg_dWEC(ikЊ0[ NjEr !}g/XoX֛pX`ML74;ġkӟ?x_̙3i1478JoĘ?ڪ6!KEr 5thVĝ[.Z% +?[: jͦk_w?5n`%2J/wD bz#џPѵ08h*=V] 8Joz.gբo}9 %z{};Jj?@Ljta9r/Gk?J~墳! ߓ@A$sݻ-ޗ[c?^V/ĕ憉ikNƁS`珝mb ?Z ,Ha0<pR|";(?p4ٰbQ{_n?!lё?&,iwk}ɃzpRx֣AѮ? H:_ pT菮qS/}!|G%!tkQB8! Er +MH۔㍁1keS`tnWy-IyuEkg-J6xL?J�4YvԧYVޏ@ +A鵤n/T/pU[{nѻ �" endstream endobj 161 0 obj <</Filter[/FlateDecode]/Length 2767>>stream +H PJ9$:'SIMmt5$R' #rQCޚDԱ-UIG$NMg^oVV7\Zx}5(h((xb!AKQx#}:Q\ }/kD {;B poUq1,1 ûdRxw)0`[ʄø^U6 yN 0 \ǎyΧ@O:ˢN[~r$rIyCoB6-&$# !-gLܘ⽀E|$xm!2os9\^;+3}Y o)Z>l'9k(GALw\ϱ˚as]#J4GX G cO`ׂmNw;B E_zp۪t}R�DA|KvVꏡq'!t}=lub}.-= mi %&moBX?| ^ZL`}gum#'C26QxAP0J ҴO:[tE LQ P^)>Ǟ%I!nlw!`nוd}0Õ-3GAL> j^R^}lqp�L?aȠiwR+?pils CnCyVU;뻿BGɉ3\"tڹs=?JGox[ v՟U9Ǔ伺R%}n>Ǟ>t 4u#B>o]vg3ȱtI6(4,(Ӡ$]/m0gQCӠ?}.6V<ng}g??| >],`ևS˛]"Qb? pl<U,-ਡ?pihMf(kN�C5gzB}Y}yg�8⵵ϼ(tb?WEc EGaC$=auFHgCӠ?PXٚݦngm�1=#Eme}UɂK41GǦ֥9tW4&9a-|I/-kt 3?&p܇>Lǡ?Ӫt-=EMuh~xK$82s�?Ꮿy~YG#iЦVUUua;!B{UMHk ? j/ tnzqd b?"yX$@wx?d49Ԭ0"ÀCG3ڲ:|b=ЧxܸC*Zoھat=_i-wYT~zcӨTW>\ṅ@b?Tژ̺؀`Gw?X=l^+\Uyk�a{!17!A=-F:o}/:ϥ#7-G_DZ2aSﷆ?qMRFAmi5}.G3Knso?l3ԽG=_kS+6zcۘwЃ{}芃V3Bb?¹,Y;?/yǺCu'*J ѽ\ k(-hQ&$ gJ +{_kvL|$6H_DZPN(AXW2̰?Ú(v:E[[ZEG<+3a" >\۝KY�aM#ιeugYuUmaHx!Jq5+c1J&8Nϲ]:"g_Qt񨓺NUNUnNhϯ\ŐP*lV&$ 68oLƪQ:f|Sg.X?xİ?7 +~psV YE,댨 m澧Hu%|=,q0Zp(vVrXmI)}؋8Æ"> uq_ye傅0qƌmUy,{}~\G~CESPҳ 9d}%ɻ>/cc!3{?KzcƷ*#l]T8&C:kC|૷in:˿ +KYch0Vp"[z;rNFi!_?zI +:n zˢƳ>o˹!Yq˛ 6@؏?VY\Z`L'9f|ukS)7n Id` cX +mOZRVb0Ip(z(9)}?p4o> ԢHǎs[ӕymSYY]i%^Ju}z@?hv2Gl"a?z#<LG.X>DyXÅp�� endstream endobj 162 0 obj <</Filter[/FlateDecode]/Length 2474>>stream +H{PT/R5Nִc2i񁢠$h%FGT1hD1{,׮,w.,ZQc|TQji'Lg9w.go;. +>� +]=oSrm.&~1 !DNJ5!a,uaKf uL'54@?RDK y,k!/05o(Xh_nx!  +}[ 6I.փަ%Uq-T0QLݖ ~;3Fr0rw';cOўv Ca T>|�9zKIO.w<{}ކCQcYs_pZvF^*&ORc|x6"8GBJkc$? ;DBҢzX'ˆ?;OjD|_p8j2k(17_ !$GO͏LXOϯ*4Ór #hG?N OSz˹:Qh`bX<t?GOs?61_̫,k?p4e435ƇꛍżP?ROeKx4mz߿!?X.GGQtf`eA0}>ɫ=r;{=_YZg0=$4,ɾ o;=<r. eٯ&ŔX)՚- pPt$Ӆ!Qh )hVˡuIgKgؽxqfs{? Vξ8>c]QӠ? M7;_y;L&d5ۡ=x3&l `iht4?R`S̄o#KGx=oMb;4=%ʋ>c]QӠ?UvU鎲}B"x[<k?c4}$z2]z;=VK叇X6S&9f_ѵ=e@ve.c݇QӠ?U@r;o.x[</lzcE3XJ9a x֥Q&z`m<%eӽ}ڋc݇QӠ?WDkkj !m^@(u +]p;׊\3*?]C FJ:Qh?b67Â3~:-a5[vUgVaLZ5 CyM,9#o/?cJO1a.kP{xݰ/=yz9^zqSy-?=`>*O;I A(lB"yMr~P7Cw?z!\a D +aq#.,SgFEkё̊$޻IA(W{_yj{iqc!osg;jN&`?$ѴDxK{ ~ ˸.&=ܶZu{+L-$do7? f?ojc[Llc;q IH]C?vǝNC=0OaZts.ܞTkyXO)6x] o;A}\zblth%c]H{{X`|  10QEs ?x-\5 CŕoSm3_ %d=o;?IYe{_1ץM k$Nc+CFl{uVj(ǐ>d(War\yl9GMPv< LM'm{ +SYx+b˲Pꊁ[0wɫ +嗎SNnL.s>S_ c6!g<0%ڛb+HƛjG*AP;tT> +mJS_⽫XBio�VӏTce͗|sUuX.OoP?`uN Yv .whQtwY5 C$`Sy^>lOQeJ5?Gk C{ +Ap,[sbnerₛoW{b=A#)P|$z!Up8( +mQEIQE'pH|F,'}w!F@;[agY(;?i/w4X ;<`gv=!N!~)Th`�϶z endstream endobj 163 0 obj <</Filter[/FlateDecode]/Length 2325>>stream +HkPT7RNI1hPFTL`*j#DXd:\k wW۞݅E*4X )J1 +t2^4ޞ eϳ}/3ٝsGܣVO.r7>6J*GMA +> LrHP̮>g!NȘ!NEO呥BKUyB쪘 ed:9C~'+ 7X,`{gcl-lby֒j]U;(}wH)_tX +ci) 7JQ(t=bn@'&=hq+!=1\ e|M[1= |6d^ui{al8Rڐ-;^ m ?4M[ +^-KLf<C?Ξ볢܆ tf"ώkKl\8}'X|oCHi+<T2hO?!7ص$;;ϳKL̰ZAګJF};3&+s|,q5C͆glеР?׫);I o;U'pxek!;ע+?뜆p]ƄϹhxƬ-q3?X qwR8ￔCHi,T`z6S m +?n6}mELjxc=}'CҌgf}`5Z¬> zׂBHilɡ7I,8| !}nEL_.mj?N�g=돿瀣wC,NLTSRj[M`*kҞ߇^J) C%G[(= +>g̈́CLyg_Ml`$ Ba#rK{ r=}F= ^Ȳh3k:mqRbb}-9S) CD7A!?v-!{C!&~sb7Va/f#vAFwcrĀFм�"I3EWiu\;>^?3 }:K) Cf{_(MC<d_}ZX_Y\ŖjmWC9C4]H> }+^޿6;Ɵ"d//88 \jk^³oh?8R{6f17TW,7mF3Wuz0U~u4R$`Ōs'#u5mbXi57]zkl'*k=NV) C.MYq7TBxPηfap@O.:?=!/d]YKFBT=I a֊d}odҠ?/7ZoS[hc?&Sh溽d໇x#"b?Ÿ"|%׺ӧM~{cBHiQ';Q_uUB1qyJFs|J&dv=i uHkLX!b)?no4}z0DžҠ?\'e]y 4 o${[xC_ٓˠ /\KGv9?{ -{POLtTOi^WY496:8|liv1_I +7 >{gH9?NU *%V/ocCHiՑf}OcqǍk5 >V]W1PWEs>l'w s|) õ+HVǖvhk?& ] +cY$aΓT&k;uyHEb]}rZ{ס s|) ]<ho?&( 8GC<,:ۋ"b?N?C5}>v8R![Kl5F}w0@L??+c4/6=k͛?҅?$i ?V 6G!7.h;5eC&N) 5όtc=aG%sҪI-R'nWM$1`U߱1{ٷup[x?D +0�!TQ endstream endobj 164 0 obj <</Filter[/FlateDecode]/Length 2070>>stream +H{pTQ$\8u22 &@AHAiBn2B\ %Ѱ Bp=gqt`E.dSmՎLg_}!v}ydLߞ{r\8:g-lT<T&Z2BCXRBRFS!I):BZ! K"Bppa㌆y +Ʋ>L:P% +iP %T{!`ٴ3@:Qe-.~OҿzSmu06H@C `mb@5@Oov+oi}̾o?n*U} @ܝ?^NUꟚ+L.GO{S[A<W {ʏC +Zkx)|];GWi{OSق*(C'jW-?^$cl71g1ޒN8VC{H$9Nk({OJbNhQN}Q6AӀj4@ܰ涝`m{/0m~3C{헗Z:UJ0qc*3` +*":jlPeyo /j-&ve%!mѫ^0;xoyיJd-C7P ,&eGxo/oπTzv>?M3L!LJ4 :lh7aaq=g *_{"0~?"طʦSL6EOk*)z*bCGT aC?`Q,<{?xt,HCx[] +ˎ{`h(QsM~=yo/ .\9aUs[ROL;J f7 RA"=59ӼQ޻C`?;6# $!?iR_t^<`ډū K|3D ݲGmF6qO}7xt%sƱM~vֆ^^0eTUr7F!NNϞ &FH:vvjB +~^Syo^t7l?fh ?ʩnXwGL#]m/ݮ[]÷ٟ{T\`+:/wvFQ E cu~d|G_e5`C`C{.FڿYNŽNK1`贔7l;H- w9c(|0̻&VH:6T6Ƃdd?w{>ZQ4`m])lGVh`U2mM16ap>ƞ7OK\ 8h,V=݊tjJ]|?k VOvz!?^Sq~~f#i{oz̻+(W.}`SCX)}i֖?Z^FHm5oDGGXl LUK9ÇUJ;OO"m޻ '͜^E+-yl4C`#:X:Wޯk&( +�Yw捤sg-˶mn۱93hL"?~ƍ u,9N6O.?rcG*Nʍ Lu)rEGcxoh3&g &n<Znm6_,x7OgY~zӦ^mr7t5>h~WvZB�� endstream endobj 165 0 obj <</Filter[/FlateDecode]/Length 3679>>stream +HyPY= +3xת#8;#"^ (*^Q "*(PsDFgu@BwjwwCDYtȼ;_wKqcn\"4( 堓 'X(!%<֜A̿ +eXɚh!GYSf3`ΊR4Qh*P]\{[>B8pKkGmjl>\Ԋ^}'Lva?þ¸7^OY~8Mǭ]&w|MNd{(MGJ^oi:|M%W.`nxVJR asa_U#c<~lAGgޯ\{+b+q"{}*mo(~T{'1th`Ö#~ZCݷ5-7!}`?iȮ+L?rXvqo.oxr0ΎfSڴkTP4v\vGn|/U4oP)^_~JRdFeJBHt^b$/zqE&-R=?XW$+Λ8y_Hm nX˫Tn$:ڙzZq/,(q953Ww$F=sM'apԴUB.{&+2d38?d3tn^ pvٰɋ # 33|W&Y4߱QpP_oɻuyW)mrسY<,5]]umL'C]ӲCQAP.A}Q>ij^soc5VjCI\LuEe-5iުO`N}N_Sf{vffzԢU=??\khz<Qr xQ%)~j㯩ާ\/3Ӱp)81B[!mg|jr#!3*GUѽ9ppGǚsSQxCL'˶[ˌr ӅP[-́o,5=se~g_5CtLRο7!՝B|0}wJfq}18anqrx>-bu]o~۹?Jr_EdzA?י@^dd=qߺS=٨9p}$͙'c)?>+ep(GX֛,XmSU%Մe\Y3�)7*Het M8?˪G*?/-?hzRSVa+=} pPW^8x"{*D!+ʒrN\(yչ81 KXfݟtFؤoC=z<Au'O/;e.uȺ^$s:(s9MIҍDJeꂟ@#YփuB=̫jq2vYSdw惶?3X8st/ZDx/}6~x2{\`1|TJ*o|!nb׬+H LQ^󁀶"Jh_@J[Ir4[)3g]/8y4(sN\< 5Eܰnocs$+yAPqĂ YKtZ?Hq2vߙ匃D_"7u-9@0?2&a)jӐ]~0G P0NCv !\oO +w8-Eɘ6`oJr[rQb.Od JR{ic]Umu~8o?No6*x73I2yxsFm:=w&pfQ4?HnMެzMIrx>*ڲG:?J藋rEc^c?pxRO)o&1ʍ +\nTDJu=pc]QUh)"ye&8<ڜqxsWC8GjCI%f-ֺ՞;мCa%XXKn'vzX,M0E Y-Zky_r}18<)?& +Cӄ6zVOcPNˌ;\kI2C2wx 4w2:yV̱mm3M^k*}p[׉\Y+TWĵjU/7t8] E<} o}֦!;8РETufh*c/?pxR?j?J8QDs^ʚm׌LN(\bdo=+F8ہ_'c �78ub;W[ \^7$TwWiz/˛UEZ G6%9x,$�(C藋rޓ\_O +W^i,8%eے8>ˍD̨l[ܛ3>3Ne0ƙsSQxs0OF#yAHNh˺eFEƠc95X-8 'H" "(Ȱ JKH 5P E1M7iyknMwm%Q)vz뵇&f9?߯ +{vȲfgۋsظl:oTg97w8FH܇sѿ,ɑ7B +{_I#wE4G+G5人H7n@vQW躐R-]=k4i^=>:*Twеw޵eY4g<-<WW{yR$+enhc<!(<[KM(՞/eP|\׻{;=ȟ??6McuJo MJR`~]҇?B +{d4mjmSGSB[睒}XqSn=ng:F[r\ߜfrTBkI7kb +p1, j jE`EڶrG͗cjwIم]f #e%\xZ%^)sCƴ6G+v {ס3jZ<�!�s=>SsƁX=/>zz!'f?lCzI/Og^O@@)? .g̅ +:-vTŞ|/I-%GiʢVNjN w�!��6 ݘد'Xho )㽆xACogc̡G%J0a>s, |B +`ؕi4t&0%U]w�@V~bc{?0/̢ҐZn|B +`39#uɾC6̤? >IL96HX$O2-|"_ �W endstream endobj 166 0 obj <</Filter[/FlateDecode]/Length 4053>>stream +HyPWǟF1&)5nf&m1^ D"!r*p:00gzn 1J""jmm?Ul\gޯ[~{o~9-}k1:MkTޕi+.CxǾ_J}f0_}0P[fD0:Ya|l\0[M E*]3""NQwPځrTd,*FIXmY(8!e#oV68ZhM:[Z5#rLAmĈ=f1;YֲyfUQZ3Aʭ;'ՎԅqO4+*0+JF0|HYB]%xvR)z݉8آ^tэ蒳UKƺB8Įc1G2{变<wlݶH /vcLkI2eAMzN}zH^3C>p7!5'"*`iv)!!PZd*z ص"r\ Hf,z|9R)ԖxN3V= +_wsf?@ tW?9¾'E9P^~nǣ +kg]'"bdeq;h{ A6;*HЌۋMm45Ǯ;h@wF`ES]"*ho`;g!QQIx!r| HfAWEa3ZЉCVJk,6eIwj,*9R)[GGegu2n,i,qJoޡ|yD|oGRSmN e+IX8Ms; 9e}NSCH> Kؽ{'zEe{-;o|dRL6 g+ hgh]~yQwT.歫5RUP&ܽos]BQ`YZ@M*+0&## Zzѿ="7:-y6rEת5F̰UׇE#=9FyFM 3@~Ы7Vu?t&MmYޚA,c{13]iߊIk2L;<0c^ e{.Jdj/=䘮|]}<b.` +ooµ,<yWu,ؓLbs}-'(&| rKPذW~ȥ$d?F7azmfGx<GeUJ+qBoxCPOx2^U sS;wV. +Sd/LIJ�do:X}z?`f<;"eߪu7 +PS,$yADW_v8X9s$7p!YG̪f?ˋ}i_[gQLOIJAs~,E3nd }>}9e|O2׍[T',&n(G֕k3!}M5|58G%NSCZm,sp|١S8k1Y3JG޻{14St66s[Aoh<-bS3G'ISYH9s$7X~7ߐE>9 ++_Gm6#ejCݐɀ{3ќ/VUD8c~#dOMz|sϚc'OtSz|SL37k$o,PX5Vu O <4i/&qEiz^?Z|xlw?f#[~];""[u* :%yy:sLz9s$WVkNԅ9R<C\ai[i�˜_{M Q.q7ឣ0[Y؁͡_11 yG"IױMB<Cز?0Ң! +uB?^Ŧn}S`M`DeڶIuPwT`RZAi'QT9C\;�ѿ;""[8.봃Wu60M ɞp~] "bd.7n%SG6 �+FNndi0>FWiGbk(} zʄ!`biM?+r>mWE.M cbXXc !R!sc#aEyiiUs=PU}Uu|a1۩bsDD]u\4Q|EB 5 r> Hfof|Vj}b7"_aŠ;LК 8聅JJ65U蕁3o>Hظ|}h̰U?-:GX[^ xЏaœ?M {#"G6"66>XRLiD XEfK-R t),eف]v7 ܼTX)W}-8B %̙sb`wX-$j4f:G )+G9A]zYT֧]u8RX Ϩ6i +>\ ￘5Tl=E}d%cOƃ! mƓW�Krl aۦPs\d!F8@3,edmUΐI{nfBx#j!pE@ɞ`SU;r:o\ yMVcunD-}KaFN7YtZxѶbl"ћ A].\v_9j.a?/1r^idt}LU#xV#Nh2T}g ROh8ѿ5Y.; Ἐ}[!woYC;a'9ޠ`H)\?|R2]M󽘆 {Jk3 טL"E~ tVaG\ IVwN|zs{c^/};|kX[j{NT/Cm9z)1-dQ?P `3Q(db?c`~Vux~ɁUԧop؏_J?Bx~:mR!Rͪ.7GI$c*Z#85`H)\?�6ܧN|)s_V$l|8 +ɔ_wJ?m]!vq (իI?~|f[N v@R%4o^46CC%{Vy%!E-I3R6zSi;5joHdc<299F�CJlH{ߔvdwYψ&OڞvE/g~X +1;X)v~d*; z<MRnr|'Ϛ;2c[^4=;G'P׃,7=l^9qWwY.v^d5}Z5#wjyE!R +wˊ$8znk?xef9+y9Eu&%5�T-lq;bAAR ήD;Go+p?#S{9TYOJ\ 0�#Ӓ endstream endobj 167 0 obj <</Filter[/FlateDecode]/Length 1619>>stream +H}Le�;X K]BB2dr5EݹQIi"oP(N0л`˗Jʩќs2ʵl-'@Ǐg=}�Mmu;3id|.t28i+-"2)H$ Fۮx?�@o 'dϡMN[9֛ҷXOc}6%8fmjw/F4JuLtsI@OD-gUU9��zr7q1ºVT׮b0&NKk:ټ{1ot+U'̓rCya�C⣧~ �m=*B6U[wKjj9K_Xxwa{׾Yn+db8:��Ox,v#cHS'O�1`)*o4_�XԿ%߾.0b$?{���A<o3X & +2^sc."٩Tڷu؄3T&} ���|A IN,G�`1blֶ躈F.W73&FBCx_ ��^ $U[nG/F�1PlrXZ)qӠ7ͬ'!���-~{SX\Yu`"?X4yrkm +"8˧rBc"y_��.,?WL d=Hчխ?@L|?X +ot ٩i{arsy1D":��0$oW<ߛ +Wc\AqJ>m8.$iؙJiжS2,XD N rBQ��<~ë8mc/Z�`56٬m/[s[j$8LJ̉n2vG�p8c$bݩ?@L|?Db䰴Sͻ"'3dL }&GMSy? +�@%ÞBO%Uu{/4Oξw_Q;տ2Yx_5CGGMy? +�@;ƻ;;KUbOazZWii@'EgPUيB<H2)=z7?��"'ۃJcqk*^U�1X3#ȼqc�(2"iP.O! TMKSx? +�-Z8a 򎾃3쏐H|vIaO錾T}}p짲ѡ$,MEZޏ�p5}PCUbe|>G;:?~lMH|)7`DL$9wS^2)��`X}{WrvwF/{~-tM)zvjSNHI$R :8-{,Y<�0qqWW-�폠ܹhّtKRTx=bJfx_]��۷ ==z@kWnA㼻$%in+-5QyZ}{��d}< endstream endobj 168 0 obj <</Filter[/FlateDecode]/Length 1632>>stream +H{Le*s?Lm-]9Y\ i + Z z9yysCΑgPHJr[YtOqҸ<y~^{|¨ \DEzs$$qnc'h %aARKğYNuGù%3ȋM絯"�x:l5قIdxKpAt=XJæh6JC&7'{KMUn.澆δlWg[Ůt[v$sB$@M?MYAw+^*t.O vΖ+>$ʍS-!]&w5v^;KPIJ"k:8uR60Y攄o fζ뎆Kf˹$^ѵR7$.+? f' 4l&ؾMvQJmN2n9ZAKo88-SLd_2Qv^+'" DEo$QekѼ&z� +/krݝI^#y\fݸa'!d$ͪmv~sA8Q@M?'MA8<rf`IjR*=*k$KG$s@8Y@M?:%8:8uG|/l 9Bcq"o~I(W[W%q_" TKb6RaӺ]~FV|gz$(z#PiȐM!j#PӺGT kTE�5jqOZ IyRLvJ\q Vf5P(T}x2tV>2ְ@D�5j7+v"J6v +)7Hi**W,*]6'UYj6,wCM{&%YV# =<N&PN &E "N8G jltJS^o7}٢Mh_{!ټC;\gKPvrfq!mN8{xQŞ]d sB8]?@@5Xļӛj l_ÙWYQ9^{Pu]VUgpXk_٘w#& ՚6We^讉lw!ΗMpD?gTتlF[P8W\JWfU;؞ZGOZzԟ}c$B])6=U ZTܿBiN*˒`a8|9K z|pb]BI|4j'UYo-Τ&㌥<3ِ \0C*IwSr]>Ǐ;Cvٜy\es!-= XL΋bu3sFI|{A8}\y^@-3����2} g�����eP�����5&���� k@M`?����(�| endstream endobj 169 0 obj <</Filter[/FlateDecode]/Length 1249>>stream +HOUur$ +W6[*m"%5L]BXD@dW^_νR(-knm|vŁ99~s! #S\ ?��=k��@ۘנ'3��1Afޖq%,)<��@ۘנEʽW^5ذ^աƪ~��.5hrwÎO;_{:8W01Pg0:3A:kߏp׮ +)_G~6ω-^&56Sg5hѧ7վt>a)Ӧݛ6ʽʒRhL1Pgz\S=OoWsHF`WF㮡QccGb6)mMp77n.[VlXRtoPA־|QccGd٢\cCctk-9OZ!Ѿkip?=iձ^Ƅ:jL_g9yMmDH" ō%$$vo_{˶MY/̈]~&B!ڎ�*:ꎾ7xjNF.5))Y3_,$B!&6@+z\>frb:[h]����tuz.Tmߑyq#X͖���ЗV{[@{^QXd�������������@OM&Q>3xLݻ-&[,ݻZw\{vnu𵞰] nsۿ;<5)^2)7+[y.[go_u_s[鏜KNY^Z6G7=r.5֗Cv9o#?s쉐E\̇-[+dMd0/{ްs1Y_j ܯk~$^M?.zZ+-cFsB4϶lrv9<0Eݮ@#\ +BzSuU/wL)9ʹ5?>XhXESw`,)O;{[>#Qc}F?rfLz\g{ˮoPzO6mz16甮'%qQcE^=ok1,z=]>$kÓ1L 3mqmx'o9@3`� endstream endobj 170 0 obj <</Filter[/FlateDecode]/Length 1838>>stream +HOSgC/C/P_'05Ή"^tDMЂ\B􎊈ˢ1N,sM3Y֝Cmڵ~y{C=}ƞ["1gӧLe7;k+:N%-G[}i0+csZumkd_g7ٚU:=.j"dfq|C=^+%KwrԗC(*UG=12ٿO8Nw5 |o޾mA{V]Z=CܩK:52?59K `hwH3얇MH|0Ze 3d ֧kQ<.)ޕU)( d#*"R??T|mtsUYY4ut\"aaa,.*?(?6m}:+6<wdN[R9gc{hd ۠3ؚsq{p0{獺=F?[]QJ{sޗٲ-2@MYbL_N !cQ+a38.4LiʄDg7g5\/g*glڜ뷙 -Ϝ%AH Zx\19JX׎VʼQH{Yi\h}Cr ofN ?]jm.u!c0+&KJKCuUƄ=d*%?(s.k+PrMEOa|آˣkd ۠3ؚsqºv0{獺=F?[]QJ /h18i\82OWZMYc{gZdQC+]W۞ܩM}f#c$C zx|]RJFY&#Qgkm^W\ήZ(1QfLA~`|g9؉pLbW.Vtwuxh([ d|KBԪcd2d Ru4f)w"z|*w {}Mce[SCg*% f-M'_,|dVۼtK7z cg:?q<ltx}ꪌA1#c$ooܧ{8$o}Y{+ooeGC٩Dȹ\L0{Bj>ת'W;d"]Ƹ ֥L0}[DXۺfmz[Va MZ4uy}Vt,ze˽h-xQs.1!U% +Z . ^SqN0&1TWe5cd2aΔ fwd9Kz` `ۖQ[p@ƾ$ӇEkzCJ{dy?/4uzskJ=;? ./.kڳzN[s}`\aV6Ws>GΎ!H5z>6ί\lU&/vYzOy3q𼹊8_;(_a4ho2Rt8Eƾi.߹i}:}U\d?+إR~~o5ݭ «8K*>{}S⢢]"c������������������������������������������������������������� 0�8h endstream endobj 171 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 172 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 173 0 obj <</Filter[/FlateDecode]/Length 537>>stream +HQn0�DA,i]!|gV.%I$I$I$9x:E>̽죉$̽M$\c$?gm2GVY[UV.>9Ƈ?Քw⑩},q7>}\iGyGn#&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kbĮc&fI욘9&kϿ1""V?gO'>W&V_T , +Lj'f~e_)?BY(SѼG2ߥɾSOKؖs*O7}om9xd1K�Xi$ endstream endobj 174 0 obj <</Filter[/FlateDecode]/Length 715>>stream +HQn0 *"hFc_`Yv@{8NJDs>R2yL+c.u{L [[>Ժ"_|4qu0T5֗ +ΰ R櫯E}pB 95d@k~(Ԑ?jd@0ȦCy! {F偌q%\>Ҙ@>Ҙ\3xKcsi;E ;M ;U ;] ;ed ;m$AsԝQs籌 ԝQs3jnPwF-ΨBYf#3Of#3Of%3Of%3f'3kɬ$weɬ$we$L㮌<>*(އW>x#G!yR!u5*k P>xJ�.k9ZNkGarQU>x}f-xR!u5Ct\jhfy0^0D\6)Y1Eql! my#zsGc+#O^-RoT+Oħgh^wsP341}lrߡyufE6&>~iVEվ Dꎊ:/4VSYNM,lv{K2+ͤxVzK6;e̗�� endstream endobj 175 0 obj <</Filter[/FlateDecode]/Length 731>>stream +HN0DQ @Tj]3N`?>ֶm}lGõI]f$)f$)ZmKsZ/uKSbNu|,='Xj{:z +ܜ.$9]hHnMM)r@oM7ZJc141t.1_i;"ѕ"{Tz+Ev(N)-Ev(N?ֻX ?"K*I)']h?@_Bڷ{ 3"C +~!kz xƎ�7Zkv,/xNjr<O8ˋ뷺p'7XR12 ߖR{F?$T I %t/t6:_B7i3`*T%2]&#PqfgH ,sozmtBϽV蹷 +=6:XXF +`a{,sozmtBϽl0hp.[G�<NsV:XXa_8˯ ˯ ˯yr|tNhp.l0?`a{,sozmtBϽV蹷 +=6:XXF +`a{,sozmtBϽV蹷 +=6:XXF +`a{,so\S�j endstream endobj 176 0 obj <</Filter[/FlateDecode]/Length 584>>stream +HAjQ&_B靠)וǻ +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~~)VlO%NJ#�2I�V~_J %^zRfHOӅ23E +|c;f~&=XTO%NJXazйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t/} +0� endstream endobj 177 0 obj <</Filter[/FlateDecode]/Length 591>>stream +HAJCQQ"#XBdɥ7//.,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB~Rz,*hǮ. +KvGh.@r_ɳ/|p9!*Bpnn妊?B@>B@ zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3z<W�X9 endstream endobj 178 0 obj <</Filter[/FlateDecode]/Length 1757>>stream +H{PTU.+ H#*fd*(KJ +k74J*JPwvW 4CEG1_9(s1N]&`{gw~ ��` }-u_"!&ݕmf &4hsMeU�`3w~wmg'pkTzseNM5Wgi;~��؁ g},&7�4)3x겳2ȎZR޳7;��@+"O>y 8R)%QTyBj"#& $J��$(ݣ.4/@x33/f !8Jj"46<Uקy?���!\?M 2γ\@0 +2/%P:w6PbSU}*$˿=1t(��lwpBTe)UvB�*U9;e!V84qڙ.>!]xO Ov ��4Y9C[CvZ9ãFǾ8! \LakL%^Q/R{Dp%+-maNvkl~"N��Bkg&uGXA�9DT ^4]BYGi2[c)W<vQyx )ZZ$-�p,;Z5M?z.MjLeozYXɚe>G$[W❏,hcG��G"xvKeMXA�ê-Egy;X}.,"{»/1b7>|o~/;>ו=r�p!G޶Q̄ Cx^t r﨣 +w + =RZJu'>Gx � w4J8> +�rxdpy_ AQXJGwlmD(QGM,S=+� ]x^W7.@?9MirJo:B5'ACeܼ=xf379EUc*ʎ]IwAW�ȌD<'jB-<c,J呗?3䦹OK>A{ޣI`APnnw +�9qq!/i,�?S#p2x2g:ZXȼ4OHcQ&(=Y�l6#c,�`sUfDJd |LakL%^]CB=D_o`n K�χ= 1.ݑ++�gB1 !2c>QXJi~<k\$QyQsDow7 �NQx6\ŒSnL⒓?!\_QR !OI4/$>m$O +!5* o[_۹׳묽!rOw � l_lՆ<sp&?1Lޙ BZX}.," w_IӀQݷA'1^0}];N1?h6\U5]$�@LVg !'i�:ȥ<>T WAނ6nCܻV`&7o"ZO89C&Y%5g.^2lc�䎵yWƯd!c8dK[�>" endstream endobj 179 0 obj <</Filter[/FlateDecode]/Length 614>>stream +H1nBAQ,l -QˈZ-:o(T=F*t1z0Usу +{LUc`BS:=йT\*Æf;]KmW҃ +V+'*`SɱTM~*9?xVh'ub3ۅ! +.\Qwpd>Da?>t9#۩ZjÖfKeLUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{LUc`BS:=йT=F*t1z0Usу +{l͚ibkoL[xfě5&ެ&6f47kMY3 im|`Q-߇3Z_GZ`�~ endstream endobj 180 0 obj <</Filter[/FlateDecode]/Length 1324>>stream +Hn6zHH+]`:-@H̘ O*L۲6Cԕ9TٯfH;\ۀ͛!{U7otN.f + 7>GkdO�u9 P=^e>7f˨[p2�Ay����� W-KӭF޽ʃL~&F||v%M;v44Oy]OY V<_=am{[~<~ulzTxpz^> [{)MG5yISku=‘8Y:W}vx#R燏\lJ[\8Ȗ᩺p͙>Ƕ}p\)[gI ׹h5{pF||v%U:~g}Ҿ}����������������������������������������������������������������������������t~͇|YrEäxax=ޏj:XTsdp}~;ǃ8\|(<>ŗ=ultS|Lw?1}7My9л}@&Pax +r +b +| ++RǺ1 +߀EH+ewW,ȋfA$FdG%،2)SBh3fL#ۣ~˖K=o?MBn4~Y,Njm hjUndA Fe쉶=`k#q+b2ո&HX&2HJ,Mɘ,1iRc97)X<(44ˢHDuiWjnD;j<T1C^#řȴ->2Mr%g2Kj8Jf<ME&wvO:u*]lnWjn@ hyT?qGib7; t4OsS<hiP,4nZs힂.ʶ9 +mqeneVL\PmQ2k[ȒIzZ1)fwuc]3(Y$ӵlnPs/^XiDYe2mC_5֗5X<}*8(xT*=5-b{ݒeۜ-,Iw(GGAg~[|Òo0<v\<-fZhȴ;}R~< ~ +0�uj< endstream endobj 181 0 obj <</Filter[/FlateDecode]/Length 2161>>stream +H PT B"1h<&: 6f+B"hUH*DR+(kRӅ@L {e$ LI)Lttb;8{mSn&=w7͎ww3'�`!9n;W9{`ўM"PA]=D6%ې,!_S2nS Lr&xk,1N(G3Ԣ./��1 8B>pfݑhO}6�)DUKr *h"nr"'r)d|gNWǏfʼw5?țN+OlP/ṕmd#TeYw$KHif-8ɺCAdڭsG#oK_-ޟ(!c%:k*ʦ7U惕C]oWp7/�@RL#9 eĵth?aݑ?/!A-TI%!t3#bs͏]D3鱔Xr>xk -sz9p)eM䯞'xqslAMp��9H$dUs6Bɺa�_Cj{{R&'O%Й nr S</#E�sV0z bwi\7U6^s>3h�1>xZ&}$p=n| )~!t q'[ՇM6?> YLge+]5đü?w?rY4�%gܶĺa�_DcwZ#c]7-spKVG{.?@Pe��Q4O%yn#;E?f(a^茵WBPCн1k]SdF4o:moBY5�3B1Dk2L uSݩV95K2wMכ "� dzOșSZk6BW_{u3+o-n)18G*Ac��Wb|_)E1º a�_ECM;u=6#BNI{(g-ѭCӝzcBC�B967[:Y HuP7Mxo]%y;QJ@[PDg$Kf��Wx{Gh`݁?/#1w wABϚ(uV,ޠɜc{cߗUb�)#vպtfg<;w9�,=bi_05ԗ/^HyPKEwv}B9I ͦ=9I幁{x3Ll|<��q<לw>h*W%r˪Ou=D{?U9 +~`݇ 1IL *`)3`{DAp�gzhDZʖ>[xpznvfBq4ҥUw>Ef4Z~ru'z⏏Y9?e; +ב^fu3�pw,62ui`}?PsGX/gCf'A},׏$ B^!tkaQ0]SeT(u'w?tK�prdz|8ۤZº`�oPs Cݤ|]b/Fƈ 爽yiu7Aά`g~C\gZv�B^^?dxuXV CNI 2j<dn!tn|QM(z,֙CM}K +Z4]�R#8_NI=*P:s?ѥU8zL7{{Qʺ#AL6ktןb;=?g_??$dc�0E9Md̺`�oânTkʝ|}ahNI-#(k)i3>)=> � endstream endobj 182 0 obj <</Filter[/FlateDecode]/Length 2108>>stream +H{PTC@BL0ZN3S6$m&(%jM%&lc & b(2K@D@a.wYXAA@hL&Q3}LO` aٻ ɏ]0=^`/9Ww5׷ِ+2~x\}5=r9~W_ۧX g̉PZl{TFt(*OS?J}tẚ,e֪>'c>Wn<o87\ymƢv4H�k_(hii+K+{n';n72f9a.yGP6ZoYcc事 {3}}ϔFf20&['l]#kOwu(zsGohPzQ7KL~yp<_O�`b|`>t_a_-︩ܲPw4|{h(.yY/3%"a@MZ'D6ƴk.ά\U}4w>J�0qB8,]Kh, +yW<(zId}'(3C×3Rf2Vl4u%z1{e,awf,@m=D+X/ҿ1ƶ{(__`;g+_XߔO5=Ӓ׋liclhrQ~-0w@HFgޓ?3G?K+i6?P\5{Vځ= ׭wsO揰)~rJ�`bݹ],#|@n%*',pu 2R +󟍵ު{z+{3G;Ul0\Am0\=: t7i1ﱷ}/kK3>8A�`bdEMm6T}GP{-�`xǚGds+ T+{?TmVF�c:<H/vޟI QQPddžs�!3s۴e3 T,{?~I9 �gݿ"G2y_"kj~jϋ1 �.|kNԙj*=»m m{{Rg'�GN '"iw)�[c+Ze꾂5U^珍;Ⱥ[k8O�`# ReR%tU�ئ7z7*3DS0j1�!k\8I�6/{?yѮ=EnbߢP�`5W=7Z:rEJ9 +�y^t2~gx" �3v}{;ލ'r?'E=b� <\x9SW&u/FfS.ُ>Ku]3_څX ʑʞ77iӼp:Ku^,{Π%>N�:/"?Pka@9R!D}^jߦS�\tifyo,]4:KrK7Uʑ!,"t u�ۤYXb ӾnvR)�P Kftm !!rCi9Qg2!Sg*�l-iPr3踆ԽfK[?T�`ͮUV?PT0*.ú˧U�`Y'::dUMxik]ԽfǦX,ߑ}=s�Xv) f1Ө0a55>r:WeG)=- wQv*ԓSG�2~22T2{0akr9~Qg+�0ל'JY;PUd.3ýZ}�׵^Ys=P}c<0e fd͍K'۩�pS <|+J}f8nfܩ�nnY;D++�\ endstream endobj 183 0 obj <</Filter[/FlateDecode]/Length 1640>>stream +HkPTej̴&&ujLmLg2s111LT"51PY ( b e]a/ĝt0/jR396Y}I뭳|p};ٻ=3Lwߵ=rV;c[�j$SA@v1{cUg$^ �G^(rBbp <C0[] Ѭ] >b=u7;z=w�d8 iQ`@x +O<!RKnOQ,�kKGkyd6Qz`[;nw+7FQ,�苵luG}@)<Jƫ^So-�SFt6t(u39)h\~+7w�ܩ[%C׆ة=a?QI)5[ �nd,V2tDL:I�['T˥=@x +obwYֻ&;c7� +<iTaaO [�&ma/?R̺!7_O�Wj|:ݢ-G1*e{8^=v=C^p <CY3ԛ �غm ]qQw#h +7# �杻,E%`O?=A7^�jsDyτ{w#LR.�t`{kv{^b{L[U#PTXG*- @XU{p <C)-(Y˜zcdCgPa,Np mFRbVE=SL{Qlsz w8}~b{Ϗ- 3}o[|<zյICm=mN7OPZ9nj7Z%5̳T ώ^c);^J#9hPu{3 +3p <'=b}+oK�f c*YZ`嶞Lu{ +$\,a�jsj`뉷vGQ^M*[] VO sʴc;^^;+n PV\.)p <CMzT_`,zɾbKi`ͮZL'ʋXB-&XVzqkIpOQ1u2F2t^9QF�D22S~9<M'2dWd5R1�5#je}p/pOQH2$Urg̏z2"nYm=pO8> @ $WAZ"}TG Srx=|͟wu$=X8K&Se�je`1ɡNߑp <E-M.X?pJ� |"Ϣ M[u)ЙYƥԻ @ XcѢ;~)j?9ղ Ƃ`�R endstream endobj 184 0 obj <</Filter[/FlateDecode]/Length 1681>>stream +HilTUlh\h  Xa +llaiCVZ"HnPe2mi锖.tLP B);?Iqɘ|g/y~v{rsogׄpQ\Ps 7߼ {<ms޹4cSS0֪+ccsirV~ẅwcx{M-O{5>5jm5 @fpQ+r⟦=y 3~ l7WօӰ`d_?T{^rHyuGU͟*4ۭy) b-zQ3�YAunL$Pg`d_?fG ϻo;;2{JS*m1Rw4�Y]M{_y@VX:33 @F!GTەIJ3N)tǬ횉ȈE;J:u޽FCOդ|=uWM?%̵~Yepz9}OͱpZtSg[`d_?:]t&IGf=<э j�yX7zM 1g[`d_?vZ(f V}J a-U] @&UЋΧPgܛ`d_?$/aZywtw{u_EuZ{;aYQw;Jsz=]{tb{LUe͵.:J =I聽פ0C9E}ocfF q @_d9L|{L측Ϣm�2Hlikâ&z^וdOqؕs;š]:Y KGeNe(u Fc9T'2Խ @[k5}l\7`oB�d]V(kol{L6Iݙy"uw0W@OeQݤ3_9M?x>ٱpƎjۑy#sMF# \kن`dzowo"{"+o~C5 wL<@7�#{X;zM$Թ#!v/+B97Sw8�Xm^~tφ]5<6pШɬISTLzUU0c')ԙ#`$/aZyw̝`T;[_r* =zm]\{aI9ɋLFXp{Qz1=hB9_ݠ7cz*3ңW+moK~_+֚>֩vUNq�FۘUUYAeJ?02 dYsXG6u0ɩOQg/:q>.`4=)-CL F`s +QtPw9�I|䰮t 1O$r_$ΥQS.8^r�FÝV2%y#'R9�#ӬϨ,J,^-%scG5Kaj?0}qLcN)-v4UWjK2<cbuҹ(u0P͍햹`ָVv*;^S.޿ �3 endstream endobj 185 0 obj <</Filter[/FlateDecode]/Length 1874>>stream +H}Lu/ V̇j5*f*l2M сf(FH#!|D){0M$Y zzX}/[[>߻'w ^0KF&D8*pk_\sÆ[wx,kْ˦M6LS|9�o?;e+#싑8KhQtZ<z~e17׿=:i-|s?fi'^ +xXYGZ+6^ ++):̅+H(x ?cM̯n6} +n 2.[E܆9m=Ncw@[Y`@B%1QQ̫JOwn8O�dVMJ)1znC*C΄Ú|S@f/ & u1s+ HDv]6ejXV4kw�2K"qLz&(YX>WIg/!w�2o_Y`<$s+ H05hP@c0~^ڌ[eș̾$3;t'܇vd:[ S8'VK�d>6MJ)1zfeҙ6e |s^Ϗ}+;`6tTUDE\8bUfnx�pVæ`ͥPb,L"fƳȊskJ8y J놲FbzvYXϥQdl%[GPLx^M9j Dӽڽl`dUћ}nwi.L jNoUR*%ѿDOȘW_Üu5[5w-#z#4k$fbB̾]U ?/w=[m&:Ki*0{ECɻl7_0P!zDDGF2{!բtL󮀟ѿJ}t&}@&97kX0籸*fȠ":59uǹg]@&Zc>OM`xzNe1{K߾>;ks?_#g?{�2q>ieioϥJg-[eB�dA=}$!om "cb?EƲj-  YƲWFsw+r^wTS l߶[E�d_x+3*#H8ǥ̾$7S>�A2:Kn);ϕ0~ܞ{Λ"; \Xv-| +NqiӪtN�d{ҠPh{\|?u,Ң)7M'MYa@)?QIy"ZS9m)}z.C\I�$0vb䥺=OPϥ̰ 1j͝.@i6ĝto-sʖl!`}angRf?p +,ʧ39O�TV}Q- t??q_�TO0va8RϤ {p[r85NSw@�*;q]`<D=@懖O�T{UJ=S\ƪL<+{ �Q|\L=`ZK(hq<{e>,H8[s^|]DmhpY (<.l2Գ + ':5OaC.J`�s7 endstream endobj 186 0 obj <</Filter[/FlateDecode]/Length 1686>>stream +HkLWZMb5MMMj+QV)VWjEPkE;.̮ &bTL5jT4٤/yOfO=~/ +[vr`}Xb + ʈl<W8Gy`Px<m[Zd0gQ } X⽦ΖVDCYǙ}O9N+멲P{@)f[IoF|l sw3?0z_ n:Ũ /ɶכGRe/lgB/q_L$"Zm^u%޺dtF|O3?0zY^=I6ws]OwE5Rnjv|7 cң�YWHN "kM7dH?-`LSXӦsV^ {]L 3Lt20)};؟5)(uFOsR:y<u7P۶Sf̍InWR]4.r)':wZṷZdsתvu7P[Ut5:72s﫰 Μzn*nͷFM;`Nj{ο�jy'HOI*"gM+ian�gC�X0v.m\:sZz#ekE=:4o-侯D_ξ%r�jkxeSgN`4?(+6:͗C8�j .ڋƱ׿L{9Q@ $l-g+-ΚVaix/|OK ?s'uOPCӕYӳLim�j{SgM`4?JL'vYQD�qBޤΚEL$9+(__(oKi2b 6i</(iÛ\7<gz62%}weBԾ혂MCse?0zxˉa.m=]w/()l}lPgLzw9}@I9zBE 92= $`1 +|%ugPiR:_σ-r٥}@)aΕ;u?0z HΜsF/oͷ +3Qy0VUB>5"u#uFOCYsVc୨Gჴzr8$�޲OcRr!|`u�FOCYg-v­3[7uX = Ayi~5svZ+.}$t(uwwwSgK`4?qset-8KVcuoP?Z\=Ɍusn7RgJ/`4?6 Lc(� +|YܵԸ%:SʲJo/+~FH7;$no{H)`P*|9X ?-6EQYK +6PXysO!<!Ob췖%G� endstream endobj 187 0 obj <</Filter[/FlateDecode]/Length 21278>>stream +HW9] <cWy2937@_=x v4|f~[m%Mo:e\n� +?v_Xzζs *�mYUs vzUnXTZmUlmKG'̖] Y!IRo* B7_,2 43DxM 4:[�8?аUL vE +Ub+ NmSs08r?8J +o,k:1AƯXbFx 名�`zN(}[V=匧&=֩TXw%Xw_¼ڜ +Yκe{t~&$6̕cv5M~ZL . }U,WoWXtʻYQ!IktT@b怘w>WS_acW˾ǟe?h}i<Ucqwd0 pA֥Z=AYV1w àCkBŌ , 0F6H̄+)djaa6ZTX+h,Ȓ@BZ`Yu_3yln�TY +V9°ZMX(B9GuLHj{~NtGOmY +5Xl0!e>s`pL*' +"$^E {O<î\HF׏z`VXZQ +%Nb:xI'8BQP0=7>W/qk 8ɺ18zNtVBi R#*VBh @;(ÀSO"Ut"{X2HǶVj +Wڲ3>Uzz~f"Bp J0 ,P^  0j[lNz,%M_ ƕ= + L4ŐSX,J^OHMÛw0m-Z$ K' +Ԕ/Yz=?({vSTjn j4 3M= 6;imGP!(yO&,Ů1c[2OCGg&;-ڭ@ @e6smJN4Κށ0BIfyx j5 н"qf  (]I*Fv.8vRAA_֊V3<7RK*?ymna~M g.�NNPs11ȘXyX'0H\l@vˠlsͻB%.,& z U@6R�i̶CwD&}UޡP҉Eg]8*8F^X 4흗&8 2') hJF(+kS6^z L2o'X;"hpkwҪ91Bw6| y5tW�7Q)*r}xeStS@TNLj&/6?UC/[Z_TQV}2ޒhf/bق9µAGef.,{klaE +eAve#&|կkg,e>j5Zj,v*HaN>$PzR쫨-%w+̢Ш u_"n6]X_(+i5>wҚQ}dOd�z[q*ĺ.-[-]XMnFn!8x^ :j~ 7nG彻 #é`!dMo'a|Ԍo{8O6[Ts/ъQQLX MRA_<xs]s |чΞ w0|#u#+z>lW߫@.t!S Rs.7 jP~/DHo&ʬ9Җg΅<#w0*L2ҋxʝ:qBo^:Uadu{iԜ>+f0Lb=pr.dz ~amq17d%fRqXk}<J"h_ Q|ݡ޼ i8Wag;!"kVmywoǢ) +eO`Llepl$]A ɐ[= '> +Υ)0d s><iRKY~>[18^_0[=! rM�iv0y?)XS+bANwj gR\,MvrrzWf@➳＝4ɽZUUMJP:fn,[[3�32ڣva4g<A)Q[pPPZ<bnvNmLfb=E [~?g3C)@z@B`9 +Eb\VXx4ȚK^ +z]Ӿ1%voՎJrNwQ?8T +}E-=Lb@WZ#$xh[xSeczq3u}ЋKt/dg d +@›f %MB<gDx1蟵4w#Û͓}%nmޔk*Y J`h۬jZi:yїfJյ2rycZBsZ;mb]h/9jR+Qɶ2jIʸ ]^Y:]?#V� D^<`l!\7ny5gc%E4;K[#Mm<q#VxmuK . lq>cQj8Tw 8`9b)f`J]> Im ]lAx58p=.?ؗ++g>%lp}t[p� +;;Zp? vi0Vyw 'iu If]4Tf'I- :K5? +Y_RVShpcY6pTnR{'nzUwO51Vr>ҧӸ�֜!8|PtYȸy�ɚ}=VKl6 "H`CfXgP)_=S,Tczk?_FG41<*>9Av\T3u &k6=Wv; E==b LMa{yxǂ0>j 'y�I0k1"9 --ZMo'롴B|)Y"pbO2siYF&HpA89C.{gHg '[z9|Y+quB`o' U c<;ۦw3RdE*ɓ}60L^owf)'=bEB{g6Α0OA}�-QH8U*CS+�fΫYuPc6`rb�Gp u;fh;loդHkSF,Z uo^JɲZ<M;0DX뤇BW^e9@X`i/3JMSEԖ6liV 3_&t"bO-Fg.UA)Ec\2Sgzœk5ub_.BtTLr޻0 %a9$@ N3NT%P7}!8Xƕ^m\ ijiΐ +^ޮ,#Eɍna| ,FYق�gTeҪn|3kdIn9:}K@i۝)g+vd:v@(+<SU{3x-[ _vIW,v_%s|<o,|  Ngˬ}}%~-[0g=X儧3u M1WmӭdLl3ƒ9L9j`nlj.S姶D,'>o#ݳφa `.ii?V1^mO YrkjkdwrWr-lN1i.Ru2n+G�펒`k/#1>ro$y^m =_;)K-hB`zS;A%}x�Y0EW9t @nzxWO0@LB# .>hyMkWG9"e r;k<P,´ooKxT%K2sߨ�k܂J XZۍx[#93BPZtD}EwY{77ߺ3Khkט& mU, 8ȥ�p:_ 0 ^N6螁Vծ;?c;Y4kc.p ,Xx |d`Zsal""{|JCHoMiU8`p($q2= >< oNvj% +W_ `cרK1:U]*`8;[IKT~)gEϮ(oR᎚kmQ;>xZ7%�#\cw�&&vV?~"G3 πpH g |zao XfߜEY($lh%$2kmQo;nSmgGwp>z�kt� gZ#W8&ɽZ+|l툺Vf(;39 (#Yl +f8l8m<@ YPs-qpZzS5~rN>*b:Ú%"lQ{ѦUv匊<*oZb}Nְ#_L@ F>*hs\j6j+8+{i,5��=Gn{@ +*@oZD(0f~ U\.~vv&} Rս@@>$zn)>tNMRcQqouWX",%jN4嫦Մ`* $˘>m즗۞y ,KcBwjБ .TPk/Csϲ`]lخcYW00dad,}nͮKg,ӭ):�75b�zmyК&_b%A +l62kcWyl~^"D) }> crGT0a- +xN;ȵ)7yٚ+kraXSǒD&{VgbLEg`I8:+0x+4b|ء4-t%?viĿ͹ۣrjw֩}s2њ,%}DԾp 4z'ۢĠybDwy,l|a-Ud M</HОMyskS.()yc 53RI^up/2 \ +<M;6 -uݣm@7s]azEvAo>&@r 80${oAB_)+QfH0K;TGQZg\~ڣe2R* 3Z# |'vZ(LzLϹ^g^ +ژ1�%h�seJ5]JJW�]U- ^S rhxZP}p&ܰrbC_%(|Cw/JWIz΄OB+pp l,ΰ�Srb +wG0Tz!N!m*ZETmD#.`SߢdI[y;  rBqQgPd_ `$.Qˮ/mu|L&`!7�-c*p"c]!OaqT}�]P +8`'?I9gh'į;) +]M d?hC�w(]6g-?5G0н�%P[UjX,pwe^Tv-8Pb-Aaʱh; )~3)ZʲHƔlhW)gǧkK`ZnMa*ή@>k zU' +p ̮M}4e|E 08b%˭{MI%r(Bvca|m:zmMt4ݟS]_Z8UwwL}Є$*XĠڋ,$'e਌a= FG`Xm^`@kgs山/H +r@9 \0~hxS|&e B>KFSh2aFK]a͊JRvP\#}يf�_Gu9;kZI XNmM9+a׏%P?zMkF˺66#%|hfSL}AYjC$XM g%9";b(O{z63<vb F̰NB=[ٟ5q҇ �b\]Vw+A0Fɟ Ø-X kŷuW9TRVؒդ2rő3m;_�P X[UDgM&1G]h9jn<=(|>HHd¸ɿ]}dcr €iϽ KaY93na[6ua +藃Z�b�'%0e@J1 AN;nt$qrb.q1j7w7r}٣Y./[o4osˀv �NИl5dR}Lx10|Z:xmk[ ew<R]Ob{S8ʣѳfm S }ʭ>F o9anmw*.k*Kv1<`aSՐ lt!+/ ޵dۨ{~o>vW$4j ͼU|"ESrE9eJl4Wy]@r@5 !ʩ=vQgcEFpΜ5c9kYL02@kQYM -O\pRf[tL)*r;cWRdvռq:o" [DO{;3+KX]e21ld䨶d/rѪf4iVYJ3o]xnS:_i ^/8ruU!mcn28=2J1 jK~ϼܾhC$&$O!}1ɒQ Gޗ~l|_sLkf0i.)%ObUoz %U9:�(vRG}i(-h3tqS3TU"N즳=KA Co-Z}�x~hį[~5:wJ 2q$=GS FٹlfT$omR5Nal/$I5-ɇezŲ@0..w}:rr#z +$+5ߧ@T2cPDM Џ J#{E7 +1DH\'8ɾck|}ڈgq_, +݊yskaRl,~Š/ē"jq&ץ= ^4 .GA=yv{}|WI%) İm< +WYfO0Q'r,ɷ:O*SdA;4cH0X +O՛֛K!u~b[_o-N)WA0~{�&Obg\joN%x9a0 +&#Py2}H 7vYu6 Q4tK%gJC(E'_bTZR~GA2 Bs1ڥOFONE<}.'m%l,ǰoOGw7tѽEV՜^mH',:)<CYY=Id? &cX v4=D]X ,'\ J6ŀldgs˵:AX7<|XDm!/j vb`<=A(Y&=*zJ0 w,y +ni8JdC!ӷоj,A4tK0%BڿD%@p696H@|YNGj -taM׏oj͵e=pJaLP a=e79m$V`^ $j!GjGmٖ*_ZLȴVwh URa C%UXeP옋#$�OkBo"3:u]`% >N ͤ<|'-{(WKf Nm^ym[K`'"\;ŖA Ԙ"'&9``Wu ovmPȽYl LE.Bk}EoaAT=-ЫcܽE߈TAAS޳2=֙T4+[5~t\}h<TKp4C^@eҵa1.|~%'42iُL# XdpT)5 RQEZ%XOag 6Ϛu@Yfm@bmfEnuosXW2 ӎrjI>�%LD&y!k)0"HQާ9d}"=&Bp7\y#}3C\7U +s+G'MN,Bby;;%)iR!̈jybW_R7Z3[2q>kgOz;ҵQn]xۤ& q %%DoROS LLHoo5O@{fAi-3N% bؒg!H߃t(c}`wg"Dqvf<x&/a@K8myاjp)3WhW3aU#^Sĸgn8^9s3&; ]mbOsQXFfCnPdq%Y! mQUs5AU2)Q7K;' +*[͜ѱ3N}[} -\fؗ~_2ોCf dDZx&T"C,Ԉ8l~0v$yz*CX鶤KYAH۳n)!AȿT("?Lٝ(Ѳ*�au-9S&ܧ|ڝUb�$~Ga'(ů`697S|TIS Bi %j k8cv}.EcԆENZ1m/ж f_|U�GoqB׏tGa]]0؞Z= qE$.`r~n%c"=9IYx`L֐؜OcDPS} \0qME.!v:ECW;`&"Bn4]bp+;l9kC dCbUv]@5}=TղKqqbqo:_^!<\3YDXU{˽ɠ.GD zVQ + Lf,=zwn`RZ:G헬`G;~Q({dz@RI&O!؛z->nzV<ƭ 6>p:P]ak+UA]W+K̄2I$!հQy=K�̩nn4_g^+[c(ϙ_n|.g? X`x_!$Q՞p{ţnLuno.:^Z537 +>~ 3vqT,orv;hJ!jq1,/0ggy%K{csd٘tD + WN:dY�Z.zhU BWRl[ڼkҵl.QeG` |J^?7h@wYNw H1)&O`R{ج~] +AzV*c&[ZPvayե{NDv'dP62NvTB#$ (� O{:hJz @?;Wu\gƽ0^H0I! %lx`tA+`tW +#"6hyj;ikoyًe*m!s"8zNϮEd<LjKw�l "So#8וل.w`eue20 ]% m]#`aJ-mXHzEu^uY�<_z`y0մv\�b Дf"6M M=2D 9cA=]9m2o7PSB?u6 ϑ~`H`HHZbceϝ 饳) 7<=o>m�h,Lѷfqy2#hp�b mŁhqgA 祔7tՄ퇔 C*s~[1ʸ8L]^u c�ghkR1diKp4~gqOr֐<jD._�M)1Ϭ-h&WGGa"Y2XOc룜)!>fhrX߼7cR&9okq lCeU8-Q&܃Q۴r_]pγZ1bv�37,e9)8A+ +OQe vLAOfV2滞ŚwQ6e%s!,rihq cVƞ!"HΪ&--=ήyX!s-'!]v ;n%gTZӫ'v)j0(2)0~ߘ,HiKnkėn`͙mQsr�$je/t}H847*!9uFDܚ k[f:ώ%p Ol.Xm4rGdTVi"~L^M�v -4 ^[ђ yrQ_]ʮnG+PV0nF+\/s\Xmo}uz,.9 bNpܯdܢB},ӂ"Vk�`c\)�-,@TGg)@i|+# fG ;;J%ۧs"/z ]d=-al'`\Jm2`c r"�Gd=\FqTGaeai 7uIk˳{`JF2PE\>tL�rWa6)N@|ٴq[f,)qt_jӝ!<Y_~ &d 7bQܝtr@t½ZCWo~c<PwRE?Ϣd]gɸ gg _:}/GqnB4rBnӀ> W=՟4x72T8ڴTLb2 V\p#K*d3D;x`zJ{T\Vbj0x3 +tْM9AжMSOhgj۞ulVS Iz\.6LBz;c&`E AwtYr J:or.qv5+(fi,lS`ɳmU +VاHʫ?+>Bo]$LGٺ19Lܔ>S轢99? 6JeVA ሇh¹DuR=MԆxsCUtn]iӉ)4fC7+="QnUby^js-Q\bJ9u^1+W(b?Gӏr0LD9r*=2Ѹ~TuigraVnrٹ1Q&iʰ8}IW8QzoOo�hS/܌=ЦF2 +VЧ[Yn[WƫuϧT\�7z. v0ndHvV˩$>;vy+YDgSE �Ul{1[fePbBFNH*YxA,><t<WYj3P~'~?,ֺ-ދӅZIp7a<?B +"һԜ;ܮtw*0Om+ȇIӀKΠ7مqe lH?pV$tW3.fX{VgXzrq,o]aRDHs52OkkW[vkKَG;?#> X4GxW6Y'/ }Pz?qVڙ.:,t%@l�8My à5mSd?{ZPk.U;OW%{z5i6Og# ̺W]AQG\X;{*w܀q߰(˕쵩%^~9 N$A]y#]%i5gƈ-@+#w$ĈI;E�CN x5O@37dr�RφtC\ߓ~ 'sBY�,wmScX( U_S3fU�Cnzg<rv'�EmQSwțvyu7!@[_Ώ7yaߍU9C\B@3qT ^,Ο7=';x-96_,$q�"'<̞ǀd� imv9P,WL?3<+ ݻ8d{m*AW^xz� 5a~H˸+7_ՅcXr`7JxSzס ~B0γ+=g,AQpIN%nB\+RU�>TlW= ;a/*Sa_T9EzlǏHHʵ2csBm9$p=ҝ9UEy ݜCZvצp[(b9C\,+&A�<5�nM ,tt1UTͣ *sϐu2D)1zW_ůw*on>A%Gcu+Y]w `B.[uqy@:dF- ! '<;_=}#@*Z?t^ZV�a?^lO;ujccWYƊ?Q%z%0iz,ƽ7KfD�C#k,͓(n0"pGa!i[cP tZא]*EfSc[gtUڂ +p B[.[U|]ډp ?}}0&{*sm4)qB})K{</2Ncn=�W6*.'#NF([pzGT0FE@$xL�6j՗*s̹EAMDzٴV2�}It5*ՇYt5jJ*6<ii2L^3rjub�cfa|sXPk}gz21]WՌkoH]Mݚk& +*GqTWmVlz˓ X7exv`sD?i7 *<@_Q|c�lb̑<ɳ,S툶 dE~i)67(c<Uf +ѳkgt(Ϯ p,-e%W6L5EAĸX}bP#ë,xBBC.g愭9UW2c <wD6'(,n+em|2bW4lmihwd ykq+ ICI{hWQrB"e?1ڡK$ۇvM:;D41hG/G٥>׾C\c_&�8}CH.�V�R yA!Vڅ4Q7S bVwXZmA,WmQ?ߋ!'kaМ Al `l.k6Ww&;v0Y +9fNnxp,5\/c +r GIc\Tls1Kp].<{y@-6ݵNyhwy׿'|r:<rhAXK<<tdߡξ)U׼{(XIkS.; +Xdo +`oy9F+An,>| ԌϔR+-ZנrlgT`^ι^w3g;?˻$ZS|[F`[ rb`Pc,oQW-F̲jǵ哝gzj[m* YŰ6:@>4? +&GU$6uhL'@o$n29GMS-5%D%:G[~ %ZLK>3d-0jI4ѫVMP6Own2LgU-1eD&Pc77al/fX!J\&n+bggOwI4T˵aƠɄGŸ :w%%.VeZa|`Ƈeb^zz4bChM k!uRƘm�> ?ƻ{;Ú;[:%+{{}5[]rߞVrݷB�!#<6:�Ae\"+ gHٖп1~Oe~ȶ1ޠV{- svV$j asO1=TN+*LɟK6=J<zGѦS(ם҅ Ҧͻ܇:ͳ�L OR{~|kR/m{AfR{fe/ξ֢A34,AxHRQ%uK ~?r/(p||o{+WsT<o Ypm~xߏzk-~5rxgYPvV5h-fG֪w7]gAƨV[! Wm \*KQ'[Znv^̔AŐ8-%c,bݭh?>VBP37st gk]4@T r`>{̳=!j<&�*qK +[D2OW?9`T�e~ksTޗVUivʭ b>.ðg&�c)ʼa%:oiMG `8;:Ii̩J| m֓7ѩG* UVZ&Eۆ[.m&a1" Xz67\[EHJ'ӛ�ӋqhKj�H?�$[ PZyCJoN$5o%qɸw{m�&Rq<[R0"1sVTu?,8uݸ- 3q2w9^Y<;)n�`jG,a+=t`JJvxS`ԠUκty(2un6{g#`^!ZF\X lOs ;.6mijVr³r9HTDF +Q"S%5 '3)U:paq'ް/}mXlOm-u| jQ7 E5dLk(_|.b'Õ)ΖpJSNDxFU.SlBj65ٯ[$7 p$ń<Pג=cY<`%ѹZ̼Fׁڹ&L|Rb%7BIܗ9e9Ġ-#rmV\MO7a7͇(aDѶ\M K\fPT̨8^hM^Ə!*֐AՓtaLJ�*CG�c/v[KkE 2vİB[ٵ%l&E^7+b^D[ +h)Md VաDבAWGt.,D$ #!ϖ.@)ӊPjؠ x6޻]G�cLZҚ)SmM7�Όo8Sx>5$49 'KB G0y]x@oJC"!Wc֫MiB[OЫ X1A6T]wF*GJQ^L~-n⮬p\DMl⸹6iS<�T7vWv�KR't[?'�{]xV=4'h,b1 +!5~?, ؑ9 zZ>ePv$;@,)7{/]7`#yJM{QTjw9K^ǣFf-lZA Vߧ Z;?fP)2Nԣӓ<O +<[8-XR.O\f<~>5RA]1DIs! /ϚB 2"<}$ŽbU=!gKe+wGOG#B$`�g�ZCK/L鋰y;҇BXC�tYmLڎo-m٠q|=D#14@-…ZApva__&<ig OiSyH >үY5 �-CG;LBlFV5ـ$\�7)*z-YQ�3 `yYK+丈ufIz`/5G73'yTk+jkh. +1u1m�ԱFqg4Q iKg?"9Ccz>\~|^RI3$/o36Z=`V >"p%KC}_ISbyH|�`AǤ )O?4<ip6s}1c,_߂WNlX>ݦ@∺o~>*a)һ/yJ:Xc{c:r3':Eu[PlLLtVgc]p(+SQCm khb+!~_lF!>LLX6n9Gh2}7i?Gɴ[ȧIur~AxqB倵,]s�cn)<Y:{l%XPG43BuK$w$:^M-/f6^7 <G�4D4,&az|xm�-,:,=T4|c\Ӯٍ)#[g(J)ĆՎT~k$/Y[oTO>t̸:fXG +cEqq2DwU9~3�_/gjs3OJb +(G5 v57#PQг�~ +żY \\plОa�BG}fZlz +;#Kbdp f<fJE|G[[m$XGʼE7'3^|ϸ飧sbWَ*=KtA?Pp[#.tej#^<ݛjzDAtcg +cy +c,m1v jd0%`q+%(((7j#_SLpV`rFI 򬀽1A|fs~^SX]?%CY`r0dJcyJ8jyL$~Dڃ3P=j "S 'h + !KpmkPA]vLͬ^YI80c� MF_*6Zߧc.B9lě_.owš첡Z!p @~Fz^-[O�9 ;6+7-H(=%C^̠RZ|I7UW"nׄH1/S[rG(cК3R5 o&>'|މ*Y͙j N"=ǥf;%8 ~MvOHLj:fY(nnB'2W=3>ۅy7Q;!i)�N*}lxѽ~nU +|"fQzd}^<#'F h86aț_j|\#ޅok<Lթ-:4.ڞH%,`d?|W=d,\ieXR0lI>Ps9ٜܩ(hy%w bQ2/J9Czv+}w}e]ux)[̴:nOuV sW&GXV[IJS) ֈVWa] ^ՒюQBMxEխp&K>7Y3#Ұ (v;@1f4}qC<.K9Q, fƯư%zqo=s-MtBb\}&y +shO`uCgWf] ,_=l"^1{ut &̙u6ED|2 ;eB1ym[~dJ. nifbI"WZx˯AZ_Jx|Ǝ+]ZޘۧүϱUdpkЕ V, +kDUA/M<I/$VY;?-F֨8w㓟'>{lL1<E[txǶV=�.B0%<~1@= \;Q#5>l&4XSUU#8Mq,ؔN|Q:<PNz+z3�B εm+<&A63ep$^c +kcrS.f AN 6֑,rdaT�^S֚WN-gV cGpeRsR({D?�Ľ/hA�MhMMuZ[]µ*zx<—ZÑAW +̚16:uewi4�{v'9+^'_J0k@""k&6:ۗ TsOVAۅq:#2Jo�⟢?yj?l[s^@s;@3v �[r<ۺԙ42BiWd +bsufۗ[GZ- ZX�ϩ[zXwTE<L/[Zsøek3h,4Wn Ǹkȸu xj#`- +;za;92"kֳBG覇0SIi3[ghCl:oQz|ge=i/Ei*F`GMMw8o[t9DsԱctpRI}mWY{!#Ym]eL2}q`ǰzJWS7+BŦ(/z^/& +;ER Z[cq׺Wr}.*-]WY=+ e-N<a}e+%q +,l{B):X%A j L1i V!僀n.זpnj;CfO߱)4+Yy9s^?vvC-x[ w p .(yiL8=-QOn�?2x`\']CF/ CMxw|q3oyKR@L#c� 9s,ěh�1p9E+ +L {g�Qf~<v/n()tk)ײRϫ7WS�8bm֍kƷbɪ$%. +ڠN-FТUxIb�VY5CnOn#3yjΌX=R5'Y |nxtk�],gO Y_Xi#J\�a-43m=nu,إx$?v%g x4Z:Mv�?ߝkQ#T)[洖ʲX@Y|3n%Ŭ0`|>8yh&؅Mjշ V"'VZzy p<Y57GW'.x}n|NÁ߄kEn-<vm܈}D/� endstream endobj 188 0 obj <</Filter[/FlateDecode]/Length 1659>>stream +H{Le0UkV\ɼox)-THpI!B.r89𾜗 ST +&O6]B{ackq~y{o+�ۧi[FP{- {s,g\SϖL "u_&|fkbMi0|k%"S9Ewfz1ߝ1MӦbWPϓL 2} \3}[d*M9SHGuZgRRgY]>=ǷUo�;H=K28%bEm⨻$@_ܯL3 +u[簧UZ }+S,p9 D`AYN*um{ØOPQg!YjJ#9m*qW$@_ꍁ9G=G{p~}SVdCeijn0|:[?jTͨRÞĽWJ_}>ᛶ%D`!SY]\~SVrv9ɚD=?,E?OͦpN [*hϊ"S؟c*ԼqE+zb|ufn=J=;,4'a)C}OT-cަYa@d +lʕg�=YGx'xO=;+6I?\�=܋43An#+Lk/W-9H/Tc+S7 +J>7Lqi;'<[Bb'Pύ̰ 2c dŚrm{]IuΞڅ=;zfz?u/[8D3}/s3#3L8{=K59RwL8_Y)76&Npegz͓ct\ƪMųJ=/3:l+U7].?N36>0ć peQgtAcQϋ 2cEZR}5y6]͵ְ wYW\4vB3ߺ=nux&c QJ|Yq?ñfE4VSwM r9uәEWjÆR2<^ktgs  2E秭.*7frot0pV\MA=#Z?jY!”4Κ^zMZ3/FXE=#"S8بŬBը;'@yGwwbP5Y˿~, {,�fl}7r8 LAc8_M;u?ϫP-#C<'媥Ў1pzJ[;;'`b`N-=z> D`11ڷ;r{'WK/4RFoՔƐ p5M;_"_|Y?p&?N[48_I==|Whr-JIO=[npHKբ y0\$ޚz. D`E3'88$Eas]0%Ϣ>,طYT/ĽO<n;\`@d +ZIE3Z gW�a endstream endobj 189 0 obj <</Filter[/FlateDecode]/Length 1920>>stream +HyLw_!PNdY˒]m6 ֳ*0PPJAoP:alxyDa2gQ}}'ĔTϲ#/m`̭_y>Ŕ3߲~~x2 0B LQ*}| }L5l Qhs-:"|~BW=/*V>hB\q q 7]\yAD =B +XbY0ɷ*f Ti8ƬtkM{rBgP$\e+fނ!OݹCLdf&BzP$<'"WVZz +,>| EUE E̹|>&L�tAC-:"ӸzƦ+Y*?Ti+:"ax`Y� Jg룆CgQ$,'05{U� X|*?܃̭g(mj. `QZj*(ۍk6TjIJ`2?P}ڪWdE?{=]L!esGL^Jz_a éOWFؙBׇ!b<wesZ,M]=S@pR8x{}n AR[2leB]o9 eN?%<kEwzQfAgSMLt߿ dTZ'9 Tkغ)+]`ʎn}pr.k1٭;{IJ`R`UG,O8R_-8瀐j-XVnΦ !׿۠(i,-_ooRcZ=w7MڱNn^V@S_a,1/kޮ!{ys@UǘZj3*⯳_˺@< ,w̤UAzn˂ʮ֚JY6:"~dA&ˢW6,mpR}iktFEH/Mo]`uFyyz{V1 #gp̥~^bnBTOW*7BzGTK" Y X˵YW!9.\!utXF~1BZFeK2߃weDi/1ltVEcПJ1FAzGDLϭ72t:"a$\qn*γi=>?^uO'^7 WC}W`Rc0r3ޓQ`;2ʋ=hru_y Y^PAgU/Y6}ar?z!g +W\XK|\hz4ќ;՜Q{O~ֲbV{G*e$Ǯ1ltfE!dgLe}n ]-> >`5^=/輊s.=4?ܩ^ I&Z0sQ}wqpom~bSCgVwBRg{йBJIeݿ8:"hI pyC7zX\)̩WdE?;Ja<.eйqj̊n G!@I{ZlV}ֱ\K7*lн ,TQΚغЋ+?ή"L^нsǹq_@>X|*?!ˮ)TOHYv6t~Eܖ|Q[ר㺶ߟ1Y�tvE_�%u2 endstream endobj 190 0 obj <</Filter[/FlateDecode]/Length 1612>>stream +H{LeK1K][Lör]x²"*$MR!r$9spQn2P'sjfQ񖶵Yt퉇E.>?}sG0XOSk-}2=]BW'3Q{DEE-x9ىO{Zq#οVtϲ0|훌͖�rc DB; RGbqNy 4fu%ђuaR͇3,cjco.3`P&C[g+XPe(z;=:0|lY$09VEdŇPRKZ\U8<z1lh{?fwOcT}7,L=ǂ:ƺvy-]Gh)?%<sU/3Գ,ul:Cg\, spbxO·1<DK>;|Zy=+YPzLiڋ9~gA-fOqM YPƺ5z9h)?`qgOUSϴ+ﴈ޼~0U9~3w|L qgפwd``@b_*Qa[(e5U>@}%<6iA|s;WWҞ)F]8CG\=;|s-(X縰UR쯴f{Sϡ]>/9,g[P?LK[F]8CRC1I-([;_<RgPC +6{K~cG=JWQ`PWRFٝ~ze[}Ln\WMґ6PrLPC &?0zf%`@^8Qv^^z+]>Y⫴Q52)J+9\cQϷ\1v\h/GW<CƭeǯPϸLzWvzێHFwG}H ?":e [/9:ŻAW<C*Ȯ(Sg]P%fo\ej{!>RDB=IsAy:2*;&Yߤ* DK~cW3s!qYg¨Y]#Er'yYY:04?-6|'}M=ݛs=D=낲1uGa Z +me,uC{gM=3/(|%וmS; +#`|Mvtg^PIؽ-+}M❠( DKLj{m7 "щRF޴e}KiOϽ GubQh)?#0szg_āvqBtx)j + dc<%5V Rhl!TgSԳ/E;RYu/1ekI=;& "+>0|?-��;D` endstream endobj 191 0 obj <</Filter[/FlateDecode]/Length 1836>>stream +H}LUe'X":3S'eCz`.g$:%@S4Sy 0DA0D@ ʫ9rν *9#(rk6m=9.[s~s3zΞ=G$</ꇔt3Lk( o?fɕ=oc֞ٹ< )[,U*B+Ohr3LmgǾľmW_#XXXYY-db7嵶J "mGgg;nt<< t&iCe4\}0|:RqJf]b=mںF0j\ iAgXJ*?iV;޸u}0 [Zj w :RYՊ]ދV[ۥ{a$k_ы ;�Ed:8`)pPҌU"Ai$t?1HCw3W&? sΝo:}{a$FOBQ%WBXJ*?kZ +;BH^}9)Jh=u8轘BI߼W-t?El^V-p9D +e .ڱAP+'Ix0:Rp>>y轘#trFP?�?dz8`)pP /%JBjtOB_Z ?)M ]>twfAEN]*_Ѭ<hKX^|C +۔;GS{c$=Gy;%[CgOJAK-9q3bϥI3+XJ*?olb+5ԫ](#inٓ^P&Άއ9b+ʗAHZ3!TԲ:{H8`)p DzsR!t/NCgNlX>U&74InV~g<ttpRRa9R5Z+A=2! jסJxI\{d$ ~Wy͚yCKIC{]ztL=;Ĭ޿ox }oXJ*?,ˮu"˓]н225-;g<kA<vz$pQ +29ęh\סͷн22*'^3(sc7"j̜hKzTm^pH//8bzRV{>C$8\K"ß^l@L=^<oe/7J]\c4KIٔ;?= /#tй=:cPfEhձf㍭+<8}l/LY`kҾ'{kX.h=T-8\Pdғkmct}`ld=0=FaΕh +cdWkJfdQW[or3xƐD7|F +B59vCg ,%)ߚ{s"tߌLT;E�-d~Ҵ~iL< 7#ӸW8v㔸:[H>8`)p\bNNS;t'}GO2?1v,->3ZwBڅe's +5sԴBhdv]n!B }U 'Bhd~:ڌ:WH^8`)plaDC˫UuqyB gK��֠ endstream endobj 192 0 obj <</Filter[/FlateDecode]/Length 1795>>stream +HkLSg 7n^6L_gYy.N/NSN1 PӖJ_bt¼Щ󚹘%[2/sjLtX->O@B9h oxƚe]}ܶFCxzDEE-xݓFʽ͍ʏ8Y&q!-P>zM/=92б cgVm>A@))@=G1- q:E9hK^vgO7- w3;xOO[ܝK@`g)+T^y"= V߬3߷տrwQ>]ط`y&ě3]_liR(ε+ԆPw/n6TX,M {`jS [>C@`3Q:%w5Gӡ\NPfW$}'A75)Je2is4uMgDԢ;f9E}W{vuϱX=j9~@)5D>cm ŹVb7gS<G\6Dxm v>=Pz uoMuM c5Ry 76dSdGpހ}+qD0} #۠+Q]a FxS?"uI7]SI&u_3mϺc[/Qڽm{8"w~g꾀:` xqZ̒c)w6rNۜL<ވ28cޞNPě/3(sVk.wֆ2[u<+y3"9+Bomh7GX;K&w`+sJ݈{&{^kܒc,ɠx.d [^t19kSw`+XaM,.<憧+3;%?=#๦, =:1憧,cso._ꎀ` jNR RsAP]VZ;fWbkPVSԲƺ:En<Dlއ0Ц诊.u?@}?&1fr'g7oEM06//3c`FW>Z7ʹA<{ |rKd)u/嚷ko7l0PY5)GR Qca6|yS|^GHV^#-:?ۗEqL< {S<ߔ@ѧ3o_f0vϞR=iy/@?5f}z�Aڥ˓#R/zI ˲rQ�'zdSև戾7/bX7fDԝ�@Ԙˮ3Ƭ#]V_%^ϫ>Zi(_y-ƒ4.1dܲm4Q'CUE�1 Y An&%%8FvՈK]?]}S",;haԷ<K<1i�crAzoѫS_F0Ə.$ u_�tD,72ϑ +87ɥ�h)遢/sm)}My{}"_<=DtQuD?{Яx HP?Mp 7=g Eu~V(~ЗΩ{CS"ύOUw:EbHTi&� endstream endobj 193 0 obj <</Filter[/FlateDecode]/Length 3550>>stream +H{PSW/`nU:ZY]ku<XE*Z@k@ yRy#$GBr!/(jUj}`[ߝ_f/`R*r~392B0)ɨ;~%,k1[^eHQ}'Qxa{Fh +cy 0&YᨶL77L!샴[a>KӹI)!>ի0 az0좶QX@#% i tk <ĭQN6wML#g16## 1gQ~RzԚ˯}>^ڷY wBUnz ReY"x(<o:( u,R Ycn]ϛ:%KWT BjIXmf9/(}|e2w]7<xp.?/-N{ &ܧt?b5'< d3*>ͅS> 5yvߔd:?$,ןtMj6@Qh +19Z|^P74-PW67$ +T ;C,LW?A_>Y_SD%où*s@wI."ǂ@l@#Ha ylm)YA#Ӑ@6l[z#@4-'T+.㶳ʪ@_/E^q-uȒTZ|]|X%L$°{o)7OsdqJOAܘq�GGRX|..qNe]h[cgX2�4OAM&69 5X FE`.>ӝ3cϱ^N"{}G8H j:yPūƻ( Y}=f|GxSYWKֲ iAf`K6MʫOC= ,Mt)ʵbK窵mUz梥cM.'O@4gBnBq}s9܇ZvnSK*~gX24P?WtL&Fp!KTm8gvӟ3'e}ק =G8H 6o&wRv~@A/io=eBAyD@[>ѼϛLfCgWA{ 0_Ħ֋x@-_ӜAFYk"uyj{O0MP$8Cy̕G@_>Ju=[:O'\YzRD?y̧;Og*WzA ^6~l؋\&BqYH~#?1f+a9UdNOAh* }&^A"d=2Bec<^hE< u<ω^3T<:SS_ _j>.plT?@"5_L tL\S܈͙t}#ЈQMӟ3 )m{F8H c"ylj4Hr/櫛z52}*umU?O{Y&(<Z#/T eX273积יFDž[9Oe[ w>=L?n!}I>#?1fX#Gn,y +CDj<N1T[ʤv8Wmc5-kv9M4v) tտ*7Ƭ?ť+a.P +4"Q_llToTBVFqwɔKw$ +MIt+2sO6Iw$jBp{p\@$h/_{ i}"-hgix''J޶,{Yp~_yPſkv/wo <Ϡ;%Σ4_:NLNugI*|y/6č>յPi/y; ב%77 :<B@4g!ۙvrI/=I"?1?\CgNJXaA% ^7ˑl pu{DZ8I ~%:Rn8A~,y"~By/_y<ֺnAک)/T :*3]A$WƘMe^?žCHsw&KZC6ܝ <޼tPt8مE86H cK&@^m%;3-bn·\^!J+vBH%dYsMŚ R) ~# +HnnBO͙0wD#@ `PyX[3jk?n-{obozSTK*~yj GZ7HGVѝ;:g(u?=Λ^'`wswGf $t+A^;XS Ss!)6Nzrvguz2B0) A/>h+a9S5gB +8"ȺƊ.ȈHL B#+ +iIf&jcl2MS*u)uY7j1y=tW;L]KY*c9*k3}ͣL*ϡݣ@{˃|iuJMΞ'$:ËU7C.㔹vW|mzF3Xu0kcpA�NFҁGJ}f] ~ogǶz5K9^@!NٛO$ ?p4?3DVdmJfAgyHHv/[N+G Zni*|6_Dy't``@ΒZ}$p@gz1)2Zzvbkj�Kh$ </&# $@I ) ,na+u'7BHt0BzyRJcJUm0>׋!a>KZ5?$-?p4?3n0;]^ ;;ziŀ"|znd~``@Ζwޱ_?=!fKZ|zg}v2|we 6_p0ΐ4aҸjL d;UJByxneRCcA΅"9sM,u&4twvfGY#G'aBD^w UBSr5ֿy t];;}sؚ޽vSq1o,d0!+nV !ٿ AkSh9Bh* z೾# 0�./ endstream endobj 194 0 obj <</Filter[/FlateDecode]/Length 3937>>stream +H{TǪQӣkj4&QP _ +XawYݽ,R^QQo==/Icq fspv4 $ʟ =f/<)xa,碨9/^OCxyZwWRÑ˨3ΉP9Hc}|_Mޱ˞ZaSYs-kXq9- ̱粝DӲi][W{Óc"eFizVZĈ=?$~ĔgE mi}yQuT9@ u:w)bPJ՗$=k[ 4gb O +w<Vl謫k훮VW`?5U1LMU2zԙJFU 3t^?ʘ k�KP?8xe:BN v +]@IGu 69|)|7/}:Kؽ{)t3YĂ_ij%0] w/q/0: #NK'o93zن[؉htvsz,%+NC 13w-6 Kp./'aa %x>I5>b~w= Z*jL|aI~ЪוAӕ8HtSc7t6v7WET&ٹʒuQs;:0^[,rZSPr!2?|УFkU6]y`>W0ABo槄dµCU:+,)34UF +[S0zF4g;UB/m^deOh++Y|ü_hsW!hMї=yw/SA07\])XO)#Eaw h:yp#c):iF[^xp@S#D|/ѫ(Ի8+RsÓKGgumzxq!໅ڮ>n=chS GK5Z` irp >|p/7,?'Q[ϫ}s-1Ss[WnUCT J~\WKث4gmf /^N +{?78bZW`?x\@F[:m^rpav-?[l/^~E}&XcG?pxRM ƻ)9;_8\?(Os1~mAD./]F&N}ǜĠ#7Q:7CX#q?-%zB0]*.7h*UnQ{-D_$Dz[;ezV>efEwT˞C/He:yj">^D'e|>#8<)ܕ?E~C;C~ќy9r*OXV8^z_V :0ve H=@Qƣ#e`^a$+^*}o'D#mȆNg b&d`�-c!Je<C񇫹Wݠƿ;k" nP[yw+f)QJk)cB[ c?nhaսawXX#pߘNF[ DK[ÓKG@p~~edCȞ+#�/ R09R{~?˹m0>H%[$}k~_< Fg`~8Hc0?i +uΏw p$mp!j0?DrA55-`vt?6LJ>3nQg7RzfRc;9h9,|/[/ڃgXմ-�k O +wrJ$zT}y^cG]|4UF'wuJ7Unhu +Bq%;Y_6t;vw֊|M[I}s#m-[7YP/6,fzꭴ2|[l. 5Zfh9^}Ʀ0pGȣ +wuP4Rb|@Y?ٖU\1'zܩ:jώE<,HQnqV$ 1Up +]f%G+i$q:wS,趌]#kmm)k�A<eca0pG"u&Eˇ&Nm'MOj +$ c>'duYwަwnh9;^[6։٧+ h u}(Z_X/|z>_$&i +d[%mɲ1qDn͹ dCD``L RX`-n3SLܗ-~0n4JZZ'%p{{AeRSAfˡɍ%/7|*k|N߻*Ye'' 8= 5/ Ӣqn# !1ŶkwgucؙK*o*Op)rTΟ%T#W; }59O7s풎-Юb8~v>;\ޙ> 2j7~8xӘYs?o"7̻}Gjɍ/2p2C:Y-Zkp3Q|Qn?{}/i,zj#'>iQ"5t}espEcѰAfn젤^gPmE)%:#ؗ&*o*O@?w.te^݈>DpV,*k(0'3'yl_p50&ܵE|'RW|]}wzjU`L�7G`F%n8~x_SZ#4b{gX5u!W'ߺQ "JQ>nbS1v**ĦI*~N ؇`?Θ �*o*O M~SڮI++v#f]I8?u�;Q[7Ҥeۿsa +~Lfa|t\ v17R7دwH2?l3"XcdlT\lX~,]\ a~8?,[<cRyaΕ !ZAx>Yhd`{|ͯQ嗺=Sp50Έl_tQM|[% &n Ⱦ`gJΐPySE|Dn0()>0lS-Vѳ$w}~I͚7I>03ƒ=at;D, ^PySoڳ*z;~ڠ(*lxS&qٌ3$w\oiA1Waΐ 7񨰾<mE.H&r[e~1q?aL@pV,zvX,*|;:!_# Z,W�o endstream endobj 195 0 obj <</Filter[/FlateDecode]/Length 1416>>stream +H}LU:{ZmrqYf6 `[5 S/Exgr}7^yKצ!_F -ؔ։_y8|?gî=;QQޥ32Rw'w#9[Ӿ&?OYA8ؾVn6F1V?nD-Z=%J`_�>^}qltf.ݟF{kH9z9Aw}wf +=+e=)Zw`=B~ɘZ4->=+"P 8mdMYCteޮɞڇ+r |Qͺ ۪Gd¾Tegfs.έ2GFshs(&'R.:=5ҽ!{._?J̹gU莶Vt(Þ%{L[,OO7v?3k-^{|Fy@x'�@*86e:3•z0Z-;m*}ME/Lյkw#GL{a3/L{B, S?J@U7ɲlϯMo jǻvm +莖<=&O>*cDz8/p&~GE c7koζY~=FP5rRG\9њT4[Sh!uu=nⵖ=!]ʉw0-<Ր;+G +BeHsC�@*:!s.+8i!w-sHαtA;6 9}EmG;pHy]qϯ`LQXGca"0m煰D�*UҭO;Pf3:mt(F:l!/Z\TZ~)oH?#CMMO9FiwiQO0Od~{jZZ7z~;^!o?Juʯr^)|󕺳=VoHhuwAd쐻ޯ;Zo:mW\1ץBU<#y:m\zv\u)<V_0˾qКZbսP˔ogp E�*?r] {^,^;.gnˎL[, R(o}%r,!,靆TO; npg7 rIy]ʐi@z����T ����`l^*}����06x>����׀J`���� k@%�����5g�����cP 3��o�8 / endstream endobj 196 0 obj <</Filter[/FlateDecode]/Length 1583>>stream +HOSgrq&4*S^#ޖ )⍋(*QXu ZJ[Tx+%[N,e(Sz8IО=}߇�$&./,MO캺7c{:uXÍz���6@zq1YR;SZ[[}%' ��� \8˔,2",luWa=Kǁ-gX!ciM8+g+܌P㰞vv�2,~XF3k D+֥P^LEbL%{{\LoQVbqXҁL4 gCҀ@)MWŽ~}4s|1XҁL4 gCҀF!SXrl#6 5_dgC~ֳt`??d, Y4�!Yl9]c}#(OBlwFr3և۠WC}ךL{Q-W4s@!crF!cs4z^6ah}GHjBHwmG+ά_s>%~ ůg +BP(�6Wzpnzb kR%I( +BP(==EdtڞDf2XA�����OvVrܴ(9݁,5cSQ=?�����M+WAt~ffcLY����������������� &2*Vr3ݬ/W.Wm\*ӂP + :;Nw]ξ;ݛ78U]x"5&2r |;Yxľt/2D,5[oZ\w:mO\M-k KYA$a1}?[(\XNׄ=d>a[l9)rA{1H2ż<:c{k 7ew٠/o1 =ܴt|@Fgv,oa9X֕S%;}H4ݧ[yxr'\O=ĝEcʐee+\٦}X\h9o0pgm&hǎMf/ \8ybnvVҿ#܇A* Dqn^(M! e2ADI?<{N;J{YB{Lbzg+RkX|M[N=2sueP_6^*?h?f7hoeٸb՘F?vn8}x<wfy=!$duJE{= ƟN+|߰Z1tGf.:{d,>#=2K'ϞC|GΩ?F..P^H?h6dAZtl^>+ObZ L4{cg+R;'c7KxW}^O_#cq &""H87/;C!cqi4uO׾E)ެ36m4jSdԎTaEmЫC v 0��@ endstream endobj 197 0 obj <</Filter[/FlateDecode]/Length 1468>>stream +HOSWDNe0g@1N4@ /nUYM݄8ǘ""Y6˲d,."kaQ ~{9{a8#hd<$♟* +X{?&r<;/d~uNZޟߵ;2-HCmZys<5ua=d8K7#aµ|vhrߞEYmJIKİrwWdlîCr20'Fֻ.+1u+7dkmV{ߵ#r1cԷ^sNWVFT(|NUq*w2 +cmiB}i=T5!@5T}`<,<׭NS_I d% _<ZJC0ҳ?Q/|* +X1cݯVhYtjG#"q`}~[Oq`0֬]aC^lӞG,zlSJ|^=ja6~9rE1G{kٿ--]eocY0K?b"c)=mqZn0]Jjbs"(o,E`|U%ҸE0/t:\d6&Yd:bia0C:m9r92Ҡ=7=h4N,%`6LUl̇KΎJ߬K&0]'nҒޜt 2<G7[$\#cuG۞M}T(V9Z7qe~Sb0}\>oeD1:Ձ>)_pzΟsm0sW՞Lk + +X.^S[dwWTxW\1^0P +TC-2,8#7d3ڒ$-[.ZJۡ2|M~K5J "2ϝ՗b%OMg}I˦w@Vޔ*`Kt6sרϣkjsra̒̈z<\WvRwiK:k>q|5jinܣe<2_t&qvU:t(^3tV!:߮3&&bZ1ՠ_DRWUCtfkr/m&m:~lCzWb!c&REǰru7,!y)؅U t>S_.ed|MӞ0r~_V _cܧ^cqy^zoLNa.vwG#/_*BxKU=ߣow}F|b�������������������������������������������������������������������������������&Bh endstream endobj 198 0 obj <</Filter[/FlateDecode]/Length 7415>>stream +H|Wݪ }\x3I3ɡ-.-@(%N/҄зh;>q &%lmܧZ.mWsH}ˍXo;ikuq{2KV\xaއ{l#<U%Uo ZN 8'zi#=i +X`θ_P/:U $Es%PY#5۶JltC477]􋁼PW1wcpػ^;b 6 cSO34徳q#͞Xmթf4%~=eZo4&#]メP֌[ﻍA/$ӵp(!xe$,t\l#%'^RL4t] +Z/̋-:UhsɦSJ挅2R0K)cٶ[͌o5Y&nUgALvw3ɪZ忁%FWE}u@X{WZ$xpdԺWA٘+lP;SBv6z@y旆vGwz戤i½?6'8@] f6I ٔ/ct`_~Ɩ> {w(@  1{P52/P@ئ^ɰG^Z{PUa7q?`U-KpN';[vC, +h!}?Okl[x@dƀrn&*El޹ +ngS|Z}Qm[ѝIFsxLVyn1z2T?uZZǰۋsv ~iWNd $c@5,.iE.zEP|V\l27ŗo_wo}~??}_??߽}s; m/+ׇ_?߷_~mp&$s|ᮻ!\t. ~ 6]*8(y|HI?4Vl J݁ڂeubDb)op+T CJlF8YAitzMt7hDE12N8#Z +Vq_KL@`.Bx`rǁHrrMQ\+;fX&\0!ϱ +J'qĶ-?GgqlZp=O(PHP�\ze"(A X~}M4wwLغVTy$%-<HlcRKŔl _Pl8]' U;./dk#h5H$<AłG 8ĵz)pVO1D1;=:k[լ6v2a%#.'ZT$b{j@F̀a#-5\PM[QĶ0=ijcǞjf-=@2VNL I8d:C $fMN +]G8'sܔ (x<h.�n#Tq<2ݞ7L="xVuyUb.65-m ;g$#*hqvBC9T lFY'CW䷓"O\U`}ODz 9bDʙ&Ѹ@t:}^njFmi?NTZ͒Ẉ0$,>zR"yWN7�GcRJs'DRS͑`\*ɬKxL\+Z׆ean pZ q)0^88$� +{mlWmKx>rZ~xN�#X'x& Rzl\{&m8LV&R.~uфjhq9  ]wsL92x;4!hJ1 +Ic�qqAj@P ڝw(Μ$9 +83*�n.P6Tq(]ck[<j/-LW4`;51V4 ̑; Fy +.B7Wmd`ɣ48O8HRl'?*8WC�v^Rku)EAh2X'@DqT+E`uċ/k�)@܍qhcf.s;FwFM+7G Wܳ&o%>bB3O㱃7[Oɳ"ኃv9I-3&7&o3 +chi xW=F1Fs`a)䚈}9ݚVg ,g8Y6$'RĝW#t,;3/@+]H[K[f3G s#+rY <-1ڒÜ!;sOT8ImXBږyl*Y|ߣ ?mGj+~A/)-8yI"e�Ѽ!S<S5U.YrtfBtz + TlkP k,K|9/02N|E,Xd?yp9L֕#q\҆A@Mz8z'f+NHZG$\zEMYP < +Z& +c @is8Nx@Nr.@$Q-@it)V CTRHhdvXZ)SJvnrp*4 U|ܓ] z+ApoRÀ =}|5duf/Vt�{Ebfڣ[{+NRlSXQMbu95XGŮO|yY<:ʌh-G 9Ԡ"n|} +D4[X_D�r{s .@PE LHUi[I`^db5܁P1N ix�p2FX=@qYѦuE^E j սA3"ܭ r^jÕeVrD܋4p*)v ^K&{�:&jA2 ԅ& H PROTי'jcnh-˜ee/78DO=C{'-aKH=7Ï)j@{p4bD-4u)I*{ UY"g  XʿB8_dtW$X8eGL!1Ìh@Mؚ *9*"ꑈG1@cAzRm90F/#)| #ז PǢ┠7OlEL$N 5]@^ڹbA@CFZvl$lU`/e_Y@Gd}P'ʆ^ Mє:|d,FȼcȬ`jqi?,7cĝi,'0:a6c$@D�Vl_`paY'c]H Ϛ}bWL\k UI'=_XT c  ʊ94𵚅ȱNzm= >pVޔK/Z!9$ʒAhMϝ-pYufƂ +A,DN*T7(x,Z�:Ub*GtXV*Vqrq 2TI Y 裾oOOZ X`r +c�eZ@PJŨbOFp&ar3UoMzcĬmlPTj.Q rCXgzрjRt)LH0@向ZĀ; U2rTLğQY$!W2"bGE3U(߸$h/,5N/�BIDA8 MHZA)'"Bfm*=kFԨlFPs;]ImJfG@"^7dD*ep'ג/Z<$|ZeU}dXӞ ]Vk)Q-Sԣ&}?Wke@+1J DAN=7IUڇ0F2QҨl-ra) AZĈ%&M>�b]J2谳8d6& lƜCV#5{l+M#qh6ɜ .+ъ(vE !J8\+bĪCC@+N'cj>Abikc̜!V'ʗz鐅0 +}q%h* *>+t`~K'K$~V.=fX1D^0b@'Վi a Czֱm2Ms7ң[EYԣARDrtb5d2>)b}(5昷p�+8Se|p?vkbi' + +peZl {8uVmD%8Cdm^d##>'*3 +u2֓yߊ0I4 )U;S|1.ή~:ŷf]>oƱdd|to~Wbh_uΞ5OVWgW-[7wz߾^xt6nx?wW_a47[>kG4u~ߏͦWeڴ==Y򘈖mj9޹[GtͥlŰpbx;O=*=NUG8+}jl^y"!;,{O'!.8,1nrjŞ|OG?>Mݭbk[G^?[͛P(v_Gq[Y?\;x˿"|l6wb~!}@> +GgXf6Vˍ[-~� �>́\͢}in1WTz=lO|'wR{'w{ ]S{P{כ~t'{3 I}"gOr$Nr$^ro~;TꠋM\6W/f" R mǫo7]CgǾ٧D/W=tNHdVesW8fvM!'\PipޫC\ ?jm;^ܳ3nXS<>_ aKQDO66͢\4ggnUz`Ecf]Q>Ax遞l EK-x1!ˁ)?wI/Gϡ<<ʱTPn}n+˻}|%=3anq؃DSUaw`@nhf.0vyœ5;z=lEq`lq=;X@W80v+s\ n)@988{k97]'f ?WRH/[K xw|xq`0+5Ɏfш+KءVjz(**Fcxo^eljY~ӊT^=R9yn<:¬p2:Rڃa?T ~ ) lsQw.}'@~65avh`<,V�cnI$a+uf +rŗKkLV~^lޱ18mPimJ\ֶ<:&]xDuDTV9CkMib1aƤʯf!~!szIVr$Kof|s|^]3'ڪil=&sgҥ=I{<vq%^yWI{H "+S0;\O[}ꦩNBsڒ27͟kD mEGيt!D +䘸<A"Y].1'Az.xDG"!]y$BBƏEܜf)eöF$ ?|Kb҅ܒr�!l:/^v^ހ/ϼKoLߐK|8G%g1yר +G.EHI1$@6)=s�T@uyT?B4JqXj¸@D* WXR[l4j9z?|í>J)ѭ''æ&GDrp1Gbi[D<lxHDrIG+< lFEE}íi! +WH> +G2 LOS.Y,Pϋ܈B_[0ۣͥvi\f۞I&&n2O<B$<v%^yWMI{hH;i ]ySO47MlLT?%ֈYی1BnFIbg9 r!= [dv%:%ɗP%"0~,4WlIȞ.7%q[.䖔.Ag_/yXogޥ֍7oH%>£͖kE}LSqᣏI"`$$Q t4́ww*1UU_摖!U* +aOʣ!:'+=-_J \[LU5:uymJS m0vI9/<.^d|uawL{hmDc*6D+M\vD 4X_x<;<k6ͳg#&fSpQYm{Yivˡ 6 uyEexd@MM%{@is&!n.g<n 8+6,2y"ȴH$LT _uXj[n? :^~Cx&d**n<c-$[l4j9z?d@p" +;OL0\ 瑄!VLHrI,ghDb~.BeBldlNFEEw~ i1jlJLuUq֘9,ꄕibS'B >Qeʷ㒨XKV4I0SC32ȉx$mN9M(IOoҊcS ;eA8x.0k7صvce"rF%2."Ҫ�^Z]ɤO ->7]g' %5㷭ʣ!:'+=4S'HH? CQy(- +?^|yUKзZ*qmrXzApw3?Β07 vXHB4JP5Lv@^i9 n`ʫ*)X ɥu1܇H99z +��s! endstream endobj 199 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 200 0 obj <</Filter[/FlateDecode]/Length 92>>stream +HA��  +{�������������������� +�����������������������������������������p0�e endstream endobj 201 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 202 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 203 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 204 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 205 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 206 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j�w endstream endobj 207 0 obj <</Filter[/FlateDecode]/Length 355>>stream +Hk@p@KZuu)vN:6}||.^[�����������������������������������������'۫y/$&Y$:6y]m vA.M݄l6-_'mERMYweEYft_doGq m7!ի$W7uY] E! k<<h4Qa_nVo Ðb[Pw7p}g#����������������������zBq endstream endobj 208 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 209 0 obj <</Filter[/FlateDecode]/Length 4081>>stream +HW]oY)+m +$M*W!lP&YsøسB =Ŏ3 dnV`89}Lq7ݓ[|g||3HOHkFFlSb'C#PBvq=?i}zC=KZWJ'!Q4HiOBO S,F{LPkUV'RKL;B 6jEP\\2Mth&P0W%FܵjD+POcC+ؚ݈搶@DdCW`:90*B%l ۽E&sE�|>;j RT(|W 8\\Nah>x, qv�Ӫҙ"ƹ+ 4v +alÑ┼@֡qˁdRXQ*֤h׶?6 ꮢ+c KaS%iZ]M5@c-Q[x{& #:UmǢWk),ʸ.BX#Y/m +ZRt{ Ј V`I׻NC$K}CHr d~Г{ Vk\I=odyRafTdSг%6cRlô1 ^ß཈z|? r[ +G.w޵ (uԎ.F`h=E -#T{��%Vr!Mb' +%/au(8A qƲ;Vr.]+;aSݵ+c KaS%iZ]M@c-Q[x, +ZMA\GtmdmǢWk)qyZ^C +MO)̀8ȂxroߖMN,HZ`.onn%m) + ~K[?$;ꦎuO?Xbts*c +'@pm}f%QϋzS2 +iU l+h8$4Faz Zh07Gd)Ŷ{$Kt+-攌k2cd>2q ,L…;d'E͈\0(" @D:ə1qTYBi ӍwbCRk?z Ed Z 4 ۰R5]?{Q߽)mwSB>jit}~0xQGt9]9FI#=ԓ0S�&t1ӫO9}Z]XݜDIN)Gک7>qԠJ�CiW<Q]}L1$zU1L<'(nUa'h<B{ET�>S5o}4LpBip3W)#:m]7.P^L85%0)_~8FI#=ԓT AT}Yhri7^1 ،80FDN΁D8D?_>&}:ah~sy\&ݗSgXT:@&⪏$_�3J +7]Ӈ,sfwK~s5]ݻ@4f@B>jit}~9Bź' PO:̷)o�a56C-1{mRֈI9RՍGw1e1܁З]/;0ɽ}Ɲ6 u`A240MMaPFoPgo/a==/}1jd=yh:&yE9VR!Mb8Ҿ*�b-*FE̵Sk rfUb .GrXMATQ/FVQhfHVħhĩDKKoX@*q|kI3AcAⴂ|)E 4b,mKCHp]_BcGU'R̤V{(Lx#{LnWlGI*3V۷5:a\SUq92eZ fn TAKS6}%RޢԎ(To4C=V*W@:Ry88Y2^}zbp۩ UqǽF7%G +ᾂ<rXAIF`H +"iqqofBp2z?>o~۾e]^ԽzzSWJMk +k(|@H!dYSk*AW>5i|Mk_=5>0JM㫶u1ide4 C*vF82_-zw)r@4f2>z �,cH +LGR�� PDB]Y*&(ziRVL.bvDs$2 gXr>8߻'ůd0ӳ`'G{2&@Bt3ߞyK2 +ic+Xs^sO6eRv9]$x.3*B1@`(2KB�: Rd \EƱ<ܦd8 ` 94 `ݪ_>�<Jc|ގxw]@?XbtK@[ +"E2?I}. Ʌ0!tM{yR GT +o@[3g߼7o4~xQp {*S%dJhATJ0i載 sJƵLRGأ( tPaQd2(. yr90"5#rJwàV7@'goQ9gt +1N7sIO_R''j5蟰:aj J_^E=nԿWr6~A7ɹ@A ^99?;M3xzdp$wcxՇ`ZV~Z)1}/ܮS|ݓX +S U*HgIɮ}]Til.Jun rvzЏKCM:,ˋڴ4Uߘ1pVF8UgFxf F.>`[}�@8wzuIGF7fL^"o:L-Ӧ##/&CiٖsMU޿x?(v/|-QIjw'&m!P;4YlɭIC_bZNsQtN BEEZ)v + -)F<*_ \[.溠I!Sh 6(n󨡴|[d@|f| +u(C%#Tŕ<npdU֔W[Q^kyK(r YuZi<Nβ̑g<ȞfͅLVS㳫Xڲ?k8 ei$6դQSGں5 -<)Dw67L;ї4^I;߼) LwsT.&S`?g|NF׃DBW~3>K@]�pۮ_$]-f�tOp<Z%Xٟw`'zD.:C᠉ZC,Rm=X[Zp @3cB<`,�;̡@;Ô?@ snH+嬽VY~֯Vo a*68;($:�xɓBME\N:IuE,t<zc .hBCh^@c�JӯO*^DW^T dR7Cqr8<O "$8J&?/V>(Ua|:7$&Wi@lS/h!v?vrK9ql +3! S8-}) +qiy@,$As"DԟK_ѓq�<f>!|L ( )b 9K|@}H)H9.ELL> Q +?@x,8"@j{,D`]XZ#9,x@Ϝ�ro�>O endstream endobj 210 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 211 0 obj <</Filter[/FlateDecode]/Length 698>>stream +HKQcsF Q9!BnMR2, hhԅ_%MHɌб~~#%&\g8X. >Ȏxy{!��������������������J8]"6eSjt)znv]����re[+ SU7]֙]����u쫪oLٵ����PTQW����*Φ?.kˑcN|19lf���@!# ĦLxv||C���O躱k&yra<?zY���Pjt)*3nOYO0η+JݫWD[[x.B!bw|w`WsqQt+~{{r&B!֎|Vs?w|sKa]t=nv L1)&kXEc}Caxi`#I:@{r<˿P[l63.z>zr{ VVc6旅;=>[$4%O Y|G@GTy44Te[kˑ~0{>z>zy3c=gc=@W̳>zf]F@GPNyA%3��^JgK#�v* endstream endobj 212 0 obj <</Filter[/FlateDecode]/Length 199>>stream +H1@�754 -82M \s��.|_g�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z{ 0�; endstream endobj 213 0 obj <</Filter[/FlateDecode]/Length 204>>stream +H֡@�o4}3@7 1#k?.|_g�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hXg�6%z�hX/o�ܥ endstream endobj 214 0 obj <</Filter[/FlateDecode]/Length 1269>>stream +HSTew* r˂ `S&ACꚗ)DJ,W])ӰiL39{flrsr83;w^G���7'G +?<�� ��M8���Fhy��065D8ٳ eF;Ks |񱱪f//[`}ZNj4kde\C-_>\%%J,..Ѭ!'=CT)P +ONI"?䳓.f?f$%jjӜNلb>�� D8Cm/~J-_xj2-WaUkwGeZ1~+|3Fh>Nޝ|gOi=MUj6r~RBt�� dg84nȞIZj4Ss 1}^W-&䔇PhIO9JT"7ӭ2R\ky<#*<H,W,D|lj~+QԾZze{:lުX[ɩUL=S5m:?sJu4| }~j/ג� 07K$ %ז.۪_ߴeq7kJOVoi92};]M*Ԫ)3�@?k&g�,q`붘<;pQ׃CG~*05~ ф `<vU'+[GgnYg-zf�x|M8�/K$E> u=RVѻ<�0=5ő}x<x\9baA]K^jK�`3͑/,YR|g6�iѯ Nuv:��`tKX8x'ϝ%?���̍~ FwB;�[4XXb] +�[[g}ذ5V8xХvm]� J?<{� =1It77U ]Gfd]�wPQ{?*<R#�YRR*=69cGfӻ$�НӘ?`4ȹ \BYIrυka:6&摼ՁށK3Va'�tr8&Ef=>I��V}4< endstream endobj 215 0 obj <</Filter[/FlateDecode]/Length 920>>stream +HOq�w[ 2V2cF_|_2b\Wvt]WW)ʆ?ZpGi]wvz %2Ev nMۺ+T~I߰Q˯?ך˥ˆN}~p*`$KʼnQs�j?+elvxkI Ku���=Ebn{s<o1'3���3zW#}o?fd���g? sȓ$^u�ۦDt:K7j?{3UN";D�$/3XGUqy�`,_TV�8E|p\u�cY9p;TgHkq֞}`@p;޷�x=t&ﲚ˥TgHn{i7;.UGq9oϛ"ﱪ�@$̈?s4!?S&�Vz*?Uq#Yu�I~4vtacŽ#Ѫ3��@\{g? s_3rGL���lZ4ta O]Ug��^Vq":B:uL���">zSЉu_2K>/;Ou,��ڢ;ځĺ?.|Jۦ:�D#ǵՙ[T�doKe+CXǴ3eQP0Ku.�$[Th}: �`e?z:Ewy[UHK^f۱i(�0*{<gdp6T5O*3T�фVw n l*|`�̤ϐ endstream endobj 216 0 obj <</Filter[/FlateDecode]/Length 968>>stream +HoSe9feơB6 h0Mca0D7F$M;-bq]]�p}Nbb7y<=\<9Q +�\ +337(�oYr6uX@˪ekzZ:{ﳾ~7׿�ʥ!gkO: �8YS]c-b4 G@{ז|)M+=>vP:�8ݸͧB/c4 >\]˥ښeK�@Q]Vdrt3LRl 'm� eZdt �pM?`b{z5l���^t!ޝ~'?{L?{0��)ݬy&*?66>N:��nj0QܿQgS|/��K:Zw =c'?s>z|���^2yqb.ݿ{&q_fc��xlѳL?L)�ܶ\1�v)3Gc/?`*8tp~|YH:"�F·u_: �{ailo$�\nǿsatnQi<:w6k$�n^`WxB: +�K\}Rv70g,?515xm�&e/:+�LR] ?>7_0IydtF�pG?}*q'gq뇑 =0Y'YY߲cjW?c _t�,7;adǦEu�^q.qzvxf�gR*}f?`RfMsz +dꔺ +_'O^J:'�h 0� +6 endstream endobj 217 0 obj <</Filter[/FlateDecode]/Length 1148>>stream +HoLu�Ҩ!q&r?io mޢɴ(0v:U8p2{>>i뙏]~&ޱ}w{-l}zhB ޳Ŕ|{k'UO3Y{ߏ-'T��Q.P:7}QN���&@ct?HOS=��@;=FEt?zuUO��Ў_ݷ֚v.F@7#dq9&*Q��@' ܶ{[l?i~^AV���T/w(6.F@'GfQ�B%)~1GG@c=clqY"A0aʼffP=�Bd'|y/@c=9BLuԯ? - egғSThmߩz�=-Cbe"A0Z{ 7O\�=ǎQ)�4dǭ$g-}atLJmY"{ Tֿ}LONQ=d{gSʰ~A0: ?,M@,^}|++[�w߽gYD`\x7@(\.-]z�><ZGPnb_N�m#GT�S=<w9oN?)#{swn׽:Mt�ߙ1T�\+|jwGG1[zoo#c׻Ev��pDLǟ-Os;~ߗ5ny!ϳ%��n[7u>N,\WCX_�� ,l4L<w&*km+DsuJ)laG׸~n.Qno>s}[4}E��5_lWw\.jʤ?:<wӌ¨Cg?9~X:o[>~L>׻?Y&=�� >4?ƶ +lۗ%G?RD 3xs9'uY}G�: endstream endobj 218 0 obj <</Filter[/FlateDecode]/Length 1508>>stream +HLu@?4r +6KDoh.CC8TJɹ 2w p̴Rc3Tjkǧ2qwzl~>n'UAxV.ת%589����pic ?Tν*u58'gӦ=U�XaTc>Ah|bL[k?ڀ���pc@)n +fjtwOMM[C۞QQr^ �@6UD� .m? X[xW?vkJM#j r�@)c;'T(�dn6tw*L"fעsG2閚BW 2~S2�@>]fS߶uJ�G*᷇5/~AP01rxk\lg=R{>\Gd$�Zu®yJ�Cc_7sRۨB@VuF]Gs㥧S`N6a߽Sp<qY|~O-Q��w Y' J�p~{.m4ۧ6-55t'c{Qdx8tfg 3z{7U*P h?�@>EE1kJ�_,q6 !˻$]pw/? 5T}R-58c?3~.I7#P +� +Mf2)aG�'$Yأ&iw? P(^\v22txFlJNv+>U/��&\1W�@�EܷwK]D棟muyH#JImb{5k]Gaar~ ��e6]ߺ�Ve~{X{Κ3lBj&gH /͜"�OLIJ&J�Ԫp~{S\ۛ΅PM,-Vf.QG+}M����%æ!k.k[%2 inOGvǧIJ���_vǻڽzM2 ;oM2[j; $xW���}{\^Gخe#ݵJ|QLbl{jmMjJdZ^���1,$Y%oM)m?$gP����>k6GhўHo,_]I؟Ki)?S2 ���9\B[펅PxLC-ھJ}"^���xE7,$^c?6Z0[jW1J_�# _"X9�@y*o+EWb^ +$6񬡽WMZw _�7s\lG�pM endstream endobj 219 0 obj <</Filter[/FlateDecode]/Length 2320>>stream +H TToaSMTTd{GH5#*F^M[4Kb5 .XЈ6&j4DO4xbkbOÌ0ę>f.wD�* +=ѫ9RmTy <e'{G++|G쾶ES<Չs֕30p+R_��th3c^ +�HT`vK3'xql5_]J-u �92W_3I�tt8NtR_z@q%*p$]Zbѩ-%R_ ��s߱di~_�Ya'U.tf +K#++xv9$e�%ViB�1=>#6S]pKTH?Ty a0ќ3cԗ�Yӧ;TQvVu�4bȸ{D7n߻lA�x<kx;guR_�k f{O/�b?ndW<emԕ7?X +BABT-^|<!x/aU4;R҉Y{&_8Yc(*7-zD" Ҟ\HK})O/׶K�s!͑m+mf)p$YokΑA~k:J4>Rf}FL:M8WNrUK*ʸefgPؘ$yɣ9{L&���l%Ci=>!,5Zw?�Zf9-j KBFrmsg=Fs~*wx&;!P]^5x4eW^^)01@nR��'j=X2GE`YR^]]l L~a׵bgݼh+uol+ 4ScȧOgRyL&���Q̸{TD7Y\Qm9 +G&)ys{hM.v / ] Ϳq#39Bǒnٛ*'o'���Uk?./v3QM�V%7Jkv3v0?i4_/ H)]P"W(r1r%Go߮.<\IK}+2rt!Uyu#).bf gR=檋k:'wz D[R_qw/; ]sﮘ 1ߟ;ׯd?9fdQy),+Sc(`@(yy\\3��8݃Exo]wֳ9<,3K֗1\fW;KeKǹs_e x?o،ϟ0<k>\Ua;nR ; ϱ{Y,V_9]4sBxY?s,|&~7z ]y +֗C9��<hqM#zҌ=C#e~%+˯κrrnc*Hc5e=us23E�/���0Æqkk8C]e l?XV/]py;D4vGj?HHX6EDIz{SDp��+s&?deU?غ[?;_ ,zD;i7a?g_FQ@lR;Km@VdTl(+:�WwSdƮ:^ӒVv0!SD|5DX3k$'nRo'Ϝg+/;-:�vӂe\:,K+M} LzC9M{A/-+ }>ڄv B.Vc5rW%Ubܔp"3)ۺGE)Uߍ,v쟧6n;&�?2z5G֟ʯXf'p$R􏔢\%;nz~CGLc/6>{X{'nwH +L [OַEOXA4 J_+eNc!3OE�gq|ở\8EzR8u`NK=!3Cx$/>X# Lygm@ʩ <uMOJwg4g*m?Xwʹ: +^>:2�N"Q8g?W� endstream endobj 220 0 obj <</Filter[/FlateDecode]/Length 26163>>stream +HWˎ OQO}Ɇ<a$;"ggw}1(.s"##l[%F_F em."(C龜۪5z_>sÿ|z_ wؤң_ۗϟ~yy?=~o_~s*࿲/c1I|ŹƃCjqR<Fm֦kX"~UV u#?biѹB=cˏ>򵔚X |=K\AӎTƊ0RĻIn ?TsjnHZUX>@Hkf k1':X׌5lLjJTILzF̴ImR[)4�9q >=?N zD+@%:s>hλ�mt@LܑuO=0;vT�A+b<\3ݙ8*O{럧߶3ق@P$5J׈W%fh#Z謌uzfݛ1,&nXUžБKTMtFZ(E5{pXRG@ +VAJ\CY #4HբC R3�4K1*Iղpq,R*鐣⺥p>,rBD?koI^xT~1f[V\ n>k}᝹�h\62fF̮K2jꚺⶖ-Y]NY@@ AB�m2P"t@m:7qʦ!*H,`ؽaڱa YLjl$CSG-"#H0Ċչy\򸘂S;jRhy ٙ o)X _U>䕷v>=FRI�C%s%c(7KM<\y XQy +#ڶ! aiM/#ʡm^ a:暑r@RH%q�'$9VΝ25g[ek:6SH}tyc-b3 S!9r2; I(p4rpHass41_Y7g{[ߔJ-]yوBi4;�blW}Ҩ bZ"}hy6”2d9m .12U٭6|Z dy1pS>&RGGMaaNw�` TmSm(damF3g?QF~OG?|*d]NG¶#GL=syRI'R#Ѽo<K 䭺G QtAۘitit}WÝaVg�WWLͶTMS m:o 7j?cGH2=G. , +.<p"nx~u@Jّ]@%,)$G#9rN6ygؘa( gu65:go> g~ ;ML^m%? +5� ;T5l[]a])'[(3tS`^v z c)k!GS6v8d3I١xf%i%ܛsQL^QjzYrbchm7yMC1zk+;}|JqN֫ZS]kI'x}~TKV4U6?a RnÊ9ъ'|ʨPc'-쎁$yGvIިaeP{=s6+t$Nwu q59NvG# 9JOó)ioAVct0~`1WiջUo|˶7ӑ-[ Z3% ս;_ +o2Sz& �Sq8(RjNs>V< %z1M8"t(PƈoOy> +zQ>tP -)Z^r |eCL!w +)ײy5)'t>(XՂ +x"]nQ|JX.аlaPb@V?S|nkM? YB>7Dx>uz"8KLҙ;{%;*<!ڀJWY5雦Qe;smd^'2KiAז!bAJ6Y,lǏ]f"!1Dz@8[G>^!&U 6֊})WlEkY>dR e;ӺF>yY7. Zګ༦y +wZ9 _ND<lsJX'J!ۘZ@?R$j~U .D͙ѢŌτQE6##Au~g6͘pqg'^^R0T|L^5i2l>}H>phQʤW| QHOTִH>Yd^q@1{h@hW#_m7c O0n" ᒉh["4 82&o^s$2tWWW_55Y}}dR'X<7޴f`veڂZHozWƂ3j/\GW}/* +a@mBU_/ D!'V� 0y d O<[RB-Oil ݋\jtCf)m_.Vzo'ManuJMBn|̤qe@)ǫ9&:-MD[{67ru6tT7"n]bb|K^Cw{V{kTM{{ܚ7VW79-/V Gzt&F=GȩE˯[ȁSH<(Xڳ +SV8FPZR? Qݰxc==ؓOUk7j~\twru'RGjR_ ͈֞=?4p<|8༌!pc  ul1I6e8NؐF;_oh%x ǁY#$Iad$K(K$ Scdr~r~wW˷o/[)9 ~h4'0 +f j5ϽFs"r҈lK99`o<-6ٰ5rͦ?[784Eq4&L/ }4E*&Q } R"[Fb TУ#69s;NWzyټuk!lt׮b`߄,E3q9S]1GDzu67Dm[o.!5%j |D] Nc#*:]K08"Rp^Eo.tI7bMvvY3ըP D]4h* AE]c=twq,VV2zTl|utf eY_ Ȭ4$ruЩFVobr0S9eѼ@ȮќIJ9ּ+`/ʀ`i4.Vm�"ȥ rc 3n@BRI:j]S11A@::r�k.:"*\Erݨ154&23|$[K< dP#BMVqmj<lP^&ٚ0X +YKВ=R 8ih <'(tEiq/7"PP t@J޿cfDX n/镆ըw{mBW֤H+Pdiر5ti9$ʬ8JUZ }9aZ7𝎠(7p}ܮO%KMkbߏi^zư/yI18B@uq1S<)}nl<ܨ`i*}䈱GئEXڎESY&5A77^[gPQ4qZRy@Vyn([dlqadl {Htس8 JGWTKxM:%U!# (ۘ6e➱�+:~߼ 15ɉm +38v>萞DK?{ʜ{pxSpx}Ҿܷ:ɿ"$rzF-##AJCCN{Qs8zZonZ Ozgfi�'j W3u<=JԃY}:KЁ[l$ <c&-(ϔmh+xex[z˞K`P +Ksɱ]J@4no` ֻ}x.c%|=08C <O*ϤE ><UG S8S#vtCqz{i|iui3Zaq8˻\g~{wނ=W+Q޹sR +>vFr]F_ }՟2X_]_],_]̯VПϬѓ쿓8b<[-^=ܜ^fVѿo9޽}s)?g'{l70u/_~5BN,4jEnxqzyeL +KE�ZOZz/'XdyTy&]IY wҜe%!ivsӐ\E +ěv,x9DŽg�9dw<=ƄeEU$+8G<7"/!ʦ< bfB)"&ȩ$DkpΑZuBTuq|.r8؃͕gBAT KJ`Y.K^WOr=SwJ޶ƽG\W|xcb<"2so*4,YZC{ 6ȂLl@byCδL2#IUHH39AǒbMzGRJ +q$=xp7d:.Iu❴E^&`#H2EX0<SBFZțB)<V3Q%SD'[.FFgfMU ʀO-U7[i+ȅC%  TQ"x pFJ\סJlgC*%n3xg)5:I^%FCɂ)5LKP,(c,T`C2c&ݧ5T.U=M·S @qq&z4E9x!+; W0{8q0v?P x +ƀYJƂgv /XU5ن胸OZm3hΡ҅ mZCX#,^YGu*<{9ֶdy"<}('7M*8B1V {;`7p+Ԕpjcrz1E=ɢuҶNkO=;Mw2t(x}ٸM4r*`u>a|k}gF( Ris+{ބW7O`/gfwfޡo\}{k/:‘z63G]npG@[1`(\3*a%GS?~,&)O:B8Uq뛭9FHiqsNQi[i- [8fyip׏*LY�vV(OS8q6>KܺJVRqs)Ӯ r_|�kj\<][ݢLxz+d�A-N]&a;b[B}݀8~5]y +t!'Dzc>i7fd +J8"m "ыb3nIWPuKGbzJeHP"K2 .j +j~J>"7 +pnN2N,ZHZzc:]#ntWR)Tt]�RFI@ի i-`r"u" ӎŪ�{ }^_~>qe+h}"PT*H!b%d%ގr%7M.WiZ_Yc:c~]eO:ro0k ́v^ƶ.EXL_~M-1^M(O2ɺXռ!(N~ lޢS @"LEC/̇1PA(m4Ue[.2ČV4, %I~7|0a3Oם| z,o{Qg͐=+As�.Rr%h.3cUU3bTY##&f@ l@` iE_ ߂5z^u¢]xOTe&?25^tFϺ5%rꊢ;Whp1s;NeP]U / $E0zIGU{fy* |-ӠW>w9jNɓ [kUUQpFDyrԭ?Ac}_~~ __Y$+4'J:K=tg8O82SR57d4 ȪP�t25 x1%o)‘`"qX)}[3e>dD5^1HEaBlI.Y3<n@ʏ07 { t.!UF*^cTJkEtbJՐ9#o +0h��8ʚN5nI0uӁtNPk! BuV^]c1|vV~lrruY!3%2A+5 e Kq|CmK͏6\mmC`nձ�g)B5~X:I!X#]Fu)Co +>^:{5%0E8Tdd6G΃+]3~_2]NnFU%)T3 I9$$fW +bR Ju; �*lَӳ& ׽$&}=}q|l׹1&Ixf Ȱ<ܣkS2VR."(Ю+xMSW5;vEŘ܅ +1tn{l=V5@pu-i9~.!zq]d%�9F-^=~\ڧ- AW^E)J'X-:U[?.Q/ȉݳչN7()ҁw^sKbdf^f,%ӻWjƷ +) ժĎ@[@\&ݵ؂�{P.hq(mT((.#[]+:]e2nE$n=TgRvp:^O%=3WGy}i 1wI0D9VFF7a&E�׋nty;37A@: +s@jg dE8}#3wxX:+D2Z +fۓ߀p&wD7|s +V*3a2L]25H[ +z՟5ss,1*,[MC 5 Ap[}vCrHN.*-nIm9JX6$b8Z +L{ff pqLf+>~N夐S(oz܋:b,C/8N:_[F/#t3Ө 4a(_H\'ɬo&|Ԕ_|�1#H[cbW6wRʴ(!k#"5a2A+/AT`jBۣY`tj;^8U?Cn/}bQS+R9ϩIT/UF,N[4k2,\Yxf!t ,=<莳Z7\̯@zn;\zMVu_J=&Hm9V<A7sl8U'N\V6;(|}DH:*%:VPDg"@ {g{XMu|׻�b l [[ ]Pm$6|ǡ\pȒ_ְ¿$7~*z-ՊUI%3O"5Vfe`*HM!g }K#dRi!H� +ttyJ&/+^Uł(l| c}]L(Δ:˃&ҏbJSyO/D*u!I簾<ne3\G1(F$F`UnǙsfvN]dLfs[Ayc +1I7JoNQkYMó%8݀U:W2L؄qE +M]JW@ġ:l{JJ~]KO8ÖubfPj +𣞍d|dq'=-!+5ysѵK)\mP}'ǶNWwqXԩ|I3�ผT#ƥĮ~e`:y) q]K}dXG]{ʹMaԡ)ƦvkxF8WQ03d z+ 63pl|l>Y %%Pb>c'lv7/qf͡ΝnpI&;s\F"Bܑ([12 aQd{-0%qA +0jzSB2qە+C8F馆1#=6rP,sv�z[;afө0]wK܀+~@*Bk{g}>]9rpCzQ'i2y^IabdFSj_<{,NKp(}ހ{{w)c޳1m{gJ#J.S顖Q̀R~&U# #pg#/ +_V;ϼm +$du(fR=K {8iSc:߄T&Y8QdqN`nq  \XeJrHwS~jejlj�*zv2( !v^},܇DS!riYڙ(XYBgKL62`1knU00Ƶ2@n-85YJ* 4r(}jwnԗV*5Ysu^̓Y}vb</ PO`Em2ߧ##uܭcuVѡ{?h%BkBe�G#+2;=BHc %=- ?js< #4ɂ59XLE>=tY {;іzW|j9AQS^gh[aK^Vs!l(ZЧnzN^ݝV)>}Ӓ%s+d,!x,woG}xudrRlQ)ӎaGΞ}E 9hn#]^|>46n!D7#`E>t,3ẵϗgkF9~O0Zjͩu-G +x'_ӔF'q/-Y|sƠP]x1K*z46 +ЂRۚ{aU\H]϶?^ٍ/2ֵ=.KlX1{Pjt{cW-G.-Kr�q\;f8F/jȵi's/^:x>Ε/OplĆ{?.7h'?j-WlлRAAOqnF2v$bC1_XOn(15<fC (Υ^6$yig5N/N2L +qsϫ!uݯtM`#W#�L+obX0'7)y 4̜bHepwC@�[{-h ^=TxVѼEKZ+:b2I= bd1#lOC}9Ao[uVwzO&%?_I+<%v ~Wk廉ajHh`0yWT` ݬL05ixˬM{tgԻ0Ihd|^wmRp]"=%U5jѳ~ˇ_O߯0O v՟?__|}ˏӷ~|[|^o0__|_aV8?2B̫CHv +xEFpcNbX'!Ivdg7e3oltH$qU}S2%:Ӓ[x&ش6){nw0C3AO#rL=2 ) ?ۊ2vW";Dic&'i H[῟dŝi;{ѫU& +1ki|I6 ]%O" ;FkvFy}3JT]oZݟW?`T{&抃X̊Gtߟo֋tn6gYDDQo=?}y}ǟ>RB?x>)РZ/, w!ŷkwӞo#ܰ_oZIq+"o*wJk9 ht;m-f]('avl)*CW1v(߈CnȁӋl~qG["t%hȥ?Y]FmK?YiP&n|uxEߌcdzG= b:;6ub<~%-9i|}_txʽ'oݱzQBٗ=ۏ 1/0w?IS)G{0q`-Mqau-I(A9iqXHxagu1SYYرN _`7cuڈ'?hGY'vy#`4g4,޵,8~iFOhYUwλ� -(7KtAAsps+ #XOF=t :Ѩ!X\i-urQ % ݷP(فYC^y>Jՠ9͖ + |a�hiJڵe\#DRDcO=;a(*3bp1Bee [>OMڹIar"Osiq>Xtq~V(rFSx]:xRJ:KOl>hL{ۘ=XS`  +L͍wŪf>R]t_gDqR#O4ÏLx>NG$%ω=jNl~~%l`9E[; hJ'Ĵ -z62&M 2nR}=K9k{"Y5 6OFoP]"OZbWNFkK?uO ĆZ}#M$A:>G;;_w:ORlޓBfjc1{q46J~=ˠ0J~+4FSӲtʾgk){9 >͡3xWڬ1ݮL3& nqI8\փVs3jޫ /&3Ys *H\qrQ>w4+cֳnpԢe-t 2tG(^LJ /' +P ^T)WI;)h损@_n~y?w+]'[\[+%p~2"2#Yk2CLJu$V?f-OV| _`u#ary[4UG̘ۣ(b;_O-d`xdHwR!>{`R)D( &) +1;Լ\j;KWJ͇]SsNG26Ds@!#mφ 9 g13h2$QGc}x˳̍[i.SVJYnWҀ|l:ٻ҈11pܑD_nN:ui‹! ,nɮu* @x =]\}մl0G9> +�kl%a0([ +k5X3a }FS`?K)QbxDyAaX5QLd)x4b4Z U%֥2k6vw|-B36`i�s?}mo;kJ )�*fzeVoMfock(0ԖyQgQDp˔zGZvaҢuE)Nփh)gd?ZP5D_  d';/# +Y"nzb<Ŝ<p ;ZUSMo9-C+njEuۡ_v ;ǿOԚSVTQ;1wuV=04%%I:K}i+ˑqSQu;zIQ(@/Y~_Z=ozOިˏv¤jhۘkMTz_:$񸛴e2?V5댮k3֠`8:LŝzG%k9ɶ}Ϊ7y8\bnty*nȩ-IleH@aw-InQA|%B\eyZjL|Zܑʩ}3Tr\}-Nb|-7O?Ґ.%(|)RL|]weԏpburߑd!}J}5`هy`TIժ]8!vMƄsIo/QdMC$d}&4 +2nKNl>Ŗ11Jw^? #˦N\$(_PYPh7^a ߍ﵁؋G|v $Zӏ+QvUiH$XED,*E޶-F_i$RZZN5wwx|ȉ%9vl \a,b)#qYB)7e"#.ua=o\CN" 1 +ʧwsYm9qG5CUYy?Yes#9syj!"~, T4=՜RI|9+5{Lgݢ%x {I$+Xz9r%ao!qpv`nf։#TC:=˾\hlW=#^[[!w-I6s3=0g^#jo{qQܣl >(ف\4BIH9=.1ldtz9 Ÿ)hZ$֔!WZZXzQ.#|EɃ-uXBzC<~G物"&._L0v$ 4%̺Kf|)ˇERSa"=enڭ'_IZ +Qd3QFQD!֫pJ~ŀ&WrMmnLo/#e1phn9XLgۙi:PWL+MgdY븢;I@4[$eb0q0(-,uC5gS_C Rսu{mGTòg:^88% :fyzdMvX5ꖺ\":߇ 94ױìMŧ8L"9UUU>|=F8=B4fՄvVRghV{3&`O[ө1+:RFL//�7ەAZ|p#Evb |sfqDxB>OM]4qǩŷ�3*zOv'_w>iݾ~Iem qҊe}uP؝#eCw{҅h,z�h' vUF1ԧ' { KZgp'iɝ|\ gXpUyR. +:RZgU˞h[^|e"T6d\|`:<`jhOuuue>fԑH] (İ`Qr]A|lM/O*zl뷿SuzMoe*ѕŇ^Әt$V&Fi,N]ehhS0`'S>Xͻ/ +n Ewgf ̺HK[R3I)9"e?Rr&bÓjDVrpG]yӊP ]X=s1ߺ#ǾCo<*/bH=TU[][bxH77c4ӴlGO2qꋫ}<{{/߾~wD4dverM]쏏g߿o/o<~7oݾᇏc/U߾}ۇ7~ջ><g'w#_{˟]L2uo=|_{A{wt|j>:( 7P1J9'?JXQT_Dpe7b5mSѹ!rx�,J7ODk8݄~"$5S3 FȦM-afZRIl{a1Zءӈ<}߈#r. +xW#C v4ZmBλʡFt55R ֝O2ᜋJ#[Nl +?.fW t\g:/Oo&dzwwy+,# /+uq R&,|*:d XDJ&2DK!%E|yuuv ?9Ga_7C[_v=2 ?*V@%>0|( rH�LIpL905 7IQJI#"%HhIH`2]@iTQlތ:Y ~? x:Om 4VuE*s|3ꙍW|,ǩwϺP#ZB<_FK]^mrl +*AjZ1{-n *էPQ%uuc y/X$F(#ٞ3^V~p<i^YJ<#TuZ7N;=hq P#F2vs%,R:@JG`ti.״ו'whCb٫p/-Z|~YqL4Q}]6[o={=RF?os\WO903e*#ᚫDtqS^'Y,i Qj-yj>` JY6$´G[c*�l$iHlJ#ϝF{j+R-8u]DL>kGqMhPg tYjQ@q> O̠lRaG/Zsʬq>Ogn ILH^O}"R!z hq6oGScإM3JL#<QRERO8!] 4 Yihk31"(桜Rgj(urY7b +="΂AvFX]; ~[3ɬ1Q�)vA@i& +?GLD +I$Wan)eT e[õа(mTYX^Y=_R R(<( ރ)GK+DиͱcCBΥRgGԮf*t˩vP9Ūb:Tj*Gq@ +lf ^'WU cL\="2كjS)`klFYZ$xJ j5o" +38 *,o�$kЅ4|S+i/2{!~솵|=2=K$| 6o'5:^&_'Rm-^tüባa0'dI$y2|- 2}7~`ުHthPc[m !dq`}Z9`$@`M+WR׳[_M).u헛H]� Ek봷͇/*$%;G"Rf@Q2#ã>},‚R}Q쎝WBNlhQ&^? { +.>5 N<ϧ4,� +Lkp0&>@U]490 3܁*YČ!):)b"PthX�풙"1ZPjTrgħb^'~'JF]V_6+Ձ氺SiDь|i>}eaw#Zq֮WU)q~ﴗ9$EW{ "1v/.W\d C2ĠJ$7YX[)fWvSsަ)fH1P<%OsR*kk8N$8͛t!h$=UNj[7sƭEg U#z8 ϧ@5XoY`\c}n󔁽OTyvط6.,m%{0z7^gn-^-a4/u +x%07 +gXn%wqygu +>2\S"EPO X2G�IP釻yT/n>É/;J!iЊařE XF2%yTEX‹鞇SGM;C@Ξ?Ճ8+W _b#B+ ߒ/xwZfcx s JKWF:-/}spTQtMbUs";B4kNYW@#^R5׋9 49""3wg$qLpiWUhD)\:j{^TK"` ^3zls%༁�Uas*l* +0b3O~b~#bsQäyz ϗ 3t ӝ:-|ϓwN@k}"Fw7{D,4 ~}bi�(s<LF 0m#VEr>l+Ȗ#ۂ]1c:2NA +Rj9nf&ң^Y4<Ӣ/.긃tAQJ9A&#:9�OYۦ?۔ޮrpUFGǬD V//mm&["5ote`) =ָ͙yhowۣH_=?)E=Y.s]s4={1Uj R3V'4_)\/bٿCsWV,KrawƏ }UVxZ?M=†yV`C]Yhb/{U D�ط\-bOW9 lnxl슩Φ - ӷ&#Śv-VviyZZ=Yԁ,f\}~kՀ>aStvs+Ӎ9%B]d,{cJXQBijY h wKL3ڦmڣ/礉P3gG]T^ +W @M=:⒀%s._qdfJ !8m`Q{yNu | -僡WN?.[y\G[#k>B[\Tʑ LqGhsN~ 4d ɚ*`vsy8d%XeN2zהIS"MÍvI=o{*ȍ#Ӧ- ]vKY0Zjy[jWDe79lV^/uލJdU\E! @Ԁ!'\⇧IB\�E ~EWeճv0dyǑpTib 8SfwO cTN?gaؔw~h}7bw5 $ؚt,:R?ԇ +RCMqh^Y�E~;NgaE\-C9lݞT5Gڗ`%o˚87 )/Re"zv{PHBmLS;m쨬f j.˜KI\#q8^JJi;W)vuPZh +"su+, +CzRDW#7B~i#E}\}YFn"X[4zT^Aj]"b+5n'%}WzW 'g0V*Ywg^E9 {uy!fN1{ 3xw!0/,6�Rȳ<Du](kFcm:t7!X4 w=5g +縄:D?)vr-[&J|z +EֈZۓ"fiD" <P �%Jq.M`X!w Cyk\&9v@X4`siy *KPx39W=e\OosYc؄ɼ K~Y8l:3v/QݮLZ҃_S^5~&Ql-K /?d_`uA[mdu']ռ:~jXnhU%GQS1TμŔF(MQ[MD*ᥕ̶ZN/4[`- +~T[Ǫuَ\$tvPĿboU~yWWNѺMDgspݵrCִWp ~tmG265H25}RjCMrtaةj܃uR_6$s{R}~Q@ lE]WP׮EM^TWB9Gzʏ 7n'̶΄7R+�jk~Ւ)ikI6I2/pxH�wu`ˈb*�o !,bHO wGqރPG|G#tnvFy =w۟m%; B4*K#&w:0'';K)hql.Z[z!xnZ^d, +t]sGac2eGOwdТj]#$KAL`9Ў-nɗϷ>v8B +vWS/\$dd(:D//oTJΟiğ82R5y>F6nq#i̴ Xȹim|w]0 Z]A7A2”VpMeYg2ո1n d#I:g`[!'~4]N34:GCC&t. (3ܺ;<%RN03o/D#o}D7cU't!w~Wٴ}�}]Sg xȀVP TuH$i,A"mOA:(ڎЭ@Ank#Ѣw /A$*3)k�8q DD3̋kxx9kgsytgOɐՆ@U +9]9-Q7X=nL癴׺3!Hޅ6jR=eAħC[*W?,NVZH08 *9]KJMZnԙV35 6:jxԜj\9 '}ևti0.4גA z^fjEа{ny,At0uHCa+GT /ొKz9ݯT:9ne]͘_BEb;j0d=] +w2iEZS'H=xgqP3" G])f R;'L]a ׆ Tgmf!D!ؒKuP/UT7ԇL #|+mm\d\ #Uh#{9ZObj!()rbj*'ΏǧgMc",p5q\+FsDcӑ*mqK%uKs͒zIݵşm s'w-i%\C{2 JE `H Pje5LMdCeZ5$FQZ(Aʼ+@՚Ss9J>J� 8 5Zj\V.l-`Q^0]U46E�?)Nd[:n<VUwN45| a%Kw}�̋H3dƨ?Aa)?n 6]NGT$.e p`3<!MrD�‡oq>{ +yl! UQع5: i8H?|T&gzRޙh6  *${J~<*C.є!Hbú-v'AV%ɨ ƄV Ր$ná8*qTI>r_2%_J}C ը.A+#Nk1"z:N +{e=&{SquDs?9EI*C1PMW!y^+whNQZUVOmъmo0Z<d{t& LMb[ypJl/-Cl"8h):H9ےITƪ:ZQاpjѧڪ!@v.rO, %u|TrR )i~"Tjѹi; 1h + VDC|j�W]*l0=W(8 YK7RɼxY {FBLނ9ɔk/ӚW~kŮ}4{̼&Akl2uQgS$-gT}E5뺬VeZ Q;Fu֡ wd d h&T5hnK&m uȋJ]=gK~Q=! Zt0!'p<'j?jP{2^lzQ`T]J'N�-d I^&&n̖N�xXN[7`uF^CG 8c)-C4K= 逪AQyiR%KtI/XQvllL>8=ҾǷ[R<y![f+)B\Z"BTin%P 6 +V16 , կ{ 2 Eű@߼HZ%oa80&t It]vg@}ưDiZX,a*2:¯B!E?uOzs%B>l#YК'Ukߩ>c:+%V@K,Achb. Ĝ>>G4JASr_ѵ~uJJ@IcmWhI$_1L:GRe8ϼB-MMS3R:\o]8 xJTpKy|T@_ue XB=B?{mg|@d_;~S6K~ߥA|GHa`P3*"L}[D)v,n�^DNIMgO^7D`wYh=mq|�9_X>[m+}z|z�_Z=?[=5W}w?.wկ_ūotw{׏_?<o7+?}}n_Wi~=x}{h$Z&H͖!H@WxLw6}+gHzȁ.ҡ]hFZx_څhRs(';8NH˗.aU}AbsG9-FDhyL#�21Il|*Ѡ +p[SI'岣Wq'!6u(#)J #i햌Yk1$Jg`ԩ}.5Oⶸc]+ev*ܸې%D.*J_> p/_=͕b2~F-@ zE/̜a`i.\GeƁ@`FQ1S=cЏUAVih 1i1m9.cl7Q!BO[(O')s_C:og1:L>dU<3}ȭUTG@AK:yz<2wR>~U^ 3nr)fI帾U&7wYF<BzJ2 u +_s"Z9DByF\ S*fvS<b{r_HQP057nHiHX_[ +z9hjx1^QѽУS8U}Ӧ9Q\@z*k a0:_FqfMs!⡩] +B"tZ8ڈJL:\gMNyDd^ueiޟ]QMZ$# I-1 \rSo #Ωj^^+F ( +Oژ}jk\~oLa"nkE*RH{#:^ 2Q 6~9@QFDhp+1<itJiCkGh *=iX&[Dj[1a&YK8W}Tqh q�?iX툛S1p|04сˢ {߫aH;"v9B CVYNΒ4_�|mH�=fxD]ƻ<眃zovpt +s9<v \{iXLjmZ.vxO/Jq8>4'qiҝ6E><Г!:J)J$`͖2׫C-ŊbGjS4nQlBz$.\fuW +6I?u)+ :;d&߰5 +ZgDʳĉv{:Ls) <IwXl}[$tc "b;<-*0s+>P)%vn"-_裷kY'=O^pke�\ ݭlmAB:븑r|n<ejT%~v,TEXQlv~CG J>Cl  +!ﱤ51d`Kk#S=d;=&(z{ˊ +i V 84Z+hPKfp;THe_-T"j^!a|2'0;ZC=U97<t8h1FyS\)5"Dk.iTP8֓$*ʻu,|$Ae4)ƹ @|Aff?fb4%$C{HIB\"M1U0㢻 s}c vrv[-JK(K=Hڡd`0MjkQY5dpC)[5Bo.EY~DkC6Ad'ES0] ~ DEW-ʎ^ ˶*9^٦2p#_'6dZY}ۛW's6%Rq)DŽ|7"J1POWy(2^Yt%Jԙ93f̈! 0#<eH2wKλXRPYrwEM|D{ۢuJtɘO gc{܏"/N C&`|R_{W=R/ )"8,&@Uxh5ʮ Ɋ +EFB*l杺}H@kS菆il3hD7 }ƩDsa3BJ8!#9r49<�YbX &g`�y\Y{ -qPhte(=Ss;mg .oIB{n8͗r$CY#slIUb ="%k-j$n,#5%H9Lg>ʐ5:`ycЕ'y3 sqnUSVtNqZE ٩ܘ ϣy+r^ (d; Ba3mU|I~FE1%H ~ŷ/c$o/7?~~||O>n_|}xś?>F}7'<zYGմ_5G0}X8m508䁬F3NwV$j;]']n7S~E գuQ4�cjD 7/pQwˑ*x9茞}SὉ$䢢*ٞ֡x|# )@sBW^)E'V4N[?݉fu7a#px?ޅÓ +L2<G">Bb-`uڝ'49_WSI mb,ޝ(O6!^u6GYW+ hdnwdpyPNLOs*7RP)`4J$$[Z% ϵD`:'28Zxt"?TmY8ᒺ a3r7-ahaI~Sxر]>W$@n gaa^i~)1*,!7(^vig~bG;y9FI+ (=!!s=Rlٿ_ٿU><=gV bF +3/<Y.5B|cV$*9$A2oy&FO]a$Vdch5~]5/Q2 \d WBm}gln>@ʔ uMʧ4Mo +Gjd&#>6P/cQCHZqTTSd> +"VNB0qTBmc� +qQ&iڦpkr>n}z|Kl$BUMdo^SF`Jàhlqu8gvB{[冮IЩu}8JJ1xXS%Vd/B,yuiMueFufQ؁$4=LXqB8 -s^sI.kQXP\nFƖQ]7fvL}R e Z FEcϾU*Y,Y*/� endstream endobj 221 0 obj <</Filter[/FlateDecode]/Length 2457>>stream +H P."DIUVЀ HH^BkbUDV+щHŲh + *b*51v$:iU38iZ9r]v<38șp3of꩙?ҽQ-"&Ie 0Z"br?jClxgHCԾ0.p}szEu3,֗FP4^8i6\^wk|D[Gj"++9�$ehiağ3,jB~à]g?*^bl=l۩=Z\E9K;  ]qsg'M P?* +w鎚/HRfMim qO[٪!;5hR늁?KdYg=V95 BzT�f3Ⱦ0U 0̡se!hۧ߳ݛ %$ 6Iʪ+ ?w}HM`ubk{\M󭺡ޞME@ 3A,b}?]�t�!�ƈ<41�}Vem[wn½͔A8u@FhLk!4jDŽZb0D޽;(1`WGkKr +@q=Q)ݎ�3�kVsb A84 _&!.N#IU?h˻jM%W 1G1�1hz/AQ*lguiHi @AF$KLbgd{.9Uv'fQc`{ߒ�Ln{ ӼOvIʨHa7Ń`~0ٱݽu~oVYSh]\>!l f* +Co�3gik%a~^n{#ly/WxZR"-:Q`4ugi$)Bjas{8UoR$v�7[%ƖOBAC.߻eaJ2b�[$e-Gڃ<O2A`\/XxqL8e6\ZV%FDAȄ1h3}i�[$eS=[Y&LVzc#~vuɊ$B6D+ HR6;CXgD!v7n|)u?lZwƜZرNLR˜+| mXw|[oo^^G%w!Ǭu}sm ^#I?iѠ=ˮ|l9ZVrRnVk,%f]?E*+S_Nr͡&^`Ito  JtJepFF2)Chlxd\aϭuaVkG <nR]XTef*kG[4V.u=jL:.Wl#Q!Jp3-;T.&!`,O}/g  ~i1vݙFƳU�o1/wqG.<D@vWj whI�Tw<lg #)k7u}_F(\ ƴ?#.bBr?Gnĭ'"NǭF[jfZ٧X 5sSGAX֍46+]F dBhpVm#6IʢpaO{<ŕƿmݷ;5&b϶=U%D MwBMt)*~K}4m⩡3w* Q~?≹ 3|(??+s,+Ɉ m$)Rܛ_:ZVr%4#U&tm*XJzLpcC[Z- u&D5gOI�++??^Șn}:`deę􇖷hĸ#ӕՆdgܛ5qwЫ\-h덉Un:߄D33�Ln7rUoNS|Q!Zp*/;n#II%As3UܿIxܚ΋`~gx`6�ϦTt"+{mL/Ani|dɌr}қcN>&!)v#ɶ MB[53^[S<=]TunD[#ΟzCdOub{DMDAȈqq<T[Li1Iu|D YSzAw`{AS y+O9 ߵo~�u9��;Ȋ endstream endobj 222 0 obj <</Filter[/FlateDecode]/Length 2730>>stream +H PTǿ]Q4A#ƘJI*aEQyKR%>""!<,0u]ZhjZ-HftctNYDp?=ù{I z8xEf 4_fد$ 3b3hޯ3}f5Vs + +u %d 3 Y؉M'dΓAǓ|4: 1o{xwSt^G8F±L$ߩQ0|qg[Kyw!LwTvŷJ!^.7o3ftnxp6UFl Ş-@Vc5xHޖ^=wBtH?B!LWRk>' "#9Pĝ?ZsĤޯSg{~Ywe$]| �2;)_:VAcevkYs!$DT$uY[c24$튙F?}I6#Q`|2g#EAEC9gF5�M@)Ǡu>Peʿ}D: Dz|^U%3*djc??yM|?,2G9NH ࣗ:gFwM:爙;FRל6_+J6=RF9+RWG2 8!c䟼ֱ+gJ#\{Vܺ<qA>s疀vT`JL u0捇}bJ;`>wAUҿƤSnz9+3ߘ4v\{~pv{vK!S 6(q<΂Ui%g+޶L_FDW] L258: b$b[Dο#|^fC5FLʾ7 QV84@V]<}RPwЖu3 8cӵGMq}\Ϋ[A9n-n? |Eɍ} q[|C^zxL]eCP0 re ]9,Jxr}HF 쀭*; @{$ �i!=J@wDONNde)!`K60@IJMl ʫְQQPR^eŕ2((se�+WD$PPQN�0x>?!v}FDmZcaoaazӹ_u'U @C?|YI_QgϹ)o;/>EmG0cs]kL'bvavR f/Tj-:B&8v\f +�Fv `G?!-"]Ԛ#Tʉ;FU^ܘ_ PX'4hj3f t9 cש3"پr;s1j?&0>rqm|hH[5wH)Q "Zva͂ }"CY2BI]ADCKHG ҢxF='2j?i$z="mL^�T+œ$3#Zʵ +\wyElZ>Q#pߦ>I@C(QXij'UŚgPXo|?Gp$Qm0;y R_؛Auڐq hX Hnm(# + +uΔ^}ADBra=Uaί۠=iƼ=%f5G3m?l 'HR^b֝c=A}RJrk?<V5ǡRmEJa985'Jϧܬ'$LADA$$"2޳9{G]2T/KB%>�'y_Fi=kWNzFjI<ƤUsV5GpF`߷ea'N l?Wbm-9Pw-5wRc$; "ߥ^Y` c\Y7o^±iV.r ;3}"#?I!c +! +tף|xkDk W1h?: +5ܭKN+Re1ڝPc%GEY$gǽcgv@Bby:R dker3rv~"-QΧ`?W1c+sJt1ZaNV m?rʶ?V@ClIHw!ԝ;@-|{tIw +3E4`"n RG ijPw5F:li]Z`^q%:E*"23+S柫Y5-b˖(`(?AnNzww hۍQ<_�N,], wj/̰ihc?m#,l �0�V+ endstream endobj 223 0 obj <</Filter[/FlateDecode]/Length 2023>>stream +H{Pu/殰)c;&4 r [^h%LjXM ЍPw&.<97 LSfggw5vƦCy|g^s=|Dcl5:uꪒ=3ūuE=o-f~ +�x͈ea6tNO/} FsyoS*f1~bߡ,KnʥBi_aE4idCJ)jBDT;˸9D|s Z]^1Ci^wZ5C>Lbޠ}2w7S*?rs>�U_NtLw=];[NA`kD>~U@eG"s?w8)Fv53͹L{eHoo-m”w +3V'XCKZcys7폟\uAOC|NUͼL̺]sF?r@<D=_MOB`4i+Q7XX'W+Y+{.x;=>_K,N؅@.0˳%f?0V`0{44; n<�U)116T{^ɜ({!+}1Qjl^0JCt<Y]bc y\}KUPܕS#zùJ#f6sA91wE?׺*{d8+Mm6:z.Ƨ"%6OY2wgUn?g4EcykwţBX1Ll]Wn}&} c }957ؘ(pFH`^-]exxcxeb?DWhYK +OO=i !fzQ_Ƃ[dB`4V%7?Y[@57ZtI?#|B:[GvkOdʣe_!IA@0u_/{ cBOOMmwJ[@5GE֝wEٻc$=U+4iYACXN|)q϶g{Dړahc+Cp|[JD4sܻ)R{6M1{0jT|q 4IF@PjK":;/; 7FX?e.6ys')pD}Ck՝&;ouk{ȩ*MG9݈�%Cz4-#A Jcyʲ\MژS�TT|IޚΡ]=n0BOtmzi}1RJg߲?UPBjUƜݿV"Ka?g+G)Ql?D.8y0*{_cR٣PCga@!YB_=SwTw]F""wݗl⻌G4&돺9W{XH?0V+la>�$b{]<gvzvTJٟ+Q\rc/|{"+cxjѝn?%CCw}R3K5w-P'M [=MvIXi{ l̩ +~�)kN2mwD pk}7돈o~6C<"7}姶he@A`4Vs +ߔ +n?�ٔ.ݍ5hyU˒]?N|c8-9ȥ]|;`^Nr(Ɗ!;X) H`^yTw=SdAO�_ endstream endobj 224 0 obj <</Filter[/FlateDecode]/Length 1994>>stream +H{Lu -qBҴZ7g1%hh&M�T!Z^PAﹽp0ZHi%Rlz:\D!y}>sx~_vK쓬7e;zo#Md OnXi]᳜d3y[7Y {͑,= +XO$%,obT218&zq%]2KowZ^.p\3ޭSq�gBX$�W|M69J6$zj59ҋ +??ϑE̿Kvm}F1`V% +o>QӬ!c[x瀀}Tro섌[g3/qAAAz jq +m}F +t _?7 !XP}h/z&)ޜ5�k"??Hd}|*M(0a߄FAr<V\<iQ,K~&:K폕!7o }Ҏ7߄FArpy^:) Yޣ{ط@ *Ś-jcp1٧^ i|w[ -cAajyۢw !cz&@(!,{Ro?cа3FD0X Ra9Phi.'Tw !c埳}yd"[|ɿ׸v]aNXDA4Lt '}[ -[W3h=BoABǪ3{+o]s!:fGŗk-9`�PhicRz|c QZؼ鶢7@I G{#h +nM7@.4Z=r_VYH*x$%:o�WRt~r(QTD:Tƾqڛr?L9Iw.*x$Xv}ov΄!gFupϕ8ȥ-1Ʒaￜ?h4z鏐哘pz<{TABoj)`>]ngx?S??dk{[yݗF/%MT&$D,A-UCP`> +z? +uy~:{Wά*r?NdN۹*7!! +5b%yrc=S5A{!hpPa䲑ۃ(zfHFOmuI�T.$D 12GmiWMc Tݵ?řw?6|A_WS1vPQ}sZWFo1#k{z@BBxdz{7AZ0\?`~{Uj2{{ߕ@A[*îU.$D t^p:"Y}ǔjɛe-4艿Z"eVgMPUBAd-*-u:+FKbfmmL�*x"7EoJTvBczkuP4 klro@ccQz{P�5G3$Zػ-#|4V#ZOqm +ކMXqi;i]Ŀa?, *?su%,鏁D?kyimJ?t[.�T>$DNǶ"OY)A~Pl 0?Y~>YWXTGWOӭw\I_ �4tX endstream endobj 225 0 obj <</Filter[/FlateDecode]/Length 2119>>stream +HP" ު^ϺN9QXPաƢt.P@!"\G+?y" $b@ǶENW4y7`wσZdy$"s~�G҉]8W:0"=BElv +8Gb!o R7GD)?'d`#!;lƑi8 K_s~dϩ}OY  p t^+T�^+pR 4 [sZ{O (ܭZ-w\J&k݆!Оl,o6%X$9 l: +,\džWLo$tyTj/R خ˜#ɣhdəFfpY<!+y <_#T\Yi5sh԰?piB?"2h4]*}X$9r{i6Kl"oȅߦ톳7ݖN0M( Xn!${gh5KK;[;|4ι$~|'6?^ӀL3-g$K6|F{Yrr\Th:wo3 ۴`PsNqd !JnEMȺ3݌XK}Y2g:豴ݨJɘꏽ(`pkb'흦'#bSY<je#"B&I7h3r$ϛ?y;?P@[3U<+3-84 eMݦDB'BV?ME/eXbz ZŴw&`i5s2zO?I.wE sfq9+# ( gS^ih2M84D*eeX2`{!?޼qj,Kz<kWXgj8A h giڻLN0 Ƿkc\ţ 7#B~_{*aؚs?*=]_OeAg`7@?g&o ő%.ȏ7ϴnvZԼ''}Ƿro^qӾTArwe9m⾔*\M' +쏠Cz/qpaӆN2t?޳;w,|gzیf;?uTfB!H=ɣ !?MA{Y?97߷Vh$d:6\䚯6W&_`8+cUB[x +23uZ .ݗ ܍vZ"2˲a^kEOyamQ_OW#dܭ%0?>�'i1 6}c<AmJ$$?zۮ@Phmȱܫ?xm Yz^Ab H2,E82řG>Y5`N%<{:nGKH$7ξe6[}Tť?X$36vljf[V`SV{?ƋTʠtd#B%Zr_Ǫ{m X?'y(б(LJI|夡O<b¼2Ѭ[\VC͓K͏qqC ܏Mh3쳷F-)$Q$2ϙ[F{gY#$^#4 ]4K�àrvx? ro^q3p?"4GE } $Cb=q#,{̝o+^፨G^0zNZgy5nm{}w(FaseR8 nH_B.Nv �靦* endstream endobj 226 0 obj <</Filter[/FlateDecode]/Length 1939>>stream +HlUQ NBD63F6&m JQPpk5V-[.fWD!ed!<;MTK{!s>sry4GHuOO_DWĆ5 XRLnrQiRPi/&RCԐ@tЬ DMkN5 ED +5*ѻ*RZUaRik}Mh6}crտ"zd3` u|[P?agvK?j$\m۽ƣ?ݟ`Ε4FILHp}]Yg@ocd"x = 7?\z ;4sj|=rq}PPiDq+?~ +^w菑>{>k/\{$@<nH4-wԉ\PQK{k>+6;*#F95u1zC,1s5D}#a{0ύm_N{]Q?j(Z|Zxf?TÎmͿwTFJݦ3uP*c%?}|R_;w]3ٸc(p >جRLD~G][)+FAnb3/<zL$U-M'ZNx6yǼQ;kҧ +.WL*aO<ЦkwmyTn +Qi5=RƲ%OXa{4E@F{d.Pşۇ돹GsO_t(k + \[ +QoM Eaܥԩ.9vD$RƲ`t$U[fu8VΧQi?֙nH pbW=wV^ QiBa6Ip0x:~f06Sǟ+YB<~J.tK@u蝔Ҡ?{(>|Y;%){(9ox^*h[z=lI< _pK{Շ}Ҡ?)k=>t;J�2I?|ڙmtѻ"_Uz}7˒:=wr uחE'@`T5ɻrc?%WaW{,cY?Ο$zUS9*p`nE?|coDѻJ&1s:*z^ `mbhwQ9Wh'4Wz_(<UѻJ W3{-Fc[zD}M7Pw3[o|pS)vH*LN4n"?wK}^-zUŸgxq3a=I=N4li`_Hp-X]]O%k*&51Po'ѽsFA+9 -=W �#?6~z~VLٺXcg/?7ֶv{GE?0* #~Zej4Oa,K;&%'-]NE p'-?J{`h2Q8XUwN4_EݺbHp[sX,We;V)sTٿK?=/U9 Ҡ?P]?9F �s,e,i{ &9U&络?Jh{ۦ -$}YsNx_�to endstream endobj 227 0 obj <</Filter[/FlateDecode]/Length 1877>>stream +H{lg:Sl3a[fbX0z1jj3RzjG/N/sv.2jń?ZLD8=yW>r�`dwnjk`z>�bS=Vޑ!D(fAwe[wGFmX`ycG@`Ph %AKBcE碋(!^D<( $� 3"<!7@ �84z +|lh’seι#t݆{?g_&G]oKH&<|^[=źk<SXdj* "\6䁣gc@!)Y�SMy殠`x +,LUzC{%5i](#ux&|_~HY2(C@6ֽºk +8g7N&։%5iy7Bu"cpzNѠ3]K;@@>2PI~^)!8sjp+B$7Ib=|-o֑}j9Fi8HA@`meg 8§CQTvJ{A!P+?!ͬ;;! $;47v@ c)@+d3wS?: +Qw}>!؜C]oֳ֋ ]٬ + yY2[*W#x)c9P.niDZw/Rb/9"K9<;Ā9h{Y?dOOCD}d/wS?VyH`w"Ȳ9,?SaRT�nɁw21xw +G&xȜ�bnK� OAp.ljA߽zDG(=ɨm f-9@\7j|G$mqR>}=qn�8ꘂRm\BK`{"W2XwJNċ9ۍ B RDv֝ OAp>3Czӛ߹% v\BWԱ^;%'Bw W#l󏂱R;ve[!NBuݼ%?ycOo^$'Mﮆn0 긃JrsX'?0<5,HOםd ODk*ڎ>$'BG2 +]ˮwm}  OAp !ސUZXZ#\D]V#&w+&^";whuD:S7빿[/6I{$GVzJ+ lg'6 lsi ˦ =  OAp}C} TאX'E c{8vK7iL!aŅ'uxS?\"cpz<TJ`"fYB]:y{U3i(!AZӱuiS4?Ѭ�˞PoƺC<)40>i:##VlI>̺?r&YKk|zH2zw +R+= OAp=Ա^Ղ"B6K`"&3uwLDcj#A6{IӦo.G@\AZAcq+z^%Fm[|cY("?�J@ endstream endobj 228 0 obj <</Filter[/FlateDecode]/Length 1925>>stream +HkPUaSdLEΨbyALM +b(a% "EA$n<X@jD)&:5MMSt洇7VB32="csc^„%YG Ą+ZBǜ@-2pԵO!G]BS:lDLTt#̣{2/t\+|wd5?aÏ\ßc<Zn,`uVӹiX(pՊSj%ׇ='|ousg(J:8JۑKpfYK,OxR ilUJ{4j> +ҫHjT?7 ՘rGp^lr"2}a5<G->οD9QƔ j);)XpZaL~^,J_o2MNY|gFJuE?N%jϪ}#Ӡ?<gITm-\E].G c1}[lDn鏿C;YpW$~/C`dg1eU[{)Ast'|]?qTo1yER5Rf=@`dg5.* KA\MMv*.ٮXEYv_-c6XMgGM'z4ϋd-(/UNMfl 9Ƃ]iͳRNFS'$8urMvukc(;k|C#Ӡ?<ј`5u-?*n +YLglLK^~Kys7G(ǂǯ?]%|Gibĩ9і�h~ +r q\ VS .9b"5Xv??B'md%z?ib<ҏaZ\ꏄہrѻP5U_渻?( +) ]}3z4qJ{�ck +rS˔0C^֘2 {?swtPtۧd%/Dk$nz4q-?7m?2Ң|D\nf!|ާvG.-}ӹ#etwk~Yqa{7L+0/-4pO99E+pa'u+Fc?xW{bɔʊx +tkd7C2D_nV YwB!K#?篷j +rr+[ +ʍ+T-lHKuTOГk~V6Gx=B`dXދG +-rTTPlJ:[o66qx +΄E]oWCz?<wd4-GL/(-ʇ?%i +?0WY.cs3Vi0?]DKP}WJ]9X.#Ӡ?d4V*{ {G5pW}jܽe�c?~Nw0I4窇#??#t1&XͿD^?02 Cfo0[4p_|Ȧ4pdQ;m;}OP;gLІAKFSNRzTUKm9k�6X%s%~ָ..VXx3j/613}~C caGp;Z@xȉAiQ>��7A endstream endobj 229 0 obj <</Filter[/FlateDecode]/Length 2128>>stream +HkPgA@v"K&i?K3&jc6t2 ++jDdYUYX+w$58im 2Eq2ie:% 肋z޳<<<?&X>ܼ.X?O(;+t㋀ؑFAiXc9!ɯ x՞(nO\Ddtp@AP@6yM @ .3)TN4'g`bx2گ,wT;OvFzofdT݊i<V[Q`?~tJ5e{~sy. uVv<zg]\={#�?((3kOZ$7j,ݙvG˴noc` AMNKawBCb8gp3bUoNuc,#$M^K*C;=DڿpD.1}70G?p:ݻh0V545 + kd_<GחK?WG{zw;>H܊a]{`M|~Qe#;`< <5{ dCr\Q_ǖ?9pi<zgܗȆ 'nzX1I\_zm8}yvsz(c45 +mMn9!ɬﰈk +W?,'L={-GWu4~oYZ}x}v5~UGGd�7[u*b6OĴ..^⍰PlWV,9 fC63:cc^mypk<y̖m{uWŒ*˂c18Ug?&we>z'3zNFi8b+% rM Pw $M#uU&KdcۃM\ܺ:6Y6pgP3>YV˱? zpDX9Ӱ?p4tFܥj<W+S.9>67y|=9W2otvf3t?T~\X )#u^zݰ?pxFSuQS0g?O}Bl4"'$EwYğ|F/àZRqkP?z~O&a&b'52ֻ<e\qҠ.X3g?CC=.,ψX7>ݴֻ|^(Cg #�]ˉa`N7/ I}eDo̟|:2k?4~2XaWb5ڊb{FH%礪sZeO/#CnkCdwJ?0~,puEG�~q },4Na`YYRUo '$EwZď`Ke?z*rk5.q2-Bg>a`cQNzVotWN1sKIwh }FD =O}ȿD!7gw(&{c0}Fc KHuGNHC/-ӟQw*#ϋ?J!`.ҬnȯթX27@D!WEpE|];^:9Ԋ? JQA}.{ ҡSL=rB֋n%d }oah(JͥeLbpf &Ms^my.F K)A>?o?RnѽQkwM2;fI7^e:[?8sȯNb;84|:XA[41/�T<P endstream endobj 230 0 obj <</Filter[/FlateDecode]/Length 1905>>stream +HkPT!1fSGsf&%/L3k$D&A$*5@͈e/ge +D1FE 6m&N:}t}|}q<w[�?0}Ebќ'Wv/ʤwWd,YM=4Rh2[5ch*Ed/'0c8�GUSؼuh߭(JGuܜ6A`}}{-=b1U{;+4Xmޢ,[}?(oFm +gHn?Ơ?P3>skߡ?02 #xe:]+K2fG祆[}̺7<o̚{C˃]@*9(轅A`dGi 5Mq:&UvoRyw\x=DD~/W?U~~[FA׭-lW_d,�\0&ӮWGLB6kwRzqA>'yҵ8f4xEpz_/0tLn<j5[ӵE2ݑwgW<꥿QܯqAqs a<̳rVj +C4T3IS/e,]]gw_fw<"+a]y>{(?)ȧGgXNy4@9Iѻ +Ã49rVlq}I4Q=!k8u*=望[=<b5䪰]A`d^=q?]0&煝; +[3|<4ȧ>X.s='D( #Ӡ?0[{}cXXb\?Q; +P1#o?Ƣ?Av-G9!zGa!0,M_/ ưO򝘑#|?!fn77dFj݃;rۃ4yNx +ˬHD}AmG]T:g/Gu4Z.μ0-FC|߀4Nşg͏, E/eD%'S;;m5F]DTlKkU,?Mσ9YwK}LOxmYX/"c?m(+P}juXu%(.Vh:)z'O6#Ѡ?3#=Ue`ǭU N'J@B; h~rBH}?n r_;P>aG�|c:f; 49,ZS]Yz`#\irce0ڵ#?:-cRZzmGkwirTگu# dluE'Ͷw]ZT{f?;.1}qnFѻ4ymϯW0Q}Xn??D@'Yn_L׸Zuei}}U7f}59gE;jNj_L[9{1qc)c[E߉A?'s{+KES;Se/c@'D#Ӡ?n69gw7Ί>"[S6%z@:/o(~#3 SO?lXO!��,h endstream endobj 231 0 obj <</Filter[/FlateDecode]/Length 26322>>stream +Hn_wSkrgfe�A(]r,D�YZu@ծ KΜ9sfiulgu칧ޞ~/^?۟=fy۳W^^^>}pϷ?+~NiKoN}{|;}6%y/-W eVfيݦO=uk%;?eޞ|#+??,Yrۘ<e>ziL7BloTbjGfU1\=dֵnvf[T�Jm3�im>7g5;k2e!tw}%t͞jke-�:Q=yVvJ[S<Oܲ7^=Xi|r5X@[{Oqyfs+qP@HK qݵov:d{澐#U"Kj:GhQiP94:@\S`}sR q>LJ/6A#ex 1ET/:y O9d\p4Ves i5bB3@),9/ҨJ/(J Q0=KĢ7 h,X@j XEVyfs4ڱ +ޖוz!/v\TѳM<*(57FhYL#j,}FqZP1矉^w{*]JW,JPj2q;)KJǀ+wh[v6Bh@$rhr:X%ne<!^ǶQ5|7=ʍ]pr%E'CUU}6Di%=w*�Ԕ%t0}6K*E<u-ij kʜV™ }Nij2PMq9y`R̃dD9 +s3gNVqD!y] iIqS֒x̪8̔YRhuZԻ[!]90U0<@`{izw-T!My`c[#γ|u3RB++aHoPZO_㡳 ƉC GU3hF&z@IRp0DM1p e1JȜ|ꀑ鈧Z4Cu v2W:}DEf(Ւ7K_%!]%!)dQJ1X8 + YI)=/S!g tMWǿ~zLJ뷏7(OW~ûo^\|wwa_^]_՛o/ޝ}xZg׷wkۉr$]$e8=za˜ߢQhWJTjҮk^d;>CJ,߉+hIM&ʆ$0tk-m&D$F>IVXVFie)4iC%I$R%.[\3arD1͸2E[L6, d|&)Y(2欆~R4R'C{1u2d|VÙV!i1ToD r?{Q{ %Bz3Rp(&I顉  PHt|q.qRH fBh􊔗̕`\OIp_۬f?K\OCbM*Urd=C@B(;|l2er%(4o qDr^\^Iw 5`,v~ W32g26e5D�Pi2E +Vpi ^r�ePW]IU4~QO8{ZeP| +}tKi),Z֞d)&UMLS"7zwV( 1 iX 1Ge0F,? eU:c~y(]b$q}} —dv8/n4 +K^QA`�Bgqo:Co@l '-ƢņzDG>쵮Gc]sÔLtUJ%=%6E7(Y`4#$&]ū+UL�PKYeŠF�c�j0h$I*p,-+4Q17cԦ>J>abC`UoB4$Vƾh&-%AEhmZ3tZ,#СP5;Az&8#`ux GuI֦P߂hMcSQ@e*Opc[ %E)DR?@Ѓ'TʏߒI)e:;Ӌ6p%CSz3t]uOv39\)L"ӛR8"F.ILFEd44ҜR3hcRjĊKJ!jn)p5jFsB*n{fUs,DED ^.9r:]膾4Rjj'ʶ {U1R �_+M�'m:nT{TZffdjC| uG@;@~nC C\A.,b |AU ӥNn:D]~Py M%Z7$: ܸ֕i#eC6`pShytt{x~pcky C艱)L%`Z N lf?ږ cG&u6*l3 >ck+wf Hed)H%7H މ(nH̪=ɣ]*#g2? + ḁ/_I }+2 `vLJ O"9lQjVT[NB6auKQ.W'p}f[[ ?/7% +=A[P! ea{C1:J1S c]I&[K{q|@jM֍H\5 +pllf[R9jtA3e+d+|B<=oboxa7j[L'y=znE㕉t GNUQwB4Ӈl7JzTv~H0 5t7\.r 5? BCi"SJ>1ag+@hT_iq;RBČkƃVm&\FQR&[ G)=jrrFLQӓʉSS7E`'R;3Af1h<'7Jڹ +\:cj9sJ#rk C_ɜ m K;֜Q%=5HiݚugeسMԶ7#yhCEyK:KOxcxDu{Ѧoy\q A]Y89er`=E&h {qlj AC-i5GIv^ +(6bI׏At;*S=奰֙T]Mvsd#fX2 $7@ԂTT`*շҟvu Y5ܢAz_/[Rhk>l7#vسF}H){X0ʞo7zuYOcA(.4ݩ J-2b Rد_^jW,@ ` l o=gz!P46ZQ^yn6\cceM[6:{ +揼LjL%T�u7QT8^bRs@k 8Cuui$0f1M4H/GJ[G XjHD\j<ijtXdzڧz=" �XyR'Dҥo +yo\[μ26gFj/?lB}wN$OjR֧`BPS/SRiqJ +UZb)䔪YPRVڋ-%`]sDRMD%`U>Zdz!@hjP&)F' eON7Imzh̲Ҧu5r:)c MD#Z8|HV GDW%剪2'c]_J�|F>"n714ۂ8 %Y{ [/ �qHXb*)w<'m <Iod=䥀%Q? G@=JOLUb U{x*䑖 vB[H@K㧛fqt#lFu.j1p| +{t>@1=>JGID9S=em~WiMB 6%>g{̃T(��K*F fZ.!Pn5qt3|))DGg Dv'/]3.3#U3c6f|n{gg[xr%tkzԱDd7:m_C9[Y-o,PP/]1o&%.C%?y=@!rT\8:1Vkfqv3jwQiq٠=5�B*gF!F;87א~K@XʢFֹ{A.1v~fM45}w$9rvɏqZnV�I_-oqM^o|cԝ!p賵7?wit*JnEoYrf ĹJAn+V)7wP1A Mׄzk\\dЯ9.%m8"_v<W\pl]D& @'}0h"ڴ 53:-j:~i.X�-B +8##%m�o�!rqH |)55zv�J"% &3wQ3,u3vv|;<^}&9l@ 1`QA\1#hLeUip*Gry+�gqkR U%>e'h5b0)Dm61n$4'i %�@MsR;h^r~ ePf9ACh*ٕ:2ȮV#! 8좧9v '%= +9 +-ZQ +*xNT@7X3 +/3]?rB&8RD)'`ԹlC2nG1dИu ^RY\ch.)0[g/|0ݻ?`輅gt( @1Y.hy/eDƒA!@S-H2%@il0;@Y6.E9ط*�b]՛h P!.4 "zۼ p\$8^QROo$s@րqr +ߨ֠U~Q|"I;IAx~jFPys l˫R9+�)UHlN}(My ,>Fu~ BC +9Ɣ%BՕC9{:{E\KCku`at&@T&Xw`Y ؓc ;KAS%o!MUpot\}FdUwB].S4Z -ћ w?iƏCe5O1t}cVկWxar$[l7|Im!dɈh|sgC$&Yk߹PdĦUڸN!~nX-mHl9Ŝ(cedx Rkj&$#!+%.lMlü̆`(ݨ J�#2pI!Ju=>3VHdA޵&^r:[Z| 2hAx99+("IB'p$'#\1Y (zJ azf8 Thjз MK24- ^W؜B($'YOz{b@A8, !uxF^E  wD%~̹UΓJ䍕80):GۘGv\NÈ/LZ|(:GE]c9꣛8\ʙM}uBJ- +:Η֭#^xQͅZ-Tb rDW xZ.!~vf;["{IrtZb|?? .+v8 ?y;p15ڙ :,|[q;Ђi&VoUCntW=G4cB~|vC_H<}EB&ʎ^oB +姶 +_۫.t +Fc|Br\#}Ze+W*NNNl&4}ؽQ|%JGƺN?^?_W6ʄlg?\ y_@C(F*; 7ź, ~I L[dnDe rjVP7Y1Ebg_hK=XE!Ywm*,h%'}ΌimQ)1볐jd1 oD jչ0Xk. ^vvn? 7I:'^0 +no/n7 Y$xMPQ;)}x1Q#\4wMR5,tbz*TjԎ;NdV_XYuyI,I8dx}9O~[_d]w)\{b}[Gۈ\6#Sg^x;dNԼTFA2PTIbU 6]GKM4}W{kUuaAI5]t,ӿyկ6QP`,oL̵[i]ݿ)2h"GۇoY0E֏l^e ?+/uѣ/<PR3y֩ye)woIKmA3.?\I ~pxHl'XJLa  +Hh?]{.|VjD/Kh4]ӈAH rX$]\fj`@>@A&=X%oً2E UĮ8^-jצA)Gw�olg,ـݫXv�HקH+5RT<u8+Nf?9-/�1,8pX&_ *8zIC,kcfa~U:ެM~Yĉ6{$wem,D : @`V(Dp&s}0h?߰;y!O0J٘y*GaJP? m?:LF*S,�e,\zgr#$DدOʼ^FoHw:&PqM'f0 +~nv) /o(JI~@x Ħ�*d9u*Z8'` 6Nb:W&VģXwI/-1sJ jޞsSaY(Rf|dU:}C7&g?")( %HQ+hN E4EcO{P5GH%f ZC:AcLD )ߗsפƀ, @:j3!u?ګXr8ǽVӛ[m)h ~-9>tH0Z˘ "0"C7NARH +<rbҤ[@,˔<(]ڡ͕2J/s# +?aB'{wHACF !ΩK&a@.۷k9Ca}jI^Z +ϪFѕ+:eLj:pdTEqcպ`^ 5:Zާy l�vgD…r)M|]A(5G% &y8 tp`@gI|*E<Oi }E^#6 b˹%@[&mouY *a�x]. +2׫s-=o'oczɵ"qܫRA:R^͍C&x395q +ӫW><G^\YR Jr\ +%g G0�aC%,U;T<=W'VK [smL駑6M[םxm-u&T#.]2MՊ/ܴdUT(gƄ;oL Hz!0O-} P̩)B5lphF3h:?kf~{W6`6Կ!8WQkjLAvJK={ ("?H.)@?ڈ&|W +,w<C~CٶYG83sPTÁHP7cx)tQɆ YR+LE3uUJ1n"rW!% +ݹ9 JAMz50v)[h'F�w* {I%bےsWtqHch*бwV]rCC4^ڼf+%d0xPԀ:` B,rtd&M!M;ּ5�)։ [4:T +JT\Q[ΌL8kɎ +v ܷe2u/e`8RPHp9\l{NMWx#! ."մXeě≚k}Q Xx#فjtFZtcőd,wwE#oʆfʉdәW&j”2<kbM击c so;E?33ZAװ"{VǙyp%cD67K +Z)BRSE/-DqXֶXiyX3pEȭ\͉ D3b T|)ц)?G`9Bozn|~x0/W?ǟ_=Ƿ_߿~x峇w7߼>7S+[c93Vu: 4fDLƠUfI0W[@ J숢ejH韉xO$.�{-%)x*SZWvBF6%$]cLaQvмY[ $7_K6i`R*v�ᄱc s1 F9l,YN�N-J hw,&iW(h8G9Z.`c:%Z 5.U6X.Wey V,!5%M/SC[ eƯP ΘEfû WƆG�WFYRtzrCв^MdD$T^Y"yeݞ%yIV�b1c +0i_g/YbQKHPEjxn=Zs@k LzTg*eKꍎFs$HHޛ(HfMRgN+ "m(Ǒ=, ?/A/ڛkKg,KʪW5a*s;Z[5;o45 Ho۔Ijyd-fTj�2i;fP:"3,U46D]:*EK)`giPz 5HN]4@.oyCPyx2Ss*)}Gz1g*Q8r'c@:r!G<R5*- .KlW#aQDJ4s };H_cJjM(dH +_Cʨ mhV2uy%�dB$w`-$*1Q(M(*m9IQr>gk3MU]d$dl3\FKߩJ)NY1桸٩Ġ`ho_`"9.8m.͐N1 h}΍f)a7­neˤ;ʴ^:p0顫yTq1"3B7 ,hph +x Y@BHZHqS@JE)u-fS]dm ZkD䳶0`5ytm +ZC5RjY\Fh;#'dHA-'ƞ�Noj ]AAYK:Ys`n!D=v|!W g#(^EA H,Zd)= Ec1w1.g+[B>n^NuF9-#_Yܻ^YݙLUU z9U]uƵV@ZDKj^^:tx0 iѵ5"vYFѤRޥK lY| +<XKQ@Xaۋ&Fտ/y�YDj=Y8PܩLTӹj׿Ӆ3UgDg n"qƏj Y !?/sd@{Lv<rr[wuN떂 F| H$2mcTknH|&̀tɨ3/%E2Ҫ[ABC<,4Mg<r|bpv9>Xs >_3[+e8nrObmT&ՏtO +[NoePUd8o!+>g>G":I:3Sn-}FqI 1D:dT0Rc%0}D+t6F.mdz-߷ +_ʹTTUe A}zO<<u!h%1mTN}.>qoؠ9.>h 1-p-yrMb"6ۃwGG9e5MM*\` VctV0 vPJ^Hdw-y?M(dqѽN3%50T\Zbζ" "ګRC ]T o3fP.Ȅך^k۟۷onG~'w'U*@`em'rJJ2趔o:8CkݎΏ�+<pѸ# D/.L`;_ywnjTb{er +bLpno7l:*q iK c*#$t:tK|4Gb+fPN%]3vyAܱ0lFm8U=M][38dX%k)))(pjp)#'gk"HhF9?ׯEӷ; wӚa'D!NJ my\#}b�C)!Fdc")å 1^$rwzJ0~H{/c<kzHOFϫvRX--kwe'?#Oqpw4O=Oޡ!IwO$}2IyќJ{-`%lʈ�W,p:Ks}U+dcuv#ޣͿibNgOD)^m<a`VtFi<�\>1i+o)ΊT,<qu{os|Bj^ +Hc8OOdC؟t~.`+$kއO.u&trfYXrCujj: u|ݥv1:DOVk'n(ε~,=ߍPYPN"ks|<"<vUtfLU!8ipqWv+ϓ+Cagz[¼PO)4:ҋmʜJ r"1G8tF�/Hb2wd o,rꃷ:4] ŻL5{le5]<oYiMwVsL#d%Tǻegvl%pIm/J|v%-`@]Tߐ%VVJq>yqO˓I~h5^tlG:EJ} A|hrG vV񍠫B_k_s6I 'J7MR Ӕ< +O!R VE`f6j% t^ztC3_6ןo:݌#L߂]Mq#`#vP7<"BC1cZϣ ~R>GYg1 0 Đ7)DZ?qh"#*j8o[%* ߄�z ('tZ1)`<KEsT1˃^$h&J$hQ3Lk-?ҶSs]cG�N:=O zK/Cq|a2�뱓4?j �2oMgx 9%0Axi,7_f #mΌO)A/ayn[wߜAZ' {ue%/}R{ɒ$' y~gV暟9 MݟlCeL˻/i+B~Eu@-,4hzk,  Z][Tvu:ˢ퐛t({E6/hVsH 1kg'Hr�OzhB}q[BkR(;ޢƃRw~J'(GAe.D]73\{("R:f>^Cu_1L`8ۑR&5T;"/<ץd8٦tv? +/�Y9Q.Poc�DOIkd.CAi-X3iRg5n|wѨXPwO9;uv,ҷ X^ !D(ΐ>kzp}oS#4i%V3"Ȣ ި5\&<N�t -~ C.^5 K>vPpu7Rxmjf)Fy 1#<kb}<2 l{"4t&$VyRq#Jx?.,nY5@Zmڃ3qq,_»,!ˍpLs]hu�۟Spa5r8am(݂z\~TQ DeMGC@;t|{k:_,&Uտj_EcXe'VZ3#n&P<R]=|$KIn|ޫ2_-tB[) \X$$MpP)x^c +P`8̓1+T۵$yCHХ,3pL.MBH)Sѡ=&uI1h- +hw۹|@62Ρn$_w-%7>w-OZ,|?~Nkz߻s3fAIg v6DL +td Wi!uH =fC)^O;Jm}J" E4Q"^[qK}v\U]rr-۳% WԮ&{n"O :eO ]3t,~ϛMe$jG P:ҧUrI2L"凚9�<vBS8F+ BST_M^S"|`̴tD.II"B:4\DA/ՐȈȑ9FYvFfAMֹ0{]!F,-]:/Lg t;ɫ85wѻDJPhqD2m|AND!2]Fĕ-}lU a"\gwv^skdF8�bV/lb-nC8i|^-^#[TE!Is>0PTKmr0MFPJϡL\=Z+, 2r?Fcn=g+I-}HL$"`ss&jPM(+%iPC#Y((ًYpy>rԖEOfy>aއmЄ q!X͛əbv3tOѕ$0#Wp8-Hk9;CItlMc}ݾ4yV3GjPEm+BPCpM;Ya&}t]zI_OdN-7Kڴ-1WnJybT[I.VRe1GJdU孚$͚oޯEMDb)>$;Uu~@H+2U^s(t5ᄦy}bハ-sa J5<rkIJ氶2_epfXYRqcG^2|TXMÙA[*q;-uC!)-D-=\,EuFo9-.B>1}RKPNԍB`lmksj/煻h'I]�kehNj;DZl 2h#G.>lNdecrl]^PuAti +DеmL([ʰJYl�)`)D;"hKiSݑ/bhk}P.jŜ\SzH!1NsփFɜmJ +I2#.1eJiPD%;�-f+~b�u_ܹ[fYXEoJs̰:V;//(|!)F]ʵbIk#7A0t륚Pn+w <Ntb]dR.B%Kdrz&;"2zq<} ?FO&"Y 2nh~w#U5ǿ-P!}*fImLI#Dt!HbÛj1YB<ox7K1( 9CEYWM +UXf&v7:mmɯ+ +A .KuTkN-BgN9Ö͇Gn5% *OhxదyI)nAfv#x4o ߻Jf7fD<LvM&;&K($s5f-qȣDY5liMt=) dHTE{SkNYNJ"-PSQ)4Eq̽ C2OQ }Eڵ>Ǐ '}9BW퓂jɣ wtRO,:xͫ*(쥈XZ)MG5tPwL ޙi5[OP]%mekb&i4 B >Xm֘B9j$=nN1vBD fqˠ(5>z"pvO,w uEi6taaݤa (~ˡYhf</u)6ߛҜ bI6뒂< \e[aU@(9Q饠 +׼SNX`%~ko7/ݥ|MЧ1[ +e'+qɾ@2,+*ɬ;.TM+(EBeդ y,* }tsȦ$q$R /^<\ +"-t+9\7+ JӒudI;Bl8U=Y4&^fܹ@v>+md2oŹ�XPfNiK=[MikuCTǓ;դ~,%WC9؞ +|bؔ]#ykLp5#XjԄ[TbN>ȫQI\3!TdL6015mG1lZidd7[ZUo"M뿴&; Æ$PeǤTCq1O<)!٭μcKV٪zYP*|o#WD]5<U]ƾ@4]ϼzͥtEU U$kMDIW�]=[Dw&* +4zgyNUقCozc.n_0]K<N*]>X8PGB+^=G 1|@K {3'[k/Z1t?ve-o}S9{VѲz0 l_ uN�0_cj "j6A+N9.l:lt^mmݏՎZDjC9_:͏w_2Vw",]=,ҰbFT>q5#>dZ'K]߫|Y*rs-˙,NCݿ!q)oioy +,Y{ &ߑW"̼�Y<[~q� }�.,!w.GVYmkK$,|{!$$yJ\99O;%jOl)n�}JrUN[Lo_ yr6Sr;djp]@pCJZE"b-kl~d_`5#Q(/FL0UA].wmN''* ɶKy+@!K#DY~V\y`%uD?)W1T>rG]Q8ʼn@^9tG0D w|0I5=Z8679؊vn6/lg\#|zZRLpW7 6uka"Џ.%'~U,o~rwV*p2N~Ӳ~GdYsq"ʚlw|j`?yuTQ=Ll!QIICi Bs#9)^cv(Ynm魏bPa8JIdEWݐyno źC%[+}: u&J4ˏwES6}y #y˘�!C0Tpƥw]/QD'CNȥEc?+,uZ6 MZ'3-ʙQKd4O/4R}t 0|)!Ռ\K +#CV(ʕDNA}ΘbN$"J"V&X茟z5{lۯ +czJi"j CnC6a .}e8'rǮe,rCЍ[fSs܄?I-8r\K[jQK<(J +zծ:E)Lf !yU 7a>Ր ЃADk +L!Ql 㑕(MF'6q*7Mxt_ΝZ* .,x]l[ {ƌ:um yӰtɯ;Z1e|K pSM_%iOa"B<N}:d 2db2z(=|'Q'zVx_yo0|W@#WV 3ƬESAwO<AL[BƔvVs:eC եrm0 }~\y¡ -/4cYr<*6L+=}dǺ63fY+;Y+؏hҾ9=U.!VEyȊt胺/&q%/̯ZH�1Ui㝒e^z5HƱ`:dY+;Ƌ/HP^ܞ�S+Se'KgáFNf!Lw s0*ݮN8i=(Ɨrxd3,™ u{! G]aM +~KM3bݙKTi ޽[ϳ]CѢbf)UW Y=E5H]fQ ]\{):őF8m.ٲ,PH; +k԰U3AEڻ,/B{}%XU6uiꥂMuxhU{E؜fIgOL6k<�,{;QV45Cߏ0l~&EwadE РNdV?C-g6e)4cO)4A,'kiUŻ｝vqZU3fv $?]-J&*EVqP.z>$[h(HU\Cٿp�[n'~mo Ǟ[&y4[<nqvuL #4m9X>ڣ| -hәi A@emxbI(GՏ`%1YsKf璿lyY1QbL˵>xW<%i9X"�(;iΖiDM-7%~O&(~jGUZF| #~8_aM'0Ԧu}Q`sR9va1ʮu>P釈; 1i ^GDme~B3YlAz=%Te+Oj/Z i /b(ǁ LFf?ތ~恚<X~޺݇!5I^N}PC꒿.Sg"伶:\(w:mX&$owW%{Upw'a�6V!� 8VnNO<s$w=6owl[p۝a,37iw)^k#J ACauR%э^.uY?IvH C M<kB%UC30ݪ:Uk}[#팞D`:yTzAg 9,l}~;f8+"LT]1R/{X qE7m-E+"0P*Nѐ,. s2Ɠh ~e*v Yh qusBp #c+N֊~j$#T%ΰڐϬr=Hgz` Ug/:QG4vk ZHJ 5\h20<.jܰKI3䮜<j 4d=S#Kk;k3*T%XM&F1jL(W);SJZ*˟]/?~y|_,]1Fח/ϟ=~{|/%ewY:lg5yU(awMqj>=H:5P.+ QL|aDQ{ }id?7Um9xa7䃊Z~R"RYԶ;M4dNL-47^-u ]ocXeh&1<Uj?StKFL2,u'�*Uƭ0H>GC9?N!P�P/'N(ݔ5aOX샱# v,-.=)wXnr4<FMUnq2i~0 b;vB^ a5%M*j̡5Dg`fHƟgRXh_RZՃ>]ŢLG"snJA%o $ SK'i"El:F cP[1QuYHU%3I~1>z+jfIV NpuR]E&j4h -7h{,*/LV7ـVhȴv`F?߅wC9(]*W7'R mHRIᖁU' [Kl 1JqTӐ_ַOXoӄy->i~QàVPtyw{}e{7۩>7DL{CCUJH\zu>OLr_p0{yVћK:L{Evl~3#V DQ|2 [ +0(Pɨ$c+V`�t}& +v=7VlńIBKWZXqQ� +ѦfEoSbd=q7ϝVS- )+zWX-wk9eD)3zA"BKo[.-SXg(c$7/! fjr o%20CLLhxr=No9%J{vl`PVdxOb=Ƣ> + +ܒKZIu!V`\jc;L_s#i+:,%\ rjPF-5qnˮal"AIku\{DfPZl)$0@Kj4d ޱ$�R X @hQ"IXYGu}")+\r>LA|8՚}וc(]n[X֏(PaNcK�"hWRZkVnR[k@ORd'w�SL=℅O/=t,82<N& +fʎ+eS<*2)>&hvtws>qJiW>3*Q.;d+7rGŅؤꎊL:!!i{J%%vjdոo1~J3Rk6K $3pV*azsK0RƹnE ̧rHHT Iw>BU = .<F:(άDl'_S2핔qE>L)֌)Dљ}MMkm1 9Գzd3g%~]j"kTkgcөfqE.˻ֵu!;U"ggYij/Ʀ3Xu5w6if]f&kI�iܕsCE @CطfV`oLAVK$.oAD9G�},6(;yi݊nfHSkB(\j*>KPsXsQĆy+,;j N�{("DXaI&i<%wMf^j2U;.F5dgXō�ji08ʲ?BS{M1è?s=hkj+EݗaIO?<0S@Q@M@kow;dG^bxf7術wRuSlRulBBK{mr0ۧuIҩ>ׇ%<1*=4t]TЧYJ4Oޢ`=fJZ<v\W#ݣSXyZӿC(\y/f/?~y|_,Iɮ^_<>>|xx|OtqgE9yD(( b^2ŮD"kYs#{l&\|z5Ie?qcڱ٦PCu|c \̤a)F͍+\(. +Zg� Z +gf681~P%< uE~?QG=.YaX+$YGXYI,i[%ŪO(skyps~e@.D`;w(%1.jdn$ERBϭC8Q9e+RbK90X@Uu\zQ|v-7S8k>>s67*}dMOP#7x1#)i|P /ݺ+~NH@~wG#ə0A` , P UV80@2Urյ¦h%8@+VC8N}\P6B]U&Wd1溕16=+ +xCD"\x1H,8�G~1,.< Y! Ha{@ʩ[8j'e[h9kF ve\tOPX%:HzMS2%>zx ̚XsOM"X.*�7[) C9sh KY @.3KN1=i;Kyg1yΘ(FF%.e +TNsRd9$- 2j@p);e. Q3%alt +bP=+/k+F#IRɩ M~zLMXP!]KsG¤4} ,_(PRbX@D +* nk]G1߈,dXec+o$7ւc8[uf^dKkIl�7{@LeՄ+^smsy0lL̆{P>LT%WbҖ3^0K`\Z cC7_1r.% ' ihjJPT w%nW!CD AزoТt>$ C\pY$ّV丸 œ1ssu`v啬]S):\/G$Z]إ⍦vJȻGE59gsSec~sM4Z?Сy} f,_0U6\UHqm +#9sY^JȯHj*mc`zh'kl(Nw1:Vo,c@cM;1G\9F%91ʺ/b4$&I#G{~+ܤױMƾ+:|y>& ց34:RT>[k>lZxWoRCjO6#[KR?Ԯ*ԔF0jʪ6M}%$F5N!hh:!miWf qAmu(#<(mB6ًyPkuEZĥ f$y̔ e@ϒg8W,RbwGʨbjTV<5i%ۇy 8\8Iyb F +HL;XRXmDm{=:-)b]!k|FU1Xְ B N4]qF[!{y]RAGz ICUٖۤAɴM)֋e*2.KCeú+F8{q%C;bmFNfDK q"4O'.Ǜ׈j  6B٣u|b{ԇ}璑iJe(P&Ґ=f~f|&{&ZtU7 +cj9I2GYIŽ15miZStFU�b˒S-4H9s90S8}Y7K(-A#E12WJHm%L^nI'!/ť8i5!ߥHH93&wH)y&ODP32GgS,,3&TQg'՝.SHzĤC@IޯKt֢*3,<ZREuXa +JlJH#e,}X F@N:\:G@ + bcTB.?Q( +uXkP*,KJ8#q1R +tr:jn#٨>)/&΢sd&}=ծeWQF QSU5Ib2.gZ2.EV_w?zۇCW3^}wsuw=Xگ^z:t~Y}O/n}o~{stO?|wO}|x{w㧗ӫwyw7o>ݷWO{xXW_?Wx)qn:xtAk]û~zk;U5p@)^@dEߣ%>g4(sͤK5#8F'<sPEfi g!Ԑe9".КP4jO,>d%C*T Sr,Tc)礡6ꞛ(j$Qf>]f8[nz`d!_#iRíAbhrLs +2�NC(<VlΆg둅Rc|C)XB|ծMoOt> ~UD l^H0iע5 G w:FWP�~x=\o~�Qړ$M i"e3y1nŚD5 �}in6PXq#E$U&:JWjBLUI"VY9 olΚjj|uf}+)JA�/o@:M)LI ,l3hAp1Ȓ5rEUap8#J90MutaŒ\YY7q haqlYڔ aD4j" +ElJ헓# +tESiUA.ac�19t2b"LK .M B͗e#0c+4z\}x.!9ubȕPORM\/sWɞRu</7 +ųE-Qu[rTU؈]y@콭x.^CxbֱQH71vcmŹrǵ䆁 +Џ<=006n$U8o;prg8U2 ͭ{heүD<u'4tfUFÆaէCQ vW{$ss-C߾9~l</a ѹȜՑҮSS쏞)?ߚNK1 99jxrkd +Fjj +Qp#G L<ڗD-dub!=Ga } +j]t8:ͬ +Z5<!!tX=]YOMT&wbC5ۅ7Ng-HיhA]9B d.Ēi9P]U<C]?mI%RŵAʧW/ܒqc-@8׀bRگna俛1BͅD{88^=%MWR90sݡC+¼a; +_dݵDQмO-15G)00z<6aw>?7C 3؈f>\7Ob>DpNpˣ´/\ e �}:錿f%QmUL TF֩`&b>kH:n{q'>627ܻ\oI.=2@F#CO5C&0(QrmPȹ"ws ,/ECRv'uqHZ-F2J|+2C5!S4Q=N"+jFr/$])&=6s(� ׀ZQp"[?`DxYo^^l qɍ܄q,YkBV4J�-G9[:+> %<[(Q N}QACpv}E8x$=ޅ|ە71^q0K4DeJga£U7َu,]y^±6RVVPzݐ$#B|6KN*~Hgv s>0/}B`*AdgJ;EO77W<U̥^>.Y8=UU $b)\筅F&آ]1󋼔}(Fk]n3dW-MJۮЏb +ʮ9= JQ] ^+W# Pp`!4\`E߭u{U>VY?�[kA endstream endobj 232 0 obj <</Filter[/FlateDecode]/Length 2161>>stream +HkPWGnWZ۩֭[:n- [V.ҵJQ,0\J$\*ysy"r1 EKLiн8e]=˱LKp73DߓزE4cɼCsLLs=ZkZ= y iWxb?<Ho?p![�9;.%0=ptx6qQLڏVyõOpY�y� +\Tz?FZu=<{zuZu%c6Q^P>cXs�=faؓ5 +դU]!ݻ�$eZz߳r 8B!,moz;m-g#ǒZzu{R<Śؑ/1`@{#=?g?Awzϳr8BCzL7pyc !q /8y!v,lhH!Wpr}_p6F<Ok@Z}a"B: +dY 9! 8a=+;OY1ϿN<o%'H> TBϿi9M]>!}xPC1T<oȱiQe:j8!"ֻ2x)'y<k=F޽ ?[P. 3 +p6ҙSf5RJNl_~ƃ=n3i5so_bWl'%ãoB~�C0.h|ݣu&yW:ki@0#Xh=uI49CCŞh?c;<-[{g=H뾄Ce=5y grkVu~wR_7+??Rz[iw47~b1d-/q#HY/O_aU'5(RGSα +S,<g:ԂQ򴥶);G#~$=E<@}MpB?|!)Oͅ JF7<6Q9bxzKU@u蟽3W)׳;낹xbw~1`XOgwaP*W٫gb3 LKP1y- iW%iOőD.7< uڳQ[;G#~bAVuT_Q +%dMwh9^ǫz}g 9A`jz;^cۘG6,$+32GYg M8BiEj'==tf41J4A:[Hue?`p7˗x_8'lɃGH}ItE&=׳xֻ3pBxs~ ֹBg3i>dP# =8NZV’-:Whra`p_sZ^u'ZXh|Du'.y0k5g}0+|0FNF-)=t\?p4?[|y2Nݷ] =8E"r^GtJ=,m)<ɇGHýM2(TmPBYh w8*_:Oym?AsRr.^2Wu۬&! QKŬwi4v:^3}w ,!Eajz:ap=_Ntx;Xg GHQƲ<QjBbYhlJk4|? !Η~Йap-M,B``@7CpT-}/1}ľ3_T؏?\y&mb!! 4,AV!aW#>>Qϫ."UAo@0k՗:_>7k8 +/&r#͈_ &=w!zF)Q[$Ac(/;S>Qcp )6ܤ::;-8B軶K~I~V:A\ ')bpr]py{sYGH}#PlRkPBޱ'�hʍ endstream endobj 233 0 obj <</Filter[/FlateDecode]/Length 3222>>stream +H{PSW|Woۺn].(ROjQQ"OES IMrCHt;:[[E[qggw_:q�D%f>#x}~ﹿϾ<YHhQWϱWa>D4hTVTN$[dE$L43.pRFHx"m?^ +Ae%UrP/AX<:{rC!״-DC&žYIFz*{?R@;/!֔$Mjc<ëΆ " ?S Vc:6|>y?Ov 8̹PR[;8YA`*sb7Z-z꛴{mynslg +YAq+IF#!<A8yV&YA`*7JNχl|fװMZI< ΋X+Il`8?DD,ŧ",?S 1"ԋ,c`Z|xgr=>r$#n{XЯ&6e_A7hoҰUeҼ]?KRztF}73slg +@Omo("I9 zN]@P+9l~cEGv}"J -6;cK{#>Y ۔Q)9N;#$'h?s{/!78QTŅs,!֌ImN81E 1&l902_I~Pf'=7n,\ O@N8S Cև3*/ D` hШ:Ffn<|Ň!'Q?|SI$kVϱma38? |=-_<ʼ>Yu6ԍv&%Ī*Ko uKXˮǎMkb/O-<KTTMZI,, L$5FA/hm,!Ihа}V6)Dcu<Dj|9 ƍ\Ixq1CCUѪJ$J; Az.مs\v& 8l~ApwyEȉy {S~|tZ-ǶzyS2x<ԪՊ}Lo秺z +H;Art-18; mi't;-`}z=z]Z9)w@)5(j9#~SMS̽:m// W{3<$Bvn=S{,J|*1(&NSuE/,g]jPl]SpzEwYUe[;YӕduLF?B'JTTMCg薋FcRbQ[;ttq?]=<Ɂ~.0r0˜j +<CXk>2{<?ʫu%b~YK;o-QᘹUWӼ8U~Ч*T +!I[eFeU-nNuB~Ǔ 8>;c~RdWɌ̗sc +n[kH犎/NsL3߀x9 r8'v3ղgI'*|c<hN'KI"zlc�qL3?"<ٓA%*53&M6=Ɨ.yV,Lw zBjPԌz6v\18ȯw?G>}Gֱ7֑- C+<}0Uyd2 ~c{3rw:?U#Rnk!^c;` , p .>�r@7 +|`f A0obRZ?& �-ѮA=<@%ڶb̌& Zɕjy?Y+ڠ:5s;D>+U:۞8.8PDZm/{663z#Ylvcgށ]=Sa|P7[؟,0.ԕ5‡>Uwwć+.u:ΗoP)Lzݟf|y-C7|E7g_58jBR{JV(8XB-uͽgAک +򎘳y8`m ?Ψ^<$cQ`A43l'Ekzgy>Qi?uSmF1KWz~AE'g1u,+: +}}W7JSrlkLaq�[ݟee08|Fe}:/l ෘ|+(m ܷA|0!k!8 8ɻixGeGC/~c< gJ@72.IC#PkN81N٠Que://^k_okqE=77vs+2+ *vǶi +Cz%;j4c+ &ִnvP1;{7.a@nX6 ?@م.l[T\3w-rAMeN>㐿>\q={w]q'nQ<|1o=Þ5+oZ&7 >p`ʇK:GãQ0`6'1q&u1p=K@Iya7u6/ǢcC&sM,ܲ�8{5QrJ(6}0ϱu݊Y ; 0SXjZt2Թj78xC 1Ͳdˊsw@Շi-+?(T\e{Chx3Ç3lZ~Tnt\⡇G`8<� ٛy*ڕ@W0d_o>>z7.[iqtqlGpbDOl4lcp1lLXՑ {֮zP|D,VP*r@ׇE<Q<rqЄb^Pz[ɐ72؈ryc��ug endstream endobj 234 0 obj <</Filter[/FlateDecode]/Length 4033>>stream +H{T/1O4mLl1Fx |QD1>**@-JP.ΰC@7Q#> MiN]W … wcwy2̬ɌOG a?þnM@~J{4&}m>E~8Ì]B36Oodk 5cb&ry+G@:M<[g66n]迵h|*biݹ�XN2^mf5+hr0/ϾY[&j +:\ex +샥@Þ+Jx�iԿ}}vR޽P;|?q'"H +yV$}I~/BZ˻l=L63Tw31uASt*HչPKWXݞ5pSѶ}}}S'$:[ Uq^ѿ|�Ɵų͍sm }=wMzGkmQڪLQunȘٚ2]$m]{֚[ +AHtbyeЍTd)[02<t]?0zy{{ ZdUbaI_ߩgѶ괝?WBṊ}Ea}]DZM}%FqGW۶M5z#[c;--hX돂eGv 'ϬԙKowbڧoZOp['އt8or +ڵXq6ݓC!o#*a=iڠ`):?fm r!7imF0ϣ 2\z(t ),,'Q\*ex۶D2E W,0wB4I7g~5=\A017MqelɊ kXm;x.D d<^úmۦy0VKLչac^:`Pł(<4T7[WG무iՓ$Ѯ߻:ErF漣3}fг?ތ=>D;HCNQ75<�u}:,;cJ,<QƳMɳ}^jA\en2 Lm)֥zo0-(?a\u|3=r} }{'ՔcjiNe~?n=n%s(hDMA[,IkVFK3&% *;~s$i+r{0nstQ$yӮ"<cQ'}g浗+??:اgn +sOD`)?`ejWA ukRIuMc?GY7+R#"?0H{X*=$i7횾+qx``e":Z&+G빸?]9Di/ Egٛ %ɗv]pJ{w`<!Ȗs 9dSCEzu;0'DƤ=!CN'S{ý5%մkωsk3�T>\_4Mz=dR{ˁv!@@_[Gi%jq@uD9C+A tdFCIny-7vy!1xl" +uȡ-A:s_5R=e4&;$LMmk+U٥ ڵg RssA~<n7mI<n\$ryG;g<AStV$:3&Bkr ]x]J{&*ĕEL*ᚋ$Xkn2m{C&&rRB4IiA -HQͱ a0';w +9G;W|AStFps&\T'LlM{oגw`mwd[{'.Q�4Q|[R]j'CQ9\=lNj<N[Ҷ 9Eg)a+y;\׉Kg!K[Vs럱owU]i{� KҶR}=<v~U^pՐϸCH>dR=h?r211#x/T\Q[ּ 领;.07,m ͫRÇضIjY[8"s!7z9�(;0_ξq|)7`̉/:F2)}}>o7v2CS@^WW\2ֳuן[Ybsdt 㧙y01ox9X'S,(wT 2g\>Xp~u&R!'ano 2wYG?gZ<2YhhEb*I~P/�F.@e /B\UsMAbv!~qjI< CNx*[Ҷ_n1Q\q#Fj[Ik)i_ͤ[j6ij)! r.h  +t^EvfgwfwصR`,5)VJ(ԇ>ηP|s﷦c _u?>O.1xٜf:bĹqkɘƲ%]qt%2wbKX|X +T^8T6J!� ۣFUsXYY}C8` 1۹x*ըߎknsa%E^;[>163x;;x_ǦϼZz9a…͂:.F7ِ6]0jG|{} 1xg^7RgKJJ{iHjGo:QD ^z{,{;UfRc`{V*xcS?D% !?Զb M:U Ko/ Du=n56=Ml0|n@:l9͊gRߣfvo@?S[sMZc@3}I?5^W9v E|YI"so:]@r^J UTOU+[ rc+ _}ۖJL +?:<?j +4D3Q|ږR[l=_^ ϧX}59H%'Ɵu$#~^t +I?0=̝ӼQK<{]d/>>5Ccv$mF?VTkvI]9yzrtl]uQě?>OG_vҽc;=QjM8UlIʳxnSQR=asJlU6%`XPec0x=yZ>RCmK-VvDH=i+'nϩO㓆[]1yDb]|s6c/2s5q3Xj˘->>܋c:t3?>Q/4OS^D\Ú`B;eI+]T`5|;^VQpekl?sJlOɚˍ?nPu=$YZ^RCmK-6DPȻE!^GVi.X>cr/@ M' +L7sْΘ0Wk'%~k>[ +M`LGStM`AcL >c)㏩fz[rbkTM`;^Bo̊>1x�~P endstream endobj 235 0 obj <</Filter[/FlateDecode]/Length 2687>>stream +H PTT L6jԘhQw@%PD⪀څ Y4GFE`i'Im_|3sϹ9_A`(T+4̍\ߑ'bO.(.HOI+đ 'D&D1QN"(cߩ"NzHЏ q C yqre_Lyc`y: 3%YeۄHO1%L]9}>Ʃo +ӣ_F]ñog̕q Ind|ngv{3#,2%~һ8֋As7PZ\lP̹"u;!Y}318uX_R8#2\>oۚPn0lk;e6[۽7yV~Mjyug:0u<Cgἢdh!EH #Ƶn7׮Urm;Al;ë6:a?IzDxFF0GY;3~ð6pkۙ]cBM[G&[x@?z73͖m- 㜺p-!~` 1_^ô%r!$ /\yM]@*^by#`!ExpXGXӣ}Ez  t|he*ז. u::PZUgR"\5U P`'dK߂ Q<bJ~P[~6\ü,xTlgXɾw6,w <k'm9n#;ƙ8Vڧ3Ks- }eZ:RDZ]^ Vt,sdh!Ep +K*xrD~{އMyfuVKP:e? +sTuuuoI<maYˊ-iKPC_vdG?h3׭\?`n{Y\K!'=9:tl[~0Dj dv4vxFy?1X|)Ϡ̮vCxQ.=ƥjopXMjڞ0xchѴ</i4Rq:*JoKs b +[ Bqp.Թ?t|`RJ>IVe~4 dXy/7MoF;J8 jڑbI*̢g?0cB݈^4?c`OV2eK +iP#FuhiAY9&><{{wrh;C.[5 /Kw/=ה%uG+]NWw9#!U CIJ<ȟО?F!uxuNAlKK"H1gvW7Pj;-9D; b(ǔX/+yj"c =F ++TFRi+%bKhAUK?Vr^#kz8hA,AS e@l ի+2-J#L7qlg_0zNuDԗOM]ѝzN˜o>whAAS *yzv-!~}YoW<8ͥK(^4<Zuq]n!!wRxUˌ]AzCL0qA+MeZʗCS! 4Εcakve|ېc;Cyb +^X4 a.kLSiX&aꫜ9;!ғzdGˈAhP5ζ?(/B;w8?0=1)z%ɯP>ٮ/.)i{FoxB@1Wǭ3lfZO>)gZITNșP1773yb +JCa&5O Vэy.%'9u[jpڹBZ8cۿQn,i;]H`Z3Ώ=Ap< b +q MeSMWN ׼\"l=|Ot{uVKs >\gޣ_,A?L+۰+c;sviAS ̢}# F˴y&D< +{ɯpdyA[_kw7rِcܠyV?039f)4( yug_4#Ns)hUb@[#FGۖwD?C=ܔI+A]IWk9x]{tvfS/ruE?xWBc| \As }CLqRުخy |8u*^}3S'v +K=bȏ*Sxy"BONY8h�A 1"6KBF4NǴB j;O +eoZE$e=G`Ǡ|l,8uTa+51^<Ȗu+.ʃ(& +�P; endstream endobj 236 0 obj <</Filter[/FlateDecode]/Length 1151>>stream +HLUu#fnQ[SZjZ.l:MEEAM@#0[8W@t?s\2HLؤ&`KɶZܸ :yp9{}]+$vo,L,M^�cϢ-B+)*p*z;]. +q&CVz*]߾گe_T~qo}ojߗ1/&OKg9wyRz#_ P# iŽ-^w%dfB{O~rs]w5aOs<;6=_=?y+|)^8o醿#!-bn2z[1W}ZmwݥS&?ZRe8p{kvyso;2aL?U$KW_Xu=:l^3rE +v_S: Ϫo +ɋu2߅Y"= %ckC1o_\h}ePqJ\h?;%2R-r#Po߅ d2؛j_8# +9U}DOPM~cLs&m*s)W̱LqNc,S~Oo]S;\X=ͥW#"iA?��5Ȅ~��07k ��`n ��8A&3��q^Lg���s���y 2��̍E(FTOpCmm֜��̍Hcs%oȊs9뢽:(y=yg���3r.M;P͝{k'NǺ~-k~0jl Y~nΜ`Fu3++2"'uux9~,jl Y~nΜ`F{7nEpiZr;Tmlk9 3QckT:`tHߗ 6&~G:ˏ[&fR8w[ʱ9wMgƣ~G:ˏ[$GD O!W_tCyy#[oW#>wWĒ,vDh΃|O�ͧ endstream endobj 237 0 obj <</Filter[/FlateDecode]/Length 2438>>stream +HSS_N` rE]e@,+(:T.Q,*,ZKрB B $Q :٩;z pӄ$g}/G07,=zW׀:cYs<&J"``r`\b ˾+]:bƿe100000000v@߆ ~}|2Nq]hPADIdSl Ӡ_ A +Cjj̤"(f>. AAAhv.yh1M5u'Q4A\AA,sf̤fLT+* (Wׅ         IRJjфn_43%e!$'eeMZL?83(b(7\EsSFhPKFޓ B{ٳϿ0jTJ׮'ѫZK^ke4~1f?swE=++CR+UwEvKMXi?[g>ٹe+Mg oEoAru jmM䩂B +{f�~D.]Ξs턩[vηNJ0=͈N3T]\P^.eP'|f+A}=n/?O5VT='6Pci3EC+ 3G-`o9m{'c&rh] azҗJEü| 3~U"s?Ο9KG pjjx =!9vߖxdDڐ(D}w&uBs=ƞm mH嚕 )ÖC=AU=dƞ~|름?Ziݣ�>*ޔz23%"s?|<Z$Lf[r!|4x_]w蛝S!HN&:lc߸^'_ƨ琾y xÚ?wWjFL_ã(2n6>_<#se�-.d#O4*7;9dtW8GxH?_zR]hn38JQXee{$$0D c'_C=Auc{պ kݺ= JEKE7 ?ae5pG@obHԘ]U|\T4* (Wԅ8-/9`F*ɣPzwXAд4w֨g ظt%T�j9T7,d\ZO7auW-nL$k-ey|rw1 eG91M5v17<.1?>N ڭ\U @D>(2n6pіC=udwr +/7kZPc�<Ӌ~W+>>%]]T. VXI((1jxC$㢢{rE]cvk(8yJ@/:ZG ډe!Sy31nmg3]l<SP>;#?3 L%٭WJsEIʾ 3 +QcěovQ)콖#e!b6ϗp(2L'Ϋ/2b""z{&E(kWE 韪K|#.'l, 'wzj ٞ(b.k;nt7 (.(@(ϋPcīhF?o۟NcEE0a. qMQ\wL*T>G,=qYr†ƞ٣b?8'cؽٹe+ѓgɶbꫵ5(0g?_JqM[kބQcěθ??`2N3tGq+kC>wst'y;rj{zog/aB]!>hPc&$0ؕaCfԠݹ$^5:JQ�?"-E2BrZ{Z-#ބU {@* +|DI. '%O +M[k!sV-!c&#z%G**7T(l[2u񠫮8� }$諭ttwiU&CjlPc|dHTM%kÿ5UWzVWՉ S쌡]XQ|^w>9՘ȩy1M2wx+{ ݾ^ifJB>Qv"b鲩yqQф9gp*v . Л̦/{rxo}s.Bf<w0ޑn75<~D/hխ#�LE endstream endobj 238 0 obj <</Filter[/FlateDecode]/Length 171>>stream +H- +A�)@ٲvE`h5 + -0x`_MǓx٦Us_S\U~Q1 Y܎wz>tbl�������������������������������������������������������������� |� endstream endobj 239 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 240 0 obj <</Filter[/FlateDecode]/Length 283>>stream +HA0DA +,Cf䇪v^t�������������������������������������>pK>`4`+7} ?kɰVY[K}_2>,v7rci[<9Dzɑ}odv7}\k4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk4VLSk̬`�O{5< endstream endobj 241 0 obj <</Filter[/FlateDecode]/Length 630>>stream +Hj"AM ل0s) eooǍ1N<59&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qkbĭc&fIܚ9&qk?f|}8SDn'~2OyO'=5Oujrc1󵺏G;3/Qث^}*#*a{8cCq=#lmty<eksv{U&#FE.حRcqTr ٩VE}D3}dikȣI[tNȩ'ȩ'3UYdsdj$82\Uv SUcgK3SOVe'K3SVcǙK3Sc.LaƎ;thh+#СPqCCc/@6KԝPq;SsRw^CLͽKݙ;ugC  ;36x$3cGΌ  ;&_EmsW&_DM4ܕWQwVwWFG�x$# endstream endobj 242 0 obj <</Filter[/FlateDecode]/Length 25363>>stream +H͎m7aOn$Ύ*W0JBd")|{�c:.\?k-F+Zsŵzk=RѼ_2ZcȐ,~~y4|Ykr%S'-5n}݆%^+禎wW3 ~Gg;,.f9으&9{_0|z̾dݦ,ٚ+zflVj4Y9)?~ C6Z(5Cvg$s^DNU$Zwz#Y\moŹUi.WW7swUgȝ"՚Q~dJ+-sĬ04:G0yM]ʺV[v^uЉrvINVث +ݝlFeM +Ӑ+;hq619K>+Nq{"`\8a`> Uvd&yCԸ)lږpN*F04#v0|!ՇTލh:fCHb-L +E~p]xM?IG{6{/ēcpU]o;eq۬t"Z$ T+u(<5{|$&m"i�"}{?T}I5PƉEjl PX~Nݖ-}7Wo6JPFB:Riʴy3dҽAA;Y[;[(yŶ6TLxۯW??ӧ~L+q}?_/?iׯY[ծoׇ/oPlm1&XR=P{�-?^{D5ݩ9rF7ZZ5͎ !sޤY-T;%b"<Yt;)/7,QՄϘ@\}&=׉숩sqd ̭Pv.9r$.+Rj)2waܳntall'ׇ> Ϊ/}!3ΈD) )5xP8b4k};"@9O2�A=Dihy*ާJFY 5 �L@%ShkEtӴ5[.0GFi3&# z*)nADj 2 `4j,cDl@qCC!/h`}!F<bǜH.Ve5ʡЗ6U;!**.$eJٸA/"E?FTI#,ЬV0�_PƮd`?X"|]�Zg'x%?`.aXSYqSCN[edO'>g')9.fS:~RoH�io^|k~v핺zﻄđ !ùُCӬ/UQ^kI#ZJ  W + K%B-ED]6>t'r^e +Ye-arFE5,^ $+(+Vwˬ}ݽt@e 8Ub Z̳j5?1IҔO az6YEo^)TJA>'O'Lƻʙ~"I/iS麱# _@;OlvW<]Pߐ]@?[RAQu:8D랖s375NHzMT)qh òJźj-G_gє`l1.iY9h@ m5*.*pqw%l u2AXPk?$Lz"݆ +[/Nt0iy@Nai@>' ) +_Kף$KZW[+bz6*T%vE)ʮ;ZkW\'xhQƗ:<Ƃ)ES2NEl{],ScQ̽y>y1ɰ@k+z +z"F--ǛzYװ[,(є2!c[IJl~ yUop٭C}o{OcOAzcZj|n$#wij + N2!C<$sdIT>i}pa�gD!mے/:'dX"|)rSU/ 'P.V<Zid;OCn=P{tqᗤ]ީqUER94_;�^+!)hrI1rKc'N5l*6G QC +j(''fuKݗ٥_)K/gq(!"q`v"y\Z>&Ru@lׇм3o5)z1V{4$N |94K!Nh!Etx" +<Q$-:#moU.#)"Xɤ;E줢iʏN*8bY*. :M'fumm v&D)I S3PMZgi- bO<6 GY6',zov89A : E f$ibƕ$eE{ 2M%U;I7)-8׆7 /'ZJ )cט,ơZQ;nH}TimkT*(4eI-'ۙE8ͩ�$f5jd{񖋺^\Ks[ez 5%vϲ=VE,`9+,' -a$�LЃD{u_+N\N;Q&'})DEUez1듋Rϴr6kb3Hձ|rKVU栬Ou_uuXB*SW: +Sڞr}lw ppWaNn3l-LYz_xn_E!\ҁ9' #_#"iV͒وZnDAD| )nמ3QL<(}=c-=7-jDL}g;*g%/ڣQYk|1m^ŴiM䬻g)V^u0}:vK9+nUΝ ˞WC/tU y0)&cP}F_1Y(HHσ-`~ݺ[o پ�ŷߗ3[Qzl@L);}Q^mq\zn$X?] c`:qgBٓ7[醞Zюˎ2ENwan$_{caGvz\˧"  `Uok=Wsq1{!1]K96QسXz\Y R0:y\vri<k6#HǫYbB͋ȩT#v!:{[BlQ1B 3*#IQY|8 2va^<h菕)t cFh*=^~tF%@ THE6dEVe}OG\j?]>P-c㪌۲oh-lS 29Hh<kt VTdI0i'6 /Xi0rT2a|,6AE,[˱o|­kDv dROq< nBb[y/ QPk=;6ee8bsl9L8H֯n1nv~H/Ԃ;/?o&>X*J4eV ~{eԆ5ۣEd$kC^KMi`ps)\ℷA['cQ,?9T*+jYo z3 LDPFxʹ(m{"ڶEDkH^Hs.QFi_I vonOV׫|4EW1|/?>_C)0낀Hj|\}cD[9>~t^'Dz"YӣT~Bf^8`g*b4vy߽E:F;m~ޅ\˯VuZ觍(Jj䪻 T\LԫG!–XcP4OUԀJ~k4̻H2X4ԝO'Kq0@~\am; +( ;vi($>"m Vʠq)Z-P| uP-/&*ْA< R vXa G8͋[l8)IEH߃QW"VB;$vj.;10֦ʐ+>>| 8u%̏x;JkS!;} Q.Hr:Ouן?aj5$yQFkd*Q]%*؜^ |pU>P -q KbN 7"aj']1n[ k xfhsH;羯MZL^eq`RU238t4Qrф,N)M%QM=p_PzھvsWol7T5[YӶtۡ69WWɤEQ5AS?oS$:DlS7IJ˟WےGN'?&EbPJs$spqFJRi~mliellu+FUkTtԘ~N5UQ}HcBy٫[^5ׇo.3 +>GIˢlu7b1/C5e@}IAP^B7fm%MAW_@Wj<X 婚cՈܩboB +#:5VhcP?/,Fa~<k4b8+;} +nc=sb+DuU R. ܬ #cI\EYئ(d1!;5 B摽?ظ҉NmP]IB:f=OΦA`/ ٪1S* U0Wvy$XRL!=^+W+%RA屺M +D JeRug)%U{P#PGȯMHױh"޴0@_ ;?l0`mh3'uh sݔ( "v?eG +Ož_Y=HHc(DIlvUEp=ۊAz1DǏʐVRv%$e`jwibm_Bf9@q<@Vb`MB;Ai­-'iKFp2+Pe23afFln z\WLe'u7-@gx=oF;#3 lmiX35{-^53xx1q-*(f;ݸBUc䶠z{&Ym匑t]Jd OYx$WCq-9љOR.`Q7oo~|xo_v꿵Ͼz|zh>]췗?~ 㻇?}ՇO#W7yכ\~ۇo??~g?=Wxx}x۟]B.Ѯ?ݯg^z}sV+_"w/?~{p5t0fwiC6emFP`i?3d5R(u^|W,gnaK=c Hj55w cFƳ\wI]PEUm] +RseRة>ڒv%? +$�)g 6Z$Ey.=;myOM|zG7z!4ɘ¤ +Lo/Z[UD> $,? &ǂ-ܯOdF0gC&hb_d0Y2|%x�NʲS2-._cqVN0P2fmG pWay3Y!D rݙfjR D%lY]kҡXY)I.܂,�q稛:~=)#Pב(5tMO T_M^uu%u&˧w*TT8&ФW΄D7mGJq7-ɼ PZ-w\čB.bKSͺZJ5�~S_Yp*ETQ˅3kx8h�Pn@.%v +vn<,lHD~,u͑@R/kʊMr̓E>54-*Î? ٻ.8Ts6X3reGWyW.r}56s ZA^Yv�2R!e]ZGdL5?wEo5 8f[-\5)gaO3I/K.Zg[($3V,]jg?(B**tA +W;ʋw%.MǺ;!5߃!,aIt$bz^ * +[y GuP!ZBW"IǦ6ãmke"bn! )FKk8[G5sB@- &R1m|=٣u#eTDD6k<pyM=6obH5Q>(KU5c$B c/pƞQe7-W3۟A<z?$ͻ55C9ڹv|7oRaq8,Sk&itw]V>z'MxH{M@RdC!d ]ܛ\Pi2#Da$[zG [0͒!3 +) 4MV5K,M&E5ZWT藠# 7_t&C>iH킴ykPn\%=1N^3B +:Mǀk0ThJqjYǖ q^ }}QsL1c;N`e/w/>u' Wt.F`n)) \Q~DaوG#%KTlF#¸T%voK؊n)\qُ2__=Ky:]G2_: l _)YʅKl]anfbLSE� Qò h.ȏ[È_\ )/bN$\k2t$E&YJt`<ӂL�!ϖ.cvUMaZg7{RFjm&9D2尨A|4Jr^6"[z6R׎}bF$!l|CVeqZ>+-3*U>\ 0ӻ*ˣ +OfԚ*Fw>O UZSo<Y;svq-{K?Ԁ{"[qBoLza!6@g')f)jǭb +, ݭ$%|#P91'+M`&1[V- j ~sCF.VTzqJ ![Rēmv:Ppw-o@裔h!rtvO8{Qk*b%Q)l*encQU^זr<hQB"j~X߫sn+HJ7W27ݳa1I3ZUi LL@}:[՘b>'%Iv)=Whr؊++>pP|ᤂkIJmwjgE@!hRVHl[ + zBwNRu 2JeFMh@*2z=3F+V-I*!ghsҀ*=\P + +c<k譎xoQ#d0W\K$mW=o+ #I�M@B'p<WU+ :źSigvv^reTL #n$J5>iSO9:{JExEKI#nw (ejyQۮ607PUu!dkT&')ɢJ b~/z�WR*/R>gK<3Ag ^pĀN?_/o޿n?>?ۛǻ5 ]ݼ=?_q}{;m>ܞOϧW7jٗ^%;9V)~g܂{ 3rه�k1h[ɝ8UMbLQ烧](EEr1^ieL(e,Ae M + +j�6l +JH{.״䶇bM4:z&MeIo=Rl'fI9#M+G9YĔ PܩA;R&CAZW*�jqa6\װܘk鮠%ƀ:VgyV)oq8D%VQ;,iT54t)~B=|"+ƅ,?ȌbѮpk 3)]s`$yQԠCgbt`x:dVl6JoIml +B^ݺ<z�Vn4sceͰSjS }N݆ͮ2r@A!՝D"h˭*r|%ر.;/~$/2) '$qӲӢN +6UxD7Q2 i "cFSh *.dJ,XM̢4rEV\H$2yV+x.0#SmB^ƈ@Oʶ$ָm'Kjy'v2V6ij7FǵA.&�JԱTY_@C2HC@ 0rQͮQ 6j6-wj56,%`Jܬwv4:A_�g)Ys d`t,~|Z@2I(lEꫠZNۺ_Y_TT1,y@$s>@ AZaJJ(Li/N_pWg8QEUQ=\sO2 f/jT̚:A(f,T\p^'шX [p4qbK 2)۝/ʹf̩^-VHQ#}i +cRH煠:k8/rjtV]2B}vü|YéjB>.-"C*^dؚ,!CYPUq>%iӡ +~p/^xL8� +wc}zjb{[8>OMy_U_uZe];!l `0jH[S!13LJ�f tR +p%5,-Bz0[ITZn[d3A}QevrwrC68J5| @Jl ,FIqw+ #e+q" +H`Kr@xJ2s @0=<ckpw-NF\bq ty"tf`v :RС J^:Gwm;/Q> N7o<uYN/EuV~jFrgX-X ]spгZδDP.DuvpӅWvȝH98h»r�d + +y ( fjy1rZoN-\(MM\2m- b|z+09SL8ǂ�=${$*HR<xr9gEܕ_Kkl.P<1dIggg&equ#+uTW@c+5sd4+J,03Qx WOX-7!B&KI̸Qq`ygc8 amƨUKp;jra^DXōZ +ݦc0-I^9nŠB^0)!|PXx +\BzPƸDVgq:{  Hz"H֑%.^ 9R:B]1:2 k5ZCW5"һTU + +YÉٓG T�j+s坹b) DK#'X8[96MK[Hh0BPʁ $6 84(8R@7Q^x@ۋv{䁢o=˛oTe{χOxzrLW7oW}ܾn_Nۧwi=x<̲Y)#D,i7 FyxoJ% ZS#46<VwH +B/jnqt[fXH n\:ҧ8o/v/(Q8$f$IWQVj 5ٸV[̜8xT4!�ۍ@%N7cXT oi v(!b&tā290T鰕uYZRMpl+3i0`"P?iyNB$iQx/$ "ԻjSywO#ՃnHvvY[%$*π4!yiu8_PD\:ntE_3o' iRք<r*rj0Lن4ZBŏdꥈ7BG[SAzϸ8lA9 DbR;zBQp +FSC'Ԁ9!'|,-RۈM}!Ѱ/rr->Bd| 5kiaVrӭm(1Ho2zG<t &|r%0pA>WײqIPy+~nZ?:kU]P8`[vCMGS.!`k$uVeʇO +6Ȧ>-yNw:N ސ@z]wvI-Po& vPiݔ=zp<Χ!7"қ) 4u;J)yӾTT.e#_iBfi85 mwp&[ i=+MVT#[},]eSݽ$BO^j< 59WW?׭l!5~3`m΋\~]wJwY>vhFj -󿇕/tfŚRhwdۉ0TLnU9'߲Am_Ed]- nm mb ! Dnz@})[2[h#-.xdO2s FEc{v _ jKq>Ϻpk2vOmWdY}VA9SkDY%^t<&&F -yK/I=+Td 4d3NJb^xI QmkgWjT`c4W1ɵ&>”~b(t]͈N#Ҫ P͚֔(#UD,n$Jk]Z>b Uo-KSh6a;5U0WTt'Q}ldP:ԃ|[ +g$㷜6ɽU̳OGah޽i܏|o!sE<-֝;ڏaN#HD)ŃgR =^K"FÓV%dg8 YP1,ŨHw!T?i4Nvr.K@ QzXU!wd֩˅F%KsF=(3GS^k6:ʢ4@u8nAMЖl\9�fƧ|ˉQil~&'&H`v~$~ɤ:~BkIyHrl>W;WEVSq]?ͳ61Cd旡YkA|\Oq9* +!Z7EI( MR `pOn3 (=@@D|,UZ0wU-ۑ0Pǹ|@x)HpL;l jW_ +WwJđT7ߴl"9y]$YFf-w +Z-56y5-*d`*"50]A#ەo5R@{'Y00 xƢV[I3S}D (V'-%Rȶy*.Tu'2) ~P ygEԭQ`idy5VFs2~p'#|S_]!lpP}Ȭrs-0h2_z:՚i l394*_W<%\U~ UdjY۬ a�9ITp 7%qM:"4,vM9)QodQ'a%;)H/`ĭR1@m׮YTz.RuzI[x'�PMUDA%";ruL[ߌzhV4 1Ev�(;wlKK6&޽t��ʓǩ.$JEw Β p `pb,zyHuǥT3նGet_% . ;+U)r`cE"sz\S{g]g~һoip7AȘ>z{vrϓ. s TQ^eW_y +.@ݲr`8|+{pCVz@c@o9Qσԏr<%�EAoj/^}tg"dy mdJ]I1egoa cdK;߬RsBJas]g'a{<n>PG<1(z+eSe)IuX+@JXq+#2e.^IpR7FfJK4&UEݏ8 Z%? ߍRLZ̽H?zo/k3Vir\֪ Npoʰ{|v�3?,{{ל՛Be{qgW5eI2V"!K*IׇC[T :7?i+Ԑ)V h:)sTaz<.$TPQU-�H 0#<r7tǁhC'0 9 ȕw�掮ȟ$IG2ȃVd�x$ŏ=@!B,F |\T�[Wi*xv 1 e$۲Ԃ; {>{#p p!8]'2n=L;;K |?/-|@ˀ[W֬'zjKal +N&KՖS]Pf@R?7yyHd A&Hy5@CC�MGlE+}䶅Vk:֓ē)$g=E^jNL6v^umCn|mEvj:0grHmG @ 'HC1EJsA6Tg}dDy3}7?]�A;W|] +0Ԣ %a] 2XmgAF!C$6nbɦTKdƜI;/U{|Xg'qjnS~_d:ϑ! E:EvE~y]yEW*W4$"syǓy[K߯űI8l”k j˼FѠbgy1D �6F׼=< t;Yb+I #.zQA{ľD4ӟ#ggpVV +[-ۛrϠdL|mf& ۈ| ̅t *hʾH\Y6J9Yu(ݦ1M+&]+2iS H?jȴ$J*1܇aU3^g|pe$ C)Lea eqxЊv"Zl1IκDWzuoWtKGfPA%Eܚn}{Ӡ +O;j# erSVE=IVF,�@v"{Hʸf̫vQ@s +l]9x#28D޶;9$+YagoWZkW93lּ$58 + >vMdpz9 +t.&c2Mafv#bY.|;g!h�&"Y+I1%1K`?~Ksg+c %Kbv* YM)50gazDSΤqSx9SH& I4.� +(m831Xӄ7:_@X SV񟂳!PRپb+yC)_4 S~ԅR]&%<J<Z=?S,]D_'5Wy4yuW<CafP e+k6+L5):QP;(N(_ +_))\�Lݶ:<C6�R>YO@!t)2n�OO'bV|$9-lҮs0RZcs͜:m9va/; >hkMY?ahy3tVC4L@'wL2Kౄ4u-<"9 B;&FCл&^<5j,'ډzAQ$4$ 0.a˝^}J5kGGT@Mh,`3Ɩ&,B_d̝)PԫFe5--)m�{.4_i :N(/ ;Lyߧ˯rଭP`xiNu;A}]VNl/;5פO3\0ɽ)[z 1=eJL1><uhrM SeM;)>58 +8 6JHeqZΓB]*^ݭ pG&#U fϽIߞ뛲[X,k#m44*^\Y,2a l{t+Y)t̲E;p)z#\PJiW/]LO1b%[MFYMFc%qΑunWRHj i!;ҷ';IIkU GbhtU0>ESl!(پw_A1f\ɖ"Jtg:+n'z# [&,j|bb6+S>ݭuVu 1F]rmUr79oe YJWkU5^8-w^| +Q5}nD3 in-BfA Q+r'˟I*}@GAHQ*8�++C|\6ѭϡHAmjbۜq) PNFZ*Qf'VCz7a<j iDUMV%ښh0`)ȭ 66|@TV%Y%wa{2Drgik\;UQh ?OE;[V'47-ѿe�ح_5_9KwEB dt_׃>>Ve3T$<&=?|DGyN, |=Vt'?Uqc/"ħ�9X-߿3C~)z.h?áUj=B8*WQqq*W%TV˧zhVI"U[>{Ipf eD 0Joj$_r7�ĥdakjdatjr#~ 2ef`xTހ1A2nr,RFj-4 MLs0.g�uL2(ΩNXg f2G-. e}iP(S R4q^}'-z~mΪG0rO(촊+ 췟 #ӴG.t2}w[lc,naZɈL D"B}2[+Oc+t>b⫩I;XzYغ0֪2z/xDV/3zRLD V$/c5-/zDxic�s$Q~C2[v[*ؚVfBO}Y?>a#.}l_l;#5</F5Ba-<lӮ +R,6~}h$x'g=duMZiۛB»HQ;*�"3`&\u' AĨi8Z^Ð+4~Sğ4:-ҥm;SC 8|$-Z`1)d@Gb^D^9*2kOIz3'ӧj]JK|ʷ7fϥu +ɐ[$&;+k`V#Ԫ ٵL oDƷ:"D/Kx^dp�{B#M/ ]e:b3]}y' I(Lsg�1 mZRP +%Z,WSek( _ḭ.}eyR笒: +);Ϯ0NJwg}'u"B +I #dʈ鉌rI#(1 f̫A2[ȅT"D(3zc_vΝw !-%~$B',L`S@ItNqULk|8Je["@tESi�c|L);LJ!;5(U.Efz9.Ap{"lѮYbDVY^~tG:V 'xUϓ\R|bߔ3}: NwS^Bٳ�l>vIEt.wP-|g& Zb|}�Dg`@x%y@W.)`:h▍ZGIpTGE<BVv/K䉽_�964E}Vx�-1"TxTMPSޝUd@h|A@_G^v/C;:LLƸT?#YgiR AL5.೺{ʞ73ܚӮRMT hRygh ag,xglM||BL]=Hu8EcNt!TKs9UJ` 2;APƢAIDP�^9V%F ?~P.@4 Ha7MGo2hLc:zL6cq= -n<iA\6X/p`nnCp&nЩ@UY2�^g`{ HX'StܠA#Ȳ:iFAU\ڂ$ ?qc @`<#7y^Sgt8n D0 t6BDfS̼<Hly\ )=D1!LCccC":"d*#=1%j?+0R@ɠjq]!n_')(AXcvx2w=p!޳SjZ*vc_ +V 7Uf`zԓHYzӎVMEu9cɪ$d5sP }KaP7(Ȉ#WNn%cpR0*Mȃʪ5чF HA!PH(E\hx$' º٣de`MbC3,8lyH$|DÝٸu �DQi <@FtZLIgTndF"J-JڌBx_ͣS�zBu +ë~7/~}uρo߿߾Owm~/o}xӇ~swoݾ_zOny/?kapq! )c&y X[4mt+Ph`969$#c-l6le?H!EPp.�h'Ahp^DxG# Fa8 JV,ENeڑ#X * ˁA`Ӓm )J k4TԢ+ݳG؈ qg1|n Fwa"5 +GY I{@d'ܖg~b*{ q^r9+m7%!#s"a!j)<6"Ғ-T$jcb?�D-a}֑@tރ6=.4-)B + 4zd?*o&/ FP`S}ȳ<Ґ R|o}Xb=OQesh!s*dX,[Z^@18]ό<PRcV=Iv)tDƩ7#lm$<TZX1Ed 0Mr\HLk>6z9b&xʌkײoܛw<ۡb +(,:4&Ts5+rgO&7z^OJ*=*:fI ߽ 3ԞnCc`ͷCL E/DCᕩ\ =ᾦ;a BJ C[iڢ +G3 +(zDB@B!t;_o9 ߓj"$~fI-$ gKMn7 3v�:15S~JqHR*CS�ҍ#Ek }ȓ7ߧ<gqSt j +΂l>0|‚9ͯJ",VRbN `+vU3!Ihfi_bCZB_RD6Sj'1b&W('x%$sn:xG%"vXn->\v@!3q.{#;XCIa^^_M6GxD{3ק:jgNtw= a,#RƳ`wA.00J^.3s˧ScW{l / *H.21{$Ϋ| I�xa^|1IsZz Y5"uVQ0}C_SSULKD.ҋȂ.G\uGXw"QU!RϡmR$.qlqxce <"-?jΞ ޳c41KƨpacŪ;[0#XF[aEdr}J=vҳwiܒH|W(TJ~Y6ynDWܗVQe|J$$wNl[c壸5#꜓ƅS+[5q;cJ3^{+Z9P(x/؝-�ׂFo1{'e䈓G*c89)�v[|FJ)1s(G7a2G˭瓰LQ%� +9�g7ML�R+ vտ MQ+셡\O"6Iw䭇6!6>A2!�eTT)FCO҄]Og">ˢ8e7-V$ E{. C f v?6r<rx,#~e N] +7ipo.  T#ɔesX�cwt7;9AՃrGsQ^�@%g-^ +ME`^iS\\M0Fl�Cs&d+U>6 6zMJqsC0WWzsi ÿ]|4visW Ky٩K 9nq_,c$6SbXУ?Li;F`!7moT;\{G + o3)BW!Rߝִً%u+x.=j*+y&9_]6W `e}Ϝzy9\;[|g�=28t[qkB|slޭ_ x{;S[K߅%.m%p&mlΡϽTrqN,'{ѵ@8DPK忠K#\JQg @7Yɛ]UL"]ubmN~TO%.j~5kT. m3dyCYL{bGV/ǽ +! +ctŷ?R6)b%OyȊB}!+Buܦ52, ]rk(E.}@86><5BFmo':9)/<YKn\X:FHx +xؑ;Jvh\ZӺsVȫϞ"I"R1- )dUA?Z5q h%pkQyelo=$HȀ.ܣye6@Ge츝3ۊt�U'U f։,E)VČ@ x +Dj~E/fKl4 Ql){+<c3C{T +*WF`t0+ +ӓth;Ch[qRJYnJuq7B<ʏ_&o$G:5iCvIc5Hw'|^>~ !8WPf.ׅ"pr^tTKEHp \@RGC>,}lu=Fa=1;ƃCW+aX0Z# _5lW |ʟҨ-ͤ+\'<!\Pk9*͗t)@, YQTiOMx +,MsPHZc獉?26*n9\yH5޾;jo 7A ]IyM*Ǩo02*vPd˿/:+ +?AaTQ^-HQJHU"1L"_yvN:+OW:(9-,伬I8QMK)Hj#n΅qÝil;wgWͩgsR#[5HarXetZAz]hv'63RK _IG'ѡ~HJwnc6+txRw6H 6H'9f΋Q4éV̢ +(6gg*SOZ8!М7@)[]/MS0+T-t2nU:Y VF4 Mқǧ@Av\hk'iŕ hqHȴ_ʔ'Ԗ\Vҏ5ePjH)"PL ; i6Ux!>MNJ{.b"YFChҬD*eqGrt~E; ZX6a=|w>/8jMƊ>H(K!uX1 %،me]^F{O5{Wc,FCH~Ilq4pnהVukSҥTyAGJDJ\VGRޫT_ "ud3O[l5!XD3e7v c e"Z5NAu$X&ӳ}tGiv~6i#'2ЌSR|T#%JeT + +l01@pqI�>NSy5-uecQt)qR긃/ZkB ٶM)I]C�Y  T0/1x.Ifhu+FV$l +T)q$ЛD#("=@\Qbu'GkQ#2sk0 C:"jث|IDפrvVZX=\)Z1z<C4 +!=& >Q=OUauҲzu+v :�MmX7ǰ%;J73fb]J W#M Y=W|5=6FtId @cVWP 7Ehʰ6dug +p`5Nӊڈo_eG1YݗZFnKREhA$3>ۑQӼNFC+'~%� +pޱl6DF mn3Й, fS3ڼў̣B,d#Y#U`V{ +(s8+Ф̫"22$ee[QIkT ȑvN8P"\՚ A+*tcTbmjE1^4t f9Hmle"U{9jWPS$2aܯ{<(1ST5<[hz7ƊyH8ӈ¯>\=i=B^'̖H4a\ +2dP>Xg}}s ܠȚMY4vf|5v,uqTu!חS_LMԣq?ygn'ځCExU#l]U(c"F]g?w9wNQol?Ͽ!1_O>ӟ }HkԿ~|zGO~ryo/ǧ?_>r7on8ܟ_|uW/߾g\mOO틫U|~߿'<7>_]pl4%r!"~!^IWdg~ys}yL}~wo׼?$}xn<uG# TwDNٷ׷WB??N8ڲy +`x uY2JGv M+=4"8)J`F%܅MI9cm{:,̶d {#bH$!${��U)JxmT^MHaѶ@!sså,.ߑ8`'ܣ/]YX=6Ӂ,ڤe!%T)"p 973$eA-a=&,M11HZfjylˑ]k[9LT֏0Pfxu@E}pc51,u9 t>Gg^Sk|�P[{P_ftNʚf,ū9r[ .;G +u5P}Hխ҄wwIzO6 9K|x_A:ba2!\zX #Y-x?>5oKgԑI+4~M"N +-u;j1z"]dJ"SD\G9ٴ^hI*b˜c©a:SW{g{.Qz.XY%<7AJ]o'|"G E H%&ӛe +7Ixy79m@EJ=0hȠ:dqXgp.rN2]<%Ь`ZqWl9ud`2WY+M$(֜fmH"�!N2XIT0Vg`M쑐t1%MC#Bfs<Mrk2(t]p^ +X%H&]5AֿU;a "ƒ#ebS$+PflD!kTؾHҫ`Tvx,z<hkxii8wX$c( + E,R6PJsp4dT 6r3P>8yqr9f:з#KJSDL)bjc[ Δ`~2ZzfOAj%'ii^Ņ@V洣j,,xcYTcukz[Mwv1 Ve(S+3X=;]xӒ3*~KmMEDoRč +P\KB:){M;F |�5%]+7,젼']U;au{!`IZҕ 8'0�x(O\J`2Z90Pbro=\8!\)1hPĂy)^*)-цvFϩ7*夥wNE0:DzRΑAOxkJB&=C{յ4N7y/9D&. S>f Ŀ~ySR||o�l,GxԯNf6mq ζH#1[x;?/ϳfoy3G)U[Jy.y_E_ĴI5!X4n,mWPh1$x՗a^|VR]O@ +X=WORt_RnQ$.bnWˡJS(HУAj[@k;U +; ӎ�x endstream endobj 243 0 obj <</Filter[/FlateDecode]/Length 878>>stream +HR0 DO;-|+XV-m/3kO.%~dwXqk#2ڹ +} �v>_V{};G8s,}`>rv>%źAvIg��z/v_8D|K]J� yd>fnqM[GZdRRIT)|!dD:Ty g +b;;2RL9!7x?UxoH%*CagOTzřZ>FN*(pbЛ.*שPP* 7 jTqq`.V7} dAruz"Co$;}d>2CVѪ}|VTszSYY>pM,U"Gq[=xyv@?># +1>A-RB :qBhH[`r"dxKY'^O'97i ݌/3;F7ңyYG?.:!nDո-Gq>k5bAﶩV#Wc̞t-*:Qr.̫gٺկVT){GmzF R5hͷ K,]m ߧU\ z4rjI;|r%!DeĻH"U$x؈j%9QmVq˰"9Ejk~b`WHYfd : aB38Fj t~Y:@ۗ��p:i endstream endobj 244 0 obj <</Filter[/FlateDecode]/Length 660>>stream +H nACA + / +N|߂v&'JgL`Ծg:GL;Q?Ab:D$~7::KL;!QuvF{ѻl`ǕyvN{;Hͥ6׹=I%yͩVk+/z:T?<]11 ]11 ]1W^?^q6U9֚6v\jsM:G`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6Uc:Ts`SE=M=6U֚6tܞ*cM;C7^?Ï `Ge%�ESF endstream endobj 245 0 obj <</Filter[/FlateDecode]/Length 620>>stream +HAAQ26ӭArFOC7T:XTտKPQž[^.e2E +|o<]x=)I +8S3`Qf~*+:O%cEB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gtsB}F +=,*gts?q),*].E˥t?ut~G#t/_CK |<ʥ<Or"X!>B@GtsB}F +=,*gt��B endstream endobj 246 0 obj <</Filter[/FlateDecode]/Length 594>>stream +HױJAQWD'x0m`!U'<,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zйB> +,*t3zй_y*;Wdkņ-y%=XT}\J +Tr_9O%NJ+ǁW~ +'r\>Ba+DžO#\yz_y~BzspWSѵbÖ縔+2hA:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`QsуE}F:=XTg`w�}o endstream endobj 247 0 obj <</Filter[/FlateDecode]/Length 715>>stream +Hn@ DQOo6 ++byav-%1 =0E^FLQ躗Se{=0E^FLQ躗Se{=0E^FLQ躗Se{=0E^FLQ躗Se{=0E^FLQ躗Se{=0E^FLQ躗Se{=0E^FLQ躗Se{=0E^6̚ib&Y3M3k]xf4kϬ&vm5ĮM<fصgLC^_(ƌ-C]{~)qt?Bq)竼+ڏ7 qW~~ GD#<a?q.ɷ?I?݃r!~C)U6h~$Iҏ!{WH}<-K >ӏ;w}3]d׋wf.69 6fg_G~locُEմ?#pWlǫ;=d?NhLr?TSl?~||7%n? x~t_|v[>|/ui=D;3cw؟6sh>ӻ-tgdw>yC97&?|+蟣e]g~4}gI$I$I$I$I$I$~ 0�g endstream endobj 248 0 obj <</Filter[/FlateDecode]/Length 359>>stream +HQk1�= rծ[SNct"帝@;޻m IIIHrp������������������_gEUΏ6mQIfu0mz uSWm糢yu]j?S9}=KzE,.fquz^݌:ݶҰ~%[U7aޅt0\e];9Ox0 pavIwF! I[m8꒢8SӐM<O���������������������������������������������WVs endstream endobj 249 0 obj <</Filter[/FlateDecode]/Length 87>>stream +H��� +���������������������������������������������������������������j��� endstream endobj 250 0 obj <</Filter[/FlateDecode]/Length 222>>stream +HνJBa�t &9;49BDPDumN^H=ȁl�����������������������������������������������������G0ϒs=z^\��qx:_uV;��8ߟi���vsz_NMR  �H!U endstream endobj 251 0 obj <</Filter[/FlateDecode]/Length 631>>stream +HKKQOęP Ix!n8I4i5Ab(ʤJQ1-KX'Ԡ&l!P8|<"gˆ kV�_͎/ڱ3+2ק7o,��/<8;5!#C-~��]cnm \l +֬-��|}6= 66e_;*JݫNv7du[DDDD$g sZy1l]|GRB/[DDDD0A^ -ܾ͋7?:!ύu[$L>~W7:0 ~=k NN\be{C?mpgR4s8 Kyztbo=1zXge֍jO=Aib.uwL|13;9cjDWtOӠS4?H~NY8 ?5NTtom+Xfjua)u6 �o5b�ͼFL3�@׈~�71��f^#&� kD?�yg�|3 �oaN#�ȵd endstream endobj 252 0 obj <</Filter[/FlateDecode]/Length 199>>stream +HA ��A uS[.3sC��Y~%z�hk,3�@_c�K �Xg�6=�5�ͯD��m~%z�hk,3�@_c�K �Xg�6=�5�ͯD��m~%z�hk,3�@_c�K �Rd endstream endobj 253 0 obj <</Filter[/FlateDecode]/Length 12657>>stream +HWn\ }}7r HkP$5UC{Frqx+]=I_7O[Ttqo.>ZK,+d,斶RiK:tߊ/2pv۠\Fb/UͽXri< δm&qSCRuJm%KBo"8k{m@бDi +zn֥&EGܭH .+Z| I$(e.ma.=B2:LBXFϝ:xl^2utɆЙ&e !u# vd>kB眅y:Az/Qs8+Rj*3.=n5%{.TY(bj-tf'(N7up+kxI +R&o4PʋiWDZĠ +{#֍Jh nLu`.d20P/Zs$@+#S ~C`QV()J_PO<J)#2V8!ٽRe�ؐ)X6@xF1O(&2} w$L\�EUX q%Ɗ)'J4 ʶ?,jP�zC ׊r$&&0D 44j�>!ZPm� +N[@k"M a +vl!�0= Bi j^?Pxp#q1e) k#f:et=2+\,ȥ"G"ģW67ljx9BNX=%=N +q3!vu8�yP1Ʀu&0}LB* /DTuܢ)␰@`GK TMn*2D9s;a+78[�< 9-(! �DwAsz) Mֲ.0^>S w0 &ujD ˁ P26߉̽<LnEI7Jw qt +.\cZ"Z85Gx+s4"e�%D,L@R,!lx:l9$B\r✊$U8X28W45wj:iJ�I6fp֐ &ԑ6$ym +Ԋ2 +zAx(Hp)1^tp94b0JH aϙ�A*3FS0#7W*L* eW v,Fo@Nx0rt1%t`o'Hf1P�7f#E2ХT`b}8B'(e -֕.Cm$9SH5h7zFbC&ӹllX[Y+#VaQSֲ#@8bjb:qmh02|[ɨs6Ƹ4p'*鮓bxquuCy) +@r)q7<enXW $Vw$xm ` 㱢 9,KQxȧׅЕL5 LJrY 6 "ӔXkdGKzj. L�mY8јTR"{GL72p6P6�kOnUd2ت3[,Ͳ"雹 bܒ[<^:Ip֙F,w**0,#6q3*U#! +oco TD C.{ 8"m~A||ŷɳo%ӛ7ݿNޞ8'vPvr~{Ո|z/on.\|yͻy  c{pF"#vb3˓ۋߠqdp8=}zryq7g9 ̑<McS~w}%B^%O^\\n/˓_ҏO6&gͻgoI=J^~:�Db^l>zܟߓV䧧$DN!r}q# "a[7\0ye5;<>na{;ckq5 W[rPz(k27l{rcqVu;mo=|xܠӠܗkoF-}BeRGO̾u8yx>80zò/| 3 +!)=EW)r9]U-, +=Dbknޘl#gN3w)ỺB`PP)ui ۻ8V +K%D6E͝hr p[RVc؆;GkIlw+q^SAEUGlYY fr]Cݫg +~?ټ�*;j9ԁ8Ho-!0w</JsW5{3e _۩nP|r[ 2Elg;Iɤm)8FN%/+$"wm7$+̐i.NKp7G bt}1O d @)YV;)AKDA'[~ +;.5E B3A* {/~Wb%n8DFmD!j@ %HƛmDf`n=RQŏ֜iGU2H+[yۊw4P?-C .~״QֵPu]̔kmKoFm}}xfG$esp3yW++zKj{Pbɞa|.wG{m ?w{ Ƃ!|V+<H~_??¯VAw6�WLm ufE +Z|pi5bȑqAټTwc&91mSfsL0!~ >#P  {CgCm>�a=5aD*EPFb6(HA2S_78ȕj-ڐ9.QsgEP\@(UF񤊴#Wcah|Ǝ͕"S2sX|v'olY!dޙ}Xhļ7Vnh fI(Z1~w2 un *hk<Q}"w|d=Qp4v-6;2O6L9\%$j/BtI(;Oqڣ>5 j]] vI՞f2*s8$_POW+h\܂r{X-wv)X: 䓾 T~|g{[zY0oPpҼ$C~憒n0. Z٣ |&Ø&Cprv +Vd}h'GE/ְ&?ALHp@CZ EگH3=E 4k*9P}YtNŏbѠSeN,?}s@U0pK{@4AӵˁPFu+ f{,MX%]K_T9`I\Xڛoʹ>QIݴCPZWm'w^p9@- (cngd4p|(|8zHib:)N&|*q]rf9l0UOm|~nBaKGDaީ -Z[,򁮠0G'V +> sIr9mY&w!#'J"?f&˺S@<N(U8kИЭIzց6dDB}~{yO(!)?@7 q}=v#l*br.;7DmHgDSMw5i"^̱؂&Cj.5x~ +'^?}+G /YJ#4ø!g˂T|e"vPe.pB\6(mYRkKd[*ֶͣ�OZ¾ +ӭ=ԁ wLdۥFJpͪb]Q+)F۸Zw=:u#3B�'yH8 +-7l-*: m *`ZU?uFN !Pu]>x|xbC"Q̥&dE�Zo.h*#uɣ�w7ඍȚxsrjmamKS<: [zA'3D lZ!!$ 6ӭ Z|(hJm56jGlkضh#w%`-e|˚ݶr6)P#f,ka!JfmfXF4:Ttb -)EmEкNwPZR`Ƶ2Rj2s;UqpMzDuV4yfh3I˺wJt`:Wz8dS/g:l({w +maP9@cdϲz@ncN_BurKm>m`)WB}T1Y>OUƈ/V"`׬nޟàDEp.GCj@.^yȧ]50+^15&34h  P- \.y 6^?@]!50n Wƌ>+k/EC+F@W^# +'G Nr,jkUhy@!Ĩ\U|UC3n[<^~uN]sRgIr3L{|k:rڬA ba? +I *5Ac"ͽwu}r!f+T PVm(21Ǹ҅.(q5NN;(sTЧ3҆@]ZJs+恮JTO}j": .dgW:'"ȧHU %9_&}F=v+Q*> m( +])n' +23 "39>`/W(Jɘ޹ ˢAu9 VWɊ]7[&FRiB!`l'6f 4<PzN9^F^:q6#Xf>6c-՗{m8\Lb:Y/1Jopq $ Lpx]ENIC~_z>?ɿ~|^G/x%{+~}yBlX ֐.q!s/B"CP9lͺܷ rBihR,fN|p2);7U=s3}C"6AV^0dM,BXMZ!XmC +1d`;O {4LꚄx p%CKEvH[ c:;u>P Yzurg+bCp.W!꧔4`7Śku}k2h huCU{gJMM<&Ir55F* 7o`NB̘=&�̥{"聯!X+5Jooխzyn5ϊjHY5!Tf7Z(00K[<hGi![ҭ0T&2)( |V+2RSxͻZ~8%y.؝(:`]F:ڱVc]k^19 +hgpBhrod=-l:-t t@ٸCf=<D(q Y|pMh8Lk^Q*P5;r?HBRgT'Qʆt\.!_U2PYb S^*J, K@chF . &rrR7.Pwms +ϙY'66uP4e +&V6ڡ(@7~9.d[Gljਹ\ />jXGjҴ4M= 2椌iZk&躕KQN6Ԋ nWjEË +' vU8ٯ +Nڟ2q :GVz}T=U:sݐ;%P W#4;ht2jkG`aS)@ɨU<{y ʵ "ݻ.JqWX^(kKɆ65"14;@)e\'\ANJ^+zTT+G!j^1,k#">7r;qYW(F@b:ǔ2ˎ馓/?҃?H9$WO$e_tA 2?#?᯿?~o_?K/tN߽EcYG6akHP*:4]E4Trζ찑6&ul^W YgjjnKiZ2Cj`m3 : mKANMHv٧rŐbqUг'4$ASFkFu\霌L5ɀ\EU*hj&'c$խJftu& hTdu"pV]NSk2)ku+Z5K Rdeme9M +zr5iTgؕ]Y1KK7 #3 bj u N{@U-IWs/!&D NV2MoHVsn!T! ⾖SV=${ސ'~:  ; 3240!,2O$ we ]rZV i:v PZU[W&=-U+ݙ<>J̺5AD7&% +!+IXW6LVԯ}a̭? 0=TzXvڵ{.j\zufz>!M79l/ˆްvXXρɛSѻ_5k�Dr7ӳ\J!y1Mb]oĵA�(f3\e,|\NRSݐ)Ϛ%y6ob(d`LaAmȼfΤK9ٖĈ5 }91N/A2)1J6: Ye/:6& NK<F#d>N5 SL/\7+pUݚtʖ2(,gϠ̞S[]W-jNִ 놂۠'~R'hG-H*+'jώYa7npq]l$W֧gP^[r mP)HL; m-Jwd ;LJc+yL3^Pk* ךzeّCEsg˧O"3;wm/';cJc/;/2DWMЪtEʖHղߥjɜ{+~}+UA`> 1KRig "rA3R9ձc N 8(K\7T_`m +NqƢ`e[ ZElU^m,Z(찮Bc?dˆ׊K4Y0;{*ZkKdLlk>Y0g Ұ1.]Y-.ԗ14&,-H\:2 ݸN\ +i]f +)NKR!aa;@Z)�r-i3E5)k`|FӲ8e ,}Ckݐh CHдDռBc4եvt$y_]G$^%N +g@\&Jܐ'j:IͪMK<|T'24j~Vu_pD}i?AFQC@U#U2u{mk#¿m H* ts<3#-*H# PʮoQ0bU܋rՔHg } H*[YE[i|"Q +u!$h9pY%v&_ +Q~ PQEAa=\=u DzN#}ew.G�qRu�/I.X6\n>HEխtGmU5 ]'Zkʼnm*rd <QPmʴNchXw{ȃGlǩk~O)qfu@'\W9@>e^;_C+RĈTY,cJR&%-* 'ulϳHLV BT{/EUyʢ r K=1h*!Ye ^D/I% +kuJ4ZgS"v�LiPKj*!M@Je(R1sY+-Fn0`\WES+" }u^^Oqć w}u +G*�]*>e +-Tj{9UD̸m! 1 Ij8-,WJyq_8%_̘@wJѢkR +X*֮z<*rşb Y"dD݅DJ)"*U脈cŜQH-;ʐvż@~ c_Kyjc1 +^SJRnCM[,&ԥ&0S'cm@nUhHZ5 /cn-86 PUJa 1eX-rx۳t +)H5U|21ą&\fz@&1DS} +4d50zr9; Dg6xdmtH3P #�JTU�,%NWrq �YHfCmX3JJEċUln2H3)W +%n; }dp慜#[Bhi\E'*i$nEW9U"Xr\ye;9@g#$Lo u-D$bbAjHAIIB-�8 >h#TbTX8hQL3./Fr;1pccc<\2 J=!R IScJ=֭FZ=^P6: ɡV"7& !cP*5q{D2iH<AlWa`FH ZB%eH&ԕljnoX(<faֵn/woW7xxvbN:宵i=Aw=n/4k] *#O1"6]G=#M02`h5;o' +]>.oT;_Š)zۙi(b\u&&#*%Ti%Yobc@x pZz4;xe;֔ʄ~`P9wn-]/5Nt<sc7)aCBh[" X ^Uۡ 5tژ ~ +_ϳ v `&C1l�\ǗMH`{5ev0ZANc]On7D .iv@|-hӫ1M0TxbD W?<] +N9$с4�>-`5ާF�aB{k]Ҡ:�?xK16kNdm7e)HPGҳ(Rę�Y9 [RGM4E7Ixj#U2P(^ζn!guk*|B9b="$c58_OY{yΓT^r5Ƌ/ IGR/6{ 1ص`r<QzebVyG_,vR- OI1P0mClӣVKX;d 0Vt[eWrnmZ)D@ɐbL؍ AX6S]u^.ڳPcv>9odجm<Დ:1F=$ޘBocP]rMخsXVK?'$ށFz\\ha:Z+Md/O 1 (-d5?CL?9;`XgySkW~[Xf^8N[Κ::6Xk)F'Zԟ._qrџryQTvt,�Ӹ5R :.(Ks<X)OSa̴y,'^ԟa;:,%6;~+AK >^n>Zgud#Œ?3$mŏ93ṅv4,T̘\2mv +L%ԶLGl +LrON_m>-`~Fʪ$(?Ӝ$TVo?t z8T5%%FN?tW wzE~JbC߇a"q] ;/QBa 8.^r,arƧ~nusիo|41e"fqq EE3ˎX8Tߗ0k)GIsDs:؀$GtrDm+~t3jJkW?9|~=~{;_7vp, ~Zv?9}rwGj>y0ؚBrx'X:TW͛oW}�NNO̫on.>\ݷ߱|͋=|O䇷M7/?yn{zxwa{~~݆/>~a L^%ٶvYmbx؅I;dr$r6?հ_X~`%.9M}c\A +(?j/b<(L݀F?| |Ur}vKO_!:x`țdHo,}UpMt"*|'*NFy@R2dǙRlF$puBCwS,c.Y σ˳6U +HSQBCj SshbjZʴbc冣g)U$ N _j<ȬyF < P,X&BR&xd"| !T(s Wm͚EF`X_n#-x&M0UGPGy=-lR*g,�Gk 8(u84@'c|锜滿/ z{Hy&/@&R;7O <a?>\gOC|Z ⅭOa {| '1=G'(]+!9:텎KRUٍ~A)/4tnuqMgCH/:i.oQn9+73?IQ"2wI'4~/bcOϿ 狯A�b[~E:(r'V18xΟrRx' e:CI>ϲ׷|01S#vuuXEa)\+5z`ǧl<іl'ngڍt?¯!tUŽ!p +E +w@K + orEM7�,2j<|Gv2j:eŤE:E:ZdkO%_7bϞ+ˊ]5F$BU#ض�6BbsǜS\9GKrD=z<ÐzH'z[P*�6p96S}:%I[sIT5QS+6mlTrr r9׸cUM(ZgpMJT 856[K``SJ1jUM:K`;ƺީ5ZKX3X2RYW9-4՘qj#sUB2O)P!ڂEm(2"PCѸfU,"UUO.JB%96гrZǔ3B=Tc w"lR[sIt g%,2nF5sߘe9g~Rw zHvǐz[9)Tui6T j ZZbRTUy%( +yzWy\d9yu1i.Ȯ1Ø.v!K2`k lET/-mIIVj8kȵk͹f,/aM`ZQšuXSF\C5\ۂk9 9k!Ԃ!]- (5 U1rFQSdR،\kk֜kҩkʦɩ\S x2&r-9zXc1fkԄkLG=B9 E5qEQLmبY45ȵ'�T" endstream endobj 254 0 obj <</Filter[/FlateDecode]/Length 930>>stream +HkWnjdl&u&gi\Ԫml!.("PXnh]b&@o +jxS(^RB/;VB}p<~?c`9{\<G� +WK g���1$3��ޘ`��@ok0 ��75~��LB?��y &��Ƽ���zc^Ig���1$3��ޘ`��@ok0 ��75~��LB?��y &��Ƽ���zc^Ig���1$@t,c *Y> -PX-q:GvZ75L[cPÛ, ,Z)/p1JKU*io**خWRQX$R}zn9A՘KLW2RSŗ"ɒ$[].��$3r[ҷv?Ym[?9F~Xf8wcfN_D~ rc=Yv ZeC/~?4~~t@NǓ#׎}eM3w[oM+W+U}u?�|ظ$t)='ffkحWINL]qkEsr7ŹyV%ysm$73K ޤ?QϝԔVVK$XV.^v}+u^eI0$KC Q8i5YrY%w/?^UΌhnpL?%)|_g|sg]rfǏu<9S}1~atpNta9]%z;=Jշ[rIǽؓܚGZO�J�݂b. endstream endobj 255 0 obj <</Filter[/FlateDecode]/Length 996>>stream +HoSe];nuΙ0l8. W\79#ٌnCYMʶLk?"[&{% 5(wgzqhfӽ_ɓ=$O~Pgmt +0UpU.Q_S(9}'OV?svq/F>p$1|Zl,U[s#聃b6R o8uu{ŖJ�żb~ҮB?dYHjw}A_7ڷ3zƼb~RMx=u}m}EYYRļb~VJr=5=pPTV�Ey fqiWnD&ë `d8~\k6d]�6k0MOVrGBrE!~y j�ż3Scg�T=dQu�035][sNûY?���̍y F7 ] 5���sc^uK���Ƽc!} 1�#sֽc�1FȌbypv>W�.>Yf�$4]V,nqT$-?;e#j+Pp%�֛c틩絩M[U�ϙLi;=G{_aY`?"7�H^O __Hj6yT�CsF㪨le}b{wyz§N1fh)g8�`rN,Rcg3jzy_\�gjb!}72T^Z:�B6,jV:[Zd�][E<8Dy(�F@\���  _��<_E% vQ��� ]G@1|:CH<)�m/Q endstream endobj 256 0 obj <</Filter[/FlateDecode]/Length 947>>stream +HoSusVŁ  cHtN| C' %k4)> űvgv-+8YyxWX"~_߯9 �18r!\nsLyى���m"f7it#a>Lz�W^5Z\z�/;wOғ� 'eC9c +9�Pp֮qE=A@=عt:~`G% �n򮻍Igבa땞�նc3uE?v(]қ�߬\Ę9?%N~Dz�@wu')uEf|?�R_֘�e9j?h4L9פ78k}~QSBz +�{?wh|BY�pKiv8�mqŽm$?S<(= �nuMg�ڸ)ur3:9o6qo.��b-Pw$?h7pdgw��ӽG G}F@'1|=i;һ���{E;b&?ZC^/5Mi���EcY}퍓ݫ&?>y5˫��OMvTՔ煗J��{l{MvW|m�0SieWWKOtl!}IM h�3U·O'B[� _NľQ=1j_�H}rS� /1{rGsʽ^y�3[/F.�y۬9N%ꏇ;_+Q5 =�R2l}9[�̎�' endstream endobj 257 0 obj <</Filter[/FlateDecode]/Length 1019>>stream +H[he'IvVCAЫ w [+XqЮՕWdͬ,:,zxsjbA !&:FF'A)X>~{x aWm4d=Mȧ}ԵAu&c=okX ~|qg/-P=�ֳvUctt/:H:�fT;ۢz �kM.?Ljxg)�`5ΟO[fS� /sAOd2aqY>�XRE�G! zͧ_}z��{E.w]eMOv��=թk A@Wcaadkq��� l7?L!|1��t u4vϛNy��t''.mt?7%]/XT��Vy=*Rظܸ{#eݯKރew�JgNl'Y,[ؓzIN�(ݼ`L-�+lB:r%yw$/: Dg/}^;߹+wϝTOX<N^=F@'T;`w �Pf&׺YTo�Rώޚ?\qdj葅̗w@D& �:'.:.W.WWV +�g/T�nDHc]?/~OC�P;>_)�+GJKbt?ʞ!a{�P%fX ]v-�(nLmb1bPfN@{C>Tl56[P:3�t,/u4c3btO#c#Ψ +��%>wA> &w&c��pO endstream endobj 258 0 obj <</Filter[/FlateDecode]/Length 1362>>stream +H}LuAzFXL3WA "YNA] +u +lF*^wt`6ӜhakS\h9 >p>��< +!\ qiuq׌k^fEEᬳNg^5Y׾{s# ��ЄQ^R? +y3Ij �� ήhg{?rYP{_���-!翺a(5=EI��hAG(_~:L T j ��Ƌhi(o*G᭱4mlk#1}ShÆj Fk!9;-@?|*\˸ynXW^KOLƌV{�!Dkk7赢aBD\n˹}*#YQ櫽;�VdD l[8].�B(V<Xv+j];?l?]?/CN\V@+?7.~C=�14-wV]x'}Zvy? #�@g8]m�]g{ȹ{d6h)-NglULN0@#\2]cmIQ̎HO�}"ql j@|]K5kyU%s%6OJۚh\nrnN7鏥e geSG<A޲9s^]�hWk4/;ؒOFNa:]Ŏ6fxg<gG(i}�Ї+Z_�irZ?{UqK{6_VO!Y/F_wrf �WfBaj@>X_jrZ4lK<sTE!gp|4��հCynӟ`P^XLq(`?�� d :!{khŤ1cEzu֞Ɲq߸Re9sb?=!��'|GM9-YvL?#zkՙa= ?RleHV���},/+ez=`׋L#-WqR1R<7v?\��`Z=e"Sh y~'4Ѡp<RQݜ59+* + _fw%UQj>~Z��П`�$Uɤ endstream endobj 259 0 obj <</Filter[/FlateDecode]/Length 1409>>stream +HLuqt&`K&b1q&nį83Y靊?+Z�גV0o_$đV.9"kW>/wsbtdɏ |1jwedo3'Y_.mw_x>౷uɷ9(޺ ^��� $f 5h,iB@x/\muJt/O14W<hIA��@ hkD\"Gyh-=~zнmVޅPUZ}&vsM} +DT?EqJ5�@`hwwMY/ n|{9<iQ_tI[X_�`VZjF�eZ=ׯ{ݟfs? tLB;_;_tX& ѱ X_�g=ic}�?YHyQ['G +m=g#D<{� N_(�<Q;s NmMt ֪5.]4q$ .{U�|".ۡ7"Y�BR2s{\~]˭RݵN>XA>\ Rm ]�|7W}9� UȷCis} L?WCRA]�|g:Q� ɵ#~Wcg? (t*FiwC'eR4#u�|p_ԕ,b}�a|{8u -W+X'JG +mUIG ���!t?B�OR\|h*QGY_��� `QD=&trEJW'JVI,܀>\ R����{E-B6!7]6'݋�wS?4;Cwxf;���J=2?E\>npS)4:nDwh6���&ѧ#dHhP^pH0^>=YM7���J,']_~%v*`=SowoƻAX���_RqUON?O)S? ?L XzX:?d}u�{Ҩd]R2Q>�T 7tA� fɭ1hM폜ײ;�dO#'> +�/xHȩGcB@8 vZkvڇ�Bvkf��{2=쯲2] +d.Ϗѿ;Nϱ��ݎ endstream endobj 260 0 obj <</Filter[/FlateDecode]/Length 2648>>stream +H TT"þ +"BYf{GP-`DI4Xh(ֽFQHjP3 !DC,.IZDzbQ{'3e ?L{f?� Ƥ^h^ �ToNxƄ9IG!]SF� s#,׆zflg*Hms' }$B& ?ol/[H{Ч*N?H؀} ң?s!d캺+yEA<i�AS9^]y:;~\ݎ7J ٣?sX\>BNν[=΅ A:C5"ROzA(Y?xZ?(Me?D?h(?RyzͩVmB{ aoc>9:RHGBNL{hOs?D?Bf~vߵTB +%܇A:boӲٳiA:{4�4רz;bN?|玁}gZ! ."FV@* `ciI{ P-/]3TwBA@1Yw|˶cUC#fhALِYM_ �?-FG@ s3!8W._,,q"vJq{>Meg Llkxj {nGH!|1|L#/I3?'Qܽ5LqBXO^mSyL<BD]AރtCȿuJџ?s1yn Y1G ύZ>N +.>Ż YJ#eÅirsT87>bD_4q9JI|矍)$Ovׄ',?ҞDBR?~-ф #7.ͥV0f{V#}A)_A uAӟ&m ]!ڊO|rI;&, rK;w'  %AL.)7Jؿ cmƝ)c/ |ZdM$=aSA_n»ܞ"$(7߯</l+*9$A Ҿ1s*S|k՗^ ]!j"dvOt= ' �A/GT ~#4n±0bDY>IؽІ:, 5yg+4pj$#3=={oKoNBK!|$}>6�uv +6`^*@+A^=Gm"e.bNUybᚓI'ž9Â<J2{kMwt}ǁ6 .\ң!xB_V1'Xb,I_[(J +[vηJ|g-{Up�Lw& }wco]%p?S|LR:$vS~r,~<ŜC0�<zFGA^BL?>'t-?Y^4=\ٲ]<Ld`[ +iQALY>Qn.&/fkV8 ܸa/ )z I8~Ξ<ßA0z&ĩ+.~%tt!yFg?!E{F7V~JHvWrE{$= +#f]΃^X^`HY=ڑ;Q 0NOxFq1^!YI{{@ Ghjkٛ?s6j +\ݕ +3T v +c@P-qe?pOVrcLS!]ze28Xk8vALq{[MmBA@A?l8Tx}IĈhE_ {vfɝ$\:'rLob0BAw�K»UEEv1,@=|dc[ݙ?s<y~EeH#*fI+rg_>uO1>t%eo_Tn^yKڎ1X{|0~L[z H P[yei%Ϥif@tq=ڑtt!cLACH3ǽq(AL u<:noBA@C?,c~ݙۼ-+J +#eD<#\}wH5烳böF7>|CI"$z!c|L왮=#b"8{Բ�귞ZZ]G/ mPΗןےIp<?yEwsLa0Sa]`B8?UfʈL_[;Σ`Se1JXynQ@{5Ê-+t|rF(x0?{=\M@l@T{͹B4-G(� �K endstream endobj 261 0 obj <</Filter[/FlateDecode]/Length 3140>>stream +H PTǿ@<VOQi4/EE Ĵ*x&DA( !փjQ1jFc!Iu:M:Ӊi:Sޮ(.ʲo_~ߙvpjtӈ,+.לs -]NJ ֯yHc,mI"`czmMK„0LӭHto6@!7!ڿ,@&pxHOs${׊i-09V+щ +ÉPwTb_B8�@;iDZxm]t|wttΉt"C` +MGU8pVAJ%EzܹR(0JСb̐5{pAn_Aol؎Ȣ.\pd"\LB! pQ(OvY`:@E$f`<5P:bm ;o1j>gx5qG;mn +RwEos=E'zrg'!4ڿ GGސҧĠFP.F.ch_U]]g;o\6I9֎ze:POjMzGiHuRwU]a۔g6Dݻ.x7RE'OɅ:!1.Y}o,58@ jnpZfH"7I"'Y# h >jLG&C<h 2+0 KM=< C yS45IO0xƒᴞArӇhBNK]ȥ|.:Uے;JbD6GD*wwk}ߨs?,ŬԣԥxmM�E`O`#@v+v2;nkF\[$"ٳtX%0JO/³,yպo)^2 }~IOz!fr'j(?3> IhMc DE`Ťp'Z#>3 i?žR +�]U@ +dugI/4g`I1|?8\+.tڿ%];yB}a݃%ny~ʫM5+ ֕|CGqɄfgup9.T}Ϗ>Wѓ`3e<I-mPrUUE^r{7*v>\bQZŕE7Å+0JOA۞[.T+(:$IsQȯ^X}1MDԶfk`J8unwhkIiŴ  + qZ,si=u9qH%ENE{wɠ1"/,b=t]iVLHKpY315]ÅgO~0`Nxaw? |K~ $on-U8dpu!q#lQR_CIۺ1{*}<ʼ9 '.6Yءԧ�;*:-ߏ2غ#p9{ikk"X,0JOZw7ZW\3 1f̀i8/6\yQ,0Gno`mk`b岪U88[Zxs[w#"7x%1p?/0J@1)QBkkVG6ǼY]phD#vhHf`PH~.sl�:!*^Ԫ+͙a*}zwGjnQZ 2Nʠ1Xu#ee^q!2k/ \?4?#7Ǭ|GCNRK'/[<%޷cǍ(xs;U֝?YMX#0^BDXcVZU:OE#[WW/~f`P4H^"!@;CBwnc*ۙs0t#D%F,Gگ6\9qRݍa!3O>Ϯ(и6뼑ΗQQO:s-FX8QgwѨtOF%v5&3@ʝ'XeޯyL#.杈?$6d=T*\2o cؽL-4nmƼE=YZPc7 Tǯ?&C^ +LpTw$) +0?W*r./͚c.QjR+2o cص"덥 9sKp*ow8RX3$ȡw50d0}0:EvORNq$R[vo66 !BF*͟_Ac{Ʈ#Guí:sW7c΋ 'O f5Duk!$,+?XeQr~ټBqYQAa,$R(14(e2d(Pj$:\%c9z,έs6" 縯¸�Bc ·6Df8vN=yvGLjyJPHPkC$#/k:t�Vh%*Ķ+òs:yy0{E+fǰ&^A9.eu{$@Z)!Nq\uPtdLZoĸ�4BԼݤ6hb¹sƞS?p@א??~�[;3-H}? 4eȨgɝu2δ8df!?*niz�uXmخ<"ޙ\藹 '4? @0">P-uВ y5(Em]=$h+DV~:y̟>y`� endstream endobj 262 0 obj <</Filter[/FlateDecode]/Length 2572>>stream +H{PTΆ5fԴ4Tg4Sj-(c1%, + +AňhTHpY.{]`DF-Ƙ(Am:Lh4lİ>nf3f2g* B?-N,f"/zR!R#q7 яgEu +U`ԡ97h +².B{zd. e-?m/QACKv'*Dȣyf�B%,5\~Pc;p !ufᬯ*qWl~FIQa#VfWښwu3^m9+uƲ( XS{Db{%U3YUQ'<3<�? P7<T)1rݨqWD=r'v[x+dWX>!,^Ln?RGWe-R<Ƣ)sW>8?ŽxIm.T0pAoq(>޿CރOyh،?hcL<vBSls0MuF8"σ~.q/wUosv+7ȺxТUQ9$Z '-(Sj(Y?I}6MFAHQ8z'r `xL7K-ybovH>~ chl{?dc\<c,FCrg7Fw@RXkyQVDs\? +*Kkv7?/=}i{T}AG- 2uxE6kM ڈq叜t<p]dl<,S:c\KD{״_70ͮ5Em7-[}ЧHuX5OJ t=o{>_U*-:öx?_ +MoG6Zp`o}侠kE4 k3rPr[uϔ +j,mqO -<x)7qheДVw +㨵ڽSE*z1mұvG#̰?4]g61xΨzQwkgq?8}7K ; :!q]g-V1ys8T6 elk4Y2T.5yd6?_ �Xd]A{ǀ?`xB=jus' eM#{ (|֥S uCcݕSz +cEK[!^ ΰ#Yct4j4<ݑ?&I?$[ !cl{l[??µ׈rW16;SaamAǺ?FLtaKw҅beT)e|%)[m{#:\'4q_F!^C^'uH.p.7ntc2  vzLc:KyBJI{*bJI3,C_q3RcZ^CACTFuo;b[ z-8<NjiG vzLc-Fp/a,*~FJ ~t0  �??I9TQ"+:# kP7 wr,c"\ΣSA{tS?Q"}SjP=ÕAÕANA蔨zAhLw^V,~d GTu"i$_!ob_HػgпÙA\ ?j5M|XdD;]W2C0^AƢ?B?`4 +R'r"i6//pl{X luj.1 $?Zאexg}i4<cbvAƢ?Fhʮd%iW ~>3]c -"YDPZMK< ӕgPqUgL0pA1=rR~A{xy_ޣ?Qz{x6G&>\zw?`RbǍ;31^A,Ƥ?߻TzLZ6$UIxxH+{urI +ݻn//~&LW2 'ZRϛ ŘZg)w7IZV([;D? ?!d,?�9:8 endstream endobj 263 0 obj <</Filter[/FlateDecode]/Length 2165>>stream +HTGGWk1lάfvf'?V-u(NRAȯ?�/{_.\T#m+;t4YZ*l֩V&]s?<9s<sνϫ*,Mq=4�e `{b/Uy]K6ʅ?44>s>s26U-qy02n(),|⳽i.sl?K r=0䶯ohO +&#<@ [qӌ@Sz, 2`/WKUzza.A =R;~ȃ.`77]c{7_�M9)G_#42q~ a_][DK8|tI93b,/\$4*Wℛa2~UPJoGq? hF�@:0n ?FCcf^G[YG pQh W鵥Iw;eh{+Nù5%m¥~ 6�2/Jz|ȐwG_#42[9Yvq�EPxq97{o ;&ދǐk5 an$zA䏁PԚsSx w"4]045ןz}�ETdbu45gG7܉M61Tonp O\nlLc@2z?.p'L#?X F pQ(Ez6{VŒŻ?-~?VʆSp? n4dO<NtnV_/܍A#Ѿ-K/~/GQ$?Bh�Œ"ǰwa2LO$,?K+R;<4#ڗp7L#?DOm;|%JcU{qfl@m]9$Lٺ+xk?]^Wu?hdZYCPx>!av<Ǿ'0ZU^ήg0 {`aJA.c2CV+JfDid]5$rPDHj{T@{̢Sǵ(1ѹ? 97m]qi;0#L#?X)_3!+(wBc'-g;{ٔΘ0˙?Xpы!C�J(wY?hdxAMQ_*GQ;ڴwvW(Zi=#BtbX$?zcX]Ⱥ۸9~0+L#?X UZnzBۏxAUk-yO]fE=;Щ?~ xe{?r$!j޻42,JKD?w,WG>nDŇ{49a?BG:D(T%xc^ qi�޻42f,R(guvQ}^dyc?'?بZ�{42`%ZrPkg܀+`?o֬SxO[9b?}HD ?^S�oh',wّ?hd19iW pR#?w OƾY  X#pZ(\5 P/?lì>1np;42`8*_nVN +pR#O7K wATxi ?"͝eG鮘?^bݺ`<.DFv^?oi܁#nQ92{:]{%{ƾFrlӑ&ٞ}9̯rp']42 vˉo?*HQ<揰+_dwANް`|?oGOpXbXW[auvw.D�1l4 endstream endobj 10 0 obj <</Filter/FlateDecode/Length 595>>stream +HUKo`W|G8x.}!T!T9ʫUE3ԩR!3pVW.Sw׭^szIUjV#T_8װZuztx$;yaФ\\ƖHN! +ʅ$XMLz +d%a&gwv +ĒնL~YDy"::ps5ȧpŦIZf̍aݽÏ.BH}&/cʮZ[rUw^Rfp=!BQwuh</z'<BkZҺS#[woQy us=`d`Az6Zq\d!CPq +ߜ#ȫdAnyч(Kق']kn0[#9Stຟm6= F40)(M;DKS('[Ac+؂'‰Qaw8,"yF#釔c]Œ<Kq +A?10j650 %8|`=xò,?#Yi1ME犿��_&w endstream endobj 11 0 obj <</CS/DeviceCMYK/I false/K false/S/Transparency>> endobj 20 0 obj <</BitsPerComponent 8/ColorSpace 24 0 R/Filter[/ASCII85Decode/FlateDecode]/Height 47/Length 614/Width 52>>stream +8;YQV4\im[&;@UR,'5HJKI^t2a/1"-fIdmN;J_sJ-[8)T3=>=J'O6DPZg0#+OZc5L +XCY%]4T=p.]H-2$lT_TB-VnGoRmt_X>@JQAgW(L^Z-D,&0tD&QW(2JNbJdFUQTN$) +g8*mWXr8,^Kd/dA:lVi65YaZ-"F=_DeX?eD7+Mj1,q,8u)MF!DX/a&&]0hh`+i<"B +5M&N$p*`g=J#R2Y#>XD&0_JXeP/f_:=HCPV;N6_^jrPYfRGCNC]H1-7g03`uWoI_V +N""PuN?qPWWFQO3LV]HC\n?Gc.WRFR<J;[;EP"_0/:Ahbfd3"0-85iO;5'&GMKkCp +KX4=u,"OCfmIB5@?a]g6Y0s5L<]lE!m9Vcf5uVddW[W?Oc?<IHmW5ZPg[=.hJ<t_, +[]/sl>pK[#Z!t%qrP?AgfX(GA)FlBg$'DQaqL2CL*h'';PYV1=S<cg9jIq-E]W$]5 +I8@c@2V%HeYM<:;4ZnXLpQfi?k4GeD?.$>b34%`4mc?p93W2#p'*D7jXDfLd<3nOB +YeO#B\:V:nZT%[81CdFP02u4]c2@Q<<FmgdQ^iD(-[F97_)+jTc6D<tL#\[8nc!n= +]/j]PlhnNYHN9mEl$`~> endstream endobj 17 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 47321/Name/X/SMask 264 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkeN s,VfE%dAB)5`k)ZI-.~ *(YBv>|Ξs7e�����������������������������������������������������������������������������������������������������������������������������������������������������������������jnh̺v\vOv:~3.^}��5w^v痏۾nc#|Ϯm[{��9bDUO׷;XZ���=#UTW_aʼ#�� o,=vwΞ}~]ڶixUU��iGݧٹqCw,vm8%.,��8p߳uԿ?{- _Q��|3g<-Yǖ,rucOoʚ1cLb RΞUcbm݀W ?Ӻ<˅n1cҞA*Z][[em3g x~Dz{qMٟynnh4oMރq9glA*O\gxֺd_ϯ9<yke3 9>g\5R/-dm~xYUǎח?o_fs}3 9>g\?`Ha^Xz엇?8vu|vs}3 9>g\?T\9|+sW*<WG-.8Ϝqep9p.笯<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈k&ewΞsֹꉃƂ7G.~Ecf::c{n--3-MCƼiܩ97L\8QS+NKϮirCqz0˦\5!k'gRa&?8flv阚?WU :k��y>͇qiջKϻlǂ{XqqX>ZZ?} ޞOv:G}޲::{?ikw_۷wӶUjJR]7^cs״_W}͚ ?q3_'NMyIHX<�+mձZV[RcKTAn!Ezlgwgvٙݩvg?6OXr,k;9|<yI0fm{W9q<�<qX59|Й:f׈tGL!1D̔Cp"Ƈ"Ol 6k̎|Ny>bfx<cͣEX;3M+spfEFqEb$%$"eOlX$6&%M)"5e/WZVl}cyغM{; ;҂2vm~6eV* N-ZTP]RjegSϭ=>d)0 d\mksGw=}.6=u}z3;qؾevlnuX{p=� p?g7%l{7$;;B‚8KqQpTf{;<:POkz{�.5kVdX2ޛoi⬬q/;Q]s|>PLJLľfY ׏Tt�a_J8JTlyr|sʩni�נg@ fX0N޵P~n-IBCe��5⬬qsPK!!")!Qv � b_?&9ۿv#t]+%._'; +�`�kwTW8k,� ŹC"n~] nY{Kâ#dG�|} .)!Q<p9ϋ!�~UK^gKWs]:k:uh0Ȏ�} fKc}eaAve4]SRy೎?�@.5iAw;kyL�"BL&� ౯Wi㳎ٵ'��W]-*L豵tul��G51SKӃiA' L +7zZ[\PGyGvrZI_Q;/t/;j�2NiZx|;<tXl㓓'  uLnd^/;�(I5F)~4&k1wz̏�^YYr<j%;�(GK~wKS`߶Y{F2�,3WZw:u(=(;�nE46woxr<1# jĕS'k2{Bّ�i? +ofq�(`ݲYce4ʎ�~o^̌*?^/;���H_ey��}7xGV.y���OE*z{y���{3uѣFɎ���BBkO@Qǫq#PX$;�}Y/@0$gL�3:jJd��=͠gڞF*#Tk~UQAL�Ԕe4�jQaBK?lgQW}ML�UYXwϨᲣ�seg?#ZL�b2wTW�|{/{R[.4F?m$ٱ�(lݲ΁�8s|)/sn߰2Iv,�=S0b|(�6&%{Y!n +23@mf}X^,� +33j{?ôtX+ο);�-@L;Nv �IMߪb3Tҿ8-lvٹ���{st\͠@5sOz���`pgjKf?cmYQ{`˲��/gk}DjzNv6��@'uN&2Tӿha"pl���Bh ݌ ?.t5^l\/;��@ [|pFC9*mv'�VL�daQ_?ǎ'"Bf�KǏ,; +�H1<ڳ:NK usI 0S&.eg�{v +thaL]J0 \;]GۗFAv�qy;=챶?6M]Ų<3NӮKr�8%ů6ܴ껗?G6zc]|�SŊ ֻzNv�Qכ.ͣ@Uz<0"(b@h4cLmxi.!aMb4T$(^jDiTTAAew]bYfrk295F:it&N~K7βxჳog=ΙఝU=twsU�}@dFsrW0P�TE+WP=�tw޽LaJ?FQ3T @T��YYkقQGPCz&3%��>MvV|)0F*+)۱-^���FB;2;#__X]q��NǷ{?`dcIqhw{ͪ��0ϩQWؚԝ:��?LOw'ڲL|GDLw OT ��`T(!Ɲf$/F?WY]n9`crr߂T�7!ꪃﵶ0㵪[TsKz5:?R(�pӄϩӷWl?`tmNj;cW|zN�S4~vY�f +oheg4k?Y) U=*�+"N8l"B�n +9»/Xߟѵ3x9eQ@8f`ճ� {I\0#xâiE=U +�Ru#뙐 գ� ?X>}4TWeg=zV� N7II}T�7bcN..>X0#UU?_�W_T+w9�F/ 9e΢H9si;gR=,�OY�pd{f +qi9B։?1k{jf䐡��0A?{Fxw?qǚx5scT ��`񧭑&gݾWaƟyVjj��ly];eFH}wS=/��vzbϞUD Piy5Co��C\u4[\XTi约G2>=]���]Vzhs{ qi|+# +c%fyݼ~=9q>}Īvf2�"Cϖ +Hnq[ <ܔrcXMzv�&=zQ�Mĥ.wa/D`Rk0Ngxכgo~H�ЖaCs?9QU~?r{-!Oϰ`Տ��bsjja٬z�R{ө#_?M3VlW{ra;[g+?Yc[!C}מXcɝQSi=iZ#v{d="�kplntQ�U=ĕ))ϝN+:zi,;ۦz{n1ߡ{_{uٚ?p|R�h]uYIᡝ;T�I?=o+W=R8?'LW|6b_؟%JDŽ O{]Ͽ]6? �߄w^^T�W,ly.ݫoxE:soOZ6M;m~N!Z#ii\Y�rïr?`$6iyKoOȳhλ5_ Gkl]z#MR=�/]ho%>EX4qڔIGcoriLky͸|>��,z{۬$Fqװqۻu-\4-0zB��ko!vV\XVsFW(?f-?폸m+ ZjڜyH��N9Sgw{my.$(HT?\ڼ?k+m?Rg]:{o?pLZ>?(��@'Y=Gل^rkZC_WdrO?00}5e=~ Ӈ\;ٕ^״z /?-��@&|G}W~YKi:#KޮN7>\O,Qﴝw#n[���Rv QgGk?YN0l9YsG<Nhy? ���b$QȽ)t]:#G/y~}Go;~8M[ZjZԑ�$=)%�c_=\B, r?? =)?L^MﭳYV=0߬|_xww7;#'۵omM,M[ A!@�6~_( (Ŋ+ )aMmD0b#UZLd$FDtwÆMMc5VjÿnvgXƙ;71n<�CItQ}f]eo?? 3EWw䡣G;y�SK]ʵE�2߾ChVuބ�G`.׮m}vIo �^]rpkC*> +�ة =:'kuU<ꮅ�{b%Y} A?R|x�OtD;.3Q(�`~{{R.־z/?�,l_,cSH,}]�p@wVZ�`zk6_W(<_֟= RX`b #f&.�8|ud�vf,㺚OۖwB=dfRBz$ y�жChk5~�%M^uILs[=5<Г���͉zo3/ۯ:s {%+K</5[fBi$Wy���kmw^�62K<`lx���zj64>d +XYK>���`=":ݶKU'ꏰLjiΗh>n#���կ{ȂdVs.t T76%1چgܴA\|x_���۩: XKT'y^"Un?!9C!_����+Ndme5;վ@le_{}w�p<͗o]�0pU7GIپZ'>�{b`a�`d4~{y> +� @22o6Jwf] +1gӊA3fuuu+ +�e[8I�%6o{g}p*jiέX{q�xK*+Q>� < JOljκ+G?آ?2Is!Cj׸~�X*V>�0ߴ=ӈ>n:2ۚ{쉭#i" yllx?�p,Sｑ!�:?bDU#F�<[sj뎮iN1�qJ][E2gô=ٞ�x065'%#cy?�p,{Vgy�h2oDi\\|w([Gį][y闧��¾ƒ>� FuaepfֆOMcb,ޏ���ۃwWYѤ~쉭cUզ Y����ljl2OϾr0غ?<'QNsݴ?bCy?�R"/9QPo #Hm}7.n\�O:4#Bs5c`a">ӽ?ҎD~�`NdX21I29Ѓa>5<b_fy)GOG~?[Ah)d^, C*]:"H U$J+ݾ!r+<A)b@t\{9em0.+D?"ŇD:H⹑$n+H2D$I.Ξ��ěCBt',�{£?JgF,Hjذ[KH"%<ە\5<-؇<G?y L1!F'DR4e~FESXZ?E$ϜL#RPOi$=Qs? ҄ ˞gS9sE%ϋVKn\"UnyIc5CY-Oqzoա +U&?ՑʣAjUC.Msg{Q'(tĨ~҄[{r"Y!3E)`QLQxAtoA0C7;7mHE1C&%UJO4tKh mQ "J4Qͦ(Z`9 ) Ƀ x7�>_V8w$ǣ?sT{d'Mc?l7e{G? 2~횏EPa2θ_U`X +Iiƽ3,=:X5灓GRPB3]vYӲ=׸ ! /zwaf<N^rr/eřw8o%ޅĠJ!=DK<QQxxՈqՠXY b<d$&r5f=7[ܔ 8΀t̏v=MLw3>ѭ~ ~^FzRk Ci텺7wlZܛ[n*k}қuGhܙ; 㣝x}F8 " zōw|zL@bKƼ͌G7AVҗU-Pr(c(-6~w �lvGㅃK8C錿Vs@?!�u=X=#‰N$";6;':t`5D-}CTh=\}BD+ !eFqc"o)Q-]Ö~xѸX* p,% a,P|�*Nk'Z8b*"rxjv ϰp8#?TfZHfڵABZVwso;sd!pL7ŴӤ 6KpDYeҗ(=cEǶ?1Q} (?Ih!NaB{<?J,f2.`>.wFmD$` L~hFzr8U*>uo+3RV۳7p)0e߈>V}r_OWi}'y+-맺So + co?4GN8=jW3;HEG }X2,Abc=``&FcyJ(hyhCSzͤ.ԛn=)_dڜ[7[1/48P'B6= }ĸ(e_5D=.RvdTUtGv~HL?*Ql~?,y>boyGac"00� G34D]YHͷv{'$~c;Ǒ"?u'SW7-+ԹJmcTdGyx?T>w5bVh/2?a~1rJޡ'QxӽhOԤ${:p^hN(vM p8LÙiW{N^T hb?rGt3Ν&}X)X 4#40efc f@і9^#OiZd*=GSRL*q-1K!B%2 ?4GN8?ℇ -U{8X;Gi,p<Z[ ,$?f?2v'|R${Tԅ{d*Nƙ6GKGl^~e@?d]#:H`%dk<YM$7CGE: oFS U:xp^pbm,s_2Roap/-Hz9_ # +C>J +-?J#ÒD4 WiHW�P 3:胚hWX{|"?TfZp$3B coxSx +h9ݺ2.`�H A6A5N!v' e=>NR/њ>ǑRg~byv.0*V([:Nho:QxhNMT +P#,>vMOP;7yIͩlie?ojL=FyRzRCe]NJƼs  QPg~ BUd1nWbLI J 4IR{t*/B>]l'@, / ؆dOJuغE+gLٓ?8Q[7W#Ly  qd+f콖~8~-s1)%`JA?< g ?Cx?#WkY|);]l{RE?8A8vuc ؓBtQ` R{yL3d;OT+qbvaIB(v`Ost">#Fw-ckPycl|,#rA:RYC%.3iޜԋ!BL ^TE gO=Y+L)ص??&{t m ??gAnU!ۼ@K`Q[j;zi[Tˇ7|+#p)?B⧺2ղ;!؋}hGMY<ϚL5ǰ'QL%/U\zÑHi?F^2aTY8 loܑVݑ?8{#='SN c/?4 (H>\¾my*+e֬gC9(rU{?zn>l&̢y<DJ/{{g* )kϗj?ݑ?8*w'*2Ӿ(dٽa~�5yq�G녺.BezUd=*WժYϪ'ZE\ڭuڮ:kmB-:;ӝLݾHH$/<3 / 35#GN]5vMނ*YH,̡n C,1p?XLab`$h^2\cfJ,Q '䂬Hn#6 x?o 1g *?~GRݬ<<f +#e?;+xrj@h5%!4A�P.YBs{pܻFl`9Z*WŻb0Έ{>?6<-.V}+1!wiol#{`>y_Y0^`@$-} @#܆;KDw1cifʻb0BI=D +fo^7j!~Ϋ9$G-ўA@?X8>Q#V h#;G ߨ 1V^9'WIo9֟:}&kD- RG&F4dH??2s@<?7C32/Ў`wiqзdaMP+7q<Nq?XkEw?` =oK7׭jꗥA媒 $Ú 2LCC Gs|Cf]gK{E8wZ6{ .q?X` yC FȠ?N !2,r(Vdc?eGpfa"�K�xxK|kc/=wB08Uμw?`LGXz9˴;邏 $\UrW,c=wg+${C`!+)(݃8<bK=1QaKF|Nw3vNNVS2HF&l7F- Rs6anq# p?XԡMJZi"xv&=j�QW#f];. +6wG` +z|iJAY)!);-.H)-ݶ= "FmCa"e�xV,ц֩kLށ82^ dlT+Tk ʈ +9b^*hBq +HBf4-c̙;gZnL"3w1l D=) +0)5y,pjJ>FMߴHN^9bGtz_1!"6#ds?"UnOowv).}=20&7@?5'w?hCS}xw̨A!e2񘷧'+e!'vH@i(c<!oGtoyy%u\joC83h]qp+Cin�(FL 7S]zqLPSuiqϷg3^/|0$]qt:?ڲBYy䂬*nTK?v#&*2x + +x�#FVg\+^>wAҨ&#G0_Oz+#0y\ԩ]WwW`KsWwUEE8s<e=XNaAqf} +p?4cwt&l=s{|,>a:΃q1䚜ck̏|ѐ+v+%Lz^6ﮈ8:!$#{9,>LYL:#@F )aAaAWCTf{ +\~#]$tuzq^;jSW^b~ܿox\s%wc9{yE ƑA4gaw S݇zGm?ޅ96qa�JrhAn{?p\m <&/4#1&Vb<WGp(*VIǼ"Ƞ?҇"^oL k¢%ϙcns4V rUiqX�5<IR~]R ̠W}z}qQgM*+̏G +iqTYYnfzU4BxwF QZl-kLΞz菗3% wmA}v#h04:�_(NkLy'c= #LPSuiq|ʕkoO g[?ޟ:^vwg`s{s˼yaPdׯ7aAZ +a4H%Mc]8n�q 鸞d:<(am/xzGl3j`6Lf<%@Bn(:}bOk繒?X7=]Ż3b0#YћbW)CykIS_ Gz8~D+QԴ֦6j1<RݪF .EtPD" /D*(u&DX?2L4M4==g콻p1?^fKÑA?x0*e H/Nj<1{ѳܸPc[711Oɡ8θ ѫVPwψks]q<�CُtϤWnac5/%̇>_Z6N~D ?h7A?e&�]!%>̞w^[l+XQ{TkX״O 5ψ~QQAiˬFDљׇ{it%5cI6_t$ ?GW;mao~H9~9'`c0r^]aTod};Bzc4ƾJuk: ֻYMYtWc4 }}Ulzd~4H*�?$|-a+s*c E'V-9 0!菑=1ie["kH[qOу'? BmQC4QD\G?$돞gwKc#$z?`8b-Bم#MYߎn0@c27EeWEZkO?w??I{BGA"mAx[dCp^[PQʱ+Xp8=%qGr'oGƊӤ3UO'ְ)G#hG;1E t$O?rGr.4w ')X1vK(4[5Gr'9c&SYx zJ]+&A;?1<[ilaS0rD*o+0c}CB쏕zޠxj.}J9MzǙ18m<(CBU9{'|Hi쏐H_ky&(Rad]^]§d}JwJ3?R@?d!'8Mz #?Q2Zb}CB$@!xݣ<]'x ?iZ!k7L~`K҈k ڎ%oa}GBe'\ԭ}g='uҥx#<%danr?Yf BMgQ_fG҈bm AB?5>L1Ʋ!B"ϽtV3>pd%03GA)y˲Os;w0Rn:t +7%!or1>;ˏ}RTÝ# XPAGRQ<=C[wb0R)cV= 0N4~Q!%"%Dg}J|a +}h7)%?dYGk,:2cBHiasQyzU ַ$M8~s'wB[3toVfÂ"H.;uC!]+Օ-CU0R)]FA۱㭬I1`s<X{Ch-Mt.G8c=b cVD|]:N)T\BTijR >kh f7L^( +ECJʨzNk}.fN)TAK1nV8M A&7n:wT*}nڜuQfS? #Ď?‘8t +oNjCBmS;0R)#8MK/qM Amx yϳ}FsY w[}|h.}C?,(trúg JWHCUJxpM A6@P =Qiyp7m +:_#c#+ف?ڽh g?MUl*H;0R)QwJ8] A4@p폌㍣GY Oi:}BhJ&ә?E#:(g'GdW"tvl,;D)1fs4=ױ+!ȕ8ݰ¤,0c9zJa8 �trCy`{?`4R-Q{Qݮx#J.X +;“ȞGX;PhV#xGe|뉺wHi菀w +Iַ%\~%X(\y)pd%0m'?!o39I +#?h9K Y_XߖWr\gNz7GS?JP?,؁Et>-" ?߶[qnd)T>ox^K1g}_B9~|7G┶=z%<D?‘lNYEHz-?num }Mg<FJ#UEG .5/!YrGꍪygլBs;VasX LN8wp6H!VGw"د31bi8d2Ij6**׊c(!X"\"B%eEd/~7hi<Rx`Gƙ鑚JX`gyN3 3ϻχN_;�]pdW+-AߘWí?{SNp#T~M|kru G�HP$Hmk)d3J#+ 1QI)s 8< [!a}Ł?ho R59|Yy zSc?E{V W?+@8F?z)]ptgs\gİ4k +ˡ)5fXK xv#tm#_7bm Ew>}Uo7aų?(Ye6tD$CR曾e{gVV_^J?+ԣ?^:@2b~9R?Cߙ[<ca}׀RBb(;7a7:j /?J=vvEC Rixk˱47!з&=c>K M5eF7@4e BNtPb#m ?JG7!-Eхi B4J1+H`y"[g_7fArXa.џ7e}`:ujh'kH crϼc͆mURiVRJE/JAߛpz9(`oo /G=Cy7hva}S@j!xU&Xr)C4J*-Y9M71xwjD8tЯP A=c2q!X婑)C4JD_n8n-İncMRݗ5BQ9wG"bH=hЖcw 2OϪ5nP}sbXwýTXr<X}$PImV?G!f}GV +Ri䏗H`sd͉aO'{WTiQB=DdzϿ?%V?E?F̆)^8<c(]}wbK&eG޿6ƛC=wIa Icf/?X;Is覢?μk5 BN4Q?Ca~}wbG:[ݒ]Zw &EGc kc_.GFiN* 'OX@ߝRVqJ.} C0RMEC+Sl艞\C?pxfةt+aÃRox'uȼS"Ʋ!H&#n?/?Ǔrl~ϡw]8<1)l!68aݤzxMw2LE?4vdG5 eY1k~WkÕ.WF`3-Aߟ V,=q^"lvy+?I(c)CV zj<phQ?fƭ&kS9);.-ciwm_)1raAp ?NjӝGwK׌8=3OTRJU ^A1Ɓ?ܺ!Vsg:X=̾xa3_ _O vp?B^lHIoC4Jq߻}b1RAýk^+LJoghލSJ? vcC+?ſ0j! +q1bfIri1AКtrŔc^CG_*ZhC3Ui_V|\?ES4 ==Y߇C?8%f riV`n› fc +JcPL_S n,HvkgjOGasa?6m! IѻC )KH`3z!B4JPRm6\Yq;Sf]-8z)u{iu[k=z"ȕ:fDk={_Z~"Ot⍙~}RJoQLy⏵GV`<|q!sI] nD;}D +<j5bΏ?J= i~o8 +zB4̸դQ0uvCߢֲOҊRK7gOA P?;Soq AJ-;_eE:{SV<=Jט Cծл쌅iծu: rshr?l8?c5ASJ$] Ӡ?lDc{_BߣgXgOA3{aO&F; GArF?RǤ~5z,Kpe8< ֘ w_a8|rŔXw-Ҭ4|1ԘLWMGArDS$8?dqLH:y PTT1d:ƤJF3Xٸ F/Av9uYVFj2rngiNjL_ X_03|_6뷭+(RבiڻL3q SLnwRh:s-K iﰔSf<v+YZP_A]CC=` 1?Gr̼]N{ix@K rjcc<~1z* ܍KfwRh X(UmYa)Q8Zfj=#fR,?$\K<D>i00R'>)Sƥˆعs|^-8?z}`a1}/GN({ `C~vr!tl(nd1­?N +?_t?<叒sh.R#yiiӉ-۷?s{#t2 gѾB#ᔁ0J9oRj"fԂ EًCGA#Rw `7oӧ 'w!˩4U:ucnROo螪(;1\戀cĞ'[)t7韠mѸ0;F7iDZī +[ae\\L?0qr&+.R< {kxm2#Ɲ޲І):}Ԋ"I}ғ?=#D<?6L4fx[ae̘?0j&/ҾBOjX`?[E}oYhpN伲Fb~!_'oE#fGþAg]W>M>iT8c\ Uok[-?znCf +ݴ類c_+6rpG9b䋧)Q+Q5c]? dʌw;+0wf$&&v{ϣ*䉣n..v-Gύ DFԥJ3)$XGoE{_Y*ޘ6S6T24uqbi xA +Ar˕<4v'}RGSF|iO<qO +MLWJ~N_双SrUa[:,D{t)#w㍴塚|cL?=r]e)EFdP+ڄQMBcm]LGnhXRA% :^ Rh*;?`8G Z_>3^3]Xo}ZSC#nm}Gxyww]e)^!$F +Ԃ?Io-#:AG?1XW aJ= #q>fg&kS_xQs%gr4׽0}O{RqQr zljy(Rf$68] xq'B$8s?=b)NKu7Vms#J}OȨ]i(EҷV!A6m8�`S_# [hHqʹZ9\栜R@ +3"X>ϓۉZ`AH}x$KLsJ1wʌw`]_,cb{>޻ x<?NV�Hϖ!d~J5wcxREy=*$XGUS5W̝,׭m@4H]8ۅ'փ?51P3*xړTi]Je![hW!yŢ?r5עii%EҔUƚN4c?�Tx#dѫ8?]{)0r&-D5uOS}*$X|;c!K[:.*[c`4tIAR(A?玭5h%|K)Ӏ??X}>JwVH>e?OpWx& GQk<LZ{jN]CgExt|PCQ�;)0r<" !g鯗 hY!0^`M9%j}CRG@mw(TLǪ/moXQ�0鏿:y(\%|GӀ?Wbɔ2u/i[!y X,1Rz.u ]C5G|J! +[l~#`'B$cRav"]d!ѿоBIeA~_g]C+s$"CZcVj ]DJ+2v:ŕ.FN_sPzW}l3{+$XNJ۷uŽ"H޿zw ғ?„,Ig/k"P^+(X!qO?n[fUڻB9 c�caϒ3[zwWXGtC%ʩ=_U^n DiܼzGPhv?V -?zuvX:FN#7ŚJӾBǒ?)L{tS<S,_AU]w�Ǐƨ44tؤI3ZqA#SmAEb!bT{{ * bP@Aә;FOyH4V{f31C߽SOD2 LCLfey&=R Ҁ?,kkfJN.+$wwûI{XH#y{GP=Cm? W?d5p[U?)aizbTm)}BN*7+&ĝnw<O0?P D,?$\N"Q'0, hxi{c@TZQYsޱkj?k?H-I$%fc:C(qCwR Ҁ?,wPT@T>P;SP~0y@H89}yR;aiֵ?t0 MXHI߱'c<Pt6?8:Kq!wN?`Xu;<OPѾc!i&/f +;boIx3P?i?' sb6sR Ҁ?HZQowؗ- I/)cO{uP{>\g2^QtoH?  ǰc.BL8VyI5 K>w:g}ڷ,$2C[L�ڻr[|L&tNѱg{ bS㏎?kR Ҁ?o3,]H[h߲?\1^=b#|NDMk,sR&yp0$È^Tm0{v!xlC|Cdp?քfi*I5 KM'Wq۫0}BJXGwĔg,~ZX㈅+,4Lf g^{?BJ!l",jdpjd{&0, 6<i/\}BJlXۓZ+61 |seRBm}3s eѠA!"8>9W|2׶$=ravSӾi!$v!Kq!i-G4RA5ٹߨЗF(@J"Ti{5)δK?`X횰})*t=UUоi!$fbKy~ɡ15Y8DtpgRp?(!7O*ym7>/ai-p/EyeӾk!i4 Xi?<1')<g򼕯`AR <gRZx;W.Hh ?`XmUq[ ZH ?V ;{/i[;S-9Ds{;j?4?1) I?m9Ήiִ/Ba3bW0}Boa=51/#N)y+j;a{N?L5lbw)M+K3i+?`X[?<S;o[H1^R7gMSr+fCǀATVc cƚ9/;Hw0, >-d0}BN8g}SM{것?BJ/#dD1Wş>^R'4<<u9DĝX߬?k;nC}y_s;//y92Q.jxs0 kX]q0, >wF9ei-$Ժ3wIUɍL?pm<y7t/2L?(R ]b) K_i"$7.$󺛁ʄHmU%~P宇 +Fm}3yek1AǕMxSx sGaik9HSkH[h߸x?>xy/Grl~ƗWvc ߺp[ GZA<<64PSSK0, þTI?оs!q&F|ۚ]鮽e.c乗 ] ?L?HH}^m0Տ?k??uxOD{X Ҁ?۸yP:BA#;g"DzMh;gmmP*ԺVqnT 1РA"43d?pMZ +ݣ?,aiosFܔ*p{%{hߺ?ϗ`ulڻ#5)Εv>"zZR^CR,qa5B5h?`XE+*Ӷ%\*i}BKlxy',J2ȹʼn/P wQ"C2|,aAv]Pk[_ O}wX Ҁ?$JNOn;.$揠f}9qG}oy98c'4 s 0jwj9ݍmY0, cxzm"tvk.}BJlH:ߔVy@Q>[ٲ^g7Axg[!]R|N'4+4Ee +i߼x?]Y>@Ѯ +UmvǀAb~�EuF/BMGG$mĻzIY^DEQGC@9Xn Pك=XH $E՚ԉ:It +K{} 揎bA:-r,1?CQ˛Y/|çA v&fW;/Ɲ{A? 6#Ey$Z#ehstc^?ƛ?-Tn78|qۯw.Q,gO^q^wVh/+<2ER]G(qw5EWuQ2]$3Y�GBΩ'"8|q{ροl1ދq#.腂Y +{uzZl1n[\;TGR?t#ѯ;F1yX?(jك!Ӡ?_:yK~R}1G=PpZ/#Xg'Khf $f+wDGϡ?`9uwD(?p4Vlu)z3?-rN? #XgyC.ᏬGA^ iZqi3|qp= ?žWӠ?` +IWɿ3Cжojc?~`Y{/!ZNջDGw&X1+nT:J>A*|B +R·A!Ӡ?`ތ2?z-ˢ i|軁u/C,ĬD:a0\+fڲZN]?9}9n}7O+"/#BVh3&?4y($N~esD{ٸea9.Nսԛ=ƖIiDnz(Z> aҡw`LX0YtX\'\ Nt/w? x`FЭBh?p4b +Oed( cZRρ >X&>˧<47? 'CMcv%^yB }'OmYw|/zƄ#-9|Y9}zNQU^Y_G_?&3{u8[}OMiCR +eIz=?䅊Tn�e[Չsg!X ??TFg{ >1s}>ޅ1C0[.`=.~8y qė\?,]9f%]j> > IzJRޅ1πI&χ>׿3Wh?WM;F6?㗪Adg +.5VK0&,])(A/j0!?g{Üj;*}bZѸ}nOXw4r> Yx}HҊ ZM=> T[�wAdϚR*Tr^~3X9ق0qTYpHi~&H\%1n};I_~8c7ܓN+L '59udD3H#8YA;DQުTga:<mBJua<bXQ4o;~>' +G�Dĝij(Vެ2 A?l yR'ͧ'/8\ӟI ]V?L+ݖyA ^k5Kӿ\r33NٟBn˧JN ~xbs?p=W:Uƌ$KiCNʊRU bލ1~#LI>=ڐc*ÖWKr{ cΐۆүÉu} n^ը6}1ۘ8|h $gy0npwCpuN.gki&!Ʌ2Ua<cXzڻc3x?ÖԔl>>X{c ss꘩ Zi翇0w 3y85|y Y_vgv^s?s7YQ>C:3Q+uĸ-D?MiC R51x@ȘIÉCW( +M :ݴ5_,õO{I4&՞&.Ö+2NeY:CzZZ+id:8.\D;=L*9~MUᏓsM<+&EXg;2/,c/zc9\/|a9 {[Šk-:FlkQ`Y9rt꺓= ålƞVj.u^ _ %�}߰yڐ,yza<d̤ab[7fj5;K9ƳMV}[ޏ R-?KwC]`A+%df9^i. U_Hz_AQg�,hDM6PTTԦ#`@*PE5 ʱ {_,ܢ5"" +*iߋc]`ߏq^,òsaKgӻd?ץsd t\u{_>E\ɹѻȵl ˕~&7zr+IBϾ~a}/M. VƸ ܄Eл IsyO!4룣CgՊ%qG%<izÕaQ&RϠ?,%G3~ҚVƸ HiqNWlDZO87zWŐ9Gǡ^8|7Ef~/c{uR(Oxc+S)\Ikї?F#p $QNk?p4n(6{+q³qyY; (?Q(DGL5?BkCiI)507?-(:">gleGΪ?WCHHǙ$}çAp>6}sSfƸu?=c�z7Wwo/A -f Xߡ?p4nN-raow3=7Vtk>N໌ >z*eexNVzw= X&"3ґI D]çApǶZy|C nƸ珌0ͩ{ ]y\n%sIMuRiUi =m-X?EOoc8|Jn03oH;4zkɐwհG4q6Ey< qI>#C5q çApOü=.~;coL \n[wى鏞ju%-"qyN <5ݛyG7YA0fX> E"zi+l~?cG |i%bCDn\a?|7/}1<ؾ+ f.!iлOfsB<jEW@WygXz%Xzw/Xqseu!Dl?b KZ? 'Ʋ~! çAp#4}9C19_0zo]8o*3GI�+p!#ʴ{OnӃVR^HCyl<!P+:/[l蛰ÙWt^pK1lOՊjy;?3.I/+1w4frB/΁WteҦ;}I@＿exkG"BU}R+bƇӠ?]IFrY?je{r?Wt&̯4&bGHg]q٪]q}M ^S4fҰNjղ&zo@+f|> *4.w9,^]Ls =g )C[d|k[rQmJqijG2B4N_C*68|}>Q1WҘ#vMwboRZ}2$"73*]lb:z_@*68|?x2zY{,$Wb2w3}q옆}wizg'"|Gu='wx> dϧTn0&75f`^jEǶw3}>~YP '-㧦|6!ϫBcy2zO@(68|Z0@1zKwb>CVuA#jzHw8{'V%Bilj$HEf~Wc8\_Zɮ݀O<zU菁#jd|Qe:IǴʙoC1!Y8|ZcCu X~:z/1uDrBAp<7w#]еK2?珇av "YC%68|<ʓ2{[g#D̗gj$z DG*[ +{=Imi\3KLwMBr?׆C3KfIl> >Ak?6>{~gNbkJs`e= ћ; ǫGhΔșj?.xR#NbCOg-ZYr`q6[/)E媕M:WA#XcFqlcMGBjPef]Ć.Ϧ %jy*5⏵:,z1_:j?^)5G*ka*4=AԅHv,n`]44x.[;\#k�.bCOo{¥% 7C?+vCsNB )Q=ێ2HRTdb41FHD@GN"h**`9\,r^ +T94j͌m3ڷ<NDXg?vyϽ[>SAχLefN&7.f3C1/>LYD*5̵76bYibYM;x36؃ԨU7=ǓTY#~Tz瞦<|xb{˴:u=D OA7EɳkYݵzg#3,Cqt8E"_Y KM'DHG4.LM%0qnIہI oF- +ESimF,ݯY\Q +?Ҵkl[)qdNjR;/>uƠvӼŞT?"4zC1?>l:;$[zX^zn~#Aϟ@Ajm?Rȧ?Grxeh6!J9v?gUߠgL>W?{ЀS?]+)TxqV轍 D0^w=JvɳkracQ:[G5e6n๽pO0^d xOçeivKk1F?kfV&D'Ks-7H^ ÌagYx̝}3}u␾(}-*z悴,Id]f[w?0| +p R:}@ondh6ײ;~y3E~›_TISO$/#/�C!yӴ/ ;/2;+10iV4shU6PRKWUfgyg@ALV[߈Y1sb2|çw?''YŭWk7724Wy;�o<c{wKi�䫦h]oG}fNVȫ:R59oJ ^&*Jy7OƜ5ᣗJD/Qy7vc`aY~pIn5EBnwXꘆQ.]C=Щտo]w#2QS,ӹK~p TDdFZ*eivQB=};bd7zJym_HZTWWT* 1IYϟA)QAt:Jm#F%Ub?!փX}Ŀ!i'öV/{g. $v$w-mBJ$*qþbMnH6?GuGLnçMc'31,縠s͎rb=lF#�yX?Z}o@)c 9RQ-R\[?vlИXEc0.ؓTUǡ?T3 ]9b(e}12`a7;ݬ[?LN�-h/Zae1a`ytwb9?0| +pkrC*L + Bs1;ztccN3퇔h?? [>+IJ`2%|91? 9#*:EBڋjѥ önˇ&WeA)&κ;\?dFUD#'z rs G:Vy;(et˃S?}'D^hm⸭[\ ?s\0}}X/QiOt!O`*{OA)ȚѴ[ޑŅ`#*:{w ^h?jԪ&׎=:=K >*Dž`CfThe{;X?¸&qöC56]t]at8?0| +Bg#eHAw~|h_rÆe5c7wç VJ58.z GxyUt8X?c=HZI3mi6!̍&k-tX?0| + !Hz ̨jIb}ۘpIaq_R\3twX?0| +$h>�. +J;+7#G{G +?6 ?Vy[^нAA)ȓJ*FQq۠DLAv}Q+;\rjxQ@x뱴}.7<>9RA;tz GQْ͏ b{ v_Nl lf �=grH OA@zZXq! ?Vrܮϊt +b{xwGFXTIH)I%tWç 1mJrB\O>zGD{*:- +b{8I«?jYmj + OA@cLH�܀(Z=33ή8'0NrI‘;u=QK�V)؝ڪݝlId)/ow~_tnό?ۈ\t l|؃o?&?f<=WM>(A () ބKVHZINaNW,m:]<;˓f1#eWElȣZD1(bXF"/9`?P9V~ +[A<V׋+lc<uS`LJ['EGg<? O(l?fK ޻L} @ps!8gSI*7A0ěvdVG,6'Yt^ l|J ob面 [p\[]Di:N`cx̝]P})-a +u&? 3]6뎊w <iS&d?@�[iw?d1m礚K32v0qAAL:Ul8sˏr<I|vzް?R{/wtRD[79} d__|ޕ~ܐ9@(zqNuo]%k+ܡ$oxL%!9O(E<sa?*EZLG<S?V`ES_\\@( +|もώ-&.|8sY燩Ttv{\ئY )3 aGE;WЄvf\ Oku3~w~e: +kYEy"!i'y<:?<iˡz뙮s#rG;E<uf<Sp{q&XX>d:Ɏu| +N ^C?[A<ㅳ猘k`he-LJ|M!<wVv")4%9^[@)>ԢvPDMC횬GsיYI +W-XK&8qLeMhJůNPQK\L_ LE5g w˘`gs&^js4*|`NtnV7[)2C7(!^6B h[g3}sܱ۶;ScZe5x㈹'|{Ե !lij;-hxiH/~>aę0g~eiP\ox?pVJSӄⵇEٿoiئğ||lYk4o!qhe?ho\𪴅K#oʃ"j2$7>*Ġ7;N 1>K]Iӵ=`t)𜆔uc?By_ ߍ~ާL¸&:  +E]Q?Ǽ##wtU ^}|b'?$ZX+;-YVdWm +*g%`gj>tSdZD?{N󣜍6D;KF*+zk!aG7{bw[8s5z#B}uOz7^cn{P!a;@"x^&$\F鮓\Y jckm\p )27U=9NʫtPDߌږp`25D؈acB)6̉~K9۪{UⓣvF mn. +n �hqmSK[l0o_{ۑL1l@UYH=}G?P5g\ȡ̓ć;Utڹkt,JZS𪴅{z6dvO<Op2^O&:V5U]q%0Ǫ mTᇻQ8xp ~/Coxo:)wr ~[o~0"eȫ"{6e^'E |DךvS`L)R .2C/ˎA5`bW~@#{c#l (ӦLJSSwFR' s5iZx]oB+y,`l&Uc<r66 RpL@_cokiLGf 0|uŴ0{6~SYʔ)aЧR+mt1T7M]⵰On9epe%> C&ub?^j'32C/.wӝe?&?]Anc7a{ @aOXTb +ajEWHZY|" (zH9}Wh-eizH#k|h5|O;]*E|x J515&? 3]"c؊?ʦjX[&|[|m?&?$wiT/(3X UD6z4ژck*3xЪ!DPyYy ݙ "GQ 5FEIGOOӞ$LC׬+ ;߁{;ݽĝkA?Mݳ|:/ լUʑ[lcN +\IdCMwGXYQIyFǗUٹ~a6hhDa7qHw.nR2{j(o%TW=n%<$oBM +YR~0{0ޢۆ*51k;4h +Myˣ'7tvp#wO/{~Ce|iOt{�g7< )Q먙xfElϋ%v.F3՜^][ǾU,o>}vRE߾<ǫC3;Ql/9&X/?H)?t鼢{<pd;rcݫ; $ЖΏjy ^1%?gSrNcRjw\(E:U8wcv }\BٜWôkzk+ +tKqq<)z+ (hTta d ABL1P=/v[lL?spaZ+xt&/.qxZL?#3߄khЭxu^CVQHJMݳef%*0(a|(} qdq;_XBR }(,5Ϙ]Î0OXpm k(Z)55ѕxc |7Rp`єgƗS8eC>Cq` !(XtpP<)M{xqtO +ݚ+�LqT_Bk% }/(|n8VtWcm[scރkxCNdmR m~F.1ZtѸM-HRUrb{X. x5&$ɩN ?+w]o-tϪi-`w0xfT?rRvĝWCb3XU6b6Mkqd}>_VY*SPҔLIjf<X!<>_u/̊g:GG 0 *d:[l4mwb +|IZZW B ?!ɸrIl͍y_1O7\tv 1@ap0]n}y x-#Awբ&;I|ӲtSk?GQUNP7$$?ښcne}ǝG'z~Ol8t-C#A< ! A01՜ZA8ƷdL#B]~/*U+^Wzqm*t/ކ;qA\XBW6P Hp +BpK?+J;au*M r{?Bʿw 19qz e釱Ugp_3ϡv!XTtKek4j|q>sOq[lp >S C]["X-AzWk T` Xi=<SVH5\]=Է ~ b +K1;R<{fE{Y8V%kjmլ:ױI>#lm.qRtE: *ky ` \uC73y' ~f[֟s&xw$=T#)Lw 1GpIҡƞRNhEkjmUucQXqx7x%ūQKZ=wu l5#5іrp{�NX%;Ort[pIB9'L )MYTdfQaVOc30PԿ +uU8p ^SX:Q<*dzҟ�[JZv=3egMٵ?b.WWɸesN Vl~rkjEg0?90|:5FA !DX:GGj+-:ӣ} ֿɯcv7A8X%՜Ahy ]V4bZ33KCF7&>u\qvΛT=|2A !DcAH;lݑ*P} _ȗug(qn_B } acd +E~EyMg!MSn̊cKm۷ ~=FSR2mAb5lPK$Jw.qxof=(q_ᡏOt|\s߫Э\5͟SZc7岀sR5R[4~cѓ`]3etR@7L2x�ƸeLP1[f+MY*BqhPō*\55303g{zfPd].^(([o+lH4�MͼW;~oިƣ zn RUx `3^ѝ`#_RʻyՔ xLwL =&䍩E:Z:8?W*3?ZǕP0x#zaf}GMT~ǦBS9{o@lmn,aۍEgl~U$υz ߯,\ !v3La;y�9c) [ʨsa}B>` 7>ia^eQgQXSl.\8ZZ1MJ*-p"*KE>5kAdJ?.fabr\6M_k <{`-5[m!:9;NSVDP|%6@L,0ꠍaM>wXX) )n0 R&?JmOSߩn9 {.TfxYVqpE'n9OOj3t)ض&>8q`f0آ2,H_>,ƀ?}dr_a\mӟnXԲ-c[Z`Բm*a |l  cuS09+c>6@lSI>jJ~UXZ +]£+|uCgGRt+f`^O aaM$o;;_sgxWts{>+eA8A<PEFcG!Qk8bF ~{,2>ȇU}xX&:&MN[|sc>6;Y8C~q3͒ͣs8 +cn:区@86꬝O#f=ojM"mmE˿t_jN;q> J}V9Ɉ/NoUn׶"Ιaz?G?pq2SC-?,>0⻛^[Fꤌ/KBS恿,{a1C*sƁ8͢BsSӲ7Aq< }.9Kd}䦒9O3>0f8/CTYZqCgmaZM\ iP|Ys DQCs bp+ȸ} ǵCoaa=|ˆi_bw o/!.P?wU%^`0JeW/~7 )„q9GrqH{+ +IE<c} AM {~R2t#fyq5T ޟdQ/b8  ?8Xr\c 8=񇳶amkƖ&QĨҀE)r89ϛ(!P g:ifRkgн<SCg Y% sHr8qvYޒzO?pq2蒜Qcީ!8]_UB&R{ <b�eui- +bq&ۙddP^lkeE>RP  M{˽p;BD`:t?lboeK~ްU'z̦XPs !UЬ2WR?{ +.Tf"28];h]]q죊jsqw~yIo_@:C]|Y'x@}|侟9yd2HʵY8nNR )ټam4Z[1:)P9m~`*Ž_Aw ՜|YeRN$4g̥šnaŕL9&Z%{"OiJV;(tB'ziT>߻jw8n6;:/~&Y'9zix0|pMoV<U0 ?HJ5/fImek(75셾ɺpa?]K[o-5'LdC;3jMNx2|z$"OxQ5roaŕL䏹q~F7er_G�#pnȯ,n{]gC!Ok3| )}wVNSEKeusMQI q<`ngh/󇹌u[|kqe +&>Ȋ.N/Jk60퀭}'q Q*C9d v?/5tjߜ`xiW̨270|7愩6c?͢"F&9*TlʉxoW}kW*3?@2]\Xi/0ݝB�Sm9474GJ -x'ܵ^{,uyςzeiO<F!|댅+ +nZ:.M){ 'm:JYOvwR3d)g;rZ'caMiua_]2 PTډSMj'4S+|&>KTJV*A<vݽ`Dc"DckL:t&8sNt@Qs7ƻ{wpA"' b3=yĺR?�O(57MhЧ/Ė Y ddhBQ״Xgp[)"|/H>/M*C(IN酫̙qb]_E�<c̶o3 +axO#iZ,|@X'霅kTY6\KP#s䜘SΣBs?�O8swDtgB,/(cZH? k +awK:ZJ )뛊HC\24R͒Ya]STvr9fH:!Εģn.Qp8y-!)9+VE ?҉Yhֿc%ZBؑ'?#836ȽD>\j{WCX犮-[,fjfؐkaOK<ǨUդ?D,W*T9úv& (Έ t&r,oT.KfjDA[/E +*EϏ&uzt$=#qx= ёsep& _xA۾c%)6M+G(2/r;i[r/mf^3& h +B GiF*:֙]ZUk%]=nk!+ p+뛬>1dbG FIϏHÑ@z]tDO ~ceRݻ]meI_]z`r6-7!7H~Id'DJb3=?9ºFvUБn5 Lf˥?f?®VYZ9u] T~Q\\xmQzLj.>'?;*|IjF]s7jV]0jz@45t>:Eƭ\kHS=0# ȃ()u[Y^[cŗHb3~BI"ZJ )뛊^I%MH8z.DH9>'? /;ߕI2n,onBAeJļ*U:ɦC}H6x&c?.f1|`]D7gmk5 $pεݹc,.i!bfOg*]:'9FlDB^aI¥.W|PK awxE$Ś+.2b+5ko_ɜ'O9ּsDp~hNb:t^&i:? u/m${q"^[vD +O+sB]"�@<;n*Iڒe?0U%9JsSI~ )C4;BhҹN�:G b-,-~SOyl$$2mLړm6,jw:t_ݾlʎfXi7O<gAsW2c+56_".$.7[B^NLv"Q{[VW343!2|כk6ŶLS77w'E�<ў?MaZ,h)-X]03c5٬ !9֕K!-= B{(k +Du9f$6vta.ݎ+uABzOC�О?�����5g�����e 3����} ����@x ����lp_<~����P6@?����(�O���� k@s4ڪ kѣ|g�����5Dh?Ib5'+{o /V/ |sg�����P")J ⵧzK)ێ녋=~vVϛz ;g;ϸ%/nNG9#{_ܼ"Qs΃j5{`{<>+\}ْ1nɰ!"Vt-Ć>t9g=v=v?�$h=o4sSz<`3`4]]WZ3ߛ7c&M_L3~y3;g;@IL~uc7`ˋÆ=# ``=e8rhKNSwMJ[?B{򫔖5@1>C1|}4z_6�z!!k,rm{P.ό;곦)/<7jg!Bl �P& G?u﷯kˋÆw2ȄWGzB!BIiFm�(kNVv^{n=de$K.���z*8~@E]XQѴ%V.H@,*u)+0000T@ lwi굚.<g;g ޯ9<|g<_�ٗM{Ϩo?}(h^mmM;����+$k&bj~PNNQ.�������������p'^*Ti6<챚^ܹY[1v0Ŝ)&My}K_5[~:c@s煆I&͵n驘-*\7qxgwlATqzA~gW]iq!sxtZ>Sj\)gb|\Sufkd^>v[CQҭol{g55KI"ޘEo%cK[4_]:z8)Y%~k` <UY:{,՚cb}61Hg{}[TҪY]rNQٙ 2w% +&}J?ŹՆG߬D)Ĭ$ձ7Nw[Ӷyd^D='GԜ|&}R8O?c5l,;z14ʩs%l_1ƊE;mL)3E0<*4)# |?*ϟ׹gb\?ó%3k +j6,{2v/K[,U9яv }1ћYn]Z1tc׆oG+JOg㼽? ~4>o?o^g?nhm^q9b$k+vOx|힌Gܒ؏͚-b}w<3*m5=y+P?DD[tW3؏Jo8W2XJ?gp]yUbt 3i3g2v>^^R<MG>G'#cP(8%>+#79<wlK܉nkӿĿ=VkmCKzKUep=NNQ.x煉SEm;<D;dMAs`8WGTLWč"UQϊDy]X)5\.ٖsָ5ҙ .Es9dQTQf?65X׎KvE]DROŜ)b qZx?Bänk?oV= *=+;'||GAYi²?D"e "9m$MtqOKzKUepe_NNQ.x煉5SE8v;;{L'cd\˼SW[*>{М/XnhhQy?7Ƌ{WEE;<+-N49Z/7X/g2Xb^q^g_k \QF`Gp`2~*3ڢu]cUZuu5"!o|G);9E%(g5}=^J5%XsYI+#79j϶k]P>Sq~^xy{1Ɣͯo ❘61Ea$ []ɥ-톆ۖTR{zJ5Ug1C4o6/[ܓf2Fiʩs||$W_:yOJ׀'몿çRjz.>1qnkyɿ{}m퍋 mGs!f2?;9EB W/U6ՠsx + +pSyxH-75"S//eG@iuW^سmZ)b,eISi6<UJLR%~ +;E~<G^N1]iqx~%q**եarz?|8PM9Dt8ooeIR=h^[~hx8|Μ^ r5]ٝudِ%$ Gxw6,6ݓz]$|!z?ganngVWՉTk5UdeM8z<9g]71x{=:͆Gw~fm. GSB&O7?,\׵nXEk\X9BMW\{%f+^'sK~|edt@ޫwߔ}vzZ +.Ug"=~,g~X/ƒ9%c���������������������������������������������������������������������������������������������!���a��������������������������������������������������������������!�v endstream endobj 18 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 48965/Name/X/SMask 265 0 R/Subtype/Image/Type/XObject/Width 800>>stream +HkebڬLfZLFÂĔ 32.TvYM料T~ ;:I;"]^Ayy?Y�����������������������������������������������������������������������������������������������������������������������������������������������������������������{W?}ѕ5��=ܚ8}dW}Fv>��쫁Clݲ{��b[mjh,<;��ٺe}==G +w_O Wkʽ=�� z1/] w_~չ��Prk&M.��` ;=cvVx8ߺquu٪%KmYGK1cIlA*vX?7 {X[XY.7c1 RB.1gwΝWoyoksGK <C{v\=glq9iy_{xط~չ _quy<ۡ(w9sƕbY_#UzB6~kSWTl|ƧWkr>W3 D00?ĸ/?54p=G׭|ysƕ9+J+qep9A%2g\s|θ2\9kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"/<s9s797Sg,h6ڇ^Zr즙ͼ3fdsq=Ljb\7iӋ3㯼g454gZ}CqNϮ48WO]RSSr}muuveg^V|ǎՍ5*][{=��/D__M;-jȬ|ka=ZgoGWRy۷>œ998N pbJ9bDvwg={>Q'}7m/Ʒ֮a͚ٯ<$ rxV<A[<ACz]u ZJ@BRD]۝t=fg:v؝nm'm,Eh>ɇc=$o|3.u(odvPCvcx:א �@�@'q?O?ALĉ7~xzFgxΌL\,2b~Lg~< gy<CY=t޷ R{F~(+$$,2)NI9)SczOMbsfؚJlsV_#^Z3CY;AG v2 9w_�#ǵW_IQUtuoϞI}j^˔]rv7z,^{[__#.#w7P~J~P?:YazYsv~^Y&_ 1k3��BN~/{`lQa8}H~A}N<8u>|h_7>솃靣~ħ�a_N1F1.,\̘)Ċd-;GJJ"&M݅EnKKk{sg;t(rR��t &'rR 3*KKި|u_uܺ}|c"M �Pk 3V_CwvkK'+f|%czb U�(N<8}~mii}p?j\(d߸t"qj!樂M[ 3�b_C :a]g?,&Hr"�P} †u:@_JJ"45h.6Ya2UG�. 1-wU\}$:\%�~&kwXoݨ\$?cψZvۇ{n{֭W �/z鸰ps02\(ꫫsR�dxa=!���} *f2 _cÒZ"GV�0?obMwߗGG &M"ni1aa߻?-V+SaO`LiAvH�0N&4MFR_7 0__>yyS/SZS'LMO=kmmڳ#�{f|x؜鶶X{m7edY1߻?�EyW;g� nKK~֞?m\GJJ"T�ާ P|?{oxd4c2�*}N]: +�xr?{9bT��ǻ:7���6?Qs4y���_5eǦ?ou9>]-T@`HU�F{ݵ=8>@vy�93GNU�taMF.r3|hՑ�3i�"BCgO@Qv)[\hH�ĉBFy Y�@G-^f}3]xƪ.WvTg8E{Crxy,�y&=]xGSӭ]uՕUgXtZhY�@'U.{rO@;M[Ugx Fɳ$;%Uu�І{/;w&3:WLu&�)9.^u�Њ{/b:W3&E��0EMѶ^>6\_LW ��`Dۘ:!%+Ļ.cU��ɪJKɽLgķ*N ]k7֪��0^XW*3tҿTv6vZs��d}YQMgr~d4@qVkA� Lh[gM4X>_;[u4�HM9c֭W�s<ggM17=ϋ6m1@ܳT�@gV"{?:>h.:�=-\9gv~^u�ѝw{w3t2Pj~pXu6�Ywܬ:�Gwo_@G +NG%fk*Q�aS/@cgSkcTsWz9� f;NN@GeUZzbx�44E<tshQ�oe$%{v|:.翏 +V^Ƈ��~خ=K?ކ3ɪ��$7ϜN^=8 Y, *ڀ* +@hl 6r-` +) iH܄$@HB .$R,8Vz 茡ә^NmtP$l6#g9{2;?`$z]Sgܪz>��PRwrG"QjKӏ�� x]OW,QGΧ8z#��LaJ?&M٪G��0f!k F+-GyYYCT��`tΙB>zr?`Tz!ϞkuǶ30q0~֔G�\Bh5ZvIpx㍵g`\M=٪��d|q5׹g1# OTM}n6A-H4�;IBp;\^7[V5{W�T)#{¿00@1,kGL`\k&MV= +�(n1ޅE<;n9wZjݵ~z�PAv,mrcC]cPU(ۓzN�ƶtn]4�`9BBF]<SrbڷU L&Jܕ+z�KC;w^N?`tǢ=zT�70<\�d{xS[TpF]ܵa9qU +��`8?>}fߚ]tQ1ڥ"T +��`$י:+[5zGIyj g��H6^ډe f]yճ��ly|Ț.Ϣ? +鏬EwzݎL��09Bt>{Ҳe*PLݞ=H^3nh��Ho.],eGvPLܜf~Bq!b/V 2�zIܳnz]a&c ?;{yI驪z�=wsV@{# ?Jջv.P=/hT؊w-Q=�Zܷgzg&WT t^{?6\(�pE,.ǙRzG|"XVXun~cQr|9;;F,�p%hd!NK7?*7?a-51SǪ@ؗ60I(�p¿ݗ<@?˚-j.#I檞NJ=G(�pEoe 8q|dFhyl͎{yb3RT WUns-P=�\ %c.}tTw;#IW<Q͉.z �2]hy9>&ѴD 7^u9>iuԜؖ2n?rl;g7$kڲм=�� +{,켟@TsmNׯ1A؋mڷ.oYc% Ӵ<#ׇO +��dF^ӄ{١|vf2]FnEz?[v?RHҴy��� *vc/MS}Oc`Lv]Myf ���])~O8#+F氝r-^}OC-7Nwy"���z? =^K@EX6az.=5=<LK#���fC?fs?`Qx]<_ t]O#R{2Yһjn'f1 ,L�PoD!~=QUp#6Zq툽՘!i$o[)OӴ ]GCI (}'=Y�@|AN~*WUAjc|T4^_gu#;G?/tL[ + d9,R=�Yhoya2PSz֐WLiFfpWM=Qz٦:M[ CU;nz�Dm)Bn"'KiF]K?0㞠﹜˹W^#{Q0sXhsNٴ1V,�YyQI j?pڽ~DmˋMy2nr->n|�5kFx]?DED�g w˴d?p5r{l;z]nDekGi˻$MK3� T#].2�$oO-uܣy^z2\ޛ5iٯ(40p*rEKa8 +TUPhGA9VT@�Π".+U׵m%jVvlnq; T0$OT}L&Wt5;sU}��ۃ͝Pۛ;d0ܰU{fǕ +wط �0#8 })�sØItm{V} R2\IN|_hOV{}����C}rloBn"K3kQb*���y2bVO~Cyݵ %jН7ts\H;,���Xzà%sپ�LP^OZ{Go���k6&cԪ`,HMam[YWb?4;db/���Pa"`hZ߻|;Ē2: 7*~q\ي}����7N/J4u~�xȒ&<K3 +stط ���0h{\y~ՓEد %jНilN\s "=( +*;Vng'�SE;aH%tEc^�1KUr˿j?Sľm�?lvVK`{}Cڭ %Cl Jneqk}� =ǚ6K��$q2股͆%ܫ %C+3Ӡ^yiq @b.YإorpR�@VwvqQ"b;fM^CydgW_�͝}~Fk�i3W;<;d(1?НilN\Q+ž}�{jWՔ}� ]l!ӕM5�`VU g_tSi$n+}� -s9=nb_ +�HTm`S*c2_6dͶ;-ݦF �@BԎԥor+Kb_ �HZLۃw+PRk c1.A�Em).vI2�@lKOF8jà3Y`#����<ľ_CG?@jl~RsF:-5i>���ߴ=҈>;ڜܣ %ꏤرYxS>���/7(=JSk�x4E^<5u4#M[G���/`}TP.?�MIS39ش?'> ����s"o{tfVUzBX?^Ϣ.}_]n56b���@^|sh~hwlA�<:kmM5{O~a?4;eb���bI딾s[jia RbȮY7,{\ۉ}$� !EV:�ɕN}b ˻z?�ù0: ??e?H�@Bp2ؗ�O(݄qDF5נ?�ͦK GuJ\q>�x0>w\^�<\== DW]غkN1#2O&[ml'},�ϓ(:hz6ѲDD.~ +=QxI'@o\c/Nڡ?�ȋCǛ/U?v\hI# I![R#SR;<F$jR3)G +w +FNA<ʓ\B-̇#hx?y>DA3b/9|WN)Q0uXzff̊9 &OqmΠL)~&΢UsfM܆6. =+Hx'.q[LHyo<>n7R&esST^z-Uʡ ja?6or<#0yNZ5}}zx {p ^T5;kK^(Kx7ߎ]oB2)Km O޽Bip_L^ͤ (O\1[8 5/(jY:E.N(bq/RT"){;1/%gbpgNљ(N?K2bF /c;pI+. %159'Pp$L1=Ұq=_LEN/yu I.޽vCyr?K{?_yOUpR9e0*3s3Q?΃dzT=)<Gx^QO09z˄�Ryj,?¨#F:ʇ>K9Ɵ\&9HH`RM &uhRkFٯ*<# 䅼a%h *S`):b1i\ +Shj+Fk:m7wg]lmSås򾠼/v8tx{cG3a p5O5}b89<1Բ@BTW lq sf鏙;EҲ; +}x^=L8(@q<O H%a̡QB$6f_WsB̩rjJSxoIB~Mb+p!'1UnaBD9:V@b(!m$ܡ6eüJ2/FW䚥ilSc/nls˧hYįj>rTZb +1E??+D\ 1R?+GshmTF/jlNC7?ኵCg/<O?Jnnus Z7!bώmU8rN쏎菚V#Ѳ-ONv07&ox%4X٣~ijR+5p.R4*2rE/$[Cʭ0G}7M]q,rnȇXrPU7{ ǧ=3m]Z?551#8rF쏎ϚpƩ:XnQ?#eklyE FN#lb)!w $}x\A?qyEZ?5!iO0(ks5p6C gQMnR-:uö{6_$˘t *a/0=*vjHx4/ \v"Ӹm%OOS'8Ios4p6C PbkT73aF\qpRTo]_CRJ  PLE 03G DxWp׶$gy)-mS. Ǡ4p6#3zC?Nl{rJiBiC+Qߠtku2l*9HC6=Mt ̓H$,nffb!3=$g1 7/H:#ყ19 х>s\.'?x6.R%([<^ۦ?RrZ 8rQqJ=ҕO9[x-dv2ʠ`5b e5 n]% O͠MTz(z)dDzp0$#t44@2F)R?$b@QHGzt@LOI# 5Q98n,ocZg%OOӂ?WĚC?h|;G?*T2 +t!x%mǏf[`:UKB̦s&mӭ3k=e#6[T69f=9f 9&[2K*I%=4_f>o@0Yf8:ek>޸?SnƨrNb6-CꝊ{󎖝wBW; +Qӄ3,0uYdĬ}"fΩ'AF5ȭ 2búm*޲ʣyp;Nӟ;^N Ƒ4cGbuͶoRw=g$OOӊ?Wt!R5pFC PbcEZUVrliM-.+Vrk֢Oj? }?ȵ2F NE?WvN6Yg̡_SSϳY?4m0ⷥaxfZWb_Yua Q9G#ҿ/ݛkͲ=٣~%]Fo?,Qont`m'b7\oYIJ*K={YQO|KݖvFb6C*|Ғ‹Bs*_X* +pOVt8ʂ1W򇡇?k ch)'ʡsvx=&zLD6IPʟls7ϱi{Kl$l{g$OOӒ?"Heֽoi3G  +1\sGe+]+夸Z3}S,8DS2(?KúI2rl+.9%Zuzs&ө(ߥNovMCbirvg$OOӒ? Ƣf]ueΩ>cP#?(=ʏmݮ mWTH׾a-jr @Ot/!q`14m79+@F%RsHj GLJм=đEg$OOӒ?^+șayH!i/V*T\ XB53kߛ79 DkZܯ (Ǫ#bc#XkB|"$)q hW|PAy#5".c#V6ډƘtejTNϹ,.f{{χ@;aZa�%SI47 Z7{]KM3&&&4@}'_пFq}uIfhÛ?|S#r1]xAH~Ȏiշ֕ }+j_kA,`&h6!4a1F0ܻ5>Sz %14qN�A[|iBԽU͌e_?Wnq,YAW8^]?Bu܊ +a!]ka/}f4vhmќw<D?ekڏb,uA��(Jf44.=`u<8%HNqKѓS!9JG0!鏗yq ջ7 xTS A/4YGst=y x�@/}=k]̻ tŴ݉88<=.>թnlx-}XuFk~dԜ<S%WDvaϗUe_Q?\i]; #I(@?�.V:$nUaǴoN?pqx˦3⠳b'a=h^KB鞺2Ywiyk5eI ?Z 4d(v{?,RHy gf}}Pci�_W|&{]ë?X`;8 Cb8UݬɉΝ,GJ A^Y??M-q wau{m"`CBG^yG'O䠳b'cnÃ:UϤݺsWi4+?&MY @?z,)r*yEae{ǑWsBIVc!![).>'vN }zA"`lhbq"X|A?]{r"Vu;Ǒg< +5ZUݺk样b#h?lpdv@LPוPPQ~*wÕ?hkfiq3^uQ G›w TLRxS+ΞШnTz?kxv]^y}!K9?ك&l7Sf@TKO^w_j!VtǓ#Y?&}8RZV5#W͍n^7kxnj8v4dp]1C +x@@~DM.SOآju[U.<FZJ3L h5vlF??[ibwTf>{s'erY>}T~9xKt UwE9#?I8U`v놱] cρM-$7h1l2?L @?x9=S]<z#IOYUU pv690&f{ ux`I,JNu;8+FAX{!u?7uɊ=gņ]YÏ=^]R&-p њY?,Ē?Z rA|@8?Pҿ%y8RuvVay<d?E}xPWzwIutbwW?G+*!^]YYoUQJ[Ł `7o@:f|ebvHE? kuwF//|`~>ӋNl<CiG堿bhd(rab왨cjM ϣ7S أc,s?F?�IWUl?p6եʬK=?#c{K-]'ڳz09sa1 c,9@Q5Cvy=rS<lM0˂?]06!?^isbɃ:^^(/$|y2KIbByi3tXt ֩o/Ϙ&+;7'dJ q&-ڦM 2A  +!?\}()}9(PS~z]#Qgg)C&  +xKWgToI)ZS +#$fc!.߸I=sTf"/oZknkwòAK\rxґG^)٣j:g)oqy'c= ۤժ8;oZr{ ux s6f-5J8i?5K/*=-L-]XWy&31c,d`##tvHm+Ϩ6 z?v{:?㟻GX`Bc-?px/n~gݲ g}e2VwO_|(2=#͠?xW {X:Ş5Wk�tl'zT N^K~Eu? -1$8I1(IVZ+JqvѨDA +ݻ{]o$Y= +{{3w>B=D(DtES;<Ln_lWnc0Juk;s| 0yJ(qy=Q?f";nYHy?`JƸ^]1+qUb~j(yq 8mt_?Z ?Z R lC'aFc_ O؆:?w F=q8d1]o_3*6(Ij{zQnYHy?1Nq|Gc�}ǤJ}B}Ǹ<W~r"<-t?y5D@bG((G$hGKúo6o]A{ǀ?`mRiJxUq,0δ?`d5_6-6n9ӥ#Ń?MÛA8iЉSKɴw &GϛBy1pB +?¸'>(ԅ-J.Ѕ|78$=xZ >Q?.2JGsK18wF Q?H[v}h== )+c/ڍ#OXlg +w8J`ial ?6~W0:JGZي7[Z0pB G?3ƨ|W2NqW7}ғ/3_vzt9AB\w{ +\^_0:J sG}Z7G3pB x>+q7]m9<lŎךsNrSHqcigbC]/#?^:3(mo3k/i0Neஅ!3Z#u 2* +܍d5yZ4Z/08+??T~>7b=ÒЅM+,[3hL010=<3pB?ncsy-iwEgOO>x/ϲEg)=)jyAE_?0̣d놠:dஅCfDc?#ѮB{xjXek5y^ ۸ùm gspq Sw۫n5F v <`b<b?q_1!N/tHG<m8n3HO_m0[ÿ +R )�<Sz?b\#OP#o(@{FMtDeiA_m!0⏵Muȷe!ҬNvP{s߻|;hcjE7\3g/?c+^2ź;g O5A*3^`<b;읉.xVD`5^_>v'ϟHtS;cldla?㏘+c(B7XN{FM.3|~X} 8moMD}HIYr6Ux~8o6_4;8d +q%b{+>so[g0j5#"=U1}q [ c]S邚KiXJ֊eE&wЊq֭?|1pܘ1ѸXn}o5A2T :`b<b7e us,~iH>G? . P=amojM7 ;QӨExEb7e`h?oÐL}oyf˵EwJ+GAc* �3ߡ7 Q?HֲܞSs!6PGqնU̳?L@ b+RK�(\$"tH>-4FMH.ЅO.a΅ !?1jb;9}!G3,{|4tǭ?R$ 0p$ۣA 3ë?ǵ]gD.4FM AG5YO3pBltH8I=H1R1yyfQrD>AgCpww䏳 ! NB! B`qO7Oij }h5A]ü ܺ{?b/t? +^[{B>V/Γ?^lOpgybV,<k8{)?Lh"tӶ=!G5sH7]] ܺ{?a<G q<Բh@HO@IO^<qi%d72|x"P +P:CFT 'kF^ZoÐL}oFM6[6f3^` Cf U)#*KC}G[.Yj'CQ1wv?-KAh14O=>×bkBO,7Π7 +Q?fϔ ܻ[?kRwMk+i@`(.,s~~1^IЋ8'X,|%/�t?ZqkU/;#ΐ+F 1pBl?uUpɗu2ng--]`f[63bKrRDRaaf i-ەɷ\ݳg/Ҷ玃̝3w~sSq<wLtg �MٻioFM0]}$uVf_΄VS;7A6?E0q?^_\b^x3FxdX]` =G{U߆mšx\Tz,xUtV:;VMA= vp7T Da^x3Fx()4 g7l'1r]VVñԮgBа]C'm %;pĝExǠG{8_4 f5ZA6̷.`%DP<Oh6$o g&x;_ ѝg["Z o[Na?6\K?%)Gtsߔg!td7PЏ"SAo[c(cNx;F[H6ZދK=&^ܚԟ~SLβ(N2! 4GcH^gd'@p0ϭOv oQӨ=-56^^Gx?Ϯuxc-fAکl8r[T2AhjH=|c 3ګc&%= +~l\`y7?p4jG⮬^&v_}/# T?B=t5*v}\<V7$E]?iI(}E5JN|'v_}G1K6<%,~'cH=r?:|Av?5P$-E5A[y <�/gGG +Ku;7@fG Ε??l>+?hB>&*7W?p4U0][~ϵwGW{GakM�%[k*J~;$tw 8 S?d؃ˆvj8oBiCg,`~rA۲`ʇX%[sP:Kh%GoA?dBn4}(2&P>~g훹g;G$@\X.J+ciI{m͵@wIQv?08Viݾ|8j@@m41X_l9aC?{Õ?V\@=Ϣ2Qѡ?�P?E[S=2&PAK:l +@*{0Pr�!#`\O{3X gTIJJ4<e&y $:VHDS'OxѳB K)["X $4}.iLW2?�1Go+qY{_\op}b4:N2Hw$Kzd[4F@?xn3/Y1[8j@Lpn.CL#`'kLWG$d~}ФY0^L>8iZ, H ߋ8 Iv?HO>ل7CtAȅƢž ?p4[t.0~ ?o,4Jwp_nEzV, i#qƩ?tAz@8ǹa2K P"&1@E7o;^%0;Gox`p\f9R--.^>,jǯeͧАnq??q48m{D5MOM�Vqc ?DߔyRJ9_zG~q6//m =y$: VCr菰>f5W*&12d6^XkGoHoL&Mg~וl}USlg-5*aDqd{a7E?h-#R?p4ZSap%� ;1�!c]G[kaWs͆Aγ]fӁuXecGA?V=9!;w+GM^HڅI7`'\Ý=zI! 2ǰJ7M?Nݴ,*FcՖDGN;N2Ƚĵ?֋R" h;G?}bev"{d5MW_\%+D�pqD-}O^ܚԟV M4Y&?H>֓h3N!}p0N&Gmc} dn_>~{y+Dw,/=~OڿcQ?RavzF#C=XZ=vWJQ?hHx"xD�cU󱝇ʋYm*vCC9:!ĽCIP知ջ=Gx-wgރ�<4H&4b Qf4t`U|eBPbDE彻"+MTĆNigڦfNa]Y,9wf{;OiEeM{ƕf$jEW01 !uc^{Xc^5cWI?fiKmQOqצ?"<?L3)jP?,q +CYHg;[V!V"+:fk?`\iF?&IN-s 8CCvy,?>^Ԋc1侜D=G  +YGՠ0$ǁ0g ⌾qOĜ?&<vǔ?|{H<Ksms^J3A:X:Vc,a| ?Dxy؈wE Ry~f[) +5[ dl5CZ;0y9?#A;M++ c1݌ (1p>GWƌtbWc$.D-G q?1a=!ۦ73t*ƹ304SEZyKơ !Z(e]fo@ϧxHюs) R Dtt0dp2cѓ0cz{^L1n{?BFmRV^p^ J0,z/%9ڻJg~ܓu{/ >?$}&dS6f&aLxo6q'̳6=z,ƕaC⏊jMi !- )jTZJPeV"ϔ󅕥qHT5/.D-OAGA0uCNJ!#lv CK+.4Ҁ?z +Km`c8'CkX͒?H)M_//Hì*5ʍ<_?YV^LKDaz8˸? ׬Z8HEO`ja>v'('9iqMiqEJ~O[v^6)qd 64Itj=ᦾs2x&8xc:⯒7i0}Vq.yo\PAڇAG_ 5ZiUFqpw?=ϵgڻL; Sq.ڲmGl|؞=S/VI㽬^Aɐj ױc ge1l,xRv?}%ϐE [G_{S"[JG$j?A?lCP_|@Y2׷ϖ#0&3kׁ?z77v2Luc ?jCO}YxyAVTݹw&TArScF?ON0s|@}Y#,Ul* +Ӌ C8/CqY}+E޲ܢ9tU w%o9g!fQ Rh/+?`2nn+:N'ϳG֦G%d8/Cg^{^a>nByI땪Q?Q$j?H(w8*P?nn|d,ړF,sD* v-g5yHQQ)Qs2`1#Ϗy~C}oŐp*|hᏻ?Z?Qo{Ie%yL{oY q=ڮM+k?.</iW1a ?#xLS݂3}Tn ƾ6H %gYB 3,7чβѳl1ю^>fDe*gy[$ D:5מpS0_'>b*YӐ!1Agrl=ϵMH}_Y +ym^?ʞƺvڤN^z`cGnuVV^pܲߞJ{hv@Zu8s3`2Мh滛ږ Jٹ!K8C"7r'UW39?`Xqϣż^QSufF{Xk΁Wwv^W0pnLc-Q滛"r޸?"G Sa8Q}>uFx0ǘ10/3WaBYq5PQ!G^u1/G +a cPW 2(=e1 Sz"si<G[uۭE{28;Cfq>GJ{GuNݩ Ax?"Q?.Q s}Yӓrˮ~Wg:<$F{  #ύq3hzLr9xt Z{#)l8%.xa_XiEi=ܥ,q ^XnW13_c<7^ bݺʖ8 j:ZJ0�8 ˅xE'q F͵%}md ?c7*&ڻ)*WqƠT}(XA=B;6AcwxO+&?`\iSR_?Uٯ;?A'iRbh&MPL҈h5j*#D(FPDTT֕{yŠR6X :>b364ms {Ź|Gp̜|K%߿ĶaKkՑm֕0H< F{E0_R?Gxc_.M{)8" CZ ӡΨX-;4&gF޵Cy勒Iq[qi䃥pRtG +!|w?7i<G߳RΡ?pD RY"{4Yf +xW(=?vϑ pҏ}n 'OQ,s,0Yt8;)8" CzR:7?q#Ⱍ>Ptx4d&ϻÆ@鏛/ `{GA׎E.?\AHdB}߶^.P.geFfCԠ?BC3F.wQ ?pD{En(q^-4pB^wa=ك,?wӼwQާ3 r+5x^2 Ѿi#ryB4 +yۮS X`#?fBߌX1.;GKi]6GG'X5%`YI9{E%i<콻w2dpxc]ݖ_~Th=K:>`yc889<*%Hp#P=D)ܧ1GJs~n\;(R<-KI[?b�qw̥&>彃J #Ҡ?<-auFCsw1yىOs�#Nzͩ=:Q?Ŵ"@G}@Q{Â-?%i57֤zK -!Y1bT'RϬt<F]pD]{g~$qTwl(gaD־ŨޣOI?pD%kgU5!$^j W$7Vw"Vl45&ӺUm{F7XzZ?2荼q2KuF[aW{_?d0㆒왼Ni?pD=4FK'dp~G~\>'މXa"&3νqD6ꍚ^Lїn&?7sF5zC=7<qSZ]Y# Y,5?迟ĞQ{s"<o2\td/R7:FSo:GGE-ѽync3GW_*1X^пpbF*)1H1Aj+Ct ;'b>y6 ]Ur6vJ?: @RF;ޗ9%iޗ]QE#5?.,Ӕk>k"3N}2' pכ5u 8GA4Hgdxҿ(n,[.+kJ #Ҡ?og+p ȳL75ˠ[757ߏN uGMP,j Gc{( +w;W<{הGAx_pD(qtFk ?uW3"z޻&rѹϲs^pIG?HGHg-qYIEq{_5i)&/-n3ܱ1'N2xa{&rcu< K򇕺G&@*=0�rQ"ow{QކP{8" 7=l +T5NU}.;6 ך2Mฉ`֛N7!#,= *7EAKGya0Po[;ҤifI{8" w(>j^A2gcjgn05gT +hT%4d].GM/P폞 q?%8=pԨqK?pDm׵m2gc>u7bUxW *}ݠ�a} ȧ~(pfȃTM3i.#RzsV5'6x {>nB9. #`{W׶nqAxgP?G>jW0 pX؜ۻnGAnX~I/6x;Ʉ{⏥m))3k&r߭@s8(V? P %57=bGl |<߫=菮p叿}L7~v!H}Jՙ*5푄ྍ?q|fY{)zީyCu6C=t7T7C?\C( +q.Un3x(?pD{cs�v1/dp#_LWo|NRqk WCd$:#a V т֖ rc6JA0=A$tnqg {)QB4ڢ;IH mbφW7DOkٹk>V!TQuE̳pD?(=h�ܶlQ(O"i~Eu? X>5֘L4i+EF(DPԊ/@EA +yײoYޏQ@0JUP:ufnY&.p=ewC>>/ s9\#h9>~+Kg}0/щ֯bA�>&A?Ð?.%1F'4ap@UIG"!ǠPt&JAzX,Fu~ءT('l7 1ʼȟb&8$$OIM?`hp&ǯGw#EpwCaqTi׷H§#ۚNt&#Ȁ?z2aț<xoǑ#4K危d+!H0yE�2 B?l)jvo/.<Hm?`h=~}xO70kJV˯9~ݫ˧gߛ41HȰðAenx=fhZڴ/&!4a)K#Ojψ%$5-; +Qc/ +ag=Drr4s +}N)f=�?;B#=/ڞhZ#�(LT_h}g�8!>?LtGoEZq=3-һCk!|cA%Gd›Epc8n=L9/琅 +0X.\k(rC&Cx\RvlCkas#S+n,]"auw:31 _Rv5;N(آ:cregGYI*J?6 KG#B^944k*.?WYOf76%is3I d5RI׽B@y)LcZ9 *0Vj +/9;Csa|UiK8npV9#ΝҸI dvͭ^G:KF #1}W0ǀIrB«Jz_hCӀ?$J- +RW+;՘)-฿(/k#hok<PY /K҂so?u/wٴ*~#/im"ٹ\#1m-b#:EVt2@[?D*ew1? %?\ +,Eo"Ԡ*(KZFzWXCӀ?ۛK;Ng14L-ɗYG6#-[k,k?>ǝuj7|?!',io*mcqsyg-qM,sQ첿4~!_6P0?Ӣ^?T:m٫<:fqb,ǟK|^&#г% ?"C?Hv#~_|g +;JA0MJ[xى6&g)1~sN9k5{>S)oԿ}ڸ?$fvǕ}v,}`]Ц<%,idwogT79K? \e}fqA1݀&Q+?t?-tܜQҜm9j `7? +)m`) M WV%-u8qz'¿ʒ o{εɺ3_.}cH UZU}^kNHowGrV|[ߋ cI7D?;| /+^ڒPU_2BE[+^}`H{ZA<INǭmB~Zn$9pkҶw$o4 BI 8 2a=DW#2B*=XTFz'X CӀ?ȶ8nNmB~ +n-֐pjemۃ%b.jhYa>1J`L4I?`h٬=RiɡZUnsS~52\"uͱ'ꏾ[wJEzX CӀ?;?GwcDpWs9n ~J Hz íNx?Ht?FCKCτѺlVpeKzX CӀ?g9eɎ&U>=G\jw2TT[#c ?l%?ƣT4ZHsvql< +_V4q??Ns^~uD@zS4ZW>K| u8;-۪X?z1NoQceNX{`9 MG63Qf6N.ʮR\اLDzۧJh:[iCP{ nOik!ACwe9ڂ2k;rKАVaRc?O.~vYzAQ rr;/ +EuCG 3?z:BjM)n<Pt]Y\4-wv}!?$hy:A#8'%g=gBujZ +rp@cN�ĸ +jCjTmzfiLpIш&EPI%*� +0 3 ΰРRScEWTccOsjOwGy<os&rw#Yuf)Eq.򡨝?}cysnĢd`8l1N-xrDc0%pj?=4Dzs wwN\|"FX~B ѭmOVuI=<p߿r2"TQ{d3izw1_{E1#;h`L Iz! g +1uQB<P^Uqunmi8p_ZGor{yqy[O^KI_0l}M(?NG,=ߤ.%{?`;}O7lyjs3tׅQJoL"s"p;ձD2}cȍ;JVv5y`|;ul!a~⁲MGK[ā;<jӶ o1fq퐰X& ibnǯC_ksrL<"Pgg1eϻ2u ߼S~wp.Dyٛ?i*I:d{%s߽͎?9<Adsrr4C~v-h^,y ] u޿͠<%7r2#=24V)Eq.ys)jvOhum;֐uJ3~c?bۼ5G/-rG$,)aiQק?{�V'dTj"PWqF+|$L1압^ 8\ǣ#%'Kl_6Uik{714y3>o]()ʫ?SޭU"GsVx >Tt?Ⱥ?Q0kȡ2fsV/&%KɏJ'+9KS$x&}Lz{Kg{k{~;@=SʨRk [āЭyx?LJۏs?T6i$Mtkm0HAQG1?n$Uj7zuї=qݩ*Czϡ'4 fǢ^OuT{ƨO^pp;N|v=wwAf9}1B#-+1`QH 2!3#.lK(Lş҆'"xɪ;x1�\0CoБ~CO4u4^~+U*eM)E#}w@bkꃺBһ EuJS'hS鏄AΟ586 ]zk'G3pbrE}t2nC-ޟkW g/ 8p{v,ާBmυt(1 tD6HH#*e |.p;ҪT +ա6|wω*\q G|}~?0hb alG8fP"^^n,&P߁?`4~8!t>.rD&)w?y2O&=]4l[k%w菫l~,4NC}Ҁ?SZ2G]kR:][oU~Nz! -p- +3# +)YG"xHE^pDIɕ[sgk<qٺ=nݬ̨WQNziiA|P|V*9pk7E'!ϐ/Y.E ҟ?: @'?ph,Q5ܸMR xԵͯ:mt P?`4~%(T.J)j|Lh59xe9VJϝ+]PYt奟iQkOffG&Ud 5r".CisO>;*Skh+Jz!3QN(XGw892OхEa.m"G6m>FkFH_)&Ejq6p>ϷDI{= ;ʝC>$d"KA.[LGhj>l,Kz!f?`45/n|f_/}o0ewb&HblG&r?#g{376hҀ?Yb"B{y EsNϧD95+|mR[Ozw!+.74\I(XN8raWDL'&0B?{#OR_wz>%J̥JwI.~;?Q{bڟ?bQ�G*"|!k-D=G_D]y! 2dT]{>/=>_>B1 +o2=GU(a.MDMsVH;ƛB'j$8 Sٯ(;|!HM#u44Mu3` E lHUʁEDNo#P-*j[cؙA v0pX) zjTʳ7#k)8[KǢ?\�{ uCqv'^C#݆?:᏿)(qcek?o}bmOڼ1e<[X) ú nw+5AA?OM.}W:h/jGA~N#!GS4 +g؃DT4ԪoB0ml +u<a _9˱Spd\Snu" +Kr3\(_CE-bG['y~Nx~oW?`4/ 'ar%iOvp]|{U|M녯s>:3#!;TllǡɽA=WN=]:FJpF4{ړ?Vݪ+v~S*d-鮜nDKdw? s3S\n}Unxj\qs/H*Թ0R4ȑ:{(3>ɇ *SV_A FP +` c:\ɐнYq|f4l[=6jdk1Tz=-'H(0R4uD{٣i + +&+x'3ƞB7+wF o*qn{M;6#/}sGPmј:FJN_o ûiiMVn;1)b! zzFdmv 8Y;ᙤ@z?Ҁ?Q]a)g}?֟8`ÜAz?!< +t=oOn+.4Co-NLCcmBu6<?!iLV*�{ Y.!#jsޖИ-  z?Opk+|t0~ԭpǗq>=I%0RJ0eM+>mow\\.IHd#R/" ?4b&B 7\׵J~®]|mCZ>ʘ$P7 CzMXx )8Ӗl=JF|'!5:dN3Ȉ)h-F>tr~N\C9fljp; uO) CEӗ9Hd㏘}%w|ymWm6#�'5z鋜޿l-NjMB"PҀ?~ls)8Ӕ,!~\ gRH"dq;YrAG\?PfՃmy&~&ʘ Ҩ>sU p!PHim6yV!iIp|_{$'_ TáCV:k0/ 5l:m{J&g⽨;E2;_G +?!~4'Hd{9e<wi|]P^wԧ4GAew:2WL0z/7Dy,m3ߴG1iv.u FZv lOCc{Nd?\sյB_ CSєQa?�qc8SyJza1CHh^ȑ3{j=S) C \t#ƳiHp}Ff#ȥMZ/EVPꏅG 4F9ZC.x­_f0!sgb@P?N+eLFp>1m@J?`4xg{PEt '݃ȅ?UGAhǷbbs+N@۴ Gwy]Д(o!saC%MvzҐF<gwW)zi0JHiү#*ҖgНw%�aF(nT E;_G _Rҹ7F C 7&?.п[R%yOziTEp;<^obϔ\=>w7Uh *¼Р?0R<rK\_g{9�aF4w=靃ȧړ]~1u؄RD?P?"lJO|y;מDyۼ{ +s9ٚ\f +t|vG'y,FJO*SVqsM(p� ,a8tbQ>jm4 @:ȟ!oh +g4. 9E/{W@uuh>cwmG +<gb�ӕ0R|d<tgoE֔S�ͳ1~>A^ҧ(Ѷ#A?o]8x7FAaٛg$&t%!X5(Q!56M4m&}N1E`J@A "b e9. FYK(�76iI9݇g Ydy?}ae5ۅQR�dikl|9ԷGv`kgcŝyΪOpT!<gS3?쏲SBG0;1MX=Yc>q|p~wt5<�8I 1NS.90⏖3͂?pJ:3+4&5L0` {x* wT!7?~! z? +ooʗ +-<<14:8%gD{w �p?6mYf]:m!2f~|P?zw.`~m )-x\]k{ɲG,o" GRb }s&aKbE>VڻBS+ K:I\� * =~BEv zGbg?~pej4{ÿ&b[Q1=!v˒JүU돳r$R,{BS݄sY-L#1D_M=q$%O $;9™ό?JGJk*/m{BShUN‹di1D4뭒39>}4 [ ?Gʷǐ'Sm)7X:r F?Ц1bR'-imZw۠<\C{C^NI Ҭ=3Asu paE޿)7/HJ�Kg?\(⇍SSq:pw,` 5UlT QZڦZpEkx5 8%7E՚[K&�8Ц1vr{ۜު?\_iSVv@OMId +3D7jd?ڻASD~?ٍ+?Y3~>Gi?A{7~NI' ⴵUu:}G,G1c�|x* Iw\'FQo9ԑG&  ea+.xQ SdqW1c� LE\/XQkFqd=uGE>fƎFNIE~y2YV3`?r4yp k}7d?E\ш@?"i8x v?pJ:=˹F3 mVIͧzMR-E}w[p4c鏯 +IWw,NNIRgd_À'w0%r4Ƣ]72/UQa{ 䏦wE林7 +)4PޱA\~m_,�[**]4F~dG:osQyq=?x{]ሥ|b+6g8V  pTn@j֞ \3 `Rmn߸\7zQվy:|zQ% z1kط+}mFu٩36{ VBev ¿&??JN;2LE;i~(5J50$hGs̩9IOhcrЕPz1nWQ_,d9C?ʲ_%D{[4쩘+f%VXN:.8/+)qzxyӡȑB5[=NC?vt_X%kb\0M ׏^w <ض|q7 xե<KYvpu‰ 䳬ض-Y?n3 +wWr"pK:2EcQr +?NN}n; +~O{  НV,fhOqr)Plof7r$p+,e5y&RNk^"*Jn81ܣtuo b;7Pﬤ`eo>BAI:==<Jks&DV)p+$v]9- ォ�)'zQپX`,<%~noޯ$&x@3_Qyd|Ɛ_>F!b%^u M՜* wD mGevOLny ѵFN[ʊ93SgP7V5l(5=`y%a)RqT^7n>n6kNGk32gX̼m,3 G)#ݨM3)6KG$j(o2i5?p#}}+Wq$/ǜ<Q^M1vwN|^S?Uh.z~4H7W;"g/;_LYu]n+ bUDeE hm0<D$<5<yl nnrI+lݎ/`답3;Gﶓ_` yq~3Is9;4E ثrTy(OYsĴCNJ@Δ ַ4v]V=u&yd)yQ0ëN.q>rѕCT867N PWoR1lfvg01WQ 1qH~teԊo\3; w )bzLJϊv 穭='< 2{3q?_d?_mg-z"uN/S^a0a̅Fߊ U?:f7$,:dI$*- |c=GU1=vliCYo˙"]i=ck`2;` +́H6 [ +Je}G{0qydfy,9@:V+7WWimk&,7C?M6SRm5r5=zl%/T Ky>en+x7>R|.aXqS}p 3`K`? ;y褄^o\"iU<,P ּfvvl66v4)^w$djk$17t#xUǩm0Y?>bq9$̄83,y$/b`˙jC=WFOQ52o7,Oc3밋W@S_Lوm#Pdwf.:GlO3_v2#xAqe IY__pZaOcifk11ir~A6#9 W=kV}ҫw_UJĢOvYlc �%7m47!G$h!2BFɚjtRXn'Um<^HE;\2 7dgF\F1L7=Ė%8{78)0v1/Csr˷Q 2s-?2n^j#~wj}my!9'mŮ[czsJ캊x&+z#9 s&ɏrU˜36nÔB+RFWHD:y <GD0f?^;W o#GQvIQ=9(pP?SkH[[ >#DzIXkMf +f_+X13e!Zm ^k$ddoҟWFȨg|F'%vR1QTC),UZH7GBvGlO~6w0l(-CO4_8O-Ou"<HM#0)㏧B s@^g$ddNVWC^2ϯ0ƍޟJ+jen7,lfv;GY C3Gpv\mU?rOԜ.czyDMEծV<ۧgc8 d=Ov!!MDϮ;B1u2w1vCxGmH+ȜɬEN"<ޒ-'|XAӾM60A+ji{q\1ot:bY +(J|Ɠ%19{q$^PksoQ ;cv!K#ϰ",ފk]X1)U^^Yj{"9 s&毆\?ПG*aO_ot[} :>HFߊ U?:$4pln+#$Dui*T(L7*I|}3;3h;Hn<EP:g8<?osoyi;&G1]N5\?fErl!@Lf-+qyY,.;]Q#W6XmD 8URLIjuROmoi?賀@?Ÿ,VbUP0P'oQk>K+]g|S>g,K2XN*3GFq51vQ12;` 4w 37&@҃$o))"9 s& Vi}WI2 +![;HMo=F�QƶT>XiGq|0R?^z*5vFԜZj.&`xlb)v*C}hX'8'c1(MVgJ'55z=x!.,O[#V +_=&F1I _{* &*ȜɬH3Ck(vkU%_4QvzZzH kDy}!L?( ?2?\B̙ t`e۰R^*9?vI]e`i*NTyTTǟUM[YILMĭIb5BDA@*#[d{l.QP5 (hOۓ?s^p=g;O0$T"e~s#t D)X!me٣NȺZٌFb=??=^!iPs%-a&%5Q9E^9M̲2'`LS᚜eb +:gy_AT?HB?F c1#Y6 D==\=(쓍A7q sxHutyK?F?'ǯjaȾwM;wXlR2Xw:cx̲G;gXXkj }D>KYo3,i +6)ǜn&-o&]mb<\l4yO8ƫEx4a&s' +lҮ5+n/E=nۿ^cah0ܾ握'~BtkB4Y#.YQht2`AWĎyhG8ƫ4Џc} u376nGr`]?= 9Pus,,Gi ִD&󈿖%t9s%]a&%sFp $l U+o41LfN+yB&7}Ylre8z;' D9\1R=XYob KMJ]?Q*<Q,JJ>i럙<GJl+ȐEb k8%6E{ +"e#`LqfJ&&bKMJIWF#+ٶ?&쫶雡=*Q}; +jkUv}PlbZJtSg%vA }<zȗ[Թ4yΠ$&sߛ?<<~޿?H5 ˸޽ ]e &Z+$H%Z ~Z$ 㹹/{Q\Mk= y Vt5Ϭo ZtleAAG_u $tk.BDo#ˆAe#?z/[\?ۚ //nNp>szw%+P/=uFUkZ`I_?Iɜ?^5f�0i 74Ʈou<j( ܧjlد0v&gwUOnJ$5Y{'CX"=EMު7@G&epq�@m1e{2^5R`=ʌ%|??1j |$ޟJ eTɻ_XT6ZЧZjƂAlo٧:&LSvŌhWp:m_#+=R 06PR8\,QJD +?\>uҦ9qj150;,g;#Gd:#m#;E k6)̃uzڪkZzncPw;">ּ6}RS_OplЛ/, l@=#·|ء.,C=!lJ·y�z)yfu>NF)X-/a<gq ^{'+Ϭ+@P+说vt#zطEq[DFbr~ m ]?no9B*S,lR2g㏅1ku'܅~qƎC^q4[g&e"|{za1LU mG~1Ϗ}xx)f3dN1on, 5ϚcǺ>iu|L3?j` xp[TMr*]6زߊk̝H30V3zJͲ\zwF#ɝ|"%D 1:MJS{C({dW.r#72ckmZ&`/+ Wn6ޒ& uf+G"\ ~`o[w�h!;9)Ti)Y֦owC ? k[j|#:ziAnaDEhdȇ6+YR{qaaVKag|W㏦+st;X%ؤdn2$Ȧ<叔cfu?9^V95=QańnB}3i2gk>.?eA H}h?DjrW 5#>">=yx>#L�"Ϭ;ɝ|{8j XkB߂h9Lx`L]?O71�{\?Y6nBS e!bsXXcܗ7$#:qMhpo,lf\�|p4$6u1ihIj#R'j(Fh"Xb�ay+Vݳw}2XA'<&t:ӱ[떘D{o={9�uУJ&}, >Vodȟ9_M+MAfxA@ۡWWtw^;]<dt}wFƾI4NCnjJSe]a \T^N-架 #/ +PX`)?2URZ+ъwZ?zfwBKqiDԻ'?Җgd[5p~_[0wBR;c">7¹K^BƸy?Z7)6g  6KW?`F/e<(|f3%IgJjc{GCN(iG_۲~s=OGvh{᷻*G;+*V:a?�X\Ҧ,vT9e |}�?Nk<wC~+W +r�KgY5[ycjۯgm[|gs<ם}y<T#1Oof~Ay=y ԋk}qGGf<ecs n?0ãKg*vy^ /H ߝ:qaaSsvz}}/SW46/ў=; +]xU('z^{0qTng;ż_e=`s^| k)@o9z4X0ĩcp3$g$sŋ>{n_*uywX_9鉨{˲7+¿A`?7?;iU'>gdMK]'rH,w֗A]bkASx�q`s_4 .z| 0qoLćpGG=}?x)KXAଶV [uB9u@SxRL#+mس幁xe/tWF`vSϻGM&)ڲ_?kLNڡ4 NA~p6Iya 9hzA=bc?07 Mtu#]{7/ׄ'N!:Ե̐_iY J[>u~9) ?I(9ę.iPXA!1v=ϛz=ȽRL#*fb/)sdȟ:$g>ϗ@ڡw@aWqCN1~0hG(*|?oȬ繞 A5yN}/k2j'#WԕvFO(9EO?03!e_@/[gj_򏹢a`,JG3%<*wMWz`0<" +@YӎE0%ΉVs{,mb/lQP=Z1yQB04-*QN&/ +::}`)?_aN+=+ofjS;o'ØA_mC<w=`u!j#aUolv ֹC!@@|ydXz??cFň|k OύK^<g2Ќ(Y+)y*? m2:J2r +3dX)`f9*?$Xs~�o:-+j(\!+X;v)WfHB2|#ݲ/ \!ȏCN"QR[ȷ#qCrO5][X!k F6IgsQ$or2|jPGXA~,r +ėy;'fJۭ6z)淙,cc8KUcXA5¹hG gtc<m:/SAS ΘD48_Yʯk%CXA$CL8ǟ!MשvmA 9"FL%|zj⪁E7xd@ov,l#?v;B i|Y, ֹ@CNq/7\oI#6G7<j/ɵ3߮+<(|b4H#2Y3xgfXs !ǜVofbTG(F,T^:ъ̿A8'l{$K&GFm!Q@[n?04:+9u+S۩_ׂ<s,[xیm뚨gsv{W"Xp~NUnMde%h~>\`Z|]g:*)ߋ 3Rs5.cmVq?3E%&?D_OMg_mET.n ꎮUж8 +(AFXK-&!{r vn;{QVOzӉ�.X9<C<{47YhjCXz4(uFb=7?Ku7z54}_)&('g|5y߈@t�1AJ,M!UVo62J}c`{%-r^4[kض3kx-X؂C\keRG۟nu7\d wQIv/gWʞێܶ3٬k15}d(\I7߿x^c)ی@H!;ku8m=tT7\K׌@=9m(璞_z^3᭠u wqnƘn#Rn'du!R%=| #h`?���5g����aCb ��� l@L���  3���^1~���6k &����†z ���@PP-;Xʕ.raploUs��� ݏNqAW+Sd^}^{rΫa?���5"͹1]'( ϸM~=[^aȱ4 Kpz HW\ }qc7<gTxci@9G>Wsl̜69d[dۛlty&~ȱ4 KS ~ ?`_?=K9ҁ!Ҁ<r, ?@hrejel2!DKߧ=H{?ҁ!Ҁ<r, ?@H-[N!DאּpnNJbw}}|Z?3YF7S|#gr~iF5Z Ǎ'% %qsnL/|+>%2t˽@ ZEyPtax@v + pıcduT4Y2g.@ B`A4ZѺ @(Z :} 80xN[~Ӻ�����@|ⷒ[N{u-@f{*jkXJ�����@\V"ju.bhf%^�����������������d(GbwGMuE+V,xM +9bȼi~}i[@ JUV[~ر^2 y Hէyfxf/)9=ߵ4/mb(-n1?[8k5֮w-r,.g&vAQ9'\~os{>ۺe �`akc +}qn':Ý2O'|>n5uk@ԉiGSTvikd>+ Ғm.|T<Ӈ)ZҺ 9~z STdC;vʎMS8hNгMcq瘍=Y [>jiȑ)]z|_녡qO^\T,Xȝ1\N[msmz2y+xz\~?.4HwncVgrƴ<w!Ӣofcqnk.e;\?h?bwc7esb +C?o}u1HEqHfy:ϯxJL4}^t0/sl\:HjiبpGRY'cXt3f>gԟ<G.N{͹1_1 e2AAZQow,!&q'3z[xo0R\6L9__2!(DN%943X\Z ڪӟFמ;\o^cmM^N[ť0N;cGM>ݐcVh\ɝ낑1XW&$S\ԏ&[Мf$93<7g�3X<i~3>0{숍]o..|{Zh11oLv9a|=ZY51HuZU=>IS.kp;6s>;;N 뷍u5cȱ8 + 'bVp,x$qgȱ8ОEz\E<-.^Z.N#lV]A# %FѮ9>7"{e%X2!ߜueHh@kvn5ub9'[uFšmfCicGlu~%E.|;Ptas顯crkFs|C +Z>#d#t$ndƁ@9ڂv^W?i7| r,NY)2Z̜i2ώ <pJ +~ݿVY�۝ePWf:H|+R2 -AP[,f͕TL6':N^5[*P=g5΅/ur.m89G3'M{?=Zo{-*/-,9_R*l{˟n]*5,Q#rӴ3A\Te׏5<Һ{gܬdFFԾwmN|1r|¬p7O0s.}';k?7x(7*DWaZ7b3mg9? uK>z쮵Y?Xqdߞӹ7n;ׯ͏ {gNwˉۺQnXmKf>k]99=DGkW\m!9'μ4{N4:c}\v2yKG;}FcС=&=H7.5ljqךӟm-_@yi +}G?59?[&,s}QP:b0cPVVgFZ|P˖'צR|7uf$-w5eB^++ + +_\]=qj;7Xpvmk uHIY]qr|wj۳`m]q㣸#xd5]VW}дp]*5hĶ]gu1W$3~GdK9zMsf{[܂M gBr1=:6/wN5Mq\P0qT0e׎^l{˥5<=G}?z}u⩖C?V~RXv2r#V.[kM9%\Yy#Gc���������������������������������������������������������������������������������������������������������������������������; �+= endstream endobj 19 0 obj <</BitsPerComponent 8/ColorSpace/DeviceCMYK/DecodeParms<</BitsPerComponent 4/Colors 4/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 50327/Name/X/SMask 266 0 R/Subtype/Image/Type/XObject/Width 800>>stream +Hkeg`E9iZEbPbtfQuZ҉2S3f[n{a*C?WE;zےz?=l},����������������������������������������������������������������������������������������������������������������������������������������������������������������VKܬm=:Þ=׬-��XPC=y]uoeLǦ靏nn,��8ά>-~ٽU> ��÷Qckj|"�� /:<Kv*E~;2kO?\[]]��|ݵ`|vlyiέ[Ύ>��ǽ=û|¿>SgO+��`>9Г3ln9U-euê7쳳u+o/lZc1Ƙ&iy_{w '<?th_{g˳\ߍ1cLړ6HEǦ\_}_th~I[93-MsMrرgc Rpy{/ϻ:;*2eg:s'geǕp*{H՛={Y1l\m۷ݐ Sy~gǕAUy&|cC?:~;kGzG+gqe2Pr}W{ώ+J+ǚ+}gv\9>; g}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$ �6}H� m3�@5"g�kD"��i׈D�Ҧ<�M_#y�HF$#sK\P JxlQ-̟͂5;7sViΘ55ά3jkd d'MΦMOM?1;glʸalMM8Y͘1٘�pJ?tWnMWgHzϰn#~cC_Gvo>Gus?~d#}?ogޯ>-+x_`~C|nh[^ػ=yw+9[}SKmƍ>Ф֯ztc7Yzhߢt=)�," +r(ୠTŪQ FM҈ h<@<(*˲,J(QL;Nәf845G])E4};<Osˍ &||'��w\ϑ".&Vǎuic9q'2$ט9e55N̎)Ĝi b^ 1F#Œ)9b_ eϘ7_dOu+eb]r>3˹iVm|wnӪպ^s {6|[d@&DFgP{,'Ͽ^~ba}ũsg̕V.+Idomtl'r8Wr9v5{{Am˽#}ŝ]!G r}mG�Kh 3WrGh,[".l{ZWcF5vS}=kCc뎑Gm qdzSo'7(3XйG[�@)B%|}EDp]q fG SSV z]BJq1"( ��-zM2|1%yھ반l]9vtVdp�z5h 33CR⧉=yƛ+ϭnk~1;.^DL#ܔ�00PٺuZpu r<v۳F]n;wUG�h�}  |�ޜ�,vdrz剼̕gW�kn9A[j*F{5رB\�O$: +'Nv|JM]F-OM�<} 3SK% "-)Yڼrr-M<:d��kd;sy?l}1xB,Q^T: �@=<4mOn9mC Q�jJ;,6/?-nJݹ V �Ȟ.mw &ܸVh<ϵ? 榋su�?؞V\S!;7VdΎW � սɞIKJ;ſϏ=<pd_QX}bnWO8]u,�@?=O3OXnn0߳6>J[ yy\S ~o-6W[: �'{ k\�<^:�tXw(^}ݵ?:gz//7&��@_d?=pyQׄ(1��SWc@ e�p;7U<n}WaQu�@e,g@S]U>FooqI]:�pĵ?٭X/jom|to?R�MUywoYf@+\vy�k4+ǎΒkG�ph񲣧?k~>>#P(s~x`|: +� zCWOc@ \" #P̠׫��p0eO3]Vv۳k)���`Gv^3 +ȹ|(fy\]V:���)+M4YʞVt'n]k^wDu&���e?}-?v+>l~:�ϕ<i8y�08z7;LsВcaձ�x ĶUg�- uvhI1e*ǙSU.L|y�f-OMsI~ts}ےas\^:hx>QkӄT�M*-(.{ghI1$m3+N-U g1D[6˗!�49Ng&ghIQZfiU >Bܷ6v~>>�8#ȿvlrKu4�ĨhUiApY�@+ zٞ|$H//0cUG0@ĆG��2m8g?[|r7Z}}|!]l���Qފ:B?߱xwl���љ=ѭw_Z8Vbl���3wnf@z{/g<Q ��`0b^߰?E=폵5F��0 svТu:$� `˗�IZR*ѱ?E=߂T/<&3"Zjc]u۵U[FcZjMDY.H"Ȫ`=03rXmm5ZMlfMy/f\a^{͛7of_z>�ow+^S= +�xW^þ#j?)(/~}SU{ 0P~_^cR= �x̷UXnدeGT=�vH3'4s�(+I/͎?`TcwOԕ.w5i`SG�P_bvKA4F?l!>t@#rcia�e¹=Q;89G6,^#'c W= +�tX|~rgJ""zw5sa+V�:*BG7^+'ܜgN>zF�ޯɤz�Њg +:"c*NR=#��^^ǞײF;5v1T ��`X<Xqs`:��$ės' N|DG߈6-[zN���*){ 02w!I]#U ��`T?[|\EOIKq</ɖzN���#)ѱ]Kfy5ET 8z!boQ�@S9KZ}zT=*�U[N޵sY�@5u >:}w?FRL]'T +@|sX}l�d\չoMݳ]ѴaDfc�mfpom^S= �ۧ?YC g0CŠg`,CU��Uz?'N'WԜzV�ߟYU�JouI8-+@gID$MlW|T pN$gfD�TrtǢÑ=# V=.�Y (H4ǫ;@3?G:Y1wqWL{|1�4Gc@g B{?9SjO���F C)|n?`$GZ9;)+U ��`7CFǞE?b++'T ��톋[q*>Ɩ@gil;qߍ/=zl���s8gA?I޷'P=:��W!Ws{&~/1GӊoD4~a1_��[~=1`;?䱜]C?z|�ӳ{w1c/U�LjЭkWM*)/?N彝vf50@#�0{?k/`U= +�YV{=IrFSnjoŎ?}li(]7' +9hߵ?,)s*ˬWCt}{pvzD�GG9I<z�hS]ĝQ숑O5 +S?N$/[>>=&lJ߽ၵKlߌ6Z/+]o<l'`tEＢz�hK~wGCp`Rw?7^ 4ܤ`WkML~yz{tk֚ߚƠ}T�mqg{s�^51EoS^8?ڎo??A�h=u %+{U�m!mнzvUWfv,uW[?c9qw<]�XnRbpUjs�kϽ!ަJE[lXشl{Zq%k엚y+Ƿ0ٓ8MӦ�[gYJ270dž %K98}ojAL}&%Ϝ8I�p_& +=#ﵢkay AߞjkaC^nmm/_|]_. ��A8edp_!vE9?lqi}𩼃Ǣ~oq޿JynY��zu{)>5h{ZC_wdrO?u1S_bf_x.sϠW',ggejoq ?��xz Q3_OگeGy{=@GdI}g9~}<,J…\ǼAQ��:@]7ñG]E:=^ް=z%<&s{+W8}T���(6Yo/ wOؚ@GTN{G@,~Ct}cs1_ԙqMpTD E<VѢ,Vq[ +b!1AQHnuZYZwJncNɉHr6ͼ3`}Ǚ3!X)����<4㈾=њ&G?lI޸ȑw?U +Kf}E����%5l +Oݹ`Ol^?V"L5�:m(��Bzгۣ1蜶=ٷ`OAԨU|YSW{m]/Q��l|vMsctڛloB@w`[UլQ?O'U9daekB�_aγ|bV[NeqDgw-s<'ܯS|P( �`v^S՜J$b�GonqDߜ.hK�䍋ݹ6nb_�lXT`*-.^��T{;ܰ%:veB=1W)-<^yB5n#}WWl2Ks��0t{&hi*c?? SQ[{|'BM+ [1GvF۫G�=oʌi7~�9MNeqDFݖAPLw�.ê/r,�н9,~Ֆߋ̱_??9T٠<S٨jM,9}m�aBH*} �KCKttIՁۋ�?g`T>3ˋjP@*���B=|S ~2n�{b`Sݻxv/j'���)$muڊ<sU'Tj*on8"c(���:w.7Oi7L1N�{c`]YѬQRJ%b_���ÄBb;U~ 3N�{bҾ3jYb_���Cq{hbTZ}術lA�f`(udDG����Pw 92KS'6VmٯS +Gf �tL*b� G2nC.\KR'Wvѓ}~XӾ?y~��lWQ~~&L&Q�HDždإ^;_fXO Z卵u6b?�Q ԩb�hx0}hFg= +flΑ#[)<}p_]'s��ۥ(_SV(9�Ϳ}{h.wql%(kG{>ۮϘAb? +�QNK`_?�v͸?np7QEYRV8gPuCٍ(+ub? �MN2}pXZZX��QEYVɫ8I 5HP�بkVGT5-RD� +'89#_;P:;5#xY5kTw󿼨ũ�蔨wYZ\G�;͛vQ]ߠ?�5ͦcջ*ׅ� �بMN(1�i:STHkO']oa7/T<~&����Oqas/cQ泦f`#����ʸ?O ia{ cl֪w/U~YBP^,s�&y2��]Mۃ*q{hb9F{v'1#qC}g E(mK4iև;ŗkxW'WWͩ\xh{bJWe0vgBRyqb0d4f<s%oΖ}=F/AwWfH")l$ +@C_SH)7(0i8 H0 +JA;2zE �G|=x}=Ǖ<]Ùd.2ʤ$bA'9ѰD)%D& L~RM̘6}�yR|ܰ;M,:tB'L/ܧ3瘚xg0LJ2Ͽt6x>M?S)I;9') =vf W)7/( ]$wXwY;TqA9>ϝ.ǝޗkڇ8ũ{j礚rK\!w;,ž879fmdܪ9mK4`&ʟF#r(*{ +E,L +b?gm7,=̈SԱc6 ᆞ? {D<i9/y Mn=ɭ y_Or7mHst $H<BeL#*F_&PQg~UvDܕAFAe(5QƥQjQC$ A#Fd&qiMbcm4hǴ='I&wg �3FsG^s޹OL|;A8cf8W^_~V3?$Jl)&Mu=t?8`bCt8zr͊"ND EL%aBa!a:|keW~AdЭOҘ.}QٹBL%OOx^z-#?<?}~_;^{5>Ltdc9v7l6(l{M +VwU棋WL7} w2Q)Q>?sg"(:N+DxnǦ,_̧1 nfmM+^N*+i8G)-ap\ +ǥ!p\iIlT$�H�$~ `8  !k4+|D]˼Cx/1x:jZɶ ?eobtCWTMT@gLGjIb!TB$DDLbD!&zP B 'Ӣic.DwC, +cM-&TmxFY�3+G01lw?ԛnH=y;/hT]2CZaZac+FG[M^De D*f~3:{s89ZG3d+Sw&Ng[bܽ1 ??RyG3SWi]&,Kk:t01D{3YۗySBqjƟO{ӀC/z(+9{A` (p8&aN k? ?$2U{UF @^p_h<#9Ǫ+k߳rbA +†p  ۦ5s#B &|b6P,VQ|PN IL?ڒl)=w+weM#2?- +iĽ*ZGlKPD +X:{s8m}M{A4b6@$zM[im#8E4J肇 y7P:;Iri֥Th9-ƶvAq?QPya˹}a"a{H8 YE75s0W'kǚK bhO%t{5m' +B{™:~pP8J=? th\UU_[?8C"4'xmh!  j7txxZC)͸KzMAfh7.=9 ?C(!shu1XO9t,9@)b#08U_yPd3{,sH2/aQߎwA?, z="N6[?b5ߪC reGo/rr@"aH#i-yjhB5E&]?mA=ƈgғ?8-yGKJvH˰^B?rPE@yw^kP.ӚY_/fJsE\-o%5<a + +xp ED"n/h?C7ӹO-ZpPG+wNglU_=әb*7c<bxQ̰pxQ?I+Uj?K'Tk"q -rg̱9z`�u�i53yCC/,oP +a=`#\hMD6#vOדPGGt5(nv'%<y815Y{ ;0abq*ϓoJ̚*_G +f{-;=9:"kjAPh$Or2y +Mh}s0 t 0+մ]Gt׈,:M%r:r]]p%plmnKô?eQOT^qY&[GbtHd[Vu(!3&U-k/ו)>yQsaI>M%_b?z6;k5ٮ ݨ:ڽW^PI|1'Q7"a!1?91&"" X)XiXHְI7"ED2 [Ѷ ]6kC϶- !^eG c>Gpә5RHS򏨬sy滯  G*ҬYn̚2E??zjpý;PF1}?d6_QQibI35=F\,,VWrU0DFv�QW$``8c'XN}}043 ;3>9_yc~sHz(n0FS N?v~/`mo> s ޅTK�F*xFXAJѰ `'DI2tvR5I*DL7zQڣmB.óc\_n'twRHks}ҫ.^݃1菧 q3;[^KN|^ڝ}*ؓ[p](6&?|N&rgRL: += v:܅k/Q pI U|LXoCVG 0zA_hϡ>((4DڀikCH՛DHL cI.?vQa<]GoIYbEOxw$59%pc*iM !04c!#Җ(  =Ռҭ]3~K(T*`?=�P94`}B>,~^+dꄝi񇱠?~(pVQx3 ݟw7BXۘ?^,<ODW00Ѩ1WȫM1vJ|}AҢo' %0:E684?Ove}scmcn`(R~Ż c`o˪3?}V\,(:QoJrq=TJյDLa JaM&fDksGwƠ?;kS2!?[RL`Y2'vwb_:2c#}AACA a(t?<AFi݉88PqwƠ?c{ qkҳ$v/RqUrQ&"JڕÙz[ @X?sFWJy!jN1GgKnw'Ơ?,,M]KmzbLPJoZ=Kx?*v\2h(3 @?p0]cc`}=w'Ơ?={cӵdzI#*7*~0_{ajYˋʯJm 2 t alG{.1WExCQɴ3;1afd8Gn2ڀ1Gs?-;y~\uLMz G8ԣ?{tOV݃8<?wR%C:޽@t4QkQ _B^ZOGU)e紞Ea7ۙ m2#){40آ?*awBX?y*ҚVƻcf_K}K53-{ l|TZ\eH[(~^srNb`qvJB*!5FC{FtyO*e~݁82@x'[9٩&OsK*;^ $w7Ơ?QQF2&mt"۝سA?4cF?4a ES_!P]QSu(wAX䥥V)eSǻZlG}k1wD۱ y`7nMa]hkвH@.:DS}hx hë :1aח }蝔Rfq iΞ2(sv VK/wEcò2!u䏶:]TJm|yu{PW-#?X\SC!i05%1rY<R&mz*ơo_mNv g`YU "$w?Ơ?#dxW1'}q?1yR%[>މ+H*#?4 m4XK4Nx4ۣRmL^TޝcI#̈.=46O}qJwkk.xc 1=}QgQ7oG$za/U\9H? �|44t! &c  ,2AX?LrRI y84jQHu ݨ}Y?XRJ>O=&'~A?#{0` G9,!9z>PwLX�MC Pg?"BC:ݲ$;ciS&d k{`qKR1o9{0wGƠ?E\]Xa}簰VWem$5pF zY$VC`+0_Ѓus86jQHu }Y?"}Xeҥs;20c=G[DpqϿ¶؂7Ԣé#4` "iA;ed]%x�<)[VI?p,mdѥ¶& {J~�Eqq� a FduJT2QSHk +<q-b@# +*pLLD2n<+fWGT`k7|_LJ5hO�ϛf%UfcO{O?Ap1v"]'hKfEaUbif;."Z:[c/<oD3o Jf <ق? $0ұ(.8pw͐K{'#{&i!GOz3_K:?iQh?oV7{W-'C?1fZ Yߒ +ʋ/c1:pNTe_]?jx ߍsM|03A{(Wc,dOLϾUWdo9Kɮ콇'C?lyڃ=mJJ%ak#JO3b_ /Lʪ=7=`1?=6Ch[G(3G*7m)ew%Om2??m[ .oKǢ=}=0+C==:ѿ乞y5~I.ٓZ}>5v5D 2=bL׭(R3"G + g8w%5"<\,\̷'W4T^n9F{W?,0|ݡnXyNB_|69>9')N?1Zs<Ç5c DyjMDĿc:KG{bވjWm0]m,$Q+/Ce\1/?na$+U)n<Tʮ6IHiGqGtMd1 b\QgMDvQ m}9GhUm;81KȝݹA{_?&LF=}^ĆvĩUpΧIl==^ȕG3b͆k zXef+Z!H@uD?#S{8ǵu{Ĥh_+ڝc WYX㸪 ?L w{-1vU~ҔS9~Ŋu4k?BiԉO?9et3?4F(i cE׏(?x-�A*Ew/)|Ig, j?D fbB?|#ae~jC{Ř=LCR~/#ƙv?`X?D5Jȿ=H{g?1)`}܋Ϭ [ڝ'v+ĤnG8xjQhۃ?U. AS0]u,$1 Ey%wޛ!c,:sCPI9H\ {+Trqhka >?AC&B+Ҿ\/v FLcoC]f!gci!)N(SO'd|jfFØAaK3=NbCK#dI\PnN7CWs=L{؁t^%BBKGAt  �?C=X8GeEG@K#d$Uo8 t?a*|{DH}GpXY?|]g�!{G;WʮfǏ##t)7V_+;C]4IjNǪ2hw)arD-:C!A?Z r +xdc`1\?NyX)q*wbJ0bKI|YVt~;hxſ#smoa(cZ%夾2sk]r5!67]hdqF?11hxc?bC,~}BƁ %Sӈnu n�{Q+p0l?.L_wBqY醇h G0?#q!&9!}}g'SӈBVeޟ!$(6$s#[Ujǫ7UߐiӀ?Z Ҡ1)"wGþ!0R)(8a'q)#?Hrת7` ?!`~{Oy@)=`*|a{H ^LG#c3 N +G4C@F)ĖM'c@8Gd+e׃r#?BJُCC�*e^N7dn#4kWD-z )f/?8IGx^펶<G{6oƌ+Q#?HbUE1^N{Eq#Y[iRiFYkIY 6hf45H?sjYꙍ_) sGw&Z0<=A!O1kٛ]{,VJK:FL'!e_vޣ!&c C`ۃ}FF B'-p}69󇧆?{:hH�?uW{E?.cw%6{i쯒 ?x8:8YUcR)u"h+e ^Ϩk,7 .(b@`N]nhm#)#dQzۯG9z{߯[TfH*râR85VpۻWu|<GAh-=Z6k!HaA/NWC?A<R:!<~@{l%6f{-xwi  bƣ/csi%_1 |衪9;b,H$՜?Bsqբ?1sw{rXtM v{D+No<"E5 8ҾKCg4G�c(s3'l}fҸzyzKDC%E5Ù7{ӹbaޝayC{ +ǷIQƢ>?`XAmXWRq(4�!#c)#C?{tG +vX HhuGkNs? +ƚCJq'RaiXǴߺgZli0Z]AEyUnsX#Je  b�8?4"ma?,xŖ?'Su +Ұ҉,H> ?5u͟d'O(,gZ: "V 5 +-zClsfkw(/ Ұꏵ'wNCӾSC#q\"A|ヅ=3 15M rU0%8CdذGWزGOq}$5;G RaiXW,tڨkҕsCMɲS{A28=Wcc%zA?KP _1Eaj=3 +JN= RaiXiFXswaC%})wELoaѦ?Z ]s + ui K=Hb@=QҰ+gBj?bߚ? $pRR;A?V>ڶT7Ž,AA6+6 rc?m_~0GP�oqXtG["S4opG߾: Kò?Hiy_ӾWCV�kn*/ ꃃ9+yCeq\e +GFWEA]ۼA:&u?*?K?ZN{Oaˏm!l5P?|0~QswCi>twGt}/&Ќ⛫ӗ$:?aaa.k{}2u {B0, wMo|Cn ?u/o\E}HY2]QTs=v3#QG]Vevcyf^ {mDSld.Ou)-\!w?`XARXeޟ&k!??>yEwԭL6͉ۖt{/hSe(菏У6D䏽 5 ;?Bgh"3-xQׂ_mWvQB E +Sߣ +(ZN׼_ CtT_J{HSǿ?#BG,hqXt&?<ӣިm +(9)g708?1%?؛%i[h9:ZAsxsc%zA  #=,Wg' raiO ;6pf`<F +zNpj/Ga9'r]oX\To7cwhQ?_EA{/Q?g MR?ӾcC%#YeeϾ\[}c; g +Ke)a xV/+Hi94JI_WM 1VѾgCC=zqjO{H,R/}iQWdS j?27GrS>rai䏑1A=Hil@_tDI(HlqEDh&fkґ2a?Ψ7"6; K$>-JДkna]8S1]1n8]Od 3OQQAtmiGAbVw\HnK2hyGai揹)jwmL8n?YvJC,sU*Jd?A'9w(-eN;" K4 <=|ewm?`K_Vt3(7;Ͷ}PUU1okf)?e)AQ�YE†N;" K4>NXg= 8}?T:v'q݊?:C%D&JF{v?Ó^Gj:k6sgQ?`X%cplTi]Ym?qm-?0]gfk{Eӱ7&Y?dǧ(tD?Q�t?Wq[>Ϻ4JiҊbyѾsCŲegc�d5J].[lh(ƪ-kdQPkJyȳ[  3sTĺ՘ +F[Yfn6m4aF2so L"^=zT<q�o}:C(h +F躺t3weO#"}+V[Se8_ysT?g:_P:zy XG2?G} O I#V +kN״+o8?c<ɫ}h+{տw._˗N$Go0I!Glo+QkeՁ?`<i?N!{ i!PBՊI﷫+oWYMK^TMj&G?LqeOA?g pAn ,oLI#fJQ}zUMn!D`<Iv㴮n(`yZ_Zg+>=ӈ?mdK`GcIJ?1+P0F_?xAxI#f? +Qb|Q??aG1c6-3Z_M{i,cyY +Vv6w#j?a2mdq) (A,x7&{tE!ԣVOZL{i?1C&egoX4⏥/$ϒsi5|%шifndG_%W+r_΢!IA,#WV:q1ArxwG1 ++AA''y\HCnw?`<i-Zfp=op?,؏cUwڳDQY2"kSVN,D;Z q(gADQGp?';F{i,G[QZ}>=#}]Ŭ>wRmǀUk 9:lǂQ /?YEG}i*KjaO .n_c}A]Z]b{j^j;$ cal/Atva0HŸ#Gp{E⊅6Q?gsh9,dewfO7 +SEb^؟|?<. 5}!G"~FX0܉0g8G1 +s/aos�NP2. I0+FmkW_>9C?71~zd%]btTwM)10ʜ^?ʝ$LA| +;M{iJZܭVc1>D.c!{<?8{a[ghʲiﰐ+dey$ !j֮?da"h!GGW8B=jݕ'Ch00Bm uKM{;e\3ma*@:4:{h)p?H(!e/B.?M)h� ņA`rT.1?UDȑ0cN5s}ôqt5g.4ַ:~P-riuF4?wDQU XB,.sobOA~g yN/+s'( G h2# sQ<{\;vf\5ȑ0 +BZS@&+0Bc$gΰ>yqgҡ/gq188cǃU Jҙҍ+N5)q%jW6 8$ a05Ě?L-{m\oYp[#_?HЧH0O{. !;EUco]qQ?Vն+n8y\l?_VBlJj43>fgȿq5JsGEґ!X2=Xxd#m|$?r  i*deyX(?`e&nr㙑^ۆl}CG$#cb.ʓ!Vŕ~@'乒Ph� }nXG?5{VJBGoLlza$;,02'ա5QK16_I4mS\+y\l?##< +5<)oWV4t݋ܯFĞ?ZlD7*07Hwr ?konL %+ۡ(ԭV~'/8\BUnJ!gr1(? @|[e^8#yI>9hPJXa~;h? ) ?$t-AGdRgϚzZ4{͞.{u5g'YHcP{Vg3$bRlMA峲ffȕF$AZlD a 8ꏩN ==HBO:=1VH?`=~Ϡ]iĉf: ]ho#Q^G'3iҔg7j1N}.K#cbu~�Eu?*-&&Y)i-LDG(MӉ&ƨѡJ u͂F UY\^<!>GPu6Q$dڙdfle7w{>/DO0>zWЬ#㋲ufSNQ:?JG,ߥ<d#Acy1zJ;2z<6 +U‹/L=vO;ɭ{~.R(Y^|WڔRMqG a}fkO.NGGT`鏧c폎腮d?:;z?`6..TNVbY6J>)I-78m$?|16PzGĐ Q`r]< ! @XkI(1 9i-Hk~c&lOڇLb}? ?Uz5zGƒ^V ڏ?lyH1l\]x,=>1B_K~.g}c\7!]!3ַCptH7*t4vwGhau?ȯ �8*(.wT?`xeΨL+0b}C PbAA_S͈Z)wIABPi q?jf"T/-k1xߠ2Vs4OꏐB}n*9`nj\_Aa3sa3H,cHF^޿NΩmυ|7H+ iQ2X<?|0VQ{2-6K%1$4tGh)(u?l4!?:gޕ&뽔s!-P`u|9;wwƺѓX勒[Et?Z VV\7?/ M OXZY{)0< Czszp)%y 4HG PbAA~? 7y~9VgT^?i*N-A4SQgBE9m띔{!yc +Z;1 cQ{ж޻dY X# s4yR4&I ]�0Gs K>_Y4JncV1c>Ư8W1~=|0VSilgJ]zyHmL]_|))BGjvWl\b詜Dֻ0< ñoou?`*qT>NA,3FEZC#}tAӞW|*6?;`HtCѲ[?? seJӀ?u(W'[y !~cpዱ'2crwsҗ@Uں 2:(cwtd0uN WUz pb߇uHkR1XEAySRPzyJgN7oFmHZp"ݨB?JE?d#|$Y@c]jTJxnDC~^-,nGnUwҞm{qM8z/AF ?l8x4—?z+|oڲ2<eJ Ӏ?V.~N`l_7;O?b/1~+V%z{)*\5&$HQ:x\Q?;~!#-c鏞U> {'g?%iC3MTi1SyFI`6)w'x!EjIe2bCuZ$rǜrkem>U6eJ +Ӏ?^>eEYo.c}C^XEAzYWRXzx,O7%qd1GOPBhc`sǑ[/{47)Y47#j%Tn%nGiSڔzxLm>襺D,![GR c,z芁z'|Zxz +{0< cx,ʊ4x#۝cj=x$;cRcCՒ)qv?Ϳ R2Xb[bO=F ڃ=MKBv;0< cx8>ond}C>Q{1;c/LczBnTN#|2*Þ!tZGE]Z]?SHPwf 5Ʋ9%i/Ś]el#7Z ]?Uvy@_odk<gM4E苚Ǟ1>GG$2Got5(c"M=G:rAhl{Xź ֻ0< c-O}m]?dw?kwb=|?"QT:>Z2jYGolxa3Z"(# @VX~4b]Sj1\7!]!񜥙1 co_==`2}Gzx. ]=>^&q}C§gΦV5g~Ab)Cn7$ߚWC?/YR:8ZYjW٨^ݵKZhbt-GEU JAN,j-%" xR+&M4%y#O:37o~51}p4۴"5tT 9,0ڃF^ 33%bП{D|Qhʰ,>X?: rW?X2/*O^فIj,5l=s8Jmzw&jj;w ҹ<M%Szn>=Xn#a#~Lgh.2jǣ?*55s9s% vmLa-?w?$Cs#y +Eq-QMڞs=: B²Í8(D~=l폞? +F4~Y C(ik`M_֖YC^&8]JU +R-3oo ۉA[B0큗\ѺWKxM#|d_GIms5 -?A˘+yy!Y#Y5{a�\FMn2ֻ8Jm8]˦*oyg a{x$}w۝y7O +\.Z(L0j ûܱ^|=~?j9g}2iRB% QGfh J?i}G#csAwʕ";t?G *^jGo?zkd h<rϫCYRB(iov@LW6XC>"y5 wʕ9ӽTk %`i'G"P?$E${Hk\vG?!RJ% >-QuW +73?Bݏ>Ry箅+"0JG +*X.'8?=h"i]Irkd<zt48J} o}ۚwҟ~H*5uO|\)tm3FuG dBݖQǵc/ a-i?@" ѥj+4>))a|<AUcL9ML?$c#s.">P,]rvU'ZDQ,PHZ(7G}~8/evF3 ]RR% ~-I }^XC?<Ioa6LeGi%!J,FQ@&) /V+ȽrfOy|#H=q!Wqaoo +#QҠ?kg@V\I],?$M?EfFz\YQ "0oY# pek6> +v?.jGG ߬9)-a߼ Iw87+FI~~0o#ҭfn.$tcUw085}p=} xRb% þ ZUqg.!,16b#iɬǕK3V5T`Gd>PRL# !wyy/=8J[P|({`ab闙zw\9l~;LQdi BH(Hr)8n99(5a ژcXrg sbd;ܻ랢*Ea"(G0d_K[q/s;f,滣8Jcژ7^$[YrK!i{޸rM<~&0ZG&)WDB) %F?x @9mސG{8Jcz~(5#->ƗsyLJ^A;y^>;f-0wY #\bhX]i]8HѦZ9ϹJ?XC(ik[v#PXr  {AaK٬󀭇wSW�%"0w[Gz'r{JTӵXrif" IpRAWYC(iky`M!KJYr ̏z_0эB`LRYM?r򰡾"+W~Hyњt678Jcۡۻ|_ֳn4mq%P߷ +^?J [{?EB$D˼?:O.ڕ3ዪ rKG4l$_y 1Oma +pZ]IB% ñݶ}P/l^U|r~`K[#G?B S?5f|J2hZsy1A H﵇? ey̶+QҠ?_G4 /vid'c#r] +�? iaC!_UXw?l�繌0׫XQҠ?%PZ67_Yr a{x$jAE7?zG׃.)pƊ?EVn }?vBd{Ϗǽ3,!v0w0lËJ%ٯ&4Od8[uTvәZvZWj3zjU\ţQ<*WECr�Cխ +긵 +hYۙo7iV"9H/uB8%Vƪ_rZ3"?pDsc4YТV=}ф?f`DD/ 1ÿcWGxCp]Stneap44&/xo=+` geOG 4.(M/բO+y׻V;Eq!-N)nrjsP"cVqsB/}<;tiQ֫?AWl? %sV�E;#|!G)h?p44f&~5,> %?bHV}A,4;z(>pƄ?M J,GU`B|-尛ѯ+<Eq!Y'-.iPp쳿"#v7FTFony徇)ă̤?Aj? 9ȗh?XkJfɓj ?r`?J=Ug%=᎑?h\iMa`8TZ#?(4*ݕ[A X2lw^tu? +`@uB`J7~p44ܼ#!N^{Xn> !?G+nTatܰgΘ>! b?!?,ߨ|=\~.폇UI5e*vƕ_HVv (xcoiN/^LPHvU0"t5txEP~ŀqBH{]#иҐ?Y?''4mfcj#gOt~aשNZAGRݯFq!%:|wi |SQjg�wJu+>HE,Ҭqsa{#иҐ?PXhڰ @?ksQЬjۣTQK"&_jO b?պy>t+o];}sg} uY. {)4;z(K<v�=)wakbv,-睘8}Tu~?/g!YQC׿GסEN]q<yGCA]ya-±-@p}H&׉]Co[AG \ +- +~Ͽ4j 6Q *)H+a'?h>UG%ԠUpz,2-@p}l}QV|)V/]~2VO{! +gkayw5'a9|(=EY,:V\` 8_PP'?q ?z؃u脦5A {SPYJ[ß͵GOİ4xmQ *%P[VK"wzyAR~aYP_ ?ؿhTv^>t&FdH1|v᏷Wן ҷ)CNZl_?3ɵͪkmkcme{k2&H1 =?z7P+Ryp?J=Li*{S4O2ΫcBF~#8o 6berM@pn7Ք^UT]Yf?qw{Sj펏)aC?c c<A?S7 ^4LiFl*rתr~u2uQz DžcxƄ(C {SSv"y[G bQȀ6)oP<uD5 ̳`{F�V9ZF<, @//$W|Ǝiw4UϪ$9yu E][%Mîʇw$. 8?pf�[[!YQC9eyCˀ3]Qf?g(K 4Q{Z7I/g{B 1V6?-~S޿)>ܝcg2vN#iϋfnضrU�1#Lc4~;Օ5*r\8 П'hw}#gsF׭EsAR4H0⏧Ƙ-oUBz&0Np(ữΖ.-fuN=;?h46fQRuqaڂ3呣zaћ]Um@pkiIM{}S֗P_]h iV (ZMĴ;叮�?^vG[$I?he2]83y!ZF ǭ.ǽYWz,=�{mS%@Wl )8[=?r=@qX[Z~Eq\*ƫԸI,7UFلDE#ELy +"CWE6VDAkf`n]4x! bĊ*7^̛~UFn>P?`2?*Iza93)>}*! Y!.V` ri/j[5]֙h3{  r2c x.w) C%rTG59Γ/ߧs54FW<I<6HC/ǹɡR{;h,6?^@Jv6=XH#Pρ?`4qXkilF�ڢ qE9w| :e/Xqztg#'t{QYmAnU{GA_3}I4s) C<%+s˨[I q]n͉Az竈0!R<6H!FGkh#j[+ +2~/Z<r_6@qA FJO eTvCp-x> +hAz7s>OE<(Fp<m?ZΌۃ`{ta.h\+CQV=!ʨg$my*, &Xh.P ]Mkaӏ%$e0ReKui+?j>]{ Q +cĽ`ǫvufuolsGGk>ŊC}Ҁ?W|QNjp/H{! B&aHCsݏh{ Kwhy2 m=HC׬(+̎%Ða?`45w%>3߻Wդ� 9+ ]ˉ0$\W5oX鏗 >%w6. AU:>T~Wyk:?n{,_?6[aȰ0R8)Ή7pi3?LOﮯ9,ɯ&ủzBA? EsQ[Дo2JjC9Cw:WAzw!HiЍ,ui3?LCJ=դw=tړ*·"P"zo>$ѱu @|w!Hi-IP8Οqg#I-$|v{ SDPww<{Ky3?K tɽM"PHiw+Q9i VYE GDUt8[qF[h?Ÿ0{?}5-c6|zM4?VjZB #Ku;+8n'i;?N)VWxT~_6O?NEnI a*92i7F +׆ Bz_Ҁ?Ŀ~GkIaUZ@̍Gz_!0:OW"G2bj:_jSjt~YiOL(<8}1 +?!r*ݹIa~p8/|/YUx-FQc+e1j{`Q>y,C+Uh`?`47o>b5u +.ݵ&[ +/|ZmScd8q]1[tWWd=8MeCeȦB"~_Uh`?`4i:G 0/$eI(dtkAIa?8HF1A^B ?5YU?&95]:ߠ.8m7Uwwx) C栜2ͩ*3m&y~A%K{gECzG!'ˎ|~A1`{h3-[`~SjXӯ Q+{B#HFtTҎ�?Vr\ މOهl?ϏY8dgx9,t7po3s ׄ#H'40Rt*櫎jn9s'iK?#vmIA!u L (2ov؃?T4GwtW&_.Qt اMu8a>w9!Dˬy޽&m ydgKtls !E kc{=ΤJ5YMKjI.NY&x3`}Ҁ?(;)or8iO?:\!w2]=1# 7 +4*jc ڙ׷-FKb+Qb,ޡUIFg˽ Ѐ?Q%Kwޮ-! 9~0 +o\J|'!f23k_?֍i` {4ih?^Y㵝$9uV6K9!˜/J e)dvxX}.B/Vֻw?~a[gJ}֌uI6}?HiLꦸJWdsZפ- +8Ԋ)hLK&? RPSw;~y*QC-LkMf[~PSw^B̽{<E/d6`Ԧ?{/9K_!wiA[6VF菍}a_|=:Qڐ ?,N{=IW-ґi-O~qPo[t{EM +ùzQgwϪ6FENYI߾"{="|^gf6;* +WGwY 3/{II85FrُPp?Vv^h?ߩw߈(?Vo2^k|afwO_ yE3MiC!Ue%J}}Aup75tϩPwJҦHVj[GڙTQѕg)/i h'6r,;)n+5zH_6mJiXxQo_0翻phJҧ.9%! IpDNM;wZ8<-Y߹l]3g׉m;XB!sFܧޟ +ӦLjkE.ë 7WOeZ2aF{t[u0q,m/c$75t];qA"?NM֟>lB6?s7I!o^k!}^85sFW<IZMm c.莘o_Z՗EvuAm/7H+ݾ}%U6rLNMG37x9Nk)1CnzOn0_̰h7˰jw~p+AuHP~HI$\Z <?pj:}ʨ,JX%)ǀ1'{׉ + z*x?]=-[{%c}Lp?ʙk6ʹhSSӤe(\\WO 1~|o)A]ws>GO){TI _o&{C *bﻵf=Ѫo>|k>֥?qG`o8ެآ;zk85^1U߼SK55x(zgH9%79[;pl?z?AS 9>?ܯU<ozSo ).reH?Gf7{}ǣ8;m +>,?ܯ!3ءÖ#yBm>Xm(\#RN^Qdl5IeOa5cR׺ۣ?a^ f7 CUz<rNNMgZ}sܜaR^ԋ/ ),٣xѹvoAB -ɜƢ\(I +FS +)_e#A=ۣ?F=? -ɦQ +97?ܷ7/`6QhO9S?揵l+Α?]!wQg2v6?d[Ļ?&=Y:}[{KzWȹ85ޭ/fo=@؜anRnb I-:{#%ʾs#<s;)nFOr~NMwֽtBc e$?\bۊQ|'yj$ȾA\}<]*)ܦr~NMٛ=V(?\_^*Q~[Bʍd<1Ha*,= 34zK&?/$XI +?\tv-8"O2+cVWٛ}#QgmB'Yl !@i[Wfܥ6u> ΍R~y|/NH߃A\㏛Bԋo$  8CRYHG؝ZQMFDz/),?؋ =^z?6?ЃF`5UkP%ݢMrlky`?t7{(w֘LDS{k +=,!l*('f$nw{3H c4rj Խ>Fg $i \i-Bpl ׉dh~eA\Q�dj*WyDtzu?㛈uA(L-,q{AW(bjWlïG{P򢥃s?-{AUV}BIZ(ϵoČ +r#A6BSի;Qμ9pSp Vr?pj:=z5믤 <n)B/"go^51G#YvB@v_A鏯w'̱q ɷSB +_lCY(5~\C亥 ?K;]>xOnN?=+ P[_=GunRD(ZW[Q 7!<d $AG=k*B#<=ۿ۞|Ycc0y~꽹YCǍ+ }⌷[`S Cߋ(nU:k^C0i7ۋ#Cxh䑄cxJqE ^?4V*ALoU*Mxgl \Ap[yV<tZz~ O{yc+ǏIK.T/l=?0mLn(Dˆ]N;$HM^e>Hk>s:QLudWb;/'HiFc_ga qME% +V7Abx1R,M?d$\VFF%e^u0iy>ۋC>I)KDo#9l?D+\L[wuj7yp .F~RehĉE?Kˋt<Ix|=qa='EEt}ང qc'krO`;'TKښ*q膍DB7Z츸YC@,帪f7HOD`?luE"۹9#GǬ9/z&<JR\@ UEvo\V)fļ컆< O;T?Rf _==w5(ѝ\@m¤iWDͰ1qCd3_۠`G8;9Y1T?§ 1N<<h^4%??U5ъn(� ZTTwǚ{,2쯎Av#p'0hOJ3^n-Pk77/7%Kt hc}V;B̼F5L+T~y&>!b˕%ik 3X[^e{Ryi֐wSV[|MY?7TfkGz}4GUՙ!M-=upA;7H2~max͝ػy%L8\prt|nueW :?čuO7T2e8PyI:fbPaTS) Xx:9S?6m ɨ&Z_[Qƺ+d?h�iʒ=0(*Ne.N9#oÚZiLCВyFVKYH4s9߆1>A inl#(򫚐3%m3M>p8:ur߶ꗿZzMkKcRy]_pp-xt׳:ppC3u j~"qy8DQxi}N*Ui P~�1"$Yµo)从4hj[pqRțw#5j%Ep!Zʮε ?g*2i\-V~$'>9QW]Rqrtx_.X k38kȲ0&}2Kjv1N(K6ӊ)!>byy,!s~M Pgr 5voƯ7)MÀik[pNFz~T! _;mMb qD#>sGl \U/I?aܮP'8Ձ;b|cʼnlΫ]hɑ{*3c g{|:ϧ(k0I-ݞ`i_82X8Q4Vtw'P6MuB;nZԒ*5-:K:@4՗v +pxG]!3 Ϫ c Rf<3Gl  Ƥ Ԕ͔zVIB7lxp&˦z#B +}-N zar]mH'fZѓ*噷 *L +cl:;X.aMyZSUxAyW$Ϭ{/=<נ24M:K:&|`5 aHx|&FzCרD"O,S8OxTTVFl { +.7q c!xx_X'Jt&c|8% +5o*fxApQpkjkՍ5IO qDqvTWKg|Y6ݔ`7g0g^k[8z}&>.eۇ?jqwodg9&!$?Udں`dY#=U[ozNFʹ']U3on�cl:;eNk +H-f^3u nbZ~H+ +`?uY\Y 9f=F>fAz/[ +oR$1tƸcK3b`Sp?ƭ#Fdf/(37bHd-㮫ԬhuE#ʥ:9`GD4&jUAT%$UTu3;f +=W~^{~?T&כhPTsE8\"׵_*e<\cvV.gJC \ۧ<0f$l$;lœcsi Qכky>8]K'>N֛KMBxua$fgh5٨  bCW>EX93+y|UO@Vh2ku^Wfo~<;�xxG1="!i5 L2߁Zܤ{*r4"DLSb=)v} )@M7ȷyK Hp93 <}7+ނ7Ŏv-#jM &$>ILx>m ҏ}\UJ5; +˳T;x?snz|zkOXp8{sHCI<y2/{� I?:BO /2Æ][CJ1P1<ߪLXȝ_5! m|b)2ع_VYUa:{MgΪ!)i)\ ^(S'}1܇sDx# UgL+͐SWϗ+yYU_6/si+y3O>zc m;[vJvbwJ5dvػGj9CmK}kWU- ~oG-"LiDԳ"k/-xk?I{r |AAWX0ƵOPY8!:jQN${]!//5@s+j?y>bq_Bԩ`*>G9qPsVY.;R=ܭDܼ?zjZ+^D'~?'=ΒcE'" ?0H(v4+ GCp& ӤO=4:^_Ez/0fuD/R;Mԣu<\wb!h|k/jԵm-k-#|2ԽTF]"CJoZ@TUn-pC-,;C?j22eA{H?iD՜COʃGiug?ԫ9y.`�q#زoۭ#ӓ,p|صCo"+2g?<? 7ڣٳŮ8f("pvTēoiDy4kH )`QX0*yճ]+Ae) sJ>_cX\"ϦS,<7R֟7?ol5~Azgw7kB j"wb &R?F^ɻ\nRE1V9?/:j;T<�Vl)8mC>`:ԝC'@xdU]sqeouSsBp!I1Co7='v!Gp&F>{vO^^ɵ}dcl4>s^X'c^sq ##gX>ks!vi!P3GĈW,ӊ,iXӟc?97Qcj +]y)Qa'q58m&EĮ"}?0?YU4i#/vunozP4qW[5țBo5(vsk5 ]csBq`Iq +sGgLs3=> m5m-Ϫgvْ@ ԸP]#+2gd9mp>\_k"o999If'v3+lzԯ<7},fz63ȳ+r;*Kyt]F^αg/ʊcVW<3k[ w@-&5u`'< c Vw􏘶Ǡ.ceD!yH߻OGk\▚j(U۽"^D`H)~5ˢMum_&�g=Eu,yGgirj>Ȕl ӤO>^/r QNY[< +{-wxUN8.JBi>@ؔi;}k괟e0M?1*3 ;ƟخOsfmbZ>Qp˙DZy.Sd,wn+&+yr92L{h*ҏ6+޲Zk{smF^t|PY8?v,1/g >Y +FJ>( /J5UԱȤ;fm4X#bQ!GMX囜 C۽-ǨRcgG'u#}0kP{r =?ҩO?�Woe&rw“HŚ L[%(g#EN(xWFﾕ.s!x?H()?|"Ԭzj9!E S3bXSpBȽ +np7TNܢ6͊]9r u>O; _?~Talql±SGfraO)5h9ȃk%NSCZB^𬝼sr򣼅/?7x^El\ཋ h:47p + 1To@x{.ѽ4]5r?@ڑ~<A>T,FĝR3/aH}T^<6ixj?YqwSrƒm4u/DޏUkFӨb XlKu>V=Yhami:97 +C4sΨlcR>6)~(jw;Cˏ^`YIqp|W@xZҩN7a3 5cr?@]CX/οw2#Nd.^fu9RTf@p�_KۅFyǀq paˉup~wypO8cɢ�i%oG c;AUX44:L<8D [_*zx,pu-Unk +> bҬcN/OT�*5󠦃&._#IPiz,ڌSW ςY p7GPbq~e~CxEzԽ+ +!SsqLG6+j GD+7z^PS6|n6O?bwK1mǓ'_(bC8.{C87/aHVmH;M ω DNS<>O ;MUg lw!h@Zc:πy p7�_T[uobHml,[#mwNQ[N; vPKH*6b  +ߥ?}h?Vn3+v%9Kl{:eŃ! .۔-o³ơ-謥igYKUh9[mfi_J'x&?H()?rZԸ<_26q-J5?Rq&?13fţvP灓IGUX|~~Bcsܫ;:]KȁH}d<)X_?<;.Qp'�ry;877>gh`y@ml,˦kbK]py(ReÑV + J +w˓@=(u|Xvz:Z(XƷXkqSp46M{xad݊{VW蜦6Fĝsj.ި~vd453&CvPhFg [_B?`^vpX<.-fTJ*^:qە{Տidp/fRC?`u^sgCcZrduUcܖcg#wi:COeq |5:L;:ZZ,;QLz=M2^cnh꾐Q /̭}~7aSX_AmkbXȜQr[V}'Q CTхq_vhzO;u]UA}L~J@{bǷr$3R@k]lR_%ך@ ABI ˡΝ\Ƌ{|`aݓM ETr(NF?6*?"};ckO Te V|F7[|zL �?H()?f"lL<9Mm{Ci$T; 87%eX"~U7Ռ.Su'ƋBFw3OQbc!a`H5&�$σY+MvS4uci DxOT�*՗0~[ώ$E]ཾp~ÂsS>$?H()<?^?f4=hfZ;9N5c),XFu%ƛdS:x/k"mCW.`Gu% d ?N6{q\DMFSC9LjJkJ 7^kTMM-4! G}嬝f#RPR ;K3vx53vyӳ>Hq1-?>-zkI ο嬾hiD? +Z4mmPK>.Z ABIA0u6vM+qԤ16fߎW-[ +,+"-ݻ{" Vęft&Ìj@ +g3#{ӣ|k%\t5GCpe]URY| !iik-gsB "):I 5p(?�O @wqUZ&ܰڄ;[ynilB匟o$vIFfSM):XH(VX|av>IН}8W5c_W%ٍNIw0_3Gvjx"Gi &^fy#!A4?�O @wsr2rܜC6ZYQJX)˛S5{> +BVH}Jb?Td ݥ]HϏs~$=OXtGXL‹Os76H7rGTວz d34zAF>-/ٖZ'}5p"�@(_U-<Hf?bh//Lz] TEҾr +!8Qhmk`.>'?;H)t5c_Wc?zaz PiѫhыE2wI**fd>'? NZFK;.?WJ$w`1PiҾ8!l4zoG-lz\ +9z- |^?�O @^3΁߼E@Ntm,Gt$qUc^3!r 5P8g-mқo +$mGEzUֹ΃z D�<ys*z*tJvvso Ju~1+?7Jbpwʕ!b^x8E˓U\asC"D�<ytΑ (im;-ƞۿ{w"ϛ?VͲtP!ܤ-څ70^E/OGN`rrYd;i;EŔl2g畗 `(?�O @]xlAݩ%ZZcoeErӲjYW]ۄ;3Vyd|yRRI&tDGfb{B/,w &H۴^M&3J:'w- )Lb5EEx/cn=3%!_5;Zc7}hZ>/gi?LMY$%/QU;d3G6Ogx5ā,*>Ӫ>Y I?�O<Y֒=Ra|dKkifJҎkY3Kp/c hI4 GvA5BiKb` /i/YH4 ����@`^<z����P6�O���� 5g�����ey ����@`^<z����P6�O���� 5g�����ey (̞K3aբlО?kP�����P"%ˡ-$=[_zug�����y (uf?T&Pס=70`=3`=ggk@f 34բuPϞz{�# 3>3x}Ƽg䅳i~SI쎝c%+>$wPϞ~{`{ �N::ϕ7]ywOL'ct s`=3`=4|njKB؞lΰd۪դtA}4=3>3@�Jb{ h3\1Z7y F塾kwfZӐ_¼b!b3F6�F!Kc\Se5.GskuzXB!Pҹ �P/]3<z z9L8A;k6B!TtN�P +md4a#KsjB������GMA2W.$;Z\x1������b9?7dRgkGof}_����������������������>$pjQ:K[IQʟ.b}[9KNN5f_4 W$}A^wtb=Qk6ޢ-N;єG3`Λ$XegoWuSfpڷދ=vO#4]{|d +n\[Ert+vhK5߇?O,E)&ECۙ3(- tOy/x +LzIVJڶݛֽ9tuxz ?^]BgJ}>IR)4�:)u QTD`8ֈ:*:MP3T@[QTRB"RT&D UXaYvawQQс?ut2it:55R+*+=yϞ{3`ܭ=q|сmYp٧)V'2]SgYٺw6^h>*k[yd[$OYuߵHgG};}!ڽު?jߝE}#cښ(ݳ/9fVs!ެ G)3¦i,|SIGS{wNS)|-l9o\v_Ɗ12=WM׻Lv=S E M6˝`adLzS5 =^+l[Hzfaj`O8&{&6ײ׹[:/ۚ =S!&R_^d{T'_9w-y[xChѣt-G3J|d!+d "u:.%Upƪ4o 2V cEADn|&cD*qQ=ɿ%?}vc}٩$HLҲNܥ֖}:g?n9):v4D'f{sC8mٮF]c[ݞ,-S#dϖHѲ&cxleT]}GƾxgnjGֆtzxeR۳YzZ<o%*_TmٟmʉCo=ߘ!cV<YQھvxw^7x'xvFg>-*) Չ &Vǥ21ʺT?\S9#l9ԳGHE n+Hr1A^=GQ=urO'f{sC8m_;]獺01?y=SYZ+@'9޴v 12Nƾ+m}C%>ݔ] ʤdMՕ6]T^!{L'fu|]JeJFY cQB\1V[yJ< 媩U򊏎wdld͙fhxgn@̫\V+a!!ʊ$-nǥ֖}:/TYZ+yj` ïTkA~˚==Ka"lWS\- Eˠ+'n9zKIX9d{ wE =On^*]y5\sh|HP"{#%1təTo x~!GCL'rnw v z6 O%{)˴r<Z(ԽsO^aanc)SiP@6FƓ[DhuZ뚹|kh5Jk=u6˝`al(˖{/xL7KY12?1UWf,-J_w>x0B&r1Tgʽ\S9s"g(v77rwNLVcˬEfG歊DƓI g + #!kz.琒=ydJuvF%/P^[}yqq˙[ub|-wѝ;~lY1#$@ݣYŶ ˽]^!9<~uȼq^k"¼X9C&c+d<9kTP}/uX1UinsHLR.{A?3`Bx2g +uߓ;m,-.j\2�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������x9W�+ endstream endobj 266 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4243/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HnDaK3KY\M8<@rX ˿~I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$醶wt +6C:iHt}"}etvC6CvC6CvCi?9>~NhoXv?CchodO>c[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[;̼G8qt'_q_(XwUE)Hg 8P0$~̇RbG_ҡO'jP!yr_9_e[>~yUuC1b[>H o9܇!>xcG͞{'![k}h~FfϽst|d>>*34z׿լ=GNh%Zd~"<[_)'@.tdSy!92<kD8~@GX_2S\Zfj\Zfj\Zfj\ږ{'th簉yB{'th'iB{˘%thIB2HYjy,cԝVԝVԝVԝVԝmg3,6d6rؙJN;Yɩbg|6;9S̶YɉrW|2+9Qrf'rW|6;9"+9![>+< +}HǼ!ڼUY  uYy벖ۼOy+Z>_Z~X},Z~yҡtuskG^~[+X˫y/(q]/q%ԸK"}$jmym=G\V꒧G\VʾZVJ&BRBJ|H ׻cgƂc3Y%j35!U%j>^:Uުyn}=e6+tzlv2}e2+dRydH{dV2٢[1Yɀ>ɬdZZ5Y*Ş3|kA-G{ZmO߼'A"-7$rsAy/h5yE6zkEyOFXoLG<ޘ*9Rޛ沑C n#+niMyF8%F8{\%}$K.i>-9$^9'Zu?=+ݢKC>NkSE뚻x5w< &VmkvZ=Z@[XWwuNڢɬ2ڠ?ԑ˚Y_`QCVC!tIoAƯН|.l~!pMutaS sх-0^.lV=E.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=l]j]T-u.{҅vC>Bnއ.! 1އ0x }.GyO'*]Za?fmKݰK֥fῂ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=h[]}T,N{~!�;q!�q!�#*J-a'IxO|JIMG0l.LIVG%R;죒ev/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls7)]ZAW?!)]ZAg?!)]ZAg?1)ܗzAw?-!:A!:CϿ4zv Cz"WpIkQs! J )+W?̿+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=2دơ h&Br7OuXtuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]Kq [kNi K[ҁ +n*տ*i]ԉ6ܼQ;iK6Cl?xwӪhZj6Ӧl\*'T{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUT{LUVYkZk+5صw֚Vڊ;kM+vmŝZӊ][qgiŮִH׶vXk!]o7WWdG<*!?R [np#}lO>*&#pm?/~{9mx_r>4=ka_oEv-t<C$o3g>w Ϗ>|]Zq-?gN^&?j<79SS߭y 䀹]8.{}lTM<}|ǷWCczI6}ӹ}.K}<^LJ\|Wч8e|hˍ<>yާO~8虹?ܚ3O ~+d2N ϏY$I$I$I$I$I$I$I$I$I$I$I$I$I$I$IR? �wq endstream endobj 265 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4237/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrGDQOφPk޵9Ya/I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$BzK!4sw+!s8u9Q9Q9nuwGOϿr͟rw?-}~tއt.qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk)qk|ZI}\7{0.>._$~̥ZOCMb[?Go#$f~?qt#qkG'22>}Q2_FG8|nq`b?GWl{/OJ㗿0BJ>Dٚqq֏_'hf6QHRY# =%,9J9J9J9X<S =mLYzۘ&si籎Y2z"$sig92z* "siGf쩬cСVСVСVСVСVСJYj,Rw{>[yԝV^)ugJYjRwv_Z^&vfYllebg\Ibg\Ibgv&Wܕ&Wܕ&W#weؖͼ-y#/6#xdװy;gy;gy[9G^Ul)އtNއtmsyNGsс\}t`;G sN˹f˿\#2vsA> XM]&@!WºF>A"}$A }hm=G%OџbwݲR5YͰoRMg,g3þUF}AQq3�t2c澃`33jC63lU GK�3tTy5,f@{MuS-<TަvzB{EMj ׈עzp͞<٠6{ +f9K˹{+n`/vnY^N0޶{ +rf9mvsAy/ZZN췦^|o5' ߘ̆cIl8&1vҎoc- )QB8%C/Fl-}\d-_m{4rf!yl{i>tbϲ&#M;6۴i][IٵcikZԉ#Ϸm3gSg}=q^Eն>Bѻ{ļ/26f}78}#wЊ</5轼ɂŘdB>ݤ�^#WӼ¬ Ɣm~x)j+/ϲ]ʌ>,9ZޞY&]+^ߝZze/M:GϽ.Ls/ S+ +=wIٺ :AwQѶ !)C�vC/+]Za?Ozx }.! 1އ0IyxZ҅vcmvcutWЅzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z>>)ږA?>*Ya?#}@]]~&RK <5MR&5_ejRS IVُIVJvJv_@V蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z^FV蹗хzetaj{]Z>3)]ZAW?&)]ZAg?&)]ZAg?6)ܗzAw?wLCtCt/_lKsG0KV*5\Uj0}!:+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20?`q(h=ı\(Sݳ@ .CB=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*tct`B=F*t/9ƥ2l96l/9oI*XvIdXVdXV;[>vrR'sp>Da; 7C.ټQ_}hKNi kNq ZS1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0U[qgiŮִbVYkZk+5صw֚Vڊ;kM+vmŝZ"]mTcmއktGG^>_ȫLJ\K'l=^}lHJe|}< >AͿ-U)K<I_C:̜U2x??)wkY?ǵ ާ_yj;=zxE OM=~ގ_gw ~߆"}ܿ2Q5-a^~S`}^&ykTS>ǻ:OB/,ux]rs>]َfGT7-7bc:S3;ws1>x>8gJC7sko/<5_ ~~;5x??~fI$I$I$I$I$I$I$I$I$I$I$I$I$I$I$Ie0�kƢ endstream endobj 264 0 obj <</BitsPerComponent 8/ColorSpace/DeviceGray/DecodeParms<</BitsPerComponent 4/Colors 1/Columns 800>>/Filter/FlateDecode/Height 600/Intent/RelativeColorimetric/Length 4306/Name/X/Subtype/Image/Type/XObject/Width 800>>stream +HrHDƆMP"}{6bfTv2+?I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$]N!]}H[< iۯD~%m>mO^Y"N.! +;]͟qNh/Xv?Cch/dO>m[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[K̬L[̼?qu 5'=hįO* Db_0_Bb撗AX|bCL$vߨAO +-/S2MN_ekみL#ca}>4[ּ!2,U 4oAo1QF[0I&/dZ#'$FRZdh%Zdh%Zdh%Zdh%Zy2z9Q2Sa3g\Zf9lLKL=՜(siKf9<C =՜&thg-4,vsСƞnN:J:%4,5,5,5,5\sTRsOe?lI >;3Q3 >;SYA3 > ;%6TtHreAG,7\s}Hۼi#/B,# އ>}`IY,#7Y'.,GTxmRш->gIeއi>Mއ6-އN_w?-UkItT?LgIz~@ ׵N%m\ ŭF>fG;E+HxˎIޖ9;'y[o#+#yZ~]٫eL_W^+dYIza= ~.,>V9ߡژU®1sߡ QZU¬GKHJK没7:GSmۛFOʂLeA[L*;e* >3lxn,5CXk}#5½Tޢ:GsD٠n)oP7{`#=B0==Bud=n7=h&yӚ݃f'#E3Ytd?+?)>i"Yn[kOz7Md;;IS$D{(V-tG}dOִȞ'+e#jdɹg^ud('?xw~v>p]9+GM|OE(z= vuz(/J57{hz /OY7;|W_s+a.; wJtq_.J#d]5640þ]!?a߄й?yQ_.Y?sQ+ ջ[IgP3eAgNwAe+Xc4bC)YhЊӰ%1][aH=3]ndD*ɍVn}\KO ս?~\vK}Ux*ڞYt!އ6t]K:c.^.O)C5t3+ߨ'wqM絧{pag5n[NkN=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.LsamKݠg,K+}@~!�C�v[*J-a's‡LMj +<7>ejRSIV﵎IVﶎJvﲎJv.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20BϽ.Ls/ S+ +=20B}I +҅t=$ S+zL +^+!:CtV?/i4 6~>D `ۛsQs!𔕫J )+Wǿ' +=20BϽ.Ls/ S+ +=20BϽ.Ls/ دơ h&Br7OuXtI1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0US1:0U~qU6.aiU4-ayK:0UZ-OWW%RW%R9-x+:wӆ! +{9mywp}VC_rZMKm_sڔKeuс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]uс +]؊;kM+vmŝZӊ][qgiŮִbVYkZk+5صw֚vnktm>Xk-?>?*}LG^>>UG^>?a .䏽r GxcGW/c; Knއgp! kmȮҴNYyH$a箒чO ߀_269e>6S+GM&|j50v:8kU6|eo1'jt;}} _c2@^ަ>b=!5>~:eK~v4;0Ͻmӑ'>z9߱w8;>~?=3Ww8=[3xSyo\f۩3K$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I*G� endstream endobj 5 0 obj <</BaseFont/QQVHAF+MyriadPro-Regular/Encoding/WinAnsiEncoding/FirstChar 32/FontDescriptor 267 0 R/LastChar 116/Subtype/Type1/Type/Font/Widths[212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 513 513 513 513 513 0 513 513 513 0 0 0 0 596 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234 0 0 0 834 555 0 0 0 0 396 331]>> endobj 267 0 obj <</Ascent 952/CapHeight 674/CharSet(/space/zero/one/two/three/four/six/seven/eight/equal/i/m/n/s/t)/Descent -250/Flags 32/FontBBox[-157 -250 1126 952]/FontFamily(Myriad Pro)/FontFile3 268 0 R/FontName/QQVHAF+MyriadPro-Regular/FontStretch/Normal/FontWeight 400/ItalicAngle 0/StemV 88/Type/FontDescriptor/XHeight 484>> endobj 268 0 obj <</Filter/FlateDecode/Length 1457/Subtype/Type1C>>stream +H|RkLWat;]:3UhD@ +R^Z|@* ՊMZY[(S &ԊVAEhHI;I_ͽ99=88>gӦkm8(5xnOjFp9QEwW-A_';08;B9udg_a} +~h t|AIhC BAИtZO~MB?%aQ'9T덼NoګxܣN˛VG?pIoI;PIz4$boHM2 z+(2`嵺K錽넱aq, +fHc6bkFq:u;*eh_⒝*;,'!u2(&`D<jg(;;C 0)19g51(AB@ӑCͣh:*+Aܹ/?f7E>H7w�oxK +!mx]M?J0VЊhqnVl_#== +\/&4iNbQ^Ry[jcU+-傂-<>|s0:2NO40iwMVx eu[\Ǝ^hA˖*Z/kvl T bBZHzbxHE96l.n qn4-.2b3DAC6c`,8wyN.(Q*:{ c2grYjvf +wlݾ-[]Bb?@(`a 8+(O.JI`H `}w<l Zd`<<^+knW Gzzn_=_x)dp?Bu>bK)UuWlQQ,)Ch+9Cc"C3^=�Qtͥ]7CaQ>糴5*Ҫg&ٝi<knj5x{J6GU[EGVvYY9T]ޅ7E21]O(mɗKHp M<~@Zo +f_Xj+-J-B;@rn#LZ' 37T=Q2mTq%m*\]s]b}7h +ݑp45M?~EvE7Աq;$ݒ9@xsv2l ouM%-W;TO.p5G%WzL9{n} .0-GU@tl g**ۮ:-[z(I+Q m?wXQJL߹lq2+/̰Ƨ>=:yB,Y�PtqeɬH.HQs3A +pNB[�^-v)R GvC[336ݖxz10�ϰZ endstream endobj 7 0 obj [6 0 R] endobj 269 0 obj <</CreationDate(D:20170110155113Z)/Creator(Adobe Illustrator CS5)/ModDate(D:20170110155113Z)/Producer(Adobe PDF library 9.90)/Title(Fig_WAD_TC6)>> endobj xref 0 270 0000000000 65535 f +0000000016 00000 n +0000000144 00000 n +0000061973 00000 n +0000000000 00000 f +0000896365 00000 n +0000206222 00000 n +0000898602 00000 n +0000062030 00000 n +0000062501 00000 n +0000733933 00000 n +0000734597 00000 n +0000206521 00000 n +0000206408 00000 n +0000064179 00000 n +0000105077 00000 n +0000149651 00000 n +0000735418 00000 n +0000783004 00000 n +0000832234 00000 n +0000734663 00000 n +0000062898 00000 n +0000063238 00000 n +0000063304 00000 n +0000063618 00000 n +0000063666 00000 n +0000205481 00000 n +0000200848 00000 n +0000196353 00000 n +0000206292 00000 n +0000206323 00000 n +0000206589 00000 n +0000212992 00000 n +0000214060 00000 n +0000226752 00000 n +0000241085 00000 n +0000243190 00000 n +0000245694 00000 n +0000247966 00000 n +0000250040 00000 n +0000252341 00000 n +0000254530 00000 n +0000256964 00000 n +0000258899 00000 n +0000263105 00000 n +0000267209 00000 n +0000281902 00000 n +0000283792 00000 n +0000284641 00000 n +0000286961 00000 n +0000287118 00000 n +0000287275 00000 n +0000287785 00000 n +0000288533 00000 n +0000289437 00000 n +0000290095 00000 n +0000290752 00000 n +0000292379 00000 n +0000293046 00000 n +0000293947 00000 n +0000294104 00000 n +0000294261 00000 n +0000294889 00000 n +0000295312 00000 n +0000295585 00000 n +0000296925 00000 n +0000297945 00000 n +0000298964 00000 n +0000299121 00000 n +0000300202 00000 n +0000301859 00000 n +0000303248 00000 n +0000306925 00000 n +0000310089 00000 n +0000312535 00000 n +0000314900 00000 n +0000317312 00000 n +0000319864 00000 n +0000322134 00000 n +0000322635 00000 n +0000324937 00000 n +0000327314 00000 n +0000329545 00000 n +0000331927 00000 n +0000334536 00000 n +0000338194 00000 n +0000342188 00000 n +0000343593 00000 n +0000345527 00000 n +0000346695 00000 n +0000347232 00000 n +0000347389 00000 n +0000347628 00000 n +0000348310 00000 n +0000349073 00000 n +0000349914 00000 n +0000350571 00000 n +0000351272 00000 n +0000352084 00000 n +0000352644 00000 n +0000352801 00000 n +0000353074 00000 n +0000353232 00000 n +0000354015 00000 n +0000354290 00000 n +0000354560 00000 n +0000356258 00000 n +0000357194 00000 n +0000358249 00000 n +0000359530 00000 n +0000361095 00000 n +0000363529 00000 n +0000364087 00000 n +0000367351 00000 n +0000370468 00000 n +0000373218 00000 n +0000375890 00000 n +0000378746 00000 n +0000381181 00000 n +0000383740 00000 n +0000386092 00000 n +0000388928 00000 n +0000391549 00000 n +0000392477 00000 n +0000394423 00000 n +0000398107 00000 n +0000402078 00000 n +0000404645 00000 n +0000405672 00000 n +0000408096 00000 n +0000408254 00000 n +0000408412 00000 n +0000408815 00000 n +0000409549 00000 n +0000410489 00000 n +0000411340 00000 n +0000412027 00000 n +0000412689 00000 n +0000413357 00000 n +0000414087 00000 n +0000414518 00000 n +0000414676 00000 n +0000415043 00000 n +0000415685 00000 n +0000415956 00000 n +0000435296 00000 n +0000436808 00000 n +0000437928 00000 n +0000439163 00000 n +0000440176 00000 n +0000441264 00000 n +0000442830 00000 n +0000444228 00000 n +0000447294 00000 n +0000450808 00000 n +0000453909 00000 n +0000456884 00000 n +0000458825 00000 n +0000461520 00000 n +0000464522 00000 n +0000467293 00000 n +0000469949 00000 n +0000472789 00000 n +0000475336 00000 n +0000477734 00000 n +0000479877 00000 n +0000483629 00000 n +0000487755 00000 n +0000489447 00000 n +0000491152 00000 n +0000492474 00000 n +0000494385 00000 n +0000494543 00000 n +0000494701 00000 n +0000495310 00000 n +0000496097 00000 n +0000496900 00000 n +0000497556 00000 n +0000498219 00000 n +0000500049 00000 n +0000500735 00000 n +0000502132 00000 n +0000504366 00000 n +0000506547 00000 n +0000508260 00000 n +0000510014 00000 n +0000511961 00000 n +0000513720 00000 n +0000535072 00000 n +0000536804 00000 n +0000538797 00000 n +0000540482 00000 n +0000542391 00000 n +0000544259 00000 n +0000547882 00000 n +0000551892 00000 n +0000553381 00000 n +0000555037 00000 n +0000556578 00000 n +0000564066 00000 n +0000564224 00000 n +0000564387 00000 n +0000564545 00000 n +0000564703 00000 n +0000564861 00000 n +0000565019 00000 n +0000565177 00000 n +0000565335 00000 n +0000565762 00000 n +0000565920 00000 n +0000570074 00000 n +0000570232 00000 n +0000571002 00000 n +0000571273 00000 n +0000571549 00000 n +0000572891 00000 n +0000573883 00000 n +0000574923 00000 n +0000576144 00000 n +0000577725 00000 n +0000580118 00000 n +0000606355 00000 n +0000608885 00000 n +0000611688 00000 n +0000613784 00000 n +0000615851 00000 n +0000618043 00000 n +0000620055 00000 n +0000622005 00000 n +0000624003 00000 n +0000626204 00000 n +0000628182 00000 n +0000654578 00000 n +0000656812 00000 n +0000660107 00000 n +0000664213 00000 n +0000666973 00000 n +0000668197 00000 n +0000670708 00000 n +0000670951 00000 n +0000671109 00000 n +0000671464 00000 n +0000672166 00000 n +0000697603 00000 n +0000698553 00000 n +0000699285 00000 n +0000699977 00000 n +0000700643 00000 n +0000701430 00000 n +0000701861 00000 n +0000702019 00000 n +0000702313 00000 n +0000703016 00000 n +0000703287 00000 n +0000716018 00000 n +0000717020 00000 n +0000718088 00000 n +0000719107 00000 n +0000720199 00000 n +0000721634 00000 n +0000723116 00000 n +0000725837 00000 n +0000729050 00000 n +0000731695 00000 n +0000891808 00000 n +0000887320 00000 n +0000882826 00000 n +0000896725 00000 n +0000897059 00000 n +0000898625 00000 n +trailer <</Size 270/Root 1 0 R/Info 269 0 R/ID[<A07ED04FFD41405DBB1025BE92170C6C><609EDEAA7E53414AA427037AC7E2E79B>]>> startxref 898789 %%EOF \ No newline at end of file diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC7.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC7.pdf new file mode 100644 index 0000000000000000000000000000000000000000..02c98536f030d1fbfcc00f85e908e86d62c2e9ab Binary files /dev/null and b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_TC7.pdf differ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_dynhpg.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_dynhpg.pdf new file mode 100644 index 0000000000000000000000000000000000000000..991efc90a9774055bc36eb09bc8810ad3a361490 Binary files /dev/null and b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Figures/Fig_WAD_dynhpg.pdf differ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad new file mode 100644 index 0000000000000000000000000000000000000000..77d9d7c3ad201d16f66fb1587da0d78d61438625 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad @@ -0,0 +1,15 @@ +!----------------------------------------------------------------------- +&namwad ! Wetting and drying +!----------------------------------------------------------------------- + ln_wd_il = .false ! T/F activation of iterative limiter for wetting and drying scheme + ln_wd_dl = .true. ! T/F activation of directional llimiter for wetting drying scheme + ln_wd_dl_bc = .true. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .true. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! dpoth at which wetting/drying 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 wetting/drying is allowed + nn_wdit = 20 ! Max iterations for W/D limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc1 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc1 new file mode 100644 index 0000000000000000000000000000000000000000..d845b6b408b0724e7197a5a2d618392d6ec22934 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc1 @@ -0,0 +1,10 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 1 +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and drying +!----------------------------------------------------------------------- + rn_wdmin1 = 0.075 ! Minimum wet depth on dried cells +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc2 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc2 new file mode 100644 index 0000000000000000000000000000000000000000..73cfcb12ac033c11b12c3f686ec0feadbb0c67ba --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc2 @@ -0,0 +1,5 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 2 +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc3 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc3 new file mode 100644 index 0000000000000000000000000000000000000000..6ec0b98c23ceb80fadfbf8d7dd6d19184d2754bc --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc3 @@ -0,0 +1,5 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 3 +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc4 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc4 new file mode 100644 index 0000000000000000000000000000000000000000..df5bffe4a73b8060ffaad1addc5934497eddb1a1 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc4 @@ -0,0 +1,10 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 4 +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and drying +!----------------------------------------------------------------------- + rn_wdmin1 = 0.45 ! Minimum wet depth on dried cells +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc5 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc5 new file mode 100644 index 0000000000000000000000000000000000000000..8c714a9ccd57ac08ca36d660dfdc0a7f8f5541d4 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc5 @@ -0,0 +1,10 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 5 +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and drying +!----------------------------------------------------------------------- + rn_wdmin1 = 0.15 ! Minimum wet depth on dried cells +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc6 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc6 new file mode 100644 index 0000000000000000000000000000000000000000..6b48e4d9ff5c8418b2e8373ffa9e5d4abb8a4660 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc6 @@ -0,0 +1,5 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 6 +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc7 b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc7 new file mode 100644 index 0000000000000000000000000000000000000000..b39828ff30614afb8a69c4e3d1aca7bec266752c --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_tc7 @@ -0,0 +1,21 @@ +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + nn_wad_test = 7 +/ +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_itend = 9600 ! last time step +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries +!----------------------------------------------------------------------- + ln_bdy = .true. + nb_bdy = 1 ! number of open boundary sets +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and drying +!----------------------------------------------------------------------- + rn_wdmin1 = 0.150 ! Minimum wet depth on dried cells +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_usr b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_usr new file mode 100644 index 0000000000000000000000000000000000000000..b01a65d8ce03e6648c6ca37522885653d8a3286a --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Namelists/nam_wad_usr @@ -0,0 +1,8 @@ +! +!----------------------------------------------------------------------- +&namusr_def +!----------------------------------------------------------------------- + rn_dx = 1000.0 + rn_dz = 1.0 + nn_wad_test = 1 +/ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/Preamble.tex b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Preamble.tex new file mode 100644 index 0000000000000000000000000000000000000000..020b99b2d47ee3458526a6fb5b0413fcfda80bd9 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/Preamble.tex @@ -0,0 +1,175 @@ +\documentclass[a4paper,11pt]{book} +%\documentclass[a4paper,11pt,makeidx]{book} <== may need this to generate index + +% makeindex NEMO_book <== to regenerate the index +% bibtex NEMO_book <== to generate the bibliography + +%\usepackage[french]{babel} +%\usepackage{color} +\usepackage{rotating, graphicx} % allows insertion of pictures +%\usepackage{graphics} % allows insertion of pictures +\graphicspath{{Figures/}} % Set global directory for pictures +\DeclareGraphicsExtensions{.pdf,.eps} % Use .eps for LaTeX2HTML +%\usepackage{xcolor} % Incompatibility with color -> graphicx +\usepackage[capbesideposition={top,center}]{floatrow} % allows captions +\floatsetup[table]{style=plaintop} % beside pictures +\usepackage[margin=10pt,font={small}, % Gives small font for captions +labelsep=colon,labelfont={bf}]{caption} % +\usepackage{enumitem} % allows non-bold description items +\usepackage{longtable} % allows multipage tables +%\usepackage{colortbl} % gives coloured panels behind table columns + +%hyperref +\usepackage[pdftitle={NEMO ocean engine},pdfauthor={Gurvan Madec},pdfstartview=FitH, +bookmarks=true,bookmarksopen=true,breaklinks=true,colorlinks=true, +linkcolor=blue,anchorcolor=blue,citecolor=blue,filecolor=blue,menucolor=blue,urlcolor=blue]{hyperref} +% pdfsubject={The preprint document class +% elsart},% pdfkeywords={diapycnal diffusion,numerical mixing,z-level models},%% usage of exteranl hyperlink : \href{mailto:my_address@wikibooks.org}{my\_address@wikibooks.org} +% \url{http://www.wikibooks.org} +% or \href{http://www.wikibooks.org}{wikibooks home} + + +%%%% page styles etc................ +\usepackage{fancyhdr} +\pagestyle{fancy} +% with this we ensure that the chapter and section +% headings are in lowercase. +\renewcommand{\chaptermark}[1]{\markboth{#1}{}} +\renewcommand{\sectionmark}[1]{\markright{\thesection.\ #1}} +\fancyhf{} % delete current setting for header and footer +\fancyhead[LE,RO]{\bfseries\thepage} +\fancyhead[LO]{\bfseries\hspace{-0em}\rightmark} +\fancyhead[RE]{\bfseries\leftmark} +\renewcommand{\headrulewidth}{0.5pt} +\renewcommand{\footrulewidth}{0pt } +\addtolength{\headheight}{2.6pt} % make space for the rule +%\addtolength{\headheight}{1.6pt} % make space for the rule +% get rid of headers on plain pages +\fancypagestyle{plain}{\fancyhead{}\renewcommand{\headrulewidth}{0pt}} + + +%%%% Section number in Margin....... +% typeset the number of each section in the left margin, with the start of each instance of +% sectional heading text aligned with the left hand edge of the body text. +\makeatletter +\def\@seccntformat#1{\protect\makebox[0pt][r]{\csname the#1\endcsname\quad}} +\makeatother + +% Leave blank pages completely empty, w/o header +\makeatletter +\def\cleardoublepage{\clearpage\if@twoside \ifodd\c@page\else + \hbox{} + \vspace*{\fill} + \vspace{\fill} + \thispagestyle{empty} + \newpage + \if@twocolumn\hbox{}\newpage\fi\fi\fi} +\makeatother + +%%%% define the chapter style ................ +\usepackage{minitoc} %In French : \usepackage[french]{minitoc} +%\usepackage{mtcoff} % invalidate the use of minitocs +\usepackage{fancybox} + +\makeatletter +\def\LigneVerticale{\vrule height 5cm depth 2cm\hspace{0.1cm}\relax} +\def\LignesVerticales{% + \let\LV\LigneVerticale\LV\LV\LV\LV\LV\LV\LV\LV\LV\LV} +\def\GrosCarreAvecUnChiffre#1{% + \rlap{\vrule height 0.8cm width 1cm depth 0.2cm}% + \rlap{\hbox to 1cm{\hss\mbox{\color{white} #1}\hss}}% + \vrule height 0pt width 1cm depth 0pt} +\def\GrosCarreAvecTroisChiffre#1{% + \rlap{\vrule height 0.8cm width 1.6cm depth 0.2cm}% + \rlap{\hbox to 1.5cm{\hss\mbox{\color{white} #1}\hss}}% + \vrule height 0pt width 1cm depth 0pt} + +\def\@makechapterhead#1{\hbox{% + \huge + \LignesVerticales + \hspace{-0.5cm}% + \GrosCarreAvecUnChiffre{\thechapter} + \hspace{0.2cm}\hbox{#1}% +% \GrosCarreAvecTroisChiffre{\thechapter} +% \hspace{1cm}\hbox{#1}% +%}\par\vskip 2cm} +}\par\vskip 1cm} +\def\@makeschapterhead#1{\hbox{% + \huge + \LignesVerticales + %\hspace{0.5cm}% + \hbox{#1}% +}\par\vskip 2cm} +\makeatother + +%\def\thechapter{\Roman{chapter}} % chapter number to be Roman + + +%%%% Mathematics............... +%\documentclass{amsart} +\usepackage{xspace} % helpd ensure correct spacing after macros +\usepackage{latexsym,amssymb,amsmath} +\allowdisplaybreaks[1] % allow page breaks in the middle of equations +\usepackage{TexFiles/Styles/math_abbrev} % use maths shortcuts + +\usepackage{times} % use times font for text +%\usepackage{mathtime} % font for illustrator to work (belleek fonts ) +%\usepackage[latin1]{inputenc} % allows some unicode removed (agn) + + +%%% essai commande +\newcommand{\nl}[1]{\texttt{\small{\textcolor{blue}{#1}}}} +\newcommand{\nlv}[1]{\texttt{\footnotesize#1}\xspace} +\newcommand{\smnlv}[1]{\texttt{\scriptsize#1}\xspace} + +%%%% namelist & code display................................ +\usepackage{alltt,verbatim} %% alltt & verbatim for namelist +% namelists +\newcommand{\namdisplay}[1]{\begin{alltt}{\tiny\verbatiminput{Namelists/#1}}\end{alltt}\vspace{-10pt}} +\newcommand{\namtools}[1]{\begin{alltt}{\tiny\verbatiminput{Namelists/#1}}\end{alltt}\vspace{-10pt}} +% code display +%\newcommand{\codedisplay} [1] {\begin{alltt}{\tiny {\begin{verbatim} {#1}} \end{verbatim}} \end{alltt} } + + + +%%%% commands for working with text................................ +% command to "comment out" portions of text ({} argument) or not ({#1} argument) +\newcommand{\amtcomment}[1]{} % command to "commented out" portions of text or not (#1 in argument) +\newcommand{\sgacomment}[1]{} % command to "commented out" portions of +\newcommand{\gmcomment}[1]{} % command to "commented out" portions of +% % text that span line breaks +%Red (NR) or Yellow(WARN) +%\newcommand{\NR} {\colorbox{red} {#1}} +%\newcommand{\WARN} {\colorbox{yellow}{#1}} + + + +%%% index commands...................... +\usepackage{makeidx} +%\usepackage{showidx} % show the index entry + +\newcommand{\mdl}[1]{\textit{#1.F90}\index{Modules!#1}} %module (mdl) +\newcommand{\rou}[1]{\textit{#1}\index{Routines!#1}} %module (routine) +\newcommand{\hf}[1]{\textit{#1.h90}\index{h90 file!#1}} %module (h90 files) +\newcommand{\ngn}[1]{\textit{#1}\index{Namelist Group Name!#1}} %namelist name (nampar) +\newcommand{\np}[1]{\textit{#1}\index{Namelist variables!#1}} %namelist variable +\newcommand{\jp}[1]{\textit{#1}\index{Model parameters!#1}} %model parameter (jp) +\newcommand{\pp}[1]{\textit{#1}\index{Model parameters!#1}} %namelist parameter (pp) +\newcommand{\ifile}[1]{\textit{#1.nc }\index{Input NetCDF files!#1.nc}} %input NetCDF files (.nc) +\newcommand{\key}[1]{\textbf{key\_#1}\index{CPP keys!key\_#1}} %key_cpp (key) +\newcommand{\NEMO}{\textit{NEMO}\xspace} %NEMO (nemo) + +%%%% Bibliography ............. +\usepackage[nottoc,notlof,notlot]{tocbibind} +\usepackage[square,comma]{natbib} +\bibpunct{[}{]}{,}{a}{}{;} %suppress "," after "et al." +\providecommand{\bibfont}{\small} + +\usepackage{subfiles} % Separate compilation of chapters from whole manual +%\newcommand{\onlyinsubfile}[1]{#1} % New commands for printing parts according to +%\newcommand{\notinsubfile}[1]{} % the file being compiled +% Commands to use in the documentfile +%\renewcommand{\onlyinsubfile}[1]{} % Appears only if chapter .tex file is compiled +%\renewcommand{\notinsubfile}[1]{#1} % " "" "" NEMO_book .tex file is compiled + +\DeclareMathAlphabet{\mathpzc}{OT1}{pzc}{m}{it} diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.pdf b/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.pdf new file mode 100644 index 0000000000000000000000000000000000000000..469fca39fb6dd4d37af109352d5f061ff75a6c1c Binary files /dev/null and b/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.pdf differ diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.tex b/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.tex new file mode 100755 index 0000000000000000000000000000000000000000..2fc36f6f6a39fbc3e91b131e0ab113f205d9fbd9 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/WAD_doc.tex @@ -0,0 +1,248 @@ +\include{Preamble} + +\begin{document} + +\title{Draft description of NEMO wetting and drying scheme: 29 November 2017 } + +\author{ Enda O'Dea, Hedong Liu, Jason Holt, Andrew Coward and Michael J. Bell } + +%------------------------------------------------------------------------ +% End of temporary latex header (to be removed) +%------------------------------------------------------------------------ + +% ================================================================ +% Chapter Ocean Dynamics (DYN) +% ================================================================ +\chapter{Ocean Dynamics (DYN)} +\label{DYN} +\minitoc + +% add a figure for dynvor ens, ene latices + +$\ $\newline % force a new ligne + +% ================================================================ +% Wetting and drying +% ================================================================ + +%---------------------------------------------------------------------------------------- +% The WAD test cases +%---------------------------------------------------------------------------------------- +\section [The WAD test cases (\textit{usrdef\_zgr})] + {The WAD test cases (\mdl{usrdef\_zgr})} +\label{WAD_test_cases} + +This section contains details of the seven test cases that can be run as part of the +WAD\_TEST\_CASES configuration. All the test cases are shallow (less than 10m deep), +basins or channels with 4m high walls and some of topography that can wet and dry up to +2.5m above sea-level. The horizontal grid is uniform with a 1km resolution and measures +52km by 34km. These dimensions are determined by a combination of code in the +\mdl{usrdef\_nam} module located in the WAD\_TEST\_CASES/MY\_SRC directory and setting +read in from the namusr\_def namelist. The first six test cases are closed systems with no +rotation or external forcing and motion is simply initiated by an initial ssh slope. The +seventh test case introduces and open boundary at the right-hand end of the channel which +is forced with sinousoidally varying ssh and barotropic velocities. + +\namdisplay{nam_wad_usr} + +The $\mathrm{nn\_wad\_test}$ parameter can takes values 1 to 7 and it is this parameter +that determines which of the test cases will be run. Most cases can be run with the +default settings but the simple linear slope cases (tests 1 and 5) can be run with lower +values of $\mathrm{rn\_wdmin1}$. Any recommended changes to the default namelist settings +will be stated in the individual subsections. + +Test case 7 requires additional {\tt namelist\_cfg} changes to activate the open boundary +and lengthen the duration of the run (in order to demonstrate the full forcing cycle). +There is also a simple python script which needs to be run in order to generate the +boundary forcing files. Full details are given in subsection (\ref{WAD_test_case7}). + +\clearpage +\subsection [WAD test case 1 : A simple linear slope] + {WAD test case 1 : A simple linear slope} +\label{WAD_test_case1} + +The first test case is a simple linear slope (in the x-direction, uniform in y) with an +adverse SSH gradient that, when released, creates a surge up the slope. The parameters are +chosen such that the surge rises above sea-level before falling back and oscillating +towards an equilibrium position. This case can be run with $\mathrm{rn\_wdmin1}$ values as +low as 0.075m. I.e. the following change may be made to the default values in {\tt +namelist\_cfg} (for this test only): + +\namdisplay{nam_wad_tc1} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC1} +\caption{ \label{Fig_WAD_TC1} +The evolution of the sea surface height in WAD\_TEST\_CASE 1 from the initial state (t=0) +over the first three hours of simulation. Note that in this time-frame the resultant surge +reaches to nearly 2m above sea-level before retreating.} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 2 : A parabolic channel ] + {WAD test case 2 : A parabolic channel} +\label{WAD_test_case2} + +The second and third test cases use a closed channel which is parabolic in x and uniform +in y. Test case 2 uses a gentler initial SSH slope which nevertheless demonstrates the +ability to wet and dry on both sides of the channel. This solution requires values of +$\mathrm{rn\_wdmin1}$ at least 0.3m ({\it Q.: A function of the maximum topographic +slope?}) + +\namdisplay{nam_wad_tc2} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC2} +\caption{ \label{Fig_WAD_TC2} +The evolution of the sea surface height in WAD\_TEST\_CASE 2 from the initial state (t=0) +over the first three hours of simulation. Note that in this time-frame the resultant sloshing +causes wetting and drying on both sides of the parabolic channel.} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 3 : A parabolic channel (extreme slope) ] + {WAD test case 3 : A parabolic channel (extreme slope)} +\label{WAD_test_case3} + +Similar to test case 2 but with a steeper initial SSH slope. The solution is similar but more vigorous. + +\namdisplay{nam_wad_tc3} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC3} +\caption{ \label{Fig_WAD_TC3} +The evolution of the sea surface height in WAD\_TEST\_CASE 3 from the initial state (t=0) +over the first three hours of simulation. Note that in this time-frame the resultant sloshing +causes wetting and drying on both sides of the parabolic channel.} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 4 : A parabolic bowl ] + {WAD test case 4 : A parabolic bowl} +\label{WAD_test_case4} + +Test case 4 includes variation in the y-direction in the form of a parabolic bowl. The +initial condition is now a raised bulge centred over the bowl. Figure \ref{Fig_WAD_TC4} +shows a cross-section of the SSH in the X-direction but features can be seen to propagate +in all directions and interfere when return paths cross. + +\namdisplay{nam_wad_tc4} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC4} +\caption{ \label{Fig_WAD_TC4} +The evolution of the sea surface height in WAD\_TEST\_CASE 4 from the initial state (t=0) +over the first three hours of simulation. Note that this test case is a parabolic bowl with +variations occurring in the y-direction too (not shown here).} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 5 : A double slope with shelf channel ] + {WAD test case 5 : A double slope with shelf channel} +\label{WAD_test_case5} + +Similar in nature to test case 1 but with a change in slope and a mid-depth shelf. + +\namdisplay{nam_wad_tc5} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC5} +\caption{ \label{Fig_WAD_TC5} +The evolution of the sea surface height in WAD\_TEST\_CASE 5 from the initial state (t=0) +over the first three hours of simulation. The surge resulting in this case wets to the full +depth permitted (2.5m above sea-level) and is only halted by the 4m high side walls.} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 6 : A parabolic channel with central bar ] + {WAD test case 6 : A parabolic channel with central bar} +\label{WAD_test_case6} + +Test cases 1 to 5 have all used uniform T and S conditions. The dashed line in each plot +shows the surface salinity along the y=17 line which remains satisfactorily constant. Test +case 6 introduces variation in salinity by taking a parabolic channel divided by a central +bar (gaussian) and using two different salinity values in each half of the channel. This +step change in salinity is initially enforced by the central bar but the bar is +subsequently over-topped after the initial SSH gradient is released. The time series in +this case shows the SSH evolution with the water coloured according to local salinity +values. Encroachment of the high salinity (red) waters into the low salinity (blue) basin +can clearly be seen. + +\namdisplay{nam_wad_tc6} + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{figure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC6} +\caption{ \label{Fig_WAD_TC6} +The evolution of the sea surface height in WAD\_TEST\_CASE 6 from the initial state (t=0) +over the first three hours of simulation. Water is coloured according to local salinity +values. Encroachment of the high salinity (red) waters into the low salinity (blue) basin +can clearly be seen although the largest influx occurs early in the sequence between the +frames shown.} +\end{center}\end{figure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +\clearpage +\subsection [WAD test case 7 : A double slope with shelf, open-ended channel ] + {WAD test case 7 : A double slope with shelf, open-ended channel} +\label{WAD_test_case7} + +Similar in nature to test case 5 but with an open boundary forced with a sinusoidally +varying ssh. This test case has been introduced to emulate a typical coastal application +with a tidally forced open boundary. The bathymetry and setup is identical to test case 5 +except the right hand end of the channel is now open and has simple ssh and barotropic +velocity boundary conditions applied at the open boundary. Several additional steps and +namelist changes are required to run this test. + +\namdisplay{nam_wad_tc7} + +In addition, the boundary condition files must be generated using the python script +provided. + +\begin{verbatim} +python ./makebdy_tc7.py +\end{verbatim} + +will create the following boundary files for this test (assuming a suitably configured +python environment: python2.7 with netCDF4 and numpy): + +\begin{verbatim} + bdyssh_tc7_m12d30.nc bdyuv_tc7_m12d30.nc + bdyssh_tc7_m01d01.nc bdyuv_tc7_m01d01.nc + bdyssh_tc7_m01d02.nc bdyuv_tc7_m01d02.nc + bdyssh_tc7_m01d03.nc bdyuv_tc7_m01d03.nc +\end{verbatim} + +These are sufficient for up to a three day simulation; the script is easily adapted if +longer periods are required. + +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +\begin{sidewaysfigure}[htb] \begin{center} +\includegraphics[width=0.8\textwidth]{Fig_WAD_TC7} +\caption{ \label{Fig_WAD_TC7} +The evolution of the sea surface height in WAD\_TEST\_CASE 7 from the initial state (t=0) +over the first 24 hours of simulation. After the initial surge the solution settles into a +simulated tidal cycle with an amplitude of 5m. This is enough to repeatedly wet and dry +both shelves.} + +\end{center}\end{sidewaysfigure} +%>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + +% ================================================================ + +%\bibliographystyle{wileyqj} +%\bibliographystyle{../../../doc/latex/NEMO/main/ametsoc.bst} +%\bibliography{references} + +\end{document} diff --git a/V4.0/nemo_sources/tests/WAD/MY_DOCS/references.bib b/V4.0/nemo_sources/tests/WAD/MY_DOCS/references.bib new file mode 100644 index 0000000000000000000000000000000000000000..73a6aa56694a45dda780f1f7d53b49315e76bcbd --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_DOCS/references.bib @@ -0,0 +1,36 @@ +@article{Oey05, + author = {L-Y Oey}, + title = {{A wetting and drying scheme for POM}}, + journal = {Ocean Mod.}, + year = {2005}, + volume = {9}, + pages = {133--150}} + +@article{Oey06, + title = "An OGCM with movable land-sea boundaries", + journal = "Ocean Modelling", + volume = "13", + number = "2", + pages = "176 - 195", + year = "2006", + issn = "1463-5003", + doi = "https://doi.org/10.1016/j.ocemod.2006.01.001", + url = "http://www.sciencedirect.com/science/article/pii/S1463500306000084", + author = "Lie-Yauw Oey", + keywords = "Wetting and drying, Inundations, Ocean general circulation model (OGCM), Princeton Ocean Model (POM), Tides, Tsunamis, Estuarine outflows", + abstract = "An ocean general circulation model (OGCM) with wetting and drying (WAD) capabilities removes the vertical-wall coastal assumption and allows simultaneous modeling of open-ocean currents and water run-up (and run-down) across movable land-sea boundaries. This paper implements and tests such a WAD scheme for the Princeton Ocean Model (POM) in its most general three-dimensional setting with stratification, bathymetry and forcing. The scheme can be easily exported to other OGCM's." +} + +@article{WarnerEtal13, + title = "A wetting and drying scheme for ROMS", + journal = "Computers \& Geosciences", + volume = "58", + pages = "54 - 61", + year = "2013", + issn = "0098-3004", + doi = "https://doi.org/10.1016/j.cageo.2013.05.004", + url = "http://www.sciencedirect.com/science/article/pii/S0098300413001362", + author = "John C. Warner and Zafer Defne and Kevin Haas and Hernan G. Arango", + keywords = "Wetting and drying, ROMS, Cell-face blocking", + abstract = "The processes of wetting and drying have many important physical and biological impacts on shallow water systems. Inundation and dewatering effects on coastal mud flats and beaches occur on various time scales ranging from storm surge, periodic rise and fall of the tide, to infragravity wave motions. To correctly simulate these physical processes with a numerical model requires the capability of the computational cells to become inundated and dewatered. In this paper, we describe a method for wetting and drying based on an approach consistent with a cell-face blocking algorithm. The method allows water to always flow into any cell, but prevents outflow from a cell when the total depth in that cell is less than a user defined critical value. We describe the method, the implementation into the three-dimensional Regional Oceanographic Modeling System (ROMS), and exhibit the new capability under three scenarios: an analytical expression for shallow water flows, a dam break test case, and a realistic application to part of a wetland area along the Georgia Coast, USA." +} diff --git a/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_hgr.F90 b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_hgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f5285c5b3c88c92001bd71e482e108dcd43e674e --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_hgr.F90 @@ -0,0 +1,109 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === WAD_TEST_CASES 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 for WAD_TEST_CASES configuration + !!---------------------------------------------------------------------- + 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, ONLY: rn_dx ! horizontal resolution in meters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called by domhgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! 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 + !! WAD_TEST_CASES configuration : uniform grid spacing (rn_dx) + !! without Coriolis force (f=0) + !! + !! ** 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) :: zfact ! local scalars + !!------------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : WAD_TEST_CASES configuration basin' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ uniform grid spacing WITHOUT Coriolis force (f=0)' + ! + ! !== grid point position ==! (in kilometers) + zfact = rn_dx * 1.e-3 ! conversion in km + DO jj = 1, jpj + DO ji = 1, jpi ! longitude + plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) ) + plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) ) + plamv(ji,jj) = plamt(ji,jj) + plamf(ji,jj) = plamu(ji,jj) + ! ! latitude + pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) + pphiu(ji,jj) = pphit(ji,jj) + pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) ) + pphif(ji,jj) = pphiv(ji,jj) + END DO + END DO + ! + ! !== Horizontal scale factors ==! (in meters) + pe1t(:,:) = rn_dx ; pe2t(:,:) = rn_dx + pe1u(:,:) = rn_dx ; pe2u(:,:) = rn_dx + pe1v(:,:) = rn_dx ; pe2v(:,:) = rn_dx + pe1f(:,:) = rn_dx ; pe2f(:,:) = rn_dx + ! + ! ! 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 Coriolis parameter afterward + ! + pff_f(:,:) = 0._wp ! here No earth rotation: f=0 + pff_t(:,:) = 0._wp + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_istate.F90 b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_istate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ad29f0c1fa4200e170f19452113a65bc427a440a --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_istate.F90 @@ -0,0 +1,187 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === WAD_TEST_CASES configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! 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 : mi0, mig, mjg, glamt, gphit, ht_0 + USE phycst ! physical constants + USE wet_dry ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called in istate.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here WAD_TEST_CASES configuration + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + 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 :: ji, jj ! dummy loop indices + REAL(wp) :: zi, zj + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zdam ! location of dam [Km] + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD_TEST_CASES configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant temperature ' + IF(lwp) WRITE(numout,*) ' and constant salinity (not used as rho=F(T) ' + ! + ! + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + pssh(:,:) = 0._wp + ! + ! ! T & S profiles + pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) + ! + pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) + !!---------------------------------------------------------------------- + ! + !!---------------------------------------------------------------------- + ! + ! Uniform T & S in most test cases + pts(:,:,:,jp_tem) = 10._wp + pts(:,:,:,jp_sal) = 35._wp + SELECT CASE ( nn_cfg ) + ! ! ==================== + CASE ( 1 ) ! WAD 1 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + do ji = 1,jpi + pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) + end do + ! ! ==================== + CASE ( 2, 8 ) ! WAD 2 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + do ji = 1,jpi + pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) + end do + ! ! ==================== + CASE ( 3 ) ! WAD 3 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + do ji = 1,jpi + pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) + end do + + ! + ! ! ==================== + CASE ( 4 ) ! WAD 4 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic bowl, mid-range initial ssh slope' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MAX(1.0-((glamt(ji,1)-25._wp)**2)/400.0, 0.0 ) + DO jj = 1, jpj + zj = MAX(1.0-((gphit(1,jj)-17._wp)**2)/144.0, 0.0 ) + pssh(ji,jj) = -2.5_wp + 5.4_wp*zi*zj + END DO + END DO + + ! + ! ! =========================== + CASE ( 5, 7 ) ! WAD 5 and 7 configurations + ! ! =========================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Double slope with shelf' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + do ji = 1,jpi + pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) + end do + + ! + ! ! ==================== + CASE ( 6 ) ! WAD 6 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel with gaussian ridge' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + do ji = 1,jpi + pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) + end do + ! + do ji = mi0(jpiglo/2), mi0(jpiglo) + pts(ji,:,:,jp_sal) = 30._wp + pssh(ji,:) = -0.1*ptmask(ji,:,1) + end do + ! + ! + ! ! =========================== + CASE DEFAULT ! NONE existing configuration + ! ! =========================== + WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded' + ! + CALL ctl_stop( ctmp1 ) + ! + END SELECT + + + ! + ! Apply minimum wetdepth criterion + ! + do jj = 1,jpj + do ji = 1,jpi + IF( ht_0(ji,jj) + pssh(ji,jj) < rn_wdmin1 ) THEN + pssh(ji,jj) = ptmask(ji,jj,1)*( rn_wdmin1 - ht_0(ji,jj) ) + ENDIF + end do + end do + ! + END SUBROUTINE usr_def_istate + + !!====================================================================== +END MODULE usrdef_istate diff --git a/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_nam.F90 b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_nam.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c3c99ef414159b82dcfe67a1bd86b57433468c0a --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_nam.F90 @@ -0,0 +1,102 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === WAD_TEST_CASES 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 ! i- & j-indices of the local 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 + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called by nemogcm.F90 + + ! !!* namusr_def namelist *!! + REAL(wp), PUBLIC :: rn_dx ! resolution in meters defining the horizontal domain size + REAL(wp), PUBLIC :: rn_dz ! resolution in meters defining the vertical domain size + INTEGER , PUBLIC :: nn_wad_test ! resolution in meters defining the vertical domain size + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $ + !! 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 WAD_TEST_CASES 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/ rn_dx, rn_dz, nn_wad_test + !!---------------------------------------------------------------------- + ! + 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 = 'wad' ! name & resolution (not used) + nn_cfg = nn_wad_test + kk_cfg = nn_wad_test + ! + ! Global Domain size: WAD_TEST_CASES domain is 52 km x 34 km x 10 m + kpi = INT( 50.e3 / rn_dx ) + 2 + kpj = INT( 32.e3 / rn_dx ) + 2 + kpk = INT( 10. / rn_dz ) + 1 + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! WAD_TEST_CASES configuration : closed domain + IF( nn_wad_test == 8 ) kperio = 7 ! North-South cyclic test + ! + ! ! 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 : WAD_TEST_CASES test case' + WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters' + WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters' + WRITE(numout,*) ' WAD_TEST_CASES domain = 52 km x 34 km x 10 m' + WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral boundary condition of the global domain' + WRITE(numout,*) ' closed jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_sbc.F90 b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_sbc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e554edf7e5f17bc7d8c366edf47f5428f5d613e6 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_sbc.F90 @@ -0,0 +1,87 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === WAD_TEST_CASES configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usrdef_sbc : user defined surface bounday conditions in WAD_TEST_CASES 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: ice 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 ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + 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: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +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 WAD_TEST_CASES case + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! + IF(lwp) WRITE(numout,*)' usr_sbc : WAD_TEST_CASES 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 + ! + 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 ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_zgr.F90 b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_zgr.F90 new file mode 100644 index 0000000000000000000000000000000000000000..78db8570a727eb45daf31602b44613e9e454f6a3 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/MY_SRC/usrdef_zgr.F90 @@ -0,0 +1,390 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === WAD_TEST_CASES case === + !! + !! Ocean domain : user defined vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-06 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system (required) + !! zgr_z : reference 1D z-coordinate + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce , ONLY: ht_0, mi0, mi1, nimpp, njmpp, & + & mj0, mj1, glamt, gphit ! ocean space and time domain + USE usrdef_nam ! User defined : namelist variables + USE wet_dry , ONLY: rn_wdmin1, rn_wdmin2, rn_wdld ! Wetting and drying + ! + 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: usrdef_zgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: 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 :: ji, jj, jk ! dummy indices + INTEGER :: ik ! local integers + REAL(wp) :: zfact, z1_jpkm1 ! local scalar + REAL(wp) :: ze3min ! local scalar + REAL(wp) :: zi, zj, zbathy ! local scalar + REAL(wp) :: ztmpu, ztmpv, ztmpf, ztmpu1, ztmpv1, ztmpf1, zwet + REAL(wp), DIMENSION(jpi,jpj) :: zht, zhu, zhv, z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : WAD_TEST_CASES configuration (s-coordinate closed box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate ==>>> here WAD_TEST_CASES : s-coordinate always + ! --------------------------- + ld_zco = .FALSE. ! z-partial-step coordinate + ld_zps = .FALSE. ! z-partial-step coordinate + ld_sco = .TRUE. ! s-coordinate + ld_isfcav = .FALSE. ! ISF Ice Shelves Flag + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + ! + ! !== UNmasked meter bathymetry ==! + ! +! + zbathy=10.0 + IF( cn_cfg == 'wad' ) THEN + SELECT CASE ( nn_cfg ) + ! ! ==================== + CASE ( 1 ) ! WAD 1 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Closed box with EW linear bottom slope' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + zht = 1.5_wp + DO ji = 1, jpi + zi = MIN((glamt(ji,1) - 10.0)/40.0, 1.0 ) + zht(ji,:) = MAX(zbathy*zi, -2.0) + END DO + zht(mi0(1):mi1(1),:) = -4._wp + zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + ! ! ==================== + CASE ( 2, 3, 8 ) ! WAD 2 or 3 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Parobolic EW channel' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MAX(1.0-((glamt(ji,1)-25.0)**2)/484.0, -0.3 ) + zht(ji,:) = MAX(zbathy*zi, -2.0) + END DO + zht(mi0(1):mi1(1),:) = -4._wp + zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp + IF( nn_cfg /= 8 ) THEN + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + ENDIF + ! ! ==================== + CASE ( 4 ) ! WAD 4 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Parobolic bowl' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MAX(1.0-((glamt(ji,1)-25.0)**2)/484.0, -2.0 ) + DO jj = 1, jpj + zj = MAX(1.0-((gphit(1,jj)-17.0)**2)/196.0, -2.0 ) + zht(ji,jj) = MAX(zbathy*zi*zj, -2.0) + END DO + END DO + zht(mi0(1):mi1(1),:) = -4._wp + zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + ! ! =========================== + CASE ( 5 ) ! WAD 5 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Double slope with shelf' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MIN(glamt(ji,1)/45.0, 1.0 ) + zht(ji,:) = MAX(zbathy*zi, -2.0) + IF( glamt(ji,1) >= 46.0 ) THEN + zht(ji,:) = 10.0 + ELSE IF( glamt(ji,1) >= 20.0 .AND. glamt(ji,1) < 46.0 ) THEN + zi = 7.5/25. + zht(ji,:) = MAX(10. - zi*(47.-glamt(ji,1)),2.5) + ELSE IF( glamt(ji,1) >= 15.0 .AND. glamt(ji,1) < 20.0 ) THEN + zht(ji,:) = 2.5 + ELSE IF( glamt(ji,1) >= 4.0 .AND. glamt(ji,1) < 15.0 ) THEN + zi = 4.5/11.0 + zht(ji,:) = MAX(2.5 - zi*(16.0-glamt(ji,1)), -2.0) + ELSE IF( glamt(ji,1) >= 0.0 .AND. glamt(ji,1) < 4.0 ) THEN + zht(ji,:) = -2.0 + ENDIF + END DO + ! ! =========================== + zht(mi0(1):mi1(1),:) = -4._wp + zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + ! ! =========================== + CASE ( 6 ) ! WAD 6 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Parabolic channel with gaussian ridge' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MAX(1.0-((glamt(ji,1)-25.0)**2)/484.0, -2.0 ) + zj = 1.075*MAX(EXP(-1.0*((glamt(ji,1)-25.0)**2)/32.0) , 0.0 ) + zht(ji,:) = MAX(zbathy*(zi-zj), -2.0) + END DO + zht(mi0(1):mi1(1),:) = -4._wp + zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + ! ! =========================== + CASE ( 7 ) ! WAD 7 configuration + ! ! ==================== + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr (WAD) : Double slope with open boundary' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + DO ji = 1, jpi + zi = MIN(glamt(ji,1)/45.0, 1.0 ) + zht(ji,:) = MAX(zbathy*zi, -2.0) + IF( glamt(ji,1) >= 46.0 ) THEN + zht(ji,:) = 10.0 + ELSE IF( glamt(ji,1) >= 20.0 .AND. glamt(ji,1) < 46.0 ) THEN + zi = 7.5/25. + zht(ji,:) = MAX(10. - zi*(47.-glamt(ji,1)),2.5) + ELSE IF( glamt(ji,1) >= 15.0 .AND. glamt(ji,1) < 20.0 ) THEN + zht(ji,:) = 2.5 + ELSE IF( glamt(ji,1) >= 4.0 .AND. glamt(ji,1) < 15.0 ) THEN + zi = 4.5/11.0 + zht(ji,:) = MAX(2.5 - zi*(16.0-glamt(ji,1)), -2.0) + ELSE IF( glamt(ji,1) >= 0.0 .AND. glamt(ji,1) < 4.0 ) THEN + zht(ji,:) = -2.0 + ENDIF + END DO + ! ! =========================== + zht(mi0(1):mi1(1),:) = -4._wp + zht(:,mj0(1):mj1(1)) = -4._wp + zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp + CASE DEFAULT + ! ! =========================== + WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded' + ! + CALL ctl_stop( ctmp1 ) + ! + END SELECT + END IF + + + ! at u-point: averaging zht + DO ji = 1, jpim1 + zhu(ji,:) = 0.5_wp * ( zht(ji,:) + zht(ji+1,:) ) + END DO + CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrounding grid-points + ! ! ==>>> set by hand non-zero value on first/last columns & rows + DO ji = mi0(1), mi1(1) ! first row of global domain only + zhu(ji,:) = zht(1,:) + END DO + DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only + zhu(ji,:) = zht(jpi,:) + END DO + ! at v-point: averaging zht + zhv = 0._wp + DO jj = 1, jpjm1 + zhv(:,jj) = 0.5_wp * ( zht(:,jj) + zht(:,jj+1) ) + END DO + CALL lbc_lnk( 'usrdef_zgr', zhv, 'V', 1. ) ! boundary condition: this mask the surrounding grid-points + DO jj = mj0(1), mj1(1) ! first row of global domain only + zhv(:,jj) = zht(:,jj) + END DO + DO jj = mj0(jpjglo), mj1(jpjglo) ! last row of global domain only + zhv(:,jj) = zht(:,jj) + END DO + ! + CALL zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + ! + ! !== top masked level bathymetry ==! (all coordinates) + ! + ! no ocean cavities : top ocean level is ONE, except over land + ! the ocean basin surrounnded by land (1 grid-point) set through lbc_lnk call as jperio=0 + z2d(:,:) = 1._wp ! surface ocean is the 1st level + z2d(mi0(1):mi1(1),:) = 0._wp + z2d(mi0(jpiglo):mi1(jpiglo),:) = 0._wp + z2d(:,mj0(1):mj1(1)) = 0._wp + z2d(:,mj0(jpjglo):mj1(jpjglo)) = 0._wp + + + + + + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90) + k_top(:,:) = NINT( z2d(:,:) ) + ! + ! + ! + IF ( ld_sco ) THEN !== s-coordinate ==! (terrain-following coordinate) + ! + ht_0 = zht + k_bot(:,:) = jpkm1 * k_top(:,:) !* bottom ocean = jpk-1 (here use k_top as a land mask) + DO jj = 1, jpj + DO ji = 1, jpi + IF( zht(ji,jj) <= -(rn_wdld - rn_wdmin2)) THEN + k_bot(ji,jj) = 0 + k_top(ji,jj) = 0 + ENDIF + END DO + END DO + ! + ! !* terrain-following coordinate with e3.(k)=cst) + ! ! OVERFLOW case : identical with j-index (T=V, U=F) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + z1_jpkm1 = 1._wp / REAL( k_bot(ji,jj) - k_top(ji,jj) + 1 , wp) + DO jk = 1, jpk + zwet = MAX( zht(ji,jj), rn_wdmin1 ) + pdept(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp ) + pdepw(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk-1 , wp ) ) + pe3t (ji,jj,jk) = zwet * z1_jpkm1 + pe3w (ji,jj,jk) = zwet * z1_jpkm1 + zwet = MAX( zhu(ji,jj), rn_wdmin1 ) + pe3u (ji,jj,jk) = zwet * z1_jpkm1 + pe3uw(ji,jj,jk) = zwet * z1_jpkm1 + pe3f (ji,jj,jk) = zwet * z1_jpkm1 + zwet = MAX( zhv(ji,jj), rn_wdmin1 ) + pe3v (ji,jj,jk) = zwet * z1_jpkm1 + pe3vw(ji,jj,jk) = zwet * z1_jpkm1 + END DO + END DO + END DO + CALL lbc_lnk( 'usrdef_zgr', pdept, 'T', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pdepw, 'T', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3t , 'T', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3w , 'T', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3u , 'U', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3uw, 'U', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3f , 'F', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3v , 'V', 1. ) + CALL lbc_lnk( 'usrdef_zgr', pe3vw, 'V', 1. ) + WHERE( pe3t (:,:,:) == 0._wp ) pe3t (:,:,:) = 1._wp + WHERE( pe3u (:,:,:) == 0._wp ) pe3u (:,:,:) = 1._wp + WHERE( pe3v (:,:,:) == 0._wp ) pe3v (:,:,:) = 1._wp + WHERE( pe3f (:,:,:) == 0._wp ) pe3f (:,:,:) = 1._wp + WHERE( pe3w (:,:,:) == 0._wp ) pe3w (:,:,:) = 1._wp + WHERE( pe3uw(:,:,:) == 0._wp ) pe3uw(:,:,:) = 1._wp + WHERE( pe3vw(:,:,:) == 0._wp ) pe3vw(:,:,:) = 1._wp + ENDIF + ! + ! + ! + 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 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 ] + !! + !! === Here constant vertical resolution === + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalar + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates: uniform dz = ', rn_dz + WRITE(numout,*) ' ~~~~~~~' + ENDIF + ! + ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function + ! ---------------------- + DO jk = 1, jpk + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = rn_dz * REAL( jk-1 , wp ) + pdept_1d(jk) = rn_dz * ( REAL( jk-1 , wp ) + 0.5_wp ) + pe3w_1d (jk) = rn_dz + pe3t_1d (jk) = rn_dz + END DO + ! + 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 + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/V4.0/nemo_sources/tests/WAD/cpp_WAD.fcm b/V4.0/nemo_sources/tests/WAD/cpp_WAD.fcm new file mode 100644 index 0000000000000000000000000000000000000000..904e97e07b64bb4e7bde3223b041c6099aa69141 --- /dev/null +++ b/V4.0/nemo_sources/tests/WAD/cpp_WAD.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_iomput key_mpp_mpi diff --git a/V4.0/nemo_sources/tests/demo_cfgs.txt b/V4.0/nemo_sources/tests/demo_cfgs.txt new file mode 100644 index 0000000000000000000000000000000000000000..7f966f05446338ebb73ee457bf67b1b0bbc683f9 --- /dev/null +++ b/V4.0/nemo_sources/tests/demo_cfgs.txt @@ -0,0 +1,10 @@ +CANAL OCE +ISOMIP OCE +LOCK_EXCHANGE OCE +OVERFLOW OCE +ICE_AGRIF OCE NST SAS ICE +ICE_ADV1D OCE SAS ICE +ICE_ADV2D OCE SAS ICE +VORTEX OCE NST +WAD OCE +BENCH OCE ICE TOP diff --git a/V4.0/nemo_sources/tests/rmt_cfgs.txt b/V4.0/nemo_sources/tests/rmt_cfgs.txt new file mode 100644 index 0000000000000000000000000000000000000000..b365fbce43717c60c4f9e3d43022c65d40692311 --- /dev/null +++ b/V4.0/nemo_sources/tests/rmt_cfgs.txt @@ -0,0 +1,3 @@ +ORCA1_CICE # ORCA2_LIM # OCE TOP # http://gws-access.ceda.ac.uk/public/nemo/uspconfigs/ORCA1_CICE/v3.6.0/ORCA1_CICE_ctl.txt +ISOMIP # GYRE # OCE # http://gws-access.ceda.ac.uk/public/nemo/uspconfigs/ISOMIP/trunk/ISOMIP_ctl.txt +IRISHSEA # GYRE # OCE # http://gws-access.ceda.ac.uk/public/nemo/uspconfigs/IRISHSEA/v3.7.0/IRISHSEA_ctl.txt diff --git a/V4.0/nemo_sources/tests/test_cases.bib b/V4.0/nemo_sources/tests/test_cases.bib new file mode 100644 index 0000000000000000000000000000000000000000..1bb54997a2a79544f446575c8307ee67f859ac5a --- /dev/null +++ b/V4.0/nemo_sources/tests/test_cases.bib @@ -0,0 +1,116 @@ +@book{HAIDVOGEL1999, + author = {D. B. Haidvogel and A. Beckmann}, + publisher = {Imperial College Press, London}, + year = {1999}, + title = {Numerical ocean circulation modeling} +} + +@book{BURCHARD2002, + title={GETM: A General Estuarine Transport Model; Scientific Documentation}, + author={Burchard, Hans and Bolding, Karsten}, + year={2002}, + publisher={European Commission, Joint Research Centre, Institute for Environment and Sustainability} +} + +@article{ILICAK2012, + title = "Spurious dianeutral mixing and the role of momentum closure", + journal = "Ocean Modelling", + volume = "45-46", + pages = "37 - 58", + year = "2012", + issn = "1463-5003", + doi = "10.1016/j.ocemod.2011.10.003", + author = "Mehmet Ilicak and Alistair J. Adcroft and Stephen M. Griffies and Robert W. Hallberg", + keywords = "Spurious dianeutral transport, Cabbeling, Overflows, Exchange-flow, Ocean models, Momentum transport, Tracer advection, Reference potential energy" +} + +@article{DEBREU2012, + title = "Two-way nesting in split-explicit ocean models: Algorithms, implementation and validation", + journal = "Ocean Modelling", + volume = "49-50", + pages = "1 - 21", + year = "2012", + issn = "1463-5003", + doi = "10.1016/j.ocemod.2012.03.003", + author = "Laurent Debreu and Patrick Marchesiello and Pierrick Penven and Gildas Cambon", + keywords = "Two-way nesting, Finite difference method, Modeling, Boundary conditions, Coastal upwelling" +} + +@article{PENVEN2006, + title = "Evaluation and application of the ROMS 1-way embedding procedure to the central california upwelling system", + journal = "Ocean Modelling", + volume = "12", + number = "1", + pages = "157 - 187", + year = "2006", + issn = "1463-5003", + doi = "10.1016/j.ocemod.2005.05.002", + author = "Pierrick Penven and Laurent Debreu and Patrick Marchesiello and James C. McWilliams", + keywords = "Ocean models, Boundary conditions, Embedding, Coastal upwelling, Mesoscale eddies, Eddy kinetic energy, North America, West Coast, Central upwelling system, Monterey Bay, 35–41°N, 128–121°W" +} + +@article{SPALL1991, + author = {Spall, M. A. and Holland, W. R.}, + title = {A Nested Primitive Equation Model for Oceanic Applications}, + journal = {Journal of Physical Oceanography}, + volume = {21}, + number = {2}, + pages = {205-220}, + year = {1991}, + doi = {10.1175/1520-0485(1991)021<0205:ANPEMF>2.0.CO;2}, +} + +@article{MATHIOT2017, + author = {Mathiot, P. and Jenkins, A. and Harris, C. and Madec, G.}, + title = {Explicit representation and parametrised impacts of under ice shelf seas in the ${z}^{\ast}$ coordinate ocean model NEMO 3.6}, + journal = {Geoscientific Model Development}, + volume = {10}, + year = {2017}, + number = {7}, + pages = {2849--2874}, + url = {https://www.geosci-model-dev.net/10/2849/2017/}, + doi = {10.5194/gmd-10-2849-2017} +} + +@article{LOSCH2008, + author = {Losch, M.}, + title = {Modeling ice shelf cavities in a z coordinate ocean general circulation model}, + journal = {Journal of Geophysical Research: Oceans}, + volume = {113}, + year = {2008}, + number = {C8}, + pages = {}, + keywords = {Ice shelf cavities, numerical ocean modeling, z coordinates}, + doi = {10.1029/2007JC004368}, + url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2007JC004368}, + eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/2007JC004368}, + abstract = {Processes at the ice shelf-ocean interface and in particular in ice shelf cavities around Antarctica have an observable effect on the solutions of basin scale to global coupled ice-ocean models. Despite this, these processes are not routinely represented in global ocean and climate models. It is shown that a new ice shelf cavity model for z coordinate models can reproduce results from an intercomparison project of earlier approaches with vertical ?~C or isopycnic coordinates. As a proof of concept, ice shelves are incorporated in a 100-year global integration of a z coordinate model. In this simulation, glacial meltwater can be traced as far as north as 15??S. The observed effects of processes in the ice shelf cavities agree with previous results from a ?~C coordinate model, notably the increase in sea ice thickness. However, melt rates are overestimated probably because the parameterization of basal melting does not suit the low resolution of this configuration.} +} + +@article{LIPSCOMB2004, + author = {Lipscomb, William H. and Hunke, Elizabeth C.}, + title = {Modeling Sea Ice Transport Using Incremental Remapping}, + journal = {Monthly Weather Review}, + volume = {132}, + number = {6}, + pages = {1341-1354}, + year = {2004}, + doi = {10.1175/1520-0493(2004)132<1341:MSITUI>2.0.CO;2}, + URL = {https://doi.org/10.1175/1520-0493(2004)132<1341:MSITUI>2.0.CO;2}, + eprint = {https://doi.org/10.1175/1520-0493(2004)132<1341:MSITUI>2.0.CO;2}, + abstract = { Abstract Sea ice models contain transport equations for the area, volume, and energy of ice and snow in various thickness categories. These equations typically are solved with first-order-accurate upwind schemes, which are very diffusive; with second-order-accurate centered schemes, which are highly oscillatory; or with more sophisticated second-order schemes that are computationally costly if many quantities must be transported [e.g., multidimensional positive-definite advection transport algorithm (MPDATA)]. Here an incremental remapping scheme, originally designed for horizontal transport in ocean models, is adapted for sea ice transport. This scheme has several desirable features: it preserves the monotonicity of both conserved quantities and tracers; it is second-order accurate except where the accuracy is reduced locally to preserve monotonicity; and it efficiently solves the large number of equations in sea ice models with multiple thickness categories and tracers. Remapping outperforms the first-order upwind scheme and basic MPDATA scheme in several simple test problems. In realistic model runs, remapping is less diffusive than the upwind scheme and about twice as fast as MPDATA. } +} + +@article{SCHAR1996, + author = {Christoph Schär and Piotr K. Smolarkiewicz}, + title = {A Synchronous and Iterative Flux-Correction Formalism for Coupled Transport Equations}, + journal = {Journal of Computational Physics}, + volume = {128}, + number = {1}, + pages = {101 - 120}, + year = {1996}, + issn = {0021-9991}, + doi = {https://doi.org/10.1006/jcph.1996.0198}, + url = {http://www.sciencedirect.com/science/article/pii/S0021999196901989}, + abstract = {Many problems of fluid dynamics involve the coupled transport of several, density-like, dependent variables (for instance, densities of mass and momenta in elastic flows). In this paper, a conservative and synchronous flux-corrected transport (FCT) formalism is developed which aims at a consistent transport of such variables. The technique differs from traditional FCT algorithms in two respects. First, the limiting of transportive fluxes of the primary variables (e.g., mass and momentum) does not derive from smooth estimates of the variables, but it derives from analytic constraints implied by the Lagrangian form of the governing continuity equations, which are imposed on the specific mixing ratios of the variables (e.g., velocity components). Second, the traditional FCT limiting based on sufficiency conditions is augmented by an iterative procedure which approaches the necessity requirements. This procedure can also be used in the framework of traditional FCT schemes, and a demonstration is provided that it can significantly reduce some of the pathological behaviors of FCT algorithms. Although the approach derived is applicable to the transport of arbitrary conserved quantities, it is particularly useful for the synchronous transport of mass and momenta in elastic flows, where it assures intrinsic stability of the algorithm regardless of the magnitude of the mass-density variable. This latter property becomes especially important in fluids with large density variations, or in models with a material “vertical” coordinate (e.g., geophysical hydrostatic stratified flows in isopycnic/isentropic coordinates), where material surfaces can collapse to zero-mass layers admitting, therefore, arbitrarily large local Courant numbers.} +} diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/Makefile b/V4.0/nemo_sources/tools/ABL_TOOLS/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..3a3546ee216c94665a77716dd7bae44cc0fde679 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/Makefile @@ -0,0 +1,62 @@ +SHELL = /bin/bash +#------------------------------------------------------------------------------------------------------------- +EXEC_BIN = vinterp_abl_frc.exe +EXEC_BIN2 = uvg_hpg_abl_frc.exe +EXEC_BIN3 = drown_abl_frc.exe + +NETCDF := $(NETCDF_DIR) +NETCDF_LIB := -L$(NETCDF)/lib -lnetcdf -lnetcdff +NETCDF_INC := -I$(NETCDF)/include + +#FC := gfortran +#FFLAGS := -fdefault-real-8 -fdefault-double-8 -O3 $(NETCDF_INC) +#FFLAGS := -g -O0 -fcheck=bounds -Wall -Wextra -fbacktrace -finit-real=snan -finit-integer=8888 -finit-character=90 $(NETCDF_INC) + +FC := ifort +FFLAGS := -check noarg_temp_created -autodouble -O3 $(NETCDF_INC) +#FFLAGS := -check noarg_temp_created -autodouble -O0 -g -traceback -check all $(NETCDF_INC) + +#--------------------------------------------------------------------- +SRC_DIR = $(PWD) +OBJ_DIR = $(PWD) +FINAL_OBJS = $(OBJ_DIR)/main_vinterp.o $(OBJ_DIR)/module_io.o $(OBJ_DIR)/module_interp.o $(OBJ_DIR)/module_grid.o +FINAL_OBJS2 = $(OBJ_DIR)/main_uvg_hpg.o $(OBJ_DIR)/module_io.o $(OBJ_DIR)/module_grid.o +FINAL_OBJS3 = $(OBJ_DIR)/main_drown.o $(OBJ_DIR)/module_io.o $(OBJ_DIR)/module_grid.o +#--------------------------------------------------------------------- + +all: | $(EXEC_BIN) $(EXEC_BIN2) $(EXEC_BIN3) + @echo + @echo =================================================== + @echo ABL Preprocessing tools for ECMWF data: OK + @echo =================================================== + @echo + +clean: + $(RM) $(OBJ_DIR)/*.o *.mod + $(RM) $(EXEC_BIN) $(EXEC_BIN2) $(EXEC_BIN3) + +$(EXEC_BIN): $(FINAL_OBJS) + $(FC) -o $(EXEC_BIN) $(FINAL_OBJS) $(NETCDF_LIB) + +$(EXEC_BIN2): $(FINAL_OBJS2) + $(FC) -o $(EXEC_BIN2) $(FINAL_OBJS2) $(NETCDF_LIB) + +$(EXEC_BIN3): $(FINAL_OBJS3) + $(FC) -o $(EXEC_BIN3) $(FINAL_OBJS3) $(NETCDF_LIB) + +# Rules +.DEFAULT: + +.SUFFIXES: + +.PRECIOUS: $(SRC_DIR)/%.F90 + +$(OBJ_DIR)/%.o : $(SRC_DIR)/%.F90 + $(FC) $(FFLAGS) -o $@ -c $< + +$(OBJ_DIR)/main_vinterp.o: $(OBJ_DIR)/module_grid.o $(OBJ_DIR)/module_io.o $(OBJ_DIR)/module_interp.o +$(OBJ_DIR)/main_uvg_hpg.o: $(OBJ_DIR)/module_grid.o $(OBJ_DIR)/module_io.o +$(OBJ_DIR)/main_drown.o: $(OBJ_DIR)/module_grid.o $(OBJ_DIR)/module_io.o +$(OBJ_DIR)/module_io.o: +$(OBJ_DIR)/module_interp.o: +$(OBJ_DIR)/module_grid.o: $(OBJ_DIR)/module_io.o diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/main_drown.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/main_drown.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6ddd32ab90c803903d9145d6e9e0cb5f05f2d4a8 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/main_drown.F90 @@ -0,0 +1,347 @@ +PROGRAM main + !!====================================================================== + !! *** PROGRAM main *** + !! + !! ** Purpose : horizontal extrapolation ("drowning") of ECMWF dataset + !! + !! + !!====================================================================== + !! History : 2016-10 (F. Lemarié) Original code largely inspired by SOSIE (L. Brodeau & J.M. Molines) + !! + !!---------------------------------------------------------------------- + USE module_io ! I/O routines + USE module_grid ! compute input and output grids + !! + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! + !! + !! + !!---------------------------------------------------------------------- + ! + INTEGER :: ji,jj,jk,kt,kv,jjp1,jjm1,jip1,jim1 + INTEGER :: jpka,jpvar ! number of vertical levels for input and target grids + INTEGER :: jpi , jpj ! number of grid points in x and y directions + INTEGER :: jptime,ctrl,niter,status,ncid + INTEGER :: ioerr + INTEGER, PARAMETER :: stdout = 6 + INTEGER, PARAMETER :: max_iter = 50 + !! + REAL(8) :: cff,cff1,cff2 + !! + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: varin + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: tmask, tmask2, ff_t + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: mask_coast, maskv ! land-sea mask + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: varold,varnew + REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d, lat + !! + CHARACTER(len=500) :: file_u,file_v,file_hpg,file_geos ! ERAi files containing wind components + CHARACTER(len=500) :: file_t,file_q, file_m ! ERAi files containing tracers and mask + CHARACTER(len=500) :: file_z,file_p,cn_dir ! ERAi files containing surface geopot and pressure + CHARACTER(len=500) :: abl_file, grd_file, drwn_file, out_file + CHARACTER(len=500) :: namelistf + CHARACTER(len=500) :: argument + CHARACTER(len= 20), DIMENSION(4) :: dimnames + CHARACTER(:), ALLOCATABLE, DIMENSION(:) :: varnames + CHARACTER(6) :: mask_var ! name of mask variable in file_m file + CHARACTER(6) :: var_name + !! + LOGICAL :: ln_read_zsurf ! read surface geopotential or not + LOGICAL :: ln_read_mask ! read land-sea mask or not + LOGICAL :: ln_perio_latbc ! use periodic BC along the domain latitudinal edges (for global data) or use zero-gradient BC (for regional data) + LOGICAL :: ln_c1d ! output only a single column in output file + LOGICAL :: ln_hpg_frc ! compute horizontal pressure gradient + LOGICAL :: ln_geo_wnd ! compute goestrophic wind components + LOGICAL :: ln_slp_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_drw_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_slp_log ! log(sea-level pressure) or sea-level pressure + LOGICAL :: ln_lsm_land ! if T mask is 1 over land and 0 over ocean if F it is the other way around + INTEGER :: ptemp_method ! way to compute potential temperature + !! + REAL(8), PARAMETER :: omega = 7.292116e-05 + REAL(8), PARAMETER :: rad = 3.141592653589793 / 180. + + + !!--------------------------------------------------------------------- + !! List of variables read in the namelist file + NAMELIST/nml_out/ grd_file, abl_file, drwn_file, var_name + NAMELIST/nml_opt/ ptemp_method, ln_slp_log, ln_slp_smth, ln_read_mask, ln_perio_latbc, & + & ln_hpg_frc, ln_geo_wnd, ln_c1d, ln_read_zsurf, ln_lsm_land, ln_drw_smth + NAMELIST/nml_fld/ cn_dir, file_u, file_v, file_t, & + & file_q, file_z, file_p, file_hpg, file_geos, & + & file_m, mask_var + !! + !! get the namelist file name + CALL get_command_argument(1, argument, ctrl, status) + ! + SELECT CASE(status) + CASE(0) + namelistf = trim(argument) + CASE(-1) + WRITE(stdout,*) "### Error: file name too long" + STOP + CASE DEFAULT + namelistf = 'namelist_abl_tools' + END SELECT + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! read namelist variables + ctrl = 0 + OPEN(50, file=namelistf, status='old', form='formatted', access='sequential', iostat=ioerr) + IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_opt, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_fld, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_out, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + + IF (ctrl > 0) then + WRITE(stdout,*) "### E R R O R while reading namelist file '",trim(namelistf),"'" + WRITE(stdout,*) " ctrl = ",ctrl + STOP + ELSE + WRITE(stdout,*) " Namelist file ",trim(namelistf)," OK " + END IF + !!------------------------------------------------------------------------------------- + !! list of variables to treat + !! + !! get the variable name + CALL get_command_argument( 2, argument, ctrl, status) + SELECT CASE(status) + CASE(0) + var_name = trim(argument) + CASE(-1) + WRITE(stdout,*) "### Error: file name too long" + STOP + END SELECT + WRITE(stdout,*) "var_name: ", trim(var_name), Len_Trim(var_name) + ! + IF (Len_Trim(var_name) == 0) THEN + jpvar = 7 + allocate(character(len=20) :: varnames(jpvar) ) + varnames(1:5) = [character(len=4) :: 'slp', 'uwnd', 'vwnd', 'tair', 'humi' ] + IF (ln_hpg_frc) varnames(6:7) = [character(len=4) :: 'uhpg', 'vhpg' ] + IF (ln_geo_wnd) varnames(6:7) = [character(len=4) :: 'ugeo', 'vgeo' ] + IF( .NOT. Var_Existence( varnames(5), trim(cn_dir)//'/'//trim(abl_file) ) ) jpvar = jpvar - 1 + IF( .NOT. Var_Existence( varnames(6), trim(cn_dir)//'/'//trim(abl_file) ) ) jpvar = jpvar - 1 + ELSE + jpvar = 1 + allocate(character(len=20) :: varnames(jpvar) ) + varnames = var_name + abl_file = trim(var_name)//'_'//trim( abl_file) + drwn_file = trim(var_name)//'_'//trim(drwn_file) + END IF + WRITE(stdout,*) "Number of variables to treat : ",jpvar + !!------------------------------------------------------------------------------------- + !! read the dimensions for the input files + CALL Read_Ncdf_dim ( 'jpka' , trim(cn_dir)//'/'//trim(abl_file), jpka ) + CALL Read_Ncdf_dim ( 'time' , trim(cn_dir)//'/'//trim(abl_file), jptime ) + CALL Read_Ncdf_dim ( 'lon' , trim(cn_dir)//'/'//trim(abl_file), jpi ) + CALL Read_Ncdf_dim ( 'lat' , trim(cn_dir)//'/'//trim(abl_file), jpj ) + WRITE(stdout,*) "jpka, jptime, jpi, jpj: ", jpka, jptime, jpi, jpj + ! + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! allocate arrays + ALLOCATE(varin (1:jpi,1:jpj,1:jpka,1)) + ALLOCATE(tmask (1:jpi,1:jpj )) + ALLOCATE(tmask2(1:jpi,1:jpj )) + ALLOCATE(maskv (1:jpi,1:jpj )) + ALLOCATE(mask_coast (1:jpi,1:jpj )) + ALLOCATE(varold (1:jpi,1:jpj )) + ALLOCATE(varnew (1:jpi,1:jpj )) + + !!--------------------------------------------------------------------- + !! Read the mask and remove some closed seas + IF (ln_read_mask) THEN + CALL init_atm_mask(jpi,jpj,trim(cn_dir)//'/'//trim(file_m),trim(mask_var),ln_lsm_land, tmask ) + CALL Read_Ncdf_var ( 'tmask' , trim(cn_dir)//'/'//trim(abl_file), tmask2(:,:) ) + ELSE + tmask(:,:) = 1. + tmask2(:,:) = 1. + END IF + !! + + + + !!--------------------------------------------------------------------- + !! create output file + !! + out_file = trim(cn_dir)//'/'//trim(drwn_file) + CALL Init_output_File ( jpi, jpj, jpka-1, trim(cn_dir)//'/'//trim(abl_file), out_file, tmask(:,:) ) + + !!--------------------------------------------------------------------- + !! Initialize the name of the dimensions for the result of the drowning + !! + dimnames(1) = 'lon' + dimnames(2) = 'lat' + dimnames(3) = 'jpka' + dimnames(4) = 'time' + + CALL Write_Ncdf_var( 'tmask', dimnames(1:2), trim(out_file), tmask2, 'float' ) + + !!--------------------------------------------------------------------- + ! Read time variable + ALLOCATE(tmp1d (1:jptime)) + ALLOCATE(lat (1:jpj)) + CALL Read_Ncdf_var ( 'time', trim(cn_dir)//'/'//trim(file_t), tmp1d ) + CALL Read_Ncdf_var ( 'lat' , trim(cn_dir)//'/'//trim(file_t), lat ) !<-- latitude + !!--------------------------------------------------------------------- + + ! force drowning in the equatorial band with geo wind + IF (ln_geo_wnd) THEN + ALLOCATE( ff_t(1:jpi,1:jpj) ) + DO jj = 1, jpj + DO ji = 1, jpi + ff_t(ji,jj) = 2. * omega * SIN( rad * lat(jj) ) + IF (abs(ff_t(ji,jj)) < 2.5e-5) tmask2(ji,jj) = 0. + END DO + END DO + END IF + + !=========== + DO kv = 1,jpvar + !=========== + DO kt = 1,jptime + !=========== + + IF( kv == 1 ) THEN + CALL Write_Ncdf_var( 'time', dimnames(4:4), trim(out_file), tmp1d(kt:kt), kt, 'double' ) + ENDIF + + ! Read variable to treat + print*,'Treat variable ',trim(varnames(kv)),' at time level ',kt + IF (trim(varnames(kv)).EQ."slp") THEN + CALL Read_Ncdf_var ( trim(varnames(kv)), trim(cn_dir)//'/'//trim(file_hpg), varin(:,:,1,1), kt ) + ELSE + CALL Read_Ncdf_var ( trim(varnames(kv)), trim(cn_dir)//'/'//trim(abl_file), varin, kt ) + END IF + + + !=========== + DO jk = 1,jpka + !=========== + + IF ( (trim(varnames(kv))=="uwnd").OR.(trim(varnames(kv))=="vwnd").OR. & + & (trim(varnames(kv))=="ugeo").OR.(trim(varnames(kv))=="vgeo").OR. & + & (trim(varnames(kv))=="uhpg").OR.(trim(varnames(kv))=="vhpg") ) THEN + maskv (1:jpi,1:jpj ) = tmask2(1:jpi,1:jpj ) + ELSE + maskv (1:jpi,1:jpj ) = tmask(1:jpi,1:jpj ) + END IF + + + varold (1:jpi,1:jpj) = varin(1:jpi,1:jpj,jk,1) + varnew (1:jpi,1:jpj) = varin(1:jpi,1:jpj,jk,1) + mask_coast(1:jpi,1:jpj) = 0. + + !$$$$$$$$$$$$$$$$ + DO niter = 1, max_iter + !$$$$$$$$$$$$$$$$ + + varold(1:jpi,1:jpj) = varnew (1:jpi,1:jpj) + + IF ( .NOT. (ANY(maskv == 0)) ) THEN + EXIT + END IF + + !+++++++++++++++++++++++++++++++++++ + ! Build mask_coast + DO jj = 1,jpj + DO ji = 1,jpi + + IF (ln_perio_latbc) THEN + jip1 = ji + 1; if(ji==jpi) jip1 = 1 + jim1 = ji - 1; if(ji== 1) jim1 = jpi + ELSE + jip1 = ji + 1; if(ji==jpi) jip1 = jpi-1 + jim1 = ji - 1; if(ji== 1) jim1 = 2 + END IF + jjp1 = jj + 1; if(jj==jpj) jjp1 = jpj-1 + jjm1 = jj - 1; if(jj== 1) jjm1 = 2 + + cff = (1.-maskv(ji,jj)) + cff1 = maskv(ji,jjp1)+maskv(jip1,jj)+maskv(jim1,jj)+maskv(ji,jjm1) + mask_coast(ji,jj) = cff * cff1 + IF( mask_coast(ji,jj) > 0. ) mask_coast(ji,jj) = 1. + + END DO + END DO + !+++++++++++++++++++++++++++++++++++ + + DO jj=1,jpj + DO ji=1,jpi + + IF ( mask_coast(ji,jj) == 1. ) THEN + + IF (ln_perio_latbc) THEN + jip1 = ji + 1; if(ji==jpi) jip1 = 1 + jim1 = ji - 1; if(ji== 1) jim1 = jpi + ELSE + jip1 = ji + 1; if(ji==jpi) jip1 = jpi-1 + jim1 = ji - 1; if(ji== 1) jim1 = 2 + END IF + jjp1 = jj + 1; if(jj==jpj) jjp1 = jpj-1 + jjm1 = jj - 1; if(jj== 1) jjm1 = 2 + + cff = maskv(jim1,jjm1)+maskv(jim1,jj)+maskv(jim1,jjp1) & + & + maskv(ji ,jjm1)+ maskv(ji ,jjp1) & + & + maskv(jip1,jjm1)+maskv(jip1,jj)+maskv(jip1,jjp1) + + varnew(ji,jj) = (1./cff)*( & + & varold(jim1,jjm1)*maskv(jim1,jjm1) & + & + varold(jim1,jj )*maskv(jim1,jj ) & + & + varold(jim1,jjp1)*maskv(jim1,jjp1) & + & + varold(ji ,jjm1)*maskv(ji ,jjm1) & + & + varold(ji ,jjp1)*maskv(ji ,jjp1) & + & + varold(jip1,jjm1)*maskv(jip1,jjm1) & + & + varold(jip1,jj )*maskv(jip1,jj ) & + & + varold(jip1,jjp1)*maskv(jip1,jjp1) ) + + END IF + + END DO + END DO + !+++++++++++++++++++++++++++++++++++ + maskv(1:jpi,1:jpj) = maskv(1:jpi,1:jpj) + mask_coast(1:jpi,1:jpj) + !+++++++++++++++++++++++++++++++++++ + !$$$$$$$$$$$$$$$$ + END DO + !$$$$$$$$$$$$$$$$ + + ! SMOOTHING AFTER DROWNING + IF (ln_drw_smth) THEN + maskv (1:jpi,1:jpj ) = 1. + ELSE + !!only over continent + maskv (1:jpi,1:jpj ) = 1. - tmask(1:jpi,1:jpj ) + END IF + + CALL smooth_field( jpi, jpj, varnew, maskv, 3 ) + varin(1:jpi,1:jpj,jk,1) = varnew(1:jpi,1:jpj) + + IF (trim(varnames(kv)).EQ."slp") EXIT + + !=========== + END DO ! jk + !=========== + + IF (trim(varnames(kv)).EQ."slp") THEN + CALL Write_Ncdf_var ( trim(varnames(kv)), dimnames(1:4), trim(cn_dir)//'/'//drwn_file, varin(:,:,1,1), kt, 'float' ) + ELSE + CALL Write_Ncdf_var ( trim(varnames(kv)), dimnames(1:4), trim(cn_dir)//'/'//drwn_file, varin(:,:,:,:), kt, 'float' ) + END IF + + !=========== + END DO ! time + !=========== + + !=========== + END DO ! variable + !=========== + + STOP + ! +END PROGRAM main diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/main_uvg_hpg.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/main_uvg_hpg.F90 new file mode 100644 index 0000000000000000000000000000000000000000..04a54204f3212dbbc2d7feacd84514041ce73ee9 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/main_uvg_hpg.F90 @@ -0,0 +1,647 @@ +PROGRAM main + !!====================================================================== + !! *** PROGRAM main *** + !! + !! ** Purpose : compute geostrophic wind or horizontal pressure gradient + !! from ECMWF atmospheric model vertical levels altitude, + !! temperature and humidity 3D fields + !! + !!====================================================================== + !! History : 2016-10 (F. Lemarié) Original code + !! + !!---------------------------------------------------------------------- + USE module_io ! I/O routines + USE module_grid ! compute input and output grids + !! + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! + !! + !! + !!---------------------------------------------------------------------- + ! + INTEGER :: ji,jj,jk,kt, nhym, nhyi + INTEGER :: jpka ! number of vertical levels for input and target grids + INTEGER :: jpi , jpj ! number of grid points in x and y directions + INTEGER :: status + INTEGER :: jptime,ctrl + INTEGER :: ioerr,ncid + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ind + INTEGER, PARAMETER :: stdout = 6 + !! + REAL(8) :: cff,tv + !! + REAL(8), ALLOCATABLE, DIMENSION(: ) :: lev ! A coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: A_w ! A coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: B_w ! B coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: B_r ! B coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: A_r ! A coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: ph,lon,lat + REAL(8), ALLOCATABLE, DIMENSION(:,:,: ) :: e3t,ghw ! thickness of vertical layers in target grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d, tmp_fullw, tmp_fullm ! temporary/working 1D arrays + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: humi + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: temp + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: uhpg + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: vhpg + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: slp, zsurf, zsurf_smth, slp_smth, ghw_smth !, slp_mask, ghw_mask + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: dx,dy,ff_t,tmask, tmask2 + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: FX,FE,wrkx,wrke + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: dZx,dZe + !! + CHARACTER(len=500) :: file_u,file_v,file_hpg, file_geos ! ECMWF files containing wind components + CHARACTER(len=500) :: file_t,file_q, file_m ! ECMWF files containing tracers and mask + CHARACTER(len=500) :: file_z,file_p,cn_dir ! ECMWF files containing surface geopot and pressure + CHARACTER(len=500) :: out_file + CHARACTER(len=500) :: namelistf + CHARACTER(len=500) :: argument + CHARACTER(len= 20),DIMENSION(4) :: dimnames + CHARACTER(len= 20),DIMENSION(4) :: varnames + CHARACTER(6) :: mask_var ! name of mask variable in file_m file + !! + LOGICAL :: ln_read_zsurf ! read surface geopotential or not + LOGICAL :: ln_read_mask ! read land-sea mask or not + LOGICAL :: ln_perio_latbc ! use periodic BC along the domain latitudinal edges (for global data) or use zero-gradient BC (for regional data) + LOGICAL :: ln_c1d ! output only a single column in output file + LOGICAL :: ln_hpg_frc ! compute horizontal pressure gradient + LOGICAL :: ln_geo_wnd ! compute goestrophic wind components + LOGICAL :: ln_slp_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_drw_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_slp_log ! log(sea-level pressure) or sea-level pressure + LOGICAL :: ln_lsm_land ! if T mask is 1 over land and 0 over ocean if F it is the other way around + LOGICAL :: ln_impose_z1 ! impose the altitude of the first level in target grid + INTEGER :: ptemp_method ! way to compute potential temperature + ! = 0 (absolute temperature) + ! = 1 (potential temperature with local ref pressure) + ! = 2 (potential temperature with global ref pressure on temperature perturbation) + ! = 3 (potential temperature with global ref pressure) + !! + REAL(8), PARAMETER :: grav = 9.80665 + REAL(8), PARAMETER :: Rd = 287.058 + REAL(8), PARAMETER :: zvir = 0.609133 + REAL(8), PARAMETER :: omega = 7.292116e-05 + REAL(8), PARAMETER :: rad = 3.141592653589793 / 180. + REAL(8), PARAMETER :: rt = 6371229. + REAL(8), PARAMETER :: lat_smth = 0. !65. !!GS: possibility to smooth only above a selected latitude + + + !!--------------------------------------------------------------------- + !! List of variables read in the namelist file + NAMELIST/nml_opt/ ptemp_method, ln_slp_log, ln_slp_smth, ln_read_mask, ln_perio_latbc, & + & ln_hpg_frc, ln_geo_wnd, ln_c1d, ln_read_zsurf, ln_lsm_land, ln_drw_smth + NAMELIST/nml_fld/ cn_dir, file_u, file_v, file_t, & + & file_q, file_z, file_p, file_hpg, file_geos, & + & file_m, mask_var + !! + !! get the namelist file name + CALL get_command_argument( 1, argument, ctrl, status) + ! + SELECT CASE(status) + CASE(0) + namelistf = trim(argument) + CASE(-1) + WRITE(stdout,*) "### Error: file name too long" + STOP + CASE DEFAULT + namelistf = 'namelist_abl_tools' + END SELECT + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! read namelist variables + ctrl = 0 + OPEN(50, file=namelistf, status='old', form='formatted', access='sequential', iostat=ioerr) + IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_opt, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_fld, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + + IF (ctrl > 0) then + WRITE(stdout,*) "### E R R O R while reading namelist file '",trim(namelistf),"'" + WRITE(stdout,*) " ctrl = ",ctrl + STOP + ELSE + WRITE(stdout,*) " Namelist file ",trim(namelistf), " OK " + END IF + + IF(ln_hpg_frc) THEN + out_file = trim(cn_dir)//'/'//trim(file_hpg) + ELSE IF(ln_geo_wnd) THEN + out_file = trim(cn_dir)//'/'//trim(file_geos) + ELSE + WRITE(stdout,*) "### E R R O R in namelist variable " + WRITE(stdout,*) "either ln_hpg_frc or ln_geo_wnd should be set to True" + STOP + END IF + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + ! check files content + CALL Read_Ncdf_dim('lev',trim(cn_dir)//'/'//trim(file_t),jpka) + ! geop_surf temp humi pressure + varnames = [ character(len=3) :: 'Z', 'T', 'Q', 'MSL' ] + IF (ln_read_zsurf) varnames(4) = "SP" + IF (ln_slp_log) varnames(4) = "LNSP" + + ctrl = 0 + IF (ln_read_zsurf) THEN + IF( .not. VAR_EXISTENCE( trim(varnames(1)) , trim(cn_dir)//'/'//trim(file_z) ) ) ctrl = ctrl + 1 + END IF + IF ( .not. VAR_EXISTENCE( trim(varnames(2)) , trim(cn_dir)//'/'//trim(file_t) ) ) ctrl = ctrl + 1 + IF ( .not. VAR_EXISTENCE( trim(varnames(3)) , trim(cn_dir)//'/'//trim(file_q) ) ) ctrl = ctrl + 1 + IF ( .not. VAR_EXISTENCE( trim(varnames(4)) , trim(cn_dir)//'/'//trim(file_p) ) ) ctrl = ctrl + 1 + WRITE(*,*) " pressure variable name: ", varnames(4) + + IF ( ctrl > 0 ) THEN + WRITE(stdout,*) "### E R R O R while reading ECMWF atmospheric files " + STOP + ELSE + WRITE(stdout,*) " ECMWF atmospheric files OK " + END IF + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! read the dimensions for the input files + CALL Read_Ncdf_dim ( 'time', trim(cn_dir)//'/'//trim(file_t), jptime ) + CALL Read_Ncdf_dim ( 'lon' , trim(cn_dir)//'/'//trim(file_t), jpi ) + CALL Read_Ncdf_dim ( 'lat' , trim(cn_dir)//'/'//trim(file_t), jpj ) + CALL Read_Ncdf_dim ( 'nhym' , trim(cn_dir)//'/'//trim(file_t), nhym ) + CALL Read_Ncdf_dim ( 'nhyi' , trim(cn_dir)//'/'//trim(file_t), nhyi ) + ! + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! allocate arrays + ALLOCATE( A_w ( 0:jpka ) ) + ALLOCATE( B_w ( 0:jpka ) ) + ALLOCATE( B_r ( 1:jpka ) ) + ALLOCATE( A_r ( 1:jpka ) ) + + ALLOCATE( e3t ( 1:jpi, 1:jpj, 1:jpka ) ) + ALLOCATE( ghw ( 1:jpi, 1:jpj, 0:jpka ) ) + ALLOCATE( slp_smth(1:jpi, 1:jpj ) ) + ALLOCATE( ghw_smth(1:jpi, 1:jpj ) ) + ALLOCATE( slp ( 1:jpi, 1:jpj ) ) + ALLOCATE( zsurf ( 1:jpi, 1:jpj ) ) + ALLOCATE( zsurf_smth ( 1:jpi, 1:jpj ) ) + ALLOCATE( temp ( 1:jpi, 1:jpj, 1:jpka, 1) ) + ALLOCATE( humi ( 1:jpi, 1:jpj, 1:jpka, 1) ) + ALLOCATE( uhpg ( 1:jpi, 1:jpj, 1:jpka, 1) ) + ALLOCATE( vhpg ( 1:jpi, 1:jpj, 1:jpka, 1) ) + ALLOCATE( ph ( 0:jpka ) ) + ALLOCATE( dx ( 1:jpi, 1:jpj ) ) + ALLOCATE( dy ( 1:jpi, 1:jpj ) ) + ALLOCATE( FX ( 1:jpi, 1:jpj ) ) + ALLOCATE( FE ( 1:jpi, 1:jpj ) ) + ALLOCATE( dzx ( 0:jpi, 1:jpj ) ) + ALLOCATE( dze ( 1:jpi, 0:jpj ) ) + ALLOCATE( wrkx ( 1:jpi, 1:jpj ) ) + ALLOCATE( wrke ( 1:jpi, 1:jpj ) ) + ALLOCATE( tmask ( 1:jpi, 1:jpj ) ) + ALLOCATE( tmask2 ( 1:jpi, 1:jpj ) ) + IF (jpka.NE.nhym) THEN + ALLOCATE( tmp_fullw(1:nhyi) ) + ALLOCATE( tmp_fullm(1:nhym) ) + END IF + + !!--------------------------------------------------------------------- + !! Read the mask and remove some closed seas + IF (ln_read_mask) THEN + CALL init_atm_mask( jpi, jpj, trim(cn_dir)//'/'//trim(file_m), trim(mask_var), ln_lsm_land, tmask) + ELSE + tmask(:,:) = 1. + END IF + tmask2 = tmask + !! + + !! Read the static A and B coefficients for the ECMWF vertical grid + IF (jpka.EQ.nhym) THEN + CALL Read_Ncdf_var ( 'hyai', trim(cn_dir)//'/'//trim(file_t), A_w ) + CALL Read_Ncdf_var ( 'hybi', trim(cn_dir)//'/'//trim(file_t), B_w ) + CALL Read_Ncdf_var ( 'hyam', trim(cn_dir)//'/'//trim(file_t), A_r ) + CALL Read_Ncdf_var ( 'hybm', trim(cn_dir)//'/'//trim(file_t), B_r ) + ELSE + CALL Read_Ncdf_var ( 'hyai', trim(cn_dir)//'/'//trim(file_t), tmp_fullw ) + A_w(0:jpka) = tmp_fullw(nhyi-(jpka+1)+1:nhyi) + CALL Read_Ncdf_var ( 'hybi', trim(cn_dir)//'/'//trim(file_t), tmp_fullw ) + B_w(0:jpka) = tmp_fullw(nhyi-(jpka+1)+1:nhyi) + CALL Read_Ncdf_var ( 'hyam', trim(cn_dir)//'/'//trim(file_t), tmp_fullm ) + A_r(1:jpka) = tmp_fullm(nhym-jpka+1:nhym) + CALL Read_Ncdf_var ( 'hybm', trim(cn_dir)//'/'//trim(file_t), tmp_fullm ) + B_r(1:jpka) = tmp_fullm(nhym-jpka+1:nhym) + END IF + + ALLOCATE(lat(1:jpj),lon(1:jpi),ff_t(1:jpi,1:jpj),lev(1:jpka)) + CALL Read_Ncdf_var ( 'lon' , trim(cn_dir)//'/'//trim(file_t), lon ) !<-- longitude + CALL Read_Ncdf_var ( 'lat' , trim(cn_dir)//'/'//trim(file_t), lat ) !<-- latitude + CALL Read_Ncdf_var ( 'lev' , trim(cn_dir)//'/'//trim(file_t), lev ) + + + !!--------------------------------------------------------------------- + !++ Compute Coriolis frequency at cell centers + ! + DO jj = 1, jpj + DO ji = 1, jpi + ff_t(ji,jj) = 2. * omega * SIN( rad * lat(jj) ) + END DO + END DO + + + !!--------------------------------------------------------------------- + !++ Compute dx and dy at cell centers + ! + dx(:,:) = 0. + dy(:,:) = 0. + DO jj = 2, jpj-1 + DO ji = 1, jpi-1 + dx(ji,jj) = rt * rad * abs( lon(ji+1) - lon(ji) ) * COS( rad * lat(jj) ) + END DO + END DO + dx( jpi,1:jpj) = dx( jpi-1,1:jpj ) + dx(1:jpi, jpj) = dx(1:jpi , jpj-1) + dx(1:jpi,1 ) = dx(1:jpi ,2 ) + !++ + DO jj = 1, jpj-1 + DO ji = 1, jpi + dy(ji,jj) = rt * rad * abs( lat(jj+1) - lat(jj) ) + END DO + END DO + dy(1:jpi,jpj) = dy(1:jpi,jpj-1) + + + !!--------------------------------------------------------------------- + !! create output file + !! + status = nf90_create( trim(out_file), NF90_WRITE, ncid ) + status = nf90_close ( ncid ) + + CALL Write_Ncdf_dim ( 'lon' , trim(out_file), jpi ) + CALL Write_Ncdf_dim ( 'lat' , trim(out_file), jpj ) + CALL Write_Ncdf_dim ( 'lev' , trim(out_file), jpka ) + CALL Write_Ncdf_dim ( 'nhym' , trim(out_file), jpka ) + CALL Write_Ncdf_dim ( 'nhyi' , trim(out_file), jpka+1 ) + CALL Write_Ncdf_dim ( 'time' , trim(out_file), 0 ) + + + !!--------------------------------------------------------------------- + !! Initialize the name of the dimensions for geostrophic winds in the output file + !! + dimnames(1) = 'lon' + dimnames(2) = 'lat' + dimnames(3) = 'lev' + dimnames(4) = 'time' + + CALL Write_Ncdf_var( 'lon', 'lon', trim(out_file), lon, 'double' ) + CALL Write_Ncdf_var( 'lat', 'lat', trim(out_file), lat, 'double' ) + CALL Write_Ncdf_var( 'lev', 'lev', trim(out_file), lev, 'double' ) + CALL Write_Ncdf_var( 'hyai', 'nhyi', trim(out_file), A_w, 'double' ) + CALL Write_Ncdf_var( 'hybi', 'nhyi', trim(out_file), B_w, 'double' ) + CALL Write_Ncdf_var( 'hyam', 'nhym', trim(out_file), A_r, 'double' ) + CALL Write_Ncdf_var( 'hybm', 'nhym', trim(out_file), B_r, 'double' ) + + CALL Write_Ncdf_var( 'tmask', dimnames(1:2), trim(out_file), tmask, 'float' ) + + + !!--------------------------------------------------------------------- + ! Read time variable + ALLOCATE(tmp1d (1:jptime)) + CALL Read_Ncdf_var ( 'time', trim(cn_dir)//'/'//trim(file_t), tmp1d ) + !!--------------------------------------------------------------------- + + + DO kt=1,jptime + ! + WRITE(stdout,*) '======================' + WRITE(stdout,*) 'time = ',kt,'/',jptime + ! + CALL Write_Ncdf_var( 'time', dimnames(4:4), trim(out_file), tmp1d(kt:kt), kt, 'double' ) + ! + IF( kt == 1 ) THEN + CALL Duplicate_lon_lat_time( trim(cn_dir)//'/'//trim(file_t), out_file ) + CALL Duplicate_lev_hyb ( trim(cn_dir)//'/'//trim(file_t), out_file ) + ENDIF + ! + IF ( varnames(4) == "LNSP" ) THEN + CALL Read_Ncdf_var( varnames(4) , trim(cn_dir)//'/'//trim(file_p), slp(:,:), kt, 1 ) !<-- log of surface pressure + ELSE + CALL Read_Ncdf_var( varnames(4) , trim(cn_dir)//'/'//trim(file_p), slp(:,:), kt ) + END IF + ! + IF (ln_slp_log) THEN + DO jj = 1, jpj + DO ji = 1, jpi + slp(ji,jj) = exp( slp(ji,jj) ) + END DO + END DO + ENDIF + ! + IF (ln_read_zsurf) THEN + CALL Read_Ncdf_var( varnames(1) , trim(cn_dir)//'/'//trim(file_z), zsurf(:,:), kt, 1 ) !<-- surface geopotential + ELSE + zsurf(:,:) = 0. + END IF + ! + CALL Read_Ncdf_var ( varnames(2), trim(cn_dir)//'/'//trim(file_t), temp(:,:,:,:), kt ) !<-- temperature + CALL Read_Ncdf_var ( varnames(3), trim(cn_dir)//'/'//trim(file_q), humi(:,:,:,:), kt ) !<-- humidity + WHERE(humi.LT.1.E-08) humi = 1.E-08 !<-- negative values in ECMWF + ! + ! Smoothing of surface fields to remove gibbs oscillations (must be done on both fields or none of them) + !IF( ln_slp_smth ) CALL smooth_field( jpi, jpj, slp (:,:), tmask(:,:), 3 ) + !IF (ln_read_zsurf.AND.ln_slp_smth) CALL smooth_field( jpi, jpj, zsurf(:,:), tmask(:,:), 3 ) + !IF( ln_slp_smth ) CALL DTV_Filter( jpi, jpj, slp(:,:), tmask(:,:,1), 25, kt ) !<-- not yet robust enough + + !!GS: DO NOT USE SMOOTH + LAND MASK FOR NOW (BUG) + IF( ln_slp_smth ) THEN + slp_smth(:,:) = slp(:,:) + wrke(:,:) = 1. + CALL smooth_field( jpi, jpj, slp_smth(:,1:jpj), wrke(:,1:jpj), 3 ) + IF (ln_read_zsurf) THEN + zsurf_smth(:,:) = zsurf(:,:) + CALL smooth_field( jpi, jpj, zsurf_smth(:,:), wrke(:,:), 3 ) + END IF + IF( ABS(lat_smth).GT.0.1) THEN + DO jj = 1, jpj + DO ji = 1, jpi + IF ((lat(jj).GE.lat_smth).OR.(lat(jj).LE.-1.*lat_smth)) THEN + slp(ji,jj) = slp_smth(ji,jj) + IF (ln_read_zsurf) zsurf(ji,jj) = zsurf_smth(ji,jj) + END IF + END DO + END DO + ELSE + slp(:,:) = slp_smth(:,:) + IF (ln_read_zsurf) zsurf(:,:) = zsurf_smth(:,:) + END IF + END IF + CALL Write_Ncdf_var( 'slp', dimnames(1:2), trim(out_file), slp(:,:), kt, 'float' ) + IF (ln_read_zsurf) CALL Write_Ncdf_var( 'zsurf', dimnames(1:2), trim(out_file), zsurf(:,:), kt, 'float' ) + + ! + ! Compute the altitude at layer interfaces + ghw(:,:,1:jpka) = 0. + ghw(:,:, jpka) = zsurf(:,:) * (1. / grav) ! * tmask(:,:) + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 0, jpka + ph(jk) = A_w( jk ) + B_w( jk ) * slp( ji, jj ) !<-- Pa + END DO + !ph(0) = 0.1 + IF ( nhym .EQ. jpka) ph(0) = 1. + DO jk = jpka,1,-1 + tv = temp( ji, jj, jk, 1 ) * ( 1. + zvir*humi( ji, jj, jk, 1 ) ) !<-- Virtual temperature + e3t ( ji, jj, jk ) = (1./grav)*( Rd * tv * log( ph( jk ) / ph( jk-1 ) ) ) !* tmask(ji, jj) + ghw ( ji, jj, jk-1 ) = e3t( ji, jj, jk ) + ghw( ji, jj, jk ) + END DO + END DO + END DO + + IF( ln_slp_smth ) THEN + wrke(:,:) = 1. + DO jk = 0, jpka + ghw_smth(:,:) = ghw(:,:,jk) + CALL smooth_field( jpi, jpj, ghw_smth(:,1:jpj), wrke(:,1:jpj), 3 ) + IF( ABS(lat_smth).GT.0.1) THEN + DO jj = 1, jpj + DO ji = 1, jpi + IF ((lat(jj).GE.lat_smth).OR.(lat(jj).LE.-1.*lat_smth)) ghw(ji,jj,jk) = ghw_smth(ji,jj) + END DO + END DO + ELSE + ghw(:,:,jk) = ghw_smth(:,:) + END IF + END DO + END IF + + ! + ! Compute horizontal gradient of slp in x-direction (FX = dslp / dx) + FX(:,:) = 0. + DO jj = 1, jpj + DO ji = 1, jpi-1 + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji+1,jj) .gt. 0.5)) THEN + cff = 2. / ( dx( ji+1,jj ) + dx( ji,jj ) ) + FX( ji ,jj ) = cff * ( slp( ji+1,jj ) - slp( ji,jj ) ) + ELSE + tmask2(ji:ji+1,jj) = 0. + END IF + END DO + END DO + + IF (ln_perio_latbc) THEN + ! apply periodicity + DO jj = 1, jpj + IF ((tmask(1,jj) .gt. 0.5).AND.(tmask(jpi,jj) .gt. 0.5)) THEN + cff = 2. / ( dx( 1, jj) + dx( jpi, jj) ) + FX( jpi , jj) = cff * ( slp( 1, jj) - slp( jpi, jj) ) + ELSE + tmask2( 1, jj) = 0. + tmask2( jpi, jj) = 0. + END IF + END DO + ELSE + ! apply no-gradient + DO jj = 1, jpj + FX( jpi ,jj ) = FX( jpi-1 ,jj ) + END DO + ENDIF + + ! + ! Compute horizontal gradient of slp in y-direction (FE = dslp / dy) + FE(:,:) = 0. + DO jj = 1, jpj-1 + DO ji = 1, jpi + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji,jj+1) .gt. 0.5)) THEN + cff = 2. / ( dy( ji,jj+1 ) + dy( ji,jj ) ) + FE( ji ,jj ) = cff * ( slp( ji,jj+1 ) - slp( ji,jj ) ) + ELSE + tmask2(ji,jj:jj+1) = 0. + END IF + END DO + END DO + + ! apply no-gradient + DO ji = 1, jpi + FE( ji ,jpj ) = FE( ji ,jpj-1 ) + END DO + + ! + !++ Compute the geostrophic winds + ! + dZx(:,:) = 0. + dZe(:,:) = 0. + wrkX(:,:) = 0. + wrkE(:,:) = 0. + !//////////// + DO jk=1,jpka + !//////////// + + ! + ! Compute horizontal gradient of altitude in x-direction along the coordinate dZx = (dz / dx)s + DO jj = 1, jpj + DO ji = 1, jpi-1 + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji+1,jj) .gt. 0.5)) THEN + cff = 1. / (dx(ji+1,jj)+dx(ji,jj)) + dZx(ji,jj) = cff * ( (ghw( ji+1, jj, jk-1) - ghw( ji, jj, jk-1)) & + & +(ghw( ji+1, jj, jk ) - ghw( ji, jj, jk )) ) + ELSE + tmask2(ji:ji+1,jj) = 0. + END IF + END DO + END DO + + IF (ln_perio_latbc) THEN + ! apply periodicity + DO jj = 1, jpj + IF ((tmask(1,jj) .gt. 0.5).AND.(tmask(jpi,jj) .gt. 0.5)) THEN + cff = 1. / (dx(1,jj)+dx(jpi,jj)) + dZx(jpi,jj) = cff * ( (ghw( 1, jj, jk-1) - ghw( jpi, jj, jk-1)) & + & +(ghw( 1, jj, jk ) - ghw( jpi, jj, jk )) ) + dZx( 0,jj) = dZx(jpi,jj) + ELSE + tmask2( 1, jj) = 0. + tmask2(jpi, jj) = 0. + END IF + END DO + ELSE + ! apply no-gradient + DO jj = 1, jpj + dZx(jpi,jj) = dZx(jpi-1,jj) + dZx( 0,jj) = dZx( 1,jj) + END DO + END IF + + ! + ! Compute horizontal gradient of altitude in y-direction along the coordinate dZy = (dz / dy)s + DO jj = 1, jpj-1 + DO ji = 1, jpi + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji,jj+1) .gt. 0.5)) THEN + cff = 1. / (dy(ji,jj)+dy(ji,jj+1)) + dZe(ji,jj) = cff * ( (ghw( ji, jj+1, jk-1) - ghw( ji, jj, jk-1)) & + & +(ghw( ji, jj+1, jk ) - ghw( ji, jj, jk )) ) + ELSE + tmask2(ji,jj:jj+1) = 0. + END IF + END DO + END DO + + ! apply no-gradient + DO ji = 1, jpi + dZe(ji,jpj) = dZe(ji,jpj-1) + dZe(ji, 0) = dZe(ji, 1) + END DO + + + ! Compute horizontal pressure gradient in x-direction along the coordinate wrkX = (dp/dx)s + DO jj = 1, jpj + DO ji = 2, jpi + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji-1,jj) .gt. 0.5)) THEN + cff = slp(ji,jj) * (B_w(jk)-B_w(jk-1)) + (A_w(jk)-A_w(jk-1)) + wrkX(ji,jj) = B_r(jk) * 0.5 * (FX(ji,jj)+FX(ji-1,jj)) & + & * (ghw(ji,jj,jk)-ghw(ji,jj,jk-1)) / cff + ELSE + tmask2(ji-1:ji,jj) = 0. + END IF + END DO + END DO + + IF (ln_perio_latbc) THEN + ! apply periodicity + ji = 1 + DO jj = 1, jpj + IF ((tmask(1,jj) .gt. 0.5).AND.(tmask(jpi,jj) .gt. 0.5)) THEN + cff = slp(ji,jj) * (B_w(jk)-B_w(jk-1)) + (A_w(jk)-A_w(jk-1)) + wrkX(ji,jj) = B_r(jk) * 0.5 * (FX(ji,jj)+FX(jpi,jj)) & + & * (ghw(ji,jj,jk)-ghw(ji,jj,jk-1)) / cff + ELSE + tmask2( 1,jj) = 0. + tmask2(jpi,jj) = 0. + END IF + END DO + ELSE + ! apply no gradient + DO jj = 1, jpj + wrkX(1,jj) = wrkX(2,jj) + END DO + END IF + + + ! Compute horizontal pressure gradient in y-direction along the coordinate wrkE = (dp/dy)s + DO jj = 2, jpj + DO ji = 1, jpi + IF ((tmask(ji,jj) .gt. 0.5).AND.(tmask(ji,jj-1) .gt. 0.5)) THEN + cff = slp(ji,jj) * (B_w(jk)-B_w(jk-1)) + (A_w(jk)-A_w(jk-1)) + wrkE(ji,jj) = B_r(jk) * 0.5 * (FE(ji,jj)+FE(ji,jj-1)) & + & * (ghw(ji,jj,jk)-ghw(ji,jj,jk-1)) / cff + ELSE + tmask2(ji,jj-1:jj) = 0. + END IF + END DO + END DO + + ! apply no gradient + jj = 1 + DO ji = 1, jpi + wrkE(ji,1) = wrkE(ji,2) + END DO + + + !+++ Finalize pressure gradient/geostrophic wind computation + IF(ln_hpg_frc) THEN + DO jj=1,jpj + DO ji=1,jpi + IF (tmask2(ji,jj).GT.0.5) THEN + uhpg(ji,jj,jk,1) = - grav*( wrkX(ji,jj) - 0.5*( dZx(ji,jj)+dZx(ji-1,jj ) ) ) + if (lat(1).GT.0.) vhpg(ji,jj,jk,1) = grav*( wrkE(ji,jj) - 0.5*( dZe(ji,jj)+dZe(ji ,jj-1) ) ) + if (lat(1).LT.0.) vhpg(ji,jj,jk,1) = - grav*( wrkE(ji,jj) - 0.5*( dZe(ji,jj)+dZe(ji ,jj-1) ) ) + ELSE + uhpg(ji,jj,jk,1) = 0. + vhpg(ji,jj,jk,1) = 0. + END IF + END DO + END DO + ELSE + DO jj=1,jpj + DO ji=1,jpi + IF (tmask2(ji,jj).GT.0.5) THEN + cff = grav / ff_t(ji,jj) + ! geostrophic wind computed only where Coriolis .ge. 3.e-5 (~12deg) + if(abs(ff_t(ji,jj)) < 2.5e-5) cff = 0. + ! minus sign for uhpg because y-derivatives are inverted + vhpg(ji,jj,jk,1) = - cff*( wrkX(ji,jj) - 0.5*( dZx(ji,jj)+dZx(ji-1,jj ) ) ) + if (lat(1).GT.0.) uhpg(ji,jj,jk,1) = - cff*( wrkE(ji,jj) - 0.5*( dZe(ji,jj)+dZe(ji ,jj-1) ) ) + if (lat(1).LT.0.) uhpg(ji,jj,jk,1) = cff*( wrkE(ji,jj) - 0.5*( dZe(ji,jj)+dZe(ji ,jj-1) ) ) + ELSE + uhpg(ji,jj,jk,1) = 0. + vhpg(ji,jj,jk,1) = 0. + END IF + END DO + END DO + ENDIF + + !//////////// + END DO ! jk + !//////////// + + IF (ln_geo_wnd) THEN + CALL Write_Ncdf_var ( 'ugeo', dimnames(1:4), trim(out_file), uhpg, kt, 'float' ) + CALL Write_Ncdf_var ( 'vgeo', dimnames(1:4), trim(out_file), vhpg, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ( 'uhpg', dimnames(1:4), trim(out_file), uhpg, kt, 'float' ) + CALL Write_Ncdf_var ( 'vhpg', dimnames(1:4), trim(out_file), vhpg, kt, 'float' ) + END IF + + IF (kt .EQ. 1) THEN + tmask2(:,1) = 0. ! force northern v line drowning + tmask2(:,jpj) = 0. ! force northern v line drowning + CALL Write_Ncdf_var( 'tmask', dimnames(1:2), trim(out_file), tmask2, 'float' ) + END IF + + END DO ! kt + ! + DEALLOCATE( zsurf, zsurf_smth, slp, slp_smth, temp,humi,uhpg,vhpg) + IF (jpka.NE.nhym) DEALLOCATE(tmp_fullw,tmp_fullm) + ! + STOP + ! +END PROGRAM main diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/main_vinterp.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/main_vinterp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3b38b6cc17d34301e71884d5ecd33900a0d534f5 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/main_vinterp.F90 @@ -0,0 +1,590 @@ +PROGRAM main + !!====================================================================== + !! *** PROGRAM main *** + !! + !! ** Purpose : Vertical interpolation of ECMWF dataset on a given fixed + !! vertical grid + !! + !!====================================================================== + !! History : 2016-10 (F. Lemarié) Original code + !! + !!---------------------------------------------------------------------- + USE module_io ! I/O routines + USE module_interp ! vertical interpolation routines + USE module_grid ! compute input and output grids + !! + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! + !! + !! + !!---------------------------------------------------------------------- + ! + INTEGER :: ji,jj,jk,kt, jk_in, nhym, nhyi + INTEGER :: jpka_in, jpka ! number of vertical levels for input and target grids + INTEGER :: jpi , jpj ! number of grid points in x and y directions + INTEGER :: iloc, jloc ! grid indexes for c1d case + INTEGER :: status + INTEGER :: jptime,ctrl + INTEGER :: ioerr + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ind + INTEGER, PARAMETER :: stdout = 6 + INTEGER, PARAMETER :: jp_weno = 1 + INTEGER, PARAMETER :: jp_spln = 2 + !! + REAL(8) :: hc,hmax,theta_s,z1 ! parameters related to the target vertical grid + REAL(8) :: cff + !! + REAL(8), ALLOCATABLE, DIMENSION(: ) :: A_w ! A coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: A_wa ! A coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: B_w ! B coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: B_wa ! B coefficients to reconstruct ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d, tmp_fullw, tmp_fullm ! temporary/working 1D arrays + REAL(8), ALLOCATABLE, DIMENSION(: ) :: e3t,e3w ! thickness of vertical layers in target grid + REAL(8), ALLOCATABLE, DIMENSION(: ) :: ght,ghw ! altitude of vertical grid points + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: e3_bak + REAL(8), ALLOCATABLE, DIMENSION(:,:,: ) :: ghw_in ! altitude of cell interfaces of ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(:,:,: ) :: e3t_in ! thickness of vertical layers in ECMWF grid + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: humi + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: tair, tpot + REAL(8), ALLOCATABLE, DIMENSION(:,:,:,:) :: varout, varc1d + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: slp, zsurf + REAL(8), ALLOCATABLE, DIMENSION(:,: ) :: tmask, tmask2 ! land-sea mask + !! + CHARACTER(len=500) :: file_u,file_v,file_hpg,file_geos ! ECMWF files containing wind components + CHARACTER(len=500) :: file_t,file_q, file_m ! ECMWF files containing tracers and mask + CHARACTER(len=500) :: file_z,file_p,cn_dir,file_in ! ECMWF files containing surface geopot and pressure + CHARACTER(len=500) :: grd_file, abl_file, drwn_file, out_file + CHARACTER(len=500) :: namelistf,stmp + CHARACTER(len=500) :: argument, var_file + CHARACTER(len= 20),DIMENSION(4) :: dimnames + CHARACTER(len= 20),DIMENSION(11) :: varnames, outnames + CHARACTER(len=500),DIMENSION(11) :: filnames + CHARACTER(6) :: mask_var ! name of mask variable in file_m file + CHARACTER(6) :: var_name + !! + LOGICAL :: ln_read_zsurf ! read surface geopotential or not + LOGICAL :: ln_read_mask ! read land-sea mask or not + LOGICAL :: ln_perio_latbc ! use periodic BC along the domain latitudinal edges (for global data) or use zero-gradient BC (for regional data) + LOGICAL :: ln_c1d ! output only a single column in output file + LOGICAL :: ln_hpg_frc ! compute horizontal pressure gradient + LOGICAL :: ln_geo_wnd ! compute goestrophic wind components + LOGICAL :: ln_slp_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_drw_smth ! apply gibbs oscillation filetring on mean sea level pressure + LOGICAL :: ln_slp_log ! log(sea-level pressure) or sea-level pressure + LOGICAL :: ln_lsm_land ! if T mask is 1 over land and 0 over ocean if F it is the other way around + LOGICAL :: ln_impose_z1 ! impose the altitude of the first level in target grid + INTEGER :: ptemp_method ! way to compute potential temperature + ! = 0 (absolute temperature) + ! = 1 (potential temperature with local ref pressure) + ! = 2 (potential temperature with global ref pressure on temperature perturbation) + ! = 3 (potential temperature with global ref pressure) + !! + REAL(8), PARAMETER :: grav = 9.80665 + + !!--------------------------------------------------------------------- + !! List of variables read in the namelist file + NAMELIST/nml_dom/ jpka, hmax, theta_s, hc, ln_impose_z1, z1 + NAMELIST/nml_opt/ ptemp_method, ln_slp_log, ln_slp_smth, ln_read_mask, ln_perio_latbc, & + & ln_hpg_frc, ln_geo_wnd, ln_c1d, ln_read_zsurf, ln_lsm_land, ln_drw_smth + NAMELIST/nml_fld/ cn_dir, file_u, file_v, file_t, & + & file_q, file_z, file_p, file_hpg, file_geos, & + & file_m, mask_var + NAMELIST/nml_out/ grd_file, abl_file, drwn_file, var_name + NAMELIST/nml_c1d/ iloc, jloc + !! + !! get the namelist file name + CALL get_command_argument( 1, argument, ctrl, status) + ! + SELECT CASE(status) + CASE(0) + namelistf = trim(argument) + CASE(-1) + WRITE(stdout,*) "### Error: file name too long" + STOP + CASE DEFAULT + namelistf = 'namelist_abl_tools' + END SELECT + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! read namelist variables + ctrl = 0 + OPEN(50, file=namelistf, status='old', form='formatted', access='sequential', iostat=ioerr) + IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_dom, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_opt, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_fld, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + READ(50,nml_out, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + IF( ln_c1d ) THEN + print*,'c1d is activated' + READ(50,nml_c1d, iostat=ioerr); IF (ioerr /= 0) ctrl = ctrl + 1 + ENDIF + + IF (ctrl > 0) THEN + WRITE(stdout,*) "### E R R O R while reading namelist file '",trim(namelistf),"'" + WRITE(stdout,*) " ctrl = ",ctrl + STOP + ELSE + WRITE(stdout,*) " Namelist file ",trim(namelistf)," OK " + ENDIF + IF( ln_hpg_frc .AND. ln_geo_wnd ) THEN + WRITE(stdout,*) "### E R R O R conflicting options " + WRITE(stdout,*) "ln_hpg_frc and ln_geo_wnd can not both be set to True" + STOP + ENDIF + + SELECT CASE (ptemp_method) + CASE(0) + WRITE(stdout,*) "Absolute temperature option is activated" + CASE(1) + WRITE(stdout,*) "Potential temperature option with local reference pressure is activated" + CASE(2) + WRITE(stdout,*) "Potential temperature option with global reference pressure on temperature perturbation is activated" + CASE(3) + WRITE(stdout,*) "Potential temperature option with global reference pressure is activated" + END SELECT + + IF(ln_slp_smth) WRITE(stdout,*) "MSLP smoothing option is activated" + IF(ln_hpg_frc ) WRITE(stdout,*) "Large-scale pressure gradient will be interpolated" + IF(ln_geo_wnd ) WRITE(stdout,*) "Geostrophic winds will be interpolated" + !!--------------------------------------------------------------------- + + !!------------------------------------------------------------------------------------- + !! list of variables to treat + !! + !! get the variable name + CALL get_command_argument( 2, argument, ctrl, status) + SELECT CASE(status) + CASE(0) + var_name = trim(argument) + CASE(-1) + WRITE(stdout,*) "### Error: file name too long" + STOP + END SELECT + WRITE(stdout,*) "var_name: ", trim(var_name), "lenght: ", Len_Trim(var_name) + !! + IF( ln_hpg_frc ) THEN + file_in = trim(file_hpg ) + ELSE + file_in = trim(file_geos) + ENDIF + varnames = [character(len=4 ) :: 'Z' , 'T', 'Q', 'U', 'V', 'MSL', 'LSM', 'uhpg', 'vhpg', 'ugeo', 'vgeo' ] + outnames = [character(len=5 ) :: 'zsurf', 'tair', 'humi', 'uwnd', 'vwnd', 'slp', '', 'uhpg', 'vhpg', 'ugeo', 'vgeo' ] + filnames = [character(len=500) :: file_z, file_t, file_q, file_u, file_v, file_p, file_m, file_in, file_in, file_in, file_in ] + IF( ln_slp_log ) varnames(6) = 'LNSP' + + !!--------------------------------------------------------------------- + ! check files content + ctrl = 0 + CALL Read_Ncdf_dim('lev',trim(cn_dir)//'/'//trim(file_t),jpka_in) + ! + IF (ln_read_zsurf) THEN + IF( .not. VAR_EXISTENCE( trim(varnames(1)) , trim(cn_dir)//'/'//trim(file_z) ) & + & .or. jpka_in == 1 ) ctrl = ctrl + 1 + ENDIF + WRITE(stdout,*) trim(varnames(1)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(2)) , trim(cn_dir)//'/'//trim(file_t) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(2)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(3)) , trim(cn_dir)//'/'//trim(file_q) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(3)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(4)) , trim(cn_dir)//'/'//trim(file_u) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(4)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(5)) , trim(cn_dir)//'/'//trim(file_v) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(5)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(6)) , trim(cn_dir)//'/'//trim(file_p) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(6)), ctrl + IF (ln_read_mask) THEN + IF ( .not. VAR_EXISTENCE( trim(varnames(7)) , trim(cn_dir)//'/'//trim(file_m) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(7)), ctrl + varnames(7) = TRIM(mask_var) + ENDIF + IF (ln_hpg_frc) THEN + IF ( .not. VAR_EXISTENCE( trim(varnames(8)) , trim(cn_dir)//'/'//trim(file_hpg) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(8)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(9)) , trim(cn_dir)//'/'//trim(file_hpg) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(9)), ctrl + ENDIF + IF (ln_geo_wnd) THEN + IF ( .not. VAR_EXISTENCE( trim(varnames(10)) , trim(cn_dir)//'/'//trim(file_geos) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(10)), ctrl + IF ( .not. VAR_EXISTENCE( trim(varnames(11)) , trim(cn_dir)//'/'//trim(file_geos) ) ) ctrl = ctrl + 1 + WRITE(stdout,*) trim(varnames(11)), ctrl + ENDIF + + IF ( ctrl > 0 ) THEN + WRITE(stdout,*) "### E R R O R while reading ECMWF atmospheric files " + STOP + ELSE + WRITE(stdout,*) " ECMWF atmospheric files OK " + ENDIF + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! read the dimensions for the input files + CALL Read_Ncdf_dim ( 'time', trim(cn_dir)//'/'//trim(file_t), jptime ) + CALL Read_Ncdf_dim ( 'lon' , trim(cn_dir)//'/'//trim(file_t), jpi ) + CALL Read_Ncdf_dim ( 'lat' , trim(cn_dir)//'/'//trim(file_t), jpj ) + CALL Read_Ncdf_dim ( 'nhym' , trim(cn_dir)//'/'//trim(file_t), nhym ) + CALL Read_Ncdf_dim ( 'nhyi' , trim(cn_dir)//'/'//trim(file_t), nhyi ) + !WRITE(stdout,*) "jpka_in, jptime, jpi, jpj, nhym, nhyi: ", jpka_in, jptime, jpi, jpj, nhym, nhyi + ! + !!--------------------------------------------------------------------- + + + !!--------------------------------------------------------------------- + !! allocate arrays + ALLOCATE( A_w ( 0:jpka_in) ) + ALLOCATE( B_w ( 0:jpka_in) ) + ALLOCATE( e3t_in ( 1:jpi, 1:jpj, 1:jpka_in) ) + ALLOCATE( ghw_in ( 1:jpi, 1:jpj, 0:jpka_in) ) + ALLOCATE( slp ( 1:jpi, 1:jpj ) ) + ALLOCATE( zsurf ( 1:jpi, 1:jpj ) ) + ALLOCATE( tair ( 1:jpi, 1:jpj, 1:jpka_in, 1) ) + ALLOCATE( tpot ( 1:jpi, 1:jpj, 1:jpka_in, 1) ) + ALLOCATE( humi ( 1:jpi, 1:jpj, 1:jpka_in, 1) ) + ALLOCATE( varout ( 1:jpi, 1:jpj, 1:jpka+1 , 1) ) + ALLOCATE( ind ( 1:jpi, 1:jpj ) ) + ALLOCATE( e3_bak ( 1:jpi, 1:jpj ) ) + ALLOCATE( ght ( 1:jpka+1 ) ) + ALLOCATE( ghw ( 1:jpka+1 ) ) + ALLOCATE( e3t ( 1:jpka+1 ) ) + ALLOCATE( e3w ( 1:jpka+1 ) ) + ALLOCATE( tmask ( 1:jpi, 1:jpj ) ) + ALLOCATE( tmask2 ( 1:jpi, 1:jpj ) ) + IF( ln_c1d ) ALLOCATE( varc1d( 1:3, 1:3, 1:jpka+1 , 1 ) ) + IF( ln_c1d ) varc1d( 1:3, 1:3, 1:jpka+1 , 1 ) = 0. + IF (jpka_in.NE.nhym) THEN + ALLOCATE( tmp_fullw(1:nhyi) ) + ALLOCATE( tmp_fullm(1:nhym) ) + ENDIF + ! + varout(:,:,:,1) = 0. + + !!--------------------------------------------------------------------- + !! Read the mask and remove some closed seas + IF (ln_read_mask) THEN + CALL init_atm_mask(jpi,jpj,trim(cn_dir)//'/'//trim(file_m),trim(mask_var),ln_lsm_land,tmask) + IF (ln_geo_wnd) CALL Read_Ncdf_var ( 'tmask' , trim(cn_dir)//'/'//trim(file_geos), tmask2(:,:) ) + IF (ln_hpg_frc) CALL Read_Ncdf_var ( 'tmask' , trim(cn_dir)//'/'//trim(file_hpg) , tmask2(:,:) ) + ELSE + tmask(:,:) = 1. + tmask2(:,:) = 1. + ENDIF + !! + + !!--------------------------------------------------------------------- + !! Compute the altitude and layer thickness of the target grid + CALL init_target_grid ( jpka, ght, ghw, e3t, e3w, hmax, hc, theta_s, & + & ln_impose_z1, z1 ) + + !! Write the grid file for the target grid + CALL Write_Grid_File ( jpka, ght, ghw, e3t, e3w, trim(cn_dir)//'/'//trim(grd_file) ) + + + !! Read the static A and B coefficients for the ECMWF vertical grid + IF (jpka_in.EQ.nhym) THEN + CALL Read_Ncdf_var ( 'hyai', trim(cn_dir)//'/'//trim(file_t), A_w ) + CALL Read_Ncdf_var ( 'hybi', trim(cn_dir)//'/'//trim(file_t), B_w ) + ELSE + CALL Read_Ncdf_var ( 'hyai', trim(cn_dir)//'/'//trim(file_t), tmp_fullw ) + A_w(0:jpka_in) = tmp_fullw(nhyi-(jpka_in+1)+1:nhyi) + CALL Read_Ncdf_var ( 'hybi', trim(cn_dir)//'/'//trim(file_t), tmp_fullw ) + B_w(0:jpka_in) = tmp_fullw(nhyi-(jpka_in+1)+1:nhyi) + ENDIF + + + !!--------------------------------------------------------------------- + !! create output file + !! + IF (Len_Trim(var_name) == 0) THEN + out_file = trim(cn_dir)//'/'//trim(abl_file) + ELSE + out_file = trim(cn_dir)//'/'//trim(var_name)//'_'//trim(abl_file) + ENDIF + + IF(ln_c1d) THEN + CALL Init_output_File_c1d ( jpi, jpj, jpka, trim(cn_dir)//'/'//trim(file_t), out_file, tmask(:,:), iloc, jloc ) + ELSE + CALL Init_output_File ( jpi, jpj, jpka, trim(cn_dir)//'/'//trim(file_t), out_file, tmask(:,:) ) + ENDIF + + !!--------------------------------------------------------------------- + !! Initialize the name of the dimensions for the result of the interpolation + !! + dimnames(1) = 'lon' + dimnames(2) = 'lat' + dimnames(3) = 'jpka' + dimnames(4) = 'time' + CALL Write_Ncdf_var( 'tmask', dimnames(1:2), trim(out_file), tmask2, 'float' ) + + !!--------------------------------------------------------------------- + ! Read time variable + ALLOCATE(tmp1d (1:jptime)) + CALL Read_Ncdf_var ( 'time', trim(cn_dir)//'/'//trim(file_t), tmp1d ) + !!--------------------------------------------------------------------- + + DO kt=1,jptime + ! + WRITE(stdout,*) '======================' + WRITE(stdout,*) 'time = ',kt,'/',jptime + ! + CALL Write_Ncdf_var( 'time', dimnames(4:4), trim(out_file), tmp1d(kt:kt), kt, 'double' ) + ! + IF( kt == 1 ) THEN + CALL Duplicate_lon_lat_time( trim(cn_dir)//'/'//trim(file_t), out_file ) + CALL add_globatt_real( out_file, "jpka" , REAL(jpka) ) + CALL add_globatt_real( out_file, "hmax" , hmax ) + CALL add_globatt_real( out_file, "theta_s", theta_s ) + CALL add_globatt_real( out_file, "hc" , hc ) + IF (ln_impose_z1) CALL add_globatt_real( out_file, "z1", z1 ) + ENDIF + ! + ! read SLP + !CALL Read_Ncdf_var ( varnames(6) , trim(cn_dir)//'/'//trim(file_p), slp, kt ) !<-- (log of) surface pressure + !IF (ln_slp_log) THEN + ! DO jj = 1, jpj + ! DO ji = 1, jpi + ! slp( ji ,jj ) = exp( slp(ji ,jj ) ) + ! END DO + ! END DO + !ENDIF + CALL Read_Ncdf_var ( outnames(6) , trim(cn_dir)//'/'//trim(file_in), slp, kt ) !<-- (log of) surface pressure + ! + ! read ZSURF + IF (ln_read_zsurf) THEN + !CALL Read_Ncdf_var ( varnames(1) , trim(cn_dir)//'/'//trim(file_z), zsurf, kt ) !<-- surface geopotential + CALL Read_Ncdf_var ( outnames(1) , trim(cn_dir)//'/'//trim(file_in), zsurf, kt ) !<-- surface geopotential + ELSE + zsurf(:,:) = 0. + ENDIF + ! + ! Smoothing of SLP and ZSURF to remove gibbs oscillations (must be done on both fields or none of them) + !IF( ln_slp_smth ) CALL smooth_field( jpi, jpj, slp(:,:), tmask(:,:), 3 ) + !IF (ln_read_zsurf.AND.ln_slp_smth) CALL smooth_field( jpi, jpj, zsurf(:,:), tmask(:,:), 3 ) + !IF( ln_slp_smth ) CALL DTV_Filter( jpi, jpj, slp(:,:), tmask(:,:), 25, kt ) !<-- not yet robust enough + ! + ! read tair and HUMI + CALL Read_Ncdf_var ( varnames(2) , trim(cn_dir)//'/'//trim(file_t), tair, kt ) !<-- temperature + CALL Read_Ncdf_var ( varnames(3) , trim(cn_dir)//'/'//trim(file_q), humi, kt ) !<-- humidity + WHERE(humi.LT.1.E-08) varout = 1.E-08 !<-- negative values in ECMWF + ! + ! Reconstruct the ERA-Interim vertical grid in terms of altitude + ghw_in(:,:,1:jpka_in) = 0. + ghw_in(:,:, jpka_in) = zsurf(:,:) * (1. / grav) + CALL get_atm_grid( jpi, jpj, jpka_in, slp, tair, & + & humi, A_w, B_w, e3t_in, ghw_in ) + ! + ! Compute potential temperature + tpot = tair ! save tpot + CALL get_pot_temp ( jpi, jpj, jpka_in, slp, tpot, A_w, B_w, & + & tmask(:,:), ptemp_method, humi(:,:,jpka_in,1), 0.5*ghw_in(:,:,jpka_in-1) ) + + ! Flip the vertical axis to go from k=0 at the bottom to k=N_in at the top of the atmosphere + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, e3t_in ) + CALL flip_vert_dim ( 0, jpka_in, jpi, jpj, ghw_in ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, tpot(:,:,:,1) ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, humi(:,:,:,1) ) + + ! Correct the layer thickness to match hmax + DO jj = 1, jpj + DO ji = 1, jpi + cff = 0. + DO jk=1,jpka_in + cff = cff + e3t_in( ji, jj, jk ) + IF ( cff > hmax ) THEN + jk_in = jk + EXIT + ENDIF + END DO + ind ( ji, jj ) = jk_in + e3_bak ( ji, jj ) = e3t_in ( ji, jj, jk_in ) ! store the value of the original layer thickness + e3t_in ( ji, jj, jk_in) = e3t_in ( ji, jj, jk_in ) - ( cff - hmax ) + END DO + END DO + ! + IF (Len_Trim(var_name) == 0) THEN + !/ + ! Interpolation of potential temperature TPOT + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & tpot, e3t_in, e3_bak, e3t, varout, jp_weno ) + + varout(:,:,1,1) = varout(:,:,2,1) + + IF (ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ('tair', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ('tair', dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + ! + ! Interpolation of HUMI + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & humi, e3t_in, e3_bak, e3t, varout, jp_weno ) + + !FL: dirty loop (possible issue in boundary conditions for WENO scheme) + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 2, jpka+1 + varout(ji,jj,jk,1) = MAX(varout(ji,jj,jk,1),1.E-08) !<-- negative values in ECMWF + END DO + END DO + END DO + + varout(:,:,1,1) = varout(:,:,2,1) + + IF (ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ('humi', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ('humi', dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + + ! + ! Interpolate large-scale HPG or geostrophic wind + ! + ! Read HPG + IF (ln_hpg_frc) THEN + CALL Read_Ncdf_var ( varnames(8) , trim(cn_dir)//'/'//trim(file_in), tair, kt ) + CALL Read_Ncdf_var ( varnames(9) , trim(cn_dir)//'/'//trim(file_in), humi, kt ) + ENDIF + ! Read geostrophic wind + IF (ln_geo_wnd) THEN + CALL Read_Ncdf_var ( varnames(10) , trim(cn_dir)//'/'//trim(file_in), tair, kt ) + CALL Read_Ncdf_var ( varnames(11) , trim(cn_dir)//'/'//trim(file_in), humi, kt ) + ENDIF + ! + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, tair( :,:,:,1 ) ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, humi( :,:,:,1 ) ) + ! + ! Interpolation of geostrophic U + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & tair, e3t_in, e3_bak, e3t, varout, jp_spln ) + varout(:,:,1,1) = varout(:,:,2,1) + + IF (ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ( 'uhpg', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + IF (ln_hpg_frc) CALL Write_Ncdf_var ( varnames( 8), dimnames(1:4), out_file, varout, kt, 'float' ) + IF (ln_geo_wnd) CALL Write_Ncdf_var ( varnames(10), dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + ! + ! Interpolation of geostrophic V + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & humi, e3t_in, e3_bak, e3t, varout, jp_spln ) + varout(:,:,1,1) = varout(:,:,2,1) + + IF (ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ( 'vhpg', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + IF (ln_hpg_frc) CALL Write_Ncdf_var ( varnames( 9), dimnames(1:4), out_file, varout, kt, 'float' ) + IF (ln_geo_wnd) CALL Write_Ncdf_var ( varnames(11), dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + ! + ! Interpolation of total winds + ! + ! Read wind + CALL Read_Ncdf_var ( varnames(4) , trim(cn_dir)//'/'//trim(file_u), tair, kt ) + CALL Read_Ncdf_var ( varnames(5) , trim(cn_dir)//'/'//trim(file_v), humi, kt ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, tair( :,:,:,1 ) ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, humi( :,:,:,1 ) ) + ! + ! Interpolation of total U + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & tair, e3t_in, e3_bak, e3t, varout, jp_spln ) + varout(:,:,1,1) = varout(:,:,2,1) + + IF(ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ( 'uwnd', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ( 'uwnd', dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + ! + ! Interpolation of total V + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & humi, e3t_in, e3_bak, e3t, varout, jp_spln ) + varout(:,:,1,1) = varout(:,:,2,1) + + IF(ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ( 'vwnd', dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ( 'vwnd', dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + + ELSE ! var_name + ! + ctrl = minval(pack([(ji,ji=1,size(outnames))],outnames==var_name)) + var_file = filnames(ctrl) + ! + ! + ! Interpolation of var_name + ! + IF ( (var_name.NE."tair").AND.(var_name.NE."humi") ) THEN + ! Read var_name + CALL Read_Ncdf_var ( varnames(ctrl) , trim(cn_dir)//'/'//trim(var_file), tair, kt ) + CALL flip_vert_dim ( 1, jpka_in, jpi, jpj, tair( :,:,:,1 ) ) + ! Interpolation of var_name + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & tair, e3t_in, e3_bak, e3t, varout, jp_spln ) + ELSE + ! humi and tpot already read + IF (var_name.EQ."humi") tair = humi + IF (var_name.EQ."tair") tair = tpot + ! Interpolation of var_name + CALL zinterp ( jpi, jpj, jpka, jpka_in, ind, & + & tair, e3t_in, e3_bak, e3t, varout, jp_weno ) + END IF + + varout(:,:,1,1) = varout(:,:,2,1) + + IF(ln_c1d) THEN + DO jj=1,3 + DO ji=1,3 + varc1d( ji, jj , 1:jpka+1 , 1 ) = varout(iloc,jloc, 1:jpka+1 , 1 ) + END DO + END DO + CALL Write_Ncdf_var ( outnames(ctrl), dimnames(1:4), out_file, varc1d, kt, 'float' ) + ELSE + CALL Write_Ncdf_var ( outnames(ctrl), dimnames(1:4), out_file, varout, kt, 'float' ) + ENDIF + ! + ENDIF ! var_name + ! + END DO ! kt + ! + DEALLOCATE(zsurf,slp,tair,humi,varout) + IF (jpka_in.NE.nhym) DEALLOCATE(tmp_fullw,tmp_fullm) + ! + STOP + ! +END PROGRAM main diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/module_grid.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/module_grid.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a27da59da545674c055efc29b7d61ec3b5bbf2a0 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/module_grid.F90 @@ -0,0 +1,904 @@ +MODULE module_grid + !!====================================================================== + !! *** MODULE module_grid *** + !! ABL utilities to define and store vertical grids + !!===================================================================== + !! History : 2016-10 (F. Lemarié) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! FUNCTIONS : None + !! SUBROUTINES : get_atm_grid, init_atm_mask, get_pot_temp + !! Write_Grid_File, Init_output_File, init_target_grid + !! flip_vert_dim, smooth_field + !!---------------------------------------------------------------------- + IMPLICIT NONE + +CONTAINS + + SUBROUTINE get_atm_grid( jpi, jpj, jpka, slp, temp, humi, Aw, Bw, & ! in + & e3t, ghw ) ! out + !!-------------------------------------------------------------------------- + !! *** ROUTINE get_atm_grid *** + !! + !! ** Purpose : compute layer thickness and altitude of interfaces + !! of the ECMWF atmospheric grid + !! + !! ** Method : + !! (1) recompute the pressure levels thanks to the sea-level pressure + !! (2) use the hydrostatic relation to convert pressure into altitudes + !! + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi, jpj + INTEGER, INTENT(in ) :: jpka + REAL(8), INTENT(in ) :: slp ( 1:jpi, 1:jpj ) + REAL(8), INTENT(in ) :: temp ( 1:jpi, 1:jpj, 1:jpka ) + REAL(8), INTENT(in ) :: humi ( 1:jpi, 1:jpj, 1:jpka ) + REAL(8), INTENT(in ) :: Aw ( 0:jpka ) + REAL(8), INTENT(in ) :: Bw ( 0:jpka ) + REAL(8), INTENT( out) :: e3t ( 1:jpi, 1:jpj, 1:jpka ) + REAL(8) :: ghw ( 1:jpi, 1:jpj, 0:jpka ) + REAL(8), PARAMETER :: g = 9.80665 + REAL(8), PARAMETER :: Rd = 287.058 + REAL(8), PARAMETER :: zvir = 0.609133 + REAL(8), PARAMETER :: ig = 1./g + !! + INTEGER :: ji,jj,jk + REAL(8) :: tv,ph(0:jpka) + ! + DO jj = 1, jpj + DO ji = 1, jpi + + DO jk=0,jpka + ph(jk) = Aw( jk ) + Bw( jk ) * slp( ji, jj ) !<-- Pa + END DO + + DO jk=jpka,1,-1 + tv = temp( ji, jj, jk ) * ( 1. + zvir*humi( ji, jj, jk ) ) !<-- Virtual temperature + e3t ( ji, jj, jk ) = ig*( Rd * tv * log( ph( jk ) / ph( jk-1 ) ) ) + ghw ( ji, jj, jk-1 ) = e3t( ji, jj, jk ) + ghw( ji, jj, jk ) + END DO + + END DO + END DO + ! + END SUBROUTINE get_atm_grid + + + + + SUBROUTINE init_atm_mask( jpi, jpj, mask_file, mask_name, ln_lsm_land, tmask ) + USE module_io + !!--------------------------------------------------------------------- + !! *** ROUTINE INIT_atm_MASK *** + !! + !! ** Purpose : extract the land/sea mask and remove isolated sea points + !! + !! ** Method : mask is 1 over the ocean and 0 over land + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi, jpj + LOGICAL, INTENT(in ) :: ln_lsm_land + REAL(8) :: tmask ( 1:jpi, 1:jpj, 1 ) + INTEGER :: jj, ji + INTEGER :: status,ncid,varid + CHARACTER(len = * ) :: mask_file, mask_name + REAL(8) :: cff + + ! Read land-sea mask variable + status = nf90_open(trim(mask_file),NF90_NOWRITE,ncid) + status = nf90_inq_varid(ncid,mask_name,varid) + status = nf90_get_var(ncid,varid,tmask,start=(/1,1,1/)) + status = nf90_close(ncid) + ! invert the mask (1 over the ocean, 0 over land if ln_lsm_land) + IF(ln_lsm_land) THEN + DO jj=1,jpj + DO ji=1,jpi + IF( tmask(ji,jj,1) <= 0. ) THEN + tmask(ji,jj,1) = 1. !! Ocean points + ELSE + tmask(ji,jj,1) = 0. !! Land points + END IF + END DO + END DO + ENDIF + ! remove some closed seas + DO jj=2,jpj-1 + DO ji=2,jpi-1 + cff = MAX( tmask(ji+1,jj ,1),tmask(ji-1,jj ,1), & + & tmask(ji ,jj+1,1),tmask(ji ,jj-1,1), & + & tmask(ji+1,jj+1,1),tmask(ji-1,jj-1,1), & + & tmask(ji+1,jj-1,1),tmask(ji-1,jj+1,1) ) + IF( tmask( ji, jj, 1 ) .gt. 0.5 .and. cff .lt. 0.5 ) THEN + tmask( ji, jj, 1 ) = 0. + END IF + END DO + END DO + WRITE(*,*)' init_atm_mask: ',mask_name,' in ',mask_file, ' OK' + !!---------------------------------------------------------------------- + ! + END SUBROUTINE init_atm_mask + + + + SUBROUTINE get_pot_temp( jpi, jpj, jpka, slp, temp, Aw, Bw, tmask, method, hum1, z1 ) + !!--------------------------------------------------------------------- + !! *** ROUTINE get_pot_temp *** + !! + !! ** Purpose : compute the potential temperature based on the + !! absolute temperature and the sea level pressure + !! + !! ** Method : five different ways are implemented depending on the + !! value of 'method' + !! (0) potential temperature = absolute temperature (not recommended) + !! (1) potential temperature is computed using a local reference + !! pressure equal to the sea-level-pressure + !! (2) potential temperature is computed only on a perturbation of + !! the absolute temperature around t0 + !! (3) a local reference pressure is used consistently with AEROBULK gamma_moist + !! (4) a constant global reference pressure is used + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi, jpj + INTEGER, INTENT(in ) :: jpka, method + REAL(8), INTENT(in ) :: slp ( 1:jpi, 1:jpj ) + REAL(8), INTENT(in ) :: tmask ( 1:jpi, 1:jpj ) + REAL(8), INTENT(in ) :: z1 ( 1:jpi, 1:jpj ) + REAL(8), INTENT(inout) :: temp ( 1:jpi, 1:jpj, 1:jpka ) + REAL(8), INTENT(in ) :: hum1 ( 1:jpi, 1:jpj ) + REAL(8), INTENT(in ) :: Aw ( 0:jpka ) + REAL(8), INTENT(in ) :: Bw ( 0:jpka ) + REAL(8), PARAMETER :: grav = 9.80665 + REAL(8), PARAMETER :: R_dry = 287.058 + REAL(8), PARAMETER :: R_vap = 461.495 + REAL(8), PARAMETER :: Cp_dry = 1005. + REAL(8), PARAMETER :: cevap = 2.5E+06 + REAL(8), PARAMETER :: reps0 = R_dry / R_vap + REAL(8), PARAMETER :: gamma = 2./7. + REAL(8) :: pres0, gamma_moist, zrv, zirt + REAL(8), PARAMETER :: t0 = 288. !<-- K + !! + INTEGER :: ji,jj,jk + REAL(8) :: pres,ph(0:jpka), cff + !! + SELECT CASE ( method ) + CASE(0) + RETURN + CASE(1) + DO jj = 1, jpj + DO ji = 1, jpi + + IF( tmask(ji,jj) .gt. 0.5 ) THEN + DO jk=0,jpka + ph(jk) = Aw( jk ) + Bw( jk ) * slp( ji, jj ) + END DO + + pres0 = 0.5*(ph(jpka)+ph(jpka-1)) + + DO jk=1,jpka + pres = 0.5*(ph(jk)+ph(jk-1)) + cff = ( pres0/pres )**gamma + temp( ji, jj, jk ) = cff * temp( ji, jj, jk ) + END DO + ELSE + temp( ji, jj, 1:jpka ) = 273.15 + END IF + END DO + END DO + CASE(2) + pres0 = 100900. + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj) .gt. 0.5 ) THEN + DO jk=0,jpka + ph(jk) = Aw( jk ) + Bw( jk ) * slp( ji, jj ) + END DO + + DO jk=1,jpka + pres = 0.5*(ph(jk)+ph(jk-1)) + cff = ( pres0/pres )**gamma + temp( ji, jj, jk ) = cff * ( temp( ji, jj, jk ) - t0 ) + t0 + END DO + ELSE + temp( ji, jj, 1:jpka ) = 273.15 + END IF + END DO + END DO + CASE(3) + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj) .gt. 0.5 ) THEN + DO jk=0,jpka + ph(jk) = Aw( jk ) + Bw( jk ) * slp( ji, jj ) + END DO + !! compute gamma_moist consistently with AEROBULK + zrv = hum1( ji, jj ) / ( 1. - hum1( ji, jj ) ) + zirt = 1. / ( R_dry * temp( ji, jj, jpka ) ) + gamma_moist = grav * ( 1. + cevap*zrv*ziRT ) & + & / ( Cp_dry + cevap*cevap*zrv*reps0*ziRT/temp( ji, jj, jpka ) ) + !! pressure at z = z1 + pres = 0.5*(ph(jpka)+ph(jpka-1)) + pres0 = pres * ( 1. + gamma_moist * z1(ji,jj) / temp( ji, jj, jpka ) )**(1./gamma) + DO jk=1,jpka + pres = 0.5*(ph(jk)+ph(jk-1)) + cff = ( pres0/pres )**gamma + temp( ji, jj, jk ) = cff * temp( ji, jj, jk ) + END DO + ELSE + temp( ji, jj, 1:jpka ) = 273.15 + END IF + END DO + END DO + CASE(4) + pres0 = 100900. + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj) .gt. 0.5 ) THEN + DO jk=0,jpka + ph(jk) = Aw( jk ) + Bw( jk ) * slp( ji, jj ) + END DO + + DO jk=1,jpka + pres = 0.5*(ph(jk)+ph(jk-1)) + cff = ( pres0/pres )**gamma + temp( ji, jj, jk ) = cff * temp( ji, jj, jk ) + END DO + ELSE + temp( ji, jj, 1:jpka ) = 273.15 + END IF + END DO + END DO + END SELECT + ! + END SUBROUTINE get_pot_temp + + + SUBROUTINE Write_Grid_File( jpka, ght, ghw, e3t, e3w, grd_file ) + !! + USE module_io + !!--------------------------------------------------------------------- + !! *** ROUTINE write_Grid_File *** + !! + !! ** Purpose : write the ABL grid file + !! + !! ** Method : store the layer thickness and altitude of grid points + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpka + REAL(8), INTENT(in ) :: ght ( 1:jpka+1 ) + REAL(8), INTENT(in ) :: ghw ( 1:jpka+1 ) + REAL(8), INTENT(in ) :: e3t ( 1:jpka+1 ) + REAL(8), INTENT(in ) :: e3w ( 1:jpka+1 ) + CHARACTER(*), INTENT(in ) :: grd_file + !! + INTEGER :: status, ncid + !! + status = nf90_create( grd_file, NF90_WRITE, ncid ) + status = nf90_close ( ncid ) + !! + Call Write_Ncdf_dim ( 'jpka' , grd_file, jpka+1 ) + Call Write_Ncdf_var ( 'ghw', 'jpka', grd_file, ghw, 'double' ) + Call Write_Ncdf_var ( 'ght', 'jpka', grd_file, ght, 'double' ) + Call Write_Ncdf_var ( 'e3t', 'jpka', grd_file, e3t, 'double' ) + Call Write_Ncdf_var ( 'e3w', 'jpka', grd_file, e3w, 'double' ) + ! + END SUBROUTINE Write_Grid_File + + + + + + SUBROUTINE Init_output_File ( jpi, jpj, jpka, atm_file, abl_file, tmask ) + !! + USE module_io + !!--------------------------------------------------------------------- + !! *** ROUTINE Init_output_File *** + !! + !! ** Purpose : write longitude, latitude and mask in the output file + !! + !! ** Method : define dimensions in the netcdf file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi,jpj,jpka + CHARACTER(*), INTENT(in ) :: atm_file + CHARACTER(*), INTENT(in ) :: abl_file + REAL(8) :: tmask(1:jpi,1:jpj) + !! + REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d + INTEGER :: status, ncid + CHARACTER(len= 20),DIMENSION(4) :: dimnames + !! + status = nf90_create( abl_file, NF90_WRITE, ncid ) + status = nf90_close ( ncid ) + !! + CALL Write_Ncdf_dim ( 'lon' , abl_file, jpi ) + CALL Write_Ncdf_dim ( 'lat' , abl_file, jpj ) + CALL Write_Ncdf_dim ( 'jpka' , abl_file, jpka+1 ) + CALL Write_Ncdf_dim ( 'time' , abl_file, 0 ) + ! + ALLOCATE( tmp1d( 1:jpi ) ) + ! + CALL Read_Ncdf_var ( 'lon', atm_file, tmp1d ) + CALL Write_Ncdf_var ( 'lon', 'lon', abl_file, tmp1d, 'double' ) + ! + DEALLOCATE( tmp1d ) + ! + ALLOCATE( tmp1d( 1:jpj ) ) + ! + CALL Read_Ncdf_var ( 'lat', atm_file, tmp1d ) + CALL Write_Ncdf_var( 'lat', 'lat', abl_file, tmp1d, 'double' ) + ! + DEALLOCATE( tmp1d ) + ! + dimnames(1) = 'lon' + dimnames(2) = 'lat' + CALL Write_Ncdf_var( 'lsm', dimnames , abl_file, tmask, 'float' ) + ! + END SUBROUTINE Init_output_File + + + SUBROUTINE Init_output_File_c1d ( jpi, jpj, jpka, atm_file, abl_file, tmask, iloc, jloc ) + !! + USE module_io + !!--------------------------------------------------------------------- + !! *** ROUTINE Init_output_File *** + !! + !! ** Purpose : write longitude, latitude and mask in the output file + !! + !! ** Method : define dimensions in the netcdf file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: iloc,jloc,jpi,jpj,jpka + CHARACTER(*), INTENT(in ) :: atm_file + CHARACTER(*), INTENT(in ) :: abl_file + REAL(8) :: tmask(1:jpi,1:jpj) + !! + REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d + REAL(8) :: tmp1d_loc(3),tmp2d_loc(3,3) + INTEGER :: status, ncid + CHARACTER(len= 20),DIMENSION(4) :: dimnames + !! + status = nf90_create( abl_file, NF90_WRITE, ncid ) + status = nf90_close ( ncid ) + !! + CALL Write_Ncdf_dim ( 'lon' , abl_file, 3 ) + CALL Write_Ncdf_dim ( 'lat' , abl_file, 3 ) + CALL Write_Ncdf_dim ( 'jpka' , abl_file, jpka+1 ) + CALL Write_Ncdf_dim ( 'time' , abl_file, 0 ) + ! + ALLOCATE( tmp1d ( 1:jpi ) ) + ! + CALL Read_Ncdf_var ( 'lon', atm_file, tmp1d ) + tmp1d_loc( 1 ) = tmp1d(iloc) + tmp1d_loc( 2 ) = tmp1d(iloc) + tmp1d_loc( 3 ) = tmp1d(iloc) + CALL Write_Ncdf_var ( 'lon', 'lon', abl_file, tmp1d_loc, 'double' ) + print*,'1D column located at : ' + print*,'longitude = ',tmp1d(iloc),' degree_east' + ! + DEALLOCATE( tmp1d ) + ! + ALLOCATE( tmp1d( 1:jpj ) ) + ! + CALL Read_Ncdf_var ( 'lat', atm_file, tmp1d ) + tmp1d_loc( 1 ) = tmp1d(jloc) + tmp1d_loc( 2 ) = tmp1d(jloc) + tmp1d_loc( 3 ) = tmp1d(jloc) + CALL Write_Ncdf_var( 'lat', 'lat', abl_file, tmp1d_loc, 'double' ) + print*,'latitude = ',tmp1d(jloc),' degree_north' + ! + DEALLOCATE( tmp1d ) + ! + tmp2d_loc(:,:) = tmask(iloc,jloc) + dimnames(1) = 'lon' + dimnames(2) = 'lat' + CALL Write_Ncdf_var( 'lsm', dimnames , abl_file, tmp2d_loc, 'float' ) + ! + END SUBROUTINE Init_output_File_c1d + + + SUBROUTINE init_target_grid( jpka, ght, ghw, e3t, e3w, hmax, hc, theta_s, & + & force_z1, z1 ) + !!--------------------------------------------------------------------- + !! *** ROUTINE init_target_grid *** + !! + !! ** Purpose : compute the layer thickness and altitude of grid points + !! for the ABL model based on the namelist parameter values + !! + !! ** Method : depending on the logical 'force_z1' two methods are used + !! (1) true -> the user chooses the value of the first vertical + !! grid point. A few Newton iterations are used to correct + !! the value of the parameter theta_s to satisfy this constraint + !! (2) false -> use the parameter values in the namelist to + !! compute the vertical grid + !! + !!---------------------------------------------------------------------- + INTEGER, intent(in ) :: jpka + REAL(8), intent(in ) :: hmax,hc + REAL(8), intent(inout) :: theta_s + LOGICAL, intent(in ) :: force_z1 + REAL(8), intent(in ) :: z1 + !! + REAL(8), intent( out) :: ghw( 1:jpka+1 ) + REAL(8), intent( out) :: ght( 1:jpka+1 ) + REAL(8), intent( out) :: e3w( 1:jpka+1 ) + REAL(8), intent( out) :: e3t( 1:jpka+1 ) + !! + REAL(8) :: ds,cff,sc_w,sc_r,alpha,x + REAL(8) :: fx,fxp + INTEGER :: jk,maxiter,jiter + REAL(8), PARAMETER :: tol = 1.E-12 + !! + IF(force_z1) THEN + IF(z1.LT.10.) THEN + WRITE(*,*) " ERROR: z1 < 1st ECMWF level height (~10m)" + STOP + ELSE + !! Newton iterations to find the appropriate value of theta_s + maxiter = 1000 + x = theta_s + sc_r = (float(1)-0.5)/float(jpka) + alpha = (z1 - hc*sc_r) / (hmax - hc) + ! + DO jiter=1,maxiter + fx = (sinh(sc_r*x)/sinh(x))-alpha + fxp = (sc_r*cosh(sc_r*x)-sinh(sc_r*x)*cosh(x)/sinh(x))/sinh(x) + IF( abs(fx) .lt. tol ) THEN + exit + ENDIF + cff = fx / fxp + x = x - cff + ENDDO + ! + theta_s = x + END IF + ! + ENDIF + ! + ds =1./float(jpka) + cff=(hmax-hc)/sinh(theta_s) + ! + DO jk = jpka,1,-1 + sc_w = ds*float(jk) + ghw(jk+1) = hc*sc_w + cff*sinh(theta_s*sc_w) + sc_r = ds*(float(jk)-0.5) + ght(jk+1) = hc*sc_r + cff*sinh(theta_s*sc_r) + END DO + ! + ghw(1) = 0. + e3t(1) = 0. + ght(1) = 0. + ! + DO jk = 2,jpka+1 + e3t(jk) = ghw(jk)-ghw(jk-1) + END DO + ! + DO jk=1,jpka + e3w(jk) = ght(jk+1)-ght(jk) + END DO + ! + e3w(jpka+1) = ghw(jpka+1) - ght(jpka+1) + ! + IF(force_z1) THEN !++ print the new parameter values + print*,'*** Updated grid parameters' + print*,'theta_s = ',theta_s + print*,'hc = ',hc + print*,'hmax = ',hmax + print*,'ght(2) = ',ght(2) + ENDIF + ! + END SUBROUTINE init_target_grid + + + + + + + SUBROUTINE flip_vert_dim( kstr, kend, jpi, jpj, tabin ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flip_vert_dim *** + !! + !! ** Purpose : flip the vertical axis of the array tabin so that + !! the vertical grid goes from k=kstr at the bottom + !! of the ABL to k=kend at the top + !!---------------------------------------------------------------------- + INTEGER, intent(in ) :: kstr,kend + INTEGER, intent(in ) :: jpi, jpj + REAL(8), intent(inout) :: tabin( 1:jpi, 1:jpj, kstr:kend ) + !! + INTEGER :: ji,jj,jk,ks + REAL(8) :: tabfl(kstr:kend) + ! + DO jj = 1,jpj + DO ji = 1,jpi + DO jk=kstr,kend + ks=(kend-jk)+kstr + tabfl(ks) = tabin( ji, jj, jk ) + END DO + tabin( ji, jj, kstr:kend ) = tabfl( kstr:kend ) + END DO + END DO + ! + END SUBROUTINE flip_vert_dim + + + + + + + + SUBROUTINE smooth_field( jpi, jpj, varin, tmask, niter ) + !!--------------------------------------------------------------------- + !! *** ROUTINE smooth_field *** + !! + !! ** Purpose : smooth the sea level pressure over the ocean + !! to attenuate Gibbs oscillation + !! ** Method : a 9-point isotropic laplacian filter is applied + !! iteratively on ocean grid points only + !! + !! Proper treatment of the periodicity is still not yet implemented + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi, jpj, niter + REAL(8), INTENT(in ) :: tmask ( 1:jpi, 1:jpj ) + REAL(8), INTENT(inout) :: varin ( 1:jpi, 1:jpj ) + INTEGER :: ji,jj,nit + REAL(8) :: smth_a,smth_b,umask,vmask + REAL(8) :: FX ( 0:jpi , 0:jpj+1 ) + REAL(8) :: FE1( 0:jpi+1, 0:jpj ) + REAL(8) :: FE ( 1:jpi , 0:jpj ) + !! + !!========================================================= + !! + ! Hanning filter + !smth_a = 1./8. + !smth_b = 1./4. + ! 9-point isotropic laplacian filter + smth_a = 1./12. + smth_b = 3./16. + + FX ( 0:jpi , 0:jpj+1 ) = 0. + FE1( 0:jpi+1, 0:jpj ) = 0. + FE ( 1:jpi , 0:jpj ) = 0. + + !!+++++++++ + DO nit = 1,niter + !!+++++++++ + DO jj=1,jpj + DO ji=1,jpi-1 + umask = tmask(ji,jj)*tmask(ji+1,jj) + FX ( ji, jj ) = ( varin( ji+1,jj ) - varin( ji ,jj ) ) * umask + END DO + END DO + FX( 0 , 1:jpj ) = FX( jpi-1, 1:jpj ) + FX ( jpi, 1:jpj ) = FX( 1, 1:jpj ) + FX( 0:jpi, 0 ) = FX( 0:jpi, 1 ) + FX( 0:jpi, jpj+1 ) = FX( 0:jpi, jpj) + !! + DO jj=1,jpj-1 + DO ji=1,jpi + vmask = tmask(ji,jj)*tmask(ji,jj+1) + FE1( ji, jj ) = ( varin( ji, jj+1 ) - varin( ji ,jj ) ) * vmask + END DO + END DO + !! + FE1( 0 , 1:jpj-1 ) = FE1( jpi , 1:jpj-1 ) + FE1( jpi+1 , 1:jpj-1 ) = FE1( 1 , 1:jpj-1 ) + FE1( 0:jpi+1, 0 ) = 0. + FE1( 0:jpi+1, jpj ) = 0. + !! + DO jj=0,jpj + DO ji=1,jpi + FE ( ji, jj ) = FE1( ji, jj ) & + & + smth_a*( FX ( ji, jj+1 ) + FX( ji-1, jj ) & + & - FX ( ji, jj ) - FX( ji-1, jj+1 ) ) + END DO + END DO + !! + DO jj = 1, jpj + DO ji = 0,jpi + FX( ji, jj ) = FX( ji, jj ) & + & + smth_a*( FE1( ji+1, jj ) + FE1( ji , jj-1 ) & + & -FE1( ji , jj ) - FE1( ji+1, jj-1 ) ) + END DO + DO ji = 1,jpi + varin( ji ,jj ) = varin( ji ,jj ) & + & + tmask(ji,jj) * smth_b * ( & + & FX( ji, jj ) - FX( ji-1, jj ) & + & +FE( ji, jj ) - FE( ji, jj-1 ) ) + END DO + END DO + !! + !!+++++++++ + END DO + !!+++++++++ + + END SUBROUTINE smooth_field + + + + + + + + + + + + + + + + + + + + + + + +! SUBROUTINE DTV_Filter( jpi, jpj, varin, tmask, niter, time ) +! USE module_io +! !!--------------------------------------------------------------------- +! !! *** ROUTINE DTV_Filter *** +! !! +! !! ** Purpose : +! !! +! !! ** Method : +! !! +! !! ** Action : +! !!---------------------------------------------------------------------- +! INTEGER, INTENT(in ) :: jpi, jpj, niter, time +! REAL(8), INTENT(in ) :: tmask ( 1:jpi, 1:jpj ) +! REAL(8), INTENT(inout) :: varin ( 1:jpi, 1:jpj ) +! INTEGER :: jn, jj, ji, nit, nt_n, nt_a, nl2 +! REAL(8) :: var0,mean,sigma2,cff,lambda +! REAL(8) :: FX(0:jpi+1,0:jpj+1) +! REAL(8) :: FE(0:jpi+1,0:jpj+1) +! REAL(8) :: FL(0:jpi+1,0:jpj+1) +! REAL(8) :: FR(0:jpi+1,0:jpj+1) +! REAL(8) :: wrk ( 1:jpi, 1:jpj, 2 ) +! REAL(8) :: div ( 0:jpi+1, 0:jpj+1 ), diag +! REAL(8), PARAMETER :: rsmall = 1.E-08 +! REAL(8), PARAMETER :: rbig = 1.E+14 +! REAL(8) :: umask, vmask, fmask, wght(8), dt +! REAL(8) :: L2norm_n, L2norm_a +! REAL(8), ALLOCATABLE, DIMENSION(: ) :: tmp1d +! INTEGER :: status,ncid,varid1,varid2,dimid1,dimid2 +! !!========================================================= +! CHARACTER(len= 3 ) :: nn +! CHARACTER(len = 500) :: erai_file, smth_file +! LOGICAL :: ln_diag_smoothing +! ln_diag_smoothing = .true. +! IF( ln_diag_smoothing ) THEN +! erai_file = '/Users/florianlemarie/Documents/INRIA/SIMBAD/ERA_INTERIM_DECEMBRE_2015/phi_ml1_6h_erai_201512.nc' +! WRITE(nn,'(I3)') time +! DO ji=1,3 +! IF(nn(ji:ji)==' ') nn(ji:ji)='0' +! END DO +! +! smth_file = 'smoothing_results_DTV_'//nn//'.nc' +! status = nf90_create( trim(smth_file) , NF90_WRITE, ncid ) +! status = nf90_close ( ncid ) +! ! +! CALL Write_Ncdf_dim ( 'lon' , trim(smth_file) , jpi ) +! CALL Write_Ncdf_dim ( 'lat' , trim(smth_file) , jpj ) +! ! +! ALLOCATE( tmp1d( 1:jpi ) ) +! CALL Read_Ncdf_var ( 'lon', erai_file, tmp1d ) +! CALL Write_Ncdf_var ( 'lon', 'lon', trim(smth_file), tmp1d, 'double' ) +! DEALLOCATE( tmp1d ) +! ! +! ALLOCATE( tmp1d( 1:jpj ) ) +! CALL Read_Ncdf_var ( 'lat', erai_file, tmp1d ) +! CALL Write_Ncdf_var( 'lat', 'lat', trim(smth_file), tmp1d, 'double' ) +! DEALLOCATE( tmp1d ) +! ! +! status = nf90_open(trim(smth_file),NF90_WRITE,ncid) +! status = nf90_inq_dimid(ncid, 'lon', dimid1) +! status = nf90_inq_dimid(ncid, 'lat', dimid2) +! status = nf90_redef(ncid) +! status = nf90_def_var(ncid,'varinp',nf90_double,(/dimid1,dimid2/),varid1) +! status = nf90_def_var(ncid,'varout',nf90_double,(/dimid1,dimid2/),varid2) +! status = nf90_enddef(ncid) +! ! +! ! +! status = nf90_put_var(ncid,varid1,varin) +! END IF +! !!========================================================= +! nit = 0 +! nl2 = 0 +! L2norm_a = 0. +! L2norm_n = rbig +! nt_n = 1 + MOD( nit , 2 ) +! nt_a = 1 + MOD( nit+1, 2 ) +! var0 = varin( nint(0.5*jpi) , nint(0.5*jpj) ) +! varin( 1:jpi, 1:jpj ) = varin( 1:jpi, 1:jpj ) - var0 +! wrk ( 1:jpi, 1:jpj, nt_n ) = varin( 1:jpi, 1:jpj ) +! !! Compute the mean first +! mean = Get_Mean ( jpi , jpj, varin, tmask ) +! sigma2 = Get_Vari ( jpi , jpj, varin, tmask, mean ) +! !! +! print*,'mean value over the ocean = ',mean + var0 +! print*,'variance of the input field = ',sigma2 +! !! +! lambda = (1. / sigma2 ) +! dt = 1. / (16.+lambda) +! diag = 0. +! +! !!>>>>>>>>>>>>>>>> +! DO nit = 1,niter +! !!>>>>>>>>>>>>>>>> +! FX(0:jpi+1,0:jpj+1) = 0. +! FE(0:jpi+1,0:jpj+1) = 0. +! FL(0:jpi+1,0:jpj+1) = 0. +! FR(0:jpi+1,0:jpj+1) = 0. +! !! +! DO jj = 1,jpj +! DO ji = 1,jpi-1 +! umask = tmask(ji,jj)*tmask(ji+1,jj) +! FX( ji, jj ) = umask * ( wrk( ji+1, jj, nt_n ) - wrk( ji, jj, nt_n ) ) +! END DO +! END DO +! !! +! DO jj = 1,jpj-1 +! DO ji = 1,jpi +! vmask = tmask(ji,jj)*tmask(ji,jj+1) +! FE( ji, jj ) = vmask * ( wrk( ji, jj+1, nt_n ) - wrk( ji, jj, nt_n ) ) +! END DO +! END DO +! !! +! DO jj = 1,jpj-1 +! DO ji = 1,jpi-1 +! fmask = tmask(ji,jj)*tmask(ji+1,jj+1)*diag +! FL( ji, jj ) = fmask * ( wrk( ji+1, jj+1, nt_n ) - wrk( ji , jj, nt_n ) ) +! fmask = tmask(ji+1,jj)*tmask(ji,jj+1)*diag +! FR( ji, jj ) = fmask * ( wrk( ji , jj+1, nt_n ) - wrk( ji+1, jj, nt_n ) ) +! END DO +! END DO +! !! +! div( 0:jpi+1, 0:jpj+1 ) = rsmall +! !! +! DO jj = 1,jpj+1 +! DO ji = 1,jpi+1 +! div(ji,jj) = MAX( sqrt( FX(ji,jj)**2 + FX(ji-1,jj )**2 + FE(ji,jj )**2 + FX(ji,jj-1)**2 & +! & + FL(ji,jj)**2 + FL(ji-1,jj-1)**2 + FR(ji,jj-1)**2 + FR(ji-1,jj)**2 ), rsmall ) +! END DO +! END DO +! +! +! +! +! DO jj=1,jpj +! DO ji=1,jpi +! IF( div(ji,jj) .eq. rsmall .or. tmask(ji,jj).lt.0.5 ) THEN +! wrk(ji,jj,nt_a) = wrk(ji,jj,nt_n) +! ELSE +! wght(1) = 1. + div(ji,jj) / div(ji+1,jj ) +! wght(2) = 1. + div(ji,jj) / div(ji-1,jj ) +! wght(3) = 1. + div(ji,jj) / div(ji ,jj+1) +! wght(4) = 1. + div(ji,jj) / div(ji ,jj-1) +! wght(5) = 1. + div(ji,jj) / div(ji+1,jj+1) +! wght(6) = 1. + div(ji,jj) / div(ji-1,jj+1) +! wght(7) = 1. + div(ji,jj) / div(ji-1,jj-1) +! wght(8) = 1. + div(ji,jj) / div(ji+1,jj-1) +! +! wrk(ji,jj,nt_a) = wrk(ji,jj,nt_n) + dt*( & +! & + FX(ji ,jj ) * wght(1) & +! & - FX(ji-1,jj ) * wght(2) & +! & + FE(ji ,jj ) * wght(3) & +! & - FE(ji ,jj-1) * wght(4) & +! & + FL(ji ,jj ) * wght(5) & +! & + FR(ji-1,jj ) * wght(6) & +! & - FL(ji-1,jj-1) * wght(7) & +! & - FR(ji ,jj-1) * wght(8) & +! & - lambda * div(ji,jj) * ( wrk(ji,jj,nt_n) - varin(ji,jj) ) ) +! +! IF( isnan(wrk(ji,jj,nt_a)) ) THEN +! print*,'Nan in smoothing at iteration ',nit +! print*,'at grid point ',ji,jj +! END IF +! IF( abs(wrk(ji,jj,nt_a)) .gt. rbig ) THEN +! print*,'Inf in smoothing at iteration ',nit +! print*,'at grid point ',ji,jj +! END IF +! L2norm_a = L2norm_a + ( wrk(ji,jj,nt_n)-wrk(ji,jj,nt_a) )**2 +! END IF +! END DO +! END DO +! +! +! mean = Get_Mean ( jpi , jpj, wrk(:,:,nt_a), tmask ) +! sigma2 = Get_Vari ( jpi , jpj, wrk(:,:,nt_a), tmask, mean ) +! !! +! print*,'mean value over the ocean = ',mean + var0 +! print*,'variance of the input field = ',sigma2 +! +! +! IF( L2norm_a .gt. L2norm_n ) THEN +! print*,'convergence after ',nit,' iterations' +!! EXIT +! END IF +! L2norm_n = L2norm_a +! L2norm_a = 0. +! nt_n = 1 + MOD( nit , 2 ) +! nt_a = 1 + MOD( nit+1, 2 ) +! +! !!>>>>>>>>>>>>>>>> +! END DO +! !!>>>>>>>>>>>>>>>> +! +! +! DO jj=1,jpj +! DO ji=1,jpi +! varin(ji,jj) = ( wrk(ji,jj,nt_n) + var0 )*tmask(ji,jj) +! END DO +! END DO +! +! IF( ln_diag_smoothing ) THEN +! status = nf90_put_var(ncid,varid2,varin) +! status = nf90_close(ncid) +! END IF +! ! +! END SUBROUTINE dtv_filter +! +! +! +! REAL(8) FUNCTION Get_Mean ( jpi , jpj, tabvar, tmask ) +! !!--------------------------------------------------------------------- +! !! *** FUNCTION Get_Mean *** +! !! +! !! ** Purpose : get the mean of the input field +! !! +! !!---------------------------------------------------------------------- +! INTEGER, INTENT(in) :: jpi,jpj +! REAL(8), INTENT(in) :: tabvar(jpi,jpj) +! REAL(8), INTENT(in) :: tmask (jpi,jpj) +! INTEGER :: ji,jj,jn +! +! !! Compute the mean first +! jn = 0 +! Get_Mean = 0. +! DO jj = 1, jpj +! DO ji = 1, jpi +! IF(tmask(ji,jj) .gt. 0.5) THEN +! Get_Mean = Get_Mean + tabvar( ji,jj ) +! jn=jn+1 +! END IF +! END DO +! END DO +! Get_Mean = (1./jn) * Get_Mean +! ! +! END FUNCTION Get_Mean +! +! +! +! +! +! REAL(8) FUNCTION Get_Vari ( jpi , jpj, tabvar, tmask, mean ) +! !!--------------------------------------------------------------------- +! !! *** FUNCTION Get_Mean *** +! !! +! !! ** Purpose : get the mean of the input field +! !! +! !!---------------------------------------------------------------------- +! INTEGER, INTENT(in) :: jpi,jpj +! REAL(8), INTENT(in) :: tabvar(jpi,jpj) +! REAL(8), INTENT(in) :: tmask (jpi,jpj), mean +! INTEGER :: ji,jj,jn +! +! jn = 0 +! Get_Vari = 0 +! !! +! DO jj = 1, jpj +! DO ji = 1, jpi +! IF(tmask(ji,jj) .gt. 0.5) THEN +! Get_Vari = Get_Vari + ( tabvar(ji,jj) - mean )**2 +! jn = jn+1 +! ENDIF +! END DO +! END DO +! Get_Vari = (1./jn) * Get_Vari +! ! +! END FUNCTION Get_Vari + + + +END MODULE module_grid diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/module_interp.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/module_interp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..286b7d1e532c2d507a5363c90c14315eaf827661 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/module_interp.F90 @@ -0,0 +1,608 @@ +MODULE module_interp + !!====================================================================== + !! *** MODULE module_interp *** + !! Ocean forcing: bulk thermohaline forcing of the ocean (or ice) + !!===================================================================== + !! History : 2016-10 (F. Lemarié) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zinterp : + !! reconstructandremap : + !! reconstructandremap_ps : + !! + !!---------------------------------------------------------------------- + IMPLICIT NONE + +CONTAINS + + SUBROUTINE zinterp( jpi, jpj, jpka, jpka_in, ind, tab_in, e3t_in, e3_bak, & + & e3t_out, tab_out, interp_type ) + + !!--------------------------------------------------------------------- + !! *** ROUTINE zinterp *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: jpi, jpj + INTEGER, INTENT(in ) :: jpka, jpka_in, interp_type + INTEGER, INTENT(in ) :: ind ( 1:jpi, 1:jpj ) + REAL(8), INTENT(inout) :: tab_in ( 1:jpi, 1:jpj, 1:jpka_in ) + REAL(8), INTENT(in ) :: e3t_in ( 1:jpi, 1:jpj, 1:jpka_in ) + REAL(8), INTENT(in ) :: e3_bak ( 1:jpi, 1:jpj ) + REAL(8), INTENT(in ) :: e3t_out ( 1:jpka+1 ) + REAL(8), INTENT( out) :: tab_out ( 1:jpi, 1:jpj, 1:jpka+1 ) + !! + INTEGER :: ji,jj,k_in + REAL(8) :: val1,val2,cff + + SELECT CASE(interp_type) + CASE(1) ! WENO + DO jj = 1,jpj + DO ji = 1,jpi + k_in = ind( ji, jj ) + val1 = tab_in ( ji, jj, k_in-1 ) + val2 = tab_in ( ji, jj, k_in ) + cff = val1 * e3_bak( ji, jj ) & + & + val2 * e3t_in( ji, jj, k_in-1 ) & + & + (val2-val1) * e3t_in( ji, jj, k_in ) + tab_in( ji, jj, k_in ) = cff / ( e3_bak( ji, jj ) + e3t_in ( ji, jj, k_in-1 ) ) + ! + CALL reconstructandremap( tab_in ( ji, jj, 1:k_in ), e3t_in( ji, jj, 1:k_in ), & + & tab_out( ji, jj, 2:jpka+1 ), e3t_out ( 2:jpka+1 ), & + & k_in, jpka ) + ! + END DO + END DO + CASE(2) ! SPLINES + DO jj = 1,jpj + DO ji = 1,jpi + k_in = ind( ji, jj ) + val1 = tab_in ( ji, jj, k_in-1 ) + val2 = tab_in ( ji, jj, k_in ) + cff = val1 * e3_bak( ji, jj ) & + & + val2 * e3t_in( ji, jj, k_in-1 ) & + & + (val2-val1) * e3t_in( ji, jj, k_in ) + tab_in( ji, jj, k_in ) = cff / ( e3_bak( ji, jj ) + e3t_in ( ji, jj, k_in-1 ) ) + ! + CALL reconstructandremap_ps( tab_in ( ji, jj, 1:k_in ), e3t_in( ji, jj, 1:k_in ), & + & tab_out( ji, jj, 2:jpka+1 ), e3t_out ( 2:jpka+1 ), & + & k_in, jpka ) + ! + END DO + END DO + CASE DEFAULT + WRITE(*,*) "### Error: problem in zinterp, interp_type not set properly" + STOP + END SELECT + ! + END SUBROUTINE zinterp + + + + + +! +!=================================================================================================== +subroutine reconstructandremap(tabin,hin,tabout,hout,N,Nout) +!--------------------------------------------------------------------------------------------------- + implicit none + integer :: N, Nout + real(8) :: tabin(N), tabout(Nout) + real(8) :: hin(N), hout(Nout) + real(8) :: coeffremap(N,3),zwork(N,3) + real(8) :: zwork2(N+1,3) + integer :: k + real(8), parameter :: dsmll=1.0d-8 + real(8) :: q,q01,q02,q001,q002,q0 + real(8) :: z_win(1:N+1), z_wout(1:Nout+1) + real(8),parameter :: dpthin = 1.D-3 + integer :: k1, kbox, ktop, ka, kbot + real(8) :: tsum, qbot, rpsum, zbox, ztop, zthk, zbot, offset, qtop +!----- + +!---------------------- + z_win(1)=0.; z_wout(1)= 0. + do k=1,N + z_win(k+1)=z_win(k)+hin(k) + enddo + + do k=1,Nout + z_wout(k+1)=z_wout(k)+hout(k) + enddo + + do k=2,N + zwork(k,1)=1./(hin(k-1)+hin(k)) + enddo + + do k=2,N-1 + q0 = 1./(hin(k-1)+hin(k)+hin(k+1)) + zwork(k,2)=hin(k-1)+2.*hin(k)+hin(k+1) + zwork(k,3)=q0 + enddo + + do k= 2,N + zwork2(k,1)=zwork(k,1)*(tabin(k)-tabin(k-1)) + enddo + + coeffremap(:,1) = tabin(:) + + do k=2,N-1 + q001 = hin(k)*zwork2(k+1,1) + q002 = hin(k)*zwork2(k,1) + if (q001*q002 < 0) then + q001 = 0. + q002 = 0. + endif + q=zwork(k,2) + q01=q*zwork2(k+1,1) + q02=q*zwork2(k,1) + if (abs(q001) > abs(q02)) q001 = q02 + if (abs(q002) > abs(q01)) q002 = q01 + + q=(q001-q002)*zwork(k,3) + q001=q001-q*hin(k+1) + q002=q002+q*hin(k-1) + + coeffremap(k,3)=coeffremap(k,1)+q001 + coeffremap(k,2)=coeffremap(k,1)-q002 + + zwork2(k,1)=(2.*q001-q002)**2 + zwork2(k,2)=(2.*q002-q001)**2 + enddo + + do k=1,N + if (k.eq.1 .or. k.eq.N .or. hin(k).le.dpthin) then + coeffremap(k,3) = coeffremap(k,1) + coeffremap(k,2) = coeffremap(k,1) + zwork2(k,1) = 0. + zwork2(k,2) = 0. + endif + enddo + + do k=2,N + q002=max(zwork2(k-1,2),dsmll) + q001=max(zwork2(k,1),dsmll) + zwork2(k,3)=(q001*coeffremap(k-1,3)+q002*coeffremap(k,2))/(q001+q002) + enddo + + zwork2(1,3) = 2*coeffremap(1,1)-zwork2(2,3) + zwork2(N+1,3)=2*coeffremap(N,1)-zwork2(N,3) + + do k=1,N + q01=zwork2(k+1,3)-coeffremap(k,1) + q02=coeffremap(k,1)-zwork2(k,3) + q001=2.*q01 + q002=2.*q02 + if (q01*q02<0) then + q01=0. + q02=0. + elseif (abs(q01)>abs(q002)) then + q01=q002 + elseif (abs(q02)>abs(q001)) then + q02=q001 + endif + coeffremap(k,2)=coeffremap(k,1)-q02 + coeffremap(k,3)=coeffremap(k,1)+q01 + enddo + + zbot=0.0 + kbot=1 + do k=1,Nout + ztop=zbot !top is bottom of previous layer + ktop=kbot + if (ztop.ge.z_win(ktop+1)) then + ktop=ktop+1 + endif + + zbot=z_wout(k+1) + zthk=zbot-ztop + + if (zthk.gt.dpthin .and. ztop.lt.z_wout(Nout+1)) then + + kbot=ktop + do while (z_win(kbot+1).lt.zbot.and.kbot.lt.N) + kbot=kbot+1 + enddo + zbox=zbot + do k1= k+1,Nout + if (z_wout(k1+1)-z_wout(k1).gt.dpthin) then + exit !thick layer + else + zbox=z_wout(k1+1) !include thin adjacent layers + if (zbox.eq.z_wout(Nout+1)) then + exit !at bottom + endif + endif + enddo + zthk=zbox-ztop + + kbox=ktop + do while (z_win(kbox+1).lt.zbox.and.kbox.lt.N) + kbox=kbox+1 + enddo + + if (ktop.eq.kbox) then + + + if (z_wout(k) .ne.z_win(kbox) .or.z_wout(k+1).ne.z_win(kbox+1) ) then + + if (hin(kbox).gt.dpthin) then + q001 = (zbox-z_win(kbox))/hin(kbox) + q002 = (ztop-z_win(kbox))/hin(kbox) + q01=q001**2+q002**2+q001*q002+1.-2.*(q001+q002) + q02=q01-1.+(q001+q002) + q0=1.-q01-q02 + else + q0 = 1.0 + q01 = 0. + q02 = 0. + endif + tabout(k)=q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3) + + else + tabout(k) = tabin(kbox) + + endif + + else + + if (ktop.le.k .and. kbox.ge.k) then + ka = k + elseif (kbox-ktop.ge.3) then + ka = (kbox+ktop)/2 + elseif (hin(ktop).ge.hin(kbox)) then + ka = ktop + else + ka = kbox + endif !choose ka + + offset=coeffremap(ka,1) + + qtop = z_win(ktop+1)-ztop !partial layer thickness + if (hin(ktop).gt.dpthin) then + q=(ztop-z_win(ktop))/hin(ktop) + q01=q*(q-1.) + q02=q01+q + q0=1-q01-q02 + else + q0 = 1. + q01 = 0. + q02 = 0. + endif + + tsum =((q0*coeffremap(ktop,1)+q01*coeffremap(ktop,2)+q02*coeffremap(ktop,3))-offset)*qtop + + do k1= ktop+1,kbox-1 + tsum =tsum +(coeffremap(k1,1)-offset)*hin(k1) + enddo !k1 + + + qbot = zbox-z_win(kbox) !partial layer thickness + if (hin(kbox).gt.dpthin) then + q=qbot/hin(kbox) + q01=(q-1.)**2 + q02=q01-1.+q + q0=1-q01-q02 + else + q0 = 1.0 + q01 = 0. + q02 = 0. + endif + + tsum = tsum +((q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3))-offset)*qbot + + rpsum=1.0d0/zthk + tabout(k)=offset+tsum*rpsum + + endif !single or multiple layers + else + if (k==1) then + print *,'problem = ',zthk,z_wout(k+1),hout(1) + endif + tabout(k) = tabout(k-1) + + endif !normal:thin layer + enddo !k + + return + +!--------------------------------------------------------------------------------------------------- +end subroutine reconstructandremap +!=================================================================================================== +! + + + + + + + + + +! +!=================================================================================================== + subroutine reconstructandremap_ps(tabin,hin,tabout,hout,N,Nout) ! parabloc spline +!--------------------------------------------------------------------------------------------------- + implicit none + integer N, Nout + real(8) tabin(N), tabout(Nout) + real(8) hin(N), hout(Nout) + real(8) coeffremap(N,3),zwork(N,3) + real(8) zwork2(N+1,3) + + real(8) my_zwork(0:N,3) + real(8) my_zwork2(0:N,3) + + integer k + double precision, parameter :: dsmll=1.0d-8 + real(8) q,q01,q02,q001,q002,q0 + real(8) z_win(1:N+1), z_wout(1:Nout+1) + real(8),parameter :: dpthin = 1.D-3 + integer :: k1, kbox, ktop, ka, kbot + real(8) :: tsum, qbot, rpsum, zbox, ztop, zthk, zbot, offset, qtop + real(8) :: p + real(8) :: qtri(0:N) + + z_win(1)=0.; z_wout(1)= 0. + do k=1,N + z_win(k+1)=z_win(k)+hin(k) + enddo + + do k=1,Nout + z_wout(k+1)=z_wout(k)+hout(k) + enddo + + do k=2,N + zwork(k,1)=1./(hin(k-1)+hin(k)) + enddo + + do k=2,N-1 + q0 = 1./(hin(k-1)+hin(k)+hin(k+1)) + zwork(k,2)=hin(k-1)+2.*hin(k)+hin(k+1) + zwork(k,3)=q0 + enddo + + do k= 2,N + zwork2(k,1)=zwork(k,1)*(tabin(k)-tabin(k-1)) + enddo + + coeffremap(:,1) = tabin(:) + + do k=2,N-1 + q001 = hin(k)*zwork2(k+1,1) + q002 = hin(k)*zwork2(k,1) + ! if (q001*q002 < 0) then + ! q001 = 0. + ! q002 = 0. + ! endif + q=zwork(k,2) + q01=q*zwork2(k+1,1) + q02=q*zwork2(k,1) + ! if (abs(q001) > abs(q02)) q001 = q02 + ! if (abs(q002) > abs(q01)) q002 = q01 + + q=(q001-q002)*zwork(k,3) + q001=q001-q*hin(k+1) + q002=q002+q*hin(k-1) + + coeffremap(k,3)=coeffremap(k,1)+q001 + coeffremap(k,2)=coeffremap(k,1)-q002 + + zwork2(k,1)=(2.*q001-q002)**2 + zwork2(k,2)=(2.*q002-q001)**2 + enddo + + do k=1,N + if (k.eq.1 .or. k.eq.N .or. hin(k).le.dpthin) then + coeffremap(k,3) = coeffremap(k,1) + coeffremap(k,2) = coeffremap(k,1) + zwork2(k,1) = 0. + zwork2(k,2) = 0. + endif + enddo + + do k=2,N + q002=max(zwork2(k-1,2),dsmll) + q001=max(zwork2(k,1),dsmll) + zwork2(k,3)=(q001*coeffremap(k-1,3)+q002*coeffremap(k,2))/(q001+q002) + enddo + + zwork2(1,3) = 2*coeffremap(1,1)-zwork2(2,3) + zwork2(N+1,3)=2*coeffremap(N,1)-zwork2(N,3) + + do k=1,N + q01=zwork2(k+1,3)-coeffremap(k,1) + q02=coeffremap(k,1)-zwork2(k,3) +! q001=2.*q01 +! q002=2.*q02 +! if (q01*q02<0) then +! q01=0. +! q02=0. +! elseif (abs(q01)>abs(q002)) then +! q01=q002 +! elseif (abs(q02)>abs(q001)) then +! q02=q001 +! endif + coeffremap(k,2)=coeffremap(k,1)-q02 + coeffremap(k,3)=coeffremap(k,1)+q01 + enddo + + + do k=0,N + if (k==0) then + my_zwork(k,1)=0. + my_zwork(k,2)=1. + my_zwork(k,3)=0.5 + my_zwork2(k,1)=1.5*tabin(1) + elseif (k==N) then + my_zwork(k,1)=0.5 + my_zwork(k,2)=1. + my_zwork(k,3)=0. + my_zwork2(k,1)=1.5*tabin(k) + else + my_zwork(k,1)=hin(k+1) + my_zwork(k,2)=2.*(hin(k)+hin(k+1)) + my_zwork(k,3)=hin(k) + my_zwork2(k,1)=3.*(hin(k+1)*tabin(k)+hin(k)*tabin(k+1)) + my_zwork2(k,2)=my_zwork2(k,1) + endif + enddo + + qtri(0)=-my_zwork(0,3)/my_zwork(0,2) + my_zwork2(0,1)=my_zwork2(0,1)/my_zwork(0,2) + + do k=1,N + p=1.0/(my_zwork(k,2)+my_zwork(k,1)*qtri(k-1)) + qtri(k)=-my_zwork(k,3)*p + my_zwork2(k,1)=(my_zwork2(k,1)-my_zwork(k,1)*my_zwork2(k-1,1))*p + enddo + + do k=N-1,0,-1 + my_zwork2(k,1)=my_zwork2(k,1)+qtri(k)*my_zwork2(k+1,1) + enddo + + do k=1,N + coeffremap(k,2)=my_zwork2(k-1,1) + coeffremap(k,3)=my_zwork2(k,1) + enddo + + do k=2,N-1 +! print *,'VAL22 = ',my_zwork(k,1)*my_zwork2(k-1,1) +! &+my_zwork(k,2)*my_zwork2(k,1) +! & +my_zwork(k,3)*my_zwork2(k+1,1),my_zwork2(k,2) + enddo + + zbot=0.0 + kbot=1 + do k=1,Nout + ztop=zbot !top is bottom of previous layer + ktop=kbot + if (ztop.ge.z_win(ktop+1)) then + ktop=ktop+1 + endif + + zbot=z_wout(k+1) + zthk=zbot-ztop + + if (zthk.gt.dpthin .and. ztop.lt.z_wout(Nout+1)) then + + kbot=ktop + do while (z_win(kbot+1).lt.zbot.and.kbot.lt.N) + kbot=kbot+1 + enddo + zbox=zbot + do k1= k+1,Nout + if (z_wout(k1+1)-z_wout(k1).gt.dpthin) then + exit !thick layer + else + zbox=z_wout(k1+1) !include thin adjacent layers + if (zbox.eq.z_wout(Nout+1)) then + exit !at bottom + endif + endif + enddo + zthk=zbox-ztop + + kbox=ktop + do while (z_win(kbox+1).lt.zbox.and.kbox.lt.N) + kbox=kbox+1 + enddo + + if (ktop.eq.kbox) then + + + if (z_wout(k) .ne.z_win(kbox).or.z_wout(k+1).ne.z_win(kbox+1) ) then + + if (hin(kbox).gt.dpthin) then + q001 = (zbox-z_win(kbox))/hin(kbox) + q002 = (ztop-z_win(kbox))/hin(kbox) + q01=q001**2+q002**2+q001*q002+1.-2.*(q001+q002) + q02=q01-1.+(q001+q002) + q0=1.-q01-q02 + else + q0 = 1.0 + q01 = 0. + q02 = 0. + endif + tabout(k)=q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2) & + +q02*coeffremap(kbox,3) + else + tabout(k) = tabin(kbox) + + endif + + else + + if (ktop.le.k .and. kbox.ge.k) then + ka = k + elseif (kbox-ktop.ge.3) then + ka = (kbox+ktop)/2 + elseif (hin(ktop).ge.hin(kbox)) then + ka = ktop + else + ka = kbox + endif !choose ka + + offset=coeffremap(ka,1) + + qtop = z_win(ktop+1)-ztop !partial layer thickness + if (hin(ktop).gt.dpthin) then + q=(ztop-z_win(ktop))/hin(ktop) + q01=q*(q-1.) + q02=q01+q + q0=1-q01-q02 + else + q0 = 1. + q01 = 0. + q02 = 0. + endif + + tsum =((q0*coeffremap(ktop,1)+q01*coeffremap(ktop,2)+ & + q02*coeffremap(ktop,3))-offset)*qtop + + do k1= ktop+1,kbox-1 + tsum =tsum +(coeffremap(k1,1)-offset)*hin(k1) + enddo !k1 + + + qbot = zbox-z_win(kbox) !partial layer thickness + if (hin(kbox).gt.dpthin) then + q=qbot/hin(kbox) + q01=(q-1.)**2 + q02=q01-1.+q + q0=1-q01-q02 + else + q0 = 1.0 + q01 = 0. + q02 = 0. + endif + + tsum = tsum +((q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+ & + q02*coeffremap(kbox,3))-offset)*qbot + + rpsum=1.0d0/zthk + tabout(k)=offset+tsum*rpsum + + endif !single or multiple layers + else + if (k==1) then + print *,'problem = ',zthk,z_wout(k+1),hout(1),hin(1),hin(2) + stop + endif + tabout(k) = tabout(k-1) + + endif !normal:thin layer + enddo !k + + return +!--------------------------------------------------------------------------------------------------- + end subroutine reconstructandremap_ps +!=================================================================================================== +! + +end module module_interp diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/module_io.F90 b/V4.0/nemo_sources/tools/ABL_TOOLS/module_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9c61a2b540388d7d3ccb63298e6e0ab969fc79b5 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/module_io.F90 @@ -0,0 +1,823 @@ +MODULE module_io + !!====================================================================== + !! *** MODULE module_io *** + !! ABL preprocessing tool netcdf I/O subroutines + !!===================================================================== + !! History : 2016-10 (F. Lemarié) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! + !! FUNCTIONS : Var_Existence + !! SUBROUTINES : Read_Ncdf_dim, Write_Ncdf_dim, Read_Ncdf_var1d_Real, + !! Read_Ncdf_var4d_Real_nt, Read_Ncdf_var4d_Real_t, + !! Write_Ncdf_var1d_Real , Write_Ncdf_var2d_Real , + !! Write_Ncdf_var4d_Real_t , Write_Ncdf_var1d_Real_t, + !! Duplicate_lon_lat_time + !!---------------------------------------------------------------------- + USE netcdf + IMPLICIT NONE + + INTERFACE Read_Ncdf_var + MODULE PROCEDURE Read_Ncdf_var1d_Real , & + & Read_Ncdf_var2d_Real , & + & Read_Ncdf_var2d_Real_t , & + & Read_Ncdf_var3d_Real_t , & + & Read_Ncdf_var4d_Real_t , & + & Read_Ncdf_var2d_Real_nt, & + & Read_Ncdf_var4d_Real_nt + END INTERFACE +! + INTERFACE Write_Ncdf_var + MODULE PROCEDURE Write_Ncdf_var1d_Real , & + & Write_Ncdf_var2d_Real , & + & Write_Ncdf_var1d_Real_t, & + & Write_Ncdf_var2d_Real_t, & + & Write_Ncdf_var4d_Real_t + END INTERFACE +! +CONTAINS + + + + + + LOGICAL FUNCTION Var_Existence( varname , filename ) + !!--------------------------------------------------------------------- + !! *** FUNCTION Var_Existence *** + !! + !! ** Purpose : check if variables varname exists in filename file + !! + !!---------------------------------------------------------------------- + CHARACTER(*), intent(in) :: varname,filename + INTEGER :: status,ncid,varid + + status = nf90_open(TRIM(filename),NF90_NOWRITE,ncid) + + IF ( status/=nf90_noerr ) THEN + WRITE(*,*) "*** Var_Existence: unable to open netcdf file : ",TRIM(filename) + stop + END IF + + status = nf90_inq_varid( ncid, varname, varid ) + + IF ( status/=nf90_noerr ) THEN + Var_Existence = .false. + ELSE + Var_Existence = .true. + END IF + + END FUNCTION Var_Existence + + + + SUBROUTINE Read_Ncdf_dim ( dimname, file, dimval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_dim *** + !! + !! ** Purpose : read the integer dimension dimname in input file and + !! store it in dimval + !! + !!---------------------------------------------------------------------- + + CHARACTER(*),INTENT(in) :: dimname,file + INTEGER :: dimval + INTEGER :: ncid,status,dimid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + + IF ( status/=nf90_noerr ) THEN + WRITE(*,*)"*** Read_Ncdf_dim: unable to open netcdf file : ",trim(file) + STOP + END IF + ! + status = nf90_inq_dimid ( ncid, dimname, dimid ) + status = nf90_inquire_dimension( ncid, dimid, len=dimval ) + status = nf90_close( ncid ) + + END SUBROUTINE Read_Ncdf_dim + + + + + + + + SUBROUTINE Write_Ncdf_dim( dimname, file, dimval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_dim *** + !! + !! ** Purpose : write the dimension dimname in the output file + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: dimname,file + INTEGER :: dimval + INTEGER :: ncid,status,dimid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*)"*** Write_Ncdf_dim: to open netcdf file : ",file + STOP + END IF + + status = nf90_redef(ncid) + + If( dimval.eq.0 ) THEN + status = nf90_def_dim(ncid,dimname,nf90_unlimited,dimid) + ELSE + status = nf90_def_dim(ncid,dimname,dimval,dimid) + END If + !! + status = nf90_enddef(ncid) + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_dim + + + + + + + SUBROUTINE Read_Ncdf_var1d_Real( varname, file, tabvar ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var1d_Real *** + !! + !! ** Purpose : read the 1D variable varname in the input file + !! and store it in tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file + REAL(8), DIMENSION(:),ALLOCATABLE :: tabvar + INTEGER, DIMENSION(1) :: dimID + INTEGER :: dim1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*) "*** Read_Ncdf_var1d_Real: unable to open netcdf file : ",file + STOP + END IF + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_inquire_variable(ncid,varid,dimids=dimID) + status = nf90_inquire_dimension(ncid,dimID(1),len=dim1) + IF( .not. allocated(tabvar) ) THEN + ALLOCATE( tabvar ( dim1 ) ) + ELSE + IF ( any(shape(tabvar)/=(/dim1/)) ) THEN + DEALLOCATE ( tabvar ) + ALLOCATE ( tabvar ( dim1 ) ) + WRITE(*,*) 'Warning change shape of array for ',trim(varname) + END IF + END IF + status = nf90_get_var(ncid,varid,tabvar) + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var1d_Real + + + SUBROUTINE Read_Ncdf_var2d_Real( varname, file, tabvar ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var2d_Real *** + !! + !! ** Purpose : read the 2D variable varname in the input file + !! and store it in 2D tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname, file + REAL(8), DIMENSION(:,:), INTENT(inout) :: tabvar + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"*** Read_Ncdf_var2d_Real: unable to open netcdf file : ",file + STOP + END IF + status = nf90_inq_varid (ncid , varname, varid) + status = nf90_inquire_variable (ncid , varid, dimids=dimIDS) + status = nf90_inquire_dimension(ncid , dimIDS(1), len=dim1) + status = nf90_inquire_dimension(ncid , dimIDS(2), len=dim2) + status = nf90_get_var( ncid, varid, tabvar(:,:), & + & start = (/1,1/), count=(/dim1,dim2/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*)"in file : ",trim(file) + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Real + + + SUBROUTINE Read_Ncdf_var2d_Real_nt( varname, file, tabvar, time, level ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var2d_Real_nt *** + !! + !! ** Purpose : read the 4D variable varname in the input file + !! for a given time and vertical level, and store it in 2D tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname, file + INTEGER , INTENT(in) :: time, level + !REAL(8), DIMENSION(:,:), ALLOCATABLE :: tabvar + REAL(8), DIMENSION(:,:), INTENT(inout) :: tabvar + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"*** Read_Ncdf_var2d_Real_nt: unable to open netcdf file : ",file + STOP + END IF + status = nf90_inq_varid (ncid , varname, varid) + status = nf90_inquire_variable (ncid , varid, dimids=dimIDS) + status = nf90_inquire_dimension(ncid , dimIDS(1), len=dim1) + status = nf90_inquire_dimension(ncid , dimIDS(2), len=dim2) + !IF( .not. allocated( tabvar ) ) then + ! ALLOCATE ( tabvar( dim1, dim2 ) ) + !ELSE + ! IF ( (size(tabvar,1) /= dim1) .OR. (size(tabvar,2) /= dim2) ) THEN + ! DEALLOCATE( tabvar ) + ! ALLOCATE ( tabvar (dim1, dim2 ) ) + ! END IF + !END IF + status = nf90_get_var( ncid, varid, tabvar(:,:), & + & start = (/1,1,level,time/), count=(/dim1,dim2,1,1/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*)"in file : ",trim(file) + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Real_nt + + + + + SUBROUTINE Read_Ncdf_var4d_Real_nt( varname, file, tabvar, time, level ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var4d_Real_nt *** + !! + !! ** Purpose : read the 4D variable varname in the input file + !! for a given time and vertical level, and store it in 4D tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file + INTEGER , INTENT(in) :: time,level + !REAL(8), DIMENSION(:,:,:,:),ALLOCATABLE :: tabvar + REAL(8), DIMENSION(:,:,:,:),INTENT(inout) :: tabvar + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"*** Read_Ncdf_var4d_Real_nt: unable to open netcdf file : ",file + STOP + END IF + status = nf90_inq_varid (ncid , varname, varid) + status = nf90_inquire_variable (ncid , varid, dimids=dimIDS) + status = nf90_inquire_dimension(ncid , dimIDS(1), len=dim1) + status = nf90_inquire_dimension(ncid , dimIDS(2), len=dim2) + !IF( .not. allocated( tabvar ) ) then + ! ALLOCATE ( tabvar( dim1, dim2, 1, 1 ) ) + !ELSE + ! IF ( (size(tabvar,1) /= dim1) .OR. (size(tabvar,2) /= dim2) ) THEN + ! DEALLOCATE( tabvar ) + ! ALLOCATE ( tabvar (dim1, dim2, 1, 1 ) ) + ! END IF + !END IF + status = nf90_get_var( ncid, varid, tabvar(:,:,:,:), & + & start = (/1,1,level,time/), count=(/dim1,dim2,1,1/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*)"in file : ",trim(file) + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Real_nt + + + + + + + SUBROUTINE Read_Ncdf_var3d_Real_t( varname, file, tabvar, time) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var3d_Real_t *** + !! + !! ** Purpose : read the 3D variable varname in the input file + !! for a given time level, and store it in tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file + INTEGER , INTENT(in) :: time + !REAL(8), DIMENSION(:,:,:),ALLOCATABLE :: tabvar + REAL(8), DIMENSION(:,:,:), INTENT(inout) :: tabvar + INTEGER, DIMENSION(3) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) then + WRITE(*,*)"*** Read_Ncdf_var3d_Real_t: unable to open netcdf file : ",file + STOP + END IF + + status = nf90_inq_varid (ncid, varname,varid) + status = nf90_inquire_variable (ncid, varid,dimids=dimIDS) + status = nf90_inquire_dimension(ncid, dimIDS(1),len=dim1) + status = nf90_inquire_dimension(ncid, dimIDS(2),len=dim2) + + !IF( .not. allocated(tabvar) ) ALLOCATE(tabvar(dim1,dim2,1)) + + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,time/)) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*)"in file : ",trim(file) + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var3d_Real_t + + + SUBROUTINE Read_Ncdf_var2d_Real_t(varname,file,tabvar,time) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var2d_Real_t *** + !! + !! ** Purpose : read the 3D variable varname in the input file + !! for a given time level, and store it in tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file + INTEGER , INTENT(in) :: time + !REAL(8), DIMENSION(:,:),ALLOCATABLE :: tabvar + REAL(8), DIMENSION(:,:), INTENT(inout) :: tabvar + INTEGER, DIMENSION(3) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) then + WRITE(*,*)"*** Read_Ncdf_var2d_Real_t: unable to open netcdf file : ",file + STOP + END IF + + status = nf90_inq_varid (ncid, varname,varid) + status = nf90_inquire_variable (ncid, varid,dimids=dimIDS) + status = nf90_inquire_dimension(ncid, dimIDS(1),len=dim1) + status = nf90_inquire_dimension(ncid, dimIDS(2),len=dim2) + + !IF( .not. allocated(tabvar) ) ALLOCATE(tabvar(dim1,dim2)) + + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,time/)) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*)"in file : ",trim(file) + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Real_t + + + SUBROUTINE Read_Ncdf_var4d_Real_t(varname,file,tabvar,time) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Read_Ncdf_var4d_Real_t *** + !! + !! ** Purpose : read the 4D variable varname in the input file + !! for a given time level, and store it in tabvar + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file + INTEGER , INTENT(in) :: time + !REAL(8), DIMENSION(:,:,:,:),ALLOCATABLE :: tabvar + REAL(8), DIMENSION(:,:,:,:), INTENT(inout):: tabvar + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) then + WRITE(*,*)"*** Read_Ncdf_var4d_Real_t: unable to open netcdf file : ",file + STOP + END IF + + status = nf90_inq_varid (ncid, varname,varid) + status = nf90_inquire_variable (ncid, varid,dimids=dimIDS) + status = nf90_inquire_dimension(ncid, dimIDS(1),len=dim1) + status = nf90_inquire_dimension(ncid, dimIDS(2),len=dim2) + status = nf90_inquire_dimension(ncid, dimIDS(3),len=dim3) + + !IF( .not. allocated(tabvar) ) ALLOCATE(tabvar(dim1,dim2,dim3,1)) + + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*) "unable to retrieve netcdf variable : ",trim(varname) + WRITE(*,*) "in file : ",trim(file) + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Real_t + + + + + + + SUBROUTINE Write_Ncdf_var1d_Real( varname, dimname, file, tabvar, typevar ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_var1d_Real *** + !! + !! ** Purpose : write the 1D variable varname stored in tabvar + !! in the output file using typevar type (float or double) + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file,dimname,typevar + REAL(8), DIMENSION(:), INTENT(in) :: tabvar + INTEGER :: dimid + INTEGER :: status,ncid + INTEGER :: varid +! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) then + WRITE(*,*)"*** Write_Ncdf_var1d_Real: unable to open netcdf file : ",file + STOP + END IF + status = nf90_inq_dimid(ncid,dimname, dimid) + status = nf90_redef(ncid) + SELECT CASE( TRIM(typevar) ) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double,(/dimid/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float,(/dimid/),varid) + END SELECT + status = nf90_enddef ( ncid ) + status = nf90_put_var( ncid ,varid,tabvar) + status = nf90_close ( ncid ) + ! + END SUBROUTINE Write_Ncdf_var1d_Real + + + + + + SUBROUTINE Write_Ncdf_var2d_Real( varname, dimname, file, tabvar, typevar ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_var2d_Real *** + !! + !! ** Purpose : write the 2D variable varname stored in tabvar + !! in the output file using typevar type (float or double) + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname, file, typevar + CHARACTER(*), DIMENSION(2), INTENT(in) :: dimname + REAL(8), DIMENSION(:,:), INTENT(in) :: tabvar + INTEGER :: dimid1, dimid2 + INTEGER :: status, ncid + INTEGER :: varid +! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) then + WRITE(*,*)"*** Write_Ncdf_var2d_Real: unable to open netcdf file : ",file + WRITE(*,*)"*** Write_Ncdf_var2d_Real: variable : ", varname + STOP + END IF + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_varid(ncid,varname,varid) + IF (status /= nf90_noerr) THEN + status = nf90_redef(ncid) + SELECT CASE( TRIM(typevar) ) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + & (/dimid1,dimid2/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + & (/dimid1,dimid2/),varid) + END SELECT + status = nf90_enddef(ncid) + END IF + status = nf90_put_var(ncid,varid,tabvar) + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var2d_Real + + + + + + + SUBROUTINE Write_Ncdf_var4d_Real_t( varname, dimname, file, tabvar, time, typevar ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_var4d_Real_t *** + !! + !! ** Purpose : write the 4D variable varname stored in tabvar + !! in the output file at time level time using typevar type (float or double) + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file,typevar + CHARACTER(*), DIMENSION(4) , INTENT(in) :: dimname + INTEGER, INTENT(in) :: time + REAL(8), DIMENSION(:,:,:,:), INTENT(in) :: tabvar + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid +! + status = nf90_open(file,NF90_WRITE,ncid) + IF ( status/=nf90_noerr ) THEN + WRITE(*,*)"*** Write_Ncdf_var4d_Real_t: unable to open netcdf file : ",file + STOP + END IF + IF ( time==1 .and. (TRIM(typevar)=='double' .or. TRIM(typevar)=='float') ) THEN + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + & (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + & (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + status = nf90_enddef(ncid) + ELSE + status = nf90_inq_varid(ncid, varname, varid) + END IF + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + WRITE(*,*)"erorr code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var4d_Real_t + + + + + + + + + SUBROUTINE Write_Ncdf_var1d_Real_t(varname,dimname,file,tabvar,time,typevar) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_var1d_Real_t *** + !! + !! ** Purpose : write the 1D variable varname stored in tabvar + !! in the output file at time level time using typevar type (float or double) + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname,file,typevar + CHARACTER(*), DIMENSION(1) ,INTENT(in) :: dimname + INTEGER, INTENT(in) :: time + REAL(8), DIMENSION(:), INTENT(in) :: tabvar + INTEGER :: dimid1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*) "*** Write_Ncdf_var1d_Real_t: unable to open netcdf file : ",file + STOP + END IF + + IF( time==1 ) THEN + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_redef(ncid) + SELECT CASE ( TRIM(typevar) ) + CASE ('double') + status = nf90_def_var(ncid,varname,nf90_double, & + & (/dimid1/),varid) + CASE ('float') + status = nf90_def_var(ncid,varname,nf90_float, & + & (/dimid1/),varid) + END SELECT + status = nf90_enddef(ncid) + ELSE + status = nf90_inq_varid(ncid, varname, varid) + END IF + + status = nf90_put_var(ncid,varid,tabvar,start=(/time/)) + + IF (status/=nf90_noerr) THEN + WRITE(*,*) "unable to store variable ",varname, & + " in file ",file + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var1d_Real_t + + + + SUBROUTINE Write_Ncdf_var2d_Real_t( varname, dimname, file, tabvar, time, typevar) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Write_Ncdf_var2d_Real_t *** + !! + !! ** Purpose : write the 1D variable varname stored in tabvar + !! in the output file at time level time using typevar type (float or double) + !! + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: varname, file, typevar + CHARACTER(*), DIMENSION(2), INTENT(in) :: dimname + INTEGER, INTENT(in) :: time + REAL(8), DIMENSION(:,:), INTENT(in) :: tabvar + INTEGER :: dimid1, dimid2, dimidt + INTEGER :: status,ncid + INTEGER :: varid + INTEGER, DIMENSION(2) :: dim_size + ! + status = nf90_open( file, NF90_WRITE, ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*) "*** Write_Ncdf_var2d_Real_t: unable to open netcdf file : ",file + STOP + END IF + + IF( time==1 ) THEN + status = nf90_inq_dimid( ncid, dimname(1), dimid1) + status = nf90_inq_dimid( ncid, dimname(2), dimid2) + status = nf90_inq_dimid( ncid, "time" , dimidt) + !status = nf90_def_dim( ncid, "time", NF90_UNLIMITED, dimidt) + status = nf90_redef(ncid) + SELECT CASE ( TRIM(typevar) ) + CASE ('double') + status = nf90_def_var( ncid, varname, nf90_double, & + & (/dimid1,dimid2,dimidt/), varid) + CASE ('float') + status = nf90_def_var( ncid, varname, nf90_float, & + & (/dimid1,dimid2,dimidt/), varid) + END SELECT + status = nf90_enddef(ncid) + ELSE + status = nf90_inq_varid( ncid, varname, varid ) + END IF + + dim_size = SHAPE(tabvar) + status = nf90_put_var( ncid, varid, tabvar(:,:), start=(/1,1,time/), count=(/dim_size(1),dim_size(2),1/) ) + + IF (status/=nf90_noerr) THEN + WRITE(*,*) "unable to store variable ",varname, & + " in file ",file + WRITE(*,*) "error code: ", status + STOP + END IF + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var2d_Real_t + + + + SUBROUTINE add_globatt_real( file, att_name, att_value ) + + INTEGER :: ncid, status + CHARACTER(*) :: file, att_name + REAL(8) :: att_value + + status = nf90_open( file, nf90_write, ncid) + + ! Enter define mode so we can add the attribute + status = nf90_redef( ncid ) + + ! ... put the range attribute, setting it to eight byte reals... + status = nf90_put_att( ncid, NF90_GLOBAL, att_name, att_value ) + + ! Leave define mode + status = nf90_enddef(ncid) + + END SUBROUTINE add_globatt_real + + + + SUBROUTINE Duplicate_lon_lat_time( file_in, file_out ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Duplicate_lon_lat_time *** + !! + !! ** Purpose : duplicate the attribute of lon, lat and time variables + !! from file_in in file_out + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: file_in, file_out + INTEGER :: status + INTEGER :: ncid_in, ncid_out + INTEGER :: varid_in,varid_out + + status = nf90_open(file_in ,NF90_NOWRITE,ncid_in ) + status = nf90_open(file_out,NF90_WRITE ,ncid_out) + + status = nf90_inq_varid(ncid_in,'lon',varid_in) + status = nf90_inq_varid(ncid_out,'lon',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'standard_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'axis',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'lat',varid_in) + status = nf90_inq_varid(ncid_out,'lat',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'standard_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'axis',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'time',varid_in) + status = nf90_inq_varid(ncid_out,'time',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'standard_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'calendar',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'axis',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + ! + END SUBROUTINE Duplicate_lon_lat_time + + + + SUBROUTINE Duplicate_lev_hyb( file_in, file_out ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE Duplicate_lon_lat_time *** + !! + !! ** Purpose : duplicate the attribute of lon, lat and time variables + !! from file_in in file_out + !!---------------------------------------------------------------------- + CHARACTER(*), INTENT(in) :: file_in, file_out + INTEGER :: status + INTEGER :: ncid_in, ncid_out + INTEGER :: varid_in,varid_out + + status = nf90_open(file_in ,NF90_NOWRITE,ncid_in ) + status = nf90_open(file_out,NF90_WRITE ,ncid_out) + + status = nf90_inq_varid(ncid_in,'hyai',varid_in) + status = nf90_inq_varid(ncid_out,'hyai',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'hybi',varid_in) + status = nf90_inq_varid(ncid_out,'hybi',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'hyam',varid_in) + status = nf90_inq_varid(ncid_out,'hyam',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'hybm',varid_in) + status = nf90_inq_varid(ncid_out,'hybm',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_inq_varid(ncid_in,'lev',varid_in) + status = nf90_inq_varid(ncid_out,'lev',varid_out) + status = nf90_redef(ncid_out) + status = nf90_copy_att(ncid_in,varid_in,'standard_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'formula',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'formula_terms',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'positive',ncid_out,varid_out) + status = nf90_enddef(ncid_out) + + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + ! + END SUBROUTINE Duplicate_lev_hyb + +END MODULE module_io diff --git a/V4.0/nemo_sources/tools/ABL_TOOLS/namelist_abl_tools b/V4.0/nemo_sources/tools/ABL_TOOLS/namelist_abl_tools new file mode 100644 index 0000000000000000000000000000000000000000..ede2ea04b05bae0190d5d0ee5a09e915f2ce3517 --- /dev/null +++ b/V4.0/nemo_sources/tools/ABL_TOOLS/namelist_abl_tools @@ -0,0 +1,53 @@ +: +:----------------------------------------------------------------------------- +: Atmospheric Boundary Layer preprocessing tool +:----------------------------------------------------------------------------- +: +&nml_dom + jpka = 50, + hmax = 2000., + theta_s = 2., + hc = 100., + ln_impose_z1 = .true., + z1 = 10., +/ + +&nml_opt + ptemp_method = 3 , ! potential temperature computation method + ln_slp_smth = .true. , ! smooth slp and ghw at high latitudes only + ln_drw_smth = .false. , ! smooth after drowning + ln_slp_log = .false. , ! read log(slp) + ln_read_zsurf = .false. , ! read surface geopotential + ln_hpg_frc = .true. , ! compute horizontal pressure gradient + ln_geo_wnd = .false. , ! compute geostrophic wind + ln_c1d = .false. , ! 1D case + ln_read_mask = .true. , ! read mask file + ln_lsm_land = .false. , ! inverse land & sea masks + ln_perio_latbc = .true. , ! periodic lateral boundary conditions +/ + +&nml_fld + cn_dir = '', + mask_var = 'LSM', + file_m = 'MASK.nc', + file_u = 'U3D.nc', + file_v = 'V3D.nc', + file_t = 'T3D.nc', + file_q = 'Q3D.nc', + file_p = 'P2D.nc', + file_z = 'Z2D.nc', + file_geos = 'UVG_OUT.nc', + file_hpg = 'HPG_OUT.nc', +/ + +&nml_out + grd_file = 'dom_cfg_abl_L50Z10.nc', + abl_file = 'ABL_L50Z10_OUT.nc', + drwn_file = 'ABL_DRWN_L50Z10_OUT.nc', + var_name = '', +/ + +&nml_c1d + iloc = 283, + jloc = 52, +/ diff --git a/V4.0/nemo_sources/tools/BDY_TOOLS/bdy_reorder b/V4.0/nemo_sources/tools/BDY_TOOLS/bdy_reorder new file mode 100755 index 0000000000000000000000000000000000000000..4b0c2b9df69e42650a50c94d70a53c6fb96dd165 --- /dev/null +++ b/V4.0/nemo_sources/tools/BDY_TOOLS/bdy_reorder @@ -0,0 +1,58 @@ +#!/bin/ksh + +# CALLS: bdy_reorder.exe + +#set -ax +usage () +{ + echo + echo " bdy_reorder" + echo " ************" + echo + echo " usage: ${0##*/} [-c] file_in file_out" + echo + echo " flags: -c target file is a coordinates.bdy.nc file" + echo " -t template file" + echo + exit 1 +} + +ln_coordinates=".false." +file_template="" + +while getopts ct: opt +do + case ${opt} in + c) + ln_coordinates=".true." + ;; + t) + file_template=${OPTARG} + ;; + [?]) usage + ;; + esac +done +shift $(expr ${OPTIND} - 1) + +if [[ $# < 2 ]] ; then + usage +fi + +script_dir=$(dirname $0) + +file_in=$1 +file_out=$2 + +cat > nam_bdy_reorder << EOC +&nam_bdy_reorder +file_in='${file_in}' +file_out='${file_out}' +file_template='${file_template}' +ln_coordinates=${ln_coordinates} +EOC +echo "/" >> nam_bdy_reorder + +${script_dir}/bdy_reorder.exe + +exit 0 diff --git a/V4.0/nemo_sources/tools/BDY_TOOLS/src/bdy_reorder.f90 b/V4.0/nemo_sources/tools/BDY_TOOLS/src/bdy_reorder.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4985f80b881030d12b09af27cb10d9408651b3ae --- /dev/null +++ b/V4.0/nemo_sources/tools/BDY_TOOLS/src/bdy_reorder.f90 @@ -0,0 +1,609 @@ +PROGRAM bdy_reorder + +!=============================================================================== +! A routine to reorder old BDY data files to make them compatible with NEMO 3.4. +! +! This routine has 2 modes: +! 1. If no template file is given then it will re-order the data in the input +! file so that it is in order of increasing nbr. +! 2. If a template file is given it will re-order the data in the input file +! be consistent with the order of the data in the template file. This is +! useful for making old barotropic and baroclinic data files consistent. +! For older versions of NEMO the barotropic boundary data did not have to +! be in the same order as the baroclinic boundary data. The rimwidth +! value can be different in the input file and template file; in this case +! the routine will just re-order the data that the two files have in common. +! +! The routine is mainly for re-ordering BDY data files, but can also be used to +! re-order BDY coordinate files if ln_coordinates is set to .true. +! +! Author: Dave Storkey Aug 2011 +! Bug notifications etc to: dave.storkey@metoffice.gov.uk +! +!=============================================================================== + + USE netcdf + + IMPLICIT NONE + + INTEGER,PARAMETER :: numnam=11 + INTEGER,PARAMETER :: sp=SELECTED_REAL_KIND(6,37) + INTEGER,PARAMETER :: dp=SELECTED_REAL_KIND(12,307) + INTEGER :: chunksize = 32000000 + + INTEGER :: jpbgrd, iostat, ncid_in, ncid_out, ncid_template, nbrid(4), nbrid_template(4) + INTEGER :: dimids(10), unlimitedDimId + INTEGER :: xtype, dimid, varid, ndims, ndims_var, nvars, natts, nblen(4), nblen_template(4), dimlen(10) + INTEGER :: lenvar(10), igrid, ib, ib1, ir, idim, jgrid, jv, icount, attid, len1, idepth, itime + INTEGER :: idim_time, idim_xb, idim_yb, idim_depth + INTEGER :: nbr_min, nbr_max, nbr_min_template, nbr_max_template, strlen, nbr_match + + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: nbr, imap + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: nbi, nbj + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: nbi_template + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: nbj_template + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: nbr_template + + INTEGER, ALLOCATABLE, DIMENSION(:) :: nbi_extract, nbj_extract + + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:) :: varin_int, varout_int + REAL(sp), ALLOCATABLE, DIMENSION(:,:,:,:) :: varin_float, varout_float + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: varin_dble, varout_dble + + LOGICAL :: ln_coordinates + LOGICAL :: ln_template + + CHARACTER(LEN=nf90_max_name) :: attname, dimname, varname, time, date, zone, timestamp + CHARACTER(LEN=nf90_max_name) :: file_in, file_out, file_template, nbi_name, nbj_name, nbr_name + CHARACTER(LEN=1),DIMENSION(4) :: cgrid + CHARACTER(LEN=1) :: end_letter + + NAMELIST/nam_bdy_reorder/ file_in, file_out, file_template, ln_coordinates, nbr_match + +!============================================================================= + +!----------------------------------------------------------------------------- +! 0. Read namelist and initialise parameters +!----------------------------------------------------------------------------- + + file_in = '' + file_out = '' + file_template = '' + ln_coordinates = .false. + nbr_match = 0 + + OPEN( UNIT=numnam, FILE='nam_bdy_reorder', FORM='FORMATTED', STATUS='OLD' ) + READ( numnam, nam_bdy_reorder ) + CLOSE( UNIT=numnam ) + + IF( ln_coordinates ) THEN + WRITE(*,*) 'Input file is a coordinates.bdy.nc file.' + jpbgrd = 4 + ELSE + WRITE(*,*) 'Input file is a boundary data file.' + jpbgrd = 1 + ENDIF + + IF( LEN_TRIM(file_template) > 0 ) THEN + WRITE(*,*) 'Reordering data to match template file.' + ln_template = .true. + ELSE + WRITE(*,*) 'Reordering data in order of increasing nbr values.' + ln_template = .false. + ENDIF + + cgrid= (/'t','u','v','f'/) + +!----------------------------------------------------------------------------- +! 1. Read in nbr variables from file and create mapping. +!----------------------------------------------------------------------------- + +! 1.1 Open input files + + iostat = nf90_open( TRIM(file_in), nf90_nowrite, ncid_in ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_inquire( ncid_in, ndims, nvars, natts ) + + IF( ln_template ) THEN + iostat = nf90_open( TRIM(file_template), nf90_nowrite, ncid_template ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + ENDIF + + DO igrid=1,jpbgrd + +! 1.2 Find dimensions of data in input files and allocate arrays + + IF( ln_coordinates ) THEN + nbr_name = 'nbr'//cgrid(igrid) + ELSE + nbr_name = 'nbrdta' + ENDIF + + iostat = nf90_inq_varid( ncid_in, nbr_name , nbrid(igrid) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_inquire_variable( ncid_in, nbrid(igrid), ndims=ndims, dimids=dimids ) + IF( ndims .ne. 2 ) THEN + WRITE(*,*) 'ERROR : ',TRIM(nbr_name),' does not have exactly 2 dimensions.' + WRITE(*,*) ' in file ',TRIM(file_in) + STOP + ENDIF + iostat = nf90_inquire_dimension( ncid_in, dimids(1), len=nblen(igrid)) + iostat = nf90_inquire_dimension( ncid_in, dimids(2), len=len1) + WRITE(*,*) 'nblen(igrid), len1 : ',nblen(igrid), len1 + IF( len1 .ne. 1 ) THEN + WRITE(*,*) 'ERROR : second dimension of ',TRIM(nbr_name),' does not have length 1.' + WRITE(*,*) ' in file ',TRIM(file_in) + WRITE(*,*) ' len1 = ',len1 + STOP + ENDIF + + IF( ln_template ) THEN + + iostat = nf90_inq_varid( ncid_template, nbr_name , nbrid_template(igrid) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_inquire_variable( ncid_template, nbrid_template(igrid), ndims=ndims, dimids=dimids ) + IF( ndims .ne. 2 ) THEN + WRITE(*,*) 'ERROR : ',TRIM(nbr_name),' does not have exactly 2 dimensions.' + WRITE(*,*) ' in file ',TRIM(file_template) + STOP + ENDIF + iostat = nf90_inquire_dimension( ncid_template, dimids(1), len=nblen_template(igrid)) + iostat = nf90_inquire_dimension( ncid_template, dimids(2), len=len1) + WRITE(*,*) 'nblen_template(igrid), len1 : ',nblen_template(igrid), len1 + IF( len1 .ne. 1 ) THEN + WRITE(*,*) 'ERROR : second dimension of ',TRIM(nbr_name),' does not have length 1.' + WRITE(*,*) ' in file ',TRIM(file_template) + WRITE(*,*) ' len1 = ',len1 + STOP + ENDIF + + ENDIF ! ln_template + + ENDDO ! jpbgrd + + ALLOCATE( nbr(MAXVAL(nblen),1), imap(MAXVAL(nblen),jpbgrd) ) + IF( ln_template ) THEN + ALLOCATE( nbi(MAXVAL(nblen),1), nbj(MAXVAL(nblen),1) ) + ALLOCATE( nbi_template(MAXVAL(nblen_template),1) ) + ALLOCATE( nbj_template(MAXVAL(nblen_template),1) ) + ALLOCATE( nbr_template(MAXVAL(nblen_template),1) ) + ENDIF + +! 1.3 Read in nbr variables and generate mapping. + + nbr(:,:) = -1 + imap(:,:) = -1 + IF( ln_template ) THEN + nbi(:,:) = -1 + nbj(:,:) = -1 + nbi_template(:,:) = -1 + nbj_template(:,:) = -1 + nbr_template(:,:) = -1 + ENDIF + + WRITE(*,*) '>>> Generating map.' + DO igrid=1,jpbgrd + + iostat = nf90_get_var( ncid_in, nbrid(igrid), nbr(1:nblen(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + + nbr_min = MINVAL( nbr(1:nblen(igrid),1) ) + nbr_max = MAXVAL( nbr(1:nblen(igrid),1) ) + IF( nbr_min .ne. 1 ) THEN + WRITE(*,*) 'Something wrong with input file ',file_in + WRITE(*,*) 'MIN(nbr) /= 1' + STOP + ENDIF + + IF( ln_template ) THEN + + IF( ln_coordinates ) THEN + nbi_name = 'nbi'//cgrid(igrid) + nbj_name = 'nbj'//cgrid(igrid) + ELSE + nbi_name = 'nbidta' + nbj_name = 'nbjdta' + ENDIF + + ! read in nbi, nbj values from input file + iostat = nf90_inq_varid( ncid_in, nbi_name, varid ) + IF (iostat == nf90_noerr) iostat = nf90_get_var( ncid_in, varid, nbi(1:nblen(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_inq_varid( ncid_in, nbj_name, varid ) + IF (iostat == nf90_noerr) iostat = nf90_get_var( ncid_in, varid, nbj(1:nblen(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + + ! read in nbi, nbj, nbr values from template file + iostat = nf90_inq_varid( ncid_template, nbi_name, varid ) + IF (iostat == nf90_noerr) iostat = nf90_get_var( ncid_template, varid, nbi_template(1:nblen_template(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_inq_varid( ncid_template, nbj_name, varid ) + IF (iostat == nf90_noerr) iostat = nf90_get_var( ncid_template, varid, nbj_template(1:nblen_template(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + iostat = nf90_get_var( ncid_template, nbrid_template(igrid), nbr_template(1:nblen_template(igrid),1:1) ) + IF (iostat /= nf90_noerr) THEN + WRITE(6,*) TRIM(nf90_strerror(iostat)) + STOP + ENDIF + + nbr_min_template = MINVAL( nbr_template(1:nblen_template(igrid),1) ) + nbr_max_template = MAXVAL( nbr_template(1:nblen_template(igrid),1) ) + IF( nbr_min_template .ne. 1 ) THEN + WRITE(*,*) 'Something wrong with template file ',file_template + WRITE(*,*) 'MIN(nbr) /= 1' + STOP + ENDIF + + IF( nbr_match .lt. 1 ) nbr_match = MIN(nbr_max, nbr_max_template) + + ! initialise imap to the identity mapping + DO ib = 1, nblen(igrid) + imap(ib, igrid) = ib + ENDDO + + ! allocate "extract" arrays + icount = 0 + DO ib = 1, nblen_template(igrid) + IF( nbr_template(ib,1) .eq. 1 ) THEN + icount = icount+1 + ENDIF + ENDDO + ALLOCATE( nbi_extract(icount), nbj_extract(icount) ) + + DO ir = 1, nbr_match + + ! extract values from template array for this ir value + icount = 0 + DO ib = 1, nblen_template(igrid) + IF( nbr_template(ib,1) .eq. ir ) THEN + icount = icount+1 + nbi_extract(icount) = nbi_template(ib,1) + nbj_extract(icount) = nbj_template(ib,1) + ENDIF + ENDDO + + ! work out the mapping for this ir value + icount = 1 + DO ib = 1, nblen(igrid) + IF( nbr(ib,1) .eq. ir ) THEN + DO ib1 = 1, nblen(igrid) + IF( nbi(ib1,1) .eq. nbi_extract(icount) .and. & + & nbj(ib1,1) .eq. nbj_extract(icount) ) THEN + imap(ib,igrid) = ib1 + icount = icount + 1 + EXIT + ENDIF + ENDDO ! ib1 + ENDIF + ENDDO ! ib + + ENDDO ! ir + + DEALLOCATE( nbi_extract, nbj_extract ) + + ELSE + + icount = 0 + DO ir = nbr_min, nbr_max + DO ib = 1, nblen(igrid) + IF( nbr(ib,1) .eq. ir ) THEN + icount = icount + 1 + imap(icount,igrid) = ib + ENDIF + ENDDO + ENDDO + + ENDIF + + ENDDO ! jpbgrd + +!----------------------------------------------------------------------------- +! 2. Open output file and copy dimensions and attributes across +!----------------------------------------------------------------------------- + + iostat = nf90_inquire( ncid_in, ndims, nvars, natts ) + +! 2.1 Create the output file + + WRITE(*,*) '>>> Initialising output file.' + iostat = nf90_create( TRIM(file_out), nf90_64bit_offset, ncid_out, chunksize=chunksize) + +! 2.2 Copy the dimensions into the output file. + + iostat = nf90_inquire( ncid_in, unlimitedDimId = unlimitedDimId ) + dimlen(:) = 1 + DO idim = 1, ndims + iostat = nf90_inquire_dimension(ncid_in, idim, dimname, dimlen(idim)) + IF (idim == unlimitedDimId) THEN + iostat = nf90_def_dim( ncid_out, dimname, nf90_unlimited, dimid) + idim_time = idim + ELSE + iostat = nf90_def_dim( ncid_out, dimname, dimlen(idim), dimid) + IF( INDEX(dimname,'x') .gt. 0 ) THEN + idim_xb = idim + ELSE IF( INDEX(dimname,'y') .gt. 0 ) THEN + idim_yb = idim + ELSE IF( INDEX(dimname,'depth') .gt. 0 .or. INDEX(dimname,'z') .gt. 0 ) THEN + idim_depth = idim + ELSE + WRITE(*,*) 'ERROR: Unrecognised dimension : ',dimname + STOP + ENDIF + ENDIF + END DO + + +! 2.2 Copy the global attributes into the output file. +! Also need to change the file_name attribute and the TimeStamp attribute. + + DO attid = 1, natts + iostat = nf90_inq_attname( ncid_in, nf90_global, attid, attname ) + WRITE(6,*)'>>> Copying attribute '//TRIM(attname)//' into destination file...' + iostat = nf90_copy_att( ncid_in, nf90_global, attname, ncid_out, nf90_global ) + END DO + iostat = nf90_put_att( ncid_out, nf90_global, "file_name", TRIM(file_out)) + CALL DATE_AND_TIME ( date=date, time=time, zone=zone ) + timestamp = date(7:8) // "/" // date(5:6) // "/" // date(1:4) // " " // & + time(1:2) // ":" // time(3:4) // ":" // time(5:6) // " " // & + zone + iostat = nf90_put_att( ncid_out, nf90_global, "TimeStamp", timestamp) + +! 2.3 Copy the variable definitions and attributes into the output file. + + DO jv = 1, nvars + iostat = nf90_inquire_variable( ncid_in, jv, varname, xtype, ndims_var, dimids, natts ) + iostat = nf90_def_var( ncid_out, varname, xtype, dimids(1:ndims_var), varid ) + IF (natts > 0) THEN + DO attid = 1, natts + iostat = nf90_inq_attname(ncid_in, varid, attid, attname) + iostat = nf90_copy_att( ncid_in, varid, attname, ncid_out, varid ) + END DO + ENDIF + END DO + +! 2.4 End definitions in output file + + iostat = nf90_enddef( ncid_out ) + +!----------------------------------------------------------------------------- +! 3. Read in variables from input file, re-order and write to output file +!----------------------------------------------------------------------------- + + IF( ln_coordinates ) THEN + ALLOCATE( varin_int(MAXVAL(nblen),1,1,1), varout_int(MAXVAL(nblen),1,1,1) ) + ALLOCATE( varin_float(MAXVAL(nblen),1,1,1), varout_float(MAXVAL(nblen),1,1,1) ) + ALLOCATE( varin_dble(MAXVAL(nblen),1,1,1), varout_dble(MAXVAL(nblen),1,1,1) ) + ELSE + SELECT CASE( ndims ) + CASE( 2 ) + ALLOCATE( varin_int(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + ALLOCATE( varout_int(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + ALLOCATE( varin_float(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + ALLOCATE( varout_float(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + ALLOCATE( varin_dble(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + ALLOCATE( varout_dble(dimlen(idim_xb),dimlen(idim_yb),1,1) ) + CASE ( 3 ) + ALLOCATE( varin_int(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + ALLOCATE( varout_int(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + ALLOCATE( varin_float(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + ALLOCATE( varout_float(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + ALLOCATE( varin_dble(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + ALLOCATE( varout_dble(dimlen(idim_xb),dimlen(idim_yb),1,dimlen(idim_time)) ) + CASE ( 4 ) + ALLOCATE( varin_int(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + ALLOCATE( varout_int(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + ALLOCATE( varin_float(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + ALLOCATE( varout_float(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + ALLOCATE( varin_dble(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + ALLOCATE( varout_dble(dimlen(idim_xb),dimlen(idim_yb),dimlen(idim_depth),dimlen(idim_time)) ) + CASE DEFAULT + WRITE(*,*) 'ERROR : Can only cope with 2, 3 or 4 dimensions in the boundary data files.' + WRITE(*,*) ' This file appears to have ',ndims,' dimensions.' + STOP + END SELECT + ENDIF + + DO jv = 1, nvars + iostat = nf90_inquire_variable( ncid_in, jv, varname, xtype, ndims_var, dimids ) + DO idim = 1, ndims_var + lenvar(idim) = dimlen(dimids(idim)) + ENDDO + + IF( ndims_var .eq. 1 ) THEN + WRITE(*,*) '>>> Copying coordinate variable ',TRIM(varname) + ELSE + WRITE(*,*) '>>> Reordering variable ',TRIM(varname) + ENDIF + ! Error check here + + IF( ln_coordinates ) THEN + strlen = len_trim(varname) + end_letter = varname(strlen:strlen) + jgrid = -1 + DO igrid = 1,4 + IF( end_letter .eq. cgrid(igrid) ) jgrid = igrid + END DO + IF( jgrid .lt. 0 ) THEN + WRITE(*,*) 'ERROR : Could not identify grid for variable ',TRIM(varname) + WRITE(*,*) ' varname : ',TRIM(varname),'!' + WRITE(*,*) ' strlen : ',strlen + WRITE(*,*) ' end_letter : ',end_letter + WRITE(*,*) ' cgrid(1) : ',cgrid(1) + WRITE(*,*) ' cgrid(2) : ',cgrid(2) + WRITE(*,*) ' cgrid(3) : ',cgrid(3) + WRITE(*,*) ' cgrid(4) : ',cgrid(4) + STOP + ENDIF + ELSE + jgrid=1 + ENDIF + + SELECT CASE(xtype) + + CASE( NF90_INT ) + SELECT CASE(ndims_var) + CASE( 1 ) + WRITE(*,*) 'This is a 1D integer.' + ! Assume this is a depth or time coordinate variable and copy across unchanged. + iostat = nf90_get_var( ncid_in, jv, varin_int(1:lenvar(1),1,1,1) ) + iostat = nf90_put_var( ncid_out, jv, varout_int(1:lenvar(1),1,1,1) ) + CASE( 2 ) + WRITE(*,*) 'This is a 2D integer.' + iostat = nf90_get_var( ncid_in, jv, varin_int(1:lenvar(1),1:1,1,1) ) + DO ib = 1,lenvar(1) + varout_int(ib,1,1,1) = varin_int(imap(ib,jgrid),1,1,1) + END DO + iostat = nf90_put_var( ncid_out, jv, varout_int(1:lenvar(1),1:1,1,1) ) + CASE( 3 ) + WRITE(*,*) 'This is a 3D integer.' + ! Assume third dimension is time. + iostat = nf90_get_var( ncid_in, jv, varin_int(1:lenvar(1),1:1,1,1:lenvar(3)) ) + DO itime = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_int(ib,1,1,itime) = varin_int(imap(ib,jgrid),1,1,itime) + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_int(1:lenvar(1),1:1,1,1:lenvar(3)) ) + CASE( 4 ) + WRITE(*,*) 'This is a 4D integer.' + ! Assume third and fourth dimensions are depth and time respectively. + iostat = nf90_get_var( ncid_in, jv, varin_int(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + DO itime = 1,lenvar(4) + DO idepth = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_int(ib,1,idepth,itime) = varin_int(imap(ib,jgrid),1,idepth,itime) + END DO + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_int(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + CASE DEFAULT + WRITE(*,*) 'ERROR : Variable with ',ndims_var,' dimensions. Case not coded.' + STOP + END SELECT + + CASE( NF90_FLOAT ) + SELECT CASE(ndims_var) + CASE( 1 ) + WRITE(*,*) 'This is a 1D float.' + ! Assume this is a depth or time coordinate variable and copy across unchanged. + iostat = nf90_get_var( ncid_in, jv, varin_float(1:lenvar(1),1,1,1) ) + iostat = nf90_put_var( ncid_out, jv, varout_float(1:lenvar(1),1,1,1) ) + CASE( 2 ) + WRITE(*,*) 'This is a 2D float.' + iostat = nf90_get_var( ncid_in, jv, varin_float(1:lenvar(1),1:1,1,1) ) + DO ib = 1,lenvar(1) + varout_float(ib,1,1,1) = varin_float(imap(ib,jgrid),1,1,1) + END DO + iostat = nf90_put_var( ncid_out, jv, varout_float(1:lenvar(1),1:1,1,1) ) + CASE( 3 ) + WRITE(*,*) 'This is a 3D float.' + ! Assume third dimension is time. + iostat = nf90_get_var( ncid_in, jv, varin_float(1:lenvar(1),1:1,1,1:lenvar(3)) ) + DO itime = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_float(ib,1,1,itime) = varin_float(imap(ib,jgrid),1,1,itime) + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_float(1:lenvar(1),1:1,1,1:lenvar(3)) ) + CASE( 4 ) + WRITE(*,*) 'This is a 4D float.' + ! Assume third and fourth dimensions are depth and time respectively. + iostat = nf90_get_var( ncid_in, jv, varin_float(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + DO itime = 1,lenvar(4) + DO idepth = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_float(ib,1,idepth,itime) = varin_float(imap(ib,jgrid),1,idepth,itime) + END DO + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_float(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + CASE DEFAULT + WRITE(*,*) 'ERROR : Variable with ',ndims_var,' dimensions. Case not coded.' + STOP + END SELECT + + CASE( NF90_DOUBLE ) + SELECT CASE(ndims_var) + CASE( 1 ) + WRITE(*,*) 'This is a 1D double.' + ! Assume this is a depth or time coordinate variable and copy across unchanged. + iostat = nf90_get_var( ncid_in, jv, varin_dble(1:lenvar(1),1,1,1) ) + iostat = nf90_put_var( ncid_out, jv, varout_dble(1:lenvar(1),1,1,1) ) + CASE( 2 ) + WRITE(*,*) 'This is a 2D double.' + iostat = nf90_get_var( ncid_in, jv, varin_dble(1:lenvar(1),1:1,1,1) ) + DO ib = 1,lenvar(1) + varout_dble(ib,1,1,1) = varin_dble(imap(ib,jgrid),1,1,1) + END DO + iostat = nf90_put_var( ncid_out, jv, varout_dble(1:lenvar(1),1:1,1,1) ) + CASE( 3 ) + WRITE(*,*) 'This is a 3D double.' + ! Assume third dimension is time. + iostat = nf90_get_var( ncid_in, jv, varin_dble(1:lenvar(1),1:1,1,1:lenvar(3)) ) + DO itime = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_dble(ib,1,1,itime) = varin_dble(imap(ib,jgrid),1,1,itime) + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_dble(1:lenvar(1),1:1,1,1:lenvar(3)) ) + CASE( 4 ) + WRITE(*,*) 'This is a 4D double.' + ! Assume third and fourth dimensions are depth and time respectively. + iostat = nf90_get_var( ncid_in, jv, varin_dble(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + DO itime = 1,lenvar(4) + DO idepth = 1,lenvar(3) + DO ib = 1,lenvar(1) + varout_dble(ib,1,idepth,itime) = varin_dble(imap(ib,jgrid),1,idepth,itime) + END DO + END DO + END DO + iostat = nf90_put_var( ncid_out, jv, varout_dble(1:lenvar(1),1:1,1:lenvar(3),1:lenvar(4)) ) + CASE DEFAULT + WRITE(*,*) 'ERROR : Variable with ',ndims_var,' dimensions. Case not coded.' + STOP + END SELECT + + CASE DEFAULT + WRITE(*,*) 'ERROR : Unrecognised data type.' + STOP + + END SELECT + + END DO ! jv + +!----------------------------------------------------------------------------- +! 4. Close input and output files +!----------------------------------------------------------------------------- + + iostat = nf90_close( ncid_out ) + iostat = nf90_close( ncid_in ) + + +END PROGRAM bdy_reorder diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/README b/V4.0/nemo_sources/tools/DMP_TOOLS/README new file mode 100644 index 0000000000000000000000000000000000000000..74d6b3cef973355126308be76b8eff135635f824 --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/README @@ -0,0 +1,5 @@ +DMP_TOOLS should be used to create a netcdf file called resto.nc containing restoration coefficients for use with the tra_dmp module in NEMO. Further instructions for it's use are available in the NEMO users guide. + +The tool can be compiled using the maketools script in the NEMOGCM/TOOLS directory as follows: +./maketools -m $ARCH -n DMP_TOOLS +where $ARCH indicates the arch file to be used from the directory NEMOGCM/ARCH. For example to use NEMOGCM/ARCH/arch-PW7_MONSOON.fcm, $ARCH would be PW7_MONSOON. diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/namelist b/V4.0/nemo_sources/tools/DMP_TOOLS/namelist new file mode 100644 index 0000000000000000000000000000000000000000..c47b8f0d1f5e307fd73efe2b78d30cf221a947f5 --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/namelist @@ -0,0 +1,24 @@ +&nam_dmp_create + cp_cfg = 'orca' ! Name of model grid (orca and C1D have special options - otherwise ignored) + cp_cfz = 'antarctic' ! Name of zoom configuration (arctic and antarctic have some special treatment if lzoom=.true.) + jp_cfg = 2 ! Resolution of the model (used for med_red_seas damping) + lzoom = .false. ! Zoom configuration or not + ln_full_field = .false. ! Calculate coefficient over whole of domain + ln_med_red_seas = .true. ! Damping in Med/Red Seas (or local modifications here if ln_full_field=.true.) + ln_old_31_lev_code = .true. ! Replicate behaviour of old online code for 31 level model (Med/Red seas damping based on level number instead of depth) + ln_coast = .true. ! Reduce near to coastlines + ln_zero_top_layer = .true. ! No damping in top layer + ln_custom = .false. ! Call "custom" module to apply user modifications to the damping coefficient field + nn_hdmp = 10 ! Damp poleward of this latitude (smooth transition up to maximum damping) + pn_surf = 0.25 ! Surface Relaxation timescale (days) + pn_bot = 0.25 ! Bottom relaxation timescale (days) + pn_dep = 1000 ! Transition depth from upper to deep ocean + jperio = 2 ! Lateral boundary condition (as specified in namelist_cfg for model run). +/ + +&nam_zoom_dmp + lzoom_n = .false. ! Open boundary had northern edge? + lzoom_e = .false. ! Open boundary at eastern edge? + lzoom_w = .false. ! Open boundary at western edge? + lzoom_s = .false. ! Open boundary at southern edge? +/ diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/coast_dist.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/coast_dist.F90 new file mode 100644 index 0000000000000000000000000000000000000000..7a9a078d99147c33e9bfa59b99310a6ecbfd169a --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/coast_dist.F90 @@ -0,0 +1,220 @@ +MODULE coastdist + + USE utils + USE netcdf + + IMPLICIT NONE + PUBLIC + + CONTAINS + + SUBROUTINE coast_dist_weight( presto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE coast_dist_weight *** + !! + !! ** Purpose: Weight restoration coefficient by distance to coast + !! + !! ** Method: 1) Calculate distance to coast + !! 2) Reduce resto with 1000km of coast + !! + IMPLICIT NONE + REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: presto + REAL(wp), DIMENSION(jpi,jpj) :: zdct + REAL(wp) :: zinfl = 1000.e3_wp ! Distance of influence of coast line (could be + ! a namelist setting) + INTEGER :: jj, ji ! dummy loop indices + + + CALL cofdis( zdct ) + DO jj = 1, jpj + DO ji = 1, jpi + zdct(ji,jj) = MIN( zinfl, zdct(ji,jj) ) + presto(ji,jj) = presto(ji, jj) * 0.5_wp * ( 1._wp - COS( rpi*zdct(ji,jj)/zinfl) ) + END DO + END DO + + END SUBROUTINE coast_dist_weight + + + SUBROUTINE cofdis( pdct ) + !!---------------------------------------------------------------------- + !! *** ROUTINE cofdis *** + !! + !! ** Purpose : Compute the distance between ocean T-points and the + !! ocean model coastlines. + !! + !! ** Method : For each model level, the distance-to-coast is + !! computed as follows : + !! - The coastline is defined as the serie of U-,V-,F-points + !! that are at the ocean-land bound. + !! - For each ocean T-point, the distance-to-coast is then + !! computed as the smallest distance (on the sphere) between the + !! T-point and all the coastline points. + !! - For land T-points, the distance-to-coast is set to zero. + !! + !! ** Action : - pdct, distance to the coastline (argument) + !! - NetCDF file 'dist.coast.nc' + !!---------------------------------------------------------------------- + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT( out ) :: pdct ! distance to the coastline + !! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: iju, ijt, icoast, itime, ierr, icot ! local integers + CHARACTER (len=32) :: clname ! local name + REAL(wp) :: zdate0 ! local scalar + REAL(wp), POINTER, DIMENSION(:,:) :: zxt, zyt, zzt, zmask + REAL(wp), POINTER, DIMENSION(: ) :: zxc, zyc, zzc, zdis ! temporary workspace + LOGICAL , ALLOCATABLE, DIMENSION(:,:) :: llcotu, llcotv, llcotf ! 2D logical workspace + + !!---------------------------------------------------------------------- + ! + ALLOCATE( zxt(jpi,jpj) , zyt(jpi,jpj) , zzt(jpi,jpj) , zmask(jpi,jpj) ) + ALLOCATE(zxc(3*jpi*jpj), zyc(3*jpi*jpj), zzc(3*jpi*jpj), zdis(3*jpi*jpj) ) + ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj) ) + ALLOCATE( gphiu(jpi,jpj), gphiv(jpi,jpj), gphif(jpi,jpj) ) + ALLOCATE( glamu(jpi,jpj), glamv(jpi,jpj), glamf(jpi,jpj), glamt(jpi,jpj) ) + ALLOCATE( umask(jpi,jpj), vmask(jpi,jpj), fmask(jpi,jpj) ) + ! + + CALL check_nf90( nf90_get_var( ncin, gphit_id, gphit, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, gphiu_id, gphiu, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, gphiv_id, gphiv, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, gphif_id, gphif, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, glamt_id, glamt, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, glamu_id, glamu, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, glamv_id, glamv, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, glamf_id, glamf, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, tmask_id, tmask, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, umask_id, umask, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, vmask_id, vmask, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_get_var( ncin, fmask_id, fmask, (/ 1,1 /), (/ jpi, jpj /) ) ) + + pdct(:,:) = 0._wp + zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) ) + zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) ) + zzt(:,:) = SIN( rad * gphit(:,:) ) + + + ! Define the coastline points (U, V and F) + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + zmask(ji,jj) = ( tmask(ji,jj+1) + tmask(ji+1,jj+1) & + & + tmask(ji,jj ) + tmask(ji+1,jj ) ) + llcotu(ji,jj) = ( tmask(ji,jj ) + tmask(ji+1,jj ) == 1._wp ) + llcotv(ji,jj) = ( tmask(ji,jj ) + tmask(ji ,jj+1) == 1._wp ) + llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp ) + END DO + END DO + + ! Lateral boundaries conditions + llcotu(:, 1 ) = umask(:, 2 ) == 1 + llcotu(:,jpj) = umask(:,jpj-1) == 1 + llcotv(:, 1 ) = vmask(:, 2 ) == 1 + llcotv(:,jpj) = vmask(:,jpj-1) == 1 + llcotf(:, 1 ) = fmask(:, 2 ) == 1 + llcotf(:,jpj) = fmask(:,jpj-1) == 1 + + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN + llcotu( 1 ,:) = llcotu(jpi-1,:) + llcotu(jpi,:) = llcotu( 2 ,:) + llcotv( 1 ,:) = llcotv(jpi-1,:) + llcotv(jpi,:) = llcotv( 2 ,:) + llcotf( 1 ,:) = llcotf(jpi-1,:) + llcotf(jpi,:) = llcotf( 2 ,:) + ELSE + llcotu( 1 ,:) = umask( 2 ,:) == 1 + llcotu(jpi,:) = umask(jpi-1,:) == 1 + llcotv( 1 ,:) = vmask( 2 ,:) == 1 + llcotv(jpi,:) = vmask(jpi-1,:) == 1 + llcotf( 1 ,:) = fmask( 2 ,:) == 1 + llcotf(jpi,:) = fmask(jpi-1,:) == 1 + ENDIF + IF( jperio == 3 .OR. jperio == 4 ) THEN + DO ji = 1, jpi-1 + iju = jpi - ji + 1 + llcotu(ji,jpj ) = llcotu(iju,jpj-2) + llcotf(ji,jpj-1) = llcotf(iju,jpj-2) + llcotf(ji,jpj ) = llcotf(iju,jpj-3) + END DO + DO ji = jpi/2, jpi-1 + iju = jpi - ji + 1 + llcotu(ji,jpj-1) = llcotu(iju,jpj-1) + END DO + DO ji = 2, jpi + ijt = jpi - ji + 2 + llcotv(ji,jpj-1) = llcotv(ijt,jpj-2) + llcotv(ji,jpj ) = llcotv(ijt,jpj-3) + END DO + ENDIF + IF( jperio == 5 .OR. jperio == 6 ) THEN + DO ji = 1, jpi-1 + iju = jpi - ji + llcotu(ji,jpj ) = llcotu(iju,jpj-1) + llcotf(ji,jpj ) = llcotf(iju,jpj-2) + END DO + DO ji = jpi/2, jpi-1 + iju = jpi - ji + llcotf(ji,jpj-1) = llcotf(iju,jpj-1) + END DO + DO ji = 1, jpi + ijt = jpi - ji + 1 + llcotv(ji,jpj ) = llcotv(ijt,jpj-1) + END DO + DO ji = jpi/2+1, jpi + ijt = jpi - ji + 1 + llcotv(ji,jpj-1) = llcotv(ijt,jpj-1) + END DO + ENDIF + + ! Compute cartesian coordinates of coastline points + ! and the number of coastline points + icoast = 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF( llcotf(ji,jj) ) THEN + icoast = icoast + 1 + zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) ) + zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) ) + zzc(icoast) = SIN( rad*gphif(ji,jj) ) + ENDIF + IF( llcotu(ji,jj) ) THEN + icoast = icoast+1 + zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) ) + zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) ) + zzc(icoast) = SIN( rad*gphiu(ji,jj) ) + ENDIF + IF( llcotv(ji,jj) ) THEN + icoast = icoast+1 + zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) ) + zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) ) + zzc(icoast) = SIN( rad*gphiv(ji,jj) ) + ENDIF + END DO + END DO + + ! Distance for the T-points + DO jj = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj) == 0._wp ) THEN + pdct(ji,jj) = 0._wp + ELSE + DO jl = 1, icoast + zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2 & + & + ( zyt(ji,jj) - zyc(jl) )**2 & + & + ( zzt(ji,jj) - zzc(jl) )**2 + END DO + pdct(ji,jj) = ra * SQRT( MINVAL( zdis(1:icoast) ) ) + ENDIF + END DO + END DO + + DEALLOCATE( zxt , zyt , zzt , zmask ) + DEALLOCATE(zxc, zyc, zzc, zdis ) + DEALLOCATE( llcotu, llcotv, llcotf ) + DEALLOCATE( gphiu, gphiv, gphif ) + DEALLOCATE( glamu, glamv, glamf, glamt ) + DEALLOCATE( umask, vmask, fmask ) + + END SUBROUTINE cofdis + +END MODULE coastdist diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/custom.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/custom.F90 new file mode 100644 index 0000000000000000000000000000000000000000..92492d4aa18c71db34a998929cde2e1d599ddbfb --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/custom.F90 @@ -0,0 +1,22 @@ +MODULE custom + + USE utils + + IMPLICIT NONE + PUBLIC + + CONTAINS + + SUBROUTINE custom_resto( presto ) + !!--------------------------------- + !! **ROUTINE: custom_resto + !! + !! ** Purpose: Module to be edited by users to create custom restoration + !! coefficient files (e.g. regional damping). + !! + !!------------------------------------- + REAL(wp), DIMENSION(jpi,jpk), INTENT(inout) :: presto + + END SUBROUTINE custom_resto + +END MODULE custom diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/make_dmp_file.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/make_dmp_file.F90 new file mode 100644 index 0000000000000000000000000000000000000000..78cb55f3cdce57ecf52981b2a2d673459e21a73c --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/make_dmp_file.F90 @@ -0,0 +1,123 @@ +PROGRAM make_dmp_file + !================================================================================ + ! *** PROGRAM make_dmp_file **** + !================================================================================ + ! + ! Purpose: Create a file containing a spacially varying + ! restoration coefficient to be used by TRADMP + ! + ! Method: 1) Read in tmask from mesh_mask file to use as a template + ! 2) Calculate restoration coefficients according to options + ! specified in the namelist. The user may modify custom.F90 to + ! specify specific damping options e.g. to mask certain regions only). + ! 3) Write the array to output file + ! + ! History: Original code: Tim Graham (Jul 2014) - some code moved from + ! old tradmp.F90 module to this tool (as part of NEMO + ! simplification process). + !------------------------------------------------------------------------------- + + ! Declare variables + USE netcdf + USE utils + USE coastdist + USE med_red_seas + USE zoom + USE custom + + IMPLICIT NONE + INTEGER :: ji, jj, jk ! dummpy loop variables + REAL(wp) :: zsdmp, zbdmp ! Surface and bottom damping coeff + CHARACTER(LEN=200) :: meshfile = 'mesh_mask.nc' ! mesh file + CHARACTER(LEN=200) :: outfile = 'resto.nc' ! output file + REAL(wp) :: zlat, zlat2, zlat0 + + ! Read namelist + OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' ) + READ( numnam, nam_dmp_create ) + CLOSE( numnam ) + + IF ( ln_full_field .AND. lzoom ) THEN + WRITE(numerr,*) 'Only one of ln_full_field and lzoom can be .true.' + STOP + ENDIF + + CALL grid_info(meshfile) + WRITE(numout, *) 'jpi = ',jpi + WRITE(numout, *) 'jpj = ',jpj + WRITE(numout, *) 'jpk = ',jpk + + ALLOCATE( resto(jpi, jpj) ) + + !Create output file + CALL make_outfile( outfile ) + + CALL check_nf90( nf90_get_var( ncin, gphit_id, gphit, (/ 1,1 /), (/ jpi, jpj /) ) ) + + !Calculate surface and bottom damping coefficients + zsdmp = 1._wp / ( pn_surf * rday ) + zbdmp = 1._wp / ( pn_bot * rday ) + + !Loop through levels and read in tmask for each level as starting point for + !coefficient array + DO jk = 1, jpk-1 + resto(:,:) = 0._wp + + IF (.NOT. (jk == 1 .AND. ln_zero_top_layer) ) THEN + !Read in tmask depth for this level + CALL check_nf90( nf90_get_var( ncin, tmask_id, tmask, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_get_var( ncin, gdept_id, gdept, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) ) + + + IF ( ln_full_field ) THEN + !Set basic value of resto + DO jj = 1, jpj + DO ji = 1, jpi + resto(ji,jj) = tmask(ji, jj) * (zbdmp + (zsdmp-zbdmp) * EXP(-gdept(ji,jj)/pn_dep)) + END DO + END DO + IF ((nn_hdmp > 0)) THEN + zlat0 = 10. !width of latitude strip where resto decreases + zlat2 = nn_hdmp + zlat0 + DO jj = 1, jpj + DO ji = 1, jpi + zlat = ABS(gphit(ji,jj)) + IF ( nn_hdmp <= zlat .AND. zlat <= zlat2 ) THEN + resto(ji,jj) = resto(ji,jj) * 0.5_wp * ( 1._wp - COS( rpi*(zlat-nn_hdmp)/zlat0 ) ) + ELSE IF ( zlat < nn_hdmp ) THEN + resto(ji,jj) = 0._wp + ENDIF + END DO + END DO + ENDIF + + IF (ln_coast) THEN + ! Reduce damping in vicinity of coastlines + CALL coast_dist_weight(resto) + ENDIF + ENDIF + + ! Damping in Med/Red Seas (or local modifications if full field is set) + IF (ln_med_red_seas .AND. (cp_cfg == 'orca') .AND. (.NOT. lzoom)) THEN + CALL med_red_dmp(resto, jk, ln_old_31_lev_code) + ENDIF + + IF ( lzoom ) THEN + CALL dtacof_zoom(resto, tmask) + ENDIF + + !Any user modifications can be added in the custom module + IF ( ln_custom ) THEN + CALL custom_resto( resto ) + ENDIF + ENDIF + + ! Write out resto for this level + CALL check_nf90( nf90_put_var( ncout, resto_id, resto, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) ) + + END DO + + ! Close the output file + CALL check_nf90( nf90_close(ncout) ) + +END PROGRAM make_dmp_file diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/med_red_seas.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/med_red_seas.F90 new file mode 100644 index 0000000000000000000000000000000000000000..996c00882786f86c6f71c080132d1648c34fd854 --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/med_red_seas.F90 @@ -0,0 +1,135 @@ +MODULE med_red_seas + + USE utils + + IMPLICIT NONE + PUBLIC + + CONTAINS + + SUBROUTINE med_red_dmp(presto, jk, ln_31_lev) + !!------------------------------------ + !! **ROUTINE: med_red_dmp + !! + !! **Purpose: Apply specific modifications to damping coefficients on ORCA + !! grids in Med and Red Seas + !! + !!----------------------------------- + INTEGER :: ij0,ij1,ii0,ii1,ji,jj + INTEGER, INTENT(in) :: jk + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmrs + REAL(wp) :: zhfac, zsdmp, zbdmp + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: presto + LOGICAL, INTENT(in), OPTIONAL :: ln_31_lev + LOGICAL :: l_31_lev + + WRITE(numout,*) 'ORCA Med and Red Seas Damping' + + IF ( PRESENT(ln_31_lev)) THEN + l_31_lev = ln_31_lev + ELSE + l_31_lev = .false. + ENDIF + + ALLOCATE( zmrs(jpi, jpj) ) + ! + zmrs(:,:) = 0._wp + ! + SELECT CASE ( jp_cfg ) + ! ! ======================= + CASE ( 4 ) ! ORCA_R4 configuration + ! ! ======================= + ij0 = 50 ; ij1 = 56 ! Mediterranean Sea + + ii0 = 81 ; ii1 = 91 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1. + ij0 = 50 ; ij1 = 55 + ii0 = 75 ; ii1 = 80 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1. + ij0 = 52 ; ij1 = 53 + ii0 = 70 ; ii1 = 74 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1. + ! + ! ! ======================= + CASE ( 2 ) ! ORCA_R2 configuration + ! ! ======================= + ij0 = 96 ; ij1 = 110 ! Mediterranean Sea + ii0 = 157 ; ii1 = 181 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ij0 = 100 ; ij1 = 110 + ii0 = 144 ; ii1 = 156 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ij0 = 100 ; ij1 = 103 + ii0 = 139 ; ii1 = 143 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ! + ij0 = 101 ; ij1 = 102 ! Decrease before Gibraltar Strait + ii0 = 139 ; ii1 = 141 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0._wp + ii0 = 142 ; ii1 = 142 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp + ii0 = 143 ; ii1 = 143 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp + ii0 = 144 ; ii1 = 144 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.75_wp + ! + ij0 = 87 ; ij1 = 96 ! Red Sea + ii0 = 147 ; ii1 = 163 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ! + ij0 = 91 ; ij1 = 91 ! Decrease before Bab el Mandeb Strait + ii0 = 153 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.80_wp + ij0 = 90 ; ij1 = 90 + ii0 = 153 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp + ij0 = 89 ; ij1 = 89 + ii0 = 158 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp + ij0 = 88 ; ij1 = 88 + ii0 = 160 ; ii1 = 163 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0._wp + ! + ! ! ======================= + CASE ( 05 ) ! ORCA_R05 configuration + ! ! ======================= + ii0 = 568 ; ii1 = 574 ! Mediterranean Sea + ij0 = 324 ; ij1 = 333 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ii0 = 575 ; ii1 = 658 + ij0 = 314 ; ij1 = 366 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ! + ii0 = 641 ; ii1 = 651 ! Black Sea (remaining part + ij0 = 367 ; ij1 = 372 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ! + ij0 = 324 ; ij1 = 333 ! Decrease before Gibraltar Strait + ii0 = 565 ; ii1 = 565 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp + ii0 = 566 ; ii1 = 566 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp + ii0 = 567 ; ii1 = 567 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.75_wp + ! + ii0 = 641 ; ii1 = 665 ! Red Sea + ij0 = 270 ; ij1 = 310 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp + ! + ii0 = 666 ; ii1 = 675 ! Decrease before Bab el Mandeb Strait + ij0 = 270 ; ij1 = 290 + DO ji = ii0, ii1 + zmrs( ji , ij0:ij1 ) = 0.1_wp * ABS( FLOAT(ji - ii1) ) + END DO + ! ! ======================== + CASE ( 025 ) ! ORCA_R025 configuration + ! ! ======================== + WRITE(numerr,*) ' Mediterranean and Red Sea damping option not implemented for ORCA_R025' + WRITE(numerr,*) ' Set ln_med_red = .false.' + STOP + ! + END SELECT + + zsdmp = 1._wp / ( pn_surf * rday ) + zbdmp = 1._wp / ( pn_bot * rday ) + + ! The l_31_lev option is used to reproduce the old behaviour of + ! defining the restoration coefficient based on the level number. + ! This is included to allow damping coefficients for reference + ! configurations to be kept the same. + IF (l_31_lev) THEN + IF (jk <= 17) THEN + zhfac = 0.5_wp * ( 1. - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday + ELSE + zhfac = 1._wp / rday + ENDIF + ELSE + zhfac = ( zbdmp + (zsdmp-zbdmp) * EXP( -gdept(1,1)/pn_dep ) ) + ENDIF + + presto(:,:) = zmrs(:,:) * zhfac + ( 1._wp - zmrs(:,:) ) * presto(:,:) + + DEALLOCATE( zmrs ) + + END SUBROUTINE med_red_dmp + + +END MODULE med_red_seas diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/utils.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/utils.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3662780d8c8f4af8cd14da6e80e05fb29d1d70de --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/utils.F90 @@ -0,0 +1,130 @@ +MODULE utils + + USE netcdf + + IMPLICIT NONE + PUBLIC + + INTEGER, PUBLIC, PARAMETER :: dp=8 , sp=4, wp=dp + INTEGER :: tmask_id, umask_id, vmask_id, fmask_id + INTEGER :: gdept_id + INTEGER :: gphit_id, gphiv_id, gphiu_id, gphif_id ! Variable ids + INTEGER :: glamt_id, glamv_id, glamu_id, glamf_id ! Variable ids + INTEGER :: resto_id ! Variable ID for output + INTEGER :: jpi, jpj, jpk ! Size of domain + INTEGER :: ncin, ncout ! File handles for netCDF files + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit, glamt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu, glamu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiv, glamv + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphif, glamf + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask, umask, vmask, fmask + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gdept + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: resto + + INTEGER,PARAMETER :: numout = 6 + INTEGER,PARAMETER :: numerr = 0 + INTEGER,PARAMETER :: numnam = 11 + REAL(wp),PARAMETER :: rday = 86400 ! seconds in a day + REAL(wp),PARAMETER :: rpi = 3.141592653589793 + REAL(wp),PARAMETER :: rad = 3.141592653589793/180. + REAL(wp),PARAMETER :: ra = 6371229. + + ! Namelist variables + CHARACTER(LEN=30) :: cp_cfg = 'ORCA' + CHARACTER(LEN=30) :: cp_cfz = 'No zoom' + INTEGER :: jp_cfg = 2 + REAL(KIND=8) :: pn_surf = 1 + REAL(KIND=8) :: pn_bot = 1 + REAL(KIND=8) :: pn_dep = 1000 + INTEGER :: nn_hdmp = 0 ! damping option + INTEGER :: jperio = 0 ! damping option + LOGICAL :: lzoom = .false. + LOGICAL :: ln_coast = .false. + LOGICAL :: ln_full_field = .true. + LOGICAL :: ln_med_red_seas = .false. + LOGICAL :: ln_old_31_lev_code = .false. + LOGICAL :: ln_zero_top_layer = .false. + LOGICAL :: ln_custom = .false. + + NAMELIST/nam_dmp_create/cp_cfg, cp_cfz, jp_cfg, lzoom, ln_full_field, & + ln_med_red_seas, ln_old_31_lev_code, ln_coast, & + ln_zero_top_layer, ln_custom, & + pn_surf, pn_bot, pn_dep, nn_hdmp, jperio + + CONTAINS + + SUBROUTINE grid_info(mesh) + CHARACTER(LEN=*),INTENT(in) :: mesh + + ! Open meshfile + CALL check_nf90( nf90_open(mesh, NF90_NOWRITE, ncin), 'Error opening mesh_mask file' ) + + ! Get size of grid from meshfile + CALL dimlen( ncin, 'x', jpi ) + CALL dimlen( ncin, 'y', jpj ) + CALL dimlen( ncin, 'z', jpk ) + + ALLOCATE( tmask(jpi, jpj), gdept(jpi, jpj), gphit(jpi,jpj) ) + + !Get ID of tmask in meshfile + CALL check_nf90( nf90_inq_varid( ncin, 'tmask', tmask_id ), 'Cannot get variable ID for tmask') + CALL check_nf90( nf90_inq_varid( ncin, 'umask', umask_id ), 'Cannot get variable ID for umask') + CALL check_nf90( nf90_inq_varid( ncin, 'vmask', vmask_id ), 'Cannot get variable ID for vmask') + CALL check_nf90( nf90_inq_varid( ncin, 'fmask', fmask_id ), 'Cannot get variable ID for fmask') + CALL check_nf90( nf90_inq_varid( ncin, 'gdept_0', gdept_id ), 'Cannot get variable ID for gdept_0') + CALL check_nf90( nf90_inq_varid( ncin, 'gphit', gphit_id ), 'Cannot get variable ID for gphit') + CALL check_nf90( nf90_inq_varid( ncin, 'gphiu', gphiu_id ), 'Cannot get variable ID for gphiu') + CALL check_nf90( nf90_inq_varid( ncin, 'gphiv', gphiv_id ), 'Cannot get variable ID for gphiv') + CALL check_nf90( nf90_inq_varid( ncin, 'gphif', gphif_id ), 'Cannot get variable ID for gphif') + CALL check_nf90( nf90_inq_varid( ncin, 'glamt', glamt_id ), 'Cannot get variable ID for glamt') + CALL check_nf90( nf90_inq_varid( ncin, 'glamu', glamu_id ), 'Cannot get variable ID for glamu') + CALL check_nf90( nf90_inq_varid( ncin, 'glamv', glamv_id ), 'Cannot get variable ID for glamv') + CALL check_nf90( nf90_inq_varid( ncin, 'glamf', glamf_id ), 'Cannot get variable ID for glamf') + + END SUBROUTINE grid_info + + SUBROUTINE dimlen( ncid, dimname, len ) + ! Determine the length of dimension dimname + INTEGER, INTENT(in) :: ncid + CHARACTER(LEN=*), INTENT(in) :: dimname + INTEGER, INTENT(out) :: len + ! Local variables + INTEGER :: id_var, istatus + + id_var = 1 + CALL check_nf90( nf90_inq_dimid(ncid, dimname, id_var), 'Dimension not found in file') + CALL check_nf90( nf90_inquire_dimension(ncid,id_var,len=len)) + + END SUBROUTINE dimlen + + SUBROUTINE make_outfile( filename ) + ! Create the output file + ! Define dimensions and resto variable + CHARACTER(LEN=*), INTENT(in) :: filename + INTEGER :: id_x, id_y, id_z + + CALL check_nf90( nf90_create(filename, NF90_CLOBBER, ncout), 'Could not create output file') + CALL check_nf90( nf90_def_dim(ncout, 'x', jpi, id_x) ) + CALL check_nf90( nf90_def_dim(ncout, 'y', jpj, id_y) ) + CALL check_nf90( nf90_def_dim(ncout, 'z', jpk, id_z) ) + + CALL check_nf90( nf90_def_var(ncout, 'resto', nf90_double, (/id_x,id_y,id_z/), resto_id ) ) + CALL check_nf90( nf90_enddef(ncout) ) + + END SUBROUTINE make_outfile + + + SUBROUTINE check_nf90( istat, message ) + !Check for netcdf errors + INTEGER, INTENT(in) :: istat + CHARACTER(LEN=*), INTENT(in), OPTIONAL :: message + + IF (istat /= nf90_noerr) THEN + WRITE(numerr,*) 'ERROR! : '//TRIM(nf90_strerror(istat)) + IF ( PRESENT(message) ) THEN ; WRITE(numerr,*) message ; ENDIF + STOP + ENDIF + + END SUBROUTINE check_nf90 + +END MODULE utils diff --git a/V4.0/nemo_sources/tools/DMP_TOOLS/src/zoom.F90 b/V4.0/nemo_sources/tools/DMP_TOOLS/src/zoom.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bf8ee263420e0dd2943bcdc5da46b7d08d0238f4 --- /dev/null +++ b/V4.0/nemo_sources/tools/DMP_TOOLS/src/zoom.F90 @@ -0,0 +1,87 @@ +MODULE zoom + + USE utils + + CONTAINS + + SUBROUTINE dtacof_zoom( presto, mask) + !!---------------------------------------------------------------------- + !! *** ROUTINE dtacof_zoom *** + !! + !! ** Purpose : Compute the damping coefficient for zoom domain + !! + !! ** Method : - set along closed boundary due to zoom a damping over + !! 6 points with a max time scale of 5 days. + !! - ORCA arctic/antarctic zoom: set the damping along + !! south/north boundary over a latitude strip. + !! + !! ** Action : - resto, the damping coeff. for T and S + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: presto ! restoring coeff. (s-1) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: mask ! restoring coeff. (s-1) + ! + INTEGER :: ji, jj, jn ! dummy loop indices + REAL(wp) :: zlat, zlat0, zlat1, zlat2, z1_5d ! local scalar + REAL(wp), DIMENSION(6) :: zfact ! 1Dworkspace + + !Namelist variables + LOGICAL :: lzoom_w, lzoom_e, lzoom_n, lzoom_s + NAMELIST/nam_zoom_dmp/lzoom_n,lzoom_e,lzoom_w,lzoom_s + !!---------------------------------------------------------------------- + + ! Read namelist + OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' ) + READ( numnam, nam_dmp_create ) + CLOSE( numnam ) + + zfact(1) = 1._wp + zfact(2) = 1._wp + zfact(3) = 11._wp / 12._wp + zfact(4) = 8._wp / 12._wp + zfact(5) = 4._wp / 12._wp + zfact(6) = 1._wp / 12._wp + zfact(:) = zfact(:) / ( 5._wp * rday ) ! 5 days max restoring time scale + + presto(:,:) = 0._wp + + ! damping along the forced closed boundary over 6 grid-points + DO jn = 1, 6 + IF( lzoom_w ) presto( jn, : ) = zfact(jn) ! west closed + IF( lzoom_s ) presto( : , jn ) = zfact(jn) ! south closed + IF( lzoom_e ) presto( jpi+1-jn , : ) = zfact(jn) ! east closed + IF( lzoom_n ) presto( : , jpj+1-jn ) = zfact(jn) ! north closed + END DO + + ! ! ==================================================== + IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN ! ORCA configuration : arctic or antarctic zoom + ! ! ==================================================== + WRITE(numout,*) + IF(cp_cfz == "arctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Arctic zoom' + IF(cp_cfz == "antarctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Antarctic zoom' + WRITE(numout,*) + ! + ! ! Initialization : + presto(:,:) = 0._wp + zlat0 = 10._wp ! zlat0 : latitude strip where resto decreases + zlat1 = 30._wp ! zlat1 : resto = 1 before zlat1 + zlat2 = zlat1 + zlat0 ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2 + z1_5d = 1._wp / ( 5._wp * rday ) ! z1_5d : 1 / 5days + + DO jj = 1, jpj + DO ji = 1, jpi + zlat = ABS( gphit(ji,jj) ) + IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN + presto(ji,jj) = 0.5_wp * z1_5d * ( 1._wp - COS( rpi*(zlat2-zlat)/zlat0 ) ) + ELSEIF( zlat < zlat1 ) THEN + presto(ji,jj) = z1_5d + ENDIF + END DO + END DO + ! + ENDIF + ! ! Mask resto array + presto(:,:) = presto(:,:) * mask(:,:) + + END SUBROUTINE dtacof_zoom + +END MODULE zoom diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/README b/V4.0/nemo_sources/tools/DOMAINcfg/README new file mode 100644 index 0000000000000000000000000000000000000000..6dc9ca0752c368ef2377f38c63cff5bfed0e3276 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/README @@ -0,0 +1,75 @@ +================================ += HOW TO COMPILE +================================ +The DOMAINcfg tool can be compiled using the maketools script in the NEMOGCM/TOOLS directory as follows: +::::::::::::::::::::::::::::::::: +./maketools -m $ARCH -n DOMAINcfg +::::::::::::::::::::::::::::::::: +where $ARCH indicates the arch file to be used from the directory NEMOGCM/ARCH. + +DOMAINcfg compiled will create "make_domain_cfg.exe" executable script (the main routine of this tool is make_domain_cfg.f90) + +================================ += HOW TO RUN +================================ +just run : +::::::::::::::::::::::::::::::::::::::::::::::::: +mpirun -np 1 ./make_domain_cfg.exe +::::::::::::::::::::::::::::::::::::::::::::::::: +NOTA: it can be run in multiproc mode, but in output there will be domain_cfg_00xx.nc files + + === Closed seas (closea module) === + +If you want to define closed seas in the bathymetry either to suppress them at runtime or +redistribute freshwater fluxes, then you need to run make_closea_masks.py after you have +created the basic domain_cfg file. This utility will add "closea_mask*" fields to the +domain_cfg file to define the closed seas in the configuration. (If you have closed seas +but don't want to treat them in a special way then you can ignore this step). + +================================ += HOW TO USE +================================ +1) copy in DOMAINcfg directory namelist_cfg all settings (that you had in 3.6_stable) of the configuration for which you want prepare domain_cfg.nc file +IMPORTANT : keep the namelist_ref committed inchanged. !!! + +NEW OPTION ln_e3_dep in the namelist_ref: +till nemo_v3.6_stable e3 were done like an analytical derivative of depth function +now e3=dk[depth] in discret sens + +If you want to create same e3[tuvw] like 3.6 you've to use "ln_e3_dep=.false." + + ln_e3_dep = .true. ! =T : e3=dk[depth] in discret sens. + ! ! ===>>> will become the only possibility in v4.0 + ! ! =F : e3 analytical derivative of depth function + ! ! only there for backward compatibility test with v3.6 + ! + +2) copy in DOMAINcfg directory same input files (of related configuration) required in v3.6_stable. + +DOMAINcfg package is EXACTLY what does exist in NEMO version 3.6 to define a model domain (both domain related namelist and initialization). +DOMAINcfg tool creates a netcdf file "domain_cfg.nc" containing all the ocean domain informations required to define an ocean configuration, +these files are : + + domain size + domain characteristics (periodic) + horizontal mesh + Coriolis parameter + depth and vertical scale factors + +FOR EXAMPLE +- for AMM12 : + coordinates.nc + bathy_meter.nc + bathy_level.nc + amm12_rivers.nc + coordinates.bdy.nc + amm12_restart_oce.nc + directories: bdydta/ + fluxes/ +- for ORCA2 : + coordinates.nc + bathy_meter.nc + bathy_level.nc + domain_def.xml + field_def.xml + iodef.xml diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/README_configs_namcfg_namdom b/V4.0/nemo_sources/tools/DOMAINcfg/README_configs_namcfg_namdom new file mode 100644 index 0000000000000000000000000000000000000000..dfd81a1980ec23220f6082b1abeba77042c5aa57 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/README_configs_namcfg_namdom @@ -0,0 +1,609 @@ + + +This README file contains the informations for the &namcfg namelist for some configurations whic are not one of the reference configurations. +These informations wher previoulsy in NEMO/OCE_SRC_par_*.h90 files. The full test with these configurations has not been done. + + +ORCA_R4 +======= +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 4 ! resolution of the configuration + jpidta = 92 ! 1st lateral dimension ( >= jpi ) + jpjdta = 76 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 92 ! 1st dimension of global domain --> i =jpidta + jpjglo = 76 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 4 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + +ORCA_R1 75 vertical levels +======= +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 1 ! resolution of the configuration + jpidta = 362 ! 1st lateral dimension ( >= jpi ) + jpjdta = 292 ! 2nd " " ( >= jpj ) + jpkdta = 75 ! number of levels ( >= jpk ) + jpiglo = 362 ! 1st dimension of global domain --> i =jpidta + jpjglo = 292 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 6 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -3958.951371276829 ! ORCA r4, r2 and r05 coefficients + ppa0 = 103.9530096000000 ! (default coefficients) + ppa1 = 2.415951269000000 ! + ppkth = 15.35101370000000 ! + ppacr = 7.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .TRUE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 100.7609285000000 ! Double tanh function parameters + ppkth2 = 48.02989372000000 ! + ppacr2 = 13.00000000000 ! +/ + + +ORCA_R1 46 vertical levels +======= +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 1 ! resolution of the configuration + jpidta = 362 ! 1st lateral dimension ( >= jpi ) + jpjdta = 292 ! 2nd " " ( >= jpj ) + jpkdta = 46 ! number of levels ( >= jpk ) + jpiglo = 362 ! 1st dimension of global domain --> i =jpidta + jpjglo = 292 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 6 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = 999998.0 ! ORCA r4, r2 and r05 coefficients + ppa0 = 999998.0 ! (default coefficients) + ppa1 = 999998.0 ! + ppkth = 23.563 ! + ppacr = 9.0 ! + ppdzmin = 6.0 ! Minimum vertical spacing + pphmax = 5750. ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ +ORCA_R05 +======== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 05 ! resolution of the configuration + jpidta = 722 ! 1st lateral dimension ( >= jpi ) + jpjdta = 511 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 722 ! 1st dimension of global domain --> i =jpidta + jpjglo = 511 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 6 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + + +ORCA_R05 Antarctic zoom +======== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + cp_cfz = "antarctic" ! name of the zoom of configuration + jp_cfg = 05 ! resolution of the configuration + jpidta = 722 ! 1st lateral dimension ( >= jpi ) + jpjdta = 511 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 722 ! 1st dimension of global domain --> i =jpidta + jpjglo = 187 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 1 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + + +ORCA_R05 Arctic zoom +======== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + cp_cfz = "arctic" ! name of the zoom of configuration + jp_cfg = 05 ! resolution of the configuration + jpidta = 722 ! 1st lateral dimension ( >= jpi ) + jpjdta = 511 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 562 ! 1st dimension of global domain --> i =jpidta + jpjglo = 211 ! 2nd - - --> j =jpjdta + jpizoom = 81 ! left bottom (i,j) indices of the zoom + jpjzoom = 301 ! in data domain indices + jperio = 5 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + +ORCA2 - Antarctic zoom +====================== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + cp_cfz = "antarctic" ! name of the zoom of configuration + jp_cfg = 2 ! resolution of the configuration + jpidta = 182 ! 1st lateral dimension ( >= jpi ) + jpjdta = 149 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 182 ! 1st dimension of global domain --> i =jpidta + jpjglo = 50 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 1 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999. ! Minimum vertical spacing + pphmax = 999999. ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999. ! Double tanh function parameters + ppkth2 = 999999. ! + ppacr2 = 999999. ! +/ + + +ORCA2 - Arctic zoom +=================== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + cp_cfz = "arctic" ! name of the zoom of configuration + jp_cfg = 2 ! resolution of the configuration + jpidta = 182 ! 1st lateral dimension ( >= jpi ) + jpjdta = 149 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 142 ! 1st dimension of global domain --> i =jpidta + jpjglo = 53 ! 2nd - - --> j =jpjdta + jpizoom = 21 ! left bottom (i,j) indices of the zoom + jpjzoom = 97 ! in data domain indices + jperio = 3 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999. ! Minimum vertical spacing + pphmax = 999999. ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999. ! Double tanh function parameters + ppkth2 = 999999. ! + ppacr2 = 999999. ! +/ + + +ORCA025 - 75 vertical levels +======= +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 025 ! resolution of the configuration + jpidta = 1442 ! 1st lateral dimension ( >= jpi ) + jpjdta = 1021 ! 2nd " " ( >= jpj ) + jpkdta = 75 ! number of levels ( >= jpk ) + jpiglo = 1442 ! 1st dimension of global domain --> i =jpidta + jpjglo = 1021 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 4 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -3958.951371276829 ! ORCA r4, r2 and r05 coefficients + ppa0 = 103.9530096000000 ! (default coefficients) + ppa1 = 2.415951269000000 ! + ppkth = 15.35101370000000 ! + ppacr = 7.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .TRUE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 100.7609285000000 ! Double tanh function parameters + ppkth2 = 48.02989372000000 ! + ppacr2 = 13. ! +/ + + +ORCA025 - 46 vertical levels +======= +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 1442 ! resolution of the configuration + jpidta = 1021 ! 1st lateral dimension ( >= jpi ) + jpjdta = 511 ! 2nd " " ( >= jpj ) + jpkdta = 46 ! number of levels ( >= jpk ) + jpiglo = 1442 ! 1st dimension of global domain --> i =jpidta + jpjglo = 1021 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 4 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = 999998.0 ! ORCA r4, r2 and r05 coefficients + ppa0 = 999998.0 ! (default coefficients) + ppa1 = 999998.0 ! + ppkth = 23.563 ! + ppacr = 9.0 ! + ppdzmin = 6.0 ! Minimum vertical spacing + pphmax = 5750.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ +EEL R2: channel +====== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "eel" ! name of the configuration + jp_cfg = 2 ! resolution of the configuration + jpidta = 83 ! 1st lateral dimension ( >= jpi ) + jpjdta = 242 ! 2nd " " ( >= jpj ) + jpkdta = 30 ! number of levels ( >= jpk ) + jpiglo = 83 ! 1st dimension of global domain --> i =jpidta + jpjglo = 242 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 1 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 3 ! type of horizontal mesh + ppglam0 = 0.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 35.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 2000.0 ! zonal grid-spacing (degrees) + ppe2_m = 2000.0 ! meridional grid-spacing (degrees) + ppsur = -2033.194295283385 ! ORCA r4, r2 and r05 coefficients + ppa0 = 155.8325369664153 ! (default coefficients) + ppa1 = 146.3615918601890 ! + ppkth = 17.28520372419791 ! + ppacr = 5.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + + +EEL R5: channel +====== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "eel" ! name of the configuration + jp_cfg = 5 ! resolution of the configuration + jpidta = 66 ! 1st lateral dimension ( >= jpi ) + jpjdta = 66 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 66 ! 1st dimension of global domain --> i =jpidta + jpjglo = 66 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 1 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 2 ! type of horizontal mesh + ppglam0 = 0.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 43.436430714 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 8000.0 ! zonal grid-spacing (degrees) + ppe2_m = 8000.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + + +EEL R6: 6 km resolution channel +====== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "eel" ! name of the configuration + jp_cfg = 6 ! resolution of the configuration + jpidta = 29 ! 1st lateral dimension ( >= jpi ) + jpjdta = 83 ! 2nd " " ( >= jpj ) + jpkdta = 30 ! number of levels ( >= jpk ) + jpiglo = 29 ! 1st dimension of global domain --> i =jpidta + jpjglo = 83 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 1 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 3 ! type of horizontal mesh + ppglam0 = 0.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 35. ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 6000.0 ! zonal grid-spacing (degrees) + ppe2_m = 6000.0 ! meridional grid-spacing (degrees) + ppsur = -2033.194295283385 ! ORCA r4, r2 and r05 coefficients + ppa0 = 155.8325369664153 ! (default coefficients) + ppa1 = 146.3615918601890 ! + ppkth = 17.28520372419791 ! + ppacr = 5.0 ! + ppdzmin = 999999.0 ! Minimum vertical spacing + pphmax = 999999.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + + +POMME: 025 +====== +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "pomme" ! name of the configuration + jp_cfg = 025 ! resolution of the configuration + jpidta = 30 ! 1st lateral dimension ( >= jpi ) + jpjdta = 40 ! 2nd " " ( >= jpj ) + jpkdta = 46 ! number of levels ( >= jpk ) + jpiglo = 30 ! 1st dimension of global domain --> i =jpidta + jpjglo = 40 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 0 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = 999998.0 ! ORCA r4, r2 and r05 coefficients + ppa0 = 999998.0 ! (default coefficients) + ppa1 = 999998.0 ! + ppkth = 23.563 ! + ppacr = 9.0 ! + ppdzmin = 6.0 ! Minimum vertical spacing + pphmax = 5750.0 ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999.0 ! Double tanh function parameters + ppkth2 = 999999.0 ! + ppacr2 = 999999.0 ! +/ + +C1D - 1D configuration. Add key_c1d in active cpp keys +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + cp_cfg = "orca" ! name of the configuration + jp_cfg = 2 ! resolution of the configuration + jpidta = 182 ! 1st lateral dimension ( >= jpi ) + jpjdta = 149 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 3 ! 1st dimension of global domain --> i =jpidta + jpjglo = 3 ! 2nd - - --> j =jpjdta +! Choose postion of the 1D column: +! jpizoom = 61, jpjzoom = 133 (160W,75N) +! jpizoom = 61, jpjzoom = 110 (160W,50N) +! jpizoom = 61, jpjzoom = 97 (160W,30N) +! jpizoom = 61, jpjzoom = 86 (160W,10N) +! jpizoom = 61, jpjzoom = 49 (160W,30S) +! jpizoom = 61, jpjzoom = 27 (160W,60S) +! jpizoom = 61, jpjzoom = 7 (160W,75S) +! jpizoom = 110,jpjzoom = 97 (64W,31.5N) BATS site + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 0 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namdom ! +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999. ! Minimum vertical spacing + pphmax = 999999. ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999. ! Double tanh function parameters + ppkth2 = 999999. ! + ppacr2 = 999999. ! +/ diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/README_make_closea_masks b/V4.0/nemo_sources/tools/DOMAINcfg/README_make_closea_masks new file mode 100644 index 0000000000000000000000000000000000000000..c1b1339287ae3c8b05f43daeb8cb384128af9d96 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/README_make_closea_masks @@ -0,0 +1,24 @@ +Make_closea_masks.py is a python routine to create closea mask fields +based on the old NEMO closea index definitions. Details of the grid +and the bathymetry are read in from the domain_cfg.nc file and the +closea_mask* fields are appended to the same domain_cfg.nc file. + +To use this routine: + + 1. Provide domain_cfg.nc file for your configuration. + + 2. Define closed seas for your configuration in Section 2 + using indices in the old NEMO style. (Read the comments on + indexing in Section 2!). Examples are given for eORCA025 + (UK version) for the three different options: + - just defining closed seas (and distribute fluxes over global ocean) + - defining closed seas with a RNF mapping for the American Great Lakes to the St Laurence Seaway + - defining closed seas with an EMPMR mapping for the American Great Lakes to the St Laurence Seaway + + 3. Choose whether to mask the closea_mask* fields. This is not required + but makes the fields easier to check. + + 4. Module can be run in python or from linux command line if you + change the top line to point to your python installation. If + using from command line, type "make_closea_masks.py --help" + for usage. diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/domain_def.xml b/V4.0/nemo_sources/tools/DOMAINcfg/domain_def.xml new file mode 100644 index 0000000000000000000000000000000000000000..84c8b1d917a1e0ba5d4dd45825230447edb50478 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/domain_def.xml @@ -0,0 +1,187 @@ + + <domain_definition> + <domain_group id="grid_T"> + <domain id="grid_T" long_name="grid T"/> + <!-- My zoom: example of hand defined zoom --> + <domain id="myzoom" zoom_ibegin="10" zoom_jbegin="10" zoom_ni="5" zoom_nj="5" /> + <domain id="1point" zoom_ibegin="10" zoom_jbegin="10" zoom_ni="1" zoom_nj="1" /> + <!-- Eq section --> + <domain id="EqT" zoom_ibegin="1" zoom_jbegin="0000" zoom_ni="0000" zoom_nj="1" /> + <!-- TAO --> + <!-- 137e --> + <domain id="2n137eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n137eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n137eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 147e --> + <domain id="0n147eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n147eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n147eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 156e --> + <domain id="5s156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n156eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 165e --> + <domain id="8s165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n165eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 180w --> + <domain id="8s180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n180wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 170w --> + <domain id="8s170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n170wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 155w --> + <domain id="8s155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n155wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 140w --> + <domain id="8s140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n140wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 125w --> + <domain id="8s125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n125wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 110w --> + <domain id="8s110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n110wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 95w --> + <domain id="8s95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2s95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="2n95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5n95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n95wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- RAMA --> + <!-- 55e --> + <domain id="16s55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12s55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8s55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4s55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5s55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5n55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n55eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 65e --> + <domain id="15n65eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 67e --> + <domain id="16s67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12s67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8s67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4s67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5s67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5n67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n67eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 80.5e --> + <domain id="16s80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12s80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8s80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4s80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5s80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5n80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n80.5eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 90e --> + <domain id="1.5s90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="1.5n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="15n90eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 95e --> + <domain id="16s95eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12s95eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8s95eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="5s95eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- PIRATA --> + <!-- 38w-30w --> + <domain id="19s34wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="14s32wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8s30wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n35wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n38wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="8n38wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12n38wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="15n38wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="20n38wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 23w --> + <domain id="0n23wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="4n23wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="12n23wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="21n23wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 10w --> + <domain id="10s10wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="6s10wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <domain id="0n10wT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + <!-- 0e --> + <domain id="0n0eT" zoom_ibegin="0000" zoom_jbegin="0000" zoom_ni="1" zoom_nj="1" /> + </domain_group> + + <domain_group id="grid_U"> + <domain id="grid_U" long_name="grid U"/> + <!-- Eq section --> + <domain id="EqU" zoom_ibegin="1" zoom_jbegin="0000" zoom_ni="0000" zoom_nj="1" /> + </domain_group> + + <domain id="grid_V" long_name="grid V"/> + + <domain_group id="grid_W"> + <domain id="grid_W" long_name="grid W"/> + <!-- Eq section --> + <domain id="EqW" zoom_ibegin="1" zoom_jbegin="0000" zoom_ni="0000" zoom_nj="1" /> + </domain_group> + + <domain id="grid_F" long_name="grid F"/> + + <domain_group id="scalarpoint"> + <domain id="scalarpoint" long_name="scalar"/> + <!-- + <domain id="1point" zoom_ibegin="1" zoom_jbegin="1" zoom_ni="1" zoom_nj="1" /> + --> + </domain_group> + + <domain_group id="gznl"> + <domain id="ptr" long_name="zonal mean grid" zoom_ibegin="0000" zoom_jbegin="1" zoom_ni="1" zoom_nj="0000" /> + </domain_group> + + + </domain_definition> + diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/field_def.xml b/V4.0/nemo_sources/tools/DOMAINcfg/field_def.xml new file mode 100644 index 0000000000000000000000000000000000000000..63e521de7dedb0274b3de97f2a3a429a3f7741e0 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/field_def.xml @@ -0,0 +1,1114 @@ +<!-- +<?xml version="1.0"?> + --> + + <!-- $id$ --> + + <!-- +============================================================================================================ += definition of all existing variables = += DO NOT CHANGE = +============================================================================================================ + --> + <field_definition level="1" prec="4" operation="average" enabled=".TRUE." default_value="1.e20" > <!-- time step automaticaly defined --> + + <!-- +============================================================================================================ + Physical ocean and ice model variables +============================================================================================================ + --> + + <!-- T grid --> + + <field_group id="grid_T" grid_ref="grid_T_2D" > + <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D"/> + <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D"/> + + <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/> + <field id="toce_e3t" long_name="temperature (thickness weighted)" unit="degC" grid_ref="grid_T_3D" > toce * e3t </field > + <field id="soce" long_name="salinity" standard_name="sea_water_practical_salinity" unit="1e-3" grid_ref="grid_T_3D"/> + <field id="soce_e3t" long_name="salinity (thickness weighted)" unit="1e-3" grid_ref="grid_T_3D" > soce * e3t </field > + + <!-- t-eddy viscosity coefficients (ldfdyn) --> + <field id="ahmt_2d" long_name=" surface t-eddy viscosity coefficient" unit="m2/s or m4/s" /> + <field id="ahmt_3d" long_name=" 3D t-eddy viscosity coefficient" unit="m2/s or m4/s" grid_ref="grid_T_3D"/> + + <field id="sst" long_name="sea surface temperature" standard_name="sea_surface_temperature" unit="degC" /> + <field id="sst2" long_name="square of sea surface temperature" standard_name="square_of_sea_surface_temperature" unit="degC2" > sst * sst </field > + <field id="sstmax" long_name="max of sea surface temperature" field_ref="sst" operation="maximum" /> + <field id="sstmin" long_name="min of sea surface temperature" field_ref="sst" operation="minimum" /> + <field id="sstgrad" long_name="module of sst gradient" unit="degC/m" /> + <field id="sstgrad2" long_name="square of module of sst gradient" unit="degC2/m2" /> + <field id="sbt" long_name="sea bottom temperature" unit="degC" /> + <field id="sst_wl" long_name="Delta SST of warm layer" unit="degC" /> + <field id="sst_cs" long_name="Delta SST of cool skin" unit="degC" /> + <field id="temp_3m" long_name="temperature at 3m" unit="degC" /> + + <field id="sss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" /> + <field id="sss2" long_name="square of sea surface salinity" unit="1e-6" > sss * sss </field > + <field id="sssmax" long_name="max of sea surface salinity" field_ref="sss" operation="maximum" /> + <field id="sssmin" long_name="min of sea surface salinity" field_ref="sss" operation="minimum" /> + <field id="sbs" long_name="sea bottom salinity" unit="1e-3" /> + + <field id="taubot" long_name="bottom stress module" unit="N/m2" /> + + <field id="ssh" long_name="sea surface height" standard_name="sea_surface_height_above_geoid" unit="m" /> + <field id="ssh2" long_name="square of sea surface height" standard_name="square_of_sea_surface_height_above_geoid" unit="m2" > ssh * ssh </field > + <field id="sshmax" long_name="max of sea surface height" field_ref="ssh" operation="maximum" /> + + <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" /> + <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" /> + <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" /> + <field id="heatc" long_name="Heat content vertically integrated" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" /> + <field id="saltc" long_name="Salt content vertically integrated" unit="1e-3*kg/m2" /> + + <!-- EOS --> + <field id="alpha" long_name="thermal expansion" unit="degC-1" grid_ref="grid_T_3D" /> + <field id="beta" long_name="haline contraction" unit="1e3" grid_ref="grid_T_3D" /> + <field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-1" grid_ref="grid_T_3D" /> + <field id="rhop" long_name="potential density (sigma0)" standard_name="sea_water_sigma_theta" unit="kg/m3" grid_ref="grid_T_3D" /> + + <!-- Energy - horizontal divergence --> + <field id="eken" long_name="kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_3D" /> + <field id="hdiv" long_name="horizontal divergence" unit="s-1" grid_ref="grid_T_3D" /> + + <!-- variables available with MLE --> + <field id="Lf_NHpf" long_name="MLE: Lf = N H / f" unit="m" /> + + <!-- next variables available with key_diahth --> + <field id="mlddzt" long_name="Thermocline Depth (depth of max dT/dz)" standard_name="depth_at_maximum_upward_derivative_of_sea_water_potential_temperature" unit="m" /> + <field id="mldr10_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr0_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mldr0_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="mld_dt02" long_name="Mixed Layer Depth (|dT| = 0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" /> + <field id="topthdep" long_name="Top of Thermocline Depth (dT = -0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" /> + <field id="pycndep" long_name="Pycnocline Depth (dsigma[dT=-0.2] wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> + <field id="BLT" long_name="Barrier Layer Thickness" unit="m" > topthdep - pycndep </field> + <field id="tinv" long_name="Max of vertical invertion of temperature" unit="degC" /> + <field id="depti" long_name="Depth of max. vert. inv. of temperature" unit="m" /> + <field id="20d" long_name="Depth of 20C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_20C" /> + <field id="28d" long_name="Depth of 28C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_28C" /> + <field id="hc300" long_name="Heat content 0-300m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" /> + + <!-- variables available with key_diaar5 --> + <field id="botpres" long_name="Pressure at sea floor" standard_name="sea_water_pressure_at_sea_floor" unit="dbar" /> + + <!-- variables available with key_vvl --> + <field id="tpt_dep" long_name="T-point depth" standard_name="depth_below_geoid" unit="m" grid_ref="grid_T_3D" /> + <field id="e3tdef" long_name="T-cell thickness deformation" unit="%" grid_ref="grid_T_3D" /> + </field_group> + + <!-- Tides --> + + <field_group id="Tides_T" grid_ref="grid_T_2D" operation="once" > + <!-- tidal composante --> + <field id="M2x" long_name="M2 Elevation harmonic real part " unit="m" /> + <field id="M2y" long_name="M2 Elevation harmonic imaginary part" unit="m" /> + <field id="S2x" long_name="S2 Elevation harmonic real part " unit="m" /> + <field id="S2y" long_name="S2 Elevation harmonic imaginary part" unit="m" /> + <field id="N2x" long_name="N2 Elevation harmonic real part " unit="m" /> + <field id="N2y" long_name="N2 Elevation harmonic imaginary part" unit="m" /> + <field id="K1x" long_name="K1 Elevation harmonic real part " unit="m" /> + <field id="K1y" long_name="K1 Elevation harmonic imaginary part" unit="m" /> + <field id="O1x" long_name="O1 Elevation harmonic real part " unit="m" /> + <field id="O1y" long_name="O1 Elevation harmonic imaginary part" unit="m" /> + <field id="Q1x" long_name="Q1 Elevation harmonic real part " unit="m" /> + <field id="Q1y" long_name="Q1 Elevation harmonic imaginary part" unit="m" /> + <field id="M4x" long_name="M4 Elevation harmonic real part " unit="m" /> + <field id="M4y" long_name="M4 Elevation harmonic imaginary part" unit="m" /> + <field id="K2x" long_name="K2 Elevation harmonic real part " unit="m" /> + <field id="K2y" long_name="K2 Elevation harmonic imaginary part" unit="m" /> + <field id="P1x" long_name="P1 Elevation harmonic real part " unit="m" /> + <field id="P1y" long_name="P1 Elevation harmonic imaginary part" unit="m" /> + <field id="Mfx" long_name="Mf Elevation harmonic real part " unit="m" /> + <field id="Mfy" long_name="Mf Elevation harmonic imaginary part" unit="m" /> + <field id="Mmx" long_name="Mm Elevation harmonic real part " unit="m" /> + <field id="Mmy" long_name="Mm Elevation harmonic imaginary part" unit="m" /> + </field_group> + + <field_group id="Tides_U" grid_ref="grid_U_2D" operation="once" > + <field id="M2x_u" long_name="M2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="M2y_u" long_name="M2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="S2x_u" long_name="S2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="S2y_u" long_name="S2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="N2x_u" long_name="N2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="N2y_u" long_name="N2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="K1x_u" long_name="K1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="K1y_u" long_name="K1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="O1x_u" long_name="O1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="O1y_u" long_name="O1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Q1x_u" long_name="Q1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Q1y_u" long_name="Q1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="M4x_u" long_name="M4 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="M4y_u" long_name="M4 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="K2x_u" long_name="K2 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="K2y_u" long_name="K2 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="P1x_u" long_name="P1 current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="P1y_u" long_name="P1 current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Mfx_u" long_name="Mf current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Mfy_u" long_name="Mf current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + <field id="Mmx_u" long_name="Mm current barotrope along i-axis harmonic real part " unit="m/s" /> + <field id="Mmy_u" long_name="Mm current barotrope along i-axis harmonic imaginary part " unit="m/s" /> + </field_group> + + <field_group id="Tides_V" grid_ref="grid_V_2D" operation="once" > + <field id="M2x_v" long_name="M2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="M2y_v" long_name="M2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="S2x_v" long_name="S2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="S2y_v" long_name="S2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="N2x_v" long_name="N2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="N2y_v" long_name="N2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="K1x_v" long_name="K1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="K1y_v" long_name="K1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="O1x_v" long_name="O1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="O1y_v" long_name="O1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Q1x_v" long_name="Q1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Q1y_v" long_name="Q1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="M4x_v" long_name="M4 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="M4y_v" long_name="M4 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="K2x_v" long_name="K2 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="K2y_v" long_name="K2 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="P1x_v" long_name="P1 current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="P1y_v" long_name="P1 current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Mfx_v" long_name="Mf current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Mfy_v" long_name="Mf current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + <field id="Mmx_v" long_name="Mm current barotrope along j-axis harmonic real part " unit="m/s" /> + <field id="Mmy_v" long_name="Mm current barotrope along j-axis harmonic imaginary part " unit="m/s" /> + </field_group> + + <!-- SBC --> + + <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> + <field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> + <field id="empbmr" long_name="Net Upward Water Flux at pre. tstep" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> + <field id="emp_oce" long_name="Evap minus Precip over ocean" standard_name="evap_minus_precip_over_sea_water" unit="kg/m2/s" /> + <field id="emp_ice" long_name="Evap minus Precip over ice" standard_name="evap_minus_precip_over_sea_ice" unit="kg/m2/s" /> + <field id="saltflx" long_name="Downward salt flux" unit="1e-3/m2/s" /> + <field id="fmmflx" long_name="Water flux due to freezing/melting" unit="kg/m2/s" /> + <field id="snowpre" long_name="Snow precipitation" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="runoffs" long_name="River Runoffs" standard_name="water_flux_into_sea_water_from_rivers" unit="kg/m2/s" /> + <field id="precip" long_name="Total precipitation" standard_name="precipitation_flux" unit="kg/m2/s" /> + + <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> + <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" /> + <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" /> + <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" /> + <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> + <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" /> + + <!-- * variable relative to atmospheric pressure forcing : available with ln_apr_dyn --> + <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" /> + + <!-- * variable related to ice shelf forcing * --> + <field id="fwfisf" long_name="Ice shelf melting" unit="Kg/m2/s" /> + <field id="qisf" long_name="Ice Shelf Heat Flux" unit="W/m2" /> + <field id="isfgammat" long_name="transfert coefficient for isf (temperature) " unit="m/s" /> + <field id="isfgammas" long_name="transfert coefficient for isf (salinity) " unit="m/s" /> + <field id="stbl" long_name="salinity in the Losh tbl " unit="PSU" /> + <field id="ttbl" long_name="temperature in the Losh tbl " unit="C" /> + <field id="utbl" long_name="zonal current in the Losh tbl at T point " unit="m/s" /> + <field id="vtbl" long_name="merid current in the Losh tbl at T point " unit="m/s" /> + <field id="thermald" long_name="thermal driving of ice shelf melting " unit="C" /> + <field id="tfrz" long_name="top freezing point (used to compute melt) " unit="C" /> + <field id="tinsitu" long_name="top insitu temperature (used to cmpt melt) " unit="C" /> + <field id="ustar" long_name="ustar at T point used in ice shelf melting " unit="m/s" /> + + <!-- *_oce variables available with ln_blk_clio or ln_blk_core --> + <field id="qlw_oce" long_name="Longwave Downward Heat Flux over open ocean" standard_name="surface_net_downward_longwave_flux" unit="W/m2" /> + <field id="qsb_oce" long_name="Sensible Downward Heat Flux over open ocean" standard_name="surface_downward_sensible_heat_flux" unit="W/m2" /> + <field id="qla_oce" long_name="Latent Downward Heat Flux over open ocean" standard_name="surface_downward_latent_heat_flux" unit="W/m2" /> + <field id="qemp_oce" long_name="Downward Heat Flux from E-P over open ocean" unit="W/m2" /> + <field id="taum_oce" long_name="wind stress module over open ocean" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> + + <!-- available key_oasis3 --> + <field id="snow_ao_cea" long_name="Snow over ice-free ocean (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="snow_ai_cea" long_name="Snow over sea-ice (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" /> + <field id="subl_ai_cea" long_name="Sublimation over sea-ice (cell average)" standard_name="surface_snow_and_ice_sublimation_flux" unit="kg/m2/s" /> + <field id="icealb_cea" long_name="Ice albedo (cell average)" standard_name="sea_ice_albedo" unit="1" /> + <field id="calving_cea" long_name="Calving" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" /> + + <!-- available if key_oasis3 + conservative method --> + <field id="rain" long_name="Liquid precipitation" standard_name="rainfall_flux" unit="kg/m2/s" /> + <field id="evap_ao_cea" long_name="Evaporation over ice-free ocean (cell average)" standard_name="water_evaporation_flux" unit="kg/m2/s" /> + <field id="isnwmlt_cea" long_name="Snow over Ice melting (cell average)" standard_name="surface_snow_melt_flux" unit="kg/m2/s" /> + <field id="fsal_virt_cea" long_name="Virtual salt flux due to ice formation (cell average)" standard_name="virtual_salt_flux_into_sea_water_due_to_sea_ice_thermodynamics" unit="kg/m2/s" /> + <field id="fsal_real_cea" long_name="Real salt flux due to ice formation (cell average)" standard_name="downward_sea_ice_basal_salt_flux" unit="kg/m2/s" /> + <field id="hflx_rain_cea" long_name="heat flux due to rainfall" standard_name="temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water" unit="W/m2" /> + <field id="hflx_evap_cea" long_name="heat flux due to evaporation" standard_name="temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water" unit="W/m2" /> + <field id="hflx_snow_cea" long_name="heat flux due to snow falling over ice-free ocean" standard_name="heat_flux_into_sea_water_due_to_snow_thermodynamics" unit="W/m2" /> + <field id="hflx_ice_cea" long_name="heat flux due to ice thermodynamics" standard_name="heat_flux_into_sea_water_due_to_sea_ice_thermodynamics" unit="W/m2" /> + <field id="hflx_rnf_cea" long_name="heat flux due to runoffs" standard_name="temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water" unit="W/m2" /> + <field id="hflx_cal_cea" long_name="heat flux due to calving" standard_name="heat_flux_into_sea_water_due_to_iceberg_thermodynamics" unit="W/m2" /> + <field id="bicemel_cea" long_name="Rate of Melt at Sea Ice Base (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_basal_melting" unit="kg/m2/s" /> + <field id="licepro_cea" long_name="Lateral Sea Ice Growth Rate (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_lateral_growth_of_ice_floes" unit="kg/m2/s" /> + <field id="snowmel_cea" long_name="Snow Melt Rate (cell average)" standard_name="surface_snow_melt_flux" unit="kg/m2/s" /> + <field id="sntoice_cea" long_name="Snow-Ice Formation Rate (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_snow_conversion" unit="kg/m2/s" /> + <field id="ticemel_cea" long_name="Rate of Melt at Upper Surface of Sea Ice (cell average)" standard_name="tendency_of_sea_ice_amount_due_to_surface_melting" unit="kg/m2/s" /> + + <!-- ice fields --> + <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" /> + + <field id="qsr_ai_cea" long_name="Air-Ice downward solar heat flux (cell average)" standard_name="surface_downwelling_shortwave_flux_in_air" unit="W/m2" /> + <field id="qns_ai_cea" long_name="Air-Ice downward non-solar heat flux (cell average)" unit="W/m2" /> + <field id="qla_ai_cea" long_name="Air-Ice downward Latent heat flux (cell average)" standard_name="surface_downward_latent_heat_flux" unit="W/m2" /> + + <field id="qsr_io_cea" long_name="Ice-Oce downward solar heat flux (cell average)" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qns_io_cea" long_name="Ice-Oce downward non-solar heat flux (cell average)" unit="W/m2" /> + + <field id="snowthic_cea" long_name="Snow thickness (cell average)" standard_name="surface_snow_thickness" unit="m" /> + <field id="icethic_cea" long_name="Ice thickness (cell average)" standard_name="sea_ice_thickness" unit="m" /> + <field id="iceprod_cea" long_name="Ice production (cell average)" unit="m/s" /> + <field id="iiceconc" long_name="Ice concentration" standard_name="sea_ice_area_fraction" unit="1" /> + + <field id="ice_pres" long_name="Ice presence" unit="" /> + <field id="ist_cea" long_name="Ice surface temperature (cell average)" standard_name="surface_temperature" unit="degC" /> + <field id="ist_ipa" long_name="Ice surface temperature (ice presence average)" standard_name="surface_temperature" unit="degC" /> + <field id="uice_ipa" long_name="Ice velocity along i-axis at I-point (ice presence average)" standard_name="sea_ice_x_velocity" unit="m/s" /> + <field id="vice_ipa" long_name="Ice velocity along j-axis at I-point (ice presence average)" standard_name="sea_ice_y_velocity" unit="m/s" /> + + <field id="utau_ice" long_name="Wind stress along i-axis over the ice at i-point" standard_name="surface_downward_x_stress" unit="N/m2" /> + <field id="vtau_ice" long_name="Wind stress along j-axis over the ice at i-point" standard_name="surface_downward_y_stress" unit="N/m2" /> + + <field id="u_imasstr" long_name="Sea-ice mass transport along i-axis" standard_name="sea_ice_x_transport" unit="kg/s" /> + <field id="v_imasstr" long_name="Sea-ice mass transport along j-axis" standard_name="sea_ice_y_transport" unit="kg/s" /> + <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" /> + <field id="emp_x_sss" long_name="Concentration/Dilution term on SSS" unit="kg*1e-3/m2/s" /> + <field id="rnf_x_sst" long_name="Runoff term on SST" unit="kg*degC/m2/s" /> + <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" /> + + <field id="iceconc" long_name="ice concentration" standard_name="sea_ice_area_fraction" unit="%" /> + <field id="isst" long_name="sea surface temperature" standard_name="sea_surface_temperature" unit="degC" /> + <field id="isss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" /> + <field id="qt_oce" long_name="total flux at ocean surface" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> + <field id="qsr_oce" long_name="solar heat flux at ocean surface" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qns_oce" long_name="non-solar heat flux at ocean surface" unit="W/m2" /> + <field id="qt_ice" long_name="total heat flux at ice surface: sum over categories" standard_name="surface_downward_heat_flux_in_air" unit="W/m2" /> + <field id="qsr_ice" long_name="solar heat flux at ice surface: sum over categories" standard_name="surface_downwelling_shortwave_flux_in_air" unit="W/m2" /> + <field id="qns_ice" long_name="non-solar heat flux at ice surface: sum over categories" unit="W/m2" /> + <field id="qtr_ice" long_name="solar heat flux transmitted through ice: sum over categories" unit="W/m2" /> + <field id="qemp_ice" long_name="Downward Heat Flux from E-P over ice" unit="W/m2" /> + <field id="micesalt" long_name="Mean ice salinity" unit="1e-3" /> + <field id="miceage" long_name="Mean ice age" unit="years" /> + <field id="alb_ice" long_name="Mean albedo over sea ice" unit="" /> + <field id="albedo" long_name="Mean albedo over sea ice and ocean" unit="" /> + + <field id="iceage_cat" long_name="Ice age for categories" unit="days" axis_ref="ncatice" /> + <field id="iceconc_cat" long_name="Ice concentration for categories" unit="%" axis_ref="ncatice" /> + <field id="icethic_cat" long_name="Ice thickness for categories" unit="m" axis_ref="ncatice" /> + <field id="snowthic_cat" long_name="Snow thicknessi for categories" unit="m" axis_ref="ncatice" /> + <field id="salinity_cat" long_name="Sea-Ice Bulk salinity for categories" unit="g/kg" axis_ref="ncatice" /> + <field id="brinevol_cat" long_name="Brine volume for categories" unit="%" axis_ref="ncatice" /> + <field id="icetemp_cat" long_name="Ice temperature for categories" unit="degC" axis_ref="ncatice" /> + <field id="snwtemp_cat" long_name="Snow temperature for categories" unit="degC" axis_ref="ncatice" /> + + <field id="micet" long_name="Mean ice temperature" unit="degC" /> + <field id="icehc" long_name="ice total heat content" unit="10^9J" /> + <field id="isnowhc" long_name="snow total heat content" unit="10^9J" /> + <field id="icest" long_name="ice surface temperature" unit="degC" /> + <field id="ibrinv" long_name="brine volume" unit="%" /> + <field id="icecolf" long_name="frazil ice collection thickness" unit="m" /> + <field id="icestr" long_name="ice strength" unit="N/m" /> + <field id="icevel" long_name="ice velocity" unit="m/s" /> + <field id="idive" long_name="divergence" unit="1e-8s-1" /> + <field id="ishear" long_name="shear" unit="1e-8s-1" /> + <field id="icevolu" long_name="ice volume" unit="m" /> + <field id="snowvol" long_name="snow volume" unit="m" /> + + <field id="icetrp" long_name="ice volume transport" unit="m/day" /> + <field id="snwtrp" long_name="snw volume transport" unit="m/day" /> + <field id="saltrp" long_name="salt content transport" unit="1e-3*kg/m2/day" /> + <field id="deitrp" long_name="advected ice enthalpy" unit="W/m2" /> + <field id="destrp" long_name="advected snw enthalpy" unit="W/m2" /> + + <field id="sfxbri" long_name="brine salt flux" unit="1e-3*kg/m2/day" /> + <field id="sfxdyn" long_name="salt flux from ridging rafting" unit="1e-3*kg/m2/day" /> + <field id="sfxres" long_name="salt flux from lipupdate (resultant)" unit="1e-3*kg/m2/day" /> + <field id="sfxbog" long_name="salt flux from bot growth" unit="1e-3*kg/m2/day" /> + <field id="sfxbom" long_name="salt flux from bot melt" unit="1e-3*kg/m2/day" /> + <field id="sfxsum" long_name="salt flux from surf melt" unit="1e-3*kg/m2/day" /> + <field id="sfxsni" long_name="salt flux from snow-ice formation" unit="1e-3*kg/m2/day" /> + <field id="sfxopw" long_name="salt flux from open water ice formation" unit="1e-3*kg/m2/day" /> + <field id="sfxsub" long_name="salt flux from sublimation" unit="1e-3*kg/m2/day" /> + <field id="sfx" long_name="salt flux total" unit="1e-3*kg/m2/day" /> + + <field id="vfxbog" long_name="daily bottom thermo ice prod." unit="m/day" /> + <field id="vfxdyn" long_name="daily dynamic ice prod." unit="m/day" /> + <field id="vfxopw" long_name="daily lateral thermo ice prod." unit="m/day" /> + <field id="vfxsni" long_name="daily snowice ice prod." unit="m/day" /> + <field id="vfxsum" long_name="surface melt" unit="m/day" /> + <field id="vfxbom" long_name="bottom melt" unit="m/day" /> + <field id="vfxres" long_name="daily resultant ice prod./melting from limupdate" unit="m/day" /> + <field id="vfxice" long_name="ice melt/growth" unit="m/day" /> + <field id="vfxsnw" long_name="snw melt/growth" unit="m/day" /> + <field id="vfxsub" long_name="snw sublimation" unit="m/day" /> + <field id="vfxspr" long_name="snw precipitation on ice" unit="m/day" /> + <field id="vfxthin" long_name="daily thermo ice prod. for thin ice(<20cm) + open water" unit="m/day" /> + + <field id="afxtot" long_name="area tendency (total)" unit="day-1" /> + <field id="afxdyn" long_name="area tendency (dynamics)" unit="day-1" /> + <field id="afxthd" long_name="area tendency (thermo)" unit="day-1" /> + + <field id="hfxsum" long_name="heat fluxes causing surface ice melt" unit="W/m2" /> + <field id="hfxbom" long_name="heat fluxes causing bottom ice melt" unit="W/m2" /> + <field id="hfxbog" long_name="heat fluxes causing bottom ice growth" unit="W/m2" /> + <field id="hfxdif" long_name="heat fluxes causing ice temperature change" unit="W/m2" /> + <field id="hfxopw" long_name="heat fluxes causing open water ice formation" unit="W/m2" /> + <field id="hfxsnw" long_name="heat fluxes causing snow melt" unit="W/m2" /> + <field id="hfxerr" long_name="heat fluxes error after heat diffusion" unit="W/m2" /> + <field id="hfxerr_rem" long_name="heat fluxes error after remapping" unit="W/m2" /> + <field id="hfxout" long_name="total heat fluxes received by the ocean" unit="W/m2" /> + <field id="hfxin" long_name="total heat fluxes at the ice/ocean surface" unit="W/m2" /> + + <!-- heat flux associated with mass exchange --> + <field id="hfxthd" long_name="heat fluxes from ice-ocean mass exchange during thermo" unit="W/m2" /> + <field id="hfxdyn" long_name="heat fluxes from ice-ocean mass exchange during dynamic" unit="W/m2" /> + <field id="hfxres" long_name="heat fluxes from ice-ocean mass exchange during resultant" unit="W/m2" /> + <field id="hfxsub" long_name="heat fluxes from ice-atm. mass exchange during sublimation" unit="W/m2" /> + <field id="hfxspr" long_name="heat fluxes from ice-atm. mass exchange during snow precip" unit="W/m2" /> + + <!-- diags --> + <field id="hfxdhc" long_name="Heat content variation in snow and ice" unit="W/m2" /> + <field id="hfxtur" long_name="turbulent heat flux at the ice base" unit="W/m2" /> + <!-- sbcssm variables --> + <field id="sst_m" unit="degC" /> + <field id="sss_m" unit="psu" /> + <field id="ssu_m" unit="m/s" /> + <field id="ssv_m" unit="m/s" /> + <field id="ssh_m" unit="m" /> + <field id="e3t_m" unit="m" /> + <field id="frq_m" unit="-" /> + + </field_group> + + <!-- U grid --> + + <field_group id="grid_U" grid_ref="grid_U_2D"> + <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> + <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/> + <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> + <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> + <field id="uoce_e3u" long_name="ocean current along i-axis (thickness weighted)" unit="m/s" grid_ref="grid_U_3D" > uoce * e3u </field> + <field id="ssu" long_name="ocean surface current along i-axis" unit="m/s" /> + <field id="sbu" long_name="ocean bottom current along i-axis" unit="m/s" /> + <field id="ubar" long_name="ocean barotropic current along i-axis" unit="m/s" /> + <field id="uocetr_eff" long_name="Effective ocean transport along i-axis" standard_name="ocean_volume_x_transport" unit="m3/s" grid_ref="grid_U_3D" /> + <field id="uocet" long_name="ocean transport along i-axis times temperature (CRS)" unit="degC*m/s" grid_ref="grid_U_3D" /> + <field id="uoces" long_name="ocean transport along i-axis times salinity (CRS)" unit="1e-3*m/s" grid_ref="grid_U_3D" /> + + <!-- u-eddy coefficients (ldftra) --> + <field id="ahtu_2d" long_name=" surface u-eddy diffusivity coefficient" unit="m2/s or m4/s" /> + <field id="ahtu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s or m4/s" grid_ref="grid_U_3D"/> + <field id="aeiu_2d" long_name=" surface u-EIV coefficient" unit="m2/s" /> + <field id="aeiu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s" grid_ref="grid_U_3D"/> + + <!-- variables available with MLE --> + <field id="psiu_mle" long_name="MLE streamfunction along i-axis" unit="m3/s" grid_ref="grid_U_3D" /> + + <!-- uoce_eiv: available EIV --> + <field id="uoce_eiv" long_name="EIV ocean current along i-axis" standard_name="bolus_sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> + + <!-- uoce_eiv: available with key_trabbl --> + <field id="uoce_bbl" long_name="BBL ocean current along i-axis" unit="m/s" /> + <field id="ahu_bbl" long_name="BBL diffusive flux along i-axis" unit="m3/s" /> + + <!-- variable for ice shelves --> + <field id="utbl" long_name="zonal current in the Losh tbl" unit="m/s" /> + + <!-- variables available with key_diaar5 --> + <field id="u_masstr" long_name="ocean eulerian mass transport along i-axis" standard_name="ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D" /> + <field id="u_heattr" long_name="ocean eulerian heat transport along i-axis" standard_name="ocean_heat_x_transport" unit="W" /> + <field id="u_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_x_transport" unit="1e-3*kg/s" /> + <field id="ueiv_heattr" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" /> + <field id="udiff_heattr" long_name="ocean diffusion heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_diffusion" unit="W" /> + </field_group> + + <!-- V grid --> + + <field_group id="grid_V" grid_ref="grid_V_2D"> + <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> + <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D"/> + <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> + <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> + <field id="voce_e3v" long_name="ocean current along j-axis (thickness weighted)" unit="m/s" grid_ref="grid_V_3D" > voce * e3v </field> + <field id="ssv" long_name="ocean surface current along j-axis" unit="m/s" /> + <field id="sbv" long_name="ocean bottom current along j-axis" unit="m/s" /> + <field id="vbar" long_name="ocean barotropic current along j-axis" unit="m/s" /> + <field id="vocetr_eff" long_name="Effective ocean transport along j-axis" standard_name="ocean_volume_y_transport" unit="m3/s" grid_ref="grid_V_3D" /> + <field id="vocet" long_name="ocean transport along j-axis times temperature (CRS)" unit="degC*m/s" grid_ref="grid_V_3D" /> + <field id="voces" long_name="ocean transport along j-axis times salinity (CRS)" unit="1e-3*m/s" grid_ref="grid_V_3D" /> + + <!-- v-eddy coefficients (ldftra, ldfdyn) --> + <field id="ahtv_2d" long_name=" surface v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" /> + <field id="ahtv_3d" long_name=" 3D v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" grid_ref="grid_V_3D"/> + <field id="aeiv_2d" long_name=" surface v-EIV coefficient" unit="m2/s" /> + <field id="aeiv_3d" long_name=" 3D v-EIV coefficient" unit="m2/s" grid_ref="grid_V_3D" /> + + <!-- variables available with MLE --> + <field id="psiv_mle" long_name="MLE streamfunction along j-axis" unit="m3/s" grid_ref="grid_V_3D" /> + + <!-- voce_eiv: available with EIV --> + <field id="voce_eiv" long_name="EIV ocean current along j-axis" standard_name="bolus_sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> + + <!-- voce_eiv: available with key_trabbl --> + <field id="voce_bbl" long_name="BBL ocean current along j-axis" unit="m/s" /> + <field id="ahv_bbl" long_name="BBL diffusive flux along j-axis" unit="m3/s" /> + + <!-- variable for ice shelves --> + <field id="vtbl" long_name="meridional current in the Losh tbl" unit="m/s" /> + + <!-- variables available with key_diaar5 --> + <field id="v_masstr" long_name="ocean eulerian mass transport along j-axis" standard_name="ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D" /> + <field id="v_heattr" long_name="ocean eulerian heat transport along j-axis" standard_name="ocean_heat_y_transport" unit="W" /> + <field id="v_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_y_transport" unit="1e-3*kg/s" /> + <field id="veiv_heattr" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" /> + <field id="vdiff_heattr" long_name="ocean diffusion heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_diffusion" unit="W" /> + </field_group> + + <!-- W grid --> + + <field_group id="grid_W" grid_ref="grid_W_3D"> + <field id="e3w" long_name="W-cell thickness" standard_name="cell_thickness" unit="m" /> + <field id="woce" long_name="ocean vertical velocity" standard_name="upward_sea_water_velocity" unit="m/s" /> + <field id="wocetr_eff" long_name="effective ocean vertical transport" unit="m3/s" /> + + <!-- woce_eiv: available with EIV --> + <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" /> + + + <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" /> + + <!-- avs: available with key_zdfddm --> + <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" /> + <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + + <!-- avt_evd and avm_evd: available with ln_zdfevd --> + <field id="avt_evd" long_name="convective enhancement of vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_convection" unit="m2/s" /> + <field id="avm_evd" long_name="convective enhancement of vertical viscosity" standard_name="ocean_vertical_momentum_diffusivity_due_to_convection" unit="m2/s" /> + + <!-- avt_tide: available with key_zdftmx --> + <field id="av_tide" long_name="tidal vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_tides" unit="m2/s" /> + + <!-- variables available with key_diaar5 --> + <field id="w_masstr" long_name="vertical mass transport" standard_name="upward_ocean_mass_transport" unit="kg/s" /> + <field id="w_masstr2" long_name="square of vertical mass transport" standard_name="square_of_upward_ocean_mass_transport" unit="kg2/s2" /> + + <!-- aht2d and aht2d_eiv --> + <field id="aht2d" long_name="lateral eddy diffusivity" standard_name="ocean_tracer_xy_laplacian_diffusivity" unit="m2/s" grid_ref="grid_W_2D" /> + <field id="aht2d_eiv" long_name="EIV lateral eddy diffusivity" standard_name="ocean_tracer_bolus_laplacian_diffusivity" unit="m2/s" grid_ref="grid_W_2D" /> + </field_group> + + <!-- F grid --> + <!-- f-eddy viscosity coefficients (ldfdyn) --> + <field id="ahmf_2d" long_name=" surface f-eddy viscosity coefficient" unit="m2/s or m4/s" /> + <field id="ahmf_3d" long_name=" 3D f-eddy viscosity coefficient" unit="m2/s or m4/s" grid_ref="grid_T_3D"/> + + <!-- scalar variables available with key_diaar5 --> + + <field_group id="scalar" domain_ref="1point" > + <field id="voltot" long_name="global total volume" standard_name="sea_water_volume" unit="m3" /> + <field id="sshtot" long_name="global mean ssh" standard_name="global_average_sea_level_change" unit="m" /> + <field id="sshsteric" long_name="global mean ssh steric" standard_name="global_average_steric_sea_level_change" unit="m" /> + <field id="sshthster" long_name="global mean ssh thermosteric" standard_name="global_average_thermosteric_sea_level_change" unit="m" /> + <field id="masstot" long_name="global total mass" standard_name="sea_water_mass" unit="kg" /> + <field id="temptot" long_name="global mean temperature" standard_name="sea_water_potential_temperature" unit="degC" /> + <field id="saltot" long_name="global mean salinity" standard_name="sea_water_salinity" unit="1e-3" /> + <field id="fram_trans" long_name="Sea Ice Mass Transport Through Fram Strait" standard_name="sea_ice_transport_across_line" unit="kg/s" /> + + <!-- available with ln_diahsb --> + <field id="bgtemper" long_name="drift in global mean temperature wrt timestep 1" standard_name="change_over_time_in_sea_water_potential_temperature" unit="degC" /> + <field id="bgsaline" long_name="drift in global mean salinity wrt timestep 1" standard_name="change_over_time_in_sea_water_practical_salinity" unit="1e-3" /> + <field id="bgheatco" long_name="drift in global mean heat content wrt timestep 1" unit="10^9J" /> + <field id="bgsaltco" long_name="drift in global mean salt content wrt timestep 1" unit="1e-3*m3" /> + <field id="bgvolssh" long_name="drift in global mean ssh volume wrt timestep 1" unit="km3" /> + <field id="bgvole3t" long_name="drift in global mean volume variation (e3t) wrt timestep 1" unit="km3" /> + <field id="bgvoltot" long_name="drift in global mean volume wrt timestep 1" unit="km3" /> + <!-- NOTE: No matching iom_put call --> + <field id="bgsshtot" long_name="drift in global mean ssh wrt timestep 1" standard_name="global_average_sea_level_change" unit="m" /> + <field id="bgfrcvol" long_name="drift in global mean volume from forcing wrt timestep 1" unit="km3" /> + <field id="bgfrctem" long_name="drift in global mean heat content from forcing wrt timestep 1" unit="10^9J" /> + <field id="bgfrcsal" long_name="drift in global mean salt content from forcing wrt timestep 1" unit="1e-3*km3" /> + <field id="bgmistem" long_name="global mean temperature error due to free surface" unit="degC" /> + <field id="bgmissal" long_name="global mean salinity error due to free surface" unit="1e-3" /> + </field_group> + + <!-- LIM3 scalar variables --> + + <field_group id="SBC_scalar" domain_ref="1point" > + <!-- available with ln_limdiaout --> + <field id="ibgvoltot" long_name="global mean ice volume" unit="km3" /> + <field id="sbgvoltot" long_name="global mean snow volume" unit="km3" /> + <field id="ibgarea" long_name="global mean ice area" unit="km2" /> + <field id="ibgsaline" long_name="global mean ice salinity" unit="1e-3" /> + <field id="ibgtemper" long_name="global mean ice temperature" unit="degC" /> + <field id="ibgheatco" long_name="global mean ice heat content" unit="10^20J" /> + <field id="sbgheatco" long_name="global mean snow heat content" unit="10^20J" /> + <field id="ibgsaltco" long_name="global mean ice salt content" unit="1e-3*km3" /> + + <field id="ibgvfx" long_name="global mean volume flux (emp)" unit="m/day" /> + <field id="ibgvfxbog" long_name="global mean volume flux (bottom growth)" unit="m/day" /> + <field id="ibgvfxopw" long_name="global mean volume flux (open water growth)" unit="m/day" /> + <field id="ibgvfxsni" long_name="global mean volume flux (snow-ice growth)" unit="m/day" /> + <field id="ibgvfxdyn" long_name="global mean volume flux (dynamic growth)" unit="m/day" /> + <field id="ibgvfxbom" long_name="global mean volume flux (bottom melt)" unit="m/day" /> + <field id="ibgvfxsum" long_name="global mean volume flux (surface melt)" unit="m/day" /> + <field id="ibgvfxres" long_name="global mean volume flux (resultant)" unit="m/day" /> + <field id="ibgvfxspr" long_name="global mean volume flux (snow precip)" unit="m/day" /> + <field id="ibgvfxsnw" long_name="global mean volume flux (snow melt)" unit="m/day" /> + <field id="ibgvfxsub" long_name="global mean volume flux (snow sublimation)" unit="m/day" /> + + <field id="ibgsfx" long_name="global mean salt flux (total)" unit="1e-3*m/day" /> + <field id="ibgsfxbri" long_name="global mean salt flux (brines)" unit="1e-3*m/day" /> + <field id="ibgsfxdyn" long_name="global mean salt flux (dynamic)" unit="1e-3*m/day" /> + <field id="ibgsfxres" long_name="global mean salt flux (resultant)" unit="1e-3*m/day" /> + <field id="ibgsfxbog" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + <field id="ibgsfxopw" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + <field id="ibgsfxsni" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + <field id="ibgsfxbom" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + <field id="ibgsfxsum" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + <field id="ibgsfxsub" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> + + <field id="ibghfxdhc" long_name="Heat content variation in snow and ice" unit="W" /> + <field id="ibghfxspr" long_name="Heat content of snow precip" unit="W" /> + + <field id="ibghfxthd" long_name="heat fluxes from ice-ocean exchange during thermo" unit="W" /> + <field id="ibghfxsum" long_name="heat fluxes causing surface ice melt" unit="W" /> + <field id="ibghfxbom" long_name="heat fluxes causing bottom ice melt" unit="W" /> + <field id="ibghfxbog" long_name="heat fluxes causing bottom ice growth" unit="W" /> + <field id="ibghfxdif" long_name="heat fluxes causing ice temperature change" unit="W" /> + <field id="ibghfxopw" long_name="heat fluxes causing open water ice formation" unit="W" /> + <field id="ibghfxdyn" long_name="heat fluxes from ice-ocean exchange during dynamic" unit="W" /> + <field id="ibghfxres" long_name="heat fluxes from ice-ocean exchange during resultant" unit="W" /> + <field id="ibghfxsub" long_name="heat fluxes from sublimation" unit="W" /> + <field id="ibghfxsnw" long_name="heat fluxes from snow-ocean exchange" unit="W" /> + <field id="ibghfxout" long_name="non solar heat fluxes received by the ocean" unit="W" /> + <field id="ibghfxin" long_name="total heat fluxes at the ice surface" unit="W" /> + + <field id="ibgfrcvol" long_name="global mean forcing volume (emp)" unit="km3" /> + <field id="ibgfrcsfx" long_name="global mean forcing salt (sfx)" unit="1e-3*km3" /> + <field id="ibgvolgrm" long_name="global mean ice growth+melt volume" unit="km3" /> + </field_group> + + <!-- variables available with key_float --> + + <field_group id="floatvar" domain_ref="1point" axis_ref="nfloat" operation="instant" > + <field id="traj_lon" long_name="floats longitude" unit="degrees_east" /> + <field id="traj_lat" long_name="floats latitude" unit="degrees_north" /> + <field id="traj_dep" long_name="floats depth" unit="m" /> + <field id="traj_temp" long_name="floats temperature" standard_name="sea_water_potential_temperature" unit="degC" /> + <field id="traj_salt" long_name="floats salinity" standard_name="sea_water_practical_salinity" unit="1e-3" /> + <field id="traj_dens" long_name="floats in-situ density" standard_name="sea_water_density" unit="kg/m3" /> + <field id="traj_group" long_name="floats group" unit="1" /> + </field_group> + + <!-- variables available with iceberg trajectories --> + + <field_group id="icbvar" domain_ref="grid_T" > + <field id="berg_melt" long_name="icb melt rate of icebergs" unit="kg/m2/s" /> + <field id="berg_buoy_melt" long_name="icb buoyancy component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_eros_melt" long_name="icb erosion component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_conv_melt" long_name="icb convective component of iceberg melt rate" unit="kg/m2/s" /> + <field id="berg_virtual_area" long_name="icb virtual coverage by icebergs" unit="m2" /> + <field id="bits_src" long_name="icb mass source of bergy bits" unit="kg/m2/s" /> + <field id="bits_melt" long_name="icb melt rate of bergy bits" unit="kg/m2/s" /> + <field id="bits_mass" long_name="icb bergy bit density field" unit="kg/m2" /> + <field id="berg_mass" long_name="icb iceberg density field" unit="kg/m2" /> + <field id="calving" long_name="icb calving mass input" unit="kg/s" /> + <field id="berg_floating_melt" long_name="icb melt rate of icebergs + bits" unit="kg/m2/s" /> + <field id="berg_real_calving" long_name="icb calving into iceberg class" unit="kg/s" axis_ref="icbcla" /> + <field id="berg_stored_ice" long_name="icb accumulated ice mass by class" unit="kg" axis_ref="icbcla" /> + </field_group> + + <!-- Poleward transport : ptr --> + <field_group id="diaptr" domain_ref="ptr" > + <field id="zomsfglo" long_name="Meridional Stream-Function: Global" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfatl" long_name="Meridional Stream-Function: Atlantic" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfpac" long_name="Meridional Stream-Function: Pacific" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfind" long_name="Meridional Stream-Function: Indian" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zomsfipc" long_name="Meridional Stream-Function: Pacific+Indian" unit="Sv" grid_ref="gznl_W_3D" /> + <field id="zotemglo" long_name="Zonal Mean Temperature : Global" unit="degC" grid_ref="gznl_T_3D" /> + <field id="zotematl" long_name="Zonal Mean Temperature : Atlantic" unit="degC" grid_ref="gznl_T_3D" /> + <field id="zotempac" long_name="Zonal Mean Temperature : Pacific" unit="degC" grid_ref="gznl_T_3D" /> + <field id="zotemind" long_name="Zonal Mean Temperature : Indian" unit="degC" grid_ref="gznl_T_3D" /> + <field id="zotemipc" long_name="Zonal Mean Temperature : Pacific+Indian" unit="degC" grid_ref="gznl_T_3D" /> + <field id="zosalglo" long_name="Zonal Mean Salinity : Global" unit="1e-3" grid_ref="gznl_T_3D" /> + <field id="zosalatl" long_name="Zonal Mean Salinity : Atlantic" unit="1e-3" grid_ref="gznl_T_3D" /> + <field id="zosalpac" long_name="Zonal Mean Salinity : Pacific" unit="1e-3" grid_ref="gznl_T_3D" /> + <field id="zosalind" long_name="Zonal Mean Salinity : Indian" unit="1e-3" grid_ref="gznl_T_3D" /> + <field id="zosalipc" long_name="Zonal Mean Salinity : Pacific+Indian" unit="1e-3" grid_ref="gznl_T_3D" /> + <field id="zosrfglo" long_name="Zonal Mean Surface" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfatl" long_name="Zonal Mean Surface : Atlantic" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfpac" long_name="Zonal Mean Surface : Pacific" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfind" long_name="Zonal Mean Surface : Indian" unit="m2" grid_ref="gznl_T_3D" /> + <field id="zosrfipc" long_name="Zonal Mean Surface : Pacific+Indian" unit="m2" grid_ref="gznl_T_3D" /> + <field id="sophtadv" long_name="Advective Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sophtldf" long_name="Diffusive Heat Transport" unit="PW" grid_ref="gznl_T_2D" /> + <field id="sopstadv" long_name="Advective Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + <field id="sopstldf" long_name="Diffusive Salt Transport" unit="Giga g/s" grid_ref="gznl_T_2D" /> + </field_group> + + <!-- +============================================================================================================ + Physical ocean model trend diagnostics : temperature, KE, PE, momentum +============================================================================================================ + --> + + <field_group id="trendT" grid_ref="grid_T_3D"> + <!-- variables available with ln_tra_trd --> + <field id="ttrd_xad" long_name="temperature-trend: i-advection" unit="degC/s" /> + <field id="strd_xad" long_name="salinity -trend: i-advection" unit="1e-3/s" /> + <field id="ttrd_yad" long_name="temperature-trend: j-advection" unit="degC/s" /> + <field id="strd_yad" long_name="salinity -trend: j-advection" unit="1e-3/s" /> + <field id="ttrd_zad" long_name="temperature-trend: k-advection" unit="degC/s" /> + <field id="strd_zad" long_name="salinity -trend: k-advection" unit="1e-3/s" /> + <field id="ttrd_ad" long_name="temperature-trend: advection" standard_name="tendency_of_sea_water_temperature_due_to_advection" unit="degC/s" > sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) </field> + <field id="strd_ad" long_name="salinity -trend: advection" standard_name="tendency_of_sea_water_salinity_due_to_advection" unit="1e-3/s" > sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) </field> + <field id="ttrd_sad" long_name="temperature-trend: surface adv. (no-vvl)" unit="degC/s" grid_ref="grid_T_2D" /> + <field id="strd_sad" long_name="salinity -trend: surface adv. (no-vvl)" unit="1e-3/s" grid_ref="grid_T_2D" /> + <field id="ttrd_ldf" long_name="temperature-trend: lateral diffusion" standard_name="tendency_of_sea_water_temperature_due_to_horizontal_mixing" unit="degC/s" /> + <field id="strd_ldf" long_name="salinity -trend: lateral diffusion" standard_name="tendency_of_sea_water_salinity_due_to_horizontal_mixing" unit="1e-3/s" /> + <field id="ttrd_zdf" long_name="temperature-trend: vertical diffusion" standard_name="tendency_of_sea_water_temperature_due_to_vertical_mixing" unit="degC/s" /> + <field id="strd_zdf" long_name="salinity -trend: vertical diffusion" standard_name="tendency_of_sea_water_salinity_due_to_vertical_mixing" unit="1e-3/s" /> + + <!-- ln_traldf_iso=T only (iso-neutral diffusion) --> + <field id="ttrd_zdfp" long_name="temperature-trend: pure vert. diffusion" unit="degC/s" /> + <field id="strd_zdfp" long_name="salinity -trend: pure vert. diffusion" unit="1e-3/s" /> + + <!-- --> + <field id="ttrd_dmp" long_name="temperature-trend: interior restoring" unit="degC/s" /> + <field id="strd_dmp" long_name="salinity -trend: interior restoring" unit="1e-3/s" /> + <field id="ttrd_bbl" long_name="temperature-trend: bottom boundary layer" unit="degC/s" /> + <field id="strd_bbl" long_name="salinity -trend: bottom boundary layer" unit="1e-3/s" /> + <field id="ttrd_npc" long_name="temperature-trend: non-penetrative conv." unit="degC/s" /> + <field id="strd_npc" long_name="salinity -trend: non-penetrative conv." unit="1e-3/s" /> + <field id="ttrd_qns" long_name="temperature-trend: non-solar flux + runoff" unit="degC/s" /> + <field id="strd_cdt" long_name="salinity -trend: C/D term + runoff" unit="degC/s" /> + <field id="ttrd_qsr" long_name="temperature-trend: solar penetr. heating" unit="degC/s" /> + <field id="ttrd_bbc" long_name="temperature-trend: geothermal heating" unit="degC/s" /> + <field id="ttrd_atf" long_name="temperature-trend: asselin time filter" unit="degC/s" /> + <field id="strd_atf" long_name="salinity -trend: asselin time filter" unit="1e-3/s" /> + + <!-- variables available with ln_KE_trd --> + <field id="ketrd_hpg" long_name="ke-trend: hydrostatic pressure gradient" unit="W/s^3" /> + <field id="ketrd_spg" long_name="ke-trend: surface pressure gradient" unit="W/s^3" /> + <field id="ketrd_spgexp" long_name="ke-trend: surface pressure gradient (explicit)" unit="W/s^3" /> + <field id="ketrd_spgflt" long_name="ke-trend: surface pressure gradient (filter)" unit="W/s^3" /> + <field id="ssh_flt" long_name="filtered contribution to ssh (dynspg_flt)" unit="m" grid_ref="grid_T_2D" /> + <field id="w0" long_name="surface vertical velocity" unit="m/s" grid_ref="grid_T_2D" /> + <field id="pw0_exp" long_name="surface pressure flux due to ssh" unit="W/s^2" grid_ref="grid_T_2D" /> + <field id="pw0_flt" long_name="surface pressure flux due to filtered ssh" unit="W/s^2" grid_ref="grid_T_2D" /> + <field id="ketrd_keg" long_name="ke-trend: KE gradient or hor. adv." unit="W/s^3" /> + <field id="ketrd_rvo" long_name="ke-trend: relative vorticity or metric term" unit="W/s^3" /> + <field id="ketrd_pvo" long_name="ke-trend: planetary vorticity" unit="W/s^3" /> + <field id="ketrd_zad" long_name="ke-trend: vertical advection" unit="W/s^3" /> + <field id="ketrd_udx" long_name="ke-trend: U.dx[U]" unit="W/s^3" /> + <field id="ketrd_ldf" long_name="ke-trend: lateral diffusion" unit="W/s^3" /> + <field id="ketrd_zdf" long_name="ke-trend: vertical diffusion" unit="W/s^3" /> + <field id="ketrd_tau" long_name="ke-trend: wind stress " unit="W/s^3" grid_ref="grid_T_2D" /> + <field id="ketrd_bfr" long_name="ke-trend: bottom friction (explicit)" unit="W/s^3" /> + <field id="ketrd_bfri" long_name="ke-trend: bottom friction (implicit)" unit="W/s^3" /> + <field id="ketrd_atf" long_name="ke-trend: asselin time filter trend" unit="W/s^3" /> + <field id="ketrd_convP2K" long_name="ke-trend: conversion (potential to kinetic)" unit="W/s^3" /> + <field id="KE" long_name="kinetic energy: u(n)*u(n+1)/2" unit="W/s^2" /> + + <!-- variables available with ln_PE_trd --> + <field id="petrd_xad" long_name="pe-trend: i-advection" unit="W/m^3" /> + <field id="petrd_yad" long_name="pe-trend: j-advection" unit="W/m^3" /> + <field id="petrd_zad" long_name="pe-trend: k-advection" unit="W/m^3" /> + <field id="petrd_sad" long_name="pe-trend: surface adv. (no-vvl)" unit="W/m^3" grid_ref="grid_T_2D" /> + <field id="petrd_ldf" long_name="pe-trend: lateral diffusion" unit="W/m^3" /> + <field id="petrd_zdf" long_name="pe-trend: vertical diffusion" unit="W/m^3" /> + <field id="petrd_zdfp" long_name="pe-trend: pure vert. diffusion" unit="W/m^3" /> + <field id="petrd_dmp" long_name="pe-trend: interior restoring" unit="W/m^3" /> + <field id="petrd_bbl" long_name="pe-trend: bottom boundary layer" unit="W/m^3" /> + <field id="petrd_npc" long_name="pe-trend: non-penetrative conv." unit="W/m^3" /> + <field id="petrd_nsr" long_name="pe-trend: surface forcing + runoff" unit="W/m^3" /> + <field id="petrd_qsr" long_name="pe-trend: solar penetr. heating" unit="W/m^3" /> + <field id="petrd_bbc" long_name="pe-trend: geothermal heating" unit="W/m^3" /> + <field id="petrd_atf" long_name="pe-trend: asselin time filter" unit="W/m^3" /> + <field id="PEanom" long_name="potential energy anomaly" unit="1" /> + <field id="alphaPE" long_name="partial deriv. of PEanom wrt T" unit="degC-1" /> + <field id="betaPE" long_name="partial deriv. of PEanom wrt S" unit="1e3" /> + </field_group> + + <field_group id="trendU" grid_ref="grid_U_3D"> + <!-- variables available with ln_dyn_trd --> + <field id="utrd_hpg" long_name="i-trend: hydrostatic pressure gradient" unit="m/s^2" /> + <field id="utrd_spg" long_name="i-trend: surface pressure gradient" unit="m/s^2" /> + <field id="utrd_spgexp" long_name="i-trend: surface pressure gradient (explicit)" unit="m/s^2" /> + <field id="utrd_spgflt" long_name="i-trend: surface pressure gradient (filtered)" unit="m/s^2" /> + <field id="utrd_keg" long_name="i-trend: KE gradient or hor. adv." unit="m/s^2" /> + <field id="utrd_rvo" long_name="i-trend: relative vorticity or metric term" unit="m/s^2" /> + <field id="utrd_pvo" long_name="i-trend: planetary vorticity" unit="m/s^2" /> + <field id="utrd_zad" long_name="i-trend: vertical advection" unit="m/s^2" /> + <field id="utrd_udx" long_name="i-trend: U.dx[U]" unit="m/s^2" /> + <field id="utrd_ldf" long_name="i-trend: lateral diffusion" unit="m/s^2" /> + <field id="utrd_zdf" long_name="i-trend: vertical diffusion" unit="m/s^2" /> + <field id="utrd_tau" long_name="i-trend: wind stress " unit="m/s^2" grid_ref="grid_U_2D" /> + <field id="utrd_bfr" long_name="i-trend: bottom friction (explicit)" unit="m/s^2" /> + <field id="utrd_bfri" long_name="i-trend: bottom friction (implicit)" unit="m/s^2" /> + <field id="utrd_tot" long_name="i-trend: total momentum trend before atf" unit="m/s^2" /> + <field id="utrd_atf" long_name="i-trend: asselin time filter trend" unit="m/s^2" /> + </field_group> + + <field_group id="trendV" grid_ref="grid_V_3D"> + <!-- variables available with ln_dyn_trd --> + <field id="vtrd_hpg" long_name="j-trend: hydrostatic pressure gradient" unit="m/s^2" /> + <field id="vtrd_spg" long_name="j-trend: surface pressure gradient" unit="m/s^2" /> + <field id="vtrd_spgexp" long_name="j-trend: surface pressure gradient (explicit)" unit="m/s^2" /> + <field id="vtrd_spgflt" long_name="j-trend: surface pressure gradient (filtered)" unit="m/s^2" /> + <field id="vtrd_keg" long_name="j-trend: KE gradient or hor. adv." unit="m/s^2" /> + <field id="vtrd_rvo" long_name="j-trend: relative vorticity or metric term" unit="m/s^2" /> + <field id="vtrd_pvo" long_name="j-trend: planetary vorticity" unit="m/s^2" /> + <field id="vtrd_zad" long_name="j-trend: vertical advection" unit="m/s^2" /> + <field id="vtrd_vdy" long_name="i-trend: V.dx[V]" unit="m/s^2" /> + <field id="vtrd_ldf" long_name="j-trend: lateral diffusion" unit="m/s^2" /> + <field id="vtrd_zdf" long_name="j-trend: vertical diffusion" unit="m/s^2" /> + <field id="vtrd_tau" long_name="j-trend: wind stress " unit="m/s^2" grid_ref="grid_V_2D" /> + <field id="vtrd_bfr" long_name="j-trend: bottom friction (explicit)" unit="m/s^2" /> + <field id="vtrd_bfri" long_name="j-trend: bottom friction (implicit)" unit="m/s^2" /> + <field id="vtrd_tot" long_name="j-trend: total momentum trend before atf" unit="m/s^2" /> + <field id="vtrd_atf" long_name="j-trend: asselin time filter trend" unit="m/s^2" /> + </field_group> + + <!-- +============================================================================================================ + Biogeochemistry model variables +============================================================================================================ + --> + + <!-- ptrc on T grid --> + + <field_group id="ptrc_T" grid_ref="grid_T_3D"> + <field id="DIC" long_name="Dissolved inorganic Concentration" unit="mmol/m3" /> + <field id="DIC_E3T" long_name="DIC * E3T" unit="mmol/m2" > DIC * e3t </field > + <field id="Alkalini" long_name="Total Alkalinity Concentration" unit="mmol/m3" /> + <field id="Alkalini_E3T" long_name="Alkalini * E3T" unit="mmol/m2" > Alkalini * e3t </field > + <field id="O2" long_name="Oxygen Concentration" unit="mmol/m3" /> + <field id="O2_E3T" long_name="O2 * E3T" unit="mmol/m2" > O2 * e3t </field > + <field id="CaCO3" long_name="Calcite Concentration" unit="mmol/m3" /> + <field id="CaCO3_E3T" long_name="CaCO3 * E3T" unit="mmol/m2" > CaCO3 * e3t </field > + <field id="PO4" long_name="Phosphate Concentration" unit="mmol/m3" /> + <field id="PO4_E3T" long_name="PO4 * E3T" unit="mmol/m2" > PO4 * e3t </field > + <field id="POC" long_name="Small organic carbon Concentration" unit="mmol/m3" /> + <field id="POC_E3T" long_name="POC * E3T" unit="mmol/m2" > POC * e3t </field > + <field id="Si" long_name="Silicate Concentration" unit="mmol/m3" /> + <field id="Si_E3T" long_name="Si * E3T" unit="mmol/m2" > Si * e3t </field > + <field id="PHY" long_name="(Nano)Phytoplankton Concentration" unit="mmol/m3" /> + <field id="PHY_E3T" long_name="PHY * E3T" unit="mmol/m2" > PHY * e3t </field > + <field id="ZOO" long_name="(Micro)Zooplankton Concentration" unit="mmol/m3" /> + <field id="ZOO_E3T" long_name="ZOO2 * E3T" unit="mmol/m2" > ZOO * e3t </field > + <field id="DOC" long_name="Dissolved organic Concentration" unit="mmol/m3" /> + <field id="DOC_E3T" long_name="DOC * E3T" unit="mmol/m2" > DOC * e3t </field > + <field id="PHY2" long_name="Diatoms Concentration" unit="mmol/m3" /> + <field id="PHY2_E3T" long_name="PHY2 * E3T" unit="mmol/m2" > PHY2 * e3t </field > + <field id="ZOO2" long_name="Mesozooplankton Concentration" unit="mmol/m3" /> + <field id="ZOO2_E3T" long_name="ZOO2 * E3T" unit="mmol/m2" > ZOO2 * e3t </field > + <field id="DSi" long_name="Diatoms Silicate Concentration" unit="mmol/m3" /> + <field id="DSi_E3T" long_name="Dsi * E3T" unit="mmol/m2" > DSi * e3t </field > + <field id="Fer" long_name="Dissolved Iron Concentration" unit="mmol/m3" /> + <field id="Fer_E3T" long_name="Fer * E3T" unit="mmol/m2" > Fer * e3t </field > + <field id="BFe" long_name="Big iron particles Concentration" unit="mmol/m3" /> + <field id="BFe_E3T" long_name="BFe * E3T" unit="mmol/m2" > BFe * e3t </field > + <field id="GOC" long_name="Big organic carbon Concentration" unit="mmol/m3" /> + <field id="GOC_E3T" long_name="GOC * E3T" unit="mmol/m2" > GOC * e3t </field > + <field id="SFe" long_name="Small iron particles Concentration" unit="mmol/m3" /> + <field id="SFe_E3T" long_name="SFe * E3T" unit="mmol/m2" > SFe * e3t </field > + <field id="DFe" long_name="Diatoms iron Concentration" unit="mmol/m3" /> + <field id="DFe_E3T" long_name="DFe * E3T" unit="mmol/m2" > DFe * e3t </field > + <field id="GSi" long_name="Sinking biogenic Silicate Concentration" unit="mmol/m3" /> + <field id="GSi_E3T" long_name="GSi * E3T" unit="mmol/m2" > GSi * e3t </field > + <field id="NFe" long_name="Nano iron Concentration" unit="mmol/m3" /> + <field id="NFe_E3T" long_name="NFe * E3T" unit="mmol/m2" > NFe * e3t </field > + <field id="NCHL" long_name="Nano chlorophyl Concentration" unit="mg/m3" /> + <field id="NCHL_E3T" long_name="NCHL * E3T" unit="mmol/m2" > NCHL * e3t </field > + <field id="DCHL" long_name="Diatoms chlorophyl Concentration" unit="mg/m3" /> + <field id="DCHL_E3T" long_name="DCHL * E3T" unit="mmol/m2" > DCHL * e3t </field > + <field id="NO3" long_name="Nitrate Concentration" unit="mmol/m3" /> + <field id="NO3_E3T" long_name="NO3 * E3T" unit="mmol/m2" > NO3 * e3t </field > + <field id="NH4" long_name="Ammonium Concentration" unit="mmol/m3" /> + <field id="NH4_E3T" long_name="NH4 * E3T" unit="mmol/m2" > NH4 * e3t </field > + + <!-- PISCES with Kriest parametisation : variables available with key_kriest --> + <field id="Num" long_name="Number of organic particles" unit="1" /> + <field id="Num_E3T" long_name="Num * E3T" unit="m" > Num * e3t </field > + + <!-- PISCES light : variables available with key_pisces_reduced --> + <field id="DET" long_name="Detritus" unit="mmol-N/m3" /> + <field id="DET_E3T" long_name="DET * E3T" unit="mmol-N/m2" > DET * e3t </field > + <field id="DOM" long_name="Dissolved Organic Matter" unit="mmol-N/m3" /> + <field id="DOM_E3T" long_name="DOM * E3T" unit="mmol-N/m2" > DOM * e3t </field > + + <!-- CFC11 : variables available with key_cfc --> + <field id="CFC11" long_name="CFC-11 Concentration" unit="umol/m3" /> + <field id="CFC11_E3T" long_name="CFC11 * E3T" unit="umol/m2" > CFC11 * e3t </field > + <!-- Bomb C14 : variables available with key_c14b --> + <field id="C14B" long_name="Bomb C14 Concentration" unit="1" /> + <field id="C14B_E3T" long_name="C14B * E3T" unit="m" > C14B * e3t </field > + </field_group> + + <!-- PISCES additional diagnostics on T grid --> + + <field_group id="diad_T" grid_ref="grid_T_2D"> + <field id="PH" long_name="PH" unit="1" grid_ref="grid_T_3D" /> + <field id="CO3" long_name="Bicarbonates" unit="mol/m3" grid_ref="grid_T_3D" /> + <field id="CO3sat" long_name="CO3 saturation" unit="mol/m3" grid_ref="grid_T_3D" /> + <field id="PAR" long_name="Photosynthetically Available Radiation" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="PARDM" long_name="Daily mean PAR" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="PPPHY" long_name="Primary production of nanophyto" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PPPHY2" long_name="Primary production of diatoms" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PPNEWN" long_name="New Primary production of nanophyto" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PPNEWD" long_name="New Primary production of diatoms" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PBSi" long_name="Primary production of Si diatoms" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PFeN" long_name="Primary production of nano iron" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="PFeD" long_name="Primary production of diatoms iron" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="xfracal" long_name="Calcifying fraction" unit="1" grid_ref="grid_T_3D" /> + <field id="PCAL" long_name="Calcite production" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="DCAL" long_name="Calcite dissolution" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="GRAZ1" long_name="Grazing by microzooplankton" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="GRAZ2" long_name="Grazing by mesozooplankton" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="REMIN" long_name="Oxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="DENIT" long_name="Anoxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="Nfix" long_name="Nitrogen fixation" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="Mumax" long_name="Maximum growth rate" unit="s-1" grid_ref="grid_T_3D" /> + <field id="MuN" long_name="Realized growth rate for nanophyto" unit="s-1" grid_ref="grid_T_3D" /> + <field id="MuD" long_name="Realized growth rate for diatomes" unit="s-1" grid_ref="grid_T_3D" /> + <field id="LNnut" long_name="Nutrient limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" /> + <field id="LDnut" long_name="Nutrient limitation term in Diatoms" unit="" grid_ref="grid_T_3D" /> + <field id="LNFe" long_name="Iron limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" /> + <field id="LDFe" long_name="Iron limitation term in Diatoms" unit="" grid_ref="grid_T_3D" /> + <field id="LNlight" long_name="Light limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" /> + <field id="LDlight" long_name="Light limitation term in Diatoms" unit="" grid_ref="grid_T_3D" /> + <field id="Fe2" long_name="Iron II concentration" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="Fe3" long_name="Iron III concentration" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="FeL1" long_name="Complexed Iron concentration with L1" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="FeL2" long_name="Complexed Iron concentration with L2" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="FeP" long_name="Precipitated Iron III" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="TL1" long_name="Total L1 concentration" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="TL2" long_name="Total L2 concentration" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="pdust" long_name="dust concentration" unit="g/m3" /> + <field id="Totlig" long_name="Total ligand concentation" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="Biron" long_name="Bioavailable iron" unit="nmol/m3" grid_ref="grid_T_3D" /> + <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="mol/m2/s" /> + <field id="Ironice" long_name="Iron input/uptake due to sea ice" unit="mol/m2/s" /> + <field id="HYDR" long_name="Iron input from hydrothemal vents" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="EPC100" long_name="Export of carbon particles at 100 m" unit="mol/m2/s" /> + <field id="EPFE100" long_name="Export of biogenic iron at 100 m" unit="mol/m2/s" /> + <field id="EPSI100" long_name="Export of Silicate at 100 m" unit="mol/m2/s" /> + <field id="EPCAL100" long_name="Export of Calcite at 100 m" unit="mol/m2/s" /> + <field id="EXPC" long_name="Export of carbon" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="EXPFE" long_name="Export of biogenic iron" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="EXPSI" long_name="Export of Silicate" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="EXPCAL" long_name="Export of Calcite" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="Cflx" long_name="DIC flux" unit="mol/m2/s" /> + <field id="Oflx" long_name="Oxygen flux" unit="mol/m2/s" /> + <field id="Kg" long_name="Gas transfer" unit="mol/m2/s/uatm" /> + <field id="Dpco2" long_name="Delta CO2" unit="uatm" /> + <field id="Dpo2" long_name="Delta O2" unit="uatm" /> + <field id="Heup" long_name="Euphotic layer depth" unit="m" /> + <field id="Irondep" long_name="Iron deposition from dust" unit="mol/m2/s" /> + <field id="Ironsed" long_name="Iron deposition from sediment" unit="mol/m2/s" grid_ref="grid_T_3D" /> + + + <!-- PISCES with Kriest parametisation : variables available with key_kriest --> + <field id="EPN100" long_name="Particulate number flux at 100 m" unit="mol/m2/s" /> + <field id="EXPN" long_name="Particulate number flux" unit="mol/m2/s" grid_ref="grid_T_3D" /> + <field id="XNUM" long_name="Number of particles in aggregats" unit="1" grid_ref="grid_T_3D" /> + <field id="WSC" long_name="sinking speed of mass flux" unit="m2/s" grid_ref="grid_T_3D" /> + <field id="WSN" long_name="sinking speed of number flux" unit="m2/s" grid_ref="grid_T_3D" /> + + <!-- dbio_T on T grid : variables available with key_diaar5 --> + <field id="TPP" long_name="Total Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="TPNEW" long_name="New Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="TPBFE" long_name="Total biogenic iron production" unit="mol/m3/s" grid_ref="grid_T_3D" /> + <field id="INTDIC" long_name="DIC content" unit="kg/m2" /> + <field id="O2MIN" long_name="Oxygen minimum concentration" unit="mol/m3" /> + <field id="ZO2MIN" long_name="Depth of oxygen minimum concentration" unit="m" /> + <field id="INTNFIX" long_name="Nitrogen fixation rate : vert. integrated" unit="mol/m2/s" /> + <field id="INTPPPHY" long_name="Vertically integrated primary production by nanophy" unit="mol/m2/s" /> + <field id="INTPPPHY2" long_name="Vertically integrated primary production by diatom" unit="mol/m2/s" /> + <field id="INTPP" long_name="Vertically integrated primary production by phyto" unit="mol/m2/s" /> + <field id="INTPNEW" long_name="Vertically integrated new primary production" unit="mol/m2/s" /> + <field id="INTPBFE" long_name="Vertically integrated of biogenic iron production" unit="mol/m2/s" /> + <field id="INTPBSI" long_name="Vertically integrated of biogenic Si production" unit="mol/m2/s" /> + <field id="INTPCAL" long_name="Vertically integrated of calcite production" unit="mol/m2/s" /> + + <!-- PISCES light : variables available with key_pisces_reduced --> + <field id="FNO3PHY" long_name="FNO3PHY" unit="" grid_ref="grid_T_3D" /> + <field id="FNH4PHY" long_name="FNH4PHY" unit="" grid_ref="grid_T_3D" /> + <field id="FNH4NO3" long_name="FNH4NO3" unit="" grid_ref="grid_T_3D" /> + <field id="TNO3PHY" long_name="TNO3PHY" unit="" /> + <field id="TNH4PHY" long_name="TNH4PHY" unit="" /> + <field id="TPHYDOM" long_name="TPHYDOM" unit="" /> + <field id="TPHYNH4" long_name="TPHYNH4" unit="" /> + <field id="TPHYZOO" long_name="TPHYZOO" unit="" /> + <field id="TPHYDET" long_name="TPHYDET" unit="" /> + <field id="TDETZOO" long_name="TDETZOO" unit="" /> + <field id="TZOODET" long_name="TZOODET" unit="" /> + <field id="TZOOBOD" long_name="TZOOBOD" unit="" /> + <field id="TZOONH4" long_name="TZOONH4" unit="" /> + <field id="TZOODOM" long_name="TZOODOM" unit="" /> + <field id="TNH4NO3" long_name="TNH4NO3" unit="" /> + <field id="TDOMNH4" long_name="TDOMNH4" unit="" /> + <field id="TDETNH4" long_name="TDETNH4" unit="" /> + <field id="TPHYTOT" long_name="TPHYTOT" unit="" /> + <field id="TZOOTOT" long_name="TZOOTOT" unit="" /> + <field id="SEDPOC" long_name="SEDPOC" unit="" /> + <field id="TDETSED" long_name="TDETSED" unit="" /> + + <!-- CFC11 : variables available with key_cfc --> + <field id="qtrCFC11" long_name="Air-sea flux of CFC-11" unit="mol/m2/s" /> + <field id="qintCFC11" long_name="Cumulative air-sea flux of CFC-11" unit="mol/m2" /> + + <!-- Bomb C14 : variables available with key_c14b --> + <field id="qtrC14b" long_name="Air-sea flux of Bomb C14" unit="mol/m2/s" /> + <field id="qintC14b" long_name="Cumulative air-sea flux of Bomb C14" unit="mol/m2" /> + <field id="fdecay" long_name="Radiactive decay of Bomb C14" unit="mol/m3" grid_ref="grid_T_3D" /> + </field_group> + + <field_group id="PISCES_scalar" domain_ref="1point" > + <field id="pno3tot" long_name="global mean nitrate concentration" unit="mol/m3" /> + <field id="ppo4tot" long_name="global mean phosphorus concentration" unit="mol/m3" /> + <field id="psiltot" long_name="global mean silicate concentration" unit="mol/m3" /> + <field id="palktot" long_name="global mean alkalinity concentration" unit="mol/m3" /> + <field id="pfertot" long_name="global mean iron concentration" unit="mol/m3" /> + <field id="tcflx" long_name="total Flux of Carbon out of the ocean" unit="mol/s" /> + <field id="tcflxcum" long_name="cumulative total Flux of Carbon out of the ocean" unit="mol/s" /> + <field id="tcexp" long_name="total Carbon export at 100m" unit="mol/s" /> + <field id="tintpp" long_name="global total integrated primary production" unit="mol/s" /> + <field id="tnfix" long_name="global total nitrogen fixation" unit="mol/s" /> + <field id="tdenit" long_name="Total denitrification" unit="mol/s" /> + </field_group> + + <!-- +============================================================================================================ + Definitions for iodef_demo.xml +============================================================================================================ + --> + + <field_group id="mooring" > + <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> + <field field_ref="soce" name="so" long_name="sea_water_salinity" /> + <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> + <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> + <field field_ref="woce" name="wo" long_name="sea_water_z_velocity" /> + <field field_ref="avt" name="difvho" long_name="ocean_vertical_heat_diffusivity" /> + <field field_ref="avm" name="difvmo" long_name="ocean_vertical_momentum_diffusivity" /> + + <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> + <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> + <field field_ref="sstgrad" name="tosgrad" long_name="module_of_sea_surface_temperature_gradient" /> + <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> + <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> + <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> + <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> + <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> + <field field_ref="taum" /> + <field field_ref="20d" /> + <field field_ref="mldkz5" /> + <field field_ref="mldr10_1" /> + <field field_ref="mldr10_3" /> + <field field_ref="mldr0_1" /> + <field field_ref="mldr0_3" /> + <field field_ref="mld_dt02" /> + <field field_ref="topthdep" /> + <field field_ref="pycndep" /> + <field field_ref="tinv" /> + <field field_ref="depti" /> + <field field_ref="BLT" name="blt" long_name="barrier_layer_thickness" /> + <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> + <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> + </field_group> + + <field_group id="groupT" > + <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> + <field field_ref="soce" name="so" long_name="sea_water_salinity" /> + <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> + <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> + <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> + <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> + <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> + <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> + <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> + <field field_ref="taum" /> + <field field_ref="20d" /> + <field field_ref="mldkz5" /> + <field field_ref="mldr10_1" /> + <field field_ref="mldr10_3" /> + <field field_ref="mld_dt02" /> + <field field_ref="topthdep" /> + <field field_ref="pycndep" /> + <field field_ref="tinv" /> + <field field_ref="depti" /> + <field field_ref="BLT" name="blt" long_name="Barrier Layer Thickness" /> + </field_group> + + <field_group id="groupU" > + <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> + <field field_ref="ssu" name="uos" long_name="sea_surface_x_velocity" /> + <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> + </field_group> + + <field_group id="groupV" > + <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> + <field field_ref="ssv" name="vos" long_name="sea_surface_y_velocity" /> + <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> + </field_group> + + <field_group id="groupW" > + <field field_ref="woce" name="wo" long_name="ocean vertical velocity" /> + </field_group> + + <!-- TB files --> + <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE." > + + <file id="file9" name_suffix="_shelftb_grid_T" description="TB ocean T grid variables" enabled=".TRUE." > + <field field_ref="sst" operation="instant" enabled=".TRUE." /> + <field field_ref="sbt" operation="instant" enabled=".TRUE." /> + <field field_ref="sss" operation="instant" enabled=".TRUE." /> + <field field_ref="sbs" operation="instant" enabled=".TRUE." /> + </file> + + <file id="file10" name_suffix="_shelftb_grid_U" description="TB ocean U grid variables" enabled=".TRUE." > + <field field_ref="ssu" operation="instant" enabled=".TRUE." /> + <field field_ref="sbu" operation="instant" enabled=".TRUE." /> + </file> + + <file id="file11" name_suffix="_shelftb_grid_V" description="TB ocean V grid variables" enabled=".TRUE." > + <field field_ref="ssv" operation="instant" enabled=".TRUE." /> + <field field_ref="sbv" operation="instant" enabled=".TRUE." /> + </file> + + </file_group> + + <!-- 25h diagnostic output --> + <field_group id="25h_grid_T" grid_ref="grid_T_3D" operation="instant"> + <field id="temper25h" name="potential temperature 25h mean" unit="degC" /> + <field id="tempis25h" name="insitu temperature 25h mean" unit="degC" /> + <field id="salin25h" name="salinity 25h mean" unit="psu" /> + <field id="ssh25h" name="sea surface height 25h mean" grid_ref="grid_T_2D" unit="m" /> + </field_group> + + <field_group id="25h_grid_U" grid_ref="grid_U_3D" operation="instant" > + <field id="vozocrtx25h" name="i current 25h mean" unit="m/s" /> + </field_group> + + <field_group id="25h_grid_V" grid_ref="grid_V_3D" operation="instant"> + <field id="vomecrty25h" name="j current 25h mean" unit="m/s" /> + </field_group> + + <field_group id="25h_grid_W" grid_ref="grid_W_3D" operation="instant"> + <field id="vomecrtz25h" name="k current 25h mean" unit="m/s" /> + <field id="avt25h" name="vertical diffusivity25h mean" unit="m2/s" /> + <field id="avm25h" name="vertical viscosity 25h mean" unit="m2/s" /> + <field id="tke25h" name="turbulent kinetic energy 25h mean" /> + <field id="mxln25h" name="mixing length 25h mean" unit="m" /> + </field_group> + + + + </field_definition> diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/iodef.xml b/V4.0/nemo_sources/tools/DOMAINcfg/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..c0f92da9a8f6b6dc4e1b08e3a9a7c8e69c0b2f73 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/iodef.xml @@ -0,0 +1,84 @@ +<?xml version="1.0"?> +<simulation> + + <context id="nemo" time_origin="1950-01-01 00:00:00" > + + <!-- $id$ --> + + <!-- +============================================================================================================ += definition of all existing variables = += DO NOT CHANGE = +============================================================================================================ + --> + <field_definition src="./field_def.xml"/> + <!-- +============================================================================================================ += output files definition = += Define your own files = += put the variables you want... = +============================================================================================================ + --> + + <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4"> + + <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> + <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE." /> <!-- 5d files --> + + </file_definition> + + <!-- +============================================================================================================ += grid definition = = DO NOT CHANGE = +============================================================================================================ + --> + + <axis_definition> + <axis id="deptht" long_name="Vertical T levels" unit="m" positive="down" /> + <axis id="depthu" long_name="Vertical U levels" unit="m" positive="down" /> + <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> + <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> + <axis id="nfloat" long_name="Float number" unit="1" /> + <axis id="icbcla" long_name="Iceberg class" unit="1" /> + <axis id="ncatice" long_name="Ice category" unit="1" /> + <axis id="iax_20C" long_name="20 degC isotherm" unit="degC" /> + <axis id="iax_28C" long_name="28 degC isotherm" unit="degC" /> + </axis_definition> + + <domain_definition src="./domain_def.xml"/> + + <grid_definition> + <grid id="grid_T_2D" domain_ref="grid_T"/> + <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> + <grid id="grid_U_2D" domain_ref="grid_U"/> + <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> + <grid id="grid_V_2D" domain_ref="grid_V"/> + <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> + <grid id="grid_W_2D" domain_ref="grid_W"/> + <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> + <grid id="gznl_T_2D" domain_ref="gznl"/> + <grid id="gznl_T_3D" domain_ref="gznl" axis_ref="deptht"/> + <grid id="gznl_W_3D" domain_ref="gznl" axis_ref="depthw"/> + </grid_definition> + </context> + + + <context id="xios"> + + <variable_definition> + + <!-- + We must have buffer_size > jpi*jpj*jpk*8 (with jpi and jpj the subdomain size) +--> + <variable id="buffer_size" type="integer">50000000</variable> + <variable id="buffer_server_factor_size" type="integer">2</variable> + <variable id="info_level" type="integer">0</variable> + <variable id="using_server" type="boolean">false</variable> + <variable id="using_oasis" type="boolean">false</variable> + <variable id="oasis_codes_id" type="string" >oceanx</variable> + + </variable_definition> + + </context> + +</simulation> diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/make_closea_masks.py b/V4.0/nemo_sources/tools/DOMAINcfg/make_closea_masks.py new file mode 100755 index 0000000000000000000000000000000000000000..b9f13cdf20c06c8301e11170bc7b135280fdb46c --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/make_closea_masks.py @@ -0,0 +1,433 @@ +#!/usr/local/sci/bin/python2.7 + +''' +Routine to create closea mask fields based on old NEMO closea index definitions. +Details of the grid and the bathymetry are read in from the domain_cfg.nc file and +the closea_mask* fields are appended to the same domain_cfg.nc file. + +To use this routine: + + 1. Provide domain_cfg.nc file for your configuration. + + 2. Define closed seas for your configuration in Section 2 + using indices in the old NEMO style. (Read the comments on + indexing in Section 2!). Examples are given for eORCA025 + (UK version) for the three different options: + - just defining closed seas (and distribute fluxes over global ocean) + - defining closed seas with a RNF mapping for the American Great Lakes to the St Laurence Seaway + - defining closed seas with an EMPMR mapping for the American Great Lakes to the St Laurence Seaway + + 3. Choose whether to mask the closea_mask* fields. Not required + but makes the fields easier to check. + + 4. Module can be run in python or from linux command line if you + change the top line to point to your python installation. If + using from command line, type "make_closea_masks.py --help" + for usage. + +@author: Dave Storkey +@date: Dec 2017 +''' +import netCDF4 as nc +import numpy as np +import numpy.ma as ma + +def make_closea_masks(config=None,domcfg_file=None,mask=None): + +#========================= +# 1. Read in domcfg file +#========================= + + if config is None: + raise Exception('configuration must be specified') + + if domcfg_file is None: + raise Exception('domain_cfg file must be specified') + + if mask is None: + mask=False + + domcfg = nc.Dataset(domcfg_file,'r+') + lon = domcfg.variables['nav_lon'][:] + lat = domcfg.variables['nav_lat'][:] + top_level = domcfg.variables['top_level'][0][:] + + nx = top_level.shape[1] + ny = top_level.shape[0] + + # Generate 2D "i" and "j" fields for use in "where" statements. + # These are the Fortran indices, counting from 1, so we have to + # add 1 to np.arange because python counts from 0. + + ones_2d = np.ones((ny,nx)) + ii1d = np.arange(nx)+1 + jj1d = np.arange(ny)+1 + ii2d = ii1d * ones_2d + jj2d = np.transpose(jj1d*np.transpose(ones_2d)) + +#===================================== +# 2. Closea definitions (old style) +#===================================== + + # NB. The model i and j indices defined here are Fortran indices, + # ie. counting from 1 as in the NEMO code. Also the indices + # of the arrays (ncsi1 etc) count from 1 in order to match + # the Fortran code. + # This means that you can cut and paste the definitions from + # the NEMO code and change round brackets to square brackets. + # But BEWARE: Fortran array(a:b) == Python array[a:b+1] !!! + # + + # If use_runoff_box = True then specify runoff area as all sea points within + # a rectangular area. If use_runoff_box = False then specify a list of points + # as in the old NEMO code. Default to false. + use_runoff_box = False + + #================================================================ + if config == 'ORCA2': + + num_closea = 4 + max_runoff_points = 4 + + ncsnr = np.zeros(num_closea+1,dtype=np.int) ; ncstt = np.zeros(num_closea+1,dtype=np.int) + ncsi1 = np.zeros(num_closea+1,dtype=np.int) ; ncsj1 = np.zeros(num_closea+1,dtype=np.int) + ncsi2 = np.zeros(num_closea+1,dtype=np.int) ; ncsj2 = np.zeros(num_closea+1,dtype=np.int) + ncsir = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) ; ncsjr = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) + + # Caspian Sea (spread over globe) + ncsnr[1] = 1 ; ncstt[1] = 0 + ncsi1[1] = 11 ; ncsj1[1] = 103 + ncsi2[1] = 17 ; ncsj2[1] = 112 + + # Great Lakes - North America - put at St Laurent mouth + ncsnr[2] = 1 ; ncstt[2] = 2 + ncsi1[2] = 97 ; ncsj1[2] = 107 + ncsi2[2] = 103 ; ncsj2[2] = 111 + ncsir[2,1] = 110 ; ncsjr[2,1] = 111 + + # Black Sea (crossed by the cyclic boundary condition) + # put in Med Sea (north of Aegean Sea) + ncsnr[3:5] = 4 ; ncstt[3:5] = 2 + ncsir[3:5,1] = 171; ncsjr[3:5,1] = 106 + ncsir[3:5,2] = 170; ncsjr[3:5,2] = 106 + ncsir[3:5,3] = 171; ncsjr[3:5,3] = 105 + ncsir[3:5,4] = 170; ncsjr[3:5,4] = 105 + # west part of the Black Sea + ncsi1[3] = 174 ; ncsj1[3] = 107 + ncsi2[3] = 181 ; ncsj2[3] = 112 + # east part of the Black Sea + ncsi1[4] = 2 ; ncsj1[4] = 107 + ncsi2[4] = 6 ; ncsj2[4] = 112 + + #================================================================ + elif config == 'eORCA1': + + num_closea = 1 + max_runoff_points = 1 + + ncsnr = np.zeros(num_closea+1,dtype=np.int) ; ncstt = np.zeros(num_closea+1,dtype=np.int) + ncsi1 = np.zeros(num_closea+1,dtype=np.int) ; ncsj1 = np.zeros(num_closea+1,dtype=np.int) + ncsi2 = np.zeros(num_closea+1,dtype=np.int) ; ncsj2 = np.zeros(num_closea+1,dtype=np.int) + ncsir = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) ; ncsjr = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) + + # Caspian Sea (spread over the globe) + ncsnr[1] = 1 ; ncstt[1] = 0 + ncsi1[1] = 332 ; ncsj1[1] = 243 + ncsi2[1] = 344 ; ncsj2[1] = 275 + + #================================================================ + elif config == 'eORCA025_UK': + + num_closea = 10 + max_runoff_points = 1 + + ncsnr = np.zeros(num_closea+1,dtype=np.int) ; ncstt = np.zeros(num_closea+1,dtype=np.int) + ncsi1 = np.zeros(num_closea+1,dtype=np.int) ; ncsj1 = np.zeros(num_closea+1,dtype=np.int) + ncsi2 = np.zeros(num_closea+1,dtype=np.int) ; ncsj2 = np.zeros(num_closea+1,dtype=np.int) + ncsir = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) ; ncsjr = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) + + # Caspian Sea + ncsnr[1] = 1 ; ncstt[1] = 0 + ncsi1[1] = 1330 ; ncsj1[1] = 831 + ncsi2[1] = 1375 ; ncsj2[1] = 981 + + # Aral Sea + ncsnr[2] = 1 ; ncstt[2] = 0 + ncsi1[2] = 1376 ; ncsj1[2] = 900 + ncsi2[2] = 1400 ; ncsj2[2] = 981 + + # Azov Sea + ncsnr[3] = 1 ; ncstt[3] = 0 + ncsi1[3] = 1284 ; ncsj1[3] = 908 + ncsi2[3] = 1304 ; ncsj2[3] = 933 + + # Lake Superior + ncsnr[4] = 1 ; ncstt[4] = 0 + ncsi1[4] = 781 ; ncsj1[4] = 905 + ncsi2[4] = 815 ; ncsj2[4] = 926 + + # Lake Michigan + ncsnr[5] = 1 ; ncstt[5] = 0 + ncsi1[5] = 795 ; ncsj1[5] = 871 + ncsi2[5] = 813 ; ncsj2[5] = 905 + + # Lake Huron part 1 + ncsnr[6] = 1 ; ncstt[6] = 0 + ncsi1[6] = 814 ; ncsj1[6] = 882 + ncsi2[6] = 825 ; ncsj2[6] = 905 + + # Lake Huron part 2 + ncsnr[7] = 1 ; ncstt[7] = 0 + ncsi1[7] = 826 ; ncsj1[7] = 889 + ncsi2[7] = 833 ; ncsj2[7] = 905 + + # Lake Erie + ncsnr[8] = 1 ; ncstt[8] = 0 + ncsi1[8] = 816 ; ncsj1[8] = 871 + ncsi2[8] = 837 ; ncsj2[8] = 881 + + # Lake Ontario + ncsnr[9] = 1 ; ncstt[9] = 0 + ncsi1[9] = 831 ; ncsj1[9] = 882 + ncsi2[9] = 847 ; ncsj2[9] = 889 + + # Lake Victoria + ncsnr[10] = 1 ; ncstt[10] = 0 + ncsi1[10] = 1274 ; ncsj1[10] = 672 + ncsi2[10] = 1289 ; ncsj2[10] = 687 + + #================================================================ + elif config == 'eORCA025_UK_rnf': + + num_closea = 10 + max_runoff_points = 1 + use_runoff_box = True + + ncsnr = np.zeros(num_closea+1,dtype=np.int) ; ncstt = np.zeros(num_closea+1,dtype=np.int) + ncsi1 = np.zeros(num_closea+1,dtype=np.int) ; ncsj1 = np.zeros(num_closea+1,dtype=np.int) + ncsi2 = np.zeros(num_closea+1,dtype=np.int) ; ncsj2 = np.zeros(num_closea+1,dtype=np.int) + ncsir1 = np.zeros(num_closea+1,dtype=np.int) ; ncsjr1 = np.zeros(num_closea+1,dtype=np.int) + ncsir2 = np.zeros(num_closea+1,dtype=np.int) ; ncsjr2 = np.zeros(num_closea+1,dtype=np.int) + ncsir = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) ; ncsjr = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) + + # Caspian Sea + ncsnr[1] = 1 ; ncstt[1] = 0 + ncsi1[1] = 1330 ; ncsj1[1] = 831 + ncsi2[1] = 1375 ; ncsj2[1] = 981 + + # Aral Sea + ncsnr[2] = 1 ; ncstt[2] = 0 + ncsi1[2] = 1376 ; ncsj1[2] = 900 + ncsi2[2] = 1400 ; ncsj2[2] = 981 + + # Azov Sea + ncsnr[3] = 1 ; ncstt[3] = 0 + ncsi1[3] = 1284 ; ncsj1[3] = 908 + ncsi2[3] = 1304 ; ncsj2[3] = 933 + + # Lake Superior + ncsnr[4] = 1 ; ncstt[4] = 1 + ncsi1[4] = 781 ; ncsj1[4] = 905 + ncsi2[4] = 815 ; ncsj2[4] = 926 + # runff points the St Laurence Seaway for all Great Lakes + ncsir1[4:10] = 873 ; ncsjr1[4:10] = 909 + ncsir2[4:10] = 884 ; ncsjr2[4:10] = 920 + + # Lake Michigan + ncsnr[5] = 1 ; ncstt[5] = 1 + ncsi1[5] = 795 ; ncsj1[5] = 871 + ncsi2[5] = 813 ; ncsj2[5] = 905 + + # Lake Huron part 1 + ncsnr[6] = 1 ; ncstt[6] = 1 + ncsi1[6] = 814 ; ncsj1[6] = 882 + ncsi2[6] = 825 ; ncsj2[6] = 905 + + # Lake Huron part 2 + ncsnr[7] = 1 ; ncstt[7] = 1 + ncsi1[7] = 826 ; ncsj1[7] = 889 + ncsi2[7] = 833 ; ncsj2[7] = 905 + + # Lake Erie + ncsnr[8] = 1 ; ncstt[8] = 1 + ncsi1[8] = 816 ; ncsj1[8] = 871 + ncsi2[8] = 837 ; ncsj2[8] = 881 + + # Lake Ontario + ncsnr[9] = 1 ; ncstt[9] = 1 + ncsi1[9] = 831 ; ncsj1[9] = 882 + ncsi2[9] = 847 ; ncsj2[9] = 889 + + # Lake Victoria + ncsnr[10] = 1 ; ncstt[10] = 0 + ncsi1[10] = 1274 ; ncsj1[10] = 672 + ncsi2[10] = 1289 ; ncsj2[10] = 687 + + #================================================================ + elif config == 'eORCA025_UK_empmr': + + num_closea = 10 + max_runoff_points = 1 + use_runoff_box = True + + ncsnr = np.zeros(num_closea+1,dtype=np.int) ; ncstt = np.zeros(num_closea+1,dtype=np.int) + ncsi1 = np.zeros(num_closea+1,dtype=np.int) ; ncsj1 = np.zeros(num_closea+1,dtype=np.int) + ncsi2 = np.zeros(num_closea+1,dtype=np.int) ; ncsj2 = np.zeros(num_closea+1,dtype=np.int) + ncsir1 = np.zeros(num_closea+1,dtype=np.int) ; ncsjr1 = np.zeros(num_closea+1,dtype=np.int) + ncsir2 = np.zeros(num_closea+1,dtype=np.int) ; ncsjr2 = np.zeros(num_closea+1,dtype=np.int) + ncsir = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) ; ncsjr = np.zeros((num_closea+1,max_runoff_points+1),dtype=np.int) + + # Caspian Sea + ncsnr[1] = 1 ; ncstt[1] = 0 + ncsi1[1] = 1330 ; ncsj1[1] = 831 + ncsi2[1] = 1375 ; ncsj2[1] = 981 + + # Aral Sea + ncsnr[2] = 1 ; ncstt[2] = 0 + ncsi1[2] = 1376 ; ncsj1[2] = 900 + ncsi2[2] = 1400 ; ncsj2[2] = 981 + + # Azov Sea + ncsnr[3] = 1 ; ncstt[3] = 0 + ncsi1[3] = 1284 ; ncsj1[3] = 908 + ncsi2[3] = 1304 ; ncsj2[3] = 933 + + # Lake Superior + ncsnr[4] = 1 ; ncstt[4] = 2 + ncsi1[4] = 781 ; ncsj1[4] = 905 + ncsi2[4] = 815 ; ncsj2[4] = 926 + # runff points the St Laurence Seaway for all Great Lakes + ncsir1[4:10] = 873 ; ncsjr1[4:10] = 909 + ncsir2[4:10] = 884 ; ncsjr2[4:10] = 920 + + # Lake Michigan + ncsnr[5] = 1 ; ncstt[5] = 2 + ncsi1[5] = 795 ; ncsj1[5] = 871 + ncsi2[5] = 813 ; ncsj2[5] = 905 + + # Lake Huron part 1 + ncsnr[6] = 1 ; ncstt[6] = 2 + ncsi1[6] = 814 ; ncsj1[6] = 882 + ncsi2[6] = 825 ; ncsj2[6] = 905 + + # Lake Huron part 2 + ncsnr[7] = 1 ; ncstt[7] = 2 + ncsi1[7] = 826 ; ncsj1[7] = 889 + ncsi2[7] = 833 ; ncsj2[7] = 905 + + # Lake Erie + ncsnr[8] = 1 ; ncstt[8] = 2 + ncsi1[8] = 816 ; ncsj1[8] = 871 + ncsi2[8] = 837 ; ncsj2[8] = 881 + + # Lake Ontario + ncsnr[9] = 1 ; ncstt[9] = 2 + ncsi1[9] = 831 ; ncsj1[9] = 882 + ncsi2[9] = 847 ; ncsj2[9] = 889 + + # Lake Victoria + ncsnr[10] = 1 ; ncstt[10] = 0 + ncsi1[10] = 1274 ; ncsj1[10] = 672 + ncsi2[10] = 1289 ; ncsj2[10] = 687 + +#===================================== +# 3. Generate mask fields +#===================================== + + rnf_count = 0 + empmr_count = 0 + + closea_mask = ma.zeros(top_level.shape,dtype=np.int) + temp_mask_rnf = ma.zeros(top_level.shape,dtype=np.int) + temp_mask_empmr = ma.zeros(top_level.shape,dtype=np.int) + closea_mask_rnf = ma.zeros(top_level.shape,dtype=np.int) + closea_mask_empmr = ma.zeros(top_level.shape,dtype=np.int) + + for ics in range(num_closea): + closea_mask = ma.where( ( ii2d[:] >= ncsi1[ics+1] ) & ( ii2d[:] <= ncsi2[ics+1] ) & + ( jj2d[:] >= ncsj1[ics+1] ) & ( jj2d[:] <= ncsj2[ics+1] ) & + ( top_level == 1 ), ics+1, closea_mask) + if ncstt[ics+1] == 1: + rnf_count = rnf_count + 1 + temp_mask_rnf[:] = 0 + if use_runoff_box: + temp_mask_rnf = ma.where( ( ii2d[:] >= ncsir1[ics+1] ) & ( ii2d[:] <= ncsir2[ics+1] ) & + ( jj2d[:] >= ncsjr1[ics+1] ) & ( jj2d[:] <= ncsjr2[ics+1] ) & + ( top_level == 1 ), rnf_count, 0) + else: + for ir in range(ncsnr[ics+1]): + temp_mask_rnf[ncsjr[ics+1],ncsjr[ics+1]] = rnf_count + + temp_mask_rnf = ma.where( closea_mask_rnf > 0, ma.minimum(temp_mask_rnf,closea_mask_rnf), temp_mask_rnf) + min_rnf = ma.amin(temp_mask_rnf[ma.where(temp_mask_rnf > 0)]) + max_rnf = ma.amax(temp_mask_rnf[ma.where(temp_mask_rnf > 0)]) + if min_rnf != max_rnf: + print 'min_rnf, max_rnf : ',min_rnf,max_rnf + raise Exception('Partially overlapping target rnf areas for two closed seas.') + else: + # source area: + closea_mask_rnf[ma.where(closea_mask==ics+1)] = min_rnf + # target area: + closea_mask_rnf[ma.where(temp_mask_rnf>0)] = min_rnf + # reset rnf_count: + rnf_count = min_rnf + + if ncstt[ics+1] == 2: + empmr_count = empmr_count + 1 + temp_mask_empmr[:] = 0 + if use_runoff_box: + temp_mask_empmr = ma.where( ( ii2d[:] >= ncsir1[ics+1] ) & ( ii2d[:] <= ncsir2[ics+1] ) & + ( jj2d[:] >= ncsjr1[ics+1] ) & ( jj2d[:] <= ncsjr2[ics+1] ) & + ( top_level == 1 ), empmr_count, 0) + else: + for ir in range(ncsnr[ics+1]): + temp_mask_empmr[ncsjr[ics+1],ncsjr[ics+1]] = empmr_count + + temp_mask_empmr = ma.where( closea_mask_empmr > 0, ma.minimum(temp_mask_empmr,closea_mask_empmr), temp_mask_empmr) + min_empmr = ma.amin(temp_mask_empmr[ma.where(temp_mask_empmr > 0)]) + max_empmr = ma.amax(temp_mask_empmr[ma.where(temp_mask_empmr > 0)]) + if min_empmr != max_empmr: + raise Exception('Partially overlapping target empmr areas for two closed seas.') + else: + # source area: + closea_mask_empmr[ma.where(closea_mask==ics+1)] = min_empmr + # target area: + closea_mask_empmr[ma.where(temp_mask_empmr>0)] = min_empmr + # reset empmr_count: + empmr_count = min_empmr + + if mask: + # apply land-sea mask if required + closea_mask.mask = np.where(top_level==0,True,False) + closea_mask_rnf.mask = np.where(top_level==0,True,False) + closea_mask_empmr.mask = np.where(top_level==0,True,False) + +#===================================== +# 4. Append masks to domain_cfg file. +#===================================== + + domcfg.createVariable('closea_mask',datatype='i',dimensions=('y','x'),fill_value=closea_mask.fill_value,chunksizes=(1000,1000)) + domcfg.variables['closea_mask'][:]=closea_mask + if rnf_count > 0: + domcfg.createVariable('closea_mask_rnf',datatype='i',dimensions=('y','x'),fill_value=closea_mask_rnf.fill_value,chunksizes=(1000,1000)) + domcfg.variables['closea_mask_rnf'][:]=closea_mask_rnf + if empmr_count > 0: + domcfg.createVariable('closea_mask_empmr',datatype='i',dimensions=('y','x'),fill_value=closea_mask_empmr.fill_value,chunksizes=(1000,1000)) + domcfg.variables['closea_mask_empmr'][:]=closea_mask_empmr + + domcfg.close() + + +if __name__=="__main__": + import argparse + parser = argparse.ArgumentParser() + parser.add_argument("-c", "--config", action="store",dest="config",default=None, + help="configuration: eORCA1, eORCA025_UK") + parser.add_argument("-d", "--domcfg", action="store",dest="domcfg_file",default=None, + help="domcfg file (input)") + parser.add_argument("-m", "--mask", action="store_true",dest="mask",default=False, + help="mask output file based on top_level in domcfg file") + + args = parser.parse_args() + + make_closea_masks(config=args.config,domcfg_file=args.domcfg_file,mask=args.mask) diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/namelist_cfg b/V4.0/nemo_sources/tools/DOMAINcfg/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..4cde8e64be9e26b1ca052310f037e76df3bee52c --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/namelist_cfg @@ -0,0 +1,267 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OPA Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! job number (no more used...) + cn_exp = "domaincfg" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 75 ! last time step (std 5475) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- + ! + ln_e3_dep = .true. ! =T : e3=dk[depth] in discret sens. + ! ! ===>>> will become the only possibility in v4.0 + ! ! =F : e3 analytical derivative of depth function + ! ! only there for backward compatibility test with v3.6 + ! ! + cp_cfg = "orca" ! name of the configuration + jp_cfg = 2 ! resolution of the configuration + jpidta = 182 ! 1st lateral dimension ( >= jpi ) + jpjdta = 149 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 182 ! 1st dimension of global domain --> i =jpidta + jpjglo = 149 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 4 ! lateral cond. type (between 0 and 6) +/ +!----------------------------------------------------------------------- +&namzgr ! vertical coordinate +!----------------------------------------------------------------------- + ln_zps = .true. ! z-coordinate - partial steps + ln_linssh = .true. ! linear free surface +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + jphgr_msh = 0 ! type of horizontal mesh + ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) + ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) + ppe1_m = 999999.0 ! zonal grid-spacing (degrees) + ppe2_m = 999999.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 999999. ! Minimum vertical spacing + pphmax = 999999. ! Maximum depth + ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 999999. ! Double tanh function parameters + ppkth2 = 999999. ! + ppacr2 = 999999. ! +/ +!----------------------------------------------------------------------- +&namcrs ! Grid coarsening for dynamics output and/or + ! passive tracer coarsened online simulations +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtsd ! data : Temperature & Salinity +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition (surface module) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc_core ! namsbc_core CORE bulk formulae +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs namelist surface boundary condition +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc_ssr ! surface boundary condition : sea surface restoring +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsbc_alb ! albedo parameters +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambfr ! bottom friction +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: NO) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + nn_fct_zts = 0 ! > 1 , 2nd order FCT scheme with vertical sub-timestepping + ! ! (number of sub-timestep = nn_fct_zts) +/ +!----------------------------------------------------------------------- +&namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) +!----------------------------------------------------------------------- +/ +!---------------------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers +!---------------------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_lap = .true. ! 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 = .true. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .true. ! 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 = 20 ! 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) + 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. +!---------------------------------------------------------------------------------- + ln_ldfeiv =.true. ! use eddy induced velocity parameterization + ln_ldfeiv_dia =.true. ! 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 +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_vor ! option of physics/algorithm (not control by CPP keys) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! enstrophy conserving scheme + ln_dynvor_ens = .false. ! energy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_een = .true. ! energy & enstrophy scheme + nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_spg ! Surface pressure gradient +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! Split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum +!----------------------------------------------------------------------- + ! ! Type of the operator : + ! ! no diffusion: set ln_dynldf_lap=..._blp=F + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .true. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral + ! ! Coefficient + nn_ahm_ijk_t = -30 ! 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) + 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] +/ +!----------------------------------------------------------------------- +&namzdf ! vertical physics +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion ("key_zdftke") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namzdf_ddm ! double diffusive mixing parameterization ("key_zdfddm") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namzdf_tmx ! tidal mixing parameterization ("key_zdftmx") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints & Benchmark +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namobs ! observation usage +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- +/ diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/namelist_ref b/V4.0/nemo_sources/tools/DOMAINcfg/namelist_ref new file mode 100644 index 0000000000000000000000000000000000000000..9a2030e647b4d619b232f1f0b247ac7e12aa87dc --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/namelist_ref @@ -0,0 +1,1279 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OPA : 1 - run manager (namrun) +!! namelists 2 - Domain (namcfg, namzgr, namzgr_sco, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! 3 - Surface boundary (namsbc, namsbc_ana, namsbc_flx, namsbc_clio, namsbc_core, 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) +!! 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 +!! namzgr vertical coordinate (default: NO selection) +!! namzgr_sco s-coordinate or hybrid z-s-coordinate +!! 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_e3_dep = .true. ! =T : e3=dk[depth] in discret sens. + ! ! ===>>> will become the only possibility in v4.0 + ! ! =F : e3 analytical derivative of depth function + ! ! only there for backward compatibility test with v3.6 + ! + cp_cfg = "default" ! name of the configuration + cp_cfz = "no zoom" ! name of the zoom of configuration + jp_cfg = 0 ! resolution of the configuration + jpidta = 10 ! 1st lateral dimension ( >= jpi ) + jpjdta = 12 ! 2nd " " ( >= jpj ) + jpkdta = 31 ! number of levels ( >= jpk ) + jpiglo = 10 ! 1st dimension of global domain --> i =jpidta + jpjglo = 12 ! 2nd - - --> j =jpjdta + jpizoom = 1 ! left bottom (i,j) indices of the zoom + jpjzoom = 1 ! in data domain indices + jperio = 0 ! lateral cond. type (between 0 and 6) + ! = 0 closed ; = 1 cyclic East-West + ! = 2 equatorial symmetric ; = 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 + 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 +/ +!----------------------------------------------------------------------- +&namzgr ! vertical coordinate (default: NO selection) +!----------------------------------------------------------------------- + ln_zco = .false. ! z-coordinate - full steps + ln_zps = .false. ! z-coordinate - partial steps + ln_sco = .false. ! s- or hybrid z-s-coordinate + ln_isfcav = .false. ! ice shelf cavity + ln_linssh = .false. ! linear free surface +/ +!----------------------------------------------------------------------- +&namzgr_sco ! s-coordinate or hybrid z-s-coordinate (default F) +!----------------------------------------------------------------------- + ln_s_sh94 = .false. ! Song & Haidvogel 1994 hybrid S-sigma (T)| + ln_s_sf12 = .false. ! Siddorn & Furner 2012 hybrid S-z-sigma (T)| if both are false the NEMO tanh stretching is applied + ln_sigcrit = .false. ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch + ! stretching coefficients for all functions + rn_sbot_min = 10.0 ! minimum depth of s-bottom surface (>0) (m) + rn_sbot_max = 7000.0 ! maximum depth of s-bottom surface (= ocean depth) (>0) (m) + rn_hc = 150.0 ! critical depth for transition to stretched coordinates + !!!!!!! Envelop bathymetry + rn_rmax = 0.3 ! maximum cut-off r-value allowed (0<r_max<1) + !!!!!!! SH94 stretching coefficients (ln_s_sh94 = .true.) + rn_theta = 6.0 ! surface control parameter (0<=theta<=20) + rn_bb = 0.8 ! stretching with SH94 s-sigma + !!!!!!! SF12 stretching coefficient (ln_s_sf12 = .true.) + rn_alpha = 4.4 ! stretching with SF12 s-sigma + rn_efold = 0.0 ! efold length scale for transition to stretched coord + rn_zs = 1.0 ! depth of surface grid box + ! bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b + rn_zb_a = 0.024 ! bathymetry scaling factor for calculating Zb + rn_zb_b = -0.2 ! offset for calculating Zb + !!!!!!!! Other stretching (not SH94 or SF12) [also uses rn_theta above] + rn_thetb = 1.0 ! bottom control parameter (0<=thetb<= 1) +/ +!----------------------------------------------------------------------- +&namdom ! space and time domain (bathymetry, mesh, timestep) +!----------------------------------------------------------------------- + nn_bathy = 1 ! compute (=0) or read (=1) the bathymetry file + rn_bathy = 0. ! value of the bathymetry. if (=0) bottom flat at jpkm1 + nn_closea = 0 ! remove (=0) or keep (=1) closed seas and lakes (ORCA) + nn_msh = 1 ! create (=1) a mesh file or not (=0) + rn_hmin = -3. ! min depth of the ocean (>0) or min number of ocean level (<0) + rn_isfhmin = 1.00 ! treshold (m) to discriminate grounding ice to floating ice + rn_e3zps_min= 20. ! partial step thickness is set larger than the minimum of + rn_e3zps_rat= 0.1 ! rn_e3zps_min and rn_e3zps_rat*e3t, with 0<rn_e3zps_rat<1 + ! + 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 + jphgr_msh = 0 ! type of horizontal mesh + ! = 0 curvilinear coordinate on the sphere read in coordinate.nc + ! = 1 geographical mesh on the sphere with regular grid-spacing + ! = 2 f-plane with regular grid-spacing + ! = 3 beta-plane with regular grid-spacing + ! = 4 Mercator grid with T/U point at the equator + ppglam0 = 0.0 ! longitude of first raw and column T-point (jphgr_msh = 1) + ppgphi0 = -35.0 ! latitude of first raw and column T-point (jphgr_msh = 1) + ppe1_deg = 1.0 ! zonal grid-spacing (degrees) + ppe2_deg = 0.5 ! meridional grid-spacing (degrees) + ppe1_m = 5000.0 ! zonal grid-spacing (degrees) + ppe2_m = 5000.0 ! meridional grid-spacing (degrees) + ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients + ppa0 = 255.58049070440 ! (default coefficients) + ppa1 = 245.58132232490 ! + ppkth = 21.43336197938 ! + ppacr = 3.0 ! + ppdzmin = 10. ! Minimum vertical spacing + pphmax = 5000. ! Maximum depth + ldbletanh = .TRUE. ! Use/do not use double tanf function for vertical coordinates + ppa2 = 100.760928500000 ! Double tanh function parameters + ppkth2 = 48.029893720000 ! + ppacr2 = 13.000000000000 ! +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&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) +/ +!----------------------------------------------------------------------- +&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_ana analytical formulation (ln_ana =T) +!! namsbc_flx flux formulation (ln_flx =T) +!! namsbc_clio CLIO bulk formulae formulation (ln_blk_clio=T) +!! namsbc_core CORE bulk formulae formulation (ln_blk_core=T) +!! namsbc_mfs MFS bulk formulae formulation (ln_blk_mfs =T) +!! namsbc_cpl CouPLed formulation ("key_oasis3" ) +!! namsbc_sas StAndalone 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_ana = .false. ! analytical formulation (T => fill namsbc_ana ) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk_clio = .false. ! CLIO bulk formulation (T => fill namsbc_clio) + ln_blk_core = .true. ! CORE bulk formulation (T => fill namsbc_core) + ln_blk_mfs = .false. ! MFS bulk formulation (T => fill namsbc_mfs ) + ! 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 = 2 ! =0 no ice boundary condition , + ! =1 use observed ice-cover , + ! =2 ice-model used ("key_lim3", "key_lim2", "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. ! coupling with surface wave (T => 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_ana ! analytical surface boundary condition +!----------------------------------------------------------------------- + nn_tau000 = 0 ! gently increase the stress over the first ntau_rst time-steps + rn_utau0 = 0.5 ! uniform value for the i-stress + rn_vtau0 = 0.e0 ! uniform value for the j-stress + rn_qns0 = 0.e0 ! uniform value for the total heat flux + rn_qsr0 = 0.e0 ! uniform value for the solar radiation + rn_emp0 = 0.e0 ! uniform value for the freswater budget (E-P) +/ +!----------------------------------------------------------------------- +&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_clio ! namsbc_clio CLIO bulk formulae +!----------------------------------------------------------------------- +! ! 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 = 'taux_1m' , -1 , 'sozotaux', .true. , .true. , 'yearly' , '' , '' , '' + sn_vtau = 'tauy_1m' , -1 , 'sometauy', .true. , .true. , 'yearly' , '' , '' , '' + sn_wndm = 'flx' , -1 , 'socliowi', .true. , .true. , 'yearly' , '' , '' , '' + sn_tair = 'flx' , -1 , 'socliot2', .true. , .true. , 'yearly' , '' , '' , '' + sn_humi = 'flx' , -1 , 'socliohu', .true. , .true. , 'yearly' , '' , '' , '' + sn_ccov = 'flx' , -1 , 'socliocl', .false. , .true. , 'yearly' , '' , '' , '' + sn_prec = 'flx' , -1 , 'socliopl', .false. , .true. , 'yearly' , '' , '' , '' + + cn_dir = './' ! root directory for the location of the bulk files are +/ +!----------------------------------------------------------------------- +&namsbc_core ! namsbc_core CORE bulk formulae +!----------------------------------------------------------------------- +! ! 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_tdif = 'taudif_core' , 24 , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + + 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) +/ +!----------------------------------------------------------------------- +&namsbc_mfs ! namsbc_mfs MFS bulk formulae +!----------------------------------------------------------------------- +! ! 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 = 'ecmwf' , 6 , 'u10' , .true. , .false., 'daily' ,'bicubic.nc' , '' , '' + sn_wndj = 'ecmwf' , 6 , 'v10' , .true. , .false., 'daily' ,'bicubic.nc' , '' , '' + sn_clc = 'ecmwf' , 6 , 'clc' , .true. , .false., 'daily' ,'bilinear.nc', '' , '' + sn_msl = 'ecmwf' , 6 , 'msl' , .true. , .false., 'daily' ,'bicubic.nc' , '' , '' + sn_tair = 'ecmwf' , 6 , 't2' , .true. , .false., 'daily' ,'bicubic.nc' , '' , '' + sn_rhm = 'ecmwf' , 6 , 'rh' , .true. , .false., 'daily' ,'bilinear.nc', '' , '' + sn_prec = 'ecmwf' , 6 , 'precip' , .true. , .true. , 'daily' ,'bicubic.nc' , '' , '' + + cn_dir = './ECMWF/' ! root directory for the location of the bulk files +/ +!----------------------------------------------------------------------- +&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' , '' , '' , '' +! 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' , '' , '' , '' +! + 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 ! analytical 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 ! + 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 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 = '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 = 0 ! parameterization of ice/snow albedo + ! 0: Shine & Henderson-Sellers (JGR 1985) + ! 1: "home made" based on Brandt et al. (J. Climate 2005) + ! and Grenfell & Perovich (JGR 2004) + rn_albice = 0.53 ! albedo of bare puddled ice (values from 0.49 to 0.58) + ! 0.53 (default) => if nn_ice_alb=0 + ! 0.50 (default) => if nn_ice_alb=1 +/ +!----------------------------------------------------------------------- +&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 = 'cdg_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_wn = 'sdw_wave', 1 , 'wave_num' , .true. , .false., 'daily' , '' , '' , '' +! + cn_dir_cdg = './' ! root directory for the location of drag coefficient files + ln_cdgw = .false. ! Neutral drag coefficient read from wave model + ln_sdw = .false. ! Computation of 3D stokes drift +/ +!----------------------------------------------------------------------- +&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<sicn_shift<1) + ln_passive_mode = .false. ! iceberg - ocean decoupling + nn_test_icebergs = 10 ! Create test icebergs of this class (-1 = no) + ! Put a test iceberg at each gridpoint in box (lon1,lon2,lat1,lat2) + rn_test_box = 108.0, 116.0, -66.0, -58.0 + rn_speed_limit = 0. ! CFL speed limit for a berg + +! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F ) ! 'monthly' ! filename ! pairing ! filename ! + sn_icb = 'calving', -1 , 'calvingmask', .true. , .true. , 'yearly' , '' , '' , '' + + cn_dir = './' +/ + +!!====================================================================== +!! *** Lateral boundary condition *** +!!====================================================================== +!! namlbc lateral momentum boundary condition +!! namagrif agrif nested grid ( read by child model only ) ("key_agrif") +!! nam_tide Tidal forcing +!! nambdy Unstructured open boundaries ("key_bdy") +!! nambdy_dta Unstructured open boundaries - external data ("key_bdy") +!! nambdy_tide tidal forcing at open boundaries ("key_bdy_tides") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = 2. ! 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") +!----------------------------------------------------------------------- + nn_cln_update = 3 ! baroclinic update frequency + 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. ! +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters ("key_tide") +!----------------------------------------------------------------------- + ln_tide_pot = .true. ! use tidal potential forcing + ln_tide_ramp= .false. ! + rdttideramp = 0. ! + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries ("key_bdy") +!----------------------------------------------------------------------- + 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_lim = 'none' ! + nn_ice_lim_dta = 0 ! = 0, bdy data are equal to the initial state + ! = 1, bdy data are read in 'bdydata .nc' files + rn_ice_tem = 270. ! lim3 only: arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! lim3 only: -- salinity -- + rn_ice_age = 30. ! lim3 only: -- age -- + + 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 ("key_bdy") +!----------------------------------------------------------------------- +! ! 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 ! + 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 lim2 +! bn_frld = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , '' +! bn_hicif = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , '' +! bn_hsnif = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , '' +! for lim3 +! bn_a_i = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , '' +! bn_ht_i = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , '' +! bn_ht_s = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , '' + + cn_dir = 'bdydta/' ! root directory for the location of the bulk files + ln_full_vel = .false. ! +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** Bottom boundary condition *** +!!====================================================================== +!! nambfr bottom friction +!! nambbc bottom temperature boundary condition +!! nambbl bottom boundary layer scheme ("key_trabbl") +!!====================================================================== +! +!----------------------------------------------------------------------- +&nambfr ! bottom friction (default: linear) +!----------------------------------------------------------------------- + nn_bfr = 1 ! type of bottom friction : = 0 : free slip, = 1 : linear friction + ! = 2 : nonlinear friction + rn_bfri1 = 4.e-4 ! bottom drag coefficient (linear case) + rn_bfri2 = 1.e-3 ! bottom drag coefficient (non linear case). Minimum coeft if ln_loglayer=T + rn_bfri2_max= 1.e-1 ! max. bottom drag coefficient (non linear case and ln_loglayer=T) + rn_bfeb2 = 2.5e-3 ! bottom turbulent kinetic energy background (m2/s2) + rn_bfrz0 = 3.e-3 ! bottom roughness [m] if ln_loglayer=T + ln_bfr2d = .false. ! horizontal variation of the bottom friction coef (read a 2D mask file ) + rn_bfrien = 50. ! local multiplying factor of bfr (ln_bfr2d=T) + rn_tfri1 = 4.e-4 ! top drag coefficient (linear case) + rn_tfri2 = 2.5e-3 ! top drag coefficient (non linear case). Minimum coeft if ln_loglayer=T + rn_tfri2_max= 1.e-1 ! max. top drag coefficient (non linear case and ln_loglayer=T) + rn_tfeb2 = 0.0 ! top turbulent kinetic energy background (m2/s2) + rn_tfrz0 = 3.e-3 ! top roughness [m] if ln_loglayer=T + ln_tfr2d = .false. ! horizontal variation of the top friction coef (read a 2D mask file ) + rn_tfrien = 50. ! local multiplying factor of tfr (ln_tfr2d=T) + + ln_bfrimp = .true. ! implicit bottom friction (requires ln_zdfexp = .false. if true) + ln_loglayer = .false. ! logarithmic formulation (non linear case) +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: NO) +!----------------------------------------------------------------------- +! ! 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_qgh ='geothermal_heating.nc', -12. , 'heatflow', .false. , .true. , 'yearly' , '' , '' , '' + ! + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 0 no flux + ! = 1 constant flux + ! = 2 variable flux (read in geothermal_heating.nc in mW/m2) + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat flux [W/m2] + cn_dir = './' ! root directory for the location of the runoff files +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme ("key_trabbl") +!----------------------------------------------------------------------- + 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 +!! namtra_adv advection scheme +!! namtra_adv_mle mixed layer eddy param. (Fox-Kemper param.) +!! namtra_ldf lateral diffusion scheme +!! namtra_ldfeiv eddy induced velocity param. +!! namtra_dmp T & S newtonian damping +!!====================================================================== +! +!----------------------------------------------------------------------- +&nameos ! ocean physical parameters +!----------------------------------------------------------------------- + ln_teos10 = .false. ! = Use TEOS-10 equation of state + ln_eos80 = .false. ! = Use EOS80 equation of state + ln_seos = .false. ! = Use simplified equation of state (S-EOS) + ! + ! ! 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 (nn_eos= 1) + rn_b0 = 7.6554e-1 ! saline expension coefficient (nn_eos= 1) + 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 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 + nn_fct_zts = 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 = .true. ! 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) + 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] + ! + ! Caution in 20 and 30 cases the coefficient have to be given for a 1 degree grid (~111km) +/ + +!!====================================================================== +!! 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 +/ +!----------------------------------------------------------------------- +&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) + 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 & Benchmark +!! 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 & Benchmark +!----------------------------------------------------------------------- + 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_bench = 0 ! Bench mode (1/0): CAUTION use zero except for bench + ! (no physical validity of the results) + 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) +!! namflo float parameters ("key_float") +!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") +!! namdct transports through some sections ("key_diadct") +!! 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<jpk) +!!gm rn_ucf = 1. ! unit conversion factor (=1 -> /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_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/V4.0/nemo_sources/tools/DOMAINcfg/src/calendar.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/calendar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9a034a414ab5fa0f95efefb3c67952244c9a3c46 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/closea.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/closea.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b4e975dcd5c62d2ad569d465ee7cd4e18b3d5e5 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/closea.f90 @@ -0,0 +1,223 @@ +MODULE closea + !!====================================================================== + !! *** MODULE closea *** + !! Closed Seas : specific treatments associated with closed seas + !!====================================================================== + !! History : 8.2 ! 00-05 (O. Marti) Original code + !! 8.5 ! 02-06 (E. Durand, G. Madec) F90 + !! 9.0 ! 06-07 (G. Madec) add clo_rnf, clo_ups, clo_bat + !! NEMO 3.4 ! 03-12 (P.G. Fogli) sbc_clo bug fix & mpp reproducibility + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_clo : modification of the ocean domain for closed seas cases + !! sbc_clo : Special handling of closed seas + !! clo_rnf : set close sea outflows as river mouths (see sbcrnf) + !! clo_ups : set mixed centered/upstream scheme in closed sea (see traadv_cen2) + !! clo_bat : set to zero a field over closed sea (see domzrg) + !!---------------------------------------------------------------------- + USE oce ! dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_fortran, ONLY: glob_sum, DDPDD + USE lbclnk ! lateral boundary condition - MPP exchanges + USE lib_mpp ! MPP library + USE timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_clo ! routine called by domain module + PUBLIC clo_bat ! routine called in domzgr module + + INTEGER, PUBLIC, PARAMETER :: jpncs = 4 !: number of closed sea + INTEGER, PUBLIC, DIMENSION(jpncs) :: ncstt !: Type of closed sea + INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsi1, ncsj1 !: south-west closed sea limits (i,j) + INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsi2, ncsj2 !: north-east closed sea limits (i,j) + INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsnr !: number of point where run-off pours + INTEGER, PUBLIC, DIMENSION(jpncs,4) :: ncsir, ncsjr !: Location of runoff + + REAL(wp), DIMENSION (jpncs+1) :: surf ! closed sea surface + + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: closea.F90 5836 2015-10-26 14:49:40Z cetlod $ + !! Software governed by the CeCILL licence (./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 : ncsi1(), ncsj1() : south-west closed sea limits (i,j) + !! ncsi2(), ncsj2() : north-east Closed sea limits (i,j) + !! ncsir(), ncsjr() : Location of runoff + !! ncsnr : number of point where run-off pours + !! ncstt : Type of closed sea + !! =0 spread over the world ocean + !! =2 put at location runoff + !!---------------------------------------------------------------------- + INTEGER :: jc ! dummy loop indices + INTEGER :: isrow ! local index + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'dom_clo : closed seas ' + IF(lwp) WRITE(numout,*)'~~~~~~~' + ! + ! initial values + ncsnr(:) = 1 ; ncsi1(:) = 1 ; ncsi2(:) = 1 ; ncsir(:,:) = 1 + ncstt(:) = 0 ; ncsj1(:) = 1 ; ncsj2(:) = 1 ; ncsjr(:,:) = 1 + ! + ! set the closed seas (in data domain indices) + ! ------------------- + ! + IF( cp_cfg == "orca" ) THEN + ! + SELECT CASE ( jp_cfg ) + ! ! ======================= + CASE ( 1 ) ! ORCA_R1 configuration + ! ! ======================= + ! This dirty section will be suppressed by simplification process: + ! all this will come back in input files + ! Currently these hard-wired indices relate to configuration with + ! extend grid (jpjglo=332) + isrow = 332 - jpjglo + ! + ncsnr(1) = 1 ; ncstt(1) = 0 ! Caspian Sea + ncsi1(1) = 332 ; ncsj1(1) = 243 - isrow + ncsi2(1) = 344 ; ncsj2(1) = 275 - isrow + ncsir(1,1) = 1 ; ncsjr(1,1) = 1 + ! + ! ! ======================= + CASE ( 2 ) ! ORCA_R2 configuration + ! ! ======================= + ! ! Caspian Sea + ncsnr(1) = 1 ; ncstt(1) = 0 ! spread over the globe + ncsi1(1) = 11 ; ncsj1(1) = 103 + ncsi2(1) = 17 ; ncsj2(1) = 112 + ncsir(1,1) = 1 ; ncsjr(1,1) = 1 + ! ! Great North American Lakes + ncsnr(2) = 1 ; ncstt(2) = 2 ! put at St Laurent mouth + ncsi1(2) = 97 ; ncsj1(2) = 107 + ncsi2(2) = 103 ; ncsj2(2) = 111 + ncsir(2,1) = 110 ; ncsjr(2,1) = 111 + ! ! Black Sea (crossed by the cyclic boundary condition) + ncsnr(3:4) = 4 ; ncstt(3:4) = 2 ! put in Med Sea (north of Aegean Sea) + ncsir(3:4,1) = 171; ncsjr(3:4,1) = 106 ! + ncsir(3:4,2) = 170; ncsjr(3:4,2) = 106 + ncsir(3:4,3) = 171; ncsjr(3:4,3) = 105 + ncsir(3:4,4) = 170; ncsjr(3:4,4) = 105 + ncsi1(3) = 174 ; ncsj1(3) = 107 ! 1 : west part of the Black Sea + ncsi2(3) = 181 ; ncsj2(3) = 112 ! (ie west of the cyclic b.c.) + ncsi1(4) = 2 ; ncsj1(4) = 107 ! 2 : east part of the Black Sea + ncsi2(4) = 6 ; ncsj2(4) = 112 ! (ie east of the cyclic b.c.) + + + + ! ! ======================= + CASE ( 4 ) ! ORCA_R4 configuration + ! ! ======================= + ! ! Caspian Sea + ncsnr(1) = 1 ; ncstt(1) = 0 + ncsi1(1) = 4 ; ncsj1(1) = 53 + ncsi2(1) = 4 ; ncsj2(1) = 56 + ncsir(1,1) = 1 ; ncsjr(1,1) = 1 + ! ! Great North American Lakes + ncsnr(2) = 1 ; ncstt(2) = 2 + ncsi1(2) = 49 ; ncsj1(2) = 55 + ncsi2(2) = 51 ; ncsj2(2) = 56 + ncsir(2,1) = 57 ; ncsjr(2,1) = 55 + ! ! Black Sea + ncsnr(3) = 4 ; ncstt(3) = 2 + ncsi1(3) = 88 ; ncsj1(3) = 55 + ncsi2(3) = 91 ; ncsj2(3) = 56 + ncsir(3,1) = 86 ; ncsjr(3,1) = 53 + ncsir(3,2) = 87 ; ncsjr(3,2) = 53 + ncsir(3,3) = 86 ; ncsjr(3,3) = 52 + ncsir(3,4) = 87 ; ncsjr(3,4) = 52 + ! ! Baltic Sea + ncsnr(4) = 1 ; ncstt(4) = 2 + ncsi1(4) = 75 ; ncsj1(4) = 59 + ncsi2(4) = 76 ; ncsj2(4) = 61 + ncsir(4,1) = 84 ; ncsjr(4,1) = 59 + ! ! ======================= + CASE ( 025 ) ! ORCA_R025 configuration + ! ! ======================= + ncsnr(1) = 1 ; ncstt(1) = 0 ! Caspian + Aral sea + ncsi1(1) = 1330 ; ncsj1(1) = 645 + ncsi2(1) = 1400 ; ncsj2(1) = 795 + ncsir(1,1) = 1 ; ncsjr(1,1) = 1 + ! + ncsnr(2) = 1 ; ncstt(2) = 0 ! Azov Sea + ncsi1(2) = 1284 ; ncsj1(2) = 722 + ncsi2(2) = 1304 ; ncsj2(2) = 747 + ncsir(2,1) = 1 ; ncsjr(2,1) = 1 + ! + END SELECT + ! + ENDIF + + ! convert the position in local domain indices + ! -------------------------------------------- + DO jc = 1, jpncs + ncsi1(jc) = mi0( ncsi1(jc) ) + ncsj1(jc) = mj0( ncsj1(jc) ) + + ncsi2(jc) = mi1( ncsi2(jc) ) + ncsj2(jc) = mj1( ncsj2(jc) ) + END DO + ! + END SUBROUTINE dom_clo + + + SUBROUTINE clo_bat( pbat, kbat ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_bat *** + !! + !! ** Purpose : suppress closed sea from the domain + !! + !! ** Method : set to 0 the meter and level bathymetry (given in + !! arguments) over the closed seas. + !! + !! ** Action : set pbat=0 and kbat=0 over closed seas + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pbat ! bathymetry in meters (bathy array) + INTEGER , DIMENSION(jpi,jpj), INTENT(inout) :: kbat ! bathymetry in levels (mbathy array) + ! + INTEGER :: jc, ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + DO jc = 1, jpncs + DO jj = ncsj1(jc), ncsj2(jc) + DO ji = ncsi1(jc), ncsi2(jc) + pbat(ji,jj) = 0._wp + kbat(ji,jj) = 0 + END DO + END DO + END DO + ! + END SUBROUTINE clo_bat + + !!====================================================================== +END MODULE closea + diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/daymod.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/daymod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2c7a0ae0be203da660b554e5aea742ca62bdef42 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/daymod.f90 @@ -0,0 +1,287 @@ +MODULE daymod + !!====================================================================== + !! *** MODULE daymod *** + !! Ocean : 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 ----------- + !! + !! we suppose that the time step is deviding the number of second of in a day + !! ---> MOD( rday, rdt ) == 0 + !! + !! ----------- WARNING ----------- + !! ------------------------------- + !! + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE iom ! + USE ioipsl , ONLY : ymds2ju ! for calendar + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC day ! called by step.F90 + PUBLIC day_init ! called by istate.F90 + PUBLIC day_mth ! Needed by TAM + + INTEGER, PUBLIC :: nsecd, nsecd05, ndt, ndt05 !: (PUBLIC for TAM) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: daymod.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./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 + REAL(wp) :: zjul + !!---------------------------------------------------------------------- + ! + ! 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 + ! all calendar staff is based on the fact that MOD( rday, rdt ) == 0 + 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' ) + nsecd = NINT(rday ) + nsecd05 = NINT(0.5 * rday ) + ndt = NINT( rdt ) + ndt05 = NINT(0.5 * rdt ) + + + ! 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( nn_time0*3600 - 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 ) + ! + 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( nn_timing == 1 ) 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( nn_timing == 1 ) CALL timing_stop('day') + ! + END SUBROUTINE day + + + !!====================================================================== +END MODULE daymod diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/defprec.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/defprec.f90 new file mode 100644 index 0000000000000000000000000000000000000000..67cda8f784a9b279dc03e4e24ce26c1c9cdf45e0 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/dom_oce.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/dom_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..403cb03abc2bd12cf76b0be44063ae7d48a8b507 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/dom_oce.f90 @@ -0,0 +1,385 @@ +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 * + INTEGER , PUBLIC :: nn_bathy !: = 0/1 ,compute/read the bathymetry file + REAL(wp), PUBLIC :: rn_bathy !: depth of flat bottom (active if nn_bathy=0; if =0 depth=jpkm1) + REAL(wp), PUBLIC :: rn_hmin !: minimum ocean depth (>0) or minimum number of ocean levels (<0) + REAL(wp), PUBLIC :: rn_isfhmin !: threshold to discriminate grounded ice to floating ice + REAL(wp), PUBLIC :: rn_e3zps_min !: miminum thickness for partial steps (meters) + REAL(wp), PUBLIC :: rn_e3zps_rat !: minimum thickness ration for partial steps + INTEGER , PUBLIC :: nn_msh !: = 1 create a mesh-mask file + REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter + REAL(wp), PUBLIC :: rn_rdt !: time step for the dynamics and tracer + INTEGER , PUBLIC :: nn_closea !: =0 suppress closed sea/lake from the ORCA domain or not (=1) + 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 + + !! 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) + + !! Horizontal grid parameters for domhgr + !! ===================================== + INTEGER :: jphgr_msh !: type of horizontal mesh + ! ! = 0 curvilinear coordinate on the sphere read in coordinate.nc + ! ! = 1 geographical mesh on the sphere with regular grid-spacing + ! ! = 2 f-plane with regular grid-spacing + ! ! = 3 beta-plane with regular grid-spacing + ! ! = 4 Mercator grid with T/U point at the equator + + REAL(wp) :: ppglam0 !: longitude of first raw and column T-point (jphgr_msh = 1) + REAL(wp) :: ppgphi0 !: latitude of first raw and column T-point (jphgr_msh = 1) + ! ! used for Coriolis & Beta parameters (jphgr_msh = 2 or 3) + REAL(wp) :: ppe1_deg !: zonal grid-spacing (degrees) + REAL(wp) :: ppe2_deg !: meridional grid-spacing (degrees) + REAL(wp) :: ppe1_m !: zonal grid-spacing (degrees) + REAL(wp) :: ppe2_m !: meridional grid-spacing (degrees) + + !! Vertical grid parameter for domzgr + !! ================================== + REAL(wp) :: ppsur !: ORCA r4, r2 and r05 coefficients + REAL(wp) :: ppa0 !: (default coefficients) + REAL(wp) :: ppa1 !: + REAL(wp) :: ppkth !: + REAL(wp) :: ppacr !: + ! + ! If both ppa0 ppa1 and ppsur are specified to 0, then + ! they are computed from ppdzmin, pphmax , ppkth, ppacr in dom_zgr + REAL(wp) :: ppdzmin !: Minimum vertical spacing + REAL(wp) :: pphmax !: Maximum depth + ! + LOGICAL :: ldbletanh !: Use/do not use double tanf function for vertical coordinates + REAL(wp) :: ppa2 !: Double tanh function parameters + REAL(wp) :: ppkth2 !: + REAL(wp) :: ppacr2 !: + + ! !! old non-DOCTOR names still used in the model + INTEGER , PUBLIC :: ntopo !: = 0/1 ,compute/read the bathymetry file + REAL(wp), PUBLIC :: e3zps_min !: miminum thickness for partial steps (meters) + REAL(wp), PUBLIC :: e3zps_rat !: minimum thickness ration for partial steps + INTEGER , PUBLIC :: nmsh !: = 1 create a mesh-mask file + 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 :: atfp1 !: asselin time filter coeff. (atfp1= 1-2*atfp) + REAL(wp), PUBLIC :: r2dt !: = 2*rdt except at nit000 (=rdt) if neuler=0 + + !!---------------------------------------------------------------------- + !! space domain parameters + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC :: lzoom = .FALSE. !: zoom flag + LOGICAL, PUBLIC :: lzoom_e = .FALSE. !: East zoom type flag + LOGICAL, PUBLIC :: lzoom_w = .FALSE. !: West zoom type flag + LOGICAL, PUBLIC :: lzoom_s = .FALSE. !: South zoom type flag + LOGICAL, PUBLIC :: lzoom_n = .FALSE. !: North zoom type flag + + ! !!! domain parameters linked to mpp + INTEGER, PUBLIC :: nperio !: type of lateral boundary condition + 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 :: npne, npnw !: index of north east and north west processor + INTEGER, PUBLIC :: npse, npsw !: index of south east and south west processor + INTEGER, PUBLIC :: nbne, nbnw !: logical of north east & north west processor + INTEGER, PUBLIC :: nbse, nbsw !: logical of south east & south west processor + 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 !!bug ==> other solution? + ! ! (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 !!bug ==> other solution? + ! ! (mi0=1 and mi1=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 [1/s] + + !!---------------------------------------------------------------------- + !! vertical coordinate and scale factors + !! --------------------------------------------------------------------- + ! !!* Namelist namzgr : vertical coordinate * + 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 + LOGICAL, PUBLIC :: ln_linssh !: variable grid flag + + ! ! 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 !: u-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) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp , e3wp !: ocean bottom level thickness at T and W points + +!!gm This should be removed from here.... ==>>> only used in domzgr at initialization phase + !! s-coordinate and hybrid z-s-coordinate + !! =----------------======--------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsigt, gsigw !: model level depth coefficient at t-, w-levels (analytic) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsi3w !: model level depth coefficient at w-level (sum of gsigw) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: esigt, esigw !: vertical scale factor coef. at t-, w-levels + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatv , hbatf !: ocean depth at the vertical of v--f + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatt , hbatu !: t--u points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: scosrf, scobot !: ocean surface and bottom topographies + ! ! (if deviating from coordinate surfaces in HYBRID) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hifv , hiff !: interface depth between stretching at v--f + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hift , hifu !: and quasi-uniform spacing t--u points (m) +!!gm end + + !!---------------------------------------------------------------------- + !! masks, bathymetry + !! --------------------------------------------------------------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbathy !: number of ocean level (=0, 1, ... , jpk-1) + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt !: vertical index of the bottom last T- ocean level + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku, mbkv !: vertical index of the bottom last U- and W- ocean level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) + 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 !: first wet T-, U-, V-, F- ocean level (ISF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep !: Iceshelf draft (ISF) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, 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 + + !!---------------------------------------------------------------------- + !! mpp reproducibility + !!---------------------------------------------------------------------- + + + + LOGICAL, PUBLIC, PARAMETER :: lk_mpp_rep = .FALSE. !: agrif flag + + + !!---------------------------------------------------------------------- + !! agrif domain + !!---------------------------------------------------------------------- + + + + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag + + + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2011) + !! $Id: dom_oce.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + !!---------------------------------------------------------------------- + !! 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 dom_oce_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(13) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( mig(jpi), mjg(jpj), nfiimpp(jpni,jpnj), & + & nfipproc(jpni,jpnj), nfilcit(jpni,jpnj), STAT=ierr(1) ) + ! + ALLOCATE( nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & + & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & + & nleit(jpnij) , nlejt(jpnij) , & + & mi0(jpidta) , mi1 (jpidta), mj0(jpjdta) , mj1 (jpjdta), & + & 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) , e3tp (jpi,jpj), e3wp(jpi,jpj) , & + & gsigt (jpk) , gsigw (jpk) , gsi3w(jpk) , & + & esigt (jpk) , esigw (jpk) , STAT=ierr(7) ) + ! + ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) , & + & hbatt (jpi,jpj) , hbatu (jpi,jpj) , & + & scosrf(jpi,jpj) , scobot(jpi,jpj) , & + & hifv (jpi,jpj) , hiff (jpi,jpj) , & + & hift (jpi,jpj) , hifu (jpi,jpj) , STAT=ierr(8) ) + + ALLOCATE( mbathy(jpi,jpj) , bathy (jpi,jpj) , & + & tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & + & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & + & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) + +! (ISF) Allocation of basic array + ALLOCATE( misfdep(jpi,jpj) , risfdep(jpi,jpj), & + & mikt(jpi,jpj), miku(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/V4.0/nemo_sources/tools/DOMAINcfg/src/domain.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domain.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3521e7e4beecf87546e2dd753881dff119d64fb9 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domain.f90 @@ -0,0 +1,506 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_init : initialize the space and time domain + !! dom_nam : read and contral domain namelists + !! dom_ctl : control print for the ocean domain + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! domain: ocean + USE phycst ! physical constants + USE closea ! closed seas + USE domhgr ! domain: set the horizontal mesh + USE domzgr ! domain: set the vertical mesh + USE domstp ! domain: set the time-step + USE dommsk ! domain: set the mask system + USE domwri ! domain: write the meshmask file + USE domvvl ! variable volume + ! + USE in_out_manager ! I/O manager + USE iom ! + USE wrk_nemo ! Memory Allocation + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_init ! called by opa.F90 + + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domain.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_init + !!---------------------------------------------------------------------- + !! *** 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_stp: defined the model time step + !! - dom_wri: create the meshmask file if nmsh=1 + !! - 1D configuration, move Coriolis, u and v at T-point + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: iconf = 0 ! local integers + REAL(wp), POINTER, DIMENSION(:,:) :: z1_hu_0, z1_hv_0 + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_init') + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_init : domain initialization' + WRITE(numout,*) '~~~~~~~~' + ENDIF + ! + ! !== Reference coordinate system ==! + ! + CALL dom_nam ! read namelist ( namrun, namdom ) + CALL dom_clo ! Closed seas and lake + CALL dom_hgr ! Horizontal mesh + CALL dom_zgr ! Vertical mesh and bathymetry + CALL dom_msk ! Masks + ! + ht_0(:,:) = e3t_0(:,:,1) * tmask(:,:,1) ! Reference ocean thickness + hu_0(:,:) = e3u_0(:,:,1) * umask(:,:,1) + hv_0(:,:) = e3v_0(:,:,1) * vmask(:,:,1) + DO jk = 2, 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 ! --- ! + ! + CALL wrk_alloc( jpi,jpj, z1_hu_0, z1_hv_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 ! + ! + CALL wrk_dealloc( jpi,jpj, z1_hu_0, z1_hv_0 ) + ! + ELSE ! time varying : initialize before/now/after variables + ! + CALL dom_vvl_init + ! + ENDIF + ! + CALL cfg_write ! create the configuration file + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_init') + ! + END SUBROUTINE dom_init + + + 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 + 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 + NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, rn_isfhmin, & + & rn_atfp , rn_rdt , nn_closea , ln_crs , jphgr_msh , & + & ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & + & ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & + & ppa2, ppkth2, ppacr2 + + + + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + + 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', lwp ) + + 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', lwp ) + IF(lwm) WRITE ( numond, namrun ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dom_nam : domain initialization through namelist read' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namrun' + WRITE(numout,*) ' job number nn_no = ', nn_no + WRITE(numout,*) ' experiment name for output cn_exp = ', cn_exp + WRITE(numout,*) ' file prefix restart input cn_ocerst_in= ', cn_ocerst_in + WRITE(numout,*) ' restart input directory cn_ocerst_indir= ', cn_ocerst_indir + WRITE(numout,*) ' file prefix restart output cn_ocerst_out= ', cn_ocerst_out + WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', 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 + WRITE(numout,*) ' frequency of output file nn_write = ', nn_write + WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland + WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta + WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber + WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz + WRITE(numout,*) ' IS coupling at the restart step ln_iscpl = ', ln_iscpl + ENDIF + + no = nn_no ! conversion DOCTOR names into model names (this should disappear soon) + cexper = cn_exp + nrstdt = nn_rstctl + nit000 = nn_it000 + nitend = nn_itend + ndate0 = nn_date0 + nleapy = nn_leapy + ninist = nn_istate + nstock = nn_stock + nstocklist = nn_stocklist + nwrite = nn_write + neuler = nn_euler + IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN + WRITE(ctmp1,*) 'ln_rstart =.FALSE., nn_euler is forced to 0 ' + CALL ctl_warn( ctmp1 ) + neuler = 0 + ENDIF + + ! ! control of output frequency + IF ( nstock == 0 .OR. nstock > nitend ) THEN + WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nstock = nitend + ENDIF + IF ( nwrite == 0 ) THEN + WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nwrite = nitend + ENDIF + + + + + 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 + + + + + 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', lwp ) + + ! + 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', lwp ) + IF(lwm) WRITE ( numond, namdom ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namdom : space & time domain' + WRITE(numout,*) ' flag read/compute bathymetry nn_bathy = ', nn_bathy + WRITE(numout,*) ' Depth (if =0 bathy=jpkm1) rn_bathy = ', rn_bathy + WRITE(numout,*) ' min depth of the ocean (>0) or rn_hmin = ', rn_hmin + WRITE(numout,*) ' min number of ocean level (<0) ' + WRITE(numout,*) ' treshold to open the isf cavity rn_isfhmin = ', rn_isfhmin, ' (m)' + WRITE(numout,*) ' minimum thickness of partial rn_e3zps_min = ', rn_e3zps_min, ' (m)' + WRITE(numout,*) ' step level rn_e3zps_rat = ', rn_e3zps_rat + WRITE(numout,*) ' create mesh/mask file(s) nn_msh = ', nn_msh + WRITE(numout,*) ' = 0 no file created ' + WRITE(numout,*) ' = 1 mesh_mask ' + WRITE(numout,*) ' = 2 mesh and mask ' + WRITE(numout,*) ' = 3 mesh_hgr, msh_zgr and mask' + WRITE(numout,*) ' ocean time step rn_rdt = ', rn_rdt + WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp + WRITE(numout,*) ' suppression of closed seas (=0) nn_closea = ', nn_closea + WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' type of horizontal mesh jphgr_msh = ', jphgr_msh + WRITE(numout,*) ' longitude of first raw and column T-point ppglam0 = ', ppglam0 + WRITE(numout,*) ' latitude of first raw and column T-point ppgphi0 = ', ppgphi0 + WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_deg = ', ppe1_deg + WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_deg = ', ppe2_deg + WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_m = ', ppe1_m + WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_m = ', ppe2_m + WRITE(numout,*) ' ORCA r4, r2 and r05 coefficients ppsur = ', ppsur + WRITE(numout,*) ' ppa0 = ', ppa0 + WRITE(numout,*) ' ppa1 = ', ppa1 + WRITE(numout,*) ' ppkth = ', ppkth + WRITE(numout,*) ' ppacr = ', ppacr + WRITE(numout,*) ' Minimum vertical spacing ppdzmin = ', ppdzmin + WRITE(numout,*) ' Maximum depth pphmax = ', pphmax + WRITE(numout,*) ' Use double tanf function for vertical coordinates ldbletanh = ', ldbletanh + WRITE(numout,*) ' Double tanh function parameters ppa2 = ', ppa2 + WRITE(numout,*) ' ppkth2 = ', ppkth2 + WRITE(numout,*) ' ppacr2 = ', ppacr2 + ENDIF + ! + ntopo = nn_bathy ! conversion DOCTOR names into model names (this should disappear soon) + e3zps_min = rn_e3zps_min + e3zps_rat = rn_e3zps_rat + nmsh = nn_msh + atfp = rn_atfp + rdt = rn_rdt + + snc4set%luse = .FALSE. ! No NetCDF 4 case + ! + END SUBROUTINE dom_nam + + + SUBROUTINE dom_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ctl *** + !! + !! ** Purpose : Domain control. + !! + !! ** Method : compute and print extrema of masked scale factors + !!---------------------------------------------------------------------- + INTEGER :: iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 + INTEGER, DIMENSION(2) :: iloc ! + REAL(wp) :: ze1min, ze1max, ze2min, ze2max + !!---------------------------------------------------------------------- + ! + IF(lk_mpp) THEN + CALL mpp_minloc( e1t(:,:), tmask_i(:,:), ze1min, iimi1,ijmi1 ) + CALL mpp_minloc( e2t(:,:), tmask_i(:,:), ze2min, iimi2,ijmi2 ) + CALL mpp_maxloc( e1t(:,:), tmask_i(:,:), ze1max, iima1,ijma1 ) + CALL mpp_maxloc( e2t(:,:), tmask_i(:,:), ze2max, iima2,ijma2 ) + ELSE + ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + + iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + iimi1 = iloc(1) + nimpp - 1 + ijmi1 = iloc(2) + njmpp - 1 + iloc = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + iimi2 = iloc(1) + nimpp - 1 + ijmi2 = iloc(2) + njmpp - 1 + iloc = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) + iima1 = iloc(1) + nimpp - 1 + ijma1 = iloc(2) + njmpp - 1 + iloc = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) + iima2 = iloc(1) + nimpp - 1 + ijma2 = 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, iima1, ijma1 + WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 + WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 + WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 + ENDIF + ! + END SUBROUTINE dom_ctl + + + SUBROUTINE cfg_write + !!---------------------------------------------------------------------- + !! *** ROUTINE cfg_write *** + !! + !! ** Purpose : Create the "domain_cfg" 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 : domain_cfg.nc : domain size, characteristics,horizontal mesh, + !! Coriolis parameter, and vertical scale factors + !! NB: also contains ORCA family information (if cp_cfg = "ORCA") + !! and depths (ln_e3_dep=F) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: izco, izps, isco, icav + INTEGER :: inum ! temprary units for 'domain_cfg.nc' file + 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_cfg.nc" file containing all required configuration information' + IF(lwp) WRITE(numout,*) '~~~~~~~~~' + ! + ! ! ============================= ! + ! ! create 'domain_cfg.nc' file ! + ! ! ============================= ! + ! + clnam = 'domain_cfg' ! filename (configuration information) + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib ) + + ! + ! !== ORCA family specificities ==! + IF( cp_cfg == "ORCA" ) THEN + CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( jp_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 (e + 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 ) + ! + IF(.NOT.ln_e3_dep ) THEN ! depth (t- & w-points) + CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d, ktype = jp_r8 ) ! required only with + CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d, ktype = jp_r8 ) ! the old e3. definition + 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 ) + ENDIF + ! + ! !== ocean top and bottom level ==! + ! + CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points + CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) + DO jj = 1,jpj + DO ji = 1,jpi + z2d (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'bathy_meter' , z2d , ktype = jp_r4 ) + + ! + 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 + ! + ! ! ============================ + ! ! close the files + ! ! ============================ + CALL iom_close( inum ) + ! + END SUBROUTINE cfg_write + + + + !!====================================================================== +END MODULE domain diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domcfg.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domcfg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a233cabbf26be8a5a5d858a773446e3c40a6b4ab --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domcfg.f90 @@ -0,0 +1,199 @@ +MODULE domcfg + !!============================================================================== + !! *** MODULE domcfg *** + !! Ocean initialization : domain configuration initialization + !!============================================================================== + !! History : 1.0 ! 2003-09 (G. Madec) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_cfg : initialize the domain configuration + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_cfg ! called by opa.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.2 , LODYC-IPSL (2009) + !! $Id: domcfg.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_cfg + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_cfg *** + !! + !! ** Purpose : set the domain configuration + !! + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_cfg') + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dom_cfg : set the ocean configuration' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' ocean model configuration used : cp_cfg = ', cp_cfg, ' jp_cfg = ', jp_cfg + ! + WRITE(numout,*) ' global domain lateral boundaries' + ! + IF( jperio == 0 ) WRITE(numout,*) ' jperio= 0, closed' + IF( jperio == 1 ) WRITE(numout,*) ' jperio= 1, cyclic east-west' + IF( jperio == 2 ) WRITE(numout,*) ' jperio= 2, equatorial symmetric' + IF( jperio == 3 ) WRITE(numout,*) ' jperio= 3, north fold with T-point pivot' + IF( jperio == 4 ) WRITE(numout,*) ' jperio= 4, cyclic east-west and north fold with T-point pivot' + IF( jperio == 5 ) WRITE(numout,*) ' jperio= 5, north fold with F-point pivot' + IF( jperio == 6 ) WRITE(numout,*) ' jperio= 6, cyclic east-west and north fold with F-point pivot' + ENDIF + ! + IF( jperio < 0 .OR. jperio > 6 ) CALL ctl_stop( 'jperio is out of range' ) + ! + CALL dom_glo ! global domain versus zoom and/or local domain + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_cfg') + ! + END SUBROUTINE dom_cfg + + + SUBROUTINE dom_glo + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_glo *** + !! + !! ** Purpose : initialization for global domain, zoom and local domain + !! + !! ** Method : + !! + !! ** Action : - mig , mjg : + !! - mi0 , mi1 : + !! - mj0, , mj1 : + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop argument + !!---------------------------------------------------------------------- + ! ! recalculate jpizoom/jpjzoom given lat/lon + ! + ! ! ============== ! + ! ! Local domain ! + ! ! ============== ! + DO ji = 1, jpi ! local domain indices ==> data domain indices + mig(ji) = ji + jpizoom - 1 + nimpp - 1 + END DO + DO jj = 1, jpj + mjg(jj) = jj + jpjzoom - 1 + njmpp - 1 + END DO + ! + ! ! data 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, jpidta + mi0(ji) = MAX( 1, MIN( ji - jpizoom + 1 - nimpp + 1, jpi+1 ) ) + mi1(ji) = MAX( 0, MIN( ji - jpizoom + 1 - nimpp + 1, jpi ) ) + END DO + DO jj = 1, jpjdta + mj0(jj) = MAX( 1, MIN( jj - jpjzoom + 1 - njmpp + 1, jpj+1 ) ) + mj1(jj) = MAX( 0, MIN( jj - jpjzoom + 1 - njmpp + 1, jpj ) ) + END DO + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dom_glo : domain: data / local ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' data input domain : jpidta = ', jpidta, & + & ' jpjdta = ', jpjdta, ' jpkdta = ', jpkdta + WRITE(numout,*) ' global or zoom domain: jpiglo = ', jpiglo, & + & ' jpjglo = ', jpjglo, ' jpk = ', jpk + WRITE(numout,*) ' local domain : jpi = ', jpi , & + & ' jpj = ', jpj , ' jpk = ', jpk + WRITE(numout,*) + WRITE(numout,*) ' south-west indices jpizoom = ', jpizoom, & + & ' jpjzoom = ', jpjzoom + IF( nn_print >= 1 ) THEN + WRITE(numout,*) + WRITE(numout,*) ' conversion local ==> data i-index domain' + WRITE(numout,25) (mig(ji),ji = 1,jpi) + WRITE(numout,*) + WRITE(numout,*) ' conversion data ==> local i-index domain' + WRITE(numout,*) ' starting index' + WRITE(numout,25) (mi0(ji),ji = 1,jpidta) + WRITE(numout,*) ' ending index' + WRITE(numout,25) (mi1(ji),ji = 1,jpidta) + WRITE(numout,*) + WRITE(numout,*) ' conversion local ==> data j-index domain' + WRITE(numout,25) (mjg(jj),jj = 1,jpj) + WRITE(numout,*) + WRITE(numout,*) ' conversion data ==> local j-index domain' + WRITE(numout,*) ' starting index' + WRITE(numout,25) (mj0(jj),jj = 1,jpjdta) + WRITE(numout,*) ' ending index' + WRITE(numout,25) (mj1(jj),jj = 1,jpjdta) + ENDIF + ENDIF + 25 FORMAT( 100(10x,19i4,/) ) + + ! ! ============== ! + ! ! Zoom domain ! + ! ! ============== ! + ! ! zoom control + IF( jpiglo + jpizoom - 1 > jpidta .OR. & + jpjglo + jpjzoom - 1 > jpjdta ) & + & CALL ctl_stop( ' global or zoom domain exceed the data domain ! ' ) + + ! ! set zoom flag + IF( jpiglo < jpidta .OR. jpjglo < jpjdta ) lzoom = .TRUE. + + ! ! set zoom type flags + IF( lzoom .AND. jpizoom /= 1 ) lzoom_w = .TRUE. ! + IF( lzoom .AND. jpjzoom /= 1 ) lzoom_s = .TRUE. + IF( lzoom .AND. jpiglo + jpizoom -1 /= jpidta ) lzoom_e = .TRUE. + IF( lzoom .AND. jpjglo + jpjzoom -1 /= jpjdta ) lzoom_n = .TRUE. + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' zoom flags : ' + WRITE(numout,*) ' lzoom = ', lzoom , ' (T = zoom, F = global )' + WRITE(numout,*) ' lzoom_e = ', lzoom_e, ' (T = forced closed east boundary)' + WRITE(numout,*) ' lzoom_w = ', lzoom_w, ' (T = forced closed west boundary)' + WRITE(numout,*) ' lzoom_s = ', lzoom_s, ' (T = forced closed South boundary)' + WRITE(numout,*) ' lzoom_n = ', lzoom_n, ' (T = forced closed North boundary)' + ENDIF + IF( ( lzoom_e .OR. lzoom_w ) .AND. ( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) ) & + & CALL ctl_stop( ' Your zoom choice is inconsistent with east-west cyclic boundary condition' ) + IF( lzoom_n .AND. ( 3 <= jperio .AND. jperio <= 6 ) ) & + & CALL ctl_stop( ' Your zoom choice is inconsistent with North fold boundary condition' ) + + ! ! Pre-defined arctic/antarctic zoom of ORCA configuration flag + IF( cp_cfg == "orca" ) THEN + SELECT CASE ( jp_cfg ) + CASE ( 2 ) ! ORCA_R2 configuration + IF( cp_cfz == "arctic" .AND. jpiglo == 142 .AND. jpjglo == 53 .AND. & + & jpizoom == 21 .AND. jpjzoom == 97 ) THEN + IF(lwp) WRITE(numout,*) ' ORCA configuration: arctic zoom ' + ENDIF + IF( cp_cfz == "antarctic" .AND. jpiglo == jpidta .AND. jpjglo == 50 .AND. & + & jpizoom == 1 .AND. jpjzoom == 1 ) THEN + IF(lwp) WRITE(numout,*) ' ORCA configuration: antarctic zoom ' + ENDIF + ! + CASE ( 05 ) ! ORCA_R05 configuration + IF( cp_cfz == "arctic" .AND. jpiglo == 562 .AND. jpjglo == 202 .AND. & + & jpizoom == 81 .AND. jpjzoom == 301 ) THEN + IF(lwp) WRITE(numout,*) ' ORCA configuration: arctic zoom ' + ENDIF + IF( cp_cfz == "antarctic" .AND. jpiglo == jpidta .AND. jpjglo == 187 .AND. & + & jpizoom == 1 .AND. jpjzoom == 1 ) THEN + IF(lwp) WRITE(numout,*) ' ORCA configuration: antarctic zoom ' + ENDIF + END SELECT + ! + ENDIF + ! + END SUBROUTINE dom_glo + + !!====================================================================== +END MODULE domcfg diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domhgr.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domhgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5142c4b43bbe7ec58dac3bbb563c8ee8b387691c --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domhgr.f90 @@ -0,0 +1,498 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_hgr : initialize the horizontal mesh + !! hgr_read : read "coordinate" NetCDF file + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE domwri ! write 'meshmask.nc' & 'coordinate_e1e2u_v.nc' files + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + REAL(wp) :: glam0, gphi0 ! variables corresponding to parameters ppglam0 ppgphi0 set in par_oce + + PUBLIC dom_hgr ! called by domain.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: domhgr.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_hgr + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_hgr *** + !! + !! ** Purpose : Compute the geographical position (in degre) of the + !! model grid-points, the horizontal scale factors (in meters) and + !! the Coriolis factor (in s-1). + !! + !! ** Method : The geographical position of the model grid-points is + !! defined from analytical functions, fslam and fsphi, the deriva- + !! tives of which gives the horizontal scale factors e1,e2. + !! Defining two function fslam and fsphi and their derivatives in + !! the two horizontal directions (fse1 and fse2), the model grid- + !! point position and scale factors are given by: + !! t-point: + !! glamt(i,j) = fslam(i ,j ) e1t(i,j) = fse1(i ,j ) + !! gphit(i,j) = fsphi(i ,j ) e2t(i,j) = fse2(i ,j ) + !! u-point: + !! glamu(i,j) = fslam(i+1/2,j ) e1u(i,j) = fse1(i+1/2,j ) + !! gphiu(i,j) = fsphi(i+1/2,j ) e2u(i,j) = fse2(i+1/2,j ) + !! v-point: + !! glamv(i,j) = fslam(i ,j+1/2) e1v(i,j) = fse1(i ,j+1/2) + !! gphiv(i,j) = fsphi(i ,j+1/2) e2v(i,j) = fse2(i ,j+1/2) + !! f-point: + !! glamf(i,j) = fslam(i+1/2,j+1/2) e1f(i,j) = fse1(i+1/2,j+1/2) + !! gphif(i,j) = fsphi(i+1/2,j+1/2) e2f(i,j) = fse2(i+1/2,j+1/2) + !! Where fse1 and fse2 are defined by: + !! fse1(i,j) = ra * rad * SQRT( (cos(phi) di(fslam))**2 + !! + di(fsphi) **2 )(i,j) + !! fse2(i,j) = ra * rad * SQRT( (cos(phi) dj(fslam))**2 + !! + dj(fsphi) **2 )(i,j) + !! + !! The coriolis factor is given at z-point by: + !! ff = 2.*omega*sin(gphif) (in s-1) + !! + !! This routine is given as an example, it must be modified + !! following the user s desiderata. nevertheless, the output as + !! well as the way to compute the model grid-point position and + !! horizontal scale factors must be respected in order to insure + !! second order accuracy schemes. + !! + !! N.B. If the domain is periodic, verify that scale factors are also + !! periodic, and the coriolis term again. + !! + !! ** Action : - define glamt, glamu, glamv, glamf: longitude of t-, + !! u-, v- and f-points (in degre) + !! - define gphit, gphiu, gphiv, gphit: latitude of t-, + !! u-, v- and f-points (in degre) + !! define e1t, e2t, e1u, e2u, e1v, e2v, e1f, e2f: horizontal + !! scale factors (in meters) at t-, u-, v-, and f-points. + !! define ff: coriolis factor at f-point + !! + !! References : Marti, Madec and Delecluse, 1992, JGR + !! Madec, Imbard, 1996, Clim. Dyn. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers + INTEGER :: ijeq ! index of equator T point (used in case 4) + REAL(wp) :: zti, zui, zvi, zfi ! local scalars + REAL(wp) :: ztj, zuj, zvj, zfj ! - - + REAL(wp) :: zphi0, zbeta, znorme ! + REAL(wp) :: zarg, zf0, zminff, zmaxff + REAL(wp) :: zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg + REAL(wp) :: zphi1, zsin_alpha, zim05, zjm05 + INTEGER :: isrow ! index for ORCA1 starting row + INTEGER :: ie1e2u_v ! fag for u- & v-surface read in coordinate file or not + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) 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,*) '~~~~~~~ type of horizontal mesh jphgr_msh = ', jphgr_msh + WRITE(numout,*) ' position of the first row and ppglam0 = ', ppglam0 + WRITE(numout,*) ' column grid-point (degrees) ppgphi0 = ', ppgphi0 + WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_deg = ', ppe1_deg + WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_deg = ', ppe2_deg + WRITE(numout,*) ' zonal grid-spacing (meters) ppe1_m = ', ppe1_m + WRITE(numout,*) ' meridional grid-spacing (meters) ppe2_m = ', ppe2_m + ENDIF + ! + ! + SELECT CASE( jphgr_msh ) ! type of horizontal mesh + ! + CASE ( 0 ) !== read in coordinate.nc file ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' curvilinear coordinate on the sphere read in "coordinate" file' + ! + ie1e2u_v = 0 ! set to unread e1e2u and e1e2v + ! + CALL hgr_read( ie1e2u_v ) ! read the coordinate.nc file + ! + IF( ie1e2u_v == 0 ) THEN ! e1e2u and e1e2v have not been read: compute them + ! ! e2u and e1v does not include a reduction in some strait: apply reduction + e1e2u (:,:) = e1u(:,:) * e2u(:,:) + e1e2v (:,:) = e1v(:,:) * e2v(:,:) + ENDIF + ! + CASE ( 1 ) !== geographical mesh on the sphere with regular (in degree) grid-spacing ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' geographical mesh on the sphere with regular grid-spacing' + IF(lwp) WRITE(numout,*) ' given by ppe1_deg and ppe2_deg' + ! + DO jj = 1, jpj + DO ji = 1, jpi + zti = REAL( ji - 1 + nimpp - 1 ) ; ztj = REAL( jj - 1 + njmpp - 1 ) + zui = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zuj = REAL( jj - 1 + njmpp - 1 ) + zvi = REAL( ji - 1 + nimpp - 1 ) ; zvj = REAL( jj - 1 + njmpp - 1 ) + 0.5 + zfi = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zfj = REAL( jj - 1 + njmpp - 1 ) + 0.5 + ! Longitude + glamt(ji,jj) = ppglam0 + ppe1_deg * zti + glamu(ji,jj) = ppglam0 + ppe1_deg * zui + glamv(ji,jj) = ppglam0 + ppe1_deg * zvi + glamf(ji,jj) = ppglam0 + ppe1_deg * zfi + ! Latitude + gphit(ji,jj) = ppgphi0 + ppe2_deg * ztj + gphiu(ji,jj) = ppgphi0 + ppe2_deg * zuj + gphiv(ji,jj) = ppgphi0 + ppe2_deg * zvj + gphif(ji,jj) = ppgphi0 + ppe2_deg * zfj + ! e1 + e1t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg + e1u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg + e1v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg + e1f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg + ! e2 + e2t(ji,jj) = ra * rad * ppe2_deg + e2u(ji,jj) = ra * rad * ppe2_deg + e2v(ji,jj) = ra * rad * ppe2_deg + e2f(ji,jj) = ra * rad * ppe2_deg + END DO + END DO + ! + CASE ( 2:3 ) !== f- or beta-plane with regular grid-spacing ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' f- or beta-plane with regular grid-spacing' + IF(lwp) WRITE(numout,*) ' given by ppe1_m and ppe2_m' + ! + ! Position coordinates (in kilometers) + ! ========== + glam0 = 0._wp + gphi0 = - ppe2_m * 1.e-3 + ! + DO jj = 1, jpj + DO ji = 1, jpi + glamt(ji,jj) = glam0 + ppe1_m * 1.e-3 * ( REAL( ji - 1 + nimpp - 1 ) ) + glamu(ji,jj) = glam0 + ppe1_m * 1.e-3 * ( REAL( ji - 1 + nimpp - 1 ) + 0.5 ) + glamv(ji,jj) = glamt(ji,jj) + glamf(ji,jj) = glamu(ji,jj) + ! + gphit(ji,jj) = gphi0 + ppe2_m * 1.e-3 * ( REAL( jj - 1 + njmpp - 1 ) ) + gphiu(ji,jj) = gphit(ji,jj) + gphiv(ji,jj) = gphi0 + ppe2_m * 1.e-3 * ( REAL( jj - 1 + njmpp - 1 ) + 0.5 ) + gphif(ji,jj) = gphiv(ji,jj) + END DO + END DO + ! + ! Horizontal scale factors (in meters) + ! ====== + e1t(:,:) = ppe1_m ; e2t(:,:) = ppe2_m + e1u(:,:) = ppe1_m ; e2u(:,:) = ppe2_m + e1v(:,:) = ppe1_m ; e2v(:,:) = ppe2_m + e1f(:,:) = ppe1_m ; e2f(:,:) = ppe2_m + ! + CASE ( 4 ) !== geographical mesh on the sphere, isotropic MERCATOR type ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' geographical mesh on the sphere, MERCATOR type' + IF(lwp) WRITE(numout,*) ' longitudinal/latitudinal spacing given by ppe1_deg' + IF ( ppgphi0 == -90 ) CALL ctl_stop( ' Mercator grid cannot start at south pole !!!! ' ) + ! + ! Find index corresponding to the equator, given the grid spacing e1_deg + ! and the (approximate) southern latitude ppgphi0. + ! This way we ensure that the equator is at a "T / U" point, when in the domain. + ! The formula should work even if the equator is outside the domain. + zarg = rpi / 4. - rpi / 180. * ppgphi0 / 2. + ijeq = ABS( 180./rpi * LOG( COS( zarg ) / SIN( zarg ) ) / ppe1_deg ) + IF( ppgphi0 > 0 ) ijeq = -ijeq + ! + IF(lwp) WRITE(numout,*) ' Index of the equator on the MERCATOR grid:', ijeq + ! + DO jj = 1, jpj + DO ji = 1, jpi + zti = REAL( ji - 1 + nimpp - 1 ) ; ztj = REAL( jj - ijeq + njmpp - 1 ) + zui = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zuj = REAL( jj - ijeq + njmpp - 1 ) + zvi = REAL( ji - 1 + nimpp - 1 ) ; zvj = REAL( jj - ijeq + njmpp - 1 ) + 0.5 + zfi = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zfj = REAL( jj - ijeq + njmpp - 1 ) + 0.5 + ! Longitude + glamt(ji,jj) = ppglam0 + ppe1_deg * zti + glamu(ji,jj) = ppglam0 + ppe1_deg * zui + glamv(ji,jj) = ppglam0 + ppe1_deg * zvi + glamf(ji,jj) = ppglam0 + ppe1_deg * zfi + ! Latitude + gphit(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* ztj ) ) + gphiu(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zuj ) ) + gphiv(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zvj ) ) + gphif(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zfj ) ) + ! e1 + e1t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg + e1u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg + e1v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg + e1f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg + ! e2 + e2t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg + e2u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg + e2v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg + e2f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg + END DO + END DO + ! + CASE ( 5 ) !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' beta-plane with regular grid-spacing and rotated domain (GYRE configuration)' + IF(lwp) WRITE(numout,*) ' given by ppe1_m and ppe2_m' + ! + ! Position coordinates (in kilometers) + ! ========== + ! + ! angle 45deg and ze1=106.e+3 / jp_cfg forced -> zlam1 = -85deg, zphi1 = 29degN + zlam1 = -85._wp + zphi1 = 29._wp + ! resolution in meters + ze1 = 106000. / REAL( jp_cfg , wp ) + ! benchmark: forced the resolution to be about 100 km + IF( nbench /= 0 ) ze1 = 106000._wp + zsin_alpha = - SQRT( 2._wp ) * 0.5_wp + zcos_alpha = SQRT( 2._wp ) * 0.5_wp + ze1deg = ze1 / (ra * rad) + IF( nbench /= 0 ) ze1deg = ze1deg / REAL( jp_cfg , wp ) ! benchmark: keep the lat/+lon + ! ! at the right jp_cfg resolution + glam0 = zlam1 + zcos_alpha * ze1deg * REAL( jpjglo-2 , wp ) + gphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp ) + ! + IF( nprint==1 .AND. lwp ) THEN + WRITE(numout,*) ' ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha + WRITE(numout,*) ' ze1deg', ze1deg, 'glam0', glam0, 'gphi0', gphi0 + 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 + ! + glamf(ji,jj) = glam0 + zim1 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + gphif(ji,jj) = gphi0 - zim1 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + ! + glamt(ji,jj) = glam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + gphit(ji,jj) = gphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + glamu(ji,jj) = glam0 + zim1 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + gphiu(ji,jj) = gphi0 - zim1 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + glamv(ji,jj) = glam0 + zim05 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + gphiv(ji,jj) = gphi0 - zim05 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + END DO + END DO + ! + ! Horizontal scale factors (in meters) + ! ====== + e1t(:,:) = ze1 ; e2t(:,:) = ze1 + e1u(:,:) = ze1 ; e2u(:,:) = ze1 + e1v(:,:) = ze1 ; e2v(:,:) = ze1 + e1f(:,:) = ze1 ; e2f(:,:) = ze1 + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for jphgr_msh = ', jphgr_msh + CALL ctl_stop( ctmp1 ) + ! + END SELECT + + ! 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( jphgr_msh /= 0 ) THEN ! e1e2u and e1e2v have not been set: compute them + e1e2u (:,:) = e1u(:,:) * e2u(:,:) + e1e2v (:,:) = e1v(:,:) * e2v(:,:) + ENDIF + r1_e1e2u(:,:) = 1._wp / e1e2u(:,:) ! compute their invert in both cases + r1_e1e2v(:,:) = 1._wp / e1e2v(:,:) + ! + e2_e1u(:,:) = e2u(:,:) / e1u(:,:) + e1_e2v(:,:) = e1v(:,:) / e2v(:,:) + + IF( lwp .AND. nn_print >=1 .AND. .NOT.ln_rstart ) THEN ! Control print : Grid informations (if not restart) + WRITE(numout,*) + WRITE(numout,*) ' longitude and e1 scale factors' + WRITE(numout,*) ' ------------------------------' + WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1), & + glamv(ji,1), glamf(ji,1), & + e1t(ji,1), e1u(ji,1), & + e1v(ji,1), e1f(ji,1), ji = 1, jpi,10) +9300 FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x, & + f19.10, 1x, f19.10, 1x, f19.10, 1x, f19.10 ) + ! + WRITE(numout,*) + WRITE(numout,*) ' latitude and e2 scale factors' + WRITE(numout,*) ' -----------------------------' + WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj), & + & gphiv(1,jj), gphif(1,jj), & + & e2t (1,jj), e2u (1,jj), & + & e2v (1,jj), e2f (1,jj), jj = 1, jpj, 10 ) + ENDIF + + + ! ================= ! + ! Coriolis factor ! + ! ================= ! + + SELECT CASE( jphgr_msh ) ! type of horizontal mesh + ! + CASE ( 0, 1, 4 ) ! mesh on the sphere + ! + ff_f(:,:) = 2. * omega * SIN( rad * gphif(:,:) ) + ff_t(:,:) = 2. * omega * SIN( rad * gphit(:,:) ) ! - - - at t-point + ! + CASE ( 2 ) ! f-plane at ppgphi0 + ! + ff_f(:,:) = 2. * omega * SIN( rad * ppgphi0 ) + ff_t(:,:) = 2. * omega * SIN( rad * ppgphi0 ) + ! + IF(lwp) WRITE(numout,*) ' f-plane: Coriolis parameter = constant = ', ff_f(1,1) + ! + CASE ( 3 ) ! beta-plane + ! + zbeta = 2. * omega * COS( rad * ppgphi0 ) / ra ! beta at latitude ppgphi0 + zphi0 = ppgphi0 - REAL( jpjglo/2) * ppe2_m / ( ra * rad ) ! latitude of the first row F-points + ! + zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south + ! + ff_f(:,:) = ( zf0 + zbeta * gphif(:,:) * 1.e+3 ) ! f = f0 +beta* y ( y=0 at south) + ff_t(:,:) = ( zf0 + zbeta * gphit(:,:) * 1.e+3 ) ! f = f0 +beta* y ( y=0 at south) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Beta-plane: Beta parameter = constant = ', ff_f(nldi,nldj) + WRITE(numout,*) ' Coriolis parameter varies from ', ff_f(nldi,nldj),' to ', ff_f(nldi,nlej) + ENDIF + IF( lk_mpp ) THEN + zminff=ff_f(nldi,nldj) + zmaxff=ff_f(nldi,nlej) + CALL mpp_min( zminff ) ! min over the global domain + CALL mpp_max( zmaxff ) ! max over the global domain + IF(lwp) WRITE(numout,*) ' Coriolis parameter varies globally from ', zminff,' to ', zmaxff + END IF + ! + CASE ( 5 ) ! beta-plane and rotated domain (gyre configuration) + ! + zbeta = 2. * omega * COS( rad * ppgphi0 ) / ra ! beta at latitude ppgphi0 + zphi0 = 15._wp ! latitude of the first row F-points + zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south + ! + ff_f(:,:) = ( zf0 + zbeta * ABS( gphif(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + ff_t(:,:) = ( zf0 + zbeta * ABS( gphit(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Beta-plane and rotated domain : ' + WRITE(numout,*) ' Coriolis parameter varies in this processor from ', ff_f(nldi,nldj),' to ', ff_f(nldi,nlej) + ENDIF + ! + IF( lk_mpp ) THEN + zminff=ff_f(nldi,nldj) + zmaxff=ff_f(nldi,nlej) + CALL mpp_min( zminff ) ! min over the global domain + CALL mpp_max( zmaxff ) ! max over the global domain + IF(lwp) WRITE(numout,*) ' Coriolis parameter varies globally from ', zminff,' to ', zmaxff + END IF + ! + END SELECT + + + ! Control of domain for symetrical condition + ! ------------------------------------------ + ! The equator line must be the latitude coordinate axe + + IF( nperio == 2 ) THEN + znorme = SQRT( SUM( gphiu(:,2) * gphiu(:,2) ) ) / REAL( jpi ) + IF( znorme > 1.e-13 ) CALL ctl_stop( ' ===>>>> : symmetrical condition: rerun with good equator line' ) + ENDIF + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_hgr') + ! + END SUBROUTINE dom_hgr + + + SUBROUTINE hgr_read( ke1e2u_v ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hgr_read *** + !! + !! ** Purpose : Read a coordinate file in NetCDF format using IOM + !! + !!---------------------------------------------------------------------- + USE iom + !! + INTEGER, INTENT( inout ) :: ke1e2u_v ! fag: e1e2u & e1e2v read in coordinate file (=1) or not (=0) + ! + INTEGER :: inum ! temporary logical unit + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'hgr_read : read the horizontal coordinates' + WRITE(numout,*) '~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk + ENDIF + ! + CALL iom_open( 'coordinates', inum ) + ! + CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamu', glamu, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamv', glamv, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamf', glamf, lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'gphit', gphit, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphiu', gphiu, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphiv', gphiv, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphif', gphif, lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'e1t' , e1t , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1u' , e1u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1v' , e1v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1f' , e1f , lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'e2t' , e2t , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2u' , e2u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2v' , e2v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2f' , e2f , lrowattr=ln_use_jattr ) + ! + IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) 'hgr_read : e1e2u & e1e2v read in coordinates file' + CALL iom_get( inum, jpdom_data, 'e1e2u' , e1e2u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1e2v' , e1e2v , 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/V4.0/nemo_sources/tools/DOMAINcfg/src/dommsk.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/dommsk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2bd6506e3edca90dac1b30cd8c825da6ffc1ed6f --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/dommsk.f90 @@ -0,0 +1,369 @@ +MODULE dommsk + !!====================================================================== + !! *** MODULE dommsk *** + !! Ocean initialization : domain land/sea mask + !!====================================================================== + !! History : OPA ! 1987-07 (G. Madec) Original code + !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon) + !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays + !! - ! 1996-05 (G. Madec) mask computed from tmask + !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F + !! 8.1 ! 1997-07 (G. Madec) modification of mbathy and fmask + !! - ! 1998-05 (G. Roullet) free surface + !! 8.2 ! 2000-03 (G. Madec) no slip accurate + !! - ! 2001-09 (J.-M. Molines) Open boundaries + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_msk : compute land/ocean mask + !!---------------------------------------------------------------------- + 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 ! + USE wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_msk ! routine called by inidom.F90 + + ! !!* Namelist namlbc : lateral boundary condition * + REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity + LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition + ! with analytical eqs. + + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.2 , LODYC-IPSL (2009) + !! $Id: dommsk.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_msk + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori- + !! zontal velocity points (u & v), vorticity points (f) points. + !! + !! ** Method : The ocean/land mask is computed from the basin bathy- + !! metry in level (mbathy) which is defined or read in dommba. + !! mbathy equals 0 over continental T-point + !! and the number of ocean level over the ocean. + !! + !! At a given position (ji,jj,jk) the ocean/land mask is given by: + !! t-point : 0. IF mbathy( ji ,jj) =< 0 + !! 1. IF mbathy( ji ,jj) >= jk + !! u-point : 0. IF mbathy( ji ,jj) or mbathy(ji+1, jj ) =< 0 + !! 1. IF mbathy( ji ,jj) and mbathy(ji+1, jj ) >= jk. + !! v-point : 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) =< 0 + !! 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) >= jk. + !! f-point : 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) + !! or mbathy(ji+1,jj) or mbathy(ji+1,jj+1) =< 0 + !! 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) + !! and mbathy(ji+1,jj) and mbathy(ji+1,jj+1) >= jk. + !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated + !! rows/lines due to cyclic or North Fold boundaries as well + !! as MPP halos. + !! + !! The lateral friction is set through the value of fmask along + !! the coast and topography. This value is defined by rn_shlat, a + !! namelist parameter: + !! rn_shlat = 0, free slip (no shear along the coast) + !! rn_shlat = 2, no slip (specified zero velocity at the coast) + !! 0 < rn_shlat < 2, partial slip | non-linear velocity profile + !! 2 < rn_shlat, strong slip | in the lateral boundary layer + !! + !! N.B. If nperio not equal to 0, the land/ocean mask arrays + !! are defined with the proper value at lateral domain boundaries. + !! + !! In case of open boundaries (lk_bdy=T): + !! - tmask is set to 1 on the points to be computed bay the open + !! boundaries routines. + !! + !! ** Action : tmask : land/ocean mask at t-point (=0. or 1.) + !! umask : land/ocean mask at u-point (=0. or 1.) + !! vmask : land/ocean mask at v-point (=0. or 1.) + !! fmask : land/ocean mask at f-point (=0. or 1.) + !! =rn_shlat along lateral boundaries + !! tmask_i : interior ocean mask + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iif, iil, ii0, ii1, ii ! local integers + INTEGER :: ijf, ijl, ij0, ij1 ! - - + INTEGER :: ios + INTEGER :: isrow ! index for ORCA1 starting row + INTEGER , POINTER, DIMENSION(:,:) :: imsk + REAL(wp), POINTER, DIMENSION(:,:) :: zwf + !! + NAMELIST/namlbc/ rn_shlat, ln_vorlat + !!--------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_msk') + ! + CALL wrk_alloc( jpi, jpj, imsk ) + CALL wrk_alloc( jpi, jpj, zwf ) + ! + 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 ) + + 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 ) + IF(lwm) WRITE ( numond, namlbc ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dommsk : ocean mask ' + WRITE(numout,*) '~~~~~~' + WRITE(numout,*) ' Namelist namlbc' + WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat + WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat + ENDIF + + IF ( 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 + WRITE(ctmp1,*) ' rn_shlat is negative = ', rn_shlat + CALL ctl_stop( ctmp1 ) + ENDIF + + ! 1. Ocean/land mask at t-point (computed from mbathy) + ! ----------------------------- + ! N.B. tmask has already the right boundary conditions since mbathy is ok + ! + tmask(:,:,:) = 0._wp + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( REAL( mbathy(ji,jj) - jk, wp ) + 0.1_wp >= 0._wp ) tmask(ji,jj,jk) = 1._wp + END DO + END DO + END DO + + ! (ISF) define barotropic mask and mask the ice shelf point + ssmask(:,:)=tmask(:,:,1) ! at this stage ice shelf is not masked + + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( REAL( misfdep(ji,jj) - jk, wp ) - 0.1_wp >= 0._wp ) THEN + tmask(ji,jj,jk) = 0._wp + END IF + END DO + END DO + END DO + + ! Interior domain mask (used for global sum) + ! -------------------- + tmask_i(:,:) = ssmask(:,:) ! (ISH) tmask_i = 1 even on the ice shelf + + tmask_h(:,:) = 1._wp ! 0 on the halo and 1 elsewhere + iif = jpreci ! ??? + iil = nlci - jpreci + 1 + ijf = jprecj ! ??? + ijl = nlcj - jprecj + 1 + + tmask_h( 1 :iif, : ) = 0._wp ! first columns + tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) + tmask_h( : , 1 :ijf) = 0._wp ! first rows + tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) + + ! north fold mask + ! --------------- + tpol(1:jpiglo) = 1._wp + fpol(1:jpiglo) = 1._wp + IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot + tpol(jpiglo/2+1:jpiglo) = 0._wp + fpol( 1 :jpiglo) = 0._wp + IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row + DO ji = iif+1, iil-1 + tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) + END DO + ENDIF + ENDIF + + tmask_i(:,:) = tmask_i(:,:) * tmask_h(:,:) + + IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot + tpol( 1 :jpiglo) = 0._wp + fpol(jpiglo/2+1:jpiglo) = 0._wp + ENDIF + + ! 2. Ocean/land mask at u-, v-, and z-points (computed from tmask) + ! ------------------------------------------- + DO jk = 1, jpk + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector loop + umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) + vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) + END DO + DO ji = 1, jpim1 ! NO vector opt. + fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & + & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) + END DO + END DO + END DO + ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet cell at u point + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector loop + ssumask(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:))) + ssvmask(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:))) + END DO + DO ji = 1, jpim1 ! NO vector opt. + ssfmask(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) & + & * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) + 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( ssumask, 'U', 1._wp ) ! Lateral boundary conditions + CALL lbc_lnk( ssvmask, 'V', 1._wp ) + CALL lbc_lnk( ssfmask, 'F', 1._wp ) + + ! 3. Ocean/land mask at wu-, wv- and w points + !---------------------------------------------- + wmask (:,:,1) = tmask(:,:,1) ! surface + wumask(:,:,1) = umask(:,:,1) + wvmask(:,:,1) = vmask(:,:,1) + DO jk = 2, jpk ! interior values + wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) + wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) + wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) + END DO + + ! Lateral boundary conditions on velocity (modify fmask) + ! --------------------------------------- + DO jk = 1, jpk + zwf(:,:) = fmask(:,:,jk) + DO jj = 2, jpjm1 + DO ji = 2, 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 + END DO + END DO + 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) ) ) + 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) ) ) + 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) ) ) + 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) ) ) + ENDIF + END DO + END DO + ! + IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA_R2 configuration + ! ! Increased lateral friction near of some straits + ! ! Gibraltar strait : partial slip (fmask=0.5) + ij0 = 101 ; ij1 = 101 + ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ij0 = 102 ; ij1 = 102 + ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ! + ! ! Bab el Mandeb : partial slip (fmask=1) + ij0 = 87 ; ij1 = 88 + ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ij0 = 88 ; ij1 = 88 + ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ! + ! ! Danish straits : strong slip (fmask > 2) +! We keep this as an example but it is instable in this case +! ij0 = 115 ; ij1 = 115 +! ii0 = 145 ; ii1 = 146 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp +! ij0 = 116 ; ij1 = 116 +! ii0 = 145 ; ii1 = 146 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp + ! + ENDIF + ! + IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration + ! ! Increased lateral friction near of some straits + ! This dirty section will be suppressed by simplification process: + ! all this will come back in input files + ! 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 ; fmask( 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 ; fmask( 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 ; fmask( 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 ; fmask( 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 ; fmask( 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 ; fmask( 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 ; fmask( 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 ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + ENDIF + ! + CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) + ! + CALL wrk_dealloc( jpi, jpj, imsk ) + CALL wrk_dealloc( jpi, jpj, zwf ) + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_msk') + ! + END SUBROUTINE dom_msk + + !!====================================================================== +END MODULE dommsk diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domngb.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domngb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f6d5707f7d157ddbc515890d862802cc3c22089e --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domngb.f90 @@ -0,0 +1,92 @@ +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 + USE wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_ngb ! routine called in iom.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domngb.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./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), POINTER, DIMENSION(:,:) :: zglam, zgphi, zmask, zdist + !!-------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_ngb') + ! + CALL wrk_alloc( 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 + + IF (jphgr_msh /= 2 .AND. jphgr_msh /= 3) THEN + 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 + ELSE + zglam(:,:) = zglam(:,:) - plon + END IF + + zgphi(:,:) = zgphi(:,:) - plat + zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) + + IF( lk_mpp ) THEN + CALL mpp_minloc( zdist(:,:), zmask, zmini, kii, kjj) + ELSE + iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) + kii = iloc(1) + nimpp - 1 + kjj = iloc(2) + njmpp - 1 + ENDIF + ! + CALL wrk_dealloc( jpi,jpj, zglam, zgphi, zmask, zdist ) + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_ngb') + ! + END SUBROUTINE dom_ngb + + !!====================================================================== +END MODULE domngb diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domstp.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domstp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4cbb932f519221213df4e8755ca448d4188ca1e2 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domstp.f90 @@ -0,0 +1,71 @@ +MODULE domstp + !!============================================================================== + !! *** MODULE domstp *** + !! Ocean initialization : time domain + !!============================================================================== + + !!---------------------------------------------------------------------- + !! dom_stp : ocean time domain initialization + !!---------------------------------------------------------------------- + !! History : OPA ! 1990-10 (O. Marti) Original code + !! ! 1996-01 (G. Madec) terrain following coordinates + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_stp ! routine called by inidom.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domstp.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_stp + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_stp *** + !! + !! ** Purpose : Intialize ocean time step for the run + !! + !! ** Method : - Initialization of a coef. use in the Asselin time + !! filter: atfp1 = 1 - 2 * atfp where atfp is the Asselin time + !! filter parameter read in namelist + !! - Model time step: + !! synchronous time intergration. + !! There is one time step only, defined by: rdt for dynamics and + !! tracer,wind stress, surface heat and salt fluxes + !! + !! ** Action : [REMOVED - rdttra: vertical profile of tracer time step] + !! - atfp1 : = 1 - 2*atfp + !! + !! References : Bryan, K., 1984, J. Phys. Oceanogr., 14, 666-673. + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indice + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_stp : time stepping setting' + WRITE(numout,*) '~~~~~~~' + ENDIF + + ! 0. Asselin Time filter + ! ---------------------- + + atfp1 = 1. - 2. * atfp + + IF(lwp) WRITE(numout,*)' synchronous time stepping' + IF(lwp) WRITE(numout,*)' dynamics and tracer time step = ', rdt/3600., ' hours' + + + END SUBROUTINE dom_stp + + !!====================================================================== +END MODULE domstp diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domvvl.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domvvl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6d15eb8b701714b6ee236a9a9e20cc0e49c1f4e8 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domvvl.f90 @@ -0,0 +1,438 @@ +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 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 wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_vvl_init ! called by domain.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 + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO-Consortium (2015) + !! $Id: domvvl.F90 6351 2016-02-24 18:50:11Z cetlod $ + !! Software governed by the CeCILL licence (./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 ) + IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('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 ) + IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('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( nn_timing == 1 ) CALL timing_start('dom_vvl_init') + ! + 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 + 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' ) + ! + ! !== 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) + ! Kristian hack. + r1_hu_b(:,:) = ssumask(:,:) / MAX(( hu_b(:,:) + 1._wp - ssumask(:,:) ), 0.01) ! _i mask due to ISF + r1_hu_n(:,:) = ssumask(:,:) / MAX(( hu_n(:,:) + 1._wp - ssumask(:,:) ), 0.01) + r1_hv_b(:,:) = ssvmask(:,:) / MAX(( hv_b(:,:) + 1._wp - ssvmask(:,:) ), 0.01) + r1_hv_n(:,:) = ssvmask(:,:) / MAX(( hv_n(:,:) + 1._wp - ssvmask(:,:) ), 0.01) + + ! !== 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( cp_cfg == "orca" .AND. jp_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 + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_init') + ! + END SUBROUTINE dom_vvl_init + + + 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 = T/F + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_vvl_interpol') + ! + zlnwd = 0.0_wp + ! + 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, 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( 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, 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( 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, 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( 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 + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_interpol') + ! + END SUBROUTINE dom_vvl_interpol + + + 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', lwp ) + ! + 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', lwp ) + 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,*) ' Namelist nam_vvl : chose kinetic-to-potential energy conservation' + ! WRITE(numout,*) ' ln_vvl_kepe = ', ln_vvl_kepe + WRITE(numout,*) ' Namelist nam_vvl : thickness diffusion coefficient' + WRITE(numout,*) ' rn_ahe3 = ', rn_ahe3 + WRITE(numout,*) ' Namelist nam_vvl : maximum e3t deformation fractional change' + WRITE(numout,*) ' rn_zdef_max = ', rn_zdef_max + IF( ln_vvl_ztilde_as_zstar ) THEN + WRITE(numout,*) ' ztilde running in zstar emulation mode; ' + 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.0' + WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)' + WRITE(numout,*) ' rn_lf_cutoff = 1.0/rdt' + ELSE + WRITE(numout,*) ' Namelist nam_vvl : z-tilde to zstar restoration timescale (days)' + WRITE(numout,*) ' rn_rst_e3t = ', rn_rst_e3t + WRITE(numout,*) ' Namelist nam_vvl : z-tilde cutoff frequency of low-pass filter (days)' + WRITE(numout,*) ' rn_lf_cutoff = ', rn_lf_cutoff + ENDIF + WRITE(numout,*) ' Namelist nam_vvl : debug prints' + WRITE(numout,*) ' ln_vvl_dbg = ', ln_vvl_dbg + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. + IF( ln_vvl_zstar ) ioptio = ioptio + 1 + IF( ln_vvl_ztilde ) ioptio = ioptio + 1 + IF( ln_vvl_layer ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) + ! + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + IF( ln_vvl_zstar ) WRITE(numout,*) ' zstar vertical coordinate is used' + IF( ln_vvl_ztilde ) WRITE(numout,*) ' ztilde vertical coordinate is used' + IF( ln_vvl_layer ) WRITE(numout,*) ' layer vertical coordinate is used' + IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' to emulate a zstar coordinate' + ! - ML - Option not developed yet + ! IF( ln_vvl_kepe ) WRITE(numout,*) ' kinetic to potential energy transfer : option used' + ! IF( .NOT. ln_vvl_kepe ) WRITE(numout,*) ' kinetic to potential energy transfer : option not used' + ENDIF + ! + ! + END SUBROUTINE dom_vvl_ctl + + !!====================================================================== +END MODULE domvvl diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/domwri.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domwri.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e127dd121bfea6bbfead8a5b1fe8085aaeb74c1e --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domwri.f90 @@ -0,0 +1,480 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! lateral boundary conditions - mpp exchanges + USE lib_mpp ! MPP library + USE wrk_nemo ! Memory allocation + USE timing ! Timing + USE phycst + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_wri ! routine called by inidom.F90 + PUBLIC dom_wri_coordinate ! routine called by domhgr.F90 + PUBLIC dom_stiff ! routine called by inidom.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_wri_coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_wri_coordinate *** + !! + !! ** Purpose : Create the NetCDF file which contains all the + !! standard coordinate information plus the surface, + !! e1e2u and e1e2v. By doing so, those surface will + !! not be changed by the reduction of e1u or e2v scale + !! factors in some straits. + !! NB: call just after the read of standard coordinate + !! and the reduction of scale factors in some straits + !! + !! ** output file : coordinate_e1e2u_v.nc + !!---------------------------------------------------------------------- + INTEGER :: inum0 ! temprary units for 'coordinate_e1e2u_v.nc' file + CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations) + ! ! workspaces + REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw + REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_wri_coordinate') + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_wri_coordinate : create NetCDF coordinate file' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~' + + clnam0 = 'coordinate_e1e2u_v' ! filename (mesh and mask informations) + + ! create 'coordinate_e1e2u_v.nc' file + ! ============================ + ! + CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib ) + ! + ! ! horizontal mesh (inum3) + CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude + CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude + CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors + CALL iom_rstput( 0, 0, inum0, 'e1u', e1u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'e1v', e1v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'e1f', e1f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum0, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors + CALL iom_rstput( 0, 0, inum0, 'e2u', e2u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'e2v', e2v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'e2f', e2f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum0, 'e1e2u', e1e2u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum0, 'e1e2v', e1e2v, ktype = jp_r8 ) + + CALL iom_close( inum0 ) + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_wri_coordinate') + ! + END SUBROUTINE dom_wri_coordinate + + + 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 : Write in a file all the arrays generated in routines + !! domhgr, domzgr, and dommsk. Note: the file contain depends on + !! the vertical coord. used (z-coord, partial steps, s-coord) + !! MOD(nmsh, 3) = 1 : 'mesh_mask.nc' file + !! = 2 : 'mesh.nc' and mask.nc' files + !! = 0 : 'mesh_hgr.nc', 'mesh_zgr.nc' and + !! 'mask.nc' files + !! For huge size domain, use option 2 or 3 depending on your + !! vertical coordinate. + !! + !! if nmsh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw] + !! if 3 < nmsh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays + !! corresponding to the depth of the bottom t- and w-points + !! if 6 < nmsh <= 9: write 2D arrays corresponding to the depth and the + !! thickness (e3[tw]_ps) of the bottom points + !! + !! ** output file : meshmask.nc : domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !!---------------------------------------------------------------------- + !! + INTEGER :: inum0 ! temprary units for 'mesh_mask.nc' file + INTEGER :: inum1 ! temprary units for 'mesh.nc' file + INTEGER :: inum2 ! temprary units for 'mask.nc' file + INTEGER :: inum3 ! temprary units for 'mesh_hgr.nc' file + INTEGER :: inum4 ! temprary units for 'mesh_zgr.nc' file + CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations) + CHARACTER(len=21) :: clnam1 ! filename (mesh informations) + CHARACTER(len=21) :: clnam2 ! filename (mask informations) + CHARACTER(len=21) :: clnam3 ! filename (horizontal mesh informations) + CHARACTER(len=21) :: clnam4 ! filename (vertical mesh informations) + INTEGER :: ji, jj, jk ! dummy loop indices + ! ! workspaces + REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw + REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_wri') + ! + CALL wrk_alloc( jpi, jpj, zprt, zprw ) + CALL wrk_alloc( jpi, jpj, jpk, zdepu, zdepv ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + clnam0 = 'mesh_mask' ! filename (mesh and mask informations) + clnam1 = 'mesh' ! filename (mesh informations) + clnam2 = 'mask' ! filename (mask informations) + clnam3 = 'mesh_hgr' ! filename (horizontal mesh informations) + clnam4 = 'mesh_zgr' ! filename (vertical mesh informations) + + SELECT CASE ( MOD(nmsh, 3) ) + ! ! ============================ + CASE ( 1 ) ! create 'mesh_mask.nc' file + ! ! ============================ + CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib ) + inum2 = inum0 ! put all the informations + inum3 = inum0 ! in unit inum0 + inum4 = inum0 + + ! ! ============================ + CASE ( 2 ) ! create 'mesh.nc' and + ! ! 'mask.nc' files + ! ! ============================ + CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib ) + CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) + inum3 = inum1 ! put mesh informations + inum4 = inum1 ! in unit inum1 + ! ! ============================ + CASE ( 0 ) ! create 'mesh_hgr.nc' + ! ! 'mesh_zgr.nc' and + ! ! 'mask.nc' files + ! ! ============================ + CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) + CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib ) + CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib ) + ! + END SELECT + + ! ! masks (inum2) + CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask + CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 ) + + CALL dom_uniq( zprw, 'T' ) + DO jj = 1, jpj + DO ji = 1, jpi + jk=mikt(ji,jj) + zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask + END DO + END DO ! ! unique point mask + CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'U' ) + DO jj = 1, jpj + DO ji = 1, jpi + jk=miku(ji,jj) + zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask + END DO + END DO + CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'V' ) + DO jj = 1, jpj + DO ji = 1, jpi + jk=mikv(ji,jj) + zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask + END DO + END DO + CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'F' ) + DO jj = 1, jpj + DO ji = 1, jpi + jk=mikf(ji,jj) + zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask + END DO + END DO + CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) + + ! ! horizontal mesh (inum3) + CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude + CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude + CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors + CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors + CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum3, 'ff_f', ff_f, ktype = jp_r8 ) ! ! coriolis factor + CALL iom_rstput( 0, 0, inum3, 'ff_t', ff_t, ktype = jp_r8 ) ! ! coriolis factor + + ! note that mbkt is set to 1 over land ==> use surface tmask + zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i2 ) ! ! nb of ocean T-points + zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum4, 'misf', zprt, ktype = jp_i2 ) ! ! nb of ocean T-points + zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp ) + CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points + + IF( ln_sco ) THEN ! s-coordinate + CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) + CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu ) + CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv ) + CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf ) + ! + CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt ) ! ! scaling coef. + CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw ) + CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w ) + CALL iom_rstput( 0, 0, inum4, 'esigt', esigt ) + CALL iom_rstput( 0, 0, inum4, 'esigw', esigw ) + ! + CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) ! ! scale factors + CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) + CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) + CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) + ! + CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system + CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) + CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) + CALL dom_stiff( zprt ) + CALL iom_rstput( 0, 0, inum4, 'stiffness', zprt ) ! ! Max. grid stiffness ratio + ENDIF + + IF( ln_zps ) THEN ! z-coordinate - partial steps + ! + IF( nmsh <= 6 ) THEN ! ! 3D vertical scale factors + CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) + CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) + CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) + CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) + ELSE ! ! 2D masked bottom ocean scale factors + DO jj = 1,jpj + DO ji = 1,jpi + e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) + e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) + END DO + END DO + CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp ) + CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp ) + END IF + ! + IF( nmsh <= 3 ) THEN ! ! 3D depth + CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) + DO jk = 1,jpk + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector opt. + zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj ,jk) ) + zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji ,jj+1,jk) ) + END DO + END DO + END DO + CALL lbc_lnk( zdepu, 'U', 1. ) ; CALL lbc_lnk( zdepv, 'V', 1. ) + CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) + ELSE ! ! 2D bottom depth + DO jj = 1,jpj + DO ji = 1,jpi + zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj) ) * ssmask(ji,jj) + zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * ssmask(ji,jj) + END DO + END DO + CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r8 ) + ENDIF + ! + CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! reference z-coord. + CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) + CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) + CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) + ENDIF + + IF( ln_zco ) THEN + ! ! z-coordinate - full steps + CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! depth + CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) + CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) ! ! scale factors + CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) + ENDIF + ! ! ============================ + ! ! close the files + ! ! ============================ + SELECT CASE ( MOD(nmsh, 3) ) + CASE ( 1 ) + CALL iom_close( inum0 ) + CASE ( 2 ) + CALL iom_close( inum1 ) + CALL iom_close( inum2 ) + CASE ( 0 ) + CALL iom_close( inum2 ) + CALL iom_close( inum3 ) + CALL iom_close( inum4 ) + END SELECT + ! + CALL wrk_dealloc( jpi, jpj, zprt, zprw ) + CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv ) + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_wri') + ! + 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), POINTER, DIMENSION(:,:) :: ztstref + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_uniq') + ! + CALL wrk_alloc( 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( 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 ) + ! + CALL wrk_dealloc( jpi, jpj, ztstref ) + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_uniq') + ! + 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( zx1, 'T', 1. ) + ! + IF( PRESENT( px1 ) ) px1 = zx1 + ! + zrxmax = MAXVAL( zx1 ) + ! + IF( lk_mpp ) CALL mpp_max( 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/V4.0/nemo_sources/tools/DOMAINcfg/src/domzgr.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/domzgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3d909fb214d49012e3f3a81a3534e7caae6077ae --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/domzgr.f90 @@ -0,0 +1,2774 @@ +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 : defined the ocean vertical coordinate system + !! zgr_bat : bathymetry fields (levels and meters) + !! zgr_bat_zoom : modify the bathymetry field if zoom domain + !! zgr_bat_ctl : check the bathymetry files + !! zgr_bot_level: deepest ocean level for t-, u, and v-points + !! zgr_z : reference z-coordinate + !! zgr_zco : z-coordinate + !! zgr_zps : z-coordinate with partial steps + !! zgr_sco : s-coordinate + !! fssig : tanh stretch function + !! fssig1 : Song and Haidvogel 1994 stretch function + !! fgamma : Siddorn and Furner 2012 stretching function + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE closea ! closed seas + ! + 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 + USE wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_zgr ! called by dom_init.F90 + + ! !!* Namelist namzgr_sco * + LOGICAL :: ln_s_sh94 ! use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 (ln_sco=T) + LOGICAL :: ln_s_sf12 ! use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma (ln_sco=T) + ! + REAL(wp) :: rn_sbot_min ! minimum depth of s-bottom surface (>0) (m) + REAL(wp) :: rn_sbot_max ! maximum depth of s-bottom surface (= ocean depth) (>0) (m) + REAL(wp) :: rn_rmax ! maximum cut-off r-value allowed (0<rn_rmax<1) + REAL(wp) :: rn_hc ! Critical depth for transition from sigma to stretched coordinates + ! Song and Haidvogel 1994 stretching parameters + REAL(wp) :: rn_theta ! surface control parameter (0<=rn_theta<=20) + REAL(wp) :: rn_thetb ! bottom control parameter (0<=rn_thetb<= 1) + REAL(wp) :: rn_bb ! stretching parameter + ! ! ( rn_bb=0; top only, rn_bb =1; top and bottom) + ! Siddorn and Furner stretching parameters + LOGICAL :: ln_sigcrit ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch + REAL(wp) :: rn_alpha ! control parameter ( > 1 stretch towards surface, < 1 towards seabed) + REAL(wp) :: rn_efold ! efold length scale for transition to stretched coord + REAL(wp) :: rn_zs ! depth of surface grid box + ! bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b + REAL(wp) :: rn_zb_a ! bathymetry scaling factor for calculating Zb + REAL(wp) :: rn_zb_b ! offset for calculating Zb + + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.3.1 , NEMO Consortium (2011) + !! $Id: domzgr.F90 6827 2016-08-01 13:37:15Z flavoni $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_zgr + !!---------------------------------------------------------------------- + !! *** 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 :: ioptio, ibat ! local integer + INTEGER :: ios + ! + NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dom_zgr') + ! + REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate + READ ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist', lwp ) + + REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate + READ ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp ) + IF(lwm) WRITE ( numond, namzgr ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dom_zgr : vertical coordinate' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Namelist namzgr : set vertical coordinate' + 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 + WRITE(numout,*) ' linear free surface ln_linssh = ', ln_linssh + ENDIF + + IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' + + 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' ) + ! + ioptio = 0 + IF ( ln_zco .AND. ln_isfcav ) ioptio = ioptio + 1 + IF ( ln_sco .AND. ln_isfcav ) ioptio = ioptio + 1 + IF( ioptio > 0 ) CALL ctl_stop( ' Cavity not tested/compatible with full step (zco) and sigma (ln_sco) ' ) + ! + ! Build the vertical coordinate system + ! ------------------------------------ + CALL zgr_z ! Reference z-coordinate system (always called) + CALL zgr_bat ! Bathymetry fields (levels and meters) + IF( ln_zco ) CALL zgr_zco ! z-coordinate + IF( ln_zps ) CALL zgr_zps ! Partial step z-coordinate + IF( ln_sco ) CALL zgr_sco ! s-coordinate or hybrid z-s coordinate + ! + ! final adjustment of mbathy & check + ! ----------------------------------- + IF( lzoom ) CALL zgr_bat_zoom ! correct mbathy in case of zoom subdomain + CALL zgr_bat_ctl ! check bathymetry (mbathy) and suppress isolated ocean points + CALL zgr_bot_level ! deepest ocean level for t-, u- and v-points + CALL zgr_top_level ! shallowest ocean level for T-, U-, V- points + ! + IF( nprint == 1 .AND. lwp ) THEN + WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) + 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 + ! + IF( nn_timing == 1 ) CALL timing_stop('dom_zgr') + ! + END SUBROUTINE dom_zgr + + + SUBROUTINE zgr_z + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : z-coordinate system (use in all type of coordinate) + !! The depth of model levels is defined from an analytical + !! function the derivative of which gives the scale factors. + !! both depth and scale factors only depend on k (1d arrays). + !! w-level: gdepw_1d = gdep(k) + !! e3w_1d(k) = dk(gdep)(k) = e3(k) + !! t-level: gdept_1d = gdep(k+0.5) + !! e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5) + !! + !! ** Action : - gdept_1d, gdepw_1d : depth of T- and W-point (m) + !! - e3t_1d , e3w_1d : scale factors at T- and W-levels (m) + !! + !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! temporary scalars + REAL(wp) :: zsur, za0, za1, zkth ! Values set from parameters in + REAL(wp) :: zacr, zdzmin, zhmax ! par_CONFIG_Rxx.h90 + REAL(wp) :: zrefdep ! depth of the reference level (~10m) + REAL(wp) :: za2, zkth2, zacr2 ! Values for optional double tanh function set from parameters + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_z') + ! + ! Set variables from parameters + ! ------------------------------ + zkth = ppkth ; zacr = ppacr + zdzmin = ppdzmin ; zhmax = pphmax + zkth2 = ppkth2 ; zacr2 = ppacr2 ! optional (ldbletanh=T) double tanh parameters + + ! If ppa1 and ppa0 and ppsur are et to pp_to_be_computed + ! za0, za1, zsur are computed from ppdzmin , pphmax, ppkth, ppacr + IF( ppa1 == pp_to_be_computed .AND. & + & ppa0 == pp_to_be_computed .AND. & + & ppsur == pp_to_be_computed ) THEN + ! + za1 = ( ppdzmin - pphmax / FLOAT(jpkm1) ) & + & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * ( LOG( COSH( (jpk - ppkth) / ppacr) ) & + & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ELSE + za1 = ppa1 ; za0 = ppa0 ; zsur = ppsur + za2 = ppa2 ! optional (ldbletanh=T) double tanh parameter + ENDIF + + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates' + WRITE(numout,*) ' ~~~~~~~' + IF( ppkth == 0._wp ) THEN + WRITE(numout,*) ' Uniform grid with ',jpk-1,' layers' + WRITE(numout,*) ' Total depth :', zhmax + WRITE(numout,*) ' Layer thickness:', zhmax/(jpk-1) + ELSE + IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN + WRITE(numout,*) ' zsur, za0, za1 computed from ' + WRITE(numout,*) ' zdzmin = ', zdzmin + WRITE(numout,*) ' zhmax = ', zhmax + ENDIF + WRITE(numout,*) ' Value of coefficients for vertical mesh:' + WRITE(numout,*) ' zsur = ', zsur + WRITE(numout,*) ' za0 = ', za0 + WRITE(numout,*) ' za1 = ', za1 + WRITE(numout,*) ' zkth = ', zkth + WRITE(numout,*) ' zacr = ', zacr + IF( ldbletanh ) THEN + WRITE(numout,*) ' (Double tanh za2 = ', za2 + WRITE(numout,*) ' parameters) zkth2= ', zkth2 + WRITE(numout,*) ' zacr2= ', zacr2 + ENDIF + ENDIF + ENDIF + + + ! Reference z-coordinate (depth - scale factor at T- and W-points) + ! ====================== + IF( ppkth == 0._wp ) THEN ! uniform vertical grid + + + + za1 = zhmax / FLOAT(jpk-1) + + DO jk = 1, jpk + zw = FLOAT( jk ) + zt = FLOAT( jk ) + 0.5_wp + gdepw_1d(jk) = ( zw - 1 ) * za1 + gdept_1d(jk) = ( zt - 1 ) * za1 + e3w_1d (jk) = za1 + e3t_1d (jk) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO jk = 1, jpk + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) ) + gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) ) + e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth) / zacr ) + e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth) / zacr ) + END DO + ELSE + DO jk = 1, jpk + zw = FLOAT( jk ) + zt = FLOAT( jk ) + 0.5_wp + ! Double tanh function + gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) ) + gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) ) + e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth ) / zacr ) & + & + za2 * TANH( (zw-zkth2) / zacr2 ) + e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth ) / zacr ) & + & + za2 * TANH( (zt-zkth2) / zacr2 ) + END DO + ENDIF + gdepw_1d(1) = 0._wp ! force first w-level to be exactly at zero + ENDIF + + IF ( ln_isfcav .OR. ln_e3_dep ) THEN ! e3. = dk[gdep] + ! +!==>>> need to be like this to compute the pressure gradient with ISF. +! If not, level beneath the ISF are not aligned (sum(e3t) /= depth) +! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively +! + DO jk = 1, jpkm1 + e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk) + END DO + e3t_1d(jpk) = e3t_1d(jpk-1) ! we don't care because this level is masked in NEMO + + DO jk = 2, jpk + e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1) + END DO + e3w_1d(1 ) = 2._wp * (gdept_1d(1) - gdepw_1d(1)) + END IF + +!!gm BUG in s-coordinate this does not work! + ! deepest/shallowest W level Above/Below ~10m + zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) + nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m + nla10 = nlb10 - 1 ! deepest W level Above ~10m +!!gm end bug + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Reference 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, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) + ENDIF + DO jk = 1, jpk ! control positivity + IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( 'dom:zgr_z: e3w_1d or e3t_1d =< 0 ' ) + IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( 'dom:zgr_z: gdepw_1d or gdept_1d < 0 ' ) + END DO + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_z') + ! + END SUBROUTINE zgr_z + + + SUBROUTINE zgr_bat + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_bat *** + !! + !! ** Purpose : set bathymetry both in levels and meters + !! + !! ** Method : read or define mbathy and bathy arrays + !! * level bathymetry: + !! The ocean basin geometry is given by a two-dimensional array, + !! mbathy, which is defined as follow : + !! mbathy(ji,jj) = 1, ..., jpk-1, the number of ocean level + !! at t-point (ji,jj). + !! = 0 over the continental t-point. + !! The array mbathy is checked to verified its consistency with + !! model option. in particular: + !! mbathy must have at least 1 land grid-points (mbathy<=0) + !! along closed boundary. + !! mbathy must be cyclic IF jperio=1. + !! mbathy must be lower or equal to jpk-1. + !! isolated ocean grid points are suppressed from mbathy + !! since they are only connected to remaining + !! ocean through vertical diffusion. + !! ntopo=-1 : rectangular channel or bassin with a bump + !! ntopo= 0 : flat rectangular channel or basin + !! ntopo= 1 : mbathy is read in 'bathy_level.nc' NetCDF file + !! bathy is read in 'bathy_meter.nc' NetCDF file + !! + !! ** Action : - mbathy: level bathymetry (in level index) + !! - bathy : meter bathymetry (in meters) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER :: ierror ! error flag + INTEGER :: ii_bump, ij_bump, ih ! bump center position + INTEGER :: ii0, ii1, ij0, ij1, ik ! local indices + REAL(wp) :: r_bump , h_bump , h_oce ! bump characteristics + REAL(wp) :: zi, zj, zh, zhmin ! local scalars + INTEGER , ALLOCATABLE, DIMENSION(:,:) :: idta ! global domain integer data + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! global domain scalar data + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_bat') + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_bat : defines level and meter bathymetry' + IF(lwp) WRITE(numout,*) ' ~~~~~~~' + ! ! ================== ! + IF( ntopo == 0 .OR. ntopo == -1 ) THEN ! defined by hand ! + ! ! ================== ! + ! ! global domain level and meter bathymetry (idta,zdta) + ! + ALLOCATE( idta(jpidta,jpjdta), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate idta array' ) + ALLOCATE( zdta(jpidta,jpjdta), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate zdta array' ) + ! + IF( ntopo == 0 ) THEN ! flat basin + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' bathymetry field: flat basin' + IF( rn_bathy > 0.01 ) THEN + IF(lwp) WRITE(numout,*) ' Depth = rn_bathy read in namelist' + zdta(:,:) = rn_bathy + IF( ln_sco ) THEN ! s-coordinate (zsc ): idta()=jpk + idta(:,:) = jpkm1 + ELSE ! z-coordinate (zco or zps): step-like topography + idta(:,:) = jpkm1 + DO jk = 1, jpkm1 + WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk + END DO + ENDIF + ELSE + IF(lwp) WRITE(numout,*) ' Depth = depthw(jpkm1)' + idta(:,:) = jpkm1 ! before last level + zdta(:,:) = gdepw_1d(jpk) ! last w-point depth + h_oce = gdepw_1d(jpk) + ENDIF + ELSE ! bump centered in the basin + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' bathymetry field: flat basin with a bump' + ii_bump = jpidta / 2 ! i-index of the bump center + ij_bump = jpjdta / 2 ! j-index of the bump center + r_bump = 50000._wp ! bump radius (meters) + h_bump = 2700._wp ! bump height (meters) + h_oce = gdepw_1d(jpk) ! background ocean depth (meters) + IF(lwp) WRITE(numout,*) ' bump characteristics: ' + IF(lwp) WRITE(numout,*) ' bump center (i,j) = ', ii_bump, ii_bump + IF(lwp) WRITE(numout,*) ' bump height = ', h_bump , ' meters' + IF(lwp) WRITE(numout,*) ' bump radius = ', r_bump , ' index' + IF(lwp) WRITE(numout,*) ' background ocean depth = ', h_oce , ' meters' + ! + DO jj = 1, jpjdta ! zdta : + DO ji = 1, jpidta + zi = FLOAT( ji - ii_bump ) * ppe1_m / r_bump + zj = FLOAT( jj - ij_bump ) * ppe2_m / r_bump + zdta(ji,jj) = h_oce - h_bump * EXP( -( zi*zi + zj*zj ) ) + END DO + END DO + ! ! idta : + IF( ln_sco ) THEN ! s-coordinate (zsc ): idta()=jpk + idta(:,:) = jpkm1 + ELSE ! z-coordinate (zco or zps): step-like topography + idta(:,:) = jpkm1 + DO jk = 1, jpkm1 + WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk + END DO + ENDIF + ENDIF + ! ! set GLOBAL boundary conditions + ! ! Caution : idta on the global domain: use of jperio, not nperio + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN + idta( : , 1 ) = -1 ; zdta( : , 1 ) = -1._wp + idta( : ,jpjdta) = 0 ; zdta( : ,jpjdta) = 0._wp + ELSEIF( jperio == 2 ) THEN + idta( : , 1 ) = idta( : , 3 ) ; zdta( : , 1 ) = zdta( : , 3 ) + idta( : ,jpjdta) = 0 ; zdta( : ,jpjdta) = 0._wp + idta( 1 , : ) = 0 ; zdta( 1 , : ) = 0._wp + idta(jpidta, : ) = 0 ; zdta(jpidta, : ) = 0._wp + ELSE + ih = 0 ; zh = 0._wp + IF( ln_sco ) ih = jpkm1 ; IF( ln_sco ) zh = h_oce + idta( : , 1 ) = ih ; zdta( : , 1 ) = zh + idta( : ,jpjdta) = ih ; zdta( : ,jpjdta) = zh + idta( 1 , : ) = ih ; zdta( 1 , : ) = zh + idta(jpidta, : ) = ih ; zdta(jpidta, : ) = zh + ENDIF + + ! ! local domain level and meter bathymetries (mbathy,bathy) + mbathy(:,:) = 0 ! set to zero extra halo points + bathy (:,:) = 0._wp ! (require for mpp case) + DO jj = 1, nlcj ! interior values + DO ji = 1, nlci + mbathy(ji,jj) = idta( mig(ji), mjg(jj) ) + bathy (ji,jj) = zdta( mig(ji), mjg(jj) ) + END DO + END DO + risfdep(:,:)=0.e0 + misfdep(:,:)=1 + ! + ! (ISF) TODO build ice draft netcdf file for isomip and build the corresponding part of code + IF( cp_cfg == "isomip" .AND. ln_isfcav ) THEN + risfdep(:,:)=200.e0 + misfdep(:,:)=1 + ij0 = 1 ; ij1 = 40 + DO jj = mj0(ij0), mj1(ij1) + risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp + END DO + WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp + ! + ELSEIF ( cp_cfg == "isomip2" .AND. ln_isfcav ) THEN + ! + risfdep(:,:)=0.e0 + misfdep(:,:)=1 + ij0 = 1 ; ij1 = 40 + DO jj = mj0(ij0), mj1(ij1) + risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp + END DO + WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp + END IF + ! + DEALLOCATE( idta, zdta ) + ! + ! ! ================ ! + ELSEIF( ntopo == 1 ) THEN ! read in file ! (over the local domain) + ! ! ================ ! + ! + IF( ln_zco ) THEN ! zco : read level bathymetry + CALL iom_open ( 'bathy_level.nc', inum ) + CALL iom_get ( inum, jpdom_data, 'Bathy_level', bathy ) + CALL iom_close( inum ) + mbathy(:,:) = INT( bathy(:,:) ) + ! initialisation isf variables + risfdep(:,:)=0._wp ; misfdep(:,:)=1 + ! ! ===================== + IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration + ! ! ===================== + ! + ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open + ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) + DO ji = mi0(ii0), mi1(ii1) + DO jj = mj0(ij0), mj1(ij1) + mbathy(ji,jj) = 15 + END DO + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r2: Gibraltar strait open at i=',ii0,' j=',ij0 + ! + ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open + ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) + DO ji = mi0(ii0), mi1(ii1) + DO jj = mj0(ij0), mj1(ij1) + mbathy(ji,jj) = 12 + END DO + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r2: Bab el Mandeb strait open at i=',ii0,' j=',ij0 + ! + ENDIF + ! + ENDIF + IF( ln_zps .OR. ln_sco ) THEN ! zps or sco : read meter bathymetry + CALL iom_open ( 'bathy_meter.nc', inum ) + IF ( ln_isfcav ) THEN + CALL iom_get ( inum, jpdom_data, 'Bathymetry_isf', bathy, lrowattr=.false. ) + ELSE + CALL iom_get ( inum, jpdom_data, 'Bathymetry' , bathy, lrowattr=ln_use_jattr ) + END IF + CALL iom_close( inum ) + ! + ! initialisation isf variables + risfdep(:,:)=0._wp ; misfdep(:,:)=1 + ! + IF ( ln_isfcav ) THEN + CALL iom_open ( 'isf_draft_meter.nc', inum ) + CALL iom_get ( inum, jpdom_data, 'isf_draft', risfdep ) + CALL iom_close( inum ) + WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp + + ! set grounded point to 0 + ! (a treshold could be set here if needed, or set it offline based on the grounded fraction) + WHERE ( bathy(:,:) <= risfdep(:,:) + rn_isfhmin ) + misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp + mbathy (:,:) = 0 ; bathy (:,:) = 0._wp + END WHERE + END IF + ! + IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration + ! + ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open + ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) + DO ji = mi0(ii0), mi1(ii1) + DO jj = mj0(ij0), mj1(ij1) + bathy(ji,jj) = 284._wp + END DO + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r2: Gibraltar strait open at i=',ii0,' j=',ij0 + ! + ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open + ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) + DO ji = mi0(ii0), mi1(ii1) + DO jj = mj0(ij0), mj1(ij1) + bathy(ji,jj) = 137._wp + END DO + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r2: Bab el Mandeb strait open at i=',ii0,' j=',ij0 + ! + ENDIF + ! + ENDIF + ! ! =============== ! + ELSE ! error ! + ! ! =============== ! + WRITE(ctmp1,*) 'parameter , ntopo = ', ntopo + CALL ctl_stop( ' zgr_bat : '//trim(ctmp1) ) + ENDIF + ! + IF( nn_closea == 0 ) CALL clo_bat( bathy, mbathy ) !== NO closed seas or lakes ==! + ! + IF ( .not. ln_sco ) THEN !== set a minimum depth ==! + IF( rn_hmin < 0._wp ) THEN ; ik = - INT( rn_hmin ) ! from a nb of level + ELSE ; ik = MINLOC( gdepw_1d, mask = gdepw_1d > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zhmin = gdepw_1d(ik+1) ! minimum depth = ik+1 w-levels + WHERE( bathy(:,:) <= 0._wp ) ; bathy(:,:) = 0._wp ! min=0 over the lands + ELSE WHERE ; bathy(:,:) = MAX( zhmin , bathy(:,:) ) ! min=zhmin over the oceans + END WHERE + IF(lwp) write(numout,*) 'Minimum ocean depth: ', zhmin, ' minimum number of ocean levels : ', ik + ENDIF + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_bat') + ! + END SUBROUTINE zgr_bat + + + SUBROUTINE zgr_bat_zoom + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_bat_zoom *** + !! + !! ** Purpose : - Close zoom domain boundary if necessary + !! - Suppress Med Sea from ORCA R2 and R05 arctic zoom + !! + !! ** Method : + !! + !! ** Action : - update mbathy: level bathymetry (in level index) + !!---------------------------------------------------------------------- + INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_bat_zoom : modify the level bathymetry for zoom domain' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~' + ! + ! Zoom domain + ! =========== + ! + ! Forced closed boundary if required + IF( lzoom_s ) mbathy( : , mj0(jpjzoom):mj1(jpjzoom) ) = 0 + IF( lzoom_w ) mbathy( mi0(jpizoom):mi1(jpizoom) , : ) = 0 + IF( lzoom_e ) mbathy( mi0(jpiglo+jpizoom-1):mi1(jpiglo+jpizoom-1) , : ) = 0 + IF( lzoom_n ) mbathy( : , mj0(jpjglo+jpjzoom-1):mj1(jpjglo+jpjzoom-1) ) = 0 + ! + ! Configuration specific domain modifications + ! (here, ORCA arctic configuration: suppress Med Sea) + IF( cp_cfg == "orca" .AND. cp_cfz == "arctic" ) THEN + SELECT CASE ( jp_cfg ) + ! ! ======================= + CASE ( 2 ) ! ORCA_R2 configuration + ! ! ======================= + IF(lwp) WRITE(numout,*) ' ORCA R2 arctic zoom: suppress the Med Sea' + ii0 = 141 ; ii1 = 162 ! Sea box i,j indices + ij0 = 98 ; ij1 = 110 + ! ! ======================= + CASE ( 05 ) ! ORCA_R05 configuration + ! ! ======================= + IF(lwp) WRITE(numout,*) ' ORCA R05 arctic zoom: suppress the Med Sea' + ii0 = 563 ; ii1 = 642 ! zero over the Med Sea boxe + ij0 = 314 ; ij1 = 370 + END SELECT + ! + mbathy( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0 ! zero over the Med Sea boxe + ! + ENDIF + ! + END SUBROUTINE zgr_bat_zoom + + + SUBROUTINE zgr_bat_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_bat_ctl *** + !! + !! ** Purpose : check the bathymetry in levels + !! + !! ** Method : The array mbathy is checked to verified its consistency + !! with the model options. in particular: + !! mbathy must have at least 1 land grid-points (mbathy<=0) + !! along closed boundary. + !! mbathy must be cyclic IF jperio=1. + !! mbathy must be lower or equal to jpk-1. + !! isolated ocean grid points are suppressed from mbathy + !! since they are only connected to remaining + !! ocean through vertical diffusion. + !! C A U T I O N : mbathy will be modified during the initializa- + !! tion phase to become the number of non-zero w-levels of a water + !! column, with a minimum value of 1. + !! + !! ** Action : - update mbathy: level bathymetry (in level index) + !! - update bathy : meter bathymetry (in meters) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: icompt, ibtest, ikmax ! temporary integers + REAL(wp), POINTER, DIMENSION(:,:) :: zbathy + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_bat_ctl') + ! + CALL wrk_alloc( jpi, jpj, zbathy ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_bat_ctl : check the bathymetry' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + ! ! Suppress isolated ocean grid points + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' suppress isolated ocean grid points' + IF(lwp) WRITE(numout,*)' -----------------------------------' + icompt = 0 + DO jl = 1, 2 + IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN + mbathy( 1 ,:) = mbathy(jpim1,:) ! local domain is cyclic east-west + mbathy(jpi,:) = mbathy( 2 ,:) + ENDIF + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ibtest = MAX( mbathy(ji-1,jj), mbathy(ji+1,jj), & + & mbathy(ji,jj-1), mbathy(ji,jj+1) ) + IF( ibtest < mbathy(ji,jj) ) THEN + IF(lwp) WRITE(numout,*) ' the number of ocean level at ', & + & 'grid-point (i,j) = ',ji,jj,' is changed from ', mbathy(ji,jj),' to ', ibtest + mbathy(ji,jj) = ibtest + icompt = icompt + 1 + ENDIF + END DO + END DO + END DO + IF( lk_mpp ) CALL mpp_sum( icompt ) + IF( icompt == 0 ) THEN + IF(lwp) WRITE(numout,*)' no isolated ocean grid points' + ELSE + IF(lwp) WRITE(numout,*)' ',icompt,' ocean grid points suppressed' + ENDIF + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1._wp ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! ! East-west cyclic boundary conditions + IF( nperio == 0 ) THEN + IF(lwp) WRITE(numout,*) ' mbathy set to 0 along east and west boundary: nperio = ', nperio + IF( lk_mpp ) THEN + IF( nbondi == -1 .OR. nbondi == 2 ) THEN + IF( jperio /= 1 ) mbathy(1,:) = 0 + ENDIF + IF( nbondi == 1 .OR. nbondi == 2 ) THEN + IF( jperio /= 1 ) mbathy(nlci,:) = 0 + ENDIF + ELSE + IF( ln_zco .OR. ln_zps ) THEN + mbathy( 1 ,:) = 0 + mbathy(jpi,:) = 0 + ELSE + mbathy( 1 ,:) = jpkm1 + mbathy(jpi,:) = jpkm1 + ENDIF + ENDIF + ELSEIF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN + IF(lwp) WRITE(numout,*)' east-west cyclic boundary conditions on mbathy: nperio = ', nperio + mbathy( 1 ,:) = mbathy(jpim1,:) + mbathy(jpi,:) = mbathy( 2 ,:) + ELSEIF( nperio == 2 ) THEN + IF(lwp) WRITE(numout,*) ' equatorial boundary conditions on mbathy: nperio = ', nperio + ELSE + IF(lwp) WRITE(numout,*) ' e r r o r' + IF(lwp) WRITE(numout,*) ' parameter , nperio = ', nperio + ! STOP 'dom_mba' + ENDIF + ! Boundary condition on mbathy + IF( .NOT.lk_mpp ) THEN +!!gm !!bug ??? think about it ! + ! ... mono- or macro-tasking: T-point, >0, 2D array, no slab + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1._wp ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! Number of ocean level inferior or equal to jpkm1 + ikmax = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ikmax = MAX( ikmax, mbathy(ji,jj) ) + END DO + END DO +!!gm !!! test to do: ikmax = MAX( mbathy(:,:) ) ??? + IF( ikmax > jpkm1 ) THEN + IF(lwp) WRITE(numout,*) ' maximum number of ocean level = ', ikmax,' > jpk-1' + IF(lwp) WRITE(numout,*) ' change jpk to ',ikmax+1,' to use the exact ead bathymetry' + ELSE IF( ikmax < jpkm1 ) THEN + IF(lwp) WRITE(numout,*) ' maximum number of ocean level = ', ikmax,' < jpk-1' + IF(lwp) WRITE(numout,*) ' you can decrease jpk to ', ikmax+1 + ENDIF + ! + CALL wrk_dealloc( jpi, jpj, zbathy ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_bat_ctl') + ! + END SUBROUTINE zgr_bat_ctl + + + SUBROUTINE zgr_bot_level + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_bot_level *** + !! + !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) + !! + !! ** Method : computes from mbathy with a minimum value of 1 over land + !! + !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest + !! ocean level at t-, u- & v-points + !! (min value = 1 over land) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), POINTER, DIMENSION(:,:) :: zmbk + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_bot_level') + ! + CALL wrk_alloc( jpi, jpj, zmbk ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' + ! + mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) + + ! ! bottom k-index of W-level = mbkt+1 + DO jj = 1, jpjm1 ! bottom k-index of u- (v-) level + DO ji = 1, jpim1 + 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 + zmbk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) + ! + CALL wrk_dealloc( jpi, jpj, zmbk ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_bot_level') + ! + END SUBROUTINE zgr_bot_level + + + SUBROUTINE zgr_top_level + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_top_level *** + !! + !! ** Purpose : defines the vertical index of ocean top (mik. arrays) + !! + !! ** Method : computes from misfdep with a minimum value of 1 + !! + !! ** Action : mikt, miku, mikv : vertical indices of the shallowest + !! ocean level at t-, u- & v-points + !! (min value = 1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), POINTER, DIMENSION(:,:) :: zmik + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_top_level') + ! + CALL wrk_alloc( jpi, jpj, zmik ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_level : ocean top k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' + ! + mikt(:,:) = MAX( misfdep(:,:) , 1 ) ! top k-index of T-level (=1) + ! ! top k-index of W-level (=mikt) + DO jj = 1, jpjm1 ! top k-index of U- (U-) level + 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) ) + 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 + zmik(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk(zmik,'U',1.) ; miku (:,:) = MAX( INT( zmik(:,:) ), 1 ) + zmik(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk(zmik,'V',1.) ; mikv (:,:) = MAX( INT( zmik(:,:) ), 1 ) + zmik(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk(zmik,'F',1.) ; mikf (:,:) = MAX( INT( zmik(:,:) ), 1 ) + ! + CALL wrk_dealloc( jpi, jpj, zmik ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_top_level') + ! + END SUBROUTINE zgr_top_level + + + SUBROUTINE zgr_zco + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_zco *** + !! + !! ** Purpose : define the reference z-coordinate system + !! + !! ** Method : set 3D coord. arrays to reference 1D array + !!---------------------------------------------------------------------- + INTEGER :: jk + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_zco') + ! + DO jk = 1, jpk + gdept_0(:,:,jk) = gdept_1d(jk) + gdepw_0(:,:,jk) = gdepw_1d(jk) + gde3w_0(:,:,jk) = gdepw_1d(jk) + e3t_0 (:,:,jk) = e3t_1d (jk) + e3u_0 (:,:,jk) = e3t_1d (jk) + e3v_0 (:,:,jk) = e3t_1d (jk) + e3f_0 (:,:,jk) = e3t_1d (jk) + e3w_0 (:,:,jk) = e3w_1d (jk) + e3uw_0 (:,:,jk) = e3w_1d (jk) + e3vw_0 (:,:,jk) = e3w_1d (jk) + END DO + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_zco') + ! + END SUBROUTINE zgr_zco + + + SUBROUTINE zgr_zps + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_zps *** + !! + !! ** Purpose : the depth and vertical scale factor in partial step + !! reference z-coordinate case + !! + !! ** Method : Partial steps : computes the 3D vertical scale factors + !! of T-, U-, V-, W-, UW-, VW and F-points that are associated with + !! a partial step representation of bottom topography. + !! + !! The reference depth of model levels is defined from an analytical + !! function the derivative of which gives the reference vertical + !! scale factors. + !! From depth and scale factors reference, we compute there new value + !! with partial steps on 3d arrays ( i, j, k ). + !! + !! w-level: gdepw_0(i,j,k) = gdep(k) + !! e3w_0(i,j,k) = dk(gdep)(k) = e3(i,j,k) + !! t-level: gdept_0(i,j,k) = gdep(k+0.5) + !! e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) + !! + !! With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), + !! we find the mbathy index of the depth at each grid point. + !! This leads us to three cases: + !! + !! - bathy = 0 => mbathy = 0 + !! - 1 < mbathy < jpkm1 + !! - bathy > gdepw_0(jpk) => mbathy = jpkm1 + !! + !! Then, for each case, we find the new depth at t- and w- levels + !! and the new vertical scale factors at t-, u-, v-, w-, uw-, vw- + !! and f-points. + !! + !! This routine is given as an example, it must be modified + !! following the user s desiderata. nevertheless, the output as + !! well as the way to compute the model levels and scale factors + !! must be respected in order to insure second order accuracy + !! schemes. + !! + !! c a u t i o n : gdept_1d, gdepw_1d and e3._1d are positives + !! - - - - - - - gdept_0, gdepw_0 and e3. are positives + !! + !! Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ik, it, ikb, ikt ! temporary integers + REAL(wp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points + REAL(wp) :: zdepwp, zdepth ! Ajusted ocean depth to avoid too small e3t + REAL(wp) :: zdiff ! temporary scalar + REAL(wp) :: zmax ! temporary scalar + REAL(wp), POINTER, DIMENSION(:,:,:) :: zprt + !!--------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_zps') + ! + CALL wrk_alloc( jpi,jpj,jpk, zprt ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_zps : z-coordinate with partial steps' + IF(lwp) WRITE(numout,*) ' ~~~~~~~ ' + IF(lwp) WRITE(numout,*) ' mbathy is recomputed : bathy_level file is NOT used' + + ! bathymetry in level (from bathy_meter) + ! =================== + zmax = gdepw_1d(jpk) + e3t_1d(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) + bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) + WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 + ELSE WHERE ; mbathy(:,:) = jpkm1 ! ocean : initialize mbathy to the max ocean level + END WHERE + + ! Compute mbathy for ocean points (i.e. the number of ocean levels) + ! find the number of ocean levels such that the last level thickness + ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where + ! e3t_1d is the reference level thickness + DO jk = jpkm1, 1, -1 + zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) + WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 + END DO + + ! Scale factors and depth at T- and W-points + DO jk = 1, jpk ! intitialization to the reference z-coordinate + gdept_0(:,:,jk) = gdept_1d(jk) + gdepw_0(:,:,jk) = gdepw_1d(jk) + e3t_0 (:,:,jk) = e3t_1d (jk) + e3w_0 (:,:,jk) = e3w_1d (jk) + END DO + + ! Bathy, iceshelf draft, scale factor and depth at T- and W- points in case of isf + IF ( ln_isfcav ) CALL zgr_isf + + ! Scale factors and depth at T- and W-points + IF ( .NOT. ln_isfcav ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbathy(ji,jj) + IF( ik > 0 ) THEN ! ocean point only + ! max ocean level case + IF( ik == jpkm1 ) THEN + zdepwp = bathy(ji,jj) + ze3tp = bathy(ji,jj) - gdepw_1d(ik) + ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) + e3t_0(ji,jj,ik ) = ze3tp + e3t_0(ji,jj,ik+1) = ze3tp + e3w_0(ji,jj,ik ) = ze3wp + e3w_0(ji,jj,ik+1) = ze3tp + gdepw_0(ji,jj,ik+1) = zdepwp + gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp + gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp + ! + ELSE ! standard case + IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) + ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) + ENDIF + !gm Bug? check the gdepw_1d + ! ... on ik + gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & + & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & + & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) + e3t_0 (ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & + & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ) + e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) & + & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) + ! ... on ik+1 + e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) + ENDIF + ENDIF + END DO + END DO + ! + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbathy(ji,jj) + IF( ik > 0 ) THEN ! ocean point only + e3tp (ji,jj) = e3t_0(ji,jj,ik) + e3wp (ji,jj) = e3w_0(ji,jj,ik) + ! test + zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) + IF( zdiff <= 0._wp .AND. lwp ) THEN + it = it + 1 + WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj + WRITE(numout,*) ' bathy = ', bathy(ji,jj) + WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff + WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) + ENDIF + ENDIF + END DO + END DO + END IF + ! + ! Scale factors and depth at U-, V-, UW and VW-points + DO jk = 1, jpk ! initialisation to z-scale factors + e3u_0 (:,:,jk) = e3t_1d(jk) + e3v_0 (:,:,jk) = e3t_1d(jk) + e3uw_0(:,:,jk) = e3w_1d(jk) + e3vw_0(:,:,jk) = e3w_1d(jk) + END DO + + DO jk = 1,jpk ! Computed as the minimum of neighbooring scale factors + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector opt. + e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) + e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) + e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) + e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) + END DO + END DO + END DO + IF ( ln_isfcav ) THEN + ! (ISF) define e3uw (adapted for 2 cells in the water column) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) + ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) + IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji+1,jj ,ikb ) ) & + & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj ,ikb-1) ) + ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) + ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) + IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji ,jj+1,ikb ) ) & + & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji ,jj+1,ikb-1) ) + END DO + END DO + END IF + + CALL lbc_lnk( e3u_0 , 'U', 1._wp ) ; CALL lbc_lnk( e3uw_0, 'U', 1._wp ) ! lateral boundary conditions + CALL lbc_lnk( e3v_0 , 'V', 1._wp ) ; CALL lbc_lnk( e3vw_0, 'V', 1._wp ) + ! + + DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) + WHERE( e3u_0 (:,:,jk) == 0._wp ) e3u_0 (:,:,jk) = e3t_1d(jk) + WHERE( e3v_0 (:,:,jk) == 0._wp ) e3v_0 (:,:,jk) = e3t_1d(jk) + WHERE( e3uw_0(:,:,jk) == 0._wp ) e3uw_0(:,:,jk) = e3w_1d(jk) + WHERE( e3vw_0(:,:,jk) == 0._wp ) e3vw_0(:,:,jk) = e3w_1d(jk) + END DO + + ! Scale factor at F-point + DO jk = 1, jpk ! initialisation to z-scale factors + e3f_0(:,:,jk) = e3t_1d(jk) + END DO + DO jk = 1, jpk ! Computed as the minimum of neighbooring V-scale factors + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector opt. + e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) + END DO + END DO + END DO + CALL lbc_lnk( e3f_0, 'F', 1._wp ) ! Lateral boundary conditions + ! + DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) + WHERE( e3f_0(:,:,jk) == 0._wp ) e3f_0(:,:,jk) = e3t_1d(jk) + END DO +!!gm bug ? : must be a do loop with mj0,mj1 + ! + e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 2 + e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:) + e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:) + e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:) + e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:) + + ! Control of the sign + IF( MINVAL( e3t_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t_0 <= 0' ) + IF( MINVAL( e3w_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w_0 <= 0' ) + IF( MINVAL( gdept_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdept_0 < 0' ) + IF( MINVAL( gdepw_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw_0 < 0' ) + + ! Compute gde3w_0 (vertical sum of e3w) + IF ( ln_isfcav ) THEN ! if cavity + WHERE( misfdep == 0 ) misfdep = 1 + DO jj = 1,jpj + DO ji = 1,jpi + gde3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) + DO jk = 2, misfdep(ji,jj) + gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) + END DO + IF( misfdep(ji,jj) >= 2 ) gde3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) + DO jk = misfdep(ji,jj) + 1, jpk + gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) + END DO + END DO + END DO + ELSE ! no cavity + 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 + END IF + ! + CALL wrk_dealloc( jpi,jpj,jpk, zprt ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_zps') + ! + END SUBROUTINE zgr_zps + + + SUBROUTINE zgr_isf + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_isf *** + !! + !! ** Purpose : check the bathymetry in levels + !! + !! ** Method : THe water column have to contained at least 2 cells + !! Bathymetry and isfdraft are modified (dig/close) to respect + !! this criterion. + !! + !! ** Action : - test compatibility between isfdraft and bathy + !! - bathy and isfdraft are modified + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl, jk ! dummy loop indices + INTEGER :: ik, it ! temporary integers + INTEGER :: icompt, ibtest ! (ISF) + INTEGER :: ibtestim1, ibtestip1 ! (ISF) + INTEGER :: ibtestjm1, ibtestjp1 ! (ISF) + REAL(wp) :: zdepth ! Ajusted ocean depth to avoid too small e3t + REAL(wp) :: zmax ! Maximum and minimum depth + REAL(wp) :: zbathydiff ! isf temporary scalar + REAL(wp) :: zrisfdepdiff ! isf temporary scalar + REAL(wp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points + REAL(wp) :: zdepwp ! Ajusted ocean depth to avoid too small e3t + REAL(wp) :: zdiff ! temporary scalar + REAL(wp), POINTER, DIMENSION(:,:) :: zrisfdep, zbathy, zmask ! 2D workspace (ISH) + INTEGER , POINTER, DIMENSION(:,:) :: zmbathy, zmisfdep ! 2D workspace (ISH) + !!--------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_isf') + ! + CALL wrk_alloc( jpi,jpj, zbathy, zmask, zrisfdep) + CALL wrk_alloc( jpi,jpj, zmisfdep, zmbathy ) + + ! (ISF) compute misfdep + WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) /= 0 ) ; misfdep(:,:) = 1 ! open water : set misfdep to 1 + ELSEWHERE ; misfdep(:,:) = 2 ! iceshelf : initialize misfdep to second level + END WHERE + + ! Compute misfdep for ocean points (i.e. first wet level) + ! find the first ocean level such that the first level thickness + ! is larger than the bot_level of e3zps_min and e3zps_rat * e3t_0 (where + ! e3t_0 is the reference level thickness + DO jk = 2, jpkm1 + zdepth = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) + WHERE( 0._wp < risfdep(:,:) .AND. risfdep(:,:) >= zdepth ) misfdep(:,:) = jk+1 + END DO + WHERE ( 0._wp < risfdep(:,:) .AND. risfdep(:,:) <= e3t_1d(1) ) + risfdep(:,:) = 0. ; misfdep(:,:) = 1 + END WHERE + + ! remove very shallow ice shelf (less than ~ 10m if 75L) + WHERE (risfdep(:,:) <= 10._wp .AND. misfdep(:,:) > 1) + misfdep = 0; risfdep = 0.0_wp; + mbathy = 0; bathy = 0.0_wp; + END WHERE + WHERE (bathy(:,:) <= 30.0_wp .AND. gphit < -60._wp) + misfdep = 0; risfdep = 0.0_wp; + mbathy = 0; bathy = 0.0_wp; + END WHERE + +! basic check for the compatibility of bathy and risfdep. I think it should be offline because it is not perfect and cannot solved all the situation + icompt = 0 +! run the bathy check 10 times to be sure all the modif in the bathy or iceshelf draft are compatible together + DO jl = 1, 10 + ! check at each iteration if isf is grounded or not (1cm treshold have to be update after first coupling experiments) + WHERE (bathy(:,:) <= risfdep(:,:) + rn_isfhmin) + misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp + mbathy (:,:) = 0 ; bathy (:,:) = 0._wp + END WHERE + WHERE (mbathy(:,:) <= 0) + misfdep(:,:) = 0; risfdep(:,:) = 0._wp + mbathy (:,:) = 0; bathy (:,:) = 0._wp + END WHERE + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN + misfdep( 1 ,:) = misfdep(jpim1,:) ! local domain is cyclic east-west + misfdep(jpi,:) = misfdep( 2 ,:) + mbathy( 1 ,:) = mbathy(jpim1,:) ! local domain is cyclic east-west + mbathy(jpi,:) = mbathy( 2 ,:) + ENDIF + + ! split last cell if possible (only where water column is 2 cell or less) + ! if coupled to ice sheet, we do not modify the bathymetry (can be discuss). + IF ( .NOT. ln_iscpl) THEN + DO jk = jpkm1, 1, -1 + zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) + WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) + mbathy(:,:) = jk + bathy(:,:) = zmax + END WHERE + END DO + END IF + + ! split top cell if possible (only where water column is 2 cell or less) + DO jk = 2, jpkm1 + zmax = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) + WHERE( gdepw_1d(jk+1) > risfdep(:,:) .AND. risfdep(:,:) >= zmax .AND. misfdep + 1 >= mbathy) + misfdep(:,:) = jk + risfdep(:,:) = zmax + END WHERE + END DO + + + ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition + DO jj = 1, jpj + DO ji = 1, jpi + ! find the minimum change option: + ! test bathy + IF (risfdep(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) & + & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) & + & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) + IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) < misfdep(ji,jj)) THEN + IF (zbathydiff <= zrisfdepdiff) THEN + bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) + mbathy(ji,jj)= mbathy(ji,jj) + 1 + ELSE + risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) + misfdep(ji,jj) = misfdep(ji,jj) - 1 + END IF + ENDIF + ELSE + IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) < misfdep(ji,jj)) THEN + risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) + misfdep(ji,jj) = misfdep(ji,jj) - 1 + END IF + END IF + END IF + END DO + END DO + + ! At least 2 levels for water thickness at T, U, and V point. + DO jj = 1, jpj + DO ji = 1, jpi + ! find the minimum change option: + ! test bathy + IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS(bathy(ji,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & + & + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji,jj) - ( gdepw_1d(misfdep(ji,jj) ) & + & - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) + IF (zbathydiff <= zrisfdepdiff) THEN + mbathy(ji,jj) = mbathy(ji,jj) + 1 + bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) + ELSE + misfdep(ji,jj)= misfdep(ji,jj) - 1 + risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) + END IF + ELSE + misfdep(ji,jj)= misfdep(ji,jj) - 1 + risfdep(ji,jj)= gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) + END IF + ENDIF + END DO + END DO + + ! point V mbathy(ji,jj) == misfdep(ji,jj+1) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS(bathy(ji,jj ) - ( gdepw_1d(mbathy (ji,jj)+1) & + & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji,jj+1) - ( gdepw_1d(misfdep(ji,jj+1)) & + & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) + IF (zbathydiff <= zrisfdepdiff) THEN + mbathy(ji,jj) = mbathy(ji,jj) + 1 + bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) + ELSE + misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 + risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) + END IF + ELSE + misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 + risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) + END IF + ENDIF + END DO + END DO + + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! point V misdep(ji,jj) == mbathy(ji,jj+1) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS( bathy(ji,jj+1) - ( gdepw_1d(mbathy (ji,jj+1)+1) & + & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji,jj ) - ( gdepw_1d(misfdep(ji,jj ) ) & + & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) + IF (zbathydiff <= zrisfdepdiff) THEN + mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 + bathy (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1) ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) + ELSE + misfdep(ji,jj) = misfdep(ji,jj) - 1 + risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) + END IF + ELSE + misfdep(ji,jj) = misfdep(ji,jj) - 1 + risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) + END IF + ENDIF + END DO + END DO + + + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + + ! point U mbathy(ji,jj) == misfdep(ji,jj+1) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS( bathy(ji ,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & + & + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji+1,jj) - ( gdepw_1d(misfdep(ji+1,jj)) & + & - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) + IF (zbathydiff <= zrisfdepdiff) THEN + mbathy(ji,jj) = mbathy(ji,jj) + 1 + bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) + ELSE + misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 + risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) + END IF + ELSE + misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 + risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) + ENDIF + ENDIF + ENDDO + ENDDO + + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + + ! point U misfdep(ji,jj) == bathy(ji,jj+1) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) > 1) THEN + IF ( .NOT. ln_iscpl ) THEN + zbathydiff =ABS( bathy(ji+1,jj) - ( gdepw_1d(mbathy (ji+1,jj)+1) & + & + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) + zrisfdepdiff=ABS(risfdep(ji ,jj) - ( gdepw_1d(misfdep(ji ,jj) ) & + & - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) + IF (zbathydiff <= zrisfdepdiff) THEN + mbathy(ji+1,jj) = mbathy (ji+1,jj) + 1 + bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) + ELSE + misfdep(ji,jj) = misfdep(ji ,jj) - 1 + risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) + END IF + ELSE + misfdep(ji,jj) = misfdep(ji ,jj) - 1 + risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) + ENDIF + ENDIF + ENDDO + ENDDO + + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + END DO + ! end dig bathy/ice shelf to be compatible + ! now fill single point in "coastline" of ice shelf, bathy, hole, and test again one cell tickness + DO jl = 1,20 + + ! remove single point "bay" on isf coast line in the ice shelf draft' + DO jk = 2, jpk + WHERE (misfdep==0) misfdep=jpk + zmask=0._wp + WHERE (misfdep <= jk) zmask=1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF (misfdep(ji,jj) == jk) THEN + ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) + IF (ibtest <= 1) THEN + risfdep(ji,jj)=gdepw_1d(jk+1) ; misfdep(ji,jj)=jk+1 + IF (misfdep(ji,jj) > mbathy(ji,jj)) misfdep(ji,jj) = jpk + END IF + END IF + END DO + END DO + END DO + WHERE (misfdep==jpk) + misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp + END WHERE + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + + ! remove single point "bay" on bathy coast line beneath an ice shelf' + DO jk = jpk,1,-1 + zmask=0._wp + WHERE (mbathy >= jk ) zmask=1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF (mbathy(ji,jj) == jk .AND. misfdep(ji,jj) >= 2) THEN + ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) + IF (ibtest <= 1) THEN + bathy(ji,jj)=gdepw_1d(jk) ; mbathy(ji,jj)=jk-1 + IF (misfdep(ji,jj) > mbathy(ji,jj)) mbathy(ji,jj) = 0 + END IF + END IF + END DO + END DO + END DO + WHERE (mbathy==0) + misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp + END WHERE + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + + ! fill hole in ice shelf + zmisfdep = misfdep + zrisfdep = risfdep + WHERE (zmisfdep <= 1._wp) zmisfdep=jpk + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ibtestim1 = zmisfdep(ji-1,jj ) ; ibtestip1 = zmisfdep(ji+1,jj ) + ibtestjm1 = zmisfdep(ji ,jj-1) ; ibtestjp1 = zmisfdep(ji ,jj+1) + IF( zmisfdep(ji,jj) >= mbathy(ji-1,jj ) ) ibtestim1 = jpk + IF( zmisfdep(ji,jj) >= mbathy(ji+1,jj ) ) ibtestip1 = jpk + IF( zmisfdep(ji,jj) >= mbathy(ji ,jj-1) ) ibtestjm1 = jpk + IF( zmisfdep(ji,jj) >= mbathy(ji ,jj+1) ) ibtestjp1 = jpk + ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) + IF( ibtest == jpk .AND. misfdep(ji,jj) >= 2) THEN + mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp + END IF + IF( zmisfdep(ji,jj) < ibtest .AND. misfdep(ji,jj) >= 2) THEN + misfdep(ji,jj) = ibtest + risfdep(ji,jj) = gdepw_1d(ibtest) + ENDIF + ENDDO + ENDDO + + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep, 'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! + !! fill hole in bathymetry + zmbathy (:,:)=mbathy (:,:) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ibtestim1 = zmbathy(ji-1,jj ) ; ibtestip1 = zmbathy(ji+1,jj ) + ibtestjm1 = zmbathy(ji ,jj-1) ; ibtestjp1 = zmbathy(ji ,jj+1) + IF( zmbathy(ji,jj) < misfdep(ji-1,jj ) ) ibtestim1 = 0 + IF( zmbathy(ji,jj) < misfdep(ji+1,jj ) ) ibtestip1 = 0 + IF( zmbathy(ji,jj) < misfdep(ji ,jj-1) ) ibtestjm1 = 0 + IF( zmbathy(ji,jj) < misfdep(ji ,jj+1) ) ibtestjp1 = 0 + ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) + IF( ibtest == 0 .AND. misfdep(ji,jj) >= 2) THEN + mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; + END IF + IF( ibtest < zmbathy(ji,jj) .AND. misfdep(ji,jj) >= 2) THEN + mbathy(ji,jj) = ibtest + bathy(ji,jj) = gdepw_1d(ibtest+1) + ENDIF + END DO + END DO + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep, 'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! if not compatible after all check (ie U point water column less than 2 cells), mask U + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF (mbathy(ji,jj) == misfdep(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN + mbathy(ji,jj) = mbathy(ji,jj) - 1 ; bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)+1) ; + END IF + END DO + END DO + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep, 'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! if not compatible after all check (ie U point water column less than 2 cells), mask U + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + IF (misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN + mbathy(ji+1,jj) = mbathy(ji+1,jj) - 1; bathy(ji+1,jj) = gdepw_1d(mbathy(ji+1,jj)+1) ; + END IF + END DO + END DO + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! if not compatible after all check (ie V point water column less than 2 cells), mask V + DO jj = 1, jpjm1 + DO ji = 1, jpi + IF (mbathy(ji,jj) == misfdep(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN + mbathy(ji,jj) = mbathy(ji,jj) - 1 ; bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)+1) ; + END IF + END DO + END DO + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! if not compatible after all check (ie V point water column less than 2 cells), mask V + DO jj = 1, jpjm1 + DO ji = 1, jpi + IF (misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN + mbathy(ji,jj+1) = mbathy(ji,jj+1) - 1 ; bathy(ji,jj+1) = gdepw_1d(mbathy(ji,jj+1)+1) ; + END IF + END DO + END DO + IF( lk_mpp ) THEN + zbathy(:,:) = FLOAT( misfdep(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + misfdep(:,:) = INT( zbathy(:,:) ) + + CALL lbc_lnk( risfdep,'T', 1. ) + CALL lbc_lnk( bathy, 'T', 1. ) + + zbathy(:,:) = FLOAT( mbathy(:,:) ) + CALL lbc_lnk( zbathy, 'T', 1. ) + mbathy(:,:) = INT( zbathy(:,:) ) + ENDIF + ! if not compatible after all check, mask T + DO jj = 1, jpj + DO ji = 1, jpi + IF (mbathy(ji,jj) <= misfdep(ji,jj)) THEN + misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0._wp ; mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0._wp ; + END IF + END DO + END DO + + WHERE (mbathy(:,:) == 1) + mbathy = 0; bathy = 0.0_wp ; misfdep = 0 ; risfdep = 0.0_wp + END WHERE + END DO +! end check compatibility ice shelf/bathy + ! remove very shallow ice shelf (less than ~ 10m if 75L) + WHERE (risfdep(:,:) <= 10._wp) + misfdep = 1; risfdep = 0.0_wp; + END WHERE + + IF( icompt == 0 ) THEN + IF(lwp) WRITE(numout,*)' no points with ice shelf too close to bathymetry' + ELSE + IF(lwp) WRITE(numout,*)' ',icompt,' ocean grid points with ice shelf thickness reduced to avoid bathymetry' + ENDIF + + ! compute scale factor and depth at T- and W- points + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbathy(ji,jj) + IF( ik > 0 ) THEN ! ocean point only + ! max ocean level case + IF( ik == jpkm1 ) THEN + zdepwp = bathy(ji,jj) + ze3tp = bathy(ji,jj) - gdepw_1d(ik) + ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) + e3t_0(ji,jj,ik ) = ze3tp + e3t_0(ji,jj,ik+1) = ze3tp + e3w_0(ji,jj,ik ) = ze3wp + e3w_0(ji,jj,ik+1) = ze3tp + gdepw_0(ji,jj,ik+1) = zdepwp + gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp + gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp + ! + ELSE ! standard case + IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) + ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) + ENDIF + ! gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) +!gm Bug? check the gdepw_1d + ! ... on ik + gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & + & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & + & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) + e3t_0 (ji,jj,ik ) = gdepw_0(ji,jj,ik+1) - gdepw_1d(ik ) + e3w_0 (ji,jj,ik ) = gdept_0(ji,jj,ik ) - gdept_1d(ik-1) + ! ... on ik+1 + e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + ENDIF + ENDIF + END DO + END DO + ! + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbathy(ji,jj) + IF( ik > 0 ) THEN ! ocean point only + e3tp (ji,jj) = e3t_0(ji,jj,ik) + e3wp (ji,jj) = e3w_0(ji,jj,ik) + ! test + zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) + IF( zdiff <= 0._wp .AND. lwp ) THEN + it = it + 1 + WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj + WRITE(numout,*) ' bathy = ', bathy(ji,jj) + WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff + WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) + ENDIF + ENDIF + END DO + END DO + ! + ! (ISF) Definition of e3t, u, v, w for ISF case + DO jj = 1, jpj + DO ji = 1, jpi + ik = misfdep(ji,jj) + IF( ik > 1 ) THEN ! ice shelf point only + IF( risfdep(ji,jj) < gdepw_1d(ik) ) risfdep(ji,jj)= gdepw_1d(ik) + gdepw_0(ji,jj,ik) = risfdep(ji,jj) +!gm Bug? check the gdepw_0 + ! ... on ik + gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) ) & + & * ( gdepw_1d(ik+1) - gdept_1d(ik) ) & + & / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) + e3t_0 (ji,jj,ik ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) + e3w_0 (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) + + IF( ik + 1 == mbathy(ji,jj) ) THEN ! ice shelf point only (2 cell water column) + e3w_0 (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik) + ENDIF + ! ... on ik / ik-1 + e3w_0 (ji,jj,ik ) = e3t_0 (ji,jj,ik) !2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik)) + gdept_0(ji,jj,ik-1) = gdept_0(ji,jj,ik) - e3w_0(ji,jj,ik) + e3t_0 (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) + e3w_0 (ji,jj,ik-1) = gdept_0(ji,jj,ik-1) - gdept_1d(ik-2) + gdepw_0(ji,jj,ik-1) = gdepw_0(ji,jj,ik) - e3t_0(ji,jj,ik-1) + ENDIF + END DO + END DO + + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = misfdep(ji,jj) + IF( ik > 1 ) THEN ! ice shelf point only + e3tp (ji,jj) = e3t_0(ji,jj,ik ) + e3wp (ji,jj) = e3w_0(ji,jj,ik+1 ) + ! test + zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik ) + IF( zdiff <= 0. .AND. lwp ) THEN + it = it + 1 + WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj + WRITE(numout,*) ' risfdep = ', risfdep(ji,jj) + WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff + WRITE(numout,*) ' e3tp = ', e3tp(ji,jj), ' e3wp = ', e3wp(ji,jj) + ENDIF + ENDIF + END DO + END DO + + CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) + CALL wrk_dealloc( jpi, jpj, zmisfdep, zmbathy ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_isf') + ! + END SUBROUTINE zgr_isf + + + SUBROUTINE zgr_sco + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_sco *** + !! + !! ** Purpose : define the s-coordinate system + !! + !! ** Method : s-coordinate + !! The depth of model levels is defined as the product of an + !! analytical function by the local bathymetry, while the vertical + !! scale factors are defined as the product of the first derivative + !! of the analytical function by the bathymetry. + !! (this solution save memory as depth and scale factors are not + !! 3d fields) + !! - Read bathymetry (in meters) at t-point and compute the + !! bathymetry at u-, v-, and f-points. + !! hbatu = mi( hbatt ) + !! hbatv = mj( hbatt ) + !! hbatf = mi( mj( hbatt ) ) + !! - Compute z_gsigt, z_gsigw, z_esigt, z_esigw from an analytical + !! function and its derivative given as function. + !! z_gsigt(k) = fssig (k ) + !! z_gsigw(k) = fssig (k-0.5) + !! z_esigt(k) = fsdsig(k ) + !! z_esigw(k) = fsdsig(k-0.5) + !! Three options for stretching are give, and they can be modified + !! following the users requirements. Nevertheless, the output as + !! well as the way to compute the model levels and scale factors + !! must be respected in order to insure second order accuracy + !! schemes. + !! + !! The three methods for stretching available are: + !! + !! s_sh94 (Song and Haidvogel 1994) + !! a sinh/tanh function that allows sigma and stretched sigma + !! + !! s_sf12 (Siddorn and Furner 2012?) + !! allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! s_tanh (Madec et al 1996) + !! a cosh/tanh function that gives stretched coordinates + !! + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jl ! dummy loop argument + INTEGER :: iip1, ijp1, iim1, ijm1 ! temporary integers + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zrmax, ztaper ! temporary scalars + REAL(wp) :: zrfact + ! + REAL(wp), POINTER, DIMENSION(:,: ) :: ztmpi1, ztmpi2, ztmpj1, ztmpj2 + REAL(wp), POINTER, DIMENSION(:,: ) :: zenv, ztmp, zmsk, zri, zrj, zhbat + !! + NAMELIST/namzgr_sco/ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & + & rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('zgr_sco') + ! + CALL wrk_alloc( jpi,jpj, zenv, ztmp, zmsk, zri, zrj, zhbat , ztmpi1, ztmpi2, ztmpj1, ztmpj2 ) + ! + REWIND( numnam_ref ) ! Namelist namzgr_sco in reference namelist : Sigma-stretching parameters + READ ( numnam_ref, namzgr_sco, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in reference namelist', lwp ) + + REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : Sigma-stretching parameters + READ ( numnam_cfg, namzgr_sco, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in configuration namelist', lwp ) + IF(lwm) WRITE ( numond, namzgr_sco ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'domzgr_sco : s-coordinate or hybrid z-s-coordinate' + WRITE(numout,*) '~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzgr_sco' + WRITE(numout,*) ' stretching coeffs ' + WRITE(numout,*) ' maximum depth of s-bottom surface (>0) rn_sbot_max = ',rn_sbot_max + WRITE(numout,*) ' minimum depth of s-bottom surface (>0) rn_sbot_min = ',rn_sbot_min + WRITE(numout,*) ' Critical depth rn_hc = ',rn_hc + WRITE(numout,*) ' maximum cut-off r-value allowed rn_rmax = ',rn_rmax + WRITE(numout,*) ' Song and Haidvogel 1994 stretching ln_s_sh94 = ',ln_s_sh94 + WRITE(numout,*) ' Song and Haidvogel 1994 stretching coefficients' + WRITE(numout,*) ' surface control parameter (0<=rn_theta<=20) rn_theta = ',rn_theta + WRITE(numout,*) ' bottom control parameter (0<=rn_thetb<= 1) rn_thetb = ',rn_thetb + WRITE(numout,*) ' stretching parameter (song and haidvogel) rn_bb = ',rn_bb + WRITE(numout,*) ' Siddorn and Furner 2012 stretching ln_s_sf12 = ',ln_s_sf12 + WRITE(numout,*) ' switching to sigma (T) or Z (F) at H<Hc ln_sigcrit = ',ln_sigcrit + WRITE(numout,*) ' Siddorn and Furner 2012 stretching coefficients' + WRITE(numout,*) ' stretchin parameter ( >1 surface; <1 bottom) rn_alpha = ',rn_alpha + WRITE(numout,*) ' e-fold length scale for transition region rn_efold = ',rn_efold + WRITE(numout,*) ' Surface cell depth (Zs) (m) rn_zs = ',rn_zs + WRITE(numout,*) ' Bathymetry multiplier for Zb rn_zb_a = ',rn_zb_a + WRITE(numout,*) ' Offset for Zb rn_zb_b = ',rn_zb_b + WRITE(numout,*) ' Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' + ENDIF + + hift(:,:) = rn_sbot_min ! set the minimum depth for the s-coordinate + hifu(:,:) = rn_sbot_min + hifv(:,:) = rn_sbot_min + hiff(:,:) = rn_sbot_min + + ! ! set maximum ocean depth + bathy(:,:) = MIN( rn_sbot_max, bathy(:,:) ) + + DO jj = 1, jpj + DO ji = 1, jpi + IF( bathy(ji,jj) > 0._wp ) bathy(ji,jj) = MAX( rn_sbot_min, bathy(ji,jj) ) + END DO + END DO + ! ! ============================= + ! ! Define the envelop bathymetry (hbatt) + ! ! ============================= + ! use r-value to create hybrid coordinates + zenv(:,:) = bathy(:,:) + ! + ! set first land point adjacent to a wet cell to sbot_min as this needs to be included in smoothing + DO jj = 1, jpj + DO ji = 1, jpi + IF( bathy(ji,jj) == 0._wp ) THEN + iip1 = MIN( ji+1, jpi ) + ijp1 = MIN( jj+1, jpj ) + iim1 = MAX( ji-1, 1 ) + ijm1 = MAX( jj-1, 1 ) +!!gm BUG fix see ticket #1617 + IF( ( + bathy(iim1,ijm1) + bathy(ji,ijp1) + bathy(iip1,ijp1) & + & + bathy(iim1,jj ) + bathy(iip1,jj ) & + & + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1) ) > 0._wp ) & + & zenv(ji,jj) = rn_sbot_min +!!gm +!!gm IF( ( bathy(iip1,jj ) + bathy(iim1,jj ) + bathy(ji,ijp1 ) + bathy(ji,ijm1) + & +!!gm & bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN +!!gm zenv(ji,jj) = rn_sbot_min +!!gm ENDIF +!!gm end + ENDIF + END DO + END DO + + ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero + CALL lbc_lnk( zenv, 'T', 1._wp, 'no0' ) + ! + ! smooth the bathymetry (if required) + scosrf(:,:) = 0._wp ! ocean surface depth (here zero: no under ice-shelf sea) + scobot(:,:) = bathy(:,:) ! ocean bottom depth + ! + jl = 0 + zrmax = 1._wp + ! + ! + ! set scaling factor used in reducing vertical gradients + zrfact = ( 1._wp - rn_rmax ) / ( 1._wp + rn_rmax ) + ! + ! initialise temporary evelope depth arrays + ztmpi1(:,:) = zenv(:,:) + ztmpi2(:,:) = zenv(:,:) + ztmpj1(:,:) = zenv(:,:) + ztmpj2(:,:) = zenv(:,:) + ! + ! initialise temporary r-value arrays + zri(:,:) = 1._wp + zrj(:,:) = 1._wp + ! ! ================ ! + DO WHILE( jl <= 10000 .AND. ( zrmax - rn_rmax ) > 1.e-8_wp ) ! Iterative loop ! + ! ! ================ ! + jl = jl + 1 + zrmax = 0._wp + ! we set zrmax from previous r-values (zri and zrj) first + ! if set after current r-value calculation (as previously) + ! we could exit DO WHILE prematurely before checking r-value + ! of current zenv + DO jj = 1, nlcj + DO ji = 1, nlci + zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) + END DO + END DO + zri(:,:) = 0._wp + zrj(:,:) = 0._wp + DO jj = 1, nlcj + DO ji = 1, nlci + iip1 = MIN( ji+1, nlci ) ! force zri = 0 on last line (ji=ncli+1 to jpi) + ijp1 = MIN( jj+1, nlcj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) + IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(iip1,jj) > 0._wp)) THEN + zri(ji,jj) = ( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) + END IF + IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(ji,ijp1) > 0._wp)) THEN + zrj(ji,jj) = ( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) + END IF + IF( zri(ji,jj) > rn_rmax ) ztmpi1(ji ,jj ) = zenv(iip1,jj ) * zrfact + IF( zri(ji,jj) < -rn_rmax ) ztmpi2(iip1,jj ) = zenv(ji ,jj ) * zrfact + IF( zrj(ji,jj) > rn_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact + IF( zrj(ji,jj) < -rn_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact + END DO + END DO + IF( lk_mpp ) CALL mpp_max( zrmax ) ! max over the global domain + ! + IF(lwp)WRITE(numout,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax + ! + DO jj = 1, nlcj + DO ji = 1, nlci + zenv(ji,jj) = MAX(zenv(ji,jj), ztmpi1(ji,jj), ztmpi2(ji,jj), ztmpj1(ji,jj), ztmpj2(ji,jj) ) + END DO + END DO + ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero + CALL lbc_lnk( zenv, 'T', 1._wp, 'no0' ) + ! ! ================ ! + END DO ! End loop ! + ! ! ================ ! + DO jj = 1, jpj + DO ji = 1, jpi + zenv(ji,jj) = MAX( zenv(ji,jj), rn_sbot_min ) ! set all points to avoid undefined scale value warnings + END DO + END DO + ! + ! Envelope bathymetry saved in hbatt + hbatt(:,:) = zenv(:,:) + IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0._wp ) THEN + CALL ctl_warn( ' s-coordinates are tapered in vicinity of the Equator' ) + DO jj = 1, jpj + DO ji = 1, jpi + ztaper = EXP( -(gphit(ji,jj)/8._wp)**2._wp ) + hbatt(ji,jj) = rn_sbot_max * ztaper + hbatt(ji,jj) * ( 1._wp - ztaper ) + END DO + END DO + ENDIF + ! + ! ! ============================== + ! ! hbatu, hbatv, hbatf fields + ! ! ============================== + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' zgr_sco: minimum depth of the envelop topography set to : ', rn_sbot_min + ENDIF + hbatu(:,:) = rn_sbot_min + hbatv(:,:) = rn_sbot_min + hbatf(:,:) = rn_sbot_min + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! NO vector opt. + hbatu(ji,jj) = 0.50_wp * ( hbatt(ji ,jj) + hbatt(ji+1,jj ) ) + hbatv(ji,jj) = 0.50_wp * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) ) + hbatf(ji,jj) = 0.25_wp * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) & + & + hbatt(ji+1,jj) + hbatt(ji+1,jj+1) ) + END DO + END DO + + ! + ! Apply lateral boundary condition +!!gm ! CAUTION: retain non zero value in the initial file this should be OK for orca cfg, not for EEL + zhbat(:,:) = hbatu(:,:) ; CALL lbc_lnk( hbatu, 'U', 1._wp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatu(ji,jj) == 0._wp ) THEN + !No worries about the following line when ln_wd == .true. + IF( zhbat(ji,jj) == 0._wp ) hbatu(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0._wp ) hbatu(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + zhbat(:,:) = hbatv(:,:) ; CALL lbc_lnk( hbatv, 'V', 1._wp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatv(ji,jj) == 0._wp ) THEN + IF( zhbat(ji,jj) == 0._wp ) hbatv(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0._wp ) hbatv(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + zhbat(:,:) = hbatf(:,:) ; CALL lbc_lnk( hbatf, 'F', 1._wp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatf(ji,jj) == 0._wp ) THEN + IF( zhbat(ji,jj) == 0._wp ) hbatf(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0._wp ) hbatf(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + +!!bug: key_helsinki a verifer + hift(:,:) = MIN( hift(:,:), hbatt(:,:) ) + hifu(:,:) = MIN( hifu(:,:), hbatu(:,:) ) + hifv(:,:) = MIN( hifv(:,:), hbatv(:,:) ) + hiff(:,:) = MIN( hiff(:,:), hbatf(:,:) ) + + IF( nprint == 1 .AND. lwp ) THEN + WRITE(numout,*) ' MAX val hif t ', MAXVAL( hift (:,:) ), ' f ', MAXVAL( hiff (:,:) ), & + & ' u ', MAXVAL( hifu (:,:) ), ' v ', MAXVAL( hifv (:,:) ) + WRITE(numout,*) ' MIN val hif t ', MINVAL( hift (:,:) ), ' f ', MINVAL( hiff (:,:) ), & + & ' u ', MINVAL( hifu (:,:) ), ' v ', MINVAL( hifv (:,:) ) + WRITE(numout,*) ' MAX val hbat t ', MAXVAL( hbatt(:,:) ), ' f ', MAXVAL( hbatf(:,:) ), & + & ' u ', MAXVAL( hbatu(:,:) ), ' v ', MAXVAL( hbatv(:,:) ) + WRITE(numout,*) ' MIN val hbat t ', MINVAL( hbatt(:,:) ), ' f ', MINVAL( hbatf(:,:) ), & + & ' u ', MINVAL( hbatu(:,:) ), ' v ', MINVAL( hbatv(:,:) ) + ENDIF +!! helsinki + + ! ! ======================= + ! ! s-ccordinate fields (gdep., e3.) + ! ! ======================= + ! + ! non-dimensional "sigma" for model level depth at w- and t-levels + + +!======================================================================== +! Song and Haidvogel 1994 (ln_s_sh94=T) +! Siddorn and Furner 2012 (ln_sf12=T) +! or tanh function (both false) +!======================================================================== + IF ( ln_s_sh94 ) THEN + CALL s_sh94() + ELSE IF ( ln_s_sf12 ) THEN + CALL s_sf12() + ELSE + CALL s_tanh() + ENDIF + + CALL lbc_lnk( e3t_0 , 'T', 1._wp ) + CALL lbc_lnk( e3u_0 , 'U', 1._wp ) + CALL lbc_lnk( e3v_0 , 'V', 1._wp ) + CALL lbc_lnk( e3f_0 , 'F', 1._wp ) + CALL lbc_lnk( e3w_0 , 'W', 1._wp ) + CALL lbc_lnk( e3uw_0, 'U', 1._wp ) + CALL lbc_lnk( e3vw_0, 'V', 1._wp ) + ! + WHERE( e3t_0 (:,:,:) == 0._wp ) e3t_0 (:,:,:) = 1._wp + WHERE( e3u_0 (:,:,:) == 0._wp ) e3u_0 (:,:,:) = 1._wp + WHERE( e3v_0 (:,:,:) == 0._wp ) e3v_0 (:,:,:) = 1._wp + WHERE( e3f_0 (:,:,:) == 0._wp ) e3f_0 (:,:,:) = 1._wp + WHERE( e3w_0 (:,:,:) == 0._wp ) e3w_0 (:,:,:) = 1._wp + WHERE( e3uw_0(:,:,:) == 0._wp ) e3uw_0(:,:,:) = 1._wp + WHERE( e3vw_0(:,:,:) == 0._wp ) e3vw_0(:,:,:) = 1._wp + + +!!gm I don't like that HERE we are supposed to set the reference coordinate (i.e. _0 arrays) +!!gm and only that !!!!! +!!gm THIS should be removed from here ! + gdept_n(:,:,:) = gdept_0(:,:,:) + gdepw_n(:,:,:) = gdepw_0(:,:,:) + gde3w_n(:,:,:) = gde3w_0(:,:,:) + e3t_n (:,:,:) = e3t_0 (:,:,:) + e3u_n (:,:,:) = e3u_0 (:,:,:) + e3v_n (:,:,:) = e3v_0 (:,:,:) + e3f_n (:,:,:) = e3f_0 (:,:,:) + e3w_n (:,:,:) = e3w_0 (:,:,:) + e3uw_n (:,:,:) = e3uw_0 (:,:,:) + e3vw_n (:,:,:) = e3vw_0 (:,:,:) +!!gm and obviously in the following, use the _0 arrays until the end of this subroutine +!! gm end +!! + ! HYBRID : + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, jpkm1 + IF( scobot(ji,jj) >= gdept_n(ji,jj,jk) ) mbathy(ji,jj) = MAX( 2, jk ) + END DO + END DO + END DO + IF( nprint == 1 .AND. lwp ) WRITE(numout,*) ' MIN val mbathy h90 ', MINVAL( mbathy(:,:) ), & + & ' MAX ', MAXVAL( mbathy(:,:) ) + + IF( nprint == 1 .AND. lwp ) THEN ! min max values over the local domain + WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) + 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 DO + IF(lwp) THEN ! selected vertical profiles + WRITE(numout,*) + WRITE(numout,*) ' domzgr: vertical coordinates : point (1,1,k) bathy = ', bathy(1,1), hbatt(1,1) + WRITE(numout,*) ' ~~~~~~ --------------------' + WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") + WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(1,1,jk), gdepw_0(1,1,jk), & + & e3t_0 (1,1,jk) , e3w_0 (1,1,jk) , jk=1,jpk ) + DO jj = mj0(20), mj1(20) + DO ji = mi0(20), mi1(20) + WRITE(numout,*) + WRITE(numout,*) ' domzgr: vertical coordinates : point (20,20,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) + WRITE(numout,*) ' ~~~~~~ --------------------' + WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") + WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & + & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) + END DO + END DO + DO jj = mj0(74), mj1(74) + DO ji = mi0(100), mi1(100) + WRITE(numout,*) + WRITE(numout,*) ' domzgr: vertical coordinates : point (100,74,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) + WRITE(numout,*) ' ~~~~~~ --------------------' + WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") + WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & + & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) + END DO + END DO + ENDIF + ! + !================================================================================ + ! check the coordinate makes sense + !================================================================================ + DO ji = 1, jpi + DO jj = 1, jpj + ! + IF( hbatt(ji,jj) > 0._wp) THEN + DO jk = 1, mbathy(ji,jj) + ! check coordinate is monotonically increasing + IF (e3w_n(ji,jj,jk) <= 0._wp .OR. e3t_n(ji,jj,jk) <= 0._wp ) THEN + WRITE(ctmp1,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'e3w',e3w_n(ji,jj,:) + WRITE(numout,*) 'e3t',e3t_n(ji,jj,:) + CALL ctl_stop( ctmp1 ) + ENDIF + ! and check it has never gone negative + IF( gdepw_n(ji,jj,jk) < 0._wp .OR. gdept_n(ji,jj,jk) < 0._wp ) THEN + WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'gdepw',gdepw_n(ji,jj,:) + WRITE(numout,*) 'gdept',gdept_n(ji,jj,:) + CALL ctl_stop( ctmp1 ) + ENDIF + ! and check it never exceeds the total depth + IF( gdepw_n(ji,jj,jk) > hbatt(ji,jj) ) THEN + WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'gdepw',gdepw_n(ji,jj,:) + CALL ctl_stop( ctmp1 ) + ENDIF + END DO + ! + DO jk = 1, mbathy(ji,jj)-1 + ! and check it never exceeds the total depth + IF( gdept_n(ji,jj,jk) > hbatt(ji,jj) ) THEN + WRITE(ctmp1,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk + WRITE(numout,*) 'gdept',gdept_n(ji,jj,:) + CALL ctl_stop( ctmp1 ) + ENDIF + END DO + ENDIF + END DO + END DO + ! + CALL wrk_dealloc( jpi, jpj, zenv, ztmp, zmsk, zri, zrj, zhbat , ztmpi1, ztmpi2, ztmpj1, ztmpj2 ) + ! + IF( nn_timing == 1 ) CALL timing_stop('zgr_sco') + ! + END SUBROUTINE zgr_sco + + + SUBROUTINE s_sh94() + !!---------------------------------------------------------------------- + !! *** ROUTINE s_sh94 *** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch using the Song and Haidvogel 1994 + !! mixed S/sigma coordinate + !! + !! Reference : Song and Haidvogel 1994. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop argument + REAL(wp) :: zcoeft, zcoefw ! temporary scalars + REAL(wp) :: ztmpu, ztmpv, ztmpf + REAL(wp) :: ztmpu1, ztmpv1, ztmpf1 + ! + REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 + REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 + !!---------------------------------------------------------------------- + + CALL wrk_alloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) + CALL wrk_alloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + + z_gsigw3 = 0._wp ; z_gsigt3 = 0._wp ; z_gsi3w3 = 0._wp + z_esigt3 = 0._wp ; z_esigw3 = 0._wp + z_esigtu3 = 0._wp ; z_esigtv3 = 0._wp ; z_esigtf3 = 0._wp + z_esigwu3 = 0._wp ; z_esigwv3 = 0._wp + ! + DO ji = 1, jpi + DO jj = 1, jpj + ! + IF( hbatt(ji,jj) > rn_hc ) THEN !deep water, stretched sigma + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) + z_gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp) , rn_bb ) + END DO + ELSE ! shallow water, uniform sigma + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) / REAL(jpk-1,wp) + z_gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) + END DO + ENDIF + ! + DO jk = 1, jpkm1 + z_esigt3(ji,jj,jk ) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) + z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) + END DO + z_esigw3(ji,jj,1 ) = 2._wp * ( z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 ) ) + z_esigt3(ji,jj,jpk) = 2._wp * ( z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk) ) + ! + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w3(ji,jj,1) = 0.5_wp * z_esigw3(ji,jj,1) + DO jk = 2, jpk + z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) + END DO + ! + DO jk = 1, jpk + zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) + zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) + gdept_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) + gdepw_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) + gde3w_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) + END DO + ! + END DO ! for all jj's + END DO ! for all ji's + + DO ji = 1, jpim1 + DO jj = 1, jpjm1 + ! extended for Wetting/Drying case + ztmpu = hbatt(ji,jj)+hbatt(ji+1,jj) + ztmpv = hbatt(ji,jj)+hbatt(ji,jj+1) + ztmpf = hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) + ztmpu1 = hbatt(ji,jj)*hbatt(ji+1,jj) + ztmpv1 = hbatt(ji,jj)*hbatt(ji,jj+1) + ztmpf1 = MIN(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) * & + & MAX(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) + DO jk = 1, jpk + z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & + & / ztmpu + z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & + & / ztmpu + + z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & + & / ztmpv + z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & + & / ztmpv + + z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & + & + hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & + & + hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & + & + hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf + + ! + e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + ! + e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) + END DO + END DO + END DO + ! + CALL wrk_dealloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) + CALL wrk_dealloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + ! + END SUBROUTINE s_sh94 + + + SUBROUTINE s_sf12 + !!---------------------------------------------------------------------- + !! *** ROUTINE s_sf12 *** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch using the Siddorn and Furner 2012? + !! mixed S/sigma/Z coordinate + !! + !! This method allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! + !! Reference : Siddorn and Furner 2012 (submitted Ocean modelling). + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop argument + REAL(wp) :: zsmth ! smoothing around critical depth + REAL(wp) :: zzs, zzb ! Surface and bottom cell thickness in sigma space + REAL(wp) :: ztmpu, ztmpv, ztmpf + REAL(wp) :: ztmpu1, ztmpv1, ztmpf1 + ! + REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 + REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 + !!---------------------------------------------------------------------- + ! + CALL wrk_alloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) + CALL wrk_alloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + + z_gsigw3 = 0._wp ; z_gsigt3 = 0._wp ; z_gsi3w3 = 0._wp + z_esigt3 = 0._wp ; z_esigw3 = 0._wp + z_esigtu3 = 0._wp ; z_esigtv3 = 0._wp ; z_esigtf3 = 0._wp + z_esigwu3 = 0._wp ; z_esigwv3 = 0._wp + + DO ji = 1, jpi + DO jj = 1, jpj + + IF (hbatt(ji,jj)>rn_hc) THEN !deep water, stretched sigma + + zzb = hbatt(ji,jj)*rn_zb_a + rn_zb_b ! this forces a linear bottom cell depth relationship with H,. + ! could be changed by users but care must be taken to do so carefully + zzb = 1.0_wp-(zzb/hbatt(ji,jj)) + + zzs = rn_zs / hbatt(ji,jj) + + IF (rn_efold /= 0.0_wp) THEN + zsmth = tanh( (hbatt(ji,jj)- rn_hc ) / rn_efold ) + ELSE + zsmth = 1.0_wp + ENDIF + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp) + ENDDO + z_gsigw3(ji,jj,:) = fgamma( z_gsigw3(ji,jj,:), zzb, zzs, zsmth ) + z_gsigt3(ji,jj,:) = fgamma( z_gsigt3(ji,jj,:), zzb, zzs, zsmth ) + + ELSE IF (ln_sigcrit) THEN ! shallow water, uniform sigma + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) + END DO + + ELSE ! shallow water, z coordinates + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) + END DO + + ENDIF + + DO jk = 1, jpkm1 + z_esigt3(ji,jj,jk) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) + z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) + END DO + z_esigw3(ji,jj,1 ) = 2.0_wp * (z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 )) + z_esigt3(ji,jj,jpk) = 2.0_wp * (z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk)) + + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w3(ji,jj,1) = 0.5 * z_esigw3(ji,jj,1) + DO jk = 2, jpk + z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) + END DO + + DO jk = 1, jpk + gdept_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) + gdepw_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) + gde3w_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) + END DO + + ENDDO ! for all jj's + ENDDO ! for all ji's + + DO ji=1,jpi-1 + DO jj=1,jpj-1 + + ! extend to suit for Wetting/Drying case + ztmpu = hbatt(ji,jj)+hbatt(ji+1,jj) + ztmpv = hbatt(ji,jj)+hbatt(ji,jj+1) + ztmpf = hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) + ztmpu1 = hbatt(ji,jj)*hbatt(ji+1,jj) + ztmpv1 = hbatt(ji,jj)*hbatt(ji,jj+1) + ztmpf1 = MIN(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) * & + & MAX(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) + DO jk = 1, jpk + z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & + & / ztmpu + z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & + & / ztmpu + z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & + & / ztmpv + z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & + & / ztmpv + + z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & + & + hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & + & + hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & + & + hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf + + ! Code prior to wetting and drying option (for reference) + !z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & + ! /( hbatt(ji,jj)+hbatt(ji+1,jj) ) + ! + !z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & + ! /( hbatt(ji,jj)+hbatt(ji+1,jj) ) + ! + !z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & + ! /( hbatt(ji,jj)+hbatt(ji,jj+1) ) + ! + !z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & + ! /( hbatt(ji,jj)+hbatt(ji,jj+1) ) + ! + !z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & + ! & +hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & + ! +hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & + ! & +hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) & + ! /( hbatt(ji ,jj )+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) + + e3t_0(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) + e3u_0(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) + e3v_0(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) + e3f_0(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) + ! + e3w_0 (ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) + e3uw_0(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) + e3vw_0(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) + END DO + + ENDDO + ENDDO + ! + CALL lbc_lnk(e3t_0 ,'T',1.) ; CALL lbc_lnk(e3u_0 ,'T',1.) + CALL lbc_lnk(e3v_0 ,'T',1.) ; CALL lbc_lnk(e3f_0 ,'T',1.) + CALL lbc_lnk(e3w_0 ,'T',1.) + CALL lbc_lnk(e3uw_0,'T',1.) ; CALL lbc_lnk(e3vw_0,'T',1.) + ! + CALL wrk_dealloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) + CALL wrk_dealloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + ! + END SUBROUTINE s_sf12 + + + SUBROUTINE s_tanh() + !!---------------------------------------------------------------------- + !! *** ROUTINE s_tanh*** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch + !! + !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop argument + REAL(wp) :: zcoeft, zcoefw ! temporary scalars + REAL(wp), POINTER, DIMENSION(:) :: z_gsigw, z_gsigt, z_gsi3w + REAL(wp), POINTER, DIMENSION(:) :: z_esigt, z_esigw + !!---------------------------------------------------------------------- + + CALL wrk_alloc( jpk, z_gsigw, z_gsigt, z_gsi3w ) + CALL wrk_alloc( jpk, z_esigt, z_esigw ) + + z_gsigw = 0._wp ; z_gsigt = 0._wp ; z_gsi3w = 0._wp + z_esigt = 0._wp ; z_esigw = 0._wp + + DO jk = 1, jpk + z_gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) + z_gsigt(jk) = -fssig( REAL(jk,wp) ) + END DO + IF( nprint == 1 .AND. lwp ) WRITE(numout,*) 'z_gsigw 1 jpk ', z_gsigw(1), z_gsigw(jpk) + ! + ! Coefficients for vertical scale factors at w-, t- levels +!!gm bug : define it from analytical function, not like juste bellow.... +!!gm or betteroffer the 2 possibilities.... + DO jk = 1, jpkm1 + z_esigt(jk ) = z_gsigw(jk+1) - z_gsigw(jk) + z_esigw(jk+1) = z_gsigt(jk+1) - z_gsigt(jk) + END DO + z_esigw( 1 ) = 2._wp * ( z_gsigt(1 ) - z_gsigw(1 ) ) + z_esigt(jpk) = 2._wp * ( z_gsigt(jpk) - z_gsigw(jpk) ) + ! + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w(1) = 0.5_wp * z_esigw(1) + DO jk = 2, jpk + z_gsi3w(jk) = z_gsi3w(jk-1) + z_esigw(jk) + END DO +!!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) + DO jk = 1, jpk + zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) + zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) + gdept_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) + gdepw_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) + gde3w_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) + END DO +!!gm: e3uw, e3vw can be suppressed (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, jpk + e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) + e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) + e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) + e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) + ! + e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) + e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) + e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) + END DO + END DO + END DO + ! + CALL wrk_dealloc( jpk, z_gsigw, z_gsigt, z_gsi3w ) + CALL wrk_dealloc( jpk, z_esigt, z_esigw ) + ! + END SUBROUTINE s_tanh + + + FUNCTION fssig( pk ) RESULT( pf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fssig *** + !! + !! ** Purpose : provide the analytical function in s-coordinate + !! + !! ** Method : the function provide the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pk ! continuous "k" coordinate + REAL(wp) :: pf ! sigma value + !!---------------------------------------------------------------------- + ! + pf = ( TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb ) ) & + & - TANH( rn_thetb * rn_theta ) ) & + & * ( COSH( rn_theta ) & + & + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) ) ) & + & / ( 2._wp * SINH( rn_theta ) ) + ! + END FUNCTION fssig + + + FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fssig1 *** + !! + !! ** Purpose : provide the Song and Haidvogel version of the analytical function in s-coordinate + !! + !! ** Method : the function provides the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pk1 ! continuous "k" coordinate + REAL(wp), INTENT(in) :: pbb ! Stretching coefficient + REAL(wp) :: pf1 ! sigma value + !!---------------------------------------------------------------------- + ! + IF ( rn_theta == 0 ) then ! uniform sigma + pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) + ELSE ! stretched sigma + pf1 = ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta ) & + & + pbb * ( (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta ) ) & + & / ( 2._wp * TANH( 0.5_wp * rn_theta ) ) ) + ENDIF + ! + END FUNCTION fssig1 + + + FUNCTION fgamma( pk1, pzb, pzs, psmth) RESULT( p_gamma ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fgamma *** + !! + !! ** Purpose : provide analytical function for the s-coordinate + !! + !! ** Method : the function provides the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !! + !! This method allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! Reference : Siddorn and Furner, in prep + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: pk1(jpk) ! continuous "k" coordinate + REAL(wp) :: p_gamma(jpk) ! stretched coordinate + REAL(wp), INTENT(in ) :: pzb ! Bottom box depth + REAL(wp), INTENT(in ) :: pzs ! surface box depth + REAL(wp), INTENT(in ) :: psmth ! Smoothing parameter + ! + INTEGER :: jk ! dummy loop index + REAL(wp) :: za1,za2,za3 ! local scalar + REAL(wp) :: zn1,zn2 ! - - + REAL(wp) :: za,zb,zx ! - - + !!---------------------------------------------------------------------- + ! + zn1 = 1._wp / REAL( jpkm1, wp ) + zn2 = 1._wp - zn1 + ! + za1 = (rn_alpha+2.0_wp)*zn1**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn1**(rn_alpha+2.0_wp) + za2 = (rn_alpha+2.0_wp)*zn2**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn2**(rn_alpha+2.0_wp) + za3 = (zn2**3.0_wp - za2)/( zn1**3.0_wp - za1) + ! + za = pzb - za3*(pzs-za1)-za2 + za = za/( zn2-0.5_wp*(za2+zn2**2.0_wp) - za3*(zn1-0.5_wp*(za1+zn1**2.0_wp) ) ) + zb = (pzs - za1 - za*( zn1-0.5_wp*(za1+zn1**2.0_wp ) ) ) / (zn1**3.0_wp - za1) + zx = 1.0_wp-za/2.0_wp-zb + ! + DO jk = 1, jpk + p_gamma(jk) = za*(pk1(jk)*(1.0_wp-pk1(jk)/2.0_wp))+zb*pk1(jk)**3.0_wp + & + & zx*( (rn_alpha+2.0_wp)*pk1(jk)**(rn_alpha+1.0_wp)- & + & (rn_alpha+1.0_wp)*pk1(jk)**(rn_alpha+2.0_wp) ) + p_gamma(jk) = p_gamma(jk)*psmth+pk1(jk)*(1.0_wp-psmth) + END DO + ! + END FUNCTION fgamma + + !!====================================================================== +END MODULE domzgr diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/dtatsd.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/dtatsd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5cd67a292ad42b5a13b0a13862218c49481ae69d --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/dtatsd.f90 @@ -0,0 +1,265 @@ +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 + suppression of CPP keys + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_tsd : read and time interpolated ocean Temperature & Salinity Data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE phycst ! physical constants + USE lib_mpp ! MPP library + USE wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_tsd_init ! called by opa.F90 + PUBLIC dta_tsd ! called by istate.F90 and tradmp.90 + + LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag + LOGICAL , PUBLIC :: ln_tsd_tradmp !: 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: dtatsd.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./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 :: ierr0, ierr1, ierr2, ierr3 ! temporary 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_tradmp, cn_dir, sn_tem, sn_sal + INTEGER :: ios + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dta_tsd_init') + ! + ! 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', lwp ) + + 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', lwp ) + IF(lwm) WRITE ( numond, namtsd ) + + IF( PRESENT( ld_tradmp ) ) ln_tsd_tradmp = .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_tradmp = ', ln_tsd_tradmp + WRITE(numout,*) + IF( .NOT.ln_tsd_init .AND. .NOT.ln_tsd_tradmp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' T & S data not used' + ENDIF + ENDIF + ! + IF( ln_rstart .AND. ln_tsd_init ) THEN + CALL ctl_warn( 'dta_tsd_init: ocean restart and T & S data intialisation, ', & + & 'we keep the restart T & S values and set ln_tsd_init to FALSE' ) + ln_tsd_init = .FALSE. + ENDIF + ! + ! ! allocate the arrays (if necessary) + IF( ln_tsd_init .OR. ln_tsd_tradmp ) 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' ) + ! + ENDIF + ! + IF( nn_timing == 1 ) CALL timing_stop('dta_tsd_init') + ! + 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_tradmp=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 + REAL(wp), POINTER, DIMENSION(:) :: ztp, zsp ! 1D workspace + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('dta_tsd') + ! + CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! + ! + ! + ! !== ORCA_R2 configuration and T & S damping ==! + IF( cp_cfg == "orca" .AND. jp_cfg == 2 .AND. ln_tsd_tradmp ) 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 + ! + 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 ==! + ! + CALL wrk_alloc( jpk, ztp, zsp ) + ! + 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 + ! + CALL wrk_dealloc( jpk, ztp, zsp ) + ! + 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_tradmp ) 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 + ! + IF( nn_timing == 1 ) CALL timing_stop('dta_tsd') + ! + END SUBROUTINE dta_tsd + + !!====================================================================== +END MODULE dtatsd diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/eosbn2.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/eosbn2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..94f776418c763d6af783a2b99d009cc42664ec01 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/eosbn2.f90 @@ -0,0 +1,1647 @@ +MODULE eosbn2 + !!============================================================================== + !! *** MODULE eosbn2 *** + !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency + !!============================================================================== + !! History : OPA ! 1989-03 (O. Marti) Original code + !! 6.0 ! 1994-07 (G. Madec, M. Imbard) add bn2 + !! 6.0 ! 1994-08 (G. Madec) Add Jackett & McDougall eos + !! 7.0 ! 1996-01 (G. Madec) statement function for e3 + !! 8.1 ! 1997-07 (G. Madec) density instead of volumic mass + !! - ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure gradient + !! 8.2 ! 2001-09 (M. Ben Jelloul) bugfix on linear eos + !! NEMO 1.0 ! 2002-10 (G. Madec) add eos_init + !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d + !! - ! 2003-08 (G. Madec) F90, free form + !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp + !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation + !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state + !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module + !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 + !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! eos : generic interface of the equation of state + !! eos_insitu : Compute the in situ density + !! eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass + !! eos_insitu_2d : Compute the in situ density for 2d fields + !! bn2 : Compute the Brunt-Vaisala frequency + !! eos_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 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 wrk_nemo ! Memory Allocation + 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 ! determine if eos_pt_from_ct is used to compute sst_m + LOGICAL , PUBLIC :: ln_EOS80 ! determine if eos_pt_from_ct is used to compute sst_m + LOGICAL , PUBLIC :: ln_SEOS ! determine if eos_pt_from_ct is used to compute sst_m + + ! 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 + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: eosbn2.F90 6505 2016-05-01 16:11:06Z gm $ + !! Software governed by the CeCILL licence (./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 Celcius, 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 Celcius, 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 [Celcius] + ! ! 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( nn_timing == 1 ) 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 : ', ovlap=1, kdim=jpk ) + ! + IF( nn_timing == 1 ) 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 [Celcius] + ! ! 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( nn_timing == 1 ) CALL timing_start('eos-pot') + ! + 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 + ! + 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 + + 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 : ', ovlap=1, kdim=jpk ) + ! + IF( nn_timing == 1 ) 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 [Celcius] + ! ! 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( nn_timing == 1 ) 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, 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( prd, 'T', 1. ) ! Lateral boundary conditions + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = 1, jpjm1 + DO ji = 1, 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( prd, 'T', 1. ) ! Lateral boundary conditions + ! + END SELECT + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) + ! + IF( nn_timing == 1 ) 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( nn_timing == 1 ) 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 + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + 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 : ', ovlap=1, kdim=jpk ) + ! + IF( nn_timing == 1 ) 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( nn_timing == 1 ) 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, 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 + ! + CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions + CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = 1, jpjm1 + DO ji = 1, 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 + ! + CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions + CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) + ! + CASE DEFAULT + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + 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( nn_timing == 1 ) 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( nn_timing == 1 ) CALL timing_start('rab_2d') + ! + 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 + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + END SELECT + ! + IF( nn_timing == 1 ) CALL timing_stop('rab_2d') + ! + 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 [Celcius,psu] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celcius-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( nn_timing == 1 ) 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) * tmask(ji,jj,jk) + END DO + END DO + END DO + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk ) + ! + IF( nn_timing == 1 ) 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. [Celcius] + !! + !! ** 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 [Celcius] + 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 [Celcius] + ! + 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 ( nn_timing == 1 ) 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( nn_timing == 1 ) 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 [Celcius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celcius 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 [Celcius] + ! + 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 + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + END SELECT + ! + END SUBROUTINE eos_fzp_2d + + + SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_fzp *** + !! + !! ** Purpose : Compute the freezing point temperature [Celcius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celcius 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 [Celcius] + ! + 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 + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + 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( nn_timing == 1 ) 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 + IF(lwp) WRITE(numout,cform_err) + IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos + nstop = nstop + 1 + ! + END SELECT + ! + IF( nn_timing == 1 ) 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', lwp ) + ! + 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', lwp ) + 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 ==! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' use of simplified eos: rhd(dT=T-10,dS=S-35,Z) = ' + WRITE(numout,*) ' [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' + WRITE(numout,*) + 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,*) ' model uses Conservative Temperature' + WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' + ELSE + WRITE(numout,*) ' model does not use Conservative Temperature' + ENDIF + ENDIF + ! + IF(lwp) WRITE(numout,*) + 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/V4.0/nemo_sources/tools/DOMAINcfg/src/errioipsl.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/errioipsl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d9ca60ea28b648969d36bb89612fa71c4fdaaf6f --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/flincom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/flincom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e53a386d8eddcec6db35afad783064ce483e7e25 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/fliocom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/fliocom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..963993862990aaf99e93435c65633516fd0cb60e --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/getincom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/getincom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7f8d6fcfac935b80ec63cee60af37a0e671ee48 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/histcom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/histcom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4d5a17419466b4a1d36476c1edba3e06cc5ef69e --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/in_out_manager.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/in_out_manager.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e8d8e5b82716c5c586c6569fb0fd8902fb824385 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/in_out_manager.f90 @@ -0,0 +1,140 @@ +MODULE in_out_manager + !!====================================================================== + !! *** MODULE in_out_manager *** + !! I/O manager utilities : Defines run parameters together with logical units + !!===================================================================== + !! History : 1.0 ! 2002-06 (G. Madec) original code + !! 2.0 ! 2006-07 (S. Masson) iom, add ctl_stop, ctl_warn + !! 3.0 ! 2008-06 (G. Madec) add ctmp4 to ctmp10 + !! 3.2 ! 2009-08 (S. MAsson) add new ctl_opn + !! 3.3 ! 2010-10 (A. Coward) add NetCDF4 usage + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameter + USE nc4interface ! NetCDF4 interface + + IMPLICIT NONE + PUBLIC + + + ! + !!---------------------------------------------------------------------- + !! namrun namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(lc) :: cn_exp !: experiment name used for output filename + CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input) + CHARACTER(lc) :: cn_ocerst_indir !: restart input directory + CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output) + CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory + LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file + LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) + INTEGER :: nn_no !: job number + INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) + INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) + INTEGER :: nn_it000 !: index of the first time step + INTEGER :: nn_itend !: index of the last time step + INTEGER :: nn_date0 !: initial calendar date aammjj + INTEGER :: nn_time0 !: initial time of day in hhmm + INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: nn_istate !: initial state output flag (0/1) + INTEGER :: nn_write !: model standard output frequency + INTEGER :: nn_stock !: restart file frequency + INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times + LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) + LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard + LOGICAL :: ln_clobber !: clobber (overwrite) an existing file + INTEGER :: nn_chunksz !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) +!$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 :: no !: job number + 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) + INTEGER :: nwrite !: model standard output frequency + INTEGER :: nstock !: restart file frequency + INTEGER, DIMENSION(10) :: nstocklist !: restart dump times + + !!---------------------------------------------------------------------- + !! 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 + INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) + INTEGER :: numrow !: logical unit for ocean restart (write) + INTEGER :: nrst_lst !: number of restart to output next + + !!---------------------------------------------------------------------- + !! output monitoring + !!---------------------------------------------------------------------- + LOGICAL :: ln_ctl !: run control for debugging + INTEGER :: nn_timing !: run control for timing + INTEGER :: nn_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 :: nn_bench !: benchmark parameter (0/1) + INTEGER :: nn_bit_cmp = 0 !: bit reproducibility (0/1) + + ! + INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt, nbench !: 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 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 :: numsol = -1 !: logical unit for solver 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 :: nstop = 0 !: error flag (=number of reason for a premature stop run) + 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 + CHARACTER(lc) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: + CHARACTER(lc) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: in_out_manager.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!===================================================================== +END MODULE in_out_manager diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/ioipsl.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/ioipsl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99076239a3ec42767da20b274f35a3bc2dc3a2fc --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/iom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c1c4db95c3e46aeeb407e20beba32f6e859a4a49 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom.f90 @@ -0,0 +1,951 @@ +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 + !!-------------------------------------------------------------------- + + !!-------------------------------------------------------------------- + !! 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_gettime : read the time axis cdvar in the file + !! 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 iom_nf90 ! NetCDF format with native NetCDF library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PUBLIC ! must be public to be able to access iom_def through iom + + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag + PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_gettime, iom_rstput, iom_put + PUBLIC iom_getatt, iom_use, iom_context_finalize + + 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 + + INTERFACE iom_get + MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d + END INTERFACE + INTERFACE iom_getatt + MODULE PROCEDURE iom_g0d_intatt + 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 + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom.F90 8572 2017-09-28 08:27:06Z cbricaud $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE iom_init( cdname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + + END SUBROUTINE iom_init + + + SUBROUTINE iom_swap( cdname ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_swap *** + !! + !! ** Purpose : swap context between different agrif grid for xmlio_server + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + ! + END SUBROUTINE iom_swap + + + SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof ) + !!--------------------------------------------------------------------- + !! *** 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) + INTEGER , INTENT(in ), OPTIONAL :: kiolib ! library used to open the file (default = jpnf90) + 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.) + + 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" or ".dimg" + 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 :: iolib ! library do we use to open the file + 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 + ! what library do we use to open the file? + IF( PRESENT(kiolib) ) THEN ; iolib = kiolib + ELSE ; iolib = jpnf90 + 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 + iln = INDEX(clname,'/') + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + ! which suffix should we use? + SELECT CASE (iolib) + CASE (jpnf90 ) ; clsuffix = '.nc' + CASE DEFAULT ; clsuffix = '' + END SELECT + ! 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 + 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 or RSTDIMG 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 + SELECT CASE (iolib) + CASE (jpnf90 ) ; CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar ) + CASE DEFAULT + END SELECT + 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 + !--------------------------------------------------------------------- + ! + 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 + SELECT CASE (iom_file(jf)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_close( jf ) + CASE DEFAULT + END SELECT + 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, 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 the dimensions + INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions + 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 + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; iom_varid = iom_nf90_varid ( kiomid, cdvar, iiv, kdimsz, kndims ) + CASE DEFAULT + END SELECT + 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(:) = 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) + ENDIF + ENDIF + ENDIF + ! + END FUNCTION iom_varid + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_get + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d( kiomid, cdvar, pvar, ktime ) + 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 + ! + 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 ! + ! + 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' ) + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_get( kiomid, idvar, pvar, itime ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_g0d + + SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(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 + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount ) + ENDIF + END SUBROUTINE iom_g1d + + SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) + 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) + ! + 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 ) + ENDIF + END SUBROUTINE iom_g2d + + SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) + 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) + ! + 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 ) + ENDIF + END SUBROUTINE iom_g3d + !!---------------------------------------------------------------------- + + SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & + & pv_r1d, pv_r2d, pv_r3d, & + & ktime , kstart, kcount, & + & lrowattr ) + !!----------------------------------------------------------------------- + !! *** 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 :: 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 ! + !--------------------------------------------------------------------- + ! + clname = iom_file(kiomid)%name ! esier to read + clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) + ! local definition of the domain ? + idom = kdom + ! 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 ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') + + 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 + IF( luse_jattr ) THEN + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) + ! Ok + CASE DEFAULT + END SELECT + ENDIF + + ! Search for the variable in the data base (eventually actualize data) + istop = nstop + idvar = iom_varid( kiomid, cdvar ) + ! + 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 .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) ) 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) = jpkdta + ELSE ; icnt(3) = jpk + 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 + + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, & + & pv_r1d, pv_r2d, pv_r3d ) + CASE DEFAULT + END SELECT + + 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( pv_r2d,'Z',-999.,'no0' ) + 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) == jpk ) THEN + CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) + 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 + + !--- 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 +!CDIR COLLAPSE + IF( zscf /= 1.) pv_r2d(:,:) = pv_r2d(:,:) * zscf +!CDIR COLLAPSE + IF( zofs /= 0.) pv_r2d(:,:) = pv_r2d(:,:) + zofs + ELSEIF( PRESENT(pv_r3d) ) THEN +!CDIR COLLAPSE + IF( zscf /= 1.) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf +!CDIR COLLAPSE + IF( zofs /= 0.) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs + ENDIF + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE iom_get_123d + + + SUBROUTINE iom_gettime( kiomid, ptime, cdvar, kntime, cdunits, cdcalendar ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_gettime *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + REAL(wp), DIMENSION(:) , INTENT( out) :: ptime ! the time axis + CHARACTER(len=*), OPTIONAL , INTENT(in ) :: cdvar ! time axis name + INTEGER , OPTIONAL , INTENT( out) :: kntime ! number of times in file + CHARACTER(len=*), OPTIONAL , INTENT( out) :: cdunits ! units attribute of time coordinate + CHARACTER(len=*), OPTIONAL , INTENT( out) :: cdcalendar ! calendar attribute of + ! + INTEGER, DIMENSION(1) :: kdimsz + INTEGER :: idvar ! id of the variable + CHARACTER(LEN=32) :: tname ! local name of time coordinate + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + IF ( PRESENT(cdvar) ) THEN + tname = cdvar + ELSE + tname = iom_file(kiomid)%uldname + ENDIF + IF( kiomid > 0 ) THEN + clinfo = 'iom_gettime, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(tname) + IF ( PRESENT(kntime) ) THEN + idvar = iom_varid( kiomid, tname, kdimsz = kdimsz ) + kntime = kdimsz(1) + ELSE + idvar = iom_varid( kiomid, tname ) + ENDIF + ! + ptime(:) = 0. ! default definition + IF( idvar > 0 ) THEN + IF( iom_file(kiomid)%ndims(idvar) == 1 ) THEN + IF( iom_file(kiomid)%luld(idvar) ) THEN + IF( iom_file(kiomid)%dimsz(1,idvar) <= size(ptime) ) THEN + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_gettime( kiomid, idvar, ptime, cdunits, cdcalendar ) + CASE DEFAULT + END SELECT + ELSE + WRITE(ctmp1,*) 'error with the size of ptime ',size(ptime),iom_file(kiomid)%dimsz(1,idvar) + CALL ctl_stop( trim(clinfo), trim(ctmp1) ) + ENDIF + ELSE + CALL ctl_stop( trim(clinfo), 'variable dimension is not unlimited... use iom_get' ) + ENDIF + ELSE + CALL ctl_stop( trim(clinfo), 'the variable has more than 1 dimension' ) + ENDIF + ELSE + CALL ctl_stop( trim(clinfo), 'variable not found in '//iom_file(kiomid)%name ) + ENDIF + ENDIF + ! + END SUBROUTINE iom_gettime + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_getatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_intatt( kiomid, cdatt, pvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT( out) :: pvar ! read field + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_getatt( kiomid, cdatt, pvar ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_g0d_intatt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_rstput + !!---------------------------------------------------------------------- + SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(wp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + INTEGER :: ivid ! variable id + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_rp0d + + SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + INTEGER :: ivid ! variable id + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_rp1d + + SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + INTEGER :: ivid ! variable id + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_rp2d + + SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + INTEGER :: ivid ! variable id + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + SELECT CASE (iom_file(kiomid)%iolib) + CASE (jpnf90 ) ; CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + CASE DEFAULT + END SELECT + ENDIF + ENDIF + END SUBROUTINE iom_rp3d + + + !!---------------------------------------------------------------------- + !! 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( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings + END SUBROUTINE iom_p0d + + SUBROUTINE iom_p1d( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:), INTENT(in) :: pfield1d + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings + END SUBROUTINE iom_p1d + + SUBROUTINE iom_p2d( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:,:), INTENT(in) :: pfield2d + IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings + END SUBROUTINE iom_p2d + + SUBROUTINE iom_p3d( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d + IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings + END SUBROUTINE iom_p3d + !!---------------------------------------------------------------------- + + + + 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 + + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + iom_use = .FALSE. + END FUNCTION iom_use + + !!====================================================================== +END MODULE iom diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_def.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_def.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c9560c965efc033196a29b26af8d3ddfe46895f1 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_def.f90 @@ -0,0 +1,71 @@ +MODULE iom_def + !!===================================================================== + !! *** MODULE iom_def *** + !! IOM variables definitions + !!==================================================================== + !! History : 9.0 ! 06 09 (S. Masson) Original code + !! " ! 07 07 (D. Storkey) Add uldname + !!-------------------------------------------------------------------- + !!--------------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_def.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!--------------------------------------------------------------------------------- + + USE par_kind + + IMPLICIT NONE + PRIVATE + + INTEGER, PARAMETER, PUBLIC :: jpdom_data = 1 !: ( 1 :jpidta, 1 :jpjdta) + 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 :: jpnf90 = 101 !: Use nf90 library + + INTEGER, PARAMETER, PUBLIC :: jprstlib = jpnf90 !: restarts io library + + 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 = 600 !: 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 = 5 !: 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 + + TYPE, PUBLIC :: file_descriptor + CHARACTER(LEN=240) :: name !: name of the file + INTEGER :: nfid !: identifier of the file (0 if closed) + INTEGER :: iolib !: library used to read the file (jpnf90 or new formats, + !: jpioipsl option has been removed) + INTEGER :: nvars !: number of identified varibles in the file + INTEGER :: iduld !: id of the unlimited dimension + INTEGER :: lenuld !: length of the unlimited dimension (number of records in file) + INTEGER :: irec !: writing record position + CHARACTER(LEN=32) :: uldname !: name of the unlimited dimension + CHARACTER(LEN=32), DIMENSION(jpmax_vars) :: cn_var !: names of the variables + INTEGER, DIMENSION(jpmax_vars) :: nvid !: id of the variables + INTEGER, DIMENSION(jpmax_vars) :: ndims !: number of dimensions of the variables + LOGICAL, DIMENSION(jpmax_vars) :: luld !: variable using the unlimited dimension + INTEGER, DIMENSION(jpmax_dims,jpmax_vars) :: dimsz !: size of variables dimensions + REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables + REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables + END TYPE file_descriptor + TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files +!$AGRIF_END_DO_NOT_TREAT + + !!===================================================================== +END MODULE iom_def diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_nf90.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_nf90.f90 new file mode 100644 index 0000000000000000000000000000000000000000..451eb4f35d1d4dea7f52d097d87bcb4d41ff9566 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iom_nf90.f90 @@ -0,0 +1,582 @@ +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 + !!-------------------------------------------------------------------- + !!gm caution add !DIR nec: improved performance to be checked as well as no result changes + + !!-------------------------------------------------------------------- + !! 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_gettime : read the time axis kvid in the file + !! 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_gettime, iom_nf90_rstput + PUBLIC iom_nf90_getatt + + INTERFACE iom_nf90_get + MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d + END INTERFACE + INTERFACE iom_nf90_getatt + MODULE PROCEDURE iom_nf90_intatt + END INTERFACE + INTERFACE iom_nf90_rstput + MODULE PROCEDURE iom_nf90_rp0123d + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_nf90.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar ) + !!--------------------------------------------------------------------- + !! *** 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: + + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: cltmp ! temporary character + INTEGER :: iln ! lengths of character + INTEGER :: istop ! temporary storage of nstop + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: idmy ! dummy variable + INTEGER :: jl ! loop variable + INTEGER :: ichunk ! temporary storage of nn_chunksz + INTEGER :: imode ! creation mode flag: NF90_CLOBBER or NF90_NOCLOBBER or NF90_HDF5 + INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5 + LOGICAL :: llclobber ! local definition of ln_clobber + !--------------------------------------------------------------------- + + clinfo = ' iom_nf90_open ~~~ ' + istop = nstop ! store the actual value of nstop + 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 does not 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 + WRITE(cltmp,'(a,a,i4.4,a)') 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, 'z', jpk , idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 't', NF90_UNLIMITED, idmy ), clinfo) + ! global attributes + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/1 , 2 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/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)%iolib = jpnf90 + iom_file(kiomid)%nvars = 0 + iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode + CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) + IF ( iom_file(kiomid)%iduld .GE. 0 ) THEN + CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld, & + & name = iom_file(kiomid)%uldname, & + & len = iom_file(kiomid)%lenuld ), clinfo ) + ENDIF + IF(lwp) WRITE(numout,*) ' ---> '//TRIM(cdname)//' OK' + ELSE + kiomid = 0 ! return error flag + ENDIF + ! + END SUBROUTINE iom_nf90_open + + + SUBROUTINE iom_nf90_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_close *** + !! + !! ** Purpose : close an input file with NF90 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kiomid ! iom identifier of the file to be closed + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_close , file: '//TRIM(iom_file(kiomid)%name) + CALL iom_nf90_check(NF90_CLOSE(iom_file(kiomid)%nfid), clinfo) + ! + END SUBROUTINE iom_nf90_close + + + FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims ) + !!----------------------------------------------------------------------- + !! *** 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 + ! + 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(:) = 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) + ELSE + iom_nf90_varid = -1 ! variable not found, return error code: -1 + ENDIF + ! + END FUNCTION iom_nf90_varid + + + 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_intatt( kiomid, cdatt, pvar ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_intatt *** + !! + !! ** Purpose : read an integer attribute with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT( out) :: pvar ! read field + ! + INTEGER :: if90id ! temporary integer + LOGICAL :: llok ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr + IF( llok) THEN + clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + CALL iom_nf90_check(NF90_GET_ATT(if90id, NF90_GLOBAL, cdatt, values=pvar), clinfo) + ELSE + CALL ctl_warn('iom_nf90_getatt: no attribute '//cdatt//' found') + pvar = -999 + ENDIF + ! + END SUBROUTINE iom_nf90_intatt + + + SUBROUTINE iom_nf90_gettime( kiomid, kvid, ptime, cdunits, cdcalendar ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_gettime *** + !! + !! ** Purpose : read the time axis kvid in the file with NF90 + !!-------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(wp), DIMENSION(:) , INTENT( out) :: ptime ! the time axis + CHARACTER(len=*), OPTIONAL, INTENT( out) :: cdunits ! units attribute + CHARACTER(len=*), OPTIONAL, INTENT( out) :: cdcalendar ! calendar attribute + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_gettime, 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), ptime(:), & + & start=(/ 1 /), count=(/ iom_file(kiomid)%dimsz(1, kvid) /)), clinfo) + IF ( PRESENT(cdunits) ) THEN + CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "units", & + & values=cdunits), clinfo) + ENDIF + IF ( PRESENT(cdcalendar) ) THEN + CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "calendar", & + & values=cdcalendar), clinfo) + ENDIF + ! + END SUBROUTINE iom_nf90_gettime + + + 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(4) :: 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) + !--------------------------------------------------------------------- + ! + 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 + cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter' /) + 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 + iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) + ! 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 ; idims = 2 ; idimid(1:idims) = (/ 3,4/) + ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2 ,4/) + ELSEIF( PRESENT(pv_r3d) ) THEN ; idims = 4 ; idimid(1:idims) = (/1,2,3,4/) + ENDIF + IF( PRESENT(ktype) ) THEN ! variable external type + SELECT CASE (ktype) + CASE (jp_r8) ; itype = NF90_DOUBLE + CASE (jp_r4) ; itype = NF90_FLOAT + CASE (jp_i4) ; itype = NF90_INT + CASE (jp_i2) ; itype = NF90_SHORT + CASE (jp_i1) ; itype = NF90_BYTE + CASE DEFAULT ; CALL ctl_stop( TRIM(clinfo)//' unknown variable type' ) + END SELECT + ELSE + itype = NF90_DOUBLE + ENDIF + IF( PRESENT(pv_r0d) ) THEN + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, & + & iom_file(kiomid)%nvid(idvar) ), clinfo) + ELSE + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), & + & iom_file(kiomid)%nvid(idvar) ), clinfo) + ENDIF + lchunk = .false. + IF( snc4set%luse .AND. idims.eq.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) + ! +++ 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/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplhsb.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplhsb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f54dd2a881ac3190c04eec20976ca8cda1bc845b --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplhsb.f90 @@ -0,0 +1,331 @@ +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 dom_oce ! ocean space and time domain + USE domwri ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition variables + USE oce ! global tra/dyn variable + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! MPP library + USE wrk_nemo ! Memory allocation + USE lbclnk ! + USE domngb ! + USE iscplini + + IMPLICIT NONE + PRIVATE + + PUBLIC iscpl_div + PUBLIC iscpl_cons + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $ + !! Software governed by the CeCILL licence (./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, zsum1, zarea, zsumn, zsumb + REAL(wp):: r1_rdtiscpl + REAL(wp):: zjip1_ratio , zjim1_ratio , zjjp1_ratio , zjjm1_ratio + !! + REAL(wp):: zde3t, zdtem, zdsal + REAL(wp), DIMENSION(:,:), POINTER :: zdssh + !! + 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 + + CALL wrk_alloc(jpi,jpj, zdssh ) + + ! get imbalance (volume heat and salt) + ! initialisation difference + zde3t = 0.0_wp; zdsal = 0.0_wp ; zdtem = 0.0_wp + + ! initialisation correction term + pvol_flx(:,:,: ) = 0.0_wp + pts_flx (:,:,:,:) = 0.0_wp + + r1_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 = 2,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 * r1_rdtiscpl + pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * r1_rdtiscpl + pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * r1_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 + + 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.) + + ! 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 = 2,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(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 = 2,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(zlat ,npts) + CALL mpp_max(zlon ,npts) + CALL mpp_max(izpts,npts) + + ! correction values + CALL mpp_max(zcorr_vol,npts) + CALL mpp_max(zcorr_sal,npts) + CALL mpp_max(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(:,:,:) + + ! 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) + + ! deallocate variables + CALL wrk_dealloc(jpi,jpj, zdssh ) + + 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/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplini.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..94ca279b4dfa0fe0155d9a0ca24f32e8c84257f6 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplini.f90 @@ -0,0 +1,85 @@ +MODULE iscplini + !!====================================================================== + !! *** MODULE sbciscpl*** + !! Ocean forcing: river runoff + !!===================================================================== + !! History : NEMO ! 2015-01 P. Mathiot: original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iscpl_init : initialisation routine (namelist) + !! iscpl_alloc : allocation of correction variables + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE oce ! global tra/dyn variable + 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, nstp_iscpl + INTEGER , PUBLIC :: nn_drown + REAL(wp), PUBLIC :: rdt_iscpl + !! !!* namsbc_iscpl namelist * + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: hdiv_iscpl + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: htsc_iscpl + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $ + !! Software governed by the CeCILL licence (./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 ) + ! + IF( lk_mpp ) CALL mpp_sum ( 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 + !!---------------------------------------------------------------------- + ! ! ============ + ! ! Namelist + ! ! ============ + ! + 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', lwp ) + + 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', lwp ) + 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 + END IF + + END SUBROUTINE iscpl_init + +END MODULE iscplini diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplrst.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplrst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..74b12549766a656e32c44ffa83dca288bdb245c3 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/iscplrst.f90 @@ -0,0 +1,451 @@ +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 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 oce ! global tra/dyn variable + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp ! MPP library + USE lib_fortran ! MPP library + USE wrk_nemo ! Memory allocation + USE lbclnk ! communication + USE iscplini ! ice sheet coupling: initialisation + USE iscplhsb ! ice sheet coupling: conservation + + IMPLICIT NONE + PRIVATE + + PUBLIC iscpl_stp ! step management + !! + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $ + !! Software governed by the CeCILL licence (./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(:,: ), POINTER :: zsmask_b + REAL(wp), DIMENSION(:,:,:), POINTER :: ztmask_b, zumask_b, zvmask_b + REAL(wp), DIMENSION(:,:,:), POINTER :: ze3t_b , ze3u_b , ze3v_b + REAL(wp), DIMENSION(:,:,:), POINTER :: zdepw_b + CHARACTER(20) :: cfile + !!---------------------------------------------------------------------- + + CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before + CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before + CALL wrk_alloc(jpi,jpj,jpk, zdepw_b ) + CALL wrk_alloc(jpi,jpj, zsmask_b ) + + + !! get restart variable + CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b ) ! need to extrapolate T/S + CALL iom_get( numror, jpdom_autoglo, 'umask' , zumask_b ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'vmask' , zvmask_b ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'smask' , zsmask_b ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'e3t_n' , ze3t_b(:,:,:) ) ! need to compute temperature correction + CALL iom_get( numror, jpdom_autoglo, 'e3u_n' , ze3u_b(:,:,:) ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b(:,:,:) ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) + + !! read namelist + CALL iscpl_init() + + !! ! 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 ) + + !! compute correction if conservation needed + IF ( ln_hsb ) THEN + 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 + + !! print mesh/mask + IF( nmsh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file + + IF ( ln_hsb ) THEN + cfile='correction' + cfile = TRIM( cfile ) + CALL iom_open ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib ) + 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 + + CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b ) + CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b ) + CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b ) + CALL wrk_dealloc(jpi,jpj, zsmask_b ) + + !! next step is an euler time step + neuler = 0 + + !! 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(:,: ), POINTER :: zdmask , zdsmask, zvcorr, zucorr, zde3t + REAL(wp), DIMENSION(:,: ), POINTER :: zbub , zbvb , zbun , zbvn + REAL(wp), DIMENSION(:,: ), POINTER :: zssh0 , zssh1, zhu1, zhv1 + REAL(wp), DIMENSION(:,: ), POINTER :: zsmask0, zsmask1 + REAL(wp), DIMENSION(:,:,: ), POINTER :: ztmask0, ztmask1, ztrp + REAL(wp), DIMENSION(:,:,: ), POINTER :: zwmaskn, zwmaskb, ztmp3d + REAL(wp), DIMENSION(:,:,:,:), POINTER :: zts0 + !!---------------------------------------------------------------------- + + !! allocate variables + CALL wrk_alloc(jpi,jpj,jpk,2, zts0 ) + CALL wrk_alloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp, ztmp3d ) + CALL wrk_alloc(jpi,jpj,jpk, zwmaskn, zwmaskb ) + CALL wrk_alloc(jpi,jpj, zsmask0, zsmask1 ) + CALL wrk_alloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t) + CALL wrk_alloc(jpi,jpj, zbub , zbvb , zbun , zbvn ) + CALL wrk_alloc(jpi,jpj, zssh0 , zssh1, zhu1, zhv1 ) + + !! 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 = 2, 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 + END IF + END DO + END DO + CALL lbc_lnk(sshn,'T',1._wp) + CALL lbc_lnk(zsmask1,'T',1._wp) + 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 = 2,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(tsn(:,:,:,1),'T',1._wp) + CALL lbc_lnk(tsn(:,:,:,2),'T',1._wp) + CALL lbc_lnk(ztmask1, 'T',1._wp) + + ! 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 + ! + ! deallocation tmp arrays + CALL wrk_dealloc(jpi,jpj,jpk,2, zts0 ) + CALL wrk_dealloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp ) + CALL wrk_dealloc(jpi,jpj,jpk, zwmaskn, zwmaskb , ztmp3d ) + CALL wrk_dealloc(jpi,jpj, zsmask0, zsmask1 ) + CALL wrk_dealloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t) + CALL wrk_dealloc(jpi,jpj, zbub , zbvb , zbun , zbvn ) + CALL wrk_dealloc(jpi,jpj, zssh0 , zssh1 , zhu1 , zhv1 ) + + END SUBROUTINE iscpl_rst_interpol + +END MODULE iscplrst diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/istate.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/istate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8691adff1f20d6c62c4b91beaa12505258ea60d5 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/istate.f90 @@ -0,0 +1,516 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! istate_init : initial state setting + !! istate_tem : analytical profile for initial Temperature + !! istate_sal : analytical profile for initial Salinity + !! istate_eel : initial state setting of EEL R5 configuration + !! istate_gyre : initial state setting of GYRE configuration + !! istate_uvg : initial velocity in geostropic balance + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE c1d ! 1D vertical configuration + USE daymod ! calendar + USE eosbn2 ! eq. of state, Brunt Vaisala frequency (eos routine) + USE ldftra ! lateral physics: ocean active tracers + USE zdf_oce ! ocean vertical physics + USE phycst ! physical constants + 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 in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! MPP library + USE restart ! restart + USE wrk_nemo ! Memory allocation + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC istate_init ! routine called by step.F90 + + !! * Substitutions + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: istate.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE istate_init + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace + !!---------------------------------------------------------------------- + ! + IF( nn_timing == 1 ) CALL timing_start('istate_init') + ! + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_ini : Initialization of the dynamics and tracers' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + + CALL dta_tsd_init ! Initialisation of T & S input data + IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data + + 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( ln_rstart ) THEN ! Restart from a file + ! ! ------------------- + CALL rst_read ! Read the restart file + IF (ln_iscpl) CALL iscpl_stp ! extraloate 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 + ! before fields ! now fields + sshb (:,:) = 0._wp ; sshn (:,:) = 0._wp + ub (:,:,:) = 0._wp ; un (:,:,:) = 0._wp + vb (:,:,:) = 0._wp ; vn (:,:,:) = 0._wp + hdivn(:,:,:) = 0._wp + ! + IF( cp_cfg == 'eel' ) THEN + CALL istate_eel ! EEL configuration : start from pre-defined U,V T-S fields + ELSEIF( cp_cfg == 'gyre' ) THEN + CALL istate_gyre ! GYRE configuration : start from pre-defined T-S fields + ELSE ! Initial T-S, U-V fields read in files + IF ( ln_tsd_init ) THEN ! read 3D T and S data at nit000 + CALL dta_tsd( nit000, tsb ) + tsn(:,:,:,:) = tsb(:,:,:,:) + ! + ELSE ! Initial T-S fields defined analytically + CALL istate_t_s + ENDIF + IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 + CALL wrk_alloc( jpi,jpj,jpk,2, zuvd ) + CALL dta_uvd( nit000, zuvd ) + ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) + vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) + CALL wrk_dealloc( jpi,jpj,jpk,2, zuvd ) + ENDIF + 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 belox 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(:,:) + ! + IF( nn_timing == 1 ) CALL timing_stop('istate_init') + ! + END SUBROUTINE istate_init + + + SUBROUTINE istate_t_s + !!--------------------------------------------------------------------- + !! *** ROUTINE istate_t_s *** + !! + !! ** Purpose : Intialization of the temperature field with an + !! analytical profile or a file (i.e. in EEL configuration) + !! + !! ** Method : - temperature: use Philander analytic profile + !! - salinity : use to a constant value 35.5 + !! + !! References : Philander ??? + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + REAL(wp) :: zsal = 35.50_wp + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_t_s : Philander s initial temperature profile' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~ and constant salinity (',zsal,' psu)' + ! + DO jk = 1, jpk + tsn(:,:,jk,jp_tem) = ( ( ( 7.5 - 0. * ABS( gphit(:,:) )/30. ) * ( 1.-TANH((gdept_n(:,:,jk)-80.)/30.) ) & + & + 10. * ( 5000. - gdept_n(:,:,jk) ) /5000.) ) * tmask(:,:,jk) + tsb(:,:,jk,jp_tem) = tsn(:,:,jk,jp_tem) + END DO + tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) + tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) + ! + END SUBROUTINE istate_t_s + + + SUBROUTINE istate_eel + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_eel *** + !! + !! ** Purpose : Initialization of the dynamics and tracers for EEL R5 + !! configuration (channel with or without a topographic bump) + !! + !! ** Method : - set temprature field + !! - set salinity field + !! - set velocity field including horizontal divergence + !! and relative vorticity fields + !!---------------------------------------------------------------------- + USE divhor ! hor. divergence (div_hor routine) + USE iom + ! + INTEGER :: inum ! temporary logical unit + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijloc + REAL(wp) :: zh1, zh2, zslope, zcst, zfcor ! temporary scalars + REAL(wp) :: zt1 = 15._wp ! surface temperature value (EEL R5) + REAL(wp) :: zt2 = 5._wp ! bottom temperature value (EEL R5) + REAL(wp) :: zsal = 35.0_wp ! constant salinity (EEL R2, R5 and R6) + REAL(wp) :: zueel = 0.1_wp ! constant uniform zonal velocity (EEL R5) + REAL(wp), DIMENSION(jpiglo,jpjglo) :: zssh ! initial ssh over the global domain + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jp_cfg ) + ! ! ==================== + CASE ( 5 ) ! EEL R5 configuration + ! ! ==================== + ! + ! set temperature field with a linear profile + ! ------------------------------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: linear temperature profile' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + zh1 = gdept_1d( 1 ) + zh2 = gdept_1d(jpkm1) + ! + zslope = ( zt1 - zt2 ) / ( zh1 - zh2 ) + zcst = ( zt1 * ( zh1 - zh2) - ( zt1 - zt2 ) * zh1 ) / ( zh1 - zh2 ) + ! + DO jk = 1, jpk + tsn(:,:,jk,jp_tem) = ( zt2 + zt1 * exp( - gdept_n(:,:,jk) / 1000 ) ) * tmask(:,:,jk) + tsb(:,:,jk,jp_tem) = tsn(:,:,jk,jp_tem) + END DO + ! + ! set salinity field to a constant value + ! -------------------------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: constant salinity field, S = ', zsal + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) + tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) + ! + ! set the dynamics: U,V, hdiv (and ssh if necessary) + ! ---------------- + ! Start EEL5 configuration with barotropic geostrophic velocities + ! according the sshb and sshn SSH imposed. + ! we assume a uniform grid (hence the use of e1t(1,1) for delta_y) + ! we use the Coriolis frequency at mid-channel. + ub(:,:,:) = zueel * umask(:,:,:) + un(:,:,:) = ub(:,:,:) + ijloc = mj0(INT(jpjglo-1)/2) + zfcor = ff(1,ijloc) + ! + DO jj = 1, jpjglo + zssh(:,jj) = - (FLOAT(jj)- FLOAT(jpjglo-1)/2.)*zueel*e1t(1,1)*zfcor/grav + END DO + ! + IF(lwp) THEN + WRITE(numout,*) ' Uniform zonal velocity for EEL R5:',zueel + WRITE(numout,*) ' Geostrophic SSH profile as a function of y:' + WRITE(numout,'(12(1x,f6.2))') zssh(1,:) + ENDIF + ! + DO jj = 1, nlcj + DO ji = 1, nlci + sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask(ji,jj,1) + END DO + END DO + sshb(nlci+1:jpi, : ) = 0.e0 ! set to zero extra mpp columns + sshb( : ,nlcj+1:jpj) = 0.e0 ! set to zero extra mpp rows + ! + sshn(:,:) = sshb(:,:) ! set now ssh to the before value + ! + IF( nn_rstssh /= 0 ) THEN + nn_rstssh = 0 ! hand-made initilization of ssh + CALL ctl_warn( 'istate_eel: force nn_rstssh = 0' ) + ENDIF + ! +!!gm Check here call to div_hor should not be necessary +!!gm div_hor call runoffs not sure they are defined at that level + CALL div_hor( nit000 ) ! horizontal divergence and relative vorticity (curl) + ! N.B. the vertical velocity will be computed from the horizontal divergence field + ! in istate by a call to wzv routine + + + ! ! ========================== + CASE ( 2 , 6 ) ! EEL R2 or R6 configuration + ! ! ========================== + ! + ! set temperature field with a NetCDF file + ! ---------------------------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_eel : EEL R2 or R6: read initial temperature in a NetCDF file' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + CALL iom_open ( 'eel.initemp', inum ) + CALL iom_get ( inum, jpdom_data, 'initemp', tsb(:,:,:,jp_tem) ) ! read before temprature (tb) + CALL iom_close( inum ) + ! + tsn(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) ! set nox temperature to tb + ! + ! set salinity field to a constant value + ! -------------------------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: constant salinity field, S = ', zsal + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ! + tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) + tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) + ! + ! ! =========================== + CASE DEFAULT ! NONE existing configuration + ! ! =========================== + WRITE(ctmp1,*) 'EEL with a ', jp_cfg,' km resolution is not coded' + CALL ctl_stop( ctmp1 ) + ! + END SELECT + ! + END SUBROUTINE istate_eel + + + SUBROUTINE istate_gyre + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_gyre *** + !! + !! ** Purpose : Initialization of the dynamics and tracers for GYRE + !! configuration (double gyre with rotated domain) + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER, PARAMETER :: ntsinit = 0 ! (0/1) (analytical/input data files) T&S initialization + !!---------------------------------------------------------------------- + ! + SELECT CASE ( ntsinit) + ! + CASE ( 0 ) ! analytical T/S profil deduced from LEVITUS + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_gyre : initial analytical T and S profil deduced from LEVITUS ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + tsn(ji,jj,jk,jp_tem) = ( 16. - 12. * TANH( (gdept_n(ji,jj,jk) - 400) / 700 ) ) & + & * (-TANH( (500-gdept_n(ji,jj,jk)) / 150 ) + 1) / 2 & + & + ( 15. * ( 1. - TANH( (gdept_n(ji,jj,jk)-50.) / 1500.) ) & + & - 1.4 * TANH((gdept_n(ji,jj,jk)-100.) / 100.) & + & + 7. * (1500. - gdept_n(ji,jj,jk)) / 1500. ) & + & * (-TANH( (gdept_n(ji,jj,jk) - 500) / 150) + 1) / 2 + tsn(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) + tsb(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) + + tsn(ji,jj,jk,jp_sal) = ( 36.25 - 1.13 * TANH( (gdept_n(ji,jj,jk) - 305) / 460 ) ) & + & * (-TANH((500 - gdept_n(ji,jj,jk)) / 150) + 1) / 2 & + & + ( 35.55 + 1.25 * (5000. - gdept_n(ji,jj,jk)) / 5000. & + & - 1.62 * TANH( (gdept_n(ji,jj,jk) - 60. ) / 650. ) & + & + 0.2 * TANH( (gdept_n(ji,jj,jk) - 35. ) / 100. ) & + & + 0.2 * TANH( (gdept_n(ji,jj,jk) - 1000.) / 5000.) ) & + & * (-TANH((gdept_n(ji,jj,jk) - 500) / 150) + 1) / 2 + tsn(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) + tsb(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) + END DO + END DO + END DO + ! + CASE ( 1 ) ! T/S data fields read in dta_tem.nc/data_sal.nc files + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_gyre : initial T and S read from dta_tem.nc/data_sal.nc files' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) ' NetCDF FORMAT' + + ! Read temperature field + ! ---------------------- + CALL iom_open ( 'data_tem', inum ) + CALL iom_get ( inum, jpdom_data, 'votemper', tsn(:,:,:,jp_tem) ) + CALL iom_close( inum ) + + tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:) + tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) + + ! Read salinity field + ! ------------------- + CALL iom_open ( 'data_sal', inum ) + CALL iom_get ( inum, jpdom_data, 'vosaline', tsn(:,:,:,jp_sal) ) + CALL iom_close( inum ) + + tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:) + tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) + ! + END SELECT + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Initial temperature and salinity profiles:' + WRITE(numout, "(9x,' level gdept_1d temperature salinity ')" ) + WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_1d(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) + ENDIF + ! + END SUBROUTINE istate_gyre + + + SUBROUTINE istate_uvg + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_uvg *** + !! + !! ** Purpose : Compute the geostrophic velocities from (tn,sn) fields + !! + !! ** Method : Using the hydrostatic hypothesis the now hydrostatic + !! pressure is computed by integrating the in-situ density from the + !! surface to the bottom. + !! p=integral [ rau*g dz ] + !!---------------------------------------------------------------------- + USE divhor ! hor. divergence (div_hor routine) + USE lbclnk ! ocean lateral boundary condition (or mpp link) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zmsv, zphv, zmsu, zphu, zalfg ! temporary scalars + REAL(wp), POINTER, DIMENSION(:,:,:) :: zprn + !!---------------------------------------------------------------------- + ! + CALL wrk_alloc( jpi,jpj,jpk, zprn) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_uvg : Start from Geostrophy' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + + ! Compute the now hydrostatic pressure + ! ------------------------------------ + + zalfg = 0.5 * grav * rau0 + + zprn(:,:,1) = zalfg * e3w_n(:,:,1) * ( 1 + rhd(:,:,1) ) ! Surface value + + DO jk = 2, jpkm1 ! Vertical integration from the surface + zprn(:,:,jk) = zprn(:,:,jk-1) & + & + zalfg * e3w_n(:,:,jk) * ( 2. + rhd(:,:,jk) + rhd(:,:,jk-1) ) + END DO + + ! Compute geostrophic balance + ! --------------------------- + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vertor opt. + zmsv = 1. / MAX( umask(ji-1,jj+1,jk) + umask(ji ,jj+1,jk) & + + umask(ji-1,jj ,jk) + umask(ji ,jj ,jk) , 1. ) + zphv = ( zprn(ji ,jj+1,jk) - zprn(ji-1,jj+1,jk) ) * umask(ji-1,jj+1,jk) / e1u(ji-1,jj+1) & + + ( zprn(ji+1,jj+1,jk) - zprn(ji ,jj+1,jk) ) * umask(ji ,jj+1,jk) / e1u(ji ,jj+1) & + + ( zprn(ji ,jj ,jk) - zprn(ji-1,jj ,jk) ) * umask(ji-1,jj ,jk) / e1u(ji-1,jj ) & + + ( zprn(ji+1,jj ,jk) - zprn(ji ,jj ,jk) ) * umask(ji ,jj ,jk) / e1u(ji ,jj ) + zphv = 1. / rau0 * zphv * zmsv * vmask(ji,jj,jk) + + zmsu = 1. / MAX( vmask(ji+1,jj ,jk) + vmask(ji ,jj ,jk) & + + vmask(ji+1,jj-1,jk) + vmask(ji ,jj-1,jk) , 1. ) + zphu = ( zprn(ji+1,jj+1,jk) - zprn(ji+1,jj ,jk) ) * vmask(ji+1,jj ,jk) / e2v(ji+1,jj ) & + + ( zprn(ji ,jj+1,jk) - zprn(ji ,jj ,jk) ) * vmask(ji ,jj ,jk) / e2v(ji ,jj ) & + + ( zprn(ji+1,jj ,jk) - zprn(ji+1,jj-1,jk) ) * vmask(ji+1,jj-1,jk) / e2v(ji+1,jj-1) & + + ( zprn(ji ,jj ,jk) - zprn(ji ,jj-1,jk) ) * vmask(ji ,jj-1,jk) / e2v(ji ,jj-1) + zphu = 1. / rau0 * zphu * zmsu * umask(ji,jj,jk) + + ! Compute the geostrophic velocities + un(ji,jj,jk) = -2. * zphu / ( ff(ji,jj) + ff(ji ,jj-1) ) + vn(ji,jj,jk) = 2. * zphv / ( ff(ji,jj) + ff(ji-1,jj ) ) + END DO + END DO + END DO + + IF(lwp) WRITE(numout,*) ' we force to zero bottom velocity' + + ! Susbtract the bottom velocity (level jpk-1 for flat bottom case) + ! to have a zero bottom velocity + + DO jk = 1, jpkm1 + un(:,:,jk) = ( un(:,:,jk) - un(:,:,jpkm1) ) * umask(:,:,jk) + vn(:,:,jk) = ( vn(:,:,jk) - vn(:,:,jpkm1) ) * vmask(:,:,jk) + END DO + + CALL lbc_lnk( un, 'U', -1. ) + CALL lbc_lnk( vn, 'V', -1. ) + + ub(:,:,:) = un(:,:,:) + vb(:,:,:) = vn(:,:,:) + + ! +!!gm Check here call to div_hor should not be necessary +!!gm div_hor call runoffs not sure they are defined at that level + CALL div_hor( nit000 ) ! now horizontal divergence + ! + CALL wrk_dealloc( jpi,jpj,jpk, zprn) + ! + END SUBROUTINE istate_uvg + + !!===================================================================== +END MODULE istate diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/lbclnk.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/lbclnk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ee452f57f8e49bc364a2b5f43feee2626a441ca0 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/lbclnk.f90 @@ -0,0 +1,63 @@ +MODULE lbclnk + !!====================================================================== + !! *** MODULE lbclnk *** + !! Ocean : 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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'key_mpp_mpi' MPI massively parallel processing library + !!---------------------------------------------------------------------- + !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp + !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp + !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine 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 lib_mpp ! distributed memory computing library + + INTERFACE lbc_lnk_multi + MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple + END INTERFACE + ! + INTERFACE lbc_lnk + MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d + END INTERFACE + ! + INTERFACE lbc_sum + MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d + END INTERFACE + ! + INTERFACE lbc_bdy_lnk + MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d + END INTERFACE + ! + INTERFACE lbc_lnk_e + MODULE PROCEDURE mpp_lnk_2d_e + END INTERFACE + ! + INTERFACE lbc_lnk_icb + MODULE PROCEDURE mpp_lnk_2d_icb + END INTERFACE + + PUBLIC lbc_lnk ! ocean lateral boundary conditions + PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions + PUBLIC lbc_sum + PUBLIC lbc_lnk_e ! + PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions + PUBLIC lbc_lnk_icb ! + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lbclnk.F90 6493 2016-04-22 13:52:52Z mathiot $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + !!====================================================================== +END MODULE lbclnk + diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/lbcnfd.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/lbcnfd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0259e8b6838e4d80887c78c507743cbb96be54f6 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/lbcnfd.f90 @@ -0,0 +1,971 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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) + !! mpp_lbc_nfd_3d : North fold treatment for a 3D arrays optimized for MPP + !! mpp_lbc_nfd_2d : North fold treatment for a 2D arrays optimized for MPP + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_nfd + MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d + END INTERFACE + ! + INTERFACE mpp_lbc_nfd + MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d + END INTERFACE + + PUBLIC lbc_nfd ! north fold conditions + PUBLIC mpp_lbc_nfd ! north fold conditions (parallel 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: lbcnfd.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) + !!---------------------------------------------------------------------- + !! *** routine lbc_nfd_3d *** + !! + !! ** Purpose : 3D lateral boundary condition : North fold treatment + !! without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : pt3d with updated values along the north fold + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! control of the sign change + ! ! = -1. , the sign is changed if north fold boundary + ! ! = 1. , the sign is kept if north fold boundary + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied + ! + INTEGER :: ji, jk + INTEGER :: ijt, iju, ijpj, ijpjm1 + !!---------------------------------------------------------------------- + + SELECT CASE ( jpni ) + CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction + END SELECT + ijpjm1 = ijpj-1 + + DO jk = 1, jpk + ! + SELECT CASE ( npolj ) + ! + CASE ( 3 , 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) + END DO + pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) + END DO + pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk) + pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) + END DO + CASE ( 'V' ) ! V-point + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) + pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk) + END DO + pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) + CASE ( 'F' ) ! F-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) + pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk) + END DO + pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk) + pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) + END SELECT + ! + CASE ( 5 , 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) + END DO + pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) + CASE ( 'V' ) ! V-point + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) + END DO + CASE ( 'F' ) ! F-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk) + END DO + pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( cd_type) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + pt3d(:, 1 ,jk) = 0.e0 + pt3d(:,ijpj,jk) = 0.e0 + CASE ( 'F' ) ! F-point + pt3d(:,ijpj,jk) = 0.e0 + END SELECT + ! + END SELECT ! npolj + ! + END DO + ! + END SUBROUTINE lbc_nfd_3d + + + SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) + !!---------------------------------------------------------------------- + !! *** routine lbc_nfd_2d *** + !! + !! ** Purpose : 2D lateral boundary condition : North fold treatment + !! without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : pt2d with updated values along the north fold + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! control of the sign change + ! ! = -1. , the sign is changed if north fold boundary + ! ! = 1. , the sign is kept if north fold boundary + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied + INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos + ! + INTEGER :: ji, jl, ipr2dj + INTEGER :: ijt, iju, ijpj, ijpjm1 + !!---------------------------------------------------------------------- + + SELECT CASE ( jpni ) + CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction + END SELECT + ! + IF( PRESENT(pr2dj) ) THEN ! use of additional halos + ipr2dj = pr2dj + IF( jpni > 1 ) ijpj = ijpj + ipr2dj + ELSE + ipr2dj = 0 + ENDIF + ! + ijpjm1 = ijpj-1 + + + SELECT CASE ( npolj ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( cd_type ) + ! + CASE ( 'T' , 'W' ) ! T- , W-points + DO jl = 0, ipr2dj + DO ji = 2, jpiglo + ijt=jpiglo-ji+2 + pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) + END DO + END DO + pt2d(1,ijpj) = psgn * pt2d(3,ijpj-2) + DO ji = jpiglo/2+1, jpiglo + ijt=jpiglo-ji+2 + pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1) + END DO + CASE ( 'U' ) ! U-point + DO jl = 0, ipr2dj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) + END DO + END DO + pt2d( 1 ,ijpj ) = psgn * pt2d( 2 ,ijpj-2) + pt2d(jpiglo,ijpj ) = psgn * pt2d(jpiglo-1,ijpj-2) + pt2d(1 ,ijpj-1) = psgn * pt2d(jpiglo ,ijpj-1) + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) + END DO + CASE ( 'V' ) ! V-point + DO jl = -1, ipr2dj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl) + END DO + END DO + pt2d( 1 ,ijpj) = psgn * pt2d( 3 ,ijpj-3) + CASE ( 'F' ) ! F-point + DO jl = -1, ipr2dj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl) + END DO + END DO + pt2d( 1 ,ijpj) = psgn * pt2d( 2 ,ijpj-3) + pt2d(jpiglo,ijpj) = psgn * pt2d(jpiglo-1,ijpj-3) + pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2) + pt2d( 1 ,ijpj-1) = psgn * pt2d( 2 ,ijpj-2) + CASE ( 'I' ) ! ice U-V point (I-point) + DO jl = 0, ipr2dj + pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) + DO ji = 3, jpiglo + iju = jpiglo - ji + 3 + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) + END DO + END DO + CASE ( 'J' ) ! first ice U-V point + DO jl =0, ipr2dj + pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) + DO ji = 3, jpiglo + iju = jpiglo - ji + 3 + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) + END DO + END DO + CASE ( 'K' ) ! second ice U-V point + DO jl =0, ipr2dj + pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) + DO ji = 3, jpiglo + iju = jpiglo - ji + 3 + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) + END DO + END DO + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 0, ipr2dj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jl = 0, ipr2dj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) + END DO + END DO + pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1) + CASE ( 'V' ) ! V-point + DO jl = 0, ipr2dj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1) + END DO + CASE ( 'F' ) ! F-point + DO jl = 0, ipr2dj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl) + END DO + END DO + pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2) + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1) + END DO + CASE ( 'I' ) ! ice U-V point (I-point) + pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 + DO jl = 0, ipr2dj + DO ji = 2 , jpiglo-1 + ijt = jpiglo - ji + 2 + pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) ) + END DO + END DO + CASE ( 'J' ) ! first ice U-V point + pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 + DO jl = 0, ipr2dj + DO ji = 2 , jpiglo-1 + ijt = jpiglo - ji + 2 + pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) + END DO + END DO + CASE ( 'K' ) ! second ice U-V point + pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 + DO jl = 0, ipr2dj + DO ji = 2 , jpiglo-1 + ijt = jpiglo - ji + 2 + pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) + END DO + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( cd_type) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + pt2d(:, 1:1-ipr2dj ) = 0.e0 + pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 + CASE ( 'F' ) ! F-point + pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 + CASE ( 'I' ) ! ice U-V point + pt2d(:, 1:1-ipr2dj ) = 0.e0 + pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 + CASE ( 'J' ) ! first ice U-V point + pt2d(:, 1:1-ipr2dj ) = 0.e0 + pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 + CASE ( 'K' ) ! second ice U-V point + pt2d(:, 1:1-ipr2dj ) = 0.e0 + pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 + END SELECT + ! + END SELECT + ! + END SUBROUTINE lbc_nfd_2d + + + SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lbc_nfd_3d *** + !! + !! ** Purpose : 3D lateral boundary condition : North fold treatment + !! without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : pt3d with updated values along the north fold + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! control of the sign change + ! ! = -1. , the sign is changed if north fold boundary + ! ! = 1. , the sign is kept if north fold boundary + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied + ! + INTEGER :: ji, jk + INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction + END SELECT + ijpjm1 = ijpj-1 + + ! + SELECT CASE ( npolj ) + ! + CASE ( 3 , 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + + DO jk = 1, jpk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) + END DO + IF(nimpp .eq. 1) THEN + pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) + ENDIF + END DO + + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + IF(startloop .le. nlci) THEN + DO jk = 1, jpk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + jia = ji + nimpp - 1 + ijta = jpiglo - jia + 2 + IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN + pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) + ELSE + pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) + ENDIF + END DO + END DO + ENDIF + + + CASE ( 'U' ) ! U-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jk = 1, jpk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) + END DO + IF(nimpp .eq. 1) THEN + pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) + ENDIF + END DO + + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF(nimpp .ge. (jpiglo/2)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN + startloop = jpiglo/2 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + IF (startloop .le. endloop) THEN + DO jk = 1, jpk + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + jia = ji + nimpp - 1 + ijua = jpiglo - jia + 1 + IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN + pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) + ELSE + pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) + ENDIF + END DO + END DO + ENDIF + + CASE ( 'V' ) ! V-point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + DO jk = 1, jpk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) + pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) + END DO + IF(nimpp .eq. 1) THEN + pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) + ENDIF + END DO + CASE ( 'F' ) ! F-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jk = 1, jpk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) + pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) + END DO + IF(nimpp .eq. 1) THEN + pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) + ENDIF + END DO + END SELECT + ! + + CASE ( 5 , 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jk = 1, jpk + DO ji = 1, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) + END DO + END DO + + CASE ( 'U' ) ! U-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jk = 1, jpk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) + END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) + ENDIF + END DO + + CASE ( 'V' ) ! V-point + DO jk = 1, jpk + DO ji = 1, nlci + ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) + END DO + END DO + + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + IF(startloop .le. nlci) THEN + DO jk = 1, jpk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) + END DO + END DO + ENDIF + + CASE ( 'F' ) ! F-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jk = 1, jpk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) + END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) + ENDIF + END DO + + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + IF (startloop .le. endloop) THEN + DO jk = 1, jpk + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) + END DO + END DO + ENDIF + + END SELECT + + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( cd_type) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + pt3dl(:, 1 ,jk) = 0.e0 + pt3dl(:,ijpj,jk) = 0.e0 + CASE ( 'F' ) ! F-point + pt3dl(:,ijpj,jk) = 0.e0 + END SELECT + ! + END SELECT ! npolj + ! + ! + END SUBROUTINE mpp_lbc_nfd_3d + + + SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lbc_nfd_2d *** + !! + !! ** Purpose : 2D lateral boundary condition : North fold treatment + !! without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : pt2d with updated values along the north fold + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! control of the sign change + ! ! = -1. , the sign is changed if north fold boundary + ! ! = 1. , the sign is kept if north fold boundary + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied + ! + INTEGER :: ji + INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop + !!---------------------------------------------------------------------- + + SELECT CASE ( jpni ) + CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction + END SELECT + ! + ijpjm1 = ijpj-1 + + + SELECT CASE ( npolj ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( cd_type ) + ! + CASE ( 'T' , 'W' ) ! T- , W-points + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + DO ji = startloop, nlci + ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) + END DO + IF (nimpp .eq. 1) THEN + pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) + ENDIF + + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + DO ji = startloop, nlci + ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + jia = ji + nimpp - 1 + ijta = jpiglo - jia + 2 + IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN + pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) + ELSE + pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) + ENDIF + END DO + + CASE ( 'U' ) ! U-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) + END DO + + IF (nimpp .eq. 1) THEN + pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) + pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) + ENDIF + + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF(nimpp .ge. (jpiglo/2)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN + startloop = jpiglo/2 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + jia = ji + nimpp - 1 + ijua = jpiglo - jia + 1 + IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN + pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) + ELSE + pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) + ENDIF + END DO + + CASE ( 'V' ) ! V-point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + DO ji = startloop, nlci + ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) + pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) + END DO + IF (nimpp .eq. 1) THEN + pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) + ENDIF + + CASE ( 'F' ) ! F-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) + END DO + IF (nimpp .eq. 1) THEN + pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3) + pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3) + pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) + ENDIF + + CASE ( 'I' ) ! ice U-V point (I-point) + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 3 + pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) + ENDIF + DO ji = startloop, nlci + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) + END DO + + CASE ( 'J' ) ! first ice U-V point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 3 + pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) + ENDIF + DO ji = startloop, nlci + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) + END DO + + CASE ( 'K' ) ! second ice U-V point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 3 + pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) + ENDIF + DO ji = startloop, nlci + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) + END DO + + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( cd_type ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) + END DO + + CASE ( 'U' ) ! U-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) + END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) + ENDIF + + CASE ( 'V' ) ! V-point + DO ji = 1, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) + END DO + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) + END DO + + CASE ( 'F' ) ! F-point + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) + END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) + ENDIF + + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF(nimpp .ge. (jpiglo/2+1)) THEN + startloop = 1 + ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) + END DO + + CASE ( 'I' ) ! ice U-V point (I-point) + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = startloop , endloop + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) + END DO + + CASE ( 'J' ) ! first ice U-V point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = startloop , endloop + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) + END DO + + CASE ( 'K' ) ! second ice U-V point + IF (nimpp .ne. 1) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + IF ((nimpp + nlci - 1) .ne. jpiglo) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO ji = startloop, endloop + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) + END DO + + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( cd_type) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + pt2dl(:, 1 ) = 0.e0 + pt2dl(:,ijpj) = 0.e0 + CASE ( 'F' ) ! F-point + pt2dl(:,ijpj) = 0.e0 + CASE ( 'I' ) ! ice U-V point + pt2dl(:, 1 ) = 0.e0 + pt2dl(:,ijpj) = 0.e0 + CASE ( 'J' ) ! first ice U-V point + pt2dl(:, 1 ) = 0.e0 + pt2dl(:,ijpj) = 0.e0 + CASE ( 'K' ) ! second ice U-V point + pt2dl(:, 1 ) = 0.e0 + pt2dl(:,ijpj) = 0.e0 + END SELECT + ! + END SELECT + ! + END SUBROUTINE mpp_lbc_nfd_2d + + !!====================================================================== +END MODULE lbcnfd diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_cray.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_cray.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9e1c0ee744811b8a1d99637e9ae60953122f94ad --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/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 +!!---------------------------------------------------------------------- +!! OPA 9.0 , LOCEAN-IPSL (2005) +!! $Id: lib_cray.f90 3680 2012-11-27 14:42:24Z rblod $ +!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt +!!---------------------------------------------------------------------- +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/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_fortran.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_fortran.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f3ed49e07f056e9b626e5f6e6df795779a359c1c --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_fortran.f90 @@ -0,0 +1,556 @@ +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...) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 + + 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 omly over the halos) + PUBLIC DDPDD ! also used in closea module + PUBLIC glob_min, glob_max + + PUBLIC SIGN + + + INTERFACE glob_sum + MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & + & glob_sum_2d_a, glob_sum_3d_a + END INTERFACE + INTERFACE glob_sum_full + MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d + END INTERFACE + INTERFACE glob_min + MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a + END INTERFACE + INTERFACE glob_max + MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a + END INTERFACE + + + 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 + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_fortran.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + ! --- SUM --- + + FUNCTION glob_sum_1d( ptab, kdim ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_sum_1D *** + !! + !! ** Purpose : perform a masked sum on the inner global domain of a 1D array + !!----------------------------------------------------------------------- + INTEGER :: kdim + REAL(wp), INTENT(in), DIMENSION(kdim) :: ptab ! input 1D array + REAL(wp) :: glob_sum_1d ! global sum + !!----------------------------------------------------------------------- + ! + glob_sum_1d = SUM( ptab(:) ) + IF( lk_mpp ) CALL mpp_sum( glob_sum_1d ) + ! + END FUNCTION glob_sum_1d + + FUNCTION glob_sum_2d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_sum_2D *** + !! + !! ** Purpose : perform a masked sum on the inner global domain of a 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array + REAL(wp) :: glob_sum_2d ! global masked sum + !!----------------------------------------------------------------------- + ! + glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_sum( glob_sum_2d ) + ! + END FUNCTION glob_sum_2d + + + FUNCTION glob_sum_3d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_sum_3D *** + !! + !! ** Purpose : perform a masked sum on the inner global domain of a 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array + REAL(wp) :: glob_sum_3d ! global masked sum + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab,3) + ! + glob_sum_3d = 0.e0 + DO jk = 1, ijpk + glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) ) + END DO + IF( lk_mpp ) CALL mpp_sum( glob_sum_3d ) + ! + END FUNCTION glob_sum_3d + + + FUNCTION glob_sum_2d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_sum_2D _a *** + !! + !! ** Purpose : perform a masked sum on the inner global domain of two 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array + REAL(wp) , DIMENSION(2) :: glob_sum_2d_a ! global masked sum + !!----------------------------------------------------------------------- + ! + glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) ) + glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_sum( glob_sum_2d_a, 2 ) + ! + END FUNCTION glob_sum_2d_a + + + FUNCTION glob_sum_3d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_sum_3D_a *** + !! + !! ** Purpose : perform a masked sum on the inner global domain of two 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array + REAL(wp) , DIMENSION(2) :: glob_sum_3d_a ! global masked sum + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab1,3) + ! + glob_sum_3d_a(:) = 0.e0 + DO jk = 1, ijpk + glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) ) + glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) ) + END DO + IF( lk_mpp ) CALL mpp_sum( glob_sum_3d_a, 2 ) + ! + END FUNCTION glob_sum_3d_a + + FUNCTION glob_sum_full_2d( ptab ) + !!---------------------------------------------------------------------- + !! *** FUNCTION glob_sum_full_2d *** + !! + !! ** Purpose : perform a sum in calling DDPDD routine (nomask) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab + REAL(wp) :: glob_sum_full_2d ! global sum + !! + !!----------------------------------------------------------------------- + ! + glob_sum_full_2d = SUM( ptab(:,:) * tmask_h(:,:) ) + IF( lk_mpp ) CALL mpp_sum( glob_sum_full_2d ) + ! + END FUNCTION glob_sum_full_2d + + FUNCTION glob_sum_full_3d( ptab ) + !!---------------------------------------------------------------------- + !! *** FUNCTION glob_sum_full_3d *** + !! + !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine (nomask) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab + REAL(wp) :: glob_sum_full_3d ! global sum + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijpk ! local variables: size of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab,3) + ! + glob_sum_full_3d = 0.e0 + DO jk = 1, ijpk + glob_sum_full_3d = glob_sum_full_3d + SUM( ptab(:,:,jk) * tmask_h(:,:) ) + END DO + IF( lk_mpp ) CALL mpp_sum( glob_sum_full_3d ) + ! + END FUNCTION glob_sum_full_3d + + + + ! --- MIN --- + FUNCTION glob_min_2d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_min_2D *** + !! + !! ** Purpose : perform a masked min on the inner global domain of a 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array + REAL(wp) :: glob_min_2d ! global masked min + !!----------------------------------------------------------------------- + ! + glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_min( glob_min_2d ) + ! + END FUNCTION glob_min_2d + + FUNCTION glob_min_3d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_min_3D *** + !! + !! ** Purpose : perform a masked min on the inner global domain of a 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array + REAL(wp) :: glob_min_3d ! global masked min + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab,3) + ! + glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ijpk + glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) + END DO + IF( lk_mpp ) CALL mpp_min( glob_min_3d ) + ! + END FUNCTION glob_min_3d + + + FUNCTION glob_min_2d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_min_2D _a *** + !! + !! ** Purpose : perform a masked min on the inner global domain of two 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array + REAL(wp) , DIMENSION(2) :: glob_min_2d_a ! global masked min + !!----------------------------------------------------------------------- + ! + glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) ) + glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_min( glob_min_2d_a, 2 ) + ! + END FUNCTION glob_min_2d_a + + + FUNCTION glob_min_3d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_min_3D_a *** + !! + !! ** Purpose : perform a masked min on the inner global domain of two 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array + REAL(wp) , DIMENSION(2) :: glob_min_3d_a ! global masked min + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab1,3) + ! + glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) ) + glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ijpk + glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) + glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) + END DO + IF( lk_mpp ) CALL mpp_min( glob_min_3d_a, 2 ) + ! + END FUNCTION glob_min_3d_a + + ! --- MAX --- + FUNCTION glob_max_2d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_max_2D *** + !! + !! ** Purpose : perform a masked max on the inner global domain of a 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array + REAL(wp) :: glob_max_2d ! global masked max + !!----------------------------------------------------------------------- + ! + glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_max( glob_max_2d ) + ! + END FUNCTION glob_max_2d + + FUNCTION glob_max_3d( ptab ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_max_3D *** + !! + !! ** Purpose : perform a masked max on the inner global domain of a 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array + REAL(wp) :: glob_max_3d ! global masked max + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab,3) + ! + glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ijpk + glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) + END DO + IF( lk_mpp ) CALL mpp_max( glob_max_3d ) + ! + END FUNCTION glob_max_3d + + + FUNCTION glob_max_2d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_max_2D _a *** + !! + !! ** Purpose : perform a masked max on the inner global domain of two 2D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array + REAL(wp) , DIMENSION(2) :: glob_max_2d_a ! global masked max + !!----------------------------------------------------------------------- + ! + glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) ) + glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_max( glob_max_2d_a, 2 ) + ! + END FUNCTION glob_max_2d_a + + + FUNCTION glob_max_3d_a( ptab1, ptab2 ) + !!----------------------------------------------------------------------- + !! *** FUNCTION glob_max_3D_a *** + !! + !! ** Purpose : perform a masked max on the inner global domain of two 3D array + !!----------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array + REAL(wp) , DIMENSION(2) :: glob_max_3d_a ! global masked max + !! + INTEGER :: jk + INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab + !!----------------------------------------------------------------------- + ! + ijpk = SIZE(ptab1,3) + ! + glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) ) + glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ijpk + glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) + glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) + END DO + IF( lk_mpp ) CALL mpp_max( glob_max_3d_a, 2 ) + ! + END FUNCTION glob_max_3d_a + + + 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 + + !!---------------------------------------------------------------------- + !! '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 + + !!====================================================================== +END MODULE lib_fortran diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_mpp.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_mpp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2d3a369b9709dfc2814690d61a71e1e88463f96d --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/lib_mpp.f90 @@ -0,0 +1,4166 @@ +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', 'mpp_lnk_obc_3d', + !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update + !! the mppobc routine to optimize the BDY and OBC communications + !! 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 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 + !! get_unit : give the index of an unused logical unit + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'key_mpp_mpi' MPI massively parallel processing library + !!---------------------------------------------------------------------- + !! lib_mpp_alloc : allocate mpp arrays + !! mynode : indentify the processor unit + !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) + !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays + !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) + !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) + !! mpprecv : + !! mppsend : SUBROUTINE mpp_ini_znl + !! 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 : north fold processors gathering + !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo + !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lbcnfd ! north fold treatment + USE in_out_manager ! I/O manager + USE wrk_nemo ! work arrays + + IMPLICIT NONE + PRIVATE + + PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam + PUBLIC mynode, mppstop, mppsync, mpp_comm_free + PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e + PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc + PUBLIC mpp_max_multiple + PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e + PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple + PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d + PUBLIC mppscatter, mppgather + PUBLIC mpp_ini_ice, mpp_ini_znl + PUBLIC mppsize + PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines + PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d + PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb + PUBLIC mpprank + + TYPE arrayptr + REAL , DIMENSION (:,:), POINTER :: pt2d + END TYPE arrayptr + PUBLIC arrayptr + + !! * 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_lbc_north + MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d + END INTERFACE + INTERFACE mpp_minloc + MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d + END INTERFACE + INTERFACE mpp_maxloc + MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d + END INTERFACE + + INTERFACE mpp_max_multiple + MODULE PROCEDURE mppmax_real_multiple + END INTERFACE + + !! ========================= !! + !! MPI variable definition !! + !! ========================= !! +!$AGRIF_DO_NOT_TREAT + INCLUDE 'mpif.h' +!$AGRIF_END_DO_NOT_TREAT + + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag + + INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) + + INTEGER :: mppsize ! number of process + INTEGER :: mpprank ! process number [ 0 - size-1 ] +!$AGRIF_DO_NOT_TREAT + INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator +!$AGRIF_END_DO_NOT_TREAT + + INTEGER :: MPI_SUMDD + + ! variables used in case of sea-ice + INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) + INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) + INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) + INTEGER :: ndim_rank_ice ! number of 'ice' processors + INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm + INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice + + ! 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, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north ! dimension ndim_rank_north + + ! Type of send : standard, buffered, immediate + CHARACTER(len=1), PUBLIC :: cn_mpi_send ! type od mpi send/recieve (S=standard, B=bsend, I=isend) + LOGICAL, PUBLIC :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I') + INTEGER, PUBLIC :: nn_buffer ! size of the buffer in case of mpi_bsend + + 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 + INTEGER, PUBLIC :: ityp + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_mpp.F90 6490 2016-04-20 14:55:58Z mcastril $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) + !!---------------------------------------------------------------------- + !! *** routine mynode *** + !! + !! ** Purpose : Find processor unit + !!---------------------------------------------------------------------- + CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! + CHARACTER(len=*) , INTENT(in ) :: ldname ! + INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist + INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist + INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output + INTEGER , INTENT(inout) :: kstop ! stop indicator + INTEGER , OPTIONAL , INTENT(in ) :: localComm ! + ! + INTEGER :: mynode, ierr, code, ji, ii, ios + LOGICAL :: mpi_was_called + ! + NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather + !!---------------------------------------------------------------------- + ! + ii = 1 + WRITE(ldtxt(ii),*) ; ii = ii + 1 + WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 + WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 + ! + + REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables + READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) + + REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables + READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) + + ! ! control print + WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 + + + + + + + + + + IF(jpnij < 1)THEN + ! If jpnij is not specified in namelist then we calculate it - this + ! means there will be no land cutting out. + jpnij = jpni * jpnj + END IF + + IF( (jpni < 1) .OR. (jpnj < 1) )THEN + WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 + ELSE + WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 + END IF + + WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 + + CALL mpi_initialized ( mpi_was_called, code ) + IF( code /= MPI_SUCCESS ) THEN + DO ji = 1, SIZE(ldtxt) + IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode + END DO + WRITE(*, cform_err) + WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' + CALL mpi_abort( mpi_comm_world, code, ierr ) + ENDIF + + IF( mpi_was_called ) THEN + ! + SELECT CASE ( cn_mpi_send ) + CASE ( 'S' ) ! Standard mpi send (blocking) + WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 + CASE ( 'B' ) ! Buffer mpi send (blocking) + WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 + IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) + CASE ( 'I' ) ! Immediate mpi send (non-blocking send) + WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 + l_isend = .TRUE. + CASE DEFAULT + WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 + kstop = kstop + 1 + END SELECT + ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN + WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 + kstop = kstop + 1 + ELSE + SELECT CASE ( cn_mpi_send ) + CASE ( 'S' ) ! Standard mpi send (blocking) + WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 + CALL mpi_init( ierr ) + CASE ( 'B' ) ! Buffer mpi send (blocking) + WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 + IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) + CASE ( 'I' ) ! Immediate mpi send (non-blocking send) + WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 + l_isend = .TRUE. + CALL mpi_init( ierr ) + CASE DEFAULT + WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 + WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 + kstop = kstop + 1 + END SELECT + ! + ENDIF + + IF( PRESENT(localComm) ) THEN + IF( Agrif_Root() ) THEN + mpi_comm_opa = localComm + ENDIF + ELSE + CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) + IF( code /= MPI_SUCCESS ) THEN + DO ji = 1, SIZE(ldtxt) + IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode + END DO + WRITE(*, cform_err) + WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' + CALL mpi_abort( mpi_comm_world, code, ierr ) + ENDIF + ENDIF + + + + + + + + + + CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) + CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) + mynode = mpprank + + IF( mynode == 0 ) THEN + CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) + WRITE(kumond, nammpp) + ENDIF + ! + CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) + ! + END FUNCTION mynode + + + SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_3d *** + !! + !! ** Purpose : Message passing manadgement + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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 + !! + !! ** Action : ptab with update value at its periphery + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland + INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east + !!---------------------------------------------------------------------- + + ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & + & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) + + ! + IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value + ELSE ; zland = 0._wp ! zero by default + ENDIF + + ! 1. standard boundary treatment + ! ------------------------------ + IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values + ! + ! WARNING ptab is defined only between nld and nle + DO jk = 1, jpk + DO jj = nlcj+1, jpj ! added line(s) (inner only) + ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) + ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) + ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) + END DO + DO ji = nlci+1, jpi ! added column(s) (full) + ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) + ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) + ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) + END DO + END DO + ! + ELSE ! standard close or cyclic treatment + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + ptab( 1 ,:,:) = ptab(jpim1,:,:) + ptab(jpi,:,:) = ptab( 2 ,:,:) + ELSE !* closed + IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point + ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north + ENDIF + ! ! North-South boundaries (always closed) + IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point + ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north + ! + 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 = nlci-nreci + DO jl = 1, jpreci + zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj * jpk + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci-jpreci + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + ptab(jl ,:,:) = zt3we(:,jl,:,2) + ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + ptab(jl ,:,:) = zt3we(:,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 = nlcj-nrecj + DO jl = 1, jprecj + zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi * jpk + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj-jprecj + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + ptab(:,jl ,:) = zt3sn(:,jl,:,2) + ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + ptab(:,jl,:) = zt3sn(:,jl,:,2) + END DO + END SELECT + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) + ! + END SUBROUTINE mpp_lnk_3d + + + SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_multiple *** + !! + !! ** Purpose : Message passing management for multiple 2d arrays + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) + !! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + INTEGER :: num_fields + TYPE( arrayptr ), DIMENSION(:) :: pt2d_array + REAL(wp) :: zland + INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east + + !!---------------------------------------------------------------------- + ! + ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & + & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) + ! + IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value + ELSE ; zland = 0._wp ! zero by default + ENDIF + + ! 1. standard boundary treatment + ! ------------------------------ + ! + !First Array + DO ii = 1 , num_fields + IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values + ! + ! WARNING pt2d is defined only between nld and nle + DO jj = nlcj+1, jpj ! added line(s) (inner only) + pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) + pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) + pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) + END DO + DO ji = nlci+1, jpi ! added column(s) (full) + pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) + pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) + pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) + END DO + ! + ELSE ! standard close or cyclic treatment + ! + ! ! East-West boundaries + IF( nbondi == 2 .AND. & ! Cyclic east-west + & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west + pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east + ELSE ! closed + IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point + pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north + ENDIF + ! ! North-South boundaries (always closed) + IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point + pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north + ! + ENDIF + END DO + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + DO ii = 1 , num_fields + SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = nlci-nreci + DO jl = 1, jpreci + zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) + zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) + END DO + END SELECT + END DO + ! + ! ! Migrations + imigr = jpreci * jpj + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) + CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci - jpreci + ! + + DO ii = 1 , num_fields + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) + pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) + END DO + END SELECT + END DO + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + !First Array + DO ii = 1 , num_fields + IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions + ijhom = nlcj-nrecj + DO jl = 1, jprecj + zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) + zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) + END DO + ENDIF + END DO + ! + ! ! Migrations + imigr = jprecj * jpi + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) + CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) + CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj - jprecj + ! + + DO ii = 1 , num_fields + !First Array + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) + pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) + END DO + END SELECT + END DO + + ! 4. north fold treatment + ! ----------------------- + ! + !First Array + IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; + DO ii = 1 , num_fields + CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp + END DO + CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + ! + DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) + ! + END SUBROUTINE mpp_lnk_2d_multiple + + + SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + TYPE(arrayptr) , DIMENSION(9) :: pt2d_array + CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points + REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary + INTEGER , INTENT (inout) :: num_fields + !!--------------------------------------------------------------------- + num_fields = num_fields + 1 + pt2d_array(num_fields)%pt2d => pt2d + type_array(num_fields) = cd_type + psgn_array(num_fields) = psgn + END SUBROUTINE load_array + + + SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & + & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & + & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) + !!--------------------------------------------------------------------- + ! Second 2D array on which the boundary condition is applied + REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA + REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE + REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI + ! define the nature of ptab array grid-points + CHARACTER(len=1) , INTENT(in ) :: cd_typeA + CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE + CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI + ! =-1 the sign change across the north fold boundary + REAL(wp) , INTENT(in ) :: psgnA + REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE + REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI + CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) + !! + TYPE(arrayptr) , DIMENSION(9) :: pt2d_array + CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary + INTEGER :: num_fields + !!--------------------------------------------------------------------- + ! + num_fields = 0 + ! + ! Load the first array + CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) + ! + ! Look if more arrays are added + IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) + IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) + ! + CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) + ! + END SUBROUTINE mpp_lnk_2d_9 + + + SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d *** + !! + !! ** Purpose : Message passing manadgement for 2d array + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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 + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) + !! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east + !!---------------------------------------------------------------------- + ! + ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & + & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) + ! + IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value + ELSE ; zland = 0._wp ! zero by default + ENDIF + + ! 1. standard boundary treatment + ! ------------------------------ + ! + IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values + ! + ! WARNING pt2d is defined only between nld and nle + DO jj = nlcj+1, jpj ! added line(s) (inner only) + pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) + pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) + pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) + END DO + DO ji = nlci+1, jpi ! added column(s) (full) + pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) + pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) + pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) + END DO + ! + ELSE ! standard close or cyclic treatment + ! + ! ! East-West boundaries + IF( nbondi == 2 .AND. & ! Cyclic east-west + & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + pt2d( 1 ,:) = pt2d(jpim1,:) ! west + pt2d(jpi,:) = pt2d( 2 ,:) ! east + ELSE ! closed + IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point + pt2d(nlci-jpreci+1:jpi ,:) = zland ! north + ENDIF + ! ! North-South boundaries (always closed) + IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point + pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north + ! + 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 = nlci-nreci + DO jl = 1, jpreci + zt2ew(:,jl,1) = pt2d(jpreci+jl,:) + zt2we(:,jl,1) = pt2d(iihom +jl,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci - jpreci + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + pt2d(iihom+jl,:) = zt2ew(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + pt2d(jl ,:) = zt2we(:,jl,2) + pt2d(iihom+jl,:) = zt2ew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + pt2d(jl ,:) = zt2we(:,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 = nlcj-nrecj + DO jl = 1, jprecj + zt2sn(:,jl,1) = pt2d(:,ijhom +jl) + zt2ns(:,jl,1) = pt2d(:,jprecj+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj - jprecj + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + pt2d(:,ijhom+jl) = zt2ns(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + pt2d(:,jl ) = zt2sn(:,jl,2) + pt2d(:,ijhom+jl) = zt2ns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + pt2d(:,jl ) = zt2sn(:,jl,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) + ! + END SUBROUTINE mpp_lnk_2d + + + SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_3d_gather *** + !! + !! ** Purpose : Message passing manadgement for two 3D arrays + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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 + !! + !! ** Action : ptab1 and ptab2 with update value at its periphery + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays + CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + !! ! = 1. , the sign is kept + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + 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(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north + REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east + !!---------------------------------------------------------------------- + ! + ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & + & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) + ! + ! 1. standard boundary treatment + ! ------------------------------ + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + ptab1( 1 ,:,:) = ptab1(jpim1,:,:) + ptab1(jpi,:,:) = ptab1( 2 ,:,:) + ptab2( 1 ,:,:) = ptab2(jpim1,:,:) + ptab2(jpi,:,:) = ptab2( 2 ,:,:) + ELSE !* closed + IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point + IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0 + ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north + ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 + ENDIF + + + ! ! North-South boundaries + IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point + IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0 + ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north + ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 + + + ! 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 = nlci-nreci + DO jl = 1, jpreci + zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) + zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) + zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) + zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj * jpk *2 + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) + CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci - jpreci + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) + ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) + ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) + ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) + ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) + ptab2(jl ,:,:) = zt4we(:,jl,:,2,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 = nlcj - nrecj + DO jl = 1, jprecj + zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) + zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) + zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) + zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi * jpk * 2 + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) + CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj - jprecj + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) + ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + ptab1(:,jl ,:) = zt4sn(:,jl,:,1,2) + ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) + ptab2(:,jl ,:) = zt4sn(:,jl,:,2,2) + ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) + ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + IF( npolj /= 0 ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) + CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs. + CALL lbc_nfd ( ptab2, cd_type2, psgn ) + CASE DEFAULT + CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs. + CALL mpp_lbc_north (ptab2, cd_type2, psgn) + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) + ! + END SUBROUTINE mpp_lnk_3d_gather + + + SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_e *** + !! + !! ** Purpose : Message passing manadgement for 2d array (with halo) + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! jpri : number of rows for extra outer halo + !! jprj : number of columns 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 + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: jpri + INTEGER , INTENT(in ) :: jprj + REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the + !! ! north boundary, = 1. otherwise + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ipreci, iprecj ! temporary integers + 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-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns + REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn + REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe + REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew + !!---------------------------------------------------------------------- + + ipreci = jpreci + jpri ! take into account outer extra 2D overlap area + iprecj = jprecj + jprj + + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! !* North-South boundaries (always colsed) + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point + pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north + + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east + pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west + ! + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point + pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( npolj /= 0 ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) + CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) + 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 = nlci-nreci-jpri + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(jpreci+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*jprj) + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) + CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci - jpreci + ! + 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-jpri,:) = r2dwe(:,jl,2) + pt2d( iihom+jl,:) = r2dew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, ipreci + pt2d(jl-jpri,:) = 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 = nlcj-nrecj-jprj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,jprecj+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*jpri ) + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) + CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj - jprecj + ! + 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-jprj) = r2dsn(:,jl,2) + pt2d(:,ijhom+jl ) = r2dns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, iprecj + pt2d(:,jl-jprj) = r2dsn(:,jl,2) + END DO + END SELECT + ! + END SUBROUTINE mpp_lnk_2d_e + + SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_sum_3d *** + !! + !! ** Purpose : Message passing manadgement (sum the overlap region) + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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 + !! + !! ** Action : ptab with update value at its periphery + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) + !! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + ! + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east + + !!---------------------------------------------------------------------- + + ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & + & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) + + ! + IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value + ELSE ; zland = 0.e0 ! zero by default + ENDIF + + ! 1. standard boundary treatment + ! ------------------------------ + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + SELECT CASE ( nbondi ) ! Read lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = nlci-jpreci + DO jl = 1, jpreci + zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp + zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj * jpk + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write lateral conditions + iihom = nlci-nreci + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) + ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) + END DO + END SELECT + + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( nbondj /= 2 ) THEN ! Read lateral conditions + ijhom = nlcj-jprecj + DO jl = 1, jprecj + zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp + zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi * jpk + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write lateral conditions + ijhom = nlcj-nrecj + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) + ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) + ! + END SUBROUTINE mpp_lnk_sum_3d + + SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_sum_2d *** + !! + !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region) + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! 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 + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only + REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) + !! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east + + !!---------------------------------------------------------------------- + + ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & + & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) + + ! + IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value + ELSE ; zland = 0.e0 ! zero by default + ENDIF + + ! 1. standard boundary treatment + ! ------------------------------ + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + SELECT CASE ( nbondi ) ! Read lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = nlci - jpreci + DO jl = 1, jpreci + zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp + zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write lateral conditions + iihom = nlci-nreci + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, jpreci + pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) + pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) + END DO + END SELECT + + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( nbondj /= 2 ) THEN ! Read lateral conditions + ijhom = nlcj - jprecj + DO jl = 1, jprecj + zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp + zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write lateral conditions + ijhom = nlcj-nrecj + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, jprecj + pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) + pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) + ! + END SUBROUTINE mpp_lnk_sum_2d + + 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 + !!---------------------------------------------------------------------- + ! + SELECT CASE ( cn_mpi_send ) + CASE ( 'S' ) ! Standard mpi send (blocking) + CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag ) + CASE ( 'B' ) ! Buffer mpi send (blocking) + CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag ) + CASE ( 'I' ) ! Immediate mpi send (non-blocking send) + ! be carefull, one more argument here : the mpi request identifier.. + CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag ) + END SELECT + ! + 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 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_opa, istatus, iflag ) + ! + 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 + CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & + & mpi_double_precision, kp , mpi_comm_opa, ierror ) + ! + END SUBROUTINE mppgather + + + SUBROUTINE mppscatter( pio, kp, ptab ) + !!---------------------------------------------------------------------- + !! *** routine mppscatter *** + !! + !! ** Purpose : Transfert between awork array which is distributed + !! following the vertical level and the local subdomain array. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array + INTEGER :: kp ! Tag (not used with MPI + REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + itaille = jpi * jpj + ! + CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & + & mpi_double_precision, kp , mpi_comm_opa, ierror ) + ! + END SUBROUTINE mppscatter + + + SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmax_a_int *** + !! + !! ** Purpose : Find maximum value in an integer layout array + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kdim ! size of array + INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array + INTEGER , INTENT(in ), OPTIONAL :: kcom ! + ! + INTEGER :: ierror, localcomm ! temporary integer + INTEGER, DIMENSION(kdim) :: iwork + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) + ! + ktab(:) = iwork(:) + ! + END SUBROUTINE mppmax_a_int + + + SUBROUTINE mppmax_int( ktab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmax_int *** + !! + !! ** Purpose : Find maximum value in an integer layout array + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(inout) :: ktab ! ??? + INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? + ! + INTEGER :: ierror, iwork, localcomm ! temporary integer + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) + ! + ktab = iwork + ! + END SUBROUTINE mppmax_int + + + SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmin_a_int *** + !! + !! ** Purpose : Find minimum value in an integer layout array + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kdim ! size of array + INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array + INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array + !! + INTEGER :: ierror, localcomm ! temporary integer + INTEGER, DIMENSION(kdim) :: iwork + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) + ! + ktab(:) = iwork(:) + ! + END SUBROUTINE mppmin_a_int + + + SUBROUTINE mppmin_int( ktab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmin_int *** + !! + !! ** Purpose : Find minimum value in an integer layout array + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(inout) :: ktab ! ??? + INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array + !! + INTEGER :: ierror, iwork, localcomm + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) + ! + ktab = iwork + ! + END SUBROUTINE mppmin_int + + + SUBROUTINE mppsum_a_int( ktab, kdim ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_a_int *** + !! + !! ** Purpose : Global integer sum, 1D array case + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kdim ! ??? + INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? + ! + INTEGER :: ierror + INTEGER, DIMENSION (kdim) :: iwork + !!---------------------------------------------------------------------- + ! + CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) + ! + ktab(:) = iwork(:) + ! + END SUBROUTINE mppsum_a_int + + + SUBROUTINE mppsum_int( ktab ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_int *** + !! + !! ** Purpose : Global integer sum + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(inout) :: ktab + !! + INTEGER :: ierror, iwork + !!---------------------------------------------------------------------- + ! + CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) + ! + ktab = iwork + ! + END SUBROUTINE mppsum_int + + + SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmax_a_real *** + !! + !! ** Purpose : Maximum + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kdim + REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab + INTEGER , INTENT(in ), OPTIONAL :: kcom + ! + INTEGER :: ierror, localcomm + REAL(wp), DIMENSION(kdim) :: zwork + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) + ptab(:) = zwork(:) + ! + END SUBROUTINE mppmax_a_real + + + SUBROUTINE mppmax_real( ptab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmax_real *** + !! + !! ** Purpose : Maximum + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: ptab ! ??? + INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? + !! + INTEGER :: ierror, localcomm + REAL(wp) :: zwork + !!---------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) + ptab = zwork + ! + END SUBROUTINE mppmax_real + + SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmax_real *** + !! + !! ** Purpose : Maximum + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? + INTEGER , INTENT(in ) :: NUM + INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? + !! + INTEGER :: ierror, localcomm + REAL(wp) , POINTER , DIMENSION(:) :: zwork + !!---------------------------------------------------------------------- + ! + CALL wrk_alloc(NUM , zwork) + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) + ptab = zwork + CALL wrk_dealloc(NUM , zwork) + ! + END SUBROUTINE mppmax_real_multiple + + + SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmin_a_real *** + !! + !! ** Purpose : Minimum of REAL, array case + !! + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kdim + REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab + INTEGER , INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ierror, localcomm + REAL(wp), DIMENSION(kdim) :: zwork + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) + ptab(:) = zwork(:) + ! + END SUBROUTINE mppmin_a_real + + + SUBROUTINE mppmin_real( ptab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppmin_real *** + !! + !! ** Purpose : minimum of REAL, scalar case + !! + !!----------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: ptab ! + INTEGER , INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ierror + REAL(wp) :: zwork + INTEGER :: localcomm + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) + ptab = zwork + ! + END SUBROUTINE mppmin_real + + + SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_a_real *** + !! + !! ** Purpose : global sum, REAL ARRAY argument case + !! + !!----------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kdim ! size of ptab + REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array + INTEGER , INTENT( in ), OPTIONAL :: kcom + !! + INTEGER :: ierror ! temporary integer + INTEGER :: localcomm + REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) + ptab(:) = zwork(:) + ! + END SUBROUTINE mppsum_a_real + + + SUBROUTINE mppsum_real( ptab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_real *** + !! + !! ** Purpose : global sum, SCALAR argument case + !! + !!----------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: ptab ! input scalar + INTEGER , INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ierror, localcomm + REAL(wp) :: zwork + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) + ptab = zwork + ! + END SUBROUTINE mppsum_real + + + SUBROUTINE mppsum_realdd( ytab, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_realdd *** + !! + !! ** Purpose : global sum in Massively Parallel Processing + !! SCALAR argument case for double-double precision + !! + !!----------------------------------------------------------------------- + COMPLEX(wp), INTENT(inout) :: ytab ! input scalar + INTEGER , INTENT(in ), OPTIONAL :: kcom + ! + INTEGER :: ierror + INTEGER :: localcomm + COMPLEX(wp) :: zwork + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + ! reduce local sums into global sum + CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) + ytab = zwork + ! + END SUBROUTINE mppsum_realdd + + + SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mppsum_a_realdd *** + !! + !! ** Purpose : global sum in Massively Parallel Processing + !! COMPLEX ARRAY case for double-double precision + !! + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kdim ! size of ytab + COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array + INTEGER , OPTIONAL , INTENT(in ) :: kcom + ! + INTEGER:: ierror, localcomm ! local integer + COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace + !!----------------------------------------------------------------------- + ! + localcomm = mpi_comm_opa + IF( PRESENT(kcom) ) localcomm = kcom + ! + CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) + ytab(:) = zwork(:) + ! + END SUBROUTINE mppsum_a_realdd + + + SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) + !!------------------------------------------------------------------------ + !! *** routine mpp_minloc *** + !! + !! ** Purpose : Compute the global minimum of an array ptab + !! and also give its global position + !! + !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC + !! + !!-------------------------------------------------------------------------- + REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array + REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask + REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame + ! + INTEGER :: ierror + INTEGER , DIMENSION(2) :: ilocs + REAL(wp) :: zmin ! local minimum + REAL(wp), DIMENSION(2,1) :: zain, zaout + !!----------------------------------------------------------------------- + ! + zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) + ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) + ! + ki = ilocs(1) + nimpp - 1 + kj = ilocs(2) + njmpp - 1 + ! + zain(1,:)=zmin + zain(2,:)=ki+10000.*kj + ! + CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) + ! + pmin = zaout(1,1) + kj = INT(zaout(2,1)/10000.) + ki = INT(zaout(2,1) - 10000.*kj ) + ! + END SUBROUTINE mpp_minloc2d + + + SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk) + !!------------------------------------------------------------------------ + !! *** routine mpp_minloc *** + !! + !! ** Purpose : Compute the global minimum of an array ptab + !! and also give its global position + !! + !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC + !! + !!-------------------------------------------------------------------------- + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask + REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame + !! + INTEGER :: ierror + REAL(wp) :: zmin ! local minimum + INTEGER , DIMENSION(3) :: ilocs + REAL(wp), DIMENSION(2,1) :: zain, zaout + !!----------------------------------------------------------------------- + ! + zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) + ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) + ! + ki = ilocs(1) + nimpp - 1 + kj = ilocs(2) + njmpp - 1 + kk = ilocs(3) + ! + zain(1,:)=zmin + zain(2,:)=ki+10000.*kj+100000000.*kk + ! + CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) + ! + pmin = zaout(1,1) + kk = INT( zaout(2,1) / 100000000. ) + kj = INT( zaout(2,1) - kk * 100000000. ) / 10000 + ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) + ! + END SUBROUTINE mpp_minloc3d + + + SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj ) + !!------------------------------------------------------------------------ + !! *** routine mpp_maxloc *** + !! + !! ** Purpose : Compute the global maximum of an array ptab + !! and also give its global position + !! + !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC + !! + !!-------------------------------------------------------------------------- + REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array + REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask + REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab + INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame + !! + INTEGER :: ierror + INTEGER, DIMENSION (2) :: ilocs + REAL(wp) :: zmax ! local maximum + REAL(wp), DIMENSION(2,1) :: zain, zaout + !!----------------------------------------------------------------------- + ! + zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) + ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) + ! + ki = ilocs(1) + nimpp - 1 + kj = ilocs(2) + njmpp - 1 + ! + zain(1,:) = zmax + zain(2,:) = ki + 10000. * kj + ! + CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) + ! + pmax = zaout(1,1) + kj = INT( zaout(2,1) / 10000. ) + ki = INT( zaout(2,1) - 10000.* kj ) + ! + END SUBROUTINE mpp_maxloc2d + + + SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) + !!------------------------------------------------------------------------ + !! *** routine mpp_maxloc *** + !! + !! ** Purpose : Compute the global maximum of an array ptab + !! and also give its global position + !! + !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC + !! + !!-------------------------------------------------------------------------- + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask + REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab + INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame + !! + REAL(wp) :: zmax ! local maximum + REAL(wp), DIMENSION(2,1) :: zain, zaout + INTEGER , DIMENSION(3) :: ilocs + INTEGER :: ierror + !!----------------------------------------------------------------------- + ! + zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) + ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) + ! + ki = ilocs(1) + nimpp - 1 + kj = ilocs(2) + njmpp - 1 + kk = ilocs(3) + ! + zain(1,:)=zmax + zain(2,:)=ki+10000.*kj+100000000.*kk + ! + CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) + ! + pmax = zaout(1,1) + kk = INT( zaout(2,1) / 100000000. ) + kj = INT( zaout(2,1) - kk * 100000000. ) / 10000 + ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) + ! + END SUBROUTINE mpp_maxloc3d + + + SUBROUTINE mppsync() + !!---------------------------------------------------------------------- + !! *** routine mppsync *** + !! + !! ** Purpose : Massively parallel processors, synchroneous + !! + !!----------------------------------------------------------------------- + INTEGER :: ierror + !!----------------------------------------------------------------------- + ! + CALL mpi_barrier( mpi_comm_opa, ierror ) + ! + END SUBROUTINE mppsync + + + SUBROUTINE mppstop + !!---------------------------------------------------------------------- + !! *** routine mppstop *** + !! + !! ** purpose : Stop massively parallel processors method + !! + !!---------------------------------------------------------------------- + INTEGER :: info + !!---------------------------------------------------------------------- + ! + CALL mppsync + CALL mpi_finalize( info ) + ! + END SUBROUTINE mppstop + + + SUBROUTINE mpp_comm_free( kcom ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kcom + !! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + CALL MPI_COMM_FREE(kcom, ierr) + ! + END SUBROUTINE mpp_comm_free + + + SUBROUTINE mpp_ini_ice( pindic, kumout ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_ice *** + !! + !! ** Purpose : Initialize special communicator for ice areas + !! condition together with global variables needed in the ddmpp folding + !! + !! ** Method : - Look for ice processors in ice routines + !! - Put their number in nrank_ice + !! - Create groups for the world processors and the ice processors + !! - Create a communicator for ice processors + !! + !! ** output + !! njmppmax = njmpp for northern procs + !! ndim_rank_ice = number of processors with ice + !! nrank_ice (ndim_rank_ice) = ice processors + !! ngrp_iworld = group ID for the world processors + !! ngrp_ice = group ID for the ice processors + !! ncomm_ice = communicator for the ice procs. + !! n_ice_root = number (in the world) of proc 0 in the ice comm. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: pindic + INTEGER, INTENT(in) :: kumout ! ocean.output logical unit + !! + INTEGER :: jjproc + INTEGER :: ii, ierr + INTEGER, ALLOCATABLE, DIMENSION(:) :: kice + INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork + !!---------------------------------------------------------------------- + ! + ! Since this is just an init routine and these arrays are of length jpnij + ! then don't use wrk_nemo module - just allocate and deallocate. + ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr ) + IF( ierr /= 0 ) THEN + WRITE(kumout, cform_err) + WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)' + CALL mppstop + ENDIF + + ! Look for how many procs with sea-ice + ! + kice = 0 + DO jjproc = 1, jpnij + IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1 + END DO + ! + zwork = 0 + CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr ) + ndim_rank_ice = SUM( zwork ) + + ! Allocate the right size to nrank_north + IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice ) + ALLOCATE( nrank_ice(ndim_rank_ice) ) + ! + ii = 0 + nrank_ice = 0 + DO jjproc = 1, jpnij + IF( zwork(jjproc) == 1) THEN + ii = ii + 1 + nrank_ice(ii) = jjproc -1 + ENDIF + END DO + + ! Create the world group + CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr ) + + ! Create the ice group from the world group + CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr ) + + ! Create the ice communicator , ie the pool of procs with sea-ice + CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr ) + + ! Find proc number in the world of proc 0 in the north + ! The following line seems to be useless, we just comment & keep it as reminder + ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr) + ! + CALL MPI_GROUP_FREE(ngrp_ice, ierr) + CALL MPI_GROUP_FREE(ngrp_iworld, ierr) + + DEALLOCATE(kice, zwork) + ! + END SUBROUTINE mpp_ini_ice + + + SUBROUTINE mpp_ini_znl( kumout ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_znl *** + !! + !! ** Purpose : Initialize special communicator for computing zonal sum + !! + !! ** Method : - Look for processors in the same row + !! - Put their number in nrank_znl + !! - Create group for the znl processors + !! - Create a communicator for znl processors + !! - Determine if processor should write znl files + !! + !! ** output + !! ndim_rank_znl = number of processors on the same row + !! ngrp_znl = group ID for the znl processors + !! ncomm_znl = communicator for the ice procs. + !! n_znl_root = number (in the world) of proc 0 in the ice comm. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kumout ! ocean.output logical units + ! + INTEGER :: jproc ! dummy loop integer + INTEGER :: ierr, ii ! local integer + INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork + !!---------------------------------------------------------------------- + !-$$ WRITE (numout,*) 'mpp_ini_znl ', 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_opa : ', mpi_comm_opa + ! + ALLOCATE( kwork(jpnij), STAT=ierr ) + IF( ierr /= 0 ) THEN + WRITE(kumout, cform_err) + WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' + CALL mppstop + ENDIF + + IF( jpnj == 1 ) THEN + ngrp_znl = ngrp_world + ncomm_znl = mpi_comm_opa + ELSE + ! + CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, 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_opa,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_opa, 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 ( kwork(1), kcom = ncomm_znl) + IF ( nimpp == kwork(1)) l_znl_root = .TRUE. + END IF + + DEALLOCATE(kwork) + + END SUBROUTINE mpp_ini_znl + + + SUBROUTINE mpp_ini_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 + !!---------------------------------------------------------------------- + ! + 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_opa, 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_opa, ngrp_north, ncomm_north, ierr ) + ! + END SUBROUTINE mpp_ini_north + + + SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn ) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_3d *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4 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. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W gridpoints + REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold + !! ! = 1. , the sign is kept + INTEGER :: ji, jj, jr, jk + INTEGER :: ierr, itaille, ildi, ilei, iilb + INTEGER :: ijpj, ijpjm1, 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 + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr + + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) + ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) + + ijpj = 4 + ijpjm1 = 3 + ! + znorthloc(:,:,:) = 0 + DO jk = 1, jpk + DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d + ij = jj - nlcj + ijpj + znorthloc(:,ij,jk) = pt3d(:,jj,jk) + END DO + END DO + ! + ! ! Build in procs of ncomm_north the znorthgloio + itaille = jpi * jpk * ijpj + + IF ( l_north_nogather ) THEN + ! + ztabr(:,:,:) = 0 + ztabl(:,:,:) = 0 + + DO jk = 1, jpk + DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array + ij = jj - nlcj + ijpj + DO ji = nfsloop, nfeloop + ztabl(ji,ij,jk) = pt3d(ji,jj,jk) + END DO + END DO + END DO + + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) + ENDIF + END DO + DO jr = 1,nsndto + iproc = nfipproc(isendto(jr),jpnj) + IF(iproc .ne. -1) THEN + ilei = nleit (iproc+1) + ildi = nldit (iproc+1) + iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) + ENDIF + IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN + CALL mpprecv(5, zfoldwk, itaille, iproc) + DO jk = 1, jpk + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) + END DO + END DO + END DO + ELSE IF (iproc .eq. (narea-1)) THEN + DO jk = 1, jpk + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) + END DO + END DO + END DO + ENDIF + END DO + IF (l_isend) THEN + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) + ENDIF + END DO + ENDIF + CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition + DO jk = 1, jpk + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d + ij = jj - nlcj + ijpj + DO ji= 1, nlci + pt3d(ji,jj,jk) = ztabl(ji,ij,jk) + END DO + END DO + END DO + ! + + ELSE + CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & + & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + ztab(:,:,:) = 0.e0 + 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 jk = 1, jpk + DO jj = 1, ijpj + DO ji = ildi, ilei + ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) + END DO + END DO + END DO + END DO + CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition + ! + DO jk = 1, jpk + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d + ij = jj - nlcj + ijpj + DO ji= 1, nlci + pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) + END DO + END DO + END DO + ! + ENDIF + ! + ! The ztab array has been either: + ! a. Fully populated by the mpi_allgather operation or + ! b. Had the active points for this domain and northern neighbours populated + ! by peer to peer exchanges + ! Either way the array may be folded by lbc_nfd and the result for the span of + ! this domain will be identical. + ! + DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) + DEALLOCATE( ztabl, ztabr ) + ! + END SUBROUTINE mpp_lbc_north_3d + + + SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_2d *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 (for 2d array ) + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4 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. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points + ! ! = T , U , V , F or W gridpoints + REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold + !! ! = 1. , the sign is kept + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille, ildi, ilei, iilb + INTEGER :: ijpj, ijpjm1, 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 + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) + ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) + ! + ijpj = 4 + ijpjm1 = 3 + ! + DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d + ij = jj - nlcj + ijpj + znorthloc(:,ij) = pt2d(:,jj) + END DO + + ! ! Build in procs of ncomm_north the znorthgloio + itaille = jpi * ijpj + IF ( l_north_nogather ) THEN + ! + ! Avoid the use of mpi_allgather by exchanging only with the processes already identified + ! (in nemo_northcomms) as being involved in this process' northern boundary exchange + ! + ztabr(:,:) = 0 + ztabl(:,:) = 0 + + DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array + ij = jj - nlcj + ijpj + DO ji = nfsloop, nfeloop + ztabl(ji,ij) = pt2d(ji,jj) + END DO + END DO + + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) + ENDIF + END DO + DO jr = 1,nsndto + iproc = nfipproc(isendto(jr),jpnj) + IF(iproc .ne. -1) THEN + ilei = nleit (iproc+1) + ildi = nldit (iproc+1) + iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) + ENDIF + IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN + CALL mpprecv(5, zfoldwk, itaille, iproc) + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj) = zfoldwk(ji,jj) + END DO + END DO + ELSE IF (iproc .eq. (narea-1)) THEN + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) + END DO + END DO + ENDIF + END DO + IF (l_isend) THEN + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) + ENDIF + END DO + ENDIF + CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition + ! + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d + ij = jj - nlcj + ijpj + DO ji = 1, nlci + pt2d(ji,jj) = ztabl(ji,ij) + END DO + END DO + ! + ELSE + CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & + & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + ztab(:,:) = 0.e0 + 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, ijpj + DO ji = ildi, ilei + ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) + END DO + END DO + END DO + CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition + ! + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d + ij = jj - nlcj + ijpj + DO ji = 1, nlci + pt2d(ji,jj) = ztab(ji+nimpp-1,ij) + END DO + END DO + ! + ENDIF + DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) + DEALLOCATE( ztabl, ztabr ) + ! + END SUBROUTINE mpp_lbc_north_2d + + SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_2d *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 + !! (for multiple 2d arrays ) + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4 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. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d + TYPE( arrayptr ), DIMENSION(:) :: pt2d_array + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points + ! ! = T , U , V , F or W gridpoints + REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold + !! ! = 1. , the sign is kept + INTEGER :: ji, jj, jr, jk + INTEGER :: ierr, itaille, ildi, ilei, iilb + INTEGER :: ijpj, ijpjm1, 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 + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions + ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) + ! + ijpj = 4 + ijpjm1 = 3 + ! + + DO jk = 1, num_fields + DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) + ij = jj - nlcj + ijpj + znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) + END DO + END DO + ! ! Build in procs of ncomm_north the znorthgloio + itaille = jpi * ijpj + + IF ( l_north_nogather ) THEN + ! + ! Avoid the use of mpi_allgather by exchanging only with the processes already identified + ! (in nemo_northcomms) as being involved in this process' northern boundary exchange + ! + ztabr(:,:,:) = 0 + ztabl(:,:,:) = 0 + + DO jk = 1, num_fields + DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array + ij = jj - nlcj + ijpj + DO ji = nfsloop, nfeloop + ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) + END DO + END DO + END DO + + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times + ENDIF + END DO + DO jr = 1,nsndto + iproc = nfipproc(isendto(jr),jpnj) + IF(iproc .ne. -1) THEN + ilei = nleit (iproc+1) + ildi = nldit (iproc+1) + iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) + ENDIF + IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN + CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times + DO jk = 1 , num_fields + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D + END DO + END DO + END DO + ELSE IF (iproc .eq. (narea-1)) THEN + DO jk = 1, num_fields + DO jj = 1, ijpj + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D + END DO + END DO + END DO + ENDIF + END DO + IF (l_isend) THEN + DO jr = 1,nsndto + IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN + CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) + ENDIF + END DO + ENDIF + ! + DO ji = 1, num_fields ! Loop to manage 3D variables + CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition + END DO + ! + DO jk = 1, num_fields + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d + ij = jj - nlcj + ijpj + DO ji = 1, nlci + pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D + END DO + END DO + END DO + + ! + ELSE + ! + CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & + & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + ztab(:,:,:) = 0.e0 + DO jk = 1, num_fields + 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, ijpj + DO ji = ildi, ilei + ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) + END DO + END DO + END DO + END DO + + DO ji = 1, num_fields + CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition + END DO + ! + DO jk = 1, num_fields + DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d + ij = jj - nlcj + ijpj + DO ji = 1, nlci + pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) + END DO + END DO + END DO + ! + ! + ENDIF + DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) + DEALLOCATE( ztabl, ztabr ) + ! + END SUBROUTINE mpp_lbc_north_2d_multiple + + SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_2d *** + !! + !! ** 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+2*jpr2dj 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. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), 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 :: ji, jj, jr + INTEGER :: ierr, itaille, ildi, ilei, iilb + INTEGER :: ijpj, ij, iproc + ! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + + !!---------------------------------------------------------------------- + ! + ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) + + ! + ijpj=4 + ztab_e(:,:) = 0.e0 + + ij=0 + ! put in znorthloc_e the last 4 jlines of pt2d + DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj + ij = ij + 1 + DO ji = 1, jpi + znorthloc_e(ji,ij)=pt2d(ji,jj) + END DO + END DO + ! + itaille = jpi * ( ijpj + 2 * jpr2dj ) + CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & + & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + 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, ijpj+2*jpr2dj + 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(:,:), cd_type, psgn, pr2dj = jpr2dj ) + + ij = jpr2dj + !! Scatter back to pt2d + DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj + ij = ij +1 + DO ji= 1, nlci + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! + END SUBROUTINE mpp_lbc_north_e + + + SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_bdy_3d *** + !! + !! ** Purpose : Message passing management + !! + !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! nbondi_bdy : mark for "east-west local boundary" + !! nbondj_bdy : 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 + !! + !! ** Action : ptab with update value at its periphery + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland ! local scalar + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + ! + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east + !!---------------------------------------------------------------------- + ! + ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & + & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) + + zland = 0._wp + + ! 1. standard boundary treatment + ! ------------------------------ + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2) THEN + IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN + ptab( 1 ,:,:) = ptab(jpim1,:,:) + ptab(jpi,:,:) = ptab( 2 ,:,:) + ELSE + IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point + ptab(nlci-jpreci+1:jpi,:,:) = zland ! north + ENDIF + ELSEIF(nbondi == -1) THEN + IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point + ELSEIF(nbondi == 1) THEN + ptab(nlci-jpreci+1:jpi,:,:) = zland ! north + ENDIF !* closed + + IF (nbondj == 2 .OR. nbondj == -1) THEN + IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point + ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN + ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north + ENDIF + ! + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = nlci-nreci + DO jl = 1, jpreci + zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj * jpk + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) + CASE ( -1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) + CASE ( 0 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) + CASE ( 1 ) + CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) + END SELECT + ! + SELECT CASE ( nbondi_bdy_b(ib_bdy) ) + CASE ( -1 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + CASE ( 0 ) + CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + CASE ( 1 ) + CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) + END SELECT + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) + CASE ( -1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci-jpreci + ! + SELECT CASE ( nbondi_bdy_b(ib_bdy) ) + CASE ( -1 ) + DO jl = 1, jpreci + ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + ptab( jl,:,:) = zt3we(:,jl,:,2) + ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + ptab( jl,:,:) = zt3we(:,jl,:,2) + END DO + END SELECT + + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions + ijhom = nlcj-nrecj + DO jl = 1, jprecj + zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi * jpk + ! + SELECT CASE ( nbondj_bdy(ib_bdy) ) + CASE ( -1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) + CASE ( 0 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) + CASE ( 1 ) + CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) + END SELECT + ! + SELECT CASE ( nbondj_bdy_b(ib_bdy) ) + CASE ( -1 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + CASE ( 0 ) + CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + CASE ( 1 ) + CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) + END SELECT + ! + SELECT CASE ( nbondj_bdy(ib_bdy) ) + CASE ( -1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj-jprecj + ! + SELECT CASE ( nbondj_bdy_b(ib_bdy) ) + CASE ( -1 ) + DO jl = 1, jprecj + ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + ptab(:,jl ,:) = zt3sn(:,jl,:,2) + ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + ptab(:,jl,:) = zt3sn(:,jl,:,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) + ! + END SUBROUTINE mpp_lnk_bdy_3d + + + SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_bdy_2d *** + !! + !! ** Purpose : Message passing management + !! + !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! nbondi_bdy : mark for "east-west local boundary" + !! nbondj_bdy : 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 + !! + !! ** Action : ptab with update value at its periphery + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points + ! ! = T , U , V , F , W points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary + ! ! = 1. , the sign is kept + INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set + ! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend + REAL(wp) :: zland + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east + !!---------------------------------------------------------------------- + + ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & + & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) + + zland = 0._wp + + ! 1. standard boundary treatment + ! ------------------------------ + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2 ) THEN + IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN + ptab( 1 ,:) = ptab(jpim1,:) + ptab(jpi,:) = ptab( 2 ,:) + ELSE + IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point + ptab(nlci-jpreci+1:jpi ,:) = zland ! north + ENDIF + ELSEIF(nbondi == -1) THEN + IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point + ELSEIF(nbondi == 1) THEN + ptab(nlci-jpreci+1:jpi ,:) = zland ! north + ENDIF + ! !* closed + IF( nbondj == 2 .OR. nbondj == -1 ) THEN + IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point + ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN + ptab(:,nlcj-jprecj+1:jpj ) = zland ! north + ENDIF + ! + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = nlci-nreci + DO jl = 1, jpreci + zt2ew(:,jl,1) = ptab(jpreci+jl,:) + zt2we(:,jl,1) = ptab(iihom +jl,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = jpreci * jpj + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) + CASE ( -1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) + CASE ( 0 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) + CASE ( 1 ) + CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) + END SELECT + ! + SELECT CASE ( nbondi_bdy_b(ib_bdy) ) + CASE ( -1 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + CASE ( 0 ) + CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + CASE ( 1 ) + CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) + END SELECT + ! + SELECT CASE ( nbondi_bdy(ib_bdy) ) + CASE ( -1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci-jpreci + ! + SELECT CASE ( nbondi_bdy_b(ib_bdy) ) + CASE ( -1 ) + DO jl = 1, jpreci + ptab(iihom+jl,:) = zt2ew(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jpreci + ptab(jl ,:) = zt2we(:,jl,2) + ptab(iihom+jl,:) = zt2ew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jpreci + ptab(jl ,:) = zt2we(:,jl,2) + END DO + END SELECT + + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions + ijhom = nlcj-nrecj + DO jl = 1, jprecj + zt2sn(:,jl,1) = ptab(:,ijhom +jl) + zt2ns(:,jl,1) = ptab(:,jprecj+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = jprecj * jpi + ! + SELECT CASE ( nbondj_bdy(ib_bdy) ) + CASE ( -1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) + CASE ( 0 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) + CASE ( 1 ) + CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) + END SELECT + ! + SELECT CASE ( nbondj_bdy_b(ib_bdy) ) + CASE ( -1 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + CASE ( 0 ) + CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + CASE ( 1 ) + CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) + END SELECT + ! + SELECT CASE ( nbondj_bdy(ib_bdy) ) + CASE ( -1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + CASE ( 0 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) + CASE ( 1 ) + IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj-jprecj + ! + SELECT CASE ( nbondj_bdy_b(ib_bdy) ) + CASE ( -1 ) + DO jl = 1, jprecj + ptab(:,ijhom+jl) = zt2ns(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, jprecj + ptab(:,jl ) = zt2sn(:,jl,2) + ptab(:,ijhom+jl) = zt2ns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, jprecj + ptab(:,jl) = zt2sn(:,jl,2) + END DO + END SELECT + + + ! 4. north fold treatment + ! ----------------------- + ! + IF( npolj /= 0) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. + END SELECT + ! + ENDIF + ! + DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) + ! + END SUBROUTINE mpp_lnk_bdy_2d + + + SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) + !!--------------------------------------------------------------------- + !! *** routine mpp_init.opa *** + !! + !! ** Purpose :: export and attach a MPI buffer for bsend + !! + !! ** Method :: define buffer size in namelist, if 0 no buffer attachment + !! but classical mpi_init + !! + !! History :: 01/11 :: IDRIS initial version for IBM only + !! 08/04 :: R. Benshila, generalisation + !!--------------------------------------------------------------------- + CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt + INTEGER , INTENT(inout) :: ksft + INTEGER , INTENT( out) :: code + INTEGER :: ierr, ji + LOGICAL :: mpi_was_called + !!--------------------------------------------------------------------- + ! + CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization + IF ( code /= MPI_SUCCESS ) THEN + DO ji = 1, SIZE(ldtxt) + IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode + END DO + WRITE(*, cform_err) + WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' + CALL mpi_abort( mpi_comm_world, code, ierr ) + ENDIF + ! + IF( .NOT. mpi_was_called ) THEN + CALL mpi_init( code ) + CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code ) + IF ( code /= MPI_SUCCESS ) THEN + DO ji = 1, SIZE(ldtxt) + IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode + END DO + WRITE(*, cform_err) + WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' + CALL mpi_abort( mpi_comm_world, code, ierr ) + ENDIF + ENDIF + ! + IF( nn_buffer > 0 ) THEN + WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1 + ! Buffer allocation and attachment + ALLOCATE( tampon(nn_buffer), stat = ierr ) + IF( ierr /= 0 ) THEN + DO ji = 1, SIZE(ldtxt) + IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode + END DO + WRITE(*, cform_err) + WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr + CALL mpi_abort( mpi_comm_world, code, ierr ) + END IF + CALL mpi_buffer_attach( tampon, nn_buffer, code ) + ENDIF + ! + END SUBROUTINE mpi_init_opa + + 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_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) + !!--------------------------------------------------------------------- + !! *** 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+2*jpr2dj 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 version accounts for an extra halo with icebergs. + !! + !!---------------------------------------------------------------------- + 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, OPTIONAL , INTENT(in ) :: pr2dj + ! + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille, ildi, ilei, iilb + INTEGER :: ijpj, ij, iproc, ipr2dj + ! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- + ! + ijpj=4 + IF( PRESENT(pr2dj) ) THEN ! use of additional halos + ipr2dj = pr2dj + ELSE + ipr2dj = 0 + ENDIF + ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) + ! + ztab_e(:,:) = 0._wp + ! + ij = 0 + ! put in znorthloc_e the last 4 jlines of pt2d + DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj + ij = ij + 1 + DO ji = 1, jpi + znorthloc_e(ji,ij)=pt2d(ji,jj) + END DO + END DO + ! + itaille = jpi * ( ijpj + 2 * ipr2dj ) + CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & + & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + 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, ijpj+2*ipr2dj + 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(:,:), cd_type, psgn, pr2dj = ipr2dj ) + + ij = ipr2dj + !! Scatter back to pt2d + DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj + ij = ij +1 + DO ji= 1, nlci + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! + END SUBROUTINE mpp_lbc_north_icb + + + SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! nlci : first dimension of the local subdomain + !! nlcj : second dimension of the local subdomain + !! jpri : number of rows for extra outer halo + !! jprj : number of columns 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 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: jpri + INTEGER , INTENT(in ) :: jprj + REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + ! ! = T , U , V , F , W and I points + REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the + !! ! north boundary, = 1. otherwise + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! temporary integers + INTEGER :: ipreci, iprecj ! temporary integers + 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-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns + REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn + REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe + REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew + !!---------------------------------------------------------------------- + + ipreci = jpreci + jpri ! take into account outer extra 2D overlap area + iprecj = jprecj + jprj + + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN + pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east + pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west + ! + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point + pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( npolj /= 0 ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) + CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) + 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 = nlci-nreci-jpri + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(jpreci+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*jprj) + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) + CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + iihom = nlci - jpreci + ! + 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-jpri,:) = r2dwe(:,jl,2) + pt2d( iihom+jl,:) = r2dew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, ipreci + pt2d(jl-jpri,:) = 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 = nlcj-nrecj-jprj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,jprecj+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*jpri ) + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) + CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) + IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + ! ! Write Dirichlet lateral conditions + ijhom = nlcj - jprecj + ! + 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-jprj) = r2dsn(:,jl,2) + pt2d(:,ijhom+jl ) = r2dns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, iprecj + pt2d(:,jl-jprj) = r2dsn(:,jl,2) + END DO + END SELECT + + END SUBROUTINE mpp_lnk_2d_icb + + + !!---------------------------------------------------------------------- + !! All cases: 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), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 + CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 + !!---------------------------------------------------------------------- + ! + nstop = nstop + 1 + IF(lwp) THEN + WRITE(numout,cform_err) + IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 + IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 + IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 + IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 + IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 + IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 + IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 + IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 + IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 + IF( PRESENT(cd10) ) WRITE(numout,*) cd10 + ENDIF + CALL FLUSH(numout ) + IF( numstp /= -1 ) CALL FLUSH(numstp ) + IF( numsol /= -1 ) CALL FLUSH(numsol ) + IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) + ! + IF( cd1 == 'STOP' ) THEN + IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' + CALL mppstop() + 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,cform_war) + IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 + IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 + IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 + IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 + IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 + IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 + IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 + IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 + IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 + IF( PRESENT(cd10) ) WRITE(numout,*) cd10 + 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 + INTEGER :: iost + !!---------------------------------------------------------------------- + ! + ! adapt filename + ! ---------------- + clfile = TRIM(cdfile) + IF( PRESENT( karea ) ) THEN + IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1 + ENDIF + knum=get_unit() + ! + iost=0 + IF( cdacce(1:6) == 'DIRECT' ) THEN + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost ) + ELSE + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) + ENDIF + IF( iost == 0 ) THEN + IF(ldwp) THEN + WRITE(kout,*) ' file : ', 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 + IF(ldwp) THEN + WRITE(kout,*) + WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile + WRITE(kout,*) ' ======= === ' + WRITE(kout,*) ' unit = ', knum + WRITE(kout,*) ' status = ', cdstat + WRITE(kout,*) ' form = ', cdform + WRITE(kout,*) ' access = ', cdacce + WRITE(kout,*) ' iostat = ', iost + WRITE(kout,*) ' we stop. verify the file ' + WRITE(kout,*) + ENDIF + STOP 'ctl_opn bad opening' + ENDIF + ! + END SUBROUTINE ctl_opn + + + SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) + !!---------------------------------------------------------------------- + !! *** 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=4) :: clios ! string to convert iostat in character for print + LOGICAL , INTENT(in ) :: ldwp ! boolean term for print + !!---------------------------------------------------------------------- + ! + WRITE (clios, '(I4.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 + RETURN + ! + 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( 'get_unit: All logical units until 999 are used...' ) + get_unit = -1 + ENDIF + ! + END FUNCTION get_unit + + !!---------------------------------------------------------------------- +END MODULE lib_mpp diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/make_domain_cfg.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/make_domain_cfg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4d31b021af31fbae8c271d0c23c0ffd0589028ba --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/make_domain_cfg.f90 @@ -0,0 +1,20 @@ +PROGRAM make_domain_cfg + !!====================================================================== + !! *** PROGRAM make_domain_cfg *** + !! + !! ** Purpose : tool to create domain_cfg.nc file via nemogcm + !!====================================================================== + !! 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: nemo.f90 2528 2010-12-27 17:33:53Z rblod $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + ! + CALL nemo_gcm ! NEMO direct code + ! + !!====================================================================== +END PROGRAM make_domain_cfg diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/mathelp.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/mathelp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99d046a058440b23b34f2a302e9328a2d50b8344 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..415b0230c9f47f0406373e2ee55c8385d2fbc773 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini.f90 @@ -0,0 +1,1011 @@ +MODULE mppini + !!============================================================================== + !! *** MODULE mppini *** + !! Ocean initialization : distributed memory computing initialization + !!============================================================================== + + !!---------------------------------------------------------------------- + !! mpp_init : Lay out the global domain over processors + !! mpp_init2 : Lay out the global domain over processors + !! with land processor elimination + !! mpp_init_ioispl: IOIPSL initialization in mpp + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O Manager + USE lib_mpp ! distribued memory computing library + USE ioipsl + + IMPLICIT NONE + PRIVATE + + PUBLIC mpp_init ! called by opa.F90 + PUBLIC mpp_init2 ! called by opa.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: mppini.F90 6412 2016-03-31 16:22:32Z lovato $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! 'key_mpp_mpi' OR MPI massively parallel processing + !!---------------------------------------------------------------------- + + SUBROUTINE mpp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! + !! ** 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 + !! nperio local periodic condition + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! nperio : lateral condition type + !! 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 + !! + !! 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 + !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: ii, ij, ifreq, il1, il2 ! local integers + INTEGER :: iresti, irestj, ijm1, imil, inum ! - - + REAL(wp) :: zidom, zjdom ! local scalars + INTEGER, DIMENSION(jpni,jpnj) :: iimppt, ijmppt, ilcit, ilcjt ! local workspace + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing MPI' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + + + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! Computation of local domain sizes ilcit() ilcjt() + ! These dimensions depend on global sizes jpni,jpnj 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). + + nreci = 2 * jpreci + nrecj = 2 * jprecj + iresti = MOD( jpiglo - nreci , jpni ) + irestj = MOD( jpjglo - nrecj , jpnj ) + + IF( iresti == 0 ) iresti = jpni + + + DO jj = 1, jpnj + DO ji = 1, iresti + ilcit(ji,jj) = jpi + END DO + DO ji = iresti+1, jpni + ilcit(ji,jj) = jpi -1 + END DO + END DO + + nfilcit(:,:) = ilcit(:,:) + IF( irestj == 0 ) irestj = jpnj + + + DO ji = 1, jpni + DO jj = 1, irestj + ilcjt(ji,jj) = jpj + END DO + DO jj = irestj+1, jpnj + ilcjt(ji,jj) = jpj -1 + END DO + END DO + + + ! 2. Index arrays for subdomains + ! ------------------------------- + + iimppt(:,:) = 1 + ijmppt(:,:) = 1 + + IF( jpni > 1 ) THEN + DO jj = 1, jpnj + DO ji = 2, jpni + iimppt(ji,jj) = iimppt(ji-1,jj) + ilcit(ji-1,jj) - nreci + END DO + END DO + ENDIF + nfiimpp(:,:)=iimppt(:,:) + + IF( jpnj > 1 ) THEN + DO jj = 2, jpnj + DO ji = 1, jpni + ijmppt(ji,jj) = ijmppt(ji,jj-1)+ilcjt(ji,jj-1)-nrecj + END DO + END DO + ENDIF + + ! 3. Subdomain description + ! ------------------------ + + DO jn = 1, jpnij + ii = 1 + MOD( jn-1, jpni ) + ij = 1 + (jn-1) / jpni + nfipproc(ii,ij) = jn - 1 + nimppt(jn) = iimppt(ii,ij) + njmppt(jn) = ijmppt(ii,ij) + nlcit (jn) = ilcit (ii,ij) + nlci = nlcit (jn) + nlcjt (jn) = ilcjt (ii,ij) + nlcj = nlcjt (jn) + nbondj = -1 ! general case + IF( jn > jpni ) nbondj = 0 ! first row of processor + IF( jn > (jpnj-1)*jpni ) nbondj = 1 ! last row of processor + IF( jpnj == 1 ) nbondj = 2 ! one processor only in j-direction + ibonjt(jn) = nbondj + + nbondi = 0 ! + IF( MOD( jn, jpni ) == 1 ) nbondi = -1 ! + IF( MOD( jn, jpni ) == 0 ) nbondi = 1 ! + IF( jpni == 1 ) nbondi = 2 ! one processor only in i-direction + ibonit(jn) = nbondi + + nldi = 1 + jpreci + nlei = nlci - jpreci + IF( nbondi == -1 .OR. nbondi == 2 ) nldi = 1 + IF( nbondi == 1 .OR. nbondi == 2 ) nlei = nlci + nldj = 1 + jprecj + nlej = nlcj - jprecj + IF( nbondj == -1 .OR. nbondj == 2 ) nldj = 1 + IF( nbondj == 1 .OR. nbondj == 2 ) nlej = nlcj + nldit(jn) = nldi + nleit(jn) = nlei + nldjt(jn) = nldj + nlejt(jn) = nlej + END DO + + ! 4. Subdomain print + ! ------------------ + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' + IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj + zidom = nreci + DO ji = 1, jpni + zidom = zidom + ilcit(ji,1) - nreci + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo + + zjdom = nrecj + DO jj = 1, jpnj + zjdom = zjdom + ilcjt(1,jj) - nrecj + END DO + IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo + IF(lwp) WRITE(numout,*) + + IF(lwp) THEN + ifreq = 4 + il1 = 1 + DO jn = 1, (jpni-1)/ifreq+1 + il2 = MIN( jpni, il1+ifreq-1 ) + WRITE(numout,*) + WRITE(numout,9200) ('***',ji = il1,il2-1) + DO jj = jpnj, 1, -1 + WRITE(numout,9203) (' ',ji = il1,il2-1) + WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) + WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) + WRITE(numout,9203) (' ',ji = il1,il2-1) + WRITE(numout,9200) ('***',ji = il1,il2-1) + END DO + WRITE(numout,9201) (ji,ji = il1,il2) + il1 = il1+ifreq + END DO + 9200 FORMAT(' ***',20('*************',a3)) + 9203 FORMAT(' * ',20(' * ',a3)) + 9201 FORMAT(' ',20(' ',i3,' ')) + 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) + 9204 FORMAT(' * ',20(' ',i3,' * ')) + ENDIF + + ! 5. From global to local + ! ----------------------- + + nperio = 0 + IF( jperio == 2 .AND. nbondj == -1 ) nperio = 2 + + + ! 6. Subdomain neighbours + ! ---------------------- + + nproc = narea - 1 + noso = nproc - jpni + nowe = nproc - 1 + noea = nproc + 1 + nono = nproc + jpni + ! great neighbours + npnw = nono - 1 + npne = nono + 1 + npsw = noso - 1 + npse = noso + 1 + nbsw = 1 + nbnw = 1 + IF( MOD( nproc, jpni ) == 0 ) THEN + nbsw = 0 + nbnw = 0 + ENDIF + nbse = 1 + nbne = 1 + IF( MOD( nproc, jpni ) == jpni-1 ) THEN + nbse = 0 + nbne = 0 + ENDIF + IF(nproc < jpni) THEN + nbsw = 0 + nbse = 0 + ENDIF + IF( nproc >= (jpnj-1)*jpni ) THEN + nbnw = 0 + nbne = 0 + ENDIF + nlcj = nlcjt(narea) + nlci = nlcit(narea) + nldi = nldit(narea) + nlei = nleit(narea) + nldj = nldjt(narea) + nlej = nlejt(narea) + nbondi = ibonit(narea) + nbondj = ibonjt(narea) + nimpp = nimppt(narea) + njmpp = njmppt(narea) + + ! Save processor layout in layout.dat file + IF (lwp) THEN + CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' + WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo + WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' + + DO jn = 1, jpnij + WRITE(inum,'(9i5)') jn, nlcit(jn), nlcjt(jn), & + nldit(jn), nldjt(jn), & + nleit(jn), nlejt(jn), & + nimppt(jn), njmppt(jn) + END DO + CLOSE(inum) + END IF + + + ! w a r n i n g narea (zone) /= nproc (processors)! + + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN + IF( jpni == 1 )THEN + nbondi = 2 + nperio = 1 + ELSE + nbondi = 0 + ENDIF + IF( MOD( narea, jpni ) == 0 ) THEN + noea = nproc-(jpni-1) + npne = npne-jpni + npse = npse-jpni + ENDIF + IF( MOD( narea, jpni ) == 1 ) THEN + nowe = nproc+(jpni-1) + npnw = npnw+jpni + npsw = npsw+jpni + ENDIF + nbsw = 1 + nbnw = 1 + nbse = 1 + nbne = 1 + IF( nproc < jpni ) THEN + nbsw = 0 + nbse = 0 + ENDIF + IF( nproc >= (jpnj-1)*jpni ) THEN + nbnw = 0 + nbne = 0 + ENDIF + ENDIF + npolj = 0 + IF( jperio == 3 .OR. jperio == 4 ) THEN + ijm1 = jpni*(jpnj-1) + imil = ijm1+(jpni+1)/2 + IF( narea > ijm1 ) npolj = 3 + IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 4 + IF( npolj == 3 ) nono = jpni*jpnj-narea+ijm1 + ENDIF + IF( jperio == 5 .OR. jperio == 6 ) THEN + ijm1 = jpni*(jpnj-1) + imil = ijm1+(jpni+1)/2 + IF( narea > ijm1) npolj = 5 + IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 6 + IF( npolj == 5 ) nono = jpni*jpnj-narea+ijm1 + ENDIF + + ! Periodicity : no corner if nbondi = 2 and nperio != 1 + + IF(lwp) THEN + 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,*) ' nperio = ', nperio + WRITE(numout,*) ' nlci = ', nlci + WRITE(numout,*) ' nlcj = ', nlcj + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse + WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw + WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne + WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw + WRITE(numout,*) + ENDIF + + IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init: error on cyclicity' ) + + ! Prepare mpp north fold + + IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN + CALL mpp_ini_north + IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' + ENDIF + + ! Prepare NetCDF output file (if necessary) + CALL mpp_init_ioipsl + + END SUBROUTINE mpp_init + + SUBROUTINE mpp_init2 + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init2 *** + !! + !! * Purpose : Lay out the global domain over processors. + !! FOR USING THIS VERSION, A PREPROCESSING TRAITMENT IS RECOMMENDED + !! FOR DEFINING BETTER CUTTING OUT. + !! This routine is used with a the bathymetry file. + !! In this version, the land processors are avoided and the adress + !! processor (nproc, narea,noea, ...) are calculated again. + !! The jpnij parameter can be lesser than jpni x jpnj + !! and this jpnij parameter must be calculated before with an + !! algoritmic preprocessing program. + !! + !! ** 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 + !! nperio local periodic condition + !! + !! ** Action : nimpp : longitudinal index + !! njmpp : latitudinal index + !! nperio : lateral condition type + !! narea : number for local area + !! nlci : first dimension + !! nlcj : second dimension + !! 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 + !! + !! 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 + !! 9.0 ! 04-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O Manager + USE iom + !! + INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER :: idir ! temporary integers + INTEGER :: jstartrow ! temporary integers + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: & + ii, ij, ifreq, il1, il2, & ! temporary integers + icont, ili, ilj, & ! " " + isurf, ijm1, imil, & ! " " + iino, ijno, iiso, ijso, & ! " " + iiea, ijea, iiwe, ijwe, & ! " " + iinw, ijnw, iine, ijne, & ! " " + iisw, ijsw, iise, ijse, & ! " " + iresti, irestj, iproc ! " " + INTEGER, DIMENSION(jpnij) :: & + iin, ijn + INTEGER, DIMENSION(jpni,jpnj) :: & + iimppt, ijmppt, ilci , ilcj , & ! temporary workspace + ipproc, ibondj, ibondi, ipolj , & ! " " + ilei , ilej , ildi , ildj , & ! " " + ioea , iowe , ioso , iono , & ! " " + ione , ionw , iose , iosw , & ! " " + ibne , ibnw , ibse , ibsw ! " " + INTEGER, DIMENSION(jpiglo,jpjglo) :: & + imask ! temporary global workspace + REAL(wp), DIMENSION(jpiglo,jpjglo) :: & + zdta, zdtaisf ! temporary data workspace + REAL(wp) :: zidom , zjdom ! temporary scalars + + ! read namelist for ln_zco + NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh + + !!---------------------------------------------------------------------- + !! OPA 9.0 , LOCEAN-IPSL (2005) + !! $Id: mppini_2.h90 6412 2016-03-31 16:22:32Z lovato $ + !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt + !!---------------------------------------------------------------------- + + REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate + READ ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist', lwp ) + + REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate + READ ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp ) + IF(lwm) WRITE ( numond, namzgr ) + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'mpp_init : Message Passing MPI' + IF(lwp)WRITE(numout,*) '~~~~~~~~' + IF(lwp)WRITE(numout,*) ' ' + + IF( jpni*jpnj < jpnij ) CALL ctl_stop( ' jpnij > jpni x jpnj impossible' ) + + ! 0. initialisation + ! ----------------- + + ! open the file + ! Remember that at this level in the code, mpp is not yet initialized, so + ! the file must be open with jpdom_unknown, and kstart and kcount forced + jstartrow = 1 + IF ( ln_zco ) THEN + CALL iom_open ( 'bathy_level.nc', inum ) ! Level bathymetry + ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file + ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry + CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found + jstartrow = MAX(1,jstartrow) + CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/), kcount=(/jpiglo,jpjglo/) ) + ELSE + CALL iom_open ( 'bathy_meter.nc', inum ) ! Meter bathy in case of partial steps + IF ( ln_isfcav ) THEN + CALL iom_get ( inum, jpdom_unknown, 'Bathymetry_isf' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) + ELSE + ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file + ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry + CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found + jstartrow = MAX(1,jstartrow) + CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/) & + & , kcount=(/jpiglo,jpjglo/) ) + ENDIF + ENDIF + CALL iom_close (inum) + + ! used to compute the land processor in case of not masked bathy file. + zdtaisf(:,:) = 0.0_wp + IF ( ln_isfcav ) THEN + CALL iom_open ( 'bathy_meter.nc', inum ) ! Meter bathy in case of partial steps + CALL iom_get ( inum, jpdom_unknown, 'isf_draft' , zdtaisf, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) + END IF + CALL iom_close (inum) + + ! land/sea mask over the global/zoom domain + + imask(:,:)=1 + WHERE ( zdta(:,:) - zdtaisf(:,:) <= rn_isfhmin ) imask = 0 + + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + + ! Computation of local domain sizes ilci() ilcj() + ! These dimensions depend on global sizes jpni,jpnj 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. + + nreci=2*jpreci + nrecj=2*jprecj + iresti = 1 + MOD( jpiglo - nreci -1 , jpni ) + irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj ) + + ilci(1:iresti ,:) = jpi + ilci(iresti+1:jpni ,:) = jpi-1 + + ilcj(:, 1:irestj) = jpj + ilcj(:, irestj+1:jpnj) = jpj-1 + + nfilcit(:,:) = ilci(:,:) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' mpp_init2: defines mpp subdomains' + IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj + + zidom = nreci + sum(ilci(:,1) - nreci ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' sum ilci(i,1)=',zidom,' jpiglo=',jpiglo + + zjdom = nrecj + sum(ilcj(1,:) - nrecj ) + IF(lwp) WRITE(numout,*) ' sum ilcj(1,j)=',zjdom,' jpjglo=',jpjglo + IF(lwp) WRITE(numout,*) + + + ! 2. Index arrays for subdomains + ! ------------------------------- + + iimppt(:,:) = 1 + ijmppt(:,:) = 1 + ipproc(:,:) = -1 + + IF( jpni > 1 )THEN + DO jj = 1, jpnj + DO ji = 2, jpni + iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci + END DO + END DO + ENDIF + nfiimpp(:,:) = iimppt(:,:) + + IF( jpnj > 1 )THEN + DO jj = 2, jpnj + DO ji = 1, jpni + ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj + END DO + END DO + ENDIF + + + ! 3. Subdomain description in the Regular Case + ! -------------------------------------------- + + nperio = 0 + icont = -1 + DO jarea = 1, jpni*jpnj + ii = 1 + MOD(jarea-1,jpni) + ij = 1 + (jarea-1)/jpni + ili = ilci(ii,ij) + ilj = ilcj(ii,ij) + ibondj(ii,ij) = -1 + IF( jarea > jpni ) ibondj(ii,ij) = 0 + IF( jarea > (jpnj-1)*jpni ) ibondj(ii,ij) = 1 + IF( jpnj == 1 ) ibondj(ii,ij) = 2 + ibondi(ii,ij) = 0 + IF( MOD(jarea,jpni) == 1 ) ibondi(ii,ij) = -1 + IF( MOD(jarea,jpni) == 0 ) ibondi(ii,ij) = 1 + IF( jpni == 1 ) ibondi(ii,ij) = 2 + + ! 2.4 Subdomain neighbors + + iproc = jarea - 1 + ioso(ii,ij) = iproc - jpni + iowe(ii,ij) = iproc - 1 + ioea(ii,ij) = iproc + 1 + iono(ii,ij) = iproc + jpni + ildi(ii,ij) = 1 + jpreci + ilei(ii,ij) = ili -jpreci + ionw(ii,ij) = iono(ii,ij) - 1 + ione(ii,ij) = iono(ii,ij) + 1 + iosw(ii,ij) = ioso(ii,ij) - 1 + iose(ii,ij) = ioso(ii,ij) + 1 + ibsw(ii,ij) = 1 + ibnw(ii,ij) = 1 + IF( MOD(iproc,jpni) == 0 ) THEN + ibsw(ii,ij) = 0 + ibnw(ii,ij) = 0 + ENDIF + ibse(ii,ij) = 1 + ibne(ii,ij) = 1 + IF( MOD(iproc,jpni) == jpni-1 ) THEN + ibse(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + IF( iproc < jpni ) THEN + ibsw(ii,ij) = 0 + ibse(ii,ij) = 0 + ENDIF + IF( iproc >= (jpnj-1)*jpni ) THEN + ibnw(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + 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) = ili + ildj(ii,ij) = 1 + jprecj + ilej(ii,ij) = ilj - jprecj + 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) = ilj + + ! warning ii*ij (zone) /= nproc (processors)! + + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN + IF( jpni == 1 )THEN + ibondi(ii,ij) = 2 + nperio = 1 + ELSE + ibondi(ii,ij) = 0 + ENDIF + IF( MOD(jarea,jpni) == 0 ) THEN + ioea(ii,ij) = iproc - (jpni-1) + ione(ii,ij) = ione(ii,ij) - jpni + iose(ii,ij) = iose(ii,ij) - jpni + ENDIF + IF( MOD(jarea,jpni) == 1 ) THEN + iowe(ii,ij) = iproc + jpni - 1 + ionw(ii,ij) = ionw(ii,ij) + jpni + iosw(ii,ij) = iosw(ii,ij) + jpni + ENDIF + ibsw(ii,ij) = 1 + ibnw(ii,ij) = 1 + ibse(ii,ij) = 1 + ibne(ii,ij) = 1 + IF( iproc < jpni ) THEN + ibsw(ii,ij) = 0 + ibse(ii,ij) = 0 + ENDIF + IF( iproc >= (jpnj-1)*jpni ) THEN + ibnw(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + ENDIF + 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 + + ! Check wet points over the entire domain to preserve the MPI communication stencil + isurf = 0 + DO jj = 1, ilj + DO ji = 1, ili + IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 + END DO + END DO + + IF(isurf /= 0) THEN + icont = icont + 1 + ipproc(ii,ij) = icont + iin(icont+1) = ii + ijn(icont+1) = ij + ENDIF + END DO + + nfipproc(:,:) = ipproc(:,:) + + ! Control + IF(icont+1 /= jpnij) THEN + WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj + WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj' + WRITE(ctmp3,*) ' ***********, mpp_init2 finds jpnij=',icont+1 + CALL ctl_stop( ' Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 ) + ENDIF + + ! 4. 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(' ',i3,' * ')) + ENDIF + + + ! 5. neighbour treatment + ! ---------------------- + + DO jarea = 1, jpni*jpnj + iproc = jarea-1 + ii = 1 + MOD(jarea-1,jpni) + ij = 1 + (jarea-1)/jpni + IF( ipproc(ii,ij) == -1 .AND. iono(ii,ij) >= 0 & + .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN + iino = 1 + MOD(iono(ii,ij),jpni) + ijno = 1 + (iono(ii,ij))/jpni + ! Need to reverse the logical direction of communication + ! for northern neighbours of northern row processors (north-fold) + ! i.e. need to check that the northern neighbour only communicates + ! to the SOUTH (or not at all) if this area is land-only (#1057) + idir = 1 + IF( ij .eq. jpnj .AND. ijno .eq. jpnj ) idir = -1 + IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno)=2 + IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ioso(ii,ij) >= 0 & + .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN + iiso = 1 + MOD(ioso(ii,ij),jpni) + ijso = 1 + (ioso(ii,ij))/jpni + IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 + IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ioea(ii,ij) >= 0 & + .AND. ioea(ii,ij) <= jpni*jpnj-1) THEN + iiea = 1 + MOD(ioea(ii,ij),jpni) + ijea = 1 + (ioea(ii,ij))/jpni + IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 + IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. iowe(ii,ij) >= 0 & + .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN + iiwe = 1 + MOD(iowe(ii,ij),jpni) + ijwe = 1 + (iowe(ii,ij))/jpni + IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 + IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibne(ii,ij) == 1 ) THEN + iine = 1 + MOD(ione(ii,ij),jpni) + ijne = 1 + (ione(ii,ij))/jpni + IF( ibsw(iine,ijne) == 1 ) ibsw(iine,ijne) = 0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibsw(ii,ij) == 1 ) THEN + iisw = 1 + MOD(iosw(ii,ij),jpni) + ijsw = 1 + (iosw(ii,ij))/jpni + IF( ibne(iisw,ijsw) == 1 ) ibne(iisw,ijsw) = 0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibnw(ii,ij) == 1 ) THEN + iinw = 1 + MOD(ionw(ii,ij),jpni) + ijnw = 1 + (ionw(ii,ij))/jpni + IF( ibse(iinw,ijnw) == 1 ) ibse(iinw,ijnw)=0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibse(ii,ij) == 1 ) THEN + iise = 1 + MOD(iose(ii,ij),jpni) + ijse = 1 + (iose(ii,ij))/jpni + IF( ibnw(iise,ijse) == 1 ) ibnw(iise,ijse) = 0 + ENDIF + END DO + + + ! 6. Change processor name + ! ------------------------ + + nproc = narea-1 + ii = iin(narea) + ij = ijn(narea) + + ! set default neighbours + noso = ioso(ii,ij) + nowe = iowe(ii,ij) + noea = ioea(ii,ij) + nono = iono(ii,ij) + npse = iose(ii,ij) + npsw = iosw(ii,ij) + npne = ione(ii,ij) + npnw = ionw(ii,ij) + + ! check neighbours location + IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN + iiso = 1 + MOD(ioso(ii,ij),jpni) + ijso = 1 + (ioso(ii,ij))/jpni + noso = ipproc(iiso,ijso) + ENDIF + IF( iowe(ii,ij) >= 0 .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN + iiwe = 1 + MOD(iowe(ii,ij),jpni) + ijwe = 1 + (iowe(ii,ij))/jpni + nowe = ipproc(iiwe,ijwe) + ENDIF + IF( ioea(ii,ij) >= 0 .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN + iiea = 1 + MOD(ioea(ii,ij),jpni) + ijea = 1 + (ioea(ii,ij))/jpni + noea = ipproc(iiea,ijea) + ENDIF + IF( iono(ii,ij) >= 0 .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN + iino = 1 + MOD(iono(ii,ij),jpni) + ijno = 1 + (iono(ii,ij))/jpni + nono = ipproc(iino,ijno) + ENDIF + IF( iose(ii,ij) >= 0 .AND. iose(ii,ij) <= (jpni*jpnj-1) ) THEN + iise = 1 + MOD(iose(ii,ij),jpni) + ijse = 1 + (iose(ii,ij))/jpni + npse = ipproc(iise,ijse) + ENDIF + IF( iosw(ii,ij) >= 0 .AND. iosw(ii,ij) <= (jpni*jpnj-1) ) THEN + iisw = 1 + MOD(iosw(ii,ij),jpni) + ijsw = 1 + (iosw(ii,ij))/jpni + npsw = ipproc(iisw,ijsw) + ENDIF + IF( ione(ii,ij) >= 0 .AND. ione(ii,ij) <= (jpni*jpnj-1) ) THEN + iine = 1 + MOD(ione(ii,ij),jpni) + ijne = 1 + (ione(ii,ij))/jpni + npne = ipproc(iine,ijne) + ENDIF + IF( ionw(ii,ij) >= 0 .AND. ionw(ii,ij) <= (jpni*jpnj-1) ) THEN + iinw = 1 + MOD(ionw(ii,ij),jpni) + ijnw = 1 + (ionw(ii,ij))/jpni + npnw = ipproc(iinw,ijnw) + ENDIF + nbnw = ibnw(ii,ij) + nbne = ibne(ii,ij) + nbsw = ibsw(ii,ij) + nbse = ibse(ii,ij) + nlcj = ilcj(ii,ij) + nlci = ilci(ii,ij) + nldi = ildi(ii,ij) + nlei = ilei(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) + DO jproc = 1, jpnij + ii = iin(jproc) + ij = ijn(jproc) + nimppt(jproc) = iimppt(ii,ij) + njmppt(jproc) = ijmppt(ii,ij) + nlcjt(jproc) = ilcj(ii,ij) + nlcit(jproc) = ilci(ii,ij) + nldit(jproc) = ildi(ii,ij) + nleit(jproc) = ilei(ii,ij) + nldjt(jproc) = ildj(ii,ij) + nlejt(jproc) = ilej(ii,ij) + END DO + + ! Save processor layout in ascii file + IF (lwp) THEN + CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' + WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo + WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' + + DO jproc = 1, jpnij + WRITE(inum,'(9i5)') jproc, nlcit(jproc), nlcjt(jproc), & + nldit(jproc), nldjt(jproc), & + nleit(jproc), nlejt(jproc), & + nimppt(jproc), njmppt(jproc) + END DO + CLOSE(inum) + END IF + + ! 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 + + ! Periodicity : no corner if nbondi = 2 and nperio != 1 + + IF(lwp) THEN + 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,*) ' nperio = ', nperio + WRITE(numout,*) ' nlci = ', nlci + WRITE(numout,*) ' nlcj = ', nlcj + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse + WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw + WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne + WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw + WRITE(numout,*) + ENDIF + + IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) + + ! Prepare mpp north fold + + IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN + CALL mpp_ini_north + IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' + ENDIF + + ! Prepare NetCDF output file (if necessary) + CALL mpp_init_ioipsl + + + END SUBROUTINE mpp_init2 + + 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 + + + !!====================================================================== +END MODULE mppini diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini_2.h90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini_2.h90 new file mode 100644 index 0000000000000000000000000000000000000000..d9fe7e02c850fac0a26e117603e3807e7fa645fd --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/mppini_2.h90 @@ -0,0 +1,580 @@ + SUBROUTINE mpp_init2 + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init2 *** + !! + !! * Purpose : Lay out the global domain over processors. + !! FOR USING THIS VERSION, A PREPROCESSING TRAITMENT IS RECOMMENDED + !! FOR DEFINING BETTER CUTTING OUT. + !! This routine is used with a the bathymetry file. + !! In this version, the land processors are avoided and the adress + !! processor (nproc, narea,noea, ...) are calculated again. + !! The jpnij parameter can be lesser than jpni x jpnj + !! and this jpnij parameter must be calculated before with an + !! algoritmic preprocessing program. + !! + !! ** 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 + !! nperio local periodic condition + !! + !! ** Action : nimpp : longitudinal index + !! njmpp : latitudinal index + !! nperio : lateral condition type + !! narea : number for local area + !! nlci : first dimension + !! nlcj : second dimension + !! 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 + !! + !! 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 + !! 9.0 ! 04-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O Manager + USE iom + !! + INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER :: idir ! temporary integers + INTEGER :: jstartrow ! temporary integers + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: & + ii, ij, ifreq, il1, il2, & ! temporary integers + icont, ili, ilj, & ! " " + isurf, ijm1, imil, & ! " " + iino, ijno, iiso, ijso, & ! " " + iiea, ijea, iiwe, ijwe, & ! " " + iinw, ijnw, iine, ijne, & ! " " + iisw, ijsw, iise, ijse, & ! " " + iresti, irestj, iproc ! " " + INTEGER, DIMENSION(jpnij) :: & + iin, ijn + INTEGER, DIMENSION(jpni,jpnj) :: & + iimppt, ijmppt, ilci , ilcj , & ! temporary workspace + ipproc, ibondj, ibondi, ipolj , & ! " " + ilei , ilej , ildi , ildj , & ! " " + ioea , iowe , ioso , iono , & ! " " + ione , ionw , iose , iosw , & ! " " + ibne , ibnw , ibse , ibsw ! " " + INTEGER, DIMENSION(jpiglo,jpjglo) :: & + imask ! temporary global workspace + REAL(wp), DIMENSION(jpiglo,jpjglo) :: & + zdta, zdtaisf ! temporary data workspace + REAL(wp) :: zidom , zjdom ! temporary scalars + + ! read namelist for ln_zco + NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh + + !!---------------------------------------------------------------------- + !! OPA 9.0 , LOCEAN-IPSL (2005) + !! $Id: mppini_2.h90 6412 2016-03-31 16:22:32Z lovato $ + !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt + !!---------------------------------------------------------------------- + + REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate + READ ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist', lwp ) + + REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate + READ ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp ) + IF(lwm) WRITE ( numond, namzgr ) + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'mpp_init : Message Passing MPI' + IF(lwp)WRITE(numout,*) '~~~~~~~~' + IF(lwp)WRITE(numout,*) ' ' + + IF( jpni*jpnj < jpnij ) CALL ctl_stop( ' jpnij > jpni x jpnj impossible' ) + + ! 0. initialisation + ! ----------------- + + ! open the file + ! Remember that at this level in the code, mpp is not yet initialized, so + ! the file must be open with jpdom_unknown, and kstart and kcount forced + jstartrow = 1 + IF ( ln_zco ) THEN + CALL iom_open ( 'bathy_level.nc', inum ) ! Level bathymetry + ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file + ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry + CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found + jstartrow = MAX(1,jstartrow) + CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/), kcount=(/jpiglo,jpjglo/) ) + ELSE + CALL iom_open ( 'bathy_meter.nc', inum ) ! Meter bathy in case of partial steps + IF ( ln_isfcav ) THEN + CALL iom_get ( inum, jpdom_unknown, 'Bathymetry_isf' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) + ELSE + ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file + ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry + CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found + jstartrow = MAX(1,jstartrow) + CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/) & + & , kcount=(/jpiglo,jpjglo/) ) + ENDIF + ENDIF + CALL iom_close (inum) + + ! used to compute the land processor in case of not masked bathy file. + zdtaisf(:,:) = 0.0_wp + IF ( ln_isfcav ) THEN + CALL iom_open ( 'bathy_meter.nc', inum ) ! Meter bathy in case of partial steps + CALL iom_get ( inum, jpdom_unknown, 'isf_draft' , zdtaisf, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) + END IF + CALL iom_close (inum) + + ! land/sea mask over the global/zoom domain + + imask(:,:)=1 + WHERE ( zdta(:,:) - zdtaisf(:,:) <= rn_isfhmin ) imask = 0 + + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + + ! Computation of local domain sizes ilci() ilcj() + ! These dimensions depend on global sizes jpni,jpnj 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. + + nreci=2*jpreci + nrecj=2*jprecj + iresti = 1 + MOD( jpiglo - nreci -1 , jpni ) + irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj ) + + ilci(1:iresti ,:) = jpi + ilci(iresti+1:jpni ,:) = jpi-1 + + ilcj(:, 1:irestj) = jpj + ilcj(:, irestj+1:jpnj) = jpj-1 + + nfilcit(:,:) = ilci(:,:) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' mpp_init2: defines mpp subdomains' + IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj + + zidom = nreci + sum(ilci(:,1) - nreci ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' sum ilci(i,1)=',zidom,' jpiglo=',jpiglo + + zjdom = nrecj + sum(ilcj(1,:) - nrecj ) + IF(lwp) WRITE(numout,*) ' sum ilcj(1,j)=',zjdom,' jpjglo=',jpjglo + IF(lwp) WRITE(numout,*) + + + ! 2. Index arrays for subdomains + ! ------------------------------- + + iimppt(:,:) = 1 + ijmppt(:,:) = 1 + ipproc(:,:) = -1 + + IF( jpni > 1 )THEN + DO jj = 1, jpnj + DO ji = 2, jpni + iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci + END DO + END DO + ENDIF + nfiimpp(:,:) = iimppt(:,:) + + IF( jpnj > 1 )THEN + DO jj = 2, jpnj + DO ji = 1, jpni + ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj + END DO + END DO + ENDIF + + + ! 3. Subdomain description in the Regular Case + ! -------------------------------------------- + + nperio = 0 + icont = -1 + DO jarea = 1, jpni*jpnj + ii = 1 + MOD(jarea-1,jpni) + ij = 1 + (jarea-1)/jpni + ili = ilci(ii,ij) + ilj = ilcj(ii,ij) + ibondj(ii,ij) = -1 + IF( jarea > jpni ) ibondj(ii,ij) = 0 + IF( jarea > (jpnj-1)*jpni ) ibondj(ii,ij) = 1 + IF( jpnj == 1 ) ibondj(ii,ij) = 2 + ibondi(ii,ij) = 0 + IF( MOD(jarea,jpni) == 1 ) ibondi(ii,ij) = -1 + IF( MOD(jarea,jpni) == 0 ) ibondi(ii,ij) = 1 + IF( jpni == 1 ) ibondi(ii,ij) = 2 + + ! 2.4 Subdomain neighbors + + iproc = jarea - 1 + ioso(ii,ij) = iproc - jpni + iowe(ii,ij) = iproc - 1 + ioea(ii,ij) = iproc + 1 + iono(ii,ij) = iproc + jpni + ildi(ii,ij) = 1 + jpreci + ilei(ii,ij) = ili -jpreci + ionw(ii,ij) = iono(ii,ij) - 1 + ione(ii,ij) = iono(ii,ij) + 1 + iosw(ii,ij) = ioso(ii,ij) - 1 + iose(ii,ij) = ioso(ii,ij) + 1 + ibsw(ii,ij) = 1 + ibnw(ii,ij) = 1 + IF( MOD(iproc,jpni) == 0 ) THEN + ibsw(ii,ij) = 0 + ibnw(ii,ij) = 0 + ENDIF + ibse(ii,ij) = 1 + ibne(ii,ij) = 1 + IF( MOD(iproc,jpni) == jpni-1 ) THEN + ibse(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + IF( iproc < jpni ) THEN + ibsw(ii,ij) = 0 + ibse(ii,ij) = 0 + ENDIF + IF( iproc >= (jpnj-1)*jpni ) THEN + ibnw(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + 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) = ili + ildj(ii,ij) = 1 + jprecj + ilej(ii,ij) = ilj - jprecj + 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) = ilj + + ! warning ii*ij (zone) /= nproc (processors)! + + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN + IF( jpni == 1 )THEN + ibondi(ii,ij) = 2 + nperio = 1 + ELSE + ibondi(ii,ij) = 0 + ENDIF + IF( MOD(jarea,jpni) == 0 ) THEN + ioea(ii,ij) = iproc - (jpni-1) + ione(ii,ij) = ione(ii,ij) - jpni + iose(ii,ij) = iose(ii,ij) - jpni + ENDIF + IF( MOD(jarea,jpni) == 1 ) THEN + iowe(ii,ij) = iproc + jpni - 1 + ionw(ii,ij) = ionw(ii,ij) + jpni + iosw(ii,ij) = iosw(ii,ij) + jpni + ENDIF + ibsw(ii,ij) = 1 + ibnw(ii,ij) = 1 + ibse(ii,ij) = 1 + ibne(ii,ij) = 1 + IF( iproc < jpni ) THEN + ibsw(ii,ij) = 0 + ibse(ii,ij) = 0 + ENDIF + IF( iproc >= (jpnj-1)*jpni ) THEN + ibnw(ii,ij) = 0 + ibne(ii,ij) = 0 + ENDIF + ENDIF + 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 + + ! Check wet points over the entire domain to preserve the MPI communication stencil + isurf = 0 + DO jj = 1, ilj + DO ji = 1, ili + IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 + END DO + END DO + + IF(isurf /= 0) THEN + icont = icont + 1 + ipproc(ii,ij) = icont + iin(icont+1) = ii + ijn(icont+1) = ij + ENDIF + END DO + + nfipproc(:,:) = ipproc(:,:) + + ! Control + IF(icont+1 /= jpnij) THEN + WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj + WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj' + WRITE(ctmp3,*) ' ***********, mpp_init2 finds jpnij=',icont+1 + CALL ctl_stop( ' Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 ) + ENDIF + + ! 4. 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(' ',i3,' * ')) + ENDIF + + + ! 5. neighbour treatment + ! ---------------------- + + DO jarea = 1, jpni*jpnj + iproc = jarea-1 + ii = 1 + MOD(jarea-1,jpni) + ij = 1 + (jarea-1)/jpni + IF( ipproc(ii,ij) == -1 .AND. iono(ii,ij) >= 0 & + .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN + iino = 1 + MOD(iono(ii,ij),jpni) + ijno = 1 + (iono(ii,ij))/jpni + ! Need to reverse the logical direction of communication + ! for northern neighbours of northern row processors (north-fold) + ! i.e. need to check that the northern neighbour only communicates + ! to the SOUTH (or not at all) if this area is land-only (#1057) + idir = 1 + IF( ij .eq. jpnj .AND. ijno .eq. jpnj ) idir = -1 + IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno)=2 + IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ioso(ii,ij) >= 0 & + .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN + iiso = 1 + MOD(ioso(ii,ij),jpni) + ijso = 1 + (ioso(ii,ij))/jpni + IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 + IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ioea(ii,ij) >= 0 & + .AND. ioea(ii,ij) <= jpni*jpnj-1) THEN + iiea = 1 + MOD(ioea(ii,ij),jpni) + ijea = 1 + (ioea(ii,ij))/jpni + IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 + IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. iowe(ii,ij) >= 0 & + .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN + iiwe = 1 + MOD(iowe(ii,ij),jpni) + ijwe = 1 + (iowe(ii,ij))/jpni + IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 + IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibne(ii,ij) == 1 ) THEN + iine = 1 + MOD(ione(ii,ij),jpni) + ijne = 1 + (ione(ii,ij))/jpni + IF( ibsw(iine,ijne) == 1 ) ibsw(iine,ijne) = 0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibsw(ii,ij) == 1 ) THEN + iisw = 1 + MOD(iosw(ii,ij),jpni) + ijsw = 1 + (iosw(ii,ij))/jpni + IF( ibne(iisw,ijsw) == 1 ) ibne(iisw,ijsw) = 0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibnw(ii,ij) == 1 ) THEN + iinw = 1 + MOD(ionw(ii,ij),jpni) + ijnw = 1 + (ionw(ii,ij))/jpni + IF( ibse(iinw,ijnw) == 1 ) ibse(iinw,ijnw)=0 + ENDIF + IF( ipproc(ii,ij) == -1 .AND. ibse(ii,ij) == 1 ) THEN + iise = 1 + MOD(iose(ii,ij),jpni) + ijse = 1 + (iose(ii,ij))/jpni + IF( ibnw(iise,ijse) == 1 ) ibnw(iise,ijse) = 0 + ENDIF + END DO + + + ! 6. Change processor name + ! ------------------------ + + nproc = narea-1 + ii = iin(narea) + ij = ijn(narea) + + ! set default neighbours + noso = ioso(ii,ij) + nowe = iowe(ii,ij) + noea = ioea(ii,ij) + nono = iono(ii,ij) + npse = iose(ii,ij) + npsw = iosw(ii,ij) + npne = ione(ii,ij) + npnw = ionw(ii,ij) + + ! check neighbours location + IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN + iiso = 1 + MOD(ioso(ii,ij),jpni) + ijso = 1 + (ioso(ii,ij))/jpni + noso = ipproc(iiso,ijso) + ENDIF + IF( iowe(ii,ij) >= 0 .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN + iiwe = 1 + MOD(iowe(ii,ij),jpni) + ijwe = 1 + (iowe(ii,ij))/jpni + nowe = ipproc(iiwe,ijwe) + ENDIF + IF( ioea(ii,ij) >= 0 .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN + iiea = 1 + MOD(ioea(ii,ij),jpni) + ijea = 1 + (ioea(ii,ij))/jpni + noea = ipproc(iiea,ijea) + ENDIF + IF( iono(ii,ij) >= 0 .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN + iino = 1 + MOD(iono(ii,ij),jpni) + ijno = 1 + (iono(ii,ij))/jpni + nono = ipproc(iino,ijno) + ENDIF + IF( iose(ii,ij) >= 0 .AND. iose(ii,ij) <= (jpni*jpnj-1) ) THEN + iise = 1 + MOD(iose(ii,ij),jpni) + ijse = 1 + (iose(ii,ij))/jpni + npse = ipproc(iise,ijse) + ENDIF + IF( iosw(ii,ij) >= 0 .AND. iosw(ii,ij) <= (jpni*jpnj-1) ) THEN + iisw = 1 + MOD(iosw(ii,ij),jpni) + ijsw = 1 + (iosw(ii,ij))/jpni + npsw = ipproc(iisw,ijsw) + ENDIF + IF( ione(ii,ij) >= 0 .AND. ione(ii,ij) <= (jpni*jpnj-1) ) THEN + iine = 1 + MOD(ione(ii,ij),jpni) + ijne = 1 + (ione(ii,ij))/jpni + npne = ipproc(iine,ijne) + ENDIF + IF( ionw(ii,ij) >= 0 .AND. ionw(ii,ij) <= (jpni*jpnj-1) ) THEN + iinw = 1 + MOD(ionw(ii,ij),jpni) + ijnw = 1 + (ionw(ii,ij))/jpni + npnw = ipproc(iinw,ijnw) + ENDIF + nbnw = ibnw(ii,ij) + nbne = ibne(ii,ij) + nbsw = ibsw(ii,ij) + nbse = ibse(ii,ij) + nlcj = ilcj(ii,ij) + nlci = ilci(ii,ij) + nldi = ildi(ii,ij) + nlei = ilei(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) + DO jproc = 1, jpnij + ii = iin(jproc) + ij = ijn(jproc) + nimppt(jproc) = iimppt(ii,ij) + njmppt(jproc) = ijmppt(ii,ij) + nlcjt(jproc) = ilcj(ii,ij) + nlcit(jproc) = ilci(ii,ij) + nldit(jproc) = ildi(ii,ij) + nleit(jproc) = ilei(ii,ij) + nldjt(jproc) = ildj(ii,ij) + nlejt(jproc) = ilej(ii,ij) + END DO + + ! Save processor layout in ascii file + IF (lwp) THEN + CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' + WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo + WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' + + DO jproc = 1, jpnij + WRITE(inum,'(9i5)') jproc, nlcit(jproc), nlcjt(jproc), & + nldit(jproc), nldjt(jproc), & + nleit(jproc), nlejt(jproc), & + nimppt(jproc), njmppt(jproc) + END DO + CLOSE(inum) + END IF + + ! 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 + + ! Periodicity : no corner if nbondi = 2 and nperio != 1 + + IF(lwp) THEN + 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,*) ' nperio = ', nperio + WRITE(numout,*) ' nlci = ', nlci + WRITE(numout,*) ' nlcj = ', nlcj + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse + WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw + WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne + WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw + WRITE(numout,*) + ENDIF + + IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) + + ! Prepare mpp north fold + + IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN + CALL mpp_ini_north + IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' + ENDIF + + ! Prepare NetCDF output file (if necessary) + CALL mpp_init_ioipsl + + + END SUBROUTINE mpp_init2 diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/nc4interface.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/nc4interface.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3c3578d9157e3983e603a2dc008f4ca8c87b60f5 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/nc4interface.f90 @@ -0,0 +1,55 @@ +MODULE nc4interface +!- +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + + !!-------------------------------------------------------------------- + !! NOT 'key_netcdf4' Defines dummy routines for netcdf4 + !! calls when compiling without netcdf4 libraries + !!-------------------------------------------------------------------- + !- netcdf4 chunking control structure + !- (optional on histbeg and histend calls) +!$AGRIF_DO_NOT_TREAT + TYPE, PUBLIC :: snc4_ctl + SEQUENCE + INTEGER :: ni + INTEGER :: nj + INTEGER :: nk + LOGICAL :: luse + END TYPE snc4_ctl +!$AGRIF_END_DO_NOT_TREAT + +CONTAINS +!=== + SUBROUTINE GET_NF90_SYMBOL(sym_name, ivalue) + CHARACTER(len=*), INTENT(in) :: sym_name + INTEGER, INTENT(out) :: ivalue + ivalue = -999 + END SUBROUTINE GET_NF90_SYMBOL + INTEGER FUNCTION SET_NF90_DEF_VAR_CHUNKING(idum1, idum2, idum3, iarr1) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_CHUNKING *** + !! + !! ** Purpose : Dummy NetCDF4 routine to enable compiling with NetCDF3 libraries + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: idum1, idum2, idum3 + INTEGER, DIMENSION(4), INTENT(in) :: iarr1 + WRITE(*,*) 'Warning: Attempt to chunk output variable without NetCDF4 support' + SET_NF90_DEF_VAR_CHUNKING = -1 + END FUNCTION SET_NF90_DEF_VAR_CHUNKING + + INTEGER FUNCTION SET_NF90_DEF_VAR_DEFLATE(idum1, idum2, idum3, idum4, idum5) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_DEFLATE *** + !! + !! ** Purpose : Dummy NetCDF4 routine to enable compiling with NetCDF3 libraries + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: idum1, idum2, idum3, idum4, idum5 + WRITE(*,*) 'Warning: Attempt to compress output variable without NetCDF4 support' + SET_NF90_DEF_VAR_DEFLATE = -1 + END FUNCTION SET_NF90_DEF_VAR_DEFLATE + +!------------------ +END MODULE nc4interface diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/nemogcm.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/nemogcm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3948ca71dd3a8c8f5d6fb5b4be7fa33607a229db --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/nemogcm.f90 @@ -0,0 +1,588 @@ +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) LIM 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 + !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add nemo_northcomms + !! - ! 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 + !! - ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) nemo_northcomms: setup avoiding MPI communication + !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 + !! nemo_partition: calculate MPP domain decomposition + !! factorise : calculate the factors of the no. of MPI processes + !!---------------------------------------------------------------------- + USE step_oce ! module used in the ocean time stepping module (step.F90) + USE domcfg ! domain configuration (dom_cfg routine) + USE mppini ! shared/distributed memory setting (mpp_init routine) + USE domain ! domain initialization (dom_init routine) + USE phycst ! physical constant (par_cst routine) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE lib_mpp ! distributed memory computing + + USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges + + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2015) + !! $Id: nemogcm.F90 6152 2015-12-21 22:33:57Z acc $ + !! Software governed by the CeCILL licence (./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 + !!---------------------------------------------------------------------- + ! + ! !-----------------------! + CALL nemo_init !== Initialisations ==! + ! !-----------------------! + + ! check that all process are still there... If some process have an error, + ! they will never enter in step and other processes will wait until the end of the cpu time! + IF( lk_mpp ) CALL mpp_max( nstop ) + + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + + ! !-----------------------! + ! !== finalize the run ==! + ! !------------------------! + ! + IF( nstop /= 0 .AND. lwp ) THEN ! error print + WRITE(numout,cform_err) + WRITE(numout,*) nstop, ' error have been found' + ENDIF + ! + IF( nn_timing == 1 ) CALL timing_finalize + ! + CALL nemo_closefile + ! + ! + END SUBROUTINE nemo_gcm + + + SUBROUTINE nemo_init + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_init *** + !! + !! ** Purpose : initialization of the NEMO GCM + !!---------------------------------------------------------------------- + INTEGER :: ji ! dummy loop indices + INTEGER :: ilocal_comm ! local integer + INTEGER :: ios + CHARACTER(len=80), DIMENSION(16) :: cltxt + ! + NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & + & nn_isplt, nn_jsplt, nn_jctls, nn_jctle, & + & nn_bench, nn_timing, nn_diacfl + NAMELIST/namcfg/ ln_e3_dep, & + & cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & + & jpizoom, jpjzoom, jperio, ln_use_jattr + !!---------------------------------------------------------------------- + ! + cltxt = '' + ! + ! ! Open reference namelist and configuration namelist files + CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) + CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) + ! + REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark + READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) + + REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark + READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) + + ! + REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark + READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) + + REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark + READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) +904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. ) + +! Force values for AGRIF zoom (cf. agrif_user.F90) + ! + ! !--------------------------------------------! + ! ! set communicator & select the local node ! + ! ! NB: mynode also opens output.namelist.dyn ! + ! ! on unit number numond on first proc ! + ! !--------------------------------------------! + ! Nodes selection (control print return in cltxt) + ilocal_comm = 0 + narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) + narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) + + lwm = (narea == 1) ! control of output namelists + lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print + + IF(lwm) THEN + ! write merged namelists from earlier to output namelist now that the + ! file has been opened in call to mynode. nammpp has already been + ! written in mynode (if lk_mpp_mpi) + WRITE( numond, namctl ) + WRITE( numond, namcfg ) + ENDIF + + ! 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( jpni < 1 .OR. jpnj < 1 ) THEN + IF( Agrif_Root() ) CALL nemo_partition( mppsize ) + ENDIF + + ! Calculate domain dimensions given calculated jpni and jpnj + ! This used to be done in par_oce.F90 when they were parameters rather than variables + IF( Agrif_Root() ) THEN + jpi = ( jpiglo -2*jpreci + (jpni-1) ) / jpni + 2*jpreci ! first dim. + jpj = ( jpjglo -2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim. + ENDIF + jpk = jpkdta ! third dim + jpim1 = jpi-1 ! inner domain indices + jpjm1 = jpj-1 ! " " + jpkm1 = jpk-1 ! " " + jpij = jpi*jpj ! jpi x j + + IF(lwp) THEN ! open listing units + ! + CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) + ! + WRITE(numout,*) + WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC' + WRITE(numout,*) ' NEMO team' + WRITE(numout,*) ' Ocean General Circulation Model' + WRITE(numout,*) ' version 3.7 (2015) ' + WRITE(numout,*) + WRITE(numout,*) + DO ji = 1, SIZE(cltxt) + IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode + END DO + WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + ENDIF + + ! 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 & Benchmark + + ! ! Domain decomposition + IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out + ELSE ; CALL mpp_init2 ! eliminate land processors + ENDIF + ! + IF( nn_timing == 1 ) CALL timing_init + ! + ! ! General initialization + CALL phy_cst ! Physical constants + CALL eos_init ! Equation of state + CALL dom_cfg ! Domain configuration + CALL dom_init ! Domain + IF( ln_ctl ) CALL prt_ctl_init ! Print control + ! + END SUBROUTINE nemo_init + + + SUBROUTINE nemo_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_ctl *** + !! + !! ** Purpose : control print setting + !! + !! ** Method : - print namctl information and check some consistencies + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namctl' + WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl + 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,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench + WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing + 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 + nbench = nn_bench + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'namcfg : configuration initialization through namelist read' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist namcfg' + WRITE(numout,*) ' vertical scale factors =T: e3.=dk[depth] ln_e3_dep = ', ln_e3_dep + WRITE(numout,*) ' =F: old definition ' + WRITE(numout,*) ' configuration name cp_cfg = ', TRIM(cp_cfg) + WRITE(numout,*) ' configuration zoom name cp_cfz = ', TRIM(cp_cfz) + WRITE(numout,*) ' configuration resolution jp_cfg = ', jp_cfg + WRITE(numout,*) ' 1st lateral dimension ( >= jpiglo ) jpidta = ', jpidta + WRITE(numout,*) ' 2nd " " ( >= jpjglo ) jpjdta = ', jpjdta + WRITE(numout,*) ' 3nd " " jpkdta = ', jpkdta + WRITE(numout,*) ' 1st dimension of global domain in i jpiglo = ', jpiglo + WRITE(numout,*) ' 2nd - - in j jpjglo = ', jpjglo + WRITE(numout,*) ' left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom + WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom + WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio + WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr + ! + IF(.NOT.ln_e3_dep ) THEN + WRITE(numout,cform_war) + WRITE(numout,*) + WRITE(numout,*) ' ===>>>> Obsolescent definition of e3 scale factors is used' + WRITE(numout,*) + ENDIF + ENDIF + ! ! 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' ) + ! + 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( numsol /= -1 ) CLOSE( numsol ) ! solver 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 dom_oce , ONLY: dom_oce_alloc + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ierr = oce_alloc () ! ocean + ierr = ierr + dom_oce_alloc () ! ocean domain + ! + IF( lk_mpp ) CALL mpp_sum( ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' ) + ! + END SUBROUTINE nemo_alloc + + + SUBROUTINE nemo_partition( num_pes ) + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_partition *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have + ! + INTEGER, PARAMETER :: nfactmax = 20 + INTEGER :: nfact ! The no. of factors returned + INTEGER :: ierr ! Error flag + INTEGER :: ji + INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value + INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors + !!---------------------------------------------------------------------- + ! + ierr = 0 + ! + CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) + ! + IF( nfact <= 1 ) THEN + WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' + WRITE (numout, *) ' : using grid of ',num_pes,' x 1' + jpnj = 1 + jpni = num_pes + ELSE + ! Search through factors for the pair that are closest in value + mindiff = 1000000 + imin = 1 + DO ji = 1, nfact-1, 2 + idiff = ABS( ifact(ji) - ifact(ji+1) ) + IF( idiff < mindiff ) THEN + mindiff = idiff + imin = ji + ENDIF + END DO + jpnj = ifact(imin) + jpni = ifact(imin + 1) + ENDIF + ! + jpnij = jpni*jpnj + ! + END SUBROUTINE nemo_partition + + + SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE factorise *** + !! + !! ** Purpose : return the prime factors of n. + !! knfax factors are returned in array kfax which is of + !! maximum dimension kmaxfax. + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kn, kmaxfax + INTEGER , INTENT( out) :: kerr, knfax + INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax + ! + INTEGER :: ifac, jl, inu + INTEGER, PARAMETER :: ntest = 14 + INTEGER, DIMENSION(ntest) :: ilfax + !!---------------------------------------------------------------------- + ! + ! lfax contains the set of allowed factors. + ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) + ! + ! Clear the error flag and initialise output vars + kerr = 0 + kfax = 1 + knfax = 0 + ! + ! Find the factors of n. + IF( kn == 1 ) GOTO 20 + + ! nu holds the unfactorised part of the number. + ! knfax holds the number of factors found. + ! l points to the allowed factor list. + ! ifac holds the current factor. + ! + inu = kn + knfax = 0 + ! + DO jl = ntest, 1, -1 + ! + ifac = ilfax(jl) + IF( ifac > inu ) CYCLE + + ! Test whether the factor will divide. + + IF( MOD(inu,ifac) == 0 ) THEN + ! + knfax = knfax + 1 ! Add the factor to the list + IF( knfax > kmaxfax ) THEN + kerr = 6 + write (*,*) 'FACTOR: insufficient space in factor array ', knfax + return + ENDIF + kfax(knfax) = ifac + ! Store the other factor that goes with this one + knfax = knfax + 1 + kfax(knfax) = inu / ifac + !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax) + ENDIF + ! + END DO + ! + 20 CONTINUE ! Label 20 is the exit point from the factor search loop. + ! + END SUBROUTINE factorise + + + SUBROUTINE nemo_northcomms + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_northcomms *** + !! ** 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 I am a process in the north + IF ( njmpp == njmppmax ) THEN + !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 is the first point (in the global domain) of the jn + !process + sxT = nfiimpp(jn, jpnj) + !dxT is the last point (in the global domain) of the jn + !process + dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 + IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + END IF + END DO + nfsloop = 1 + nfeloop = nlci + DO jn = 2,jpni-1 + IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN + IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN + nfsloop = nldi + ENDIF + IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN + nfeloop = nlei + ENDIF + ENDIF + END DO + + ENDIF + l_north_nogather = .TRUE. + END SUBROUTINE nemo_northcomms + + + !!====================================================================== +END MODULE nemogcm + diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/oce.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b4929c73ef9a3b6b43982d9b718b3d8e9a2d2275 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/oce.f90 @@ -0,0 +1,132 @@ +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(:,:,:) :: hdivn !: horizontal divergence [s-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsb , tsn , tsa !: 4D T-S fields [Celcius,psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celcius-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] + + !! 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(:,:) :: 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 + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rke !: kinetic energy + + !! arrays relating 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] + + !! 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/OPA 3.7 , NEMO Consortium (2014) + !! $Id: oce.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(7) + !!---------------------------------------------------------------------- + ! + 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(rke(jpi,jpj,jpk) , & + & 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( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) + ! + ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(4) ) + ! + 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(5) ) + ! + ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj) , STAT=ierr(6) ) + + + + ! + oce_alloc = MAXVAL( ierr ) + IF( oce_alloc /= 0 ) CALL ctl_warn('oce_alloc: failed to allocate arrays') + ! + END FUNCTION oce_alloc + + !!====================================================================== +END MODULE oce diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/par_kind.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/par_kind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..024faa022f7b9057bc282132dda5e8e08bd24a57 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/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/OCE 4.0 , NEMO Consortium (2018) + !! $Id: par_kind.F90 2528 2010-12-27 17:33:53Z rblod $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +END MODULE par_kind diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/par_oce.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/par_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..947769d1e118aa41d1bb8bcac38983cfada96407 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/par_oce.f90 @@ -0,0 +1,102 @@ +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 + + !!---------------------------------------------------------------------- + !! 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 :: jpreci = 1 !: number of columns for overlap + INTEGER, PUBLIC, PARAMETER :: jprecj = 1 !: number of rows for overlap + + !!---------------------------------------------------------------------- + !! namcfg namelist parameters + !!---------------------------------------------------------------------- + ! + LOGICAL :: ln_e3_dep ! e3. definition flag + ! + CHARACTER(lc) :: cp_cfg !: name of the configuration + CHARACTER(lc) :: cp_cfz !: name of the zoom of configuration + INTEGER :: jp_cfg !: resolution of the configuration + + ! data size !!! * size of all input files * + INTEGER :: jpidta !: 1st lateral dimension ( >= jpi ) + INTEGER :: jpjdta !: 2nd " " ( >= jpj ) + INTEGER :: jpkdta !: number of levels ( >= jpk ) + + ! global or zoom domain size !!! * computational domain * + INTEGER :: jpiglo !: 1st dimension of global domain --> i + INTEGER :: jpjglo !: 2nd - - --> j + + ! zoom starting position + INTEGER :: jpizoom !: left bottom (i,j) indices of the zoom + INTEGER :: jpjzoom !: in data domain indices + + ! Domain characteristics + INTEGER :: jperio !: lateral cond. type (between 0 and 6) + ! ! = 0 closed ; = 1 cyclic East-West + ! ! = 2 equatorial symmetric ; = 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 + + ! Input file read offset + LOGICAL :: ln_use_jattr !: 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. + + !! Values set to pp_not_used indicates that this parameter is not used in THIS config. + !! Values set to pp_to_be_computed indicates that variables will be computed in domzgr + REAL(wp) :: pp_not_used = 999999._wp !: vertical grid parameter + REAL(wp) :: pp_to_be_computed = 999999._wp !: - - - + + + + + !!--------------------------------------------------------------------- + !! 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 Matrix size (if AGRIF, they are not all parameters) + !!--------------------------------------------------------------------- + + + + + + + INTEGER, PUBLIC :: jpi ! = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci !: first dimension + INTEGER, PUBLIC :: jpj ! = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj !: second dimension + INTEGER, PUBLIC :: jpk ! = jpkdta + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: par_oce.F90 5836 2015-10-26 14:49:40Z cetlod $ + !! Software governed by the CeCILL licence (./LICENSE) + !!====================================================================== +END MODULE par_oce diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/phycst.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/phycst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0ac20ad1fc8513a598a3fb6dfd5ebb8a6423cafc --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/phycst.f90 @@ -0,0 +1,179 @@ +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 :: rtt = 273.16_wp !: triple point of temperature [Kelvin] + REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] + + + + + REAL(wp), PUBLIC :: rt0_snow = 273.15_wp !: melting point of snow [Kelvin] + REAL(wp), PUBLIC :: rt0_ice = 273.05_wp !: melting point of ice [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 :: rhosn = 330._wp !: volumic mass of snow [kg/m3] + REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice + REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice [psu] + REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea [psu] + REAL(wp), PUBLIC :: cevap = 2.5e+6_wp !: latent heat of evaporation (water) + REAL(wp), PUBLIC :: srgamma = 0.9_wp !: correction factor for solar radiation (Oberhuber, 1974) + REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant + REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant + + REAL(wp), PUBLIC :: rhoic = 900._wp !: volumic mass of sea ice [kg/m3] + REAL(wp), PUBLIC :: rcdic = 2.034396_wp !: conductivity of the ice [W/m/K] + REAL(wp), PUBLIC :: rcpic = 1.8837e+6_wp !: volumetric specific heat for ice [J/m3/K] + REAL(wp), PUBLIC :: cpic !: = rcpic / rhoic (specific heat for ice) [J/Kg/K] + REAL(wp), PUBLIC :: rcdsn = 0.22_wp !: conductivity of the snow [W/m/K] + REAL(wp), PUBLIC :: rcpsn = 6.9069e+5_wp !: volumetric specific heat for snow [J/m3/K] + REAL(wp), PUBLIC :: xlsn = 110.121e+6_wp !: volumetric latent heat fusion of snow [J/m3] + REAL(wp), PUBLIC :: lfus !: = xlsn / rhosn (latent heat of fusion of fresh ice) [J/Kg] + REAL(wp), PUBLIC :: xlic = 300.33e+6_wp !: volumetric latent heat fusion of ice [J/m3] + REAL(wp), PUBLIC :: xsn = 2.8e+6_wp !: volumetric latent heat of sublimation of snow [J/m3] + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: phycst.F90 5147 2015-03-13 10:01:32Z cetlod $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE phy_cst + !!---------------------------------------------------------------------- + !! *** ROUTINE phy_cst *** + !! + !! ** Purpose : Print model parameters and set and print the constants + !!---------------------------------------------------------------------- + CHARACTER (len=64) :: cform = "(A12, 3(A13, I7) )" + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' phy_cst : initialization of ocean parameters and constants' + IF(lwp) WRITE(numout,*) ' ~~~~~~~' + + ! Ocean Parameters + ! ---------------- + IF(lwp) THEN + WRITE(numout,*) ' Domain info' + WRITE(numout,*) ' dimension of model' + WRITE(numout,*) ' Local domain Global domain Data domain ' + WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo, ' jpidta : ', jpidta + WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo, ' jpjdta : ', jpjdta + WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpk : ', jpk , ' jpkdta : ', jpkdta + WRITE(numout,*) ' ',' jpij : ', jpij + WRITE(numout,*) ' mpp local domain info (mpp)' + WRITE(numout,*) ' jpni : ', jpni, ' jpreci : ', jpreci + WRITE(numout,*) ' jpnj : ', jpnj, ' jprecj : ', jprecj + WRITE(numout,*) ' jpnij : ', jpnij + WRITE(numout,*) ' lateral domain boundary condition type : jperio = ', jperio + ENDIF + + ! Define constants + ! ---------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Constants' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' mathematical constant rpi = ', rpi + + rsiyea = 365.25_wp * rday * 2._wp * rpi / 6.283076_wp + rsiday = rday / ( 1._wp + rday / rsiyea ) + omega = 2._wp * rpi / rsiday + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' day rday = ', rday, ' s' + IF(lwp) WRITE(numout,*) ' sideral year rsiyea = ', rsiyea, ' s' + IF(lwp) WRITE(numout,*) ' sideral day rsiday = ', rsiday, ' s' + IF(lwp) WRITE(numout,*) ' omega omega = ', omega, ' s^-1' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' nb of months per year raamo = ', raamo, ' months' + IF(lwp) WRITE(numout,*) ' nb of hours per day rjjhh = ', rjjhh, ' hours' + IF(lwp) WRITE(numout,*) ' nb of minutes per hour rhhmm = ', rhhmm, ' mn' + IF(lwp) WRITE(numout,*) ' nb of seconds per minute rmmss = ', rmmss, ' s' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' earth radius ra = ', ra, ' m' + IF(lwp) WRITE(numout,*) ' gravity grav = ', grav , ' m/s^2' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' triple point of temperature rtt = ', rtt , ' K' + IF(lwp) WRITE(numout,*) ' freezing point of water rt0 = ', rt0 , ' K' + IF(lwp) WRITE(numout,*) ' melting point of snow rt0_snow = ', rt0_snow, ' K' + IF(lwp) WRITE(numout,*) ' melting point of ice rt0_ice = ', rt0_ice , ' K' + + IF(lwp) WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90' + + cpic = rcpic / rhoic ! specific heat for ice [J/Kg/K] + lfus = xlsn / rhosn ! latent heat of fusion of fresh ice + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' thermal conductivity of the snow = ', rcdsn , ' J/s/m/K' + WRITE(numout,*) ' thermal conductivity of the ice = ', rcdic , ' J/s/m/K' + WRITE(numout,*) ' fresh ice specific heat = ', cpic , ' J/kg/K' + WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', lfus , ' J/kg' + WRITE(numout,*) ' density times specific heat for snow = ', rcpsn , ' J/m^3/K' + WRITE(numout,*) ' density times specific heat for ice = ', rcpic , ' J/m^3/K' + WRITE(numout,*) ' volumetric latent heat fusion of sea ice = ', xlic , ' J/m' + WRITE(numout,*) ' latent heat of sublimation of snow = ', xsn , ' J/kg' + WRITE(numout,*) ' volumetric latent heat fusion of snow = ', xlsn , ' J/m^3' + WRITE(numout,*) ' density of sea ice = ', rhoic , ' kg/m^3' + WRITE(numout,*) ' density of snow = ', rhosn , ' kg/m^3' + WRITE(numout,*) ' emissivity of snow or ice = ', emic + WRITE(numout,*) ' salinity of ice = ', sice , ' psu' + WRITE(numout,*) ' salinity of sea = ', soce , ' psu' + WRITE(numout,*) ' latent heat of evaporation (water) = ', cevap , ' J/m^3' + WRITE(numout,*) ' correction factor for solar radiation = ', srgamma + 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/V4.0/nemo_sources/tools/DOMAINcfg/src/prtctl.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/prtctl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..143734b59c0151d09fba584ebfc63b7a1b1871d2 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/prtctl.f90 @@ -0,0 +1,561 @@ +MODULE prtctl + !!====================================================================== + !! *** MODULE prtctl *** + !! Ocean system : print all SUM trends for each processor domain + !!====================================================================== + !! History : 9.0 ! 05-07 (C. Talandier) original code + !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain variables + + + + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing + USE wrk_nemo ! work arrays + + 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: prtctl.F90 5025 2015-01-12 15:53:50Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, & + & mask2, clinfo2, ovlap, 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 + !! ovlap : overlap value + !! 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 :: ovlap + INTEGER , INTENT(in), OPTIONAL :: kdim + CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3 + ! + CHARACTER (len=15) :: cl2 + INTEGER :: overlap, jn, sind, eind, kdir,j_id + REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 + REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d_1, ztab2d_2 + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask1, zmask2, ztab3d_1, ztab3d_2 + !!---------------------------------------------------------------------- + + CALL wrk_alloc( jpi,jpj, ztab2d_1, ztab2d_2 ) + CALL wrk_alloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 ) + + ! Arrays, scalars initialization + overlap = 0 + 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(ovlap) ) overlap = ovlap + 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) - overlap ) + nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn)) + njctls = MAX( 1, nldjtl(jn) - overlap ) + njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - 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) + nlditl(jn) - 1 - overlap ) + nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) ) + njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap ) + njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - 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 + + CALL wrk_dealloc( jpi,jpj, ztab2d_1, ztab2d_2 ) + CALL wrk_dealloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 ) + ! + 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,i3.3) +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 + !! nperio local periodic condition + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! nperio : lateral condition type + !! 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, POINTER, DIMENSION(:,:) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace + REAL(wp) :: zidom, zjdom ! temporary scalars + !!---------------------------------------------------------------------- + + ! + CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) + ! + ! 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). + + + + + + ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci + ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj + + + + nrecil = 2 * jpreci + nrecjl = 2 * jprecj + irestil = MOD( jpiglo - nrecil , isplt ) + irestjl = MOD( jpjglo - nrecjl , jsplt ) + + IF( irestil == 0 ) irestil = isplt + + 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 + + + IF( irestjl == 0 ) irestjl = jsplt + + 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 + + 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 + jpreci + nleil = nlcil - jpreci + IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1 + IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil + nldjl = 1 + jprecj + nlejl = nlcjl - jprecj + 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 + ! + ! + CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl ) + ! + ! + END SUBROUTINE sub_dom + + !!====================================================================== +END MODULE prtctl diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/restart.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/restart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5399966d785714e3671a435984dbf2dd8c4c10c5 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/restart.f90 @@ -0,0 +1,281 @@ +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_lim3 + 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 diurnal_bulk + + 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 + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: restart.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rst_opn( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_opn *** + !! + !! ** Purpose : + initialization (should be read in the namelist) of nitrst + !! + open the restart when we are one time step before nitrst + !! - restart header is defined when kt = nitrst-1 + !! - restart data are written when kt = nitrst + !! + define lrst_oce to .TRUE. when we need to define or write the restart + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! ocean output restart file name + CHARACTER(lc) :: clpath ! full path to ocean output restart file + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! default definitions + lrst_oce = .FALSE. + IF( ln_rst_list ) THEN + nrst_lst = 1 + nitrst = nstocklist( nrst_lst ) + ELSE + nitrst = nitend + ENDIF + ENDIF + + ! frequency-based restart dumping (nn_stock) + IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nstock ) == 0 ) THEN + ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment + nitrst = kt + nstock - 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. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN + IF( nitrst <= nitend .AND. nitrst > 0 ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE ( jprstlib ) + CASE DEFAULT ; WRITE(numout,*) & + ' open ocean restart NetCDF file: ',TRIM(clpath)//clname + END SELECT + 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 + ! + CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE., kiolib = jprstlib ) + lrst_oce = .TRUE. + ENDIF + ENDIF + ! + END SUBROUTINE rst_opn + + + SUBROUTINE rst_write( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rstwrite *** + !! + !! ** Purpose : Write restart fields in the format corresponding to jprstlib + !! + !! ** Method : Write in numrow when kt == nitrst in NetCDF + !! file, save fields which are necessary for restart + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !!---------------------------------------------------------------------- + + CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rdt ) ! dynamics and tracer time step + + IF ( .NOT. ln_diurnal_only ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ub' , ub ) ! before fields + CALL iom_rstput( kt, nitrst, numrow, 'vb' , vb ) + CALL iom_rstput( kt, nitrst, numrow, 'tb' , tsb(:,:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'sb' , tsb(:,:,:,jp_sal) ) + CALL iom_rstput( kt, nitrst, numrow, 'sshb' , sshb ) + ! + CALL iom_rstput( kt, nitrst, numrow, 'un' , un ) ! now fields + CALL iom_rstput( kt, nitrst, numrow, 'vn' , vn ) + CALL iom_rstput( kt, nitrst, numrow, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_rstput( kt, nitrst, numrow, 'sshn' , sshn ) + CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop ) + + ! extra variable needed for the ice sheet coupling + IF ( ln_iscpl ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask ) ! need to extrapolate T/S + CALL iom_rstput( kt, nitrst, numrow, 'umask' , umask ) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'vmask' , vmask ) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'smask' , ssmask ) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t_n(:,:,:) ) ! need to compute temperature correction + CALL iom_rstput( kt, nitrst, numrow, 'e3u_n', e3u_n(:,:,:) ) ! need to compute bt conservation + CALL iom_rstput( kt, nitrst, numrow, 'e3v_n', e3v_n(:,:,:) ) ! need to compute bt conservation + CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw_n(:,:,:) ) ! need to compute extrapolation if vvl + END IF + ENDIF + + IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) + + IF( kt == nitrst ) THEN + CALL iom_close( numrow ) ! close the restart file (only at last time step) +!!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(nstocklist,1)) + nitrst = nstocklist( nrst_lst ) + ENDIF + lrst_oce = .FALSE. + ENDIF + ! + END SUBROUTINE rst_write + + + SUBROUTINE rst_read_open + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read_open *** + !! + !! ** Purpose : Open read files for restart (format fixed by jprstlib ) + !! + !! ** Method : Use a non-zero, positive value of numror to assess whether or not + !! the file has already been opened + !!---------------------------------------------------------------------- + INTEGER :: jlibalt = jprstlib + LOGICAL :: llok + CHARACTER(lc) :: clpath ! full path to ocean output restart file + !!---------------------------------------------------------------------- + ! + IF( numror <= 0 ) THEN + IF(lwp) THEN ! Contol prints + WRITE(numout,*) + SELECT CASE ( jprstlib ) + CASE ( jpnf90 ) ; WRITE(numout,*) 'rst_read : read oce NetCDF restart file' + END SELECT + IF ( snc4set%luse ) WRITE(numout,*) 'rst_read : configured with NetCDF4 support' + WRITE(numout,*) '~~~~~~~~' + ENDIF + + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror, kiolib = jlibalt ) + ENDIF + END SUBROUTINE rst_read_open + + + SUBROUTINE rst_read + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read *** + !! + !! ** Purpose : Read files for restart (format fixed by jprstlib ) + !! + !! ** Method : Read in restart.nc file fields which are necessary for restart + !!---------------------------------------------------------------------- + REAL(wp) :: zrdt + INTEGER :: jk + !!---------------------------------------------------------------------- + + CALL rst_read_open ! open restart for reading (if not already opened) + + ! 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 ) + IF( zrdt /= rdt ) neuler = 0 + ENDIF + + ! Diurnal DSST + IF( ln_diurnal ) CALL iom_get( numror, jpdom_autoglo, 'Dsst' , x_dsst ) + 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' , tsn(:,:,1,jp_tem) ) + RETURN + ENDIF + + IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_autoglo, 'ub' , ub ) ! before fields + CALL iom_get( numror, jpdom_autoglo, 'vb' , vb ) + CALL iom_get( numror, jpdom_autoglo, 'tb' , tsb(:,:,:,jp_tem) ) + CALL iom_get( numror, jpdom_autoglo, 'sb' , tsb(:,:,:,jp_sal) ) + CALL iom_get( numror, jpdom_autoglo, 'sshb' , sshb ) + ELSE + neuler = 0 + ENDIF + ! + CALL iom_get( numror, jpdom_autoglo, 'un' , un ) ! now fields + CALL iom_get( numror, jpdom_autoglo, 'vn' , vn ) + CALL iom_get( numror, jpdom_autoglo, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_get( numror, jpdom_autoglo, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_get( numror, jpdom_autoglo, 'sshn' , sshn ) + IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_autoglo, 'rhop' , rhop ) ! 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/V4.0/nemo_sources/tools/DOMAINcfg/src/restcom.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/restcom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..37a2f0fd90229e07e0d84205a38a813219614cc2 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/step_oce.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/step_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1347b08adababcdb5895de46fc6f1083af716a87 --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/step_oce.f90 @@ -0,0 +1,30 @@ +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 daymod ! calendar (day routine) + + USE eosbn2 ! equation of state (eos_bn2 routine) + + USE prtctl ! Print control (prt_ctl routine) + + USE in_out_manager ! I/O manager + USE iom ! + USE lbclnk + USE timing ! Timing + + + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO Consortium (2014) + !! $Id: step_oce.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!====================================================================== +END MODULE step_oce diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/stpctl.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/stpctl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d7154a8d4ed65e81ec2b0cd74faf56c1684f1dcb --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/stpctl.f90 @@ -0,0 +1,159 @@ +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 + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_ctl ! routine called by step.F90 + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stpctl.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +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) :: zumax, zsmin, zssh2 ! 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 (zonal only) + ! ! ------------------------ + !! zumax = MAXVAL( ABS( un(:,:,:) ) ) ! slower than the following loop on NEC SX5 + zumax = 0.e0 + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + zumax = MAX(zumax,ABS(un(ji,jj,jk))) + END DO + END DO + END DO + IF( lk_mpp ) CALL mpp_max( zumax ) ! max over the global domain + ! + IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' abs(U) max: ', zumax + ! + IF( zumax > 20.e0 ) THEN + IF( lk_mpp ) THEN + CALL mpp_maxloc(ABS(un),umask,zumax,ii,ij,ik) + ELSE + ilocu = MAXLOC( ABS( un(:,:,:) ) ) + 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 zonal velocity is larger than 20 m/s' + WRITE(numout,*) ' ====== ' + WRITE(numout,9400) kt, zumax, ii, ij, ik + WRITE(numout,*) + WRITE(numout,*) ' output of last fields in numwso' + ENDIF + kindic = -3 + ENDIF +9400 FORMAT (' kt=',i6,' max abs(U): ',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 + ! + zssh2 = SUM( sshn(:,:) * sshn(:,:) * tmask_i(:,:) ) + IF( lk_mpp ) CALL mpp_sum( zssh2 ) ! sum over the global domain + ! + IF(lwp) WRITE(numsol,9300) kt, zssh2, zumax, zsmin ! ssh statistics + ! +9200 FORMAT('it:', i8, ' iter:', i4, ' r: ',e16.10, ' b: ',e16.10 ) +9300 FORMAT(' it :', i8, ' ssh2: ', e16.10, ' Umax: ',e16.10,' Smin: ',e16.10) + ! + END SUBROUTINE stp_ctl + + !!====================================================================== +END MODULE stpctl diff --git a/V4.0/nemo_sources/tools/DOMAINcfg/src/stringop.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/stringop.f90 new file mode 100644 index 0000000000000000000000000000000000000000..89be0ee43d79b3be753a9a14f8b3868b0b58bced --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/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/V4.0/nemo_sources/tools/DOMAINcfg/src/timing.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/timing.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0f5246888a70286b3946c1a56e2421209b4fecca --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/timing.f90 @@ -0,0 +1,766 @@ +MODULE timing + !!======================================================================== + !! *** MODULE timing *** + !!======================================================================== + !! History : 4.0 ! 2001-05 (R. Benshila) + !!------------------------------------------------------------------------ + + !!------------------------------------------------------------------------ + !! timming_init : initialize timing process + !! timing_start : start Timer + !! timing_stop : stop Timer + !! timing_reset : end timing variable creation + !! timing_finalize : compute stats and write output in calling w*_info + !! timing_ini_var : create timing variables + !! timing_listing : print instumented subroutines in ocean.output + !! wcurrent_info : compute and print detailed stats on the current CPU + !! wave_info : compute and print averaged statson all processors + !! wmpi_info : compute and write global stats + !! supress : suppress an element of the timing linked list + !! insert : insert an element of the timing linked list + !!------------------------------------------------------------------------ + USE in_out_manager ! I/O manager + USE dom_oce ! ocean domain + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC timing_init, timing_finalize ! called in nemogcm module + PUBLIC timing_reset ! called in step module + PUBLIC timing_start, timing_stop ! called in each routine to time + + + INCLUDE 'mpif.h' + + + ! Variables for fine grain timing + TYPE timer + CHARACTER(LEN=20) :: cname + 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_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/OPA 4.0 , NEMO Consortium (2011) + !! $Id: timing.F90 5120 2015-03-03 16:11:55Z acc $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE timing_start(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_start *** + !! ** Purpose : collect execution time + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + ! + + ! Create timing structure at first call + IF( .NOT. l_initdone ) THEN + CALL timing_ini_var(cdinfo) + ELSE + 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 + 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 + + s_timer%t_clock= MPI_Wtime() + + + + + ! + 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 + ! + s_wrk => NULL() + + ! clock time collection + + zmpitime = MPI_Wtime() + + + + ! CPU time collection + CALL CPU_TIME( zcpu_end ) + + 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 + s_timer%t_cpu = zcpu_end - s_timer%t_cpu - t_overcpu - s_timer%tsub_cpu + + ! clock time correction + + s_timer%t_clock = zmpitime - s_timer%t_clock - t_overclock - s_timer%tsub_clock + + + + + + + + ! Correction of parent section + IF( .NOT. PRESENT(csection) ) THEN + s_wrk => s_timer + DO WHILE ( ASSOCIATED(s_wrk%parent_section ) ) + s_wrk => s_wrk%parent_section + s_wrk%tsub_cpu = s_wrk%tsub_cpu + s_timer%t_cpu + s_wrk%tsub_clock = s_wrk%tsub_clock + s_timer%t_clock + END DO + 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. + ! + 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 3.6 (2015) ' + WRITE(numtime,*) + WRITE(numtime,*) ' Timing Informations ' + WRITE(numtime,*) + WRITE(numtime,*) + ENDIF + + ! Compute clock function overhead + + t_overclock = MPI_WTIME() + t_overclock = MPI_WTIME() - t_overclock + + ! Compute cpu_time function overhead + CALL CPU_TIME(zdum) + CALL CPU_TIME(t_overcpu) + + ! End overhead omputation + t_overcpu = t_overcpu - zdum + t_overclock = t_overcpu + t_overclock + + ! Timing on date and time + CALL DATE_AND_TIME(cdate(1),ctime(1),czone,nvalues) + + CALL CPU_TIME(t_cpu(1)) + ! Start elapsed and CPU time counters + t_elaps(1) = MPI_WTIME() + ! + END SUBROUTINE timing_init + + + SUBROUTINE timing_finalize + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_finalize *** + !! ** Purpose : compute average time + !! write timing output file + !!---------------------------------------------------------------------- + TYPE(timer), POINTER :: s_temp + INTEGER :: idum, iperiods, icode + LOGICAL :: ll_ord, ll_averep + CHARACTER(len=120) :: clfmt + + ll_averep = .TRUE. + + ! total CPU and elapse + CALL CPU_TIME(t_cpu(2)) + t_cpu(2) = t_cpu(2) - t_cpu(1) - t_overcpu + t_elaps(2) = MPI_WTIME() - t_elaps(1) - t_overclock + + ! End of timings on date & time + CALL DATE_AND_TIME(cdate(2),ctime(2),czone,nvalues) + + ! Compute the numer of routines + nsize = 0 + s_timer => s_timer_root + DO WHILE( ASSOCIATED(s_timer) ) + nsize = nsize + 1 + s_timer => s_timer%next + END DO + idum = nsize + IF(lk_mpp) CALL mpp_sum(idum) + IF( idum/jpnij /= nsize ) THEN + IF( lwriter ) WRITE(numtime,*) ' ===> W A R N I N G: ' + IF( lwriter ) WRITE(numtime,*) ' Some CPU have different number of routines instrumented for timing' + IF( lwriter ) WRITE(numtime,*) ' No detailed report on averaged timing can be provided' + IF( lwriter ) WRITE(numtime,*) ' The following detailed report only deals with the current processor' + IF( lwriter ) WRITE(numtime,*) + ll_averep = .FALSE. + ENDIF + + ! in MPI gather some info + ALLOCATE( all_etime(jpnij), all_ctime(jpnij) ) + CALL MPI_ALLGATHER(t_elaps(2), 1, MPI_DOUBLE_PRECISION, & + all_etime , 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OPA, icode) + CALL MPI_ALLGATHER(t_cpu(2) , 1, MPI_DOUBLE_PRECISION, & + all_ctime, 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OPA, icode) + tot_etime = SUM(all_etime(:)) + tot_ctime = SUM(all_ctime(:)) + + ! write output file + IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' + IF( lwriter ) WRITE(numtime,*) '--------------------' + IF( lwriter ) WRITE(numtime,"('Elapsed Time (s) CPU Time (s)')") + IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)') tot_etime, tot_ctime + IF( lwriter ) WRITE(numtime,*) + IF( ll_averep ) CALL waver_info + CALL wmpi_info + IF( lwriter ) CALL wcurrent_info + + clfmt='(1X,"Timing started on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(1)(7:8), cdate(1)(5:6), cdate(1)(1:4), & + & ctime(1)(1:2), ctime(1)(3:4), ctime(1)(5:6), & + & czone(1:3), czone(4:5) + clfmt='(1X, "Timing ended on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(2)(7:8), cdate(2)(5:6), cdate(2)(1:4), & + & ctime(2)(1:2), ctime(2)(3:4), ctime(2)(5:6), & + & czone(1:3), czone(4:5) + + 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 + + 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_OPA, icode) + CALL MPI_GATHER(s_timer%tsum_clock , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_clock, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OPA, icode) + CALL MPI_GATHER(s_timer%tsum_cpu , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_cpu, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OPA, icode) + CALL MPI_GATHER(s_timer%niter , 1, MPI_INTEGER, & + sl_timer_glob%niter, 1, MPI_INTEGER, & + 0, MPI_COMM_OPA, 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 + + WRITE(*,*) 'ARPDBG: timing: done gathers' + + 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 + + WRITE(*,*) 'ARPDBG: timing: done computing stats' + + ! 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(zall_ratio(:)) + zavg_ratio = ztot_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)=' (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' + WRITE(cllignes(4)(1:4),'(I4)') jpnij + cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(7)='1x,"Maximum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(8)='1x,"Average |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3)' + clfmt=TRIM(cllignes(1))// TRIM(cllignes(2))//TRIM(cllignes(3))// & + & TRIM(clhline)//TRIM(cllignes(4))//TRIM(clhline)//TRIM(cllignes(5))// & + & TRIM(clhline)//TRIM(cllignes(6))//TRIM(clhline)//TRIM(cllignes(7))// & + & TRIM(clhline)//TRIM(cllignes(8)) + WRITE(numtime, TRIM(clfmt)) & + (iall_rank(idum),all_etime(idum),all_ctime(idum),zall_ratio(idum),idum=1, jpnij), & + tot_etime, tot_ctime, ztot_ratio, & + zmin_etime, zmin_ctime, zmin_ratio, & + zmax_etime, zmax_ctime, zmax_ratio, & + zavg_etime, zavg_ctime, zavg_ratio + WRITE(numtime,*) + END IF + ! + DEALLOCATE(zall_ratio, iall_rank) + ! + END SUBROUTINE wmpi_info + + + SUBROUTINE timing_ini_var(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_ini_var *** + !! ** Purpose : create timing structure + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + LOGICAL :: ll_section + + ! + IF( .NOT. ASSOCIATED(s_timer_root) ) THEN + ALLOCATE(s_timer_root) + s_timer_root%cname = cdinfo + s_timer_root%t_cpu = 0._wp + s_timer_root%t_clock = 0._wp + s_timer_root%tsum_cpu = 0._wp + s_timer_root%tsum_clock = 0._wp + s_timer_root%tmax_cpu = 0._wp + s_timer_root%tmax_clock = 0._wp + s_timer_root%tmin_cpu = 0._wp + s_timer_root%tmin_clock = 0._wp + s_timer_root%tsub_cpu = 0._wp + s_timer_root%tsub_clock = 0._wp + s_timer_root%ncount = 0 + s_timer_root%ncount_rate = 0 + s_timer_root%ncount_max = 0 + s_timer_root%niter = 0 + s_timer_root%l_tdone = .FALSE. + s_timer_root%next => NULL() + s_timer_root%prev => NULL() + s_timer => s_timer_root + ! + ALLOCATE(s_wrk) + s_wrk => NULL() + + ELSE + s_timer => s_timer_root + ! case of already existing area (typically inside a loop) + DO WHILE( ASSOCIATED(s_timer) ) + IF( TRIM(s_timer%cname) .EQ. TRIM(cdinfo) ) RETURN + 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 + + ALLOCATE(s_timer%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 + + ! are we inside a section + s_wrk => s_timer%prev + ll_section = .FALSE. + DO WHILE( ASSOCIATED(s_wrk) .AND. .NOT. ll_section ) + IF( .NOT. s_wrk%l_tdone ) THEN + ll_section = .TRUE. + s_timer%parent_section => s_wrk + ENDIF + s_wrk => s_wrk%prev + END DO + ENDIF + ! + 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/V4.0/nemo_sources/tools/DOMAINcfg/src/trc_oce.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/trc_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..33c35091da72e228e931fa43b7c0f7f8210400bc --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/trc_oce.f90 @@ -0,0 +1,263 @@ +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 + + 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(:,:,:) :: facvol !: volume for degraded regions + + + + + + + + + !!---------------------------------------------------------------------- + !! Default option No bio-model light absorption + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trc_oce.F90 6140 2015-12-21 11:35:23Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_oce_alloc() + !!---------------------------------------------------------------------- + !! *** trc_oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(2) ! Local variables + !!---------------------------------------------------------------------- + ierr(:) = 0 + ALLOCATE( etot3 (jpi,jpj,jpk), STAT=ierr(1) ) + IF( lk_degrad) ALLOCATE( facvol(jpi,jpj,jpk), STAT=ierr(2) ) + trc_oce_alloc = MAXVAL( ierr ) + ! + 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/V4.0/nemo_sources/tools/DOMAINcfg/src/wrk_nemo.f90 b/V4.0/nemo_sources/tools/DOMAINcfg/src/wrk_nemo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2906bf66f343bd67edb0f5877a9ea0958a8a3d0d --- /dev/null +++ b/V4.0/nemo_sources/tools/DOMAINcfg/src/wrk_nemo.f90 @@ -0,0 +1,599 @@ +MODULE wrk_nemo + !!====================================================================== + !! *** MODULE wrk_nemo *** + !! NEMO work space: define and allocate work-space arrays used in + !! all components of NEMO + !!====================================================================== + !! History : 4.0 ! 2011-01 (A Porter) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! wrk_alloc : get work space arrays + !! wrk_dealloc : release work space arrays + !! + !! 1d arrays: + !! REAL(wp), POINTER, DIMENSION(:) :: arr1, arr2, ... arr10 + !! or + !! INTEGER, POINTER, DIMENSION(:) :: arr1, arr2, ... arr10 + !! ... + !! CALL wrk_alloc( nx, arr1, arr2, ... arr10, kistart = kistart ) + !! ... + !! CALL wrk_dealloc( nx, arr1, arr2, ... arr10, kistart = kistart) + !! with: + !! - arr*: 1d arrays. real or (not and) integer + !! - nx: size of the 1d arr* arrays + !! - arr2, ..., arr10: optional parameters + !! - kistart: optional parameter to lower bound of the 1st dimension (default = 1) + !! + !! 2d arrays: + !! REAL(wp), POINTER, DIMENSION(:,:) :: arr1, arr2, ... arr10 + !! or + !! INTEGER, POINTER, DIMENSION(:,:) :: arr1, arr2, ... arr10 + !! ... + !! CALL wrk_alloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart ) + !! ... + !! CALL wrk_dealloc( nx, ny, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart ) + !! with: + !! - arr* 2d arrays. real or (not and) integer + !! - nx, ny: size of the 2d arr* arrays + !! - arr2, ..., arr10: optional parameters + !! - kistart, kjstart: optional parameters to lower bound of the 1st/2nd dimension (default = 1) + !! + !! 3d arrays: + !! REAL(wp), POINTER, DIMENSION(:,:,:) :: arr1, arr2, ... arr10 + !! or + !! INTEGER, POINTER, DIMENSION(:,:,:) :: arr1, arr2, ... arr10 + !! ... + !! CALL wrk_alloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart ) + !! ... + !! CALL wrk_dealloc( nx, ny, nz, arr1, arr2, ... arr10, kistart = kistart, kjstart = kjstart, kkstart = kkstart ) + !! with: + !! - arr* 3d arrays. real or (not and) integer + !! - nx, ny, nz: size of the 3d arr* arrays + !! - arr2, ..., arr10: optional parameters + !! - kistart, kjstart, kkstart: optional parameters to lower bound of the 1st/2nd/3rd dimension (default = 1) + !! + !! 4d arrays: + !! REAL(wp), POINTER, DIMENSION(:,:,:,:) :: arr1, arr2, ... arr10 + !! or + !! INTEGER, POINTER, DIMENSION(:,:,:,:) :: arr1, arr2, ... arr10 + !! ... + !! CALL wrk_alloc( nx, ny, nz, nl, arr1, arr2, ... arr10, & + !! & kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart ) + !! ... + !! CALL wrk_dealloc( nx, ny, nz, nl, arr1, arr2, ... arr10, & + !! & kistart = kistart, kjstart = kjstart, kkstart = kkstart, klstart = klstart ) + !! with: + !! - arr* 3d arrays. real or (not and) integer + !! - nx, ny, nz, nl: size of the 4d arr* arrays + !! - arr2, ..., arr10: optional parameters + !! - kistart, kjstart, kkstart, klstart: optional parameters to lower bound of the 1st/2nd/3rd/4th dimension (default = 1) + !! + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC wrk_alloc, wrk_dealloc, wrk_list + + INTERFACE wrk_alloc + MODULE PROCEDURE wrk_alloc_1dr, wrk_alloc_2dr, wrk_alloc_3dr, wrk_alloc_4dr, & + & wrk_alloc_1di, wrk_alloc_2di, wrk_alloc_3di, wrk_alloc_4di + END INTERFACE + + INTERFACE wrk_dealloc + MODULE PROCEDURE wrk_dealloc_1dr, wrk_dealloc_2dr, wrk_dealloc_3dr, wrk_dealloc_4dr, & + & wrk_dealloc_1di, wrk_dealloc_2di, wrk_dealloc_3di, wrk_dealloc_4di + END INTERFACE + + + INTEGER, PARAMETER :: jparray = 1000 + INTEGER, PARAMETER :: jpmaxdim = 4 + + INTEGER, PARAMETER :: jpnotdefined = 0 + INTEGER, PARAMETER :: jpinteger = 1 + INTEGER, PARAMETER :: jpreal = 2 + + TYPE leaf + LOGICAL :: in_use + INTEGER :: indic + INTEGER , DIMENSION(:) , POINTER :: iwrk1d => NULL() + INTEGER , DIMENSION(:,:) , POINTER :: iwrk2d => NULL() + INTEGER , DIMENSION(:,:,:) , POINTER :: iwrk3d => NULL() + INTEGER , DIMENSION(:,:,:,:), POINTER :: iwrk4d => NULL() + REAL(wp), DIMENSION(:) , POINTER :: zwrk1d => NULL() + REAL(wp), DIMENSION(:,:) , POINTER :: zwrk2d => NULL() + REAL(wp), DIMENSION(:,:,:) , POINTER :: zwrk3d => NULL() + REAL(wp), DIMENSION(:,:,:,:), POINTER :: zwrk4d => NULL() + TYPE (leaf), POINTER :: next => NULL() + TYPE (leaf), POINTER :: prev => NULL() + END TYPE leaf + + TYPE branch + INTEGER :: itype + INTEGER, DIMENSION(jpmaxdim) :: ishape, istart + TYPE(leaf), POINTER :: start => NULL() + TYPE(leaf), POINTER :: current => NULL() + END TYPE branch + + TYPE(branch), SAVE, DIMENSION(jparray) :: tree + + LOGICAL :: linit = .FALSE. + LOGICAL :: ldebug = .FALSE. + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2011) + !! $Id: wrk_nemo.F90 5514 2015-06-30 10:06:05Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE wrk_list + ! to list 3d arrays in use, to be duplicated for all cases + WRITE(*,*) 'Arrays in use :' + ! CALL listage(tree_3d(1)%s_wrk_3d_start) + WRITE(*,*) '' + + END SUBROUTINE wrk_list + + + RECURSIVE SUBROUTINE listage(ptr) + + TYPE(leaf), POINTER, INTENT(in) :: ptr + ! + IF( ASSOCIATED(ptr%next) ) CALL listage(ptr%next) + WRITE(*,*) ptr%in_use, ptr%indic + + END SUBROUTINE listage + + + SUBROUTINE wrk_alloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart ) + INTEGER , INTENT(in ) :: kidim ! dimensions size + REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01 + REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart + ! + CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, & + & p1d01 = p1d01, p1d02 = p1d02, p1d03 = p1d03, p1d04 = p1d04, p1d05 = p1d05, & + & p1d06 = p1d06, p1d07 = p1d07, p1d08 = p1d08, p1d09 = p1d09, p1d10 = p1d10 ) + ! + END SUBROUTINE wrk_alloc_1dr + + + SUBROUTINE wrk_alloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart ) + INTEGER , INTENT(in ) :: kidim ! dimensions size + INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01 + INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart + ! + CALL wrk_alloc_xd( kidim, 0, 0, 0, kistart, 1, 1, 1, & + & k1d01 = k1d01, k1d02 = k1d02, k1d03 = k1d03, k1d04 = k1d04, k1d05 = k1d05, & + & k1d06 = k1d06, k1d07 = k1d07, k1d08 = k1d08, k1d09 = k1d09, k1d10 = k1d10 ) + ! + END SUBROUTINE wrk_alloc_1di + + + SUBROUTINE wrk_alloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart, kjstart ) + INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01 + REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart + ! + CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, & + & p2d01 = p2d01, p2d02 = p2d02, p2d03 = p2d03, p2d04 = p2d04, p2d05 = p2d05, & + & p2d06 = p2d06, p2d07 = p2d07, p2d08 = p2d08, p2d09 = p2d09, p2d10 = p2d10 ) + ! + END SUBROUTINE wrk_alloc_2dr + + + SUBROUTINE wrk_alloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart, kjstart ) + INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01 + INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart + ! + CALL wrk_alloc_xd( kidim, kjdim, 0, 0, kistart, kjstart, 1, 1, & + & k2d01 = k2d01, k2d02 = k2d02, k2d03 = k2d03, k2d04 = k2d04, k2d05 = k2d05, & + & k2d06 = k2d06, k2d07 = k2d07, k2d08 = k2d08, k2d09 = k2d09, k2d10 = k2d10 ) + ! + END SUBROUTINE wrk_alloc_2di + + + SUBROUTINE wrk_alloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, & + & kistart, kjstart, kkstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01 + REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart + ! + CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, & + & p3d01 = p3d01, p3d02 = p3d02, p3d03 = p3d03, p3d04 = p3d04, p3d05 = p3d05, & + & p3d06 = p3d06, p3d07 = p3d07, p3d08 = p3d08, p3d09 = p3d09, p3d10 = p3d10 ) + ! + END SUBROUTINE wrk_alloc_3dr + + + SUBROUTINE wrk_alloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, & + & kistart, kjstart, kkstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01 + INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart + ! + CALL wrk_alloc_xd( kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1, & + & k3d01 = k3d01, k3d02 = k3d02, k3d03 = k3d03, k3d04 = k3d04, k3d05 = k3d05, & + & k3d06 = k3d06, k3d07 = k3d07, k3d08 = k3d08, k3d09 = k3d09, k3d10 = k3d10 ) + ! + END SUBROUTINE wrk_alloc_3di + + + SUBROUTINE wrk_alloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, & + & kistart, kjstart, kkstart, klstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01 + REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart + ! + CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, & + & p4d01 = p4d01, p4d02 = p4d02, p4d03 = p4d03, p4d04 = p4d04, p4d05 = p4d05, & + & p4d06 = p4d06, p4d07 = p4d07, p4d08 = p4d08, p4d09 = p4d09, p4d10 = p4d10 ) + ! + END SUBROUTINE wrk_alloc_4dr + + + SUBROUTINE wrk_alloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, & + & kistart, kjstart, kkstart, klstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01 + INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart + ! + CALL wrk_alloc_xd( kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart, & + & k4d01 = k4d01, k4d02 = k4d02, k4d03 = k4d03, k4d04 = k4d04, k4d05 = k4d05, & + & k4d06 = k4d06, k4d07 = k4d07, k4d08 = k4d08, k4d09 = k4d09, k4d10 = k4d10 ) + ! + END SUBROUTINE wrk_alloc_4di + + + SUBROUTINE wrk_dealloc_1dr( kidim, p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, kistart ) + INTEGER , INTENT(in ) :: kidim ! dimensions size + REAL(wp), POINTER, DIMENSION(:), INTENT(inout) :: p1d01 + REAL(wp), POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(p1d02),PRESENT(p1d03),PRESENT(p1d04),PRESENT(p1d05), & + & PRESENT(p1d06),PRESENT(p1d07),PRESENT(p1d08),PRESENT(p1d09),PRESENT(p1d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, 0, 0, 0, kistart, 1, 1, 1) ; END DO + ! + END SUBROUTINE wrk_dealloc_1dr + + + SUBROUTINE wrk_dealloc_1di( kidim, k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, kistart ) + INTEGER , INTENT(in ) :: kidim ! dimensions size + INTEGER , POINTER, DIMENSION(:), INTENT(inout) :: k1d01 + INTEGER , POINTER, DIMENSION(:), INTENT(inout), OPTIONAL :: k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(k1d02),PRESENT(k1d03),PRESENT(k1d04),PRESENT(k1d05), & + & PRESENT(k1d06),PRESENT(k1d07),PRESENT(k1d08),PRESENT(k1d09),PRESENT(k1d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, 0, 0, 0, kistart, 1, 1, 1 ) ; END DO + ! + END SUBROUTINE wrk_dealloc_1di + + + SUBROUTINE wrk_dealloc_2dr( kidim, kjdim, p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, kistart,kjstart ) + INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout) :: p2d01 + REAL(wp), POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(p2d02),PRESENT(p2d03),PRESENT(p2d04),PRESENT(p2d05), & + & PRESENT(p2d06),PRESENT(p2d07),PRESENT(p2d08),PRESENT(p2d09),PRESENT(p2d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO + ! + END SUBROUTINE wrk_dealloc_2dr + + + SUBROUTINE wrk_dealloc_2di( kidim, kjdim, k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, kistart,kjstart ) + INTEGER , INTENT(in ) :: kidim, kjdim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:), INTENT(inout) :: k2d01 + INTEGER , POINTER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(k2d02),PRESENT(k2d03),PRESENT(k2d04),PRESENT(k2d05), & + & PRESENT(k2d06),PRESENT(k2d07),PRESENT(k2d08),PRESENT(k2d09),PRESENT(k2d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, 0, 0, kistart, kjstart, 1, 1 ) ; END DO + ! + END SUBROUTINE wrk_dealloc_2di + + + SUBROUTINE wrk_dealloc_3dr( kidim, kjdim, kkdim, p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, & + & kistart, kjstart, kkstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout) :: p3d01 + REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(p3d02),PRESENT(p3d03),PRESENT(p3d04),PRESENT(p3d05), & + & PRESENT(p3d06),PRESENT(p3d07),PRESENT(p3d08),PRESENT(p3d09),PRESENT(p3d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO + ! + END SUBROUTINE wrk_dealloc_3dr + + + SUBROUTINE wrk_dealloc_3di( kidim, kjdim, kkdim, k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, & + & kistart, kjstart, kkstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout) :: k3d01 + INTEGER , POINTER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(k3d02),PRESENT(k3d03),PRESENT(k3d04),PRESENT(k3d05), & + & PRESENT(k3d06),PRESENT(k3d07),PRESENT(k3d08),PRESENT(k3d09),PRESENT(k3d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, 0, kistart, kjstart, kkstart, 1 ) ; END DO + ! + END SUBROUTINE wrk_dealloc_3di + + + SUBROUTINE wrk_dealloc_4dr( kidim, kjdim, kkdim, kldim, p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10, & + & kistart, kjstart, kkstart, klstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size + REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: p4d01 + REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(p4d02),PRESENT(p4d03),PRESENT(p4d04),PRESENT(p4d05), & + & PRESENT(p4d06),PRESENT(p4d07),PRESENT(p4d08),PRESENT(p4d09),PRESENT(p4d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpreal, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO + ! + END SUBROUTINE wrk_dealloc_4dr + + + SUBROUTINE wrk_dealloc_4di( kidim, kjdim, kkdim, kldim, k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, & + & kistart, kjstart, kkstart, klstart ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size + INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout) :: k4d01 + INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10 + INTEGER , INTENT(in ), OPTIONAL :: kistart, kjstart, kkstart, klstart + ! + INTEGER :: icnt, jn + icnt = 1 + COUNT( (/ PRESENT(k4d02),PRESENT(k4d03),PRESENT(k4d04),PRESENT(k4d05), & + & PRESENT(k4d06),PRESENT(k4d07),PRESENT(k4d08),PRESENT(k4d09),PRESENT(k4d10) /) ) + DO jn = 1, icnt ; CALL wrk_deallocbase( jpinteger, kidim, kjdim, kkdim, kldim, kistart, kjstart, kkstart, klstart ) ; END DO + ! + END SUBROUTINE wrk_dealloc_4di + + + SUBROUTINE wrk_alloc_xd( kidim, kjdim, kkdim, kldim, & + & kisrt, kjsrt, kksrt, klsrt, & + & k1d01, k1d02, k1d03, k1d04, k1d05, k1d06, k1d07, k1d08, k1d09, k1d10, & + & k2d01, k2d02, k2d03, k2d04, k2d05, k2d06, k2d07, k2d08, k2d09, k2d10, & + & k3d01, k3d02, k3d03, k3d04, k3d05, k3d06, k3d07, k3d08, k3d09, k3d10, & + & k4d01, k4d02, k4d03, k4d04, k4d05, k4d06, k4d07, k4d08, k4d09, k4d10, & + & p1d01, p1d02, p1d03, p1d04, p1d05, p1d06, p1d07, p1d08, p1d09, p1d10, & + & p2d01, p2d02, p2d03, p2d04, p2d05, p2d06, p2d07, p2d08, p2d09, p2d10, & + & p3d01, p3d02, p3d03, p3d04, p3d05, p3d06, p3d07, p3d08, p3d09, p3d10, & + & p4d01, p4d02, p4d03, p4d04, p4d05, p4d06, p4d07, p4d08, p4d09, p4d10 ) + INTEGER ,INTENT(in ) :: kidim, kjdim, kkdim, kldim ! dimensions size + INTEGER ,INTENT(in ),OPTIONAL:: kisrt, kjsrt, kksrt, klsrt + INTEGER , POINTER, DIMENSION(: ),INTENT(inout),OPTIONAL:: k1d01,k1d02,k1d03,k1d04,k1d05,k1d06,k1d07,k1d08,k1d09,k1d10 + INTEGER , POINTER, DIMENSION(:,: ),INTENT(inout),OPTIONAL:: k2d01,k2d02,k2d03,k2d04,k2d05,k2d06,k2d07,k2d08,k2d09,k2d10 + INTEGER , POINTER, DIMENSION(:,:,: ),INTENT(inout),OPTIONAL:: k3d01,k3d02,k3d03,k3d04,k3d05,k3d06,k3d07,k3d08,k3d09,k3d10 + INTEGER , POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL:: k4d01,k4d02,k4d03,k4d04,k4d05,k4d06,k4d07,k4d08,k4d09,k4d10 + REAL(wp), POINTER, DIMENSION(: ),INTENT(inout),OPTIONAL:: p1d01,p1d02,p1d03,p1d04,p1d05,p1d06,p1d07,p1d08,p1d09,p1d10 + REAL(wp), POINTER, DIMENSION(:,: ),INTENT(inout),OPTIONAL:: p2d01,p2d02,p2d03,p2d04,p2d05,p2d06,p2d07,p2d08,p2d09,p2d10 + REAL(wp), POINTER, DIMENSION(:,:,: ),INTENT(inout),OPTIONAL:: p3d01,p3d02,p3d03,p3d04,p3d05,p3d06,p3d07,p3d08,p3d09,p3d10 + REAL(wp), POINTER, DIMENSION(:,:,:,:),INTENT(inout),OPTIONAL:: p4d01,p4d02,p4d03,p4d04,p4d05,p4d06,p4d07,p4d08,p4d09,p4d10 + ! + LOGICAL :: llpres + INTEGER :: jn, iisrt, ijsrt, iksrt, ilsrt + ! + IF( .NOT. linit ) THEN + tree(:)%itype = jpnotdefined + DO jn = 1, jparray ; tree(jn)%ishape(:) = 0 ; tree(jn)%istart(:) = 0 ; END DO + linit = .TRUE. + ENDIF + + IF( PRESENT(kisrt) ) THEN ; iisrt = kisrt ; ELSE ; iisrt = 1 ; ENDIF + IF( PRESENT(kjsrt) ) THEN ; ijsrt = kjsrt ; ELSE ; ijsrt = 1 ; ENDIF + IF( PRESENT(kksrt) ) THEN ; iksrt = kksrt ; ELSE ; iksrt = 1 ; ENDIF + IF( PRESENT(klsrt) ) THEN ; ilsrt = klsrt ; ELSE ; ilsrt = 1 ; ENDIF + + llpres = PRESENT(k1d01) .OR. PRESENT(k2d01) .OR. PRESENT(k3d01) .OR. PRESENT(k4d01) & + & .OR. PRESENT(p1d01) .OR. PRESENT(p2d01) .OR. PRESENT(p3d01) .OR. PRESENT(p4d01) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d01, k2d01, k3d01, k4d01, p1d01, p2d01, p3d01, p4d01 ) + llpres = PRESENT(k1d02) .OR. PRESENT(k2d02) .OR. PRESENT(k3d02) .OR. PRESENT(k4d02) & + & .OR. PRESENT(p1d02) .OR. PRESENT(p2d02) .OR. PRESENT(p3d02) .OR. PRESENT(p4d02) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d02, k2d02, k3d02, k4d02, p1d02, p2d02, p3d02, p4d02 ) + llpres = PRESENT(k1d03) .OR. PRESENT(k2d03) .OR. PRESENT(k3d03) .OR. PRESENT(k4d03) & + & .OR. PRESENT(p1d03) .OR. PRESENT(p2d03) .OR. PRESENT(p3d03) .OR. PRESENT(p4d03) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d03, k2d03, k3d03, k4d03, p1d03, p2d03, p3d03, p4d03 ) + llpres = PRESENT(k1d04) .OR. PRESENT(k2d04) .OR. PRESENT(k3d04) .OR. PRESENT(k4d04) & + & .OR. PRESENT(p1d04) .OR. PRESENT(p2d04) .OR. PRESENT(p3d04) .OR. PRESENT(p4d04) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d04, k2d04, k3d04, k4d04, p1d04, p2d04, p3d04, p4d04 ) + llpres = PRESENT(k1d05) .OR. PRESENT(k2d05) .OR. PRESENT(k3d05) .OR. PRESENT(k4d05) & + & .OR. PRESENT(p1d05) .OR. PRESENT(p2d05) .OR. PRESENT(p3d05) .OR. PRESENT(p4d05) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d05, k2d05, k3d05, k4d05, p1d05, p2d05, p3d05, p4d05 ) + llpres = PRESENT(k1d06) .OR. PRESENT(k2d06) .OR. PRESENT(k3d06) .OR. PRESENT(k4d06) & + & .OR. PRESENT(p1d06) .OR. PRESENT(p2d06) .OR. PRESENT(p3d06) .OR. PRESENT(p4d06) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d06, k2d06, k3d06, k4d06, p1d06, p2d06, p3d06, p4d06 ) + llpres = PRESENT(k1d07) .OR. PRESENT(k2d07) .OR. PRESENT(k3d07) .OR. PRESENT(k4d07) & + & .OR. PRESENT(p1d07) .OR. PRESENT(p2d07) .OR. PRESENT(p3d07) .OR. PRESENT(p4d07) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d07, k2d07, k3d07, k4d07, p1d07, p2d07, p3d07, p4d07 ) + llpres = PRESENT(k1d08) .OR. PRESENT(k2d08) .OR. PRESENT(k3d08) .OR. PRESENT(k4d08) & + & .OR. PRESENT(p1d08) .OR. PRESENT(p2d08) .OR. PRESENT(p3d08) .OR. PRESENT(p4d08) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d08, k2d08, k3d08, k4d08, p1d08, p2d08, p3d08, p4d08 ) + llpres = PRESENT(k1d09) .OR. PRESENT(k2d09) .OR. PRESENT(k3d09) .OR. PRESENT(k4d09) & + & .OR. PRESENT(p1d09) .OR. PRESENT(p2d09) .OR. PRESENT(p3d09) .OR. PRESENT(p4d09) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d09, k2d09, k3d09, k4d09, p1d09, p2d09, p3d09, p4d09 ) + llpres = PRESENT(k1d10) .OR. PRESENT(k2d10) .OR. PRESENT(k3d10) .OR. PRESENT(k4d10) & + & .OR. PRESENT(p1d10) .OR. PRESENT(p2d10) .OR. PRESENT(p3d10) .OR. PRESENT(p4d10) + IF( llpres ) CALL wrk_allocbase( kidim, kjdim, kkdim, kldim, iisrt, ijsrt, iksrt, ilsrt, & + & k1d10, k2d10, k3d10, k4d10, p1d10, p2d10, p3d10, p4d10 ) + + END SUBROUTINE wrk_alloc_xd + + + SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt , & + & kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d ) + INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim + INTEGER , INTENT(in ) :: kisrt, kjsrt, kksrt, klsrt + INTEGER , POINTER, DIMENSION(:) , INTENT(inout), OPTIONAL :: kwrk1d + INTEGER , POINTER, DIMENSION(:,:) , INTENT(inout), OPTIONAL :: kwrk2d + INTEGER , POINTER, DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: kwrk3d + INTEGER , POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: kwrk4d + REAL(wp), POINTER, DIMENSION(:) , INTENT(inout), OPTIONAL :: pwrk1d + REAL(wp), POINTER, DIMENSION(:,:) , INTENT(inout), OPTIONAL :: pwrk2d + REAL(wp), POINTER, DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: pwrk3d + REAL(wp), POINTER, DIMENSION(:,:,:,:), INTENT(inout), OPTIONAL :: pwrk4d + ! + INTEGER, DIMENSION(jpmaxdim) :: ishape, isrt, iend + INTEGER :: itype + INTEGER :: ii + + ! define the shape to be given to the work array + ishape(:) = (/ kidim, kjdim, kkdim, kldim /) + ! define the starting index of the dimension shape to be given to the work array + isrt (:) = (/ kisrt, kjsrt, kksrt, klsrt /) + iend (:) = ishape(:) + isrt(:) - 1 + + ! is it integer or real array? + IF( PRESENT(kwrk1d) .OR. PRESENT(kwrk2d) .OR. PRESENT(kwrk3d) .OR. PRESENT(kwrk4d) ) itype = jpinteger + IF( PRESENT(pwrk1d) .OR. PRESENT(pwrk2d) .OR. PRESENT(pwrk3d) .OR. PRESENT(pwrk4d) ) itype = jpreal + + ! find the branch with the matching shape, staring index and type or get the first "free" branch + ii = 1 + DO WHILE( ( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= isrt ) .OR. tree(ii)%itype /= itype ) & + & .AND. SUM( tree(ii)%ishape ) /= 0 ) + ii = ii + 1 + IF (ii > jparray) STOP ! increase the value of jparray (should not be needed as already very big!) + END DO + + IF( SUM( tree(ii)%ishape ) == 0 ) THEN ! create a new branch + IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype + tree(ii)%itype = itype ! define the type of this branch + tree(ii)%ishape(:) = ishape(:) ! define the shape of this branch + tree(ii)%istart(:) = isrt(:) ! define the lower bounds of this branch + ALLOCATE( tree(ii)%start ) ! allocate its start + ALLOCATE( tree(ii)%current) ! allocate the current leaf (the first leaf) + + tree(ii)%start%in_use = .FALSE. ! Never use the start as work array + tree(ii)%start%indic = 0 + tree(ii)%start%prev => NULL() ! nothing before the start + tree(ii)%start%next => tree(ii)%current ! first leaf link to the start + + tree(ii)%current%in_use = .FALSE. ! first leaf is not yet used + tree(ii)%current%indic = 1 ! first leaf + tree(ii)%current%prev => tree(ii)%start ! previous leaf is the start + tree(ii)%current%next => NULL() ! next leaf is not yet defined + ! allocate the array of the first leaf + IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) ) + IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) + IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) + IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) + IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) ) + IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) + IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) + IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) + + ELSE IF( .NOT. ASSOCIATED(tree(ii)%current%next) ) THEN ! all leafs used -> define a new one + ALLOCATE( tree(ii)%current%next ) ! allocate the new leaf + tree(ii)%current%next%in_use = .FALSE. ! this leaf is not yet used + tree(ii)%current%next%indic = tree(ii)%current%indic + 1 ! number of this leaf + IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic + tree(ii)%current%next%prev => tree(ii)%current ! previous leaf of the new leaf is the current leaf + tree(ii)%current%next%next => NULL() ! next leaf is not yet defined + + tree(ii)%current => tree(ii)%current%next ! the current leaf becomes the new one + + ! allocate the array of the new leaf + IF( PRESENT(kwrk1d) ) ALLOCATE( tree(ii)%current%iwrk1d(isrt(1):iend(1) ) ) + IF( PRESENT(kwrk2d) ) ALLOCATE( tree(ii)%current%iwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) + IF( PRESENT(kwrk3d) ) ALLOCATE( tree(ii)%current%iwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) + IF( PRESENT(kwrk4d) ) ALLOCATE( tree(ii)%current%iwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) + IF( PRESENT(pwrk1d) ) ALLOCATE( tree(ii)%current%zwrk1d(isrt(1):iend(1) ) ) + IF( PRESENT(pwrk2d) ) ALLOCATE( tree(ii)%current%zwrk2d(isrt(1):iend(1),isrt(2):iend(2) ) ) + IF( PRESENT(pwrk3d) ) ALLOCATE( tree(ii)%current%zwrk3d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3) ) ) + IF( PRESENT(pwrk4d) ) ALLOCATE( tree(ii)%current%zwrk4d(isrt(1):iend(1),isrt(2):iend(2),isrt(3):iend(3),isrt(4):iend(4)) ) + + ELSE + tree(ii)%current => tree(ii)%current%next ! the current leaf becomes the next one + ENDIF + ! + ! use the array of the current leaf as a work array + IF( PRESENT(kwrk1d) ) kwrk1d => tree(ii)%current%iwrk1d + IF( PRESENT(kwrk2d) ) kwrk2d => tree(ii)%current%iwrk2d + IF( PRESENT(kwrk3d) ) kwrk3d => tree(ii)%current%iwrk3d + IF( PRESENT(kwrk4d) ) kwrk4d => tree(ii)%current%iwrk4d + IF( PRESENT(pwrk1d) ) pwrk1d => tree(ii)%current%zwrk1d + IF( PRESENT(pwrk2d) ) pwrk2d => tree(ii)%current%zwrk2d + IF( PRESENT(pwrk3d) ) pwrk3d => tree(ii)%current%zwrk3d + IF( PRESENT(pwrk4d) ) pwrk4d => tree(ii)%current%zwrk4d + tree(ii)%current%in_use = .TRUE. ! this leaf is now used + ! + END SUBROUTINE wrk_allocbase + + + SUBROUTINE wrk_deallocbase( ktype, kidim, kjdim, kkdim, kldim, kisrt, kjsrt, kksrt, klsrt ) + INTEGER, INTENT(in ) :: ktype + INTEGER, INTENT(in ) :: kidim, kjdim, kkdim, kldim + INTEGER, INTENT(in ), OPTIONAL :: kisrt, kjsrt, kksrt, klsrt + ! + INTEGER, DIMENSION(jpmaxdim) :: ishape, istart + INTEGER :: ii + + ishape(:) = (/ kidim, kjdim, kkdim, kldim /) + IF( PRESENT(kisrt) ) THEN ; istart(1) = kisrt ; ELSE ; istart(1) = 1 ; ENDIF + IF( PRESENT(kjsrt) ) THEN ; istart(2) = kjsrt ; ELSE ; istart(2) = 1 ; ENDIF + IF( PRESENT(kksrt) ) THEN ; istart(3) = kksrt ; ELSE ; istart(3) = 1 ; ENDIF + IF( PRESENT(klsrt) ) THEN ; istart(4) = klsrt ; ELSE ; istart(4) = 1 ; ENDIF + + ! find the branch with the matcing shape and type or get the first "free" branch + ii = 1 + DO WHILE( ANY( tree(ii)%ishape /= ishape ) .OR. ANY( tree(ii)%istart /= istart ) .OR. tree(ii)%itype /= ktype ) + ii = ii + 1 + END DO + ! + tree(ii)%current%in_use = .FALSE. ! current leaf is no more used + tree(ii)%current => tree(ii)%current%prev ! move back toward previous leaf + ! + END SUBROUTINE wrk_deallocbase + + + SUBROUTINE wrk_stop(cmsg) + !!---------------------------------------------------------------------- + !! *** ROUTINE wrk_stop *** + !! ** Purpose : to act as local alternative to ctl_stop. + !! Avoids dependency on in_out_manager module. + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in) :: cmsg + !!---------------------------------------------------------------------- + ! +! WRITE(kumout, cform_err2) + WRITE(*,*) TRIM(cmsg) + ! ARPDBG - would like to CALL mppstop here to force a stop but that + ! introduces a dependency on lib_mpp. Could CALL mpi_abort() directly + ! but that's fairly brutal. Better to rely on CALLing routine to + ! deal with the error passed back from the wrk_X routine? + !CALL mppstop + ! + END SUBROUTINE wrk_stop + + !!===================================================================== +END MODULE wrk_nemo diff --git a/V4.0/nemo_sources/tools/GRIDGEN/namelist_R05 b/V4.0/nemo_sources/tools/GRIDGEN/namelist_R05 new file mode 100644 index 0000000000000000000000000000000000000000..c3ebe0b7ceb78a47c5f7e364500e329275be3441 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/namelist_R05 @@ -0,0 +1,19 @@ +&input_output + ln_iom_activated = true +/ + +&coarse_grid_files + cn_parent_coordinate_file = 'coordinates_ORCA_R05.nc' + cn_position_pivot = 'F-grid' +/ + +&nesting + nn_imin = 0 + nn_imax = 1 + nn_jmin = 1 + nn_jmax = 1 + nn_rhox = 2 + nn_rhoy = 2 +/ + + diff --git a/V4.0/nemo_sources/tools/GRIDGEN/namelist_R2 b/V4.0/nemo_sources/tools/GRIDGEN/namelist_R2 new file mode 100644 index 0000000000000000000000000000000000000000..57a71fcef466d6363ee8f4ebd5a359dba9846d58 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/namelist_R2 @@ -0,0 +1,19 @@ +&input_output + ln_iom_activated = true +/ + +&coarse_grid_files + cn_parent_coordinate_file = 'coordinates_ORCA_R2.nc' + cn_position_pivot = 'T-grid' +/ + +&nesting + nn_imin = 49 + nn_imax = 52 + nn_jmin = 147 + nn_jmax = 147 + nn_rhox = 3 + nn_rhoy = 3 +/ + + diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/cfg_tools.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/cfg_tools.f90 new file mode 100644 index 0000000000000000000000000000000000000000..090be53cd672fa79f9a1c7522c17ae8a53a16868 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/cfg_tools.f90 @@ -0,0 +1,633 @@ +MODULE cfg_tools +!!----------------------------------------------------------- +!! +!! to make that we use a 4th order polynomial interpolation +!! +!! Created by Brice Lemaire on 12/2009. +!! +!!----------------------------------------------------------- + USE readwrite + USE projection + ! + IMPLICIT NONE + PUBLIC + ! + ! + ! + CONTAINS + !******************************************************** + ! SUBROUTINE interp_grid * + ! * + ! calculate polynomial interpolation at 4th order * + ! * + ! CALLED from create_coordinates.f90 * + !******************************************************** + SUBROUTINE interp_grid + ! + REAL*8, DIMENSION(:,:),ALLOCATABLE :: dlcoef !Array to store the coefficients of Lagrange + INTEGER :: ji, jj, jk, jproj + INTEGER :: istat, ip + LOGICAL :: llnorth_pole = .FALSE. + ! + WRITE(*,*) '' + WRITE(*,*) '### SUBROUTINE interp_grid ###' + WRITE(*,*) '' + ! + jproj = 0 + ! + ! Calculate coefficients for interpolation along longitude + ! + ALLOCATE(dlcoef(nn_rhox-1,4)) + istat = pol_coef(dlcoef,nn_rhox) + IF (istat/=1) THEN + WRITE(*,*) "ERROR WITH LAGRANGIAN COEFFICIENTS" + STOP + ENDIF + ! + WRITE(*,*) 'Interpolation along longitude' + ! + DO jj = nn_rhoy,nygmix,nn_rhoy + DO ji = nn_rhox,nxgmix,nn_rhox + ! + DO jk = 1,nn_rhox-1 + ! + ! First, we check the +-180 discontinuity. + ! In this case, we increase the negative values of 360. + IF(ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji+1*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji,jj).LT.0.) THEN + smixgrd%glam(ji,jj) = smixgrd%glam(ji,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji+1*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji+1*nn_rhox,jj).LT.0.) THEN + smixgrd%glam(ji+1*nn_rhox,jj) = smixgrd%glam(ji+1*nn_rhox,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji+1*nn_rhox,jj)-smixgrd%glam(ji+2*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji+1*nn_rhox,jj).LT.0.) THEN + smixgrd%glam(ji+1*nn_rhox,jj) = smixgrd%glam(ji+1*nn_rhox,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji+1*nn_rhox,jj)-smixgrd%glam(ji+2*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji+2*nn_rhox,jj).LT.0.) THEN + smixgrd%glam(ji+2*nn_rhox,jj) = smixgrd%glam(ji+2*nn_rhox,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji+2*nn_rhox,jj)-smixgrd%glam(ji+3*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji+2*nn_rhox,jj).LT.0.) THEN + smixgrd%glam(ji+2*nn_rhox,jj) = smixgrd%glam(ji+2*nn_rhox,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji+2*nn_rhox,jj)-smixgrd%glam(ji+3*nn_rhox,jj)).GT.180.0.AND.smixgrd%glam(ji+3*nn_rhox,jj).LT.0.) THEN + smixgrd%glam(ji+3*nn_rhox,jj) = smixgrd%glam(ji+3*nn_rhox,jj) + 360. + ENDIF + ! + ! If we are along north boundary, + ! the variation of longitude looks like a heaviside fonction at the geographical north pole. + ! Thus, we can't make an interpolation. + IF(ABS(smixgrd%glam(ji,jj) - smixgrd%glam(ji+3*nn_rhox,jj)).EQ.180.0)THEN + llnorth_pole = .TRUE. + ENDIF + ! + ! Nearby the geographical north pole, + ! the variation of the longitudes is too important. + ! We need to make a polar stereographic projection before interpolation. + !IF(.NOT.llnorth_pole.AND.ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji+3*nn_rhox,jj)).GE.80.0) THEN + IF(.NOT.llnorth_pole.AND.smixgrd%gphi(ji,jj).GE.88.) THEN + CALL stereo_projection(ji,jj,jk,llnorth_pole,1) + jproj = 1 + ENDIF + ! + smixgrd%glam(ji+nn_rhox+jk,jj) = dlcoef(jk,1) * smixgrd%glam(ji,jj) & + + dlcoef(jk,2) * smixgrd%glam(ji+1*nn_rhox,jj) & + + dlcoef(jk,3) * smixgrd%glam(ji+2*nn_rhox,jj) & + + dlcoef(jk,4) * smixgrd%glam(ji+3*nn_rhox,jj) + ! + smixgrd%gphi(ji+nn_rhox+jk,jj) = dlcoef(jk,1) * smixgrd%gphi(ji,jj) & + + dlcoef(jk,2) * smixgrd%gphi(ji+1*nn_rhox,jj) & + + dlcoef(jk,3) * smixgrd%gphi(ji+2*nn_rhox,jj) & + + dlcoef(jk,4) * smixgrd%gphi(ji+3*nn_rhox,jj) + ! + smixgrd%e1(ji+nn_rhox+jk,jj) = dlcoef(jk,1) * smixgrd%e1(ji,jj) & + + dlcoef(jk,2) * smixgrd%e1(ji+1*nn_rhox,jj) & + + dlcoef(jk,3) * smixgrd%e1(ji+2*nn_rhox,jj) & + + dlcoef(jk,4) * smixgrd%e1(ji+3*nn_rhox,jj) + ! + smixgrd%e2(ji+nn_rhox+jk,jj) = dlcoef(jk,1) * smixgrd%e2(ji,jj) & + + dlcoef(jk,2) * smixgrd%e2(ji+1*nn_rhox,jj) & + + dlcoef(jk,3) * smixgrd%e2(ji+2*nn_rhox,jj) & + + dlcoef(jk,4) * smixgrd%e2(ji+3*nn_rhox,jj) + ! + smixgrd%nav_lon(ji+nn_rhox+jk,jj) = smixgrd%glam(ji+nn_rhox+jk,jj) + smixgrd%nav_lat(ji+nn_rhox+jk,jj) = smixgrd%gphi(ji+nn_rhox+jk,jj) + ! + ! We make the polar stereographic projection reverse if needs. + IF(jproj.EQ.1)THEN + CALL stereo_projection_inv(ji,jj,jk,llnorth_pole,1) + ENDIF + ! + ! We replace the strong values along the north boundary. + IF(llnorth_pole)THEN + IF(smixgrd%glam(ji+1*nn_rhox,jj).EQ.smixgrd%glam(ji+2*nn_rhox,jj))THEN + smixgrd%glam(ji+nn_rhox+jk,jj) = smixgrd%glam(ji+1*nn_rhox,jj) + ELSEIF(ABS(smixgrd%glam(ji+1*nn_rhox,jj) - smixgrd%glam(ji+2*nn_rhox,jj)).EQ.180.0)THEN + IF(smixgrd%gphi(ji+1*nn_rhox,jj).LT.smixgrd%gphi(ji+2*nn_rhox,jj))THEN + smixgrd%glam(ji+nn_rhox+jk,jj) = smixgrd%glam(ji+1*nn_rhox,jj) + ELSEIF(smixgrd%gphi(ji+1*nn_rhox,jj).GT.smixgrd%gphi(ji+2*nn_rhox,jj))THEN + smixgrd%glam(ji+nn_rhox+jk,jj) = smixgrd%glam(ji+2*nn_rhox,jj) + ENDIF + ENDIF + ENDIF + ! + ip = 0 + jproj = 0 + llnorth_pole = .FALSE. + ! + END DO + END DO + END DO + ! + WHERE(smixgrd%glam.GT.180) + smixgrd%glam = smixgrd%glam - 360.0 + ENDWHERE + ! + DEALLOCATE(dlcoef) + ! + ! Calculate coefficients for interpolation along latitude + ! + ALLOCATE(dlcoef(nn_rhoy-1,4)) + istat = pol_coef(dlcoef,nn_rhoy) + IF (istat/=1) THEN + WRITE(*,*) "ERROR WITH LAGRANGIAN COEFFICIENTS" + STOP + ENDIF + ! + WRITE(*,*) 'Interpolation along latitude' + ! +print*, nequator + DO ji = 1,nxgmix,1 + ! + DO jj = nn_rhoy,nygmix,nn_rhoy + ! + DO jk = 1,nn_rhoy-1 + ! + IF(ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji,jj+1*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj).LT.0.) THEN + smixgrd%glam(ji,jj) = smixgrd%glam(ji,jj) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji,jj+1*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj+1*nn_rhoy).LT.0.) THEN + smixgrd%glam(ji,jj+1*nn_rhoy) = smixgrd%glam(ji,jj+1*nn_rhoy) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj+1*nn_rhoy)-smixgrd%glam(ji,jj+2*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj+1*nn_rhoy).LT.0.) THEN + smixgrd%glam(ji,jj+1*nn_rhoy) = smixgrd%glam(ji,jj+1*nn_rhoy) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj+1*nn_rhoy)-smixgrd%glam(ji,jj+2*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj+2*nn_rhoy).LT.0.) THEN + smixgrd%glam(ji,jj+2*nn_rhoy) = smixgrd%glam(ji,jj+2*nn_rhoy) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj+2*nn_rhoy)-smixgrd%glam(ji,jj+3*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj+2*nn_rhoy).LT.0.) THEN + smixgrd%glam(ji,jj+2*nn_rhoy) = smixgrd%glam(ji,jj+2*nn_rhoy) + 360. + ENDIF + ! + IF(ABS(smixgrd%glam(ji,jj+2*nn_rhoy)-smixgrd%glam(ji,jj+3*nn_rhoy)).GT.180.0.AND.smixgrd%glam(ji,jj+3*nn_rhoy).LT.0.) THEN + smixgrd%glam(ji,jj+3*nn_rhoy) = smixgrd%glam(ji,jj+3*nn_rhoy) + 360. + ENDIF + ! + !IF(.NOT.llnorth_pole.AND.ABS(smixgrd%glam(ji,jj)-smixgrd%glam(ji,jj+3*nn_rhoy)).GE.60.0) THEN + IF(.NOT.llnorth_pole.AND.smixgrd%gphi(ji,jj).GE.88.) THEN + CALL stereo_projection(ji,jj,jk,llnorth_pole,2) + jproj = 1 + ENDIF + ! + smixgrd%glam(ji,jj+nn_rhoy+jk) = dlcoef(jk,1) * smixgrd%glam(ji,jj) & + + dlcoef(jk,2) * smixgrd%glam(ji,jj+nn_rhoy) & + + dlcoef(jk,3) * smixgrd%glam(ji,jj+2*nn_rhoy) & + + dlcoef(jk,4) * smixgrd%glam(ji,jj+3*nn_rhoy) + ! + smixgrd%gphi(ji,jj+nn_rhoy+jk) = dlcoef(jk,1) * smixgrd%gphi(ji,jj) & + + dlcoef(jk,2) * smixgrd%gphi(ji,jj+nn_rhoy) & + + dlcoef(jk,3) * smixgrd%gphi(ji,jj+2*nn_rhoy) & + + dlcoef(jk,4) * smixgrd%gphi(ji,jj+3*nn_rhoy) + ! + smixgrd%e1(ji,jj+nn_rhoy+jk) = dlcoef(jk,1) * smixgrd%e1(ji,jj) & + + dlcoef(jk,2) * smixgrd%e1(ji,jj+nn_rhoy) & + + dlcoef(jk,3) * smixgrd%e1(ji,jj+2*nn_rhoy) & + + dlcoef(jk,4) * smixgrd%e1(ji,jj+3*nn_rhoy) + ! + smixgrd%e2(ji,jj+nn_rhoy+jk) = dlcoef(jk,1) * smixgrd%e2(ji,jj) & + + dlcoef(jk,2) * smixgrd%e2(ji,jj+nn_rhoy) & + + dlcoef(jk,3) * smixgrd%e2(ji,jj+2*nn_rhoy) & + + dlcoef(jk,4) * smixgrd%e2(ji,jj+3*nn_rhoy) + ! + smixgrd%nav_lon(ji,jj+nn_rhoy+jk) = smixgrd%glam(ji,jj+nn_rhoy+jk) + smixgrd%nav_lat(ji,jj+nn_rhoy+jk) = smixgrd%gphi(ji,jj+nn_rhoy+jk) + ! + IF(jproj.EQ.1)THEN + CALL stereo_projection_inv(ji,jj,jk,llnorth_pole,2) + ENDIF + ! + jproj = 0 + llnorth_pole = .FALSE. + ! + END DO + ! + IF(jj+3*nn_rhoy.EQ.nygmix) EXIT + ! + END DO + ! + END DO + ! + WHERE(smixgrd%glam.GT.180.) + smixgrd%glam = smixgrd%glam - 360.0 + ENDWHERE + ! + WRITE(*,*) '' + WRITE(*,*) '### END SUBROUTINE interp_grid ###' + WRITE(*,*) '' + ! + END SUBROUTINE + ! + ! + ! + !******************************************************** + ! FUNCTION pol_coef * + ! * + ! calculate the coefficients of Lagrange * + ! for the polynomial interpolation * + ! * + ! CALLED from SUBROUTINE interp * + !******************************************************** + REAL FUNCTION pol_coef(kvect,kxy) + ! + REAL*8, DIMENSION(:,:),ALLOCATABLE :: kvect + REAL*8, DIMENSION(3) :: dlv + INTEGER :: ji, jm, jk + REAL*8 :: dlx0 !position relative du point calculer + INTEGER :: jx_k, jx_i !position relative des points utiliss pour l'interpolation + REAL*8 :: dleps + INTEGER :: kxy, irho + ! + !on parle de position relative puisque nous utilisons les positions + !indiciaires, lesquelles sont rptes dans toute la grille. + !Il n'est donc ncessaire de calculer qu'une fois les 4 coefficients + !qui seront utiliss dans toute la grille en fonction de nn_rho + ! + WRITE(*,*) '' + WRITE(*,*) '*** FUNCTION pol_coef ***' + WRITE(*,*) '' + ! + jm=1 + dleps = 1.-1e-8 + ! + irho = kxy + ! + DO jk = 1,irho-1 + dlx0 = irho+1+jk + ji=1 + DO jx_i = 1,4+3*(irho-1),irho + jm=1 + DO jx_k=1,4+3*(irho-1),irho + IF(jx_k == jx_i) THEN + CYCLE + ELSE + dlv(jm) = (dlx0-jx_k) / (jx_i-jx_k) + jm = jm + 1 + END IF + END DO + kvect(jk,ji) = product(dlv) + ji = ji + 1 + END DO + END DO + ! + IF(SUM(kvect).LT.dleps .OR. SUM(kvect).GT.dleps) THEN + WRITE(*,*) '' + WRITE(*,*) '*** CHECK LAGRANGE COEFFICIENTS: ***' + WRITE(*,*) '' + ! + DO ji=1,irho-1 + WRITE(*,*)'point #',ji + WRITE(*,*) 'dlcoef(:)= ', kvect(ji,:) + WRITE(*,*) 'SUM(dlcoef(:)) =', SUM(kvect(ji,:)) + WRITE(*,*)'' + END DO + pol_coef = 1 + ELSE + ! + pol_coef = 0 + ENDIF + ! + END FUNCTION pol_coef + ! + ! + ! + !******************************************************** + ! SUBROUTINE child_grid * + ! * + ! create the child grids from mixed grid * + ! * + ! CALLED from create_coordinates.f90 * + !******************************************************** + SUBROUTINE child_grid + ! + INTEGER :: ji, jj + INTEGER :: ip, iq + REAL*8, DIMENSION(2) :: dlgrdt, dlgrdu, dlgrdv, dlgrdf + REAL*8 :: dleps + ! + WRITE(*,*) '' + WRITE(*,*) '### SUBROUTINE child_grid ###' + WRITE(*,*) '' + ! + IF(.NOT.nglobal.AND.(nn_rhox.GT.1.OR.nn_rhoy.GT.1)) THEN + iq=1 + DO jj = (2*nn_rhoy)+1-nequator,(nygmix-(2*nn_rhoy-1)-nequator),2 + ip=1 + DO ji = (2*nn_rhox)+1,(nxgmix-(2*nn_rhox-1)),2 + ! + sfingrd%nav_lon(ip,iq) = smixgrd%nav_lon(ji,jj) + sfingrd%nav_lat(ip,iq) = smixgrd%nav_lat(ji,jj) + ! + sfingrd%glamt(ip,iq) = smixgrd%glam(ji,jj) + sfingrd%glamu(ip,iq) = smixgrd%glam(ji+1,jj) + sfingrd%glamv(ip,iq) = smixgrd%glam(ji,jj+1) + sfingrd%glamf(ip,iq) = smixgrd%glam(ji+1,jj+1) + ! + sfingrd%gphit(ip,iq) = smixgrd%gphi(ji,jj) + sfingrd%gphiu(ip,iq) = smixgrd%gphi(ji+1,jj) + sfingrd%gphiv(ip,iq) = smixgrd%gphi(ji,jj+1) + sfingrd%gphif(ip,iq) = smixgrd%gphi(ji+1,jj+1) + ! + sfingrd%e1t(ip,iq) = smixgrd%e1(ji,jj) + sfingrd%e1u(ip,iq) = smixgrd%e1(ji+1,jj) + sfingrd%e1v(ip,iq) = smixgrd%e1(ji,jj+1) + sfingrd%e1f(ip,iq) = smixgrd%e1(ji+1,jj+1) + ! + sfingrd%e2t(ip,iq) = smixgrd%e2(ji,jj) + sfingrd%e2u(ip,iq) = smixgrd%e2(ji+1,jj) + sfingrd%e2v(ip,iq) = smixgrd%e2(ji,jj+1) + sfingrd%e2f(ip,iq) = smixgrd%e2(ji+1,jj+1) + ! + ip=ip+1 + ENDDO + iq=iq+1 + ENDDO + ! + ELSEIF(nglobal.AND.(nn_rhox.GT.1.OR.nn_rhoy.GT.1))THEN + iq=1 + DO jj = (2*nn_rhoy)+1-nequator,nygmix,2 + ip=1 + DO ji = (2*nn_rhox)-1,nxgmix,2 + ! + sfingrd%nav_lon(ip,iq) = smixgrd%nav_lon(ji,jj) + sfingrd%nav_lat(ip,iq) = smixgrd%nav_lat(ji,jj) + ! + sfingrd%glamt(ip,iq) = smixgrd%glam(ji,jj) + sfingrd%glamu(ip,iq) = smixgrd%glam(ji+1,jj) + sfingrd%glamv(ip,iq) = smixgrd%glam(ji,jj+1) + sfingrd%glamf(ip,iq) = smixgrd%glam(ji+1,jj+1) + ! + sfingrd%gphit(ip,iq) = smixgrd%gphi(ji,jj) + sfingrd%gphiu(ip,iq) = smixgrd%gphi(ji+1,jj) + sfingrd%gphiv(ip,iq) = smixgrd%gphi(ji,jj+1) + sfingrd%gphif(ip,iq) = smixgrd%gphi(ji+1,jj+1) + ! + sfingrd%e1t(ip,iq) = smixgrd%e1(ji,jj) + sfingrd%e1u(ip,iq) = smixgrd%e1(ji+1,jj) + sfingrd%e1v(ip,iq) = smixgrd%e1(ji,jj+1) + sfingrd%e1f(ip,iq) = smixgrd%e1(ji+1,jj+1) + ! + sfingrd%e2t(ip,iq) = smixgrd%e2(ji,jj) + sfingrd%e2u(ip,iq) = smixgrd%e2(ji+1,jj) + sfingrd%e2v(ip,iq) = smixgrd%e2(ji,jj+1) + sfingrd%e2f(ip,iq) = smixgrd%e2(ji+1,jj+1) + ! + IF(ip.EQ.nxfine) EXIT + ! + ip=ip+1 + ! + ENDDO + ! + IF(iq.EQ.nyfine) EXIT + ! + iq=iq+1 + ! + ENDDO + ! + ELSE !No interpolation + iq=1 + DO jj = 1,nygmix-1,2 + ip=1 + DO ji = 1,nxgmix-1,2 + ! + sfingrd%nav_lon(ip,iq) = smixgrd%nav_lon(ji,jj) + sfingrd%nav_lat(ip,iq) = smixgrd%nav_lat(ji,jj) + ! + sfingrd%glamt(ip,iq) = smixgrd%glam(ji,jj) + sfingrd%glamu(ip,iq) = smixgrd%glam(ji+1,jj) + sfingrd%glamv(ip,iq) = smixgrd%glam(ji,jj+1) + sfingrd%glamf(ip,iq) = smixgrd%glam(ji+1,jj+1) + ! + sfingrd%gphit(ip,iq) = smixgrd%gphi(ji,jj) + sfingrd%gphiu(ip,iq) = smixgrd%gphi(ji+1,jj) + sfingrd%gphiv(ip,iq) = smixgrd%gphi(ji,jj+1) + sfingrd%gphif(ip,iq) = smixgrd%gphi(ji+1,jj+1) + ! + sfingrd%e1t(ip,iq) = smixgrd%e1(ji,jj) + sfingrd%e1u(ip,iq) = smixgrd%e1(ji+1,jj) + sfingrd%e1v(ip,iq) = smixgrd%e1(ji,jj+1) + sfingrd%e1f(ip,iq) = smixgrd%e1(ji+1,jj+1) + ! + sfingrd%e2t(ip,iq) = smixgrd%e2(ji,jj) + sfingrd%e2u(ip,iq) = smixgrd%e2(ji+1,jj) + sfingrd%e2v(ip,iq) = smixgrd%e2(ji,jj+1) + sfingrd%e2f(ip,iq) = smixgrd%e2(ji+1,jj+1) + ! + ip=ip+1 + END DO + iq=iq+1 + END DO + ! + ENDIF + ! + ! With a global domain, we check the overlap bands for have + ! * Grid(1,:) = Grid(n-1,:) + ! * Grid(2,:) = Grid(n,:) + ! because after interpolation the first column have no values + IF(nglobal.AND.nn_rhox.GT.1)THEN + ! + sfingrd%nav_lon(1,:) = sfingrd%nav_lon(nxfine-1,:) + sfingrd%nav_lat(1,:) = sfingrd%nav_lat(nxfine-1,:) + ! + sfingrd%glamt(1,:) = sfingrd%glamt(nxfine-1,:) + sfingrd%glamu(1,:) = sfingrd%glamu(nxfine-1,:) + sfingrd%glamv(1,:) = sfingrd%glamv(nxfine-1,:) + sfingrd%glamf(1,:) = sfingrd%glamf(nxfine-1,:) + ! + sfingrd%gphit(1,:) = sfingrd%gphit(nxfine-1,:) + sfingrd%gphiu(1,:) = sfingrd%gphiu(nxfine-1,:) + sfingrd%gphiv(1,:) = sfingrd%gphiv(nxfine-1,:) + sfingrd%gphif(1,:) = sfingrd%gphif(nxfine-1,:) + ! + sfingrd%e1t(1,:) = sfingrd%e1t(nxfine-1,:) + sfingrd%e1u(1,:) = sfingrd%e1u(nxfine-1,:) + sfingrd%e1v(1,:) = sfingrd%e1v(nxfine-1,:) + sfingrd%e1f(1,:) = sfingrd%e1f(nxfine-1,:) + ! + sfingrd%e2t(1,:) = sfingrd%e2t(nxfine-1,:) + sfingrd%e2u(1,:) = sfingrd%e2u(nxfine-1,:) + sfingrd%e2v(1,:) = sfingrd%e2v(nxfine-1,:) + sfingrd%e2f(1,:) = sfingrd%e2f(nxfine-1,:) + ! + WRITE(*,*) '' + WRITE(*,*) 'WE CHECK THE OVERLAP BANDS FOR EACH FINE GRID (T,U,V & F):' + WRITE(*,*) ' ==> SUM{ grd(1,:) + grd(2,:) } - SUM{ grd(n-1) + grd(n,:) } = 0' + ! + dleps = 1e-2 + ! + WRITE(*,*) '* grid T:' + dlgrdt(1) = SUM(sfingrd%glamt(1,:)) + SUM(sfingrd%glamt(2,:)) + dlgrdt(1) = dlgrdt(1) + SUM(sfingrd%gphit(1,:)) + SUM(sfingrd%gphit(2,:)) + dlgrdt(1) = dlgrdt(1) + SUM(sfingrd%e1t(1,:)) + SUM(sfingrd%e1t(2,:)) + dlgrdt(1) = dlgrdt(1) + SUM(sfingrd%e2t(1,:)) + SUM(sfingrd%e2t(2,:)) + ! + dlgrdt(2) = SUM(sfingrd%glamt(nxfine-1,:)) + SUM(sfingrd%glamt(nxfine,:)) + dlgrdt(2) = dlgrdt(2) + SUM(sfingrd%gphit(nxfine-1,:)) + SUM(sfingrd%gphit(nxfine,:)) + dlgrdt(2) = dlgrdt(2) + SUM(sfingrd%e1t(nxfine-1,:)) + SUM(sfingrd%e1t(nxfine,:)) + dlgrdt(2) = dlgrdt(2) + SUM(sfingrd%e2t(nxfine-1,:)) + SUM(sfingrd%e2t(nxfine,:)) + ! + IF((dlgrdt(1)-dlgrdt(2)).GT.dleps.OR.(dlgrdt(1)+dlgrdt(2)).LT.dleps) THEN + WRITE(*,*) ' ERROR' + print*,(dlgrdt(1)-dlgrdt(2)), (dlgrdt(1)+dlgrdt(2)) + ELSE + WRITE(*,*) 'OVERLAP BANDS OK' + ENDIF + ! + WRITE(*,*) '* grid U:' + dlgrdu(1) = SUM(sfingrd%glamu(1,:)) + SUM(sfingrd%glamu(2,:)) + dlgrdu(1) = dlgrdu(1) + SUM(sfingrd%gphiu(1,:)) + SUM(sfingrd%gphiu(2,:)) + dlgrdu(1) = dlgrdu(1) + SUM(sfingrd%e1u(1,:)) + SUM(sfingrd%e1u(2,:)) + dlgrdu(1) = dlgrdu(1) + SUM(sfingrd%e2u(1,:)) + SUM(sfingrd%e2u(2,:)) + ! + dlgrdu(2) = SUM(sfingrd%glamu(nxfine-1,:)) + SUM(sfingrd%glamu(nxfine,:)) + dlgrdu(2) = dlgrdu(2) + SUM(sfingrd%gphiu(nxfine-1,:)) + SUM(sfingrd%gphiu(nxfine,:)) + dlgrdu(2) = dlgrdu(2) + SUM(sfingrd%e1u(nxfine-1,:)) + SUM(sfingrd%e1u(nxfine,:)) + dlgrdu(2) = dlgrdu(2) + SUM(sfingrd%e2u(nxfine-1,:)) + SUM(sfingrd%e2u(nxfine,:)) + ! + IF((dlgrdu(1)-dlgrdu(2)).GT.dleps.OR.(dlgrdu(1)+dlgrdu(2)).LT.dleps) THEN + WRITE(*,*) ' ERROR' + print*,(dlgrdu(1)-dlgrdu(2)), (dlgrdu(1)+dlgrdu(2)) + ELSE + WRITE(*,*) 'OVERLAP BANDS OK' + ENDIF + ! + WRITE(*,*) '* grid V:' + dlgrdv(1) = SUM(sfingrd%glamv(1,:)) + SUM(sfingrd%glamv(2,:)) + dlgrdv(1) = dlgrdv(1) + SUM(sfingrd%gphiv(1,:)) + SUM(sfingrd%gphiv(2,:)) + dlgrdv(1) = dlgrdv(1) + SUM(sfingrd%e1v(1,:)) + SUM(sfingrd%e1v(2,:)) + dlgrdv(1) = dlgrdv(1) + SUM(sfingrd%e2v(1,:)) + SUM(sfingrd%e2v(2,:)) + ! + dlgrdv(2) = SUM(sfingrd%glamv(nxfine-1,:)) + SUM(sfingrd%glamv(nxfine,:)) + dlgrdv(2) = dlgrdv(2) + SUM(sfingrd%gphiv(nxfine-1,:)) + SUM(sfingrd%gphiv(nxfine,:)) + dlgrdv(2) = dlgrdv(2) + SUM(sfingrd%e1v(nxfine-1,:)) + SUM(sfingrd%e1v(nxfine,:)) + dlgrdv(2) = dlgrdv(2) + SUM(sfingrd%e2v(nxfine-1,:)) + SUM(sfingrd%e2v(nxfine,:)) + ! + IF((dlgrdv(1)-dlgrdv(2)).GT.dleps.OR.(dlgrdv(1)+dlgrdv(2)).LT.dleps) THEN + WRITE(*,*) ' ERROR' + print*,(dlgrdv(1)-dlgrdv(2)), (dlgrdv(1)+dlgrdv(2)) + ELSE + WRITE(*,*) 'OVERLAP BANDS OK' + ENDIF + ! + WRITE(*,*) '* grid F:' + dlgrdf(1) = SUM(sfingrd%glamf(1,:)) + SUM(sfingrd%glamf(2,:)) + dlgrdf(1) = dlgrdf(1) + SUM(sfingrd%gphif(1,:)) + SUM(sfingrd%gphif(2,:)) + dlgrdf(1) = dlgrdf(1) + SUM(sfingrd%e1f(1,:)) + SUM(sfingrd%e1f(2,:)) + dlgrdf(1) = dlgrdf(1) + SUM(sfingrd%e2f(1,:)) + SUM(sfingrd%e2f(2,:)) + ! + dlgrdf(2) = SUM(sfingrd%glamf(nxfine-1,:)) + SUM(sfingrd%glamf(nxfine,:)) + dlgrdf(2) = dlgrdf(2) + SUM(sfingrd%gphif(nxfine-1,:)) + SUM(sfingrd%gphif(nxfine,:)) + dlgrdf(2) = dlgrdf(2) + SUM(sfingrd%e1f(nxfine-1,:)) + SUM(sfingrd%e1f(nxfine,:)) + dlgrdf(2) = dlgrdf(2) + SUM(sfingrd%e2f(nxfine-1,:)) + SUM(sfingrd%e2f(nxfine,:)) + ! + IF((dlgrdf(1)-dlgrdf(2)).GT.dleps.OR.(dlgrdf(1)+dlgrdf(2)).LT.dleps) THEN + WRITE(*,*) ' ERROR' + print*, (dlgrdf(1)-dlgrdf(2)), (dlgrdf(1)+dlgrdf(2)) + ELSE + WRITE(*,*) 'OVERLAP BANDS OK' + ENDIF + ! + WRITE(*,*) '' + WRITE(*,*) ' grid T' + WRITE(*,*) 'i= ',' 1 ',' 2 ',' 3 ' + WRITE(*,*) sfingrd%glamt(1:3,1) + WRITE(*,*) sfingrd%gphit(1:3,1) + WRITE(*,*) 'i= ',' n-2 ',' n-1 ',' n ' + WRITE(*,*) sfingrd%glamt(nxfine-2:nxfine,1) + WRITE(*,*) sfingrd%gphit(nxfine-2:nxfine,1) + WRITE(*,*) '' + WRITE(*,*) ' grid U' + WRITE(*,*) 'i= ',' 1 ',' 2 ',' 3 ' + WRITE(*,*) sfingrd%glamu(1:3,1) + WRITE(*,*) sfingrd%gphiu(1:3,1) + WRITE(*,*) 'i= ',' n-2 ',' n-1 ',' n ' + WRITE(*,*) sfingrd%glamu(nxfine-2:nxfine,1) + WRITE(*,*) sfingrd%gphiu(nxfine-2:nxfine,1) + WRITE(*,*) '' + WRITE(*,*) ' grid V' + WRITE(*,*) 'i= ',' 1 ',' 2 ',' 3 ' + WRITE(*,*) sfingrd%glamv(1:3,1) + WRITE(*,*) sfingrd%gphiv(1:3,1) + WRITE(*,*) 'i= ',' n-2 ',' n-1 ',' n ' + WRITE(*,*) sfingrd%glamv(nxfine-2:nxfine,1) + WRITE(*,*) sfingrd%gphiv(nxfine-2:nxfine,1) + WRITE(*,*) '' + WRITE(*,*) ' grid F' + WRITE(*,*) 'i= ',' 1 ',' 2 ',' 3 ' + WRITE(*,*) sfingrd%glamf(1:3,1) + WRITE(*,*) sfingrd%gphif(1:3,1) + WRITE(*,*) 'i= ',' n-2 ',' n-1 ',' n ' + WRITE(*,*) sfingrd%glamf(nxfine-2:nxfine,1) + WRITE(*,*) sfingrd%gphif(nxfine-2:nxfine,1) + WRITE(*,*) '' + ENDIF + ! + IF(nglobal.AND.nequator.EQ.1) THEN + ! *** GRID U + jj = 1 + DO ji = nxfine/2 + nn_rhox,nxfine,2 + sfingrd%glamu(ji,nyfine-1) = sfingrd%glamu(nxfine/2+1 - jj,nyfine-1) + sfingrd%gphiu(ji,nyfine-1) = sfingrd%gphiu(nxfine/2+1 - jj,nyfine-1) + jj = jj+2 + ENDDO + ! + jj = 0 + DO ji = 2,nxfine + sfingrd%glamu(ji,nyfine) = sfingrd%glamu(nxfine - jj,nyfine-2) + sfingrd%gphiu(ji,nyfine) = sfingrd%gphiu(nxfine - jj,nyfine-2) + jj = jj+1 + ENDDO + ! + ! *** GRID T + jj = 0 + DO ji = nxfine/2 + nn_rhox,nxfine + sfingrd%glamt(ji,nyfine-1) = sfingrd%glamt(nxfine/2+1 - jj,nyfine-1) + sfingrd%gphit(ji,nyfine-1) = sfingrd%gphit(nxfine/2+1 - jj,nyfine-1) + jj = jj+1 + ENDDO + ! + jj = 0 + DO ji = 3,nxfine + sfingrd%glamt(ji,nyfine) = sfingrd%glamt(nxfine - jj,nyfine-2) + sfingrd%gphit(ji,nyfine) = sfingrd%gphit(nxfine - jj,nyfine-2) + jj = jj+1 + ENDDO + ENDIF + ! + WRITE(*,*) '' + WRITE(*,*) '### END SUBROUTINE child_grid ###' + WRITE(*,*) '' + ! + END SUBROUTINE child_grid + ! + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +END MODULE cfg_tools diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/create_coordinates.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/create_coordinates.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bee99c245266f840f203b0a89b6481216ee62af3 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/create_coordinates.f90 @@ -0,0 +1,250 @@ +PROGRAM create_coordinates +!!----------------------------------------------------------- +!! +!! to create regional coordinates file (e.g. 1_coordinates.nc) +!! for fine grid from coarse grid (e.g. coordinates.nc) +!! +!! to make it we use a 4th order polynomial interpolation +!! +!! Created by Brice Lemaire on 12/2009. +!! +!!----------------------------------------------------------- + USE netcdf + USE cfg_tools + USE mixed_grid + USE domain + !------------ + IMPLICIT NONE + ! + INTEGER :: narg,iargc + INTEGER :: nstat, imodulo + INTEGER :: nik, njk, npk + INTEGER :: ival + CHARACTER(len=80) :: cnmlname, cfingrdname + ! + ! + ! + !************************************* + ! Read input file (namelist file) + ! using types.f90 + !************************************* + narg = iargc() + ! + IF (narg == 0) THEN + cnmlname = 'namelist.input' + ELSE + CALL getarg(1,cnmlname) + ENDIF + ! + CALL read_namelist(cnmlname) + ! + nstat = read_coordinates(TRIM(cn_parent_coordinate_file),scoagrd) + IF (nstat/=1) THEN + WRITE(*,*) 'unable to open netcdf file : ',cn_parent_coordinate_file + STOP + ENDIF + ! + nsizex = SIZE(scoagrd%glamt,1) + nsizey = SIZE(scoagrd%glamt,2) + ! + WRITE(*,*) '' + WRITE(*,*) 'Size of input matrix: ' + WRITE(*,*) '(',nsizex,';', nsizey,')' + WRITE(*,*) '' + ! + WRITE(*,*) 'Domain: ' + WRITE(*,*) '' + WRITE(*,*) ' ', ' min(1,1:nsizey) ', ' max(nsizex,1:nsizey) ' + WRITE(*,*) 'longitude: ', MINVAL(scoagrd%glamt(1,1:nsizey)), ' --> ', MAXVAL(scoagrd%glamf(nsizex,1:nsizey)) + WRITE(*,*) 'latitude: ', MINVAL(scoagrd%gphit(1:nsizex,1)), ' --> ', MAXVAL(scoagrd%gphif(1:nsizex,nsizey)) + WRITE(*,*) '' + ! + !************************************* + ! Check the values read in the namelist + !************************************* + IF(nn_imin.LE.0.OR.nn_imin.GT.nsizex)THEN + WRITE(*,*) 'Wrong values in namelist:' + WRITE(*,*) 'nn_imin must be greater than 0 and less than', nsizex + STOP + ENDIF + ! + IF(nn_imax.LE.0.OR.nn_imax.GT.nsizex)THEN + WRITE(*,*) 'Wrong values in namelist:' + WRITE(*,*) 'nn_imax must be greater than 0 and less than', nsizex + STOP + ENDIF + ! + IF(nn_jmin.LE.0.OR.nn_jmin.GT.nsizey)THEN + WRITE(*,*) 'Wrong values in namelist:' + WRITE(*,*) 'nn_jmin must be greater than 0 and less than', nsizey + STOP + ENDIF + ! + IF(nn_jmax.LE.0.OR.nn_jmax.GT.nsizey)THEN + WRITE(*,*) 'Wrong values in namelist:' + WRITE(*,*) 'nn_jmax must be greater than 0 and less than', nsizey + STOP + ENDIF + ! + !************************************* + ! Define the sub-domain chosen by user + !************************************* + WRITE(*,*) 'Domain defined by user: ' + WRITE(*,*) '' + WRITE(*,*) ' ', ' min ', ' max ' + WRITE(*,*) 'longitude: ', MINVAL(scoagrd%glamt(nn_imin,nn_jmin:nn_jmax)), ' --> ', MAXVAL(scoagrd%glamf(nn_imax,nn_jmin:nn_jmax)) + WRITE(*,*) 'latitude: ', MINVAL(scoagrd%gphit(nn_imin:nn_imax,nn_jmin)), ' --> ', MAXVAL(scoagrd%gphif(nn_imin:nn_imax,nn_jmax)) + WRITE(*,*) '' + ! + IF(nn_imin.EQ.nn_imax.AND.nn_jmin.EQ.nn_jmax) THEN + nglobal = .TRUE. + WRITE(*,*) 'Size of domain: GLOBAL' + ELSE + nglobal = .FALSE. + WRITE(*,*) 'Size of domain: REGIONAL' + ENDIF + ! + IF(cn_position_pivot.EQ.'F-grid') THEN !case of ORCA05 & ORCA025 grids + npivot = 0 + ELSEIF(cn_position_pivot.EQ.'T-grid') THEN !case of ORCA2 grid + npivot = 1 + ENDIF + ! + nmid = nsizex/2 + npivot + ! + ! + ! + !************************************* + ! Redefine for particular cases + !************************************* + IF(((nn_imax - nn_imin).EQ.-1).OR.((nn_imax - nn_imin).EQ.-2)) THEN + nn_imax = nn_imin + ELSEIF(ABS(nn_imin - nn_imax).GE.nsizex-1) THEN + nn_imax = nn_imin + ELSEIF((nn_imin.EQ.1).AND.(nn_imax.EQ.nsizex)) THEN + nn_imax = nn_imin + ELSEIF(nn_imin.EQ.1.AND.nn_imax.GT.nn_imin) THEN + nn_imin = nsizey-2 + ELSEIF(nn_imax.EQ.nsizex) THEN + nn_imax = 3 + ELSEIF(nn_imin.EQ.nsizex) THEN + nn_imin = nsizex-1 + ELSEIF(nn_imax.EQ.1.AND.nn_imax.NE.nn_imin) THEN + nn_imax = 2 + ENDIF + ! + ! + ! + !************************************* + ! We want to fix equator along T and U-points + !************************************* + imodulo = MOD(nn_rhoy,2) + ! + IF(.NOT.nglobal.AND.(scoagrd%gphit(nn_imin,nn_jmin)*scoagrd%gphit(nn_imin,nn_jmax)).LT.0.AND.imodulo.EQ.0) THEN + nequator = 1 + ELSEIF(nglobal.AND.imodulo.EQ.0) THEN + nequator = 1 + ELSE + nequator = 0 + ENDIF + ! + ! + ! + !************************************* + ! CREATE MIXED GRID + !************************************* + CALL define_domain + ! + CALL define_mixed_grid + ! + ! + ! + !************************************* + !!! CALCULATE FINE GRID DIMENSIONS + !************************************* + IF(.NOT.nglobal) THEN + IF(nn_rhox.EQ.1) THEN + nxfine = nxcoag + ELSE + nxfine = (nxcoag-2)*nn_rhox + 1 + ENDIF + ! + IF(nn_rhoy.EQ.1) THEN + nyfine = nycoag + ELSE + nyfine = (nycoag-2)*nn_rhoy + 1 + ENDIF + ! + ELSEIF(nglobal) THEN + IF(nn_rhox.GT.1) THEN + nxfine = (nxgmix - 4*(nn_rhox-1))/2 + ELSEIF(nn_rhox.EQ.1) THEN + nxfine = nsizex + ENDIF + ! + IF(nn_rhoy.GT.1) THEN + nyfine = (nygmix - (2*nn_rhoy))/2 - nn_rhoy + nequator + ELSEIF(nn_rhoy.EQ.1) THEN + nyfine = nsizey + ENDIF + ! + ENDIF + ! + WRITE(*,*) '' + WRITE(*,*) '*** SIZE OF FINE GRID ***' + WRITE(*,*) nxfine, ' x ', nyfine + WRITE(*,*) '' + ! + ! + ! + !************************************* + ! Interpolation inside the mixed grid + ! from cfg_tools.f90 + !************************************* + IF(nn_rhox.GT.1.OR.nn_rhoy.GT.1) THEN + CALL interp_grid + ENDIF + ! + ! + ! + !************************************* + ! Define name of child coordinate file + ! coordinates.nc -> 1_coordinates.nc + !************************************* + CALL set_child_name(cn_parent_coordinate_file,cfingrdname) + ! + ! + ! + !************************************* + ! Allocation of child grid elements + ! from types.f90 + !************************************* + CALL grid_allocate(sfingrd,nxfine,nyfine) + ! + ! + ! + !************************************* + ! Break the mixed grid smixgrd into 4 grids + ! from cfg_tools.f90 + !************************************* + CALL child_grid + ! + ! + ! + !************************************* + ! Read parent coordinate file + ! from readwrite.f90 + !************************************* + nstat = write_coordinates(cfingrdname,sfingrd,nxfine,nyfine) + IF (nstat/=1) THEN + WRITE(*,*)"unable to write netcdf file : ",cfingrdname + STOP + ENDIF + ! + CALL grid_deallocate(scoagrd) + CALL grid_deallocate(sfingrd) + CALL mixed_grid_deallocate(smixgrd) + ! + ! + ! +END PROGRAM create_coordinates \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/domain.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/domain.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4245ea74a58e291729b651a60a73a84d82475687 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/domain.f90 @@ -0,0 +1,172 @@ +MODULE domain +!!----------------------------------------------------------- +!! +!! module to define domain to extract +!! from initial grid +!! +!! Created by Brice Lemaire on 01/2010. +!! +!!----------------------------------------------------------- + USE readwrite + USE mixed_grid + ! + IMPLICIT NONE + PUBLIC + ! + CONTAINS + !******************************************************** + ! SUBROUTINE define_domain * + ! * + ! to define the domain of the coarse grid * + ! which will be used * + ! * + ! CALLED from create_coordinates * + !******************************************************** + SUBROUTINE define_domain + ! + WRITE(*,*) '' + WRITE(*,*) ' ### SUBROUTINE define_domain ### ' + WRITE(*,*) '' + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! *** without northern boundary *** + IF((nn_jmax.LT.(nsizey-1)).AND.(nn_jmax.GT.nn_jmin)) THEN + ! + WRITE(*,*) ' ****************************** ' + WRITE(*,*) ' *** WITHOUT NORTH BOUNDARY *** ' + WRITE(*,*) ' ****************************** ' + ! + ! *** with left/right boundary *** + IF(nn_imin.GT.nn_imax) THEN + nxcoag = (nsizex - (nn_imin-1) + 1) + ((nn_imax+1) - 2) + ! *** all around the earth *** + ELSEIF(nn_imin.EQ.nn_imax) THEN + nxcoag = nsizex + ELSE + nxcoag = (nn_imax+1) - (nn_imin-1) + 1 + ENDIF + ! + !(+/-1) we need ghost cells to make interpolation + nycoag = (nn_jmax+1) - (nn_jmin-1) + 1 + ! + ENDIF + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! *** along northern boundary *** + IF((nn_jmax.LE.nn_jmin).OR.(nn_jmax.GE.nsizey-1)) THEN + ! + WRITE(*,*) ' **************************** ' + WRITE(*,*) ' *** ALONG NORTH BOUNDARY *** ' + WRITE(*,*) ' **************************** ' + ! + ! *** with left/right boundary *** + IF(nn_imin.GT.nn_imax) THEN + ! + WRITE(*,*) '' + WRITE(*,*) ' ** asian bipole ** ' + WRITE(*,*) '' + ! + nval1 = nsizex - nn_imin + 1 + nval2 = nn_imax + nn_jmin = nn_jmax + ! + ! *** to respect symmetry around asian bipole *** + IF((nval1.LT.nval2).AND.(nval2.LT.nmid)) THEN + ! + nn_imin = nsizex - nval2 + 1 + nxcoag = nval2 + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 + ! + ELSEIF((nval1.GE.nval2).AND.(nval1.LT.nmid)) THEN + ! + nn_imax = nval1 + nxcoag = nval1 + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 + ! + ! *** all around the earth *** + ELSE + ! + nn_imax = nn_imin + ! + ENDIF + ENDIF + ! + IF(nn_imin.LT.nn_imax) THEN + ! + ! *** without bipole *** + IF(((nn_imin.LT.nmid).AND.(nn_imax.LT.nmid)).OR.((nn_imin.GT.nmid).AND.(nn_imax.GT.nmid))) THEN + ! + WRITE(*,*) '' + WRITE(*,*) ' ** without bipole ** ' + WRITE(*,*) '' + ! + nxcoag = (nn_imax+1) - (nn_imin-1) + 1 + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 -0 + ! + ! *** including canada bipole *** + ELSEIF((nn_imin.LE.nmid).AND.(nn_imax.GE.nmid)) THEN + ! + WRITE(*,*) '' + WRITE(*,*) ' ** canadian bipole ** ' + WRITE(*,*) '' + ! + nn_jmin = nn_jmax + nval1 = nmid - nn_imin + nval2 = nn_imax - (nmid-1) + ! + ! *** to respect around canada bipole *** + IF(nval1.LT.nval2) THEN + ! + nn_imin = nmid - nval2 + nxcoag = (nval2+1) + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 - (2*npivot) + ! + ELSEIF(nval1.GE.nval2) THEN + ! + nn_imax = nmid + nval1 + nxcoag = (nval1+1) + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 - (2*npivot) + ! + ENDIF + ENDIF + ENDIF + ENDIF + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + IF(nglobal) THEN !Global + ! Don't change the global shape of the matrix + WRITE(*,*) '' + WRITE(*,*) ' ** global ** ' + WRITE(*,*) '' + ! + nn_imin = 1 + nn_imax = nsizex + nn_jmin = 1 + nn_jmax = nsizey + nxcoag = nsizex + nycoag = nsizey + ! + ELSEIF(nn_imin.EQ.nn_imax) THEN !Semi-global (e.g northern hemisphere) + ! Change the global shape -> suppression of the northern boundary and bipoles + WRITE(*,*) '' + WRITE(*,*) ' ** all around the earth (2 bipoles) ** ' + WRITE(*,*) '' + ! + nn_imin = 2 + nn_imax = nmid + nn_jmin = nn_jmax + nxcoag = (nn_imax+1) - (nn_imin-1) + 1 + nycoag = (nsizey+1 - (nn_jmin-1)) + (nsizey+1 - (nn_jmax-1)) - 2 + ! + ENDIF + ! + WRITE(*,*) '' + WRITE(*,*) ' ### END SUBROUTINE define_domain ### ' + WRITE(*,*) '' + ! + END SUBROUTINE + ! +END MODULE \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/io_netcdf.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/io_netcdf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..012c91bde96755aa39431861183ee1635750f41a --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/io_netcdf.f90 @@ -0,0 +1,1688 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +!******************************************************************************** +! * +! module io_netcdf * +! * +! NetCDF Fortran 90 read/write interface * +! using input/output functions provided * +! by unidata * +! * +!http://my.unidata.ucar.edu/content/software/netcdf/docs/netcdf-f90/index.html * +! * +!******************************************************************************** +! +! +! +MODULE io_netcdf + ! + USE netcdf + USE types + ! + INTERFACE Read_Ncdf_var + MODULE PROCEDURE Read_Ncdf_var1d_Real, & + Read_Ncdf_var2d_Real, & + Read_Ncdf_var2d_Real_bis, & + Read_Ncdf_var3d_Real, & + Read_Ncdf_var4d_Real, & + Read_Ncdf_var3d_Real_t, & + Read_Ncdf_var4d_Real_t, & + Read_Ncdf_var4d_Real_nt, & + Read_Ncdf_var1d_Int, & + Read_Ncdf_var2d_Int, & + Read_Ncdf_var3d_Int, & + Read_Ncdf_var4d_Int, & + Read_Ncdf_var0d_Int, & + Read_Ncdf_var0d_Real + END INTERFACE + ! + INTERFACE Write_Ncdf_var + MODULE PROCEDURE Write_Ncdf_var1d_Real, & + Write_Ncdf_var2d_Real, & + Write_Ncdf_var3d_Real, & + Write_Ncdf_var4d_Real, & + Write_Ncdf_var3d_Real_t, & + Write_Ncdf_var4d_Real_t, & + Write_Ncdf_var4d_Real_nt, & + Write_Ncdf_var2d_Real_bis, & + Write_Ncdf_var1d_Int, & + Write_Ncdf_var2d_Int, & + Write_Ncdf_var3d_Int, & + Write_Ncdf_var4d_Int, & + Write_Ncdf_var0d_Real + END INTERFACE + ! + INTERFACE Copy_Ncdf_att + MODULE PROCEDURE Copy_Ncdf_att_latlon,Copy_Ncdf_att_var + END INTERFACE + ! +CONTAINS + ! + !**************************************************************** + ! subroutine Read_Ncdf_dim * + ! * + ! subroutine to retrieve value of a given dimension * + ! * + ! dimname : name of dimension to retrieve * + ! file : netcdf file name * + ! dimval : value of the required dimension * + ! * + !**************************************************************** + ! + SUBROUTINE Read_Ncdf_dim(dimname,file,dimval) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: dimname,file + INTEGER :: dimval + INTEGER ncid,status,dimid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname,dimid) + status = nf90_inquire_dimension(ncid,dimid,len=dimval) + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_dim + ! + ! + ! + !**************************************************************** + ! subroutine Write_Ncdf_dim * + ! * + ! subroutine to write a dimension in a given file * + ! * + ! dimname : name of dimension to initialize * + ! file : netcdf file name * + ! dimval : value of the dimension to write * + ! * + !**************************************************************** + SUBROUTINE Write_Ncdf_dim(dimname,file,dimval) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: dimname,file + INTEGER :: dimval + ! + ! local variables + ! + INTEGER ncid,status,dimid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_redef(ncid) + IF(dimval.EQ.0) THEN + status = nf90_def_dim(ncid,dimname,nf90_unlimited,dimid) + ELSE + status = nf90_def_dim(ncid,dimname,dimval,dimid) + END IF + ! + status = nf90_enddef(ncid) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_dim + ! + ! + ! + !**************************************************************** + ! subroutine Read_Ncdf_var * + ! * + ! subroutine to retrieve values of a given variable * + ! * + ! varname : name of variable to retrieve * + ! file : netcdf file name * + ! tabvar : array containing values of the required variable * + ! * + !**************************************************************** + SUBROUTINE Read_Ncdf_var1d_Real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(1) :: dimID + INTEGER :: dim1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimID) + status=nf90_inquire_dimension(ncid,dimID(1),len=dim1) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var1d_Real + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var2d_real + !************************************************************** + SUBROUTINE Read_Ncdf_var2d_Real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Real + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var2d_real_bis + !************************************************************** + SUBROUTINE Read_Ncdf_var2d_Real_bis(varname,file,tabvar,strt,cnt) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER, DIMENSION(2) :: strt,cnt + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + dim1 = cnt(1) + dim2 = cnt(2) + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar,start = strt,count = cnt) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Real_bis + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var3d_real + !************************************************************** + SUBROUTINE Read_Ncdf_var3d_Real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var3d_Real + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var4d_real + !************************************************************** + SUBROUTINE Read_Ncdf_var4d_Real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3,dim4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + status=nf90_inquire_dimension(ncid,dimIDS(4),len=dim4) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3,dim4/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Real + + SUBROUTINE Read_Ncdf_var0d_Real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8 :: tabvar + ! + !local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var0d_Real + + SUBROUTINE Read_Ncdf_var0d_Int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER :: tabvar + ! + !local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var0d_Int + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var1d_int + !************************************************************** + SUBROUTINE Read_Ncdf_var1d_Int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:), POINTER :: tabvar + ! + !local variables + ! + INTEGER,DIMENSION(10) :: dimID + INTEGER :: dim1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimID) + status=nf90_inquire_dimension(ncid,dimID(1),len=dim1) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var1d_Int + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var2d_int + !************************************************************** + SUBROUTINE Read_Ncdf_var2d_Int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var2d_Int + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var3d_Int + !************************************************************** + SUBROUTINE Read_Ncdf_var3d_Int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var3d_Int + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var4d_int + !************************************************************** + SUBROUTINE Read_Ncdf_var4d_Int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3,dim4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + status=nf90_inquire_dimension(ncid,dimIDS(4),len=dim4) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3,dim4/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Int + ! + ! + ! + !**************************************************************** + ! subroutine Write_Ncdf_var * + ! * + ! subroutine to write a variable in a given file * + ! * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! * + !**************************************************************** + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var1d_real + !************************************************************** + SUBROUTINE Write_Ncdf_var1d_Real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,dimname,typevar + REAL*8, DIMENSION(:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname, dimid) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double,(/dimid/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float,(/dimid/),varid) + END SELECT + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var1d_Real + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var2d_real + !************************************************************** + SUBROUTINE Write_Ncdf_var2d_Real_bis(varname,dimname,file,tabvar,nbdim,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + INTEGER,INTENT(in) :: nbdim + CHARACTER(*), DIMENSION(4) :: dimname + REAL*8, DIMENSION(:,:) :: tabvar + REAL*8, DIMENSION(:,:,:),POINTER :: tabtemp3d + REAL*8, DIMENSION(:,:,:,:),POINTER :: tabtemp4d + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid,ncid2 + INTEGER :: varid,varid2 + ! + IF(nbdim==4) THEN + ALLOCATE(tabtemp4d(SIZE(tabvar,1),SIZE(tabvar,2),1,1)) + tabtemp4d(:,:,1,1) = tabvar(:,:) + ELSE IF(nbdim==3) THEN + ALLOCATE(tabtemp3d(SIZE(tabvar,1),SIZE(tabvar,2),1)) + tabtemp3d(:,:,1) = tabvar(:,:) + END IF + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + ! + IF(nbdim==4) status = nf90_inq_dimid(ncid,dimname(4), dimid4) + ! + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + IF(nbdim==4 .AND. typevar == 'double') THEN + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + ! + ELSE IF(nbdim==4 .AND. typevar == 'float') THEN + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + ! + ELSE IF(nbdim==3 .AND. typevar == 'float') THEN + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + ! + ELSE IF(nbdim==3 .AND. typevar == 'double') THEN + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + ! + ENDIF + ! + status = nf90_enddef(ncid) + IF(nbdim==4) status = nf90_put_var(ncid,varid,tabtemp4d) + IF(nbdim==3) status = nf90_put_var(ncid,varid,tabtemp3d) + ! + IF(ASSOCIATED( tabtemp3d ) ) DEALLOCATE( tabtemp3d ) + IF(ASSOCIATED( tabtemp4d ) ) DEALLOCATE( tabtemp4d ) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var2d_Real_bis + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var2d_real + !************************************************************** + SUBROUTINE Write_Ncdf_var2d_Real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*), DIMENSION(2) :: dimname + REAL*8, DIMENSION(:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var2d_Real + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var3d_real + !************************************************************** + SUBROUTINE Write_Ncdf_var3d_Real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var3d_Real + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var4d_real + !************************************************************** + SUBROUTINE Write_Ncdf_var4d_Real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + IF(status/=nf90_noerr) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var4d_Real + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var1d_Int + !************************************************************** + SUBROUTINE Write_Ncdf_var1d_Int(varname,dimname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,dimname + INTEGER, DIMENSION(:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname, dimid) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int,(/dimid/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var1d_Int + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var2d_Int + !************************************************************** + SUBROUTINE Write_Ncdf_var2d_Int(varname,dimname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + CHARACTER(*), DIMENSION(2) :: dimname + INTEGER, DIMENSION(:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int, & + (/dimid1,dimid2/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var2d_Int + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var3d_Int + !************************************************************** + SUBROUTINE Write_Ncdf_var3d_Int(varname,dimname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + INTEGER, DIMENSION(:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int, & + (/dimid1,dimid2,dimid3/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var3d_Int + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var4d_Int + !************************************************************** + SUBROUTINE Write_Ncdf_var4d_Int(varname,dimname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var4d_Int + ! + ! + ! + !**************************************************************** + ! subroutine Read_Ncdf_var_t * + ! * + ! subroutine to read a variable in a given file for time t * + ! * + ! varname : name of variable to read * + ! file : netcdf file name * + ! tabvar : values of the read variable * + ! time : time corresponding to the values to read * + ! * + !**************************************************************** + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var3d_real_t + !************************************************************** + SUBROUTINE Read_Ncdf_var3d_Real_t(varname,file,tabvar,time) + ! + USE types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(3) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,1)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,1)) + ENDIF + ENDIF + + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,time/)) + + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var3d_Real_t + ! + ! + ! + !**************************************************************** + ! subroutine Write_Ncdf_var_t * + ! * + ! subroutine to write a variable in a given file for time t * + ! * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! time : time corresponding to the values to store * + ! * + !**************************************************************** + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var3d_real_t + !************************************************************** + SUBROUTINE Write_Ncdf_var3d_Real_t(varname,dimname,file,tabvar,time,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + INTEGER :: time + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_redef(ncid) + + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var3d_Real_t + ! + ! + ! + !**************************************************************** + ! subroutine Read_Ncdf_var_t * + ! * + ! subroutine to read a variable in a given file for time t * + ! at level n * + ! varname : name of variable to read * + ! file : netcdf file name * + ! tabvar : values of the read variable * + ! time : time corresponding to the values to read * + ! level : level corresponding to the values to read * + ! * + !**************************************************************** + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var4d_real_nt + !************************************************************** + SUBROUTINE Read_Ncdf_var4d_Real_nt(varname,file,tabvar,time,level) + ! + USE types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time,level + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,1,1)) + ELSE + IF ((SIZE(tabvar,1) /= dim1) .OR. (SIZE(tabvar,2) /= dim2)) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,1,1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,level,time/),count=(/dim1,dim2,1,1/)) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Real_nt + ! + ! + ! + !************************************************************** + ! subroutine Read_Ncdf_var4d_real_t + !************************************************************** + SUBROUTINE Read_Ncdf_var4d_Real_t(varname,file,tabvar,time) + ! + USE types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) ALLOCATE(tabvar(dim1,dim2,dim3,1)) + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Read_Ncdf_var4d_Real_t + ! + ! + ! + !**************************************************************** + ! subroutine Write_Ncdf_var_t * + ! * + ! subroutine to write a variable in a given file for time t * + ! at level n * + ! * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! time : time corresponding to the values to store * + ! level : level corresponding to the values to store * + ! * + !**************************************************************** + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var4d_real_t + !************************************************************** + SUBROUTINE Write_Ncdf_var4d_Real_t(varname,dimname,file,tabvar,time,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER :: time,level + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var4d_Real_t + ! + ! + ! + !************************************************************** + ! subroutine Write_Ncdf_var4d_real_nt + !************************************************************** + SUBROUTINE Write_Ncdf_var4d_Real_nt(varname,dimname,file,tabvar,time,level,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER :: time,level + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1.AND.level==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,level,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var4d_Real_nt + + SUBROUTINE Write_Ncdf_var0d_Real(varname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + INTEGER :: time,level + REAL*8 :: tabvar + ! + ! local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + varid=varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + varid=varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ! + status = nf90_put_var(ncid,varid,tabvar) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE Write_Ncdf_var0d_Real + ! + ! + !**************************************************************** + ! subroutine Read_Ncdf_VarName * + ! * + ! subroutine to retrieve of all variables * + ! included in a given file * + ! * + ! filename : netcdf file name * + ! tabvarname : array containing various variables names * + ! * + !**************************************************************** + ! + !************************************************************** + ! subroutine Read_Ncdf_VarName + !************************************************************** + SUBROUTINE Read_Ncdf_VarName(filename,tabvarname) + ! + CHARACTER(*),INTENT(in) :: filename + CHARACTER*20,DIMENSION(:),POINTER :: tabvarname + INTEGER :: nDimensions,nVariables + INTEGER :: nAttributes,unlimitedDimId,i + INTEGER :: ncid,status,dimid + ! + status = nf90_open(filename,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",filename + STOP + ENDIF + ! + status = nf90_inquire(ncid,nDimensions,nVariables,nAttributes, & + unlimitedDimId) + ! + ALLOCATE(tabvarname(nVariables)) + ! + DO i=1,nVariables + status = nf90_inquire_variable(ncid,i,tabvarname(i)) + END DO + ! + END SUBROUTINE Read_Ncdf_Varname + ! + ! + ! + !************************************************************** + ! subroutine Copy_Ncdf_att + !************************************************************** + SUBROUTINE Copy_Ncdf_att_var(varname,filein,fileout) + ! + CHARACTER(*),INTENT(in) :: filein,fileout + CHARACTER(*),INTENT(in) :: varname + INTEGER :: ncid_in,ncid_out,status,varid_in,varid_out + ! + status = nf90_open(filein,NF90_NOWRITE,ncid_in) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open input netcdf file : ",filein + STOP + ENDIF + ! + status = nf90_open(fileout,NF90_WRITE,ncid_out) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open output netcdf file : ",fileout + STOP + ENDIF + ! + status = nf90_inq_varid(ncid_in,varname,varid_in) + status = nf90_inq_varid(ncid_out,varname,varid_out) + ! + status = nf90_redef(ncid_out) + ! + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'valid_min',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'valid_max',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'calendar',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'time_origin',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'positive',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'tstep_sec',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'Minvalue=',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'Maxvalue=',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'short_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'online_operation',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'axis',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'interval_operation',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'interval_write',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'associate',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'actual_range',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'longitude',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'latitude',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'scale_factor',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'add_offset',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'missing_value',ncid_out,varid_out) + ! + status = nf90_enddef(ncid_out) + ! + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + ! + END SUBROUTINE Copy_Ncdf_att_var + ! + ! + ! + !************************************************************** + ! subroutine Copy_Ncdf_att + !************************************************************** + SUBROUTINE Copy_Ncdf_att_latlon(varname,filein,fileout,min,max) + ! + CHARACTER(*),INTENT(in) :: filein,fileout + CHARACTER(*),INTENT(in) :: varname + REAL*8 :: min,max + INTEGER :: ncid_in,ncid_out,status,varid_in,varid_out + ! + status = nf90_open(filein,NF90_NOWRITE,ncid_in) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",filein + STOP + ENDIF + ! + status = nf90_open(fileout,NF90_WRITE,ncid_out) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",fileout + STOP + ENDIF + ! + status = nf90_inq_varid(ncid_in,varname,varid_in) + status = nf90_inq_varid(ncid_out,varname,varid_out) + ! + status = nf90_redef(ncid_out) + ! + SELECT CASE (varname) + ! + CASE('nav_lon') + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_put_att(ncid_out,varid_out,'valid_min',REAL(min,4)) + status = nf90_put_att(ncid_out,varid_out,'valid_max',REAL(max,4)) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + ! + CASE('nav_lat') + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_put_att(ncid_out,varid_out,'valid_min',REAL(min,4)) + status = nf90_put_att(ncid_out,varid_out,'valid_max',REAL(max,4)) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + ! + END SELECT + ! + status = nf90_enddef(ncid_out) + ! + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + END SUBROUTINE Copy_Ncdf_att_latlon + ! + ! + ! + !************************************************************** + ! function Get_NbDims + !************************************************************** + INTEGER FUNCTION Get_NbDims( varname , filename ) + ! + CHARACTER(*),INTENT(in) :: varname,filename + INTEGER :: status,ncid,varid + ! + status = nf90_open(TRIM(filename),NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",TRIM(filename) + STOP + ENDIF + status = nf90_inq_varid(ncid,TRIM(varname),varid) + status = nf90_inquire_variable(ncid, varid , ndims = Get_NbDims) + ! + RETURN + ! + END FUNCTION Get_NbDims + ! + ! + ! + !************************************************************** + ! function Get_NbDims + !************************************************************** + LOGICAL FUNCTION Dims_Existence( dimname , filename ) + ! + CHARACTER(*),INTENT(in) :: dimname,filename + INTEGER :: status,ncid,dimid + ! + status = nf90_open(TRIM(filename),NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",TRIM(filename) + STOP + ENDIF + status = nf90_inq_dimid(ncid,dimname,dimid) + ! + IF (status/=nf90_noerr) THEN + Dims_Existence = .FALSE. + ELSE + Dims_Existence = .TRUE. + ENDIF + ! + RETURN + ! + END FUNCTION Dims_Existence + ! +END MODULE io_netcdf diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/mixed_grid.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/mixed_grid.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8decffd28040d01c9243b5852c08c7ef2f9150b6 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/mixed_grid.f90 @@ -0,0 +1,267 @@ +MODULE mixed_grid +!!----------------------------------------------------------- +!! +!! tools box to create a mixed grid storing +!! the known values of grids U,V,T,F +!! +!! Created by Brice Lemaire on 01/2010. +!! +!!----------------------------------------------------------- + USE readwrite + ! + IMPLICIT NONE + PUBLIC + ! + CONTAINS + !******************************************************** + ! SUBROUTINE define_mixed_grid * + ! * + ! to define the size of the mixed grid * + ! * + ! CALL from create_coordinates * + !******************************************************** + SUBROUTINE define_mixed_grid + ! + INTEGER :: ixgmix, iygmix + INTEGER :: ii, ij + ! + WRITE(*,*) '' + WRITE(*,*) ' ### SUBROUTINE define_mixed_grid ### ' + WRITE(*,*) '' + ! + WRITE(*,*) ' *** CHECKING SIZE OF COARSE DOMAIN *** ' + WRITE(*,*) nxcoag, 'x', nycoag + WRITE(*,*) '' + ! + !************************************* + !!!Calculate size of mixed grid (ixgmix x iygmix) + !************************************* + IF(.NOT.nglobal) THEN + ixgmix = (nxcoag) * 2 !known points (T,U,V,F) along x + ixgmix = ixgmix + (nn_rhox-1)*(ixgmix)!-1) !points to interpolate '' + ! + iygmix = (nycoag) * 2 !known points (T,U,V,F) along y + iygmix = iygmix + (nn_rhoy-1)*(iygmix)!-1) !points to interpolate '' + ELSEIF(nglobal) THEN + ixgmix = (nxcoag) * 2 + ixgmix = ixgmix + (nn_rhox-1)*(ixgmix) + ! + iygmix = (nycoag) * 2 + iygmix = iygmix + (nn_rhoy-1)*(iygmix) + ENDIF + ! + nxgmix = ixgmix + nygmix = iygmix + ! + WRITE(*,*) '' + WRITE(*,*) '*** SIZE OF MIXED GRID ***' + WRITE(*,*) nxgmix, ' x ', nygmix + WRITE(*,*) '' + ! + CALL mixed_grid_allocate(smixgrd,ixgmix,iygmix) !using type.f90 + ! + IF(nglobal)THEN + ii = 1 + ij = 1 + ELSE + ii = nn_imin-1 + ij = nn_jmin-1 + ENDIF + ! + CALL write_mixed_grid(ixgmix,iygmix,ii,ij) + ! + WRITE(*,*) '' + WRITE(*,*) ' ### END SUBROUTINE define_mixed_grid ### ' + WRITE(*,*) '' + ! + END SUBROUTINE + ! + ! + ! + !******************************************************** + ! SUBROUTINE write_mixed_grid * + ! * + ! to write the known values into the mixed grid * + ! These known values are spaced every (nn_rho-1) points * + ! for allowing to compute the interpolation * + ! inside this same grid * + ! * + !******************************************************** + SUBROUTINE write_mixed_grid(ki_end,kj_end,ki_min,kj_min) + ! + INTEGER, INTENT(IN) :: ki_end, kj_end + INTEGER, INTENT(INOUT) :: ki_min, kj_min + INTEGER :: ji_start, jj_start + INTEGER :: ji,jj + INTEGER :: isym_x, isym_y + INTEGER :: itmp1, itmp2, itmp3, itmp4, itmp5, itmp6, itmp7 + INTEGER :: icorrxt, icorrxu, icorrxv, icorrxf !correction factor for i-indexation + INTEGER :: icorryt, icorryu, icorryv, icorryf !correction factor for j-indexation + LOGICAL :: llp = .TRUE. + LOGICAL :: llq = .TRUE. + ! + WRITE(*,*) '' + WRITE(*,*) ' ### SUBROUTINE write_mixed_grid ### ' + WRITE(*,*) '' + ! + ji_start = 1 + jj_start = 1 + ! + isym_y = 1 + ! + ! correction factor for symmetry along north boundary + icorrxt = 0 + icorrxu = 0 + icorrxv = 0 + icorrxf = 0 + ! + icorryt = 0 + icorryu = 0 + icorryv = 0 + icorryf = 0 + ! + DO jj=nn_rhoy,kj_end,2*nn_rhoy + ! + DO ji=nn_rhox,ki_end,2*nn_rhox + ! + smixgrd%nav_lon(ji,jj) = scoagrd%nav_lon(ki_min + icorrxt, kj_min + icorryt) + smixgrd%nav_lat(ji,jj) = scoagrd%nav_lat(ki_min + icorrxt, kj_min + icorryt) + ! + smixgrd%glam(ji,jj) = scoagrd%glamt(ki_min + icorrxt, kj_min + icorryt) + smixgrd%glam(ji+nn_rhox,jj) = scoagrd%glamu(ki_min + icorrxu, kj_min + icorryu) + smixgrd%glam(ji,jj+nn_rhoy) = scoagrd%glamv(ki_min + icorrxv, kj_min + icorryv) + smixgrd%glam(ji+nn_rhox,jj+nn_rhoy) = scoagrd%glamf(ki_min + icorrxf, kj_min + icorryf) + ! + smixgrd%gphi(ji,jj) = scoagrd%gphit(ki_min + icorrxt, kj_min + icorryt) + smixgrd%gphi(ji+nn_rhox,jj) = scoagrd%gphiu(ki_min + icorrxu, kj_min + icorryu) + smixgrd%gphi(ji,jj+nn_rhoy) = scoagrd%gphiv(ki_min + icorrxv, kj_min + icorryv) + smixgrd%gphi(ji+nn_rhox,jj+nn_rhoy) = scoagrd%gphif(ki_min + icorrxf, kj_min + icorryf) + ! + smixgrd%e1(ji,jj) = scoagrd%e1t(ki_min + icorrxt, kj_min + icorryt) + smixgrd%e1(ji+nn_rhox,jj) = scoagrd%e1u(ki_min + icorrxu, kj_min + icorryu) + smixgrd%e1(ji,jj+nn_rhoy) = scoagrd%e1v(ki_min + icorrxv, kj_min + icorryv) + smixgrd%e1(ji+nn_rhox,jj+nn_rhoy) = scoagrd%e1f(ki_min + icorrxf, kj_min + icorryf) + ! + smixgrd%e2(ji,jj) = scoagrd%e2t(ki_min + icorrxt, kj_min + icorryt) + smixgrd%e2(ji+nn_rhox,jj) = scoagrd%e2u(ki_min + icorrxu, kj_min + icorryu) + smixgrd%e2(ji,jj+nn_rhoy) = scoagrd%e2v(ki_min + icorrxv, kj_min + icorryv) + smixgrd%e2(ji+nn_rhox,jj+nn_rhoy) = scoagrd%e2f(ki_min + icorrxf, kj_min + icorryf) + ! + IF(.NOT.nglobal)THEN + IF(ki_min.EQ.nsizex.AND.nn_imin.NE.2) THEN ! across right/left boundary BUT not all around the earth + ki_min = 3 + ELSEIF(isym_y.EQ.1) THEN ! normal case + ki_min = ki_min + 1 + ELSEIF(isym_y.EQ.-1) THEN ! symetry along north boundary + ki_min = ki_min - 1 + ENDIF + ELSE + ki_min = ki_min + 1 + ENDIF + ! + ENDDO + ! + ! + ! when we reach north boundary + IF(.NOT.nglobal)THEN + IF(kj_min.EQ.nsizey-npivot-1.AND.llp) THEN ! npivot => pivot located on T-point or F-point + llp = .FALSE. + kj_min = nsizey + isym_y = -1 + IF(nn_imin.LT.nmid.AND.nn_imax.LT.nmid) THEN ! no bipole (from Asia to Canada) + itmp1 = nsizex - nn_imin + 2 + npivot + isym_x = 1 + ELSEIF(nn_imin.GT.nmid.AND.nn_imax.GT.nmid) THEN ! no bipole (from Canada to Asia) + itmp2 = nsizex - nn_imin + 2 + npivot + isym_x = 2 + ELSEIF(nn_imin.LT.nmid.AND.nn_imax.GT.nmid) THEN ! canadian bipole + IF(nval1.LT.nval2) THEN + itmp3 = nmid + nval2 + isym_x = 3 + ELSEIF(nval1.GE.nval2) THEN ! canadian bipole + itmp4 = nmid + nval1 + 2 - npivot + isym_x = 4 + ENDIF + ELSEIF(ki_min.EQ.nsizex.AND.nval1.GT.nval2) THEN ! asian bipole + itmp5 = nval1 + 1 + npivot + isym_x = 5 + ELSEIF(ki_min.EQ.nsizex.AND.nval1.LT.nval2) THEN ! asian bipole + itmp6 = nval2 + 1 + isym_x = 6 + ELSEIF(ki_min.GE.nmid) THEN ! all around the earth (2 bipoles) + itmp7 = nsizex + isym_x = 7 + ENDIF + ENDIF + ! + ! + ! + IF(isym_y.EQ.1) THEN + kj_min = kj_min + 1 ! cas normal + ki_min = nn_imin - 1 + ELSEIF(isym_y.EQ.-1) THEN + kj_min = kj_min - 1 + ! + icorrxt = 0 + icorrxu = -1 + icorrxv = 0 + icorrxf = -1 + ! + icorryt = 0 + icorryu = 0 + icorryv = -1 + icorryf = -1 + ! + IF(isym_x.EQ.1) THEN ! no bipole + ki_min = itmp1 + IF(llq)THEN + icorrxt = 0 + icorrxu = -1 + npivot + icorrxv = 0 + ! + icorryt = 0 + icorryu = 0 + icorryv = -1 + npivot + ! + llq = .FALSE. + ENDIF + ELSEIF(isym_x.EQ.2) THEN ! no bipole + ki_min = itmp2 + ELSEIF(isym_x.EQ.3) THEN ! canadian bipole + ki_min = itmp3 + ELSEIF(isym_x.EQ.4) THEN ! canadian bipole + ki_min = itmp4 + IF(llq)THEN + icorrxt = 0 + icorrxu = -1 + npivot + icorrxv = 0 + ! + icorryt = 0 + icorryu = 0 + icorryv = -1 + npivot + ! + llq = .FALSE. + ENDIF + ELSEIF(isym_x.EQ.5) THEN ! asian bipole + ki_min = itmp5 + ELSEIF(isym_x.EQ.6) THEN ! asian bipole + ki_min = itmp6 + ELSEIF(isym_x.EQ.7) THEN ! all around the earth (2 bipoles) + ki_min = itmp7 + ENDIF + ! + ENDIF + ! + ELSEIF(nglobal) THEN + kj_min = kj_min + 1 + ki_min = 1 + ENDIF + ENDDO + ! + WRITE(*,*) '' + WRITE(*,*) ' ### END SUBROUTINE write_mixed_grid ### ' + WRITE(*,*) '' + ! + END SUBROUTINE + ! +END MODULE \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/projection.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/projection.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1fa027494eb0aaff60e84f5d860a44af0bd50044 --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/projection.f90 @@ -0,0 +1,240 @@ +MODULE projection +!!----------------------------------------------------------- +!! +!! to make a polar stereographic projection +!! in the area of the north pole +!! +!! Created by Brice Lemaire on 05/2010. +!! +!!----------------------------------------------------------- + USE readwrite + ! + IMPLICIT NONE + PUBLIC + ! + REAL*8,DIMENSION(4) :: dmixlam, dmixphi + REAL*8 :: dray = 6357 !rayon polaire de la Terre (km) + REAL*8 :: PI = ACOS(-1.0) + REAL*8 :: dlong0 = 0. !longitude du centre de projection (origine) + REAL*8 :: dlat0 = 90. !latitude '' + INTEGER :: idisc = 0 !to check the +/- 180 discontinuity + INTEGER :: m + ! + CONTAINS + !******************************************************** + ! SUBROUTINE stereo_projection * + ! * + ! * + ! CALLED by cfg_tools.F90 * + !******************************************************** + SUBROUTINE stereo_projection(kji,kjj,kjk,knorth_pole,kway) + ! + INTEGER,INTENT(IN) :: kji,kjj,kjk + LOGICAL,INTENT(IN) :: knorth_pole + INTEGER,INTENT(IN) :: kway + INTEGER :: klon, klat + REAL*8,DIMENSION(4) :: dlx, dly + REAL*8,DIMENSION(4) :: dllam, dlphi, dlk + REAL*8 :: dl_lat0, dl_long0 + ! + dl_lat0 = dlat0 * PI/180. + dl_long0 = dlong0 * PI/180. + ! + !Either we interpolate along longitude or along latitude + IF(kway.EQ.1)THEN + klon = 1 + klat = 0 + ELSEIF(kway.EQ.2) THEN + klon = 0 + klat = 1 + ENDIF + ! + ! Check the discontinuity +/- 180 + IF(kway.EQ.1)THEN + IF(smixgrd%glam(kji,kjj).LT.180..AND.smixgrd%glam(kji+3*nn_rhox,kjj).GT.180.) THEN + IF(smixgrd%glam(kji+2*nn_rhox,kjj).LT.180.) THEN + idisc = 1 + ELSEIF(smixgrd%glam(kji+1*nn_rhox,kjj).GT.180.) THEN + idisc = 2 + ELSEIF(smixgrd%glam(kji+2*nn_rhox,kjj).GT.180.AND.smixgrd%glam(kji+1*nn_rhox,kjj).LT.180.)THEN + idisc = 3 + ENDIF + ELSE + idisc = 0 + ENDIF + ENDIF + ! + dllam(1) = smixgrd%glam(kji,kjj) * PI/180. + dlphi(1) = smixgrd%gphi(kji,kjj) * PI/180. + dlk(1) = (2*dray) / (1 + (SIN(dl_lat0)*SIN(dlphi(1))) + (COS(dl_lat0)*COS(dlphi(1))*COS(dllam(1) - dl_long0))) + ! + dllam(2) = smixgrd%glam(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) * PI/180. + dlphi(2) = smixgrd%gphi(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) * PI/180. + dlk(2) = (2*dray) / (1 + (SIN(dl_lat0)*SIN(dlphi(2))) + (COS(dl_lat0)*COS(dlphi(2))*COS(dllam(2) - dl_long0))) + ! + dllam(3) = smixgrd%glam(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) * PI/180. + dlphi(3) = smixgrd%gphi(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) * PI/180. + dlk(3) = (2*dray) / (1 + (SIN(dl_lat0)*SIN(dlphi(3))) + (COS(dl_lat0)*COS(dlphi(3))*COS(dllam(3) - dl_long0))) + ! + dllam(4) = smixgrd%glam(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) * PI/180. + dlphi(4) = smixgrd%gphi(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) * PI/180. + dlk(4) = (2*dray) / (1 + (SIN(dl_lat0)*SIN(dlphi(4))) + (COS(dl_lat0)*COS(dlphi(4))*COS(dllam(4) - dl_long0))) + ! + dlx(1) = dlk(1) * COS(dlphi(1)) * SIN(dllam(1) - dl_long0) + dly(1) = dlk(1) * ((COS(dl_lat0) * SIN(dlphi(1))) - (SIN(dl_lat0) * COS(dlphi(1)) * COS(dllam(1) - dl_long0))) + ! + dlx(2) = dlk(2) * COS(dlphi(2)) * SIN(dllam(2) - dl_long0) + dly(2) = dlk(2) * ((COS(dl_lat0) * SIN(dlphi(2))) - (SIN(dl_lat0) * COS(dlphi(2)) * COS(dllam(2) - dl_long0))) + ! + dlx(3) = dlk(3) * COS(dlphi(3)) * SIN(dllam(3) - dl_long0) + dly(3) = dlk(3) * ((COS(dl_lat0) * SIN(dlphi(3))) - (SIN(dl_lat0) * COS(dlphi(3)) * COS(dllam(3) - dl_long0))) + ! + dlx(4) = dlk(4) * COS(dlphi(4)) * SIN(dllam(4) - dl_long0) + dly(4) = dlk(4) * ((COS(dl_lat0) * SIN(dlphi(4))) - (SIN(dl_lat0) * COS(dlphi(4)) * COS(dllam(4) - dl_long0))) + ! + dmixlam(1) = smixgrd%glam(kji,kjj) + dmixlam(2) = smixgrd%glam(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) + dmixlam(3) = smixgrd%glam(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) + dmixlam(4) = smixgrd%glam(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) + ! + dmixphi(1) = smixgrd%gphi(kji,kjj) + dmixphi(2) = smixgrd%gphi(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) + dmixphi(3) = smixgrd%gphi(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) + dmixphi(4) = smixgrd%gphi(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) + ! + smixgrd%glam(kji,kjj) = dlx(1) + smixgrd%glam(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) = dlx(2) + smixgrd%glam(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) = dlx(3) + smixgrd%glam(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) = dlx(4) + ! + smixgrd%gphi(kji,kjj) = dly(1) + smixgrd%gphi(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) = dly(2) + smixgrd%gphi(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) = dly(3) + smixgrd%gphi(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) = dly(4) + ! + END SUBROUTINE stereo_projection + ! + ! + ! + !******************************************************** + ! SUBROUTINE stereo_projection_inv * + ! * + ! * + ! CALLED from here * + !******************************************************** + SUBROUTINE stereo_projection_inv(kji,kjj,kjk,knorth_pole,kway) + ! + INTEGER,INTENT(IN) :: kji,kjj,kjk + LOGICAL,INTENT(IN) :: knorth_pole + INTEGER,INTENT(IN) :: kway + INTEGER :: klon, klat + REAL*8,DIMENSION(5) :: dlx, dly + REAL*8,DIMENSION(5) :: dllam, dlphi + REAL*8,DIMENSION(5) :: dlro, dlc + REAL*8 :: dl_long0, dl_lat0 + ! + dl_lat0 = dlat0 * PI/180. + dl_long0 = dlong0 * PI/180. + ! + IF(kway.EQ.1)THEN + klon = 1 + klat = 0 + ELSEIF(kway.EQ.2) THEN + klon = 0 + klat = 1 + ENDIF + ! + ! + dlx(1) = smixgrd%glam(kji,kjj) + dlx(2) = smixgrd%glam(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) + dlx(3) = smixgrd%glam(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) + dlx(4) = smixgrd%glam(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) + dlx(5) = smixgrd%glam(kji+(nn_rhox+kjk)*klon,kjj+(nn_rhoy+kjk)*klat) + ! + dly(1) = smixgrd%gphi(kji,kjj) + dly(2) = smixgrd%gphi(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) + dly(3) = smixgrd%gphi(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) + dly(4) = smixgrd%gphi(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) + dly(5) = smixgrd%gphi(kji+(nn_rhox+kjk)*klon,kjj+(nn_rhoy+kjk)*klat) + ! + dlro(1) = SQRT(dlx(1)*dlx(1) + dly(1)*dly(1)) + dlro(2) = SQRT(dlx(2)*dlx(2) + dly(2)*dly(2)) + dlro(3) = SQRT(dlx(3)*dlx(3) + dly(3)*dly(3)) + dlro(4) = SQRT(dlx(4)*dlx(4) + dly(4)*dly(4)) + dlro(5) = SQRT(dlx(5)*dlx(5) + dly(5)*dly(5)) + ! + dlc(1) = 2*ATAN(dlro(1)/(2*dray)) + dlc(2) = 2*ATAN(dlro(2)/(2*dray)) + dlc(3) = 2*ATAN(dlro(3)/(2*dray)) + dlc(4) = 2*ATAN(dlro(4)/(2*dray)) + dlc(5) = 2*ATAN(dlro(5)/(2*dray)) + ! + dlphi(1) = ASIN(COS(dlc(1))*SIN(dl_lat0) + (dly(1)*SIN(dlc(1))*COS(dl_lat0) / dlro(1))) + dlphi(2) = ASIN(COS(dlc(2))*SIN(dl_lat0) + (dly(2)*SIN(dlc(2))*COS(dl_lat0) / dlro(2))) + dlphi(3) = ASIN(COS(dlc(3))*SIN(dl_lat0) + (dly(3)*SIN(dlc(3))*COS(dl_lat0) / dlro(3))) + dlphi(4) = ASIN(COS(dlc(4))*SIN(dl_lat0) + (dly(4)*SIN(dlc(4))*COS(dl_lat0) / dlro(4))) + dlphi(5) = ASIN(COS(dlc(5))*SIN(dl_lat0) + (dly(5)*SIN(dlc(5))*COS(dl_lat0) / dlro(5))) + ! + dlphi(:) = dlphi(:) * 180./PI + ! + dllam(1) = dl_long0 + ATAN(dlx(1)*SIN(dlc(1) / ((dlro(1)*COS(dl_lat0)*COS(dlc(1)))-(dly(1)*SIN(dl_lat0)*SIN(dlc(1)))))) + dllam(2) = dl_long0 + ATAN(dlx(2)*SIN(dlc(2) / ((dlro(2)*COS(dl_lat0)*COS(dlc(2)))-(dly(2)*SIN(dl_lat0)*SIN(dlc(2)))))) + dllam(3) = dl_long0 + ATAN(dlx(3)*SIN(dlc(3) / ((dlro(3)*COS(dl_lat0)*COS(dlc(3)))-(dly(3)*SIN(dl_lat0)*SIN(dlc(3)))))) + dllam(4) = dl_long0 + ATAN(dlx(4)*SIN(dlc(4) / ((dlro(4)*COS(dl_lat0)*COS(dlc(4)))-(dly(4)*SIN(dl_lat0)*SIN(dlc(4)))))) + dllam(5) = dl_long0 + ATAN(dlx(5)*SIN(dlc(5) / ((dlro(5)*COS(dl_lat0)*COS(dlc(5)))-(dly(5)*SIN(dl_lat0)*SIN(dlc(5)))))) + ! + dllam(1) = dllam(1) * 180./PI + dllam(2) = dllam(2) * 180./PI + dllam(3) = dllam(3) * 180./PI + dllam(4) = dllam(4) * 180./PI + ! + dllam(5) = dllam(5) * 180./PI + ! + IF(kway.EQ.1)THEN + IF(idisc.EQ.1) THEN + dllam(5) = dllam(5) + 180. + ELSEIF(idisc.EQ.2) THEN + dllam(5) = dllam(5) - 180. + ELSEIF(idisc.EQ.3) THEN + dllam(5) = dllam(5) - 180. + ELSE + dllam(5) = dllam(5) + ENDIF + ! + ELSEIF(kway.EQ.2)THEN + IF(smixgrd%glam(kji,kjj+1*nn_rhoy).GT.0.AND.smixgrd%glam(kji,kjj+2*nn_rhoy).GT.0)THEN + IF(dllam(5).LT.0.)THEN + dllam(5) = dllam(5) + 180 + ENDIF + ELSEIF(smixgrd%glam(kji,kjj+1*nn_rhoy).LT.0.AND.smixgrd%glam(kji,kjj+2*nn_rhoy).LT.0)THEN + IF(dllam(5).GT.0.)THEN + dllam(5) = dllam(5) - 180 + ENDIF + ELSEIF(smixgrd%glam(kji,kjj+1*nn_rhoy)*smixgrd%glam(kji,kjj+2*nn_rhoy).LT.0)THEN + IF(dllam(5).LT.0.)THEN + dllam(5) = dllam(5) + 180 + ELSEIF(dllam(5).GT.0.)THEN + dllam(5) = dllam(5) - 180 + ENDIF + ENDIF + ENDIF + ! + smixgrd%glam(kji,kjj) = dmixlam(1) + smixgrd%glam(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) = dmixlam(2) + smixgrd%glam(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) = dmixlam(3) + smixgrd%glam(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) = dmixlam(4) + ! + smixgrd%glam(kji+(nn_rhox+kjk)*klon,kjj+(nn_rhoy+kjk)*klat) = dllam(5) + ! + smixgrd%gphi(kji,kjj) = dmixphi(1) + smixgrd%gphi(kji+1*nn_rhox*klon,kjj+1*nn_rhoy*klat) = dmixphi(2) + smixgrd%gphi(kji+2*nn_rhox*klon,kjj+2*nn_rhoy*klat) = dmixphi(3) + smixgrd%gphi(kji+3*nn_rhox*klon,kjj+3*nn_rhoy*klat) = dmixphi(4) + ! + smixgrd%gphi(kji+(nn_rhox+kjk)*klon,kjj+(nn_rhoy+kjk)*klat) = dlphi(5) + ! + END SUBROUTINE stereo_projection_inv + ! + ! + ! +END MODULE projection diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/readwrite.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/readwrite.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2560415855b9fabf7b76f45483c07b6de36427bc --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/readwrite.f90 @@ -0,0 +1,182 @@ +MODULE readwrite + ! + USE types + ! + IMPLICIT NONE + ! +CONTAINS + ! + !***************************************************** + ! function Read_Coordinates(name,Grid) + !***************************************************** + INTEGER FUNCTION read_coordinates(name,Grid) + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(coordinates) :: Grid + ! + CALL Read_Ncdf_var('glamt',name,Grid%glamt) + CALL Read_Ncdf_var('glamu',name,Grid%glamu) + CALL Read_Ncdf_var('glamv',name,Grid%glamv) + CALL Read_Ncdf_var('glamf',name,Grid%glamf) + CALL Read_Ncdf_var('gphit',name,Grid%gphit) + CALL Read_Ncdf_var('gphiu',name,Grid%gphiu) + CALL Read_Ncdf_var('gphiv',name,Grid%gphiv) + CALL Read_Ncdf_var('gphif',name,Grid%gphif) + CALL Read_Ncdf_var('e1t',name,Grid%e1t) + CALL Read_Ncdf_var('e1u',name,Grid%e1u) + CALL Read_Ncdf_var('e1v',name,Grid%e1v) + CALL Read_Ncdf_var('e1f',name,Grid%e1f) + CALL Read_Ncdf_var('e2t',name,Grid%e2t) + CALL Read_Ncdf_var('e2u',name,Grid%e2u) + CALL Read_Ncdf_var('e2v',name,Grid%e2v) + CALL Read_Ncdf_var('e2f',name,Grid%e2f) + CALL Read_Ncdf_var('nav_lon',name,Grid%nav_lon) + CALL Read_Ncdf_var('nav_lat',name,Grid%nav_lat) + ! + WRITE(*,*) ' ' + WRITE(*,*) '*** Reading coordinates file: ',name + WRITE(*,*) ' ' + ! + read_coordinates = 1 + ! + END FUNCTION read_coordinates + ! + ! + ! + !***************************************************** + ! function Write_Coordinates(name,Grid) + !***************************************************** + INTEGER FUNCTION write_coordinates(name,Grid,kxfine,kyfine) + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(coordinates) :: Grid + INTEGER :: status,ncid,z + REAL*8,DIMENSION(:),POINTER :: tabtemp + INTEGER,DIMENSION(:),POINTER :: tabint + CHARACTER(len=20),DIMENSION(4) :: dimnames + INTEGER :: kxfine, kyfine + ! + status = nf90_create(name,NF90_WRITE,ncid) + status = nf90_close(ncid) + ! + CALL Write_Ncdf_dim('x',name,nxfine) + CALL Write_Ncdf_dim('y',name,nyfine) + IF(.NOT. ln_iom_activated) CALL Write_Ncdf_dim('z',name,1) + CALL Write_Ncdf_dim('time',name,0) + ! + dimnames(1)='x' + dimnames(2)='y' + CALL Write_Ncdf_var('nav_lon',dimnames(1:2),name,Grid%nav_lon,'float') + CALL Write_Ncdf_var('nav_lat',dimnames(1:2),name,Grid%nav_lat,'float') + ! + IF(.NOT. ln_iom_activated) THEN + ! copy nav_lev variable -> IOIPSL + CALL Read_Ncdf_dim('z',cn_parent_coordinate_file,z) + ALLOCATE(tabtemp(z)) + CALL Read_Ncdf_var('nav_lev',TRIM(cn_parent_coordinate_file),tabtemp) + CALL Write_Ncdf_var('nav_lev','z',name,tabtemp,'float') + DEALLOCATE(tabtemp) + ENDIF + ! + CALL Read_Ncdf_var('time',TRIM(cn_parent_coordinate_file),tabtemp) + CALL Write_Ncdf_var('time','time',name,tabtemp,'float') + DEALLOCATE(tabtemp) + CALL Read_Ncdf_var('time_steps',TRIM(cn_parent_coordinate_file),tabint) + CALL Write_Ncdf_var('time_steps','time',name,tabint) + ! + dimnames(1)='x' + dimnames(2)='y' + IF(ln_iom_activated) THEN + dimnames(3)='time' + ELSE + dimnames(3)='z' + dimnames(4)='time' + ENDIF + + CALL Write_Ncdf_var('glamt',dimnames,name,Grid%glamt,3,'double') + CALL Write_Ncdf_var('glamu',dimnames,name,Grid%glamu,3,'double') + CALL Write_Ncdf_var('glamv',dimnames,name,Grid%glamv,3,'double') + CALL Write_Ncdf_var('glamf',dimnames,name,Grid%glamf,3,'double') + CALL Write_Ncdf_var('gphit',dimnames,name,Grid%gphit,3,'double') + CALL Write_Ncdf_var('gphiu',dimnames,name,Grid%gphiu,3,'double') + CALL Write_Ncdf_var('gphiv',dimnames,name,Grid%gphiv,3,'double') + CALL Write_Ncdf_var('gphif',dimnames,name,Grid%gphif,3,'double') + CALL Write_Ncdf_var('e1t',dimnames,name,Grid%e1t,3,'double') + CALL Write_Ncdf_var('e1u',dimnames,name,Grid%e1u,3,'double') + CALL Write_Ncdf_var('e1v',dimnames,name,Grid%e1v,3,'double') + CALL Write_Ncdf_var('e1f',dimnames,name,Grid%e1f,3,'double') + CALL Write_Ncdf_var('e2t',dimnames,name,Grid%e2t,3,'double') + CALL Write_Ncdf_var('e2u',dimnames,name,Grid%e2u,3,'double') + CALL Write_Ncdf_var('e2v',dimnames,name,Grid%e2v,3,'double') + CALL Write_Ncdf_var('e2f',dimnames,name,Grid%e2f,3,'double') + ! + CALL Copy_Ncdf_att('nav_lon',TRIM(cn_parent_coordinate_file),name,& + MINVAL(Grid%nav_lon),MAXVAL(Grid%nav_lon)) + CALL Copy_Ncdf_att('nav_lat',TRIM(cn_parent_coordinate_file),name,& + MINVAL(Grid%nav_lat),MAXVAL(Grid%nav_lat)) + CALL Copy_Ncdf_att('nav_lev',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('time',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('time_steps',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('glamt',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('glamu',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('glamv',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('glamf',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('gphit',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('gphiu',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('gphiv',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('gphif',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e1t',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e1u',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e1v',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e1f',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e2t',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e2u',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e2v',TRIM(cn_parent_coordinate_file),name) + CALL Copy_Ncdf_att('e2f',TRIM(cn_parent_coordinate_file),name) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Writing coordinates file: ',name + IF(.NOT. ln_iom_activated) WRITE(*,*) 'IOISPL format' + IF(ln_iom_activated) WRITE(*,*) 'IOM format' + WRITE(*,*) ' ' + ! + write_coordinates = 1 + ! + END FUNCTION write_coordinates + ! + ! + ! + !***************************************************** + ! function set_child_name(Parentname,Childname) + !***************************************************** + SUBROUTINE set_child_name(Parentname,Childname) + ! + CHARACTER(*),INTENT(in) :: Parentname + CHARACTER(*),INTENT(out) :: Childname + CHARACTER(2) :: prefix + INTEGER :: pos + ! + pos = INDEX(TRIM(Parentname),'/',back=.TRUE.) + ! + prefix=Parentname(pos+1:pos+2) + IF (prefix == '1_') THEN + Childname = '2_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '2_') THEN + Childname = '3_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '3_') THEN + Childname = '4_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '4_') THEN + Childname = '5_'//Parentname(pos+3:LEN(Parentname)) + ELSE + Childname = '1_'//Parentname(pos+1:LEN(Parentname)) + ENDIF + ! + END SUBROUTINE set_child_name + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +END MODULE readwrite diff --git a/V4.0/nemo_sources/tools/GRIDGEN/src/types.f90 b/V4.0/nemo_sources/tools/GRIDGEN/src/types.f90 new file mode 100644 index 0000000000000000000000000000000000000000..66cd92369040a7cfa5be51f6c446fc9e380fe45c --- /dev/null +++ b/V4.0/nemo_sources/tools/GRIDGEN/src/types.f90 @@ -0,0 +1,210 @@ +MODULE types + ! + PUBLIC + ! + !***************************** + ! Coordinates type definition + !***************************** + TYPE coordinates + REAL*8, DIMENSION(:,:), POINTER :: nav_lon,nav_lat => NULL() + REAL*8, DIMENSION(:,:), POINTER :: glamv, glamu, glamt, glamf => NULL() + REAL*8, DIMENSION(:,:), POINTER :: gphit, gphiu, gphiv, gphif => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e1t, e1u, e1v, e1f => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e2t, e2u, e2v, e2f => NULL() + INTEGER, DIMENSION(:) , POINTER :: time_steps => NULL() + END TYPE coordinates + ! + ! + ! + TYPE mixed_coordinates + REAL*8, DIMENSION(:,:), POINTER :: nav_lon,nav_lat => NULL() + REAL*8, DIMENSION(:,:), POINTER :: glam => NULL() + REAL*8, DIMENSION(:,:), POINTER :: gphi => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e1 => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e2 => NULL() + INTEGER, DIMENSION(:) , POINTER :: time_steps => NULL() + END TYPE mixed_coordinates + ! + !************************************************************** + ! Declaration of global variables + !************************************************************** + !size of input ORCA grid + INTEGER :: nsizex, nsizey + INTEGER :: nmid + ! + !kind of input grid + INTEGER :: npivot + ! + INTEGER :: nequator + ! + LOGICAL :: nglobal + ! + INTEGER :: nresx, nresy + ! + !distance between middle of input grid and the border of sub-domain + INTEGER :: nval1, nval2 + ! + INTEGER :: nxcoag, nycoag !size of the sub-domain inside input ORCA grid + INTEGER :: nxgmix, nygmix !size of the mixed grid + INTEGER :: nxfine, nyfine !size of fine grid + ! + TYPE(coordinates), SAVE :: scoagrd !coarse grid + TYPE(coordinates), SAVE :: sfingrd !fine grid + TYPE(mixed_coordinates), SAVE :: smixgrd !mixed grid to store all components (T,U,V,F) + ! of the coarse grid in the same one + ! + ! + ! + !************************************************************** + ! Declaration of various input file variables (namelist.input) + !************************************************************** + INTEGER nn_imin,nn_jmin,nn_imax,nn_jmax,nn_rhox,nn_rhoy + LOGICAL ln_iom_activated + CHARACTER*100 cn_parent_coordinate_file, cn_position_pivot + ! + NAMELIST /input_output/ln_iom_activated + NAMELIST /coarse_grid_files/cn_parent_coordinate_file,cn_position_pivot + NAMELIST /nesting/nn_imin,nn_jmin,nn_imax,nn_jmax,nn_rhox,nn_rhoy + ! + ! + ! +CONTAINS + !******************************************************** + ! subroutine grid_allocate * + ! * + ! allocation of grid type elements * + ! according to nx and ny * + ! * + !******************************************************** + SUBROUTINE grid_allocate(Grid,nx,ny) + ! + TYPE(coordinates) :: Grid + INTEGER :: nx,ny + ! + ALLOCATE(Grid%nav_lon(nx,ny),Grid%nav_lat(nx,ny)) + ALLOCATE(Grid%glamt(nx,ny),Grid%glamu(nx,ny),Grid%glamv(nx,ny),Grid%glamf(nx,ny)) + ALLOCATE(Grid%gphit(nx,ny),Grid%gphiu(nx,ny),Grid%gphiv(nx,ny),Grid%gphif(nx,ny)) + ALLOCATE(Grid%e1t(nx,ny),Grid%e1u(nx,ny),Grid%e1v(nx,ny),Grid%e1f(nx,ny)) + ALLOCATE(Grid%e2t(nx,ny),Grid%e2u(nx,ny),Grid%e2v(nx,ny),Grid%e2f(nx,ny)) + ! + END SUBROUTINE grid_allocate + ! + ! + ! + SUBROUTINE grid_deallocate(Grid) + ! + TYPE(coordinates) :: Grid + ! + DEALLOCATE(Grid%nav_lon,Grid%nav_lat) + DEALLOCATE(Grid%glamt,Grid%glamu,Grid%glamv,Grid%glamf) + DEALLOCATE(Grid%gphit,Grid%gphiu,Grid%gphiv,Grid%gphif) + DEALLOCATE(Grid%e1t,Grid%e1u,Grid%e1v,Grid%e1f) + DEALLOCATE(Grid%e2t,Grid%e2u,Grid%e2v,Grid%e2f) + ! + END SUBROUTINE grid_deallocate + ! + ! + ! + !******************************************************** + ! subroutine mixed_grid_allocate * + ! * + ! allocation of grid type elements * + ! according to nx and ny * + ! * + !******************************************************** + SUBROUTINE mixed_grid_allocate(Grid,nx,ny) + ! + TYPE(mixed_coordinates) :: Grid + INTEGER :: nx,ny + ! + ALLOCATE(Grid%nav_lon(nx,ny),Grid%nav_lat(nx,ny)) + ALLOCATE(Grid%glam(nx,ny)) + ALLOCATE(Grid%gphi(nx,ny)) + ALLOCATE(Grid%e1(nx,ny)) + ALLOCATE(Grid%e2(nx,ny)) + ! + END SUBROUTINE mixed_grid_allocate + ! + ! + ! + SUBROUTINE mixed_grid_deallocate(Grid) + ! + TYPE(mixed_coordinates) :: Grid + ! + DEALLOCATE(Grid%nav_lon,Grid%nav_lat) + DEALLOCATE(Grid%glam) + DEALLOCATE(Grid%gphi) + DEALLOCATE(Grid%e1) + DEALLOCATE(Grid%e2) + ! + END SUBROUTINE mixed_grid_deallocate + ! + ! + ! + !******************************************************** + ! subroutine read_namelist * + ! * + ! read variables contained in namelist.input file * + ! filled in by user * + ! * + !******************************************************** + SUBROUTINE read_namelist(namelistname) + ! + IMPLICIT NONE + CHARACTER(len=80) :: namelistname + CHARACTER*255 :: output + LOGICAL :: is_it_there + INTEGER unit_nml + ! + unit_nml = Get_Unit() + ! + INQUIRE ( FILE = namelistname , EXIST = is_it_there ) + ! + IF ( is_it_there ) THEN + ! + OPEN ( FILE = namelistname, & + UNIT = unit_nml, & + STATUS = 'OLD', & + FORM = 'FORMATTED', & + ACTION = 'READ', & + ACCESS = 'SEQUENTIAL' ) + ! + REWIND(unit_nml) + READ (unit_nml , NML = coarse_grid_files) + READ (unit_nml , NML = nesting) + CLOSE(unit_nml) + ! + ELSE + ! + PRINT *,'namelist file ''',TRIM(namelistname),''' not found' + STOP + ! + END IF + ! + END SUBROUTINE read_namelist + ! + ! + ! + !************************************************* + ! function Get_Unit + !************************************************* + INTEGER FUNCTION Get_Unit() + ! + INTEGER n + LOGICAL op + INTEGER :: nunit + INTEGER :: iii,out,iiimax + ! + DO n = 7,1000 + ! + INQUIRE(Unit=n,Opened=op) + ! + IF (.NOT.op) EXIT + ! + ENDDO + ! + Get_Unit=n + ! + END FUNCTION Get_Unit + ! +END MODULE types diff --git a/V4.0/nemo_sources/tools/MISCELLANEOUS/README_uspcfg b/V4.0/nemo_sources/tools/MISCELLANEOUS/README_uspcfg new file mode 100644 index 0000000000000000000000000000000000000000..ad8e33919fa3e037ab7dabb5476c2a831b7912b0 --- /dev/null +++ b/V4.0/nemo_sources/tools/MISCELLANEOUS/README_uspcfg @@ -0,0 +1,134 @@ +Instructions for using unsupported configurations on systems without wget access to +the internet + +The unsupported configurations in NEMO are provided as a way for users to provide +alternative configurations to the wider community without having to rely on system team +sponsership and support. The idea is to provide minimal but sufficient information +with the standard distribution to allow ancillary files to be fetched from remote +servers at compile time. Thus a makenemo command such as: + +./makenemo -n MYISOMIP -u ISOMIP -m some_arch + +will create a new configuration called MYISOMIP with MY_SRC and EXP00 directories +populated from a remote server. It does this by first using the wget command to fetch a +list of remote files and then using wget repeatedly to fetch each of the files listed +therein. The location of the remote list is contained in one line of information held +in the uspcfg.txt file (in CONFIG). + +These instructions provide a work-around for systems without direct access to the +internet or on which wget has been disabled/not installed. On these systems it is +possible to create local copies of the remote files and replace the wget function +with a local copy command. It will be the user's responsibility to ensure that the +local copies reflect any changes made in the remote sources. + +The procedure requires the following steps: + +1. From the target NEMOGCM directory on your target system copy the following + files into a working directory on a system that does have internet access + and a working wget command: + + a. TOOLS/MISCELLANEOUS/make_usp_tar.sh + b. CONFIG/uspcfg.txt + +2. On that alternative system and in the working directory containing the newly + copied files, run the make_usp_tar.sh script. The script takes three arguments: + + a. The name of the uspcfg.txt file + b. The name of the unsupported configuration you wish to use + c. The name of a directory that will be created and filled with the remote + files in the current working directory. This directory will be tarred and + eventually transferred to the target system. There it will be unpacked and + will form the local archive for this configuration. A meaningful name is + therefore recommended. + + For example: + + ./make_usp_tar.sh uspcfg.txt ISOMIP ISOMIP_ARCHIVE + +3. Copy the resulting tarball (in this case: ISOMIP_ARCHIVE.tar) to the target + system and unpack (tar xvf ISOMIP_ARCHIVE.tar) in a location that is visible to + the node on which you intend to compile nemo. The unpacked directory will contain + the files retrieved from the remote server, modified versions of the file list and + uspcfg.txt files and two new scripts. For example: + + ls -1R ISOMIP_ARCHIVE + cpp_ISOMIP.fcm - downloaded from remote server + def_wget - newly constructed script + local_template.ctl - file list modified for local copy + uspcfg_local_template.txt - a copy of uspcfg.txt with modification for local copy + remote_file.list - downloaded from remote server + set_local_uspcfg - newly constructed script + EXP00 - new subdirectory + MY_SRC - new subdirectory + + ./EXP00: + iodef.xml - downloaded from remote server + namelist_cfg - downloaded from remote server + + ./MY_SRC: + domzgr.F90 - downloaded from remote server + istate.F90 - downloaded from remote server + +4. The final stage is to enter the directory and execute the set_local_uspcfg script. + This script will prompt for a full path to the target CONFIG directory and then: + + a. Edit the templates and create local.ctl and uspcfg_local.txt files by inserting + the full path to the archive directory (i.e. the current working directory) + b. move uspcfg_local.txt to the named CONFIG directory + c. rename any existing uspcfg.txt file in the CONFIG directory to uspcfg_remote.txt + d. insert symbolic link (uspcfg.txt) to uspcfg_local.txt in the CONFIG directory + e. redefine/define wget as an exported bash function to simply copy + + This last action is needed so that subsequent use of makenemo with the -u argument + will not invoke wget. For this to be effective the set_local_usp script should be run + within the same bash shell as makenemo will be run in. I.e.: + + . ./set_local_usp + + If this is not possible or the makenemo command is run at a later date, then the + def_wget script should be run in the bash shell before any attempt to use the -u + option of makenemo. I.e.: + + . ./def_wget + + [ Tip: check that the definition/re-definition of wget has worked correctly by + issuing this command: + + wget a b c + + If you get messages such as: + + wget a b c + --2016-10-27 10:14:52-- http://a/ + Resolving a... failed: Name or service not known. + wget: unable to resolve host address `a' + . + . + + then the re-definition of wget has not been retained by the current shell. Run + . ./def_wget and try again. You should get a response such as: + + wget a b c + Expected wget usage: wget src -O dest + -O not found. No action taken + + if the environment is set correctly + ] + +5. The setup is now complete and moving to the CONFIG directory and issuing a command + such as: + + ./makenemo -n MYISOMIP -u ISOMIP -m target_arch + + should correctly configure from local archives only. + + [ Tip: the -u argument ( and hence the need to switch wget to local copies on isolated + systems ) is only required when compiling for the first time. Subsequent compilations + following code changes in the MYISOMIP directories can be carried out in your + default nemo environment. I.e.: + + ./makenemo -n MYISOMIP -m target_arch + + will not require any of the preceeding steps in future sessions. + ] + diff --git a/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_ifdef.sh b/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_ifdef.sh new file mode 100755 index 0000000000000000000000000000000000000000..4eaf14c93c58101de819b6bc29b258af4ffc6cf1 --- /dev/null +++ b/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_ifdef.sh @@ -0,0 +1,31 @@ +#!/bin/bash +# +# check the propper syntax of C preprocessor directives. +# for example: +#if defined key_traldf_c3d && key_traldf_smag +# is not good and should be +#if defined key_traldf_c3d && defined key_traldf_smag +# +# use: go to TOOLS/MISCELLANEOUS/ and simply execute: +# ./chk_ifdef.sh +# +set -u +# +grep -r "^ *#if" ../../NEMO | grep -v "~:" > tmp$$ # get each lines of the code starting with #if +grep -r "^ *#elif" ../../NEMO | grep -v "~:" >> tmp$$ # get each lines of the code starting with #elif +# +for ll in $( seq 1 $( cat tmp$$ | wc -l ) ) # for each of these lines +do + lll=$( sed -n -e "${ll}p" tmp$$ ) + nbdef=$( echo $lll | grep -o defined | wc -l ) # number of occurences of "defined" + nband=$( echo $lll | grep -o "&&" | wc -l ) # number of occurences of "&&" + nbor=$( echo $lll | grep -o "||" | wc -l ) # number of occurences of "||" + [ $nbdef -ne $(( $nband + $nbor + 1 )) ] && echo $lll # print bad line +done +rm -f tmp$$ + +# +# add other basic tests +# +grep -ir ":,:.*ji,jj" * | grep -v "~:" +grep -ir "ji,jj.*:,:" * | grep -v "~:" diff --git a/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_iomput.sh b/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_iomput.sh new file mode 100755 index 0000000000000000000000000000000000000000..43cc6cbd5bb1fd236006d716d86b0d8f76944e32 --- /dev/null +++ b/V4.0/nemo_sources/tools/MISCELLANEOUS/chk_iomput.sh @@ -0,0 +1,167 @@ +#!/bin/bash +#------------------------------------------------ +#$Id: chk_iomput.sh 9598 2018-05-15 22:47:16Z nicolasmartin $ +#------------------------------------------------ +# +set -u +# +# if not argument -> get the help +[ $# -eq 0 ] && ./$0 --help && exit +# +inxml=0 +insrc=0 +while [ $# -gt 0 ] # Until you run out of parameters . . . +do + case "$1" in + -h|--help) + echo + echo 'Description:' + echo ' check that an xml file is coherant with the source code:' + echo ' - all variable ids defined by "call iom_put" must have their counterpart' + echo ' in the variable definition in xml file' + echo ' - list variable ids defined in xml file without any corresponding call' + echo ' to iom_put. This can be done but it is useless as iom will only ouput zeros' + echo ' - all variable ids used in the files definition in xml file must have' + echo ' their counterpart in the variable definition in xml file' + echo 'Usage:' + echo ' chk_iomput.sh [OPTION]' + echo ' or chk_iomput.sh [OPTION] xmlfile DIRECTORIES' + echo ' with:' + echo ' xmlfile: the xml file to test' + echo ' DIRECTORIES: a list of directories containing the source code' + echo 'Options' + echo ' -h, --help to get this help' + echo ' --inxml only print all variable definitions found in the xml file' + echo ' --insrc only print all variable definitions found in the source code' + echo 'Examples' + echo ' ./chk_iomput.sh' + echo ' ./chk_iomput.sh --help' + echo ' ./chk_iomput.sh ../../cfgs/ORCA2_LIM/EXP00/context_nemo.xml "../../src/OCE/ ../../src/ICE/"' + echo + exit ;; + --inxml) inxml=1 ;; + --insrc) insrc=1 ;; + -*) echo ; echo "illegal option" ; ./$0 --help && exit ;; + *) [ $# -ne 2 ] && echo && echo "wrong number of arguments" && ./$0 --help && exit + xmlfile=${1} + srcdir=${2} + shift + esac + shift # Check next set of parameters. +done +# +echo $xmlfile +echo $srcdir + +for i in $xmlfile +do + [ ! -f "$xmlfile" ] && echo "$xmlfile not found, we stop..." && exit +done +for i in $srcdir +do + [ ! -d $i ] && echo "$i is not a directory, we stop..." && exit +done +# +#------------------------------------------------ +# +external=$( grep -c "<field_definition *\([^ ].* \)*src=" $xmlfile ) +if [ $external -ge 1 ] +then + xmlfield_def=$( grep "<field_definition *\([^ ].* \)*src=" $xmlfile | sed -e 's/.*src="\([^"]*\)".*/\1/' ) + tmp_def="" + for fdef in $xmlfield_def ; do tmp_def="$tmp_def $( dirname $xmlfile )/$fdef" ; done + xmlfield_def=$tmp_def + echo $xmlfield_def +else + xmlfield_def=$xmlfile +fi +external=$( grep -c "<file_definition *\([^ ].* \)*src=" $xmlfile ) +if [ $external -ge 1 ] +then + xmlfile_def=$( grep "<file_definition *\([^ ].* \)*src=" $xmlfile | sed -e 's/.*src="\([^"]*\)".*/\1/' ) + tmp_def="" + for fdef in $xmlfile_def ; do tmp_def="$tmp_def $( dirname $xmlfile )/$fdef" ; done + xmlfile_def=$tmp_def + echo $xmlfile_def +else + xmlfile_def=$xmlfile +fi + +[ $inxml -eq 1 ] && grep "< *field *\([^ ].* \)*id *=" $xmlfield_def +[ $insrc -eq 1 ] && find $srcdir -name "*.[Ffh]90" -exec grep -iH "^[^\!]*call *iom_put *(" {} \; +[ $(( $insrc + $inxml )) -ge 1 ] && exit +# +#------------------------------------------------ +# +# list of file containing "CALL iom_put" in $srcdir +# +srclist=$( find $srcdir -name "*.[Ffh]90" -exec grep -il "^[^\!]*call *iom_put *(" {} \; ) +# +# list of variables used in "CALL iom_put" +# +badvarsrc=$( find $srcdir -name "*.[Ffh]90" -exec grep -i "^[^\!]*call *iom_put *(" {} \; | sed -e "s/.*iom_put *( *[\"\']\([^\"\']*\)[\"\'] *,.*/\1/" | grep -ic iom_put ) +if [ $badvarsrc -ne 0 ] +then + echo "The following call to iom_put cannot be checked" + echo + find $srcdir -name "*.[Ffh]90" -exec grep -i "^[^\!]*call *iom_put *(" {} \; | sed -e "s/.*iom_put *( *[\"\']\([^\"\']*\)[\"\'] *,.*/\1/" | grep -i iom_put | sort -d + echo +fi +varlistsrc=$( find $srcdir -name "*.[Ffh]90" -exec grep -i "^[^\!]*call *iom_put *(" {} \; | sed -e "s/.*iom_put *( *[\"\']\([^\"\']*\)[\"\'] *,.*/\1/" | grep -vi iom_put | sort -d ) +# +# list of variables defined in the xml file +# +varlistxml=$( grep "< *field *\([^ ].* \)*id *=" $xmlfield_def | sed -e "s/^.*< *field .*id *= *[\"\']\([^\"\']*\)[\"\'].*/\1/" | sort -d ) +# +# list of variables to be outputed in the xml file +# +varlistout=$( grep "< *field *\([^ ].* \)*field_ref *=" $xmlfile_def | sed -e "s/^.*< *field .*field_ref *= *[\"\']\([^\"\']*\)[\"\'].*/\1/" | sort -d ) +# +echo "--------------------------------------------------" +echo check if all iom_put found in $srcdir +echo have a corresponding variable definition in $xmlfield_def +echo "--------------------------------------------------" +for var in $varlistsrc +do + tst=$( echo " "$varlistxml" " | grep -c " $var " ) + if [ $tst -ne 1 ] + then + echo "problem with $var: $tst lines corresponding to its definition in $xmlfield_def, but defined in the code in" + for f in $srclist + do + grep -iH "^[^\!]*call *iom_put *( *[\"\']${var}[\"\'] *," $f + done + echo + fi +done +# +echo "--------------------------------------------------" +echo check if all variables defined in $xmlfile +echo have a corresponding \"call iom_put\" in sources found in $srcdir +echo "--------------------------------------------------" +# +for var in $varlistxml +do + found=$( echo " "$varlistsrc" " | grep -c " $var " ) + if [ $found -eq 0 ] + then + echo \"call iom_put\" not found for variable $var + grep "< *field * id *= *[\"\']${var}[\"\']" $xmlfile + echo + fi +done +# +echo "--------------------------------------------------" +echo ${xmlfile}: check if all variables to be outputed in files are really defined... +echo "--------------------------------------------------" +# +# list of variables defined in the xml file +for var in $varlistout +do + found=$( echo " "$varlistxml" " | grep -c " $var " ) + [ $found -eq 0 ] && echo variable to be outputed but not defined: $var +done + + + +exit diff --git a/V4.0/nemo_sources/tools/MISCELLANEOUS/icb_pp.py b/V4.0/nemo_sources/tools/MISCELLANEOUS/icb_pp.py new file mode 100755 index 0000000000000000000000000000000000000000..d594e00b2cf6b56236de13a0edf1e6584fe14b24 --- /dev/null +++ b/V4.0/nemo_sources/tools/MISCELLANEOUS/icb_pp.py @@ -0,0 +1,208 @@ +from netCDF4 import Dataset +from argparse import ArgumentParser +import numpy as np +import sys + +# +# Basic iceberg trajectory post-processing python script. +# This script collates iceberg trajectories from the distributed datasets written +# out by each processing region and rearranges the ragged arrays into contiguous +# streams for each unique iceberg. The output arrays are 2D (ntraj, ntimes) arrays. +# Note that some icebergs may only exist for a subset of the possible times. In these +# cases the missing instances are filled with invalid (NaN) values. +# +# Version 2.0 August 2017. Adapted to process all variables and retain original +# datatypes. (acc@noc.ac.uk) + +parser = ArgumentParser(description='produce collated trajectory file \ + from distributed output files, e.g. \ + \n python ./icb_pp.py \ + -t trajectory_icebergs_004248_ \ + -n 296 -o trajsout.nc' ) + +parser.add_argument('-t',dest='froot', + help='fileroot_of_distrbuted_data; root name \ + of distributed trajectory output (usually \ + completed with XXXX.nc, where XXXX is the \ + 4 digit processor number)', + default='trajectory_icebergs_004248_') + +parser.add_argument('-n',dest='fnum',help='number of distributed files to process', + type=int, default=None) + +parser.add_argument('-o',dest='fout', + help='collated_output_file; file name to receive \ + the collated trajectory data', default='trajsout.nc') + +args = parser.parse_args() + +default_used = 0 +if args.froot is None: + pathstart = 'trajectory_icebergs_004248_' + default_used = 1 +else: + pathstart = args.froot + +if args.fnum is None: + procnum = 0 + default_used = 1 +else: + procnum = args.fnum + +if args.fout is None: + pathout = 'trajsout.nc' + default_used = 1 +else: + pathout = args.fout + +if default_used == 1: + print('At least one default value will be used; command executing is:') + print('icb_pp.py -t ',pathstart,' -n ',procnum,' -o ',pathout) + +if procnum < 1: + print('Need some files to collate! procnum = ',procnum) + sys.exit(11) + +icu = [] +times = [] +# +# Loop through all distributed datasets to obtain the complete list +# of iceberg identification numbers and timesteps +# +for n in range(procnum): + nn = '%4.4d' % n + fw = Dataset(pathstart+nn+'.nc') + # keep a list of the variables in the first dataset + if n == 0: + varlist = fw.variables + # + # skip any files with no icebergs + if len(fw.dimensions['n']) > 0: + print pathstart+nn+'.nc' + ic = fw.variables['iceberg_number'][:,0] + ts = fw.variables['timestep'][:] + icv = np.unique(ic) + ts = np.unique(ts) + print('Min Max ts: ',ts.min(), ts.max()) + print('Number unique icebergs= ',icv.shape[0]) + icu.append(icv) + times.append(ts) + fw.close() +# +# Now flatten the lists and reduce to the unique spanning set +# +try: + icu = np.concatenate(icu) +except ValueError: + # No icebergs: create an empty output file. + print 'No icebergs in the model.' + fw = Dataset(pathstart+'0000.nc') + fo = Dataset(pathout, 'w', format='NETCDF4_CLASSIC') + ntrj = fo.createDimension('ntraj', None) + icbn = fo.createVariable('iceberg_number', 'i4',('ntraj')) + n = 0 + for key, value in varlist.iteritems() : + if key != "iceberg_number" : + print 'key is ',key + oout = fo.createVariable(key, value.dtype, ('ntraj'), + zlib=True, complevel=1) + oout.long_name = fw.variables[key].getncattr('long_name') + oout.units = fw.variables[key].getncattr('units') + n = n + 1 + fw.close() + fo.close() + sys.exit() + +icu = np.unique(icu) +times = np.concatenate(times) +times = np.unique(times) +ntraj = icu.shape[0] +print(ntraj, ' unique icebergs found across all datasets') +print('Icebergs ids range from: ',icu.min(), 'to: ',icu.max()) +print('times range from: ',times.min(), 'to: ', times.max()) +# +# Declare array to receive data from all files +# +nt = times.shape[0] +# +n=0 +for key, value in varlist.iteritems() : + if key != "iceberg_number" : + n = n + 1 +inarr = np.zeros((n, ntraj, nt)) +# +# initially fill with invalid data +# +inarr.fill(np.nan) +# +# Declare some lists to store variable names, types and long_name and units attributes +# iceberg_number gets special treatment +innam = [] +intyp = [] +inlngnam = [] +inunits = [] +for key, value in varlist.iteritems() : + if key != "iceberg_number" : + innam.append(key) +# +# reopen the first datset to collect variable attributes +# (long_name and units only) +# +nn = '%4.4d' % 0 +fw = Dataset(pathstart+nn+'.nc') +for key, value in varlist.iteritems() : + if key != "iceberg_number" : + intyp.append(fw.variables[key].dtype) + inlngnam.append(fw.variables[key].getncattr('long_name')) + inunits.append(fw.variables[key].getncattr('units')) +fw.close() +# +# loop through distributed datasets again, this time +# checking indices against icu and times lists and +# inserting data into the correct locations in the +# collated sets. +# +for n in range(procnum): + nn = '%4.4d' % n + fw = Dataset(pathstart+nn+'.nc') +# +# Note many distributed datafiles will contain no iceberg data +# so skip quickly over these + m = len(fw.dimensions['n']) + if m > 0: + inx = np.zeros(m, dtype=int) + tsx = np.zeros(m, dtype=int) + #print pathstart+nn+'.nc' + ic = fw.variables['iceberg_number'][:,0] + ts = fw.variables['timestep'][:] + for k in range(m): + inxx = np.where(icu == ic[k]) + inx[k] = inxx[0] + for k in range(m): + inxx = np.where(times == ts[k]) + tsx[k] = inxx[0] + n = 0 + for key, value in varlist.iteritems() : + if key != "iceberg_number" : + insmall = fw.variables[innam[n]][:] + inarr[n,inx[:],tsx[:]] = insmall[:] + n = n + 1 + fw.close() +# +# Finally create the output file and write out the collated sets +# +fo = Dataset(pathout, 'w', format='NETCDF4_CLASSIC') +ntrj = fo.createDimension('ntraj', ntraj) +nti = fo.createDimension('ntime', None) +icbn = fo.createVariable('iceberg_number', 'i4',('ntraj')) +icbn[:] = icu +n = 0 +for key, value in varlist.iteritems() : + if key != "iceberg_number" : + oout = fo.createVariable(innam[n], intyp[n], ('ntraj','ntime'), + zlib=True, complevel=1, chunksizes=(1,nt)) + oout[:,:] = inarr[n,:,:] + oout.long_name = inlngnam[n] + oout.units = inunits[n] + n = n + 1 +fo.close() diff --git a/V4.0/nemo_sources/tools/MISCELLANEOUS/make_usp_tar.sh b/V4.0/nemo_sources/tools/MISCELLANEOUS/make_usp_tar.sh new file mode 100755 index 0000000000000000000000000000000000000000..3c4de917bfc8dea019510a6765c2f22c02eb5825 --- /dev/null +++ b/V4.0/nemo_sources/tools/MISCELLANEOUS/make_usp_tar.sh @@ -0,0 +1,235 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# =============== +# make_usp_tar.sh +# =============== +# --------------- +# Fetch and tar a unsupported configuration setup. +# This script is only needed when target systems do +# not have wget access to the internet. To configure +# unsupported conigurations on these systems it will +# first be necessary to run this script on a system that +# does have access. Then copy access the resulting tar file, +# unpack and run the enclosed set_local_uspcfg script in a +# bash shell to complete the process. That script redefines/ +# defines wget as a bash function to perform local copies +# from this unpacked tarball. If you wish to create a new +# configuration based on this local copy of an unsupported +# configuration in future sessions then you may need to +# redefine wget again before running makenemo with the +# appropriate -u setting. A simple script: def_wget is included +# for such situations. +# --------------- +# SYNOPSIS +# ======== +# $ make_usp_tar.sh uspcfg.txt target_conf target_dir +# Note target_dir.tar will be created +# +# DESCRIPTION +# =========== +# - Extract target configuration details from uspcfg.txt +# - Create target directory +# - Recursively use wget to retrieve remote configuration files +# into target directory +# - Copy uspcfg.txt into target directory and alter remote paths +# to local (relative) versions +# - tar target_directory and remove originals +#---------------------------------------------------------------- +# +#---------------------------------------------------------------- +# Check the correct number of arguments have been provided +#---------------------------------------------------------------- +# + if [ "$#" != "3" ]; then + echo "Expected usage: make_usp_tar.sh uspcfg.txt target_conf target_dir" + exit + fi +# +#---------------------------------------------------------------- +# Check the named uspcfg.txt file exists +#---------------------------------------------------------------- +# + if [ ! -f $1 ]; then + echo "named uspcfg.txt file does not exist ($1); attempt abandoned" + exit + fi +# +#---------------------------------------------------------------- +# Check the requested configuration is listed in the named uspcfg.txt file +#---------------------------------------------------------------- +# + inthere=$( grep -c "$2" $1 ) + if [ "$inthere" -lt 1 ]; then + echo "requested configuration is not in named uspcfg.txt file ($2); attempt abandoned" + exit + fi +# +#---------------------------------------------------------------- +# Create the target directory if it does not already exist +# and cd into it +#---------------------------------------------------------------- +# + if [ ! -d $3 ]; then + mkdir $3 + else + echo "target directory already exists; attempt abandoned" + exit + fi + basedir=$(pwd) +# + cd ${3} +# +#---------------------------------------------------------------- +# Copy named uspcfg.txt file into target directory +#---------------------------------------------------------------- +# + cp $basedir/$1 . +# +#---------------------------------------------------------------- +# Extract information on target configuration and +# retrieve full file list from remote server +#---------------------------------------------------------------- +# + grep "$2 " $1 > ./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}') + wget ${REMOTE_CTL} -O remote_file.list +# +#---------------------------------------------------------------- +# Retrieve each remote file and create local directory structure +# At the same time prepare a local version of the control file +# by replacing http links with a string that will be replaced later +# with a local directory path +#---------------------------------------------------------------- +# + if [ -f remote_file.list ] ; then + cat remote_file.list | grep -v '^#' | + while + read remfile locfile + do + if [ $remfile == 'create_directory' ] ;then + mkdir $locfile + echo $remfile " " $locfile >> local_template.ctl + else + wget $remfile -O $locfile + remfile=$(echo $remfile | sed -e "s;.*$locfile;SET_LOCAL_DIRECTORY_HERE/$locfile;") + echo $remfile " " $locfile >> local_template.ctl + fi + done + else + echo "Unable to find remote_file.list. Attempt abandoned" + echo "Files may be left in "$(pwd) + exit + fi +# +#---------------------------------------------------------------- +# Construct a modified version of the named uspcfg.txt file +# First copy across all the other untouched configuration listed +#---------------------------------------------------------------- +# + grep -v "$2 " $1 > uspcfg_local_template.txt +# +#---------------------------------------------------------------- +# Now append the modified entry, replacing http links as before +#---------------------------------------------------------------- +# + cat cfg.tmp | sed -e "s;http.*$;SET_LOCAL_DIRECTORY_HERE/local.ctl;" >> uspcfg_local_template.txt +# +# +#---------------------------------------------------------------- +# Construct a script that can be used later to complete a local installation +#---------------------------------------------------------------- +# +cat > set_local_uspcfg << EOF +#!/bin/bash + if [ "\$( echo $SHELL | grep -c bash )" -lt 1 ]; then + echo "WARNING: This is only going to be effective in a bash shell" + echo "since it redefines the wget command as a bash function." + echo "(ignore this comment if you are in a bash shell)" + fi + basedir=\$(pwd) +# + echo "Enter full path to the CONFIG directory on your target system: " + read confdir +# +# Edit the local.ctl file to set the local directory path +# + sed -e "s;SET_LOCAL_DIRECTORY_HERE;\$basedir;" local_template.ctl > local.ctl +# +# Edit the uspcfg_local.txt file to set the local directory path +# + sed -e "s;SET_LOCAL_DIRECTORY_HERE;\$basedir;" uspcfg_local_template.txt > uspcfg_local.txt +# +# Install local versions in the named CONFIG directory +# + if [ -f \$confdir/uspcfg.txt ] && [ ! -L \$confdir/uspcfg.txt ]; then + mv \$confdir/uspcfg.txt \$confdir/uspcfg_remote.txt + echo "\$confdir/uspcfg.txt moved to \$confdir/uspcfg_remote.txt" + fi + if [ -f \$confdir/uspcfg_local.txt ]; then + echo "Existing uspcfg_local.txt file found in \$confdir" + echo "This has been moved to: "\$confdir/uspcfg_local.txt\$\$ + mv \$confdir/uspcfg_local.txt \$confdir/uspcfg_local.txt\$\$ + fi + mv uspcfg_local.txt \$confdir/uspcfg_local.txt + ln -s \$confdir/uspcfg_local.txt \$confdir/uspcfg.txt +# +# define/redefine the wget command +# +function wget { + if [ "\$2" != "-O" ]; then + echo "Expected wget usage: wget src -O dest" + echo "-O not found. No action taken" + else + cp \$1 \$3 + fi +} +export -f wget +EOF +#---------------------------------------------------------------- +# Construct a script that can be used later to just redefine wget +# in bash shell sessions +#---------------------------------------------------------------- +# +cat > def_wget << EOFC +#!/bin/bash + if [ "\$( echo $SHELL | grep -c bash )" -lt 1 ]; then + echo "WARNING: This is only going to be effective in a bash shell" + echo "since it redefines the wget command as a bash function." + echo "(ignore this comment if you are in a bash shell)" + fi +function wget { + if [ "\$2" != "-O" ]; then + echo "Expected wget usage: wget src -O dest" + echo "-O not found. No action taken" + else + cp \$1 \$3 + fi +} +export -f wget +EOFC +#---------------------------------------------------------------- +# Make sure these scripts have execute permission +#---------------------------------------------------------------- + chmod 755 set_local_uspcfg + chmod 755 def_wget +# +#---------------------------------------------------------------- +# Tidy up and tar the contents of the downloaded configuration +#---------------------------------------------------------------- + rm cfg.tmp + cd $basedir + tar cvf ${3}.tar $3 + echo ${3}.tar " file successfully created and prepared for local references. Move this" + echo "tar file to your target system, unpack and run the set_local_uspcfg script in a " + echo "bash shell to complete the process. This script redefines/defines wget as a bash" + echo "function to perform local copies from this unpacked tarball. If you wish to create" + echo "a new configuration based on this local copy of an unsupported configuration in " + echo "future sessions then you may need to rerun the def_wget script" +exit diff --git a/V4.0/nemo_sources/tools/MPP_PREP/README.rst b/V4.0/nemo_sources/tools/MPP_PREP/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..7e623cf119fa4307ac89b3d0b1d57ba49d5eba44 --- /dev/null +++ b/V4.0/nemo_sources/tools/MPP_PREP/README.rst @@ -0,0 +1,185 @@ +============ +MPP_PREP +============ + +Description +=========== +MPP_PREP proposes possible domain decompositions for a given +bathymetric file, which is particularly intersting when +we want to eliminate land-only domain. +All solution are proposed and written to output file. +The ratio between the effective number of computed +point and the total number of points in the domain is +given and is probably a major criteria for choosing a +domain decomposition. + +Tools mpp_optimiz_zoom_nc.exe as been tested on one eORCA12 and one eORCA025 configuration at trunk@10036 + +Tools mppopt_showproc_nc.exe has not been tested. + +Method +====== +Use mpp_init like code for setting up the decomposition +and evaluate the efficiency of the decomposition. + +How to compile it +================= +MPP_PREP is compiled in the same manner as all the other tools. +The compilation script is maketools and the option are very similar to makenemo. + +Here an example of how to compile MPP_PREP on the MetOffice XC40 HPC: + +.. code-block:: console + + $ ./maketools -n MPP_PREP -m XC40_METO + +Usage +===== + +the MPP_PREP executable is named mpp_optimiz_zoom_nc.exe. The input file needed are: + + * a netcdf file containing a variable with 0 on land and data > 0 on ocean (typically a bathymetry file) + + * a namelist to specify the number of vertical levels, netcdf input file, variable and dimension names (...). + A namelist template is available in the file 'namelist'. Default namelist is set up for input file domain_cfg.nc (output of Domaincfg tool) + and will find decomposition between 100 and 4000 processors. + +.. code-block:: console + + $ ./mpp_optimiz_zoom_nc.exe -h + usage : mpp_optimize [ -h ] [-keep jpni jpnj] [ -o file out ] + [ -modulo val ] [-r ratio] [-minocean procs] -n namelist + + PURPOSE : + This program is build to optimize the domain beakdown into + subdomain for mpp computing. + Once the grid size, and the land/sea mask is known, it looks + for all the possibilities within a range of setting parameters + and determine the optimal. + + Optimization is done with respect to the maximum number of + sea processors and to the maximum numbers of procs (nn_procmax) + + Optional optimization can be performed taking into account + the maximum available processor memory rn_ppmcal. This is + activated if ln_memchk is set true in the namelist + + Additional criteria can be given on the command line to reduce + the amount of possible choices. + + ARGUMENTS : + -n namelist : indicate the name of the namelist to use + + OPTIONS : + -h : print this help message + -keep jpni jpnj : print a file suitable for plotting, + corresponding to the given decomposition + -o output file : give the name of the output file + default is processor.layout + -modulo val : only retain decomposition whose total number + of util processors (sea) are a multiple of val + -r ratio : only retain decomposition with a ratio computed/global + less or equal to the given ratio + -minocean procs : only retain decomposition with a number of + ocean procs greater of equal to procs + + REQUIRED FILES : + A bathymetric file and an ad-hoc namelist are required. + The file name of the bathymetry is specified in the namelist + + OUTPUT : + processor.layout : an ascii file with all found possibilities + + SEE ALSO : + script screen.ksh helps a lot in the analysis of the output file. + + STOP + +Example +======= + +Here is an example of usage of ./mpp_optimiz_zoom_nc.exe on the the eORCA025 bathymetry. We keep in the output only domain decomposition with a ratio (computed/global) lower than 1, using namelist_eORCA025 and output the list of domain decomposition in processor.layout_eORCA025 + +.. code-block:: console + + $ ./mpp_optimiz_zoom_nc.exe -r 1 -n namelist_eORCA025 -o processor.layout_eORCA025 + + ocean/land file used is: domcfg_eORCA025.nc + variable used to find ocean domain is: bottom_level + Dimensions (jpi x jpj) are: 1442 x 1207 + + Loop over all the decompositions (can take a while) ... + + STOP + +The output for one specific decomposition contains this information: + +.. code-block:: console + + iresti= 14 irestj= 9 + --> Total number of domains 1612 + + jpni= 31 jpnj= 52 + jpi= 49 jpj= 26 + Number of ocean processors 1074 + Number of land processors 538 + Mean ocean coverage per domain 0.7542637596508307 + Minimum ocean coverage 7.849293761E-4 + Maximum ocean coverage 1. + nb of proc with coverage < 10 % 68 + nb of proc with coverage 10 < nb < 30 % 99 + nb of proc with coverage 30 < nb < 50 % 59 + Number of computed points 1368276 + Overhead of computed points -372218 + % sup (computed / global) 0.786142349 + +Sorting phase +============= +The processor.layout can be very long and hard to exploit. +To sort out what is the best model decomposition for a specific application, there is a suggestion at the end of the processor.layout file. Otherwise you can use the python script find_layout.py to dig into it. + +.. code-block:: console + + $ python2.7 find_layout.py + usage: find_layout.py [-h] -f layout_file --rmax max_ratio --noce min/max_noce + +Below an example to extract all decomposition with a ratio (computed/global) < 0.8 and a number of ocean domain between 300 and 350. All the decomposition fitting the criterions are listed. At the end, a summary of the one with the smallest ratio, the largest number of ocean domains and the smallest computed domain. + +.. code-block:: console + + $ python2.7 find_layout.py -f processor.layout_eORCA025 --rmax 0.8 --noce 300 350 + Domain decomposition 0 + domain decomposition (jpni, jpnj) = (13, 32) + number of ocean domain = 300 + ratio computed/global = 0.779089153 + domain size (jpi, jpj) = (113, 40) + ... + Domain decomposition 76 + domain decomposition (jpni, jpnj) = (37, 13) + number of ocean domain = 350 + ratio computed/global = 0.783254623 + domain size (jpi, jpj) = (41, 95) + + ===================================================================== + + Among the layouts fitting the constraint on : ratio (computed/global) < 0.8 and 300 <= number of ocean domain <= 350 + + 3 layouts are highlighted : + + Domain decomposition SMALLEST RATIO + domain decomposition (jpni, jpnj) = (24, 18) + number of ocean domain = 310 + ratio computed/global = 0.761956096 + domain size (jpi, jpj) = (62, 69) + + Domain decomposition LARGEST NUMBER OF OCEAN DOMAINS + domain decomposition (jpni, jpnj) = (21, 23) + number of ocean domain = 350 + ratio computed/global = 0.785265565 + domain size (jpi, jpj) = (71, 55) + + Domain decomposition SMALLEST COMPUTED DOMAIN + domain decomposition (jpni, jpnj) = (18, 27) + number of ocean domain = 350 + ratio computed/global = 0.775009871 + domain size (jpi, jpj) = (82, 47) diff --git a/V4.0/nemo_sources/tools/MPP_PREP/find_layout.py b/V4.0/nemo_sources/tools/MPP_PREP/find_layout.py new file mode 100644 index 0000000000000000000000000000000000000000..550fbd97c93f8471da0cc8cbccabcdcddf32a4f0 --- /dev/null +++ b/V4.0/nemo_sources/tools/MPP_PREP/find_layout.py @@ -0,0 +1,220 @@ +""" + script to sort and select processor layout from MPP_PREP output + wrote by P. Mathiot 10/2018 +""" + +# import module +from __future__ import print_function +import argparse +import sys + +# define class layout +class layout(object): + """ + Class containing all the information about a specific model layout + + Output: + self.jpnij = (i domain along i dimension, j domain along j dimension, total number of domain (land+ocean)) + self.nproc = (total number of domain (land+ocean), n ocean domain, nland domain) + self.jpij = (dimension along i, dimension along j) of a domain + self.ratio = (total computed point, overhead, ratio computed point / global) + """ + def __init__(self, txtlst): + """ + Initialisation of a layout class object: + + Input: list of string containing 1 layout description + extracted from the processor layout file + """ + self.jpnij = extract_jpnij(txtlst) # (jpni, jpnj, jpnij) + self.nproc = extract_nproc(txtlst) # (ntot, noce, nland) + self.jpij = extract_jpij(txtlst) # (jpi , jpj) + self.ratio = extract_point(txtlst) # (total computed point, overhead, ratio computed point / global) + + def test_criterion(self, rmax, nocemin, nocemax): + """ + function to decide if yes or no a specific layout has to be selected + Input: + float rmax: maximal ratio (computed/global) accepted + int nocemin and nocemax: range of number of ocean processor accepted + + output: logical + """ + if ( nocemin <= self.nproc[1] <= nocemax ) and ( self.ratio[2] <= rmax ): + return True + else: + return False + + def print_layout(self, cidx): + """ + function to print specific information about a specific layout + """ + print( 'Domain decomposition {}'.format(cidx) ) + print( 'domain decomposition (jpni, jpnj) = {}'.format((self.jpnij[0], self.jpnij[1])) ) + print( 'number of ocean domain = {}'.format(self.nproc[1]) ) + print( 'ratio computed/global = {}'.format(self.ratio[2]) ) + print( 'domain size (jpi, jpj) = {}'.format(self.jpij) ) + print('') + +# define sorting function +def noce_proc(elem): + """ + function used as key to sort list of layout + by number of ocean domain in the list sorting algorithm + """ + return elem.nproc[1] + +def ratio_proc(elem): + """ + function used as key to sort list of layout + by ratio (computed/global) in the list sorting algorithm + """ + return elem.ratio[2] + +def jpij_proc(elem): + """ + function used as key to sort list of layout + by domain size in the list sorting algorithm + """ + return elem.jpij[0]*elem.jpij[1] + +# txt extraction function to feed class layout +def extract_jpnij(txtlst): + """ + function to extract total number of domain + for a specific domain layout txt output + + Input: list of string containing 1 layout description + extracted from the processor layout file + + Output: tuple (jpni, jpnj, jpni*jpnj) + """ + jpnij = int(txtlst[1].split()[-1]) + ctmp = txtlst[3].split() + jpni = int(ctmp[1]) + jpnj = int(ctmp[3]) + return (jpni, jpnj, jpnij) + +def extract_nproc(txtlst): + """ + function to extract total number of ocean domain + for a specific domain layout txt output + + Input: list of string containing 1 layout description + extracted from the processor layout file + + Output: tuple (jpni*jpnj, n oce domain, n land domain) + """ + ntot = int(txtlst[1].split()[-1]) + noce = int(txtlst[5].split()[-1]) + nland = int(txtlst[6].split()[-1]) + return (ntot, noce, nland) + +def extract_jpij(txtlst): + """ + function to extract domain dimension + for a specific domain layout txt output + + Input: list of string containing 1 layout description + extracted from the processor layout file + + Output: tuple (jpi, jpj) + """ + ctmp = txtlst[4].split() + jpi = int(ctmp[1]) + jpj = int(ctmp[3]) + return (jpi, jpj) + +def extract_point(txtlst): + """ + function to extract ration (computed/global) + for a specific domain layout txt output + + Input: list of string containing 1 layout description + extracted from the processor layout file + + Output: tuple (total number of point, overhead, ratio (computed/global)) + """ + npoint = int(txtlst[13].split()[-1]) + noverh = int(txtlst[14].split()[-1]) + ratio = float(txtlst[15].split()[-1]) + return (npoint, noverh, ratio) + +# main +def main(): + """ + script to sort and select processor layout from MPP_PREP output based on user constrains + """ + + parser = argparse.ArgumentParser() + parser.add_argument("-f", metavar='layout_file' , help="names of domain layout file to sort", type=str, nargs=1, required=True) + parser.add_argument("--rmax", metavar='max_ratio' , help="max ratio allowed (computed/global)", type=float, nargs=1, required=True) + parser.add_argument("--noce", metavar='min/max_noce' , help="min and max number of ocean domain allowed", type=int, nargs=2, required=True) + + args = parser.parse_args() + + # read file + filein = args.f[0] + fid = open(filein,"r") #opens file with name of "test.txt" + txtdata = [] + for cline in fid: + txtdata.extend([cline]) + + # skip header and tail of file + txtdata = txtdata[4:-20] + + # loop on different domain decomposition + ilinepl = 17 # number of line of a specific decomposition + ilayout = 0 + lst_layout = [] + ratio_min = 9999.0 + noce_min = 9999999 + noce_max = 0 + for iline in range(0, len(txtdata)): + if iline % ilinepl == 0: + # initialise layout + conf_layout = layout( txtdata[iline:iline+ilinepl] ) + ratio_min = min( conf_layout.ratio[2], ratio_min ) + noce_min = min( conf_layout.nproc[1], noce_min ) + noce_max = max( conf_layout.nproc[1], noce_max ) + + # select layout based on condition + if conf_layout.test_criterion(args.rmax[0], args.noce[0], args.noce[1]): + ilayout = ilayout + 1 + lst_layout.extend([conf_layout]) + + if lst_layout == []: + print('') + print( 'E R R O R: constrains are too strong, no domain are found' ) + print('') + if ratio_min > args.rmax[0] : + print( 'min ratio is {} and you ask for a ratio smaller than {}'.format(ratio_min, args.rmax[0]) ) + if noce_min > args.noce[1] : + print( 'min ocean proc is {} and you ask for a number of ocean proc lower than {}'.format(noce_min, args.noce[1]) ) + if noce_max < args.noce[0] : + print( 'max ocean proc is {} and you ask for a number of ocean proc larger than {}'.format(noce_max, args.noce[0]) ) + print('') + sys.exit() + + lst_layout.sort(key=noce_proc) + for idx, ilayout in enumerate(lst_layout): + ilayout.print_layout(str(idx)) + + print( '=====================================================================' ) + print('') + print( 'Among the layouts fitting the constraint on : ratio (computed/global) < {} and {} <= number of ocean domain <= {}' \ + .format(args.rmax[0], args.noce[0], args.noce[1]) ) + print('') + print( ' 3 layouts are highlighted : ' ) + print('') + lst_layout.sort(key=ratio_proc) + lst_layout[0].print_layout('SMALLEST RATIO') +# + lst_layout.sort(key=noce_proc) + lst_layout[-1].print_layout('LARGEST NUMBER OF OCEAN DOMAINS') +# + lst_layout.sort(key=jpij_proc) + lst_layout[0].print_layout('SMALLEST COMPUTED DOMAIN') + +if __name__ == "__main__": + main() diff --git a/V4.0/nemo_sources/tools/MPP_PREP/mpp_nc.pdf b/V4.0/nemo_sources/tools/MPP_PREP/mpp_nc.pdf new file mode 100644 index 0000000000000000000000000000000000000000..cc64dce0271a88598d9c120ec9e8b0bae7d45c28 Binary files /dev/null and b/V4.0/nemo_sources/tools/MPP_PREP/mpp_nc.pdf differ diff --git a/V4.0/nemo_sources/tools/MPP_PREP/mpp_prep-1.0.tar.gz b/V4.0/nemo_sources/tools/MPP_PREP/mpp_prep-1.0.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..f34366f7f5fc39c8fd047bfb4687dbe996483921 Binary files /dev/null and b/V4.0/nemo_sources/tools/MPP_PREP/mpp_prep-1.0.tar.gz differ diff --git a/V4.0/nemo_sources/tools/MPP_PREP/namelist b/V4.0/nemo_sources/tools/MPP_PREP/namelist new file mode 100644 index 0000000000000000000000000000000000000000..2f184fabed4c7617c0b6ba74738fe4516eeeae94 --- /dev/null +++ b/V4.0/nemo_sources/tools/MPP_PREP/namelist @@ -0,0 +1,47 @@ +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MPP_OPTIMIZE namelist template +! ------------------------------- +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!''''''''''''''''''''''''''''''''''''''''' +! namspace spatial indexes +!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +&namspace + nn_jpk = 75 ! number of vertical level + nn_izoom = 1 ! i-index of point (1,1) of the zoomed region/ jpidta + nn_jzoom = 1 ! j-index of point (1,1) of the zoomed region/ jpjdta +/ +!''''''''''''''''''''''''''''''''''''' +! namproc +!'''''''''''''''''''''''''''''''''''' +&namproc + nn_procmax = 4000 ! maximum number of proc to look for + nn_procmin = 100 ! minimum number of proc + ln_memchk = .false. ! optimization of memory +/ +!'''''''''''''''''''''''''''''''''''''' +! namparam +!'''''''''''''''''''''''''''''''''''''' +&namparam + rn_ppmcal = 225000000. ! maximum memory for 1 processor + rn_ppmin = 0.4 ! minimum ratio for filling the available memory + rn_ppmax = 0.9 ! maximum ratio for filling the available memory +/ +!''''''''''''''''''''''''''''''''''''''' +! namfile of filename +!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +&namfile + cn_fbathy = 'domain_cfg.nc' ! bathy file name + cn_var = 'bottom_level' ! Bathy variable name + cn_x = 'x' ! bathy x dimension name + cn_y = 'y' ! bathy y dimension name + ln_zps = .true. ! partial step flag +/ +! +!'''''''''''''''''''''''''''''''''''''' +! namkeep option -keep. Specify the root name of the overdata file +!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +&namkeep + cn_fovdta = 'domain_cfg' ! Root for the overdata file name + ! complete name will be {covdta}.{jpni}x{jpnj}_{jpnij} +/ diff --git a/V4.0/nemo_sources/tools/MPP_PREP/src/mpp_optimiz_zoom_nc.f90 b/V4.0/nemo_sources/tools/MPP_PREP/src/mpp_optimiz_zoom_nc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6f01de42730105f5710540aa772cdd222915a5bb --- /dev/null +++ b/V4.0/nemo_sources/tools/MPP_PREP/src/mpp_optimiz_zoom_nc.f90 @@ -0,0 +1,535 @@ +PROGRAM mpp_optimize + !!====================================================================== + !! *** PROGRAM mpp_optimize *** + !!===================================================================== + !! ** Purpose : Propose possible domain decompositions for a given + !! bathymetric file, which is particularly intersting when + !! we want to eliminate land-only domain. + !! All solution are proposed and written to output file. + !! The ratio between the effective number of computed + !! point and the total number of points in the domain is + !! given and is probably a major criteria for choosing a + !! domain decomposition. + !! + !! ** Method : Use mpp_init like code for seting up the decomposition + !! and evaluate the efficiency of the decomposition. + !! History + !! original : 95-12 (Imbard M) for OPA8.1, CLIPPER + !! f90 : 03-06 (Molines JM), namelist as input + !! : 05-05 (Molines JM), bathy in ncdf + !! : 13-03 (Molines JM), Nemo-like coding and license. + !! : 18-10 (Mathiot P), upgrade the NEMO 4.0 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! routines : description + !!---------------------------------------------------------------------- + + + !!---------------------------------------------------------------------- + !! MPP-PREP, MEOM 2013 + !! $Id: mpp_optimiz_zoom_nc.f90 10335 2018-11-19 14:25:00Z mathiot $ + !! Copyright (c) 2013, J.-M. Molines + !! Software governed by the CeCILL licence (Licence/MPP-PREPCeCILL.txt) + !!---------------------------------------------------------------------- + USE netcdf + + IMPLICIT NONE + + INTEGER, PARAMETER :: jpreci=1 ,jprecj=1 !: overlap between processors + + ! Namelist declaration and definition + ! ----------------------------------- + INTEGER :: nn_procmax =250 !: maximum number of proc. (Read from namelist) + INTEGER :: nn_procmin = 1 !: maximum number of proc. (Read from namelist) + LOGICAL :: ln_memchk = .FALSE. ! add a memory constraint if true (obsolete) + NAMELIST /namproc/ nn_procmax, nn_procmin, ln_memchk + ! + INTEGER :: nn_jpk = 46 !: vertical levels + INTEGER :: nn_izoom = 1 !: I zoom indicator + INTEGER :: nn_jzoom = 1 !: J zoom indicator + NAMELIST /namspace/ nn_jpk, nn_izoom, nn_jzoom + ! + ! Following variables are used only if ln_memchk=.true. + REAL(KIND=4) :: required_memory, rppmpt !: not in namelist working array + REAL(KIND=4) :: rn_ppmcal = 225000000. !: maximum memory of one processor for a + !: given machine (in 8 byte words) + REAL(KIND=4) :: rn_ppmin = 0.4 !: minimum ratio to fill the memory + REAL(KIND=4) :: rn_ppmax = 0.9 !: maximum ratio to fill the memory + NAMELIST /namparam/ rn_ppmcal, rn_ppmin, rn_ppmax + ! + CHARACTER(LEN=80) :: cn_var='none' !: Variable name of the bathymetry + CHARACTER(LEN=80) :: cn_x='x' !: X dimension name + CHARACTER(LEN=80) :: cn_y='y' !: Y dimension name + CHARACTER(LEN=80) :: cn_fbathy !: File name of the netcdf bathymetry (namelist) + LOGICAL :: ln_zps=.FALSE. !: Logical flag for partial cells. + NAMELIST /namfile/ cn_fbathy, cn_var, cn_x, cn_y, ln_zps + ! + CHARACTER(LEN=80) :: cn_fovdta !: root file name for keep output + NAMELIST /namkeep/ cn_fovdta + ! + INTEGER :: numnam = 4 ! logical unit for namelist + INTEGER :: numout = 10 ! logical unit for output + INTEGER :: npiglo, npjglo ! domain size + INTEGER :: npidta, npjdta ! domain size + + INTEGER :: ji, jj, jni, jnj ! dummy loop index + INTEGER :: ii, ij, jjc ! dummy loop index + INTEGER :: narg, iargc, ijarg ! browsing command line + + ! Decomposition related arrays (using same meaning than in NEMO) + INTEGER, DIMENSION(:,:), ALLOCATABLE :: ilci, ilcj ,iimppt, ijmppt + INTEGER, DIMENSION(:) , ALLOCATABLE :: nlei_ocea, nldi_ocea + INTEGER, DIMENSION(:) , ALLOCATABLE :: nlej_ocea, nldj_ocea + INTEGER, DIMENSION(:) , ALLOCATABLE :: nlei_land, nldi_land + INTEGER, DIMENSION(:) , ALLOCATABLE :: nlej_land, nldj_land + INTEGER :: nimpp, njmpp + INTEGER :: nreci, nrecj + INTEGER :: ili, ilj + INTEGER :: jarea, iarea, iarea0 + INTEGER :: iresti, irestj + ! + INTEGER :: ioce, isurf !: number of ocean points cumulated, per_proc + INTEGER :: ioce_opt !: number of ocean points cumulated for optimal case + INTEGER :: nland, nocea, nvalid !: number of land, ocean, memory_valid procs + INTEGER :: nland_opt !: optimal number of land procs + INTEGER :: ii1, ii2, ij1, ij2 !: limit of subdomain in global domain + INTEGER :: jpimax, jpjmax !: size of sub domain + INTEGER :: jpimax_opt, jpjmax_opt !: size of sub domain for optimal case + INTEGER :: inf10, inf30, inf50 !: + INTEGER :: inf10_opt, inf30_opt, inf50_opt !: in optimal case + INTEGER :: npni_opt, npnj_opt !: optimal domain decomposition + + INTEGER :: iminproci, imaxproci !: limits of the processor loop + INTEGER :: iminprocj, imaxprocj !: can be reduded to nkeepi, nkeepj + + ! Saving criteria + REAL(KIND=4) :: ratio_min=99999. !: keep only decomposition with ration less than ratio_min + INTEGER :: nocea_min = 1 !: minimum number of ocean procs for saving + INTEGER :: nmodulo = 1 !: Only keep solution multiple of nmodulo + LOGICAL :: ll_criteria=.TRUE. !: + ! + REAL(KIND=4) :: oce_cover + REAL(KIND=4) :: oce_cover_min, oce_cover_max, ratio + REAL(KIND=4) :: oce_cover_min_opt, oce_cover_max_opt, ratio_opt + REAL(KIND=4), DIMENSION(:,:), ALLOCATABLE :: tmask ! npiglo x npjglo + REAL(KIND=4), DIMENSION(:,:), ALLOCATABLE :: bathy ! npidta x npjdta + + ! CDF stuff + INTEGER :: ncid, istatus, id + LOGICAL :: ll_good = .FALSE. + + CHARACTER(LEN=80) :: cf_namlist='namelist' + CHARACTER(LEN=80) :: cf_out='processor.layout' + CHARACTER(LEN=80) :: cdum ! dummy character variable + + ! Keep stuff + LOGICAL :: ll_keep = .FALSE. + INTEGER :: nkeepi, nkeepj !: for option -keep : the retained decomposition + ! + + !!---------------------------------------------------------------------- + narg=iargc() + ijarg=1 + IF ( narg == 0 ) THEN + PRINT *,' try mpp_optimize -h for instructions !' + STOP + ENDIF + ! + DO WHILE ( ijarg <= narg ) + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 + SELECT CASE ( cdum ) + CASE ('-h') + PRINT *,' usage : mpp_optimize [ -h ] [-keep jpni jpnj] [ -o file out ] ' + PRINT *,' [ -modulo val ] [-r ratio] [-minocean procs] -n namelist' + PRINT *,' ' + PRINT *,' PURPOSE :' + PRINT *,' This program is build to optimize the domain beakdown into' + PRINT *,' subdomain for mpp computing.' + PRINT *,' Once the grid size, and the land/sea mask is known, it looks' + PRINT *,' for all the possibilities within a range of setting parameters' + PRINT *,' and determine the optimal.' + PRINT *,'' + PRINT *,' Optimization is done with respect to the maximum number of' + PRINT *,' sea processors and to the maximum numbers of procs (nn_procmax)' + PRINT *,' ' + PRINT *,' Optional optimization can be performed taking into account' + PRINT *,' the maximum available processor memory rn_ppmcal. This is' + PRINT *,' activated if ln_memchk is set true in the namelist' + PRINT *,' ' + PRINT *,' Additional criteria can be given on the command line to reduce' + PRINT *,' the amount of possible choices.' + PRINT *,' ' + PRINT *,' ARGUMENTS :' + PRINT *,' -n namelist : indicate the name of the namelist to use' + PRINT *,' ' + PRINT *,' OPTIONS :' + PRINT *,' -h : print this help message' + PRINT *,' -keep jpni jpnj : print a file suitable for plotting,' + PRINT *,' corresponding to the given decomposition' + PRINT *,' -o output file : give the name of the output file' + PRINT *,' default is ',TRIM(cf_out) + PRINT *,' -modulo val : only retain decomposition whose total number' + PRINT *,' of util processors (sea) are a multiple of val' + PRINT *,' -r ratio : only retain decomposition with a ratio computed/global' + PRINT *,' less or equal to the given ratio' + PRINT *,' -minocean procs : only retain decomposition with a number of ' + PRINT *,' ocean procs greater of equal to procs' + PRINT *,' ' + PRINT *,' REQUIRED FILES :' + PRINT *,' A bathymetric file and an ad-hoc namelist are required.' + PRINT *,' The file name of the bathymetry is specified in the namelist' + PRINT *,' ' + PRINT *,' OUTPUT : ' + PRINT *,' ',TRIM(cf_out),' : an ascii file with all found possibilities' + PRINT *,' ' + STOP + CASE ('-n' ) + CALL getarg(ijarg,cf_namlist) ; ijarg=ijarg+1 + CASE ('-o' ) + CALL getarg(ijarg,cf_out) ; ijarg=ijarg+1 + CASE ('-keep' ) + ll_keep=.TRUE. + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 ; READ( cdum,*) nkeepi + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 ; READ( cdum,*) nkeepj + CASE ('-modulo' ) + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 ; READ( cdum,*) nmodulo + CASE ('-r' ) + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 ; READ( cdum,*) ratio_min + CASE ('-minocean' ) + CALL getarg(ijarg,cdum) ; ijarg=ijarg+1 ; READ( cdum,*) nocea_min + END SELECT + ENDDO + + ! Open and read the namelist + OPEN(numnam,FILE=cf_namlist) + REWIND(numnam) + READ(numnam,namspace) + + REWIND(numnam) + READ(numnam,namfile) + + REWIND(numnam) + READ(numnam,namparam) + + REWIND(numnam) + READ(numnam,namproc) + + REWIND(numnam) + READ(numnam,namkeep) ! only used for -keep option but still ... + CLOSE(numnam) + + ! estimated code size expressed in number of 3D arrays (valid for OPA8.1) to be tuned for OPA9.0/Nemo + rppmpt = 55.+73./nn_jpk + + ! Open bathy file an allocate required memory + INQUIRE( FILE=cn_fbathy, EXIST=ll_good ) + IF( ll_good ) THEN + istatus = NF90_OPEN(cn_fbathy, NF90_NOWRITE, ncid) + istatus = NF90_INQ_DIMID(ncid, cn_x, id) ; istatus = NF90_INQUIRE_DIMENSION(ncid, id, len=npiglo) + istatus = NF90_INQ_DIMID(ncid, cn_y, id) ; istatus = NF90_INQUIRE_DIMENSION(ncid, id, len=npjglo) + npidta = npiglo ; npjdta=npjglo + ELSE + PRINT *,' File missing : ', TRIM(cn_fbathy) + STOP 42 + ENDIF + + ALLOCATE (tmask(npiglo,npjglo), bathy(npidta,npjdta) ) + ALLOCATE (ilci(nn_procmax,nn_procmax), ilcj(nn_procmax,nn_procmax) ) + ALLOCATE (iimppt(nn_procmax,nn_procmax), ijmppt(nn_procmax,nn_procmax) ) + + ! Open output file for results + IF ( ll_keep ) THEN + nn_procmax = nkeepi*nkeepj ! reduce nn_procmax + ! File will be open later + ELSE + OPEN(numout,FILE=cf_out) + WRITE(numout,*) + WRITE(numout,*) ' Domain decomposition optimization ' + WRITE(numout,*) ' ----------------------------------' + WRITE(numout,*) + ENDIF + ! + ALLOCATE ( nlei_ocea(nn_procmax), nldi_ocea(nn_procmax), nlej_ocea(nn_procmax), nldj_ocea(nn_procmax) ) + ALLOCATE ( nlei_land(nn_procmax), nldi_land(nn_procmax), nlej_land(nn_procmax), nldj_land(nn_procmax) ) + ! + ! Read cdf bathy file + IF ( cn_var == 'none' ) THEN ! automatic detection of variable name according to partial step + IF ( ln_zps ) THEN ! partial steps + cn_var = 'Bathymetry' + ELSE + cn_var = 'Bathy_level' ! full steps + ENDIF + ENDIF + PRINT *,'' + PRINT *,' ocean/land file used is: ', TRIM(cn_fbathy) + PRINT *,' variable used to find ocean domain is: ', TRIM(cn_var) + PRINT *,' Dimensions (jpi x jpj) are: ',npiglo,'x',npjglo + PRINT *,'' + + istatus = NF90_INQ_VARID (ncid, cn_var, id) + istatus = NF90_GET_VAR (ncid, id, bathy) + istatus = NF90_CLOSE (ncid) + ! + ! Building the mask ( eventually on a smaller domain than the bathy) + tmask(:,:) = bathy(nn_izoom:nn_izoom+npiglo -1, nn_jzoom:nn_jzoom+npjglo -1) + + WHERE ( tmask > 0 ) + tmask = 1. + ELSEWHERE + tmask = 0. + ENDWHERE + + ! Main loop on processors + ! ------------------------ + ! initialization of working variables + npni_opt=1 ; npnj_opt=1 + jpimax_opt=npiglo ; jpjmax_opt=npjglo + nland_opt=0 + ioce_opt=0 + oce_cover_min_opt=0. ; oce_cover_max_opt=0. + inf10_opt=0 ; inf30_opt=0 ; inf50_opt=0 + ratio_opt=1. + + nvalid=0 ! counter for valid case ( ln_memchk true ) + IF ( ll_keep ) THEN + iminproci = nkeepi ; imaxproci = iminproci + iminprocj = nkeepj ; imaxprocj = iminprocj + ELSE + iminproci = 1 ; imaxproci = MIN( nn_procmax, npiglo ) + iminprocj = 1 ; imaxprocj = MIN( nn_procmax, npjglo ) + ENDIF + + ! loop on all decomposition a priori + PRINT *, 'Loop over all the decomposition (can take a while) ...' + PRINT *, '' + DO jni=iminproci, imaxproci + DO jnj=iminprocj, imaxprocj + ! Limitation of the maxumun number of PE's + IF ( jni*jnj <= nn_procmax .AND. jni*jnj >= nn_procmin ) THEN + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! + ! Partition : size of sub-domain + jpimax=(npiglo-2*jpreci + (jni-1))/jni + 2*jpreci + jpjmax=(npjglo-2*jprecj + (jnj-1))/jnj + 2*jprecj + ! + ! Memory optimization ? + IF ( ln_memchk ) THEN + required_memory=rppmpt*jpimax*jpjmax*nn_jpk + IF( required_memory > rn_ppmcal ) EXIT + IF( required_memory > rn_ppmax*rn_ppmcal .OR. required_memory < rn_ppmin*rn_ppmcal) EXIT + ENDIF + nvalid=nvalid+1 + ! + ! Position of each sub domain (jni x jni in total ) + nreci = 2*jpreci ; nrecj = 2*jprecj + iresti = 1 + MOD ( npiglo - nreci - 1 , jni ) ; irestj = 1 + MOD ( npjglo - nrecj - 1 , jnj ) + ! + ! + ilci( 1:iresti, 1:jnj) = jpimax + ilci(iresti+1:jni , 1:jnj) = jpimax-1 + + ilcj(1:jni, 1:irestj) = jpjmax + ilcj(1:jni,irestj+1:jnj ) = jpjmax-1 + + ! 2. Index arrays for subdomains + ! ------------------------------- + iimppt(1:jni, 1:jnj) = 1 + ijmppt(1:jni, 1:jnj) = 1 + IF( jni > 1 ) THEN + DO jj=1,jnj + DO ji=2,jni + iimppt(ji,jj)= iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci + END DO + END DO + ENDIF + + IF( jnj > 1 ) THEN + DO jj=2,jnj + DO ji=1,jni + ijmppt(ji,jj)= ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj + END DO + END DO + ENDIF + ! + ! Loop on each subdomain to look for land proportion + nland = 0 + nocea = 0 + ioce = 0 + oce_cover_min = 1.e+20 + oce_cover_max = -1.e+20 + inf10=0 + inf30=0 + inf50=0 + ! + ! 3. Subdomain description in the Regular Case + ! -------------------------------------------- + ! + DO jarea = 1, jni*jnj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,jni) + ij = 1 + iarea0/jni + ili = ilci(ii,ij) + ilj = ilcj(ii,ij) + + isurf = 0 + ! loop on inner point of sub-domain + DO jj=1, ilj + DO ji=1, ili + IF( tmask(ji + iimppt(ii,ij) - 1, jj + ijmppt(ii,ij) - 1) == 1 ) isurf=isurf+1 + END DO + END DO + + nimpp = iimppt(ii,ij) + njmpp = ijmppt(ii,ij) + ii1 = nimpp+jpreci ; ii2 = nimpp+ili-1 -jpreci + ij1 = njmpp+jprecj ; ij2 = njmpp+ilj-1 -jprecj + IF ( isurf == 0 ) THEN + nland = nland+1 + nldi_land(nland) = ii1 + nlei_land(nland) = ii2 + nldj_land(nland) = ij1 + nlej_land(nland) = ij2 + ELSE + nocea = nocea+1 + ioce = ioce + isurf + nldi_ocea(nocea) = ii1 + nlei_ocea(nocea) = ii2 + nldj_ocea(nocea) = ij1 + nlej_ocea(nocea) = ij2 + ENDIF + + ! ratio of wet points over total number of point per proc. + oce_cover = float(isurf)/float(jpimax*jpjmax) + + IF(oce_cover_min > oce_cover .AND. isurf /= 0) oce_cover_min=oce_cover + IF(oce_cover_max < oce_cover .AND. isurf /= 0) oce_cover_max=oce_cover + IF(oce_cover < 0.1 .AND. isurf /= 0) inf10=inf10+1 + IF(oce_cover < 0.3 .AND. isurf /= 0) inf30=inf30+1 + IF(oce_cover < 0.5 .AND. isurf /= 0) inf50=inf50+1 + ! + !END DO ! loop on processors + END DO ! loop on processors + ! + ratio=float(nocea)*float(jpimax*jpjmax)/float(npiglo*npjglo) + + ! criteria for printing results + ll_criteria = ( ( MOD ( nocea, nmodulo ) == 0 ) .AND. & + & ( ratio <= ratio_min ) .AND. & + & ( nocea >= nocea_min ) ) + IF ( ll_keep ) THEN ! the loop in done only once ! + WRITE(cdum,'(a,"-",i3.3,"x",i3.3,"_",i4.4)') TRIM(cn_fovdta), nkeepi, nkeepj, nocea + OPEN(numout, file=cdum ) + WRITE(numout,'("# ocean ",i5)') nocea + DO jjc=1, nocea + WRITE(numout,'("#",i5)') jjc + WRITE(numout,'(2i5)') nldi_ocea(jjc)-1+nn_izoom-1, nldj_ocea(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_ocea(jjc)+1+nn_izoom-1, nldj_ocea(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_ocea(jjc)+1+nn_izoom-1, nlej_ocea(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nldi_ocea(jjc)-1+nn_izoom-1, nlej_ocea(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nldi_ocea(jjc)-1+nn_izoom-1, nldj_ocea(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') 9999, 9999 + ENDDO + ! + WRITE(numout,'("# land ",i5)') nland + DO jjc=1, nland + WRITE(numout,'("# land ",i5)') jjc + WRITE(numout,'(2i5)') nldi_land(jjc)-1+nn_izoom-1, nldj_land(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_land(jjc)+1+nn_izoom-1, nldj_land(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_land(jjc)+1+nn_izoom-1, nlej_land(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nldi_land(jjc)-1+nn_izoom-1, nlej_land(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nldi_land(jjc)-1+nn_izoom-1, nldj_land(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_land(jjc)+1+nn_izoom-1, nlej_land(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nldi_land(jjc)-1+nn_izoom-1, nlej_land(jjc)+1+nn_jzoom -1 + WRITE(numout,'(2i5)') nlei_land(jjc)+1+nn_izoom-1, nldj_land(jjc)-1+nn_jzoom -1 + WRITE(numout,'(2i5)') 9999, 9999 + ENDDO + ! + ELSE + IF ( ll_criteria ) THEN + WRITE(numout,*) ' iresti=',iresti,' irestj=',irestj + WRITE(numout,*) '--> Total number of domains ',jni*jnj + WRITE(numout,*) ' ' + WRITE(numout,*) ' jpni=',jni ,' jpnj=',jnj + WRITE(numout,*) ' jpi= ',jpimax ,' jpj= ',jpjmax + WRITE(numout,*) ' Number of ocean processors ', nocea + WRITE(numout,*) ' Number of land processors ', nland + WRITE(numout,*) ' Mean ocean coverage per domain ', float(ioce)/float(nocea)/float(jpimax*jpjmax) + WRITE(numout,*) ' Minimum ocean coverage ', oce_cover_min + WRITE(numout,*) ' Maximum ocean coverage ', oce_cover_max + WRITE(numout,*) ' nb of proc with coverage < 10 % ', inf10 + WRITE(numout,*) ' nb of proc with coverage 10 < nb < 30 % ', inf30 - inf10 + WRITE(numout,*) ' nb of proc with coverage 30 < nb < 50 % ', inf50 - inf30 + WRITE(numout,*) ' Number of computed points ', nocea*jpimax*jpjmax + WRITE(numout,*) ' Overhead of computed points ', nocea*jpimax*jpjmax-npiglo*npjglo + WRITE(numout,*) ' % sup (computed / global) ', ratio + WRITE(numout,*) + ENDIF ! note that indication of optimum does not take modulo into account (for information) + ! + ! Look for optimum + IF( nland > nland_opt ) THEN + npni_opt = jni + npnj_opt = jnj + jpimax_opt = jpimax + jpjmax_opt = jpjmax + nland_opt = nland + ioce_opt = ioce + oce_cover_min_opt = oce_cover_min + oce_cover_max_opt = oce_cover_max + inf10_opt = inf10 + inf30_opt = inf30 + inf50_opt = inf50 + ratio_opt = ratio + ELSE IF( nland == nland_opt .AND. ratio_opt < ratio) THEN + npni_opt = jni + npnj_opt = jnj + jpimax_opt = jpimax + jpjmax_opt = jpjmax + ioce_opt = ioce + oce_cover_min_opt = oce_cover_min + oce_cover_max_opt = oce_cover_max + inf10_opt = inf10 + inf30_opt = inf30 + inf50_opt = inf50 + ratio_opt = ratio + ENDIF + ENDIF + ENDIF + END DO + END DO + ! + ! print optimal result + IF ( .NOT. ll_keep ) THEN + IF ( nvalid == 0 ) THEN + WRITE(numout,*) ' no possible choice ...' + WRITE(numout,*) + WRITE(numout,*) 'insufficient number of processors for the available memory' + STOP + ENDIF + + WRITE(numout,*) ' Optimal choice' + WRITE(numout,*) ' ==============' + WRITE(numout,*) + WRITE(numout,*) '--> Total number of domains ',npni_opt*npnj_opt + WRITE(numout,*) ' ' + WRITE(numout,*) ' jpni=',npni_opt ,' jpnj=',npnj_opt + WRITE(numout,*) ' jpi= ',jpimax_opt ,' jpj= ',jpjmax_opt + WRITE(numout,*) + WRITE(numout,*) ' Number of ocean processors ', npni_opt*npnj_opt-nland_opt + WRITE(numout,*) ' Number of land processors ', nland_opt + WRITE(numout,*) ' Mean ocean coverage ', float(ioce_opt)/float(npni_opt*npnj_opt-nland_opt)/float(jpimax_opt*jpjmax_opt) + WRITE(numout,*) ' Minimum ocean coverage ', oce_cover_min_opt + WRITE(numout,*) ' Maximum ocean coverage ', oce_cover_max_opt + WRITE(numout,*) ' nb of proc with coverage < 10 % ', inf10_opt + WRITE(numout,*) ' nb of proc with coverage 10 < nb < 30 % ', inf30_opt - inf10_opt + WRITE(numout,*) ' nb of proc with coverage 30 < nb < 50 % ', inf50_opt - inf30_opt + WRITE(numout,*) ' Number of computed points ', (npni_opt*npnj_opt-nland_opt)*jpimax_opt*jpjmax_opt + WRITE(numout,*) ' Overhead of computed points ', (npni_opt*npnj_opt-nland_opt)*jpimax_opt*jpjmax_opt-npiglo*npjglo + WRITE(numout,*) ' % sup (computed / global) ', ratio_opt + WRITE(numout,*) + ENDIF + CLOSE(numout) + ! + STOP +END PROGRAM mpp_optimize diff --git a/V4.0/nemo_sources/tools/MPP_PREP/src/mppopt_showproc_nc.f90 b/V4.0/nemo_sources/tools/MPP_PREP/src/mppopt_showproc_nc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dfd38b7c7f0830171102e90468510e131fc7a22b --- /dev/null +++ b/V4.0/nemo_sources/tools/MPP_PREP/src/mppopt_showproc_nc.f90 @@ -0,0 +1,452 @@ +PROGRAM mppopt_showproc_nc + !!--------------------------------------------------------------------- + !! + !! PROGRAM MPP_showproc_nc + !! *********************** + !! + !! PURPOSE : + !! --------- + !! Build a ascii file (suitable for the overlay function of + !! chart) holding the chosen domain decomposition, formely + !! determined by mpp_opatimize_nc. + !! It takes the same namelist than mpp_optimize_nc, with + !! the jpni, jpnj given in the namelist (NAMKEEP) + !! + !! + !! The output file is called from a root name in the namelist + !! (covdta) with the jpni, jpnj, and jpnij added to the name. + !! MODIFICATIONS: + !! -------------- + !! original : 95-12 (Imbard M) + !! modif pour chart : 98-12 ( J.M. Molines) + !! 26/05/2005 : English documentation (partial ..) JMM + !!---------------------------------------------------------------------- + ! + USE netcdf + IMPLICIT NONE + ! + INTEGER :: jprocx=250 + ! + INTEGER :: jpmem=0 + ! + ! les dimensions du modele + ! + INTEGER :: jpk,jpiglo,jpjglo, jpidta, jpjdta + NAMELIST /namspace/ jpk,jpiglo,jpjglo, jpidta, jpjdta,nizoom,njzoom + NAMELIST /namproc/ jprocx, jpmem + + INTEGER :: jpni,jpnj, jpnij + CHARACTER(LEN=80) :: covdta, cdum + NAMELIST /namkeep/ jpni,jpnj,covdta + + CHARACTER(LEN=80) :: cbathy + LOGICAL :: ln_zps=.false. + NAMELIST /namfile / cbathy, ln_zps + !! + ! quelques parametres + ! + INTEGER :: jpnix,jpnjx + ! + INTEGER,PARAMETER :: jpreci=1,jprecj=1 + ! + ! les dimensions de la memoire du modele et du calculateur (T3E) + ! + REAL(KIND=4) :: ppmpt , & + ppmcal = 1000000000., & + ppmin = 0.4, & + ppmax = 1.0 + ! Aleph + ! PARAMETER(ppmcal=16000000.) + !Brodie + ! PARAMETER(ppmcal=250000000.) + ! Uqbar + ! PARAMETER(ppmcal=3750000000.) + ! Zahir + ! PARAMETER(ppmcal=1000000000.) + NAMELIST /namparam/ ppmcal, ppmin, ppmax + + + ! + INTEGER,PARAMETER :: iumout=8, numnam=4, iumbat=11 + INTEGER :: ji,jj,jn,jni,jnj,jni2,jnj2 + INTEGER :: ifreq,il1,il2 + INTEGER :: ii,iim,ij,ijm,imoy,iost,iresti,irestj,isurf,ivide + INTEGER :: iilb,ijlb,ireci,irecj,in + INTEGER :: ipi,ipj + INTEGER :: inf10,inf30,inf50,iptx,isw + INTEGER :: iii,iij,iiii,iijj,iimoy,iinf10,iinf30,iinf50 + ! + INTEGER,DIMENSION(:,:),ALLOCATABLE :: ibathy ! jpidta -jpjdta + INTEGER,DIMENSION(:,:),ALLOCATABLE :: ippdi, ippdj ,iidom, ijdom + INTEGER,DIMENSION(:) ,ALLOCATABLE :: nlei, nldi,nlej,nldj,ICOUNT + INTEGER,DIMENSION(:) ,ALLOCATABLE :: nleiv, nldiv,nlejv,nldjv + INTEGER :: jjc, nizoom, njzoom + ! + REAL(KIND=4) :: zmin,zmax,zper,zmem + REAL(KIND=4) :: zzmin,zzmax,zperx + REAL(KIND=4),DIMENSION(:,:),ALLOCATABLE :: zmask, zdta, & ! jpiglo -jpjglo + zlamt, zphit + REAL(KIND=4),DIMENSION(:),ALLOCATABLE :: zdept ! jpk + LOGICAL :: llbon, lwp=.true. + CHARACTER(LEN=80) :: clvar + INTEGER :: numout=6, itime, ipk, istep, inum + REAL(KIND=4) :: zdt, zdate0 + ! CDF stuff + INTEGER :: ncid, ivarid, istatus + + ! + ! + ! + ! 0. Initialisation + ! ----------------- + ! + OPEN(numnam,FILE='namelist') + + REWIND(numnam) + READ(numnam,namspace) + ALLOCATE ( ibathy(jpidta,jpjdta), zmask(jpiglo,jpjglo) ,zdta(jpidta,jpjdta)) + ALLOCATE ( zlamt(jpidta,jpjdta), zphit(jpidta,jpjdta)) + + REWIND(numnam) + READ(numnam,namparam) + + REWIND(numnam) + READ(numnam,namproc) + + ppmpt = 55.+73./jpk + jpnix = jprocx ; jpnjx=jprocx + + ALLOCATE (ippdi(jpnix,jpnjx), ippdj(jpnix,jpnjx) ) + ALLOCATE (iidom(jpnix,jpnjx), ijdom(jpnix,jpnjx) ) + ALLOCATE (nlei(jprocx), nldi(jprocx) ) + ALLOCATE (nlej(jprocx), nldj(jprocx) ) +! empty processors + ALLOCATE (nleiv(jprocx), nldiv(jprocx) ) + ALLOCATE (nlejv(jprocx), nldjv(jprocx) ) + ALLOCATE (ICOUNT(jprocx), zdept(jpk) ) + + REWIND(numnam) + READ(numnam,namfile) + + REWIND(numnam) + READ(numnam,namkeep) + + WRITE(iumout,*) + WRITE(iumout,*) ' optimisation de la partition' + WRITE(iumout,*) ' ----------------------------' + WRITE(iumout,*) + + ! + ! Lecture de la bathymetrie + ! + ! open the file + IF ( ln_zps ) THEN + clvar = 'Bathymetry' + + ELSE + clvar = 'Bathy_level' + ENDIF + + INQUIRE( FILE=cbathy, EXIST=llbon ) + IF( llbon ) THEN + istatus=NF90_OPEN(cbathy,NF90_NOWRITE,ncid) + istatus=NF90_INQ_VARID(ncid,clvar,ivarid) + istatus=NF90_GET_VAR(ncid,ivarid,zdta) + istatus=NF90_CLOSE(ncid) + ELSE + WRITE(numout,*)' mppini_2 : unable to read the file', cbathy + ENDIF + + ! land/sea mask over the global/zoom domain + +! imask(:,:)=1 +! WHERE ( zdta(jpizoom:jpiglo+jpizoom-1, jpjzoom:jpjglo+jpjzoom-1) == 0.e0 ) imask = 0 + ibathy(:,:)=zdta(:,:) + + DO jj=1,jpjglo + DO ji=1,jpiglo + zmask(ji,jj) = float(ibathy(ji+nizoom -1,jj+njzoom -1)) + END DO + END DO + DO jj=1,jpjglo + DO ji=1,jpiglo + zmask(ji,jj)= min(REAL(1.,kind=4),max(REAL(0.,kind=4),zmask(ji,jj))) + END DO + END DO + print *,'Nombre de pts mer :', sum(zmask) + ! + ! + ! 1. Boucle sur le nombre de processeurs + ! --------------------------------------- + ! + iii=1 + iij=1 + iiii=jpiglo + iijj=jpjglo + iptx=0 + iimoy=0 + zzmin=0. + zzmax=0. + iinf10=0 + iinf30=0 + iinf50=0 + zperx=1. + in=0 +! Next loop corresponds to just 1 case, which is the one kept from mpp_optimize. + DO jni=jpni,jpni + DO jnj=jpnj,jpnj + ! + ! Limitation nombre de pe + ! + IF(jni*jnj.GT.jprocx) go to 1000 + ! + ! Partition + ! + ipi=(jpiglo-2*jpreci + (jni-1))/jni + 2*jpreci + ipj=(jpjglo-2*jprecj + (jnj-1))/jnj + 2*jprecj + ! + ! Optimisation memoire ? + ! + isw=0 + zmem=ppmpt*ipi*ipj*jpk + jpiglo*jpjglo + IF(zmem.GT.ppmcal) go to 1000 + IF(jpmem.EQ.1) THEN + IF(zmem.GT.ppmax*ppmcal.OR.zmem.LT.ppmin*ppmcal) isw=1 + ENDIF + IF(isw.EQ.1) go to 1000 + in=in+1 + ! + WRITE(iumout,*) '--> nombre de processeurs ',jni*jnj + WRITE(iumout,*) ' ' + WRITE(iumout,*) " jpni=",jni ," jpnj=",jnj + WRITE(iumout,*) " jpi= ",ipi ," jpj= ",ipj + zper=(jni*jnj*ipi*ipj)/float(jpiglo*jpjglo) + WRITE(iumout,*) " rapport jpnij*domain/global domain ",zper + ! + ! Coin en bas a gauche de chaque processeur + ! + iilb=1 + ijlb=1 + ireci=2*jpreci + irecj=2*jprecj + iresti = MOD ( jpiglo - ireci , jni ) + irestj = MOD ( jpjglo - irecj , jnj ) + ! + IF (iresti.EQ.0) iresti = jni + DO jj=1,jnj + DO ji=1,iresti + ippdi(ji,jj) = ipi + END DO + DO ji=iresti+1,jni + ippdi(ji,jj) = ipi -1 + END DO + END DO + IF (irestj.EQ.0) irestj = jnj + DO ji=1,jni + DO jj=1,irestj + ippdj(ji,jj) = ipj + END DO + DO jj=irestj+1,jnj + ippdj(ji,jj) = ipj -1 + END DO + END DO + DO jj=1,jnj + DO ji=1,jni + iidom(ji,jj)=iilb + ijdom(ji,jj)=ijlb + END DO + END DO + ! + ! 2. Boucle sur les processeurs + ! ------------------------------ + ! + ivide=0 + imoy=0 + zmin=1.e+20 + zmax=-1.e+20 + inf10=0 + inf30=0 + inf50=0 + jjc=0 + ! + DO jni2=1,jni + DO jnj2=1,jnj + + IF(jni.GT.1)THEN + DO jj=1,jnj + DO ji=2,jni + iidom(ji,jj)=iidom(ji-1,jj)+ippdi(ji-1,jj)-ireci + END DO + END DO + iilb=iidom(jni2,jnj2) + ENDIF + IF(jnj.GT.1)THEN + DO jj=2,jnj + DO ji=1,jni + ijdom(ji,jj)=ijdom(ji,jj-1)+ippdj(ji,jj-1)-irecj + END DO + END DO + ijlb=ijdom(jni2,jnj2) + ENDIF + + ! Check wet points over the entire domain to preserve the MPI communication stencil + isurf=0 + DO jj=1,ippdj(jni2,jnj2) + DO ji=1,ippdi(jni2,jnj2) + IF(zmask(ji+iilb-1,jj+ijlb-1).EQ.1.) isurf=isurf+1 + END DO + END DO + + IF(isurf.EQ.0) THEN + ivide=ivide+1 + nldiv(ivide)=jpreci+iilb + nleiv(ivide)=iilb+ippdi(jni2,jnj2)-1-jpreci + nldjv(ivide)=jprecj+ijlb + nlejv(ivide)=ijlb+ippdj(jni2,jnj2)-1-jprecj + ELSE + imoy=imoy+isurf + jjc=jjc+1 + icount(jjc)=isurf + nldi(jjc)=jpreci+iilb + nlei(jjc)=iilb+ippdi(jni2,jnj2)-1-jpreci + nldj(jjc)=jprecj+ijlb + nlej(jjc)=ijlb+ippdj(jni2,jnj2)-1-jprecj + ENDIF + zper=float(isurf)/float(ipi*ipj) + IF(zmin.GT.zper.AND.isurf.NE.0) zmin=zper + IF(zmax.LT.zper.AND.isurf.NE.0) zmax=zper + IF(zper.LT.0.1.AND.isurf.NE.0) inf10=inf10+1 + IF(zper.LT.0.3.AND.isurf.NE.0) inf30=inf30+1 + IF(zper.LT.0.5.AND.isurf.NE.0) inf50=inf50+1 + ! + ! + ! 3. Fin de boucle sur les processeurs, impression + ! ------------------------------------------------ + ! + END DO + END DO + WRITE(iumout,*) ' nombre de processeurs ',jni*jnj + WRITE(iumout,*) ' nombre de processeurs mer ',jni*jnj-ivide + WRITE(iumout,*) ' nombre de processeurs terre ',ivide + WRITE(iumout,*) ' moyenne de recouvrement ',float(imoy)/float(jni*jnj-ivide)/float(ipi*ipj) + WRITE(iumout,*) ' minimum de recouvrement ',zmin + WRITE(iumout,*) ' maximum de recouvrement ',zmax + WRITE(iumout,*) ' nb de p recouvrement < 10 % ',inf10 + WRITE(iumout,*) ' nb de p 10 < nb < 30 % ',inf30-inf10 + WRITE(iumout,*) ' nb de p 30 < nb < 50 % ',inf50-inf10-inf30 + WRITE(iumout,*) ' nombre de points integres ',(jni*jnj-ivide)*ipi*ipj + WRITE(iumout,*) ' nbr de pts supplementaires ',(jni*jnj-ivide)*ipi*ipj-jpiglo*jpjglo + zper=float((jni*jnj-ivide))*float(ipi*ipj)/float(jpiglo*jpjglo) + WRITE(iumout,*) ' % sup ',zper + WRITE(iumout,*) + WRITE(iumout,*) ' PROCESSORS WITH LESS THAN 100 WATER POINTS' + + WRITE(cdum,'(a,1h-,i3.3,1hx,i3.3,1h_,i3.3)') TRIM(covdta),jpni,jpnj,jni*jnj -ivide + OPEN (10,file=cdum) + WRITE(10,'(a,i5)')'#',jni*jnj -ivide + DO jjc=1,jni*jnj-ivide + WRITE(10,'(a,i5)')'#',jjc + WRITE(10,'(2i5)')nldi(jjc)-1+nizoom-1,nldj(jjc)-1+njzoom -1 + WRITE(10,'(2i5)')nlei(jjc)+1+nizoom-1,nldj(jjc)-1+njzoom -1 + WRITE(10,'(2i5)')nlei(jjc)+1+nizoom-1,nlej(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nldi(jjc)-1+nizoom-1,nlej(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nldi(jjc)-1+nizoom-1,nldj(jjc)-1+njzoom -1 + WRITE(10,'(2i5)') 9999,9999 + IF (icount(jjc).LT.100) THEN + WRITE(iumout,*)' proc ji=',jjc,' water points:', icount(jjc) + WRITE(iumout,*) ' ji from ',nldi(jjc), ' to :',nlei(jjc) + WRITE(iumout,*) ' jj / mask value for all ji' + DO jj=nldj(jjc),nlej(jjc) + WRITE(iumout,900) jj,(INT(zmask(ji,jj)),ji=nldi(jjc),nlei(jjc)) + ENDDO +900 FORMAT(1x,i4,1x,9(10i1,1x)) + ENDIF + ENDDO + WRITE(10,'(a,i5)')'# vides:',ivide + DO jjc=1,ivide + WRITE(10,'(a,i5)')'# vide ',jjc + WRITE(10,'(2i5)')nldiv(jjc)-1+nizoom-1,nldjv(jjc)-1+njzoom -1 + WRITE(10,'(2i5)')nleiv(jjc)+1+nizoom-1,nldjv(jjc)-1+njzoom -1 + WRITE(10,'(2i5)')nleiv(jjc)+1+nizoom-1,nlejv(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nldiv(jjc)-1+nizoom-1,nlejv(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nldiv(jjc)-1+nizoom-1,nldjv(jjc)-1+njzoom -1 + WRITE(10,'(2i5)')nleiv(jjc)+1+nizoom-1,nlejv(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nldiv(jjc)-1+nizoom-1,nlejv(jjc)+1+njzoom -1 + WRITE(10,'(2i5)')nleiv(jjc)+1+nizoom-1,nldjv(jjc)-1+njzoom -1 + WRITE(10,'(2i5)') 9999,9999 + END DO + + ! + ! + ! 4. Recherche de l optimum + ! ------------------------- + ! + IF(ivide.GT.iptx) THEN + iii=jni + iij=jnj + iiii=ipi + iijj=ipj + iptx=ivide + iimoy=imoy + zzmin=zmin + zzmax=zmax + iinf10=inf10 + iinf30=inf30 + iinf50=inf50 + zperx=zper + ELSE IF(ivide.EQ.iptx.AND.zperx.LT.zper) THEN + iii=jni + iij=jnj + iiii=ipi + iijj=ipj + iimoy=imoy + zzmin=zmin + zzmax=zmax + iinf10=inf10 + iinf30=inf30 + iinf50=inf50 + zperx=zper + ENDIF + ! + ! 5. Fin de boucle sur le nombre de processeurs + ! --------------------------------------------- + ! +1000 CONTINUE + END DO + END DO + ! + ! + ! 6. Affichage resultat + ! --------------------- + ! + IF(in.EQ.0) THEN + WRITE(iumout,*) ' le choix n a pas pu etre fait ' + WRITE(iumout,*) + WRITE(iumout,*) 'le nombre de processeurs maximum est insuffisant' + STOP + ENDIF + WRITE(iumout,*) ' choix optimum' + WRITE(iumout,*) ' =============' + WRITE(iumout,*) + WRITE(iumout,*) '--> nombre de processeurs ',iii*iij + WRITE(iumout,*) ' ' + WRITE(iumout,*) " jpni=",iii ," jpnj=",iij + WRITE(iumout,*) " jpi= ",iiii ," jpj= ",iijj + WRITE(iumout,*) + WRITE(iumout,*) ' nombre de processeurs mer ',iii*iij-iptx + WRITE(iumout,*) ' nombre de processeurs terre ',iptx + WRITE(iumout,*) ' moyenne de recouvrement ',float(iimoy)/float(iii*iij-iptx)/float(iiii*iijj) + WRITE(iumout,*) ' minimum de recouvrement ',zzmin + WRITE(iumout,*) ' maximum de recouvrement ',zzmax + WRITE(iumout,*) ' nb de p recouvrement < 10 % ',iinf10 + WRITE(iumout,*) ' nb de p 10 < nb < 30 % ',iinf30-iinf10 + WRITE(iumout,*) ' nb de p 30 < nb < 50 % ',iinf50-iinf10-iinf30 + WRITE(iumout,*) ' nombre de points integres ',(iii*iij-iptx)*iiii*iijj + WRITE(iumout,*) ' nbr de pts supplementaires ',(iii*iij-iptx)*iiii*iijj-jpiglo*jpjglo + WRITE(iumout,*) ' % sup ',zperx + WRITE(iumout,*) + ! + ! + ! + STOP +END PROGRAM mppopt_showproc_nc diff --git a/V4.0/nemo_sources/tools/NESTING/README b/V4.0/nemo_sources/tools/NESTING/README new file mode 100644 index 0000000000000000000000000000000000000000..aed448b0e583a4fe70bf168b2d7b5362c3adc81a --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/README @@ -0,0 +1,70 @@ +============================================================= +How to build a doubly nested configuration such as AGRIF_DEMO +============================================================= + +::::::::::::::::::::::::::::::::::::::::::::::::: +1) Files needed from root (parent) grid +::::::::::::::::::::::::::::::::::::::::::::::::: +- coordinates.nc +- bathy_meter.nc +- bathymetry database (For example GEBCO 2014 dataset) + + +::::::::::::::::::::::::::::::::::::::::::::::::: +2) Compile the tool +::::::::::::::::::::::::::::::::::::::::::::::::: + +$NEMOPATH/NEMOGCM/TOOLS/maketools -n NESTING -m X64_ADA -j 4 + +It creates 5 executables: +- agrif_create_coordinates.exe +- agrif_create_bathy.exe +- agrif_create_restart.exe +- agrif_create_restart_trc.exe +- agrif_create_data.exe + + +::::::::::::::::::::::::::::::::::::::::::::::::: +3) Create coordinates and bathymetries +::::::::::::::::::::::::::::::::::::::::::::::::: + +a) agrif_create_coordinates.exe namelist_nordic1 + It creates level 1 child grid coordinates: 1_coordinates.nc + +b) agrif_create_bathy.exe namelist_nordic1 + It creates level 1 child grid bathymetry: 1_bathymeter.nc + It updates parent grid bathymetry: bathy_updated.nc + +c) agrif_create_coordinates.exe namelist_nordic2 + It creates level 2 child grid coordinates: 2_coordinates.nc + +d) agrif_create_bathy.exe namelist_nordic2 + It creates level 2 child grid bathymetry: 2_bathymeter.nc + It updates level 1 child grid bathymetry: 1_bathy_updated.nc + +e) agrif_create_bathy.exe namelist_nordic1_update + It updates parent grid bathymetry: bathy_updated_parent.nc + +Note: This last step takes into account both levels 1 and 2 bathymetries to update the parent grid bathymetry + to make sure that volumes match between child grids and parent grid. + To only perform an update as in step e), i.e. without interpolation, one has to set in the namelist: + - elevation_database = 1_bathy_updated.nc + - type_bathy_interp = 2 + +** Files needed for your model to run: + - bathy_updated_parent.nc + coordinates.nc + - 1_bathy_updated.nc + 1_coordinates.nc + - 2_bathy_meter.nc + 2_coordinates.nc + + +::::::::::::::::::::::::::::::::::::::::::::::::: +4) Create data +::::::::::::::::::::::::::::::::::::::::::::::::: + +a) agrif_create_data.exe namelist_nordic1 + It creates level 1 child grid data: 1_chlorophyll.nc etc + +b) agrif_create_data.exe namelist_nordic2 + It creates level 2 child grid data: 2_chlorophyll.nc etc + + diff --git a/V4.0/nemo_sources/tools/NESTING/namelist_nordic1 b/V4.0/nemo_sources/tools/NESTING/namelist_nordic1 new file mode 100644 index 0000000000000000000000000000000000000000..4da3eb55733ab179fac803ce6bd1b6f837cc520b --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/namelist_nordic1 @@ -0,0 +1,107 @@ +&input_output + iom_activated = .true. +/ + +&coarse_grid_files + parent_coordinate_file = 'coordinates.nc' + parent_bathy_level = 'meshmask.nc' + parent_level_name = 'mbathy' + parent_bathy_meter = 'bathy_meter.nc' + parent_meter_name = 'Bathymetry' + parent_domcfg_out = 'domain_cfg.nc' + parent_jperio = 4 +/ + +&bathymetry + new_topo = .true. + elevation_database = 'GEBCO_2014_2D.nc' + elevation_name = 'elevation' + smoothing = .true. + smoothing_factor = 0.6 + ln_agrif_domain = .true. + npt_connect = 2 ! default = 3 + npt_copy = 2 ! default = 2 + removeclosedseas = .true. + type_bathy_interp = 0 + rn_hmin = -3 +/ + +&nesting + imin = 122 + imax = 153 + jmin = 110 + jmax = 143 + rho = 4 + rhot = 4 + nbghostcellsfine = 3 + bathy_update = .true. + parent_bathy_meter_updated = 'bathy_updated.nc' + parent_domcfg_updated = 'domain_cfg_updated.nc' +/ + +&vertical_grid + ln_e3_dep = .true. + ppkth = 21.4333619793800 + ppacr = 3 + ppdzmin = 0 + pphmax = 0 + psur = -4762.96143546300 + pa0 = 255.58049070440 + pa1 = 245.58132232490 + N = 31 + ldbletanh = .false. + pa2 = 0 + ppkth2 = 0 + ppacr2 = 0 +/ + +&partial_cells + partial_steps = .true. + e3zps_min = 20. + e3zps_rat = 0.1 +/ + +&nemo_coarse_grid + jpizoom = 1 + jpjzoom = 1 +/ +&forcing_files + FLX_FILES = + 'data_1m_salinity_nomask.nc', + 'data_1m_potential_temperature_nomask.nc', + 'geothermal_heating.nc' + 'mixing_power_bot.nc', + 'mixing_power_pyc.nc', + 'mixing_power_cri.nc', + 'chlorophyll.nc' +/ + +&interp + VAR_INTERP = + 'votemper/bilinear', + 'vosaline/bilinear', + 'heatflow/bilinear' + 'field/bilinear', + 'field/bilinear', + 'field/bilinear', + 'CHLA/bilinear' +/ + +&restart + restart_file = 'restart.nc' + shlat = 0 + dimg = false + dimg_output_file = 'test_dimg' + adatrj = 360.25 + interp_type = 'bilinear' +/ + +&restart_trc + restart_trc_file = 'restart_trc.nc' + interp_type = 'bilinear' +/ + +&restart_ice + restart_ice_file = 'restart_ice.nc' + interp_type = 'bilinear' +/ diff --git a/V4.0/nemo_sources/tools/NESTING/namelist_nordic1_update b/V4.0/nemo_sources/tools/NESTING/namelist_nordic1_update new file mode 100644 index 0000000000000000000000000000000000000000..99a4904dd7566470e3a3e5dae03d5fbc0b01accb --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/namelist_nordic1_update @@ -0,0 +1,108 @@ +&input_output + iom_activated = .true. +/ + +&coarse_grid_files + parent_coordinate_file = 'coordinates.nc' + parent_bathy_level = 'meshmask.nc' + parent_level_name = 'mbathy' + parent_bathy_meter = 'bathy_meter.nc' + parent_meter_name = 'Bathymetry' + parent_domcfg_out = 'domain_cfg.nc' + parent_jperio = 4 +/ + +&bathymetry + new_topo = .true. + elevation_database = '1_bathy_updated.nc' + elevation_name = 'Bathymetry' + smoothing = .true. + smoothing_factor = 0.6 + ln_agrif_domain = .true. + npt_connect = 2 + npt_copy = 2 + removeclosedseas = .true. + type_bathy_interp = 2 + rn_hmin = -3 +/ + +&nesting + imin = 122 + imax = 153 + jmin = 110 + jmax = 143 + rho = 4 + rhot = 4 + nbghostcellsfine = 3 + bathy_update = .true. + parent_bathy_meter_updated = 'bathy_updated_parent.nc' + parent_domcfg_updated = 'domain_cfg_updated_parent.nc' +/ + +&vertical_grid + ln_e3_dep = .true. + ppkth = 21.4333619793800 + ppacr = 3 + ppdzmin = 0 + pphmax = 0 + psur = -4762.96143546300 + pa0 = 255.58049070440 + pa1 = 245.58132232490 + N = 31 + ldbletanh = .false. + pa2 = 0 + ppkth2 = 0 + ppacr2 = 0 +/ + +&partial_cells + partial_steps = .true. + e3zps_min = 20. + e3zps_rat = 0.1 +/ + +&nemo_coarse_grid + jpizoom = 1 + jpjzoom = 1 +/ + +&forcing_files + FLX_FILES = + 'data_1m_salinity_nomask.nc', + 'data_1m_potential_temperature_nomask.nc', + 'geothermal_heating.nc' + 'mixing_power_bot.nc', + 'mixing_power_pyc.nc', + 'mixing_power_cri.nc', + 'chlorophyll.nc' +/ + +&interp + VAR_INTERP = + 'votemper/bilinear', + 'vosaline/bilinear', + 'heatflow/bilinear' + 'field/bilinear', + 'field/bilinear', + 'field/bilinear', + 'CHLA/bilinear' +/ + +&restart + restart_file = 'restart.nc' + shlat = 0 + dimg = false + dimg_output_file = 'test_dimg' + adatrj = 360.25 + interp_type = 'bilinear' +/ + +&restart_trc + restart_trc_file = 'restart_trc.nc' + interp_type = 'bilinear' +/ + +&restart_ice + restart_ice_file = 'restart_ice.nc' + interp_type = 'bilinear' +/ diff --git a/V4.0/nemo_sources/tools/NESTING/namelist_nordic2 b/V4.0/nemo_sources/tools/NESTING/namelist_nordic2 new file mode 100644 index 0000000000000000000000000000000000000000..2fd265d772a12e45c71a3845b510d62099c29516 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/namelist_nordic2 @@ -0,0 +1,108 @@ +&input_output + iom_activated = .true. +/ + +&coarse_grid_files + parent_coordinate_file = '1_coordinates.nc' + parent_bathy_level = '1_meshmask.nc' + parent_level_name = 'mbathy' + parent_bathy_meter = '1_bathy_meter.nc' + parent_meter_name = 'Bathymetry' + parent_domcfg_out = '1_domain_cfg.nc' + parent_jperio = 0 +/ + +&bathymetry + new_topo = .true. + elevation_database = 'GEBCO_2014_2D.nc' + elevation_name = 'elevation' + smoothing = .true. + smoothing_factor = 0.6 + ln_agrif_domain = .true. + npt_connect = 2 + npt_copy = 2 + removeclosedseas = .true. + type_bathy_interp = 0 + rn_hmin = -3 +/ + +&nesting + imin = 38 + imax = 80 + jmin = 71 + jmax = 111 + rho = 3 + rhot = 3 + nbghostcellsfine = 3 + bathy_update = .true. + parent_bathy_meter_updated = '1_bathy_updated.nc' + parent_domcfg_updated = '1_domain_cfg_updated.nc' +/ + +&vertical_grid + ln_e3_dep = .true. + ppkth = 21.4333619793800 + ppacr = 3 + ppdzmin = 0 + pphmax = 0 + psur = -4762.96143546300 + pa0 = 255.58049070440 + pa1 = 245.58132232490 + N = 31 + ldbletanh = .false. + pa2 = 0 + ppkth2 = 0 + ppacr2 = 0 +/ + +&partial_cells + partial_steps = .true. + e3zps_min = 20. + e3zps_rat = 0.1 +/ + +&nemo_coarse_grid + jpizoom = 1 + jpjzoom = 1 +/ + +&forcing_files + FLX_FILES = + '1_data_1m_salinity_nomask.nc', + '1_data_1m_potential_temperature_nomask.nc', + '1_geothermal_heating.nc' + '1_mixing_power_bot.nc', + '1_mixing_power_pyc.nc', + '1_mixing_power_cri.nc', + '1_chlorophyll.nc' +/ + +&interp + VAR_INTERP = + 'votemper/bilinear', + 'vosaline/bilinear', + 'heatflow/bilinear' + 'field/bilinear', + 'field/bilinear', + 'field/bilinear', + 'CHLA/bilinear' +/ + +&restart + restart_file = 'restart.nc' + shlat = 0 + dimg = false + dimg_output_file = 'test_dimg' + adatrj = 360.25 + interp_type = 'bilinear' +/ + +&restart_trc + restart_trc_file = 'restart_trc.nc' + interp_type = 'bilinear' +/ + +&restart_ice + restart_ice_file = 'restart_ice.nc' + interp_type = 'bilinear' +/ diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_connect_topo.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_connect_topo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4e4793e886eb535ed60fae716e738d188b389b0e --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_connect_topo.f90 @@ -0,0 +1,948 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! Laurent Debreu (Laurent.Debreu@imag.fr) * +!************************************************************************ +! +!Smoothing procedures : Pierrick Penven 2004 +! +MODULE agrif_connect_topo + ! + USE agrif_types + ! + IMPLICIT NONE + ! +CONTAINS + ! + ! + !************************************************************************ + ! * + ! MODULE CONNECT_TOPO * + ! * + ! module containing subroutine used for : * + ! - Parent-Child bathymetry connection * + ! - Bathymetry smoothing * + ! - Meters to levels conversion * + ! - Parent Bathymetry update * + ! * + !************************************************************************ + ! + !**************************************************************** + ! subroutine init_constant_bathy * + ! * + ! * + ! - input : * + ! coarse_bathy : coarse grid bathymetry * + ! - ouput : * + ! bathy_fin_constant : coarse bathymetry on fine grid * + ! * + !**************************************************************** + ! + SUBROUTINE init_constant_bathy(coarse_bathy,bathy_fin_constant) + ! + IMPLICIT NONE + ! + INTEGER :: i,j,ii,jj,ji + INTEGER :: jpt,ipt,diff,indx,indy,bornex,borney,bornex2,borney2 + INTEGER :: jdeb,ideb,ifin,jfin + REAL*8, DIMENSION(:,:) :: coarse_bathy + REAL*8, DIMENSION(:,:),POINTER :: bathy_fin_constant + TYPE(Coordinates) :: Grid + ! + IF( ln_agrif_domain ) THEN + ! + diff = 0 + IF(MOD(rho,2) .EQ. 0) diff = 1 + ! + indx = 1 + nbghostcellsfine + CEILING(irafx/2.0) + diff + indy = 1 + nbghostcellsfine + CEILING(irafy/2.0) + diff + bornex = 1+nbghostcellsfine + CEILING(irafx/2.0) + diff - irafx + borney = 1+nbghostcellsfine + CEILING(irafy/2.0) + diff - irafy + bornex2 = nxfin - (nbghostcellsfine) + irafx - CEILING(irafx/2.0) + borney2 = nyfin - (nbghostcellsfine) + irafy - CEILING(irafy/2.0) + ! + ALLOCATE(bathy_fin_constant(bornex-FLOOR(irafx/2.0):bornex2+FLOOR(irafx/2.0), & + borney-FLOOR(irafy/2.0):borney2+FLOOR(irafy/2.0))) + ! + DO j = borney,borney2,irafy + + jpt = jmin + 1 + nbghostcellsfine + (j-indy)/irafy + IF(j<=1) jpt = jmin + 1 + + DO i = bornex,bornex2,irafx + + ipt = imin + 1 + nbghostcellsfine + (i-indx)/irafx + IF(i<=1) ipt = imin + 1 + ! + DO jj = j-FLOOR(irafy/2.0),j+FLOOR(irafy/2.0)-diff + DO ii = i-FLOOR(irafx/2.0),i+FLOOR(irafx/2.0)-diff + + bathy_fin_constant(ii,jj) = coarse_bathy(ipt,jpt) + + END DO + END DO + + END DO + END DO + + ELSE + + ALLOCATE(bathy_fin_constant(1:nxfin,1:nyfin)) + + DO j = 1,nyfin-irafy+1,irafy + jpt = jmin + FLOOR( (j - 1.) / irafy ) + ! + DO i = 1,nxfin-irafx+1,irafx + ipt = imin + FLOOR( (i - 1.) / irafx ) + ! + bathy_fin_constant(i:i+irafx-1,j:j+irafy-1) = coarse_bathy(ipt,jpt) + ! + END DO + END DO + + ENDIF + ! + ! + END SUBROUTINE init_constant_bathy + ! + !**************************************************************** + ! subroutine meter_to_levels * + ! * + ! subroutine to convert bathymetry in meters to bathymetry * + ! in vertical levels * + ! * + ! - input/output : * + ! Grid : grid where conversion is required * + ! * + !various input parameters come from namelist.input files * + !**************************************************************** + ! + SUBROUTINE meter_to_levels(Grid) + ! + IMPLICIT NONE + ! + REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin,zmax + TYPE(Coordinates) :: Grid + INTEGER :: i,j + INTEGER, DIMENSION(1) :: k + INTEGER :: k1,ji,jj,jpi,jpj + REAL*8, POINTER, DIMENSION(:) :: gdepw,gdept,e3w,e3t + ! + WRITE(*,*) 'convert bathymetry from etopo to vertical levels' + ! + jpi = SIZE(Grid%bathy_meter,1) + jpj = SIZE(Grid%bathy_meter,2) + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + za1=( ppdzmin - pphmax / (N-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & + * ( LOG( COSH( (N - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(N-1) + DO i = 1, N + gdepw(i) = ( i - 1 ) * za1 + gdept(i) = ( i - 0.5 ) * za1 + e3w (i) = za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,N + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) + e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,N + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) + e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & + & + za2 * TANH( (i-zkth2) / zacr2 ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + ! + gdepw(1) = 0.0 + ! + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, N-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(N) = e3t(N-1) + + DO i = 2, N + e3w(i) = gdept(i) - gdept(i-1) + END DO + e3w(1 ) = 2. * (gdept(1) - gdepw(1)) + END IF + ! + zmax = gdepw(N) + e3t(N) + IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level + ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zmin = gdepw(i+1) + ! + IF ( .NOT. ASSOCIATED(Grid%bathy_level)) & + ALLOCATE(Grid%bathy_level(jpi,jpj)) + ! + Grid%bathy_level = N-1 + ! + DO jj = 1, jpj + DO ji= 1, jpi + IF( Grid%bathy_meter(ji,jj) <= 0. ) & + Grid%bathy_level(ji,jj) = INT( Grid%bathy_meter(ji,jj) ) + END DO + END DO + ! + DO jj = 1, jpj + DO ji= 1, jpi + IF( Grid%bathy_meter(ji,jj) <= 0. ) THEN + Grid%bathy_meter(ji,jj) = 0.e0 + ELSE + Grid%bathy_meter(ji,jj) = MAX( Grid%bathy_meter(ji,jj), zmin ) + Grid%bathy_meter(ji,jj) = MIN( Grid%bathy_meter(ji,jj), zmax ) + ENDIF + END DO + END DO + ! + ! + ! + DO jj = 1,jpj + DO ji = 1,jpi + ! + IF (Grid%bathy_meter(ji,jj) .EQ. 0.0 ) THEN + Grid%bathy_level(ji,jj)=0 + ELSE + ! + k1=2 ! clem: minimum levels = 2 ??? + DO WHILE (k1 .LT. (N-1)) + IF ((Grid%bathy_meter(ji,jj).GE.gdepw(k1)) & + .AND.(Grid%bathy_meter(ji,jj).LE.gdepw(k1+1))) EXIT + k1=k1+1 + END DO + Grid%bathy_level(ji,jj)=k1 + ! + ENDIF + ! + END DO + END DO + ! + END SUBROUTINE meter_to_levels + ! + !! + !**************************************************************** + ! subroutine levels_to_meter * + ! * + ! subroutine to convert bathymetry in meters to bathymetry * + ! in vertical levels * + ! * + ! - input/output : * + ! Grid : grid where conversion is required * + ! * + !various input parameters come from namelist.input files * + !**************************************************************** + ! + SUBROUTINE levels_to_meter(Grid) + ! + IMPLICIT NONE + ! + REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin,zmax + TYPE(Coordinates) :: Grid + INTEGER :: i,j + INTEGER, DIMENSION(1) :: k + INTEGER :: k1,ji,jj,jpi,jpj + REAL*8, POINTER, DIMENSION(:) :: gdepw,gdept,e3w,e3t + ! + WRITE(*,*) 'convert bathymetry in meters for smoothing' + ! + jpi = SIZE(Grid%bathy_level,1) + jpj = SIZE(Grid%bathy_level,2) + ! + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + za1=( ppdzmin - pphmax / (N-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & + * ( LOG( COSH( (N - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(N-1) + DO i = 1, N + gdepw(i) = ( i - 1 ) * za1 + gdept(i) = ( i - 0.5 ) * za1 + e3w (i) = za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,N + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) + e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,N + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) + e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & + & + za2 * TANH( (i-zkth2) / zacr2 ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + ! + gdepw(1) = 0.0 + ! + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, N-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(N) = e3t(N-1) + + DO i = 2, N + e3w(i) = gdept(i) - gdept(i-1) + END DO + e3w(1 ) = 2. * (gdept(1) - gdepw(1)) + END IF + ! + IF(.NOT. ASSOCIATED(Grid%bathy_meter)) THEN + ALLOCATE(Grid%bathy_meter(jpi,jpj)) + ELSE + IF( ANY(SHAPE(Grid%bathy_meter)/=(/jpi,jpj/)) ) THEN + DEALLOCATE(Grid%bathy_meter) + ALLOCATE(Grid%bathy_meter(jpi,jpj)) + ENDIF + ENDIF + ! + DO jj = 1, jpj + DO ji= 1, jpi + ! + Grid%bathy_meter(ji,jj) = gdepw( INT( Grid%bathy_level(ji,jj) ) + 1 ) + ! + END DO + END DO + ! + END SUBROUTINE levels_to_meter + ! + + !**************************************************************** + ! subroutine smooth_topo * + ! * + ! subroutine to smooth a given bathymetry (in meters) * + ! hanning filter is used (smoothing criterion : rfactor) * + ! * + ! - input/output : * + ! h : bathymetry * + ! * + !various input parameters are stored in namelist.input files * + !**************************************************************** + ! + SUBROUTINE smooth_topo(h,nbiter) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h + REAL*8 :: hmin,cff,nu,r + REAL*8, DIMENSION(:,:), ALLOCATABLE :: rx,ry,cx,cy,f_x,f_y + INTEGER :: Mm,Mmm,Lm,Lmm,M,L,nbiter,i,j + REAL*8,DIMENSION(:,:),ALLOCATABLE :: maskedtopo + ! + M = SIZE(h,1) + L = SIZE(h,2) + ! + ALLOCATE(cx(M,L),cy(M,L)) + ALLOCATE(rx(M,L),ry(M,L)) + ALLOCATE(f_x(M,L),f_y(M,L)) + ALLOCATE(maskedtopo(M,L)) + ! + WRITE(*,*) '' + WRITE(*,*) 'smooth the topography (Hanning filter)' + WRITE(*,*) 'slope parameter = ',smoothing_factor + ! + hmin = 1.1 + WHERE(h <= hmin) + h = hmin + END WHERE + ! + WHERE (h == hmin) + maskedtopo = 0. + ELSEWHERE + maskedtopo = 1. + END WHERE + ! + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + cff = 0.8 + nu = 3.0/16.0 + rx=0. + ry=0. + CALL rfact(h,rx,ry,maskedtopo) + r = MAX(MAXVAL(rx),MAXVAL(ry)) + h = LOG(h) + nbiter = 0 + ! + DO WHILE (r.GT.smoothing_factor .AND. nbiter < 500 ) + ! + nbiter=nbiter+1 + WHERE(rx > cff*smoothing_factor) + cx = 1 + ELSEWHERE + cx = 0 + END WHERE + CALL hanningx(cx,maskedtopo) + WHERE(ry > cff*smoothing_factor) + cy = 1 + ELSEWHERE + cy = 0 + END WHERE + CALL hanningy(cy,maskedtopo) + CALL FX(h,f_x,cx,maskedtopo) + CALL FY(h,f_y,cy,maskedtopo) + h(2:Mm,2:Lm) = h(2:Mm,2:Lm) + maskedtopo(2:Mm,2:Lm)*nu * & + ((f_x(2:Mm,3:L)-f_x(2:Mm,2:Lm)) + & + (f_y(3:M,2:Lm)-f_y(2:Mm,2:Lm))) + CALL rfact(EXP(h),rx,ry,maskedtopo) + r = MAX(MAXVAL(rx(2:Mm,2:L)),MAXVAL(ry(2:M,2:Lm))) + ! + END DO + ! + WRITE(*,*) 'iterations = ',nbiter + WRITE(*,*) '' + h = EXP(h) + WHERE( ABS(h-hmin) <= 0.001 ) + h = 0. + END WHERE + DEALLOCATE(rx,ry,cx,cy,f_x,f_y,maskedtopo) + ! + END SUBROUTINE smooth_topo + ! + !************************************************************************ + ! subroutine hanning(bathy_meter) + !************************************************************************ + ! + SUBROUTINE hanning(h,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h,maskedtopo + ! + INTEGER :: Mm,Mmm,Lm,Lmm,M,L + ! + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + ! + h(2:Mm,2:Lm) = maskedtopo(2:Mm,2:Lm)*0.125*( h(1:Mmm,2:Lm) + & + h(3:M,2:Lm) + & + h(2:Mm,1:Lmm) + & + h(2:Mm,3:L) + & + 4*h(2:Mm,2:Lm))+(1.-maskedtopo(2:Mm,2:Lm))*h(2:Mm,2:Lm) + ! + END SUBROUTINE hanning + ! + !************************************************************************ + ! subroutine hanningx(bathy_meter) + !************************************************************************ + ! + SUBROUTINE hanningx(h,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h,maskedtopo + REAL*8, DIMENSION(:,:), ALLOCATABLE :: htemp + ! + INTEGER :: Mm,Mmm,Lm,Lmm,M,L + INTEGER :: i,j + ! + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + + ALLOCATE(htemp(M,L)) + ! + htemp = h + DO j=3,Lm + DO i=2,Mm + IF ((maskedtopo(i,j)*maskedtopo(i,j-1)) .NE.0.) THEN + h(i,j)=0.125*(htemp(i-1,j)+htemp(i+1,j) & + +htemp(i,j+1)+htemp(i,j-1)+4.*htemp(i,j)) + ENDIF + ENDDO + ENDDO + j=2 + DO i=2,Mm + IF ((maskedtopo(i,j)*maskedtopo(i,j-1)) .NE.0.) THEN + h(i,j)=0.25*(htemp(i+1,j)+htemp(i-1,j)+2.*htemp(i,j)) + ENDIF + ENDDO + j=L + DO i=2,Mm + IF ((maskedtopo(i,j)*maskedtopo(i,j-1)) .NE.0.) THEN + h(i,j)=0.25*(htemp(i+1,j)+htemp(i-1,j)+2.*htemp(i,j)) + ENDIF + ENDDO + DEALLOCATE(htemp) + ! + END SUBROUTINE hanningx + + !************************************************************************ + ! subroutine hanning(bathy_meter) + !************************************************************************ + ! + SUBROUTINE hanningy(h,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h,maskedtopo + REAL*8, DIMENSION(:,:), ALLOCATABLE :: htemp + ! + INTEGER :: Mm,Mmm,Lm,Lmm,M,L + INTEGER :: i,j + ! + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + ALLOCATE(htemp(M,L)) + ! + htemp = h + + DO j=2,Lm + DO i=3,Mm + IF ((maskedtopo(i,j)*maskedtopo(i-1,j)) .NE.0.) THEN + h(i,j)=0.125*(htemp(i-1,j)+htemp(i+1,j) & + +htemp(i,j+1)+htemp(i,j-1)+4.*htemp(i,j)) + ENDIF + ENDDO + ENDDO + + i=2 + DO j=2,Lm + IF ((maskedtopo(i,j)*maskedtopo(i-1,j)) .NE.0.) THEN + h(i,j)=0.25*(htemp(i,j+1)+htemp(i,j-1)+2.*htemp(i,j)) + ENDIF + ENDDO + + i=M + DO j=2,Lm + IF ((maskedtopo(i,j)*maskedtopo(i-1,j)) .NE.0.) THEN + h(i,j)=0.25*(htemp(i,j+1)+htemp(i,j-1)+2.*htemp(i,j)) + ENDIF + ENDDO + + DEALLOCATE(htemp) + ! + END SUBROUTINE hanningy + + ! + !************************************************************************ + ! subroutine FX(bathy_meter,fx) + !************************************************************************ + ! + SUBROUTINE FX(h,f,c,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h,c + REAL*8, DIMENSION(:,:) :: f,maskedtopo + REAL*8, DIMENSION(SIZE(h,1),SIZE(h,2)) :: floc + ! + INTEGER :: Mm,Mmm,Lm,Lmm,M,L,i,j + ! + f = 0.0 + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + floc = 0. + + DO j=2,L + DO i=1,M + + IF ((maskedtopo(i,j)*maskedtopo(i,j-1)).EQ.0.) THEN + floc(i,j)=0. + ELSEIF ((i.EQ.1).OR.(i.EQ.M)) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i,j-1)) + ELSEIF ((maskedtopo(i-1,j)*maskedtopo(i-1,j-1)).EQ.0.) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i,j-1)) + ELSEIF ((maskedtopo(i+1,j)*maskedtopo(i+1,j-1)).EQ.0.) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i,j-1)) + ELSE + floc(i,j)=(5./12.)*(h(i,j)-h(i,j-1)) & + +(1./12.)*(h(i-1,j)-h(i-1,j-1)+h(i+1,j)-h(i+1,j-1)) + ENDIF + ENDDO + ENDDO + ! + DO j = 1,L + DO i = 1,M + f(i,j) = c(i,j)*floc(i,j) + END DO + END DO + ! + ! + END SUBROUTINE FX + ! + ! + ! + !************************************************************************ + ! subroutine FY(bathy_meter,fy) + !************************************************************************ + ! + SUBROUTINE FY(h,f,c,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h,c + REAL*8, DIMENSION(:,:) :: f,maskedtopo + REAL*8, DIMENSION(SIZE(h,1),SIZE(h,2)) :: floc + INTEGER :: Mm,Mmm,Lm,Lmm,M,L,i,j + f=0.0 + ! + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + ! + floc = 0. + + DO j=1,L + DO i=2,M + IF ((maskedtopo(i,j)*maskedtopo(i-1,j)).EQ.0.) THEN + floc(i,j) = 0. + ELSEIF ((j.EQ.1).OR.(j.EQ.L)) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i-1,j)) + ELSEIF ((maskedtopo(i,j-1)*maskedtopo(i-1,j-1)).EQ.0.) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i-1,j)) + ELSEIF ((maskedtopo(i,j+1)*maskedtopo(i-1,j+1)).EQ.0.) THEN + floc(i,j)=(7./12.)*(h(i,j)-h(i-1,j)) + ELSE + floc(i,j)=(5./12.)*(h(i,j)-h(i-1,j)) & + +(1./12.)*(h(i,j-1)-h(i-1,j-1)+h(i,j+1)-h(i-1,j+1)) + ENDIF + ENDDO + ENDDO + ! + DO j = 1,L + DO i = 1,M + f(i,j) = c(i,j)*floc(i,j) + END DO + END DO + ! + END SUBROUTINE FY + ! + ! + !**************************************************************** + ! subroutine rfact * + ! * + ! subroutine to check if smoothing criterion * + ! is verified everywhere * + ! * + ! - input : * + ! h : bathymetry * + ! - ouput : * + ! rx,ry : delta(theta)/theta in x and y directions * + !**************************************************************** + ! + SUBROUTINE rfact(h,rx,ry,maskedtopo) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: h + REAL*8, DIMENSION(:,:) :: rx,ry + REAL*8, DIMENSION(:,:) :: maskedtopo + INTEGER M,L,i,j,Mm,Mmm,Lm,Lmm + ! + M = SIZE(h,1) + L = SIZE(h,2) + Mm = M-1 + Mmm = Mm - 1 + Lm = L-1 + Lmm = Lm - 1 + ! + rx=0. + ry=0. + ! + DO j=2,L + DO i=1,M + rx(i,j) = ABS(h(i,j)-h(i,j-1))/(h(i,j)+h(i,j-1)) + IF ((maskedtopo(i,j)*maskedtopo(i,j-1)) .EQ.0.) THEN + rx(i,j)=0. + ENDIF + ENDDO + ENDDO + ! + DO j=1,L + DO i=2,M + ry(i,j) = ABS(h(i,j)-h(i-1,j))/(h(i,j)+h(i-1,j)) + IF ((maskedtopo(i,j)*maskedtopo(i-1,j)) .EQ.0.) THEN + ry(i,j)=0. + ENDIF + ENDDO + ENDDO + ! + END SUBROUTINE rfact + ! + ! + !**************************************************************** + ! subroutine Update_Parent_Bathy * + ! * + ! (if desired) subroutine to update parent grid bathymetry * + ! for consistency with fine grid bathymetry * + ! * + ! if a given coarse grid point is masked and one of the * + ! child grid points contained in this coarse cell is not masked * + ! the corresponding coarse grid point is unmasked with rn_hmin * + ! value * + ! * + ! - input : * + ! G0,G1 : both grids involved * + ! - ouput : * + ! G0 parent grid containing updated bathymetry * + !**************************************************************** + ! + ! + SUBROUTINE Update_Parent_Bathy( G0,G1 ) + ! + IMPLICIT NONE + + TYPE(coordinates) :: G0,G1 + INTEGER :: ii,jj,jk,ipt,jpt,diff,indx,indy,bornex,borney,bornex2,borney2 + ! + REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zmin + INTEGER :: i,j + INTEGER :: k1 + INTEGER :: compt, compt_oce + REAL*8, POINTER, DIMENSION(:) :: gdepw,gdept,e3w,e3t + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + za1=( ppdzmin - pphmax / (N-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & + * ( LOG( COSH( (N - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(N-1) + DO i = 1, N + gdepw(i) = ( i - 1 ) * za1 + gdept(i) = ( i - 0.5 ) * za1 + e3w (i) = za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,N + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) + e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,N + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) + e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & + & + za2 * TANH( (i-zkth2) / zacr2 ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + ! + gdepw(1)=0. + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, N-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(N) = e3t(N-1) + + DO i = 2, N + e3w(i) = gdept(i) - gdept(i-1) + END DO + e3w(1 ) = 2. * (gdept(1) - gdepw(1)) + END IF + ! + IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level + ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zmin = gdepw(i+1) + ! + diff = 0 + IF(MOD(rho,2) .EQ. 0) diff = 1 + ! + indx = 1+nbghostcellsfine + CEILING(irafx/2.0) + diff + indy = 1+nbghostcellsfine + CEILING(irafy/2.0) + diff + bornex = 1+nbghostcellsfine + CEILING(irafx/2.0) + diff + borney = 1+nbghostcellsfine + CEILING(irafy/2.0) + diff + bornex2 = nxfin - (nbghostcellsfine) - CEILING(irafx/2.0) + borney2 = nyfin - (nbghostcellsfine) - CEILING(irafy/2.0) + ! + DO j = borney,borney2,irafy + + jpt = jmin + 1 + nbghostcellsfine + (j-indy)/irafy + IF(j<=1) jpt = jmin + 1 + + DO i = bornex,bornex2,irafx + + ipt = imin + 1 + nbghostcellsfine + (i-indx)/irafx + IF(i<=1) ipt = imin + 1 + IF ((i==bornex).AND.(j==borney)) print *, 'Coarse grid Corner', ipt,jpt + ! + G0%Bathy_meter(ipt,jpt) = 0. + compt = 0 + compt_oce = 0 + DO jj = j-FLOOR(irafy/2.0),j+FLOOR(irafy/2.0)-diff + DO ii = i-FLOOR(irafx/2.0),i+FLOOR(irafx/2.0)-diff + G0%Bathy_meter(ipt,jpt) = G0%Bathy_meter(ipt,jpt) + G1%Bathy_meter(ii,jj) + IF (G1%Bathy_meter(ii,jj)>0.) compt_oce = compt_oce + 1 + compt = compt + 1 + END DO + END DO +! IF (compt_oce > 0.5*irafx*irafy) G0%Bathy_meter(ipt,jpt) = G0%Bathy_meter(ipt,jpt) / FLOAT(compt) + G0%Bathy_meter(ipt,jpt) = G0%Bathy_meter(ipt,jpt) / FLOAT(compt) + IF(G0%Bathy_meter(ipt,jpt).GT.0.) G0%Bathy_meter(ipt,jpt) = MAX(G0%Bathy_meter(ipt,jpt),zmin) + ! + G0%wgt(ipt,jpt) = 1. ! Flag for output + END DO + END DO + + ! + WRITE(*,*) ' Number of coarse grid points updated = ',compt + WRITE(*,*) '---------------------------------' + ! + END SUBROUTINE Update_Parent_Bathy + +END MODULE agrif_connect_topo diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_bathy.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_bathy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fab9be5b7974675f2b55c05467c04d1966c440d5 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_bathy.f90 @@ -0,0 +1,504 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! Laurent Debreu (Laurent.Debreu@imag.fr) * +!************************************************************************ +! +PROGRAM create_bathy + ! + USE NETCDF + USE bilinear_interp + USE agrif_readwrite + USE agrif_partial_steps + USE agrif_connect_topo + USE agrif_interpolation + ! + IMPLICIT NONE + ! + !************************************************************************ + ! * + ! PROGRAM CREATE_BATHY * + ! * + ! program to implement bathymetry interpolation to generate * + ! child grid bathymetry file * + ! * + ! various options : * + ! * + ! 1- Interpolation directly from parent bathymetry file (z-coord) * + ! 2- Use new topo file in meters (for example etopo) * + ! * + ! vertical coordinates permitted : z-coord and partial steps * + ! sigma coordinates is not yet implemented * + ! * + !Interpolation is carried out using bilinear interpolation * + !routine from SCRIP package or median average * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + !************************************************************************ + ! + ! variables declaration + ! + CHARACTER(len=80) :: namelistname + CHARACTER*100 :: child_coordinates, child_level, child_meter, child_domcfg + LOGICAL :: identical_grids + INTEGER :: nbadd,status,narg,iargc + INTEGER :: jpj,jpi + LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL() + INTEGER,DIMENSION(:,:),ALLOCATABLE :: mask_oce,trouble_points + INTEGER,DIMENSION(:) ,POINTER :: src_add,dst_add => NULL() + REAL*8, DIMENSION(:,:),POINTER :: matrix,interpdata => NULL() + REAL*8, DIMENSION(:,:),POINTER :: bathy_fin_constant => NULL() + REAL*8, DIMENSION(:,:),ALLOCATABLE :: bathy_test,vardep + REAL*8, DIMENSION(:) ,ALLOCATABLE :: vardep1d + REAL*8, DIMENSION(:,:),POINTER :: gdepw_ps_interp => NULL() + REAL*8 :: Cell_lonmin,Cell_lonmax,Cell_latmin,Cell_latmax,wghts + LOGICAL :: Pacifique = .FALSE. + INTEGER :: boundary,iimin,iimax,jjmax,jjmin + INTEGER :: nxhr,nyhr,nxyhr,ji,jj,nbiter + + TYPE(Coordinates) :: G0,G1 + ! + narg = iargc() + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + ! + ! read input file (namelist.input) + CALL read_namelist(namelistname) + + ! if level or meter name is missing + IF( TRIM(parent_level_name) == '' ) parent_level_name='mbathy' + IF( TRIM(parent_meter_name) == '' ) parent_meter_name='Bathymetry' + + ! define names of child grid files + CALL set_child_name(parent_coordinate_file,child_coordinates) + IF( TRIM(parent_bathy_level) /= '' ) CALL set_child_name(parent_bathy_level,child_level) + IF( TRIM(parent_bathy_meter) /= '' ) CALL set_child_name(parent_bathy_meter,child_meter) + IF( TRIM(parent_domcfg_out) /= '' ) CALL set_child_name(parent_domcfg_out,child_domcfg) + ! + IF( TRIM(parent_bathy_level) == '' .AND. TRIM(parent_bathy_meter) == '') THEN + WRITE(*,*) 'ERROR ***** one needs at least to define parent_bathy_level or parent_bathy_meter ...' + STOP + ENDIF + ! + ! read fine and coarse grids coordinates file + status = Read_Coordinates(TRIM(parent_coordinate_file),G0) + status = Read_Coordinates(TRIM(child_coordinates),G1,Pacifique) + ! + ! check error in size + IF( imax > SIZE(G0%nav_lon,1) .OR. jmax > SIZE(G0%nav_lon,2) .OR. imax <= imin .OR. jmax <= jmin ) THEN + WRITE(*,*) 'ERROR ***** bad child grid definition ...' + WRITE(*,*) 'please check imin,jmin,imax,jmax,jpizoom,jpjzoom values' + STOP + ENDIF + IF( SIZE(G1%nav_lon,1) .NE. nxfin .OR. SIZE(G1%nav_lon,2) .NE. nyfin ) THEN + WRITE(*,*) 'ERROR ***** bad child coordinates file ...' + WRITE(*,*) 'please check that child coordinates file has been created with the same namelist' + STOP + ENDIF + ! + ! read bathymetry data set => G0%bathy_meter + IF( new_topo ) THEN ! read G0%bathy_meter (on a reduced grid) and G1 coordinates + DEALLOCATE( G0%nav_lon, G0%nav_lat ) + status = read_bathy_coord(TRIM(elevation_database),G0,G1,Pacifique) + ELSE ! read G0%bathy_meter (on the global grid) + IF( TRIM(parent_bathy_meter) /= '') THEN + status = read_bathy_meter(TRIM(parent_bathy_meter),G0) + ELSE + status = Read_bathy_level(TRIM(parent_bathy_level),G0) + CALL levels_to_meter(G0) + ENDIF + ! change longitudes (from -180:180 to 0:360) + IF(Pacifique) THEN + WHERE(G0%nav_lon < 0.001) G0%nav_lon = G0%nav_lon + 360. + ENDIF + ENDIF + ! + ! 1st allocation of child grid bathy + ALLOCATE(G1%bathy_meter(nxfin,nyfin)) + G1%bathy_meter(:,:)=0. + + ! check grids: if identical then do not interpolate + identical_grids = .FALSE. + + IF( SIZE(G0%nav_lat,1) == SIZE(G1%nav_lat,1) .AND. SIZE(G0%nav_lat,2) == SIZE(G1%nav_lat,2) .AND. & + & SIZE(G0%nav_lon,1) == SIZE(G1%nav_lon,1) .AND. SIZE(G0%nav_lon,2) == SIZE(G1%nav_lon,2) ) THEN + IF( MAXVAL( ABS(G0%nav_lat(:,:)- G1%nav_lat(:,:)) ) < 0.0001 .AND. & + & MAXVAL( ABS(G0%nav_lon(:,:)- G1%nav_lon(:,:)) ) < 0.0001 ) THEN + WRITE(*,*) '' + WRITE(*,*) 'same grid between parent and child domains => NO INTERPOLATION' + WRITE(*,*) '' + G1%bathy_meter = G0%bathy_meter + identical_grids = .TRUE. + ENDIF + ENDIF + + IF( .NOT.new_topo ) type_bathy_interp = 2 ! only one which works + ! + ! + ! what type of interpolation for bathymetry + IF( type_bathy_interp == 0 ) THEN + WRITE(*,*) 'Interpolation of high resolution bathymetry on child grid: Arithmetic average ...' + ELSE IF( type_bathy_interp == 1 ) THEN + WRITE(*,*) 'Interpolation of high resolution bathymetry on child grid: Median average ...' + ELSE IF( type_bathy_interp == 2 ) THEN + WRITE(*,*) 'Interpolation of high resolution bathymetry on child grid: Bilinear interpolation ...' + ELSE + WRITE(*,*) 'bad value for type_bathy_interp variable ( must be 0, 1 or 2 )' + STOP + ENDIF + ! + ! + ! --------------------------------------------------------------------------------- + ! === Bathymetry of the fine grid (step1) === + ! --------------------------------------------------------------------------------- + ! ==> It gives G1%bathy_meter from G0%bathy_meter + ! --------------------------------------------------------------------------------- + + ! === Here: G0 is the grid associated with the new topography (as gebco or etopo) === + + IF( .NOT. identical_grids ) THEN + ! ! ----------------------------- + IF( type_bathy_interp == 0 .OR. type_bathy_interp == 1 ) THEN ! arithmetic or median averages + ! ! ----------------------------- + ALLOCATE(trouble_points(nxfin,nyfin)) + trouble_points(:,:) = 0 + ! + DO jj = 2, nyfin + DO ji = 2, nxfin + ! + ! fine grid cell extension + Cell_lonmin = MIN(G1%glamf(ji-1,jj-1),G1%glamf(ji,jj-1),G1%glamf(ji,jj),G1%glamf(ji-1,jj)) + Cell_lonmax = MAX(G1%glamf(ji-1,jj-1),G1%glamf(ji,jj-1),G1%glamf(ji,jj),G1%glamf(ji-1,jj)) + Cell_latmin = MIN(G1%gphif(ji-1,jj-1),G1%gphif(ji,jj-1),G1%gphif(ji,jj),G1%gphif(ji-1,jj)) + Cell_latmax = MAX(G1%gphif(ji-1,jj-1),G1%gphif(ji,jj-1),G1%gphif(ji,jj),G1%gphif(ji-1,jj)) + ! + ! look for points in G0 (bathy dataset) contained in the fine grid cells + iimin = 1 + DO WHILE( G0%nav_lon(iimin,1) < Cell_lonmin ) + iimin = iimin + 1 + ENDDO + ! + jjmin = 1 + DO WHILE( G0%nav_lat(iimin,jjmin) < Cell_latmin ) + jjmin = jjmin + 1 + ENDDO + ! + iimax = iimin + DO WHILE( G0%nav_lon(iimax,1) <= Cell_lonmax ) + iimax = iimax + 1 + iimax = MIN( iimax,SIZE(G0%bathy_meter,1)) + ENDDO + ! + jjmax = jjmin + DO WHILE( G0%nav_lat(iimax,jjmax) <= Cell_latmax ) + jjmax = jjmax + 1 + jjmax = MIN( jjmax,SIZE(G0%bathy_meter,2)) + ENDDO + ! + IF( ln_agrif_domain ) THEN + iimax = iimax-1 + jjmax = jjmax-1 + ELSE + iimax = MAX(iimin,iimax-1) + jjmax = MAX(jjmin,jjmax-1) + ENDIF + ! + iimin = MAX( iimin,1 ) + jjmin = MAX( jjmin,1 ) + iimax = MIN( iimax,SIZE(G0%bathy_meter,1)) + jjmax = MIN( jjmax,SIZE(G0%bathy_meter,2)) + + nxhr = iimax - iimin + 1 + nyhr = jjmax - jjmin + 1 + + IF( nxhr == 0 .OR. nyhr == 0 ) THEN + ! + trouble_points(ji,jj) = 1 + ! + ELSE + ! + ALLOCATE( vardep(nxhr,nyhr), mask_oce(nxhr,nyhr) ) + vardep(:,:) = G0%bathy_meter(iimin:iimax,jjmin:jjmax) + ! + WHERE( vardep(:,:) .GT. 0. ) ; mask_oce = 1 ; + ELSEWHERE ; mask_oce = 0 ; + ENDWHERE + ! + nxyhr = nxhr*nyhr + IF( SUM(mask_oce) < 0.5*(nxyhr) ) THEN ! if more than half of the points are on land then bathy fine = 0 + G1%bathy_meter(ji,jj) = 0. + ELSE + IF( type_bathy_interp == 0 ) THEN ! Arithmetic average + G1%bathy_meter(ji,jj) = SUM( vardep(:,:) * mask_oce(:,:) ) / SUM( mask_oce(:,:) ) + ELSE ! Median average + ALLOCATE(vardep1d(nxyhr)) + vardep1d = RESHAPE(vardep,(/ nxyhr /) ) + !!CALL ssort(vardep1d,nxyhr) + CALL quicksort(vardep1d,1,nxyhr) + ! + ! Calculate median + IF (MOD(nxyhr,2) .NE. 0) THEN + G1%bathy_meter(ji,jj) = vardep1d( nxyhr/2 + 1 ) + ELSE + G1%bathy_meter(ji,jj) = 0.5 * ( vardep1d(nxyhr/2) + vardep1d(nxyhr/2+1) ) + END IF + DEALLOCATE(vardep1d) + ENDIF + ENDIF + DEALLOCATE (mask_oce,vardep) + ! + ENDIF + ENDDO + ENDDO + + IF( SUM( trouble_points ) > 0 ) THEN + PRINT*,'too much empty cells, proceed to bilinear interpolation' + type_bathy_interp = 2 + ENDIF + + DEALLOCATE(trouble_points) + + ENDIF + ! ! ----------------------------- + IF( type_bathy_interp == 2) THEN ! Bilinear interpolation + ! ! ----------------------------- + + ALLOCATE(masksrc(SIZE(G0%bathy_meter,1),SIZE(G0%bathy_meter,2))) + ALLOCATE(bathy_test(nxfin,nyfin)) + ! + WHERE(G0%bathy_meter.LE.0) ; masksrc = .FALSE. ; + ELSEWHERE ; masksrc = .TRUE. ; + END WHERE + ! + ! compute remapping matrix thanks to SCRIP package + CALL get_remap_matrix(G0%nav_lat,G1%nav_lat,G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_remap(G0%bathy_meter,bathy_test,nxfin,nyfin,matrix,src_add,dst_add) + ! + G1%bathy_meter = bathy_test + ! + DEALLOCATE(masksrc) + DEALLOCATE(bathy_test) + + ENDIF + ! + ENDIF ! not identical grids + ! --- + ! At this stage bathymetry in meters has already been interpolated on fine grid + ! => G1%bathy_meter(nxfin,nyfin) + ! + ! Also G0 was the grid from the new bathymetry data set (etopo, gebco...) and not the coarse grid + ! --- + ! + ! --------------------------------------------------------------------------------- + ! === Bathymetry of the fine grid (step2) === + ! --------------------------------------------------------------------------------- + ! ==> It gives an update of G1%bathy_meter and G1%bathy_level + ! --------------------------------------------------------------------------------- + ! From here on: G0 is the coarse grid + ! + ! Coarse grid bathymetry : G0%bathy_meter (on the global grid) + IF( TRIM(parent_bathy_meter) /= '') THEN + status = read_bathy_meter(TRIM(parent_bathy_meter),G0) + ELSE + status = Read_bathy_level(TRIM(parent_bathy_level),G0) + CALL levels_to_meter(G0) + ENDIF + + ! Coarse grid coordinatees : G0 coordinates + DEALLOCATE(G0%nav_lat,G0%nav_lon) + status = Read_coordinates(TRIM(parent_coordinate_file),G0) + + ! allocate temporary arrays + IF (.NOT.ASSOCIATED(G0%gdepw_ps)) ALLOCATE(G0%gdepw_ps (SIZE(G0%bathy_meter,1),SIZE(G0%bathy_meter,2))) + IF (.NOT.ASSOCIATED(G1%gdepw_ps)) ALLOCATE(G1%gdepw_ps (SIZE(G1%bathy_meter,1),SIZE(G1%bathy_meter,2))) + IF (.NOT.ASSOCIATED(gdepw_ps_interp)) ALLOCATE(gdepw_ps_interp(SIZE(G1%bathy_meter,1),SIZE(G1%bathy_meter,2))) + ! + IF( ln_agrif_domain ) THEN + boundary = npt_copy*irafx + nbghostcellsfine + 1 + ELSE + boundary = npt_copy*irafx + ENDIF + ! + ! compute G0%gdepw_ps and G1%gdepw_ps + CALL get_partial_steps(G0) + CALL get_partial_steps(G1) + CALL bathymetry_control(G0%Bathy_level) + + ! --------------------------------------- + ! Bathymetry at the boundaries (npt_copy) + ! --------------------------------------- + ! 1st step: interpolate coarse bathy on the fine grid (using partial steps or not) + IF( ln_agrif_domain ) THEN + CALL Check_interp(G0,gdepw_ps_interp) + ELSE + gdepw_ps_interp = 0. * G1%gdepw_ps + !!CALL agrif_interp(G0%gdepw_ps,gdepw_ps_interp,'T') + CALL init_constant_bathy(G0%gdepw_ps,gdepw_ps_interp) + ENDIF + + IF (.NOT.ASSOCIATED(G1%wgt)) ALLOCATE(G1%wgt(SIZE(G1%bathy_meter,1),SIZE(G1%bathy_meter,2))) + G1%wgt(:,:) = 0. + IF ((.NOT.ASSOCIATED(G0%wgt)).AND.bathy_update) THEN + ALLOCATE(G0%wgt(SIZE(G0%nav_lat,1),SIZE(G0%nav_lat,2))) + G0%wgt(:,:) = 0. + ENDIF + ! +!!$ IF( new_topo ) THEN ! clem: no, do it even when there is no new topo + ! 2nd step: copy parent bathymetry at the boundaries + DO jj=1,nyfin ! West and East + IF ( gdepw_ps_interp(nbghostcellsfine+1,jj) > 0. ) THEN + G1%gdepw_ps(1:boundary,jj) = gdepw_ps_interp(1:boundary,jj) + G1%wgt(1:boundary,jj) = 1. + ELSE + G1%gdepw_ps(1:nbghostcellsfine+1,jj)=0. + ENDIF + ! + IF ( gdepw_ps_interp(nxfin-nbghostcellsfine,jj) > 0.) THEN + G1%gdepw_ps(nxfin-boundary+1:nxfin,jj)=gdepw_ps_interp(nxfin-boundary+1:nxfin,jj) + G1%wgt(nxfin-boundary+1:nxfin,jj) = 1. + ELSE + G1%gdepw_ps(nxfin-nbghostcellsfine:nxfin,jj) = 0. + ENDIF + END DO + ! + DO ji=1,nxfin ! South and North + IF (gdepw_ps_interp(ji,nbghostcellsfine+1)>0.) THEN + G1%gdepw_ps(ji,1:boundary) = gdepw_ps_interp(ji,1:boundary) + G1%wgt(ji,1:boundary) = 1. + ELSE + G1%gdepw_ps(ji,1:nbghostcellsfine+1)=0. + ENDIF + ! + IF (gdepw_ps_interp(ji,nyfin-nbghostcellsfine)>0.) THEN + G1%gdepw_ps(ji,nyfin-boundary+1:nyfin)=gdepw_ps_interp(ji,nyfin-boundary+1:nyfin) + G1%wgt(ji,nyfin-boundary+1:nyfin) = 1. + ELSE + G1%gdepw_ps(ji,nyfin-nbghostcellsfine:nyfin) = 0. + ENDIF + END DO + ! + !clem: recalculate interpolation everywhere before linear connection (useless to me??) + IF( ln_agrif_domain ) THEN + gdepw_ps_interp = 0. + CALL Check_interp(G0,gdepw_ps_interp) + ENDIF + ! + ! ------------------------------------------------------- + ! Bathymetry between boundaries and interior (npt_connect) + ! -------------------------------------------------------- + ! Make linear connection (on npt_connect*irafx points) between the boundaries and the interior + IF( ln_agrif_domain ) THEN + boundary = (npt_copy + npt_connect)*irafx + nbghostcellsfine + 1 + ELSE + boundary = (npt_copy + npt_connect)*irafx + ENDIF + + IF( npt_connect > 0 ) THEN + WRITE(*,*) ' linear connection on ',npt_connect,'coarse grid points' + + wghts = 1. + DO ji = boundary - npt_connect*irafx + 1 , boundary + wghts = wghts - (1. / (npt_connect*irafx + 1. ) ) + DO jj=1,nyfin + IF (G1%gdepw_ps(nbghostcellsfine+1,jj) > 0.) G1%wgt(ji,jj) = MAX(wghts, G1%wgt(ji,jj)) + END DO + END DO + + wghts = 1. + DO ji = nxfin - (boundary - npt_connect*irafx), nxfin - boundary +1 , -1 + wghts = wghts - (1. / (npt_connect*irafx + 1. ) ) + DO jj=1,nyfin + IF (G1%gdepw_ps(nxfin-nbghostcellsfine,jj) > 0.) G1%wgt(ji,jj) = MAX(wghts, G1%wgt(ji,jj)) + END DO + END DO + + wghts = 1. + DO jj = boundary - npt_connect*irafy + 1 , boundary + wghts = wghts - (1. / (npt_connect*irafy + 1. ) ) + DO ji=1,nxfin + IF (G1%gdepw_ps(ji,nbghostcellsfine+1) > 0.) G1%wgt(ji,jj) = MAX(wghts, G1%wgt(ji,jj)) + END DO + END DO + + wghts = 1. + DO jj = nyfin - (boundary - npt_connect*irafy) , nyfin - boundary +1, -1 + wghts = wghts - (1. / (npt_connect*irafy + 1. ) ) + DO ji=1,nxfin + IF (G1%gdepw_ps(ji,nyfin-nbghostcellsfine) > 0.) G1%wgt(ji,jj) = MAX(wghts, G1%wgt(ji,jj)) + END DO + END DO + IF (.NOT.identical_grids) THEN + G1%gdepw_ps(:,:) = (1.-G1%wgt(:,:)) * G1%gdepw_ps(:,:) + gdepw_ps_interp(:,:)*G1%wgt(:,:) + ENDIF + + ENDIF +!!$ ENDIF + + ! replace G1%bathy_meter by G1%gdepw_ps + G1%bathy_meter = G1%gdepw_ps + ! + ! -------------------- + ! Bathymetry smoothing + ! -------------------- + IF( smoothing .AND. (.NOT.identical_grids) ) THEN + ! Chanut: smoothing everywhere then discard result in connection zone + CALL smooth_topo(G1%gdepw_ps(:,:),nbiter) + WHERE (G1%wgt(:,:)==0.) G1%bathy_meter(:,:) = G1%gdepw_ps(:,:) + ELSE + WRITE(*,*) 'No smoothing process only connection is carried out' + ENDIF + ! + ! ------------------ + ! Remove closed seas + ! ------------------ + IF (removeclosedseas) THEN + ALLOCATE(bathy_test(nxfin,nyfin)) + bathy_test=0. + WHERE (G1%bathy_meter(1,:) .GT.0.) bathy_test(1,:)=1 + WHERE (G1%bathy_meter(nxfin,:).GT.0.) bathy_test(nxfin,:)=1 + WHERE (G1%bathy_meter(:,1) .GT.0.) bathy_test(:,1)=1 + WHERE (G1%bathy_meter(:,nyfin).GT.0.) bathy_test(:,nyfin)=1 + + nbadd = 1 + DO WHILE (nbadd.NE.0) + nbadd = 0 + DO jj=2,nyfin-1 + DO ji=2,nxfin-1 + IF (G1%bathy_meter(ji,jj).GT.0.) THEN + IF (MAX(bathy_test(ji,jj+1),bathy_test(ji,jj-1),bathy_test(ji-1,jj),bathy_test(ji+1,jj)).EQ.1) THEN + IF (bathy_test(ji,jj).NE.1.) nbadd = nbadd + 1 + bathy_test(ji,jj)=1. + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + WHERE (bathy_test.EQ.0.) G1%bathy_meter = 0. + DEALLOCATE(bathy_test) + ENDIF + ! + CALL get_partial_steps(G1) ! recompute bathy_level and gdepw_ps for G1 (and correct bathy_meter) + ! + ! update parent grid + IF(bathy_update) THEN + CALL Update_Parent_Bathy( G0,G1 ) + status = Write_Bathy_meter(TRIM(parent_bathy_meter_updated),G0) + status = write_domcfg(TRIM(parent_domcfg_updated),G0) + ENDIF + ! + ! store interpolation result in output file + IF( TRIM(parent_bathy_level) /= '' ) status = Write_Bathy_level(TRIM(child_level),G1) + IF( TRIM(parent_bathy_meter) /= '' ) status = Write_Bathy_meter(TRIM(child_meter),G1) + IF( TRIM(parent_domcfg_out) /= '' ) status = write_domcfg(TRIM(child_domcfg),G1) + ! + WRITE(*,*) '****** Bathymetry successfully created ******' + STOP + ! +END PROGRAM create_bathy + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_coordinates.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_coordinates.f90 new file mode 100644 index 0000000000000000000000000000000000000000..30ce3e56a3c3bd4215594ef8c2a81497cc83e959 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_coordinates.f90 @@ -0,0 +1,206 @@ +PROGRAM create_coordinate + ! + USE NETCDF + USE agrif_readwrite + USE agrif_interpolation + ! + !**************************************************************** + ! * + !************************************************************************ + ! Fortran 95 OPA Nesting tools * + ! * + ! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * + ! * + !************************************************************************ + ! + ! PROGRAM CREATE_COORDINATE * + ! * + ! program to create coordinates file for child grid * + ! (child grid defined by imin,imax,jmin,jmax,rho) * + ! * + !**************************************************************** + ! + ! variables declaration + ! + REAL*8 :: rpi,ra,rad + CHARACTER*100 :: Child_filename + INTEGER :: i + TYPE(Coordinates) :: G0,G1 + INTEGER :: narg,iargc + CHARACTER(len=80) :: namelistname + + narg = iargc() + + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + ! + ! read input file (namelist.input) + CALL read_namelist(namelistname) + ! + ! read parent coodinates file + status = Read_Coordinates(TRIM(parent_coordinate_file),G0) + ! + ! define name of child coordinate file + CALL set_child_name(parent_coordinate_file,Child_filename) + ! + IF( imax > SIZE(G0%glamt,1) .OR. jmax > SIZE(G0%glamt,2) .OR. imax <= imin .OR. jmax <= jmin ) THEN + WRITE(*,*) 'ERROR ***** bad child grid definition ...' + WRITE(*,*) 'please check imin,jmin,imax,jmax,jpizoom,jpjzoom values' + WRITE(*,*) ' ' + STOP + ENDIF + ! + WRITE(*,*) ' ' + WRITE(*,*)'Size of the High resolution grid: ',nxfin,' x ',nyfin + WRITE(*,*) ' ' + ! + ! allocation of child grid elements + CALL agrif_grid_allocate(G1,nxfin,nyfin) + ! + ! check potential longitude problems + IF( G0%glamt(imin,jmin) > G0%glamt(imax,jmax) ) THEN + WHERE ( G0%glamt < 0 ) G0%glamt = G0%glamt + 360. + WHERE ( G0%glamf < 0 ) G0%glamf = G0%glamf + 360. + ENDIF + ! + ! interpolation from parent grid to child grid for + ! T points (cell center) + ! F points (lower left corner) + ! U points (cell left side) + ! V points (cell top side) + ! glam = longitude + ! gphi = latitude + ! + ! + CALL agrif_interp(G0%glamt,G1%glamt,'T') + CALL agrif_interp(G0%glamf,G1%glamf,'F') + CALL agrif_interp(G0%glamu,G1%glamu,'U') + CALL agrif_interp(G0%glamv,G1%glamv,'V') + ! + CALL agrif_interp(G0%gphit,G1%gphit,'T') + CALL agrif_interp(G0%gphif,G1%gphif,'F') + CALL agrif_interp(G0%gphiu,G1%gphiu,'U') + CALL agrif_interp(G0%gphiv,G1%gphiv,'V') + ! + ! + rpi = 4.*ATAN(1.) + rad = rpi/180. + ra = 6371229. + ! + ! Compute scale factors e1 e2 +! DO j=1,nyfin +! DO i=2,nxfin +! G1%e1t(i,j) = ra * rad * SQRT( (COS(rad*G1%gphit(i,j))*(G1%glamu(i,j)-G1%glamu(i-1,j)))**2 & +! + (G1%gphiu(i,j)-G1%gphiu(i-1,j))**2) +! G1%e1v(i,j) = ra * rad * SQRT( (COS(rad*G1%gphiv(i,j))*(G1%glamf(i,j)-G1%glamf(i-1,j)))**2 & +! + (G1%gphif(i,j)-G1%gphif(i-1,j))**2) +! END DO +! END DO +! ! +! G1%e1t(1,:)=G1%e1t(2,:) +! G1%e1v(1,:)=G1%e1v(2,:) +! ! +! DO j=1,nyfin +! DO i=1,nxfin-1 +! G1%e1u(i,j) = ra * rad * SQRT( (COS(rad*G1%gphiu(i,j))*(G1%glamt(i+1,j)-G1%glamt(i,j)))**2 & +! + (G1%gphit(i+1,j)-G1%gphit(i,j))**2) +! G1%e1f(i,j) = ra * rad * SQRT( (COS(rad*G1%gphif(i,j))*(G1%glamv(i+1,j)-G1%glamv(i,j)))**2 & +! + (G1%gphiv(i+1,j)-G1%gphiv(i,j))**2) +! END DO +! END DO +! ! +! G1%e1u(nxfin,:)=G1%e1u(nxfin-1,:) +! G1%e1f(nxfin,:)=G1%e1f(nxfin-1,:) +! ! +! DO j=2,nyfin +! DO i=1,nxfin +! G1%e2t(i,j) = ra * rad * SQRT( (COS(rad*G1%gphit(i,j))*(G1%glamv(i,j)-G1%glamv(i,j-1)))**2 & +! + (G1%gphiv(i,j)-G1%gphiv(i,j-1))**2) +! G1%e2u(i,j) = ra * rad * SQRT( (COS(rad*G1%gphiu(i,j))*(G1%glamf(i,j)-G1%glamf(i,j-1)))**2 & +! + (G1%gphif(i,j)-G1%gphif(i,j-1))**2) +! END DO +! END DO +! ! +! G1%e2t(:,1)=G1%e2t(:,2) +! G1%e2u(:,1)=G1%e2u(:,2) +! ! +! DO j=1,nyfin-1 +! DO i=1,nxfin +! G1%e2v(i,j) = ra * rad * SQRT( (COS(rad*G1%gphiv(i,j))*(G1%glamt(i,j+1)-G1%glamt(i,j)))**2 & +! + (G1%gphit(i,j+1)-G1%gphit(i,j))**2) +! G1%e2f(i,j) = ra * rad * SQRT( (COS(rad*G1%gphif(i,j))*(G1%glamu(i,j+1)-G1%glamu(i,j)))**2 & +! + (G1%gphiu(i,j+1)-G1%gphiu(i,j))**2) +! END DO +! END DO +! ! +! G1%e2v(:,nyfin)=G1%e2v(:,nyfin-1) +! G1%e2f(:,nyfin)=G1%e2f(:,nyfin-1) + + + CALL agrif_interp(G0%e1t,G1%e1t,'T') ; G1%e1t = G1%e1t / REAL(irafx) + CALL agrif_interp(G0%e2t,G1%e2t,'T') ; G1%e2t = G1%e2t / REAL(irafy) + + CALL agrif_interp(G0%e1u,G1%e1u,'U') ; G1%e1u = G1%e1u / REAL(irafx) + CALL agrif_interp(G0%e2u,G1%e2u,'U') ; G1%e2u = G1%e2u / REAL(irafy) + + CALL agrif_interp(G0%e1v,G1%e1v,'V') ; G1%e1v = G1%e1v / REAL(irafx) + CALL agrif_interp(G0%e2v,G1%e2v,'V') ; G1%e2v = G1%e2v / REAL(irafy) + + CALL agrif_interp(G0%e1f,G1%e1f,'F') ; G1%e1f = G1%e1f / REAL(irafx) + CALL agrif_interp(G0%e2f,G1%e2f,'F') ; G1%e2f = G1%e2f / REAL(irafy) + ! + WHERE ( G1%glamt > 180 ) G1%glamt = G1%glamt - 360. + WHERE ( G1%glamf > 180 ) G1%glamf = G1%glamf - 360. + WHERE ( G1%glamu > 180 ) G1%glamu = G1%glamu - 360. + WHERE ( G1%glamv > 180 ) G1%glamv = G1%glamv - 360. + ! + G1%nav_lon=G1%glamt + G1%nav_lat=G1%gphit + ! + ! Write interpolation result in child coodinates file + status = Write_Coordinates(TRIM(Child_filename),G1) + ! + WRITE(*,*) 'Position of the inner Child domain (i.e. without borders(masked) and ghostcells) : ' + IF( ln_agrif_domain ) THEN + WRITE(*,*) 'latmin =',G1%gphit(2+nbghostcellsfine,2+nbghostcellsfine) + WRITE(*,*) 'latmax =',G1%gphit(nxfin-(1+nbghostcellsfine),nyfin-(1+nbghostcellsfine)) + WRITE(*,*) 'lonmin =',G1%glamt(2+nbghostcellsfine,2+nbghostcellsfine) + WRITE(*,*) 'lonmax =',G1%glamt(nxfin-(1+nbghostcellsfine),nyfin-(1+nbghostcellsfine)) + ELSE + WRITE(*,*) 'latmin =',G1%gphit(1,1) + WRITE(*,*) 'latmax =',G1%gphit(nxfin,nyfin) + WRITE(*,*) 'lonmin =',G1%glamt(1,1) + WRITE(*,*) 'lonmax =',G1%glamt(nxfin,nyfin) + ENDIF + STOP +END PROGRAM create_coordinate + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_data.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_data.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c6419e80d9904097168b6d9602dac35fc0312fee --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_data.f90 @@ -0,0 +1,73 @@ +PROGRAM create_data + ! + USE io_netcdf + USE bilinear_interp + USE agrif_readwrite + USE agrif_interpolation + ! + IMPLICIT NONE + ! + !************************************************************************ + ! * + ! PROGRAM CREATE_DATA * + ! * + ! program to implement data interpolation to generate * + ! child grid forcing files * + ! * + !Interpolation is carried out using bilinear interpolation * + !routine from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + !************************************************************************ + ! + INTEGER :: narg, iargc, ji + CHARACTER(len=80) :: namelistname + + narg = iargc() + + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + + ! read input file (namelist.input) + CALL read_namelist(namelistname) + ! + ! Interpolate U grid data + ji = 1 + DO WHILE( TRIM(U_Files(ji)) /= '' ) + PRINT *,'Grid U forcing files = ',u_files(ji) + ! + CALL Interp_Extrap_var(U_FILES(ji), 'U') + ji = ji+1 + ! + END DO + + ! + ! Interpolate V grid data + ji = 1 + DO WHILE( TRIM(V_Files(ji)) /= '' ) + PRINT *,'Grid V forcing files = ',v_files(ji) + ! + CALL Interp_Extrap_var(V_FILES(ji), 'V') + ji = ji+1 + ! + END DO + ! + ! Interpolate flux data + ji = 1 + DO WHILE( TRIM(Flx_Files(ji)) /= '' ) + PRINT *,'flxfiles = ',flx_files(ji) + ! + CALL Interp_Extrap_var(FLX_FILES(ji), 'T') + ji = ji+1 + ! + END DO + ! + WRITE(*,*) ' ' + WRITE(*,*) '******* forcing files successfully created *******' + WRITE(*,*) ' ' + ! + STOP +END PROGRAM create_data diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9197147a7c52458a43cb1c06ea7cd92205e35c88 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart.f90 @@ -0,0 +1,548 @@ +! +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +PROGRAM create_rstrt + ! + USE NETCDF + USE bilinear_interp + USE bicubic_interp + USE agrif_readwrite + USE io_netcdf + USE agrif_extrapolation + USE agrif_interpolation + USE agrif_partial_steps + USE agrif_connect_topo + ! + IMPLICIT NONE + ! + !************************************************************************ + ! * + ! PROGRAM CREATE_RSTRT * + ! * + ! program to interpolate parent grid restart file to child grid * + ! * + ! * + !Interpolation is carried out using bilinear interpolation * + !routine from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + !************************************************************************ + ! + ! variables declaration + ! + CHARACTER*20,DIMENSION(:),POINTER :: Ncdf_varname => NULL() + CHARACTER*20 :: vert_coord_name + CHARACTER*1 :: posvar + CHARACTER*100 :: Child_file,Childcoordinates,varname,Child_Bathy_Level,Child_Bathy_Meter + REAL*8, POINTER, DIMENSION(:,:,:) :: tabvar3d => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: un,ub,vn,vb,tn,tb,sn,sb,e3t_n,e3t_b => NULL() + REAL*8, POINTER, DIMENSION(:,:,:) :: sshn,sshb => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabinterp4d,tabvar1,tabvar2,tabvar3 => NULL() + REAL*8, POINTER, DIMENSION(:) :: tabtemp1D,nav_lev => NULL() + REAL*8, POINTER, DIMENSION(:,:) :: tabtemp2D => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabtemp4D => NULL() + INTEGER,DIMENSION(:),POINTER :: src_add,dst_add => NULL() + REAL*8,DIMENSION(:,:),POINTER :: matrix => NULL() + LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL() + LOGICAL, DIMENSION(:,:,:), POINTER :: detected_pts + LOGICAL :: Interpolation,Extrapolation,Pacifique + INTEGER :: narg,iargc,ncid,x,y,z,z_a,x_a,y_a,z_b,nbvert_lev + REAL*8 :: now_wght,before_wght + INTEGER :: status,ii,jk + CHARACTER(len=20),DIMENSION(4) :: dimnames + CHARACTER(len=80) :: namelistname + TYPE(Coordinates) :: G0,G1 + REAL*8 :: tabtemp0dreal + CHARACTER(len=20) :: timedimname + + LOGICAL, PARAMETER :: conservation = .FALSE. + ! + ! + narg = iargc() + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + ! + ! read input file + ! + CALL read_namelist(namelistname) + ! + IF(TRIM(restart_file) == '') THEN + WRITE(*,*) 'no restart file specified in ',TRIM(namelistname) + STOP + END IF + + IF (iom_activated) THEN + timedimname = 'time_counter' + ELSE + timedimname='time' + ENDIF + + ! + WRITE(*,*) '' + WRITE(*,*) 'Interpolation of restart file : ',TRIM(restart_file) + WRITE(*,*) '' + ! + CALL Read_Ncdf_VarName(restart_file,Ncdf_varname) + ! + CALL set_child_name(parent_coordinate_file,Childcoordinates) + IF( TRIM(parent_bathy_level) /= '' ) CALL set_child_name(parent_bathy_level,Child_Bathy_Level) + IF( TRIM(parent_bathy_meter) /= '' ) CALL set_child_name(parent_bathy_meter,Child_Bathy_Meter) + ! + ! create this file + ! + CALL set_child_name(restart_file,Child_file) + status = nf90_create(Child_file,NF90_WRITE,ncid) + status = nf90_close(ncid) + WRITE(*,*) 'Child grid restart file name = ',TRIM(Child_file) + WRITE(*,*) '' + + ! + ! read dimensions in parent restart file + ! + CALL Read_Ncdf_dim('x',restart_file,x) + CALL Read_Ncdf_dim('y',restart_file,y) + CALL Read_Ncdf_dim('nav_lev',restart_file,z) + IF (.NOT.iom_activated) THEN + CALL Read_Ncdf_dim('x_a',restart_file,x_a) + CALL Read_Ncdf_dim('y_a',restart_file,y_a) + CALL Read_Ncdf_dim('z_a',restart_file,z_a) + CALL Read_Ncdf_dim('z_b',restart_file,z_b) + ENDIF + + IF( z .NE. N ) THEN + WRITE(*,*) '***' + WRITE(*,*) 'Number of vertical levels doesn t match between namelist and restart file' + WRITE(*,*) 'Please check the values in namelist file' + STOP + ENDIF + ! + ! mask initialization for extrapolation and interpolation + ! + WRITE(*,*) 'mask initialisation on coarse and fine grids' + ! + status = Read_Local_Coordinates(parent_coordinate_file,G0,(/jpizoom,jpjzoom/),(/x,y/)) + status = Read_Coordinates(Childcoordinates,G1,Pacifique) + ! + !longitude modification if child domain covers Pacific ocean area + ! + IF( Pacifique ) THEN + ! + WHERE( G0%nav_lon < 0 ) + G0%nav_lon = G0%nav_lon + 360. + END WHERE + ! + WHERE( G1%nav_lon < 0 ) + G1%nav_lon = G1%nav_lon + 360. + END WHERE + ! + ENDIF + ! + ! one needs bathy_level + IF( TRIM(parent_bathy_level) /= '' ) THEN + status = Read_bathy_level(TRIM(parent_bathy_level),G0) + status = Read_bathy_level(TRIM(child_bathy_level),G1) + ELSE + status = read_bathy_meter(TRIM(parent_bathy_meter),G0) + status = read_bathy_meter(TRIM(child_bathy_meter),G1) + CALL meter_to_levels(G0) + CALL meter_to_levels(G1) + ENDIF + ! get masks + CALL Init_mask(parent_bathy_level,G0,x,y) + CALL Init_mask(child_bathy_level,G1,1,1) + + G0%tmask = 1. + + DO jk=1,z + ALLOCATE(tabvar1(x,y,1,1)) + CALL Read_Ncdf_var('sn',TRIM(restart_file),tabvar1,1,jk) + WHERE( tabvar1(:,:,1,1) == 0. ) + G0%tmask(:,:,jk) = 0. + END WHERE + DEALLOCATE(tabvar1) + END DO + ! + G0%umask(1:x-1,:,:) = G0%tmask(1:x-1,:,:)*G0%tmask(2:x,:,:) + G0%umask(x,:,:) = G0%tmask(x,:,:) + G0%vmask(:,1:y-1,:) = G0%tmask(:,1:y-1,:)*G0%tmask(:,2:y,:) + G0%vmask(:,y,:) = G0%tmask(:,y,:) + ! + G0%fmask(1:x-1,1:y-1,:) = G0%tmask(1:x-1,1:y-1,:)*G0%tmask(2:x,1:y-1,:)* & + & G0%tmask(1:x-1,2:y,:)*G0%tmask(2:x,2:y,:) + G0%fmask(x,:,:) = G0%tmask(x,:,:) + G0%fmask(:,y,:) = G0%tmask(:,y,:) + ! + ! + ! write dimensions in output file + WRITE(*,*) 'write dimensions' + ! + CALL Write_Ncdf_dim('x',Child_file,nxfin) + CALL Write_Ncdf_dim('y',Child_file,nyfin) + CALL Write_Ncdf_dim('nav_lev',Child_file,z) + CALL Write_Ncdf_dim(TRIM(timedimname),Child_file,0) + IF (.NOT.iom_activated) THEN + CALL Write_Ncdf_dim('x_a',Child_file,x_a) + CALL Write_Ncdf_dim('y_a',Child_file,y_a) + CALL Write_Ncdf_dim('z_a',Child_file,z_a) + CALL Write_Ncdf_dim('z_b',Child_file,z_b) + ENDIF + ! + ! + ! + ! + DO ii = 1,SIZE(Ncdf_varname) + ! + ! loop on variables names + varname = TRIM(Ncdf_varname(ii)) + WRITE(*,*) 'var = ',TRIM(varname) + ! + SELECT CASE (TRIM(varname)) + ! + CASE('nav_lon') + CALL Read_Ncdf_var('nav_lon',TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var('nav_lon',(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att('nav_lon',TRIM(restart_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + CASE('nav_lat') + CALL Read_Ncdf_var('nav_lat',TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var('nav_lat',(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att('nav_lat',TRIM(restart_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + CASE('nav_lev') + CALL Read_Ncdf_var('nav_lev',TRIM(restart_file),nav_lev) + CALL Write_Ncdf_var('nav_lev','nav_lev',Child_file,nav_lev,'float') + CALL Copy_Ncdf_att('nav_lev',TRIM(restart_file),Child_file) + Interpolation = .FALSE. + ! + CASE('time') + CALL Read_Ncdf_var('time',TRIM(restart_file),tabtemp1D) + CALL Write_Ncdf_var('time',TRIM(timedimname),Child_file,tabtemp1D,'float') + CALL Copy_Ncdf_att('time',TRIM(restart_file),Child_file) + DEALLOCATE(tabtemp1D) + Interpolation = .FALSE. + ! + CASE('time_counter') + CALL Read_Ncdf_var('time_counter',TRIM(restart_file),tabtemp1D) + tabtemp1D = tabtemp1D * rhot + CALL Write_Ncdf_var('time_counter',TRIM(timedimname),Child_file,tabtemp1D,'double') + CALL Copy_Ncdf_att('time_counter',TRIM(restart_file),Child_file) + DEALLOCATE(tabtemp1D) + Interpolation = .FALSE. + ! + CASE('kt','ndastp','adatrj','ntime','nn_fsbc','rdt') + IF (iom_activated) THEN + CALL Read_Ncdf_var(TRIM(varname),TRIM(restart_file),tabtemp0dreal) + SELECT CASE (TRIM(varname)) + CASE('rdt') + tabtemp0dreal = tabtemp0dreal / rhot + CASE('kt') + tabtemp0dreal = tabtemp0dreal * rhot + END SELECT + CALL Write_Ncdf_var(TRIM(varname),Child_file,tabtemp0dreal,'double') + ELSE + CALL Read_Ncdf_var(TRIM(varname),TRIM(restart_file),tabtemp4D) + dimnames(1)='x_a' + dimnames(2)='y_a' + dimnames(3)='z_b' + dimnames(4)=TRIM(timedimname) + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabtemp4D,'double') + DEALLOCATE(tabtemp4D) + ENDIF + CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_file),Child_file) + Interpolation = .FALSE. + ! + CASE('frc_v','frc_t','frc_s') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp0dreal) + CALL Write_Ncdf_var(varname,Child_file,tabtemp0dreal,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + Interpolation = .FALSE. + ! + ! Variable interpolation according to their position on grid + ! + CASE('ssu_m','utau_b','un_bf','un','ub') + IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN + vert_coord_name = 'nav_lev' + ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN + vert_coord_name = '1' + ENDIF + posvar='U' + Interpolation = .TRUE. + ! + CASE('ssv_m','vtau_b','vn_bf','vn','vb') + IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN + vert_coord_name = 'nav_lev' + ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN + vert_coord_name = '1' + ENDIF + posvar='V' + Interpolation = .TRUE. + ! + CASE DEFAULT + IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN + vert_coord_name = 'nav_lev' + ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN + vert_coord_name = '1' + ENDIF + posvar='T' + Interpolation = .TRUE. + ! + END SELECT + ! + ! --- start interpolation --- ! + IF( Interpolation ) THEN + ! + IF( vert_coord_name == '1' ) THEN + nbvert_lev = 1 + ELSE + nbvert_lev = z + ENDIF + ! + + ALLOCATE(detected_pts(SIZE(G0%tmask,1),SIZE(G0%tmask,2),nbvert_lev)) + ALLOCATE(tabvar1(x,y,1,2)) + ALLOCATE(tabvar2(x,y,1,1)) + ALLOCATE(tabvar3(x,y,1,1)) + ALLOCATE(masksrc(x,y)) + ALLOCATE(tabinterp4d(nxfin,nyfin,1,1)) + + ! + DO n = 1,nbvert_lev + ! + WRITE(*,*) 'interpolate/extrapolate for vertical level = ',n + ! + CALL Read_Ncdf_var(varname,TRIM(restart_file),tabvar1,1,n) + IF(n==1) THEN + ! + ELSE IF (n==2) THEN + tabvar2(:,:,:,1) = tabvar1(:,:,:,2) + ELSE + tabvar3(:,:,:,1) = tabvar2(:,:,:,1) + tabvar2(:,:,:,1) = tabvar1(:,:,:,2) + + ENDIF + ! + SELECT CASE(posvar) + ! + CASE('T') + ! + IF(MAXVAL(G1%tmask(:,:,n)) == 0.) THEN + tabinterp4d = 0.0 + WRITE(*,*) 'only land points on level ',n + ELSE + + CALL extrap_detect(G0,G1,detected_pts(:,:,n),n) + + CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n) + + ! for the following variables, you do not want to mask the values + IF( TRIM(varname) == 'e3t_n' .OR. TRIM(varname) == 'e3t_b' .OR. TRIM(varname) == 'e3t_m' .OR. & + & TRIM(varname) == 'fraqsr_1lev' .OR. TRIM(varname) == 'frq_m' .OR. TRIM(varname) == 'surf_ini' ) THEN + masksrc(:,:) = .TRUE. + ENDIF + + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(G0%nav_lat,G1%nav_lat, & + G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL get_remap_bicub(G0%nav_lat,G1%nav_lat, & + G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),& + nxfin,nyfin,matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) THEN ! clem: it currently does not work + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), & + G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + ENDIF + + ENDIF + + IF( ALL(masksrc) ) THEN + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) + ELSE + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) * G1%tmask(:,:,n) + ENDIF + ! + CASE('U') + ! + IF(MAXVAL(G1%umask(:,:,n)) == 0) THEN + tabinterp4d = 0.0 + WRITE(*,*) 'only land points on level ',n + ELSE + ! + CALL extrap_detect(G0,G1,detected_pts(:,:,n),n,'U') + CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n,'U') + ! + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(G0%gphiu,G1%gphiu, & + G0%glamu,G1%glamu,masksrc,matrix,src_add,dst_add) + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL get_remap_bicub(G0%gphiu,G1%gphiu, & + G0%glamu,G1%glamu,masksrc,matrix,src_add,dst_add) + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),& + nxfin,nyfin,matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) THEN ! clem: not coded for U + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), & + G0%e1u,G0%e2u,G1%e1u,G1%e2u,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + ENDIF + ENDIF + + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) * G1%umask(:,:,n) + ! + CASE('V') + ! + IF(MAXVAL(G1%vmask(:,:,n)) == 0) THEN + tabinterp4d = 0.0 + WRITE(*,*) 'only land points on level ',n + ELSE + ! + + CALL extrap_detect(G0,G1,detected_pts(:,:,n),n,'V') + + CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n,'V') + ! + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(G0%gphiv,G1%gphiv, & + G0%glamv,G1%glamv,masksrc,matrix,src_add,dst_add) + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL get_remap_bicub(G0%gphiv,G1%gphiv, & + G0%glamv,G1%glamv,masksrc,matrix,src_add,dst_add) + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),& + nxfin,nyfin,matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) THEN ! clem: not coded for V + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), & + G0%e1v,G0%e2v,G1%e1v,G1%e2v,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + ENDIF + ENDIF + + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) * G1%vmask(:,:,n) + ! + END SELECT + ! + ! + dimnames(1)='x' + dimnames(2)='y' + IF( vert_coord_name == '1' ) THEN + dimnames(3)=TRIM(timedimname) + + ALLOCATE(tabvar3d(SIZE(tabinterp4d,1),SIZE(tabinterp4d,2),SIZE(tabinterp4d,3))) + tabvar3d=tabinterp4d(:,:,:,1) + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabvar3d,1,'double') + DEALLOCATE(tabvar3d) + ELSE + dimnames(3)=vert_coord_name + dimnames(4)=TRIM(timedimname) + + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabinterp4d,1,n,'double') + ENDIF + ! + ! + CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_file),Child_file) + ! + ! + IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,src_add,dst_add) + ! + END DO + ! + DEALLOCATE(detected_pts) + DEALLOCATE(tabinterp4d) + DEALLOCATE(tabvar1,tabvar2,tabvar3) + DEALLOCATE(masksrc) + ! + ENDIF + + END DO + + ! change the before fields + IF(rhot == 1) THEN + WRITE(*,*) '' + WRITE(*,*) 'no time interpolation (time refinement ratio = 1)' + ELSE + now_wght = (rhot-1.)/rhot + before_wght = 1./rhot + ! + ! --- 4D variables --- ! + CALL Read_Ncdf_var('un',Child_file,un) + CALL Read_Ncdf_var('vn',Child_file,vn) + CALL Read_Ncdf_var('ub',Child_file,ub) + CALL Read_Ncdf_var('vb',Child_file,vb) + ub = now_wght*un + before_wght*ub + vb = now_wght*vn + before_wght*vb + ! + CALL Read_Ncdf_var('tb',Child_file,tb) + CALL Read_Ncdf_var('tn',Child_file,tn) + tb = now_wght*tn + before_wght*tb + ! + CALL Read_Ncdf_var('sb',Child_file,sb) + CALL Read_Ncdf_var('sn',Child_file,sn) + sb = now_wght*sn + before_wght*sb + ! + CALL Read_Ncdf_var('e3t_b',Child_file,e3t_b) + CALL Read_Ncdf_var('e3t_n',Child_file,e3t_n) + e3t_b = now_wght*e3t_n + before_wght*e3t_b + ! + dimnames(1)='x' + dimnames(2)='y' + dimnames(3)='nav_lev' + dimnames(4)=TRIM(timedimname) + CALL Write_Ncdf_var('ub',dimnames,Child_file,ub,'double') + CALL Write_Ncdf_var('vb',dimnames,Child_file,vb,'double') + CALL Write_Ncdf_var('tb',dimnames,Child_file,tb,'double') + CALL Write_Ncdf_var('sb',dimnames,Child_file,sb,'double') + CALL Write_Ncdf_var('e3t_b',dimnames,Child_file,e3t_b,'double') + ! + DEALLOCATE(un,ub,vn,vb,tn,tb,sn,sb,e3t_n,e3t_b) + !---------------------- + ! + ! --- 3D variables --- ! + CALL Read_Ncdf_var('sshb',Child_file,sshb) + CALL Read_Ncdf_var('sshn',Child_file,sshn) + sshb = now_wght*sshn + before_wght*sshb + ! + dimnames(1)='x' + dimnames(2)='y' + dimnames(3)=TRIM(timedimname) + CALL Write_Ncdf_var('sshb',dimnames,Child_file,sshb,'double') + ! + DEALLOCATE(sshn,sshb) + !---------------------- + ! + ENDIF + ! + ! + WRITE(*,*) ' ' + WRITE(*,*) ' --- list of all the variables that have been interpolated --- ' + WRITE(*,*) Ncdf_varname + WRITE(*,*) ' ' + WRITE(*,*) '******* restart file successfully created *******' + WRITE(*,*) ' ' + ! + STOP +END PROGRAM + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_ice.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_ice.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b4c213c1014e0bc6d4cae260c3e5a47e83776c0 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_ice.f90 @@ -0,0 +1,346 @@ +! +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +PROGRAM create_rstrt_ice + ! + USE NETCDF + USE bilinear_interp + USE bicubic_interp + USE agrif_readwrite + USE io_netcdf + USE agrif_extrapolation + USE agrif_interpolation + USE agrif_partial_steps + USE agrif_connect_topo + ! + IMPLICIT NONE + ! + !************************************************************************ + ! * + ! PROGRAM CREATE_RSTRT_ICE * + ! * + ! program to interpolate parent grid restart file to child grid * + ! * + ! * + !Interpolation is carried out using bilinear interpolation * + !routine from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + !************************************************************************ + ! + ! variables declaration + ! + CHARACTER*20,DIMENSION(:),POINTER :: Ncdf_varname => NULL() + CHARACTER*20 :: vert_coord_name + CHARACTER*1 :: posvar + CHARACTER*100 :: Child_file,Childcoordinates,varname,Child_Bathy_Level,Child_Bathy_Meter + REAL*8, POINTER, DIMENSION(:,:,:) :: tabvar00, tabvar3d,mask => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabinterp4d,tabvar0,tabvar1,tabvar2,tabvar3 => NULL() + REAL*8, POINTER, DIMENSION(:) :: tabtemp1D,nav_lev => NULL() + REAL*8, POINTER, DIMENSION(:,:) :: tabtemp2D => NULL() + INTEGER,DIMENSION(:),POINTER :: src_add,dst_add => NULL() + REAL*8,DIMENSION(:,:),POINTER :: matrix => NULL() + LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL() + LOGICAL, DIMENSION(:,:,:), POINTER :: detected_pts + LOGICAL :: Interpolation,Extrapolation,Pacifique + INTEGER :: narg,iargc,ncid,x,y,z + INTEGER :: ii,jl,status,varid,numdims + CHARACTER(len=20),DIMENSION(4) :: dimnames + CHARACTER(len=80) :: namelistname + TYPE(Coordinates) :: G0,G1 + INTEGER :: jpl + REAL*8 :: tabtemp0dreal + + LOGICAL, PARAMETER :: conservation = .FALSE. + ! + narg = iargc() + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + ! + ! read input file + ! + CALL read_namelist(namelistname) + ! + IF(TRIM(restart_ice_file) == '') THEN + WRITE(*,*) 'no ice restart file specified in ',TRIM(namelistname) + STOP + ENDIF + + ! + WRITE(*,*) '' + WRITE(*,*) 'Interpolation of restart file : ',TRIM(restart_ice_file) + WRITE(*,*) '' + ! + CALL Read_Ncdf_VarName(restart_ice_file,Ncdf_varname) + ! + CALL set_child_name(parent_coordinate_file,Childcoordinates) + IF( TRIM(parent_bathy_level) /= '' ) CALL set_child_name(parent_bathy_level,Child_Bathy_Level) + IF( TRIM(parent_bathy_meter) /= '' ) CALL set_child_name(parent_bathy_meter,Child_Bathy_Meter) + ! + ! create this file + ! + CALL set_child_name(restart_ice_file,Child_file) + status = nf90_create(Child_file,NF90_WRITE,ncid) + status = nf90_close(ncid) + WRITE(*,*) 'Child grid restart file name = ',TRIM(Child_file) + WRITE(*,*) '' + ! + ! read dimensions in parent restart file + ! + CALL Read_Ncdf_dim('x',restart_ice_file,x) + CALL Read_Ncdf_dim('y',restart_ice_file,y) + CALL Read_Ncdf_dim('numcat',restart_ice_file,z) + + ! + ! mask initialization for extrapolation and interpolation + ! + WRITE(*,*) 'mask initialisation on coarse and fine grids' + ! + status = Read_Local_Coordinates(parent_coordinate_file,G0,(/jpizoom,jpjzoom/),(/x,y/)) + status = Read_Coordinates(Childcoordinates,G1,Pacifique) + ! + !longitude modification if child domain covers Pacific ocean area + ! + IF( Pacifique ) THEN + WHERE( G0%nav_lon < 0 ) + G0%nav_lon = G0%nav_lon + 360. + END WHERE + WHERE( G1%nav_lon < 0 ) + G1%nav_lon = G1%nav_lon + 360. + END WHERE + ENDIF + ! + ! one needs bathy_level + IF( TRIM(parent_bathy_level) /= '' ) THEN + status = Read_bathy_level(TRIM(parent_bathy_level),G0) + status = Read_bathy_level(TRIM(child_bathy_level),G1) + ELSE + status = read_bathy_meter(TRIM(parent_bathy_meter),G0) + status = read_bathy_meter(TRIM(child_bathy_meter),G1) + CALL meter_to_levels(G0) + CALL meter_to_levels(G1) + ENDIF + ! get masks + CALL Init_mask(parent_bathy_level,G0,x,y) + CALL Init_mask(child_bathy_level,G1,nxfin,nyfin) + + ! + ! write dimensions in output file + WRITE(*,*) 'write dimensions' + ! + CALL Write_Ncdf_dim('x',Child_file,nxfin) + CALL Write_Ncdf_dim('y',Child_file,nyfin) + CALL Write_Ncdf_dim('numcat',Child_file,z) + CALL Write_Ncdf_dim('time_counter',Child_file,0) + ! + ! + DO ii = 1,SIZE(Ncdf_varname) + ! + ! loop on variables names + varname = TRIM(Ncdf_varname(ii)) + ! + WRITE(*,*) 'var = ',TRIM(varname) + ! + SELECT CASE (varname) + ! + !copy nav_lon from child coordinates to output file + ! + CASE('nav_lon') + CALL Read_Ncdf_var(varname,TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var(varname,(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file, MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + !copy nav_lat from child coordinates to output file + ! + CASE('nav_lat') + CALL Read_Ncdf_var(varname,TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var(varname,(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + !copy numcat from restart_ice_file to output file + ! + CASE('numcat') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),nav_lev) + CALL Write_Ncdf_var(varname,varname,Child_file,nav_lev,'float') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + Interpolation = .FALSE. + ! + !copy time from restart_ice_file to output file + ! + CASE('time_counter') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp1D) + tabtemp1D = tabtemp1D * rhot + CALL Write_Ncdf_var(varname,'time_counter',Child_file,tabtemp1D,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + DEALLOCATE(tabtemp1D) + Interpolation = .FALSE. + ! + !copy info from restart_ice_file to output file + ! + CASE('kt_ice') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp0dreal) + tabtemp0dreal = tabtemp0dreal * rhot + CALL Write_Ncdf_var(varname,Child_file,tabtemp0dreal,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + Interpolation = .FALSE. + ! + CASE('nn_fsbc') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp0dreal) + CALL Write_Ncdf_var(varname,Child_file,tabtemp0dreal,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + Interpolation = .FALSE. + ! + CASE('frc_voltop','frc_volbot','frc_temtop','frc_tembot') + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp0dreal) + CALL Write_Ncdf_var(varname,Child_file,tabtemp0dreal,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file) + Interpolation = .FALSE. + ! + CASE('u_ice') + vert_coord_name = '1' + posvar='U' + Interpolation = .TRUE. + + CASE('v_ice') + vert_coord_name = '1' + posvar='V' + Interpolation = .TRUE. + + CASE('stress12_i') + vert_coord_name = '1' + posvar='F' + Interpolation = .TRUE. + + CASE DEFAULT + IF( Get_NbDims(TRIM(varname),TRIM(restart_ice_file)) == 4 ) THEN + vert_coord_name = 'numcat' + ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_ice_file)) == 3 ) THEN + vert_coord_name = '1' + ENDIF + posvar='T' + Interpolation = .TRUE. + ! + END SELECT + + ! --- start interpolation --- ! + IF( Interpolation ) THEN + ! + ! + IF( vert_coord_name == '1' ) THEN + jpl = 1 + ELSE + jpl = z + ENDIF + ! + ALLOCATE(detected_pts(SIZE(G0%tmask,1),SIZE(G0%tmask,2),jpl)) + ALLOCATE(tabvar00(x,y,1)) + ALLOCATE(tabvar0(x,y,jpl,1)) + ALLOCATE(tabvar1(x,y,1,1)) + ALLOCATE(tabvar2(x,y,1,1)) + ALLOCATE(tabvar3(x,y,1,1)) + ALLOCATE(masksrc(x,y)) + ALLOCATE(tabinterp4d(nxfin,nyfin,jpl,1)) + + IF( vert_coord_name == '1' ) THEN + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabvar00) + ELSE + CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabvar0) + ENDIF + + DO jl = 1, jpl + ! + WRITE(*,*) 'interpolate/extrapolate for category = ',jl + ! + IF( vert_coord_name == '1' ) THEN + tabvar1(:,:,1,1) = tabvar00(:,:,1) + tabvar2(:,:,1,1) = tabvar00(:,:,1) + tabvar3(:,:,1,1) = tabvar00(:,:,1) + ELSE + tabvar1(:,:,1,1) = tabvar0(:,:,jl,1) + tabvar2(:,:,1,1) = tabvar0(:,:,jl,1) + tabvar3(:,:,1,1) = tabvar0(:,:,jl,1) + ENDIF + ! + CALL extrap_detect(G0,G1,detected_pts(:,:,jl),1,posvar) + CALL correct_field(detected_pts(:,:,jl),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,1,posvar) !clem: nav_lev is useless here + + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(G0%nav_lat,G1%nav_lat,G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,jl,1),nxfin,nyfin,matrix,src_add,dst_add) + CASE('bicubic') + CALL get_remap_bicub(G0%nav_lat,G1%nav_lat,G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,jl,1),nxfin,nyfin,matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) THEN ! clem: currently this does not work (and is only coded for T) + SELECT CASE (posvar) + CASE( 'T' ) + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,jl,1), & + & G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + CASE( 'U' ) + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,jl,1), & + & G0%e1u,G0%e2u,G1%e1u,G1%e2u,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + CASE( 'V' ) + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,jl,1), & + & G0%e1v,G0%e2v,G1%e1v,G1%e2v,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + CASE( 'F' ) + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,jl,1), & + & G0%e1f,G0%e2f,G1%e1f,G1%e2f,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + END SELECT + ENDIF + tabinterp4d(:,:,jl,1) = tabinterp4d(:,:,jl,1) * G1%tmask(:,:,1) + + IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,src_add,dst_add) + + ENDDO + + dimnames(1)='x' + dimnames(2)='y' + IF( vert_coord_name == '1' ) THEN + dimnames(3)='time_counter' + + ALLOCATE(tabvar3d(SIZE(tabinterp4d,1),SIZE(tabinterp4d,2),SIZE(tabinterp4d,3))) + tabvar3d=tabinterp4d(:,:,:,1) + CALL Write_Ncdf_var(varname,dimnames,Child_file,tabvar3d,'double') + DEALLOCATE(tabvar3d) + ELSE + dimnames(3)='numcat' + dimnames(4)='time_counter' + + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabinterp4d,'double') + ENDIF + ! + CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_ice_file),Child_file) + + DEALLOCATE(detected_pts) + DEALLOCATE(tabinterp4d) + DEALLOCATE(tabvar00, tabvar0, tabvar1,tabvar2,tabvar3) + DEALLOCATE(masksrc) + + ENDIF + END DO + ! + WRITE(*,*) ' ' + WRITE(*,*) ' --- list of all the variables that have been interpolated --- ' + WRITE(*,*) Ncdf_varname + WRITE(*,*) ' ' + WRITE(*,*) '******* restart file successfully created *******' + WRITE(*,*) ' ' + ! + STOP +END PROGRAM create_rstrt_ice + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_trc.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_trc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3a19a350ebb7bed006ebf7171dc040a2f88597aa --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_create_restart_trc.f90 @@ -0,0 +1,388 @@ +! +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +PROGRAM create_rstrt_trc + ! + USE NETCDF + USE bilinear_interp + USE bicubic_interp + USE agrif_readwrite + USE io_netcdf + USE agrif_extrapolation + USE agrif_interpolation + USE agrif_partial_steps + USE agrif_connect_topo + ! + IMPLICIT NONE + ! + !************************************************************************ + ! * + ! PROGRAM CREATE_RSTRT_TRC * + ! * + ! program to interpolate parent grid restart file to child grid * + ! * + ! * + !Interpolation is carried out using bilinear interpolation * + !routine from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + !************************************************************************ + ! + ! variables declaration + ! + CHARACTER*20,DIMENSION(:),POINTER :: Ncdf_varname => NULL() + CHARACTER*20 :: vert_coord_name + CHARACTER*1 :: posvar + CHARACTER*3 :: prefix + CHARACTER*20:: suffix + CHARACTER*100 :: Child_file,Childcoordinates,varname,varname2,Child_Bathy_Level,Child_Bathy_Meter + REAL*8, POINTER, DIMENSION(:,:,:) :: tabvar3d => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: trb,trn => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabinterp4d,tabvar1,tabvar2,tabvar3 => NULL() + REAL*8, POINTER, DIMENSION(:) :: tabtemp1D,nav_lev => NULL() + REAL*8, POINTER, DIMENSION(:,:) :: tabtemp2D => NULL() + INTEGER,DIMENSION(:),POINTER :: src_add,dst_add => NULL() + REAL*8,DIMENSION(:,:),POINTER :: matrix => NULL() + LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL() + LOGICAL, DIMENSION(:,:,:), POINTER :: detected_pts + LOGICAL :: Interpolation,Extrapolation,Pacifique + INTEGER :: narg,iargc,ncid,x,y,z,nbvert_lev + REAL*8 :: now_wght,before_wght + INTEGER :: ii,ji,jj,jk,status,varid,numdims + CHARACTER(len=20),DIMENSION(4) :: dimnames + CHARACTER(len=80) :: namelistname + TYPE(Coordinates) :: G0,G1 + REAL*8 :: tabtemp0dreal + + LOGICAL, PARAMETER :: conservation = .FALSE. + ! + narg = iargc() + IF (narg == 0) THEN + namelistname = 'namelist.input' + ELSE + CALL getarg(1,namelistname) + ENDIF + ! + ! read input file + ! + CALL read_namelist(namelistname) + ! + IF(TRIM(restart_trc_file) == '') THEN + WRITE(*,*) 'no tracers restart file specified in ',TRIM(namelistname) + STOP + ENDIF + + ! + WRITE(*,*) '' + WRITE(*,*) 'Interpolation of restart file : ',TRIM(restart_trc_file) + WRITE(*,*) '' + ! + CALL Read_Ncdf_VarName(restart_trc_file,Ncdf_varname) + ! + CALL set_child_name(parent_coordinate_file,Childcoordinates) + IF( TRIM(parent_bathy_level) /= '' ) CALL set_child_name(parent_bathy_level,Child_Bathy_Level) + IF( TRIM(parent_bathy_meter) /= '' ) CALL set_child_name(parent_bathy_meter,Child_Bathy_Meter) + ! + ! create this file + ! + CALL set_child_name(restart_trc_file,Child_file) + status = nf90_create(Child_file,NF90_WRITE,ncid) + status = nf90_close(ncid) + WRITE(*,*) 'Child grid restart file name = ',TRIM(Child_file) + WRITE(*,*) '' + ! + ! read dimensions in parent restart file + ! + CALL Read_Ncdf_dim('x',restart_trc_file,x) + CALL Read_Ncdf_dim('y',restart_trc_file,y) + CALL Read_Ncdf_dim('nav_lev',restart_trc_file,z) + + IF( z .NE. N ) THEN + WRITE(*,*) '***' + WRITE(*,*) 'Number of vertical levels doesn t match between namelist and restart file' + WRITE(*,*) 'Please check the values in namelist file' + STOP + ENDIF + ! + ! mask initialization for extrapolation and interpolation + ! + WRITE(*,*) 'mask initialisation on coarse and fine grids' + ! + status = Read_Local_Coordinates(parent_coordinate_file,G0,(/jpizoom,jpjzoom/),(/x,y/)) + status = Read_Coordinates(Childcoordinates,G1,Pacifique) + ! + !longitude modification if child domain covers Pacific ocean area + ! + IF( Pacifique ) THEN + WHERE( G0%nav_lon < 0 ) + G0%nav_lon = G0%nav_lon + 360. + END WHERE + WHERE( G1%nav_lon < 0 ) + G1%nav_lon = G1%nav_lon + 360. + END WHERE + ENDIF + ! + ! one needs bathy_level + IF( TRIM(parent_bathy_level) /= '' ) THEN + status = Read_bathy_level(TRIM(parent_bathy_level),G0) + status = Read_bathy_level(TRIM(child_bathy_level),G1) + ELSE + status = read_bathy_meter(TRIM(parent_bathy_meter),G0) + status = read_bathy_meter(TRIM(child_bathy_meter),G1) + CALL meter_to_levels(G0) + CALL meter_to_levels(G1) + ENDIF + ! get masks + CALL Init_tmask(parent_bathy_level,G0,x,y) + CALL Init_tmask(child_bathy_level,G1,nxfin,nyfin) + +!!clem G0%tmask = 1. + + ! which dataset + status = nf90_open(TRIM(restart_trc_file), NF90_NOWRITE, ncid) ! Open dataset + DO jk = 1, z + ALLOCATE(tabvar1(x,y,1,1)) + ! + status = nf90_inq_varid(ncid, "TRNDIC", VarId) !PISCES + IF (status == nf90_noerr) THEN + CALL Read_Ncdf_var('TRNDIC',TRIM(restart_trc_file),tabvar1,1,jk) + ELSE + status = nf90_inq_varid(ncid, "TRNNO3" , VarId) ! LOBSTER + IF (status == nf90_noerr) THEN + CALL Read_Ncdf_var('TRNNO3',TRIM(restart_trc_file),tabvar1,1,jk) + ELSE + status = nf90_inq_varid(ncid, "TRNCFC11", VarId) ! CFC + IF (status == nf90_noerr) THEN + CALL Read_Ncdf_var('TRNCFC11',TRIM(restart_trc_file),tabvar1,1,jk) + ELSE + status = nf90_inq_varid(ncid, "TRNCLR ", VarId) ! My TRC + IF (status == nf90_noerr) THEN + CALL Read_Ncdf_var('TRNCLR',TRIM(restart_trc_file),tabvar1,1,jk) + ELSE + WRITE(*,*) 'No suitable tracer found to build the mask ' + ENDIF + ENDIF + ENDIF + ENDIF + WHERE( tabvar1(:,:,1,1) == 0. ) + G0%tmask(:,:,jk) = 0. + END WHERE + DEALLOCATE(tabvar1) + END DO + + ! + ! write dimensions in output file + WRITE(*,*) 'write dimensions' + ! + CALL Write_Ncdf_dim('x',Child_file,nxfin) + CALL Write_Ncdf_dim('y',Child_file,nyfin) + CALL Write_Ncdf_dim('nav_lev',Child_file,z) + CALL Write_Ncdf_dim('time_counter',Child_file,0) + ! + ! + DO ii = 1,SIZE(Ncdf_varname) + ! + ! loop on variables names + varname = TRIM(Ncdf_varname(ii)) + WRITE(*,*) 'var = ',TRIM(varname) + ! + SELECT CASE (TRIM(varname)) + ! + CASE('nav_lon') + CALL Read_Ncdf_var('nav_lon',TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var('nav_lon',(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att('nav_lon',TRIM(restart_trc_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + CASE('nav_lat') + CALL Read_Ncdf_var('nav_lat',TRIM(Childcoordinates),tabtemp2D) + CALL Write_Ncdf_var('nav_lat',(/'x','y'/),Child_file,tabtemp2D,'float') + CALL Copy_Ncdf_att('nav_lat',TRIM(restart_trc_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D)) + DEALLOCATE(tabtemp2D) + Interpolation = .FALSE. + ! + CASE('nav_lev') + CALL Read_Ncdf_var('nav_lev',TRIM(restart_trc_file),nav_lev) + CALL Write_Ncdf_var('nav_lev','z',Child_file,nav_lev,'float') + CALL Copy_Ncdf_att('nav_lev',TRIM(restart_trc_file),Child_file) + Interpolation = .FALSE. + ! + CASE('time_counter') + CALL Read_Ncdf_var('time_counter',TRIM(restart_trc_file),tabtemp1D) + tabtemp1D = tabtemp1D * rhot + CALL Write_Ncdf_var('time_counter','time_counter',Child_file,tabtemp1D,'double') + CALL Copy_Ncdf_att('time_counter',TRIM(restart_trc_file),Child_file) + DEALLOCATE(tabtemp1D) + Interpolation = .FALSE. + ! + CASE('kt','ndastp','adatrj','ntime','rdttrc1') + CALL Read_Ncdf_var(TRIM(varname),TRIM(restart_trc_file),tabtemp0dreal) + SELECT CASE (TRIM(varname)) + CASE('rdttrc1') + tabtemp0dreal = tabtemp0dreal / rhot + CASE('kt') + tabtemp0dreal = tabtemp0dreal * rhot + END SELECT + CALL Write_Ncdf_var(TRIM(varname),Child_file,tabtemp0dreal,'double') + CALL Copy_Ncdf_att(varname,TRIM(restart_trc_file),Child_file) + Interpolation = .FALSE. + ! + CASE DEFAULT + IF( Get_NbDims(TRIM(varname),TRIM(restart_trc_file)) == 4 ) THEN + vert_coord_name = 'nav_lev' + ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_trc_file)) == 3 ) THEN + vert_coord_name = '1' + ENDIF + posvar='T' + Interpolation = .TRUE. + ! + END SELECT + ! + ! --- start interpolation --- ! + IF( Interpolation ) THEN + ! + IF( vert_coord_name == '1' ) THEN + nbvert_lev = 1 + ELSE + nbvert_lev = z + ENDIF + + ALLOCATE(detected_pts(SIZE(G0%tmask,1),SIZE(G0%tmask,2),nbvert_lev)) + ALLOCATE(tabvar1(x,y,1,2)) + ALLOCATE(tabvar2(x,y,1,1)) + ALLOCATE(tabvar3(x,y,1,1)) + ALLOCATE(masksrc(x,y)) + ALLOCATE(tabinterp4d(nxfin,nyfin,1,1)) + + ! + DO n = 1,nbvert_lev + ! + WRITE(*,*) 'interpolate/extrapolate for vertical level = ',n + ! + CALL Read_Ncdf_var(varname,TRIM(restart_trc_file),tabvar1,1,n) + IF(n==1) THEN + ! + ELSE IF (n==2) THEN + tabvar2(:,:,:,1) = tabvar1(:,:,:,2) + ELSE + tabvar3(:,:,:,1) = tabvar2(:,:,:,1) + tabvar2(:,:,:,1) = tabvar1(:,:,:,2) + ENDIF + ! + ! + IF(MAXVAL(G1%tmask(:,:,n)) == 0.) THEN + tabinterp4d = 0.0 + WRITE(*,*) 'only land points on level ',n + ELSE + CALL extrap_detect(G0,G1,detected_pts(:,:,n),n) + + CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n) + + ! for the following variables, you do not want to mask the values + IF( TRIM(varname) == 'Silicalim' .OR. TRIM(varname) == 'Silicamax' ) THEN + masksrc(:,:) = .TRUE. + ENDIF + + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(G0%nav_lat,G1%nav_lat, & + G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL get_remap_bicub(G0%nav_lat,G1%nav_lat, & + G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add) + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),& + nxfin,nyfin,matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) THEN ! clem: it currently does not work + CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), & + G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1) + ENDIF + ENDIF + + IF( ALL(masksrc) ) THEN + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) + ELSE + tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) * G1%tmask(:,:,n) + ENDIF + + ! + dimnames(1)='x' + dimnames(2)='y' + IF( vert_coord_name == '1' ) THEN + dimnames(3)='time_counter' + + ALLOCATE(tabvar3d(SIZE(tabinterp4d,1),SIZE(tabinterp4d,2),SIZE(tabinterp4d,3))) + tabvar3d=tabinterp4d(:,:,:,1) + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabvar3d,1,'double') + DEALLOCATE(tabvar3d) + ELSE + dimnames(3)=vert_coord_name + dimnames(4)='time_counter' + + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabinterp4d,1,n,'double') + ENDIF + ! + ! + CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_trc_file),Child_file) + ! + ! + IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,src_add,dst_add) + ! + ! + END DO + ! + DEALLOCATE(detected_pts) + DEALLOCATE(tabinterp4d) + DEALLOCATE(tabvar1,tabvar2,tabvar3) + DEALLOCATE(masksrc) + ! + ENDIF + + ! change the before fields + prefix = varname(1:3) + suffix = varname(4:LEN_TRIM(varname)) + + IF(rhot == 1 .OR. prefix/= 'TRB') THEN + WRITE(*,*) '' + WRITE(*,*) 'no time interpolation for ',TRIM(varname) + ELSE + ALLOCATE(trn(nxfin,nyfin,z,1),trb(nxfin,nyfin,z,1)) + varname2 = 'TRN'//TRIM(suffix) + now_wght = (rhot-1.)/rhot + before_wght = 1./rhot + ! + CALL Read_Ncdf_var(TRIM(varname),Child_file,trb) + CALL Read_Ncdf_var(TRIM(varname2),Child_file,trn) + trb = now_wght*trn + before_wght*trb + + dimnames(1)='x' + dimnames(2)='y' + dimnames(3)='nav_lev' + dimnames(4)='time_counter' + CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,trb,'double') + DEALLOCATE(trn,trb) + ! + ENDIF + + END DO + ! + WRITE(*,*) ' ' + WRITE(*,*) ' --- list of all the variables that have been interpolated --- ' + WRITE(*,*) Ncdf_varname + WRITE(*,*) ' ' + WRITE(*,*) '******* restart file successfully created *******' + WRITE(*,*) ' ' + ! + STOP +END PROGRAM create_rstrt_trc + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_extrapolation.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_extrapolation.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0f4b5a395bc210f362e3935fa1bd1e2790efd7d1 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_extrapolation.f90 @@ -0,0 +1,650 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +MODULE agrif_extrapolation + ! + USE agrif_types + USE agrif_readwrite + USE io_netcdf + USE agrif_gridsearch + + IMPLICIT NONE + +CONTAINS + ! + !************************************************************************ + ! * + ! MODULE AGRIF_EXTRAPOLATION * + ! * + !************************************************************************ + ! + !**************************************************************** + ! subroutine extrap_detect * + ! * + ! detection on each level of points * + ! where extrapolation is required * + ! * + !**************************************************************** + ! + ! + SUBROUTINE extrap_detect(G0,G1,detected,n,posvar) + ! + LOGICAL, DIMENSION(:,:) :: detected + TYPE(Coordinates) :: G0,G1 + CHARACTER(*), OPTIONAL :: posvar + INTEGER :: i,j,k,ic,jc,compt,dst_add,n + INTEGER, DIMENSION(1) :: i_min,j_min + ! + IF( PRESENT(posvar) .AND. posvar == 'U' ) THEN + CALL get_detected_pts(G0%gphiu,G1%gphiu,G0%glamu,G1%glamu, & + G0%umask(:,:,n),G1%umask(:,:,n),detected(:,:)) + ELSEIF( PRESENT(posvar) .AND. posvar == 'V' ) THEN + CALL get_detected_pts(G0%gphiv,G1%gphiv,G0%glamv,G1%glamv, & + G0%vmask(:,:,n),G1%vmask(:,:,n),detected(:,:)) + ELSEIF( PRESENT(posvar) .AND. posvar == 'F' ) THEN + CALL get_detected_pts(G0%gphif,G1%gphif,G0%glamf,G1%glamf, & + G0%fmask(:,:,n),G1%fmask(:,:,n),detected(:,:)) + ELSE + CALL get_detected_pts(G0%gphit,G1%gphit,G0%glamt,G1%glamt, & + G0%tmask(:,:,n),G1%tmask(:,:,n),detected(:,:)) +!clem CALL get_detected_pts(G0%nav_lat,G1%nav_lat,G0%nav_lon,G1%nav_lon, & +!clem G0%tmask(:,:,n),G1%tmask(:,:,n),detected(:,:)) + ENDIF + ! + END SUBROUTINE extrap_detect + ! + ! + !**************************************************************** + ! end subroutine extrap_detect * + !**************************************************************** + ! + ! + !**************************************************************** + ! subroutine correct_field * + ! correct field on detected points * + ! * + !**************************************************************** + ! + SUBROUTINE correct_field(detected_pts,tabin,tabinkm1,tabinkm2,G0,nav_lev,newmask,k,posvar) + ! + LOGICAL, DIMENSION(:,:) :: detected_pts + LOGICAL, DIMENSION(:,:) :: newmask + CHARACTER(*),OPTIONAL :: posvar + INTEGER :: k + ! + INTEGER :: i,j,ii,jj,nx,ny,n,lbi,ubi,lbj,ubj,kpos,ipos,jpos,r + ! + REAL*8, DIMENSION(:,:,:,:) :: tabin + REAL*8, DIMENSION(:,:,:,:) :: tabinkm1 + REAL*8, DIMENSION(:,:,:,:) :: tabinkm2 + REAL*8, DIMENSION(:) :: nav_lev + REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: mask + REAL*8, DIMENSION(:,:), ALLOCATABLE :: lon,lat + REAL*8 :: deriv,deriv_min + LOGICAL :: found + ! + TYPE(Coordinates) :: G0 + ! + ! copy coarse grid mask in newmask + ! + IF ( PRESENT(posvar) .AND. posvar == 'U' ) THEN + WHERE(G0%umask(:,:,k) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%umask,1),SIZE(G0%umask,2),SIZE(G0%umask,3))) + ALLOCATE(lat(SIZE(G0%umask,1),SIZE(G0%umask,2))) + ALLOCATE(lon(SIZE(G0%umask,1),SIZE(G0%umask,2))) + mask = G0%umask + lat = G0%gphiu + lon = G0%glamu + ELSE IF ( PRESENT(posvar) .AND. posvar == 'V' ) THEN + WHERE(G0%vmask(:,:,k) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%vmask,1),SIZE(G0%vmask,2),SIZE(G0%vmask,3))) + ALLOCATE(lat(SIZE(G0%vmask,1),SIZE(G0%vmask,2))) + ALLOCATE(lon(SIZE(G0%vmask,1),SIZE(G0%vmask,2))) + mask = G0%vmask + lat = G0%gphiv + lon = G0%glamv + ELSE IF ( PRESENT(posvar) .AND. posvar == 'F' ) THEN + WHERE(G0%fmask(:,:,k) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%fmask,1),SIZE(G0%fmask,2),SIZE(G0%fmask,3))) + ALLOCATE(lat(SIZE(G0%fmask,1),SIZE(G0%fmask,2))) + ALLOCATE(lon(SIZE(G0%fmask,1),SIZE(G0%fmask,2))) + mask = G0%fmask + lat = G0%gphif + lon = G0%glamf + ELSE + WHERE(G0%tmask(:,:,k) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%tmask,1),SIZE(G0%tmask,2),SIZE(G0%tmask,3))) + ALLOCATE(lat(SIZE(G0%tmask,1),SIZE(G0%tmask,2))) + ALLOCATE(lon(SIZE(G0%tmask,1),SIZE(G0%tmask,2))) + mask = G0%tmask + lat = G0%gphit + lon = G0%glamt +!clem mask = G0%tmask +!clem lon = G0%nav_lon +!clem lat = G0%nav_lat + ENDIF + ! + ! dimensions initialisation + ! + nx = SIZE(tabin,1) + ny = SIZE(tabin,2) + ! + ! + DO j = 1,ny + ! + DO i = 1,nx + ! + IF( detected_pts(i,j) ) THEN + ! + r = 0 + found = .FALSE. + deriv_min = 2000000. + ipos=0 + jpos=0 + ! + DO WHILE(.NOT. found) + ! + r = r + 1 + ! + IF(i-r < 1 ) THEN + lbi = 1 + ubi = MIN(i+r,nx) + ELSE IF(i+r > nx) THEN + lbi = MAX(i-r,1) + ubi = nx + ELSE + lbi = i-r + ubi = i+r + ENDIF + ! + IF(j-r < 1) THEN + lbj = 1 + ubj = MIN(j+r,ny) + ELSE IF(j+r > ny) THEN + lbj = MAX(j-r,1) + ubj = ny + ELSE + lbj = j-r + ubj = j+r + ENDIF + ! + DO jj = lbj,ubj,ubj-lbj + DO ii = lbi,ubi,ubi-lbi + ! + deriv = search_pts_h(ii,jj,k,i,j,k,tabin(:,:,1,1),mask,lon,lat) + ! + IF( ABS(deriv) < deriv_min ) THEN + deriv_min = ABS(deriv) + ipos = ii + jpos = jj + kpos = k + ENDIF + ! + deriv = search_pts_v(ii,jj,k-1,i,j,k,tabinkm1,tabinkm2,mask,nav_lev,lon,lat) + ! + IF( ABS(deriv) < deriv_min ) THEN + deriv_min = ABS(deriv) + ipos = ii + jpos = jj + kpos = k-1 + ENDIF + ! + END DO + END DO + ! + ! + IF( deriv_min < 2000000. ) THEN + ! + IF(kpos == k) tabin(i,j,1,1) = tabin(ipos,jpos,1,1) + IF(kpos == k-1) tabin(i,j,1,1) = tabinkm1(ipos,jpos,1,1) + found = .TRUE. + newmask(i,j) = .TRUE. + ELSE IF ((lbi == 1).AND.(ubi == nx).AND.(lbj == 1).AND.(ubj == ny)) THEN + found = .TRUE. + newmask(i,j) = .FALSE. + ! + ENDIF + ! + END DO !do while + ! + ENDIF + ! + END DO + ! + END DO + ! + DEALLOCATE(mask,lon,lat) + ! + END SUBROUTINE correct_field + ! + !************************************************************** + ! end subroutine correct_field + !************************************************************** + ! + SUBROUTINE correct_field_2d(detected_pts,tabin,G0,newmask,posvar) + ! + LOGICAL, DIMENSION(:,:) :: detected_pts + LOGICAL, DIMENSION(:,:) :: newmask + CHARACTER(*), OPTIONAL :: posvar + LOGICAL :: found + INTEGER :: k + ! + INTEGER :: i,j,ii,jj,nx,ny,n,lbi,ubi,lbj,ubj,ipos,jpos,r + ! + REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: mask + REAL*8, DIMENSION(:,:), ALLOCATABLE :: lon,lat + REAL*8, DIMENSION(:,:,:) :: tabin + REAL*8 :: deriv,deriv_min + ! + TYPE(Coordinates) :: G0 + ! + ! copy coarse grid mask in newmask + ! + mask = G0%tmask + lon = G0%nav_lon + lat = G0%nav_lat + IF ( PRESENT(posvar) .AND. posvar == 'U' ) THEN + WHERE(G0%umask(:,:,1) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%umask,1),SIZE(G0%umask,2),SIZE(G0%umask,3))) + ALLOCATE(lat(SIZE(G0%umask,1),SIZE(G0%umask,2))) + ALLOCATE(lon(SIZE(G0%umask,1),SIZE(G0%umask,2))) + mask = G0%umask + lat = G0%gphiu + lon = G0%glamu + ELSE IF ( PRESENT(posvar) .AND. posvar == 'V' ) THEN + WHERE(G0%vmask(:,:,1) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%vmask,1),SIZE(G0%vmask,2),SIZE(G0%vmask,3))) + ALLOCATE(lat(SIZE(G0%vmask,1),SIZE(G0%vmask,2))) + ALLOCATE(lon(SIZE(G0%vmask,1),SIZE(G0%vmask,2))) + mask = G0%vmask + lat = G0%gphiv + lon = G0%glamv + ELSE + WHERE(G0%tmask(:,:,1) == 1. ) + newmask(:,:) = .TRUE. + ELSEWHERE + newmask(:,:) = .FALSE. + END WHERE + ALLOCATE(mask(SIZE(G0%tmask,1),SIZE(G0%tmask,2),SIZE(G0%tmask,3))) + ALLOCATE(lat(SIZE(G0%tmask,1),SIZE(G0%tmask,2))) + ALLOCATE(lon(SIZE(G0%tmask,1),SIZE(G0%tmask,2))) + mask = G0%tmask + lon = G0%nav_lon + lat = G0%nav_lat + ENDIF + + ! + ! dimensions initialisation + ! + nx = SIZE(tabin,1) + ny = SIZE(tabin,2) + ! + DO i = 1,nx + ! + DO j = 1,ny + ! + ! + IF( detected_pts(i,j) ) THEN + ! + r = 0 + found = .FALSE. + deriv_min = 2000000. + ipos=0 + jpos=0 + ! + DO WHILE (.NOT. found ) + + ! + r = r + 1 + ! + IF(i-r < 1 ) THEN + lbi = 1 + ubi = MIN(i+r,nx) + ELSE IF(i+r > nx) THEN + lbi = MAX(i-r,1) + ubi = nx + ELSE + lbi = i-r + ubi = i+r + ENDIF + ! + IF(j-r < 1) THEN + lbj = 1 + ubj = MIN(j+r,ny) + ELSE IF(j+r > ny) THEN + lbj = MAX(j-r,1) + ubj = ny + ELSE + lbj = j-r + ubj = j+r + ENDIF + ! + DO ii = lbi,ubi + DO jj = lbj,ubj + ! + deriv = search_pts_h(ii,jj,1,i,j,1,tabin(:,:,1),mask,lon,lat) + ! + IF( ABS(deriv) < deriv_min ) THEN + deriv_min = ABS(deriv) + ipos = ii + jpos = jj + ENDIF + ! + END DO + END DO + ! + ! + IF( deriv_min < 2000000. ) THEN + ! + found = .TRUE. + tabin(i,j,1) = tabin(ipos,jpos,1) + newmask(i,j) = .TRUE. + ! + ENDIF + ! + END DO !do while + ! + ENDIF + ! + END DO + ! + END DO + ! + DEALLOCATE(mask,lon,lat) + ! + END SUBROUTINE correct_field_2d + ! + !************************************************************** + ! function get_dist + !************************************************************** + ! + + ! + REAL*8 FUNCTION get_dist(plat1,plon1,plat2,plon2) + ! + REAL*8 :: plat1,plon1,plat2,plon2 + REAL*8 :: dist,ra,rad,rpi,lat,lon + ! + rpi = 3.141592653589793 + rad = rpi/180. + ra = 6371229. + ! + lat = plat2-plat1 + lon = plon2-plon1 + ! + dist = ra * rad * SQRT( (COS(rad*(plat1+plat2)/2.)*lon)**2 + lat**2 ) + get_dist = dist + RETURN + ! + END FUNCTION get_dist + + ! + ! + !************************************************************** + ! end function get_dist + !************************************************************** + ! + ! + !************************************************************** + ! subroutine check_extrap + !************************************************************** + ! + + ! + SUBROUTINE check_extrap(Grid,tabin,k) + ! + REAL*8, DIMENSION(:,:,:,:) :: tabin + TYPE(Coordinates) :: Grid + INTEGER :: i,j,k + ! + DO i = 2,SIZE(tabin,1)-1 + DO j=2,SIZE(tabin,2)-1 + ! + IF( Grid%tmask(i,j,k) == 1. .AND. tabin(i,j,1,1)==0.) THEN + ! + WRITE(*,*) 'no masked point with value zero (',i,',',j,',',k,')' + ! + ENDIF + + END DO + END DO + ! + END SUBROUTINE check_extrap + + ! + ! + !************************************************************** + ! end subroutine check_extrap + !************************************************************** + ! + !************************************************************** + ! subroutine search_pts_h + !************************************************************** + ! + REAL*8 FUNCTION search_pts_h(i,j,k,ipt,jpt,kpt,tabvar,mask,lon,lat) + ! + REAL*8 :: hx,hy,fx,fy + REAL*8 :: h_x,h_y + REAL*8, DIMENSION(:,:) :: tabvar + INTEGER :: i,j,k,ipt,jpt,kpt,nx,ny + LOGICAL :: foundx,foundy + REAL*8, DIMENSION(:,:,:) :: mask + REAL*8, DIMENSION(:,:) :: lon,lat + ! + ! + foundx = .TRUE. + foundy = .TRUE. + ! + nx = SIZE(tabvar,1) + ny = SIZE(tabvar,2) + ! + IF( i==ipt .AND. j==jpt ) THEN + search_pts_h = 2000000. + RETURN + ENDIF + ! + IF( mask(i,j,k) == 0. ) THEN + search_pts_h = 2000000. + RETURN + ENDIF + ! + ! x direction + ! + IF(i+1<=nx .AND. i-1>=1) THEN + IF(mask(i+1,j,k)==1. .AND. mask(i-1,j,k)==1.) THEN + hx = get_dist(lat(i+1,j),lon(i+1,j),& + lat(i-1,j),lon(i-1,j)) + fx = (tabvar(i+1,j) - tabvar(i-1,j))/hx + ELSE IF(mask(i+1,j,k)==1. .AND. mask(i-1,j,k)==0. .AND. mask(i,j,k)==1.) THEN + hx = get_dist(lat(i+1,j),lon(i+1,j),& + lat(i,j),lon(i,j)) + fx = (tabvar(i+1,j) - tabvar(i,j))/hx + ELSE IF(mask(i+1,j,k)==0. .AND. mask(i-1,j,k)==1. .AND. mask(i,j,k)==1.) THEN + hx = get_dist(lat(i,j),lon(i,j),& + lat(i-1,j),lon(i-1,j)) + fx = (tabvar(i,j) - tabvar(i-1,j))/hx + ELSE + foundx = .FALSE. + ENDIF + ! + ELSE IF(i+1<=nx .AND. i>=1) THEN + ! + IF(mask(i+1,j,k)==1. .AND. mask(i,j,k)==1.) THEN + hx = get_dist(lat(i+1,j),lon(i+1,j),& + lat(i,j),lon(i,j)) + fx = (tabvar(i+1,j) - tabvar(i,j))/hx + ELSE + foundx = .FALSE. + ENDIF + ! + ELSE IF(i<=nx .AND. i-1>=1) THEN + ! + IF(mask(i,j,k)==1. .AND. mask(i-1,j,k)==1.) THEN + hx = get_dist(lat(i,j),lon(i,j),& + lat(i-1,j),lon(i-1,j)) + fx = (tabvar(i,j) - tabvar(i-1,j))/hx + ELSE + foundx = .FALSE. + ENDIF + ! + ELSE + foundy = .FALSE. + ENDIF + + ! + ! y direction + ! + IF(j+1<=ny .AND. j-1>=1) THEN + IF( mask(i,j+1,k)==1. .AND. mask(i,j-1,k)==1. ) THEN + hy = get_dist(lat(i,j+1),lon(i,j+1),& + lat(i,j-1),lon(i,j-1)) + fy = (tabvar(i,j+1) - tabvar(i,j-1))/hy + ELSE IF( mask(i,j+1,k)==1. .AND. mask(i,j-1,k)==0. .AND. mask(i,j,k)==1.) THEN + hy = get_dist(lat(i,j+1),lon(i,j+1),& + lat(i,j),lon(i,j)) + fy = (tabvar(i,j+1) - tabvar(i,j))/hy + ELSE IF( mask(i,j+1,k)==0. .AND. mask(i,j-1,k)==1. .AND. mask(i,j,k)==1.) THEN + hy = get_dist(lat(i,j),lon(i,j),& + lat(i,j-1),lon(i,j-1)) + fy = (tabvar(i,j) - tabvar(i,j-1))/hy + ELSE + foundy = .FALSE. + ENDIF + ! + ELSE IF(j+1<=ny .AND. j>=1) THEN + ! + IF(mask(i,j+1,k)==1. .AND. mask(i,j,k)==1.) THEN + hy = get_dist(lat(i,j+1),lon(i,j+1),& + lat(i,j),lon(i,j)) + fy = (tabvar(i,j+1) - tabvar(i,j))/hy + ELSE + foundy = .FALSE. + ENDIF + ! + ELSE IF(j<=ny .AND. j-1>=1) THEN + ! + IF(mask(i,j,k)==1. .AND. mask(i,j-1,k)==1.) THEN + hy = get_dist(lat(i,j),lon(i,j),& + lat(i,j-1),lon(i,j-1)) + fy = (tabvar(i,j) - tabvar(i,j-1))/hy + ELSE + foundy = .FALSE. + ENDIF + ! + ELSE + foundy = .FALSE. + ENDIF + ! + h_x = get_dist(lat(ipt,jpt),lon(ipt,jpt),lat(ipt,jpt),lon(i,j)) + h_y = get_dist(lat(ipt,jpt),lon(ipt,jpt),lat(i,j),lon(ipt,jpt)) + ! + IF(.NOT.foundx .AND. .NOT.foundy)THEN + search_pts_h = 2000000. + ELSE IF( foundx .AND. foundy) THEN + search_pts_h = h_x * fx + h_y * fy + ELSE IF( .NOT.foundx .AND. foundy .AND. h_y.NE.0.) THEN + search_pts_h = h_y * fy + ELSE IF( foundx .AND. .NOT.foundy .AND. h_x.NE.0.) THEN + search_pts_h = h_x * fx + ELSE + search_pts_h = 2000000. + ENDIF + + ! + RETURN + ! + END FUNCTION search_pts_h + ! + !************************************************************** + ! end subroutine search_pts_h + !************************************************************** + ! + !************************************************************** + ! subroutine search_pts_v + !************************************************************** + ! + REAL*8 FUNCTION search_pts_v(i,j,k,ipt,jpt,kpt,tabvarkm1,tabvarkm2,mask,depth,lon,lat) + ! + REAL*8 :: hz,fz,dz,fh + REAL*8, DIMENSION(:) :: depth + REAL*8, DIMENSION(:,:,:,:) :: tabvarkm1,tabvarkm2 + INTEGER :: i,j,k,ipt,jpt,kpt,nx,ny + LOGICAL :: foundz + REAL*8, DIMENSION(:,:,:) :: mask + REAL*8, DIMENSION(:,:) :: lon,lat + ! + IF( k <= 2 .OR. mask(i,j,k) == 0. ) THEN + ! + search_pts_v = 2000000. + RETURN + ! + ELSE IF( i==ipt .AND. j==jpt .AND. mask(i,j,k-1) == 1. .AND. mask(i,j,k-2) == 1. ) THEN + ! + dz = depth(k) - depth(k-1) + hz = depth(kpt) - depth(k) + search_pts_v = ((tabvarkm2(i,j,1,1) - tabvarkm1(i,j,1,1))/dz)*hz + RETURN + ! + ELSE + ! + IF( mask(i,j,k) == 1. .AND. mask(i,j,k-1) == 1. ) THEN + ! + dz = depth(k) - depth(k-1) + fz = (tabvarkm2(i,j,1,1) - tabvarkm1(i,j,1,1))/dz + hz = depth(kpt) - depth(k) + ! + ELSE + foundz = .FALSE. + ENDIF + ! + fh = search_pts_h(i,j,k,ipt,jpt,k,tabvarkm1(:,:,1,1),mask,lon,lat) + ! + IF(foundz) THEN + search_pts_v = hz * fz + fh + RETURN + ELSE + search_pts_v = 2000000. + RETURN + ENDIF + ! + ENDIF + WRITE(*,*) 'cas 2', search_pts_v + ! + RETURN + ! + END FUNCTION search_pts_v + ! + !************************************************************** + ! end subroutine search_pts_v + !************************************************************** + ! + ! +END MODULE agrif_extrapolation diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_gridsearch.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_gridsearch.f90 new file mode 100644 index 0000000000000000000000000000000000000000..929a79ee8efe25c909545ec69782689d691774d9 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_gridsearch.f90 @@ -0,0 +1,760 @@ +! +MODULE agrif_gridsearch + ! + USE agrif_modutil + ! + !************************************************************************ + ! * + ! MODULE AGRIF_GRIDSEARCH * + ! * + !************************************************************************ + ! + !----------------------------------------------------------------------- + IMPLICIT NONE + + !----------------------------------------------------------------------- + ! variables that describe each grid + !----------------------------------------------------------------------- + ! + ! integer :: grid1_size,grid2_size,grid1_rank, grid2_rank + ! integer, dimension(:), pointer :: grid1_dims, grid2_dims + ! logical, dimension(:), pointer :: grid1_mask,grid2_mask + ! real*8,dimension(:),pointer :: grid1_center_lat,grid1_center_lon,grid2_center_lat,grid2_center_lon + ! + ! real*8,dimension(:,:), pointer :: grid1_bound_box,grid2_bound_box + ! integer, parameter :: num_srch_bins = 90 + ! integer,dimension(:,:),pointer :: bin_addr1,bin_addr2 + ! real*8, dimension(:,:),pointer :: bin_lats,bin_lons + REAL*8, PARAMETER :: zero = 0.0, & + one = 1.0, & + two = 2.0, & + three = 3.0, & + four = 4.0, & + five = 5.0, & + half = 0.5, & + quart = 0.25, & + bignum = 1.e+20, & + tiny = 1.e-14, & + pi = 3.14159265359, & + pi2 = two*pi, & + pih = half*pi + ! + REAL*8, PARAMETER :: deg2rad = pi/180. + ! + ! +CONTAINS + ! + ! + SUBROUTINE get_detected_pts(grid1_lat,grid2_lat,grid1_lon,grid2_lon,maskC,maskF,detected_pts) + ! + !----------------------------------------------------------------------- + !this routine makes any necessary changes (e.g. for 0,2pi longitude range) + !----------------------------------------------------------------------- + ! + REAL*8,DIMENSION(:,:),POINTER :: grid1_lat,grid2_lat,grid1_lon,grid2_lon + LOGICAL, POINTER, DIMENSION(:,:) :: masksrc,maskdst + LOGICAL, DIMENSION(:,:) :: detected_pts + REAL*8,DIMENSION(:,:) :: maskF,maskC + LOGICAL,POINTER,DIMENSION(:) :: detected_pts_1D + REAL*8 :: plat,plon + INTEGER :: lastsrc_add + INTEGER, DIMENSION(4) :: src_add + REAL*8,DIMENSION(4) :: src_lats,src_lons + INTEGER :: grid1_size,grid2_size,grid1_rank, grid2_rank + INTEGER, DIMENSION(:), POINTER :: grid1_dims, grid2_dims + LOGICAL, DIMENSION(:), POINTER :: grid1_mask,grid2_mask + REAL*8,DIMENSION(:),POINTER :: grid1_center_lat,grid1_center_lon,grid2_center_lat,grid2_center_lon + + REAL*8,DIMENSION(:,:), POINTER :: grid1_bound_box,grid2_bound_box + ! integer, parameter :: num_srch_bins = 90 + INTEGER,DIMENSION(:,:),POINTER :: bin_addr1,bin_addr2 + REAL*8, DIMENSION(:,:),POINTER :: bin_lats,bin_lons + + REAL*8, PARAMETER :: zero = 0.0, & + one = 1.0, & + two = 2.0, & + three = 3.0, & + four = 4.0, & + five = 5.0, & + half = 0.5, & + quart = 0.25, & + bignum = 1.e+20, & + tiny = 1.e-14, & + pi = 3.14159265359, & + pi2 = two*pi, & + pih = half*pi + + REAL*8, PARAMETER :: deg2rad = pi/180. + ! + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + ! + INTEGER :: n,nele,i,j,ip1,jp1,n_add,e_add,ne_add,nx,ny + INTEGER :: xpos,ypos,dst_add + ! + ! integer mask + ! + INTEGER, DIMENSION(:), POINTER :: imask + ! + ! lat/lon intervals for search bins + ! + REAL*8 :: dlat,dlon + ! + ! temps for computing bounding boxes + ! + REAL*8, DIMENSION(4) :: tmp_lats, tmp_lons + ! + ! write(*,*)'proceed to Bilinear interpolation ...' + ! + ALLOCATE(grid1_dims(2),grid2_dims(2)) + ! + grid1_dims(1) = SIZE(grid1_lat,2) + grid1_dims(2) = SIZE(grid1_lat,1) + grid2_dims(1) = SIZE(grid2_lat,2) + grid2_dims(2) = SIZE(grid2_lat,1) + grid1_size = SIZE(grid1_lat,2) * SIZE(grid1_lat,1) + grid2_size = SIZE(grid2_lat,2) * SIZE(grid2_lat,1) + ! + !----------------------------------------------------------------------- + ! allocate grid coordinates/masks and read data + !----------------------------------------------------------------------- + ! + ALLOCATE( grid1_bound_box (4,grid1_size),grid2_bound_box (4,grid2_size)) + + ALLOCATE(detected_pts_1D(grid1_size)) + ALLOCATE(masksrc(SIZE(maskC,1),SIZE(maskC,2))) + ALLOCATE(maskdst(SIZE(maskF,1),SIZE(maskF,2))) + ! + WHERE(maskC == 1.) + masksrc= .TRUE. + ELSEWHERE + masksrc= .FALSE. + END WHERE + ! + WHERE(maskF == 1.) + maskdst= .TRUE. + ELSEWHERE + maskdst= .FALSE. + END WHERE + ! + ! + ! + ! 2D array -> 1D array + ! + ALLOCATE(grid1_center_lat(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL tab2Dto1D(grid1_lat,grid1_center_lat) + + ALLOCATE(grid1_center_lon(SIZE(grid1_lon,1)*SIZE(grid1_lon,2))) + CALL tab2Dto1D(grid1_lon,grid1_center_lon) + + ALLOCATE(grid2_center_lat(SIZE(grid2_lat,1)*SIZE(grid2_lat,2))) + CALL tab2Dto1D(grid2_lat,grid2_center_lat) + + ALLOCATE(grid2_center_lon(SIZE(grid2_lon,1)*SIZE(grid2_lon,2))) + CALL tab2Dto1D(grid2_lon,grid2_center_lon) + + ALLOCATE(grid1_mask(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL logtab2Dto1D(masksrc,grid1_mask) + + ALLOCATE(grid2_mask(SIZE(grid2_lat,1)*SIZE(grid2_lat,2))) + CALL logtab2Dto1D(maskdst,grid2_mask) + ! + ! + ! degrees to radian + ! + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + + !----------------------------------------------------------------------- + ! convert longitudes to 0,2pi interval + !----------------------------------------------------------------------- + + WHERE (grid1_center_lon .GT. pi2) grid1_center_lon = & + grid1_center_lon - pi2 + WHERE (grid1_center_lon .LT. zero) grid1_center_lon = & + grid1_center_lon + pi2 + WHERE (grid2_center_lon .GT. pi2) grid2_center_lon = & + grid2_center_lon - pi2 + WHERE (grid2_center_lon .LT. zero) grid2_center_lon = & + grid2_center_lon + pi2 + + !----------------------------------------------------------------------- + ! + ! make sure input latitude range is within the machine values + ! for +/- pi/2 + ! + !----------------------------------------------------------------------- + + WHERE (grid1_center_lat > pih) grid1_center_lat = pih + WHERE (grid1_center_lat < -pih) grid1_center_lat = -pih + WHERE (grid2_center_lat > pih) grid2_center_lat = pih + WHERE (grid2_center_lat < -pih) grid2_center_lat = -pih + + !----------------------------------------------------------------------- + ! + ! compute bounding boxes for restricting future grid searches + ! + !----------------------------------------------------------------------- + ! + nx = grid1_dims(1) + ny = grid1_dims(2) + + DO n=1,grid1_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid1_center_lat(e_add) - & + grid1_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ip1=nx + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid1_center_lat(n_add) - & + grid1_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + jp1=ny + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid1_center_lat(n) + tmp_lats(2) = grid1_center_lat(e_add) + tmp_lats(3) = grid1_center_lat(ne_add) + tmp_lats(4) = grid1_center_lat(n_add) + + tmp_lons(1) = grid1_center_lon(n) + tmp_lons(2) = grid1_center_lon(e_add) + tmp_lons(3) = grid1_center_lon(ne_add) + tmp_lons(4) = grid1_center_lon(n_add) + + grid1_bound_box(1,n) = MINVAL(tmp_lats) + grid1_bound_box(2,n) = MAXVAL(tmp_lats) + + grid1_bound_box(3,n) = MINVAL(tmp_lons) + grid1_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + + nx = grid2_dims(1) + ny = grid2_dims(2) + + DO n=1,grid2_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid2_center_lat(e_add) - & + grid2_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid2_center_lat(n_add) - & + grid2_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid2_center_lat(n) + tmp_lats(2) = grid2_center_lat(e_add) + tmp_lats(3) = grid2_center_lat(ne_add) + tmp_lats(4) = grid2_center_lat(n_add) + + tmp_lons(1) = grid2_center_lon(n) + tmp_lons(2) = grid2_center_lon(e_add) + tmp_lons(3) = grid2_center_lon(ne_add) + tmp_lons(4) = grid2_center_lon(n_add) + + grid2_bound_box(1,n) = MINVAL(tmp_lats) + grid2_bound_box(2,n) = MAXVAL(tmp_lats) + grid2_bound_box(3,n) = MINVAL(tmp_lons) + grid2_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + ! + ! + ! + WHERE (ABS(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) + grid1_bound_box(3,:) = zero + grid1_bound_box(4,:) = pi2 + END WHERE + + WHERE (ABS(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) + grid2_bound_box(3,:) = zero + grid2_bound_box(4,:) = pi2 + END WHERE + + !*** + !*** try to check for cells that overlap poles + !*** + + WHERE (grid1_center_lat > grid1_bound_box(2,:)) & + grid1_bound_box(2,:) = pih + + WHERE (grid1_center_lat < grid1_bound_box(1,:)) & + grid1_bound_box(1,:) = -pih + + WHERE (grid2_center_lat > grid2_bound_box(2,:)) & + grid2_bound_box(2,:) = pih + + WHERE (grid2_center_lat < grid2_bound_box(1,:)) & + grid2_bound_box(1,:) = -pih + + !----------------------------------------------------------------------- + ! set up and assign address ranges to search bins in order to + ! further restrict later searches + !----------------------------------------------------------------------- + + ALLOCATE(bin_addr1(2,90)) + ALLOCATE(bin_addr2(2,90)) + ALLOCATE(bin_lats (2,90)) + ALLOCATE(bin_lons (2,90)) + + dlat = pi/90 + + DO n=1,90 + bin_lats(1,n) = (n-1)*dlat - pih + bin_lats(2,n) = n*dlat - pih + bin_lons(1,n) = zero + bin_lons(2,n) = pi2 + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + END DO + + DO nele=1,grid1_size + DO n=1,90 + IF (grid1_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid1_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr1(1,n) = MIN(nele,bin_addr1(1,n)) + bin_addr1(2,n) = MAX(nele,bin_addr1(2,n)) + ENDIF + END DO + END DO + + DO nele=1,grid2_size + DO n=1,90 + IF (grid2_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid2_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr2(1,n) = MIN(nele,bin_addr2(1,n)) + bin_addr2(2,n) = MAX(nele,bin_addr2(2,n)) + ENDIF + END DO + END DO + ! + ! Call init_remap_vars + ! + + lastsrc_add=1 + detected_pts_1D = .FALSE. + ! + DO dst_add = 1, grid2_size + ! + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + !*** + !*** find nearest square of grid points on source grid + !*** + CALL grid_search_bilin(bin_lons,bin_lats,src_add, src_lats, src_lons, & + plat, plon, grid1_dims, & + grid1_center_lat, grid1_center_lon, & + grid1_bound_box, bin_addr1, bin_addr2,lastsrc_add) + ! + IF (src_add(1) > 0) THEN + ! + IF(grid2_mask(dst_add)) THEN !mask true on destination grid + DO n=1,4 + IF(.NOT. grid1_mask(src_add(n))) THEN + detected_pts_1D(src_add(n)) = .TRUE. + ENDIF + END DO + ENDIF + ENDIF + END DO + ! + ! + CALL logtab1Dto2D(detected_pts_1D,detected_pts,SIZE(detected_pts,2),SIZE(detected_pts,1)) + ! + DEALLOCATE(detected_pts_1D,grid1_bound_box,grid2_bound_box) + DEALLOCATE(grid1_center_lon,grid1_center_lat,grid2_center_lon,grid2_center_lat) + DEALLOCATE(grid1_mask,grid2_mask,masksrc,maskdst) + DEALLOCATE(bin_addr1,bin_addr2,bin_lats,bin_lons) + DEALLOCATE(grid1_dims,grid2_dims) + ! + !----------------------------------------------------------------------- + + END SUBROUTINE get_detected_pts + + !********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE GRID_SEARCH_BILIN + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE grid_search_bilin(bin_lons,bin_lats,src_add, src_lats, src_lons, & + plat, plon, src_grid_dims, & + src_center_lat, src_center_lon, & + src_grid_bound_box, & + src_bin_add, dst_bin_add,lastsrc_add) + + !----------------------------------------------------------------------- + ! + ! this routine finds the location of the search point plat, plon + ! in the source grid and returns the corners needed for a bilinear + ! interpolation. + ! + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------------- + ! + ! address of each corner point enclosing P + ! + INTEGER,DIMENSION(4) :: src_add + REAL*8,DIMENSION(4) :: src_lats,src_lons + ! + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + ! + ! latitude, longitude of the search point + ! + REAL*8, DIMENSION(:,:) :: bin_lats,bin_lons + REAL*8, INTENT(in) :: plat,plon + ! + ! size of each src grid dimension + ! + INTEGER, DIMENSION(2), INTENT(in) :: src_grid_dims + ! + ! latitude, longitude of each src grid center + ! + REAL*8, DIMENSION(:), INTENT(in) :: src_center_lat,src_center_lon + ! + ! bound box for source grid + ! + REAL*8, DIMENSION(:,:), INTENT(in) :: src_grid_bound_box + ! + ! latitude bins for restricting searches + ! + INTEGER, DIMENSION(:,:), INTENT(in) ::src_bin_add,dst_bin_add + + INTEGER,OPTIONAL :: lastsrc_add + INTEGER :: loopsrc,l1,l2 + ! + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + ! + INTEGER :: n,next_n,srch_add,nx, ny,min_add, max_add, & + i, j, jp1, ip1, n_add, e_add, ne_add + + + REAL*8 :: vec1_lat, vec1_lon,vec2_lat, vec2_lon, cross_product, & + cross_product_last,coslat_dst, sinlat_dst, coslon_dst, & + sinlon_dst,dist_min, distance + + !----------------------------------------------------------------------- + ! restrict search first using bins + !----------------------------------------------------------------------- + + src_add = 0 + + min_add = SIZE(src_center_lat) + max_add = 1 + DO n=1,90 + IF (plat >= bin_lats(1,n) .AND. plat <= bin_lats(2,n) .AND. & + plon >= bin_lons(1,n) .AND. plon <= bin_lons(2,n)) THEN + min_add = MIN(min_add, src_bin_add(1,n)) + max_add = MAX(max_add, src_bin_add(2,n)) + ENDIF + END DO + + !----------------------------------------------------------------------- + ! now perform a more detailed search + !----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + loopsrc=0 + DO WHILE (loopsrc <= max_add) + + + l1=MAX(min_add,lastsrc_add-loopsrc) + l2=MIN(max_add,lastsrc_add+loopsrc) + + loopsrc = loopsrc+1 + + srch_loop: DO srch_add = l1,l2,MAX(l2-l1,1) + + !*** first check bounding box + + IF (plat <= src_grid_bound_box(2,srch_add) .AND. & + plat >= src_grid_bound_box(1,srch_add) .AND. & + plon <= src_grid_bound_box(4,srch_add) .AND. & + plon >= src_grid_bound_box(3,srch_add)) THEN + !*** + !*** we are within bounding box so get really serious + !*** + !*** determine neighbor addresses + ! + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + ! + IF (i < nx) THEN + ip1 = i + 1 + ELSE + ip1 = 1 + ENDIF + ! + IF (j < ny) THEN + jp1 = j+1 + ELSE + jp1 = 1 + ENDIF + ! + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + ! + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + ! + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + ! + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + ! + vec1_lon = src_lons(1) - plon + IF (vec1_lon > pi) THEN + src_lons(1) = src_lons(1) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(1) = src_lons(1) + pi2 + ENDIF + DO n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + IF (vec1_lon > pi) THEN + src_lons(n) = src_lons(n) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(n) = src_lons(n) + pi2 + ENDIF + END DO + ! + corner_loop: DO n=1,4 + next_n = MOD(n,4) + 1 + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the box. + !*** + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + !*** + !*** check for 0,2pi crossings + !*** + IF (vec1_lon > three*pih) THEN + vec1_lon = vec1_lon - pi2 + ELSE IF (vec1_lon < -three*pih) THEN + vec1_lon = vec1_lon + pi2 + ENDIF + IF (vec2_lon > three*pih) THEN + vec2_lon = vec2_lon - pi2 + ELSE IF (vec2_lon < -three*pih) THEN + vec2_lon = vec2_lon + pi2 + ENDIF + ! + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + ! + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + IF (n == 1) cross_product_last = cross_product + IF (cross_product*cross_product_last < zero) & + EXIT corner_loop + cross_product_last = cross_product + ! + END DO corner_loop + !*** + !*** if cross products all same sign, we found the location + !*** + IF (n > 4) THEN + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + ! + lastsrc_add = srch_add + RETURN + ENDIF + !*** + !*** otherwise move on to next cell + !*** + ENDIF !bounding box check + END DO srch_loop + + + ENDDO + + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + !print *,'Could not find location for ',plat,plon + !print *,'Using nearest-neighbor average for this point' + ! + coslat_dst = COS(plat) + sinlat_dst = SIN(plat) + coslon_dst = COS(plon) + sinlon_dst = SIN(plon) + ! + dist_min = bignum + src_lats = bignum + DO srch_add = min_add,max_add + distance = ACOS(coslat_dst*COS(src_center_lat(srch_add))* & + (coslon_dst*COS(src_center_lon(srch_add)) + & + sinlon_dst*SIN(src_center_lon(srch_add)))+ & + sinlat_dst*SIN(src_center_lat(srch_add))) + + IF (distance < dist_min) THEN + sort_loop: DO n=1,4 + IF (distance < src_lats(n)) THEN + DO i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + END DO + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + EXIT sort_loop + ENDIF + END DO sort_loop + ENDIF + END DO + ! + src_lons = one/(src_lats + tiny) + distance = SUM(src_lons) + src_lats = src_lons/distance + + !----------------------------------------------------------------------- + + END SUBROUTINE grid_search_bilin + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE INIT_REMAP_VARS + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! subroutine init_remap_vars + ! + !----------------------------------------------------------------------- + ! + ! this routine initializes some variables and provides an initial + ! allocation of arrays (fairly large so frequent resizing + ! unnecessary). + ! + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! determine the number of weights + !----------------------------------------------------------------------- + ! num_wts = 1 ! bilinear interpolation + !----------------------------------------------------------------------- + ! initialize num_links and set max_links to four times the largest + ! of the destination grid sizes initially (can be changed later). + ! set a default resize increment to increase the size of link + ! arrays if the number of links exceeds the initial size + !!----------------------------------------------------------------------- + ! + ! num_links_map1 = 0 + ! max_links_map1 = 4*grid2_size + ! if (num_maps > 1) then + ! num_links_map2 = 0 + ! max_links_map1 = max(4*grid1_size,4*grid2_size) + ! max_links_map2 = max_links_map1 + ! endif + ! + ! resize_increment = 0.1*max(grid1_size,grid2_size) + ! + !----------------------------------------------------------------------- + ! allocate address and weight arrays for mapping 1 + !----------------------------------------------------------------------- + ! + ! allocate (grid1_add_map1(max_links_map1), & + ! grid2_add_map1(max_links_map1), & + ! wts_map1(num_wts, max_links_map1)) + ! + ! grid1_add_map1 = 0. + ! grid2_add_map1 = 0. + ! wts_map1 = 0.! + ! + !!----------------------------------------------------------------------- + ! + ! end subroutine init_remap_vars + +END MODULE agrif_gridsearch diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_interpolation.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_interpolation.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e28a0ef55a9730f1be0afa92de716918ab6d1fa9 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_interpolation.f90 @@ -0,0 +1,1054 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +MODULE agrif_interpolation + ! + USE agrif_types + USE io_netcdf + USE bicubic_interp + USE bilinear_interp + USE agrif_extrapolation + USE agrif_readwrite + ! + ! + !************************************************************************ + ! * + ! MODULE AGRIF_INTERPOLATION * + ! * + ! module containing subroutine used for : * + ! - Forcing data interpolation * + ! - Parent to Child coordinates interpolation * + ! * + !************************************************************************ + ! + ! +CONTAINS + ! + ! + !**************************************************************** + ! subroutine agrif_interp * + ! * + ! subroutine to interpolate coordinates * + ! * + ! - input : * + ! tabin : coarse grid coordinate variable * + ! typevar : position of interpolated variable on cells * + ! * + ! - ouput : * + ! tabout : coordinate variable interpolated on fine grid * + ! * + !**************************************************************** + ! + SUBROUTINE agrif_interp(tabin,tabout,typevar) + ! + REAL*8,DIMENSION(:,:) :: tabin,tabout + CHARACTER(*) :: typevar + REAL*8 :: cff1 + INTEGER :: ii,jj + REAL*8,DIMENSION(:,:),ALLOCATABLE :: tabouttemp + ! + ! + ! + IF( ln_agrif_domain ) THEN + CALL agrif_base_interp2(tabin,tabout,imin,jmin,typevar) + ELSE + CALL agrif_base_interp3(tabin,tabout,imin,jmin,typevar) + ENDIF + + ! + END SUBROUTINE agrif_interp + ! + ! + SUBROUTINE agrif_base_interp2(tabin,tabout,i_min,j_min,typevar) + ! + IMPLICIT NONE + REAL*8,DIMENSION(:,:) :: tabin,tabout + REAL*8 :: cff1 + INTEGER :: i_min,j_min + INTEGER :: ii,jj,i,j + CHARACTER(*) :: typevar + REAL*8,DIMENSION(:),ALLOCATABLE :: xc,yc,xf,yf + REAL*8,DIMENSION(:,:),ALLOCATABLE :: tabtemp + REAL*8 :: dxc,dyc,dxf,dyf + REAL*8 :: decalxc,decalyc,decalxf,decalyf + + INTEGER :: ptx,pty + REAL*8 :: val(4),xval(4) + + INTEGER :: nxc,nyc,nxf,nyf + REAL :: xmin,ymin,x,y + INTEGER :: ic,jc,itemp,jtemp + + nxc = SIZE(tabin,1) + nyc = SIZE(tabin,2) + + nxf = SIZE(tabout,1) + nyf = SIZE(tabout,2) + ! + + ALLOCATE(xc(nxc)) + ALLOCATE(yc(nyc)) + ALLOCATE(xf(nxf)) + ALLOCATE(yf(nyf)) + + ALLOCATE(tabtemp(nxc,nyf)) + + dxc = 1. + dyc = 1. + dxf = 1./REAL(irafx) + dyf = 1./REAL(irafy) + + IF (typevar .EQ. 'F') THEN + ptx = 1 + nbghostcellsfine + pty = 1 + nbghostcellsfine + decalxc = 0. + decalyc = 0. + decalxf = 0. + decalyf = 0. + ELSEIF (typevar .EQ. 'T') THEN + ptx = 2 + nbghostcellsfine + pty = 2 + nbghostcellsfine + decalxc = dxc/2. + decalyc = dyc/2. + decalxf = dxf/2. + decalyf = dyf/2. + ELSEIF (typevar .EQ. 'U') THEN + ptx = 1 + nbghostcellsfine + pty = 2 + nbghostcellsfine + decalxc = 0. + decalyc = dyc/2. + decalxf = 0. + decalyf = dyf/2. + ELSEIF (typevar .EQ. 'V') THEN + ptx = 2 + nbghostcellsfine + pty = 1 + nbghostcellsfine + decalxc = dxc/2. + decalyc = 0. + decalxf = dxf/2. + decalyf = 0. + ENDIF + + DO i=1,nxc + xc(i) = 0. + (i-ptx) * dxc + decalxc + ENDDO + + DO j=1,nyc + yc(j) = 0. + (j-pty) * dyc + decalyc + ENDDO + + + xmin = (i_min - 1) * dxc + ymin = (j_min - 1) * dyc + + DO i=1,nxf + xf(i) = xmin + (i-ptx) * dxf + decalxf + ENDDO + + DO j=1,nyf + yf(j) = ymin + (j-pty) * dyf + decalyf + ENDDO + + + DO j = 1,nyf + DO i = 1,nxc + x = xc(i) + y = yf(j) + + ic = ptx + NINT((x-0.-decalxc)/dxc) + jc = pty + agrif_int((y-0.-decalyc)/dyc) + + jc = jc - 1 + + CALL polint(yc(jc:jc+3),tabin(ic,jc:jc+3),4,y,tabtemp(i,j)) + ENDDO + ENDDO + + DO j = 1,nyf + DO i = 1,nxf + x = xf(i) + y = yf(j) + + itemp = ptx + agrif_int((x-0.-decalxc)/dxc) + jtemp = pty + NINT((y-ymin-decalyf)/dyf) + + itemp = itemp - 1 + + val = tabtemp(itemp:itemp+3,jtemp) + xval = xc(itemp:itemp+3) + CALL polint(xval,val,4,x,tabout(i,j)) + + ENDDO + ENDDO + + DEALLOCATE(xc,yc,xf,yf,tabtemp) + + + END SUBROUTINE agrif_base_interp2 + ! + ! + SUBROUTINE agrif_base_interp3(tabin,tabout,i_min,j_min,typevar) + ! + IMPLICIT NONE + REAL*8,DIMENSION(:,:) :: tabin,tabout + INTEGER :: i_min,j_min + CHARACTER(*) :: typevar + + INTEGER :: nxf,nyf,nxc,nyc,zx,zy + INTEGER :: ji,jj,jif,jjf,jic,jjc,jic1,jjc1,jdecx,jdecy + REAL*8 :: Ax, Bx, Ay, By + + nxf = SIZE(tabout,1) + nyf = SIZE(tabout,2) + + nxc = SIZE(tabin,1) + nyc = SIZE(tabin,2) + + SELECT CASE(typevar) + CASE('T') + IF(MOD(irafx,2)==1) THEN ! odd + zx = 1 ; zy = 1 ; jdecx = FLOOR(irafx/2.) ; jdecy = FLOOR(irafy/2.) + ELSE ! even + zx = 2 ; zy = 2 ; jdecx = FLOOR(irafx/2.) ; jdecy = FLOOR(irafy/2.) + ENDIF + CASE('U') + IF(MOD(irafx,2)==1) THEN ! odd + zx = 1 ; zy = 1 ; jdecx = irafx - 1 ; jdecy = FLOOR(irafy/2.) + ELSE ! even + zx = 1 ; zy = 2 ; jdecx = irafx - 1 ; jdecy = FLOOR(irafy/2.) + ENDIF + CASE('V') + IF(MOD(irafx,2)==1) THEN ! odd + zx = 1 ; zy = 1 ; jdecx = FLOOR(irafx/2.) ; jdecy = irafy - 1 + ELSE ! even + zx = 2 ; zy = 1 ; jdecx = FLOOR(irafx/2.) ; jdecy = irafy - 1 + ENDIF + CASE('F') + IF(MOD(irafx,2)==1) THEN ! odd + zx = 1 ; zy = 1 ; jdecx = irafx - 1 ; jdecy = irafy - 1 + ELSE ! even + zx = 1 ; zy = 1 ; jdecx = irafx - 1 ; jdecy = irafy - 1 + ENDIF + END SELECT + + + DO jj = 1, nyf + + jjf = jj - jdecy + jjc = j_min + FLOOR((jjf-1.) / irafy) + + DO ji = 1, nxf + + jif = ji - jdecx + jic = i_min + FLOOR((jif-1.) / irafx) + + Bx = MOD( zx*jif-1, zx*irafx ) / REAL(zx*irafx) + By = MOD( zy*jjf-1, zy*irafy ) / REAL(zy*irafy) + Ax = 1. - Bx + Ay = 1. - By + + jic1 = MIN( nxc, jic+1 ) ! avoid out of bounds for tabin below + jjc1 = MIN( nyc, jjc+1 ) ! -- + + tabout(ji,jj) = ( Bx * tabin(jic1,jjc ) + Ax * tabin(jic,jjc ) ) * Ay + & + & ( Bx * tabin(jic1,jjc1) + Ax * tabin(jic,jjc1) ) * By + END DO + END DO + + ! + END SUBROUTINE agrif_base_interp3 + + ! + SUBROUTINE polint(xin,valin,n,x,val) + IMPLICIT NONE + INTEGER n + REAL*8 xin(n), valin(n) + REAL*8 x,val + + INTEGER ns,i,m + REAL *8 dif,dift + REAL*8 c(n),d(n),ho,hp,w,den,dy + + ns = 1 + dif = ABS(x-xin(1)) + + DO i=1,n + dift = ABS(x-xin(i)) + IF (dift < dif) THEN + ns = i + dif = dift + ENDIF + c(i) = valin(i) + d(i) = valin(i) + ENDDO + + val = valin(ns) + ns = ns - 1 + + DO m=1,n-1 + DO i=1,n-m + ho = xin(i)-x + hp = xin(i+m)-x + w=c(i+1)-d(i) + den = w/(ho-hp) + d(i) = hp * den + c(i) = ho * den + ENDDO + IF (2*ns < (n-m)) THEN + dy = c(ns+1) + ELSE + dy = d(ns) + ns = ns - 1 + ENDIF + val = val + dy + ENDDO + END SUBROUTINE polint + ! + ! + SUBROUTINE polcoe(xin,valin,n,cof) + IMPLICIT NONE + INTEGER n + REAL*8 xin(n),valin(n),cof(n) + + + INTEGER i,j,k + REAL*8 b,ff,phi,s(n) + + s = 0. + cof = 0. + + s(n)=-xin(1) + DO i=2,n + DO j=n+1-i,n-1 + s(j) =s(j) -xin(i)*s(j+1) + ENDDO + s(n)=s(n)-xin(i) + ENDDO + + DO j=1,n + phi=n + DO k=n-1,1,-1 + phi = k*s(k+1)+xin(j)*phi + ENDDO + ff=valin(j)/phi + b=1. + DO k=n,1,-1 + cof(k)=cof(k)+b*ff + b=s(k)+xin(j)*b + ENDDO + ENDDO + + RETURN + END SUBROUTINE polcoe + ! + + !**************************************************************** + ! subroutine Correctforconservation * + ! * + ! Conservation on domain boundaries ( over 2 coarse grid cells) * + ! * + !**************************************************************** + ! + ! + SUBROUTINE Correctforconservation(tabcoarse,tabfine,e1parent,e2parent,e1,e2,nxfin,nyfin,posvar,i_min,j_min) + IMPLICIT NONE + INTEGER :: nxfin,nyfin + REAL*8,DIMENSION(:,:) :: tabcoarse,tabfine,e1parent,e2parent,e1,e2 + CHARACTER*1 :: posvar + INTEGER :: i_min,j_min,diff + INTEGER ji,jj,ipt,jpt,i,j + INTEGER ind1,ind2,ind3,ind4,ind5,ind6 + REAL*8 cff1,cff2,cff3 + ! + diff = 0 + IF ( MOD(irafx,2) .EQ. 0 ) diff = 1 + ! + ind1 = 2 + CEILING(irafx/2.0) + diff + ind2 = nxfin-(2-1)-CEILING(irafx/2.0) + ind3 = 2 + CEILING(irafy/2.0) + diff + ind4 = nyfin-(2-1)-CEILING(irafy/2.0) + ind5 = nxfin - 1 - irafx - CEILING(irafx/2.0) + ind6 = nyfin - 1 - irafy - CEILING(irafy/2.0) + ! + IF (posvar.EQ.'T') THEN + ! + PRINT *,'correction' + ! + DO ji=ind1,ind1+irafx,irafx + ! + ipt=i_min+(3-1)+(ji-ind1)/irafx + ! + DO jj=ind3,ind4,irafy + ! + jpt=j_min+(3-1)+(jj-ind3)/irafy + + cff1=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff2=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff3=e1parent(ipt,jpt)*e2parent(ipt,jpt)*tabcoarse(ipt,jpt) + + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)= & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)+(cff3-cff2)/cff1 + + END DO + + ENDDO + !**** + DO ji=ind5,ind5+irafx,irafx + ! + ipt=i_min+(3-1)+(ji-ind1)/irafx + + DO jj=ind3,ind4,irafy + jpt=j_min+(3-1)+(jj-ind3)/irafy + + cff1=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff2=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff3=e1parent(ipt,jpt)*e2parent(ipt,jpt)*tabcoarse(ipt,jpt) + + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)= & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)+(cff3-cff2)/cff1 + + END DO + ENDDO + + DO jj=ind3,ind3+irafy,irafy + ! + jpt=j_min+(3-1)+(jj-ind3)/irafy + ! + DO ji=ind1,ind2,irafx + ! + ipt=i_min+(3-1)+(ji-ind1)/irafx + + cff1=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff2=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff3=e1parent(ipt,jpt)*e2parent(ipt,jpt)*tabcoarse(ipt,jpt) + + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)= & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)+(cff3-cff2)/cff1 + + END DO + ENDDO + !**** + DO jj=ind6,ind6+irafy,irafy + ! + jpt=j_min+(3-1)+(jj-ind3)/irafy + ! + DO ji=ind1,ind2,irafx + ipt=i_min+(3-1)+(ji-ind1)/irafx + + cff1=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff2=SUM(e1(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + e2(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)* & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)) + + cff3=e1parent(ipt,jpt)*e2parent(ipt,jpt)*tabcoarse(ipt,jpt) + + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)= & + tabfine(ji-FLOOR(irafx/2.0):ji+FLOOR(irafx/2.0)-diff,jj-FLOOR(irafy/2.0):jj+FLOOR(irafy/2.0)-diff)+(cff3-cff2)/cff1 + + END DO + ENDDO + ! + ! + ENDIF + RETURN + END SUBROUTINE Correctforconservation + + ! + !**************************************************************** + ! subroutine Interp_Extrap_var * + ! * + ! Interpolation and Extrapolation for temperature and salinity * + ! * + ! -input : * + ! filename : file containing variable to interpolate * + ! * + !**************************************************************** + ! + SUBROUTINE Interp_Extrap_var(filename, cd_type) + ! + IMPLICIT NONE + ! + ! variables declaration + ! + CHARACTER(len=80),INTENT(in) :: filename + CHARACTER(len=1 ), OPTIONAL, INTENT(in) :: cd_type + + CHARACTER*100 :: interp_type + CHARACTER*100 :: Child_file,Childcoordinates + CHARACTER*100 :: varname,childbathy + CHARACTER*1 :: posvar + CHARACTER*20,DIMENSION(:),POINTER :: Ncdf_varname + CHARACTER(len=20),DIMENSION(4) :: dimnames + ! + REAL*8, POINTER, DIMENSION(:,:) :: lonParent,latParent => NULL() + REAL*8, POINTER, DIMENSION(:,:) :: lonChild,latChild,latlon_temp => NULL() + REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabinterp4d,tabvar1,tabvar2,tabvar3 => NULL() + REAL*8, POINTER, DIMENSION(:,:,:) :: tabinterp3d,tabvar3d => NULL() + REAL*8, POINTER, DIMENSION(:) :: timedepth_temp,depth => NULL() + REAL*8,DIMENSION(:,:),POINTER :: matrix => NULL() + INTEGER,DIMENSION(:),POINTER :: src_add,dst_add => NULL() + INTEGER, POINTER, DIMENSION(:) :: tabtemp1DInt => NULL() + REAL*8, POINTER, DIMENSION(:) :: nav_lev => NULL() + ! + LOGICAL, DIMENSION(:,:,:), POINTER :: detected_pts => NULL() + REAL*8,DIMENSION(:,:,:),POINTER :: mask => NULL() + LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL() + LOGICAL :: Interpolation,conservation,Pacifique,Extrapolation,land_level + ! + INTEGER :: deptht,time,i,status,ncid,t,ii,j,nb,numlon,numlat + + ! + TYPE(Coordinates) :: G0,G1 + ! + !***************** + !If coarse grid is masked possibility to activate an extrapolation process + ! + Extrapolation = .FALSE. + PRINT*,'DEBUT INTERP_EXTRAP_VAR' + ! + !***************** + ! + ! check grid position + ! + IF( PRESENT(cd_type) ) THEN + posvar = cd_type + ELSE + posvar = 'T' + ENDIF + + ! + ! read dimensions in netcdf file + ! + CALL Read_Ncdf_dim('x',filename,numlon) + CALL Read_Ncdf_dim('y',filename,numlat) + CALL Read_Ncdf_dim('time_counter',filename,time) + IF ( Dims_Existence( 'deptht' , filename ) ) THEN + CALL Read_Ncdf_dim('deptht',filename,deptht) + ELSE IF ( Dims_Existence( 'depthu' , filename ) ) THEN + CALL Read_Ncdf_dim('depthu',filename,deptht) + ELSE IF ( Dims_Existence( 'depthv' , filename ) ) THEN + CALL Read_Ncdf_dim('depthv',filename,deptht) + ELSE IF ( Dims_Existence( 'depthw' , filename ) ) THEN + CALL Read_Ncdf_dim('depthw',filename,deptht) + ELSE IF ( Dims_Existence( 'z' , filename ) ) THEN + CALL Read_Ncdf_dim('z',filename,deptht) + ELSE + deptht = N + ENDIF + + ! + ! retrieve netcdf variable name + ! + CALL Read_Ncdf_VarName(filename,Ncdf_varname) + ! + ! define name of child grid file + ! + CALL set_child_name(filename,Child_file) + CALL set_child_name(parent_coordinate_file,Childcoordinates) + CALL set_child_name(parent_bathy_level,childbathy) + WRITE(*,*) 'Child grid file name = ',TRIM(Child_file) + ! + ! create this file + ! + status = nf90_create(Child_file,NF90_WRITE,ncid) + status = nf90_close(ncid) + ! + ! read coordinates of both domains + ! + status = Read_Coordinates(parent_coordinate_file,G0) + status = Read_Coordinates(Childcoordinates,G1,Pacifique) + ! + ! check consistency of informations read in namelist + ! + IF( imax > SIZE(G0%glamt,1) .OR. jmax > SIZE(G0%glamt,2) .OR. & + imax <= imin .OR. jmax <= jmin ) THEN + WRITE(*,*) 'ERROR ***** bad child grid definition ...' + WRITE(*,*) 'please check imin,jmin,imax,jmax,jpizoom,jpjzoom values' + WRITE(*,*) ' ' + STOP + ENDIF + ! + IF( SIZE(G1%nav_lon,1) .NE. nxfin .OR. SIZE(G1%nav_lon,2) .NE. nyfin ) THEN + WRITE(*,*) 'ERROR ***** bad child coordinates or bathy file ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check that child coordinates file and child bathymetry file' + WRITE(*,*) 'has been created with the current namelist ' + WRITE(*,*) ' ' + STOP + ENDIF + ! + + ! + ! Initialization of T-mask thanks to bathymetry + ! + IF( Extrapolation ) THEN + + WRITE(*,*) 'mask initialisation on coarse and fine grids' + ! + ALLOCATE(mask(numlon,numlat,N)) + CALL Init_mask(childbathy,G1,1,1) + CALL Init_mask(parent_bathy_level,G0,1,1) + ! + ENDIF + + ! + ! select coordinates to use according to variable position + ! + ALLOCATE(lonParent(numlon,numlat),latParent(numlon,numlat)) + ALLOCATE(lonChild(nxfin,nyfin),latChild(nxfin,nyfin)) + + SELECT CASE(posvar) + CASE('T') + lonParent = G0%glamt + latParent = G0%gphit + lonChild = G1%glamt + latChild = G1%gphit + mask = G1%tmask + CASE('U') + lonParent = G0%glamu + latParent = G0%gphiu + lonChild = G1%glamu + latChild = G1%gphiu + mask = G1%umask + CASE('V') + lonParent = G0%glamv + latParent = G0%gphiv + lonChild = G1%glamv + latChild = G1%gphiv + mask = G1%vmask + END SELECT + + DEALLOCATE(G0%glamu,G0%glamv,G0%gphiu,G0%gphiv) + DEALLOCATE(G1%glamu,G1%glamv,G1%gphiu,G1%gphiv) + DEALLOCATE(G1%glamt,G1%gphit,G0%glamt,G0%gphit) + + ! + !longitude modification if child domain covers Pacific ocean area + ! + IF( lonChild(1,1) > lonChild(nxfin,nyfin) ) THEN + Pacifique = .TRUE. + WHERE( lonChild < 0 ) + lonChild = lonChild + 360. + END WHERE + WHERE( lonParent < 0 ) + lonParent = lonParent + 360. + END WHERE + ENDIF + + ! + ! + ! dimensions initialization + ! + CALL Write_Ncdf_dim('x',Child_file,nxfin) + CALL Write_Ncdf_dim('y',Child_file,nyfin) + IF ( Dims_Existence( 'deptht' , filename ) ) CALL Write_Ncdf_dim('deptht',Child_file,deptht) + IF ( Dims_Existence( 'depthu' , filename ) ) CALL Write_Ncdf_dim('depthu',Child_file,deptht) + IF ( Dims_Existence( 'depthv' , filename ) ) CALL Write_Ncdf_dim('depthv',Child_file,deptht) + IF ( Dims_Existence( 'depthw' , filename ) ) CALL Write_Ncdf_dim('depthw',Child_file,deptht) + IF ( Dims_Existence( 'z' , filename ) ) CALL Write_Ncdf_dim('z',Child_file,deptht) + CALL Write_Ncdf_dim('time_counter',Child_file,0) + + IF( deptht .NE. 1 .AND. deptht .NE. N ) THEN + WRITE(*,*) '***' + WRITE(*,*) 'Number of vertical levels doesn t match between namelist' + WRITE(*,*) 'and forcing file ',TRIM(filename) + WRITE(*,*) 'Please check the values in namelist file' + WRITE(*,*) 'N = ',N + WRITE(*,*) 'deptht = ',deptht + STOP + ENDIF + ! + ! + DO i = 1,SIZE(Ncdf_varname) + ! + ! + ! ******************************LOOP ON VARIABLE NAMES******************************************* + ! + ! + SELECT CASE (TRIM(Ncdf_varname(i))) + ! + !copy nav_lon from child coordinates to output file + CASE('nav_lon') + ALLOCATE(latlon_temp(nxfin,nyfin)) + CALL Read_Ncdf_var('nav_lon',TRIM(Childcoordinates),latlon_temp) + CALL Write_Ncdf_var('nav_lon',(/'x','y'/),Child_file,latlon_temp,'float') + CALL Copy_Ncdf_att('nav_lon',TRIM(filename),Child_file, & + MINVAL(latlon_temp),MAXVAL(latlon_temp)) + DEALLOCATE(latlon_temp) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy nav_lat from child coordinates to output file + CASE('nav_lat') + ALLOCATE(latlon_temp(nxfin,nyfin)) + CALL Read_Ncdf_var('nav_lat',TRIM(Childcoordinates),latlon_temp) + CALL Write_Ncdf_var('nav_lat',(/'x','y'/),Child_file,latlon_temp,'float') + CALL Copy_Ncdf_att('nav_lat',TRIM(filename),Child_file, & + MINVAL(latlon_temp),MAXVAL(latlon_temp)) + DEALLOCATE(latlon_temp) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy nav_lev from restart_file to output file + ! + CASE('nav_lev') + + WRITE(*,*) 'copy nav_lev' + CALL Read_Ncdf_var('nav_lev',filename,nav_lev) + IF(.NOT. dimg ) THEN + CALL Write_Ncdf_var('nav_lev','z',Child_file,nav_lev,'float') + CALL Copy_Ncdf_att('nav_lev',filename,Child_file) + ENDIF + DEALLOCATE(nav_lev) + Interpolation = .FALSE. + ! + !copy time_counter from input file to output file + CASE('time_counter') + ALLOCATE(timedepth_temp(time)) + CALL Read_Ncdf_var('time_counter',filename,timedepth_temp) + CALL Write_Ncdf_var('time_counter','time_counter', & + Child_file,timedepth_temp,'float') + CALL Copy_Ncdf_att('time_counter',TRIM(filename),Child_file) + DEALLOCATE(timedepth_temp) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy deptht from input file to output file + CASE('deptht') + ALLOCATE(depth(deptht)) + CALL Read_Ncdf_var('deptht',filename,depth) + CALL Write_Ncdf_var('deptht','deptht',Child_file,depth,'float') + CALL Copy_Ncdf_att('deptht',TRIM(filename),Child_file) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy depthu from input file to output file + CASE('depthu') + ALLOCATE(depth(deptht)) + CALL Read_Ncdf_var('depthu',filename,depth) + CALL Write_Ncdf_var('depthu','depthu',Child_file,depth,'float') + CALL Copy_Ncdf_att('depthu',TRIM(filename),Child_file) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy depthv from input file to output file + CASE('depthv') + ALLOCATE(depth(deptht)) + CALL Read_Ncdf_var('depthv',filename,depth) + CALL Write_Ncdf_var('depthv','depthv',Child_file,depth,'float') + CALL Copy_Ncdf_att('depthv',TRIM(filename),Child_file) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy depthv from input file to output file + CASE('depthw') + ALLOCATE(depth(deptht)) + CALL Read_Ncdf_var('depthw',filename,depth) + CALL Write_Ncdf_var('depthw','depthw',Child_file,depth,'float') + CALL Copy_Ncdf_att('depthw',TRIM(filename),Child_file) + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + !copy time_steps from input file in case of restget use in NEMO in/out routines + CASE('time_steps') + ! print *,'avant time step' + + CALL Read_Ncdf_var('time_steps',filename,tabtemp1DInt) + ! print *,'timedeph = ',tabtemp1DInt + CALL Write_Ncdf_var('time_steps','time_counter',Child_file,tabtemp1DInt,'integer') + CALL Copy_Ncdf_att('time_steps',filename,Child_file) + DEALLOCATE(tabtemp1DInt) + Interpolation = .FALSE. + ! + !store tmask in output file + CASE('tmask') + dimnames(1)='x' + dimnames(2)='y' + dimnames(3)='deptht' + IF (.NOT.ASSOCIATED(G1%tmask)) THEN + ALLOCATE(G1%tmask(nxfin,nyfin,deptht)) + G1%tmask = 1 + ENDIF + CALL Write_Ncdf_var('tmask',dimnames(1:3),Child_file,G1%tmask,'float') + varname = TRIM(Ncdf_varname(i)) + Interpolation = .FALSE. + ! + CASE default + varname = Ncdf_varname(i) + conservation = .FALSE. + CALL get_interptype( varname,interp_type,conservation ) + WRITE(*,*) '**********************************************' + WRITE(*,*) 'varname = ',TRIM(varname), 'at ', posvar, ' point' + WRITE(*,*) 'interp_type = ',TRIM(interp_type) + WRITE(*,*) 'conservation = ',conservation + WRITE(*,*) '***********************************************' + Interpolation = .TRUE. + ! + END SELECT + + ! //////////////// INTERPOLATION FOR 3D VARIABLES ///////////////////////////////////// + ! + IF( Interpolation .AND. Get_NbDims(TRIM(varname),TRIM(filename)) == 3 ) THEN + ! + ALLOCATE(detected_pts(numlon,numlat,N)) + ALLOCATE(masksrc(numlon,numlat)) + ! + ! ******************************LOOP ON TIME******************************************* + !loop on time + DO t = 1,time + ! + IF(extrapolation) THEN + WRITE(*,*) 'interpolation/extrapolation ',TRIM(varname),' for time t = ',t + ELSE + WRITE(*,*) 'interpolation ',TRIM(varname),' for time t = ',t + ENDIF + ! + ALLOCATE(tabvar3d(numlon,numlat,1)) + ALLOCATE(tabinterp3d(nxfin,nyfin,1)) + ! + CALL Read_Ncdf_var(varname,filename,tabvar3d,t) + ! + ! search points where extrapolation is required + ! + IF(Extrapolation) THEN + WHERE( tabvar3d .GE. 1.e+20 ) tabvar3d = 0. + IF (t .EQ. 1. ) CALL extrap_detect(G0,G1,detected_pts(:,:,1),1) + CALL correct_field_2d(detected_pts(:,:,1),tabvar3d,G0,masksrc,'posvar') + ELSE + masksrc = .TRUE. + ENDIF + + IF (t.EQ.1 ) THEN + + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(latParent,latChild, & + lonParent,lonChild, & + masksrc,matrix,src_add,dst_add) + + CASE('bicubic') + CALL get_remap_bicub(latParent,latChild, & + lonParent,lonChild, & + masksrc,matrix,src_add,dst_add) + + END SELECT + ! + ENDIF + ! + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL make_remap(tabvar3d(:,:,1),tabinterp3d(:,:,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL make_bicubic_remap(tabvar3d(:,:,1),masksrc,tabinterp3d(:,:,1),nxfin,nyfin, & + matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) CALL Correctforconservation(tabvar3d(:,:,1),tabinterp3d(:,:,1), & + G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin,jmin) + ! + IF(Extrapolation) tabinterp3d(:,:,1) = tabinterp3d(:,:,1) * mask(:,:,1) + ! + dimnames(1)='x' + dimnames(2)='y' + dimnames(3)='time_counter' + ! + CALL Write_Ncdf_var(TRIM(varname),dimnames(1:3),& + Child_file,tabinterp3d,t,'float') + ! + DEALLOCATE(tabinterp3d) + DEALLOCATE(tabvar3d) + !end loop on time + END DO + ! + DEALLOCATE(detected_pts) + IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,dst_add,src_add) + DEALLOCATE( masksrc) + + CALL Copy_Ncdf_att(TRIM(varname),TRIM(filename),Child_file) + ! + ELSE IF( Interpolation .AND. Get_NbDims(TRIM(varname),TRIM(filename)) == 4 ) THEN + ! + ! + ! //////////////// INTERPOLATION FOR 4D VARIABLES ///////////////////////////////////// + ! + dimnames(1)='x' + dimnames(2)='y' + IF ( Dims_Existence( 'deptht' , filename ) ) dimnames(3)='deptht' + IF ( Dims_Existence( 'depthu' , filename ) ) dimnames(3)='depthu' + IF ( Dims_Existence( 'depthv' , filename ) ) dimnames(3)='depthv' + IF ( Dims_Existence( 'depthw' , filename ) ) dimnames(3)='depthw' + IF ( Dims_Existence( 'z' , filename ) ) dimnames(3)='z' + dimnames(4)='time_counter' + ! + ! loop on vertical levels + ! + DO nb = 1,deptht + ! + ALLOCATE(masksrc(numlon,numlat)) + ALLOCATE(detected_pts(numlon,numlat,N)) + ! + ! point detection et level n + ! + land_level = .FALSE. + IF( Extrapolation ) THEN + IF(MAXVAL(mask(:,:,nb))==0.) land_level = .TRUE. + ENDIF + + + IF ( land_level ) THEN + ! + WRITE(*,*) 'only land points on level ',nb + ALLOCATE(tabinterp4d(nxfin,nyfin,1,1)) + tabinterp4d = 0.e0 + ! + DO ii = 1,time + CALL Write_Ncdf_var(TRIM(varname),dimnames, & + Child_file,tabinterp4d,ii,nb,'float') + END DO + DEALLOCATE(tabinterp4d) + ! + ELSE + ! + ! loop on time + ! + DO t = 1,time + ! + ALLOCATE(tabvar1(numlon,numlat,1,1)) ! level k + IF(Extrapolation) ALLOCATE(tabvar2(numlon,numlat,1,1)) ! level k-1 + IF(Extrapolation) ALLOCATE(tabvar3(numlon,numlat,1,1)) ! level k-2 + ALLOCATE(tabinterp4d(nxfin,nyfin,1,1)) + ! + IF(Extrapolation) THEN + IF(nb==1) THEN + CALL Read_Ncdf_var(varname,filename,tabvar1,t,nb) + WHERE( tabvar1 .GE. 1.e+20 ) tabvar1 = 0. + ELSE IF (nb==2) THEN + CALL Read_Ncdf_var(varname,filename,tabvar2,t,nb-1) + CALL Read_Ncdf_var(varname,filename,tabvar1,t,nb) + WHERE( tabvar1 .GE. 1.e+20 ) tabvar1 = 0. + WHERE( tabvar2 .GE. 1.e+20 ) tabvar2 = 0. + ELSE + CALL Read_Ncdf_var(varname,filename,tabvar3,t,nb-2) + CALL Read_Ncdf_var(varname,filename,tabvar2,t,nb-1) + CALL Read_Ncdf_var(varname,filename,tabvar1,t,nb) + WHERE( tabvar1 .GE. 1.e+20 ) tabvar1 = 0. + WHERE( tabvar2 .GE. 1.e+20 ) tabvar2 = 0. + WHERE( tabvar3 .GE. 1.e+20 ) tabvar3 = 0. + ENDIF + ! + IF (t.EQ.1 ) CALL extrap_detect(G0,G1,detected_pts(:,:,nb),nb) + + CALL correct_field(detected_pts(:,:,nb),tabvar1,tabvar2,& + tabvar3,G0,depth,masksrc,nb,'posvar') + DEALLOCATE(tabvar2,tabvar3) + + ELSE + CALL Read_Ncdf_var(varname,filename,tabvar1,t,nb) + IF(MAXVAL(tabvar1(:,:,1,1))==0.) land_level = .TRUE. + masksrc = .TRUE. + ENDIF + + IF( Extrapolation ) THEN + WRITE(*,*) 'interpolation/extrapolation ',TRIM(varname),' for time t = ',t,'vertical level = ',nb + ELSE + WRITE(*,*) 'interpolation ',TRIM(varname),' for time t = ',t,'vertical level = ',nb + ENDIF + + ! + + IF (t.EQ.1 ) THEN + + SELECT CASE(TRIM(interp_type)) + CASE('bilinear') + CALL get_remap_matrix(latParent,latChild, & + lonParent,lonChild, & + masksrc,matrix,src_add,dst_add) + + CASE('bicubic') + CALL get_remap_bicub(latParent,latChild, & + lonParent,lonChild, & + masksrc,matrix,src_add,dst_add) + ! + END SELECT + ! + ENDIF + ! + SELECT CASE(TRIM(interp_type)) + ! + CASE('bilinear') + CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + CASE('bicubic') + CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),nxfin,nyfin, & + matrix,src_add,dst_add) + END SELECT + ! + IF( conservation ) CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), & + G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin,jmin) + + ! + IF(Extrapolation) CALL check_extrap(G1,tabinterp4d,nb) + ! + IF(Extrapolation) tabinterp4d(:,:,1,1) = tabinterp4d(:,:,1,1) * mask(:,:,nb) + ! + CALL Write_Ncdf_var(TRIM(varname),dimnames, & + Child_file,tabinterp4d,t,nb,'float') + ! + DEALLOCATE(tabinterp4d) + DEALLOCATE(tabvar1) + ! + ! end loop on time + ! + + END DO + + ENDIF + + ! + IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,dst_add,src_add) + DEALLOCATE( masksrc ) + DEALLOCATE(detected_pts) + ! + ! end loop on vertical levels + ! + END DO + ! + CALL Copy_Ncdf_att(TRIM(varname),TRIM(filename),Child_file) + ! + ! fin du if interpolation ... + ! + ENDIF + ! + END DO + + PRINT *,'FIN DE INTERPEXTRAPVAR' + ! + IF(Extrapolation) DEALLOCATE(G1%tmask,G0%tmask) + DEALLOCATE(G0%e1t,G0%e2t,G1%e1t,G1%e2t) + IF(ASSOCIATED(depth)) DEALLOCATE(depth) + ! + END SUBROUTINE Interp_Extrap_var + ! + ! +END MODULE agrif_interpolation diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_modutil.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_modutil.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d34e5adf6b49ba78a6a228a1fca34109ab704c33 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_modutil.f90 @@ -0,0 +1,472 @@ +! +MODULE agrif_modutil + ! +CONTAINS + ! + !************************************************************************ + ! * + ! MODULE AGRIF_MODUTIL * + ! * + ! module containing subroutine used for : * + ! - unrolling 2D arrays to 1D arrays (required for SCRIP package use) * + ! - convert 1D arrays to 2D arrays (required for SCRIP package use) * + ! - remapping process (use SCRIP remapping matrix) * + ! * + !************************************************************************ + ! + !*********************************************************** + SUBROUTINE ssort (x, nb) + !*********************************************************** + ! + IMPLICIT NONE + + INTEGER :: nb + REAL*8, DIMENSION(:) :: x + REAL*8 :: temp + INTEGER ji,jj,jmax,itemp + ! + jmax=nb-1 + ! + ! + DO ji=1,nb-1 + temp=HUGE(1) + + DO jj=1,jmax + + IF(X(jj).LE.X(jj+1)) THEN + temp=X(jj) + X(jj)=X(jj+1) + X(jj+1)=temp + ENDIF + + ENDDO + + IF(temp.EQ.HUGE(1)) RETURN + jmax=jmax-1 + ENDDO + + RETURN + END SUBROUTINE ssort + ! + !*********************************************************** + ! --- quicksort --- + ! Author: t-nissie + ! License: GPLv3 + ! Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea + !*********************************************************** + RECURSIVE SUBROUTINE quicksort(var, first, last) + IMPLICIT NONE + + REAL*8, DIMENSION(:), INTENT(inout) :: var + INTEGER, INTENT(in) :: first, last + REAL*8 :: x, t + INTEGER :: ji, jj + + x = var( (first+last) / 2 ) + ji = first + jj = last + DO + DO WHILE (var(ji) < x) + ji=ji+1 + END DO + DO WHILE (x < var(jj)) + jj=jj-1 + END DO + IF (ji >= jj) EXIT + t = var(ji); var(ji) = var(jj); var(jj) = t + ji=ji+1 + jj=jj-1 + END DO + IF (first < ji-1) CALL quicksort(var, first, ji-1) + IF (jj+1 < last) CALL quicksort(var, jj+1, last) + END SUBROUTINE quicksort + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE 1Dto2D + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE tab1Dto2D(tab1D,tab2D,nx,ny) + ! + IMPLICIT NONE + ! + REAL*8,DIMENSION(:) :: tab1D + REAL*8,DIMENSION(:,:) :: tab2D + ! + INTEGER :: xpos,ypos + INTEGER :: nx,ny + INTEGER :: i + ! + xpos=0 + ypos=1 + ! + DO i=1,nx*ny + xpos=xpos+1 + IF(xpos.GT.nx) THEN + xpos=1 + ypos=ypos+1 + ENDIF + tab2D(ypos,xpos)=tab1D(i) + END DO + ! + END SUBROUTINE tab1Dto2D + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE tab2Dto1D + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE tab2Dto1D(tab2D,tab1D) + ! + IMPLICIT NONE + ! + REAL*8,DIMENSION(:,:) :: tab2D + REAL*8,DIMENSION(:) :: tab1D + ! + INTEGER :: xpos,ypos + INTEGER :: nx,ny + INTEGER :: i + ! + nx = SIZE(tab2D,2) + ny = SIZE(tab2D,1) + ! + xpos = 0 + ypos = 1 + DO i = 1,nx*ny + xpos = xpos + 1 + IF(xpos.GT.nx) THEN + xpos = 1 + ypos = ypos + 1 + END IF + tab1D(i) = tab2D(ypos,xpos) + END DO + ! + END SUBROUTINE tab2Dto1D + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE tab2Dto1D logical + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE logtab2Dto1D(tab2D,tab1D) + ! + IMPLICIT NONE + ! + LOGICAL,DIMENSION(:,:) :: tab2D + LOGICAL,DIMENSION(:) :: tab1D + ! + INTEGER :: xpos,ypos + INTEGER :: nx,ny + INTEGER :: i + ! + nx = SIZE(tab2D,2) + ny = SIZE(tab2D,1) + ! + xpos = 0 + ypos = 1 + DO i = 1,nx*ny + xpos = xpos + 1 + IF(xpos.GT.nx) THEN + xpos = 1 + ypos = ypos + 1 + END IF + tab1D(i) = tab2D(ypos,xpos) + END DO + ! + END SUBROUTINE logtab2Dto1D + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE 1Dto2D + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE logtab1Dto2D(tab1D,tab2D,nx,ny) + ! + IMPLICIT NONE + ! + LOGICAL,DIMENSION(:) :: tab1D + LOGICAL,DIMENSION(:,:) :: tab2D + ! + INTEGER :: xpos,ypos + INTEGER :: nx,ny + INTEGER :: i + ! + xpos=0 + ypos=1 + ! + DO i=1,nx*ny + xpos=xpos+1 + IF(xpos.GT.nx) THEN + xpos=1 + ypos=ypos+1 + ENDIF + tab2D(ypos,xpos)=tab1D(i) + END DO + ! + END SUBROUTINE logtab1Dto2D + + !************************************************************** + ! subroutine make_remap + !************************************************************** + ! + SUBROUTINE make_remap(tabin,tabout,nxfin,nyfin,matrix,src_add,dst_add) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: tabin + REAL*8, DIMENSION(:,:) :: tabout + REAL*8, POINTER, DIMENSION(:,:) :: tabtemp + INTEGER,DIMENSION(:) :: src_add,dst_add + INTEGER :: nxfin,nyfin + REAL*8, POINTER, DIMENSION(:) :: var1D,var_interp1D + REAL*8,DIMENSION(:,:) :: matrix + INTEGER :: num_links,i + ! + ALLOCATE(var1D(SIZE(tabin,1)*SIZE(tabin,2))) + CALL tab2Dto1D(tabin,var1D) + ! + ALLOCATE(var_interp1D(nxfin*nyfin)) + var_interp1D = 0.0 + num_links = SIZE(dst_add) + ! + DO i = 1,num_links + var_interp1D(dst_add(i)) = var_interp1D(dst_add(i)) & + + matrix(1,i)*var1D(src_add(i)) + END DO + ! + ALLOCATE(tabtemp(SIZE(tabout,1),SIZE(tabout,2))) + ! + CALL tab1Dto2D(var_interp1D,tabtemp,nyfin,nxfin) + ! + tabout = tabtemp + ! + DEALLOCATE(var_interp1D,var1D,tabtemp) + ! + END SUBROUTINE make_remap + ! + ! + !************************************************************** + ! end subroutine make_remap + !************************************************************** + ! + ! + !************************************************************** + ! subroutine make_bicubic_remap + !************************************************************** + ! + SUBROUTINE make_bicubic_remap(tabin,masksrc,tabout,nxfin,nyfin,matrix,src_add,dst_add) + ! + IMPLICIT NONE + ! + REAL*8, DIMENSION(:,:) :: tabin + LOGICAL, DIMENSION(:,:) :: masksrc + LOGICAL, POINTER, DIMENSION(:) :: grid1_mask + REAL*8, DIMENSION(:,:) :: tabout + INTEGER,DIMENSION(:) :: src_add,dst_add + INTEGER :: nxfin,nyfin + REAL*8, POINTER, DIMENSION(:) :: var1D,var_interp1D,gradi,gradj,gradij,deriv1,deriv2 + REAL*8,DIMENSION(:,:) :: matrix + INTEGER :: num_links,i,j,nx,ny,n,ip1,im1,jp1,jm1 + INTEGER :: in,is,ie,iw,ine,inw,ise,isw + REAL*8 :: delew,delns + ! + nx = SIZE(tabin,1) + ny = SIZE(tabin,2) + ALLOCATE(gradi(nx*ny),gradj(nx*ny),gradij(nx*ny),deriv1(nx*ny),deriv2(nx*ny)) + ALLOCATE(var1D(nx*ny),grid1_mask(nx*ny)) + ! + CALL tab2Dto1D(tabin,var1D) + CALL logtab2Dto1D(masksrc,grid1_mask) + ! + gradi = 0.0 + gradj = 0.0 + gradij = 0.0 + ! + DO n = 1,nx*ny + + IF( grid1_mask(n) ) THEN + ! + delew = 0.5 + delns = 0.5 + + j = (n-1)/ny + 1 + i = n - (j-1)*ny + ! + ip1 = i+1 + im1 = i-1 + jp1 = j+1 + jm1 = j-1 + ! + IF (ip1 > ny) ip1 = ip1 - ny + + IF (im1 < 1 ) im1 = ny + + IF (jp1 > nx) THEN + jp1 = j + delns = 1. + ENDIF + + IF (jm1 < 1 ) THEN + jm1 = j + delns = 1. + ENDIF + ! + in = (jp1-1)*ny + i + is = (jm1-1)*ny + i + ie = (j -1)*ny + ip1 + iw = (j -1)*ny + im1 + ! + ine = (jp1-1)*ny + ip1 + inw = (jp1-1)*ny + im1 + ise = (jm1-1)*ny + ip1 + isw = (jm1-1)*ny + im1 + ! + !*** compute i-gradient + + IF (.NOT. grid1_mask(ie)) THEN + ie = n + delew = 1. + ENDIF + ! + IF (.NOT. grid1_mask(iw)) THEN + iw = n + delew = 1. + ENDIF + ! + gradi(n) = delew*(var1D(ie) - var1D(iw)) + ! + !*** compute j-gradient + + IF (.NOT. grid1_mask(in)) THEN + in = n + delns = 1. + ENDIF + ! + IF (.NOT. grid1_mask(is)) THEN + is = n + delns = 1. + ENDIF + ! + gradj(n) = delns*(var1D(in) - var1D(is)) + ! + !*** compute ij-gradient + + delew = 0.5 + + IF (jp1 == j .OR. jm1 == j) THEN + delns = 1. + ELSE + delns = 0.5 + ENDIF + ! + IF (.NOT. grid1_mask(ine)) THEN + IF (in /= n) THEN + ine = in + delew = 1. + ELSE IF (ie /= n) THEN + ine = ie + inw = iw + IF (inw == n) delew = 1. + delns = 1. + ELSE + ine = n + inw = iw + delew = 1 + delns = 1 + ENDIF + ENDIF + ! + IF (.NOT. grid1_mask(inw)) THEN + IF (in /= n) THEN + inw = in + delew = 1. + ELSE IF (iw /= n) THEN + inw = iw + ine = ie + IF (ie == n) delew = 1. + delns = 1. + ELSE + inw = n + ine = ie + delew = 1. + delns = 1. + ENDIF + ENDIF + ! + deriv1(n) = delew*(var1D(ine)-var1D(inw)) + ! + IF (.NOT. grid1_mask(ise)) THEN + IF (is /= n) THEN + ise = is + delew = 1. + ELSE IF (ie /= n) THEN + ise = ie + isw = iw + IF (isw == n) delew = 1. + delns = 1. + ELSE + ise = n + isw = iw + delew = 1. + delns = 1. + ENDIF + ENDIF + ! + IF (.NOT. grid1_mask(isw)) THEN + IF (is /= n) THEN + isw = is + delew = 1. + ELSE IF (iw /= n) THEN + isw = iw + ise = ie + IF (ie == n) delew = 1. + delns = 1. + ELSE + isw = n + ise = ie + delew = 1. + delns = 1. + ENDIF + ENDIF + + deriv2(n) = delew*(var1D(ise) - var1D(isw)) + gradij(n) = delns*(deriv1(n) - deriv2(n)) + ENDIF + END DO + ! + DEALLOCATE(deriv1,deriv2,grid1_mask) + + ! + ALLOCATE(var_interp1D(nxfin*nyfin)) + var_interp1D = 0.0 + num_links = SIZE(dst_add) + ! + DO i = 1,num_links + ! + var_interp1D(dst_add(i)) = var_interp1D(dst_add(i)) + & + matrix(1,i)*var1D(src_add(i)) + & + matrix(2,i)*gradi(src_add(i)) + & + matrix(3,i)*gradj(src_add(i)) + & + matrix(4,i)*gradij(src_add(i)) + END DO + ! + DEALLOCATE(gradi,gradj,gradij,var1D) + ! + CALL tab1Dto2D(var_interp1D,tabout,nyfin,nxfin) + ! + DEALLOCATE(var_interp1D) + ! + END SUBROUTINE make_bicubic_remap + ! + ! + !************************************************************** + ! end subroutine make_bicubic_remap + !************************************************************** + ! + ! +END MODULE agrif_modutil diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_partial_steps.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_partial_steps.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f55b812907042891915753268eb3465731f7dd95 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_partial_steps.f90 @@ -0,0 +1,934 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! Laurent Debreu (Laurent.Debreu@imag.fr) * +!************************************************************************ +! +MODULE agrif_partial_steps + ! + USE agrif_types +CONTAINS + + + + + + ! + !************************************************************************ + ! * + ! MODULE AGRIF_PARTIAL_STEPS * + ! * + !************************************************************************ + + + !************************************************************************ + ! * + ! Subroutine get_partial_steps * + ! * + ! subroutine to compute gdepw_ps on the input grid (based on NEMO code) * + ! * + !************************************************************************ + ! + SUBROUTINE get_partial_steps(Grid) + ! + IMPLICIT NONE + ! + TYPE(Coordinates) :: Grid + REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp + INTEGER :: i,j,jk,jj,ji,jpj,jpi,ik,ii,ipt,jpt + INTEGER, DIMENSION(1) :: k + INTEGER :: k1 + REAL*8, POINTER, DIMENSION(:) :: gdepw,gdept,e3w,e3t + REAL*8, POINTER, DIMENSION(:,:) :: hdepw,e3tp,e3wp + REAL*8, POINTER, DIMENSION(:,:,:) :: gdept_ps,gdepw_ps + REAL*8 e3t_ps + + ! + WRITE(*,*) 'convert bathymetry from etopo for partial step z-coordinate case' + WRITE(*,*) 'minimum thickness of partial step e3zps_min = ', e3zps_min, ' (m)' + WRITE(*,*) ' step level e3zps_rat = ', e3zps_rat + ! + jpi = SIZE(Grid%bathy_meter,1) + jpj = SIZE(Grid%bathy_meter,2) + ! + ALLOCATE(gdepw(N),gdept(N),e3w(N),e3t(N)) + ALLOCATE(gdepw_ps(jpi,jpj,N)) + IF (.NOT.ASSOCIATED(Grid%bathy_level)) ALLOCATE(Grid%bathy_level(jpi,jpj)) + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 computed' + za1=( ppdzmin - pphmax / (N-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & + * ( LOG( COSH( (N - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 given by namelist' + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(N-1) + DO i = 1, N + gdepw(i) = ( i - 1 ) * za1 + gdept(i) = ( i - 0.5 ) * za1 + e3w (i) = za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,N + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + gdept(i) = (zsur+za0*(i+0.5)+za1*zacr*LOG(COSH(((i+0.5)-zkth)/zacr))) + e3w(i) = (za0 + za1 * TANH((i-zkth)/zacr)) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,N + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + gdept(i) = ( zsur + za0*(i+0.5) + za1 * zacr * LOG ( COSH( ((i+0.5)-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( ((i+0.5)-zkth2) / zacr2 ) ) ) + e3w (i) = za0 + za1 * TANH( (i-zkth ) / zacr ) & + & + za2 * TANH( (i-zkth2) / zacr2 ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + gdepw(1) = 0.0 + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, N-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(N) = e3t(N-1) + + DO i = 2, N + e3w(i) = gdept(i) - gdept(i-1) + END DO + e3w(1 ) = 2. * (gdept(1) - gdepw(1)) + END IF + ! + ! Initialization of constant + ! + zmax = gdepw(N) + e3t(N) + IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level + ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zmin = gdepw(i+1) + ! + ! Initialize bathy_level to the maximum ocean level available + ! + Grid%bathy_level = N-1 + ! + ! storage of land and island's number (zera and negative values) in mbathy + ! + DO jj = 1, jpj + DO ji= 1, jpi + IF( Grid%bathy_meter(ji,jj) <= 0. ) & + Grid%bathy_level(ji,jj) = INT( Grid%bathy_meter(ji,jj) ) + END DO + END DO + ! + ! the last ocean level thickness cannot exceed e3t(jpkm1)+e3t(jpk) + ! + DO jj = 1, jpj + DO ji= 1, jpi + IF( Grid%bathy_meter(ji,jj) <= 0. ) THEN + Grid%bathy_meter(ji,jj) = 0.e0 + ELSE + Grid%bathy_meter(ji,jj) = MAX( Grid%bathy_meter(ji,jj), zmin ) + Grid%bathy_meter(ji,jj) = MIN( Grid%bathy_meter(ji,jj), zmax ) + ENDIF + END DO + END DO + ! +!!$ IF( partial_steps ) THEN + ! Compute bathy_level for ocean points (i.e. the number of ocean levels) + ! find the number of ocean levels such that the last level thickness + ! is larger than the minimum of e3zps_min and e3zps_rat * e3t (where + ! e3t is the reference level thickness + DO jk = N-1, 1, -1 + zdepth = gdepw(jk) + MIN( e3zps_min, e3t(jk)*e3zps_rat ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( 0. < Grid%bathy_meter(ji,jj) .AND. Grid%bathy_meter(ji,jj) <= zdepth ) & + Grid%bathy_level(ji,jj) = jk-1 + END DO + END DO + END DO +!!$ ELSE +!!$ DO jj = 1,jpj +!!$ DO ji = 1,jpi +!!$ ! +!!$ IF (Grid%bathy_meter(ji,jj) .EQ. 0.0 ) THEN +!!$ Grid%bathy_level(ji,jj)=0 +!!$ ELSE +!!$ ! +!!$ k1=2 ! clem: minimum levels = 2 ??? +!!$ DO WHILE (k1 .LT. (N-1)) +!!$ IF ((Grid%bathy_meter(ji,jj).GE.gdepw(k1)) & +!!$ .AND.(Grid%bathy_meter(ji,jj).LE.gdepw(k1+1))) EXIT +!!$ k1=k1+1 +!!$ END DO +!!$ Grid%bathy_level(ji,jj)=k1 +!!$ ! +!!$ ENDIF +!!$ ! +!!$ END DO +!!$ END DO +!!$ +!!$ ENDIF + + CALL bathymetry_control(grid%bathy_level) + ! + ! initialization to the reference z-coordinate + ! + WRITE(*,*) ' initialization to the reference z-coordinate ' + ! + DO jk = 1, N + ! Write(*,*) 'k = ',jk + gdepw_ps(1:jpi,1:jpj,jk) = gdepw(jk) + END DO + ! + Grid%gdepw_ps(:,:) = gdepw_ps(:,:,3) + ! + DO jj = 1, jpj + DO ji = 1, jpi + ik = Grid%bathy_level(ji,jj) + ! ocean point only + IF( ik > 0 ) THEN + ! max ocean level case + IF( ik == N-1 ) THEN + zdepwp = Grid%bathy_meter(ji,jj) + ze3tp = Grid%bathy_meter(ji,jj) - gdepw(ik) + ze3wp = 0.5 * e3w(ik) * ( 1. + ( ze3tp/e3t(ik) ) ) + gdepw_ps(ji,jj,ik+1) = zdepwp + ! standard case + ELSE + ! + IF( Grid%bathy_meter(ji,jj) <= gdepw(ik+1) ) THEN + gdepw_ps(ji,jj,ik+1) = Grid%bathy_meter(ji,jj) + ELSE + ! + gdepw_ps(ji,jj,ik+1) = gdepw(ik+1) + ENDIF + ! + ENDIF + ! + ENDIF + END DO + END DO + ! + DO jj = 1, jpj + DO ji = 1, jpi + ik = Grid%bathy_level(ji,jj) + ! ocean point only + IF( ik > 0 ) THEN + ! bathymetry output + ! + Grid%gdepw_ps(ji,jj) = gdepw_ps(ji,jj,ik+1) + ! + !AJOUT----------------------------------------------------------------------- + ! + ELSE + ! + Grid%gdepw_ps(ji,jj) = 0 + ! + !AJOUT------------------------------------------------------------------------ + ! + ENDIF + ! + END DO + END DO + ! + ! + DEALLOCATE(gdepw,gdept,e3w,e3t) + DEALLOCATE(gdepw_ps) + END SUBROUTINE get_partial_steps + ! + ! + !************************************************************************* + ! * + ! Subroutine check interp * + ! * + ! subroutine to compute gdepw_ps on the input grid (based on NEMO code) * + ! * + !************************************************************************ + ! + ! + SUBROUTINE check_interp( ParentGrid , gdepwChild ) + ! + IMPLICIT NONE + ! + TYPE(Coordinates) :: ParentGrid + REAL*8,DIMENSION(:,:) :: gdepwChild + INTEGER :: i,j,ji,ij,ii,jj,jpt,ipt + REAL,DIMENSION(N) :: gdepw,e3t + REAL :: za0,za1,za2,zsur,zacr,zacr2,zkth,zkth2,zmin,zmax,zdepth + INTEGER :: kbathy,jk + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 computed' + za1=( ppdzmin - pphmax / (N-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(N-1) & + * ( LOG( COSH( (N - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 given by namelist' + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(N-1) + DO i = 1, N + gdepw(i) = ( i - 1 ) * za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,N + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,N + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + gdepw(1) = 0.0 + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, N-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(N) = e3t(N-1) + END IF + ! + ! + ! west boundary + IF( ln_agrif_domain ) THEN + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,2+nbghostcellsfine+(npt_copy+npt_connect)*irafx-1,1,nyfin) + ELSE + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,(npt_copy+npt_connect)*irafx,1,nyfin) + ENDIF + ! + ! east boundary + IF( ln_agrif_domain ) THEN + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,nxfin-1-nbghostcellsfine-((npt_copy+npt_connect)*irafx-1),nxfin,1,nyfin) + ELSE + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,nxfin-((npt_copy+npt_connect)*irafx+1),nxfin,1,nyfin) + ENDIF + ! + ! north boundary + IF( ln_agrif_domain ) THEN + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,nxfin,nyfin-1-nbghostcellsfine-((npt_copy+npt_connect)*irafy-1),nyfin) + ELSE + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,nxfin,nyfin-((npt_copy+npt_connect)*irafy+1),nyfin) + ENDIF + ! + ! south boundary + IF( ln_agrif_domain ) THEN + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,nxfin,1,2+nbghostcellsfine+(npt_copy+npt_connect)*irafy-1) + ELSE + CALL correct_level( gdepwchild,ParentGrid,gdepw,e3t,1,nxfin,1,(npt_copy+npt_connect)*irafy) + ENDIF + ! + ! + ! + END SUBROUTINE check_interp + ! + SUBROUTINE correct_level( gdepwchild,ParentGrid,gdepw,e3t,minboundx,maxboundx,minboundy,maxboundy ) + ! + IMPLICIT NONE + TYPE(Coordinates) :: ParentGrid + REAL*8,DIMENSION(:,:) :: gdepwChild + REAL*8,DIMENSION(N) :: gdepw,e3t + INTEGER :: minboundx,maxboundx,minboundy,maxboundy + INTEGER :: kbathy,jk,indx,indy,diff + REAL :: xdiff + INTEGER :: i,j,ji,ij,ii,jj,jpt,ipt,i1,i2,j1,j2,ii1,ii2,jj1,jj2 + REAL*8 :: slopex, slopey,val,tmp1,tmp2,tmp3,tmp4 + INTEGER :: parentbathy + REAL :: mindepth, maxdepth + REAL :: xmin,ymin,dxfin,dyfin,dsparent + INTEGER ipbegin,ipend,jpbegin,jpend + INTEGER ibegin,iend,jbegin,jend + REAL x,y,zmin,zmax + INTEGER ptx,pty + REAL,DIMENSION(:,:),ALLOCATABLE :: gdepwtemp + INTEGER,DIMENSION(:,:),ALLOCATABLE :: parentbathytab + ! + ! + ! Initialization of constant + ! + zmax = gdepw(N) + e3t(N) + IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level + ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zmin = gdepw(i+1) + ! + ! check that interpolated value stays at the same level + ! + ! + diff = 0 + IF ( MOD(irafx,2) .EQ. 0 ) diff = 1 + + xdiff = REAL(diff)/2. + + dxfin = 1./irafx + dyfin = 1./irafy + + ptx = 1 + nbghostcellsfine + 1 + pty = 1 + nbghostcellsfine + 1 + + xmin = (imin-1) * 1 + ymin = (jmin-1) * 1 + + + ! compute x and y the locations of the indices minbounx and minboundy + + x = xmin + (minboundx-ptx)*dxfin + dxfin/2. + y = ymin + (minboundy-pty)*dyfin + dyfin/2. + + ! compute the indices of the nearest coarse grid points + ipbegin = ptx + agrif_int((x-0.-1./2.) / 1.) - 1 + jpbegin = pty + agrif_int((y-0.-1./2.) / 1.) - 1 + + ! compute indices of the fine grid points nearest to the preceeding coarse grid points + ! (inferior values) + + x = (ipbegin - ptx) + 1./2. + y = (jpbegin - pty) + 1./2. + + ibegin = ptx + agrif_int((x-xmin-dxfin/2.)/dxfin) + jbegin = pty + agrif_int((y-ymin-dyfin/2.)/dyfin) + + ! compute x and y the locations of the indices maxbounx and maxboundy + x = xmin + (maxboundx-ptx)*dxfin + dxfin/2. + y = ymin + (maxboundy-pty)*dyfin + dyfin/2. + + ! compute the indices of the nearest coarse grid points + ipend = ptx + CEILING((x-0.-1./2) / 1.) + 1 + jpend = pty + CEILING((y-0.-1./2) / 1.) + 1 + + ! compute indices of the fine grid points nearest to the preceeding coarse grid points + ! (inferior values) + + x = (ipend - ptx) + 1./2. + y = (jpend - pty) + 1./2. + iend = ptx + agrif_int((x-xmin-dxfin/2.)/dxfin) + jend = pty + agrif_int((y-ymin-dyfin/2.)/dyfin) + + IF( ln_agrif_domain ) THEN + ALLOCATE(gdepwtemp(ibegin-irafx:iend+irafx,jbegin-irafy:jend+irafy)) + ALLOCATE(parentbathytab(ibegin-irafx:iend+irafx,jbegin-irafy:jend+irafy)) + + i1 = ibegin + i2 = iend + j1 = jbegin + j2 = jend + + ii1 = -FLOOR(irafx/2.0)+diff + ii2 = FLOOR(irafx/2.0) + jj1 = -FLOOR(irafy/2.0)+diff + jj2 = FLOOR(irafy/2.0) + ELSE + ibegin = minboundx + jbegin = minboundy + iend = maxboundx ! (npt_copy+npt_connect)*irafx + jend = maxboundy ! (npt_copy+npt_connect)*irafy + ! + ipbegin = imin + (ibegin-1)/irafx + jpbegin = jmin + (jbegin-1)/irafy + ipend = ipbegin + (npt_copy+npt_connect) - 1 + jpend = jpbegin + (npt_copy+npt_connect) - 1 + ! + i1 = ibegin + i2 = iend + j1 = jbegin + j2 = jend + + ii1 = 0 + ii2 = irafx - 1 + jj1 = 0 + jj2 = irafy - 1 + ! + ALLOCATE(gdepwtemp(ibegin:iend,jbegin:jend)) + ALLOCATE(parentbathytab(ibegin:iend,jbegin:jend)) + + ENDIF + + + jpt=jpbegin + DO j=jbegin,jend,irafy + + ipt=ipbegin + + + DO i=i1,i2,irafx + + + ! + parentbathy = ParentGrid%bathy_level(ipt,jpt) + IF (parentbathy == 0) THEN + mindepth = 0. + maxdepth = 0. + ELSE + mindepth = MAX(gdepw(parentbathy) + MIN( e3zps_min, e3t(parentbathy)*e3zps_rat ),zmin) + ! maxdepth = min(gdepw(parentbathy + 1),zmax) + IF (parentbathy < (N-1)) THEN + maxdepth = gdepw(parentbathy + 1) + ELSE + maxdepth = HUGE(1.) + ENDIF + ENDIF + + slopex = vanleer(parentgrid%gdepw_ps(ipt-1:ipt+1,jpt))/REAL(irafx) + + + tmp1 = (maxdepth - parentgrid%gdepw_ps(ipt,jpt)) / REAL(irafx) + tmp2 = (parentgrid%gdepw_ps(ipt,jpt) - mindepth) / REAL(irafx) + + IF (ABS(slopex) > tmp1) THEN + IF (slopex > 0) THEN + slopex = tmp1 + ELSE + slopex = -tmp1 + ENDIF + ENDIF + + IF (ABS(slopex) > tmp2) THEN + IF (slopex > 0) THEN + slopex = tmp2 + ELSE + slopex = -tmp2 + ENDIF + ENDIF + ! + ! interpolation on fine grid points (connection zone) + ! + DO ii = i+ii1,i+ii2 +!! x = ii-i - xdiff/2. +!! val = parentgrid%gdepw_ps(ipt,jpt)+slopex * x +!! chanut: uncomment this to get nearest neighbor interpolation + val = parentgrid%gdepw_ps(ipt,jpt) + gdepwtemp(ii,j) = val + IF (gdepwtemp(ii,j) < mindepth) THEN + gdepwtemp(ii,j) = mindepth + ENDIF + IF (gdepwtemp(ii,j) > maxdepth) THEN + gdepwtemp(ii,j) = maxdepth + ENDIF + parentbathytab(ii,j) = parentbathy + ENDDO + ipt =ipt + 1 + ENDDO + + jpt = jpt + 1 + ENDDO + + DO j=jbegin+irafy,jend-irafy,irafy + + DO i=ibegin,iend + + parentbathy = parentbathytab(i,j) + IF (parentbathy == 0) THEN + mindepth = 0. + maxdepth = 0. + ELSE + mindepth = MAX(gdepw(parentbathy) + MIN( e3zps_min, e3t(parentbathy)*e3zps_rat ),zmin) + ! maxdepth = min(gdepw(parentbathy + 1),zmax) + IF (parentbathy < (N-1)) THEN + maxdepth = gdepw(parentbathy + 1) + ELSE + maxdepth = HUGE(1.) + ENDIF + ENDIF + + slopey = vanleer(gdepwtemp(i,j-irafy:j+irafy:irafy))/REAL(irafy) + + tmp1 = (maxdepth - gdepwtemp(i,j)) / REAL(irafy) + tmp2 = (gdepwtemp(i,j) - mindepth) / REAL(irafy) + + IF (ABS(slopey) > tmp1) THEN + IF (slopey > 0) THEN + slopey = tmp1 + ELSE + slopey = -tmp1 + ENDIF + ENDIF + IF (ABS(slopey) > tmp2) THEN + IF (slopey > 0) THEN + slopey = tmp2 + ELSE + slopey = -tmp2 + ENDIF + ENDIF + + + DO jj = j+jj1,j+jj2 +!! y = jj-j - xdiff/2. +!! val = gdepwtemp(i,j) + slopey*y +!! chanut: uncomment this to get nearest neighbor interpolation + val = gdepwtemp(i,j) + gdepwtemp(i,jj) = val + ENDDO + ENDDO + ENDDO + + + gdepwchild(minboundx:maxboundx,minboundy:maxboundy) = gdepwtemp(minboundx:maxboundx,minboundy:maxboundy) + DEALLOCATE(gdepwtemp,parentbathytab) + + END SUBROUTINE correct_level + ! + ! + !*************************************************** + ! function van leer to compute the corresponding + ! Van Leer slopes + !*************************************************** + ! + REAL FUNCTION vanleer(tab) + REAL, DIMENSION(3) :: tab + REAL res,res1 + REAL p1,p2,p3 + + p1=(tab(3)-tab(1))/2. + p2=(tab(2)-tab(1)) + p3=(tab(3)-tab(2)) + + IF ((p1>0.).AND.(p2>0.).AND.(p3>0)) THEN + res1=MINVAL((/p1,p2,p3/)) + ELSEIF ((p1<0.).AND.(p2<0.).AND.(p3<0)) THEN + res1=MAXVAL((/p1,p2,p3/)) + ELSE + res1=0. + ENDIF + + vanleer = res1 + + + END FUNCTION vanleer + ! + ! + !******************************************************************************** + ! subroutine bathymetry_control * + ! * + ! - Purpose : check the bathymetry in levels * + ! * + ! - Method : The array mbathy is checked to verified its consistency * + ! with the model options. in particular: * + ! mbathy must have at least 1 land grid-points (mbathy<=0) * + ! along closed boundary. * + ! mbathy must be cyclic IF jperio=1. * + ! mbathy must be lower or equal to jpk-1. * + ! isolated ocean grid points are suppressed from mbathy * + ! since they are only connected to remaining * + ! ocean through vertical diffusion. * + ! * + ! * + !******************************************************************************** + + SUBROUTINE bathymetry_control(mbathy) + + INTEGER :: ji, jj, jl + INTEGER :: icompt, ibtest, ikmax + REAL*8, DIMENSION(:,:) :: mbathy + + ! ================ + ! Bathymetry check + ! ================ + + ! Suppress isolated ocean grid points + + WRITE(*,*)' suppress isolated ocean grid points' + WRITE(*,*)' -----------------------------------' + + icompt = 0 + + DO jl = 1, 2 + ! + DO jj = 2, SIZE(mbathy,2)-1 + DO ji = 2, SIZE(mbathy,1)-1 + + ibtest = MAX( mbathy(ji-1,jj), mbathy(ji+1,jj),mbathy(ji,jj-1),mbathy(ji,jj+1) ) + ! + IF( ibtest < mbathy(ji,jj) ) THEN + ! + WRITE(*,*) 'grid-point(i,j)= ',ji,jj,'is changed from',mbathy(ji,jj),' to ', ibtest + mbathy(ji,jj) = ibtest + icompt = icompt + 1 + ! + ENDIF + ! + END DO + END DO + ! + END DO + ! + IF( icompt == 0 ) THEN + WRITE(*,*)' no isolated ocean grid points' + ELSE + WRITE(*,*)' ',icompt,' ocean grid points suppressed' + ENDIF + ! + + ! Number of ocean level inferior or equal to jpkm1 + + ikmax = 0 + DO jj = 1, SIZE(mbathy,2) + DO ji = 1, SIZE(mbathy,1) + ikmax = MAX( ikmax, NINT(mbathy(ji,jj)) ) + END DO + END DO + ! + IF( ikmax > N-1 ) THEN + WRITE(*,*) ' maximum number of ocean level = ', ikmax,' > jpk-1' + WRITE(*,*) ' change jpk to ',ikmax+1,' to use the exact ead bathymetry' + ELSE IF( ikmax < N-1 ) THEN + WRITE(*,*) ' maximum number of ocean level = ', ikmax,' < jpk-1' + WRITE(*,*) ' you can decrease jpk to ', ikmax+1 + ENDIF + + END SUBROUTINE bathymetry_control + ! + ! + !********************************************************************************** + ! + !subroutine get_scale_factors + ! + !********************************************************************************** + ! + SUBROUTINE get_scale_factors(Grid,fse3t,fse3u,fse3v) + ! + IMPLICIT NONE + ! + TYPE(Coordinates) :: Grid + REAL*8, DIMENSION(:,:,:) :: fse3u,fse3t,fse3v + ! + REAL*8 :: za2,za1,za0,zsur,zacr,zkth,zacr2,zkth2,zdepth,zdepwp,zmin,zmax,zdiff,ze3tp,ze3wp + INTEGER :: i,j,jk,jj,ji,jpj,jpi,ik,ii,ipt,jpt,jpk + INTEGER, DIMENSION(1) :: k + INTEGER :: k1 + REAL*8, POINTER, DIMENSION(:) :: gdepw,gdept,e3w,e3t + REAL*8, POINTER, DIMENSION(:,:) :: hdepw,e3tp,e3wp + REAL*8, POINTER, DIMENSION(:,:,:) :: gdept_ps,gdepw_ps + ! + jpi = SIZE(fse3t,1) + jpj = SIZE(fse3t,2) + jpk = SIZE(fse3t,3) + ! + ALLOCATE(gdepw(jpk),e3t(jpk)) + ALLOCATE(gdepw_ps(jpi,jpj,jpk)) + ! + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 computed' + za1=( ppdzmin - pphmax / (jpk-1) ) & + / ( TANH((1-ppkth)/ppacr) - ppacr/(jpk-1) & + * ( LOG( COSH( (jpk - ppkth) / ppacr) ) & + - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ! + ELSE IF ( (ppdzmin == 0 .OR. pphmax == 0) .AND. psur.NE.0 .AND. & + pa0.NE.0 .AND. pa1.NE.0 ) THEN + ! + WRITE(*,*) 'psur,pa0,pa1 given by namelist' + zsur = psur + za0 = pa0 + za1 = pa1 + za2 = pa2 + ! + ELSE + ! + WRITE(*,*) 'ERROR ***** bad vertical grid parameters ...' + WRITE(*,*) ' ' + WRITE(*,*) 'please check values of variables' + WRITE(*,*) 'in namelist vertical_grid section' + WRITE(*,*) ' ' + STOP + ! + ENDIF + + zacr = ppacr + zkth = ppkth + zacr2 = ppacr2 + zkth2 = ppkth2 + ! + IF( ppkth == 0. ) THEN ! uniform vertical grid + za1 = pphmax / FLOAT(jpk-1) + DO i = 1, jpk + gdepw(i) = ( i - 1 ) * za1 + e3t (i) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO i = 1,jpk + ! + gdepw(i) = (zsur+za0*i+za1*zacr*LOG(COSH((i-zkth)/zacr))) + e3t(i) = (za0 + za1 * TANH(((i+0.5)-zkth)/zacr)) + ! + END DO + ELSE + DO i = 1,jpk + ! Double tanh function + gdepw(i) = ( zsur + za0*i + za1 * zacr * LOG ( COSH( (i-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (i-zkth2) / zacr2 ) ) ) + e3t (i) = za0 + za1 * TANH( ((i+0.5)-zkth ) / zacr ) & + & + za2 * TANH( ((i+0.5)-zkth2) / zacr2 ) + END DO + ENDIF + ENDIF + ! + gdepw(1)=0. + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + DO i = 1, jpk-1 + e3t(i) = gdepw(i+1)-gdepw(i) + END DO + e3t(jpk) = e3t(jpk-1) + END IF + ! + DO i = 1,jpk + ! + fse3t(:,:,i) = e3t(i) + gdepw_ps(:,:,i) = gdepw(i) + ! + END DO + ! + gdepw(1) = 0.0 + gdepw_ps(:,:,1) = 0.0 + ! + zmax = gdepw(jpk) + e3t(jpk) + IF( rn_hmin < 0. ) THEN ; i = - INT( rn_hmin ) ! from a nb of level + ELSE ; i = MINLOC( gdepw, mask = gdepw > rn_hmin, dim = 1 ) ! from a depth + ENDIF + zmin = gdepw(i+1) + ! + DO jj = 1, jpj + DO ji= 1, jpi + IF( Grid%bathy_meter(ji,jj) <= 0. ) THEN + Grid%bathy_meter(ji,jj) = 0.e0 + ELSE + Grid%bathy_meter(ji,jj) = MAX( Grid%bathy_meter(ji,jj), zmin ) + Grid%bathy_meter(ji,jj) = MIN( Grid%bathy_meter(ji,jj), zmax ) + ENDIF + END DO + END DO + ! + DO jj = 1, jpj + DO ji = 1, jpi + ik = Grid%bathy_level(ji,jj) + IF( ik > 0 ) THEN + ! max ocean level case + IF( ik == jpk-1 ) THEN + zdepwp = Grid%bathy_meter(ji,jj) + ze3tp = Grid%bathy_meter(ji,jj) - gdepw(ik) + fse3t(ji,jj,ik ) = ze3tp + fse3t(ji,jj,ik+1) = ze3tp + gdepw_ps(ji,jj,ik+1) = zdepwp + ELSE + IF( Grid%bathy_meter(ji,jj) <= gdepw(ik+1) ) THEN + gdepw_ps(ji,jj,ik+1) = Grid%bathy_meter(ji,jj) + ELSE + gdepw_ps(ji,jj,ik+1) = gdepw(ik+1) + ENDIF + fse3t(ji,jj,ik) = e3t(ik) * ( gdepw_ps(ji,jj,ik+1) - gdepw(ik)) & + /( gdepw(ik+1) - gdepw(ik)) + fse3t(ji,jj,ik+1) = fse3t(ji,jj,ik) + + ENDIF + ENDIF + END DO + END DO + ! + DO i = 1, jpk + fse3u (:,:,i) = e3t(i) + fse3v (:,:,i) = e3t(i) + END DO + ! + DO jk = 1,jpk + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + fse3u (ji,jj,jk) = MIN( fse3t(ji,jj,jk), fse3t(ji+1,jj,jk)) + fse3v (ji,jj,jk) = MIN( fse3t(ji,jj,jk), fse3t(ji,jj+1,jk)) + ENDDO + ENDDO + ENDDO + ! + DEALLOCATE(gdepw,e3t) + DEALLOCATE(gdepw_ps) + DEALLOCATE(Grid%bathy_meter,Grid%bathy_level) + ! + END SUBROUTINE get_scale_factors + ! +END MODULE agrif_partial_steps + + diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_readwrite.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_readwrite.f90 new file mode 100644 index 0000000000000000000000000000000000000000..87e50abdd926ee0a4bdfc79b725645f22b07dfb5 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_readwrite.f90 @@ -0,0 +1,1396 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +MODULE agrif_readwrite + ! + USE agrif_types + ! + IMPLICIT NONE + ! +CONTAINS + ! + !************************************************************************ + ! * + ! MODULE AGRIF_READWRITE * + ! * + ! module containing subroutine used for : * + ! - Coordinates files reading/writing * + ! - Bathymetry files reading/writing (meter and levels) * + ! - Naming of child grid files * + ! * + !************************************************************************ + ! + !***************************************************** + ! function Read_Coordinates(name,Grid) + !***************************************************** + + INTEGER FUNCTION Read_Coordinates(name,Grid,Pacifique) + ! + USE io_netcdf + ! + ! file name to open + ! + CHARACTER(*) name + LOGICAL,OPTIONAL :: Pacifique + ! + TYPE(Coordinates) :: Grid + ! + CALL read_ncdf_var('glamt',name,Grid%glamt) + CALL read_ncdf_var('glamu',name,Grid%glamu) + CALL read_ncdf_var('glamv',name,Grid%glamv) + CALL read_ncdf_var('glamf',name,Grid%glamf) + CALL read_ncdf_var('gphit',name,Grid%gphit) + CALL read_ncdf_var('gphiu',name,Grid%gphiu) + CALL read_ncdf_var('gphiv',name,Grid%gphiv) + CALL read_ncdf_var('gphif',name,Grid%gphif) + CALL read_ncdf_var('e1t',name,Grid%e1t) + CALL read_ncdf_var('e1u',name,Grid%e1u) + CALL read_ncdf_var('e1v',name,Grid%e1v) + CALL read_ncdf_var('e1f',name,Grid%e1f) + CALL read_ncdf_var('e2t',name,Grid%e2t) + CALL read_ncdf_var('e2u',name,Grid%e2u) + CALL read_ncdf_var('e2v',name,Grid%e2v) + CALL read_ncdf_var('e2f',name,Grid%e2f) + CALL read_ncdf_var('nav_lon',name,Grid%nav_lon) + CALL read_ncdf_var('nav_lat',name,Grid%nav_lat) + ! + IF( PRESENT(Pacifique) )THEN + IF ( Grid%glamt(1,1) > Grid%glamt(nxfin,nyfin) ) THEN + Pacifique = .TRUE. + WHERE ( Grid%glamt < 0 ) + Grid%glamt = Grid%glamt + 360. + END WHERE + WHERE ( Grid%glamf < 0 ) + Grid%glamf = Grid%glamf + 360. + END WHERE + WHERE ( Grid%glamu < 0 ) + Grid%glamu = Grid%glamu + 360. + END WHERE + WHERE ( Grid%glamv < 0 ) + Grid%glamv = Grid%glamv + 360. + END WHERE + WHERE ( Grid%nav_lon < 0 ) + Grid%nav_lon = Grid%nav_lon + 360. + END WHERE + ENDIF + ENDIF + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Reading coordinates file: ',name + WRITE(*,*) ' ' + ! + Read_Coordinates = 1 + ! + END FUNCTION Read_Coordinates + + !***************************************************** + ! function Read_Coordinates(name,Grid) + !***************************************************** + + INTEGER FUNCTION Read_Local_Coordinates(name,Grid,strt,cnt) + ! + USE io_netcdf + ! + ! file name to open + ! + CHARACTER(*) name + INTEGER, DIMENSION(2) :: strt,cnt + ! + TYPE(Coordinates) :: Grid + ! + CALL read_ncdf_var('glamt',name,Grid%glamt,strt,cnt) + CALL read_ncdf_var('glamu',name,Grid%glamu,strt,cnt) + CALL read_ncdf_var('glamv',name,Grid%glamv,strt,cnt) + CALL read_ncdf_var('glamf',name,Grid%glamf,strt,cnt) + CALL read_ncdf_var('gphit',name,Grid%gphit,strt,cnt) + CALL read_ncdf_var('gphiu',name,Grid%gphiu,strt,cnt) + CALL read_ncdf_var('gphiv',name,Grid%gphiv,strt,cnt) + CALL read_ncdf_var('gphif',name,Grid%gphif,strt,cnt) + CALL read_ncdf_var('e1t',name,Grid%e1t,strt,cnt) + CALL read_ncdf_var('e1u',name,Grid%e1u,strt,cnt) + CALL read_ncdf_var('e1v',name,Grid%e1v,strt,cnt) + CALL read_ncdf_var('e1f',name,Grid%e1f,strt,cnt) + CALL read_ncdf_var('e2t',name,Grid%e2t,strt,cnt) + CALL read_ncdf_var('e2u',name,Grid%e2u,strt,cnt) + CALL read_ncdf_var('e2v',name,Grid%e2v,strt,cnt) + CALL read_ncdf_var('e2f',name,Grid%e2f,strt,cnt) + CALL read_ncdf_var('nav_lon',name,Grid%nav_lon,strt,cnt) + CALL read_ncdf_var('nav_lat',name,Grid%nav_lat,strt,cnt) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Reading coordinates file: ',name + WRITE(*,*) ' ' + ! + Read_Local_Coordinates = 1 + ! + END FUNCTION Read_Local_Coordinates + + !***************************************************** + ! function Write_Coordinates(name,Grid) + !***************************************************** + + INTEGER FUNCTION Write_Coordinates(name,Grid) + ! + USE io_netcdf + CHARACTER(*) name + TYPE(Coordinates) :: Grid + INTEGER :: status,ncid + CHARACTER(len=1),DIMENSION(2) :: dimnames + ! + status = nf90_create(name,NF90_WRITE,ncid) + status = nf90_close(ncid) + ! + dimnames = (/ 'x','y' /) + CALL write_ncdf_dim(dimnames(1),name,nxfin) + CALL write_ncdf_dim(dimnames(2),name,nyfin) + ! + CALL write_ncdf_var('nav_lon',dimnames,name,Grid%nav_lon,'float') + CALL write_ncdf_var('nav_lat',dimnames,name,Grid%nav_lat,'float') + ! + CALL write_ncdf_var('glamt',dimnames,name,Grid%glamt,'double') + CALL write_ncdf_var('glamu',dimnames,name,Grid%glamu,'double') + CALL write_ncdf_var('glamv',dimnames,name,Grid%glamv,'double') + CALL write_ncdf_var('glamf',dimnames,name,Grid%glamf,'double') + CALL write_ncdf_var('gphit',dimnames,name,Grid%gphit,'double') + CALL write_ncdf_var('gphiu',dimnames,name,Grid%gphiu,'double') + CALL write_ncdf_var('gphiv',dimnames,name,Grid%gphiv,'double') + CALL write_ncdf_var('gphif',dimnames,name,Grid%gphif,'double') + CALL write_ncdf_var('e1t',dimnames,name,Grid%e1t,'double') + CALL write_ncdf_var('e1u',dimnames,name,Grid%e1u,'double') + CALL write_ncdf_var('e1v',dimnames,name,Grid%e1v,'double') + CALL write_ncdf_var('e1f',dimnames,name,Grid%e1f,'double') + CALL write_ncdf_var('e2t',dimnames,name,Grid%e2t,'double') + CALL write_ncdf_var('e2u',dimnames,name,Grid%e2u,'double') + CALL write_ncdf_var('e2v',dimnames,name,Grid%e2v,'double') + CALL write_ncdf_var('e2f',dimnames,name,Grid%e2f,'double') + ! + CALL copy_ncdf_att('nav_lon',TRIM(parent_coordinate_file),name,MINVAL(Grid%nav_lon),MAXVAL(Grid%nav_lon)) + CALL copy_ncdf_att('nav_lat',TRIM(parent_coordinate_file),name,MINVAL(Grid%nav_lat),MAXVAL(Grid%nav_lat)) + CALL copy_ncdf_att('glamt',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamu',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamv',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamf',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphit',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphiu',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphiv',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphif',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1t',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1u',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1v',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1f',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2t',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2u',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2v',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2f',TRIM(parent_coordinate_file),name) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Writing coordinates file: ',name + WRITE(*,*) ' ' + ! + Write_Coordinates = 1 + ! + END FUNCTION Write_Coordinates + ! + ! + ! + !***************************************************** + ! function Read_Bathy_level(name,Grid) + !***************************************************** + ! + INTEGER FUNCTION Read_Bathy_level(name,Grid) + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(Coordinates) :: Grid + ! + CALL read_ncdf_var(parent_level_name,name,Grid%Bathy_level) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Reading bathymetry file: ',name + WRITE(*,*) ' ' + ! + Read_Bathy_level = 1 + ! + END FUNCTION Read_Bathy_level + ! + !***************************************************** + ! function Write_Bathy_level(name,Grid) + !***************************************************** + ! + INTEGER FUNCTION Write_Bathy_level(name,Grid) + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(Coordinates) :: Grid + INTEGER :: status,ncid + CHARACTER(len=1),DIMENSION(2) :: dimnames + ! + status = nf90_create(name,NF90_WRITE,ncid) + status = nf90_close(ncid) + ! + dimnames = (/ 'x','y' /) + CALL write_ncdf_dim(dimnames(1),name,nxfin) + CALL write_ncdf_dim(dimnames(2),name,nyfin) + ! + CALL write_ncdf_var('nav_lon' ,dimnames,name,Grid%nav_lon ,'float') + CALL write_ncdf_var('nav_lat' ,dimnames,name,Grid%nav_lat ,'float') + CALL write_ncdf_var(parent_level_name,dimnames,name,NINT(Grid%bathy_level),'integer') + ! + CALL copy_ncdf_att('nav_lon' ,TRIM(parent_bathy_level),name,MINVAL(Grid%nav_lon),MAXVAL(Grid%nav_lon)) + CALL copy_ncdf_att('nav_lat' ,TRIM(parent_bathy_level),name,MINVAL(Grid%nav_lat),MAXVAL(Grid%nav_lat)) + CALL copy_ncdf_att(parent_level_name,TRIM(parent_bathy_level),name) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Writing bathymetry (levels) in: ',name + WRITE(*,*) ' ' + ! + Write_Bathy_level = 1 + ! + END FUNCTION Write_Bathy_level + ! + !***************************************************** + ! function read_bathy_coord(name,CoarseGrid,ChildGrid) + !***************************************************** + ! + INTEGER FUNCTION read_bathy_coord(name,CoarseGrid,ChildGrid,Pacifique) + ! + USE io_netcdf + CHARACTER(*) name + INTEGER :: i,j,tabdim1,tabdim2 + INTEGER, DIMENSION(1) :: i_min,i_max,j_min,j_max + REAL*8,POINTER,DIMENSION(:) :: topo_lon,topo_lat + INTEGER :: status,ncid,varid + LOGICAL,OPTIONAL :: Pacifique + TYPE(Coordinates) :: CoarseGrid,ChildGrid + REAL*8 :: zdel + zdel = 0.5 ! Offset in degrees to extend extraction of bathymetry data + ! + IF( Dims_Existence('lon',name) .AND. Dims_Existence('lat',name) ) THEN + WRITE(*,*) '****' + WRITE(*,*) ' etopo format for external high resolution database ' + WRITE(*,*) '****' + CALL read_ncdf_var('lon',name,topo_lon) + CALL read_ncdf_var('lat',name,topo_lat) + ELSE IF( Dims_Existence('x',name) .AND. Dims_Existence('y',name) ) THEN + WRITE(*,*) '****' + WRITE(*,*) ' OPA format for external high resolution database ' + WRITE(*,*) '****' + CALL read_ncdf_var('nav_lon',name,CoarseGrid%nav_lon) + CALL read_ncdf_var('nav_lat',name,CoarseGrid%nav_lat) + CALL read_ncdf_var(parent_meter_name,name,CoarseGrid%Bathy_meter) + ! + IF ( PRESENT(Pacifique) ) THEN + IF(Pacifique) THEN + WHERE(CoarseGrid%nav_lon < 0.001) + CoarseGrid%nav_lon = CoarseGrid%nav_lon + 360. + END WHERE + ENDIF + ENDIF + ! + read_bathy_coord = 1 + RETURN + ELSE + WRITE(*,*) '****' + WRITE(*,*) '*** ERROR Bad format for external high resolution database' + WRITE(*,*) '****' + STOP + ENDIF + ! + IF( MAXVAL(ChildGrid%glamt) > 180. ) THEN + ! + WHERE( topo_lon < 0. ) topo_lon = topo_lon + 360. + ! + i_min = MAXLOC(topo_lon,mask = topo_lon < MINVAL(ChildGrid%nav_lon)-zdel) + i_max = MINLOC(topo_lon,mask = topo_lon > MAXVAL(ChildGrid%nav_lon)+zdel) + j_min = MAXLOC(topo_lat,mask = topo_lat < MINVAL(ChildGrid%nav_lat)-zdel) + j_max = MINLOC(topo_lat,mask = topo_lat > MAXVAL(ChildGrid%nav_lat)+zdel) + ! + tabdim1 = ( SIZE(topo_lon) - i_min(1) + 1 ) + i_max(1) + ! + IF( ln_agrif_domain ) THEN + IF(j_min(1)-2 >= 1 .AND. j_max(1)+3 <= SIZE(topo_lat,1) ) THEN + j_min(1) = j_min(1)-2 + j_max(1) = j_max(1)+3 + ENDIF + ENDIF + tabdim2 = j_max(1) - j_min(1) + 1 + ! + ALLOCATE(CoarseGrid%nav_lon(tabdim1,tabdim2)) + ALLOCATE(CoarseGrid%nav_lat(tabdim1,tabdim2)) + ALLOCATE(CoarseGrid%Bathy_meter(tabdim1,tabdim2)) + ! + DO i = 1,tabdim1 + CoarseGrid%nav_lat(i,:) = topo_lat(j_min(1):j_max(1)) + END DO + ! + DO j = 1, tabdim2 + ! + CoarseGrid%nav_lon(1:SIZE(topo_lon)-i_min(1)+1 ,j) = topo_lon(i_min(1):SIZE(topo_lon)) + CoarseGrid%nav_lon(2+SIZE(topo_lon)-i_min(1):tabdim1,j) = topo_lon(1:i_max(1)) + ! + END DO + status = nf90_open(name,NF90_NOWRITE,ncid) + status = nf90_inq_varid(ncid,elevation_name,varid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"Can't find variable: ", elevation_name + STOP + ENDIF + ! + status=nf90_get_var(ncid,varid,CoarseGrid%Bathy_meter(1:SIZE(topo_lon)-i_min(1)+1,:), & + start=(/i_min(1),j_min(1)/),count=(/SIZE(topo_lon)-i_min(1),tabdim2/)) + + status=nf90_get_var(ncid,varid,CoarseGrid%Bathy_meter(2+SIZE(topo_lon)-i_min(1):tabdim1,:), & + start=(/1,j_min(1)/),count=(/i_max(1),tabdim2/)) + ! + ELSE + ! + WHERE( topo_lon > 180. ) topo_lon = topo_lon - 360. + ! + i_min = MAXLOC(topo_lon,mask = topo_lon < MINVAL(ChildGrid%nav_lon)-zdel) + i_max = MINLOC(topo_lon,mask = topo_lon > MAXVAL(ChildGrid%nav_lon)+zdel) + j_min = MAXLOC(topo_lat,mask = topo_lat < MINVAL(ChildGrid%nav_lat)-zdel) + j_max = MINLOC(topo_lat,mask = topo_lat > MAXVAL(ChildGrid%nav_lat)+zdel) + ! + IF( ln_agrif_domain ) THEN + IF(i_min(1)-2 >= 1 .AND. i_max(1)+3 <= SIZE(topo_lon,1) ) THEN + i_min(1) = i_min(1)-2 + i_max(1) = i_max(1)+3 + ENDIF + ENDIF + tabdim1 = i_max(1) - i_min(1) + 1 + ! + IF( ln_agrif_domain ) THEN + IF(j_min(1)-2 >= 1 .AND. j_max(1)+3 <= SIZE(topo_lat,1) ) THEN + j_min(1) = j_min(1)-2 + j_max(1) = j_max(1)+3 + ENDIF + ENDIF + tabdim2 = j_max(1) - j_min(1) + 1 + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Reading bathymetry file: ',name + WRITE(*,*) ' ' + ! + ALLOCATE(CoarseGrid%nav_lon(tabdim1,tabdim2)) + ALLOCATE(CoarseGrid%nav_lat(tabdim1,tabdim2)) + ALLOCATE(CoarseGrid%Bathy_meter(tabdim1,tabdim2)) + ! + DO j = 1,tabdim2 + CoarseGrid%nav_lon(:,j) = topo_lon(i_min(1):i_max(1)) + END DO + ! + DO i = 1,tabdim1 + CoarseGrid%nav_lat(i,:) = topo_lat(j_min(1):j_max(1)) + END DO + ! + status = nf90_open(name,NF90_NOWRITE,ncid) + status = nf90_inq_varid(ncid,elevation_name,varid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"Can't find variable: ", elevation_name + STOP + ENDIF + + status = nf90_get_var(ncid,varid,CoarseGrid%Bathy_meter, & + & start=(/i_min(1),j_min(1)/),count=(/tabdim1,tabdim2/)) + ! + ENDIF + ! + status = nf90_close(ncid) + ! + WHERE(CoarseGrid%Bathy_meter.GE.0) + CoarseGrid%Bathy_meter = 0.0 + END WHERE + ! + CoarseGrid%Bathy_meter(:,:) = -1.0 * CoarseGrid%Bathy_meter(:,:) + ! + read_bathy_coord = 1 + RETURN + ! + END FUNCTION read_bathy_coord + ! + ! + !***************************************************** + ! function read_bathy_meter(name,CoarseGrid,ChildGrid) + !***************************************************** + ! + INTEGER FUNCTION read_bathy_meter(name,Grid) + ! + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(Coordinates) :: Grid + ! + CALL read_ncdf_var(parent_meter_name,name,Grid%Bathy_meter) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Reading bathymetry file: ',name + WRITE(*,*) ' ' + ! + read_bathy_meter = 1 + ! + END FUNCTION read_bathy_meter + ! + !***************************************************** + ! function Write_Bathy_meter(name,Grid) + !***************************************************** + ! + INTEGER FUNCTION Write_Bathy_meter(name,Grid) + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(Coordinates) :: Grid + INTEGER :: status,ncid + CHARACTER(len=1),DIMENSION(2) :: dimnames + INTEGER :: nx,ny + ! + status = nf90_create(name,NF90_WRITE,ncid) + status = nf90_close(ncid) + ! + nx = SIZE(Grid%bathy_meter,1) + ny = SIZE(Grid%bathy_meter,2) + dimnames = (/ 'x','y' /) + + CALL write_ncdf_dim(dimnames(1),name,nx) + CALL write_ncdf_dim(dimnames(2),name,ny) + ! + CALL write_ncdf_var('nav_lon' ,dimnames,name,Grid%nav_lon ,'float') + CALL write_ncdf_var('nav_lat' ,dimnames,name,Grid%nav_lat ,'float') + CALL write_ncdf_var(parent_meter_name,dimnames,name,Grid%bathy_meter,'float') + CALL write_ncdf_var('weight' ,dimnames,name,Grid%wgt ,'float') + ! + CALL copy_ncdf_att('nav_lon' ,TRIM(parent_bathy_meter),name,MINVAL(Grid%nav_lon),MAXVAL(Grid%nav_lon)) + CALL copy_ncdf_att('nav_lat' ,TRIM(parent_bathy_meter),name,MINVAL(Grid%nav_lat),MAXVAL(Grid%nav_lat)) + CALL copy_ncdf_att(parent_meter_name,TRIM(parent_bathy_meter),name) + ! + WRITE(*,*) ' ' + WRITE(*,*) 'Writing bathymetry (meters) in: ',name + WRITE(*,*) ' ' + ! + Write_Bathy_meter = 1 + ! + END FUNCTION Write_Bathy_meter + ! + !***************************************************** + ! function write_domcfg(name,Grid) + !***************************************************** + + INTEGER FUNCTION write_domcfg(name,Grid) + !----------------------------------------- + ! It creates a domain_cfg.nc used in NEMO4 + !----------------------------------------- + ! + USE io_netcdf + ! + CHARACTER(*) name + TYPE(Coordinates) :: Grid + ! + INTEGER :: status, ncid + INTEGER :: nx, ny, jk + INTEGER :: ln_sco, ln_isfcav, ln_zco, ln_zps, jperio + REAL*8 :: rpi, rad, rday, rsiyea, rsiday, omega + ! + CHARACTER(len=1), DIMENSION(3) :: dimnames + REAL*8 , DIMENSION(N) :: e3t_1d, e3w_1d, gdept_1d, gdepw_1d + REAL*8 , ALLOCATABLE, DIMENSION(:,:) :: ff_t, ff_f, zbathy + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: bottom_level, top_level, mbathy + REAL*8 , ALLOCATABLE, DIMENSION(:,:,:) :: e3t_0, e3u_0, e3v_0, e3f_0, e3w_0, e3uw_0, e3vw_0 + ! + ! size of the Grid + nx = SIZE(Grid%bathy_meter,1) + ny = SIZE(Grid%bathy_meter,2) + + ! allocate needed arrays for domain_cfg + ALLOCATE( ff_t(nx,ny), ff_f(nx,ny), zbathy(nx,ny) ) + ALLOCATE( bottom_level(nx,ny), top_level(nx,ny), mbathy(nx,ny) ) + ALLOCATE( e3t_0(nx,ny,N), e3u_0 (nx,ny,N), e3v_0 (nx,ny,N), e3f_0(nx,ny,N), & + & e3w_0(nx,ny,N), e3uw_0(nx,ny,N), e3vw_0(nx,ny,N) ) + + ! some physical parameters + rpi = 3.141592653589793 + rad = 3.141592653589793 / 180. + rday = 24.*60.*60. + rsiyea = 365.25 * rday * 2. * rpi / 6.283076 + rsiday = rday / ( 1. + rday / rsiyea ) + omega = 2. * rpi / rsiday + + ! Coriolis + ff_f(:,:) = 2. * omega * SIN( rad * Grid%gphif(:,:) ) ! compute it on the sphere at f-point + ff_t(:,:) = 2. * omega * SIN( rad * Grid%gphit(:,:) ) ! - - - at t-point + + ! bathy in meters + zbathy(:,:) = Grid%bathy_meter + + ! vertical scale factors + CALL zgr_z( e3t_1d, e3w_1d, gdept_1d, gdepw_1d ) +! DO jk = 1, N +! e3t_0 (:,:,jk) = e3t_1d (jk) +! e3u_0 (:,:,jk) = e3t_1d (jk) +! e3v_0 (:,:,jk) = e3t_1d (jk) +! e3f_0 (:,:,jk) = e3t_1d (jk) +! e3w_0 (:,:,jk) = e3w_1d (jk) +! e3uw_0 (:,:,jk) = e3w_1d (jk) +! e3vw_0 (:,:,jk) = e3w_1d (jk) +! END DO + + ! logicals and others + ln_sco = 0 + ln_isfcav = 0 +!!$ IF( partial_steps ) THEN + ln_zps = 1 + ln_zco = 0 +!!$ ELSE +!!$ ln_zps = 0 +!!$ ln_zco = 1 +!!$ ENDIF + + CALL zgr_zps( nx, ny, gdept_1d, gdepw_1d, e3t_1d, e3w_1d, zbathy, & ! input + & mbathy, e3t_0, e3u_0, e3v_0, e3f_0, e3w_0, e3uw_0, e3vw_0 ) ! output + + ! top/bottom levels + bottom_level(:,:) = mbathy(:,:) + top_level(:,:) = MIN( 1, mbathy(:,:) ) + + ! closed domain for child grid and namelist defined domain for parent grid + IF( TRIM(name) == TRIM(parent_domcfg_updated) .OR. TRIM(name) == TRIM(parent_domcfg_out) ) THEN + jperio = parent_jperio + ELSE + jperio = 0 + ENDIF + + !IF( .NOT.ln_agrif_domain ) THEN + ! bottom_level(1:nx,1 ) = 0 + ! bottom_level(1:nx, ny) = 0 + ! bottom_level(1 ,1:ny) = 0 + ! bottom_level( nx,1:ny) = 0 + + ! top_level(1:nx,1 ) = 0 + ! top_level(1:nx, ny) = 0 + ! top_level(1 ,1:ny) = 0 + ! top_level( nx,1:ny) = 0 + + ! zbathy(1:nx,1 ) = 0. + ! zbathy(1:nx, ny) = 0. + ! zbathy(1 ,1:ny) = 0. + ! zbathy( nx,1:ny) = 0. + !ENDIF + + ! ------------------- + ! write domain_cfg.nc + ! ------------------- + status = nf90_create(name,IOR(NF90_64BIT_OFFSET,NF90_WRITE),ncid) + status = nf90_close(ncid) + ! + ! dimensions + dimnames = (/'x','y','z'/) + CALL write_ncdf_dim(dimnames(1),name,nx) + CALL write_ncdf_dim(dimnames(2),name,ny) + CALL write_ncdf_dim(dimnames(3),name,N) + ! + ! variables + CALL write_ncdf_var('nav_lon',dimnames(1:2),name,Grid%nav_lon,'float') + CALL write_ncdf_var('nav_lat',dimnames(1:2),name,Grid%nav_lat,'float') + CALL write_ncdf_var('nav_lev',dimnames(3) ,name,gdept_1d ,'float') + ! + CALL write_ncdf_var('jpiglo',name,nx ,'integer') + CALL write_ncdf_var('jpjglo',name,ny ,'integer') + CALL write_ncdf_var('jpkglo',name,N ,'integer') + CALL write_ncdf_var('jperio',name,jperio,'integer') + ! + CALL write_ncdf_var('ln_zco' ,name,ln_zco ,'integer') + CALL write_ncdf_var('ln_zps' ,name,ln_zps ,'integer') + CALL write_ncdf_var('ln_sco' ,name,ln_sco ,'integer') + CALL write_ncdf_var('ln_isfcav',name,ln_isfcav,'integer') + + CALL write_ncdf_var('glamt',dimnames(1:2),name,Grid%glamt,'double') + CALL write_ncdf_var('glamu',dimnames(1:2),name,Grid%glamu,'double') + CALL write_ncdf_var('glamv',dimnames(1:2),name,Grid%glamv,'double') + CALL write_ncdf_var('glamf',dimnames(1:2),name,Grid%glamf,'double') + CALL write_ncdf_var('gphit',dimnames(1:2),name,Grid%gphit,'double') + CALL write_ncdf_var('gphiu',dimnames(1:2),name,Grid%gphiu,'double') + CALL write_ncdf_var('gphiv',dimnames(1:2),name,Grid%gphiv,'double') + CALL write_ncdf_var('gphif',dimnames(1:2),name,Grid%gphif,'double') + + CALL write_ncdf_var('e1t',dimnames(1:2),name,Grid%e1t,'double') + CALL write_ncdf_var('e1u',dimnames(1:2),name,Grid%e1u,'double') + CALL write_ncdf_var('e1v',dimnames(1:2),name,Grid%e1v,'double') + CALL write_ncdf_var('e1f',dimnames(1:2),name,Grid%e1f,'double') + CALL write_ncdf_var('e2t',dimnames(1:2),name,Grid%e2t,'double') + CALL write_ncdf_var('e2u',dimnames(1:2),name,Grid%e2u,'double') + CALL write_ncdf_var('e2v',dimnames(1:2),name,Grid%e2v,'double') + CALL write_ncdf_var('e2f',dimnames(1:2),name,Grid%e2f,'double') + + CALL write_ncdf_var('ff_f',dimnames(1:2),name,ff_f,'double') + CALL write_ncdf_var('ff_t',dimnames(1:2),name,ff_t,'double') + + CALL write_ncdf_var('e3t_1d',dimnames(3),name,e3t_1d,'double') + CALL write_ncdf_var('e3w_1d',dimnames(3),name,e3w_1d,'double') + + CALL write_ncdf_var('e3t_0' ,dimnames(:),name,e3t_0 ,'double') + CALL write_ncdf_var('e3w_0' ,dimnames(:),name,e3w_0 ,'double') + CALL write_ncdf_var('e3u_0' ,dimnames(:),name,e3u_0 ,'double') + CALL write_ncdf_var('e3v_0' ,dimnames(:),name,e3v_0 ,'double') + CALL write_ncdf_var('e3f_0' ,dimnames(:),name,e3f_0 ,'double') + CALL write_ncdf_var('e3w_0' ,dimnames(:),name,e3w_0 ,'double') + CALL write_ncdf_var('e3uw_0',dimnames(:),name,e3uw_0,'double') + CALL write_ncdf_var('e3vw_0',dimnames(:),name,e3vw_0,'double') + + CALL write_ncdf_var('bottom_level',dimnames(1:2),name,bottom_level,'integer') + CALL write_ncdf_var('top_level' ,dimnames(1:2),name,top_level ,'integer') + CALL write_ncdf_var('bathy_meter' ,dimnames(1:2),name,zbathy ,'float') + + ! some attributes + CALL copy_ncdf_att('nav_lon',TRIM(parent_coordinate_file),name,MINVAL(Grid%nav_lon),MAXVAL(Grid%nav_lon)) + CALL copy_ncdf_att('nav_lat',TRIM(parent_coordinate_file),name,MINVAL(Grid%nav_lat),MAXVAL(Grid%nav_lat)) + + CALL copy_ncdf_att('glamt',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamu',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamv',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('glamf',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphit',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphiu',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphiv',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('gphif',TRIM(parent_coordinate_file),name) + + CALL copy_ncdf_att('e1t',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1u',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1v',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e1f',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2t',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2u',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2v',TRIM(parent_coordinate_file),name) + CALL copy_ncdf_att('e2f',TRIM(parent_coordinate_file),name) + ! + ! control print + WRITE(*,*) ' ' + WRITE(*,*) 'Writing domcfg file: ',name + WRITE(*,*) ' ' + ! + DEALLOCATE( ff_t, ff_f, zbathy ) + DEALLOCATE( bottom_level, top_level, mbathy ) + DEALLOCATE( e3t_0, e3u_0, e3v_0, e3f_0, e3w_0, e3uw_0, e3vw_0 ) + ! + write_domcfg = 1 + + END FUNCTION write_domcfg + ! + SUBROUTINE zgr_z(e3t_1d, e3w_1d, gdept_1d, gdepw_1d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z (from NEMO4) *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : z-coordinate system (use in all type of coordinate) + !! The depth of model levels is defined from an analytical + !! function the derivative of which gives the scale factors. + !! both depth and scale factors only depend on k (1d arrays). + !! w-level: gdepw_1d = gdep(k) + !! e3w_1d(k) = dk(gdep)(k) = e3(k) + !! t-level: gdept_1d = gdep(k+0.5) + !! e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5) + !! + !! ** Action : - gdept_1d, gdepw_1d : depth of T- and W-point (m) + !! - e3t_1d , e3w_1d : scale factors at T- and W-levels (m) + !! + !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + REAL*8 :: zt, zw ! temporary scalars + REAL*8 :: zsur, za0, za1, zkth ! Values set from parameters in + REAL*8 :: zacr, zdzmin, zhmax ! par_CONFIG_Rxx.h90 + REAL*8 :: za2, zkth2, zacr2 ! Values for optional double tanh function set from parameters + + REAL*8, DIMENSION(:), INTENT(out) :: e3t_1d, e3w_1d, gdept_1d, gdepw_1d + !!---------------------------------------------------------------------- + ! + ! + ! Set variables from parameters + ! ------------------------------ + zkth = ppkth ; zacr = ppacr + zdzmin = ppdzmin ; zhmax = pphmax + zkth2 = ppkth2 ; zacr2 = ppacr2 ! optional (ldbletanh=T) double tanh parameters + + ! If pa1 and pa0 and psur are et to pp_to_be_computed + ! za0, za1, zsur are computed from ppdzmin , pphmax, ppkth, ppacr + IF ( ( pa0 == 0 .OR. pa1 == 0 .OR. psur == 0 ) & + .AND. ppdzmin.NE.0 .AND. pphmax.NE.0 ) THEN + ! + za1 = ( ppdzmin - pphmax / FLOAT(N-1) ) & + & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(N-1) * ( LOG( COSH( (N - ppkth) / ppacr) ) & + & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) + za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) + zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) + ELSE + za1 = pa1 ; za0 = pa0 ; zsur = psur + za2 = pa2 ! optional (ldbletanh=T) double tanh parameter + ENDIF + + ! Reference z-coordinate (depth - scale factor at T- and W-points) + ! ====================== + IF( ppkth == 0. ) THEN ! uniform vertical grid + + za1 = zhmax / FLOAT(N-1) + + DO jk = 1, N + zw = FLOAT( jk ) + zt = FLOAT( jk ) + 0.5 + gdepw_1d(jk) = ( zw - 1 ) * za1 + gdept_1d(jk) = ( zt - 1 ) * za1 + e3w_1d (jk) = za1 + e3t_1d (jk) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. ldbletanh ) THEN + DO jk = 1, N + zw = REAL( jk ) + zt = REAL( jk ) + 0.5 + gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) ) + gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) ) + e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth) / zacr ) + e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth) / zacr ) + END DO + ELSE + DO jk = 1, N + zw = FLOAT( jk ) + zt = FLOAT( jk ) + 0.5 + ! Double tanh function + gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) ) + gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) ) + e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth ) / zacr ) & + & + za2 * TANH( (zw-zkth2) / zacr2 ) + e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth ) / zacr ) & + & + za2 * TANH( (zt-zkth2) / zacr2 ) + END DO + ENDIF + gdepw_1d(1) = 0. ! force first w-level to be exactly at zero + ENDIF + + IF ( ln_e3_dep ) THEN ! e3. = dk[gdep] + ! + !==>>> need to be like this to compute the pressure gradient with ISF. + ! If not, level beneath the ISF are not aligned (sum(e3t) /= depth) + ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively + ! + DO jk = 1, N-1 + e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk) + END DO + e3t_1d(N) = e3t_1d(N-1) ! we don't care because this level is masked in NEMO + + DO jk = 2, N + e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1) + END DO + e3w_1d(1 ) = 2. * (gdept_1d(1) - gdepw_1d(1)) + END IF + + ! + END SUBROUTINE zgr_z + + SUBROUTINE zgr_zps( nx, ny, gdept_1d, gdepw_1d, e3t_1d, e3w_1d, zbathy, & + & mbathy, e3t_0, e3u_0, e3v_0, e3f_0, e3w_0, e3uw_0, e3vw_0 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_zps (from NEMO4) *** + !! + !! ** Purpose : the depth and vertical scale factor in partial step + !! reference z-coordinate case + !! + !! ** Method : Partial steps : computes the 3D vertical scale factors + !! of T-, U-, V-, W-, UW-, VW and F-points that are associated with + !! a partial step representation of bottom topography. + !! + !! The reference depth of model levels is defined from an analytical + !! function the derivative of which gives the reference vertical + !! scale factors. + !! From depth and scale factors reference, we compute there new value + !! with partial steps on 3d arrays ( i, j, k ). + !! + !! w-level: gdepw_0(i,j,k) = gdep(k) + !! e3w_0(i,j,k) = dk(gdep)(k) = e3(i,j,k) + !! t-level: gdept_0(i,j,k) = gdep(k+0.5) + !! e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) + !! + !! With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), + !! we find the mbathy index of the depth at each grid point. + !! This leads us to three cases: + !! + !! - bathy = 0 => mbathy = 0 + !! - 1 < mbathy < jpkm1 + !! - bathy > gdepw_0(jpk) => mbathy = jpkm1 + !! + !! Then, for each case, we find the new depth at t- and w- levels + !! and the new vertical scale factors at t-, u-, v-, w-, uw-, vw- + !! and f-points. + !! + !! This routine is given as an example, it must be modified + !! following the user s desiderata. nevertheless, the output as + !! well as the way to compute the model levels and scale factors + !! must be respected in order to insure second order accuracy + !! schemes. + !! + !! c a u t i o n : gdept_1d, gdepw_1d and e3._1d are positives + !! - - - - - - - gdept_0, gdepw_0 and e3. are positives + !! + !! Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ik + INTEGER :: ikb, ikt ! temporary integers + REAL*8 :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points + REAL*8 :: zdepwp, zdepth ! Ajusted ocean depth to avoid too small e3t + REAL*8 :: zmax ! temporary scalar + ! + REAL*8, ALLOCATABLE, DIMENSION(:,:,:) :: gdept_0, gdepw_0, zprt + ! + INTEGER, INTENT(in ) :: nx, ny + REAL*8 , DIMENSION(:) , INTENT(in ) :: gdept_1d, gdepw_1d, e3t_1d, e3w_1d + REAL*8 , DIMENSION(:,:) , INTENT(inout) :: zbathy + INTEGER, DIMENSION(:,:) , INTENT( out) :: mbathy + REAL*8 , DIMENSION(:,:,:), INTENT( out) :: e3t_0, e3u_0, e3v_0, e3f_0, e3w_0, e3uw_0, e3vw_0 + ! + !!--------------------------------------------------------------------- + + ALLOCATE( zprt(nx,ny,N), gdept_0(nx,ny,N), gdepw_0(nx,ny,N) ) + ! + ! bathymetry in level (from bathy_meter) + ! =================== + zmax = gdepw_1d(N) + e3t_1d(N) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(N-1) ) + zbathy(:,:) = MIN( zmax , zbathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) + WHERE( zbathy(:,:) == 0. ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 + ELSEWHERE ; mbathy(:,:) = N-1 ! ocean : initialize mbathy to the max ocean level + END WHERE + +!!$ IF( partial_steps ) THEN + ! Compute mbathy for ocean points (i.e. the number of ocean levels) + ! find the number of ocean levels such that the last level thickness + ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where + ! e3t_1d is the reference level thickness + DO jk = N-1, 1, -1 + zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) + WHERE( 0. < zbathy(:,:) .AND. zbathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 + END DO +!!$ ELSE +!!$ DO jk = 1, N +!!$ WHERE( 0. < zbathy(:,:) .AND. zbathy(:,:) >= gdepw_1d(jk) ) mbathy(:,:) = jk-1 +!!$ END DO +!!$ ENDIF + + ! Scale factors and depth at T- and W-points + DO jk = 1, N ! intitialization to the reference z-coordinate + gdept_0(:,:,jk) = gdept_1d(jk) + gdepw_0(:,:,jk) = gdepw_1d(jk) + e3t_0 (:,:,jk) = e3t_1d (jk) + e3w_0 (:,:,jk) = e3w_1d (jk) + END DO + + ! Bathy, iceshelf draft, scale factor and depth at T- and W- points in case of isf + !!clem: not implemented yet + !! IF ( ln_isfcav == 1 ) CALL zgr_isf + ! + ! Scale factors and depth at T- and W-points + ! IF ( ln_isfcav == 0 ) THEN + DO jj = 1, ny + DO ji = 1, nx + ik = mbathy(ji,jj) + IF( ik > 0 ) THEN ! ocean point only + ! max ocean level case + IF( ik == N-1 ) THEN + zdepwp = zbathy(ji,jj) + ze3tp = zbathy(ji,jj) - gdepw_1d(ik) + ze3wp = 0.5 * e3w_1d(ik) * ( 1. + ( ze3tp/e3t_1d(ik) ) ) + e3t_0(ji,jj,ik ) = ze3tp + e3t_0(ji,jj,ik+1) = ze3tp + e3w_0(ji,jj,ik ) = ze3wp + e3w_0(ji,jj,ik+1) = ze3tp + gdepw_0(ji,jj,ik+1) = zdepwp + gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp + gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp + ! + ELSE ! standard case + IF( zbathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = zbathy(ji,jj) + ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) + ENDIF + !gm Bug? check the gdepw_1d + ! ... on ik + gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & + & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & + & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) + e3t_0 (ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & + & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ) + e3w_0(ji,jj,ik) = 0.5 * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2. * gdepw_1d(ik) ) & + & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) + ! ... on ik+1 + e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) + gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) + ENDIF + ENDIF + END DO + END DO + ! + ! DO jj = 1, ny + ! DO ji = 1, nx + ! ik = mbathy(ji,jj) + ! IF( ik > 0 ) THEN ! ocean point only + ! e3tp (ji,jj) = e3t_0(ji,jj,ik) + ! e3wp (ji,jj) = e3w_0(ji,jj,ik) + ! ENDIF + ! END DO + ! END DO + ! END IF + ! + ! Scale factors and depth at U-, V-, UW and VW-points + DO jk = 1, N ! initialisation to z-scale factors + e3u_0 (:,:,jk) = e3t_1d(jk) + e3v_0 (:,:,jk) = e3t_1d(jk) + e3uw_0(:,:,jk) = e3w_1d(jk) + e3vw_0(:,:,jk) = e3w_1d(jk) + END DO + + DO jk = 1,N ! Computed as the minimum of neighbooring scale factors + DO jj = 1, ny-1 + DO ji = 1, nx-1 ! vector opt. + e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) + e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) + e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) + e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) + END DO + END DO + END DO + +! IF ( ln_isfcav == 1 ) THEN +! ! (ISF) define e3uw (adapted for 2 cells in the water column) +! DO jj = 2, ny-1 +! DO ji = 2, nx-1 ! vector opt. +! ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) +! ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) +! IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji+1,jj ,ikb ) ) & +! & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj ,ikb-1) ) +! ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) +! ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) +! IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji ,jj+1,ikb ) ) & +! & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji ,jj+1,ikb-1) ) +! END DO +! END DO +! END IF + ! + + DO jk = 1, N ! set to z-scale factor if zero (i.e. along closed boundaries) + WHERE( e3u_0 (:,:,jk) == 0. ) e3u_0 (:,:,jk) = e3t_1d(jk) + WHERE( e3v_0 (:,:,jk) == 0. ) e3v_0 (:,:,jk) = e3t_1d(jk) + WHERE( e3uw_0(:,:,jk) == 0. ) e3uw_0(:,:,jk) = e3w_1d(jk) + WHERE( e3vw_0(:,:,jk) == 0. ) e3vw_0(:,:,jk) = e3w_1d(jk) + END DO + + ! Scale factor at F-point + DO jk = 1, N ! initialisation to z-scale factors + e3f_0(:,:,jk) = e3t_1d(jk) + END DO + DO jk = 1, N ! Computed as the minimum of neighbooring V-scale factors + DO jj = 1, ny-1 + DO ji = 1, nx-1 ! vector opt. + e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) + END DO + END DO + END DO + ! + DO jk = 1, N ! set to z-scale factor if zero (i.e. along closed boundaries) + WHERE( e3f_0(:,:,jk) == 0. ) e3f_0(:,:,jk) = e3t_1d(jk) + END DO + + ! Control of the sign + IF( MINVAL( e3t_0 (:,:,:) ) <= 0. ) STOP ' zgr_zps : e r r o r e3t_0 <= 0' + IF( MINVAL( e3w_0 (:,:,:) ) <= 0. ) STOP ' zgr_zps : e r r o r e3w_0 <= 0' + IF( MINVAL( gdept_0(:,:,:) ) < 0. ) STOP ' zgr_zps : e r r o r gdept_0 < 0' + IF( MINVAL( gdepw_0(:,:,:) ) < 0. ) STOP ' zgr_zps : e r r o r gdepw_0 < 0' + + ! Compute gde3w_0 (vertical sum of e3w) +! IF ( ln_isfcav ==1 ) THEN ! if cavity +! WHERE( misfdep == 0 ) misfdep = 1 +! DO jj = 1,ny +! DO ji = 1,nx +! gde3w_0(ji,jj,1) = 0.5 * e3w_0(ji,jj,1) +! DO jk = 2, misfdep(ji,jj) +! gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) +! END DO +! IF( misfdep(ji,jj) >= 2 ) gde3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5 * e3w_0(ji,jj,misfdep(ji,jj)) +! DO jk = misfdep(ji,jj) + 1, N +! gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) +! END DO +! END DO +! END DO +! ELSE ! no cavity +! gde3w_0(:,:,1) = 0.5 * e3w_0(:,:,1) +! DO jk = 2, N +! gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) +! END DO +! END IF + ! + DEALLOCATE( zprt, gdept_0, gdepw_0 ) + ! + END SUBROUTINE zgr_zps + + !***************************************************** + ! function set_child_name(Parentname,Childname) + !***************************************************** + ! + SUBROUTINE set_child_name(Parentname,Childname) + ! + CHARACTER(*),INTENT(in) :: Parentname + CHARACTER(*),INTENT(out) :: Childname + CHARACTER(2) :: prefix + INTEGER :: pos + ! + pos = INDEX(TRIM(Parentname),'/',back=.TRUE.) + ! + prefix=Parentname(pos+1:pos+2) + IF (prefix == '1_') THEN + Childname = '2_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '2_') THEN + Childname = '3_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '3_') THEN + Childname = '4_'//Parentname(pos+3:LEN(Parentname)) + ELSEIF (prefix == '4_') THEN + Childname = '5_'//Parentname(pos+3:LEN(Parentname)) + ELSE + Childname = '1_'//Parentname(pos+1:LEN(Parentname)) + ENDIF + ! + END SUBROUTINE set_child_name + ! + !***************************************************** + ! subroutine get_interptype(varname,interp_type,conservation) + !***************************************************** + ! + SUBROUTINE get_interptype( varname,interp_type,conservation ) + ! + LOGICAL,OPTIONAL :: conservation + CHARACTER(*) :: interp_type,varname + INTEGER :: pos,pos1,pos2,pos3,i,k + LOGICAL :: find + i=1 + DO WHILE ( TRIM(VAR_INTERP(i)) /= '' ) + pos = INDEX( TRIM(VAR_INTERP(i)) , TRIM(varname) ) + IF ( pos .NE. 0 ) THEN + pos1 = INDEX( TRIM(VAR_INTERP(i)) , 'bicubic' ) + pos2 = INDEX( TRIM(VAR_INTERP(i)) , 'bilinear' ) + pos3 = INDEX( TRIM(VAR_INTERP(i)) , 'conservative' ) + ! initialize interp_type + IF( pos1 .NE. 0 ) interp_type = 'bicubic' + IF( pos2 .NE. 0 ) interp_type = 'bilinear' + IF( pos1 .EQ. 0 .AND. pos2 .EQ. 0) interp_type = 'bicubic' + ! initialize conservation + IF( pos3 .NE. 0 .AND. PRESENT(conservation) ) THEN + conservation = .TRUE. + RETURN + ELSE + conservation = .FALSE. + ENDIF + find = .FALSE. + IF( PRESENT(conservation) ) THEN + k=0 + conservation = .FALSE. + DO WHILE( k < SIZE(flxtab) .AND. .NOT.find ) + k = k+1 + IF( TRIM(varname) .EQ. TRIM(flxtab(k)) ) THEN + conservation = .TRUE. + find = .TRUE. + ENDIF + END DO + ENDIF + RETURN + ENDIF + i = i+1 + END DO + !default values interp_type = bicubic // conservation = false + interp_type = 'bicubic' + IF( PRESENT(conservation) ) conservation = .FALSE. + + RETURN + ! + END SUBROUTINE get_interptype + ! + !***************************************************** + ! subroutine Init_mask(name,Grid) + !***************************************************** + ! + SUBROUTINE Init_mask(name,Grid,jpiglo,jpjglo) + ! + USE io_netcdf + ! + CHARACTER(*) name + INTEGER :: nx,ny,k,i,j,jpiglo,jpjglo + TYPE(Coordinates) :: Grid + REAL*8, POINTER, DIMENSION(:,:) ::zwf => NULL() + ! + IF(jpiglo == 1 .AND. jpjglo == 1) THEN + CALL read_ncdf_var('Bathy_level',name,Grid%Bathy_level) + ELSE + CALL read_ncdf_var('Bathy_level',name,Grid%Bathy_level,(/jpizoom,jpjzoom/),(/jpiglo,jpjglo/) ) + ENDIF + + + ! + WRITE(*,*) 'Init masks in T,U,V,F points' + ! + nx = SIZE(Grid%Bathy_level,1) + ny = SIZE(Grid%Bathy_level,2) + ! + ! + ALLOCATE(Grid%tmask(nx,ny,N), & + Grid%umask(nx,ny,N), & + Grid%vmask(nx,ny,N), & + Grid%fmask(nx,ny,N)) + ! + DO k = 1,N + ! + WHERE(Grid%Bathy_level(:,:) <= k-1 ) + Grid%tmask(:,:,k) = 0 + ELSEWHERE + Grid%tmask(:,:,k) = 1 + END WHERE + ! + END DO + ! + Grid%umask(1:nx-1,:,:) = Grid%tmask(1:nx-1,:,:)*Grid%tmask(2:nx,:,:) + Grid%vmask(:,1:ny-1,:) = Grid%tmask(:,1:ny-1,:)*Grid%tmask(:,2:ny,:) + ! + Grid%umask(nx,:,:) = Grid%tmask(nx,:,:) + Grid%vmask(:,ny,:) = Grid%tmask(:,ny,:) + ! + Grid%fmask(1:nx-1,1:ny-1,:) = Grid%tmask(1:nx-1,1:ny-1,:)*Grid%tmask(2:nx,1:ny-1,:)* & + Grid%tmask(1:nx-1,2:ny,:)*Grid%tmask(2:nx,2:ny,:) + ! + Grid%fmask(nx,:,:) = Grid%tmask(nx,:,:) + Grid%fmask(:,ny,:) = Grid%tmask(:,ny,:) + ! + ALLOCATE(zwf(nx,ny)) + ! + DO k = 1,N + ! + zwf(:,:) = Grid%fmask(:,:,k) + ! + DO j = 2, ny-1 + DO i = 2,nx-1 + IF( Grid%fmask(i,j,k) == 0. ) THEN + Grid%fmask(i,j,k) = shlat * MIN(1.,MAX( zwf(i+1,j),zwf(i,j+1),zwf(i-1,j),zwf(i,j-1))) + END IF + END DO + END DO + ! + DO j = 2, ny-1 + IF( Grid%fmask(1,j,k) == 0. ) THEN + Grid%fmask(1,j,k) = shlat * MIN(1.,MAX(zwf(2,j),zwf(1,j+1),zwf(1,j-1))) + ENDIF + + IF( Grid%fmask(nx,j,k) == 0. ) THEN + Grid%fmask(nx,j,k) = shlat * MIN(1.,MAX(zwf(nx,j+1),zwf(nx-1,j),zwf(nx,j-1))) + ENDIF + END DO + ! + DO i = 2, nx-1 + IF( Grid%fmask(i,1,k) == 0. ) THEN + Grid%fmask(i, 1 ,k) = shlat*MIN( 1.,MAX(zwf(i+1,1),zwf(i,2),zwf(i-1,1))) + ENDIF + ! + IF( Grid%fmask(i,ny,k) == 0. ) THEN + Grid%fmask(i,ny,k) = shlat * MIN(1.,MAX(zwf(i+1,ny),zwf(i-1,ny),zwf(i,ny-1))) + ENDIF + END DO + !! + END DO + !! + END SUBROUTINE Init_mask + ! + !***************************************************** + ! subroutine Init_Tmask(name,Grid) + !***************************************************** + ! + SUBROUTINE Init_Tmask(name,Grid,jpiglo,jpjglo) + ! + USE io_netcdf + ! + CHARACTER(*) name + INTEGER :: nx,ny,k,i,j,jpiglo,jpjglo + TYPE(Coordinates) :: Grid + REAL*8, POINTER, DIMENSION(:,:) ::zwf => NULL() + ! + IF(jpiglo == 1 .AND. jpjglo == 1) THEN + CALL read_ncdf_var('Bathy_level',name,Grid%Bathy_level) + ELSE + CALL read_ncdf_var('Bathy_level',name,Grid%Bathy_level,(/jpizoom,jpjzoom/),(/jpiglo,jpjglo/) ) + ENDIF + ! + nx = SIZE(Grid%Bathy_level,1) + ny = SIZE(Grid%Bathy_level,2) + ! + WRITE(*,*) 'Init masks in T points' + ! + ALLOCATE( Grid%tmask(nx,ny,N) ) + ! + DO k = 1,N + ! + WHERE(Grid%Bathy_level(:,:) <= k-1 ) + Grid%tmask(:,:,k) = 0. + ELSEWHERE + Grid%tmask(:,:,k) = 1. + END WHERE + ! + END DO + ! + END SUBROUTINE Init_Tmask + ! + !***************************************************** + ! subroutine Init_ssmask(name,Grid) + !***************************************************** + ! +! SUBROUTINE Init_ssmask(varname,filename,Grid,jpiglo,jpjglo) +! ! +! USE io_netcdf +! ! +! CHARACTER(*) varname,filename +! INTEGER :: nx,ny,k,i,j,jpiglo,jpjglo +! TYPE(Coordinates) :: Grid +! REAL*8, POINTER, DIMENSION(:,:) ::zwf => NULL() +! ! +! IF(jpiglo == 1 .AND. jpjglo == 1) THEN +! CALL read_ncdf_var(varname,filename,Grid%bathy_level) +! ELSE +! CALL read_ncdf_var(varname,filename,Grid%bathy_level,(/jpizoom,jpjzoom/),(/jpiglo,jpjglo/) ) +! ENDIF +! ! +! nx = SIZE(Grid%bathy_level,1) +! ny = SIZE(Grid%bathy_level,2) +! ! +! WRITE(*,*) 'Init surface masks in T points' +! ! +! ALLOCATE( Grid%ssmask(nx,ny), Grid%ssumask(nx,ny), Grid%ssvmask(nx,ny) ) +! ! +! WHERE(Grid%bathy_level(:,:) <= 0. ) +! Grid%ssmask(:,:) = 0. +! ELSEWHERE +! Grid%ssmask(:,:) = 1. +! END WHERE +! ! +! Grid%ssumask(1:nx-1,:) = Grid%ssmask(1:nx-1,:)*Grid%ssmask(2:nx,:) +! Grid%ssvmask(:,1:ny-1) = Grid%ssmask(:,1:ny-1)*Grid%ssmask(:,2:ny) +! ! +! Grid%ssumask(nx,:) = Grid%ssmask(nx,:) +! Grid%ssvmask(:,ny) = Grid%ssmask(:,ny) +! ! +! END SUBROUTINE Init_ssmask + ! + !***************************************************** + ! subroutine get_mask(name,Grid) + !***************************************************** + ! + SUBROUTINE get_mask(level,posvar,mask,filename) + ! + USE io_netcdf + ! + CHARACTER(*) filename + CHARACTER(*) posvar + INTEGER :: level, nx, ny + LOGICAL,DIMENSION(:,:),POINTER :: mask + INTEGER,DIMENSION(:,:),POINTER :: maskT,maskU,maskV + ! + TYPE(Coordinates) :: Grid + ! + CALL read_ncdf_var('Bathy_level',filename,Grid%Bathy_level) + ! + nx = SIZE(Grid%Bathy_level,1) + ny = SIZE(Grid%Bathy_level,2) + ALLOCATE(maskT(nx,ny),mask(nx,ny)) + mask = .TRUE. + ! + WHERE(Grid%Bathy_level(:,:) <= level-1 ) + maskT(:,:) = 0 + ELSEWHERE + maskT(:,:) = 1 + END WHERE + ! + SELECT CASE(posvar) + ! + CASE('T') + ! + WHERE(maskT > 0) + mask = .TRUE. + ELSEWHERE + mask = .FALSE. + END WHERE + DEALLOCATE(maskT) + ! + CASE('U') + ! + ALLOCATE(maskU(nx,ny)) + maskU(1:nx-1,:) = maskT(1:nx-1,:)*maskT(2:nx,:) + maskU(nx,:) = maskT(nx,:) + WHERE(maskU > 0) + mask = .TRUE. + ELSEWHERE + mask = .FALSE. + END WHERE + DEALLOCATE(maskU,maskT) + ! + CASE('V') + ! + ALLOCATE(maskV(nx,ny)) + maskV(:,1:ny-1) = maskT(:,1:ny-1)*maskT(:,2:ny) + maskV(:,ny) = maskT(:,ny) + WHERE(maskT > 0) + mask = .TRUE. + ELSEWHERE + mask = .FALSE. + END WHERE + DEALLOCATE(maskV,maskT) + ! + END SELECT + ! + END SUBROUTINE get_mask + ! + ! + !***************************************************** + ! subroutine read_dimg_var(unit,irec,field) + !***************************************************** + ! + SUBROUTINE read_dimg_var(unit,irec,field,jpk) + ! + INTEGER :: unit,irec,jpk + REAL*8,DIMENSION(:,:,:,:),POINTER :: field + INTEGER :: k + ! + DO k = 1,jpk + READ(unit,REC=irec) field(:,:,k,1) + irec = irec + 1 + ENDDO + ! + END SUBROUTINE read_dimg_var + ! + ! + !***************************************************** + ! subroutine read_dimg_var(unit,irec,field) + !***************************************************** + ! + SUBROUTINE write_dimg_var(unit,irec,field,jpk) + ! + INTEGER :: unit,irec,jpk + REAL*8,DIMENSION(:,:,:,:),POINTER :: field + INTEGER :: k + ! + DO k = 1,jpk + WRITE(unit,REC=irec) field(:,:,k,1) + irec = irec + 1 + ENDDO + ! + END SUBROUTINE write_dimg_var + +END MODULE agrif_readwrite diff --git a/V4.0/nemo_sources/tools/NESTING/src/agrif_types.f90 b/V4.0/nemo_sources/tools/NESTING/src/agrif_types.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b07fc5dd4d7c04385aaba00b6288be8ba95eab9d --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/agrif_types.f90 @@ -0,0 +1,249 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari (Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +MODULE agrif_types + ! + PUBLIC + ! + !***************************** + ! Coordinates type definition + !***************************** + TYPE Coordinates + ! + REAL*8, DIMENSION(:,:), POINTER :: nav_lon, nav_lat => NULL() + REAL*8, DIMENSION(:,:), POINTER :: glamv, glamu, glamt, glamf => NULL() + REAL*8, DIMENSION(:,:), POINTER :: gphit, gphiu, gphiv, gphif => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e1t, e1u, e1v, e1f => NULL() + REAL*8, DIMENSION(:,:), POINTER :: e2t, e2u, e2v, e2f => NULL() + REAL*8, DIMENSION(:,:), POINTER :: bathy_level => NULL() + REAL*8, DIMENSION(:,:), POINTER :: bathy_meter => NULL() + REAL*8, DIMENSION(:,:), POINTER :: wgt => NULL() + REAL*8, DIMENSION(:,:,:),POINTER :: fmask, umask, vmask, tmask => NULL() + REAL*8, DIMENSION(:,:,:),POINTER :: e3t_ps, e3w_ps, gdept_ps, gdepwps => NULL() + REAL*8, DIMENSION(:,:), POINTER :: gdepw_ps => NULL() + REAL*8, DIMENSION(:), POINTER :: gdeptht => NULL() + INTEGER, DIMENSION(:) , POINTER :: time_steps => NULL() + ! + END TYPE Coordinates + ! + ! + ! + CHARACTER*8,DIMENSION(10) :: flxtab = (/'socliot1','socliot2','socliopl', & + 'socliocl','socliohu','socliowi','soshfldo','sohefldo','sowaflup','sofbt '/) + ! + ! + !************************************************************** + ! Declaration of various input file variables (namelist.input) + !************************************************************** + ! + INTEGER :: irafx, irafy + INTEGER :: nxfin, nyfin + ! + INTEGER :: nbghostcellsfine, imin, jmin, imax, jmax, rho, rhot + INTEGER :: shlat + INTEGER :: N, type_bathy_interp + ! + INTEGER :: jpizoom, jpjzoom, npt_connect, npt_copy + INTEGER :: parent_jperio + ! + REAL*8 :: rn_hmin + REAL*8 :: ppkth2, ppacr2, ppkth, ppacr, ppdzmin, pphmax, smoothing_factor, e3zps_min, e3zps_rat + REAL*8 :: psur, pa0, pa1, pa2, adatrj + ! + LOGICAL :: ldbletanh, ln_e3_dep + LOGICAL :: partial_steps, smoothing, bathy_update + LOGICAL :: new_topo, removeclosedseas, dimg, iom_activated + LOGICAL :: ln_agrif_domain + ! + CHARACTER*100 :: parent_bathy_level, parent_level_name, parent_bathy_meter, parent_meter_name, parent_domcfg_out + CHARACTER*100 :: elevation_name, elevation_database + CHARACTER*100 :: parent_coordinate_file, parent_bathy_meter_updated, parent_domcfg_updated, & + & restart_file, restart_trc_file, restart_ice_file + CHARACTER*100 :: dimg_output_file, interp_type + ! + CHARACTER(len=80) , DIMENSION(20) :: flx_Files, u_files, v_files + CHARACTER(len=255), DIMENSION(20) :: VAR_INTERP + ! + NAMELIST /input_output/iom_activated + ! + NAMELIST /coarse_grid_files/parent_coordinate_file, parent_bathy_level, parent_level_name, & + & parent_bathy_meter, parent_meter_name, parent_domcfg_out, & + & parent_jperio + ! + NAMELIST /bathymetry/new_topo, elevation_database, elevation_name, smoothing, smoothing_factor, & + ln_agrif_domain, npt_connect, npt_copy, removeclosedseas, type_bathy_interp, rn_hmin + ! + NAMELIST /nesting/nbghostcellsfine, imin, imax, jmin, jmax, rho, rhot, & + & bathy_update, parent_bathy_meter_updated, parent_domcfg_updated + ! + NAMELIST /vertical_grid/ppkth, ppacr, ppdzmin, pphmax, psur, pa0, pa1, N, ldbletanh, ln_e3_dep, pa2, ppkth2, ppacr2 + ! + NAMELIST /partial_cells/partial_steps, e3zps_min, e3zps_rat + ! + NAMELIST /nemo_coarse_grid/ jpizoom, jpjzoom + ! + NAMELIST /forcing_files/ flx_files, u_files, v_files + ! + NAMELIST /interp/ VAR_INTERP + ! + NAMELIST /restart/ restart_file, shlat, dimg, dimg_output_file, adatrj, interp_type + ! + NAMELIST /restart_trc/ restart_trc_file, interp_type + ! + NAMELIST /restart_ice/ restart_ice_file, interp_type + ! +CONTAINS + ! + !******************************************************** + !subroutine agrif_grid_allocate * + ! * + !allocation of grid type elements * + ! according to nx and ny * + ! * + ! * + !******************************************************** + ! + SUBROUTINE agrif_grid_allocate(Grid, nx, ny) + ! + TYPE(Coordinates) :: Grid + INTEGER :: nx, ny + ! + ALLOCATE(Grid%nav_lon(nx,ny),Grid%nav_lat(nx,ny)) + ! + ALLOCATE(Grid%glamt(nx,ny),Grid%glamu(nx,ny),Grid%glamv(nx,ny),Grid%glamf(nx,ny)) + ALLOCATE(Grid%gphit(nx,ny),Grid%gphiu(nx,ny),Grid%gphiv(nx,ny),Grid%gphif(nx,ny)) + ! + ALLOCATE(Grid%e1t(nx,ny),Grid%e1u(nx,ny),Grid%e1v(nx,ny),Grid%e1f(nx,ny)) + ALLOCATE(Grid%e2t(nx,ny),Grid%e2u(nx,ny),Grid%e2v(nx,ny),Grid%e2f(nx,ny)) + ! + ALLOCATE(Grid%bathy_level(nx,ny)) + ! + END SUBROUTINE agrif_grid_allocate + ! + ! + !************************************************************************ + ! * + ! subroutine read_namelist * + ! * + ! read variables contained in namelist.input file * + ! filled in by user * + ! * + !************************************************************************ + ! + SUBROUTINE read_namelist(namelistname) + ! + IMPLICIT NONE + CHARACTER(len=80) :: namelistname + CHARACTER*255 :: output + LOGICAL :: is_it_there + INTEGER unit_nml + ! + FLX_FILES = '' + U_FILES = '' + V_FILES = '' + VAR_INTERP = '' + unit_nml = Agrif_Get_Unit() + ! + INQUIRE ( FILE = namelistname , EXIST = is_it_there ) + ! + IF ( is_it_there ) THEN + ! + OPEN ( FILE = namelistname , & + UNIT = unit_nml , & + STATUS = 'OLD' , & + FORM = 'FORMATTED' , & + ACTION = 'READ' , & + ACCESS = 'SEQUENTIAL' ) + ! + REWIND(unit_nml) + READ (unit_nml , NML = input_output) + READ (unit_nml , NML = coarse_grid_files) + READ (unit_nml , NML = bathymetry) + READ (unit_nml , NML = nesting) + READ (unit_nml , NML = vertical_grid) + READ (unit_nml , NML = partial_cells) + READ (unit_nml , NML = nemo_coarse_grid ) + READ (unit_nml , NML = forcing_files ) + READ (unit_nml , NML = interp ) + READ (unit_nml , NML = restart ) + READ (unit_nml , NML = restart_trc ) + READ (unit_nml , NML = restart_ice ) + CLOSE(unit_nml) + ! + irafx = rho + irafy = rho + imin = imin + jpizoom - 1 + imax = imax + jpizoom - 1 + jmin = jmin + jpjzoom - 1 + jmax = jmax + jpjzoom - 1 + ! + IF( ln_agrif_domain ) THEN + nxfin = (imax-imin)*irafx+2*nbghostcellsfine+2 + nyfin = (jmax-jmin)*irafy+2*nbghostcellsfine+2 + ELSE + bathy_update = .FALSE. + nbghostcellsfine = 0 + nxfin = (imax-imin+1)*irafx + nyfin = (jmax-jmin+1)*irafy + ENDIF + ! + IF( .NOT.partial_steps ) THEN + WRITE(*,*) 'E R R O R: partial_steps must be set to true otherwise very thin bottom layers can be created' + STOP + ENDIF + ! + ELSE + ! + PRINT *,'namelist file ''',TRIM(namelistname),''' not found' + STOP + ! + END IF + ! + ! + END SUBROUTINE read_namelist + + INTEGER FUNCTION agrif_int(x) + + REAL :: x + INTEGER ::i + + i = FLOOR(x) + 1 + + IF( ABS(x - i).LE.0.0001 )THEN + agrif_int = i + ELSE + agrif_int = i-1 + ENDIF + + END FUNCTION agrif_int + ! + !************************************************* + ! function Agrif_Get_Unit + !************************************************* + ! + + INTEGER FUNCTION Agrif_Get_Unit() + ! + INTEGER n + LOGICAL op + INTEGER :: nunit + INTEGER :: iii,out,iiimax + ! + DO n = 7,1000 + ! + INQUIRE(Unit=n,Opened=op) + ! + IF (.NOT.op) EXIT + ! + ENDDO + ! + Agrif_Get_Unit=n + ! + ! + END FUNCTION Agrif_Get_Unit + ! +END MODULE agrif_types diff --git a/V4.0/nemo_sources/tools/NESTING/src/bicubic_interp.f90 b/V4.0/nemo_sources/tools/NESTING/src/bicubic_interp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b98bd6fc1a5806432e7ae85ff0a6728a494c7a80 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/bicubic_interp.f90 @@ -0,0 +1,1091 @@ +! +MODULE bicubic_interp + ! + USE agrif_modutil + ! + !************************************************************************ + ! * + ! MODULE BICUBIC INTERP * + ! * + ! bicubic interpolation routines from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + ! * + !Bicubic remapping * + ! * + !************************************************************************ + ! + IMPLICIT NONE + ! + INTEGER :: grid1_size,grid2_size,grid1_rank, grid2_rank + INTEGER, DIMENSION(:), POINTER :: grid1_dims, grid2_dims + LOGICAL, DIMENSION(:), POINTER :: grid1_mask,grid2_mask + REAL*8,DIMENSION(:),POINTER :: & + grid1_center_lat, & + grid1_center_lon, & + grid2_center_lat, & + grid2_center_lon, & + grid1_frac, & + grid2_frac + REAL*8,DIMENSION(:,:), POINTER :: grid1_bound_box,grid2_bound_box + INTEGER, PARAMETER :: num_srch_bins = 90 + INTEGER,DIMENSION(:,:),POINTER :: bin_addr1,bin_addr2 + REAL*8, DIMENSION(:,:),POINTER :: bin_lats,bin_lons + REAL*8, PARAMETER :: zero = 0.0, & + one = 1.0, & + two = 2.0, & + three = 3.0, & + four = 4.0, & + five = 5.0, & + half = 0.5, & + quart = 0.25, & + bignum = 1.e+20, & + tiny = 1.e-14, & + pi = 3.14159265359, & + pi2 = two*pi, & + pih = half*pi + + REAL*8, PARAMETER :: deg2rad = pi/180. + INTEGER , PARAMETER :: max_iter = 100 + REAL*8, PARAMETER :: converge = 1.e-10 + INTEGER, PARAMETER :: norm_opt_none = 1 & + ,norm_opt_dstarea = 2 & + ,norm_opt_frcarea = 3 + ! + INTEGER, PARAMETER :: map_type_conserv = 1 & + ,map_type_bilinear = 2 & + ,map_type_bicubic = 3 & + ,map_type_distwgt = 4 + ! + INTEGER :: max_links_map1 & ! current size of link arrays + ,num_links_map1 & ! actual number of links for remapping + ,max_links_map2 & ! current size of link arrays + ,num_links_map2 & ! actual number of links for remapping + ,num_maps & ! num of remappings for this grid pair + ,num_wts & ! num of weights used in remapping + ,map_type & ! identifier for remapping method + ,norm_opt & ! option for normalization (conserv only) + ,resize_increment ! default amount to increase array size + + INTEGER , DIMENSION(:), POINTER :: & + bicubic_grid1_add_map1, & ! grid1 address for each link in mapping 1 + bicubic_grid2_add_map1, & ! grid2 address for each link in mapping 1 + grid1_add_map2, & ! grid1 address for each link in mapping 2 + grid2_add_map2 ! grid2 address for each link in mapping 2 + + REAL*8, DIMENSION(:,:), POINTER :: & + bicubic_wts_map1, & ! map weights for each link (num_wts,max_links) + wts_map2 => NULL() ! map weights for each link (num_wts,max_links) + + + + + + +CONTAINS + + + + + + + + !*********************************************************************** + SUBROUTINE get_remap_bicub(grid1_lat,grid2_lat,grid1_lon,grid2_lon,mask, & + remap_matrix,source_add,destination_add) + + !----------------------------------------------------------------------- + ! + ! this routine computes the weights for a bicubic interpolation. + ! + !----------------------------------------------------------------------- + REAL*8,DIMENSION(:,:),POINTER :: grid1_lat,grid2_lat,grid1_lon,grid2_lon + LOGICAL,DIMENSION(:,:) :: mask + ! + INTEGER,DIMENSION(:),POINTER :: source_add,destination_add + REAL*8,DIMENSION(:,:),POINTER :: remap_matrix + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + INTEGER :: n,icount,dst_add,iter,nx,ny,i,j,ip1,e_add,jp1,n_add,ne_add,nele + REAL*8, DIMENSION(4) :: tmp_lats, tmp_lons + INTEGER, DIMENSION(4) :: src_add + + REAL*8, DIMENSION(4) :: src_lats,src_lons + INTEGER lastsrc_add + REAL*8, DIMENSION(4,4) :: wgts + REAL*8 :: dlat,dlon + REAL*8 :: plat, plon,iguess, jguess,thguess, phguess,deli, delj, & + dth1, dth2, dth3,dph1, dph2, dph3,dthp, dphp, & + mat1, mat2, mat3, mat4,determinant,sum_wgts, & + w1,w2,w3,w4,w5,w6,w7,w8,w9,w10,w11,w12,w13,w14,w15,w16 + + + !----------------------------------------------------------------------- + ! + ! compute mappings from grid1 to grid2 + ! + !----------------------------------------------------------------------- + ! + ALLOCATE(grid1_dims(2),grid2_dims(2)) + grid1_dims(1) = SIZE(grid1_lat,2) + grid1_dims(2) = SIZE(grid1_lat,1) + grid2_dims(1) = SIZE(grid2_lat,2) + grid2_dims(2) = SIZE(grid2_lat,1) + grid1_size = SIZE(grid1_lat,2) * SIZE(grid1_lat,1) + grid2_size = SIZE(grid2_lat,2) * SIZE(grid2_lat,1) + ! + ALLOCATE( grid2_mask(grid2_size), & + grid1_bound_box (4,grid1_size), & + grid2_bound_box (4,grid2_size), & + grid1_frac (grid1_size), & + grid2_frac (grid2_size)) + + grid1_frac = zero + grid2_frac = zero + + ! + ! 2D array -> 1D array + ! + ALLOCATE(grid1_center_lat(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL tab2Dto1D(grid1_lat,grid1_center_lat) + + ALLOCATE(grid1_center_lon(SIZE(grid1_lon,1)*SIZE(grid1_lon,2))) + CALL tab2Dto1D(grid1_lon,grid1_center_lon) + + ALLOCATE(grid2_center_lat(SIZE(grid2_lat,1)*SIZE(grid2_lat,2))) + CALL tab2Dto1D(grid2_lat,grid2_center_lat) + + ALLOCATE(grid2_center_lon(SIZE(grid2_lon,1)*SIZE(grid2_lon,2))) + CALL tab2Dto1D(grid2_lon,grid2_center_lon) + + ALLOCATE(grid1_mask(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL logtab2Dto1D(mask,grid1_mask) + ! + ! Write(*,*) ,'grid1_mask = ',grid1_mask + ! + ! + ! degrees to radian + ! + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + + !----------------------------------------------------------------------- + ! convert longitudes to 0,2pi interval + !----------------------------------------------------------------------- + + WHERE (grid1_center_lon .GT. pi2) grid1_center_lon = & + grid1_center_lon - pi2 + WHERE (grid1_center_lon .LT. zero) grid1_center_lon = & + grid1_center_lon + pi2 + WHERE (grid2_center_lon .GT. pi2) grid2_center_lon = & + grid2_center_lon - pi2 + WHERE (grid2_center_lon .LT. zero) grid2_center_lon = & + grid2_center_lon + pi2 + + !----------------------------------------------------------------------- + ! + ! make sure input latitude range is within the machine values + ! for +/- pi/2 + ! + !----------------------------------------------------------------------- + + WHERE (grid1_center_lat > pih) grid1_center_lat = pih + WHERE (grid1_center_lat < -pih) grid1_center_lat = -pih + WHERE (grid2_center_lat > pih) grid2_center_lat = pih + WHERE (grid2_center_lat < -pih) grid2_center_lat = -pih + ! + + ! + !----------------------------------------------------------------------- + ! + ! compute bounding boxes for restricting future grid searches + ! + !----------------------------------------------------------------------- + ! + nx = grid1_dims(1) + ny = grid1_dims(2) + + DO n=1,grid1_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid1_center_lat(e_add) - & + grid1_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ip1=nx + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid1_center_lat(n_add) - & + grid1_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + jp1=ny + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid1_center_lat(n) + tmp_lats(2) = grid1_center_lat(e_add) + tmp_lats(3) = grid1_center_lat(ne_add) + tmp_lats(4) = grid1_center_lat(n_add) + + tmp_lons(1) = grid1_center_lon(n) + tmp_lons(2) = grid1_center_lon(e_add) + tmp_lons(3) = grid1_center_lon(ne_add) + tmp_lons(4) = grid1_center_lon(n_add) + + grid1_bound_box(1,n) = MINVAL(tmp_lats) + grid1_bound_box(2,n) = MAXVAL(tmp_lats) + + grid1_bound_box(3,n) = MINVAL(tmp_lons) + grid1_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + + nx = grid2_dims(1) + ny = grid2_dims(2) + + DO n=1,grid2_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid2_center_lat(e_add) - & + grid2_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid2_center_lat(n_add) - & + grid2_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid2_center_lat(n) + tmp_lats(2) = grid2_center_lat(e_add) + tmp_lats(3) = grid2_center_lat(ne_add) + tmp_lats(4) = grid2_center_lat(n_add) + + tmp_lons(1) = grid2_center_lon(n) + tmp_lons(2) = grid2_center_lon(e_add) + tmp_lons(3) = grid2_center_lon(ne_add) + tmp_lons(4) = grid2_center_lon(n_add) + + grid2_bound_box(1,n) = MINVAL(tmp_lats) + grid2_bound_box(2,n) = MAXVAL(tmp_lats) + grid2_bound_box(3,n) = MINVAL(tmp_lons) + grid2_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + ! + ! + ! + WHERE (ABS(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) + grid1_bound_box(3,:) = zero + grid1_bound_box(4,:) = pi2 + END WHERE + + WHERE (ABS(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) + grid2_bound_box(3,:) = zero + grid2_bound_box(4,:) = pi2 + END WHERE + + !*** + !*** try to check for cells that overlap poles + !*** + + WHERE (grid1_center_lat > grid1_bound_box(2,:)) & + grid1_bound_box(2,:) = pih + + WHERE (grid1_center_lat < grid1_bound_box(1,:)) & + grid1_bound_box(1,:) = -pih + + WHERE (grid2_center_lat > grid2_bound_box(2,:)) & + grid2_bound_box(2,:) = pih + + WHERE (grid2_center_lat < grid2_bound_box(1,:)) & + grid2_bound_box(1,:) = -pih + + !----------------------------------------------------------------------- + ! set up and assign address ranges to search bins in order to + ! further restrict later searches + !----------------------------------------------------------------------- + + ALLOCATE(bin_addr1(2,num_srch_bins)) + ALLOCATE(bin_addr2(2,num_srch_bins)) + ALLOCATE(bin_lats (2,num_srch_bins)) + ALLOCATE(bin_lons (2,num_srch_bins)) + + dlat = pi/num_srch_bins + + DO n=1,num_srch_bins + bin_lats(1,n) = (n-1)*dlat - pih + bin_lats(2,n) = n*dlat - pih + bin_lons(1,n) = zero + bin_lons(2,n) = pi2 + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + END DO + + DO nele=1,grid1_size + DO n=1,num_srch_bins + IF (grid1_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid1_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr1(1,n) = MIN(nele,bin_addr1(1,n)) + bin_addr1(2,n) = MAX(nele,bin_addr1(2,n)) + ENDIF + END DO + END DO + + DO nele=1,grid2_size + DO n=1,num_srch_bins + IF (grid2_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid2_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr2(1,n) = MIN(nele,bin_addr2(1,n)) + bin_addr2(2,n) = MAX(nele,bin_addr2(2,n)) + ENDIF + END DO + END DO + + CALL init_remap_vars + ! + !*** + !*** loop over destination grid + !*** + ! + grid2_mask = .TRUE. + ! + lastsrc_add=1 + ! + WRITE(*,*) 'Bicubic remapping weights computation' + ! + DO dst_add = 1, grid2_size + + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + ! + ! + CALL grid_search_bicub(src_add, src_lats, src_lons, & + plat, plon, grid1_dims, & + grid1_center_lat, grid1_center_lon, & + grid1_bound_box, bin_addr1, bin_addr2,lastsrc_add) + ! + ! + IF (src_add(1) > 0) THEN + DO n=1,4 + IF (.NOT. grid1_mask(src_add(n))) src_add(1) = 0 + END DO + ENDIF + + !----------------------------------------------------------------------- + ! + ! if point found, find local i,j coordinates for weights + ! + !----------------------------------------------------------------------- + + IF (src_add(1) > 0) THEN + + grid2_frac(dst_add) = one + ! + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + IF (dph1 > three*pih) dph1 = dph1 - pi2 + IF (dph2 > three*pih) dph2 = dph2 - pi2 + IF (dph3 > three*pih) dph3 = dph3 - pi2 + IF (dph1 < -three*pih) dph1 = dph1 + pi2 + IF (dph2 < -three*pih) dph2 = dph2 + pi2 + IF (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + iguess = half + jguess = half + + DO iter=1,max_iter + + dthp = plat-src_lats(1)-dth1*iguess- & + dth2*jguess-dth3*iguess*jguess + dphp = plon - src_lons(1) + + IF (dphp > three*pih) dphp = dphp - pi2 + IF (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + ! + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + ! + determinant = mat1*mat4 - mat2*mat3 + ! + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + ! + IF (ABS(deli) < converge .AND. & + ABS(delj) < converge) EXIT + ! + iguess = iguess + deli + jguess = jguess + delj + + END DO + + IF (iter <= max_iter) THEN + ! + wgts(1,1) = (one - jguess**2*(three-two*jguess))* & + (one - iguess**2*(three-two*iguess)) + + wgts(1,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(three-two*iguess) + + wgts(1,3) = jguess**2*(three-two*jguess)* & + iguess**2*(three-two*iguess) + + wgts(1,4) = jguess**2*(three-two*jguess)* & + (one - iguess**2*(three-two*iguess)) + + wgts(2,1) = (one - jguess**2*(three-two*jguess))* & + iguess*(iguess-one)**2 + + wgts(2,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(iguess-one) + + wgts(2,3) = jguess**2*(three-two*jguess)* & + iguess**2*(iguess-one) + + wgts(2,4) = jguess**2*(three-two*jguess)* & + iguess*(iguess-one)**2 + + wgts(3,1) = jguess*(jguess-one)**2* & + (one - iguess**2*(three-two*iguess)) + + wgts(3,2) = jguess*(jguess-one)**2* & + iguess**2*(three-two*iguess) + + wgts(3,3) = jguess**2*(jguess-one)* & + iguess**2*(three-two*iguess) + + wgts(3,4) = jguess**2*(jguess-one)* & + (one - iguess**2*(three-two*iguess)) + + wgts(4,1) = iguess*(iguess-one)**2* & + jguess*(jguess-one)**2 + + wgts(4,2) = iguess**2*(iguess-one)* & + jguess*(jguess-one)**2 + + wgts(4,3) = iguess**2*(iguess-one)* & + jguess**2*(jguess-one) + + wgts(4,4) = iguess*(iguess-one)**2* & + jguess**2*(jguess-one) + + CALL store_link_bicub(dst_add, src_add, wgts) + + ELSE + STOP 'Iteration for i,j exceed max iteration count' + ENDIF + ! + ELSE IF (src_add(1) < 0) THEN + + src_add = ABS(src_add) + ! + icount = 0 + ! + DO n=1,4 + IF (grid1_mask(src_add(n))) THEN + icount = icount + 1 + ELSE + src_lats(n) = zero + ENDIF + END DO + + IF (icount > 0) THEN + + sum_wgts = SUM(src_lats) + wgts(1,1) = src_lats(1)/sum_wgts + wgts(1,2) = src_lats(2)/sum_wgts + wgts(1,3) = src_lats(3)/sum_wgts + wgts(1,4) = src_lats(4)/sum_wgts + wgts(2:4,:) = zero + + CALL store_link_bicub(dst_add, src_add, wgts) + + ENDIF + + ENDIF + ! + END DO + ! + ALLOCATE(remap_matrix(SIZE(bicubic_wts_map1,1),SIZE(bicubic_wts_map1,2)), & + source_add(num_links_map1), & + destination_add(num_links_map1)) + + DO j = 1,SIZE(bicubic_wts_map1,2) + DO i = 1,SIZE(bicubic_wts_map1,1) + + remap_matrix(i,j) = bicubic_wts_map1(i,j) + + END DO + END DO + ! + source_add(:) = bicubic_grid1_add_map1(1:num_links_map1) + destination_add(:) = bicubic_grid2_add_map1(1:num_links_map1) + ! + ! + WHERE(destination_add == 0) + destination_add = 1 + END WHERE + + WHERE(source_add == 0) + source_add = 1 + END WHERE + ! + DEALLOCATE(grid1_bound_box,grid2_bound_box,grid1_center_lat,grid1_center_lon) + DEALLOCATE(grid2_center_lat,grid2_center_lon,bicubic_grid1_add_map1,bicubic_wts_map1) + DEALLOCATE(grid1_frac,grid2_frac,grid1_dims,grid2_dims,grid2_mask) + DEALLOCATE(bin_addr1,bin_addr2,bin_lats,bin_lons) + DEALLOCATE(grid1_mask,bicubic_grid2_add_map1) + ! + !----------------------------------------------------------------------- + + END SUBROUTINE get_remap_bicub + + ! + !*********************************************************************** + + !*********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE GRID_SEARCH_BILIN + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE grid_search_bicub(src_add, src_lats, src_lons, & + plat, plon, src_grid_dims, & + src_center_lat, src_center_lon, & + src_grid_bound_box, & + src_bin_add, dst_bin_add,lastsrc_add) + + !----------------------------------------------------------------------- + ! + ! this routine finds the location of the search point plat, plon + ! in the source grid and returns the corners needed for a bilinear + ! interpolation. + ! + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------------- + ! + ! address of each corner point enclosing P + ! + INTEGER,DIMENSION(4) :: src_add + REAL*8,DIMENSION(4) :: src_lats,src_lons + ! + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + ! + ! latitude, longitude of the search point + ! + REAL*8, INTENT(in) :: plat,plon + ! + ! size of each src grid dimension + ! + INTEGER, DIMENSION(2), INTENT(in) :: src_grid_dims + ! + ! latitude, longitude of each src grid center + ! + REAL*8, DIMENSION(:), INTENT(in) :: src_center_lat,src_center_lon + ! + ! bound box for source grid + ! + REAL*8, DIMENSION(:,:), INTENT(in) :: src_grid_bound_box + ! + ! latitude bins for restricting searches + ! + INTEGER, DIMENSION(:,:), INTENT(in) ::src_bin_add,dst_bin_add + + INTEGER,OPTIONAL :: lastsrc_add + INTEGER :: loopsrc,l1,l2 + ! + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + ! + INTEGER :: n,next_n,srch_add,nx, ny,min_add, max_add, & + i, j, jp1, ip1, n_add, e_add, ne_add + + + REAL*8 :: vec1_lat, vec1_lon,vec2_lat, vec2_lon, cross_product, & + cross_product_last,coslat_dst, sinlat_dst, coslon_dst, & + sinlon_dst,dist_min, distance + + !----------------------------------------------------------------------- + ! restrict search first using bins + !----------------------------------------------------------------------- + + src_add = 0 + min_add = SIZE(src_center_lat) + max_add = 1 + DO n=1,num_srch_bins + IF (plat >= bin_lats(1,n) .AND. plat <= bin_lats(2,n) .AND. & + plon >= bin_lons(1,n) .AND. plon <= bin_lons(2,n)) THEN + min_add = MIN(min_add, src_bin_add(1,n)) + max_add = MAX(max_add, src_bin_add(2,n)) + ENDIF + END DO + + !----------------------------------------------------------------------- + ! now perform a more detailed search + !----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + loopsrc=0 + DO WHILE (loopsrc <= max_add) + + + l1=MAX(min_add,lastsrc_add-loopsrc) + l2=MIN(max_add,lastsrc_add+loopsrc) + + loopsrc = loopsrc+1 + + srch_loop: DO srch_add = l1,l2,MAX(l2-l1,1) + + !*** first check bounding box + + IF (plat <= src_grid_bound_box(2,srch_add) .AND. & + plat >= src_grid_bound_box(1,srch_add) .AND. & + plon <= src_grid_bound_box(4,srch_add) .AND. & + plon >= src_grid_bound_box(3,srch_add)) THEN + + + !*** + !*** we are within bounding box so get really serious + !*** + !*** determine neighbor addresses + ! + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + ! + IF (i < nx) THEN + ip1 = i + 1 + ELSE + ip1 = 1 + ENDIF + ! + IF (j < ny) THEN + jp1 = j+1 + ELSE + jp1 = 1 + ENDIF + ! + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + ! + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + ! + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + ! + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + ! + vec1_lon = src_lons(1) - plon + IF (vec1_lon > pi) THEN + src_lons(1) = src_lons(1) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(1) = src_lons(1) + pi2 + ENDIF + DO n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + IF (vec1_lon > pi) THEN + src_lons(n) = src_lons(n) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(n) = src_lons(n) + pi2 + ENDIF + END DO + ! + corner_loop: DO n=1,4 + next_n = MOD(n,4) + 1 + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the box. + !*** + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + !*** + !*** check for 0,2pi crossings + !*** + IF (vec1_lon > three*pih) THEN + vec1_lon = vec1_lon - pi2 + ELSE IF (vec1_lon < -three*pih) THEN + vec1_lon = vec1_lon + pi2 + ENDIF + IF (vec2_lon > three*pih) THEN + vec2_lon = vec2_lon - pi2 + ELSE IF (vec2_lon < -three*pih) THEN + vec2_lon = vec2_lon + pi2 + ENDIF + ! + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + ! + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + IF (n == 1) cross_product_last = cross_product + IF (cross_product*cross_product_last < zero) & + EXIT corner_loop + cross_product_last = cross_product + ! + END DO corner_loop + !*** + !*** if cross products all same sign, we found the location + !*** + IF (n > 4) THEN + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + ! + lastsrc_add = srch_add + RETURN + ENDIF + !*** + !*** otherwise move on to next cell + !*** + ENDIF !bounding box check + END DO srch_loop + + + ENDDO + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + !print *,'Could not find location for ',plat,plon + !print *,'Using nearest-neighbor average for this point' + ! + coslat_dst = COS(plat) + sinlat_dst = SIN(plat) + coslon_dst = COS(plon) + sinlon_dst = SIN(plon) + ! + dist_min = bignum + src_lats = bignum + DO srch_add = min_add,max_add + distance = ACOS(coslat_dst*COS(src_center_lat(srch_add))* & + (coslon_dst*COS(src_center_lon(srch_add)) + & + sinlon_dst*SIN(src_center_lon(srch_add)))+ & + sinlat_dst*SIN(src_center_lat(srch_add))) + + IF (distance < dist_min) THEN + sort_loop: DO n=1,4 + IF (distance < src_lats(n)) THEN + DO i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + END DO + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + EXIT sort_loop + ENDIF + END DO sort_loop + ENDIF + END DO + ! + src_lons = one/(src_lats + tiny) + distance = SUM(src_lons) + src_lats = src_lons/distance + + !----------------------------------------------------------------------- + + END SUBROUTINE grid_search_bicub + + + + + + + + + + + + + + !----------------------------------------------------------------------- + + SUBROUTINE store_link_bicub(dst_add, src_add, weights) + + !----------------------------------------------------------------------- + ! + ! this routine stores the address and weight for four links + ! associated with one destination point in the appropriate address + ! and weight arrays and resizes those arrays if necessary. + ! + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------------- + + INTEGER :: dst_add + INTEGER, DIMENSION(4) :: src_add + REAL*8, DIMENSION(4,4) :: weights + + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + INTEGER :: n,num_links_old + + !----------------------------------------------------------------------- + ! + ! increment number of links and check to see if remap arrays need + ! to be increased to accomodate the new link. then store the + ! link. + ! + !----------------------------------------------------------------------- + + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + IF (num_links_map1 > max_links_map1) & + CALL resize_remap_vars(resize_increment) + + DO n=1,4 + bicubic_grid1_add_map1(num_links_old+n) = src_add(n) + bicubic_grid2_add_map1(num_links_old+n) = dst_add + bicubic_wts_map1 (:,num_links_old+n) = weights(:,n) + END DO + + + + + + !----------------------------------------------------------------------- + + END SUBROUTINE store_link_bicub + + !*********************************************************************** + + + + + + + + + + + + + + + ! + !************************************************************************ + ! SUBROUTINE INIT_REMAP_VAR + !************************************************************************ + ! + SUBROUTINE init_remap_vars + ! + num_wts = 4 + ! + num_links_map1 = 0 + max_links_map1 = 4*grid2_size + IF (num_maps > 1) THEN + num_links_map2 = 0 + max_links_map1 = MAX(4*grid1_size,4*grid2_size) + max_links_map2 = max_links_map1 + ENDIF + + resize_increment = 0.1*MAX(grid1_size,grid2_size) + ! + !----------------------------------------------------------------------- + ! + ! allocate address and weight arrays for mapping 1 + ! + !----------------------------------------------------------------------- + ! + ALLOCATE (bicubic_grid1_add_map1(max_links_map1), & + bicubic_grid2_add_map1(max_links_map1), & + bicubic_wts_map1(num_wts, max_links_map1)) + + !----------------------------------------------------------------------- + ! + ! allocate address and weight arrays for mapping 2 if necessary + ! + !----------------------------------------------------------------------- + + IF (num_maps > 1) THEN + ALLOCATE (grid1_add_map2(max_links_map2), & + grid2_add_map2(max_links_map2), & + wts_map2(num_wts, max_links_map2)) + ENDIF + + !----------------------------------------------------------------------- + + END SUBROUTINE init_remap_vars + + !*********************************************************************** + !************************************************************************ + ! SUBROUTINE RESIZE_REMAP_VAR + !************************************************************************ + + SUBROUTINE resize_remap_vars(increment) + + !----------------------------------------------------------------------- + ! this routine resizes remapping arrays by increasing(decreasing) + ! the max_links by increment + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + + INTEGER :: increment + + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + + INTEGER :: & + ierr, & ! error flag + mxlinks ! size of link arrays + + INTEGER, DIMENSION(:), POINTER :: & + add1_tmp, & ! temp array for resizing address arrays + add2_tmp ! temp array for resizing address arrays + ! + ! temp array for resizing weight arrays + ! + REAL*8, DIMENSION(:,:), POINTER :: wts_tmp + ! + !----------------------------------------------------------------------- + !*** + !*** allocate temporaries to hold original values + !*** + mxlinks = SIZE(bicubic_grid1_add_map1) + ALLOCATE (add1_tmp(mxlinks), add2_tmp(mxlinks), & + wts_tmp(num_wts,mxlinks)) + + add1_tmp = bicubic_grid1_add_map1 + add2_tmp = bicubic_grid2_add_map1 + wts_tmp = bicubic_wts_map1 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + DEALLOCATE (bicubic_grid1_add_map1, bicubic_grid2_add_map1, bicubic_wts_map1) + max_links_map1 = mxlinks + increment + ALLOCATE (bicubic_grid1_add_map1(max_links_map1), & + bicubic_grid2_add_map1(max_links_map1), & + bicubic_wts_map1(num_wts,max_links_map1)) + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + mxlinks = MIN(mxlinks, max_links_map1) + bicubic_grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks) + bicubic_grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks) + bicubic_wts_map1 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + DEALLOCATE(add1_tmp, add2_tmp, wts_tmp) + + !----------------------------------------------------------------------- + ! + END SUBROUTINE resize_remap_vars + ! + !************************************************************************ + ! + +END MODULE bicubic_interp + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/NESTING/src/bilinear_interp.f90 b/V4.0/nemo_sources/tools/NESTING/src/bilinear_interp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..695a700bc009d3990ec8e0a778b5b9eec05ac584 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/bilinear_interp.f90 @@ -0,0 +1,1207 @@ +! +MODULE bilinear_interp + ! + USE agrif_modutil + ! + !************************************************************************ + ! * + ! MODULE BILINEAR INTERP * + ! * + ! bilinear interpolation routines from SCRIP package * + ! * + !http://climate.lanl.gov/Software/SCRIP/ * + ! * + !Bilinear remapping * + ! * + !************************************************************************ + ! + !----------------------------------------------------------------------- + IMPLICIT NONE + + !----------------------------------------------------------------------- + ! variables that describe each grid + !----------------------------------------------------------------------- + ! + INTEGER :: grid1_size,grid2_size,grid1_rank, grid2_rank + ! + INTEGER, DIMENSION(:), POINTER :: grid1_dims, grid2_dims + ! + + !----------------------------------------------------------------------- + ! grid coordinates and masks + !----------------------------------------------------------------------- + ! + LOGICAL, DIMENSION(:), POINTER :: grid1_mask,grid2_mask + ! each grid center in radians + REAL*8,DIMENSION(:),POINTER :: & + grid1_center_lat, & + grid1_center_lon, & + grid2_center_lat, & + grid2_center_lon, & + grid1_frac, & ! fractional area of grid cells + grid2_frac ! participating in remapping + ! + ! lat/lon bounding box for use in restricting grid searches + ! + REAL*8,DIMENSION(:,:), POINTER :: grid1_bound_box,grid2_bound_box + ! + !----------------------------------------------------------------------- + ! bins for restricting searches + !----------------------------------------------------------------------- + ! + ! num of bins for restricted srch + INTEGER, PARAMETER :: num_srch_bins = 90 + ! + ! min,max adds for grid cells in this lat bin + ! + INTEGER,DIMENSION(:,:),POINTER :: bin_addr1,bin_addr2 + ! + ! min,max longitude for each search bin + ! + REAL*8, DIMENSION(:,:),POINTER :: bin_lats,bin_lons + + REAL*8, PARAMETER :: zero = 0.0, & + one = 1.0, & + two = 2.0, & + three = 3.0, & + four = 4.0, & + five = 5.0, & + half = 0.5, & + quart = 0.25, & + bignum = 1.e+20, & + tiny = 1.e-14, & + pi = 3.14159265359, & + pi2 = two*pi, & + pih = half*pi + + REAL*8, PARAMETER :: deg2rad = pi/180. + ! + ! max iteration count for i,j iteration + ! + INTEGER , PARAMETER :: max_iter = 100 + ! + ! convergence criterion + ! + REAL*8, PARAMETER :: converge = 1.e-10 + + + ! + INTEGER, PARAMETER :: norm_opt_none = 1 & + ,norm_opt_dstarea = 2 & + ,norm_opt_frcarea = 3 + ! + INTEGER, PARAMETER :: map_type_conserv = 1 & + ,map_type_bilinear = 2 & + ,map_type_bicubic = 3 & + ,map_type_distwgt = 4 + ! + INTEGER :: max_links_map1 & ! current size of link arrays + ,num_links_map1 & ! actual number of links for remapping + ,max_links_map2 & ! current size of link arrays + ,num_links_map2 & ! actual number of links for remapping + ,num_maps & ! num of remappings for this grid pair + ,num_wts & ! num of weights used in remapping + ,map_type & ! identifier for remapping method + ,norm_opt & ! option for normalization (conserv only) + ,resize_increment ! default amount to increase array size + + INTEGER , DIMENSION(:), POINTER :: & + grid1_add_map1, & ! grid1 address for each link in mapping 1 + grid2_add_map1, & ! grid2 address for each link in mapping 1 + grid1_add_map2, & ! grid1 address for each link in mapping 2 + grid2_add_map2 ! grid2 address for each link in mapping 2 + + REAL*8, DIMENSION(:,:), POINTER :: & + wts_map1, & ! map weights for each link (num_wts,max_links) + wts_map2 ! map weights for each link (num_wts,max_links) + ! +CONTAINS + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE GRID_INIT + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE get_remap_matrix(grid1_lat,grid2_lat,grid1_lon,grid2_lon,mask, & + remap_matrix,source_add,destination_add) + ! + !----------------------------------------------------------------------- + !this routine makes any necessary changes (e.g. for 0,2pi longitude range) + !----------------------------------------------------------------------- + ! + REAL*8,DIMENSION(:,:),POINTER :: grid1_lat,grid2_lat,grid1_lon,grid2_lon + LOGICAL,DIMENSION(:,:) :: mask + ! + INTEGER,DIMENSION(:),POINTER :: source_add,destination_add + REAL*8,DIMENSION(:,:),POINTER :: remap_matrix + ! + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + ! + INTEGER :: n,nele,i,j,ip1,jp1,n_add,e_add,ne_add,nx,ny + INTEGER :: xpos,ypos + ! + ! integer mask + ! + INTEGER, DIMENSION(:), POINTER :: imask + ! + ! lat/lon intervals for search bins + ! + REAL*8 :: dlat,dlon + ! + ! temps for computing bounding boxes + ! + REAL*8, DIMENSION(4) :: tmp_lats, tmp_lons + ! + ! write(*,*)'proceed to Bilinear interpolation ...' + ! + IF(ASSOCIATED(wts_map1)) DEALLOCATE(wts_map1) + IF(ASSOCIATED(grid1_add_map1)) DEALLOCATE(grid1_add_map1) + IF(ASSOCIATED(grid2_add_map1)) DEALLOCATE(grid2_add_map1) + + + ! + ALLOCATE(grid1_dims(2),grid2_dims(2)) + ! + grid1_dims(1) = SIZE(grid1_lat,2) + grid1_dims(2) = SIZE(grid1_lat,1) + grid2_dims(1) = SIZE(grid2_lat,2) + grid2_dims(2) = SIZE(grid2_lat,1) + grid1_size = SIZE(grid1_lat,2) * SIZE(grid1_lat,1) + grid2_size = SIZE(grid2_lat,2) * SIZE(grid2_lat,1) + ! + !----------------------------------------------------------------------- + ! allocate grid coordinates/masks and read data + !----------------------------------------------------------------------- + ! + ALLOCATE( grid2_mask(grid2_size), & + grid1_bound_box (4,grid1_size), & + grid2_bound_box (4,grid2_size), & + grid1_frac (grid1_size), & + grid2_frac (grid2_size)) + ALLOCATE(imask(grid1_size)) + ! + ! + grid1_frac = zero + grid2_frac = zero + + ! + ! 2D array -> 1D array + ! + ALLOCATE(grid1_center_lat(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL tab2Dto1D(grid1_lat,grid1_center_lat) + + ALLOCATE(grid1_center_lon(SIZE(grid1_lon,1)*SIZE(grid1_lon,2))) + CALL tab2Dto1D(grid1_lon,grid1_center_lon) + + ALLOCATE(grid2_center_lat(SIZE(grid2_lat,1)*SIZE(grid2_lat,2))) + CALL tab2Dto1D(grid2_lat,grid2_center_lat) + + ALLOCATE(grid2_center_lon(SIZE(grid2_lon,1)*SIZE(grid2_lon,2))) + CALL tab2Dto1D(grid2_lon,grid2_center_lon) + + ALLOCATE(grid1_mask(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) + CALL logtab2Dto1D(mask,grid1_mask) + ! + ! Write(*,*) ,'grid1_mask = ',grid1_mask + ! + ! degrees to radian + ! + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + + !----------------------------------------------------------------------- + ! convert longitudes to 0,2pi interval + !----------------------------------------------------------------------- + + WHERE (grid1_center_lon .GT. pi2) grid1_center_lon = & + grid1_center_lon - pi2 + WHERE (grid1_center_lon .LT. zero) grid1_center_lon = & + grid1_center_lon + pi2 + WHERE (grid2_center_lon .GT. pi2) grid2_center_lon = & + grid2_center_lon - pi2 + WHERE (grid2_center_lon .LT. zero) grid2_center_lon = & + grid2_center_lon + pi2 + + !----------------------------------------------------------------------- + ! + ! make sure input latitude range is within the machine values + ! for +/- pi/2 + ! + !----------------------------------------------------------------------- + + WHERE (grid1_center_lat > pih) grid1_center_lat = pih + WHERE (grid1_center_lat < -pih) grid1_center_lat = -pih + WHERE (grid2_center_lat > pih) grid2_center_lat = pih + WHERE (grid2_center_lat < -pih) grid2_center_lat = -pih + + !----------------------------------------------------------------------- + ! + ! compute bounding boxes for restricting future grid searches + ! + !----------------------------------------------------------------------- + ! + nx = grid1_dims(1) + ny = grid1_dims(2) + + DO n=1,grid1_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid1_center_lat(e_add) - & + grid1_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ip1=nx + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid1_center_lat(n_add) - & + grid1_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + jp1=ny + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid1_center_lat(n) + tmp_lats(2) = grid1_center_lat(e_add) + tmp_lats(3) = grid1_center_lat(ne_add) + tmp_lats(4) = grid1_center_lat(n_add) + + tmp_lons(1) = grid1_center_lon(n) + tmp_lons(2) = grid1_center_lon(e_add) + tmp_lons(3) = grid1_center_lon(ne_add) + tmp_lons(4) = grid1_center_lon(n_add) + + grid1_bound_box(1,n) = MINVAL(tmp_lats) + grid1_bound_box(2,n) = MAXVAL(tmp_lats) + + grid1_bound_box(3,n) = MINVAL(tmp_lons) + grid1_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + + nx = grid2_dims(1) + ny = grid2_dims(2) + + DO n=1,grid2_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + IF (i < nx) THEN + ip1 = i + 1 + ELSE + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + IF (ABS(grid2_center_lat(e_add) - & + grid2_center_lat(n )) > pih) THEN + ip1 = i + ENDIF + ENDIF + + IF (j < ny) THEN + jp1 = j+1 + ELSE + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + IF (ABS(grid2_center_lat(n_add) - & + grid2_center_lat(n )) > pih) THEN + jp1 = j + ENDIF + ENDIF + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid2_center_lat(n) + tmp_lats(2) = grid2_center_lat(e_add) + tmp_lats(3) = grid2_center_lat(ne_add) + tmp_lats(4) = grid2_center_lat(n_add) + + tmp_lons(1) = grid2_center_lon(n) + tmp_lons(2) = grid2_center_lon(e_add) + tmp_lons(3) = grid2_center_lon(ne_add) + tmp_lons(4) = grid2_center_lon(n_add) + + grid2_bound_box(1,n) = MINVAL(tmp_lats) + grid2_bound_box(2,n) = MAXVAL(tmp_lats) + grid2_bound_box(3,n) = MINVAL(tmp_lons) + grid2_bound_box(4,n) = MAXVAL(tmp_lons) + END DO + ! + ! + ! + WHERE (ABS(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) + grid1_bound_box(3,:) = zero + grid1_bound_box(4,:) = pi2 + END WHERE + + WHERE (ABS(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) + grid2_bound_box(3,:) = zero + grid2_bound_box(4,:) = pi2 + END WHERE + + !*** + !*** try to check for cells that overlap poles + !*** + + WHERE (grid1_center_lat > grid1_bound_box(2,:)) & + grid1_bound_box(2,:) = pih + + WHERE (grid1_center_lat < grid1_bound_box(1,:)) & + grid1_bound_box(1,:) = -pih + + WHERE (grid2_center_lat > grid2_bound_box(2,:)) & + grid2_bound_box(2,:) = pih + + WHERE (grid2_center_lat < grid2_bound_box(1,:)) & + grid2_bound_box(1,:) = -pih + + !----------------------------------------------------------------------- + ! set up and assign address ranges to search bins in order to + ! further restrict later searches + !----------------------------------------------------------------------- + + ALLOCATE(bin_addr1(2,num_srch_bins)) + ALLOCATE(bin_addr2(2,num_srch_bins)) + ALLOCATE(bin_lats (2,num_srch_bins)) + ALLOCATE(bin_lons (2,num_srch_bins)) + + dlat = pi/num_srch_bins + + DO n=1,num_srch_bins + bin_lats(1,n) = (n-1)*dlat - pih + bin_lats(2,n) = n*dlat - pih + bin_lons(1,n) = zero + bin_lons(2,n) = pi2 + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + END DO + + DO nele=1,grid1_size + DO n=1,num_srch_bins + IF (grid1_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid1_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr1(1,n) = MIN(nele,bin_addr1(1,n)) + bin_addr1(2,n) = MAX(nele,bin_addr1(2,n)) + ENDIF + END DO + END DO + + DO nele=1,grid2_size + DO n=1,num_srch_bins + IF (grid2_bound_box(1,nele) <= bin_lats(2,n) .AND. & + grid2_bound_box(2,nele) >= bin_lats(1,n)) THEN + bin_addr2(1,n) = MIN(nele,bin_addr2(1,n)) + bin_addr2(2,n) = MAX(nele,bin_addr2(2,n)) + ENDIF + END DO + END DO + ! + CALL init_remap_vars + CALL remap_bilin + + ALLOCATE(remap_matrix(SIZE(wts_map1,1),SIZE(wts_map1,2)), & + source_add(SIZE(grid1_add_map1)), & + destination_add(SIZE(grid2_add_map1))) + + DO j = 1,SIZE(wts_map1,2) + DO i = 1,SIZE(wts_map1,1) + + remap_matrix(i,j) = wts_map1(i,j) + + END DO + END DO + + + source_add(:) = grid1_add_map1(:) + destination_add(:) = grid2_add_map1(:) + ! + WHERE(destination_add == 0) + destination_add = 1 + END WHERE + + WHERE(source_add == 0) + source_add = 1 + END WHERE + ! + DEALLOCATE(grid1_bound_box,grid2_bound_box,grid1_center_lat,grid1_center_lon) + DEALLOCATE(grid2_center_lat,grid2_center_lon,grid2_add_map1,grid1_add_map1,wts_map1) + DEALLOCATE(grid1_frac,grid2_frac,grid1_dims,grid2_dims,grid2_mask,imask) + DEALLOCATE(bin_addr1,bin_addr2,bin_lats,bin_lons) + DEALLOCATE(grid1_mask) + ! + !----------------------------------------------------------------------- + + END SUBROUTINE get_remap_matrix + + + + + + + + + + + + + + + + + + + + + + + + + !*********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE REMAP_BILINEAR + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE remap_bilin + + !----------------------------------------------------------------------- + ! this routine computes the weights for a bilinear interpolation. + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + + INTEGER :: n,icount,dst_add,iter,nmap,nbmasked + ! + ! address for the four source points + ! + INTEGER, DIMENSION(4) :: src_add,involved_pts + INTEGER, DIMENSION(1) :: minlon + INTEGER, DIMENSION(1) :: minlat + REAL*8, DIMENSION(4) :: distx,disty + REAL*8 :: normalize + ! + ! latitudes longitudes of four bilinear corners + ! + REAL*8, DIMENSION(4) :: src_lats,src_lons + ! + ! bilinear weights for four corners + ! + REAL*8, DIMENSION(4) :: wgts + ! + REAL*8 :: & + plat, plon, & ! lat/lon coords of destination point + iguess, jguess, & ! current guess for bilinear coordinate + thguess, phguess, & ! current guess for lat/lon coordinate + deli, delj, & ! corrections to i,j + dth1, dth2, dth3, & ! some latitude differences + dph1, dph2, dph3, & ! some longitude differences + dthp, dphp, & ! difference between point and sw corner + mat1, mat2, mat3, mat4, & ! matrix elements + determinant, & ! matrix determinant + sum_wgts ! sum of weights for normalization + + INTEGER lastsrc_add + ! + grid2_mask = .TRUE. + ! + ! + nmap = 1 + ! + !*** + !*** loop over destination grid + !*** + ! print*,'grid2_size =',grid2_size + ! + lastsrc_add=1 + ! + grid_loop1: DO dst_add = 1, grid2_size + + IF (.NOT. grid2_mask(dst_add)) CYCLE grid_loop1 + ! + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + !*** + !*** find nearest square of grid points on source grid + !*** + CALL grid_search_bilin(src_add, src_lats, src_lons, & + plat, plon, grid1_dims, & + grid1_center_lat, grid1_center_lon, & + grid1_bound_box, bin_addr1, bin_addr2,lastsrc_add) + !*** + !*** check to see if points are land points + !*** + ! + IF (src_add(1) > 0) THEN + ! + DO n=1,4 + ! if(.not. grid1_mask(src_add(n))) nbmasked = nbmasked + 1 + IF(.NOT. grid1_mask(src_add(n))) src_add(1) = 0 + END DO + ! + ENDIF + ! + ! + + !*** + !*** if point found, find local i,j coordinates for weights + !*** + IF (src_add(1) > 0) THEN + grid2_frac(dst_add) = one + !*** + !*** iterate to find i,j for bilinear approximation + !*** + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + IF (dph1 > three*pih) dph1 = dph1 - pi2 + IF (dph2 > three*pih) dph2 = dph2 - pi2 + IF (dph3 > three*pih) dph3 = dph3 - pi2 + IF (dph1 < -three*pih) dph1 = dph1 + pi2 + IF (dph2 < -three*pih) dph2 = dph2 + pi2 + IF (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = half + jguess = half + + iter_loop1: DO iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - & + dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + IF (dphp > three*pih) dphp = dphp - pi2 + IF (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + IF (ABS(deli) < converge .AND. & + ABS(delj) < converge) EXIT iter_loop1 + + iguess = iguess + deli + jguess = jguess + delj + + END DO iter_loop1 + + IF (iter <= max_iter) THEN + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1) = (one-iguess)*(one-jguess) + wgts(2) = iguess*(one-jguess) + wgts(3) = iguess*jguess + wgts(4) = (one-iguess)*jguess + ! + ! + CALL store_link_bilin(dst_add, src_add, wgts, nmap) + + ELSE + PRINT *,'Point coords: ',plat,plon + PRINT *,'Dest grid lats: ',src_lats + PRINT *,'Dest grid lons: ',src_lons + PRINT *,'Dest grid addresses: ',src_add + PRINT *,'Current i,j : ',iguess, jguess + STOP 'Iteration for i,j exceed max iteration count' + ENDIF + ! + !*** + !*** search for bilinear failed - use a distance-weighted + !*** average instead (this is typically near the pole) + !*** + ELSE IF (src_add(1) < 0) THEN + + src_add = ABS(src_add) + icount = 0 + DO n=1,4 + ! + IF (grid1_mask(src_add(n))) THEN + icount = icount + 1 + ELSE + src_lats(n) = zero + ENDIF + ! + END DO + + IF (icount > 0) THEN + ! + !*** renormalize weights + ! + sum_wgts = SUM(src_lats) + wgts(1) = src_lats(1)/sum_wgts + wgts(2) = src_lats(2)/sum_wgts + wgts(3) = src_lats(3)/sum_wgts + wgts(4) = src_lats(4)/sum_wgts + ! + grid2_frac(dst_add) = one + CALL store_link_bilin(dst_add, src_add, wgts, nmap) + ENDIF + + ! + ENDIF + END DO grid_loop1 + ! + ! Call sort_add(grid2_add_map1, grid1_add_map1, wts_map1) + ! + ! + !----------------------------------------------------------------------- + + END SUBROUTINE remap_bilin + + + + + + + + + + + + + + + + + + + !*********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE GRID_SEARCH_BILIN + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE grid_search_bilin(src_add, src_lats, src_lons, & + plat, plon, src_grid_dims, & + src_center_lat, src_center_lon, & + src_grid_bound_box, & + src_bin_add, dst_bin_add,lastsrc_add) + + !----------------------------------------------------------------------- + ! + ! this routine finds the location of the search point plat, plon + ! in the source grid and returns the corners needed for a bilinear + ! interpolation. + ! + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------------- + ! + ! address of each corner point enclosing P + ! + INTEGER,DIMENSION(4) :: src_add + REAL*8,DIMENSION(4) :: src_lats,src_lons + ! + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + ! + ! latitude, longitude of the search point + ! + REAL*8, INTENT(in) :: plat,plon + ! + ! size of each src grid dimension + ! + INTEGER, DIMENSION(2), INTENT(in) :: src_grid_dims + ! + ! latitude, longitude of each src grid center + ! + REAL*8, DIMENSION(:), INTENT(in) :: src_center_lat,src_center_lon + ! + ! bound box for source grid + ! + REAL*8, DIMENSION(:,:), INTENT(in) :: src_grid_bound_box + ! + ! latitude bins for restricting searches + ! + INTEGER, DIMENSION(:,:), INTENT(in) ::src_bin_add,dst_bin_add + + INTEGER,OPTIONAL :: lastsrc_add + INTEGER :: loopsrc,l1,l2 + ! + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + ! + INTEGER :: n,next_n,srch_add,nx, ny,min_add, max_add, & + i, j, jp1, ip1, n_add, e_add, ne_add + + + REAL*8 :: vec1_lat, vec1_lon,vec2_lat, vec2_lon, cross_product, & + cross_product_last,coslat_dst, sinlat_dst, coslon_dst, & + sinlon_dst,dist_min, distance + + !----------------------------------------------------------------------- + ! restrict search first using bins + !----------------------------------------------------------------------- + + src_add = 0 + + min_add = SIZE(src_center_lat) + max_add = 1 + DO n=1,num_srch_bins + IF (plat >= bin_lats(1,n) .AND. plat <= bin_lats(2,n) .AND. & + plon >= bin_lons(1,n) .AND. plon <= bin_lons(2,n)) THEN + min_add = MIN(min_add, src_bin_add(1,n)) + max_add = MAX(max_add, src_bin_add(2,n)) + ENDIF + END DO + + !----------------------------------------------------------------------- + ! now perform a more detailed search + !----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + loopsrc=0 + DO WHILE (loopsrc <= max_add) + + + l1=MAX(min_add,lastsrc_add-loopsrc) + l2=MIN(max_add,lastsrc_add+loopsrc) + + loopsrc = loopsrc+1 + + srch_loop: DO srch_add = l1,l2,MAX(l2-l1,1) + + !*** first check bounding box + + IF (plat <= src_grid_bound_box(2,srch_add) .AND. & + plat >= src_grid_bound_box(1,srch_add) .AND. & + plon <= src_grid_bound_box(4,srch_add) .AND. & + plon >= src_grid_bound_box(3,srch_add)) THEN + !*** + !*** we are within bounding box so get really serious + !*** + !*** determine neighbor addresses + ! + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + ! + IF (i < nx) THEN + ip1 = i + 1 + ELSE + ip1 = 1 + ENDIF + ! + IF (j < ny) THEN + jp1 = j+1 + ELSE + jp1 = 1 + ENDIF + ! + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + ! + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + ! + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + ! + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + ! + vec1_lon = src_lons(1) - plon + IF (vec1_lon > pi) THEN + src_lons(1) = src_lons(1) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(1) = src_lons(1) + pi2 + ENDIF + DO n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + IF (vec1_lon > pi) THEN + src_lons(n) = src_lons(n) - pi2 + ELSE IF (vec1_lon < -pi) THEN + src_lons(n) = src_lons(n) + pi2 + ENDIF + END DO + ! + corner_loop: DO n=1,4 + next_n = MOD(n,4) + 1 + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the box. + !*** + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + !*** + !*** check for 0,2pi crossings + !*** + IF (vec1_lon > three*pih) THEN + vec1_lon = vec1_lon - pi2 + ELSE IF (vec1_lon < -three*pih) THEN + vec1_lon = vec1_lon + pi2 + ENDIF + IF (vec2_lon > three*pih) THEN + vec2_lon = vec2_lon - pi2 + ELSE IF (vec2_lon < -three*pih) THEN + vec2_lon = vec2_lon + pi2 + ENDIF + ! + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + ! + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + IF (n == 1) cross_product_last = cross_product + IF (cross_product*cross_product_last < zero) & + EXIT corner_loop + cross_product_last = cross_product + ! + END DO corner_loop + !*** + !*** if cross products all same sign, we found the location + !*** + IF (n > 4) THEN + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + ! + lastsrc_add = srch_add + RETURN + ENDIF + !*** + !*** otherwise move on to next cell + !*** + ENDIF !bounding box check + END DO srch_loop + + + ENDDO + + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + !print *,'Could not find location for ',plat,plon + !print *,'Using nearest-neighbor average for this point' + ! + coslat_dst = COS(plat) + sinlat_dst = SIN(plat) + coslon_dst = COS(plon) + sinlon_dst = SIN(plon) + ! + dist_min = bignum + src_lats = bignum + DO srch_add = min_add,max_add + distance = ACOS(coslat_dst*COS(src_center_lat(srch_add))* & + (coslon_dst*COS(src_center_lon(srch_add)) + & + sinlon_dst*SIN(src_center_lon(srch_add)))+ & + sinlat_dst*SIN(src_center_lat(srch_add))) + + IF (distance < dist_min) THEN + sort_loop: DO n=1,4 + IF (distance < src_lats(n)) THEN + DO i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + END DO + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + EXIT sort_loop + ENDIF + END DO sort_loop + ENDIF + END DO + ! + src_lons = one/(src_lats + tiny) + distance = SUM(src_lons) + src_lats = src_lons/distance + + !----------------------------------------------------------------------- + + END SUBROUTINE grid_search_bilin + + + !*********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE STORE_LINK_BILIN + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE store_link_bilin(dst_add, src_add, weights, nmap) + + !----------------------------------------------------------------------- + ! this routine stores the address and weight for four links + ! associated with one destination point in the appropriate address + ! and weight arrays and resizes those arrays if necessary. + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + ! + INTEGER :: dst_add,nmap + ! + INTEGER, DIMENSION(4) :: src_add + ! + REAL*8, DIMENSION(4) :: weights + + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + INTEGER :: n,num_links_old + + !----------------------------------------------------------------------- + ! increment number of links and check to see if remap arrays need + ! to be increased to accomodate the new link. then store the + ! link. + !----------------------------------------------------------------------- + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + IF (num_links_map1 > max_links_map1) & + CALL resize_remap_vars(1,resize_increment) + + DO n=1,4 + grid1_add_map1(num_links_old+n) = src_add(n) + grid2_add_map1(num_links_old+n) = dst_add + wts_map1 (1,num_links_old+n) = weights(n) + END DO + + !----------------------------------------------------------------------- + + END SUBROUTINE store_link_bilin + + + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE INIT_REMAP_VARS + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE init_remap_vars + + !----------------------------------------------------------------------- + ! + ! this routine initializes some variables and provides an initial + ! allocation of arrays (fairly large so frequent resizing + ! unnecessary). + ! + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! determine the number of weights + !----------------------------------------------------------------------- + num_wts = 1 ! bilinear interpolation + !----------------------------------------------------------------------- + ! initialize num_links and set max_links to four times the largest + ! of the destination grid sizes initially (can be changed later). + ! set a default resize increment to increase the size of link + ! arrays if the number of links exceeds the initial size + !----------------------------------------------------------------------- + + num_links_map1 = 0 + max_links_map1 = 4*grid2_size + IF (num_maps > 1) THEN + num_links_map2 = 0 + max_links_map1 = MAX(4*grid1_size,4*grid2_size) + max_links_map2 = max_links_map1 + ENDIF + + resize_increment = 0.1*MAX(grid1_size,grid2_size) + + !----------------------------------------------------------------------- + ! allocate address and weight arrays for mapping 1 + !----------------------------------------------------------------------- + + ALLOCATE (grid1_add_map1(max_links_map1), & + grid2_add_map1(max_links_map1), & + wts_map1(num_wts, max_links_map1)) + + grid1_add_map1 = 0. + grid2_add_map1 = 0. + wts_map1 = 0. + + !----------------------------------------------------------------------- + + END SUBROUTINE init_remap_vars + + + + + + + + + + + + + + + !*********************************************************************** +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !************************************************************************ + ! SUBROUTINE RESIZE_REMAP_VAR + !************************************************************************ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE resize_remap_vars(nmap, increment) + + !----------------------------------------------------------------------- + ! this routine resizes remapping arrays by increasing(decreasing) + ! the max_links by increment + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------------- + + INTEGER :: & + nmap, & ! identifies which mapping array to resize + increment ! the number of links to add(subtract) to arrays + + !----------------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------------- + + INTEGER :: & + ierr, & ! error flag + mxlinks ! size of link arrays + + INTEGER, DIMENSION(:), POINTER :: & + add1_tmp, & ! temp array for resizing address arrays + add2_tmp ! temp array for resizing address arrays + ! + ! temp array for resizing weight arrays + ! + REAL*8, DIMENSION(:,:), POINTER :: wts_tmp + ! + !----------------------------------------------------------------------- + !*** + !*** allocate temporaries to hold original values + !*** + mxlinks = SIZE(grid1_add_map1) + ALLOCATE (add1_tmp(mxlinks), add2_tmp(mxlinks), & + wts_tmp(num_wts,mxlinks)) + + add1_tmp = grid1_add_map1 + add2_tmp = grid2_add_map1 + wts_tmp = wts_map1 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + DEALLOCATE (grid1_add_map1, grid2_add_map1, wts_map1) + max_links_map1 = mxlinks + increment + ALLOCATE (grid1_add_map1(max_links_map1), & + grid2_add_map1(max_links_map1), & + wts_map1(num_wts,max_links_map1)) + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + mxlinks = MIN(mxlinks, max_links_map1) + grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks) + grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks) + wts_map1 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + DEALLOCATE(add1_tmp, add2_tmp, wts_tmp) + + !----------------------------------------------------------------------- + ! + END SUBROUTINE resize_remap_vars + ! + !************************************************************************ + ! +END MODULE bilinear_interp + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/V4.0/nemo_sources/tools/NESTING/src/io_netcdf.f90 b/V4.0/nemo_sources/tools/NESTING/src/io_netcdf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..98a407653f3b6ffefe2f3094a54ed6413908e2a8 --- /dev/null +++ b/V4.0/nemo_sources/tools/NESTING/src/io_netcdf.f90 @@ -0,0 +1,1606 @@ +!************************************************************************ +! Fortran 95 OPA Nesting tools * +! * +! Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr) * +! * +!************************************************************************ +! +!******************************************************************************** +! * +! module io_netcdf * +! * +! NetCDF Fortran 90 read/write interface * +! using input/output functions provided * +! by unidata * +! * +!http://my.unidata.ucar.edu/content/software/netcdf/docs/netcdf-f90/index.html * +! * +!******************************************************************************** +! +! +! +MODULE io_netcdf + ! + USE netcdf + USE agrif_types + ! + INTERFACE read_ncdf_var + MODULE PROCEDURE & + read_ncdf_var0d_real, read_ncdf_var1d_real, read_ncdf_var2d_real , read_ncdf_var2d_real_bis, & + read_ncdf_var3d_real, read_ncdf_var4d_real, read_ncdf_var3d_real_t, read_ncdf_var4d_real_t, read_ncdf_var4d_real_nt, & + read_ncdf_var0d_int, read_ncdf_var1d_int , read_ncdf_var2d_int , read_ncdf_var3d_int , read_ncdf_var4d_int + END INTERFACE + ! + INTERFACE write_ncdf_var + MODULE PROCEDURE & + write_ncdf_var0d_real, write_ncdf_var1d_real , write_ncdf_var2d_real , write_ncdf_var3d_real, & + write_ncdf_var4d_real, write_ncdf_var3d_real_t, write_ncdf_var4d_real_t, write_ncdf_var4d_real_nt, & + write_ncdf_var2d_real_bis , & + write_ncdf_var0d_int, write_ncdf_var1d_int, write_ncdf_var2d_int, write_ncdf_var3d_int, write_ncdf_var4d_int + END INTERFACE + ! + INTERFACE copy_ncdf_att + MODULE PROCEDURE copy_ncdf_att_latlon,copy_ncdf_att_var + END INTERFACE + ! +CONTAINS + ! + !**************************************************************** + ! subroutine read_ncdf_dim * + ! * + ! subroutine to retrieve value of a given dimension * + ! * + ! dimname : name of dimension to retrieve * + ! file : netcdf file name * + ! dimval : value of the required dimension * + ! * + !**************************************************************** + ! + SUBROUTINE read_ncdf_dim(dimname,file,dimval) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: dimname,file + INTEGER :: dimval + ! + ! local variables + ! + INTEGER ncid,status,dimid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname,dimid) + status = nf90_inquire_dimension(ncid,dimid,len=dimval) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_dim + ! + !************************************************************** + ! end subroutine read_ncdf_dim + !************************************************************** + ! + !**************************************************************** + ! subroutine write_ncdf_dim * + ! * + ! subroutine to write a dimension in a given file * + ! * + ! dimname : name of dimension to initialize * + ! file : netcdf file name * + ! dimval : value of the dimension to write * + ! * + !**************************************************************** + ! + SUBROUTINE write_ncdf_dim(dimname,file,dimval) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: dimname,file + INTEGER :: dimval + ! + ! local variables + ! + INTEGER ncid,status,dimid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_redef(ncid) + IF(dimval.EQ.0) THEN + status = nf90_def_dim(ncid,dimname,nf90_unlimited,dimid) + ELSE + status = nf90_def_dim(ncid,dimname,dimval,dimid) + END IF + + status = nf90_enddef(ncid) + ! + + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_dim + ! + !************************************************************** + ! end subroutine write_ncdf_dim + !************************************************************** + ! + !**************************************************************** + ! subroutine read_ncdf_var * + ! * + ! subroutine to retrieve values of a given variable * + ! * + ! varname : name of variable to retrieve * + ! file : netcdf file name * + ! tabvar : array containing values of the required variable* + ! * + !**************************************************************** + ! + SUBROUTINE read_ncdf_var1d_real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(1) :: dimID + INTEGER :: dim1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimID) + status=nf90_inquire_dimension(ncid,dimID(1),len=dim1) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var1d_real + ! + ! + SUBROUTINE read_ncdf_var2d_real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var2d_real + ! + ! + SUBROUTINE read_ncdf_var2d_real_bis(varname,file,tabvar,strt,cnt) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER, DIMENSION(2) :: strt,cnt + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + dim1 = cnt(1) + dim2 = cnt(2) + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar)/=(/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar,start = strt,count = cnt) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var2d_real_bis + ! + ! + SUBROUTINE read_ncdf_var3d_real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var3d_real + ! + ! + SUBROUTINE read_ncdf_var4d_real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3,dim4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + status=nf90_inquire_dimension(ncid,dimIDS(4),len=dim4) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3,dim4/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var4d_real + + SUBROUTINE read_ncdf_var0d_real(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + REAL*8 :: tabvar + ! + !local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var0d_real + + SUBROUTINE read_ncdf_var0d_int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER :: tabvar + ! + !local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var0d_int + ! + ! + SUBROUTINE read_ncdf_var1d_int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:), POINTER :: tabvar + ! + !local variables + ! + INTEGER,DIMENSION(10) :: dimID + INTEGER :: dim1 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimID) + status=nf90_inquire_dimension(ncid,dimID(1),len=dim1) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var1d_int + ! + ! + SUBROUTINE read_ncdf_var2d_int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:), POINTER :: tabvar + !local variables + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var2d_int + ! + ! + SUBROUTINE read_ncdf_var3d_int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var3d_int + ! + ! + SUBROUTINE read_ncdf_var4d_int(varname,file,tabvar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(10) :: dimIDS + INTEGER :: dim1,dim2,dim3,dim4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + status=nf90_inquire_dimension(ncid,dimIDS(4),len=dim4) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,dim3,dim4/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,dim3,dim4)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var4d_int + ! + ! + !**************************************************************** + ! subroutine write_ncdf_var * + ! * + ! subroutine to write a variable in a given file * + ! * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! * + !**************************************************************** + ! + ! + SUBROUTINE write_ncdf_var1d_real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,dimname,typevar + REAL*8, DIMENSION(:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname,dimid) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double,(/dimid/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float,(/dimid/),varid) + END SELECT + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var1d_real + ! + ! + SUBROUTINE write_ncdf_var2d_real_bis(varname,dimname,file,tabvar,nbdim,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + INTEGER,INTENT(in) :: nbdim + CHARACTER(*), DIMENSION(4) :: dimname + REAL*8, DIMENSION(:,:) :: tabvar + REAL*8, ALLOCATABLE, DIMENSION(:,:,:) :: tabtemp3d + REAL*8, ALLOCATABLE, DIMENSION(:,:,:,:) :: tabtemp4d + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid,ncid2 + INTEGER :: varid,varid2 + ! + IF(nbdim==4) THEN + ALLOCATE(tabtemp4d(SIZE(tabvar,1),SIZE(tabvar,2),1,1)) + tabtemp4d(:,:,1,1) = tabvar(:,:) + ELSE IF(nbdim==3) THEN + ALLOCATE(tabtemp3d(SIZE(tabvar,1),SIZE(tabvar,2),1)) + tabtemp3d(:,:,1) = tabvar(:,:) + END IF + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + ! + IF(nbdim==4) status = nf90_inq_dimid(ncid,dimname(4), dimid4) + ! + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + IF(nbdim==4 .AND. typevar == 'double') THEN + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + ! + ELSE IF(nbdim==4 .AND. typevar == 'float') THEN + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + ! + ELSE IF(nbdim==3 .AND. typevar == 'float') THEN + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + ! + ELSE IF(nbdim==3 .AND. typevar == 'double') THEN + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + ! + ENDIF + ! + status = nf90_enddef(ncid) + IF(nbdim==4) status = nf90_put_var(ncid,varid,tabtemp4d) + IF(nbdim==3) status = nf90_put_var(ncid,varid,tabtemp3d) + ! + IF(ALLOCATED( tabtemp3d ) ) DEALLOCATE( tabtemp3d ) + IF(ALLOCATED( tabtemp4d ) ) DEALLOCATE( tabtemp4d ) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var2d_real_bis + ! + ! + SUBROUTINE write_ncdf_var2d_real(varname,dimname,file,tabvar,typevar) + ! + ! implicit none + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*), DIMENSION(2) :: dimname + REAL*8, DIMENSION(:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var2d_real + ! + ! + SUBROUTINE write_ncdf_var3d_real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + REAL*8, DIMENSION(:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var3d_real + ! + ! + SUBROUTINE write_ncdf_var4d_real(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + REAL*8, DIMENSION(:,:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + IF(status/=nf90_noerr) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var4d_real + ! + ! + SUBROUTINE write_ncdf_var1d_int(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,dimname,typevar + INTEGER, DIMENSION(:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid + INTEGER :: status,ncid + INTEGER :: varid + ! + ! print *,'ici tabvar = ',tabvar,varname,dimname + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname, dimid) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int,(/dimid/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var1d_int + ! + ! + SUBROUTINE write_ncdf_var2d_int(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*), INTENT(in) :: varname,file,typevar + CHARACTER(*), DIMENSION(2), INTENT(in) :: dimname + INTEGER, DIMENSION(:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1),dimid1) + status = nf90_inq_dimid(ncid,dimname(2),dimid2) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int,(/dimid1,dimid2/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var2d_int + ! + ! + SUBROUTINE write_ncdf_var3d_int(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + INTEGER, DIMENSION(:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int, & + (/dimid1,dimid2,dimid3/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var3d_int + ! + ! + SUBROUTINE write_ncdf_var4d_int(varname,dimname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER, DIMENSION(:,:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_inq_varid(ncid,varname,varid) + status = nf90_redef(ncid) + status = nf90_def_var(ncid,varname,nf90_int, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var4d_int + ! + ! + !**************************************************************** + ! subroutine read_ncdf_var_t * + ! * + ! subroutine to read a variable in a given file for time t * + ! * + ! varname : name of variable to read * + ! file : netcdf file name * + ! tabvar : values of the read variable * + ! time : time corresponding to the values to read * + ! * + !**************************************************************** + ! + ! + SUBROUTINE read_ncdf_var3d_real_t(varname,file,tabvar,time) + ! + USE agrif_types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time + REAL*8, DIMENSION(:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(3) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,1)) + ELSE + IF( ANY(SHAPE(tabvar) /= (/dim1,dim2,1/)) ) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,1)) + ENDIF + ENDIF + + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,time/)) + + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var3d_real_t + ! + ! + !**************************************************************** + ! subroutine write_ncdf_var_t * + ! * + ! subroutine to write a variable in a given file for time t * + ! * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! time : time corresponding to the values to store * + ! * + !**************************************************************** + ! + ! + SUBROUTINE write_ncdf_var3d_real_t(varname,dimname,file,tabvar,time,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(3),INTENT(in) :: dimname + INTEGER :: time + REAL*8, DIMENSION(:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_redef(ncid) + + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,varname,nf90_double, & + (/dimid1,dimid2,dimid3/),varid) + CASE('float') + status = nf90_def_var(ncid,varname,nf90_float, & + (/dimid1,dimid2,dimid3/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var3d_real_t + ! + ! + !**************************************************************** + ! subroutine read_ncdf_var_t * + ! * + ! subroutine to read a variable in a given file for time t * + ! at level n * + ! varname : name of variable to read * + ! file : netcdf file name * + ! tabvar : values of the read variable * + ! time : time corresponding to the values to read * + ! level : level corresponding to the values to read * + ! * + !**************************************************************** + ! + ! + SUBROUTINE read_ncdf_var4d_real_nt(varname,file,tabvar,time,level) + ! + USE agrif_types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time,level + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + ! + IF(.NOT. ASSOCIATED(tabvar)) THEN + ALLOCATE(tabvar(dim1,dim2,1,1)) + ELSE + IF ((SIZE(tabvar,1) /= dim1) .OR. (SIZE(tabvar,2) /= dim2)) THEN + DEALLOCATE(tabvar) + ALLOCATE(tabvar(dim1,dim2,1,1)) + ENDIF + ENDIF + ! + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,level,time/),count=(/dim1,dim2,1,1/)) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var4d_real_nt + ! + ! + SUBROUTINE read_ncdf_var4d_real_t(varname,file,tabvar,time) + ! + USE agrif_types + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file + INTEGER,INTENT(in) :: time + REAL*8, DIMENSION(:,:,:,:), POINTER :: tabvar + ! + !local variables + ! + INTEGER, DIMENSION(4) :: dimIDS + INTEGER :: dim1,dim2,dim3 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_NOWRITE,ncid) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_inq_varid(ncid,varname,varid) + ! + status=nf90_inquire_variable(ncid,varid,dimids=dimIDS) + status=nf90_inquire_dimension(ncid,dimIDS(1),len=dim1) + status=nf90_inquire_dimension(ncid,dimIDS(2),len=dim2) + status=nf90_inquire_dimension(ncid,dimIDS(3),len=dim3) + ! + IF(.NOT. ASSOCIATED(tabvar)) ALLOCATE(tabvar(dim1,dim2,dim3,1)) + status=nf90_get_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to retrieve netcdf variable : ",TRIM(varname) + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE read_ncdf_var4d_real_t + ! + !**************************************************************** + ! subroutine write_ncdf_var_t * + ! * + ! subroutine to write a variable in a given file for time t * + ! at level n * + ! varname : name of variable to store * + ! dimname : name of dimensions of the given variable * + ! file : netcdf file name * + ! tabvar : values of the variable to write * + ! time : time corresponding to the values to store * + ! level : level corresponding to the values to store * + ! * + !**************************************************************** + ! + ! + SUBROUTINE write_ncdf_var4d_real_t(varname,dimname,file,tabvar,time,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER :: time,level + REAL*8, DIMENSION(:,:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,1,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var4d_real_t + ! + ! + SUBROUTINE write_ncdf_var4d_real_nt(varname,dimname,file,tabvar,time,level,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + CHARACTER(*),DIMENSION(4),INTENT(in) :: dimname + INTEGER :: time,level + REAL*8, DIMENSION(:,:,:,:), INTENT(in) :: tabvar + ! + ! local variables + ! + INTEGER :: dimid1,dimid2,dimid3,dimid4 + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + IF(time==1.AND.level==1) THEN + ! + status = nf90_inq_dimid(ncid,dimname(1), dimid1) + status = nf90_inq_dimid(ncid,dimname(2), dimid2) + status = nf90_inq_dimid(ncid,dimname(3), dimid3) + status = nf90_inq_dimid(ncid,dimname(4), dimid4) + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + (/dimid1,dimid2,dimid3,dimid4/),varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ELSE + status = nf90_inq_varid(ncid, varname, varid) + ENDIF + ! + status = nf90_put_var(ncid,varid,tabvar,start=(/1,1,level,time/)) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var4d_real_nt + + SUBROUTINE write_ncdf_var0d_real(varname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + INTEGER :: time,level + REAL*8 :: tabvar + ! + ! local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + + status = nf90_redef(ncid) + ! + SELECT CASE(TRIM(typevar)) + CASE('double') + status = nf90_def_var(ncid,TRIM(varname),nf90_double, & + varid=varid) + CASE('float') + status = nf90_def_var(ncid,TRIM(varname),nf90_float, & + varid=varid) + END SELECT + ! + status = nf90_enddef(ncid) + + ! + status = nf90_put_var(ncid,varid,tabvar) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + ! + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var0d_real + + SUBROUTINE write_ncdf_var0d_int(varname,file,tabvar,typevar) + ! + IMPLICIT NONE + ! + CHARACTER(*),INTENT(in) :: varname,file,typevar + INTEGER :: tabvar + ! + ! local variables + ! + INTEGER :: status,ncid + INTEGER :: varid + ! + status = nf90_open(file,NF90_WRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",file + STOP + ENDIF + ! + status = nf90_redef(ncid) + status = nf90_def_var(ncid,TRIM(varname),nf90_int,varid) + status = nf90_enddef(ncid) + status = nf90_put_var(ncid,varid,tabvar) + ! + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to store variable ",varname, & + " in file ",file + STOP + ENDIF + status = nf90_close(ncid) + ! + END SUBROUTINE write_ncdf_var0d_int + + ! + !**************************************************************** + ! subroutine read_ncdf_VarName * + ! * + ! subroutine to retrieve of all variables * + ! included in a given file * + ! * + ! filename : netcdf file name * + ! tabvarname : array containing various variables names * + ! * + !**************************************************************** + ! + ! + SUBROUTINE read_ncdf_VarName(filename,tabvarname) + ! + CHARACTER(*),INTENT(in) :: filename + CHARACTER*20,DIMENSION(:),POINTER :: tabvarname + INTEGER :: nDimensions,nVariables + INTEGER :: nAttributes,unlimitedDimId,i + INTEGER :: ncid,status,dimid + ! + status = nf90_open(filename,NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",filename + STOP + ENDIF + ! + status = nf90_inquire(ncid,nDimensions,nVariables,nAttributes, & + unlimitedDimId) + ! + ALLOCATE(tabvarname(nVariables)) + ! + DO i=1,nVariables + status = nf90_inquire_variable(ncid,i,tabvarname(i)) + END DO + + END SUBROUTINE read_ncdf_Varname + ! + ! + SUBROUTINE copy_ncdf_att_var(varname,filein,fileout) + ! + CHARACTER(*),INTENT(in) :: filein,fileout + CHARACTER(*),INTENT(in) :: varname + INTEGER :: ncid_in,ncid_out,status,varid_in,varid_out + ! + ! print *,'filein = ',filein,fileout + status = nf90_open(filein,NF90_NOWRITE,ncid_in) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open input netcdf file : ",filein + STOP + ENDIF + ! + status = nf90_open(fileout,NF90_WRITE,ncid_out) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open output netcdf file : ",fileout + STOP + ENDIF + ! + ! print *,'ici1' + status = nf90_inq_varid(ncid_in,varname,varid_in) + status = nf90_inq_varid(ncid_out,varname,varid_out) + ! + status = nf90_redef(ncid_out) + ! + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'valid_min',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'valid_max',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'calendar',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'time_origin',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'positive',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'tstep_sec',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'Minvalue=',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'Maxvalue=',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'short_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'online_operation',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'axis',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'interval_operation',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'interval_write',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'associate',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'actual_range',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'longitude',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'latitude',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'scale_factor',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'add_offset',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'missing_value',ncid_out,varid_out) + ! + status = nf90_enddef(ncid_out) + ! + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + ! print *,'ici2' + ! + END SUBROUTINE copy_ncdf_att_var + ! + ! + SUBROUTINE copy_ncdf_att_latlon(varname,filein,fileout,min,max) + ! + CHARACTER(*),INTENT(in) :: filein,fileout + CHARACTER(*),INTENT(in) :: varname + REAL*8 :: min,max + INTEGER :: ncid_in,ncid_out,status,varid_in,varid_out + ! + status = nf90_open(filein,NF90_NOWRITE,ncid_in) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",filein + STOP + ENDIF + ! + status = nf90_open(fileout,NF90_WRITE,ncid_out) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",fileout + STOP + ENDIF + ! + status = nf90_inq_varid(ncid_in,varname,varid_in) + status = nf90_inq_varid(ncid_out,varname,varid_out) + ! + status = nf90_redef(ncid_out) + ! + SELECT CASE (varname) + ! + CASE('nav_lon') + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_put_att(ncid_out,varid_out,'valid_min',REAL(min,4)) + status = nf90_put_att(ncid_out,varid_out,'valid_max',REAL(max,4)) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + ! + CASE('nav_lat') + status = nf90_copy_att(ncid_in,varid_in,'units',ncid_out,varid_out) + status = nf90_put_att(ncid_out,varid_out,'valid_min',REAL(min,4)) + status = nf90_put_att(ncid_out,varid_out,'valid_max',REAL(max,4)) + status = nf90_copy_att(ncid_in,varid_in,'long_name',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'nav_model',ncid_out,varid_out) + status = nf90_copy_att(ncid_in,varid_in,'title',ncid_out,varid_out) + ! + END SELECT + ! + status = nf90_enddef(ncid_out) + ! + status = nf90_close(ncid_in) + status = nf90_close(ncid_out) + END SUBROUTINE copy_ncdf_att_latlon + + !************************************************************* + !************************************************************** + ! + INTEGER FUNCTION Get_NbDims( varname , filename ) + ! + CHARACTER(*),INTENT(in) :: varname,filename + INTEGER :: status,ncid,varid + ! + status = nf90_open(TRIM(filename),NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",TRIM(filename) + STOP + ENDIF + status = nf90_inq_varid(ncid,TRIM(varname),varid) + status = nf90_inquire_variable(ncid, varid , ndims = Get_NbDims) + ! + RETURN + ! + END FUNCTION Get_NbDims + ! + ! + LOGICAL FUNCTION Dims_Existence( dimname , filename ) + ! + CHARACTER(*),INTENT(in) :: dimname,filename + INTEGER :: status,ncid,dimid + ! + status = nf90_open(TRIM(filename),NF90_NOWRITE,ncid) + IF (status/=nf90_noerr) THEN + WRITE(*,*)"unable to open netcdf file : ",TRIM(filename) + STOP + ENDIF + status = nf90_inq_dimid(ncid,dimname,dimid) + ! + IF (status/=nf90_noerr) THEN + Dims_Existence = .FALSE. + ELSE + Dims_Existence = .TRUE. + ENDIF + ! + RETURN + ! + END FUNCTION Dims_Existence + ! +END MODULE io_netcdf diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/bin/ooo b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/bin/ooo new file mode 100644 index 0000000000000000000000000000000000000000..b2eb75a32268bd0c21adac830fbd166acd7e1722 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/bin/ooo @@ -0,0 +1,4 @@ +#!/usr/bin/env python2.7 +import ooo +if __name__ == '__main__': + ooo.main() diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/__init__.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/__init__.py new file mode 100644 index 0000000000000000000000000000000000000000..66a74eae7c60911097ab89ee4bc049b6e2193d7d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/__init__.py @@ -0,0 +1,3 @@ +import nml +import locator +from ooo import main diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/locator.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/locator.py new file mode 100644 index 0000000000000000000000000000000000000000..74fc8485bd30e79a8d9e0c1876d730995994d5fa --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/locator.py @@ -0,0 +1,151 @@ +"""Locates input files and calculates namelist attributes + + Typically a user will have files distributed throughout the hard drive + and it makes little or no sense to try to capture all use cases. + + >>> date = "20130101" + >>> namobs = observations(date, types=["profbfiles"]) + + >>> namooo, namcl4 = forecasts(date, types=["forecast", "persistence"], lead_times=[12, 36, 60]) +""" + +def observations(date, types=None): + """Responsible for locating observation files + + Valid **namobs** observation types. + + * profbfiles + * sstfbfiles + * slafbfiles + + :param date: The verification date in string format ``'%Y%m%d'`` + :param types: A list of namobs observation types + + :returns: namobs namelist dictionary + """ + namobs = {"ln_t3d": False, + "ln_s3d": False, + "ln_ena": False, + "ln_profb": False, + "ln_sst": False, + "ln_sstfb": False, + "ln_reysst": False, + "ln_ghrsst": False, + "ln_sla": False, + "ln_slafb": False, + "ln_sladt": False} + if types is None: types = [] + for obtype in types: + if obtype == "profbfiles": + namobs[obtype] = profbfiles(date) + namobs["ln_t3d"] = True + namobs["ln_s3d"] = True + namobs["ln_profb"] = True + elif obtype == "sstfbfiles": + namobs[obtype] = sstfbfiles(date) + namobs["ln_sst"] = True + namobs["ln_sstfb"] = True + elif obtype == "slafbfiles": + namobs[obtype] = slafbfiles(date) + namobs["ln_sla"] = True + namobs["ln_slafb"] = True + return namobs + +def profbfiles(date): + """Observation file locator stub + + .. note:: User-specified stub + + :param date: The verification date in string format ``'%Y%m%d'`` + :returns: List of files + """ + files = ['profb.nc'] + return files + +def sstfbfiles(date): + """Observation file locator stub + + .. note:: User-specified stub + + :param date: The verification date in string format ``'%Y%m%d'`` + :returns: List of files + """ + files = ['sstfb.nc'] + return files + +def slafbfiles(date): + """Observation file locator stub + + .. note:: User-specified stub + + :param date: The verification date in string format ``'%Y%m%d'`` + :returns: List of files + """ + files = ['slafb.nc'] + return files + +def forecasts(date, types=None, lead_times=None): + """Responsible for locating forecast fields + + :param date: The verification date in string format ``'%Y%m%d'`` + :param types: A list of forecast system types + :param lead_times: A list of lead_times to search for + + :returns: tuple of namelist data, (namooo, namcl4) + """ + namooo = {} + namcl4 = {} + if types is None: types = [] + if lead_times is None: lead_times = [] + + # Initialise data + ooo_files = [] + nn_ooo_idx = [] + cl4_vars = [] + cl4_fcst_idx = [] + + # Search for files + for type in types: + files = [] + in_indices = [] + out_indices = [] + for ilt, lead_time in enumerate(lead_times): + file, index = field(date, type=type, lead_time=lead_time) + files.append(file) + in_indices.append(index) + out_indices.append(ilt + 1) + # Expand return lists + ooo_files += files + nn_ooo_idx += in_indices + cl4_fcst_idx += out_indices + cl4_vars += len(files) * [type] + + # Namoo + namooo["ooo_files"] = ooo_files + namooo["nn_ooo_idx"] = nn_ooo_idx + + # Namcl4 + namcl4["cl4_vars"] = cl4_vars + namcl4["cl4_fcst_idx"] = cl4_fcst_idx + + return namooo, namcl4 + +def field(date, type=None, lead_time=None): + """Forecast field locator + + Maps verification date and lead time off set to file name and + index along file *time_counter* + + .. note:: User-specified stub + + :param date: The verification date in string format ``'%Y%m%d'`` + :param type: Forecast type + :param lead_time: Forecast off set + + :returns: (**path**, **index**) + """ + # Worker function + file = 'nofile' + index = -1 + return file, index + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/nml.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/nml.py new file mode 100644 index 0000000000000000000000000000000000000000..0e3626b6e985af1261c0d0be2478b5e9e53ef6bf --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/nml.py @@ -0,0 +1,479 @@ +"""Collection of Fortran 90 namelist helper functions. + + A common way to interface with a Fortran executable is via + an input file called a namelist. This module defines + functions which simplify the process of updating and + extending namelist data. + + .. note:: This module is especially lightweight and follows the + batteries included philosophy. As such, only standard + library modules are required to use this code. + + Walkthrough + =========== + + New namelist + ------------ + + A typical usage is to create and update a Fortran namelist on the fly. + + >>> import nml + >>> namid = "namfoo" + >>> text = nml.new(namid) + >>> data = {"x": nml.tostring([1, 2, 3])} + >>> text = nml.update(namid, text, data) + >>> print text + &namfoo + x = 1 2 3 + / + <BLANKLINE> + + In the above snippet :func:`tostring` has been used to sanitize the input + Python list. This function cleverly maps string data and numeric data to + the correct Fortran syntax. + + However, the :func:`new` function takes care of many of the above steps automatically. + Where appropriate :func:`sanitize` has been embedded to reduce the need + to worry about data format problems. Take for example, + + >>> print nml.new("namfoo", data={"x": range(3)}) + &namfoo + x = 0 1 2 + / + <BLANKLINE> + + Parse existing namelist + ----------------------- + + In order to update a namelist it is necessary to convert the namelist text into + a dictionary of *key, value* pairs which can be manipulated in the usual Pythonic + fashion before being piped back out to disk. + + In everyday usage text will be read from files, here however for illustration + purposes I have hand written a namelist. + + >>> text = ''' + ... &namfoo + ... x = y ! A description of the variables + ... / + ... &nambar + ... ln_on = .TRUE. ! A description of the variables + ... / + ... ''' + + This can be parsed by invoking the :func:`variables` command. + + >>> nml.variables(text) + {'x': 'y', 'ln_on': '.TRUE.'} + + Or by using the :func:`namelists` function to split the file into sub-lists. + + >>> nml.namelists(text) + {'namfoo': '&namfoo\\n x = y ! A description of the variables\\n/', 'nambar': '&nambar\\n ln_on = .TRUE. ! A description of the variables\\n/'} + >>> sublists = nml.namelists(text) + >>> print sublists["nambar"] + &nambar + ln_on = .TRUE. ! A description of the variables + / + + Which can be parsed into a dictionary as before. + + >>> print nml.variables(sublists["nambar"]) + {'ln_on': '.TRUE.'} + + + Update/replace data + ------------------- + + There are two ways of modifying values inside a Fortran namelist. + + Replace + The first is to simply replace a set of variables with new values. This behaviour is accomplished + via the :func:`replace` function. This approach simply overwrites existing variables. No knowledge + of sub-namelist structure is required to modify a string of text. + + .. note:: Additional variables will not be added to a namelist via this approach + + Update + The second is to extend the set of variables contained within a namelist. This functionality is + controlled by the :func:`update` function. Here, variables which are not already specified are + added using a templated namelist line. + + .. note:: It is essential to specify which sub-namelist is to be updated before modification takes place + + Pipe to/from file + ----------------- + + As typical NEMO namelists are no larger than a few tens of kilobytes + it makes sense to process namelists as single strings instead of + line by line. + + >>> path = "foo.nml" + >>> text = nml.new("namfoo") + + To write to a file simply invoke the writer. + + >>> # Write to file + >>> nml.writer(path, text) + + To read from a file specify the path to be read. + + >>> # Read from file + >>> text = nml.reader(path) + + Join multiple namelists + ----------------------- + + Since the namelists are regular Python strings there is no need for a + specific *join* function. Namelists can be combined in whatever manner + is most pleasing to the eye. + + >>> namoff = nml.new("namoff") + >>> namcl4 = nml.new("namcl4") + >>> # new line join + >>> print "\\n".join([namoff, namcl4]) + &namoff + / + <BLANKLINE> + &namcl4 + / + <BLANKLINE> + + >>> # Or addition + >>> print namoff + namcl4 + &namoff + / + &namcl4 + / + <BLANKLINE> + + Module functions + ================ + +""" +__version__ = "0.1.0" +import re +from numbers import Number + +def reader(path): + """Reads a file into a string + + Reads whole file into single string. Typically, + namelists are small enough to be stored in memory + while updates and edits are being performed. + + :param path: Path to input file + :returns: entire file as a single string + + """ + with open(path, "r") as handle: + text = handle.read() + return text + +def writer(path, text): + """Writes to a file from a string + + Handy way of piping a processed namelist into + a file. + + :param path: Path to output file + :param text: Input text to process + + """ + with open(path, "w") as handle: + handle.write(text) + +def update(namid, text, data, convert=True): + """Extends namelist definition. + + Similar to replace this function alters the values + of variables defined within a namelist. In addition to + replacing values it also creates definitions if the + variable is not found in the namelist. As such, the + namelist id must be specified. + + :param namid: Namelist id + :param text: Input text to process + :param data: Dictionary of variables + :keyword convert: Sanitizes input data before replacement takes place + + :returns: Text + + .. seealso:: :func:`replace` :func:`sanitize` + """ + sublists = namelists(text) + assert namid in sublists, "Warning: invalid namid specified!" + + # Sanitize inputs + if convert: + data = sanitize(data) + + # Parse subsection + namtext = sublists[namid] + subdata = variables(namtext) + subvars = subdata.keys() + + # Replace existing variables in namtext + tmptext = replace(namtext, data) + text = text.replace(namtext, tmptext) + namtext = tmptext + + # Identify new variables + vars = data.keys() + newvars = list(set(vars) - set(subvars)) + newvars.sort() + + # Append new vars to namid + lines = namtext.split("\n") + for v in newvars: + newline = " %s = %s" % (v, data[v]) + lines.insert(-1, newline) + newtext = "\n".join(lines) + + # Replace old namtext with new namtext + text = text.replace(namtext, newtext) + return text + +def replace(text, data, convert=True): + """Edits existing variables. + + Pattern matches and substitutes variables inside + a string of text. This is independent of namid and + as such is useful for modifying existing variables. + To append new variables the :func:`update` function + is required. + + >>> text = ''' + ... &namobs + ... ln_sst = .TRUE. ! Logical switch for SST observations + ... / + ... ''' + >>> data = {"ln_sst": ".FALSE."} + >>> print replace(text, data) + <BLANKLINE> + &namobs + ln_sst = .FALSE. ! Logical switch for SST observations + / + <BLANKLINE> + + .. note :: This does not append new variables to a namelist + + :param text: string to process + :param data: dictionary with which to modify **text** + :keyword convert: Sanitizes input data before replacement takes place + + :returns: string with new data values + + .. seealso:: :func:`update`, :func:`sanitize` + """ + if convert: + data = sanitize(data) + for k, v in data.iteritems(): + pat = r"(%s\s*=\s*).+?(\s*[!\n])" % (k,) + repl = r"\g<1>%s\g<2>" % (v,) + text = re.sub(pat, repl, text) + return text + +def variables(text): + """Retrieves dictionary of variables in text. + + >>> text = ''' + ... &namobs + ... ln_sst = .TRUE. ! Logical switch for SST observations + ... / + ... ''' + >>> variables(text) + {'ln_sst': '.TRUE.'} + + :param text: Input text to process + + :returns: A dictionary of variable, value pairs. + + """ + data = {} + pairs = re.findall(r"\n\s*(\w+)\s*=\s*(.+?)\s*(?=[!\n])", text) + for key, value in pairs: + data[key] = value + return data + +def namelists(text): + """Retrieves dictionary of namelists in text. + + Useful for isolating sub-namelists. + + >>> text = ''' + ... &namobs + ... ln_sst = .TRUE. ! Logical switch for SST observations + ... / + ... ''' + >>> namelists(text) + {'namobs': '&namobs\\n ln_sst = .TRUE. ! Logical switch for SST observations\\n/'} + + :param text: Input text to process + + :returns: A dictionary of id, text block key, value pairs + + """ + # Boundary case + if text.startswith("&"): + text = "\n" + text + # Regular expression + results = re.findall(r"\n(&(\w+).*?\n/)", text, re.DOTALL) + data = {} + for content, namid in results: + data[namid] = content + return data + +def tostring(data): + """Maps standard Python data to Fortran namelist format. + + >>> tostring([1, 2, 3]) + '1 2 3' + >>> tostring(["foo.nc", "bar.nc"]) + "'foo.nc', 'bar.nc'" + >>> tostring(True) + '.TRUE.' + + :param data: Input Python data + + :returns: Namelist formatted string + + .. seealso:: :func:`sanitize` + """ + if isinstance(data, list): + if all_numeric(data): + delim = " " + else: + delim = ", " + text = delim.join([convert(item) for item in data]) + else: + text = convert(data) + return text + +def all_numeric(inputs): + # Checks all list entries are numbers + flag = True + for input in inputs: + if not isinstance(input, Number): + flag = False + break + return flag + +def numeric(word): + # Tests input string is numeric data + parts = word.split(" ") + try: + map(float, parts) + flag = True + except ValueError: + flag = False + return flag + +def logical(word): + # Tests input string is numeric data + if word.upper() in [".FALSE.", ".TRUE."]: + flag = True + else: + flag = False + return flag + +def listed(word): + # Tests input string is not a list + if ("," in word) or (" " in word): + flag = True + else: + flag = False + return flag + +def quote(word): + word = str(word) + if not quoted(word): + word = "'%s'" % (word,) + return word + +def convert(word): + # Conversion function + if isinstance(word, str): + if (quoted(word) or numeric(word) + or logical(word) or listed(word)): + result = "%s" % (word,) + else: + result = quote(word) + elif isinstance(word, bool): + if word: + result = ".TRUE." + else: + result = ".FALSE." + else: + result = str(word) + return result + +def quoted(word): + # Checks if string begins/ends with quotation marks + if (word.startswith("'") and word.endswith("'")): + flag = True + elif (word.startswith('"') and word.endswith('"')): + flag = True + else: + flag = False + return flag + +def same_type(data): + # True if all entries are the same type + types = map(type, data) + if len(set(types)) == 1: + flag = True + else: + flag = False + return flag + +def sanitize(data): + """Converts dictionary values into Fortran namelist format. + + This is a more typical way to prepare data for inclusion in + a Fortran namelist. Instead of manually applying :func:`tostring` + to every element of the input data, **sanitize** fixes the entire + data set. + + >>> sanitize({"x": True}) + {'x': '.TRUE.'} + >>> + + :param data: Dictionary to convert + + :returns: Dictionary whose values are in Fortran namelist format + + .. seealso:: :func:`tostring` + """ + replacements = [(k, tostring(v)) for k, v in data.items()] + data.update(replacements) + return data + +def new(namid, data=None, convert=True): + """Creates a new Fortran namelist + + >>> new("namobs") + '&namobs\\n/\\n' + >>> print new("namobs") + &namobs + / + <BLANKLINE> + + :param namid: Name for the new namelist + + :keyword data: Specifies an initial dictionary with which to + populate the namelist + :type data: dict + :keyword convert: Sanitizes input data before replacement takes place + + :returns: string representation of a Fortran namelist + """ + text = "&{namid}\n/\n".format(namid=namid) + if data is not None: + text = update(namid, text, data, convert=convert) + return text + +if __name__ == '__main__': + import doctest + doctest.testmod() + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/ooo.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/ooo.py new file mode 100755 index 0000000000000000000000000000000000000000..2cdaee6a995870926de9404cbddb6d02a52c9380 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/ooo.py @@ -0,0 +1,124 @@ +#!/usr/bin/env python2.7 + +import os +import shutil + +# Local imports +import locator +import nml +import run + +def parse_args(): + import argparse + parser = argparse.ArgumentParser() + parser.add_argument("date", metavar="DATE", + help="Run date.") + parser.add_argument("-w", "--work-dir", default=os.getcwd()) + parser.add_argument("-f", "--forecast-types", default="forecast", + help="Choice of forecast,persistence,climatology") + parser.add_argument("-l", "--lead-times", default="12", + help="Forecast lead times") + parser.add_argument("-o", "--obs-types", default="profbfiles", + help="Choice of namobs types.") + parser.add_argument("--class4", dest="ln_cl4", action="store_true", + help="Flag to choose class 4 file outputs") + parser.add_argument("--dry-run", action="store_true", + help="Flag to test namelist building without submitting.") + parser.add_argument("--cmd", dest="command", default="./opa", + help="Submit task to run.") + parser.add_argument("-v", "--verbose", action="store_true", + help="Prints difference between before and after namelists.") + parser.add_argument("namelist", metavar="NAMELIST", + help="NEMO namelist to edit.") + args = parser.parse_args() + args.forecast_types = args.forecast_types.split(',') + args.obs_types = args.obs_types.split(',') + args.lead_times = map(int, args.lead_times.split(',')) + return args + +def printdiff(text1, text2): + # Provides nice text difference summary of namelists + import difflib + lines1 = text1.splitlines() + lines2 = text2.splitlines() + d = difflib.Differ() + result = list(d.compare(lines1, lines2)) + text = '\n'.join(result) + print text + +def main(): + args = parse_args() + date = args.date + print "Processing", args.namelist, " for", args.date + + # Move to working directory + if not os.path.exists(args.work_dir): + os.makedirs(args.work_dir) + os.chdir(args.work_dir) + + # Collect forecast files + types = args.forecast_types + lead_times = args.lead_times + namooo, namcl4 = locator.forecasts(date=date, + types=types, + lead_times=lead_times) + + # Process NEMO namelist + text = nml.reader(args.namelist) + sublists = nml.namelists(text) + + # Verbose save original text + if args.verbose: + original_text = text + + # namooo + if "namooo" not in sublists: + # Attach boilerplate + text += nml.new("namooo") + text = nml.update("namooo", text, data=namooo) + + # namcl4 + if "namcl4" not in sublists: + # Attach boilerplate + text += nml.new("namcl4") + namcl4["cl4_leadtime"] = lead_times + namcl4["cl4_date"] = nml.quote(date) + namcl4["cl4_match_len"] = len(namcl4["cl4_vars"]) + namcl4["cl4_fcst_len"] = len(namcl4["cl4_leadtime"]) + # Add naming convention + namcl4["cl4_sys"] = "FOAM" + namcl4["cl4_cfg"] = "orca025" + namcl4["cl4_vn"] = "'1.0'" + namcl4["cl4_prefix"] = "class4" + namcl4["cl4_contact"] = "example@example.com" + namcl4["cl4_inst"] = "institute" + text = nml.update("namcl4", text, data=namcl4) + + # namrun + namrun = {"nn_date0": nml.quote(date)} + text = nml.update("namrun", text, data=namrun) + + # namobs + namobs = locator.observations(date=date, + types=args.obs_types) + namobs["ln_cl4"] = args.ln_cl4 + text = nml.update("namobs", text, data=namobs) + + # Verbose print namelist differences + if args.verbose: + printdiff(original_text, text) + + # pipe text to file + tmp = args.namelist+".tmp" + nml.writer(tmp, text) + shutil.move(tmp, args.namelist) + + # Run job + if not args.dry_run: + run.submit(command=args.command) + + + +if __name__ == '__main__': + main() + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/run.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/run.py new file mode 100644 index 0000000000000000000000000000000000000000..2eb162845240b6884838f652d2a0e2b61773bec6 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/run.py @@ -0,0 +1,27 @@ +""" + +The NEMO offline observation operator is built and runs similarly to the +online NEMO model. + +""" +import subprocess +import shlex +import os + +class SubmitError(Exception): + pass + +def submit(command="./opa"): + """Simple function that runs the code. + + This can be customised based on the particular environment + used to submit MPI or serial tasks. For simplicity, this + function calls opa. + + By default, this program runs ``./opa``. + + :returns: retcode + """ + retcode = subprocess.call(shlex.split(command)) + return retcode + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/test_nml.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/test_nml.py new file mode 100755 index 0000000000000000000000000000000000000000..99cb4ea8a4617ac1c3625d7fff9ae30450f6aa74 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/ooo/test_nml.py @@ -0,0 +1,248 @@ +#!/usr/bin/env python2.7 +import unittest +import nml + +def version(vn): + # Converts module version string to int tuple as PEP-440 + return tuple(map(int, vn.split("."))) + +HEADER = """ +!! ===================================== +!! An example FORTRAN 90 namelist +!! ===================================== +&namex +""" +NOHEADER = "&namex\n" +LOGIC = " ln_test = .TRUE. ! Comment\n" +NUMERIC = " nn_off_idx = 1 2 3\n" +NOSPACE = " nn_off_idx=1 2 3\n" +NEGATIVE = " nn_off_idx = -1 -2 -3\n" +LIST = " off_files = 'a.nc' 'b.nc' 'c.nc' ! Comment\n" +STRING = ' contact = "example@nowhere.com" ! Comment\n' +COMMENT = ' ! x = y ' +FOOTER = "/\n" +NOFOOTER = "/" + +class TestNamelist(unittest.TestCase): + def setUp(self): + self.logic_text = "\n".join([HEADER, LOGIC, FOOTER]) + self.numeric_text = "\n".join([HEADER, NUMERIC, FOOTER]) + self.nospace_text = "\n".join([HEADER, NOSPACE, FOOTER]) + self.neg_numeric_text = "\n".join([HEADER, NEGATIVE, FOOTER]) + self.list_text = "\n".join([HEADER, LIST, FOOTER]) + self.mix_text = "\n".join([HEADER, LIST, NUMERIC, FOOTER]) + self.string_text = "\n".join([HEADER, STRING, FOOTER]) + self.comment_text = "\n".join([HEADER, COMMENT, FOOTER]) + self.no_trail_text = "\n".join([HEADER, NUMERIC, LIST, NOFOOTER]) + + def test_should_handle_footer(self): + data = nml.variables(self.no_trail_text) + truth = {"nn_off_idx": "1 2 3", + "off_files": "'a.nc' 'b.nc' 'c.nc'"} + self.assertDictEqual(data, truth) + + def test_mix_data(self): + data = nml.variables(self.mix_text) + truth = {"nn_off_idx": "1 2 3", + "off_files": "'a.nc' 'b.nc' 'c.nc'"} + self.assertDictEqual(data, truth) + + def test_comment_data(self): + data = nml.variables(self.comment_text) + truth = {} + self.assertDictEqual(data, truth) + + def test_logical_data(self): + data = nml.variables(self.logic_text) + truth = {"ln_test": ".TRUE."} + self.assertDictEqual(data, truth) + + def test_numeric_data(self): + data = nml.variables(self.numeric_text) + truth = {"nn_off_idx": "1 2 3"} + self.assertDictEqual(data, truth) + + def test_nospace_data(self): + data = nml.variables(self.nospace_text) + truth = {"nn_off_idx": "1 2 3"} + self.assertDictEqual(data, truth) + + def test_negative_numeric_data(self): + data = nml.variables(self.neg_numeric_text) + truth = {"nn_off_idx": "-1 -2 -3"} + self.assertDictEqual(data, truth) + + def test_string_data(self): + data = nml.variables(self.string_text) + truth = {"contact": '"example@nowhere.com"'} + self.assertDictEqual(data, truth) + + def test_list_data(self): + data = nml.variables(self.list_text) + truth = {"off_files": "'a.nc' 'b.nc' 'c.nc'"} + self.assertDictEqual(data, truth) + + def test_replace_variable_comment(self): + FIXTURE = " x = 'y' ! comment \n" + RESULT = " x = 'z' ! comment \n" + text = nml.replace(FIXTURE, {"x": "z"}) + self.assertEqual(text, RESULT) + + def test_replace_variable_no_comment(self): + FIXTURE = " x = 'y' \n" + RESULT = " x = 'z' \n" + text = nml.replace(FIXTURE, {"x": "z"}) + self.assertEqual(text, RESULT) + + def test_replace_variable_no_space(self): + FIXTURE = " x='y' \n" + RESULT = " x='z' \n" + text = nml.replace(FIXTURE, {"x": "z"}) + self.assertEqual(text, RESULT) + + def test_replace_variable_no_space_comment(self): + FIXTURE = " x='y' ! comment \n" + RESULT = " x='z' ! comment \n" + text = nml.replace(FIXTURE, {"x": "z"}) + self.assertEqual(text, RESULT) + + @unittest.skipIf(version(nml.__version__) < (1, 0), + "Not implemented in this version") + def test_multiline_variable_replace(self): + # As a result of a code review + FIXTURE = " x = 1, \n 2" + RESULT = " x = 3, \n 4" + text = nml.replace(FIXTURE, {"x": [3,4]}) + self.assertEqual(text, RESULT) + +class TestCombinedNamelists(unittest.TestCase): + def setUp(self): + self.minimal = """&namone +/""" + self.blanks = """ +&namone +/ +&namtwo +/ +""" + self.contents = """ +&namone +Content 1 +/ +&namtwo +Content 2 +/ +""" + self.contents_slash = """ +&namone +Content 1 ! Y/N +/ +&namtwo +Content 2 +/ +""" + def test_should_select_name_from_minimal_namelist(self): + data = nml.namelists(self.minimal) + result = {"namone": "&namone\n/"} + self.assertDictEqual(data, result) + + def test_should_select_names(self): + data = nml.namelists(self.blanks) + result = {"namone": "&namone\n/", + "namtwo": "&namtwo\n/"} + self.assertDictEqual(data, result) + + def test_should_select_contents(self): + data = nml.namelists(self.contents) + result = {"namone": "&namone\nContent 1\n/", + "namtwo": "&namtwo\nContent 2\n/"} + self.assertDictEqual(data, result) + + def test_should_select_contents_with_forward_slash(self): + data = nml.namelists(self.contents_slash) + result = {"namone": "&namone\nContent 1 ! Y/N\n/", + "namtwo": "&namtwo\nContent 2\n/"} + self.assertDictEqual(data, result) + + +class TestToString(unittest.TestCase): + def setUp(self): + self.char_list = ["a.nc", "b.nc", "c.nc"] + self.num_list = [1, 3, 7] + self.char = "foo@bar.com" + self.num = 10 + self.mixed_list = ["foo.nc", -1, True] + self.mixed_str_list = map(nml.quote, ["foo.nc", "-1", ".TRUE."]) + + def test_should_format_mixed_list(self): + data = nml.tostring(self.mixed_list) + result = "'foo.nc', -1, .TRUE." + self.assertEqual(data, result) + + def test_should_format_numeric_list(self): + data = nml.tostring(self.num_list) + result = "1 3 7" + self.assertEqual(data, result) + + def test_should_format_character_list(self): + data = nml.tostring(self.char_list) + result = "'a.nc', 'b.nc', 'c.nc'" + self.assertEqual(data, result) + + def test_should_format_strings(self): + data = nml.tostring(self.char) + result = "'%s'" % (self.char,) + self.assertEqual(data, result) + + def test_should_format_numbers(self): + data = nml.tostring(self.num) + result = str(self.num) + self.assertEqual(data, result) + + def test_should_not_format_numeric_string(self): + input = "3.14159" + self.assertEqual(nml.tostring(input), input) + + def test_should_format_logicals(self): + data = nml.tostring(True) + result = ".TRUE." + self.assertEqual(data.upper(), result) + + def test_should_not_format_string_of_list_data(self): + for input in ["1 2 3", "1, 2, 3", ".TRUE. .FALSE."]: + case = nml.tostring(input) + self.assertEqual(case, input) + + def test_should_treat_mixed_numeric_character_data_as_character(self): + case = nml.tostring(self.mixed_str_list) + result = "'foo.nc', '-1', '.TRUE.'" + self.assertEqual(case, result) + +class TestUpdateNamelist(unittest.TestCase): + def setUp(self): + self.empty = """ +&namone +/ +""" + self.single = """ +&namone + x = 'y' +/ +""" + self.single_update = """ +&namone + x = 'z' +/ +""" + + def test_should_append_new_variable_to_namelist(self): + trial = nml.update("namone", self.empty, {"x": "'y'"}) + self.assertEqual(trial, self.single) + + def test_should_update_existing_variables(self): + trial = nml.update("namone", self.single, {"x": "'z'"}) + self.assertEqual(trial, self.single_update) + +if __name__ == '__main__': + unittest.main() + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/OOO/setup.py b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/setup.py new file mode 100644 index 0000000000000000000000000000000000000000..7e528ca35e8f93dc70e2f424f7a44bbac4b4c1ab --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/OOO/setup.py @@ -0,0 +1,9 @@ +from distutils.core import setup +setup(name='Offline observation operator', + version='0.1', + description='NEMO Offline observation operator', + author='Andrew Ryan', + author_email='andrew.ryan@metoffice.gov.uk', + packages=['ooo',], + scripts=['bin/ooo'], + ) diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/README b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/README new file mode 100644 index 0000000000000000000000000000000000000000..356e49c13c1c251d5815e6e880bfe2baac4b69bd --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/README @@ -0,0 +1,12 @@ +dataplot.pro - IDL widget based program to read in netcdf feedback and data +files and plot observation and background values. + +example calls: + +dataplot,filenamearray +dataplot,filenamearray,/batchplot,/gif +dataplot,filenamearray,/batchplot,/ps + +use + +man,'dataplot' in idl for more information diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/colorbar_idl.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/colorbar_idl.pro new file mode 100644 index 0000000000000000000000000000000000000000..21baa86d57a707bfa31717dfa765f1c5329adcb9 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/colorbar_idl.pro @@ -0,0 +1,212 @@ +;+ +PRO colorbar_idl, datain, colors, lablevels, datalevels, data=data, $ + textcolor=textcolor, mincolor=mincolor, position=position +;-------------------------------------------------------------------- +; datain - gives the range of values which are represented by colors +; colors - color values +; lablevels - label levels +; +; Author: D. J. Lea Nov 2008 +;-------------------------------------------------------------------- + +; keep current graphics keywords + +psave=!p +xsave=!x +ysize=!y + + if (n_elements(mincolor) eq 3) then $ + TVLCT,mincolor(0),mincolor(1),mincolor(2),0 + + mx=max(datain,min=mn) + + normal=1 + if (keyword_set(data)) then normal=0 + + + if (keyword_set(data)) then begin ; data coords + y1 = !y.crange(0)-0.1*(!y.crange(1)-!y.crange(0)) + y2 = !y.crange(0)-0.05*(!y.crange(1)-!y.crange(0)) + x1 = !x.crange(0)+0.1*(!x.crange(1)-!x.crange(0)) + x2 = !x.crange(0)+0.9*(!x.crange(1)-!x.crange(0)) + endif else begin ; normal coords + y1 = !y.window(0)-0.11*(!y.window(1)-!y.window(0)) + y2 = !y.window(0)-0.05*(!y.window(1)-!y.window(0)) +;; y1 = !y.window(0)+0.05*(!y.window(1)-!y.window(0)) +;; y2 = !y.window(0)+0.1*(!y.window(1)-!y.window(0)) + x1 = !x.window(0)+0.076*(!x.window(1)-!x.window(0)) + x2 = !x.window(0)+0.924*(!x.window(1)-!x.window(0)) + endelse + + if (n_elements(position) eq 4) then begin + coords=position + endif else begin + coords=[x1,y1,x2,y2] + endelse + + print,'coords: ',coords + print, 'normal: ',normal, ' data: ',keyword_set(data) + +; nb = N_ELEMENTS(colors) +; x=coords(0)+(coords(2)-coords(0))*findgen(nb+1)/nb +; +; FOR i=0,nb-1 DO BEGIN +;; print,colors(i) +; polyfill, transpose([[x(i),x(i+1),x(i+1),x(i),x(i)],$ +; [coords(1),coords(1),coords(3),coords(3),coords(1)]]),$ +; color=colors(i), data=data, normal=normal +; ENDFOR + +;Position is always in normal units will need to do a conversion if +; data units required... + + fill=0 + cell_fill=1 + + maxdat=mx + mindat=mn + if (n_elements(datalevels) gt 0) then begin + maxdat=max(datalevels,min=mindat) +; mindat=mindat+(1./!d.table_size)*(maxdat-mindat) +; print,'datalevels ',datalevels + endif + +; fix to prevent zero contour range + if (maxdat eq mindat) then begin + if (maxdat eq 0) then begin + maxdat = maxdat + 1e-20 + mindat = mindat - 1e-20 + endif else begin + maxdat = maxdat * 1.01 + mindat = mindat * 0.99 + if (maxdat lt mindat) then begin + tmp = mindat + mindat = maxdat + maxdat = tmp + endif + endelse + endif + + array1d=(findgen(!d.table_size+1))/!d.table_size*(maxdat-mindat)+mindat +; array1d=(findgen(!d.table_size+10)-10)/!d.table_size*(maxdat-mindat)+mindat + + print,'!d.table_size ',!d.table_size + +; print,'array1d ',array1d + print,'min array1d ',min(array1d), max(array1d) + print,'datain ',datain + print,'mx ',mx,' mn ',mn + + if (n_elements(datalevels) gt 0) then print, 'datalevels ', datalevels + + array2d=array1d#replicate(1,2) + if (n_elements(datalevels) lt 2) then datalevels=array1d + +; print, 'datalevels ', datalevels +; print,'cell_fill ',cell_fill + + TVLCT, R, G, B, /get + TVLCT,R(1),G(1),B(1),0 ; bodge fix for wrong black contour + + if (n_elements(data) gt 0) then print,'data = ',data + if (n_elements(normal) gt 0) then print,'normal = ',normal + print,coords + +; draw a few times to remove gaps + nel=n_elements(datalevels) + print, 'datalevels ',datalevels(0), datalevels(nel-1), nel + print, 'array2d ',min(array2d), max(array2d) + if (datalevels(0) lt datalevels(nel-1)) then begin + for i=0,2 do begin + contour, array2d, levels=datalevels, fill=fill, cell_fill=cell_fill, $ + POSITION=coords, /noerase, xstyle=5, ystyle=5, data=data, normal=normal + endfor + endif + + TVLCT,R(0),G(0),B(0),0 + + numlablevels=n_elements(lablevels) + sigfig=1 + strlabs=strarr(numlablevels) + + repeat begin + widstr=strtrim(string(sigfig+8),2) +; output 2 significant figures except if 0. + + for i = 0, numlablevels-1 do begin + format='(g'+widstr+'.'+strtrim(string(sigfig),2)+')' + strlabs(i)=strcompress(string(lablevels(i),format=format),/remove_all) + +; print,i,'.',strlabs(i),'.',format + + if (strmid(strlabs(i),0,1) eq '0' or strmid(strlabs(i),0,2) eq '-0') then begin + format='(g'+widstr+'.'+strtrim(string(sigfig-1),2)+')' + strlabs(i)=strcompress(string(lablevels(i),format=format),/remove_all) +; print,i,'.',strlabs(i),'.',format + endif + +; print,i,'.',strlabs(i),'.',format + +; trim out spaces + strlabs(i)=strtrim(strlabs(i),2) + + strtemp=strlabs(i) +; strip off last two characters if there is 0 after the decimal place +; with a number thereafter + ptpos=strpos(strtemp,'.0') + len=strlen(strtemp) +; if ptpos gt 0 then print,ptpos,len + if ptpos gt 0 and len-2 ge ptpos then begin + strlabs(i)=strmid(strtemp,0,len-1) + endif + +;if the remaining last character is a point (.) then get rid of it + ptpos=strpos(strlabs(i),'.') + len=strlen(strlabs(i)) +; print,ptpos, len + if ptpos gt 0 and ptpos eq len-1 then begin + strlabs(i)=strmid(strlabs(i),0,len-1) + endif + + endfor +; print,strlabs +; print,strlen(strlabs) + sigfig=sigfig+1 + whe=where(strpos(strlabs,'e') gt 0, numexps) +; print,'whe ',whe, numexps +; all labels should be unique +; should be all exps or none +; give up if sigfigs 255 + endrep until (n_elements(unique(strlabs)) eq numlablevels $ + and (numexps eq 0 or numexps eq numlablevels) $ + or sigfig gt 255) + + pcharsize=!p.charsize + if (pcharsize lt 1) then pcharsize=1 +; tolx=0.01*pcharsize*(!x.crange(1)-!x.crange(0)) + tolx=0.01*(x2-x1) + + ypos = y1-0.02*pcharsize*(!y.crange(1)-!y.crange(0)) + for i = 0, numlablevels-1 do begin +; xpos = x1 + float(i)/float(n_elements(lablevels)-1)*(x2-x1) + xpos = x1 + (lablevels(i)-mn)/(mx-mn)*(x2-x1) ; position labels correctly relative + + if (xpos ge x1-tolx and xpos le x2+tolx) then begin ; don't print any labels off the edge + +; xyouts, xpos, ypos, strcompress(string(lablevels(i),format='(f7.2)'),/remove_all), $ +; color=!d.table_size-1, data=data, normal=normal, align=0.5 + + if (n_elements(textcolor) eq 3) then $ + TVLCT,textcolor(0),textcolor(1),textcolor(2),0 +; print,'xyouts ',xpos, ypos, ' ',strlabs(i) + xyouts, xpos, ypos, strlabs(i), data=data, normal=normal, align=0.5 + endif + + endfor + +; restore graphics keywords +!p=psave +!x=xsave +!y=ysize + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot.pro new file mode 100644 index 0000000000000000000000000000000000000000..bfb8d5452a0399fd2b71458878914c97f923d593 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot.pro @@ -0,0 +1,4517 @@ +;+---------------------------------------------------------------------------------------- +; dataplot.pro +; IDL widget based plotting routine for plotting observation and background values +; +; Author: D. J. Lea - Feb 2008 +; +;+---------------------------------------------------------------------------------------- +;example calls: +; +;dataplot,filenamearray +;dataplot,filenamearray,/batch,/gif ; plots data directly to a gif +;dataplot,filenamearray,/batch,/ps ; plots data directly to a ps +;dataplot,filenamearray,/batch,area=area ; area 4 element array or descriptive string +;dataplot, longitude, latitude, deparr, dayarr, valarr, bkgarr +;dataplot, [longitude, latitude, deparr, dayarr, valarr, bkgarr], rmdi=rmdi, filename=filename +; +;optional keywords +;area descriptive string or array [minlon,minlat,maxlon,maxlat] +;typeplot=1-5 plot obs-bkg or obs bkg etc +;alldays=1 plot all days otherwise just plot first day +;depths [depmin,depmax] in metres +;showmdt plot mdt +;obstypeselect string array of selected obs types to plot +;printobstypes keyword to print unique obs types to the terminal +; +;+----------------------------------------------------------------------------------------- +; Note the upper two slider bars control the depth range +; the lower two slider bars control the day range +;------------------------------------------------------------------------------------------ + + +; Event-handling procedure. +PRO dataplot_event, ev + + ; Retrieve the anonymous structure contained in the user value of + ; the top-level base widget. + + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + +; print,uval + +; print,'event' +; print,stash.depmin + +; position = [!X.Window[0], !Y.Window[0], !X.Window[1], !Y.Window[1]] +; print,position +; xsize = (position(2) - position(0)) * !D.X_VSIZE +; ysize = (position(3) - position(1)) * !D.Y_VSIZE +; xstart = position(0) * !D.X_VSIZE +; ystart = position(1) * !D.Y_VSIZE +; print,xsize,ysize,xstart,ystart + + ; If the event is generated in the draw widget, update the + ; label values with the current cursor position and the value + ; of the data point under the cursor. Note that since we have + ; passed a pointer to the image array rather than the array + ; itself, we must dereference the pointer in the 'image' field + ; of the stash structure before getting the subscripted value. + + IF (TAG_NAMES(ev, /STRUCTURE_NAME) eq 'WIDGET_DRAW') THEN BEGIN + xdev= ev.X + ydev= ev.Y + +; print, 'xdev ',xdev, ' ydev ',ydev + +; convert the pointer position to a data position + arr=CONVERT_COORD( xdev, ydev, /device, /to_data) + xdata=arr(0) + ydata=arr(1) + +; print, xdata , ydata + +; print, 'xdev: ',xdev,' ydev: ',ydev,' xdata: ',xdata, ' ydata: ',ydata +; WIDGET_CONTROL, stash.label1, $ +; SET_VALUE='X position: ' + STRING(xdata) +; WIDGET_CONTROL, stash.label2, $ +; SET_VALUE='Y position: ' + STRING(ydata) +;; WIDGET_CONTROL, stash.label3, $ +;; SET_VALUE='Value: ' + $ +;; STRING((*stash.imagePtr)[ev.X, ev.Y], FORMAT='(Z12)') +; WIDGET_CONTROL, stash.label3, $ + + + ; What kind of event is this? + +;eventTypes = ['DOWN', 'UP', 'MOTION'] +;0 1 2 +;thisEvent = ev.type + +;print, 'ev.type ',ev.type + +CASE ev.type OF + 0: BEGIN +; dragbox start + print, 'down ',xdev,ydev, xdata, ydata + ; Turn motion events on for the draw widget. + + Widget_Control, stash.draw, Draw_Motion_Events=1 + + ; dragbox + ; Create a pixmap. Store its ID. Copy window contents into it. + + Window, /Free, /Pixmap, XSize=stash.im_size(1), YSize=stash.im_size(2) + stash.pixID = !D.Window + Device, Copy=[0, 0, stash.im_size(1), stash.im_size(2), 0, 0, stash.drawID] +; WSet, stash.drawID + + print,stash.im_size(0), stash.im_size(1), stash.im_size(2), stash.pixID, stash.drawID + + stash.xcorn=xdev + stash.ycorn=ydev + + stash.xdatacorn=xdata + stash.ydatacorn=ydata + +; RETURN + ENDCASE + 1: BEGIN +; dragbox close + print, 'up ',xdev,ydev, xdata, ydata + ; Turn draw motion events off. Clear any events queued for widget. + + Widget_Control, stash.draw, Draw_Motion_Events=0, Clear_Events=1 + + WSet, stash.drawID + Device, Copy=[0, 0, stash.im_size(1), stash.im_size(2), 0, 0, stash.pixID] + WDelete, stash.pixID + + ; zoom in + +; dragbox +; avoid zooming if no dragging has occurred + pixdiffx = min([abs(stash.xcorn-xdev),abs(stash.ycorn-ydev)]) + print, '** Pixdiffx ',pixdiffx, stash.xcorn-xdev, stash.ycorn-ydev + if (pixdiffx gt 1 and finite(xdata) and finite(ydata)) then begin + + minxdata = min([stash.xdatacorn, xdata], max=maxxdata) + minydata = min([stash.ydatacorn, ydata], max=maxydata) + + + if (minxdata ge -180 and maxxdata le 360 and minydata ge -90 and maxydata le 90) then begin + + stash.xrange=[minxdata,maxxdata] + stash.yrange=[minydata,maxydata] + + plotpoints,stash + endif + endif + +; RETURN + ENDCASE + 2: BEGIN +; drag box motion +; print, 'motion: ',ev.x, ev.y + + WSet, stash.drawID + Device, Copy=[0, 0, stash.im_size(1), stash.im_size(2), 0, 0, stash.pixID] + + + sx = stash.xcorn + sy = stash.ycorn + + PlotS, [sx, sx, xdev, xdev, sx], [sy, ydev, ydev, sy, sy], /Device, $ + Color=!p.color +; Color=255 + + ENDCASE + +; RETURN + 7: begin + print,'mouse wheel event ',ev.clicks + if (ev.clicks eq 1 or ev.clicks eq -1) then begin + print,'zoom in/out' + + print,'stash.depmin ',stash.depmin + + print,'xdata ',xdata + + if (finite(xdata) and finite(ydata)) then begin + +; make an adjustment if we're in the Pacific + xrange=stash.xrange + typeproj=stash.typeproj + if (xrange(1) gt 180 and typeproj eq 1) then if (xdata lt 0) then xdata=xdata+360 + + + oxrange=stash.xrange + oyrange=stash.yrange + + dataplot_zoom, stash, xdata, ydata, ev.clicks + +; plot only if a change has been made + if (stash.xrange(0) ne oxrange(0) or stash.yrange(0) ne oyrange(0) $ + or stash.xrange(1) ne oxrange(1) or stash.yrange(1) ne oyrange(1)) then $ + plotpoints, stash + + endif + + endif + + ENDCASE +ENDCASE + + + + + + + + +; SET_VALUE='Value: ' + STRING(ev.release) + +; if(ev.release eq 1) then begin +; print,'left click - search for nearest point' + if(ev.release eq 1 or ev.release eq 4) then begin ; mouse click + +; might want a generalised point selection routine +; for this routine and for plotpoints + + print,'xdata ',xdata, ' ydata ',ydata + print,'xdev ',xdev, 'ydev ',ydev + + if (finite(xdata) and finite(ydata)) then begin + + print, 'finite' + + xarr1=stash.xarr + yarr1=stash.yarr + dep1=stash.dep + dayarr=stash.dayarr + daymin=stash.daymin + daymax=stash.daymax + obstypes1=stash.obstypes + xrange=stash.xrange + yrange=stash.yrange + xs=xrange(1)-xrange(0) + ys=yrange(1)-yrange(0) + rmdi=stash.rmdi +; if (stash.salinity eq 0) then begin +; obs1=stash.obs +; bkg1=stash.bkg +; qcarr1=stash.qcarr +; endif else begin +; obs1=stash.obs2 +; bkg1=stash.bkg2 +; qcarr1=stash.qcarr2 +; endelse + typeproj=stash.typeproj + +; make an adjustment if we're in the Pacific + if (xrange(1) gt 180 and typeproj eq 1) then if (xdata lt 0) then xdata=xdata+360 + +; set reasonable dist criteria + + distmax=(xs/100.)^2+(ys/100.)^2 +; print,'distmax ',distmax + + + selpoints,stash,lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr + +; get max min daysel + mindaysel=min(daysel, max=maxdaysel) + +; print, 'selpoints ',obnumsel + + if (n_elements(lonsel) gt 0) then begin + dist=((lonsel-xdata)^2+(latsel-ydata)^2) + res=min(dist,whd) ; whd is the minumum dist point index + +; print,lonsel + + xselstr="" + yselstr="" + valselstr="" + qcselstr="" + datestr="" + obnumselstr="" + mindatestr="" + maxdatestr="" + +; print,'whd(0) ',whd(0) +; print,'res ',res, ' distmax ',distmax + + obstypstr="" + if (whd(0) gt -1 and res lt distmax) then begin + xsel=lonsel(whd) + ysel=latsel(whd) + + print,'xsel ',xsel,' ysel ',ysel + ; make an adjustment if we're in the Pacific + if (xrange(1) gt 180 and typeproj eq 1) then if (xsel gt 180) then xsel=xsel-360 + + valsel=innovsel(whd) + qcsel=qcsel(whd) + datesel=daysel(whd) + obstypsel=obstypsel(whd) + obnumsel=obnumsel(whd) + + xselstr=string(xsel) + yselstr=string(ysel) + valselstr=string(valsel) + qcselstr=string(qcsel) +; datestr=string(datesel) + obstypstr=string(obstypsel(0)) + obnumselstr=string(obnumsel(0)) + print,'datesel(0) ',datesel(0) + print,'obnumsel(0) ',obnumsel(0) + jul_to_dtstr,datesel(0),datestr + jul_to_dtstr,mindaysel,mindatestr + jul_to_dtstr,maxdaysel,maxdatestr + + if (ev.release eq 4) then begin + + print,'ev.release ',ev.release + +; window + wh=where(xarr1 eq xsel and yarr1 eq ysel) + print,'xsel ',xsel +; print,'xarr1 ',xarr1 + dep2=dep1(wh) + + if (wh(0) gt -1) then begin + if (stash.density eq 0) then begin + + if (stash.salinity eq 0) then begin +; print,'salinity eq 0' + obs2=stash.obs(wh) + bkg2=stash.bkg(wh) + qcarr2=stash.qcarr(wh) + endif else begin +; print,'salinity eq 1' + obs2=stash.obs2(wh) + bkg2=stash.bkg2(wh) + qcarr2=stash.qcarr2(wh) + endelse + + endif else begin + + if (stash.filetype eq 'CRT') then begin + + bkgU=stash.bkg(wh) + bkgV=stash.bkg2(wh) + bkg2=sqrt(bkgU*bkgU + bkgV*bkgV) + + obsU=stash.obs(wh) + obsV=stash.obs2(wh) + obs2=sqrt(obsU*obsU + obsV*obsV) + + qcarr2=stash.qcarr(wh) + + endif else begin + +; print,'density eq 1' + bkgt=stash.bkg(wh) + bkgs=stash.bkg2(wh) + obst=stash.obs(wh) + obss=stash.obs2(wh) +; obs2=obst+obss +; bkg2=bkgt+bkgs + obs2=eos_nemo(obst,obss) + bkg2=eos_nemo(bkgt,bkgs) + wh2=where(bkgt eq rmdi or bkgs eq rmdi) + if (wh2(0) gt -1) then begin + obs2(wh2)=rmdi + bkg2(wh2)=rmdi + endif + qcarr2=max([[stash.qcarr(wh)],[stash.qcarr2(wh)]],dim=2) + + endelse + + endelse + +; val2=abs(obs1(wh)-bkg1(wh)) + val2=abs(obs2-bkg2) +; obs2=obs1(wh) +; bkg2=bkg1(wh) + obstype2=obstypes1(wh) +; qcarr2=qcarr1(wh) + dayarr2=dayarr(wh) +; val2=sqrt(val1(wh)^2) + +; print,'val2 ',val2(wh2) +; print,'dep2 ',dep2(wh2) +; plot,val2(wh2),dep2(wh2),ystyle=1,xstyle=1 + + profilewindow,dep2,val2,obs2,bkg2,obstype2,qcarr2,dayarr2,datestr,xselstr,yselstr,rmdi, salinity=stash.salinity, $ + plot_bad_obs=stash.plot_bad_obs, white_on_black=stash.white_on_black, coltable=stash.coltable, $ + depmax=stash.depmax, depmin=stash.depmin + + +; set graphics back to main window +; WSET, stash.drawID + print,'ev release' + plotpoints,stash + + endif ; wh(0)>-1 + + endif ; ev.release 4 (right mouse) + endif + endif ; left or right mouse click + + WIDGET_CONTROL, stash.label1, $ + SET_VALUE=stash.labt1 + strtrim(xselstr,1) + WIDGET_CONTROL, stash.label2, $ + SET_VALUE=stash.labt2 + strtrim(yselstr,1) + WIDGET_CONTROL, stash.label3, $ + SET_VALUE=typestr+': ' + strtrim(valselstr,1) + WIDGET_CONTROL, stash.label4, $ + SET_VALUE=stash.labt4 + strtrim(qcselstr,1) + WIDGET_CONTROL, stash.label5, $ + SET_VALUE=stash.labt5 + strtrim(datestr,1) + WIDGET_CONTROL, stash.label6, $ + SET_VALUE=stash.labt6 + strtrim(valselstr,1) +; WIDGET_CONTROL, stash.label7, $ +; SET_VALUE=stash.labt7 + strtrim(string(innovsd),1) + WIDGET_CONTROL, stash.label8, $ + SET_VALUE=stash.labt8 + strtrim(obstypstr,1) + WIDGET_CONTROL, stash.label9, $ + SET_VALUE=stash.labt9 + strtrim(obnumselstr,1) + WIDGET_CONTROL, stash.label10, $ + SET_VALUE=stash.labt10 + string(mindatestr) + ' ' + string(maxdatestr) + + endif else begin ; not finite + + print, 'not finite' + +; check for colorbar click + if (ydev lt 80) then begin + toplevel=stash.base + fmx=stash.fmx + fmn=stash.fmn + mx=stash.mx + mn=stash.mn + inputmxmnwindow, fmx, fmn, mx, mn, stash.rmdi, toplevel, success + if (success eq 1) then begin + stash.fmx=fmx + stash.fmn=fmn + plotpoints,stash + endif + endif + + endelse ; finite + + endif + + + +; print,tag_names(ev) +; print,ev.id +; print,ev.top +; print,ev.handler +; print,ev.type +; print,ev.press +; print,ev.release +; print,ev.clicks +; print,ev.modifiers +; print,ev.ch +; print,ev.key + + ENDIF ; end of widget draw events + + ; If the event is generated in a button, destroy the widget + ; hierarchy. We know we can use this simple test because there + ; is only one button in the application. + + +; IF (TAG_NAMES(ev, /STRUCTURE_NAME) eq 'WIDGET_COMBOBOX') THEN BEGIN +; IF (uval eq 'LEVELLIST') THEN BEGIN + + IF (uval eq 'LEVELCHOICE') THEN BEGIN + + stash.depmin=ev.value + + print,'levelchoice' + print, 'stash.depmin: ',stash.depmin + print, 'stash.depmax: ',stash.depmax + + if (stash.depmin ge stash.depmax) then begin + stash.depmax=stash.depmin + if (stash.depmax gt stash.depmaxl) then stash.depmax=stash.depmaxl + +;set sliderb position + WIDGET_CONTROL, stash.sliderb, set_value=stash.depmax + + endif + + + plotpoints, stash + + +; print,ev.index,widget_info(ev.id,/combobox_gettext) + + ENDIF + + IF (uval eq 'LEVELCHOICEB') THEN BEGIN + + stash.depmax=ev.value + + print,'levelchoiceb' + print, 'stash.depmin: ',stash.depmin + print, 'stash.depmax: ',stash.depmax + + if (stash.depmax le stash.depmin) then begin + stash.depmin=stash.depmax + if (stash.depmin lt stash.depminl) then stash.depmin=stash.depminl + +;set sliderb position + WIDGET_CONTROL, stash.slider, set_value=stash.depmin + + endif + + + plotpoints, stash + + +; print,ev.index,widget_info(ev.id,/combobox_gettext) + + ENDIF + + + IF (uval eq 'DATERANGE1') THEN BEGIN + + odaymin=stash.daymin + odaymax=stash.daymax + + stash.daymin=ev.value +; print, 'ev.drag ',ev.drag + +; set slider label + jul_to_dtstr,stash.daymin,dayminstr, /notime + WIDGET_CONTROL, stash.slider1label, $ + SET_VALUE='min date: '+dayminstr + + if (stash.daymin ge stash.daymax) then begin +; stash.daymax=stash.daymin+1 + stash.daymax=stash.daymin + if (stash.daymax gt stash.daymaxl) then stash.daymax=stash.daymaxl + +;set slider2 position + WIDGET_CONTROL, stash.slider2, set_value=stash.daymax +; set slider 2 label + jul_to_dtstr,stash.daymax,daymaxstr, /notime + WIDGET_CONTROL, stash.slider2label, $ + SET_VALUE='max date: '+daymaxstr + + + endif + + print,'daterange1' +; if (ev.drag eq 0) then + if (stash.daymin ne odaymin or stash.daymax ne odaymax) then plotpoints,stash + + ENDIF + IF (uval eq 'DATERANGE2') THEN BEGIN + + odaymin=stash.daymin + odaymax=stash.daymax + + stash.daymax=ev.value + +; set slider label + jul_to_dtstr,stash.daymax,daymaxstr, /notime + WIDGET_CONTROL, stash.slider2label, $ + SET_VALUE='max date: '+daymaxstr + + if (stash.daymax le stash.daymin) then begin +; stash.daymin=stash.daymax-1 + stash.daymin=stash.daymax + if (stash.daymin lt stash.dayminl) then stash.daymin=stash.dayminl + +;set slider1 position + WIDGET_CONTROL, stash.slider1, set_value=stash.daymin +; set slider 2 label + jul_to_dtstr,stash.daymin,dayminstr, /notime + WIDGET_CONTROL, stash.slider1label, $ + SET_VALUE='min date: '+dayminstr + + endif + + print,'daterange2' +; if (ev.drag eq 0) then + if (stash.daymin ne odaymin or stash.daymax ne odaymax) then plotpoints,stash + + ENDIF + + IF (uval eq "RADIO1") THEN BEGIN + print,'uval eq RADIO1' + stash.typeplot=1 + print, 'typeplot ',stash.typeplot + plotpoints,stash + ENDIF + IF (uval eq "RADIO2") THEN BEGIN + print,'uval eq RADIO2' + stash.typeplot=2 + print, 'typeplot ',stash.typeplot + plotpoints,stash + ENDIF + IF (uval eq "RADIO3") THEN BEGIN + print,'uval eq RADIO3' + stash.typeplot=3 + print, 'typeplot ',stash.typeplot + plotpoints,stash + ENDIF + IF (uval eq "RADIO4") THEN BEGIN + print,'uval eq RADIO4' + stash.typeplot=4 + print, 'typeplot ',stash.typeplot + plotpoints,stash + ENDIF + + IF (uval eq "RADIO5") THEN BEGIN + print,'uval eq RADIO5' + stash.ombtypeplot=1 + print, 'ombtypeplot ',stash.ombtypeplot + plotpoints,stash + ENDIF + IF (uval eq "RADIO6") THEN BEGIN + print,'uval eq RADIO6' + stash.ombtypeplot=2 + print, 'ombtypeplot ',stash.ombtypeplot + plotpoints,stash + ENDIF + IF (uval eq "RADIO7") THEN BEGIN + print,'uval eq RADIO7' + stash.ombtypeplot=3 + print, 'ombtypeplot ',stash.ombtypeplot + plotpoints,stash + ENDIF + + IF (uval eq "RADIO01") THEN BEGIN + print,'uval eq RADIO01' + stash.typeproj=1 + stash.xrange=stash.xrangedef + stash.yrange=stash.yrangedef + plotpoints,stash + ENDIF + IF (uval eq "RADIO02") THEN BEGIN + print,'uval eq RADIO02' + stash.typeproj=2 + stash.xrange=stash.xrangedef + stash.yrange=stash.yrangedef + plotpoints,stash + ENDIF + IF (uval eq "RADIO03") THEN BEGIN + print,'uval eq RADIO03' + stash.typeproj=3 + stash.xrange=stash.xrangedef + stash.yrange=stash.yrangedef + plotpoints,stash + ENDIF + + IF (uval eq "RADIO001") THEN BEGIN + print,'uval eq RADIO001 ev.select: ',ev.select + stash.plot_bad_obs=ev.select +; stash.xrange=stash.xrangedef +; stash.yrange=stash.yrangedef + plotpoints,stash + ENDIF + + + IF (uval eq "RADIOSAL") THEN BEGIN + print,'uval eq RADIOSAL ev.select: ',ev.select + salinity=ev.select +; if (stash.filetype eq "Prof" or stash.filetype eq "feedback") then begin + stash.salinity=salinity + plotpoints,stash +; endif + ENDIF + + + IF (uval eq "RADIODENSITY") THEN BEGIN + print,'uval eq RADIODENSITY ev.select: ',ev.select + density=ev.select + if (stash.filetype eq "CRT") then stash.salinity=0 +; if (stash.filetype eq "Prof" or stash.filetype eq "CRT") then begin + stash.density=density + plotpoints,stash +; endif + ENDIF + + + IF (uval eq "PRINT") THEN BEGIN + ps=1 + eps=0 + landscape=1 + pr2,file=stash.outfile+'.ps',landscape=landscape,ps=ps,eps=eps,color=1 + plotpoints,stash + prend2,/view + ENDIF + + IF (uval eq "SAVE") THEN BEGIN + + thisDevice = !D.Name + psave=!p + + Set_Plot, 'Z' ; do graphics in the background +; Device, Set_Resolution=[800,512], decomposed=0 + Device, Set_Resolution=stash.picsize, decomposed=0 + Erase ; clear any existing stuff + !p.charsize=0.75 + +; if (stash.white_on_black eq 0) then begin +;; flip background and foreground color +; pcolor=!p.color +; pbackground=!p.background +; !p.color=pbackground +; !p.background=pcolor +; +; endif +; print,'!p.color,!p.background ',!p.color,!p.background + + setupct, r, g, b, coltable=stash.coltable, $ + white_on_black=stash.white_on_black ; setup color table +; plot data + plotpoints,stash + snapshot = TVRD() + WRITE_GIF,stash.outfile+'.gif',snapshot, r, g, b + Device, Z_Buffer=1 ; reset graphics mode + Set_Plot, thisDevice +; !p.charsize=0.0 + !p=psave + + spawn,'xv '+stash.outfile+'.gif' + + ENDIF + +;Area selection + + xrange=stash.xrange + yrange=stash.yrange + areasel,uval,xrange,yrange,success, toplevel=stash.base + if (success eq 1) then begin + stash.xrange=xrange + stash.yrange=yrange + plotpoints,stash + endif + + + IF (uval eq "Timeseries") THEN BEGIN + stash.numtimeseries=0 + timeserieswindow,stash +; set graphics back to main window +; WSET, stash.drawID +;; print,'ev release' +;; plotpoints,stash + + ENDIF + + IF (uval eq "Num timeseries") THEN BEGIN + stash.numtimeseries=1 + timeserieswindow,stash +; set graphics back to main window +; WSET, stash.drawID + print,'ev release' + plotpoints,stash + + ENDIF + + IF (uval eq "TS diagram") THEN BEGIN + tsdiagramwindow,stash +; set graphics back to main window +; WSET, stash.drawID + print,'ev release' + plotpoints,stash + + ENDIF + + IF (uval eq "Worst points") THEN BEGIN + worstpointswindow,stash + ENDIF + + IF (uval eq "Filter type") THEN BEGIN + filterwindow, stash + ENDIF + + IF (uval eq "Low res map") THEN BEGIN +; stash.map_file="" + stash.hires_map=0 + Widget_Control, stash.loresmap, Set_Button=1 + Widget_Control, stash.hiresmap, Set_Button=0 + plotpoints,stash + ENDIF + + IF (uval eq "Hi res map") THEN BEGIN +; stash.map_file="/opt/ukmo/wave/ukmo/data/map_europe.xdr" + stash.hires_map=1 + Widget_Control, stash.loresmap, Set_Button=0 + Widget_Control, stash.hiresmap, Set_Button=1 + plotpoints,stash + ENDIF + + IF (uval eq "Plot only bad obs") THEN BEGIN + stash.plot_only_bad_obs = 1-stash.plot_only_bad_obs + Widget_Control, stash.pltonbado, Set_Button=stash.plot_only_bad_obs + if (stash.plot_bad_obs eq 1) then plotpoints,stash + ENDIF + + IF (uval eq "White on black") THEN BEGIN + print,uval,' !p.color,!p.background ',!p.color,!p.background + stash.white_on_black = 1-stash.white_on_black + Widget_Control, stash.whtonblack, Set_Button=stash.white_on_black +; IF (!d.name eq 'X') then begin +; WSET, stash.drawID +;; flip background and foreground color +; pcolor=!p.color +; pbackground=!p.background +; !p.color=pbackground +; !p.background=pcolor + + setupct, r, g, b, coltable=stash.coltable, $ + white_on_black=stash.white_on_black ; setup color table + + plotpoints,stash +; endif + + + ENDIF + + + IF (uval eq "Square psym") THEN BEGIN + stash.sym=1 + plotpoints,stash + ENDIF + IF (uval eq "Round psym") THEN BEGIN + stash.sym=2 + plotpoints,stash + ENDIF + + IF (uval eq "incsym") THEN BEGIN + stash.symscale=stash.symscale*1.41421 + plotpoints,stash + ENDIF + IF (uval eq "decsym") THEN BEGIN + stash.symscale=stash.symscale/1.41421 + plotpoints,stash + ENDIF + IF (uval eq "resetsym") THEN BEGIN + stash.symscale=1.0 + plotpoints,stash + ENDIF + + IF (uval eq "vertgrad") THEN BEGIN + stash.vertgrad=1-stash.vertgrad + Widget_Control, stash.vertgradmenu, Set_Button=stash.vertgrad + plotpoints,stash + ENDIF + + IF (uval eq "Info") THEN BEGIN + infowindow + ENDIF + + IF (uval eq "input max/min") THEN BEGIN + toplevel=stash.base + fmx=stash.fmx + fmn=stash.fmn + mx=stash.mx + mn=stash.mn + inputmxmnwindow, fmx, fmn, mx, mn, stash.rmdi, toplevel, success + if (success eq 1) then begin + stash.fmx=fmx + stash.fmn=fmn + plotpoints,stash + endif + +; stash.mx=mx +; stash.mn=mn +; info,stash.fmx +; info,stash.fmn +; info,stash.mx +; info,stash.mn + + ENDIF + + +; store values + WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash + +; IF (TAG_NAMES(ev, /STRUCTURE_NAME) eq 'WIDGET_BUTTON') THEN BEGIN + IF (uval eq "DONE") THEN BEGIN +; WIDGET_CONTROL, ev.TOP, /DESTROY + WIDGET_CONTROL, stash.base, /DESTROY + ENDIF + + + +; WIDGET_CONTROL, stash.label3, SET_VALUE=TAG_NAMES(ev, /STRUCTURE_NAME) +; print,TAG_NAMES(ev, /STRUCTURE_NAME), uval + +END + +;----------------- +; proceedures +;----------------- + +;setup area ranges + +PRO areasel, uval, xrange, yrange, success, toplevel=toplevel + +;info, xrange +;info, yrange + +success=0 + + IF (uval eq "Global") THEN BEGIN + xrange=[-180.,180.] + yrange=[-90.,90.] + success=1 + ENDIF + IF (uval eq "Arctic") THEN BEGIN + xrange=[-180.,180.] + yrange=[70.,90.] + success=1 + ENDIF + IF (uval eq "N Atl") THEN BEGIN + xrange=[-100.,0.] + yrange=[25.,70.] + success=1 + ENDIF + IF (uval eq "Trop Atl") THEN BEGIN + xrange=[-80.,20.] + yrange=[-25.,25.] + success=1 + ENDIF + IF (uval eq "S Atl") THEN BEGIN + xrange=[-70.,20.] + yrange=[-50.,-25.] + success=1 + ENDIF + IF (uval eq "N Pac") THEN BEGIN + xrange=[120.,-100.+360.] + yrange=[25.,70.] + success=1 + ENDIF + IF (uval eq "Trop Pac") THEN BEGIN + xrange=[120.,-80.+360.] + yrange=[-25.,25.] + success=1 + ENDIF + IF (uval eq "S Pac") THEN BEGIN + xrange=[120.,-70.+360.] + yrange=[-50.,-25.] + success=1 + ENDIF + IF (uval eq "Indian") THEN BEGIN + xrange=[20.,120.] + yrange=[-50.,30.] + success=1 + ENDIF + IF (uval eq "S Ocean") THEN BEGIN + xrange=[-180.,180.] + yrange=[-90.,-50.] + success=1 + ENDIF + IF (uval eq "Pacific") THEN BEGIN + xrange=[120.,-80.+360.] + yrange=[-50.,70.] + success=1 + ENDIF + IF (uval eq "Atlantic") THEN BEGIN + xrange=[-100.,20.] + yrange=[-50.,70.] + success=1 + ENDIF + IF (uval eq "Med") THEN BEGIN + xrange=[-15.,38.] + yrange=[30.,46.] + success=1 + ENDIF + IF (uval eq "NWS") THEN BEGIN + xrange=[-20.,13.] + yrange=[40.,65.] + success=1 + ENDIF + IF (uval eq "Input Area") THEN BEGIN + IF (n_elements(toplevel) gt 0) THEN BEGIN + print,'success b4',success + inputareawindow, xrange, yrange, toplevel, success + print,'success af',success + ENDIF + ENDIF + +END + + +;select points to plot + +PRO selpoints, stash, lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr, $ + daymin=daymin, daymax=daymax, salinity=salinity, rmsmean=rmsmean, innovsel2=innovsel2 + +; print, 'calling selpoints ',stash.netcdf, stash.txt + print, 'calling selpoints' + + xarr1=stash.xarr + yarr1=stash.yarr + dep1=stash.dep + if (n_elements(salinity) eq 0) then salinity=stash.salinity + density=stash.density + mld=stash.mld + filetype=stash.filetype + + obnum=stash.obnum +; obnum=lindgen(n_elements(xarr1)) ; generate an array of observation numbers +; ; starting with zero + +; if (salinity eq 0) then begin +; obs1=stash.obs +; bkg1=stash.bkg +; qcarr=stash.qcarr +; endif else begin +; obs1=stash.obs2 +; bkg1=stash.bkg2 +; qcarr=stash.qcarr2 +; endelse + + if (salinity eq 0) then qcarr=stash.qcarr + if (salinity eq 1 or mld eq 1) then qcarr=stash.qcarr2 + if (density eq 1) then begin + if (filetype eq 'CRT') then qcarr=stash.qcarr $ + else qcarr=max([[stash.qcarr],[stash.qcarr2]],dim=2) + endif + + obstypes1=stash.obstypes + depmin=stash.depmin + depmax=stash.depmax + xrange=stash.xrange + yrange=stash.yrange + dayarr=stash.dayarr + fdayarr=long(dayarr+stash.dayshi) ; 0:00 hours should be plotted in prev day + if (n_elements(daymin) eq 0) then daymin=stash.daymin + if (n_elements(daymax) eq 0) then daymax=stash.daymax + fdaymin=long(daymin) + fdaymax=long(daymax) + typeplot=stash.typeplot + ombtypeplot=stash.ombtypeplot + typeproj=stash.typeproj + xrange=stash.xrange + yrange=stash.yrange + rmdi=stash.rmdi + + print,'dayarr ',max(dayarr)-2454710d, min(dayarr)-2454710d + print,'dayarr a',max(dayarr+stash.dayshi)-2454710d,min(dayarr+stash.dayshi)-2454710d + print,'stash.dayshi ',stash.dayshi + + print,'fdayarr mx/mn ',max(fdayarr),min(fdayarr) + print,'fdaymin ',fdaymin,' fdaymax ',fdaymax + + plot_bad_obs=stash.plot_bad_obs + + typestr='' + + if (typeproj eq 2) then begin + xrange=[-999., 999.] + yrange=[0., 90.] + endif + if (typeproj eq 3) then begin + xrange=[-999., 999.] + yrange=[-90, 0.] + endif + +; add 360 if we're in the pacific + + if (xrange(1) gt 180 and typeproj eq 1) then begin + print,'xrange(1) gt 180 ',xrange + wh=where(xarr1 lt 0) + xarr1(wh)=xarr1(wh)+360 + endif + + print,'dayarr(0): ',dayarr(0),fdayarr(0), daymin, daymax + +; if (plot_bad_obs eq 1) then begin + wh=where(dep1 ge depmin and dep1 le depmax and $ + fdayarr ge fdaymin and fdayarr le fdaymax and $ + xarr1 ge xrange(0) and xarr1 le xrange(1) and $ + yarr1 ge yrange(0) and yarr1 le yrange(1)) +; endif else begin +; wh=where(dep1 ge depmin and dep1 le depmax and $ +; fdayarr ge fdaymin and fdayarr le fdaymax and $ +; xarr1 ge xrange(0) and xarr1 le xrange(1) and $ +; yarr1 ge yrange(0) and yarr1 le yrange(1) and qcarr eq 0) +; endelse + + nelwh=n_elements(wh) + + print,'nelwh ',nelwh + + if (wh(0) gt -1) then begin +; obssel=obs1(wh) +; bkgsel=bkg1(wh) + + qcsel=qcarr(wh) + lonsel=xarr1(wh) + latsel=yarr1(wh) + daysel=dayarr(wh) + depsel=dep1(wh) + obstypsel=obstypes1(wh) + obnumsel=obnum(wh) + numsel=lonarr(nelwh) + + nel=n_elements(obssel) + +; select points here to avoid unnecessary density calculations + + obssel1=stash.obs(wh) + bkgsel1=stash.bkg(wh) + obssel2=stash.obs2(wh) + bkgsel2=stash.bkg2(wh) + + if (density eq 0 and mld eq 0) then begin + if (salinity eq 0) then begin + obssel=obssel1 + bkgsel=bkgsel1 + endif else begin + obssel=obssel2 + bkgsel=bkgsel2 + endelse + endif else begin + if (filetype eq 'CRT') then begin + bkgsel=sqrt(bkgsel1*bkgsel1 + bkgsel2*bkgsel2) + if (salinity eq 0) then begin + obssel=sqrt(obssel1*obssel1 + obssel2*obssel2) + endif else begin + obssel=stash.obs3(wh) + endelse + endif else begin ; calculate density if mld flag set + obssel=eos_nemo(obssel1,obssel2) + bkgsel=eos_nemo(bkgsel1,bkgsel2) + endelse + endelse + +; create an array to store the sum of the square differences for calculating profile rms +; omb2sel=(obssel - bkgsel)^2 + nel=n_elements(obssel) + endif else begin ; if there are no obs then exit subroutine + nel=0 + return + endelse + + if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + innovseli=obssel^2 + innovseli2=bkgsel^2 + innovseli3=(obssel-bkgsel)^2 + innovseli4=obssel*bkgsel + endif else begin + + + if (ombtypeplot eq 1) then begin + typestr='obs - bkg' + innovseli=obssel-bkgsel + endif + if (ombtypeplot eq 2) then begin + typestr='obs' + innovseli=obssel + endif + if (ombtypeplot eq 3) then begin + typestr='bkg' + innovseli=bkgsel + endif + + if (keyword_set(rmsmean)) then begin + innovseli=innovseli + innovseli2=innovseli^2 + endif else begin + + if (typeplot eq 1) then begin + typestr='mean '+typestr + endif + if (typeplot eq 2) then begin + typestr='rms '+typestr + innovseli=innovseli^2 + endif + if (typeplot eq 3) then begin + typestr='sd '+typestr + innovseli=innovseli^2 ; ? + endif + if (typeplot eq 4) then begin + typestr='mean sq '+typestr + innovseli=innovseli^2 + endif + + endelse + + endelse + +; print,'bkgsel ',bkgsel +; print,'obssel ',obssel + +; tolerance check + + if (wh(0) gt -1) then begin + wh2=[-1] + +; print,qcsel + + if (plot_bad_obs eq 0) then begin +; if (typeplot eq 1 or typeplot eq 2 $ +; or typeplot eq 3) then $ + if (ombtypeplot eq 1) then $ +; wh2=where(bkgsel ne rmdi and obssel ne rmdi) + wh2=where(abs(bkgsel-rmdi) gt abs(rmdi)*0.01 and abs(obssel-rmdi) gt $ + abs(rmdi)*0.01 and qcsel eq 0) ; tolerance rmdi check + if (ombtypeplot eq 2) then $ +; if (typeplot eq 4) then $ +; wh2=where(obssel ne rmdi) + wh2=where(abs(obssel-rmdi) gt abs(rmdi)*0.01 and qcsel eq 0) ;tol rmdi check + if (ombtypeplot eq 3) then $ +; if (typeplot eq 5) then $ +; wh2=where(bkgsel ne rmdi) + wh2=where(abs(bkgsel-rmdi) gt abs(rmdi)*0.01 and qcsel eq 0) ;tol rmdi check + +; check for bad observations +; if (plot_bad_obs eq 1) then begin + endif else if (plot_bad_obs eq 1 and stash.plot_only_bad_obs eq 1) then begin +; wh2=where(qcsel ne 0 or obssel eq rmdi or bkgsel eq rmdi, count) +; wh2=where(qcsel ne 0 or abs(obssel-rmdi) lt abs(rmdi)*0.01,count) + wh2=where(qcsel ne 0 and obssel ne rmdi) + +; wh2=where(qcsel ne 0 or abs(obssel-rmdi) lt abs(rmdi)*0.01 or abs(bkgsel-rmdi) lt abs(rmdi)*0.01,count) +; print,'bad obs: ',count +; whtmp=where(qcsel eq 0, count) +; print,'qcsel eq 0: ',count +; whtmp=where(obssel eq 0, count) +; print,'obssel eq 0: ',count +; whtmp=where(bkgsel eq 0, count) +; print,'bkgsel eq 0: ',count + endif else begin ; plot all observations +; wh2=where(obssel) + wh2=where(obssel ne rmdi) + endelse + + if (wh2(0) gt -1) then begin + obssel=obssel(wh2) + bkgsel=bkgsel(wh2) + innovseli=innovseli(wh2) +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2=innovseli2(wh2) + if (n_elements(innovseli3) gt 0) then innovseli3=innovseli3(wh2) + if (n_elements(innovseli4) gt 0) then innovseli4=innovseli4(wh2) +; endif + qcsel=qcsel(wh2) + lonsel=lonsel(wh2) + latsel=latsel(wh2) + daysel=daysel(wh2) + depsel=depsel(wh2) + obstypsel=obstypsel(wh2) + obnumsel=obnumsel(wh2) +; numsel=numsel(wh2) + endif + + print,'nelwh2 ',n_elements(wh2), typeplot, ombtypeplot + + if (wh2(0) gt -1) then begin + + ; calculate vertical gradients if required + if (stash.filetype eq "Prof" and stash.vertgrad eq 1) then $ + calcvertgrad, lonsel, latsel, daysel, obssel, bkgsel, qcsel, depsel, rmdi + +; average profiles on the same latitude and longitude +; goes through each point and puts the average in the first instance and flags +; the others for later removal +; this routine can also be used to bin data + depmx=max(depsel,min=depmn) + print,'depmn/mx: ',depmn, depmx + if (depmx gt depmn or stash.duplicates gt 0 or stash.differences or stash.bindata) then begin + +; sort by lat and lon +; presumably will average in time also... + + if (stash.bindata) then begin ; if we are binning data (in 1 deg bins) + ; use +0.5 to get nearest round number + latbin=double(fix((latsel+stash.binsize(1)/2.)*(1/stash.binsize(1))))/(1/stash.binsize(1)) + lonbin=double(fix((lonsel+stash.binsize(0)/2.)*(1/stash.binsize(0))))/(1/stash.binsize(0)) + latlon=long(latbin*10000000d)+double(lonbin+180d)/360d + endif else begin + latlon=long(double(latsel)*10000000d)+double(lonsel+180d)/360d + endelse + + elsort=sort(latlon) + + latsel=latsel(elsort) + lonsel=lonsel(elsort) + obssel=obssel(elsort) + bkgsel=bkgsel(elsort) + innovseli=innovseli(elsort) +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2=innovseli2(elsort) + if (n_elements(innovseli3) gt 0) then innovseli3=innovseli3(elsort) + if (n_elements(innovseli4) gt 0) then innovseli4=innovseli4(elsort) +; endif + qcsel=qcsel(elsort) + daysel=daysel(elsort) + depsel=depsel(elsort) + obstypsel=obstypsel(elsort) + obnumsel=obnumsel(elsort) +; numsel=numsel(elsort) + latlon=latlon(elsort) + + nel=n_elements(obssel) + accum=0 + isave=0 + lon1=-99999.0 + lat1=-99999.0 + latlon1=-99999.0 + day1=-99999 + num=0 + +; if (nel gt 100) then begin +; info,latsel +; print,latsel(0:100) +; info,lonsel +; print,lonsel(0:100) +; info,latlon +; print,latlon(0:100) + +; latsel(0:100)=latsel(50) +; lonsel(0:100)=lonsel(50) +; latlon=long(double(latsel)*10000000d)+double(lonsel+180d)/360d + +; endif + + + print,'DJL ',max(daysel),min(daysel) + +; loop through the data averaging profiles at the same location + + sign=1 + if (stash.duplicates eq 2) then sign=-1 ; plot the difference rather than the average + + numsel=lonarr(nel) + for i=0L,nel-1 do begin + + if i mod 100000 eq 0 then print,i,nel + +; if (plot_bad_obs eq 0 and obssel(i) ne rmdi) or $ +; (plot_bad_obs eq 1 and lonsel(i) ne rmdi) then begin + +; if (lonsel(i) ne lon1 or latsel(i) ne lat1) then begin + +; check for new profile or reaching the end of the data +; check for the end of a day added + + if ((latlon(i) ne latlon1) or (i eq nel-1) or (long(daysel(i)) ne long(day1))) then begin + +; print,i, latlon(i), latlon1, daysel(i), day1 +; if i gt 0 then stop + +; average last profile + if (isave ge 0 and num gt 0) then begin + + if (num gt 1) then begin + +; print,num + numsave=num + if (stash.duplicates eq 2) then num=1 + + if (stash.bindata) then begin + latsel(isave)=latsel(isave)/num + lonsel(isave)=lonsel(isave)/num + endif + obssel(isave)=obssel(isave)/num + bkgsel(isave)=bkgsel(isave)/num + daysel(isave)=daysel(isave)/num + depsel(isave)=depsel(isave)/num + innovseli(isave)=innovseli(isave)/num +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2(isave)=innovseli2(isave)/num + if (n_elements(innovseli3) gt 0) then innovseli3(isave)=innovseli3(isave)/num + if (n_elements(innovseli4) gt 0) then innovseli4(isave)=innovseli4(isave)/num +; endif + + num=numsave + +; save the num + numsel(isave)=num + +; if (fix(lonsel(isave)) eq -7297 and $ +; fix(latsel(isave)) eq -5935) then begin +; print,'completed ',isave, num +; print,'obssel ',obssel(isave) +; print,'bkgsel ',bkgsel(isave) +; endif + + endif else begin + numsel(isave)=num + endelse + if ((stash.duplicates gt 0 and num eq 1) or (stash.differences and num gt 1)) then begin + obssel(isave)=rmdi + bkgsel(isave)=rmdi + lonsel(isave)=rmdi + latsel(isave)=rmdi + qcsel(isave)=rmdi + innovseli(isave)=rmdi +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2(isave)=rmdi + if (n_elements(innovseli3) gt 0) then innovseli3(isave)=rmdi + if (n_elements(innovseli4) gt 0) then innovseli4(isave)=rmdi +; endif + + endif + + endif + + if (plot_bad_obs eq 0 and obssel(i) ne rmdi) or $ + (plot_bad_obs eq 1 and lonsel(i) ne rmdi) then begin + +; start a new profile + lon1=lonsel(i) + lat1=latsel(i) + latlon1=latlon(i) + day1=daysel(i) + isave=i + accum=1 + num=1 + + endif ; plot_bad_obs ... + + ; accumulating + + endif else begin + + if (plot_bad_obs eq 0 and obssel(i) ne rmdi) or $ + (plot_bad_obs eq 1 and lonsel(i) ne rmdi) then begin + + num=num+1 + + if (stash.bindata) then begin + latsel(isave)=latsel(isave)+double(fix((1./stash.binsize(1))*(latsel(i)+stash.binsize(1)/2.)))/(1./stash.binsize(1)) ;latsel(isave)+fix(latsel(i)+0.5) + lonsel(isave)=lonsel(isave)+double(fix((1./stash.binsize(0))*(lonsel(i)+stash.binsize(0)/2.)))/(1./stash.binsize(0)) ;lonsel(isave)+fix(lonsel(i)+0.5) + endif + + obssel(isave)=obssel(isave)+obssel(i)*sign + bkgsel(isave)=bkgsel(isave)+bkgsel(i)*sign + innovseli(isave)=innovseli(isave)+innovseli(i)*sign +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2(isave)=innovseli2(isave)+innovseli2(i)*sign + if (n_elements(innovseli3) gt 0) then innovseli3(isave)=innovseli3(isave)+innovseli3(i)*sign + if (n_elements(innovseli4) gt 0) then innovseli4(isave)=innovseli4(isave)+innovseli4(i)*sign +; endif + + qcsel(isave)=min([qcsel(isave),qcsel(i)]) + daysel(isave)=daysel(isave)+daysel(i) + depsel(isave)=depsel(isave)+depsel(i) + + if (stash.bindata) then begin + latsel(i)=rmdi + lonsel(i)=rmdi + endif + obssel(i)=rmdi + bkgsel(i)=rmdi + innovseli(i)=rmdi +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2(i)=rmdi + if (n_elements(innovseli3) gt 0) then innovseli3(i)=rmdi + if (n_elements(innovseli4) gt 0) then innovseli4(i)=rmdi +; endif + lonsel(i)=rmdi + latsel(i)=rmdi + qcsel(i)=rmdi + +; if (fix(lonsel(isave)*100) eq -7297 and $ +; fix(latsel(isave)*100) eq -5935) then begin +; print,'isave ',isave, num +; print,'obssel ',obssel(isave) +; print,'bkgsel ',bkgsel(isave) +; endif + + endif ; plot_bad_obs ... + + endelse + +; endif + + endfor ; i nobs + + print,'DJL2x ',max(daysel),min(daysel) + + + wh5=where(lonsel ne rmdi) ; clears out but the averaged profiles + if (wh5(0) gt -1) then begin + obssel=obssel(wh5) + bkgsel=bkgsel(wh5) + innovseli=innovseli(wh5) +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2=innovseli2(wh5) + if (n_elements(innovseli3) gt 0) then innovseli3=innovseli3(wh5) + if (n_elements(innovseli4) gt 0) then innovseli4=innovseli4(wh5) +; endif + qcsel=qcsel(wh5) + lonsel=lonsel(wh5) + latsel=latsel(wh5) + daysel=daysel(wh5) + obstypsel=obstypsel(wh5) + obnumsel=obnumsel(wh5) + numsel=numsel(wh5) + nel=n_elements(obssel) + endif else begin ; if there are no obs then exit subroutine + nel=0 + return + endelse + endif + + print,'nel wh5 ',n_elements(wh5) + print,'DJL3 ',max(daysel),min(daysel) + + typeselect=stash.obstypeselect +; print, 'typeselect ',typeselect + if (typeselect(0) ne "") then begin +; typeselecta=strsplit(typeselect,' ,',/extract) ; split string on commas or spaces + typeselecta=strsplit(typeselect,',',/extract) ; split string on commas only + nel=n_elements(typeselecta) + print,'n_elements(typeselecta) ',nel + for i=0L,nel-1 do begin + ; string matching (understands * ?) + st1=strtrim(string(obstypsel),2) ; strip tailing and leading spaces + st2=strtrim(typeselecta(i),2) + wh6t=where(strmatch(st1,st2,/FOLD_CASE) EQ 1) +; print, 'wh6t ',typeselecta(i), wh6t + if i eq 0 then wh6=wh6t else wh6=[wh6,wh6t] + endfor +; print,n_elements(wh6) +; print,wh6 + wh=where(wh6 gt -1) +; print,wh + if (wh(0) gt -1) then begin + wh6=wh6(wh) + obssel=obssel(wh6) + bkgsel=bkgsel(wh6) + innovseli=innovseli(wh6) +; if ((stash.txt eq 1 or stash.netcdf eq 1) and stash.bindata eq 1) then begin + if (n_elements(innovseli2) gt 0) then innovseli2=innovseli2(wh6) + if (n_elements(innovseli3) gt 0) then innovseli3=innovseli3(wh6) + if (n_elements(innovseli4) gt 0) then innovseli4=innovseli4(wh6) +; endif + qcsel=qcsel(wh6) + lonsel=lonsel(wh6) + latsel=latsel(wh6) + daysel=daysel(wh6) + obstypsel=obstypsel(wh6) + obnumsel=obnumsel(wh6) + numsel=numsel(wh6) + nel=n_elements(obssel) +; print, 'nel (in obstypeselect) ',nel + endif else begin ; if there are no obs then exit subroutine + print,'no matching obs' + nel=0 + endelse + endif + + if (stash.printobstypes eq 1) then begin + s=sort(obstypsel) + sobstypsel=obstypsel(s) + u=uniq(sobstypsel) + print,"unique obs types: ",sobstypsel(u) + endif + + print,'nel ',nel + stash.symsize=1.0 + if (nel gt 250) then stash.symsize=0.75 + if (nel gt 1000) then stash.symsize=0.5 + if (nel gt 2000) then stash.symsize=0.25 + if (nel lt 20) then stash.symsize=2.0 + + if (!d.name eq 'Z') then stash.symsize=stash.symsize/2 + + print,'stash.symsize: ',stash.symsize + +; save data for mean and rms plots +; for ombtypeplot=3 typeplot=2 innovsel = (obs - bkg)^2 mean value available from obssel(i) - bkgsel(i) + +; copy innovseli to innovsel (if we've got some valid data to plot / save) + if (nel gt 0) then innovsel=innovseli + + if (stash.txt eq 1 and stash.bindata eq 1) then begin + +; The file contains: longitude, latitude, num of points, obs mean, bkg mean +; mean sq obs, mean sq bkg, mean sq obs - bkg, mean obs * bkg + + outfile=stash.outfile+'_selpoints.txt' + print, 'saving data to ',outfile + OPENW, unit, outfile, /get_lun +; printf,unit,'Output selpoints data: ' + printf,unit, 3 ; file version + printf,unit, typeplot + printf,unit, stash.bindata + printf,unit, xrange, yrange + printf,unit, min(daysel), max(daysel) + + for i=0L,nel-1 do begin + printf,unit, lonsel(i), latsel(i), numsel(i), obssel(i), bkgsel(i), $ + innovseli(i), innovseli2(i), innovseli3(i), innovseli4(i), $ + format='(2d10.3, i8, 6d18.8)' + endfor + FREE_LUN, unit + + endif + + if (stash.netcdf eq 1 and stash.bindata eq 1) then begin + + outfile=stash.outfile+'_selpoints.nc' + print, 'saving data to ',outfile + + nid=NCDF_CREATE( outfile, /CLOBBER ) + + NCDF_ATTPUT, nid, 'version', 3, /SHORT, /GLOBAL + NCDF_ATTPUT, nid, 'bindata', stash.bindata, /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'xrange0', xrange(0), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'xrange1', xrange(1), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'yrange0', yrange(0), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'yrange1', yrange(1), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'mindaysel', min(daysel), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'maxdaysel', max(daysel), /FLOAT, /GLOBAL + + print, 'nel ',nel + nelid = NCDF_DIMDEF( nid, 'n', nel ) + + lonid = NCDF_VARDEF ( nid, 'longitudes', [nelid], /FLOAT ) + latid = NCDF_VARDEF ( nid, 'latitudes', [nelid], /FLOAT ) + numid = NCDF_VARDEF ( nid, 'num', [nelid], /LONG ) + obsid = NCDF_VARDEF ( nid, 'obs_mean', [nelid], /FLOAT ) + bkgid = NCDF_VARDEF ( nid, 'bkg_mean', [nelid], /FLOAT ) + innovseli1id = NCDF_VARDEF ( nid, 'obs_mean_sq', [nelid], /FLOAT ) + innovseli2id = NCDF_VARDEF ( nid, 'bkg_mean_sq', [nelid], /FLOAT ) + innovseli3id = NCDF_VARDEF ( nid, 'omb_mean_sq', [nelid], /FLOAT ) + innovseli4id = NCDF_VARDEF ( nid, 'otimesb_mean', [nelid], /FLOAT ) + NCDF_CONTROL, nid, /ENDEF + + if (nel gt 0) then begin + NCDF_VARPUT, nid, lonid, lonsel + NCDF_VARPUT, nid, latid, latsel + NCDF_VARPUT, nid, numid, numsel + NCDF_VARPUT, nid, obsid, obssel + NCDF_VARPUT, nid, bkgid, bkgsel + NCDF_VARPUT, nid, innovseli1id, innovseli + NCDF_VARPUT, nid, innovseli2id, innovseli2 + NCDF_VARPUT, nid, innovseli3id, innovseli3 + NCDF_VARPUT, nid, innovseli4id, innovseli4 + endif + + NCDF_CLOSE, nid + + endif + + if (stash.filterout ne '') then begin + + ; write out filtered feedback file in new feedback format + ; with some filthy fudges to emulate NEMOVAR format + if (nel gt 0) then begin + + print, 'writing filtered feedback file ',stash.filterout + + ; split type string in two to be used as STATION_IDENTIFIER and STATION_TYPE + typesel=strarr(nel) + instsel=strarr(nel) + + for iob = 0, nel-1 do begin + tempsel=strsplit(obstypsel[iob],/extract) + typesel[iob]=tempsel[0] + ; catch for data without space and instrument id in types (e.g. altimeter) + instsel[iob]='' + if (n_elements(tempsel) gt 1 ) then $ + instsel[iob]=tempsel[1] + endfor + + ; setup netcdf file + nid=NCDF_CREATE( stash.filterout, /CLOBBER ) + + ; global attribute to emulate NEMOVAR feedback files + NCDF_ATTPUT, nid, 'title', "NEMO observation operator output", /GLOBAL + if (stash.obstypeselect ne '' ) then $ + NCDF_ATTPUT, nid, 'filter', stash.obstypeselect, /GLOBAL + NCDF_ATTPUT, nid, 'minday', min(daysel), /FLOAT, /GLOBAL + NCDF_ATTPUT, nid, 'maxday', max(daysel), /FLOAT, /GLOBAL + + nobid = NCDF_DIMDEF( nid, 'N_OBS', nel ) + ndepid = NCDF_DIMDEF( nid, 'N_LEVELS', 1 ) ; temporarily input 1d profile arrays + + if (stash.filetype eq 'feedback') then begin + + ncvars = stash.varname + nnvars = n_elements(ncvars) + + endif else begin + + nnvars = 1 + ncvars = stash.filetype + if (stash.filetype eq 'Prof') then begin + ncvars = 'POTM' + if (salinity eq 1) then ncvars = 'PSAL' + nextid = NCDF_DIMDEF( nid, 'N_EXTRA', 1 ) + endif + + endelse + + nvarid = NCDF_DIMDEF( nid, 'N_VARS', nnvars ) + + nentid = NCDF_DIMDEF( nid, 'N_ENTRIES', 1 ) + + nstrnamid = NCDF_DIMDEF( nid, 'STRINGNAM', 8 ) + nstrwmoid = NCDF_DIMDEF( nid, 'STRINGWMO', 8 ) + nstrtypid = NCDF_DIMDEF( nid, 'STRINGTYP', 4 ) + nstrjulid = NCDF_DIMDEF( nid, 'STRINGJULD', 14 ) + + varid = NCDF_VARDEF ( nid, 'VARIABLES', [nstrnamid,nvarid], /CHAR ) + entid = NCDF_VARDEF ( nid, 'ENTRIES', [nstrnamid,nentid], /CHAR ) + signid = NCDF_VARDEF ( nid, 'STATION_IDENTIFIER', [nstrwmoid,nobid], /CHAR ) + typeid = NCDF_VARDEF ( nid, 'STATION_TYPE', [nstrtypid,nobid], /CHAR ) + + lonid = NCDF_VARDEF ( nid, 'LONGITUDE', [nobid], /DOUBLE ) + latid = NCDF_VARDEF ( nid, 'LATITUDE', [nobid], /DOUBLE ) + depid = NCDF_VARDEF ( nid, 'DEPTH', [nobid], /DOUBLE ) +; depid = NCDF_VARDEF ( nid, 'DEPTH', [ndepid,nobid], /DOUBLE ) + julid = NCDF_VARDEF ( nid, 'JULD', [nobid], /DOUBLE ) + jrefid = NCDF_VARDEF ( nid, 'JULD_REFERENCE', [nstrjulid], /CHAR ) + + obsqcid = NCDF_VARDEF ( nid, 'OBSERVATION_QC', [nobid], /LONG ) + + FillVal=9999 + NCDF_ATTPUT, nid, depid, '_Fillvalue', FillVal, /DOUBLE + NCDF_ATTPUT, nid, obsqcid, '_Fillvalue', FillVal, /LONG + + obsids=intarr(nnvars) + bkgids=intarr(nnvars) + qcids=intarr(nnvars) + lqcids=intarr(nnvars) + + for ivar = 0, nnvars-1 do begin + + obsids[ivar] = NCDF_VARDEF ( nid, ncvars[ivar]+'_OBS', [nobid], /FLOAT ) + NCDF_ATTPUT, nid, obsids[ivar], '_Fillvalue', FillVal, /FLOAT + bkgids[ivar] = NCDF_VARDEF ( nid, ncvars[ivar]+'_Hx', [nobid], /FLOAT ) + NCDF_ATTPUT, nid, bkgids[ivar], '_Fillvalue', FillVal, /FLOAT + qcids[ivar] = NCDF_VARDEF ( nid, ncvars[ivar]+'_QC', [nobid], /LONG ) + NCDF_ATTPUT, nid, qcids[ivar], '_Fillvalue', FillVal, /FLOAT + lqcids[ivar] = NCDF_VARDEF ( nid, ncvars[ivar]+'_LEVEL_QC', [nobid], /LONG ) + NCDF_ATTPUT, nid, lqcids[ivar], '_Fillvalue', FillVal, /FLOAT + + endfor + + NCDF_CONTROL, nid, /ENDEF + + JulDRef = '19500101000000' + NCDF_VARPUT, nid, jrefid, JulDRef + RefDate = JULDAY(fix(strmid(JulDRef,4,2)), fix(strmid(JulDRef,6,2)), fix(strmid(JulDRef,0,4)), $ + fix(strmid(JulDRef,8,2)), fix(strmid(JulDRef,10,2)), fix(strmid(JulDRef,12,2))) + NCDF_VARPUT, nid, julid,daysel-RefDate + + NCDF_VARPUT, nid, varid, ncvars + NCDF_VARPUT, nid, entid, 'Hx' + + NCDF_VARPUT, nid, lonid, lonsel + NCDF_VARPUT, nid, latid, latsel + + NCDF_VARPUT, nid, depid, fltarr(nel) + NCDF_VARPUT, nid, obsqcid, fltarr(nel)+1 + + for ivar = 0, nnvars-1 do begin + + NCDF_VARPUT, nid, obsids[ivar], obssel + NCDF_VARPUT, nid, bkgids[ivar], bkgsel + NCDF_VARPUT, nid, qcids[ivar], qcsel+1 + NCDF_VARPUT, nid, lqcids[ivar], fltarr(nel)+1 + + endfor + + NCDF_VARPUT, nid, typeid, typesel + NCDF_VARPUT, nid, signid, instsel + + endif + + NCDF_CLOSE, nid + + endif ; filterout + + if (nel gt 0) then begin + + if (typeplot eq 2) then begin + innovsel=sqrt(innovsel) + endif + if (typeplot eq 3) then begin +; std dev = sqrt ( mean x2 - (mean x)^2) + x2=innovsel + print,'typeplot ',typeplot,' ombtypeplot ',ombtypeplot + if (ombtypeplot eq 1) then $ + innovsel=sqrt(x2-(obssel-bkgsel)^2) + if (ombtypeplot eq 2) then $ + innovsel=sqrt(x2-(obssel)^2) + if (ombtypeplot eq 3) then $ + innovsel=sqrt(x2-(bkgsel)^2) + endif + + if (keyword_set(rmsmean)) then begin + innovsel=innovseli ; mean + if (n_elements(innovseli2) gt 0) then innovsel2=innovseli2 ; rms + endif + + + innovmean=total(innovsel)/nel + innovmean2=total(innovsel^2)/nel + innovsd=sqrt(innovmean2-innovmean^2) + print,'mean innovsel ',innovmean + print,'sd innovsel ',innovsd + + endif + + + + endif + + endif + + wh=where(numsel eq 0) + if (wh(0) gt -1) then numsel(wh)=1 + +END + +PRO setupct, r, g, b, coltable=coltable, white_on_black=white_on_black + +if (coltable eq 0 or coltable lt -2) then begin +; get color table and modify + loadct, 13 + stretch, -40, 256 +; tvlct,r,g,b,/get +; r(0)=0 +; g(0)=0 +; b(0)=0 +; r(255)=255 +; g(255)=255 +; b(255)=255 +; tvlct,r,g,b +endif else begin + if (coltable eq -1) then begin + restore_colors, 'spectrum.clr' + endif else if (coltable eq -2) then begin + restore_colors, '~frbe/spectrum_alt.xdr',/asis + endif else begin + loadct,coltable + endelse +endelse + +tvlct,r,g,b,/get +i0=0 +i1=255 +if (n_elements(white_on_black) eq 1 and !d.name ne "PS") then begin + if (white_on_black eq 0) then begin + i0=255 + i1=0 + endif +endif +r(i0)=0 +g(i0)=0 +b(i0)=0 +r(i1)=255 +g(i1)=255 +b(i1)=255 +tvlct,r,g,b + +END + +PRO plotpoints, stash + + nplots=1 + if (stash.pmulti eq 2) then nplots=stash.pmulti + + for nplot=0,nplots-1 do begin + + if (stash.busy eq 1) then return + stash.busy = 1 + + num_cols=254 + + print,"!d.name ",!d.name + IF (stash.drawID gt -1) then begin + IF (!d.name eq 'X' or !d.name eq 'Z') then begin + device, decomposed=0 + endif + IF (!d.name eq 'X') then WSET, stash.drawID + endif + + IF (!d.name ne 'Z') then setupct, r, g, b, $ + coltable=stash.coltable,white_on_black=stash.white_on_black ; setup color table + + noerase=0 + if (stash.pmulti eq 2) then begin + if (stash.pmultinum gt 0) then noerase=1 + !p.multi=[stash.pmultinum,2,1] + stash.pmultinum=(stash.pmultinum+1) mod 2 + endif else begin + !p.multi=0 + endelse + +; xarr1=stash.xarr +; yarr1=stash.yarr +; dep1=stash.dep +; obs1=stash.obs +; bkg1=stash.bkg +; depmin=stash.depmin + xrange=stash.xrange + yrange=stash.yrange +; dayarr=stash.dayarr + daymin=stash.daymin + daymax=stash.daymax +; typeplot=stash.typeplot + typeproj=stash.typeproj +; print,"stash.map_file: ",stash.map_file +; if (strlen(stash.map_file) gt 0) then map_file=stash.map_file + +; print,depmin,xrange,yrange + + dummy=[0,0] + + +; plot,dummy,/nodata,yrange=[-90,90],xrange=[-180,180] +; plot,dummy,/nodata,yrange=[-50,80],xrange=[-110,40],$ +; xstyle=1,ystyle=1, xtitle='Longitude',ytitle='Latitude' + + if (typeproj ne 1) then begin + origlon=0. + if (typeproj eq 2) then begin + origlat=90. + if (yrange(0) lt 0) then yrange(0)=45 + if (yrange(1) lt 0) then yrange(1)=90 + endif + if (typeproj eq 3) then begin + origlat=-90. + if (yrange(0) gt 0) then yrange(0)=-90 + if (yrange(1) gt 0) then yrange(1)=-45 + endif + ;scale=0.35 + smap = map_proj_init('Polar Stereographic') + endif + + ; select points to plot + typestr="" + +spawn,'echo plotpoints 1 `date`' + + selpoints, stash, lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr + +spawn,'echo plotpoints 2 `date`' + + if (stash.txt eq 0 and stash.netcdf eq 0) then begin + nelsel=n_elements(innovsel) + + nptsstr=strtrim(string(nelsel),2) + print,nptsstr, nelsel + +; if (nelsel gt 0) then begin + + + + ;convert lats and lons to projection positions +; if (nelsel gt 0) then begin +; print,'min/max lonsel: ',min(lonsel),max(lonsel) +; if (typeproj ne 1) then begin +; coords = map_proj_forward(lonsel,latsel,MAP=smap) +; lonsel=coords(0,*) +; latsel=coords(1,*) +; endif +; endif + + + + print,'nelsel: ',nelsel + nelinnov=n_elements(innovsel) + print,'nelinnov: ',nelinnov + + jul_to_dtstr, daymin, dateminstr, /notime + jul_to_dtstr, daymax, datemaxstr, /notime + + strtsal='' +; print,'stash.filetype ',stash.filetype + if (stash.filetype eq "Prof" or stash.filetype eq "feedback") then begin + strtsal='T: ' + if (stash.salinity eq 1) then strtsal='S: ' + if (stash.density eq 1) then strtsal='Density: ' + if (stash.mld eq 1) then strtsal='MLD: ' + endif else begin + if (stash.filetype eq "CRT") then begin + strtsal='U: ' + if (stash.salinity eq 1) then strtsal='V: ' + if (stash.density eq 1) then strtsal='Speed: ' + if (stash.salinity eq 1 and stash.density eq 1) then strtsal='Total Speed: ' + endif else begin + strtsal=stash.filetype+': ' + endelse + endelse + if (stash.vertgrad eq 1) then strtsal='Grad '+strtsal + nptsstr2='Points: '+nptsstr+' ' + titlestr=strtsal+typestr+': '+dateminstr+' to '+datemaxstr + print,'titlestr ',titlestr + +; get max and min values + mx=0 + mn=0 + meaninnov=0 + rmsinnov=0 + if (nelinnov gt 0) then begin +; NB these values are just the rms and mean of the points plotted... +; and do not take account of the datapoints used in profiles plotted... + mx=max(innovsel) + mn=min(innovsel) + meaninnov=avg(innovsel) + rmsinnov=sqrt(avg(innovsel^2)) +; n=total(numsel) +; wh=where(numsel gt 0) +; print, 'innovsel: ',max(innovsel), min(innovsel) +; print, 'numsel: ',max(numsel), min(numsel) +; if (n gt 0) then begin +; x=total(innovsel(wh)*numsel(wh)) +; x2=total(innovsel(wh)^2*numsel(wh)) +; meaninnov=x/n +; rmsinnov=sqrt(x2/n) +; endif + endif + + subtitle='' + subtitle=nptsstr2+'depths: '+strtrim(string(long(stash.depmin)),2)+'-'+$ + strtrim(string(long(stash.depmax)),2) + if (stash.obstypeselect ne "") then subtitle=subtitle+' filtered type: '+stash.obstypeselect + subtitle=subtitle+' extrema: '+$ + strtrim(string(mn,format='(G0.4)'),2)+', '+strtrim(string(mx,format='(G0.4)'),2) + subtitle=subtitle+' mean: '+strtrim(string(meaninnov,format='(G0.4)'))+$ + ' rms: '+strtrim(string(rmsinnov,format='(G0.4)')) + +; print,'noerase ',noerase + + if (typeproj ne 1) then begin + map_set, /STEREOGRAPHIC, origlat, 0, /continents, title=titlestr+'!C'+subtitle, $ + ymargin=[10.,5.], /label, latlab=xrange(0), lonlab=yrange(0), $ + limit=[yrange(0),xrange(0),yrange(1),xrange(1)],/isotropic, hires=stash.hires_map, noerase=noerase + endif else begin + P0lon=0 + P0lat=0 + if (xrange(1) gt 180) then P0lon=180 + print,'ranges: ',yrange(0),xrange(0),yrange(1),xrange(1) + map_set, P0lat, P0lon, /continents, title=titlestr+'!C'+subtitle, $ + ymargin=[10.,5.], /label, latlab=xrange(0), lonlab=yrange(0), $ + limit=[yrange(0),xrange(0),yrange(1),xrange(1)],/isotropic, hires=stash.hires_map, noerase=noerase + endelse + + + if (nelsel eq 0 or nelinnov eq 0) then begin +; pp_contour,fld,title=titlestr,/nodata, /proportional, map_file=map_file + endif else begin +; pp_contour,fld,title=titlestr,/nodata, /proportional, map_file=map_file + + if (stash.fmx ne stash.rmdi) then mx=stash.fmx + if (stash.fmn ne stash.rmdi) then mn=stash.fmn + + print,'setting stash mx/mn' + stash.mx=mx + stash.mn=mn + +; levs=contour_levels([mn,mx],nlevels=15) +; levs=findgen(10+1)/10.*(mx-mn)+mn + + print, 'mn mx ',mn,mx + + + +;; De-select points outside window? +; +; xnd= [ -!X.s(0), 1. ]/!X.s(1) +; ynd= [ -!Y.s(0), 1. ]/!Y.s(1) +; ov=0 ; overlap +; clip_data= [ (!ppp.position(0)-ov)*xnd(1) + xnd(0) , $ +; (!ppp.position(1)-ov)*ynd(1) + ynd(0) , $ +; (!ppp.position(2)+ov)*xnd(1) + xnd(0) , $ +; (!ppp.position(3)+ov)*ynd(1) + ynd(0) ] +; +; wh=where(lonsel ge clip_data(0) and lonsel le clip_data(2) and $ +; latsel ge clip_data(1) and latsel le clip_data(3)) +; if (wh(0) gt -1) then begin +; latsel=latsel(wh) +; lonsel=lonsel(wh) +; innovsel=innovsel(wh) +; endif + + + print,'daymin=',daymin + print,'daymax=',daymax +; print,dayarr(wh) + + +; titlestr=typestr+': '+titlestr + + + + mx=max(innovsel) + mn=min(innovsel) + if (stash.fmx ne stash.rmdi) then mx=stash.fmx + if (stash.fmn ne stash.rmdi) then mn=stash.fmn + +; stash.mx=mx +; stash.mn=mn + +; levs=contour_levels([mn,mx],nlevels=30) + levs=findgen(15)/15.*(mx-mn)+mn + + print, 'typeproj: ',typeproj + +; wh=sort(innovsel) +; print,'innovsel ',innovsel(wh) + + clr=fix((innovsel-mn)/(mx-mn)*(num_cols-1))+1 + +; prevent colours going out of range + wh=where(clr lt 1) + if (wh(0) gt -1) then clr(wh)=1 + wh=where(clr gt num_cols) + if (wh(0) gt -1) then clr(wh)=num_cols + +; print,'clr ',clr(wh) + + case stash.sym of + 1: USERSYM, [-1,-1,1,1,-1],[1,-1,-1,1,1], /FILL + 2: usersym, cos(2.0*!pi*indgen(17)/16.0), sin(2.0*!pi*indgen(17)/16.0), thick=2.0, /fill + endcase + + spawn,'echo plotpoints 3 `date`' + +;; rgb=transpose(reform(color24_to_rgb(clr),nelwh,3)) + + symsize=stash.symsize*stash.symscale +; for i=0L,nelsel-1 do $ +; plots,lonsel(i),latsel(i),psym=8,color=clr,symsize=symsize + + if (stash.bindata eq 0) then begin + plots,lonsel,latsel,psym=8,color=clr,symsize=symsize,noclip=0 +; plots,lonsel,latsel,psym=3,color=clr + +; print, 'lonsel latsel' +; print,lonsel, format='(4g20.10)' +; print,latsel, format='(4g20.10)' + endif + + +; print, 'lonseld latseld' +; print,lonsel - lonsel(0), format='(4g20.10)' +; print,latsel - latsel(0), format='(4g20.10)' + +; wh=where(lonsel eq lonsel(0) and latsel eq latsel(0)) +; print,wh + + endelse + + spawn,'echo plotpoints 4 `date`' + print,"stash.symsize ",stash.symsize + + print,'limit=',[yrange(0),xrange(0),yrange(1),xrange(1)] + +; endif ; nel lonsel > 0 + + if (stash.bindata) then begin + fillval=-32000 + mxlat=max(latsel) + mnlat=min(latsel) + mxlon=max(lonsel) + mnlon=min(lonsel) + dlon=stash.binsize(0) + dlat=stash.binsize(1) + nlats=(mxlat-mnlat)/dlat+1 + nlons=(mxlon-mnlon)/dlon+1 + print,'nlons ',nlons,' nlats ',nlats + if (nlats ge 2 and nlons ge 2) then begin + innovsel2=fltarr(nlons,nlats) +; latsel2=fltarr(nlons,nlats) +; lonsel2=fltarr(nlons,nlats) + latsel2=findgen(nlats)*dlat+mnlat + lonsel2=findgen(nlons)*dlon+mnlon + innovsel2(*)=fillval ; missing data +; latsel2(*)=fillval +; lonsel2(*)=fillval + nelin=n_elements(innovsel) + print,mnlat,mnlon + iiarr=(lonsel-mnlon)/dlon + ijarr=(latsel-mnlat)/dlat + print,min(ijarr),max(ijarr),min(ijarr),max(ijarr) + info,latsel2 + info,lonsel2 + for i=0L,nelin-1 do begin + ii=iiarr(i) + iip=ii+1 + if (iip ge nlons-1) then iip=ii + iim=ii-1 + if (iim lt 0) then iim=0 + ij=ijarr(i) + ijp=ij+1 + if (ijp ge nlats-1) then ijp=ij + ijm=ij-1 + if (ijm lt 0) then ijm=0 + + innovsel2(ii,ij)=innovsel(i) + ; fill in gaps + if (innovsel2(iip,ij) eq fillval) then innovsel2(iip,ij)=innovsel(i) + if (innovsel2(ii,ijp) eq fillval) then innovsel2(ii,ijp)=innovsel(i) + if (innovsel2(iim,ij) eq fillval) then innovsel2(iim,ij)=innovsel(i) + if (innovsel2(ii,ijm) eq fillval) then innovsel2(ii,ijm)=innovsel(i) +; latsel2(ii,ij)=latsel(i) +; lonsel2(ii,ij)=lonsel(i) + endfor + info,latsel2 + print,latsel2 + info,lonsel2 + print,lonsel2 + + TVLCT, R, G, B, /get + TVLCT,R(1),G(1),B(1),0 ; bodge fix for wrong black contour + + wh=where(innovsel2 gt mx-(mx-mn)*0.001 and innovsel2 ne fillval) + if (wh(0) gt -1) then innovsel2(wh)=mx-(mx-mn)*0.001 + wh=where(innovsel2 lt mn and innovsel2 ne fillval) + if (wh(0) gt -1) then innovsel2(wh)=mn + + levs2=nice_contourlevels([mn,mx],nlevels=50) + + contour,innovsel2,lonsel2,latsel2,levels=levs2, /overplot, /cell_fill, min_value=-1000 + + TVLCT,R(0),G(0),B(0),0 ; restore original colour table + endif + + endif + + if (daymin eq daymax and daymin eq 0) then begin + print,'No data file' + xyouts, 0.15, 0.5, 'No data files', /normal, charsize=8 + endif + +; plot colorbar + levs=nice_contourlevels([mn,mx],nlevels=10) + + print, levs + + barclr=findgen(num_cols)+1 + colorbar_idl, [mn,mx], barclr, levs + endif ; stash.txt eq 0 + + stash.busy=0 + + if (stash.pmulti eq 2) then begin + typeproj=stash.typeproj + print, 'old stash.typeproj: ',stash.typeproj + if (typeproj eq 2) then stash.typeproj=3 ;plot north and south poles + if (typeproj eq 3) then stash.typeproj=2 + print, 'new stash.typeproj: ',stash.typeproj + endif + + endfor ; nplots + + +end + +;------------------------------------------ +;Profile plotting window and event handling +;------------------------------------------ + +PRO profilewindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash2 + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + print,uval + if (uval eq "PRINTPW") then begin + ps=1 + eps=0 + landscape=1 + pr2,file="~/plotprofile.ps",landscape=landscape,ps=ps,eps=eps,color=1 + plotprofile,stash2 + prend2,/view + endif + if (uval eq "SAVEPW") then begin + thisDevice = !D.Name + psave=!p + + Set_Plot, 'Z' ; do graphics in the background + Device, Set_Resolution=[640,480] ; clear any existing stuff + !p.charsize=0.75 + + if (stash2.white_on_black eq 0) then begin +; flip background and foreground color + pcolor=!p.color + pbackground=!p.background + !p.color=pbackground + !p.background=pcolor + + endif + print,'!p.color,!p.background ',!p.color,!p.background + + setupct, r, g, b, $ + coltable=stash2.coltable,white_on_black=stash2.white_on_black ; setup color table +; plot data + plotprofile,stash2 + snapshot = TVRD() + WRITE_GIF,"~/plotprofile.gif",snapshot, r, g, b + Device, Z_Buffer=1 ; reset graphics mode + Set_Plot, thisDevice + !p=psave + + spawn,'xv ~/plotprofile.gif' + + endif + if (uval eq "TXTPW") then begin + plotprofile,stash2,/txt + endif +end + +PRO plotprofile,stash2, txt=txt + + if (n_elements(txt) eq 0) then txt=0 + +;** need to deal with multiple times + + dep2=stash2.dep2 + val2=stash2.val2 + obs2=stash2.obs2 + bkg2=stash2.bkg2 + obstype2=stash2.obstype2 + qcarr2=stash2.qcarr2 + dayarr2=stash2.dayarr2 + datestr=stash2.datestr + xselstr=stash2.xselstr + yselstr=stash2.yselstr + rmdi=stash2.rmdi + + multstr="" + mindayarr2=min(dayarr2,max=maxdayarr2) + + whs=sort(dayarr2) + u=uniq(dayarr2) + + nu=n_elements(u) + dayarr2u=dayarr2(u) + + print,'dayarr2u: ',dayarr2u + + if (maxdayarr2 ne mindayarr2) then multstr="mult times "+strtrim(string(nu),2) + +; print,'obstype2 ',obstype2 + + print,'profile plot_bad_obs: ',stash2.plot_bad_obs + print, obs2 + print, bkg2 + print, qcarr2 + + if (stash2.plot_bad_obs eq 0) then begin + wh=where(obs2 ne rmdi and qcarr2 eq 0) + endif else begin +; wh=where(obs2 eq obs2) + wh=where(obs2 ne rmdi) + endelse + + if (wh(0) gt -1) then begin + depo1=dep2(wh) + valo1=val2(wh) + obso1=obs2(wh) + bkgo1=bkg2(wh) + qcarro1=qcarr2(wh) + endif + + + if (stash2.plot_bad_obs eq 0) then begin + wh=where(bkg2 ne rmdi and qcarr2 eq 0) + endif else begin +; wh=where(bkg2 eq bkg2) + wh=where(bkg2 ne rmdi) + endelse + + if (wh(0) gt -1) then begin + depb1=dep2(wh) + valb1=val2(wh) + obsb1=obs2(wh) + bkgb1=bkg2(wh) + qcarrb1=qcarr2(wh) + endif + + +;loop thru times + + if (n_elements(bkgb1) gt 0) then begin + xmx=max([obso1,bkgb1],min=xmn) + ymx=max([depo1,depb1],min=ymn) + endif else begin + xmx=max(obso1,min=xmn) + ymx=max(depo1,min=ymn) + endelse + +; set max and min depth based on selection of depths from the main window + if (ymx gt stash2.depmax) then ymx=stash2.depmax + if (ymn lt stash2.depmin) then ymn=stash2.depmin + +; reset xrange based on new ymx and ymn + if (n_elements(bkgb1) gt 0) then begin + wh1=where(depo1 ge ymn and depo1 le ymx) + wh2=where(depb1 ge ymn and depb1 le ymx) + if (wh1(0) gt -1 and wh2(0) gt -1) then xmx=max([obso1(wh1),bkgb1(wh2)],min=xmn) + endif else begin + wh1=where(depo1 ge ymn and depo1 le ymx) + if (wh1(0) gt -1) then xmx=max(obso1(wh1),min=xmn) + endelse + +; add a little bit to xrange to make plots look better + if (xmn eq xmx) then begin + xmn=xmn-0.5 + xmx=xmx+0.5 + endif + dxrange=(xmx-xmn)*0.02 + xmx=xmx+dxrange + xmn=xmn-dxrange + +; add a little bit to yrange to make plots look better + if (ymn eq ymx) then begin + ymn=ymn-0.5 + ymx=ymx+0.5 + endif + dyrange=(ymx-ymn)*0.01 + ymx=ymx+dyrange + ymn=ymn-dyrange + print,'** yrange: ',ymn, ymx + + if (txt eq 1) then begin + outfile='dataplot_profile.txt' + print, 'saving data to ',outfile + OPENW, unit, outfile, /get_lun + endif + + for t=0,nu-1 do begin ; loop through times + + wht=where(dayarr2 eq dayarr2u(t)) + depo=depo1(wht) + valo=valo1(wht) + obso=obso1(wht) + bkgo=bkgo1(wht) + qcarro=qcarro1(wht) + dayarro=dayarr2(wht) + if (n_elements(depb1) gt 0) then depb=depb1(wht) + if (n_elements(valb1) gt 0) then valb=valb1(wht) + if (n_elements(obsb1) gt 0) then obsb=obsb1(wht) + if (n_elements(bkgb1) gt 0) then bkgb=bkgb1(wht) + if (n_elements(qcarrb1) gt 0) then qcarrb=qcarrb1(wht) + + + +;print data + +; if (txt eq 1) then begin +; print,'rmdi: ',rmdi +; print,'profile data' +; for i=0,n_elements(depo)-1 do begin +; print,depo(i),obso(i),bkgo(i),qcarro(i) +; endfor +; print,'profile data' +; for i=0,n_elements(depb)-1 do begin +; print,depb(i),obsb(i),bkgb(i),qcarrb(i) +; endfor +; endif + + typestr="type: "+string(obstype2(0)) + +;get variable type + vartype=size(obstype2,/type) + if (vartype ne 7) then begin + if (obstype2(0) eq rmdi) then typestr="" + endif + +; line thickness + thick1=2 + thick2=2 + +; color1='FFCC66'x + color1=102 + color2=!p.color + color3=234 + + linestyle1=0 + linestyle2=0 + + who=sort(depo) + whb=sort(depb) + + obso_srto=obso(who) + depo_srto=depo(who) + qcarro_srto=qcarro(who) + whbad=where(qcarro ne 0) + + if (txt eq 0) then begin + + if (t eq 0) then $ + plot,obso_srto,depo_srto,ystyle=1,xstyle=1,linestyle=linestyle1,$ + xrange=[xmn,xmx],yrange=[ymx,ymn],thick=thick1, $ + psym=-4,ytitle='Level',xtitle='Value', $ + title=datestr+" "+multstr+" ("+xselstr+","+yselstr+") "+typestr, /nodata + + oplot,obso_srto,depo_srto,linestyle=linestyle1,psym=-4, thick=thick1, color=color1 + if (whbad(0) gt -1) then begin + oplot,obso_srto(whbad),depo_srto(whbad),psym=4, thick=thick1, color=color3 + oplot,obso_srto(whbad),depo_srto(whbad),psym=1, thick=thick1, color=color3 + endif + if (n_elements(bkgb) gt 0) then oplot,bkgb(whb),depb(whb),psym=-5,thick=thick2, color=color2,$ + linestyle=linestyle2 + xcoord=0.8 + ycoord=0.2 +; if (stash2.salinity eq 1) then xcoord=0.15 ; left corner legend for salinity + nel=n_elements(who) + if (obso(who(0)) lt obso(who(nel-1))) then xcoord=0.15 + if (t eq 0) then $ + + ycoord2=ycoord-0.05 + xcoord2=xcoord+0.03 + xcoord3=xcoord+0.05 + plots, [xcoord,xcoord2],[ycoord,ycoord], psym=-4, linestyle=linestyle1, /normal, $ + thick=thick1, color=color1 + xyouts, xcoord+0.05, ycoord, 'obs', /normal + plots, [xcoord,xcoord2],[ycoord2,ycoord2], psym=-5, linestyle=linestyle2, /normal, $ + thick=thick2, color=color2 + xyouts, xcoord+0.05, ycoord2, 'bkg',/normal + + endif else begin ; txt + + printf, unit,'observations ',n_elements(who) + for i=0L,n_elements(who)-1 do begin + printf, unit, depo(i), obso(i), dayarro(i), format='(3f18.5)' + endfor + printf, unit, 'background ',n_elements(who) + for i=0L,n_elements(whb)-1 do begin + printf, unit, depb(i), bkgb(i), dayarro(i), format='(3f18.5)' + endfor + + endelse + + endfor ; t + + if (txt eq 1) then FREE_LUN, unit + +end + +PRO profilewindow,dep2,val2,obs2,bkg2,obstype2,qcarr2,dayarr2,datestr,xselstr,yselstr,rmdi,salinity=salinity, $ + plot_bad_obs=plot_bad_obs, density=density, white_on_black=white_on_black, coltable=coltable, $ + depmax=depmax, depmin=depmin + basepw=WIDGET_BASE(/column) + drawpw = WIDGET_DRAW(basepw, XSIZE=640, YSIZE=480) + buttonBase = Widget_Base(basepw, Row=1) + buttonpw = WIDGET_BUTTON(buttonBase, VALUE='Print',uvalue="PRINTPW") + button2pw = WIDGET_BUTTON(buttonBase, VALUE='Save',uvalue="SAVEPW") + button3pw = WIDGET_BUTTON(buttonBase, VALUE='Text file',uvalue="TXTPW") + WIDGET_CONTROL, basepw, /REALIZE + + if (n_elements(salinity) eq 0) then salinity=0 + if (n_elements(density) eq 0) then density=0 + if (n_elements(plot_bad_obs) eq 0) then plot_bad_obs=0 + if (n_elements(white_on_black) eq 0) then white_on_black=1 + + stash2 = { dep2:dep2,val2:val2,obs2:obs2, bkg2:bkg2, $ + obstype2:obstype2, qcarr2:qcarr2, dayarr2:dayarr2, $ + datestr:datestr,xselstr:xselstr, yselstr:yselstr, $ + rmdi:rmdi, salinity:salinity, plot_bad_obs:plot_bad_obs,$ + density:density, white_on_black:white_on_black, $ + coltable:coltable, depmax:depmax, depmin:depmin } + + plotprofile,stash2 + + WIDGET_CONTROL, basepw, SET_UVALUE=stash2 + + XMANAGER, 'profilewindow', basepw, /NO_BLOCK +end + +;--------------------------------------- +;Worst points, window and event handling +;--------------------------------------- + +PRO worstpoints,stash2 + +;stash2 is a combination of main stash and worstpoints specific stuff + + xrange=stash2.xrange + yrange=stash2.yrange + selpoints,stash2,lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, obnumsel, numsel, typestr + + str1='Worst points in '+$ + ' lons ('+strtrim(string(xrange(0)),2)+','+strtrim(string(xrange(1)),2)+$ + ') lats ('+strtrim(string(yrange(0)),2)+','+strtrim(string(yrange(1)),2)+')'+$ + ' depths '+strtrim(string(long(stash2.depmin)),2)+'-'+strtrim(string(long(stash2.depmax)),2) + print,str1 + + WIDGET_CONTROL, stash2.wwlabel1, set_value=str1 + + count=n_elements(innovsel) + wh=sort(abs(innovsel)) + wh0=reverse(wh) ; reverse order starting with the largest + cmax=min([count,10]) + stash2.lonselw(0:cmax-1)=lonsel(wh0(0:cmax-1)) + stash2.latselw(0:cmax-1)=latsel(wh0(0:cmax-1)) + stash2.dayselw(0:cmax-1)=daysel(wh0(0:cmax-1)) + print,'lon lat '+typestr+' qc date ' + for j1=1,cmax do begin + j=j1-1 + jul_to_dtstr,daysel(wh0(j)),datestr +; datedt=jul_to_dt(daysel(wh0(j))) +; datestr=strtrim(fix(datedt.year),2)+'/'+ $ +; strtrim(string(fix(datedt.month),format='(i2.2)'),2)+'/'+ $ +; strtrim(string(fix(datedt.day),format='(i2.2)'),2)+' '+ $ +; strtrim(string(fix(datedt.hour),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.minute),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.second),format='(i2.2)'),2) + + print,lonsel(wh0(j)),latsel(wh0(j)),innovsel(wh0(j)),$ + qcsel(wh0(j)),' ',datestr + + endfor + + if (n_elements(stash2) gt 0) then begin + i=0 + WIDGET_CONTROL, stash2.labels2(i,0), set_value="Lon" & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,0), set_value="Lat" & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,0), set_value=typestr & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,0), set_value="QC" & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,0), set_value="Date" & i=i+1 + + for j1=1,cmax do begin + j=j1-1 + jul_to_dtstr,daysel(wh0(j)),datestr +; datedt=jul_to_dt(daysel(wh0(j))) +; datestr=strtrim(fix(datedt.year),2)+'/'+ $ +; strtrim(string(fix(datedt.month),format='(i2.2)'),2)+'/'+ $ +; strtrim(string(fix(datedt.day),format='(i2.2)'),2)+' '+ $ +; strtrim(string(fix(datedt.hour),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.minute),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.second),format='(i2.2)'),2) + + i=0 + WIDGET_CONTROL, stash2.labels2(i,j1), $ + set_value=strtrim(string(lonsel(wh0(j)),format='(f9.3)'),2) & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,j1), $ + set_value=strtrim(string(latsel(wh0(j)),format='(f9.3)'),2) & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,j1), set_value=strtrim(string(innovsel(wh0(j))),2) & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,j1), set_value=strtrim(string(qcsel(wh0(j))),2) & i=i+1 + WIDGET_CONTROL, stash2.labels2(i,j1), set_value=strtrim(datestr,2) & i=i+1 + +; print,lonsel(wh0(j)),latsel(wh0(j)),innovsel(wh0(j)),$ +; qcsel(wh0(j)),' ',datestr + + endfor + + + endif + + + + +end + +pro worstpointswindow,stash + basepw=WIDGET_BASE(/column) +; drawpw = WIDGET_DRAW(basepw, XSIZE=640, YSIZE=480) + + wwlabel1 = WIDGET_LABEL(basepw, XSIZE=480, VALUE="Worst points") + + nj=11 + ni=5 + labels=intarr(nj) + for j=0,nj-1 do begin + labels(j)=Widget_Base(basepw,row=1) + endfor + + labsiz=[50,50,50,50,125] + labels2=intarr(ni+2,nj) + for j=0,nj-1 do begin + for i=0,ni-1 do begin + labels2(i,j) = WIDGET_LABEL(labels(j), XSIZE=labsiz(i), $ + VALUE="a") + endfor + if (j gt 0) then begin + labels2(i,j) = WIDGET_BUTTON(labels(j), VALUE='Zoom to', uvalue="Zoom to "+strtrim(string(j),2)) + labels2(i+1,j) = WIDGET_BUTTON(labels(j), VALUE='Profile', uvalue="Profile "+strtrim(string(j),2)) + endif + endfor + + stashb={ wwlabel1:wwlabel1, labels2:labels2, ni:ni, nj:nj, lonselw:dblarr(10), latselw:dblarr(10), dayselw:dblarr(10)} + stash2=CREATE_STRUCT(stash,stashb) + + buttonpw = WIDGET_BUTTON(basepw, VALUE='Print',uvalue="PRINTPW") + + WIDGET_CONTROL, basepw, /REALIZE + worstpoints,stash2 + WIDGET_CONTROL, basepw, SET_UVALUE=stash2 + XMANAGER, 'worstpointswindow', basepw, /NO_BLOCK +end + +PRO worstpointswindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash2 + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + print,uval + + xarr1=stash2.xarr + yarr1=stash2.yarr + dep1=stash2.dep + dayarr=stash2.dayarr + daymin=stash2.daymin + daymax=stash2.daymax + obstypes1=stash2.obstypes + xrange=stash2.xrange + yrange=stash2.yrange + xs=xrange(1)-xrange(0) + ys=yrange(1)-yrange(0) + rmdi=stash2.rmdi + if (stash2.salinity eq 0) then begin + obs1=stash2.obs + bkg1=stash2.bkg + qcarr1=stash2.qcarr + endif else begin + obs1=stash2.obs2 + bkg1=stash2.bkg2 + qcarr1=stash2.qcarr2 + endelse + + if (uval eq "PRINTTSW") then begin + ps=1 + eps=0 + landscape=1 + pr2,file="~/worstpoints.ps",landscape=landscape,ps=ps,eps=eps,color=1 + worstpoints,stash2 + prend2,/view + endif + print,strmid(uval,0,7) + if (strcmp(strmid(uval,0,7),"Zoom to")) then begin + num=fix(strmid(uval,7,3)) + xsel=stash2.lonselw(num-1) + ysel=stash2.latselw(num-1) + print,num,xsel,ysel + dataplot_zoom,stash2, xsel, ysel, 1 + plotpoints,stash2 + + endif + if (strcmp(strmid(uval,0,7),"Profile")) then begin + num=fix(strmid(uval,7,3)) + xsel=stash2.lonselw(num-1) + ysel=stash2.latselw(num-1) + daysel=stash2.dayselw(num-1) +; print,num,xsel,ysel,daysel,daysel-long(daysel),float(daysel) +; info,dayarr +; info,daysel +; info,xarr1 +; info,ysel +; info,yarr1 +; info,xsel + + wh1=where(xarr1 eq xsel and yarr1 eq ysel) +; print,'dayarr(wh1) ',dayarr(wh1), float(dayarr(wh1)) +; print,'dayarr(wh1)-long ',dayarr(wh1)-long(dayarr(wh1)) +; print,'dep1(wh1) ',dep1(wh1) + wh2=where(xarr1 eq xsel and yarr1 eq ysel and float(dayarr) eq float(daysel)) +; print,'wh2 ',wh2 +; if (wh2(0) gt -1) then print,'daysel(wh2) ',daysel(wh2) + + wh=where(xarr1 eq xsel and yarr1 eq ysel and long(dayarr) eq long(daysel)) + if (wh(0) gt -1) then begin + dep2=dep1(wh) + val2=abs(obs1(wh)-bkg1(wh)) + obs2=obs1(wh) + bkg2=bkg1(wh) + obstype2=obstypes1(wh) + qcarr2=qcarr1(wh) + dayarr2=dayarr(wh) + jul_to_dtstr,stash2.dayselw(num-1),datestr + xselstr=string(xsel) + yselstr=string(ysel) + + profilewindow,dep2,val2,obs2,bkg2,obstype2,qcarr2,dayarr2,datestr,xselstr,yselstr,rmdi, salinity=stash2.salinity, $ + white_on_black=stash.white_on_black, coltable=stash.coltable, depmax=stash.depmax, depmin=stash.depmin + endif + endif + +; store values + WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash2 + +end + +PRO filterwindow, stash + + val=stash.obstypeselect + + obstypes=stash.obstypes + uniquetypes=strjoin(obstypes(uniq(obstypes, sort(obstypes))),string(10b)) + + base = WIDGET_BASE(GROUP_LEADER=stash.base ,/modal,/column) + + + intextid = CW_FIELD(base, TITLE = "Filter type", /FRAME, value=val, uvalue='intext', /RETURN_EVENTS) + outtextid = WIDGET_TEXT(base, value="Choose from:"+string(10b)+uniquetypes, $ + scr_xsize=200, scr_ysize=200, /scroll) + + buttonBase = Widget_Base(base, Row=1) + cancelID = Widget_Button(buttonBase, Value='Cancel', uvalue='cancel') + acceptID = Widget_Button(buttonBase, Value='Accept', uvalue='accept') + + WIDGET_CONTROL, base, /REALIZE + + ptr = Ptr_New({text:"", nocancel:0}) + + stash2={ ptr:ptr, intextid:intextid } + WIDGET_CONTROL, base, SET_UVALUE=stash2, /No_Copy + + XMANAGER, 'filterwindow', base + + theText = (*ptr).text + nocancel = (*ptr).nocancel + Ptr_Free, ptr + + print, 'finished ',theText, nocancel + +; if obstypeselect has changed then replot the points + + if (stash.obstypeselect ne theText and nocancel eq 1) then begin + stash.obstypeselect=theText + plotpoints,stash + endif + + +end + +PRO filterwindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash2 + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + WIDGET_CONTROL, ev.ID, GET_VALUE=val +; info,uval +; info,val + print,uval + print,val + + if (uval eq "accept" or uval eq "intext") then begin +; stash2.val=val + + Widget_Control, stash2.intextid, Get_Value=theText + print,'the text ',theText + + (*stash2.ptr).text=theText + (*stash2.ptr).nocancel=1 + endif + +; WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash2 + + WIDGET_CONTROL, ev.top, /DESTROY + +end + +;-------------------------------------- +; Input area +;-------------------------------------- + +PRO inputareawindow, xrange, yrange, toplevel, success + + val1=xrange(0) + val2=xrange(1) + val3=yrange(0) + val4=yrange(1) + + base = WIDGET_BASE(GROUP_LEADER=toplevel,/modal,/column) + + intextid1 = CW_FIELD(base, TITLE = "lon1", /FRAME, value=val1, uvalue='intext1', /RETURN_EVENTS) + intextid2 = CW_FIELD(base, TITLE = "lon2", /FRAME, value=val2, uvalue='intext2', /RETURN_EVENTS) + intextid3 = CW_FIELD(base, TITLE = "lat1", /FRAME, value=val3, uvalue='intext3', /RETURN_EVENTS) + intextid4 = CW_FIELD(base, TITLE = "lat2", /FRAME, value=val4, uvalue='intext4', /RETURN_EVENTS) + +; outtextid = WIDGET_TEXT(base, value="Choose from:"+string(10b)+uniquetypes, $ +; scr_xsize=200, scr_ysize=200, /scroll) + + buttonBase = Widget_Base(base, Row=1) + acceptID = Widget_Button(buttonBase, Value='Accept', uvalue='accept') + cancelID = Widget_Button(buttonBase, Value='Cancel', uvalue='cancel') + + WIDGET_CONTROL, base, /REALIZE + + ptr = Ptr_New({text1:"", text2:"", text3:"", text4:"", nocancel:0}) + + stash2={ ptr:ptr, intextid1:intextid1, intextid2:intextid2, $ + intextid3:intextid3, intextid4:intextid4} + WIDGET_CONTROL, base, SET_UVALUE=stash2, /No_Copy + + XMANAGER, 'inputareawindow', base + + lon1 = (*ptr).text1 + lon2 = (*ptr).text2 + lat1 = (*ptr).text3 + lat2 = (*ptr).text4 + nocancel = (*ptr).nocancel + Ptr_Free, ptr + + print, 'finished ',lon1, lon2, lat1, lat2, nocancel + +; if obstypeselect has changed then replot the points + + if (nocancel eq 1) then begin + xrange=[float(lon1),float(lon2)] + yrange=[float(lat1),float(lat2)] + xrange=xrange(sort(xrange)) + yrange=yrange(sort(yrange)) + wh=where(xrange gt 360) + if (wh(0) gt -1) then xrange(wh)=360 + wh=where(xrange lt -180) + if (wh(0) gt -1) then xrange(wh)=-180 + wh=where(yrange gt 90) + if (wh(0) gt -1) then yrange(wh)=90 + wh=where(yrange lt -90) + if (wh(0) gt -1) then yrange(wh)=-90 + + if (xrange(0) eq xrange(1)) then xrange(1)=xrange(1)+0.1 + if (yrange(0) eq yrange(1)) then yrange(1)=yrange(1)+0.1 + + success=1 + endif + + +end + +PRO inputareawindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash2 + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + WIDGET_CONTROL, ev.ID, GET_VALUE=val +; info,uval +; info,val + print,uval + print,val + + if (uval eq 'accept') then begin +; stash2.val=val + + Widget_Control, stash2.intextid1, Get_Value=theText1 + Widget_Control, stash2.intextid2, Get_Value=theText2 + Widget_Control, stash2.intextid3, Get_Value=theText3 + Widget_Control, stash2.intextid4, Get_Value=theText4 + print,'the text ',theText1, theText2, theText3, theText4 + + (*stash2.ptr).text1=theText1 + (*stash2.ptr).text2=theText2 + (*stash2.ptr).text3=theText3 + (*stash2.ptr).text4=theText4 + (*stash2.ptr).nocancel=1 + endif + +; WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash2 + + WIDGET_CONTROL, ev.top, /DESTROY + +end + +;-------------------------------------- +; Input max min +;-------------------------------------- + +PRO inputmxmnwindow, fmx, fmn, mx, mn, rmdi, toplevel, success + + print,'fmx/mn ',fmx,fmn + print,'mx/mn ',mx,mn + + val1=mx + val2=mn + + base = WIDGET_BASE(GROUP_LEADER=toplevel,/modal,/column) + + intextid1 = CW_FIELD(base, TITLE = "mx", /FRAME, value=val1, uvalue='intext1', /RETURN_EVENTS) + intextid2 = CW_FIELD(base, TITLE = "mn", /FRAME, value=val2, uvalue='intext2', /RETURN_EVENTS) + + text="Max and min not locked" + if (fmx ne rmdi) then text="Max locked" + if (fmn ne rmdi) then text="Min Locked" + if (fmx ne rmdi and fmn ne rmdi) then text="Max and min locked" + outtextid = WIDGET_TEXT(base, value=text, $ + scr_xsize=200, scr_ysize=40) + + buttonBase = Widget_Base(base, Row=1) + acceptID = Widget_Button(buttonBase, Value='Accept/lock', uvalue='accept') + resetID = Widget_Button(buttonBase, Value='Reset/free', uvalue='reset') + cancelID = Widget_Button(buttonBase, Value='Cancel', uvalue='cancel') + + + WIDGET_CONTROL, base, /REALIZE + + ptr = Ptr_New({text1:"", text2:"", nocancel:0}) + + stash2={ ptr:ptr, intextid1:intextid1, intextid2:intextid2} + WIDGET_CONTROL, base, SET_UVALUE=stash2, /No_Copy + + XMANAGER, 'inputmxmnwindow', base + + fmx = float((*ptr).text1) + fmn = float((*ptr).text2) + + info, fmx + info, fmn + + nocancel = (*ptr).nocancel + Ptr_Free, ptr + + print, 'finished ',fmx,fmn, mx, mn + +; if obstypeselect has changed then replot the points + + if (nocancel eq 1) then begin + success=1 + endif + if (nocancel eq 2) then begin + fmx=rmdi + fmn=rmdi + success=1 + endif + +end + +PRO inputmxmnwindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash2 + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + WIDGET_CONTROL, ev.ID, GET_VALUE=val +; info,uval +; info,val + print,'uval ',uval,' val ',val + + if (uval eq 'accept') then begin +; stash2.val=val + + Widget_Control, stash2.intextid1, Get_Value=theText1 + Widget_Control, stash2.intextid2, Get_Value=theText2 + print,'the text ',theText1, theText2 + + (*stash2.ptr).text1=theText1 + (*stash2.ptr).text2=theText2 + (*stash2.ptr).nocancel=1 + endif + + if (uval eq 'reset') then begin + (*stash2.ptr).nocancel=2 + endif + +; WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash2 + + WIDGET_CONTROL, ev.top, /DESTROY + +end + + + +pro infowindow + basepw=WIDGET_BASE(/column) + xsz=360 + + iwlabel0 = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="Dataplot") + iwlabela = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="--------") + iwlabelb = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="") + iwlabel1 = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="To report bugs or for help") + iwlabel2 = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="contact Dan Lea") + iwlabel3 = WIDGET_LABEL(basepw, XSIZE=xsz, VALUE="daniel.lea@metoffice.gov.uk") + + WIDGET_CONTROL, basepw, /REALIZE + +; WIDGET_CONTROL, basepw, SET_UVALUE=stash2 +; XMANAGER, 'worstpointswindow', basepw, /NO_BLOCK +end + +PRO dataplot_zoom, stash, xdata, ydata, zoominout + + xrange=stash.xrange + yrange=stash.yrange + xrangedef=stash.xrangedef + yrangedef=stash.yrangedef + + + print,xrange,yrange + +; zx=xrange(0) +; zy=yrange(0) + sx=xrange(1)-xrange(0) + sy=yrange(1)-yrange(0) + sxd=xrangedef(1)-xrangedef(0) + syd=yrangedef(1)-yrangedef(0) + + print,sx,sy + + if (zoominout eq 1) then begin + sx=sx/2. + sy=sy/2. +; try to squarify for zoomed in version + sx2=(sx+sy)/2. +; sx=max(sx,sx2) +; sy=max(sy,sx2) +; sx=(sx+sx2)/2. +; sy=(sy+sx2)/2. + +; try to tend to initial proportions for zooming in + sx=(sx+1.0*(sxd*0.5/(sxd+syd)))/2. + sy=(sy+1.0*(syd*0.5/(sxd+syd)))/2. + + endif + if (zoominout eq -1) then begin + sx=sx*2. + sy=sy*2. + ; try to make similar to initial proportions for zooming out + sx2=(sx+sy)*2. + sx=(sx+sx2*(sxd*0.5/(sxd+syd)))/2. + sy=(sy+sx2*(syd*0.5/(sxd+syd)))/2. + + endif + + + print,'sx sy ',sx,sy, xdata, ydata + + oxrange=xrange + + xrange=[xdata-sx/2.,xdata+sx/2.] + yrange=[ydata-sy/2.,ydata+sy/2.] + + if (oxrange(1) le 180) then begin ; 0 longitude centred + if (xrange(0) lt xrangedef(0)) then xrange(0)=xrangedef(0) + if (xrange(1) gt xrangedef(1)) then xrange(1)=xrangedef(1) + endif else begin ; 180 longitude centred + if (xrange(0) lt xrangedef(0)+180) then xrange(0)=xrangedef(0)+180 + if (xrange(1) gt xrangedef(1)+180) then xrange(1)=xrangedef(1)+180 + endelse + + if (yrange(0) lt yrangedef(0)) then yrange(0)=yrangedef(0) + if (yrange(1) gt yrangedef(1)) then yrange(1)=yrangedef(1) + + print,'xrange ',xrange,' yrange ',yrange + + stash.xrange=xrange + stash.yrange=yrange + +end + +;--------------------------------------- +;Time series plotting and event handling +;--------------------------------------- + +PRO plottimeseries, stash + + xrange=stash.xrange + yrange=stash.yrange +; dayarr=stash.dayarr + daymin=stash.daymin + daymax=stash.daymax + dayminl=stash.dayminl + daymaxl=stash.daymaxl + + numtimeseries=stash.numtimeseries ; if 1 then plot number of points + +; print,depmin,xrange,yrange + +; wh=where(dep1 eq ev.index) +; wh=where(dep1 eq depmin and $ +; dayarr ge daymin and dayarr le daymax) + +; + +; nelwh=n_elements(wh) + + ; select points to plot + typestr='' + + if (stash.plottssel eq 1) then begin + dayminl=daymin + daymaxl=daymax + endif + + print,'djl ',dayminl,daymaxl, min(stash.dayarr), max(stash.dayarr) + + selpoints, stash, lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr, $ + daymin=dayminl, daymax=daymaxl, /rmsmean, innovsel2=innovsel2 + + print,'djl ',min(daysel), max(daysel) + + if (stash.plottssel eq 1) then begin + daymaxl=daymaxl+1 + endif + + +; plot,daysel, ystyle=1 + + print,'n_elements(daysel) ',n_elements(daysel), min(daysel), max(daysel) + print, dayminl, daymaxl + +; group in 1/4 day bins + +; binspday=double(4.0) ; every 6 hours +; binspday=double(8.0) ; every 3 hours + binspday=double(stash.binspday) + nbins=(daymaxl-dayminl)*binspday+1 + + print, daymaxl, dayminl, binspday + + x2arr=dblarr(nbins) + xarr=dblarr(nbins) + narr=dblarr(nbins) + tarr=dblarr(nbins) + meants=dblarr(nbins) + rmsts=dblarr(nbins) + + print, 'nbins: ',nbins + + if n_elements(innovsel) gt 0 then begin + + print,max(daysel),min(daysel) + + for ibin=0L,nbins-1 do begin + timmn=double(dayminl)+ibin/binspday + timmx=timmn+1/binspday +; print, ibin, timmn, timmx, timmx-timmn + wh=where(daysel ge timmn and daysel lt timmx, count) + print, 'ibin ',ibin, timmn, timmx, count +; redo based on the number of observations + if (wh(0) ne -1) then begin + innovsels=innovsel(wh) + innovsel2s=innovsel2(wh) + numsels=numsel(wh) + + x2arr(ibin)=total(innovsel2s*numsels) + xarr(ibin)=total(innovsels*numsels) +; narr(ibin)=n_elements(innovsels) + narr(ibin)=total(numsels) +; print,ibin, x2arr(ibin), xarr(ibin) + endif + tarr(ibin)=timmn + endfor + + meants=xarr/narr + rmsts=sqrt(x2arr/narr) + +; print,'meants: ',meants +; print,'rmsts: ',rmsts + + endif ; n_elements(innovsel) + + wh=where(finite(meants)) ; find finite values + ymx=max([meants(wh),rmsts(wh)],min=ymn) + +;put a bit of white space around ymx,ymn + dymxmn=(ymx-ymn)*0.02 + ymx=ymx+dymxmn + ymn=ymn-dymxmn + + print,'ymx/mn ',ymx,ymn + + strtsal='' +; print,'stash.filetype ',stash.filetype + if (stash.filetype eq 'Prof' or stash.filetype eq 'feedback') then begin + strtsal='T: ' + if (stash.salinity eq 1) then strtsal='S: ' + endif else begin + strtsal=stash.filetype+': ' + endelse + + title=strtsal+typestr+' lons ('+string(xrange(0))+','+string(xrange(1))+$ + ') lats ('+string(yrange(0))+','+string(yrange(1))+')' + print,title + +; dtarr=jul_to_dt(tarr) + dtarr=tarr-0.5 ; convert back to julian day + + xmx=max(dtarr,min=xmn) +;put a bit of white space around xmx,xmn + dxmxmn=(xmx-xmn)*0.02 + xmx=xmx+dxmxmn + xmn=xmn-dxmxmn + + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%I:%S', '%H', '%D %M, %Y']) + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%D %M, %Y']) + +date_label = LABEL_DATE(DATE_FORMAT=['%D-%M','%Y']) + + + + if (stash.txt eq 0) then begin + if (numtimeseries ne 1) then begin + plot,dtarr, meants, xstyle=1, linestyle=1, yrange=[ymn,ymx], title=title, $ + ytitle=typestr, xrange=[xmn,xmx], $ + XTICKUNITS=['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + + plot, dtarr, rmsts, xstyle=1, yrange=[ymn,ymx], /noerase, $ + ytitle=typestr, xrange=[xmn,xmx], $ + XTICKUNITS=['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + + + xcoord=0.8 + ycoord=0.9 + ycoord=0.35 + ycoord=0.2 +; ukmo_legend,xcoord=xcoord,ycoord=ycoord,delta_y=0.05,$ +; ['RMS','mean'],linestyle=[0,1],/normal + + ycoord2=ycoord-0.05 + xcoord2=xcoord+0.03 + xcoord3=xcoord+0.05 + plots, [xcoord,xcoord2],[ycoord,ycoord], linestyle=0, /normal + xyouts, xcoord3, ycoord, 'RMS', /normal + plots, [xcoord,xcoord2],[ycoord2,ycoord2], linestyle=1, /normal + xyouts, xcoord3, ycoord2, 'mean',/normal + + endif else begin + plot,dtarr, narr, xstyle=1, title=title, $ + ytitle='number of obs', $ + XTICKUNITS=['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + + endelse + endif else begin + + outfile=stash.outfile+'_timeseries.txt' + print, 'saving data to ',outfile + OPENW, unit, outfile, /get_lun +; printf,unit,'Output timeseries data: ' + printf,unit, strtsal + printf,unit, typestr + printf,unit, xrange, yrange + printf,unit, binspday + nel=n_elements(dtarr) + for i=0L,nel-1 do begin + printf,unit, dtarr(i), narr(i), meants(i), rmsts(i),format='(d18.8,d18.2,d18.8,d18.8)' + endfor + FREE_LUN, unit + + endelse + +; print,'min/max lonsel: ',min(lonsel),max(lonsel) + +end + +PRO timeserieswindow, stash + basepw=WIDGET_BASE(/column) + drawpw = WIDGET_DRAW(basepw, XSIZE=640, YSIZE=480) + buttons=Widget_Base(basepw,row=1) + + tlb = Widget_Base(buttons,Title='Push-Buttons', row=1, Scr_XSize=400,$ + /Exclusive) +; no_release only sends select events (not release ones) + buttonp1 = Widget_Button(tlb, Value='1 bin per day',uvalue='RADIO1',/no_release) + buttonp2 = Widget_Button(tlb, Value='2 bins',uvalue='RADIO2',/no_release) + buttonp3= Widget_Button(tlb, Value='4 bins',uvalue='RADIO3',/no_release) + buttonp4 = Widget_Button(tlb, Value='8 bins',uvalue='RADIO4',/no_release) + + if (stash.binspday eq 1) then Widget_Control, buttonp1, Set_Button=1 + if (stash.binspday eq 2) then Widget_Control, buttonp2, Set_Button=1 + if (stash.binspday eq 4) then Widget_Control, buttonp3, Set_Button=1 + if (stash.binspday eq 8) then Widget_Control, buttonp4, Set_Button=1 + + tlb2 = Widget_Base(buttons,Title='Push-Buttons', row=1, Scr_XSize=100,$ + /NonExclusive) + buttonpa1= Widget_Button(tlb2, Value='plot selected period',uvalue='PLOTSEL') + + + Widget_Control, buttonpa1, Set_Button=stash.plottssel + + buttonpw = WIDGET_BUTTON(buttons, VALUE='Print',uvalue='PRINTTSW') + buttonpw2 = WIDGET_BUTTON(buttons, VALUE='Output',uvalue='OUTPUTTSW') + + WIDGET_CONTROL, basepw, /REALIZE + + xyouts,0.2,0.5,'working...',/normal,charsize=2.5 + + plottimeseries,stash + + WIDGET_CONTROL, basepw, SET_UVALUE=stash + + XMANAGER, 'timeserieswindow', basepw, /NO_BLOCK +end + +PRO timeserieswindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + print,uval + if (uval eq 'PRINTTSW') then begin + ps=1 + eps=0 + landscape=1 + pr2,file='~/timeseries.ps',landscape=landscape,ps=ps,eps=eps,color=1 + plottimeseries,stash + prend2,/view + endif + if (uval eq 'OUTPUTTSW') then begin + savetxt=stash.txt + stash.txt=1 + plottimeseries,stash + stash.txt=savetxt + endif + if (uval eq 'RADIO1') then begin + stash.binspday=1 + plottimeseries,stash + endif + if (uval eq 'RADIO2') then begin + stash.binspday=2 + plottimeseries,stash + endif + if (uval eq 'RADIO3') then begin + stash.binspday=4 + plottimeseries,stash + endif + if (uval eq 'RADIO4') then begin + stash.binspday=8 + plottimeseries,stash + endif + if (uval eq 'PLOTSEL') then begin + stash.plottssel=1-stash.plottssel + print,'stash.plottssel ',stash.plottssel + WIDGET_CONTROL, ev.TOP, SET_UVALUE=stash + plottimeseries,stash + endif + + +end + +;---------------------------------------- +; T-S diagram plotting and event handling +;---------------------------------------- + +PRO plottsdiagram, stash + + xrange=stash.xrange + yrange=stash.yrange +; dayarr=stash.dayarr + daymin=stash.daymin + daymax=stash.daymax + dayminl=stash.dayminl + daymaxl=stash.daymaxl + xarr=stash.xarr + yarr=stash.yarr + rmdi=stash.rmdi + + ; select T and S points to plot + typestr='' + selpoints, stash, lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr, $ + daymin=dayminl, daymax=daymaxl, salinity=1 + + ; select points with salinity + + nel=n_elements(lonsel) + + if (nel gt 0) then begin + + bkg=stash.bkg + bkg2=stash.bkg2 + obs=stash.obs + obs2=stash.obs2 + dep=stash.dep + strtarr=0 + depmin=stash.depmin + depmax=stash.depmax + + for i=0L,nel-1 do begin + wh=where(lonsel(i) eq xarr and latsel(i) eq yarr and $ + dep ge depmin and dep le depmax ) + if (wh(0) gt -1) then begin + if (strtarr eq 0) then begin + strtarr=1 + bkgsel=bkg(wh) + bkg2sel=bkg2(wh) + obssel=obs(wh) + obs2sel=obs2(wh) + endif else begin + bkgsel=[bkgsel,bkg(wh)] + bkg2sel=[bkg2sel,bkg2(wh)] + obssel=[obssel,obs(wh)] + obs2sel=[obs2sel,obs2(wh)] + endelse + endif + endfor + + ;filter out points with missing data + + wh=where(bkgsel ne rmdi and bkg2sel ne rmdi $ + and obssel ne rmdi and obs2sel ne rmdi) + + if (wh(0) gt -1) then begin + obssel=obssel(wh) + bkgsel=bkgsel(wh) + obs2sel=obs2sel(wh) + bkg2sel=bkg2sel(wh) + + xmn=min([obssel,bkgsel],max=xmx) + ymn=min([obs2sel,bkg2sel],max=ymx) + + title='T-S diagram: dep '+string(depmin)+'-'+string(depmax) + + plot,obssel,obs2sel,psym=4, color='FFFFFF'x, xtitle='Temperature',ytitle='Salinity',$ + xrange=[xmn,xmx], yrange=[ymn,ymx],xstyle=1,ystyle=1, title=title + oplot,bkgsel,bkg2sel,psym=5, color='FFCC66'x + + xcoord=0.8 + ycoord=0.9 + ycoord=0.2 +; ukmo_legend,xcoord=xcoord,ycoord=ycoord,delta_y=0.05,$ +; ['obs','bkg'],psym=[4,5],color=['FFFFFF'x, 'FFCC66'x],/normal + + ycoord2=ycoord-0.05 + xcoord2=xcoord+0.03 + xcoord3=xcoord+0.05 + plots, [xcoord,xcoord2],[ycoord,ycoord], psym=4, color='FFFFFF'x, /normal + xyouts, xcoord+0.05, ycoord, 'obs', /normal + plots, [xcoord,xcoord2],[ycoord2,ycoord2], psym=5, color='FFCC66'x, /normal + xyouts, xcoord+0.05, ycoord2, 'bkg',/normal + + + endif + endif + +end + +PRO tsdiagramwindow, stash + basepw=WIDGET_BASE(/column) + drawpw = WIDGET_DRAW(basepw, XSIZE=640, YSIZE=480) + buttonpw = WIDGET_BUTTON(basepw, VALUE='Print',uvalue='PRINTTSW') + WIDGET_CONTROL, basepw, /REALIZE + + plottsdiagram,stash + + WIDGET_CONTROL, basepw, SET_UVALUE=stash + + XMANAGER, 'tsdiagramwindow', basepw, /NO_BLOCK +end + +PRO tsdiagramwindow_event, ev + WIDGET_CONTROL, ev.TOP, GET_UVALUE=stash + WIDGET_CONTROL, ev.ID, GET_UVALUE=uval + print,uval + if (uval eq 'PRINTTSW') then begin + ps=1 + eps=0 + landscape=1 + pr2,file='~/tsdiagram.ps',landscape=landscape,ps=ps,eps=eps,color=1 + plottsdiagram,stash + prend2,/view + endif +end + +PRO jul_to_dtstr, daysel, datestr, notime=notime + +;print,'called jul_to_dtstr ',daysel + +; IDL Julian days start at 12 noon + + CALDAT, daysel(0)-0.5, Month, Day, Year, Hour, Minute, Second + datestr=strtrim(fix(year),2)+'/'+ $ + strtrim(string(fix(month),format='(i2.2)'),2)+'/'+ $ + strtrim(string(fix(day),format='(i2.2)'),2) + + if (n_elements(notime) eq 0) then $ + datestr=datestr+' '+$ + strtrim(string(fix(hour),format='(i2.2)'),2)+':'+ $ + strtrim(string(fix(minute),format='(i2.2)'),2)+':'+ $ + strtrim(string(fix(second),format='(i2.2)'),2) + +; datedt=jul_to_dt(daysel) +; datedt=datedt(0) +; datestr=strtrim(fix(datedt.year),2)+'/'+ $ +; strtrim(string(fix(datedt.month),format='(i2.2)'),2)+'/'+ $ +; strtrim(string(fix(datedt.day),format='(i2.2)'),2)+' '+ $ +; strtrim(string(fix(datedt.hour),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.minute),format='(i2.2)'),2)+':'+ $ +; strtrim(string(fix(datedt.second),format='(i2.2)'),2) + +;print,datestr + +END + +;----------------------------------------------------------------------- +; MAIN routine +; Widget creation routine. +; dataplot, [longitude, latitude, deparr, dayarr, valarr, bkgarr] +;+ +PRO dataplot, indata, rmdi=rmdi, filename=filename, salinity=salinity, batch=batch, $ + ps=ps, gif=gif, area=area, typeplot=typeplot, ombtypeplot=ombtypeplot, $ + alldays=alldays, depths=depths, $ + mx=mx, mn=mn, showmdt=showmdt, obstypeselect=obstypeselect, printobstypes=printobstypes, $ + daterange=daterange, timeseries=timeseries, binspday=binspday, plot_bad_obs=plot_bad_obs, $ + plot_only_bad_obs=plot_only_bad_obs, $ + numtimeseries=numtimeseries, txt=txt, netcdf=netcdf, vertgrad=vertgrad, healthcheck=healthcheck, $ + duplicates=duplicates, differences=differences, outfile=outfile, white_on_black=white_on_black, $ + bindata=bindata, symscale=symscale, hiresmap=hiresmap, coltable=coltable, $ + picsize=picsize, pmulti=pmulti, typeproj=typeproj, dayrange=dayrange, $ + notfussy=notfussy, mld=mld, binsize=binsize, filterout=filterout +;- + +; DJL switch off wave compatibility mode +res=execute('waveoff') + +; string array obstypeselect + +if (n_elements(obstypeselect) eq 0) then obstypeselect='' +if (n_elements(printobstypes) eq 0) then printobstypes='' +if (n_elements(filterout) eq 0) then filterout='' + +if (n_elements(binspday) eq 0) then binspday=4 ; plot timeseries every 6 hours +plottssel=0 ; plot selected period of timeseries +if (n_elements(plot_bad_obs) eq 0) then plot_bad_obs=0 ; don't plot bad obs + +if (n_elements(plot_only_bad_obs) eq 0) then plot_only_bad_obs=1 ; plot only bad obs if selected +if (n_elements(white_on_black) eq 0) then white_on_black=1 + +if (n_elements(duplicates) eq 0) then duplicates=0 ; plot only duplicates if selected +if (n_elements(differences) eq 0) then differences=0 ; plot only differences if selected + +if (n_elements(numtimeseries) eq 0) then numtimeseries=0 ; plot time series of O-B + +if (n_elements(txt) eq 0) then txt=0 + +if (n_elements(netcdf) eq 0) then netcdf=0 ; if 1 the output netcdf data + +print,obstypeselect + +if (n_elements(salinity) eq 0) then salinity=0 +density=0 +if (n_elements(vertgrad) eq 0) then vertgrad=0 + +if (n_elements(mld) eq 0) then mld=0 + +if (n_elements(outfile) eq 0) then outfile="dataplot" + +if (n_elements(bindata) eq 0) then bindata=0 + +if (n_elements(binsize) eq 0) then binsize=[1.0,1.0] + +if (n_elements(symscale) eq 0) then symscale=1.0 + +if (n_elements(hiresmap) eq 0) then begin + hires_map=0 +endif else begin + hires_map=hiresmap +endelse + +if (n_elements(rmdi) eq 0) then rmdi=0 + +if (n_elements(coltable) eq 0) then begin + coltable=-1 +endif + +if (n_elements(picsize) ne 2) then picsize=[800,512] ; default gif resolution + +if (n_elements(pmulti) eq 0) then pmulti=0 ; default pmulti + +sz=size(indata) +nsz=n_elements(sz) +type=sz(nsz-2) ; get type 2 integer, 4 float, 7 string +if (type eq 7) then filename=indata + +if (type ne 7) then begin + nel=n_elements(indata) + nel8=nel/8 + numobs=nel8 + + ; get input values + if (nel gt 0) then begin + indata=reform(indata,numobs,8) + xarr=indata(*,0) + yarr=indata(*,1) + dep=indata(*,2) + dayarrin=indata(*,3) + obs=indata(*,4) + bkg=indata(*,5) + obs2=rmdi + obs3=rmdi + bkg2=rmdi + qcarr=long(indata(*,6)) + qcarr2=rmdi + obnum=rmdi + obstypes=long(indata(*,7)) + filetype="generic" + + print, 'djl max/min dayarrin ',max(dayarrin), min(dayarrin) + print, 'djl max/min qcarr ',max(qcarr), min(qcarr) + + endif +endif else begin + if (n_elements(filename) eq 0) then begin + print,'ERROR: No filename supplied' + print,'call: dataplot, filenamearr' + return + endif +endelse + +;read in data +if (n_elements(filename) gt 0) then begin + read_cdfobs, filename, numobs=numobs, Latitudes=yarr, Longitudes=xarr, $ + obs=obs, modelvals=bkg, qcs=qcarr, $ + ob2=obs2, modelval2=bkg2, qc2=qcarr2, $ + ob3=obs3, $ + Dates=dayarrin, rmdi=rmdi, $ + depths=dep, nodates=0, types=obstypes, $ + filetype=filetype, iobs=iobs, jobs=jobs, MDT=MDT, error=error, profilenum=obnum, $ + notfussy=notfussy, VarName=varname + + if (error eq 1) then begin + numobs=0 + dayarrin=0 + rmdi=-99999 + xarr=rmdi + yarr=rmdi + obs=rmdi + bkg=rmdi + qcarr=1 + dayarrin=rmdi + dayarr=rmdi + dep=rmdi + filetype="" + obstypes=rmdi + obnum=0 + endif + + print,'error ',error, numobs + + if (numobs gt 0) then begin + print, 'numobs ',numobs + +;setup obnum if it is not produced by read_cdfobs + + if (n_elements(obnum) ne numobs and numobs gt 0) then begin + obnum=lindgen(n_elements(numobs)) ; generate an array of observation numbers + ; starting with zero + endif + + + +;if gt 180 then make longitudes negative + + wh=where(xarr ge 180 and xarr le 360) + if (wh(0) gt -1) then begin + xarr(wh)=xarr(wh)-360 + endif + + +;calculate vertical gradient +; +; if (filetype eq "Prof") then $ +; calcvertgrad, xarr, yarr, dayarrin, obs, bkg, qcarr, obs2,bkg2, qcarr2, dep, rmdi + +; adjust qc values for profile obs data (1 = good) + wh=where(bkg ne rmdi) + if (n_elements(bkg2) gt 0) then begin + wh2=where(bkg2 ne rmdi) + if (filetype eq "Prof" and wh(0) eq -1 and wh2(0) eq -1) then begin + qcarr=qcarr-1 + qcarr2=qcarr2-1 + endif + endif + + if (keyword_set(showmdt) eq 1) then begin + bkg=MDT + endif + + + print,'rmdi ',rmdi + + print,'file read in' + +spawn,'echo part 1 `date`' + + if (n_elements(rmdi) eq 0) then rmdi=-1.07374e+09 + + qcarr=fix(qcarr) + + endif ; numobs + + print,'endif numobs' + +; select area + + sz=size(area) + nsz=n_elements(sz) + type=sz(nsz-2) ; get type 2 integer, 4 float, 7 string + if (type eq 7) then areasel, area, xrange, yrange, success + if (type eq 4 or type eq 2) then begin + if (nsz eq 4) then begin + xrange=[area(0),area(2)] + yrange=[area(1),area(3)] + endif + endif + +; set missing obs types to missing data + if (n_elements(obs2) eq 0) then begin + obs2=rmdi + bkg2=rmdi + qcarr2=rmdi + endif + if (n_elements(obs3) eq 0) then begin + obs3=rmdi + bkg3=rmdi + qcarr3=rmdi + endif + +endif ; filename + +if (n_elements(varname) eq 0) then varname='' + + if (n_elements(dayarrin) ne numobs) then dayarrin=replicate(1,numobs) +; dep=replicate(0,numobs) + + + if (size(dayarrin,/type) eq 8) then begin + dayarr=dayarrin.julian + endif else begin + dayarr=dayarrin + dayarr=dayarr+0.5 ; dataplot prefers each day to be a different integer + endelse + +print,'xxx' + +;set contour range mn, mx +if (n_elements(mx) eq 0) then fmx=rmdi else fmx=mx +if (n_elements(mn) eq 0) then fmn=rmdi else fmn=mn +mx=fmx +mn=fmn + + + + ; Define a monochrome image array for use in the application. +; READ_PNG, FILEPATH('mineral.png', $ +; SUBDIR=['examples', 'data']), image + + ; Place the image array in a pointer heap variable, so we can + ; pass the pointer to the event routine rather than passing the + ; entire image array. +; imagePtr=PTR_NEW(image, /NO_COPY) + + ; Retrieve the size information from the image array. +; im_size=SIZE(*imagePtr) + +;--------------- +;Setup defaults +;--------------- + + busy=0 + wh=where(dep ge 0) + depminl=0. + depmaxl=1. + if( wh(0) gt -1) then depminl=min(dep(wh),max=depmaxl) + depscl=fix((depmaxl-depminl)/100.) + if (depscl lt 1) then depscl=1 + depmin=depminl +; depmax=depmin+depscl + depmax=depmaxl + pmultinum=0 + +if (n_elements(depths) eq 2) then begin + + depmin=max([depminl,depths(0)]) + depmax=min([depmaxl,depths(1)]) +endif + + print,'n_elements(typeplot) ',n_elements(typeplot) + + if (n_elements(typeplot) eq 0) then typeplot=1 +; if (n_elements(where(bkg ne bkg(0))) gt 1) then begin +; typeplot=3 +; endif else begin +; typeplot=4 +; endelse +; endif + if (typeplot gt 4) then typeplot=4 + if (typeplot lt 1) then typeplot=1 + + if (n_elements(ombtypeplot) eq 0) then begin + if (n_elements(where(bkg ne bkg(0))) gt 1) then begin + ombtypeplot=1 + endif else begin + ombtypeplot=2 + endelse + endif + if (ombtypeplot gt 3) then ombtypeplot=3 + if (ombtypeplot lt 1) then ombtypeplot=1 + + print,'typeplot ',typeplot, ' ombtypeplot ',ombtypeplot + + if (n_elements(typeproj) eq 0) then typeproj=1 + + xrangedef=[-110.,40.] + yrangedef=[-50.,80.] + wh=where(xarr lt xrangedef(0) or xarr gt xrangedef(1) or $ + yarr lt yrangedef(0) or yarr gt yrangedef(1),count) + if (count gt 0) then begin + xrangedef=[-180.,180.] + yrangedef=[-90.,90.] + endif + + if (n_elements(xrange) eq 0) then begin + xrange=xrangedef + yrange=yrangedef + endif + symsize=1.0 + +; map_file="" + +; plot_bad_obs=0 + + dayshi=-10.d/86400. ; small shift to group 0:00 hours with the previous day +; dayshi=-0.1d + + wh=where(dayarr gt 0 and dayarr lt 9000000) +; print,dayarr +; print,wh(0) + if (wh(0) gt -1) then begin + daymin=min(dayarr(wh)+dayshi,max=daymax) + endif else begin + daymax=0 + daymin=0 + endelse +; daymax=maxday +; daymin=minday + dayminl=daymin + daymaxl=daymax + + + print,'** dayminl daymaxl ', dayminl, daymaxl + +; ** Health check file + if (keyword_set(healthcheck)) then begin + OPENW, unit, outfile+'_health.txt', /get_lun + printf,unit,' Health check data ' + printf,unit,'-------------------' + printf,unit,' Number of files ',n_elements(filename) + printf,unit,' List of files ' + printf,unit,filename + printf,unit,' Filetype ',filetype + printf,unit,' Number of observations ',numobs + printf,unit,' Date range in julian days ',dayminl, daymaxl,format='(a,2f20.8)' + jul_to_dtstr,dayminl,datestr1 + jul_to_dtstr,daymaxl,datestr2 + printf,unit,' Date range ',datestr1,' - ',datestr2 + mxo=0 & mno=0 + mxb=0 & mnb=0 + mxob=0 & mnob=0 + rmsomb=0 & meanomb=0 +; info,obs +; print,obs +; info,bkg +; print,bkg +; print,'rmdi: ',rmdi +; wh=where(obs ne rmdi and qcarr lt 1,counto) +; check for missing data within a tolerance + wh=where(abs((obs-rmdi)/rmdi) gt 0.01 and qcarr lt 1, counto) +; print,'min ',min(abs((bkg(wh)-rmdi)/rmdi)) +; print,'min ',min(bkg(wh)), min(obs(wh)) +; print,'min ',max(bkg(wh)), max(obs(wh)) + if (counto gt 0) then mxo=max(obs(wh),min=mno) +; wh=where(bkg ne rmdi and qcarr lt 1,countb) + wh=where(abs((bkg-rmdi)/rmdi) gt 0.01 and qcarr lt 1, countb) + if (countb gt 0) then mxb=max(bkg(wh),min=mnb) +; wh=where(obs ne rmdi and bkg ne rmdi and qcarr lt 1,countob) + wh=where(abs((obs-rmdi)/rmdi) gt 0.01 and $ + abs((bkg-rmdi)/rmdi) gt 0.01 and qcarr lt 1, countob) + if (countob gt 0) then mxob=max(obs(wh)-bkg(wh),min=mnob) +; calculate rms / mean + if (countob gt 0) then begin + x=total(obs(wh)-bkg(wh)) + x2=total((obs(wh)-bkg(wh))^2) + nel=n_elements(wh) + meanomb=x/nel + rmsomb=sqrt(x2/nel) + endif + + printf,unit,' Max/min obs ',mxo,mno + printf,unit,' Max/min bkg ',mxb,mnb + printf,unit,' Max/min obs-bkg ',mxob,mnob + printf,unit,' RMS/mean obs-bkg ',rmsomb,meanomb + printf,unit,' Number of good observations ',counto + printf,unit,' Number of bad observations ', numobs-counto + + mxo=0 & mno=0 + mxb=0 & mnb=0 + mxob=0 & mnob=0 + rmsomb=0 & meanomb=0 + wh=where(obs2 ne rmdi and qcarr2 lt 1,counto) + if (counto gt 0) then mxo=max(obs2(wh),min=mno) + wh=where(bkg2 ne rmdi and qcarr2 lt 1,countb) + if (countb gt 0) then mxb=max(bkg2(wh),min=mnb) + wh=where(obs2 ne rmdi and bkg2 ne rmdi and qcarr2 lt 1,countob) + if (countob gt 0) then mxob=max(obs2(wh)-bkg2(wh),min=mnob) +; calculate rms / mean + if (countob gt 0) then begin + x=total(obs2(wh)-bkg2(wh)) + x2=total((obs2(wh)-bkg2(wh))^2) + nel=n_elements(wh) + meanomb=x/nel + rmsomb=sqrt(x2/nel) + endif + + printf,unit,' Max/min obs2 ',mxo,mno + printf,unit,' Max/min bkg2 ',mxb,mnb + printf,unit,' Max/min obs2-bkg2 ',mxob,mnob + printf,unit,' RMS/mean obs2-bkg2 ',rmsomb,meanomb + printf,unit,' Number of good observations2 ',counto + printf,unit,' Number of bad observations2 ', numobs-counto + + FREE_LUN,unit + endif + + daymax=daymaxl ; default to show everything + if (keyword_set(alldays)) then daymax=daymaxl ;print alldays + if (n_elements(daterange) eq 2) then begin + daymin=daterange(0) + if (daterange(0) lt dayminl) then daymin=dayminl + if (daterange(0) gt daymaxl) then daymin=daymaxl + if (daterange(1) gt dayminl and daterange(1) le daymaxl) then begin + daymax=daterange(1) + endif else begin + daymax=daymaxl + endelse + endif + if (n_elements(daterange) eq 1) then begin ; select number of days before end or after beginning + print,'daymin b4: ',daymin, daymax + daymax=daymaxl + daymin=dayminl + if (daterange(0) lt 0) then begin + if (daterange(0) eq -9999) then begin + daymin=daymax + endif else begin + daymin=daymax+daterange(0) + endelse + endif + if (daterange(0) gt 0) then daymax=daymin+daterange(0) + endif + +; select day from the start day + if (n_elements(dayrange) eq 1) then begin + daymin=dayminl+dayrange + daymax=daymin + endif + + if (n_elements(dayrange) eq 2) then begin + daymin=dayminl+dayrange(0) + daymax=dayminl+dayrange(1) + endif + + +; prevent error where only one day plotted + daymaxsl=daymaxl + dayminsl=dayminl + if (daymaxsl le dayminsl+1) then daymaxsl=dayminsl+1 +; stop day going out of range + if (daymax gt daymaxl) then daymax=daymaxl + if (daymax lt dayminl) then daymax=dayminl + if (daymin lt dayminl) then daymin=dayminl + if (daymin gt daymaxl) then daymin=daymaxl + + print,'daymin af: ',daymin, daymax + + sym=1 + +;------------- +;Setup window +;------------- + +if (not keyword_set(batch)) then begin + ; Create a base widget to hold the application. +; base0=WIDGET_BASE() + + base = WIDGET_BASE(/COLUMN,mbar=bar) +; base = WIDGET_BASE(/row) + + + ; setup menu bar + + menu1 = WIDGET_BUTTON(bar, VALUE='Areas', /MENU) +button1 = WIDGET_BUTTON(menu1, VALUE='Global', uvalue='Global') +button2 = WIDGET_BUTTON(menu1, VALUE='Arctic', uvalue='Arctic') +button2a = WIDGET_BUTTON(menu1, VALUE='Atlantic', uvalue='Atlantic') +button3 = WIDGET_BUTTON(menu1, VALUE='N Atl', uvalue='N Atl') +button4 = WIDGET_BUTTON(menu1, VALUE='Trop Atl', uvalue='Trop Atl') +button5 = WIDGET_BUTTON(menu1, VALUE='S Atl', uvalue='S Atl') +button5a = WIDGET_BUTTON(menu1, VALUE='Pacific', uvalue='Pacific') +button6 = WIDGET_BUTTON(menu1, VALUE='N Pac', uvalue='N Pac') +button7 = WIDGET_BUTTON(menu1, VALUE='Trop Pac', uvalue='Trop Pac') +button8 = WIDGET_BUTTON(menu1, VALUE='S Pac', uvalue='S Pac') +button9 = WIDGET_BUTTON(menu1, VALUE='Indian', uvalue='Indian') +button10 = WIDGET_BUTTON(menu1, VALUE='S Ocean', uvalue='S Ocean') +button11 = WIDGET_BUTTON(menu1, VALUE='Med', uvalue='Med') +button12 = WIDGET_BUTTON(menu1, VALUE='N West Shelf', uvalue='NWS') +button13 = WIDGET_BUTTON(menu1, VALUE='Input Area', uvalue='Input Area') + + menu2 = WIDGET_BUTTON(bar, VALUE='Plot', /MENU) +button1 = WIDGET_BUTTON(menu2, VALUE='Timeseries', uvalue='Timeseries') +button1a = WIDGET_BUTTON(menu2, VALUE='Num timeseries', uvalue='Num timeseries') +button2 = WIDGET_BUTTON(menu2, VALUE='T-S diagram', uvalue='TS diagram') + + menu1a = WIDGET_BUTTON(bar, VALUE='Find',/MENU) +button1a= WIDGET_BUTTON(menu1a, VALUE='Worst points', uvalue='Worst points') +button1a1 = WIDGET_BUTTON(menu1a, VALUE='Filter type', uvalue='Filter type') + + menu3 = WIDGET_BUTTON(bar, VALUE='Config', /MENU) +loresmap = WIDGET_BUTTON(menu3, VALUE='Low res map', uvalue='Low res map', /checked_menu) +hiresmap = WIDGET_BUTTON(menu3, VALUE='Hi res map', uvalue='Hi res map', /checked_menu) + +button3 = WIDGET_BUTTON(menu3, VALUE='Square psym', uvalue='Square psym') +button4 = WIDGET_BUTTON(menu3, VALUE='Round psym', uvalue='Round psym') + +pltonbado = WIDGET_BUTTON(menu3, VALUE='Plot only bad obs', uvalue='Plot only bad obs', /checked_menu) + +whtonblack = WIDGET_BUTTON(menu3, VALUE='White on black', uvalue='White on black', /checked_menu) + +incsym = WIDGET_BUTTON(menu3, VALUE='Psym size+ ', uvalue='incsym') +decsym = WIDGET_BUTTON(menu3, VALUE='Psym size- ', uvalue='decsym') +resetsym = WIDGET_BUTTON(menu3, VALUE='Psym size reset ', uvalue='resetsym') + +vertgradmenu = WIDGET_BUTTON(menu3, VALUE='Vert gradient', uvalue='vertgrad', /checked_menu) +button12 = WIDGET_BUTTON(menu3, VALUE='Input max/min', uvalue='input max/min') + + + menu4 = WIDGET_BUTTON(bar, VALUE='Help', /MENU) +help1 = WIDGET_BUTTON(menu4, VALUE='Info', uvalue='Info') + +if (n_elements(filename) gt 0) then begin + menu5 = WIDGET_BUTTON(bar, VALUE=filename[0]) +nel=n_elements(filename) +nel2=nel +nelmx=32 +if (nel2 gt nelmx) then nel2=nelmx +for i=0L, nel2-1 do begin + id = WIDGET_BUTTON(menu5, VALUE=filename[i]) +endfor +if (nel gt nelmx) then id=WIDGET_BUTTON(menu5, VALUE='... etc ...') +endif + +Widget_Control, loresmap, Set_Button=1 +Widget_Control, vertgradmenu, Set_Button=vertgrad + +Widget_Control, pltonbado, Set_Button=plot_only_bad_obs +Widget_Control, whtonblack, Set_Button=white_on_black + + ; Create a draw widget based on the size of the image, and + ; set the MOTION_EVENTS keyword so that events are generated + ; as the cursor moves across the image. Setting the BUTTON_EVENTS + ; keyword rather than MOTION_EVENTS would require the user to + ; click on the image before an event is generated. + +; im_size=[2,1024,800] +; im_size=[2,800,800] +; im_size=[2,800,720] +; im_size=[2,1024,720] + im_size=[2,1024,680] +; im_size=[2,800,640] + + draw = WIDGET_DRAW(base, XSIZE=im_size[1], YSIZE=im_size[2], $ + /BUTTON_EVENTS,/WHEEL_EVENTS, uvalue='MAPWINDOW') + +; base2=widget_base(GROUP_LEADER=base,/column) + +; droplist = WIDGET_COMBOBOX(base2,value=string([indgen(101)]),$ +; uvalue='LEVELLIST', FRAME=2) + +; button = WIDGET_BUTTON(base2, value='test',uvalue='test') + + +; print,'depminl/maxl ',depminl, depmaxl +; print,'value depmin ',depmin +; print,'value depmax ',depmax + +depmaxlsl=depmaxl +depminlsl=depminl +if (depmaxlsl eq depminlsl) then depmaxlsl=depmaxlsl+1 +print, 'depminlsl, depmaxlsl ',depminlsl, depmaxlsl + slider = WIDGET_SLIDER(base,maximum=depmaxlsl,minimum=depminlsl,scroll=depscl,$ + value=depmin,uvalue='LEVELCHOICE', ysize=32) + + sliderb = WIDGET_SLIDER(base,maximum=depmaxlsl,minimum=depminlsl, scroll=depscl,$ + value=depmax,uvalue='LEVELCHOICEB', ysize=32) + + + jul_to_dtstr,daymin,dayminstr,/notime + slider1label = WIDGET_LABEL(base, VALUE="min date: "+dayminstr, xsize=800,ysize=14) + slider1 = WIDGET_SLIDER(base,minimum=dayminsl,maximum=daymaxsl,scroll=1,$ + value=daymin,uvalue='DATERANGE1',/suppress_value,/drag) + + jul_to_dtstr,daymax,daymaxstr,/notime + slider2label = WIDGET_LABEL(base, VALUE="max date: "+daymaxstr, xsize=800,ysize=14) + slider2 = WIDGET_SLIDER(base,minimum=dayminsl,maximum=daymaxsl,scroll=1,$ + value=daymax,uvalue='DATERANGE2',/suppress_value,/drag) + + + +; slider1 = WIDGET_SLIDER(base,minimum=dayminl,maximum=daymaxl,scroll=1,$ +; value=daymin,uvalue='DATERANGE1',PRO_SET_VALUE="datesliderset",/drag) +; +; slider2 = WIDGET_SLIDER(base,minimum=dayminl,maximum=daymaxl,scroll=1,$ +; value=daymax,uvalue='DATERANGE2',PRO_SET_VALUE="datesliderset",/drag) + + ; Labels for stats + + labt1='Lon: ' + labt2='Lat: ' + labt3='Value: ' + labt4='QC: ' + labt5='Date: ' + labt6='Value: ' + labt7=' ' + labt8='Type: ' + labt9='obnum: ' + labt10='visible date range: ' + + ; Create label widgets to hold the cursor position and + ; Hexadecimal value of the pixel under the cursor. + labelb=Widget_Base(base,row=1) + + labsiz=105 + labsizl1=150 + labsizlg=150 + labsizl2=135 + label7=0 + lb_ysize=14 + label1 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ + VALUE=labt1, ysize=lb_ysize) + label2 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ + VALUE=labt2, ysize=lb_ysize) + label3 = WIDGET_LABEL(labelb, XSIZE=labsizl1, $ + VALUE=labt3, ysize=lb_ysize) + label4 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ + VALUE=labt4, ysize=lb_ysize) + label5 = WIDGET_LABEL(labelb, XSIZE=labsizlg, $ + VALUE=labt5, ysize=lb_ysize) + label6 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ + VALUE=labt6, ysize=lb_ysize) +; label7 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ +; VALUE=labt7, ysize=lb_ysize) + label8 = WIDGET_LABEL(labelb, XSIZE=labsizl2, $ + VALUE=labt8, ysize=lb_ysize) + label9 = WIDGET_LABEL(labelb, XSIZE=labsiz, $ + VALUE=labt9, ysize=lb_ysize) + + labelb2 = Widget_Base(base,row=1) + label10 = WIDGET_LABEL(labelb2, XSIZE=1024, $ + VALUE=labt10, ysize=lb_ysize) + + tlba = Widget_Base(base,row=1) + + t1b = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=200,$ + /Exclusive) + button1 = Widget_Button(t1b, Value='mean',uvalue='RADIO1',/no_release) + button2 = Widget_Button(t1b, Value='rms',uvalue='RADIO2',/no_release) + button3 = Widget_Button(t1b, Value='sd',uvalue='RADIO3',/no_release) + button4 = Widget_Button(t1b, Value='ms',uvalue='RADIO4',/no_release) + + if (typeplot eq 1) then Widget_Control, button1, Set_Button=typeplot + if (typeplot eq 2) then Widget_Control, button2, Set_Button=typeplot + if (typeplot eq 3) then Widget_Control, button3, Set_Button=typeplot + if (typeplot eq 4) then Widget_Control, button4, Set_Button=typeplot + + t1c = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=200,$ + /Exclusive) + button5 = Widget_Button(t1c, Value='obs - bkg', uvalue='RADIO5',/no_release) + button6 = Widget_Button(t1c, Value='obs', uvalue='RADIO6',/no_release) + button7 = Widget_Button(t1c, Value='bkg', uvalue='RADIO7',/no_release) + + if (ombtypeplot eq 1) then Widget_Control, button5, /Set_Button + if (ombtypeplot eq 2) then Widget_Control, button6, /Set_Button + if (ombtypeplot eq 3) then Widget_Control, button7, /Set_Button + +; tlb = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=400,$ +; /Exclusive) +;; no_release only sends select events (not release ones) +; button1 = Widget_Button(tlb, Value='rms Obs - Bkg',uvalue='RADIO1',/no_release) +; button2 = Widget_Button(tlb, Value='sum(Obs - Bkg)^2',uvalue='RADIO2',/no_release) +; button3= Widget_Button(tlb, Value='Obs - Bkg',uvalue='RADIO3',/no_release) +; button4 = Widget_Button(tlb, Value='Obs',uvalue='RADIO4',/no_release) +; button5 = Widget_Button(tlb, Value='Bkg',uvalue='RADIO5',/no_release) +; +; if (typeplot eq 1) then Widget_Control, button1, Set_Button=typeplot +; if (typeplot eq 2) then Widget_Control, button2, Set_Button=typeplot +; if (typeplot eq 3) then Widget_Control, button3, Set_Button=typeplot +; if (typeplot eq 4) then Widget_Control, button4, Set_Button=typeplot +; if (typeplot eq 5) then Widget_Control, button5, Set_Button=typeplot + + tlb1 = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=220,$ + /Exclusive) + button01 = Widget_Button(tlb1, Value='Lat/Lon',uvalue='RADIO01',/no_release) + button02 = Widget_Button(tlb1, Value='N Polar',uvalue='RADIO02',/no_release) + button03 = Widget_Button(tlb1, Value='S Polar',uvalue='RADIO03',/no_release) + + Widget_Control, button01, Set_Button=typeproj + + + tlb1a = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=250,$ + /NonExclusive) + button001 = Widget_Button(tlb1a, Value='Plot Bad Obs', uvalue='RADIO001') + + Widget_Control, button001, Set_Button=plot_bad_obs + + + if filetype eq 'CRT' then begin + + button002 = Widget_Button(tlb1a, Value='Meridional', uvalue='RADIOSAL') + Widget_Control, button002, Set_Button=salinity + + button003 = Widget_Button(tlb1a, Value='Speed', uvalue='RADIODENSITY') + Widget_Control, button003, Set_Button=density + + endif else begin +; tlb1b = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=90,$ +; /NonExclusive) + button002 = Widget_Button(tlb1a, Value='Salinity', uvalue='RADIOSAL') + Widget_Control, button002, Set_Button=salinity +; tlb1c = Widget_Base(tlba,Title='Push-Buttons', row=1, Scr_XSize=90,$ +; /NonExclusive) + button003 = Widget_Button(tlb1a, Value='Density', uvalue='RADIODENSITY') + Widget_Control, button003, Set_Button=density + endelse + + + tlb2= Widget_Base(tlba,row=1) + button = WIDGET_BUTTON(tlb2, VALUE='Print',uvalue="PRINT") + button = WIDGET_BUTTON(tlb2, VALUE='Save',uvalue="SAVE") + + button = WIDGET_BUTTON(tlb2, VALUE='Done',uvalue="DONE") + + + + ; Realize the widget hierarchy. + WIDGET_CONTROL, base, /REALIZE +; WIDGET_CONTROL, base2, /REALIZE +; WIDGET_CONTROL, tlb, /REALIZE + + ; Retrieve the widget ID of the draw widget. Note that the widget + ; hierarchy must be realized before you can retrieve this value. + WIDGET_CONTROL, draw, GET_VALUE=drawID + + + ; Create an anonymous array to hold the image data and widget IDs + ; of the label widgets. +; stash = { imagePtr:imagePtr, label1:label1, label2:label2, $ +; label3:label3, $ +; xarr:xarr, yarr:yarr, dep:dep, val:val } + + +spawn,'echo part 2 `date`' + + + stash = { label1:label1, label2:label2, $ + label3:label3, label4:label4, $ + label5:label5, label6:label6, $ + label7:label7, label8:label8, $ + label9:label9, label10:label10, $ + labt1:labt1, labt2:labt2, $ + labt3:labt3, labt4:labt4, $ + labt5:labt5, labt6:labt6, $ + labt7:labt7, labt8:labt8, $ + labt9:labt9, labt10:labt10, $ + slider1label:slider1label, $ + slider2label:slider2label, $ + drawID:drawID, draw:draw, base:base, $ + im_size:im_size, pixID:0, $ + xcorn:0, ycorn:0, xdatacorn:0.0, ydatacorn:0.0, $ + slider1:slider1, slider2:slider2, $ + slider:slider, sliderb:sliderb, $ + hiresmap:hiresmap, loresmap:loresmap, vertgradmenu:vertgradmenu, $ + pltonbado:pltonbado, plot_only_bad_obs:plot_only_bad_obs, $ + whtonblack:whtonblack, white_on_black:white_on_black, $ + duplicates:duplicates, differences:differences, $ + bindata:bindata, binsize:binsize, $ + filetype:filetype, $ + xarr:xarr, yarr:yarr, dep:dep, dayarr:dayarr, $ + obs:obs, bkg:bkg, qcarr:qcarr, obstypes: obstypes, $ + obs2:obs2, obs3:obs3, bkg2:bkg2, qcarr2:qcarr2, $ + obnum:obnum, $ + depmin:depmin, typeplot:typeplot, ombtypeplot:ombtypeplot, $ + typeproj:typeproj, $ + hires_map:hires_map, $ + plot_bad_obs:plot_bad_obs, salinity: salinity, $ + density:density, vertgrad:vertgrad, mld:mld, $ + daymin:daymin, daymax:daymax, dayminl:dayminl, daymaxl:daymaxl, $ + dayshi:dayshi, $ + depminl:depminl, depmaxl:depmaxl, depmax:depmax, depscl:depscl, $ + xrange:xrange, yrange:yrange, $ + fmx:fmx, fmn:fmn, mx:mx, mn:mn, $ + symsize:symsize, sym:sym, picsize:picsize, $ + pmulti:pmulti, pmultinum:pmultinum, $ + outfile:outfile, $ + xrangedef:xrangedef, yrangedef:yrangedef, rmdi:rmdi, $ + obstypeselect:obstypeselect, printobstypes:printobstypes, $ + plottssel:plottssel, $ + binspday:binspday, numtimeseries:numtimeseries, txt:txt, netcdf:netcdf, $ + busy:busy, symscale:symscale, coltable:coltable, $ + filterout:filterout, varname:varname } + + ; Set the user value of the top-level base widget equal to the + ; 'stash' array. + WIDGET_CONTROL, base, SET_UVALUE=stash + + ; Make the draw widget the current IDL drawable area. + WSET, drawID + +spawn,'echo part 3 `date`' + + ; Draw the image into the draw widget. + plotpoints, stash + +; plotpoints updates mx/mn values make sure these are included + WIDGET_CONTROL, base, SET_UVALUE=stash + +spawn,'echo part 4 `date`' + + ; Call XMANAGER to manage the widgets. + XMANAGER, 'dataplot', base, /NO_BLOCK +; XMANAGER, 'dataplot', base +endif else begin + +;do batch + +print,"batch" + +drawID=-1 + +print, 'filetype: ',filetype + + stash = { drawID:drawID,$ + filetype:filetype, $ + xarr:xarr, yarr:yarr, dep:dep, dayarr:dayarr, $ + obs:obs, bkg:bkg, qcarr:qcarr, obstypes: obstypes, $ + obs2:obs2, bkg2:bkg2, qcarr2:qcarr2, $ + obnum:obnum, $ + depmin:depmin, typeplot:typeplot, ombtypeplot:ombtypeplot, $ + typeproj:typeproj, $ + hires_map:hires_map, $ + plot_only_bad_obs:plot_only_bad_obs, $ + white_on_black:white_on_black, $ + duplicates:duplicates, differences:differences, $ + bindata: bindata, binsize:binsize, $ + plot_bad_obs:plot_bad_obs, salinity: salinity, $ + density:density, vertgrad:vertgrad, mld:mld, $ + daymin:daymin, daymax:daymax, dayminl:dayminl, daymaxl:daymaxl, $ + dayshi:dayshi, $ + depminl:depminl, depmaxl:depmaxl, depmax:depmax, depscl:depscl, $ + xrange:xrange, yrange:yrange, $ + fmx:fmx, fmn:fmn, mx:mx, mn:mn, $ + symsize:symsize, sym:sym, picsize:picsize, $ + pmulti:pmulti, pmultinum:pmultinum, $ + outfile:outfile, $ + xrangedef:xrangedef, yrangedef:yrangedef, rmdi:rmdi, $ + obstypeselect:obstypeselect, printobstypes:printobstypes, $ + plottssel:plottssel, $ + binspday:binspday, numtimeseries:numtimeseries, txt:txt, netcdf:netcdf, $ + busy:busy, symscale:symscale, coltable:coltable, $ + filterout:filterout, varname:varname } + +if (keyword_set(ps)) then begin + ps=1 + eps=0 + landscape=1 + pr2,file=stash.outfile+'.ps',landscape=landscape,ps=ps,eps=eps,color=1 + +; plot data + if keyword_set(timeseries) then begin ; plot timeseries if keyword is set + plottimeseries,stash + endif else begin ; otherwise plot points on a map + plotpoints,stash + endelse + + prend2,view=0 + +endif + +if (keyword_set(gif)) then begin + thisDevice = !D.Name + + Set_Plot, 'Z' ; do graphics in the background +; Device, Set_Resolution=[640,512], decomposed=0 +; Device, Set_Resolution=[800,512], decomposed=0 + Device, Set_Resolution=picsize, decomposed=0 + Erase ; clear any existing stuff + !p.charsize=0.75 + setupct, r, g, b, coltable=stash.coltable, $ + white_on_black=stash.white_on_black ; setup color table + +; plot data + if keyword_set(timeseries) then begin ; plot timeseries if keyword is set + plottimeseries,stash + endif else begin ; otherwise plot points on a map + plotpoints,stash + endelse + +; if (keyword_set(gif)) then begin +; IMAGE_GRAB, /gif, filename=stash.outfile+'.gif',/overwrite + snapshot = TVRD() + WRITE_GIF,stash.outfile+'.gif',snapshot, r, g, b +; endif + Device, Z_Buffer=1 ; reset graphics mode + Set_Plot, thisDevice + !p.charsize=0.0 + +endif + +if (keyword_set(txt)) then begin + if keyword_set(timeseries) then begin ; plot timeseries if keyword is set + plottimeseries,stash + endif else begin ; otherwise plot points on a map + plotpoints,stash +; print,'no txt version of plotpoints!' + endelse +endif + +if (keyword_set(netcdf)) then begin + if keyword_set(timeseries) then begin + print,'no netcdf version of timeseries!' + endif else begin + plotpoints,stash + endelse +endif + +if (stash.filterout ne '') then begin + + selpoints, stash, lonsel, latsel, innovsel, qcsel, daysel, obstypsel, obnumsel, numsel, typestr + +endif + +endelse ; batch + +END + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot_txttimeseries.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot_txttimeseries.pro new file mode 100644 index 0000000000000000000000000000000000000000..5c79593b41c6b094579a5b85b6fb1dcc07aa1c64 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/dataplot_txttimeseries.pro @@ -0,0 +1,452 @@ +pro plotts1, arrsv, title, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax, $ + emax=emax, emin=emin +;+-------------------------------------------------------- +; plot mean and rms timeseries +; +; Author: D. J. Lea Feb 2008 +;+-------------------------------------------------------- + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%D %M, %Y']) + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%D', '%M, %Y']) +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%M %Y']) + +date_label = LABEL_DATE(DATE_FORMAT=['%D-%M','%Y']) + + +; sort times (in case of a repeated day) + +timsrt=sort(arrsv(0,*)) + +taxis=arrsv(0,timsrt) +num=arrsv(1,timsrt) +yaxis=arrsv(2,timsrt) +yaxis2=arrsv(3,timsrt) + +; remove any zero times or non-finite values +wh=where(taxis gt 0 and finite(yaxis) and finite(yaxis2)) +if (wh(0) gt -1) then begin +taxis=taxis(wh) +num=num(wh) +yaxis=yaxis(wh) +yaxis2=yaxis2(wh) +endif + +; remove any with num lt than a specific value +if (n_elements(minperc) eq 1) then begin +maxnum=max(num,min=minnum) +wh=where(num gt maxnum*minperc) +if (wh(0) gt -1) then begin +taxis=taxis(wh) +num=num(wh) +yaxis=yaxis(wh) +yaxis2=yaxis2(wh) +endif +endif + +mxt=max(taxis,min=mnt) +print, 'mnt mxt ',mnt, mxt + +ymx=max([yaxis,yaxis2],min=ymn) + +print, 'ymn ymx ',ymn,ymx + +;create a small amount of space around the max and min + +spc=(ymx-ymn)*0.05 + +ymn=ymn-spc*3 +ymx=ymx+spc + +if (n_elements(emax) gt 0) then ymx=emax +if (n_elements(emin) gt 0) then ymn=emin + +; setup time axis range + +skip=0 +xmx=max(taxis,min=xmn) +if (n_elements(juldatemin) gt 0) then begin + if (xmn le juldatemin) then xmn=juldatemin + if (xmx le juldatemin) then skip=1 +endif +if (n_elements(juldatemax) gt 0) then begin + if (xmx ge juldatemax) then xmx=juldatemax + if (xmn ge juldatemin) then skip=1 +endif + +if (skip eq 0) then begin +;plot, arrsv(0,timsrt), arrsv(2,timsrt), xstyle=1, linestyle=1, $ +; yrange=[ymn,ymx], $ +; ytitle=typestr, title=title, $ +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + +;plot, arrsv(0,timsrt), arrsv(3,timsrt), xstyle=1, /noerase, $ +; yrange=[ymn,ymx], $ +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + +;plot, arrsv(0,timsrt), arrsv(2,timsrt), xstyle=1, linestyle=1, $ +; yrange=[ymn,ymx], $ +; ytitle=typestr, title=title, $ +; XTICKFORMAT = ['LABEL_DATE','LABEL_DATE'],$ +; XTICKUNITS = ['Day','Month'] + +;plot, arrsv(0,timsrt), arrsv(3,timsrt), xstyle=1, /noerase, $ +; yrange=[ymn,ymx], $ +; XTICKFORMAT = ['LABEL_DATE','LABEL_DATE'],$ +; XTICKUNITS = ['Day','Month'] + +;plot, taxis, yaxis, xstyle=1, linestyle=1, $ +; yrange=[ymn,ymx], $ +; ytitle=typestr, title=title, $ +; XTICKFORMAT = ['LABEL_DATE'] +; +;plot, taxis, yaxis2, xstyle=1, /noerase, $ +; yrange=[ymn,ymx], $ +; XTICKFORMAT = ['LABEL_DATE'] + +plot, taxis, yaxis, xstyle=1, ystyle=1, linestyle=1, $ + yrange=[ymn,ymx], xrange=[xmn,xmx], $ + ytitle=typestr, title=title, $ + XTICKUNITS=['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] + +plot, taxis, yaxis2, xstyle=4+1, ystyle=4+1, /noerase, $ + yrange=[ymn,ymx], xrange=[xmn,xmx], $ + XTICKUNITS=['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] + + + +; key + xcoord=0.8 + ycoord=0.9 + ycoord=0.35 + ycoord=0.2 + + ycoord2=ycoord-0.05 + xcoord2=xcoord+0.03 + xcoord3=xcoord+0.05 + plots, [xcoord,xcoord2],[ycoord,ycoord], linestyle=0, /normal + xyouts, xcoord3, ycoord, 'RMS', /normal + plots, [xcoord,xcoord2],[ycoord2,ycoord2], linestyle=1, /normal + xyouts, xcoord3, ycoord2, 'mean',/normal + +endif + +end + + +; plot number + +pro plotts2, arrsv, title, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax + + +; number +; + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%D %M, %Y']) + +;date_label = LABEL_DATE(DATE_FORMAT = $ +; ['%M %Y']) + +date_label = LABEL_DATE(DATE_FORMAT=['%D-%M','%Y']) + + + +timsrt=sort(arrsv(0,*)) + +taxis=arrsv(0,timsrt) +yaxis=arrsv(1,timsrt) + +wh=where(taxis gt 0 and finite(yaxis)) ; remove any zero times and non-finite vals +if (wh(0) gt -1) then begin +taxis=taxis(wh) +yaxis=yaxis(wh) +endif +mxt=max(taxis,min=mnt) +print, 'mnt mxt ',mnt, mxt + +;plot, arrsv(0,timsrt), arrsv(1,timsrt), xstyle=1, $ +; ytitle='Number of obs assim', title=title, $ +; XTICKFORMAT = ['LABEL_DATE'], $ +; XTICKUNITS = ['Day'], $ +; XTICKINTERVAL = 4 + +;info, taxis +;info, yaxis + +;print,taxis, yaxis + +;plot, taxis, yaxis, xstyle=1, $ +; ytitle='Number of obs assim', title=title, $ +; XTICKFORMAT = ['LABEL_DATE'] + +ymx=max(yaxis)*1.05 + +; setup time axis range + +skip=0 +xmx=max(taxis,min=xmn) +if (n_elements(juldatemin) gt 0) then begin + if (xmn le juldatemin) then xmn=juldatemin + if (xmx le juldatemin) then skip=1 +endif +if (n_elements(juldatemax) gt 0) then begin + if (xmx ge juldatemax) then xmx=juldatemax + if (xmn ge juldatemin) then skip=1 +endif + +if (skip eq 0) then $ +plot, taxis, yaxis, xstyle=1, ystyle=1, $ + ytitle='Number of obs assim', title=title, yrange=[0,ymx], xrange=[xmn,xmx],$ + XTICKUNITS = ['Time', 'Time'], XTICKFORMAT = ['LABEL_DATE'],YMARGIN=[6,4] + + +print,'min time ',min(arrsv(0,timsrt)),max(arrsv(0,timsrt)) + +end + +PRO dataplot_txttimeseries, files, gif=gif, ps=ps, filtstr=filtstr, view=view, $ + bin=bin, minperc=minperc, datemin=datemin, datemax=datemax, notitle=notitle, $ + emax=emax, emin=emin + +; DJL switch off wave compatibility mode +res=execute("waveoff") + +if (n_elements(filtstr) eq 0) then filtstr="" +if (n_elements(view) eq 0) then view=0 + +print, 'dataplot_txttimeseries ' + +if (n_elements(datemin) gt 0) then begin + ; month, day, year + juldatemin=julday(datemin(1),datemin(2), datemin(0)) + print, 'juldatemin set:', juldatemin, datemin +endif +if (n_elements(datemax) gt 0) then begin + ; month, day, year + juldatemax=julday(datemax(1),datemax(2), datemax(0)) + print, 'juldatemax set:', juldatemax, datemax +endif + + + +numfiles=n_elements(files) + +print,'numfiles ',numfiles + +imax=500 + arrs=dblarr(4,imax) + arr=dblarr(4) + arrsv=dblarr(4,10000) + +j=0L ; position in full array +for ii=0,numfiles-1 do begin + print,files(ii) + OPENR, unit, files(ii), /get_lun + obstypestr="" + readf,unit,obstypestr + typestr="" + readf,unit,typestr + xrange=fltarr(2) + readf,unit,xrange + yrange=fltarr(2) + readf,unit,yrange + binspday=0.0 + readf,unit,binspday + + i=0 + while (~ eof(unit) and i lt imax) do begin + readf,unit,arr + print,i,arr + if arr(1) eq 0 then arr(2:*)=0 + print,arr + arrs(*,i)=arr + i=i+1 + endwhile + + numtimes=i + print, 'numtimes ',numtimes + + if (numtimes ge binspday) then begin + print,arrs(*,numtimes-binspday:numtimes-1) + +; store daily values from each file in full time series array + + arrsv(*,j:j+binspday-1)=arrs(*,numtimes-binspday:numtimes-1) + j=j+binspday + + endif else begin + if (numtimes gt 0) then begin + + print, '** numtimes ',numtimes + print, arrs(*,0:numtimes-1) + arrsv(*,j:j+numtimes-1)=arrs(*,0:numtimes-1) + j=j+numtimes + + endif + endelse + + FREE_LUN, unit + + print, obstypestr + print, typestr + print, xrange + print, yrange + print, binspday +endfor + +print, 'j ',j + +arrsv=arrsv(*,0:j-1) + +;stop + +; bin up the data + +;print,arrsv + +if (n_elements(bin) gt 0) then begin +if (bin gt 1) then begin +; time 0 num 1 mean 2 rms 3 +arrsv2=dblarr(4,j/bin) +for i=0,j/bin-1 do begin + + arrsvtemp=arrsv(*,i*bin:(i+1)*bin-1) + print,arrsvtemp + wh=where(arrsvtemp(1,*) gt 0) ; number of obs gt 0 +; print,wh + if (wh(0) gt -1) then begin + +; number of obs + arrsv2(1,i)=total(arrsvtemp(1,wh)) +; mean + arrsv2(2,i)=total(arrsvtemp(2,wh)*arrsvtemp(1,wh))/arrsv2(1,i) +; rms + arrsv2(3,i)=sqrt(total(arrsvtemp(3,wh)^2*arrsvtemp(1,wh))/arrsv2(1,i)) +; date (average) +; print,arrsv(0,i*bin) + arrsv2(0,i)=total(arrsvtemp(0,*))/bin +; print,arrsv2(0,i) + + endif + +endfor + +info, arrsv2 + +arrsv=arrsv2 + +endif +endif + +nel=n_elements(arrsv(0,*)) + +; produce 1 month/3 month/all average values + +finaltime=arrsv(0,nel-1) +onemon=finaltime-30 +threemon=finaltime-90 + +print,arrsv + +wh1=where(arrsv(0,*) gt onemon and arrsv(1,*) gt 0) +wh3=where(arrsv(0,*) gt threemon and arrsv(1,*) gt 0) +wh0=where(arrsv(1,*) gt 0) + +num1=total(arrsv(1,wh1)) +mean1=total(arrsv(2,wh1)*arrsv(1,wh1))/num1 +rms1=sqrt(total(arrsv(3,wh1)^2*arrsv(1,wh1))/num1) +print,num1 + +num3=total(arrsv(1,wh3)) +mean3=total(arrsv(2,wh3)*arrsv(1,wh3))/num3 +rms3=sqrt(total(arrsv(3,wh3)^2*arrsv(1,wh3))/num3) +print,num3 + +num0=total(arrsv(1,wh0)) +mean0=total(arrsv(2,wh0)*arrsv(1,wh0))/num0 +rms0=sqrt(total(arrsv(3,wh0)^2*arrsv(1,wh0))/num0) +print,num0 + +if (keyword_set(notitle)) then begin +title1="" +title="" +endif else begin +subtitle= 'rms (mean), 1 month: '+strtrim(string(rms1,format='(G0.4)'),2)+$ + '('+strtrim(string(mean1,format='(G0.3)'),2)+')' +subtitle=subtitle+ ', 3 month: '+strtrim(string(rms3,format='(G0.4)'),2)+$ + '('+strtrim(string(mean3,format='(G0.3)'),2)+')' +subtitle=subtitle+ ', all: '+strtrim(string(rms0,format='(G0.4)'),2)+$ + '('+strtrim(string(mean0,format='(G0.3)'),2)+')' + + +fullfiltstr='' +if (filtstr ne '') then fullfiltstr=' Type: '+filtstr + +title=obstypestr+typestr+' lons ('+strtrim(string(xrange(0),format='(F0.2)'),2)+$ + ','+strtrim(string(xrange(1),format='(F0.2)'),2)+$ + ') lats ('+strtrim(string(yrange(0),format='(F0.2)'),2)+','+$ + strtrim(string(yrange(1),format='(F0.2)'),2)+')'+fullfiltstr + +title1=title+'!C'+subtitle +endelse + +if (keyword_set(gif)) then begin + thisDevice = !D.Name + + Set_Plot, 'Z' ; do graphics in the background +; Device, Set_Resolution=[640,512], decomposed=0 + Device, Set_Resolution=[800,512], decomposed=0 + Erase ; clear any existing stuff + !p.charsize=0.75 +; setupct, r, g, b ; setup color table + + plotts1, arrsv, title1, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax, $ + emax=emax, emin=emin + + + snapshot = TVRD() + WRITE_GIF,'dataplot_timeseries.gif',snapshot, r, g, b + + plotts2, arrsv, title, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax + + + snapshot = TVRD() + WRITE_GIF,'dataplot_numtimeseries.gif',snapshot, r, g, b + + Device, Z_Buffer=1 ; reset graphics mode + Set_Plot, thisDevice + !p.charsize=0.0 + +endif + +if (keyword_set(ps)) then begin + ps=1 + eps=0 + landscape=1 + pr2o,file='dataplot_timeseries.ps',landscape=landscape,ps=ps,eps=eps,color=1 + plotts1, arrsv, title1, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax, $ + emax=emax, emin=emin + prend2o,view=view + + pr2o,file='dataplot_numtimeseries.ps',landscape=landscape,ps=ps,eps=eps,color=1 + plotts2, arrsv, title, typestr, minperc=minperc, $ + juldatemin=juldatemin, juldatemax=juldatemax + prend2o,view=view + +endif + +end + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/eos_nemo.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/eos_nemo.pro new file mode 100644 index 0000000000000000000000000000000000000000..ca4da96070815c7c89a154fd5cdcf12df869f7f7 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/eos_nemo.pro @@ -0,0 +1,79 @@ +function eos_nemo, t_in, psal +;------------------------------------------------------------------------------ +; +; Purpose: +; To calculate the density using the equation of state used in NEMO. +; This is based on the Jackett and McDougall (1994) equation of state +; for calculating the in situ density based on potential temperature +; and salinity. +; +; Inputs: +; temperature => 1d array potential temperature (deg C) +; salinity => 1d array salinity (PSU) +; +; Outputs: +; rhop => 1d array pot density (kg/m**3) +; +; could add use a difference reference pressure +; observations are in-situ temperature? +; +; Author: +; D. J. Lea. Dec 2006. +;------------------------------------------------------------------------------ + + zws = SQRT( ABS( psal ) ) + + sz=size(t_in) + ndim=sz(0) + NO_LEVS=sz(ndim) + + prhop=psal*0. + +; + for jk = 0L, NO_LEVS-1 do begin + + zt = T_IN(jk) + zs = psal(jk) +; * depth +; zh = O_DEP_LEVS(jk) ;used in calculating insitu density only + zsr= zws(jk) +; * compute volumic mass pure water at atm pressure + zr1= ( ( ( ( 6.536332e-9*zt-1.120083e-6 )*zt+1.001685e-4)*zt $ + -9.095290e-3 )*zt+6.793952e-2 )*zt+999.842594 +; * seawater volumic mass atm pressure + zr2= ( ( ( 5.3875e-9*zt-8.2467e-7 ) *zt+7.6438e-5 ) *zt $ + -4.0899e-3 ) *zt+0.824493 + zr3= ( -1.6546e-6*zt+1.0227e-4 ) *zt-5.72466e-3 + zr4= 4.8314e-4 + +; * potential volumic mass (reference to the surface) + zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 + +; * save potential volumic mass + prhop(jk) = zrhop + +; * add the compression terms + ze = ( -3.508914e-8*zt-1.248266e-8 ) *zt-2.595994e-6 + zbw= ( 1.296821e-6*zt-5.782165e-9 ) *zt+1.045941e-4 + zb = zbw + ze * zs + + zd = -2.042967e-2 + zc = (-7.267926e-5*zt+2.598241e-3 ) *zt+0.1571896 + zaw= ( ( 5.939910e-6*zt+2.512549e-3 ) *zt-0.1028859 ) *zt - 4.721788 + za = ( zd*zsr + zc ) *zs + zaw + + zb1= (-0.1909078*zt+7.390729 ) *zt-55.87545 + za1= ( ( 2.326469e-3*zt+1.553190)*zt-65.00517 ) *zt+1044.077 + zkw= ( ( (-1.361629e-4*zt-1.852732e-2 ) *zt-30.41638 ) *zt + 2098.925 ) *zt+190925.6 + zk0= ( zb1*zsr + za1 )*zs + zkw + +; ; in situ density anomaly +; prd(jk) = zrhop / ( 1.0 - zh / ( zk0 - zh * ( za - zh * zb ) ) ) +; + endfor + + + +return, prhop + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/nice_contourlevels.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/nice_contourlevels.pro new file mode 100644 index 0000000000000000000000000000000000000000..f01ed7239e33faec65fd64db9349b4c6f9588a60 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/nice_contourlevels.pro @@ -0,0 +1,60 @@ +function nice_contourlevels, data, nlevels=nlevels +;+---------------------------------------------------------------------------------------- +; nice_contourlevels.pro +; +; Select nice contour levels based on the data input and the number of levels +; +; Author: D. J. Lea - Feb 2008 +; +;+---------------------------------------------------------------------------------------- + +if (n_elements(nlevels) eq 0) then nlevels=15 + +mx=max(data) +mn=min(data) + +; use this to select colors to plot and labels + +clevels=findgen(nlevels)/nlevels*(mx-mn)+mn + +ocint=1./nlevels*(mx-mn) +print,'ocint ',ocint + +; contour interval at 2 sig figs +;digits=2 +;p10 = floor(alog10(abs(ocint))) +;expo = 10.0d^(digits -1 - p10) +;cint = long(ocint*expo)/expo +;print,'cint ',cint + +;does it end in 5 or 0? +digits=1 +p10 = floor(alog10(abs(ocint))) +expo = 10.0d^(digits -1 - p10) +cint = long(ocint*expo)/expo +print,'cint ',cint + +if (mx ne mn) then begin +mxfix=fix(mx/cint)*cint +mnfix=fix(mn/cint)*cint +print, mx, mxfix +print, mn, mnfix + +; nice contour values + +;calculate new nlevels +nlevels=fix((mxfix-mnfix)/cint+1) + +;print,nlevels +if (nlevels gt 0) then begin + clevels=findgen(nlevels)*cint+mnfix +endif else begin + clevels=mnfix +endelse +endif else begin + clevels=mn +endelse + +return, clevels + +end diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/pr2.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/pr2.pro new file mode 100644 index 0000000000000000000000000000000000000000..f4578ef63b39b1f2c8d71de188e9a09771a49c78 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/pr2.pro @@ -0,0 +1,55 @@ + PRO Pr2,device,$ + bw=bw,$ + color=o_color,$ + pcl=pcl,$ + ps=ps,$ + cps=cps,$ + eps=eps,$ + cgm=cgm,$ + screen=screen,$ + transparency=o_transparency,$ + encapsulated=encapsulated,$ + bpp=bpp,$ + portrait=portrait,$ + landscape=landscape,$ + table=table,$ + reread=reread,$ + noflip=noflip,$ + verbose=verbose,$ + xsize=xsize,$ + ysize=ysize,$ + xoffset=xoff,$ + yoffset=yoff,$ + scale=scale,$ + file=file,$ + destination=destination +;+---------------------------------------------------------- +; NAME:pr2 +; like pr, but uses nice fonts +; +; Author: D. J. Lea Feb 2008 +;+---------------------------------------------------------- + +COMMON pr2, view_landscape + + set_plot,'ps' + + if (n_elements(color) eq 0) then color=1 + if (n_elements(landscape) eq 0) then landscape=1 + if (keyword_set(portrait)) then landscape=0 + encapsulated=1 + if (keyword_set(eps)) then encapsulated=1 + if (keyword_set(ps)) then encapsulated=0 + + view_landscape=landscape + + DEVICE, filename=file, COLOR=color, landscape=landscape, $ + encapsulated=encapsulated, xsize=xsize, ysize=ysize + + +!p.font=0 +device,/helv + +;return + +end diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/prend2.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/prend2.pro new file mode 100644 index 0000000000000000000000000000000000000000..4aa3ff35b7bb0ae20765dac8da995b2805f0b90d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/prend2.pro @@ -0,0 +1,38 @@ +PRO PREND2,in_printer,keep=keep,noprint=noprint,double=double,$ + view=view,spin_landscape_ps=spin_landscape_ps,$ + eps_preview=eps_preview,colour_preview=colour_preview,$ + dpi_preview=dpi_preview, suppress_stderr=suppress_stderr +;+ +; NAME:prend +; +; Author: D. J. Lea Feb 2008 + +COMMON pr2, view_landscape + +; get filename of postscript device + +r = fstat(!D.UNIT) +filename = r.name + +device,/close +set_plot,'x' + +if keyword_set(view) then begin + + if (view_landscape) then begin + spawn,'gv -orientation=landscape -swap '+filename + endif else begin + spawn,'gv '+filename + endelse + +endif + +!p.font=-1 +!p.charsize=0 +!p.charthick=0 +!p.thick=0 +!p.background=0 + +;return + +end diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_cdfobs.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_cdfobs.pro new file mode 100644 index 0000000000000000000000000000000000000000..62fa2ca2f3c658fa38c5e61c74c8e2130b02ecf0 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_cdfobs.pro @@ -0,0 +1,221 @@ +;+--------------------------------------------------------------------------- +PRO read_cdfobs, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, Depths=Depths, $ + Obs=Observations, ModelVals=ModelVals, qcs=QCs, $ + Ob2=Observations2, ModelVal2=ModelVals2, qc2=QCs2, $ + Ob3=Observations3, $ + Dates=Dates, rmdi=rmdi, iobs=iobs, jobs=jobs, kobs=kobs, $ + Salinity=Salinity, nodates=nodates, types=types, $ + filetype=ObsType, quiet=quiet, MDT=MDT, $ + ProfileNum=ProfileNum, error=error, $ + notfussy=notfussy,VarName=VarName +;+-------------------------------------------------------------------------- +; Read in observation and feedback files +; detects filetype and calls the appropriate reading routine +; +; Author: D. J. Lea Feb 2008 +;+-------------------------------------------------------------------------- + +; Declare error label. +ON_IOERROR, IOERROR + +error=0 +title='' + +; Set types to undefined +types=-1 & tempvar=size(temporary(types)) + +; Read in netcdf data file and observation operator +;2. Work out which type of data is in the files by looking at the first one. +ncid = ncdf_open(Files(0), /nowrite) +if ncid lt 0 then message, 'Error opening file '+File +result = NCDF_ATTINQ( ncid, 'title', /global) +if result.datatype ne 'UNKNOWN' then ncdf_attget, ncid, 'title', Title, /global + +if string(Title) eq "NEMO observation operator output" then ObsType='feedback' $ +else $ +if string(Title) eq "Forecast class 4 file" then ObsType='ForecastClass4' $ +else $ +ObsType = 'none' + +if ObsType eq 'none' then begin + varid = ncdf_varid(ncid, 'POTM_CORRECTED') + if varid ge 0 then ObsType = 'Prof' + + varid = ncdf_varid(ncid, 'SLA') + if varid ge 0 then ObsType = 'SSH' + + varid = ncdf_varid(ncid, 'SST') + varid2 = ncdf_varid(ncid, 'sea_surface_temperature') + varid=max([varid,varid2]) + if varid ge 0 then ObsType = 'SST' + + varid = ncdf_varid(ncid, 'SEAICE') + varid2 = ncdf_varid(ncid, 'sea_ice_concentration') + varid=max([varid,varid2]) + if varid ge 0 then ObsType = 'SEAICE' + + varid = ncdf_varid(ncid, 'LOGCHL') + varid2 = ncdf_varid(ncid, 'LogChl') + varid3 = ncdf_varid(ncid, 'CHL1_mean') + varid=max([varid,varid2,varid3]) + if varid ge 0 then ObsType = 'LOGCHL' + + varid = ncdf_varid(ncid, 'PCO2') + if varid ge 0 then ObsType = 'PCO2' + + varid = ncdf_varid(ncid, 'UCRT') + varid2 = ncdf_varid(ncid, 'VCRT') + varid=max([varid,varid2]) + if varid ge 0 then ObsType = 'CRT' +endif + +ncdf_close, ncid + +if not keyword_set(quiet) then print, 'Reading in data as type ',ObsType + + if ObsType eq 'feedback' then begin + + if n_elements(DepRange) eq 0 then DepRange=[0,5000] + + read_feedback, Files, DepRange=DepRange, VarName=VarName, NumData=numobs, $ + OutLats=Latitudes, OutLons=Longitudes, $ + OutInstruments=Instruments, OutPlatform=Platform, $ + OutDeps=Depths, $ + OutObs1=Observations, OutObs2=Observations2, $ + OutMod1=ModelVals, OutMod2=ModelVals2, $ + OutQC1=QCs, OutQC2=QCs2, $ + MDT=MDT, OutDates=Dates, $ + rmdi=rmdi, quiet=quiet, $ + OutProfileNum=ProfileNum + +; info, instruments +; info, platform + + types=Platform + if n_elements(instruments) gt 0 then types=Platform+' '+Instruments + + print, 'Varname: ',VarName + endif else if ObsType eq 'Prof' then begin + + if keyword_set(PlotModel) then begin + OutTMod = 1 + OutSMod = 1 + endif + + if n_elements(DepRange) eq 0 then DepRange=[0,5000] + + read_enact, Files, DepRange=DepRange, NumData=NumData, $ + OutLats=Latitudes, OutLons=Longitudes, $ + Instruments=Instruments, Platform=Platform, $ + OutDeps=Depths, OutSObs=OutSObs, OutSQC=OutSQC, $ + OutTObs=OutTObs, OutTQC=OutTQC, OutDates=Dates, $ + OutTMod=OutTMod, OutSMod=OutSMod, rmdi=rmdi, quiet=quiet, $ + iobs=iobs, jobs=jobs, kobs=kobs, $ + ProfileNum=ProfileNum + + types=Instruments+' '+Platform + +; if salinity keyword is set then put salinity values first + if keyword_set(Salinity) then begin + Observations = OutSObs + ModelVals = OutSMod + QCs = OutSQC + Observations2 = OutTObs + ModelVals2 = OutTMod + QCs2 = OutTQC + endif else begin + Observations = OutTObs + ModelVals = OutTMod + QCs = OutTQC + Observations2 = OutSObs + ModelVals2 = OutSMod + QCs2 = OutSQC + endelse + + numobs=numdata + numobs=n_elements(latitudes) + + endif else if ObsType eq 'SSH' then begin + + read_sla, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + ObsSLA=Observations, ModSLA=ModelVals, SLAQC=QCs, $ + MDT=MDT, Satellites=Satellites, types=types, Dates=Dates, rmdi=rmdi, $ + iobs=iobs, jobs=jobs, mstp=mstp, quiet=quiet + Depths = fltarr(NumObs) + + endif else if ObsType eq 'SST' then begin + + read_sst, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + ObsSST=Observations, ModSST=ModelVals, SSTQC=QCs, $ + Dates=Dates, rmdi=rmdi, types=types, iobs=iobs, jobs=jobs, $ + quiet=quiet + Depths = fltarr(NumObs) + + endif else if ObsType eq 'SEAICE' then begin + + read_seaice, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + Obs=Observations, Modarr=ModelVals, QC=QCs, $ + Dates=Dates, rmdi=rmdi, iobs=iobs, jobs=jobs, nodates=nodates, $ + quiet=quiet + Depths = fltarr(NumObs) + + endif else if ObsType eq 'LOGCHL' then begin + + read_chl, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + Obs=Observations, Modarr=ModelVals, QC=QCs, $ + Dates=Dates, rmdi=rmdi, iobs=iobs, jobs=jobs, nodates=nodates, $ + quiet=quiet + Depths = fltarr(NumObs) + + endif else if ObsType eq 'PCO2' then begin + + read_pco2, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + Obs=Observations, Modarr=ModelVals, QC=QCs, $ + Dates=Dates, rmdi=rmdi, iobs=iobs, jobs=jobs, nodates=nodates, $ + quiet=quiet + Depths = fltarr(NumObs) + + endif else if ObsType eq 'CRT' then begin + + read_crt, Files, NumObs=NumObs, $ + OutLats=Latitudes, OutLons=Longitudes, $ + OutTypes=Types, OutDates=Dates, $ + OutUObs=Observations, OutVObs=Observations2, $ + OutUMod=ModelVals, OutVMod=ModelVals2, Quiet=Quiet, $ + FloatNum=FloatNum, QC=QCs, OutSpeed=Observations3 + rmdi=0.0 + QCs2=QCs + Depths = fltarr(NumObs) + + endif else if ObsType eq 'ForecastClass4' then begin + + print, 'reading forecast class 4 files' + read_forc_class4, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + Depths=Depths, $ + Types=types, Dates=Dates, $ + Obsarr=Observations, Obs2arr=Observations2, $ + Modarr=ModelVals, Mod2arr=ModelVals2, $ + QCs1=QCs, QCs2=QCs2, rmdi=rmdi, $ + notfussy=notfussy + + endif else message, 'Error: ObsType is not set correctly' + + if (n_elements(types) eq 0) then begin + types=replicate(rmdi,NumObs) + endif + + goto, NOERROR + +IOERROR: error=1 + print,'read_cdfobs: an error occurred trying read files: ',files + +NOERROR: + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_enact.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_enact.pro new file mode 100644 index 0000000000000000000000000000000000000000..75077db09423a0109a33c127200f93aeb1e59aee --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_enact.pro @@ -0,0 +1,313 @@ +PRO read_enact, Files, DepRange=DepRange, $ + NumData=NumData, $ + OutLats=OutLats, OutLons=OutLons, Instruments=OutInst, $ + Platform=OutPlatform, $ + OutDeps=OutDeps, OutSObs=OutSObs, OutSQC=OutSQC, $ + OutTObs=OutTObs, OutTQC=OutTQC, OutDates=OutDates, $ + OutTMod=OutTMod, OutSMod=OutSMod, rmdi=rmdi, quiet=quiet, $ + iobs=outiobs, jobs=outjobs, kobs=outkobs, $ + ProfileNum=OutProfileNum + +;------------------------------------------------------------------------------------------ +;Program to read in data from an ENACT format file containing profile data. +; +; Inputs: +; File => File name to be read in +; DepRange => (optional) Range of depths for which the data is to be extracted. +; +; Outputs: +; NumProfs => Number of profiles -Integer +; Latitudes => Latitudes(NumProfs) -Real +; Longitudes => Longitudes(NumProfs) -Real +; Dates => Dates(NumProfs) -Date/time structure. +; Instruments => Instrument type (NumProfs) -String +; Depths => Depths of each ob (NumProfs) -Real +; Salinity => Salinity (psu) (NumProfs) -Real +; SalQC => QC flag for salinity (NumProfs) 1=> Good -Int +; Temperature => Temperature (deg C) (NumProfs) -Real +; TempQC => QC flag for temperature (NumProfs) 1=> Good -Int +; ModelT => Model temperature (deg C) (NumProfs) -Real +; ModelS => Model salinity (psu) (NumProfs) -Real +; rmdi => Missing data indicator -Real +; +;Author: Matt Martin. 5/10/07. +;------------------------------------------------------------------------------------------ +rmdi = 99999. +if NOT keyword_set(DepRange) then DepRange=[0.,1.e1] ;Default to top 10 metres. +NumFiles=n_elements(Files) + +ifile2=0 +for ifile = 0, NumFiles-1 do begin + File = Files(ifile) + +;1. Open the netcdf file + ncid = ncdf_open(File, /nowrite) + if ncid lt 0 and not keyword_set(quiet) then print, 'Error opening file '+File + if ncid ge 0 then begin + if not keyword_set(quiet) then print, 'Opened file '+File+' successfully' + + ;2. Get info about file + ncinfo = ncdf_inquire(ncid) +; if not keyword_set(quiet) then , ncinfo + ;3. Read in the relevant dimensions + for idim = 0, ncinfo.ndims-1 do begin + ncdf_diminq, ncid, idim, name, dimlen + if name eq 'N_PROF' then NumProfs = dimlen $ + else if name eq 'N_LEVELS' then NumLevels = dimlen $ + else if name eq 'STRING4' then str4 = dimlen + endfor + + ;4. Set up arrays and read in the data + + if (NumProfs gt 0) then begin + JulDays = fltarr(NumProfs) + Latitudes = fltarr(NumProfs) + Longitudes = fltarr(NumProfs) + BytInsts = intarr(4, NumProfs) + Instruments = strarr(NumProfs) + Platforms = strarr(NumProfs) + Instrumentsa = strarr(NumLevels, NumProfs) + Platformsa = strarr(NumLevels, NumProfs) + Depths = fltarr(NumLevels, NumProfs) + Salinity = fltarr(NumLevels, NumProfs) + SalQC = intarr(NumLevels, NumProfs) + Temperature = fltarr(NumLevels, NumProfs) + TempQC = intarr(NumLevels, NumProfs) + ModelT = fltarr(NumLevels, NumProfs) + ModelS = fltarr(NumLevels, NumProfs) + ProfileNum = replicate(1,NumLevels)#indgen(NumProfs) + + varid = ncdf_varid(ncid, 'JULD') + ncdf_varget, ncid, varid, JulDays + +; print,JulDays + +; BaseDate = var_to_dt(1950,1,1) +; BaseDate=JULDAY(1,1,1950,0,0) + BaseDate=double(JULDAY(1,1,1950,0,0)) ;should be at 0 UTC +; info,BaseDate + Dates = replicate(BaseDate, NumLevels,NumProfs) +; info,dates + for iprof = 0L, NumProfs-1 do begin + secs = JulDays(iprof)* 24. * 60. * 60. +; dt = dt_add(BaseDate, second=secs) + dt=BaseDate+JulDays(iprof) +; CALDAT, dt, mon, day, year, hour, minute, second +; print,dt-BaseDate, mon, day, year, hour, minute, second + Dates(0:NumLevels-1,iprof) = replicate(dt,NumLevels) + endfor + + + + varid = ncdf_varid(ncid, 'LONGITUDE') + ncdf_varget, ncid, varid, Longitudes + + varid = ncdf_varid(ncid, 'LATITUDE') + ncdf_varget, ncid, varid, Latitudes + + varid = ncdf_varid(ncid, 'DEPH_CORRECTED') + ncdf_varget, ncid, varid, Depths + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse + pts = where(Depths eq FillVal, count) + if count gt 0 then Depths(pts) = rmdi + +; if keyword_set(Salinity) then begin + varid = ncdf_varid(ncid, 'PSAL_CORRECTED') + if (varid ne -1) then begin +; if not keyword_set(quiet) then print,'reading psal_corrected' + ncdf_varget, ncid, varid, Salinity + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse + pts = where(Salinity eq FillVal, count) + if count gt 0 then Salinity(pts) = rmdi + endif + varid = ncdf_varid(ncid, 'PSAL_CORRECTED_QC') + ncdf_varget, ncid, varid, SalQC + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse + SalQC = SalQC - 48 +; endif + +; if keyword_set(Temperature) then begin + varid = ncdf_varid(ncid, 'POTM_CORRECTED') + if (varid ne -1) then begin +; if not keyword_set(quiet) then print,'reading potm_corrected' + ncdf_varget, ncid, varid, Temperature + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse +; if not keyword_set(quiet) then print,'Temp fill value ',fillval + pts = where(Temperature eq FillVal, count) + if count gt 0 then Temperature(pts) = rmdi + endif + varid = ncdf_varid(ncid, 'POTM_CORRECTED_QC') + ncdf_varget, ncid, varid, TempQC + TempQC = TempQC - 48 +; endif + +; if keyword_set(OutTMod) then begin + varid = ncdf_varid(ncid, 'POTM_Hx') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, ModelT + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse + pts = where(ModelT eq FillVal, count) + if count gt 0 then ModelT(pts) = rmdi + endif else begin + ModelT=rmdi + endelse +; endif + +; if keyword_set(OutSMod) then begin + varid = ncdf_varid(ncid, 'PSAL_Hx') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, ModelS + res = ncdf_attinq( ncid, varid , '_FillValue') + if res.length gt 0 and res.datatype ne "UNKNOWN" then ncdf_attget, ncid, varid, '_FillValue', FillVal $ + else begin + res = ncdf_attinq( ncid, varid , '_fillvalue') + ncdf_attget, ncid, varid, '_fillvalue', FillVal + endelse + pts = where(ModelS eq FillVal, count) + if count gt 0 then ModelS(pts) = rmdi + endif else begin + ModelS=rmdi + endelse +; endif + + varid = ncdf_varid(ncid, 'WMO_INST_TYPE') + ncdf_varget, ncid, varid, BytInsts + + pts = where(BytInsts(0,*) eq 32 and $ + BytInsts(1,*) eq 56 and $ + BytInsts(2,*) eq 50 and $ + BytInsts(3,*) eq 48, count) + if count gt 0 then Instruments(pts) = 'BUOYS' ; 820 + + pts = where(BytInsts(0,*) eq 32 and $ + BytInsts(1,*) eq 52 and $ + BytInsts(2,*) eq 48 and $ + BytInsts(3,*) eq 49, count) + if count gt 0 then Instruments(pts) = 'XBT' ; 401 + + pts = where(BytInsts(0,*) eq 32 and $ + BytInsts(1,*) eq 55 and $ + BytInsts(2,*) eq 52 and $ + BytInsts(3,*) eq 49, count) + if count gt 0 then Instruments(pts) = 'TESAC' ; 741 + + pts = where(BytInsts(0,*) eq 32 and $ + BytInsts(1,*) eq 56 and $ + BytInsts(2,*) eq 51 and $ + BytInsts(3,*) eq 49, count) + if count gt 0 then Instruments(pts) = 'ARGO' ; 831 + + pts = where(Instruments eq '', count) + if count gt 0 then Instruments(pts) = 'UNKNOWN' + + varid = ncdf_varid(ncid, 'PLATFORM_NUMBER') + ncdf_varget, ncid, varid, platforms + platforms=string(platforms) + + for i=0,numlevels-1 do begin + platformsa(i,*)=platforms + instrumentsa(i,*)=instruments + endfor + + varid = ncdf_varid(ncid, 'IOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, iobsval + + varid = ncdf_varid(ncid, 'JOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, jobsval + + varid = ncdf_varid(ncid, 'KOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, kobsval + + ;Select those obs in the required depth range +; Lats = replv(Latitudes(*), [NumLevels,NumProfs],1) +; Lons = replv(Longitudes(*), [NumLevels,NumProfs],1) + + Lons=fltarr(NumLevels,NumProfs) + Lats=fltarr(NumLevels,NumProfs) + iobs=fltarr(NumLevels,NumProfs) + jobs=fltarr(NumLevels,NumProfs) + + for i=0L,NumProfs-1 do begin + Lats(*,i)=Latitudes(i) + Lons(*,i)=Longitudes(i) + if (n_elements(iobsval) gt 0) then $ + iobs(*,i)=iobsval(i) + if (n_elements(jobsval) gt 0) then $ + jobs(*,i)=jobsval(i) + endfor + + pts = where(Depths ge DepRange(0) and Depths le DepRange(1), NumData) + + if ifile2 eq 0 then begin + OutTObs = [Temperature(pts)] + OutSObs = [Salinity(pts)] + OutTMod = [ModelT(pts)] + OutSMod = [ModelS(pts)] + OutTQC = [TempQC(pts)] + OutSQC = [SalQC(pts)] + OutDeps = [Depths(pts)] + OutLats = [Lats(pts)] + OutLons = [Lons(pts)] + OutDates= [Dates(pts)] + OutInst= [Instrumentsa(pts)] + OutPlatform= [Platformsa(pts)] + OutProfileNum = [ProfileNum(pts)] + if (n_elements(iobsval) gt 0) then outiobs = [iobs(pts)] + if (n_elements(jobsval) gt 0) then outjobs = [jobs(pts)] + if (n_elements(kobsval) gt 0) then outkobs = [kobsval(pts)] + + endif else begin + OutTObs = [OutTObs,Temperature(pts)] + OutSObs = [OutSObs,Salinity(pts)] + OutTMod = [OutTMod,ModelT(pts)] + OutSMod = [OutSMod,ModelS(pts)] + OutTQC = [OutTQC,TempQC(pts)] + OutSQC = [OutSQC,SalQC(pts)] + OutDeps = [OutDeps,Depths(pts)] + OutLats = [OutLats,Lats(pts)] + OutLons = [OutLons,Lons(pts)] + OutDates= [OutDates,Dates(pts)] + OutInst= [OutInst,Instrumentsa(pts)] + OutPlatform = [OutPlatform, Platformsa(pts)] + OutProfileNum = [OutProfileNum, ProfileNum(pts)] + if (n_elements(iobsval) gt 0) then outiobs = [outiobs, iobs(pts)] + if (n_elements(jobsval) gt 0) then outjobs = [outjobs, jobs(pts)] + if (n_elements(kobsval) gt 0) then outkobs = [outkobs, kobsval(pts)] + + endelse + + ifile2=ifile2+1 + endif + ncdf_close, ncid + + + endif + +endfor ;ifile + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_feedback.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_feedback.pro new file mode 100644 index 0000000000000000000000000000000000000000..a258bbe332949647069ab453fa7ef94cea88bc84 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_feedback.pro @@ -0,0 +1,283 @@ +PRO read_feedback, Files, DepRange=DepRange, VarName=VarNames, NumData=NumData, $ + OutLats=OutLats, OutLons=OutLons, $ + OutInstruments=OutInst, OutPlatform=OutPlatform, $ + OutDeps=OutDeps, $ + OutObs1=OutObs1, OutObs2=OutObs2, $ + OutMod1=OutMod1, OutMod2=OutMod2, $ + OutQC1=OutQC1, OutQC2=OutQC2, $ + MDT=MDT, OutDates=OutDates, $ + rmdi=rmdi, quiet=quiet, $ + OutProfileNum=OutProfileNum + +;------------------------------------------------------------------------------------------ +;Program to read in data from a feedback format file +; +; Inputs: +; File => File name to be read in +; DepRange => (optional) Range of depths for which the data is to be extracted. +; +; Outputs: + +; +;Author: Matt Martin. 29/09/09 +;------------------------------------------------------------------------------------------ +rmdi = 99999. +if NOT keyword_set(DepRange) then DepRange=[0.,1.e1] ;Default to top 10 metres. +NumFiles=n_elements(Files) + +ifile2=0 +numdata=0 +for ifile = 0, NumFiles-1 do begin + File = Files(ifile) + +;1. Open the netcdf file + ncid = ncdf_open(File, /nowrite) + if ncid lt 0 and not keyword_set(quiet) then print, 'Error opening file '+File + if ncid ge 0 then begin + if not keyword_set(quiet) then print, 'Opened file '+File+' successfully' + + ;2. Get info about file + ncinfo = ncdf_inquire(ncid) + + ;3. Read in the relevant dimensions + NumExtra = 0 + for idim = 0, ncinfo.ndims-1 do begin + ncdf_diminq, ncid, idim, name, dimlen + if name eq 'N_OBS' then NumObs = dimlen $ + else if name eq 'N_LEVELS' then NumLevels = dimlen $ + else if name eq 'N_VARS' then NumVars = dimlen $ + else if name eq 'N_QCF' then NumFlags = dimlen $ + else if name eq 'N_ENTRIES' then NumEntries = dimlen $ + else if name eq 'N_EXTRA' then NumExtra = dimlen $ + else if name eq 'STRINGNAM' then strnam = dimlen $ + else if name eq 'STRINGGRID' then strgrid = dimlen $ + else if name eq 'STRINGWMO' then strwmo = dimlen $ + else if name eq 'STRINGTYP' then strtyp = dimlen $ + else if name eq 'STRINGJULD' then strjuld = dimlen + endfor + + ;4. Set up arrays + + if (NumObs gt 0) then begin + ByteNam = intarr(strnam, NumVars) + if (n_elements(NumEntries) eq 1) then ByteEntries = intarr(strnam, NumEntries) + ByteId = intarr(strwmo, NumObs) + ByteType = intarr(strtyp, NumObs) + ByteJulDRef = intarr(strjuld) + VarNames = strarr(NumVars) + if (n_elements(NumEntries) eq 1) then Entries = strarr(NumEntries) + Id = strarr(NumObs) + Type = strarr(NumObs) + if NumExtra gt 0 then begin + ByteExtra = intarr(strnam, NumExtra) + Extra = strarr(NumExtra) + endif + Longitude = fltarr(NumObs) + Latitude = fltarr(NumObs) + Depth = fltarr(NumLevels, NumObs) + DepQC = intarr(NumLevels, NumObs) + JulD = dblarr(NumObs) + ObsQC = intarr(NumObs) + PosQC = intarr(NumObs) + JulDQC = intarr(NumObs) + Obs = fltarr(NumLevels, NumObs, NumVars) + Hx = fltarr(NumLevels, NumObs, NumVars) + VarQC = intarr(NumObs, NumVars) + LevelQC = intarr(NumLevels, NumObs, NumVars) + + ;5. Read in the data + varid = ncdf_varid(ncid, 'VARIABLES') + ncdf_varget, ncid, varid, ByteNam +; info, VarNames +; info, ByteNam + for ivar= 0, NumVars-1 do begin + VarNames(ivar) = string(ByteNam(*,ivar)) + endfor + + if ifile2 eq 0 then VarName = VarNames(0) + if VarName ne VarNames(0) then message, 'Can only read in from files containing the same variables' + + varid = ncdf_varid(ncid, 'JULD_REFERENCE') + ncdf_varget, ncid, varid, ByteJulDRef + JulDRef = string(ByteJulDRef) + RefDate = JULDAY(fix(strmid(JulDRef,4,2)), fix(strmid(JulDRef,6,2)), fix(strmid(JulDRef,0,4)), $ + fix(strmid(JulDRef,8,2)), fix(strmid(JulDRef,10,2)), fix(strmid(JulDRef,12,2))) + print, 'RefDate: ',RefDate + varid = ncdf_varid(ncid, 'JULD') + ncdf_varget, ncid, varid, JulD +; print, JulD + Dates = dblarr(NumLevels, NumObs) + for iob = 0L, long(NumObs)-1L do begin + dt = RefDate + JulD(iob) +; print,dt, JulD(iob) + Dates(0:NumLevels-1, iob) = replicate(dt, NumLevels) + endfor + + varid = ncdf_varid(ncid, 'STATION_IDENTIFIER') + ncdf_varget, ncid, varid, ByteId + Identifier = string(ByteId) + + varid = ncdf_varid(ncid, 'STATION_TYPE') + ncdf_varget, ncid, varid, ByteType + Type = string(ByteType) + + varid = ncdf_varid(ncid, 'LONGITUDE') + ncdf_varget, ncid, varid, Longitude + + varid = ncdf_varid(ncid, 'LATITUDE') + ncdf_varget, ncid, varid, Latitude + + varid = ncdf_varid(ncid, 'DEPTH') + ncdf_varget, ncid, varid, Depth + ncdf_attget, ncid, varid, '_Fillvalue', FillVal + pts = where(Depth eq FillVal, count) + if count gt 0 then Depth(pts) = rmdi + + varid = ncdf_varid(ncid, 'OBSERVATION_QC') + ncdf_varget, ncid, varid, ObsQC + ncdf_attget, ncid, varid, '_Fillvalue', FillVal + pts = where(ObsQC eq FillVal, count) + if count gt 0 then ObsQC(pts) = rmdi + + for ivar = 0, NumVars-1 do begin + + varid = ncdf_varid(ncid, strtrim(VarNames(ivar))+'_OBS') + ncdf_varget, ncid, varid, tmp + Obs(*,*,ivar) = tmp + ncdf_attget, ncid, varid, '_Fillvalue', FillValObs + + varid = ncdf_varid(ncid, strtrim(VarNames(ivar))+'_Hx') + if (varid gt -1) then begin + ncdf_varget, ncid, varid, tmp + Hx(*,*,ivar) = tmp + ncdf_attget, ncid, varid, '_Fillvalue', FillValHx + endif else begin + FillValHx=0 + endelse + + varid = ncdf_varid(ncid, strtrim(VarNames(ivar))+'_QC') + ncdf_varget, ncid, varid, tmp + VarQC(*,ivar) = tmp + ncdf_attget, ncid, varid, '_Fillvalue', FillValQC + + + varid = ncdf_varid(ncid, strtrim(VarNames(ivar))+'_LEVEL_QC') + ncdf_varget, ncid, varid, tmp + LevelQC(*,*,ivar) = tmp + ncdf_attget, ncid, varid, '_Fillvalue', FillValLevQC + + endfor + +; print,' DJL levelqc(*,218,0) ',levelqc(*,218,0) +; print,' DJL levelqc(*,218,1) ',levelqc(*,218,1) + + pts = where(Obs eq FillValObs, count) + if count gt 0 then Obs(pts) = rmdi + pts = where(Hx eq FillValHx, count) + if count gt 0 then Hx(pts) = rmdi + pts = where(VarQC eq FillValQC, count) + if count gt 0 then VarQC(pts) = rmdi + pts = where(LevelQC eq FillValLevQC, count) + if count gt 0 then LevelQC(pts) = rmdi + + Obs1 = Obs(*,*,0) + Hx1 = Hx(*,*,0) + VarQC1=LevelQC(*,*,0) + if NumVars gt 1 then begin + Obs2 = Obs(*,*,1) + Hx2 = Hx(*,*,1) + VarQC2=LevelQC(*,*,1) + endif + + if strtrim(VarName,2) eq 'SLA' then begin + MDT = fltarr(NumLevels, NumObs) + print, NumLevels, NumObs + varid = ncdf_varid(ncid, 'MDT') + ncdf_varget, ncid, varid, MDT + ncdf_attget, ncid, varid, '_Fillvalue', FillVal + pts = where(MDT eq FillVal, count) + if count gt 0 then MDT(pts) = rmdi + Obs2 = MDT + endif + + ;6. Put the data into the correct form to be output from this routine + Platformsa = strarr(NumLevels, NumObs) + Instrumentsa = strarr(NumLevels, NumObs) + Lons = fltarr(NumLevels,NumObs) + Lats = fltarr(NumLevels,NumObs) + ProfileNum = lonarr(NumLevels,NumObs) + + for i=0,NumLevels-1 do begin + Platformsa(i,*)=Type + Instrumentsa(i,*)=Identifier + endfor + + for i=0L,long(NumObs)-1L do begin + Lats(*,i)=Latitude(i) + Lons(*,i)=Longitude(i) + ProfileNum(*,i) = i+1 + endfor +; + pts = where(Depth ge DepRange(0) and Depth le DepRange(1), NumDataInc) + NumData=NumData+NumDataInc +; + if ifile2 eq 0 then begin + OutObs1 = [Obs1(pts)] + OutMod1 = [Hx1(pts)] + OutQC1 = [VarQC1(pts)] + OutDeps = [Depth(pts)] + OutLats = [Lats(pts)] + OutLons = [Lons(pts)] + OutDates= [Dates(pts)] + OutInst= [Instrumentsa(pts)] + OutPlatform= [Platformsa(pts)] + OutProfileNum = [ProfileNum(pts)] + if NumVars eq 2 then begin + OutObs2 = [Obs2(pts)] + OutMod2 = [Hx2(pts)] + OutQC2 = [VarQC2(pts)] + endif + endif else begin + OutObs1 = [OutObs1, Obs1(pts)] + OutMod1 = [OutMod1, Hx1(pts)] + OutQC1 = [OutQC1, VarQC1(pts)] + OutDeps = [OutDeps, Depth(pts)] + OutLats = [OutLats, Lats(pts)] + OutLons = [OutLons, Lons(pts)] + OutDates= [OutDates, Dates(pts)] + OutInst= [OutInst, Instrumentsa(pts)] + OutPlatform= [OutPlatform, Platformsa(pts)] + OutProfileNum = [OutProfileNum, ProfileNum(pts)] + if NumVars eq 2 then begin + OutObs2 = [OutObs2, Obs2(pts)] + OutMod2 = [OutMod2, Hx2(pts)] + OutQC2 = [OutQC2, VarQC2(pts)] + endif + endelse + + if NumVars eq 1 then begin + if VarName ne 'SLA' then OutObs2 = fltarr(n_elements(OutObs1)) + rmdi + OutMod2 = fltarr(n_elements(OutMod1)) + rmdi + OutQC2 = fltarr(n_elements(OutQC1)) + rmdi + endif +; + ifile2=ifile2+1 + endif + ncdf_close, ncid + + endif + +endfor ;ifile + +pts1 = where(OutQC1 eq 1, count1) +pts2 = where(OutQC1 ne 1, count2) +if count1 gt 0 then OutQc1(pts1) = 0 +if count2 gt 0 then OutQc1(pts2) = 1 +if NumVars gt 1 then begin + pts1 = where(OutQC2 eq 1, count1) + pts2 = where(OutQC2 ne 1, count2) + if count1 gt 0 then OutQc2(pts1) = 0 + if count2 gt 0 then OutQc2(pts2) = 1 +endif + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_seaice.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_seaice.pro new file mode 100644 index 0000000000000000000000000000000000000000..7999ab6f683b918ca0b07815d2b7806b376b4b1c --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_seaice.pro @@ -0,0 +1,178 @@ +PRO read_seaice, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + Obs=Obs, modarr=modarr, qc=qcarr, $ + Dates=Dates, rmdi=rmdi, iobs=outiobs, jobs=outjobs, $ + nodates=nodates, quiet=quiet +;------------------------------------------------------------ +;IDL program to read in netcdf files of sea ice data. +; +;Author: D. J. Lea Feb 2008 +; +;------------------------------------------------------------ +rmdi = -99999. +NumFiles=n_elements(Files) +;RefDate = '1950-01-01' +;!DATE_SEPARATOR='-' +RefDate=JULDAY(1,1,1950,0,0) ; should be at 0 UTC + +; could read in from file + +ifile2=0 +for ifile = 0, NumFiles-1 do begin +;------------------------------------------------------------ +;1. Open the file containing the data + ncid = ncdf_open(Files(ifile), /nowrite) + if ncid lt 0 and not keyword_set(quiet) then print, 'Error opening file '+Files(ifile) + if ncid ge 0 then begin + if not keyword_set(quiet) then print, 'Opened file '+Files(ifile)+' successfully' + +;------------------------------------------------------------ +;2. Read in the dimensions in the file + ncinfo = ncdf_inquire(ncid) + ncdf_diminq, ncid, 0, name, NData + if Ndata gt 0 then begin + +;------------------------------------------------------------ +;3. Allocate the data arrays and read in the data + lons = dblarr(NData) + lats = dblarr(NData) + obsval = fltarr(NData) + modval = fltarr(NData) + bytQC = bytarr(NData) + QC = fltarr(NData) + Dats = dblarr(NData) + dts = replicate(!dt_base, NData) + iobs = intarr(NData) + jobs = intarr(NData) + +; output attribute and variable info +; ncattinfo, id + + varid = ncdf_varid(ncid, 'lon') +; if not keyword_set(quiet) then print,varid + if (varid eq -1) then varid = ncdf_varid(ncid, 'LONGITUDE') + ncdf_varget, ncid, varid, lons + + varid = ncdf_varid(ncid, 'lat') +; if not keyword_set(quiet) then print,varid + if (varid eq -1) then varid = ncdf_varid(ncid, 'LATITUDE') + ncdf_varget, ncid, varid, lats + + if (keyword_set(nodates) eq 0) then begin + + varid = ncdf_varid(ncid, 'JULD') + if varid ne -1 then begin + ncdf_varget, ncid, varid, Dats + dts = Dats+RefDate + endif else begin + varid = ncdf_varid(ncid, 'time') + ncdf_varget, ncid, varid, secs_from_base + varid = ncdf_varid(ncid, 'SeaIce_dtime') + ncdf_varget, ncid, varid, dtime + ncdf_attget, ncid, varid, 'scale_factor', scale_factor + if not keyword_set(quiet) then print,'dtime(0): ',dtime(0), scale_factor + dtime=dtime*scale_factor +; RefDate = '1981-01-01' + RefDate = JULDAY(1,1,1981,0,0) ; should be ref from 0 UTC + dtime = dtime + secs_from_base + dts = RefDate + dtime/86400. + endelse + + endif + + if not keyword_set(quiet) then print,'reading sea ice data' + varid = ncdf_varid(ncid, 'sea_ice_concentration') + if not keyword_set(quiet) then print,varid + if (varid eq -1) then begin + varid2 = ncdf_varid(ncid, 'SEAICE') + if (varid2 ne -1) then ncdf_varget, ncid, varid2, obsval + endif + if (varid ne -1) then ncdf_varget, ncid, varid, obsval + if not keyword_set(quiet) then print,'scale_factor' + scale_factor=1. + if (varid ne -1) then ncdf_attget, ncid, varid, 'scale_factor', scale_factor + + if not keyword_set(quiet) then print,'_FillValue' + FillValue=99999 + +; ncdf_attget, ncid, varid, '_FillValue', FillValue + if not keyword_set(quiet) then print,FillValue + + pts = where(obsval eq FillValue, count) + + if not keyword_set(quiet) then print,'scale_factor ',scale_factor + obsval=obsval*scale_factor + + if count gt 0 then obsval(pts) = rmdi + + + if not keyword_set(quiet) then print,'reading sea ice model values' + varid = ncdf_varid(ncid, 'SEAICE_Hx') + if (varid ne -1) then ncdf_varget, ncid, varid, modval + + varid = ncdf_varid(ncid, 'IOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, iobs + + varid = ncdf_varid(ncid, 'JOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, jobs + + + scale_factor=1 + pts = where(modval eq FillValue or modval eq -9999, count) + + modval=modval*scale_factor + + if count gt 0 then modval(pts) = rmdi + + if not keyword_set(quiet) then print,'sea ice qc' + + varid = ncdf_varid(ncid, 'SEAICE_QC') + if (varid ne -1) then begin + if not keyword_set(quiet) then print,'bytQC' + ncdf_varget, ncid, varid, bytQC + ncdf_attget, ncid, varid, '_FillValue', FillValue + QC(*) = 0. + pts = where(bytQC eq FillValue, count) + if count gt 0 then QC(pts) = rmdi + pts = where(bytQC ne 48, count) + if count gt 0 then QC(pts) = 1. + endif else begin + varid = ncdf_varid(ncid, 'confidence_flag') + ncdf_varget, ncid, varid, QC + endelse + + if ifile2 eq 0 then begin + Latitudes = [float(lats)] + Longitudes = [float(lons)] + Obs = [obsval] + Modarr = [modval] + QCarr = [QC] + Dates = [dts] + if (n_elements(iobs) gt 0) then outiobs = [iobs] + if (n_elements(jobs) gt 0) then outjobs = [jobs] + endif else begin + Latitudes = [Latitudes, float(lats)] + Longitudes = [Longitudes, float(lons)] + Obs = [Obs, obsval] + Modarr = [Modarr, modval] + QCarr = [QCarr, QC] + Dates = [Dates, dts] + if (n_elements(iobs) gt 0) then outiobs = [outiobs, iobs] + if (n_elements(jobs) gt 0) then outjobs = [outjobs, jobs] + endelse + +ifile2=ifile2+1 +endif + + if not keyword_set(quiet) then print,'closing file' + + ncdf_close, ncid + +endif +endfor ; ifile + +NumObs = n_elements(Latitudes) + +if (n_elements(Modarr) ne NumObs) then Modarr=replicate(rmdi,NumObs) + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sla.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sla.pro new file mode 100644 index 0000000000000000000000000000000000000000..e2b56223f6c0e4b5af3bab5d13664034700e43a4 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sla.pro @@ -0,0 +1,312 @@ +;+ +PRO read_sla, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + ObsSLA=ObsSLA, ModSLA=ModSLA, SLAQC=SLAQC, $ + MDT=MDT, Satellites=Satellites, Types=Types, Dates=Dates, rmdi=rmdi, $ + iobs=iobs, jobs=jobs, mstp=mstp, quiet=quiet, track=track +;+----------------------------------------------------------- +;IDL program to read in netcdf files of altimeter data. +; +;Author: D. J. Lea - Feb 2008 +; +;------------------------------------------------------------ +rmdi = -99999. +NumFiles=n_elements(Files) +;RefDate = '1950-01-01' +;!DATE_SEPARATOR='-' +RefDate=JULDAY(1,1,1950,0,0) ; should be at 0 UTC + +ifile2=0 +for ifile = 0, NumFiles-1 do begin +;------------------------------------------------------------ +;1. Open the file containing the data + ncid = ncdf_open(Files(ifile), /nowrite) + if ncid lt 0 and not keyword_set(quiet) then print, 'Error opening file '+Files(ifile) + if ncid ge 0 then begin + if not keyword_set(quiet) then print, 'Opened file '+Files(ifile)+' successfully' + +;------------------------------------------------------------ +;2. Read in the dimensions in the file + ncinfo = ncdf_inquire(ncid) +; var = ncdf_varinq( ncid, "SLA" ) + if not keyword_set(quiet) then print,'ncinfo.ndims ',ncinfo.ndims + ncdf_diminq, ncid, 0, name, NData + NData2=0 + cycles=1 + if (ncinfo.ndims gt 2) then ncdf_diminq, ncid, 2, name, NData2 + if (ncinfo.ndims gt 1) then ncdf_diminq, ncid, 1, name, cycles + + + if not keyword_set(quiet) then print,NData, NData2 + + NData=max([NData*cycles, NData2*cycles]) + +; print,NData, NData2 + + if (NData gt 0) then begin +;------------------------------------------------------------ +;3. Allocate the data arrays and read in the data + lons = dblarr(NData) + lats = dblarr(NData) + obsval = fltarr(NData) + modval = fltarr(NData) + mdtval = fltarr(NData) + bytQC = bytarr(NData) + QC = fltarr(NData) + Dats = dblarr(NData) + trackval = intarr(NData) + Sats = intarr(NData) + strSats= strarr(NData) + StrVal = strarr(8) +; dts = replicate(!dt_base, NData) + dts = dblarr(NData) + +; info,lons + varid = ncdf_varid(ncid, 'LONGITUDE') + scale_factor=1. + if (varid eq -1) then begin + varid = ncdf_varid(ncid, 'Longitudes') + if (varid eq -1) then begin + varid = ncdf_varid(ncid, 'longitude') + endif + ncdf_attget, ncid, varid, 'scale_factor', scale_factor + endif + ncdf_varget, ncid, varid, lons + lons=lons*scale_factor +; info, lons + if (cycles gt 1) then begin + lonsn=lons + for i=1,cycles-1 do begin + lonsn=[lonsn,lons] + endfor + lons=lonsn + endif + +; info, lons + +; info,lats + varid = ncdf_varid(ncid, 'LATITUDE') + scale_factor=1. + if (varid eq -1) then begin + varid = ncdf_varid(ncid, 'Latitudes') + if (varid eq -1) then begin + varid = ncdf_varid(ncid, 'latitude') + endif + ncdf_attget, ncid, varid, 'scale_factor', scale_factor + endif + ncdf_varget, ncid, varid, lats + lats=lats*scale_factor +; info, lats + if (cycles gt 1) then begin + latsn=lats + for i=1,cycles-1 do begin + latsn=[latsn,lats] + endfor + lats=latsn + endif + +; info, lats + + varid = ncdf_varid(ncid, 'JULD') + if (varid eq -1) then begin + varid = ncdf_varid(ncid, 'time') + endif + if (varid ne -1) then begin + ncdf_varget, ncid, varid, Dats + endif else begin + varid = ncdf_varid(ncid, 'BeginDates') + ncdf_varget, ncid, varid, Bds +; print,bds +; info, bds + if (cycles gt 1) then begin + bds=transpose(bds) + endif + varid = ncdf_varid(ncid, 'NbPoints') + ncdf_varget, ncid, varid, nbpoints + +; Read in dataindexes and deltat in cls format file +; These are used to adjust dates + varid = ncdf_varid(ncid, 'DeltaT') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, deltat + ncdf_attget, ncid, varid, 'scale_factor', scale_factor + deltat=deltat*scale_factor + varid = ncdf_varid(ncid, 'DataIndexes') + ncdf_varget, ncid, varid, dataindexes + + endif + + print, 'deltat ',deltat +; print, 'dataindexes ',dataindexes + +; info, nbpoints +; print,nbpoints +; info, cycles + cumbds=[0] + nbpointst=nbpoints + dataindexest=dataindexes + for i=1,cycles-1 do begin + nbpointst=[nbpointst,nbpoints] + dataindexest=[dataindexest,dataindexes] + endfor + cumbds=[0,total(nbpointst,/cumulative)] +; if not keyword_set(quiet) then print,'cumbds ',cumbds + nel=n_elements(Bds) +; info,nel +; if not keyword_set(quiet) then print,n_elements(dats) + for i=0,nel-1 do begin +; print,'*',i, cumbds(i+1)-cumbds(i) +; print,i,cumbds(i),cumbds(i+1)-1 + dats(cumbds(i):cumbds(i+1)-1)=bds(i) + trackval(cumbds(i):cumbds(i+1)-1)=i + dataindexest(cumbds(i):cumbds(i+1)-1)=dataindexest(cumbds(i):cumbds(i+1)-1)-dataindexest(cumbds(i)) + endfor + +; adjust dats based on dataindex + dats=dats+dataindexest*deltat/86400. + + +; print, dats + endelse + + + + dts=RefDate + Dats + + varid = ncdf_varid(ncid, 'MISSION') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, Sats + ncdf_attget, ncid, varid, 'Value_0', StrVal0 + ncdf_attget, ncid, varid, 'Value_1', StrVal1 + ncdf_attget, ncid, varid, 'Value_2', StrVal2 + ncdf_attget, ncid, varid, 'Value_3', StrVal3 + ncdf_attget, ncid, varid, 'Value_4', StrVal4 + ncdf_attget, ncid, varid, 'Value_5', StrVal5 + ncdf_attget, ncid, varid, 'Value_6', StrVal6 + ncdf_attget, ncid, varid, 'Value_7', StrVal7 + StrVal=[StrVal0, StrVal1, StrVal2, StrVal3, StrVal4, $ + StrVal5, StrVal6, StrVal7] + for ival = 0, 7 do begin + pts = where(Sats eq ival, count) + if count gt 0 then strSats(pts) = StrVal(ival) + endfor + endif + + varid = ncdf_varid(ncid, 'SLA') + ncdf_varget, ncid, varid, obsval + ncdf_attget, ncid, varid, '_FillValue', FillValue + scale_factor=1. + add_offset=0. + ;if (ncinfo.ndims gt 2) then ncdf_attget, ncid, varid, 'scale_factor', scale_factor + ncviq=ncdf_varinq(ncid, varid) + for iatt=0,ncviq.natts-1 do begin + ncaiq=ncdf_attname(ncid, varid, iatt) + if ( ncaiq eq 'scale_factor') then ncdf_attget, ncid, varid, 'scale_factor', scale_factor + if ( ncaiq eq 'add_factor') then ncdf_attget, ncid, varid, 'add_factor', add_factor + endfor + + if not keyword_set(quiet) then print,'SLA scale factor: ',scale_factor + if not keyword_set(quiet) then print,'SLA add offset: ',add_offset + if not keyword_set(quiet) then print,'SLA FillValue: ',FillValue + pts = where(obsval eq FillValue, count) +; if not keyword_set(quiet) then print,count + obsval=obsval*scale_factor+add_offset + if count gt 0 then obsval(pts) = rmdi + + varid = ncdf_varid(ncid, 'SLA_Hx') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, modval + ncdf_attget, ncid, varid, '_FillValue', FillValue +; if not keyword_set(quiet) then print,'SLA_Hx FillValue ',FillValue + pts = where(modval eq FillValue or modval eq -9999.0, count) +; if not keyword_set(quiet) then print,count + if count gt 0 then modval(pts) = rmdi + endif + + varid = ncdf_varid(ncid, 'SLA_QC') + if (varid ne -1) then begin + ncdf_varget, ncid, varid, bytQC + ncdf_attget, ncid, varid, '_FillValue', FillValue + QC(*) = 0. + pts = where(bytQC eq FillValue, count) + if count gt 0 then QC(pts) = rmdi + pts = where(bytQC ne 48, count) + if count gt 0 then QC(pts) = 1. + endif + + varid = ncdf_varid(ncid, 'MDT') + if (varid ne -1) then ncdf_varget, ncid, varid, mdtval + + varid = ncdf_varid(ncid, 'data_source') + if varid ne -1 then begin + ncdf_varget, ncid, varid, obstyp + endif else begin + varid = ncdf_varid(ncid, 'MISSION') + if varid ne -1 then ncdf_varget, ncid, varid, obstyp + endelse + +; reads in multi cycle data the wrong way round! + if (cycles gt 1) then begin + obsval=reform(obsval,[cycles,ndata/cycles]) + obsval=transpose(obsval) + modval=reform(modval,[cycles,ndata/cycles]) + modval=transpose(modval) + QC=reform(QC,[cycles,ndata/cycles]) + QC=transpose(QC) + endif + + varid = ncdf_varid(ncid, 'IOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, iobsval + + varid = ncdf_varid(ncid, 'JOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, jobsval + + varid = ncdf_varid(ncid, 'MSTP') + if (varid ne -1) then ncdf_varget, ncid, varid, mstpval + +; info, obssla +; info, obsval +; info, modsla +; info, modval + + if ifile2 eq 0 then begin + Latitudes = [float(lats)] + Longitudes = [float(lons)] + ObsSLA = [obsval(*)] + ModSLA = [modval(*)] + MDT = [mdtval] + SLAQC = [QC] + Dates = [dts] + Satellites = [strSats] + if (n_elements(obstyp) gt 0) then Types = [obstyp] + if (n_elements(iobsval) gt 0) then iobs = [iobsval] + if (n_elements(jobsval) gt 0) then jobs = [jobsval] + if (n_elements(mstpval) gt 0) then mstp = [mstpval] + if (n_elements(trackval) gt 0) then track = [trackval] + endif else begin + Latitudes = [Latitudes, float(lats)] + Longitudes = [Longitudes, float(lons)] + ObsSLA = [ObsSLA, obsval(*)] + ModSLA = [ModSLA, modval(*)] + MDT = [MDT, mdtval] + SLAQC = [SLAQC, QC] + Dates = [Dates, dts] + Satellites = [Satellites, strSats] + if (n_elements(obstyp) gt 0) then Types = [Types, obstyp] + if (n_elements(iobsval) gt 0) then iobs = [iobs, iobsval] + if (n_elements(jobsval) gt 0) then jobs = [jobs, jobsval] + if (n_elements(mstpval) gt 0) then mstp = [mstp, mstpval] + if (n_elements(trackval) gt 0) then tracks = [track, trackval] + endelse + +ifile2=ifile2+1 +endif + ncdf_close, ncid + +endif + +endfor ; ifile + +NumObs = n_elements(Latitudes) + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sst.pro b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sst.pro new file mode 100644 index 0000000000000000000000000000000000000000..6d7b6255c47170dcff0caa1c77968ed5445b87b7 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/dataplot/read_sst.pro @@ -0,0 +1,193 @@ +PRO read_sst, Files, NumObs=NumObs, $ + Latitudes=Latitudes, Longitudes=Longitudes, $ + ObsSST=ObsSST, ModSST=ModSST, SSTQC=SSTQC, $ + Dates=Dates, rmdi=rmdi, Types=Types, iobs=iobs, jobs=jobs, $ + quiet=quiet +;------------------------------------------------------------ +;IDL program to read in netcdf files of altimeter data. +; +;Author: D. J. Lea - Feb 2008 +; +;------------------------------------------------------------ +rmdi = -99999. +NumFiles=n_elements(Files) +;print,NumFiles +;RefDate = '1950-01-01' +;!DATE_SEPARATOR='-' +RefDate=JULDAY(1,1,1950,0,0) ; should be at 0 UTC +ifile2=0 +for ifile = 0, NumFiles-1 do begin +;------------------------------------------------------------ +;1. Open the file containing the data + ncid = ncdf_open(Files(ifile), /nowrite) + if ncid lt 0 and not keyword_set(quiet) then print, 'Error opening file '+Files(ifile) + if ncid ge 0 then begin + if not keyword_set(quiet) then print, 'Opened file '+Files(ifile)+' successfully' + +;------------------------------------------------------------ +;2. Read in the dimensions in the file + ncinfo = ncdf_inquire(ncid) + + if ncinfo.Ndims eq 1 then begin + ncdf_diminq, ncid, 0, name, NData + endif else if ncinfo.Ndims eq 2 then begin + ncdf_diminq, ncid, 1, name, NData + if (name eq "string8") then ncdf_diminq, ncid, 0, name, NData + endif else if ncinfo.Ndims eq 3 then begin + ncdf_diminq, ncid, 1, name, NLats + ncdf_diminq, ncid, 2, name, NLons + NData = NLats * NLons + endif + + if not keyword_set(quiet) then print, 'Number of SST data points ',NData + + if (NData gt 0) then begin +;------------------------------------------------------------ +;3. Allocate the data arrays and read in the data + lons = dblarr(NData) + lats = dblarr(NData) + obsval = fltarr(NData) + modval = fltarr(NData) + bytQC = bytarr(NData) + QC = fltarr(NData) + obstyp = intarr(NData) + Dats = dblarr(NData) + dts = replicate(!dt_base, NData) + iobsa = intarr(NData) + jobsa = intarr(NData) + + varid = ncdf_varid(ncid, 'LONGITUDE') + if varid ne -1 then ncdf_varget, ncid, varid, lons $ + else begin + varid = ncdf_varid(ncid, 'lon') + ncdf_varget, ncid, varid, lons + endelse + + varid = ncdf_varid(ncid, 'LATITUDE') + if varid ne -1 then ncdf_varget, ncid, varid, lats $ + else begin + varid = ncdf_varid(ncid, 'lat') + ncdf_varget, ncid, varid, lats + endelse + + varid = ncdf_varid(ncid, 'JULD') + if varid ne -1 then begin + ncdf_varget, ncid, varid, Dats + dts=RefDate + Dats + + endif else begin + varid = ncdf_varid(ncid, 'time') + ncdf_varget, ncid, varid, secs_from_base + varid = ncdf_varid(ncid, 'sst_dtime') + ncdf_varget, ncid, varid, dtime + ncdf_attget, ncid, varid, 'scale_factor', scale_factor + dtime=dtime*scale_factor +; RefDate = '1981-01-01' + RefDate = JULDAY(1,1,1981,0,0) ; should be ref from 0 UTC + dtime = dtime + secs_from_base + dts = RefDate + dtime/86400. + endelse + + varid = ncdf_varid(ncid, 'SST') + if varid ne -1 then begin + ncdf_varget, ncid, varid, obsval + obsval=float(obsval) ;ensure obsval is a floating point array + ncdf_attget, ncid, varid, '_FillValue', FillValue + pts = where(obsval eq FillValue, count) + if count gt 0 then obsval(pts) = rmdi + endif else begin + varid = ncdf_varid(ncid, 'sea_surface_temperature') + ncdf_varget, ncid, varid, obsval + obsval=float(obsval) ;ensure obsval is a floating point array + ncdf_attget, ncid, varid, '_FillValue', FillValue + ncdf_attget, ncid, varid, 'add_offset', Offset + ncdf_attget, ncid, varid, 'scale_factor', Scale + pts = where(obsval ne FillValue, count) + if count gt 0 then obsval(pts) = Offset + (obsval(pts) *Scale) + pts = where(obsval eq FillValue, count) + if count gt 0 then obsval(pts) = rmdi + endelse + + varid = ncdf_varid(ncid, 'SST_Hx') + if varid ne -1 then begin + ncdf_varget, ncid, varid, modval + ncdf_attget, ncid, varid, '_FillValue', FillValue + pts = where(modval eq FillValue, count) + if count gt 0 then modval(pts) = rmdi + endif + + varid = ncdf_varid(ncid, 'SST_QC') + if varid ne -1 then begin + ncdf_varget, ncid, varid, bytQC + ncdf_attget, ncid, varid, '_FillValue', FillValue + QC(*) = 0. + pts = where(bytQC eq FillValue, count) + if count gt 0 then QC(pts) = rmdi + pts = where(bytQC ne 48, count) + if count gt 0 then QC(pts) = bytQC(pts)-48 + endif else begin + varid = ncdf_varid(ncid, 'confidence_flag') + ncdf_varget, ncid, varid, bytQC + QC = float(bytQC) + endelse + + varid = ncdf_varid(ncid, 'SST_DATA_SOURCE') + if varid ne -1 then ncdf_varget, ncid, varid, obstyp $ + else begin + varid = ncdf_varid(ncid, 'data_source') + if varid ne -1 then ncdf_varget, ncid, varid, obstyp + endelse + + varid = ncdf_varid(ncid, 'callsign') + if varid ne -1 then begin + ncdf_varget, ncid, varid, callsign + tmp=strtrim(string(obstyp),2)+' '+strtrim(string(callsign),2) + obstyp=tmp + endif else begin + varid = ncdf_varid(ncid, 'SST_CALL_SIGN') + if varid ne -1 then begin + ncdf_varget, ncid, varid, callsign + tmp=strtrim(string(obstyp),2)+' '+strtrim(string(callsign),2) + obstyp=tmp + endif + endelse + + varid = ncdf_varid(ncid, 'IOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, iobsa + + varid = ncdf_varid(ncid, 'JOBS') + if (varid ne -1) then ncdf_varget, ncid, varid, jobsa + + if ifile2 eq 0 then begin + Latitudes = [float(lats)] + Longitudes = [float(lons)] + ObsSST = [obsval] + ModSST = [modval] + SSTQC = [QC] + Dates = [dts] + Types = [obstyp] + iobs = [iobsa] + jobs = [jobsa] + endif else begin + Latitudes = [Latitudes, float(lats)] + Longitudes = [Longitudes, float(lons)] + ObsSST = [ObsSST, obsval] + ModSST = [ModSST, modval] + SSTQC = [SSTQC, QC] + Dates = [Dates, dts] + Types = [Types, obstyp] + iobs = [iobs, iobsa] + jobs = [jobs, jobsa] + endelse + + ifile2=ifile2+1 + endif + ncdf_close, ncid + + endif + +endfor ; ifile + +NumObs = n_elements(Latitudes) + +END diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/python/increments_gen.py b/V4.0/nemo_sources/tools/OBSTOOLS/python/increments_gen.py new file mode 100644 index 0000000000000000000000000000000000000000..de9d8e19a1f554e135d7c03a1865e5be5b15f55b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/python/increments_gen.py @@ -0,0 +1,93 @@ +''' +Generate a test increments file +and the SlaReference file + +Requires coordinates and depth file + +D. J. Lea Sep 2014 +''' + +import netCDF4 +import numpy as np + +# example files to get lon and lat +exdir='/hpc/data/nwp/ofrd/frld/FORCING/ORCA2_LIM_nemo_v3.6' +exfile1='coordinates.nc' + +infile1=exdir+'/'+exfile1 +fileid=netCDF4.Dataset(infile1, mode='r') +nav_lon=fileid.variables['nav_lon'][:,:] +nav_lat=fileid.variables['nav_lat'][:,:] +fileid.close + +print np.shape(nav_lon) + +exfile2='data_1m_potential_temperature_nomask.nc' +infile2=exdir+'/'+exfile2 +fileid=netCDF4.Dataset(infile2, mode='r') +nav_lev=fileid.variables['depth'][:] +fileid.close() + +nshp=np.shape(nav_lon) +ny=nshp[0] +nx=nshp[1] +nz=np.size(nav_lev) +nt=1 + +#create a new file +outdir='.' +outfile='assim_background_increments_test.nc' + +print "creating: ",outfile +ncfile=netCDF4.Dataset(outdir+'/'+outfile, mode='w', format='NETCDF3_CLASSIC') +ncfile.createDimension('x',nx) +ncfile.createDimension('y',ny) +ncfile.createDimension('z',nz) +ncfile.createDimension('t',size=0) +ncnav_lat = ncfile.createVariable('nav_lat','f4',('y','x')) +ncnav_lat[:,:]=nav_lat +ncnav_lon = ncfile.createVariable('nav_lon','f4',('y','x')) +ncnav_lon[:,:]=nav_lon +ncnav_lev = ncfile.createVariable('nav_lev','f4',('z')) +ncnav_lev[:]=nav_lev +ncvar = ncfile.createVariable('bckineta','f8',('t','y','x')) +ncvar[0,:,:]=0.1 +ncvar = ncfile.createVariable('bckins','f8',('t','z','y','x')) +ncvar[0,:,:,:]=0.1 +ncvar = ncfile.createVariable('bckint','f8',('t','z','y','x')) +ncvar[0,:,:,:]=0.1 +ncvar = ncfile.createVariable('bckinu','f8',('t','z','y','x')) +ncvar[0,:,:,:]=0.1 +ncvar = ncfile.createVariable('bckinv','f8',('t','z','y','x')) +ncvar[0,:,:,:]=0.1 +ncvar = ncfile.createVariable('bckinseaice','f8',('t','y','x')) +ncvar[0,:,:]=0.1 +ncvar = ncfile.createVariable('bckinsshobias','f8',('t','y','x')) +ncvar[0,:,:]=0.1 +ncvar = ncfile.createVariable('time_counter','f8',('t')) +ncvar[0]=0 +ncvar = ncfile.createVariable('time','f8') +ncvar[:]=10101 +ncvar = ncfile.createVariable('z_inc_dateb','f8') +ncvar[:]=10101 +ncvar = ncfile.createVariable('z_inc_datef','f8') +ncvar[:]=10102 + + +ncfile.close() + +#create sla reference file +outfile='slaReferenceLevel_test.nc' + +print "creating: ",outfile +ncfile=netCDF4.Dataset(outdir+'/'+outfile, mode='w', format='NETCDF3_CLASSIC') +ncfile.createDimension('x',nx) +ncfile.createDimension('y',ny) +ncnav_lat = ncfile.createVariable('nav_lat','f4',('y','x')) +ncnav_lat[:,:]=nav_lat +ncnav_lon = ncfile.createVariable('nav_lon','f4',('y','x')) +ncnav_lon[:,:]=nav_lon +ncvar = ncfile.createVariable('sossheig','f4',('y','x'),fill_value=1e20) +ncvar[:,:]=0.01 + +ncfile.close() diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/c4comb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/c4comb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bc4124938cdfb0da782e8f6e5c5a04b826bdb73d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/c4comb.F90 @@ -0,0 +1,702 @@ +PROGRAM c4comb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM c4comb ** + !! + !! ** Purpose : Combine MPI decomposed class4 files into one file + !! + !! ** Method : Use of utilities from obs_utils, ooo_utils. + !! + !! ** Action : + !! + !! Usage: + !! c4comb.exe outputfile inputfile1 inputfile2 ... + !! + !! History : + !!---------------------------------------------------------------------- + USE netcdf + USE obs_const + USE obs_utils + USE ooo_utils, ONLY: date_format, obfilldbl + USE toolspar_kind + IMPLICIT NONE + !! Command line setup +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs, & !: number of command line arguments + & ia, & !: argument loop index + & ninfiles !: number of input files + !! Routine arguments + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + !! Routine variables + CHARACTER(len=80) :: cpname + INTEGER,PARAMETER :: nstr=8, n128=128 + INTEGER :: ncid, & !: netcdf file id + & dimid, & !: netcdf dimension id + & dpdim, & !: netcdf dimension ids + & fcdim, & + & vrdim, & + & obdim, & + & stdim, & + & sxdim, & + & fdvid, & !: netcdf variable ids + & lonid, & + & latid, & + & depid, & + & varid, & + & unitid, & + & obvid, & + & fcvid, & + & prvid, & + & clvid, & + & dm2id, & + & dm1id, & + & mdtid, & + & altid, & + & qcvid, & + & jdvid, & + & mjdid, & + & typid, & + & idvid, & + & ndeps, & !: number depths + & nfcst, & !: number forecast + & nvars, & !: number variables + & nobs, & !: number obs + & sdeps, & + & sobs, & + & l_dex, & + & u_dex + + INTEGER :: iob, idep, istat + INTEGER, DIMENSION(2) :: dim2a, dim2b, dim2c, dim2d + INTEGER, DIMENSION(3) :: dim3a + INTEGER, DIMENSION(4) :: dim4a + INTEGER, ALLOCATABLE, DIMENSION(:) :: fcday + REAL(wp), ALLOCATABLE, DIMENSION(:) :: modjd + !: Global Attributes + CHARACTER(len=40) :: nam_str, & + & version, & + & contact, & + & sys_str, & + & cfg_str, & + & ins_str, & + & val_str, & + & dat_str, & + & obs_str + !: Variable Attributes + CHARACTER(len=100) :: lon_units, & + & lat_units, & + & dep_units, & + & jul_units, & + & mjd_units, & + & fcd_units, & + & lead_comment, & + & fcst_comment, & + & per_comment, & + & cli_comment, & + & dm2_comment, & + & dm1_comment + CHARACTER(len=128) :: qc_comment, & + & qc_flag_meaning + INTEGER, DIMENSION(2) :: qc_flag_value + + !: Global Arrays + REAL(wp), ALLOCATABLE, DIMENSION(:) :: g_lam, & + & g_phi, & + & gjuld + CHARACTER(len=n128),ALLOCATABLE,DIMENSION(:) :: gtype + CHARACTER(len=nstr),ALLOCATABLE,DIMENSION(:) :: & + & g_id, & + & gvnam, & + & gunit + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: g_dep + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: g3dob, & + & g3dcl, & + & g3mdt, & + & g3alt, & + & g3dm2, & + & g3dm1 + INTEGER(ik), ALLOCATABLE, DIMENSION(:,:,:) :: g3dqc + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: g3dmc, & + & g3dpr + !: Small Arrays + REAL(wp), ALLOCATABLE, DIMENSION(:) :: s_lam, & + & s_phi, & + & sjuld + + CHARACTER(len=n128),ALLOCATABLE,DIMENSION(:) :: stype + CHARACTER(len=nstr),ALLOCATABLE,DIMENSION(:) :: & + & s_id + + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: s_dep + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: s3dob, & + & s3dcl, & + & s3mdt, & + & s3alt, & + & s3dm2, & + & s3dm1 + INTEGER(ik), ALLOCATABLE, DIMENSION(:,:,:) :: s3dqc + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: s3dmc, & + & s3dpr + + !: File creation logical + LOGICAL :: ln_cre + + !: Optional variable logicals + LOGICAL :: ln_init, & + & ln_mdt, & + & ln_altbias, & + & ln_best + !! Command name + cpname='c4comb.exe' + + !! Process command line + nargs = IARGC() + IF (nargs /= 2) THEN + WRITE(*, *) "Usage: c4comb.exe outputfile inputfile1 inputfile2 ..." + CALL abort() + END IF + CALL GETARG(1, cdoutfile) + + !! Process input files + !! Set output file creation to off + ln_cre = .false. + + !! Turn optional variables off + ln_init = .false. + ln_best = .false. + ln_altbias = .false. + ln_mdt = .false. + + !! Compute size of output file + nobs = 0 + ndeps= 0 + ALLOCATE( cdinfile( nargs - 1 ) ) + ninfiles = nargs - 1 + DO ia = 1, ninfiles + CALL GETARG(ia+1, cdinfile(ia)) + WRITE(*,*) "Opening : ", TRIM(cdinfile(ia)) + !! Open Netcdf file + istat = nf90_open(TRIM(cdinfile(ia)),nf90_nowrite,ncid) + IF (istat == nf90_noerr) THEN + !! Turn output file creation on + ln_cre = .true. + !! Get Dimensions + CALL chkerr( nf90_inq_dimid(ncid, 'numobs', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=sobs ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numdeps', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=sdeps ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numfcsts',dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=nfcst ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numvars', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=nvars ), cpname, __LINE__ ) + !! Close Netcdf file + CALL chkerr( nf90_close(ncid), cpname, __LINE__ ) + !! Report on file contents + WRITE(*,'(2A)')'File = ', TRIM(cdinfile(ia)) + WRITE(*,'(A,I9,A)')'has', sobs, ' observations' + !! Increment size + nobs = nobs + sobs !: Accumulate number of profiles + ndeps = MAX(ndeps, sdeps) !: Define maximum number of levels needed + END IF ! istat + END DO + + !! Allocate global arrays + ALLOCATE( g_phi(nobs), & + & g_lam(nobs), & + & g_dep(ndeps, nobs), & + & g3dob(ndeps, nvars, nobs), & + & g3dmc(ndeps, nfcst, nvars, nobs), & + & g3dpr(ndeps, nfcst, nvars, nobs), & + & g3dcl(ndeps, nvars, nobs), & + & g3dm2(ndeps, nvars, nobs), & + & g3dm1(ndeps, nvars, nobs), & + & g3mdt(ndeps, nvars, nobs), & + & g3alt(ndeps, nvars, nobs), & + & g3dqc(ndeps, nvars, nobs), & + & gjuld(nobs), & + & gtype(nobs), & + & g_id(nobs), & + & gvnam(nvars), & + & gunit(nvars) ) + ALLOCATE(fcday(nfcst), modjd(nfcst)) + + !! Fill with missing data value + g_dep(:,:) = 99999. + g3dmc(:,:,:,:) = 99999. + g3dpr(:,:,:,:) = 99999. + g3dob(:,:,:) = 99999. + g3dcl(:,:,:) = 99999. + g3dm2(:,:,:) = 99999. + g3dm1(:,:,:) = 99999. + g3mdt(:,:,:) = 99999. + g3alt(:,:,:) = 99999. + g3dqc(:,:,:) = NF90_FILL_SHORT + + !! Read in each file + ! initialise global matrix indices + l_dex = 0 + u_dex = 0 + + !! initialise Global attribute strings + nam_str = '' + version = '' + contact = '' + sys_str = '' + cfg_str = '' + ins_str = '' + val_str = '' + dat_str = '' + obs_str = '' + + !! initialise Variable attribute strings + fcd_units = '' + lon_units = '' + lat_units = '' + dep_units = '' + jul_units = '' + mjd_units = '' + lead_comment = '' + fcst_comment = '' + per_comment = '' + cli_comment = '' + dm2_comment = '' + dm1_comment = '' + qc_comment = '' + qc_flag_meaning = '' + + DO ia = 1, ninfiles + WRITE(*,*) "Opening : ", TRIM(cdinfile(ia)) + !! Open Netcdf file + istat = nf90_open(TRIM(cdinfile(ia)),nf90_nowrite,ncid) + IF (istat == nf90_noerr) THEN + !! Get Global Attributes + CALL chkerr( nf90_get_att(ncid, nf90_global,'title', nam_str),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'version', version),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'contact', contact),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'obs_type', obs_str),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'system', sys_str),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'configuration', cfg_str),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'institution', ins_str),cpname, __LINE__) + CALL chkerr( nf90_get_att(ncid, nf90_global,'validity_time', val_str),cpname, __LINE__) + !! Get Dimensions of single file + CALL chkerr( nf90_inq_dimid(ncid, 'numdeps', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=sdeps ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numfcsts',dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=nfcst ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numvars', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=nvars ), cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(ncid, 'numobs', dimid), cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension(ncid, dimid, len=sobs ), cpname, __LINE__ ) + !! Check for Optional variables in first file + IF (ia == 1) THEN + !! Best estimate + istat = nf90_inq_varid(ncid,'best_estimate',dm2id) + IF (istat == nf90_noerr) THEN + ln_best = .TRUE. + ENDIF + !! nrt_analysis + istat = nf90_inq_varid(ncid,'nrt_analysis',dm1id) + IF (istat == nf90_noerr) THEN + ln_init = .TRUE. + ENDIF + !! Mean Dynamic Topography + istat = nf90_inq_varid(ncid,'mdt_reference',mdtid) + IF (istat == nf90_noerr) THEN + ln_mdt = .TRUE. + ENDIF + !! Altimeter bias + istat = nf90_inq_varid(ncid,'altimeter_bias',altid) + IF (istat == nf90_noerr) THEN + ln_altbias = .TRUE. + ENDIF + END IF + WRITE(*,*) TRIM(cdinfile(ia)), " contains ", sobs, " observations" + WRITE(*,*) TRIM(cdinfile(ia)), " contains ", sdeps, " depths" + WRITE(*,*) TRIM(cdinfile(ia)), " contains ", nfcst, " forecasts" + WRITE(*,*) TRIM(cdinfile(ia)), " contains ", nvars, " vars" + !! Read Variables + IF (sobs /= 0) THEN + !! Get Variable ids + CALL chkerr(nf90_inq_varid(ncid,'leadtime', fdvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'longitude', lonid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'latitude', latid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'depth', depid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'varname', varid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'unitname', unitid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'observation', obvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'forecast', fcvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'persistence', prvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'climatology', clvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'qc', qcvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'juld', jdvid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'modeljuld', mjdid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'type', typid) ,cpname, __LINE__ ) + CALL chkerr(nf90_inq_varid(ncid,'id', idvid) ,cpname, __LINE__ ) + !! Get variable attributes + CALL chkerr(nf90_get_att(ncid, fdvid, 'units', fcd_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, lonid, 'units', lon_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, latid, 'units', lat_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, depid, 'units', dep_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, jdvid, 'units', jul_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, mjdid, 'units', mjd_units) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, fcvid, 'comment', fcst_comment) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, prvid, 'comment', per_comment) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, clvid, 'comment', cli_comment) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, fdvid, 'comment', lead_comment) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, qcvid, 'comment', qc_comment) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, qcvid, 'flag_value', qc_flag_value) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, qcvid, 'flag_meaning', qc_flag_meaning) ,cpname, __LINE__ ) + !! Optional variables + IF (ln_best) THEN + CALL chkerr(nf90_inq_varid(ncid,'best_estimate',dm2id) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, dm2id, 'comment', dm2_comment) ,cpname, __LINE__ ) + ENDIF + IF (ln_init) THEN + CALL chkerr(nf90_inq_varid(ncid,'nrt_analysis', dm1id) ,cpname, __LINE__ ) + CALL chkerr(nf90_get_att(ncid, dm1id, 'comment', dm1_comment) ,cpname, __LINE__ ) + ENDIF + IF (ln_mdt) THEN + CALL chkerr(nf90_inq_varid(ncid,'mdt_reference', mdtid) ,cpname, __LINE__ ) + ENDIF + IF (ln_altbias) THEN + CALL chkerr(nf90_inq_varid(ncid,'altimeter_bias', altid) ,cpname, __LINE__ ) + ENDIF + + !! Allocate small arrays + ALLOCATE( s_lam(sobs), s_phi(sobs), s_dep(sdeps, sobs), & + & s3dob(sdeps, nvars, sobs), & !: observations + & s3dmc(sdeps, nfcst, nvars, sobs), & !: model data + & s3dpr(sdeps, nfcst, nvars, sobs), & !: persistence + & s3dcl(sdeps, nvars, sobs), & !: climatology + & s3dm2(sdeps, nvars, sobs), & !: best estimate + & s3dm1(sdeps, nvars, sobs), & !: nrt_analysis + & s3mdt(sdeps, nvars, sobs), & !: mdt + & s3alt(sdeps, nvars, sobs), & !: altbias + & s3dqc(sdeps, nvars, sobs), & !: QC + & sjuld(sobs), stype( sobs), & + & s_id(sobs) ) + !! Fill with missing data value + s3dmc(:,:,:,:) = 99999. + s3dpr(:,:,:,:) = 99999. + s3dob(:,:,:) = 99999. + s3dcl(:,:,:) = 99999. + s3dm2(:,:,:) = 99999. + s3dm1(:,:,:) = 99999. + s3mdt(:,:,:) = 99999. + s3alt(:,:,:) = 99999. + s3dqc(:,:,:) = NF90_FILL_SHORT + + !! Read variables into small arrays + CALL chkerr( nf90_get_var(ncid, fdvid, fcday), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, lonid, s_lam), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, latid, s_phi), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, depid, s_dep), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, obvid, s3dob), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, fcvid, s3dmc), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, prvid, s3dpr), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, clvid, s3dcl), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, qcvid, s3dqc), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, jdvid, sjuld), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, mjdid, modjd), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, typid, stype), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, idvid, s_id), cpname, __LINE__ ) + !! Read unitname and varname into global arrays + CALL chkerr( nf90_get_var(ncid, varid, gvnam), cpname, __LINE__ ) + CALL chkerr( nf90_get_var(ncid, unitid,gunit), cpname, __LINE__ ) + !! Optional variables read + IF (ln_best) THEN + CALL chkerr( nf90_get_var(ncid, dm2id, s3dm2), cpname, __LINE__ ) + ENDIF + IF (ln_init) THEN + CALL chkerr( nf90_get_var(ncid, dm1id, s3dm1), cpname, __LINE__ ) + ENDIF + IF (ln_mdt) THEN + CALL chkerr( nf90_get_var(ncid, mdtid, s3mdt), cpname, __LINE__ ) + ENDIF + IF (ln_altbias) THEN + CALL chkerr( nf90_get_var(ncid, altid, s3alt), cpname, __LINE__ ) + ENDIF + + !! Fill Global arrays + ! increment numobs indices + l_dex = u_dex + 1 + u_dex = l_dex + sobs -1 + + g_lam(l_dex:u_dex) = s_lam(:) + g_phi(l_dex:u_dex) = s_phi(:) + g_dep(1:sdeps, l_dex:u_dex) = s_dep(1:sdeps,:) + g3dob(1:sdeps,1:nvars,l_dex:u_dex) = s3dob(1:sdeps,1:nvars,:) + g3dmc(1:sdeps,1:nfcst,1:nvars,l_dex:u_dex) = s3dmc(1:sdeps,1:nfcst,1:nvars,:) + g3dpr(1:sdeps,1:nfcst,1:nvars,l_dex:u_dex) = s3dpr(1:sdeps,1:nfcst,1:nvars,:) + g3dcl(1:sdeps,1:nvars,l_dex:u_dex) = s3dcl(1:sdeps,1:nvars,:) + g3dm2(1:sdeps,1:nvars,l_dex:u_dex) = s3dm2(1:sdeps,1:nvars,:) + g3dm1(1:sdeps,1:nvars,l_dex:u_dex) = s3dm1(1:sdeps,1:nvars,:) + g3mdt(1:sdeps,1:nvars,l_dex:u_dex) = s3mdt(1:sdeps,1:nvars,:) + g3alt(1:sdeps,1:nvars,l_dex:u_dex) = s3alt(1:sdeps,1:nvars,:) + g3dqc(1:sdeps,1:nvars,l_dex:u_dex) = s3dqc(1:sdeps,1:nvars,:) + gjuld(l_dex:u_dex) = sjuld(:) + gtype(l_dex:u_dex) = stype(:) + g_id(l_dex:u_dex) = s_id(:) + + !! Deallocate small array + DEALLOCATE( s_lam, s_phi, s_dep, s3dob, s3dmc, s3dpr, s3dcl, s3dqc, s3dm2, s3dm1, s3mdt, s3alt, sjuld, stype, s_id) + ENDIF ! sobs + !! Close Netcdf file + CALL chkerr( nf90_close(ncid), cpname, __LINE__ ) + END IF ! istat + END DO + + !! Create Output file + IF (ln_cre) THEN + WRITE(*,*) 'Create the output file, ',trim(cdoutfile) + CALL chkerr( nf90_create(trim(cdoutfile),nf90_clobber,ncid), cpname, __LINE__ ) + !! Put Global Attributes + CALL date_format(dat_str) + CALL chkerr( nf90_put_att(ncid, nf90_global,'title', trim(nam_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'version', trim(version)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'creation_date', trim(dat_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'contact', trim(contact)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'obs_type', trim(obs_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'system', trim(sys_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'configuration', trim(cfg_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'institution', trim(ins_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'validity_time', trim(val_str)),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'best_estimate_description', & + & 'analysis produced 2 days behind real time'),cpname, __LINE__) + CALL chkerr( nf90_put_att(ncid, nf90_global,'time_interp', 'daily average fields'),cpname, __LINE__) + WRITE(*,*) 'Succesfully put global attributes ' + + !! Define Dimensions + CALL chkerr( nf90_def_dim(ncid, 'numdeps', ndeps, dpdim) ,cpname, __LINE__ ) + CALL chkerr( nf90_def_dim(ncid, 'numfcsts', nfcst, fcdim) ,cpname, __LINE__ ) + CALL chkerr( nf90_def_dim(ncid, 'numvars', nvars, vrdim) ,cpname, __LINE__ ) + CALL chkerr( nf90_def_dim(ncid, 'numobs', nobs, obdim) ,cpname, __LINE__ ) + CALL chkerr( nf90_def_dim(ncid, 'string_length8', nstr, stdim) ,cpname, __LINE__ ) + CALL chkerr( nf90_def_dim(ncid, 'string_length128', n128, sxdim) ,cpname, __LINE__ ) + WRITE(*,*) 'Succesfully defined dimensions' + + !! Define possible dimension permutations + ! 2d + dim2a(:) = (/ dpdim, obdim /) !: (/ ndeps, nobs /) + dim2b(:) = (/ stdim, obdim /) !: (/ nstr, nobs /) + dim2c(:) = (/ stdim, vrdim /) !: (/ nstr, nvars /) + dim2d(:) = (/ sxdim, obdim /) !: (/ nstr, nobs /) + ! 3d + dim3a(:) = (/ dpdim, vrdim, obdim/) !: (/ ndeps, nvars, nobs /) + ! 4d + dim4a(:) = (/ dpdim, fcdim, vrdim, obdim /) !: (/ ndeps, nfcst, nvars, nobs /) + + + !! Create the variables + ! Forecast day + CALL chkerr( nf90_def_var(ncid, 'leadtime', nf90_double, fcdim, fdvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fdvid, 'long_name', 'Model forecast day offset') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fdvid, 'units', trim(fcd_units)) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fdvid, 'comment', trim(lead_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'leadtime created' + ! longitude + CALL chkerr( nf90_def_var(ncid, 'longitude', nf90_float, obdim, lonid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, lonid, 'long_name', 'Longitudes') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, lonid, 'units', trim(lon_units)) ,cpname, __LINE__ ) + WRITE(*,*) 'lon created' + ! latitude + CALL chkerr( nf90_def_var(ncid, 'latitude', nf90_float, obdim, latid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, latid, 'long_name', 'Latitudes') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, latid, 'units', trim(lat_units)) ,cpname, __LINE__ ) + WRITE(*,*) 'lat created' + ! depth + CALL chkerr( nf90_def_var(ncid, 'depth', nf90_float, dim2a, depid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, depid, 'long_name', 'Depths') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, depid, 'units', trim(dep_units)) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, depid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + WRITE(*,*) 'dep created' + ! varname + CALL chkerr( nf90_def_var(ncid, 'varname', nf90_char, dim2c, varid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, varid, 'long_name', 'Variable name') ,cpname, __LINE__ ) + WRITE(*,*) 'varname created' + ! unitname + CALL chkerr( nf90_def_var(ncid, 'unitname', nf90_char, dim2c, unitid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, unitid, 'long_name', 'Unit name') ,cpname, __LINE__ ) + WRITE(*,*) 'unitname created' + ! obs + CALL chkerr( nf90_def_var(ncid, 'observation', nf90_float, dim3a, obvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, obvid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, obvid, 'long_name', 'Observation value') ,cpname, __LINE__ ) + WRITE(*,*) 'obs created' + ! forecast + CALL chkerr( nf90_def_var(ncid, 'forecast', nf90_float, dim4a, fcvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fcvid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fcvid, 'long_name', 'Model forecast counterpart of obs. value') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, fcvid, 'comment', trim(fcst_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'forecast created' + ! persistence + CALL chkerr( nf90_def_var(ncid, 'persistence', nf90_float, dim4a, prvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, prvid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, prvid, 'long_name', 'Model persistence counterpart of obs. value'),cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, prvid, 'comment', trim(per_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'persistence created' + ! clim + CALL chkerr( nf90_def_var(ncid, 'climatology', nf90_float, dim3a, clvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, clvid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, clvid, 'long_name', 'Climatological value') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, clvid, 'comment', trim(cli_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'clim created' + IF (ln_best) THEN + ! daym2 + CALL chkerr( nf90_def_var(ncid, 'best_estimate', nf90_float, dim3a, dm2id) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm2id, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm2id, 'long_name', 'Best estimate') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm2id, 'comment', trim(dm2_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'daym2 created' + ENDIF + IF (ln_init) THEN + ! daym1 + CALL chkerr( nf90_def_var(ncid, 'nrt_analysis', nf90_float, dim3a, dm1id) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm1id, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm1id, 'long_name', 'Near real time analysis') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, dm1id, 'comment', trim(dm1_comment)) ,cpname, __LINE__ ) + WRITE(*,*) 'daym1 created' + ENDIF + IF (ln_mdt) THEN + ! mdt + CALL chkerr( nf90_def_var(ncid, 'mdt_reference', nf90_float, dim3a, mdtid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, mdtid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, mdtid, 'long_name', 'Mean dynamic topography') ,cpname, __LINE__ ) + WRITE(*,*) 'mdt created' + ENDIF + IF (ln_altbias) THEN + ! altbias + CALL chkerr( nf90_def_var(ncid, 'altimeter_bias', nf90_float, dim3a, altid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, altid, '_FillValue',obfillflt) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, altid, 'long_name', 'Altimeter bias') ,cpname, __LINE__ ) + WRITE(*,*) 'altbias created' + ENDIF + ! qc + CALL chkerr( nf90_def_var(ncid, 'qc', nf90_short, dim3a, qcvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, qcvid, '_FillValue', NF90_FILL_SHORT) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, qcvid, 'long_name', 'Quality flags') ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, qcvid, 'flag_value', qc_flag_value) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, qcvid, 'flag_meaning', qc_flag_meaning) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, qcvid, 'comment', qc_comment) ,cpname, __LINE__ ) + WRITE(*,*) 'qc created' + ! juld + CALL chkerr( nf90_def_var(ncid, 'juld', nf90_double, obdim, jdvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, jdvid, '_FillValue',99999.) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, jdvid, 'long_name', 'Observation time in Julian days'),cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, jdvid, 'units', trim(jul_units)) ,cpname, __LINE__ ) + WRITE(*,*) 'juld created' + ! modeljuld + CALL chkerr( nf90_def_var(ncid, 'modeljuld', nf90_double, fcdim, mjdid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, mjdid, 'long_name', 'Model field date in Julian days'),cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, mjdid, 'units', trim(mjd_units)) ,cpname, __LINE__ ) + WRITE(*,*) 'modeljuld created' + ! type + CALL chkerr( nf90_def_var(ncid, 'type', nf90_char, dim2d, typid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, typid, 'long_name', 'Observation type') ,cpname, __LINE__ ) + WRITE(*,*) 'type created' + ! id + CALL chkerr( nf90_def_var(ncid, 'id', nf90_char, dim2b, idvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_att(ncid, idvid, 'long_name', 'Observation id') ,cpname, __LINE__ ) + WRITE(*,*) 'id created' + ! Close Netcdf file + CALL chkerr( nf90_close(ncid) ,cpname, __LINE__ ) + !! Fill in the variables + CALL chkerr( nf90_open(trim(cdoutfile),nf90_write,ncid), cpname, __LINE__ ) + WRITE(*,*) 'Create the variables ',trim(cdoutfile) + ! Forecast day + CALL chkerr( nf90_inq_varid(ncid, 'leadtime', fdvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, fdvid, fcday) ,cpname, __LINE__ ) + WRITE(*,*) 'forecast day put' + ! longitude + CALL chkerr( nf90_inq_varid(ncid, 'longitude', lonid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, lonid, g_lam) ,cpname, __LINE__ ) + WRITE(*,*) 'lon put' + ! latitude + CALL chkerr( nf90_inq_varid(ncid, 'latitude', latid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, latid, g_phi) ,cpname, __LINE__ ) + WRITE(*,*) 'lat put' + ! depth + CALL chkerr( nf90_inq_varid(ncid, 'depth',depid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, depid, g_dep) ,cpname, __LINE__ ) + WRITE(*,*) 'dep put' + ! varname + CALL chkerr( nf90_inq_varid(ncid, 'varname', varid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, varid, gvnam,(/1,1/), (/nstr,nvars/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'var put' + ! unitname + CALL chkerr( nf90_inq_varid(ncid, 'unitname',unitid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, unitid, gunit,(/1,1/),(/nstr,nvars/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'unitnam put' + ! obs + CALL chkerr( nf90_inq_varid(ncid, 'observation', obvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, obvid,g3dob ) ,cpname, __LINE__ ) + WRITE(*,*) 'obs put' + ! clim + CALL chkerr( nf90_inq_varid(ncid, 'climatology', clvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, clvid,g3dcl ) ,cpname, __LINE__ ) + WRITE(*,*) 'cli put' + IF (ln_best) THEN + ! daym2 + CALL chkerr( nf90_inq_varid(ncid, 'best_estimate',dm2id) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, dm2id,g3dm2 ) ,cpname, __LINE__ ) + WRITE(*,*) 'daym2 put' + ENDIF + IF (ln_init) THEN + ! daym1 + CALL chkerr( nf90_inq_varid(ncid, 'nrt_analysis',dm1id) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, dm1id,g3dm1 ) ,cpname, __LINE__ ) + WRITE(*,*) 'daym1 put' + ENDIF + IF (ln_mdt) THEN + ! mdt + CALL chkerr( nf90_inq_varid(ncid, 'mdt_reference', mdtid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, mdtid, g3mdt ) ,cpname, __LINE__ ) + WRITE(*,*) 'mdt put' + ENDIF + IF (ln_altbias) THEN + ! altbias + CALL chkerr( nf90_inq_varid(ncid, 'altimeter_bias', altid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, altid, g3alt ) ,cpname, __LINE__ ) + WRITE(*,*) 'altbias put' + ENDIF + ! persistence + CALL chkerr( nf90_inq_varid(ncid, 'persistence',prvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, prvid, g3dpr, (/1,1,1,1/) ,(/ ndeps,nfcst,nvars,nobs/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'per put' + ! forecast + CALL chkerr( nf90_inq_varid(ncid, 'forecast',fcvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, fcvid, g3dmc, (/1,1,1,1/), (/ ndeps,nfcst,nvars,nobs/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'fcst put' + ! qc + CALL chkerr( nf90_inq_varid(ncid, 'qc', qcvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, qcvid,g3dqc ) ,cpname, __LINE__ ) + WRITE(*,*) 'qc put' + ! juld + CALL chkerr( nf90_inq_varid(ncid, 'juld',jdvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, jdvid, gjuld) ,cpname, __LINE__ ) + WRITE(*,*) 'juld put' + ! modeljuld + CALL chkerr( nf90_inq_varid(ncid, 'modeljuld', mjdid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, mjdid, modjd,(/1/),(/nfcst/)) ,cpname, __LINE__ ) + WRITE(*,*) 'modjuld put' + ! type + CALL chkerr( nf90_inq_varid(ncid, 'type', typid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, typid, gtype,(/1,1/) , (/n128,nobs/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'type put' + ! id + CALL chkerr( nf90_inq_varid(ncid, 'id', idvid) ,cpname, __LINE__ ) + CALL chkerr( nf90_put_var(ncid, idvid, g_id,(/1,1/) , (/nstr,nobs/) ) ,cpname, __LINE__ ) + WRITE(*,*) 'id put' + ! Close netcdf file + CALL chkerr( nf90_close(ncid), cpname, __LINE__ ) + END IF ! ln_cre + !! Deallocate Global arrays + DEALLOCATE( g_lam, g_phi, g_dep, g3dob, g3dmc, g3dpr, g3dcl, g3dm2, g3dm1, g3mdt, g3alt, g3dqc, gjuld, gtype, g_id, gvnam, gunit) + DEALLOCATE( fcday, modjd ) + + !! Deallocate input argument list + DEALLOCATE(cdinfile) +END PROGRAM c4comb diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/convmerge.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/convmerge.F90 new file mode 100644 index 0000000000000000000000000000000000000000..19027775a1d926b64c1889df4bbb528f85756d90 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/convmerge.F90 @@ -0,0 +1,131 @@ +MODULE convmerge + + USE toolspar_kind + USE obs_fbm + USE obs_utils + IMPLICIT NONE + +CONTAINS + + SUBROUTINE conv_fbmerge( cdoutfile, nfiles, fbdata ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE conv_fbmerg ** + !! + !! ** Purpose : Merge all fbfiles into a single fbfile + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Optional : + !! namelist = namobs.in to select the observation range + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdoutfile ! Input file. + INTEGER :: nfiles ! Number of files + TYPE(obfbdata), dimension(nfiles) :: fbdata ! Structure to merge + !! * Local variables + type(obfbdata) :: fbmerge + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + INTEGER :: nmaxlev + INTEGER :: ia,ij,ii + REAL(fbdp), DIMENSION(nfiles) :: djulini, djulend + CHARACTER(len=8) :: cl_refdate + INTEGER :: irefdate,iyea,imon,iday,ihou,imin,isec + ! Namelist variables + CHARACTER(len=9) :: cdnamefile='namobs.in' + LOGICAL :: lexists + REAL(fbdp) :: dobsini,dobsend + NAMELIST/namobs/dobsini,dobsend + + dobsini = 0.0 + dobsend = 99991231.235959 + + INQUIRE(file=cdnamefile, exist=lexists) + IF (lexists) THEN + OPEN(10,file=cdnamefile) + READ(10,namobs) + WRITE(*,namobs) + CLOSE(10) + ENDIF + ! + ! Count number of data points + ! + nmaxlev = 1 + ii = 0 + DO ia = 1,nfiles + IF (lexists) THEN + cl_refdate=fbdata(ia)%cdjuldref(1:8) + READ(cl_refdate,'(I8)') irefdate + CALL ddatetoymdhms( dobsini, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(ia), & + & krefdate = irefdate ) + CALL ddatetoymdhms( dobsend, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(ia), & + & krefdate = irefdate ) + DO ij = 1, fbdata(ia)%nobs + IF ( ( fbdata(ia)%ptim(ij) > djulini(ia) ) .AND. & + & ( fbdata(ia)%ptim(ij) <= djulend(ia) ) ) THEN + ii = ii + 1 + nmaxlev = MAX(nmaxlev,fbdata(ia)%nlev) + ENDIF + ENDDO + ELSE + nmaxlev = MAX(nmaxlev,fbdata(ia)%nlev) + ii = ii + fbdata(ia)%nobs + ENDIF + ENDDO + ! + ! Merge the input structures into the output structure + ! + ALLOCATE( iset(ii), inum(ii), iindex(ii)) + ii = 0 + DO ia = 1,nfiles + DO ij = 1, fbdata(ia)%nobs + IF (lexists) THEN + IF ( ( fbdata(ia)%ptim(ij) > djulini(ia) ) .AND. & + & ( fbdata(ia)%ptim(ij) <= djulend(ia) ) ) THEN + ii = ii + 1 + iset(ii) = ia + inum(ii) = ij + iindex(ii) = ii + ENDIF + ELSE + ii = ii + 1 + iset(ii) = ia + inum(ii) = ij + iindex(ii) = ii + ENDIF + ENDDO + ENDDO + WRITE(*,*)'Output number of observations = ',ii + WRITE(*,*)'Output number of levels = ',nmaxlev + ! + ! Prepare fbmerge structure + ! + CALL init_obfbdata( fbmerge ) + CALL alloc_obfbdata( fbmerge, fbdata(1)%nvar, ii, nmaxlev, & + & fbdata(1)%nadd, fbdata(1)%next, fbdata(1)%lgrid ) + CALL merge_obfbdata( nfiles, fbdata, fbmerge, iset, inum, iindex ) + ! + ! Write the file + ! + CALL write_obfbdata( TRIM(cdoutfile), fbmerge ) + ! + ! Dellocate the data + ! + CALL dealloc_obfbdata( fbmerge ) + + END SUBROUTINE conv_fbmerge + +#include "ctl_stop.h90" + +#include "greg2jul.h90" + +!#include "ddatetoymdhms.h90" + +END MODULE convmerge diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/coords.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/coords.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b943a0ba9998436de60e26683c5ba8072d4a431c --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/coords.F90 @@ -0,0 +1,1025 @@ +MODULE coords + + IMPLICIT NONE + + INTEGER, PARAMETER :: nsech = 167 + CHARACTER(len=20), DIMENSION(nsech) :: cl_sech = (/ & + & 'global ', & + & 'nstrpac ', & + & 'sstrpac ', & + & 'npac ', & + & 'spac ', & + & 'trpac ', & + & 'natl ', & + & 'satl ', & + & 'tratl ', & + & 'nstratl ', & + & 'sstratl ', & + & 'neatl ', & + & 'nwatl ', & + & 'equa ', & + & 'nino1 ', & + & 'nino2 ', & + & 'nino12 ', & + & 'nino3 ', & + & 'nino4 ', & + & 'nino34 ', & + & 'ind1 ', & + & 'ind2 ', & + & 'ind3 ', & + & 'eq1 ', & + & 'eq2 ', & + & 'eq3 ', & + & 'eq4 ', & + & 'neq1 ', & + & 'neq2 ', & + & 'neq3 ', & + & 'neq4 ', & + & 'eqpac ', & + & 'eqind ', & + & 'atl1 ', & + & 'atl2 ', & + & 'atl3 ', & + & 'eqatl ', & + & 'trop ', & + & 'nxtrp ', & + & 'sxtrp ', & + & 'trind ', & + & 'sind ', & + & 'nepac ', & + & 'nwpac ', & + & 'trepac ', & + & 'trwpac ', & + & 'p15n38w ', & + & 'p12n38w ', & + & 'p8n38w ', & + & 'p4n38w ', & + & 'p0n35w ', & + & 'p21n23w ', & + & 'p12n23w ', & + & 'p4n23w ', & + & 'p0n23w ', & + & 'p0n10w ', & + & 'p0n0w ', & + & 'p5s10w ', & + & 'p10s10w ', & + & 't0n156e ', & + & 't0n165e ', & + & 't0n180e ', & + & 't0n170w ', & + & 't0n155w ', & + & 't0n140w ', & + & 't0n125w ', & + & 't0n110w ', & + & 't0n95w ', & + & 't5n156e ', & + & 't5s156e ', & + & 't5n165e ', & + & 't5n180e ', & + & 't5n170w ', & + & 't5n155w ', & + & 't5n140w ', & + & 't5n125w ', & + & 't5n110w ', & + & 't5n95w ', & + & 't5s165e ', & + & 't5s180e ', & + & 't5s170w ', & + & 't5s155w ', & + & 't5s140w ', & + & 't5s125w ', & + & 't5s110w ', & + & 't5s95w ', & + & 'r8s55e ', & + & 'r12s55e ', & + & 'r4s67e ', & + & 'r8s67e ', & + & 'r12s67e ', & + & 'r0n80e ', & + & 'r4s80e ', & + & 'r12s80e ', & + & 'r12n90e ', & + & 'r8n90e ', & + & 'r4n90e ', & + & 'r0n90e ', & + & 'r5s95e ', & + & 'r8s95e ', & + & 'r8s100e ', & + & 'NE_subtrop_pac ', & + & 'NW_subtrop_pac ', & + & 'NE_extratrop_pac ', & + & 'NW_extratrop_pac ', & + & 'SE_subtrop_pac ', & + & 'SW_subtrop_pac ', & + & 'NE_subtrop_atl ', & + & 'NW_subtrop_atl ', & + & 'NE_extratrop_atl ', & + & 'NW_extratrop_atl ', & + & 'SE_subtrop_atl ', & + & 'SW_subtrop_atl ', & + & 'SE_subtrop_ind ', & + & 'SW_subtrop_ind ', & + & 'Southern_ocean_pac ', & + & 'Southern_ocean_atl ', & + & 'Southern_ocean_ind ', & + & 'GLOBAL05 ', & + & 'GLOBAL10 ', & + & 'GLOBAL15 ', & + & 'GLOBAL20 ', & + & 'GLOBAL25 ', & + & 'GLOBAL30 ', & + & 'GLOBAL40 ', & + & 'GLOBAL50 ', & + & 'GLOBAL60 ', & + & 'ARCTIC ', & + & 'ATL60NA ', & + & 'ATL50NA ', & + & 'ATL40NA ', & + & 'ATL35NA ', & + & 'ATL30NA ', & + & 'ATL26NA ', & + & 'ATL10NA ', & + & 'ATLEQA ', & + & 'ATL10SA ', & + & 'ATL20SA ', & + & 'ATL30SA ', & + & 'PAC60NA ', & + & 'PAC50NA ', & + & 'PAC40NA ', & + & 'PAC35NA ', & + & 'PAC30NA ', & + & 'PAC20NA ', & + & 'PAC10NA ', & + & 'PACEQA ', & + & 'INP10SA ', & + & 'PAC20SA ', & + & 'PAC30SA ', & + & 'INDEQA ', & + & 'IND20SA ', & + & 'IND30SA ', & + & 'GLB60NA ', & + & 'GLB50NA ', & + & 'GLB40NA ', & + & 'GLB30NA ', & + & 'GLB20NA ', & + & 'GLB10NA ', & + & 'GLBEQA ', & + & 'GLB10SA ', & + & 'GLB20SA ', & + & 'GLB30SA ', & + & 'GLB40SA ', & + & 'GLB50SA ', & + & 'GLB60SA ', & + & 'npac25 ' & + & /) + + ! User defined areas + INTEGER :: nboxuser + CHARACTER(len=20), DIMENSION(:), ALLOCATABLE :: cl_boxes_user + REAL, DIMENSION(:,:), ALLOCATABLE :: areas + + ! zonal sections + INTEGER, PARAMETER :: nsecz = 50 + CHARACTER(len=20), DIMENSION(nsecz) :: cl_secz = (/ & + & 'LOMBOK ', & + & 'BANDA ', & + & 'MAKASSAR ', & + & 'SAVU ', & + & 'MALACCAS ', & + & 'PHILIPINES ', & + & 'YUCATAN ', & + & 'GIN ', & + & 'LABRADOR ', & + & 'ATL60N ', & + & 'ATL50N ', & + & 'ATL40N ', & + & 'ATL35N ', & + & 'ATL30N ', & + & 'ATL27N ', & + & 'ATL26N ', & + & 'ATL10N ', & + & 'ATLEQ ', & + & 'ATL10S ', & + & 'ATL20S ', & + & 'ATL30S ', & + & 'PAC60N ', & + & 'PAC50N ', & + & 'PAC40N ', & + & 'PAC35N ', & + & 'PAC30N ', & + & 'PAC25N ', & + & 'PAC20N ', & + & 'PAC10N ', & + & 'PACEQ ', & + & 'INP10S ', & + & 'PAC20S ', & + & 'PAC30S ', & + & 'INDEQ ', & + & 'IND20S ', & + & 'IND30S ', & + & 'GLB60N ', & + & 'GLB50N ', & + & 'GLB40N ', & + & 'GLB30N ', & + & 'GLB20N ', & + & 'GLB10N ', & + & 'GLBEQ ', & + & 'GLB10S ', & + & 'GLB20S ', & + & 'GLB30S ', & + & 'GLB40S ', & + & 'GLB50S ', & + & 'GLB60S ', & + & 'SUM-DARWIN ' & + & /) + + ! meridional sections + INTEGER, PARAMETER :: nsecm = 10 + CHARACTER(len=20), DIMENSION(nsecm) :: cl_secm = (/ & + & 'IT ', & + & 'ITA ', & + & 'TIMOR ', & +! & 'OMBAI ', & +! & 'SUMBA ', & +! & 'LUZON ', & + & 'DRAKE ', & + & 'TORRES ', & + & 'MED ', & + & 'FLORIDA ', & + & 'ANTILLAS ', & + & 'GOODHOPE ', & + & 'SOUTHAUS ' & + & /) + +CONTAINS + + SUBROUTINE coord_area( reg, area ) + !----------------------------------------------------------------------- + ! + ! ROUTINE coord_area + ! ********************** + ! + ! Purpose : + ! ------- + ! Define coordinates of different regions + ! + ! Modifications : + ! ------------- + ! + ! SEE: /home/ocx/postp/NEWGRIB/regions.txt + ! and /home/nep/sms/verify/automat/include/regions.h + ! + ! modification : 04-09 (N. Daget) + ! modification : 04-09 (N. Daget) add new regions + IMPLICIT NONE + !---------------------------------------------------------------------- + ! local declarations + !---------------------------------------------------------------------- + ! + CHARACTER(len=20), INTENT(inout) :: reg + REAL, DIMENSION(4), INTENT(out) :: area + ! + reg=TRIM(reg) + ! + SELECT CASE (reg) + CASE ('global') + area = (/0.,360.,-90.,90./) + CASE ('nstrpac') + area = (/105.,270.,10.,30./) + CASE ('sstrpac') + area = (/105.,270.,-30.,-10./) + CASE ('npac') + area = (/100.,260.,30.,70./) + CASE ('spac') + area = (/150.,290.,-70.,-30./) + CASE ('trpac') + area = (/125.,280.,-30.,30./) + CASE ('natl') + area = (/290.,15.,30.,70./) + CASE ('satl') + area = (/290.,20.,-70.,-30./) + CASE ('tratl') + area = (/280.,20.,-20.,30./) + CASE ('nstratl') + area = (/280.,20.,5.,28./) + CASE ('sstratl') + area = (/300.,20.,-20.,5./) + CASE ('neatl') + area = (/320.,15.,30.,70./) + CASE ('nwatl') + area = (/260.,320.,30.,70./) + CASE ('equa') + area = (/0.,360.,-2.,2./) + CASE ('nino1') + area = (/270.,280.,-10.,-5./) + CASE ('nino2') + area = (/270.,280.,-5.,0./) + CASE ('nino12') + area = (/270.,280.,-10.,0./) + CASE ('nino3') + area = (/210.,270.,-5.,5./) + CASE ('nino4') + area = (/160.,210.,-5.,5./) + CASE ('nino34') + area = (/190.,240.,-5.,5./) + CASE ('ind1') + area = (/50.,70.,-10.,10./) + CASE ('ind2') + area = (/90.,110.,-10.,0./) + CASE ('ind3') + area = (/50.,90.,-10.,0./) + CASE ('eq1') + area = (/230.,270.,-5.,5./) + CASE ('eq2') + area = (/190.,230.,-5.,5./) + CASE ('eq3') + area = (/150.,190.,-5.,5./) + CASE ('eq4') + area = (/120.,150.,-5.,5./) + CASE ('neq1') + area = (/230.,270.,5.,15./) + CASE ('neq2') + area = (/190.,230.,5.,15./) + CASE ('neq3') + area = (/150.,190.,5.,15./) + CASE ('neq4') + area = (/120.,150.,5.,15./) + CASE ('eqpac') + area = (/130.,280.,-5.,5./) + CASE ('eqind') + area = (/40.,120.,-5.,5./) + CASE ('atl1') + area = (/315.,340.,0.,10./) + CASE ('atl2') + area = (/0.,10.,-3.,3./) + CASE ('atl3') + area = (/340.,360.,-3.,3./) + CASE ('eqatl') + area = (/290.,30.,-5.,5./) + CASE ('trop') + area = (/0.,360.,-30.,30./) ! Tropics (second definition) + CASE ('nxtrp') + area = (/0.,360.,30.,70./) ! Northern Extratropics + CASE ('sxtrp') + area = (/0.,360.,-70.,-30./) ! Southern Extratropics + CASE ('trind') + area = (/40.,120.,-30.,30./) + CASE ('sind') + area = (/20.,150.,-70.,-30./) + CASE ('nepac') + area = (/210.,260.,30.,70./) + CASE ('nwpac') + area = (/100.,210.,30.,70./) + CASE ('trepac') + area = (/210.,270.,-30.,30./) + CASE ('trwpac') + area = (/100.,210.,-30.,30./) + ! PIRATA + CASE ('p20n38w') + area = (/321.,323.,19.,21./) + CASE ('p15n38w') + area = (/321.,323.,14.,16./) + CASE ('p12n38w') + area = (/321.,323.,11.,13./) + CASE ('p8n38w') + area = (/321.,323.,7.,9./) + CASE ('p4n38w') + area = (/321.,323.,3.,5./) + CASE ('p0n35w') + area = (/324.,326.,-0.5,0.5/) + CASE ('p21n23w') + area = (/336.,338.,20.,22./) + CASE ('p12n23w') + area = (/336.,338.,11.,13./) + CASE ('p4n23w') + area = (/336.,338.,3.,5./) + CASE ('p0n23w') + area = (/336.,338.,-0.5,0.5/) + CASE ('p0n10w') + area = (/349.,351.,-0.5,0.5/) + CASE ('p0n0w') + area = (/359.,1.,-0.5,0.5/) + CASE ('p5s10w') + area = (/349.,351.,-6.,-4./) + CASE ('p10s10w') + area = (/349.,351.,-11.,-9./) + + ! TAO + CASE ('t0n156e') + area = (/155.,157.,-0.5,0.5/) + CASE ('t0n165e') + area = (/164.,166.,-0.5,0.5/) + CASE ('t0n180e') + area = (/179.,181.,-0.5,0.5/) + CASE ('t0n170w') + area = (/189.,191.,-0.5,0.5/) + CASE ('t0n155w') + area = (/204.,206.,-0.5,0.5/) + CASE ('t0n140w') + area = (/219.,221.,-0.5,0.5/) + CASE ('t0n125w') + area = (/234.,236.,-0.5,0.5/) + CASE ('t0n110w') + area = (/249.,251.,-0.5,0.5/) + CASE ('t0n95w') + area = (/264.,266.,-0.5,0.5/) + CASE ('t5n156e') + area = (/155.,157.,4.5,5.5/) + CASE ('t5n165e') + area = (/164.,166.,4.5,5.5/) + CASE ('t5n180e') + area = (/179.,181.,4.5,5.5/) + CASE ('t5n170w') + area = (/189.,191.,4.5,5.5/) + CASE ('t5n155w') + area = (/204.,206.,4.5,5.5/) + CASE ('t5n140w') + area = (/219.,221.,4.5,5.5/) + CASE ('t5n125w') + area = (/234.,236.,4.5,5.5/) + CASE ('t5n110w') + area = (/249.,251.,4.5,5.5/) + CASE ('t5n95w') + area = (/264.,266.,4.5,5.5/) + CASE ('t5s156e') + area = (/155.,157.,-5.5,-5.5/) + CASE ('t5s165e') + area = (/164.,166.,-5.5,4.5/) + CASE ('t5s180e') + area = (/179.,181.,-5.5,-4.5/) + CASE ('t5s170w') + area = (/189.,191.,-5.5,-4.5/) + CASE ('t5s155w') + area = (/204.,206.,-5.5,-4.5/) + CASE ('t5s140w') + area = (/219.,221.,-5.5,-4.5/) + CASE ('t5s125w') + area = (/234.,236.,-5.5,-4.5/) + CASE ('t5s110w') + area = (/249.,251.,-5.5,-4.5/) + CASE ('t5s95w') + area = (/264.,266.,-5.5,-4.5/) + !RAMA + CASE ('r8s55e') + area = (/54.,56.,-8.,-7./) + CASE ('r12s55e') + area = (/54.,56.,-13.,-11./) + CASE ('r4s67e') + area = (/66.,68.,-4.5,-3.5/) + CASE ('r8s67e') + area = (/66.,68.,-9.,-7./) + CASE ('r12s67e') + area = (/66.,68.,-13.,-11./) + CASE ('r0n80e') + area = (/79.,81.,-0.5,0.5/) + CASE ('r4s80e') + area = (/79.,81.,-4.5,-3.5/) + CASE ('r8s80e') + area = (/79.,81.,-9.,-7./) + CASE ('r12s80e') + area = (/79.,81.,-13.,-11./) + CASE ('r12n90e') + area = (/89.,91.,11.,13./) + CASE ('r8n90e') + area = (/89.,91.,7.,9./) + CASE ('r4n90e') + area = (/89.,91.,3.5,4.5/) + CASE ('r0n90e') + area = (/89.,91.,-0.5,0.5/) + CASE ('r5s95e') + area = (/94.,96.,-5.5,-4.5/) + CASE ('r8s95e') + area = (/94.,96.,-9.,-7./) + CASE ('r8s100e') + area = (/99.,101.,-9.,-7./) + + + ! ENACT + CASE ('NE_subtrop_pac') + area = (/190.,260.,10.,30./) + CASE ('NW_subtrop_pac') + area = (/120.,190.,10.,30./) + CASE ('NE_extratrop_pac') + area = (/190.,250.,30.,60./) + CASE ('NW_extratrop_pac') + area = (/120.,190.,30.,60./) + CASE ('SE_subtrop_pac') + area = (/200.,300.,-30.,-10./) + CASE ('SW_subtrop_pac') + area = (/143.,200.,-30.,-10./) + CASE ('NE_subtrop_atl') + area = (/320.,355.,10.,30./) + CASE ('NW_subtrop_atl') + area = (/283.,320.,10.,30./) + CASE ('NE_extratrop_atl') + area = (/320.,360.,30.,60./) + CASE ('NW_extratrop_atl') + area = (/285.,320.,30.,60./) + CASE ('SE_subtrop_atl') + area = (/350.,20.,-30.,-10./) + CASE ('SW_subtrop_atl') + area = (/300.,350.,-30.,-10./) + CASE ('SE_subtrop_ind') + area = (/80.,120.,-30.,-10./) + CASE ('SW_subtrop_ind') + area = (/30.,80.,-30.,-10./) + CASE ('Southern_ocean_pac') + area = (/130.,290.,-80.,-30./) + CASE ('Southern_ocean_atl') + area = (/290.,20.,-80.,-30./) + CASE ('Southern_ocean_ind') + area = (/20.,130.,-80.,-30./) + ! Global areas different latitudes + CASE ('GLOBAL05') + area = (/0.,360.,-5.,5./) + CASE ('GLOBAL10') + area = (/0.,360.,-10.,10./) + CASE ('GLOBAL15') + area = (/0.,360.,-15.,15./) + CASE ('GLOBAL20') + area = (/0.,360.,-20.,20./) + CASE ('GLOBAL25') + area = (/0.,360.,-25.,25./) + CASE ('GLOBAL30') + area = (/0.,360.,-30.,30./) + CASE ('GLOBAL40') + area = (/0.,360.,-40.,40./) + CASE ('GLOBAL50') + area = (/0.,360.,-50.,50./) + CASE ('GLOBAL60') + area = (/0.,360.,-60.,60./) + CASE ('ARCTIC') + area = (/0.,360.,65.,90./) + CASE ('ATL60NA') + area=(/260.,9.13,59.,61./) + CASE ('ATL50NA') + area=(/260.,5.,49.,51./) + CASE ('ATL40NA') + area=(/260.,358.,39.,41./) + CASE ('ATL35NA') + area=(/260.,360.,34.,36./) + CASE ('ATL30NA') + area=(/260.,360.,29.,31./) + CASE ('ATL26NA') + area=(/260.,360.,25.,27./) + CASE ('ATL20NA') + area=(/260.,360.,19.,21./) + CASE ('ATL10NA') + area=(/290.,360.,9.,11./) + CASE ('ATLEQA') + area=(/289.,11.,-1.,1./) + CASE ('ATL10SA') + area=(/320.,15.,-11.,-9./) + CASE ('ATL20SA') + area=(/318.,15.,-21.,-19./) + CASE ('ATL30SA') + area=(/310.,20.,-31.,-29./) + CASE ('PAC60NA') + area=(/140.,250.,59.,61./) + CASE ('PAC50NA') + area=(/130.,240.,49.,51./) + CASE ('PAC40NA') + area=(/125.,240.,39.,41./) + CASE ('PAC35NA') + area=(/115.,242.,34.,36./) + CASE ('PAC30NA') + area=(/115.,250.,29.,31./) + CASE ('PAC20NA') + area=(/100.,260.,19.,21./) + CASE ('PAC10NA') + area=(/105.,275.,9.,11./) + CASE ('PACEQA') + area=(/115.,282.,-1.,1./) + CASE ('INP10SA') + area=(/35.,290.,-11.,-9./) + CASE ('PAC20SA') + area=(/140.,292.,-21.,-19./) + CASE ('PAC30SA') + area=(/150.,292.,-31.,-29./) + CASE ('INDEQA') + area=(/40.,115.,-1.,1./) + CASE ('IND20SA') + area=(/30.,130.,-21.,-19./) + CASE ('IND30SA') + area=(/30.,120.,-31.,-29./) + CASE ('GLB60NA') + area=(/166.,9.13,59.,61./) + CASE ('GLB50NA') + area=(/0.,360.,49.,51./) + CASE ('GLB40NA') + area=(/0.,360.,39.,41./) + CASE ('GLB30NA') + area=(/0.,360.,29.,31./) + CASE ('GLB20NA') + area=(/0.,360.,19.,21./) + CASE ('GLB10NA') + area=(/0.,360.,9.,11./) + CASE ('GLBEQA') + area=(/0.,360.,-1.,1./) + CASE ('GLB10SA') + area=(/0.,360.,-11.,-9./) + CASE ('GLB20SA') + area=(/0.,360.,-21.,-19./) + CASE ('GLB30SA') + area=(/0.,360.,-31.,-29./) + CASE ('GLB40SA') + area=(/0.,360.,-41.,-39./) + CASE ('GLB50SA') + area=(/0.,360.,-51.,-49./) + CASE ('GLB60SA') + area=(/0.,360.,-61.,-59./) + CASE ('npac25') + area = (/100.,260.,25.,70./) + !Zonal sections + ! Measurements of Indonesian Throughflow at + ! http://www.ocean.washington.edu/people/faculty/susanh/spga/spga.htm + ! INSTANT obserational program + + CASE ('LOMBOK') +! area=(/114.,118.,-8.,-8./) + area=(/114.,120.,-8.,-9./) ! first/last point rather than min,max + CASE ('MAKASSAR') +! area=(/114.,120.,-3.,-3./) + area=(/114.,121.,-3.,-3./) + CASE ('MALACCAS') +! area=(/99.,102.,3.,3./) + area=(/103.,112.,-2.8,-2.8/) + CASE ('BANDA') + area=(/122.,140.,-4.,-4./) + CASE ('SAVU') +! area=(/122.,124.,-8.8,-8.8/) + area=(/120.,125.,-8.8,-9.4/) + CASE ('PHILIPINES') + area=(/106.,120.,10.985,10.985/) + CASE ('YUCATAN') +! area=(/273.,285.,20.,20./) + area=(/271.,283.,20.,21./) + CASE ('GIN') +! area=(/315.,7.,63.,63./) + area=(/315.,9.8,63.,63./) + CASE ('LABRADOR') +! area=(/290.,315.,61.,61./) + area=(/289.,310.,60.6,63.5/) + CASE ('ATL60N') +! area=(/260.,10.,57.,57./) +! area=(/260.,10.87,57.,57./) +! area=(/260.,11.2,57.,57./) + area=(/260.,9.13,60.,59.925/) + CASE ('ATL50N') + area=(/260.,5.,50.,50./) + CASE ('ATL40N') + area=(/260.,358.,40.,40./) + CASE ('ATL35N') + area=(/260.,360.,35.,35./) + CASE ('ATL30N') + area=(/260.,360.,30.,30./) + CASE ('ATL27N') + area=(/260.,360.,27.,27./) + CASE ('ATL26N') + area=(/260.,360.,26.,26./) + CASE ('ATL20N') + area=(/260.,360.,20.,20./) + CASE ('ATL10N') +! area=(/300.,360.,10.,10./) + area=(/290.,360.,10.,10./) + CASE ('ATLEQ') +! area=(/300.,10.,0.,0./) + area=(/289.,11.,0.,0./) + CASE ('ATL10S') + area=(/320.,15.,-10.,-10./) + CASE ('ATL20S') + area=(/318.,15.,-30.,-30./) + CASE ('ATL30S') + area=(/310.,20.,-30.,-30./) + CASE ('PAC60N') + area=(/140.,250.,60.,60./) + CASE ('PAC50N') + area=(/130.,240.,50.,50./) + CASE ('PAC40N') + area=(/125.,240.,40.,40./) + CASE ('PAC35N') +! area=(/115.,240.,35.,35./) + area=(/115.,242.,35.,35./) + CASE ('PAC30N') + area=(/115.,250.,30.,30./) + CASE ('PAC25N') + area=(/100.,260.,25.,25./) + CASE ('PAC20N') + area=(/100.,260.,20.,20./) + CASE ('PAC10N') +! area=(/98.,275.,10.,10./) + area=(/105.,275.,10.,10./) + CASE ('PACEQ') + area=(/115.,282.,0.,0./) + CASE ('INP10S') + area=(/35.,290.,-10.,-10./) + CASE ('PAC20S') + area=(/140.,292.,-20.,-20./) + CASE ('PAC30S') + area=(/150.,292.,-30.,-30./) + CASE ('INDEQ') + area=(/40.,115.,-0.,-0./) + CASE ('IND20S') + area=(/30.,130.,-20.,-20./) + CASE ('IND30S') + area=(/30.,120.,-30.,-30./) + CASE ('GLB60N') +! area=(/0.,360.,60.,60./) +! area=(/166.,10.,60.5,60./) +! area=(/166.,6.6,60.5,59.7/) + area=(/166.,9.13,60.5,59.925/) + CASE ('GLB50N') + area=(/0.,360.,50.,50./) + CASE ('GLB40N') + area=(/0.,360.,40.,40./) + CASE ('GLB30N') + area=(/0.,360.,30.,30./) + CASE ('GLB20N') + area=(/0.,360.,20.,20./) + CASE ('GLB10N') + area=(/0.,360.,10.,10./) + CASE ('GLBEQ') + area=(/0.,360.,0.,0./) + CASE ('GLB10S') + area=(/0.,360.,-10.,-10./) + CASE ('GLB20S') + area=(/0.,360.,-20.,-20./) + CASE ('GLB30S') + area=(/0.,360.,-30.,-30./) + CASE ('GLB40S') + area=(/0.,360.,-40.,-40./) + CASE ('GLB50S') + area=(/0.,360.,-50.,-50./) + CASE ('GLB60S') + area=(/0.,360.,-60.,-60./) + CASE ('SUM-DARWIN') + area=(/104.,131.,-4.9,-15.3/) + + !Meridonal sections (for zonal transports) + CASE ('IT' ) !From Flores to Australia +! area=(/114.,114.,-22.,-8.5/) + area=(/126.,126.,-8.8,-16./) + CASE ('ITA' ) !From Sumatra to Australia +! area=(/115.,114.,-22.,-3./) + area=(/104.,115.,-4.9,-24.7/) + CASE ('TIMOR') + area=(/124.,124.,-17.,-9./) +! CASE ('OMBAI') +! area=(/124.5,124.5,-9.2,-8.2/) +! CASE ('SUMBA') +! area=(/120.,120.,-9.3,-8.3/) +! CASE ('LUZON') +! area=(/120.5,120.5,17.,23./) + CASE ('DRAKE') +! area=(/290.,290.,-75.,-52./) +! area=(/-69.,-64.,-55.2,-65.9/) + area=(/291.,296.,-54.6,-65.9/) + CASE ('TORRES') + area=(/143.,143.,-15.,-8./) + CASE ('MED') + area=(/356.,356.,32.,40./) + CASE ('FLORIDA') +! area=(/279.5,279.5,22.,28./) +! area=(/-81.,-79,26.5,21.9/) + area=(/-82.,-79.,28.2,22./) + CASE ('ANTILLAS') +! area=(/290.,290.,10.,18./) + area=(/-72.,-72.,19.1,8.2/) + CASE ('GOODHOPE') +! area=(/340.,340.,-80.,-30./) + area=(/23.,44.,-31.7,-68.2/) + CASE ('SOUTHAUS') +! area=(/140.,140.,-80.,-30./) + area=(/133.,133.,-30.,-67.5/) + CASE default + PRINT*,'area: ', reg, 'is not defined' + CALL abort + END SELECT + + END SUBROUTINE coord_area + + SUBROUTINE coord_user_init (sec) + CHARACTER(len=1), INTENT(IN) :: sec + CHARACTER(len=20), DIMENSION(:), ALLOCATABLE :: cl_boxes + INTEGER :: nbox + CHARACTER(len=32) :: cdnamelist = 'coords.nml' + LOGICAL :: lexists, lnodefaults + CHARACTER(len=20) :: carea + REAL :: lat1,lat2,lon1,lon2,dlat,dlon + LOGICAL :: lreg, lstd + INTEGER :: nlat,nlon + INTEGER :: i,j,k + NAMELIST/area/lstd,lreg,carea,lat1,lat2,lon1,lon2,dlat,dlon + + lnodefaults=.TRUE. + nboxuser=0 + SELECT CASE (sec) + CASE ('u') + nbox=nsecm + ALLOCATE(cl_boxes(nbox)) + cl_boxes(:)=cl_secm(:) + CASE ('v') + nbox=nsecz + ALLOCATE(cl_boxes(nbox)) + cl_boxes(:)=cl_secz(:) + CASE default + nbox=nsech + ALLOCATE(cl_boxes(nbox)) + cl_boxes(:)=cl_sech(:) + END SELECT + INQUIRE(file=cdnamelist,exist=lexists) + IF (lexists) THEN + nboxuser=0 + OPEN(20,file=cdnamelist) + DO + carea='undefined' + lat1=-90 + lat2=90 + lon1=0 + lon2=360 + dlat=10 + dlon=10 + lreg=.FALSE. + lstd=.FALSE. + READ(20,area,end=100) + DO + IF (lon1<0) lon1=lon1+360 + IF (lon1>360) lon1=lon1-360 + IF ((lon1>=0).AND.(lon1<=360)) EXIT + ENDDO + DO + IF (lon2<0) lon2=lon2+360 + IF (lon2>360) lon2=lon2-360 + IF ((lon2>=0).AND.(lon2<=360)) EXIT + ENDDO + WRITE(*,area) + IF (lreg.AND.(TRIM(carea)/='undefined')) THEN + WRITE(*,*)'coord_init: please specify either lreg=true '//& + & 'or carea/=undefined' + CALL abort + ENDIF + IF (TRIM(carea)/='undefined') THEN + nboxuser=nboxuser+1 + ENDIF + IF (lreg) THEN + nlat=NINT((MAX(lat1,lat2)-MIN(lat1,lat2))/dlat) + nlon=NINT((MAX(lon1,lon2)-MIN(lon1,lon2))/dlon) + nboxuser=nboxuser+nlat*nlon + ENDIF + IF (lstd) THEN + IF (lnodefaults) THEN + nboxuser=nboxuser+nbox + lnodefaults=.FALSE. + ENDIF + ENDIF + END DO +100 CONTINUE + WRITE(*,*)'Total areas = ',nboxuser + IF (nboxuser==0) THEN + CLOSE(20) + WRITE(*,*)'coord_init: no boxes defined!!' + CALL abort + ENDIF + ALLOCATE(cl_boxes_user(nboxuser)) + ALLOCATE(areas(4,nboxuser)) + nboxuser=0 + IF (.NOT.lnodefaults) THEN + cl_boxes_user(1:nbox)=cl_boxes(1:nbox) + DO i=1,nbox + CALL coord_area( cl_boxes_user(i), areas(:,i) ) + ENDDO + nboxuser=nboxuser+nbox + ENDIF + REWIND(20) + WRITE(*,*)'Reading areas' + DO + carea='undefined' + lat1=-90 + lat2=90 + lon1=0 + lon2=360 + dlat=10 + dlon=10 + lreg=.FALSE. + lstd=.FALSE. + READ(20,area,end=200) + DO + IF (lon1<0) lon1=lon1+360 + IF (lon1>360) lon1=lon1-360 + IF ((lon1>=0).AND.(lon1<=360)) EXIT + ENDDO + DO + IF (lon2<0) lon2=lon2+360 + IF (lon2>360) lon2=lon2-360 + IF ((lon2>=0).AND.(lon2<=360)) EXIT + ENDDO + IF (TRIM(carea)/='undefined') THEN + nboxuser=nboxuser+1 + cl_boxes_user(nboxuser)=carea + areas(1,nboxuser)=MIN(lon1,lon2) + areas(2,nboxuser)=MAX(lon1,lon2) + areas(3,nboxuser)=MIN(lat1,lat2) + areas(4,nboxuser)=MAX(lat1,lat2) + ENDIF + IF (lreg) THEN + nlat=NINT((MAX(lat1,lat2)-MIN(lat1,lat2))/dlat) + nlon=NINT((MAX(lon1,lon2)-MIN(lon1,lon2))/dlon) + k=0 + DO j=1,nlat + DO i=1,nlon + k=k+1 + areas(1,k+nboxuser)=MIN(lon1,lon2)+(i-1)*dlon + areas(2,k+nboxuser)=MIN(lon1,lon2)+i*dlon + areas(3,k+nboxuser)=MIN(lat1,lat2)+(j-1)*dlat + areas(4,k+nboxuser)=MIN(lat1,lat2)+j*dlat + WRITE(cl_boxes_user(k+nboxuser)(1:5),'(I4.4,A1)') & + & NINT(areas(1,k+nboxuser)*10),'e' + WRITE(cl_boxes_user(k+nboxuser)(6:10),'(I4.4,A1)') & + & NINT(areas(2,k+nboxuser)*10),'e' + IF (areas(3,k+nboxuser)<0) THEN + WRITE(cl_boxes_user(k+nboxuser)(11:15),'(I4.4,A1)') & + & -NINT(areas(3,k+nboxuser)*10),'s' + ELSE + WRITE(cl_boxes_user(k+nboxuser)(11:15),'(I4.4,A1)') & + & NINT(areas(3,k+nboxuser)*10),'n' + ENDIF + IF (areas(4,k+nboxuser)<0) THEN + WRITE(cl_boxes_user(k+nboxuser)(16:20),'(I4.4,A1)') & + & -NINT(areas(4,k+nboxuser)*10),'s' + ELSE + WRITE(cl_boxes_user(k+nboxuser)(16:20),'(I4.4,A1)') & + & NINT(areas(4,k+nboxuser)*10),'n' + ENDIF + ENDDO + ENDDO + nboxuser=nboxuser+nlat*nlon + ENDIF + END DO +200 CONTINUE + CLOSE(20) + ELSE + nboxuser=nbox + ALLOCATE(cl_boxes_user(nboxuser)) + ALLOCATE(areas(4,nboxuser)) + cl_boxes_user(:)=cl_boxes(:) + DO i=1,nbox + CALL coord_area( cl_boxes_user(i), areas(:,i) ) + ENDDO + ENDIF + DO i=1,nboxuser + WRITE(*,'(A,4F12.2)')cl_boxes_user(i),areas(:,i) + DO j=i+1,nboxuser + IF (TRIM(cl_boxes_user(i))==TRIM(cl_boxes_user(j))) THEN + WRITE(*,*)'coord_user_init: dublicate boxes' + CALL abort + ENDIF + ENDDO + ENDDO + + END SUBROUTINE coord_user_init + + SUBROUTINE coord_area_user( reg, area, ldfail ) + !----------------------------------------------------------------------- + ! + ! ROUTINE coord_area_user + ! **************************** + ! + ! Purpose : + ! ------- + ! Get coordinate of different regions + ! + ! Modifications : + ! ------------- + IMPLICIT NONE + !---------------------------------------------------------------------- + ! local declarations + !---------------------------------------------------------------------- + ! + CHARACTER(len=20), INTENT(inout) :: reg + REAL, DIMENSION(4), INTENT(out) :: area + LOGICAL, OPTIONAL, INTENT(out) :: ldfail + INTEGER :: i + LOGICAL :: lnotfound + ! + reg=TRIM(reg) + + lnotfound=.TRUE. + DO i=1,nboxuser + IF (reg==TRIM(cl_boxes_user(i))) THEN + area(:)=areas(:,i) + lnotfound=.FALSE. + EXIT + ENDIF + ENDDO + IF (PRESENT(ldfail)) THEN + ldfail=lnotfound + ELSE + IF (lnotfound) THEN + WRITE(*,*)'coord_area_user: area not found' + CALL abort + ENDIF + ENDIF + + END SUBROUTINE coord_area_user + +END MODULE coords diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/corio2fb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/corio2fb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..96e909e76e8d317941e53e901b4df05570332598 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/corio2fb.F90 @@ -0,0 +1,90 @@ +PROGRAM corio2fb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM corio2fb ** + !! + !! ** Purpose : Convert Coriolis format profiles to feedback format + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! corio2fb.exe outputfile inputfile1 inputfile2 ... + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE obs_prof_io + USE convmerge + IMPLICIT NONE + ! + ! Command line arguments for output file and input files + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + ! + ! Input data + ! + TYPE(obfbdata), POINTER :: coriof(:) + INTEGER :: ninfiles,ntotcorio,nmaxlev + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + ! + ! Output data + ! + TYPE(obfbdata) :: fbdata + ! + ! Loop variables + ! + INTEGER :: ia,ii,ij + ! + ! Get number of command line arguments + ! + nargs=IARGC() + IF (nargs < 1) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'corio2fb outputfile inputfile1 inputfile2 ...' + CALL abort() + ENDIF + CALL getarg(1,cdoutfile) + ! + ! Get input data + ! + ALLOCATE( coriof(MAX(nargs-1,1)) ) + ALLOCATE( cdinfile(nargs-1) ) + ntotcorio = 0 + ninfiles = nargs - 1 + DO ia=1,ninfiles + CALL getarg( ia + 1, cdinfile(ia) ) + CALL read_coriofile( TRIM(cdinfile(ia)), coriof(ia), 6, .TRUE., .FALSE. ) + WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia)) + WRITE(*,'(A,I9,A)')'has',coriof(ia)%nobs,' profiles' + ntotcorio = ntotcorio + coriof(ia)%nobs + nmaxlev = MAX( nmaxlev, coriof(ia)%nlev ) + ENDDO + IF (ninfiles==0) THEN + CALL init_obfbdata( coriof(1) ) + CALL alloc_obfbdata( coriof(1), 2, 0, 1, 0, 1, .FALSE. ) + coriof(1)%cname(1) = 'POTM' + coriof(1)%cname(2) = 'PSAL' + coriof(1)%coblong(1) = 'Potential temperature' + coriof(1)%coblong(2) = 'Practical salinity' + coriof(1)%cobunit(1) = 'Degrees Celsius' + coriof(1)%cobunit(2) = 'PSU' + coriof(1)%cextname(1) = 'TEMP' + coriof(1)%cextlong(1) = 'Insitu temperature' + coriof(1)%cextunit(1) = 'Degrees Celsius' + coriof(1)%cdjuldref = '19500101000000' + ENDIF + WRITE(*,'(A,I8)') 'Total profiles : ',ntotcorio + ! + ! Merge and output the data. + ! + CALL conv_fbmerge( TRIM(cdoutfile), ninfiles, coriof ) + +END PROGRAM corio2fb diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/ctl_stop.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/ctl_stop.h90 new file mode 100644 index 0000000000000000000000000000000000000000..df995bf0267483839825d9b0d5495c4cf357494a --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/ctl_stop.h90 @@ -0,0 +1,21 @@ + SUBROUTINE ctl_stop( cerr ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE ctl_stop ** + !! + !! ** Purpose : Stop execution + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : (2008-12) K. Mogensen. NEMOVAR version + !!---------------------------------------------------------------------- + CHARACTER(len=*) :: cerr + + WRITE(*,*)'Error:' + WRITE(*,*)TRIM(cerr) + CALL abort + + END SUBROUTINE ctl_stop + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/date_utils.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/date_utils.F90 new file mode 100644 index 0000000000000000000000000000000000000000..eea39f8169b306db975ce3990fe80cf7d528a42e --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/date_utils.F90 @@ -0,0 +1,482 @@ +MODULE date_utils + + USE toolspar_kind + IMPLICIT NONE + +CONTAINS + + SUBROUTINE add_date(initial_date,hours,final_date) + + ! Add a number of hours to initial_date and return it in final_date + + IMPLICIT NONE + + + !! Arguments + INTEGER,INTENT(in) :: initial_date ! Initial date (YYYYMMDDHH) + INTEGER,INTENT(in) :: hours ! Number of hours to add + INTEGER,INTENT(out) :: final_date ! Final date (YYYYMMDDHH) + + !! Local variables + + INTEGER :: isec,imin,ihours,iyear,imon,iday ! temporary results + REAL(dp):: juld + + CALL split_date(initial_date,iyear,imon,iday,ihours) + + CALL greg2jul(0,0,ihours,iday,imon,iyear,juld) + + juld=juld+REAL(hours)/24.0 + + CALL jul2greg(isec,imin,ihours,iday,imon,iyear,juld) + + final_date=iyear*1000000+imon*10000+iday*100+ihours + + END SUBROUTINE add_date + + + SUBROUTINE add_days_to_date(initial_date,days,final_date) + + ! Add a number of days to initial_date and return it in final_date + + IMPLICIT NONE + + + !! Arguments + INTEGER,INTENT(in) :: initial_date ! Initial date (YYYYMMDD) + INTEGER,INTENT(in) :: days ! Number of days to add + INTEGER,INTENT(out) :: final_date ! Final date (YYYYMMDD) + + !! Local variables + + INTEGER :: isec,imin,ihours,iyear,imon,iday ! temporary results + REAL(dp):: juld + + ! Account for lack of hours in date format (initial_date*100) + CALL split_date(initial_date*100,iyear,imon,iday,ihours) + + CALL greg2jul(0,0,ihours,iday,imon,iyear,juld) + + juld=juld+REAL(days) + + CALL jul2greg(isec,imin,ihours,iday,imon,iyear,juld) + + final_date=(iyear*1000000+imon*10000+iday*100+ihours)/100 + + END SUBROUTINE add_days_to_date + + + SUBROUTINE split_date(iyyyymmddhh,iyyyy,imm,idd,ihh) + + ! Splits a date in YYYYMMDDHH format into iyyyy, imm, idd, ihh + + IMPLICIT NONE + INTEGER,INTENT(in) :: iyyyymmddhh + INTEGER,INTENT(out) :: iyyyy,imm,idd,ihh + + iyyyy=iyyyymmddhh/1000000 + imm=iyyyymmddhh/10000-iyyyy*100 + idd=iyyyymmddhh/100-(iyyyy*10000+imm*100) + ihh=MOD(iyyyymmddhh,100) + + END SUBROUTINE split_date + + SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & + & prelday ) + + IMPLICIT NONE + !!----------------------------------------------------------------------- + !! + !! *** 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 + !!----------------------------------------------------------------------- + + ! * Arguments + 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 + + ! Main computation + iref = jporef + + zday = prelday + ksec = NINT( 86400. * MOD( zday, 1.0_wp ) ) + + IF ( ksec < 0. ) ksec = 86400. + ksec + + khour = ksec / 3600 + kminut = ( ksec - 3600 * khour ) / 60 + ksec = MOD( ksec , 60 ) + + ijulian = iref + INT( zday ) + IF ( zday < 0. ) ijulian = ijulian - 1 + + ! If input date after 10/15/1582 : + IF ( ijulian >= jpgreg ) THEN + ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 ) + ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) ) + ELSE + ija = ijulian + ENDIF + + ijb = ija + 1524 + ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 ) + ijd = 365 * ijc + INT( 0.25 * ijc ) + ije = INT( ( ijb - ijd ) / 30.6001 ) + kday = ijb - ijd - INT( 30.6001 * ije ) + kmonth = ije - 1 + IF ( kmonth > 12 ) kmonth = kmonth - 12 + kyear = ijc - 4715 + IF ( kmonth > 2 ) kyear = kyear - 1 + IF ( kyear <= 0 ) kyear = kyear - 1 + + END SUBROUTINE jul2greg + + SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian ) + + IMPLICIT NONE + !!----------------------------------------------------------------------- + !! + !! *** 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 + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), & ! Gregorian calendar introduction date + & jpjref = 2433283 ! Julian reference date: 19500101 + INTEGER :: & + & ija, & + & ijy, & + & ijm, & + & ijultmp, & + & ijyear + + ! 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 - jpjref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400. + + END SUBROUTINE greg2jul + + + SUBROUTINE addseconds(iyear,imon,iday,ihour,imin,isec,iaddsec) + + ! Add iaddsecs to the date and return the new date (in place) + + !! Arguments + + INTEGER,intent(inout) :: iyear,imon,iday,ihour,imin,isec,iaddsec + + !! Local variables + + INTEGER :: itotsec,idays,isecs + INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + itotsec=iaddsec+ihour*3600*imin*60+isec + + IF (itotsec<0) THEN + WRITE(*,*)'Negative itotsec in addseconds' + WRITE(*,*)'This does not work' + RETURN + ENDIF + + ihour=0 + imin=0 + isec=0 + + idays=itotsec/86400 + isecs=itotsec-idays*86400 + iday=iday+idays + + ! Compute the date + DO + ! Leap year + mday(2)=28 + IF (MOD(iyear,4).EQ.0) mday(2)=29 + IF (MOD(iyear,100).EQ.0) mday(2)=28 + IF (MOD(iyear,400).EQ.0) mday(2)=29 + IF (MOD(iyear,4000).EQ.0) mday(2)=28 + + IF (iday.GT.mday(imon))THEN + iday=iday-mday(imon) + imon=imon+1 + IF(imon.GT.12)THEN + imon=1 + iyear=iyear+1 + ENDIF + ELSE + EXIT + ENDIF + + ENDDO + + ! Set the time + ihour=isecs/3600 + imin=isecs/60-ihour*60 + isec=isecs-ihour*3600-imin*60 + + END SUBROUTINE addseconds + + INTEGER FUNCTION nextdate(idate) + + ! Return next date. + ! Date format is assumed to be YYYYMMDD + + IMPLICIT NONE + + !! Arguments + + INTEGER :: idate ! Initial date + + !! Local variables + + INTEGER :: year,day,mon + INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + + day=MOD(idate,100) + mon=MOD((idate-day)/100,100) + year=idate/10000 + + mday(2)=28 + IF (MOD(year,4).EQ.0) mday(2)=29 + IF (MOD(year,100).EQ.0) mday(2)=28 + IF (MOD(year,400).EQ.0) mday(2)= 29 + IF (MOD(year,4000).EQ.0) mday(2) = 28 + + day=day+1 + IF (day.GT.mday(mon))THEN + day=1 + mon=mon+1 + IF(mon.GT.12)THEN + mon=1 + year=year+1 + ENDIF + ENDIF + nextdate=year*10000+mon*100+day + RETURN + + END FUNCTION nextdate + + INTEGER FUNCTION prevdate(idate) + + ! Return previous date. + ! Date format is assumed to be YYYYMMDD + + IMPLICIT NONE + + !! Arguments + + INTEGER :: idate ! Initial date + + !! Local variables + + INTEGER :: year,day,mon + INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + + day=MOD(idate,100) + mon=MOD((idate-day)/100,100) + year=idate/10000 + + mday(2)=28 + IF (MOD(year,4).EQ.0) mday(2)=29 + IF (MOD(year,100).EQ.0) mday(2)=28 + IF (MOD(year,400).EQ.0) mday(2)= 29 + IF (MOD(year,4000).EQ.0) mday(2) = 28 + + day=day-1 + IF (day.LT.1)THEN + mon=mon-1 + IF(mon.LT.1)THEN + mon=12 + year=year-1 + ENDIF + day=mday(mon) + ENDIF + prevdate=year*10000+mon*100+day + RETURN + + END FUNCTION prevdate + + INTEGER FUNCTION diffdate(idate1,idate2) + + ! Compute difference in days between dates + ! Assumes YYYYMMDD format for dates + + IMPLICIT NONE + + !! Argument + + INTEGER :: idate1,idate2 ! Dates to be diffed. + + !! Local variables + + INTEGER :: itdate1,itdate2 + INTEGER :: it + + itdate1=MIN(idate1,idate2) + itdate2=MAX(idate1,idate2) + + IF (itdate1==itdate2) THEN + diffdate=0 + RETURN + ENDIF + diffdate=0 + it=itdate1 + DO + it=nextdate(it) + diffdate=diffdate+1 + IF (it==itdate2) EXIT + ENDDO + RETURN + + END FUNCTION diffdate + + INTEGER FUNCTION difftime(itime1,itime2) + + ! Compute difference in minutes between times + ! Assumes HHMM or HMM or MM or M format for dates + ! + ! ORDER MATTERS - itime1 is ealier time + ! Result is an integer number of minutes + + IMPLICIT NONE + INTEGER, INTENT(IN) :: itime1,itime2 ! Times to be diffed. + INTEGER :: imin1, imin2, ihr1, ihr2 + + ihr1 = (itime1/100) + ihr2 = (itime2/100) + + imin1 = (itime1 - ihr1*100) + (60 * ihr1) + imin2 = (itime2 - ihr2*100) + (60 * ihr2) + + ! Assume that itime2 is later, so wrap around midnight if necessary. + IF (imin2 < imin1) THEN + imin2 = imin2 + 24*60 + END IF + + difftime = imin2 - imin1 + + END FUNCTION difftime + + + INTEGER FUNCTION add_mins_to_time(itime1, imin_add) + + ! Add number of minutes onto given time + ! Assumes time in HHMM or HMM or MM or M format + ! + ! Result is in HHMM format + + IMPLICIT NONE + INTEGER, INTENT(IN) :: itime1,imin_add + INTEGER :: imin1, ihr1, imin2, ihr2 + + ihr1 = (itime1/100) + + ! itime1 in minutes from previous midnight + imin1 = (itime1 - ihr1*100) + (60 * ihr1) + + imin1 = imin1 + imin_add + + ! Add 1day if time went nagative + IF (imin1 < 0) THEN + imin1 = imin1 + 24*60 + END IF + + ! Turn number of minutes back into HHMM + ihr2 = imin1/60 + imin2 = imin1 - ihr2*60 + + DO + IF (ihr2<0) THEN + ihr2 = ihr2 + 24 + ELSE IF (ihr2>=24) THEN + ihr2 = ihr2 - 24 + END IF + IF ((ihr2>=0).OR.(ihr2<24)) EXIT + END DO + + add_mins_to_time = ihr2*100 + imin2 + + END FUNCTION add_mins_to_time + + +END MODULE date_utils diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/ddatetoymdhms.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/ddatetoymdhms.h90 new file mode 120000 index 0000000000000000000000000000000000000000..3fb44664181f4b087a2ccf8e597bf96a7287eea0 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/ddatetoymdhms.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/ddatetoymdhms.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/distance.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/distance.h90 new file mode 100644 index 0000000000000000000000000000000000000000..4dd2351b62048ddec039367d01513f1657fa5fb0 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/distance.h90 @@ -0,0 +1,33 @@ + REAL FUNCTION distance( plon1, plat1, plon2, plat2 ) + ! Arggumnts + REAL :: plon1,plat1,plat2,plon2 + ! Local variables + REAL :: zplat1,zplon1,zplat2,zplon2 + REAL :: za1,za2,zb1,zb2,zc1,zc2,zcos1,zcos2 + REAL, PARAMETER :: zrad = 3.141592653589793/180.0 + REAL, parameter :: rearth = 6371229 + + zplon1 = plon1 + zplon2 = plon2 + IF ( zplon1 < -180 ) zplon1 = zplon1 + 360.0 + IF ( zplon1 >= 180 ) zplon1 = zplon1 - 360.0 + IF ( zplon2 < -180 ) zplon2 = zplon2 + 360.0 + IF ( zplon2 >= 180 ) zplon2 = zplon2 - 360.0 + + zplon1 = zplon1 * zrad + zplon2 = zplon2 * zrad + zplat1 = plat1 * zrad + zplat2 = plat2 * zrad + zcos1 = COS( zplat1 ) + zcos2 = COS( zplat2 ) + za1 = SIN( zplat1 ) + za2 = SIN( zplat2 ) + zb1 = zcos1 * COS( zplon1 ) + zb2 = zcos2 * COS( zplon2 ) + zc1 = zcos1 * SIN( zplon1 ) + zc2 = zcos2 * SIN( zplon2 ) + + distance = rearth * & + & ASIN( SQRT( ABS ( 1.0 - ( za1 * za2 + zb1 * zb2 + zc1 * zc2) ** 2) ) ) + + END FUNCTION distance diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/dom_oce.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/dom_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d9858b5ad4be836debfc4d2e9639b327536032f3 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/dom_oce.F90 @@ -0,0 +1 @@ +../../../src/OCE/DOM/dom_oce.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/enact2fb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/enact2fb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..a5f42f0d814272d2588d2964219fdce6ff2b4027 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/enact2fb.F90 @@ -0,0 +1,90 @@ +PROGRAM enact2fb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM corio2fb ** + !! + !! ** Purpose : Convert ENACT format profiles to feedback format + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! enact2fb.exe outputfile inputfile1 inputfile2 ... + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE obs_prof_io + USE convmerge + IMPLICIT NONE + ! + ! Command line arguments for output file and input files + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + ! + ! Input data + ! + TYPE(obfbdata), POINTER :: enactf(:) + INTEGER :: ninfiles,ntotenact,nmaxlev + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + ! + ! Output data + ! + TYPE(obfbdata) :: fbdata + ! + ! Loop variables + ! + INTEGER :: ia,ii,ij + ! + ! Get number of command line arguments + ! + nargs=IARGC() + IF (nargs < 1) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'enact2fb outputfile inputfile1 inputfile2 ...' + CALL abort() + ENDIF + CALL getarg(1,cdoutfile) + ! + ! Get input data + ! + ALLOCATE( enactf(MAX(nargs-1,1)) ) + ALLOCATE( cdinfile(nargs-1) ) + ntotenact = 0 + ninfiles = nargs - 1 + DO ia = 1,ninfiles + CALL getarg( ia + 1, cdinfile(ia) ) + CALL read_enactfile( TRIM(cdinfile(ia)), enactf(ia), 6, .TRUE., .FALSE. ) + WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia)) + WRITE(*,'(A,I9,A)')'has',enactf(ia)%nobs,' profiles' + ntotenact = ntotenact + enactf(ia)%nobs + nmaxlev = MAX( nmaxlev, enactf(ia)%nlev ) + ENDDO + IF (ninfiles==0) THEN + CALL init_obfbdata( enactf(1) ) + CALL alloc_obfbdata( enactf(1), 2, 0, 1, 0, 1, .FALSE. ) + enactf(1)%cname(1) = 'POTM' + enactf(1)%cname(2) = 'PSAL' + enactf(1)%coblong(1) = 'Potential temperature' + enactf(1)%coblong(2) = 'Practical salinity' + enactf(1)%cobunit(1) = 'Degrees Celsius' + enactf(1)%cobunit(2) = 'PSU' + enactf(1)%cextname(1) = 'TEMP' + enactf(1)%cextlong(1) = 'Insitu temperature' + enactf(1)%cextunit(1) = 'Degrees Celsius' + enactf(1)%cdjuldref = '19500101000000' + ENDIF + WRITE(*,'(A,I8)') 'Total profiles : ',ntotenact + ! + ! Merge and output the data. + ! + CALL conv_fbmerge( TRIM(cdoutfile), ninfiles, enactf ) + +END PROGRAM enact2fb diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbaccdata.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbaccdata.F90 new file mode 100644 index 0000000000000000000000000000000000000000..4e6ccf86e78b1f242f9f6c64b76158f651a9d555 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbaccdata.F90 @@ -0,0 +1,16 @@ +MODULE fbaccdata + USE fbacctype + IMPLICIT NONE + INTEGER, DIMENSION(:,:,:,:,:), ALLOCATABLE :: inum,inumov,inumbv + INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: inuma + REAL, DIMENSION(:,:,:,:,:), ALLOCATABLE :: zbias,zrms,zsdev,zomean,zmmean,& + & zoemea,zovmea,zbemea,zbvmea + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: zoamean + INTEGER, PARAMETER :: maxvars = 10 + REAL, DIMENSION(maxvars) :: zcheck + REAL, DIMENSION(maxvars) :: zhistmax, zhistmin, zhiststep + TYPE(histtype), DIMENSION(maxvars) :: hist + REAL, DIMENSION(maxvars) :: zxymax, zxymin, zxystep + TYPE(xytype), DIMENSION(maxvars) :: xy +END MODULE fbaccdata + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbacctype.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbacctype.F90 new file mode 100644 index 0000000000000000000000000000000000000000..42d4c37b7de193a2cf08654c6bdaa2109feb2f61 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbacctype.F90 @@ -0,0 +1,11 @@ +MODULE fbacctype + IMPLICIT NONE + TYPE histtype + INTEGER :: npoints + INTEGER, POINTER, DIMENSION(:,:,:,:,:) :: nhist + END TYPE histtype + TYPE xytype + INTEGER :: npoints + INTEGER, POINTER, DIMENSION(:,:,:,:,:,:) :: nxy + END TYPE xytype +END MODULE fbacctype diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbcomb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbcomb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..891a1860f9799c6af8e4cf743b5b3852aa171344 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbcomb.F90 @@ -0,0 +1,182 @@ +PROGRAM fbcomb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbcomb ** + !! + !! ** Purpose : Combine MPI decomposed feedback files into one file + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! fbcomb.exe outputfile inputfile1 inputfile2 ... + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE toolspar_kind + USE obs_fbm + USE index_sort + IMPLICIT NONE + ! + ! Command line arguments for output file and input file + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + ! + ! Input data + ! + TYPE(obfbdata),POINTER :: obsdata(:) + INTEGER :: ninfiles,ntotobs,nlev + ! + ! Time sorting arrays + ! + REAL(KIND=dp),ALLOCATABLE :: zsort(:,:) + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + INTEGER :: iwmo + ! + ! Output data + ! + TYPE(obfbdata) :: obsoutdata + ! + ! Loop variables + ! + INTEGER :: ia,iv,ii,ij + ! + ! Get number of command line arguments + ! + nargs = IARGC() + IF ( nargs < 2 ) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'fbcomb outputfile inputfile1 inputfile2 ...' + CALL abort() + ENDIF + CALL getarg( 1, cdoutfile ) + ! + ! Get input data + ! + ALLOCATE( obsdata( nargs - 1 ) ) + ALLOCATE( cdinfile( nargs - 1 ) ) + ntotobs = 0 + ninfiles = nargs - 1 + DO ia=1, ninfiles + CALL getarg( ia+1, cdinfile(ia) ) + CALL init_obfbdata( obsdata(ia) ) + CALL read_obfbdata( TRIM(cdinfile(ia)), obsdata(ia) ) + WRITE(*,'(2A)')'File = ', TRIM(cdinfile(ia)) + WRITE(*,'(A,I9,A)')'has', obsdata(ia)%nobs, ' observations' + ntotobs = ntotobs + obsdata(ia)%nobs + ENDDO + WRITE(*,'(A,I8)') 'Total obsfiles : ',ntotobs + ! + ! Check that the data is confirming + ! + DO ia=2, ninfiles + IF ( obsdata(ia)%cdjuldref /= obsdata(1)%cdjuldref ) THEN + WRITE(*,*)'Different julian date reference. Aborting' + CALL abort + ENDIF + IF ( obsdata(ia)%nvar /= obsdata(1)%nvar ) THEN + WRITE(*,*)'Different number of variables. Aborting' + CALL abort + ENDIF + IF (obsdata(ia)%nadd /= obsdata(1)%nadd ) THEN + WRITE(*,*)'Different number of additional entries. Aborting' + CALL abort + ENDIF + IF ( obsdata(ia)%next /= obsdata(1)%next ) THEN + WRITE(*,*)'Different number of additional variables. Aborting' + CALL abort + ENDIF + IF ( obsdata(ia)%lgrid .NEQV. obsdata(1)%lgrid ) THEN + WRITE(*,*)'Inconsistent grid search info. Aborting' + CALL abort + ENDIF + DO iv=1, obsdata(ia)%nvar + IF ( obsdata(ia)%cname(iv) /= obsdata(1)%cname(iv) ) THEN + WRITE(*,*)'Variable name ', TRIM(obsdata(ia)%cname(iv)), & + & ' is different from ', TRIM(obsdata(1)%cname(iv)), & + & '. Aborting' + CALL abort + ENDIF + IF ( obsdata(1)%lgrid ) THEN + IF ( obsdata(ia)%cgrid(iv) /= obsdata(1)%cgrid(iv) ) THEN + IF (obsdata(1)%nobs==0) THEN + obsdata(1)%cgrid(iv) = obsdata(ia)%cgrid(iv) + ELSE + IF (obsdata(ia)%nobs>0) THEN + WRITE(*,*)'Grid name ', TRIM(obsdata(ia)%cgrid(iv)), & + & ' is different from ', & + & TRIM(obsdata(1)%cgrid(iv)), '. Aborting' + CALL abort + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + DO iv=1,obsdata(ia)%nadd + IF ( obsdata(ia)%caddname(iv) /= obsdata(1)%caddname(iv) ) THEN + WRITE(*,*)'Additional name ', TRIM(obsdata(ia)%caddname(iv)), & + & ' is different from ', TRIM(obsdata(1)%caddname(iv)), & + & '. Aborting' + CALL abort + ENDIF + ENDDO + DO iv=1,obsdata(ia)%next + IF ( obsdata(ia)%cextname(iv) /= obsdata(1)%cextname(iv) ) THEN + WRITE(*,*)'Extra name ', TRIM(obsdata(ia)%cextname(iv)), & + & ' is different from ', TRIM(obsdata(1)%cextname(iv)), & + & '. Aborting' + CALL abort + ENDIF + ENDDO + ENDDO + ! + ! Construct sorting arrays + ! + ALLOCATE( zsort(5,ntotobs), iset(ntotobs), & + & inum(ntotobs), iindex(ntotobs)) + ii = 0 + DO ia = 1,ninfiles + DO ij = 1,obsdata(ia)%nobs + ii = ii+1 + zsort(1,ii) = obsdata(ia)%ptim(ij) + zsort(2,ii) = obsdata(ia)%pphi(ij) + zsort(3,ii) = obsdata(ia)%plam(ij) + iwmo = TRANSFER( obsdata(ia)%cdwmo(ij)(1:4), iwmo ) + zsort(4,ii) = iwmo + iwmo = TRANSFER( obsdata(ia)%cdwmo(ij)(5:8), iwmo ) + zsort(5,ii) = iwmo + iset(ii) = ia + inum(ii) = ij + ENDDO + ENDDO + ! + ! Get indexes for time sorting. + ! + CALL index_sort_dp_n(zsort,5,iindex,ntotobs) + ! + ! Allocate output data + ! + nlev = -1 + DO ia = 1,ninfiles + IF ( obsdata(ia)%nlev > nlev ) nlev = obsdata(ia)%nlev + ENDDO + CALL init_obfbdata( obsoutdata ) + CALL alloc_obfbdata( obsoutdata, obsdata(1)%nvar, ntotobs, nlev, & + & obsdata(1)%nadd, obsdata(1)%next, obsdata(1)%lgrid ) + ! + ! Copy input data into output data + ! + CALL merge_obfbdata( ninfiles, obsdata, obsoutdata, iset, inum, iindex ) + ! + ! Save output data + ! + CALL write_obfbdata ( TRIM(cdoutfile), obsoutdata ) + +END PROGRAM fbcomb diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c51c9e4343539c7e8d15e67cf637c739af2a3c7b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate.F90 @@ -0,0 +1,327 @@ +PROGRAM fbgenerate + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbmatchup ** + !! + !! ** Purpose : Generate a feedback file of pseudo obs + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : Read in data from a namelist file and generate a feedback + !! file of pseudo observations + !! + !! Usage: For any parameter, if 3 values are given, these will be treated as + !! bounds (start, stop, step), EXCEPT when only 3 values are expected. + !! + !! For spatial coord, date and time + !! 3 values with nlat=3 will be treated as three separate values + !! 3 values with nobs=3 will be treated as three separate values + !! 3 values with nobs>3 will be treated as a start, end and step + !! Giving a FillValue in one of namelist entries may have unexpected consequences + !! e.g., discarding rest of list of values + !! + !! For time bounds, start(HHMM), end(HHMM), step(minutes) + !! For date bounds, start(YYYYMMDD), end(YYYYMMDD), step(days) + !! + !! To split obs evenly in time, date and time should be given two values + !! describing the start and end times. + !! + !! Can use logical flag to shuffle timestamps to remove position-time correlation. + !! + !! Can use logical flag to add uniformly sampled perturbation (up to defined limit) to positions + !! + !! For obs values, can list either single value for all (x,y,z) + !! or can specify single profile for all (x,y) + !! or can specify all values 1 profile after another. + !! + !! In namelist to set vals(nlev,nobs,nvar) + !! set all obs (for variable 1) at all levels to one value + !! vals(:,:,1)= 1.0 + !! set all obs (for variable 2) at all levels to one value + !! vals(:,:,2)= 35.0 + !! set one profile (for variable 1), apply to all + !! vals(:,:,1)= 1.0, 2.0, 3.0, 4.0 + !! set all profiles profile (for variable 1) + !! vals(:,1,1)= 1.0, 2.0, 3.0, 4.0 + !! vals(:,2,1)= 1.0, 2.0, 3.0, 4.0 + !! vals(:,nobs,1)= 1.0, 2.0, 3.0, 4.0 + !! + !! + !! Limitations: Uses an allocatable array in a namelist. This is not meant + !! to be allowed in F95, but it works when compiled with xlf90_r + !! (and is allowed in Fortran2003). + !! + !! Forces same depth levels on all profiles. + !! + !! History : + !! ! 2014 (J. Waters) Initial version + !! ! 2014-02 (R. King) Adapted for profiles and bounds on vars + !!---------------------------------------------------------------------- + USE obs_fbm + USE fbgenerate_coords + USE test_fbgenerate + IMPLICIT NONE + TYPE(obfbdata) :: fbobsdata + CHARACTER(len=256) :: filenameout +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nobs, nvar, nlev, ntyp, nadd, next, lgrid, ierr, nlats, nlons + INTEGER :: i, j + INTEGER :: FillValue_int + REAL(KIND=fbdp) :: FillValue_real + INTEGER, ALLOCATABLE :: dates(:), times(:) + REAL(KIND=fbdp), ALLOCATABLE :: julian_dates(:) + REAL(KIND=fbdp) :: phys_spacing, lat_step, current_lat, perturb_limit + REAL(KIND=fbdp), ALLOCATABLE :: lats(:), lons(:), deps(:), vals(:,:,:), model_vals(:,:,:) + CHARACTER(LEN=ilenwmo) :: cdwmo, cdtyp + CHARACTER(LEN=ilenwmo), ALLOCATABLE :: variable(:) + CHARACTER(LEN=ilenlong), ALLOCATABLE :: variable_longname(:) + CHARACTER(LEN=ilenunit), ALLOCATABLE :: variable_units(:) + LOGICAL, PARAMETER :: test_prog = .FALSE. + LOGICAL :: ln_listobs, ln_physpace, ln_gridobs, ln_shuffletimes, ln_perturb_posn + REAL(KIND=fbdp), PARAMETER :: earth_radius = 6371.0_fbdp + REAL(KIND=fbdp), PARAMETER :: pi = 3.14159_fbdp + + !!!! set up default values and read in namelist namfbgen.in !!!!!!!!!!!!!!!!!!!! + NAMELIST/namfbgeneratesetup/ln_listobs,ln_physpace,ln_gridobs,ln_shuffletimes,ln_perturb_posn,perturb_limit,nobs,nlats,nlons,phys_spacing,nlev,nvar,nadd + NAMELIST/namfbgenerate/ntyp,lats,lons,deps,times,dates,vals,model_vals,variable,variable_longname,variable_units,cdwmo,cdtyp + + IF (test_prog) THEN + WRITE(*,*) "In test mode:" + CALL tester + ELSE + + + IF (iargc()/=1) THEN + WRITE(*,*)'Usage:' + WRITE(*,*)'fbgenerate <output filename>' + CALL abort + ENDIF + + CALL getarg(1,filenameout) + + ! set up default values for namfbgeneratesetup + ln_listobs=.FALSE. + ln_physpace=.FALSE. + ln_gridobs=.FALSE. + ln_shuffletimes=.FALSE. + ln_perturb_posn=.FALSE. + nobs=0 + nlats=0 + nlons=0 + phys_spacing =100.0_fbdp + nlev=0 + nvar=0 + + ! Read in number of obs and number of depths from namelist (before reading other variables) + FillValue_real = 99999.0_fbdp + FillValue_int = 99999 + OPEN(10,file='namfbgen.in') + READ(10,namfbgeneratesetup) + CLOSE(10) + + ! Calculate number of observations + IF ((ln_gridobs) .AND. (.NOT.ln_physpace) .AND. (.NOT.ln_listobs)) THEN + IF( ( nlats .LE. 0 ) .OR. (nlons .LE. 0) )THEN + WRITE(6,*)'ERROR: nlats and nlons must be greater than 0 if ln_gridobs set' + ELSE + nobs=nlats*nlons + WRITE(*,*) "Constructing a grid of lat-lons" + ENDIF + + ELSE IF ((.NOT.ln_gridobs) .AND. (ln_physpace) .AND. (.NOT.ln_listobs)) THEN + IF ((phys_spacing .LE. 0) .OR.(phys_spacing .GE. earth_radius)) THEN + WRITE(6,*)'ERROR: phys_spacing must be greater than 0 and less than 6371km.' + ELSE + nlats = INT(pi * earth_radius / phys_spacing) + IF (MOD(nlats,2)==0) nlats=nlats-1 ! Ensure nlats is odd to have even number around equator. + lat_step = 180.0_fbdp / (nlats-1) + nobs=0 + current_lat=0.0_fbdp + ! Sum up number of lons at each latitude + DO i=1,(nlats-1)/2 + current_lat = current_lat + lat_step * (pi/180.0_fbdp) + nobs = nobs + INT(2.0_fbdp * pi * earth_radius * cos(current_lat) / phys_spacing) + END DO + nobs = nobs * 2 + INT(2.0_fbdp * pi * earth_radius / phys_spacing) + WRITE(*,*) "Using a physical seperation of ~", INT(phys_spacing),"km" + END IF + + ELSE IF ((.NOT.ln_gridobs) .AND. (.NOT.ln_physpace) .AND. (ln_listobs)) THEN + IF( nobs .LE. 0 ) THEN + WRITE(6,*)'ERROR: nobs must be greater than 0' + ENDIF + WRITE(*,*) "Constructing a list of lat-lons" + ELSE + WRITE(*,*)'ERROR: one (and only one) of the logical flags must be true!' + CALL abort + ENDIF + + + ALLOCATE(dates(nobs), & + times(nobs), & + julian_dates(nobs), & + lats(nobs), & + lons(nobs), & + deps(nlev), & + variable(nvar), & + variable_longname(nvar), & + variable_units(nvar),& + vals(nlev,nobs,nvar),& + model_vals(nlev,nobs,nvar),& + STAT=ierr & + ) + IF (ierr /= 0) THEN + WRITE(*,*) "Could not allocate observation arrays:" + WRITE(*,*) "dates(", nobs, ")" + WRITE(*,*) "times(", nobs, ")" + WRITE(*,*) "lats(", nobs, ")" + WRITE(*,*) "lons(", nobs, ")" + WRITE(*,*) "deps(", nlev, ")" + WRITE(*,*) "variable(", nvar, ")" + WRITE(*,*) "variable_longname(", nvar, ")" + WRITE(*,*) "variable_units(", nvar, ")" + WRITE(*,*) "vals(", nlev, nobs, nvar, ")" + WRITE(*,*) "model_vals(", nlev, nobs, nvar, ")" + + CALL abort + END IF + + + !!!! set up default values and read in namelist namfbgen.in !!!!!!!!!!!!!!!!!!!! + ntyp=-1 + lats(:) = FillValue_real + lons(:) = FillValue_real + deps(:) = FillValue_real + times(:) = FillValue_int + dates(:) = FillValue_int + vals(:,:,:) = FillValue_real + model_vals(:,:,:) = FillValue_real + variable=REPEAT('X',ilenwmo) + variable_longname=REPEAT('X',ilenwmo) + variable_units=REPEAT('X',ilenwmo) + cdwmo=REPEAT('X',ilenwmo) !station identifier + cdtyp="90" !station type + + WRITE(*,*) "Creating a fdbk file with", nobs, "observations" + WRITE(*,*) "with", nvar, "variables and",nlev, "depths." + + OPEN(10,file='namfbgen.in') + READ(10,namfbgenerate) + CLOSE(10) + + ! Use bounds to construct the full arrays of coords and values + + IF (ln_physpace) THEN + CALL set_spatial_coords_physpace(lats,lons,nobs,FillValue_real,phys_spacing) + ELSE IF (ln_gridobs) THEN + CALL set_spatial_coords_grid(lats,lons,nobs,nlats,nlons,FillValue_real) + ELSE + CALL set_spatial_coords(lats,lons,nobs,FillValue_real) + END IF + + ! Add random perturbation to position if ln_perturb_posn=.TRUE. + IF (ln_perturb_posn) CALL perturb_positions(lats,lons,perturb_limit) + + CALL set_datetime(dates,times,julian_dates,nobs,FillValue_int) + CALL set_depths(deps,nlev,FillValue_real) + CALL set_obs_values(vals,nvar,nobs,nlev,FillValue_real) + CALL set_obs_values(model_vals,nvar,nobs,nlev,FillValue_real) + + + !nadd=1 ! Hx + next=0 ! e.g. TEMP + ! Add TEMP as extra variable if POTM is defined. + DO i=1,nvar + IF (variable(i)(1:4) == "POTM") THEN + next=1 ! e.g. If set to zero, will not add extra TEMP variable + EXIT + END IF + END DO + + CALL init_obfbdata(fbobsdata) + + !!!! Allocate the obfb type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL alloc_obfbdata( fbobsdata, nvar, nobs, nlev, nadd, next, .FALSE.) + + !!!! Read data specified in the namelist into obfd type!!!!!!!!!!!!!!! + + fbobsdata%cname = variable(:) + fbobsdata%coblong = variable_longname(:) + fbobsdata%cobunit = variable_units(:) + fbobsdata%cdjuldref = "19500101000000" + fbobsdata%cdwmo = cdwmo + fbobsdata%cdtyp = cdtyp + + ! Add model counterpart values if nadd=1 + IF (nadd > 0) THEN + IF (nadd /= 1) THEN + CALL abort + WRITE(*,*) "Not set-up to add more than 1 additional variable." + ELSE + fbobsdata%caddname = "Hx" + fbobsdata%caddlong(1,:) = "Model interpolated " // variable_longname(:) + fbobsdata%caddunit(1,:) = variable_units(:) + fbobsdata%padd(:,:,1,:)=model_vals(:,:,:) + END IF + END IF + + ! Add TEMP as extra variable if POTM is defined. + IF (next==1) THEN + fbobsdata%cextname = "TEMP" + END IF + + ! set up pos/time variables + fbobsdata%plam(:)=lons(:) + fbobsdata%pphi(:)=lats(:) + DO i=1,nobs + fbobsdata%pdep(:,i)=deps(:) + END DO + + + fbobsdata%ptim(:)= julian_dates(:) + + ! Shuffle the time array to spread the profiles across the time period + IF (ln_shuffletimes) CALL shuffle(fbobsdata%ptim) + + ! read in variable data and flags + fbobsdata%ivqc(:,:)=1 + fbobsdata%ivqcf(:,:,:)=1 + fbobsdata%ivlqc(:,:,:)=1 + fbobsdata%pob(:,:,:)=vals(:,:,:) + + !set up all QC flags + fbobsdata%ioqc(:)=1 + fbobsdata%ioqcf(:,:)=0 + fbobsdata%ipqc(:)=1 + fbobsdata%ipqcf(:,:)=0 + fbobsdata%idqc(:,:)=1 !0 + fbobsdata%idqcf(:,:,:)=0 + fbobsdata%itqc(:)=1 + fbobsdata%kindex(:)=0 + + !!!! Write out the obfb type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL write_obfbdata(TRIM(filenameout),fbobsdata) + + DEALLOCATE(dates, & + times, & + julian_dates,& + lats, & + lons, & + deps, & + variable, & + variable_longname, & + variable_units, & + vals, & + model_vals & + ) + + END IF !test prog + + +END PROGRAM fbgenerate + + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate_coords.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate_coords.F90 new file mode 100644 index 0000000000000000000000000000000000000000..8d8ea2434ffe07826c522d2617c736f4a374ae57 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbgenerate_coords.F90 @@ -0,0 +1,509 @@ +MODULE fbgenerate_coords +USE obs_fbm +USE date_utils + +CONTAINS + + REAL(KIND=fbdp) FUNCTION fb_dates(timein,datein) + IMPLICIT NONE + INTEGER, INTENT(IN) :: timein ! Format: HHMM + INTEGER, INTENT(IN) :: datein ! Format: YYYYMMDD + INTEGER :: iyea,imon,iday + INTEGER :: ihr,imin,isec + + iyea=datein/10000 + imon=datein/100-iyea*100 + iday=datein-iyea*10000-imon*100 + + ihr = timein/100 + imin = timein - ihr*100 + isec = 0 + + CALL greg2jul(isec,imin,ihr,iday,imon,iyea,fb_dates) + + END FUNCTION fb_dates + + + + SUBROUTINE set_spatial_coords(lats,lons,n,FillVal) + IMPLICIT NONE + INTEGER :: i, j, k, p, nlats, nlons, nlats_in_list, nlons_in_list + INTEGER, INTENT(IN) :: n + REAL(KIND=fbdp), INTENT(INOUT) :: lats(:), lons(:) + REAL(KIND=fbdp) :: FillVal + + ! A single non-FillVal value should be replicated n times + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + ! unless n is three, in which case treat as list, not bounds. + ! A full list of n non-FillVals should be left unaltered. + + !Find number of lats and lons + ! by finding number of non-FillVal entries in arrays + ! and expanding bounds if necessary + + nlats_in_list = last_element(lats,FillVal) + nlons_in_list = last_element(lons,FillVal) + + !Expand bounds only if 3 values given and number obs>3 + IF (nlats_in_list == 1) THEN + lats(1:nlats) = lats(1) + ELSE IF ((nlats_in_list==3).AND.((n>3))) THEN ! Treat as list of three, not bounds + CALL expand_bounds(lats, FillVal) + END IF + + IF (nlons_in_list == 1) THEN + lons(1:nlons) = lons(1) + ELSE IF ((nlons_in_list==3).AND.((n>3))) THEN ! Treat as list of three, not bounds + CALL expand_bounds(lons, FillVal) + END IF + + nlats = last_element(lats,FillVal) + nlons = last_element(lons,FillVal) + + IF ((n /= nlats) .AND. (n /= nlons)) THEN + WRITE(*,*) "ERROR: Number of lat/lons not equal to nobs", nlats, nlons, n + CALL abort + END IF + + END SUBROUTINE set_spatial_coords + + + SUBROUTINE set_spatial_coords_grid(lats,lons,n,nlats,nlons,FillVal) + IMPLICIT NONE + INTEGER :: i, j, k, p, nlats_in_list, nlons_in_list + INTEGER, INTENT(IN) :: n, nlats, nlons + REAL(KIND=fbdp), INTENT(INOUT) :: lats(:), lons(:) + REAL(KIND=fbdp), ALLOCATABLE :: tmp_lats(:), tmp_lons(:) + REAL(KIND=fbdp) :: FillVal + + ! A single non-FillVal value should be replicated n times + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + ! unless n is three, in which case treat as list, not bounds. + ! A full list of n non-FillVals should be left unaltered. + + !Find number of lats and lons in list + ! by finding number of non-FillVal entries in arrays + ! and then expand bounds if necessary + + nlats_in_list = last_element(lats,FillVal) + nlons_in_list = last_element(lons,FillVal) + + !Expand bounds only if 3 values given and number lats (or lons) not equal to 3 + IF (nlats_in_list == 1) THEN + lats(1:nlats) = lats(1) + ELSE IF ((nlats_in_list==3).AND.((nlats>3))) THEN ! Treat as bounds + CALL expand_bounds(lats, FillVal) + END IF + + IF (nlons_in_list == 1) THEN + lons(1:nlons) = lons(1) + ELSE IF ((nlons_in_list==3).AND.((nlons>3))) THEN ! Treat as bounds + CALL expand_bounds(lons, FillVal) + END IF + + nlats_in_list = last_element(lats,FillVal) + nlons_in_list = last_element(lons,FillVal) + + + IF ((nlats_in_list * nlons_in_list) == n) THEN + ALLOCATE(tmp_lons(n)) + ALLOCATE(tmp_lats(n)) + k = 0 + p = 0 + DO i = 1, nlats + p = p + 1 + DO j = 1, nlons + k = k + 1 + tmp_lons(k) = lons(j) + tmp_lats(k) = lats(p) + END DO + END DO + lats(:) = tmp_lats(:) + lons(:) = tmp_lons(:) + DEALLOCATE(tmp_lons) + DEALLOCATE(tmp_lats) + ELSE + WRITE(*,*) + WRITE(*,*) "ERROR: Number of lat * lon values not equal to nobs", nlats_in_list, nlons_in_list, n + CALL abort + END IF + + END SUBROUTINE set_spatial_coords_grid + + + SUBROUTINE set_spatial_coords_physpace(lats,lons,n,FillVal,phys_spacing) + IMPLICIT NONE + INTEGER :: i, j, k, nlats, nlons + INTEGER, INTENT(IN) :: n + REAL(KIND=fbdp), INTENT(INOUT) :: lats(:), lons(:) + REAL(KIND=fbdp), ALLOCATABLE :: tmp_lats(:) + REAL(KIND=fbdp) :: FillVal + REAL(KIND=fbdp), PARAMETER :: earth_radius = 6371.0_fbdp ! km + REAL(KIND=fbdp), PARAMETER :: pi = 3.141592654_fbdp + REAL(KIND=fbdp), INTENT(IN) :: phys_spacing + REAL(KIND=fbdp) :: lat_step + + ! Use physical spacing to set lats and lons + + nlats = INT(pi * earth_radius / phys_spacing) + IF (MOD(nlats,2)==0) nlats=nlats-1 ! Ensure nlats is odd to have even number around equator. + + ALLOCATE(tmp_lats(nlats)) + + lat_step = 180.0_fbdp / (nlats-1) + + tmp_lats(1) = 0.0_fbdp + DO i=1,(nlats-1)/2 + tmp_lats(i+1) = tmp_lats(i) + lat_step + tmp_lats(((nlats-1)/2)+i+1) = tmp_lats(i+1) * (-1.0_fbdp) + END DO + + k = 0 + DO i=1,nlats + nlons = INT(2.0_fbdp * pi * earth_radius * cos(tmp_lats(i)* (pi/180.0_fbdp)) / phys_spacing) + IF (nlons>0) THEN + DO j = 1, nlons + k = k + 1 + lons(k) = REAL(j-1) * 360.0_fbdp / nlons + lats(k) = tmp_lats(i) + END DO + END IF + END DO + DEALLOCATE(tmp_lats) + + END SUBROUTINE set_spatial_coords_physpace + + + SUBROUTINE expand_bounds(array, fillval) + ! + ! Checks if there are three entries and expands bounds. + ! + IMPLICIT NONE + INTEGER :: i, nentries + REAL(KIND=fbdp), INTENT(INOUT) :: array(:) + REAL(KIND=fbdp), INTENT(IN) :: fillval + REAL(KIND=fbdp) :: nsteps, start, step + + ! Find number of elements given in list + nentries = last_element(array, fillval) + + IF (nentries==3) THEN ! Bounds given + nsteps = (array(2) - array(1)) / array(3) + IF ((array(2) < array(1)) .AND. (array(3) >= 0.0)) THEN + WRITE(*,*) "Error: if upper bound is less than lower bound, step must be negative.", array + CALL abort + ELSE IF ( NINT(nsteps)+1 > SIZE(array) ) THEN + WRITE(*,*) "Error: bounds not compatible with length of array.", array + WRITE(*,*) "Error: bounds not compatible with length of array.", nsteps + CALL abort + END IF + start = array(1) + step = array(3) + DO i=1,NINT(nsteps)+1 + array(i) = start + (i-1)*step + END DO + END IF + + END SUBROUTINE expand_bounds + + + + INTEGER FUNCTION last_element(array,fillval) + ! + ! Returns index of the last non-fill value element in a list + ! Will return 1, even in first element is the FillValue + ! + IMPLICIT NONE + REAL(KIND=fbdp), INTENT(IN) :: array(:), fillval + INTEGER :: i + + last_element = 1 + IF (SIZE(array) > 1) THEN + DO i=2, SIZE(array) + IF (array(i) /= fillval) THEN + last_element = i + END IF + END DO + END IF + + END FUNCTION last_element + + + + SUBROUTINE set_depths(array,n,FillVal) + IMPLICIT NONE + INTEGER :: i + INTEGER, INTENT(IN) :: n + REAL(KIND=fbdp), INTENT(INOUT) :: array(:) + REAL(KIND=fbdp) :: FillVal + REAL(KIND=fbdp) :: start, step, nstep + ! Top bound not necessarily inclusive - will use start, step and number of obs + + ! A single non-FillVal value should be replicated n times + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + ! unless n is three, in which case treat as list, not bounds. + ! A full list of n non-FillVals should be left unaltered. + IF (n==1) THEN + array(:) = array(1) + ELSE IF ((n > 1) .AND. (array(2)==FillVal)) THEN + array(:) = array(1) + ELSE IF ((n==2) .AND. (array(2)/=FillVal)) THEN + array(:) = array(:) + ELSE IF (n==3) THEN ! Treat as list of three, not bounds + array(:) = array(:) + ELSE IF ((n>=4) .AND. (array(4)==FillVal)) THEN ! Assume start, stop, step + nstep = (array(2) - array(1)) / array(3) + IF ((array(2) < array(1)) .AND. (array(3) >= 0.0)) THEN + WRITE(*,*) "Error: if upper bound is less than lower bound, step must be negative.", array + CALL abort + ELSE IF ( ( nstep < (0.99 * real(n-1)) ) .OR. & + ( nstep > (1.01 * real(n-1)) ) ) THEN + WRITE(*,*) "Error: depth bounds not compatible.", array + WRITE(*,*) "Error: depth bounds not compatible.", nstep + CALL abort + END IF + start = array(1) + step = array(3) + DO i=1,n + array(i) = start + (i-1)*step + END DO + END IF + + END SUBROUTINE set_depths + + + + + + SUBROUTINE set_datetime(date,time,julian_date,n,FillVal) + ! + ! Transform input array from m values describing n dates to a list of n dates. + ! + IMPLICIT NONE + INTEGER :: i + INTEGER, INTENT(IN) :: n + INTEGER, INTENT(INOUT) :: date(:), time(:) + INTEGER :: FillVal + REAL(KIND=fbdp), INTENT(INOUT) :: julian_date(:) + REAL(KIND=fbdp) :: start, step, finish + + ! Check if user has supplied start and end times to be split amongst number of obs + ! (i.e. more than 2 obs, but only 2 dates and 2 times given.) + IF ((n>2) .AND. (date(2)/=FillVal) .AND. (date(3)==FillVal) & + & .AND. (time(2)/=FillVal) .AND. (time(3)==FillVal)) THEN + + !work out JD of each + start = fb_dates(time(1),date(1)) + finish = fb_dates(time(2),date(2)) + + ! use info to calc step + step = ( finish - start ) / n + ! calc all JDs and put output in dates + DO i=1,n + ! Could make this an elemental function if dateutils were pure funcs + julian_date(i)= start + (i-1)*step + END DO + + ELSE + CALL set_date(date,n,FillVal) + CALL set_time(time,n,FillVal) + ! Replace dates with JD including time info + DO i=1,n + ! Could make this an elemental function if dateutils were pure funcs + julian_date(i)= fb_dates(time(i),date(i)) + END DO + END IF + + + END SUBROUTINE set_datetime + + + SUBROUTINE set_date(array,n,FillVal) + ! + ! Transform input array from m values describing n dates to a list of n dates. + ! + IMPLICIT NONE + INTEGER :: i + INTEGER, INTENT(IN) :: n + INTEGER, INTENT(INOUT) :: array(:) + INTEGER :: FillVal + INTEGER :: start, step, diff + ! Top bound not necessarily inclusive - will use start, step and number of obs + + ! A single non-FillVal value should be replicated n times + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + ! unless n is three, in which case treat as list, not bounds. + ! A full list of n non-FillVals should be left unaltered. + IF (n==1) THEN + array(:) = array(1) + ELSE IF ((n > 1) .AND. (array(2)==FillVal)) THEN + array(:) = array(1) + ELSE IF ((n==2) .AND. (array(2)/=FillVal)) THEN + array(:) = array(:) + ELSE IF (n==3) THEN ! Treat as list of three, not bounds + array(:) = array(:) + ELSE IF ((n>=4) .AND. (array(4)==FillVal)) THEN ! Assume start, stop, step + diff = diffdate(array(2),array(1)) ! in number of days + IF ((array(2) < array(1)) .AND. (array(3) >= 0)) THEN + WRITE(*,*) "Error: if upper bound is less than lower bound, step must be negative.", array + CALL abort + ELSE IF ( ( diff / ABS(array(3)) ) /= (n-1) ) THEN + WRITE(*,*) "Error: date bounds not compatible.", array + CALL abort + END IF + start = array(1) + step = array(3) + DO i=1,n + CALL add_days_to_date(start,(i-1)*step,array(i)) + END DO + END IF + + END SUBROUTINE set_date + + + + SUBROUTINE set_time(array,n,FillVal) + ! + ! Transform input array from m (m<=n) values describing n times to a list of n times. + ! + IMPLICIT NONE + INTEGER :: i + INTEGER, INTENT(IN) :: n + INTEGER, INTENT(INOUT) :: array(:) + INTEGER :: FillVal + INTEGER :: start, step, nstep + ! Top bound not necessarily inclusive - will use start, step and number of obs + + ! A single non-FillVal value should be replicated n times + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + ! unless n is three, in which case treat as list, not bounds. + ! A full list of n non-FillVals should be left unaltered. + IF (n==1) THEN + array(:) = array(1) + ELSE IF ((n > 1) .AND. (array(2)==FillVal)) THEN + array(:) = array(1) + ELSE IF ((n==2) .AND. (array(2)/=FillVal)) THEN + array(:) = array(:) + ELSE IF (n==3) THEN ! Treat as list of three, not bounds + array(:) = array(:) + ELSE IF ((n>=4) .AND. (array(4)==FillVal)) THEN ! Assume start, stop, step + IF (array(3)<0) nstep = difftime(array(2),array(1)) / ABS(array(3)) + IF (array(3)>=0) nstep = difftime(array(1),array(2)) / ABS(array(3)) + IF ( nstep /= (n-1) ) THEN + WRITE(*,*) "Error: time bounds not compatible.", array + CALL abort + END IF + start = array(1) + step = array(3) + DO i=1,n + array(i) = add_mins_to_time(start,(i-1)*step) + END DO + END IF + + END SUBROUTINE set_time + + + + SUBROUTINE set_obs_values(array,p,n,m,FillVal) + ! + ! n profiles at m depths + ! + IMPLICIT NONE + INTEGER :: i, j, k + INTEGER, INTENT(IN) :: n, m, p + REAL(KIND=fbdp), INTENT(INOUT) :: array(:,:,:) ! (nlevels, nprofiles, nvars) = (m,n,p) + REAL(KIND=fbdp) :: FillVal + + + DO k=1,p + IF ((k > 1) .AND. (array(1,1,k) == FillVal)) THEN ! set to same values as first variable + array(:,:,k) = array(:,:,1) + ELSE + IF ((n==1).AND.(m==1)) THEN + array(:,:,k) = array(1,1,k) + + ! If mult depths, but not specified, set all to one value + ELSE IF ((m > 1) .AND. (array(2,1,k) == FillVal)) THEN + array(:,:,k) = array(1,1,k) + + ! If mult profiles and mult depths and only one value set in first profile + ELSE IF ((n > 1) .AND. (m > 1) .AND. (array(2,1,k) == FillVal)) THEN + array(:,:,k) = array(1,1,k) + + ! If mult profiles and mult depths and only one first profile set + ELSE IF ((n > 1) .AND. (m > 1) .AND. (array(1,2,k) == FillVal)) THEN + DO j=1,m + array(j,:,k) = array(j,1,k) + END DO + + ELSE + array(:,:,k) = array(:,:,k) + END IF + END IF + END DO + + END SUBROUTINE set_obs_values + + + ! Unbiased shuffle of array + SUBROUTINE shuffle(a) + REAL(KIND=fbdp), INTENT(INOUT) :: a(:) + INTEGER :: i, randpos + REAL(KIND=fbdp) :: r, temp + + CALL random_seed() + DO i = SIZE(a), 2, -1 + CALL random_number(r) + randpos = int(r * i) + 1 + temp = a(randpos) + a(randpos) = a(i) + a(i) = temp + END DO + + END SUBROUTINE shuffle + + + ! Add a random perturbation to the lats and lons + ! Perturbation is sampled from a uniform distribution +/-perturb_limit + SUBROUTINE perturb_positions(lats,lons,perturb_limit) + INTEGER :: i + REAL(KIND=fbdp), INTENT(INOUT) :: lats(:), lons(:) + REAL(KIND=fbdp), INTENT(IN) :: perturb_limit + REAL(KIND=fbdp) :: randpos, lat_perturb, lon_perturb + REAL(KIND=fbdp), PARAMETER :: earth_radius = 6371.0_fbdp + REAL(KIND=fbdp), PARAMETER :: pi = 3.141592654_fbdp + + IF ( SIZE(lats) /= SIZE(lons) ) THEN + WRITE(*,*) "Error: different number of lat and lon elements", SIZE(lats), SIZE(lons) + CALL abort + END IF + + CALL random_seed() + + ! Convert physical sep into a latidue sep in degrees + lat_perturb = 360.0_fbdp * perturb_limit / (2.0_fbdp * pi * earth_radius) + + DO i=1,SIZE(lats) + + ! Perturb lats first, as lon conversion uses lat + CALL random_number(randpos) + lats(i) = lats(i) + randpos*lat_perturb + IF (lats(i) > 90.0_fbdp) lats(i) = 180.0_fbdp - lats(i) + IF (lats(i) < -90.0_fbdp) lats(i) = (lats(i) + 180.0_fbdp) * (-1.0_fbdp) + + ! Use lat to convert physical size to delta_longitude + IF (ABS(lats(i)) == 90.0_fbdp) THEN + lon_perturb = 0.0_fbdp + ELSE + lon_perturb = 360.0_fbdp * perturb_limit / (2.0_fbdp * pi * earth_radius * cos(lats(i)*(pi/180.0_fbdp))) + END IF + CALL random_number(randpos) + lons(i) = lons(i) + randpos*lon_perturb + IF (lons(i) >= 360.0_fbdp) lons(i) = lons(i) - 360.0_fbdp + IF (lons(i) < 0.0_fbdp) lons(i) = lons(i) + 360.0_fbdp + + END DO + + END SUBROUTINE perturb_positions + +END MODULE fbgenerate_coords diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbmatchup.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbmatchup.F90 new file mode 100644 index 0000000000000000000000000000000000000000..49a74a5c50c1a7d3d8fe451e892a668857d6105d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbmatchup.F90 @@ -0,0 +1,477 @@ +PROGRAM fbmatchup + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbmatchup ** + !! + !! ** Purpose : Find matching obs in feedback files + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! fbmatchup.exe outputfile inputfile1 varname1 inputfile2 varname2 ... + !! + !! Optional: + !! namelist = namfbmatchup.in to set ldaily820 + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE toolspar_kind + USE obs_fbm + USE index_sort + IMPLICIT NONE + ! + ! Command line arguments for output file and input file + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + CHARACTER(len=ilenname),ALLOCATABLE :: cdnames(:) + CHARACTER(len=2*ilenname) :: cdtmp + LOGICAL :: ldaily820 + NAMELIST/namfbmatchup/ldaily820 + ! + ! Input data + ! + TYPE(obfbdata) :: obsdatatmp(1) + TYPE(obfbdata),POINTER :: obsdata(:) + INTEGER :: ninfiles,ntotobs,nlev,nadd,next + ! + ! Time sorting arrays + ! + REAL(KIND=dp),ALLOCATABLE :: zsort(:,:) + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + ! + ! Comparison arrays and scalars + ! + REAL(KIND=fbsp), ALLOCATABLE :: zrtim(:),zrphi(:),zrlam(:) + INTEGER(KIND=SELECTED_INT_KIND(12)), ALLOCATABLE :: irwmo(:) + REAL(KIND=fbsp) :: ztim,zphi,zlam + INTEGER(KIND=SELECTED_INT_KIND(12)) :: iwmo + LOGICAL, ALLOCATABLE :: ltaken(:) + ! + ! Output data + ! + TYPE(obfbdata) :: obsoutdata + ! + ! Storage for extra to search for unique. + ! + CHARACTER(len=ilenname), ALLOCATABLE :: cexttmp(:) + TYPE extout + LOGICAL, POINTER, DIMENSION(:) :: luse + INTEGER, POINTER, DIMENSION(:) :: ipos + END TYPE extout + TYPE(extout), POINTER, DIMENSION(:) :: pextinf + ! + ! Loop variables + ! + INTEGER :: ifi,ia,ip,i1,ii,ij,ik1,ik2,iv,ist,iadd,ie,iext + LOGICAL :: llfound + LOGICAL :: lexists,lnotobs + INTEGER :: ityp + ! + ! Get number of command line arguments + ! + nargs = IARGC() + IF ( ( MOD(nargs,2) /= 1 ) .OR. ( nargs == 0 ) ) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'fbmatchup outputfile inputfile1 varname1 inputfile2 varname2 ...' + CALL abort() + ENDIF + CALL getarg( 1, cdoutfile ) + ! + ! Read namelist if present + ! + ldaily820=.FALSE. + INQUIRE(file='namfbmatchup.in',exist=lexists) + IF (lexists) THEN + OPEN(10,file='namfbmatchup.in') + READ(10,namfbmatchup) + CLOSE(10) + WRITE(*,namfbmatchup) + ENDIF + ! + ! Get input data + ! + ninfiles = ( nargs -1 ) / 2 + ALLOCATE( obsdata( ninfiles ) ) + ALLOCATE( cdinfile( ninfiles ) ) + ALLOCATE( cdnames( ninfiles ) ) + ip = 1 + DO ifi = 1, ninfiles + ! + ! Read the unsorted file + ! + ip = ip + 1 + CALL getarg( ip, cdinfile(ifi) ) + ip = ip + 1 + CALL getarg( ip, cdnames(ifi) ) + CALL init_obfbdata( obsdatatmp(1) ) + CALL read_obfbdata( TRIM(cdinfile(ifi)), obsdatatmp(1) ) + ! + ! Check if we have fewer levels than in the first file + ! + IF ( ifi > 1 ) THEN + IF ( obsdatatmp(1)%nlev > obsdata(1)%nlev ) THEN + WRITE(*,*)'Warning. More levels in file than the first file' + WRITE(*,*)'Number of levels in current file = ', obsdatatmp(1)%nlev + WRITE(*,*)'Number of levels in first file = ', obsdata(1)%nlev + WRITE(*,*)'Only the number of levels in the first'//& + &' file will be used' + ENDIF + ENDIF + ! + ! Check if we have fewer observations than in the first file + ! + IF ( ifi > 1 ) THEN + IF ( obsdatatmp(1)%nobs > obsdata(1)%nobs ) THEN + WRITE(*,*)'Warning. More obs in file than the first file' + WRITE(*,*)'Number of obs in current file = ', obsdatatmp(1)%nobs + WRITE(*,*)'Number of obs in first file = ', obsdata(1)%nobs + WRITE(*,*)'Only the observations in the first'//& + &' file will be stored' + ENDIF + ENDIF + ! + ! Check that we have the same number of variables + ! + IF ( ifi > 1 ) THEN + IF ( obsdatatmp(1)%nvar /= obsdata(1)%nvar ) THEN + WRITE(*,*)'Error. Different number of variables.' + WRITE(*,*)'Number of var in current file = ', obsdatatmp(1)%nvar + WRITE(*,*)'Number of var in first file = ', obsdata(1)%nvar + CALL abort + ENDIF + ENDIF + ! + ! Check reference datas + ! + IF ( ifi > 1 ) THEN + IF ( obsdatatmp(1)%cdjuldref /= obsdata(1)%cdjuldref ) THEN + WRITE(*,*)'Different reference dates' + CALL abort + ENDIF + ENDIF + ! + ! Special fix for daily average MRB data (820) for the first file + ! + IF (ldaily820.AND.(ifi==1)) THEN + DO ij = 1,obsdatatmp(1)%nobs + READ(obsdatatmp(1)%cdtyp(ij),'(I5)')ityp + IF (ityp==820) THEN + obsdatatmp(1)%ptim(ij)=INT(obsdatatmp(1)%ptim(ij))+1.0 + ENDIF + ENDDO + ENDIF + ! + ! Construct sorting arrays + ! + ALLOCATE( zsort(3,obsdatatmp(1)%nobs), iset(obsdatatmp(1)%nobs), & + & inum(obsdatatmp(1)%nobs), iindex(obsdatatmp(1)%nobs)) + ii = 0 + DO ij = 1,obsdatatmp(1)%nobs + ii = ii+1 + zsort(1,ii) = obsdatatmp(1)%ptim(ij) + zsort(2,ii) = obsdatatmp(1)%pphi(ij) + zsort(3,ii) = obsdatatmp(1)%plam(ij) + iset(ii) = 1 + inum(ii) = ij + ENDDO + ! + ! Get indexes for time sorting. + ! + CALL index_sort_dp_n(zsort,3,iindex,obsdatatmp(1)%nobs) + CALL init_obfbdata( obsdata(ifi) ) + CALL alloc_obfbdata( obsdata(ifi), & + & obsdatatmp(1)%nvar, obsdatatmp(1)%nobs, & + & obsdatatmp(1)%nlev, obsdatatmp(1)%nadd, & + & obsdatatmp(1)%next, obsdatatmp(1)%lgrid ) + ! + ! Copy input data into output data + ! + CALL merge_obfbdata( 1, obsdatatmp, obsdata(ifi), iset, inum, iindex ) + CALL dealloc_obfbdata( obsdatatmp(1) ) + + WRITE(*,'(2A)')'File = ', TRIM(cdinfile(ifi)) + WRITE(*,'(A,I9,A)')'has', obsdata(ifi)%nobs, ' observations' + + DEALLOCATE( zsort, iset, inum, iindex ) + + ENDDO + ! + ! Prepare output data + ! + CALL init_obfbdata( obsoutdata ) + ! + ! Count number of additional fields + ! + nadd = 0 + DO ifi = 1, ninfiles + nadd = nadd + obsdata(ifi)%nadd + ENDDO + ! + ! Count number of unique extra fields + ! + ! First the maximum to construct list + next = 0 + DO ifi = 1, ninfiles + next = next + obsdata(ifi)%next + ENDDO + ALLOCATE( & + & cexttmp(next) & + & ) + ! Setup pextinf structure and search for unique extra fields + ALLOCATE( & + & pextinf(ninfiles) & + & ) + next = 0 + DO ifi = 1, ninfiles + ALLOCATE( & + & pextinf(ifi)%luse(obsdata(ifi)%next), & + & pextinf(ifi)%ipos(obsdata(ifi)%next) & + & ) + DO ie = 1, obsdata(ifi)%next + llfound = .FALSE. + DO ii = 1, next + IF ( cexttmp(ii) == obsdata(ifi)%cextname(ie) ) THEN + llfound = .TRUE. + ENDIF + ENDDO + IF (llfound) THEN + pextinf(ifi)%luse(ie) = .FALSE. + pextinf(ifi)%ipos(ie) = -1 + ELSE + next = next + 1 + pextinf(ifi)%luse(ie) = .TRUE. + pextinf(ifi)%ipos(ie) = next + cexttmp(next) = obsdata(ifi)%cextname(ie) + ENDIF + ENDDO + ENDDO + ! + ! Copy the first input data to output data + ! + CALL copy_obfbdata( obsdata(1), obsoutdata, & + & kadd = nadd, kext = next ) + ALLOCATE( ltaken(obsoutdata%nlev) ) + iadd = 0 + DO ifi = 1, ninfiles + DO ia = 1, obsdata(ifi)%nadd + cdtmp = TRIM(obsdata(ifi)%caddname(ia))//TRIM(cdnames(ifi)) + obsoutdata%caddname(iadd+ia) = cdtmp(1:ilenname) + DO iv = 1, obsdata(ifi)%nvar + obsoutdata%caddlong(iadd+ia,iv) = obsdata(ifi)%caddlong(ia,iv) + obsoutdata%caddunit(iadd+ia,iv) = obsdata(ifi)%caddunit(ia,iv) + ENDDO + ENDDO + DO ie = 1, obsdata(ifi)%next + IF ( pextinf(ifi)%luse(ie) ) THEN + obsoutdata%cextname(pextinf(ifi)%ipos(ie)) = & + & obsdata(ifi)%cextname(ie) + obsoutdata%cextlong(pextinf(ifi)%ipos(ie)) = & + & obsdata(ifi)%cextlong(ie) + obsoutdata%cextunit(pextinf(ifi)%ipos(ie)) = & + & obsdata(ifi)%cextunit(ie) + ENDIF + ENDDO + iadd = iadd + obsdata(ifi)%nadd + ENDDO + ! + ! Allocate comparison arrays and file them + ! + IF (ilenwmo>8) THEN + WRITE(*,*)'Fix fbmatchup to allow string length > 8' + CALL abort + ENDIF + ALLOCATE(zrtim(obsoutdata%nobs),zrphi(obsoutdata%nobs), & + & zrlam(obsoutdata%nobs),irwmo(obsoutdata%nobs)) + DO i1 = 1, obsoutdata%nobs + irwmo(i1) = TRANSFER( obsoutdata%cdwmo(i1), irwmo(i1) ) + zrtim(i1) = REAL( obsoutdata%ptim(i1), fbsp ) + zrphi(i1) = REAL( obsoutdata%pphi(i1), fbsp ) + zrlam(i1) = REAL( obsoutdata%plam(i1), fbsp ) + ENDDO + ! + ! Merge extra data into output data + ! + iadd = obsdata(1)%nadd + DO ifi = 2, ninfiles + ist = 1 + DO ii = 1, obsdata(ifi)%nobs + IF (MOD(ii,10000)==1) THEN + WRITE(*,*)'Handling observation no ',ii,' for file no ',ifi + ENDIF + llfound = .FALSE. + iwmo = TRANSFER( obsdata(ifi)%cdwmo(ii), iwmo ) + ztim = REAL( obsdata(ifi)%ptim(ii), fbsp ) + zphi = REAL( obsdata(ifi)%pphi(ii), fbsp ) + zlam = REAL( obsdata(ifi)%plam(ii), fbsp ) + ! Check if the the same index is the right one. + IF ( iwmo == irwmo(ii) ) THEN + IF ( ztim == zrtim(ii) ) THEN + IF ( zphi == zrphi(ii) ) THEN + IF ( zlam == zrlam(ii) ) THEN + llfound = .TRUE. + i1 = ii + ENDIF + ENDIF + ENDIF + ENDIF + ! Search for position in from previous found position + ! if not the same index + IF (.NOT.llfound) THEN + DO i1 = ist, obsoutdata%nobs + IF ( iwmo == irwmo(i1) ) THEN + IF ( ztim == zrtim(i1) ) THEN + IF ( zphi == zrphi(i1) ) THEN + IF ( zlam == zrlam(i1) ) THEN + llfound = .TRUE. + EXIT + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ! If not fount try agan from the beginnning + IF ( .NOT.llfound ) THEN + DO i1 = 1, obsoutdata%nobs + IF ( iwmo == irwmo(i1) ) THEN + IF ( ztim == zrtim(i1) ) THEN + IF ( zphi == zrphi(i1) ) THEN + IF ( zlam == zrlam(i1) ) THEN + llfound = .TRUE. + EXIT + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ! If found put the data into the common structure + IF (llfound) THEN + obsoutdata%ioqc(i1) = & + & MAX( obsoutdata%ioqc(i1), obsdata(ifi)%ioqc(ii) ) + obsoutdata%ipqc(i1) = & + & MAX( obsoutdata%ipqc(i1), obsdata(ifi)%ipqc(ii) ) + obsoutdata%itqc(i1) = & + & MAX( obsoutdata%itqc(i1), obsdata(ifi)%itqc(ii) ) + obsoutdata%ivqc(i1,:) = & + & MAX( obsoutdata%ivqc(i1,:), obsdata(ifi)%ivqc(ii,:) ) + obsoutdata%ioqcf(:,i1) = IOR( obsdata(ifi)%ioqcf(:,ii), & + & obsoutdata%ioqcf(:,i1) ) + obsoutdata%ipqcf(:,i1) = IOR( obsdata(ifi)%ipqcf(:,ii), & + & obsoutdata%ipqcf(:,i1) ) + obsoutdata%itqcf(:,i1) = IOR( obsdata(ifi)%itqcf(:,ii), & + & obsoutdata%itqcf(:,i1) ) + obsoutdata%ivqcf(:,i1,:) = IOR( obsdata(ifi)%ivqcf(:,ii,:), & + & obsoutdata%ivqcf(:,i1,:) ) + llfound = .FALSE. + ! Search for levels + ltaken(:) = .FALSE. + DO ik1 = 1, obsdata(ifi)%nlev + levloop : DO ik2 = 1, obsoutdata%nlev + IF ( REAL( obsdata(ifi)%pdep(ik1,ii), fbsp ) == & + & REAL( obsoutdata%pdep(ik2,i1), fbsp ) ) THEN + lnotobs=.TRUE. + IF (ltaken(ik2)) CYCLE + DO iv = 1, obsdata(ifi)%nvar + IF ( REAL( obsdata(ifi)%pob(ik1,ii,iv), fbsp ) == & + & REAL( obsoutdata%pob(ik2,i1,iv), fbsp ) ) THEN + lnotobs=.FALSE. + ENDIF + ENDDO + IF (lnotobs) CYCLE levloop + ltaken(ik2)=.TRUE. + DO ia = 1, obsdata(ifi)%nadd + obsoutdata%padd(ik2,i1,iadd+ia,:) = & + & obsdata(ifi)%padd(ik1,ii,ia,:) + ENDDO + DO ie = 1, obsdata(ifi)%next + IF ( pextinf(ifi)%luse(ie) ) THEN + obsoutdata%pext(ik2,i1,pextinf(ifi)%ipos(ie)) = & + & obsdata(ifi)%pext(ik1,ii,ie) + ENDIF + ENDDO + obsoutdata%idqc(ik2,i1) = & + & MAX( obsoutdata%idqc(ik2,i1), obsdata(ifi)%idqc(ik1,ii) ) + obsoutdata%ivlqc(ik2,i1,:) = & + & MAX( obsoutdata%ivlqc(ik2,i1,:), obsdata(ifi)%ivlqc(ik1,ii,:) ) + obsoutdata%idqcf(:,ik2,i1) = & + & IOR( obsdata(ifi)%idqcf(:,ik1,ii), & + & obsoutdata%idqcf(:,ik2,i1) ) + obsoutdata%ivlqcf(:,ik2,i1,:) = & + & IOR( obsdata(ifi)%ivlqcf(:,ik1,ii,:), & + & obsoutdata%ivlqcf(:,ik2,i1,:) ) + llfound = .TRUE. + EXIT + ENDIF + ENDDO levloop + ! Write warning if level not found + IF (.NOT.llfound.AND.(obsdata(ifi)%pdep(ik1,ii)/=fbrmdi)) THEN + WRITE(*,*)'Level not found in first file : ',& + & TRIM( cdinfile(1) ) + WRITE(*,*)'Data file : ',& + & TRIM( cdinfile(ifi) ) + WRITE(*,*)'Identifier : ',& + & obsdata(ifi)%cdwmo(ii) + WRITE(*,*)'Julifin date : ',& + & obsdata(ifi)%ptim(ii) + WRITE(*,*)'Latitude : ',& + & obsdata(ifi)%pphi(ii) + WRITE(*,*)'Longitude : ',& + & obsdata(ifi)%plam(ii) + WRITE(*,*)'Depth : ',& + & obsdata(ifi)%pdep(ik1,ii) + ENDIF + ENDDO + ist = i1 + ELSE + ! Write warning if observation not found + WRITE(*,*)'Observation not found in first data file : ',& + & TRIM( cdinfile(1) ) + WRITE(*,*)'Data file : ',& + & TRIM( cdinfile(ifi) ) + WRITE(*,*)'Identifier : ',& + & obsdata(ifi)%cdwmo(ii) + WRITE(*,*)'Julifin date : ',& + & obsdata(ifi)%ptim(ii) + WRITE(*,*)'Latitude : ',& + & obsdata(ifi)%pphi(ii) + WRITE(*,*)'Longitude : ',& + & obsdata(ifi)%plam(ii) + ist = 1 + ENDIF + ENDDO + IF (obsdata(ifi)%nobs>0) THEN + WRITE(*,*)'Handled last obs. no ',ii,' for file no ',ifi + ENDIF + iadd = iadd + obsdata(ifi)%nadd + ENDDO + ! + ! Write output file + ! + CALL write_obfbdata( TRIM(cdoutfile), obsoutdata ) + ! + ! Deallocate temporary data + ! + DEALLOCATE(zrtim,zrphi,zrlam,irwmo ) + DEALLOCATE( & + & cexttmp & + & ) + DO ifi = 1, ninfiles + DEALLOCATE( & + & pextinf(ifi)%luse, & + & pextinf(ifi)%ipos & + & ) + ENDDO + DEALLOCATE( & + & pextinf & + & ) + +END PROGRAM fbmatchup diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbprint.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbprint.F90 new file mode 100644 index 0000000000000000000000000000000000000000..37133607f83a14dbb23806a78061315115d87615 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbprint.F90 @@ -0,0 +1,536 @@ +PROGRAM fbprint + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbprint ** + !! + !! ** Purpose : Print feedback file contents as text + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage : + !! fbprint.exe [options] inputfile + !! Options : + !! -b shorter output + !! -q QC flags (nqc=1) select observations based on QC flags + !! -Q QC flags (nqc=2) select observations based on QC flags + !! -B QC flags (nqc=3) select observations based on QC flags + !! -u unsorted + !! -s ID select station ID + !! -t TYPE select observation type + !! -v NUM1-NUM2 select variable range to print by number (default all) + !! -a NUM1-NUM2 select additional variable range to print by number (default all) + !! -e NUM1-NUM2 select extra variable range to print by number (default all) + !! -d output date range + !! -D print depths + !! -z use zipped files + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE toolspar_kind + USE obs_fbm + USE index_sort + USE date_utils + USE proftools + + IMPLICIT NONE + ! + ! Command line arguments input file + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdinfile, cdbrief + LOGICAL :: lbrief, lqcflags, lstat, ltyp, lsort, ldaterange, lzinp, ldepths + CHARACTER(len=ilenwmo) :: cdstat + CHARACTER(len=ilentyp) :: cdtyp + INTEGER :: nqc + INTEGER :: nvar1, nvar2, nadd1, nadd2, next1, next2 + ! + ! Input data + ! + TYPE(obfbdata) :: obsdata + ! + ! Loop variables + ! + INTEGER :: ii, iarg, ip + ! + ! Sorting + ! + INTEGER :: iwmo + REAL(KIND=dp),ALLOCATABLE :: zsort(:,:) + INTEGER,ALLOCATABLE :: iindex(:) + ! + ! Get number of command line arguments + ! + nargs = IARGC() + lbrief = .FALSE. + lstat = .FALSE. + ltyp = .FALSE. + ldaterange = .FALSE. + ldepths = .FALSE. + cdstat = 'XXXXXXX' + cdtyp = 'XXXX' + lsort = .TRUE. + nqc = 0 + nvar1 = -1 + nvar2 = -1 + nadd1 = -1 + nadd2 = -1 + next1 = -1 + next2 = -1 + lzinp = .FALSE. + IF ( nargs < 1 ) THEN + CALL usage() + ENDIF + iarg = 1 + DO + IF ( iarg == nargs ) EXIT + CALL getarg( iarg, cdbrief ) + IF ( cdbrief == '-b' ) THEN + lbrief = .TRUE. + iarg = iarg + 1 + ELSEIF( cdbrief == '-q' ) THEN + lqcflags = .TRUE. + nqc=1 + iarg = iarg + 1 + ELSEIF( cdbrief == '-Q' ) THEN + lqcflags = .TRUE. + nqc=2 + iarg = iarg + 1 + ELSEIF( cdbrief == '-B' ) THEN + lqcflags = .TRUE. + nqc=3 + iarg = iarg + 1 + ELSEIF( cdbrief == '-u' ) THEN + lsort = .FALSE. + iarg = iarg + 1 + ELSEIF ( cdbrief == '-s' ) THEN + lstat = .TRUE. + CALL getarg( iarg + 1, cdstat ) + iarg = iarg + 2 + ELSEIF ( cdbrief == '-t' ) THEN + ltyp = .TRUE. + CALL getarg( iarg + 1, cdtyp ) + iarg = iarg + 2 + ELSEIF ( cdbrief == '-v' ) THEN + CALL getarg( iarg + 1, cdbrief ) + ip=INDEX(cdbrief,'-') + IF (ip==0) THEN + READ(cdbrief,'(I10)') nvar1 + IF (nvar1==0) THEN + nvar2=-1 + ELSE + nvar2 = nvar1 + ENDIF + ELSEIF(ip==1) THEN + nvar1=1 + READ(cdbrief(ip+1:),'(I10)') nvar2 + ELSE + READ(cdbrief(1:ip-1),'(I10)') nvar1 + READ(cdbrief(ip+1:),'(I10)') nvar2 + ENDIF + iarg = iarg + 2 + ELSEIF ( cdbrief == '-a' ) THEN + CALL getarg( iarg + 1, cdbrief ) + ip=INDEX(cdbrief,'-') + IF (ip==0) THEN + READ(cdbrief,'(I10)') nadd1 + IF (nadd1==0) THEN + nadd2=-1 + ELSE + nadd2 = nadd1 + ENDIF + ELSEIF(ip==1) THEN + nadd1=1 + READ(cdbrief(ip+1:),'(I10)') nadd2 + ELSE + READ(cdbrief(1:ip-1),'(I10)') nadd1 + READ(cdbrief(ip+1:),'(I10)') nadd2 + ENDIF + iarg = iarg + 2 + ELSEIF ( cdbrief == '-e' ) THEN + CALL getarg( iarg + 1, cdbrief ) + ip=INDEX(cdbrief,'-') + IF (ip==0) THEN + READ(cdbrief,'(I10)') next1 + IF (next1==0) THEN + next2=-1 + ELSE + next2 = next1 + ENDIF + ELSEIF(ip==1) THEN + next1=1 + READ(cdbrief(ip+1:),'(I10)') next2 + ELSE + READ(cdbrief(1:ip-1),'(I10)') next1 + READ(cdbrief(ip+1:),'(I10)') next2 + ENDIF + iarg = iarg + 2 + ELSEIF ( cdbrief == '-d' ) THEN + ldaterange=.TRUE. + iarg = iarg + 1 + ELSEIF ( cdbrief == '-D' ) THEN + ldepths=.TRUE. + iarg = iarg + 1 + ELSEIF ( cdbrief == '-z' ) THEN + lzinp=.TRUE. + iarg = iarg + 1 + ELSE + CALL usage + ENDIF + ENDDO + CALL getarg( nargs, cdinfile ) + ! + ! Get input data + ! + IF (lzinp) THEN +#if defined NOSYSTEM + WRITE(*,*)'Compressed files need the system subroutine call' + CALL abort +#else + CALL system( 'cp '//TRIM(cdinfile)//' fbprint_tmp.nc.gz' ) + CALL system( 'gzip -df fbprint_tmp.nc.gz' ) + CALL read_obfbdata( 'fbprint_tmp.nc', obsdata ) + CALL system( 'rm -f fbprint_tmp.nc' ) +#endif + ELSE + CALL read_obfbdata( TRIM(cdinfile), obsdata ) + ENDIF + CALL sealsfromargo( obsdata ) + WRITE(*,'(2A,I9,A,I9,A)')TRIM(cdinfile), ' has ', obsdata%nobs ,& + & ' observations and a maximum of ', obsdata%nlev, ' levels' + IF (nvar1<0) THEN + nvar1 = 1 + nvar2 = obsdata%nvar + ENDIF + IF (nadd1<0) THEN + nadd1 = 1 + nadd2 = obsdata%nadd + ENDIF + IF (next1<0) THEN + next1 = 1 + next2 = obsdata%next + ENDIF + ! + ! Sort the data + ! + ALLOCATE(zsort(5,obsdata%nobs),iindex(obsdata%nobs)) + IF (lsort) THEN + DO ii=1,obsdata%nobs + zsort(1,ii)=obsdata%ptim(ii) + zsort(2,ii)=obsdata%pphi(ii) + zsort(3,ii)=obsdata%plam(ii) + iwmo = TRANSFER( obsdata%cdwmo(ii)(1:4), iwmo ) + zsort(4,ii) = iwmo + iwmo = TRANSFER( obsdata%cdwmo(ii)(5:8), iwmo ) + zsort(5,ii) = iwmo + ENDDO + CALL index_sort_dp_n(zsort,5,iindex,obsdata%nobs) + ELSE + DO ii=1,obsdata%nobs + iindex(ii)=ii + ENDDO + ENDIF + IF (ldaterange) THEN + IF (obsdata%nobs>0) THEN + WRITE(*,'(A)')'First observation' + CALL print_time(obsdata%ptim(1)) + WRITE(*,'(A)')'Last observation' + CALL print_time(obsdata%ptim(obsdata%nobs)) + ENDIF + ELSE + ! + ! Print the sorted list + ! + DO ii=1,obsdata%nobs + IF (lstat) THEN + IF (TRIM(ADJUSTL(cdstat)) /= & + &TRIM(ADJUSTL(obsdata%cdwmo(iindex(ii))))) CYCLE + ENDIF + IF (ltyp) THEN + IF (TRIM(ADJUSTL(cdtyp)) /= & + &TRIM(ADJUSTL(obsdata%cdtyp(iindex(ii))))) CYCLE + ENDIF + IF (ldepths) THEN + CALL print_depths(obsdata,iindex(ii)) + ELSE + IF (lqcflags) THEN + CALL print_obs_qc(obsdata,iindex(ii),nqc,nvar1,nvar2) + ELSE + CALL print_obs(obsdata,iindex(ii),lbrief,& + & nvar1,nvar2,nadd1,nadd2,next1,next2) + ENDIF + ENDIF + ENDDO + + ENDIF + +CONTAINS + + SUBROUTINE usage + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'fbprint [options] inputfile' + CALL abort() + END SUBROUTINE usage + + SUBROUTINE print_depths(obsdata,iindex) + IMPLICIT NONE + TYPE(obfbdata) :: obsdata + INTEGER :: iindex + INTEGER :: kj + REAL :: mindep,maxdep + + mindep=10000 + maxdep=0 + DO kj=1,obsdata%nlev + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + IF (obsdata%pdep(kj,iindex)>maxdep) maxdep=obsdata%pdep(kj,iindex) + IF (obsdata%pdep(kj,iindex)<mindep) mindep=obsdata%pdep(kj,iindex) + ENDIF + ENDDO + + WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) + WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) + WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) + WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) + WRITE(*,*)'Longtude = ',obsdata%plam(iindex) + CALL print_time( obsdata%ptim(iindex) ) + WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) + WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) + WRITE(*,*)'Minimum obs. depth = ',mindep + WRITE(*,*)'Maximum obs. depth = ',maxdep + WRITE(*,*) + + END SUBROUTINE print_depths + + SUBROUTINE print_obs(obsdata,iindex,lshort,& + & kvar1,kvar2,kadd1,kadd2,kext1,kext2) + IMPLICIT NONE + TYPE(obfbdata) :: obsdata + INTEGER :: iindex + LOGICAL :: lshort + INTEGER :: kvar1,kvar2,kadd1,kadd2,kext1,kext2 + INTEGER :: jv,ja,je,jk + INTEGER :: kj + LOGICAL :: lskip + CHARACTER(len=1024) :: cdfmt1,cdfmt2 + CHARACTER(len=16) :: cdtmp + + WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) + WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) + WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) + WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) + WRITE(*,*)'Longtude = ',obsdata%plam(iindex) + CALL print_time( obsdata%ptim(iindex) ) + WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) + WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) + IF (.NOT.lshort) THEN + DO jv = kvar1, kvar2 + WRITE(*,*)'Variable name = ',obsdata%cname(jv) + WRITE(*,*)'Variable QC = ',obsdata%ivqc(iindex,jv) + IF (obsdata%lgrid) THEN + WRITE(*,*)'Grid I = ',obsdata%iobsi(iindex,jv) + WRITE(*,*)'Grid J = ',obsdata%iobsj(iindex,jv) + ENDIF + ENDDO + cdfmt1='(1X,A8,1X,A8' + cdfmt2='(1X,F8.2,1X,I8' + DO jv = kvar1, kvar2 + cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8' + cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8' + IF (kadd2-kadd1+1>0) THEN + WRITE(cdtmp,'(I10)')kadd2-kadd1+1 + cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' + cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' + ENDIF + IF (obsdata%lgrid) THEN + cdfmt1 = TRIM(cdfmt1)//',1X,A10' + cdfmt2 = TRIM(cdfmt2)//',1X,I10' + ENDIF + ENDDO + IF (kext2-kext1+1>0) THEN + WRITE(cdtmp,'(I10)')kext2-kext1+1 + cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' + cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' + ENDIF + cdfmt1=TRIM(cdfmt1)//')' + cdfmt2=TRIM(cdfmt2)//')' + IF (obsdata%lgrid) THEN + WRITE(*,FMT=cdfmt1)& + & 'DEPTH', 'DEP_QC', & + & (TRIM(obsdata%cname(jv))//'_OBS', & + & TRIM(obsdata%cname(jv))//'_QC' , & + & (TRIM(obsdata%cname(jv))//'_'//TRIM(obsdata%caddname(ja)),& + & ja = kadd1, kadd2 ), & + & TRIM(obsdata%cname(jv))//'_K' , & + & jv = kvar1, kvar2 ), & + & ( TRIM(obsdata%cextname(ja)),& + & ja = kext1, kext2 ) + DO kj=1,obsdata%nlev + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + WRITE (*,FMT=cdfmt2) & + & obsdata%pdep(kj,iindex), & + & obsdata%idqc(kj,iindex), & + & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & + & ( obsdata%padd(kj,iindex,ja,jv) , ja = kadd1, kadd2 ), & + & obsdata%iobsk(kj,iindex,jv), & + & jv = kvar1, kvar2 ), & + & ( obsdata%pext(kj,iindex,ja), ja = kext1, kext2 ) + ENDIF + ENDDO + ELSE + cdfmt1=TRIM(cdfmt1)//')' + cdfmt2=TRIM(cdfmt2)//')' + WRITE(*,FMT=cdfmt1)& + & 'DEPTH', 'DEP_QC', & + & (TRIM(obsdata%cname(jv))//'_OBS', & + & TRIM(obsdata%cname(jv))//'_QC' , & + & (TRIM(obsdata%cname(jv))//TRIM(obsdata%caddname(ja)),& + & ja = kadd1, kadd2 ), & + & jv = kvar1, kvar2 ), & + & ( TRIM(obsdata%cextname(ja)),& + & ja = kext1, kext2 ) + DO kj=1,obsdata%nlev + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + WRITE (*,FMT=cdfmt2) & + & obsdata%pdep(kj,iindex), & + & obsdata%idqc(kj,iindex), & + & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & + & ( obsdata%padd(kj,iindex,ja,jv) , ja = kadd1, kadd2 ), & + & jv = kvar1, kvar2 ), & + & ( obsdata%pext(kj,iindex,ja), ja = kext1, kext2 ) + ENDIF + ENDDO + ENDIF + ENDIF + WRITE(*,*) + END SUBROUTINE print_obs + + SUBROUTINE print_obs_qc(obsdata,iindex,kqc,kvar1,kvar2) + IMPLICIT NONE + TYPE(obfbdata) :: obsdata + INTEGER :: iindex + LOGICAL :: lqc + INTEGER :: kqc + INTEGER :: kvar1,kvar2 + INTEGER :: jv,ja,je,jk + INTEGER :: kj + LOGICAL :: lskip + CHARACTER(len=1024) :: cdfmt1,cdfmt2 + CHARACTER(len=16) :: cdtmp + INTEGER :: iqcf + + IF (kqc==2) THEN + lskip=.TRUE. + IF (obsdata%ipqc(iindex)>1) lskip=.FALSE. + IF (obsdata%ioqc(iindex)>1) lskip=.FALSE. + DO jv = kvar1, kvar2 + IF (obsdata%ivqc(iindex,jv)>1) lskip=.FALSE. + ENDDO + DO kj=1,obsdata%nlev + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE. + DO jv = kvar1, kvar2 + IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE. + ENDDO + ENDIF + ENDDO + IF (lskip) RETURN + ELSEIF (kqc==3) THEN + lskip=.TRUE. + DO kj=1,obsdata%nlev + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + iqcf=0 + DO jv = kvar1, kvar2 + IF (obsdata%ivlqc(kj,iindex,jv)>1) iqcf=iqcf+1 + IF (iqcf==obsdata%nvar) lskip=.FALSE. + ENDDO + ENDIF + ENDDO + IF (lskip) RETURN + ENDIF + WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) + WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) + WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) + WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) + WRITE(*,*)'Longtude = ',obsdata%plam(iindex) + CALL print_time( obsdata%ptim(iindex) ) + WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) + WRITE(*,*)'Position QC flags = ',obsdata%ipqcf(:,iindex) + WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) + WRITE(*,*)'Observation QC flags= ',obsdata%ioqcf(:,iindex) + DO jv = kvar1, kvar2 + WRITE(*,*)'Variable name = ',obsdata%cname(jv) + WRITE(*,*)'Variable QC = ',obsdata%ivqc(iindex,jv) + WRITE(*,*)'Variable QC flags = ',obsdata%ivqcf(:,iindex,jv) + ENDDO + cdfmt1='(1X,A8,1X,A8' + cdfmt2='(1X,F8.2,1X,I8' + WRITE(cdtmp,'(I10)')obsdata%nqcf + cdfmt1 = TRIM(cdfmt1)//',1X,A18' + cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)' + DO jv = kvar1, kvar2 + cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8' + cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8' + WRITE(cdtmp,'(I10)')obsdata%nqcf + cdfmt1 = TRIM(cdfmt1)//',1X,A18' + cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)' + ENDDO + IF (obsdata%next>0) THEN + WRITE(cdtmp,'(I10)')obsdata%next + cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' + cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' + ENDIF + cdfmt1=TRIM(cdfmt1)//')' + cdfmt2=TRIM(cdfmt2)//')' + WRITE(*,FMT=cdfmt1)& + & 'DEPTH', 'DEP_QC', 'DEP_QC_FLAGS', & + & (TRIM(obsdata%cname(jv))//'_OBS', & + & TRIM(obsdata%cname(jv))//'_QC' , & + & TRIM(obsdata%cname(jv))//'_QC_FLAGS',& + & jv = kvar1, kvar2 ), & + & ( TRIM(obsdata%cextname(ja)),& + & ja = 1, obsdata%next ) + DO kj=1,obsdata%nlev + IF (kqc>=2) THEN + lskip=.TRUE. + IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE. + DO jv = kvar1, kvar2 + IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE. + ENDDO + IF (lskip) CYCLE + ENDIF + IF (obsdata%pdep(kj,iindex)<99999.0) THEN + WRITE (*,FMT=cdfmt2) & + & obsdata%pdep(kj,iindex), & + & obsdata%idqc(kj,iindex), & + & ( obsdata%idqcf(ja,kj,iindex), ja = 1, obsdata%nqcf ), & + & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & + & ( obsdata%ivlqcf(ja,kj,iindex,jv) , ja=1, obsdata%nqcf ), & + & jv = kvar1, kvar2 ), & + & ( obsdata%pext(kj,iindex,ja), ja=1, obsdata%next ) + ENDIF + ENDDO + WRITE(*,*) + + END SUBROUTINE print_obs_qc + + SUBROUTINE print_time(ptim) + IMPLICIT NONE + REAL(fbdp) :: ptim + INTEGER:: iyr,imon,iday,ihou,imin,isec + WRITE(*,*)'Julian date = ',ptim + CALL jul2greg(isec,imin,ihou,iday,imon,iyr,ptim) + WRITE(*,'(1X,A,I4,2I2.2)') & + & 'Gregorian date = ',iyr,imon,iday + WRITE(*,'(1X,A,I2.2,A1,I2.2,A1,I2.2)') & + & 'Time = ',ihou,':',imin,':',isec + END SUBROUTINE print_time + +END PROGRAM fbprint + + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbsel.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbsel.F90 new file mode 100644 index 0000000000000000000000000000000000000000..de78990f39637af4afb63f47671baf89950570b3 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbsel.F90 @@ -0,0 +1,260 @@ +PROGRAM fbsel + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbsel ** + !! + !! ** Purpose : Select or subsample observations + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! fbsel.exe <input filename> <output filename> + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE date_utils + IMPLICIT NONE + TYPE(obfbdata) :: fbdatain,fbdataout + CHARACTER(len=256) :: filenamein,filenameout,filenametmp,cnameout +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER,PARAMETER :: maxtyp=1023 + INTEGER,PARAMETER :: maxdates=20 + INTEGER :: nqc,ntyp,ndates,ninidate(maxdates),nenddate(maxdates) + LOGICAL :: lsplitqc,lsplittyp,lsplitstat + INTEGER :: iqc,ityp,idate,istat + REAL :: maxlat,minlat,maxlon,minlon + CHARACTER(len=ilenwmo) :: cdwmo,cdwmobeg,cdwmoend + CHARACTER(len=ilenwmo), DIMENSION(:), POINTER :: clstatids + INTEGER :: nstat + NAMELIST/namsel/nqc,ntyp,ndates,ninidate,nenddate,lsplitqc,lsplittyp, & + & lsplitstat,maxlat,minlat,maxlon,minlon,cdwmo,& + & cdwmobeg,cdwmoend + + IF (iargc()/=2) THEN + WRITE(*,*)'Usage:' + WRITE(*,*)'fbsel <input filename> <output filename>' + CALL abort + ENDIF + + CALL getarg(1,filenamein) + CALL getarg(2,filenameout) + + nqc=-1 + ntyp=-1 + ndates=1 + ninidate=19500101 + nenddate=21000101 + + lsplitqc=.FALSE. + lsplittyp=.FALSE. + lsplitstat=.FALSE. + cdwmo=REPEAT('X',ilenwmo) + cdwmobeg=cdwmo + cdwmoend=cdwmo + maxlat=1e+38 + minlat=-1e+38 + maxlon=1e+38 + minlon=-1e+38 + OPEN(10,file='namsel.in') + READ(10,namsel) + CLOSE(10) + IF (cdwmobeg==REPEAT('X',ilenwmo)) cdwmobeg=cdwmo + IF (cdwmoend==REPEAT('X',ilenwmo)) cdwmoend=cdwmo + WRITE(*,namsel) + + CALL init_obfbdata(fbdatain) + CALL init_obfbdata(fbdataout) + + WRITE(*,*)'Reading file : ',TRIM(filenamein) + CALL read_obfbdata(TRIM(filenamein),fbdatain) + WRITE(*,*)'Number of observations before selection = ',fbdatain%nobs + DO idate=1,ndates + IF (ndates==1) THEN + cnameout=filenameout + ELSE + WRITE(cnameout,'(I2.2,2A)')idate,'_',TRIM(filenameout) + ENDIF + IF (lsplitqc) THEN + DO iqc=1,3 + CALL fb_sel(fbdatain,fbdataout,iqc,ntyp, & + & ninidate(idate),nenddate(idate), & + & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) + WRITE(filenametmp,'(A,I2.2,A,A)')'qc_',iqc,'_',TRIM(cnameout) + IF (fbdataout%nobs>0) THEN + WRITE(*,*)'QC selected = ',iqc + WRITE(*,*)'Number of observations selected = ',fbdataout%nobs + WRITE(*,*)'Writing file : ',TRIM(filenametmp) + CALL write_obfbdata(TRIM(filenametmp),fbdataout) + ENDIF + CALL dealloc_obfbdata(fbdataout) + ENDDO + ELSEIF (lsplittyp) THEN + DO ityp=0,maxtyp + CALL fb_sel(fbdatain,fbdataout,nqc,ityp, & + & ninidate(idate),nenddate(idate), & + & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) + WRITE(filenametmp,'(A,I4.4,A,A)')'typ_',ityp,'_',TRIM(cnameout) + IF (fbdataout%nobs>0) THEN + WRITE(*,*)'Type = ',ityp + WRITE(*,*)'Number of observations selected = ',fbdataout%nobs + WRITE(*,*)'Writing file : ',TRIM(filenametmp) + CALL write_obfbdata(TRIM(filenametmp),fbdataout) + ENDIF + CALL dealloc_obfbdata(fbdataout) + ENDDO + ELSEIF (lsplitstat) THEN + CALL fb_sel_uniqueids(fbdatain,clstatids,nstat) + DO istat=1,nstat + CALL fb_sel(fbdatain,fbdataout,nqc,ntyp, & + & ninidate(idate),nenddate(idate), & + & maxlat,minlat,maxlon,minlon,clstatids(istat),clstatids(istat)) + WRITE(filenametmp,'(4A)')'statid_', & + & TRIM(clstatids(istat)),'_',TRIM(cnameout) + IF (fbdataout%nobs>0) THEN + WRITE(*,*)'Station = ',clstatids(istat) + WRITE(*,*)'Number of observations selected = ',fbdataout%nobs + WRITE(*,*)'Writing file : ',TRIM(filenametmp) + CALL write_obfbdata(TRIM(filenametmp),fbdataout) + ENDIF + CALL dealloc_obfbdata(fbdataout) + ENDDO + ELSE + CALL fb_sel(fbdatain,fbdataout,nqc,ntyp, & + & ninidate(idate),nenddate(idate), & + & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) + WRITE(*,*)'Number of observations selected = ',fbdataout%nobs + WRITE(*,*)'Writing file : ',TRIM(cnameout) + CALL write_obfbdata(TRIM(cnameout),fbdataout) + CALL dealloc_obfbdata(fbdataout) + ENDIF + ENDDO + +CONTAINS + + SUBROUTINE fb_sel(fbdatain,fbdataout,nqc,ntyp,ninidate,nenddate,& + & maxlat,minlat,maxlon,minlon,cdwmobeg,cdwmoend) + TYPE(obfbdata) :: fbdatain,fbdataout + INTEGER :: nqc,ntyp,ninidate,nenddate + REAL :: maxlat,minlat,maxlon,minlon + CHARACTER(len=ilenwmo) :: cdwmobeg,cdwmoend + INTEGER :: jobs + INTEGER :: iqc,ityp + LOGICAL :: llvalid(fbdatain%nobs) + INTEGER :: iyea,imon,iday + REAL(KIND=dp) :: zjini,zjend + LOGICAL :: lcheckwmo + + lcheckwmo=(cdwmobeg/=REPEAT('X',ilenwmo)).OR.& + & (cdwmoend/=REPEAT('X',ilenwmo)) + iyea=ninidate/10000 + imon=ninidate/100-iyea*100 + iday=ninidate-iyea*10000-imon*100 + CALL greg2jul(0,0,0,iday,imon,iyea,zjini) + iyea=nenddate/10000 + imon=nenddate/100-iyea*100 + iday=nenddate-iyea*10000-imon*100 + CALL greg2jul(0,0,0,iday,imon,iyea,zjend) + DO jobs = 1, fbdatain%nobs + llvalid(jobs)=.TRUE. + IF (nqc/=-1) THEN + CALL check_prof(fbdatain,jobs,iqc) + llvalid(jobs)=(iqc==nqc).AND.llvalid(jobs) + ENDIF + IF (ntyp/=-1) THEN + READ(fbdatain%cdtyp(jobs),'(I4)')ityp + llvalid(jobs)=(ityp==ntyp).AND.llvalid(jobs) + ENDIF + IF (ninidate/=-1) THEN + llvalid(jobs)=(fbdatain%ptim(jobs)>zjini).AND.llvalid(jobs) + ENDIF + IF (nenddate/=-1) THEN + llvalid(jobs)=(fbdatain%ptim(jobs)<=zjend).AND.llvalid(jobs) + ENDIF + llvalid(jobs)=(fbdatain%pphi(jobs)<=maxlat).AND. & + & (fbdatain%pphi(jobs)>=minlat).AND. & + & (((fbdatain%plam(jobs)<=maxlon).AND. & + & (fbdatain%plam(jobs)>=minlon)).OR. & + & ((fbdatain%plam(jobs)+360<=maxlon).AND. & + & (fbdatain%plam(jobs)+360>=minlon)).OR. & + & ((fbdatain%plam(jobs)-360<=maxlon).AND. & + & (fbdatain%plam(jobs)-360>=minlon))).AND.llvalid(jobs) + IF (lcheckwmo) THEN + llvalid(jobs)=LGE(TRIM(fbdatain%cdwmo(jobs)),TRIM(cdwmobeg)) & + & .AND. LLE(TRIM(fbdatain%cdwmo(jobs)),TRIM(cdwmoend)) & + & .AND. llvalid(jobs) + ENDIF + ! Add more checks here... + ENDDO + + CALL subsamp_obfbdata(fbdatain,fbdataout,llvalid) + + END SUBROUTINE fb_sel + + SUBROUTINE fb_sel_uniqueids(fbdatain,clstatids,nstat) + TYPE(obfbdata) :: fbdatain + CHARACTER(len=ilenwmo), DIMENSION(:), POINTER :: clstatids + INTEGER :: nstat + INTEGER :: jobs,kobs + LOGICAL, DIMENSION(fbdatain%nobs) :: lunique + + lunique(:)=.TRUE. + DO jobs=1,fbdatain%nobs + IF (.NOT.lunique(jobs)) CYCLE + DO kobs=jobs+1,fbdatain%nobs + IF (.NOT.lunique(kobs)) CYCLE + IF (fbdatain%cdwmo(jobs)==fbdatain%cdwmo(kobs)) THEN + lunique(kobs)=.FALSE. + ENDIF + ENDDO + ENDDO + nstat=COUNT(lunique) + ALLOCATE(clstatids(nstat)) + kobs=0 + DO jobs=1,fbdatain%nobs + IF (lunique(jobs)) THEN + kobs=kobs+1 + clstatids(kobs)=fbdatain%cdwmo(jobs) + ENDIF + ENDDO + WRITE(*,*)'Unique station ids' + DO jobs=1,nstat + WRITE(*,'(I5,1X,A)')jobs,clstatids(jobs) + ENDDO + + END SUBROUTINE fb_sel_uniqueids + + SUBROUTINE check_prof(fbdata,iobs,iqc) + + TYPE(obfbdata) :: fbdata + INTEGER :: iobs,iqc + INTEGER :: i,ivar + + LOGICAL :: lpart,lfull + + lpart=.false. + lfull=.true. + DO ivar=1,fbdata%nvar + DO i=1,fbdata%nlev + IF ((fbdata%ivlqc(i,iobs,ivar)>2).AND.& + &(fbdata%ivlqc(i,iobs,ivar)<9)) lpart = .TRUE. + IF (fbdata%ivlqc(i,iobs,ivar)<=2) lfull = .FALSE. + ENDDO + ENDDO + + IF(lfull) THEN + iqc=3 + ELSEIF (lpart) then + iqc=2 + ELSE + iqc=1 + ENDIF + + END SUBROUTINE check_prof + +END PROGRAM fbsel diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstat.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstat.F90 new file mode 100755 index 0000000000000000000000000000000000000000..16dd41195ab32ac9f8d20d7b04273e1846a2ad62 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstat.F90 @@ -0,0 +1,1335 @@ +PROGRAM fbstat + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbstat ** + !! + !! ** Purpose : Output feedback file summary info/statistics + !! into a number of .dat files for different areas + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! fbstat.exe [-nmlev] <filenames> + !! Optional: + !! namelist = namfbstat.in + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE fbaccdata + USE coords + USE omonainfo + USE fbstatncio + USE proftools + IMPLICIT NONE + TYPE(obfbdata) :: fbdata + CHARACTER(len=256) :: filename,outfilename + INTEGER :: jfile,jbox,jlev,jfirst,jvar,jadd,ji,ja,jt,jboxl +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + REAL,DIMENSION(:),ALLOCATABLE :: zlev + INTEGER :: nmlev, nfiles + LOGICAL :: lexists,lomona,ltext,lnetcdf,lzinp + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: zdat3d + REAL, ALLOCATABLE, DIMENSION(:,:) :: zdat2d + INTEGER,DIMENSION(1) :: itime + INTEGER :: inidate,icurdate,loopno,ityp,iloopno + INTEGER :: nvar,nadd,noberr,nbgerr + CHARACTER(len=4) :: expver + CHARACTER(len=20) :: cltyp + CHARACTER(len=128) :: cdfmthead,cdfmtbody + LOGICAL :: lnear,linner,linnerp,linnerini,lpassive,lhistogram,lfound + LOGICAL :: lxyplot,lrmmean + INTEGER :: nqc,nqco + REAL :: rlspc,rlmax + CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: cname,caddname,& + & cobename,cbgename + INTEGER, PARAMETER :: nmaxareas = 20 + CHARACTER(len=20), DIMENSION(nmaxareas) :: carea + LOGICAL, DIMENSION(:), ALLOCATABLE :: lskipbox + INTEGER, parameter :: maxtyp = 10 + CHARACTER(len=ilentyp), DIMENSION(maxtyp) :: ctyp + INTEGER :: ntyp,nboxuserl,ipdcst + REAL :: mindcst + NAMELIST/namfbstat/ltext,lomona,lnetcdf,nmlev,inidate,icurdate,loopno,& + & expver,lnear,linner,lpassive,lhistogram,& + & zhistmax,zhistmin,zhiststep,zcheck,carea,nmlev,& + & nqc,nqco, & + & rlspc,rlmax,ntyp,ctyp,& + & lxyplot,zxymin,zxymax,zxystep,lzinp,lrmmean,mindcst + + ltext=.TRUE. + lnetcdf=.TRUE. + lomona=.FALSE. + nmlev=31 + inidate=19010101 + icurdate=19010116 + loopno=0 + expver='test' + lnear=.TRUE. + linner=.FALSE. + lpassive=.FALSE. + lhistogram=.FALSE. + zhistmin(:)=-10.0 + zhistmax(:)=10.0 + zhiststep(:)=0.1 + zcheck(:)=1000.0 + nqc=2 + nqco=2 + carea(:)='all' + rlmax=5000.0 + rlspc=-0.1 + ntyp=1 + ctyp(:)='all' + lxyplot=.FALSE. + zxymin(:)=-5.0 + zxymax(:)=45.0 + zxystep(:)=0.5 + lzinp=.FALSE. + lrmmean=.FALSE. + mindcst=-1.0 + + INQUIRE(file='namfbstat.in',exist=lexists) + IF (lexists) THEN + OPEN(10,file='namfbstat.in') + READ(10,namfbstat) + CLOSE(10) + WRITE(*,namfbstat) + ENDIF + mindcst=mindcst*1000.0 !From km to m. + IF (iargc()==0) THEN + WRITE(*,*)'Usage:' + WRITE(*,*)'fbstat [-nmlev] <filenames>' + CALL abort + ENDIF + jfirst=1 + DO ji=1,2 + CALL getarg(jfirst,filename) + IF (filename=='-42') THEN + nmlev=42 + jfirst=jfirst+1 + ELSEIF(filename=='-31') THEN + nmlev=31 + jfirst=jfirst+1 + ELSEIF(filename=='-1') THEN + nmlev=1 + lnear=.TRUE. + jfirst=jfirst+1 + ELSEIF(filename=='-q') THEN + jfirst=jfirst+1 + CALL getarg(jfirst,filename) + READ(filename,'(I4)')nqc + IF ((nqc<0).OR.(nqc>4)) THEN + WRITE(*,*)'Quality control option (-q) should be 1 to 4' + CALL abort + ENDIF + jfirst=jfirst+1 + ENDIF + END DO + nfiles=iargc() + + CALL coord_user_init('o') + + ALLOCATE(lskipbox(nboxuser)) + lskipbox(:)=.FALSE. + + IF (carea(1)/='all') THEN + IF (lomona) THEN + WRITE(*,*)'For omona files carea(1) has to be all' + CALL abort + ENDIF + lskipbox(:)=.TRUE. + DO ji=1,nmaxareas + IF (carea(ji)/='all') THEN + lfound=.FALSE. + DO jbox=1,nboxuser + IF (TRIM(carea(ji))==TRIM(cl_boxes_user(jbox))) THEN + lskipbox(jbox)=.FALSE. + lfound=.TRUE. + ENDIF + ENDDO + IF (.NOT.lfound) THEN + WRITE(*,*)'Area ',TRIM(carea(ji)),' not found' + CALL abort + ENDIF + ENDIF + ENDDO + nboxuserl=0 + DO ji=1,nboxuser + WRITE(*,*)'Area ',TRIM(cl_boxes_user(ji)),' is set to ',lskipbox(ji) + IF (.NOT.lskipbox(ji)) nboxuserl=nboxuserl+1 + ENDDO + WRITE(*,*)'Total areas for statistics = ',nboxuserl + IF (lomona.AND.(nboxuserl/=nboxuser)) THEN + WRITE(*,*)'Omona files only possible if all areas' + CALL abort + ENDIF + ELSE + nboxuserl=nboxuser + ENDIF + + IF (rlspc>0.0) THEN + lnear=.TRUE. + nmlev=rlmax/rlspc+1 + ALLOCATE(zlev(nmlev)) + DO ji=1,nmlev + zlev(ji)=(ji-1)*rlspc + ENDDO + ELSE + IF (.NOT.lnear) nmlev=nmlev-1 + ALLOCATE(& + & zlev(nmlev) & + & ) + IF(lnear) THEN + CALL getlevs(nmlev,zlev) + ELSE + CALL getlevsmean(nmlev,zlev) + ENDIF + ENDIF + + DO jfile=jfirst, nfiles + CALL getarg(jfile,filename) + WRITE(*,*)'Handling file : ',TRIM(filename) + CALL flush(6) + IF (lzinp) THEN +#if defined NOSYSTEM + WRITE(*,*)'Compressed files need the system subroutine call' + CALL abort +#else + CALL system('cp '//TRIM(filename)//' fbstat_tmp.nc.gz') + CALL system('gzip -df fbstat_tmp.nc.gz') + CALL read_obfbdata('fbstat_tmp.nc',fbdata) + CALL system('rm -f fbstat_tmp.nc') +#endif + ELSE + CALL read_obfbdata(TRIM(filename),fbdata) + ENDIF + CALL sealsfromargo( fbdata ) + IF (jfile==jfirst) THEN + nvar=fbdata%nvar + nadd=0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:2)=='Hx') nadd=nadd+1 + ENDDO + noberr=0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='OBE') noberr=noberr+1 + ENDDO + nbgerr=0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='BGE') nbgerr=nbgerr+1 + ENDDO + IF (lhistogram) THEN + IF (nvar>maxvars) THEN + WRITE(*,*)'fbstat.F90: Increase maxvars to ',nvar + WRITE(*,*)'if you want histograms' + CALL abort + ENDIF + DO jvar = 1, nvar + hist(jvar)%npoints=(zhistmax(jvar)-zhistmin(jvar))& + & /zhiststep(jvar)+1 + WRITE(*,*)'Number of points in histogram = ',& + & hist(jvar)%npoints + WRITE(*,*)'Size of histogram array (elements) = ',& + & hist(jvar)%npoints*nmlev*nboxuserl*nadd + ALLOCATE(& + & hist(jvar)%nhist(hist(jvar)%npoints,nmlev,nboxuserl,nadd,ntyp) & + & ) + hist(jvar)%nhist(:,:,:,:,:)=0 + ENDDO + ENDIF + ipdcst=0 + IF (mindcst>0) THEN + DO ja= 1, fbdata%next + IF (TRIM(fbdata%cextname(ja))=='DCST') THEN + ipdcst=ja + EXIT + ENDIF + ENDDO + IF (ipdcst==0) THEN + WRITE(*,*)'Distance to coast not found in file, but mindcst>0' + WRITE(*,*)'Extra variables:' + DO ja= 1, fbdata%next + WRITE(*,*)ja,TRIM(fbdata%cextname(ja)) + ENDDO + CALL abort + ENDIF + ENDIF + IF (lxyplot) THEN + IF (nvar>maxvars) THEN + WRITE(*,*)'fbstat.F90: Increase maxvars to ',nvar + WRITE(*,*)'if you want xyplots' + CALL abort + ENDIF + DO jvar = 1, nvar + xy(jvar)%npoints=(zxymax(jvar)-zxymin(jvar))& + & /zxystep(jvar)+1 + WRITE(*,*)'Number of points in x and y for xyplots = ',& + & xy(jvar)%npoints + WRITE(*,*)'Size of xyplot array (elements) = ',& + & xy(jvar)%npoints*xy(jvar)%npoints*nmlev*nboxuserl*nadd + ALLOCATE(& + & xy(jvar)%nxy(xy(jvar)%npoints,xy(jvar)%npoints,& + & nmlev,nboxuserl,nadd,ntyp) & + & ) + xy(jvar)%nxy(:,:,:,:,:,:)=0 + ENDDO + ENDIF + ALLOCATE(& + & inum(nmlev,nboxuserl,nadd,nvar,ntyp), & + & inumov(nmlev,nboxuserl,noberr,nvar,ntyp), & + & inumbv(nmlev,nboxuserl,nbgerr,nvar,ntyp), & + & inuma(nmlev,nboxuserl,nvar,ntyp), & + & zbias(nmlev,nboxuserl,nadd,nvar,ntyp), & + & zrms(nmlev,nboxuserl,nadd,nvar,ntyp), & + & zsdev(nmlev,nboxuserl,nadd,nvar,ntyp), & + & zomean(nmlev,nboxuserl,nadd,nvar,ntyp),& + & zmmean(nmlev,nboxuserl,nadd,nvar,ntyp),& + & zoemea(nmlev,nboxuserl,noberr,nvar,ntyp),& + & zovmea(nmlev,nboxuserl,noberr,nvar,ntyp),& + & zbemea(nmlev,nboxuserl,nbgerr,nvar,ntyp),& + & zbvmea(nmlev,nboxuserl,nbgerr,nvar,ntyp),& + & zoamean(nmlev,nboxuserl,nvar,ntyp), & + & cname(nvar), & + & caddname(nadd), & + & cobename(noberr), & + & cbgename(nbgerr) & + & ) + DO jvar = 1, nvar + cname(jvar) = fbdata%cname(jvar) + END DO + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:2)=='Hx') THEN + jadd=jadd+1 + caddname(jadd) = fbdata%caddname(ja) + ENDIF + END DO + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='OBE') THEN + jadd=jadd+1 + cobename(jadd) = fbdata%caddname(ja) + ENDIF + END DO + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='BGE') THEN + jadd=jadd+1 + cbgename(jadd) = fbdata%caddname(ja) + ENDIF + END DO + IF (nadd>0) THEN + inum(:,:,:,:,:)=0 + zbias(:,:,:,:,:)=0.0 + zrms(:,:,:,:,:)=0.0 + zsdev(:,:,:,:,:)=0.0 + zomean(:,:,:,:,:)=0.0 + zmmean(:,:,:,:,:)=0.0 + ENDIF + IF (noberr>0) THEN + inumov(:,:,:,:,:)=0 + zoemea(:,:,:,:,:)=0 + zovmea(:,:,:,:,:)=0 + ENDIF + IF (nbgerr>0) THEN + inumbv(:,:,:,:,:)=0 + zbemea(:,:,:,:,:)=0 + zbvmea(:,:,:,:,:)=0 + ENDIF + inuma(:,:,:,:)=0 + zoamean(:,:,:,:)=0.0 + ELSE + IF (fbdata%nvar/=nvar) THEN + WRITE(*,*)'Different number of nvar ',fbdata%nvar,' in ',& + & TRIM(filename) + CALL abort + ENDIF + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:2)=='Hx') THEN + jadd=jadd+1 + ENDIF + END DO + IF (jadd/=nadd) THEN + WRITE(*,*)'Different number of nadd ',jadd,' in ',& + & TRIM(filename) + CALL abort + ENDIF + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='OBE') THEN + jadd=jadd+1 + ENDIF + END DO + IF (jadd/=noberr) THEN + WRITE(*,*)'Different number of noberr ',jadd,' in ',& + & TRIM(filename) + CALL abort + ENDIF + jadd = 0 + DO ja= 1, fbdata%nadd + IF (fbdata%caddname(ja)(1:3)=='BGE') THEN + jadd=jadd+1 + ENDIF + END DO + IF (jadd/=nbgerr) THEN + WRITE(*,*)'Different number of nbgerr ',jadd,' in ',& + & TRIM(filename) + CALL abort + ENDIF + IF (ipdcst>0) THEN + IF (ipdcst>fbdata%next) THEN + WRITE(*,*)'Distrance to coast in file not compatible with first file' + CALL abort + ENDIF + IF (TRIM(fbdata%cextname(ipdcst))/='DCST') THEN + WRITE(*,*)'Distrance to coast in file not compatible with first file' + CALL abort + ENDIF + ENDIF + ENDIF + IF (lrmmean) THEN + CALL fb_rmmean(fbdata) + ENDIF + CALL fb_stat(fbdata,lskipbox,nmlev,zlev,lnear,nqc,nqco,& + & lhistogram,lxyplot,ntyp,ctyp,ipdcst,mindcst) + CALL dealloc_obfbdata(fbdata) + ENDDO + + DO jt=1,ntyp + DO jvar=1,nvar + DO jadd=1,nadd + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + DO jlev = 1, nmlev + IF ( inum(jlev,jboxl,jadd,jvar,jt) > 0 ) THEN + zbias(jlev,jboxl,jadd,jvar,jt) = & + & zbias(jlev,jboxl,jadd,jvar,jt)/inum(jlev,jboxl,jadd,jvar,jt) + zrms(jlev,jboxl,jadd,jvar,jt) = & + & SQRT(zrms(jlev,jboxl,jadd,jvar,jt)/inum(jlev,jboxl,jadd,jvar,jt)) + zsdev(jlev,jboxl,jadd,jvar,jt) = & + & SQRT(MAX(zrms(jlev,jboxl,jadd,jvar,jt)**2-zbias(jlev,jboxl,jadd,jvar,jt)**2,0.0)) + zomean(jlev,jboxl,jadd,jvar,jt) = & + & zomean(jlev,jboxl,jadd,jvar,jt)/inum(jlev,jboxl,jadd,jvar,jt) + zmmean(jlev,jboxl,jadd,jvar,jt) = & + & zmmean(jlev,jboxl,jadd,jvar,jt)/inum(jlev,jboxl,jadd,jvar,jt) + ELSE + zbias(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zrms(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zsdev(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zomean(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zmmean(jlev,jboxl,jadd,jvar,jt) = fbrmdi + ENDIF + ENDDO + ENDDO + ENDDO + DO jadd=1,noberr + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + DO jlev = 1, nmlev + IF ( inumov(jlev,jboxl,jadd,jvar,jt) > 0 ) THEN + zoemea(jlev,jboxl,jadd,jvar,jt) = & + & zoemea(jlev,jboxl,jadd,jvar,jt)/inumov(jlev,jboxl,jadd,jvar,jt) + zovmea(jlev,jboxl,jadd,jvar,jt) = & + & zovmea(jlev,jboxl,jadd,jvar,jt)/inumov(jlev,jboxl,jadd,jvar,jt) + ELSE + zoemea(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zovmea(jlev,jboxl,jadd,jvar,jt) = fbrmdi + ENDIF + ENDDO + ENDDO + ENDDO + DO jadd=1,nbgerr + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + DO jlev = 1, nmlev + IF ( inumbv(jlev,jboxl,jadd,jvar,jt) > 0 ) THEN + zbemea(jlev,jboxl,jadd,jvar,jt) = & + & zbemea(jlev,jboxl,jadd,jvar,jt)/inumbv(jlev,jboxl,jadd,jvar,jt) + zbvmea(jlev,jboxl,jadd,jvar,jt) = & + & zbvmea(jlev,jboxl,jadd,jvar,jt)/inumbv(jlev,jboxl,jadd,jvar,jt) + ELSE + zbemea(jlev,jboxl,jadd,jvar,jt) = fbrmdi + zbvmea(jlev,jboxl,jadd,jvar,jt) = fbrmdi + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + DO jt=1,ntyp + DO jvar=1,nvar + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + DO jlev = 1, nmlev + IF ( inuma(jlev,jboxl,jvar,jt) > 0 ) THEN + zoamean(jlev,jboxl,jvar,jt) = & + & zoamean(jlev,jboxl,jvar,jt)/inuma(jlev,jboxl,jvar,jt) + ELSE + zoamean(jlev,jboxl,jvar,jt) = fbrmdi + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + IF (ltext) THEN + + DO jt=1,ntyp + DO jvar=1,nvar + DO jadd=1,nadd + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + WRITE(filename,'(7A)')TRIM(cname(jvar)),& + & TRIM(caddname(jadd)),'_',& + & TRIM(cl_boxes_user(jbox)),'_',& + & TRIM(ADJUSTL(ctyp(jt))),'.dat' + OPEN(10,file=TRIM(filename)) + DO jlev = 1, nmlev + WRITE(10,'(F16.7,2I12,5F17.10)') zlev(jlev), & + & jlev, inum(jlev,jboxl,jadd,jvar,jt), & + & zbias(jlev,jboxl,jadd,jvar,jt), & + & zrms(jlev,jboxl,jadd,jvar,jt), & + & zsdev(jlev,jboxl,jadd,jvar,jt), & + & zomean(jlev,jboxl,jadd,jvar,jt), & + & zmmean(jlev,jboxl,jadd,jvar,jt) + ENDDO + CLOSE(10) + ENDDO + ENDDO + DO jadd=1,noberr + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + WRITE(filename,'(7A)')TRIM(cname(jvar)),& + & TRIM(cobename(jadd)),'_',& + & TRIM(cl_boxes_user(jbox)),'_',& + & TRIM(ADJUSTL(ctyp(jt))),'.dat' + OPEN(10,file=TRIM(filename)) + DO jlev = 1, nmlev + WRITE(10,'(F16.7,2I12,5F17.10)') zlev(jlev), & + & jlev, inumov(jlev,jboxl,jadd,jvar,jt), & + & zoemea(jlev,jboxl,jadd,jvar,jt), & + & zovmea(jlev,jboxl,jadd,jvar,jt) + ENDDO + CLOSE(10) + ENDDO + ENDDO + DO jadd=1,nbgerr + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + WRITE(filename,'(7A)')TRIM(cname(jvar)),& + & TRIM(cbgename(jadd)),'_',& + & TRIM(cl_boxes_user(jbox)),'_',& + & TRIM(ADJUSTL(ctyp(jt))),'.dat' + OPEN(10,file=TRIM(filename)) + DO jlev = 1, nmlev + WRITE(10,'(F16.7,2I12,5F17.10)') zlev(jlev), & + & jlev, inumbv(jlev,jboxl,jadd,jvar,jt), & + & zbemea(jlev,jboxl,jadd,jvar,jt), & + & zbvmea(jlev,jboxl,jadd,jvar,jt) + ENDDO + CLOSE(10) + ENDDO + ENDDO + ENDDO + ENDDO + + DO jt=1,ntyp + DO jvar=1,nvar + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + WRITE(filename,'(7A)')TRIM(cname(jvar)),'_',& + & TRIM(cl_boxes_user(jbox)),'_',& + & TRIM(ADJUSTL(ctyp(jt))),'.dat' + OPEN(10,file=TRIM(filename)) + DO jlev = 1, nmlev + WRITE(10,'(F16.7,2I12,F17.10)') zlev(jlev), & + & jlev, inuma(jlev,jboxl,jvar,jt), & + & zoamean(jlev,jboxl,jvar,jt) + ENDDO + CLOSE(10) + ENDDO + ENDDO + ENDDO + + IF (lhistogram) THEN + DO jt=1,ntyp + DO jvar=1,nvar + DO jadd=1,nadd + jboxl=0 + DO jbox=1,nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + WRITE(filename,'(7A)')TRIM(cname(jvar)),& + & TRIM(caddname(jadd)),'_',& + & TRIM(cl_boxes_user(jbox)),'_',& + & TRIM(ADJUSTL(ctyp(jt))),& + & '_histogram.dat' + OPEN(10,file=TRIM(filename)) + WRITE(10,'(A10,1000F10.2)')'#',(zlev(jlev),jlev=1,nmlev) + DO ji=1,hist(jvar)%npoints + WRITE(10,'(F10.2,1000I10)') & + & zhistmin(jvar)+(ji-1)*zhiststep(jvar), & + & (hist(jvar)%nhist(ji,jlev,jboxl,jadd,jt),jlev=1,nmlev) + ENDDO + CLOSE(10) + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + + IF (lnetcdf) THEN + + IF (nadd>0) THEN + DO jt=1,ntyp + WRITE(outfilename,'(3A)')'fbstat_',TRIM(ADJUSTL(ctyp(jt))),'.nc' + CALL fbstat_ncwrite(TRIM(outfilename),& + & nvar,cname,nadd,caddname,noberr,cobename,nbgerr,cbgename,& + & nboxuser,nboxuserl,20,cl_boxes_user,lskipbox,nmlev,zlev,& + & inum(:,:,:,:,jt),zbias(:,:,:,:,jt),zrms(:,:,:,:,jt), & + & zsdev(:,:,:,:,jt),zomean(:,:,:,:,jt),zmmean(:,:,:,:,jt),& + & inuma(:,:,:,jt),zoamean(:,:,:,jt), & + & inumov(:,:,:,:,jt),zoemea(:,:,:,:,jt),zovmea(:,:,:,:,jt), & + & inumbv(:,:,:,:,jt),zbemea(:,:,:,:,jt),zbvmea(:,:,:,:,jt) ) + IF (lhistogram) THEN + WRITE(outfilename,'(3A)')'fbstat_hist_',TRIM(ADJUSTL(ctyp(jt))),'.nc' + CALL fbstat_ncwrite_hist(TRIM(outfilename),& + & nvar,cname,nadd,caddname,& + & nboxuser,20,cl_boxes_user,lskipbox,nmlev,zlev,& + & hist,zhistmin,zhiststep,jt) + ENDIF + IF (lxyplot) THEN + WRITE(outfilename,'(3A)')'fbstat_xyplot_',TRIM(ADJUSTL(ctyp(jt))),'.nc' + CALL fbstat_ncwrite_xy(TRIM(outfilename),& + & nvar,cname,nadd,caddname,& + & nboxuser,20,cl_boxes_user,lskipbox,nmlev,zlev,& + & xy,zxymin,zxystep,jt) + ENDIF + ENDDO + ENDIF + ENDIF + + IF (lomona) THEN + + IF (ntyp>1) THEN + WRITE(*,*)'Omona file only supported for the first type which is : ',TRIM(ctyp(1)) + ENDIF + IF (nmlev>1) THEN + ALLOCATE(zdat3d(nmlev,nboxuser,1)) + ELSE + ALLOCATE(zdat2d(nboxuser,1)) + ENDIF + + cl_expnam=expver + WRITE(cl_date,'(I8.8)')inidate + i_dp = nmlev + itime=icurdate + linnerp=.TRUE. + iloopno = loopno + linnerini = linner + i_fill=0 + + DO jt=1,ntyp + DO jvar = 1, nvar + linner = linnerini + loopno = iloopno + SELECT CASE (TRIM(cname(jvar))) + CASE('POTM') + cl_var = 'votemper' + CASE('PSAL') + cl_var='vosaline' + CASE('SLA') + cl_var='sossheig' + CASE('SST') + cl_var='sosstsst' + CASE('UVEL') + cl_var='vozocrtx' + CASE('VVEL') + cl_var='vomecrty' + END SELECT + DO jadd = 1, nadd + linner = (caddname(jadd)(1:3)=='Hxa').OR.linner + IF (lpassive) THEN + ityp=145 + ELSE + IF (linner) THEN + linnerp=.TRUE. + ityp=144 + IF (jadd>1) loopno=loopno+1 + ELSE + ityp=142 + IF (.NOT.linnerp) THEN + IF (jadd>1) loopno=loopno+1 + ENDIF + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zbias(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zbias(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=245 + ELSE + IF (linner) THEN + ityp=244 + ELSE + ityp=242 + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zrms(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zrms(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=345 + ELSE + IF (linner) THEN + ityp=344 + ELSE + ityp=342 + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zsdev(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zsdev(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=445 + ELSE + IF (linner) THEN + ityp=444 + ELSE + ityp=442 + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = inum(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = inum(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=545 + ELSE + IF (linner) THEN + ityp=544 + ELSE + ityp=542 + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zomean(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zomean(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=645 + ELSE + IF (linner) THEN + ityp=644 + ELSE + ityp=642 + ENDIF + ENDIF + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zmmean(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zmmean(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + linner=.FALSE. + ENDDO + loopno = iloopno + DO jadd = 1, noberr + linner = .TRUE. + ityp = 139 + IF (jadd>1) loopno=loopno+1 + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zoemea(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zoemea(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + ityp = 239 + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zovmea(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zovmea(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + ENDDO + loopno = iloopno + DO jadd = 1, nbgerr + linner = .TRUE. + ityp = 141 + IF (jadd>1) loopno=loopno+1 + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zbemea(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zbemea(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + ityp = 241 + WRITE(cltyp,'(I3.3,A1,I2.2,A1,A)')ityp,'_',loopno,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zbvmea(:,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zbvmea(1,:,jadd,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + ENDDO + IF (lpassive) THEN + ityp=745 + ELSE + ityp=742 + ENDIF + WRITE(cltyp,'(I3.3,A1,A)')ityp,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = inuma(:,:,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = inuma(1,:,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + IF (lpassive) THEN + ityp=845 + ELSE + ityp=842 + ENDIF + WRITE(cltyp,'(I3.3,A1,A)')ityp,'_',& + & TRIM(ADJUSTL(ctyp(jt))) + CALL obs_variable_att(cltyp) + IF (nmlev>1) THEN + zdat3d(:,:,1) = zoamean(:,:,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat3d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + CALL write_dep_netcdf(cl_filename_out,cl_boxes_user,zlev) + ELSE + zdat2d(:,1) = zoamean(1,:,jvar,jt) + i_fill=0 + CALL write_omona_netcdf(cl_filename_out,zdat2d,itime, & + & cl_boxes_user,REAL(fbrmdi),i_fill) + ENDIF + ENDDO + ENDDO + + IF (nmlev>1) THEN + DEALLOCATE(zdat3d) + ELSE + DEALLOCATE(zdat2d) + ENDIF + + ENDIF + +CONTAINS + + SUBROUTINE fb_stat(fbdata,lskipbox,nmlev,zlev,lnear,kqc,kqco,lhist,lxyplot,& + & ntyp,ctyp,ipdcst,mindcst) + USE fbaccdata + USE coords + TYPE(obfbdata) :: fbdata + LOGICAL, DIMENSION(nboxuser) :: lskipbox + INTEGER :: nmlev + REAL :: zlev(nmlev) + LOGICAL :: lnear + INTEGER :: kqc,kqco + LOGICAL :: lhist,lxyplot + INTEGER :: ntyp + CHARACTER(len=ilentyp), DIMENSION(ntyp) :: ctyp + INTEGER :: ipdcst + REAL :: mindcst + INTEGER, DIMENSION(nboxuser) :: jlboxnum + INTEGER :: jlev, jobs, jvar, klev,jlev2,ih,ja,jadd,jbox,jt,ix,iy,jboxl + REAL :: zarea(4),zlat,zlon,zdiff,zdiff2,zvar + + jboxl=0 + jlboxnum=-1 + DO jbox = 1, nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jboxl+1 + jlboxnum(jbox)=jboxl + ENDDO + + !$omp parallel do default(shared) private(jlev,jobs,jvar,klev,jlev2,ih,ja,jadd,jbox,jt,ix,iy,jboxl,zarea,zlat,zlon,zdiff,zdiff2) + DO jbox = 1, nboxuser + IF (lskipbox(jbox)) CYCLE + jboxl=jlboxnum(jbox) + CALL coord_area_user(cl_boxes_user(jbox),zarea) + DO jobs = 1, fbdata%nobs + ! Reject observations with observation, position or time flag rejections + IF (fbdata%ioqc(jobs)>kqco) CYCLE + IF (fbdata%ipqc(jobs)>kqco) CYCLE + IF (fbdata%itqc(jobs)>kqco) CYCLE + zlat = fbdata%pphi(jobs) + zlon = fbdata%plam(jobs) + IF (zlon<0) zlon=zlon+360 + IF (zlon>360) zlon=zlon-360 + IF ( ( zlat .GE. zarea(3) ) .AND. & + & ( zlat .LE. zarea(4) ) .AND. & + & ( ( ( zlon .GE. zarea(1) ) .AND. & + & ( zlon .LE. zarea(2) ) ) .OR. & + & ( ( zarea(2) .LE. zarea(1) ) .AND. & + & ( zlon .GE. zarea(1) ) .AND. & + & ( zlon .LE. 360 ) ) .OR. & + & ( ( zarea(2) .LE. zarea(1) ) .AND. & + & ( zlon .GE. 0 ) .AND. & + & ( zlon .LE. zarea(2) ) ) ) ) THEN + + DO jlev = 1, fbdata%nlev + IF (ipdcst>0) THEN + IF (fbdata%pext(jlev,jobs,ipdcst)==fbrmdi) CYCLE + IF (fbdata%pext(jlev,jobs,ipdcst)<mindcst) CYCLE + ENDIF + DO jvar = 1, fbdata%nvar + IF (nmlev==1) THEN + klev=1 + ELSE + IF (lnear) THEN + zdiff=ABS(fbdata%pdep(jlev,jobs)-zlev(1)) + klev=1 + DO jlev2=2,nmlev + zdiff2=ABS(fbdata%pdep(jlev,jobs)-zlev(jlev2)) + IF (zdiff2<zdiff) THEN + klev=jlev2 + zdiff=zdiff2 + ENDIF + ENDDO + ELSE + klev = fbdata%iobsk(jlev,jobs,jvar)-1 + ENDIF + IF ( klev > nmlev ) THEN + DO ja = 1, fbdata%nadd + IF ( fbdata%caddname(ja)(1:2) /= 'Hx' ) CYCLE + IF ( ABS(fbdata%padd(jlev,jobs,ja,jvar))<9000 ) THEN + WRITE(*,*)'Error in fb_stat' + WRITE(*,*)'Increase nmlev to at least ',klev + klev=nmlev + CALL abort + ENDIF + ENDDO + ENDIF + ENDIF + IF (( klev > 0 ).AND. & + &(ABS(fbdata%pob(jlev,jobs,jvar)) < 9000 )) THEN + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + inuma(klev,jboxl,jvar,jt) = inuma(klev,jboxl,jvar,jt) + 1 + zoamean(klev,jboxl,jvar,jt) = zoamean(klev,jboxl,jvar,jt) + & + & fbdata%pob(jlev,jobs,jvar) + ENDDO + ENDIF + IF ( fbdata%ivlqc(jlev,jobs,jvar) < 0 ) CYCLE + IF ( fbdata%ivlqc(jlev,jobs,jvar) > kqc ) CYCLE + IF (( klev > 0 ).AND. & + &(ABS(fbdata%pob(jlev,jobs,jvar)) < 9000 )) THEN + jadd = 0 + DO ja = 1, fbdata%nadd + IF ( fbdata%caddname(ja)(1:2) /= 'Hx' ) CYCLE + jadd = jadd + 1 + IF ( ABS(fbdata%padd(jlev,jobs,ja,jvar)) < 9000 ) THEN + zdiff = ( fbdata%padd(jlev,jobs,ja,jvar) - & + & fbdata%pob(jlev,jobs,jvar) ) + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + inum(klev,jboxl,jadd,jvar,jt) = inum(klev,jboxl,jadd,jvar,jt) + 1 + zbias(klev,jboxl,jadd,jvar,jt) = zbias(klev,jboxl,jadd,jvar,jt) + & + & zdiff + zrms(klev,jboxl,jadd,jvar,jt) = zrms(klev,jboxl,jadd,jvar,jt) + & + & zdiff * zdiff + zomean(klev,jboxl,jadd,jvar,jt) = zomean(klev,jboxl,jadd,jvar,jt) + & + & fbdata%pob(jlev,jobs,jvar) + zmmean(klev,jboxl,jadd,jvar,jt) = zmmean(klev,jboxl,jadd,jvar,jt) + & + & fbdata%padd(jlev,jobs,ja,jvar) + ENDDO + IF (ABS(zdiff)>zcheck(jvar)) THEN + WRITE(*,*)'Departure outside check range ',& + & TRIM(fbdata%cname(jvar)),' entry ',& + & fbdata%caddname(jadd) + WRITE(*,*)'Depar = ',zdiff + WRITE(*,*)'Check = ',zcheck(jvar) + WRITE(*,*)'Id = ',fbdata%cdwmo(jobs) + WRITE(*,*)'Lat = ',fbdata%pphi(jobs) + WRITE(*,*)'Lon = ',fbdata%plam(jobs) + WRITE(*,*)'Tim = ',fbdata%ptim(jobs) + WRITE(*,*)'Depth = ',fbdata%pdep(jlev,jobs) + WRITE(*,*)'Obs = ',fbdata%pob(jlev,jobs,jvar) + WRITE(*,*)'Var = ',fbdata%padd(jlev,jobs,ja,jvar) + WRITE(*,*)'QC = ',fbdata%ivlqc(jlev,jobs,jvar) + WRITE(*,*)'QCflag= ',fbdata%ivlqcf(:,jlev,jobs,jvar) + ENDIF + IF (lhist) THEN + ih=NINT((zdiff-zhistmin(jvar))/zhiststep(jvar))+1 + IF ((ih>=1).AND.(ih<=hist(jvar)%npoints)) THEN + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + hist(jvar)%nhist(ih,klev,jboxl,jadd,jt) = & + hist(jvar)%nhist(ih,klev,jboxl,jadd,jt) +1 + ENDDO + ELSE + WRITE(*,*)'Histogram value outside range for ',& + & TRIM(fbdata%cname(jvar)),' entry ',& + & fbdata%caddname(jadd) + WRITE(*,*)'Value = ',zdiff + WRITE(*,*)'Range = ',zhistmin(jvar),zhistmax(jvar) + WRITE(*,*)'Step = ',zhiststep(jvar) + WRITE(*,*)'Index = ',ih + WRITE(*,*)'Id = ',TRIM(fbdata%cdwmo(jobs)) + WRITE(*,*)'Typ = ',TRIM(fbdata%cdtyp(jobs)) + WRITE(*,*)'Lat = ',fbdata%pphi(jobs) + WRITE(*,*)'Lon = ',fbdata%plam(jobs) + WRITE(*,*)'Tim = ',fbdata%ptim(jobs) + WRITE(*,*)'Depth = ',fbdata%pdep(jlev,jobs) + WRITE(*,*)'Obs = ',fbdata%pob(jlev,jobs,jvar) + WRITE(*,*)'Var = ',fbdata%padd(jlev,jobs,jadd,jvar) + WRITE(*,*)'QC = ',fbdata%ivlqc(jlev,jobs,jvar) + WRITE(*,*)'QCflag= ',fbdata%ivlqcf(:,jlev,jobs,jvar) + ENDIF + ENDIF + IF (lxyplot) THEN + ix=NINT((fbdata%pob(jlev,jobs,jvar)-zxymin(jvar))/& + & zxystep(jvar))+1 + iy=NINT((fbdata%padd(jlev,jobs,ja,jvar)-zxymin(jvar))/& + & zxystep(jvar))+1 + IF ((ix>=1).AND.(ix<=xy(jvar)%npoints).AND. & + &(iy>=1).AND.(iy<=xy(jvar)%npoints)) THEN + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + xy(jvar)%nxy(ix,iy,klev,jboxl,jadd,jt) = & + xy(jvar)%nxy(ix,iy,klev,jboxl,jadd,jt) +1 + ENDDO + ELSE + WRITE(*,*)'xy plot values outside range for ',& + & TRIM(fbdata%cname(jvar)),' entry ',& + & fbdata%caddname(jadd) + WRITE(*,*)'Obs = ',fbdata%pob(jlev,jobs,jvar) + WRITE(*,*)'Model = ',fbdata%padd(jlev,jobs,ja,jvar) + WRITE(*,*)'Range = ',zxymin(jvar),zxymax(jvar) + WRITE(*,*)'Step = ',zxystep(jvar) + WRITE(*,*)'Index = ',ih + WRITE(*,*)'Id = ',TRIM(fbdata%cdwmo(jobs)) + WRITE(*,*)'Typ = ',TRIM(fbdata%cdtyp(jobs)) + WRITE(*,*)'Lat = ',fbdata%pphi(jobs) + WRITE(*,*)'Lon = ',fbdata%plam(jobs) + WRITE(*,*)'Tim = ',fbdata%ptim(jobs) + WRITE(*,*)'Depth = ',fbdata%pdep(jlev,jobs) + WRITE(*,*)'Obs = ',fbdata%pob(jlev,jobs,jvar) + WRITE(*,*)'Var = ',fbdata%padd(jlev,jobs,jadd,jvar) + WRITE(*,*)'QC = ',fbdata%ivlqc(jlev,jobs,jvar) + WRITE(*,*)'QCflag= ',fbdata%ivlqcf(:,jlev,jobs,jvar) + ENDIF + ENDIF + ENDIF + ENDDO + jadd = 0 + DO ja = 1, fbdata%nadd + IF ( fbdata%caddname(ja)(1:3) /= 'OBE' ) CYCLE + jadd = jadd + 1 + IF ( ABS(fbdata%padd(jlev,jobs,ja,jvar)) < 9000 ) THEN + zvar = fbdata%padd(jlev,jobs,ja,jvar)*fbdata%padd(jlev,jobs,ja,jvar) + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + inumov(klev,jboxl,jadd,jvar,jt) = inumov(klev,jboxl,jadd,jvar,jt) + 1 + zoemea(klev,jboxl,jadd,jvar,jt) = zoemea(klev,jboxl,jadd,jvar,jt) + & + & fbdata%padd(jlev,jobs,ja,jvar) + zovmea(klev,jboxl,jadd,jvar,jt) = zovmea(klev,jboxl,jadd,jvar,jt) + zvar + ENDDO + ENDIF + ENDDO + jadd = 0 + DO ja = 1, fbdata%nadd + IF ( fbdata%caddname(ja)(1:3) /= 'BGE' ) CYCLE + jadd = jadd + 1 + IF ( ABS(fbdata%padd(jlev,jobs,ja,jvar)) < 9000 ) THEN + zvar = fbdata%padd(jlev,jobs,ja,jvar)*fbdata%padd(jlev,jobs,ja,jvar) + DO jt=1,ntyp + IF (TRIM(ADJUSTL(ctyp(jt)))/='all') THEN + IF (TRIM(ADJUSTL(ctyp(jt)))/=TRIM(ADJUSTL(fbdata%cdtyp(jobs)))) CYCLE + ENDIF + inumbv(klev,jboxl,jadd,jvar,jt) = inumbv(klev,jboxl,jadd,jvar,jt) + 1 + zbemea(klev,jboxl,jadd,jvar,jt) = zbemea(klev,jboxl,jadd,jvar,jt) + & + & fbdata%padd(jlev,jobs,ja,jvar) + zbvmea(klev,jboxl,jadd,jvar,jt) = zbvmea(klev,jboxl,jadd,jvar,jt) + zvar + ENDDO + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO + ENDDO + !$omp end parallel do + + END SUBROUTINE fb_stat + + SUBROUTINE fb_rmmean(fbdata) + TYPE(obfbdata) :: fbdata + INTEGER :: jadd,jmean + + jmean=0 + DO jadd=1,fbdata%nadd + IF (fbdata%caddname(jadd)(1:4)=='MEAN') THEN + jmean=jadd + EXIT + ENDIF + ENDDO + IF (jmean==0) THEN + WRITE(*,*)'Warning: MEAN additional variable not found' + RETURN + ENDIF + IF (fbdata%nobs>0) THEN + DO jadd=1,fbdata%nadd + IF (fbdata%caddname(jadd)(1:2)=='Hx') THEN + fbdata%padd(:,:,jadd,:)=fbdata%padd(:,:,jadd,:)& + & +fbdata%padd(:,:,jmean,:) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE fb_rmmean + + SUBROUTINE getlevsmean(nmlev,zlev) + IMPLICIT NONE + INTEGER :: nmlev + REAL,DIMENSION(nmlev) :: zlev + REAL,DIMENSION(nmlev+1) :: ztmp + INTEGER :: i + + zlev(:)=9999.9 + CALL getlevs(nmlev+1,ztmp) + DO i=1,nmlev + zlev(i)=0.5*(ztmp(i)+ztmp(i+1)) + ENDDO + + END SUBROUTINE getlevsmean + + SUBROUTINE getlevs(nmlev,zlev) + IMPLICIT NONE + INTEGER :: nmlev + REAL,DIMENSION(nmlev) :: zlev + + zlev(:)=9999.9 + + IF (nmlev==42) THEN + zlev(1)=5.02159 + zlev(2)=15.07854 + zlev(3)=25.16046 + zlev(4)=35.27829 + zlev(5)=45.44776 + zlev(6)=55.69149 + zlev(7)=66.04198 + zlev(8)=76.54591 + zlev(9)=87.27029 + zlev(10)=98.31118 + zlev(11)=109.8062 + zlev(12)=121.9519 + zlev(13)=135.0285 + zlev(14)=149.4337 + zlev(15)=165.7285 + zlev(16)=184.6975 + zlev(17)=207.4254 + zlev(18)=235.3862 + zlev(19)=270.5341 + zlev(20)=315.3741 + zlev(21)=372.9655 + zlev(22)=446.8009 + zlev(23)=540.5022 + zlev(24)=657.3229 + zlev(25)=799.5496 + zlev(26)=967.9958 + zlev(27)=1161.806 + zlev(28)=1378.661 + zlev(29)=1615.291 + zlev(30)=1868.071 + zlev(31)=2133.517 + zlev(32)=2408.583 + zlev(33)=2690.780 + zlev(34)=2978.166 + zlev(35)=3269.278 + zlev(36)=3563.041 + zlev(37)=3858.676 + zlev(38)=4155.628 + zlev(39)=4453.502 + zlev(40)=4752.021 + zlev(41)=5050.990 + zlev(42)=5350.272 + ELSEIF (nmlev==31) THEN + zlev(1)=4.999938 + zlev(2)=15.00029 + zlev(3)=25.00176 + zlev(4)=35.00541 + zlev(5)=45.01332 + zlev(6)=55.0295 + zlev(7)=65.06181 + zlev(8)=75.12551 + zlev(9)=85.25037 + zlev(10)=95.49429 + zlev(11)=105.9699 + zlev(12)=116.8962 + zlev(13)=128.6979 + zlev(14)=142.1953 + zlev(15)=158.9606 + zlev(16)=181.9628 + zlev(17)=216.6479 + zlev(18)=272.4767 + zlev(19)=364.303 + zlev(20)=511.5348 + zlev(21)=732.2009 + zlev(22)=1033.217 + zlev(23)=1405.698 + zlev(24)=1830.885 + zlev(25)=2289.768 + zlev(26)=2768.242 + zlev(27)=3257.479 + zlev(28)=3752.442 + zlev(29)=4250.401 + zlev(30)=4749.913 + zlev(31)=5250.227 + ELSEIF (nmlev==1) THEN + zlev(1)=0.0 + ELSE + WRITE(*,*) 'Unknown number of levels' + CALL abort + ENDIF + + END SUBROUTINE getlevs + +END PROGRAM fbstat diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstatncio.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstatncio.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6689ec837091d56857714d80a67d4b20d4a715ef --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbstatncio.F90 @@ -0,0 +1,995 @@ +#define MYFILE 'fbstatncio.F90' +MODULE fbstatncio + + USE fbacctype + USE nctools + IMPLICIT NONE + + REAL, PARAMETER :: fbstncmiss = 99999. + + TYPE fbstatnctype + INTEGER :: nlev,nbox,nadd + CHARACTER(len=20), POINTER, DIMENSION(:) :: area + CHARACTER(len=32), POINTER, DIMENSION(:) :: name + REAL, POINTER, DIMENSION(:) :: dep + REAL, POINTER, DIMENSION(:,:,:) :: val + INTEGER, POINTER, DIMENSION(:,:) :: cnt + END TYPE fbstatnctype + + TYPE fbstathistnctype + INTEGER :: nlev,nbox,npoints + CHARACTER(len=20), POINTER, DIMENSION(:) :: area + REAL, POINTER, DIMENSION(:) :: dep,val + INTEGER, POINTER, DIMENSION(:,:,:) :: nhist + END TYPE fbstathistnctype + + TYPE fbstatxynctype + INTEGER :: nlev,nbox,npoints + CHARACTER(len=20), POINTER, DIMENSION(:) :: area + REAL, POINTER, DIMENSION(:) :: dep,val + INTEGER, POINTER, DIMENSION(:,:,:,:) :: nxy + END TYPE fbstatxynctype + +CONTAINS + + SUBROUTINE fbstat_ncwrite(cdfilename,nvar,cdvar,nadd,cdadd,& + & nobe,cdobe,nbge,cdbge,& + & nbox,nboxl,lenboxname,cdboxnam,lskipbox,nlev,pdep,& + & knum,pbias,prms,pstd,pomean,pmmean,knuma,poamean, & + & knumo,poerr,povar,knumb,pberr,pbvar) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + INTEGER :: nvar ! Number of variables + CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables + INTEGER :: nadd ! Number of additional data + CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries + INTEGER :: nobe ! Number of obs errors + CHARACTER(len=*), DIMENSION(nadd) :: cdobe ! Name of obs erors + INTEGER :: nbge ! Number of bg errors + CHARACTER(len=*), DIMENSION(nadd) :: cdbge ! Name of bg erors + INTEGER :: nbox ! Total number of boxes + INTEGER :: nboxl ! Actual number of boxes + INTEGER :: lenboxname ! Length of box names + CHARACTER(len=lenboxname), DIMENSION(nbox) :: & + & cdboxnam ! Name of boxes + LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip + INTEGER :: nlev ! Number of levels + REAL,DIMENSION(nlev) :: pdep ! Depth of levels + INTEGER, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data + & knum + REAL, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data + & pbias, prms, pstd, pomean, pmmean + INTEGER, DIMENSION(nlev,nboxl,nvar) :: & ! Output data + & knuma + REAL, DIMENSION(nlev,nboxl,nvar) :: & ! Output data + & poamean + INTEGER, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data + & knumo + REAL, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data + & poerr,povar + INTEGER, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data + & knumb + REAL, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data + & pberr,pbvar + ! Local variables + INTEGER :: jadd,jvar,incvar,iv,jbox,ip + CHARACTER(len=50) :: cncvarbase + CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar + ! netcdf stuff + INTEGER :: ncid,idlev,idbox,idlbox,idimdep(1),idimbox(2),idimids(2) + INTEGER :: idvbox,idvlev + INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar + INTEGER :: inoboxes + REAL, ALLOCATABLE, DIMENSION(:,:) :: ztmp + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: itmp + CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & + & clboxnam ! Name of boxes + + ! Open netCDF files. + + CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& + & __LINE__,MYFILE) + + ! Create dimensions + + inoboxes=nbox-COUNT(lskipbox) + ALLOCATE(ztmp(nlev,inoboxes),itmp(nlev,inoboxes),clboxnam(inoboxes)) + + CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& + & __LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) + + ! Box variable name + + idimbox(1)=idlbox + idimbox(2)=idbox + CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& + & __LINE__,MYFILE) + + ! Depths + + idimdep(1)=idlev + CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& + & __LINE__,MYFILE) + + ! Setup variables names + + idimids(1)=idlev + idimids(2)=idbox + incvar=(nadd*6+nobe*3+nbge*3+2)*nvar + ALLOCATE(cncvar(incvar),idvar(incvar)) + iv=0 + DO jvar=1,nvar + DO jadd=1,nadd + WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdadd(jadd)) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_bias' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_rms' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_std' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_omean' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_mmean' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_count' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + ENDDO + DO jadd=1,nobe + WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdobe(jadd)) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_meanerr' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_meanvar' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_count' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + ENDDO + DO jadd=1,nbge + WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdbge(jadd)) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_meanerr' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_meanvar' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_count' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + ENDDO + WRITE(cncvarbase,'(A)')TRIM(cdvar(jvar)) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_omean' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + iv=iv+1 + cncvar(iv)=TRIM(cncvarbase)//'_count' + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& + & idimids,idvar(iv)),__LINE__,MYFILE) + CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& + & __LINE__,MYFILE) + ENDDO + CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) + + ! Write box names + + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + clboxnam(ip)=cdboxnam(jbox) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& + & __LINE__,MYFILE) + + ! Write levels + + CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& + & __LINE__,MYFILE) + + ! Write the output data + + iv=0 + DO jvar=1,nvar + DO jadd=1,nadd + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pbias(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=prms(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pstd(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pomean(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pmmean(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,ip)=knum(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + ENDDO + DO jadd=1,nobe + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=poerr(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=povar(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,ip)=knumo(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + ENDDO + DO jadd=1,nbge + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pberr(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=pbvar(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,ip)=knumb(:,ip,jadd,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + ENDDO + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + ztmp(:,ip)=poamean(:,ip,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& + & __LINE__,MYFILE) + iv=iv+1 + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,ip)=knuma(:,ip,jvar) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + ENDDO + + ! Close the file + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + DEALLOCATE(cncvar,idvar,ztmp,itmp,clboxnam) + + END SUBROUTINE fbstat_ncwrite + + SUBROUTINE fbstat_ncwrite_hist(cdfilename,nvar,cdvar,nadd,cdadd,& + & nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,& + & zhist,zhistmin,zhiststep,ntyp) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + INTEGER :: nvar ! Number of variables + CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables + INTEGER :: nadd ! Number of addiables + CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries + INTEGER :: nbox ! Number of boxes + INTEGER :: lenboxname ! Length of box names + CHARACTER(len=lenboxname), dimension(nbox) :: & + & cdboxnam ! Name of boxes + LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip + INTEGER :: nlev ! Number of levels + REAL,DIMENSION(nlev) :: pdep ! Depth of levels + TYPE(histtype), DIMENSION(nvar) :: zhist ! Histogram data + REAL, DIMENSION(nvar) :: & + & zhistmin,zhiststep ! Histogram info + integer :: ntyp ! Type to write + ! Local variables + INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox + CHARACTER(len=50) :: cncvarbase + CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar + ! netcdf stuff + INTEGER :: ncid,idlev,idbox,idlbox,idimhist(nvar),& + & idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(3) + INTEGER :: idvbox,idvlev + INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar + CHARACTER(len=40) :: cdhdimname + REAL, ALLOCATABLE, DIMENSION(:) :: zhval + INTEGER :: inoboxes + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: itmp + CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & + & clboxnam ! Name of boxes + + ! Open netCDF files. + + CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& + & __LINE__,MYFILE) + + ! Create dimensions + + inoboxes=nbox-COUNT(lskipbox) + ALLOCATE(clboxnam(inoboxes)) + + CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& + & __LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) + + DO jvar=1,nvar + WRITE(cdhdimname,'(A,A)')'hist',TRIM(cdvar(jvar)) + CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),& + & zhist(jvar)%npoints,idimhist(jvar)),& + & __LINE__,MYFILE) + ENDDO + + ! Box variable name + + idimbox(1)=idlbox + idimbox(2)=idbox + CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& + & __LINE__,MYFILE) + + ! Depths + + idimdep(1)=idlev + CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& + & __LINE__,MYFILE) + + ! Histogram values and depths + + incvar=nvar+nadd*nvar + ALLOCATE(cncvar(incvar),idvar(incvar)) + iv=0 + DO jvar=1,nvar + iv=iv+1 + WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val' + idimval(1)=idimhist(jvar) + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& + & nf90_float,idimval,idvar(iv)),& + & __LINE__,MYFILE) + DO jadd=1,nadd + iv=iv+1 + WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),& + & TRIM(cdadd(jadd)),'_count' + idimcnt(1)=idimhist(jvar) + idimcnt(2)=idlev + idimcnt(3)=idbox + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& + & nf90_int,idimcnt,idvar(iv)),& + & __LINE__,MYFILE) + ENDDO + ENDDO + CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) + + ! Write box names + + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + clboxnam(ip)=cdboxnam(jbox) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& + & __LINE__,MYFILE) + + ! Write levels + + CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& + & __LINE__,MYFILE) + + iv=0 + DO jvar=1,nvar + iv=iv+1 + ALLOCATE(zhval(zhist(jvar)%npoints)) + DO ji=1,zhist(jvar)%npoints + zhval(ji)=(ji-1)*zhiststep(jvar)+zhistmin(jvar) + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),& + & __LINE__,MYFILE) + DEALLOCATE(zhval) + DO jadd=1,nadd + iv=iv+1 + ALLOCATE(itmp(zhist(jvar)%npoints,nlev,inoboxes)) + ip=0 + DO jbox=1,nbox + IF(.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,:,ip)=zhist(jvar)%nhist(:,:,ip,jadd,ntyp) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + DEALLOCATE(itmp) + ENDDO + ENDDO + + ! Close the file + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + DEALLOCATE(cncvar,idvar,clboxnam) + + END SUBROUTINE fbstat_ncwrite_hist + + SUBROUTINE fbstat_ncwrite_xy(cdfilename,nvar,cdvar,nadd,cdadd,& + & nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,& + & zxy,zxymin,zxystep,ntyp) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + INTEGER :: nvar ! Number of variables + CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables + INTEGER :: nadd ! Number of addiables + CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries + INTEGER :: nbox ! Number of boxes + INTEGER :: lenboxname ! Length of box names + CHARACTER(len=lenboxname), dimension(nbox) :: & + & cdboxnam ! Name of boxes + LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip + INTEGER :: nlev ! Number of levels + REAL,DIMENSION(nlev) :: pdep ! Depth of levels + TYPE(xytype), DIMENSION(nvar) :: zxy ! xyplot data + REAL, DIMENSION(nvar) :: & + & zxymin,zxystep ! xyplot info + integer :: ntyp ! Type to write + ! Local variables + INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox + CHARACTER(len=50) :: cncvarbase + CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar + ! netcdf stuff + INTEGER :: ncid,idlev,idbox,idlbox,idimxy(nvar),& + & idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(4) + INTEGER :: idvbox,idvlev + INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar + CHARACTER(len=40) :: cdhdimname + REAL, ALLOCATABLE, DIMENSION(:) :: zhval + INTEGER :: inoboxes + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:) :: itmp + CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & + & clboxnam ! Name of boxes + + ! Open netCDF files. + + CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& + & __LINE__,MYFILE) + + ! Create dimensions + + inoboxes=nbox-COUNT(lskipbox) + ALLOCATE(clboxnam(inoboxes)) + + CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& + & __LINE__,MYFILE) + + CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) + + DO jvar=1,nvar + WRITE(cdhdimname,'(A,A)')'xy',TRIM(cdvar(jvar)) + CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),& + & zxy(jvar)%npoints,idimxy(jvar)),& + & __LINE__,MYFILE) + ENDDO + + ! Box variable name + + idimbox(1)=idlbox + idimbox(2)=idbox + CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& + & __LINE__,MYFILE) + + ! Depths + + idimdep(1)=idlev + CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& + & __LINE__,MYFILE) + + ! Histogram values and depths + + incvar=nvar+nadd*nvar + ALLOCATE(cncvar(incvar),idvar(incvar)) + iv=0 + DO jvar=1,nvar + iv=iv+1 + WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val' + idimval(1)=idimxy(jvar) + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& + & nf90_float,idimval,idvar(iv)),& + & __LINE__,MYFILE) + DO jadd=1,nadd + iv=iv+1 + WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),& + & TRIM(cdadd(jadd)),'_count' + idimcnt(1)=idimxy(jvar) + idimcnt(2)=idimxy(jvar) + idimcnt(3)=idlev + idimcnt(4)=idbox + CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& + & nf90_int,idimcnt,idvar(iv)),& + & __LINE__,MYFILE) + ENDDO + ENDDO + CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) + + ! Write box names + + ip=0 + DO jbox=1,nbox + IF (.NOT.lskipbox(jbox)) THEN + ip=ip+1 + clboxnam(ip)=cdboxnam(jbox) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& + & __LINE__,MYFILE) + + ! Write levels + + CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& + & __LINE__,MYFILE) + + iv=0 + DO jvar=1,nvar + iv=iv+1 + ALLOCATE(zhval(zxy(jvar)%npoints)) + DO ji=1,zxy(jvar)%npoints + zhval(ji)=(ji-1)*zxystep(jvar)+zxymin(jvar) + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),& + & __LINE__,MYFILE) + DEALLOCATE(zhval) + DO jadd=1,nadd + iv=iv+1 + ALLOCATE(itmp(zxy(jvar)%npoints,zxy(jvar)%npoints,nlev,inoboxes)) + ip=0 + DO jbox=1,nbox + IF(.NOT.lskipbox(jbox)) THEN + ip=ip+1 + itmp(:,:,:,ip)=zxy(jvar)%nxy(:,:,:,ip,jadd,ntyp) + ENDIF + ENDDO + CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& + & __LINE__,MYFILE) + DEALLOCATE(itmp) + ENDDO + ENDDO + + ! Close the file + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + DEALLOCATE(cncvar,idvar,clboxnam) + + END SUBROUTINE fbstat_ncwrite_xy + + SUBROUTINE fbstat_ncread(cdfilename,cdvar,sdata) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + CHARACTER(len=*) :: cdvar ! Name of variables + TYPE(fbstatnctype) :: sdata ! Data to be filled + ! Local variables + INTEGER :: nbox,nlev,nadd,nvar + INTEGER :: ncid,dimid,varid,i,icntpos + CHARACTER(len=128) :: cdname,tmpname + + ! Open the file and get the dimensions + + CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nbox),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nlev),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire(ncid,nVariables=nvar),__LINE__,MYFILE) + + ! Count the number of variables and find the "count" position + + nadd=0 + icntpos=0 + DO i=1,nvar + CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),& + & __LINE__,MYFILE) + IF (TRIM(cdvar)//'_count'==TRIM(cdname)) THEN + icntpos=i + ELSE + IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN + tmpname=cdname(LEN_TRIM(cdvar)+2:) + IF (INDEX(tmpname,'_')==0) THEN + nadd=nadd+1 + ENDIF + ENDIF + ENDIF + ENDDO + + ! Allocate the data structure + + CALL fbstat_ncread_alloc(sdata,nlev,nbox,nadd) + + ! Get the box names in files + + CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) + + ! Get the depths + + CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) + + nadd=0 + DO i=1,nvar + CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),& + & __LINE__,MYFILE) + IF (i==icntpos) THEN + CALL nchdlerr(nf90_get_var(ncid,i,sdata%cnt),__LINE__,MYFILE) + ELSE + IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN + tmpname=cdname(LEN_TRIM(cdvar)+2:) + IF (INDEX(tmpname,'_')==0) THEN + nadd=nadd+1 + sdata%name(nadd)=tmpname(1:MAX(LEN_TRIM(tmpname),32)) + CALL nchdlerr(nf90_get_var(ncid,i,sdata%val(:,:,nadd)),& + & __LINE__,MYFILE) + ENDIF + ENDIF + ENDIF + ENDDO + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + END SUBROUTINE fbstat_ncread + + SUBROUTINE fbstat_ncread_alloc(sdata,nlev,nbox,nadd) + ! Arguments + TYPE(fbstatnctype) :: sdata ! Data to be allocated + INTEGER :: nlev,nbox,nadd + ! Local variables + + sdata%nlev=nlev + sdata%nbox=nbox + sdata%nadd=nadd + ALLOCATE( & + & sdata%area(nbox), & + & sdata%dep(nlev), & + & sdata%name(nadd), & + & sdata%val(nlev,nbox,nadd), & + & sdata%cnt(nlev,nbox) & + ) + + END SUBROUTINE fbstat_ncread_alloc + + SUBROUTINE fbstat_ncread_dealloc(sdata) + ! Arguments + TYPE(fbstatnctype) :: sdata ! Data to be deallocated + ! Local variables + + sdata%nlev=0 + sdata%nbox=0 + sdata%nadd=0 + DEALLOCATE( & + & sdata%area, & + & sdata%dep, & + & sdata%name, & + & sdata%val, & + & sdata%cnt & + ) + + END SUBROUTINE fbstat_ncread_dealloc + + SUBROUTINE fbstat_ncread_hist(cdfilename,cdvar,cdext,sdata) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + CHARACTER(len=*) :: cdvar ! Name of variables + CHARACTER(len=*) :: cdext ! Name of extras + TYPE(fbstathistnctype) :: sdata ! Data to be filled + ! Local variables + INTEGER :: nbox,nlev,npoints + INTEGER :: ncid,dimid,varid + + ! Open the file and get the dimensions + + CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nbox),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nlev),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'hist'//TRIM(cdvar),dimid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=npoints),__LINE__,MYFILE) + + ! Allocate the data structure + + CALL fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox) + + ! Get the box names in files + + CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) + + ! Get the depths + + CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) + + ! Get values + + CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE) + + ! Get histograms + + CALL nchdlerr(nf90_inq_varid(ncid,& + & TRIM(cdvar)//TRIM(cdext)//'_count',varid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nhist),__LINE__,MYFILE) + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + END SUBROUTINE fbstat_ncread_hist + + SUBROUTINE fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox) + ! Arguments + TYPE(fbstathistnctype) :: sdata ! Data to be allocated + INTEGER :: npoints,nlev,nbox + ! Local variables + + sdata%nlev=nlev + sdata%nbox=nbox + sdata%npoints=npoints + ALLOCATE( & + & sdata%area(nbox), & + & sdata%dep(nlev), & + & sdata%val(npoints), & + & sdata%nhist(npoints,nlev,nbox) & + & ) + + END SUBROUTINE fbstat_ncread_hist_alloc + + SUBROUTINE fbstat_ncread_hist_dealloc(sdata) + ! Arguments + TYPE(fbstathistnctype) :: sdata ! Data to be deallocated + ! Local variables + + sdata%nlev=0 + sdata%nbox=0 + sdata%npoints=0 + DEALLOCATE( & + & sdata%area, & + & sdata%dep, & + & sdata%val, & + & sdata%nhist & + & ) + + END SUBROUTINE fbstat_ncread_hist_dealloc + + SUBROUTINE fbstat_ncread_xy(cdfilename,cdvar,cdext,sdata) + ! Arguments + CHARACTER(len=*) :: cdfilename ! Netcdf filename + CHARACTER(len=*) :: cdvar ! Name of variables + CHARACTER(len=*) :: cdext ! Name of extras + TYPE(fbstatxynctype) :: sdata ! Data to be filled + ! Local variables + INTEGER :: nbox,nlev,npoints + INTEGER :: ncid,dimid,varid + + ! Open the file and get the dimensions + + CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nbox),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=nlev),__LINE__,MYFILE) + CALL nchdlerr(nf90_inq_dimid(ncid,'xy'//TRIM(cdvar),dimid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& + & len=npoints),__LINE__,MYFILE) + + ! Allocate the data structure + + CALL fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox) + + ! Get the box names in files + + CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) + + ! Get the depths + + CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) + + ! Get values + + CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE) + + ! Get xyograms + + CALL nchdlerr(nf90_inq_varid(ncid,& + & TRIM(cdvar)//TRIM(cdext)//'_count',varid),& + & __LINE__,MYFILE) + CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nxy),__LINE__,MYFILE) + + CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) + + END SUBROUTINE fbstat_ncread_xy + + SUBROUTINE fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox) + ! Arguments + TYPE(fbstatxynctype) :: sdata ! Data to be allocated + INTEGER :: npoints,nlev,nbox + ! Local variables + + sdata%nlev=nlev + sdata%nbox=nbox + sdata%npoints=npoints + ALLOCATE( & + & sdata%area(nbox), & + & sdata%dep(nlev), & + & sdata%val(npoints), & + & sdata%nxy(npoints,npoints,nlev,nbox) & + & ) + + END SUBROUTINE fbstat_ncread_xy_alloc + + SUBROUTINE fbstat_ncread_xy_dealloc(sdata) + ! Arguments + TYPE(fbstatxynctype) :: sdata ! Data to be deallocated + ! Local variables + + sdata%nlev=0 + sdata%nbox=0 + sdata%npoints=0 + DEALLOCATE( & + & sdata%area, & + & sdata%dep, & + & sdata%val, & + & sdata%nxy & + & ) + + END SUBROUTINE fbstat_ncread_xy_dealloc + +END MODULE fbstatncio diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/fbthin.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbthin.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e1b5223cb3eede8c2f9a8476e6d63846989a0b53 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/fbthin.F90 @@ -0,0 +1,164 @@ +PROGRAM fbthin + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM fbthin ** + !! + !! ** Purpose : Thin the data to 1 degree resolution + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! fbthin.exe inputfile outputfile + !! + !! Required: + !! namelist = namthin.in + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + IMPLICIT NONE + ! + ! Command line arguments for output file and input file + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256) :: cdinfile + CHARACTER(len=256) :: cdtmp + INTEGER :: nout,ninn,nadd,next,i,j,k + LOGICAL :: lgrid + ! + ! Feedback data + ! + TYPE(obfbdata) :: fbdatain + ! + ! Get number of command line arguments + ! + nargs=IARGC() + IF ((nargs /= 2)) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'fbthin inputfile outputfile' + CALL abort() + ENDIF + CALL getarg(1,cdinfile) + CALL getarg(2,cdoutfile) + ! + ! Initialize feedback data + ! + CALL init_obfbdata( fbdatain ) + ! + ! Read the file + ! + CALL read_obfbdata( TRIM(cdinfile), fbdatain ) + ! + ! Do the thining + ! + CALL fb_thin( fbdatain ) + ! + ! Write the file + ! + CALL write_obfbdata( TRIM(cdoutfile), fbdatain ) + +CONTAINS + + SUBROUTINE fb_thin( fbdata ) + ! + ! Observation thinning + ! + IMPLICIT NONE + TYPE(obfbdata) :: fbdata + ! Namelist parameters + INTEGER, PARAMETER :: nmaxtypes = 10 + CHARACTER(len=ilentyp), DIMENSION(nmaxtypes) :: thintypes + REAL, DIMENSION(nmaxtypes) :: thindists, thindtime + ! Local variables + NAMELIST/namthin/thintypes, thindists, thindtime + INTEGER :: it,ii,ij,iv,iobs,irej + REAL :: zdist + + ! Get namelist + thintypes(:) = 'XXXX' + ! Distance in km + thindists(:) = 100.0 + ! Time difference in days + thindtime(:) = 0.99999999 + OPEN(10,file='namthin.in') + READ(10,namthin) + CLOSE(10) + WRITE(*,namthin) + + ! Convert to meters + thindists(:) = thindists(:) * 1000.0 + + DO it = 1, nmaxtypes + + IF ( TRIM(thintypes(it)) == 'XXXX' ) CYCLE + + iobs = 0 + irej = 0 + + master_loop: DO ii= 1, fbdata%nobs + + IF ( TRIM(ADJUSTL(thintypes(it))) /= 'all' ) THEN + IF ( TRIM(ADJUSTL(fbdata%cdtyp(ii))) /= & + & TRIM(ADJUSTL(thintypes(it))) ) CYCLE + ENDIF + + iobs = iobs + 1 + + ! Skip data with missing lon and lat and observation flag rejected. + + IF (fbdata%plam(ii)==fbrmdi) CYCLE + IF (fbdata%pphi(ii)==fbrmdi) CYCLE + IF (fbdata%ioqc(ii)>2) CYCLE + + DO ij=ii+1, fbdata%nobs + + ! Skip data with missing lon and lat and observation flag rejected. + + IF (fbdata%plam(ij)==fbrmdi) CYCLE + IF (fbdata%pphi(ij)==fbrmdi) CYCLE + IF (fbdata%ioqc(ij)>2) CYCLE + + ! Skip different type unless thintypes is 'all' + + IF ( TRIM(ADJUSTL(thintypes(it))) /= 'all' ) THEN + IF ( TRIM(ADJUSTL(fbdata%cdtyp(ij))) /= & + & TRIM(ADJUSTL(thintypes(it))) ) CYCLE + ENDIF + + IF ( ABS( fbdata%ptim(ij) - fbdata%ptim(ii) ) & + & >= thindtime(it) ) CYCLE + + zdist = distance( fbdata%plam(ii), fbdata%pphi(ii), & + & fbdata%plam(ij), fbdata%pphi(ij) ) + + IF ( zdist < thindists(it) ) THEN + + irej = irej + 1 + fbdata%ioqc(ij) = 4 + fbdata%ioqcf(2,ij) = fbdata%ioqcf(2,ij) + 32 + + ENDIF + ENDDO + + ENDDO master_loop + + WRITE(*,*)'For type = ',TRIM(thintypes(it)) + WRITE(*,*)'Observations considered = ',iobs + WRITE(*,*)'Observations rejected = ',irej + + ENDDO + + + + END SUBROUTINE fb_thin + +#include "distance.h90" + +END PROGRAM fbthin diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/greg2jul.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/greg2jul.h90 new file mode 120000 index 0000000000000000000000000000000000000000..20c46d53bd962292b1895b4c8e79607784a642f9 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/greg2jul.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/greg2jul.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis.h90 new file mode 120000 index 0000000000000000000000000000000000000000..f014a870c1741912d3eccc3a7c5032ab63cefd94 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/grt_cir_dis.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis_saa.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis_saa.h90 new file mode 120000 index 0000000000000000000000000000000000000000..c7137a9fc6924d2c5203be1a6aedfea3d065d7b2 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/grt_cir_dis_saa.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/grt_cir_dis_saa.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/in_out_manager.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/in_out_manager.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ca5c87522eacac6e3a411cb9356519234f9eb015 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/in_out_manager.F90 @@ -0,0 +1,131 @@ +MODULE in_out_manager + !!====================================================================== + !! *** MODULE in_out_manager *** + !! Ocean physics: vertical mixing coefficient compute from the tke + !! turbulent closure parameterization + !!===================================================================== + !! 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 lib_print ! formated print library +! USE nc4interface ! NetCDF4 interface + + IMPLICIT NONE + PUBLIC + + !!---------------------------------------------------------------------- + !! namrun namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(lc) :: cn_exp = "exp0" !: experiment name used for output filename + CHARACTER(lc) :: cn_ocerst_in = "restart" !: suffix of ocean restart name (input) + CHARACTER(lc) :: cn_ocerst_out = "restart" !: suffix of ocean restart name (output) + LOGICAL :: ln_rstart = .FALSE. !: start from (F) rest or (T) a restart file + INTEGER :: nn_no = 0 !: job number + INTEGER :: nn_rstctl = 0 !: 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 = 1 !: index of the first time step + INTEGER :: nn_itend = 10 !: index of the last time step + INTEGER :: nn_date0 = 961115 !: initial calendar date aammjj + INTEGER :: nn_leapy = 0 !: Leap year calendar flag (0/1 or 30) + INTEGER :: nn_istate = 0 !: initial state output flag (0/1) + INTEGER :: nn_write = 10 !: model standard output frequency + INTEGER :: nn_stock = 10 !: restart file frequency + LOGICAL :: ln_mskland = .FALSE. !: mask land points in NetCDF outputs (costly: + ~15%) + LOGICAL :: ln_clobber = .FALSE. !: clobber (overwrite) an existing file + INTEGER :: nn_chunksz = 0 !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) +#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 = 1 !: number of chunks required in the i-dimension + INTEGER :: nn_nchunks_j = 1 !: number of chunks required in the j-dimension + INTEGER :: nn_nchunks_k = 1 !: number of chunks required in the k-dimension + INTEGER :: nn_nchunks_t = 1 !: number of chunks required in the t-dimension + LOGICAL :: ln_nc4zip = .TRUE. !: 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 :: no !: job number + 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) + INTEGER :: nwrite !: model standard output frequency + INTEGER :: nstock !: restart file frequency + + !!---------------------------------------------------------------------- + !! 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 + + !!---------------------------------------------------------------------- + !! output monitoring + !!---------------------------------------------------------------------- + LOGICAL :: ln_ctl = .FALSE. !: run control for debugging + INTEGER :: nn_print = 0 !: level of print (0 no print) + INTEGER :: nn_ictls = 0 !: Start i indice for the SUM control + INTEGER :: nn_ictle = 0 !: End i indice for the SUM control + INTEGER :: nn_jctls = 0 !: Start j indice for the SUM control + INTEGER :: nn_jctle = 0 !: End j indice for the SUM control + INTEGER :: nn_isplt = 1 !: number of processors following i + INTEGER :: nn_jsplt = 1 !: number of processors following j + INTEGER :: nn_bench = 0 !: benchmark parameter (0/1) + INTEGER :: nn_bit_cmp = 0 !: bit reproducibility (0/1) + + ! + INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt, nbench !: OLD namelist names + + INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors + + !!---------------------------------------------------------------------- + !! logical units + !!---------------------------------------------------------------------- + INTEGER :: numstp = -1 !: logical unit for time step + INTEGER :: numout = 6 !: logical unit for output print + INTEGER :: numnam = -1 !: logical unit for namelist + INTEGER :: numnam_ice = -1 !: logical unit for ice namelist + INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) + INTEGER :: numsol = -1 !: logical unit for solver statistics + + !!---------------------------------------------------------------------- + !! Run control + !!---------------------------------------------------------------------- + INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) + 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 + CHARACTER(lc) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: + CHARACTER(lc) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: + LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only + LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: in_out_manager.F90 2715 2011-03-30 15:58:35Z rblod $ + !! Software governed by the CeCILL licence (./LICENSE) + !!===================================================================== +END MODULE in_out_manager diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/index_sort.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/index_sort.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f8a585d2a8b62fb893c7067b6857c5a326b52726 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/index_sort.F90 @@ -0,0 +1,361 @@ +MODULE index_sort + +CONTAINS + + LOGICAL FUNCTION lessn(a,b,n) + !!---------------------------------------------------------------------- + !! *** ROUTINE lessn *** + !! + !! ** Purpose : Compare two array and return true if the first + !! element of array "a" different from the corresponding + !! array "b" element is less than the this element + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + USE toolspar_kind + IMPLICIT NONE + INTEGER :: n + REAL(KIND=dp), DIMENSION(n) :: a,b + INTEGER :: i,j + + DO i=1,n + IF (a(i)/=b(i)) THEN + IF (a(i)<b(i)) THEN + lessn=.TRUE. + ELSE + lessn=.FALSE. + ENDIF + EXIT + ENDIF + ENDDO + + END FUNCTION lessn + + SUBROUTINE index_sort_dp_n(pval, n, kindx, kvals) + USE toolspar_kind + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for a + !! double precision array 2D + !! + !! ** Method : Heapsort with call to lessn for comparision + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code based on index_sort_dp + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: & + & n ! Number of keys + INTEGER, INTENT(IN) :: & + & kvals ! Number of values + REAL(KIND=dp),DIMENSION(n,kvals),INTENT(IN) :: & + & pval ! Array to be sorted + INTEGER,DIMENSION(kvals),INTENT(INOUT) :: & + & kindx ! Indicies for ordering + !! * Local variables + INTEGER :: ji, jj, jt, jn, jparent, jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + IF (kvals > 1) THEN + + 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 ( lessn(pval(:,kindx(jchild)),pval(:,kindx(jchild+1)),n) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( lessn(pval(:,jt),pval(:,kindx(jchild)),n) ) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + ENDDO inner_loop + + kindx(jparent) = jt + + END DO main_loop + ENDIF + + END SUBROUTINE index_sort_dp_n + + SUBROUTINE index_sort_dp(pval, kindx, kvals) + USE toolspar_kind + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + !! * Arguments + REAL(KIND=dp),DIMENSION(*),INTENT(IN) :: & + & pval ! Array to be sorted + INTEGER,DIMENSION(*),INTENT(INOUT) :: & + & kindx ! Indicies for ordering + INTEGER, INTENT(IN) :: & + & kvals ! Number of values + + !! * Local variables + INTEGER :: ji, jj, jt, jn, jparent, jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + IF (kvals > 1) THEN + + 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 + ENDDO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + ENDIF + END SUBROUTINE index_sort_dp + + SUBROUTINE index_sort_int(kval, kindx, kvals) + USE toolspar_kind + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for an + !! integer array + !! + !! ** Method : Heapsort + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER,DIMENSION(*),INTENT(IN) :: & + & kval ! Array to be sorted + INTEGER,DIMENSION(*),INTENT(INOUT) :: & + & kindx ! Indicies for ordering + INTEGER, INTENT(IN) :: & + & kvals ! Number of values + + !! * Local variables + INTEGER :: ji, jj, jt, jn, jparent, jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + IF (kvals > 1 ) THEN + + 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 ( kval(kindx(jchild)) < kval(kindx(jchild+1)) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( kval(jt) < kval(kindx(jchild))) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + ENDDO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + ENDIF + + END SUBROUTINE index_sort_int + + SUBROUTINE index_sort_string(cdval, kindx, kvals) + USE toolspar_kind + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for an + !! integer array + !! + !! ** Method : Heapsort + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(len=*),DIMENSION(*),INTENT(IN) :: & + & cdval ! Array to be sorted + INTEGER,DIMENSION(*),INTENT(INOUT) :: & + & kindx ! Indicies for ordering + INTEGER, INTENT(IN) :: & + & kvals ! Number of values + + !! * Local variables + INTEGER :: ji, jj, jt, jn, jparent, jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + IF (kvals > 1 ) THEN + + 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 ( cdval(kindx(jchild)) < cdval(kindx(jchild+1)) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( cdval(jt) < cdval(kindx(jchild))) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + ENDDO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + ENDIF + + END SUBROUTINE index_sort_string + +END MODULE index_sort diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/ioncdf.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/ioncdf.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e7f2cfe663fcce1d16b7b53c15db802b5b280eb0 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/ioncdf.F90 @@ -0,0 +1,4315 @@ +#define __MYFILE__ 'ioncdf.F90' +MODULE ioncdf + !!====================================================================== + !! *** MODULE ioncdf *** + !! Input/Output: manage netcdf inputs/outputs + !!===================================================================== + + !!---------------------------------------------------------------------- + !! ioncdf : manage netcdf inputs/outputs + !! put_map : write a 2d/3d map + !! put_scalar : write a scalar + !! test_var : test if variable exists + !! get_nb_dim : get dimension number of a variable + !! get_dim_val : get dimensions values of a variable + !! get_var : read a 1d/2d/3d/4d array + !! put_coord : write coordinates + !! create_map : create map netcdf file + !! put_att : write CF attributes + !! get_var_info : get CF attributes + !! Original : Nicolas Daget + !! Modified : MAB (nf90) + !!--------------------------------------------------------------------- + !! * Modules used + USE toolspar_kind + USE netcdf + USE nctools + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC :: put_coord, put_map, get_var, test_var, put_scalar, get_nb_dim, & + get_dim_val, get_scalar + + !! * Substitutions + + !! * Interface + INTERFACE put_coord + MODULE PROCEDURE put_coord_r, put_coord_d + END INTERFACE + + INTERFACE put_map + MODULE PROCEDURE put_map_2d_r, put_map_3d_r, put_map_2d_d, put_map_3d_d + END INTERFACE + + INTERFACE put_scalar + MODULE PROCEDURE put_scalar_i, put_scalar_r, put_scalar_d + END INTERFACE + + INTERFACE get_var + MODULE PROCEDURE get_var_1d_r, get_var_2d_r, get_var_3d_r, get_var_4d_r, & + get_var_1d_d, get_var_2d_d, get_var_3d_d, get_var_4d_d, & + get_var_1d_i, get_var_2d_i, get_var_3d_i, get_var_4d_i + END INTERFACE + + INTERFACE get_scalar + MODULE PROCEDURE get_scalar_i, get_scalar_r, get_scalar_d + END INTERFACE + +CONTAINS + + SUBROUTINE test_var ( cd_filename, cd_var, k_test ) + !!---------------------------------------------------------------------- + !! *** ROUTINE test_var *** + !! + !! ** Purpose : test if cd_var exists + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, INTENT(out) :: & + k_test ! test if variable exists + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id ! file and variable identifier + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ),& + & __LINE__,__MYFILE__) + k_test = nf90_inq_varid( i_file_id, cd_var, i_var_id ) + CALL nchdlerr( nf90_close( i_file_id ),& + & __LINE__,__MYFILE__) + + IF ( k_test .EQ. nf90_noerr ) THEN + k_test = 1 + ELSE + k_test = 0 + ENDIF + + END SUBROUTINE test_var + SUBROUTINE get_nb_dim ( cd_filename, cd_var, k_nb_dim ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_nb_dim *** + !! + !! ** Purpose : Get dimension number of variable + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get dimension number of variables + !! + !! Reference : + !! + !! History : + !! 06-06 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, INTENT(out) :: & + k_nb_dim ! c$dimension number of variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id ! file and variable identifier + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_variable( i_file_id, i_var_id, ndims=k_nb_dim ),& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_close( i_file_id ),& + & __LINE__,__MYFILE__) + END SUBROUTINE get_nb_dim + + SUBROUTINE get_dim_val ( cd_filename, cd_var, k_dim ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_dim_val *** + !! + !! ** Purpose : Get dimensions values of a variable + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get dimensions values of a variable + !! + !! Reference : + !! + !! History : + !! 06-06 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, DIMENSION(:), INTENT(out) :: & + k_dim ! dimensions values of a variable + + !! * local declarations + INTEGER, DIMENSION(1) :: i_nbdim ! dimensions of the variable + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + ii ! counter + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_variable( i_file_id, i_var_id, dimids=k_dim ) ,& + & __LINE__,__MYFILE__) + i_nbdim = SHAPE( k_dim ) + DO ii = 1, i_nbdim(1) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, k_dim(ii), len=k_dim(ii) ),__LINE__,__MYFILE__ ) + ENDDO + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE get_dim_val + + !!====================================================================== + + SUBROUTINE get_scalar_i ( cd_filename, cd_var, k_var ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_scalar_i *** + !! + !! ** Purpose : read integer scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-09 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), INTENT(in) :: & + cd_var ! variable name + INTEGER, INTENT(out) :: & + k_var ! variable to read in netcdf file + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type ! external data type for this variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr(nf90_open( cd_filename, nf90_nowrite, i_file_id ),& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr(nf90_inquire_variable( i_file_id, i_var_id,xtype=i_type,ndims=i_ndims),& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_INT : 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, k_var ),& + & __LINE__,__MYFILE__ ) + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE get_scalar_i + + SUBROUTINE get_scalar_r ( cd_filename, cd_var, p_var ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_scalar_r *** + !! + !! ** Purpose : read real scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-09 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), INTENT(in) :: & + cd_var ! variable name + REAL(KIND=sp), INTENT(out) :: & + p_var ! variable to read in netcdf file + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type ! external data type for this variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type,ndims=i_ndims ),& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 5 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_FLOAT : 5' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, p_var ) ,__LINE__,__MYFILE__ ) + + CALL nchdlerr( nf90_close( i_file_id ),__LINE__,__MYFILE__ ) + + END SUBROUTINE get_scalar_r + + SUBROUTINE get_scalar_d ( cd_filename, cd_var, dd_var ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_scalar_d *** + !! + !! ** Purpose : read double scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-09 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), INTENT(in) :: & + cd_var ! variable name + REAL(KIND=dp), INTENT(out) :: & + dd_var ! variable to read in netcdf file + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type ! external data type for this variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type,ndims=i_ndims),__LINE__,__MYFILE__ ) + IF ( i_type .NE. 6 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_DOUBLE : 6' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, dd_var ),__LINE__,__MYFILE__ ) + + CALL nchdlerr( nf90_close( i_file_id ),__LINE__,__MYFILE__ ) + + END SUBROUTINE get_scalar_d + + !!====================================================================== + + SUBROUTINE put_scalar_i ( cd_filename, k_var, cd_var, cd_longname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_scalar_i *** + !! + !! ** Purpose : write an integer scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename, & ! filename + cd_var ! variable name + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_longname ! variable longname + INTEGER, INTENT(in) :: & + k_var ! variable to write in netcdf file + + !! * local declarations + LOGICAL :: llexist ! test + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_id, & ! dimension identifier + i_var_exist, i_dim_exist ! tests + INTEGER, DIMENSION(1) :: & + i_dim ! netcdf information + !!---------------------------------------------------------------------- + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + CALL nchdlerr( nf90_create( cd_filename, nf90_clobber, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim_exist = nf90_inq_dimid( i_file_id, 'scalar', i_dim_id ) + IF ( i_dim_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'scalar', 1, i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim(1) = i_dim_id + + ! + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cd_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cd_var, nf90_int, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', TRIM(cd_var) ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(cd_longname) ) THEN + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', TRIM(cd_longname) ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, k_var ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_scalar_i + + SUBROUTINE put_scalar_r ( cd_filename, p_var, cd_var, cd_longname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_scalar_r *** + !! + !! ** Purpose : write an real scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename, & ! filename + cd_var ! variable name + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_longname ! variable longname + REAL(KIND=sp), INTENT(in) :: & + p_var ! variable to write in netcdf file + + !! * local declarations + LOGICAL :: llexist ! test + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_id, & ! dimension identifier + i_var_exist, i_dim_exist ! tests + INTEGER, DIMENSION(1) :: & + i_dim ! netcdf information + !!---------------------------------------------------------------------- + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + CALL nchdlerr( nf90_create( cd_filename, nf90_clobber, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim_exist = nf90_inq_dimid( i_file_id, 'scalar', i_dim_id ) + IF ( i_dim_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'scalar', 1, i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim(1) = i_dim_id + + ! + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cd_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cd_var, nf90_real, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', TRIM(cd_var) ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(cd_longname) ) THEN + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', TRIM(cd_longname) ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_var ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_scalar_r + + SUBROUTINE put_scalar_d ( cd_filename, dd_var, cd_var, cd_longname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_scalar_d *** + !! + !! ** Purpose : write an integer scalar in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename, & ! filename + cd_var ! variable name + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_longname ! variable longname + REAL(KIND=dp), INTENT(in) :: & + dd_var ! variable to write in netcdf file + + !! * local declarations + LOGICAL :: llexist ! test + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_id, & ! dimension identifier + i_var_exist, i_dim_exist ! tests + INTEGER, DIMENSION(1) :: & + i_dim ! netcdf information + !!---------------------------------------------------------------------- + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + CALL nchdlerr( nf90_create( cd_filename, nf90_clobber, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim_exist = nf90_inq_dimid( i_file_id, 'scalar', i_dim_id ) + IF ( i_dim_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'double', 1, i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + i_dim(1) = i_dim_id + + ! + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cd_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cd_var, nf90_double, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', TRIM(cd_var) ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(cd_longname) ) THEN + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', TRIM(cd_longname) ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_var ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_scalar_d + + !!====================================================================== + + SUBROUTINE put_map_2d_r ( cd_filename, p_var, p_missing, cd_var, k_code, k_time, reftime, leadtime, time_bnd, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_map_2d_r *** + !! + !! ** Purpose : write 2d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, OPTIONAL, INTENT(in) :: & + k_code, & ! CF code + k_time, & ! time of the variable + leadtime ! leadtime of the variable + INTEGER, DIMENSION(:), OPTIONAL, INTENT(in) :: & + time_bnd ! time_bnd + REAL(KIND=sp), OPTIONAL, INTENT(in) :: & + p_missing, & ! missing value of the variable + reftime ! reftime of the variable + REAL(KIND=sp), DIMENSION(:,:), INTENT(in) :: & + p_var ! variable to write in netcdf file + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + CHARACTER(len=80) :: cl_var ! new variable name + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_x_id, i_dim_y_id, i_time_id, & ! dimension identifier + i_reftime_id, i_leadtime_id, & ! dimension identifier + i_time_bnd_id, i_dim_id, & ! dimension identifier + i_var_exist, i_pos, ii ! test and temporary variable + INTEGER, DIMENSION(1) :: i_time_bnd ! dimensions of the variable + INTEGER, DIMENSION(2) :: i_dimxy, i_len ! dimensions of the variable + INTEGER, DIMENSION(3) :: & + i_tab_start, i_tab_count, i_dim ! netcdf information + INTEGER, DIMENSION(:), ALLOCATABLE :: & + i_time ! time + REAL :: & + z_min, z_max, z_min_old, z_max_old ! Minima and maxima of variable + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( p_var) + i_tab_start(1) = 1 + i_tab_count(1) = i_dimxy(1) + i_tab_start(2) = 1 + i_tab_count(2) = i_dimxy(2) + i_tab_count(3) = 1 + + IF ( PRESENT(p_missing) ) THEN + z_min = MINVAL(p_var, mask = p_var .NE. p_missing ) + z_max = MAXVAL(p_var, mask = p_var .NE. p_missing ) + ELSE + z_min = MINVAL(p_var ) + z_max = MAXVAL(p_var ) + ENDIF + + ! Define the name of the variable + ! ------------------------------- + cl_var = "var" + IF ( PRESENT(cd_var) ) cl_var = cd_var + IF ( PRESENT(k_code) ) CALL get_var_info( k_code, cl_var ) + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + i_dim(3) = i_time_id + + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(1), len=i_len(1) ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + + IF ( (i_len(1) .NE. i_dimxy(1)) .OR. (i_len(2) .NE. i_dimxy(2)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cl_var + WRITE(*,*)'shape of array = ',i_dimxy + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cl_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cl_var, nf90_real, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_code) ) CALL put_att( i_file_id, i_var_id, k_code ) + IF ( PRESENT(p_missing) ) & + & CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', p_missing ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,& + & __LINE__,__MYFILE__) + i_var_exist = nf90_inq_varid( i_file_id, 'time', i_time_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'time', nf90_int, i_dim(3), i_time_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'reftime', nf90_real, i_dim(3), i_reftime_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'units', 'days since 1950-01-01 00:00:00' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'standard_name', 'forecast_reference_time' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'long_name', 'forecast reference time' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(leadtime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'leadtime', nf90_int, i_dim(3), i_leadtime_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'standard_name', 'forecast_period' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'long_name', & + & 'Time elapsed since the start of the forecast' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'bounds', 'time_bnd' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) + IF ( i_var_exist .NE. 0 ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_def_dim( i_file_id, 'time_bnd', i_time_bnd(1) , i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, 'time_bnd', nf90_int, (/i_dim_id, i_dim(3)/), i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_time_bnd_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + i_tab_start(3) = 1 + i_pos = 1 + ELSE + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', z_min_old ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', z_max_old ) ,& + & __LINE__,__MYFILE__) + z_min = MIN( z_min, z_min_old ) + z_max = MAX( z_max, z_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_time_id, len=i_pos ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + ALLOCATE( i_time(i_pos) ) + CALL nchdlerr( nf90_get_var( i_file_id, i_time_id, i_time ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_time) ) THEN + DO ii = 1, i_pos + IF ( k_time .EQ. i_time(ii) ) THEN + i_pos = ii - 1 + EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE( i_time ) + i_pos = i_pos + 1 + i_tab_start(3) = i_pos + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_var, & + & start=i_tab_start, count=i_tab_count ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_time) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/k_time/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/i_pos/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_reftime_id, (/reftime/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_leadtime_id, (/leadtime/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_bnd_id, time_bnd, & + start=(/1,i_tab_start(3)/), count=(/i_time_bnd(1),i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_map_2d_r + + SUBROUTINE put_map_2d_d ( cd_filename, dd_var, dd_missing, cd_var, k_code, k_time, reftime, leadtime, time_bnd, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_map_2d_d *** + !! + !! ** Purpose : write 2d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, OPTIONAL, INTENT(in) :: & + k_code, & ! CF code + k_time, & ! time of the variable + leadtime ! leadtime of the variable + INTEGER, DIMENSION(:), OPTIONAL, INTENT(in) :: & + time_bnd ! time_bnd + REAL(KIND=dp), OPTIONAL, INTENT(in) :: & + dd_missing, & ! missing value of the variable + reftime ! reftime of the variable + REAL(KIND=dp), DIMENSION(:,:), INTENT(in) :: & + dd_var ! variable to write in netcdf file + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + CHARACTER(len=80) :: cl_var ! new variable name + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_x_id, i_dim_y_id, i_time_id, & ! dimension identifier + i_reftime_id, i_leadtime_id, & ! dimension identifier + i_time_bnd_id, i_dim_id, & ! dimension identifier + i_var_exist, i_pos, ii ! test and temporary variable + INTEGER, DIMENSION(1) :: i_time_bnd ! dimensions of the variable + INTEGER, DIMENSION(2) :: i_dimxy, i_len ! dimensions of the variable + INTEGER, DIMENSION(3) :: & + i_tab_start, i_tab_count, i_dim ! netcdf information + INTEGER, DIMENSION(:), ALLOCATABLE :: & + i_time ! time + REAL(KIND=dp) :: & + dl_min, dl_max, dl_min_old, dl_max_old ! Minima and maxima of variable + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( dd_var) + i_tab_start(1) = 1 + i_tab_count(1) = i_dimxy(1) + i_tab_start(2) = 1 + i_tab_count(2) = i_dimxy(2) + i_tab_count(3) = 1 + + IF ( PRESENT(dd_missing) ) THEN + dl_min = MINVAL( dd_var, mask = dd_var .NE. dd_missing ) + dl_max = MAXVAL( dd_var, mask = dd_var .NE. dd_missing ) + ELSE + dl_min = MINVAL( dd_var ) + dl_max = MAXVAL( dd_var ) + ENDIF + + ! Define the name of the variable + ! ------------------------------- + cl_var = "var" + IF ( PRESENT(cd_var) ) cl_var = cd_var + IF ( PRESENT(k_code) ) CALL get_var_info( k_code, cl_var ) + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + i_dim(3) = i_time_id + + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + + IF ( (i_len(1) .NE. i_dimxy(1)) .OR. (i_len(2) .NE. i_dimxy(2)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cl_var + WRITE(*,*)'shape of array = ',i_dimxy + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cl_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cl_var, nf90_double, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_code) ) CALL put_att( i_file_id, i_var_id, k_code ) + IF ( PRESENT(dd_missing) ) & + & CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', dd_missing ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_max ) ,& + & __LINE__,__MYFILE__) + i_var_exist = nf90_inq_varid( i_file_id, 'time', i_time_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'time', nf90_int, i_dim(3), i_time_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'reftime', nf90_double, i_dim(3), i_reftime_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'units', 'days since 1950-01-01 00:00:00' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'standard_name', 'forecast_reference_time' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'long_name', 'forecast reference time' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(leadtime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'leadtime', nf90_int, i_dim(3), i_leadtime_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'standard_name', 'forecast_period' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'long_name', & + & 'Time elapsed since the start of the forecast' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'bounds', 'time_bnd' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) + IF ( i_var_exist .NE. 0 ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_def_dim( i_file_id, 'time_bnd', i_time_bnd(1) , i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, 'time_bnd', nf90_int, (/i_dim_id, i_dim(3)/), i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_time_bnd_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + i_tab_start(3) = 1 + i_pos = 1 + ELSE + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', dl_min_old ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', dl_max_old ) ,& + & __LINE__,__MYFILE__) + dl_min = MIN( dl_min, dl_min_old ) + dl_max = MAX( dl_max, dl_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_max ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_time_id, len=i_pos ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + ALLOCATE( i_time(i_pos) ) + CALL nchdlerr( nf90_get_var( i_file_id, i_time_id, i_time ) ,& + & __LINE__,__MYFILE__) + DO ii = 1, i_pos + IF ( k_time .EQ. i_time(ii) ) THEN + i_pos = ii - 1 + EXIT + ENDIF + ENDDO + DEALLOCATE( i_time ) + i_pos = i_pos + 1 + i_tab_start(3) = i_pos + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_var, & + & start=i_tab_start, count=i_tab_count ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_time) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/k_time/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/i_pos/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_reftime_id, (/reftime/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_leadtime_id, (/leadtime/), & + & start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_bnd_id, time_bnd, & + & start=(/1,i_tab_start(3)/), count=(/i_time_bnd(1),i_tab_count(3)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_map_2d_d + + SUBROUTINE put_map_3d_r ( cd_filename, p_var, p_missing, cd_var, k_code, k_time, reftime, leadtime, time_bnd, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_map_3d_r *** + !! + !! ** Purpose : write 3d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, OPTIONAL, INTENT(in) :: & + k_code, & ! CF code + k_time, & ! time of the variable + leadtime ! leadtime of the variable + INTEGER, DIMENSION(:), OPTIONAL, INTENT(in) :: & + time_bnd ! time_bnd + REAL(KIND=sp), OPTIONAL, INTENT(in) :: & + p_missing, & ! missing value of the variable + reftime ! reftime of the variable + REAL(KIND=sp), DIMENSION(:,:,:), INTENT(in) :: & + p_var ! variable to write in netcdf file + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + CHARACTER(len=80) :: cl_var ! new variable name + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_x_id, i_dim_y_id, & ! dimension identifiers + i_dim_z_id, i_time_id, & ! dimension identifiers + i_reftime_id, i_leadtime_id, & ! dimension identifier + i_time_bnd_id, i_dim_id, & ! dimension identifier + i_var_exist, i_pos, ii ! test and temporary variable + INTEGER, DIMENSION(1) :: i_time_bnd ! dimensions of the variable + INTEGER, DIMENSION(3) :: i_dimxy, i_len ! dimensions of the variable + INTEGER, DIMENSION(4) :: & + i_tab_start, i_tab_count, i_dim ! netcdf information + INTEGER, DIMENSION(:), ALLOCATABLE :: & + i_time ! time + REAL :: & + z_min, z_max, z_min_old, z_max_old ! Minima and maxima of variable + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( p_var) + i_tab_start(1) = 1 + i_tab_count(1) = i_dimxy(1) + i_tab_start(2) = 1 + i_tab_count(2) = i_dimxy(2) + i_tab_start(3) = 1 + i_tab_count(3) = i_dimxy(3) + i_tab_count(4) = 1 + + IF ( PRESENT(p_missing) ) THEN + z_min = MINVAL(p_var, mask = p_var .NE. p_missing ) + z_max = MAXVAL(p_var, mask = p_var .NE. p_missing ) + ELSE + z_min = MINVAL(p_var ) + z_max = MAXVAL(p_var ) + ENDIF + + ! Define the name of the variable + ! ------------------------------- + cl_var = "var" + IF ( PRESENT(cd_var) ) cl_var = cd_var + IF ( PRESENT(k_code) ) CALL get_var_info( k_code, cl_var ) + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'z', i_dim_z_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + i_dim(3) = i_dim_z_id + i_dim(4) = i_time_id + + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + + IF ( (i_len(1) .NE. i_dimxy(1)) .OR. (i_len(2) .NE. i_dimxy(2)) .OR. & + (i_len(3) .NE. i_dimxy(3)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cl_var + WRITE(*,*)'shape of array = ',i_dimxy + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cl_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cl_var, nf90_real, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_code) ) CALL put_att( i_file_id, i_var_id, k_code ) + IF ( PRESENT(p_missing) ) & + & CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', p_missing ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,& + & __LINE__,__MYFILE__) + i_var_exist = nf90_inq_varid( i_file_id, 'time', i_time_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'time', nf90_int, i_dim(4), i_time_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'reftime', nf90_real, i_dim(4), i_reftime_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'units', 'days since 1950-01-01 00:00:00' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'standard_name', 'forecast_reference_time' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'long_name', 'forecast reference time' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(leadtime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'leadtime', nf90_int, i_dim(4), i_leadtime_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'standard_name', 'forecast_period' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'long_name', & + & 'Time elapsed since the start of the forecast' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'bounds', 'time_bnd' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) + IF ( i_var_exist .NE. 0 ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_def_dim( i_file_id, 'time_bnd', i_time_bnd(1) , i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, 'time_bnd', nf90_int, (/i_dim_id, i_dim(4)/), i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_time_bnd_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + i_tab_start(4) = 1 + i_pos = 1 + ELSE + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', z_min_old ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', z_max_old ) ,& + & __LINE__,__MYFILE__) + z_min = MIN( z_min, z_min_old ) + z_max = MAX( z_max, z_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_time_id, len=i_pos ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + ALLOCATE( i_time(i_pos) ) + CALL nchdlerr( nf90_get_var( i_file_id, i_time_id, i_time ) ,& + & __LINE__,__MYFILE__) + DO ii = 1, i_pos + IF ( k_time .EQ. i_time(ii) ) THEN + i_pos = ii - 1 + EXIT + ENDIF + ENDDO + DEALLOCATE( i_time ) + i_pos = i_pos + 1 + i_tab_start(4) = i_pos + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_var, & + & start=i_tab_start, count=i_tab_count ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_time) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/k_time/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/i_pos/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_reftime_id, (/reftime/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_leadtime_id, (/leadtime/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_bnd_id, time_bnd, & + start=(/1,i_tab_start(4)/), count=(/i_time_bnd(1),i_tab_count(4)/) ),__LINE__,__MYFILE__ ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_map_3d_r + + SUBROUTINE put_map_3d_d ( cd_filename, dd_var, dd_missing, cd_var, k_code, k_time, reftime, leadtime, time_bnd, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_map_3d_d *** + !! + !! ** Purpose : write 3d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, OPTIONAL, INTENT(in) :: & + k_code, & ! CF code + k_time, & ! time of the variable + leadtime ! leadtime of the variable + INTEGER, DIMENSION(:), OPTIONAL, INTENT(in) :: & + time_bnd ! time_bnd + REAL(KIND=dp), OPTIONAL, INTENT(in) :: & + dd_missing, & ! missing value of the variable + reftime ! reftime of the variable + REAL(KIND=dp), DIMENSION(:,:,:), INTENT(in) :: & + dd_var ! variable to write in netcdf file + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + CHARACTER(len=80) :: cl_var ! new variable name + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_dim_x_id, i_dim_y_id, & ! dimension identifiers + i_dim_z_id, i_time_id, & ! dimension identifiers + i_reftime_id, i_leadtime_id, & ! dimension identifier + i_time_bnd_id, i_dim_id, & ! dimension identifier + i_var_exist, i_pos, ii ! test and temporary variable + INTEGER, DIMENSION(1) :: i_time_bnd ! dimensions of the variable + INTEGER, DIMENSION(3) :: i_dimxy, i_len ! dimensions of the variable + INTEGER, DIMENSION(4) :: & + i_tab_start, i_tab_count, i_dim ! netcdf information + INTEGER, DIMENSION(:), ALLOCATABLE :: & + i_time ! time + REAL(KIND=dp) :: & + dl_min, dl_max, dl_min_old, dl_max_old ! Minima and maxima of variable + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( dd_var) + i_tab_start(1) = 1 + i_tab_count(1) = i_dimxy(1) + i_tab_start(2) = 1 + i_tab_count(2) = i_dimxy(2) + i_tab_start(3) = 1 + i_tab_count(3) = i_dimxy(3) + i_tab_count(4) = 1 + + IF ( PRESENT(dd_missing) ) THEN + dl_min = MINVAL(dd_var, mask = dd_var .NE. dd_missing ) + dl_max = MAXVAL(dd_var, mask = dd_var .NE. dd_missing ) + ELSE + dl_min = MINVAL(dd_var ) + dl_max = MAXVAL(dd_var ) + ENDIF + + ! Define the name of the variable + ! ------------------------------- + cl_var = "var" + IF ( PRESENT(cd_var) ) cl_var = cd_var + IF ( PRESENT(k_code) ) CALL get_var_info( k_code, cl_var ) + + ! + ! Open or create file + ! ------------------- + INQUIRE( FILE=cd_filename, EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'z', i_dim_z_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + i_dim(3) = i_dim_z_id + i_dim(4) = i_time_id + + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + + IF ( (i_len(1) .NE. i_dimxy(1)) .OR. (i_len(2) .NE. i_dimxy(2)) .OR. & + (i_len(3) .NE. i_dimxy(3)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cl_var + WRITE(*,*)'shape of array = ',i_dimxy + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + ! Define variable or find it + ! -------------------------- + i_var_exist = nf90_inq_varid( i_file_id, cl_var, i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cl_var, nf90_double, i_dim, i_var_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_code) ) CALL put_att( i_file_id, i_var_id, k_code ) + IF ( PRESENT(dd_missing) ) & + & CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', dd_missing ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_max ) ,& + & __LINE__,__MYFILE__) + i_var_exist = nf90_inq_varid( i_file_id, 'time', i_time_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'time', nf90_int, i_dim(4), i_time_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'reftime', nf90_double, i_dim(4), i_reftime_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'units', 'days since 1950-01-01 00:00:00' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'standard_name', 'forecast_reference_time' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_reftime_id, 'long_name', 'forecast reference time' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(leadtime) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, 'leadtime', nf90_int, i_dim(4), i_leadtime_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'standard_name', 'forecast_period' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'long_name', & + & 'Time elapsed since the start of the forecast' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_leadtime_id, 'bounds', 'time_bnd' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) + IF ( i_var_exist .NE. 0 ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_def_dim( i_file_id, 'time_bnd', i_time_bnd(1) , i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, 'time_bnd', nf90_int, (/i_dim_id, i_dim(4)/), i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_time_bnd_id, 'units', 'days' ) ,& + & __LINE__,__MYFILE__) + ENDIF + ENDIF + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + i_tab_start(4) = 1 + i_pos = 1 + ELSE + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', dl_min_old ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', dl_max_old ) ,& + & __LINE__,__MYFILE__) + dl_min = MIN( dl_min, dl_min_old ) + dl_max = MAX( dl_max, dl_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_min ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_max ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_time_id, len=i_pos ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'reftime', i_reftime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_inq_varid( i_file_id, 'leadtime', i_leadtime_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + i_time_bnd=SHAPE(time_bnd) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time_bnd', i_time_bnd_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + ALLOCATE( i_time(i_pos) ) + CALL nchdlerr( nf90_get_var( i_file_id, i_time_id, i_time ) ,& + & __LINE__,__MYFILE__) + DO ii = 1, i_pos + IF ( k_time .EQ. i_time(ii) ) THEN + i_pos = ii - 1 + EXIT + ENDIF + ENDDO + DEALLOCATE( i_time ) + i_pos = i_pos + 1 + i_tab_start(4) = i_pos + ENDIF + + ! Put variable(s) + ! -------------- + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_var, & + & start=i_tab_start, count=i_tab_count ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_time) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/k_time/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ELSE + CALL nchdlerr( nf90_put_var( i_file_id, i_time_id, (/i_pos/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(reftime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_reftime_id, (/reftime/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(leadtime) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_leadtime_id, (/leadtime/), & + & start=(/i_tab_start(4)/), count=(/i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( PRESENT(time_bnd) ) THEN + CALL nchdlerr( nf90_put_var( i_file_id, i_time_bnd_id, time_bnd, & + & start=(/1,i_tab_start(4)/), count=(/i_time_bnd(1),i_tab_count(4)/) ) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_map_3d_d + + !!====================================================================== + + SUBROUTINE get_var_1d_i ( cd_filename, cd_var, k_var, k_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_1d_i *** + !! + !! ** Purpose : read 1d map of integers in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, DIMENSION(:), INTENT(out) :: & + k_var ! variable to read in netcdf file + INTEGER, OPTIONAL, INTENT(out) :: & + k_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(1) :: i_dimid, i_len, i_shape ! dimensions of the variable + INTEGER :: i_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_INT : 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(k_var) + IF ( i_len(1) .NE. i_shape(1) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(k_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, k_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', i_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', i_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + i_missing2 = MAXVAL(k_var) + ENDIF + + IF ( PRESENT(k_missing) ) THEN + k_missing = i_missing2 + ELSE + WHERE(k_var .EQ. i_missing2) k_var = 0.0 + WHERE((k_var .GT. 0.) .EQV. (k_var .LE. 0.)) k_var = 0.0 + ENDIF + + END SUBROUTINE get_var_1d_i + + SUBROUTINE get_var_2d_i ( cd_filename, cd_var, k_var, k_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_2d_i *** + !! + !! ** Purpose : read 2d map of integers in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, DIMENSION(:,:), INTENT(out) :: & + k_var ! variable to read in netcdf file + INTEGER, OPTIONAL, INTENT(out) :: & + k_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(2) :: i_dimid, i_len, i_shape ! dimensions of the variable + INTEGER :: i_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_INT : 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 2 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 2' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(k_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(k_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, k_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', i_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', i_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + i_missing2 = MAXVAL(k_var) + ENDIF + + IF ( PRESENT(k_missing) ) THEN + k_missing = i_missing2 + ELSE + WHERE(k_var .EQ. i_missing2) k_var = 0.0 + WHERE((k_var .GT. 0.) .EQV. (k_var .LE. 0.)) k_var = 0.0 + ENDIF + + END SUBROUTINE get_var_2d_i + + SUBROUTINE get_var_3d_i ( cd_filename, cd_var, k_var, k_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_3d_i *** + !! + !! ** Purpose : read 3d map of integers in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, DIMENSION(:,:,:), INTENT(out) :: & + k_var ! variable to read in netcdf file + INTEGER, OPTIONAL, INTENT(out) :: & + k_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(3) :: i_dimid, i_len, i_shape ! dimensions of the variable + INTEGER :: i_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_INT : 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 3 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 3' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(k_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(k_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, k_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', i_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', i_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + i_missing2 = MAXVAL(k_var) + ENDIF + + IF ( PRESENT(k_missing) ) THEN + k_missing = i_missing2 + ELSE + WHERE(k_var .EQ. i_missing2) k_var = 0.0 + WHERE((k_var .GT. 0.) .EQV. (k_var .LE. 0.)) k_var = 0.0 + ENDIF + + END SUBROUTINE get_var_3d_i + + SUBROUTINE get_var_4d_i ( cd_filename, cd_var, k_var, k_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_4d_i *** + !! + !! ** Purpose : read 4d map of integers in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + INTEGER, DIMENSION(:,:,:,:), INTENT(out) :: & + k_var ! variable to read in netcdf file + INTEGER, OPTIONAL, INTENT(out) :: & + k_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(4) :: i_dimid, i_len, i_shape ! dimensions of the variable + INTEGER :: i_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_INT : 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(4), len=i_len(4) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(k_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) .OR. (i_len(4) .NE. i_shape(4)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(k_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, k_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', i_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', i_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + i_missing2 = MAXVAL(k_var) + ENDIF + + IF ( PRESENT(k_missing) ) THEN + k_missing = i_missing2 + ELSE + WHERE(k_var .EQ. i_missing2) k_var = 0.0 + WHERE((k_var .GT. 0.) .EQV. (k_var .LE. 0.)) k_var = 0.0 + ENDIF + + END SUBROUTINE get_var_4d_i + + SUBROUTINE get_var_1d_r ( cd_filename, cd_var, p_var, p_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_1d_r *** + !! + !! ** Purpose : read 1d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=sp), DIMENSION(:), INTENT(out) :: & + p_var ! variable to read in netcdf file + REAL(KIND=sp), OPTIONAL, INTENT(out) :: & + p_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(1) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL :: z_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 5 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_FLOAT : 5' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(p_var) + IF ( i_len(1) .NE. i_shape(1) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(p_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, p_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', z_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', z_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + z_missing2 = MAXVAL(p_var) + ENDIF + + IF ( PRESENT(p_missing) ) THEN + p_missing = z_missing2 + ELSE + WHERE(p_var .EQ. z_missing2) p_var = 0.0 + WHERE((p_var .GT. 0.) .EQV. (p_var .LE. 0.)) p_var = 0.0 + ENDIF + + END SUBROUTINE get_var_1d_r + + SUBROUTINE get_var_2d_r ( cd_filename, cd_var, p_var, p_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_2d_r *** + !! + !! ** Purpose : read 2d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=sp), DIMENSION(:,:), INTENT(out) :: & + p_var ! variable to read in netcdf file + REAL(KIND=sp), OPTIONAL, INTENT(out) :: & + p_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(2) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL :: z_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 5 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_FLOAT : 5' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 2 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 2' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(p_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(p_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, p_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', z_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', z_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + z_missing2 = MAXVAL(p_var) + ENDIF + + IF ( PRESENT(p_missing) ) THEN + p_missing = z_missing2 + ELSE + WHERE(p_var .EQ. z_missing2) p_var = 0.0 + WHERE((p_var .GT. 0.) .EQV. (p_var .LE. 0.)) p_var = 0.0 + ENDIF + + END SUBROUTINE get_var_2d_r + + SUBROUTINE get_var_3d_r ( cd_filename, cd_var, p_var, p_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_3d_r *** + !! + !! ** Purpose : read 3d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=sp), DIMENSION(:,:,:), INTENT(out) :: & + p_var ! variable to read in netcdf file + REAL(KIND=sp), OPTIONAL, INTENT(out) :: & + p_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(3) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL :: z_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 5 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_FLOAT : 5' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 3 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 3' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(p_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(p_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, p_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', z_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', z_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + z_missing2 = MAXVAL(p_var) + ENDIF + + IF ( PRESENT(p_missing) ) THEN + p_missing = z_missing2 + ELSE + WHERE(p_var .EQ. z_missing2) p_var = 0.0 + WHERE((p_var .GT. 0.) .EQV. (p_var .LE. 0.)) p_var = 0.0 + ENDIF + + END SUBROUTINE get_var_3d_r + + SUBROUTINE get_var_4d_r ( cd_filename, cd_var, p_var, p_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_4d_r *** + !! + !! ** Purpose : read 4d map of reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=sp), DIMENSION(:,:,:,:), INTENT(out) :: & + p_var ! variable to read in netcdf file + REAL(KIND=sp), OPTIONAL, INTENT(out) :: & + p_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(4) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL :: z_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. 5 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF_FLOAT : 5' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(4), len=i_len(4) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(p_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) .OR. (i_len(4) .NE. i_shape(4)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(p_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, p_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', z_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', z_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + z_missing2 = MAXVAL(p_var) + ENDIF + + IF ( PRESENT(p_missing) ) THEN + p_missing = z_missing2 + ELSE + WHERE(p_var .EQ. z_missing2) p_var = 0.0 + WHERE((p_var .GT. 0.) .EQV. (p_var .LE. 0.)) p_var = 0.0 + ENDIF + + END SUBROUTINE get_var_4d_r + + SUBROUTINE get_var_1d_d ( cd_filename, cd_var, dd_var, dd_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_1d_d *** + !! + !! ** Purpose : read 1d map of real(kind=dp) reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=dp), DIMENSION(:), INTENT(out) :: & + dd_var ! variable to read in netcdf file + REAL(KIND=dp), OPTIONAL, INTENT(out) :: & + dd_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(1) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL(KIND=dp) :: dl_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. NF90_DOUBLE ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF90_DOUBLE : 6' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 1 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 1' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(dd_var) + IF ( i_len(1) .NE. i_shape(1) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(dd_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, dd_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', dl_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', dl_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + dl_missing2 = MAXVAL(dd_var) + ENDIF + + IF ( PRESENT(dd_missing) ) THEN + dd_missing = dl_missing2 + ELSE + WHERE(dd_var .EQ. dl_missing2) dd_var = 0.0 + WHERE((dd_var .GT. 0.) .EQV. (dd_var .LE. 0.)) dd_var = 0.0 + ENDIF + + END SUBROUTINE get_var_1d_d + + SUBROUTINE get_var_2d_d ( cd_filename, cd_var, dd_var, dd_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_2d_d *** + !! + !! ** Purpose : read 2d map of real(kind=dp) reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=dp), DIMENSION(:,:), INTENT(out) :: & + dd_var ! variable to read in netcdf file + REAL(KIND=dp), OPTIONAL, INTENT(out) :: & + dd_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(2) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL(KIND=dp) :: dl_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. NF90_DOUBLE ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF90_DOUBLE : 6' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 2 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 2' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(dd_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(dd_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, dd_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', dl_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', dl_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + dl_missing2 = MAXVAL(dd_var) + ENDIF + + IF ( PRESENT(dd_missing) ) THEN + dd_missing = dl_missing2 + ELSE + WHERE(dd_var .EQ. dl_missing2) dd_var = 0.0 + WHERE((dd_var .GT. 0.) .EQV. (dd_var .LE. 0.)) dd_var = 0.0 + ENDIF + + END SUBROUTINE get_var_2d_d + + SUBROUTINE get_var_3d_d ( cd_filename, cd_var, dd_var, dd_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_3d_d *** + !! + !! ** Purpose : read 3d map of real(kind=dp) reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=dp), DIMENSION(:,:,:), INTENT(out) :: & + dd_var ! variable to read in netcdf file + REAL(KIND=dp), OPTIONAL, INTENT(out) :: & + dd_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(3) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL(KIND=dp) :: dl_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. NF90_DOUBLE ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF90_DOUBLE : 6' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 3 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 3' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(dd_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(dd_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, dd_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', dl_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', dl_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + dl_missing2 = MAXVAL(dd_var) + ENDIF + + IF ( PRESENT(dd_missing) ) THEN + dd_missing = dl_missing2 + ELSE + WHERE(dd_var .EQ. dl_missing2) dd_var = 0.0 + WHERE((dd_var .GT. 0.) .EQV. (dd_var .LE. 0.)) dd_var = 0.0 + ENDIF + + END SUBROUTINE get_var_3d_d + + SUBROUTINE get_var_4d_d ( cd_filename, cd_var, dd_var, dd_missing ) + !!---------------------------------------------------------------------- + !! *** ROUTINE get_var_4d_d *** + !! + !! ** Purpose : read 4d map of real(kind=dp) reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - read variable + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + CHARACTER(len=80), OPTIONAL, INTENT(in) :: & + cd_var ! variable name + REAL(KIND=dp), DIMENSION(:,:,:,:), INTENT(out) :: & + dd_var ! variable to read in netcdf file + REAL(KIND=dp), OPTIONAL, INTENT(out) :: & + dd_missing ! missing value of the variable + + !! * local declarations + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifier + i_ndims, & ! Number of dimensions for this variable + i_type, & ! external data type for this variable + i_exist ! test + INTEGER, DIMENSION(4) :: i_dimid, i_len, i_shape ! dimensions of the variable + REAL(KIND=dp) :: dl_missing2 ! missing value of the variable + !!---------------------------------------------------------------------- + + ! Open and test netcdf file + ! ------------------------- + CALL nchdlerr( nf90_open( cd_filename, nf90_nowrite, i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_varid( i_file_id, cd_var, i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, xtype=i_type ) ,& + & __LINE__,__MYFILE__) + IF ( i_type .NE. NF90_DOUBLE ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'External type for this variable = ',i_type + WRITE(*,*)'The valid external data type is NF90_DOUBLE : 6' +! WRITE(*,*)'CALL abort' +! CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, ndims=i_ndims ) ,& + & __LINE__,__MYFILE__) + IF ( i_ndims .NE. 4 ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'Number of dimensions for this variable = ',i_ndims + WRITE(*,*)'The valid number of dimension is 4' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + CALL nchdlerr( nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dimid ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(1), len=i_len(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(2), len=i_len(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(3), len=i_len(3) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dimid(4), len=i_len(4) ) ,& + & __LINE__,__MYFILE__) + i_shape=SHAPE(dd_var) + IF ( (i_len(1) .NE. i_shape(1)) .OR. (i_len(2) .NE. i_shape(2)) & + .OR. (i_len(3) .NE. i_shape(3)) .OR. (i_len(4) .NE. i_shape(4)) ) THEN + WRITE(*,*)'filename = ',cd_filename + WRITE(*,*)'variable = ',cd_var + WRITE(*,*)'shape of array = ',SHAPE(dd_var) + WRITE(*,*)'Dimension length of variable = ',i_len + WRITE(*,*)'Dimensions are different' + WRITE(*,*)'CALL abort' + CALL abort + ENDIF + + ! Read variable + ! ------------- + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, dd_var ) ,& + & __LINE__,__MYFILE__) + + i_exist = nf90_get_att( i_file_id, i_var_id, '_FillValue', dl_missing2 ) + IF ( i_exist .NE. nf90_noerr ) THEN + i_exist = nf90_get_att( i_file_id, i_var_id, 'missing_value', dl_missing2 ) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + IF ( i_exist .NE. nf90_noerr ) THEN + dl_missing2 = MAXVAL(dd_var) + ENDIF + + IF ( PRESENT(dd_missing) ) THEN + dd_missing = dl_missing2 + ELSE + WHERE(dd_var .EQ. dl_missing2) dd_var = 0.0 + WHERE((dd_var .GT. 0.) .EQV. (dd_var .LE. 0.)) dd_var = 0.0 + ENDIF + + END SUBROUTINE get_var_4d_d + + !!====================================================================== + + SUBROUTINE put_coord_r ( cd_filename, p_lon, p_lat, p_dep, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_coord_r *** + !! + !! ** Purpose : write coordinates as reals in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + REAL(KIND=sp), DIMENSION(:,:), INTENT(in) :: & + p_lon, p_lat ! longitude and latitude + REAL(KIND=sp), DIMENSION(:), OPTIONAL, INTENT(in) :: & + p_dep ! depth + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifiers + i_dim_x_id, i_dim_y_id, i_dim_z_id, & ! dimension identifiers + i_var_exist ! test + INTEGER, DIMENSION(2) :: i_dimxy ! dimensions of longitude and latitude + INTEGER, DIMENSION(1) :: i_dimz ! dimension of depth + INTEGER, DIMENSION(3) :: i_dim ! dimensions for netcdf file + REAL :: & + z_minx, z_maxx, z_miny, z_maxy, z_minz, z_maxz ! minima and maxima + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( p_lon ) + z_minx = MINVAL( p_lon ) + z_maxx = MAXVAL( p_lon ) + z_miny = MINVAL( p_lat ) + z_maxy = MAXVAL( p_lat ) + + IF ( PRESENT( p_dep ) ) THEN + i_dimz = SHAPE( p_dep ) + z_minz = MINVAL( p_dep ) + z_maxz = MAXVAL( p_dep ) + ENDIF + + ! Open or create netcdf file + ! -------------------------- + INQUIRE( FILE=TRIM(cd_filename), EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( p_dep ) ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, i_dimz, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy, i_dimz ) + ENDIF + ELSE + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + ! Add longitude, latitude and depth + ! --------------------------------- + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + IF ( PRESENT( p_dep ) ) THEN + i_var_exist = nf90_inq_dimid( i_file_id, 'z', i_dim_z_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'z', i_dimz(1), i_dim_z_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'z', i_dim_z_id ) ,& + & __LINE__,__MYFILE__) + i_dim(3) = i_dim_z_id + ENDIF + + i_var_exist = nf90_inq_varid( i_file_id, "longitude", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "longitude", nf90_real, (/i_dim(1),i_dim(2)/), i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'longitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'longitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'degrees_east' ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'Y' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'east' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', 9.e+19 ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_minx ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_maxx ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_lon) ,& + & __LINE__,__MYFILE__) + + i_var_exist = nf90_inq_varid( i_file_id, "latitude", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "latitude", nf90_real, (/i_dim(1),i_dim(2)/), i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'latitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'latitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'degrees_north' ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'X' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'north' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', 9.e+19 ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_miny ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_maxy ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_lat),__LINE__,__MYFILE__ ) + + IF ( PRESENT( p_dep ) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, "depth", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "depth", nf90_real, i_dim(3), i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'depth' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'depth below the surface') ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'm' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'unit_long', 'meter' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'Z' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'down' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', 9.e+19 ),__LINE__,__MYFILE__ ) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_minz ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_maxz ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, p_dep) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE put_coord_r + + SUBROUTINE put_coord_d ( cd_filename, dd_lon, dd_lat, dd_dep, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_coord_d *** + !! + !! ** Purpose : write coordinates as real(kind=dp) in a netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - get variable informations + !! - (re)define variable + !! - put variable in netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + REAL(KIND=dp), DIMENSION(:,:), INTENT(in) :: & + dd_lon, dd_lat ! longitude and latitude + REAL(KIND=dp), DIMENSION(:), OPTIONAL, INTENT(in) :: & + dd_dep ! depth + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + LOGICAL :: llexist ! test + INTEGER :: & + i_file_id, i_var_id, & ! file and variable identifiers + i_dim_x_id, i_dim_y_id, i_dim_z_id, & ! dimension identifiers + i_var_exist ! test + INTEGER, DIMENSION(2) :: i_dimxy ! dimensions of longitude and latitude + INTEGER, DIMENSION(1) :: i_dimz ! dimension of depth + INTEGER, DIMENSION(3) :: i_dim ! dimensions for netcdf file + REAL(KIND=dp) :: & + dl_minx, dl_maxx, dl_miny, dl_maxy, & + dl_minz, dl_maxz, & ! minima and maxima + dl_missing ! missing value + !!---------------------------------------------------------------------- + + ! Read dimensions and compute min and max + ! --------------------------------------- + i_dimxy = SHAPE( dd_lon ) + dl_minx = MINVAL( dd_lon ) + dl_maxx = MAXVAL( dd_lon ) + dl_miny = MINVAL( dd_lat ) + dl_maxy = MAXVAL( dd_lat ) + + IF ( PRESENT( dd_dep ) ) THEN + i_dimz = SHAPE( dd_dep ) + dl_minz = MINVAL(dd_dep) + dl_maxz = MAXVAL(dd_dep) + ENDIF + + ! Open or create netcdf file + ! -------------------------- + INQUIRE( FILE=TRIM(cd_filename), EXIST=llexist ) + IF ( .NOT. llexist ) THEN + IF ( PRESENT( dd_dep ) ) THEN + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, i_dimz, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy, i_dimz ) + ENDIF + ELSE + IF ( PRESENT( cd_descr ) ) THEN + CALL create_map ( cd_filename, i_dimxy, cd_descr=cd_descr ) + ELSE + CALL create_map ( cd_filename, i_dimxy ) + ENDIF + ENDIF + ENDIF + + CALL nchdlerr( nf90_open( cd_filename, nf90_write, i_file_id ) ,& + & __LINE__,__MYFILE__) + + ! Add longitude, latitude and depth + ! --------------------------------- + dl_missing = 9.e+19_8 + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'x', i_dim_x_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'y', i_dim_y_id ) ,& + & __LINE__,__MYFILE__) + i_dim(1) = i_dim_x_id + i_dim(2) = i_dim_y_id + IF ( PRESENT( dd_dep ) ) THEN + i_var_exist = nf90_inq_dimid( i_file_id, 'z', i_dim_z_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'z', i_dimz(1), i_dim_z_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + i_dim(3) = i_dim_z_id + ENDIF + + i_var_exist = nf90_inq_varid( i_file_id, "longitude", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "longitude", nf90_double, (/i_dim(1),i_dim(2)/), i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'longitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'longitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'degrees_east' ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'Y' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'east' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', dl_missing ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_minx ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_maxx ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_lon) ,& + & __LINE__,__MYFILE__) + + i_var_exist = nf90_inq_varid( i_file_id, "latitude", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "latitude", nf90_double, (/i_dim(1),i_dim(2)/), i_var_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'latitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'latitude' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'degrees_north' ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'X' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'north' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', dl_missing ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_miny ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_maxy ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_lat),__LINE__,__MYFILE__ ) + + IF ( PRESENT( dd_dep ) ) THEN + i_var_exist = nf90_inq_varid( i_file_id, "depth", i_var_id ) + CALL nchdlerr( nf90_redef( i_file_id ) ,& + & __LINE__,__MYFILE__) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_def_var( i_file_id, "depth", nf90_double, i_dim(3), i_var_id ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'data_type', 'float' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', 'depth' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'depth below the surface'),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'm' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'unit_long', 'meter' ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'axis', 'Z' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'positive', 'down' ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, '_FillValue', dl_missing ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', dl_minz ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', dl_maxz ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, dd_dep) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) +! + END SUBROUTINE put_coord_d + + !!====================================================================== + + SUBROUTINE create_map ( cd_filename, k_dimxy, k_dimz, cd_descr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE create_map *** + !! + !! ** Purpose : create netcdf file + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - define dimension of the netcdf file + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(in) :: & + cd_filename ! filename + INTEGER, DIMENSION(:), INTENT(in) :: k_dimxy ! dimensions of longitude and latitude + INTEGER, DIMENSION(1), OPTIONAL, INTENT(in) :: k_dimz ! dimension of depth + CHARACTER(len=80), DIMENSION(6), OPTIONAL, INTENT(in) :: & + cd_descr ! description of file contents + + !! * local declarations + INTEGER :: & + i_file_id, i_dim_id ! file and dimension identifiers + INTEGER, DIMENSION(1) :: i_dim ! dimension of k_dimxy + !!---------------------------------------------------------------------- + + i_dim = SHAPE(k_dimxy) + + ! Create file + ! ----------- + CALL nchdlerr( nf90_create( cd_filename, nf90_clobber, i_file_id ) ,& + & __LINE__,__MYFILE__) + + ! Define dimensions + ! ----------------- + CALL nchdlerr( nf90_def_dim( i_file_id, 'x', k_dimxy(1), i_dim_id ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'y', k_dimxy(2), i_dim_id ) ,& + & __LINE__,__MYFILE__) + IF ( PRESENT(k_dimz) ) THEN + CALL nchdlerr( nf90_def_dim( i_file_id, 'z', k_dimz(1), i_dim_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + IF ( i_dim(1) .EQ. 3 ) THEN + CALL nchdlerr( nf90_def_dim( i_file_id, 'z', k_dimxy(3), i_dim_id ) ,& + & __LINE__,__MYFILE__) + ENDIF + CALL nchdlerr( nf90_def_dim( i_file_id, 'time', nf90_unlimited, i_dim_id ) ,& + & __LINE__,__MYFILE__) + + IF ( PRESENT( cd_descr ) ) THEN + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "title", cd_descr(1) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "institution", cd_descr(2) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "source", cd_descr(3) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "history", cd_descr(4) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "references", cd_descr(5) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, nf90_global, "comment", cd_descr(6) ) ,& + & __LINE__,__MYFILE__) + ENDIF + + CALL nchdlerr( nf90_close( i_file_id ) ,& + & __LINE__,__MYFILE__) + + END SUBROUTINE create_map + + !!====================================================================== + + SUBROUTINE put_att( k_file_id, k_var_id, k_code ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_att *** + !! + !! ** Purpose : write CF attributes + !! + !! ** Method : use netcdf fortran library + !! + !! ** Action : - write CF attributes + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + INTEGER, INTENT(in) :: k_file_id, k_var_id, & ! file and variable identifiers + k_code ! CF identifier + + !! * local declarations + CHARACTER(len=80) :: & + cl_name, cl_longname, & ! names of variable + cl_unit, cl_longunit ! units of variable + !!---------------------------------------------------------------------- + + ! Get variable attributes and write them + ! -------------------------------------- + CALL get_var_info( k_code, cl_name, cl_longname, cl_unit, cl_longunit ) + + CALL nchdlerr( nf90_put_att( k_file_id, k_var_id, 'standard_name', TRIM(cl_name) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( k_file_id, k_var_id, 'long_name', TRIM(cl_longname) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( k_file_id, k_var_id, 'units', TRIM(cl_unit) ) ,& + & __LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( k_file_id, k_var_id, 'unit_long', TRIM(cl_longunit) ),__LINE__,__MYFILE__ ) + + END SUBROUTINE put_att + + !!====================================================================== + + SUBROUTINE get_var_info( k_code, cd_name, cd_longname, cd_unit, cd_longunit ) + !!---------------------------------------------------------------------- + !! *** ROUTINE put_att *** + !! + !! ** Purpose : get CF attributes + !! + !! ** Method : outofcore database + !! + !! ** Action : - find iCF attributes + !! + !! Reference : + !! + !! History : + !! 06-05 (N. Daget) original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Library used + + !! * arguments + CHARACTER(len=80), INTENT(out) :: cd_name ! name of variable + CHARACTER(len=80), OPTIONAL, INTENT(out) :: & + cd_longname, cd_unit, cd_longunit ! name and units of variable + INTEGER, INTENT(in) :: k_code ! CF identifier + + !! * local declarations + !!---------------------------------------------------------------------- + + ! Get CF attributes + ! ----------------- + SELECT CASE ( k_code ) + CASE (129) + cd_name="sea_water_potential_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="Potential temperature ref to surface K" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_Celcius" + CASE (130) + cd_name="sea_water_salinity" + IF ( PRESENT(cd_longname) ) cd_longname="sea water salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (131) + cd_name="sea_water_x_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="U zonal current m/s" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (132) + cd_name="sea_water_y_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="V meridional current m/s" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (133) + cd_name="upward_sea_water_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="W vertical current m/s" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (134) + cd_name="mst" + IF ( PRESENT(cd_longname) ) cd_longname="Modulus of strain rate tensor" + IF ( PRESENT(cd_unit) ) cd_unit="s-1" + IF ( PRESENT(cd_longunit) ) cd_longunit="per_second" + CASE (135) + cd_name="vvs" + IF ( PRESENT(cd_longname) ) cd_longname="Vertical viscosity" + IF ( PRESENT(cd_unit) ) cd_unit="m^2/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_meter_per_second" + CASE (136) + cd_name="vdf" + IF ( PRESENT(cd_longname) ) cd_longname="Vertical diffusivity" + IF ( PRESENT(cd_unit) ) cd_unit="m^2/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_meter_per_second" + CASE (137) + cd_name="depth" + IF ( PRESENT(cd_longname) ) cd_longname="depth" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (138) + cd_name="sea_water_sigma_theta" + IF ( PRESENT(cd_longname) ) cd_longname="Sigma theta" + IF ( PRESENT(cd_unit) ) cd_unit="kgm3" + IF ( PRESENT(cd_longunit) ) cd_longunit="kilogramme cubicmeter" + CASE (139) + cd_name="richardson_number" + IF ( PRESENT(cd_longname) ) cd_longname="Richardson number" + IF ( PRESENT(cd_unit) ) cd_unit="" + IF ( PRESENT(cd_longunit) ) cd_longunit="" + CASE (140) + cd_name="UV" + IF ( PRESENT(cd_longname) ) cd_longname="UV product" + IF ( PRESENT(cd_unit) ) cd_unit="m**2 s**-2" + IF ( PRESENT(cd_longunit) ) cd_longunit="m**2 s**-2" + CASE (141) + cd_name="UT" + IF ( PRESENT(cd_longname) ) cd_longname="UT product" + IF ( PRESENT(cd_unit) ) cd_unit="m s**-1 degC" + IF ( PRESENT(cd_longunit) ) cd_longunit="m s**-1 degC" + CASE (142) + cd_name="VT" + IF ( PRESENT(cd_longname) ) cd_longname="VT product" + IF ( PRESENT(cd_unit) ) cd_unit="m s**-1 degC" + IF ( PRESENT(cd_longunit) ) cd_longunit="m s**-1 degC" + CASE (143) + cd_name="UU" + IF ( PRESENT(cd_longname) ) cd_longname="UU product" + IF ( PRESENT(cd_unit) ) cd_unit="m**2 s**-2" + IF ( PRESENT(cd_longunit) ) cd_longunit="m**2 s**-2" + CASE (144) + cd_name="VV" + IF ( PRESENT(cd_longname) ) cd_longname="VV product" + IF ( PRESENT(cd_unit) ) cd_unit="m**2 s**-2" + IF ( PRESENT(cd_longunit) ) cd_longunit="m**2 s**-2" + CASE (145) + cd_name="sea_surface_height_above_geoid" + IF ( PRESENT(cd_longname) ) cd_longname="sea_surface_height_above_geoid" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (146) + cd_name="sea_floor_topography" + IF ( PRESENT(cd_longname) ) cd_longname="Sea floor topography" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (147) + cd_name="ocean_barotropic_streamfunction" + IF ( PRESENT(cd_longname) ) cd_longname="Barotropic Stream Function" + IF ( PRESENT(cd_unit) ) cd_unit="m3/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="cubic_meter_per_second" + CASE (148) + cd_name="ocean_mixed_layer_thickness" + IF ( PRESENT(cd_longname) ) cd_longname="depth of the ocean mixed layer from the surface" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (149) + cd_name="sea_water_bottom_pressure" + IF ( PRESENT(cd_longname) ) cd_longname="sea_water_bottom_pressure" + IF ( PRESENT(cd_unit) ) cd_unit="Pa" + IF ( PRESENT(cd_longunit) ) cd_longunit="Pascal" + CASE (153) + cd_name="surface_downward_eastward_stress" + IF ( PRESENT(cd_longname) ) cd_longname="U-Stress" + IF ( PRESENT(cd_unit) ) cd_unit="Pa" + IF ( PRESENT(cd_longunit) ) cd_longunit="Pascal" + CASE (154) + cd_name="surface_downward_northward_stress" + IF ( PRESENT(cd_longname) ) cd_longname="V-Stress" + IF ( PRESENT(cd_unit) ) cd_unit="Pa" + IF ( PRESENT(cd_longunit) ) cd_longunit="Pascal" + CASE (156) + cd_name="turbulent_kinetic_energy_input" + IF ( PRESENT(cd_longname) ) cd_longname="turbulent kinetic energy input" + IF ( PRESENT(cd_unit) ) cd_unit="W.m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="watt_per_square_meter" + CASE (157) + cd_name="absorbed_solar_radiation" + IF ( PRESENT(cd_longname) ) cd_longname="Absorbed solar radiation" + IF ( PRESENT(cd_unit) ) cd_unit="W.m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="watt_per_square_meter" + CASE (158) + cd_name="surface_downward_water_flux" + IF ( PRESENT(cd_longname) ) cd_longname="Precipitation minus Evaporation" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (159) + cd_name="sea_surface_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="specified sea surface temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_Celcius" + CASE (160) + cd_name="surface_downward_heat_flux_in_sea_water" + IF ( PRESENT(cd_longname) ) cd_longname="Specified Surface Heat flux" + IF ( PRESENT(cd_unit) ) cd_unit="W.m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="watt_per_square_meter" + CASE (161) + cd_name="diagnosed_sst_error" + IF ( PRESENT(cd_longname) ) cd_longname="diagnosed sea surface temperature error" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (162) + cd_name="surface_downward_heat_flux_in_sea_water" + IF ( PRESENT(cd_longname) ) cd_longname="Heat flux Correction" + IF ( PRESENT(cd_unit) ) cd_unit="W.m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="watt_per_square_meter" + CASE (163) + cd_name="d20_isotherm_depth" + IF ( PRESENT(cd_longname) ) cd_longname="depth of the D20 isotherm" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (164) + cd_name="ocean_integral_of_sea_water_temperature_wrt_depth" + IF ( PRESENT(cd_longname) ) cd_longname="averaged temperature over the fisrt 300m" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (167) + cd_name="barotropic_eastward_sea_water_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="integral of U dz" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (168) + cd_name="barotropic_northward_sea_water_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="integral of V dz" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (169) + cd_name="product_of_eastward_sea_water_velocity_and_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="integral of Tudz" + IF ( PRESENT(cd_unit) ) cd_unit="Km/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="Kelvin_meter_per_second" + CASE (170) + cd_name="product_of_northward_sea_water_velocity_and_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="integral of Tvdz" + IF ( PRESENT(cd_unit) ) cd_unit="Km/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="Kelvin_meter_per_second" + CASE (171) + cd_name="velocity_maximum" + IF ( PRESENT(cd_longname) ) cd_longname="velocity maximum" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (172) + cd_name="depth_of_maximum_velocity" + IF ( PRESENT(cd_longname) ) cd_longname="depth of maximum velocity" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (173) + cd_name="salinity_maximum" + IF ( PRESENT(cd_longname) ) cd_longname="salinity maximum" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (174) + cd_name="depth_of_maximum_salinity" + IF ( PRESENT(cd_longname) ) cd_longname="depth of maximum salinity" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (175) + cd_name="ocean_integral_of_sea_water_salinity_wrt_depth" + IF ( PRESENT(cd_longname) ) cd_longname="averaged salinity over the fisrt 300m" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (179) + cd_name="potential_temperature_analysis_error" + IF ( PRESENT(cd_longname) ) cd_longname="Potential temperature analysis error" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (180) + cd_name="background_potential_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="background potential temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (181) + cd_name="analysed_potential_temperature" + IF ( PRESENT(cd_longname) ) cd_longname="Analysed potential temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (182) + cd_name="potential_temperature_background_error" + IF ( PRESENT(cd_longname) ) cd_longname="Potential temperature background error" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (183) + cd_name="analysed_salinity_from_soft" + IF ( PRESENT(cd_longname) ) cd_longname="analysed salinity from S(T) balance operator" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (184) + cd_name="sea_water_salinity_increment" + IF ( PRESENT(cd_longname) ) cd_longname="salinity increment" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (185) + cd_name="temperature_bias" + IF ( PRESENT(cd_longname) ) cd_longname="bias in temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (186) + cd_name="salinity_bias" + IF ( PRESENT(cd_longname) ) cd_longname="bias in salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (187) + cd_name="eastward_sea_water_velocity_increment_from_balance" + IF ( PRESENT(cd_longname) ) cd_longname="eastward sea water velocity increment from balance operator" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (188) + cd_name="northward_sea_water_velocity_increment_from_balance" + IF ( PRESENT(cd_longname) ) cd_longname="northward sea water velocity increment from balance operator" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (190) + cd_name="sea_water_salinity_increment_from_soft" + IF ( PRESENT(cd_longname) ) cd_longname="sea water salinity increment from soft" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (191) + cd_name="sea_water_salinity_analysis_error" + IF ( PRESENT(cd_longname) ) cd_longname="sea water salinity analysis error" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (192) + cd_name="sea_water_background_salinity" + IF ( PRESENT(cd_longname) ) cd_longname="sea water background salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (193) + cd_name="sea_water_analysed_salinity" + IF ( PRESENT(cd_longname) ) cd_longname="sea water analysed salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (194) + cd_name="sea_water_salinity_background_error" + IF ( PRESENT(cd_longname) ) cd_longname="sea water salinity background error" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (500) + cd_name="bcksta_bal_S" + IF ( PRESENT(cd_longname) ) cd_longname="balanced part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (501) + cd_name="bcksta_unbal_S" + IF ( PRESENT(cd_longname) ) cd_longname="unbalanced part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (502) + cd_name="bcksta_bal_u" + IF ( PRESENT(cd_longname) ) cd_longname="balanced part of u" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (503) + cd_name="bcksta_unbal_u" + IF ( PRESENT(cd_longname) ) cd_longname="unbalanced part of u" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (504) + cd_name="bcksta_bal_v" + IF ( PRESENT(cd_longname) ) cd_longname="balanced part of v" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (505) + cd_name="bcksta_unbal_v" + IF ( PRESENT(cd_longname) ) cd_longname="unbalanced part of v" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (506) + cd_name="bcksta_bal_e" + IF ( PRESENT(cd_longname) ) cd_longname="balanced part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (507) + cd_name="bcksta_unbal_e" + IF ( PRESENT(cd_longname) ) cd_longname="unbalanced part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (510) + cd_name="increm_tot_T" + IF ( PRESENT(cd_longname) ) cd_longname="increment for total part of T" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (511) + cd_name="increm_tot_S" + IF ( PRESENT(cd_longname) ) cd_longname="increment for total part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (512) + cd_name="increm_bal_S" + IF ( PRESENT(cd_longname) ) cd_longname="increment for balanced part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (513) + cd_name="increm_unbal_S" + IF ( PRESENT(cd_longname) ) cd_longname="increment for unbalanced part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (514) + cd_name="increm_tot_u" + IF ( PRESENT(cd_longname) ) cd_longname="increment for total part of U" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (515) + cd_name="increm_bal_u" + IF ( PRESENT(cd_longname) ) cd_longname="increment for balanced part of U" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (516) + cd_name="increm_unbal_u" + IF ( PRESENT(cd_longname) ) cd_longname="increment for unbalanced part of U" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (517) + cd_name="increm_tot_v" + IF ( PRESENT(cd_longname) ) cd_longname="increment for total part of V" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (518) + cd_name="increm_bal_v" + IF ( PRESENT(cd_longname) ) cd_longname="increment for balanced part of V" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (519) + cd_name="increm_unbal_v" + IF ( PRESENT(cd_longname) ) cd_longname="increment for unbalanced part of V" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (520) + cd_name="increm_tot_e" + IF ( PRESENT(cd_longname) ) cd_longname="increment for total part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (521) + cd_name="increm_bal_e" + IF ( PRESENT(cd_longname) ) cd_longname="increment for balanced part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (522) + cd_name="increm_unbal_e" + IF ( PRESENT(cd_longname) ) cd_longname="increment for unbalanced part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (530) + cd_name="pbudct" + IF ( PRESENT(cd_longname) ) cd_longname="distance between coastline and model u-points" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (531) + cd_name="pbvdct" + IF ( PRESENT(cd_longname) ) cd_longname="distance between coastline and model v-points" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (532) + cd_name="pbtdct" + IF ( PRESENT(cd_longname) ) cd_longname="distance between coastline and model t-points" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (533) + cd_name="pbfdct" + IF ( PRESENT(cd_longname) ) cd_longname="distance between coastline and model f-points" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (540) + cd_name="bckenw_wetjc" + IF ( PRESENT(cd_longname) ) cd_longname="energy T weighting coefficient for Jc term" + IF ( PRESENT(cd_unit) ) cd_unit="m^2/s^2/C^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_meter_per_square_second_per_square_degre_celcius" + CASE (541) + cd_name="bckenw_wesjc" + IF ( PRESENT(cd_longname) ) cd_longname="energy S weighting coefficient for Jc term" + IF ( PRESENT(cd_unit) ) cd_unit="m^2/s^2/PSU^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_meter_per_square_second_per_square_practical_salinity_scale" + CASE (550) + cd_name="bckesd_ana_t" + IF ( PRESENT(cd_longname) ) cd_longname="standard deviations for total part of T" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (551) + cd_name="bckesd_ana_s" + IF ( PRESENT(cd_longname) ) cd_longname="standard deviations for unbalanced part of S" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (552) + cd_name="bckesd_ana_u" + IF ( PRESENT(cd_longname) ) cd_longname="standard deviations for unbalanced part of u" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (553) + cd_name="bckesd_ana_v" + IF ( PRESENT(cd_longname) ) cd_longname="standard deviations for unbalanced part of V" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (554) + cd_name="bckesd_ana_e" + IF ( PRESENT(cd_longname) ) cd_longname="standard deviations for unbalanced part of SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (560) + cd_name="bckesd_mod_t" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (561) + cd_name="bckesd_mod_s" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (562) + cd_name="bckesd_mod_u" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for u-velocity" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (563) + cd_name="bckesd_mod_v" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for v-velocity" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (564) + cd_name="bckesd_mod_e" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (565) + cd_name="bckesd_modf_t" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for temperature at final time" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (566) + cd_name="bckesd_modf_s" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for salinity at final time" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (567) + cd_name="bckesd_modf_u" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for u-velocity at final time" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (568) + cd_name="bckesd_modf_v" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for v-velocity at final time" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (569) + cd_name="bckesd_modf_e" + IF ( PRESENT(cd_longname) ) cd_longname="background error standard deviations for SSH at final time" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (570) + cd_name="bcksal_dSdT" + IF ( PRESENT(cd_longname) ) cd_longname="dS/dT coefficient for the salinity balance" + IF ( PRESENT(cd_unit) ) cd_unit="PSU/C" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale_per_degree_celcius" + CASE (571) + cd_name="bcksal_dTdz" + IF ( PRESENT(cd_longname) ) cd_longname="dT/dz for the background" + IF ( PRESENT(cd_unit) ) cd_unit="C/m" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius_per_meter" + CASE (572) + cd_name="bcksal_dSdz" + IF ( PRESENT(cd_longname) ) cd_longname="dS/dz for the background" + IF ( PRESENT(cd_unit) ) cd_unit="PSU/m" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale_per_meter" + CASE (575) + cd_name="bckssh_alpha" + IF ( PRESENT(cd_longname) ) cd_longname="Thermal expansion coefficient for the SSH balance" + IF ( PRESENT(cd_unit) ) cd_unit="" + IF ( PRESENT(cd_longunit) ) cd_longunit="" + CASE (576) + cd_name="bckssh_beta" + IF ( PRESENT(cd_longname) ) cd_longname="Saline expansion coefficient for the SSH balance" + IF ( PRESENT(cd_unit) ) cd_unit="" + IF ( PRESENT(cd_longunit) ) cd_longunit="" + CASE (580) + cd_name="filnot" + IF ( PRESENT(cd_longname) ) cd_longname="filter normalization factor at T-points" + IF ( PRESENT(cd_unit) ) cd_unit="m^(3/2)" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_root_of_cube_meter" + CASE (581) + cd_name="filnou" + IF ( PRESENT(cd_longname) ) cd_longname="filter normalization factor at u-points" + IF ( PRESENT(cd_unit) ) cd_unit="m^(3/2)" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_root_of_cube_meter" + CASE (582) + cd_name="filnov" + IF ( PRESENT(cd_longname) ) cd_longname="filter normalization factor at v-points" + IF ( PRESENT(cd_unit) ) cd_unit="m^(3/2)" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_root_of_cube_meter" + CASE (583) + cd_name="filnoe" + IF ( PRESENT(cd_longname) ) cd_longname="filter normalization factor at eta-points" + IF ( PRESENT(cd_unit) ) cd_unit="m^(3/2)" + IF ( PRESENT(cd_longunit) ) cd_longunit="square_root_of_cube_meter" + CASE (590) + cd_name="bckint" + IF ( PRESENT(cd_longname) ) cd_longname="increment to background temperature" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (591) + cd_name="bckins" + IF ( PRESENT(cd_longname) ) cd_longname="increment to background salinity" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity" + CASE (592) + cd_name="bckinu" + IF ( PRESENT(cd_longname) ) cd_longname="increment to background u-velocity" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (593) + cd_name="bckinv" + IF ( PRESENT(cd_longname) ) cd_longname="increment to background v-velocity" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (594) + cd_name="bckineta" + IF ( PRESENT(cd_longname) ) cd_longname="increment to background SSH" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (610) + cd_name="tangent_T" + IF ( PRESENT(cd_longname) ) cd_longname="tangent potential temperature field" + IF ( PRESENT(cd_unit) ) cd_unit="C" + IF ( PRESENT(cd_longunit) ) cd_longunit="degree_celcius" + CASE (611) + cd_name="tangent_S" + IF ( PRESENT(cd_longname) ) cd_longname="tangent salinity field" + IF ( PRESENT(cd_unit) ) cd_unit="PSU" + IF ( PRESENT(cd_longunit) ) cd_longunit="practical_salinity_scale" + CASE (612) + cd_name="tangent_u" + IF ( PRESENT(cd_longname) ) cd_longname="tangent U zonal current" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (613) + cd_name="tangent_v" + IF ( PRESENT(cd_longname) ) cd_longname="tangent V meridional current" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (614) + cd_name="tangent_w" + IF ( PRESENT(cd_longname) ) cd_longname="tangent W vertical current" + IF ( PRESENT(cd_unit) ) cd_unit="m/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter_per_second" + CASE (615) + cd_name="tangent_SSH" + IF ( PRESENT(cd_longname) ) cd_longname="tangent sea surface height above geoid" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (616) + cd_name="tangent BSF" + IF ( PRESENT(cd_longname) ) cd_longname="tangent barotropic stream function" + IF ( PRESENT(cd_unit) ) cd_unit="m3/s" + IF ( PRESENT(cd_longunit) ) cd_longunit="cubic_meter_per_second" + CASE (620) + cd_name="d28_isotherm_depth" + IF ( PRESENT(cd_longname) ) cd_longname="depth of the D28 isotherm" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (621) + cd_name="ocean_mixed_layer_thickness_bn2_criterion" + IF ( PRESENT(cd_longname) ) cd_longname="depth of the ocean mixed layer from the surface with bn2 citerion" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (622) + cd_name="thermocline_depth" + IF ( PRESENT(cd_longname) ) cd_longname="depth of the strongest vertical temperature gradient" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (623) + cd_name="heat_content_of_first_300m" + IF ( PRESENT(cd_longname) ) cd_longname="heat content of first 300 m" + IF ( PRESENT(cd_unit) ) cd_unit="J" + IF ( PRESENT(cd_longunit) ) cd_longunit="joules" + CASE (624) + cd_name="turbocline_depth" + IF ( PRESENT(cd_longname) ) cd_longname="turbocline depth" + IF ( PRESENT(cd_unit) ) cd_unit="m" + IF ( PRESENT(cd_longunit) ) cd_longunit="meter" + CASE (625) + cd_name="U-energy_transport" + IF ( PRESENT(cd_longname) ) cd_longname="U-energy transport" + IF ( PRESENT(cd_unit) ) cd_unit="J/s/m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="joules_per_second_per_square_meter" + CASE (626) + cd_name="V-energy_transport" + IF ( PRESENT(cd_longname) ) cd_longname="V-energy transport" + IF ( PRESENT(cd_unit) ) cd_unit="J/s/m^2" + IF ( PRESENT(cd_longunit) ) cd_longunit="joules_per_second_per_square_meter" + CASE default + cd_name="varname" + IF ( PRESENT(cd_longname) ) cd_longname="long_varname" + IF ( PRESENT(cd_unit) ) cd_unit="varunit" + IF ( PRESENT(cd_longunit) ) cd_longunit="long_varunit" + END SELECT + + END SUBROUTINE get_var_info + +END MODULE ioncdf diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_ext_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_ext_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..0213bd09750cc0050784fca7d0b6c043820b19e1 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_ext_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/lbc_nfd_ext_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..bbb6a19409224b27d93942df87c5eefc5292b2a2 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/lbc_nfd_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_nogather_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_nogather_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..558d42496370db8a324d81cb6bf2f9fe422dd27d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbc_nfd_nogather_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/lbc_nfd_nogather_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/lbcnfd.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbcnfd.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c00d87e87162e6a51ebf5b3ca9d49d5eb8ab1a58 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/lbcnfd.F90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/lbcnfd.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/lib_mpp.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/lib_mpp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a71e0fdb9badcfa0fe1326a06b1d806f568e611a --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/lib_mpp.F90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/lib_mpp.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_allreduce_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_allreduce_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..94777b02c68c8a942100f220e334d79c7285447e --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_allreduce_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/mpp_allreduce_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_bdy_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_bdy_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..cd65dc967d22ee86a29c2e1ff02bfff3ce239329 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_bdy_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/mpp_bdy_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_lnk_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_lnk_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..903c04facf1853feeaae4ad5c2aed6cd619c57e3 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_lnk_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/mpp_lnk_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_loc_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_loc_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..84ebdf53ac48fa4bc2c104d445bb697d6c492b69 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_loc_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/mpp_loc_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_nfd_generic.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_nfd_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..2a6139866ed7b52233f9dec84ba4e62a60df9548 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/mpp_nfd_generic.h90 @@ -0,0 +1 @@ +../../../src/OCE/LBC/mpp_nfd_generic.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/nctools.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/nctools.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d0f1e99c2d7822b86af90b04e303c9be2b9aabc7 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/nctools.F90 @@ -0,0 +1,40 @@ +#define __MYFILE__ 'nctools.F90' +MODULE nctools + + ! Utility subroutines for netCDF access + ! Modified : MAB (nf90, handle_error, LINE&FILE) + ! Modifled : KSM (new shorter name) + + USE netcdf + + PUBLIC ldebug_netcdf, nchdlerr + LOGICAL :: ldebug_netcdf = .FALSE. ! Debug switch for netcdf + +CONTAINS + + SUBROUTINE nchdlerr(status,lineno,filename) + + ! Error handler for netCDF access + IMPLICIT NONE + + + INTEGER :: status ! netCDF return status + INTEGER :: lineno ! Line number (usually obtained from + ! preprocessing __LINE__,__MYFILE__) + CHARACTER(len=*),OPTIONAL :: filename + + IF (status/=nf90_noerr) THEN + WRITE(*,*)'Netcdf error, code ',status + IF (PRESENT(filename)) THEN + WRITE(*,*)'In file ',filename,' in line ',lineno + ELSE + WRITE(*,*)'In line ',lineno + END IF + WRITE(*,'(2A)')' Error message : ',nf90_strerror(status) + CALL abort + ENDIF + + END SUBROUTINE nchdlerr + +!---------------------------------------------------------------------- +END MODULE nctools diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_const.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_const.F90 new file mode 120000 index 0000000000000000000000000000000000000000..bd1db8e6b8a22ecd03e40ada24a6c6d31d6a253f --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_const.F90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/obs_const.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9c85c1cea4564a317bf9739ca1977ccf98dd8559 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv.F90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/obs_conv.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv_functions.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv_functions.h90 new file mode 120000 index 0000000000000000000000000000000000000000..7d0e71c2fa92e69e82022bf3522d9aa9069bbe58 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_conv_functions.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/obs_conv_functions.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_fbm.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_fbm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..cd2bcbb0496ba9339a2c60ff8b63a45c0b709a41 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_fbm.F90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/obs_fbm.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_prof_io.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_prof_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..632b2bce498745f2698fb131302ef9b308016349 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_prof_io.F90 @@ -0,0 +1,32 @@ +MODULE obs_prof_io + !!====================================================================== + !! *** MODULE obs_prof_io *** + !! Observation operators : I/O for ENACT and Coriolis files + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! read_enactfile : Read a obfbdata structure from an ENACT file. + !! read_coriofile : Read a obfbdata structure from an Coriolis file. + !!---------------------------------------------------------------------- + USE par_kind + USE obs_utils + USE obs_fbm + USE obs_conv + USE netcdf + IMPLICIT NONE + + INTEGER, PARAMETER :: imaxlev = 10000 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_prof_io.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsprof_io.h90" + +END MODULE obs_prof_io diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_seaice_io.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_seaice_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1293a9b2537862f3cf446b7994ce972940a3e6dd --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_seaice_io.F90 @@ -0,0 +1,30 @@ +MODULE obs_seaice_io + !!====================================================================== + !! *** MODULE obs_seaice_io *** + !! Observation operators : I/O for GHRSEAICE files + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! read_seaicefile : Read a obfbdata structure from an GHRSEAICE file + !!---------------------------------------------------------------------- + USE par_kind + USE obs_utils + USE obs_fbm + USE julian + USE netcdf + + IMPLICIT NONE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_seaice_io.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsseaice_io.h90" + +END MODULE obs_seaice_io diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_io.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b21958587ed39a136d85b921d20d329fb7a17350 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_io.F90 @@ -0,0 +1,30 @@ +MODULE obs_sla_io + !!====================================================================== + !! *** MODULE obs_sla_io *** + !! Observation operators : I/O for AVISO SLA files + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! read_enactfile : Read a obfbdata structure from an AVISO SLA file + !!---------------------------------------------------------------------- + USE par_kind + USE obs_utils + USE obs_fbm + use obs_sla_types + USE netcdf + + IMPLICIT NONE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sla_io.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obssla_io.h90" + +END MODULE obs_sla_io diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_types.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_types.F90 new file mode 100644 index 0000000000000000000000000000000000000000..029b67c4a2a9ffad5153703b04aacd3a5d5d58e2 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sla_types.F90 @@ -0,0 +1,19 @@ +MODULE obs_sla_types + !!====================================================================== + !! *** MODULE obs_sla_type *** + !! Observation operators : Satellite identifiers for SLA data + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sla_types.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + IMPLICIT NONE + +#include "obssla_types.h90" + +END MODULE obs_sla_types diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sst_io.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sst_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..702b329f2ad12d28076fd5745e300192f67031b4 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_sst_io.F90 @@ -0,0 +1,30 @@ +MODULE obs_sst_io + !!====================================================================== + !! *** MODULE obs_sst_io *** + !! Observation operators : I/O for GHRSST files + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! read_sstfile : Read a obfbdata structure from an GHRSST file + !!---------------------------------------------------------------------- + USE par_kind + USE obs_utils + USE obs_fbm + USE julian + USE netcdf + + IMPLICIT NONE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sst_io.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obssst_io.h90" + +END MODULE obs_sst_io diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_utils.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_utils.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e0a57ba7b222f9a61fa5f256e460fed068cc3fa1 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_utils.F90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/obs_utils.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_vel_io.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_vel_io.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9aa95dcbbc29e87398e659af90709d1e0e013c48 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obs_vel_io.F90 @@ -0,0 +1,32 @@ +MODULE obs_vel_io + !!====================================================================== + !! *** MODULE obs_vel_io *** + !! Observation operators : I/O for TAO velocity data + !!====================================================================== + !! History : + !! ! 09-01 (K. Mogensen) Initial version based on obs_read_taovel + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! read_taofile : Read a obfbdata structure from an TAO velocity file. + !!---------------------------------------------------------------------- + USE par_kind + USE obs_utils + USE obs_fbm + USE obs_conv + USE in_out_manager + USE netcdf + IMPLICIT NONE + + INTEGER, PARAMETER :: imaxlev = 10000 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_vel_io.F90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsvel_io.h90" + +END MODULE obs_vel_io diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obsprof_io.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsprof_io.h90 new file mode 100644 index 0000000000000000000000000000000000000000..381b7a35689a7dabe3206a4cf899f800626dcaab --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsprof_io.h90 @@ -0,0 +1,834 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsprof_io.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE read_enactfile( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_enactfile ** + !! + !! ** Purpose : Read from file the profile ENACT observations. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! History : + !! ! 09-01 (K. Mogensen) Original based on old versions + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output obfbdata structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + !! * Local declarations + INTEGER :: iobs ! Number of observations + INTEGER :: ilev ! Number of levels + INTEGER :: i_file_id + INTEGER :: i_obs_id + INTEGER :: i_lev_id + INTEGER :: i_phi_id + INTEGER :: i_lam_id + INTEGER :: i_depth_id + INTEGER :: i_var_id + INTEGER :: i_pl_num_id + INTEGER :: i_reference_date_time_id + INTEGER :: i_format_version_id + INTEGER :: i_juld_id + INTEGER :: i_data_type_id + INTEGER :: i_wmo_inst_type_id + INTEGER :: i_qc_var_id + INTEGER :: i_dc_ref_id + INTEGER :: i_qc_flag_id + CHARACTER(LEN=40) :: cl_fld_lam + CHARACTER(LEN=40) :: cl_fld_phi + CHARACTER(LEN=40) :: cl_fld_depth + CHARACTER(LEN=40) :: cl_fld_var_tp + CHARACTER(LEN=40) :: cl_fld_var_s + CHARACTER(LEN=40) :: cl_fld_var_ti + CHARACTER(LEN=40) :: cl_fld_var_juld_qc + CHARACTER(LEN=40) :: cl_fld_var_pos_qc + CHARACTER(LEN=40) :: cl_fld_var_depth_qc + CHARACTER(LEN=40) :: cl_fld_var_qc_t + CHARACTER(LEN=40) :: cl_fld_var_qc_s + CHARACTER(LEN=40) :: cl_fld_var_prof_qc_t + CHARACTER(LEN=40) :: cl_fld_var_prof_qc_s + CHARACTER(LEN=40) :: cl_fld_reference_date_time + CHARACTER(LEN=40) :: cl_fld_juld + CHARACTER(LEN=40) :: cl_fld_data_type + CHARACTER(LEN=40) :: cl_fld_pl_num + CHARACTER(LEN=40) :: cl_fld_format_version + CHARACTER(LEN=40) :: cl_fld_wmo_inst_type + CHARACTER(LEN=40) :: cl_fld_qc_flags_profiles + CHARACTER(LEN=40) :: cl_fld_qc_flags_levels + + CHARACTER(LEN=14), PARAMETER :: cl_name = 'read_enactfile' + CHARACTER(LEN=16) :: cl_data_type = '' + CHARACTER(LEN=4 ) :: cl_format_version = '' + INTEGER, DIMENSION(1) :: istart1, icount1 + INTEGER, DIMENSION(2) :: istart2, icount2 + CHARACTER(len=imaxlev) :: clqc + CHARACTER(len=1) :: cqc + INTEGER :: ji, jk + INTEGER, ALLOCATABLE, DIMENSION(:) :: iqc1 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iqc2 + + !----------------------------------------------------------------------- + ! Initialization + !----------------------------------------------------------------------- + + cl_fld_lam = 'LONGITUDE' + cl_fld_phi = 'LATITUDE' + cl_fld_depth = 'DEPH_CORRECTED' + cl_fld_reference_date_time = 'REFERENCE_DATE_TIME' + cl_fld_juld = 'JULD' + cl_fld_data_type = 'DATA_TYPE' + cl_fld_format_version = 'FORMAT_VERSION' + cl_fld_wmo_inst_type = 'WMO_INST_TYPE' + cl_fld_pl_num = 'PLATFORM_NUMBER' + + cl_fld_var_qc_t = 'POTM_CORRECTED_QC' + cl_fld_var_prof_qc_t = 'PROFILE_POTM_QC' + cl_fld_var_tp = 'POTM_CORRECTED' + cl_fld_var_qc_s = 'PSAL_CORRECTED_QC' + cl_fld_var_prof_qc_s = 'PROFILE_PSAL_QC' + cl_fld_var_s = 'PSAL_CORRECTED' + cl_fld_var_depth_qc = 'DEPH_CORRECTED_QC' + cl_fld_var_juld_qc = 'JULD_QC' + cl_fld_var_pos_qc = 'POSITION_QC' + cl_fld_var_ti = 'TEMP' + cl_fld_qc_flags_profiles = 'QC_FLAGS_PROFILES' + cl_fld_qc_flags_levels = 'QC_FLAGS_LEVELS' + + icount1(1) = 1 + + !----------------------------------------------------------------------- + ! Open file + !----------------------------------------------------------------------- + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & + & i_file_id ), cl_name, __LINE__ ) + + !----------------------------------------------------------------------- + ! Read the heading of the file + !----------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_data_type, & + & i_data_type_id ), cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_data_type_id, & + & cl_data_type ), cl_name, __LINE__ ) + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_format_version, & + & i_format_version_id ), cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_format_version_id, & + & cl_format_version ), cl_name, __LINE__ ) + + CALL str_c_to_for( cl_data_type ) + CALL str_c_to_for( cl_format_version ) + + IF(ldwp)WRITE(kunit,*) + IF(ldwp)WRITE(kunit,*) ' read_enactfile :' + IF(ldwp)WRITE(kunit,*) ' ~~~~~~~~~~~~~~~~' + IF(ldwp)WRITE(kunit,*) ' Data type = ', & + & TRIM( ADJUSTL( cl_data_type ) ) + IF(ldwp)WRITE(kunit,*) ' Format version = ', & + & TRIM( ADJUSTL( cl_format_version ) ) + + IF ( ( ( INDEX( cl_data_type,"ENACT v1.0" ) == 1 ) .OR. & + & ( INDEX( cl_data_type,"ENACT v1.4" ) == 1 ) .OR. & + & ( INDEX( cl_data_type,"ENACT v1.5" ) == 1 ) .OR. & + & ( INDEX( cl_data_type,"ENSEMBLES EN3 v1" ) == 1 ) ) & + & .AND. & + & ( INDEX( cl_format_version,"2.0" ) == 1 ) ) THEN + IF(ldwp)WRITE(kunit,*)' Valid input file' + ELSE + CALL fatal_error( 'Invalid input file', __LINE__ ) + ENDIF + + !--------------------------------------------------------------------- + ! Read the number of observations and levels to allocate arrays + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_dimid ( i_file_id, 'N_PROF', i_obs_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_obs_id, len = iobs ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_dimid ( i_file_id, 'N_LEVELS', i_lev_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_lev_id, len = ilev ), & + & cl_name, __LINE__ ) + IF(ldwp)WRITE(kunit,*) ' No. of data records = ', iobs + IF(ldwp)WRITE(kunit,*) ' No. of levels = ', ilev + IF(ldwp)WRITE(kunit,*) + IF (ilev > imaxlev) THEN + CALL fatal_error( 'Increase imaxlev in obs_prof_io.F90', __LINE__ ) + ENDIF + + !--------------------------------------------------------------------- + ! Allocate arrays + !--------------------------------------------------------------------- + + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 2, iobs, ilev, 0, 1, ldgrid ) + inpfile%cname(1) = 'POTM' + inpfile%cname(2) = 'PSAL' + inpfile%coblong(1) = 'Potential temperature' + inpfile%coblong(2) = 'Practical salinity' + inpfile%cobunit(1) = 'Degrees Celsius' + inpfile%cobunit(2) = 'PSU' + inpfile%cextname(1) = 'TEMP' + inpfile%cextlong(1) = 'Insitu temperature' + inpfile%cextunit(1) = 'Degrees Celsius' + + !--------------------------------------------------------------------- + ! Read the QC atributes + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_qc_t, i_qc_var_id ), & + & cl_name, __LINE__ ) + istart2(1) = 1 + icount2(2) = 1 + icount2(1) = ilev + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + inpfile%ivlqc(jk,ji,1) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_qc_s, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + inpfile%ivlqc(jk,ji,2) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + ! No depth QC in files + DO ji = 1, iobs + DO jk = 1, ilev + inpfile%idqc(jk,ji) = 1 + inpfile%idqcf(:,jk,ji) = 0 + END DO + END DO + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_prof_qc_t, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ivqc(ji,1) = IACHAR( cqc ) - IACHAR( '0' ) + END DO + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_prof_qc_s, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ivqc(ji,2) = IACHAR( cqc ) - IACHAR( '0' ) + END DO +!! CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_juld_qc, i_qc_var_id ), & +!! & cl_name, __LINE__ ) +!! !DO ji = 1,iobs +!! istart1(1) = ji +!! CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & +!! & start = istart1, count = icount1), & +!! & cl_name, __LINE__ ) +!! inpfile%itqc(ji) = IACHAR( cqc ) - IACHAR( '0' ) +!! inpfile%itqcf(:,ji) = 0 +!! END DO + ! Since the flags are not set in the ENACT files we reset them to 0 + inpfile%itqc(:) = 1 + inpfile%itqcf(:,:) = 0 + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_pos_qc, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ipqc(ji) = IACHAR( cqc ) - IACHAR( '0' ) + inpfile%ipqcf(:,ji) = 0 + END DO + DO ji = 1,iobs + inpfile%ioqc(ji) = MIN( inpfile%ivqc(ji,1), inpfile%ivqc(ji,2) ) + END DO + IF ( nf90_inq_varid( i_file_id, cl_fld_qc_flags_profiles, i_qc_flag_id ) == nf90_noerr ) THEN + ALLOCATE( & + & iqc1(iobs) & + & ) + CALL chkerr( nf90_get_var ( i_file_id, i_qc_flag_id, iqc1 ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + inpfile%ioqcf(1,ji) = iqc1(ji) + inpfile%ivqcf(1,ji,:) = iqc1(ji) + inpfile%ioqcf(2,ji) = 0 + inpfile%ivqcf(2,ji,:) = 0 + END DO + DEALLOCATE( & + & iqc1 & + & ) + ELSE + IF(ldwp) WRITE(kunit,*)'No QC profile flags in file' + inpfile%ioqcf(:,:) = 0 + inpfile%ivqcf(:,:,:) = 0 + ENDIF + IF ( nf90_inq_varid( i_file_id, cl_fld_qc_flags_levels, i_qc_flag_id ) == nf90_noerr ) THEN + ALLOCATE( & + & iqc2(ilev,iobs) & + & ) + CALL chkerr( nf90_get_var ( i_file_id, i_qc_flag_id, iqc2 ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + DO jk = 1,ilev + inpfile%ivlqcf(1,jk,ji,:) = iqc2(jk,ji) + inpfile%ivlqcf(2,jk,ji,:) = 0 + END DO + END DO + DEALLOCATE( & + & iqc2 & + & ) + ELSE + IF(ldwp) WRITE(kunit,*)'No QC level flags in file' + inpfile%ivlqcf(:,:,:,:) = 0 + ENDIF + + !--------------------------------------------------------------------- + ! Read the time/position variables + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_juld, i_juld_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_juld_id, inpfile%ptim ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_depth, i_depth_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_depth_id, inpfile%pdep ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_phi, i_phi_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_phi_id, inpfile%pphi ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_lam, i_lam_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_lam_id, inpfile%plam ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_reference_date_time, i_reference_date_time_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_reference_date_time_id, inpfile%cdjuldref ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Read the platform information + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_wmo_inst_type, i_wmo_inst_type_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_wmo_inst_type_id, inpfile%cdtyp ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_pl_num, i_pl_num_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_pl_num_id, inpfile%cdwmo ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Read the variables + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_tp, i_var_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, inpfile%pob(:,:,1) ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_s, i_var_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, inpfile%pob(:,:,2) ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_ti, i_var_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, inpfile%pext(:,:,1) ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Close file + !--------------------------------------------------------------------- + + CALL chkerr( nf90_close( i_file_id ), cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Set file indexes + !--------------------------------------------------------------------- + DO ji = 1, inpfile%nobs + inpfile%kindex(ji) = ji + END DO + + END SUBROUTINE read_enactfile + + SUBROUTINE read_coriofile( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_coriofile ** + !! + !! ** Purpose : Read from file the profile CORIO observations. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! History : + !! ! 09-01 (K. Mogensen) Original based on old versions + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output enactfile structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + INTEGER :: & + & iobs, & + & ilev + !! * Local declarations + INTEGER :: & + & i_file_id, & + & i_obs_id, & + & i_lev_id, & + & i_phi_id, & + & i_lam_id, & + & i_depth_id, & + & i_pres_id, & + & i_var_id, & + & i_pl_num_id, & + & i_format_version_id, & + & i_juld_id, & + & i_data_type_id, & + & i_wmo_inst_type_id, & + & i_qc_var_id, & + & i_dc_ref_id + CHARACTER(LEN=40) :: & + & cl_fld_lam, & + & cl_fld_phi, & + & cl_fld_depth, & + & cl_fld_depth_qc, & + & cl_fld_pres, & + & cl_fld_pres_qc, & + & cl_fld_var_t, & + & cl_fld_var_s, & + & cl_fld_var_ti, & + & cl_fld_var_pos_qc, & + & cl_fld_var_qc_t, & + & cl_fld_var_qc_s, & + & cl_fld_var_prof_qc_t, & + & cl_fld_var_prof_qc_s, & + & cl_fld_dc_ref, & + & cl_fld_juld, & + & cl_fld_pl_num, & + & cl_fld_wmo_inst_type + CHARACTER(LEN=14), PARAMETER :: & + & cl_name = 'read_coriofile' + CHARACTER(LEN=4 ) :: & + & cl_format_version = '' + INTEGER, DIMENSION(1) :: & + & istart1, icount1 + INTEGER, DIMENSION(2) :: & + & istart2, icount2 + CHARACTER(len=imaxlev) :: & + & clqc + CHARACTER(len=1) :: & + & cqc + CHARACTER(len=256) :: & + & cdjulref + INTEGER :: & + & ji, jk + INTEGER :: & + & iformat + LOGICAL :: & + & lsal + REAL(fbdp), DIMENSION(:,:), ALLOCATABLE :: & + & zpres + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & ipresqc + CHARACTER(len=256) :: & + & cerr + !----------------------------------------------------------------------- + ! Initialization + !----------------------------------------------------------------------- + + icount1(1) = 1 + lsal = .TRUE. + + !----------------------------------------------------------------------- + ! Open file + !----------------------------------------------------------------------- + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & + & i_file_id ), cl_name, __LINE__ ) + + !----------------------------------------------------------------------- + ! Check format and set variables accordingly + !----------------------------------------------------------------------- + + IF ( ( nf90_inq_dimid( i_file_id, 'N_PROF', i_obs_id ) == nf90_noerr ) .AND. & + & ( nf90_inq_dimid( i_file_id, 'N_LEVELS', i_lev_id ) == nf90_noerr ) ) THEN + iformat = 1 + ELSEIF ( ( nf90_inq_dimid( i_file_id, 'mN_PROF', i_obs_id ) == nf90_noerr ) .AND. & + & ( nf90_inq_dimid( i_file_id, 'mN_ZLEV', i_lev_id ) == nf90_noerr ) ) THEN + iformat = 2 + ELSE + WRITE(cerr,'(2A)')'Invalid data format in ',cl_name + CALL fatal_error( cerr, __LINE__ ) + ENDIF + IF ( iformat == 1 ) THEN + cl_fld_lam = 'LONGITUDE' + cl_fld_phi = 'LATITUDE' + cl_fld_depth = 'DEPH' + cl_fld_depth_qc = 'DEPH_QC' + cl_fld_pres = 'PRES' + cl_fld_pres_qc = 'PRES_QC' + cl_fld_juld = 'JULD' + cl_fld_wmo_inst_type = 'WMO_INST_TYPE' + cl_fld_dc_ref = 'DC_REFERENCE' + cl_fld_pl_num = 'PLATFORM_NUMBER' + cl_fld_var_qc_t = 'TEMP_QC' + cl_fld_var_prof_qc_t = 'PROFILE_TEMP_QC' + cl_fld_var_t = 'TEMP' + cl_fld_var_qc_s = 'PSAL_QC' + cl_fld_var_prof_qc_s = 'PROFILE_PSAL_QC' + cl_fld_var_s = 'PSAL' + cl_fld_var_pos_qc = 'POSITION_QC' + ELSEIF ( iformat==2 ) THEN + cl_fld_lam = 'LONGITUDE' + cl_fld_phi = 'LATITUDE' + cl_fld_depth = 'DEPH' + cl_fld_depth_qc = 'QC_DEPH' + cl_fld_pres = 'PRES' + cl_fld_pres_qc = 'QC_PRES' + cl_fld_juld = 'JULD' + cl_fld_wmo_inst_type = 'INST_TYPE' + cl_fld_dc_ref = 'REFERENCE' + cl_fld_pl_num = 'PLATFORM_NUMBER' + cl_fld_var_qc_t = 'QC_TEMP' + cl_fld_var_prof_qc_t = 'Q_PROFILE_TEMP' + cl_fld_var_t = 'TEMP' + cl_fld_var_qc_s = 'QC_PSAL' + cl_fld_var_prof_qc_s = 'Q_PROFILE_PSAL' + cl_fld_var_s = 'PSAL' + cl_fld_var_pos_qc = 'Q_POSITION' + ENDIF + + !----------------------------------------------------------------------- + ! Read the heading of the file + !----------------------------------------------------------------------- + + IF(ldwp)WRITE(kunit,*) + IF(ldwp)WRITE(kunit,*) ' read_coriofile :' + IF(ldwp)WRITE(kunit,*) ' ~~~~~~~~~~~~~~~~' + IF(ldwp)WRITE(kunit,*) ' Format version = ', iformat + + !--------------------------------------------------------------------- + ! Read the number of observations and levels to allocate arrays + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inquire_dimension( i_file_id, i_obs_id, len = iobs ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_lev_id, len = ilev ), & + & cl_name, __LINE__ ) + IF(ldwp)WRITE(kunit,*) ' No. of data records = ', iobs + IF(ldwp)WRITE(kunit,*) ' No. of levels = ', ilev + IF(ldwp)WRITE(kunit,*) + IF (ilev > imaxlev) THEN + CALL fatal_error( 'Increase imaxlev in obs_prof_io.F90', __LINE__ ) + ENDIF + + !--------------------------------------------------------------------- + ! Allocate arrays + !--------------------------------------------------------------------- + + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 2, iobs, ilev, 0, 1, ldgrid ) + inpfile%cname(1) = 'POTM' + inpfile%cname(2) = 'PSAL' + inpfile%coblong(1) = 'Potential temperature' + inpfile%coblong(2) = 'Practical salinity' + inpfile%cobunit(1) = 'Degrees Celsius' + inpfile%cobunit(2) = 'PSU' + inpfile%cextname(1) = 'TEMP' + inpfile%cextlong(1) = 'Insitu temperature' + inpfile%cextunit(1) = 'Degrees Celsius' + ALLOCATE( & + & zpres(ilev,iobs), & + & ipresqc(ilev,iobs) & + & ) + !--------------------------------------------------------------------- + ! Get julian data reference (iformat==2) + !--------------------------------------------------------------------- + + IF (iformat==2) THEN + CALL chkerr ( nf90_get_att( i_file_id, nf90_global, & + & "Reference_date_time", cdjulref ), & + & cl_name, __LINE__ ) + inpfile%cdjuldref = cdjulref(7:10)//cdjulref(4:5)// & + & cdjulref(1:2)//cdjulref(12:13)//cdjulref(15:16)//cdjulref(18:19) + ENDIF + + !--------------------------------------------------------------------- + ! Read the QC attributes + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_qc_t, i_qc_var_id ), & + & cl_name, __LINE__ ) + istart2(1) = 1 + icount2(2) = 1 + icount2(1) = ilev + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + inpfile%ivlqc(jk,ji,1) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_s, i_qc_var_id ) == nf90_noerr ) THEN + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + inpfile%ivlqc(jk,ji,2) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + ELSE + inpfile%ivlqc(:,:,2) = 4 + inpfile%pob(:,:,2) = fbrmdi + lsal = .FALSE. + ENDIF + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_prof_qc_t, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ivqc(ji,1) = IACHAR( cqc ) - IACHAR( '0' ) + END DO + IF (lsal) THEN + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_prof_qc_s, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1,iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ivqc(ji,2) = IACHAR( cqc ) - IACHAR( '0' ) + END DO + ELSE + inpfile%ivqc(:,2) = 4 + ENDIF + DO ji = 1,iobs + inpfile%ioqc(ji) = MIN( inpfile%ivqc(ji,1), inpfile%ivqc(ji,2) ) + END DO + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_pos_qc, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1, iobs + istart1(1) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, cqc, & + & start = istart1, count = icount1), & + & cl_name, __LINE__ ) + inpfile%ipqc(ji) = IACHAR( cqc ) - IACHAR( '0' ) + END DO + + !--------------------------------------------------------------------- + ! Read the time/position variables + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_juld, i_juld_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_juld_id, inpfile%ptim ), & + & cl_name, __LINE__ ) + IF (iformat==1) THEN + CALL chkerr ( nf90_get_att( i_file_id, i_juld_id, & + & "units", cdjulref ), & + & cl_name, __LINE__ ) + inpfile%cdjuldref = cdjulref(12:15)//cdjulref(17:18)// & + & cdjulref(20:21)//cdjulref(23:24)//cdjulref(26:27)//& + & cdjulref(29:30) + ENDIF + + IF ( nf90_inq_varid( i_file_id, cl_fld_depth, i_depth_id ) == nf90_noerr ) THEN + CALL chkerr( nf90_get_var ( i_file_id, i_depth_id, inpfile%pdep ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_depth_qc, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + inpfile%idqc(jk,ji) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + ELSE + inpfile%pdep(:,:) = fbrmdi + inpfile%idqc(:,:) = 4 + ENDIF + + IF ( nf90_inq_varid( i_file_id, cl_fld_pres, i_pres_id ) == nf90_noerr ) THEN + CALL chkerr( nf90_get_var ( i_file_id, i_pres_id, zpres ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_pres_qc, i_qc_var_id ), & + & cl_name, __LINE__ ) + DO ji = 1, iobs + istart2(2) = ji + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, clqc, & + & start = istart2, count = icount2), & + & cl_name, __LINE__ ) + DO jk = 1, ilev + ipresqc(jk,ji) = IACHAR( clqc(jk:jk) ) - IACHAR( '0' ) + END DO + END DO + ELSE + zpres(:,:) = fbrmdi + ipresqc(:,:) = 4 + ENDIF + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_phi, i_phi_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_phi_id, inpfile%pphi ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_lam, i_lam_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_lam_id, inpfile%plam ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Read the platform information + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_wmo_inst_type, i_wmo_inst_type_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_wmo_inst_type_id, inpfile%cdtyp ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_pl_num, i_pl_num_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_pl_num_id, inpfile%cdwmo ), & + & cl_name, __LINE__ ) + + + !--------------------------------------------------------------------- + ! Read the variables + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_t, i_var_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, inpfile%pext(:,:,1) ), & + & cl_name, __LINE__ ) + + IF (lsal) THEN + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_s, i_var_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, inpfile%pob(:,:,2) ), & + & cl_name, __LINE__ ) + ENDIF + + !--------------------------------------------------------------------- + ! Close file + !--------------------------------------------------------------------- + + CALL chkerr( nf90_close( i_file_id ), cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Set file indexes + !--------------------------------------------------------------------- + DO ji = 1, inpfile%nobs + inpfile%kindex(ji) = ji + END DO + + !--------------------------------------------------------------------- + ! Coriolis data conversion from insitu to potential temperature + !--------------------------------------------------------------------- + !--------------------------------------------------------------------- + ! Convert pressure to depth if depth not present + !--------------------------------------------------------------------- + DO ji = 1, inpfile%nobs + IF ( inpfile%pphi(ji) < 9999.0 ) THEN + DO jk = 1, inpfile%nlev + IF ( inpfile%pdep(jk,ji) >= 9999.0 ) THEN + IF ( zpres(jk,ji) < 9999.0 ) THEN + inpfile%pdep(jk,ji) = & + & p_to_dep( REAL(zpres(jk,ji),wp), REAL(inpfile%pphi(ji),wp) ) + inpfile%idqc(jk,ji) = ipresqc(jk,ji) + ENDIF + ENDIF + END DO + ENDIF + END DO + + !--------------------------------------------------------------------- + ! Convert depth to pressure if pressure not present + !--------------------------------------------------------------------- + DO ji = 1, inpfile%nobs + IF ( inpfile%pphi(ji) < 9999.0 ) THEN + DO jk = 1, inpfile%nlev + IF ( zpres(jk,ji) >= 9999.0 ) THEN + IF ( inpfile%pdep(jk,ji) < 9999.0 ) THEN + zpres(jk,ji) = dep_to_p( REAL(inpfile%pdep(jk,ji),wp), & + & REAL(inpfile%pphi(ji),wp) ) + ipresqc(jk,ji) = inpfile%idqc(jk,ji) + ENDIF + ENDIF + END DO + ENDIF + END DO + + !--------------------------------------------------------------------- + ! Convert insitu temperature to potential temperature if + ! salinity, insitu temperature and pressure are present + !--------------------------------------------------------------------- + DO ji = 1, inpfile%nobs + DO jk = 1, inpfile%nlev + IF (( inpfile%pob(jk,ji,2) < 9999.0 ) .AND. & + &( inpfile%pext(jk,ji,1) < 9999.0 ) .AND. & + &( zpres(jk,ji) < 9999.0 ) ) THEN + inpfile%pob(jk,ji,1) = potemp( REAL(inpfile%pob(jk,ji,2), wp), & + & REAL(inpfile%pext(jk,ji,1), wp), & + & REAL(zpres(jk,ji),wp), & + & 0.0_wp ) + ELSE + inpfile%pob(jk,ji,1) = fbrmdi + ENDIF + END DO + END DO + + !--------------------------------------------------------------------- + ! Initialize flags since they are not in the CORIOLIS input files + !--------------------------------------------------------------------- + + inpfile%ioqcf(:,:) = 0 + inpfile%ipqcf(:,:) = 0 + inpfile%itqcf(:,:) = 0 + inpfile%idqcf(:,:,:) = 0 + inpfile%ivqcf(:,:,:) = 0 + inpfile%ivlqcf(:,:,:,:) = 0 + + END SUBROUTINE read_coriofile diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obsseaice_io.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsseaice_io.h90 new file mode 100644 index 0000000000000000000000000000000000000000..48bb8a48acfccb603d376370ffb66e9210a6cec3 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsseaice_io.h90 @@ -0,0 +1,270 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsseaice_io.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE read_seaice( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_seaice ** + !! + !! ** Purpose : Read from file the SEAICE observations. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 09-01 (K. Mogensen) Original based on old versions + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output obfbdata structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + !! * Local declarations + CHARACTER(LEN=12),PARAMETER :: cpname = 'read_seaice' + INTEGER :: i_file_id ! netcdf IDS + INTEGER :: i_time_id + INTEGER :: i_ni_id + INTEGER :: i_data_id + INTEGER :: i_var_id + INTEGER :: i_data ! Number of data per parameter in current file + INTEGER :: i_time ! Number of reference times in file + INTEGER, DIMENSION(:), POINTER :: & + & i_reftime ! Reference time in file in seconds since 1/1/1981. + INTEGER, DIMENSION(:,:), POINTER :: & + & i_dtime, & ! Offset in seconds since reference time + & i_qc, & ! Quality control flag. + & i_type ! Type of seaice measurement. + REAL(wp), DIMENSION(:), POINTER :: & + & z_phi, & ! Latitudes + & z_lam ! Longitudes + REAL(wp), DIMENSION(:,:), POINTER :: & + & z_seaice ! Seaice data + INTEGER, PARAMETER :: imaxdim = 2 ! Assumed maximum for no. dims. in file + INTEGER, DIMENSION(2) :: idims ! Dimensions in file + INTEGER :: iilen ! Length of netCDF attributes + INTEGER :: itype ! Typeof netCDF attributes + REAL(KIND=wp) :: zsca ! Scale factor + REAL(KIND=wp) :: zoff ! Offset for data in netcdf file + REAL(KIND=wp) :: z_offset ! Offset for time conversion + REAL(KIND=wp) :: zfill ! Fill value in netcdf file + CHARACTER (len=33) ::creftime ! Reference time of file + INTEGER :: i_refyear ! Integer version of reference time + INTEGER :: i_refmonth + INTEGER :: i_refday + INTEGER :: i_refhour + INTEGER :: i_refmin + INTEGER :: i_refsec + INTEGER :: ichunk + INTEGER :: jtim + INTEGER :: jobs + INTEGER :: iobs + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & + & i_file_id, chunksize=ichunk), cpname, __LINE__ ) + + ! Get the netCDF dimensions + + CALL chkerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_time_id, & + & len = i_time ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid( i_file_id, 'ni', i_ni_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_ni_id, & + & len = i_data ), & + & cpname, __LINE__ ) + + + ! Allocate NetCDF variables + + ALLOCATE( & + & i_reftime ( i_time ), & + & i_dtime ( i_data,i_time ), & + & i_qc ( i_data,i_time ), & + & i_type ( i_data,i_time ), & + & z_phi ( i_data ), & + & z_lam ( i_data ), & + & z_seaice ( i_data,i_time ) & + & ) + + ! Get reference time of file which is in seconds since 1981/1/1 00:00. + + CALL chkerr( nf90_inq_varid( i_file_id, 'time', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_time + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_reftime),& + & cpname, __LINE__ ) + IF (nf90_inquire_attribute( i_file_id, i_var_id, "units") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "units",creftime), cpname, __LINE__ ) + ELSE + creftime = "seconds since 1981-01-01 00:00:00" + ENDIF + READ(creftime(15:18),*)i_refyear + READ(creftime(20:21),*)i_refmonth + READ(creftime(23:24),*)i_refday + READ(creftime(26:27),*)i_refhour + READ(creftime(29:30),*)i_refmin + READ(creftime(32:33),*)i_refsec + !Work out offset in days between reference time and 1/1/1950. + CALL greg2jul( i_refsec, i_refmin, i_refhour, i_refday, & + & i_refmonth, i_refyear, z_offset) + + ! Get list of times for each ob in seconds relative to reference time + + CALL chkerr( nf90_inq_varid( i_file_id, 'SeaIce_dtime', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_dtime),& + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zoff = 0.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "add_offset") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "add_offset",zoff), cpname, __LINE__ ) + ENDIF + i_dtime(:,:) = NINT((zsca * FLOAT(i_dtime(:,:))) & + & + zoff) + + ! Get longitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'lon', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_lam), & + & cpname, __LINE__ ) + + ! Get latitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'lat', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_phi), & + & cpname, __LINE__ ) + + ! Get seaice data + + CALL chkerr( nf90_inq_varid( i_file_id, 'sea_ice_concentration', & + & i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_seaice), & + & cpname, __LINE__ ) + zoff = 0. + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zfill = 0.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "_FillValue") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "_FillValue",zfill), cpname, __LINE__ ) + ENDIF + WHERE(z_seaice(:,:) /= zfill) + z_seaice(:,:) = (zsca * z_seaice(:,:)) + zoff + ELSEWHERE + z_seaice(:,:) = fbrmdi + END WHERE + + ! Get QC flag + + CALL chkerr( nf90_inq_varid( i_file_id, 'confidence_flag', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_qc), & + & cpname, __LINE__ ) + + ! Get seaice obs type + + i_type(:,:)=1 + + ! Close the file + + CALL chkerr( nf90_close( i_file_id ), cpname, __LINE__ ) + + ! Fill the obfbdata structure + + ! Allocate obfbdata + + iobs = i_data * i_time + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 1, iobs, 1, 0, 0, ldgrid ) + inpfile%cname(1) = 'SEAICE' + + ! Fill the obfbdata structure from input data + + inpfile%cdjuldref = "19500101000000" + iobs = 0 + DO jtim = 1, i_time + DO jobs = 1, i_data + iobs = iobs + 1 + ! Characters + WRITE(inpfile%cdwmo(iobs),'(A6,A2)') 'seaice',' ' + WRITE(inpfile%cdtyp(iobs),'(I4)') i_type(jobs,jtim) + ! Real values + inpfile%plam(iobs) = z_lam(jobs) + inpfile%pphi(iobs) = z_phi(jobs) + inpfile%pob(1,iobs,1) = z_seaice(jobs,jtim) + inpfile%ptim(iobs) = & + & REAL(i_reftime(jtim))/(60.*60.*24.) + & + & z_offset + REAL(i_dtime(jobs,jtim))/(60.*60.*24.) + inpfile%pdep(1,iobs) = 0.0 + ! Integers + inpfile%kindex(iobs) = iobs + IF ( z_seaice(jobs,jtim) == fbrmdi ) THEN + inpfile%ioqc(iobs) = 4 + inpfile%ivqc(iobs,1) = 4 + inpfile%ivlqc(1,iobs,1) = 4 + ELSE + inpfile%ioqc(iobs) = i_qc(jobs,jtim) + inpfile%ivqc(iobs,1) = i_qc(jobs,jtim) + inpfile%ivlqc(1,iobs,1) = 1 + ENDIF + inpfile%ipqc(iobs) = 0 + inpfile%ipqcf(:,iobs) = 0 + inpfile%itqc(iobs) = 0 + inpfile%itqcf(:,iobs) = 0 + inpfile%ivqcf(:,iobs,1) = 0 + inpfile%ioqcf(:,iobs) = 0 + inpfile%idqc(1,iobs) = 0 + inpfile%idqcf(1,1,iobs) = 0 + inpfile%ivlqcf(:,1,iobs,1) = 0 + END DO + END DO + + END SUBROUTINE read_seaice + + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_io.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_io.h90 new file mode 100644 index 0000000000000000000000000000000000000000..0403acc320d5878d9e59a0c148b82a32dbbc443d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_io.h90 @@ -0,0 +1,378 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obssla_io.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE read_avisofile( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_avisofile ** + !! + !! ** Purpose : Read from file the AVISO SLA observations. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! References : http://www.aviso.oceanobs.com + !! + !! History : + !! ! 09-01 (K. Mogensen) Original based on old versions + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output obfbdata structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + !! * Local declarations + CHARACTER(LEN=14),PARAMETER :: cpname = 'read_avisofile' + INTEGER :: i_file_id ! netcdf IDS + INTEGER :: i_tracks_id + INTEGER :: i_cycles_id + INTEGER :: i_data_id + INTEGER :: i_var_id + INTEGER, PARAMETER :: imaxdim = 2 ! Assumed maximum for no. dims. in file + INTEGER, DIMENSION(2) :: idims ! Dimensions in file + INTEGER :: iilen ! Length of netCDF attributes + INTEGER :: itype ! Typeof netCDF attributes + REAL(fbdp) :: zsca ! Scale factor + REAL(fbdp) :: zfill ! Fill value + CHARACTER(len=3) :: cmission ! Mission global attribute + INTEGER :: itracks ! Maximum number of passes in file + INTEGER :: icycles ! Maximum number of cycles for each pass + INTEGER :: idata ! Number of data per parameter in current file + REAL(fbdp) :: zdeltat ! Time gap getween two measurements in seconds + INTEGER, DIMENSION(:), POINTER :: & + & iptracks, & ! List of passes contained in current file + & ipnbpoints, & ! Number of points per pass + & ipdataindexes ! Index of data in theoretical profile + INTEGER, DIMENSION(:,:), POINTER :: & + & ipcycles ! List of cycles per pass + REAL(fbdp), DIMENSION(:), POINTER :: & + & zphi, & ! Latitudes + & zlam ! Longitudes + REAL(fbdp), DIMENSION(:,:), POINTER :: & + & zbegindates ! Date of point with index 0 + REAL(fbdp) :: zbeginmiss ! Missing data for dates + REAL(fbsp), DIMENSION(:,:), POINTER :: & + & zsla ! SLA data + REAL(fbdp), DIMENSION(:), POINTER :: & + & zjuld ! Julian date + LOGICAL, DIMENSION(:), POINTER :: & + & llskip ! Skip observation + CHARACTER(len=14) :: cdjuldref ! Julian data reference + INTEGER :: imission ! Mission number converted from Mission global + ! netCDF atttribute. + CHARACTER(len=255) :: ctmp + INTEGER :: iobs + INTEGER :: jl + INTEGER :: jm + INTEGER :: jj + INTEGER :: ji + INTEGER :: jk + INTEGER :: jobs + INTEGER :: jcycle + + ! Open the file + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, i_file_id ), & + & cpname, __LINE__ ) + + ! Get the netCDF dimensions + + CALL chkerr( nf90_inq_dimid( i_file_id, 'Tracks', i_tracks_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_tracks_id, & + & len = itracks ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid( i_file_id, 'Cycles', i_cycles_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_cycles_id, & + & len = icycles ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid( i_file_id, 'Data', i_data_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_data_id, & + & len = idata ), & + & cpname, __LINE__ ) + + ! Allocate memory for input data + + ALLOCATE( & + & iptracks ( itracks ), & + & ipnbpoints ( itracks ), & + & ipcycles ( icycles, itracks ), & + & zphi ( idata ), & + & zlam ( idata ), & + & zbegindates ( icycles, itracks ), & + & ipdataindexes( idata ), & + & zsla ( icycles, idata ), & + & zjuld ( idata*icycles ), & + & llskip ( idata*icycles ) & + & ) + + ! Get time gap getween two measurements in seconds + + CALL chkerr( nf90_inq_varid( i_file_id, 'DeltaT', i_var_id ), & + & cpname, __LINE__ ) + CALL chkdim( i_file_id, i_var_id, 0, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zdeltat), & + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, 'scale_factor') & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & 'scale_factor',zsca), cpname, __LINE__) + ENDIF + zdeltat = zsca * zdeltat + + ! Get List of passes contained in current file + + CALL chkerr( nf90_inq_varid( i_file_id, 'Tracks', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = itracks + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, iptracks), & + & cpname, __LINE__ ) + + ! Get Number of points per pass + + CALL chkerr( nf90_inq_varid( i_file_id, 'NbPoints', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = itracks + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, ipnbpoints),& + & cpname, __LINE__ ) + + ! Get list of cycles per pass + + CALL chkerr( nf90_inq_varid( i_file_id, 'Cycles', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = icycles + idims(2) = itracks + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, ipcycles), & + & cpname, __LINE__ ) + + ! Get longitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'Longitudes', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = idata + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zlam), & + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, 'scale_factor') & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & 'scale_factor',zsca), cpname, __LINE__) + ENDIF + zlam(:) = zsca * zlam(:) + + ! Get latitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'Latitudes', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = idata + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zphi), & + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, 'scale_factor') & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & 'scale_factor',zsca), cpname, __LINE__) + ENDIF + zphi(:) = zsca * zphi(:) + + ! Get date of point with index 0 + + CALL chkerr( nf90_inq_varid( i_file_id, 'BeginDates', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = icycles + idims(2) = itracks + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zbegindates), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_attribute( i_file_id, i_var_id, & + & 'units', len = iilen, & + & xtype = itype), cpname, __LINE__ ) + IF (( itype /= NF90_CHAR ) .OR. ( iilen > 255 )) THEN + CALL fatal_error('Error decoding BeginDates unit', __LINE__ ) + ENDIF + CALL chkerr( nf90_get_att( i_file_id, i_var_id, 'units', & + & ctmp ), cpname, __LINE__ ) + jl=1 + DO jm = 1, LEN(TRIM(ctmp)) + IF ((ctmp(jm:jm)>='0').AND.(ctmp(jm:jm)<='9')) THEN + cdjuldref(jl:jl) = ctmp(jm:jm) + jl=jl+1 + ENDIF + IF (jl>14) EXIT + END DO + CALL chkerr( nf90_inquire_attribute( i_file_id, i_var_id, '_FillValue', & + & xtype = itype), cpname, __LINE__ ) + IF ( itype /= NF90_DOUBLE ) THEN + CALL fatal_error('Error decoding BeginDates missing data', __LINE__ ) + ENDIF + CALL chkerr( nf90_get_att( i_file_id, i_var_id, '_FillValue', & + & zbeginmiss ), cpname, __LINE__ ) + + ! Get indices of data in theoretical profile + + CALL chkerr( nf90_inq_varid( i_file_id, 'DataIndexes', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = idata + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, ipdataindexes), & + & cpname, __LINE__ ) + + ! Get SLA data + + CALL chkerr( nf90_inq_varid( i_file_id, 'SLA', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = icycles + idims(2) = idata + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zsla), & + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, 'scale_factor') & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & 'scale_factor',zsca), cpname, __LINE__ ) + ENDIF + zfill = 0.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, '_FillValue') & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & '_FillValue',zfill), cpname, __LINE__ ) + ENDIF + WHERE(zsla(:,:) /= zfill) + zsla(:,:) = zsca * zsla(:,:) + ELSEWHERE + zsla(:,:) = fbrmdi + END WHERE + + ! Get the global Mission netCDF attribute + + cmission=' ' + CALL chkerr( nf90_inquire_attribute( i_file_id, nf90_global, & + & 'Mission', len = iilen, & + & xtype = itype), cpname, __LINE__ ) + IF (( itype /= NF90_CHAR ) .OR. ( iilen > 3 )) THEN + CALL fatal_error('Error decoding Mission global attribute', __LINE__ ) + ENDIF + CALL chkerr( nf90_get_att( i_file_id, nf90_global, 'Mission', & + & cmission ), cpname, __LINE__ ) + + ! Convert it to an integer + imission = 0 + DO jm = 1, imaxmissions + IF (cmission==cmissions(jm)) THEN + imission = jm + EXIT + ENDIF + END DO + + ! Close the file + + CALL chkerr( nf90_close( i_file_id ), cpname, __LINE__ ) + + ! Compute Julian dates for all observations + + jm = 0 + jl = 0 + DO jj = 1, itracks + DO ji = 1, ipnbpoints(jj) + jl = jl + 1 + DO jk = 1, icycles + jm = jm + 1 + IF (zbegindates(jk,jj)==zbeginmiss) THEN + llskip(jm) = .TRUE. + zjuld(jm) = fbrmdi + ELSE + llskip(jm) = .FALSE. + zjuld(jm) = zbegindates(jk,jj) + & + & (ipdataindexes(jl) * zdeltat / 86400._wp ) + ENDIF + END DO + END DO + END DO + + ! Get rid of missing data + + jm = 0 + DO jobs = 1, idata + DO jcycle = 1, icycles + jm = jm + 1 + IF (zsla(jcycle,jobs) == fbrmdi) llskip(jm) = .TRUE. + END DO + END DO + + ! Allocate obfbdata + + iobs = COUNT( .NOT.llskip(:) ) + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 1, iobs, 1, 0, 0, ldgrid ) + inpfile%cname(1) = 'SLA' + + ! Fill the obfbdata structure from input data + + inpfile%cdjuldref = cdjuldref + iobs = 0 + jm = 0 + DO jobs = 1, idata + DO jcycle = 1, icycles + jm = jm + 1 + IF (llskip(jm)) CYCLE + iobs = iobs + 1 + ! Characters + WRITE(inpfile%cdwmo(iobs),'(A3,A5)') cmissions(imission), ' ' + WRITE(inpfile%cdtyp(iobs),'(I4)') imission + ! Real values + inpfile%plam(iobs) = zlam(jobs) + inpfile%pphi(iobs) = zphi(jobs) + inpfile%pob(1,iobs,1) = zsla(jcycle,jobs) + inpfile%ptim(iobs) = zjuld(jm) + inpfile%pdep(1,iobs) = 0.0 + ! Integers + inpfile%kindex(iobs) = iobs + inpfile%ioqc(iobs) = 1 + inpfile%ivqc(iobs,1) = 1 + inpfile%ivlqc(1,iobs,1) = 1 + inpfile%ipqc(iobs) = 0 + inpfile%ipqcf(:,iobs) = 0 + inpfile%itqc(iobs) = 0 + inpfile%itqcf(:,iobs) = 0 + inpfile%ivqcf(:,iobs,1) = 0 + inpfile%ioqcf(:,iobs) = 0 + inpfile%idqc(1,iobs) = 0 + inpfile%idqcf(1,1,iobs) = 0 + inpfile%ivlqcf(:,1,iobs,1) = 0 + END DO + END DO + + + ! Deallocate memory for input data + + DEALLOCATE( & + & iptracks, & + & ipnbpoints, & + & ipcycles, & + & zphi, & + & zlam, & + & zbegindates, & + & ipdataindexes, & + & zsla, & + & zjuld, & + & llskip & + & ) + + END SUBROUTINE read_avisofile + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_types.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_types.h90 new file mode 100644 index 0000000000000000000000000000000000000000..a57f1f723c1116fb59ee3acf62fcc4f471906151 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssla_types.h90 @@ -0,0 +1,25 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obssla_types.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !! History : + !! ! 2016-04 (H. Zuo) updated satellite type list to the latest + !! AVISO v5 version + !! ! 2016-09 (H. Zuo) updated to include J3 and J2N type + !! ! 2017-05 (H. Zuo) updated to include Sentinel-3A + !! ! 2018-09 (H. Zuo) updated to include ALG and H2G + !! ! 2019-06 (H. Zuo) updated to include J2G and S3B + !! ! 2019-10 (H. Zuo) updated to include e1g + !! ! 2020-06 (H. Zuo) updated to include h2b + !! ! 2020-11 (H. Zuo) updated to include c2n + !! ! 2022-04 (H. Zuo) updated to include s6a + !! ! 2022-06 (E. de Boisseson) updated to + !! DT2021 naming (H2A/H2AG) + !!---------------------------------------------------------------------- + + INTEGER, PARAMETER :: imaxmissions=27 + CHARACTER(len=4) :: cmissions(0:imaxmissions) = & + & (/ 'XXX ', 'E1 ', 'E2 ', 'TP ', 'TPN ', 'G2 ', 'J1 ', & + & 'EN ', 'J2 ','J1N ','J1G ','ENN ','AL ','C2 ','H2 ', & + & 'J3 ', 'J2N ','S3A ', 'ALG ','H2G ','J2G ','S3B ','E1G ', & + & 'H2B ','C2N ','S6A ','H2A ','H2AG'/) diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obssst_io.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssst_io.h90 new file mode 100644 index 0000000000000000000000000000000000000000..5c16891f964f56d27f9ba3830ec234b661c03a16 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obssst_io.h90 @@ -0,0 +1,286 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obssst_io.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE read_ghrsst( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_ghrsst ** + !! + !! ** Purpose : Read from file the GHRSST observations. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 09-01 (K. Mogensen) Original based on old versions + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output obfbdata structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + !! * Local declarations + CHARACTER(LEN=12),PARAMETER :: cpname = 'read_ghrsst' + INTEGER :: i_file_id ! netcdf IDS + INTEGER :: i_time_id + INTEGER :: i_ni_id + INTEGER :: i_data_id + INTEGER :: i_var_id + INTEGER :: i_data ! Number of data per parameter in current file + INTEGER :: i_time ! Number of reference times in file + INTEGER, DIMENSION(:), POINTER :: & + & i_reftime ! Reference time in file in seconds since 1/1/1981. + INTEGER, DIMENSION(:,:), POINTER :: & + & i_dtime, & ! Offset in seconds since reference time + & i_qc, & ! Quality control flag. + & i_type ! Type of SST measurement. + REAL(wp), DIMENSION(:), POINTER :: & + & z_phi, & ! Latitudes + & z_lam ! Longitudes + REAL(wp), DIMENSION(:,:), POINTER :: & + & z_sst ! SST data + INTEGER, PARAMETER :: imaxdim = 2 ! Assumed maximum for no. dims. in file + INTEGER, DIMENSION(2) :: idims ! Dimensions in file + INTEGER :: iilen ! Length of netCDF attributes + INTEGER :: itype ! Typeof netCDF attributes + REAL(KIND=wp) :: zsca ! Scale factor + REAL(KIND=wp) :: zoff ! Offset for data in netcdf file + REAL(KIND=dp) :: z_offset ! Offset for time conversion + REAL(KIND=wp) :: zfill ! Fill value in netcdf file + CHARACTER (len=33) :: creftime ! Reference time of file + INTEGER :: i_refyear ! Integer version of reference time + INTEGER :: i_refmonth + INTEGER :: i_refday + INTEGER :: i_refhour + INTEGER :: i_refmin + INTEGER :: i_refsec + INTEGER :: ichunk + INTEGER :: jtim + INTEGER :: jobs + INTEGER :: iobs + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & + & i_file_id, chunksize=ichunk), cpname, __LINE__ ) + + ! Get the netCDF dimensions + + CALL chkerr( nf90_inq_dimid( i_file_id, 'time', i_time_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_time_id, & + & len = i_time ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid( i_file_id, 'ni', i_ni_id ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_ni_id, & + & len = i_data ), & + & cpname, __LINE__ ) + + + ! Allocate NetCDF variables + + ALLOCATE( & + & i_reftime ( i_time ), & + & i_dtime ( i_data,i_time ), & + & i_qc ( i_data,i_time ), & + & i_type ( i_data,i_time ), & + & z_phi ( i_data ), & + & z_lam ( i_data ), & + & z_sst ( i_data,i_time ) & + & ) + + ! Get reference time of file which is in seconds since 1981/1/1 00:00. + + CALL chkerr( nf90_inq_varid( i_file_id, 'time', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_time + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_reftime),& + & cpname, __LINE__ ) + IF (nf90_inquire_attribute( i_file_id, i_var_id, "units") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "units",creftime), cpname, __LINE__ ) + ELSE + creftime = "seconds since 1981-01-01 00:00:00" + ENDIF + READ(creftime(15:18),*)i_refyear + READ(creftime(20:21),*)i_refmonth + READ(creftime(23:24),*)i_refday + READ(creftime(26:27),*)i_refhour + READ(creftime(29:30),*)i_refmin + READ(creftime(32:33),*)i_refsec + !Work out offset in days between reference time and 1/1/1950. + CALL greg2jul( i_refsec, i_refmin, i_refhour, i_refday, & + & i_refmonth, i_refyear, z_offset) + + ! Get list of times for each ob in seconds relative to reference time + + CALL chkerr( nf90_inq_varid( i_file_id, 'sst_dtime', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_dtime),& + & cpname, __LINE__ ) + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zoff = 0.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "add_offset") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "add_offset",zoff), cpname, __LINE__ ) + ENDIF + i_dtime(:,:) = NINT((zsca * FLOAT(i_dtime(:,:))) & + & + zoff) + + ! Get longitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'lon', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_lam), & + & cpname, __LINE__ ) + + ! Get latitudes + + CALL chkerr( nf90_inq_varid( i_file_id, 'lat', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + CALL chkdim( i_file_id, i_var_id, 1, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_phi), & + & cpname, __LINE__ ) + + ! Get SST data + + CALL chkerr( nf90_inq_varid( i_file_id, 'sea_surface_temperature', & + & i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, z_sst), & + & cpname, __LINE__ ) + zoff = 0. + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zsca = 1.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "scale_factor") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "scale_factor",zsca), cpname, __LINE__ ) + ENDIF + zfill = 0.0 + IF (nf90_inquire_attribute( i_file_id, i_var_id, "_FillValue") & + & == nf90_noerr) THEN + CALL chkerr( nf90_get_att( i_file_id, i_var_id, & + & "_FillValue",zfill), cpname, __LINE__ ) + ENDIF + WHERE(z_sst(:,:) /= zfill) + z_sst(:,:) = (zsca * z_sst(:,:)) + zoff + ELSEWHERE + z_sst(:,:) = fbrmdi + END WHERE + + ! Get QC flag + + CALL chkerr( nf90_inq_varid( i_file_id, 'confidence_flag', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_qc), & + & cpname, __LINE__ ) + + ! Get SST obs type + + CALL chkerr( nf90_inq_varid( i_file_id, 'data_source', i_var_id ), & + & cpname, __LINE__ ) + idims(1) = i_data + idims(2) = i_time + CALL chkdim( i_file_id, i_var_id, 2, idims, cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, i_type), & + & cpname, __LINE__ ) + + ! Close the file + + CALL chkerr( nf90_close( i_file_id ), cpname, __LINE__ ) + + ! Fill the obfbdata structure + + ! Allocate obfbdata + + iobs = i_data * i_time + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 1, iobs, 1, 0, 0, ldgrid ) + inpfile%cname(1) = 'SST' + + ! Fill the obfbdata structure from input data + + inpfile%cdjuldref = "19500101000000" + iobs = 0 + DO jtim = 1, i_time + DO jobs = 1, i_data + iobs = iobs + 1 + ! Characters + WRITE(inpfile%cdwmo(iobs),'(A6,A2)') 'ghrsst',' ' + WRITE(inpfile%cdtyp(iobs),'(I4)') i_type(jobs,jtim) + ! Real values + inpfile%plam(iobs) = z_lam(jobs) + inpfile%pphi(iobs) = z_phi(jobs) + inpfile%pob(1,iobs,1) = z_sst(jobs,jtim) + inpfile%ptim(iobs) = & + & REAL(i_reftime(jtim))/(60.*60.*24.) + & + & z_offset + REAL(i_dtime(jobs,jtim))/(60.*60.*24.) + inpfile%pdep(1,iobs) = 0.0 + ! Integers + inpfile%kindex(iobs) = iobs + IF ( z_sst(jobs,jtim) == fbrmdi ) THEN + inpfile%ioqc(iobs) = 4 + inpfile%ivqc(iobs,1) = 4 + inpfile%ivlqc(1,iobs,1) = 4 + ELSE + inpfile%ioqc(iobs) = i_qc(jobs,jtim) + inpfile%ivqc(iobs,1) = i_qc(jobs,jtim) + inpfile%ivlqc(1,iobs,1) = 1 + ENDIF + inpfile%ipqc(iobs) = 0 + inpfile%ipqcf(:,iobs) = 0 + inpfile%itqc(iobs) = 0 + inpfile%itqcf(:,iobs) = 0 + inpfile%ivqcf(:,iobs,1) = 0 + inpfile%ioqcf(:,iobs) = 0 + inpfile%idqc(1,iobs) = 0 + inpfile%idqcf(1,1,iobs) = 0 + inpfile%ivlqcf(:,1,iobs,1) = 0 + END DO + END DO + + DEALLOCATE( & + & i_reftime, & + & i_dtime, & + & i_qc, & + & i_type, & + & z_phi, & + & z_lam, & + & z_sst & + & ) + + END SUBROUTINE read_ghrsst + + diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/obsvel_io.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsvel_io.h90 new file mode 100644 index 0000000000000000000000000000000000000000..4a5b19c5f409ff3095b6d4151632edb845194207 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/obsvel_io.h90 @@ -0,0 +1,360 @@ + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.3 , NEMO Consortium (2010) + !! $Id: obsvel_io.h90 2287 2010-10-18 07:53:52Z smasson $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- + + SUBROUTINE read_taondbc( cdfilename, inpfile, kunit, ldwp, ldgrid ) + !!--------------------------------------------------------------------- + !! + !! ** ROUTINE read_enactfile ** + !! + !! ** Purpose : Read from file the TAO data fro NDBC. + !! + !! ** Method : The data file is a NetCDF file. + !! + !! ** Action : + !! + !! ** Reference : http://tao.noaa.gov/tao/data_deliv/deliv_ndbc.shtml + !! History : + !! ! 09-01 (K. Mogensen) Original version. + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: inpfile ! Output obfbdata structure + INTEGER :: kunit ! Unit for output + LOGICAL :: ldwp ! Print info + LOGICAL :: ldgrid ! Save grid info in data structure + !! * Local declarations + INTEGER :: iobs ! Number of observations + INTEGER :: ilev ! Number of levels + INTEGER :: ilat ! Number of latitudes + INTEGER :: ilon ! Number of longtudes + INTEGER :: itim ! Number of obs. times + INTEGER :: i_file_id + INTEGER :: i_dimid_id + INTEGER :: i_phi_id + INTEGER :: i_lam_id + INTEGER :: i_depth_id + INTEGER :: i_var_id + INTEGER :: i_time_id + INTEGER :: i_time2_id + INTEGER :: i_qc_var_id + CHARACTER(LEN=40) :: cl_fld_lam + CHARACTER(LEN=40) :: cl_fld_phi + CHARACTER(LEN=40) :: cl_fld_depth + CHARACTER(LEN=40) :: cl_fld_var_u + CHARACTER(LEN=40) :: cl_fld_var_v + CHARACTER(LEN=40) :: cl_fld_var_qc_uv1 + CHARACTER(LEN=40) :: cl_fld_var_qc_uv2 + CHARACTER(LEN=40) :: cl_fld_time + CHARACTER(LEN=40) :: cl_fld_time2 + INTEGER :: ja + INTEGER :: jo + INTEGER :: jk + INTEGER :: jt + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: & + & zv, & + & zu, & + & zuv1qc, & + & zuv2qc + REAL(wp), ALLOCATABLE, DIMENSION(:) :: & + & zdep, & + & zlat, & + & zlon, & + & zjuld + REAL(wp) :: zl + INTEGER, ALLOCATABLE, DIMENSION(:) :: & + & itime, & + & itime2 + CHARACTER(LEN=50) :: cdjulref + CHARACTER(LEN=12), PARAMETER :: cl_name = 'read_taondbc' + CHARACTER(len=1) :: cns, cew + + !----------------------------------------------------------------------- + ! Initialization + !----------------------------------------------------------------------- + cl_fld_lam = 'lon' + cl_fld_phi = 'lat' + cl_fld_depth = 'depth' + cl_fld_time = 'time' + cl_fld_time2 = 'time2' + + !----------------------------------------------------------------------- + ! Open file + !----------------------------------------------------------------------- + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & + & i_file_id ), cl_name, __LINE__ ) + + !----------------------------------------------------------------------- + ! Read the heading of the file + !----------------------------------------------------------------------- + IF(ldwp) WRITE(kunit,*) + IF(ldwp) WRITE(kunit,*) ' read_taondbc :' + IF(ldwp) WRITE(kunit,*) ' ~~~~~~~~~~~~' + + !--------------------------------------------------------------------- + ! Read the number of observations and of levels to allocate array + !--------------------------------------------------------------------- + CALL chkerr( nf90_inq_dimid ( i_file_id, 'time', i_dimid_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = itim ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_dimid ( i_file_id, 'depth', i_dimid_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = ilev ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_dimid ( i_file_id, 'lat', i_dimid_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = ilat ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inq_dimid ( i_file_id, 'lon', i_dimid_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = ilon ), & + & cl_name, __LINE__ ) + + iobs = itim * ilat * ilon + IF(ldwp)WRITE(kunit,*) ' No. of data records = ', iobs + IF(ldwp)WRITE(kunit,*) ' No. of levels = ', ilev + IF(ldwp)WRITE(kunit,*) + + !--------------------------------------------------------------------- + ! Allocate arrays + !--------------------------------------------------------------------- + + CALL init_obfbdata( inpfile ) + CALL alloc_obfbdata( inpfile, 2, iobs, ilev, 0, 0, ldgrid ) + inpfile%cname(1) = 'UVEL' + inpfile%cname(2) = 'VVEL' + inpfile%coblong(1) = 'Zonal current' + inpfile%coblong(2) = 'Meridional current' + inpfile%cobunit(1) = 'Meters per second' + inpfile%cobunit(2) = 'Meters per second' + + ALLOCATE( & + & zu(ilon,ilat,ilev,itim), & + & zv(ilon,ilat,ilev,itim), & + & zdep(ilev), & + & zuv1qc(ilon,ilat,ilev,itim), & + & zuv2qc(ilon,ilat,ilev,itim), & + & itime(itim), & + & itime2(itim), & + & zlat(ilat), & + & zlon(ilon), & + & zjuld(itim) & + & ) + + !--------------------------------------------------------------------- + ! Read the time/position variables + !--------------------------------------------------------------------- + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_time, i_time_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_time_id, itime ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_time2, i_time2_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_time2_id, itime2 ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_depth, i_depth_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_depth_id, zdep ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_phi, i_phi_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_phi_id, zlat ), & + & cl_name, __LINE__ ) + + CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_lam, i_lam_id ), & + & cl_name, __LINE__ ) + CALL chkerr( nf90_get_var ( i_file_id, i_lam_id, zlon ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Read the variables + !--------------------------------------------------------------------- + + ! ADCP format assumed + cl_fld_var_u = 'u_1205' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_u, i_var_id ) /= nf90_noerr ) THEN + ! Try again with current meter format + cl_fld_var_u = 'U_320' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_u, i_var_id ) /= nf90_noerr ) THEN + CALL fatal_error( 'Unknown format in read_taondbc', __LINE__ ) + ENDIF + ENDIF + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zu ), & + & cl_name, __LINE__ ) + + ! ADCP format assumed + cl_fld_var_v = 'v_1206' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_v, i_var_id ) /= nf90_noerr ) THEN + ! Try again with current meter format + cl_fld_var_v = 'V_321' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_v, i_var_id ) /= nf90_noerr ) THEN + CALL fatal_error( 'Unknown format in read_taondbc', __LINE__ ) + ENDIF + ENDIF + CALL chkerr( nf90_get_var ( i_file_id, i_var_id, zv ), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Read the QC attributes + !--------------------------------------------------------------------- + + ! ADCP format assumed + cl_fld_var_qc_uv1 = 'QU_5205' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv1, i_qc_var_id ) /= nf90_noerr ) THEN + ! Try again with current meter format + cl_fld_var_qc_uv1 = 'QCS_5300' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv1, i_qc_var_id ) /= nf90_noerr ) THEN + ! Try again with high freq. current meter format + cl_fld_var_qc_uv1 = 'QCU_5320' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv1, i_qc_var_id ) /= nf90_noerr ) THEN + CALL fatal_error( 'Unknown format in read_taondbc', __LINE__ ) + ENDIF + ENDIF + ENDIF + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, zuv1qc), & + & cl_name, __LINE__ ) + + ! ADCP format assumed + cl_fld_var_qc_uv2 = 'QV_5206' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv2, i_qc_var_id ) /= nf90_noerr ) THEN + ! Try again with current meter format + cl_fld_var_qc_uv2 = 'QCD_5310' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv2, i_qc_var_id ) /= nf90_noerr ) THEN + ! Try again with high freq. current meter format + cl_fld_var_qc_uv2 = 'QCV_5321' + IF ( nf90_inq_varid( i_file_id, cl_fld_var_qc_uv2, i_qc_var_id ) /= nf90_noerr ) THEN + CALL fatal_error( 'Unknown format in read_taondbc', __LINE__ ) + ENDIF + ENDIF + ENDIF + CALL chkerr( nf90_get_var ( i_file_id, i_qc_var_id, zuv2qc), & + & cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Close file + !--------------------------------------------------------------------- + + CALL chkerr( nf90_close( i_file_id ), cl_name, __LINE__ ) + + !--------------------------------------------------------------------- + ! Convert to to 19500101 based Julian date + !--------------------------------------------------------------------- + DO jt = 1, itim + zjuld(jt) = REAL(itime(jt),wp) + REAL(itime2(jt),wp)/86400000.0_wp & + & - 2433283.0_wp + END DO + inpfile%cdjuldref = '19500101000000' + + !--------------------------------------------------------------------- + ! Copy info to obfbdata structure + !--------------------------------------------------------------------- + + iobs = 0 + DO jt = 1, itim + DO ja = 1, ilat + DO jo = 1, ilon + iobs = iobs + 1 + zl = zlon(jo) + IF ( zl > 180.0_wp ) zl = zl - 360.0_wp + IF ( zl < 0 ) THEN + cew = 'w' + ELSE + cew = 'e' + ENDIF + IF ( zlat(jo) < 0 ) THEN + cns = 's' + ELSE + cns = 'n' + ENDIF + WRITE(inpfile%cdwmo(iobs),'(A1,I2.2,A1,I3.3)') & + & cns, ABS(NINT(zlat(ja))), cew, ABS(NINT(zl)) + DO jk = 1, ilev + inpfile%pob(jk,iobs,1) = zu(jo,ja,jk,jt) + inpfile%pob(jk,iobs,2) = zv(jo,ja,jk,jt) + inpfile%pdep(jk,iobs) = zdep(jk) + inpfile%ivlqc(jk,iobs,1:2) = INT( MAX( zuv1qc(jo,ja,jk,jt), zuv2qc(jo,ja,jk,jt) ) ) + END DO + inpfile%plam(iobs) = zlon(jo) + inpfile%pphi(iobs) = zlat(ja) + inpfile%ptim(iobs) = zjuld(jt) + END DO + END DO + END DO + + ! No position, time, depth and variable QC in input files + DO jo = 1, iobs + inpfile%ipqc(jo) = 1 + inpfile%itqc(jo) = 1 + inpfile%ivqc(jo,1:2) = 1 + DO jk = 1, ilev + inpfile%idqc(jk,jo) = 1 + END DO + END DO + + !--------------------------------------------------------------------- + ! Set the platform information + !--------------------------------------------------------------------- + inpfile%cdtyp(:)=' 820' + + !--------------------------------------------------------------------- + ! Set QC flags for missing data and rescale to m/s + !--------------------------------------------------------------------- + + DO jo = 1, iobs + DO jk = 1, ilev + IF ( ( ABS(inpfile%pob(jk,jo,1)) > 10000.0_wp ) .OR. & + & ( ABS(inpfile%pob(jk,jo,2)) > 10000.0_wp ) ) THEN + inpfile%ivlqc(jk,jo,:) = 4 + inpfile%pob(jk,jo,1) = fbrmdi + inpfile%pob(jk,jo,2) = fbrmdi + ELSE + inpfile%pob(jk,jo,1) = 0.01 * inpfile%pob(jk,jo,1) + inpfile%pob(jk,jo,2) = 0.01 * inpfile%pob(jk,jo,2) + ENDIF + END DO + END DO + + !--------------------------------------------------------------------- + ! Set file indexes + !--------------------------------------------------------------------- + + DO jo = 1, inpfile%nobs + inpfile%kindex(jo) = jo + END DO + + !--------------------------------------------------------------------- + ! Initialize flags since they are not in the TAO input files + !--------------------------------------------------------------------- + + inpfile%ioqcf(:,:) = 0 + inpfile%ipqcf(:,:) = 0 + inpfile%itqcf(:,:) = 0 + inpfile%idqcf(:,:,:) = 0 + inpfile%ivqcf(:,:,:) = 0 + inpfile%ivlqcf(:,:,:,:) = 0 + + !--------------------------------------------------------------------- + ! Deallocate data + !--------------------------------------------------------------------- + DEALLOCATE( & + & zu, & + & zv, & + & zdep, & + & zuv1qc, & + & zuv2qc, & + & itime, & + & itime2, & + & zlat, & + & zlon, & + & zjuld & + & ) + + END SUBROUTINE read_taondbc diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/omonainfo.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/omonainfo.F90 new file mode 100644 index 0000000000000000000000000000000000000000..013968dc783d839cb0656462b2f1e67bcd0e823b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/omonainfo.F90 @@ -0,0 +1,1283 @@ +#define __MYFILE__ 'omonainfo.F90' +MODULE omonainfo + + ! Specific utilities for omona files + ! + ! History + ! Original: Magdalena A. Balmaseda + ! 2010: Split as to remove "scale factor information", + ! which is now in auxgrid + ! + + + USE netcdf + USE nctools + USE ioncdf + USE coords +! USE orcagrid + + CHARACTER(len=4) :: cl_expnam + CHARACTER(len=8) :: cl_date + CHARACTER(len=80) :: cl_filename_out + CHARACTER(len=80) :: cl_filename2_out + CHARACTER(len=3) :: cl_code + CHARACTER(len=1) :: cl_grid + CHARACTER(len=80) :: cl_var,cl_var_out + CHARACTER(len=80) :: cl_varname1, cl_varname2, cl_varunit1, cl_varunit2 + CHARACTER(len=1) :: sec !o =box average omona + !x =zonal section. Integral along x + !y =meridional section. Integral along y + + CHARACTER(len=1) :: grid0='?' + + INTEGER :: i_nb_dims,i_dp + INTEGER :: i_fill + REAL, DIMENSION(:,:), ALLOCATABLE :: z_var_2d + REAL, DIMENSION(:,:,:), ALLOCATABLE :: z_var_3d + REAL, DIMENSION(:), ALLOCATABLE :: z_dep2 + + PUBLIC :: variable_att, write_omona_netcdf, & + & write_dep_netcdf, create_time_series_netcdf_file + + + INTERFACE write_omona_netcdf + MODULE PROCEDURE write_omona_netcdf_2d_r, write_omona_netcdf_3d_r + END INTERFACE + +CONTAINS + + ! + !---------------------------------------------------------------------- + ! + ! W R I T E _ O M O N A _ N E T C D F + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE write_omona_netcdf_2d_r (cl_filename, z_field,i_time, & + cl_boxes, z_missing,i_fill) + ! + ! write a 2d array (time_serie) of reals + ! + IMPLICIT NONE + ! + CHARACTER(len=80), INTENT(in) :: cl_filename + INTEGER, DIMENSION(:), INTENT(in) :: i_time + INTEGER, INTENT(inout) :: i_fill + REAL, DIMENSION(:,:), INTENT(in) :: z_field + REAL, INTENT(in) :: z_missing + CHARACTER(len=20), DIMENSION(:), INTENT(in) :: cl_boxes + + ! + LOGICAL :: clbon + INTEGER :: i_var_exist, i_pos + INTEGER :: i_file_id, i_var_id + INTEGER :: i_nb_files,i_z, i_b + INTEGER :: i_tim_id,i_box_id + INTEGER :: i_time_var + INTEGER :: i_file + INTEGER, DIMENSION(2) :: i_dim, i_tab_start, i_tab_count + INTEGER :: i_rest_start, i_rest_end + INTEGER :: i_time0, i_time1 + REAL :: z_min, z_max + REAL :: z_min_old, z_max_old + INTEGER, DIMENSION(:), ALLOCATABLE :: i_time_old + INTEGER, DIMENSION(:), ALLOCATABLE :: i_time_rest + INTEGER :: i_t + REAL, DIMENSION(:,:), ALLOCATABLE :: z_old_2d + ! + i_tab_start(1) = 1 + i_z=1 + i_b=SIZE(z_field,1) + i_nb_files = SIZE(z_field,2) + i_tab_count(1) = i_b + i_tab_count(2) = i_nb_files + i_rest_start = 0 + i_rest_end = 0 + i_time0 = 0 + i_time1 = 0 + + WRITE(6,*)' Input time dimensions ',i_nb_files + WRITE(6,*)' file for output ',cl_filename + ! + z_min = MINVAL(z_field, mask = z_field .NE. z_missing ) + z_max = MAXVAL(z_field, mask = z_field .NE. z_missing ) + ! + + INQUIRE( FILE=cl_filename_out, EXIST=clbon ) + WRITE(*,*)' Inquiring clbon ',clbon + IF ( .NOT. clbon ) THEN + CALL create_time_series_netcdf_file ( cl_filename, cl_boxes) + ELSE + WRITE(*,*)' Time series file already exists' + ENDIF + ! + WRITE(*,*)' opening file ',cl_filename + CALL nchdlerr( nf90_open( cl_filename, nf90_write, i_file_id ) ,__LINE__,__MYFILE__) + ! + + WRITE(*,*)' Inquiring var ',cl_var_out + i_var_exist = nf90_inq_varid( i_file_id, cl_var_out, i_var_id ) + WRITE(*,*)' i_var_exist ',i_var_exist, i_var_id + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_tim_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'box', i_box_id ) ,__LINE__,__MYFILE__) + i_dim(1) = i_box_id + i_dim(2) = i_tim_id + ! write(*,*)' i_dim ',i_dim + ! + CALL nchdlerr( nf90_redef(i_file_id) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var(i_file_id, cl_var_out, nf90_real, i_dim, i_var_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', cl_varname1 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', cl_varname2 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units',cl_varunit1 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'unit_long',cl_varunit2 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'missing_value', z_missing ) ,__LINE__,__MYFILE__) + WRITE(*,*)'nf_put valid_min ',z_min + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,__LINE__,__MYFILE__) + WRITE(*,*)'nf_put valid_max ',z_max + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_var ) ,__LINE__,__MYFILE__) + i_pos = 1 + i_tab_start(2)=1 + ELSE + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', z_min_old ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', z_max_old ) ,__LINE__,__MYFILE__) + z_min = MIN( z_min, z_min_old ) + z_max = MAX( z_max, z_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_tim_id ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_tim_id,len=i_pos ) ,__LINE__,__MYFILE__) + ALLOCATE(i_time_old(i_pos)) + + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_var ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_get_var( i_file_id, i_time_var, i_time_old ) ,__LINE__,__MYFILE__) + i_tab_start(2)=i_pos+1 + DO i_t=i_pos,1,-1 + IF(i_time_old(i_t).GE.i_time(1)) THEN + i_tab_start(2)=i_t + ELSE + EXIT + ENDIF + ENDDO + WRITE(*,*)' i_tab_start(2)',i_tab_start(2) + + IF (I_FILL == 1 ) THEN + DO i_t=1,i_tab_start(2),1 + IF(i_time_old(i_t).LT.i_time(1)) THEN + i_time0=i_t+1 + ELSE + EXIT + ENDIF + ENDDO + WRITE(*,*)' i_tab_start(2), i_time0',i_tab_start(2),i_time0 + i_time0=min(i_time0,i_tab_start(2)) + i_tab_start(2)=i_time0 + i_time1=i_tab_start(2)+i_tab_count(2)-1 + WRITE(*,*)' Starting at time ',i_time_old(i_tab_start(2)-1),i_time(1) + i_rest_start=i_time1+1 + i_rest_end = i_pos + IF ( i_rest_end .gt. i_rest_start ) THEN + ALLOCATE( z_old_2d(i_b, i_pos)) + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, z_old_2d ) ,__LINE__,__MYFILE__) + z_old_2d(:,i_time0:i_time1)=z_field + i_time_old(i_time0:i_time1)=i_time + i_tab_start(2)=1 + i_tab_count(2)=i_pos + WRITE(*,*)' writing output I_FILL i_time0 ',i_time0 + WRITE(*,*)' writing output I_FILL i_time1 ',i_time1 + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, & + & z_old_2d, start=i_tab_start, count=i_tab_count),__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_time_var, & + & i_time_old,start=(/i_tab_start(2)/), count=(/i_tab_count(2)/)),__LINE__,__MYFILE__) + ELSE + I_FILL = 0 + DEALLOCATE(i_time_old) + DEALLOCATE(i_time_rest) + DEALLOCATE(z_old_2d) + ENDIF + ELSE + WRITE(*,*)' Starting at time ',i_time_old(i_tab_start(2)-1),i_time(1) + DEALLOCATE(i_time_old) + ENDIF + ENDIF + ! + IF ( I_FILL == 0 ) THEN + WRITE(*,*)' writing output start ',i_tab_start + WRITE(*,*)' writing output count ',i_tab_count + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, & + & z_field, start=i_tab_start, count=i_tab_count),__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_put_var( i_file_id, i_time_var, & + & i_time,start=(/i_tab_start(2)/), count=(/i_tab_count(2)/)),__LINE__,__MYFILE__) + ENDIF + + ! + + CALL nchdlerr( nf90_close( i_file_id ) ,__LINE__,__MYFILE__) + ! + RETURN + ! + END SUBROUTINE write_omona_netcdf_2d_r + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE write_omona_netcdf_3d_r (cl_filename, z_field,i_time, & + cl_boxes, z_missing, i_fill) +! +! write a 3d array (time_serie) of reals +! + IMPLICIT NONE +! + CHARACTER(len=80), INTENT(in) :: cl_filename + INTEGER, DIMENSION(:), INTENT(in) :: i_time + INTEGER, INTENT(inout) :: i_fill + REAL, DIMENSION(:,:,:), INTENT(in) :: z_field + REAL, INTENT(in) :: z_missing + CHARACTER(len=20), DIMENSION(:), INTENT(in) :: cl_boxes + +! + LOGICAL :: clbon + INTEGER :: i_var_exist, i_pos + INTEGER :: i_file_id, i_var_id + INTEGER :: i_nb_files,i_z,i_b + INTEGER :: i_tim_id,i_box_id,i_z_id + INTEGER :: i_time_var + INTEGER :: i_file + INTEGER, DIMENSION(3) :: i_dim, i_tab_start, i_tab_count + INTEGER :: i_rest_start, i_rest_end + INTEGER :: i_time0, i_time1 + REAL :: z_min, z_max + REAL :: z_min_old, z_max_old + INTEGER, DIMENSION(:), ALLOCATABLE :: i_time_old + INTEGER, DIMENSION(:), ALLOCATABLE :: i_time_rest + INTEGER :: i_t + REAL, DIMENSION(:,:,:), ALLOCATABLE :: z_old_3d +! + i_tab_start(1) = 1 + i_tab_start(2) = 1 + i_tab_start(3) = 1 + i_z=SIZE(z_field,1) !depth + i_b=SIZE(z_field,2) !nbox + i_nb_files = SIZE(z_field,3) + i_tab_count(1) = i_z + i_tab_count(2) = i_b + i_tab_count(3) = i_nb_files + i_time0 = 0 + i_time1 = 0 + i_rest_start = 0 + i_rest_end = 0 + +! write(6,*)' in write_3d ,shape(z_field) ',shape(z_field) +! write(6,*)' i_z =',i_z +! write(6,*)' i_b =',i_b +! write(6,*)' i_nb_files =',i_nb_files + + +! + z_min = MINVAL(z_field, mask = z_field .NE. z_missing ) + z_max = MAXVAL(z_field, mask = z_field .NE. z_missing ) +! + INQUIRE( FILE=cl_filename, EXIST=clbon ) + IF ( .NOT. clbon ) THEN + CALL create_time_series_netcdf_file ( cl_filename, cl_boxes) + ELSE + WRITE(*,*)' Time series file already exists' + ENDIF +! + WRITE(*,*)' opening file ',cl_filename + CALL nchdlerr( nf90_open( cl_filename, nf90_write, i_file_id ) ,__LINE__,__MYFILE__) +! + WRITE(*,*)'Inquiring var ',cl_var_out, i_var_id + i_var_exist = nf90_inq_varid( i_file_id, cl_var_out, i_var_id) + WRITE(*,*)'i_var_exist ',i_var_exist + + IF ( i_var_exist .NE. 0 ) THEN +! write(*,*)' Inquiring dimensions' + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'depth', i_z_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'box', i_box_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_tim_id ) ,__LINE__,__MYFILE__) + + i_dim(1) = i_z_id + i_dim(2) = i_box_id + i_dim(3) = i_tim_id +! write(*,*)' In write_omona_ncdf_3d: Dimensions: i_dim ',i_dim + + + CALL nchdlerr( nf90_redef( i_file_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, cl_var_out, nf90_real,i_dim, i_var_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name', cl_varname1 ),__LINE__,__MYFILE__ ) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', cl_varname2 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', cl_varunit1 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'unit_long', cl_varunit2 ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'missing_value', z_missing ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,__LINE__,__MYFILE__) +! + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + +! CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_tim_id ) ,__LINE__,__MYFILE__) +! write(6,*)' inq_dimid ',i_tim_id + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_var ) ,__LINE__,__MYFILE__) + WRITE(*,*) 'inq_varid i_tim_id for var time ',i_time_var + i_pos = 1 + i_tab_start(3)=1 + ELSE + !new addition +! CALL nchdlerr (nf90_inquire_variable( i_file_id, i_var_id, dimids=i_dim ) ,__LINE__,__MYFILE__) +! write(6,*)' after inquire variable i_dim = ',i_dim +! CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(1), len=i_pos ) ,__LINE__,__MYFILE__) +! write(6,*)' i_dim(1), len(1) ',i_dim(1),i_pos +! CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(2), len=i_pos ) ,__LINE__,__MYFILE__) +! write(6,*)' i_dim(2), len(2) ',i_dim(2),i_pos +! CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_dim(3), len=i_pos ) ,__LINE__,__MYFILE__) +! write(6,*)' i_dim(3), len(3) ',i_dim(3),i_pos + !!!! + + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_min', z_min_old ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_get_att( i_file_id, i_var_id, 'valid_max', z_max_old ) ,__LINE__,__MYFILE__) + z_min = MIN( z_min, z_min_old ) + z_max = MAX( z_max, z_max_old ) + CALL nchdlerr( nf90_redef( i_file_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + + + +! CALL nchdlerr( nf90_inq_varid( i_file_id, 'depth', i_z_id ) ,__LINE__,__MYFILE__) +! CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_z_id, len=i_pos ) ,__LINE__,__MYFILE__) +! write(*,*)' i_z_id, dim ',i_z_id,i_pos + +! CALL nchdlerr( nf90_inq_varid( i_file_id, 'box', i_box_id ) ,__LINE__,__MYFILE__) +! CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_box_id, len=i_pos ) ,__LINE__,__MYFILE__) +! write(*,*)' i_box_id, dim ',i_box_id,i_pos + + + + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'time', i_tim_id ) ,__LINE__,__MYFILE__) +! write(6,*)' inq_dimid ',i_tim_id + CALL nchdlerr( nf90_inquire_dimension( i_file_id, i_tim_id, len=i_pos ) ,__LINE__,__MYFILE__) +! write(*,*) 'inq_var_id i_tim_id,dim ',i_tim_id,i_pos + ALLOCATE(i_time_old(i_pos)) + CALL nchdlerr( nf90_inq_varid( i_file_id, 'time', i_time_var ) ,__LINE__,__MYFILE__) +! write(*,*) 'inq_var_id time',i_time_var + CALL nchdlerr( nf90_get_var( i_file_id, i_time_var, i_time_old ) ,__LINE__,__MYFILE__) + i_tab_start(3)=i_pos+1 + DO i_t=i_pos,1,-1 + IF(i_time_old(i_t).GE.i_time(1)) THEN + i_tab_start(3)=i_t + ELSE + EXIT + ENDIF + ENDDO + + WRITE(*,*)'i_tab_start(3)',i_tab_start(3) + WRITE(*,*)'i_tab_count(3)',i_tab_count(3) + + IF (I_FILL == 1 ) THEN + DO i_t=1,i_tab_start(3),1 + IF(i_time_old(i_t).LT.i_time(1)) THEN + i_time0=i_t+1 + ELSE + EXIT + ENDIF + ENDDO + + i_time0=min(i_time0,i_tab_start(3)) + i_tab_start(3)=i_time0 + i_time1=i_time0+i_tab_count(3)-1 + WRITE(*,*)'i_time0,i_tab_count(3),i_time1',i_Time0,i_tab_count(3),i_time1 + WRITE(*,*)' Starting at time ',i_time_old(i_tab_start(3)-1),i_time(1) + i_rest_start=i_time1+1 + i_rest_end = i_pos + IF ( i_rest_end .gt. i_rest_start ) THEN + ALLOCATE( z_old_3d(i_z,i_b, i_pos)) + CALL nchdlerr( nf90_get_var( i_file_id, i_var_id, z_old_3d ) ,__LINE__,__MYFILE__) + z_old_3d(:,:,i_time0:i_time1)=z_field + i_time_old(i_time0:i_time1)=i_time + i_tab_start(3)=1 + i_tab_count(3)=i_pos + WRITE(*,*)' writing output I_FILL i_time0 ',i_time0 + WRITE(*,*)' writing output I_FILL i_time1 ',i_time1 + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, & + & z_old_3d, start=i_tab_start, count=i_tab_count),__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_time_var, & + & i_time_old,start=(/i_tab_start(3)/), count=(/i_tab_count(3)/)),__LINE__,__MYFILE__) + ELSE + I_FILL = 0 + DEALLOCATE(i_time_old) + DEALLOCATE(i_time_rest) + DEALLOCATE(z_old_3d) + ENDIF + ELSE + WRITE(*,*)' Starting at time ',i_time_old(i_tab_start(3)-1),i_time(1) + DEALLOCATE(i_time_old) + ENDIF + ENDIF + ! + IF ( I_FILL == 0 ) THEN + WRITE(*,*)' writing output count ',i_tab_count + WRITE(*,*)' writing output start ',i_tab_start + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, & + z_field, start=i_tab_start, count=i_tab_count),__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_var( i_file_id, i_time_var, & + i_time,start=(/i_tab_start(3)/), count=(/i_tab_count(3)/) ),__LINE__,__MYFILE__) + ENDIF +! + CALL nchdlerr( nf90_close( i_file_id ),__LINE__,__MYFILE__ ) +! + RETURN + ! + END SUBROUTINE write_omona_netcdf_3d_r + !!---------------------------------------------------------------------- + ! + SUBROUTINE write_dep_netcdf ( cl_filename, cl_boxes, z_dep ) + ! + ! write a 2d array (map) of reals + ! + IMPLICIT NONE + ! + CHARACTER(len=80), INTENT(in) :: cl_filename + CHARACTER(len=20), DIMENSION(:), INTENT(in) :: cl_boxes + REAL, DIMENSION(:), INTENT(in) :: z_dep + ! + LOGICAL :: clbon + INTEGER :: i_file_id, i_var_id + INTEGER :: i_dim_z_id + INTEGER :: i_dimz, i_var_exist + INTEGER, DIMENSION(1) :: i_dim + REAL :: z_min, z_max + ! + i_dimz = i_dp + ! + z_min = MINVAL(z_dep) + z_max = MAXVAL(z_dep) + ! + INQUIRE( FILE=cl_filename, EXIST=clbon ) + IF ( .NOT. clbon ) THEN + CALL create_time_series_netcdf_file ( cl_filename, cl_boxes ) + ELSE + WRITE(*,*)' Time series file already exists' + ENDIF + ! + CALL nchdlerr( nf90_open( cl_filename, nf90_write, i_file_id ) ,__LINE__,__MYFILE__) + ! + CALL nchdlerr( nf90_inq_dimid( i_file_id, 'depth', i_dim_z_id ) ,__LINE__,__MYFILE__) + i_dim(1) = i_dim_z_id + ! write(6,*)' defining depth axis : i_dim(1)= ',i_dim(1) + ! + i_var_exist = nf90_inq_varid( i_file_id, "depth", i_var_id ) + IF ( i_var_exist .NE. 0 ) THEN + CALL nchdlerr( nf90_redef( i_file_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_var( i_file_id, "depth", nf90_real,i_dim, i_var_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'standard_name','depth') ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'long_name', 'depth below the surface') ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'units', 'm' ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'unit_long','meter' ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_min', z_min ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_var_id, 'valid_max', z_max ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + ENDIF + ! + CALL nchdlerr( nf90_put_var( i_file_id, i_var_id, z_dep) ,__LINE__,__MYFILE__) + ! + CALL nchdlerr( nf90_close( i_file_id ) ,__LINE__,__MYFILE__) + ! + RETURN + ! + END SUBROUTINE write_dep_netcdf + ! + ! + !---------------------------------------------------------------------- + ! + ! C R E A T E _ T I M E _ S E R I E S _ N E T C D F _ F I L E + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE create_time_series_netcdf_file ( cl_filename,cl_boxes) + ! + ! create time_series netcdf file + ! + IMPLICIT NONE + ! + + CHARACTER(len=80), INTENT(in) :: cl_filename + CHARACTER(len=20), DIMENSION(:) :: cl_boxes + ! + LOGICAL :: clbon + INTEGER :: i_file_id, i_dim_z_id, i_dim_box_id, & + i_dim_len_id, i_dim_t_id + INTEGER :: i_box_id, i_tim_id + INTEGER :: i_nbox + ! + i_nbox = SIZE(cl_boxes,1) + ! + + WRITE(*,*)' create_time_series',cl_filename + CALL nchdlerr( nf90_create( cl_filename, nf90_clobber, i_file_id ) ,__LINE__,__MYFILE__) + ! + CALL nchdlerr( nf90_def_dim( i_file_id, 'len', 20, i_dim_len_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'depth',i_dp, i_dim_z_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'box', i_nbox, i_dim_box_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_def_dim( i_file_id, 'time', nf90_unlimited, i_dim_t_id ) ,__LINE__,__MYFILE__) + + + WRITE(*,*)' In create_time_series_ntcdf' + WRITE(*,*)' z,box,time: ',i_dim_z_id,i_dim_box_id, i_dim_t_id + + WRITE(*,*)' Definining box var ' + CALL nchdlerr( nf90_def_var( i_file_id, 'box', nf90_char, & + (/i_dim_len_id,i_dim_box_id/), i_box_id ),__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_box_id, & + 'long_name', 'Name of the box' ) ,__LINE__,__MYFILE__) + + WRITE(*,*)' Definining time var' + CALL nchdlerr( nf90_def_var( i_file_id, 'time', nf90_int, & + (/i_dim_t_id/),i_tim_id ) ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_tim_id, 'standard_name','time') ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_tim_id, 'long_name','time') ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_tim_id, 'unit','days as %Y%m%d') ,__LINE__,__MYFILE__) + CALL nchdlerr( nf90_put_att( i_file_id, i_tim_id, 'unit_long','days as %Y%m%d') ,__LINE__,__MYFILE__) + ! + CALL nchdlerr( nf90_enddef( i_file_id ) ,__LINE__,__MYFILE__) + + CALL nchdlerr( nf90_put_var( i_file_id, i_box_id, cl_boxes & + ),__LINE__,__MYFILE__ ) + ! + CALL nchdlerr( nf90_close( i_file_id ),__LINE__,__MYFILE__ ) + ! + RETURN + ! + END SUBROUTINE create_time_series_netcdf_file + + + !----------------------------------------------------------------------- + SUBROUTINE variable_att + !----------------------------------------------------------------------- + ! + ! ROUTINE variable_att + ! ********************** + ! + ! Purpose : + ! ------- + ! set attributes for a given variable name + ! + ! Original : M. Balmaseda + IMPLICIT NONE + !----------------------------------------------------------------------- + ! Different variables + !----------------------------------------------------------------------- + ! + INTEGER:: ji,jj,jk + REAL :: dx0 !nominal longitudinal resolution in deg + REAL :: alat, alon,aux + INTEGER,DIMENSION(:,:), ALLOCATABLE:: iaux + + SELECT CASE ( TRIM(cl_var) ) + CASE ('sosstsst') + i_nb_dims=2 + cl_var_out='specified_sea_surface_temperature' + cl_varname1='Sea_Surface_Temperature' + cl_varname2='Sea Surface Temperature' + cl_varunit1='C' + cl_varunit2='degrees C' + cl_code='159' + cl_grid='t' + CASE ('somxl010') + i_nb_dims=2 + cl_var_out='ocean_mixed_layer_thickness' + cl_varname1='ocean_mixed_layer_thickness' + cl_varname2='depth of the ocean mixed layer from the surface' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='148' + cl_grid='t' + CASE ('somixhgt') + i_nb_dims=2 + cl_var_out='turbocline_depth' + cl_varname1='turbocline_depth' + cl_varname2='turbocline depth' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='248' + cl_grid='t' + CASE ('somxlt05') + i_nb_dims=2 + cl_var_out='ocean_mixed_layer_depth' + cl_varname1='ocean_mixed_layer_depth' + cl_varname2='depth of the ocean mixed layer T 0.5 criteria' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='348' + cl_grid='t' + CASE ('sohtc300') + i_nb_dims=2 + cl_var_out='hc300' + cl_varname1='300m_ocean_heat_content' + cl_varname2='ocean heat content over the first 300m' + cl_varunit1='J/m2' + cl_varunit2='J/m2' + cl_code='164' + cl_grid='t' + CASE ('sohtc700') + i_nb_dims=2 + cl_var_out='hc700' + cl_varname1='700m_ocean_heat_content' + cl_varname2='ocean heat content over the first 700m' + cl_varunit1='J/m2' + cl_varunit2='J/m2' + cl_code='264' + cl_grid='t' + CASE ('sohtcbtm') + i_nb_dims=2 + cl_var_out='hcbtm' + cl_varname1='Column_ocean_heat_content' + cl_varname2='ocean heat content over the whole column' + cl_varunit1='J/m2' + cl_varunit2='J/m2' + cl_code='364' + cl_grid='t' + CASE ('sosal300') + i_nb_dims=2 + cl_var_out='sal300' + cl_varname1='300m_integrated salinity' + cl_varname2='salinity integrated over the first 300m' + cl_varunit1='psu*m' + cl_varunit2='psu*m' + cl_code='175' + cl_grid='t' + CASE ('sosal700') + i_nb_dims=2 + cl_var_out='sal700' + cl_varname1='700m_integrated salinity' + cl_varname2='salinity integrated over the first 700m' + cl_varunit1='psu*m' + cl_varunit2='psu*m' + cl_code='275' + cl_grid='t' + CASE ('sosalbtm') + i_nb_dims=2 + cl_var_out='salbtm' + cl_varname1='Column_integrate_salinity' + cl_varname2='Integrated Salinity over the whole column' + cl_varunit1='psu*m' + cl_varunit2='psu*m' + cl_code='375' + cl_grid='t' + CASE ('so20chgt') + i_nb_dims=2 + cl_var_out='d20_isotherm_depth' + cl_varname1='depth' + cl_varname2='depth of the D20 isotherm' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='163' + cl_grid='t' + CASE ('so28chgt') + i_nb_dims=2 + cl_var_out='d28_isotherm_depth' + cl_varname1='28I_depth' + cl_varname2='depth of the D28 isotherm' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='263' + cl_grid='t' + CASE ('so26chgt') + i_nb_dims=2 + cl_var_out='d26_isotherm_depth' + cl_varname1='26I_depth' + cl_varname2='depth of the D26 isotherm' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='463' + cl_grid='t' + CASE ('sothedep') + i_nb_dims=2 + cl_var_out='thermocline_depth' + cl_varname1='thermocline_depth' + cl_varname2='thermocline depth' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='363' + cl_grid='t' + CASE ('sossheig') + i_nb_dims=2 + cl_var_out='sea_surface_height_above_geoid' + cl_varname1='sea_surface_height_above_geoid' + cl_varname2='sea_surface_height_above_geoid' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='145' + cl_grid='t' + CASE ('sostheig') + i_nb_dims=2 + cl_var_out='steric_height' + cl_varname1='steric_height' + cl_varname2='steric_height' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='150' + cl_grid='t' + CASE ('sobpheig') + i_nb_dims=2 + cl_var_out='bottom_pressure_equivalent_height' + cl_varname1='Bottom Pressure' + cl_varname2='Bottom Pressure' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='149' + cl_grid='t' + CASE ('sohefldo') + i_nb_dims=2 + cl_var_out='specified_surface_heat_flux' + cl_varname1='Net Downward Heat Flux' + cl_varname2='Net Downward Heat Flux' + cl_varunit1='W/m2' + cl_varunit2='Watt_per_square_meter' + cl_code='160' + cl_grid='t' + CASE ('sohefldp') + i_nb_dims=2 + cl_var_out='heat_flux_correction' + cl_varname1='Surface_Heat_Flux_Damping' + cl_varname2='Surface Heat Flux: Damping' + cl_varunit1='W/m2' + cl_varunit2='Watt_per_square_meter' + cl_code='162' + cl_grid='t' + CASE ('soshfldo') + i_nb_dims=2 + cl_var_out='absorbed_solar_radiation' + cl_varname1='Shortwave_Radiation' + cl_varname2='Shortwave Radiation' + cl_varunit1='W/m2' + cl_varunit2='Watt_per_square_meter' + cl_code='157' + cl_grid='t' + CASE ('sosalflx') + i_nb_dims=2 + cl_var_out='Surface_Salt_Flux' + cl_varname1='Surface_Salt_Flux' + cl_varname2='Surface Salt Flux' + cl_varunit1='Kg/m2/s' + cl_varunit2='Kg/m2/s' + cl_code='260' + cl_grid='t' + CASE ('sosafldp') + i_nb_dims=2 + cl_var_out='Surface_salt_flux_damping' + cl_varname1=cl_var_out + cl_varname2='Surface salt flux: damping' + cl_varunit1='Kg/m2/s' + cl_varunit2='Kg/m2/s' + cl_code='261' + cl_grid='t' + CASE ('sowaflup') + i_nb_dims=2 + cl_var_out='Net_Upward_Water_Flux' + cl_varname1=cl_var_out + cl_varname2=cl_var_out + cl_varunit1='Kg/m2/s' + cl_varunit2='Kg/m2/s' + cl_code='258' + cl_grid='t' + CASE ('sowafldp') + i_nb_dims=2 + cl_var_out='Surface_Water_Flux_Damping' + cl_varname1=cl_var_out + cl_varname2=cl_var_out + cl_varunit1='Kg/m2/s' + cl_varunit2='Kg/m2/s' + cl_code='262' + cl_grid='t' + CASE ('soicetem') + i_nb_dims=2 + cl_var_out='Ice_Surface_Temperature' + cl_varname1=cl_var_out + cl_varname2=cl_var_out + cl_varunit1='K' + cl_varunit2='Kelvin' + cl_code='429' + cl_grid='t' + CASE ('soicealb') + i_nb_dims=2 + cl_var_out='Ice_Albedo' + cl_varname1=cl_var_out + cl_varname2=cl_var_out + cl_varunit1='dl' + cl_varunit2='dimensionless' + cl_code='430' + cl_grid='t' + CASE ('soicecov') + i_nb_dims=2 + cl_var_out='Ice_Fraction' + cl_varname1=cl_var_out + cl_varname2=cl_var_out + cl_varunit1='dl' + cl_varunit2='dimensionless' + cl_code='431' + cl_grid='t' + CASE ('votemper') + i_nb_dims=3 + cl_var_out='sea_water_potential_temperature' + cl_varname1='sea_water_potential_temperature' + cl_varname2='Potential temperature ref to surface C' + cl_varunit1='C' + cl_varunit2='degree_Celcius' + cl_code='129' + cl_grid='t' + CASE ('vosaline') + i_nb_dims=3 + cl_var_out='sea_water_salinity' + cl_varname1='sea_water_salinity' + cl_varname2='sea water salinity' + cl_varunit1='PSU' + cl_varunit2='practical_salinity_scale' + cl_code='130' + cl_grid='t' + CASE ('vosigmat') + i_nb_dims=3 + cl_var_out='sigmat' + cl_varname1='sigmat' + cl_varname2='sigmat' + cl_varunit1='C' + cl_varunit2='NA' + cl_code='138' + cl_grid='t' + CASE ('vottrdmp') + i_nb_dims=3 + cl_var_out='Damping_T_3D' + cl_varname1='Damping_T_3D' + cl_varname2='Damping T 3D' + cl_varunit1='C/s' + cl_varunit2='degree_Celsius/second' + cl_code='201' + cl_grid='t' + CASE ('vostrdmp') + i_nb_dims=3 + cl_var_out='Damping_S_3D' + cl_varname1='Damping_S_3D' + cl_varname2='Damping S_3D' + cl_varunit1='psu/s' + cl_varunit2='psu/second' + cl_code='202' + cl_grid='t' + CASE ('votbiasd') + i_nb_dims=3 + cl_var_out='Bias_T_direct' + cl_varname1='Bias_T_direct' + cl_varname2='Bias_T_direct' + cl_varunit1='C' + cl_varunit2='degree_Celsius' + cl_code='203' + cl_grid='t' + CASE ('vosbiasd') + i_nb_dims=3 + cl_var_out='Bias_S_direct' + cl_varname1='Bias_S_direct' + cl_varname2='Bias_S_direct' + cl_varunit1='psu' + cl_varunit2='psu' + cl_code='204' + cl_grid='t' + CASE ('votbiasp') + i_nb_dims=3 + cl_var_out='Bias_T_pressure' + cl_varname1='Bias_T_pressure' + cl_varname2='Bias_T_pressure' + cl_varunit1='C' + cl_varunit2='degree_Celsius' + cl_code='205' + cl_grid='t' + CASE ('vosbiasp') + i_nb_dims=3 + cl_var_out='Bias_S_pressure' + cl_varname1='Bias_S_pressure' + cl_varname2='Bias_S_pressure' + cl_varunit1='psu' + cl_varunit2='psu' + cl_code='206' + cl_grid='t' + CASE ('vorbiasp') + i_nb_dims=3 + cl_var_out='Bias_rho_pressure' + cl_varname1='Bias_rho_pressure' + cl_varname2='Bias_rho_pressure' + cl_varunit1='kg/m3/s' + cl_varunit2='kg/m3/s' + cl_code='207' + cl_grid='t' + CASE ('sozotaux') + i_nb_dims=2 + cl_var_out='surface_downward_eastward_stress' + cl_varname1='Wind_Stress_along_i-axis' + cl_varname2=cl_var_out + cl_varunit1='N/m2' + cl_varunit2='N/m2' + cl_code='153' + cl_grid='u' + if (sec .eq. 'v') then + cl_varname2='taux*x*z' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + if (sec .eq. 'u') then + cl_varname2='taux*y*z' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + CASE ('vozocrtx') + i_nb_dims=3 + cl_var_out='sea_water_x_velocity' + cl_varname1='sea_water_x_velocity' + cl_varname2='U zonal current m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='131' + cl_grid='u' + if (sec .eq. 'u') then + cl_var_out='zonal_transport' + cl_varname1='zonal_transport' + cl_varname2='zonal_transport' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + CASE ('vozout') + i_nb_dims=3 + cl_var_out='UT' + cl_varname1='UT' + cl_varname2='UT' + cl_varunit1='K*m/s' + cl_varunit2='K*m/s' + cl_code='169' + cl_grid='t' + if (sec .eq. 'u') then + cl_var_out='zonal_H_transport' + cl_varname1='zonal_H_transport' + cl_varname2='zonal_H_transport' + cl_varunit1='PW' + cl_varunit2='PW' + endif + CASE ('vozous') + i_nb_dims=3 + cl_var_out='US' + cl_varname1='US' + cl_varname2='US' + cl_varunit1='psu*m/s' + cl_varunit2='psu*m/s' + cl_code='171' + cl_grid='t' + if (sec .eq. 'u') then + cl_var_out='zonal_S_transport' + cl_varname1='zonal_S_transport' + cl_varname2='zonal_S_transport' + cl_varunit1='kT/s' + cl_varunit2='kT/s' + endif + CASE ('vomecrty') + i_nb_dims=3 + cl_var_out='sea_water_y_velocity' + cl_varname1='sea_water_y_velocity' + cl_varname2='V meridional current m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='132' + cl_grid='v' + if (sec .eq. 'v') then + cl_var_out='meridional_transport' + cl_varname1='meridional_transport' + cl_varname2='meridional_transport' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + CASE ('sometauy') + i_nb_dims=2 + cl_var_out='surface_downward_northward_stress' + cl_varname1='Wind_Stress_along_j-axis' + cl_varname2=cl_var_out + cl_varunit1='N/m2' + cl_varunit2='N/m2' + cl_code='154' + cl_grid='v' + if (sec .eq. 'v') then + cl_varname2='tauy*x*z' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + if (sec .eq. 'u') then + cl_varname2='tauy*y*z' + cl_varunit1='Sv' + cl_varunit2='Sv' + endif + CASE ('vomevt') + i_nb_dims=3 + cl_var_out='VT' + cl_varname1='VT' + cl_varname2='VT' + cl_varunit1='K*m/s' + cl_varunit2='K*m/s' + cl_code='170' + cl_grid='t' + if (sec .eq. 'v') then + cl_var_out='meridional_H_transport' + cl_varname1='meridional_H_transport' + cl_varname2='meridional_H_transport' + cl_varunit1='PW' + cl_varunit2='PW' + endif + CASE ('vomevs') + i_nb_dims=3 + cl_var_out='VS' + cl_varname1='VS' + cl_varname2='VS' + cl_varunit1='psu*m/s' + cl_varunit2='psu*m/s' + cl_code='172' + cl_grid='t' + if (sec .eq. 'v') then + cl_var_out='meridional_S_transport' + cl_varname1='meridional_S_transport' + cl_varname2='meridional_S_transport' + cl_varunit1='kT/s' + cl_varunit2='kT/s' + endif + CASE ('vovecrtz') + i_nb_dims=3 + cl_var_out='upward_sea_water_velocity' + cl_varname1='upward_sea_water_velocity' + cl_varname2='W vertical current m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='133' + cl_grid='f' + CASE ('votkeavm') + i_nb_dims=3 + cl_var_out='vertical_eddy_viscosity' + cl_varname1='vertical_eddy_viscosity' + cl_varname2='vertical eddy viscosity' + cl_varunit1='m2/s' + cl_varunit2='square_meter_per_second' + cl_code='135' + cl_grid='f' + CASE ('votkeavt') + i_nb_dims=3 + cl_var_out='vertical_eddy_diffusivity' + cl_varname1='vertical_eddy_diffusivity' + cl_varname2='vertical eddy diffusivity' + cl_varunit1='m2/s' + cl_varunit2='square_meter_per_second' + cl_code='136' + cl_grid='f' + CASE ('votkeevm') + i_nb_dims=3 + cl_var_out='enhanced_vertical_eddy_viscosity' + cl_varname1='enhanced_vertical_eddy_viscosity' + cl_varname2='enhanced vertical eddy viscosity' + cl_varunit1='m2/s' + cl_varunit2='square_meter_per_second' + cl_code='235' + cl_grid='f' + CASE ('votkeevd') + i_nb_dims=3 + cl_var_out='enhanced_vertical_eddy_diffusivity' + cl_varname1='enhanced_vertical_eddy_diffusivity' + cl_varname2='enhanced vertical eddy diffusivity' + cl_varunit1='m2/s' + cl_varunit2='square_meter_per_second' + cl_code='236' + cl_grid='f' + CASE ('voddmavs') + i_nb_dims=3 + cl_var_out='salt_vertical_eddy_diffusivity' + cl_varname1='salt_vertical_eddy_diffusivity' + cl_varname2='salt vertical eddy diffusivity' + cl_varunit1='m2/s' + cl_varunit2='square_meter_per_second' + cl_code='237' + cl_grid='f' + CASE ('bckint') + i_nb_dims=3 + cl_var_out='assim_incr_temperature' + cl_varname1='assim_incr_temperature' + cl_varname2='assim_incr_temperature' + cl_varunit1='K/s' + cl_varunit2='Kelvin_per_second' + cl_code='178' + cl_grid='t' + CASE ('bckins') + i_nb_dims=3 + cl_var_out='assim_incr_salinity' + cl_varname1='assim_incr_salinity' + cl_varname2='assim_incr_salinity' + cl_varunit1='psu/s' + cl_varunit2='psu_per_second' + cl_code='184' + cl_grid='t' + CASE ('bckinu') + i_nb_dims=3 + cl_var_out='assim_incr_uvel' + cl_varname1='assim_incr_uvel' + cl_varname2='assim_incr_uvel' + cl_varunit1='m/s2' + cl_varunit2='meter_per_square_second' + cl_code='179' + cl_grid='u' + CASE ('bckinv') + i_nb_dims=3 + cl_var_out='assim_incr_vvel' + cl_varname1='assim_incr_vvel' + cl_varname2='assim_incr_vvel' + cl_varunit1='m/s2' + cl_varunit2='meter_per_square_second' + cl_code='180' + cl_grid='v' + CASE ('bckineta') + i_nb_dims=2 + cl_var_out='assim_incr_eta' + cl_varname1='assim_incr_eta' + cl_varname2='assim_incr_eta' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='181' + cl_grid='t' + CASE ('vozoeivu') + i_nb_dims=3 + cl_var_out='vozoeivu' + cl_varname1='vozoeivu' + cl_varname2='eddy U velocity m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='231' + CASE ('vomeeivv') + i_nb_dims=3 + cl_var_out='vomeeivv' + cl_varname1='vomeeivv' + cl_varname2='eddy V velocity m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='232' + CASE default + WRITE(*,*)'Variables not defined' + CALL ABORT + END SELECT + cl_var_out = TRIM(cl_var_out) + cl_varname1 = TRIM(cl_varname1) + cl_varname2 = TRIM(cl_varname2) + cl_varunit1 = TRIM(cl_varunit1) + cl_varunit2 = TRIM(cl_varunit2) + cl_code = TRIM(cl_code) + cl_grid = TRIM(cl_grid) + + cl_filename_out = TRIM(cl_expnam) // TRIM(cl_date) // '_' // TRIM(cl_code) //sec//'mona.nc' + cl_filename2_out = TRIM(cl_expnam) // TRIM(cl_date) // '_' // TRIM(cl_code) // 'xy' //sec//'mona.nc' +! IF ( i_nb_dims .EQ. 2 ) THEN +! i_dp=1 +! ELSE +! i_dp=jpk +! ENDIF + WRITE(*,*)'Variable Attributes: ' + WRITE(*,*)' cl_var_out = ',cl_var_out +! WRITE(*,*)' i_dp = ',i_dp + WRITE(*,*)' cl_grid = ',cl_grid + WRITE(*,*)' cl_code = ',cl_code + WRITE(*,*)' i_nb_dims = ',i_nb_dims + WRITE(*,*)'------------------------------------ ' + + RETURN + END SUBROUTINE variable_att + !----------------------------------------------------------------------- + SUBROUTINE obs_variable_att(cl_type) + !----------------------------------------------------------------------- + ! + ! ROUTINE obs_variable_att + ! **************************** + ! + ! Purpose : + ! ------- + ! set attributes for a given variable name (feedback version) + ! + ! Original : K. Mogensen + IMPLICIT NONE + !----------------------------------------------------------------------- + ! Different variables + !----------------------------------------------------------------------- + CHARACTER(len=*) :: cl_type + ! + SELECT CASE ( TRIM(cl_var) ) + CASE ('sossheig') + i_nb_dims=2 + cl_var_out='sea_surface_height_above_geoid' + cl_varname1='sea_surface_height_above_geoid' + cl_varname2='sea_surface_height_above_geoid' + cl_varunit1='m' + cl_varunit2='meter' + cl_code='145' + CASE ('sosstsst') + i_nb_dims=2 + cl_var_out='sea_surface_temperature' + cl_varname1='sea_surface_temperature' + cl_varname2='sea_surface_temperature' + cl_varunit1='K' + cl_varunit2='Kelvin' + cl_code='159' + CASE ('votemper') + i_nb_dims=3 + cl_var_out='sea_water_potential_temperature' + cl_varname1='sea_water_potential_temperature' + cl_varname2='Potential temperature ref to surface C' + cl_varunit1='C' + cl_varunit2='degree_Celcius' + cl_code='129' + CASE ('vosaline') + i_nb_dims=3 + cl_var_out='sea_water_salinity' + cl_varname1='sea_water_salinity' + cl_varname2='sea water salinity' + cl_varunit1='PSU' + cl_varunit2='practical_salinity_scale' + cl_code='130' + CASE ('vozocrtx') + i_nb_dims=3 + cl_var_out='sea_water_x_velocity' + cl_varname1='sea_water_x_velocity' + cl_varname2='U zonal current m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='131' + CASE ('vomecrty') + i_nb_dims=3 + cl_var_out='sea_water_y_velocity' + cl_varname1='sea_water_y_velocity' + cl_varname2='V meridional current m/s' + cl_varunit1='m/s' + cl_varunit2='meter_per_second' + cl_code='132' + CASE default + WRITE(*,*)'Variables not defined' + CALL ABORT + END SELECT + cl_var_out = TRIM(cl_var_out) + cl_varname1 = TRIM(cl_varname1) + cl_varname2 = TRIM(cl_varname2) + cl_varunit1 = TRIM(cl_varunit1) + cl_varunit2 = TRIM(cl_varunit2) + cl_code = TRIM(cl_code) + cl_filename_out = TRIM(cl_expnam) // TRIM(cl_date) // '_' // & + & TRIM(cl_code) // '_'//TRIM(cl_type)//'_'//'fbmona.nc' + cl_filename2_out = TRIM(cl_expnam) // TRIM(cl_date) // '_' // & + & TRIM(cl_code) // '_'//TRIM(cl_type)//'_'// 'xy' //'_'//'fbmona.nc' + + RETURN + END SUBROUTINE obs_variable_att + + +END MODULE omonainfo diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/ooo_utils.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/ooo_utils.F90 new file mode 100644 index 0000000000000000000000000000000000000000..f4b3292fe50e72e683a490cd7c0cc9f504fdae7b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/ooo_utils.F90 @@ -0,0 +1,39 @@ +MODULE ooo_utils + !! ================================================================= + !! *** MODULE ooo_utils *** + !! ================================================================= + USE par_oce + + IMPLICIT NONE + + ! Define double precision obfillflt + REAL(kind=dp), PARAMETER :: obfilldbl=99999. + + !! $Id: ooo_utils.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ + CONTAINS + + + SUBROUTINE date_format(date_str) + !--------------------------------------- + ! Routine to create creation date string + !--------------------------------------- + + ! Routine arguments + CHARACTER(len=*), INTENT(OUT) :: date_str + ! Local variables + CHARACTER(8) :: date + CHARACTER(10) :: time + + CHARACTER(10) :: date_part + CHARACTER(8) :: time_part + + CALL date_and_time(DATE=date) + CALL date_and_time(TIME=time) + date_part = date(1:4)//'/'//date(5:6)//'/'//date(7:8) + time_part = time(1:2)//':'//time(3:4)//':'//time(5:6) + + date_str = date_part//' '//time_part + + END SUBROUTINE date_format + +END MODULE ooo_utils diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/par_kind.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/par_kind.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2c701c22bb4eac6c0d867a43c16fec5178ea9296 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/par_kind.F90 @@ -0,0 +1 @@ +../../../src/OCE/par_kind.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/par_oce.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/par_oce.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6bf7fd4a6f64e8faf960655b346f7a31b0c20e98 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/par_oce.F90 @@ -0,0 +1,99 @@ +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 + + !!---------------------------------------------------------------------- + !! 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 :: jpreci = 1 !: number of columns for overlap + INTEGER, PUBLIC, PARAMETER :: jprecj = 1 !: number of rows for overlap + + !!---------------------------------------------------------------------- + !! namcfg namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(lc) :: cp_cfg !: name of the configuration + CHARACTER(lc) :: cp_cfz !: name of the zoom of configuration + INTEGER :: jp_cfg !: resolution of the configuration + + ! data size !!! * size of all input files * + INTEGER :: jpidta !: 1st lateral dimension ( >= jpi ) + INTEGER :: jpjdta !: 2nd " " ( >= jpj ) + INTEGER :: jpkdta !: number of levels ( >= jpk ) + + ! global or zoom domain size !!! * computational domain * + INTEGER :: jpiglo !: 1st dimension of global domain --> i + INTEGER :: jpjglo !: 2nd - - --> j + + ! zoom starting position + INTEGER :: jpizoom !: left bottom (i,j) indices of the zoom + INTEGER :: jpjzoom !: in data domain indices + +! ! Domain characteristics +! INTEGER :: jperio !: lateral cond. type (between 0 and 6) +! ! ! = 0 closed ; = 1 cyclic East-West +! ! ! = 2 equatorial symmetric ; = 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 + + ! Input file read offset + LOGICAL :: ln_use_jattr !: 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. + + !! Values set to pp_not_used indicates that this parameter is not used in THIS config. + !! Values set to pp_to_be_computed indicates that variables will be computed in domzgr + REAL(wp) :: pp_not_used = 999999._wp !: vertical grid parameter + REAL(wp) :: pp_to_be_computed = 999999._wp !: - - - + + + + + !!--------------------------------------------------------------------- + !! 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 Matrix size (if AGRIF, they are not all parameters) + !!--------------------------------------------------------------------- +#if defined key_agrif + INTEGER, PUBLIC, PARAMETER :: nbghostcells = 1 !: 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 + ! +#endif + INTEGER, PUBLIC :: jpi ! = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci !: first dimension + INTEGER, PUBLIC :: jpj ! = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj !: second dimension + INTEGER, PUBLIC :: jpk ! = jpkdta + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: par_oce.F90 5974 2015-12-02 10:52:05Z timgraham $ + !! Software governed by the CeCILL licence (./LICENSE) + !!====================================================================== +END MODULE par_oce diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/proftools.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/proftools.F90 new file mode 100644 index 0000000000000000000000000000000000000000..366ff3fbd4af30115c2415d667e5bbd7c6e6e02b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/proftools.F90 @@ -0,0 +1,34 @@ +MODULE proftools + + ! Various tools to manipulate fb profiles data. + + USE obs_fbm + IMPLICIT NONE + +CONTAINS + + SUBROUTINE sealsfromargo( fbdata ) + + ! Separate seals from argo + + ! Notes: + ! Argo is type 831 + ! Seals have station ids from Q9900000 to Q9900328 + ! according to + ! http://www.nodc.noaa.gov/GTSPP/document/codetbls/shipcode/name_1-C.html + ! on 2010-04-28 but we assume that all Q990???? are seals + + TYPE(obfbdata) :: fbdata + CHARACTER(len=ilentyp) :: cdtyp + INTEGER :: i + + DO i=1,fbdata%nobs + + cdtyp=ADJUSTL(fbdata%cdtyp(i)) + IF ((cdtyp(1:3)=='831') .AND. & + &(fbdata%cdwmo(i)(1:4)=='Q990')) fbdata%cdtyp(i)='Seal' + ENDDO + + END SUBROUTINE sealsfromargo + +END MODULE proftools diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/sla2fb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/sla2fb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..ce17193151ce481ef9b40a52aea83408bec7a6c1 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/sla2fb.F90 @@ -0,0 +1,102 @@ +PROGRAM sla2fb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM sla2fb ** + !! + !! ** Purpose : Convert AVISO SLA format to feedback format + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! sla2fb.exe [-s type] outputfile inputfile1 inputfile2 ... + !! Option: + !! -s Select altimeter data_source + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE obs_sla_io + USE convmerge + IMPLICIT NONE + ! + ! Command line arguments for output file and input files + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + CHARACTER(len=256) :: cdtmp + CHARACTER(len=5) :: cdsource + ! + ! Input data + ! + TYPE(obfbdata), POINTER :: slaf(:) + INTEGER :: ninfiles,ntotobs + ! + ! Output data + ! + TYPE(obfbdata) :: fbdata + ! + ! Loop variables + ! + INTEGER :: ip,ia,ji,jk,noff + ! + ! Get number of command line arguments + ! + nargs=IARGC() + IF (nargs < 1) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'sla2fb [-s type] outputfile inputfile1 inputfile2 ...' + CALL abort() + ENDIF + cdsource='' + ! + ! Get input data + ! + noff=1 + IF ( nargs > 1 ) THEN + CALL getarg(1,cdtmp) + IF (TRIM(cdtmp)=='-s') THEN + IF ( nargs < 3 ) THEN + WRITE(*,*)'Missing arguments to -s <datasource>' + CALL abort + ENDIF + CALL getarg(2,cdsource) + noff=3 + ENDIF + ENDIF + CALL getarg(noff,cdoutfile) + ninfiles = nargs - noff + ALLOCATE( slaf(MAX(nargs-noff,1)) ) + ALLOCATE( cdinfile(nargs-noff) ) + ntotobs = 0 + DO ia=1,ninfiles + CALL getarg( ia + noff, cdinfile(ia) ) + WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia)) + CALL read_avisofile( TRIM(cdinfile(ia)), slaf(ia), 6, .TRUE., .FALSE. ) + WRITE(*,'(A,I9,A)')'has',slaf(ia)%nobs,' observations' + IF (LEN_TRIM(cdsource)>0) THEN + DO ji=1,slaf(ia)%nobs + slaf(ia)%cdwmo(ji)=TRIM(slaf(ia)%cdwmo(ji))//'_'//TRIM(cdsource) + ENDDO + ENDIF + ntotobs = ntotobs + slaf(ia)%nobs + ENDDO + IF (ninfiles==0) THEN + CALL init_obfbdata( slaf(1) ) + CALL alloc_obfbdata( slaf(1), 1, 0, 1, 0, 0, .FALSE. ) + slaf(1)%cname(1) = 'SLA' + slaf(1)%cdjuldref = '19500101000000' + ENDIF + WRITE(*,'(A,I8)') 'Total observations : ',ntotobs + ! + ! Merge and output the data. + ! + CALL conv_fbmerge( TRIM(cdoutfile), ninfiles, slaf ) + +END PROGRAM sla2fb diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/str_c_to_for.h90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/str_c_to_for.h90 new file mode 120000 index 0000000000000000000000000000000000000000..b61704e1de1efbfc7cd92219a9f1189b021ead2b --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/str_c_to_for.h90 @@ -0,0 +1 @@ +../../../src/OCE/OBS/str_c_to_for.h90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/test_arrays_mod.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/test_arrays_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3e31f4154705ecc880a5427dbd25d8114b778e52 --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/test_arrays_mod.F90 @@ -0,0 +1,94 @@ +MODULE test_arrays_mod +USE obs_fbm + +INTERFACE test_arrays + MODULE PROCEDURE test_real_arrays + MODULE PROCEDURE test_real_arrays_2D + MODULE PROCEDURE test_real_arrays_3D + MODULE PROCEDURE test_integer_arrays +END INTERFACE test_arrays + +CONTAINS + + LOGICAL FUNCTION test_real_arrays(array_in,array_out) + IMPLICIT NONE + INTEGER :: i + REAL(KIND=fbdp) :: array_in(:), array_out(:) + + test_real_arrays=.TRUE. + DO i=1,SIZE(array_in) + IF (array_in(i) /= array_out(i)) THEN + test_real_arrays=.FALSE. + END IF + END DO + + IF (SIZE(array_in) /= SIZE(array_out)) THEN + test_real_arrays=.FALSE. + END IF + + END FUNCTION test_real_arrays + + + LOGICAL FUNCTION test_real_arrays_2D(array_in,array_out) + IMPLICIT NONE + INTEGER :: i, j + REAL(KIND=fbdp) :: array_in(:,:), array_out(:,:) + + test_real_arrays_2D=.TRUE. + DO j=1,SIZE(array_in,2) + DO i=1,SIZE(array_in,1) + IF (array_in(i,j) /= array_out(i,j)) THEN + test_real_arrays_2D=.FALSE. + END IF + END DO + END DO + + IF (SIZE(array_in) /= SIZE(array_out)) THEN + test_real_arrays_2D=.FALSE. + END IF + + END FUNCTION test_real_arrays_2D + + + LOGICAL FUNCTION test_real_arrays_3D(array_in,array_out) + IMPLICIT NONE + INTEGER :: i, j, k + REAL(KIND=fbdp) :: array_in(:,:,:), array_out(:,:,:) + + test_real_arrays_3D=.TRUE. + DO k=1,SIZE(array_in,3) + DO j=1,SIZE(array_in,2) + DO i=1,SIZE(array_in,1) + IF (array_in(i,j,k) /= array_out(i,j,k)) THEN + test_real_arrays_3D=.FALSE. + END IF + END DO + END DO + END DO + + IF (SIZE(array_in) /= SIZE(array_out)) THEN + test_real_arrays_3D=.FALSE. + END IF + + END FUNCTION test_real_arrays_3D + + + LOGICAL FUNCTION test_integer_arrays(array_in,array_out) + IMPLICIT NONE + INTEGER :: i + INTEGER :: array_in(:), array_out(:) + + test_integer_arrays=.TRUE. + DO i=1,SIZE(array_in) + IF (array_in(i) /= array_out(i)) THEN + test_integer_arrays=.FALSE. + END IF + END DO + + IF (SIZE(array_in) /= SIZE(array_out)) THEN + test_integer_arrays=.FALSE. + END IF + + END FUNCTION test_integer_arrays + +END MODULE test_arrays_mod diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/test_fbgenerate.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/test_fbgenerate.F90 new file mode 100644 index 0000000000000000000000000000000000000000..6115264de322bfb8743e2867b00b631610ec144a --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/test_fbgenerate.F90 @@ -0,0 +1,787 @@ +MODULE test_fbgenerate +USE obs_fbm +USE test_arrays_mod +USE fbgenerate_coords + +CONTAINS + + SUBROUTINE tester + IMPLICIT NONE + REAL(KIND=fbdp) :: array10_in(10), array1_in(1), array2_in(2), array3_in(3) + REAL(KIND=fbdp) :: array10_out(10), array1_out(1), array2_out(2), array3_out(3) + REAL(KIND=fbdp) :: array_4x3_in(3,4,1), array_4x3_out(3,4,1) + REAL(KIND=fbdp), ALLOCATABLE :: lat_array_in(:), lat_array_out(:) + REAL(KIND=fbdp), ALLOCATABLE :: lon_array_in(:), lon_array_out(:) + INTEGER :: iarray10_in(10), iarray1_in(1), iarray2_in(2), iarray3_in(3) + INTEGER :: iarray10_out(10), iarray1_out(1), iarray2_out(2), iarray3_out(3) + LOGICAL :: okay = .TRUE. + LOGICAL :: okay_too = .TRUE. + LOGICAL :: all_okay = .TRUE. + INTEGER, PARAMETER :: FV_int = 99999 + REAL(KIND=fbdp), PARAMETER :: FV_real = 99999.0_fbdp + + ! A single non-FillVal value should be replicated n times + array1_in(:)=(/1.0_fbdp/) + array1_out(:)=(/1.0_fbdp/) + CALL set_depths(array1_in,1,FV_real) + okay = test_arrays(array1_in,array1_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 1 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + array2_in(:) = (/1.0_fbdp, FV_real/) + array2_out(:) = (/1.0_fbdp, 1.0_fbdp/) + CALL set_depths(array2_in,2,FV_real) + okay = test_arrays(array2_in,array2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 2 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + array10_in(:) = (/1.0_fbdp,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real/) + array10_out(:) = 1.0_fbdp + CALL set_depths(array10_in,10,FV_real) + okay = test_arrays(array10_in,array10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 3 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + array3_in(:) = (/1.0_fbdp,FV_real,FV_real/) + array3_out(:) = 1.0_fbdp + CALL set_depths(array3_in,3,FV_real) + okay = test_arrays(array3_in,array3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 4 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + array2_in(:) = (/1.0_fbdp, 2.0_fbdp/) + array2_out(:) = (/1.0_fbdp, 2.0_fbdp/) + CALL set_depths(array2_in,2,FV_real) + okay = test_arrays(array2_in,array2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 5 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + array3_in(:) = (/3.0_fbdp, 2.0_fbdp, 56.23_fbdp/) + array3_out(:) = (/3.0_fbdp, 2.0_fbdp, 56.23_fbdp/) + CALL set_depths(array3_in,3,FV_real) + okay = test_arrays(array3_in,array3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 6 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + array10_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, -5.0_fbdp, 5.0_fbdp, 67.0_fbdp, 7.0_fbdp, 8.0_fbdp, 9.0_fbdp, 10.0_fbdp/) + array10_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, -5.0_fbdp, 5.0_fbdp, 67.0_fbdp, 7.0_fbdp, 8.0_fbdp, 9.0_fbdp, 10.0_fbdp/) + CALL set_depths(array10_in,10,FV_real) + okay = test_arrays(array10_in,array10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 7 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + array10_in(:) = (/1.0_fbdp,10.0_fbdp,1.0_fbdp,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real/) + array10_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp, 6.0_fbdp, 7.0_fbdp, 8.0_fbdp, 9.0_fbdp, 10.0_fbdp/) + CALL set_depths(array10_in,10,FV_real) + okay = test_arrays(array10_in,array10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 8 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + array10_in(:) = (/1.0_fbdp, 3.25_fbdp, 0.25_fbdp, FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real/) + array10_out(:) = (/1.0_fbdp, 1.25_fbdp, 1.5_fbdp, 1.75_fbdp, 2.0_fbdp, 2.25_fbdp, 2.5_fbdp, 2.75_fbdp, 3.0_fbdp, 3.25_fbdp/) + CALL set_depths(array10_in,10,FV_real) + okay = test_arrays(array10_in,array10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 9 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + array10_in(:) = (/3.25_fbdp, 1.0_fbdp, -0.25_fbdp, FV_real,FV_real,FV_real,FV_real,FV_real,FV_real,FV_real/) + array10_out(:) = (/3.25_fbdp, 3.0_fbdp, 2.75_fbdp, 2.5_fbdp, 2.25_fbdp, 2.0_fbdp, 1.75_fbdp, 1.5_fbdp, 1.25_fbdp, 1.0_fbdp/) + CALL set_depths(array10_in,10,FV_real) + okay = test_arrays(array10_in,array10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 11 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray1_in(:)=(/19991231/) + iarray1_out(:)=(/19991231/) + CALL set_date(iarray1_in,1,FV_int) + okay = test_arrays(iarray1_in,iarray1_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 12 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray2_in(:) = (/19991231, FV_int/) + iarray2_out(:) = (/19991231, 19991231/) + CALL set_date(iarray2_in,2,FV_int) + okay = test_arrays(iarray2_in,iarray2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 13 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray10_in(:) = (/20110101,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = 20110101 + CALL set_date(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 14 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray3_in(:) = (/20110101,FV_int,FV_int/) + iarray3_out(:) = 20110101 + CALL set_date(iarray3_in,3,FV_int) + okay = test_arrays(iarray3_in,iarray3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 15 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + iarray2_in(:) = (/19991231, 20000101/) + iarray2_out(:) = (/19991231, 20000101/) + CALL set_date(iarray2_in,2,FV_int) + okay = test_arrays(iarray2_in,iarray2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 16 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + iarray3_in(:) = (/19840101, 19001231, 20500612/) + iarray3_out(:) = (/19840101, 19001231, 20500612/) + CALL set_date(iarray3_in,3,FV_int) + okay = test_arrays(iarray3_in,iarray3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 17 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + iarray10_in(:) = (/20091231, 20100101, 20100102, 20100103, 20091231, & + 20100105, 20100106, 20091231, 20100108, 20100109/) + iarray10_out(:) = (/20091231, 20100101, 20100102, 20100103, 20091231, & + 20100105, 20100106, 20091231, 20100108, 20100109/) + CALL set_date(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 18 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/20091231,20100109,1,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/20091231, 20100101, 20100102, 20100103, 20100104, & + 20100105, 20100106, 20100107, 20100108, 20100109/) + CALL set_date(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 19 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/20100109,20091231,-1,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/20100109, 20100108, 20100107, 20100106, 20100105, & + 20100104, 20100103, 20100102, 20100101, 20091231/) + CALL set_date(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 20 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/20100101,20100401,10,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/20100101, 20100111, 20100121, 20100131, 20100210, & + 20100220, 20100302, 20100312, 20100322, 20100401/) + CALL set_date(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 21 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray1_in(:)=(/0000/) + iarray1_out(:)=(/0/) + CALL set_time(iarray1_in,1,FV_int) + okay = test_arrays(iarray1_in,iarray1_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 22 failed" + all_okay = .FALSE. + END IF + + ! A single non-FillVal value should be replicated n times + iarray2_in(:) = (/0600, FV_int/) + iarray2_out(:) = (/600, 600/) + CALL set_time(iarray2_in,2,FV_int) + okay = test_arrays(iarray2_in,iarray2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 23 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + iarray2_in(:) = (/0600, 1200/) + iarray2_out(:) = (/0600, 1200/) + CALL set_time(iarray2_in,2,FV_int) + okay = test_arrays(iarray2_in,iarray2_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 24 failed" + all_okay = .FALSE. + END IF + + ! A full list of n non-FillVals should be left unaltered. + iarray10_in(:) = (/1, 2, 3, -5, 5, 67, 7, 8, 9, 10/) + iarray10_out(:) = (/1, 2, 3, -5, 5, 67, 7, 8, 9, 10/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 25 failed" + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/0000,0430,0030,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/0, 30, 100, 130, 200, & + 230, 300, 330, 400, 430/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 26 failed" + WRITE(*,*) iarray10_in + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/2200,0230,0030,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/2200, 2230, 2300, 2330, 0, & + 30, 100, 130, 200, 230/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 27 failed" + WRITE(*,*) iarray10_in + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/2200,1730,-0030,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/2200, 2130, 2100, 2030, 2000, & + 1930, 1900, 1830, 1800, 1730/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 28 failed" + WRITE(*,*) iarray10_in + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/0100,2200,-0020,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/0100, 0040, 0020, 0000, 2340, & + 2320, 2300, 2240, 2220, 2200/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 29 failed" + WRITE(*,*) iarray10_in + all_okay = .FALSE. + END IF + + ! Three non-FillVal values should be used as the start, end, step in conjunction with n + iarray10_in(:) = (/1700,0630,90,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int,FV_int/) + iarray10_out(:) = (/1700, 1830, 2000, 2130, 2300, & + 0030, 0200, 0330, 0500, 0630/) + CALL set_time(iarray10_in,10,FV_int) + okay = test_arrays(iarray10_in,iarray10_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 30 failed" + WRITE(*,*) iarray10_in + all_okay = .FALSE. + END IF + + ! A single obs value should be replicated throught the array(obs,levels) + array_4x3_in(:,1,1) = (/1.0,FV_real,FV_real/) + array_4x3_in(:,2,1) = (/FV_real,FV_real,FV_real/) + array_4x3_in(:,3,1) = (/FV_real,FV_real,FV_real/) + array_4x3_in(:,4,1) = (/FV_real,FV_real,FV_real/) + array_4x3_out(:,1,1) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + array_4x3_out(:,2,1) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + array_4x3_out(:,3,1) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + array_4x3_out(:,4,1) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + CALL set_obs_values(array_4x3_in,1,4,3,FV_real) + okay = test_arrays(array_4x3_in,array_4x3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 31 failed" + WRITE(*,*) array_4x3_in + WRITE(*,*) + WRITE(*,*) array_4x3_out + all_okay = .FALSE. + END IF + + ! A full specification of the obs values should be unaltered + array_4x3_in(:,1,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_in(:,2,1) = (/4.0_fbdp, 5.0_fbdp, 6.0_fbdp/) + array_4x3_in(:,3,1) = (/7.0_fbdp, 8.0_fbdp, 9.0_fbdp/) + array_4x3_in(:,4,1) = (/10.0_fbdp, 11.0_fbdp, 12.0_fbdp/) + array_4x3_out(:,1,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_out(:,2,1) = (/4.0_fbdp, 5.0_fbdp, 6.0_fbdp/) + array_4x3_out(:,3,1) = (/7.0_fbdp, 8.0_fbdp, 9.0_fbdp/) + array_4x3_out(:,4,1) = (/10.0_fbdp, 11.0_fbdp, 12.0_fbdp/) + CALL set_obs_values(array_4x3_in,1,4,3,FV_real) + okay = test_arrays(array_4x3_in,array_4x3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 32 failed" + WRITE(*,*) array_4x3_in + WRITE(*,*) + WRITE(*,*) array_4x3_out + all_okay = .FALSE. + END IF + + ! A single profile should be replicated at all lat/lons + array_4x3_in(:,1,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_in(:,2,1) = (/FV_real, FV_real, FV_real/) + array_4x3_in(:,3,1) = (/FV_real, FV_real, FV_real/) + array_4x3_in(:,4,1) = (/FV_real, FV_real, FV_real/) + array_4x3_out(:,1,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_out(:,2,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_out(:,3,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + array_4x3_out(:,4,1) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + CALL set_obs_values(array_4x3_in,1,4,3,FV_real) + okay = test_arrays(array_4x3_in,array_4x3_out) + IF (okay .EQV. .FALSE.) THEN + WRITE(*,*) "Test 33 failed" + WRITE(*,*) array_4x3_in + WRITE(*,*) + WRITE(*,*) array_4x3_out + all_okay = .FALSE. + END IF + + ! A single profile position should only be given where nobs=1 + ALLOCATE(lat_array_in(1), & + lon_array_in(1), & + lat_array_out(1), & + lon_array_out(1) ) + lat_array_in(:) = (/1.0_fbdp/) + lon_array_in(:) = (/1.0_fbdp/) + lat_array_out(:) = (/1.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,1,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 34 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A single lat and list of lons should give nobs observations + ALLOCATE(lat_array_in(4), & + lon_array_in(4), & + lat_array_out(4), & + lon_array_out(4) ) + lat_array_in(:) = (/1.0_fbdp, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,4,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 35 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A single lat and bounded lons should give nobs = no elements in expanded bounds + ALLOCATE(lat_array_in(3), & + lon_array_in(3), & + lat_array_out(3), & + lon_array_out(3) ) + lat_array_in(:) = (/1.0_fbdp, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 3.0_fbdp, 1.0_fbdp/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,3,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 36 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A single lat and bounded lons should give nobs = no elements in expanded bounds + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/1.0_fbdp, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 5.0_fbdp, 1.0_fbdp, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 37 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A single lon and bounded lats should give nobs = no elements in expanded bounds + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/1.0_fbdp, 5.0_fbdp, 1.0_fbdp, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, FV_real, FV_real, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 38 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A list of lats and lons with same number of elements as nobs should be unaltered + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lon_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lat_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 39 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A list of lats and lons with fewer elements as nobs should be gridded + ! to produce nobs observations - list all lons at same lat, before stepping in lat. + ALLOCATE(lat_array_in(25), & + lon_array_in(25), & + lat_array_out(25), & + lon_array_out(25) ) + lat_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, & + 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, & + 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, & + 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, & + 5.0_fbdp, 5.0_fbdp, 5.0_fbdp, 5.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,25,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 40 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + ! A list of lats and lon bounds with fewer elements as nobs should be gridded + ! to produce nobs observations - list all lons at same lat, before stepping in lat. + ALLOCATE(lat_array_in(25), & + lon_array_in(25), & + lat_array_out(25), & + lon_array_out(25) ) + lat_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/10.0_fbdp, 50.0_fbdp, 10.0_fbdp, FV_real, FV_real,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, & + 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, & + 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, & + 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, & + 5.0_fbdp, 5.0_fbdp, 5.0_fbdp, 5.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,25,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 41 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + ! A list of lats and lon bounds with the same number of elements as nobs should be + ! unaltered expect for bounds expansion + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lon_array_in(:) = (/10.0_fbdp, 50.0_fbdp, 10.0_fbdp, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 42 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + ! A list of lons and lat bounds with the same number of elements as nobs should be + ! unaltered expect for bounds expansion + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/10.0_fbdp, 50.0_fbdp, 10.0_fbdp, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + lat_array_out(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp, 50.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 43 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + ! A list of lons and lat bounds with fewer elements as nobs should be gridded + ! to produce nobs observations - list all lons at same lat, before stepping in lat. + ALLOCATE(lat_array_in(25), & + lon_array_in(25), & + lat_array_out(25), & + lon_array_out(25) ) + lat_array_in(:) = (/10.0_fbdp, 50.0_fbdp, 10.0_fbdp, FV_real, FV_real,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lat_array_out(:) = (/10.0_fbdp, 10.0_fbdp, 10.0_fbdp, 10.0_fbdp, 10.0_fbdp, & + 20.0_fbdp, 20.0_fbdp, 20.0_fbdp, 20.0_fbdp, 20.0_fbdp, & + 30.0_fbdp, 30.0_fbdp, 30.0_fbdp, 30.0_fbdp, 30.0_fbdp, & + 40.0_fbdp, 40.0_fbdp, 40.0_fbdp, 40.0_fbdp, 40.0_fbdp, & + 50.0_fbdp, 50.0_fbdp, 50.0_fbdp, 50.0_fbdp, 50.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + 1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + 1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + 1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp,& + 1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,25,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 44 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + ! A single lat and bounded lons should give nobs = no elements in expanded bounds + ALLOCATE(lat_array_in(5), & + lon_array_in(5), & + lat_array_out(5), & + lon_array_out(5) ) + lat_array_in(:) = (/1.0_fbdp, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/1.0_fbdp, 5.0_fbdp, 1.0_fbdp, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp/) + lon_array_out(:) = (/1.0_fbdp, 2.0_fbdp, 3.0_fbdp, 4.0_fbdp, 5.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,5,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 45 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + ! Bounded lat and bounded lons - list all lons at same lat, before stepping in lat. + ALLOCATE(lat_array_in(20), & + lon_array_in(20), & + lat_array_out(20), & + lon_array_out(20) ) + lat_array_in(:) = (/1.0_fbdp, 5.0_fbdp, 1.0_fbdp, FV_real, FV_real,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lon_array_in(:) = (/10.0_fbdp, 40.0_fbdp, 10.0_fbdp, FV_real, FV_real,& + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real, & + FV_real, FV_real, FV_real, FV_real, FV_real/) + lat_array_out(:) = (/1.0_fbdp, 1.0_fbdp, 1.0_fbdp, 1.0_fbdp, & + 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, 2.0_fbdp, & + 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, 3.0_fbdp, & + 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, 4.0_fbdp, & + 5.0_fbdp, 5.0_fbdp, 5.0_fbdp, 5.0_fbdp/) + lon_array_out(:) = (/10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp,& + 10.0_fbdp, 20.0_fbdp, 30.0_fbdp, 40.0_fbdp/) + CALL set_spatial_coords(lat_array_in,lon_array_in,20,FV_real) + okay = test_arrays(lat_array_in,lat_array_out) + okay_too = test_arrays(lon_array_in,lon_array_out) + IF ((okay .EQV. .FALSE.) .OR. (okay_too .EQV. .FALSE.)) THEN + WRITE(*,*) "Test 46 failed" + WRITE(*,*) lat_array_in + WRITE(*,*) lon_array_in + WRITE(*,*) lat_array_out + WRITE(*,*) lon_array_out + all_okay = .FALSE. + END IF + DEALLOCATE(lat_array_in, & + lon_array_in, & + lat_array_out, & + lon_array_out ) + + + IF (all_okay) WRITE(*,*) "All tests passed" + + END SUBROUTINE tester + +END MODULE test_fbgenerate diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/toolspar_kind.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/toolspar_kind.F90 new file mode 100644 index 0000000000000000000000000000000000000000..1e8f590bb5906804690d80764a7d1248ec0437ea --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/toolspar_kind.F90 @@ -0,0 +1,8 @@ +MODULE toolspar_kind + IMPLICIT NONE + INTEGER, PUBLIC, PARAMETER :: & !: Floating point section + sp = SELECTED_REAL_KIND( 6, 37), & !: single precision (real 4) + dp = SELECTED_REAL_KIND(12,307), & !: double precision (real 8) + wp = SELECTED_REAL_KIND(12,307), & !: double precision (real 8) + ik = SELECTED_INT_KIND(6) !: integer precision +END MODULE toolspar_kind diff --git a/V4.0/nemo_sources/tools/OBSTOOLS/src/vel2fb.F90 b/V4.0/nemo_sources/tools/OBSTOOLS/src/vel2fb.F90 new file mode 100644 index 0000000000000000000000000000000000000000..3b7fc2869e60cc9191dc60547ada66a92bf6f29d --- /dev/null +++ b/V4.0/nemo_sources/tools/OBSTOOLS/src/vel2fb.F90 @@ -0,0 +1,86 @@ +PROGRAM vel2fb + !!--------------------------------------------------------------------- + !! + !! ** PROGRAM vel2fb ** + !! + !! ** Purpose : Convert TAO/PIRATA/RAMA currents to feedback format + !! + !! ** Method : Use of utilities from obs_fbm. + !! + !! ** Action : + !! + !! Usage: + !! vel2fb.exe outputfile inputfile1 inputfile2 ... + !! + !! History : + !! ! 2010 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + USE obs_fbm + USE obs_vel_io + USE convmerge + IMPLICIT NONE + ! + ! Command line arguments for output file and input files + ! +#ifndef NOIARGCPROTO + INTEGER,EXTERNAL :: iargc +#endif + INTEGER :: nargs + CHARACTER(len=256) :: cdoutfile + CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) + ! + ! Input data + ! + TYPE(obfbdata), POINTER :: velf(:) + INTEGER :: ninfiles,ntotvel,nmaxlev + INTEGER,ALLOCATABLE :: iset(:),inum(:),iindex(:) + ! + ! Output data + ! + TYPE(obfbdata) :: fbdata + ! + ! Loop variables + ! + INTEGER :: ia,ii,ij + ! + ! Get number of command line arguments + ! + nargs=IARGC() + IF (nargs < 1) THEN + WRITE(*,'(A)')'Usage:' + WRITE(*,'(A)')'vel2fb outputfile inputfile1 inputfile2 ...' + CALL abort() + ENDIF + CALL getarg(1,cdoutfile) + ! + ! Get input data + ! + ALLOCATE( velf(MAX(nargs-1,1)) ) + ALLOCATE( cdinfile(nargs-1) ) + ntotvel = 0 + ninfiles = nargs - 1 + DO ia = 1,ninfiles + CALL getarg( ia + 1, cdinfile(ia) ) + CALL read_taondbc( TRIM(cdinfile(ia)), velf(ia), 6, .TRUE., .FALSE. ) + WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia)) + WRITE(*,'(A,I9,A)')'has',velf(ia)%nobs,' profiles' + ntotvel = ntotvel + velf(ia)%nobs + nmaxlev = MAX( nmaxlev, velf(ia)%nlev ) + ENDDO + IF (ninfiles==0) THEN + CALL init_obfbdata( velf(1) ) + CALL alloc_obfbdata( velf(1), 2, 0, 1, 0, 1, .FALSE. ) + velf(1)%cname(1) = 'UVEL' + velf(1)%cname(2) = 'VVEL' + velf(1)%coblong(1) = 'Zonal current' + velf(1)%coblong(2) = 'Meridional current' + velf(1)%cobunit(1) = 'Meters per second' + velf(1)%cobunit(2) = 'Meters per second' + ENDIF + WRITE(*,'(A,I8)') 'Total profiles : ',ntotvel + ! + ! Merge and output the data. + ! + CALL conv_fbmerge( TRIM(cdoutfile), ninfiles, velf ) + +END PROGRAM vel2fb diff --git a/V4.0/nemo_sources/tools/README.rst b/V4.0/nemo_sources/tools/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..7a98caf2c85507de66b959220c81b1afaa93a371 --- /dev/null +++ b/V4.0/nemo_sources/tools/README.rst @@ -0,0 +1,134 @@ +***** +Tools +***** + +.. todo:: + + The 'Tools' chapter needs to be enriched + +.. contents:: + :local: + :depth: 1 + +A set of tools is provided with NEMO to setup user own configuration and (pre|post)process data. + +How to compile a tool +===================== + +The tool can be compiled using the maketools script in the tools directory as follows: + +.. code-block:: console + + $ ./maketools -m 'my_arch' -n '<TOOL_NAME>' + +where ``my_arch`` can be selected among available architecture files or providing a user defined one. + +List of tools +============= + +BDY_TOOLS +--------- + +It contains the utility *bdy_reorder* used to reorder old BDY data files used with +previous versions of the model (before 3.4) to make them compatible with NEMO 3.4. + +DMP_TOOLS +--------- + +Used to create a netcdf file called :file:`resto.nc` containing +restoration coefficients for use with the :file:`tra_dmp` module in NEMO +(see :download:`DMP_TOOLS README <../../../tools/DMP_TOOLS/README>`). + +DOMAINcfg +--------- + +This tool allows the creation of a domain configuration file (``domain_cfg.nc``) containing +the ocean domain information required to define an ocean configuration from scratch. +(see :download:`DOMAINcfg README <../../../tools/DOMAINcfg/README>`). + +GRIDGEN +------- + +A toolbox allowing the creation of regional configurations from curvilinear grid +(see :download:`GRIDGEN documentation <../../../tools/GRIDGEN/doc_cfg_tools.pdf>`). + +MISCELLANEOUS +------------- + +The tool allows to create alternative configurations to the community without +having to rely on system team sponsorship and support. + +MPP_PREP +-------- + +This tool provides the user with information to choose the best domain decomposition. +The tool computes the number of water processors for all possible decompositions, +up to a maximum number of processors +(see :download:`MPP_PREP documentation <../../../tools/MPP_PREP/mpp_nc.pdf>` and +:download:`MPP_PREP archive <../../../tools/MPP_PREP/mpp_prep-1.0.tar.gz>`). + +NESTING +------- + +AGRIF nesting tool allows for the seamless two-way coupling of nested sub-models within +the NEMO framework as long as these are defined on subsets of the original root grid. +It allows to create the grid coordinates, the surface forcing and the initial conditions required by +each sub-model when running a NEMO/AGRIF embedded mode +(see :download:`NESTING README <../../../tools/NESTING/README>`). + +OBSTOOLS +-------- + +A series of Fortran utilities which are helpful in handling observation files and +the feedback file output from the NEMO observation operator. +Further info are available in the :doc:`Nemo manual <cite>`. + +REBUILD_NEMO +------------ + +REBUILD_NEMO is a tool to rebuild NEMO output files from multiple processors +(mesh_mask, restart or XIOS output files) into one file +(see :download:`REBUILD_NEMO README <../../../tools/REBUILD_NEMO/README.rst>`). + +REBUILD +------- + +It contains the old version of REBUILD_NEMO tool based on the IOIPSL code. + +SCOORD_GEN +---------- + +Offline tool to generate a vertical coordinates input file for use with S coordinates. +This has been carried out by copying the model code to an offline tool and then +modifying it to suppress the use of 3D arrays (to reduce memory usage). +The tool has been created in preparation for the removal of the vertical grid definition from +the code. +The output file should contain all variables that are necessary to restart the model. + +SECTIONS_DIADCT +--------------- + +When the Transport across sections diagnostic is activated (``key_diadct``), +this tool is used to build the binary file containing the pathways between +the extremities of each section. +Further info are available in the :doc:`Nemo manual <cite>`. + +SIREN +----- + +SIREN is a configuration management tool to set up regional configurations with NEMO +(see :download:`SIREN README <../../../tools/SIREN/README>`). + +WEIGHTS +------- + +This directory contains software for generating and manipulating interpolation weights for use with +the Interpolation On the Fly (IOF) option in NEMO v3 onwards +(see :download:`WEIGHTS README <../../../tools/WEIGHTS/README>`). + +TOYATM +------ + +This directory contains a simplified model that send/receive atmospheric fields to/from NEMO. +Used to test the coupling interface. +This toy requires OASIS3-MCT to be installed and properly defined in the arch file. diff --git a/V4.0/nemo_sources/tools/REBUILD/rebuild b/V4.0/nemo_sources/tools/REBUILD/rebuild new file mode 120000 index 0000000000000000000000000000000000000000..0b2a9fa9dfb0de846d0d4070761e7b1e0bc03166 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/rebuild @@ -0,0 +1 @@ +../../ext/IOIPSL/tools/rebuild \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/calendar.f90 b/V4.0/nemo_sources/tools/REBUILD/src/calendar.f90 new file mode 120000 index 0000000000000000000000000000000000000000..bff4b4c4adcbf139e569ee3221ee33b7c665a523 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/calendar.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/calendar.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/defprec.f90 b/V4.0/nemo_sources/tools/REBUILD/src/defprec.f90 new file mode 120000 index 0000000000000000000000000000000000000000..ef6bc88652546176b5156a834e88dfe8b9d091a1 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/defprec.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/defprec.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/errioipsl.f90 b/V4.0/nemo_sources/tools/REBUILD/src/errioipsl.f90 new file mode 120000 index 0000000000000000000000000000000000000000..a42fd36e6989261d570032beac196711daf6bff4 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/errioipsl.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/errioipsl.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/flincom.f90 b/V4.0/nemo_sources/tools/REBUILD/src/flincom.f90 new file mode 120000 index 0000000000000000000000000000000000000000..960ad4b27a7e850382df3c46f3af39e6ba0b99c2 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/flincom.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/flincom.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/flio_rbld.f90 b/V4.0/nemo_sources/tools/REBUILD/src/flio_rbld.f90 new file mode 120000 index 0000000000000000000000000000000000000000..19d17cc46fbe2975d583c4dad613e239aa95ca95 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/flio_rbld.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/tools/flio_rbld.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/fliocom.f90 b/V4.0/nemo_sources/tools/REBUILD/src/fliocom.f90 new file mode 120000 index 0000000000000000000000000000000000000000..8318a48fd3e067aba5a86bfe56f641b02a9233e4 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/fliocom.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/fliocom.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/getincom.f90 b/V4.0/nemo_sources/tools/REBUILD/src/getincom.f90 new file mode 120000 index 0000000000000000000000000000000000000000..06a2079ec770a4a105a262ca96328ff5faf47570 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/getincom.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/getincom.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/histcom.f90 b/V4.0/nemo_sources/tools/REBUILD/src/histcom.f90 new file mode 120000 index 0000000000000000000000000000000000000000..1521441565115d95338e9ad7631edca5831294d7 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/histcom.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/histcom.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/ioipsl.f90 b/V4.0/nemo_sources/tools/REBUILD/src/ioipsl.f90 new file mode 120000 index 0000000000000000000000000000000000000000..3565d9a3754c23306c5e45b8917f6b7f5bf0196a --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/ioipsl.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/ioipsl.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/mathelp.f90 b/V4.0/nemo_sources/tools/REBUILD/src/mathelp.f90 new file mode 120000 index 0000000000000000000000000000000000000000..47b41a38d8f409639bd661f6288e9b3fe938d1d0 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/mathelp.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/mathelp.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/nc4interface.F90 b/V4.0/nemo_sources/tools/REBUILD/src/nc4interface.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a8f63cff57ea81100a9620d95e78668774bed116 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/nc4interface.F90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/nc4interface.F90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/ncunderflow.f90 b/V4.0/nemo_sources/tools/REBUILD/src/ncunderflow.f90 new file mode 120000 index 0000000000000000000000000000000000000000..483c9647006094a36251c3ac036ddb534cf76cc8 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/ncunderflow.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/tools/ncunderflow.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/restcom.f90 b/V4.0/nemo_sources/tools/REBUILD/src/restcom.f90 new file mode 120000 index 0000000000000000000000000000000000000000..929002fdd07989fc22030e84c9c46b7270c0f550 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/restcom.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/restcom.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD/src/stringop.f90 b/V4.0/nemo_sources/tools/REBUILD/src/stringop.f90 new file mode 120000 index 0000000000000000000000000000000000000000..580f24326386bde184de92932f0039e59d756e52 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD/src/stringop.f90 @@ -0,0 +1 @@ +../../../ext/IOIPSL/src/stringop.f90 \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/param_XC40_METO b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/param_XC40_METO new file mode 100644 index 0000000000000000000000000000000000000000..37b54f7bd5322ed00397cf7f80bc49accfd3183f --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/param_XC40_METO @@ -0,0 +1,3 @@ +#!/bin/ksh +BATCH_CMD="qsub" +ARCH="XC40_METO" diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_PW7_METO b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_PW7_METO new file mode 100644 index 0000000000000000000000000000000000000000..be0d684602c6bca221b9e63b7093c228d5e1e810 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_PW7_METO @@ -0,0 +1,31 @@ +#!/bin/ksh +# +#@ shell = /usr/bin/ksh +#@ class = serial +#@ job_type = serial +#@ job_name = rebuild_nemo +#@ output = $(job_name).$(jobid).out +#@ error = $(job_name).$(jobid).out +#@ notification = never +#@ resources = ConsumableMemory(MEMORY) +#@ node = 1 +#@ parallel_threads = 8 +#@ task_affinity = cpu(NTHREADS) +#@ cpu_limit = 00:5:00 +#@ wall_clock_limit = 00:5:00 +#@ queue + +export OMP_NUM_THREADS=NTHREADS + +MPI_DSM_VERBOSE=1; export MPI_DSM_VERBOSE + +nam_rebuild=NAMELIST +indir=INDIR + + +cd ${LOADL_STEP_INITDIR} + +${indir}/rebuild_nemo.exe $nam_rebuild +RC=$? + +exit $RC diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_XC40_METO b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_XC40_METO new file mode 100755 index 0000000000000000000000000000000000000000..ba8fe56d21f7b1c46c4bbc068730a94cd6850fbc --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/BATCH_TEMPLATES/rebuild_nemo_batch_XC40_METO @@ -0,0 +1,21 @@ +#!/bin/bash --login +#PBS -N Rebuild_Nemo +#PBS -q shared +#PBS -l ncpus=NTHREADS +#PBS -l mem=MEMORY +#PBS -l walltime=1:0:0 + +export OMP_NUM_THREADS=NTHREADS +indir=INDIR +nam_rebuild=NAMELIST + +ulimit -s unlimited +ulimit -n NOPEN + +module load cray-snplauncher +cd $PBS_O_WORKDIR +${indir}/rebuild_nemo.exe $nam_rebuild + +RC=$? + +exit $RC diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/README.rst b/V4.0/nemo_sources/tools/REBUILD_NEMO/README.rst new file mode 100644 index 0000000000000000000000000000000000000000..6e15165545dcb282cef0ffc5d4f58454fdd46d1c --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/README.rst @@ -0,0 +1,118 @@ +============ +REBUILD_NEMO +============ +REBUILD_NEMO is a tool to rebuild NEMO output files from multiple processors (mesh_mask, restart or XIOS output files) into one file. + +Description +=========== + +NEMO rebuild has the following features: + * dynamically works out what variables require rebuilding + * does not copy subdomain halo regions + * works for 1,2,3 and 4d arrays or types for all valid NetCDF types + * utilises OMP shared memory parallelisation where applicable + * time 'slicing' for lower memory use (only for 4D vars with unlimited dimension) + +The code reads the filestem and number of subdomains from the namelist file nam_rebuild. +| The 1st subdomain file is used to determine the dimensions and variables in all the input files. +It is also used to find which dimensions (and hence which variables) require rebuilding +as well as information about the global domain. +| It then opens all the input files (unbuffered) and creates an array of netcdf identifiers +before looping through all the variables and updating the rebuilt output file (either by direct +copying or looping over the number of domains and rebuilding as appropriate). +| The code looks more complicated than it is because it has lots of case statements to deal with all +the various NetCDF data types and with various data dimensions (up to 4d). +| Diagnostic output is written to numout (default 6 - stdout) +and errors are written to numerr (default 0 - stderr). +| If time slicing is specified the code will use less memory but take a little longer. +It does this by breaking down the 4D input variables over their 4th dimension +(generally time) by way of a while loop. + +How to compile it +================= +REBUILD_NEMO is compiled in the same manner as all the other tools. +The compilation script is maketools and the option are very similar to makenemo. + +Here an example of how to compile REBUILD_NEMO on the MetOffice XC40 HPC: + +.. code-block:: console + + $ ./maketools -n REBUILD_NEMO -m XC40_METO + +Usage +===== +There is 2 manners to use REBUILD_NEMO: + +* **rebuild_nemo shell script** + +If the rebuild_nemo shell script it used, the namelist is filled automatically depending on the on-line arguments. + +.. code-block:: console + + $ ./rebuild_nemo + + NEMO Rebuild + ************ + + usage: rebuild_nemo [-l -p -s -m -n -r -d -x -y -z -t -c] filebase ndomain [rebuild dimensions] + + flags: -l arch submit to compute node + -p num use num threads + -s num split 4D vars into time slice of size num + -m force masking of global arrays (zero if no mdi) + -n namelist full path to namelist file to be created (otherwise default nam_rebuild+_process_id is used) + -r memory Memory to request on compute node including units (Default = 10Gb) + + key_netcdf4 only + -d deflate_level deflate level for output files + -x chunksize along x + -y chunksize along y + -z chunksize along z + -t chunksize along t + -c total size of the chunk cache + +In case the option '-l arch' is used, a template for the batch script and parameter for job submission has to be provided in BATCH_TEMPLATES (param_arch and rebuild_nemo_batch_arch). +Exemple from the XC40_METO architecture can be found in the directory. +Some keywords (NTHREADS, MEMORY, INDIR, NAMELIST and NOPEN) from the template are replaced by the rebuild_nemo script. + +* **rebuild_nemo.exe + namelist** + +If rebuild_nemo.exe is used directly, a namelist has to be provided. Default name is nam_rebuild. A specific name can be provided as argument. +The minimal namelist required is (here example to rebuild a mesh_mask split in 36 files): + +.. code-block:: console + + &nam_rebuild + filebase='mesh_mask' + ndomain=36 + / + +Some option can be added (the value mentioned here are the default value): + +.. code-block:: console + + l_maskout=.false !(-m option: useful if input file comes from a run using land suppression) + nslicesize=0 !(-s option: 0 means no splitting in time slice) + deflate_level=0 !(-d option) + nc4_xchunk=206 !(-x option) + nc4_ychunk=135 !(-y option) + nc4_zchunk=1 !(-z option) + nc4_tchunk=1 !(-t option) + fchunksize=32000000 !(-c option) + +Example +======= + +Here is an example of usage of rebuild_nemo shelf script +(rebuild mesh_mask files on the XC40_METO computer with deflation level set to 1 and chunksize to (1,1,100,100)): + +.. code-block:: console + + $ rebuild_nemo -l XC40_METO -m -d 1 -x 100 -y 100 -z 1 -t 1 mesh_mask 36 + + output is mask using netcdf missing value (_Fillvalue attribute) or 0 if missing value not in the netcdf. + + file mesh_mask, num_domains 36, num_threads 1 + Submitting job to compute node + 8510610.xcs00 + $ diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/icb_combrest.py b/V4.0/nemo_sources/tools/REBUILD_NEMO/icb_combrest.py new file mode 100644 index 0000000000000000000000000000000000000000..c10a64e7482bc219e83a8469b12b7d19a01899b5 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/icb_combrest.py @@ -0,0 +1,275 @@ +import os +from netCDF4 import Dataset +from argparse import ArgumentParser +import numpy as np +import sys + +# +# Basic iceberg trajectory restart post-processing python script. +# This script collects iceberg information from the distributed restarts written +# out by each processing region and writes the information into a global restart file. +# The global restart file must already exist and contain the collated 2D spatial fields +# as prepared by utilities such as rebuild_nemo. This python script simply adds the +# iceberg position and state data that is held using the unlimited dimension 'n' which +# has been ignored by rebuild_nemo. Each processing region that contains icebergs will +# (probably) have a different number of icebergs (indicated by differing values for the +# current size of the unlimited dimension). This script collects all icebergs into a +# single unordered list. +# + +parser = ArgumentParser(description='produce a global trajectory restart file from distributed output\ + files, e.g. \n python ./icb_pp.py \ + -f icebergs_00692992_restart_ -n 480 -o icebergs_restart.nc [-O]') + +parser.add_argument('-f',dest='froot',help='fileroot_of_distrbuted_data; root name of \ + distributed trajectory restart file (usually completed with XXXX.nc, where \ + XXXX is the 4 digit processor number)', + default='icebergs_00692992_restart_') + +parser.add_argument('-n',dest='fnum',help='number of distributed files to process', + type=int, default=None) + +parser.add_argument('-o',dest='fout',help='global_iceberg_restart; file name to append the \ + global iceberg restart data to.', default='icebergs_restart.nc') + +parser.add_argument('-O',dest='fcre',help='Create the output file from scratch rather than \ + append to an existing file.', \ + action='store_true', default=False) + +args = parser.parse_args() + +default_used = 0 +if args.froot is None: + pathstart = 'icebergs_00692992_restart_' + default_used = 1 +else: + pathstart = args.froot + +if args.fnum is None: + procnum = 0 + default_used = 1 +else: + procnum = args.fnum + +if args.fout is None: + pathout = 'icebergs_restart.nc' + default_used = 1 +else: + pathout = args.fout + +if default_used == 1: + print('At least one default value will be used; command executing is:') + print('icb_combrest.py -f ',pathstart,' -n ',procnum,' -o ',pathout) + +if procnum < 1: + print('Need some files to collate! procnum = ',procnum) + sys.exit(11) + +icu = [] +times = [] +ntraj = 0 +nk = 0 +# +# Loop through all distributed datasets to obtain the total number +# of icebergs to transfer +# +for n in range(procnum): + nn = '%4.4d' % n + try: + fw = Dataset(pathstart+nn+'.nc') + except: + print 'Error: unable to open input file: ' + pathstart+nn+'.nc' + sys.exit(12) + for d in fw.dimensions : + if d == 'n' : + if len(fw.dimensions['n']) > 0: +# print 'icebergs found in: ' + pathstart+nn+'.nc' + if len(fw.dimensions['k']) > nk : + nk = len(fw.dimensions['k']) + ntraj = ntraj + len(fw.dimensions['n']) + fw.close() +# +print(ntraj, ' icebergs found across all datasets') +# +# Declare 2-D arrays to receive the data from all files +# +lons = np.zeros(ntraj) +lats = np.zeros(ntraj) +xis = np.zeros(ntraj) +yjs = np.zeros(ntraj) +uvs = np.zeros(ntraj) +vvs = np.zeros(ntraj) +mas = np.zeros(ntraj) +ths = np.zeros(ntraj) +wis = np.zeros(ntraj) +les = np.zeros(ntraj) +dys = np.zeros(ntraj) +mss = np.zeros(ntraj) +msb = np.zeros(ntraj) +hds = np.zeros(ntraj) +yrs = np.zeros(ntraj , dtype=int) +num = np.zeros((ntraj, nk), dtype=int) +# +# loop through distributed datasets again, this time +# collecting all trajectory data +# +nt = 0 +for n in range(procnum): + nn = '%4.4d' % n + fw = Dataset(pathstart+nn+'.nc') + for d in fw.dimensions : + if d == 'n' : +# Note many distributed datafiles will contain no iceberg data +# so skip quickly over these + m = len(fw.dimensions['n']) + if m > 0: +# print pathstart+nn+'.nc' + lons[nt:nt+m] = fw.variables['lon'][:] + lats[nt:nt+m] = fw.variables['lat'][:] + xis[nt:nt+m] = fw.variables['xi'][:] + yjs[nt:nt+m] = fw.variables['yj'][:] + uvs[nt:nt+m] = fw.variables['uvel'][:] + vvs[nt:nt+m] = fw.variables['vvel'][:] + mas[nt:nt+m] = fw.variables['mass'][:] + ths[nt:nt+m] = fw.variables['thickness'][:] + wis[nt:nt+m] = fw.variables['width'][:] + les[nt:nt+m] = fw.variables['length'][:] + dys[nt:nt+m] = fw.variables['day'][:] + mss[nt:nt+m] = fw.variables['mass_scaling'][:] + msb[nt:nt+m] = fw.variables['mass_of_bits'][:] + hds[nt:nt+m] = fw.variables['heat_density'][:] + yrs[nt:nt+m] = fw.variables['year'][:] + num[nt:nt+m,:] = fw.variables['number'][:,:] + nt = nt + m + fw.close() + +# Finally create the output file and write out the collated sets +# +if args.fcre : + try: + fo = Dataset(pathout, 'w', format='NETCDF4') + except: + print 'Error accessing output file: ' + pathout + print 'Check it is a writable location.' + sys.exit(13) +else : + # Copy 2D variables across to output file from input file. This step avoids problems if rebuild_nemo + # has created an "n" dimension in the prototype rebuilt file (ie. if there are icebergs on the zeroth + # processor). + try: + os.rename(pathout,pathout.replace('.nc','_WORK.nc')) + except OSError: + print 'Error: unable to move icebergs restart file: '+pathout + sys.exit(14) + # + try: + fi = Dataset(pathout.replace('.nc','_WORK.nc'), 'r') + except: + print 'Error: unable to open icebergs restart file: '+pathout.replace('.nc','_WORK.nc') + sys.exit(15) + fo = Dataset(pathout, 'w') + for dim in ['x','y','c','k']: + indim = fi.dimensions[dim] + fo.createDimension(dim, len(indim)) + for var in ['kount','calving','calving_hflx','stored_ice','stored_heat']: + invar = fi.variables[var] + fo.createVariable(var, invar.datatype, invar.dimensions) + fo.variables[var][:] = invar[:] + if "long_name" in invar.ncattrs(): + fo.variables[var].long_name = invar.long_name + if "units" in invar.ncattrs(): + fo.variables[var].units = invar.units + os.remove(pathout.replace('.nc','_WORK.nc')) +# +add_k = 1 +for d in fo.dimensions : + if d == 'n' : + print 'Error: dimension n already exists in output file' + sys.exit(16) + if d == 'k' : + add_k = 0 +onn = fo.createDimension('n', None) +if add_k > 0 : + onk = fo.createDimension('k', nk) +olon = fo.createVariable('lon', 'f8',('n')) +olat = fo.createVariable('lat', 'f8',('n')) +oxis = fo.createVariable('xi', 'f8',('n')) +oyjs = fo.createVariable('yj', 'f8',('n')) +ouvs = fo.createVariable('uvel', 'f8',('n')) +ovvs = fo.createVariable('vvel', 'f8',('n')) +omas = fo.createVariable('mass', 'f8',('n')) +oths = fo.createVariable('thickness', 'f8',('n')) +owis = fo.createVariable('width', 'f8',('n')) +oles = fo.createVariable('length', 'f8',('n')) +odys = fo.createVariable('day', 'f8',('n')) +omss = fo.createVariable('mass_scaling', 'f8',('n')) +omsb = fo.createVariable('mass_of_bits', 'f8',('n')) +ohds = fo.createVariable('heat_density', 'f8',('n')) +oyrs = fo.createVariable('year', 'i4',('n')) +onum = fo.createVariable('number', 'i4',('n','k')) +# +olon[:] = lons +olon.long_name = "longitude" +olon.units = "degrees_E" +# +olat[:] = lats +olat.long_name = "latitude" +olat.units = "degrees_N" +# +oxis[:] = xis +oxis.long_name = "x grid box position" +oxis.units = "fractional" +# +oyjs[:] = yjs +oyjs.long_name = "y grid box position" +oyjs.units = "fractional" +# +ouvs[:] = uvs +ouvs.long_name = "zonal velocity" +ouvs.units = "m/s" +# +ovvs[:] = vvs +ovvs.long_name = "meridional velocity" +ovvs.units = "m/s" +# +omas[:] = mas +omas.long_name = "mass" +omas.units = "kg" +# +oths[:] = ths +oths.long_name = "thickness" +oths.units = "m" +# +owis[:] = wis +owis.long_name = "width" +owis.units = "m" +# +oles[:] = les +oles.long_name = "length" +oles.units = "m" +# +odys[:] = dys +odys.long_name = "year day of calving event" +odys.units = "days" +# +omss[:] = mss +omss.long_name = "scaling factor for mass of calving berg" +omss.units = "none" +# +omsb[:] = msb +omsb.long_name = "mass of bergy bits" +omsb.units = "kg" +# +ohds[:] = hds +ohds.long_name = "heat density" +ohds.units = "J/kg" +# +oyrs[:] = yrs +oyrs.long_name = "calendar year of calving event" +oyrs.units = "years" +# +onum[:,:] = num +onum.long_name = "iceberg number on this processor" +onum.units = "count" +# +fo.close() diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/nam_rebuild b/V4.0/nemo_sources/tools/REBUILD_NEMO/nam_rebuild new file mode 100644 index 0000000000000000000000000000000000000000..6ab412f433b228cd59bcc9aeee98e74f02290b02 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/nam_rebuild @@ -0,0 +1,12 @@ +&nam_rebuild +filebase='mesh_mask' +ndomain=36 +l_maskout=.false !(-m option: useful if input file comes from a run using land suppression) +nslicesize=0 !(-s option: 0 means no splitting in time slice) +deflate_level=1 !(-d option) +nc4_xchunk=206 !(-x option) +nc4_ychunk=135 !(-y option) +nc4_zchunk=1 !(-z option) +nc4_tchunk=1 !(-t option) +fchunksize=32000000 !(-c option) +/ diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/rebuild_nemo b/V4.0/nemo_sources/tools/REBUILD_NEMO/rebuild_nemo new file mode 100755 index 0000000000000000000000000000000000000000..3bc021ec132edd9382f764e9fbeaded6f7498576 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/rebuild_nemo @@ -0,0 +1,183 @@ +#!/bin/ksh + +# CALLS: rebuild_nemo.exe + +#set -ax +usage () +{ + echo + echo " NEMO Rebuild" + echo " ************" + echo + echo " usage: ${0##*/} [-l -p -s -m -n -r -d -x -y -z -t -c] filebase ndomain [rebuild dimensions]" + echo + echo " flags: -l arch submit to compute node" + echo " -p num use num threads" + echo " -s num split 4D vars into time slice of size num" + echo " -m force masking of global arrays (zero if no mdi)" + echo " -n namelist full path to namelist file to be created (otherwise default nam_rebuild+_process_id is used)" + echo " -r memory Memory to request on compute node including units (Default = 10Gb)" + echo "" + echo " key_netcdf4 only " + echo " -d deflate_level deflate level for output files" + echo " -x chunksize along x " + echo " -y chunksize along y " + echo " -z chunksize along z " + echo " -t chunksize along t " + echo " -c total size of the chunk cache " + echo + exit 1 +} + +while getopts l:p:s:n:r:d:x:y:z:t:c:m opt +do + case ${opt} in + l) + BATCH="yes" + ARCH=${OPTARG} + ;; + p) + OMP_NUM_THREADS=${OPTARG} + ;; + s) + NSLICESIZE=${OPTARG} + ;; + m) + NMASK="TRUE" + echo "" + echo "output is mask using netcdf missing value (_Fillvalue attribute) or 0 if missing value not in the netcdf." + echo "" + ;; + d) + DEFLATE=${OPTARG} + ;; + n) + nam_rebuild=${OPTARG} + ;; + r) + MEMORY=${OPTARG} + ;; + x) + NXCHUNK=${OPTARG} + ;; + y) + NYCHUNK=${OPTARG} + ;; + z) + NZCHUNK=${OPTARG} + ;; + t) + NTCHUNK=${OPTARG} + ;; + c) + CHUNKSIZE=${OPTARG} + ;; + esac +done +shift $(expr ${OPTIND} - 1) + +if [[ $# -lt 2 ]] ; then + usage +fi + +script_dir=$(dirname $0) + +file=$1 +ndomain=$2 +DIM1=$3 +DIM2=$4 +export OMP_NUM_THREADS=${OMP_NUM_THREADS:-1} +nam_rebuild=${nam_rebuild:-nam_rebuild_$$} +MEMORY=${MEMORY:-10Gb} + +#Find out the maximum number of files that can be opened and increase if necessary) +nopen=$(ulimit -n) +if [[ $ndomain -gt $nopen ]] ; then + nopen=$((ndomain+4)) # +2 failed !!! +fi + +if [[ -n ${DIM1} && -n ${DIM2} ]] ; then + dim_str=" dims '${DIM1}','${DIM2}'" + dims="dims='${DIM1}','${DIM2}'" +fi + +echo "file ${file}, num_domains ${ndomain}, num_threads ${OMP_NUM_THREADS}${dim_str}" + +cat > $nam_rebuild << EOC +&nam_rebuild +filebase='${file}' +ndomain=${ndomain} +EOC +if [[ -n ${dims} ]] ; then + echo ${dims} >> $nam_rebuild +fi +if [[ -n ${NCSLICESIZE} ]] ; then + echo " nslicesize=${NCSLICESIZE}" >> $nam_rebuild +fi +if [[ -n ${NMASK} ]] ; then + echo " l_maskout=.true." >> $nam_rebuild +fi +if [[ -n ${DEFLATE} ]] ; then + echo " deflate_level=${DEFLATE}" >> $nam_rebuild +fi +if [[ -n ${NXCHUNK} ]] ; then + echo " nc4_xchunk=${NXCHUNK}" >> $nam_rebuild +fi +if [[ -n ${NYCHUNK} ]] ; then + echo " nc4_ychunk=${NYCHUNK}" >> $nam_rebuild +fi +if [[ -n ${NZCHUNK} ]] ; then + echo " nc4_zchunk=${NZCHUNK}" >> $nam_rebuild +fi +if [[ -n ${NTCHUNK} ]] ; then + echo " nc4_tchunk=${NTCHUNK}" >> $nam_rebuild +fi +if [[ -n ${CHUNKSIZE} ]] ; then + echo " fchunksize=${CHUNKSIZE}" >> $nam_rebuild +fi + + + +echo "/" >> $nam_rebuild + +if [[ ${BATCH} == "yes" ]] ; then + + template_dir=${script_dir}/BATCH_TEMPLATES/ + param_file=${template_dir}/param_${ARCH} + if [ ! -f $param_file ]; then + echo '' + echo "E R R O R: $param_file is missing, stop 42" + echo '' + echo "check your arch name or add one $param_file file in BATCH_TEMPLATES" + echo '' + exit 42 + fi + . $param_file + + batch_file=rebuild_nemo_batch_${ARCH} + if [ ! -f ${template_dir}/${batch_file} ]; then + echo '' + echo "E R R O R: $batch_file is missing, stop 42" + echo '' + echo "check your arch name or add one $batch_file file in BATCH_TEMPLATES" + echo '' + exit 42 + fi + + #Create a modified local copy of the batch submission file + #The process ID is appended to the end of the file name so it is unique + cat ${template_dir}/${batch_file} | sed -e"s/NTHREADS/${OMP_NUM_THREADS}/" \ + -e"s/MEMORY/${MEMORY}/" \ + -e"s:INDIR:${script_dir}:" \ + -e"s/NOPEN/${nopen}/" \ + -e"s/NAMELIST/${nam_rebuild}/" > ${batch_file}_$$.sh + + #Submit the job + echo "Submitting job to compute node" + $BATCH_CMD ${batch_file}_$$.sh + +else + ulimit -n $nopen + ${script_dir}/rebuild_nemo.exe $nam_rebuild +fi + diff --git a/V4.0/nemo_sources/tools/REBUILD_NEMO/src/rebuild_nemo.F90 b/V4.0/nemo_sources/tools/REBUILD_NEMO/src/rebuild_nemo.F90 new file mode 100644 index 0000000000000000000000000000000000000000..82a90c5900d0f60297d5f71ed1e37545cdeb1fa1 --- /dev/null +++ b/V4.0/nemo_sources/tools/REBUILD_NEMO/src/rebuild_nemo.F90 @@ -0,0 +1,1326 @@ +PROGRAM rebuild_nemo +#define key_netcdf4 + !!========================================================================= + !! *** rebuild_nemo *** + !!========================================================================= + !! + !! A routine to rebuild NEMO files from multiple processors into one file. + !! This routine is designed to be much quicker than the old IOIPSL rebuild + !! but at the cost of an increased memory usage. + !! + !! NEMO rebuild has the following features: + !! * dynamically works out what variables require rebuilding + !! * does not copy subdomain halo regions + !! * works for 1,2,3 and 4d arrays or types for all valid NetCDF types + !! * utilises OMP shared memory parallelisation where applicable + !! * time 'slicing' for lower memory use + !! (only for 4D vars with unlimited dimension) + !! + !! Ed Blockley - August 2011 + !! (based on original code by Matt Martin) + !! Julien Palmieri and Andrew Coward - September 2018 (add compression and chunking) + !! + !!------------------------------------------------------------------------- + !! + !! The code reads the filestem and number of subdomains from the namelist file nam_rebuild. + !! + !! The 1st subdomain file is used to determine the dimensions and variables in all the input files. + !! It is also used to find which dimensions (and hence which variables) require rebuilding + !! as well as information about the global domain. + !! + !! It then opens all the input files (unbuffered) and creates an array of netcdf identifiers + !! before looping through all the variables and updating the rebuilt output file (either by direct + !! copying or looping over the number of domains and rebuilding as appropriate). + !! + !! The code looks more complicated than it is because it has lots of case statements to deal with all + !! the various NetCDF data types and with various data dimensions (up to 4d). + !! + !! Diagnostic output is written to numout (default 6 - stdout) + !! and errors are written to numerr (default 0 - stderr). + !! + !! If time slicing is specified the code will use less memory but take a little longer. + !! It does this by breaking down the 4D input variables over their 4th dimension + !! (generally time) by way of a while loop. + !! + !!------------------------------------------------------------------------------- + + USE netcdf + +!$ USE omp_lib ! Note OpenMP sentinel + + IMPLICIT NONE + + ! kind specifications + INTEGER,PARAMETER :: i1=SELECTED_INT_KIND(2) ! NF90_BYTE + INTEGER,PARAMETER :: i2=SELECTED_INT_KIND(4) ! NF90_SHORT + INTEGER,PARAMETER :: i4=SELECTED_INT_KIND(9) ! NF90_INT + INTEGER,PARAMETER :: sp=SELECTED_REAL_KIND(6,37) ! NF90_FLOAT + INTEGER,PARAMETER :: dp=SELECTED_REAL_KIND(12,307) ! NF90_DOUBLE + + INTEGER,PARAMETER :: numnam = 11 + INTEGER,PARAMETER :: numout = 6 + INTEGER,PARAMETER :: numerr = 0 + + LOGICAL, PARAMETER :: l_verbose = .true. + + CHARACTER(LEN=nf90_max_name) :: filebase, suffix, attname, dimname, varname, time, date, zone, timestamp + CHARACTER(LEN=nf90_max_name), ALLOCATABLE :: filenames(:), indimnames(:) + CHARACTER(LEN=nf90_max_name), DIMENSION(2) :: dims + CHARACTER(LEN=256) :: cnampath, cdimlst, cdim + CHARACTER(LEN=50) :: clibnc ! netcdf library version + + INTEGER :: ndomain, ifile, ndomain_file, nslicesize, deflate_level + INTEGER :: ncid, outid, idim, istop + INTEGER :: natts, attid, xtype, varid, rbdims + INTEGER :: jv, ndims, nvars, dimlen, dimids(4) + INTEGER :: dimid, unlimitedDimId, di, dj, dr + INTEGER :: nmax_unlimited, nt, ntslice + INTEGER :: fchunksize = 32000000 ! NetCDF global file chunk cache size + INTEGER :: patchchunk ! NetCDF processor-domain file chunk cache size + INTEGER :: nthreads = 1 + INTEGER :: chunkalg = 0 ! NetCDF4 variable chunking algorithm + ! Default variable chunksizes (typical ORCA025 + ! recommendations which can be adjusted via namelist + ! or will be bounded if too large for domain.) + INTEGER :: nc4_xchunk = 206 ! Default x (longitude) variable chunk size + INTEGER :: nc4_ychunk = 135 ! Default y (latitude) variable chunk size + INTEGER :: nc4_zchunk = 1 ! Default z (depth) variable chunk size (almost always 1) + INTEGER :: nc4_tchunk = 1 ! Default t (time) variable chunk size (almost always 1) + INTEGER, ALLOCATABLE :: outdimids(:), outdimlens(:), indimlens(:), inncids(:) + INTEGER, ALLOCATABLE :: chunksizes(:) + INTEGER, ALLOCATABLE :: global_sizes(:), rebuild_dims(:) + INTEGER, DIMENSION(2) :: halo_start, halo_end, local_sizes + INTEGER, DIMENSION(2) :: idomain, jdomain, rdomain, start_pos + INTEGER :: ji, jj, jk, jl, jr + INTEGER :: nargs ! number of arguments + INTEGER, EXTERNAL :: iargc + + REAL(sp) :: ValMin, ValMax, InMin, InMax, rmdi + REAL(dp), ALLOCATABLE :: mdiVals(:) + + ! NF90_BYTE local data arrays + INTEGER(i1), ALLOCATABLE, SAVE, DIMENSION(:) :: localdata_1d_i1 + INTEGER(i1), ALLOCATABLE, SAVE, DIMENSION(:,:) :: localdata_2d_i1 + INTEGER(i1), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: localdata_3d_i1 + INTEGER(i1), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: localdata_4d_i1 + + ! NF90_SHORT local data arrays + INTEGER(i2), ALLOCATABLE, SAVE, DIMENSION(:) :: localdata_1d_i2 + INTEGER(i2), ALLOCATABLE, SAVE, DIMENSION(:,:) :: localdata_2d_i2 + INTEGER(i2), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: localdata_3d_i2 + INTEGER(i2), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: localdata_4d_i2 + + ! NF90_INT local data arrays + INTEGER(i4), ALLOCATABLE, SAVE, DIMENSION(:) :: localdata_1d_i4 + INTEGER(i4), ALLOCATABLE, SAVE, DIMENSION(:,:) :: localdata_2d_i4 + INTEGER(i4), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: localdata_3d_i4 + INTEGER(i4), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: localdata_4d_i4 + + ! NF90_FLOAT local data arrays + REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:) :: localdata_1d_sp + REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: localdata_2d_sp + REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: localdata_3d_sp + REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: localdata_4d_sp + + ! NF90_DOUBLE local data arrays + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:) :: localdata_1d_dp + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: localdata_2d_dp + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: localdata_3d_dp + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: localdata_4d_dp + + ! NF90_BYTE global data arrays + INTEGER(i1) :: globaldata_0d_i1 + INTEGER(i1), ALLOCATABLE, DIMENSION(:) :: globaldata_1d_i1 + INTEGER(i1), ALLOCATABLE, DIMENSION(:,:) :: globaldata_2d_i1 + INTEGER(i1), ALLOCATABLE, DIMENSION(:,:,:) :: globaldata_3d_i1 + INTEGER(i1), ALLOCATABLE, DIMENSION(:,:,:,:) :: globaldata_4d_i1 + + ! NF90_SHORT global data arrays + INTEGER(i2) :: globaldata_0d_i2 + INTEGER(i2), ALLOCATABLE, DIMENSION(:) :: globaldata_1d_i2 + INTEGER(i2), ALLOCATABLE, DIMENSION(:,:) :: globaldata_2d_i2 + INTEGER(i2), ALLOCATABLE, DIMENSION(:,:,:) :: globaldata_3d_i2 + INTEGER(i2), ALLOCATABLE, DIMENSION(:,:,:,:) :: globaldata_4d_i2 + + ! NF90_INT global data arrays + INTEGER(i4) :: globaldata_0d_i4 + INTEGER(i4), ALLOCATABLE, DIMENSION(:) :: globaldata_1d_i4 + INTEGER(i4), ALLOCATABLE, DIMENSION(:,:) :: globaldata_2d_i4 + INTEGER(i4), ALLOCATABLE, DIMENSION(:,:,:) :: globaldata_3d_i4 + INTEGER(i4), ALLOCATABLE, DIMENSION(:,:,:,:) :: globaldata_4d_i4 + + ! NF90_FLOAT global data arrays + REAL(sp) :: globaldata_0d_sp + REAL(sp), ALLOCATABLE, DIMENSION(:) :: globaldata_1d_sp + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: globaldata_2d_sp + REAL(sp), ALLOCATABLE, DIMENSION(:,:,:) :: globaldata_3d_sp + REAL(sp), ALLOCATABLE, DIMENSION(:,:,:,:) :: globaldata_4d_sp + + ! NF90_DOUBLE global data arrays + REAL(dp) :: globaldata_0d_dp + REAL(dp), ALLOCATABLE, DIMENSION(:) :: globaldata_1d_dp + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: globaldata_2d_dp + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: globaldata_3d_dp + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: globaldata_4d_dp + + LOGICAL :: l_valid = .false. + LOGICAL :: l_noRebuild = .false. + LOGICAL :: l_findDims = .true. + LOGICAL :: l_maskout = .false. + LOGICAL :: l_namexist = .false. + + NAMELIST/nam_rebuild/ filebase, ndomain, dims, nslicesize, l_maskout, deflate_level, & + & nc4_xchunk, nc4_ychunk, nc4_zchunk, nc4_tchunk, fchunksize + + external :: getarg + + !End of definitions + +!-------------------------------------------------------------------------------- +!0. OMP setup + +!$OMP PARALLEL DEFAULT(NONE) SHARED(nthreads) +!$OMP MASTER +!$ nthreads = omp_get_num_threads() +!$ WRITE(numout,*) 'Running OMP with ',nthreads,' thread(s).' +!$OMP END MASTER +!$OMP END PARALLEL + +!-------------------------------------------------------------------------------- +!1.0 Check netcdf version for warning + clibnc = TRIM(nf90_inq_libvers()) + IF (ICHAR(clibnc(1:1)) <= 3) THEN + PRINT *, '==========================================================' + PRINT *, 'You are using old netcdf library (',TRIM(clibnc),').' + PRINT *, 'REBUILD_NEMO support of old netcdf library will end soon' + PRINT *, 'please consider moving to netcdf 4 or higher' + PRINT *, '==========================================================' + END IF + +!1.1 Get the namelist path + !Determine the number of arguments on the command line + nargs=iargc() + !Check that the required argument is present, if it is not then set it to the default value: nam_rebuild + IF (nargs == 0) THEN + WRITE(numout,*) + WRITE(numout,*) 'W A R N I N G : Namelist path not supplied as command line argument. Using default, nam_rebuild.' + cnampath='nam_rebuild' + ELSE IF (nargs == 1) THEN + CALL getarg(1, cnampath) + ELSE + WRITE(numerr,*) 'E R R O R ! : Incorrect number of command line arguments. Please supply only' + WRITE(numerr,*) ' the path to the namelist file, or no arguments to use default value' + STOP 1 + END IF + + ! check presence of namelist + INQUIRE(FILE=cnampath, EXIST=l_namexist) + IF (.NOT. l_namexist) THEN + WRITE(numout,*) + WRITE(numout,*) 'E R R O R : Namelist '//TRIM(cnampath)//' not present.' + STOP 42 + END IF + +!1.2 Read in the namelist + + dims(:) = "" + nslicesize = 0 + deflate_level = 0 + OPEN( UNIT=numnam, FILE=TRIM(cnampath), FORM='FORMATTED', STATUS='OLD' ) + READ( numnam, nam_rebuild ) + CLOSE( numnam ) + IF( .NOT. ALL(dims(:) == "") ) l_findDims = .false. + +!1.3 Set up the filenames and fileids + + ALLOCATE(filenames(ndomain)) + IF (l_verbose) WRITE(numout,*) 'Rebuilding the following files:' + DO ifile = 1, ndomain + WRITE(suffix,'(i4.4)') ifile-1 + filenames(ifile) = TRIM(filebase)//'_'//TRIM(suffix)//'.nc' + IF (l_verbose) WRITE(numout,*) TRIM(filenames(ifile)) + END DO + ALLOCATE(inncids(ndomain)) + +!--------------------------------------------------------------------------- +!2. Read in the global dimensions from the first input file and set up the output file + + CALL check_nf90( nf90_open( TRIM(filenames(1)), nf90_share, ncid ) ) + CALL check_nf90( nf90_inquire( ncid, ndims, nvars, natts ) ) + +!2.0 Read in the total number of processors the file is expecting and check it's correct + + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_number_total', ndomain_file ) ) + IF( ndomain /= ndomain_file ) THEN + WRITE(numerr,*) 'ERROR! : number of files to rebuild in file does not agree with namelist' + WRITE(numerr,*) 'Attribute DOMAIN_number_total is : ', ndomain_file + WRITE(numerr,*) 'Number of files specified in namelist is: ', ndomain + STOP 2 + ENDIF + +!2.1 Set up the output file +#if defined key_netcdf4 + CALL check_nf90( nf90_create( TRIM(filebase)//'.nc', nf90_netcdf4, outid, chunksize=fchunksize ) ) +#else + CALL check_nf90( nf90_create( TRIM(filebase)//'.nc', nf90_64bit_offset, outid, chunksize=fchunksize ) ) +#endif + +!2.2 Set up dimensions in output file + +!2.2.0 Find out how many dimensions are required to be rebuilt and which ones they are + CALL check_nf90( nf90_inquire_attribute( ncid, nf90_global, 'DOMAIN_dimensions_ids', xtype, rbdims, attid ) ) + + ALLOCATE(rebuild_dims(rbdims)) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_dimensions_ids', rebuild_dims ) ) + + ALLOCATE(global_sizes(rbdims)) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_size_global', global_sizes ) ) + IF (l_verbose) WRITE(numout,*) 'Size of global arrays: ', global_sizes + + +!2.2.1 Copy the dimensions into the output file apart from rebuild_dims() which are dimensioned globally + ALLOCATE(indimlens(ndims), indimnames(ndims), outdimlens(ndims)) + CALL check_nf90( nf90_inquire( ncid, unlimitedDimId = unlimitedDimId ) ) + istop = 0 + DO idim = 1, ndims + CALL check_nf90( nf90_inquire_dimension( ncid, idim, dimname, dimlen ) ) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_size_local', local_sizes ) ) + indimlens(idim) = dimlen + indimnames(idim) = dimname + IF (l_findDims) THEN + IF( idim == rebuild_dims(1) ) THEN + IF( dimlen == local_sizes(1) ) THEN + dimlen = global_sizes(1) + dims(1) = trim(dimname) + ELSE + istop = 1 + ENDIF + ENDIF + IF( rbdims > 1 .AND. idim == rebuild_dims(2) ) THEN + IF( dimlen == local_sizes(2) ) THEN + dimlen = global_sizes(2) + dims(2) = trim(dimname) + ELSE + istop = 1 + ENDIF + ENDIF + ELSE ! l_findDims = false + IF( TRIM(dimname) == TRIM(dims(1))) THEN + dimlen = global_sizes(1) + rebuild_dims(1) = idim + ENDIF + IF( rbdims > 1 .AND. TRIM(dimname) == TRIM(dims(2))) THEN + dimlen = global_sizes(2) + rebuild_dims(2) = idim + ENDIF + ENDIF + + IF( idim == unlimitedDimId ) THEN + CALL check_nf90( nf90_def_dim( outid, dimname, nf90_unlimited, dimid) ) + nmax_unlimited = dimlen + ELSE + CALL check_nf90( nf90_def_dim( outid, dimname, dimlen, dimid) ) + ENDIF + outdimlens(idim) = dimlen + END DO + ! nmax_unlimited is only used for time-slicing so we set it to be at least 1 to + ! account for files with no record dimension or zero length record dimension(!) + nmax_unlimited = max(nmax_unlimited,1) + + IF( istop == 1 ) THEN + WRITE(numerr,*) 'ERROR! : DOMAIN_local_sizes attribute does not match rebuild dimension lengths in the first file' + WRITE(numerr,*) 'Attribute DOMAIN_local_sizes is : ', local_sizes + WRITE(numerr,*) 'Dimensions to be rebuilt are of size : ', outdimlens(rebuild_dims(1)), outdimlens(rebuild_dims(2)) + STOP 3 + ENDIF + + IF (l_findDims) THEN + IF (l_verbose) WRITE(numout,*) 'Finding rebuild dimensions from the first file...' + ELSE + IF (l_verbose) WRITE(numout,*) 'Using rebuild dimensions given in namelist...' + ENDIF + + IF( rbdims > 1 ) THEN + IF (l_verbose) WRITE(numout,*) 'Rebuilding across dimensions '//TRIM(indimnames(rebuild_dims(1)))// & + & ' and '//TRIM(indimnames(rebuild_dims(2))) + ELSE + IF (l_verbose) WRITE(numout,*) 'Rebuilding across dimension '//TRIM(indimnames(rebuild_dims(1))) + ENDIF + +!2.2.2 Copy the global attributes into the output file, apart from those beginning with DOMAIN_ +! Also need to change the file_name attribute and the TimeStamp attribute. + DO attid = 1, natts + CALL check_nf90( nf90_inq_attname( ncid, nf90_global, attid, attname ) ) + IF( INDEX( attname, "DOMAIN_" ) == 1 ) CYCLE + IF( INDEX( attname, "file_name") == 1 ) CYCLE + IF( INDEX( attname, "associate_file") == 1 ) CYCLE + IF (l_verbose) WRITE(numout,*) 'Copying attribute '//TRIM(attname)//' into destination file...' + CALL check_nf90( nf90_copy_att( ncid, nf90_global, attname, outid, nf90_global ) ) + END DO + CALL check_nf90( nf90_put_att( outid, nf90_global, "file_name", TRIM(filebase)//'.nc') ) + IF (l_verbose) WRITE(numout,*) 'Writing new file_name attribute' + CALL DATE_AND_TIME ( date=date, time=time, zone=zone ) + timestamp = date(7:8) // "/" // date(5:6) // "/" // date(1:4) // " " // & + time(1:2) // ":" // time(3:4) // ":" // time(5:6) // " " // & + zone + CALL check_nf90( nf90_put_att( outid, nf90_global, "TimeStamp", timestamp ) ) + IF (l_verbose) WRITE(numout,*) 'Writing new TimeStamp attribute' + +!2.2.3 Copy the variable definitions and attributes into the output file. + ALLOCATE(mdiVals(nvars)) + mdiVals(:)=0 + DO jv = 1, nvars + CALL check_nf90( nf90_inquire_variable( ncid, jv, varname, xtype, ndims, dimids, natts ) ) + ALLOCATE(outdimids(ndims)) + ALLOCATE(chunksizes(ndims)) + IF( ndims > 0 ) then + DO idim = 1, ndims + outdimids(idim) = dimids(idim) + chunksizes(idim) = outdimlens(dimids(idim)) + cdim='|'//TRIM(indimnames(dimids(idim)))//'|' + +! trick to find var in a list of suggestion (var0 and var1 : INDEX(|var0|var1|,|var|) + cdimlst='|x|x_grid_T|x_grid_U|x_grid_V|x_grid_W|' + if( INDEX(TRIM(cdimlst),TRIM(cdim)) > 0 ) & + & chunksizes(idim) = min(outdimlens(dimids(idim)), max(nc4_xchunk,1)) + + cdimlst='|y|y_grid_T|y_grid_U|y_grid_V|y_grid_W|' + if( INDEX(TRIM(cdimlst),TRIM(cdim)) > 0 ) & + & chunksizes(idim) = min(outdimlens(dimids(idim)), max(nc4_ychunk,1)) + + cdimlst='|z|deptht|depthu|depthv|depthw|depth|nav_lev|' + if( INDEX(TRIM(cdimlst),TRIM(cdim)) > 0 ) & + & chunksizes(idim) = min(outdimlens(dimids(idim)), max(nc4_zchunk,1)) + + cdimlst='|t|time|time_counter|' + if( INDEX(TRIM(cdimlst),TRIM(cdim)) > 0 ) & + & chunksizes(idim) = min(outdimlens(dimids(idim)), max(nc4_tchunk,1)) + + END DO +#if defined key_netcdf4 + CALL check_nf90( nf90_def_var( outid, varname, xtype, outdimids, varid, & + deflate_level=deflate_level ) ) + IF (l_verbose) WRITE(numout,*) 'Dims : ',ndims, outdimids(1:ndims) + IF (l_verbose) WRITE(numout,*) 'names : ',(TRIM(indimnames(dimids(idim)))//' ',idim=1,ndims) + IF (l_verbose) WRITE(numout,*) 'lens : ',(outdimlens(dimids(idim)),idim=1,ndims) + IF (l_verbose) WRITE(numout,*) 'Chunking: ',chunksizes + IF (l_verbose) WRITE(numout,*) 'Deflation : ',deflate_level + IF (l_verbose) WRITE(numout,*) 'Chunk algo: ',chunkalg + CALL check_nf90( nf90_def_var_chunking( outid, varid, chunkalg, & + & chunksizes ) ) + ELSE + CALL check_nf90( nf90_def_var( outid, varname, xtype, outdimids, varid ) ) +#else + CALL check_nf90( nf90_def_var( outid, varname, xtype, outdimids, varid ) ) +#endif + ENDIF + DEALLOCATE(outdimids) + DEALLOCATE(chunksizes) + IF (l_verbose) WRITE(numout,*) 'Defining variable '//TRIM(varname)//'...' + IF( natts > 0 ) THEN + DO attid = 1, natts + CALL check_nf90( nf90_inq_attname( ncid, varid, attid, attname ) ) + IF ( attname == "_FillValue" ) THEN + CALL check_nf90( nf90_get_att( ncid, varid, attname, rmdi ) ) + mdiVals(jv)=rmdi + ENDIF + CALL check_nf90( nf90_copy_att( ncid, varid, attname, outid, varid ) ) + END DO + ENDIF + END DO + +!2.3 End definitions in output file and copy 1st file ncid to the inncids array + + CALL check_nf90( nf90_enddef( outid ) ) + inncids(1) = ncid + IF (l_verbose) WRITE(numout,*) 'Finished defining output file.' + +!--------------------------------------------------------------------------- +!3. Read in data from each file for each variable + +!3.1 Open each file and store the ncid in inncids array + + IF (l_verbose) WRITE(numout,*) 'Opening input files...' + + ! Set a file chunk cache size for the processor-domain files that scales with the number of processors + patchchunk = max(8192, fchunksize/ndomain) + + ! open files + DO ifile = 2, ndomain + CALL check_nf90( nf90_open( TRIM(filenames(ifile)), nf90_share, ncid, chunksize=patchchunk ) ) + inncids(ifile) = ncid + END DO + IF (l_verbose) WRITE(numout,*) 'All input files open.' + + DO jv = 1, nvars + + ValMin = 1.e10 + ValMax = -1.e10 + l_valid = .false. + istop = nf90_noerr + nt = 1 + ntslice = nmax_unlimited + IF( nslicesize == 0 ) nslicesize = nmax_unlimited + +!3.2 Inquire variable to find out name and how many dimensions it has +! and importantly whether it contains the dimensions in rebuild_dims() + + ncid = inncids(1) + CALL check_nf90( nf90_inquire_variable( ncid, jv, varname, xtype, ndims, dimids, natts ) ) + + l_noRebuild = .true. + IF( ANY( dimids(1:ndims) == rebuild_dims(1) )) l_noRebuild = .false. + IF( rbdims > 1 ) THEN + IF( ANY( dimids(1:ndims) == rebuild_dims(2) )) l_noRebuild = .false. + ENDIF + +!3.2.0 start while loop for time slicing + + DO WHILE( nt <= nmax_unlimited ) + + IF( ndims > 3 ) THEN + ntslice = MIN( nslicesize, nmax_unlimited + 1 - nt ) + ENDIF + + IF (l_noRebuild) THEN + + IF( nslicesize == nmax_unlimited .OR. ndims <= 3 ) THEN + IF (l_verbose) WRITE(numout,*) 'Copying data from variable '//TRIM(varname)//'...' + ELSE + IF (l_verbose) WRITE(numout,'(A,I3,A,I3,A)') ' Copying data from variable ' & + & //TRIM(varname)//' for slices ',nt,' to ',nt+ntslice-1,' ...' + ENDIF + +!3.2.1 If rebuilding not required then just need to read in variable +! for copying direct into output file after the OMP (files) loop. + IF( ndims == 0 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i1 ) ) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i2 ) ) + CASE( NF90_INT ) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i4 ) ) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_sp ) ) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_dp ) ) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 1 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_1d_i1(indimlens(dimids(1)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i1 ) ) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_1d_i2(indimlens(dimids(1)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i2 ) ) + CASE( NF90_INT ) + ALLOCATE(globaldata_1d_i4(indimlens(dimids(1)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i4 ) ) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_1d_sp(indimlens(dimids(1)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_sp ) ) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_1d_dp(indimlens(dimids(1)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_dp ) ) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 2 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_2d_i1(indimlens(dimids(1)),indimlens(dimids(2)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i1 ) ) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_2d_i2(indimlens(dimids(1)),indimlens(dimids(2)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i2 ) ) + CASE( NF90_INT ) + ALLOCATE(globaldata_2d_i4(indimlens(dimids(1)),indimlens(dimids(2)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i4 ) ) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_2d_sp(indimlens(dimids(1)),indimlens(dimids(2)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_sp ) ) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_2d_dp(indimlens(dimids(1)),indimlens(dimids(2)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_dp ) ) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 3 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_3d_i1(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i1 ) ) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_3d_i2(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i2 ) ) + CASE( NF90_INT ) + ALLOCATE(globaldata_3d_i4(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i4 ) ) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_3d_sp(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_sp ) ) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_3d_dp(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_dp ) ) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 4 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_4d_i1(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i1, start=(/1,1,1,nt/) ) ) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_4d_i2(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i2, start=(/1,1,1,nt/) ) ) + CASE( NF90_INT ) + ALLOCATE(globaldata_4d_i4(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i4, start=(/1,1,1,nt/) ) ) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_4d_sp(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_sp, start=(/1,1,1,nt/) ) ) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_4d_dp(indimlens(dimids(1)),indimlens(dimids(2)), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_dp, start=(/1,1,1,nt/) ) ) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ENDIF + + ELSE ! l_noRebuild = .false. + +!3.2.2 For variables that require rebuilding we need to read in from all ndomain files +! Here we allocate global variables ahead of looping over files + IF( nslicesize == nmax_unlimited .OR. ndims <= 3 ) THEN + IF (l_verbose) WRITE(numout,*) 'Rebuilding data from variable '//TRIM(varname)//'...' + ELSE + IF (l_verbose) WRITE(numout,'(A,I3,A,I3,A)') ' Rebuilding data from variable ' & + & //TRIM(varname)//' for slices ',nt,' to ',nt+ntslice-1,' ...' + ENDIF + IF( ndims == 1 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_1d_i1(outdimlens(dimids(1)))) + IF (l_maskout) globaldata_1d_i1(:)=mdiVals(jv) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_1d_i2(outdimlens(dimids(1)))) + IF (l_maskout) globaldata_1d_i2(:)=mdiVals(jv) + CASE( NF90_INT ) + ALLOCATE(globaldata_1d_i4(outdimlens(dimids(1)))) + IF (l_maskout) globaldata_1d_i4(:)=mdiVals(jv) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_1d_sp(outdimlens(dimids(1)))) + IF (l_maskout) globaldata_1d_sp(:)=mdiVals(jv) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_1d_dp(outdimlens(dimids(1)))) + IF (l_maskout) globaldata_1d_dp(:)=mdiVals(jv) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 2 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_2d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)))) + IF (l_maskout) globaldata_2d_i1(:,:)=mdiVals(jv) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_2d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)))) + IF (l_maskout) globaldata_2d_i2(:,:)=mdiVals(jv) + CASE( NF90_INT ) + ALLOCATE(globaldata_2d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)))) + IF (l_maskout) globaldata_2d_i4(:,:)=mdiVals(jv) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_2d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)))) + IF (l_maskout) globaldata_2d_sp(:,:)=mdiVals(jv) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_2d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)))) + IF (l_maskout) globaldata_2d_dp(:,:)=mdiVals(jv) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 3 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_3d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)))) + IF (l_maskout) globaldata_3d_i1(:,:,:)=mdiVals(jv) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_3d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)))) + IF (l_maskout) globaldata_3d_i2(:,:,:)=mdiVals(jv) + CASE( NF90_INT ) + ALLOCATE(globaldata_3d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)))) + IF (l_maskout) globaldata_3d_i4(:,:,:)=mdiVals(jv) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_3d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)))) + IF (l_maskout) globaldata_3d_sp(:,:,:)=mdiVals(jv) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_3d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)))) + IF (l_maskout) globaldata_3d_dp(:,:,:)=mdiVals(jv) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 4 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(globaldata_4d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)),ntslice)) + IF (l_maskout) globaldata_4d_i1(:,:,:,:)=mdiVals(jv) + CASE( NF90_SHORT ) + ALLOCATE(globaldata_4d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)),ntslice)) + IF (l_maskout) globaldata_4d_i2(:,:,:,:)=mdiVals(jv) + CASE( NF90_INT ) + ALLOCATE(globaldata_4d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)),ntslice)) + IF (l_maskout) globaldata_4d_i4(:,:,:,:)=mdiVals(jv) + CASE( NF90_FLOAT ) + ALLOCATE(globaldata_4d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)),ntslice)) + IF (l_maskout) globaldata_4d_sp(:,:,:,:)=mdiVals(jv) + CASE( NF90_DOUBLE ) + ALLOCATE(globaldata_4d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)), & + & outdimlens(dimids(3)),ntslice)) + IF (l_maskout) globaldata_4d_dp(:,:,:,:)=mdiVals(jv) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + STOP 4 + END SELECT + ELSE + WRITE(numerr,*) 'ERROR! : A netcdf variable has more than 4 dimensions which is not taken into account' + STOP 4 + ENDIF + +!$OMP PARALLEL DO DEFAULT(NONE) & +!$OMP& PRIVATE(ifile,ncid,xtype,start_pos,local_sizes,InMin,InMax,natts, & +!$OMP& ndims,attid,attname,dimids,idim,dimname,dimlen,unlimitedDimId, & +!$OMP& halo_start,halo_end,idomain,jdomain,rdomain,di,dj,dr, & +!$OMP& localdata_1d_i2,localdata_1d_i4,localdata_1d_sp,localdata_1d_dp, & +!$OMP& localdata_2d_i2,localdata_2d_i4,localdata_2d_sp,localdata_2d_dp, & +!$OMP& localdata_3d_i2,localdata_3d_i4,localdata_3d_sp,localdata_3d_dp, & +!$OMP& localdata_4d_i2,localdata_4d_i4,localdata_4d_sp,localdata_4d_dp, & +!$OMP& localdata_1d_i1,localdata_2d_i1,localdata_3d_i1,localdata_4d_i1) & +!$OMP& SHARED(jv,nvars,varname,filenames,ValMin,ValMax,indimlens,outdimlens,rbdims, & +!$OMP& ndomain,outid,fchunksize,istop,l_valid,nthreads,inncids,rebuild_dims, & +!$OMP& globaldata_1d_i2,globaldata_1d_i4,globaldata_1d_sp,globaldata_1d_dp, & +!$OMP& globaldata_2d_i2,globaldata_2d_i4,globaldata_2d_sp,globaldata_2d_dp, & +!$OMP& globaldata_3d_i2,globaldata_3d_i4,globaldata_3d_sp,globaldata_3d_dp, & +!$OMP& globaldata_4d_i2,globaldata_4d_i4,globaldata_4d_sp,globaldata_4d_dp, & +!$OMP& globaldata_1d_i1,globaldata_2d_i1,globaldata_3d_i1,globaldata_4d_i1, & +!$OMP& ntslice,nt,nmax_unlimited,indimnames,dims,patchchunk) + + DO ifile = 1, ndomain + + ncid = inncids(ifile) +!$OMP CRITICAL + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_size_local', local_sizes ), istop ) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_position_first', start_pos ), istop ) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_halo_size_start', halo_start ), istop ) + CALL check_nf90( nf90_get_att( ncid, nf90_global, 'DOMAIN_halo_size_end', halo_end ), istop ) + CALL check_nf90( nf90_inquire_variable( ncid, jv, varname, xtype, ndims, dimids, natts ), istop ) + CALL check_nf90( nf90_inquire( ncid, unlimitedDimId = unlimitedDimId ), istop ) +!$OMP END CRITICAL + + ! set defaults for rebuilding so that i is 1st, j 2nd + di=1 + dj=2 + + IF( rbdims == 1 ) THEN + ! override defaults above and set other variables + start_pos(2) = 1 + local_sizes(2) = outdimlens(3-dimids(2)) + halo_end(2) = 0 + halo_start(2) = 0 + di=rebuild_dims(1) + dj=3-di + ENDIF + +!3.3.1 Generate local domain interior sizes from local_sizes and halo sizes +! idomain defines the 1st and last interior points in the i direction and +! jdomain defines the 1st and last interior points in the j direction + + idomain(1) = 1 + halo_start(di) + idomain(2) = local_sizes(di) - halo_end(di) + jdomain(1) = 1 + halo_start(dj) + jdomain(2) = local_sizes(dj) - halo_end(dj) + +!3.3.2 For rbdims or more dimensions put the data array from this input file into the correct +! part of the output data array. Assume the first dimensions are those to be rebuilt. + + IF( ndims == 1 ) THEN + + IF( rebuild_dims(1) == 1 ) THEN + dr = di + rdomain = idomain + ELSE + dr = dj + rdomain = jdomain + ENDIF + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(localdata_1d_i1(local_sizes(dr))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_1d_i1 ), istop ) + DO jr = rdomain(1), rdomain(2) + globaldata_1d_i1(start_pos(dr) + jr - 1) = localdata_1d_i1(jr) + END DO + DEALLOCATE(localdata_1d_i1) + CASE( NF90_SHORT ) + ALLOCATE(localdata_1d_i2(local_sizes(dr))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_1d_i2 ), istop ) + DO jr = rdomain(1), rdomain(2) + globaldata_1d_i2(start_pos(dr) + jr - 1) = localdata_1d_i2(jr) + END DO + DEALLOCATE(localdata_1d_i2) + CASE( NF90_INT ) + ALLOCATE(localdata_1d_i4(local_sizes(dr))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_1d_i4 ), istop ) + DO jr = rdomain(1), rdomain(2) + globaldata_1d_i4(start_pos(dr) + jr - 1) = localdata_1d_i4(jr) + END DO + DEALLOCATE(localdata_1d_i4) + CASE( NF90_FLOAT ) + ALLOCATE(localdata_1d_sp(local_sizes(dr))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_1d_sp ), istop ) + DO jr = rdomain(1), rdomain(2) + globaldata_1d_sp(start_pos(dr) + jr - 1) = localdata_1d_sp(jr) + END DO + DEALLOCATE(localdata_1d_sp) + CASE( NF90_DOUBLE ) + ALLOCATE(localdata_1d_dp(local_sizes(dr))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_1d_dp ), istop ) + DO jr = rdomain(1), rdomain(2) + globaldata_1d_dp(start_pos(dr) + jr - 1) = localdata_1d_dp(jr) + END DO + DEALLOCATE(localdata_1d_dp) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + istop = istop + 1 + END SELECT + + ELSEIF( ndims == 2 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(localdata_2d_i1(local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_2d_i1 ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_2d_i1(start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_2d_i1(ji,jj) + END DO + END DO + DEALLOCATE(localdata_2d_i1) + CASE( NF90_SHORT ) + ALLOCATE(localdata_2d_i2(local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_2d_i2 ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_2d_i2(start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_2d_i2(ji,jj) + END DO + END DO + DEALLOCATE(localdata_2d_i2) + CASE( NF90_INT ) + ALLOCATE(localdata_2d_i4(local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_2d_i4 ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_2d_i4(start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_2d_i4(ji,jj) + END DO + END DO + DEALLOCATE(localdata_2d_i4) + CASE( NF90_FLOAT ) + ALLOCATE(localdata_2d_sp(local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_2d_sp ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_2d_sp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_2d_sp(ji,jj) + END DO + END DO + DEALLOCATE(localdata_2d_sp) + CASE( NF90_DOUBLE ) + ALLOCATE(localdata_2d_dp(local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_2d_dp ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_2d_dp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_2d_dp(ji,jj) + END DO + END DO + DEALLOCATE(localdata_2d_dp) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + istop = istop + 1 + END SELECT + + ELSEIF( ndims == 3 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(localdata_3d_i1(local_sizes(di),local_sizes(dj),indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_i1 ), istop ) +!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ji,jj,jk) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_3d_i1,localdata_3d_i1,di,dj) + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_3d_i1(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk) = localdata_3d_i1(ji,jj,jk) + END DO + END DO + END DO +!$OMP END PARALLEL DO + DEALLOCATE(localdata_3d_i1) + CASE( NF90_SHORT ) + ALLOCATE(localdata_3d_i2(local_sizes(di),local_sizes(dj),indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_i2 ), istop ) +!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ji,jj,jk) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_3d_i2,localdata_3d_i2,di,dj) + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_3d_i2(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk) = localdata_3d_i2(ji,jj,jk) + END DO + END DO + END DO +!$OMP END PARALLEL DO + DEALLOCATE(localdata_3d_i2) + CASE( NF90_INT ) + ALLOCATE(localdata_3d_i4(local_sizes(di),local_sizes(dj),indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_i4 ), istop ) +!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ji,jj,jk) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_3d_i4,localdata_3d_i4,di,dj) + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_3d_i4(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk) = localdata_3d_i4(ji,jj,jk) + END DO + END DO + END DO +!$OMP END PARALLEL DO + DEALLOCATE(localdata_3d_i4) + CASE( NF90_FLOAT ) + ! TG: This if statement is added to check if the 1st dimension is the corners (for lon_bounds) variables + ! TG: Had to add the unsatisfactory check for 'lon' as it failed for diaptr files + ! TG: Would like to find a better assumption for this. + IF ( trim(indimnames(dimids(1))) /= dims(1) .AND. indimnames(dimids(1)) .NE. 'lon' ) THEN + ALLOCATE(localdata_3d_sp(indimlens(dimids(1)),local_sizes(di),local_sizes(dj))) + WRITE(*,*) 'test', ifile, jv, indimlens(dimids(1)),local_sizes(di),local_sizes(dj) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_sp ), istop ) + WRITE(*,*) 'test2' + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + DO jk = 1, indimlens(dimids(1)) + globaldata_3d_sp(jk, start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_3d_sp(jk,ji,jj) + END DO + END DO + END DO + ELSE + ALLOCATE(localdata_3d_sp(local_sizes(di),local_sizes(dj),indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_sp ), istop ) +!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ji,jj,jk) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_3d_sp,localdata_3d_sp,di,dj) + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_3d_sp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk) = localdata_3d_sp(ji,jj,jk) + END DO + END DO + END DO +!$OMP END PARALLEL DO + ENDIF + DEALLOCATE(localdata_3d_sp) + CASE( NF90_DOUBLE ) + IF ( trim(indimnames(dimids(1))) /= dims(1) ) THEN + ALLOCATE(localdata_3d_dp(indimlens(dimids(1)),local_sizes(di),local_sizes(dj))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_dp ), istop ) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + DO jk = 1, indimlens(dimids(1)) + globaldata_3d_dp(jk, start_pos(di) + ji - 1, start_pos(dj) + jj - 1) = localdata_3d_dp(jk,ji,jj) + END DO + END DO + END DO + ELSE + ALLOCATE(localdata_3d_dp(local_sizes(di),local_sizes(dj),indimlens(dimids(3)))) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_3d_dp ), istop ) +!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ji,jj,jk) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_3d_dp,localdata_3d_dp,di,dj) + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_3d_dp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk) = localdata_3d_dp(ji,jj,jk) + END DO + END DO + END DO +!$OMP END PARALLEL DO + ENDIF + DEALLOCATE(localdata_3d_dp) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + istop = istop + 1 + END SELECT + + ELSEIF (ndims == 4) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + ALLOCATE(localdata_4d_i1(local_sizes(di),local_sizes(dj), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_4d_i1, start=(/1,1,1,nt/) ), istop ) +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(ji,jj,jk,jl) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_4d_i1,localdata_4d_i1,di,dj,nt,ntslice) + DO jl = 1, ntslice +!$OMP DO + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_4d_i1(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk, jl) = localdata_4d_i1(ji,jj,jk,jl) + END DO + END DO + END DO +!$OMP END DO nowait + END DO +!$OMP END PARALLEL + DEALLOCATE(localdata_4d_i1) + CASE( NF90_SHORT ) + ALLOCATE(localdata_4d_i2(local_sizes(di),local_sizes(dj), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_4d_i2, start=(/1,1,1,nt/) ), istop ) +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(ji,jj,jk,jl) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_4d_i2,localdata_4d_i2,di,dj,nt,ntslice) + DO jl = 1, ntslice +!$OMP DO + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_4d_i2(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk, jl) = localdata_4d_i2(ji,jj,jk,jl) + END DO + END DO + END DO +!$OMP END DO nowait + END DO +!$OMP END PARALLEL + DEALLOCATE(localdata_4d_i2) + CASE( NF90_INT ) + ALLOCATE(localdata_4d_i4(local_sizes(di),local_sizes(dj), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_4d_i4, start=(/1,1,1,nt/) ), istop ) +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(ji,jj,jk,jl) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_4d_i4,localdata_4d_i4,di,dj,nt,ntslice) + DO jl = 1, ntslice +!$OMP DO + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_4d_i4(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk, jl) = localdata_4d_i4(ji,jj,jk,jl) + END DO + END DO + END DO +!$OMP END DO nowait + END DO +!$OMP END PARALLEL + DEALLOCATE(localdata_4d_i4) + CASE( NF90_FLOAT ) + ALLOCATE(localdata_4d_sp(local_sizes(di),local_sizes(dj), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_4d_sp, start=(/1,1,1,nt/) ), istop ) +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(ji,jj,jk,jl) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_4d_sp,localdata_4d_sp,di,dj,nt,ntslice) + DO jl = 1, ntslice +!$OMP DO + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_4d_sp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk, jl) = localdata_4d_sp(ji,jj,jk,jl) + END DO + END DO + END DO +!$OMP END DO nowait + END DO +!$OMP END PARALLEL + DEALLOCATE(localdata_4d_sp) + CASE( NF90_DOUBLE ) + ALLOCATE(localdata_4d_dp(local_sizes(di),local_sizes(dj), & + & indimlens(dimids(3)),ntslice)) + CALL check_nf90( nf90_get_var( ncid, jv, localdata_4d_dp, start=(/1,1,1,nt/) ), istop ) +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(ji,jj,jk,jl) & +!$OMP& SHARED(idomain,jdomain,indimlens,dimids,start_pos,globaldata_4d_dp,localdata_4d_dp,di,dj,nt,ntslice) + DO jl = 1, ntslice +!$OMP DO + DO jk = 1, indimlens(dimids(3)) + DO jj = jdomain(1), jdomain(2) + DO ji = idomain(1), idomain(2) + globaldata_4d_dp(start_pos(di) + ji - 1, start_pos(dj) + jj - 1, jk, jl) = localdata_4d_dp(ji,jj,jk,jl) + END DO + END DO + END DO +!$OMP END DO nowait + END DO +!$OMP END PARALLEL + DEALLOCATE(localdata_4d_dp) + CASE DEFAULT + WRITE(numerr,*) 'Unknown nf90 type: ', xtype + istop = istop + 1 + END SELECT + + ENDIF ! l_noRebuild false + +!3.4 Work out if the valid_min and valid_max attributes exist for this variable. +! If they do then calculate the extrema over all input files. + + DO attid = 1, natts + CALL check_nf90( nf90_inq_attname( ncid, jv, attid, attname ), istop ) + IF( INDEX( attname, "valid_min" ) == 1 ) THEN + CALL check_nf90( nf90_get_att( ncid, jv, attname, InMin), istop ) + l_valid = .true. + ENDIF + IF( INDEX( attname, "valid_max" ) == 1 ) THEN + CALL check_nf90( nf90_get_att( ncid, jv, attname, InMax ), istop ) + l_valid = .true. + ENDIF + END DO + + IF (l_valid) THEN +!$OMP CRITICAL + IF( InMin < ValMin ) ValMin = InMin + IF( InMax > ValMax ) ValMax = InMax +!$OMP END CRITICAL + ENDIF + +!3.5 Abort if failure and only 1 thread + + IF( nthreads == 1 .AND. istop /= nf90_noerr ) THEN + WRITE(numerr,*) '*** NEMO rebuild failed! ***' + STOP 5 + ENDIF + + END DO ! loop over files +!$OMP END PARALLEL DO + +!3.6 Abort if any of the OMP threads failed + IF( istop /= nf90_noerr ) THEN + WRITE(numerr,*) '*** NEMO rebuild failed! ***' + STOP 5 + ENDIF + + ENDIF ! ndims > 2 + +!--------------------------------------------------------------------------- +!4. Write data to output file + + IF (l_verbose) WRITE(numout,*) 'Writing variable '//TRIM(varname)//'...' + +!4.1 If the valid min and max attributes exist then update them in the file + + IF( l_valid ) THEN + CALL check_nf90( nf90_put_att( outid, jv, "valid_min", ValMin ) ) + CALL check_nf90( nf90_put_att( outid, jv, "valid_max", ValMax ) ) + ENDIF + +!4.2 Write the data to the output file depending on how many dimensions it has + + IF( ndims == 0 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_0d_i1 ) ) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_0d_i2 ) ) + CASE( NF90_INT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_0d_i4 ) ) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_0d_sp ) ) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_0d_dp ) ) + CASE DEFAULT + WRITE(numerr,*) '0d Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 1 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_1d_i1 ) ) + DEALLOCATE(globaldata_1d_i1) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_1d_i2 ) ) + DEALLOCATE(globaldata_1d_i2) + CASE( NF90_INT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_1d_i4 ) ) + DEALLOCATE(globaldata_1d_i4) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_1d_sp ) ) + DEALLOCATE(globaldata_1d_sp) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_1d_dp ) ) + DEALLOCATE(globaldata_1d_dp) + CASE DEFAULT + WRITE(numerr,*) '1d Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 2 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_2d_i1 ) ) + DEALLOCATE(globaldata_2d_i1) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_2d_i2 ) ) + DEALLOCATE(globaldata_2d_i2) + CASE( NF90_INT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_2d_i4 ) ) + DEALLOCATE(globaldata_2d_i4) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_2d_sp ) ) + DEALLOCATE(globaldata_2d_sp) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_2d_dp ) ) + DEALLOCATE(globaldata_2d_dp) + CASE DEFAULT + WRITE(numerr,*) '2d Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 3 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_3d_i1 ) ) + DEALLOCATE(globaldata_3d_i1) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_3d_i2 ) ) + DEALLOCATE(globaldata_3d_i2) + CASE( NF90_INT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_3d_i4 ) ) + DEALLOCATE(globaldata_3d_i4) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_3d_sp ) ) + DEALLOCATE(globaldata_3d_sp) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_3d_dp ) ) + DEALLOCATE(globaldata_3d_dp) + CASE DEFAULT + WRITE(numerr,*) '3d Unknown nf90 type: ', xtype + STOP 4 + END SELECT + + ELSEIF( ndims == 4 ) THEN + + SELECT CASE( xtype ) + CASE( NF90_BYTE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_4d_i1, start=(/1,1,1,nt/) ) ) + DEALLOCATE(globaldata_4d_i1) + CASE( NF90_SHORT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_4d_i2, start=(/1,1,1,nt/) ) ) + DEALLOCATE(globaldata_4d_i2) + CASE( NF90_INT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_4d_i4, start=(/1,1,1,nt/) ) ) + DEALLOCATE(globaldata_4d_i4) + CASE( NF90_FLOAT ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_4d_sp, start=(/1,1,1,nt/) ) ) + DEALLOCATE(globaldata_4d_sp) + CASE( NF90_DOUBLE ) + CALL check_nf90( nf90_put_var( outid, jv, globaldata_4d_dp, start=(/1,1,1,nt/) ) ) + DEALLOCATE(globaldata_4d_dp) + CASE DEFAULT + WRITE(numerr,*) '4d Unknown nf90 type: ', xtype + STOP 4 + END SELECT + ! why only for big data set, test the cost. + CALL check_nf90( nf90_sync( outid ) ) ! flush buffers to disk after writing big 4D datasets + + ENDIF + + nt = nt + ntslice + + END DO ! WHILE loop + + END DO ! loop over variables + +!--------------------------------------------------------------------------- +!5. Close files + +!5.1 Close input files + + IF (l_verbose) WRITE(numout,*) 'Closing input files...' + DO ifile = 1, ndomain + ncid = inncids(ifile) + CALL check_nf90( nf90_close( ncid ) ) + END DO + +!5.2 Close output file + + IF (l_verbose) WRITE(numout,*) 'Closing output file...' + CALL check_nf90( nf90_close( outid ) ) + + IF (l_verbose) WRITE(numout,*) 'NEMO rebuild completed successfully' + IF (l_verbose) WRITE(numout,*) + +CONTAINS + + + SUBROUTINE check_nf90(status, errorFlag) + !--------------------------------------------------------------------- + ! Checks return code from nf90 library calls and warns if needed + ! If errorFlag is present then it just increments this flag (OMP use) + ! + !--------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: status + INTEGER, INTENT(INOUT), OPTIONAL :: errorFlag + !--------------------------------------------------------------------- + + IF( status /= nf90_noerr ) THEN + WRITE(numerr,*) 'ERROR! : '//TRIM(nf90_strerror(status)) + IF( PRESENT( errorFlag ) ) THEN + errorFlag = errorFlag + status + ELSE + WRITE(numerr,*) "*** NEMO rebuild failed ***" + WRITE(numerr,*) + STOP 5 + ENDIF + ENDIF + + END SUBROUTINE check_nf90 + + +END PROGRAM rebuild_nemo diff --git a/V4.0/nemo_sources/tools/SCOORD_GEN/namelist b/V4.0/nemo_sources/tools/SCOORD_GEN/namelist new file mode 100644 index 0000000000000000000000000000000000000000..ada5d2c6a8e360e7d16ab82014a7b186363395db --- /dev/null +++ b/V4.0/nemo_sources/tools/SCOORD_GEN/namelist @@ -0,0 +1,28 @@ +!----------------------------------------------------------------------- +&namzgr_sco ! s-coordinate or hybrid z-s-coordinate +!----------------------------------------------------------------------- + ln_s_sh94 = .false. ! Song & Haidvogel 1994 hybrid S-sigma (T)| + ln_s_sf12 = .true. ! Siddorn & Furner 2012 hybrid S-z-sigma (T)| if both are false the NEMO tanh stretching is applied + ln_sigcrit = .true. ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch + ! stretching coefficients for all functions + rn_jpk = 51 ! Number of S levels + ln_eq_taper = .false. ! Tapering of S coords near equator + cn_coord_hgr = 'coordinates.nc' ! File containing gphit (latitude) coordinate for use if ln_eq_taper=.true. + rn_sbot_min = 10.0 ! minimum depth of s-bottom surface (>0) (m) + rn_sbot_max = 7000.0 ! maximum depth of s-bottom surface (= ocean depth) (>0) (m) + rn_hc = 50.0 ! critical depth for transition to stretched coordinates + !!!!!!! Envelop bathymetry + rn_rmax = 0.3 ! maximum cut-off r-value allowed (0<r_max<1) + !!!!!!! SH94 stretching coefficients (ln_s_sh94 = .true.) + rn_theta = 6.0 ! surface control parameter (0<=theta<=20) + rn_bb = 0.8 ! stretching with SH94 s-sigma + !!!!!!! SF12 stretching coefficient (ln_s_sf12 = .true.) + rn_alpha = 4.4 ! stretching with SF12 s-sigma + rn_efold = 0.0 ! efold length scale for transition to stretched coord + rn_zs = 1.0 ! depth of surface grid box + ! bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b + rn_zb_a = 0.024 ! bathymetry scaling factor for calculating Zb + rn_zb_b = -0.2 ! offset for calculating Zb + !!!!!!!! Other stretching (not SH94 or SF12) [also uses rn_theta above] + rn_thetb = 1.0 ! bottom control parameter (0<=thetb<= 1) +/ diff --git a/V4.0/nemo_sources/tools/SCOORD_GEN/src/scoord_gen.F90 b/V4.0/nemo_sources/tools/SCOORD_GEN/src/scoord_gen.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fe491e3311021eb996e8842c27e6dc5b0931b986 --- /dev/null +++ b/V4.0/nemo_sources/tools/SCOORD_GEN/src/scoord_gen.F90 @@ -0,0 +1,664 @@ +PROGRAM SCOORD_GEN + !!---------------------------------------------------------------------- + !! *** PROGRAM scoord_gen *** + !! + !! ** Purpose : define the s-coordinate system + !! + !! ** Method : s-coordinate + !! The depth of model levels is defined as the product of an + !! analytical function by the local bathymetry, while the vertical + !! scale factors are defined as the product of the first derivative + !! of the analytical function by the bathymetry. + !! (this solution save memory as depth and scale factors are not + !! 3d fields) + !! - Read bathymetry (in meters) at t-point and compute the + !! bathymetry at u-, v-, and f-points. + !! hbatu = mi( hbatt ) + !! hbatv = mj( hbatt ) + !! hbatf = mi( mj( hbatt ) ) + !! - Compute z_gsigt, z_gsigw, z_esigt, z_esigw from an analytical + !! function and its derivative given as function. + !! z_gsigt(k) = fssig (k ) + !! z_gsigw(k) = fssig (k-0.5) + !! z_esigt(k) = fsdsig(k ) + !! z_esigw(k) = fsdsig(k-0.5) + !! Three options for stretching are give, and they can be modified + !! following the users requirements. Nevertheless, the output as + !! well as the way to compute the model levels and scale factors + !! must be respected in order to insure second order accuracy + !! schemes. + !! + !! The three methods for stretching available are: + !! + !! s_sh94 (Song and Haidvogel 1994) + !! a sinh/tanh function that allows sigma and stretched sigma + !! + !! s_sf12 (Siddorn and Furner 2012?) + !! allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! s_tanh (Madec et al 1996) + !! a cosh/tanh function that gives stretched coordinates + !! + !! ** History: 2015: Tim Graham - Code created based on online zdf_sco routine + !! + !! + !!---------------------------------------------------------------------- + ! + USE utils + IMPLICIT NONE + + + !!---------------------------------------------------------------------- + ! + ! + OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' ) + READ( numnam, namzgr_sco ) + CLOSE( numnam ) + jpk = INT(rn_jpk) + + WRITE(*,*) + WRITE(*,*) 'scoord_gen : s-coordinate or hybrid z-s-coordinate' + WRITE(*,*) '~~~~~~~~~~~' + WRITE(*,*) ' Namelist namzgr_sco' + WRITE(*,*) ' stretching coeffs ' + WRITE(*,*) ' Number of levels rn_jpk = ',rn_jpk + WRITE(*,*) ' maximum depth of s-bottom surface (>0) rn_sbot_max = ',rn_sbot_max + WRITE(*,*) ' minimum depth of s-bottom surface (>0) rn_sbot_min = ',rn_sbot_min + WRITE(*,*) ' Critical depth rn_hc = ',rn_hc + WRITE(*,*) ' maximum cut-off r-value allowed rn_rmax = ',rn_rmax + WRITE(*,*) ' Tapering in vicinity of equator ln_eq_taper = ',ln_eq_taper + WRITE(*,*) ' Horizontal Coordinate File cn_coord_hgr = ',cn_coord_hgr + WRITE(*,*) ' Song and Haidvogel 1994 stretching ln_s_sh94 = ',ln_s_sh94 + WRITE(*,*) ' Song and Haidvogel 1994 stretching coefficients' + WRITE(*,*) ' surface control parameter (0<=rn_theta<=20) rn_theta = ',rn_theta + WRITE(*,*) ' bottom control parameter (0<=rn_thetb<= 1) rn_thetb = ',rn_thetb + WRITE(*,*) ' stretching parameter (song and haidvogel) rn_bb = ',rn_bb + WRITE(*,*) ' Siddorn and Furner 2012 stretching ln_s_sf12 = ',ln_s_sf12 + WRITE(*,*) ' switching to sigma (T) or Z (F) at H<Hc ln_sigcrit = ',ln_sigcrit + WRITE(*,*) ' Siddorn and Furner 2012 stretching coefficients' + WRITE(*,*) ' stretchin parameter ( >1 surface; <1 bottom) rn_alpha = ',rn_alpha + WRITE(*,*) ' e-fold length scale for transition region rn_efold = ',rn_efold + WRITE(*,*) ' Surface cell depth (Zs) (m) rn_zs = ',rn_zs + WRITE(*,*) ' Bathymetry multiplier for Zb rn_zb_a = ',rn_zb_a + WRITE(*,*) ' Offset for Zb rn_zb_b = ',rn_zb_b + WRITE(*,*) ' Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' + + + ! Read in bathy, jpi and jpj from bathy.nc + CALL read_bathy() + + !Allocate all other allocatable variables + ios = dom_oce_alloc() + IF( ios .NE. 0) THEN + WRITE(0,*) 'Unable to allocate all arrays' + STOP 1 + ENDIF + + hift(:,:) = rn_sbot_min ! set the minimum depth for the s-coordinate + hifu(:,:) = rn_sbot_min + hifv(:,:) = rn_sbot_min + hiff(:,:) = rn_sbot_min + + ! ! set maximum ocean depth + bathy(:,:) = MIN( rn_sbot_max, bathy(:,:) ) + + DO jj = 1, jpj + DO ji = 1, jpi + IF( bathy(ji,jj) > 0. ) bathy(ji,jj) = MAX( rn_sbot_min, bathy(ji,jj) ) + END DO + END DO + ! ! ============================= + ! ! Define the envelop bathymetry (hbatt) + ! ! ============================= + ! use r-value to create hybrid coordinates + zenv(:,:) = bathy(:,:) + ! + ! set first land point adjacent to a wet cell to sbot_min as this needs to be included in smoothing + DO jj = 1, jpj + DO ji = 1, jpi + IF( bathy(ji,jj) == 0. ) THEN + iip1 = MIN( ji+1, jpi ) + ijp1 = MIN( jj+1, jpj ) + iim1 = MAX( ji-1, 1 ) + ijm1 = MAX( jj-1, 1 ) + IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) + & + & bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0. ) THEN + zenv(ji,jj) = rn_sbot_min + ENDIF + ENDIF + END DO + END DO + ! + ! smooth the bathymetry (if required) + scosrf(:,:) = 0. ! ocean surface depth (here zero: no under ice-shelf sea) + scobot(:,:) = bathy(:,:) ! ocean bottom depth + ! + jl = 0 + zrmax = 1. + ! + ! + ! set scaling factor used in reducing vertical gradients + zrfact = ( 1. - rn_rmax ) / ( 1. + rn_rmax ) + ! + ! initialise temporary evelope depth arrays + ztmpi1(:,:) = zenv(:,:) + ztmpi2(:,:) = zenv(:,:) + ztmpj1(:,:) = zenv(:,:) + ztmpj2(:,:) = zenv(:,:) + ! + ! initialise temporary r-value arrays + zri(:,:) = 1. + zrj(:,:) = 1. + + ! ! ================ ! + DO WHILE( jl <= 10000 .AND. ( zrmax - rn_rmax ) > 1.e-8 ) ! Iterative loop ! + ! ! ================ ! + jl = jl + 1 + zrmax = 0. + ! we set zrmax from previous r-values (zri and zrj) first + ! if set after current r-value calculation (as previously) + ! we could exit DO WHILE prematurely before checking r-value + ! of current zenv + DO jj = 1, jpj + DO ji = 1, jpi + zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) + END DO + END DO + zri(:,:) = 0. + zrj(:,:) = 0. + DO jj = 1, jpj + DO ji = 1, jpi + iip1 = MIN(ji+1,jpi) + ijp1 = MIN(jj+1,jpj) + IF( (zenv(ji,jj) > 0.) .AND. (zenv(iip1,jj) > 0.)) THEN + zri(ji,jj) = ( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) + END IF + IF( (zenv(ji,jj) > 0.) .AND. (zenv(ji,ijp1) > 0.)) THEN + zrj(ji,jj) = ( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) + END IF + IF( zri(ji,jj) > rn_rmax ) ztmpi1(ji ,jj ) = zenv(iip1,jj ) * zrfact + IF( zri(ji,jj) < -rn_rmax ) ztmpi2(iip1,jj ) = zenv(ji ,jj ) * zrfact + IF( zrj(ji,jj) > rn_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact + IF( zrj(ji,jj) < -rn_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact + END DO + END DO + ! + WRITE(*,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax + ! + DO jj = 1, jpj + DO ji = 1, jpi + zenv(ji,jj) = MAX(zenv(ji,jj), ztmpi1(ji,jj), ztmpi2(ji,jj), ztmpj1(ji,jj), ztmpj2(ji,jj) ) + END DO + END DO + ! ! ================ ! + END DO ! End loop ! + ! ! ================ ! + DO jj = 1, jpj + DO ji = 1, jpi + zenv(ji,jj) = MAX( zenv(ji,jj), rn_sbot_min ) ! set all points to avoid undefined scale value warnings + END DO + END DO + ! + ! Envelope bathymetry saved in hbatt + hbatt(:,:) = zenv(:,:) + IF( ln_eq_taper) THEN + CALL READ_GPHIT() + IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0. ) THEN + WRITE(*,*) 's-coordinates are tapered in vicinity of the Equator' + DO jj = 1, jpj + DO ji = 1, jpi + ztaper = EXP( -(gphit(ji,jj)/8.)**2. ) + hbatt(ji,jj) = rn_sbot_max * ztaper + hbatt(ji,jj) * ( 1. - ztaper ) + END DO + END DO + ENDIF + ENDIF + ! + ! ! ============================== + ! ! hbatu, hbatv, hbatf fields + ! ! ============================== + WRITE(*,*) + WRITE(*,*) ' zgr_sco: minimum depth of the envelop topography set to : ', rn_sbot_min + hbatu(:,:) = rn_sbot_min + hbatv(:,:) = rn_sbot_min + hbatf(:,:) = rn_sbot_min + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 ! NO vector opt. + hbatu(ji,jj) = 0.50 * ( hbatt(ji ,jj) + hbatt(ji+1,jj ) ) + hbatv(ji,jj) = 0.50 * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) ) + hbatf(ji,jj) = 0.25 * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) & + & + hbatt(ji+1,jj) + hbatt(ji+1,jj+1) ) + END DO + END DO + ! + zhbat(:,:) = hbatu(:,:) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatu(ji,jj) == 0. ) THEN + IF( zhbat(ji,jj) == 0. ) hbatu(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0. ) hbatu(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + zhbat(:,:) = hbatv(:,:) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatv(ji,jj) == 0. ) THEN + IF( zhbat(ji,jj) == 0. ) hbatv(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0. ) hbatv(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + zhbat(:,:) = hbatf(:,:) + DO jj = 1, jpj + DO ji = 1, jpi + IF( hbatf(ji,jj) == 0. ) THEN + IF( zhbat(ji,jj) == 0. ) hbatf(ji,jj) = rn_sbot_min + IF( zhbat(ji,jj) /= 0. ) hbatf(ji,jj) = zhbat(ji,jj) + ENDIF + END DO + END DO + +!!bug: key_helsinki a verifer + hift(:,:) = MIN( hift(:,:), hbatt(:,:) ) + hifu(:,:) = MIN( hifu(:,:), hbatu(:,:) ) + hifv(:,:) = MIN( hifv(:,:), hbatv(:,:) ) + hiff(:,:) = MIN( hiff(:,:), hbatf(:,:) ) + + WRITE(*,*) ' MAX val hif t ', MAXVAL( hift (:,:) ), ' f ', MAXVAL( hiff (:,:) ), & + & ' u ', MAXVAL( hifu (:,:) ), ' v ', MAXVAL( hifv (:,:) ) + WRITE(*,*) ' MIN val hif t ', MINVAL( hift (:,:) ), ' f ', MINVAL( hiff (:,:) ), & + & ' u ', MINVAL( hifu (:,:) ), ' v ', MINVAL( hifv (:,:) ) + WRITE(*,*) ' MAX val hbat t ', MAXVAL( hbatt(:,:) ), ' f ', MAXVAL( hbatf(:,:) ), & + & ' u ', MAXVAL( hbatu(:,:) ), ' v ', MAXVAL( hbatv(:,:) ) + WRITE(*,*) ' MIN val hbat t ', MINVAL( hbatt(:,:) ), ' f ', MINVAL( hbatf(:,:) ), & + & ' u ', MINVAL( hbatu(:,:) ), ' v ', MINVAL( hbatv(:,:) ) + + ! Create the output file + CALL make_coord_file() + + ! ! ======================= + ! ! s-coordinate fields (gdep., e3.) + ! ! ======================= + ! + ! non-dimensional "sigma" for model level depth at w- and t-levels + + +!======================================================================== +! Song and Haidvogel 1994 (ln_s_sh94=T) +! Siddorn and Furner 2012 (ln_sf12=T) +! or tanh function (both false) +! To reduce memory loop over jpk and write each level to file +!======================================================================== + IF ( ln_s_sh94 ) THEN + CALL s_sh94() + ELSE IF ( ln_s_sf12 ) THEN + CALL s_sf12() + ELSE + CALL s_tanh() + ENDIF + +!Write all 2D variables to output file + CALL write_netcdf_2d_vars() + CALL check_nf90( nf90_close(ncout) ) + + + ! +END PROGRAM SCOORD_GEN + +!!====================================================================== + SUBROUTINE s_sh94() + + !!---------------------------------------------------------------------- + !! *** ROUTINE s_sh94 *** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch using the Song and Haidvogel 1994 + !! mixed S/sigma coordinate + !! + !! Reference : Song and Haidvogel 1994. + !!---------------------------------------------------------------------- + ! + USE utils + REAL(wp) :: zcoeft, zcoefw ! temporary scalars + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_gsigw3p1, z_gsigt3m1, z_gsi3w3m1 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_esigt3, z_esigw3, z_esigtu3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 + + ALLOCATE( z_gsigw3(jpi,jpj), z_gsigt3(jpi,jpj), z_gsi3w3(jpi,jpj) ) + ALLOCATE( z_esigt3(jpi,jpj), z_esigw3(jpi,jpj), z_esigtu3(jpi,jpj)) + ALLOCATE( z_esigtv3(jpi,jpj), z_esigtf3(jpi,jpj), z_esigwu3(jpi,jpj)) + ALLOCATE( z_esigwv3(jpi,jpj), z_gsigw3p1(jpi,jpj), z_gsigt3m1(jpi,jpj) ) + ALLOCATE( z_gsi3w3m1(jpi,jpj) ) + + z_gsigw3 = 0. ; z_gsigt3 = 0. ; z_gsi3w3 = 0. + z_esigt3 = 0. ; z_esigw3 = 0. + z_esigtu3 = 0. ; z_esigtv3 = 0. ; z_esigtf3 = 0. + z_esigwu3 = 0. ; z_esigwv3 = 0. + + DO jk = 1,jpk + DO ji = 1, jpi + DO jj = 1, jpj + + IF( hbatt(ji,jj) > rn_hc ) THEN !deep water, stretched sigma + z_gsigw3(ji,jj) = -fssig1( REAL(jk,wp)-0.5, rn_bb ) + z_gsigw3p1(ji,jj) = -fssig1( REAL(jk+1,wp)-0.5, rn_bb ) + z_gsigt3(ji,jj) = -fssig1( REAL(jk,wp) , rn_bb ) + ELSE ! shallow water, uniform sigma + z_gsigw3(ji,jj) = REAL(jk-1,wp) / REAL(jpk-1,wp) + z_gsigw3p1(ji,jj) = REAL(jk,wp) / REAL(jpk-1,wp) + z_gsigt3(ji,jj) = ( REAL(jk-1,wp) + 0.5 ) / REAL(jpk-1,wp) + ENDIF + ! + !gsi3w3m1 & gsigt3m1 only used if jk /= 1 and is set at the end of the loop over jk + IF( jk .EQ. 1) THEN + z_esigw3(ji,jj ) = 2. * ( z_gsigt3(ji,jj ) - z_gsigw3(ji,jj ) ) + z_gsi3w3(ji,jj) = 0.5 * z_esigw3(ji,jj) + ELSE + z_esigw3(ji,jj) = z_gsigt3(ji,jj) - z_gsigt3m1(ji,jj) + z_gsi3w3(ji,jj) = z_gsi3w3m1(ji,jj) + z_esigw3(ji,jj) + ENDIF + IF( jk .EQ. jpk) THEN + z_esigt3(ji,jj) = 2. * ( z_gsigt3(ji,jj) - z_gsigw3(ji,jj) ) + ELSE + z_esigt3(ji,jj ) = z_gsigw3p1(ji,jj) - z_gsigw3(ji,jj) + ENDIF + ! + + zcoeft = ( REAL(jk,wp) - 0.5 ) / REAL(jpk-1,wp) + zcoefw = ( REAL(jk,wp) - 1.0 ) / REAL(jpk-1,wp) + gdept_0(ji,jj) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj)+rn_hc*zcoeft ) + gdepw_0(ji,jj) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj)+rn_hc*zcoefw ) + gdep3w_0(ji,jj) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj)+rn_hc*zcoeft ) + ! + END DO ! for all jj's + END DO ! for all ji's + + DO ji = 1, jpi-1 + DO jj = 1, jpj-1 + z_esigtu3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj) ) & + & / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) + z_esigtv3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1) ) & + & / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) + z_esigtf3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj) & + & + hbatt(ji,jj+1)*z_esigt3(ji,jj+1)+hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1) ) & + & / ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) + z_esigwu3(ji,jj) = ( hbatt(ji,jj)*z_esigw3(ji,jj)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj) ) & + & / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) + z_esigwv3(ji,jj) = ( hbatt(ji,jj)*z_esigw3(ji,jj)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1) ) & + & / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) + ! + e3t_0(ji,jj) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj) + rn_hc/REAL(jpk-1,wp) ) + e3u_0(ji,jj) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj) + rn_hc/REAL(jpk-1,wp) ) + e3v_0(ji,jj) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj) + rn_hc/REAL(jpk-1,wp) ) + e3f_0(ji,jj) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj) + rn_hc/REAL(jpk-1,wp) ) + ! + e3w_0 (ji,jj) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj) + rn_hc/REAL(jpk-1,wp) ) + e3uw_0(ji,jj) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj) + rn_hc/REAL(jpk-1,wp) ) + e3vw_0(ji,jj) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj) + rn_hc/REAL(jpk-1,wp) ) + END DO + END DO + + z_gsigt3m1 = z_gsigt3 + z_gsi3w3m1 = z_gsi3w3 + + where (e3t_0 (:,:).eq.0.0) e3t_0(:,:) = 1.0 + where (e3u_0 (:,:).eq.0.0) e3u_0(:,:) = 1.0 + where (e3v_0 (:,:).eq.0.0) e3v_0(:,:) = 1.0 + where (e3f_0 (:,:).eq.0.0) e3f_0(:,:) = 1.0 + where (e3w_0 (:,:).eq.0.0) e3w_0(:,:) = 1.0 + where (e3uw_0 (:,:).eq.0.0) e3uw_0(:,:) = 1.0 + where (e3vw_0 (:,:).eq.0.0) e3vw_0(:,:) = 1.0 + + CALL write_netcdf_3d_vars(jk) + DO jj = 1, jpj + DO ji = 1, jpi + IF( scobot(ji,jj) >= gdept_0(ji,jj) ) mbathy(ji,jj) = MAX( 2, jk ) + IF( scobot(ji,jj) == 0. ) mbathy(ji,jj) = 0 + END DO + END DO + END DO !End of loop over jk + + DEALLOCATE( z_gsigw3, z_gsigt3, z_gsi3w3, z_gsigw3p1, z_gsigt3m1, z_gsi3w3m1) + DEALLOCATE( z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + + END SUBROUTINE s_sh94 + + SUBROUTINE s_sf12 + + !!---------------------------------------------------------------------- + !! *** ROUTINE s_sf12 *** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch using the Siddorn and Furner 2012? + !! mixed S/sigma/Z coordinate + !! + !! This method allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! + !! Reference : Siddorn and Furner 2012 (submitted Ocean modelling). + !!---------------------------------------------------------------------- + ! + USE utils + REAL(wp) :: zsmth ! smoothing around critical depth + REAL(wp) :: zzs, zzb ! Surface and bottom cell thickness in sigma space + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_gsigw3p1, z_gsigt3m1, z_gsi3w3m1 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_esigt3, z_esigw3, z_esigtu3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 + + ALLOCATE( z_gsigw3(jpi,jpj), z_gsigt3(jpi,jpj), z_gsi3w3(jpi,jpj) ) + ALLOCATE( z_esigt3(jpi,jpj), z_esigw3(jpi,jpj), z_esigtu3(jpi,jpj)) + ALLOCATE( z_esigtv3(jpi,jpj), z_esigtf3(jpi,jpj), z_esigwu3(jpi,jpj)) + ALLOCATE( z_esigwv3(jpi,jpj), z_gsigw3p1(jpi,jpj), z_gsigt3m1(jpi,jpj) ) + ALLOCATE( z_gsi3w3m1(jpi,jpj) ) + + z_gsigw3 = 0. ; z_gsigt3 = 0. ; z_gsi3w3 = 0. + z_esigt3 = 0. ; z_esigw3 = 0. + z_esigtu3 = 0. ; z_esigtv3 = 0. ; z_esigtf3 = 0. + z_esigwu3 = 0. ; z_esigwv3 = 0. + + + DO jk = 1,jpk + DO ji = 1, jpi + DO jj = 1, jpj + IF (hbatt(ji,jj)>rn_hc) THEN !deep water, stretched sigma + + zzb = hbatt(ji,jj)*rn_zb_a + rn_zb_b ! this forces a linear bottom cell depth relationship with H,. + ! could be changed by users but care must be taken to do so carefully + zzb = 1.0-(zzb/hbatt(ji,jj)) + + zzs = rn_zs / hbatt(ji,jj) + + IF (rn_efold /= 0.0) THEN + zsmth = tanh( (hbatt(ji,jj)- rn_hc ) / rn_efold ) + ELSE + zsmth = 1.0 + ENDIF + + z_gsigw3(ji,jj) = REAL(jk-1,wp) /REAL(jpk-1,wp) + z_gsigw3p1(ji,jj) = REAL(jk,wp) /REAL(jpk-1,wp) + z_gsigt3(ji,jj) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) + z_gsigw3(ji,jj) = fgamma( z_gsigw3(ji,jj), zzb, zzs, zsmth ) + z_gsigw3p1(ji,jj) = fgamma( z_gsigw3p1(ji,jj), zzb, zzs, zsmth ) + z_gsigt3(ji,jj) = fgamma( z_gsigt3(ji,jj), zzb, zzs, zsmth ) + + ELSE IF(ln_sigcrit) THEN ! shallow water, uniform sigma + + z_gsigw3(ji,jj) = REAL(jk-1,wp) /REAL(jpk-1,wp) + z_gsigw3p1(ji,jj) = REAL(jk,wp) /REAL(jpk-1,wp) + z_gsigt3(ji,jj) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) + + ELSE ! shallow water, z coordinates + + z_gsigw3(ji,jj) = REAL(jk-1,wp) /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) + z_gsigw3p1(ji,jj) = REAL(jk,wp) /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) + z_gsigt3(ji,jj) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) + + ENDIF + + !gsi3w3m1 & z_gsigt3m1 only used if jk /= 1 and is set at the end of the loop over jk + IF( jk .EQ. 1) THEN + z_esigw3(ji,jj ) = 2.0 * (z_gsigt3(ji,jj ) - z_gsigw3(ji,jj )) + z_gsi3w3(ji,jj) = 0.5 * z_esigw3(ji,jj) + ELSE + z_esigw3(ji,jj) = z_gsigt3(ji,jj) - z_gsigt3m1(ji,jj) + z_gsi3w3(ji,jj) = z_gsi3w3m1(ji,jj) + z_esigw3(ji,jj) + ENDIF + IF( jk .EQ. jpk) THEN + z_esigt3(ji,jj) = 2.0 * (z_gsigt3(ji,jj) - z_gsigw3(ji,jj)) + ELSE + z_esigt3(ji,jj) = z_gsigw3p1(ji,jj) - z_gsigw3(ji,jj) + ENDIF + + gdept_0(ji,jj) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj) + gdepw_0(ji,jj) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj) + gdep3w_0(ji,jj) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj) + + ENDDO ! for all jj's + ENDDO ! for all ji's + + DO ji=1,jpi-1 + DO jj=1,jpj-1 + + z_esigtu3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj) ) / & + ( hbatt(ji,jj)+hbatt(ji+1,jj) ) + z_esigtv3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1) ) / & + ( hbatt(ji,jj)+hbatt(ji,jj+1) ) + z_esigtf3(ji,jj) = ( hbatt(ji,jj)*z_esigt3(ji,jj)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj) + & + hbatt(ji,jj+1)*z_esigt3(ji,jj+1)+hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1) ) / & + ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) + z_esigwu3(ji,jj) = ( hbatt(ji,jj)*z_esigw3(ji,jj)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj) ) / & + ( hbatt(ji,jj)+hbatt(ji+1,jj) ) + z_esigwv3(ji,jj) = ( hbatt(ji,jj)*z_esigw3(ji,jj)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1) ) / & + ( hbatt(ji,jj)+hbatt(ji,jj+1) ) + + e3t_0(ji,jj)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj) + e3u_0(ji,jj)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj) + e3v_0(ji,jj)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj) + e3f_0(ji,jj)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj) + ! + e3w_0(ji,jj)=hbatt(ji,jj)*z_esigw3(ji,jj) + e3uw_0(ji,jj)=hbatu(ji,jj)*z_esigwu3(ji,jj) + e3vw_0(ji,jj)=hbatv(ji,jj)*z_esigwv3(ji,jj) + ENDDO + ENDDO + ! Keep some arrays for next level + z_gsigt3m1 = z_gsigt3 + z_gsi3w3m1 = z_gsi3w3 + + where (e3t_0 (:,:).eq.0.0) e3t_0(:,:) = 1.0 + where (e3u_0 (:,:).eq.0.0) e3u_0(:,:) = 1.0 + where (e3v_0 (:,:).eq.0.0) e3v_0(:,:) = 1.0 + where (e3f_0 (:,:).eq.0.0) e3f_0(:,:) = 1.0 + where (e3w_0 (:,:).eq.0.0) e3w_0(:,:) = 1.0 + where (e3uw_0 (:,:).eq.0.0) e3uw_0(:,:) = 1.0 + where (e3vw_0 (:,:).eq.0.0) e3vw_0(:,:) = 1.0 + + CALL write_netcdf_3d_vars(jk) + + DO jj = 1, jpj + DO ji = 1, jpi + IF( scobot(ji,jj) >= gdept_0(ji,jj) ) mbathy(ji,jj) = MAX( 2, jk ) + IF( scobot(ji,jj) == 0. ) mbathy(ji,jj) = 0 + END DO + END DO + + ENDDO ! End of loop over jk + + DEALLOCATE( z_gsigw3, z_gsigt3, z_gsi3w3, z_gsigw3p1, z_gsigt3m1, z_gsi3w3m1) + DEALLOCATE( z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) + + END SUBROUTINE s_sf12 + + SUBROUTINE s_tanh() + + !!---------------------------------------------------------------------- + !! *** ROUTINE s_tanh*** + !! + !! ** Purpose : stretch the s-coordinate system + !! + !! ** Method : s-coordinate stretch + !! + !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. + !!---------------------------------------------------------------------- + + USE utils + REAL(wp) :: zcoeft, zcoefw ! temporary scalars + + REAL(wp), ALLOCATABLE, DIMENSION(:) :: z_gsigw, z_gsigt, z_gsi3w + REAL(wp), ALLOCATABLE, DIMENSION(:) :: z_esigt, z_esigw + + ALLOCATE( z_gsigw(jpk), z_gsigt(jpk), z_gsi3w(jpk) ) + ALLOCATE( z_esigt(jpk), z_esigw(jpk) ) + + z_gsigw = 0. ; z_gsigt = 0. ; z_gsi3w = 0. + z_esigt = 0. ; z_esigw = 0. + + DO jk = 1, jpk + z_gsigw(jk) = -fssig( REAL(jk,wp)-0.5 ) + z_gsigt(jk) = -fssig( REAL(jk,wp) ) + END DO + WRITE(*,*) 'z_gsigw 1 jpk ', z_gsigw(1), z_gsigw(jpk) + ! + ! Coefficients for vertical scale factors at w-, t- levels +!!gm bug : define it from analytical function, not like juste bellow.... +!!gm or betteroffer the 2 possibilities.... + DO jk = 1, jpk-1 + z_esigt(jk ) = z_gsigw(jk+1) - z_gsigw(jk) + z_esigw(jk+1) = z_gsigt(jk+1) - z_gsigt(jk) + END DO + z_esigw( 1 ) = 2. * ( z_gsigt(1 ) - z_gsigw(1 ) ) + z_esigt(jpk) = 2. * ( z_gsigt(jpk) - z_gsigw(jpk) ) + ! + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w(1) = 0.5 * z_esigw(1) + DO jk = 2, jpk + z_gsi3w(jk) = z_gsi3w(jk-1) + z_esigw(jk) + END DO +!!gm: e3uw, e3vw can be suppressed (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + zcoeft = ( REAL(jk,wp) - 0.5 ) / REAL(jpk-1,wp) + zcoefw = ( REAL(jk,wp) - 1.0 ) / REAL(jpk-1,wp) + gdept_0(ji,jj) = ( scosrf(ji,jj) + (hbatt(ji,jj)-hift(ji,jj))*z_gsigt(jk) + hift(ji,jj)*zcoeft ) + gdepw_0(:,:) = ( scosrf(ji,jj) + (hbatt(ji,jj)-hift(ji,jj))*z_gsigw(jk) + hift(ji,jj)*zcoefw ) + gdep3w_0(:,:) = ( scosrf(ji,jj) + (hbatt(ji,jj)-hift(ji,jj))*z_gsi3w(jk) + hift(ji,jj)*zcoeft ) + e3t_0(ji,jj) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpk-1,wp) ) + e3u_0(ji,jj) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpk-1,wp) ) + e3v_0(ji,jj) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpk-1,wp) ) + e3f_0(ji,jj) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpk-1,wp) ) + ! + e3w_0(ji,jj) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpk-1,wp) ) + e3uw_0(ji,jj) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpk-1,wp) ) + e3vw_0(ji,jj) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpk-1,wp) ) + IF( scobot(ji,jj) >= gdept_0(ji,jj) ) mbathy(ji,jj) = MAX( 2, jk ) + IF( scobot(ji,jj) == 0. ) mbathy(ji,jj) = 0 + END DO + END DO + where (e3t_0 (:,:).eq.0.0) e3t_0(:,:) = 1.0 + where (e3u_0 (:,:).eq.0.0) e3u_0(:,:) = 1.0 + where (e3v_0 (:,:).eq.0.0) e3v_0(:,:) = 1.0 + where (e3f_0 (:,:).eq.0.0) e3f_0(:,:) = 1.0 + where (e3w_0 (:,:).eq.0.0) e3w_0(:,:) = 1.0 + where (e3uw_0 (:,:).eq.0.0) e3uw_0(:,:) = 1.0 + where (e3vw_0 (:,:).eq.0.0) e3vw_0(:,:) = 1.0 + + CALL write_netcdf_3d_vars(jk) + ENDDO ! End of loop over jk + + + DEALLOCATE( z_gsigw, z_gsigt, z_gsi3w ) + DEALLOCATE( z_esigt, z_esigw ) + + END SUBROUTINE s_tanh diff --git a/V4.0/nemo_sources/tools/SCOORD_GEN/src/utils.F90 b/V4.0/nemo_sources/tools/SCOORD_GEN/src/utils.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b74c3c496e1452329d4386f4e593726bd470a809 --- /dev/null +++ b/V4.0/nemo_sources/tools/SCOORD_GEN/src/utils.F90 @@ -0,0 +1,330 @@ +MODULE utils + + USE netcdf + + IMPLICIT NONE + PUBLIC ! allows the acces to par_oce when dom_oce is used + ! ! exception to coding rules... to be suppressed ??? + +! PUBLIC dom_oce_alloc + + INTEGER, PARAMETER :: dp=8 , sp=4, wp=dp + + !! All coordinates + !! --------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gdep3w_0 !: depth of t-points (sum of e3w) (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gdept_0, gdepw_0 !: analytical (time invariant) depth at t-w points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gphit !: latitude at t points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3v_0 , e3f_0 !: analytical (time invariant) vertical scale factors at v-f + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_0 , e3u_0 !: t-u points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3vw_0 !: analytical (time invariant) vertical scale factors at vw + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3w_0 , e3uw_0 !: w-uw points (m) + + !! s-coordinate and hybrid z-s-coordinate + !! =----------------======--------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatv , hbatf !: ocean depth at the vertical of v--f + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatt , hbatu !: t--u points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: scosrf, scobot !: ocean surface and bottom topographies + ! ! (if deviating from coordinate surfaces in HYBRID) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hifv , hiff !: interface depth between stretching at v--f + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hift , hifu !: and quasi-uniform spacing t--u points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rx1 !: Maximum grid stiffness ratio + + !!---------------------------------------------------------------------- + !! masks, bathymetry + !! --------------------------------------------------------------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbathy !: number of ocean level (=0, 1, ... , jpk-1) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters - read from file) + + !! Other variables needed by scoord_gen + INTEGER :: jpi, jpj, jpk ! Size of the domain - read from bathy or namelist? + INTEGER :: ji, jj, jk, jl ! dummy loop argument + INTEGER :: iip1, ijp1, iim1, ijm1 ! temporary integers + INTEGER :: ios ! Local integer output status for namelist read and allocation + INTEGER,PARAMETER :: numnam=8 ! File handle for namelist + REAL(wp) :: zrmax, ztaper ! temporary scalars + REAL(wp) :: zrfact + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmpi1, ztmpi2, ztmpj1, ztmpj2 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zenv, ztmp, zmsk, zri, zrj, zhbat + + !Namelist variables + REAL(wp) :: rn_jpk, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax, rn_theta + REAL(wp) :: rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b + LOGICAL :: ln_s_sh94, ln_s_sf12, ln_sigcrit, ln_eq_taper + CHARACTER(len=50) :: cn_coord_hgr + + NAMELIST/namzgr_sco/rn_jpk, ln_s_sh94, ln_s_sf12, ln_sigcrit, ln_eq_taper, & + & cn_coord_hgr, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & + & rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b + + ! IDs for output netcdf file + INTEGER :: id_x, id_y, id_z + INTEGER :: ncout + INTEGER, DIMENSION(20) :: var_ids !Array to contain all variable IDs + + CONTAINS + + INTEGER FUNCTION dom_oce_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(4) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( zenv(jpi,jpj), ztmp(jpi,jpj), zmsk(jpi,jpj), zri(jpi,jpj), zrj(jpi,jpj), & + & zhbat(jpi,jpj) , ztmpi1(jpi,jpj), ztmpi2(jpi,jpj), ztmpj1(jpi,jpj), ztmpj2(jpi,jpj), STAT=ierr(1) ) + ! + ALLOCATE( gdep3w_0(jpi,jpj) , e3v_0(jpi,jpj) , e3f_0(jpi,jpj) , & + & gdept_0(jpi,jpj) , e3t_0(jpi,jpj) , e3u_0 (jpi,jpj) , & + & gdepw_0(jpi,jpj) , e3w_0(jpi,jpj) , e3vw_0(jpi,jpj) , & + & gphit(jpi,jpj) , e3uw_0(jpi,jpj) , STAT=ierr(2) ) + ! + ! + ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) , & + & hbatt (jpi,jpj) , hbatu (jpi,jpj) , & + & scosrf(jpi,jpj) , scobot(jpi,jpj) , & + & hifv (jpi,jpj) , hiff (jpi,jpj) , & + & hift (jpi,jpj) , hifu (jpi,jpj) , rx1 (jpi,jpj) , STAT=ierr(3) ) + + ALLOCATE( mbathy(jpi,jpj) , STAT=ierr(4) ) + ! + dom_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION dom_oce_alloc + + + SUBROUTINE read_bathy() + !! Read bathymetry from input netcdf file + INTEGER :: var_id, ncin + + CALL check_nf90( nf90_open('bathy_meter.nc', NF90_NOWRITE, ncin), 'Error opening bathy_meter.nc file' ) + + ! Find the size of the input bathymetry + CALL dimlen(ncin, 'lon', jpi) + CALL dimlen(ncin, 'lat', jpj) + + ALLOCATE( bathy(jpi, jpj) ) + + ! Read the bathymetry variable from file + CALL check_nf90( nf90_inq_varid( ncin, 'Bathymetry', var_id ), 'Cannot get variable ID for bathymetry') + CALL check_nf90( nf90_get_var( ncin, var_id, bathy, (/ 1,1 /), (/ jpi, jpj /) ) ) + + CALL check_nf90( nf90_close(ncin), 'Error closing bathy.nc file' ) + + END SUBROUTINE read_bathy + + SUBROUTINE read_gphit() + !! Read gphit from horizontal coordinate file if required + INTEGER :: var_id, ncin + + CALL check_nf90( nf90_open(cn_coord_hgr, NF90_NOWRITE, ncin), 'Error opening horizontal coordinate file' ) + + ! Read gphit variable from file + CALL check_nf90( nf90_inq_varid( ncin, 'gphit', var_id ), 'Cannot get variable ID for bathymetry') + CALL check_nf90( nf90_get_var( ncin, var_id, gphit, (/ 1,1 /), (/ jpi, jpj /) ) ) + + CALL check_nf90( nf90_close(ncin), 'Error closing horizontal coordinate file' ) + + END SUBROUTINE read_gphit + + SUBROUTINE dimlen( ncid, dimname, len ) + ! Determine the length of dimension dimname + INTEGER, INTENT(in) :: ncid + CHARACTER(LEN=*), INTENT(in) :: dimname + INTEGER, INTENT(out) :: len + ! Local variables + INTEGER :: id_var + + id_var = 1 + CALL check_nf90( nf90_inq_dimid(ncid, dimname, id_var), 'Dimension not found in file') + CALL check_nf90( nf90_inquire_dimension(ncid,id_var,len=len)) + + END SUBROUTINE dimlen + + + SUBROUTINE make_coord_file() + ! Create new coordinates file and define dimensions and variables ready for + ! writing + + + !Create the file + CALL check_nf90( nf90_create('coord_zgr.nc', NF90_NETCDF4, ncout), 'Could not create output file') + ! + !Define dimensions + CALL check_nf90( nf90_def_dim(ncout, 'x', jpi, id_x) ) + CALL check_nf90( nf90_def_dim(ncout, 'y', jpj, id_y) ) + CALL check_nf90( nf90_def_dim(ncout, 'z', jpk, id_z) ) + ! + !Define variables - include all varibles that would be put into the mesh + !mask file + CALL check_nf90( nf90_def_var(ncout, 'gdept_0', nf90_double, (/id_x, id_y,id_z/), var_ids(1)) ) + CALL check_nf90( nf90_def_var(ncout, 'gdepw_0', nf90_double, (/id_x, id_y,id_z/), var_ids(2)) ) + CALL check_nf90( nf90_def_var(ncout, 'gdep3w_0', nf90_double, (/id_x, id_y,id_z/), var_ids(3)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3f_0', nf90_double, (/id_x, id_y,id_z/), var_ids(4)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3t_0', nf90_double, (/id_x, id_y,id_z/), var_ids(5)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3u_0', nf90_double, (/id_x, id_y,id_z/), var_ids(6)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3v_0', nf90_double, (/id_x, id_y,id_z/), var_ids(7)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3w_0', nf90_double, (/id_x, id_y,id_z/), var_ids(8)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3uw_0', nf90_double, (/id_x, id_y,id_z/), var_ids(9)) ) + CALL check_nf90( nf90_def_var(ncout, 'e3vw_0', nf90_double, (/id_x, id_y,id_z/), var_ids(10)) ) + ! 2D fields + CALL check_nf90( nf90_def_var(ncout, 'mbathy', nf90_double, (/id_x, id_y/), var_ids(11)) ) + CALL check_nf90( nf90_def_var(ncout, 'hbatt', nf90_double, (/id_x, id_y/), var_ids(12)) ) + CALL check_nf90( nf90_def_var(ncout, 'hbatu', nf90_double, (/id_x, id_y/), var_ids(13)) ) + CALL check_nf90( nf90_def_var(ncout, 'hbatv', nf90_double, (/id_x, id_y/), var_ids(14)) ) + CALL check_nf90( nf90_def_var(ncout, 'hbatf', nf90_double, (/id_x, id_y/), var_ids(15)) ) + CALL check_nf90( nf90_def_var(ncout, 'rx1', nf90_double, (/id_x, id_y/), var_ids(16)) ) + + + ! End define mode + CALL check_nf90( nf90_enddef(ncout) ) + + WRITE(*,*) 'Opened coord_zgr.nc file and defined variables' + + END SUBROUTINE make_coord_file + + SUBROUTINE write_netcdf_2d_vars() + + CALL check_nf90( nf90_put_var(ncout, var_ids(11), mbathy, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(12), hbatt, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(13), hbatu, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(14), hbatv, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(15), hbatf, (/ 1,1 /), (/ jpi, jpj /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(16), rx1, (/ 1,1 /), (/ jpi, jpj /) ) ) + + END SUBROUTINE write_netcdf_2d_vars + + SUBROUTINE write_netcdf_3d_vars(kk) + ! Write variables to the netcdf file at level kk + INTEGER, INTENT(in) :: kk + + CALL check_nf90( nf90_put_var(ncout, var_ids(1), gdept_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(2), gdepw_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(3), gdep3w_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(4), e3f_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(5), e3t_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(6), e3u_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(7), e3v_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(8), e3w_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(9), e3uw_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + CALL check_nf90( nf90_put_var(ncout, var_ids(10), e3vw_0, (/ 1,1,kk /), (/ jpi, jpj,1 /) ) ) + + END SUBROUTINE write_netcdf_3d_vars + + SUBROUTINE check_nf90( istat, message ) + !Check for netcdf errors + INTEGER, INTENT(in) :: istat + CHARACTER(LEN=*), INTENT(in), OPTIONAL :: message + + IF (istat /= nf90_noerr) THEN + WRITE(*,*) 'ERROR! : '//TRIM(nf90_strerror(istat)) + IF ( PRESENT(message) ) THEN ; WRITE(*,*) message ; ENDIF + STOP + ENDIF + + END SUBROUTINE check_nf90 + FUNCTION fssig( pk ) RESULT( pf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fssig *** + !! + !! ** Purpose : provide the analytical function in s-coordinate + !! + !! ** Method : the function provide the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !!---------------------------------------------------------------------- +! USE utils, ONLY : wp,rn_theta,rn_thetb,jpk + IMPLICIT NONE + REAL(wp), INTENT(in) :: pk ! continuous "k" coordinate + REAL(wp) :: pf ! sigma value + !!---------------------------------------------------------------------- + ! + pf = ( TANH( rn_theta * ( -(pk-0.5) / REAL(jpk-1) + rn_thetb ) ) & + & - TANH( rn_thetb * rn_theta ) ) & + & * ( COSH( rn_theta ) & + & + COSH( rn_theta * ( 2. * rn_thetb - 1. ) ) ) & + & / ( 2. * SINH( rn_theta ) ) + ! + END FUNCTION fssig + + FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fssig1 *** + !! + !! ** Purpose : provide the Song and Haidvogel version of the analytical function in s-coordinate + !! + !! ** Method : the function provides the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !!---------------------------------------------------------------------- +! USE utils, ONLY : wp, jpk, rn_theta + IMPLICIT NONE + REAL(wp), INTENT(in) :: pk1 ! continuous "k" coordinate + REAL(wp), INTENT(in) :: pbb ! Stretching coefficient + REAL(wp) :: pf1 ! sigma value + !!---------------------------------------------------------------------- + ! + IF ( rn_theta == 0 ) then ! uniform sigma + pf1 = - ( pk1 - 0.5 ) / REAL( jpk-1 ) + ELSE ! stretched sigma + pf1 = ( 1. - pbb ) * ( SINH( rn_theta*(-(pk1-0.5)/REAL(jpk-1)) ) ) / SINH( rn_theta ) & + & + pbb * ( (TANH( rn_theta*( (-(pk1-0.5)/REAL(jpk-1)) + 0.5) ) - TANH( 0.5 * rn_theta ) ) & + & / ( 2. * TANH( 0.5 * rn_theta ) ) ) + ENDIF + ! + END FUNCTION fssig1 + + FUNCTION fgamma( pk1, pzb, pzs, psmth) RESULT( p_gamma ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fgamma *** + !! + !! ** Purpose : provide analytical function for the s-coordinate + !! + !! ** Method : the function provides the non-dimensional position of + !! T and W (i.e. between 0 and 1) + !! T-points at integer values (between 1 and jpk) + !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !! + !! This method allows the maintenance of fixed surface and or + !! bottom cell resolutions (cf. geopotential coordinates) + !! within an analytically derived stretched S-coordinate framework. + !! + !! Reference : Siddorn and Furner, in prep + !!---------------------------------------------------------------------- +! USE utils, ONLY : jpk,wp,rn_alpha + IMPLICIT NONE + REAL(wp), INTENT(in ) :: pk1 ! continuous "k" coordinate + REAL(wp) :: p_gamma ! stretched coordinate + REAL(wp), INTENT(in ) :: pzb ! Bottom box depth + REAL(wp), INTENT(in ) :: pzs ! surface box depth + REAL(wp), INTENT(in ) :: psmth ! Smoothing parameter + REAL(wp) :: za1,za2,za3 ! local variables + REAL(wp) :: zn1,zn2 ! local variables + REAL(wp) :: za,zb,zx ! local variables + !!---------------------------------------------------------------------- + ! + + zn1 = 1./(jpk-1.) + zn2 = 1. - zn1 + + za1 = (rn_alpha+2.0)*zn1**(rn_alpha+1.0)-(rn_alpha+1.0)*zn1**(rn_alpha+2.0) + za2 = (rn_alpha+2.0)*zn2**(rn_alpha+1.0)-(rn_alpha+1.0)*zn2**(rn_alpha+2.0) + za3 = (zn2**3.0 - za2)/( zn1**3.0 - za1) + + za = pzb - za3*(pzs-za1)-za2 + za = za/( zn2-0.5*(za2+zn2**2.0) - za3*(zn1-0.5*(za1+zn1**2.0) ) ) + zb = (pzs - za1 - za*( zn1-0.5*(za1+zn1**2.0 ) ) ) / (zn1**3.0 - za1) + zx = 1.0-za/2.0-zb + + p_gamma = za*(pk1*(1.0-pk1/2.0))+zb*pk1**3.0 + & + & zx*( (rn_alpha+2.0)*pk1**(rn_alpha+1.0)- & + & (rn_alpha+1.0)*pk1**(rn_alpha+2.0) ) + p_gamma = p_gamma*psmth+pk1*(1.0-psmth) + + ! + END FUNCTION fgamma + + +END MODULE utils diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/job.ksh b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/job.ksh new file mode 100755 index 0000000000000000000000000000000000000000..05c0d7f407725aa8b227f05746041d7609a289c5 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/job.ksh @@ -0,0 +1,46 @@ +#!/bin/ksh +set -x +##################################################### +# CONFIGURATION CHOICE # +##################################################### +#CONFIG=ORCA2_LIM GYRE +CONFIG=ORCA2_LIM + +##################################################### +# CONFIGURATION DESCRIPTION # +##################################################### +# each configuration is defined by: +# - INSPACE: directory the coordinate netcdf file is +# - COOR_FIL: configuration's coordinate netcdf file +# - LIST: configuration's list of sections +# +##################################################### +case $CONFIG in +# +ORCA2_LIM) +INSPACE=/dataref/rd/INITIALISATION/ORCA2 +COOR_FIL=coordinates.nc +LIST=list_sections.ascii_global +;; +# +GYRE) +INSPACE=/perm/ms/fr/ar5 +COOR_FIL=mesh_mask.nc +LIST=list_sections.ascii_GYRE +;; +# +esac + +##################################################### +# RUN # +##################################################### +BIN=diadct_sections.exe + +export CTLDIR=`pwd` +cd ${CTLDIR} +rm -f coordinates.nc ${BIN} list_sections.ascii +cp ../${BIN} . +ln -sf ${LIST} list_sections.ascii +ln -s $INSPACE/$COOR_FIL ./coordinates.nc +./${BIN} +mv section_ijglobal.diadct section_ijglobal.diadct_$CONFIG diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_GYRE b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_GYRE new file mode 100644 index 0000000000000000000000000000000000000000..85a6ee21129dfbe74af7c6b76087e9a01c28dc49 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_GYRE @@ -0,0 +1,3 @@ + -80. 14. -80. 30. 00 okstrpond noice SEC1 + -70. 14. -70. 30. 00 okstrpond noice SEC2 + -90. 20. -60. 20. 00 okstrpond noice SEC3 diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_exp b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_exp new file mode 100755 index 0000000000000000000000000000000000000000..ff50b5e686728bbcbc94f43634cc94ba15be0504 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_exp @@ -0,0 +1,27 @@ +(F7.2,1X,F7.2,1X,F7.2,1X,F7.2,1X,I2,1X,A9,1X,A5,1X,A40) + +long1 lat1 long2 lat2 nbclasse S/T transp? ice transp? section name + +-xxx.xx_-xxx.xx_-xxx.xx_-xxx.xx_ii_aaaaaaaaa_aaaaa_aaaaa.... + 100. -23.9 115. -23.9 00 nostrpond noice IND_W1 + 100. -33.8 117. -33.8 00 nostrpond noice IND_W2 + 100. -33.8 100. 2. 00 nostrpond noice IND_W3 + 122. -45. 122. -30. 00 nostrpond noice IND_S1 + 139.5 -45. 139.5 -32. 00 nostrpond noice IND_S2 + 122. -45. 139.5 -45. 00 nostrpond noice IND_S3 + 150. -28.5 165. -28.5 00 nostrpond noice IND_E1 + 148. -34. 165. -34. 00 nostrpond noice IND_E2 + 146. -41.7 165. -41.7 00 nostrpond noice IND_E3 + 165. -41.7 165. -28.5 00 nostrpond noice IND_E4 + 149. -10. 165. -10. 00 nostrpond noice IND_E6 + 165. -41.7 173. -41.7 00 nostrpond noice IND_E7 + 115. 24. 122. 17. 00 nostrpond noice IND_N1 + 125. 8. 134. -2. 00 nostrpond noice IND_N2 + 114.1 -8.45 118.9 -8.45 00 nostrpond noice IND_N3 + 121.8 -8.7 124.1 -9.7 00 nostrpond noice IND_N4 + 124.1 -9.7 127. -15. 00 nostrpond noice IND_N5 + 115. -25. 104. -4. 00 nostrpond noice IND_N6 + 116. 2.3 134. -2. 00 nostrpond noice IND_N8 + 33. -22.2 45. -22.2 00 nostrpond noice IND_AG1 + 25. -33.65 44. -33.65 00 nostrpond noice IND_AG2 + 44. -22.2 44. -33.65 00 nostrpond noice IND_AG3 diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_global b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_global new file mode 100755 index 0000000000000000000000000000000000000000..5d2c7a87e13f3cf12fe98eb356171d361d2cf350 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/list_sections.ascii_global @@ -0,0 +1,357 @@ + -68. -54.5 -60. -64.7 00 okstrpond noice ACC_Drake_Passage + 27. -73. 27. -30. 00 nostrpond noice ACC_LeCap + 116. -70. 116. -33.8 00 nostrpond noice ACC_WAUS + 147.3 -70. 147.3 -41. 00 okstrpond noice ACC_TAS + 167.4 -73. 167.4 -45.5 00 nostrpond noice ACC_NZ + -82. 73.4 -82. 74.9 00 nostrpond ice ARC_Lancaster_sound + -81. 75.1 -81. 76.6 00 nostrpond ice ARC_Jones_Strait + -76. 78.4 -72. 78.3 00 nostrpond ice ARC_Robeson_Channel + -64.6 60.3 -65. 61.5 00 nostrpond ice ARC_Hudson_Strait + 20.9 71.5 16. 77. 03 nostrpond ice ARC_Bear_Island +zsal + 0.00 +34.9 +50.0 + 33.5 68. 33.5 74. 03 nostrpond ice ARC_Kola_Section +zsal + 0.00 +34.9 +50.0 + 25. 80. 48.2 80.2 00 nostrpond ice ARC_Spitzberg_FJLand + 57. 80.3 65.9 76.4 03 nostrpond ice ARC_FJLand_NovZemlija +zsigi + 0. +27.8 +30.0 + 57. 70.7 59. 70.2 00 nostrpond ice ARC_Kara_Gate + 25. 70. 22.6 77.8 05 nostrpond ice ARC_Barents_Sea +zsigi + 0.0 +25.0 +27.8 +29.0 +30.0 + -21.5 79.5 15. 79. 05 nostrpond ice ARC_Fram_Strait +zsigi +0.0 +25.0 +27.8 +29.0 +30.0 + -81. 27.1 -73. 27. 04 nostrpond noice ATL_West_Atlantic_27N +zlay + 0. + 1000. + 6000. +20000. + -35. 15.1 -35. -8. 00 nostrpond noice ATL_Tropical_Atlantic_35W + -63. 9. -55. 20. 03 nostrpond noice ATL_South_West_Atlantic +ztem +-2.0 + 4.5 +40.0 + -35. 54. -30.5 52. 03 nostrpond noice ATL_Gibbs +zlay + 0. + 3000. +20000. + -40. -4. -40. 10. 03 nostrpond noice ATL_North_Brazil_Current_40W +zsigi + 0.0 +27.45 +30.0 + -55. -1. -50. 10. 05 nostrpond noice ATL_North_Brazil_Current_10N +zsigi + 0.0 +24.5 +27.125 +27.45 +30.0 + -53. -30.1 -40. -30. 00 nostrpond noice ATL_Brazil_Current_30S + -63 -40.1 -53. -40. 00 nostrpond noice ATL_Falklands_Current_40S + -23. -15. -23. 15. 05 nostrpond noice ATL_Atlantic_Equatorial +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + 5. -15.1 13. -15. 00 nostrpond noice ATL_Benguela_Current_15S + 10. -40. 22. -31. 00 nostrpond noice ATL_Agulhas_zone_30S + 19. -30.1 -54.0 -30.0 00 nostrpond noice ATL_Trans_Atlantic_30S + -7. 62.2 -4.5 58. 05 nostrpond noice ATL_England_Faroe +zsigi + 0.0 +25. +27.8 +29. +30.0 + -15. 65. -7. 62.2 05 nostrpond noice ATL_Iceland_Faroe +zsigi + 0.0 +25. +27.8 +29. +30.0 + -37. 66.1 -22.5 66. 05 nostrpond ice ATL_Denmark_Strait +zsigi + 0.0 +25. +27.8 +29. +30.0 + -44. 63. -35. 61. 05 nostrpond ice ATL_East_Greenland +zsigi + 0.0 +25. +27.8 +29. +30.0 + -45. 60.9 -45. 57. 05 nostrpond ice ATL_South_Greenland +zsigi + 0.0 +25. +27.8 +29. +30.0 + -50.1 55.1 -61. 55. 05 nostrpond ice ATL_Labrador_55N +zsigi + 0.0 +25. +27.8 +29. +30.0 + 8. 58.5 -2.5 57. 00 nostrpond noice ATL_England_Norway + -5.7 35.5 -5.7 36.5 00 nostrpond noice ATL_Gibraltar + -8.5 32. -8.5 38.2 00 nostrpond noice ATL_Gulf_Cadiz + -44. 60. -27. 56. 00 nostrpond noice ATL_Ovide1 + -27. 56. -16. 40. 00 nostrpond noice ATL_Ovide2 + -16. 40.1 -8.1 40. 00 nostrpond noice ATL_Portugal + -4. 48.2 -8.1 43.1 05 nostrpond noice ATL_Biscay +zsal + 0.0 +35.6 +36.0 +36.0 +50.0 + -14. 26.1 -22. 26. 00 nostrpond noice ATL_South_Canaries + -24. 32. -24. 37.9 03 nostrpond noice ATL_Acores_24W +zlay + 0. + 800. +20000. + -66.4 18.1 -63. 10. 05 nostrpond noice ATL_Antilles +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -60.1 18.1 -66.5 18.2 05 nostrpond noice ATL_Porto_Rico +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -66.5 18.1 -68.9 18.5 05 nostrpond noice ATL_Hispagnola_Porto_Rico +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -75. 20.2 -72.6 19.7 05 nostrpond noice ATL_Windward_Passage +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -77.5 18.2 -84. 14. 05 nostrpond noice ATL_Jamaica_Ridge +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -77.5 18. -76.5 20.3 05 nostrpond noice ATL_Cuba_Jamaica +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -87.3 21. -84. 22.2 05 nostrpond noice ATL_Yucatan_Strait_KANEC +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -80.5 22.5 -80.5 25.5 05 nostrpond noice ATL_Cuba_Florida +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -78.5 26.7 -80.5 27. 05 okstrpond noice ATL_Florida_Bahamas +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -70. 30.1 -82. 30. 05 nostrpond noice ATL_West_Atlantic_30N +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -70. 45. -70. 30.1 05 nostrpond noice ATL_Gulf_Stream +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -55. 30. -55. 47.9 05 nostrpond noice ATL_Gulf_Stream_2 +ztem +-2.0 + 4.5 + 7.0 +12.0 +40.0 + -55. 48.1 -3.9 48. 00 okstrpond noice ATL_Atlantic_48N + -85. 24.1 -10.8 24. 00 okstrpond noice ATL_Atlantic_24N + -75.6 24. -10.8 24. 00 okstrpond noice ATL_Atlantic_24N1 + -85. 26.1 -10.8 26. 04 okstrpond noice ATL_Atlantic_26N +zlay + 0. + 1000. + 6000. +20000. + 100. -23.9 115. -23.9 00 nostrpond noice IND_W1 + 100. -33.8 117. -33.8 00 nostrpond noice IND_W2 + 100. -33.8 100. 2. 00 nostrpond noice IND_W3 + 122. -45. 122. -30. 00 nostrpond noice IND_S1 + 139.5 -45. 139.5 -32. 00 nostrpond noice IND_S2 + 122. -45. 139.5 -45. 00 nostrpond noice IND_S3 + 150. -28.5 165. -28.5 00 nostrpond noice IND_E1 + 148. -34. 165. -34. 00 nostrpond noice IND_E2 + 146. -41.7 165. -41.7 00 nostrpond noice IND_E3 + 165. -41.7 165. -28.5 00 nostrpond noice IND_E4 + 165. -10. 165. -28.5 00 nostrpond noice IND_E5 + 149. -10. 165. -10. 00 nostrpond noice IND_E6 + 165. -41.7 173. -41.7 00 nostrpond noice IND_E7 + 115. 24. 122. 17. 00 nostrpond noice IND_N1 + 125. 8. 134. -2. 00 nostrpond noice IND_N2 + 114.1 -8.45 118.9 -8.45 00 nostrpond noice IND_N3 + 121.8 -8.7 124.1 -9.7 00 nostrpond noice IND_N4 + 124.1 -9.7 127. -15. 00 nostrpond noice IND_N5 + 115. -25. 104. -4. 00 nostrpond noice IND_N6 + 116. 2.3 134. -2. 00 nostrpond noice IND_N8 + 33. -22.2 45. -22.2 00 nostrpond noice IND_AG1 + 25. -33.65 44. -33.65 00 nostrpond noice IND_AG2 + 44. -22.2 44. -33.65 00 nostrpond noice IND_AG3 + 114. -8.5 120. -21. 05 nostrpond noice IND_Australia_Bali +zlay + 0. + 200. + 500. + 2000. +20000. + 45. 6.1 53. 6. 00 nostrpond noice IND_Somali_Current + 39. -16. 45. -18. 00 nostrpond noice IND_Mozambique_Current + 27. -32.1 40. -32. 06 nostrpond noice IND_Agulhas_Current_32S +zsigi + 0. +26.5 +26.75 +27. +27.4 +50.0 + 43.25 12.65 43.75 12.9 00 nostrpond noice IND_Bab_El_Manded + 41. 0.1 50. 0. 00 nostrpond noice IND_Indian_Equatorial + 81. -20. 81. 8. 00 nostrpond noice IND_Indian_80E + 115. -30.1 109. -30. 00 nostrpond noice IND_West_Australia + 52. -24. 47. -22. 00 nostrpond noice IND_Madagascar + 25. -30.1 120. -30. 00 nostrpond noice IND_Indian_30S +-171.5 66.2 -166.0 65.7 00 okstrpond ice ARC_Bering_Strait +-120. 47.1 142.5 47. 00 nostrpond noice PAC_Subarctic_Gyre_47N +-130. 43. -122. 47. 00 nostrpond noice PAC_OffCalif1 +-122. 40. -130. 36. 00 nostrpond noice PAC_OffCalif2 +-118. 35. -126. 31. 00 nostrpond noice PAC_OffCalif3 + 121. 24. -110.6 24. 03 okstrpond noice PAC_North_Pacific_24N +zsigi +20. +27. +30. +-137. 7. -137. 25. 00 nostrpond noice PAC_North_Pacific_137W_NEC +-137. 25. -137. 37. 00 nostrpond noice PAC_North_Pacific_137W_Kuroshio + 132.8 33. 137. 26. 00 nostrpond noice PAC_Kuroshio + 175. -20. 175. 10. 00 nostrpond noice PAC_Pacific_Equatorial_175E +-125. -10. -125. 10. 00 nostrpond noice PAC_Pacific_Equatorial_125W + -70. -17.1 -76. -17. 00 nostrpond noice PAC_Peru_Current + 152. -30.1 175. -30. 00 nostrpond noice PAC_East_Australia + 142.5 -8. 142.5 -13. 00 nostrpond noice PAC_Torres_Strait + 147. 10. 147. 50. 06 nostrpond noice PAC_Pacific_147E_10N_50N +zsigi +20. +26.6 +26.7 +26.8 +27.2 +30.0 + 165. 0. 165. 50. 06 nostrpond noice PAC_Pacific_165E +zsigi +20. +26.6 +26.7 +26.8 +27.2 +30.0 + 179.9 0. 179.9 50. 06 nostrpond noice PAC_Pacific_180E +zsigi +20. +26.6 +26.7 +26.8 +27.2 +30.0 +-140. 0. -140. 30. 06 nostrpond noice PAC_Pacific_140W +zsigi +20. +26.6 +26.7 +26.8 +27.2 +30.0 +-150. 40. -150. 60.5 00 nostrpond noice PAC_Alaskan_Gyre + 161. 55. -162. 55.5 00 nostrpond noice PAC_Bering_Sea + 137. 0. 137. 36. 00 nostrpond noice PAC_JMA_137E_0N_35N + 150. -30. -70. -30. 00 nostrpond noice PAC_Pacific_30S + 0. 38.75 0. 35.36 00 nostrpond noice MED_0E + 0. 38.75 1.37 39. 00 nostrpond noice MED_Ibiza_Channel + 9. 36.8 9. 39.37 00 nostrpond noice MED_Sardinia_Channel + 9.3 42.5 11.68 42.5 00 nostrpond noice MED_Corsica_Channel + 10.5 36.6 12.9 37.85 00 nostrpond noice MED_Sicily_Strait + 18.3 40.1 20.07 40. 00 nostrpond noice MED_Otranto_Strait + 25. 31.5 25. 35.05 00 nostrpond noice MED_Cretan_Passage + 28. 30.8 28. 37.32 00 nostrpond noice MED_Rhodes_Gyre + 25.5 35.1 28.6 37.07 00 nostrpond noice MED_Kassos_Strait + 33.4 35. 33.4 36.36 00 nostrpond noice MED_Cilician_Channel + 22.9 36.8 23.85 35.42 00 nostrpond noice MED_Kytheron_Strait + 10.08 60. 10.08, 56. 00 nostrpond noice BAL_WesternBaltic + 10. 57. 13. 57. 00 nostrpond noice BAL_Kattegat + 14. 57. 14. 53. 00 nostrpond noice BAL_Skagerrak + -53.5 47. -43. 47. 00 nostrpond noice ATL_FlemishCap + -40. -11. 20. -11.1 03 okstrpond noice ATL_11S +zsigi +0.0 +28.12 +60.0 + 25. -32. 120. -32. 00 okstrpond noice IND_Indian_32S + 150. -32. -70. -32. 00 okstrpond noice PAC_Pacific_32S diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/namelist b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/namelist new file mode 100755 index 0000000000000000000000000000000000000000..70a277d7469276c471fd433929537de6b9141ab9 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/run/namelist @@ -0,0 +1,8 @@ +&namdct +!----------------------------------------! +!nsecdebug =-1 (debug all section ! +! = 0 (no section to debug) ! +! = n (debug section # n ! +!----------------------------------------! +nsecdebug= 1 +/ diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/compute_sections.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/compute_sections.f90 new file mode 100755 index 0000000000000000000000000000000000000000..276021d6737ed93db09725accdd03b43971376d9 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/compute_sections.f90 @@ -0,0 +1,692 @@ +MODULE compute_sections + !!===================================================================== + !! *** MODULE diadct *** + !! Ocean diagnostics: Compute the transport through a section + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!=============================================================== + !! * Modules used + USE declarations + USE sections_tools + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC compsec + + !! * Module variables + +CONTAINS + + SUBROUTINE compsec(jsec,sec,lkdebug) + !!--------------------------------------------------------------------- + !! *** ROUTINE compsec *** + !! + !! ** Purpose : Compute the series of mesh points that represent the section + !! defined by its extremities. + !! + !! ** Method : + !! I. Find which cells of the mesh the section is crossing + !! II. Classification of the intersections mesh/section + !! -first classification west to east + !! -second classification south to north + !! III. Find extremities of section in the mesh + !! IV. Find the series of mesh points that form the section + !! ** Input: sec : the section to compute + !! + !! ** Output: + !!--------------------------------------------------------------------- + !! * Arguments + INTEGER,INTENT(IN) :: jsec ! number of the section + TYPE(SECTION), INTENT(INOUT) :: sec ! information about the section + LOGICAL ,INTENT(IN) :: lkdebug ! debug or not debug this section + + !! * Local variables + INTEGER :: & + ji,jj , & ! dummy loop argument + jseg , & ! loop on segments that form the section + nb_inmesh , & ! number of intersections between the section and the mesh + nmesh ! number of cells in processor domain + INTEGER :: itest , jtest ! dummy integer + REAL(wp) :: & + zdistEst , zdistNorth , zdistWest , zdistSouth , &! temporary scalars + zdistEst2 , zdistNorth2, zdistWest2, zdistSouth2, &! temporary scalars + zdistEst3 , zdistNorth3, zdistWest3, zdistSouth3, &! temporary scalars + zdistFirst , zdistLast , zdistref , &! temporary scalars + zdistante , zdistante2 , zdistnew , zdistnew2 , &! temporary scalars + zdeltai , zdeltaj ! temporary scalars + LOGICAL :: & + ll_overlap_sec_left = .FALSE. , ll_overlap_sec_right = .FALSE. ,&! temporary logical + ll_date_domain_left = .FALSE. , ll_date_domain_right = .FALSE. ,&! temporary logical + ll_overlap_sec = .FALSE. , ll_date_domain = .FALSE. ,&! temporary logical + ll_test = .FALSE. ! temporary logical + LOGICAL :: lest, lwest, lnorth, lsouth + LOGICAL :: l_oldmethod + CHARACTER(len=120) :: cltmp + TYPE(COORD_SECTION) :: & + coord_a , coord_b , coord_d , coord_t , &!temporary point (long/lat) + coordFirst, coordLast, coordTemp ! " + TYPE(COORD_SECTION), DIMENSION(nb_point_max) :: coordSec !intersections mesh/section + TYPE(POINT_SECTION) :: & + endingPoint, prevPoint , nextPoint, &!temporary point (I/J) + SouthPoint , NorthPoint, EstPoint , WestPoint ! " + !!--------------------------------------------------------------------- + IF( jsec==1 )THEN + PRINT*,' ' + PRINT*,'COMPUTE SECTIONS' + PRINT*,'----------------' + ENDIF + + !debug + CALL write_debug(jsec,'compute section:') + CALL write_debug(jsec,'================') + + + !==================! + !0. Initializations! + !==================! + + nmesh = jpi*jpj ! number of cells in processor domain + nb_inmesh = 0 ! initialize number of intersections between section and the mesh + zdistEst =0. ; zdistNorth=0. ; zdistWest=0. ; zdistSouth=0. ! temporary scalars + zdistFirst=0. ; zdistLast =0. ! temporary scalars + zdistante =0. ; zdistante2=0. ; zdistnew=0. ; zdistnew2=0. ! temporary scalars + zdeltai=0. ; zdeltaj=0. + coord_a = COORD_SECTION( 0., 0. ) ; coord_b = COORD_SECTION( 0., 0. ) + coord_d = COORD_SECTION( 0., 0. ) ; coord_t = COORD_SECTION( 0., 0. ) + coordFirst = COORD_SECTION( 0., 0. ) ; coordLast = COORD_SECTION( 0., 0. ) + coordTemp = COORD_SECTION( 0., 0. ) ; coordSec = COORD_SECTION( 0., 0. ) + endingPoint = POINT_SECTION( -1, -1 ) + prevPoint = POINT_SECTION( -1, -1 ) ; nextPoint = POINT_SECTION( -1, -1 ) + SouthPoint = POINT_SECTION( -1, -1 ) ; NorthPoint = POINT_SECTION( -1, -1 ) + EstPoint = POINT_SECTION( -1, -1 ) ; WestPoint = POINT_SECTION( -1, -1 ) + + !===========================================================! + !I. Find which cells of the mesh the section is crossing ! + !===========================================================! + + !loop on the mesh + DO jj=2,jpj + DO ji=2,jpi + !----------------------------------------------------------- + !For each cell of the mesh, we find the intersection between + !the section and the cell as described below: + !The cell is defined by 4 points A B C D + !and the section by S1 and S2 + ! + !Section\ ________ + ! \ B| | + ! \ | | + ! \|one cell| + ! .....\ | + ! |\ | + ! | \ | + ! A|__\_____|D + ! ........\ + !----------------\------------------------------------------- + + !definition of points A,B,D (we don't need C) + coord_a = COORD_SECTION( glamf(ji-1,jj-1) ,gphif(ji-1,jj-1) ) + coord_b = COORD_SECTION( glamf(ji-1,jj) ,gphif(ji-1,jj) ) + coord_d = COORD_SECTION( glamf(ji,jj-1) ,gphif(ji,jj-1) ) + + !size of the cell + zdeltai= glamf(ji-1,jj) - glamf(ji-1,jj-1) !zdeltai=[AB] + zdeltaj= gphif(ji,jj-1) - gphif(ji-1,jj-1) !zdeltaj=[AD] + + !intersection section/[AB]=? + coordTemp = intersec(sec,coord_a,coord_b) !compute intersection + + IF( coordTemp%lon .NE. -9999 )THEN + IF( nb_inmesh+1 .GT. nb_point_max )THEN + PRINT*,"WARNING diadct: nb_point_max needs to be greater than ", nb_inmesh + ELSE + nb_inmesh=nb_inmesh+1 + coordSec(nb_inmesh) = coordTemp !store the intersection's coordinates + + !We need to know if the section crosses the overlapping band. + + !Fist we look if there is an intersection mesh/section + !just on the left of the overlapping band: + IF( coordTemp%lon .GT. glamf(1,1)-5 .AND. coordTemp%lon .LT. glamf(1,1) ) & + & ll_overlap_sec_left = .TRUE. + !And we look if there is an intersection mesh/section + !just on the right of the overlapping band: + IF( coordTemp%lon .GT. glamf(jpi,1) .AND. coordTemp%lon .LT. glamf(1,1)+5 ) & + & ll_overlap_sec_right = .TRUE. + ENDIF + ENDIF + + !intersection section/[AD]=? + coordTemp=intersec(sec,coord_a,coord_d) !compute intersection + coordTemp%lon = coordTemp%lon !* zmask(ji,jj)-9999.*(1-zmask(ji,jj)) + coordTemp%lat = coordTemp%lat !* zmask(ji,jj)-9999.*(1-zmask(ji,jj)) + + IF( coordTemp%lon .NE. -9999 )THEN + IF( nb_inmesh+1 .GT. nb_point_max )THEN + PRINT*, "WARNING diadct: nb_point_max needs to be greater than ", nb_inmesh + ELSE + nb_inmesh=nb_inmesh+1 + coordSec(nb_inmesh)=coordTemp + + !We need to know if the section crosses the overlapping band: + !same test as above + IF( coordTemp%lon .GE. glamf(1,1)-3 .AND. coordTemp%lon .LE. glamf(1,1) ) & + & ll_overlap_sec_left = .TRUE. + IF( coordTemp%lon .GE. glamf(jpi,1) .AND. coordTemp%lon .LE. glamf(jpi,1)+3) & + & ll_overlap_sec_right = .TRUE. + ENDIF + ENDIF + + !We need to know if the domain crosses the date line: + !Fist, we search a mesh point that is just one the left of date line: + IF( glamf(ji-1,jj-1) .GT. 175 .AND. glamf(ji-1,jj-1) .LT. 180 ) & + & ll_date_domain_left = .TRUE. + !And we search a mesh point that is just one the right of date line: + IF( glamf(ji-1,jj-1) .GT. -180 .AND. glamf(ji-1,jj-1) .LT. -175 ) & + & ll_date_domain_right = .TRUE. + + ENDDO + ENDDO !End of the loop on the mesh + + + !Crossing section/overlapping band (we need to know it for later): + !----------------------------------------------------------------- + !If there is one intersection mesh/section just on the left of + !the overlapping band (ll_overlap_sec_left = .TRUE.) + !AND there is one just the right of the overlapping band + !(ll_overlap_sec_right = .TRUE.), + !so the section crosses the overlapping band. + ll_overlap_sec = ll_overlap_sec_left .AND. ll_overlap_sec_right + + !Crossing of the domain and the date line (we need to know it for later): + !------------------------------------------------------------------------ + !If there is one point of the domain that is just on the left of the date line + !(ll_date_domain_left = .TRUE.) AND one point that is just on the right of the + !date line (ll_date_domain_right = .TRUE. ) + !So the domain crosses the date line: + ll_date_domain = ll_date_domain_left .AND. ll_date_domain_right + + !=====================================================! + ! II. Classification of the intersections mesh/section! + !=====================================================! + + ! -first classification west to east + ! -second classification south to north + !CAUTION: routine qcksrt doesn't work in the same way if the section + !and the domain crosse the date line (sec%ll_date_line=T and ll_date_domain=T) + + IF( sec%ll_date_line .AND. ll_date_domain )THEN + + !we add 360 to negative longitudes to have a good classification + DO jseg=1,nb_inmesh + IF( coordSec(jseg)%lon .LT. 0 ) coordSec(jseg)%lon=coordSec(jseg)%lon+360. + ENDDO + IF( sec%coordSec(1)%lon .NE. sec%coordSec(2)%lon ) THEN + CALL qcksrt(coordSec(:)%lon,coordSec(:)%lat,nb_inmesh) + ELSE + CALL qcksrt(coordSec(:)%lat,coordSec(:)%lon,nb_inmesh) + ENDIF + DO jseg=1,nb_inmesh + IF( coordSec(jseg)%lon .GT. 180 ) coordSec(jseg)%lon=coordSec(jseg)%lon-360. + ENDDO + + ELSE + + IF( sec%coordSec(1)%lon .NE. sec%coordSec(2)%lon )THEN + CALL qcksrt(coordSec(:)%lon,coordSec(:)%lat,nb_inmesh) + ELSE + CALL qcksrt(coordSec(:)%lat,coordSec(:)%lon,nb_inmesh) + ENDIF + + ENDIF + + !debug + WRITE(cltmp,'(A20,i3.3)')'number intersections = ',nb_inmesh ; CALL write_debug(jsec,cltmp) + CALL write_debug(jsec,'List of intersections between grid and section: ') + DO jseg=1,nb_inmesh + WRITE(cltmp,'(i4.4,1X,2(f8.3,1X) )')jseg,coordSec(jseg) ; CALL write_debug(jsec,cltmp) + ENDDO + + !=====================================================! + ! III. Find extremities of section in the mesh ! + !=====================================================! + !we can find section's extremities in the mesh only if + !there is intersection between section and mesh (nb_inmesh .ne. 0) + + IF( nb_inmesh .ne. 0 )THEN + coordFirst = coordSec(1) + coordLast = coordSec(nb_inmesh) + sec%nb_point = nb_inmesh + sec%listPoint(1) = POINT_SECTION(-1,-1) + zdistante = 1000. + zdistante2 = 1000. + + !First, we find the point of the mesh that is the closest + !to the first intersection section/mesh (=coordFirst=coordSec(1)): + !this point will be called sec%listPoint(1). + !Then, we find the point of the mesh that is the closest + !to the last intersection section/mesh (coordLast=coordSec(nb_inmesh)) + !this point will be called endingPoint. + + DO jj=1,jpj + DO ji=1,jpi + coord_t=COORD_SECTION(glamf(ji,jj),gphif(ji,jj)) + zdistFirst = distance2(coord_t,coordFirst) + zdistLast = distance2(coord_t,coordLast) + IF( zdistFirst .LT. zdistante )THEN + sec%listPoint(1) = POINT_SECTION(ji,jj) + zdistante=zdistFirst + ENDIF + IF( zdistLast .LT. zdistante2 )THEN + endingPoint = POINT_SECTION(ji,jj) + zdistante2=zdistLast + ENDIF + ENDDO + ENDDO + + IF( sec%listPoint(1)%I == endingPoint%I .AND. sec%listPoint(1)%J == endingPoint%J )THEN + sec%listPoint(1) = POINT_SECTION(-1,-1) + endingPoint = POINT_SECTION(-1,-1) + coordFirst = coordSec(1) + coordLast = coordSec(2) + sec%nb_point = 0 + ENDIF + + ELSE + !If there is no intersection section/mesh + sec%listPoint(1) = POINT_SECTION(-1,-1) + endingPoint = POINT_SECTION(-1,-1) + coordFirst = coordSec(1) + coordLast = coordSec(2) + sec%nb_point = 0 + ENDIF + + !debug + CALL write_debug(jsec,"extremities of section in the grid : ") + ji=sec%listPoint(1)%I ; jj=sec%listPoint(1)%J + IF( sec%nb_point .ne. 0 )THEN + ji=sec%listPoint(1)%I ; jj=sec%listPoint(1)%J + WRITE(cltmp,'(A15,X,i4.4,X,i4.4,X,f8.3,X,f8.3)')'First point: ',sec%listPoint(1),glamf(ji,jj),gphif(ji,jj) + CALL write_debug(jsec,cltmp) + ji=endingPoint%I ; jj=endingPoint%J + WRITE(cltmp,'(A15,X,i4.4,X,i4.4,X,f8.3,X,f8.3)')'Last point: ',endingPoint,glamf(ji,jj),gphif(ji,jj) + CALL write_debug(jsec,cltmp) + ! + coord_a=pointToCoordF(sec%listPoint(1)) ; coord_b=pointToCoordF(endingPoint) + ll_test = .FALSE. + IF ( ll_date_domain .AND. ABS( coord_a%lon - coord_b%lon ).GT. 180) ll_test= .TRUE. + zdistante=distance2(coord_a,coord_b ,ll_test ) + WRITE(cltmp,'(A20,f10.3)' )'distance between IJ-extremities : ',zdistante + CALL write_debug(jsec,cltmp) + ! + CALL write_debug(jsec,"Initial extremities : ") + WRITE(cltmp,'( 2(f9.3),A3,2(f9.3) )')coordFirst,'---',coordLast + CALL write_debug(jsec,cltmp) + ll_test = .FALSE. + IF( ll_date_domain .AND. ABS(coordFirst%lon - coordLast%lon).GT. 180)ll_test= .TRUE. + zdistante=distance2(coordFirst,coordLast,ll_test) + WRITE(cltmp,'(A30,f10.3)')' distance between initial extremities : ',zdistante + CALL write_debug(jsec,cltmp) + CALL write_debug(jsec," ") + ELSE + WRITE(cltmp,'(A50)' )"no intersection between section and mesh" + ENDIF + + !==========================================================! + ! IV. Find the series of mesh points that form the section ! + !==========================================================! + CALL write_debug(jsec,"Find the serie of mesh's points that form the section") + + IF( sec%nb_point .ne. 0 )THEN + + !The series of mesh points that form the section will 'link' + !sec%listPoint(1) to endingPoint: it will be stored in + !sec%listPoint(jseg) + ! + !We take place on the first point (sec%listPoint(1)) + ! a. We find the 4 adjacent points (North, South, East, West) + ! b. Compute distance between current point and endingPoint + ! c. Compute distance between the 4 adjacent points and endingPoint + ! d. Select the points which are closer to end-point than current point + ! e.1 If at least one point is selected, select the point which is closest to original section among selected points + ! e.2 If no point is selected, select the point which is the closest to end-point + ! f. save next point and direction of velocity. + ! g. Save nextPoint and go to nextPoint + ! + !We get out of this loop if: + ! - we are on endingPoint + ! - the number of points (jseg) that link sec%listPoint(1) to endingPoint is + ! twice greater than number of section/mesh intersection (nb_inmesh): + ! it could be possible if thr algorithm can't link endingPoint (bug). + + !initialize distnew value (with distance between section's extremities) + zdistnew = distance2(coordFirst,coordLast,sec%ll_date_line) + prevPoint = POINT_SECTION(0,0) + jseg = 1 + + DO WHILE ( ( sec%listPoint(jseg)%I .NE. endingPoint%I & + .OR. sec%listPoint(jseg)%J .NE. endingPoint%J ) & + .AND. jseg .LT. nb_inmesh + 10 .AND. sec%listPoint(jseg)%I .GT. 0 ) + + ! a. find the 4 adjacent points (North, South, East, West) + !--------------------------------------------------------- + SouthPoint = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J-1) + NorthPoint = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) + WestPoint = POINT_SECTION(sec%listPoint(jseg)%I-1,sec%listPoint(jseg)%J) + EstPoint = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) + + !debug + CALL write_debug(jsec,"---------------") + WRITE(cltmp,100)'Current points: ',sec%listPoint(jseg), & + glamf(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J), & + gphif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) + CALL write_debug(jsec,cltmp) + CALL write_debug(jsec,"E/W/N/S points") + WRITE(cltmp,102)EstPoint,WestPoint,NorthPoint,SouthPoint + CALL write_debug(jsec,cltmp) + itest=MIN(MAX(EstPoint%I,0),jpi+1) ; jtest=MIN(MAX(EstPoint%J,0),jpj+1) + IF( itest .NE. 0 .AND. itest .NE. jpi+1 .AND. jtest .NE. 0 .AND. jtest .NE. jpj+1 )THEN + WRITE(cltmp,101)'Est',glamf(itest,jtest),gphif(itest,jtest) + CALL write_debug(jsec,cltmp) + ELSE + CALL write_debug(jsec,"Est point out of domain") + ENDIF + ! + itest=MIN(MAX(WestPoint%I,0),jpi+1) ; jtest=MIN(MAX(WestPoint%J,0),jpj+1) + IF( itest .NE. 0 .AND. itest .NE. jpi+1 .AND. jtest .NE. 0 .AND. jtest .NE. jpj+1 )THEN + WRITE(cltmp,101)'West',glamf(itest,jtest),gphif(itest,jtest) + CALL write_debug(jsec,cltmp) + ELSE + CALL write_debug(jsec,"West point out of domain") + ENDIF + ! + itest=MIN(MAX(NorthPoint%I,0),jpi+1) ; jtest=MIN(MAX(NorthPoint%J,0),jpj+1) + IF( itest .NE. 0 .AND. itest .NE. jpi+1 .AND. jtest .NE. 0 .AND. jtest .NE. jpj+1 )THEN + WRITE(cltmp,101)'North',glamf(itest,jtest),gphif(itest,jtest) + CALL write_debug(jsec,cltmp) + ELSE + CALL write_debug(jsec,"North point out of domain") + ENDIF + ! + itest=MIN(MAX(SouthPoint%I,0),jpi+1) ; jtest=MIN(MAX(SouthPoint%J,0),jpj+1) + IF( itest .NE. 0 .AND. itest .NE. jpi+1 .AND. jtest .NE. 0 .AND. jtest .NE. jpj+1 )THEN + WRITE(cltmp,101)'South',glamf(itest,jtest),gphif(itest,jtest) + CALL write_debug(jsec,cltmp) + ELSE + CALL write_debug(jsec,"South point out of domain") + ENDIF + ! + ! +100 FORMAT ( A15,2(i4.4," "),2(f8.3," ") ) +101 FORMAT ( A6,2(f7.3," ")) +102 FORMAT ( "E ",i4.4,' ',i4.4,"//W ",i4.4,' ',i4.4,"//N ",i4.4,' ',i4.4,"//S ",i4.4,' ',i4.4 ) + + + !Either we are at an end-point + !-------------------- + IF( SouthPoint%I==endingPoint%I .AND. SouthPoint%J==endingPoint%J )THEN + sec%direction(jseg)=2 ; jseg = jseg+1 ; sec%listPoint(jseg) = SouthPoint + ELSE IF( NorthPoint%I==endingPoint%I .AND. NorthPoint%J==endingPoint%J )THEN + sec%direction(jseg)=3 ; jseg = jseg+1 ; sec%listPoint(jseg) = NorthPoint + ELSE IF( WestPoint%I==endingPoint%I .AND. WestPoint%J==endingPoint%J )THEN + sec%direction(jseg)=0 ; jseg = jseg+1 ; sec%listPoint(jseg) = WestPoint + ELSE IF( EstPoint%I==endingPoint%I .AND. EstPoint%J==endingPoint%J )THEN + sec%direction(jseg)=1 ; jseg = jseg+1 ; sec%listPoint(jseg) = EstPoint + + ELSE + !Else we are NOT on end-point + !------------------------ + + ! b. distance between current point and endingPoint + !-------------------------------------------------- + zdistante = zdistnew + + ! c. compute distance between the 4 adjacent points and endingPoint + !------------------------------------------------------------------ + ! BE CAREFUL! When the domain crosses the date line (ll_date_domain): + ! + ! When we will compute distances between W/E/S/N points and endingPoint, + ! we have to check if theses 4 lines crosses the date line + ! (test: ABS(coordTemp%lon - coordLast%lon).GT. 180) + ! + ! If one of these lines crosses the date line, we have to add 360 + ! to the longitudes of the extremities to compute the distance through + ! the date line and not around the Earth. + + ! c.1 compute distWest: distance between west point and endingPoint + !---------------------- + zdistWest2 = 99999999.9 ; zdistWest3 = 99999999.9 + IF( sec%listPoint(jseg)%I .NE. 1 )THEN + !When we are on the west side of the mesh (i=1),we can't go to the west. + coordTemp = pointToCoordF(WestPoint) + ll_test = .FALSE. + IF( ll_date_domain .AND. ABS(coordTemp%lon - coordLast%lon).GT. 180 )ll_test = .TRUE. + zdistWest2 = distance2(pointToCoordF(WestPoint) ,coordLast ,ll_test) + ENDIF + + ! c.2 compute distEst: distance between east point and endingPoint + !--------------------- + zdistEst2 = 99999999.9 ; zdistEst3 = 99999999.9 + IF( sec%listPoint(jseg)%I .EQ. jpi )THEN + !We test if the current point is on the east side of the mesh + ! The method is done such that we go toward east to link + ! sec%listPoint(1) to endingPoint. + ! So, if the section crosses the overlapping band (ll_overlap_sec=T), + ! we won't have to stop if the current point is on the EAST side of the mesh: + ! we have to follow the construction of the section on the + ! WEST side of the mesh + IF( ll_overlap_sec )THEN + !section crosses the overlapping band + !So EastPoint is on the west side of the mesh + EstPoint = POINT_SECTION(3,sec%listPoint(jseg)%J) + zdistEst2= distance2(pointToCoordF(EstPoint) ,coordLast ,.FALSE.) + ENDIF + ELSE + coordTemp = pointToCoordF(EstPoint) + ll_test = .FALSE. + IF( ll_date_domain .AND. ABS(coordTemp%lon - coordLast%lon).GT. 180 )ll_test= .TRUE. + zdistEst2 = distance2(pointToCoordF(EstPoint) ,coordLast ,ll_test ) + ENDIF + + ! c.3 compute distSouth: distance between south point and endingPoint + !----------------------- + zdistSouth2 = 99999999.9 ; zdistSouth3 = 99999999.9 + IF( sec%listPoint(jseg)%J .NE. 1 )THEN + !When we are on the south side of the mesh (j=1),we can't go to the south. + coordTemp=pointToCoordF(SouthPoint) + ll_test = .FALSE. + IF( ll_date_domain .AND. ABS(coordTemp%lon - coordLast%lon).GT. 180 )ll_test= .TRUE. + zdistSouth2 = distance2(pointToCoordF(SouthPoint),coordlast ,ll_test ) + ENDIF + + ! c.4 compute distNorth: distance between north and endingPoint + !----------------------- + zdistNorth2 = 99999999.9 ; zdistNorth3 = 99999999.9 + IF( sec%listPoint(jseg)%J .NE. jpj )THEN + !When we are on the north side of the mesh (j=jpj),we can't go to the south. + coordTemp=pointToCoordF(NorthPoint) + ll_test = .FALSE. + IF( ll_date_domain .AND. ABS(coordTemp%lon - coordLast%lon).GT. 180 )ll_test= .TRUE. + zdistNorth2 = distance2(pointToCoordF(NorthPoint),coordlast ,ll_test ) + ENDIF + + ! d. select the points which are closer to end-point than current point + !---------------------------------------------------------------------- + zdistref=distance2(pointToCoordF(sec%listPoint(jseg)),coordlast ,ll_test ) + WRITE(cltmp,'( A56,f10.3 )' )'distance between actual point and last point: zdistref = ',zdistref + CALL write_debug(jsec,cltmp) + lest = .FALSE. ; IF( zdistEst2 .LE. zdistref ) lest = .TRUE. + lwest = .FALSE. ; IF( zdistwest2 .LE. zdistref ) lwest = .TRUE. + lnorth = .FALSE. ; IF( zdistnorth2 .LE. zdistref ) lnorth= .TRUE. + lsouth = .FALSE. ; IF( zdistsouth2 .LE. zdistref ) lsouth= .TRUE. + + !debug + IF( .NOT. lest )CALL write_debug(jsec,'Est point eliminated') + IF( .NOT. lwest )CALL write_debug(jsec,'West point eliminated') + IF( .NOT. lnorth )CALL write_debug(jsec,'North point eliminated') + IF( .NOT. lsouth )CALL write_debug(jsec,'South point eliminated') + + l_oldmethod = .FALSE. + + IF( ( COUNT((/lest/))+COUNT((/lwest/))+COUNT((/lnorth/))+COUNT((/lsouth/)) ) .NE. 0 )THEN + + ! e.1 If at least one point is selected, select the point + ! which is the closest to original section among selected points + !------------------------------------------------------------------- + + zdistWest3 = 9999999.9 + IF( lwest )zdistWest3 = & + distance3(pointToCoordF(sec%listPoint(1)),pointToCoordF(WestPoint) ,pointToCoordF(endingPoint) ,lkdebug ) + zdistEst3 = 9999999.9 + IF( lest )zdistEst3 = & + distance3(pointToCoordF(sec%listPoint(1)),pointToCoordF(EstPoint) ,pointToCoordF(endingPoint) ,lkdebug ) + zdistSouth3 = 9999999.9 + IF( lsouth )zdistSouth3 = & + distance3(pointToCoordF(sec%listPoint(1)),pointToCoordF(SouthPoint),pointToCoordF(endingPoint) ,lkdebug ) + zdistNorth3 = 9999999.9 + IF( lnorth )zdistNorth3 = & + distance3(pointToCoordF(sec%listPoint(1)),pointToCoordF(NorthPoint),pointToCoordF(endingPoint) ,lkdebug ) + + zdistEst3 = zdistEst3 + (1-COUNT((/lest/)) )*9999999.9 + zdistWest3 = zdistWest3 + (1-COUNT((/lwest/)) )*9999999.9 + zdistNorth3 = zdistNorth3 + (1-COUNT((/lnorth/)))*9999999.9 + zdistSouth3 = zdistSouth3 + (1-COUNT((/lsouth/)))*9999999.9 + + zdistnew = MIN(zdistEst3,zdistWest3,zdistnorth3,zdistSouth3) + + ELSE + + ! e.2 If no point is selected, select the point which is the closest to end-point + !-------------------------------------------------------------------------------- + l_oldmethod = .TRUE. + + !debug + WRITE(cltmp,'(A30,i3.3)' )'SEARCH NEW POINT WITH OLD METHOD: ',jsec + CALL write_debug(jsec,cltmp) + + !be careful! we can't go backward. + zdistNorth = zdistNorth2 ; zdistSouth = zdistSouth2 + zdistEst = zdistEst2 ; zdistWest = zdistWest2 + + IF( prevPoint%I .EQ. NorthPoint%I .AND. prevPoint%J .EQ. NorthPoint%J) THEN + zdistnew = MIN(zdistEst,zdistWest,zdistSouth) + ELSE IF(prevPoint%I .EQ. SouthPoint%I .AND. prevPoint%J .EQ. SouthPoint%J) THEN + zdistnew = MIN(zdistEst,zdistWest,zdistNorth) + ELSE IF(prevPoint%I .EQ. WestPoint%I .AND. prevPoint%J .EQ. WestPoint%J ) THEN + zdistnew = MIN(zdistEst,zdistNorth,zdistSouth) + ELSE IF(prevPoint%I .EQ. EstPoint%I .AND. prevPoint%J .EQ. EstPoint%J ) THEN + zdistnew = MIN(zdistWest,zdistNorth,zdistSouth) + ELSE + zdistnew = MIN(zdistEst,zdistWest,zdistNorth,zdistSouth) + ENDIF + + ENDIF + + !debug + WRITE(cltmp,'(A11, f8.3)')'zdistref = ',zdistref + CALL write_debug(jsec,cltmp) + WRITE(cltmp, 103 )'distance2 :',zdistEst2,zdistWest2,zdistNorth2,zdistSouth2 + CALL write_debug(jsec,cltmp) + WRITE(cltmp, 103 )'distance3 :',zdistEst3,zdistWest3,zdistNorth3,zdistSouth3 + CALL write_debug(jsec,cltmp) + WRITE(cltmp,'(A11, f8.3)')"zdistnew = ",zdistnew + CALL write_debug(jsec,cltmp) + +103 FORMAT (A12,"E",f12.3," W",f12.3," N",f12.3," S",f12.3) + + !f. save next point and direction of velocity. + !--------------------------------------------- + !nextPoint will be the one which is the closest to endingPoint. + !sec%direction will be direction between current point and nextPoint: + !It will be used to compute velocity through the segment [CurrentPoint,nextPoint}: + ! + !A:Current Point NorthPoint(I,J+1) Nextpoint=NorthPoint(I,J+1) => sec%direction=3 + ! | Nextpoint=SouthPoint(I,J-1) => sec%direction=2 + ! | Nextpoint=WestPoint(I-1,J) => sec%direction=0 + ! |==>V(I,J+1) Nextpoint=EastPoint(I+1,J) => sec%direction=1 + ! U(I,J) | U(I+1,J) + ! ^ | ^ + ! West_____|______A_______|_____EstPoint + ! Point |(I,J) (I+1,J) + ! (I-1,J) | + ! |==>V(I,J) + ! | + ! SoutPoint(I,J-1) + IF( l_oldmethod )THEN + IF( zdistnew == zdistWest ) THEN + sec%direction(jseg)=0 ; nextPoint = WestPoint + ELSE IF( zdistnew == zdistEst ) THEN + sec%direction(jseg)=1 ; nextPoint = EstPoint + ELSE IF( zdistnew == zdistSouth )THEN + sec%direction(jseg)=2 ; nextPoint = SouthPoint + ELSE IF( zdistnew == zdistNorth )THEN + sec%direction(jseg)=3 ; nextPoint= NorthPoint + ENDIF + ELSE + IF( zdistnew == zdistWest3 ) THEN + sec%direction(jseg)=0 ; nextPoint = WestPoint + ELSE IF( zdistnew == zdistEst3 ) THEN + sec%direction(jseg)=1 ; nextPoint = EstPoint + ELSE IF( zdistnew == zdistSouth3 )THEN + sec%direction(jseg)=2 ; nextPoint = SouthPoint + ELSE IF( zdistnew == zdistNorth3 )THEN + sec%direction(jseg)=3 ; nextPoint= NorthPoint + ENDIF + ENDIF + + WRITE(cltmp,'(A11, 2(i4.4,1X) )')'nextPoint = ', nextPoint + CALL write_debug(jsec,cltmp) + + !f. Save nextPoint and go to nextPoint + !------------------------------------- + prevPoint = sec%listPoint(jseg) + jseg = jseg+1 !increment of number of segments that form the section + sec%listPoint(jseg) = nextPoint !Save next point + + ENDIF ! southP/northP/WestP/EstP == endingpoint ? + + ENDDO !End of loop on jseg + sec%nb_point = jseg !Save the number of segments that form the section + + + ELSE ! isec%nb_point == 0 + DO jseg=1,nb_point_max + sec%listPoint(:)=POINT_SECTION(0,0) + ENDDO + sec%direction(:)=0. + sec%nb_point = 0 + ENDIF + + !debug + IF( sec%nb_point .ne. 0 )THEN + CALL write_debug(jsec,"-------------------------------------") + CALL write_debug(jsec,"list of points in the grid : ") + DO jseg=1,sec%nb_point + ji=sec%listPoint(jseg)%I ; jj=sec%listPoint(jseg)%J + WRITE(cltmp, '(i4.4,X,i4.4,X,i4.4,X,f8.3,X,f8.3)' )jseg,ji,jj,glamf(ji,jj),gphif(ji,jj) + CALL write_debug(jsec,cltmp) + ENDDO + + !test if we are an end-point + IF( sec%listPoint(sec%nb_point)%I .NE. endingPoint%J .AND. sec%listPoint(sec%nb_point)%J .NE. endingPoint%J )THEN + PRINT*,TRIM(sec%name)," NOT ARRIVED TO endingPoint FOR jsec = ",jsec + ENDIF + ENDIF + + !now compute new slopeSection with ij-coordinates of first and last point + sec%slopeSection = 0 ! default value + IF( sec%nb_point .ne. 0 )THEN + IF ( sec%listPoint(sec%nb_point)%I .NE. sec%listPoint(1)%I ) THEN + sec%slopeSection = REAL( ( sec%listPoint(sec%nb_point)%J - sec%listPoint(1)%J ) , wp )/ & + REAL( ( sec%listPoint(sec%nb_point)%I - sec%listPoint(1)%I ) , wp ) + ELSE + sec%slopeSection = 10000._wp + ENDIF + ENDIF + + END SUBROUTINE compsec + +END MODULE compute_sections diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/declarations.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/declarations.f90 new file mode 100755 index 0000000000000000000000000000000000000000..8db95358ae37b9a4136b223f851dce6a918dfdd6 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/declarations.f90 @@ -0,0 +1,61 @@ +MODULE declarations + !!---------------------------------------------------------------------------- + !! *** declarations global varibles + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!---------------------------------------------------------------------------- + + IMPLICIT NONE + PUBLIC + + !! * Shared module variables + INTEGER, PUBLIC, PARAMETER :: dp=8 , sp=4, wp=dp + INTEGER, PUBLIC, PARAMETER :: nb_class_max = 10 ! Max number of classes + INTEGER, PUBLIC, PARAMETER :: nb_sec_max = 150 ! Max number of sections + INTEGER, PUBLIC, PARAMETER :: nb_point_max = 2000 ! Max number of segments per section + INTEGER, PUBLIC, PARAMETER :: nb_type_class = 10 ! Max number of types of classes + INTEGER, PUBLIC, PARAMETER :: numnam=3 ! Unit for namelist + INTEGER, PUBLIC, PARAMETER :: numdctin=1 ! Unit for input file + INTEGER, PUBLIC, PARAMETER :: numdctout=2 ! Unit for output file + + INTEGER, PUBLIC :: jpi,jpj ! domain dimensions + INTEGER, PUBLIC :: nb_sec ! Number of sections read from input file + INTEGER, PUBLIC :: nsecdebug = 0 ! Number of the section to debug + + REAL(wp), PUBLIC ,DIMENSION(:,:) , ALLOCATABLE :: glamf,gphif,glamt,gphit,e1t + INTEGER, PUBLIC ,DIMENSION(nb_sec_max) :: num_sec_debug + + 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 transport + LOGICAL :: ll_ice_section ! ice surface and icevolume transport 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 section + 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 ,&! insitu 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 ! depth level classes (99 if you don't want) + 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 section + END TYPE SECTION + + TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections + + + +END MODULE declarations diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/diadct_sections.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/diadct_sections.f90 new file mode 100755 index 0000000000000000000000000000000000000000..69a4c371c6ccbfc1bc1484cf240f36f38484fc7f --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/diadct_sections.f90 @@ -0,0 +1,114 @@ +PROGRAM generate_sections + !!============================================================================== + !! *** PROGRAM generate_sections *** + !! + !! create a binary file containig the IJ positions of sections in global + !! coordinates for the diagnostic routine diadct.F90 of NEMO + !! + !! + !! History: 09/2011: Clement Bricaud ( Mercator-Ocean ) + !! + !!============================================================================== + !! * Modules used + USE declarations + USE sections_tools + USE readcoordmesh + USE readsections + USE compute_sections + USE writesections + + IMPLICIT NONE + + !! * Module Variables used + INTEGER :: iargc, narg + CHARACTER(LEN=80) :: cdum + INTEGER :: jsec ,&! loop on sections + jseg ! loop on segments (parts of the section) + CHARACTER(len=40) :: clname + LOGICAL :: llok + + NAMELIST/namdct/nsecdebug + !!============================================================================== + + PRINT*,'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + PRINT*,'CREATION OF SECTIONS FOR NEMO diadct.F90 ROUTINE' + PRINT*,'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + + !-------------------! + !1. Read namelist ! + !-------------------! + PRINT*,' ' + PRINT*,'READ NAMELIST' + PRINT*,'--------------' + + !!open, read and close namelist + nsecdebug=0 + clname='namelist' + CALL file_open(numnam,clname,llok,cdform="FORMATTED",cdstatus="OLD",cdaction="READ") + IF ( llok ) THEN + REWIND( numnam ) + READ ( numnam, namdct ) + PRINT*,' ' + PRINT*,'read namelist' + IF( nsecdebug==-1 )THEN ; PRINT*,' Debug all sections' + ELSE IF ( nsecdebug==0 )THEN ; PRINT*,' No section to debug' + ELSE IF ( nsecdebug .GE. 1 .AND. nsecdebug .LE. nb_sec_max )THEN + PRINT*,' Debug section number ',nsecdebug + ELSE + PRINT*,'Wrong number for nsecdebug = ',nsecdebug + ENDIF + ENDIF + CLOSE(numnam) + PRINT*,'read namelist ok' + + !-------------------------------------! + !2. Read coordinates and meshmask ! + !-------------------------------------! + CALL read_coord_mesh + + PRINT*,'domain sizes: ' + PRINT*,'jpi jpj = ',jpi ,jpj + PRINT*,'domain boundaries: ' + PRINT*,' 1 1 ',glamt(1,1),gphit(1,1) + PRINT*,' 1 jpj ',glamt(1,jpj),gphit(1,jpj) + PRINT*,' jpi 1 ',glamt(jpi,1),gphit(jpi,1) + PRINT*,'jpi jpj ',glamt(jpi,jpj),gphit(jpi,jpj) + + + + !----------------------! + !3. Read list_sections ! + !----------------------! + num_sec_debug(:)=0 ! Unit numbers for debug files + CALL read_list_sections + + !----------------------! + !4.Compute sections ! + !----------------------! + DO jsec=1,nb_sec + !we use compsec to generate the series of grid points making the section + IF(jsec == nsecdebug .OR. nsecdebug ==-1)THEN + CALL compsec(jsec,secs(jsec),.true.) + ELSE + CALL compsec(jsec,secs(jsec),.false.) + ENDIF + IF (jsec == nb_sec)PRINT*,'compute section ok ' + ENDDO + + !--------------------------------! + !5.Write section_ijglobal.diadct ! + !--------------------------------! + CALL write_sections + + !----------------------! + !END ! + !----------------------! + + !close debug files + DO jsec=1,nb_sec + IF( num_sec_debug(jsec) .NE. 0 )CLOSE(num_sec_debug(jsec)) + ENDDO + + PRINT*,'END END END END END END END END END END END END' + +END PROGRAM generate_sections diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readcoordmesh.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readcoordmesh.f90 new file mode 100755 index 0000000000000000000000000000000000000000..9e8a9a34b5884110d242c5fed6a6adc7c043d233 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readcoordmesh.f90 @@ -0,0 +1,199 @@ +MODULE readcoordmesh + !!===================================================================== + !! *** MODULE readcoordmesh *** + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!===================================================================== + !! * Modules used + USE netcdf + USE declarations + + IMPLICIT NONE + PRIVATE + + PUBLIC read_coord_mesh + +CONTAINS + + SUBROUTINE read_coord_mesh + !!--------------------------------------------------------------------- + !! *** ROUTINE coord_mesh_read *** + !! + !! ** Purpose : Read a coordinate file and a meshmask file in NetCDF format + !! + !!--------------------------------------------------------------------- + PRINT*,' ' + PRINT*,'READ COORDINATES AND MESHMASK' + PRINT*,'-----------------------------' + + ! Get coordinates dimensions + CALL getdim(cdfile="coordinates.nc") + + !Allocate coordinates array with domain size + ALLOCATE(glamt(jpi,jpj)) ; ALLOCATE(gphit(jpi,jpj)) + ALLOCATE(glamf(jpi,jpj)) ; ALLOCATE(gphif(jpi,jpj)) + ALLOCATE(e1t(jpi,jpj) ) + + !Read glamt + CALL read_ncdf(cdfile="coordinates.nc",cdvar="glamt",ksize=(/jpi,jpj,1,1/),ptab=glamt) + + !Read gphit + CALL read_ncdf(cdfile="coordinates.nc",cdvar="gphit",ksize=(/jpi,jpj,1,1/),ptab=gphit) + + !Read glamf + CALL read_ncdf(cdfile="coordinates.nc",cdvar="glamf",ksize=(/jpi,jpj,1,1/),ptab=glamf) + + !Read gphif + CALL read_ncdf(cdfile="coordinates.nc",cdvar="gphif",ksize=(/jpi,jpj,1,1/),ptab=gphif) + + !Read e1t + CALL read_ncdf(cdfile="coordinates.nc",cdvar="e1t",ksize=(/jpi,jpj,1,1/),ptab=e1t) + + END SUBROUTINE read_coord_mesh + + SUBROUTINE getdim(cdfile) + !!---------------------------------------------------------------------- + !! *** ROUTINE getdim *** + !! + !! ** Purpose : get dimensions of a netcdf file + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(*),INTENT(IN):: cdfile + + !! * Local declarations + INTEGER :: ncid ! file unit + INTEGER :: idims ! number of dimensions + INTEGER :: istatus, id_var ! dummy variable + CHARACTER(len=30) :: clname ! dimension name + INTEGER, ALLOCATABLE,DIMENSION(:) :: ndim ! dimension value + !!---------------------------------------------------------------------- + + !Open file + istatus=NF90_OPEN(TRIM(cdfile),nf90_nowrite,ncid) + + IF( istatus/= NF90_NOERR )THEN + PRINT*,TRIM(cdfile),' not found.stop ' ; STOP + ELSE + + ! read number of dimensions + istatus=NF90_INQUIRE(ncid,ndimensions=idims) + + ALLOCATE( ndim(idims) ) + + ! read each dimension + PRINT*,' File dimensions: ' + DO id_var=1,idims + istatus=NF90_Inquire_Dimension(ncid,id_var,clname,ndim(id_var)) + PRINT*,' ',id_var,clname,ndim(id_var) + ENDDO + + !close + istatus=NF90_CLOSE( ncid ) + IF( istatus/=NF90_NOERR )THEN + PRINT*,'Problem for closing ',TRIM(cdfile);STOP + ELSE + PRINT*,' close ',TRIM(cdfile),' OK' + ENDIF + + ENDIF + + !domain dimensions + jpi = ndim(1) + jpj = ndim(2) + + DEALLOCATE( ndim ) + END SUBROUTINE getdim + + SUBROUTINE read_ncdf(cdfile,cdvar,ksize,ptab,kstart,kcount) + !!---------------------------------------------------------------------- + !! *** ROUTINE coord_mesh_read *** + !! + !! ** Purpose : Read a coordinate and a meshmask file in NetCDF format + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(*), INTENT(IN) :: cdfile + CHARACTER(*), INTENT(IN) :: cdvar + INTEGER,DIMENSION(4),INTENT(IN) :: ksize + INTEGER,DIMENSION(4),INTENT(IN),OPTIONAL :: kstart,kcount + REAL(wp),DIMENSION(ksize(1),ksize(2),ksize(3),ksize(4)),INTENT(OUT):: ptab + + !! * Local declarations + INTEGER ::istatus,ncid,id_var,len + CHARACTER(len=30) :: clname , cdvar2 + + INTEGER :: idims + INTEGER,DIMENSION(3)::idimids + !!---------------------------------------------------------------------- + ptab=0. + PRINT*,'read ',TRIM(cdvar),' in ',TRIM(cdfile) + + !OPEN + !---- + istatus=NF90_OPEN(TRIM(cdfile),nf90_nowrite,ncid) + IF( istatus/= NF90_NOERR )THEN + PRINT*,TRIM(cdfile),' not found.stop ' ; STOP + ENDIF + + !READ + !---- + !search variable + istatus=NF90_INQ_VARID (ncid,TRIM(cdvar),id_var) + IF( istatus/=NF90_NOERR )THEN + PRINT*,TRIM(cdvar),' not found in ',TRIM(cdfile),'.stop';STOP + ENDIF + + !get variable + !------------ + istatus=nf90_inquire_variable(ncid,id_var, cdvar2, ndims=idims, dimids=idimids) + IF ( PRESENT(kstart) .AND. PRESENT(kcount) )THEN + istatus=NF90_GET_VAR(ncid,id_var,ptab,start=kstart,count=kcount) + ELSE + istatus=NF90_GET_VAR(ncid,id_var,ptab) + ENDIF + + CALL ERR_HDL(istatus) + + IF( istatus/=NF90_NOERR )THEN + PRINT*,'Problem for reading ',TRIM(cdvar),' in ',TRIM(cdfile); STOP + ELSE + PRINT*,' read ',TRIM(cdvar),' OK' + ENDIF + + !CLOSE + !----- + istatus=NF90_CLOSE( ncid ) + IF( istatus/=NF90_NOERR )THEN + PRINT*,'Problem for closing ',TRIM(cdfile);stop + ELSE + PRINT*,' close ',TRIM(cdfile),' OK' + ENDIF + + + END SUBROUTINE read_ncdf + + SUBROUTINE ERR_HDL(kstatus) + !! ---------------------------------------------------------- + !! *** SUBROUTINE err_hdl + !! + !! ** Purpose : Error handle for NetCDF routine. + !! Stop if kstatus indicates error conditions. + !! + !! History : + !! Original: J.M. Molines (01/99) + !! + !! ----------------------------------------------------------- + INTEGER, INTENT(in) :: kstatus + + !! ----------------------------------------------------------- + IF( kstatus /= NF90_NOERR ) THEN + PRINT *, 'ERROR in NETCDF routine, status=',kstatus + PRINT *,NF90_STRERROR(kstatus) + STOP + END IF + + END SUBROUTINE ERR_HDL + +END MODULE readcoordmesh diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readsections.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readsections.f90 new file mode 100755 index 0000000000000000000000000000000000000000..ac727d018974c25b3c91e6f778c51abb3cd99ac6 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/readsections.f90 @@ -0,0 +1,200 @@ +MODULE readsections + !!===================================================================== + !! *** MODULE readsections *** + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!===================================================================== + !! * Modules used + USE declarations + USE sections_tools + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC read_list_sections + +CONTAINS + + SUBROUTINE read_list_sections + !!--------------------------------------------------------------------- + !! *** ROUTINE read_list_sections *** + !! + !! ** Purpose: read ascii file 'list_sections.ascii' that contains + !! section descriptions + !! + !!--------------------------------------------------------------------- + !! * arguments + + !! * Local declarations + INTEGER :: jsec !loop on section number + INTEGER :: iost,ji + INTEGER :: iclass , jclass + LOGICAL :: llok,llstrpond,llice,lldate + REAL(wp) :: plon1,plat1,plon2,plat2 + REAL(wp) :: zslope + CHARACTER(len=5) :: clclass + CHARACTER(len=5) :: cdice + CHARACTER(len=9) :: cdstrpond + CHARACTER(len=110) :: clname,cdsecname,cltmp + REAL,DIMENSION(nb_type_class) :: zclass_value + TYPE(COORD_SECTION) :: coord_point1,coord_point2,coordTemp + TYPE(COORD_SECTION), DIMENSION(2) :: coord_sec + !!--------------------------------------------------------------------- + PRINT*,' ' + PRINT*,'READ list_sections' + PRINT*,'------------------' + PRINT*,' ' + + nb_sec=0 !initialize number of sections read in list_sections.ascii + + !open and read input file + clname='list_sections.ascii' + PRINT*,' ' + CALL file_open(numdctin,clname,llok,cdform="FORMATTED",cdstatus="OLD",cdaction="READ") + + IF ( llok ) THEN + PRINT*,'list_sections.ascii open ' + PRINT*,'nb_sec_max = ',nb_sec_max + PRINT*,' ' + + DO jsec=1,nb_sec_max + + !read a line corresponding to one section + READ(numdctin,'(F7.2,1X,F7.2,1X,F7.2,1X,F7.2,1X,I2,1X,A9,1X,A5,1X,A40)',iostat=iost) & + & plon1,plat1,plon2,plat2,iclass,cdstrpond,cdice,cdsecname + IF (iost /= 0) EXIT ! end of file + + ! cdsecname: change space to underscore for cdsecname + cdsecname=ADJUSTL(cdsecname) + ji = SCAN(TRIM(cdsecname)," ") + DO WHILE(ji .NE. 0) + cdsecname(ji:ji) = "_" + ji = SCAN(TRIM(cdsecname)," ") + ENDDO + + !computation of heat and salt transport ? + llstrpond=.FALSE. ; IF( cdstrpond .EQ. 'okstrpond' ) llstrpond=.TRUE. + + !computation of ice tranpsort ? + llice=.FALSE. ; IF( cdice .EQ. 'okice' ) llice=.TRUE. + + !store coordinates of the extremities + coord_point1=COORD_SECTION(plon1,plat1) + coord_point2=COORD_SECTION(plon2,plat2) + coord_sec=(/coord_point1,coord_point2/) + + !Extremities of the section are classed + lldate=.FALSE. + IF( coord_sec(2)%lon .LT. coord_sec(1)%lon .OR. & + ((coord_sec(2)%lon .EQ. coord_sec(1)%lon) .AND. & + (coord_sec(2)%lat .LT. coord_sec(1)%lat)) ) THEN + coordTemp =coord_sec(1) + coord_sec(1)=coord_sec(2) + coord_sec(2)=coordTemp + ENDIF + IF((coord_sec(2)%lon - coord_sec(1)%lon) .GT. 180) THEN + coordTemp =coord_sec(1) + coord_sec(1)=coord_sec(2) + coord_sec(2)=coordTemp + lldate=.TRUE. + ENDIF + + !slope of the section (equidistant cylindric projection) + zslope=slope_coeff(coord_sec(1),coord_sec(2),lldate) + + !!initialise global array secs + secs(jsec)%llstrpond=.FALSE. + secs(jsec)%ll_date_line=.FALSE. ; secs(jsec)%nb_class=0 + secs(jsec)%zsigi=99. ; secs(jsec)%zsigp=99. + secs(jsec)%zsal=99. ; secs(jsec)%ztem=99. + secs(jsec)%zlay=99. + secs(jsec)%nb_point=0 + + !store all information in global array secs + secs(jsec)%name = cdsecname + secs(jsec)%llstrpond = llstrpond + secs(jsec)%ll_ice_section = llice + secs(jsec)%coordSec = (/ coord_sec(1) , coord_sec(2) /) + secs(jsec)%slopeSection = zslope + secs(jsec)%ll_date_line = lldate + + !debug information + CALL write_debug(jsec,'Informations read in ascii file:') + CALL write_debug(jsec,'--------------------------------') + CALL write_debug(jsec,'section name: '//secs(jsec)%name ) + IF( secs(jsec)%llstrpond )THEN ; CALL write_debug(jsec,'salt/heat transport computing' ) + ELSE ; CALL write_debug(jsec,'no salt/heat transport computing' ) + ENDIF + IF( secs(jsec)%ll_ice_section )THEN ; CALL write_debug(jsec,'Ice transport computing' ) + ELSE ; CALL write_debug(jsec,'no Ice transport computing' ) + ENDIF + WRITE(cltmp,'(A20,2f8.3)')'Extremity 1 :',secs(jsec)%coordSec(1) + CALL write_debug(jsec,cltmp) + WRITE(cltmp,'(A20,2f8.3)')'Extremity 2 :',secs(jsec)%coordSec(2) + CALL write_debug(jsec,cltmp) + WRITE(cltmp,'(A20,f8.3)')'Slope coefficient :',secs(jsec)%slopeSection + CALL write_debug(jsec,cltmp) + WRITE(cltmp,'(A20,i3.3)')'number of classes : ',iclass + CALL write_debug(jsec,cltmp) + IF( secs(jsec)%ll_date_line ) THEN ; CALL write_debug(jsec,'section crosses date line') + ELSE ; CALL write_debug(jsec,'section don t crosse date line') + ENDIF + CALL write_debug(jsec,' ') + + !verify number of sections and store it + IF ( iclass .GT. nb_class_max) THEN + PRINT*,"WARNING: nb_class_max needs to be greater than ", iclass ; STOP + ENDIF + secs(jsec)%nb_class=iclass + + !read classes + IF ( iclass .NE. 0 )THEN + + !classname=zsigi/zsigp/zsal/ztem/zlay + READ(numdctin,'(A5)')clclass + DO jclass = 1,iclass + READ(numdctin,'(F9.3)',iostat=iost) zclass_value(jclass) + ENDDO + IF ( TRIM(clclass) .EQ. 'zsigi' )THEN + secs(jsec)%zsigi(1:iclass)=zclass_value(1:iclass) + ELSE IF ( TRIM(clclass) .EQ. 'zsigp' )THEN + secs(jsec)%zsigp(1:iclass)=zclass_value(1:iclass) + ELSE IF ( TRIM(clclass) .EQ. 'zsal' )THEN + secs(jsec)%zsal(1:iclass)=zclass_value(1:iclass) + ELSE IF ( TRIM(clclass) .EQ. 'ztem' )THEN + secs(jsec)%ztem(1:iclass)=zclass_value(1:iclass) + ELSE IF ( TRIM(clclass) .EQ. 'zlay' )THEN + secs(jsec)%zlay(1:iclass)=zclass_value(1:iclass) + ELSE + PRINT*,'Wrong name of class for section/clclass: ', cdsecname,TRIM(clclass) + ENDIF + + IF ( jsec==nsecdebug .OR. nsecdebug==-1)THEN + PRINT*,'class type = ',clclass + PRINT*,'class values = ',zclass_value(1:iclass) + ENDIF + + ENDIF + + ENDDO !end of loop on sections + + CLOSE(numdctin) !Close file + IF( jsec .EQ. nb_sec_max)THEN + PRINT*,' ' + PRINT*,' nb_sec_max is less than the number of sections written in list_sections.ascii' + STOP + ELSE + nb_sec=jsec-1 !number of read sections + PRINT*,' ' + PRINT*,'Number of sections read in list_sections.ascii: ',nb_sec + PRINT*,'Reading of list_sections.ascii ok' + PRINT*,' ' + ENDIF + + ENDIF + + END SUBROUTINE read_list_sections + +END MODULE readsections diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/sections_tools.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/sections_tools.f90 new file mode 100755 index 0000000000000000000000000000000000000000..15bb89b64cd05d8a0c9c5d9ea194e2817305a783 --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/sections_tools.f90 @@ -0,0 +1,563 @@ +MODULE sections_tools + !!===================================================================== + !! *** MODULE sections_tools *** + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!===================================================================== + !! * Modules used + USE declarations + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC pointToCoordF ! define a point with geographical coordinates + PUBLIC distance2 ! compute distance between 2 points + PUBLIC distance3 ! compute distance between a point and a line + PUBLIC intersec ! intersection between 2 lines + PUBLIC slope_coeff ! slope coefficient of a line + PUBLIC qcksrt ! organize a list of point + PUBLIC write_debug ! write debug messages + PUBLIC file_open ! open a file ( ascii, bin) + +CONTAINS + + TYPE(COORD_SECTION) FUNCTION pointToCoordF(p) + !!--------------------------------------------------------------------- + !! *** FUNCTION pointToCoordF *** + !! + !! ** Purpose: define a point with geographical coordinates + !! + !!--------------------------------------------------------------------- + !! * arguments + TYPE(POINT_SECTION), INTENT(IN) :: p + + !!--------------------------------------------------------------------- + + pointToCoordF = COORD_SECTION(glamf(p%I,p%J),gphif(p%I,p%J)) + + RETURN + + END FUNCTION pointToCoordF + + REAL(wp) FUNCTION distance2(coordA,coordB,ld_date_line) + !!--------------------------------------------------------------------- + !! *** FUNCTION distance *** + !! + !! ** Purpose:compute distance between coordA and coordB + !! We add 360 to coordB%long if the line (coordA,coordB) + !! crosses the date-line. + !! + !!--------------------------------------------------------------------- + !! * arguments + TYPE(COORD_SECTION), INTENT(IN) :: coordA,coordB + LOGICAL,INTENT(IN),OPTIONAL :: ld_date_line + + !! * Local declarations + REAL(wp) :: zrad, zrayon + REAL(wp) :: zpi = 3.141592653589793 + REAL(wp) :: zlam1, zlam2, zphi1, zphi2 + + !----------------------------------------------- + zrayon = 6367000.0 + zrad = zpi/180. + zlam1 = coordA%lon*zrad + zlam2 = coordB%lon*zrad + zphi1 = coordA%lat*zrad + zphi2 = coordB%lat*zrad + ! + !function output + distance2=0.001*2.*zrayon *ASIN(SQRT(SIN((zphi2-zphi1)/2.0)**2.0+COS(zphi1)*COS(zphi2)*SIN((zlam2-zlam1)/2.0)**2.0) ) + ! + RETURN + END FUNCTION distance2 + + REAL(wp) FUNCTION distance3(coordA,coordB,coordC,ll_debug) + !!--------------------------------------------------------------------- + !! *** FUNCTION cosinus *** + !! + !! ** Purpose: compute distance between a point B and a line (AC) + !! + !! ** Methode: use Al-Kashi theorem + !! + !! B A first point of the section + !! / \ B intermediate point on the section + !! / | \ C last point of the section + !! / | \ + !! / | \ angle=ACB + !! / | \ + !! / | \ distance3=Bd + !! / | \ + !! C -------d------- A + !! + !!--------------------------------------------------------------------- + !! * arguments + TYPE(COORD_SECTION), INTENT(IN) :: coordA,coordB,coordC + LOGICAL :: ll_debug + + !! * Local declarations + REAL(wp) :: ztmp + REAL(wp) :: za, zb, zc, zangle + + !----------------------------------------------- + za = SQRT( (coordB%lon-coordC%lon)**2 + (coordB%lat-coordC%lat)**2 ) + zb = SQRT( (coordA%lon-coordC%lon)**2 + (coordA%lat-coordC%lat)**2 ) + zc = SQRT( (coordA%lon-coordB%lon)**2 + (coordA%lat-coordB%lat)**2 ) + ! + IF( za /= 0. .AND. zb /= 0. )THEN + ztmp = ( za**2 + zb**2 - zc**2 ) / ( 2.0*za*zb ) + ztmp = MIN(ztmp,1.00_wp) + IF( ztmp==1.00_wp )THEN ; zangle = 0.0 + ELSE ; zangle = ABS(acos(ztmp)) + ENDIF + ELSE + PRINT*,'You should not have this situation: za zb =',za,zb ; STOP + ENDIF + ! + distance3 = za*ABS(sin(zangle)) + ! + !function output + RETURN + END FUNCTION distance3 + + REAL(wp) FUNCTION slope_coeff(coordA,coordB,ld_dateline) + !!--------------------------------------------------------------------- + !! *** Function slope_coeff *** + !! + !! ** Purpose: Compute slope coefficient of the line (coordA,coordB) + !! + !! ** Method: + !! Usual method : + !! slope_coeff = (latB-latA)/(lonB-lonA) + !! Special case: the segment [A,B] crosses the date-line (lddate=T) + !! slope_coeff = (latB-latA)/(360+lonB-lonA) + !!--------------------------------------------------------------------- + !! * arguments + TYPE(COORD_SECTION), INTENT(IN) :: coordA, coordB + LOGICAL,INTENT(IN),OPTIONAL :: ld_dateline + + !! * Local declarations + REAL(wp) :: zcoeff + INTEGER :: idateline + + !!--------------------------------------------------------- + !initialization + zcoeff = 1.e20 + idateline=0 + IF( PRESENT( ld_dateline))THEN + IF( ld_dateline )idateline=1 + ENDIF + + !compute slope coefficient + IF ( coordB%lon-coordA%lon .NE. 0.) & + zcoeff=(coordB%lat-coordA%lat)/(360*idateline+coordB%lon-coordA%lon) + + !output + slope_coeff = zcoeff + RETURN + + END FUNCTION slope_coeff + + TYPE(COORD_SECTION) FUNCTION intersec(sec,coord_a,coord_b) + !!--------------------------------------------------------------------- + !! *** Function intersec *** + !! + !! ** Purpose:Return the coordinates of the intersection point, + !! between segment [a,b] and the section. + !! If no intersection the point = -9999. + !! + !! ** Method:(coord_a,coord_b) => y=za2*x+zb2 (2) + !! sec => y=za1*x+zb1 (1) + !! Intersection = (X,Y) solves (1) and (2) + !! Vefify that (X,Y) is in [coord_a,coord_b] AND in the section + !! + !! ** Action: 1. compute za1, za1 + !! 2. compute zb1, zb2 + !! 3. compute X and Y + !! 4.Verify that (zX,zY) is in [coord_a,coord_b] + !! and in [sec%coordSec(1),sec%coordSec(2)] + !! + !! History: Author: 10/05 Matthieu Laborie + !! Additions: + !! 05-2007: (C Bricaud) add special cases + !! (crossing date line) + !----------------------------------------------------------------------------- + !! * arguments + TYPE(SECTION), INTENT(IN) :: sec + TYPE(COORD_SECTION) , INTENT(IN):: coord_a, coord_b + + !! * Local declarations + TYPE(COORD_SECTION) :: coordInter + REAL(wp) :: za1,za2, &! slope coefficient + zb1,zb2, &! + zX,zY ! coordinates of intersection + LOGICAL :: ll_date_line=.FALSE. !segment [a,b] crosses the date-line ? + + !---------------------------------------------------------------------------- + + !=================! + !0. INITALIZATION ! + !=================! + coordInter=COORD_SECTION(-9999.,-9999.) + ll_date_line=.FALSE. + !we need to know if [coord_a,coord_b] crosses the date-line + if(coord_a%lon-coord_b%lon .GT. 180)ll_date_line=.TRUE. + + !=======================! + !1. compute za1 and za2 ! + !=======================! + za1=sec%slopeSection + za2=slope_coeff(coord_a,coord_b,ll_date_line) + + !=======================! + !2. compute zb1 and zb2 ! + !=======================! + + ! Compute coefficient b for a straight line y=a*x+b + ! Usual method: knowing value of a, we compute b with coordinates of 1 point: + ! b=latA-a.lonA or b=latB-a.lonB + ! Particular case: the straight line crosses the date line; so it is in 2 parts: + ! one on the left of the date-line and one the right + ! then,b can could have 2 values: + ! As the date-line can be crossed by the section and the segment of the mesh [a,b], + ! we have to check if the segment [a,b] crosses the date-line (we know it already for the + ! section(sec%ll_date_line): ll_date_line + ! Then, there are 4 cases for computing b1 and b2 ( sec%ll_date_line=T/F AND ll_date_line=T/F ) + !=========================================================================================! + ! CASE A : !CASE C: + ! sec%ll_date_line=T AND ll_date_line =T !sec%ll_date_line=F AND ll_date_line =T + ! ! | -180 !+180 | + ! this case doesn't exist ! | ! | + !========================================! a___|_______!_______|__b + !CASE B: ! | ! | + !sec%ll_date_line=T AND ll_date_line=F ! | ! | + ! \ | ! section date-line section + ! a__\__b | ! b1: usual method + ! \ | ! b2: depend of longitude of + ! \ | ! sec%coordSec(1) et de sec%coordSec(2) + ! \ | !=================================================! + ! \| !CASE D: + ! +180 \ -180 !sec%ll_date_line=F AND ll_date_line =F + ! |\ ! | ! | + ! | \ ! | +180 ! -180 | + ! | \ ! a___|___b ! a___|___b + ! |a__\__b ! | ! | + ! | \ ! | ! | + ! date-line section ! section date-line section + !b2: usual method !b1: usual method + !b1: depend of longitude of a and b. !b2: usual method + !==========================================================================================! + + IF( sec%ll_date_line )THEN + IF( ll_date_line )THEN + !CASE A: this case doesn't exist + !------- + zb1=1.e20 + zb2=1.e20 + ELSE + !CASE B: + !------- + !compute zb2: + !zb2 = coord_b%lat - za2 * coord_b%lon = coord_a%lat - za2 * coord_a%lon + zb2=coord_b%lat - za2 * coord_b%lon + + !compute zb1: + IF( coord_a%lon .GT. 0 .AND. coord_b%lon .GT. 0 )THEN + zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon + ELSE + zb1 = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon + ENDIF + ENDIF + ELSE + IF( ll_date_line )THEN + !CASE C: + !------- + !Compute zb1: + !zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon + ! = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon + zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon + + !Compute zb2: + IF( sec%coordSec(1)%lon .GT. 0 .AND. sec%coordSec(2)%lon .GT. 0 )THEN + zb2 = coord_a%lat - za2 * coord_a%lon + ELSE + zb2 = coord_b%lat - za2 * coord_b%lon + ENDIF + ELSE + !CASE D: + !------- + !compute zb1: + !zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon + ! = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon + zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon + + !compute zb2: + !zb2 = coord_b%lat - za2 * coord_b%lon = coord_a%lat - za2 * coord_a%lon + zb2 = coord_b%lat - za2 * coord_b%lon + ENDIF + ENDIF + + IF( (za1 - za2) .NE. 0) THEN + !================================! + !3. Compute intersection (zX,zY) ! + !================================! + IF( za1 == 1.e20 ) THEN ! Case X=constant + zX = sec%coordSec(1)%lon + zY = za2 * zX + zb2 + ELSE IF ( za2 == 1.e20) THEN ! Case X=constant + zX = coord_b%lon + zY = za1 * zX + zb1 + ELSE ! Case zY=A*zX+B + zX = (zb2 - zb1) / (za1 - za2) + zY = (za1 * zX ) + zb1 + ENDIF + + !==============================================! + !4.Verify that (zX,zY) is in [coord_a,coord_b] ! + ! and in [sec%coordSec(1),sec%coordSec(2)] ! + !==============================================! + !Be careful! The test is not the same for all configurations + IF( sec%ll_date_line )THEN + + IF( ll_date_line )THEN + !CASE A: this case doesn't exist + !------- + coordInter=COORD_SECTION(-9999.,-9999.) + ELSE + !CASE B: + !------- + IF( zX .GE. MIN(coord_a%lon,coord_b%lon ) .AND. & + zX .LE. MAX(coord_a%lon,coord_b%lon ) .AND. & + zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. & + zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. & + ((zX .LE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zX .GE. -180) .OR. & + (zX .GE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zX .LE. 180)) .AND. & + zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. & + zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN + coordInter = COORD_SECTION(zX, zY) + ENDIF + ENDIF + ELSE + + IF( ll_date_line )THEN + !CASE C: + !------- + IF( ((zX .LE. MIN(coord_a%lon,coord_b%lon ) .AND. & + zX .GE. -180 ) .OR. & + (zX .GE. MAX(coord_a%lon,coord_b%lon ) .AND. & + zX .LE. 180 )) .AND. & + zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. & + zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. & + zX .GE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zX .LE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. & + zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN + coordInter = COORD_SECTION(zX, zY) + ENDIF + ELSE + !CASE D: + !------- + IF( zX .GE. MIN(coord_a%lon,coord_b%lon ) .AND. & + zX .LE. MAX(coord_a%lon,coord_b%lon ) .AND. & + zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. & + zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. & + zX .GE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zX .LE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. & + zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. & + zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN + coordInter = COORD_SECTION(zX, zY) + ENDIF + ENDIF + ENDIF + + ENDIF + + !output + intersec = coordInter + RETURN + + END FUNCTION intersec + + SUBROUTINE qcksrt(arr1,arr2,n) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE qcksrt *** + !! + !! ** Purpose : organize a list point by latitude , and after by longitude + !! using "numerical recipies " routine. + !!--------------------------------------------------------------------- + !! * arguments + INTEGER,INTENT(IN) :: n ! number of points + REAL(wp),DIMENSION(n),INTENT(INOUT):: arr1,arr2 ! longitude and latitude + + !! * Local declarations + INTEGER , PARAMETER :: m = 7, nstack = 500 + REAL(wp), PARAMETER :: fm=7875.,fa=211.,fc=1663.,fmi=1./fm + INTEGER :: il, ir, i, iq, ist !local integers + INTEGER :: jj !loop indices + REAL(wp) :: zfx, za, zb !local real + INTEGER,DIMENSION(nstack) :: istack(nstack) !temp array + !--------------------------------------------------- + ist=0 + il=1 + ir=n + zfx=0. + ! + 10 IF( ir-il .LT. m )THEN + + DO jj = il+1,ir + za = arr1(jj) + zb = arr2(jj) + DO i = jj-1,1,-1 + IF( arr1(i) .LE. za )GOTO 12 + arr1(i+1) = arr1(i) + arr2(i+1) = arr2(i) + ENDDO + i=0 + 12 arr1(i+1) = za + arr2(i+1) = zb + ENDDO + IF( ist .EQ. 0 )RETURN + ir = istack(ist) + il = istack(ist-1) + ist = ist-2 + ELSE + i = il + jj = ir + zfx = MOD(zfx*fa+fc,fm) + iq = il+(ir-il+1)*(zfx*fmi) + za = arr1(iq) + arr1(iq) = arr1(il) + zb = arr2(iq) + arr2(iq) = arr2(il) + 20 CONTINUE + 21 IF( jj .GT. 0 )THEN + IF( za .LT. arr1(jj) )THEN + jj = jj-1 + GOTO 21 + ENDIF + ENDIF + IF( jj .LE. i )THEN + arr1(i) = za + arr2(i) = zb + GOTO 30 + ENDIF + arr1(i) = arr1(jj) + arr2(i) = arr2(jj) + i=i+1 + 22 IF( i .LE. n )THEN + IF( za .GT. arr1(i) )THEN + i = i+1 + GOTO 22 + ENDIF + ENDIF + IF( jj .LE.i )THEN + arr1(jj) = za + arr2(jj) = zb + i = jj + GOTO 30 + ENDIF + arr1(jj) = arr1(i) + arr2(jj) = arr2(i) + jj = jj - 1 + GOTO 20 + 30 ist = ist + 2 + IF( ist .GT. nstack )PAUSE 'nstack too small' + IF( ir-i .GE. i-1 )THEN + istack(ist ) = ir + istack(ist-1) = i + 1 + ir = i-1 + ELSE + istack(ist ) = i-1 + istack(ist-1) = il + il = i+1 + ENDIF + ENDIF + GOTO 10 + END SUBROUTINE qcksrt + + SUBROUTINE write_debug(ksec,cd_write) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE write_debug *** + !! + !! ** Purpose: write debug messages + !! + !!--------------------------------------------------------------------- + !! * arguments + INTEGER :: ksec !number of section + CHARACTER(len=*) :: cd_write !message to write + + !! * Local declarations + INTEGER :: iunit + LOGICAL :: llok + CHARACTER(len=80) :: clfilename + + !!--------------------------------------------------------------------- + IF( ksec == nsecdebug .OR. nsecdebug == -1 )THEN + + + !open / verify is debug output file is open + + clfilename=TRIM(secs(ksec)%name)//"_debug" + iunit = num_sec_debug(ksec) + + IF( iunit .EQ. 0 )THEN + PRINT*,"Open debug file: "//TRIM(clfilename) + iunit = 100 + ksec + num_sec_debug(ksec) = iunit + + CALL file_open(iunit,clfilename,llok,cdform="FORMATTED",cdstatus="REPLACE",cdaction="WRITE") + + IF( .NOT. llok )THEN + PRINT*,"Can not open TRIM(clfilename)." ; STOP + ENDIF + ENDIF + + WRITE(iunit,*)TRIM(cd_write) + + ENDIF + + END SUBROUTINE write_debug + + SUBROUTINE file_open(knum,cdfile,ldok,cdform,cdstatus,cdaction) + !!--------------------------------------------------------------------- + !! *** ROUTINE file_open *** + !! + !! ** Purpose: open a file + !! + !!--------------------------------------------------------------------- + !! * arguments + INTEGER ,INTENT(IN) :: knum ! file unit number + CHARACTER(len=*),INTENT(IN) :: cdfile ! file name to open + LOGICAL ,INTENT(OUT) :: ldok ! =.TRUE. if file exists and is corectly opened + CHARACTER(len=*),INTENT(IN) :: cdform, &! FORM arguments for OPEN function + cdstatus, &! STATUS arguments for OPEN function + cdaction ! ACTION arguments for OPEN function + + !! * Local declarations + INTEGER :: iost + LOGICAL :: llbon=.FALSE. !check existence of file + !!--------------------------------------------------------------------- + ldok = .FALSE. ! initialization; file not found and not opened + + !check presence of file + IF( cdstatus .EQ. "OLD" ) THEN + INQUIRE( FILE=cdfile, EXIST=llbon ) ! check presence of namelist + IF( llbon )THEN ; PRINT*,TRIM(cdfile)//' EXISTS' + ELSE ; PRINT*,TRIM(cdfile)//' NOT EXISTS' ; STOP + ENDIF + ENDIF + + !open file + OPEN(UNIT=knum,FILE=TRIM(cdfile),FORM=cdform,status=cdstatus,action=cdaction,iostat=iost) + IF ( iost == 0 )THEN + ldok=.TRUE. + ELSE + PRINT*,TRIM(cdfile)//' bad opening. STOP.'; STOP + ENDIF + + END SUBROUTINE file_open + +END MODULE sections_tools diff --git a/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/writesections.f90 b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/writesections.f90 new file mode 100755 index 0000000000000000000000000000000000000000..5717d3d3f23ce3718d4f92987d51c3044283406b --- /dev/null +++ b/V4.0/nemo_sources/tools/SECTIONS_DIADCT/src/writesections.f90 @@ -0,0 +1,91 @@ +MODULE writesections + !!===================================================================== + !! *** MODULE writesections *** + !! + !! History: 2011: Clement Bricaud, Mercator-Ocean + !! + !!===================================================================== + !! * Modules used + USE declarations + USE sections_tools + + IMPLICIT NONE + PRIVATE + + !! * Routine accessibility + PUBLIC write_sections + PRIVATE file_open + +CONTAINS + + SUBROUTINE write_sections + !!--------------------------------------------------------------------- + !! *** ROUTINE read_list_sections *** + !! + !! ** Purpose + !! + !! ** Method + !! + !! ** Input + !! + !! ** Action + !! + !! History + !!--------------------------------------------------------------------- + !! * arguments + + !! * Local declarations + INTEGER :: jsec ,&!loop on sections + jseg !loop on segments + INTEGER :: i1, i2 !temporary integers + LOGICAL :: llok ! + CHARACTER(len=40) :: clname ! + TYPE(POINT_SECTION) :: point !coordinates of a point + + !!--------------------------------------------------------------------- + + PRINT*,' ' + PRINT*,'WRITE SECTIONS' + PRINT*,'--------------' + + !open output file + llok=.FALSE. + clname='section_ijglobal.diadct' + CALL file_open(numdctout,clname,llok,cdform="UNFORMATTED",cdstatus="REPLACE",cdaction="WRITE") + + !print informations + IF ( llok ) THEN + PRINT*,TRIM(clname),' open. ' + + DO jsec=1,nb_sec + + WRITE(numdctout)jsec + WRITE(numdctout)secs(jsec)%name + WRITE(numdctout)secs(jsec)%llstrpond + WRITE(numdctout)secs(jsec)%ll_ice_section + WRITE(numdctout)secs(jsec)%ll_date_line + WRITE(numdctout)secs(jsec)%coordSec + WRITE(numdctout)secs(jsec)%nb_class + WRITE(numdctout)secs(jsec)%zsigi + WRITE(numdctout)secs(jsec)%zsigp + WRITE(numdctout)secs(jsec)%zsal + WRITE(numdctout)secs(jsec)%ztem + WRITE(numdctout)secs(jsec)%zlay + WRITE(numdctout)secs(jsec)%slopeSection + WRITE(numdctout)secs(jsec)%nb_point + IF( secs(jsec)%nb_point .NE. 0 )THEN + DO jseg=1,secs(jsec)%nb_point + i1 = secs(jsec)%listPoint(jseg)%I ; i2 = secs(jsec)%listPoint(jseg)%J + WRITE(numdctout)i1,i2 + ENDDO + WRITE(numdctout)secs(jsec)%direction(1:secs(jsec)%nb_point) + ENDIF + + ENDDO !end of loop on sections + + CLOSE(numdctout) !Close file + ENDIF + + END SUBROUTINE write_sections + +END MODULE writesections diff --git a/V4.0/nemo_sources/tools/SIREN/Doxyfile b/V4.0/nemo_sources/tools/SIREN/Doxyfile new file mode 100644 index 0000000000000000000000000000000000000000..d2d20ed7c59ff3235fcb3336b989086047e05c5f --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/Doxyfile @@ -0,0 +1,2493 @@ +# Doxyfile 1.8.15 + +# This file describes the settings to be used by the documentation system +# doxygen (www.doxygen.org) for a project. +# +# All text after a double hash (##) is considered a comment and is placed in +# front of the TAG it is preceding. +# +# All text after a single hash (#) is considered a comment and will be ignored. +# The format is: +# TAG = value [value, ...] +# For lists, items can also be appended using: +# TAG += value [value, ...] +# Values that contain spaces should be placed between quotes (\" \"). + +#--------------------------------------------------------------------------- +# Project related configuration options +#--------------------------------------------------------------------------- + +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. +# The default value is: UTF-8. + +DOXYFILE_ENCODING = UTF-8 + +# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by +# double-quotes, unless you are using Doxywizard) that should identify the +# project for which the documentation is generated. This name is used in the +# title of most generated pages and in a few other places. +# The default value is: My Project. + +PROJECT_NAME = "SIREN" + +# The PROJECT_NUMBER tag can be used to enter a project or revision number. This +# could be handy for archiving the generated documentation or if some version +# control system is used. + +PROJECT_NUMBER = "$Rev: 12080 $" + +# Using the PROJECT_BRIEF tag one can provide an optional one line description +# for a project that appears at the top of each page and should give viewer a +# quick idea about the purpose of the project. Keep the description short. + +PROJECT_BRIEF = "System and Interface for oceanic RElocatable Nesting" + +# With the PROJECT_LOGO tag one can specify a logo or an icon that is included +# in the documentation. The maximum height of the logo should not exceed 55 +# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy +# the logo to the output directory. + +PROJECT_LOGO = ./src/docsrc/Image/logoSirenNemo.png + +# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path +# into which the generated documentation will be written. If a relative path is +# entered, it will be relative to the location where doxygen was started. If +# left blank the current directory will be used. + +OUTPUT_DIRECTORY = ./doc + +# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- +# directories (in 2 levels) under the output directory of each output format and +# will distribute the generated files over these directories. Enabling this +# option can be useful when feeding doxygen a huge amount of source files, where +# putting all generated files in the same directory would otherwise causes +# performance problems for the file system. +# The default value is: NO. + +CREATE_SUBDIRS = NO + +# If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII +# characters to appear in the names of generated files. If set to NO, non-ASCII +# characters will be escaped, for example _xE3_x81_x84 will be used for Unicode +# U+3044. +# The default value is: NO. + +ALLOW_UNICODE_NAMES = NO + +# The OUTPUT_LANGUAGE tag is used to specify the language in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all constant output in the proper language. +# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese, +# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States), +# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian, +# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages), +# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian, +# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian, +# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish, +# Ukrainian and Vietnamese. +# The default value is: English. + +OUTPUT_LANGUAGE = English + +# The OUTPUT_TEXT_DIRECTION tag is used to specify the direction in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all generated output in the proper direction. +# Possible values are: None, LTR, RTL and Context. +# The default value is: None. + +OUTPUT_TEXT_DIRECTION = None + +# If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member +# descriptions after the members that are listed in the file and class +# documentation (similar to Javadoc). Set to NO to disable this. +# The default value is: YES. + +BRIEF_MEMBER_DESC = YES + +# If the REPEAT_BRIEF tag is set to YES, doxygen will prepend the brief +# description of a member or function before the detailed description +# +# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the +# brief descriptions will be completely suppressed. +# The default value is: YES. + +REPEAT_BRIEF = YES + +# This tag implements a quasi-intelligent brief description abbreviator that is +# used to form the text in various listings. Each string in this list, if found +# as the leading text of the brief description, will be stripped from the text +# and the result, after processing the whole list, is used as the annotated +# text. Otherwise, the brief description is used as-is. If left blank, the +# following values are used ($name is automatically replaced with the name of +# the entity):The $name class, The $name widget, The $name file, is, provides, +# specifies, contains, represents, a, an and the. + +ABBREVIATE_BRIEF = + +# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then +# doxygen will generate a detailed section even if there is only a brief +# description. +# The default value is: NO. + +ALWAYS_DETAILED_SEC = NO + +# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all +# inherited members of a class in the documentation of that class as if those +# members were ordinary class members. Constructors, destructors and assignment +# operators of the base classes will not be shown. +# The default value is: NO. + +INLINE_INHERITED_MEMB = NO + +# If the FULL_PATH_NAMES tag is set to YES, doxygen will prepend the full path +# before files name in the file list and in the header files. If set to NO the +# shortest path that makes the file name unique will be used +# The default value is: YES. + +FULL_PATH_NAMES = YES + +# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path. +# Stripping is only done if one of the specified strings matches the left-hand +# part of the path. The tag can be used to show relative paths in the file list. +# If left blank the directory from which doxygen is run is used as the path to +# strip. +# +# Note that you can specify absolute paths here, but also relative paths, which +# will be relative from the directory where doxygen is started. +# This tag requires that the tag FULL_PATH_NAMES is set to YES. + +STRIP_FROM_PATH = + +# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the +# path mentioned in the documentation of a class, which tells the reader which +# header file to include in order to use a class. If left blank only the name of +# the header file containing the class definition is used. Otherwise one should +# specify the list of include paths that are normally passed to the compiler +# using the -I flag. + +STRIP_FROM_INC_PATH = + +# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but +# less readable) file names. This can be useful is your file systems doesn't +# support long names like on DOS, Mac, or CD-ROM. +# The default value is: NO. + +SHORT_NAMES = NO + +# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the +# first line (until the first dot) of a Javadoc-style comment as the brief +# description. If set to NO, the Javadoc-style will behave just like regular Qt- +# style comments (thus requiring an explicit @brief command for a brief +# description.) +# The default value is: NO. + +JAVADOC_AUTOBRIEF = NO + +# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first +# line (until the first dot) of a Qt-style comment as the brief description. If +# set to NO, the Qt-style will behave just like regular Qt-style comments (thus +# requiring an explicit \brief command for a brief description.) +# The default value is: NO. + +QT_AUTOBRIEF = NO + +# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a +# multi-line C++ special comment block (i.e. a block of //! or /// comments) as +# a brief description. This used to be the default behavior. The new default is +# to treat a multi-line C++ comment block as a detailed description. Set this +# tag to YES if you prefer the old behavior instead. +# +# Note that setting this tag to YES also means that rational rose comments are +# not recognized any more. +# The default value is: NO. + +MULTILINE_CPP_IS_BRIEF = NO + +# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the +# documentation from any documented member that it re-implements. +# The default value is: YES. + +INHERIT_DOCS = YES + +# If the SEPARATE_MEMBER_PAGES tag is set to YES then doxygen will produce a new +# page for each member. If set to NO, the documentation of a member will be part +# of the file/class/namespace that contains it. +# The default value is: NO. + +SEPARATE_MEMBER_PAGES = NO + +# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen +# uses this value to replace tabs by spaces in code fragments. +# Minimum value: 1, maximum value: 16, default value: 4. + +TAB_SIZE = 3 + +# This tag can be used to specify a number of aliases that act as commands in +# the documentation. An alias has the form: +# name=value +# For example adding +# "sideeffect=@par Side Effects:\n" +# will allow you to put the command \sideeffect (or @sideeffect) in the +# documentation, which will result in a user-defined paragraph with heading +# "Side Effects:". You can put \n's in the value part of an alias to insert +# newlines (in the resulting output). You can put ^^ in the value part of an +# alias to insert a newline as if a physical newline was in the original file. +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) + +ALIASES = + +# This tag can be used to specify a number of word-keyword mappings (TCL only). +# A mapping has the form "name=value". For example adding "class=itcl::class" +# will allow you to use the command class in the itcl::class meaning. + +TCL_SUBST = + +# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources +# only. Doxygen will then generate output that is more tailored for C. For +# instance, some of the names that are used will be different. The list of all +# members will be omitted, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_FOR_C = NO + +# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or +# Python sources only. Doxygen will then generate output that is more tailored +# for that language. For instance, namespaces will be presented as packages, +# qualified scopes will look different, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_JAVA = NO + +# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran +# sources. Doxygen will then generate output that is tailored for Fortran. +# The default value is: NO. + +OPTIMIZE_FOR_FORTRAN = NO + +# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL +# sources. Doxygen will then generate output that is tailored for VHDL. +# The default value is: NO. + +OPTIMIZE_OUTPUT_VHDL = NO + +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + +# Doxygen selects the parser to use depending on the extension of the files it +# parses. With this tag you can assign which parser to use for a given +# extension. Doxygen has a built-in mapping, but you can override or extend it +# using this tag. The format is ext=language, where ext is a file extension, and +# language is one of the parsers supported by doxygen: IDL, Java, Javascript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files), VHDL, tcl. For instance to make doxygen treat +# .inc files as Fortran files (default is PHP), and .f files as C (default is +# Fortran), use: inc=Fortran f=C. +# +# Note: For files without extension you can use no_extension as a placeholder. +# +# Note that for custom extensions you also need to set FILE_PATTERNS otherwise +# the files are not read by doxygen. + +EXTENSION_MAPPING = + +# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments +# according to the Markdown format, which allows for more readable +# documentation. See https://daringfireball.net/projects/markdown/ for details. +# The output of markdown processing is further processed by doxygen, so you can +# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in +# case of backward compatibilities issues. +# The default value is: YES. + +MARKDOWN_SUPPORT = YES + +# When the TOC_INCLUDE_HEADINGS tag is set to a non-zero value, all headings up +# to that level are automatically included in the table of contents, even if +# they do not have an id attribute. +# Note: This feature currently applies only to Markdown headings. +# Minimum value: 0, maximum value: 99, default value: 0. +# This tag requires that the tag MARKDOWN_SUPPORT is set to YES. + +TOC_INCLUDE_HEADINGS = 0 + +# When enabled doxygen tries to link words that correspond to documented +# classes, or namespaces to their corresponding documentation. Such a link can +# be prevented in individual cases by putting a % sign in front of the word or +# globally by setting AUTOLINK_SUPPORT to NO. +# The default value is: YES. + +AUTOLINK_SUPPORT = YES + +# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want +# to include (a tag file for) the STL sources as input, then you should set this +# tag to YES in order to let doxygen match functions declarations and +# definitions whose arguments contain STL classes (e.g. func(std::string); +# versus func(std::string) {}). This also make the inheritance and collaboration +# diagrams that involve STL classes more complete and accurate. +# The default value is: NO. + +BUILTIN_STL_SUPPORT = NO + +# If you use Microsoft's C++/CLI language, you should set this option to YES to +# enable parsing support. +# The default value is: NO. + +CPP_CLI_SUPPORT = NO + +# Set the SIP_SUPPORT tag to YES if your project consists of sip (see: +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen +# will parse them like normal C++ but will assume all classes use public instead +# of private inheritance when no explicit protection keyword is present. +# The default value is: NO. + +SIP_SUPPORT = NO + +# For Microsoft's IDL there are propget and propput attributes to indicate +# getter and setter methods for a property. Setting this option to YES will make +# doxygen to replace the get and set methods by a property in the documentation. +# This will only work if the methods are indeed getting or setting a simple +# type. If this is not the case, or you want to show the methods anyway, you +# should set this option to NO. +# The default value is: YES. + +IDL_PROPERTY_SUPPORT = YES + +# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC +# tag is set to YES then doxygen will reuse the documentation of the first +# member in the group (if any) for the other members of the group. By default +# all members of a group must be documented explicitly. +# The default value is: NO. + +DISTRIBUTE_GROUP_DOC = NO + +# If one adds a struct or class to a group and this option is enabled, then also +# any nested class or struct is added to the same group. By default this option +# is disabled and one has to add nested compounds explicitly via \ingroup. +# The default value is: NO. + +GROUP_NESTED_COMPOUNDS = NO + +# Set the SUBGROUPING tag to YES to allow class member groups of the same type +# (for instance a group of public functions) to be put as a subgroup of that +# type (e.g. under the Public Functions section). Set it to NO to prevent +# subgrouping. Alternatively, this can be done per class using the +# \nosubgrouping command. +# The default value is: YES. + +SUBGROUPING = YES + +# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions +# are shown inside the group in which they are included (e.g. using \ingroup) +# instead of on a separate page (for HTML and Man pages) or section (for LaTeX +# and RTF). +# +# Note that this feature does not work in combination with +# SEPARATE_MEMBER_PAGES. +# The default value is: NO. + +INLINE_GROUPED_CLASSES = NO + +# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions +# with only public data fields or simple typedef fields will be shown inline in +# the documentation of the scope in which they are defined (i.e. file, +# namespace, or group documentation), provided this scope is documented. If set +# to NO, structs, classes, and unions are shown on a separate page (for HTML and +# Man pages) or section (for LaTeX and RTF). +# The default value is: NO. + +INLINE_SIMPLE_STRUCTS = NO + +# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or +# enum is documented as struct, union, or enum with the name of the typedef. So +# typedef struct TypeS {} TypeT, will appear in the documentation as a struct +# with name TypeT. When disabled the typedef will appear as a member of a file, +# namespace, or class. And the struct will be named TypeS. This can typically be +# useful for C code in case the coding convention dictates that all compound +# types are typedef'ed and only the typedef is referenced, never the tag name. +# The default value is: NO. + +TYPEDEF_HIDES_STRUCT = NO + +# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This +# cache is used to resolve symbols given their name and scope. Since this can be +# an expensive process and often the same symbol appears multiple times in the +# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small +# doxygen will become slower. If the cache is too large, memory is wasted. The +# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range +# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536 +# symbols. At the end of a run doxygen will report the cache usage and suggest +# the optimal cache size from a speed point of view. +# Minimum value: 0, maximum value: 9, default value: 0. + +LOOKUP_CACHE_SIZE = 0 + +#--------------------------------------------------------------------------- +# Build related configuration options +#--------------------------------------------------------------------------- + +# If the EXTRACT_ALL tag is set to YES, doxygen will assume all entities in +# documentation are documented, even if no documentation was available. Private +# class members and static file members will be hidden unless the +# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES. +# Note: This will also disable the warnings about undocumented members that are +# normally produced when WARNINGS is set to YES. +# The default value is: NO. + +EXTRACT_ALL = NO + +# If the EXTRACT_PRIVATE tag is set to YES, all private members of a class will +# be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIVATE = NO + +# If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal +# scope will be included in the documentation. +# The default value is: NO. + +EXTRACT_PACKAGE = NO + +# If the EXTRACT_STATIC tag is set to YES, all static members of a file will be +# included in the documentation. +# The default value is: NO. + +EXTRACT_STATIC = NO + +# If the EXTRACT_LOCAL_CLASSES tag is set to YES, classes (and structs) defined +# locally in source files will be included in the documentation. If set to NO, +# only classes defined in header files are included. Does not have any effect +# for Java sources. +# The default value is: YES. + +EXTRACT_LOCAL_CLASSES = YES + +# This flag is only useful for Objective-C code. If set to YES, local methods, +# which are defined in the implementation section but not in the interface are +# included in the documentation. If set to NO, only methods in the interface are +# included. +# The default value is: NO. + +EXTRACT_LOCAL_METHODS = NO + +# If this flag is set to YES, the members of anonymous namespaces will be +# extracted and appear in the documentation as a namespace called +# 'anonymous_namespace{file}', where file will be replaced with the base name of +# the file that contains the anonymous namespace. By default anonymous namespace +# are hidden. +# The default value is: NO. + +EXTRACT_ANON_NSPACES = NO + +# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all +# undocumented members inside documented classes or files. If set to NO these +# members will be included in the various overviews, but no documentation +# section is generated. This option has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_MEMBERS = NO + +# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all +# undocumented classes that are normally visible in the class hierarchy. If set +# to NO, these classes will be included in the various overviews. This option +# has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_CLASSES = NO + +# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend +# (class|struct|union) declarations. If set to NO, these declarations will be +# included in the documentation. +# The default value is: NO. + +HIDE_FRIEND_COMPOUNDS = NO + +# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any +# documentation blocks found inside the body of a function. If set to NO, these +# blocks will be appended to the function's detailed documentation block. +# The default value is: NO. + +HIDE_IN_BODY_DOCS = NO + +# The INTERNAL_DOCS tag determines if documentation that is typed after a +# \internal command is included. If the tag is set to NO then the documentation +# will be excluded. Set it to YES to include the internal documentation. +# The default value is: NO. + +INTERNAL_DOCS = NO + +# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file +# names in lower-case letters. If set to YES, upper-case letters are also +# allowed. This is useful if you have classes or files whose names only differ +# in case and if your file system supports case sensitive file names. Windows +# and Mac users are advised to set this option to NO. +# The default value is: system dependent. + +CASE_SENSE_NAMES = YES + +# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with +# their full class and namespace scopes in the documentation. If set to YES, the +# scope will be hidden. +# The default value is: NO. + +HIDE_SCOPE_NAMES = NO + +# If the HIDE_COMPOUND_REFERENCE tag is set to NO (default) then doxygen will +# append additional text to a page's title, such as Class Reference. If set to +# YES the compound reference will be hidden. +# The default value is: NO. + +HIDE_COMPOUND_REFERENCE= NO + +# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of +# the files that are included by a file in the documentation of that file. +# The default value is: YES. + +SHOW_INCLUDE_FILES = YES + +# If the SHOW_GROUPED_MEMB_INC tag is set to YES then Doxygen will add for each +# grouped member an include statement to the documentation, telling the reader +# which file to include in order to use the member. +# The default value is: NO. + +SHOW_GROUPED_MEMB_INC = NO + +# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include +# files with double quotes in the documentation rather than with sharp brackets. +# The default value is: NO. + +FORCE_LOCAL_INCLUDES = NO + +# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the +# documentation for inline members. +# The default value is: YES. + +INLINE_INFO = YES + +# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the +# (detailed) documentation of file and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. +# The default value is: YES. + +SORT_MEMBER_DOCS = YES + +# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief +# descriptions of file, namespace and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. Note that +# this will also influence the order of the classes in the class list. +# The default value is: NO. + +SORT_BRIEF_DOCS = NO + +# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the +# (brief and detailed) documentation of class members so that constructors and +# destructors are listed first. If set to NO the constructors will appear in the +# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS. +# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief +# member documentation. +# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting +# detailed member documentation. +# The default value is: NO. + +SORT_MEMBERS_CTORS_1ST = NO + +# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy +# of group names into alphabetical order. If set to NO the group names will +# appear in their defined order. +# The default value is: NO. + +SORT_GROUP_NAMES = NO + +# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by +# fully-qualified names, including namespaces. If set to NO, the class list will +# be sorted only by class name, not including the namespace part. +# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES. +# Note: This option applies only to the class list, not to the alphabetical +# list. +# The default value is: NO. + +SORT_BY_SCOPE_NAME = NO + +# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper +# type resolution of all parameters of a function it will reject a match between +# the prototype and the implementation of a member function even if there is +# only one candidate or it is obvious which candidate to choose by doing a +# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still +# accept a match between prototype and implementation in such cases. +# The default value is: NO. + +STRICT_PROTO_MATCHING = NO + +# The GENERATE_TODOLIST tag can be used to enable (YES) or disable (NO) the todo +# list. This list is created by putting \todo commands in the documentation. +# The default value is: YES. + +GENERATE_TODOLIST = YES + +# The GENERATE_TESTLIST tag can be used to enable (YES) or disable (NO) the test +# list. This list is created by putting \test commands in the documentation. +# The default value is: YES. + +GENERATE_TESTLIST = YES + +# The GENERATE_BUGLIST tag can be used to enable (YES) or disable (NO) the bug +# list. This list is created by putting \bug commands in the documentation. +# The default value is: YES. + +GENERATE_BUGLIST = YES + +# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or disable (NO) +# the deprecated list. This list is created by putting \deprecated commands in +# the documentation. +# The default value is: YES. + +GENERATE_DEPRECATEDLIST= YES + +# The ENABLED_SECTIONS tag can be used to enable conditional documentation +# sections, marked by \if <section_label> ... \endif and \cond <section_label> +# ... \endcond blocks. + +ENABLED_SECTIONS = + +# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the +# initial value of a variable or macro / define can have for it to appear in the +# documentation. If the initializer consists of more lines than specified here +# it will be hidden. Use a value of 0 to hide initializers completely. The +# appearance of the value of individual variables and macros / defines can be +# controlled using \showinitializer or \hideinitializer command in the +# documentation regardless of this setting. +# Minimum value: 0, maximum value: 10000, default value: 30. + +MAX_INITIALIZER_LINES = 30 + +# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at +# the bottom of the documentation of classes and structs. If set to YES, the +# list will mention the files that were used to generate the documentation. +# The default value is: YES. + +SHOW_USED_FILES = YES + +# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This +# will remove the Files entry from the Quick Index and from the Folder Tree View +# (if specified). +# The default value is: YES. + +SHOW_FILES = YES + +# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces +# page. This will remove the Namespaces entry from the Quick Index and from the +# Folder Tree View (if specified). +# The default value is: YES. + +SHOW_NAMESPACES = YES + +# The FILE_VERSION_FILTER tag can be used to specify a program or script that +# doxygen should invoke to get the current version for each file (typically from +# the version control system). Doxygen will invoke the program by executing (via +# popen()) the command command input-file, where command is the value of the +# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided +# by doxygen. Whatever the program writes to standard output is used as the file +# version. For an example see the documentation. + +FILE_VERSION_FILTER = + +# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed +# by doxygen. The layout file controls the global structure of the generated +# output files in an output format independent way. To create the layout file +# that represents doxygen's defaults, run doxygen with the -l option. You can +# optionally specify a file name after the option, if omitted DoxygenLayout.xml +# will be used as the name of the layout file. +# +# Note that if you run doxygen from a directory containing a file called +# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE +# tag is left empty. + +LAYOUT_FILE = + +# The CITE_BIB_FILES tag can be used to specify one or more bib files containing +# the reference definitions. This must be a list of .bib files. The .bib +# extension is automatically appended if omitted. This requires the bibtex tool +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. +# For LaTeX the style of the bibliography can be controlled using +# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the +# search path. See also \cite for info how to create references. + +CITE_BIB_FILES = + +#--------------------------------------------------------------------------- +# Configuration options related to warning and progress messages +#--------------------------------------------------------------------------- + +# The QUIET tag can be used to turn on/off the messages that are generated to +# standard output by doxygen. If QUIET is set to YES this implies that the +# messages are off. +# The default value is: NO. + +QUIET = NO + +# The WARNINGS tag can be used to turn on/off the warning messages that are +# generated to standard error (stderr) by doxygen. If WARNINGS is set to YES +# this implies that the warnings are on. +# +# Tip: Turn warnings on while writing the documentation. +# The default value is: YES. + +WARNINGS = YES + +# If the WARN_IF_UNDOCUMENTED tag is set to YES then doxygen will generate +# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag +# will automatically be disabled. +# The default value is: YES. + +WARN_IF_UNDOCUMENTED = YES + +# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for +# potential errors in the documentation, such as not documenting some parameters +# in a documented function, or documenting parameters that don't exist or using +# markup commands wrongly. +# The default value is: YES. + +WARN_IF_DOC_ERROR = YES + +# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that +# are documented, but have no documentation for their parameters or return +# value. If set to NO, doxygen will only warn about wrong or incomplete +# parameter documentation, but not about the absence of documentation. If +# EXTRACT_ALL is set to YES then this flag will automatically be disabled. +# The default value is: NO. + +WARN_NO_PARAMDOC = NO + +# If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when +# a warning is encountered. +# The default value is: NO. + +WARN_AS_ERROR = NO + +# The WARN_FORMAT tag determines the format of the warning messages that doxygen +# can produce. The string should contain the $file, $line, and $text tags, which +# will be replaced by the file and line number from which the warning originated +# and the warning text. Optionally the format may contain $version, which will +# be replaced by the version of the file (if it could be obtained via +# FILE_VERSION_FILTER) +# The default value is: $file:$line: $text. + +WARN_FORMAT = "$file:$line: $text" + +# The WARN_LOGFILE tag can be used to specify a file to which warning and error +# messages should be written. If left blank the output is written to standard +# error (stderr). + +WARN_LOGFILE = + +#--------------------------------------------------------------------------- +# Configuration options related to the input files +#--------------------------------------------------------------------------- + +# The INPUT tag is used to specify the files and/or directories that contain +# documented source files. You may enter file names like myfile.cpp or +# directories like /usr/src/myproject. Separate the files or directories with +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING +# Note: If this tag is empty the current directory is searched. + +INPUT = ./src \ + ./src/docsrc + +# This tag can be used to specify the character encoding of the source files +# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses +# libiconv (or the iconv built into libc) for the transcoding. See the libiconv +# documentation (see: https://www.gnu.org/software/libiconv/) for the list of +# possible encodings. +# The default value is: UTF-8. + +INPUT_ENCODING = UTF-8 + +# If the value of the INPUT tag contains directories, you can use the +# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and +# *.h) to filter out the source-files in the directories. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# read by doxygen. +# +# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, +# *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, +# *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, +# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, +# *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf, *.qsf and *.ice. + +FILE_PATTERNS = *.f90 \ + *.F90 \ + *.md \ + *.dox + +# The RECURSIVE tag can be used to specify whether or not subdirectories should +# be searched for input files as well. +# The default value is: NO. + +RECURSIVE = NO + +# The EXCLUDE tag can be used to specify files and/or directories that should be +# excluded from the INPUT source files. This way you can easily exclude a +# subdirectory from a directory tree whose root is specified with the INPUT tag. +# +# Note that relative paths are relative to the directory from which doxygen is +# run. + +EXCLUDE = + +# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or +# directories that are symbolic links (a Unix file system feature) are excluded +# from the input. +# The default value is: NO. + +EXCLUDE_SYMLINKS = NO + +# If the value of the INPUT tag contains directories, you can use the +# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude +# certain files from those directories. +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories for example use the pattern */test/* + +EXCLUDE_PATTERNS = + +# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names +# (namespaces, classes, functions, etc.) that should be excluded from the +# output. The symbol name can be a fully qualified name, a word, or if the +# wildcard * is used, a substring. Examples: ANamespace, AClass, +# AClass::ANamespace, ANamespace::*Test +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories use the pattern */test/* + +EXCLUDE_SYMBOLS = + +# The EXAMPLE_PATH tag can be used to specify one or more files or directories +# that contain example code fragments that are included (see the \include +# command). + +EXAMPLE_PATH = ./src/docsrc/include/ \ + ./src/docsrc/include/namlog \ + ./src/docsrc/include/namcfg \ + ./src/docsrc/include/namsrc \ + ./src/docsrc/include/namtgt \ + ./src/docsrc/include/namvar \ + ./src/docsrc/include/namnst \ + ./src/docsrc/include/namout + +# If the value of the EXAMPLE_PATH tag contains directories, you can use the +# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and +# *.h) to filter out the source-files in the directories. If left blank all +# files are included. + +EXAMPLE_PATTERNS = + +# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be +# searched for input files to be used with the \include or \dontinclude commands +# irrespective of the value of the RECURSIVE tag. +# The default value is: NO. + +EXAMPLE_RECURSIVE = NO + +# The IMAGE_PATH tag can be used to specify one or more files or directories +# that contain images that are to be included in the documentation (see the +# \image command). + +IMAGE_PATH = ./src/docsrc/Image + +# The INPUT_FILTER tag can be used to specify a program that doxygen should +# invoke to filter for each input file. Doxygen will invoke the filter program +# by executing (via popen()) the command: +# +# <filter> <input-file> +# +# where <filter> is the value of the INPUT_FILTER tag, and <input-file> is the +# name of an input file. Doxygen will then use the output that the filter +# program writes to standard output. If FILTER_PATTERNS is specified, this tag +# will be ignored. +# +# Note that the filter must not add or remove lines; it is applied before the +# code is scanned, but not when the output code is generated. If lines are added +# or removed, the anchors will not be placed correctly. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +INPUT_FILTER = + +# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern +# basis. Doxygen will compare the file name with each pattern and apply the +# filter if there is a match. The filters are a list of the form: pattern=filter +# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how +# filters are used. If the FILTER_PATTERNS tag is empty or if none of the +# patterns match the file name, INPUT_FILTER is applied. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +FILTER_PATTERNS = + +# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using +# INPUT_FILTER) will also be used to filter the input files that are used for +# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES). +# The default value is: NO. + +FILTER_SOURCE_FILES = NO + +# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file +# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and +# it is also possible to disable source filtering for a specific pattern using +# *.ext= (so without naming a filter). +# This tag requires that the tag FILTER_SOURCE_FILES is set to YES. + +FILTER_SOURCE_PATTERNS = + +# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that +# is part of the input, its contents will be placed on the main page +# (index.html). This can be useful if you have a project on for instance GitHub +# and want to reuse the introduction page also for the doxygen output. + +USE_MDFILE_AS_MAINPAGE = + +#--------------------------------------------------------------------------- +# Configuration options related to source browsing +#--------------------------------------------------------------------------- + +# If the SOURCE_BROWSER tag is set to YES then a list of source files will be +# generated. Documented entities will be cross-referenced with these sources. +# +# Note: To get rid of all source code in the generated output, make sure that +# also VERBATIM_HEADERS is set to NO. +# The default value is: NO. + +SOURCE_BROWSER = NO + +# Setting the INLINE_SOURCES tag to YES will include the body of functions, +# classes and enums directly into the documentation. +# The default value is: NO. + +INLINE_SOURCES = NO + +# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any +# special comment blocks from generated source code fragments. Normal C, C++ and +# Fortran comments will always remain visible. +# The default value is: YES. + +STRIP_CODE_COMMENTS = YES + +# If the REFERENCED_BY_RELATION tag is set to YES then for each documented +# entity all documented functions referencing it will be listed. +# The default value is: NO. + +REFERENCED_BY_RELATION = NO + +# If the REFERENCES_RELATION tag is set to YES then for each documented function +# all documented entities called/used by that function will be listed. +# The default value is: NO. + +REFERENCES_RELATION = NO + +# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set +# to YES then the hyperlinks from functions in REFERENCES_RELATION and +# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will +# link to the documentation. +# The default value is: YES. + +REFERENCES_LINK_SOURCE = YES + +# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the +# source code will show a tooltip with additional information such as prototype, +# brief description and links to the definition and documentation. Since this +# will make the HTML file larger and loading of large files a bit slower, you +# can opt to disable this feature. +# The default value is: YES. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +SOURCE_TOOLTIPS = YES + +# If the USE_HTAGS tag is set to YES then the references to source code will +# point to the HTML generated by the htags(1) tool instead of doxygen built-in +# source browser. The htags tool is part of GNU's global source tagging system +# (see https://www.gnu.org/software/global/global.html). You will need version +# 4.8.6 or higher. +# +# To use it do the following: +# - Install the latest version of global +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file +# - Make sure the INPUT points to the root of the source tree +# - Run doxygen as normal +# +# Doxygen will invoke htags (and that will in turn invoke gtags), so these +# tools must be available from the command line (i.e. in the search path). +# +# The result: instead of the source browser generated by doxygen, the links to +# source code will now point to the output of htags. +# The default value is: NO. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +USE_HTAGS = NO + +# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a +# verbatim copy of the header file for each class for which an include is +# specified. Set to NO to disable this. +# See also: Section \class. +# The default value is: YES. + +VERBATIM_HEADERS = YES + +#--------------------------------------------------------------------------- +# Configuration options related to the alphabetical class index +#--------------------------------------------------------------------------- + +# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all +# compounds will be generated. Enable this if the project contains a lot of +# classes, structs, unions or interfaces. +# The default value is: YES. + +ALPHABETICAL_INDEX = NO + +# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in +# which the alphabetical index list will be split. +# Minimum value: 1, maximum value: 20, default value: 5. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +COLS_IN_ALPHA_INDEX = 5 + +# In case all classes in a project start with a common prefix, all classes will +# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag +# can be used to specify a prefix (or a list of prefixes) that should be ignored +# while generating the index headers. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +IGNORE_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the HTML output +#--------------------------------------------------------------------------- + +# If the GENERATE_HTML tag is set to YES, doxygen will generate HTML output +# The default value is: YES. + +GENERATE_HTML = YES + +# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_OUTPUT = html + +# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each +# generated HTML page (for example: .htm, .php, .asp). +# The default value is: .html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FILE_EXTENSION = .html + +# The HTML_HEADER tag can be used to specify a user-defined HTML header file for +# each generated HTML page. If the tag is left blank doxygen will generate a +# standard header. +# +# To get valid HTML the header file that includes any scripts and style sheets +# that doxygen needs, which is dependent on the configuration options used (e.g. +# the setting GENERATE_TREEVIEW). It is highly recommended to start with a +# default header using +# doxygen -w html new_header.html new_footer.html new_stylesheet.css +# YourConfigFile +# and then modify the file new_header.html. See also section "Doxygen usage" +# for information on how to generate the default header that doxygen normally +# uses. +# Note: The header is subject to change so you typically have to regenerate the +# default header when upgrading to a newer version of doxygen. For a description +# of the possible markers and block names see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_HEADER = + +# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each +# generated HTML page. If the tag is left blank doxygen will generate a standard +# footer. See HTML_HEADER for more information on how to generate a default +# footer and what special commands can be used inside the footer. See also +# section "Doxygen usage" for information on how to generate the default footer +# that doxygen normally uses. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FOOTER = + +# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style +# sheet that is used by each HTML page. It can be used to fine-tune the look of +# the HTML output. If left blank doxygen will generate a default style sheet. +# See also section "Doxygen usage" for information on how to generate the style +# sheet that doxygen normally uses. +# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as +# it is more robust and this tag (HTML_STYLESHEET) will in the future become +# obsolete. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_STYLESHEET = + +# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined +# cascading style sheets that are included after the standard style sheets +# created by doxygen. Using this option one can overrule certain style aspects. +# This is preferred over using HTML_STYLESHEET since it does not replace the +# standard style sheet and is therefore more robust against future updates. +# Doxygen will copy the style sheet files to the output directory. +# Note: The order of the extra style sheet files is of importance (e.g. the last +# style sheet in the list overrules the setting of the previous ones in the +# list). For an example see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_STYLESHEET = + +# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or +# other source files which should be copied to the HTML output directory. Note +# that these files will be copied to the base HTML output directory. Use the +# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these +# files. In the HTML_STYLESHEET file, use the file name only. Also note that the +# files will be copied as-is; there are no commands or markers available. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_FILES = + +# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen +# will adjust the colors in the style sheet and background images according to +# this color. Hue is specified as an angle on a colorwheel, see +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value +# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 +# purple, and 360 is red again. +# Minimum value: 0, maximum value: 359, default value: 220. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_HUE = 220 + +# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors +# in the HTML output. For a value of 0 the output will use grayscales only. A +# value of 255 will produce the most vivid colors. +# Minimum value: 0, maximum value: 255, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_SAT = 100 + +# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the +# luminance component of the colors in the HTML output. Values below 100 +# gradually make the output lighter, whereas values above 100 make the output +# darker. The value divided by 100 is the actual gamma applied, so 80 represents +# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not +# change the gamma. +# Minimum value: 40, maximum value: 240, default value: 80. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_GAMMA = 80 + +# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML +# page will contain the date and time when the page was generated. Setting this +# to YES can help to show when doxygen was last run and thus if the +# documentation is up to date. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_TIMESTAMP = YES + +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via Javascript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have Javascript, +# like the Qt help browser. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_MENUS = YES + +# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML +# documentation will contain sections that can be hidden and shown after the +# page has loaded. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_SECTIONS = NO + +# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries +# shown in the various tree structured indices initially; the user can expand +# and collapse entries dynamically later on. Doxygen will expand the tree to +# such a level that at most the specified number of entries are visible (unless +# a fully collapsed tree already exceeds this amount). So setting the number of +# entries 1 will produce a full collapsed tree by default. 0 is a special value +# representing an infinite number of entries and will result in a full expanded +# tree by default. +# Minimum value: 0, maximum value: 9999, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_INDEX_NUM_ENTRIES = 100 + +# If the GENERATE_DOCSET tag is set to YES, additional index files will be +# generated that can be used as input for Apple's Xcode 3 integrated development +# environment (see: https://developer.apple.com/xcode/), introduced with OSX +# 10.5 (Leopard). To create a documentation set, doxygen will generate a +# Makefile in the HTML output directory. Running make will produce the docset in +# that directory and running make install will install the docset in +# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_DOCSET = NO + +# This tag determines the name of the docset feed. A documentation feed provides +# an umbrella under which multiple documentation sets from a single provider +# (such as a company or product suite) can be grouped. +# The default value is: Doxygen generated docs. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_FEEDNAME = "Doxygen generated docs" + +# This tag specifies a string that should uniquely identify the documentation +# set bundle. This should be a reverse domain-name style string, e.g. +# com.mycompany.MyDocSet. Doxygen will append .docset to the name. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_BUNDLE_ID = org.doxygen.Project + +# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify +# the documentation publisher. This should be a reverse domain-name style +# string, e.g. com.mycompany.MyDocSet.documentation. +# The default value is: org.doxygen.Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_ID = org.doxygen.Publisher + +# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher. +# The default value is: Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_NAME = Publisher + +# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three +# additional HTML index files: index.hhp, index.hhc, and index.hhk. The +# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop +# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# Windows. +# +# The HTML Help Workshop contains a compiler that can convert all HTML output +# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML +# files are now used as the Windows 98 help format, and will replace the old +# Windows help format (.hlp) on all Windows platforms in the future. Compressed +# HTML files also contain an index, a table of contents, and you can search for +# words in the documentation. The HTML workshop also contains a viewer for +# compressed HTML files. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_HTMLHELP = NO + +# The CHM_FILE tag can be used to specify the file name of the resulting .chm +# file. You can add a path in front of the file if the result should not be +# written to the html output directory. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_FILE = + +# The HHC_LOCATION tag can be used to specify the location (absolute path +# including file name) of the HTML help compiler (hhc.exe). If non-empty, +# doxygen will try to run the HTML help compiler on the generated index.hhp. +# The file has to be specified with full path. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +HHC_LOCATION = + +# The GENERATE_CHI flag controls if a separate .chi index file is generated +# (YES) or that it should be included in the master .chm file (NO). +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +GENERATE_CHI = NO + +# The CHM_INDEX_ENCODING is used to encode HtmlHelp index (hhk), content (hhc) +# and project file content. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_INDEX_ENCODING = + +# The BINARY_TOC flag controls whether a binary table of contents is generated +# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it +# enables the Previous and Next buttons. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +BINARY_TOC = NO + +# The TOC_EXPAND flag can be set to YES to add extra items for group members to +# the table of contents of the HTML help documentation and to the tree view. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +TOC_EXPAND = NO + +# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and +# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that +# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help +# (.qch) of the generated HTML documentation. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_QHP = NO + +# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify +# the file name of the resulting .qch file. The path specified is relative to +# the HTML output folder. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QCH_FILE = + +# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help +# Project output. For more information please see Qt Help Project / Namespace +# (see: http://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_NAMESPACE = org.doxygen.Project + +# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt +# Help Project output. For more information please see Qt Help Project / Virtual +# Folders (see: http://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- +# folders). +# The default value is: doc. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_VIRTUAL_FOLDER = doc + +# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom +# filter to add. For more information please see Qt Help Project / Custom +# Filters (see: http://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_NAME = + +# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the +# custom filter to add. For more information please see Qt Help Project / Custom +# Filters (see: http://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_ATTRS = + +# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this +# project's filter section matches. Qt Help Project / Filter Attributes (see: +# http://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_SECT_FILTER_ATTRS = + +# The QHG_LOCATION tag can be used to specify the location of Qt's +# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the +# generated .qhp file. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHG_LOCATION = + +# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be +# generated, together with the HTML files, they form an Eclipse help plugin. To +# install this plugin and make it available under the help contents menu in +# Eclipse, the contents of the directory containing the HTML and XML files needs +# to be copied into the plugins directory of eclipse. The name of the directory +# within the plugins directory should be the same as the ECLIPSE_DOC_ID value. +# After copying Eclipse needs to be restarted before the help appears. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_ECLIPSEHELP = NO + +# A unique identifier for the Eclipse help plugin. When installing the plugin +# the directory name containing the HTML and XML files should also have this +# name. Each documentation set should have its own identifier. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES. + +ECLIPSE_DOC_ID = org.doxygen.Project + +# If you want full control over the layout of the generated HTML pages it might +# be necessary to disable the index and replace it with your own. The +# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top +# of each HTML page. A value of NO enables the index and the value YES disables +# it. Since the tabs in the index contain the same information as the navigation +# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +DISABLE_INDEX = NO + +# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index +# structure should be generated to display hierarchical information. If the tag +# value is set to YES, a side panel will be generated containing a tree-like +# index structure (just like the one that is generated for HTML Help). For this +# to work a browser that supports JavaScript, DHTML, CSS and frames is required +# (i.e. any modern browser). Windows users are probably better off using the +# HTML help feature. Via custom style sheets (see HTML_EXTRA_STYLESHEET) one can +# further fine-tune the look of the index. As an example, the default style +# sheet generated by doxygen has an example that shows how to put an image at +# the root of the tree instead of the PROJECT_NAME. Since the tree basically has +# the same information as the tab index, you could consider setting +# DISABLE_INDEX to YES when enabling this option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_TREEVIEW = NO + +# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that +# doxygen will group on one line in the generated HTML documentation. +# +# Note that a value of 0 will completely suppress the enum values from appearing +# in the overview section. +# Minimum value: 0, maximum value: 20, default value: 4. +# This tag requires that the tag GENERATE_HTML is set to YES. + +ENUM_VALUES_PER_LINE = 4 + +# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used +# to set the initial width (in pixels) of the frame in which the tree is shown. +# Minimum value: 0, maximum value: 1500, default value: 250. +# This tag requires that the tag GENERATE_HTML is set to YES. + +TREEVIEW_WIDTH = 250 + +# If the EXT_LINKS_IN_WINDOW option is set to YES, doxygen will open links to +# external symbols imported via tag files in a separate window. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +EXT_LINKS_IN_WINDOW = NO + +# Use this tag to change the font size of LaTeX formulas included as images in +# the HTML documentation. When you change the font size after a successful +# doxygen run you need to manually remove any form_*.png images from the HTML +# output directory to force them to be regenerated. +# Minimum value: 8, maximum value: 50, default value: 10. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_FONTSIZE = 10 + +# Use the FORMULA_TRANSPARENT tag to determine whether or not the images +# generated for formulas are transparent PNGs. Transparent PNGs are not +# supported properly for IE 6.0, but are supported on all modern browsers. +# +# Note that when changing this option you need to delete any form_*.png files in +# the HTML output directory before the changes have effect. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_TRANSPARENT = YES + +# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see +# https://www.mathjax.org) which uses client side Javascript for the rendering +# instead of using pre-rendered bitmaps. Use this if you do not have LaTeX +# installed or if you want to formulas look prettier in the HTML output. When +# enabled you may also need to install MathJax separately and configure the path +# to it using the MATHJAX_RELPATH option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +USE_MATHJAX = NO + +# When MathJax is enabled you can set the default output format to be used for +# the MathJax output. See the MathJax site (see: +# http://docs.mathjax.org/en/latest/output.html) for more details. +# Possible values are: HTML-CSS (which is slower, but has the best +# compatibility), NativeMML (i.e. MathML) and SVG. +# The default value is: HTML-CSS. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_FORMAT = HTML-CSS + +# When MathJax is enabled you need to specify the location relative to the HTML +# output directory using the MATHJAX_RELPATH option. The destination directory +# should contain the MathJax.js script. For instance, if the mathjax directory +# is located at the same level as the HTML output directory, then +# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax +# Content Delivery Network so you can quickly see the result without installing +# MathJax. However, it is strongly recommended to install a local copy of +# MathJax from https://www.mathjax.org before deployment. +# The default value is: https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest + +# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax +# extension names that should be enabled during MathJax rendering. For example +# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_EXTENSIONS = + +# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces +# of code that will be used on startup of the MathJax code. See the MathJax site +# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# example see the documentation. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_CODEFILE = + +# When the SEARCHENGINE tag is enabled doxygen will generate a search box for +# the HTML output. The underlying search engine uses javascript and DHTML and +# should work on any modern browser. Note that when using HTML help +# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET) +# there is already a search function so this one should typically be disabled. +# For large projects the javascript based search engine can be slow, then +# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to +# search using the keyboard; to jump to the search box use <access key> + S +# (what the <access key> is depends on the OS and browser, but it is typically +# <CTRL>, <ALT>/<option>, or both). Inside the search box use the <cursor down +# key> to jump into the search results window, the results can be navigated +# using the <cursor keys>. Press <Enter> to select an item or <escape> to cancel +# the search. The filter options can be selected when the cursor is inside the +# search box by pressing <Shift>+<cursor down>. Also here use the <cursor keys> +# to select a filter and <Enter> or <escape> to activate or cancel the filter +# option. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +SEARCHENGINE = YES + +# When the SERVER_BASED_SEARCH tag is enabled the search engine will be +# implemented using a web server instead of a web client using Javascript. There +# are two flavors of web server based searching depending on the EXTERNAL_SEARCH +# setting. When disabled, doxygen will generate a PHP script for searching and +# an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing +# and searching needs to be provided by external tools. See the section +# "External Indexing and Searching" for details. +# The default value is: NO. +# This tag requires that the tag SEARCHENGINE is set to YES. + +SERVER_BASED_SEARCH = NO + +# When EXTERNAL_SEARCH tag is enabled doxygen will no longer generate the PHP +# script for searching. Instead the search results are written to an XML file +# which needs to be processed by an external indexer. Doxygen will invoke an +# external search engine pointed to by the SEARCHENGINE_URL option to obtain the +# search results. +# +# Doxygen ships with an example indexer (doxyindexer) and search engine +# (doxysearch.cgi) which are based on the open source search engine library +# Xapian (see: https://xapian.org/). +# +# See the section "External Indexing and Searching" for details. +# The default value is: NO. +# This tag requires that the tag SEARCHENGINE is set to YES. + +EXTERNAL_SEARCH = NO + +# The SEARCHENGINE_URL should point to a search engine hosted by a web server +# which will return the search results when EXTERNAL_SEARCH is enabled. +# +# Doxygen ships with an example indexer (doxyindexer) and search engine +# (doxysearch.cgi) which are based on the open source search engine library +# Xapian (see: https://xapian.org/). See the section "External Indexing and +# Searching" for details. +# This tag requires that the tag SEARCHENGINE is set to YES. + +SEARCHENGINE_URL = + +# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed +# search data is written to a file for indexing by an external tool. With the +# SEARCHDATA_FILE tag the name of this file can be specified. +# The default file is: searchdata.xml. +# This tag requires that the tag SEARCHENGINE is set to YES. + +SEARCHDATA_FILE = searchdata.xml + +# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the +# EXTERNAL_SEARCH_ID tag can be used as an identifier for the project. This is +# useful in combination with EXTRA_SEARCH_MAPPINGS to search through multiple +# projects and redirect the results back to the right project. +# This tag requires that the tag SEARCHENGINE is set to YES. + +EXTERNAL_SEARCH_ID = + +# The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen +# projects other than the one defined by this configuration file, but that are +# all added to the same external search index. Each project needs to have a +# unique id set via EXTERNAL_SEARCH_ID. The search mapping then maps the id of +# to a relative location where the documentation can be found. The format is: +# EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ... +# This tag requires that the tag SEARCHENGINE is set to YES. + +EXTRA_SEARCH_MAPPINGS = + +#--------------------------------------------------------------------------- +# Configuration options related to the LaTeX output +#--------------------------------------------------------------------------- + +# If the GENERATE_LATEX tag is set to YES, doxygen will generate LaTeX output. +# The default value is: YES. + +GENERATE_LATEX = YES + +# The LATEX_OUTPUT tag is used to specify where the LaTeX docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: latex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_OUTPUT = latex + +# The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be +# invoked. +# +# Note that when not enabling USE_PDFLATEX the default is latex when enabling +# USE_PDFLATEX the default is pdflatex and when in the later case latex is +# chosen this is overwritten by pdflatex. For specific output languages the +# default can have been set differently, this depends on the implementation of +# the output language. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_CMD_NAME = latex + +# The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate +# index for LaTeX. +# Note: This tag is used in the Makefile / make.bat. +# See also: LATEX_MAKEINDEX_CMD for the part in the generated output file +# (.tex). +# The default file is: makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +MAKEINDEX_CMD_NAME = makeindex + +# The LATEX_MAKEINDEX_CMD tag can be used to specify the command name to +# generate index for LaTeX. +# Note: This tag is used in the generated output file (.tex). +# See also: MAKEINDEX_CMD_NAME for the part in the Makefile / make.bat. +# The default value is: \makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_MAKEINDEX_CMD = \makeindex + +# If the COMPACT_LATEX tag is set to YES, doxygen generates more compact LaTeX +# documents. This may be useful for small projects and may help to save some +# trees in general. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +COMPACT_LATEX = NO + +# The PAPER_TYPE tag can be used to set the paper type that is used by the +# printer. +# Possible values are: a4 (210 x 297 mm), letter (8.5 x 11 inches), legal (8.5 x +# 14 inches) and executive (7.25 x 10.5 inches). +# The default value is: a4. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +PAPER_TYPE = a4 + +# The EXTRA_PACKAGES tag can be used to specify one or more LaTeX package names +# that should be included in the LaTeX output. The package can be specified just +# by its name or with the correct syntax as to be used with the LaTeX +# \usepackage command. To get the times font for instance you can specify : +# EXTRA_PACKAGES=times or EXTRA_PACKAGES={times} +# To use the option intlimits with the amsmath package you can specify: +# EXTRA_PACKAGES=[intlimits]{amsmath} +# If left blank no extra packages will be included. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +EXTRA_PACKAGES = + +# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the +# generated LaTeX document. The header should contain everything until the first +# chapter. If it is left blank doxygen will generate a standard header. See +# section "Doxygen usage" for information on how to let doxygen write the +# default header to a separate file. +# +# Note: Only use a user-defined header if you know what you are doing! The +# following commands have a special meaning inside the header: $title, +# $datetime, $date, $doxygenversion, $projectname, $projectnumber, +# $projectbrief, $projectlogo. Doxygen will replace $title with the empty +# string, for the replacement values of the other commands the user is referred +# to HTML_HEADER. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_HEADER = + +# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the +# generated LaTeX document. The footer should contain everything after the last +# chapter. If it is left blank doxygen will generate a standard footer. See +# LATEX_HEADER for more information on how to generate a default footer and what +# special commands can be used inside the footer. +# +# Note: Only use a user-defined footer if you know what you are doing! +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_FOOTER = + +# The LATEX_EXTRA_STYLESHEET tag can be used to specify additional user-defined +# LaTeX style sheets that are included after the standard style sheets created +# by doxygen. Using this option one can overrule certain style aspects. Doxygen +# will copy the style sheet files to the output directory. +# Note: The order of the extra style sheet files is of importance (e.g. the last +# style sheet in the list overrules the setting of the previous ones in the +# list). +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EXTRA_STYLESHEET = + +# The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or +# other source files which should be copied to the LATEX_OUTPUT output +# directory. Note that the files will be copied as-is; there are no commands or +# markers available. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EXTRA_FILES = + +# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is +# prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will +# contain links (just like the HTML output) instead of page references. This +# makes the output suitable for online browsing using a PDF viewer. +# The default value is: YES. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +PDF_HYPERLINKS = YES + +# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate +# the PDF file directly from the LaTeX files. Set this option to YES, to get a +# higher quality PDF documentation. +# The default value is: YES. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +USE_PDFLATEX = YES + +# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \batchmode +# command to the generated LaTeX files. This will instruct LaTeX to keep running +# if errors occur, instead of asking the user for help. This option is also used +# when generating formulas in HTML. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_BATCHMODE = NO + +# If the LATEX_HIDE_INDICES tag is set to YES then doxygen will not include the +# index chapters (such as File Index, Compound Index, etc.) in the output. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_HIDE_INDICES = NO + +# If the LATEX_SOURCE_CODE tag is set to YES then doxygen will include source +# code with syntax highlighting in the LaTeX output. +# +# Note that which sources are shown also depends on other settings such as +# SOURCE_BROWSER. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_SOURCE_CODE = NO + +# The LATEX_BIB_STYLE tag can be used to specify the style to use for the +# bibliography, e.g. plainnat, or ieeetr. See +# https://en.wikipedia.org/wiki/BibTeX and \cite for more info. +# The default value is: plain. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_BIB_STYLE = plain + +# If the LATEX_TIMESTAMP tag is set to YES then the footer of each generated +# page will contain the date and time when the page was generated. Setting this +# to NO can help when comparing the output of multiple runs. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_TIMESTAMP = NO + +# The LATEX_EMOJI_DIRECTORY tag is used to specify the (relative or absolute) +# path from which the emoji images will be read. If a relative path is entered, +# it will be relative to the LATEX_OUTPUT directory. If left blank the +# LATEX_OUTPUT directory will be used. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EMOJI_DIRECTORY = + +#--------------------------------------------------------------------------- +# Configuration options related to the RTF output +#--------------------------------------------------------------------------- + +# If the GENERATE_RTF tag is set to YES, doxygen will generate RTF output. The +# RTF output is optimized for Word 97 and may not look too pretty with other RTF +# readers/editors. +# The default value is: NO. + +GENERATE_RTF = NO + +# The RTF_OUTPUT tag is used to specify where the RTF docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: rtf. +# This tag requires that the tag GENERATE_RTF is set to YES. + +RTF_OUTPUT = rtf + +# If the COMPACT_RTF tag is set to YES, doxygen generates more compact RTF +# documents. This may be useful for small projects and may help to save some +# trees in general. +# The default value is: NO. +# This tag requires that the tag GENERATE_RTF is set to YES. + +COMPACT_RTF = NO + +# If the RTF_HYPERLINKS tag is set to YES, the RTF that is generated will +# contain hyperlink fields. The RTF file will contain links (just like the HTML +# output) instead of page references. This makes the output suitable for online +# browsing using Word or some other Word compatible readers that support those +# fields. +# +# Note: WordPad (write) and others do not support links. +# The default value is: NO. +# This tag requires that the tag GENERATE_RTF is set to YES. + +RTF_HYPERLINKS = NO + +# Load stylesheet definitions from file. Syntax is similar to doxygen's +# configuration file, i.e. a series of assignments. You only have to provide +# replacements, missing definitions are set to their default value. +# +# See also section "Doxygen usage" for information on how to generate the +# default style sheet that doxygen normally uses. +# This tag requires that the tag GENERATE_RTF is set to YES. + +RTF_STYLESHEET_FILE = + +# Set optional variables used in the generation of an RTF document. Syntax is +# similar to doxygen's configuration file. A template extensions file can be +# generated using doxygen -e rtf extensionFile. +# This tag requires that the tag GENERATE_RTF is set to YES. + +RTF_EXTENSIONS_FILE = + +# If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code +# with syntax highlighting in the RTF output. +# +# Note that which sources are shown also depends on other settings such as +# SOURCE_BROWSER. +# The default value is: NO. +# This tag requires that the tag GENERATE_RTF is set to YES. + +RTF_SOURCE_CODE = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the man page output +#--------------------------------------------------------------------------- + +# If the GENERATE_MAN tag is set to YES, doxygen will generate man pages for +# classes and files. +# The default value is: NO. + +GENERATE_MAN = NO + +# The MAN_OUTPUT tag is used to specify where the man pages will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. A directory man3 will be created inside the directory specified by +# MAN_OUTPUT. +# The default directory is: man. +# This tag requires that the tag GENERATE_MAN is set to YES. + +MAN_OUTPUT = man + +# The MAN_EXTENSION tag determines the extension that is added to the generated +# man pages. In case the manual section does not start with a number, the number +# 3 is prepended. The dot (.) at the beginning of the MAN_EXTENSION tag is +# optional. +# The default value is: .3. +# This tag requires that the tag GENERATE_MAN is set to YES. + +MAN_EXTENSION = .3 + +# The MAN_SUBDIR tag determines the name of the directory created within +# MAN_OUTPUT in which the man pages are placed. If defaults to man followed by +# MAN_EXTENSION with the initial . removed. +# This tag requires that the tag GENERATE_MAN is set to YES. + +MAN_SUBDIR = + +# If the MAN_LINKS tag is set to YES and doxygen generates man output, then it +# will generate one additional man file for each entity documented in the real +# man page(s). These additional files only source the real man page, but without +# them the man command would be unable to find the correct page. +# The default value is: NO. +# This tag requires that the tag GENERATE_MAN is set to YES. + +MAN_LINKS = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the XML output +#--------------------------------------------------------------------------- + +# If the GENERATE_XML tag is set to YES, doxygen will generate an XML file that +# captures the structure of the code including all documentation. +# The default value is: NO. + +GENERATE_XML = NO + +# The XML_OUTPUT tag is used to specify where the XML pages will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: xml. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_OUTPUT = xml + +# If the XML_PROGRAMLISTING tag is set to YES, doxygen will dump the program +# listings (including syntax highlighting and cross-referencing information) to +# the XML output. Note that enabling this will significantly increase the size +# of the XML output. +# The default value is: YES. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_PROGRAMLISTING = YES + +# If the XML_NS_MEMB_FILE_SCOPE tag is set to YES, doxygen will include +# namespace members in file scope as well, matching the HTML output. +# The default value is: NO. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_NS_MEMB_FILE_SCOPE = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the DOCBOOK output +#--------------------------------------------------------------------------- + +# If the GENERATE_DOCBOOK tag is set to YES, doxygen will generate Docbook files +# that can be used to generate PDF. +# The default value is: NO. + +GENERATE_DOCBOOK = NO + +# The DOCBOOK_OUTPUT tag is used to specify where the Docbook pages will be put. +# If a relative path is entered the value of OUTPUT_DIRECTORY will be put in +# front of it. +# The default directory is: docbook. +# This tag requires that the tag GENERATE_DOCBOOK is set to YES. + +DOCBOOK_OUTPUT = docbook + +# If the DOCBOOK_PROGRAMLISTING tag is set to YES, doxygen will include the +# program listings (including syntax highlighting and cross-referencing +# information) to the DOCBOOK output. Note that enabling this will significantly +# increase the size of the DOCBOOK output. +# The default value is: NO. +# This tag requires that the tag GENERATE_DOCBOOK is set to YES. + +DOCBOOK_PROGRAMLISTING = NO + +#--------------------------------------------------------------------------- +# Configuration options for the AutoGen Definitions output +#--------------------------------------------------------------------------- + +# If the GENERATE_AUTOGEN_DEF tag is set to YES, doxygen will generate an +# AutoGen Definitions (see http://autogen.sourceforge.net/) file that captures +# the structure of the code including all documentation. Note that this feature +# is still experimental and incomplete at the moment. +# The default value is: NO. + +GENERATE_AUTOGEN_DEF = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the Perl module output +#--------------------------------------------------------------------------- + +# If the GENERATE_PERLMOD tag is set to YES, doxygen will generate a Perl module +# file that captures the structure of the code including all documentation. +# +# Note that this feature is still experimental and incomplete at the moment. +# The default value is: NO. + +GENERATE_PERLMOD = NO + +# If the PERLMOD_LATEX tag is set to YES, doxygen will generate the necessary +# Makefile rules, Perl scripts and LaTeX code to be able to generate PDF and DVI +# output from the Perl module output. +# The default value is: NO. +# This tag requires that the tag GENERATE_PERLMOD is set to YES. + +PERLMOD_LATEX = NO + +# If the PERLMOD_PRETTY tag is set to YES, the Perl module output will be nicely +# formatted so it can be parsed by a human reader. This is useful if you want to +# understand what is going on. On the other hand, if this tag is set to NO, the +# size of the Perl module output will be much smaller and Perl will parse it +# just the same. +# The default value is: YES. +# This tag requires that the tag GENERATE_PERLMOD is set to YES. + +PERLMOD_PRETTY = YES + +# The names of the make variables in the generated doxyrules.make file are +# prefixed with the string contained in PERLMOD_MAKEVAR_PREFIX. This is useful +# so different doxyrules.make files included by the same Makefile don't +# overwrite each other's variables. +# This tag requires that the tag GENERATE_PERLMOD is set to YES. + +PERLMOD_MAKEVAR_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the preprocessor +#--------------------------------------------------------------------------- + +# If the ENABLE_PREPROCESSING tag is set to YES, doxygen will evaluate all +# C-preprocessor directives found in the sources and include files. +# The default value is: YES. + +ENABLE_PREPROCESSING = YES + +# If the MACRO_EXPANSION tag is set to YES, doxygen will expand all macro names +# in the source code. If set to NO, only conditional compilation will be +# performed. Macro expansion can be done in a controlled way by setting +# EXPAND_ONLY_PREDEF to YES. +# The default value is: NO. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +MACRO_EXPANSION = NO + +# If the EXPAND_ONLY_PREDEF and MACRO_EXPANSION tags are both set to YES then +# the macro expansion is limited to the macros specified with the PREDEFINED and +# EXPAND_AS_DEFINED tags. +# The default value is: NO. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +EXPAND_ONLY_PREDEF = NO + +# If the SEARCH_INCLUDES tag is set to YES, the include files in the +# INCLUDE_PATH will be searched if a #include is found. +# The default value is: YES. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +SEARCH_INCLUDES = YES + +# The INCLUDE_PATH tag can be used to specify one or more directories that +# contain include files that are not input files but should be processed by the +# preprocessor. +# This tag requires that the tag SEARCH_INCLUDES is set to YES. + +INCLUDE_PATH = + +# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard +# patterns (like *.h and *.hpp) to filter out the header-files in the +# directories. If left blank, the patterns specified with FILE_PATTERNS will be +# used. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +INCLUDE_FILE_PATTERNS = + +# The PREDEFINED tag can be used to specify one or more macro names that are +# defined before the preprocessor is started (similar to the -D option of e.g. +# gcc). The argument of the tag is a list of macros of the form: name or +# name=definition (no spaces). If the definition and the "=" are omitted, "=1" +# is assumed. To prevent a macro definition from being undefined via #undef or +# recursively expanded use the := operator instead of the = operator. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +PREDEFINED = + +# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this +# tag can be used to specify a list of macro names that should be expanded. The +# macro definition that is found in the sources will be used. Use the PREDEFINED +# tag if you want to use a different macro definition that overrules the +# definition found in the source code. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +EXPAND_AS_DEFINED = + +# If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will +# remove all references to function-like macros that are alone on a line, have +# an all uppercase name, and do not end with a semicolon. Such function macros +# are typically used for boiler-plate code, and will confuse the parser if not +# removed. +# The default value is: YES. +# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. + +SKIP_FUNCTION_MACROS = YES + +#--------------------------------------------------------------------------- +# Configuration options related to external references +#--------------------------------------------------------------------------- + +# The TAGFILES tag can be used to specify one or more tag files. For each tag +# file the location of the external documentation should be added. The format of +# a tag file without this location is as follows: +# TAGFILES = file1 file2 ... +# Adding location for the tag files is done as follows: +# TAGFILES = file1=loc1 "file2 = loc2" ... +# where loc1 and loc2 can be relative or absolute paths or URLs. See the +# section "Linking to external documentation" for more information about the use +# of tag files. +# Note: Each tag file must have a unique name (where the name does NOT include +# the path). If a tag file is not located in the directory in which doxygen is +# run, you must also specify the path to the tagfile here. + +TAGFILES = + +# When a file name is specified after GENERATE_TAGFILE, doxygen will create a +# tag file that is based on the input files it reads. See section "Linking to +# external documentation" for more information about the usage of tag files. + +GENERATE_TAGFILE = + +# If the ALLEXTERNALS tag is set to YES, all external class will be listed in +# the class index. If set to NO, only the inherited external classes will be +# listed. +# The default value is: NO. + +ALLEXTERNALS = NO + +# If the EXTERNAL_GROUPS tag is set to YES, all external groups will be listed +# in the modules index. If set to NO, only the current project's groups will be +# listed. +# The default value is: YES. + +EXTERNAL_GROUPS = YES + +# If the EXTERNAL_PAGES tag is set to YES, all external pages will be listed in +# the related pages index. If set to NO, only the current project's pages will +# be listed. +# The default value is: YES. + +EXTERNAL_PAGES = YES + +# The PERL_PATH should be the absolute path and name of the perl script +# interpreter (i.e. the result of 'which perl'). +# The default file (with absolute path) is: /usr/bin/perl. + +PERL_PATH = /usr/bin/perl + +#--------------------------------------------------------------------------- +# Configuration options related to the dot tool +#--------------------------------------------------------------------------- + +# If the CLASS_DIAGRAMS tag is set to YES, doxygen will generate a class diagram +# (in HTML and LaTeX) for classes with base or super classes. Setting the tag to +# NO turns the diagrams off. Note that this option also works with HAVE_DOT +# disabled, but it is recommended to install and use dot, since it yields more +# powerful graphs. +# The default value is: YES. + +CLASS_DIAGRAMS = YES + +# You can define message sequence charts within doxygen comments using the \msc +# command. Doxygen will then run the mscgen tool (see: +# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the +# documentation. The MSCGEN_PATH tag allows you to specify the directory where +# the mscgen tool resides. If left empty the tool is assumed to be found in the +# default search path. + +MSCGEN_PATH = + +# You can include diagrams made with dia in doxygen documentation. Doxygen will +# then run dia to produce the diagram and insert it in the documentation. The +# DIA_PATH tag allows you to specify the directory where the dia binary resides. +# If left empty dia is assumed to be found in the default search path. + +DIA_PATH = + +# If set to YES the inheritance and collaboration graphs will hide inheritance +# and usage relations if the target is undocumented or is not a class. +# The default value is: YES. + +HIDE_UNDOC_RELATIONS = YES + +# If you set the HAVE_DOT tag to YES then doxygen will assume the dot tool is +# available from the path. This tool is part of Graphviz (see: +# http://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent +# Bell Labs. The other options in this section have no effect if this option is +# set to NO +# The default value is: NO. + +HAVE_DOT = NO + +# The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed +# to run in parallel. When set to 0 doxygen will base this on the number of +# processors available in the system. You can set it explicitly to a value +# larger than 0 to get control over the balance between CPU load and processing +# speed. +# Minimum value: 0, maximum value: 32, default value: 0. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_NUM_THREADS = 0 + +# When you want a differently looking font in the dot files that doxygen +# generates you can specify the font name using DOT_FONTNAME. You need to make +# sure dot is able to find the font, which can be done by putting it in a +# standard location or by setting the DOTFONTPATH environment variable or by +# setting DOT_FONTPATH to the directory containing the font. +# The default value is: Helvetica. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_FONTNAME = Helvetica + +# The DOT_FONTSIZE tag can be used to set the size (in points) of the font of +# dot graphs. +# Minimum value: 4, maximum value: 24, default value: 10. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_FONTSIZE = 10 + +# By default doxygen will tell dot to use the default font as specified with +# DOT_FONTNAME. If you specify a different font using DOT_FONTNAME you can set +# the path where dot can find it using this tag. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_FONTPATH = + +# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for +# each documented class showing the direct and indirect inheritance relations. +# Setting this tag to YES will force the CLASS_DIAGRAMS tag to NO. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +CLASS_GRAPH = YES + +# If the COLLABORATION_GRAPH tag is set to YES then doxygen will generate a +# graph for each documented class showing the direct and indirect implementation +# dependencies (inheritance, containment, and class references variables) of the +# class with other documented classes. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +COLLABORATION_GRAPH = YES + +# If the GROUP_GRAPHS tag is set to YES then doxygen will generate a graph for +# groups, showing the direct groups dependencies. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +GROUP_GRAPHS = YES + +# If the UML_LOOK tag is set to YES, doxygen will generate inheritance and +# collaboration diagrams in a style similar to the OMG's Unified Modeling +# Language. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +UML_LOOK = YES + +# If the UML_LOOK tag is enabled, the fields and methods are shown inside the +# class node. If there are many fields or methods and many nodes the graph may +# become too big to be useful. The UML_LIMIT_NUM_FIELDS threshold limits the +# number of items for each type to make the size more manageable. Set this to 0 +# for no limit. Note that the threshold may be exceeded by 50% before the limit +# is enforced. So when you set the threshold to 10, up to 15 fields may appear, +# but if the number exceeds 15, the total amount of fields shown is limited to +# 10. +# Minimum value: 0, maximum value: 100, default value: 10. +# This tag requires that the tag HAVE_DOT is set to YES. + +UML_LIMIT_NUM_FIELDS = 10 + +# If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and +# collaboration graphs will show the relations between templates and their +# instances. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +TEMPLATE_RELATIONS = NO + +# If the INCLUDE_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are set to +# YES then doxygen will generate a graph for each documented file showing the +# direct and indirect include dependencies of the file with other documented +# files. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +INCLUDE_GRAPH = YES + +# If the INCLUDED_BY_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are +# set to YES then doxygen will generate a graph for each documented file showing +# the direct and indirect include dependencies of the file with other documented +# files. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +INCLUDED_BY_GRAPH = YES + +# If the CALL_GRAPH tag is set to YES then doxygen will generate a call +# dependency graph for every global function or class method. +# +# Note that enabling this option will significantly increase the time of a run. +# So in most cases it will be better to enable call graphs for selected +# functions only using the \callgraph command. Disabling a call graph can be +# accomplished by means of the command \hidecallgraph. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +CALL_GRAPH = NO + +# If the CALLER_GRAPH tag is set to YES then doxygen will generate a caller +# dependency graph for every global function or class method. +# +# Note that enabling this option will significantly increase the time of a run. +# So in most cases it will be better to enable caller graphs for selected +# functions only using the \callergraph command. Disabling a caller graph can be +# accomplished by means of the command \hidecallergraph. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +CALLER_GRAPH = NO + +# If the GRAPHICAL_HIERARCHY tag is set to YES then doxygen will graphical +# hierarchy of all classes instead of a textual one. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +GRAPHICAL_HIERARCHY = YES + +# If the DIRECTORY_GRAPH tag is set to YES then doxygen will show the +# dependencies a directory has on other directories in a graphical way. The +# dependency relations are determined by the #include relations between the +# files in the directories. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +DIRECTORY_GRAPH = YES + +# The DOT_IMAGE_FORMAT tag can be used to set the image format of the images +# generated by dot. For an explanation of the image formats see the section +# output formats in the documentation of the dot tool (Graphviz (see: +# http://www.graphviz.org/)). +# Note: If you choose svg you need to set HTML_FILE_EXTENSION to xhtml in order +# to make the SVG files visible in IE 9+ (other browsers do not have this +# requirement). +# Possible values are: png, jpg, gif, svg, png:gd, png:gd:gd, png:cairo, +# png:cairo:gd, png:cairo:cairo, png:cairo:gdiplus, png:gdiplus and +# png:gdiplus:gdiplus. +# The default value is: png. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_IMAGE_FORMAT = png + +# If DOT_IMAGE_FORMAT is set to svg, then this option can be set to YES to +# enable generation of interactive SVG images that allow zooming and panning. +# +# Note that this requires a modern browser other than Internet Explorer. Tested +# and working are Firefox, Chrome, Safari, and Opera. +# Note: For IE 9+ you need to set HTML_FILE_EXTENSION to xhtml in order to make +# the SVG files visible. Older versions of IE do not have SVG support. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +INTERACTIVE_SVG = NO + +# The DOT_PATH tag can be used to specify the path where the dot tool can be +# found. If left blank, it is assumed the dot tool can be found in the path. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_PATH = + +# The DOTFILE_DIRS tag can be used to specify one or more directories that +# contain dot files that are included in the documentation (see the \dotfile +# command). +# This tag requires that the tag HAVE_DOT is set to YES. + +DOTFILE_DIRS = + +# The MSCFILE_DIRS tag can be used to specify one or more directories that +# contain msc files that are included in the documentation (see the \mscfile +# command). + +MSCFILE_DIRS = + +# The DIAFILE_DIRS tag can be used to specify one or more directories that +# contain dia files that are included in the documentation (see the \diafile +# command). + +DIAFILE_DIRS = + +# When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the +# path where java can find the plantuml.jar file. If left blank, it is assumed +# PlantUML is not used or called during a preprocessing step. Doxygen will +# generate a warning when it encounters a \startuml command in this case and +# will not generate output for the diagram. + +PLANTUML_JAR_PATH = + +# When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a +# configuration file for plantuml. + +PLANTUML_CFG_FILE = + +# When using plantuml, the specified paths are searched for files specified by +# the !include statement in a plantuml block. + +PLANTUML_INCLUDE_PATH = + +# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes +# that will be shown in the graph. If the number of nodes in a graph becomes +# larger than this value, doxygen will truncate the graph, which is visualized +# by representing a node as a red box. Note that doxygen if the number of direct +# children of the root node in a graph is already larger than +# DOT_GRAPH_MAX_NODES then the graph will not be shown at all. Also note that +# the size of a graph can be further restricted by MAX_DOT_GRAPH_DEPTH. +# Minimum value: 0, maximum value: 10000, default value: 50. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_GRAPH_MAX_NODES = 50 + +# The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the graphs +# generated by dot. A depth value of 3 means that only nodes reachable from the +# root by following a path via at most 3 edges will be shown. Nodes that lay +# further from the root node will be omitted. Note that setting this option to 1 +# or 2 may greatly reduce the computation time needed for large code bases. Also +# note that the size of a graph can be further restricted by +# DOT_GRAPH_MAX_NODES. Using a depth of 0 means no depth restriction. +# Minimum value: 0, maximum value: 1000, default value: 0. +# This tag requires that the tag HAVE_DOT is set to YES. + +MAX_DOT_GRAPH_DEPTH = 0 + +# Set the DOT_TRANSPARENT tag to YES to generate images with a transparent +# background. This is disabled by default, because dot on Windows does not seem +# to support this out of the box. +# +# Warning: Depending on the platform used, enabling this option may lead to +# badly anti-aliased labels on the edges of a graph (i.e. they become hard to +# read). +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_TRANSPARENT = NO + +# Set the DOT_MULTI_TARGETS tag to YES to allow dot to generate multiple output +# files in one run (i.e. multiple -o and -T options on the command line). This +# makes dot run faster, but since only newer versions of dot (>1.8.10) support +# this, this feature is disabled by default. +# The default value is: NO. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_MULTI_TARGETS = NO + +# If the GENERATE_LEGEND tag is set to YES doxygen will generate a legend page +# explaining the meaning of the various boxes and arrows in the dot generated +# graphs. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +GENERATE_LEGEND = YES + +# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate dot +# files that are used to generate the various graphs. +# The default value is: YES. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_CLEANUP = YES diff --git a/V4.0/nemo_sources/tools/SIREN/README b/V4.0/nemo_sources/tools/SIREN/README new file mode 100644 index 0000000000000000000000000000000000000000..d12b5db736d89879629f992af85b6e8ef14250d5 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/README @@ -0,0 +1,7 @@ + +To create SIREN documentation, run doxygen in TOOLS/SIREN directory +(http://www.stack.nl/~dimitri/doxygen/index.html version 1.8.5 or upper) +then + open ./TOOLS/SIREN/doc/html/index.html in your web browser +or + run gmake in ./TOOLS/SIREN/doc/latex directory and open ./TOOLS/SIREN/doc/latex/refman.pdf diff --git a/V4.0/nemo_sources/tools/SIREN/cfg/dimension.cfg b/V4.0/nemo_sources/tools/SIREN/cfg/dimension.cfg new file mode 100644 index 0000000000000000000000000000000000000000..fe0c0727a0538ebfd8c8a58e90c5908c9f711011 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/cfg/dimension.cfg @@ -0,0 +1,10 @@ +&namdim + in_dimX=2 + in_dimY=2 + in_dimZ=6 + in_dimT=3 + cn_dimX="x","xaxis" + cn_dimY="y","yaxis" + cn_dimZ="z","deptht","depthu","depthv","depthw","ncatice" + cn_dimT="t","time","time_counter" +/ diff --git a/V4.0/nemo_sources/tools/SIREN/cfg/dummy.cfg b/V4.0/nemo_sources/tools/SIREN/cfg/dummy.cfg new file mode 100644 index 0000000000000000000000000000000000000000..71f35b046b9c61132fc7254109392e2018b304cb --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/cfg/dummy.cfg @@ -0,0 +1,8 @@ +&namdum + in_ndumvar=4 + in_ndumdim=0 + in_ndumatt=1 + cn_dumvar="orca_lon", "orca_lat", "time_instant", "time_centered" + cn_dumdim="" + cn_dumatt="history" +/ diff --git a/V4.0/nemo_sources/tools/SIREN/cfg/variable.cfg b/V4.0/nemo_sources/tools/SIREN/cfg/variable.cfg new file mode 100644 index 0000000000000000000000000000000000000000..144e714db6254dacf2b4ed5860e739a5e94f4744 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/cfg/variable.cfg @@ -0,0 +1,165 @@ +# name | units | axis | pt| interpolation | long name | standard name +X | unitless | X | | | | projection_x_coordinate +Y | unitless | Y | | | | projection_y_coordinate +Z | unitless | Z | | | | projection_z_coordinate +T | unitless | T | | | | projection_t_coordinate +nav_lon | degrees_east | XY | T | cubic | Longitude | longitude +nav_lat | degrees_north | XY | T | cubic | Latitude | latitude +nav_lev | model_levels | Z | T | cubic | Model levels | +deptht | m | Z | T | | Vertical T levels | depth +ncatice | 1 | Z | T | | Ice category | num_icecat_coordinate +time_counter | | T | | | Time axis | time +Bathymetry | m | XY | T | cubic | Bathymetry | bathymetry +votemper | degree_Celsius | XYZT | T | cubic | Temperature | sea_water_potential_temperature +vozocrtx | m s-1 | XYZT | U | cubic | Zonal velocity | +vomecrty | m s-1 | XYZT | V | cubic | Meridional velocity | +vosaline | PSU | XYZT | T | cubic | Salinity | sea_water_salinity +sossheig | m | XYT | T | cubic | Sea Surface Height | sea_surface_height +sotemper | m | XYT | T | cubic | | +sossheig | m | XYT | T | cubic | | +glamt | degrees_east | XY | T | cubic | Longitude_T | +glamu | degrees_east | XY | U | cubic | Longitude_U | +glamv | degrees_east | XY | V | cubic | Longitude_V | +glamf | degrees_east | XY | F | cubic | Longitude_F | +gphit | degrees_north | XY | T | cubic | Latitude_T | +gphiu | degrees_north | XY | U | cubic | Latitude_U | +gphiv | degrees_north | XY | V | cubic | Latitude_V | +gphif | degrees_north | XY | F | cubic | Latitude_F | +e1t | m | XY | T | cubic/rhoi | | +e1u | m | XY | U | cubic/rhoi | | +e1v | m | XY | V | cubic/rhoi | | +e1f | m | XY | F | cubic/rhoi | | +e2t | m | XY | T | cubic/rhoj | | +e2u | m | XY | U | cubic/rhoj | | +e2v | m | XY | V | cubic/rhoj | | +e2f | m | XY | F | cubic/rhoj | | +tmask | | XYZ | T | nearest | | +umask | | XYZ | U | nearest | | +vmask | | XYZ | V | nearest | | +fmask | | XYZ | F | nearest | | +weight | | XY | T | | | +kt | | | | | | +ndastp | | | | | | +adatrj | | | | | | +kt | | | | | | +rdt | | | | | | +rdttra1 | | | | | | +utau_b | | XY | U | | |surface_downward_eastward_stress +vtau_b | | XY | V | | |surface_downward_northward_stress +qns_b | | XY | T | | | +emp_b | | XY | T | | | +sfx_b | | XY | T | | | +en | | XYZ | T | | | +avt | | XYZ | T | | vertical eddy diffusivity | +avm | | XYZ | T | | vertical eddy viscosity | +avmu | | XYZ | T | | | +avmv | | XYZ | T | | | +dissl | | XYZ | T | | | +sbc_hc_b | | XY | T | | | +sbc_sc_b | | XY | T | | | +gcx | | XY | T | | | +gcxb | | XY | T | | | +ub | | XYZ | U | | | +vb | | XYZ | V | | | +tb | | XYZ | T | | | +sb | | XYZ | T | | | +rotb | | XYZ | T | | | +hdivb | | XYZ | T | | | +sshb | | XY | T | | | +un | | XYZ | U | | | +vn | | XYZ | V | | | +tn | | XYZ | T | | | +sn | | XYZ | T | | | +rotn | | XYZ | T | | | +hdivn | | XYZ | T | | | +sshn | | XYT | T | | | +rhop | | XYZ | T | | | +dic | | XYZT | T | | Dissolved Inorganic Carbon | mole_concentration_of_dissolved_inorganic_caron_in_sea_water +alkalini | | XYZT | T | | Total Alkalinity | sea_water_alkalinity_expressed_as_mole_equivalent +o2 | | XYZT | T | | Dissolved Oxygen | mole_concentration_of_dissolved_molecular_oxygen_in_sea_water +caco3 | | XYZT | T | | Calcite | +po4 | | XYZT | T | | Phosphate | mole_concentration_of_phosphate_in_sea_water +poc | | XYZT | T | | Small Particulate Organic Carbon | +si | | XYZT | T | | Dissolved Silicate | mole_concentration_of_silicate_in_sea_water +phy | | XYZT | T | | Nanophytoplankton | +zoo | | XYZT | T | | Microzooplankton | mole_concentration_of_microzooplankton_expressed_as_carbon_in_sea_water +doc | | XYZT | T | | Dissolved Organic Carbon | +phy2 | | XYZT | T | | Diatoms | +zoo2 | | XYZT | T | | Mesozooplankton | mole_concentration_of_mesozooplankton_expressed_as_carbon_in_sea_water +gsi | | XYZT | T | | Sinking biogenic Silica | +fer | | XYZT | T | | Dissolved Iron | mole_concentration_of_dissolved_iron_in_sea_water +bfe | | XYZT | T | | Iron in the big particles | +goc | | XYZT | T | | Big Particulate Organic Carbon | +sfe | | XYZT | T | | Iron in the small particles | +dfe | | XYZT | T | | Iron content of the Diatoms | +dsi | | XYZT | T | | Silicon content of the Diatoms | +nfe | | XYZT | T | | Iron content of the Nanophytoplankton | +nchl | | XYZT | T | | Chlorophyll of the Nanophytoplankton | +dchl | | XYZT | T | | Chlorophyll of the Diatoms | +no3 | | XYZT | T | | Nitrate | mole_concentration_of_nitrate_in_sea_water +nh4 | | XYZT | T | | Ammonium | mole_concentration_of_ammonium_in_sea_water +ppd | | XYZT | T | | | +ppn | | XYZT | T | | | +ph | | XYZT | T | | | +cflx | | XYZT | T | | | +oflx | | XYZT | T | | | +kg | | XYZT | T | | | +dpco2 | | XYZT | T | | | +heup | | XYZT | T | | | +kz | | XYZT | T | | | +irondep | | XYZT | T | | | +sivelu | m/s | XYT | T | | Ice velocity along i-axis at I-point | sea_ice_x_velocity +sivelv | m/s | XYT | T | | Ice velocity along j-axis at I-point | sea_ice_y_velocity +siconcat | % | XYZT | T | | Ice concentration for categories | sea_ice_cat_concentration +sithicat | m | XYZT | T | | Ice thickness for categories | sea_ice_cat_icethickness +snthicat | m | XYZT | T | | Snow thickness for categories | sea_ice_cat_snowthickness +kt_ice | | | | | | +hicif | | | | | | +hsnif | | | | | | +frld | | | | | | +sist | | | | | | +tbif1 | | | | | | +tbif2 | | | | | | +tbif3 | | | | | | +ui_ice | | | | | | +vi_ice | | | | | | +qstoif | | | | | | +fsbbq | | | | | | +stress1_i | | | | | | +stress2_i | | | | | | +stress12_i | | | | | | +sxice | | | | | | +syice | | | | | | +sxxice | | | | | | +syyice | | | | | | +sxyice | | | | | | +sxsn | | | | | | +sysn | | | | | | +sxxsn | | | | | | +syysn | | | | | | +sxysn | | | | | | +sxa | | | | | | +sya | | | | | | +sxxa | | | | | | +syya | | | | | | +sxya | | | | | | +sxc0 | | | | | | +syc0 | | | | | | +sxxc0 | | | | | | +syyc0 | | | | | | +sxyc0 | | | | | | +sxc1 | | | | | | +syc1 | | | | | | +sxxc1 | | | | | | +syyc1 | | | | | | +sxyc1 | | | | | | +sxc2 | | | | | | +syc2 | | | | | | +sxxc2 | | | | | | +syyc2 | | | | | | +sxyc2 | | | | | | +sxst | | | | | | +syst | | | | | | +sxxst | | | | | | +syyst | | | | | | +sxyst | | | | | | diff --git a/V4.0/nemo_sources/tools/SIREN/src/addline_deg.f90 b/V4.0/nemo_sources/tools/SIREN/src/addline_deg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5d699a9d8dd6284bc9e9c4e8f16c470c11d89057 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/addline_deg.f90 @@ -0,0 +1,697 @@ +!---------------------------------------------------------------------- +! MERCATOR OCEAN, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +!> @file +!> @brief +!> This program add line to all variables of the input file. +!> +!> @details +!> @section sec2 how to +!> to add line to file:<br/> +!> @code{.sh} +!> ./SIREN/bin/addline addline.nam +!> @endcode +!> the namelist file (**addline.nam**) sets up program parameters. +!> +!> to set up program parameters, you just have to fill the namelist file (**add_line.nam**). +!> @note +!> you could find a template of the namelist in templates directory. +!> +!> create_bathy.nam comprise 4 namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source grid parameters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a addline.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the source/coarse grid sub-namelist parameters are : +!> +!> - **cn_coord0** [@a ]<br/> +!> path to the coordinate file +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varfile** [@a ]<br/> +!> list of variable, and associated file +!> +!> *cn_varfile* is the path and filename of the file where find +!> variable. +!> @note +!> *cn_varfile* could be a matrix of value, if you want to handwrite +!> variable value.<br/> +!> the variable array of value is split into equal subdomain.<br/> +!> each subdomain is filled with the corresponding value +!> of the matrix.<br/> +!> separators used to defined matrix are: +!> - ',' for line +!> - '/' for row +!> Example:<br/> +!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} +!> 3 & 2 & 3 \\ +!> 1 & 4 & 5 \end{array} \right) @f$ +!> +!> Examples: +!> - 'Bathymetry:gridT.nc' +!> +!> @note +!> Optionnaly, NEMO periodicity could be added following the filename. +!> the periodicity must be separated by ';' +!> +!> Example: +!> - 'Bathymetry:gridT.nc ; perio=4'<br/> +!> +!> - **cn_varinfo** [@a ]<br/> +!> list of variable and extra information about request(s) to be used<br/> +!> +!> each elements of *cn_varinfo* is a string character (separated by ',').<br/> +!> it is composed of the variable name follow by ':', +!> then request(s) to be used on this variable.<br/> +!> request could be: +!> - int = interpolation method +!> - ext = extrapolation method +!> - flt = filter method +!> - min = minimum value +!> - max = maximum value +!> - unt = new units +!> - unf = unit scale factor (linked to new units) +!> +!> requests must be separated by ';'.<br/> +!> order of requests does not matter.<br/> +!> +!> informations about available method could be find in @ref interp, +!> @ref extrap and @ref filter modules.<br/> +!> Example: +!> - 'Bathymetry: flt=2*hamming(2,3); min=0' +!> +!> @note +!> If you do not specify a method which is required, +!> default one is apply. +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a addline_deg.nc]<br/> +!> output filename +!> - @b ln_extrap [@a .FALSE.]<br/> +!> extrapolate extra line +!> - @b ln_copy [@a .FALSE.]<br/> +!> copy extra line from above +!> - **in_nproc** [@a 1]<br/> +!> number of processor to be used +!> - **in_niproc** [@a 1]<br/> +!> i-direction number of processor +!> - **in_njproc** [@a 1]<br/> +!> j-direction numebr of processor +!> +!> <hr> +!> @author J.Paul +!> @date October, 2015 - Initial Version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM addline_deg + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE multi ! multi file manager + USE iom ! I/O manager + USE grid ! grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE iom_mpp ! MPP I/O manager + + IMPLICIT NONE + + ! local variable + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_varid + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_index + INTEGER(i4) :: il_nvar + + LOGICAL :: ll_exist + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_mpp + TYPE(TMPP) :: tl_mppout + + TYPE(TATT) :: tl_att + + TYPE(TVAR) :: tl_lon + TYPE(TVAR) :: tl_lat + TYPE(TVAR) :: tl_depth + TYPE(TVAR) :: tl_time + + TYPE(TVAR) :: tl_tmp + TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_var + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TMULTI) :: tl_multi + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jvar + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'addline.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = 'dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_coord0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' + + ! namout + CHARACTER(LEN=lc) :: cn_fileout = 'addline_deg.nc' + LOGICAL :: ln_extrap = .FALSE. + LOGICAL :: ln_copy = .FALSE. + INTEGER(i4) :: in_nproc = 0 + INTEGER(i4) :: in_niproc = 0 + INTEGER(i4) :: in_njproc = 0 + CHARACTER(LEN=lc) :: cn_type = 'cdf' + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_coord0, & !< coordinate file + & in_perio0 !< periodicity index + + NAMELIST /namvar/ & !< variable namelist + & cn_varinfo, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' ) + & cn_varfile !< list of variable file + + NAMELIST /namout/ & !< output namlist + & cn_fileout, & !< fine grid bathymetry file + & ln_extrap, & + & ln_copy, & + & in_niproc, & !< i-direction number of processor + & in_njproc, & !< j-direction numebr of processor + & in_nproc, & !< number of processor to be used + & cn_type !< output type format (dimg, cdf) + !------------------------------------------------------------------- + + ! namelist + ! get namelist + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + IF( il_narg/=1 )THEN + PRINT *,"ERROR in addline: need a namelist" + STOP + ELSE + CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec + ENDIF + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + PRINT *,"ERROR in addline: error opening "//TRIM(cl_namelist) + STOP + ENDIF + + READ( il_fileid, NML = namlog ) + ! define log file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namvar ) + ! add user change in extra information + CALL var_chg_extra( cn_varinfo ) + ! match variable with file + tl_multi=multi_init(cn_varfile) + + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("ADD LINE: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + PRINT *,"ERROR in addline: can't find "//TRIM(cl_namelist) + STOP + + ENDIF + + CALL multi_print(tl_multi) + + ! open files + IF( cn_coord0 /= '' )THEN + tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0) + CALL grid_get_info(tl_coord0) + ELSE + CALL logger_fatal("ADD LINE: no coarse grid coordinate found. "//& + & "check namelist") + ENDIF + + ! check + ! check output file do not already exist + print *,'cn_fileout ',TRIM(cn_fileout) + INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("ADD LINE: output file "//TRIM(cn_fileout)//& + & " already exist.") + ENDIF + + IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN + CALL logger_error("ADD LINE: no mpp file to work on. "//& + & "check cn_varfile in namelist.") + ELSE + + ALLOCATE( tl_var( tl_multi%i_nvar ) ) + jk=0 + DO ji=1,tl_multi%i_nmpp + + IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN + + CALL logger_fatal("ADD LINE: no variable to work on for "//& + & "mpp file"//TRIM(tl_multi%t_mpp(ji)%c_name)//& + & ". check cn_varfile in namelist.") + ELSE + + WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name) + tl_mpp=mpp_init( file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name)) ) + CALL grid_get_info(tl_mpp) + + ! open mpp file + CALL iom_mpp_open(tl_mpp) + + ! get or check depth value + IF( tl_multi%t_mpp(ji)%t_proc(1)%i_depthid /= 0 )THEN + il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_depthid + IF( ASSOCIATED(tl_depth%d_value) )THEN + tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) + IF( ANY( tl_depth%d_value(:,:,:,:) /= & + & tl_tmp%d_value(:,:,:,:) ) )THEN + CALL logger_fatal("ADD LINE: depth value from "//& + & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& + & " to those from former file(s).") + ENDIF + CALL var_clean(tl_tmp) + ELSE + tl_depth=iom_mpp_read_var(tl_mpp,il_varid) + ENDIF + ENDIF + + ! get or check time value + IF( tl_multi%t_mpp(ji)%t_proc(1)%i_timeid /= 0 )THEN + il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_timeid + IF( ASSOCIATED(tl_time%d_value) )THEN + tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) + IF( ANY( tl_time%d_value(:,:,:,:) /= & + & tl_tmp%d_value(:,:,:,:) ) )THEN + CALL logger_fatal("ADD LINE: time value from "//& + & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& + & " to those from former file(s).") + ENDIF + CALL var_clean(tl_tmp) + ELSE + tl_time=iom_mpp_read_var(tl_mpp,il_varid) + ENDIF + ENDIF + + ! close mpp file + CALL iom_mpp_close(tl_mpp) + + !- add line to input file variable + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + jk=jk+1 + tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + WRITE(*,'(2x,a)') "work on variable "//TRIM(tl_tmp%c_name) + + tl_var(jk)=add_line( tl_tmp, tl_mpp, & + & tl_coord0 ) + + IF( ln_copy )THEN + tl_var(jk)%d_value(:,2,:,:)=tl_var(jk)%d_value(:,3,:,:) + ELSEIF( ln_extrap )THEN + ! extrapolate variable + CALL extrap_fill_value( tl_var(jk) ) + ENDIF + ! clean + CALL var_clean(tl_tmp) + + ENDDO + + ENDIF + + ENDDO + + ENDIF + + il_nvar=tl_multi%i_nvar + ! clean + CALL multi_clean(tl_multi) + + ! create file + IF( in_niproc == 0 .AND. & + & in_njproc == 0 .AND. & + & in_nproc == 0 )THEN + in_niproc = 1 + in_njproc = 1 + in_nproc = 1 + ENDIF + + ! add dimension + tl_dim(:)=var_max_dim(tl_var(:)) + + DO ji=1,il_nvar + + IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN + tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type) + EXIT + ENDIF + + ENDDO + + DO ji=1,ip_maxdim + + IF( tl_dim(ji)%l_use )THEN + CALL mpp_move_dim(tl_mppout, tl_dim(ji)) + SELECT CASE(TRIM(tl_dim(ji)%c_sname)) + CASE('z','t') + DO jj=1,tl_mppout%i_nproc + CALL file_add_dim(tl_mppout%t_proc(jj), tl_dim(ji)) + ENDDO + END SELECT + ENDIF + + ENDDO + + ! add variables + IF( ALL( tl_dim(1:2)%l_use ) )THEN + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! add longitude + tl_lon=iom_mpp_read_var(tl_coord0,'longitude') + CALL mpp_add_var(tl_mppout, tl_lon) + CALL var_clean(tl_lon) + + ! add latitude + tl_lat=iom_mpp_read_var(tl_coord0,'latitude') + CALL mpp_add_var(tl_mppout, tl_lat) + CALL var_clean(tl_lat) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + ENDIF + + IF( tl_dim(3)%l_use )THEN + IF( ASSOCIATED(tl_depth%d_value) )THEN + ! add depth + CALL mpp_add_var(tl_mppout, tl_depth) + ELSE + CALL logger_warn("CREATE RESTART: no value for depth variable.") + ENDIF + ENDIF + IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth) + + IF( tl_dim(4)%l_use )THEN + IF( ASSOCIATED(tl_time%d_value) )THEN + ! add time + CALL mpp_add_var(tl_mppout, tl_time) + ELSE + CALL logger_warn("CREATE RESTART: no value for time variable.") + ENDIF + ENDIF + IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time) + + ! add other variables + DO jvar=il_nvar,1,-1 + ! check if variable already add + il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name) + IF( il_index == 0 )THEN + CALL mpp_add_var(tl_mppout, tl_var(jvar)) + CALL var_clean(tl_var(jvar)) + ENDIF + ENDDO + + ! add some attribute + tl_att=att_init("Created_by","SIREN addline_deg") + CALL mpp_add_att(tl_mppout, tl_att) + + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",cl_date) + CALL mpp_add_att(tl_mppout, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'periodicity') + ENDIF + IF( tl_coord0%i_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',tl_coord0%i_perio) + CALL mpp_add_att(tl_mppout,tl_att) + ENDIF + + il_attid=0 + IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'ew_overlap') + ENDIF + IF( tl_coord0%i_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',tl_coord0%i_ew) + CALL mpp_add_att(tl_mppout,tl_att) + ENDIF + + ! print + CALL mpp_print(tl_mppout) + + ! create file + CALL iom_mpp_create(tl_mppout) + + ! write file + CALL iom_mpp_write_file(tl_mppout) + ! close file + CALL iom_mpp_close(tl_mppout) + + ! clean + CALL att_clean(tl_att) + CALL var_clean(tl_var(:)) + DEALLOCATE(tl_var) + + CALL mpp_clean(tl_mppout) + CALL mpp_clean(tl_coord0) + + ! close log file + CALL logger_footer() + CALL logger_close() + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION add_line(td_var, td_mpp, td_coord) & + & RESULT(tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function add line to variable and return variable structure + !> + !> @author J.Paul + !> @date October, 2015 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] td_mpp mpp file structure + !> @param[in] td_coord coordinate file structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TMPP), INTENT(IN) :: td_coord + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(2,2) :: il_ghost + + TYPE(TMPP) :: tl_mpp + + TYPE(TATT) :: tl_att + + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + ! loop indices + !---------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + CALL logger_error("ADD LINE: no processor associated "//& + & "to mpp "//TRIM(td_mpp%c_name)) + ELSE + + !init + tl_mpp=mpp_copy(td_mpp) + il_ghost(:,:)=0 + + tl_dim(:)=dim_copy(td_coord%t_dim(:)) + + ! ghost cell to be added + il_ghost(jp_I,:)=(/0,0/) + il_ghost(jp_J,:)=(/1,0/) + + ! open mpp files + CALL iom_mpp_open(tl_mpp) + + ! read variable + tf_var=iom_mpp_read_var(tl_mpp,TRIM(td_var%c_name)) + + ! close mpp file + CALL iom_mpp_close(tl_mpp) + + ! add ghost cell + CALL grid_add_ghost(tf_var,il_ghost(:,:)) + + ! add attribute to variable + tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('add_i_line',(/il_ghost(jp_I,1), il_ghost(jp_I,2)/)) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('add_j_line',(/il_ghost(jp_J,1), il_ghost(jp_J,2)/)) + CALL var_move_att(tf_var, tl_att) + + ! clean structure + CALL att_clean(tl_att) + CALL mpp_clean(tl_mpp) + ENDIF + + END FUNCTION add_line + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM diff --git a/V4.0/nemo_sources/tools/SIREN/src/attribute.f90 b/V4.0/nemo_sources/tools/SIREN/src/attribute.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0a7306d1007c95de2b6f4d64ab5136f7533dceda --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/attribute.f90 @@ -0,0 +1,1516 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage attribute of variable or file. +!> +!> @details +!> define type TATT:<br/> +!> @code +!> TYPE(TATT) :: tl_att +!> @endcode +!> +!> the attribute value inside attribute structure will be +!> character or real(8) 1D array.<br/> +!> However the attribute value could be initialized with:<br/> +!> - character +!> - scalar (real(4), real(8), integer(4) or integer(8)) +!> - array 1D (real(4), real(8), integer(4) or integer(8)) +!> +!> to initialize an attribute structure :<br/> +!> @code +!> tl_att=att_init('attname',value) +!> @endcode +!> - value is a character, scalar value or table of value +!> +!> to print attribute information of one or array of attribute structure:<br/> +!> @code +!> CALL att_print(td_att) +!> @endcode +!> +!> to clean attribute structure:<br/> +!> @code +!> CALL att_clean(td_att) +!> @endcode +!> +!> to copy attribute structure in another one (using different memory cell):<br/> +!> @code +!> tl_att2=att_copy(tl_att1) +!> @endcode +!> @note as we use pointer for the value array of the attribute structure, +!> the use of the assignment operator (=) to copy attribute structure +!> create a pointer on the same array. +!> This is not the case with this copy function. +!> +!> to get attribute index, in an array of attribute structure:<br/> +!> @code +!> il_index=att_get_index( td_att, cd_name ) +!> @endcode +!> - td_att array of attribute structure +!> - cd_name attribute name +!> +!> to get attribute id, read from a file:<br/> +!>@code +!> il_id=att_get_id( td_att, cd_name ) +!>@endcode +!> - td_att array of attribute structure +!> - cd_name attribute name +!> +!> to get attribute name +!> - tl_att\%c_name +!> +!> to get character length or the number of value store in attribute +!> - tl_att\%i_len +!> +!> to get attribute value:<br/> +!> - tl_att\%c_value (for character attribute) +!> - tl_att\%d_value(i) (otherwise) +!> +!> to get the type number (based on NETCDF type constants) of the +!> attribute:<br/> +!> - tl_att\%i_type +!> +!> to get attribute id (read from file):<br/> +!> - tl_att\%i_id +!> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date November, 2014 +!> - Fix memory leaks bug +!> @date September, 2015 +!> - manage useless (dummy) attributes +!> @date May, 2019 +!> - read number of element for each dummy array in configuration file +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE att + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + + IMPLICIT NONE + + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TATT !< attribute structure + + PRIVATE :: im_ndumatt !< number of elt in dummy attribute array + PRIVATE :: cm_dumatt !< dummy attribute array + + ! function and subroutine + PUBLIC :: att_init !< initialize attribute structure + PUBLIC :: att_print !< print attribute structure + PUBLIC :: att_clean !< clean attribute strcuture + PUBLIC :: att_copy !< copy attribute structure + PUBLIC :: att_get_index !< get attribute index, in an array of attribute structure + PUBLIC :: att_get_id !< get attribute id, read from file + PUBLIC :: att_get_dummy !< fill dummy attribute array + PUBLIC :: att_is_dummy !< check if attribute is defined as dummy attribute + + PRIVATE :: att__clean_unit ! clean attribute strcuture + PRIVATE :: att__clean_arr ! clean array of attribute strcuture + PRIVATE :: att__print_unit ! print information on one attribute + PRIVATE :: att__print_arr ! print information on a array of attribute + PRIVATE :: att__init_c ! initialize an attribute structure with character value + PRIVATE :: att__init_dp ! initialize an attribute structure with array of real(8) value + PRIVATE :: att__init_dp_0d ! initialize an attribute structure with real(8) value + PRIVATE :: att__init_sp ! initialize an attribute structure with array of real(4) value + PRIVATE :: att__init_sp_0d ! initialize an attribute structure with real(4) value + PRIVATE :: att__init_i1 ! initialize an attribute structure with array of integer(1) value + PRIVATE :: att__init_i1_0d ! initialize an attribute structure with integer(1) value + PRIVATE :: att__init_i2 ! initialize an attribute structure with array of integer(2) value + PRIVATE :: att__init_i2_0d ! initialize an attribute structure with integer(2) value + PRIVATE :: att__init_i4 ! initialize an attribute structure with array of integer(4) value + PRIVATE :: att__init_i4_0d ! initialize an attribute structure with integer(4) value + PRIVATE :: att__init_i8 ! initialize an attribute structure with array of integer(8) value + PRIVATE :: att__init_i8_0d ! initialize an attribute structure with integer(8) value + PRIVATE :: att__copy_unit ! copy attribute structure + PRIVATE :: att__copy_arr ! copy array of attribute structure + + TYPE TATT !< attribute structure + CHARACTER(LEN=lc) :: c_name = '' !< attribute name + INTEGER(i4) :: i_id = 0 !< attribute id + INTEGER(i4) :: i_type = 0 !< attribute type + INTEGER(i4) :: i_len = 0 !< number of value store in attribute + CHARACTER(LEN=lc) :: c_value = 'none' !< attribute value if type CHAR + REAL(dp), DIMENSION(:), POINTER :: d_value => NULL() !< attribute value if type SHORT,INT,FLOAT or DOUBLE + END TYPE TATT + + INTEGER(i4) , SAVE :: im_ndumatt !< number of elt in dummy attribute array + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg), SAVE :: cm_dumatt !< dummy attribute + + INTERFACE att_init + MODULE PROCEDURE att__init_c + MODULE PROCEDURE att__init_dp + MODULE PROCEDURE att__init_dp_0d + MODULE PROCEDURE att__init_sp + MODULE PROCEDURE att__init_sp_0d + MODULE PROCEDURE att__init_i1 + MODULE PROCEDURE att__init_i1_0d + MODULE PROCEDURE att__init_i2 + MODULE PROCEDURE att__init_i2_0d + MODULE PROCEDURE att__init_i4 + MODULE PROCEDURE att__init_i4_0d + MODULE PROCEDURE att__init_i8 + MODULE PROCEDURE att__init_i8_0d + END INTERFACE att_init + + INTERFACE att_print + MODULE PROCEDURE att__print_unit ! print information on one attribute + MODULE PROCEDURE att__print_arr ! print information on a array of attribute + END INTERFACE att_print + + INTERFACE att_clean + MODULE PROCEDURE att__clean_unit + MODULE PROCEDURE att__clean_arr + END INTERFACE + + INTERFACE att_copy + MODULE PROCEDURE att__copy_unit ! copy attribute structure + MODULE PROCEDURE att__copy_arr ! copy array of attribute structure + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__copy_arr(td_att) & + & RESULT(tf_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy a array of attribute structure in another one + !> @details + !> see att__copy_unit + !> + !> @warning do not use on the output of a function who create or read an + !> attribute (ex: tl_att=att_copy(att_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + ! + !> @param[in] td_att array of attribute structure + !> @return copy of input array of attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), DIMENSION(:) , INTENT(IN) :: td_att + ! function + TYPE(TATT), DIMENSION(SIZE(td_att(:))) :: tf_att + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_att(:)) + tf_att(ji)=att_copy(td_att(ji)) + ENDDO + + END FUNCTION att__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__copy_unit(td_att) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy an attribute structure in another one. + !> @details + !> attribute value are copied in a temporary array, so input and output + !> attribute structure value do not point on the same "memory cell", and so + !> on are independant. + !> + !> @warning do not use on the output of a function who create or read an + !> attribute (ex: tl_att=att_copy(att_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator (to avoid memory leak) + !> + !> @param[in] td_att attribute structure + !> @return copy of input attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), INTENT(IN) :: td_att + + ! function + TYPE(TATT) :: tf_att + + ! local variable + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value + !---------------------------------------------------------------- + + ! copy attribute variable + tf_att%c_name = TRIM(td_att%c_name) + tf_att%i_id = td_att%i_id + tf_att%i_type = td_att%i_type + tf_att%i_len = td_att%i_len + tf_att%c_value = TRIM(td_att%c_value) + + ! copy attribute pointer in an independant variable + IF( ASSOCIATED(tf_att%d_value) ) DEALLOCATE(tf_att%d_value) + IF( ASSOCIATED(td_att%d_value) )THEN + ALLOCATE( dl_value(td_att%i_len) ) + dl_value(:) = td_att%d_value(:) + + ALLOCATE( tf_att%d_value(tf_att%i_len) ) + tf_att%d_value(:) = dl_value(:) + + DEALLOCATE( dl_value ) + ENDIF + + END FUNCTION att__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att_get_index(td_att, cd_name) & + & RESULT(if_idx) + !------------------------------------------------------------------- + !> @brief This function return attribute index, in a array of attribute structure, + !> given attribute name.<br/> + !> @details + !> if attribute name do not exist, return 0. + !> + !> @author J.Paul + !> @date Septempber, 2014 - Initial Version + ! + !> @param[in] td_att array of attribute structure + !> @param[in] cd_name attribute name + !> @return attribute index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + INTEGER(i4) :: if_idx + + ! local variable + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + if_idx=0 + + il_size=SIZE(td_att(:)) + DO ji=1,il_size + IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN + if_idx=ji + EXIT + ENDIF + ENDDO + + END FUNCTION att_get_index + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att_get_id(td_att, cd_name) & + & RESULT (if_id) + !------------------------------------------------------------------- + !> @brief This function return attribute id, read from a file.<br/> + !> @details + !> if attribute name do not exist, return 0. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - bug fix with use of id read from attribute structure + !> + !> @param[in] td_att array of attribute structure + !> @param[in] cd_name attribute name + !> @return attribute id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + INTEGER(i4) :: if_id + + ! local variable + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + if_id=0 + + il_size=SIZE(td_att(:)) + DO ji=1,il_size + IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN + if_id=td_att(ji)%i_id + EXIT + ENDIF + ENDDO + + END FUNCTION att_get_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_c(cd_name, cd_value) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with character + !> value. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] cd_value attribute value + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), INTENT(IN) :: cd_value + + ! function + TYPE(TATT) :: tf_att + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cd_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + tf_att%i_type=NF90_CHAR + + tf_att%c_value=TRIM(ADJUSTL(cd_value)) + tf_att%i_len=LEN( TRIM(ADJUSTL(cd_value)) ) + + END FUNCTION att__init_c + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_dp(cd_name, dd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of real(8) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] dd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(dd_value(:)) + + cl_value="(/" + DO ji=1,il_len-1 + cl_value=TRIM(cl_value)//TRIM(fct_str(dd_value(ji)))//"," + ENDDO + cl_value=TRIM(cl_value)//TRIM(fct_str(dd_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_DOUBLE + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=dd_value(:) + tf_att%i_len=il_len + + END FUNCTION att__init_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_dp_0d(cd_name, dd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> real(8) value + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] dd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp), INTENT(IN) :: dd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(dd_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_DOUBLE + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=dd_value + tf_att%i_len=1 + + END FUNCTION att__init_dp_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_sp(cd_name, rd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of real(4) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] rd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp), DIMENSION(:), INTENT(IN) :: rd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(rd_value(:)) + + cl_value="(/" + DO ji=1,il_len-1 + cl_value=TRIM(cl_value)//TRIM(fct_str(rd_value(ji)))//"," + ENDDO + CALL logger_trace( & + & " ATT INIT: attribute name: il_len "//fct_str(il_len)& + ) + cl_value=TRIM(cl_value)//TRIM(fct_str(rd_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_FLOAT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=REAL(rd_value(:),dp) + tf_att%i_len=il_len + + END FUNCTION att__init_sp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_sp_0d(cd_name, rd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> real(4) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] rd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp), INTENT(IN) :: rd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(rd_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_FLOAT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=REAL(rd_value,dp) + tf_att%i_len=1 + + END FUNCTION att__init_sp_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i1(cd_name, bd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of integer(1) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] bd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1), DIMENSION(:), INTENT(IN) :: bd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(bd_value(:)) + + cl_value="(/" + DO ji=1,il_len-1 + cl_value=TRIM(cl_value)//TRIM(fct_str(bd_value(ji)))//"," + ENDDO + cl_value=TRIM(cl_value)//TRIM(fct_str(bd_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_BYTE + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=REAL(bd_value(:),dp) + tf_att%i_len=il_len + + END FUNCTION att__init_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i1_0d(cd_name, bd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> integer(1) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] bd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1), INTENT(IN) :: bd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + !local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(bd_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attibute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_BYTE + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=REAL(bd_value,dp) + tf_att%i_len=1 + + END FUNCTION att__init_i1_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i2(cd_name, sd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of integer(2) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] sd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2), DIMENSION(:), INTENT(IN) :: sd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(sd_value(:)) + + cl_value="(/" + DO ji=1,il_len-1 + cl_value=TRIM(cl_value)//TRIM(fct_str(sd_value(ji)))//"," + ENDDO + cl_value=TRIM(cl_value)//TRIM(fct_str(sd_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_SHORT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=REAL(sd_value(:),dp) + tf_att%i_len=il_len + + END FUNCTION att__init_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i2_0d(cd_name, sd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> integer(2) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] sd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2), INTENT(IN) :: sd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + !local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(sd_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attibute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_SHORT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=REAL(sd_value,dp) + tf_att%i_len=1 + + END FUNCTION att__init_i2_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i4(cd_name, id_value, id_type) & + & RESULT(tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of integer(4) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] id_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(id_value(:)) + + cl_value="(/" + DO ji=1,il_len-1 + cl_value=TRIM(cl_value)//TRIM(fct_str(id_value(ji)))//"," + ENDDO + cl_value=TRIM(cl_value)//TRIM(fct_str(id_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attribute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_INT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=REAL(id_value(:),dp) + tf_att%i_len=il_len + + END FUNCTION att__init_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i4_0d(cd_name, id_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> integer(4) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_name attribute name + !> @param[in] id_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), INTENT(IN) :: id_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + !local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(id_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attibute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_INT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=REAL(id_value,dp) + tf_att%i_len=1 + + END FUNCTION att__init_i4_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i8(cd_name, kd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with array + !> of integer(8) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] kd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8), DIMENSION(:), INTENT(IN) :: kd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + ! array size + il_len=size(kd_value(:)) + + cl_value="(/" + DO ji=1,il_len + cl_value=TRIM(cl_value)//TRIM(fct_str(kd_value(ji)))//"," + ENDDO + cl_value=TRIM(cl_value)//TRIM(fct_str(kd_value(il_len)))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attibute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_INT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(il_len)) + + tf_att%d_value(:)=REAL(kd_value(:),dp) + tf_att%i_len=il_len + + END FUNCTION att__init_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att__init_i8_0d(cd_name, kd_value, id_type) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function initialize an attribute structure with + !> integer(8) value. + !> @details + !> Optionaly you could specify the type of the variable to be saved. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_name attribute name + !> @param[in] kd_value attribute value + !> @param[in] id_type type of the variable to be saved + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8), INTENT(IN) :: kd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + + ! function + TYPE(TATT) :: tf_att + + ! local value + CHARACTER(LEN=lc) :: cl_value + !---------------------------------------------------------------- + + ! clean attribute + CALL att_clean(tf_att) + + cl_value="(/"//TRIM(fct_str(kd_value))//"/)" + + CALL logger_trace( & + & " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//& + & " attibute value "//TRIM(ADJUSTL(cl_value)) ) + + tf_att%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_type) )THEN + tf_att%i_type=id_type + ELSE + tf_att%i_type=NF90_INT + ENDIF + + IF( ASSOCIATED(tf_att%d_value) )THEN + DEALLOCATE(tf_att%d_value) + ENDIF + ALLOCATE(tf_att%d_value(1)) + + tf_att%d_value(1)=REAL(kd_value,dp) + tf_att%i_len=1 + + END FUNCTION att__init_i8_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE att__print_arr(td_att) + !------------------------------------------------------------------- + !> @brief This subroutine print informations of an array of attribute. + !> + !> @author J.Paul + !> @date June, 2014 - Initial Version + !> + !> @param[in] td_att array of attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_att(:)) + CALL att_print(td_att(ji)) + ENDDO + + END SUBROUTINE att__print_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE att__print_unit(td_att) + !------------------------------------------------------------------- + !> @brief This subroutine print attribute information. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - take into account type of attribute. + ! + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), INTENT(IN) :: td_att + + ! local vairbale + CHARACTER(LEN=lc) :: cl_type + CHARACTER(LEN=lc) :: cl_value + + INTEGER(i8) :: kl_tmp + INTEGER(i2) :: sl_tmp + INTEGER(i1) :: bl_tmp + REAL(sp) :: rl_tmp + REAL(dp) :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + SELECT CASE( td_att%i_type ) + + CASE(NF90_CHAR) + cl_type='CHAR' + CASE(NF90_BYTE) + cl_type='BYTE' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE DEFAULT + cl_type='' + + END SELECT + + SELECT CASE( td_att%i_type ) + + CASE(NF90_CHAR) + + cl_value=td_att%c_value + + CASE(NF90_BYTE) + IF( td_att%i_len > 1 )THEN + cl_value='(/' + DO ji=1,td_att%i_len-1 + bl_tmp=INT(td_att%d_value(ji),i1) + cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//',' + ENDDO + bl_tmp=INT(td_att%d_value(td_att%i_len),i1) + cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//'/)' + ELSE + cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)' + ENDIF + + CASE(NF90_SHORT) + IF( td_att%i_len > 1 )THEN + cl_value='(/' + DO ji=1,td_att%i_len-1 + sl_tmp=INT(td_att%d_value(ji),i2) + cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//',' + ENDDO + sl_tmp=INT(td_att%d_value(td_att%i_len),i2) + cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//'/)' + ELSE + cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)' + ENDIF + + CASE(NF90_INT) + IF( td_att%i_len > 1 )THEN + cl_value='(/' + DO ji=1,td_att%i_len-1 + kl_tmp=INT(td_att%d_value(ji),i8) + cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//',' + ENDDO + kl_tmp=INT(td_att%d_value(td_att%i_len),i8) + cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//'/)' + ELSE + cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)' + ENDIF + + CASE(NF90_FLOAT) + IF( td_att%i_len > 1 )THEN + cl_value='(/' + DO ji=1,td_att%i_len-1 + rl_tmp=REAL(td_att%d_value(ji),sp) + cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//',' + ENDDO + rl_tmp=REAL(td_att%d_value(td_att%i_len),sp) + cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//'/)' + ELSE + cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)' + ENDIF + + CASE(NF90_DOUBLE) + IF( td_att%i_len > 1 )THEN + cl_value='(/' + DO ji=1,td_att%i_len-1 + dl_tmp=REAL(td_att%d_value(ji),dp) + cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//',' + ENDDO + dl_tmp=REAL(td_att%d_value(td_att%i_len),dp) + cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//'/)' + ELSE + cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)' + ENDIF + + CASE DEFAULT + cl_value="none" + + END SELECT + + WRITE(*,'((3x,a,a),(/6x,a,i2.2),(a,a),(a,a))')& + & " attribute : ",TRIM(ADJUSTL(td_att%c_name)), & + & " id : ",td_att%i_id, & + & " type : ",TRIM(ADJUSTL(cl_type)), & + & " value : ",TRIM(ADJUSTL(cl_value)) + + END SUBROUTINE att__print_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE att__clean_unit(td_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean attribute strcuture. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - nullify array inside attribute structure + !> + !> @param[inout] td_att attribute strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), INTENT(INOUT) :: td_att + + ! local variable + TYPE(TATT) :: tl_att ! empty attribute structure + !---------------------------------------------------------------- + + CALL logger_trace( & + & " CLEAN: reset attribute "//TRIM(td_att%c_name) ) + + IF( ASSOCIATED(td_att%d_value) )THEN + ! clean value + DEALLOCATE(td_att%d_value) + NULLIFY(td_att%d_value) + ENDIF + + ! replace by empty structure + td_att=att_copy(tl_att) + + END SUBROUTINE att__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE att__clean_arr(td_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean array of attribute strcuture. + ! + !> @author J.Paul + !> @date September, 2014 - Initial Version + ! + !> @param[inout] td_att attribute strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), DIMENSION(:), INTENT(INOUT) :: td_att + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_att(:)),1,-1 + CALL att_clean(td_att(ji) ) + ENDDO + + END SUBROUTINE att__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE att_get_dummy(cd_dummy) + !------------------------------------------------------------------- + !> @brief This subroutine fill dummy attribute array + ! + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date Marsh, 2016 + !> - close file (bugfix) + !> @date May, 2019 + !> - read number of dummy element + !> + !> @param[in] cd_dummy dummy configuration file + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_dummy + + ! local variable + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_status + + LOGICAL :: ll_exist + + ! namelist + INTEGER(i4) :: in_ndumvar + INTEGER(i4) :: in_ndumdim + INTEGER(i4) :: in_ndumatt + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumvar + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumdim + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumatt + !---------------------------------------------------------------- + NAMELIST /namdum/ & !< dummy namelist + & in_ndumvar,& !< number of dummy elt in variable array + & in_ndumdim,& !< number of dummy elt in dimension array + & in_ndumatt,& !< number of dummy elt in attribute array + & cn_dumvar, & !< variable name + & cn_dumdim, & !< dimension name + & cn_dumatt !< attribute name + !---------------------------------------------------------------- + + ! init + cm_dumatt(:)='' + + ! read namelist + INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_dummy), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) + ENDIF + + READ( il_fileid, NML = namdum ) + im_ndumatt = in_ndumatt + cm_dumatt(:)= cn_dumatt(:) + + CLOSE( il_fileid ) + + IF( im_ndumatt > ip_maxdumcfg )THEN + CALL logger_fatal("ATT GET dUMMY : too much dummy attributes & + & ( >"//fct_str(ip_maxdumcfg)//" ). & + & set ip_maxdumcfg to higher value.") + ENDIF + + ENDIF + + END SUBROUTINE att_get_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION att_is_dummy(td_att) & + & RESULT (lf_dummy) + !------------------------------------------------------------------- + !> @brief This function check if attribute is defined as dummy attribute + !> in configuraton file + !> + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date, May, 2019 + !> - use number of dummy elt in do-loop + !> + !> @param[in] td_att attribute structure + !> @return true if attribute is dummy attribute + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TATT), INTENT(IN) :: td_att + + ! function + LOGICAL :: lf_dummy + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + CALL logger_trace("ATT IS DUMMY : check if attribute is useless") + + lf_dummy=.FALSE. + DO ji=1,im_ndumatt + IF( fct_lower(td_att%c_name) == fct_lower(cm_dumatt(ji)) )THEN + lf_dummy=.TRUE. + EXIT + ENDIF + ENDDO + + CALL logger_trace("ATT IS DUMMY : check ok") + + END FUNCTION att_is_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE att + diff --git a/V4.0/nemo_sources/tools/SIREN/src/boundary.f90 b/V4.0/nemo_sources/tools/SIREN/src/boundary.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6863bd2dfb5e6f1bd901e3cdf9a4ecf1aae9e4f5 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/boundary.f90 @@ -0,0 +1,1949 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage boundary. +!> +!> @details +!> define type TBDY:<br/> +!> @code +!> TYPE(TBDY) :: tl_bdy<br/> +!> @endcode +!> +!> to initialise boundary structure:<br/> +!> @code +!> tl_bdy=boundary_init(td_var, [ld_north,] [ld_south,] [ld_east,] [ld_west,] +!> [cd_north,] [cd_south,] [cd_east,] [cd_west,] [ld_oneseg]) +!> @endcode +!> - td_var is variable structure +!> - ld_north is logical to force used of north boundary [optional] +!> - ld_south is logical to force used of north boundary [optional] +!> - ld_east is logical to force used of north boundary [optional] +!> - ld_west is logical to force used of north boundary [optional] +!> - cd_north is string character description of north boundary [optional] +!> - cd_south is string character description of south boundary [optional] +!> - cd_east is string character description of east boundary [optional] +!> - cd_west is string character description of west boundary [optional] +!> - ld_oneseg is logical to force to use only one segment for each boundary [optional] +!> +!> to get boundary cardinal:<br/> +!> - tl_bdy\%c_card +!> +!> to know if boundary is use:<br/> +!> - tl_bdy\%l_use +!> +!> to know if boundary come from namelist (cn_north,..):<br/> +!> - tl_bdy\%l_nam +!> +!> to get the number of segment in boundary:<br/> +!> - tl_bdy\%i_nseg +!> +!> to get array of segment in boundary:<br/> +!> - tl_bdy\%t_seg(:) +!> +!> to get orthogonal segment index of north boundary:<br/> +!> - tl_bdy\%t_seg(jp_north)%\i_index +!> +!> to get segment width of south boundary:<br/> +!> - tl_bdy\%t_seg(jp_south)%\i_width +!> +!> to get segment first indice of east boundary:<br/> +!> - tl_bdy\%t_seg(jp_east)%\i_first +!> +!> to get segment last indice of west boundary:<br/> +!> - tl_bdy\%t_seg(jp_west)%\i_last +!> +!> to print information about boundary:<br/> +!> @code +!> CALL boundary_print(td_bdy) +!> @endcode +!> - td_bdy is boundary structure or a array of boundary structure +!> +!> to clean boundary structure:<br/> +!> @code +!> CALL boundary_clean(td_bdy) +!> @endcode +!> +!> to get indices of each semgent for each boundary:<br/> +!> @code +!> CALL boundary_get_indices( td_bdy, td_var, ld_oneseg) +!> @endcode +!> - td_bdy is boundary structure +!> - td_var is variable structure +!> - ld_oneseg is logical to force to use only one segment for each boundary [optional] +!> +!> to check boundary indices and corner:<br/> +!> @code +!> CALL boundary_check(td_bdy, td_var) +!> @endcode +!> - td_bdy is boundary structure +!> - td_var is variable structure +!> +!> to check boundary corner:<br/> +!> @code +!> CALL boundary_check_corner(td_bdy, td_var) +!> @endcode +!> - td_bdy is boundary structure +!> - td_var is variable structure +!> +!> to create filename with cardinal name inside:<br/> +!> @code +!> cl_filename=boundary_set_filename(cd_file, cd_card) +!> @endcode +!> - cd_file = original file name +!> - cd_card = cardinal name +!> +!> to swap array for east and north boundary:<br/> +!> @code +!> CALL boundary_swap( td_var, td_bdy ) +!> @endcode +!> - td_var is variable strucutre +!> - td_bdy is boundary strucutre +!> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add boundary description +!> @date November, 2014 +!> - Fix memory leaks bug +!> @date February, 2015 +!> - Do not change indices read from namelist +!> - Change string character format of boundary read from namelist, +!> see boundary__get_info +!> +!> @todo add schematic to boundary structure description +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE boundary + + USE netcdf ! nf90 library + USE global ! global parameter + USE phycst ! physical constant + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE var ! variable manager + + IMPLICIT NONE + + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TBDY !< boundary structure + PUBLIC :: TSEG !< segment structure + + PRIVATE :: im_width !< boundary width + + ! function and subroutine + PUBLIC :: boundary_copy !< copy boundary structure + PUBLIC :: boundary_init !< initialise boundary structure + PUBLIC :: boundary_print !< print information about boundary + PUBLIC :: boundary_clean !< clean boundary structure + PUBLIC :: boundary_get_indices !< get indices of each semgent for each boundary. + PUBLIC :: boundary_check !< check boundary indices and corner. + PUBLIC :: boundary_check_corner !< check boundary corner + PUBLIC :: boundary_set_filename !< set boundary filename + PUBLIC :: boundary_swap !< swap array for north and east boundary + + PRIVATE :: boundary__clean_unit ! clean boundary structure + PRIVATE :: boundary__clean_arr ! clean array of boundary structure + PRIVATE :: boundary__init_wrapper ! initialise a boundary structure + PRIVATE :: boundary__init ! initialise basically a boundary structure + PRIVATE :: boundary__copy_unit ! copy boundary structure in another + PRIVATE :: boundary__copy_arr ! copy boundary structure in another + PRIVATE :: boundary__add_seg ! add one segment structure to a boundary + PRIVATE :: boundary__del_seg ! remove all segments of a boundary + PRIVATE :: boundary__get_info ! get boundary information from boundary description string character. + PRIVATE :: boundary__get_seg_number ! compute the number of sea segment for one boundary + PRIVATE :: boundary__get_seg_indices ! get segment indices for one boundary + PRIVATE :: boundary__print_unit ! print information about one boundary + PRIVATE :: boundary__print_arr ! print information about a array of boundary + + PRIVATE :: seg__init ! initialise segment structure + PRIVATE :: seg__clean ! clean segment structure + PRIVATE :: seg__clean_unit ! clean one segment structure + PRIVATE :: seg__clean_arr ! clean array of segment structure + PRIVATE :: seg__copy ! copy segment structure in another + PRIVATE :: seg__copy_unit ! copy segment structure in another + PRIVATE :: seg__copy_arr ! copy array of segment structure in another + + TYPE TSEG !< segment structure + INTEGER(i4) :: i_index = 0 !< segment index + INTEGER(i4) :: i_width = 0 !< segment width + INTEGER(i4) :: i_first = 0 !< segment first indice + INTEGER(i4) :: i_last = 0 !< segment last indices + END TYPE TSEG + + TYPE TBDY !< boundary structure + CHARACTER(LEN=lc) :: c_card = '' !< boundary cardinal + LOGICAL :: l_use = .FALSE. !< boundary use or not + LOGICAL :: l_nam = .FALSE. !< boundary get from namelist + INTEGER(i4) :: i_nseg = 0 !< number of segment in boundary + TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() !< array of segment structure + END TYPE TBDY + + ! module variable + INTEGER(i4), PARAMETER :: im_width=10 + + INTERFACE boundary_init + MODULE PROCEDURE boundary__init_wrapper + END INTERFACE boundary_init + + INTERFACE boundary_print + MODULE PROCEDURE boundary__print_unit + MODULE PROCEDURE boundary__print_arr + END INTERFACE boundary_print + + INTERFACE boundary_clean + MODULE PROCEDURE boundary__clean_unit + MODULE PROCEDURE boundary__clean_arr + END INTERFACE + + INTERFACE seg__clean + MODULE PROCEDURE seg__clean_unit + MODULE PROCEDURE seg__clean_arr + END INTERFACE + + INTERFACE boundary_copy + MODULE PROCEDURE boundary__copy_unit + MODULE PROCEDURE boundary__copy_arr + END INTERFACE + + INTERFACE seg__copy + MODULE PROCEDURE seg__copy_unit ! copy segment structure + MODULE PROCEDURE seg__copy_arr ! copy array of segment structure + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary__copy_arr(td_bdy) & + & RESULT (tf_bdy) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy a array of boundary structure in another one + !> @details + !> + !> @warning do not use on the output of a function who create or read an + !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + ! + !> @param[in] td_bdy array of boundary structure + !> @return copy of input array of boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), DIMENSION(:) , INTENT(IN) :: td_bdy + + ! function + TYPE(TBDY), DIMENSION(SIZE(td_bdy(:))) :: tf_bdy + + ! local variable + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + DO jk=1,SIZE(td_bdy(:)) + tf_bdy(jk)=boundary_copy(td_bdy(jk)) + ENDDO + + END FUNCTION boundary__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary__copy_unit(td_bdy) & + & RESULT (tf_bdy) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy boundary structure in another one + !> @details + !> + !> @warning do not use on the output of a function who create or read an + !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + ! + !> @param[in] td_bdy boundary structure + !> @return copy of input boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), INTENT(IN) :: td_bdy + + ! function + TYPE(TBDY) :: tf_bdy + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! copy variable name, id, .. + tf_bdy%c_card = TRIM(td_bdy%c_card) + tf_bdy%i_nseg = td_bdy%i_nseg + tf_bdy%l_use = td_bdy%l_use + + ! copy segment + IF( ASSOCIATED(tf_bdy%t_seg) )THEN + CALL seg__clean(tf_bdy%t_seg(:)) + DEALLOCATE(tf_bdy%t_seg) + ENDIF + IF( ASSOCIATED(td_bdy%t_seg) .AND. tf_bdy%i_nseg > 0 )THEN + ALLOCATE( tf_bdy%t_seg(tf_bdy%i_nseg) ) + DO ji=1,tf_bdy%i_nseg + tf_bdy%t_seg(ji)=td_bdy%t_seg(ji) + ENDDO + ENDIF + + END FUNCTION boundary__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__clean_unit(td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine clean boundary structure + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - nullify segment structure inside boundary structure + ! + !> @param[inout] td_bdy boundary strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), INTENT(INOUT) :: td_bdy + + ! local variable + TYPE(TBDY) :: tl_bdy ! empty boundary strucutre + + ! loop indices + !---------------------------------------------------------------- + + CALL logger_info( & + & " CLEAN: reset boundary "//TRIM(td_bdy%c_card) ) + + ! del segment + IF( ASSOCIATED(td_bdy%t_seg) )THEN + ! clean each segment + CALL seg__clean(td_bdy%t_seg(:) ) + DEALLOCATE( td_bdy%t_seg ) + NULLIFY(td_bdy%t_seg) + ENDIF + + ! replace by empty structure + td_bdy=boundary_copy(tl_bdy) + + END SUBROUTINE boundary__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__clean_arr(td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine clean array of boundary structure + ! + !> @author J.Paul + !> @date September, 2014 - Initial Version + ! + !> @param[inout] td_bdy boundary strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), DIMENSION(:), INTENT(INOUT) :: td_bdy + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_bdy(:)),1,-1 + CALL boundary_clean( td_bdy(ji) ) + ENDDO + + END SUBROUTINE boundary__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary_set_filename(cd_file, cd_card, id_seg, cd_date) & + & RESULT (cf_file) + !------------------------------------------------------------------- + !> @brief This function put cardinal name and date inside file name. + ! + !> @details + !> Examples : + !> cd_file="boundary.nc" + !> cd_card="west" + !> id_seg =2 + !> cd_date=y2015m07d16 + !> + !> function return "boundary_west_2_y2015m07d16.nc" + !> + !> cd_file="boundary.nc" + !> cd_card="west" + !> + !> function return "boundary_west.nc" + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_file file name + !> @param[in] cd_card cardinal name + !> @param[in] id_seg segment number + !> @param[in] cd_date file date (format: y????m??d??) + !> @return file name with cardinal name inside + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + CHARACTER(LEN=*), INTENT(IN) :: cd_card + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_seg + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_date + + ! function + CHARACTER(LEN=lc) :: cf_file + + ! local variable + CHARACTER(LEN=lc) :: cl_dirname + CHARACTER(LEN=lc) :: cl_basename + CHARACTER(LEN=lc) :: cl_base + CHARACTER(LEN=lc) :: cl_suffix + CHARACTER(LEN=lc) :: cl_segnum + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_indend + + ! loop indices + !---------------------------------------------------------------- + ! init + cf_file='' + + IF( TRIM(cd_file) /= '' .AND. TRIM(cd_card) /= '' )THEN + + cl_dirname = fct_dirname( TRIM(cd_file)) + IF( TRIM(cl_dirname) == '' ) cl_dirname='.' + + cl_basename= fct_basename(TRIM(cd_file)) + + cl_base =fct_split(TRIM(cl_basename),1,'.') + cl_suffix=fct_split(TRIM(cl_basename),2,'.') + + ! add segment number + IF( PRESENT(id_seg) )THEN + cl_segnum="_"//TRIM(fct_str(id_seg)) + ELSE + cl_segnum="" + ENDIF + + ! add date + IF( PRESENT(cd_date) )THEN + cl_date="_"//TRIM(ADJUSTL(cd_date)) + ELSE + cl_date="" + ENDIF + + ! special case for obcdta + il_ind=INDEX(cl_base,'_obcdta_') + IF( il_ind/=0 )THEN + il_ind=il_ind-1+8 + il_indend=LEN_TRIM(cl_base) + + cl_name=TRIM(cl_base(1:il_ind))//TRIM(cd_card)//& + & TRIM(cl_segnum)//"_"//TRIM(cl_base(il_ind+1:il_indend))//& + & TRIM(cl_date)//"."//TRIM(cl_suffix) + ELSE + cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& + & TRIM(cl_date)//"."//TRIM(cl_suffix) + ENDIF + + cf_file=TRIM(cl_dirname)//"/"//TRIM(cl_name) + ELSE + CALL logger_error("BOUNDARY SET FILENAME: file or cardinal name "//& + & " are empty") + ENDIF + + END FUNCTION boundary_set_filename + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary__init_wrapper(td_var, & + & ld_north, ld_south, ld_east, ld_west, & + & cd_north, cd_south, cd_east, cd_west, & + & ld_oneseg) & + & RESULT (tf_bdy) + !------------------------------------------------------------------- + !> @brief This function initialise a boundary structure. + ! + !> @details + !> Boundaries for each cardinal will be compute with variable structure. + !> It means that orthogonal index, first and last indices of each + !> sea segment will be compute automatically. + !> However you could specify which boundary to use or not with + !> arguments ln_north, ln_south, ln_east, ln_west. + !> And boundary description could be specify with argument + !> cn_north, cn_south, cn_east, cn_west. + !> For each cardinal you could specify orthogonal index, + !> first and last indices (in this order) and boundary width (between + !> parentheses). + !> ex : cn_north='index,first,last(width)' + !> You could specify more than one segment for each boundary. + !> However each segment will have the same width. So you do not need to + !> specify it for each segment. + !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' + !> + !> @warn Boundaries are compute on T point, but expressed on U,V point. + !> change will be done to get data on other point when need be. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - add boolean to use only one segment for each boundary + !> - check boundary width + ! + !> @param[in] td_var variable structure + !> @param[in] ld_north use north boundary or not + !> @param[in] ld_south use south boundary or not + !> @param[in] ld_east use east boundary or not + !> @param[in] ld_west use west boundary or not + !> @param[in] cd_north north boundary description + !> @param[in] cd_south south boundary description + !> @param[in] cd_east east boundary description + !> @param[in] cd_west west boundary description + !> @param[in] ld_oneseg force to use only one segment for each boundary + !> @return boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + LOGICAL , INTENT(IN), OPTIONAL :: ld_north + LOGICAL , INTENT(IN), OPTIONAL :: ld_south + LOGICAL , INTENT(IN), OPTIONAL :: ld_east + LOGICAL , INTENT(IN), OPTIONAL :: ld_west + CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_north + CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_south + CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_east + CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_west + LOGICAL , INTENT(IN), OPTIONAL :: ld_oneseg + + ! function + TYPE(TBDY) , DIMENSION(ip_ncard) :: tf_bdy + + ! local variable + INTEGER(i4) :: il_width + INTEGER(i4) , DIMENSION(ip_ncard) :: il_max_width + INTEGER(i4) , DIMENSION(ip_ncard) :: il_index + INTEGER(i4) , DIMENSION(ip_ncard) :: il_min + INTEGER(i4) , DIMENSION(ip_ncard) :: il_max + + CHARACTER(LEN=lc), DIMENSION(ip_ncard) :: cl_card + + TYPE(TBDY) :: tl_tmp + + TYPE(TSEG) :: tl_seg + + LOGICAL :: ll_oneseg + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + !---------------------------------------------------------------- + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("BOUNDARY INIT: no value associated to variable "//& + & TRIM(td_var%c_name) ) + ELSEIF( TRIM(td_var%c_point) /= 'T' )THEN + CALL logger_error("BOUNDARY INIT: can not compute boundary with "//& + & "variable "//TRIM(td_var%c_name)//& + & ". need a variable on T point." ) + ELSE + ll_oneseg=.TRUE. + IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg + + ! init + tf_bdy(jp_north)=boundary__init('north',ld_north) + tf_bdy(jp_south)=boundary__init('south',ld_south) + tf_bdy(jp_east )=boundary__init('east ',ld_east ) + tf_bdy(jp_west )=boundary__init('west ',ld_west ) + + ! if EW cyclic no east west boundary and force to use one segment + IF( td_var%i_ew >= 0 )THEN + CALL logger_info("BOUNDARY INIT: cyclic domain, "//& + & "no East West boundary") + tf_bdy(jp_east )%l_use=.FALSE. + tf_bdy(jp_west )%l_use=.FALSE. + + CALL logger_info("BOUNDARY INIT: force to use one segment due"//& + & " to EW cyclic domain") + ll_oneseg=.TRUE. + ENDIF + + il_index(jp_north)=td_var%t_dim(2)%i_len-ip_ghost + il_index(jp_south)=1+ip_ghost + il_index(jp_east )=td_var%t_dim(1)%i_len-ip_ghost + il_index(jp_west )=1+ip_ghost + + il_min(jp_north)=1 + il_min(jp_south)=1 + il_min(jp_east )=1 + il_min(jp_west )=1 + + il_max(jp_north)=td_var%t_dim(1)%i_len + il_max(jp_south)=td_var%t_dim(1)%i_len + il_max(jp_east )=td_var%t_dim(2)%i_len + il_max(jp_west )=td_var%t_dim(2)%i_len + + cl_card=(/'','','',''/) + IF( PRESENT(cd_north) ) cl_card(jp_north)=TRIM(cd_north) + IF( PRESENT(cd_south) ) cl_card(jp_south)=TRIM(cd_south) + IF( PRESENT(cd_east ) ) cl_card(jp_east )=TRIM(cd_east ) + IF( PRESENT(cd_west ) ) cl_card(jp_west )=TRIM(cd_west ) + + il_max_width(jp_north)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost)) + il_max_width(jp_south)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost)) + il_max_width(jp_east )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost)) + il_max_width(jp_west )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost)) + + DO jk=1,ip_ncard + + ! check boundary width + IF( il_max_width(jk) <= im_width )THEN + IF( il_max_width(jk) <= 0 )THEN + CALL logger_fatal("BOUNDARY INIT: domain too small to define"//& + & " boundaries.") + ELSE + CALL logger_warn("BOUNDARY INIT: default boundary width too "//& + & "large for boundaries. force to use boundary"//& + & " on one point") + il_width=1 + ENDIF + ELSE + il_width=im_width + ENDIF + + ! define default segment + tl_seg=seg__init(il_index(jk),il_width,il_min(jk),il_max(jk)) + + IF( tf_bdy(jk)%l_use )THEN + + ! get namelist information + tl_tmp=boundary__get_info(cl_card(jk),jk) + + ! get segments indices + DO ji=1,tl_tmp%i_nseg + CALL boundary__add_seg(tf_bdy(jk),tl_tmp%t_seg(ji)) + ENDDO + ! indices from namelist or not + tf_bdy(jk)%l_nam=tl_tmp%l_nam + + CALL boundary_clean(tl_tmp) + + IF( tf_bdy(jk)%i_nseg == 0 )THEN + ! add default segment + CALL boundary__add_seg(tf_bdy(jk),tl_seg) + ELSE + ! fill undefined value + WHERE( tf_bdy(jk)%t_seg(:)%i_index == 0 ) + tf_bdy(jk)%t_seg(:)%i_index = tl_seg%i_index + END WHERE + WHERE( tf_bdy(jk)%t_seg(:)%i_width == 0 ) + tf_bdy(jk)%t_seg(:)%i_width = tl_seg%i_width + END WHERE + WHERE( tf_bdy(jk)%t_seg(:)%i_first == 0 ) + tf_bdy(jk)%t_seg(:)%i_first = tl_seg%i_first + END WHERE + WHERE( tf_bdy(jk)%t_seg(:)%i_last == 0 ) + tf_bdy(jk)%t_seg(:)%i_last = tl_seg%i_last + END WHERE + ENDIF + + ENDIF + ! clean + CALL seg__clean(tl_seg) + + ENDDO + + CALL boundary_get_indices(tf_bdy(:), td_var, ll_oneseg) + + CALL boundary_check(tf_bdy, td_var) + + ENDIF + + END FUNCTION boundary__init_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary__init(cd_card, ld_use, ld_nam, td_seg) & + & RESULT (tf_bdy) + !------------------------------------------------------------------- + !> @brief This function initialise basically a boundary structure with + !> cardinal name. + ! + !> @details + !> optionnaly you could specify if this boundary is used or not, + !> and add one segment structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_card cardinal name + !> @param[in] ld_use boundary use or not + !> @param[in] td_seg segment structure + !> @return boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_card + LOGICAL , INTENT(IN), OPTIONAL :: ld_use + LOGICAL , INTENT(IN), OPTIONAL :: ld_nam + TYPE(TSEG) , INTENT(IN), OPTIONAL :: td_seg + + ! function + TYPE(TBDY) :: tf_bdy + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + SELECT CASE(TRIM(cd_card)) + CASE ('north','south','east','west') + + tf_bdy%c_card=TRIM(cd_card) + + tf_bdy%l_use=.TRUE. + IF( PRESENT(ld_use) ) tf_bdy%l_use=ld_use + + tf_bdy%l_nam=.FALSE. + IF( PRESENT(ld_nam) ) tf_bdy%l_nam=ld_nam + + IF( PRESENT(td_seg) )THEN + CALL boundary__add_seg(tf_bdy, td_seg) + ENDIF + + CASE DEFAULT + CALL logger_error("BOUNDARY INIT: invalid cardinal name") + END SELECT + + END FUNCTION boundary__init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__add_seg(td_bdy, td_seg) + !------------------------------------------------------------------- + !> @brief This subroutine add one segment structure to a boundary structure + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !> @param[in] td_seg segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), INTENT(INOUT) :: td_bdy + TYPE(TSEG), INTENT(IN ) :: td_seg + + ! local variable + INTEGER(i4) :: il_status + TYPE(TSEG) , DIMENSION(:), ALLOCATABLE :: tl_seg + + ! loop indices + !---------------------------------------------------------------- + + IF( td_bdy%i_nseg > 0 )THEN + ! already other segment in boundary structure + ALLOCATE( tl_seg(td_bdy%i_nseg), stat=il_status ) + IF(il_status /= 0 )THEN + CALL logger_error( & + & " BOUNDARY ADD SEG: not enough space to put segments ") + ELSE + ! save temporary segment + tl_seg(:)=seg__copy(td_bdy%t_seg(:)) + + CALL seg__clean(td_bdy%t_seg(:)) + DEALLOCATE( td_bdy%t_seg ) + ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status ) + IF(il_status /= 0 )THEN + CALL logger_error( & + & " BOUNDARY ADD SEG: not enough space to put segments ") + ENDIF + + ! copy segment in boundary before + td_bdy%t_seg(1:td_bdy%i_nseg)=seg__copy(tl_seg(:)) + + ! clean + CALL seg__clean(tl_seg(:)) + DEALLOCATE(tl_seg) + + ENDIF + ELSE + ! no segment in boundary structure + IF( ASSOCIATED(td_bdy%t_seg) )THEN + CALL seg__clean(td_bdy%t_seg(:)) + DEALLOCATE(td_bdy%t_seg) + ENDIF + ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status ) + IF(il_status /= 0 )THEN + CALL logger_error( & + & " BOUNDARY ADD SEG: not enough space to put segments ") + ENDIF + ENDIF + + ! update number of segment + td_bdy%i_nseg=td_bdy%i_nseg+1 + + ! add new segment + td_bdy%t_seg(td_bdy%i_nseg)=seg__copy(td_seg) + + END SUBROUTINE boundary__add_seg + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__del_seg(td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine remove all segments of a boundary structure + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), INTENT(INOUT) :: td_bdy + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_bdy%t_seg) )THEN + CALL seg__clean(td_bdy%t_seg(:)) + DEALLOCATE(td_bdy%t_seg) + ENDIF + !update number of segment + td_bdy%i_nseg=0 + + END SUBROUTINE boundary__del_seg + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION boundary__get_info(cd_card, id_jcard) & + & RESULT (tf_bdy) + !------------------------------------------------------------------- + !> @brief This function get information about boundary from string character. + ! + !> @details + !> This string character that will be passed through namelist could contains + !> orthogonal index, first and last indices, of each segment. + !> And also the width of all segments of this boundary. + !> cn_north='index1,first1:last1(width)|index2,first2:last2' + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date february, 2015 + !> - do not change indices read from namelist + !> - change format cn_north + ! + !> @param[in] cd_card boundary description + !> @param[in] id_jcard boundary index + !> @return boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=lc), INTENT(IN) :: cd_card + INTEGER(i4) , INTENT(IN) :: id_jcard + + ! function + TYPE(TBDY) :: tf_bdy + + ! local variable + INTEGER(i4) :: il_width + INTEGER(i4) :: il_ind1 + INTEGER(i4) :: il_ind2 + + CHARACTER(LEN=lc) :: cl_seg + CHARACTER(LEN=lc) :: cl_index + CHARACTER(LEN=lc) :: cl_width + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_first + CHARACTER(LEN=lc) :: cl_last + + TYPE(TSEG) :: tl_seg + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ji=1 + cl_seg=fct_split(cd_card,ji) + + il_width=0 + ! look for segment width + ! width should be the same for all segment of one boundary + IF( TRIM(cl_seg) /= '' )THEN + + ! initialise boundary + ! temporaty boundary, so it doesn't matter which caridnal is used + tf_bdy=boundary__init('north',ld_nam=.TRUE.) + + il_ind1=SCAN(fct_lower(cl_seg),'(') + IF( il_ind1 /=0 )THEN + cl_width=TRIM(cl_seg(il_ind1+1:)) + + il_ind2=SCAN(fct_lower(cl_width),')') + IF( il_ind2 /=0 )THEN + cl_width=TRIM(cl_width(1:il_ind2-1)) + READ(cl_width,*) il_width + ELSE + CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& + & " check namelist. ") + ENDIF + ENDIF + + ENDIF + + DO WHILE( TRIM(cl_seg) /= '' ) + + cl_index=fct_split(cl_seg,1,',') + ! remove potential width information + il_ind1=SCAN(fct_lower(cl_index),'(') + IF( il_ind1 /=0 )THEN + il_ind2=SCAN(fct_lower(cl_index),')') + IF( il_ind2 /=0 )THEN + cl_index=TRIM(cl_index(:il_ind1-1))//TRIM(cl_index(il_ind2+1:)) + ELSE + CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& + & " check namelist. ") + ENDIF + ENDIF + + + cl_tmp=fct_split(cl_seg,2,',') + + + cl_first=fct_split(cl_tmp,1,':') + ! remove potential width information + il_ind1=SCAN(fct_lower(cl_first),'(') + IF( il_ind1 /=0 )THEN + il_ind2=SCAN(fct_lower(cl_first),')') + IF( il_ind2 /=0 )THEN + cl_first=TRIM(cl_first(:il_ind1-1))//TRIM(cl_first(il_ind2+1:)) + ELSE + CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& + & " check namelist. ") + ENDIF + ENDIF + + cl_last =fct_split(cl_tmp,2,':') + ! remove potential width information + il_ind1=SCAN(fct_lower(cl_last),'(') + IF( il_ind1 /=0 )THEN + il_ind2=SCAN(fct_lower(cl_last),')') + IF( il_ind2 /=0 )THEN + cl_last=TRIM(cl_last(:il_ind1-1))//TRIM(cl_last(il_ind2+1:)) + ELSE + CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& + & " check namelist. ") + ENDIF + ENDIF + + IF( il_width /= 0 ) tl_seg%i_width=il_width + + IF( TRIM(cl_index) /= '' ) READ(cl_index,*) tl_seg%i_index + IF( TRIM(cl_first) /= '' ) READ(cl_first,*) tl_seg%i_first + IF( TRIM(cl_last) /= '' ) READ(cl_last ,*) tl_seg%i_last + + ! index expressed on U,V point, move on T point. + SELECT CASE(id_jcard) + CASE(jp_north, jp_east) + tl_seg%i_index=tl_seg%i_index+1 + END SELECT + + IF( (tl_seg%i_first == 0 .AND. tl_seg%i_last == 0) .OR. & + & (tl_seg%i_first /= 0 .AND. tl_seg%i_last /= 0) )THEN + CALL boundary__add_seg(tf_bdy, tl_seg) + ELSE + CALL logger_error("BOUNDARY INIT: first or last segment indices "//& + & "are missing . check namelist.") + ENDIF + + ji=ji+1 + cl_seg=fct_split(cd_card,ji) + + ! clean + CALL seg__clean(tl_seg) + ENDDO + + END FUNCTION boundary__get_info + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary_get_indices(td_bdy, td_var, ld_oneseg) + !------------------------------------------------------------------- + !> @brief This subroutine get indices of each semgent for each boundary. + ! + !> @details + !> indices are compute from variable value, actually variable fill value, + !> which is assume to be land mask. + !> Boundary structure should have been initialized before running + !> this subroutine. Segment indices will be search between first and last + !> indies, at this orthogonal index. + !> + !> Optionnally you could forced to use only one segment for each boundary. + !> + !> @warning number of segment (i_nseg) will be change, before the number + !> of segment structure + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !> @param[in] td_var variable structure + !> @param[in] ld_onseg use only one sgment for each boundary + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy + TYPE(TVAR) , INTENT(IN ) :: td_var + LOGICAL , INTENT(IN ), OPTIONAL :: ld_oneseg + + ! local variable + INTEGER(i4) :: il_index + INTEGER(i4) :: il_width + INTEGER(i4) :: il_first + INTEGER(i4) :: il_last + + LOGICAL :: ll_oneseg + + TYPE(TSEG) :: tl_seg + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ll_oneseg=.TRUE. + IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg + + DO jk=1,ip_ncard + IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)%l_nam )THEN + ! nothing to be done + ELSE + + IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN + CALL logger_error("BOUNDARY GET INDICES: no segment "//& + & " associated to "//TRIM(td_bdy(jk)%c_card)//& + & " boundary. you should have run boundary_init before"//& + & " running boundary_get_indices" ) + ELSE + il_index=td_bdy(jk)%t_seg(1)%i_index + il_width=td_bdy(jk)%t_seg(1)%i_width + il_first=td_bdy(jk)%t_seg(1)%i_first + il_last =td_bdy(jk)%t_seg(1)%i_last + + CALL boundary__get_seg_number( td_bdy(jk), td_var) + + CALL boundary__get_seg_indices( td_bdy(jk), td_var, & + & il_index, il_width, & + & il_first, il_last ) + + IF( ll_oneseg .AND. td_bdy(jk)%l_use )THEN + tl_seg=seg__copy(td_bdy(jk)%t_seg(1)) + ! use last indice of last segment + tl_seg%i_last=td_bdy(jk)%t_seg(td_bdy(jk)%i_nseg)%i_last + + ! remove all segment from boundary + CALL boundary__del_seg(td_bdy(jk)) + + ! add one segment + CALL boundary__add_seg(td_bdy(jk),tl_seg) + + ! clean + CALL seg__clean(tl_seg) + ENDIF + + ENDIF + + ENDIF + + ENDDO + + END SUBROUTINE boundary_get_indices + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__get_seg_number(td_bdy, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine compute the number of sea segment. + ! + !> @details + !> It use variable value, actually variable fill value + !> (which is assume to be land mask), to compute the number of segment between + !> first and last indices at boundary orthogonal index. + !> @warning number of segment (i_nseg) will be change, before the number + !> of segment structure + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY) , INTENT(INOUT) :: td_bdy + TYPE(TVAR) , INTENT(IN ) :: td_var + + ! local variable + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + LOGICAL :: ll_sea + INTEGER(i4) :: il_index + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( td_bdy%l_use .AND. td_bdy%i_nseg == 1 )THEN + + il_index=td_bdy%t_seg(1)%i_index + + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north','south') + + ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) + dl_value(:)=td_var%d_value(:,il_index,1,1) + + IF( ANY(dl_value(:) /= td_var%d_fill) )THEN + + td_bdy%l_use=.TRUE. + td_bdy%i_nseg=0 + + ll_sea=.FALSE. + DO ji=1,td_var%t_dim(1)%i_len + IF( dl_value(ji)/= td_var%d_fill )THEN + IF( .NOT. ll_sea )THEN + td_bdy%i_nseg=td_bdy%i_nseg+1 + ENDIF + ll_sea=.TRUE. + ELSE + ll_sea=.FALSE. + ENDIF + ENDDO + + ELSE + td_bdy%l_use=.FALSE. + td_bdy%i_nseg=0 + ENDIF + + DEALLOCATE( dl_value ) + + CASE('east','west') + + ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) + dl_value(:)=td_var%d_value(il_index,:,1,1) + + IF( ANY(dl_value(:) /= td_var%d_fill) )THEN + + td_bdy%l_use=.TRUE. + td_bdy%i_nseg=0 + + ll_sea=.FALSE. + DO ji=1,td_var%t_dim(2)%i_len + IF( dl_value(ji)/= td_var%d_fill )THEN + IF( .NOT. ll_sea )THEN + td_bdy%i_nseg=td_bdy%i_nseg+1 + ENDIF + ll_sea=.TRUE. + ELSE + ll_sea=.FALSE. + ENDIF + ENDDO + + ELSE + td_bdy%l_use=.FALSE. + td_bdy%i_nseg=0 + ENDIF + + DEALLOCATE( dl_value ) + + END SELECT + ENDIF + + END SUBROUTINE boundary__get_seg_number + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__get_seg_indices(td_bdy, td_var, & + & id_index, id_width, id_first, id_last) + !------------------------------------------------------------------- + !> @brief This subroutine get segment indices for one boundary. + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !> @param[in] td_var variable structure + !> @param[in] id_index boundary orthogonal index + !> @param[in] id_width bounary width + !> @param[in] id_first boundary first indice + !> @param[in] id_last boundary last indice + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY) , INTENT(INOUT) :: td_bdy + TYPE(TVAR) , INTENT(IN ) :: td_var + INTEGER(i4), INTENT(IN ) :: id_index + INTEGER(i4), INTENT(IN ) :: id_width + INTEGER(i4), INTENT(IN ) :: id_first + INTEGER(i4), INTENT(IN ) :: id_last + + ! local variable + INTEGER(i4) :: il_nseg + INTEGER(i4), DIMENSION(ip_ncard) :: il_max + INTEGER(i4), DIMENSION(ip_ncard) :: il_min + + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + LOGICAL :: ll_sea + LOGICAL :: ll_first + LOGICAL :: ll_last + + TYPE(TSEG) :: tl_seg + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north') + jk=jp_north + + ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) + dl_value(:)=td_var%d_value(:,id_index,1,1) + + CASE('south') + jk=jp_south + + ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) + dl_value(:)=td_var%d_value(:,id_index,1,1) + + CASE('east ') + jk=jp_east + + ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) + dl_value(:)=td_var%d_value(id_index,:,1,1) + + CASE('west ') + jk=jp_west + + ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) + dl_value(:)=td_var%d_value(id_index,:,1,1) + + END SELECT + + il_max(jp_north)=td_var%t_dim(1)%i_len-ip_ghost + il_max(jp_south)=td_var%t_dim(1)%i_len-ip_ghost + il_max(jp_east )=td_var%t_dim(2)%i_len-ip_ghost + il_max(jp_west )=td_var%t_dim(2)%i_len-ip_ghost + + il_min(jp_north)=1+ip_ghost + il_min(jp_south)=1+ip_ghost + il_min(jp_east )=1+ip_ghost + il_min(jp_west )=1+ip_ghost + + ! special case for EW cyclic + IF( td_var%i_ew >= 0 )THEN + il_min(jp_north)=1 + il_min(jp_south)=1 + + il_max(jp_north)=td_var%t_dim(1)%i_len + il_max(jp_south)=td_var%t_dim(1)%i_len + ENDIF + + il_nseg=td_bdy%i_nseg + ! remove all segment from boundary + CALL boundary__del_seg(td_bdy) + + ll_first=.FALSE. + ll_last =.FALSE. + DO jl=1,il_nseg + + ! init + tl_seg=seg__init(id_index,id_width,id_first,id_last) + + IF( .NOT. (ll_first .AND. ll_last) )THEN + ! first loop + tl_seg%i_first=MAX(id_first,il_min(jk)) + tl_seg%i_last =MIN(id_last ,il_max(jk)) + ELSE + ! load new min and max + tl_seg%i_first=MAX(td_bdy%t_seg(jl-1)%i_last,il_min(jk)) + tl_seg%i_last =MIN(id_last ,il_max(jk)) + ENDIF + + ll_first=.FALSE. + ll_last =.FALSE. + ll_sea =.FALSE. + + DO ji=tl_seg%i_first,tl_seg%i_last + + IF( ll_first .AND. ll_last )THEN + ! first and last point already loaded + ! look for next segment + EXIT + ENDIF + + IF( dl_value(ji)/= td_var%d_fill )THEN + IF( .NOT. ll_sea )THEN + tl_seg%i_first=MAX(tl_seg%i_first,ji-1) + ll_first=.true. + ENDIF + ll_sea=.TRUE. + ELSE + IF( ll_sea )THEN + tl_seg%i_last=ji + ll_last=.TRUE. + ENDIF + ll_sea=.FALSE. + ENDIF + + ENDDO + + CALL boundary__add_seg(td_bdy,tl_seg) + + ! clean + CALL seg__clean(tl_seg) + + ENDDO + + DEALLOCATE(dl_value) + + END SUBROUTINE boundary__get_seg_indices + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary_check_corner(td_bdy, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine check if there is boundary at corner, and + !> adjust boundary indices if necessary. + ! + !> @details + !> If there is a north west corner, first indices of north boundary + !> should be the same as the west boundary indices. + !> And the last indices of the west boundary should be the same as + !> the north indices. + !> More over the width of west and north boundary should be the same. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_bdy boundary structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy + TYPE(TVAR) , INTENT(IN ) :: td_var + + ! local variable + TYPE(TSEG) :: tl_north + TYPE(TSEG) :: tl_south + TYPE(TSEG) :: tl_east + TYPE(TSEG) :: tl_west + + INTEGER(i4) :: il_width + + ! loop indices + !---------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: no value associated "//& + & "to variable "//TRIM(td_var%c_name)) + ENDIF + + ! check north west corner + IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_west)%l_use )THEN + tl_west =seg__copy(td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)) + tl_north=seg__copy(td_bdy(jp_north)%t_seg(1)) + + IF( tl_west%i_last >= tl_north%i_index .AND. & + & tl_west%i_index >= tl_north%i_first ) THEN + CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& + & "a north west corner") + + tl_west%i_last = tl_north%i_index + tl_north%i_first = tl_west%i_index + + IF( tl_west%i_width /= tl_north%i_width )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& + & " width between north and west boundary ") + + il_width=MIN(tl_west%i_width,tl_north%i_width) + + tl_west%i_width =il_width + tl_north%i_width=il_width + + ENDIF + + td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)=seg__copy(tl_west) + td_bdy(jp_north)%t_seg(1) =seg__copy(tl_north) + + ELSE + + IF( td_var%d_value(tl_north%i_first,tl_north%i_index,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "north boundary first indice ") + ENDIF + + IF( td_var%d_value(tl_west%i_index,tl_west%i_last,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "west boundary last indice") + ENDIF + ENDIF + ENDIF + + ! check north east corner + IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_east)%l_use )THEN + tl_east =seg__copy(td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)) + tl_north=seg__copy(td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)) + + IF( tl_east%i_last >= tl_north%i_index .AND. & + & tl_east%i_index <= tl_north%i_last ) THEN + CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& + & "a north east corner") + + tl_east%i_last = tl_north%i_index + tl_north%i_last = tl_east%i_index + + IF( tl_east%i_width /= tl_north%i_width )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& + & " width between north and east boundary ") + + il_width=MIN(tl_east%i_width,tl_north%i_width) + + tl_east%i_width =il_width + tl_north%i_width=il_width + + ENDIF + + td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)=seg__copy(tl_east) + td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=seg__copy(tl_north) + ELSE + + IF( td_var%d_value(tl_north%i_last,tl_north%i_index,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "north boundary last indice ") + ENDIF + + IF( td_var%d_value(tl_east%i_index,tl_east%i_last,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "east boundary last indice") + ENDIF + ENDIF + ENDIF + + ! check south east corner + IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_east)%l_use )THEN + tl_east =seg__copy(td_bdy(jp_east )%t_seg(1)) + tl_south=seg__copy(td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)) + + IF( tl_east%i_first <= tl_south%i_index .AND. & + & tl_east%i_index <= tl_south%i_last ) THEN + CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& + & "a south east corner") + + tl_east%i_first = tl_south%i_index + tl_south%i_last = tl_east%i_index + + IF( tl_east%i_width /= tl_south%i_width )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& + & " width between south and east boundary ") + + il_width=MIN(tl_east%i_width,tl_south%i_width) + + tl_east%i_width =il_width + tl_south%i_width=il_width + + ENDIF + + td_bdy(jp_east )%t_seg(1) =seg__copy(tl_east) + td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=seg__copy(tl_south) + ELSE + + IF( td_var%d_value(tl_south%i_last,tl_south%i_index,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "south boundary last indice ") + ENDIF + + IF( td_var%d_value(tl_east%i_index,tl_east%i_first,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "east boundary first indice") + ENDIF + ENDIF + ENDIF + + ! check south west corner + IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_west)%l_use )THEN + tl_west =seg__copy(td_bdy(jp_west )%t_seg(1)) + tl_south=seg__copy(td_bdy(jp_south)%t_seg(1)) + + IF( tl_west%i_first <= tl_south%i_index .AND. & + & tl_west%i_index >= tl_south%i_first ) THEN + CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& + & "a south west corner") + + tl_west%i_first = tl_south%i_index + tl_south%i_first= tl_west%i_index + + IF( tl_west%i_width /= tl_south%i_width )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& + & " width between south and west boundary ") + + il_width=MIN(tl_west%i_width,tl_south%i_width) + + tl_west%i_width =il_width + tl_south%i_width=il_width + + ENDIF + + td_bdy(jp_west )%t_seg(1) = seg__copy(tl_west) + td_bdy(jp_south)%t_seg(1) = seg__copy(tl_south) + ELSE + + IF( td_var%d_value(tl_south%i_first,tl_south%i_index,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "south boundary first indice ") + ENDIF + + IF( td_var%d_value(tl_west%i_index,tl_west%i_first,1,1) /= & + & td_var%d_fill )THEN + CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& + & "west boundary first indice") + ENDIF + ENDIF + ENDIF + + ! clean + CALL seg__clean(tl_north) + CALL seg__clean(tl_south) + CALL seg__clean(tl_east ) + CALL seg__clean(tl_west ) + + END SUBROUTINE boundary_check_corner + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary_check(td_bdy, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine check boundary. + ! + !> @details + !> It checks that first and last indices as well as orthogonal index are + !> inside domain, and check corner (see boundary_check_corner). + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2016 + !> - Bug fix: take into account that boundaries are compute on T point, + !> but expressed on U,V point + !> + !> @param[inout] td_bdy boundary structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy + TYPE(TVAR) , INTENT(IN ) :: td_var + + ! local variable + INTEGER(i4) , DIMENSION(ip_ncard) :: il_max + INTEGER(i4) , DIMENSION(ip_ncard) :: il_maxindex + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_max(jp_north)=td_var%t_dim(1)%i_len + il_max(jp_south)=td_var%t_dim(1)%i_len + il_max(jp_east )=td_var%t_dim(2)%i_len + il_max(jp_west )=td_var%t_dim(2)%i_len + + ! index expressed on U,V point, move on T point. + il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ip_ghost+1 + il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ip_ghost + il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ip_ghost+1 + il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ip_ghost + + DO jk=1,ip_ncard + IF( td_bdy(jk)%l_use )THEN + IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN + CALL logger_error("BOUNDARY CHECK: no segment associted "//& + & "to "//TRIM(td_bdy(jk)%c_card)//" boundary") + ELSE + ! check indices + IF( ANY(td_bdy(jk)%t_seg(:)%i_first < 1 ) .OR. & + & ANY(td_bdy(jk)%t_seg(:)%i_first > il_max(jk)) .OR. & + & ANY(td_bdy(jk)%t_seg(:)%i_last < 1 ) .OR. & + & ANY(td_bdy(jk)%t_seg(:)%i_last > il_max(jk)) .OR. & + & ANY(td_bdy(jk)%t_seg(:)%i_first > td_bdy(jk)%t_seg(:)%i_last)& + & )THEN + CALL logger_error("BOUNDARY CHECK: invalid segment "//& + & "first and/or last indice for "//& + & TRIM(td_bdy(jk)%c_card)//& + & " boundary. check namelist") + ENDIF + + IF( ANY(td_bdy(jk)%t_seg(:)%i_index < 1 ) .OR. & + & ANY(td_bdy(jk)%t_seg(:)%i_index > il_maxindex(jk)) & + & )THEN + CALL logger_error("BOUNDARY CHECK: invalid index "//& + & "for "//TRIM(td_bdy(jk)%c_card)//& + & " boundary. check namelist") + ENDIF + ENDIF + ENDIF + ENDDO + + CALL boundary_check_corner(td_bdy, td_var) + + END SUBROUTINE boundary_check + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary_swap(td_var, td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine swap array for east and north boundary. + ! + !> @detail + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_var variable strucutre + !> @param[in ] td_bdy boundary strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TBDY), INTENT(IN ) :: td_bdy + + ! local variable + REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("BOUNDARY SWAP: no array of value "//& + & "associted to variable "//TRIM(td_var%c_name) ) + ELSE + + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north') + ALLOCATE( dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) + + DO jj=1, td_var%t_dim(2)%i_len + td_var%d_value(:,jj,:,:) = & + & dl_value(:,td_var%t_dim(2)%i_len-jj+1,:,:) + ENDDO + + DEALLOCATE( dl_value ) + CASE('east') + ALLOCATE( dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) + + DO ji=1, td_var%t_dim(1)%i_len + td_var%d_value(ji,:,:,:) = & + & dl_value(td_var%t_dim(1)%i_len-ji+1,:,:,:) + ENDDO + + DEALLOCATE( dl_value ) + CASE DEFAULT + ! nothing to be done + END SELECT + + ENDIF + END SUBROUTINE boundary_swap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__print_unit(td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine print information about one boundary. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_bdy boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), INTENT(IN) :: td_bdy + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + WRITE(*,'(a,/1x,a,/1x,a)') "Boundary "//TRIM(td_bdy%c_card), & + & " use "//TRIM(fct_str(td_bdy%l_use)), & + & " nseg "//TRIM(fct_str(td_bdy%i_nseg)) + DO ji=1,td_bdy%i_nseg + WRITE(*,'(4(/1x,a))') & + & " index "//TRIM(fct_str(td_bdy%t_seg(ji)%i_index)), & + & " width "//TRIM(fct_str(td_bdy%t_seg(ji)%i_width)), & + & " first "//TRIM(fct_str(td_bdy%t_seg(ji)%i_first)), & + & " last "//TRIM(fct_str(td_bdy%t_seg(ji)%i_last)) + ENDDO + + END SUBROUTINE boundary__print_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE boundary__print_arr(td_bdy) + !------------------------------------------------------------------- + !> @brief This subroutine print information about a array of boundary + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_bdy boundary structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_bdy(:)) + CALL boundary_print(td_bdy(ji)) + ENDDO + + END SUBROUTINE boundary__print_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION seg__copy_unit(td_seg) & + & RESULT (tf_seg) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy segment structure in another one. + !> + !> @warning do not use on the output of a function who create or read a + !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + ! + !> @param[in] td_seg segment structure + !> @return copy of input segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TSEG), INTENT(IN) :: td_seg + + ! function + TYPE(TSEG) :: tf_seg + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + ! copy segment index, width, .. + tf_seg%i_index = td_seg%i_index + tf_seg%i_width = td_seg%i_width + tf_seg%i_first = td_seg%i_first + tf_seg%i_last = td_seg%i_last + + END FUNCTION seg__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION seg__copy_arr(td_seg) & + & RESULT (tf_seg) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy segment structure in another one. + !> + !> @warning do not use on the output of a function who create or read a + !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + ! + !> @param[in] td_seg segment structure + !> @return copy of input array of segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TSEG), DIMENSION(:), INTENT(IN) :: td_seg + + ! function + TYPE(TSEG), DIMENSION(SIZE(td_seg(:))) :: tf_seg + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_seg(:)) + tf_seg(ji)=seg__copy(td_seg(ji)) + ENDDO + + END FUNCTION seg__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION seg__init(id_index, id_width, id_first, id_last) & + & RESULT(tf_seg) + !------------------------------------------------------------------- + !> @brief This function initialise segment structure. + ! + !> @details + !> It simply add orthogonal index, and optionnaly width, first + !> and last indices of the segment. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] id_index orthogonal index + !> @param[in] id_width width of the segment + !> @param[in] id_first first indices + !> @param[in] id_last last indices + !> @return segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: id_index + INTEGER(i4), INTENT(IN), OPTIONAL :: id_width + INTEGER(i4), INTENT(IN), OPTIONAL :: id_first + INTEGER(i4), INTENT(IN), OPTIONAL :: id_last + + ! function + TYPE(TSEG) :: tf_seg + + ! local variable + + ! loop indices + !---------------------------------------------------------------- + + tf_seg%i_index=id_index + + IF( PRESENT(id_width) ) tf_seg%i_width=id_width + IF( PRESENT(id_first) ) tf_seg%i_first=id_first + IF( PRESENT(id_last ) ) tf_seg%i_last =id_last + + END FUNCTION seg__init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE seg__clean_unit(td_seg) + !------------------------------------------------------------------- + !> @brief This subroutine clean segment structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_seg segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TSEG), INTENT(INOUT) :: td_seg + + ! local variable + TYPE(TSEG) :: tl_seg + ! loop indices + !---------------------------------------------------------------- + + td_seg=seg__copy(tl_seg) + + END SUBROUTINE seg__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE seg__clean_arr(td_seg) + !------------------------------------------------------------------- + !> @brief This subroutine clean segment structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_seg array of segment structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TSEG), DIMENSION(:), INTENT(INOUT) :: td_seg + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_seg(:)),1,-1 + CALL seg__clean(td_seg(ji)) + ENDDO + + END SUBROUTINE seg__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE boundary diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_bathy.f90 b/V4.0/nemo_sources/tools/SIREN/src/create_bathy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ad41191f915df191e58bd0c45621d4a395a0d2c9 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_bathy.f90 @@ -0,0 +1,1417 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> This program creates fine grid bathymetry file. +!> +!> @section sec1 method +!> This bathymetry could be : +!> - extracted from a wider fine grid bathymetry file +!> - interpolated from a wider coarse grid bathymetry file +!> - handwritten +!> +!> @image html bathy_40.png +!> <center>@image latex bathy_30.png +!> </center> +!> +!> @section sec2 how to +!> USAGE: create_bathy create_bathy.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_bathy.nam<br/> +!> namelist of create_bathy +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_bathy +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_bathy create_bathy.nam +!> create_bathy.nam contains 7 sub-namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source/coarse grid parameters +!> - **namtgt** to set target/fine grid parameters +!> - **namvar** to set variable parameters +!> - **namnst** to set sub domain and nesting paramters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_bathy.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the source/coarse grid sub-namelist parameters are : +!> +!> - **cn_coord0** [@a ]<br/> +!> path to the coordinate file +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subtgt namtgt +!> the target/fine grid sub-namelist parameters are : +!> +!> - **cn_coord1** [@a ]<br/> +!> path to coordinate file +!> +!> - **in_perio1** [@a ]<br/> +!> NEMO periodicity index (see above) +!> @note if the fine/target coordinates file (cn_coord1) was created by SIREN, you do +!> not need to fill this parameter. SIREN will read it on the global attributes of +!> the coordinates file. +!> +!> - **ln_fillclosed** [@a .TRUE.]<br/> +!> logical to fill closed sea or not +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varfile** [@a ]<br/> +!> list of variable, and associated file +!> @warning +!> variable name must be __Bathymetry__ here. +!> +!> *cn_varfile* is the path and filename of the file where find +!> variable. +!> @note +!> *cn_varfile* could be a matrix of value, if you want to handwrite +!> variable value.<br/> +!> the variable array of value is split into equal subdomain.<br/> +!> each subdomain is filled with the corresponding value +!> of the matrix.<br/> +!> separators used to defined matrix are: +!> - ',' for line +!> - '/' for row +!> Example:<br/> +!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} +!> 3 & 2 & 3 \\ +!> 1 & 4 & 5 \end{array} \right) @f$ +!> +!> Examples: +!> - 'Bathymetry:gridT.nc' +!> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000'<br/> +!> +!> @note +!> Optionnaly, NEMO periodicity could be added following the filename. +!> the periodicity must be separated by ';' +!> +!> Example: +!> - 'Bathymetry:gridT.nc ; perio=4'<br/> +!> +!> - **cn_varinfo** [@a ]<br/> +!> list of variable and extra information about request(s) to be used<br/> +!> +!> each elements of *cn_varinfo* is a string character (separated by ',').<br/> +!> it is composed of the variable name follow by ':', +!> then request(s) to be used on this variable.<br/> +!> request could be: +!> - int = interpolation method +!> - ext = extrapolation method +!> - flt = filter method +!> - min = minimum value +!> - max = maximum value +!> - unt = new units +!> - unf = unit scale factor (linked to new units) +!> +!> requests must be separated by ';'.<br/> +!> order of requests does not matter.<br/> +!> +!> informations about available method could be find in @ref interp, +!> @ref extrap and @ref filter modules.<br/> +!> Example: +!> - 'Bathymetry: flt=2*hamming(2,3); min=0' +!> +!> @note +!> If you do not specify a method which is required, +!> default one is apply. +!> +!> - **ln_rand** [@a .False.]<br/> +!> logical to add random value to Bathymetry<br/> +!> Only for handmade Bathymetry. +!> A random value (+/- 0.1% of the maximum depth) will +!> will be added to avoid flat Bathymetry (which may cause issue). +!> +!> @subsection subnst namnst +!> the nesting sub-namelist parameters are : +!> +!> - **in_rhoi** [@a 1]<br/> +!> refinement factor in i-direction +!> +!> - **in_rhoj** [@a 1]<br/> +!> refinement factor in j-direction +!> +!> @note +!> coarse grid indices will be deduced from fine grid +!> coordinate file. +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a bathy_fine.nc]<br/> +!> output bathymetry filename +!> +!> <hr> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date Sepember, 2014 +!> - add header for user +!> - Bug fix, compute offset depending of grid point +!> @date June, 2015 +!> - extrapolate all land points. +!> - allow to change unit. +!> @date September, 2015 +!> - manage useless (dummy) variable, attributes, and dimension +!> @date January,2016 +!> - add create_bathy_check_depth as in create_boundary +!> - add create_bathy_check_time as in create_boundary +!> @date February, 2016 +!> - do not closed sea for east-west cyclic domain +!> @date October, 2016 +!> - dimension to be used select from configuration file +!> @date July, 2017 +!> - add random value to avoid flat bathymetry +!> @date January, 2019 +!> - add option to add random value to a flat Bathymetry +!> - create and clean file structure to avoid memory leaks +!> - check dimension of matrix for 'handmade' bathymetry +!> - add url path to global attributes of output file(s) +!> @date February, 2019 +!> - rename sub namelist namcrs to namsrc +!> - rename sub namelist namfin to namtgt +!> @date August, 2019 +!> - use periodicity read from namelist, and store in multi structure +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @todo +!> - check tl_multi is not empty +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_bathy + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE multi ! multi file manager + USE iom ! I/O manager + USE grid ! grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE dom ! domain manager + USE iom_mpp ! MPP I/O manager + USE iom_dom ! DOM I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_bathy" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_data + CHARACTER(LEN=lc) :: cl_url + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_varid + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho + INTEGER(i4) , DIMENSION(2,2) :: il_offset + INTEGER(i4) , DIMENSION(2,2) :: il_ind + INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_mask + + LOGICAL :: ll_exist + LOGICAL :: ll_fillclosed + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + TYPE(TMPP) :: tl_mpp + TYPE(TFILE) :: tl_fileout + + TYPE(TATT) :: tl_att + + TYPE(TVAR) :: tl_lon + TYPE(TVAR) :: tl_lat + TYPE(TVAR) :: tl_depth + TYPE(TVAR) :: tl_time + + TYPE(TVAR) :: tl_tmp + TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_var + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TFILE) :: tl_file + + TYPE(TMULTI) :: tl_multi + + REAL(dp) :: dl_minbat + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_coord0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namtgt + CHARACTER(LEN=lc) :: cn_coord1 = '' + INTEGER(i4) :: in_perio1 = -1 + LOGICAL :: ln_fillclosed = .TRUE. + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + LOGICAL :: ln_rand = .FALSE. + + ! namnst + INTEGER(i4) :: in_rhoi = 1 + INTEGER(i4) :: in_rhoj = 1 + + ! namout + CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc' + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_coord0, & !< coordinate file + & in_perio0 !< periodicity index + + NAMELIST /namtgt/ & !< target/fine grid namelist + & cn_coord1, & !< coordinate file + & in_perio1, & !< periodicity index + & ln_fillclosed !< fill closed sea + + NAMELIST /namvar/ & !< variable namelist + & cn_varfile, & !< list of variable file + & cn_varinfo, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' ) + & ln_rand !< add random value to avoid flat bathymetry + + NAMELIST /namnst/ & !< nesting namelist + & in_rhoi, & !< refinement factor in i-direction + & in_rhoj !< refinement factor in j-direction + + NAMELIST /namout/ & !< output namelist + & cn_fileout !< fine grid bathymetry file + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + + ! define logger file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information on configuration file + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namtgt ) + READ( il_fileid, NML = namvar ) + ! add user change in extra information + CALL var_chg_extra( cn_varinfo ) + ! match variable with file + tl_multi=multi_init(cn_varfile) + + READ( il_fileid, NML = namnst ) + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE BATHY: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + CALL multi_print(tl_multi) + + ! open files + IF( TRIM(cn_coord0) /= '' )THEN + tl_file=file_init(TRIM(cn_coord0)) + tl_coord0=mpp_init( tl_file, id_perio=in_perio0) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord0) + ELSE + CALL logger_fatal("CREATE BATHY: no coarse grid coordinate found. "//& + & "check namelist") + ENDIF + + IF( TRIM(cn_coord1) /= '' )THEN + tl_file=file_init(TRIM(cn_coord1)) + tl_coord1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord1) + ELSE + CALL logger_fatal("CREATE BATHY: no fine grid coordinate found. "//& + & "check namelist") + ENDIF + + ! do not closed sea for east-west cyclic domain + ll_fillclosed=ln_fillclosed + IF( tl_coord1%i_perio == 1 ) ll_fillclosed=.FALSE. + + ! check + ! check output file do not already exist + INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE BATHY: output file "//TRIM(cn_fileout)//& + & " already exist.") + ENDIF + + ! check namelist + ! check refinement factor + il_rho(:)=1 + IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN + CALL logger_error("CREATE BATHY: invalid refinement factor."//& + & " check namelist "//TRIM(cl_namelist)) + ELSE + il_rho(jp_I)=in_rhoi + il_rho(jp_J)=in_rhoj + ENDIF + + ! check domain indices + ! compute coarse grid indices around fine grid + il_ind(:,:)=grid_get_coarse_index( tl_coord0, tl_coord1, & + & id_rho=il_rho(:) ) + + il_imin0=il_ind(jp_I,1) ; il_imax0=il_ind(jp_I,2) + il_jmin0=il_ind(jp_J,1) ; il_jmax0=il_ind(jp_J,2) + + ! check domain validity + CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0) + + ! check coincidence between coarse and fine grid + CALL grid_check_coincidence( tl_coord0, tl_coord1, & + & il_imin0, il_imax0, & + & il_jmin0, il_jmax0, & + & il_rho(:) ) + + IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN + CALL logger_error("CREATE BATHY: no mpp file to work on. "//& + & "check cn_varfile in namelist.") + ELSE + + ALLOCATE( tl_var( tl_multi%i_nvar ) ) + jk=0 + DO ji=1,tl_multi%i_nmpp + + WRITE(cl_data,'(a,i2.2)') 'data-',jk+1 + IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN + + CALL logger_fatal("CREATE BATHY: no variable to work on for "//& + & "mpp file"//TRIM(tl_multi%t_mpp(ji)%c_name)//& + & ". check cn_varfile in namelist.") + + ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN + + !- use input matrix to initialise variable + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + jk=jk+1 + tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + + IF( COUNT(tl_tmp%t_dim(:)%l_use) > 2 )THEN + CALL logger_fatal("CREATE BATHY: input matrix use more "//& + & "than 2D. Check namelist.") + ENDIF + tl_var(jk)=create_bathy_matrix(tl_tmp, tl_coord1, ln_rand) + ENDDO + ! clean + CALL var_clean(tl_tmp) + + ELSE + + tl_file=file_init(TRIM(tl_multi%t_mpp(ji)%c_name), & + & id_perio=tl_multi%t_mpp(ji)%i_perio) + tl_mpp=mpp_init( tl_file ) + + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_mpp) + + ! open mpp file + CALL iom_mpp_open(tl_mpp) + + ! get or check depth value + CALL create_bathy_check_depth( tl_mpp, tl_depth ) + + ! get or check time value + CALL create_bathy_check_time( tl_mpp, tl_time ) + + ! close mpp file + CALL iom_mpp_close(tl_mpp) + + IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len).OR.& + & ALL(il_rho(:)==1) )THEN + !- extract bathymetry from fine grid bathymetry + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + jk=jk+1 + tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + + tl_var(jk)=create_bathy_extract( tl_tmp, tl_mpp, & + & tl_coord1 ) + ENDDO + ! clean + CALL var_clean(tl_tmp) + ELSE + !- get bathymetry from coarse grid bathymetry + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + jk=jk+1 + tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + + il_offset(:,:)= grid_get_fine_offset(tl_coord0, & + & il_imin0, il_jmin0, & + & il_imax0, il_jmax0, & + & tl_coord1, & + & il_rho(:), & + & TRIM(tl_tmp%c_point) ) + + tl_var(jk)=create_bathy_get_var( tl_tmp, tl_mpp, & + & il_imin0, il_jmin0, & + & il_imax0, il_jmax0, & + & il_offset(:,:), & + & il_rho(:) ) + ENDDO + ! clean + CALL var_clean(tl_tmp) + ENDIF + + ! clean structure + CALL mpp_clean(tl_mpp) + + ENDIF + ENDDO + ENDIF + + ! use additional request + DO jk=1,tl_multi%i_nvar + + ! change unit and apply factor + CALL var_chg_unit(tl_var(jk)) + + ! forced min and max value + CALL var_limit_value(tl_var(jk)) + + ! fill closed sea + IF( ll_fillclosed )THEN + ALLOCATE( il_mask(tl_var(jk)%t_dim(1)%i_len, & + & tl_var(jk)%t_dim(2)%i_len) ) + + ! split domain in N sea subdomain + il_mask(:,:)=grid_split_domain(tl_var(jk)) + + ! fill smallest domain + CALL grid_fill_small_dom( tl_var(jk), il_mask(:,:) ) + + DEALLOCATE( il_mask ) + ENDIF + + ! filter + CALL filter_fill_value(tl_var(jk)) + + ! check bathymetry + dl_minbat=MINVAL(tl_var(jk)%d_value(:,:,:,:)) + IF( TRIM(tl_var(jk)%c_stdname) == 'bathymetry' .AND. & + & dl_minbat <= 0._dp )THEN + CALL logger_debug("CREATE BATHY: min value "//TRIM(fct_str(dl_minbat))) + CALL logger_fatal("CREATE BATHY: Bathymetry has value <= 0") + ENDIF + + ENDDO + + ! create file + tl_fileout=file_init(TRIM(cn_fileout)) + + ! add dimension + tl_dim(:)=var_max_dim(tl_var(:)) + + DO ji=1,ip_maxdim + IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji)) + ENDDO + + ! add variables + IF( ALL( tl_dim(1:2)%l_use ) )THEN + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! add longitude + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude') + IF( il_varid == 0 )THEN + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude_T') + ENDIF + tl_lon=iom_mpp_read_var(tl_coord1, il_varid) + CALL file_add_var(tl_fileout, tl_lon) + CALL var_clean(tl_lon) + + ! add latitude + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude') + IF( il_varid == 0 )THEN + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude_T') + ENDIF + tl_lat=iom_mpp_read_var(tl_coord1, il_varid) + CALL file_add_var(tl_fileout, tl_lat) + CALL var_clean(tl_lat) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + ENDIF + + IF( tl_dim(3)%l_use )THEN + ! add depth + CALL file_add_var(tl_fileout, tl_depth) + CALL var_clean(tl_depth) + ENDIF + + IF( tl_dim(4)%l_use )THEN + ! add time + CALL file_add_var(tl_fileout, tl_time) + CALL var_clean(tl_time) + ENDIF + + ! add other variables + DO jk=tl_multi%i_nvar,1,-1 + CALL file_add_var(tl_fileout, tl_var(jk)) + CALL var_clean(tl_var(jk)) + ENDDO + DEALLOCATE(tl_var) + + ! clean + CALL multi_clean(tl_multi) + + ! add some attribute + tl_att=att_init("Created_by","SIREN create_bathy") + CALL file_add_att(tl_fileout, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL file_add_att(tl_fileout, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",cl_date) + CALL file_add_att(tl_fileout, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attid=att_get_index(tl_fileout%t_att(:),'periodicity') + ENDIF + IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',tl_coord1%i_perio) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + + ! add attribute east west overlap + il_attid=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attid=att_get_index(tl_fileout%t_att(:),'ew_overlap') + ENDIF + IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',tl_coord1%i_ew) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + + ! create file + CALL iom_create(tl_fileout) + + ! write file + CALL iom_write_file(tl_fileout) + + ! close file + CALL iom_close(tl_fileout) + + ! clean + CALL att_clean(tl_att) + + CALL file_clean(tl_fileout) + CALL mpp_clean(tl_coord1) + CALL mpp_clean(tl_coord0) + CALL var_clean_extra() + + ! close log file + CALL logger_footer() + CALL logger_close() + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_bathy_matrix(td_var, td_coord, ld_rand) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function create variable, filled with matrix value + !> + !> @details + !> A variable is create with the same name that the input variable, + !> and with dimension of the coordinate file.<br/> + !> Then the variable array of value is split into equal subdomain. + !> Each subdomain is filled with the corresponding value of the matrix. + !> + !> Optionaly, you could add a random value of 0.1% of maximum depth to each + !> points of the bathymetry + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] td_coord coordinate file structure + !> @param[in] ld_rand add random value to bathymetry + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + TYPE(TMPP), INTENT(IN) :: td_coord + LOGICAL , INTENT(IN) :: ld_rand + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) , DIMENSION(2,2) :: il_xghost + INTEGER(i4) , DIMENSION(2) :: il_dim + INTEGER(i4) , DIMENSION(2) :: il_size + INTEGER(i4) , DIMENSION(2) :: il_rest + + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape + + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_ran + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + TYPE(TVAR) :: tl_lon + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TMPP) :: tl_coord + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! copy structure + tl_coord=mpp_copy(td_coord) + + ! use only edge processor + CALL mpp_get_contour(tl_coord) + + ! open useful processor + CALL iom_mpp_open(tl_coord) + + ! read output grid + tl_lon=iom_mpp_read_var(tl_coord,'longitude') + + ! look for ghost cell + il_xghost(:,:)=grid_get_ghost( tl_coord ) + + ! close processor + CALL iom_mpp_close(tl_coord) + ! clean + CALL mpp_clean(tl_coord) + + ! remove ghost cell + CALL grid_del_ghost(tl_lon, il_xghost(:,:)) + + ! write value on grid + ! get matrix dimension + il_dim(:)=td_var%t_dim(1:2)%i_len + ! output dimension + tl_dim(:)=dim_copy(tl_lon%t_dim(:)) + ! clean + CALL var_clean(tl_lon) + + ! split output domain in N subdomain depending of matrix dimension + il_size(:) = tl_dim(1:2)%i_len / il_dim(:) + il_rest(:) = MOD(tl_dim(1:2)%i_len, il_dim(:)) + + ALLOCATE( il_ishape(il_dim(1)+1) ) + il_ishape(:)=0 + DO ji=2,il_dim(1)+1 + il_ishape(ji)=il_ishape(ji-1)+il_size(1) + ENDDO + ! add rest to last cell + il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1) + + ALLOCATE( il_jshape(il_dim(2)+1) ) + il_jshape(:)=0 + DO jj=2,il_dim(2)+1 + il_jshape(jj)=il_jshape(jj-1)+il_size(2) + ENDDO + ! add rest to last cell + il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2) + + ! write ouput array of value + ALLOCATE(dl_value( tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + dl_value(:,:,:,:)=0 + DO jj=2,il_dim(2)+1 + DO ji=2,il_dim(1)+1 + + dl_value( 1+il_ishape(ji-1):il_ishape(ji), & + & 1+il_jshape(jj-1):il_jshape(jj), & + & 1,1 ) = td_var%d_value(ji-1,jj-1,1,1) + + ENDDO + ENDDO + + + IF( ld_rand )THEN + ALLOCATE(dl_ran(tl_dim(1)%i_len, & + & tl_dim(2)%i_len) ) + + ! set random value between 0 and 1 + CALL RANDOM_NUMBER(dl_ran(:,:)) + ! set random value between -0.5 and 0.5 + dl_ran(:,:)=dl_ran(:,:)-0.5 + ! set random value of 0.1% of maximum depth + dl_ran(:,:)=dl_ran(:,:)*1.e-4*MAXVAL(td_var%d_value(:,:,1,1)) + + dl_value(:,:,1,1)=dl_value(:,:,1,1)+dl_ran(:,:) + + DEALLOCATE(dl_ran) + ENDIF + + ! initialise variable with value + tf_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:)) + + DEALLOCATE(dl_value) + + ! add ghost cell + CALL grid_add_ghost(tf_var, il_xghost(:,:)) + + ! clean + CALL dim_clean(tl_dim(:)) + + END FUNCTION create_bathy_matrix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_bathy_extract(td_var, td_mpp, td_coord) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function extract variable from file over coordinate domain and + !> return variable structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] td_mpp mpp file structure + !> @param[in] td_coord coordinate file structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TMPP), INTENT(IN) :: td_coord + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(2,2) :: il_ind + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmax + + TYPE(TMPP) :: tl_mpp + + TYPE(TATT) :: tl_att + + TYPE(TDOM) :: tl_dom + ! loop indices + !---------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + CALL logger_error("CREATE BATHY EXTRACT: no processor associated "//& + & "to mpp "//TRIM(td_mpp%c_name)) + ELSE + + !init + tl_mpp=mpp_copy(td_mpp) + + ! compute file grid indices around coord grid + il_ind(:,:)=grid_get_coarse_index(tl_mpp, td_coord ) + + il_imin=il_ind(1,1) ; il_imax=il_ind(1,2) + il_jmin=il_ind(2,1) ; il_jmax=il_ind(2,2) + + ! check grid coincidence + CALL grid_check_coincidence( tl_mpp, td_coord, & + & il_imin, il_imax, & + & il_jmin, il_jmax, & + & (/1, 1, 1/) ) + + ! compute domain + tl_dom=dom_init(tl_mpp, & + & il_imin, il_imax, & + & il_jmin, il_jmax) + + ! open mpp files over domain + CALL iom_dom_open(tl_mpp, tl_dom) + + ! read variable on domain + tf_var=iom_dom_read_var(tl_mpp,TRIM(td_var%c_name),tl_dom) + + ! close mpp file + CALL iom_dom_close(tl_mpp) + + ! add ghost cell + CALL grid_add_ghost(tf_var,tl_dom%i_ghost(:,:)) + + ! check result + IF( ANY( tf_var%t_dim(:)%l_use .AND. & + & tf_var%t_dim(:)%i_len /= td_coord%t_dim(:)%i_len) )THEN + CALL logger_debug("CREATE BATHY EXTRACT: "//& + & "dimensoin of variable "//TRIM(td_var%c_name)//" "//& + & TRIM(fct_str(tf_var%t_dim(1)%i_len))//","//& + & TRIM(fct_str(tf_var%t_dim(2)%i_len))//","//& + & TRIM(fct_str(tf_var%t_dim(3)%i_len))//","//& + & TRIM(fct_str(tf_var%t_dim(4)%i_len)) ) + CALL logger_debug("CREATE BATHY EXTRACT: "//& + & "dimensoin of coordinate file "//& + & TRIM(fct_str(td_coord%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_coord%t_dim(2)%i_len))//","//& + & TRIM(fct_str(td_coord%t_dim(3)%i_len))//","//& + & TRIM(fct_str(td_coord%t_dim(4)%i_len)) ) + CALL logger_fatal("CREATE BATHY EXTRACT: "//& + & "dimensoin of extracted "//& + & "variable and coordinate file dimension differ") + ENDIF + + ! add attribute to variable + tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('src_i_indices',(/tl_dom%i_imin, tl_dom%i_imax/)) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('src_j_indices',(/tl_dom%i_jmin, tl_dom%i_jmax/)) + CALL var_move_att(tf_var, tl_att) + + ! clean structure + CALL att_clean(tl_att) + CALL mpp_clean(tl_mpp) + ENDIF + + END FUNCTION create_bathy_extract + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_bathy_get_var(td_var, td_mpp, & + & id_imin, id_jmin, & + & id_imax, id_jmax, & + & id_offset, & + & id_rho) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function get coarse grid variable, interpolate variable, and return + !> variable structure over fine grid + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] td_mpp mpp file structure + !> @param[in] id_imin i-direction lower left corner indice + !> @param[in] id_imax i-direction upper right corner indice + !> @param[in] id_jmin j-direction lower left corner indice + !> @param[in] id_jmax j-direction upper right corner indice + !> @param[in] id_offset offset between fine grid and coarse grid + !> @param[in] id_rho array of refinement factor + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + TYPE(TMPP) , INTENT(IN) :: td_mpp + INTEGER(i4) , INTENT(IN) :: id_imin + INTEGER(i4) , INTENT(IN) :: id_imax + INTEGER(i4) , INTENT(IN) :: id_jmin + INTEGER(i4) , INTENT(IN) :: id_jmax + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_offset + INTEGER(i4), DIMENSION(:) , INTENT(IN) :: id_rho + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TMPP) :: tl_mpp + TYPE(TATT) :: tl_att + TYPE(TDOM) :: tl_dom + + INTEGER(i4) :: il_size + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + ! loop indices + !---------------------------------------------------------------- + IF( ANY(SHAPE(id_offset(:,:)) /= 2) )THEN + CALL logger_error("CREATE BATHY GET VAR: invalid dimension of "//& + & "offset array") + ENDIF + + ! copy structure + tl_mpp=mpp_copy(td_mpp) + + !- compute domain + tl_dom=dom_init(tl_mpp, & + & id_imin, id_imax, & + & id_jmin, id_jmax) + + !- add extra band (if possible) to compute interpolation + CALL dom_add_extra(tl_dom) + + !- open mpp files over domain + CALL iom_dom_open(tl_mpp, tl_dom) + + !- read variable value on domain + tf_var=iom_dom_read_var(tl_mpp,TRIM(td_var%c_name),tl_dom) + + !- close mpp files + CALL iom_dom_close(tl_mpp) + + il_size=SIZE(id_rho(:)) + ALLOCATE( il_rho(il_size) ) + il_rho(:)=id_rho(:) + + !- interpolate variable + CALL create_bathy_interp(tf_var, il_rho(:), id_offset(:,:)) + + !- remove extraband added to domain + CALL dom_del_extra( tf_var, tl_dom, il_rho(:) ) + + CALL dom_clean_extra( tl_dom ) + + !- add ghost cell + CALL grid_add_ghost(tf_var,tl_dom%i_ghost(:,:)) + + !- add attribute to variable + tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('src_i_indices',(/tl_dom%i_imin, tl_dom%i_imax/)) + CALL var_move_att(tf_var, tl_att) + + tl_att=att_init('src_j_indices',(/tl_dom%i_jmin, tl_dom%i_jmax/)) + CALL var_move_att(tf_var, tl_att) + + IF( .NOT. ALL(id_rho(:)==1) )THEN + tl_att=att_init("refinment_factor",(/id_rho(jp_I),id_rho(jp_J)/)) + CALL var_move_att(tf_var, tl_att) + ENDIF + + DEALLOCATE( il_rho ) + + !- clean structure + CALL att_clean(tl_att) + CALL mpp_clean(tl_mpp) + + END FUNCTION create_bathy_get_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_bathy_interp(td_var, id_rho, id_offset, & + & id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] id_rho array of refinment factor + !> @param[in] id_offset array of offset between fine and coarse grid + !> @param[in] id_iext i-direction size of extra bands (default=im_minext) + !> @param[in] id_jext j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + ! local variable + TYPE(TVAR) :: tl_mask + + INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask + + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + + ! loop indices + !---------------------------------------------------------------- + + !WARNING: two extrabands are required for cubic interpolation + il_iext=3 + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=3 + IF( PRESENT(id_jext) ) il_jext=id_jext + + IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE BATHY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_iext=2 + ENDIF + + IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE BATHY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_jext=2 + ENDIF + + ! work on mask + ! create mask + ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + bl_mask(:,:,:,:)=1 + WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0 + + SELECT CASE(TRIM(td_var%c_point)) + CASE DEFAULT ! 'T' + tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=td_var%t_dim(:), & + & id_ew=td_var%i_ew ) + CASE('U','V','F') + CALL logger_fatal("CREATE BATHY INTERP: can not computed "//& + & "interpolation on "//TRIM(td_var%c_point)//& + & " grid point (variable "//TRIM(td_var%c_name)//& + & "). check namelist.") + END SELECT + + DEALLOCATE(bl_mask) + + ! interpolate mask + CALL interp_fill_value( tl_mask, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! work on variable + ! add extraband + CALL extrap_add_extrabands(td_var, il_iext, il_jext) + + ! extrapolate variable + CALL extrap_fill_value( td_var ) + + ! interpolate Bathymetry + CALL interp_fill_value( td_var, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! remove extraband + CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) + + ! keep original mask + WHERE( tl_mask%d_value(:,:,:,:) == 0 ) + td_var%d_value(:,:,:,:)=td_var%d_fill + END WHERE + + ! clean variable structure + CALL var_clean(tl_mask) + + END SUBROUTINE create_bathy_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_bathy_check_depth(td_mpp, td_depth) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get depth variable value in an open mpp structure + !> and check if agree with already input depth variable. + !> + !> @details + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_depth depth variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN ) :: td_mpp + TYPE(TVAR) , INTENT(INOUT) :: td_depth + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_depth + ! loop indices + !---------------------------------------------------------------- + + ! get or check depth value + IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_depthid + IF( ASSOCIATED(td_depth%d_value) )THEN + + tl_depth=iom_mpp_read_var(td_mpp, il_varid) + + IF( ANY( td_depth%d_value(:,:,:,:) /= & + & tl_depth%d_value(:,:,:,:) ) )THEN + + CALL logger_warn("CREATE BATHY: depth value from "//& + & TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_depth) + + ELSE + td_depth=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + + END SUBROUTINE create_bathy_check_depth + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_bathy_check_time(td_mpp, td_time) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get date and time in an open mpp structure + !> and check if agree with date and time already read. + !> + !> @details + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_time time variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN ) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_time + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_time + + TYPE(TDATE) :: tl_date1 + TYPE(TDATE) :: tl_date2 + ! loop indices + !---------------------------------------------------------------- + + ! get or check depth value + IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_timeid + IF( ASSOCIATED(td_time%d_value) )THEN + + tl_time=iom_mpp_read_var(td_mpp, il_varid) + + tl_date1=var_to_date(td_time) + tl_date2=var_to_date(tl_time) + IF( tl_date1 - tl_date2 /= 0 )THEN + + CALL logger_warn("CREATE BATHY: date from "//& + & TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_time) + + ELSE + td_time=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + + END SUBROUTINE create_bathy_check_time + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM create_bathy diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_boundary.F90 b/V4.0/nemo_sources/tools/SIREN/src/create_boundary.F90 new file mode 100644 index 0000000000000000000000000000000000000000..bf3dee81c28cea14f6a54cb0af5819d2f96c9cd5 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_boundary.F90 @@ -0,0 +1,2178 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> This program creates boundary files. +!> +!> @details +!> @section sec1 method +!> Variables are read from coarse grid standard output, +!> extracted or interpolated on fine grid. +!> Variables could also be manually written.<br/> +!> @note +!> method could be different for each variable. +!> +!> <br/> +!> @image html boundary_NEATL36_70.png +!> <center>@image latex boundary_NEATL36_70.png +!> </center> +!> +!> @section sec2 how to +!> USAGE: create_boundary create_bounary.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_boundary.nam<br/> +!> namelist of create_boundary +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_boundary +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit)<br/> +!> @note +!> compiled with @a key_mpp_mpi, could be run on multi processor :<br/> +!> USAGE: create_boundary create_bounary.nam create_bounary2.nam ... [-v] [-h]<br/> +!> +!> @section sec_boundary create_boundary.nam +!> create_boundary.nam contains 9 namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source/coarse grid parameters +!> - **namtgt** to set target/fine grid parameters +!> - **namvar** to set variable parameters +!> - **namnst** to set sub domain and nesting paramters +!> - **nambdy** to set boundary parameters +!> - **namzgr** to set vertical grid parameters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_boundary.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subcrs namcrs +!> the coarse grid sub-namelist parameters are : +!> +!> - **cn_coord0** [@a ]<br/> +!> path to the coordinate file +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subfin namfin +!> the fine grid sub-namelist parameters are : +!> +!> - **cn_coord1** [@a ]<br/> +!> path to coordinate file +!> +!> - **cn_bathy1** [@a ]<br/> +!> path to bathymetry file +!> @warning +!> +!> - **in_perio1** [@a ]<br/> +!> NEMO periodicity index (see above) +!> @note if the fine/target coordinates file (cn_coord1) was created by SIREN, you do +!> not need to fill this parameter. SIREN will read it on the global attributes of +!> the coordinates file. +!> +!> @subsection subzgr namzgr +!> the vertical grid sub-namelist parameters are : +!> +!> - **dn_pp_to_be_computed** [@a 0]<br/> +!> +!> - **dn_ppsur** [@a -3958.951371276829]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa0** [@a 103.953009600000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa1** [@a 2.415951269000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa2** [@a 100.760928500000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppkth** [@a 15.351013700000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppkth2** [@a 48.029893720000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppacr** [@a 7.000000000000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppacr2** [@a 13.000000000000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppdzmin** [@a 6.]<br/> +!> minimum vertical spacing +!> +!> - **dn_pphmax** [@a 5750.]<br/> +!> maximum depth +!> +!> - **in_nlevel** [@a 75]<br/> +!> number of vertical level +!> +!> @note +!> If *dn_ppa1*, *dn_ppa0* and *dn_ppsur* are undefined, +!> NEMO will compute them from *dn_ppdzmin, dn_pphmax, dn_ppkth, dn_ppacr* +!> +!> @subsection subzps namzps +!> the partial step sub-namelist parameters are : +!> +!> - **dn_e3zps_min** [@a 25.]<br/> +!> minimum thickness of partial step level (meters) +!> - **dn_e3zps_rat** [@a 0.2]<br/> +!> minimum thickness ratio of partial step level +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varfile** [@a ]<br/> +!> list of variable, and associated file +!> +!> *cn_varfile* is the path and filename of the file where find +!> variable. +!> @note +!> *cn_varfile* could be a matrix of value, if you want to handwrite +!> variable value.<br/> +!> the variable array of value is split into equal subdomain.<br/> +!> each subdomain is filled with the corresponding value +!> of the matrix.<br/> +!> separators used to defined matrix are: +!> - ',' for line +!> - '/' for row +!> - '\' for level<br/> +!> Example:<br/> +!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} +!> 3 & 2 & 3 \\ +!> 1 & 4 & 5 \end{array} \right) @f$ +!> +!> @warning +!> the same matrix is used for all boundaries. +!> +!> Examples: +!> - 'votemper:gridT.nc', 'vozocrtx:gridU.nc' +!> - 'votemper:10\25', 'vozocrtx:gridU.nc'<br/> +!> +!> @note +!> Optionnaly, NEMO periodicity could be added following the filename. +!> the periodicity must be separated by ';' +!> +!> Example: +!> - 'votemper:gridT.nc ; perio=4' +!> +!> - **cn_varinfo** [@a ]<br/> +!> list of variable and extra information about request(s) to be used<br/> +!> +!> each elements of *cn_varinfo* is a string character (separated by ',').<br/> +!> it is composed of the variable name follow by ':', +!> then request(s) to be used on this variable.<br/> +!> request could be: +!> - int = interpolation method +!> - ext = extrapolation method +!> - flt = filter method +!> - min = minimum value +!> - max = maximum value +!> - unt = new units +!> - unf = unit scale factor (linked to new units) +!> +!> requests must be separated by ';'.<br/> +!> order of requests does not matter.<br/> +!> +!> informations about available method could be find in @ref interp, +!> @ref extrap and @ref filter modules.<br/> +!> Example: +!> - 'votemper: int=linear; flt=hann; ext=dist_weight', +!> 'vosaline: int=cubic' +!> +!> @note +!> If you do not specify a method which is required, +!> default one is apply. +!> +!> @subsection subnst namnst +!> the nesting sub-namelist parameters are : +!> +!> - **in_rhoi** [@a 1]<br/> +!> refinement factor in i-direction +!> +!> - **in_rhoj** [@a 1]<br/> +!> refinement factor in j-direction +!> +!> @note +!> coarse grid indices will be deduced from fine grid +!> coordinate file. +!> +!> @subsection subbdy nambdy +!> the boundary sub-namelist parameters are : +!> +!> - **ln_north** [@a .TRUE.]<br/> +!> logical to use north boundary or not +!> - **ln_south** [@a .TRUE.]<br/> +!> logical to use south boundary or not +!> - **ln_east** [@a .TRUE.]<br/> +!> logical to use east boundary or not +!> - **ln_west** [@a .TRUE.]<br/> +!> logical to use west boundary or not +!> <br/> <br/> +!> - **cn_north** [@a ]<br/> +!> north boundary indices on fine grid<br/> +!> - **cn_south** [@a ]<br/> +!> south boundary indices on fine grid<br/> +!> - **cn_east** [@a ]<br/> +!> east boundary indices on fine grid<br/> +!> - **cn_west** [@a ]<br/> +!> west boundary indices on fine grid<br/> +!> +!> *cn_north* is a string character defining boundary +!> segmentation.<br/> +!> segments are separated by '|'.<br/> +!> each segments of the boundary is composed of: +!> - indice of velocity (orthogonal to boundary .ie. +!> for north boundary, J-indice). +!> - indice of segment start (I-indice for north boundary) +!> - indice of segment end (I-indice for north boundary)<br/> +!> indices must be separated by ':' .<br/> +!> - optionally, boundary size could be added between '(' and ')' +!> in the first segment defined. +!> @note +!> boundary size is the same for all segments of one boundary. +!> +!> Examples: +!> - cn_north='index1,first1:last1(width)' +!> - cn_north='index1(width),first1:last1|index2,first2:last2' +!> +!> @image html boundary_50.png +!> <center>@image latex boundary_50.png +!> </center> +!> +!> - **ln_oneseg** [@a .TRUE.]<br/> +!> logical to use only one segment for each boundary or not +!> +!> @note +!> the number of point(s) with coarse value save at boundaries is +!> defined with the *weight* variable (see @ref merge_bathy) +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a boundary.nc]<br/> +!> output bathymetry filename +!> +!> @note +!> cardinal point and segment number will be automatically added +!> +!> - **ln_extrap** [@a .FALSE.]<br/> +!> extrapolate on land point +!> +!> - **dn_dayofs** [@a 0]<br/> +!> date offset in day (change only ouput file name) +!> +!> Examples: +!> - cn_fileout='boundary.nc'<br/> +!> if time_counter (16/07/2015 00h) is read on input file (see varfile), +!> west boundary will be named boundary_west_y2015m07d16 +!> - dn_dayofs=-2.<br/> +!> if you use day offset you get boundary_west_y2015m07d14 +!> +!> @subsection sub_nambdy How to fill Lateral Boundary Condition in NEMO namelist +!> To use boundary condition within NEMO, you need to fill the NEMO namelist.<br/> +!> As this is a little bit messy for lateral boundary condition, here after +!> is an explanation of how to do it. +!> +!> This will be done in 3 steps. +!> +!> @subsubsection ss_nambdy nambdy +!> The *nambdy* NEMO sub-namelist defines open boundaries.<br/> +!> Here we indicate the number of open boundary (**nb_bdy**). +!> +!> @note +!> we have to fill most of the parameters with as many elements as there are open boundaries +!> +!> Regarding the width of the relaxation zone **nn_rimwidth**, +!> this information is available as a global attribute (**bdy_width**) +!> in the metadata of boundary files created with SIREN +!> +!> @code{.sh} +!> ncdump -h boundary_east.nc +!> @endcode +!> @warning +!> The order of the boundaries must stay unchanged, in parameters list as well as +!> in the next sub-namelsits +!> +!> Example:<br/> +!> here is an example for a domain with two boundaries East and North +!> +!> @code{.sh} +!> !----------------------------------------------------------------------- +!> &nambdy ! unstructured open boundaries ("key_bdy") +!> !----------------------------------------------------------------------- +!> nb_bdy = 2 ! number of open boundary sets +!> ln_coords_file = .false.,.false. ! =T : read bdy coordinates from file +!> cn_coords_file = '','' ! 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 = 'flather','flather' ! +!> nn_dyn2d_dta = 1,1 ! = 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 = 'specified','specified' ! +!> nn_dyn3d_dta = 1,1 ! = 0, bdy data are equal to the initial state +!> ! = 1, bdy data are read in 'bdydata .nc' files +!> cn_tra = 'specified','specified' ! +!> nn_tra_dta = 1,1 ! = 0, bdy data are equal to the initial state +!> ! = 1, bdy data are read in 'bdydata .nc' files +!> ! +!> ln_tra_dmp =.true.,.true. ! open boudaries conditions for tracers +!> ln_dyn3d_dmp =.true.,.true. ! open boundary condition for baroclinic velocities +!> rn_time_dmp = 1.,1. ! Damping time scale in days +!> rn_time_dmp_out = 1.,1. ! Outflow damping time scale +!> nn_rimwidth = 10,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 +!> / +!> @endcode +!> +!> @subsubsection ss_nambdy_index nambdy_index +!> The *nambdy_index* NEMO sub-namelist describes the boundaries we will use. +!> +!> @warning +!> We have to add as many as sub namelist *nambdy_index* than open boundaries (nb_bdy), +!> and keep them in the same order as above +!> +!> Here we indicate if the open boundary is North, South, East, or West (**ctypebdy**).<br/> +!> We also indicate indice of segment start and end (respectively **nbdybeg** and **nbdyend**) +!> as well as indice of velocity row or column (**nbdyind**).<br/> +!> +!> Those informations are available as global attributes +!> (respectively **bdy_deb, bdy_end, bdy_ind**) in the metadata of our boundary files +!> created with SIREN. +!> +!> Example:<br/> +!> here is an example for a domain with two boundaries East and North +!> +!> @code{.sh} +!> !----------------------------------------------------------------------- +!> &nambdy_index ! structured open boundaries definition ("key_bdy") +!> !----------------------------------------------------------------------- +!> ctypebdy ='E' ! Open boundary type (W,E,S or N) +!> nbdyind = 407 ! indice of velocity row or column +!> ! if ==-1, set obc at the domain boundary +!> ! , discard start and end indices +!> nbdybeg = 32 ! indice of segment start +!> nbdyend = 300 ! indice of segment end +!> / +!> !----------------------------------------------------------------------- +!> &nambdy_index ! structured open boundaries definition ("key_bdy") +!> !----------------------------------------------------------------------- +!> ctypebdy ='N' ! Open boundary type (W,E,S or N) +!> nbdyind = 299 ! indice of velocity row or column +!> ! if ==-1, set obc at the domain boundary +!> ! , discard start and end indices +!> nbdybeg = 200 ! indice of segment start +!> nbdyend = 408 ! indice of segment end +!> / +!> @endcode +!> +!> @subsubsection ss_nambdy_dat nambdy_dta +!> The *nambdy_dta* NEMO sub-namelists describes the boundary data and files to be used.<br/> +!> @warning +!> We have to add as many as sub namelist *nambdy_dta* than open boundaries (nb_bdy), +!> and keep them in the same order as above +!> +!> Example:<br/> +!> here is an example for a domain with two boundaries East and North +!> +!> @code{.sh} +!> !----------------------------------------------------------------------- +!> &nambdy_dta ! open boundaries - external data ("key_bdy") +!> !----------------------------------------------------------------------- +!> ! ! file name ! freq (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights... +!> ! ! ! (if < 0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename +!> bn_ssh = 'boundary_east' , -12 , 'sossheig' , .false. , .true. , 'yearly' , '', '', '' +!> bn_u2d = 'boundary_east' , -12 , 'vobtcrtx' , .false. , .true. , 'yearly' , '', '', '' +!> bn_v2d = 'boundary_east' , -12 , 'vobtcrty' , .false. , .true. , 'yearly' , '', '', '' +!> bn_u3d = 'boundary_east' , -12 , 'vozocrtx' , .false. , .true. , 'yearly' , '', '', '' +!> bn_v3d = 'boundary_east' , -12 , 'vomecrty' , .false. , .true. , 'yearly' , '', '', '' +!> bn_tem = 'boundary_east' , -12 , 'votemper' , .false. , .true. , 'yearly' , '', '', '' +!> bn_sal = 'boundary_east' , -12 , 'vosaline' , .false. , .true. , 'yearly' , '', '', '' +!> cn_dir = './' +!> ln_full_vel = .true. +!> / +!> !----------------------------------------------------------------------- +!> &nambdy_dta ! open boundaries - external data ("key_bdy") +!> !----------------------------------------------------------------------- +!> ! ! file name ! freq (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights... +!> ! ! ! (if < 0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename +!> bn_ssh = 'boundary_north' , -12 , 'sossheig' , .false. , .true. , 'yearly' , '', '', '' +!> bn_u2d = 'boundary_north' , -12 , 'vobtcrtx' , .false. , .true. , 'yearly' , '', '', '' +!> bn_v2d = 'boundary_north' , -12 , 'vobtcrty' , .false. , .true. , 'yearly' , '', '', '' +!> bn_u3d = 'boundary_north' , -12 , 'vozocrtx' , .false. , .true. , 'yearly' , '', '', '' +!> bn_v3d = 'boundary_north' , -12 , 'vomecrty' , .false. , .true. , 'yearly' , '', '', '' +!> bn_tem = 'boundary_north' , -12 , 'votemper' , .false. , .true. , 'yearly' , '', '', '' +!> bn_sal = 'boundary_north' , -12 , 'vosaline' , .false. , .true. , 'yearly' , '', '', '' +!> cn_dir = './' +!> ln_full_vel = .true. +!> / +!> @endcode +!> +!> <hr> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header for user +!> - take into account grid point to compue boundaries +!> - reorder output dimension for north and south boundaries +!> @date June, 2015 +!> - extrapolate all land points, and add ln_extrap in namelist. +!> - allow to change unit. +!> @date July, 2015 +!> - add namelist parameter to shift date of output file name. +!> @date September, 2015 +!> - manage useless (dummy) variable, attributes, and dimension +!> - allow to run on multi processors with key_mpp_mpi +!> @date January, 2016 +!> - same process use for variable extracted or interpolated from input file. +!> @date October, 2016 +!> - dimension to be used select from configuration file +!> @date January, 2019 +!> - add url path to global attributes of output file(s) +!> - create and clean file structure to avoid memory leaks +!> - explain how to fill Lateral Boundary Condition in NEMO namelist +!> @date February, 2019 +!> - rename sub namelist namcrs to namsrc +!> - rename sub namelist namfin to namtgt +!> @date August, 2019 +!> - use periodicity read from namelist, and store in multi structure +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @todo +!> - rewitre using meshmask instead of bathymetry and coordinates files. +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_boundary + + USE netcdf ! nf90 library + USE global ! global variable + USE phycst ! physical constant + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE multi ! multi file manager + USE boundary ! boundary manager + USE iom ! I/O manager + USE dom ! domain manager + USE grid ! grid manager + USE vgrid ! vertical grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE iom_mpp ! MPP I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_boundary" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i4) :: il_narg + +#if defined key_mpp_mpi + ! mpp variable + CHARACTER(LEN=lc), DIMENSION(:) , ALLOCATABLE :: cl_args + + INTEGER(i4) :: ierror + INTEGER(i4) :: iproc + INTEGER(i4) :: nproc + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_nprog + + ! loop indices + INTEGER(i4) :: jm +#else + CHARACTER(LEN=lc) :: cl_namelist +#endif + !------------------------------------------------------------------- +#if defined key_mpp_mpi + INCLUDE 'mpif.h' +#endif + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + +#if ! defined key_mpp_mpi + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec + CALL create_boundary__mono(cl_namelist) + + END SELECT + ENDIF +#else + + ! Initialize MPI + CALL mpi_init(ierror) + CALL mpi_comm_rank(mpi_comm_world,iproc,ierror) + CALL mpi_comm_size(mpi_comm_world,nproc,ierror) + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg == 0 )THEN + WRITE(cl_errormsg,*) ' ERROR : at least one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + ALLOCATE(cl_args(il_narg)) + DO jm=1,il_narg + + CALL GET_COMMAND_ARGUMENT(jm,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_args(jm)=TRIM(cl_arg) + + END SELECT + ENDDO + ENDIF + + ALLOCATE(il_nprog(il_narg)) + DO jm=1, il_narg + il_nprog(jm)= MOD(jm,nproc) + ENDDO + + DO jm=1, il_narg + IF ( il_nprog(jm) .eq. iproc ) THEN + CALL create_boundary__mono(cl_args(jm)) + ENDIF + ENDDO + + CALL mpi_finalize(ierror) + + DEALLOCATE(cl_args) + DEALLOCATE(il_nprog) +#endif + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary__mono(cd_namelist) + !------------------------------------------------------------------- + !> @brief + !> This subroutine create boundary files. + !> + !> @details + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !> + !> @param[in] cd_namelist namelist file + !------------------------------------------------------------------- + + USE logger ! log file manager + + IMPLICIT NONE + ! Argument + CHARACTER(LEN=lc), INTENT(IN) :: cd_namelist + + ! local variable + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_bdyout + CHARACTER(LEN=lc) :: cl_data + CHARACTER(LEN=lc) :: cl_dimorder + CHARACTER(LEN=lc) :: cl_fmt + CHARACTER(LEN=lc) :: cl_url + + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_shift + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho + INTEGER(i4) , DIMENSION(2,2) :: il_offset + INTEGER(i4) , DIMENSION(2,2) :: il_ind + + LOGICAL :: ll_exist + + TYPE(TATT) :: tl_att + + TYPE(TVAR) :: tl_depth + TYPE(TVAR) :: tl_time + TYPE(TVAR) :: tl_var1 + TYPE(TVAR) :: tl_var0 + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + TYPE(TVAR) :: tl_lvl1 + TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level + TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_seglvl1 + TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segvar1 + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TDATE) :: tl_date + + TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy + + TYPE(TDOM) :: tl_dom0 + TYPE(TDOM) :: tl_dom1 + TYPE(TDOM) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segdom1 + + TYPE(TFILE) :: tl_file + TYPE(TFILE) :: tl_fileout + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + TYPE(TMPP) :: tl_bathy1 + TYPE(TMPP) :: tl_mpp + + TYPE(TMULTI) :: tl_multi + + ! loop indices + INTEGER(i4) :: jvar + INTEGER(i4) :: jpoint + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_coord0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namtgt + CHARACTER(LEN=lc) :: cn_coord1 = '' + CHARACTER(LEN=lc) :: cn_bathy1 = '' + INTEGER(i4) :: in_perio1 = -1 + + !namzgr + REAL(dp) :: dn_pp_to_be_computed = 0._dp + REAL(dp) :: dn_ppsur = -3958.951371276829_dp + REAL(dp) :: dn_ppa0 = 103.953009600000_dp + REAL(dp) :: dn_ppa1 = 2.415951269000_dp + REAL(dp) :: dn_ppa2 = 100.760928500000_dp + REAL(dp) :: dn_ppkth = 15.351013700000_dp + REAL(dp) :: dn_ppkth2 = 48.029893720000_dp + REAL(dp) :: dn_ppacr = 7.000000000000_dp + REAL(dp) :: dn_ppacr2 = 13.000000000000_dp + REAL(dp) :: dn_ppdzmin = 6._dp + REAL(dp) :: dn_pphmax = 5750._dp + INTEGER(i4) :: in_nlevel = 75 + + !namzps + REAL(dp) :: dn_e3zps_min = 25._dp + REAL(dp) :: dn_e3zps_rat = 0.2_dp + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + + ! namnst + INTEGER(i4) :: in_rhoi = 1 + INTEGER(i4) :: in_rhoj = 1 + + ! nambdy + LOGICAL :: ln_north = .TRUE. + LOGICAL :: ln_south = .TRUE. + LOGICAL :: ln_east = .TRUE. + LOGICAL :: ln_west = .TRUE. + LOGICAL :: ln_oneseg = .TRUE. + CHARACTER(LEN=lc) :: cn_north = '' + CHARACTER(LEN=lc) :: cn_south = '' + CHARACTER(LEN=lc) :: cn_east = '' + CHARACTER(LEN=lc) :: cn_west = '' + + ! namout + CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc' + REAL(dp) :: dn_dayofs = 0._dp + LOGICAL :: ln_extrap = .FALSE. + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_coord0, & !< coordinate file + & in_perio0 !< periodicity index + + NAMELIST /namtgt/ & !< target/fine grid namelist + & cn_coord1, & !< coordinate file + & cn_bathy1, & !< bathymetry file + & in_perio1 !< periodicity index + + NAMELIST /namzgr/ & + & dn_pp_to_be_computed, & + & dn_ppsur, & + & dn_ppa0, & + & dn_ppa1, & + & dn_ppa2, & + & dn_ppkth, & + & dn_ppkth2, & + & dn_ppacr, & + & dn_ppacr2, & + & dn_ppdzmin, & + & dn_pphmax, & + & in_nlevel !< number of vertical level + + NAMELIST /namzps/ & + & dn_e3zps_min, & + & dn_e3zps_rat + + NAMELIST /namvar/ & !< variable namelist + & cn_varfile, & !< list of variable and file where find it. (ex: 'votemper:GLORYS_gridT.nc' ) + & cn_varinfo !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' ) + + NAMELIST /namnst/ & !< nesting namelist + & in_rhoi, & !< refinement factor in i-direction + & in_rhoj !< refinement factor in j-direction + + NAMELIST /nambdy/ & !< boundary namelist + & ln_north, & !< use north boundary + & ln_south, & !< use south boundary + & ln_east , & !< use east boundary + & ln_west , & !< use west boundary + & cn_north, & !< north boundary indices on fine grid + & cn_south, & !< south boundary indices on fine grid + & cn_east , & !< east boundary indices on fine grid + & cn_west , & !< west boundary indices on fine grid + & ln_oneseg !< use only one segment for each boundary or not + + NAMELIST /namout/ & !< output namelist + & cn_fileout, & !< fine grid boundary file basename + & dn_dayofs, & !< date offset in day (change only ouput file name) + & ln_extrap !< extrapolate or not + !------------------------------------------------------------------- + + ! read namelist + INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist) + + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + PRINT *,"CREATE BOUNDARY: ERROR opening "//TRIM(cd_namelist) + STOP + ENDIF + + READ( il_fileid, NML = namlog ) + ! define log file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namtgt ) + READ( il_fileid, NML = namzgr ) + READ( il_fileid, NML = namvar ) + ! add user change in extra information + CALL var_chg_extra(cn_varinfo) + ! match variable with file + tl_multi=multi_init(cn_varfile) + + READ( il_fileid, NML = namnst ) + READ( il_fileid, NML = nambdy ) + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE BOUNDARY: ERROR closing "//TRIM(cd_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cd_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + CALL multi_print(tl_multi) + + IF( tl_multi%i_nvar <= 0 )THEN + CALL logger_fatal("CREATE BOUNDARY: no variable to be used."//& + & " check namelist.") + ENDIF + + ! open files + IF( TRIM(cn_coord0) /= '' )THEN + tl_file= file_init(TRIM(cn_coord0)) + tl_coord0=mpp_init( tl_file, id_perio=in_perio0) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord0) + ELSE + CALL logger_fatal("CREATE BOUNDARY: can not find coarse grid "//& + & "coordinate file. check namelist") + ENDIF + + IF( TRIM(cn_coord1) /= '' )THEN + tl_file=file_init(TRIM(cn_coord1)) + tl_coord1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord1) + ELSE + CALL logger_fatal("CREATE BOUNDARY: can not find fine grid coordinate "//& + & "file. check namelist") + ENDIF + + IF( TRIM(cn_bathy1) /= '' )THEN + tl_file=file_init(TRIM(cn_bathy1)) + tl_bathy1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_bathy1) + ELSE + CALL logger_fatal("CREATE BOUNDARY: can not find fine grid bathymetry "//& + & "file. check namelist") + ENDIF + + ! check + ! check output file do not already exist + ! WARNING: do not work when use time to create output file name + DO jk=1,ip_ncard + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(cp_card(jk)), 1 ) + INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//& + & " already exist.") + ENDIF + + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(cp_card(jk)) ) + INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//& + & " already exist.") + ENDIF + ENDDO + + ! check namelist + ! check refinement factor + il_rho(:)=1 + IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN + CALL logger_error("CREATE BOUNDARY: invalid refinement factor."//& + & " check namelist "//TRIM(cd_namelist)) + ELSE + il_rho(jp_I)=in_rhoi + il_rho(jp_J)=in_rhoj + ENDIF + + ! + ! compute coarse grid indices around fine grid + il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, & + & id_rho=il_rho(:)) + + il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2) + il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2) + + ! check domain validity + CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0) + + ! check coordinate file + CALL grid_check_coincidence( tl_coord0, tl_coord1, & + & il_imin0, il_imax0, & + & il_jmin0, il_jmax0, & + & il_rho(:) ) + + ! read or compute boundary + CALL mpp_get_contour(tl_bathy1) + + CALL iom_mpp_open(tl_bathy1) + + tl_var1=iom_mpp_read_var(tl_bathy1,'Bathymetry') + + CALL iom_mpp_close(tl_bathy1) + + ! get boundaries indices + tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, & + & cn_north, cn_south, cn_east, cn_west, & + & ln_oneseg ) + + + CALL var_clean(tl_var1) + + ! compute level + ALLOCATE(tl_level(ip_npoint)) + tl_level(:)=vgrid_get_level(tl_bathy1, cd_namelist ) + + ! get coordinate for each segment of each boundary + ALLOCATE( tl_segdom1(ip_npoint,ip_maxseg,ip_ncard) ) + ALLOCATE( tl_seglvl1(ip_npoint,ip_maxseg,ip_ncard) ) + + DO jl=1,ip_ncard + IF( tl_bdy(jl)%l_use )THEN + DO jk=1,tl_bdy(jl)%i_nseg + + ! get fine grid segment domain + tl_segdom1(:,jk,jl)=create_boundary_get_dom( tl_bathy1, & + & tl_bdy(jl), jk ) + + IF( .NOT. ln_extrap )THEN + ! get fine grid level + tl_seglvl1(:,jk,jl)= & + & create_boundary_get_level( tl_level(:), & + & tl_segdom1(:,jk,jl)) + ENDIF + + ! add extra band to fine grid domain (if possible) + ! to avoid dimension of one and so be able to compute offset + DO jj=1,ip_npoint + CALL dom_add_extra(tl_segdom1(jj,jk,jl), & + & il_rho(jp_I), il_rho(jp_J)) + ENDDO + + ENDDO + ENDIF + ENDDO + + ! clean + CALL var_clean(tl_level(:)) + DEALLOCATE(tl_level) + + ! clean bathy + CALL mpp_clean(tl_bathy1) + + ALLOCATE( tl_segvar1(tl_multi%i_nvar,ip_maxseg,ip_ncard) ) + ! compute boundary for variable to be used (see namelist) + IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN + CALL logger_error("CREATE BOUNDARY: no file to work on. "//& + & "check cn_varfile in namelist.") + ELSE + + jvar=0 + ! for each file + DO ji=1,tl_multi%i_nmpp + + WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1 + IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN + + CALL logger_error("CREATE BOUNDARY: no variable to work on for "//& + & "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//& + & ". check cn_varfile in namelist.") + + ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN + !- use input matrix to fill variable + + WRITE(*,'(a)') "work on data" + ! for each variable initialise from matrix + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + jvar=jvar+1 + WRITE(*,'(2x,a,a)') "work on variable "//& + & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + + tl_var1=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + + SELECT CASE(TRIM(tl_var1%c_point)) + CASE DEFAULT !'T' + jpoint=jp_T + CASE('U') + jpoint=jp_U + CASE('V') + jpoint=jp_V + CASE('F') + jpoint=jp_F + END SELECT + + WRITE(*,'(4x,a,a)') 'work on '//TRIM(tl_var1%c_name) + DO jl=1,ip_ncard + IF( tl_bdy(jl)%l_use )THEN + + DO jk=1,tl_bdy(jl)%i_nseg + + ! fill value with matrix data + tl_segvar1(jvar,jk,jl)=create_boundary_matrix( & + & tl_var1, & + & tl_segdom1(jpoint,jk,jl), & + & in_nlevel ) + + !del extra + CALL dom_del_extra( tl_segvar1(jvar,jk,jl), & + & tl_segdom1(jpoint,jk,jl) ) + + ENDDO + + ENDIF + ENDDO + + ! clean + CALL var_clean(tl_var1) + + ENDDO + + !- end of use input matrix to fill variable + ELSE + !- use mpp file to fill variable + + WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name) + ! + tl_file=file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name), & + & id_perio=tl_multi%t_mpp(ji)%i_perio) + tl_mpp=mpp_init( tl_file ) + !tl_mpp=mpp_init( tl_file, id_perio=tl_multi%t_mpp(ji)%t_proc(1)%i_perio) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_mpp) + + DO jl=1,ip_ncard + IF( tl_bdy(jl)%l_use )THEN + + WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//& + & ' boundary' + DO jk=1,tl_bdy(jl)%i_nseg + + ! for each variable of this file + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + WRITE(*,'(4x,a,a)') "work on variable "//& + & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + + tl_var0=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)) + + ! open mpp file + CALL iom_mpp_open(tl_mpp) + + ! get or check depth value + CALL create_boundary_check_depth( tl_var0, tl_mpp, & + & in_nlevel, tl_depth ) + + ! get or check time value + CALL create_boundary_check_time( tl_var0, tl_mpp, & + & tl_time ) + + ! close mpp file + CALL iom_mpp_close(tl_mpp) + + ! open mpp file on domain + SELECT CASE(TRIM(tl_var0%c_point)) + CASE DEFAULT !'T' + jpoint=jp_T + CASE('U') + jpoint=jp_U + CASE('V') + jpoint=jp_V + CASE('F') + jpoint=jp_F + END SELECT + + tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl)) + + CALL create_boundary_get_coord( tl_coord1, tl_dom1, & + & tl_var0%c_point, & + & tl_lon1, tl_lat1 ) + + ! get coarse grid indices of this segment + il_ind(:,:)=grid_get_coarse_index(tl_coord0, & + & tl_lon1, tl_lat1, & + & id_rho=il_rho(:) ) + + IF( ANY(il_ind(:,:)==0) )THEN + CALL logger_error("CREATE BOUNDARY: error "//& + & "computing coarse grid indices") + ELSE + il_imin0=il_ind(1,1) + il_imax0=il_ind(1,2) + + il_jmin0=il_ind(2,1) + il_jmax0=il_ind(2,2) + ENDIF + + il_offset(:,:)= grid_get_fine_offset( & + & tl_coord0, & + & il_imin0, il_jmin0,& + & il_imax0, il_jmax0,& + & tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & il_rho(:),& + & TRIM(tl_var0%c_point) ) + + ! compute coarse grid segment domain + tl_dom0=dom_init( tl_coord0, & + & il_imin0, il_imax0,& + & il_jmin0, il_jmax0 ) + + ! add extra band (if possible) to compute interpolation + CALL dom_add_extra(tl_dom0) + + ! open mpp files + CALL iom_dom_open(tl_mpp, tl_dom0) + + cl_name=tl_var0%c_name + ! read variable value on domain + tl_segvar1(jvar+jj,jk,jl)= & + & iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0) + + IF( ANY(il_rho(:)/=1) )THEN + WRITE(*,'(4x,a,a)') "interp variable "//TRIM(cl_name) + ! work on variable + CALL create_boundary_interp( & + & tl_segvar1(jvar+jj,jk,jl),& + & il_rho(:), il_offset(:,:) ) + ENDIF + + ! remove extraband added to domain + CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & + & tl_dom0, il_rho(:) ) + + ! del extra point on fine grid + CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & + & tl_dom1 ) + + ! clean extra point information on coarse grid domain + CALL dom_clean_extra( tl_dom0 ) + + ! add attribute to variable + tl_att=att_init('src_file',& + & TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), & + & tl_att) + + ! + tl_att=att_init('src_i_indices',& + & (/tl_dom0%i_imin, tl_dom0%i_imax/)) + CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), & + & tl_att) + + tl_att=att_init('src_j_indices', & + & (/tl_dom0%i_jmin, tl_dom0%i_jmax/)) + CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), & + & tl_att) + + IF( ANY(il_rho(:)/=1) )THEN + tl_att=att_init("refinment_factor", & + & (/il_rho(jp_I),il_rho(jp_J)/)) + CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), & + & tl_att) + ENDIF + + ! clean structure + CALL att_clean(tl_att) + + ! clean + CALL dom_clean(tl_dom0) + CALL dom_clean(tl_dom1) + + ! close mpp files + CALL iom_dom_close(tl_mpp) + + ! clean structure + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + CALL var_clean(tl_lvl1) + + ENDDO ! jj + + ! clean + CALL var_clean(tl_var0) + + ENDDO ! jk + + ENDIF + ENDDO ! jl + + jvar=jvar+tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + ! clean + CALL mpp_clean(tl_mpp) + + !- end of use file to fill variable + ENDIF + ENDDO ! ji + ENDIF + + IF( jvar /= tl_multi%i_nvar )THEN + CALL logger_error("CREATE BOUNDARY: it seems some variable "//& + & "can not be read") + ENDIF + + ! write file for each segment of each boundary + DO jl=1,ip_ncard + IF( tl_bdy(jl)%l_use )THEN + + DO jk=1,tl_bdy(jl)%i_nseg + !- + CALL create_boundary_get_coord( tl_coord1, tl_segdom1(jp_T,jk,jl),& + & 'T', tl_lon1, tl_lat1 ) + + ! force to use nav_lon, nav_lat as variable name + tl_lon1%c_name='nav_lon' + tl_lat1%c_name='nav_lat' + + ! del extra point on fine grid + CALL dom_del_extra( tl_lon1, tl_segdom1(jp_T,jk,jl) ) + CALL dom_del_extra( tl_lat1, tl_segdom1(jp_T,jk,jl) ) + + ! clean + DO jpoint=1,ip_npoint + CALL dom_clean(tl_segdom1(jpoint,jk,jl)) + ENDDO + + ! swap array + CALL boundary_swap(tl_lon1, tl_bdy(jl)) + CALL boundary_swap(tl_lat1, tl_bdy(jl)) + DO jvar=1,tl_multi%i_nvar + + ! use additional request + ! change unit and apply factor + CALL var_chg_unit(tl_segvar1(jvar,jk,jl)) + + ! forced min and max value + CALL var_limit_value(tl_segvar1(jvar,jk,jl)) + + ! filter + CALL filter_fill_value(tl_segvar1(jvar,jk,jl)) + + IF( .NOT. ln_extrap )THEN + ! use mask + SELECT CASE(TRIM(tl_segvar1(jvar,jk,jl)%c_point)) + CASE DEFAULT !'T' + jpoint=jp_T + CASE('U') + jpoint=jp_U + CASE('V') + jpoint=jp_V + CASE('F') + jpoint=jp_F + END SELECT + + CALL create_boundary_use_mask(tl_segvar1(jvar,jk,jl), & + & tl_seglvl1(jpoint,jk,jl)) + ENDIF + + ! swap dimension order + CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl)) + + ENDDO + + ! create file + ! create file structure + ! set file namearray of level variable structure + IF( tl_bdy(jl)%i_nseg > 1 )THEN + IF( ASSOCIATED(tl_time%d_value) )THEN + cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" + tl_date=var_to_date(tl_time) + tl_date=tl_date+dn_dayofs + cl_date=date_print( tl_date, cl_fmt ) + + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(tl_bdy(jl)%c_card), jk,& + & cd_date=TRIM(cl_date) ) + ELSE + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(tl_bdy(jl)%c_card), jk ) + ENDIF + ELSE + IF( ASSOCIATED(tl_time%d_value) )THEN + cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" + tl_date=var_to_date(tl_time) + tl_date=tl_date+dn_dayofs + cl_date=date_print( tl_date, cl_fmt ) + + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(tl_bdy(jl)%c_card), & + & cd_date=TRIM(cl_date) ) + ELSE + cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & + & TRIM(tl_bdy(jl)%c_card) ) + ENDIF + ENDIF + ! + tl_fileout=file_init(TRIM(cl_bdyout),id_perio=in_perio1) + + ! add dimension + tl_dim(:)=var_max_dim(tl_segvar1(:,jk,jl)) + + SELECT CASE(TRIM(tl_bdy(jl)%c_card)) + CASE DEFAULT ! 'north','south' + cl_dimorder='xyzt' + CASE('east','west') + cl_dimorder='yxzt' + END SELECT + + DO ji=1,ip_maxdim + IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji)) + ENDDO + + ! add variables + IF( ALL( tl_dim(1:2)%l_use ) )THEN + ! add longitude + CALL file_add_var(tl_fileout, tl_lon1) + CALL var_clean(tl_lon1) + + ! add latitude + CALL file_add_var(tl_fileout, tl_lat1) + CALL var_clean(tl_lat1) + ENDIF + + + + IF( tl_dim(3)%l_use )THEN + IF( ASSOCIATED(tl_depth%d_value) )THEN + ! add depth + CALL file_add_var(tl_fileout, tl_depth) + ENDIF + ENDIF + + IF( tl_dim(4)%l_use )THEN + IF( ASSOCIATED(tl_time%d_value) )THEN + ! add time + CALL file_add_var(tl_fileout, tl_time) + ENDIF + ENDIF + + ! add other variable + DO jvar=tl_multi%i_nvar,1,-1 + CALL file_add_var(tl_fileout, tl_segvar1(jvar,jk,jl)) + CALL var_clean(tl_segvar1(jvar,jk,jl)) + ENDDO + + ! add some attribute + tl_att=att_init("Created_by","SIREN create_boundary") + CALL file_add_att(tl_fileout, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL file_add_att(tl_fileout, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",cl_date) + CALL file_add_att(tl_fileout, tl_att) + + ! add shift on north and east boundary + ! boundary compute on T point but express on U or V point + SELECT CASE(TRIM(tl_bdy(jl)%c_card)) + CASE DEFAULT ! 'south','west' + il_shift=0 + CASE('north','east') + il_shift=1 + END SELECT + + ! add indice of velocity row or column + tl_att=att_init('bdy_ind',tl_bdy(jl)%t_seg(jk)%i_index-il_shift) + CALL file_move_att(tl_fileout, tl_att) + + ! add width of the relaxation zone + tl_att=att_init('bdy_width',tl_bdy(jl)%t_seg(jk)%i_width) + CALL file_move_att(tl_fileout, tl_att) + + ! add indice of segment start + tl_att=att_init('bdy_deb',tl_bdy(jl)%t_seg(jk)%i_first) + CALL file_move_att(tl_fileout, tl_att) + + ! add indice of segment end + tl_att=att_init('bdy_end',tl_bdy(jl)%t_seg(jk)%i_last) + CALL file_move_att(tl_fileout, tl_att) + + ! clean + CALL att_clean(tl_att) + + ! create file + CALL iom_create(tl_fileout) + + ! write file + CALL iom_write_file(tl_fileout, cl_dimorder) + + ! close file + CALL iom_close(tl_fileout) + CALL file_clean(tl_fileout) + + ENDDO ! jk + + ENDIF + ! clean + CALL boundary_clean(tl_bdy(jl)) + ENDDO !jl + + ! clean + IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth) + IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time) + DEALLOCATE( tl_segdom1 ) + DEALLOCATE( tl_segvar1 ) + CALL var_clean(tl_seglvl1(:,:,:)) + DEALLOCATE( tl_seglvl1 ) + + + CALL mpp_clean(tl_coord1) + CALL mpp_clean(tl_coord0) + CALL var_clean_extra() + + CALL multi_clean(tl_multi) + + ! close log file + CALL logger_footer() + CALL logger_close() + CALL logger_clean() + + END SUBROUTINE create_boundary__mono + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_boundary_get_dom(td_bathy1, td_bdy, id_seg) & + & RESULT (tf_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute boundary domain for each grid point (T,U,V,F) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - take into account grid point to compute boundary indices + !> + !> @param[in] td_bathy1 file structure + !> @param[in] td_bdy boundary structure + !> @param[in] id_seg segment indice + !> @return array of domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN ) :: td_bathy1 + TYPE(TBDY) , INTENT(IN ) :: td_bdy + INTEGER(i4), INTENT(IN ) :: id_seg + + ! function + TYPE(TDOM), DIMENSION(ip_npoint) :: tf_dom + + ! local variable + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + INTEGER(i4), DIMENSION(ip_npoint) :: il_ishift + INTEGER(i4), DIMENSION(ip_npoint) :: il_jshift + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + !---------------------------------------------------------------- + ! init + jk=id_seg + + il_ishift(:)=0 + il_jshift(:)=0 + + ! get boundary definition + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north') + + il_imin1=td_bdy%t_seg(jk)%i_first + il_imax1=td_bdy%t_seg(jk)%i_last + il_jmin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1) + il_jmax1=td_bdy%t_seg(jk)%i_index + + il_jshift(jp_V)=-1 + il_jshift(jp_F)=-1 + + CASE('south') + + il_imin1=td_bdy%t_seg(jk)%i_first + il_imax1=td_bdy%t_seg(jk)%i_last + il_jmin1=td_bdy%t_seg(jk)%i_index + il_jmax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1) + + CASE('east') + + il_imin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1) + il_imax1=td_bdy%t_seg(jk)%i_index + il_jmin1=td_bdy%t_seg(jk)%i_first + il_jmax1=td_bdy%t_seg(jk)%i_last + + il_ishift(jp_U)=-1 + il_ishift(jp_F)=-1 + + CASE('west') + + il_imin1=td_bdy%t_seg(jk)%i_index + il_imax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1) + il_jmin1=td_bdy%t_seg(jk)%i_first + il_jmax1=td_bdy%t_seg(jk)%i_last + + END SELECT + + !-read fine grid domain + DO ji=1,ip_npoint + + ! shift domain + il_imin=il_imin1+il_ishift(ji) + il_imax=il_imax1+il_ishift(ji) + + il_jmin=il_jmin1+il_jshift(ji) + il_jmax=il_jmax1+il_jshift(ji) + + ! compute domain + tf_dom(ji)=dom_init(td_bathy1, & + & il_imin, il_imax, & + & il_jmin, il_jmax, & + & TRIM(td_bdy%c_card)) + + ENDDO + + END FUNCTION create_boundary_get_dom + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary_get_coord(td_coord1, td_dom1, cd_point, & + & td_lon1, td_lat1) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get coordinates over boundary domain + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - take into account grid point + !> + !> @param[in] td_coord1 coordinates file structure + !> @param[in] td_dom1 boundary domain structure + !> @param[in] cd_point grid point + !> @param[out] td_lon1 longitude variable structure + !> @param[out] td_lat1 latitude variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN ) :: td_coord1 + TYPE(TDOM) , INTENT(IN ) :: td_dom1 + CHARACTER(LEN=*), INTENT(IN ) :: cd_point + TYPE(TVAR) , INTENT( OUT) :: td_lon1 + TYPE(TVAR) , INTENT( OUT) :: td_lat1 + + ! local variable + TYPE(TMPP) :: tl_coord1 + + CHARACTER(LEN=lc) :: cl_name + ! loop indices + !---------------------------------------------------------------- + !read variables on domain (ugly way to do it, have to work on it) + ! init mpp structure + tl_coord1=mpp_copy(td_coord1) + + ! open mpp files + CALL iom_dom_open(tl_coord1, td_dom1) + + ! read variable value on domain + WRITE(cl_name,*) 'longitude_'//TRIM(cd_point) + td_lon1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1) + WRITE(cl_name,*) 'latitude_'//TRIM(cd_point) + td_lat1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1) + + ! close mpp files + CALL iom_dom_close(tl_coord1) + + ! clean structure + CALL mpp_clean(tl_coord1) + + END SUBROUTINE create_boundary_get_coord + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary_interp(td_var, id_rho, id_offset, & + & id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable on boundary + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] id_rho array of refinment factor + !> @param[in] id_offset array of offset between fine and coarse grid + !> @param[in] id_iext i-direction size of extra bands (default=im_minext) + !> @param[in] id_jext j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset + + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + + ! local variable + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + ! loop indices + !---------------------------------------------------------------- + + !WARNING: at least two extrabands are required for cubic interpolation + il_iext=2 + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=2 + IF( PRESENT(id_jext) ) il_jext=id_jext + + IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_iext=2 + ENDIF + + IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_jext=2 + ENDIF + + ! work on variable + ! add extraband + CALL extrap_add_extrabands(td_var, il_iext, il_jext) + + ! extrapolate variable + CALL extrap_fill_value( td_var ) + + ! interpolate variable + CALL interp_fill_value( td_var, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! remove extraband + CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), & + & il_jext*id_rho(jp_J)) + + END SUBROUTINE create_boundary_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_boundary_matrix(td_var, td_dom, id_nlevel) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function create variable, filled with matrix value + !> + !> @details + !> A variable is create with the same name that the input variable, + !> and with dimension of the coordinate file. + !> Then the variable array of value is split into equal subdomain. + !> Each subdomain is fill with the associated value of the matrix. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] td_dom domain structure + !> @param[in] id_nlevel number of levels + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + TYPE(TDOM) , INTENT(IN) :: td_dom + INTEGER(i4), INTENT(IN) :: id_nlevel + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) , DIMENSION(3) :: il_dim + INTEGER(i4) , DIMENSION(3) :: il_size + INTEGER(i4) , DIMENSION(3) :: il_rest + + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_kshape + + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! write value on grid + ! get matrix dimension + il_dim(:)=td_var%t_dim(1:3)%i_len + + tl_dim(jp_I:jp_J)=dim_copy(td_dom%t_dim(jp_I:jp_J)) + tl_dim(jp_K)%i_len=id_nlevel + + ! split output domain in N subdomain depending of matrix dimension + il_size(:) = tl_dim(1:3)%i_len / il_dim(:) + il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:)) + + ALLOCATE( il_ishape(il_dim(1)+1) ) + il_ishape(:)=0 + DO ji=2,il_dim(1)+1 + il_ishape(ji)=il_ishape(ji-1)+il_size(1) + ENDDO + ! add rest to last cell + il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1) + + ALLOCATE( il_jshape(il_dim(2)+1) ) + il_jshape(:)=0 + DO jj=2,il_dim(2)+1 + il_jshape(jj)=il_jshape(jj-1)+il_size(2) + ENDDO + ! add rest to last cell + il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2) + + ALLOCATE( il_kshape(il_dim(3)+1) ) + il_kshape(:)=0 + DO jk=2,il_dim(3)+1 + il_kshape(jk)=il_kshape(jk-1)+il_size(3) + ENDDO + ! add rest to last cell + il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3) + + ! write ouput array of value + ALLOCATE(dl_value( tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + dl_value(:,:,:,:)=0 + + DO jk=2,il_dim(3)+1 + DO jj=2,il_dim(2)+1 + DO ji=2,il_dim(1)+1 + + dl_value( 1+il_ishape(ji-1):il_ishape(ji), & + & 1+il_jshape(jj-1):il_jshape(jj), & + & 1+il_kshape(jk-1):il_kshape(jk), & + & 1 ) = td_var%d_value(ji-1,jj-1,jk-1,1) + + ENDDO + ENDDO + ENDDO + + ! initialise variable with value + tf_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:)) + + DEALLOCATE(dl_value) + + END FUNCTION create_boundary_matrix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary_use_mask(td_var, td_mask) + !------------------------------------------------------------------- + !> @brief + !> This subroutine use mask to filled land point with _FillValue + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_mask mask variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TVAR), INTENT(IN ) :: td_mask + + ! local variable + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask + + ! loop indices + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( ANY(td_var%t_dim(1:2)%i_len /= & + & td_mask%t_dim(1:2)%i_len) )THEN + CALL logger_debug(" mask dimension ( "//& + & TRIM(fct_str(td_mask%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_mask%t_dim(2)%i_len))//")" ) + CALL logger_debug(" variable dimension ( "//& + & TRIM(fct_str(td_var%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_var%t_dim(2)%i_len))//")" ) + CALL logger_fatal("CREATE BOUNDARY USE MASK: mask and "//& + & "variable dimension differ." ) + ENDIF + + ALLOCATE( il_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len) ) + + il_mask(:,:)=INT(td_mask%d_value(:,:,1,1)) + + DO jl=1,td_var%t_dim(4)%i_len + DO jk=1,td_var%t_dim(3)%i_len + WHERE( il_mask(:,:) < jk ) td_var%d_value(:,:,jk,jl)=td_var%d_fill + ENDDO + ENDDO + + DEALLOCATE( il_mask ) + + END SUBROUTINE create_boundary_use_mask + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_boundary_get_level(td_level, td_dom) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function extract level over domain on each grid point, and return + !> array of variable structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_level array of level variable structure + !> @param[in] td_dom array of domain structure + !> @return array of variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level + TYPE(TDOM), DIMENSION(:), INTENT(IN) :: td_dom + + ! function + TYPE(TVAR), DIMENSION(ip_npoint) :: tf_var + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_level(:)) /= ip_npoint .OR. & + & SIZE(td_dom(:)) /= ip_npoint )THEN + CALL logger_error("CREATE BDY GET LEVEL: invalid dimension. "//& + & "check input array of level and domain.") + ELSE + + DO ji=1,ip_npoint + + tf_var(ji)=var_copy(td_level(ji)) + + IF( ASSOCIATED(tf_var(ji)%d_value) ) DEALLOCATE(tf_var(ji)%d_value) + + tf_var(ji)%t_dim(1)%i_len=td_dom(ji)%t_dim(1)%i_len + tf_var(ji)%t_dim(2)%i_len=td_dom(ji)%t_dim(2)%i_len + ALLOCATE(tf_var(ji)%d_value(tf_var(ji)%t_dim(1)%i_len, & + & tf_var(ji)%t_dim(2)%i_len, & + & tf_var(ji)%t_dim(3)%i_len, & + & tf_var(ji)%t_dim(4)%i_len) ) + + tf_var(ji)%d_value(:,:,:,:) = & + & td_level(ji)%d_value( td_dom(ji)%i_imin:td_dom(ji)%i_imax, & + & td_dom(ji)%i_jmin:td_dom(ji)%i_jmax, :, : ) + + ENDDO + + ENDIF + + END FUNCTION create_boundary_get_level + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary_check_depth(td_var, td_mpp, id_nlevel, td_depth) + !------------------------------------------------------------------- + !> @brief + !> This subroutine check if variable need depth dimension, + !> get depth variable value in an open mpp structure + !> and check if agree with already input depth variable. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> @date January, 2016 + !> - check if variable need/use depth dimension + !> + !> @param[in] td_var variable structure + !> @param[in] td_mpp mpp structure + !> @param[in] id_nlevel mpp structure + !> @param[inout] td_depth depth variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN ) :: td_var + TYPE(TMPP) , INTENT(IN ) :: td_mpp + INTEGER(i4), INTENT(IN ) :: id_nlevel + TYPE(TVAR) , INTENT(INOUT) :: td_depth + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_depth + ! loop indices + !---------------------------------------------------------------- + + IF( td_var%t_dim(jp_K)%l_use .AND. & + & ( TRIM(td_var%c_axis) == '' .OR. & + & INDEX(TRIM(td_var%c_axis),'Z') /= 0 )& + & )THEN + + ! check vertical dimension + IF( td_mpp%t_dim(jp_K)%l_use )THEN + IF( td_mpp%t_dim(jp_K)%i_len /= id_nlevel .AND. & + & td_mpp%t_dim(jp_K)%i_len /= 1 )THEN + CALL logger_error("CREATE BOUNDARY: dimension in file "//& + & TRIM(td_mpp%c_name)//" not agree with namelist in_nlevel ") + ENDIF + ENDIF + + ! get or check depth value + IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_depthid + IF( ASSOCIATED(td_depth%d_value) )THEN + + tl_depth=iom_mpp_read_var(td_mpp, il_varid) + + IF( ANY( td_depth%d_value(:,:,:,:) /= & + & tl_depth%d_value(:,:,:,:) ) )THEN + + CALL logger_error("CREATE BOUNDARY: depth value "//& + & "for variable "//TRIM(td_var%c_name)//& + & "from "//TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_depth) + + ELSE + td_depth=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + ELSE + CALL logger_debug("CREATE BOUNDARY: no depth dimension use"//& + & " for variable "//TRIM(td_var%c_name)) + ENDIF + + END SUBROUTINE create_boundary_check_depth + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_boundary_check_time(td_var, td_mpp, td_time) + !------------------------------------------------------------------- + !> @brief + !> This subroutine check if variable need time dimension, + !> get date and time in an open mpp structure + !> and check if agree with date and time already read. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> @date January, 2016 + !> - check if variable need/use time dimension + !> + !> @param[in] td_var variable structure + !> @param[in] td_mpp mpp structure + !> @param[inout] td_time time variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN ) :: td_var + TYPE(TMPP), INTENT(IN ) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_time + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_time + + TYPE(TDATE) :: tl_date1 + TYPE(TDATE) :: tl_date2 + ! loop indices + !---------------------------------------------------------------- + IF( td_var%t_dim(jp_L)%l_use .AND. & + & ( TRIM(td_var%c_axis) == '' .OR. & + & INDEX(TRIM(td_var%c_axis),'T') /= 0 )& + & )THEN + + ! get or check time value + IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_timeid + IF( ASSOCIATED(td_time%d_value) )THEN + + tl_time=iom_mpp_read_var(td_mpp, il_varid) + + tl_date1=var_to_date(td_time) + tl_date2=var_to_date(tl_time) + IF( tl_date1 - tl_date2 /= 0 )THEN + + CALL logger_warn("CREATE BOUNDARY: date from "//& + & TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_time) + + ELSE + td_time=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + + ELSE + CALL logger_debug("CREATE BOUNDARY: no time dimension use"//& + & " for variable "//TRIM(td_var%c_name)) + ENDIF + + END SUBROUTINE create_boundary_check_time + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM create_boundary diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_coord.f90 b/V4.0/nemo_sources/tools/SIREN/src/create_coord.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c540d1cc6f843926fe2edbc250c07846cd00775d --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_coord.f90 @@ -0,0 +1,834 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> this program creates fine grid coordinate file. +!> +!> @details +!> @section sec1 method +!> variables from the input coordinates coarse/source grid file, are extracted +!> and interpolated to create a fine/taget grid coordinates file.<br/> +!> @note +!> interpolation method could be different for each variable. +!> +!> \image html header_coord_40.png +!> <center> \image latex header_coord_40.png +!> </center> +!> +!> @section sec2 how to +!> USAGE: create_coord create_coord.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_coord.nam<br/> +!> namelist of create_coord +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_coord +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_coord create_coord.nam +!> create_coord.nam contains 6 sub-namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source/coarse grid parameters +!> - **namvar** to set variable parameters +!> - **namnst** to set sub domain and nesting paramters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_coord.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the source/coarse grid sub-namelist parameters are : +!> +!> - **cn_coord0** [@a ]<br/> +!> path to the coordinate file +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varinfo** [@a ]<br/> +!> list of variable and extra information about request(s) to be used<br/> +!> +!> each elements of *cn_varinfo* is a string character (separated by ',').<br/> +!> it is composed of the variable name follow by ':', +!> then request(s) to be used on this variable.<br/> +!> request could be: +!> - int = interpolation method +!> - ext = extrapolation method +!> +!> requests must be separated by ';'.<br/> +!> order of requests does not matter.<br/> +!> +!> informations about available method could be find in @ref interp, +!> @ref extrap and @ref filter modules.<br/> +!> Example: +!> - 'glamt: int=linear; ext=dist_weight', 'e1t: int=cubic/rhoi' +!> +!> @note +!> If you do not specify a method which is required, +!> default one is apply. +!> +!> @subsection subnst namnst +!> the nesting sub-namelist parameters are : +!> +!> - **in_imin0** [@a ]<br/> +!> i-direction lower left point indice of coarse grid subdomain to be used +!> - **in_imax0** [@a ]<br/> +!> i-direction upper right point indice of coarse grid subdomain to be used +!> - **in_jmin0** [@a ]<br/> +!> j-direction lower left point indice of coarse grid subdomain to be used +!> - **in_jmax0** [@a ]<br/> +!> j-direction upper right point indice of coarse grid subdomain to be used +!> <br/>or<br/> +!> - **rn_lonmin0** [@a ]<br/> +!> lower left longitude of coarse grid subdomain to be used +!> - **rn_lonmax0** [@a ]<br/> +!> upper right longitude of coarse grid subdomain to be used +!> - **rn_latmin0** [@a ]<br/> +!> lower left latitude of coarse grid subdomain to be used +!> - **rn_latmax0** [@a ]<br/> +!> upper right latitude of coarse grid subdomain to be used +!> @note you could define sub domain with +!> - coarse/source grid indices +!> <br/>or<br/> +!> - coordinates.<br/> +!> if coordinates are defined (-180 < lon < 360 and -90 < lat < 90), +!> SIREN does not take into account indices. +!> +!> - **in_rhoi** [@a 1]<br/> +!> refinement factor in i-direction +!> +!> - **in_rhoj** [@a 1]<br/> +!> refinement factor in j-direction +!> +!> \image html grid_zoom_60.png +!> <center> \image latex grid_zoom_40.png +!> </center> +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a coord_fine.nc]<br/> +!> output bathymetry filename +!> +!> <hr> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header for user +!> - compute offset considering grid point +!> - add global attributes in output file +!> @date September, 2015 +!> - manage useless (dummy) variable, attributes, and dimension +!> @date September, 2016 +!> - allow to use coordinate to define subdomain +!> @date October, 2016 +!> - dimension to be used select from configuration file +!> @date January, 2019 +!> - add url path to global attributes of output file(s) +!> @date February, 2019 +!> - rename sub namelist namcrs to namsrc +!> - create and clean file structure to avoid memory leaks +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_coord + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE iom ! I/O manager + USE grid ! grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE dom ! domain manager + USE iom_mpp ! MPP I/O manager + USE iom_dom ! DOM I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_coord" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_url + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_nvar + INTEGER(i4) :: il_ew + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho + INTEGER(i4) , DIMENSION(2) :: il_index + INTEGER(i4) , DIMENSION(2,2,ip_npoint) :: il_offset + + LOGICAL :: ll_exist + + TYPE(TATT) :: tl_att + + TYPE(TDOM) :: tl_dom + + TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_var + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TFILE) :: tl_file + + TYPE(TMPP) :: tl_coord0 + TYPE(TFILE) :: tl_fileout + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log' + CHARACTER(LEN=lc) :: cn_verbosity= 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_coord0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + + !namnst + REAL(sp) :: rn_lonmin0 = -360. + REAL(sp) :: rn_lonmax0 = -360. + REAL(sp) :: rn_latmin0 = -360. + REAL(sp) :: rn_latmax0 = -360. + INTEGER(i4) :: in_imin0 = 0 + INTEGER(i4) :: in_imax0 = 0 + INTEGER(i4) :: in_jmin0 = 0 + INTEGER(i4) :: in_jmax0 = 0 + INTEGER(i4) :: in_rhoi = 1 + INTEGER(i4) :: in_rhoj = 1 + + !namout + CHARACTER(LEN=lc) :: cn_fileout = 'coord_fine.nc' + !------------------------------------------------------------------- + + NAMELIST /namlog/ & ! logger namelist + & cn_logfile, & !< logger file name + & cn_verbosity, & !< logger verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_coord0 , & !< coordinate file + & in_perio0 !< periodicity index + + NAMELIST /namvar/ & !< variable namelist + & cn_varinfo !< list of variable and extra information about + !< interpolation, extrapolation or filter method to be used. + !< (ex: 'votemper:linear,hann,dist_weight','vosaline:cubic' ) + + NAMELIST /namnst/ & !< nesting namelist + & rn_lonmin0, & !< lower left coarse grid longitude + & rn_lonmax0, & !< upper right coarse grid longitude + & rn_latmin0, & !< lower left coarse grid latitude + & rn_latmax0, & !< upper right coarse grid latitude + & in_imin0, & !< i-direction lower left point indice + & in_imax0, & !< i-direction upper right point indice + & in_jmin0, & !< j-direction lower left point indice + & in_jmax0, & !< j-direction upper right point indice + & in_rhoi, & !< refinement factor in i-direction + & in_rhoj !< refinement factor in j-direction + + NAMELIST /namout/ & !< output namelist + & cn_fileout !< fine grid coordinate file + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + + ! define logger file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information on configuration file + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namvar ) + ! add user change in extra information + CALL var_chg_extra( cn_varinfo ) + + READ( il_fileid, NML = namnst ) + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE COORD: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + ! open files + IF( cn_coord0 /= '' )THEN + tl_file=file_init(TRIM(cn_coord0)) + tl_coord0=mpp_init( tl_file, id_perio=in_perio0) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord0) + ELSE + CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//& + & "check namelist") + ENDIF + + ! check + ! check output file do not already exist + INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE COORD: output file "//TRIM(cn_fileout)//& + & " already exist.") + ENDIF + + ! check nesting parameters + il_index(:)=0 + IF( rn_lonmin0 >= -180. .AND. rn_lonmin0 <= 360 .AND. & + & rn_latmin0 >= -90. .AND. rn_latmin0 <= 90. )THEN + + il_index(:)=grid_get_closest(tl_coord0, & + & REAL(rn_lonmin0,dp), REAL(rn_latmin0,dp), & + & cd_pos='ll') + il_imin0=il_index(1) + il_jmin0=il_index(2) + ELSE + il_imin0=in_imin0 + il_jmin0=in_jmin0 + ENDIF + + il_index(:)=0 + IF( rn_lonmax0 >= -180. .AND. rn_lonmax0 <= 360 .AND. & + & rn_latmax0 >= -90. .AND. rn_latmax0 <= 90. )THEN + + il_index(:)=grid_get_closest(tl_coord0, & + & REAL(rn_lonmax0,dp), REAL(rn_latmax0,dp), & + & cd_pos='ur') + il_imax0=il_index(1) + il_jmax0=il_index(2) + ELSE + il_imax0=in_imax0 + il_jmax0=in_jmax0 + ENDIF + + ! forced indices for east west cyclic domain + IF( rn_lonmin0 == rn_lonmax0 .AND. & + & rn_lonmin0 /= -360. )THEN + il_imin0=0 + il_imax0=0 + ENDIF + + IF( il_imin0 < 0 .OR. il_imax0 < 0 .OR. il_jmin0 < 0 .OR. il_jmax0 < 0)THEN + CALL logger_fatal("CREATE COORD: invalid points indices."//& + & " check namelist "//TRIM(cl_namelist)) + ENDIF + + il_rho(:)=1 + IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN + CALL logger_error("CREATE COORD: invalid refinement factor."//& + & " check namelist "//TRIM(cl_namelist)) + ELSE + il_rho(jp_I)=in_rhoi + il_rho(jp_J)=in_rhoj + + il_offset(:,:,:)=create_coord_get_offset(il_rho(:)) + ENDIF + + ! check domain validity + CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0 ) + + ! compute domain + tl_dom=dom_init( tl_coord0, & + & il_imin0, il_imax0,& + & il_jmin0, il_jmax0 ) + + ! add extra band (if need be) to compute interpolation + CALL dom_add_extra(tl_dom) + + ! open mpp files + CALL iom_dom_open(tl_coord0, tl_dom) + + il_nvar=tl_coord0%t_proc(1)%i_nvar + ALLOCATE( tl_var(il_nvar) ) + DO ji=1,il_nvar + + tl_var(ji)=iom_dom_read_var(tl_coord0, & + & TRIM(tl_coord0%t_proc(1)%t_var(ji)%c_name),& + & tl_dom) + + SELECT CASE(TRIM(tl_var(ji)%c_point)) + CASE('T') + jj=jp_T + CASE('U') + jj=jp_U + CASE('V') + jj=jp_V + CASE('F') + jj=jp_F + END SELECT + + ! interpolate variables + CALL create_coord_interp( tl_var(ji), il_rho(:), & + & il_offset(:,:,jj) ) + + ! remove extraband added to domain + CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:), .true. ) + + ! filter + CALL filter_fill_value(tl_var(ji)) + + ENDDO + + ! clean + CALL dom_clean_extra( tl_dom ) + + ! close mpp files + CALL iom_dom_close(tl_coord0) + + ! clean + CALL mpp_clean(tl_coord0) + + ! create file + tl_fileout=file_init(TRIM(cn_fileout)) + + ! add dimension + ! save biggest dimension + tl_dim(:)=var_max_dim(tl_var(:)) + + DO ji=1,ip_maxdim + IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji)) + ENDDO + + ! add variables + DO ji=il_nvar,1,-1 + CALL file_add_var(tl_fileout, tl_var(ji)) + CALL var_clean(tl_var(ji)) + ENDDO + + ! add some attribute + tl_att=att_init("Created_by","SIREN create_coord") + CALL file_add_att(tl_fileout, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL file_add_att(tl_fileout, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",cl_date) + CALL file_add_att(tl_fileout, tl_att) + + tl_att=att_init("src_file",TRIM(fct_basename(cn_coord0))) + CALL file_add_att(tl_fileout, tl_att) + + tl_att=att_init("src_i_indices",(/tl_dom%i_imin,tl_dom%i_imax/)) + CALL file_add_att(tl_fileout, tl_att) + tl_att=att_init("src_j_indices",(/tl_dom%i_jmin,tl_dom%i_jmax/)) + CALL file_add_att(tl_fileout, tl_att) + IF( .NOT. ALL(il_rho(:)==1) )THEN + tl_att=att_init("refinment_factor",(/il_rho(jp_I),il_rho(jp_J)/)) + CALL file_add_att(tl_fileout, tl_att) + ENDIF + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attid=att_get_index(tl_fileout%t_att(:),'periodicity') + ENDIF + IF( tl_dom%i_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',tl_dom%i_perio) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + + ! add attribute east west overlap + il_attid=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attid=att_get_index(tl_fileout%t_att(:),'ew_overlap') + ENDIF + IF( il_attid == 0 )THEN + il_ind=var_get_index(tl_fileout%t_var(:),'longitude') + IF( il_ind == 0 )THEN + il_ind=var_get_index(tl_fileout%t_var(:),'longitude_T') + ENDIF + il_ew=grid_get_ew_overlap(tl_fileout%t_var(il_ind)) + IF( il_ew >= 0 )THEN + tl_att=att_init('ew_overlap',il_ew) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + ENDIF + + ! create file + CALL iom_create(tl_fileout) + + ! write file + CALL iom_write_file(tl_fileout) + + ! close file + CALL iom_close(tl_fileout) + + ! clean + CALL att_clean(tl_att) + CALL var_clean(tl_var(:)) + DEALLOCATE( tl_var) + + CALL file_clean(tl_fileout) + CALL var_clean_extra() + + ! close log file + CALL logger_footer() + CALL logger_close() + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_coord_get_offset(id_rho) & + & RESULT (if_offset) + !------------------------------------------------------------------- + !> @brief + !> This function compute offset over Arakawa grid points, + !> given refinement factor. + !> + !> @author J.Paul + !> @date August, 2014 - Initial Version + !> + !> @param[in] id_rho array of refinement factor + !> @return array of offset + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_rho + + ! function + INTEGER(i4), DIMENSION(2,2,ip_npoint) :: if_offset + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + ! case 'T' + if_offset(jp_I,:,jp_T)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5) + if_offset(jp_J,:,jp_T)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5) + ! case 'U' + if_offset(jp_I,1,jp_U)=0 + if_offset(jp_I,2,jp_U)=id_rho(jp_I)-1 + if_offset(jp_J,:,jp_U)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5) + ! case 'V' + if_offset(jp_I,:,jp_V)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5) + if_offset(jp_J,1,jp_V)=0 + if_offset(jp_J,2,jp_V)=id_rho(jp_J)-1 + ! case 'F' + if_offset(jp_I,1,jp_F)=0 + if_offset(jp_I,2,jp_F)=id_rho(jp_I)-1 + if_offset(jp_J,1,jp_F)=0 + if_offset(jp_J,2,jp_F)=id_rho(jp_J)-1 + + END FUNCTION create_coord_get_offset + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_coord_interp(td_var, id_rho, id_offset, & + & id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable, given refinment factor. + !> + !> @details + !> Optionaly, you could specify number of points + !> to be extrapolated in i- and j-direction.<br/> + !> variable mask is first computed (using _FillValue) and interpolated.<br/> + !> variable is then extrapolated, and interpolated.<br/> + !> Finally interpolated mask is applied on refined variable. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable strcuture + !> @param[in] id_rho array of refinement factor + !> @param[in] id_offset offset between fine grid and coarse grid + !> @param[in] id_iext number of points to be extrapolated in i-direction + !> @param[in] id_jext number of points to be extrapolated in j-direction + !> + !> @todo check if mask is really needed + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_offset + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + ! local variable + TYPE(TVAR) :: tl_mask + + INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask + + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + + ! loop indices + !---------------------------------------------------------------- + + IF( ANY(SHAPE(id_offset(:,:)) /= 2) )THEN + CALL logger_error("CREATE COORD INTERP: invalid dimension of "//& + & "offset array") + ENDIF + + !WARNING: two extrabands are required for cubic interpolation + il_iext=2 + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=2 + IF( PRESENT(id_jext) ) il_jext=id_jext + + IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE COORD INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_iext=2 + ENDIF + + IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE COORD INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_jext=2 + ENDIF + + IF( ANY(id_rho(:)>1) )THEN + ! work on mask + ! create mask + ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + bl_mask(:,:,:,:)=1 + WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0 + + SELECT CASE(TRIM(td_var%c_point)) + CASE DEFAULT ! 'T' + tl_mask=var_init('tmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& + & id_ew=td_var%i_ew ) + CASE('U') + tl_mask=var_init('umask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& + & id_ew=td_var%i_ew ) + CASE('V') + tl_mask=var_init('vmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& + & id_ew=td_var%i_ew ) + CASE('F') + tl_mask=var_init('fmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& + & id_ew=td_var%i_ew ) + END SELECT + + DEALLOCATE(bl_mask) + + ! interpolate mask + CALL interp_fill_value( tl_mask, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! work on variable + ! add extraband + CALL extrap_add_extrabands(td_var, il_iext, il_jext) + + ! extrapolate variable + CALL extrap_fill_value( td_var ) + + ! interpolate variable + CALL interp_fill_value( td_var, id_rho(:), & + & id_offset=id_offset(:,:)) + + ! remove extraband + CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) + + ! keep original mask + WHERE( tl_mask%d_value(:,:,:,:) == 0 ) + td_var%d_value(:,:,:,:)=td_var%d_fill + END WHERE + ENDIF + + ! clean variable structure + CALL var_clean(tl_mask) + + END SUBROUTINE create_coord_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM create_coord diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_layout.f90 b/V4.0/nemo_sources/tools/SIREN/src/create_layout.f90 new file mode 100644 index 0000000000000000000000000000000000000000..76193390306ad6e780b27eae0396b5e5b1307c47 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_layout.f90 @@ -0,0 +1,351 @@ +!---------------------------------------------------------------------- +! MERCATOR OCEAN, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> This program creates/computes the domain layout for you configuration. +!> +!> @details +!> @section sec1 method +!> +!> Domain layout is computed, with domain dimension, overlap between subdomain, +!> and the number of processors available or following i and j-direction. +!> Then the number of sea/land processors is compute with mask. +!> +!> The optimized domain layout is assumed to be the domain layout, with the the most land +!> processors removed. If no land processor could be removed, it assumed to be the domain layout +!> with the most sea processors. +!> +!> @section sec2 how to +!> USAGE: create_layout create_layout.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_layout.nam<br/> +!> namelist of create_layout +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_layout +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_layout create_layout.nam +!> create_layout.nam contains 4 namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namvar** to set variable parameters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_layout.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varfile** [@a ]<br/> +!> list of variable, and associated file +!> @warning +!> variable name must be __Bathymetry__ here. +!> +!> - **cn_varfile** [@a ]<br/>: +!> list of variable, and associated file.<br/> +!> *cn_varfile* is the path and filename of the file where find +!> variable to be used as mask grid.<br/> +!> +!> Examples: +!> - 'Bathymetry:bathy_meter.nc' +!> +!> @subsection subout namout +!> the output sub-namelist parameters are : +!> +!> - **in_niproc** [@a 1]<br/>: +!> number of processor in i-direction +!> - **in_njproc** [@a 1]<br/>: +!> number of processor in j-direction +!> - **in_nproc** [@a 1]<br/>: +!> total number of processor to be used +!> +!> @note +!> - if *in_niproc*, and *in_njproc* are provided : the program only look for land +!> processor to be removed +!> - if *in_nproc* is provided : the program compute each possible domain layout, +!> and save the one with the most land processor to be removed +!> - with no information about number of processors, the program +!> assume to use only one processor +!> +!> <hr> +!> @author +!> J.Paul +!> +!> @date January, 2019 - Initial Version +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_layout + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE math ! + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE multi ! multi file manager + USE iom ! I/O manager + USE dom ! domain manager + USE grid ! grid manager + USE mpp ! MPP manager + USE iom_mpp ! MPP I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_layout" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_var + CHARACTER(LEN=lc) :: cl_errormsg + + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + + LOGICAL :: ll_exist + + TYPE(TVAR) :: tl_var + + TYPE(TFILE) :: tl_file + + TYPE(TMPP) :: tl_mpp + TYPE(TMPP) :: tl_mppout + + TYPE(TMULTI) :: tl_multi + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_layout.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' + + ! namout + INTEGER(i4) :: in_niproc = 0 + INTEGER(i4) :: in_njproc = 0 + INTEGER(i4) :: in_nproc = 0 + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namvar/ & !< source grid namelist + & cn_varfile !< input file and mask variable + + NAMELIST /namout/ & !< output namelist + & in_niproc, & + & in_njproc, & + & in_nproc + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + ! define log file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namvar ) + + ! match variable with file + tl_multi=multi_init(cn_varfile) + + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE LAYOUT: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + IF( .NOT. ASSOCIATED(tl_multi%t_mpp) .AND. tl_multi%i_nmpp /= 1 )THEN + CALL logger_error("CREATE LAYOUT: no (or too much) mpp file to work on. "//& + & "check cn_varfile in namelist.") + CALL logger_fatal("CREATE LAYOUT: no input grid found. "//& + & "check namelist") + ELSE + + CALL multi_print(tl_multi) + + ! open file + tl_file=file_init(TRIM(tl_multi%t_mpp(1)%c_name)) + tl_mpp=mpp_init( tl_file ) + ! clean + CALL file_clean(tl_file) + ! + CALL grid_get_info(tl_mpp) + + CALL iom_mpp_open(tl_mpp) + + cl_var=TRIM((tl_multi%t_mpp(1)%t_proc(1)%t_var(1)%c_name)) + tl_var=iom_mpp_read_var(tl_mpp,cl_var) + + CALL iom_mpp_close(tl_mpp) + ! clean structure + CALL mpp_clean(tl_mpp) + + tl_mppout=mpp_init('layout.nc',tl_var,in_niproc, in_njproc,in_nproc) + + CALL mpp_print(tl_mppout) + + ! clean structure + CALL var_clean(tl_var) + CALL mpp_clean(tl_mppout) + + ENDIF + + ! clean + CALL multi_clean(tl_multi) + + ! close log file + CALL logger_footer() + CALL logger_close() + +END PROGRAM diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_meshmask.f90 b/V4.0/nemo_sources/tools/SIREN/src/create_meshmask.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dadf11b3aa750ec386f1e2f3f86fdbad6d6e145e --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_meshmask.f90 @@ -0,0 +1,1964 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> This program creates the NetCDF file(s) which contain(s) all the +!> ocean domain informations. +!> it also permits to create the domain_cfg.nc file (needed to run NEMO v4.0 +!> and upper), or the mesh_mask file(s). +!> +!> @details +!> @section sec1 method +!> bathymetry (and optionally ice shelf draft) is read on input file.<br/> +!> horizontal grid-point position, scale factors, and the coriolis factor +!> are read in coordinates file or computed.<br/> +!> vertical coordinate is defined, and the bathymetry recomputed to fit the +!> vertical grid.<br/> +!> finally the masks from the bathymetry are computed. +!> +!> all the variables read and or computed, are writen in one to three file(s) depending on +!> output option. +!> @note +!> the file contain depends on +!> the vertical coordinate used (z-coord, partial steps, s-coord) +!> +!> @section sec2 how to +!> USAGE: create_meshmask create_meshmask.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_meshmask.nam<br/> +!> namelist of create_meshmask +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_meshmask +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_meshmask create_meshmask.nam +!> create_meshmask.nam contains 13 sub-namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source files parameters +!> - **namhgr** to set horizontal grid parameters +!> - **namzgr** to set vertical grid parameters +!> - **namdmin** to set minimum depth parameters +!> - **namzco** to set vertical coordinate parameters +!> - **namzps** to set partial step parameters +!> - **namsco** to set sigma or hybrid parameters +!> - **namlbc** to set lateral boundary condition parameters +!> - **namwd** to set wetting and drying parameters +!> - **namgrd** to set grid parameters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_meshmask.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the source grid sub-namelist parameters are : +!> +!> - **cn_bathy** [@a ]<br/> +!> path to the bathymetry file +!> - **cn_varbathy** [@a ]<br/> +!> bathymetry variable name +!> - **cn_coord** [@a ]<br/> +!> path to the coordinate file (in_mshhgr=0) +!> - **cn_isfdep** [@a ]<br/> +!> iceshelf draft (ln_isfcav=true, see namzgr) +!> - **cn_varisfdep** [@a isfdraft]<br/> +!> iceshelf draft variable name (ln_isfcav=true, see namzgr) +!> - **in_perio** [@a ]<br/> +!> NEMO periodicity +!> - **ln_closea** [@a .TRUE.]<br/> +!> logical to fill closed sea or not +!> +!> @subsection subhgr namhgr +!> the grid sub-namelist parameters are : +!> +!> - **in_mshhgr** [@a 0]<br/> +!> type of horizontal mesh +!> - 0: curvilinear coordinate on the sphere read in coordinate.nc +!> - 1: geographical mesh on the sphere with regular grid-spacing +!> - 2: f-plane with regular grid-spacing +!> - 3: beta-plane with regular grid-spacing +!> - 4: Mercator grid with T/U point at the equator +!> - 5: beta-plane with regular grid-spacing and rotated domain (GYRE configuration) +!> - **dn_ppglam0** [@a ]<br/> +!> longitude of first raw and column T-point (in_mshhgr = 1 or 4) +!> - **dn_ppgphi0** [@a ]<br/> +!> latitude of first raw and column T-point (in_mshhgr = 1 or 4) +!> - **dn_ppe1_deg** [@a ]<br/> +!> zonal grid-spacing (degrees) (in_mshhgr = 1,2,3 or 4) +!> - **dn_ppe2_deg** [@a ]<br/> +!> meridional grid-spacing (degrees) (in_mshhgr = 1,2,3 or 4) +!> +!> +!> @subsection subzgr namzgr +!> the vertical grid sub-namelist parameters are : +!> +!> - **ln_zco** [@a .FALSE.]<br/> +!> z-coordinate - full steps +!> - **ln_zps** [@a .FALSE.]<br/> +!> z-coordinate - partial steps +!> - **ln_sco** [@a .FALSE.]<br/> +!> s- or hybrid z-s-coordinate +!> - **ln_isfcav** [@a .FALSE.]<br/> +!> ice shelf cavities +!> - **ln_iscpl** [@a .FALSE.]<br/> +!> coupling with ice sheet +!> - **ln_wd** [@a .FALSE.]<br/> +!> Wetting/drying activation +!> - **in_nlevel** [@a 75]<br/> +!> number of vertical level +!> +!> @subsection subdmin namdmin +!> the minimum depth sub-namelist parameters are : +!> +!> - **dn_hmin** [@a ]<br/> +!> minimum ocean depth (>0) or minimum number of ocean levels (<0) +!> - **dn_isfhmin** [@a ]<br/> +!> threshold to discriminate grounded ice to floating ice +!> +!> @subsection subzco namzco +!> the vertical coordinate sub-namelist parameters are : +!> +!> - **dn_pp_to_be_computed** [@a 0]<br/> +!> +!> - **dn_ppsur** [@a -3958.951371276829]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa0** [@a 103.953009600000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa1** [@a 2.415951269000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppkth** [@a 15.351013700000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppacr** [@a 7.000000000000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppdzmin** [@a 6.]<br/> +!> minimum vertical spacing +!> +!> - **dn_pphmax** [@a 5750.]<br/> +!> maximum depth +!> +!> - @b ln_dbletanh [@a .TRUE.]<br/> +!> use double tanh to compute vartical grid +!> +!> - **dn_ppa2** [@a 100.760928500000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppkth2** [@a 48.029893720000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppacr2** [@a 13.000000000000]<br/> +!> double tanh function parameter +!> +!> @note +!> If *dn_ppa1*, *dn_ppa0* and *dn_ppsur* are undefined, +!> NEMO will compute them from *dn_ppdzmin, dn_pphmax, dn_ppkth, dn_ppacr* +!> +!> @warning +!> this namelist is also needed to define partial steps, sigma or hybrid coordinate. +!> +!> @subsection subzps namzps +!> the partial step sub-namelist parameters are : +!> +!> - **dn_e3zps_min** [@a 25.]<br/> +!> minimum thickness of partial step level (meters) +!> - **dn_e3zps_rat** [@a 0.2]<br/> +!> minimum thickness ratio of partial step level +!> +!> +!> @subsection subsco namsco +!> the sigma or hybrid sub-namelist parameters are : +!> +!> - **ln_s_sh94** [@a .FALSE.]<br/> +!> use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 +!> - **ln_s_sf12** [@a .FALSE.]<br/> +!> use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma +!> - **dn_sbot_min** [@a ]<br/> +!> minimum depth of s-bottom surface (>0) (m) +!> - **dn_sbot_max** [@a ]<br/> +!> maximum depth of s-bottom surface (= ocean depth) (>0) (m) +!> - **dn_hc** [@a ]<br/> +!> Critical depth for transition from sigma to stretched coordinates +!> <br/> <br/> +!> Song and Haidvogel 1994 stretching additional parameters +!> - **dn_rmax** [@a ]<br/> +!> maximum cut-off r-value allowed (0<dn_rmax<1) +!> - **dn_theta** [@a ]<br/> +!> surface control parameter (0<=dn_theta<=20) +!> - **dn_thetb** [@a ]<br/> +!> bottom control parameter (0<=dn_thetb<= 1) +!> - **dn_bb** [@a ]<br/> +!> stretching parameter ( dn_bb=0; top only, dn_bb =1; top and bottom) +!> <br/> <br/> +!> Siddorn and Furner stretching additional parameters +!> - **ln_sigcrit** [@a .FALSE.]<br/> +!> switching to sigma (T) or Z (F) at H<Hc +!> - **dn_alpha** [@a ]<br/> +!> stretchin parameter ( >1 surface; <1 bottom) +!> - **dn_efold** [@a ]<br/> +!> e-fold length scale for transition region +!> - **dn_zs** [@a ]<br/> +!> Surface cell depth (Zs) (m) +!> <br/> +!> Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' +!> - **dn_zb_a** [@a ]<br/> +!> Bathymetry multiplier for Zb +!> - **dn_zb_b** [@a ]<br/> +!> Offset for Zb +!> +!> @subsection sublbc namlbc +!> the lateral boundary condition sub-namelist parameters are : +!> +!> - **rn_shlat** [@a 2.]<br/> +!> lateral boundary conditions at the coast (modify fmask) +!> - shlat = 0 : free slip +!> - 0 < shlat < 2 : partial slip +!> - shlat = 2 : no slip +!> - shlat > 2 : strong slip +!> +!> for more information see Boundary Condition at the Coast +!> in [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subwd namwd +!> the wetting and drying sub-namelist parameters are : +!> +!> - **dn_wdmin1** [@a ]<br/> +!> minimum water depth on dried cells +!> - **dn_wdmin2** [@a ]<br/> +!> tolerrance of minimum water depth on dried cells +!> - **dn_wdld** [@a ]<br/> +!> land elevation below which wetting/drying +!> +!> @subsection subgrd namgrd +!> the grid sub-namelist parameters are : +!> +!> - **in_cfg** [@a 0]<br/> +!> inverse resolution of the configuration (1/4° => 4) +!> - **ln_bench** [@a .FALSE.]<br/> +!> GYRE (in_mshhgr = 5 ) used as Benchmark.<br/> +!> => forced the resolution to be about 100 km +!> - **ln_c1d** [@a .FALSE.]<br/> +!> use configuration 1D +!> - **ln_e3_dep** [@a .FALSE.]<br/> +!> vertical scale factors =T: e3.=dk[depth] =F: old definition +!> +!> @subsection subout namout +!> the output sub-namelist parameters are : +!> +!> - **cn_domcfg** [@a domain_cfg.nc]<br/> +!> output file name +!> - **in_msh** [@a 0]<br/> +!> number of output file and contain (0-9) +!> - **in_nproc** [@a 1]<br/> +!> number of processor to be used +!> - **in_niproc** [@a 1]<br/> +!> i-direction number of processor +!> - **in_njproc** [@a 1]<br/> +!> j-direction numebr of processor +!> +!> - if niproc, and njproc are provided : the program only look for land +!> processor to be removed +!> - if nproc is provided : the program compute each possible domain layout, +!> and save the one with the most land processor to be removed +!> - with no information about number of processors, the program +!> assume to use only one processor +!> +!> @note +!> - if in_msh = 0 : write '**domain_cfg.nc**' file. +!> - if MOD(in_msh, 3) = 1 : write '<b>mesh_mask.nc</b>' file. +!> - if MOD(in_msh, 3) = 2 : write '<b>mesh.nc</b>' and '<b>mask.nc</b>' files. +!> - if MOD(in_msh, 3) = 0 : write '<b>mesh_hgr.nc</b>', '<b>mesh_zgr.nc</b>' and '<b>mask.nc</b>' files.<br/> +!> For huge size domain, use option 2 or 3 depending on your vertical coordinate.<br/> +!> +!> @note +!> - if 0 < in_msh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw] +!> - if 3 < in_msh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays +!> corresponding to the depth of the bottom t- and w-points +!> - if 6 < in_msh <= 9: write 2D arrays corresponding to the depth and the +!> thickness (e3[tw]_ps) of the bottom points +!> +!> <hr> +!> @author J.Paul +!> +!> @date September, 2015 - Initial Version (based on domhgr.F90, domzgr.F90, domwri.F90) +!> @date October, 2016 +!> - update from trunk (revision 6961): add wetting and drying, ice sheet coupling.. +!> @date October, 2016 +!> - dimension to be used select from configuration file +!> - do not use anymore special case for ORCA grid +!> - allow to write domain_cfg file +!> @date November, 2016 +!> - choose vertical scale factors (e3.=dk[depth] or old definition) +!> @date January, 2019 +!> - add url path to global attributes of output file(s) +!> @date February, 2019 +!> - rename sub namelist namin to namsrc +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_meshmask + + USE global ! global variable + USE kind ! F90 kind parameter + USE phycst ! physical constant + USE logger ! log file manager + USE date ! date manager + USE fct ! basic useful function + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE mpp ! MPP manager + USE iom_mpp ! I/O MPP manager + USE lbc ! lateral boundary conditions + USE grid + USE grid_hgr + USE grid_zgr + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_meshmask" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_url + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i1), DIMENSION(:) , ALLOCATABLE :: bl_tmp + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_ew + INTEGER(i4) :: jpi + INTEGER(i4) :: jpj + INTEGER(i4) :: jpk + INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_tmp + INTEGER(i4), DIMENSION(:,:) , ALLOCATABLE :: il_mask + + LOGICAL :: ll_exist + LOGICAL :: ll_domcfg + + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_tmp2D + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_tmp3D + + TYPE(TATT) :: tl_att + TYPE(TATT) , DIMENSION(:) , ALLOCATABLE :: tl_gatt + + TYPE(TDIM) :: tl_dim + + TYPE(TVAR) :: tl_bathy + TYPE(TVAR) :: tl_risfdep + TYPE(TVAR) :: tl_misf + TYPE(TVAR) :: tl_gdepu + TYPE(TVAR) :: tl_gdepv + TYPE(TVAR) :: tl_hdept + TYPE(TVAR) :: tl_hdepw + TYPE(TVAR) :: tl_scalar + + TYPE(TNAMH) :: tl_namh + TYPE(TNAMZ) :: tl_namz + + TYPE(TMPP) :: tl_mpp + TYPE(TMPP) , TARGET :: tl_mppout0 + TYPE(TMPP) , TARGET :: tl_mppout1 + TYPE(TMPP) , TARGET :: tl_mppout2 + TYPE(TMPP) , POINTER :: tl_mppmsk + TYPE(TMPP) , POINTER :: tl_mpphgr + TYPE(TMPP) , POINTER :: tl_mppzgr + + ! parameter + INTEGER(i4) , PARAMETER :: ip_maxatt = 40 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + + INTEGER(i4) :: ik + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_meshmask.log' + CHARACTER(LEN=lc) :: cn_verbosity= 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_bathy = '' + CHARACTER(LEN=lc) :: cn_varbathy = '' + CHARACTER(LEN=lc) :: cn_coord = '' + CHARACTER(LEN=lc) :: cn_isfdep = '' + CHARACTER(LEN=lc) :: cn_varisfdep= 'isfdraft' + INTEGER(i4) :: in_perio = -1 + LOGICAL :: ln_closea = .TRUE. + + ! namzgr + LOGICAL :: ln_zco = .FALSE. + LOGICAL :: ln_zps = .FALSE. + LOGICAL :: ln_sco = .FALSE. + LOGICAL :: ln_isfcav = .FALSE. + LOGICAL :: ln_iscpl = .FALSE. + LOGICAL :: ln_wd = .FALSE. + INTEGER(i4) :: in_nlevel = 75 + + ! namlbc + REAL(sp) :: rn_shlat = 2. + + ! namout + CHARACTER(LEN=lc) :: cn_domcfg = 'domain_cfg.nc' + INTEGER(i4) :: in_msh = 0 + CHARACTER(LEN=lc) :: cn_type = 'cdf' + INTEGER(i4) :: in_nproc = 0 + INTEGER(i4) :: in_niproc = 0 + INTEGER(i4) :: in_njproc = 0 + !------------------------------------------------------------------- + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source namelist + & cn_bathy, & !< Bathymetry file + & cn_varbathy, & !< Bathymetry variable name + & cn_coord, & !< Coordinate file (in_mshhgr=0) + & cn_isfdep, & !< Iceshelf draft (ln_isfcav=true) + & cn_varisfdep, & !< Iceshelf draft variable name (ln_isfcav=true) + & in_perio, & !< NEMO periodicity + & ln_closea + + NAMELIST /namzgr/ & + & ln_zco, & !< z-coordinate + & ln_zps, & !< z-coordinate with partial steps + & ln_sco, & !< s-coordinate + & ln_isfcav, & !< presence of ISF + & ln_iscpl, & !< coupling with ice sheet + & ln_wd, & !< Wetting/drying activation + & in_nlevel + + NAMELIST /namlbc/ & + & rn_shlat !< lateral momentum boundary condition + + NAMELIST /namout/ & !< output namlist + & cn_domcfg, & !< output file name + & in_msh, & !< number of output file (1,2,3) + & in_nproc, & !< number of processor to be used + & in_niproc, & !< i-direction number of processor + & in_njproc !< j-direction numebr of processor + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + + ! define logger file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namzgr ) + READ( il_fileid, NML = namlbc ) + + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE MASK: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + ll_domcfg=.FALSE. + IF( in_msh == 0 )THEN + ll_domcfg=.TRUE. + ENDIF + + ! open file + IF( cn_bathy /= '' )THEN + tl_mpp=mpp_init( file_init(TRIM(cn_bathy)), id_perio=in_perio) + CALL grid_get_info(tl_mpp) + ELSE + CALL logger_fatal("CREATE MESH MASK: no input bathymetry file found. "//& + & "check namelist") + ENDIF + + ! read bathymetry + WRITE(*,*) 'FILE TO BE USED:',TRIM(cn_bathy) + CALL iom_mpp_open(tl_mpp) + + ! get dimension + jpi=tl_mpp%t_dim(jp_I)%i_len + jpj=tl_mpp%t_dim(jp_J)%i_len + jpk=in_nlevel + + WRITE(*,*) 'DIMENSION TO BE USED :',jpi,jpj,jpk + + ! read variable + IF( TRIM(cn_varbathy) == '' )THEN + IF( ln_zco )THEN + cn_varbathy='Bathy_level' + ELSEIF( ln_zps .OR. ln_sco )THEN + IF( ln_isfcav )THEN + cn_varbathy='Bathymetry_isf' + ELSE + cn_varbathy='Bathymetry' + ENDIF + ENDIF + ENDIF + WRITE(*,*) 'VARIABLE READ : '//TRIM(cn_varbathy) + tl_bathy=iom_mpp_read_var(tl_mpp, TRIM(cn_varbathy)) + CALL iom_mpp_close(tl_mpp) + + WHERE( tl_bathy%d_value(:,:,1,1) == tl_bathy%d_fill .OR. & + & tl_bathy%d_value(:,:,1,1) < 0._dp ) + tl_bathy%d_value(:,:,1,1) = 0._dp + END WHERE + + IF ( ln_isfcav ) THEN + WRITE(*,*) 'ICESHELF DRAFT FILE TO BE USED:',TRIM(cn_isfdep) + WRITE(*,*) 'ICESHELF VARIABLE READ : '//TRIM(cn_varisfdep) + ! open Iceshelf draft + IF( cn_isfdep /= '' )THEN + tl_mpp=mpp_init( file_init(TRIM(cn_isfdep)), id_perio=in_perio) + CALL grid_get_info(tl_mpp) + ELSE + CALL logger_fatal("CREATE MESH MASK: no input Iceshelf draft '//& + & 'file found. check namelist") + ENDIF + + ! read Iceshelf draft + CALL iom_mpp_open(tl_mpp) + IF( ln_zps .OR. ln_sco ) THEN + tl_risfdep=iom_mpp_read_var(tl_mpp, cn_varisfdep) + ENDIF + CALL iom_mpp_close(tl_mpp) + ELSE + ALLOCATE(dl_tmp2D(jpi,jpj)) + dl_tmp2D(:,:)=0._dp + + tl_risfdep=var_init(cn_varisfdep, dl_tmp2D(:,:), id_type=NF90_DOUBLE) + + DEALLOCATE(dl_tmp2D) + ENDIF + + ! fill closed sea + IF( ln_closea )THEN + WRITE(*,*) "CLOSED SEA" + ALLOCATE( il_mask(tl_bathy%t_dim(1)%i_len, & + & tl_bathy%t_dim(2)%i_len) ) + + ! split domain in N sea subdomain + il_mask(:,:)=grid_split_domain(tl_bathy) + + ! fill smallest domain + CALL grid_fill_small_dom( tl_bathy, il_mask(:,:) ) + + DEALLOCATE( il_mask ) + ENDIF + + in_perio = tl_mpp%i_perio + il_ew = tl_mpp%i_ew + + ! clean + CALL mpp_clean(tl_mpp) + + ! Horizontal mesh (dom_hgr) ------------------------------------------------- + tl_namh=grid_hgr_nam( cn_coord, in_perio, cl_namelist ) + + ! init Horizontal grid global variable + CALL grid_hgr_init(jpi,jpj,jpk,ll_domcfg) + + ! compute horizontal mesh + WRITE(*,*) "COMPUTE HORIZONTAL MESH" + CALL grid_hgr_fill(tl_namh,jpi,jpj,ll_domcfg) + + ! Vertyical mesh (dom_zgr) ------------------------------------------------- + tl_namz=grid_zgr_nam( cn_coord, in_perio, cl_namelist ) + + ! init Vertical grid global variable + CALL grid_zgr_init(jpi,jpj,jpk,ln_sco) + IF( ln_zps ) CALL grid_zgr_zps_init(jpi,jpj) + IF( ln_sco ) CALL grid_zgr_sco_init(jpi,jpj) + + ! compute vertical mesh + WRITE(*,*) "COMPUTE VERTICAL MESH" + CALL grid_zgr_fill( tl_namz,jpi,jpj,jpk, tl_bathy, tl_risfdep ) + + ! compute masks + WRITE(*,*) "COMPUTE MASK" + CALL create_meshmask__mask(tl_namh,jpi,jpj,jpk,ll_domcfg) + + ! Maximum stiffness ratio/hydrostatic consistency + IF( ln_sco ) CALL grid_zgr_sco_stiff(tl_namz,jpi,jpj,jpk) + + ! clean + CALL var_clean(tl_bathy) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! create ouptut structure + IF( in_niproc == 0 .AND. & + & in_njproc == 0 .AND. & + & in_nproc == 0 )THEN + in_niproc = 1 + in_njproc = 1 + in_nproc = 1 + ENDIF + + WRITE(*,*) "WRITE FILE(S)" + IF( ll_domcfg )THEN + ! ! ============================ + ! ! create 'domain_cfg.nc' file + ! ! ============================ + tl_mppout0=mpp_init( cn_domcfg, tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + + tl_mppmsk=>tl_mppout0 + tl_mpphgr=>tl_mppout0 + tl_mppzgr=>tl_mppout0 + + ELSE + SELECT CASE ( MOD(in_msh, 3) ) + ! ! ============================ + CASE ( 1 ) ! create 'mesh_mask.nc' file + ! ! ============================ + tl_mppout0=mpp_init( 'mesh_mask.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + + tl_mppmsk=>tl_mppout0 + tl_mpphgr=>tl_mppout0 + tl_mppzgr=>tl_mppout0 + + ! ! ============================ + CASE ( 2 ) ! create 'mesh.nc' and + ! ! 'mask.nc' files + ! ! ============================ + tl_mppout0=mpp_init( 'mask.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + tl_mppout1=mpp_init( 'mesh.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + + tl_mppmsk=>tl_mppout0 + tl_mpphgr=>tl_mppout1 + tl_mppzgr=>tl_mppout1 + + ! ! ============================ + CASE ( 0 ) ! create 'mesh_hgr.nc' + ! ! 'mesh_zgr.nc' and + ! ! 'mask.nc' files + ! ! ============================ + tl_mppout0=mpp_init( 'mask.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + tl_mppout1=mpp_init( 'mesh_hgr.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + tl_mppout2=mpp_init( 'mesh_zgr.nc', tg_tmask, & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type ) + ! + + tl_mppmsk=>tl_mppout0 + tl_mpphgr=>tl_mppout1 + tl_mppzgr=>tl_mppout2 + + END SELECT + ENDIF + + ! add variables + IF( ll_domcfg )THEN + ALLOCATE(il_tmp(1)) + tl_dim%l_use=.FALSE. + + il_tmp(:)=jpi + tl_scalar=var_init('jpiglo', il_tmp(:), id_type=NF90_INT, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + il_tmp(:)=jpj + tl_scalar=var_init('jpjglo', il_tmp(:), id_type=NF90_INT, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + il_tmp(:)=jpk + tl_scalar=var_init('jpkglo', il_tmp(:), id_type=NF90_INT, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + il_tmp(:)=tl_mppout0%i_perio + tl_scalar=var_init('jperio', il_tmp(:), id_type=NF90_INT, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + DEALLOCATE(il_tmp) + ALLOCATE(bl_tmp(1)) + + bl_tmp(:)=0 + IF( ln_zco ) bl_tmp(:)=1 + tl_scalar=var_init('ln_zco',bl_tmp(:), id_type=NF90_BYTE, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + bl_tmp(:)=0 + IF( ln_zps ) bl_tmp(:)=1 + tl_scalar=var_init('ln_zps',bl_tmp(:), id_type=NF90_BYTE, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + bl_tmp(:)=0 + IF( ln_sco ) bl_tmp(:)=1 + tl_scalar=var_init('ln_sco',bl_tmp(:), id_type=NF90_BYTE, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + bl_tmp(:)=0 + IF( ln_isfcav ) bl_tmp(:)=1 + tl_scalar=var_init('ln_isfcav',bl_tmp(:), id_type=NF90_BYTE, td_dim=tl_dim) + CALL mpp_add_var(tl_mppmsk, tl_scalar) + + DEALLOCATE(bl_tmp) + CALL var_clean(tl_scalar) + ENDIF + + !!! mask (msk) + !!!---------------------- + IF( .NOT. ll_domcfg )THEN + ! tmask + CALL mpp_add_var(tl_mppmsk, tg_tmask) + CALL var_clean(tg_tmask) + ! umask + CALL mpp_add_var(tl_mppmsk, tg_umask) + CALL var_clean(tg_umask) + ! vmask + CALL mpp_add_var(tl_mppmsk, tg_vmask) + CALL var_clean(tg_vmask) + ! fmask + CALL mpp_add_var(tl_mppmsk, tg_fmask) + CALL var_clean(tg_fmask) + ENDIF + + !!! horizontal mesh (hgr) + !!!---------------------- + + ! latitude + ! glamt + CALL mpp_add_var(tl_mpphgr, tg_glamt) + CALL var_clean(tg_glamt) + ! glamu + CALL mpp_add_var(tl_mpphgr, tg_glamu) + CALL var_clean(tg_glamu) + ! glamV + CALL mpp_add_var(tl_mpphgr, tg_glamv) + CALL var_clean(tg_glamv) + ! glamf + CALL mpp_add_var(tl_mpphgr, tg_glamf) + CALL var_clean(tg_glamf) + + ! longitude + ! gphit + CALL mpp_add_var(tl_mpphgr, tg_gphit) + CALL var_clean(tg_gphit) + ! gphiu + CALL mpp_add_var(tl_mpphgr, tg_gphiu) + CALL var_clean(tg_gphiu) + ! gphiv + CALL mpp_add_var(tl_mpphgr, tg_gphiv) + CALL var_clean(tg_gphiv) + ! gphif + CALL mpp_add_var(tl_mpphgr, tg_gphif) + CALL var_clean(tg_gphif) + + ! e1 scale factors + ! e1t + CALL mpp_add_var(tl_mpphgr, tg_e1t) + CALL var_clean(tg_e1t) + ! e1u + CALL mpp_add_var(tl_mpphgr, tg_e1u) + CALL var_clean(tg_e1u) + ! e1v + CALL mpp_add_var(tl_mpphgr, tg_e1v) + CALL var_clean(tg_e1v) + ! e1f + CALL mpp_add_var(tl_mpphgr, tg_e1f) + CALL var_clean(tg_e1f) + + ! e2 scale factors + ! e2t + CALL mpp_add_var(tl_mpphgr, tg_e2t) + CALL var_clean(tg_e2t) + ! e2u + CALL mpp_add_var(tl_mpphgr, tg_e2u) + CALL var_clean(tg_e2u) + ! e2v + CALL mpp_add_var(tl_mpphgr, tg_e2v) + CALL var_clean(tg_e2v) + ! e2f + CALL mpp_add_var(tl_mpphgr, tg_e2f) + CALL var_clean(tg_e2f) + + ! coriolis factor + ! ff_t + CALL mpp_add_var(tl_mpphgr, tg_ff_t) + CALL var_clean(tg_ff_t) + ! ff_f + CALL mpp_add_var(tl_mpphgr, tg_ff_f) + CALL var_clean(tg_ff_f) + + ! angles + IF( .NOT. ll_domcfg )THEN + ! cost + CALL mpp_add_var(tl_mpphgr, tg_gcost) + CALL var_clean(tg_gcost) + ! cosu + CALL mpp_add_var(tl_mpphgr, tg_gcosu) + CALL var_clean(tg_gcosu) + ! cosv + CALL mpp_add_var(tl_mpphgr, tg_gcosv) + CALL var_clean(tg_gcosv) + ! cosf + CALL mpp_add_var(tl_mpphgr, tg_gcosf) + CALL var_clean(tg_gcosf) + + ! sint + CALL mpp_add_var(tl_mpphgr, tg_gsint) + CALL var_clean(tg_gsint) + ! sinu + CALL mpp_add_var(tl_mpphgr, tg_gsinu) + CALL var_clean(tg_gsinu) + ! sinv + CALL mpp_add_var(tl_mpphgr, tg_gsinv) + CALL var_clean(tg_gsinv) + ! sinf + CALL mpp_add_var(tl_mpphgr, tg_gsinf) + CALL var_clean(tg_gsinf) + ENDIF + + !!! vertical mesh (zgr) + !!!---------------------- + ! note that mbkt is set to 1 over land ==> use surface tmask + ! + ! mbathy + tg_mbathy%d_value(:,:,:,:) = tg_ssmask%d_value(:,:,:,:) * & + & tg_mbkt%d_value(:,:,:,:) + ! + IF( ll_domcfg )THEN + tg_mbathy%c_name='bottom_level' + ENDIF + CALL mpp_add_var(tl_mppzgr, tg_mbathy) + CALL var_clean(tg_mbathy) + + ! misf + ALLOCATE(dl_tmp2D(jpi,jpj)) + dl_tmp2D(:,:)=dp_fill + + tl_misf =var_init('misf ',dl_tmp2D(:,:), id_type=NF90_INT) + + DEALLOCATE(dl_tmp2D) + tl_misf%d_value(:,:,1,1) = tg_ssmask%d_value(:,:,1,1) * & + & tg_mikt%d_value(:,:,1,1) + ! + IF( ll_domcfg ) tl_misf%c_name='top_level' + CALL mpp_add_var(tl_mppzgr, tl_misf) + CALL var_clean(tl_misf) + + IF( .NOT. ll_domcfg )THEN + ! isfdraft + tl_risfdep%d_value(:,:,:,:) = tl_risfdep%d_value(:,:,:,:) * & + & tg_mikt%d_value(:,:,:,:) + + CALL mpp_add_var(tl_mppzgr, tl_risfdep) + CALL var_clean(tl_risfdep) + ENDIF + + IF( ln_sco ) THEN ! s-coordinate + + IF( .NOT. ll_domcfg )THEN + ! hbatt + CALL mpp_add_var(tl_mppzgr, tg_hbatt) + CALL var_clean(tg_hbatt) + ! hbatu + CALL mpp_add_var(tl_mppzgr, tg_hbatu) + CALL var_clean(tg_hbatu) + ! hbatv + CALL mpp_add_var(tl_mppzgr, tg_hbatv) + CALL var_clean(tg_hbatv) + ! hbatf + CALL mpp_add_var(tl_mppzgr, tg_hbatf) + CALL var_clean(tg_hbatf) + + ! scaling coef. + IF( .NOT. (tl_namz%l_s_sh94 .OR. tl_namz%l_s_sf12) )THEN + ! gsigt + CALL mpp_add_var(tl_mppzgr, tg_gsigt) + CALL var_clean(tg_gsigt) + ! gsigw + CALL mpp_add_var(tl_mppzgr, tg_gsigw) + CALL var_clean(tg_gsigw) + ! gsi3w + CALL mpp_add_var(tl_mppzgr, tg_gsi3w) + CALL var_clean(tg_gsi3w) + ! esigt + CALL mpp_add_var(tl_mppzgr, tg_esigt) + CALL var_clean(tg_esigt) + ! esigw + CALL mpp_add_var(tl_mppzgr, tg_esigw) + CALL var_clean(tg_esigw) + ENDIF + ENDIF + + ! scale factors + ! e3t_0 + CALL mpp_add_var(tl_mppzgr, tg_e3t_0) + CALL var_clean(tg_e3t_0) + ! e3u_0 + CALL mpp_add_var(tl_mppzgr, tg_e3u_0) + CALL var_clean(tg_e3u_0) + ! e3v_0 + CALL mpp_add_var(tl_mppzgr, tg_e3v_0) + CALL var_clean(tg_e3v_0) + ! e3f_0 + CALL mpp_add_var(tl_mppzgr, tg_e3f_0) + CALL var_clean(tg_e3f_0) + ! e3w_0 + CALL mpp_add_var(tl_mppzgr, tg_e3w_0) + CALL var_clean(tg_e3w_0) + ! e3uw_0 + CALL mpp_add_var(tl_mppzgr, tg_e3uw_0) + CALL var_clean(tg_e3uw_0) + ! e3vw_0 + CALL mpp_add_var(tl_mppzgr, tg_e3vw_0) + CALL var_clean(tg_e3vw_0) + + ! Max. grid stiffness ratio + ! rx1 + IF( ll_domcfg ) tg_rx1%c_name='stiffness' + CALL mpp_add_var(tl_mppzgr, tg_rx1) + CALL var_clean(tg_rx1) + + ! stretched system + IF( .NOT. tl_namz%l_e3_dep )THEN + ! gdept_1d + CALL mpp_add_var(tl_mppzgr, tg_gdept_1d) + CALL var_clean(tg_gdept_1d) + ! gdepw_1d + CALL mpp_add_var(tl_mppzgr, tg_gdepw_1d) + CALL var_clean(tg_gdepw_1d) + + ! gdept_0 + CALL mpp_add_var(tl_mppzgr, tg_gdept_0) + CALL var_clean(tg_gdept_0) + ! gdepw_0 + CALL mpp_add_var(tl_mppzgr, tg_gdepw_0) + CALL var_clean(tg_gdepw_0) + ENDIF + + ENDIF + + IF( ln_zps ) THEN ! z-coordinate - partial steps + + IF( ll_domcfg .OR. in_msh <= 6 ) THEN ! 3D vertical scale factors + + ! e3t_0 + CALL mpp_add_var(tl_mppzgr, tg_e3t_0) + CALL var_clean(tg_e3t_0) + ! e3u_0 + CALL mpp_add_var(tl_mppzgr, tg_e3u_0) + CALL var_clean(tg_e3u_0) + ! e3v_0 + CALL mpp_add_var(tl_mppzgr, tg_e3v_0) + CALL var_clean(tg_e3v_0) + ! e3w_0 + CALL mpp_add_var(tl_mppzgr, tg_e3w_0) + CALL var_clean(tg_e3w_0) + + ELSE + + DO jj = 1,jpj + DO ji = 1,jpi + ik=tg_mbkt%d_value(ji,jj,1,1) + tg_e3tp%d_value(ji,jj,1,1) = tg_e3t_0%d_value(ji,jj,ik,1) * & + & tg_ssmask%d_value(ji,jj,1,1) + tg_e3wp%d_value(ji,jj,1,1) = tg_e3w_0%d_value(ji,jj,ik,1) * & + & tg_ssmask%d_value(ji,jj,1,1) + END DO + END DO + ! e3t_ps + CALL mpp_add_var(tl_mppzgr, tg_e3tp) + CALL var_clean(tg_e3tp) + ! e3w_ps + CALL mpp_add_var(tl_mppzgr, tg_e3wp) + CALL var_clean(tg_e3wp) + + ENDIF ! 3D vertical scale factors + + IF( ll_domcfg .OR. in_msh <= 3 ) THEN ! 3D depth + + IF( .NOT. tl_namz%l_e3_dep )THEN + + ! gdepu, gdepv + IF( .NOT. ll_domcfg )THEN + ALLOCATE(dl_tmp3D(jpi,jpj,jpk)) + dl_tmp3D(:,:,:)=dp_fill + + tl_gdepu=var_init('gdepu',dl_tmp3D(:,:,:), id_type=NF90_FLOAT) + tl_gdepv=var_init('gdepv',dl_tmp3D(:,:,:), id_type=NF90_FLOAT) + + DEALLOCATE(dl_tmp3D) + DO jk = 1,jpk + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 ! vector opt. + tl_gdepu%d_value(ji,jj,jk,1) = MIN( tg_gdept_0%d_value(ji ,jj ,jk,1) , & + & tg_gdept_0%d_value(ji+1,jj ,jk,1) ) + + tl_gdepv%d_value(ji,jj,jk,1) = MIN( tg_gdept_0%d_value(ji ,jj ,jk,1) , & + & tg_gdept_0%d_value(ji ,jj+1,jk,1) ) + END DO + END DO + END DO + CALL lbc_lnk( tl_gdepu%d_value(:,:,:,1), 'U', in_perio, 1._dp ) + CALL lbc_lnk( tl_gdepv%d_value(:,:,:,1), 'V', in_perio, 1._dp ) + + ! gdepu + CALL mpp_add_var(tl_mppzgr, tl_gdepu) + CALL var_clean(tl_gdepu) + ! gdepv + CALL mpp_add_var(tl_mppzgr, tl_gdepv) + CALL var_clean(tl_gdepv) + ENDIF + + ! gdept_0 + CALL mpp_add_var(tl_mppzgr, tg_gdept_0) + CALL var_clean(tg_gdept_0) + + ! gdepw_0 + CALL mpp_add_var(tl_mppzgr, tg_gdepw_0) + CALL var_clean(tg_gdepw_0) + ENDIF + + ELSE ! 2D bottom depth + ALLOCATE(dl_tmp2D(jpi,jpj)) + dl_tmp2D(:,:)=dp_fill + + tl_hdept=var_init('hdept',dl_tmp2D(:,:), id_type=NF90_INT) + tl_hdepw=var_init('hdepw',dl_tmp2D(:,:), id_type=NF90_INT) + + DEALLOCATE(dl_tmp2D) + DO jj = 1,jpj + DO ji = 1,jpi + ik=tg_mbkt%d_value(ji,jj,1,1) + tl_hdept%d_value(ji,jj,1,1) = tg_gdept_0%d_value(ji,jj,ik ,1) * tg_ssmask%d_value(ji,jj,1,1) + tl_hdepw%d_value(ji,jj,1,1) = tg_gdepw_0%d_value(ji,jj,ik+1,1) * tg_ssmask%d_value(ji,jj,1,1) + END DO + END DO + ! hdept + CALL mpp_add_var(tl_mppzgr, tl_hdept) + CALL var_clean(tl_hdept) + ! hdepw + CALL mpp_add_var(tl_mppzgr, tl_hdepw) + CALL var_clean(tl_hdepw) + + ! clean + CALL var_clean(tg_gdept_0) + + ENDIF ! 3D depth + + ENDIF + + ! scale factors + IF( ll_domcfg )THEN + ! e3t_1d + CALL mpp_add_var(tl_mppzgr, tg_e3t_1d) + CALL var_clean(tg_e3t_1d) + ! e3w_1d + CALL mpp_add_var(tl_mppzgr, tg_e3w_1d) + CALL var_clean(tg_e3w_1d) + ENDIF + + IF( ln_zps .OR. ln_zco )THEN ! z-coordinate + IF( .NOT. tl_namz%l_e3_dep )THEN + ! depth + ! gdept_1d + CALL mpp_add_var(tl_mppzgr, tg_gdept_1d) + CALL var_clean(tg_gdept_1d) + ! gdepw_1d + CALL mpp_add_var(tl_mppzgr, tg_gdepw_1d) + CALL var_clean(tg_gdepw_1d) + ENDIF + ENDIF + + ! define global attributes + ALLOCATE(tl_gatt(ip_maxatt)) + + tl_gatt(:) = create_meshmask__gloatt(cn_bathy,cn_coord,cn_isfdep,tl_namh,tl_namz) + + + IF( in_msh == 0 ) in_msh=1 + SELECT CASE ( MOD(in_msh, 3) ) + CASE ( 1 ) + ! add some attribute + tl_att=att_init("Created_by","SIREN create_meshmask") + CALL mpp_add_att(tl_mppmsk, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL mpp_add_att(tl_mppmsk, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",TRIM(cl_date)) + CALL mpp_add_att(tl_mppmsk, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'periodicity') + ENDIF + IF( in_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',in_perio) + CALL mpp_add_att(tl_mppmsk,tl_att) + ENDIF + + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'ew_overlap') + ENDIF + IF( il_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',il_ew) + CALL mpp_add_att(tl_mppmsk,tl_att) + ENDIF + + ji=1 + DO WHILE( tl_gatt(ji)%c_name /= '' ) + CALL mpp_add_att(tl_mppmsk,tl_gatt(ji)) + ji=ji+1 + ENDDO + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! create file + CALL iom_mpp_create(tl_mppmsk) + + ! write file + CALL iom_mpp_write_file(tl_mppmsk) + ! close file + CALL iom_mpp_close(tl_mppmsk) + + ! clean + CALL mpp_clean(tl_mppmsk) + + CASE ( 2 ) + ! add some attribute + tl_att=att_init("Created_by","SIREN create_meshmask") + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",TRIM(cl_date)) + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'periodicity') + ENDIF + IF( in_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',in_perio) + CALL mpp_add_att(tl_mppmsk,tl_att) + CALL mpp_add_att(tl_mpphgr,tl_att) + ENDIF + + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'ew_overlap') + ENDIF + IF( il_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',il_ew) + CALL mpp_add_att(tl_mppmsk,tl_att) + CALL mpp_add_att(tl_mpphgr,tl_att) + ENDIF + + ji=1 + DO WHILE( tl_gatt(ji)%c_name /= '' ) + CALL mpp_add_att(tl_mppmsk,tl_gatt(ji)) + CALL mpp_add_att(tl_mpphgr,tl_gatt(ji)) + ji=ji+1 + ENDDO + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! create mask file + !----------------- + CALL iom_mpp_create(tl_mppmsk) + + ! write file + CALL iom_mpp_write_file(tl_mppmsk) + ! close file + CALL iom_mpp_close(tl_mppmsk) + + ! clean + CALL mpp_clean(tl_mppmsk) + + ! create mesh file + !----------------- + CALL iom_mpp_create(tl_mpphgr) + + ! write file + CALL iom_mpp_write_file(tl_mpphgr) + ! close file + CALL iom_mpp_close(tl_mpphgr) + + ! clean + CALL mpp_clean(tl_mpphgr) + + CASE(0) + ! add some attribute + tl_att=att_init("Created_by","SIREN create_meshmask") + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + CALL mpp_add_att(tl_mppzgr, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + CALL mpp_add_att(tl_mppzgr, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",TRIM(cl_date)) + CALL mpp_add_att(tl_mppmsk, tl_att) + CALL mpp_add_att(tl_mpphgr, tl_att) + CALL mpp_add_att(tl_mppzgr, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'periodicity') + ENDIF + IF( in_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',in_perio) + CALL mpp_add_att(tl_mppmsk,tl_att) + CALL mpp_add_att(tl_mpphgr,tl_att) + CALL mpp_add_att(tl_mppzgr,tl_att) + ENDIF + + il_attid=0 + IF( ASSOCIATED(tl_mppmsk%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppmsk%t_proc(1)%t_att(:),'ew_overlap') + ENDIF + IF( il_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',il_ew) + CALL mpp_add_att(tl_mppmsk,tl_att) + CALL mpp_add_att(tl_mpphgr,tl_att) + CALL mpp_add_att(tl_mppzgr,tl_att) + ENDIF + + ji=1 + DO WHILE( tl_gatt(ji)%c_name /= '' ) + CALL mpp_add_att(tl_mppmsk,tl_gatt(ji)) + CALL mpp_add_att(tl_mpphgr,tl_gatt(ji)) + CALL mpp_add_att(tl_mppzgr,tl_gatt(ji)) + ji=ji+1 + ENDDO + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! create mask file + !----------------- + CALL iom_mpp_create(tl_mppmsk) + + ! write file + CALL iom_mpp_write_file(tl_mppmsk) + ! close file + CALL iom_mpp_close(tl_mppmsk) + + ! clean + WRITE(*,*) "CLEAN MSK" + CALL mpp_clean(tl_mppmsk) + + ! create mesh_hgr file + !----------------- + CALL iom_mpp_create(tl_mpphgr) + + ! write file + CALL iom_mpp_write_file(tl_mpphgr) + ! close file + CALL iom_mpp_close(tl_mpphgr) + + ! clean + WRITE(*,*) "CLEAN HGR" + CALL mpp_clean(tl_mpphgr) + + ! create mesh_zgr file + !----------------- + WRITE(*,*) "CREATE ZGR" + CALL iom_mpp_create(tl_mppzgr) + + ! write file + WRITE(*,*) "WRITE ZGR" + CALL iom_mpp_write_file(tl_mppzgr) + ! close file + WRITE(*,*) "CLOSE ZGR" + CALL iom_mpp_close(tl_mppzgr) + + ! clean + WRITE(*,*) "CLEAN ZGR" + CALL mpp_clean(tl_mppzgr) + + CASE DEFAULT + CALL logger_fatal("CREATE MESHMASK : something wrong with in_msh("//& + & TRIM(fct_str(in_msh))//"), check your namelist.") + END SELECT + + ! clean + WRITE(*,*) "CLEAN" + CALL att_clean(tl_att) + CALL att_clean(tl_gatt) + + DEALLOCATE(tl_gatt) + + CALL grid_hgr_clean(ll_domcfg) + CALL grid_zgr_clean(ln_sco) + IF( ln_zps ) CALL grid_zgr_zps_clean() + IF( ln_sco ) CALL grid_zgr_sco_clean() + CALL var_clean_extra() + + ! close log file + CALL logger_footer() + CALL logger_close() +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_meshmask__mask(td_nam,jpi,jpj,jpk,ld_domcfg) + !------------------------------------------------------------------- + !> @brief This subroutine compute land/ocean mask arrays at tracer points, + !> horizontal velocity points (u & v), vorticity points (f) and + !> barotropic stream function points (b). + !> + !> @details + !> + !> ** Method : The ocean/land mask is computed from the basin bathymetry in level (mbathy) + !> which is defined or read in dommba. + !> mbathy equals 0 over continental T-point and the number of ocean level over the ocean. + !> + !> At a given position (ji,jj,jk) the ocean/land mask is given by: + !> - t-point : + !> - 0. IF mbathy( ji ,jj) =< 0 + !> - 1. IF mbathy( ji ,jj) >= jk + !> - u-point : + !> - 0. IF mbathy( ji ,jj) or mbathy(ji+1, jj ) =< 0 + !> - 1. IF mbathy( ji ,jj) and mbathy(ji+1, jj ) >= jk. + !> - v-point : + !> - 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) =< 0 + !> - 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) >= jk. + !> - f-point : + !> - 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) or mbathy(ji+1,jj) or mbathy(ji+1,jj+1) =< 0 + !> - 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) and mbathy(ji+1,jj) and mbathy(ji+1,jj+1) >= jk. + !> - b-point : the same definition as for f-point of the first ocean + !> level (surface level) but with 0 along coastlines. + !> - tmask_i : interior ocean mask at t-point, i.e. excluding duplicated + !> rows/lines due to cyclic or North Fold boundaries as well + !> as MPP halos. + !> + !> @warning do not set the lateral friction through the value of fmask along + !> the coast and topography. + !> + !> @note If nperio not equal to 0, the land/ocean mask arrays + !> are defined with the proper value at lateral domain boundaries, + !> but bmask. indeed, bmask defined the domain over which the + !> barotropic stream function is computed. this domain cannot + !> contain identical columns because the matrix associated with + !> the barotropic stream function equation is then no more inverti- + !> ble. therefore bmask is set to 0 along lateral domain boundaries + !> even IF nperio is not zero. + !> + !> In case of open boundaries (lk_bdy=T): + !> - tmask is set to 1 on the points to be computed bay the open + !> boundaries routines. + !> - bmask is set to 0 on the open boundaries. + !> + !> ** Action : + !> - tmask : land/ocean mask at t-point (=0. or 1.) + !> - umask : land/ocean mask at u-point (=0. or 1.) + !> - vmask : land/ocean mask at v-point (=0. or 1.) + !> - fmask : land/ocean mask at f-point (=0. or 1.) + !> - bmask : land/ocean mask at barotropic stream + !> function point (=0. or 1.) and set to 0 along lateral boundaries + !> - tmask_i : interior ocean mask + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from dom_msk + !> @date October, 2016 + !> - do not use anymore special case for ORCA grid + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + INTEGER(i4), INTENT(IN) :: jpk + LOGICAL , INTENT(IN) :: ld_domcfg + + ! local variable +! INTEGER(i4) :: ii0, ii1 ! local integers +! INTEGER(i4) :: ij0, ij1 +! INTEGER(i4) :: isrow + +! INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: imsk + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: zwf + +! REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_tpol +! REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_fpol + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + +! ALLOCATE( imsk(jpi,jpj) ) + +! ALLOCATE( dl_tpol(jpi) ) +! ALLOCATE( dl_fpol(jpi) ) + + CALL logger_info('dommsk : ocean mask ') + CALL logger_info('~~~~~~') + IF ( rn_shlat == 0. )THEN ; CALL logger_info(' ocean lateral free-slip ') + ELSEIF( rn_shlat == 2. )THEN ; CALL logger_info(' ocean lateral no-slip ') + ELSEIF( 0. < rn_shlat .AND. rn_shlat < 2. )THEN ; CALL logger_info(' ocean lateral partial-slip ') + ELSEIF( 2. < rn_shlat )THEN ; CALL logger_info(' ocean lateral strong-slip ') + ELSE ; CALL logger_info(' rn_shlat is negative = '//TRIM(fct_str(rn_shlat))) + ENDIF + + ! 1. Ocean/land mask at t-point (computed from mbathy) + ! ----------------------------- + ! N.B. tmask has already the right boundary conditions since mbathy is ok + ! + tg_tmask%d_value(:,:,:,1) = 0._dp + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_mbathy%d_value(ji,jj,1,1) - REAL(jk,dp) + 0.1_dp >= 0._dp )THEN + tg_tmask%d_value(ji,jj,jk,1) = 1._dp + ENDIF + ENDDO + ENDDO + ENDDO + + ! (ISF) define barotropic mask and mask the ice shelf point + tg_ssmask%d_value(:,:,1,1)=tg_tmask%d_value(:,:,1,1) ! at this stage ice shelf is not masked + + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_misfdep%d_value(ji,jj,1,1) - REAL(jk,dp) - 0.1_dp >= 0._dp ) THEN + tg_tmask%d_value(ji,jj,jk,1) = 0._dp + END IF + ENDDO + ENDDO + ENDDO + +! ! Interior domain mask (used for global sum) +! ! -------------------- +! tg_tmask_i%d_value(:,:,1,1) = tg_ssmask%d_value(:,:,1,1) ! (ISH) tmask_i = 1 even on the ice shelf +! +! tg_tmask_h%d_value(:,:,1,1) = 1._dp ! 0 on the halo and 1 elsewhere +! +! tg_tmask_h%d_value( 1 , : ,1,1) = 0._dp ! first columns +! tg_tmask_h%d_value(jpi, : ,1,1) = 0._dp ! last columns +! tg_tmask_h%d_value( : , 1 ,1,1) = 0._dp ! first rows +! tg_tmask_h%d_value( : ,jpj,1,1) = 0._dp ! last rows +! +! ! north fold mask +! ! --------------- +! dl_tpol(1:jpi) = 1._dp +! dl_fpol(1:jpi) = 1._dp +! IF( td_nam%i_perio == 3 .OR. td_nam%i_perio == 4 )THEN ! T-point pivot +! dl_tpol(jpi/2+1:jpi) = 0._dp +! dl_fpol( 1 :jpi) = 0._dp +! IF( mjg(nlej) == jpj ) THEN ! only half of the nlcj-1 row +! DO ji = iif+1, iil-1 +! tg_tmask_h%d_value(ji,nlej-1,1,1) = tg_tmask_h%d_value(ji,nlej-1,1,1) * dl_tpol(mig(ji)) +! END DO +! ENDIF +! ENDIF +! +! tg_tmask_i%d_value(:,:,1,1) = tg_tmask_i%d_value(:,:,1,1) * tg_tmask_h%d_value(:,:,1,1) +! +! IF( td_nam%i_perio == 5 .OR. td_nam%i_perio == 6 )THEN ! F-point pivot +! dl_tpol( 1 :jpi) = 0._dp +! dl_fpol(jpi/2+1:jpi) = 0._dp +! ENDIF + + ! 2. Ocean/land mask at u-, v-, and z-points (computed from tmask) + ! ------------------------------------------- + DO jk = 1, jpk + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 ! vector loop + tg_umask%d_value(ji,jj,jk,1) = tg_tmask%d_value(ji ,jj ,jk,1) * & + & tg_tmask%d_value(ji+1,jj ,jk,1) + + tg_vmask%d_value(ji,jj,jk,1) = tg_tmask%d_value(ji ,jj ,jk,1) * & + & tg_tmask%d_value(ji ,jj+1,jk,1) + !END DO + !DO ji = 1, jpi-1 ! NO vector opt. + IF( .NOT. ld_domcfg )THEN + tg_fmask%d_value(ji,jj,jk,1) = tg_tmask%d_value(ji ,jj ,jk,1) * & + & tg_tmask%d_value(ji+1,jj ,jk,1) * & + & tg_tmask%d_value(ji ,jj+1,jk,1) * & + & tg_tmask%d_value(ji+1,jj+1,jk,1) + ENDIF + ENDDO + ENDDO + ENDDO + +! ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet cell at u point +! DO jj = 1, jpjm1 +! DO ji = 1, fs_jpim1 ! vector loop +! tg_ssumask%d_value(ji,jj,1,1) = tg_ssmask%d_value(ji ,jj ,1,1) * & +! & tg_ssmask%d_value(ji+1,jj ,1,1) * & +! & MIN( 1._wp, SUM(tg_umask%d_value(ji,jj,:,1)) ) +! tg_ssvmask%d_value(ji,jj,1,1) = tg_ssmask%d_value(ji ,jj ,1,1) * & +! & tg_ssmask%d_value(ji ,jj+1,1,1) * & +! & MIN( 1._wp, SUM(tg_vmask%d_value(ji,jj,:,1)) ) +! END DO +! DO ji = 1, jpim1 ! NO vector opt. +! tg_ssfmask%d_value(ji,jj,1,1) = tg_ssmask%d_value(ji ,jj ,1,1) * & +! & tg_ssmask%d_value(ji+1,jj ,1,1) * & +! & tg_ssmask%d_value(ji ,jj+1,1,1) * & +! & tg_ssmask%d_value(ji+1,jj+1,1,1) * & +! & MIN( 1._wp, SUM(tg_fmask%d_value(ji,jj,:,1)) ) +! END DO +! END DO + CALL lbc_lnk( tg_umask%d_value (:,:,:,1), 'U', td_nam%i_perio, 1._dp ) ! Lateral boundary conditions + CALL lbc_lnk( tg_vmask%d_value (:,:,:,1), 'V', td_nam%i_perio, 1._dp ) + IF( .NOT. ld_domcfg )THEN + CALL lbc_lnk( tg_fmask%d_value (:,:,:,1), 'F', td_nam%i_perio, 1._dp ) + ENDIF +! CALL lbc_lnk( tg_ssumask%d_value(:,:,:,1), 'U', td_nam%i_perio, 1._dp ) ! Lateral boundary conditions +! CALL lbc_lnk( tg_ssvmask%d_value(:,:,:,1), 'V', td_nam%i_perio, 1._dp ) +! CALL lbc_lnk( tg_ssfmask%d_value(:,:,:,1), 'F', td_nam%i_perio, 1._dp ) + + ! 3. Ocean/land mask at wu-, wv- and w points + !---------------------------------------------- +! tg_wmask%d_value (:,:,1,1) = tg_tmask%d_value(:,:,1,1) ! surface +! tg_wumask%d_value(:,:,1,1) = tg_umask%d_value(:,:,1,1) +! tg_wvmask%d_value(:,:,1,1) = tg_vmask%d_value(:,:,1,1) +! +! DO jk=2,jpk ! interior values +! tg_wmask%d_value (:,:,jk,1) = tg_tmask%d_value(:,:,jk ,1) * & +! & tg_tmask%d_value(:,:,jk-1,1) +! tg_wumask%d_value(:,:,jk,1) = tg_umask%d_value(:,:,jk ,1) * & +! & tg_umask%d_value(:,:,jk-1,1) +! tg_wvmask%d_value(:,:,jk,1) = tg_vmask%d_value(:,:,jk ,1) * & +! & tg_vmask%d_value(:,:,jk-1,1) +! ENDDO + + ! Lateral boundary conditions on velocity (modify fmask) + ! --------------------------------------- + IF( .NOT. ld_domcfg )THEN + ALLOCATE( zwf(jpi,jpj) ) + DO jk = 1, jpk + zwf(:,:) = tg_fmask%d_value(:,:,jk,1) + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 ! vector opt. + IF( tg_fmask%d_value(ji,jj,jk,1) == 0._dp )THEN + tg_fmask%d_value(ji,jj,jk,1) = rn_shlat * & + & MIN(1._dp , MAX(zwf(ji+1,jj), zwf(ji,jj+1), & + & zwf(ji-1,jj), zwf(ji,jj-1)) ) + ENDIF + END DO + END DO + DO jj = 2, jpj-1 + IF( tg_fmask%d_value(1,jj,jk,1) == 0._dp )THEN + tg_fmask%d_value(1 ,jj,jk,1) = rn_shlat * & + & MIN(1._dp, MAX(zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1))) + ENDIF + IF( tg_fmask%d_value(jpi,jj,jk,1) == 0._dp )THEN + tg_fmask%d_value(jpi,jj,jk,1) = rn_shlat * & + & MIN(1._wp, MAX(zwf(jpi,jj+1), zwf(jpi-1,jj), zwf(jpi,jj-1))) + ENDIF + END DO + DO ji = 2, jpi-1 + IF( tg_fmask%d_value(ji,1,jk,1) == 0._dp )THEN + tg_fmask%d_value(ji, 1 ,jk,1) = rn_shlat * & + & MIN(1._dp, MAX(zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1))) + ENDIF + IF( tg_fmask%d_value(ji,jpj,jk,1) == 0._dp )THEN + tg_fmask%d_value(ji,jpj,jk,1) = rn_shlat * & + & MIN(1._dp, MAX(zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpj-1))) + ENDIF + END DO + END DO + DEALLOCATE( zwf ) + +! IF( td_nam%c_cfg == "orca" .AND. td_nam%i_cfg == 2 )THEN ! ORCA_R2 configuration +! ! ! Increased lateral friction near of some straits +! IF( td_nam%i_cla == 0 ) THEN +! ! Gibraltar strait : partial slip (fmask=0.5) +! ij0 = 101 ; ij1 = 101 +! ii0 = 139 ; ii1 = 140 +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1) = 0.5_dp +! +! ij0 = 102 ; ij1 = 102 +! ii0 = 139 ; ii1 = 140 +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1) = 0.5_dp +! ! +! !Bab el Mandeb : partial slip (fmask=1) +! ij0 = 87 ; ij1 = 88 +! ii0 = 160 ; ii1 = 160 +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1) = 1._dp +! +! ij0 = 88 ; ij1 = 88 +! ii0 = 159 ; ii1 = 159 +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1) = 1._dp +! ! +! ENDIF +! ENDIF +! ! +! IF( td_nam%c_cfg == "orca" .AND. td_nam%i_cfg == 1 )THEN ! ORCA R1 configuration +! ! Increased lateral friction near of some straits +! ! This dirty section will be suppressed by simplification process: +! ! all this will come back in input files +! ! Currently these hard-wired indices relate to configuration with +! ! extend grid (jpjglo=332) +! ! +! isrow = 332 - jpj +! ! Gibraltar Strait +! ii0 = 282 ; ii1 = 283 +! ij0 = 201 + isrow ; ij1 = 241 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1) = 2._dp +! +! ! Bhosporus Strait +! ii0 = 314 ; ii1 = 315 +! ij0 = 208 + isrow ; ij1 = 248 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 2._dp +! +! ! Makassar Strait (Top) +! ii0 = 48 ; ii1 = 48 +! ij0 = 149 + isrow ; ij1 = 190 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 3._dp +! +! ! Lombok Strait +! ii0 = 44 ; ii1 = 44 +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 2._dp +! +! ! Ombai Strait +! ii0 = 53 ; ii1 = 53 +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 2._dp +! +! ! Timor Passage +! ii0 = 56 ; ii1 = 56 +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 2._dp +! +! ! West Halmahera Strait +! ii0 = 58 ; ii1 = 58 +! ij0 = 141 + isrow ; ij1 = 182 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 3._dp +! +! ! East Halmahera Strait +! ii0 = 55 ; ii1 = 55 +! ij0 = 141 + isrow ; ij1 = 182 - isrow +! tg_fmask%d_value(ii0:ii1,ij0:ij1,1:jpk,1 ) = 3._dp +! ! +! ENDIF + ! + CALL lbc_lnk( tg_fmask%d_value(:,:,:,1), 'F', td_nam%i_perio, 1._dp ) ! Lateral boundary conditions on fmask + ENDIF + +! DEALLOCATE( imsk ) + +! DEALLOCATE( dl_tpol ) +! DEALLOCATE( dl_fpol ) + + END SUBROUTINE create_meshmask__mask + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_meshmask__gloatt(cd_bathy,cd_coord,cd_isfdep,td_namh,td_namz) & + & RESULT(tf_att) + !------------------------------------------------------------------- + !> @brief + !> this function create array of global attributes. + !> + !> @author J.Paul + !> @date October, 2016 - initial release + !> + !> @param[in] cd_bathy + !> @param[in] cd_coord + !> @param[in] cd_isfdep + !> @param[in] td_namh + !> @param[in] td_namz + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_bathy + CHARACTER(LEN=*), INTENT(IN ) :: cd_coord + CHARACTER(LEN=*), INTENT(IN ) :: cd_isfdep + TYPE(TNAMH) , INTENT(IN ) :: td_namh + TYPE(TNAMZ) , INTENT(IN ) :: td_namz + + ! function + TYPE(TATT), DIMENSION(ip_maxatt) :: tf_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ji=1 ; tf_att(ji)=att_init("src_bathy",TRIM(cd_bathy)) + ! horizontal grid + ji=ji+1 ; tf_att(ji)=att_init("in_mshhgr",td_namh%i_mshhgr) + SELECT CASE(td_namh%i_mshhgr) + CASE(0) + ji=ji+1 ; tf_att(ji)=att_init("src_coord",TRIM(cd_coord)) + CASE(1,4) + ji=ji+1 ; tf_att(ji)=att_init("ppglam0",td_namh%d_ppglam0) + ji=ji+1 ; tf_att(ji)=att_init("ppgphi0",td_namh%d_ppgphi0) + CASE(2,3) + ji=ji+1 ; tf_att(ji)=att_init("ppglam0",td_namh%d_ppglam0) + ji=ji+1 ; tf_att(ji)=att_init("ppgphi0",td_namh%d_ppgphi0) + ji=ji+1 ; tf_att(ji)=att_init("ppe1_deg",td_namh%d_ppe1_deg) + ji=ji+1 ; tf_att(ji)=att_init("ppe2_deg",td_namh%d_ppe2_deg) + END SELECT + + IF( td_namz%l_isfcav )THEN + ji=ji+1 ; tf_att(ji)=att_init("ice_shelf_cavities","activated") + ji=ji+1 ; tf_att(ji)=att_init("src_isfdep",TRIM(cd_isfdep)) + ENDIF + IF( td_namz%l_iscpl )THEN + ji=ji+1 ; tf_att(ji)=att_init("ice_sheet_coupling","activated") + ENDIF + + ! vertical grid + IF( td_namz%l_zco )THEN + ji=ji+1 ; tf_att(ji)=att_init("z_coord","full steps") + ENDIF + IF( td_namz%l_zps )THEN + ji=ji+1 ; tf_att(ji)=att_init("z_coord","partial steps") + ENDIF + IF( td_namz%l_sco )THEN + IF( td_namz%l_s_sh94 )THEN + ji=ji+1 ; tf_att(ji)=att_init("z_coord","hybrid Song and Haidvogel 1994") + ELSEIF( td_namz%l_s_sf12 )THEN + ji=ji+1 ; tf_att(ji)=att_init("z_coord","hybrid Siddorn and Furner 2012") + ELSE + ji=ji+1 ; tf_att(ji)=att_init("z_coord","sigma") + ENDIF + ENDIF + ji=ji+1 ; tf_att(ji)=att_init("hmin",td_namz%d_hmin) + IF( td_namz%l_isfcav ) ji=ji+1 ; tf_att(ji)=att_init("isfhmin",td_namz%d_isfhmin) + + ! zco + IF( td_namz%d_ppsur /= NF90_FILL_DOUBLE )THEN + ji=ji+1 ; tf_att(ji)=att_init("ppsur",td_namz%d_ppsur) + ELSE + ji=ji+1 ; tf_att(ji)=att_init("ppsur","to_be_computed") + ENDIF + IF( td_namz%d_ppa0 /= NF90_FILL_DOUBLE )THEN + ji=ji+1 ; tf_att(ji)=att_init("ppa0",td_namz%d_ppa0) + ELSE + ji=ji+1 ; tf_att(ji)=att_init("ppa0","to_be_computed") + ENDIF + IF( td_namz%d_ppa1 /= NF90_FILL_DOUBLE )THEN + ji=ji+1 ; tf_att(ji)=att_init("ppa1",td_namz%d_ppa1) + ELSE + ji=ji+1 ; tf_att(ji)=att_init("ppa1","to_be_computed") + ENDIF + + ji=ji+1 ; tf_att(ji)=att_init("ppkth",td_namz%d_ppkth) + ji=ji+1 ; tf_att(ji)=att_init("ppacr",td_namz%d_ppacr) + ji=ji+1 ; tf_att(ji)=att_init("ppdzmin",td_namz%d_ppdzmin) + ji=ji+1 ; tf_att(ji)=att_init("pphmax",td_namz%d_pphmax) + + IF( td_namz%l_dbletanh )THEN + ji=ji+1 ; tf_att(ji)=att_init("ppa2",td_namz%d_ppa2) + ji=ji+1 ; tf_att(ji)=att_init("ppkth2",td_namz%d_ppkth2) + ji=ji+1 ; tf_att(ji)=att_init("ppacr2",td_namz%d_ppacr2) + ENDIF + + IF( td_namz%l_zps )THEN + ji=ji+1 ; tf_att(ji)=att_init("e3zps_min",td_namz%d_e3zps_min) + ji=ji+1 ; tf_att(ji)=att_init("e3zps_rat",td_namz%d_e3zps_rat) + ENDIF + + IF( td_namz%l_sco )THEN + ji=ji+1 ; tf_att(ji)=att_init("sbot_min",td_namz%d_sbot_min) + ji=ji+1 ; tf_att(ji)=att_init("sbot_max",td_namz%d_sbot_max) + ji=ji+1 ; tf_att(ji)=att_init("hc",td_namz%d_hc) + IF( td_namz%l_s_sh94 )THEN + ji=ji+1 ; tf_att(ji)=att_init("rmax",td_namz%d_rmax) + ji=ji+1 ; tf_att(ji)=att_init("theta",td_namz%d_theta) + ji=ji+1 ; tf_att(ji)=att_init("thetb",td_namz%d_thetb) + ji=ji+1 ; tf_att(ji)=att_init("bb",td_namz%d_bb) + ELSEIF( td_namz%l_s_sf12 )THEN + IF( td_namz%l_sigcrit ) ji=ji+1 ; tf_att(ji)=att_init("sigma_below_critical_depth","activated") + ji=ji+1 ; tf_att(ji)=att_init("alpha",td_namz%d_alpha) + ji=ji+1 ; tf_att(ji)=att_init("efold",td_namz%d_efold) + ji=ji+1 ; tf_att(ji)=att_init("zs",td_namz%d_zs) + ji=ji+1 ; tf_att(ji)=att_init("zb_a",td_namz%d_zb_a) + ji=ji+1 ; tf_att(ji)=att_init("zb_b",td_namz%d_zb_b) + ENDIF + ENDIF + + IF( td_namz%l_wd )THEN + ji=ji+1 ; tf_att(ji)=att_init("wetting_drying","activated") + ENDIF + + IF( td_namz%l_wd )THEN + ji=ji+1 ; tf_att(ji)=att_init("wdmin1",td_namz%d_wdmin1) + ji=ji+1 ; tf_att(ji)=att_init("wdmin2",td_namz%d_wdmin2) + ji=ji+1 ; tf_att(ji)=att_init("wdld",td_namz%d_wdld) + ENDIF + + END FUNCTION create_meshmask__gloatt + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM diff --git a/V4.0/nemo_sources/tools/SIREN/src/create_restart.f90 b/V4.0/nemo_sources/tools/SIREN/src/create_restart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..92957f958c47cce1a687826c9e8ae8e121593999 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/create_restart.f90 @@ -0,0 +1,1518 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> this program creates restart file or initial state. +!> +!> @details +!> @section sec1 method +!> variables could be +!> - extracted from fine grid file +!> - interpolated from coarse grid file +!> - interpolated from restart file +!> - handwritten +!> +!> then they are split over new layout. +!> @note +!> interpolation and/or extrapolation method could be different for each variable. +!> +!> @section sec2 how to +!> USAGE: create_restart create_restart.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - create_restart.nam<br/> +!> namelist of create_restart +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py create_restart +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_restart create_restart.nam +!> create_restart.nam contains 9 namelists:<br/> +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source/coarse grid parameters +!> - **namtgt** to set target/fine grid parameters +!> - **namzgr** to set vertical grid parameters +!> - **namzps** to set partial step parameters +!> - **namvar** to set variable parameters +!> - **namnst** to set sub domain and nesting paramters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a create_restart.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the coarse grid sub-namelist parameters are : +!> +!> - **cn_coord0** [@a ]<br/> +!> path to the coordinate file +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subtgt namtgt +!> the fine grid sub-namelist parameters are : +!> +!> - **cn_coord1** [@a ]<br/> +!> path to coordinate file +!> +!> - **cn_bathy1** [@a ]<br/> +!> path to bathymetry file +!> +!> - **in_perio1** [@a ]<br/> +!> NEMO periodicity index (see above) +!> @note if the fine/target coordinates file (cn_coord1) was created by SIREN, you do +!> not need to fill this parameter. SIREN will read it on the global attributes of +!> the coordinates file. +!> +!> @subsection subzgr namzgr +!> the vertical grid sub-namelist parameters are : +!> +!> - **dn_pp_to_be_computed** [@a 0]<br/> +!> +!> - **dn_ppsur** [@a -3958.951371276829]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa0** [@a 103.953009600000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa1** [@a 2.415951269000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppa2** [@a 100.760928500000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppkth** [@a 15.351013700000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppkth2** [@a 48.029893720000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppacr** [@a 7.000000000000]<br/> +!> coefficient to compute vertical grid +!> +!> - **dn_ppacr2** [@a 13.000000000000]<br/> +!> double tanh function parameter +!> +!> - **dn_ppdzmin** [@a 6.]<br/> +!> minimum vertical spacing +!> +!> - **dn_pphmax** [@a 5750.]<br/> +!> maximum depth +!> +!> - **in_nlevel** [@a 75]<br/> +!> number of vertical level +!> +!> @note +!> If *dn_ppa1*, *dn_ppa0* and *dn_ppsur* are undefined, +!> NEMO will compute them from *dn_ppdzmin, dn_pphmax, dn_ppkth, dn_ppacr* +!> +!> @subsection subzps namzps +!> the partial step sub-namelist parameters are : +!> +!> - **dn_e3zps_min** [@a 25.]<br/> +!> minimum thickness of partial step level (meters) +!> - **dn_e3zps_rat** [@a 0.2]<br/> +!> minimum thickness ratio of partial step level +!> +!> @subsection subvar namvar +!> the variable sub-namelist parameters are : +!> +!> - **cn_varfile** [@a ]<br/> +!> list of variable, and associated file +!> +!> *cn_varfile* is the path and filename of the file where find +!> variable. +!> @note +!> *cn_varfile* could be a matrix of value, if you want to handwrite +!> variable value.<br/> +!> the variable array of value is split into equal subdomain.<br/> +!> each subdomain is filled with the corresponding value +!> of the matrix.<br/> +!> separators used to defined matrix are: +!> - ',' for line +!> - '/' for row +!> Example:<br/> +!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} +!> 3 & 2 & 3 \\ +!> 1 & 4 & 5 \end{array} \right) @f$ +!> +!> Examples: +!> - 'votemper:gridT.nc', 'vozocrtx:gridU.nc' +!> - 'votemper:10\25', 'vozocrtx:gridU.nc'<br/> +!> +!> @note +!> to get all variables from one file: +!> +!> Example: +!> - 'all:restart.dimg' +!> +!> @note +!> Optionnaly, NEMO periodicity could be added following the filename. +!> the periodicity must be separated by ';' +!> +!> Example: +!> - 'votemper:gridT.nc ; perio=4' +!> +!> - **cn_varinfo** [@a ]<br/> +!> list of variable and extra information about request(s) to be used<br/> +!> +!> each elements of *cn_varinfo* is a string character (separated by ',').<br/> +!> it is composed of the variable name follow by ':', +!> then request(s) to be used on this variable.<br/> +!> request could be: +!> - int = interpolation method +!> - ext = extrapolation method +!> - flt = filter method +!> - min = minimum value +!> - max = maximum value +!> - unt = new units +!> - unf = unit scale factor (linked to new units) +!> +!> requests must be separated by ';'.<br/> +!> order of requests does not matter.<br/> +!> +!> informations about available method could be find in @ref interp, +!> @ref extrap and @ref filter modules.<br/> +!> Example: +!> - 'votemper: int=linear; flt=hann; ext=dist_weight', +!> 'vosaline: int=cubic' +!> +!> @note +!> If you do not specify a method which is required, +!> default one is apply. +!> +!> @subsection subnst namnst +!> the nesting sub-namelist parameters are : +!> +!> - **in_rhoi** [@a 1]<br/> +!> refinement factor in i-direction +!> +!> - **in_rhoj** [@a 1]<br/> +!> refinement factor in j-direction +!> +!> @note +!> coarse grid indices will be deduced from fine grid +!> coordinate file. +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a restart.nc]<br/> +!> output bathymetry filename +!> +!> - **ln_extrap** [@a .FALSE.]<br/> +!> logical to extrapolate land point or not +!> +!> - **in_niproc** [@a 1]<br/> +!> number of processor in i-direction +!> +!> - **in_njproc** [@a 1]<br/> +!> number of processor in j-direction +!> +!> - **in_nproc** [@a 1]<br/> +!> total number of processor to be used +!> +!> - **cn_type** [@a ]<br/> +!> output format ('dimg', 'cdf') +!> +!> @note +!> - if *in_niproc*, and *in_njproc* are provided : the program only look for land +!> processor to be removed +!> - if *in_nproc* is provided : the program compute each possible domain layout, +!> and save the one with the most land processor to be removed +!> - with no information about number of processors, the program +!> assume to use only one processor +!> +!> <hr> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header for user +!> - offset computed considering grid point +!> - add attributes in output variable +!> @date June, 2015 +!> - extrapolate all land points, and add ln_extrap in namelist. +!> - allow to change unit. +!> @date September, 2015 +!> - manage useless (dummy) variable, attributes, and dimension +!> @date October, 2016 +!> - dimension to be used select from configuration file +!> @date January, 2019 +!> - add url path to global attributes of output file(s) +!> - check name and standard name for longitude and latitude +!> @date February, 2019 +!> - rename sub namelist namcrs to namsrc +!> - rename sub namelist namfin to namtgt +!> @date May, 2019 +!> - create and clean file structure to avoid memory leaks +!> @date August, 2019 +!> - use periodicity read from namelist, and store in multi structure +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> @todo +!> - rewrite using meshmask instead of bathymetry and coordinates files +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM create_restart + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE multi ! multi file manager + USE iom ! I/O manager + USE grid ! grid manager + USE vgrid ! vertical grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE dom ! domain manager + USE iom_mpp ! MPP I/O manager + USE iom_dom ! DOM I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_restart" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_data + CHARACTER(LEN=lc) :: cl_fileout + CHARACTER(LEN=lc) :: cl_url + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_varid + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_nvar + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_index + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho + INTEGER(i4) , DIMENSION(2,2) :: il_xghost + INTEGER(i4) , DIMENSION(2,2) :: il_offset + INTEGER(i4) , DIMENSION(2,2) :: il_ind + + LOGICAL :: ll_exist + LOGICAL :: ll_sameGrid + + TYPE(TDOM) :: tl_dom1 + TYPE(TDOM) :: tl_dom0 + + TYPE(TATT) :: tl_att + + TYPE(TVAR) :: tl_depth + TYPE(TVAR) :: tl_time + TYPE(TVAR) :: tl_lon + TYPE(TVAR) :: tl_lat + TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_var + TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TFILE) :: tl_file + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + TYPE(TMPP) :: tl_bathy1 + TYPE(TMPP) :: tl_mpp + TYPE(TMPP) :: tl_mppout + + TYPE(TMULTI) :: tl_multi + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jvar + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_coord0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namtgt + CHARACTER(LEN=lc) :: cn_coord1 = '' + CHARACTER(LEN=lc) :: cn_bathy1 = '' + INTEGER(i4) :: in_perio1 = -1 + + !namzgr + REAL(dp) :: dn_pp_to_be_computed = 0._dp + REAL(dp) :: dn_ppsur = -3958.951371276829_dp + REAL(dp) :: dn_ppa0 = 103.953009600000_dp + REAL(dp) :: dn_ppa1 = 2.415951269000_dp + REAL(dp) :: dn_ppa2 = 100.760928500000_dp + REAL(dp) :: dn_ppkth = 15.351013700000_dp + REAL(dp) :: dn_ppkth2 = 48.029893720000_dp + REAL(dp) :: dn_ppacr = 7.000000000000_dp + REAL(dp) :: dn_ppacr2 = 13.000000000000_dp + REAL(dp) :: dn_ppdzmin = 6._dp + REAL(dp) :: dn_pphmax = 5750._dp + INTEGER(i4) :: in_nlevel = 75 + + !namzps + REAL(dp) :: dn_e3zps_min = 25._dp + REAL(dp) :: dn_e3zps_rat = 0.2_dp + + ! namvar + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + + ! namnst + INTEGER(i4) :: in_rhoi = 1 + INTEGER(i4) :: in_rhoj = 1 + + ! namout + CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' + LOGICAL :: ln_extrap = .FALSE. + INTEGER(i4) :: in_nproc = 0 + INTEGER(i4) :: in_niproc = 0 + INTEGER(i4) :: in_njproc = 0 + CHARACTER(LEN=lc) :: cn_type = '' + + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_coord0, & !< coordinate file + & in_perio0 !< periodicity index + + NAMELIST /namtgt/ & !< target/fine grid namelist + & cn_coord1, & !< coordinate file + & cn_bathy1, & !< bathymetry file + & in_perio1 !< periodicity index + + NAMELIST /namzgr/ & + & dn_pp_to_be_computed, & + & dn_ppsur, & + & dn_ppa0, & + & dn_ppa1, & + & dn_ppa2, & + & dn_ppkth, & + & dn_ppkth2, & + & dn_ppacr, & + & dn_ppacr2, & + & dn_ppdzmin, & + & dn_pphmax, & + & in_nlevel !< number of vertical level + + NAMELIST /namzps/ & + & dn_e3zps_min, & + & dn_e3zps_rat + + NAMELIST /namvar/ & !< variable namelist + & cn_varfile, & !< list of variable file + & cn_varinfo !< list of variable and interpolation method to be used. + + NAMELIST /namnst/ & !< nesting namelist + & in_rhoi, & !< refinement factor in i-direction + & in_rhoj !< refinement factor in j-direction + + NAMELIST /namout/ & !< output namelist + & cn_fileout, & !< fine grid bathymetry file + & ln_extrap, & !< extrapolate or not + & in_niproc, & !< i-direction number of processor + & in_njproc, & !< j-direction numebr of processor + & in_nproc, & !< number of processor to be used + & cn_type !< output type format (dimg, cdf) + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + + ! define logger file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namtgt ) + READ( il_fileid, NML = namzgr ) + READ( il_fileid, NML = namvar ) + ! add user change in extra information + CALL var_chg_extra(cn_varinfo) + ! match variable with file + tl_multi=multi_init(cn_varfile) + + READ( il_fileid, NML = namnst ) + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE RESTART: closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + CALL multi_print(tl_multi) + + IF( tl_multi%i_nvar <= 0 )THEN + CALL logger_fatal("CREATE RESTART: no variable to be used."//& + & " check namelist.") + ENDIF + + ! open files + IF( cn_coord0 /= '' )THEN + tl_file=file_init(TRIM(cn_coord0)) + tl_coord0=mpp_init( tl_file, id_perio=in_perio0) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord0) + ELSE + CALL logger_fatal("CREATE RESTART: no coarse grid coordinate found. "//& + & "check namelist") + ENDIF + + IF( TRIM(cn_coord1) /= '' )THEN + tl_file=file_init(TRIM(cn_coord1)) + tl_coord1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_coord1) + ELSE + CALL logger_fatal("CREATE RESTART: no fine grid coordinate found. "//& + & "check namelist") + ENDIF + + IF( TRIM(cn_bathy1) /= '' )THEN + tl_file=file_init(TRIM(cn_bathy1)) + tl_bathy1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_bathy1) + ELSE + CALL logger_fatal("CREATE RESTART: no fine grid bathymetry found. "//& + & "check namelist") + ENDIF + + ! check + ! check output file do not already exist + IF( in_nproc > 0 )THEN + cl_fileout=file_rename(cn_fileout,1) + ELSE + cl_fileout=file_rename(cn_fileout) + ENDIF + INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE RESTART: output file "//TRIM(cl_fileout)//& + & " already exist.") + ENDIF + + ! check refinement factor + il_rho(:)=1 + IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN + CALL logger_error("CREATE RESTART: invalid refinement factor."//& + & " check namelist "//TRIM(cl_namelist)) + ELSE + il_rho(jp_I)=in_rhoi + il_rho(jp_J)=in_rhoj + ENDIF + + ! check domain indices + ! compute coarse grid indices around fine grid + il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, & + & id_rho=il_rho(:)) + + il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2) + il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2) + + ! check domain validity + CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0) + + !3-2-4 check coincidence between coarse and fine grid + CALL grid_check_coincidence( tl_coord0, tl_coord1, & + & il_imin0, il_imax0, & + & il_jmin0, il_jmax0, & + & il_rho(:) ) + + ! fine grid ghost cell + il_xghost(:,:)=grid_get_ghost(tl_bathy1) + + ! work on variables + IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN + CALL logger_error("CREATE RESTART: no file to work on. "//& + & "check cn_varfile in namelist.") + ELSE + ALLOCATE( tl_var( tl_multi%i_nvar ) ) + + jvar=0 + ! for each file + DO ji=1,tl_multi%i_nmpp + + WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1 + IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN + + CALL logger_error("CREATE RESTART: no variable to work on for "//& + & "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//& + & ". check cn_varfile in namelist.") + + ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN + !- use input matrix to fill variable + + WRITE(*,'(a)') "work on data" + ! for each variable initialise from matrix + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + jvar=jvar+1 + + WRITE(*,'(2x,a,a)') "work on variable "//& + & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + + ! fill value with matrix data + tl_var(jvar) = create_restart_matrix( & + & tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, & + & in_nlevel, il_xghost(:,:) ) + + ! add ghost cell + CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) + + ENDDO + !- end of use input matrix to fill variable + ELSE + !- use mpp file to fill variable + + WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name) + ! + tl_file=file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name), & + & id_perio=tl_multi%t_mpp(ji)%i_perio) + tl_mpp=mpp_init( tl_file ) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_mpp) + + ! check vertical dimension + IF( tl_mpp%t_dim(jp_K)%l_use .AND. & + & tl_mpp%t_dim(jp_K)%i_len /= in_nlevel )THEN + CALL logger_error("CREATE RESTART: dimension in file "//& + & TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ") + ENDIF + + ! open mpp file + CALL iom_mpp_open(tl_mpp) + + ! get or check depth value + CALL create_restart_check_depth( tl_mpp, tl_depth ) + + ! get or check time value + CALL create_restart_check_time( tl_mpp, tl_time ) + + ! close mpp file + CALL iom_mpp_close(tl_mpp) + + IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) .OR.& + & ALL(il_rho(:)==1) )THEN + !!! extract value from fine grid + + IF( ANY( tl_mpp%t_dim(1:2)%i_len < & + & tl_coord1%t_dim(1:2)%i_len) )THEN + CALL logger_fatal("CREATE RESTART: dimensions in file "//& + & TRIM(tl_mpp%c_name)//" smaller than those in fine"//& + & " grid coordinates.") + ENDIF + + ! use coord0 instead of mpp for restart file case + ! (without lon,lat) + ll_sameGrid=.FALSE. + IF( ALL(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) & + & )THEN + ll_sameGrid=.TRUE. + ENDIF + + ! compute domain on fine grid + IF( ll_sameGrid )THEN + il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 ) + ELSE + il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 ) + ENDIF + + il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2) + il_jmin1=il_ind(2,1) ; il_jmax1=il_ind(2,2) + + !- check grid coincidence + IF( ll_sameGrid )THEN + il_rho(:)=1 + CALL grid_check_coincidence( tl_mpp, tl_coord1, & + & il_imin1, il_imax1, & + & il_jmin1, il_jmax1, & + & il_rho(:) ) + ELSE + CALL grid_check_coincidence( tl_coord0, tl_coord1, & + & il_imin1, il_imax1, & + & il_jmin1, il_jmax1, & + & il_rho(:) ) + ENDIF + + ! compute domain + tl_dom1=dom_init(tl_mpp, & + & il_imin1, il_imax1, & + & il_jmin1, il_jmax1) + + ! open mpp files + CALL iom_dom_open(tl_mpp, tl_dom1) + + ! for each variable of this file + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + WRITE(*,'(2x,a,a)') "work on (extract) variable "//& + & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + + jvar=jvar+1 + cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name + ! read variable over domain + tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom1) + + ! add attribute to variable + tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tl_var(jvar), tl_att) + + tl_att=att_init('src_i_indices',(/il_imin0, il_imax0/)) + CALL var_move_att(tl_var(jvar), tl_att) + + tl_att=att_init('src_j_indices',(/il_jmin0, il_jmax0/)) + CALL var_move_att(tl_var(jvar), tl_att) + + ! clean structure + CALL att_clean(tl_att) + + ! add ghost cell + CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:)) + + ENDDO + + ! close mpp file + CALL iom_dom_close(tl_mpp) + + ! clean structure + CALL mpp_clean(tl_mpp) + CALL dom_clean(tl_dom1) + + ELSE + !!! get value from coarse grid + + ! compute domain on coarse grid + tl_dom0=dom_init(tl_mpp, & + & il_imin0, il_imax0, & + & il_jmin0, il_jmax0 ) + + ! add extra band (if possible) to compute interpolation + CALL dom_add_extra(tl_dom0) + + ! open mpp files + CALL iom_dom_open(tl_mpp, tl_dom0) + ! for each variable of this file + DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar + + WRITE(*,'(2x,a,a)') "work on (interp) variable "//& + & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + + jvar=jvar+1 + cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name + + ! read variable over domain + tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0) + + il_offset(:,:)=grid_get_fine_offset(tl_coord0, & + & il_imin0, il_jmin0, & + & il_imax0, il_jmax0, & + & tl_coord1, & + & id_rho=il_rho(:), & + & cd_point=TRIM(tl_var(jvar)%c_point)) + + ! interpolate variable + CALL create_restart_interp(tl_var(jvar), & + & il_rho(:), & + & id_offset=il_offset(:,:)) + + ! remove extraband added to domain + CALL dom_del_extra( tl_var(jvar), tl_dom0, il_rho(:) ) + + ! add attribute to variable + tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) + CALL var_move_att(tl_var(jvar), tl_att) + + tl_att=att_init('src_i-indices',(/il_imin0, il_imax0/)) + CALL var_move_att(tl_var(jvar), tl_att) + + tl_att=att_init('src_j-indices',(/il_jmin0, il_jmax0/)) + CALL var_move_att(tl_var(jvar), tl_att) + + IF( ANY(il_rho(:)/=1) )THEN + tl_att=att_init("refinment_factor", & + & (/il_rho(jp_I),il_rho(jp_J)/)) + CALL var_move_att(tl_var(jvar), tl_att) + ENDIF + + ! clean structure + CALL att_clean(tl_att) + + ! add ghost cell + CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) + ENDDO + + ! close mpp file + CALL iom_dom_close(tl_mpp) + + ! clean structure + CALL mpp_clean(tl_mpp) + CALL dom_clean(tl_dom0) + + ENDIF + + ! clean structure + CALL mpp_clean(tl_mpp) + ENDIF + ENDDO + ENDIF + + il_nvar=tl_multi%i_nvar + + ! clean + CALL multi_clean(tl_multi) + CALL mpp_clean(tl_coord0) + + IF( .NOT. ln_extrap )THEN + ! compute level + ALLOCATE(tl_level(ip_npoint)) + tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) + ENDIF + + ! clean + CALL mpp_clean(tl_bathy1) + + ! use additional request + DO jvar=1,il_nvar + + ! change unit and apply factor + CALL var_chg_unit(tl_var(jvar)) + + ! forced min and max value + CALL var_limit_value(tl_var(jvar)) + + ! filter + CALL filter_fill_value(tl_var(jvar)) + + IF( .NOT. ln_extrap )THEN + ! use mask + CALL create_restart_mask(tl_var(jvar), tl_level(:)) + ENDIF + + ENDDO + + ! create file + IF( in_niproc == 0 .AND. & + & in_njproc == 0 .AND. & + & in_nproc == 0 )THEN + in_niproc = 1 + in_njproc = 1 + in_nproc = 1 + ENDIF + + ! add dimension + tl_dim(:)=var_max_dim(tl_var(:)) + + DO ji=1,il_nvar + + IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN + tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), & + & in_niproc, in_njproc, in_nproc, & + & cd_type=cn_type) + EXIT + ENDIF + + ENDDO + + DO ji=1,ip_maxdim + + IF( tl_dim(ji)%l_use )THEN + CALL mpp_move_dim(tl_mppout, tl_dim(ji)) + SELECT CASE(TRIM(tl_dim(ji)%c_sname)) + CASE('z','t') + DO jj=1,tl_mppout%i_nproc + CALL file_add_dim(tl_mppout%t_proc(jj), tl_dim(ji)) + ENDDO + END SELECT + ENDIF + + ENDDO + + ! add variables + IF( ALL( tl_dim(1:2)%l_use ) )THEN + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! add longitude + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude') + IF( il_varid == 0 )THEN + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude_T') + ENDIF + tl_lon=iom_mpp_read_var(tl_coord1, il_varid) + CALL mpp_add_var(tl_mppout, tl_lon) + CALL var_clean(tl_lon) + + ! add latitude + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude') + IF( il_varid == 0 )THEN + il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude_T') + ENDIF + tl_lat=iom_mpp_read_var(tl_coord1, il_varid) + CALL mpp_add_var(tl_mppout, tl_lat) + CALL var_clean(tl_lat) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + ENDIF + + IF( tl_dim(3)%l_use )THEN + IF( ASSOCIATED(tl_depth%d_value) )THEN + ! add depth + CALL mpp_add_var(tl_mppout, tl_depth) + ELSE + CALL logger_warn("CREATE RESTART: no value for depth variable.") + ENDIF + ENDIF + IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth) + + IF( tl_dim(4)%l_use )THEN + IF( ASSOCIATED(tl_time%d_value) )THEN + ! add time + CALL mpp_add_var(tl_mppout, tl_time) + ELSE + CALL logger_warn("CREATE RESTART: no value for time variable.") + ENDIF + ENDIF + IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time) + + ! add other variable + DO jvar=il_nvar,1,-1 + ! check if variable already add + il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name) + IF( il_index == 0 )THEN + CALL mpp_add_var(tl_mppout, tl_var(jvar)) + CALL var_clean(tl_var(jvar)) + ENDIF + ENDDO + + ! add some attribute + tl_att=att_init("Created_by","SIREN create_restart") + CALL mpp_add_att(tl_mppout, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL mpp_add_att(tl_mppout, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",TRIM(cl_date)) + CALL mpp_add_att(tl_mppout, tl_att) + + ! add attribute periodicity + il_attid=0 + IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'periodicity') + ENDIF + IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('periodicity',tl_coord1%i_perio) + CALL mpp_add_att(tl_mppout,tl_att) + ENDIF + + il_attid=0 + IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN + il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'ew_overlap') + ENDIF + IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN + tl_att=att_init('ew_overlap',tl_coord1%i_ew) + CALL mpp_add_att(tl_mppout,tl_att) + ENDIF + + ! print + CALL mpp_print(tl_mppout) + + ! create file + CALL iom_mpp_create(tl_mppout) + + ! write file + CALL iom_mpp_write_file(tl_mppout) + ! close file + CALL iom_mpp_close(tl_mppout) + + ! clean + CALL att_clean(tl_att) + CALL var_clean(tl_var(:)) + DEALLOCATE(tl_var) + IF( .NOT. ln_extrap )THEN + CALL var_clean(tl_level(:)) + DEALLOCATE(tl_level) + ENDIF + + CALL mpp_clean(tl_mppout) + CALL mpp_clean(tl_coord1) + CALL var_clean_extra() + + ! close log file + CALL logger_footer() + CALL logger_close() + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This function create variable, filled with matrix value + !> + !> @details + !> A variable is create with the same name that the input variable, + !> and with dimension of the coordinate file.<br/> + !> Then the variable array of value is split into equal subdomain. + !> Each subdomain is filled with the associated value of the matrix. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - do not use level anymore + !> + !> @param[in] td_var variable structure + !> @param[in] td_coord coordinate file structure + !> @param[in] id_nlevel number of vertical level + !> @param[in] id_xghost ghost cell array + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + TYPE(TMPP) , INTENT(IN) :: td_coord + INTEGER(i4) , INTENT(IN) :: id_nlevel + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_xghost + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) , DIMENSION(3) :: il_dim + INTEGER(i4) , DIMENSION(3) :: il_size + INTEGER(i4) , DIMENSION(3) :: il_rest + + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape + INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_kshape + + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! write value on grid + ! get matrix dimension + il_dim(:)=td_var%t_dim(1:3)%i_len + + ! output dimension + tl_dim(jp_I:jp_J)=dim_copy(td_coord%t_dim(jp_I:jp_J)) + IF( id_nlevel >= 1 )THEN + tl_dim(jp_K)=dim_init('Z',id_nlevel) + ENDIF + + ! remove ghost cell + tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(id_xghost(jp_I,:))*ip_ghost + tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(id_xghost(jp_J,:))*ip_ghost + + ! split output domain in N subdomain depending of matrix dimension + il_size(:) = tl_dim(1:3)%i_len / il_dim(:) + il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:)) + + ALLOCATE( il_ishape(il_dim(1)+1) ) + il_ishape(:)=0 + DO ji=2,il_dim(1)+1 + il_ishape(ji)=il_ishape(ji-1)+il_size(1) + ENDDO + ! add rest to last cell + il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1) + + ALLOCATE( il_jshape(il_dim(2)+1) ) + il_jshape(:)=0 + DO jj=2,il_dim(2)+1 + il_jshape(jj)=il_jshape(jj-1)+il_size(2) + ENDDO + ! add rest to last cell + il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2) + + ALLOCATE( il_kshape(il_dim(3)+1) ) + il_kshape(:)=0 + DO jk=2,il_dim(3)+1 + il_kshape(jk)=il_kshape(jk-1)+il_size(3) + ENDDO + ! add rest to last cell + il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3) + + ! write ouput array of value + ALLOCATE(dl_value( tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + dl_value(:,:,:,:)=0 + + DO jk=2,il_dim(3)+1 + DO jj=2,il_dim(2)+1 + DO ji=2,il_dim(1)+1 + + dl_value( 1+il_ishape(ji-1):il_ishape(ji), & + & 1+il_jshape(jj-1):il_jshape(jj), & + & 1+il_kshape(jk-1):il_kshape(jk), & + & 1 ) = td_var%d_value(ji-1,jj-1,jk-1,1) + + ENDDO + ENDDO + ENDDO + + ! keep attribute and type + tf_var=var_copy(td_var) + DEALLOCATE( tf_var%d_value ) + ! save new dimension + tf_var%t_dim(:)=dim_copy(tl_dim(:)) + ! add variable value + CALL var_add_value( tf_var, dl_value(:,:,:,:), & + & id_type=td_var%i_type) + + DEALLOCATE(dl_value) + + ! clean + DEALLOCATE(il_ishape) + DEALLOCATE(il_jshape) + DEALLOCATE(il_kshape) + + END FUNCTION create_restart_matrix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_restart_mask(td_var, td_mask) + !------------------------------------------------------------------- + !> @brief + !> This subroutine use mask to filled land point with _FillValue + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_mask mask variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_mask + + ! local variable + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask + + ! loop indices + INTEGER(i4) :: jl + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN + CALL logger_error("CREATE RESTART MASK: dimension differ between"//& + & " variable "//TRIM(td_var%c_name)//" ("//& + & TRIM(fct_str(td_var%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_var%t_dim(2)%i_len))//& + & ") and level ("//& + & TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")") + ELSE + ALLOCATE( il_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len) ) + + SELECT CASE(TRIM(td_var%c_point)) + CASE('T') + il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1)) + CASE('U') + il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1)) + CASE('V') + il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1)) + CASE('F') + il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1)) + END SELECT + + DO jl=1,td_var%t_dim(4)%i_len + DO jk=1,td_var%t_dim(3)%i_len + WHERE( il_mask(:,:) < jk ) + td_var%d_value(:,:,jk,jl)=td_var%d_fill + END WHERE + ENDDO + ENDDO + + DEALLOCATE( il_mask ) + ENDIF + ENDIF + END SUBROUTINE create_restart_mask + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_restart_interp(td_var, id_rho, id_offset, & + & id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - do not use level anymore (for extrapolation) + !> + !> @param[inout] td_var variable structure + !> @param[in] id_rho array of refinment factor + !> @param[in] id_offset array of offset between fine and coarse grid + !> @param[in] id_iext i-direction size of extra bands (default=im_minext) + !> @param[in] id_jext j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + ! local variable + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + + ! loop indices + !---------------------------------------------------------------- + + il_iext=3 + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=3 + IF( PRESENT(id_jext) ) il_jext=id_jext + + IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_iext=2 + ENDIF + + IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_jext=2 + ENDIF + ! work on variable + ! add extraband + CALL extrap_add_extrabands(td_var, il_iext, il_jext) + + ! extrapolate variable + CALL extrap_fill_value( td_var ) + + ! interpolate variable + CALL interp_fill_value( td_var, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! remove extraband + CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) + + END SUBROUTINE create_restart_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_restart_check_depth(td_mpp, td_depth) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get depth variable value in an open mpp structure + !> and check if agree with already input depth variable. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_depth depth variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN ) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_depth + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_depth + ! loop indices + !---------------------------------------------------------------- + + ! get or check depth value + IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_depthid + IF( ASSOCIATED(td_depth%d_value) )THEN + + tl_depth=iom_mpp_read_var(td_mpp, il_varid) + IF( ANY( td_depth%d_value(:,:,:,:) /= & + & tl_depth%d_value(:,:,:,:) ) )THEN + + CALL logger_warn("CREATE RESTART: depth value from "//& + & TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_depth) + + ELSE + td_depth=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + + END SUBROUTINE create_restart_check_depth + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE create_restart_check_time(td_mpp, td_time) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get date and time in an open mpp structure + !> and check if agree with date and time already read. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_time time variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN ) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_time + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_time + + TYPE(TDATE) :: tl_date1 + TYPE(TDATE) :: tl_date2 + ! loop indices + !---------------------------------------------------------------- + + ! get or check depth value + + IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN + + il_varid=td_mpp%t_proc(1)%i_timeid + IF( ASSOCIATED(td_time%d_value) )THEN + + tl_time=iom_mpp_read_var(td_mpp, il_varid) + + tl_date1=var_to_date(td_time) + tl_date2=var_to_date(tl_time) + IF( tl_date1 - tl_date2 /= 0 )THEN + + CALL logger_warn("CREATE BOUNDARY: date from "//& + & TRIM(td_mpp%c_name)//" not conform "//& + & " to those from former file(s).") + + ENDIF + CALL var_clean(tl_time) + + ELSE + td_time=iom_mpp_read_var(td_mpp,il_varid) + ENDIF + + ENDIF + + END SUBROUTINE create_restart_check_time + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM create_restart diff --git a/V4.0/nemo_sources/tools/SIREN/src/date.f90 b/V4.0/nemo_sources/tools/SIREN/src/date.f90 new file mode 100644 index 0000000000000000000000000000000000000000..800f36be3573731328a286e1f79ded884519ecd5 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/date.f90 @@ -0,0 +1,1148 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module provide the calculation of Julian dates, and +!> do many manipulations with dates. +!> +!> @details +!> Actually we use Modified Julian Dates, with +!> 17 Nov 1858 at 00:00:00 as origin.<br/> +!> +!> define type TDATE:<br/> +!> @code +!> TYPE(TDATE) :: tl_date1 +!> @endcode +!> default date is 17 Nov 1858 at 00:00:00<br/> +!> +!> to intialise date : <br/> +!> - from date of the day at 12:00:00 : +!> @code +!> tl_date1=date_today() +!> @endcode +!> - from date and time of the day : +!> @code +!> tl_date1=date_now() +!> @endcode +!> - from julian day : +!> @code +!> tl_date1=date_init(dd_jd) +!> @endcode +!> - dd_jd julian day (double precision) +!> - from number of second since julian day origin : +!> @code +!> tl_date1=date_init(kd_nsec) +!> @endcode +!> - kd_nsec number of second (integer 8) +!> - from year month day : +!> @code +!> tl_date1=date_init(2012,12,10) +!> @endcode +!> - from string character formatted date : +!> @code +!> tl_date1=date_init(cd_fmtdate) +!> @endcode +!> - cd_fmtdate date in format YYYY-MM-DD hh:mm:ss +!> +!> to print date in format YYYY-MM-DD hh:mm:ss<br/> +!> CHARACTER(LEN=lc) :: cl_date<br/> +!> @code +!> cl_date=date_print(tl_date1) +!> PRINT *, TRIM(cl_date) +!> @endcode +!> +!> to print date in another format (only year, month, day): +!> @code +!> cl_date=date_print(tl_date1, cd_fmt) +!> PRINT *, TRIM(cl_date) +!> @endcode +!> - cd_fmt ouput format (ex: cd_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" ) +!> +!> to print day of the week:<br/> +!> @code +!> PRINT *,"dow ", tl_date1\%i_dow +!> @endcode +!> to print last day of the month:<br/> +!> @code +!> PRINT *,"last day ", tl_date1\%i_lday +!> @endcode +!> +!> to know if year is a leap year:<br/> +!> @code +!> ll_isleap=date_leapyear(tl_date1) +!> @endcode +!> - ll_isleap is logical +!> +!> to compute number of days between two dates:<br/> +!> @code +!> tl_date2=date_init(2010,12,10) +!> dl_diff=tl_date1-tl_date2 +!> @endcode +!> - dl_diff is the number of days between date1 and date2 (double precision) +!> +!> to add or substract nday to a date:<br/> +!> @code +!> tl_date2=tl_date1+2. +!> tl_date2=tl_date1-2.6 +!> @endcode +!> - number of day (double precision) +!> +!> to print julian day:<br/> +!> @code +!> PRINT *," julian day",tl_date1\%r_jd +!> @endcode +!> +!> to print CNES julian day (origin 1950-01-01 00:00:00)<br/> +!> @code +!> PRINT *," CNES julian day",tl_date1\%r_jc +!> @endcode +!> +!> to create pseudo julian day with origin date_now:<br/> +!> @code +!> tl_date1=date_init(2012,12,10,td_dateo=date_now()) +!> @endcode +!> @note you erase CNES julian day when doing so<br/> +!> +!> to print julian day in seconds:<br/> +!> @code +!> PRINT *, tl_date1\%k_jdsec +!> @endcode +!> to print CNES or new julian day in seconds:<br/> +!> @code +!> PRINT *, tl_date1\%k_jcsec +!> @endcode +!> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +! +!> @note This module is based on Perderabo's date calculator (ksh) +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!> +!> @todo +!> - see calendar.f90 and select Gregorian, NoLeap, or D360 calendar +!---------------------------------------------------------------------- +MODULE date + + USE global ! global variable + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TDATE !< date structure + + PRIVATE :: cm_fmtdate !< date and time format + PRIVATE :: im_secbyday !< number of second by day + + ! function and subroutine + PUBLIC :: date_today !< return the date of the day at 12:00:00 + PUBLIC :: date_now !< return the date and time + PUBLIC :: date_time !< return the date and time in milliseconds + PUBLIC :: date_init !< initialized date structure form julian day or year month day + PUBLIC :: date_print !< print the date with format YYYY-MM-DD hh:mm:ss + PUBLIC :: date_leapyear !< check if year is a leap year + PUBLIC :: OPERATOR(-) !< substract two dates or n days to a date + PUBLIC :: OPERATOR(+) !< add n days to a date + + PRIVATE :: date__init_fmtdate ! initialized date structure from character YYYY-MM-DD hh:mm:ss + PRIVATE :: date__init_jd ! initialized date structure from julian day + PRIVATE :: date__init_nsec ! initialized date structure from number of second since origin of julian day + PRIVATE :: date__init_ymd ! initialized date structure from year month day + PRIVATE :: date__addnday ! add nday to a date + PRIVATE :: date__subnday ! substract nday to a date + PRIVATE :: date__diffdate ! compute number of days between two dates + PRIVATE :: date__lastday ! compute last day of the month + PRIVATE :: date__ymd2jd ! compute julian day from year month day + PRIVATE :: date__jd2ymd ! compute year month day from julian day + PRIVATE :: date__jc2jd ! compute julian day from pseudo julian day + PRIVATE :: date__jd2jc ! compute pseudo julian day with new date origin + PRIVATE :: date__jd2dow ! compute the day of week from julian day + PRIVATE :: date__hms2jd ! compute fraction of a day from hour, minute, second + PRIVATE :: date__jd2hms ! compute hour, minute, second from julian fraction + PRIVATE :: date__check ! check date in date structure + PRIVATE :: date__adjust ! adjust date + PRIVATE :: date__jd2sec ! convert julian day in seconds since julian day origin + PRIVATE :: date__sec2jd ! convert seconds since julian day origin in julian day + + TYPE TDATE !< date structure + INTEGER(i4) :: i_year = 1858 !< year + INTEGER(i4) :: i_month = 11 !< month + INTEGER(i4) :: i_day = 17 !< day + INTEGER(i4) :: i_hour = 0 !< hour + INTEGER(i4) :: i_min = 0 !< min + INTEGER(i4) :: i_sec = 0 !< sec + INTEGER(i4) :: i_dow = 0 !< day of week + INTEGER(i4) :: i_lday = 0 !< last day of the month + REAL(dp) :: d_jd = 0 !< julian day (origin : 1858/11/17 00:00:00) + REAL(dp) :: d_jc = 0 !< CNES julian day or pseudo julian day with new date origin + INTEGER(i8) :: k_jdsec = 0 !< number of seconds since julian day origin + INTEGER(i8) :: k_jcsec = 0 !< number of seconds since CNES or pseudo julian day origin + END TYPE TDATE + + ! module variable + CHARACTER(LEN=lc), PARAMETER :: cm_fmtdate = & !< date and time format + & "(i0.4,'-',i0.2,'-',i0.2,1x,i0.2,':',i0.2,':',i0.2)" + + INTEGER(i4), PARAMETER :: im_secbyday = 86400 !< number of second by day + + INTERFACE date_init + MODULE PROCEDURE date__init_jd ! initialized date structure from julian day + MODULE PROCEDURE date__init_nsec ! initialized date structure from number of second since origin of julian day + MODULE PROCEDURE date__init_ymd ! initialized date structure from year month day + MODULE PROCEDURE date__init_fmtdate ! initialized date structure from character YYYY-MM-DD hh:mm:ss + END INTERFACE date_init + + INTERFACE OPERATOR(+) + MODULE PROCEDURE date__addnday ! add nday to a date + END INTERFACE + + INTERFACE OPERATOR(-) + MODULE PROCEDURE date__subnday ! substract nday to a date + MODULE PROCEDURE date__diffdate ! compute number of day between two dates + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date_print(td_date, cd_fmt) & + & RESULT (cf_date) + !------------------------------------------------------------------- + !> @brief This function print the date and time with + !> format YYYY/MM/DD hh:mm:ss. + !> @details + !> Optionally, you could specify output format. However it will be + !> only apply to year, month, day. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @param[in] cd_fmt ouput format (only for year,month,day) + !> @return date in format YYYY-MM-DD hh:mm:ss + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE) , INTENT(IN) :: td_date + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_fmt + + ! function + CHARACTER(LEN=lc) :: cf_date + !---------------------------------------------------------------- + + IF( PRESENT(cd_fmt) )THEN + WRITE(cf_date,TRIM(cd_fmt)) & + & td_date%i_year,td_date%i_month,td_date%i_day + ELSE + WRITE(cf_date,cm_fmtdate) & + & td_date%i_year,td_date%i_month,td_date%i_day, & + & td_date%i_hour,td_date%i_min,td_date%i_sec + ENDIF + + END FUNCTION date_print + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date_leapyear(td_date) & + & RESULT (lf_leap) + !------------------------------------------------------------------- + !> @brief This function check if year is a leap year. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @return true if year is leap year + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + + ! function + LOGICAL :: lf_leap + !---------------------------------------------------------------- + + lf_leap=.false. + IF( (MOD(td_date%i_year,100_i4)==0) )THEN + IF( (MOD(td_date%i_year,400_i4)==0) )THEN + lf_leap=.true. + ENDIF + ELSE + IF( (MOD(td_date%i_year,4_i4)==0) )THEN + lf_leap=.true. + ENDIF + ENDIF + + END FUNCTION date_leapyear + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date_now() & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function return the current date and time. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @return current date and time in a date structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! function + TYPE(TDATE) :: tf_date + + ! local variable + INTEGER(sp), DIMENSION(8) :: il_values + !---------------------------------------------------------------- + + CALL DATE_AND_TIME( values= il_values) + + tf_date=date_init( il_values(1), il_values(2), il_values(3), & + & il_values(5), il_values(6), il_values(7) ) + + END FUNCTION date_now + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date_time() + !------------------------------------------------------------------- + !> @brief This subroutine print the current date and time in milliseconds. + !> + !> @author J.Paul + !> @date August, 2017 - Initial Version + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! local variable + INTEGER(sp), DIMENSION(8) :: il_values + CHARACTER(LEN=lc) :: cl_fmtdate = & !< date and time format + & "(i0.4,'-',i0.2,'-',i0.2,1x,i0.2,':',i0.2,':',i0.2'.',i0.3)" + !---------------------------------------------------------------- + + CALL DATE_AND_TIME( values= il_values) + + WRITE(*,cl_fmtdate) il_values(1),il_values(2),il_values(3),il_values(5),il_values(6),il_values(7),il_values(8) + + END SUBROUTINE date_time + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date_today() & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function return the date of the day at 12:00:00. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @return date of the day at 12:00:00 in a date structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! function + TYPE(TDATE) :: tf_date + + ! local variable + INTEGER(sp), DIMENSION(8) :: il_values + !---------------------------------------------------------------- + + CALL DATE_AND_TIME( values= il_values) + + tf_date=date_init( il_values(1), il_values(2), il_values(3), 12_i4 ) + + END FUNCTION date_today + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__init_fmtdate(cd_datetime, td_dateo) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function initialized date structure from a character + !> date with format YYYY-MM-DD hh:mm:ss.<br/> + !> @details + !> Optionaly create pseudo julian day with new origin.<br/> + !> julian day origin is 17 Nov 1858 at 00:00:00 + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date April, 2019 + !> - check time units CF convention, raise error if not + !> + !> @param[in] cd_date date in format YYYY-MM-DD hh:mm:ss + !> @param[in] td_dateo new date origin for pseudo julian day + !> @return date structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_datetime + TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo + + ! function + TYPE(TDATE) :: tf_date + + ! local variable + CHARACTER(LEN=lc) :: cl_datetime + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_time + CHARACTER(LEN=lc) :: cl_year + CHARACTER(LEN=lc) :: cl_month + CHARACTER(LEN=lc) :: cl_day + CHARACTER(LEN=lc) :: cl_hour + CHARACTER(LEN=lc) :: cl_min + CHARACTER(LEN=lc) :: cl_sec + CHARACTER(LEN=lc) :: cl_msg + + INTEGER(i4) :: il_year + INTEGER(i4) :: il_month + INTEGER(i4) :: il_day + INTEGER(i4) :: il_hour + INTEGER(i4) :: il_min + INTEGER(i4) :: il_sec + !---------------------------------------------------------------- + + cl_datetime=TRIM(ADJUSTL(cd_datetime)) + + cl_date=fct_split(cl_datetime,1,' ') + cl_time=fct_split(cl_datetime,2,' ') + + cl_year = fct_split(cl_date,1,'-') + READ(cl_year,*) il_year + cl_month= fct_split(cl_date,2,'-') + READ(cl_month, *) il_month + cl_day = fct_split(cl_date,3,'-') + READ(cl_day, *) il_day + cl_hour = fct_split(cl_time,1,':') + IF( TRIM(cl_hour) /= '' )THEN + READ(cl_hour, *) il_hour + ELSE + WRITE(cl_msg,*) "time units not conform to CF conventions" + CALL logger_error(cl_msg) + il_hour=0 + ENDIf + cl_min = fct_split(cl_time,2,':') + IF( TRIM(cl_min) /= '' )THEN + READ(cl_min, *) il_min + ELSE + WRITE(cl_msg,*) "time units not conform to CF conventions" + CALL logger_error(cl_msg) + il_min=0 + ENDIf + cl_sec = fct_split(cl_time,3,':') + IF( TRIM(cl_sec) /= '' )THEN + READ(cl_sec, *) il_sec + ELSE + WRITE(cl_msg,*) "time units not conform to CF conventions" + CALL logger_error(cl_msg) + il_sec=0 + ENDIf + + tf_date = date_init( il_year, il_month, il_day, il_hour, & + & il_min, il_sec, td_dateo=td_dateo ) + + END FUNCTION date__init_fmtdate + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__init_jd(dd_jd, td_dateo) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function initialized date structure from julian day.<br/> + !> @details + !> Optionaly create pseudo julian day with new origin.<br/> + !> julian day origin is 17 Nov 1858 at 00:00:00 + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_jd julian day + !> @param[in] td_dateo new date origin for pseudo julian day + !> + !> @return date structure of julian day + !------------------------------------------------------------------- + + IMPLICIT NONE + + !Argument + REAL(dp), INTENT(IN) :: dd_jd + TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo + + ! function + TYPE(TDATE) :: tf_date + !---------------------------------------------------------------- + IF( PRESENT(td_dateo) )THEN + CALL date__check(td_dateo) + + ! pseudo julian day with origin dateo + tf_date%d_jc=dd_jd + tf_date%k_jcsec=date__jd2sec(dd_jd) + + ! convert to truly julian day + CALL date__jc2jd(tf_date, td_dateo) + ELSE + tf_date%d_jd=dd_jd + tf_date%k_jdsec=date__jd2sec(dd_jd) + + ! compute CNES julian day + CALL date__jd2jc(tf_date) + ENDIF + + ! check input data + CALL date__check(tf_date) + + ! compute year month day hour min sec + CALL date__jd2ymd(tf_date) + + ! compute day of the wekk + CALL date__jd2dow(tf_date) + + !compute last day of the month + tf_date%i_lday=date__lastday(tf_date) + + END FUNCTION date__init_jd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__init_nsec(kd_nsec, td_dateo) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function initialized date structure from number of + !> second since julian day origin.<br/> + !> @details + !> Optionaly create pseudo julian day with new origin. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] kd_nsec number of second since julian day origin + !> @param[in] td_dateo new date origin for pseudo julian day + !> + !> @return date structure of julian day + !------------------------------------------------------------------- + + IMPLICIT NONE + + !Argument + INTEGER(i8), INTENT(IN) :: kd_nsec + TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo + + ! function + TYPE(TDATE) :: tf_date + !---------------------------------------------------------------- + IF( PRESENT(td_dateo) )THEN + tf_date=date_init( date__sec2jd(kd_nsec), td_dateo ) + ELSE + tf_date=date_init( date__sec2jd(kd_nsec) ) + ENDIF + + END FUNCTION date__init_nsec + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__init_ymd(id_year, id_month, id_day, & + & id_hour, id_min, id_sec, & + & td_dateo) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function initialized date structure form year month day + !> and optionnaly hour min sec.<br/> + !> @details + !> Optionaly create pseudo julian day with new origin. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] id_year + !> @param[in] id_month + !> @param[in] id_day + !> @param[in] id_hour + !> @param[in] id_min + !> @param[in] id_sec + !> @param[in] td_dateo new date origin for pseudo julian day + !> + !> @return date structure of year month day + !------------------------------------------------------------------- + + IMPLICIT NONE + + !Argument + INTEGER(i4), INTENT(IN) :: id_year + INTEGER(i4), INTENT(IN) :: id_month + INTEGER(i4), INTENT(IN) :: id_day + INTEGER(i4), INTENT(IN), OPTIONAL :: id_hour + INTEGER(i4), INTENT(IN), OPTIONAL :: id_min + INTEGER(i4), INTENT(IN), OPTIONAL :: id_sec + TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo + + ! function + TYPE(TDATE) :: tf_date + !---------------------------------------------------------------- + tf_date%i_year=id_year + tf_date%i_month=id_month + tf_date%i_day=id_day + IF( PRESENT(id_hour) )THEN + tf_date%i_hour=id_hour + ENDIF + IF( PRESENT(id_min) )THEN + tf_date%i_min=id_min + ENDIF + IF( PRESENT(id_sec) )THEN + tf_date%i_sec=id_sec + ENDIF + ! check input data + CALL date__check(tf_date) + + ! compute julian day + CALL date__ymd2jd(tf_date) + + IF( PRESENT(td_dateo) )THEN + CALL date__check(td_dateo) + ! compute julian day with origin dateo + CALL date__jd2jc(tf_date, td_dateo) + ELSE + ! compute CNES julian day + CALL date__jd2jc(tf_date) + ENDIF + + ! compute day of the week + CALL date__jd2dow(tf_date) + + !compute last day of the month + tf_date%i_lday=date__lastday(tf_date) + + END FUNCTION date__init_ymd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__diffdate(td_date1, td_date2) & + & RESULT (df_diff) + !------------------------------------------------------------------- + !> @brief This function compute number of day between two dates: + !> nday= date1 - date2 + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date1 first date strutcutre + !> @param[in] td_date2 second date strutcutre + !> @return nday + !------------------------------------------------------------------- + + IMPLICIT NONE + + !Argument + TYPE(TDATE), INTENT(IN) :: td_date1 + TYPE(TDATE), INTENT(IN) :: td_date2 + + ! function + REAL(dp) :: df_diff + !---------------------------------------------------------------- + + ! check year month day hour min sec + CALL date__check(td_date1) + CALL date__check(td_date2) + + df_diff = td_date1%d_jd - td_date2%d_jd + + END FUNCTION date__diffdate + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__subnday(td_date, dd_nday) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function substract nday to a date: + !> date2 = date1 - nday + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @param[in] dd_nday number of day + !> @return date strutcutre of date - nday + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + REAL(dp), INTENT(IN) :: dd_nday + + ! function + TYPE(TDATE) :: tf_date + !---------------------------------------------------------------- + + ! check year month day hour min sec + CALL date__check(td_date) + + tf_date=date__init_jd(td_date%d_jd-dd_nday) + + END FUNCTION date__subnday + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__addnday(td_date, dd_nday) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief This function add nday to a date: + !> date2 = date1 + nday + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @param[in] dd_nday number of day + !> @return date strutcutre of date + nday + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + REAL(dp), INTENT(IN) :: dd_nday + + ! function + TYPE(TDATE) :: tf_date + !---------------------------------------------------------------- + + ! check year month day hour min sec + CALL date__check(td_date) + + tf_date=date__init_jd(td_date%d_jd+dd_nday) + + END FUNCTION date__addnday + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__lastday(td_date) & + & RESULT (if_lday) + !------------------------------------------------------------------- + !> @brief This subroutine compute last day of the month + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @return last day of the month + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + + ! function + INTEGER(i4) :: if_lday + + ! local variable + INTEGER, DIMENSION(12), PARAMETER :: il_lastdaytab = & + & (/31,28,31,30,31,30,31,31,30,31,30,31/) + !---------------------------------------------------------------- + + ! general case + IF( td_date%i_month /= 2 )THEN + if_lday=il_lastdaytab(td_date%i_month) + ELSE + IF( date_leapyear(td_date) )THEN + if_lday=29 + ELSE + if_lday=il_lastdaytab(td_date%i_month) + ENDIF + ENDIF + + END FUNCTION date__lastday + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__ymd2jd(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine compute julian day from year month day , and fill + !> input date strutcutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + + ! local variable + REAL(dp) :: dl_standard_jd + REAL(dp) :: dl_frac + !---------------------------------------------------------------- + + dl_standard_jd= td_date%i_day - 32075 & + & + 1461 * (td_date%i_year + 4800 - (14 - td_date%i_month)/12)/4 & + & + 367 * (td_date%i_month - 2 + (14 - td_date%i_month)/12*12)/12 & + & - 3 * ((td_date%i_year + 4900 - (14 - td_date%i_month)/12)/100)/4 + + td_date%d_jd = dl_standard_jd-2400001 ! origin : 17 nov 1858 h00m00s00 + + ! compute fraction of day + dl_frac=date__hms2jd(td_date) + + td_date%d_jd = td_date%d_jd + dl_frac + + td_date%k_jdsec = date__jd2sec( td_date%d_jd ) + + END SUBROUTINE date__ymd2jd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__jd2ymd(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine compute year month day from julian day, and fill + !> input date strutcutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + + ! local variable + INTEGER(i4) :: il_standard_jd + INTEGER(i4) :: il_temp1 + INTEGER(i4) :: il_temp2 + !---------------------------------------------------------------- + + ! check year month day hour min sec + CALL date__check(td_date) + + il_standard_jd=INT( td_date%d_jd+2400001, i4 ) + + il_temp1=il_standard_jd + 68569 + il_temp2=4*il_temp1/146097 + il_temp1=il_temp1 - (146097 * il_temp2 + 3) / 4 + td_date%i_year = 4000 * (il_temp1 + 1) / 1461001 + il_temp1 = il_temp1 - 1461 * td_date%i_year/4 + 31 + td_date%i_month = 80 * il_temp1 / 2447 + td_date%i_day = il_temp1 - 2447 * td_date%i_month / 80 + il_temp1 = td_date%i_month / 11 + td_date%i_month = td_date%i_month + 2 - 12 * il_temp1 + td_date%i_year = 100 * (il_temp2 - 49) + td_date%i_year + il_temp1 + + ! compute hour, minute, second from julian fraction + CALL date__jd2hms(td_date) + + ! adjust date + CALL date__adjust(td_date) + + END SUBROUTINE date__jd2ymd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__jc2jd(td_date, td_dateo) + !------------------------------------------------------------------- + !> @brief This subroutine compute julian day from pseudo julian day + !> with new date origin, and fill input date strutcutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date + !> @param[in] td_dateo new date origin for pseudo julian day + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + TYPE(TDATE), INTENT(IN) :: td_dateo + + ! local variable + TYPE(TDATE) :: tl_date + REAL(dp) :: dl_nday + !---------------------------------------------------------------- + ! origin julian day + tl_date=date_init(1858,11,17) + + dl_nday=td_dateo-tl_date + + ! compute julian day + td_date%d_jd = td_date%d_jc + dl_nday + ! compute number of second since julian day origin + td_date%k_jdsec = date__jd2sec(td_date%d_jd) + + END SUBROUTINE date__jc2jd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__jd2jc(td_date, td_dateo) + !------------------------------------------------------------------- + !> @brief This subroutine compute pseudo julian day with new date origin, and + !> fill input date structure.<br/> + !> default new origin is CNES julian day origin: 1950-01-01 00:00:00 + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date + !> @param[in] td_dateo new origin date + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo + + ! local variable + TYPE(TDATE) :: tl_dateo + !---------------------------------------------------------------- + IF( PRESENT(td_dateo) )THEN + td_date%d_jc=td_date%d_jd-td_dateo%d_jd + ELSE + ! CNES julian day origin + tl_dateo%i_year = 1950 + tl_dateo%i_month = 1 + tl_dateo%i_day = 1 + + CALL date__ymd2jd(tl_dateo) + + td_date%d_jc = td_date%d_jd-tl_dateo%d_jd + ENDIF + + td_date%k_jcsec = date__jd2sec(td_date%d_jc) + + END SUBROUTINE date__jd2jc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__jd2dow(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine compute the day of week from julian day, and fill + !> input date structure.<br/> + !> days : Sunday Monday Tuesday Wednesday Thursday Friday Saturday<br/> + !> numday : 0 1 2 3 4 5 6<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + !---------------------------------------------------------------- + + td_date%i_dow=MOD((INT(AINT(td_date%d_jd))+3),7) + + END SUBROUTINE date__jd2dow + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__hms2jd(td_date) & + & RESULT (df_frac) + !------------------------------------------------------------------- + !> @brief This function compute fraction of a day from + !> hour, minute, second. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @return fraction of the day + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + + ! function + REAL(dp) :: df_frac + !---------------------------------------------------------------- + + ! compute real seconds + df_frac = REAL( td_date%i_sec, dp ) + ! compute real minutes + df_frac = REAL( td_date%i_min, dp ) + df_frac/60.0 + ! compute real hours + df_frac = REAL( td_date%i_hour, dp ) + df_frac/60.0 + ! julian fraction of a day + df_frac = df_frac/24.0 + + END FUNCTION date__hms2jd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__jd2hms(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine compute hour, minute, second from julian + !> fraction, and fill date structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + + !local variable + REAL(dp) :: dl_fract + !---------------------------------------------------------------- + + dl_fract=(td_date%d_jd)-AINT(td_date%d_jd) + ! compute hour + td_date%i_hour = INT( dl_fract * 24.0, i4 ) + dl_fract = ( dl_fract - REAL( td_date%i_hour, dp ) / 24.0) * 24.0 + ! compute minute + td_date%i_min = INT( dl_fract * 60.0, i4 ) + dl_fract = ( dl_fract - REAL( td_date%i_min, dp ) / 60.0) * 60.0 + ! compute second + td_date%i_sec = NINT( dl_fract * 60.0, i4 ) + + END SUBROUTINE date__jd2hms + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__check(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine check date express in date structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(IN) :: td_date + + ! local variable + INTEGER(i4) :: il_lastday + INTEGER(i4) :: il_status + CHARACTER(LEN=lc) :: cl_msg + !---------------------------------------------------------------- + + ! init + il_status=0 + + ! check year + IF( td_date%i_year < 1858_i4 .OR. td_date%i_year > 39999_i4 )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "year ",td_date%i_year," out of range" + CALL logger_error(cl_msg) + ENDIF + ! check month + IF( td_date%i_month < 1_i4 .OR. td_date%i_month > 12_i4 )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "month ",td_date%i_month," out of range" + CALL logger_error(cl_msg) + ENDIF + ! check day + il_lastday=date__lastday(td_date) + IF( td_date%i_day < 1_i4 .OR. td_date%i_day > il_lastday )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "day ",td_date%i_day," out of range" + CALL logger_error(cl_msg) + ENDIF + ! check hour + IF( td_date%i_hour < 0_i4 .OR. td_date%i_hour > 23_i4 )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "hour ",td_date%i_hour," out of range" + CALL logger_error(cl_msg) + ENDIF + ! check minutes + IF( td_date%i_min < 0_i4 .OR. td_date%i_min > 59_i4 )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "minutes ",td_date%i_min," out of range" + CALL logger_error(cl_msg) + ENDIF + ! check seconds + IF( td_date%i_sec < 0_i4 .OR. td_date%i_sec > 59_i4 )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "seconds ",td_date%i_sec," out of range" + CALL logger_error(cl_msg) + ENDIF + + ! check julian day + IF( td_date%d_jd < 0_sp .OR. td_date%d_jd > 782028_sp )THEN + il_status=il_status+1 + WRITE(cl_msg,*) "julian day ",td_date%d_jd," out of range" + CALL logger_error(cl_msg) + ENDIF + + IF( il_status/= 0 )THEN + WRITE(cl_msg,*) " date error" + CALL logger_fatal(cl_msg) + ENDIF + + END SUBROUTINE date__check + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE date__adjust(td_date) + !------------------------------------------------------------------- + !> @brief This subroutine adjust date (correct hour, minutes, and seconds + !> value if need be) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_date date strutcutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDATE), INTENT(INOUT) :: td_date + !---------------------------------------------------------------- + + IF( td_date%i_sec == 60 )THEN + td_date%i_sec=0 + td_date%i_min=td_date%i_min+1 + ENDIF + + IF( td_date%i_min == 60 )THEN + td_date%i_min=0 + td_date%i_hour=td_date%i_hour+1 + ENDIF + + IF( td_date%i_hour == 24 )THEN + td_date%i_hour=0 + td_date=date__addnday(td_date,1._dp) + ENDIF + + END SUBROUTINE date__adjust + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__jd2sec(dd_jul) & + & RESULT (if_sec) + !------------------------------------------------------------------- + !> @brief This function convert julian day in seconds + !> since julian day origin. + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_date date strutcutre + !> @return number of seconds since julian day origin + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), INTENT(IN) :: dd_jul + + ! function + INTEGER(i8) :: if_sec + !---------------------------------------------------------------- + + if_sec = NINT( dd_jul * im_secbyday, i8 ) + + END FUNCTION date__jd2sec + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION date__sec2jd(kd_nsec) & + & RESULT (df_sec) + !------------------------------------------------------------------- + !> @brief This function convert seconds since julian day origin in + !> julian day. + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] kd_nsec number of second since julian day origin + !> @return julian day + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i8), INTENT(IN) :: kd_nsec + + ! function + REAL(dp) :: df_sec + !---------------------------------------------------------------- + + df_sec = REAL( REAL( kd_nsec , dp ) / im_secbyday, dp ) + + END FUNCTION date__sec2jd + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE date + diff --git a/V4.0/nemo_sources/tools/SIREN/src/dimension.f90 b/V4.0/nemo_sources/tools/SIREN/src/dimension.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8b429221c35466ba61e5676ec7f5d3ad48d4d9e9 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/dimension.f90 @@ -0,0 +1,1772 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage dimension and how to change order of those dimension. +!> +!> @details +!> define type TDIM:<br/> +!> @code +!> TYPE(TDIM) :: tl_dim +!> @endcode +!> +!> to initialize a dimension structure:<br/> +!> @code +!> tl_dim=dim_init( cd_name, [id_len,] [ld_uld,] [cd_sname]) +!> @endcode +!> - cd_name is the dimension name +!> - id_len is the dimension size [optional] +!> - ld_uld is true if this dimension is the unlimited one [optional] +!> - cd_sname is the dimension short name ('x','y','z','t') [optional] +!> +!> to clean dimension structure:<br/> +!> @code +!> CALL dim_clean(tl_dim) +!> @endcode +!> - tl_dim : dimension strucutre or array of dimension structure +!> +!> to print information about dimension structure:<br/> +!> @code +!> CALL dim_print(tl_dim) +!> @endcode +!> +!> to copy dimension structure in another one (using different memory cell):<br/> +!> @code +!> tl_dim2=dim_copy(tl_dim1) +!> @endcode +!> +!> to get dimension name:<br/> +!> - tl_dim\%c_name +!> +!> to get dimension short name:<br/> +!> - tl_dim\%c_sname +!> +!> to get dimension length:<br/> +!> - tl_dim\%i_len +!> +!> to know if dimension is the unlimited one:<br/> +!> - tl_dim\%l_uld +!> +!> to get dimension id (for variable or file dimension):<br/> +!> - tl_dim\%i_id +!> +!> to know if dimension is used (for variable or file dimension):<br/> +!> - tl_dim\%l_use +!> +!> Former function or information concern only one dimension. However +!> variables as well as files use usually 4 dimensions.<br/> +!> To easily work with variable we want they will be all 4D and ordered as +!> following: ('x','y','z','t').<br/> +!> Functions and subroutines below, allow to reorder dimension of +!> variable.<br/> +!> +!> Suppose we defined the array of dimension structure below:<br/> +!> @code +!> TYPE(TDIM), DIMENSION(4) :: tl_dim +!> tl_dim(1)=dim_init( 'X', id_len=10) +!> tl_dim(2)=dim_init( 'T', id_len=3, ld_uld=.TRUE.) +!> @endcode +!> +!> to reorder dimension (default order: ('x','y','z','t')):<br/> +!> @code +!> CALL dim_reorder(tl_dim(:)) +!> @endcode +!> +!> This subroutine filled dimension structure with unused dimension, +!> then switch from "disordered" dimension to "ordered" dimension.<br/> +!> The dimension structure return will be:<br/> +!> tl_dim(1) => 'X', i_len=10, l_use=T, l_uld=F<br/> +!> tl_dim(2) => 'Y', i_len=1, l_use=F, l_uld=F<br/> +!> tl_dim(3) => 'Z', i_len=1, l_use=F, l_uld=F<br/> +!> tl_dim(4) => 'T', i_len=3, l_use=T, l_uld=T<br/> +!> +!> After using subroutine dim_reorder you could use functions and subroutine +!> below.<br/> +!> +!> to use another dimension order.<br/> +!> @code +!> CALL dim_reorder(tl(dim(:), cl_neworder) +!> @endcode +!> - cl_neworder : character(len=4) (example: 'yxzt') +!> +!> to switch dimension array from ordered dimension to disordered +!> dimension:<br/> +!> @code +!> CALL dim_disorder(tl_dim(:)) +!> @endcode +!> +!> to fill unused dimension of an array of dimension structure.<br/> +!> @code +!> tl_dimout(:)=dim_fill_unused(tl_dimin(:)) +!> @endcode +!> - tl_dimout(:) : 1D array (4elts) of dimension strcuture +!> - tl_dimin(:) : 1D array (<=4elts) of dimension structure +!> +!> to reshape array of value in "ordered" dimension:<br/> +!> @code +!> CALL dim_reshape_2xyzt(tl_dim(:), value(:,:,:,:)) +!> @endcode +!> - value must be a 4D array of real(8) value "disordered" +!> +!> to reshape array of value in "disordered" dimension:<br/> +!> @code +!> CALL dim_reshape_xyzt2(tl_dim(:), value(:,:,:,:)) +!> @endcode +!> - value must be a 4D array of real(8) value "ordered" +!> +!> to reorder a 1D array of 4 elements in "ordered" dimension:<br/> +!> @code +!> CALL dim_reorder_2xyzt(tl_dim(:), tab(:)) +!> @endcode +!> - tab must be a 1D array with 4 elements "disordered". +!> It could be composed of character, integer(4), or logical +!> +!> to reorder a 1D array of 4 elements in "disordered" dimension:<br/> +!> @code +!> CALL dim_reorder_xyzt2(tl_dim(:), tab(:)) +!> @endcode +!> - tab must be a 1D array with 4 elements "ordered". +!> It could be composed of character, integer(4), or logical +!> +!> to get dimension index from a array of dimension structure, +!> given dimension name or short name :<br/> +!> @code +!> index=dim_get_index( tl_dim(:), [cl_name, cl_sname] ) +!> @endcode +!> - tl_dim(:) : array of dimension structure +!> - cl_name : dimension name [optional] +!> - cl_sname: dimension short name [optional] +!> +!> to get dimension id used in an array of dimension structure, +!> given dimension name or short name :<br/> +!> @code +!> id=dim_get_id( tl_dim(:), [cl_name, cl_sname] ) +!> @endcode +!> - tl_dim(:) : array of dimension structure +!> - cl_name : dimension name [optional] +!> - cl_sname: dimension short name [optional] +!> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2015 +!> - manage useless (dummy) dimension +!> @date October, 2016 +!> - dimension allowed read in configuration file +!> @date May, 2019 +!> - read number of element for each dimension allowed in configuration file +!> - read number of element for each dummy array in configuration file +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE dim + + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TDIM !< dimension structure + + PRIVATE :: im_ndumdim !< number of elt in dummy dimension array + PRIVATE :: cm_dumdim !< dummy dimension array + PRIVATE :: im_dimX !< number of elt in x dimension array + PRIVATE :: im_dimY !< number of elt in y dimension array + PRIVATE :: im_dimZ !< number of elt in z dimension array + PRIVATE :: im_dimT !< number of elt in t dimension array + PRIVATE :: cm_dimX !< x dimension array + PRIVATE :: cm_dimY !< y dimension array + PRIVATE :: cm_dimZ !< z dimension array + PRIVATE :: cm_dimT !< t dimension array + + ! function and subroutine + PUBLIC :: dim_init !< initialize dimension structure + PUBLIC :: dim_clean !< clean dimension structuree + PUBLIC :: dim_print !< print dimension information + PUBLIC :: dim_copy !< copy dimension structure + PUBLIC :: dim_reorder !< filled dimension structure to switch from disordered to ordered dimension + PUBLIC :: dim_disorder !< switch dimension array from ordered to disordered dimension + PUBLIC :: dim_fill_unused !< filled dimension structure with unused dimension + PUBLIC :: dim_reshape_2xyzt !< reshape array dimension to ('x','y','z','t') + PUBLIC :: dim_reshape_xyzt2 !< reshape array dimension from ('x','y','z','t') + PUBLIC :: dim_reorder_2xyzt !< reorder 1D array to ('x','y','z','t') + PUBLIC :: dim_reorder_xyzt2 !< reorder 1D array from ('x','y','z','t') + PUBLIC :: dim_get_index !< get dimension index in array of dimension structure + PUBLIC :: dim_get_id !< get dimension id in array of dimension structure + PUBLIC :: dim_get_dummy !< fill dummy dimension array + PUBLIC :: dim_is_dummy !< check if dimension is defined as dummy dimension + PUBLIC :: dim_def_extra !< read dimension configuration file, and save dimension allowed. + + PRIVATE :: dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t') + PRIVATE :: dim__reshape_xyzt2_dp ! reshape real(8) 4D array from ('x','y','z','t') + PRIVATE :: dim__reorder_2xyzt_i4 ! reorder integer(4) 1D array to ('x','y','z','t') + PRIVATE :: dim__reorder_xyzt2_i4 ! reorder integer(4) 1D array from ('x','y','z','t') + PRIVATE :: dim__reorder_2xyzt_l ! reorder logical 1D array to ('x','y','z','t') + PRIVATE :: dim__reorder_xyzt2_l ! reorder logical 1D array from ('x','y','z','t') + PRIVATE :: dim__reorder_2xyzt_c ! reorder string 1D array to ('x','y','z','t') + PRIVATE :: dim__reorder_xyzt2_c ! reorder string 1D array from ('x','y','z','t') + PRIVATE :: dim__clean_unit ! clean one dimension structure + PRIVATE :: dim__clean_arr ! clean a array of dimension structure + PRIVATE :: dim__print_unit ! print information on one dimension structure + PRIVATE :: dim__print_arr ! print information on a array of dimension structure + PRIVATE :: dim__copy_unit ! copy dimension structure + PRIVATE :: dim__copy_arr ! copy array of dimension structure + PRIVATE :: dim__is_allowed + + TYPE TDIM !< dimension structure + CHARACTER(LEN=lc) :: c_name = '' !< dimension name + CHARACTER(LEN=lc) :: c_sname = 'u' !< dimension short name + INTEGER(i4) :: i_id = 0 !< dimension id + INTEGER(i4) :: i_len = 1 !< dimension length + LOGICAL :: l_uld = .FALSE. !< dimension unlimited or not + LOGICAL :: l_use = .FALSE. !< dimension used or not + INTEGER(i4) :: i_2xyzt = 0 !< indices to reshape array to ('x','y','z','t') + INTEGER(i4) :: i_xyzt2 = 0 !< indices to reshape array from ('x','y','z','t') + END TYPE + + INTEGER(i4) , SAVE :: im_ndumdim !< number of elt in dummy dimension array + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg), SAVE :: cm_dumdim !< dummy dimension + INTEGER(i4) , SAVE :: im_dimX !< number of elt in x dimension array + INTEGER(i4) , SAVE :: im_dimY !< number of elt in y dimension array + INTEGER(i4) , SAVE :: im_dimZ !< number of elt in z dimension array + INTEGER(i4) , SAVE :: im_dimT !< number of elt in t dimension array + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg), SAVE :: cm_dimX !< x dimension + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg), SAVE :: cm_dimY !< y dimension + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg), SAVE :: cm_dimZ !< z dimension + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg), SAVE :: cm_dimT !< t dimension + + INTERFACE dim_print + MODULE PROCEDURE dim__print_unit ! print information on one dimension + MODULE PROCEDURE dim__print_arr ! print information on a array of dimension + END INTERFACE dim_print + + INTERFACE dim_clean + MODULE PROCEDURE dim__clean_unit ! clean one dimension + MODULE PROCEDURE dim__clean_arr ! clean a array of dimension + END INTERFACE dim_clean + + INTERFACE dim_copy + MODULE PROCEDURE dim__copy_unit ! copy dimension structure + MODULE PROCEDURE dim__copy_arr ! copy array of dimension structure + END INTERFACE + + INTERFACE dim_reshape_2xyzt + MODULE PROCEDURE dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t') + END INTERFACE dim_reshape_2xyzt + + INTERFACE dim_reshape_xyzt2 + MODULE PROCEDURE dim__reshape_xyzt2_dp ! reshape real(8) 4D array from ('x','y','z','t') + END INTERFACE dim_reshape_xyzt2 + + INTERFACE dim_reorder_2xyzt + MODULE PROCEDURE dim__reorder_2xyzt_i4 ! reorder integer(4) 1D array to ('x','y','z','t') + MODULE PROCEDURE dim__reorder_2xyzt_c ! reorder string 1D array to ('x','y','z','t') + MODULE PROCEDURE dim__reorder_2xyzt_l ! reorder logical 1D array to ('x','y','z','t') + END INTERFACE dim_reorder_2xyzt + + INTERFACE dim_reorder_xyzt2 + MODULE PROCEDURE dim__reorder_xyzt2_i4 ! reorder integer(4) 1D array from ('x','y','z','t') + MODULE PROCEDURE dim__reorder_xyzt2_c ! reorder string 1D array from ('x','y','z','t') + MODULE PROCEDURE dim__reorder_xyzt2_l ! reorder logical 1D array from ('x','y','z','t') + END INTERFACE dim_reorder_xyzt2 + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__copy_arr(td_dim) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy a array of dimension structure in another one + !> @details + !> see dim__copy_unit + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_dim=dim_copy(dim_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @return copy of input array of dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + + ! function + TYPE(TDIM), DIMENSION(SIZE(td_dim(:))) :: tf_dim + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_dim(:)) + tf_dim(ji)=dim_copy(td_dim(ji)) + ENDDO + + END FUNCTION dim__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__copy_unit(td_dim) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy an dimension structure in another one + !> @details + !> dummy function to get the same use for all structure + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_dim=dim_copy(dim_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> + !> @param[in] td_dim dimension structure + !> @return copy of input dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), INTENT(IN) :: td_dim + + ! function + TYPE(TDIM) :: tf_dim + + ! local variable + !---------------------------------------------------------------- + + tf_dim=td_dim + + END FUNCTION dim__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim_get_index(td_dim, cd_name, cd_sname) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function returns dimension index, + !> given dimension name or short name. + !> + !> @details + !> the function check dimension name, in the array of dimension structure. + !> dimension could be used or not. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - do not check if dimension used + !> + !> @param[in] td_dim array of dimension structure + !> @param[in] cd_name dimension name + !> @param[in] cd_sname dimension short name + !> @return dimension index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname + + ! function + INTEGER(i4) :: if_idx + + ! local variable + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_dim_name + CHARACTER(LEN=lc) :: cl_sname + CHARACTER(LEN=lc) :: cl_dim_sname + + INTEGER(i4) :: il_ndim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! init + if_idx=0 + + il_ndim=SIZE(td_dim(:)) + + ! look for dimension name + cl_name=fct_lower(cd_name) + ! check if dimension is in array of dimension structure + DO ji=1,il_ndim + cl_dim_name=fct_lower(td_dim(ji)%c_name) + IF( TRIM(cl_dim_name) == TRIM(cl_name) )THEN + if_idx=ji + EXIT + ENDIF + ENDDO + + ! look for dimension short name + IF( if_idx == 0 )THEN + + cl_sname=fct_lower(cd_name) + ! check if dimension is in array of dimension structure + DO ji=1,il_ndim + cl_dim_sname=fct_lower(td_dim(ji)%c_sname) + IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ) )THEN + CALL logger_debug("DIM GET INDEX: variable short name "//& + & TRIM(ADJUSTL(cd_name))//" already in file") + if_idx=ji + EXIT + ENDIF + ENDDO + + ENDIF + + ! look for dimension short name + IF( PRESENT(cd_sname) )THEN + IF( if_idx == 0 )THEN + + cl_sname=fct_lower(cd_sname) + ! check if dimension is in array of dimension structure + DO ji=1,il_ndim + cl_dim_sname=fct_lower(td_dim(ji)%c_sname) + IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ) )THEN + CALL logger_debug("DIM GET INDEX: variable short name "//& + & TRIM(ADJUSTL(cd_sname))//" already in file") + if_idx=ji + EXIT + ENDIF + ENDDO + + ENDIF + ENDIF + + END FUNCTION dim_get_index + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim_get_id(td_dim, cd_name, cd_sname) & + & RESULT (if_id) + !------------------------------------------------------------------- + !> @brief This function returns dimension id, in a array of dimension structure, + !> given dimension name, or short name. + !> @note only dimension used are checked. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim dimension structure + !> @param[in] cd_name dimension name or short name + !> @param[in] cd_sname dimension short name + !> @return dimension id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname + + ! function + INTEGER(i4) :: if_id + + ! local variable + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_dim_name + CHARACTER(LEN=lc) :: cl_sname + CHARACTER(LEN=lc) :: cl_dim_sname + + INTEGER(i4) :: il_ndim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! init + if_id=0 + + il_ndim=SIZE(td_dim(:)) + + ! look for dimension name + cl_name=fct_lower(cd_name) + ! check if dimension is in array of dimension structure and used + jj=0 + DO ji=1,il_ndim + cl_dim_name=fct_lower(td_dim(ji)%c_name) + IF( TRIM(cl_dim_name) == TRIM(cl_name) .AND. & + & td_dim(ji)%l_use )THEN + IF( td_dim(ji)%i_id /= 0 )THEN + if_id=td_dim(ji)%i_id + EXIT + ENDIF + ENDIF + ENDDO + + ! look for dimension short name + IF( if_id == 0 )THEN + + cl_sname=fct_lower(cd_name) + ! check if dimension is in array of dimension structure and used + jj=0 + DO ji=1,il_ndim + cl_dim_sname=fct_lower(td_dim(ji)%c_sname) + IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.& + & td_dim(ji)%l_use )THEN + IF( td_dim(ji)%i_id /= 0 )THEN + if_id=td_dim(ji)%i_id + EXIT + ENDIF + ENDIF + ENDDO + + ENDIF + + ! look for dimension short name + IF( PRESENT(cd_sname) )THEN + IF( if_id == 0 )THEN + + cl_sname=fct_lower(cd_sname) + ! check if dimension is in array of dimension structure and used + jj=0 + DO ji=1,il_ndim + cl_dim_sname=fct_lower(td_dim(ji)%c_sname) + IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.& + & td_dim(ji)%l_use )THEN + IF( td_dim(ji)%i_id /= 0 )THEN + if_id=td_dim(ji)%i_id + EXIT + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + + END FUNCTION dim_get_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim_init(cd_name, id_len, ld_uld, cd_sname, ld_use) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function initialize a dimension structure with given + !> name.<br/> + !> @details + !> Optionally length could be inform, as well as short name and if dimension + !> is unlimited or not.<br/> + !> By default, define dimension is supposed to be used. + !> Optionally you could force a defined dimension to be unused. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - add optional argument to define dimension unused + !> @date July, 2015 + !> - Bug fix: inform order to disorder table instead of disorder to order + !> table + !> @date May, 2019 + !> - use number of element for each dimention allowed, instead of while loop + !> + !> @param[in] cd_name dimension name + !> @param[in] id_len dimension length + !> @param[in] ld_uld dimension unlimited + !> @param[in] cd_sname dimension short name + !> @param[in] ld_use dimension use or not + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), INTENT(IN), OPTIONAL :: id_len + LOGICAL, INTENT(IN), OPTIONAL :: ld_uld + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname + LOGICAL, INTENT(IN), OPTIONAL :: ld_use + + ! function + TYPE(TDIM) :: tf_dim + + ! local variable + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_sname + !---------------------------------------------------------------- + + ! clean dimension + CALL dim_clean(tf_dim) + + cl_name=fct_upper(cd_name) + + CALL logger_debug( & + & " DIM INIT: dimension name: "//TRIM(cl_name) ) + tf_dim%c_name=TRIM(ADJUSTL(cd_name)) + + IF( PRESENT(id_len) )THEN + CALL logger_debug( & + & " DIM INIT: dimension length: "//fct_str(id_len) ) + tf_dim%i_len=id_len + ENDIF + + ! define dimension is supposed to be used + IF( PRESENT(ld_use) )THEN + tf_dim%l_use=ld_use + ELSE + tf_dim%l_use=.TRUE. + ENDIF + + IF( PRESENT(cd_sname) )THEN + + cl_sname=fct_lower(cd_sname) + + IF( TRIM(cl_sname) == 'x' .OR. & + & TRIM(cl_sname) == 'y' .OR. & + & TRIM(cl_sname) == 'z' .OR. & + & TRIM(cl_sname) == 't' )THEN + CALL logger_debug( & + & " DIM INIT: dimension short name: "//TRIM(cd_sname) ) + tf_dim%c_sname=TRIM(cd_sname) + ELSE + CALL logger_warn("DIM INIT: invalid short name."//& + " choose between ('x','y','z','t')") + ENDIF + ENDIF + + IF( TRIM(fct_lower(tf_dim%c_sname)) == 'u' )THEN + + cl_name=fct_lower(cd_name) + + IF( dim__is_allowed(TRIM(cl_name), cm_dimX(:), im_dimX) )THEN + tf_dim%c_sname='x' + ELSEIF( dim__is_allowed(TRIM(cl_name), cm_dimY(:), im_dimY) )THEN + tf_dim%c_sname='y' + ELSEIF( dim__is_allowed(TRIM(cl_name), cm_dimZ(:), im_dimZ) )THEN + tf_dim%c_sname='z' + ELSEIF( dim__is_allowed(TRIM(cl_name), cm_dimT(:), im_dimT) )THEN + tf_dim%c_sname='t' + ELSE + CALL logger_warn("DIM INIT: "//TRIM(cd_name)//& + " not allowed.") + ENDIF + + ENDIF + + IF( PRESENT(ld_uld) )THEN + CALL logger_debug( & + & " DIM INIT: unlimited dimension: "//fct_str(ld_uld) ) + tf_dim%l_uld=ld_uld + ELSE + IF( TRIM(fct_lower(tf_dim%c_sname)) =='t' )THEN + tf_dim%l_uld=.TRUE. + ENDIF + ENDIF + + ! get dimension order indices + tf_dim%i_xyzt2=SCAN(TRIM(cp_dimorder),TRIM(tf_dim%c_sname)) + + END FUNCTION dim_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim__print_arr(td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine print informations of an array of dimension. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_dim(:)) + CALL dim_print(td_dim(ji)) + ENDDO + + END SUBROUTINE dim__print_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim__print_unit(td_dim) + !------------------------------------------------------------------- + !> @brief This subrtoutine print dimension information. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), INTENT(IN) :: td_dim + !---------------------------------------------------------------- + + WRITE(*,'((3x,a,a),(/6x,a,a),(a,i1),(a,i5),2(a,a),2(a,i1))') & + & " dimension : ",TRIM(td_dim%c_name), & + & " short name : ",TRIM(td_dim%c_sname), & + & " id : ",td_dim%i_id, & + & " len : ",td_dim%i_len, & + & " use : ",TRIM(fct_str(td_dim%l_use)), & + & " uld : ",TRIM(fct_str(td_dim%l_uld)), & + & " xyzt2 : ",td_dim%i_xyzt2, & + & " 2xyzt : ",td_dim%i_2xyzt + + END SUBROUTINE dim__print_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim_fill_unused(td_dim) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function fill unused dimension of an array of dimension + !> and return a 4 elts array of dimension structure. + !> @details + !> output dimensions 'x','y','z' and 't' are all informed. + !> + !> @note without input array of dimension, return + !> a 4 elts array of dimension structure all unused + !> (case variable 0d) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - Bug fix: use order to disorder table (see dim_init) + !> + !> @param[in] td_dim array of dimension structure + !> @return 4elts array of dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + + ! function + TYPE(TDIM), DIMENSION(ip_maxdim) :: tf_dim + + ! local variable + CHARACTER(LEN=lc) :: cl_dimin + INTEGER(i4) , DIMENSION(1) :: il_ind ! index + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( PRESENT(td_dim) )THEN + tf_dim(1:SIZE(td_dim(:)))=td_dim(:) + ENDIF + ! concatenate short nem dimension in a character string + cl_dimin=fct_lower(fct_concat(tf_dim(:)%c_sname)) + DO ji = 1, ip_maxdim + + ! search missing dimension + IF( INDEX(cl_dimin,TRIM(fct_lower(cp_dimorder(ji:ji)))) == 0 )THEN + ! search first empty dimension (see dim_init) + il_ind(:)=MINLOC( tf_dim(:)%i_xyzt2, tf_dim(:)%i_xyzt2 == 0 ) + + ! put missing dimension instead of empty one + tf_dim(il_ind(1))%c_sname=fct_lower(cp_dimorder(ji:ji)) + ! update output structure + tf_dim(il_ind(1))%c_name=fct_lower(cp_dimorder(ji:ji)) + tf_dim(il_ind(1))%i_xyzt2=ji + tf_dim(il_ind(1))%i_len=1 + tf_dim(il_ind(1))%l_use=.FALSE. + ENDIF + + ENDDO + + END FUNCTION dim_fill_unused + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim_reorder(td_dim, cd_dimorder) + !------------------------------------------------------------------- + !> @brief + !> This subroutine switch element of an array (4 elts) of dimension + !> structure + !> from disordered dimension to ordered dimension <br/> + !> + !> @details + !> Optionally you could specify dimension order to output + !> (default 'xyzt') + !> Example: (/'z','x','t','y'/) => (/'x','y','z','t'/) + !> + !> @warning this subroutine change dimension order + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - allow to choose ordered dimension to be output + !> + !> @param[inout] td_dim array of dimension structure + !> @param[in] cd_dimorder dimension order to be output + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(INOUT) :: td_dim + CHARACTER(LEN=ip_maxdim) , INTENT(IN ), OPTIONAL :: cd_dimorder + + ! local variable + INTEGER(i4) :: il_ind + + CHARACTER(LEN=lc) :: cl_dimin + CHARACTER(LEN=lc) :: cl_dimorder + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER: invalid dimension of array dimension.") + ELSE + + cl_dimorder=TRIM(cp_dimorder) + IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(ADJUSTL(cd_dimorder)) + + ! add id if dimension used and no id + DO ji=1, ip_maxdim + + IF( td_dim(ji)%l_use )THEN + IF( td_dim(ji)%i_id == 0 )THEN + td_dim(ji)%i_id=MAXVAL(td_dim(:)%i_id)+1 + ENDIF + ELSE + td_dim(ji)%i_id=0 + td_dim(ji)%i_xyzt2=0 + td_dim(ji)%i_2xyzt=0 + td_dim(ji)%c_sname='u' + td_dim(ji)%c_name='' + td_dim(ji)%l_uld=.FALSE. + ENDIF + + ENDDO + + ! fill unused dimension + tl_dim(:)=dim_fill_unused(td_dim(:)) + cl_dimin=fct_lower(fct_concat(tl_dim(:)%c_sname)) + + ! compute input id from output id (xyzt) + DO ji = 1, ip_maxdim + + il_ind=SCAN(TRIM(cl_dimorder),TRIM(cl_dimin(ji:ji))) + IF( il_ind /= 0 )THEN + tl_dim(ji)%i_xyzt2=il_ind + ENDIF + + ENDDO + + ! compute output id (xyzt) from input id + DO ji = 1, ip_maxdim + + il_ind=SCAN(TRIM(cl_dimin),TRIM(cl_dimorder(ji:ji))) + IF( il_ind /= 0 )THEN + tl_dim(ji)%i_2xyzt=il_ind + ENDIF + + ENDDO + + ! change dimension order to ('x','y','z','t') + td_dim(:)%c_name = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%c_name) + td_dim(:)%c_sname = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%c_sname) + td_dim(:)%i_id = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%i_id ) + td_dim(:)%i_len = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%i_len ) + td_dim(:)%l_uld = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%l_uld ) + td_dim(:)%l_use = dim_reorder_2xyzt(tl_dim(:),tl_dim(:)%l_use ) + td_dim(:)%i_2xyzt = tl_dim(:)%i_2xyzt + td_dim(:)%i_xyzt2 = tl_dim(:)%i_xyzt2 + + ! clean + CALL dim_clean(tl_dim(:)) + ENDIF + + END SUBROUTINE dim_reorder + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim_disorder(td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine switch dimension array from ordered dimension ('x','y','z','t') + !> to disordered dimension. <br/> + !> @details + !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/)<br/> + ! This is useful to add dimension in a variable or file. + !> @warning this subroutine change dimension order + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_dim array of dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(INOUT) :: td_dim + + ! local variable + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim )THEN + CALL logger_error("DIM DISORDER: invalid dimension of array dimension.") + ELSE + ! add dummy xyzt2 id to unused dimension + jj=1 + DO ji = 1, ip_maxdim + IF( .NOT. td_dim(ji)%l_use .AND. td_dim(ji)%i_xyzt2 == 0 )THEN + DO WHILE( ANY( td_dim(:)%i_xyzt2 == jj )) + jj=jj+1 + ENDDO + td_dim(ji)%i_xyzt2=jj + ENDIF + ENDDO + + ! change dimension order from ('x','y','z','t') + td_dim(:)%c_name = dim_reorder_xyzt2(td_dim,td_dim(:)%c_name) + td_dim(:)%c_sname = dim_reorder_xyzt2(td_dim,td_dim(:)%c_sname) + td_dim(:)%i_id = dim_reorder_xyzt2(td_dim,td_dim(:)%i_id ) + td_dim(:)%i_len = dim_reorder_xyzt2(td_dim,td_dim(:)%i_len ) + td_dim(:)%l_uld = dim_reorder_xyzt2(td_dim,td_dim(:)%l_uld ) + td_dim(:)%l_use = dim_reorder_xyzt2(td_dim,td_dim(:)%l_use ) + + ! remove dummy xyzt2 id from unused dimension + DO ji = 1, ip_maxdim + IF( .NOT. td_dim(ji)%l_use )THEN + td_dim(ji)%i_id=0 + td_dim(ji)%i_xyzt2=0 + td_dim(ji)%c_sname='u' + td_dim(ji)%c_name='' + td_dim(ji)%l_uld=.FALSE. + ENDIF + ENDDO + ENDIF + + END SUBROUTINE dim_disorder + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reshape_2xyzt_dp(td_dim, dd_value) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief This function reshape real(8) 4D array + !> to an ordered array, as defined by dim_reorder.<br/> + !> @details + !> Example: (/'z','x','t','y'/) => (/'x','y','z','t'/) + ! + !> @note you must have run dim_reorder before use this subroutine + ! + !> @warning output array dimension differ from input array dimension + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - do not reshape array already order + !> + !> @param[in] td_dim array of dimension structure + !> @param[in] dd_value array of value to reshape + !> @return array of value reshaped + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:) , INTENT(IN) :: td_dim + REAL(dp) , DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + REAL(dp), DIMENSION(td_dim(1)%i_len, & + & td_dim(2)%i_len, & + & td_dim(3)%i_len, & + & td_dim(4)%i_len) :: df_value + + ! local variable + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + CHARACTER(LEN=lc) :: cl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim )THEN + CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of "//& + & "array dimension.") + ELSE + + IF( ANY(td_dim(:)%i_2xyzt==0) .OR. ANY(td_dim(:)%i_xyzt2==0) )THEN + + CALL logger_fatal( & + & " DIM RESHAPE 2 XYZT: you should have run dim_reorder"// & + & " before running RESHAPE" ) + + ENDIF + + il_shape=SHAPE(dd_value) + ! check input dimension + IF( ANY(il_shape(:) /= (/ td_dim(td_dim(1)%i_xyzt2)%i_len, & + & td_dim(td_dim(2)%i_xyzt2)%i_len, & + & td_dim(td_dim(3)%i_xyzt2)%i_len, & + & td_dim(td_dim(4)%i_xyzt2)%i_len /)) )THEN + + DO ji=1,ip_maxdim + CALL logger_debug(" DIM RESHAPE 2 XYZT: dim "//& + & TRIM(td_dim(td_dim(ji)%i_xyzt2)%c_name)//" "//& + & TRIM(fct_str(td_dim(td_dim(ji)%i_xyzt2)%i_len))//" vs "//& + & TRIM(fct_str(il_shape(ji))) ) + ENDDO + CALL logger_fatal(" DIM RESHAPE 2 XYZT: wrong input dimensions " ) + + ELSE + + ! write some informations + cl_dim="(/" + DO ji=1,ip_maxdim-1 + cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ji)))//',' + ENDDO + cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ip_maxdim)))//"/)" + + CALL logger_debug(" DIM RESHAPE 2 XYZT: input dimensions are "//& + & TRIM(cl_dim) ) + + cl_dim="(/" + DO ji=1,ip_maxdim-1 + cl_dim=TRIM(cl_dim)//TRIM(fct_str(td_dim(ji)%i_len))//',' + ENDDO + cl_dim=TRIM(cl_dim)//TRIM(fct_str(td_dim(ip_maxdim)%i_len))//"/)" + + CALL logger_debug(" DIM RESHAPE 2 XYZT: ouput dimensions should be "//& + & TRIM(cl_dim) ) + + IF( td_dim(1)%i_xyzt2 == 1 .AND. & + & td_dim(2)%i_xyzt2 == 2 .AND. & + & td_dim(3)%i_xyzt2 == 3 .AND. & + & td_dim(4)%i_xyzt2 == 4 )THEN + + DO jl=1,td_dim(4)%i_len + DO jk=1,td_dim(3)%i_len + DO jj=1,td_dim(2)%i_len + DO ji=1,td_dim(1)%i_len + df_value(ji,jj,jk,jl)=dd_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + + ELSE + + ! reorder dimension to x,y,z,t + df_value(:,:,:,:)=RESHAPE(SOURCE=dd_value(:,:,:,:),& + & SHAPE = (/ td_dim(1)%i_len, & + & td_dim(2)%i_len, & + & td_dim(3)%i_len, & + & td_dim(4)%i_len /),& + & ORDER = (/ td_dim(1)%i_2xyzt, & + & td_dim(2)%i_2xyzt, & + & td_dim(3)%i_2xyzt, & + & td_dim(4)%i_2xyzt /)) + ENDIF + ENDIF + ENDIF + + END FUNCTION dim__reshape_2xyzt_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reshape_xyzt2_dp(td_dim, dd_value) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief This function reshape ordered real(8) 4D array with dimension + !> (/'x','y','z','t'/) to an "disordered" array.<br/> + !> @details + !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/) + ! + !> @note you must have run dim_reorder before use this subroutine + ! + !> @warning output array dimension differ from input array dimension + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] dd_value array of value to reshape + !> @return array of value reshaped + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:) , INTENT(IN) :: td_dim + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + REAL(dp), DIMENSION(td_dim(td_dim(1)%i_xyzt2)%i_len, & + & td_dim(td_dim(2)%i_xyzt2)%i_len, & + & td_dim(td_dim(3)%i_xyzt2)%i_len, & + & td_dim(td_dim(4)%i_xyzt2)%i_len) :: df_value + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + CHARACTER(LEN=lc) :: cl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim )THEN + CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of "//& + & "array dimension.") + ELSE + + IF( ANY(td_dim(:)%i_xyzt2==0) .OR. ANY(td_dim(:)%i_2xyzt==0) )THEN + + CALL logger_fatal( & + & " DIM RESHAPE XYZT 2: you should have run dim_reorder"// & + & " before running RESHAPE" ) + + ENDIF + + ! check input dimension + il_shape=SHAPE(dd_value) + IF( ANY(il_shape(:)/=td_dim(:)%i_len))THEN + + DO ji=1,ip_maxdim + CALL logger_trace(" DIM RESHAPE XYZT 2: dim "//& + & TRIM(td_dim(ji)%c_name)//" "//& + & TRIM(fct_str(td_dim(ji)%i_len))//" vs "//& + & TRIM(fct_str(il_shape(ji))) ) + ENDDO + CALL logger_fatal( "DIM RESHAPE XYZT 2: wrong input dimensions ") + + ELSE + + ! write some informations + cl_dim="(/" + DO ji=1,ip_maxdim-1 + cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ji)))//',' + ENDDO + cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ip_maxdim)))//"/)" + + CALL logger_debug(" DIM RESHAPE XYZT 2: input dimensions are "//& + & TRIM(cl_dim) ) + + cl_dim="(/" + DO ji=1,ip_maxdim-1 + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_str(td_dim(td_dim(ji)%i_xyzt2)%i_len))//',' + ENDDO + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_str(td_dim(td_dim(ip_maxdim)%i_xyzt2)%i_len))//"/)" + + CALL logger_debug(" DIM RESHAPE XYZT 2: ouput dimensions should be "//& + & TRIM(cl_dim) ) + + ! reshape array + df_value(:,:,:,:)=RESHAPE(SOURCE=dd_value, & + & SHAPE = (/ td_dim(td_dim(1)%i_xyzt2)%i_len, & + & td_dim(td_dim(2)%i_xyzt2)%i_len, & + & td_dim(td_dim(3)%i_xyzt2)%i_len, & + & td_dim(td_dim(4)%i_xyzt2)%i_len /),& + & ORDER = (/ td_dim(1)%i_xyzt2, & + & td_dim(2)%i_xyzt2, & + & td_dim(3)%i_xyzt2, & + & td_dim(4)%i_xyzt2 /)) + + ENDIF + ENDIF + + END FUNCTION dim__reshape_xyzt2_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_2xyzt_i4(td_dim, id_arr) & + & RESULT (if_value) + !------------------------------------------------------------------- + !> @brief This function reordered integer(4) 1D array to be suitable + !> with dimension ordered as defined in dim_reorder. + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] id_arr array of value to reshape + !> @return array of value reshaped + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_arr + + ! function + INTEGER(i4), DIMENSION(ip_maxdim) :: if_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(id_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//& + & " or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_2xyzt==0) )THEN + + CALL logger_error( & + & " DIM REORDER 2 XYZT: you should have run dim_reorder"//& + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + if_value(ji)=id_arr(td_dim(ji)%i_2xyzt) + ENDDO + ENDIF + + END FUNCTION dim__reorder_2xyzt_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_xyzt2_i4(td_dim, id_arr) & + & RESULT (if_value) + !------------------------------------------------------------------- + !> @brief This function disordered integer(4) 1D array to be suitable with + !> initial dimension order (ex: dimension read in file). + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] id_arr array of value to reshape + !> @return array of value reshaped + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_arr + + ! function + INTEGER(i4), DIMENSION(ip_maxdim) :: if_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(id_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER XYZT 2: invalid dimension of "//& + & "array dimension or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_xyzt2==0) )THEN + + CALL logger_error( & + & " DIM REORDER XYZT 2: you should have run dim_reorder"// & + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + if_value(ji)=id_arr(td_dim(ji)%i_xyzt2) + ENDDO + ENDIF + + END FUNCTION dim__reorder_xyzt2_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_2xyzt_l(td_dim, ld_arr) & + & RESULT (lf_arr) + !------------------------------------------------------------------- + !> @brief This function reordered logical 1D array to be suitable + !> with dimension ordered as defined in dim_reorder. + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] ld_arr array of value to reordered + !> @return array of value reordered + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim + LOGICAL , DIMENSION(:), INTENT(IN) :: ld_arr + + ! function + LOGICAL, DIMENSION(ip_maxdim) :: lf_arr + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(ld_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//& + & " or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_2xyzt==0) )THEN + + CALL logger_error( & + & " DIM REORDER 2 XYZT: you should have run dim_reorder"// & + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + lf_arr(ji)=ld_arr(td_dim(ji)%i_2xyzt) + ENDDO + ENDIF + + END FUNCTION dim__reorder_2xyzt_l + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_xyzt2_l(td_dim, ld_arr) & + & RESULT (lf_arr) + !------------------------------------------------------------------- + !> @brief This function disordered logical 1D array to be suitable with + !> initial dimension order (ex: dimension read in file). + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] ld_arr array of value to reordered + !> @return array of value reordered + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim + LOGICAL , DIMENSION(:), INTENT(IN) :: ld_arr + + ! function + LOGICAL, DIMENSION(ip_maxdim) :: lf_arr + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(ld_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//& + & " or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_xyzt2==0) )THEN + + CALL logger_error( & + & " DIM REORDER XYZT 2: you should have run dim_reorder"//& + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + lf_arr(ji)=ld_arr(td_dim(ji)%i_xyzt2) + ENDDO + ENDIF + + END FUNCTION dim__reorder_xyzt2_l + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_2xyzt_c(td_dim, cd_arr) & + & RESULT (cf_arr) + !------------------------------------------------------------------- + !> @brief This function reordered string 1D array to be suitable + !> with dimension ordered as defined in dim_reorder. + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] cd_arr array of value to reordered + !> @return array of value reordered + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_arr + + ! function + CHARACTER(LEN=lc), DIMENSION(ip_maxdim) :: cf_arr + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(cd_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//& + & " or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_2xyzt==0) )THEN + + CALL logger_error( & + & " DIM REORDER 2 XYZT: you should have run dim_reorder"//& + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + cf_arr(ji)=TRIM(cd_arr(td_dim(ji)%i_2xyzt)) + ENDDO + ENDIF + + END FUNCTION dim__reorder_2xyzt_c + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__reorder_xyzt2_c(td_dim, cd_arr) & + & RESULT (cf_arr) + !------------------------------------------------------------------- + !> @brief This function disordered string 1D array to be suitable with + !> initial dimension order (ex: dimension read in file). + !> @note you must have run dim_reorder before use this subroutine + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension structure + !> @param[in] cd_arr array of value to reordered + !> @return array of value reordered + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_arr + + ! function + CHARACTER(LEN=lc), DIMENSION(ip_maxdim) :: cf_arr + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & + & SIZE(cd_arr(:)) /= ip_maxdim )THEN + CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//& + & " or of array of value.") + ELSE + IF( ANY(td_dim(:)%i_xyzt2==0) )THEN + CALL logger_error( & + & " DIM REORDER XYZT 2: you should have run dim_reorder"// & + & " before running REORDER" ) + + ENDIF + + DO ji=1,ip_maxdim + cf_arr(ji)=TRIM(cd_arr(td_dim(ji)%i_xyzt2)) + ENDDO + ENDIF + + END FUNCTION dim__reorder_xyzt2_c + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim__clean_unit(td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine clean dimension structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim dimension strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), INTENT(INOUT) :: td_dim + + ! local variable + TYPE(TDIM) :: tl_dim ! empty dimension strucutre + !---------------------------------------------------------------- + + CALL logger_trace( & + & " DIM CLEAN: reset dimension "//TRIM(td_dim%c_name) ) + + ! replace by empty structure + td_dim=tl_dim + + END SUBROUTINE dim__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim__clean_arr(td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine clean array of dimension structure + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_dim array of dimension strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + ! Argument + TYPE(TDIM), DIMENSION(:), INTENT(INOUT) :: td_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_dim(:)) + CALL dim_clean(td_dim(ji)) + ENDDO + + END SUBROUTINE dim__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim_get_dummy(cd_dummy) + !------------------------------------------------------------------- + !> @brief This subroutine fill dummy dimension array + ! + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date May, 2019 + !> - read number of dummy element + !> + !> @param[in] cd_dummy dummy configuration file + !------------------------------------------------------------------- + + IMPLICIT NONE + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_dummy + + ! local variable + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_status + + LOGICAL :: ll_exist + + ! loop indices + ! namelist + INTEGER(i4) :: in_ndumvar + INTEGER(i4) :: in_ndumdim + INTEGER(i4) :: in_ndumatt + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumvar + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumdim + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumatt + + !---------------------------------------------------------------- + NAMELIST /namdum/ & !< dummy namelist + & in_ndumvar,& !< number of variable name + & in_ndumdim,& !< number of dimension name + & in_ndumatt,& !< number of attribute name + & cn_dumvar, & !< variable name + & cn_dumdim, & !< dimension name + & cn_dumatt !< attribute name + !---------------------------------------------------------------- + + ! init + cm_dumdim(:)='' + + ! read namelist + INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_dummy), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) + ENDIF + + READ( il_fileid, NML = namdum ) + im_ndumdim = in_ndumdim + cm_dumdim(:)= cn_dumdim(:) + + CLOSE( il_fileid ) + + IF( im_ndumdim > ip_maxdumcfg )THEN + CALL logger_fatal("DIM GET dUMMY : too much dummy dimension & + & ( >"//fct_str(ip_maxdumcfg)//" ). & + & set ip_maxdumcfg to higher value.") + ENDIF + ENDIF + + END SUBROUTINE dim_get_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim_is_dummy(td_dim) & + & RESULT (lf_dummy) + !------------------------------------------------------------------- + !> @brief This function check if dimension is defined as dummy dimension + !> in configuraton file + !> + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date, May, 2019 + !> - use number of dummy elt in do-loop + !> + !> @param[in] td_dim dimension structure + !> @return true if dimension is dummy dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDIM), INTENT(IN) :: td_dim + + ! function + LOGICAL :: lf_dummy + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_dummy=.FALSE. + DO ji=1,im_ndumdim + IF( fct_lower(td_dim%c_name) == fct_lower(cm_dumdim(ji)) )THEN + lf_dummy=.TRUE. + EXIT + ENDIF + ENDDO + + END FUNCTION dim_is_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dim_def_extra(cd_file) + !------------------------------------------------------------------- + !> @brief This subroutine read dimension configuration file, + !> and fill array of dimension allowed. + !> + !> @author J.Paul + !> @date Ocotber, 2016 - Initial Version + !> @date May, 2019 + !> - read number of element for each dimention + ! + !> @param[in] cd_file input file (dimension configuration file) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + + ! local variable + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_status + + LOGICAL :: ll_exist + + ! loop indices + ! namelist + INTEGER(i4) :: in_dimX = 0 + INTEGER(i4) :: in_dimY = 0 + INTEGER(i4) :: in_dimZ = 0 + INTEGER(i4) :: in_dimT = 0 + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg) :: cn_dimX = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg) :: cn_dimY = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg) :: cn_dimZ = '' + CHARACTER(LEN=lc), DIMENSION(ip_maxdimcfg) :: cn_dimT = '' + + !---------------------------------------------------------------- + NAMELIST /namdim/ & !< dimension namelist + & in_dimX, & !< number of x dimension name allowed + & in_dimY, & !< number of y dimension name allowed + & in_dimZ, & !< number of z dimension name allowed + & in_dimT, & !< number of t dimension name allowed + & cn_dimX, & !< x dimension name allowed + & cn_dimY, & !< y dimension name allowed + & cn_dimZ, & !< z dimension name allowed + & cn_dimT !< t dimension name allowed + + !---------------------------------------------------------------- + + ! init + cm_dimX(:)='' + cm_dimY(:)='' + cm_dimZ(:)='' + cm_dimT(:)='' + + ! read config variable file + INQUIRE(FILE=TRIM(cd_file), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_file), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_file)) + ENDIF + + READ( il_fileid, NML = namdim ) + im_dimX =in_dimX + im_dimY =in_dimY + im_dimZ =in_dimZ + im_dimT =in_dimT + cm_dimX(:)=cn_dimX(:) + cm_dimY(:)=cn_dimY(:) + cm_dimZ(:)=cn_dimZ(:) + cm_dimT(:)=cn_dimT(:) + + CLOSE( il_fileid ) + + ELSE + + CALL logger_fatal("DIM DEF EXTRA: can't find configuration"//& + & " file "//TRIM(cd_file)) + + ENDIF + + END SUBROUTINE dim_def_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dim__is_allowed(cd_name, cd_dim, id_ndim) & + & RESULT (lf_allowed) + !------------------------------------------------------------------- + !> @brief This function check if dimension is allowed, i.e defined + !> in dimension configuraton file + !> + !> @author J.Paul + !> @date October, 2016 - Initial Version + !> @date May, 2019 + !> - use number of element for each dimention allowed, instead of while loop + ! + !> @param[in] cd_name dimension name + !> @param[in] cd_dim array dimension name allowed + !> @param[in] id_ndim number of elt in array dimension name allowed + !> @return true if dimension is allowed + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_dim + INTEGER(i4) , INTENT(IN) :: id_ndim + + ! function + LOGICAL :: lf_allowed + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_allowed=.FALSE. + DO ji=1,id_ndim + IF( TRIM(fct_lower(cd_name)) == TRIM(fct_lower(cd_dim(ji))) )THEN + lf_allowed=.TRUE. + EXIT + ENDIF + ENDDO + + END FUNCTION dim__is_allowed + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE dim + diff --git a/V4.0/nemo_sources/tools/SIREN/src/domain.f90 b/V4.0/nemo_sources/tools/SIREN/src/domain.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aa955c846a6da62b31095ad6eb38faf6341a70e9 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/domain.f90 @@ -0,0 +1,1823 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage domain computation. +!> +!> @details +!> define type TDOM:<br/> +!> @code +!> TYPE(TDOM) :: tl_dom +!> @endcode +!> +!> to initialize domain structure:<br/> +!> @code +!> tl_dom=dom_init(td_mpp, [id_imin,] [id_imax,] [id_jmin,] [id_jmax],[cd_card]) +!> @endcode +!> - td_mpp is mpp structure of an opened file. +!> - id_imin is i-direction sub-domain lower left point indice +!> - id_imax is i-direction sub-domain upper right point indice +!> - id_jmin is j-direction sub-domain lower left point indice +!> - id_jmax is j-direction sub-domain upper right point indice +!> - cd_card is the cardinal name (for boundary case) +!> +!> to get global domain dimension:<br/> +!> - tl_dom\%t_dim0 +!> +!> to get NEMO periodicity index of global domain:<br/> +!> - tl_dom\%i_perio0 +!> +!> to get NEMO pivot point index F(0),T(1):<br/> +!> - tl_dom\%i_pivot +!> +!> to get East-West overlap of global domain:<br/> +!> - tl_dom\%i_ew0 +!> +!> to get selected sub domain dimension:<br/> +!> - tl_dom\%t_dim +!> +!> to get NEMO periodicity index of sub domain:<br/> +!> - tl_dom\%i_perio +!> +!> to get East-West overlap of sub domain:<br/> +!> - tl_dom\%i_ew +!> +!> to get i-direction sub-domain lower left point indice:<br/> +!> - tl_dom\%i_imin +!> +!> to get i-direction sub-domain upper right point indice:<br/> +!> - tl_dom\%i_imax +!> +!> to get j-direction sub-domain lower left point indice:<br/> +!> - tl_dom\%i_jmin +!> +!> to get j-direction sub-domain upper right point indice:<br/> +!> - tl_dom\%i_jmax +!> +!> to get size of i-direction extra band:<br/> +!> - tl_dom\%i_iextra +!> +!> to get size of j-direction extra band:<br/> +!> - tl_dom\%i_jextra +!> +!> to get i-direction ghost cell number:<br/> +!> - tl_dom\%i_ighost +!> +!> to get j-direction ghost cell number:<br/> +!> - tl_dom\%i_jghost +!> +!> to get boundary index:<br/> +!> - tl_dom\%i_bdy +!> - 0 = no boundary +!> - 1 = north +!> - 2 = south +!> - 3 = east +!> - 4 = west +!> +!> to clean domain structure:<br/> +!> @code +!> CALL dom_clean(td_dom) +!> @endcode +!> - td_dom is domain structure +!> +!> to print information about domain structure:<br/> +!> @code +!> CALL dom_print(td_dom) +!> @endcode +!> +!> to get East-West overlap (if any):<br/> +!> @code +!> il_ew=dom_get_ew_overlap(td_lon) +!> @endcode +!> - td_lon : longitude variable structure +!> +!> to add extra bands to coarse grid domain (for interpolation):<br/> +!> @code +!> CALL dom_add_extra( td_dom, id_iext, id_jext ) +!> @endcode +!> - td_dom is domain structure +!> - id_iext is i-direction size of extra bands +!> - id_jext is j-direction size of extra bands +!> +!> to remove extra bands from fine grid (after interpolation):<br/> +!> @code +!> CALL dom_del_extra( td_var, td_dom, id_rho ) +!> @endcode +!> - td_var is variable structure to be changed +!> - td_dom is domain structure +!> - id_rho is a array of refinement factor following i- and j-direction +!> +!> to reset coarse grid domain witouht extra bands:<br/> +!> @code +!> CALL dom_clean_extra( td_dom ) +!> @endcode +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header +!> - use zero indice to defined cyclic or global domain +!> @date October, 2014 +!> - use mpp file structure instead of file +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE dom + + USE kind ! F90 kind parameter + USE global ! global parameter + USE fct ! basic useful function + USE logger ! log file manager + USE dim ! dimension manager + USE var ! variable manager + USE mpp ! mpp file manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TDOM !< domain structure + + PRIVATE :: im_minext !< default minumum number of extraband + + ! function and subroutine + PUBLIC :: dom_copy !< copy domain structure + PUBLIc :: dom_clean !< clean domain structure + PUBLIC :: dom_init !< initialise domain structure + PUBLIC :: dom_print !< print information about domain + PUBLIC :: dom_add_extra !< add useful extra bands to coarse grid for interpolation + PUBLIC :: dom_clean_extra !< reset domain without extra bands + PUBLIC :: dom_del_extra !< remove extra point from fine grid after interpolation + + PRIVATE :: dom__init_mpp ! initialise domain structure, given mpp file structure + PRIVATE :: dom__define ! define sub domain indices + ! define sub domain indices for input domain with + PRIVATE :: dom__define_cyclic_north_fold ! - cyclic east-west boundary and north fold boundary condition. + PRIVATE :: dom__define_north_fold ! - north fold boundary condition. + PRIVATE :: dom__define_symmetric ! - symmetric boundary condition across the equator. + PRIVATE :: dom__define_cyclic ! - cyclic east-west boundary. + PRIVATE :: dom__define_closed ! - cyclic east-west boundary. + ! compute size of sub domain + PRIVATE :: dom__size_no_pole ! - without north fold condition + PRIVATE :: dom__size_no_pole_overlap ! - without north fold condition, and which overlap east-west boundary + PRIVATE :: dom__size_no_pole_no_overlap ! - without north fold condition, and which do not overlap east-west boundary + PRIVATE :: dom__size_pole ! - with north fold condition + PRIVATE :: dom__size_pole_overlap ! - with north fold condition, and which overlap east-west boundary + PRIVATE :: dom__size_pole_no_overlap ! - with north fold condition, and which do not overlap east-west boundary + ! compute size of + PRIVATE :: dom__size_global ! - global domain + PRIVATE :: dom__size_semi_global ! - semi global domain + PRIVATE :: dom__copy_unit ! copy attribute structure + + TYPE TDOM !< domain structure + TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim0 !< global domain dimension + TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< sub domain dimension + INTEGER(i4) :: i_perio0 !< NEMO periodicity index of global domain + INTEGER(i4) :: i_ew0 !< East-West overlap of global domain + INTEGER(i4) :: i_perio !< NEMO periodicity index of sub domain + INTEGER(i4) :: i_pivot !< NEMO pivot point index F(0),T(1) + INTEGER(i4) :: i_imin = 0 !< i-direction sub-domain lower left point indice + INTEGER(i4) :: i_imax = 0 !< i-direction sub-domain upper right point indice + INTEGER(i4) :: i_jmin = 0 !< j-direction sub-domain lower left point indice + INTEGER(i4) :: i_jmax = 0 !< j-direction sub-domain upper right point indice + + INTEGER(i4) :: i_bdy = 0 !< boundary index : 0 = no boundary + !< 1 = north + !< 2 = south + !< 3 = east + !< 4 = west + INTEGER(i4), DIMENSION(2,2) :: i_ghost0 = 0 !< array of ghost cell factor of global domain + INTEGER(i4), DIMENSION(2,2) :: i_ghost = 0 !< array of ghost cell factor of sub domain + + INTEGER(i4), DIMENSION(2) :: i_iextra = 0 !< i-direction extra point + INTEGER(i4), DIMENSION(2) :: i_jextra = 0 !< j-direction extra point + + END TYPE TDOM + + INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of extraband + + INTERFACE dom_init + MODULE PROCEDURE dom__init_file + MODULE PROCEDURE dom__init_mpp + END INTERFACE dom_init + + INTERFACE dom_copy + MODULE PROCEDURE dom__copy_unit ! copy attribute structure + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dom__copy_unit(td_dom) & + & RESULT (tf_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy an domain structure in another one + !> @details + !> dummy function to get the same use for all structure + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_dom=dom_copy(dom_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> + !> @param[in] td_dom domain structure + !> @return copy of input domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(IN) :: td_dom + + ! function + TYPE(TDOM) :: tf_dom + + ! local variable + !---------------------------------------------------------------- + + tf_dom=td_dom + + END FUNCTION dom__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom_print(td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine print some information about domain strucutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_dom dom structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(IN) :: td_dom + + ! local argument + CHARACTER(LEN=lc) :: cl_pivot + !---------------------------------------------------------------- + SELECT CASE(td_dom%i_pivot) + CASE(0) + cl_pivot='F-point' + CASE(1) + cl_pivot='T-point' + CASE DEFAULT + cl_pivot='unknown' + END SELECT + + WRITE(*,'((a,4(i0,1x)),(/a,i2,a,a),2(/a,2(i0,1x)),(/a,4(i0,1x)),(/a,i2/),& + & 4(/a,i0),4(/a,2(i0,1x)))') & + & " global domain size ",td_dom%t_dim0(:)%i_len, & + & " domain periodicity ",td_dom%i_perio0,", pivot: ",TRIM(cl_pivot), & + & " i-direction ghost cell factor of global domain ",td_dom%i_ghost0(jp_I,:), & + & " j-direction ghost cell factor of global domain ",td_dom%i_ghost0(jp_J,:), & + & " sub-domain size : ",td_dom%t_dim(:)%i_len, & + & " sub domain periodicity ",td_dom%i_perio, & + & " i-direction sub-domain lower left point indice ",td_dom%i_imin, & + & " i-direction sub-domain upper right point indice ",td_dom%i_imax, & + & " j-direction sub-domain lower left point indice ",td_dom%i_jmin, & + & " j-direction sub-domain upper right point indice ",td_dom%i_jmax, & + & " i-direction ghost cell factor ",td_dom%i_ghost(jp_I,:), & + & " j-direction ghost cell factor ",td_dom%i_ghost(jp_J,:), & + & " i-direction extra point for interpolation ",td_dom%i_iextra(:), & + & " j-direction extra point for interpolation ",td_dom%i_jextra(:) + + END SUBROUTINE dom_print + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dom__init_mpp(td_mpp, id_imin, id_imax, id_jmin, id_jmax, cd_card) & + & RESULT (tf_dom) + !------------------------------------------------------------------- + !> @brief + !> This function intialise domain structure, given open file structure, + !> and sub domain indices. + !> @details + !> sub domain indices are computed, taking into account coarse grid + !> periodicity, pivot point, and East-West overlap. + !> + !> @author J.Paul + !> @date June, 2013 - Initial Version + !> @date September, 2014 + !> - add boundary index + !> - add ghost cell factor + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] td_mpp mpp structure + !> @param[in] id_perio grid periodicity + !> @param[in] id_imin i-direction sub-domain lower left point indice + !> @param[in] id_imax i-direction sub-domain upper right point indice + !> @param[in] id_jmin j-direction sub-domain lower left point indice + !> @param[in] id_jmax j-direction sub-domain upper right point indice + !> @param[in] cd_card name of cardinal (for boundary) + !> @return domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imin + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imax + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmin + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmax + + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_card + + ! function + TYPE(TDOM) :: tf_dom + + !local variable + !---------------------------------------------------------------- + + ! clean domain structure + CALL dom_clean(tf_dom) + + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( & + & " DOM INIT: no processor file associated to mpp "//& + & TRIM(td_mpp%c_name)) + + ELSE + ! global domain define by file + + ! look for boundary index + IF( PRESENT(cd_card) )THEN + SELECT CASE(TRIM(cd_card)) + CASE('north') + tf_dom%i_bdy=jp_north + CASE('south') + tf_dom%i_bdy=jp_south + CASE('east') + tf_dom%i_bdy=jp_east + CASE('west') + tf_dom%i_bdy=jp_west + CASE DEFAULT + ! no boundary + tf_dom%i_bdy=0 + END SELECT + ELSE + ! no boundary + tf_dom%i_bdy=0 + ENDIF + + ! use global dimension define by mpp file + tf_dom%t_dim0(:) = dim_copy(td_mpp%t_dim(:)) + + IF( td_mpp%i_perio < 0 .OR. td_mpp%i_perio > 6 )THEN + CALL logger_error("DOM INIT: invalid grid periodicity ("//& + & TRIM(fct_str(td_mpp%i_perio))//& + & ") you should use grid_get_perio to compute it") + ELSE + tf_dom%i_perio0=td_mpp%i_perio + ENDIF + + ! global domain pivot point + SELECT CASE(tf_dom%i_perio0) + CASE(3,4) + tf_dom%i_pivot = 0 + CASE(5,6) + tf_dom%i_pivot = 1 + CASE DEFAULT + tf_dom%i_pivot = 0 + END SELECT + + ! add ghost cell factor of global domain + tf_dom%i_ghost0(:,:)=0 + SELECT CASE(tf_dom%i_perio0) + CASE(0) + tf_dom%i_ghost0(:,:)=1 + CASE(1) + tf_dom%i_ghost0(jp_J,:)=1 + CASE(2) + tf_dom%i_ghost0(jp_I,:)=1 + tf_dom%i_ghost0(jp_J,2)=1 + CASE(3,5) + tf_dom%i_ghost0(jp_I,:)=1 + tf_dom%i_ghost0(jp_J,1)=1 + CASE(4,6) + tf_dom%i_ghost0(jp_J,1)=1 + END SELECT + + ! look for EW overlap + tf_dom%i_ew0=td_mpp%i_ew + + ! initialise domain as global + tf_dom%i_imin = 1 + tf_dom%i_imax = tf_dom%t_dim0(1)%i_len + + tf_dom%i_jmin = 1 + tf_dom%i_jmax = tf_dom%t_dim0(2)%i_len + + ! sub domain dimension + tf_dom%t_dim(:) = dim_copy(td_mpp%t_dim(:)) + + ! define sub domain indices + CALL dom__define(tf_dom, id_imin, id_imax, id_jmin, id_jmax) + + ENDIF + + END FUNCTION dom__init_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION dom__init_file(td_file, id_imin, id_imax, id_jmin, id_jmax, cd_card) & + & RESULT (tf_dom) + !------------------------------------------------------------------- + !> @brief + !> This function intialise domain structure, given open file structure, + !> and sub domain indices. + !> @details + !> sub domain indices are computed, taking into account coarse grid + !> periodicity, pivot point, and East-West overlap. + !> + !> @author J.Paul + !> @date June, 2013 - Initial Version + !> @date September, 2014 + !> - add boundary index + !> - add ghost cell factor + !> + !> @param[in] td_file file structure + !> @param[in] id_perio grid periodicity + !> @param[in] id_imin i-direction sub-domain lower left point indice + !> @param[in] id_imax i-direction sub-domain upper right point indice + !> @param[in] id_jmin j-direction sub-domain lower left point indice + !> @param[in] id_jmax j-direction sub-domain upper right point indice + !> @param[in] cd_card name of cardinal (for boundary) + !> @return domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(IN) :: td_file + + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imin + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imax + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmin + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmax + + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_card + + ! function + TYPE(TDOM) :: tf_dom + + !local variable + !---------------------------------------------------------------- + + ! clean domain structure + CALL dom_clean(tf_dom) + + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " DOM INIT: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + ! global domain define by file + + ! look for boundary index + IF( PRESENT(cd_card) )THEN + SELECT CASE(TRIM(cd_card)) + CASE('north') + tf_dom%i_bdy=jp_north + CASE('south') + tf_dom%i_bdy=jp_south + CASE('east') + tf_dom%i_bdy=jp_east + CASE('west') + tf_dom%i_bdy=jp_west + CASE DEFAULT + ! no boundary + tf_dom%i_bdy=0 + END SELECT + ELSE + ! no boundary + tf_dom%i_bdy=0 + ENDIF + + ! use global dimension define by file + tf_dom%t_dim0(:) = dim_copy(td_file%t_dim(:)) + + IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN + CALL logger_error("DOM INIT: invalid grid periodicity ("//& + & TRIM(fct_str(td_file%i_perio))//& + & ") you should use grid_get_perio to compute it") + ELSE + tf_dom%i_perio0=td_file%i_perio + ENDIF + + ! global domain pivot point + SELECT CASE(tf_dom%i_perio0) + CASE(3,4) + tf_dom%i_pivot = 0 + CASE(5,6) + tf_dom%i_pivot = 1 + CASE DEFAULT + tf_dom%i_pivot = 0 + END SELECT + + ! add ghost cell factor of global domain + tf_dom%i_ghost0(:,:)=0 + SELECT CASE(tf_dom%i_perio0) + CASE(0) + tf_dom%i_ghost0(:,:)=1 + CASE(1) + tf_dom%i_ghost0(jp_J,:)=1 + CASE(2) + tf_dom%i_ghost0(jp_I,:)=1 + tf_dom%i_ghost0(jp_J,2)=1 + CASE(3,5) + tf_dom%i_ghost0(jp_I,:)=1 + tf_dom%i_ghost0(jp_J,1)=1 + CASE(4,6) + tf_dom%i_ghost0(jp_J,1)=1 + END SELECT + + ! look for EW overlap + tf_dom%i_ew0=td_file%i_ew + + ! initialise domain as global + tf_dom%i_imin = 1 + tf_dom%i_imax = tf_dom%t_dim0(1)%i_len + + tf_dom%i_jmin = 1 + tf_dom%i_jmax = tf_dom%t_dim0(2)%i_len + + ! sub domain dimension + tf_dom%t_dim(:) = dim_copy(td_file%t_dim(:)) + + ! define sub domain indices + CALL dom__define(tf_dom, id_imin, id_imax, id_jmin, id_jmax) + + ENDIF + + END FUNCTION dom__init_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define(td_dom, & + & id_imin, id_imax, id_jmin, id_jmax) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices, and compute the size + !> of the sub domain. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain structure + !> @param[in] id_imin i-direction sub-domain lower left point indice + !> @param[in] id_imax i-direction sub-domain upper right point indice + !> @param[in] id_jmin j-direction sub-domain lower left point indice + !> @param[in] id_jmax j-direction sub-domain upper right point indice + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin + INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax + INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin + INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax + !---------------------------------------------------------------- + + IF( PRESENT(id_imin) ) td_dom%i_imin = id_imin + IF( PRESENT(id_imax) ) td_dom%i_imax = id_imax + + IF( PRESENT(id_jmin) ) td_dom%i_jmin = id_jmin + IF( PRESENT(id_jmax) ) td_dom%i_jmax = id_jmax + + ! check indices + IF(( td_dom%i_imin < -1 .OR. td_dom%i_imin > td_dom%t_dim0(1)%i_len ).OR. & + & ( td_dom%i_imax < -1 .OR. td_dom%i_imax > td_dom%t_dim0(1)%i_len ).OR. & + & ( td_dom%i_jmin < -1 .OR. td_dom%i_jmin > td_dom%t_dim0(2)%i_len ).OR. & + & ( td_dom%i_jmax < -1 .OR. td_dom%i_jmax > td_dom%t_dim0(2)%i_len ))THEN + CALL logger_debug("0 <= imin ("//TRIM(fct_str(id_imin))//") < "//& + & TRIM(fct_str(td_dom%t_dim0(1)%i_len))) + CALL logger_debug("0 <= imax ("//TRIM(fct_str(id_imax))//") < "//& + & TRIM(fct_str(td_dom%t_dim0(1)%i_len))) + CALL logger_debug("0 <= jmin ("//TRIM(fct_str(id_jmin))//") < "//& + & TRIM(fct_str(td_dom%t_dim0(2)%i_len))) + CALL logger_debug("0 <= jmax ("//TRIM(fct_str(id_jmax))//") < "//& + & TRIM(fct_str(td_dom%t_dim0(2)%i_len))) + CALL logger_fatal( "DOM INIT DEFINE: invalid grid definition."// & + & " check min and max indices") + ELSE + + ! force to select north fold + IF( td_dom%i_perio0 > 2 .AND. & + & ( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 .OR. & + & td_dom%i_jmax < td_dom%i_jmin .OR. & + & td_dom%i_jmin == 0 ) )THEN + td_dom%i_jmax=0 + ENDIF + + ! force to use cyclic boundary + IF( ( td_dom%i_perio0 == 1 .OR. & + & td_dom%i_perio0 == 4 .OR. & + & td_dom%i_perio0 == 6 ) .AND. & + & ( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 .OR. & + & ABS(td_dom%i_imax-td_dom%i_imin)+1 == td_dom%t_dim0(1)%i_len ) & + & )THEN + td_dom%i_imin = 0 + td_dom%i_imax = 0 + ENDIF + + SELECT CASE(td_dom%i_perio0) + CASE(0) ! closed boundary + CALL logger_trace("DOM INIT DEFINE: closed boundary") + CALL dom__define_closed( td_dom ) + CASE(1) ! cyclic east-west boundary + CALL logger_trace("DOM INIT DEFINE: cyclic east-west boundary") + CALL dom__define_cyclic( td_dom ) + CASE(2) ! symmetric boundary condition across the equator + CALL logger_trace("DOM INIT DEFINE: symmetric boundary condition "//& + & " across the equator") + CALL dom__define_symmetric( td_dom ) + CASE(3) ! North fold boundary (with a F-point pivot) + CALL logger_trace("DOM INIT DEFINE: North fold boundary "//& + & "(with a F-point pivot)") + CALL dom__define_north_fold( td_dom ) + CASE(5) ! North fold boundary (with a T-point pivot) + CALL logger_trace("DOM INIT DEFINE: North fold boundary "//& + & "(with a T-point pivot)") + CALL dom__define_north_fold( td_dom ) + CASE(4) ! North fold boundary (with a F-point pivot) + ! and cyclic east-west boundary + CALL logger_trace("DOM INIT DEFINE: North fold boundary "//& + & "(with a F-point pivot) and cyclic "//& + & "east-west boundary") + CALL dom__define_cyclic_north_fold( td_dom ) + CASE(6) ! North fold boundary (with a T-point pivot) + ! and cyclic east-west boundary + CALL logger_trace("DOM INIT DEFINE: North fold boundary "//& + & "(with a T-point pivot) and cyclic "//& + & "east-west boundary") + CALL dom__define_cyclic_north_fold( td_dom ) + CASE DEFAULT + CALL logger_error("DOM INIT DEFINE: invalid grid periodicity index") + END SELECT + + ENDIF + + END SUBROUTINE dom__define + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define_cyclic_north_fold(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices from global domain with + !> cyclic east-west boundary and north fold boundary condition. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date September, 2014 + !> - use zero indice to defined cyclic or global domain + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + !CALL dom__check_EW_index( td_dom ) + + IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. & + & td_dom%i_jmin == 0 .AND. td_dom%i_jmax == 0 )THEN + + CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "domain to extract is global" ) + ! coarse domain is global domain + + CALL dom__size_global( td_dom ) + + ELSEIF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. & + & td_dom%i_jmax == 0 )THEN + + CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "domain to extract is semi-global" ) + + CALL dom__size_semi_global( td_dom ) + + ELSEIF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. & + & td_dom%i_jmax /= 0 )THEN + + CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "domain to extract is band of latidue" ) + + CALL dom__size_no_pole( td_dom ) + + ELSEIF( td_dom%i_jmax == 0 )THEN + + CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "domain to extract use north fold" ) + + CALL dom__size_pole( td_dom ) + + ELSEIF( td_dom%i_jmax /= 0 )THEN + + CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "domain to extract do not use north fold" ) + ! no North Pole + + CALL dom__size_no_pole( td_dom ) + + ELSE + + CALL logger_error("DOM DEFINE CYCLIC NORTH FOLD: "//& + & "should have been an impossible case" ) + + ENDIF + + END SUBROUTINE dom__define_cyclic_north_fold + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define_north_fold(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices from global domain + !> with north fold boundary condition. + !> + !> @author J.Paul + !> @date November, 2013 - Initial verison + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_jmax /= 0 )THEN + + CALL logger_trace("DOM DEFINE NORTH FOLD: "//& + & "domain to extract has no north boundary" ) + ! no North Pole + + CALL dom__size_no_pole_no_overlap( td_dom ) + + ELSE + + CALL logger_trace("DOM DEFINE NORTH FOLD: "//& + & "sub domain has north boundary" ) + + CALL dom__size_pole_no_overlap( td_dom ) + + ENDIF + + END SUBROUTINE dom__define_north_fold + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define_symmetric(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices from global domain + !> with symmetric boundary condition across the equator. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + CALL dom__size_no_pole_no_overlap( td_dom ) + + END SUBROUTINE dom__define_symmetric + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define_cyclic(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices from global domain + !> with cyclic east-west boundary. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_imin >= td_dom%i_imax )THEN + CALL logger_trace("DOM DEFINE CYCLIC: "//& + & "domain to extract overlap east-west boundary") + + CALL dom__size_no_pole_overlap( td_dom ) + + ELSE + ! id_imin < id_imax + CALL logger_trace("DOM DEFINE CYCLIC: "//& + & "domain to extract do not overlap east-west boundary") + + CALL dom__size_no_pole_no_overlap( td_dom ) + + ENDIF + + END SUBROUTINE dom__define_cyclic + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__define_closed(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine define sub domain indices from global domain + !> with closed boundaries. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + CALL dom__size_no_pole_no_overlap( td_dom ) + + END SUBROUTINE dom__define_closed + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_global(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of global domain + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + td_dom%i_imin = 1 + td_dom%i_imax = td_dom%t_dim0(1)%i_len + + td_dom%i_jmin = 1 + td_dom%i_jmax = td_dom%t_dim0(2)%i_len + + ! domain size + td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len + td_dom%t_dim(2)%i_len = td_dom%t_dim0(2)%i_len + + ! no ghost cell to add + td_dom%i_ghost(:,:)=0 + + ! periodicity + IF( td_dom%i_pivot == 0 )THEN ! 0-F + td_dom%i_perio=4 + td_dom%i_pivot=0 + ELSE ! 1-T + td_dom%i_perio=6 + td_dom%i_pivot=1 + ENDIF + + END SUBROUTINE dom__size_global + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_semi_global(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of a semi global domain + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !> @note never tested + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + + ! local variable + INTEGER(i4) :: il_imid ! canadian bipole index (middle of global domain) + !---------------------------------------------------------------- + + il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot + + td_dom%i_imin = 2 + td_dom%i_imax = il_imid !td_dom%t_dim0(1)%i_len + + IF( td_dom%i_jmin == 0 ) td_dom%i_jmin=1 + td_dom%i_jmax = td_dom%t_dim0(2)%i_len + + ! domain size + td_dom%t_dim(1)%i_len = td_dom%i_imax - & + & td_dom%i_imin + 1 + + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ? + + ! ghost cell to add + td_dom%i_ghost(:,:)=1 + + ! periodicity + IF( td_dom%i_pivot == 0 )THEN !0-F + td_dom%i_perio=3 + td_dom%i_pivot=0 + ELSE !1-T + td_dom%i_perio=5 + td_dom%i_pivot=1 + ENDIF + + END SUBROUTINE dom__size_semi_global + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_no_pole(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain without north fold + !> condition + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_jmax == 0 )THEN + CALL logger_fatal("DOM SIZE NO POLE: invalid domain. "//& + & "can not get north pole from this coarse grid. "//& + & "check namelist and coarse grid periodicity." ) + ENDIF + + IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .OR. & + & td_dom%i_imin > td_dom%i_imax )THEN + CALL logger_trace("DOM SIZE NO POLE: "// & + & "domain to extract overlap east-west boundary") + + CALL dom__size_no_pole_overlap( td_dom ) + + ELSE + ! id_imin < id_imax + CALL logger_trace("DOM SIZE NO POLE: "// & + & "domain to extract do not overlap east-west boundary") + + CALL dom__size_no_pole_no_overlap( td_dom ) + + ENDIF + + END SUBROUTINE dom__size_no_pole + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_pole(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain with north fold + !> condition. + !> + !> @author J.Paul + !> @date April, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !> @note never tested + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_imin >= td_dom%i_imax )THEN + CALL logger_trace("DOM SIZE POLE: "//& + & "domain to extract overlap east-west boundary") + CALL dom__size_pole_overlap( td_dom ) + ELSEIF( td_dom%i_imin < td_dom%i_imax )THEN + CALL logger_trace("DOM SIZE POLE: "//& + & "domain to extract do not overlap east-west boundary") + CALL dom__size_pole_no_overlap( td_dom ) + ENDIF + + END SUBROUTINE dom__size_pole + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_no_pole_overlap(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain without north fold + !> condition, and which overlap east-west boundary + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_jmax == 0 )THEN + CALL logger_fatal("DOM SIZE NO POLE OVERLAP: invalid domain. "//& + & "can not get north pole from this coarse grid. "//& + & "check namelist and coarse grid periodicity." ) + ENDIF + + IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 )THEN + ! domain to extract with east west cyclic boundary + CALL logger_trace("DOM SIZE NO POLE OVERLAP: "//& + & "domain to extract has cyclic east-west boundary") + + td_dom%i_imin = 1 + td_dom%i_imax = td_dom%t_dim0(1)%i_len + + td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len + + ! no ghost cell + td_dom%i_ghost(jp_I,:)=0 + + ! periodicity + td_dom%i_perio=1 + + ELSE + + ! id_imin > id_imax + ! extract domain overlap east-west boundary + + td_dom%t_dim(1)%i_len = td_dom%i_imax + & + & td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 - & + & td_dom%i_ew0 ! remove cyclic boundary + + ! add ghost cell + td_dom%i_ghost(jp_I,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ENDIF + + td_dom%t_dim(2)%i_len = td_dom%i_jmax - & + & td_dom%i_jmin + 1 + + ! add ghost cell + td_dom%i_ghost(jp_J,:)=1 + + END SUBROUTINE dom__size_no_pole_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_no_pole_no_overlap(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain without north fold + !> condition, and which do not overlap east-west boundary + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + !---------------------------------------------------------------- + + IF( td_dom%i_jmax == 0 )THEN + CALL logger_fatal("DOM SIZE NO POLE NO OVERLAP: invalid domain. "//& + & "can not get north pole from this coarse grid. "//& + & "check domain indices and grid periodicity." ) + ENDIF + + IF( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 )THEN + CALL logger_fatal("DOM SIZE NO POLE NO OVERLAP: invalid domain. "//& + & "can not overlap East-West boundary with this coarse grid. "//& + & "check domain indices and grid periodicity." ) + ENDIF + + td_dom%t_dim(1)%i_len = td_dom%i_imax - & + & td_dom%i_imin + 1 + + td_dom%t_dim(2)%i_len = td_dom%i_jmax - & + & td_dom%i_jmin + 1 + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + END SUBROUTINE dom__size_no_pole_no_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_pole_overlap(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain with north fold + !> condition, and which overlap east-west boundary + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !> @note never tested + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + + ! local variable + INTEGER(i4) :: il_idom1 ! extract domain size, east part + INTEGER(i4) :: il_idom2 ! extract domain size, west part + INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain) + !---------------------------------------------------------------- + + CALL logger_trace("DOM SIZE POLE OVERLAP: "//& + & "asian bipole inside domain to extract") + + il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot + + il_idom1 = td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 + il_idom2 = td_dom%i_imax + + IF( il_idom1 > il_imid .OR. il_idom2 > il_imid )THEN + + CALL logger_trace("DOM SIZE POLE OVERLAP: "//& + & "canadian bipole inside domain to extract") + td_dom%i_imin = 0 + td_dom%i_imax = 0 + + IF( td_dom%i_jmin == 0 .AND. td_dom%i_jmax == 0 )THEN + CALL dom__size_global( td_dom ) + ELSE + CALL dom__size_semi_global( td_dom ) + ENDIF + + ! periodicity + td_dom%i_perio=0 + + ELSEIF( il_idom1 > il_idom2 )THEN + + ! east part bigger than west part + CALL logger_trace("DOM SIZE POLE OVERLAP: east part bigger than west part ") + ! to respect symmetry around asian bipole + td_dom%i_imax = il_idom1 + + IF( td_dom%i_jmin == 0 ) td_dom%i_jmin = 1 + ! north pole + td_dom%i_jmax = td_dom%t_dim0(2)%i_len + + ! compute size + td_dom%t_dim(1)%i_len = il_idom1 !! no ghost cell ?? + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ? + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ELSE ! il_idom2 >= il_idom1 + + ! west part bigger than east part + CALL logger_trace("DOM SIZE POLE OVERLAP: west part bigger than east part ") + + ! to respect symmetry around asian bipole + td_dom%i_imin = td_dom%t_dim0(1)%i_len - il_idom2 + 1 + + IF( td_dom%i_jmin == 0 ) td_dom%i_jmin = 1 + ! north pole + td_dom%i_jmax=td_dom%t_dim0(2)%i_len + + ! compute size + td_dom%t_dim(1)%i_len = il_idom2 + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) - 2 + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ENDIF + + END SUBROUTINE dom__size_pole_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom__size_pole_no_overlap(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute size of sub domain with north fold + !> condition, and which do not overlap east-west boundary + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !> @note never tested + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + + ! local variable + INTEGER(i4) :: il_idom1 ! extract domain size, east part + INTEGER(i4) :: il_idom2 ! extract domain size, west part + INTEGER(i4) :: il_mid ! canadian biple index ? + !---------------------------------------------------------------- + + IF( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 .OR. & + & td_dom%i_imin > td_dom%i_imax )THEN + CALL logger_fatal("DOM SIZE POLE NO OVERLAP: invalid domain. "//& + & "can not overlap East-West boundary with this coarse grid. "//& + & "check namelist and coarse grid periodicity." ) + ENDIF + + CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//& + & "no asian bipole inside domain to extract") + + IF( td_dom%i_jmin==0 ) td_dom%i_jmin = 1 + IF( td_dom%i_jmax==0 ) td_dom%i_jmax = td_dom%t_dim0(2)%i_len + + ! + il_mid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot + + IF( (td_dom%i_imin < il_mid .AND. td_dom%i_imax < il_mid) .OR. & + & (td_dom%i_imin > il_mid .AND. td_dom%i_imax > il_mid) )THEN + CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//& + & "no canadian bipole inside domain to extract") + + td_dom%t_dim(1)%i_len = td_dom%i_imax - & + & td_dom%i_imin + 1 + + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ? + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ELSE ! id_imin < il_mid .AND. id_imax > il_mid + CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//& + & "canadian bipole inside domain to extract") + + il_idom1 = td_dom%i_imax - (il_mid - 1) + il_idom2 = il_mid - td_dom%i_imin + IF( il_idom1 > il_idom2 )THEN + ! east part bigger than west part + CALL logger_trace("DOM SIZE POLE NO OVERLAP: east part bigger than west part ") + ! to respect symmetry around canadian bipole + td_dom%i_imin = il_mid - il_idom1 + + td_dom%t_dim(1)%i_len = il_idom1 + 1 + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) & + & - 2 - 2 * td_dom%i_pivot ! remove north fold condition ? + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ELSE ! il_idom2 >= il_idom1 + ! west part bigger than east part + CALL logger_trace("DOM SIZE POLE NO OVERLAP: west part bigger than east part ") + ! to respect symmetry around canadian bipole + + td_dom%i_imax = il_mid + il_idom2 + + td_dom%t_dim(1)%i_len = il_idom2 + 1 + td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmin + 1 ) + & + & ( td_dom%t_dim0(2)%i_len - & + & td_dom%i_jmax + 1 ) & + & - 2 - 2 * td_dom%i_pivot ! remove north fold condition ? + + ! add ghost cell + td_dom%i_ghost(:,:)=1 + + ! periodicity + td_dom%i_perio=0 + + ENDIF + ENDIF + + END SUBROUTINE dom__size_pole_no_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom_add_extra(td_dom, id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add extra bands to coarse domain to get enough point for + !> interpolation... + !> + !> @details + !> - domain periodicity is take into account.<br/> + !> - domain indices are changed, and size of extra bands are saved.<br/> + !> - optionaly, i- and j- direction size of extra bands could be specify + !> (default=im_minext) + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date September, 2014 + !> - take into account number of ghost cell + !> @date February, 2016 + !> - number of extra point is the MAX (not the MIN) of zero and asess value. + !> + !> @param[inout] td_dom domain strcuture + !> @param [in] id_iext i-direction size of extra bands (default=im_minext) + !> @param [in] id_jext j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM) , INTENT(INOUT) :: td_dom + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + ! local variable + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + + ! loop indices + !---------------------------------------------------------------- + ! init + il_iext=im_minext + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=im_minext + IF( PRESENT(id_jext) ) il_jext=id_jext + + td_dom%i_iextra(:)=0 + td_dom%i_jextra(:)=0 + + IF( td_dom%i_imin == 1 .AND. & + & td_dom%i_imax == td_dom%t_dim0(1)%i_len .AND. & + & td_dom%i_jmin == 1 .AND. & + & td_dom%i_jmax == td_dom%t_dim0(2)%i_len )THEN + ! global + ! nothing to be done + ELSE + + IF( td_dom%i_imin == 1 .AND. & + & td_dom%i_imax == td_dom%t_dim0(1)%i_len )THEN + ! EW cyclic + ! nothing to be done + ELSE + IF( td_dom%i_ew0 < 0 )THEN + ! EW not cyclic + IF( td_dom%i_imin - il_iext > td_dom%i_ghost0(jp_I,1)*ip_ghost )THEN + td_dom%i_iextra(1) = il_iext + td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) + ELSE ! td_dom%i_imin - il_iext <= td_dom%i_ghost0(jp_I,1)*ip_ghost + td_dom%i_iextra(1) = MAX(0, & + & td_dom%i_imin - & + & td_dom%i_ghost0(jp_I,1)*ip_ghost -1) + td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) + ENDIF + + IF( td_dom%i_imax + il_iext < & + & td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost )THEN + td_dom%i_iextra(2) = il_iext + td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) + ELSE ! td_dom%i_imax + il_iext >= & + ! td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost + td_dom%i_iextra(2) = MAX( 0, & + & td_dom%t_dim0(1)%i_len - & + & td_dom%i_ghost0(jp_I,2)*ip_ghost - & + & td_dom%i_imax ) + td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) + ENDIF + + ELSE ! td_dom%i_ew0 >= 0 + + ! EW cyclic + IF( td_dom%i_imin - il_iext > 0 )THEN + td_dom%i_iextra(1) = il_iext + td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) + ELSE ! td_dom%i_imin - il_iext <= 0 + td_dom%i_iextra(1) = il_iext + td_dom%i_imin = td_dom%t_dim0(1)%i_len + & + & td_dom%i_imin - td_dom%i_iextra(1) -& + & td_dom%i_ew0 + ENDIF + + IF( td_dom%i_imax + il_iext <= td_dom%t_dim0(1)%i_len )THEN + td_dom%i_iextra(2) = il_iext + td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) + ELSE ! td_dom%i_imax + il_iext > td_dom%t_dim0(1)%i_len + td_dom%i_iextra(2) = il_iext + td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) - & + & (td_dom%t_dim0(1)%i_len-td_dom%i_ew0) + ENDIF + ENDIF + + ENDIF + + IF( td_dom%i_jmin == 1 .AND. & + & td_dom%i_jmax == td_dom%t_dim0(2)%i_len )THEN + ! nothing to be done + ELSE + + IF( td_dom%i_jmin - il_jext > td_dom%i_ghost0(jp_J,1)*ip_ghost )THEN + td_dom%i_jextra(1) = il_jext + td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1) + ELSE ! td_dom%i_jmin - il_jext <= td_dom%i_ghost0(jp_J,1)*ip_ghost + td_dom%i_jextra(1) = MAX( 0, & + & td_dom%i_jmin - & + & td_dom%i_ghost0(jp_J,1)*ip_ghost - 1) + td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1) + ENDIF + + IF( td_dom%i_jmax + il_jext < & + & td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost )THEN + td_dom%i_jextra(2) = il_jext + td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2) + ELSE ! td_dom%i_jmax + il_jext >= & + ! td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost + td_dom%i_jextra(2) = MAX( 0, & + & td_dom%t_dim0(2)%i_len - & + & td_dom%i_ghost0(jp_J,2)*ip_ghost - & + & td_dom%i_jmax ) + td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2) + ENDIF + ENDIF + + ENDIF + + IF( td_dom%i_imin <= td_dom%i_imax )THEN + td_dom%t_dim(1)%i_len = td_dom%i_imax - td_dom%i_imin +1 + ELSE ! td_dom%i_imin > td_dom%i_imax + td_dom%t_dim(1)%i_len = td_dom%i_imax + & + & td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 - & + & td_dom%i_ew0 ! remove overlap + ENDIF + + td_dom%t_dim(2)%i_len = td_dom%i_jmax-td_dom%i_jmin+1 + + + END SUBROUTINE dom_add_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom_clean_extra(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean coarse grid domain structure. + !> it remove extra point added. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM) , INTENT(INOUT) :: td_dom + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + ! change domain + td_dom%i_imin = td_dom%i_imin + td_dom%i_iextra(1) + td_dom%i_jmin = td_dom%i_jmin + td_dom%i_jextra(1) + + td_dom%i_imax = td_dom%i_imax - td_dom%i_iextra(2) + td_dom%i_jmax = td_dom%i_jmax - td_dom%i_jextra(2) + + td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len - & + & td_dom%i_iextra(1) - & + & td_dom%i_iextra(2) + td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len - & + & td_dom%i_jextra(1) - & + & td_dom%i_jextra(2) + + td_dom%i_iextra(:)=0 + td_dom%i_jextra(:)=0 + + END SUBROUTINE dom_clean_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom_del_extra(td_var, td_dom, id_rho, ld_coord) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete extra band, from fine grid variable value, + !> and dimension, taking into account refinement factor. + !> + !> @details + !> @note This subroutine should be used before clean domain structure. + !> + !> @warning if work on coordinates grid, do not remove all extra point. + !> save value on ghost cell. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date September, 2014 + !> - take into account boundary for one point size domain + !> @date December, 2014 + !> - add special case for coordinates file. + !> + !> @param[inout] td_var variable strcuture + !> @param[in] td_dom domain strcuture + !> @param[in] id_rho array of refinement factor + !> @param[in] ld_coord work on coordinates file or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + TYPE(TDOM) , INTENT(IN ) :: td_dom + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho + LOGICAL , INTENT(IN ), OPTIONAL :: ld_coord + + ! local variable + INTEGER(i4) :: il_iextra + INTEGER(i4) :: il_jextra + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + INTEGER(i4), DIMENSION(2) :: il_rho + INTEGER(i4), DIMENSION(2,2) :: il_ghost + + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + LOGICAL :: ll_coord + ! loop indices + !---------------------------------------------------------------- + + IF( PRESENT(id_rho) )THEN + ! work on coarse grid + il_rho(:)=id_rho(jp_I:jp_J) + ELSE + ! work on fine grid + il_rho(:)=1 + ENDIF + + ll_coord=.false. + IF( PRESENT(ld_coord) ) ll_coord=ld_coord + + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("DOM DEL EXTRA: no value associated to "//& + & "variable "//TRIM(td_var%c_name) ) + ELSE + ! get variable right domain + IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + + ALLOCATE(dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) + + il_iextra=SUM(td_dom%i_iextra(:))*il_rho(jp_I) + il_jextra=SUM(td_dom%i_jextra(:))*il_rho(jp_J) + + il_ghost(:,:)=0 + IF( ll_coord )THEN + il_ghost(:,:)=td_dom%i_ghost(:,:) + ENDIF + + IF( il_iextra >= td_var%t_dim(1)%i_len )THEN + ! case one point size dimension + SELECT CASE(td_dom%i_bdy) + + CASE(jp_north,jp_east) + + CALL logger_info("DOM DEL EXTRA: special case for north"//& + & " or east boundary.") + IF( td_dom%i_iextra(1) <= 0 )THEN + il_imin= 1 + il_ghost(jp_I,1) = 0 + ELSE + il_imin= 1 + (td_dom%i_iextra(1)-1)*il_rho(jp_I) + 1 & + & - il_ghost(jp_I,1) + ENDIF + IF( td_dom%i_iextra(2) <= 0 )THEN; + il_imax= td_var%t_dim(1)%i_len + il_ghost(jp_I,2) = 0 + ELSE + il_imax= td_var%t_dim(1)%i_len - & + & td_dom%i_iextra(2)*il_rho(jp_I) & + & + il_ghost(jp_I,2) + ENDIF + + CASE(jp_south,jp_west) + + CALL logger_info("DOM DEL EXTRA: special case for south"//& + & " or west boundary.") + IF( td_dom%i_iextra(1) <= 0 )THEN + il_imin= 1 + il_ghost(jp_I,1) = 0 + ELSE + il_imin= 1 + td_dom%i_iextra(1)*il_rho(jp_I) & + & - il_ghost(jp_I,1) + ENDIF + IF( td_dom%i_iextra(2) <= 0 )THEN + il_imax= td_var%t_dim(1)%i_len + il_ghost(jp_I,2) = 0 + ELSE + il_imax= td_var%t_dim(1)%i_len - & + & (td_dom%i_iextra(2)-1)*il_rho(jp_I) - 1 & + & + il_ghost(jp_I,2) + ENDIF + + CASE DEFAULT + + IF( MOD(il_iextra-td_var%t_dim(1)%i_len,2)==0 )THEN + ! case one point size dimension with even refinment + CALL logger_fatal("DOM DEL EXTRA: should have been"//& + & "an impossible case: domain of "//& + & " one point size and even refinment.") + ELSE + il_imin= 1 + & + & (td_dom%i_iextra(1)-1)*il_rho(jp_I) + & + & (il_rho(jp_I)-1)/2 + 1 & + & - il_ghost(jp_I,1) + il_imax= td_var%t_dim(1)%i_len - & + & (td_dom%i_iextra(2)-1)*il_rho(jp_I) - & + & (il_rho(jp_I)-1)/2 - 1 & + & + il_ghost(jp_I,2) + ENDIF + + END SELECT + + td_var%t_dim(1)%i_len = 1 + SUM(il_ghost(jp_I,:)) + + ELSE + ! general case + il_imin=1 + td_dom%i_iextra(1)*il_rho(jp_I) & + & - il_ghost(jp_I,1) + il_imax=td_var%t_dim(1)%i_len - td_dom%i_iextra(2)*il_rho(jp_I) & + & + il_ghost(jp_I,2) + + td_var%t_dim(1)%i_len=td_var%t_dim(1)%i_len - il_iextra & + & + SUM(il_ghost(jp_I,:)) + ENDIF + + IF( il_jextra >= td_var%t_dim(2)%i_len )THEN + ! case one point size dimension + SELECT CASE(td_dom%i_bdy) + + CASE(jp_north,jp_east) + + IF( td_dom%i_jextra(1) <= 0 )THEN + il_jmin= 1 + il_ghost(jp_J,1) = 0 + ELSE + il_jmin= 1 + (td_dom%i_jextra(1)-1)*il_rho(jp_J) + 1 & + & - il_ghost(jp_J,1) + ENDIF + IF( td_dom%i_jextra(2) <= 0 )THEN + il_jmax= td_var%t_dim(2)%i_len + il_ghost(jp_J,2) = 0 + ELSE + il_jmax= td_var%t_dim(2)%i_len - & + & td_dom%i_jextra(2)*il_rho(jp_J) & + & + il_ghost(jp_J,2) + ENDIF + + CASE(jp_south,jp_west) + + IF( td_dom%i_iextra(2) <= 0 )THEN + il_jmin= 1 + il_ghost(jp_J,1) = 0 + ELSE + il_jmin= 1 + td_dom%i_jextra(1)*il_rho(jp_J) & + & - il_ghost(jp_J,1) + ENDIF + IF( td_dom%i_jextra(2) <= 0 )THEN + il_jmax= td_var%t_dim(2)%i_len + il_ghost(jp_J,2) = 0 + ELSE + il_jmax= td_var%t_dim(2)%i_len - & + & (td_dom%i_jextra(2)-1)*il_rho(jp_J) - 1 & + & + il_ghost(jp_J,2) + ENDIF + + CASE DEFAULT + + IF( MOD(il_jextra-td_var%t_dim(2)%i_len,2)==0 )THEN + ! case one point size dimension with even refinment + CALL logger_fatal("DOM DEL EXTRA: should have been"//& + & "an impossible case: domain of "//& + & " one point size and even refinment.") + ELSE + il_jmin= 1 + & + & (td_dom%i_jextra(1)-1)*il_rho(jp_J) + & + & (il_rho(jp_J)-1)/2 + 1 & + & - il_ghost(jp_J,1) + il_jmax= td_var%t_dim(2)%i_len - & + & (td_dom%i_jextra(2)-1)*il_rho(jp_J) - & + & (il_rho(jp_J)-1)/2 - 1 & + & + il_ghost(jp_J,2) + ENDIF + + END SELECT + + td_var%t_dim(2)%i_len = 1 + SUM(il_ghost(jp_J,:)) + + ELSE + ! general case + il_jmin=1 + td_dom%i_jextra(1)*il_rho(jp_J) & + & - il_ghost(jp_J,1) + il_jmax=td_var%t_dim(2)%i_len - td_dom%i_jextra(2)*il_rho(jp_J) & + & + il_ghost(jp_J,2) + + td_var%t_dim(2)%i_len= td_var%t_dim(2)%i_len - il_jextra & + & + SUM(il_ghost(jp_J,:)) + ENDIF + + DEALLOCATE(td_var%d_value) + ALLOCATE(td_var%d_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + td_var%d_value(:,:,:,:)=dl_value(il_imin:il_imax, & + & il_jmin:il_jmax, & + & :, :) + DEALLOCATE(dl_value) + ENDIF + + ENDIF + + END SUBROUTINE dom_del_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE dom_clean(td_dom) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean domain structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_dom domain strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TDOM), INTENT(INOUT) :: td_dom + + ! local variable + TYPE(TDOM) :: tl_dom ! empty dom structure + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + CALL logger_info( "DOM CLEAN: reset domain " ) + + ! del dimension + DO ji=ip_maxdim,1,-1 + CALL dim_clean( td_dom%t_dim0(ji) ) + ENDDO + + ! replace by empty structure + td_dom=tl_dom + + END SUBROUTINE dom_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE dom diff --git a/V4.0/nemo_sources/tools/SIREN/src/extrap.f90 b/V4.0/nemo_sources/tools/SIREN/src/extrap.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9c0a33c0346cb36907acc1f1a3ed1b177e3af91c --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/extrap.f90 @@ -0,0 +1,1382 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage extrapolation. +!> +!> @details +!> Extrapolation method to be used is specify inside variable +!> strcuture, as array of string character.<br/> +!> - td_var\%c_extrap(1) string character is the interpolation name choose between: +!> - 'dist_weight' +!> - 'min_error' +!> +!> @note Extrapolation method could be specify for each variable in namelist _namvar_, +!> defining string character _cn\_varinfo_. By default _dist_weight_.<br/> +!> Example: +!> - cn_varinfo='varname1:ext=dist_weight', 'varname2:ext=min_error' +!> +!> to detect point to be extrapolated:<br/> +!> @code +!> il_detect(:,:,:)=extrap_detect(td_var) +!> @endcode +!> - il_detect(:,:,:) is 3D array of point to be extrapolated +!> - td_var is coarse grid variable to be extrapolated +!> +!> to extrapolate variable:<br/> +!> @code +!> CALL extrap_fill_value( td_var, [id_radius]) +!> @endcode +!> - td_var is coarse grid variable to be extrapolated +!> - id_radius is radius of the halo used to compute extrapolation [optional] +!> +!> to add extraband to the variable (to be extrapolated):<br/> +!> @code +!> CALL extrap_add_extrabands(td_var, [id_isize,] [id_jsize] ) +!> @endcode +!> - td_var is variable structure +!> - id_isize : i-direction size of extra bands [optional] +!> - id_jsize : j-direction size of extra bands [optional] +!> +!> to delete extraband of a variable:<br/> +!> @code +!> CALL extrap_del_extrabands(td_var, [id_isize,] [id_jsize] ) +!> @endcode +!> - td_var is variable structure +!> - id_isize : i-direction size of extra bands [optional] +!> - id_jsize : j-direction size of extra bands [optional] +!> +!> @warning _FillValue must not be zero (use var_chg_FillValue()) +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header +!> @date June, 2015 +!> - extrapolate all land points (_FillValue) +!> - move deriv function to math module +!> @date July, 2015 +!> - compute extrapolation from north west to south east, +!> and from south east to north west +!> +!> @todo +!> - create module for each extrapolation method +!> - smooth extrapolated points +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE extrap + + USE netcdf ! nf90 library + USE kind ! F90 kind parameter + USE phycst ! physical constant + USE global ! global variable + USE fct ! basic useful function + USE date ! date manager + USE logger ! log file manager + USE math ! mathematical function + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PRIVATE :: im_minext !< default minumum number of point to extrapolate + PRIVATE :: im_mincubic !< default minumum number of point to extrapolate for cubic interpolation + + ! function and subroutine + PUBLIC :: extrap_detect !< detected point to be extrapolated + PUBLIC :: extrap_fill_value !< extrapolate value over detected point + PUBLIC :: extrap_add_extrabands !< add extraband to the variable (to be extrapolated) + PUBLIC :: extrap_del_extrabands !< delete extraband of the variable + + PRIVATE :: extrap__detect_wrapper ! detected point to be extrapolated wrapper + PRIVATE :: extrap__detect ! detected point to be extrapolated + PRIVATE :: extrap__fill_value_wrapper ! extrapolate value over detected point wrapper + PRIVATE :: extrap__fill_value ! extrapolate value over detected point + PRIVATE :: extrap__3D ! + PRIVATE :: extrap__3D_min_error_coef ! + PRIVATE :: extrap__3D_min_error_fill ! + PRIVATE :: extrap__3D_dist_weight_coef ! + PRIVATE :: extrap__3D_dist_weight_fill ! + + INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of point to extrapolate + INTEGER(i4), PARAMETER :: im_mincubic= 4 !< default minumum number of point to extrapolate for cubic interpolation + + INTERFACE extrap_detect + MODULE PROCEDURE extrap__detect_wrapper !< detected point to be extrapolated + END INTERFACE extrap_detect + + INTERFACE extrap_fill_value + MODULE PROCEDURE extrap__fill_value_wrapper !< detected point to be interpolated + END INTERFACE extrap_fill_value + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION extrap__detect(td_var0) & + & RESULT (if_detect) + !------------------------------------------------------------------- + !> @brief + !> This function detected point to be extrapolated, given variable structure. + !> + !> @details + !> optionaly, you could sepcify fine grid level, refinment factor (default 1), + !> offset between fine and coarse grid (default compute from refinment factor + !> as offset=(rho-1)/2), number of point to be extrapolated in each direction + !> (default im_minext).<br/> + !> + !> First coarsening fine grid level, if need be, then select point near + !> grid point already inform. + !> + !> @note point to be extrapolated are selected using FillValue, + !> so to avoid mistake FillValue should not be zero (use var_chg_FillValue) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - do not use level to select points to be extrapolated + !> + !> @param[in] td_var0 coarse grid variable to extrapolate + !> @return array of point to be extrapolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN ) :: td_var0 + + ! function + INTEGER(i4), DIMENSION(td_var0%t_dim(1)%i_len,& + & td_var0%t_dim(2)%i_len,& + & td_var0%t_dim(3)%i_len ) :: if_detect + + ! local variable + ! loop indices + INTEGER(i4) :: ji0 + INTEGER(i4) :: jj0 + INTEGER(i4) :: jk0 + !---------------------------------------------------------------- + + ! force to extrapolated all points + if_detect(:,:,:)=1 + + ! do not compute grid point already inform + DO jk0=1,td_var0%t_dim(3)%i_len + DO jj0=1,td_var0%t_dim(2)%i_len + DO ji0=1,td_var0%t_dim(1)%i_len + IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill )THEN + if_detect(ji0,jj0,jk0)=0 + ENDIF + ENDDO + ENDDO + ENDDO + + END FUNCTION extrap__detect + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION extrap__detect_wrapper(td_var) & + & RESULT (if_detect) + !------------------------------------------------------------------- + !> @brief + !> This function sort variable to be extrapolated, depending on number of + !> dimentsion, then detected point to be extrapolated. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - select all land points for extrapolation + !> + !> @param[in] td_var coarse grid variable to extrapolate + !> @return 3D array of point to be extrapolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN ) :: td_var + + ! function + INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len,& + & td_var%t_dim(2)%i_len,& + & td_var%t_dim(3)%i_len ) :: if_detect + + ! local variable + ! loop indices + !---------------------------------------------------------------- + ! init + if_detect(:,:,:)=0 + + IF( .NOT. ANY(td_var%t_dim(1:3)%l_use) )THEN + ! no dimension I-J-K used + CALL logger_debug(" EXTRAP DETECT: nothing done for variable"//& + & TRIM(td_var%c_name) ) + ELSE IF( ALL(td_var%t_dim(1:3)%l_use) )THEN + + ! detect point to be extrapolated on I-J-K + CALL logger_debug(" EXTRAP DETECT: detect point "//& + & " for variable "//TRIM(td_var%c_name) ) + + if_detect(:,:,:)=extrap__detect( td_var ) + + ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + + ! detect point to be extrapolated on I-J + CALL logger_debug(" EXTRAP DETECT: detect horizontal point "//& + & " for variable "//TRIM(td_var%c_name) ) + + if_detect(:,:,1:1)=extrap__detect( td_var ) + + ELSE IF( td_var%t_dim(3)%l_use )THEN + + ! detect point to be extrapolated on K + CALL logger_debug(" EXTRAP DETECT: detect vertical point "//& + & " for variable "//TRIM(td_var%c_name) ) + + if_detect(1:1,1:1,:)=extrap__detect( td_var ) + + ENDIF + + CALL logger_debug(" EXTRAP DETECT: "//& + & TRIM(fct_str(SUM(if_detect(:,:,:))))//& + & " points to be extrapolated" ) + + END FUNCTION extrap__detect_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE extrap__fill_value_wrapper(td_var, id_radius) + !------------------------------------------------------------------- + !> @brief + !> This subroutine select method to be used for extrapolation. + !> If need be, increase number of points to be extrapolated. + !> Finally launch extrap__fill_value. + !> + !> @details + !> optionaly, you could specify :<br/> + !> - refinment factor (default 1) + !> - offset between fine and coarse grid (default compute from refinment factor + !> as offset=(rho-1)/2) + !> - number of point to be extrapolated in each direction (default im_minext) + !> - radius of the halo used to compute extrapolation + !> - maximum number of iteration + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - select all land points for extrapolation + !> + !> @param[inout] td_var variable structure + !> @param[in] id_radius radius of the halo used to compute extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_radius + + ! local variable + INTEGER(i4) :: il_radius + + CHARACTER(LEN=lc) :: cl_method + + ! loop indices + !---------------------------------------------------------------- + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("EXTRAP FILL VALUE: no value "//& + & "associted to variable "//TRIM(td_var%c_name) ) + ELSE + + SELECT CASE(TRIM(td_var%c_extrap(1))) + CASE('min_error') + cl_method='min_error' + CASE DEFAULT + cl_method='dist_weight' + + !update variable structure + td_var%c_extrap(1)='dist_weight' + END SELECT + + ! number of point use to compute box + il_radius=1 + IF( PRESENT(id_radius) ) il_radius=id_radius + IF( il_radius < 0 )THEN + CALL logger_error("EXTRAP FILL VALUE: invalid "//& + & " radius of the box used to compute extrapolation "//& + & "("//TRIM(fct_str(il_radius))//")") + ENDIF + + CALL logger_info("EXTRAP FILL: extrapolate "//TRIM(td_var%c_name)//& + & " using "//TRIM(cl_method)//" method." ) + + CALL extrap__fill_value( td_var, cl_method, & + & il_radius ) + + ENDIF + + END SUBROUTINE extrap__fill_value_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE extrap__fill_value(td_var, cd_method, id_radius) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute point to be extrapolated, then extrapolate point. + !> + !> @details + !> optionaly, you could specify :<br/> + !> - refinment factor (default 1) + !> - offset between fine and coarse grid (default compute from refinment factor + !> as offset=(rho-1)/2) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - select all land points for extrapolation + !> + !> @param[inout] td_var variable structure + !> @param[in] cd_method extrapolation method + !> @param[in] id_radius radius of the halo used to compute extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=*), INTENT(IN ) :: cd_method + INTEGER(i4) , INTENT(IN ) :: id_radius + + ! local variable + CHARACTER(LEN=lc) :: cl_extrap + + INTEGER(i4), DIMENSION(:,:,:) , ALLOCATABLE :: il_detect + + TYPE(TATT) :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + !1- detect point to be extrapolated + ALLOCATE( il_detect( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len) ) + + il_detect(:,:,:) = extrap_detect( td_var ) + + !2- add attribute to variable + cl_extrap=fct_concat(td_var%c_extrap(:)) + tl_att=att_init('extrapolation',cl_extrap) + CALL var_move_att(td_var, tl_att) + + CALL att_clean(tl_att) + + IF( ALL(il_detect(:,:,:)==1) )THEN + CALL logger_warn(" EXTRAP FILL: "//& + & " can not extrapolate "//TRIM(td_var%c_name)//& + & ". no value inform." ) + ELSE + CALL logger_info(" EXTRAP FILL: "//& + & TRIM(fct_str(SUM(il_detect(:,:,:))))//& + & " point(s) to extrapolate " ) + + CALL logger_info(" EXTRAP FILL: method "//& + & TRIM(cd_method) ) + + !3- extrapolate + CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, & + & il_detect(:,:,:), & + & cd_method, id_radius ) + ENDIF + + DEALLOCATE(il_detect) + + END SUBROUTINE extrap__fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE extrap__3D(dd_value, dd_fill, id_detect,& + & cd_method, id_radius) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute point to be extrapolated in 3D array. + !> + !> @details + !> in case of 'min_error' method:<br/> + !> - compute derivative in i-, j- and k- direction + !> - compute minimum error coefficient (distance to center of halo) + !> - compute extrapolatd values by calculated minimum error using taylor expansion + !> in case of 'dist_weight' method:<br/> + !> - compute distance weight coefficient (inverse of distance to center of halo) + !> - compute extrapolatd values using Inverse Distance Weighting + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - compute coef indices to be used + !> - bug fix: force coef indice to 1, for dimension lenth equal to 1 + !> + !> @param[inout] dd_value 3D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect array of point to extrapolate + !> @param[in] cd_method extrapolation method + !> @param[in] id_radius radius of the halo used to compute extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(i4), DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect + CHARACTER(LEN=*), INTENT(IN ) :: cd_method + INTEGER(i4), INTENT(IN ) :: id_radius + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + INTEGER(i4) :: il_kmin + INTEGER(i4) :: il_kmax + INTEGER(i4) :: il_iter + INTEGER(i4) :: il_radius + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + INTEGER(i4) :: il_j1 + INTEGER(i4) :: il_j2 + INTEGER(i4) :: il_k1 + INTEGER(i4) :: il_k2 + + INTEGER(i4), DIMENSION(4) :: il_shape + INTEGER(i4), DIMENSION(3) :: il_dim + + INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect + + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdx + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdy + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdz + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_coef + + LOGICAL :: ll_iter + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(dd_value) + + ALLOCATE( il_detect( il_shape(1), il_shape(2), il_shape(3)) ) + + SELECT CASE(TRIM(cd_method)) + CASE('min_error') + DO jl=1,il_shape(4) + + ! initialise table of point to be extrapolated + il_detect(:,:,:)=id_detect(:,:,:) + + il_iter=1 + DO WHILE( ANY(il_detect(:,:,:)==1) ) + ! change extend value to minimize number of iteration + il_radius=id_radius+(il_iter-1) + ll_iter=.TRUE. + + ALLOCATE( dl_dfdx(il_shape(1), il_shape(2), il_shape(3)) ) + ALLOCATE( dl_dfdy(il_shape(1), il_shape(2), il_shape(3)) ) + ALLOCATE( dl_dfdz(il_shape(1), il_shape(2), il_shape(3)) ) + + ! compute derivative in i-direction + dl_dfdx(:,:,:)=dd_fill + IF( il_shape(1) > 1 )THEN + dl_dfdx(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & + & dd_fill, 'I' ) + ENDIF + + ! compute derivative in j-direction + dl_dfdy(:,:,:)=dd_fill + IF( il_shape(2) > 1 )THEN + dl_dfdy(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & + & dd_fill, 'J' ) + ENDIF + + ! compute derivative in k-direction + dl_dfdz(:,:,:)=dd_fill + IF( il_shape(3) > 1 )THEN + dl_dfdz(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & + & dd_fill, 'K' ) + ENDIF + + il_dim(1)=2*il_radius+1 + IF( il_shape(1) < 2*il_radius+1 ) il_dim(1)=1 + il_dim(2)=2*il_radius+1 + IF( il_shape(2) < 2*il_radius+1 ) il_dim(2)=1 + il_dim(3)=2*il_radius+1 + IF( il_shape(3) < 2*il_radius+1 ) il_dim(3)=1 + + ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) ) + + dl_coef(:,:,:)=extrap__3D_min_error_coef(dd_value( 1:il_dim(1), & + & 1:il_dim(2), & + & 1:il_dim(3), & + & jl )) + + DO jk=1,il_shape(3) + ! from North West(1,1) to South East(il_shape(1),il_shape(2)) + IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE + DO jj=1,il_shape(2) + IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE + DO ji=1,il_shape(1) + + IF( il_detect(ji,jj,jk) == 1 )THEN + + il_imin=MAX(ji-il_radius,1) + il_imax=MIN(ji+il_radius,il_shape(1)) + ! coef indices to be used + il_i1 = il_radius-(ji-il_imin)+1 + il_i2 = il_radius+(il_imax-ji)+1 + IF( il_dim(1) == 1 )THEN + il_imin=ji + il_imax=ji + ! coef indices to be used + il_i1 = 1 + il_i2 = 1 + ENDIF + + + il_jmin=MAX(jj-il_radius,1) + il_jmax=MIN(jj+il_radius,il_shape(2)) + ! coef indices to be used + il_j1 = il_radius-(jj-il_jmin)+1 + il_j2 = il_radius+(il_jmax-jj)+1 + IF( il_dim(2) == 1 )THEN + il_jmin=jj + il_jmax=jj + ! coef indices to be used + il_j1 = 1 + il_j2 = 1 + ENDIF + + il_kmin=MAX(jk-il_radius,1) + il_kmax=MIN(jk+il_radius,il_shape(3)) + ! coef indices to be used + il_k1 = il_radius-(jk-il_kmin)+1 + il_k2 = il_radius+(il_kmax-jk)+1 + IF( il_dim(3) == 1 )THEN + il_kmin=jk + il_kmax=jk + ! coef indices to be used + il_k1 = 1 + il_k2 = 1 + ENDIF + + dd_value(ji,jj,jk,jl)=extrap__3D_min_error_fill( & + & dd_value( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax,jl ), dd_fill, il_radius, & + & dl_dfdx( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_dfdy( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_dfdz( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_coef(il_i1:il_i2, & + & il_j1:il_j2, & + & il_k1:il_k2) ) + + IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN + il_detect(ji,jj,jk)= 0 + ll_iter=.FALSE. + ENDIF + + ENDIF + + ENDDO + ENDDO + ! from South East(il_shape(1),il_shape(2)) to North West(1,1) + IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE + DO jj=il_shape(2),1,-1 + IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE + DO ji=il_shape(1),1,-1 + + IF( il_detect(ji,jj,jk) == 1 )THEN + + il_imin=MAX(ji-il_radius,1) + il_imax=MIN(ji+il_radius,il_shape(1)) + ! coef indices to be used + il_i1 = il_radius-(ji-il_imin)+1 + il_i2 = il_radius+(il_imax-ji)+1 + IF( il_dim(1) == 1 )THEN + il_imin=ji + il_imax=ji + ! coef indices to be used + il_i1 = 1 + il_i2 = 1 + ENDIF + + + il_jmin=MAX(jj-il_radius,1) + il_jmax=MIN(jj+il_radius,il_shape(2)) + ! coef indices to be used + il_j1 = il_radius-(jj-il_jmin)+1 + il_j2 = il_radius+(il_jmax-jj)+1 + IF( il_dim(2) == 1 )THEN + il_jmin=jj + il_jmax=jj + ! coef indices to be used + il_j1 = 1 + il_j2 = 1 + ENDIF + + il_kmin=MAX(jk-il_radius,1) + il_kmax=MIN(jk+il_radius,il_shape(3)) + ! coef indices to be used + il_k1 = il_radius-(jk-il_kmin)+1 + il_k2 = il_radius+(il_kmax-jk)+1 + IF( il_dim(3) == 1 )THEN + il_kmin=jk + il_kmax=jk + ! coef indices to be used + il_k1 = 1 + il_k2 = 1 + ENDIF + + dd_value(ji,jj,jk,jl)=extrap__3D_min_error_fill( & + & dd_value( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax,jl ), dd_fill, il_radius, & + & dl_dfdx( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_dfdy( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_dfdz( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax ), & + & dl_coef(il_i1:il_i2, & + & il_j1:il_j2, & + & il_k1:il_k2) ) + + IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN + il_detect(ji,jj,jk)= 0 + ll_iter=.FALSE. + ENDIF + + ENDIF + + ENDDO + ENDDO + ENDDO + + DEALLOCATE( dl_dfdx ) + DEALLOCATE( dl_dfdy ) + DEALLOCATE( dl_dfdz ) + DEALLOCATE( dl_coef ) + + IF( ll_iter ) il_iter=il_iter+1 + ENDDO + ENDDO + + CASE DEFAULT ! 'dist_weight' + DO jl=1,il_shape(4) + + ! intitialise table of poitn to be extrapolated + il_detect(:,:,:)=id_detect(:,:,:) + + il_iter=1 + DO WHILE( ANY(il_detect(:,:,:)==1) ) + ! change extend value to minimize number of iteration + il_radius=id_radius+(il_iter-1) + ll_iter=.TRUE. + + il_dim(1)=2*il_radius+1 + IF( il_shape(1) < 2*il_radius+1 ) il_dim(1)=1 + il_dim(2)=2*il_radius+1 + IF( il_shape(2) < 2*il_radius+1 ) il_dim(2)=1 + il_dim(3)=2*il_radius+1 + IF( il_shape(3) < 2*il_radius+1 ) il_dim(3)=1 + + ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) ) + + dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1),& + & 1:il_dim(2),& + & 1:il_dim(3),& + & jl ) ) + + DO jk=1,il_shape(3) + ! from North West(1,1) to South East(il_shape(1),il_shape(2)) + IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE + DO jj=1,il_shape(2) + IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE + DO ji=1,il_shape(1) + + IF( il_detect(ji,jj,jk) == 1 )THEN + + il_imin=MAX(ji-il_radius,1) + il_imax=MIN(ji+il_radius,il_shape(1)) + ! coef indices to be used + il_i1 = il_radius-(ji-il_imin)+1 + il_i2 = il_radius+(il_imax-ji)+1 + IF( il_dim(1) == 1 )THEN + il_imin=ji + il_imax=ji + ! coef indices to be used + il_i1 = 1 + il_i2 = 1 + ENDIF + + il_jmin=MAX(jj-il_radius,1) + il_jmax=MIN(jj+il_radius,il_shape(2)) + ! coef indices to be used + il_j1 = il_radius-(jj-il_jmin)+1 + il_j2 = il_radius+(il_jmax-jj)+1 + IF( il_dim(2) == 1 )THEN + il_jmin=jj + il_jmax=jj + ! coef indices to be used + il_j1 = 1 + il_j2 = 1 + ENDIF + + il_kmin=MAX(jk-il_radius,1) + il_kmax=MIN(jk+il_radius,il_shape(3)) + ! coef indices to be used + il_k1 = il_radius-(jk-il_kmin)+1 + il_k2 = il_radius+(il_kmax-jk)+1 + IF( il_dim(3) == 1 )THEN + il_kmin=jk + il_kmax=jk + ! coef indices to be used + il_k1 = 1 + il_k2 = 1 + ENDIF + + dd_value(ji,jj,jk,jl)=extrap__3D_dist_weight_fill( & + & dd_value( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax, & + & jl), dd_fill, il_radius, & + & dl_coef(il_i1:il_i2, & + & il_j1:il_j2, & + & il_k1:il_k2) ) + + IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN + il_detect(ji,jj,jk)= 0 + ll_iter=.FALSE. + ENDIF + + ENDIF + + ENDDO + ENDDO + ! from South East(il_shape(1),il_shape(2)) to North West(1,1) + IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE + DO jj=il_shape(2),1,-1 + IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE + DO ji=il_shape(1),1,-1 + + IF( il_detect(ji,jj,jk) == 1 )THEN + + il_imin=MAX(ji-il_radius,1) + il_imax=MIN(ji+il_radius,il_shape(1)) + ! coef indices to be used + il_i1 = il_radius-(ji-il_imin)+1 + il_i2 = il_radius+(il_imax-ji)+1 + IF( il_dim(1) == 1 )THEN + il_imin=ji + il_imax=ji + ! coef indices to be used + il_i1 = 1 + il_i2 = 1 + ENDIF + + il_jmin=MAX(jj-il_radius,1) + il_jmax=MIN(jj+il_radius,il_shape(2)) + ! coef indices to be used + il_j1 = il_radius-(jj-il_jmin)+1 + il_j2 = il_radius+(il_jmax-jj)+1 + IF( il_dim(2) == 1 )THEN + il_jmin=jj + il_jmax=jj + ! coef indices to be used + il_j1 = 1 + il_j2 = 1 + ENDIF + + il_kmin=MAX(jk-il_radius,1) + il_kmax=MIN(jk+il_radius,il_shape(3)) + ! coef indices to be used + il_k1 = il_radius-(jk-il_kmin)+1 + il_k2 = il_radius+(il_kmax-jk)+1 + IF( il_dim(3) == 1 )THEN + il_kmin=jk + il_kmax=jk + ! coef indices to be used + il_k1 = 1 + il_k2 = 1 + ENDIF + + dd_value(ji,jj,jk,jl)=extrap__3D_dist_weight_fill( & + & dd_value( il_imin:il_imax, & + & il_jmin:il_jmax, & + & il_kmin:il_kmax, & + & jl), dd_fill, il_radius, & + & dl_coef(il_i1:il_i2, & + & il_j1:il_j2, & + & il_k1:il_k2) ) + + IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN + il_detect(ji,jj,jk)= 0 + ll_iter=.FALSE. + ENDIF + + ENDIF + + ENDDO + ENDDO + ENDDO + CALL logger_info(" EXTRAP 3D: "//& + & TRIM(fct_str(SUM(il_detect(:,:,:))))//& + & " point(s) to extrapolate " ) + + DEALLOCATE( dl_coef ) + IF( ll_iter ) il_iter=il_iter+1 + ENDDO + ENDDO + END SELECT + + DEALLOCATE( il_detect ) + + END SUBROUTINE extrap__3D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION extrap__3D_min_error_coef(dd_value) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief + !> This function compute coefficient for min_error extrapolation. + !> + !> @details + !> coefficients are "grid distance" to the center of the box + !> choosed to compute extrapolation. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - decrease weight of third dimension + !> + !> @param[in] dd_value 3D array of variable to be extrapolated + !> @return 3D array of coefficient for minimum error extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value + + ! function + REAL(dp), DIMENSION(SIZE(dd_value(:,:,:),DIM=1), & + & SIZE(dd_value(:,:,:),DIM=2), & + & SIZE(dd_value(:,:,:),DIM=3) ) :: df_value + + ! local variable + INTEGER(i4), DIMENSION(3) :: il_shape + + INTEGER(i4) :: il_imid + INTEGER(i4) :: il_jmid + INTEGER(i4) :: il_kmid + + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dist + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! init + df_value(:,:,:)=0 + + il_shape(:)=SHAPE(dd_value(:,:,:)) + + il_imid=INT(REAL(il_shape(1),sp)*0.5+1) + il_jmid=INT(REAL(il_shape(2),sp)*0.5+1) + il_kmid=INT(REAL(il_shape(3),sp)*0.5+1) + + ALLOCATE( dl_dist(il_shape(1),il_shape(2),il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + + ! compute distance + ! "vertical weight" is lower than horizontal + dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & + & (jj-il_jmid)**2 + & + & 3*(jk-il_kmid)**2 + + IF( dl_dist(ji,jj,jk) /= 0 )THEN + dl_dist(ji,jj,jk)=SQRT( dl_dist(ji,jj,jk) ) + ENDIF + + ENDDO + ENDDO + ENDDO + + WHERE( dl_dist(:,:,:) /= 0 ) + df_value(:,:,:)=dl_dist(:,:,:) + END WHERE + + DEALLOCATE( dl_dist ) + + END FUNCTION extrap__3D_min_error_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION extrap__3D_min_error_fill(dd_value, dd_fill, id_radius,& + & dd_dfdx, dd_dfdy, dd_dfdz, & + & dd_coef) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief + !> This function compute extrapolatd value by calculated minimum error using + !> taylor expansion + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_value 3D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[in] id_radius radius of the halo used to compute extrapolation + !> @param[in] dd_dfdx derivative of function in i-direction + !> @param[in] dd_dfdy derivative of function in j-direction + !> @param[in] dd_dfdz derivative of function in k-direction + !> @param[in] dd_coef array of coefficient for min_error extrapolation + !> @return extrapolatd value + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + INTEGER(i4), INTENT(IN) :: id_radius + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_dfdx + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_dfdy + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_dfdz + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_coef + + ! function + REAL(dp) :: df_value + + ! local variable + INTEGER(i4), DIMENSION(3) :: il_shape + INTEGER(i4), DIMENSION(3) :: il_ind + + INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_error + + INTEGER(i4) :: il_min + ! loop indices + + !---------------------------------------------------------------- + + ! init + df_value=dd_fill + + il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2)) + + IF( COUNT(dd_value(:,:,:) /= dd_fill) >= il_min )THEN + + il_shape(:)=SHAPE(dd_value(:,:,:)) + ALLOCATE( il_mask( il_shape(1),il_shape(2),il_shape(3)) ) + ALLOCATE( dl_error(il_shape(1),il_shape(2),il_shape(3)) ) + + ! compute error + dl_error(:,:,:)=0. + il_mask(:,:,:)=0 + WHERE( dd_dfdx(:,:,:) /= dd_fill ) + dl_error(:,:,:)=dd_coef(:,:,:)*dd_dfdx(:,:,:) + il_mask(:,:,:)=1 + END WHERE + WHERE( dd_dfdy(:,:,:) /= dd_fill ) + dl_error(:,:,:)=(dl_error(:,:,:)+dd_coef(:,:,:)*dd_dfdy(:,:,:)) + il_mask(:,:,:)=1 + END WHERE + WHERE( dd_dfdz(:,:,:) /= dd_fill ) + dl_error(:,:,:)=(dl_error(:,:,:)+dd_coef(:,:,:)*dd_dfdz(:,:,:)) + il_mask(:,:,:)=1 + END WHERE + + ! get minimum error indices + il_ind(:)=MINLOC(dl_error(:,:,:),il_mask(:,:,:)==1) + + ! return value + IF( ALL(il_ind(:)/=0) )THEN + df_value=dd_value(il_ind(1),il_ind(2),il_ind(3)) + ENDIF + + DEALLOCATE( il_mask ) + DEALLOCATE( dl_error ) + + ENDIF + + END FUNCTION extrap__3D_min_error_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION extrap__3D_dist_weight_coef(dd_value) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief + !> This function compute coefficient for inverse distance weighted method + !> + !> @details + !> coefficients are inverse "grid distance" to the center of the box choosed to compute + !> extrapolation. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - decrease weight of third dimension + !> + !> @param[in] dd_value 3D array of variable to be extrapolated + !> @return 3D array of coefficient for inverse distance weighted extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: dd_value + + ! function + REAL(dp), DIMENSION(SIZE(dd_value(:,:,:),DIM=1), & + & SIZE(dd_value(:,:,:),DIM=2), & + & SIZE(dd_value(:,:,:),DIM=3) ) :: df_value + + ! local variable + INTEGER(i4), DIMENSION(3) :: il_shape + + INTEGER(i4) :: il_imid + INTEGER(i4) :: il_jmid + INTEGER(i4) :: il_kmid + + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dist + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! init + df_value(:,:,:)=0 + + il_shape(:)=SHAPE(dd_value(:,:,:)) + + il_imid=INT(REAL(il_shape(1),sp)*0.5+1,i4) + il_jmid=INT(REAL(il_shape(2),sp)*0.5+1,i4) + il_kmid=INT(REAL(il_shape(3),sp)*0.5+1,i4) + + ALLOCATE( dl_dist(il_shape(1),il_shape(2),il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + + ! compute distance + ! "vertical weight" is lower than horizontal + dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & + & (jj-il_jmid)**2 + & + & 3*(jk-il_kmid)**2 + + IF( dl_dist(ji,jj,jk) /= 0 )THEN + dl_dist(ji,jj,jk)=SQRT( dl_dist(ji,jj,jk) ) + ENDIF + + ENDDO + ENDDO + ENDDO + + WHERE( dl_dist(:,:,:) /= 0 ) + df_value(:,:,:)=1./dl_dist(:,:,:) + END WHERE + + DEALLOCATE( dl_dist ) + + END FUNCTION extrap__3D_dist_weight_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION extrap__3D_dist_weight_fill(dd_value, dd_fill, id_radius, & + & dd_coef) & + & RESULT (df_value) + !------------------------------------------------------------------- + !> @brief + !> This function compute extrapolatd value using inverse distance weighted + !> method + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_value 3D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[in] id_radius radius of the halo used to compute extrapolation + !> @param[in] dd_coef 3D array of coefficient for inverse distance weighted extrapolation + !> @return extrapolatd value + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + INTEGER(i4), INTENT(IN) :: id_radius + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_coef + + ! function + REAL(dp) :: df_value + + ! local variable + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_value + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_coef + + INTEGER(i4) :: il_min + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! init + df_value=dd_fill + + il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2)) + + IF( COUNT(dd_value(:,:,:)/= dd_fill) >= il_min )THEN + + il_shape(:)=SHAPE(dd_value(:,:,:)) + ALLOCATE( dl_value( il_shape(1),il_shape(2),il_shape(3)) ) + ALLOCATE( dl_coef( il_shape(1),il_shape(2),il_shape(3)) ) + + dl_value(:,:,:)=0 + dl_coef(:,:,:)=0 + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + + IF( dd_value(ji,jj,jk) /= dd_fill )THEN + ! compute factor + dl_value(ji,jj,jk)=dd_coef(ji,jj,jk)*dd_value(ji,jj,jk) + dl_coef(ji,jj,jk)=dd_coef(ji,jj,jk) + ENDIF + + ENDDO + ENDDO + ENDDO + + + ! return value + IF( SUM( dl_coef(:,:,:) ) /= 0 )THEN + df_value = SUM( dl_value(:,:,:) )/SUM( dl_coef(:,:,:) ) + ENDIF + + DEALLOCATE( dl_value ) + DEALLOCATE( dl_coef ) + + ENDIF + + END FUNCTION extrap__3D_dist_weight_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE extrap_add_extrabands(td_var, id_isize, id_jsize) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add to the variable (to be extrapolated) an + !> extraband of N points at north,south,east and west boundaries. + !> + !> @details + !> optionaly you could specify size of extra bands in i- and j-direction + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_var variable + !> @param[in] id_isize i-direction size of extra bands (default=im_minext) + !> @param[in] id_jsize j-direction size of extra bands (default=im_minext) + !> @todo + !> - invalid special case for grid with north fold + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_isize + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jsize + + ! local variable + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + INTEGER(i4) :: il_isize + INTEGER(i4) :: il_jsize + INTEGER(i4) :: il_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ij + !---------------------------------------------------------------- + il_isize=im_minext + IF(PRESENT(id_isize)) il_isize=id_isize + IF( il_isize < im_minext .AND. & + & TRIM(td_var%c_interp(1)) == 'cubic' )THEN + CALL logger_warn("EXTRAP ADD EXTRABANDS: size of extrabands "//& + & "should be at least "//TRIM(fct_str(im_minext))//" for "//& + & " cubic interpolation ") + ENDIF + + il_jsize=im_minext + IF(PRESENT(id_jsize)) il_jsize=id_jsize + IF( il_jsize < im_minext .AND. & + & TRIM(td_var%c_interp(1)) == 'cubic' )THEN + CALL logger_warn("EXTRAP ADD EXTRABANDS: size of extrabands "//& + & "should be at least "//TRIM(fct_str(im_minext))//" for "//& + & " cubic interpolation ") + ENDIF + + IF( .NOT. td_var%t_dim(1)%l_use ) il_isize=0 + IF( .NOT. td_var%t_dim(2)%l_use ) il_jsize=0 + + CALL logger_trace( "EXTRAP ADD EXTRABANDS: dimension change "//& + & "in variable "//TRIM(td_var%c_name) ) + + ! add extrabands in variable + ALLOCATE(dl_value( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len )) + + dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) + + + td_var%t_dim(1)%i_len = td_var%t_dim(1)%i_len + 2*il_isize + td_var%t_dim(2)%i_len = td_var%t_dim(2)%i_len + 2*il_jsize + + DEALLOCATE(td_var%d_value) + ALLOCATE( td_var%d_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len ) ) + + ! intialise + td_var%d_value(:,:,:,:)=td_var%d_fill + + ! fill center + td_var%d_value( 1+il_isize:td_var%t_dim(1)%i_len-il_isize, & + & 1+il_jsize:td_var%t_dim(2)%i_len-il_jsize, & + & :,:) = dl_value(:,:,:,:) + + ! special case for overlap + IF( td_var%i_ew >= 0 .AND. il_isize /= 0 )THEN + DO ji=1,il_isize + ! from east to west + il_tmp=td_var%t_dim(1)%i_len-td_var%i_ew+ji-2*il_isize + td_var%d_value(ji,:,:,:) = td_var%d_value(il_tmp,:,:,:) + + ! from west to east + ij=td_var%t_dim(1)%i_len-ji+1 + il_tmp=td_var%i_ew-ji+2*il_isize+1 + td_var%d_value(ij,:,:,:) = td_var%d_value(il_tmp,:,:,:) + ENDDO + ENDIF + + DEALLOCATE( dl_value ) + + END SUBROUTINE extrap_add_extrabands + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE extrap_del_extrabands(td_var, id_isize, id_jsize) + !------------------------------------------------------------------- + !> @brief + !> This subroutine remove of the variable an extraband + !> of N points at north,south,east and west boundaries. + !> + !> @details + !> optionaly you could specify size of extra bands in i- and j-direction + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_var variable + !> @param[in] id_isize i-direction size of extra bands (default=im_minext) + !> @param[in] id_jsize j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_isize + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jsize + + ! local variable + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + INTEGER(i4) :: il_isize + INTEGER(i4) :: il_jsize + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + ! loop indices + !---------------------------------------------------------------- + il_isize=im_minext + IF(PRESENT(id_isize)) il_isize=id_isize + + il_jsize=im_minext + IF(PRESENT(id_jsize)) il_jsize=id_jsize + + IF( .NOT. td_var%t_dim(1)%l_use ) il_isize=0 + IF( .NOT. td_var%t_dim(2)%l_use ) il_jsize=0 + + CALL logger_trace( "EXTRAP DEL EXTRABANDS: dimension change "//& + & "in variable "//TRIM(td_var%c_name) ) + + ! add extrabands in variable + ALLOCATE(dl_value( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len )) + + dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) + + ! fill center + il_imin=1+il_isize + il_imax=td_var%t_dim(1)%i_len-il_isize + + il_jmin=1+il_jsize + il_jmax=td_var%t_dim(2)%i_len-il_jsize + + td_var%t_dim(1)%i_len = td_var%t_dim(1)%i_len - 2*il_isize + td_var%t_dim(2)%i_len = td_var%t_dim(2)%i_len - 2*il_jsize + + DEALLOCATE(td_var%d_value) + ALLOCATE( td_var%d_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len ) ) + + ! intialise + td_var%d_value(:,:,:,:)=td_var%d_fill + + td_var%d_value(:,:,:,:)=dl_value(il_imin:il_imax,& + & il_jmin:il_jmax,& + & :,:) + + DEALLOCATE( dl_value ) + + END SUBROUTINE extrap_del_extrabands + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE extrap diff --git a/V4.0/nemo_sources/tools/SIREN/src/file.f90 b/V4.0/nemo_sources/tools/SIREN/src/file.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d8871ab45853e8e242b3afb1c883a21c3cb44e41 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/file.f90 @@ -0,0 +1,2270 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +!> @brief +!> This module manage file structure. +!> +!> @details +!> define type TFILE:<br/> +!> @code +!> TYPE(TFILE) :: tl_file +!> @endcode +!> +!> to initialize a file structure:<br/> +!> @code +!> tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,cd_grid]) +!% tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,id_ew] [,id_perio] [,id_pivot] [,cd_grid]) +!> @endcode +!> - cd_file is the file name +!> - cd_type is the type of the file ('cdf', 'dimg') [optional] +!> - ld_wrt file in write mode or not [optional] +!% - id_ew is the number of point for east-west overlap [optional] +!% - id_perio is the NEMO periodicity index [optional] +!% - id_pivot is the NEMO pivot point index F(0),T(1) [optional] +!> - cd_grid is the grid type (default 'ARAKAWA-C') +!> +!> to get file name:<br/> +!> - tl_file\%c_name +!> +!> to get file id (units):<br/> +!> - tl_file\%i_id +!> +!> to get the type of the file (cdf, cdf4, dimg):<br/> +!> - tl_file\%c_type +!> +!> to know if file was open in write mode:<br/> +!> - tl_file\%l_wrt +!> +!> to get the record length of the file:<br/> +!> - tl_file\%i_recl +!> +!> Files variables<br/> +!> to get the number of variable in the file:<br/> +!> - tl_file\%i_nvar +!> +!> to get the array of variable structure associated to the file:<br/> +!> - tl_file\%t_var(:) +!> +!> Files attributes<br/> +!> to get the nmber of global attributes of the file:<br/> +!> - tl_file\%i_natt +!> +!> to get the array of attributes structure associated to the file:<br/> +!> - tl_file\%t_att(:) +!> +!> Files dimensions<br/> +!> to get the number of dimension used in the file:<br/> +!> - tl_file\%i_ndim +!> +!> to get the array of dimension structure (4 elts) associated to the +!> file:<br/> +!> - tl_file\%t_dim(:) +!> +!> to print information about file structure:<br/> +!> @code +!> CALL file_print(td_file) +!> @endcode +!> +!> to clean file structure:<br/> +!> @code +!> CALL file_clean(td_file) +!> @endcode +!> +!> to add a global attribute structure in file structure:<br/> +!> @code +!> CALL file_add_att(td_file, td_att) +!> @endcode +!> - td_att is an attribute structure +!> +!> to add a dimension structure in file structure:<br/> +!> @code +!> CALL file_add_dim(td_file, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to add a variable structure in file structure:<br/> +!> @code +!> CALL file_add_var(td_file, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> to delete a global attribute structure in file structure:<br/> +!> @code +!> CALL file_del_att(td_file, td_att) +!> @endcode +!> - td_att is an attribute structure +!> +!> to delete a dimension structure in file structure:<br/> +!> @code +!> CALL file_del_dim(td_file, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to delete a variable structure in file structure:<br/> +!> @code +!> CALL file_del_var(td_file, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> to overwrite one attribute structure in file structure:<br/> +!> @code +!> CALL file_move_att(td_file, td_att) +!> @endcode +!> - td_att is an attribute structure +!> +!> to overwrite one dimension strucutre in file structure:<br/> +!> @code +!> CALL file_move_dim(td_file, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to overwrite one variable structure in file structure:<br/> +!> @code +!> CALL file_move_var(td_file, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> to check if file and variable structure share same dimension:<br/> +!> @code +!> ll_check_dim = file_check_var_dim(td_file, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date November, 2014 +!> - Fix memory leaks bug +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE file + + USE kind ! F90 kind parameter + USE global ! global variable + USE fct ! basic useful function + USE logger ! log file manager + USE dim ! dimension manager + USE att ! attribute manager + USE var ! variable manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TFILE !< file structure + + ! function and subroutine + PUBLIC :: file_copy !< copy file structure + PUBLIC :: file_print !< print information about file structure + PUBLIC :: file_clean !< clean file structure + PUBLIC :: file_init !< initialize file structure + PUBLIC :: file_add_att !< add one attribute structure in file structure + PUBLIC :: file_add_var !< add one variable structure in file structure + PUBLIC :: file_add_dim !< add one dimension strucutre in file structure + PUBLIC :: file_del_att !< delete one attribute structure of file structure + PUBLIC :: file_del_var !< delete one variable structure of file structure + PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure + PUBLIC :: file_move_att !< overwrite one attribute structure in file structure + PUBLIC :: file_move_var !< overwrite one variable structure in file structure + PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure + PUBLIC :: file_check_var_dim !< check if file and variable structure use same dimension. + PUBLIC :: file_get_type !< get type of file + PUBLIC :: file_get_id !< get file id + PUBLIC :: file_rename !< rename file name + PUBLIC :: file_add_suffix !< add suffix to file name + + PRIVATE :: file__clean_unit ! clean file structure + PRIVATE :: file__clean_arr ! clean array of file structure + PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name + PRIVATE :: file__del_var_str ! delete a variable structure in file structure, given variable structure + PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name + PRIVATE :: file__del_att_str ! delete a attribute structure in file structure, given attribute structure + PRIVATE :: file__get_number ! get number in file name without suffix + PRIVATE :: file__get_suffix ! get suffix of file name + PRIVATE :: file__copy_unit ! copy file structure + PRIVATE :: file__copy_arr ! copy array of file structure + PRIVATE :: file__rename_char ! rename file name, given processor number. + PRIVATE :: file__rename_str ! rename file name, given file structure. + + TYPE TFILE !< file structure + + ! general + CHARACTER(LEN=lc) :: c_name = "" !< file name + CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg) + INTEGER(i4) :: i_id = 0 !< file id + LOGICAL :: l_wrt = .FALSE. !< read or write mode + INTEGER(i4) :: i_nvar = 0 !< number of variable + TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables + + CHARACTER(LEN=lc) :: c_grid = 'ARAKAWA-C' !< grid type + + INTEGER(i4) :: i_ew =-1 !< east-west overlap + INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index + INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1) + + INTEGER(i4) :: i_depthid = 0 !< variable id of depth + INTEGER(i4) :: i_timeid = 0 !< variable id of time + + ! netcdf file + INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file + INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file + INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file + LOGICAL :: l_def = .FALSE. !< define mode or not + TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes + TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure + + ! dimg file + INTEGER(i4) :: i_recl = 0 !< record length (binary file) + INTEGER(i4) :: i_n0d = 0 !< number of scalar variable + INTEGER(i4) :: i_n1d = 0 !< number of 1D variable + INTEGER(i4) :: i_n2d = 0 !< number of 2D variable + INTEGER(i4) :: i_n3d = 0 !< number of 3D variable + INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record) + + ! mpp + ! only use for massively parallel processing + INTEGER(i4) :: i_pid = -1 !< processor id (start to 1) + INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom + INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom + INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain + INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain + INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices + INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices + INTEGER(i4) :: i_lei = 0 !< last indoor i-indices + INTEGER(i4) :: i_lej = 0 !< last indoor j-indices + + LOGICAL :: l_ctr = .FALSE. !< domain is on border + LOGICAL :: l_use = .FALSE. !< domain is used + + ! only use to draw domain decomposition when initialize with mpp_init + INTEGER(i4) :: i_iind = 0 !< i-direction indices + INTEGER(i4) :: i_jind = 0 !< j-direction indices + + END TYPE TFILE + + INTERFACE file_clean + MODULE PROCEDURE file__clean_unit + MODULE PROCEDURE file__clean_arr + END INTERFACE file_clean + + INTERFACE file_del_var + MODULE PROCEDURE file__del_var_name + MODULE PROCEDURE file__del_var_str + END INTERFACE file_del_var + + INTERFACE file_del_att + MODULE PROCEDURE file__del_att_name + MODULE PROCEDURE file__del_att_str + END INTERFACE file_del_att + + INTERFACE file_rename + MODULE PROCEDURE file__rename_char + MODULE PROCEDURE file__rename_str + END INTERFACE file_rename + + INTERFACE file_copy + MODULE PROCEDURE file__copy_unit + MODULE PROCEDURE file__copy_arr + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__copy_unit(td_file) & + & RESULT (tf_file) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy file structure in another one + !> @details + !> file variable and attribute value are copied in a temporary array, + !> so input and output file structure value do not point on the same + !> "memory cell", and so on are independant. + !> + !> @note new file is assume to be closed. + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_file=file_copy(file_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + !> @date January, 2019 + !> - clean variable structure + !> + !> @param[in] td_file file structure + !> @return copy of input file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + + ! function + TYPE(TFILE) :: tf_file + + ! local variable + TYPE(TVAR) :: tl_var + TYPE(TATT) :: tl_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) ) + + ! copy file variable + tf_file%c_name = TRIM(td_file%c_name) + tf_file%c_type = TRIM(td_file%c_type) + ! file1 should be closed even if file2 is opened right now + tf_file%i_id = 0 + tf_file%l_wrt = td_file%l_wrt + tf_file%i_nvar = td_file%i_nvar + + tf_file%c_grid = td_file%c_grid + + tf_file%i_ew = td_file%i_ew + tf_file%i_perio= td_file%i_perio + tf_file%i_pivot= td_file%i_pivot + + tf_file%i_depthid = td_file%i_depthid + tf_file%i_timeid = td_file%i_timeid + + ! copy variable structure + IF( ASSOCIATED(tf_file%t_var) )THEN + CALL var_clean(tf_file%t_var(:)) + DEALLOCATE(tf_file%t_var) + ENDIF + IF( ASSOCIATED(td_file%t_var) .AND. tf_file%i_nvar > 0 )THEN + ALLOCATE( tf_file%t_var(tf_file%i_nvar) ) + DO ji=1,tf_file%i_nvar + tl_var = var_copy(td_file%t_var(ji)) + tf_file%t_var(ji) = var_copy(tl_var) + ! clean + CALL var_clean(tl_var) + ENDDO + ENDIF + + ! copy netcdf variable + tf_file%i_ndim = td_file%i_ndim + tf_file%i_natt = td_file%i_natt + tf_file%i_uldid = td_file%i_uldid + tf_file%l_def = td_file%l_def + + ! copy dimension + tf_file%t_dim(:) = dim_copy(td_file%t_dim(:)) + + ! copy attribute structure + IF( ASSOCIATED(tf_file%t_att) )THEN + CALL att_clean(tf_file%t_att(:)) + DEALLOCATE(tf_file%t_att) + ENDIF + IF( ASSOCIATED(td_file%t_att) .AND. tf_file%i_natt > 0 )THEN + ALLOCATE( tf_file%t_att(tf_file%i_natt) ) + DO ji=1,tf_file%i_natt + tl_att = att_copy(td_file%t_att(ji)) + tf_file%t_att(ji) = att_copy(tl_att) + ENDDO + ENDIF + + ! clean + CALL att_clean(tl_att) + + ! copy dimg variable + tf_file%i_recl = td_file%i_recl + tf_file%i_n0d = td_file%i_n0d + tf_file%i_n1d = td_file%i_n1d + tf_file%i_n2d = td_file%i_n2d + tf_file%i_n3d = td_file%i_n3d + tf_file%i_rhd = td_file%i_rhd + + ! copy mpp variable + tf_file%i_pid = td_file%i_pid + tf_file%i_impp = td_file%i_impp + tf_file%i_jmpp = td_file%i_jmpp + tf_file%i_lci = td_file%i_lci + tf_file%i_lcj = td_file%i_lcj + tf_file%i_ldi = td_file%i_ldi + tf_file%i_ldj = td_file%i_ldj + tf_file%i_lei = td_file%i_lei + tf_file%i_lej = td_file%i_lej + tf_file%l_ctr = td_file%l_ctr + tf_file%l_use = td_file%l_use + tf_file%i_iind = td_file%i_iind + tf_file%i_jind = td_file%i_jind + + END FUNCTION file__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__copy_arr(td_file) & + & RESULT (tf_file) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy a array of file structure in another one + !> @details + !> file variable and attribute value are copied in a temporary array, + !> so input and output file structure value do not point on the same + !> "memory cell", and so on are independant. + !> + !> @note new file is assume to be closed. + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_file=file_copy(file_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + !> + !> @param[in] td_file file structure + !> @return copy of input array of file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file + + ! function + TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: tf_file + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_file(:)) + tf_file(ji)=file_copy(td_file(ji)) + ENDDO + + END FUNCTION file__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_init(cd_file, cd_type, ld_wrt, & + & id_ew, id_perio, id_pivot,& + & cd_grid) & + & RESULT (tf_file) + !------------------------------------------------------------------- + !> @brief This function initialize file structure.<br/> + !> @details + !> If cd_type is not specify, check if file name include '.nc' or + !> '.dimg'<br/> + !> Optionally, you could specify:<br/> + !> - write mode (default .FALSE., ld_wrt) + !> - East-West overlap (id_ew) + !> - NEMO periodicity index (id_perio) + !> - NEMO pivot point index F(0),T(1) (id_pivot) + !> - grid type (default: 'ARAKAWA-C') + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_file file name + !> @param[in] cd_type file type ('cdf', 'dimg') + !> @param[in] ld_wrt write mode (default .FALSE.) + !> @param[in] id_ew east-west overlap + !> @param[in] id_perio NEMO periodicity index + !> @param[in] id_pivot NEMO pivot point index F(0),T(1) + !> @param[in] cd_grid grid type (default 'ARAKAWA-C') + !> @return file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type + LOGICAL , INTENT(IN), OPTIONAL :: ld_wrt + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_pivot + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_grid + + ! function + TYPE(TFILE) :: tf_file + + ! local variable + TYPE(TATT) :: tl_att + !---------------------------------------------------------------- + + ! clean file + CALL file_clean(tf_file) + + tf_file%c_name=TRIM(ADJUSTL(cd_file)) + CALL logger_trace("FILE INIT: initialize file "//TRIM(tf_file%c_name)) + + ! check type + IF( PRESENT(cd_type) )THEN + SELECT CASE(TRIM(cd_type)) + CASE('cdf') + tf_file%c_type='cdf' + CASE('dimg') + tf_file%c_type='dimg' + CASE DEFAULT + CALL logger_error( " FILE INIT: can't initialize file "//& + & TRIM(tf_file%c_name)//" : type unknown " ) + END SELECT + ELSE + CALL logger_debug("FILE INIT: look for file type "//TRIM(tf_file%c_name)) + tf_file%c_type=TRIM(file_get_type(cd_file)) + ENDIF + + ! create some global attribute + IF( TRIM(tf_file%c_type) == 'cdf' )THEN + tl_att=att_init("Conventions","CF-1.5") + CALL file_add_att(tf_file,tl_att) + ENDIF + + tl_att=att_init("Grid",TRIM(tf_file%c_grid)) + CALL file_add_att(tf_file,tl_att) + + IF( PRESENT(ld_wrt) )THEN + tf_file%l_wrt=ld_wrt + ENDIF + + IF( PRESENT(id_ew) )THEN + tf_file%i_ew=id_ew + IF( id_ew >= 0 )THEN + tl_att=att_init('ew_overlap',id_ew) + CALL file_move_att(tf_file, tl_att) + ENDIF + ENDIF + + IF( PRESENT(id_perio) )THEN + tf_file%i_perio=id_perio + IF( id_perio >= 0 )THEN + tl_att=att_init('periodicity',id_perio) + CALL file_move_att(tf_file, tl_att) + ENDIF + ENDIF + + IF( PRESENT(id_pivot) )THEN + tf_file%i_pivot=id_pivot + IF( id_pivot > 0 )THEN + tl_att=att_init('pivot_point',id_pivot) + CALL file_move_att(tf_file, tl_att) + ENDIF + ENDIF + + IF( PRESENT(cd_grid) )THEN + tf_file%c_grid=cd_grid + ENDIF + + ! clean + CALL att_clean(tl_att) + + END FUNCTION file_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_get_type(cd_file) & + & RESULT (cf_type) + !------------------------------------------------------------------- + !> @brief + !> This function get type of file, given file name. + !> @details + !> Actually it get suffix of the file name, and compare it to 'nc', 'cdf' or + !> 'dimg'<br/> + !> If no suffix or suffix not identify, we assume file is dimg + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - netcdf4 files identify as netcdf file + !> + !> @param[in] cd_file file name + !> @return type of file + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + + ! function + CHARACTER(LEN=lc) :: cf_type + + !local variable + CHARACTER(LEN=lc) :: cl_suffix + !---------------------------------------------------------------- + + cl_suffix=file__get_suffix(cd_file) + SELECT CASE( TRIM(fct_lower(cl_suffix)) ) + CASE('.nc','.cdf','.nc4') + CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf") + ! Warning : type could be change to cdf4 when opening file. + cf_type='cdf' + CASE('.dimg') + CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" ) + cf_type='dimg' + CASE DEFAULT + CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//& + & TRIM(cd_file)//" is dimg ") + cf_type='dimg' + END SELECT + + END FUNCTION file_get_type + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_check_var_dim(td_file, td_var, ld_chklen) & + & RESULT (lf_dim) + !------------------------------------------------------------------- + !> @brief This function check that variable dimension to be used + !> of both variable and file structure are convenient (axis, length). + ! + !> @details + !> optionaly you could choose to not check length + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2017 + !> - add option to not check dimension length + ! + !> @param[in] td_file file structure + !> @param[in] td_var variable structure + !> @param[in] ld_chklen check length + !> @return true if dimension of variable and file structure agree + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + TYPE(TVAR), INTENT(IN) :: td_var + LOGICAL, INTENT(IN), OPTIONAL :: ld_chklen + + ! function + LOGICAL :: lf_dim + + ! local variable + CHARACTER(LEN=lc) :: cl_dim + LOGICAL :: ll_error + LOGICAL :: ll_warn + LOGICAL :: ll_chklen + LOGICAL :: ll_use + LOGICAL :: ll_len + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_dim=.TRUE. + + CALL logger_debug( " FILE CHECK VAR DIM: check: "//TRIM(td_var%c_name) ) + ! check dimension length + ll_chklen=.TRUE. + IF( PRESENT(ld_chklen) ) ll_chklen=ld_chklen + + ! check used dimension + ll_error=.FALSE. + ll_warn=.FALSE. + DO ji=1,ip_maxdim + il_ind=dim_get_index( td_file%t_dim(:), & + & TRIM(td_var%t_dim(ji)%c_name), & + & TRIM(td_var%t_dim(ji)%c_sname)) + + IF( il_ind /= 0 )THEN + ll_use=(td_var%t_dim(ji)%l_use .AND. td_file%t_dim(il_ind)%l_use) + + ll_len=.TRUE. + IF( ll_chklen )THEN + ! check dimension length + ll_len=(td_var%t_dim(ji)%i_len == td_file%t_dim(il_ind)%i_len) + ENDIF + IF( ll_use .AND. .NOT. ll_len )THEN + IF( INDEX( TRIM(td_var%c_axis), & + & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN + ll_warn=.TRUE. + ELSE + ll_error=.TRUE. + ENDIF + ENDIF + ENDIF + ENDDO + + IF( ll_error )THEN + + cl_dim='(/' + DO ji = 1, td_file%i_ndim + IF( td_file%t_dim(ji)%l_use )THEN + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_upper(td_file%t_dim(ji)%c_sname))//':'//& + & TRIM(fct_str(td_file%t_dim(ji)%i_len))//',' + ENDIF + ENDDO + cl_dim=TRIM(cl_dim)//'/)' + CALL logger_debug( " file dimension: "//TRIM(cl_dim) ) + + cl_dim='(/' + DO ji = 1, td_var%i_ndim + IF( td_var%t_dim(ji)%l_use )THEN + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& + & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' + ENDIF + ENDDO + cl_dim=TRIM(cl_dim)//'/)' + CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) + + lf_dim=.FALSE. + + CALL logger_error( & + & " FILE CHECK VAR DIM: variable and file dimension differ"//& + & " for variable "//TRIM(td_var%c_name)//& + & " and file "//TRIM(td_file%c_name)) + + ELSEIF( ll_warn )THEN + CALL logger_warn( & + & " FILE CHECK VAR DIM: variable and file dimension differ"//& + & " for variable "//TRIM(td_var%c_name)//& + & " and file "//TRIM(td_file%c_name)//". you should use"//& + & " var_check_dim to remove useless dimension.") + ELSE + + IF( td_var%i_ndim > td_file%i_ndim )THEN + CALL logger_info("FILE CHECK VAR DIM: variable "//& + & TRIM(td_var%c_name)//" use more dimension than file "//& + & TRIM(td_file%c_name)//" do until now.") + ENDIF + + ENDIF + + END FUNCTION file_check_var_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_add_var(td_file, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine add a variable structure in a file structure.<br/> + !> Do not overwrite, if variable already in file structure. + ! + !> @note variable value is suppose to be ordered ('x','y','z','t') + ! + !> @details + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - add dimension in file if need be + !> - do not reorder dimension from variable, before put in file + !> @date September, 2015 + !> - check variable dimension expected + !> @date January, 2019 + !> - clean variable structure + !> + !> @param[inout] td_file file structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TVAR) , INTENT(INOUT) :: td_var + + ! local variable + INTEGER(i4) :: il_status + !INTEGER(i4) :: il_rec + INTEGER(i4) :: il_ind + + TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//& + & "running file_add_var" ) + CALL logger_error( " FILE ADD VAR: structure file unknown" ) + + ELSE + ! check if variable exist + IF( TRIM(td_var%c_name) == '' .AND. & + & TRIM(td_var%c_stdname) == '' )THEN + CALL logger_error(" FILE ADD VAR: variable without name ") + ELSE + ! check if variable already in file structure + il_ind=0 + IF( ASSOCIATED(td_file%t_var) )THEN + il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & + & td_var%c_stdname ) + ENDIF + CALL logger_debug( & + & " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) ) + IF( il_ind /= 0 )THEN + + CALL logger_error( & + & " FILE ADD VAR: variable "//TRIM(td_var%c_name)//& + & ", standard name "//TRIM(td_var%c_stdname)//& + & ", already in file "//TRIM(td_file%c_name) ) + + DO ji=1,td_file%i_nvar + CALL logger_debug( " ADD VAR: in file : & + & variable "//TRIM(td_file%t_var(ji)%c_name)//& + & ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) ) + ENDDO + + ELSE + + CALL logger_debug( & + & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//& + & ", standard name "//TRIM(td_var%c_stdname)//& + & ", in file "//TRIM(td_file%c_name) ) + + ! check used dimension + IF( file_check_var_dim(td_file, td_var) )THEN + + ! check variable dimension expected + CALL var_check_dim(td_var) + + ! update dimension if need be + DO ji=1,ip_maxdim + IF( td_var%t_dim(ji)%l_use .AND. & + & .NOT. td_file%t_dim(ji)%l_use )THEN + CALL file_add_dim(td_file,td_var%t_dim(ji)) + ENDIF + ENDDO + + ! get index of new variable + SELECT CASE(td_var%i_ndim) + CASE(0) + il_ind=td_file%i_n0d+1 + !il_rec=0 + CASE(1) + il_ind=td_file%i_n0d+td_file%i_n1d+1 + !il_rec=1 + CASE(2) + il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1 + !il_rec=1 + CASE(3,4) + il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1 + !il_rec=td_file%t_dim(3)%i_len + END SELECT + + IF( td_file%i_nvar > 0 )THEN + ! already other variable in file structure + ALLOCATE( tl_var(td_file%i_nvar), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD VAR: not enough space to put variables "//& + & "from "//TRIM(td_file%c_name)//& + & " in variable structure") + + ELSE + + ! save temporary variable of file structure + tl_var(:)=var_copy(td_file%t_var(:)) + + CALL var_clean( td_file%t_var(:) ) + DEALLOCATE(td_file%t_var) + ALLOCATE( td_file%t_var(td_file%i_nvar+1), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD VAR: not enough space to put variable "//& + & "in file structure "//TRIM(td_file%c_name) ) + + ENDIF + + ! copy variable in file before + ! variable with less than or equal dimension that new variable + IF( il_ind > 1 )THEN + td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1)) + ENDIF + + IF( il_ind < td_file%i_nvar+1 )THEN + ! variable with more dimension than new variable + td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & + & var_copy( tl_var(il_ind : td_file%i_nvar) ) + ENDIF + + ! clean + CALL var_clean(tl_var(:)) + ENDIF + DEALLOCATE(tl_var) + + ELSE + ! no variable in file structure + IF( ASSOCIATED(td_file%t_var) )THEN + CALL var_clean(td_file%t_var(:)) + DEALLOCATE(td_file%t_var) + ENDIF + ALLOCATE( td_file%t_var(td_file%i_nvar+1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD VAR: not enough space to put variable "//& + & "in file structure "//TRIM(td_file%c_name) ) + + ENDIF + + ENDIF + + ! add new variable in array of variable + ALLOCATE( tl_var(1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD VAR: not enough space to put variables from "//& + & TRIM(td_var%c_name)//" in variable structure") + + ELSE + tl_var(1)=var_copy(td_var) + ! remove old id + tl_var(1)%i_id=0 + + ! update dimension name in new variable + tl_var(1)%t_dim(:)%c_name = td_file%t_dim(:)%c_name + + ! add new variable + td_file%t_var(il_ind)=var_copy(tl_var(1)) + + ! update number of variable + td_file%i_nvar=td_file%i_nvar+1 + SELECT CASE(tl_var(1)%i_ndim) + CASE(0) + td_file%i_n0d=td_file%i_n0d+1 + CASE(1) + td_file%i_n1d=td_file%i_n1d+1 + CASE(2) + td_file%i_n2d=td_file%i_n2d+1 + CASE(3,4) + td_file%i_n3d=td_file%i_n3d+1 + END SELECT + + ! update variable id + td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:)) + + ! update dimension used + td_file%t_dim(:)%l_use=.FALSE. + DO ji=1,ip_maxdim + IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN + td_file%t_dim(ji)%l_use=.TRUE. + ENDIF + ENDDO + + ! update number of dimension + td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) + + ! clean + CALL var_clean( tl_var(:) ) + ENDIF + DEALLOCATE(tl_var) + + ENDIF + ENDIF + ENDIF + ENDIF + + END SUBROUTINE file_add_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__del_var_name(td_file, cd_name) + !------------------------------------------------------------------- + !> @brief This subroutine delete a variable structure + !> in file structure, given variable name or standard name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - define local variable structure to avoid mistake with pointer + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name variable name or standard name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + + ! local variable + INTEGER(i4) :: il_ind + TYPE(TVAR) :: tl_var + !---------------------------------------------------------------- + + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE DEL VAR NAME: file structure unknown ") + CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//& + & "running file_del_var" ) + + ELSE + + IF( td_file%i_nvar /= 0 )THEN + + ! get the variable index, in file variable structure + il_ind=0 + IF( ASSOCIATED(td_file%t_var) )THEN + il_ind=var_get_index(td_file%t_var(:), cd_name ) + ENDIF + + IF( il_ind /= 0 )THEN + + tl_var=var_copy(td_file%t_var(il_ind)) + CALL file_del_var(td_file, tl_var) + ! clean + CALL var_clean(tl_var) + ELSE + + CALL logger_debug( & + & " FILE DEL VAR NAME: there is no variable with name or "//& + & "standard name "//TRIM(cd_name)//" in file "//& + & TRIM(td_file%c_name)) + + ENDIF + + ELSE + CALL logger_debug( " FILE DEL VAR NAME: "//& + & "no variable associated to file "//& + & TRIM(td_file%c_name) ) + ENDIF + + ENDIF + + END SUBROUTINE file__del_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__del_var_str(td_file, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine delete a variable structure + !> in file structure, given variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - clean variable structure + !> + !> @param[inout] td_file file structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TVAR), INTENT(IN) :: td_var + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_rec + TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE DEL VAR: file structure unknown ") + CALL logger_debug( " FILE DEL VAR: you should have used "//& + & "file_init before running file_del_var" ) + + ELSE + + ! check if variable is member of a file + IF( td_var%l_file )THEN + CALL logger_warn( & + & " FILE DEL VAR: variable "//TRIM(td_var%c_name)//& + & ", belong to file "//TRIM(td_file%c_name)//& + & " and can not be removed.") + ELSE + ! check if variable already in file structure + il_ind=0 + IF( ASSOCIATED(td_file%t_var) )THEN + il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & + & td_var%c_stdname ) + ENDIF + + IF( il_ind == 0 )THEN + + CALL logger_warn( "FILE DEL VAR: no variable "//& + & TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) ) + + DO ji=1,td_file%i_nvar + CALL logger_debug( "FILE DEL VAR: in file "//& + & TRIM(td_file%t_var(ji)%c_name)//", standard name "//& + & TRIM(td_file%t_var(ji)%c_stdname) ) + ENDDO + + ELSE + + CALL logger_trace( "FILE DEL VAR: delete variable "//& + & TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) ) + + ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE DEL VAR: not enough space to put variables from "//& + & TRIM(td_file%c_name)//" in temporary variable structure") + + ELSE + + ! save temporary variable's file structure + IF( il_ind > 1 )THEN + tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1)) + ENDIF + + IF( il_ind < td_file%i_nvar )THEN + tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:)) + ENDIF + + ! new number of variable in file + td_file%i_nvar=td_file%i_nvar-1 + SELECT CASE(td_var%i_ndim) + CASE(0) + td_file%i_n0d=td_file%i_n0d-1 + il_rec=0 + CASE(1) + td_file%i_n1d=td_file%i_n1d-1 + il_rec=1 + CASE(2) + td_file%i_n2d=td_file%i_n2d-1 + il_rec=1 + CASE(3,4) + td_file%i_n3d=td_file%i_n3d-1 + il_rec=td_file%t_dim(3)%i_len + END SELECT + + CALL var_clean( td_file%t_var(:) ) + DEALLOCATE(td_file%t_var) + + IF( td_file%i_nvar > 0 )THEN + ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( " FILE DEL VAR: not enough space"//& + & "to put variables in file structure "//& + & TRIM(td_file%c_name) ) + + ENDIF + + ! copy attribute in file before + td_file%t_var(:)=var_copy(tl_var(:)) + + ! update dimension used + td_file%t_dim(:)%l_use=.FALSE. + DO ji=1,ip_maxdim + IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN + td_file%t_dim(ji)%l_use=.TRUE. + ENDIF + ENDDO + + ! update number of dimension + td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) + + ENDIF + + ! clean + CALL var_clean(tl_var(:)) + ENDIF + DEALLOCATE(tl_var) + + ENDIF + ENDIF + ENDIF + + END SUBROUTINE file__del_var_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_move_var(td_file, td_var) + !------------------------------------------------------------------- + !> @brief This subroutine overwrite variable structure + !> in file structure. + ! + !> @warning change variable id in file structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_file file structure + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TVAR), INTENT(IN) :: td_var + + ! local variable + TYPE(TVAR) :: tl_var + !---------------------------------------------------------------- + + ! copy variable + tl_var=var_copy(td_var) + + ! remove variable with same name or standard name + CALL file_del_var(td_file, tl_var) + + ! add new variable + CALL file_add_var(td_file, tl_var) + + ! clean + CALL var_clean(tl_var) + + END SUBROUTINE file_move_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_add_att(td_file, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine add a global attribute + !> in a file structure.<br/> + !> Do not overwrite, if attribute already in file structure. + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - clean attribute structure + !> + !> @param[inout] td_file file structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE ADD ATT: file structure unknown ") + CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//& + & "running file_add_att" ) + + ELSE + + ! check if attribute already in file structure + il_ind=0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) + ENDIF + + IF( il_ind /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//& + & ", already in file "//TRIM(td_file%c_name) ) + + DO ji=1,td_file%i_natt + CALL logger_debug( & + & " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) ) + ENDDO + + ELSE + + CALL logger_trace( & + & " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//& + & ", in file "//TRIM(td_file%c_name) ) + + IF( td_file%i_natt > 0 )THEN + ! already other attribute in file structure + ALLOCATE( tl_att(td_file%i_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: not enough space to put attributes from "//& + & TRIM(td_file%c_name)//" in temporary attribute structure") + + ELSE + + ! save temporary global attribute's file structure + tl_att(:)=att_copy(td_file%t_att(:)) + + CALL att_clean( td_file%t_att(:) ) + DEALLOCATE(td_file%t_att) + ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: not enough space to put attributes "//& + & "in file structure "//TRIM(td_file%c_name) ) + + ENDIF + + ! copy attribute in file before + td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) + + ! clean + CALL att_clean(tl_att(:)) + ENDIF + DEALLOCATE(tl_att) + + ELSE + ! no attribute in file structure + IF( ASSOCIATED(td_file%t_att) )THEN + CALL att_clean(td_file%t_att(:)) + DEALLOCATE(td_file%t_att) + ENDIF + + ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: not enough space to put attributes "//& + & "in file structure "//TRIM(td_file%c_name) ) + + ENDIF + ENDIF + ! add new attribute + td_file%t_att(td_file%i_natt+1)=att_copy(td_att) + + ! update number of attribute + td_file%i_natt=td_file%i_natt+1 + ENDIF + ENDIF + + END SUBROUTINE file_add_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__del_att_name(td_file, cd_name) + !------------------------------------------------------------------- + !> @brief This subroutine delete a global attribute structure + !> in file structure, given attribute name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - define local attribute structure to avoid mistake + !> with pointer + !> @date January, 2019 + !> - clean attribute structure + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name attribute name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + + ! local variable + INTEGER(i4) :: il_ind + TYPE(TATT) :: tl_att + !---------------------------------------------------------------- + + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE DEL ATT NAME: file structure unknown ") + CALL logger_debug( " FILE DEL ATT NAME: you should have "//& + & "used file_init before running file_del_att" ) + + ELSE + + IF( td_file%i_natt /= 0 )THEN + + ! get the variable id, in file variable structure + il_ind=0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_ind=att_get_index(td_file%t_att(:), cd_name ) + ENDIF + + IF( il_ind /= 0 )THEN + + tl_att=att_copy(td_file%t_att(il_ind)) + CALL file_del_att(td_file, tl_att) + ! clean + CALL att_clean(tl_att) + ELSE + + CALL logger_debug( & + & " FILE DEL ATT NAME: there is no attribute with name "//& + & TRIM(cd_name)//" in file "//TRIM(td_file%c_name)) + + ENDIF + + ELSE + CALL logger_debug( " FILE DEL ATT NAME: no attribute "//& + & "associated to file "//TRIM(td_file%c_name) ) + ENDIF + + ENDIF + + END SUBROUTINE file__del_att_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__del_att_str(td_file, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine delete a global attribute structure + !> from file structure, given attribute structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - clean attribute structure + !> + !> @param[inout] td_file file structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE DEL ATT: file structure unknown ") + CALL logger_debug( " FILE DEL ATT: you should have used "//& + & "file_init before running file_del_att" ) + + ELSE + + ! check if attribute already in file structure + il_ind=0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) + ENDIF + + IF( il_ind == 0 )THEN + + CALL logger_error( & + & " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//& + & ", in file "//TRIM(td_file%c_name) ) + + ELSE + + CALL logger_trace( & + & " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//& + & ", in file "//TRIM(td_file%c_name) ) + + ALLOCATE( tl_att(td_file%i_natt-1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: not enough space to put attributes from "//& + & TRIM(td_file%c_name)//" in temporary attribute structure") + + ELSE + + ! save temporary global attribute's file structure + IF( il_ind > 1 )THEN + tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1)) + ENDIF + + IF( il_ind < td_file%i_natt )THEN + tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:)) + ENDIF + + CALL att_clean( td_file%t_att(:) ) + DEALLOCATE(td_file%t_att) + + ! new number of attribute in file + td_file%i_natt=td_file%i_natt-1 + + ALLOCATE( td_file%t_att(td_file%i_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " FILE ADD ATT: not enough space to put attributes "//& + & "in file structure "//TRIM(td_file%c_name) ) + + ENDIF + + ! copy attribute in file before + td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) + + ! clean + CALL att_clean(tl_att(:)) + ENDIF + DEALLOCATE(tl_att) + + ENDIF + ENDIF + + END SUBROUTINE file__del_att_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_move_att(td_file, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine move a global attribute structure + !> from file structure. + !> @warning change attribute id in file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + TYPE(TATT) :: tl_att + INTEGER(i4) :: il_ind + !---------------------------------------------------------------- + + ! copy attribute + tl_att=att_copy(td_att) + + IF( ASSOCIATED(td_file%t_att) )THEN + il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name)) + IF( il_ind /= 0 )THEN + ! remove attribute with same name + CALL file_del_att(td_file, tl_att) + ENDIF + ENDIF + + ! add new attribute + CALL file_add_att(td_file, tl_att) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE file_move_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_add_dim(td_file, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine add a dimension structure in file + !> structure. + !> Do not overwrite, if dimension already in file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - do not reorder dimension, before put in file + !> + !> @param[inout] td_file file structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE ADD DIM: file structure unknown ") + CALL logger_debug( " FILE ADD DIM: you should have used "//& + & "file_init before running file_add_dim" ) + + ELSE + + IF( td_file%i_ndim <= ip_maxdim )THEN + + ! check if dimension already in file structure + il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) + IF( il_ind /= 0 )THEN + IF( td_file%t_dim(il_ind)%l_use )THEN + CALL logger_error( & + & "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", already used in file "//TRIM(td_file%c_name) ) + ELSE + ! replace dimension + td_file%t_dim(il_ind)=dim_copy(td_dim) + td_file%t_dim(il_ind)%i_id=il_ind + td_file%t_dim(il_ind)%l_use=.TRUE. + ENDIF + ELSE + IF( td_file%i_ndim == ip_maxdim )THEN + CALL logger_error( & + & "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", in file "//TRIM(td_file%c_name)//". Already "//& + & TRIM(fct_str(ip_maxdim))//" dimensions." ) + ELSE + ! search empty dimension + DO ji=1,ip_maxdim + IF( td_file%t_dim(ji)%i_id == 0 )THEN + il_ind=ji + EXIT + ENDIF + ENDDO + + ! add new dimension + td_file%t_dim(il_ind)=dim_copy(td_dim) + ! update number of attribute + td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) + + td_file%t_dim(il_ind)%i_id=td_file%i_ndim + td_file%t_dim(il_ind)%l_use=.TRUE. + ENDIF + ENDIF + + ELSE + CALL logger_error( & + & " FILE ADD DIM: too much dimension in file "//& + & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") + ENDIF + + ENDIF + + END SUBROUTINE file_add_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_del_dim(td_file, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine delete a dimension structure in file + !> structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - clean dimension structure + !> + !> @param[inout] td_file file structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + + TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( TRIM(td_file%c_name) == '' )THEN + + CALL logger_error( " FILE DEL DIM: file structure unknown ") + CALL logger_debug( " FILE DEL DIM: you should have used "//& + & "file_init before running file_del_dim" ) + + ELSE + + ! check if dimension already in file structure + il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) + IF( il_ind == 0 )THEN + + CALL logger_error( & + & "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", in file "//TRIM(td_file%c_name) ) + + ELSE + ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & "FILE DEL DIM: not enough space to put dimensions from "//& + & TRIM(td_file%c_name)//" in temporary dimension structure") + + ELSE + ! save temporary dimension's mpp structure + tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1)) + tl_dim( il_ind : td_file%i_ndim-1 ) = & + & dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim)) + + ! remove dimension from file + CALL dim_clean(td_file%t_dim(:)) + ! copy dimension in file, except one + td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:)) + + ! update number of dimension + td_file%i_ndim=td_file%i_ndim-1 + + ! update dimension id + DO ji=1,td_file%i_ndim + td_file%t_dim(ji)%i_id=ji + ENDDO + + ! clean + CALL dim_clean(tl_dim(:)) + ENDIF + DEALLOCATE(tl_dim) + + ENDIF + ENDIF + + END SUBROUTINE file_del_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_move_dim(td_file, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine move a dimension structure + !> in file structure. + !> @warning change dimension order in file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_dimid + !---------------------------------------------------------------- + IF( td_file%i_ndim <= ip_maxdim )THEN + + ! check if dimension already in mpp structure + il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname) + IF( il_ind /= 0 )THEN + + il_dimid=td_file%t_dim(il_ind)%i_id + ! replace dimension + td_file%t_dim(il_ind)=dim_copy(td_dim) + td_file%t_dim(il_ind)%i_id=il_dimid + td_file%t_dim(il_ind)%l_use=.TRUE. + + ELSE + CALL file_add_dim(td_file, td_dim) + ENDIF + + ELSE + CALL logger_error( & + & "FILE MOVE DIM: too much dimension in mpp "//& + & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") + ENDIF + + END SUBROUTINE file_move_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file_print(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine print some information about file strucutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + + ! local variable + CHARACTER(LEN=lc) :: cl_mode + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + cl_mode='READ' + IF( td_file%l_wrt ) cl_mode='WRITE' + + WRITE(*,'((a,a),2(/3x,a,a),4(/3x,a,i0))')& + & "File : ",TRIM(td_file%c_name), & + & " type : ",TRIM(td_file%c_type), & + & " mode : ",TRIM(cl_mode), & + & " id : ",td_file%i_id, & + & " ndim : ",td_file%i_ndim, & + & " natt : ",td_file%i_natt, & + & " nvar : ",td_file%i_nvar + + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + WRITE(*,'((/3x,a,a),(/3x,a,i3))')& + & "define mode : ",TRIM(fct_str(td_file%l_def)),& + & "unlimited id : ",td_file%i_uldid + CASE('dimg') + WRITE(*,'(5(/3x,a,i0))')& + & " record length : ",td_file%i_recl, & + & " n0d : ",td_file%i_n0d, & + & " n1d : ",td_file%i_n1d, & + & " n2d : ",td_file%i_n2d, & + & " n3d : ",td_file%i_n3d + END SELECT + + ! print dimension + IF( td_file%i_ndim /= 0 )THEN + WRITE(*,'(/a)') " File dimension" + DO ji=1,ip_maxdim + IF( td_file%t_dim(ji)%l_use )THEN + CALL dim_print(td_file%t_dim(ji)) + ENDIF + ENDDO + ENDIF + + ! print global attribute + IF( td_file%i_natt /= 0 )THEN + WRITE(*,'(/a)') " File attribute" + DO ji=1,td_file%i_natt + CALL att_print(td_file%t_att(ji)) + ENDDO + ENDIF + + ! print variable + IF( td_file%i_nvar /= 0 )THEN + WRITE(*,'(/a)') " File variable" + DO ji=1,td_file%i_nvar + CALL var_print(td_file%t_var(ji),.FALSE.) + ENDDO + ENDIF + + END SUBROUTINE file_print + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__get_suffix(cd_file) & + & RESULT (cf_suffix) + !------------------------------------------------------------------- + !> @brief This function get suffix of file name. + !> @details + !> we assume suffix is define as alphanumeric character following the + !> last '.' in file name.<br/> + !> If no suffix is found, return empty character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_file file structure + !> @return suffix + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + + ! function + CHARACTER(LEN=lc) :: cf_suffix + + ! local variable + INTEGER(i4) :: il_ind + !---------------------------------------------------------------- + + CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//& + & TRIM(cd_file) ) + + il_ind=INDEX(TRIM(cd_file),'.',BACK=.TRUE.) + IF( il_ind /= 0 )THEN + ! read number in basename + READ( cd_file(il_ind:),'(a)' ) cf_suffix + + IF( fct_is_num(cf_suffix(2:)) )THEN + cf_suffix='' + ENDIF + + ELSE + cf_suffix='' + ENDIF + + END FUNCTION file__get_suffix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__get_number(cd_file) & + & RESULT (cf_number) + !------------------------------------------------------------------- + !> @brief This function get number in file name without suffix. + !> @details + !> Actually it get the number following the last separator. + !> separator could be '.' or '_'. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - add case to not return date (yyyymmdd) at the end of filename + !> @date February, 2015 + !> - add case to not return release number + !> we assume release number only on one digit (ex : file_v3.5.nc) + !> + !> @param[in] cd_file file name (without suffix) + !> @return character file number. + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=lc), INTENT(IN) :: cd_file + + ! function + CHARACTER(LEN=lc) :: cf_number + + ! local variable + INTEGER(i4) :: il_indmax + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! get number position in file name + il_indmax=0 + DO ji=1,ip_nsep + il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.) + IF( il_ind > il_indmax )THEN + il_indmax=il_ind + ENDIF + ENDDO + + IF( il_indmax /= 0 )THEN + ! read number in basename + READ( cd_file(il_indmax:),'(a)' ) cf_number + + IF( .NOT. fct_is_num(cf_number(2:)) )THEN + cf_number='' + ELSEIF( LEN(TRIM(cf_number))-1 == 8 )THEN + ! date case yyyymmdd + cf_number='' + ELSEIF( LEN(TRIM(cf_number))-1 == 1 )THEN + ! release number case + cf_number='' + ENDIF + ELSE + cf_number='' + ENDIF + + END FUNCTION file__get_number + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__rename_char(cd_file, id_num) & + & RESULT (cf_file) + !------------------------------------------------------------------- + !> @brief This function rename file name, given processor number. + !> @details + !> If no processor number is given, return file name without number + !> If processor number is given, return file name with new number + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_num processor number (start to 1) + !> @return file name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + INTEGER(i4), INTENT(IN), OPTIONAL :: id_num + + ! function + CHARACTER(LEN=lc) :: cf_file + + ! local variable + CHARACTER(LEN=lc) :: cl_suffix + CHARACTER(LEN=lc) :: cl_file + CHARACTER(LEN=lc) :: cl_number + CHARACTER(LEN=lc) :: cl_base + CHARACTER(LEN=lc) :: cl_sep + CHARACTER(LEN=lc) :: cl_format + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_numlen + !---------------------------------------------------------------- + + ! get suffix + cl_suffix=file__get_suffix(cd_file) + IF( TRIM(cl_suffix) /= '' )THEN + il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.) + cl_file=TRIM(cd_file(:il_ind-1)) + ELSE + cl_file=TRIM(cd_file) + ENDIF + + cl_number=file__get_number(cl_file) + IF( TRIM(cl_number) /= '' )THEN + il_ind=INDEX(TRIM(cl_file),TRIM(cl_number(1:1)),BACK=.TRUE.) + cl_base=TRIM(cl_file(:il_ind-1)) + + cl_sep=TRIM(cl_number(1:1)) + il_numlen=LEN(TRIM(cl_number))-1 + ELSE + cl_base=TRIM(cl_file) + il_numlen=4 + cl_sep='_' + ENDIF + + IF( PRESENT(id_num) )THEN + ! format + WRITE(cl_format,'(a,i1.1,a,i1.1,a)') '(a,a,i',il_numlen,'.',il_numlen,',a)' + WRITE(cf_file,cl_format) TRIM(cl_base),TRIM(cl_sep),id_num,TRIM(cl_suffix) + ELSE + WRITE(cf_file,'(a,a)') TRIM(cl_base),TRIM(cl_suffix) + ENDIF + CALL logger_trace(" FILE RENAME : "//TRIM(cf_file)) + + END FUNCTION file__rename_char + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file__rename_str(td_file, id_num) & + & RESULT (tf_file) + !------------------------------------------------------------------- + !> @brief This function rename file name, given file structure. + !> @details + !> If no processor number is given, return file name without number + !> I processor number is given, return file name with new number + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_num processor number (start to 1) + !> @return file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN), OPTIONAL :: id_num + + ! function + TYPE(TFILE) :: tf_file + + ! local variable + CHARACTER(LEN=lc) :: cl_name + !---------------------------------------------------------------- + + ! change name + cl_name=TRIM( file_rename(td_file%c_name, id_num) ) + + tf_file=file_init(TRIM(cl_name), TRIM(td_file%c_type)) + + END FUNCTION file__rename_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_add_suffix(cd_file, cd_type) & + & RESULT (cf_file) + !------------------------------------------------------------------- + !> @brief This function add suffix to file name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @return file name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + CHARACTER(LEN=*), INTENT(IN) :: cd_type + + ! function + CHARACTER(LEN=lc) :: cf_file + + ! local variable + INTEGER(i4) :: il_ind + CHARACTER(LEN=lc) :: cl_file + CHARACTER(LEN=lc) :: cl_suffix + !---------------------------------------------------------------- + + ! get suffix + cl_suffix=file__get_suffix(cd_file) + IF( TRIM(cl_suffix) /= '' )THEN + il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.) + cl_file=TRIM(cd_file(:il_ind-1)) + ELSE + cl_file=TRIM(cd_file) + ENDIF + + SELECT CASE(TRIM(cd_type)) + CASE('cdf') + cf_file=TRIM(cl_file)//TRIM(cl_suffix) + CASE('dimg') + IF( TRIM(cl_suffix) /= '' )THEN + cf_file=TRIM(cl_file)//'.dimg' + ELSE + cf_file=TRIM(cl_file) + ENDIF + CASE DEFAULT + CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type)) + END SELECT + + END FUNCTION file_add_suffix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__clean_unit(td_file) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean file strcuture. + !> + !> @author J.Paul + !> @date November, 2013 - Inital version + !> @date January, 2019 + !> - nullify attribute structure inside file structure + !> - nullify variable structure inside file structure + !> + !> @param[inout] td_file file strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + TYPE(TFILE) :: tl_file ! empty file structure + + ! loop indices + !---------------------------------------------------------------- + + CALL logger_trace( & + & " FILE CLEAN: reset file "//TRIM(td_file%c_name) ) + + ! del attribute + IF( ASSOCIATED( td_file%t_att ) )THEN + CALL att_clean( td_file%t_att(:) ) + DEALLOCATE(td_file%t_att) + NULLIFY(td_file%t_att) + ENDIF + + ! del dimension + IF( td_file%i_ndim /= 0 )THEN + CALL dim_clean( td_file%t_dim(:) ) + ENDIF + + ! del variable + IF( ASSOCIATED( td_file%t_var ) )THEN + CALL var_clean( td_file%t_var(:) ) + DEALLOCATE(td_file%t_var) + NULLIFY(td_file%t_var) + ENDIF + + ! replace by empty structure + td_file=file_copy(tl_file) + + END SUBROUTINE file__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE file__clean_arr(td_file) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean file array of file strcuture. + !> + !> @author J.Paul + !> @date Marsh, 2014 - Inital version + !> + !> @param[inout] td_file array file strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_file(:)),1,-1 + CALL file_clean(td_file(ji)) + ENDDO + + END SUBROUTINE file__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_get_id(td_file, cd_name) & + & RESULT (if_id) + !------------------------------------------------------------------- + !> @brief This function return the file id, in a array of file + !> structure, given file name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file array of file structure + !> @param[in] cd_name file name + !> @return file id in array of file structure (0 if not found) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , DIMENSION(:), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + INTEGER(i4) :: if_id + + ! local variable + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + if_id=0 + il_size=SIZE(td_file(:)) + + ! check if file is in array of file structure + DO ji=1,il_size + ! look for file name + IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN + + if_id=td_file(ji)%i_id + EXIT + + ENDIF + ENDDO + + END FUNCTION file_get_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION file_get_unit(td_file) & + & RESULT (if_unit) + !------------------------------------------------------------------- + !> @brief + !> This function get the next unused unit in array of file structure. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] td_file array of file + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file + + ! function + INTEGER(i4) :: if_unit + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + if_unit=MAXVAL(td_file(:)%i_id)+1 + + END FUNCTION file_get_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE file + diff --git a/V4.0/nemo_sources/tools/SIREN/src/filter.f90 b/V4.0/nemo_sources/tools/SIREN/src/filter.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9ac2d08d73d84f2ef742bbefc3e778acd10cc4bb --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/filter.f90 @@ -0,0 +1,1322 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module is filter manager. +!> +!> @details Filtering method to be used is specify inside variable strcuture, +!> as array of string character.<br/> +!> td_var\%c_filter(1) string character is the filter name choose between:<br/> +!> - 'hann' +!> - rad < cutoff : @f$ filter=0.5+0.5*COS(\pi*\frac{rad}{cutoff}) @f$ +!> - rad > cutoff : @f$ filter=0 @f$ +!> - 'hamming' +!> - rad < cutoff : @f$ filter=0.54+0.46*COS(\pi*\frac{rad}{cutoff}) @f$ +!> - rad > cutoff : @f$ filter=0 @f$ +!> - 'blackman' +!> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + +!> 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$ +!> - rad > cutoff : @f$ filter=0 @f$ +!> - 'gauss' +!> - @f$filter=exp(-(\alpha * rad^2) / (2*cutoff^2))@f$ +!> - 'butterworth' +!> - @f$ filer=1 / (1+(rad^2 / cutoff^2)^{\alpha}) @f$ +!> . +!> +!> with @f$ rad= \sqrt{(dist-radius)^2} @f$ +!> +!> td_var\%c_filter(2) string character is the number of turn to be done<br/> +!> td_var\%c_filter(3) string character is the cut-off frequency +! > (count in number of mesh grid)<br/> +!> td_var\%c_filter(4) string character is the halo radius +!> (count in number of mesh grid)<br/> +!> td_var\%c_filter(5) string character is the alpha parameter +!> (for gauss and butterworth method)<br/> +!> +!> @note Filter method could be specify for each variable in namelist _namvar_, +!> defining string character _cn\_varinfo_. None by default.<br/> +!> Filter method parameters are informed inside bracket. +!> - @f$\alpha@f$ parameter is added for _gauss_ and _butterworth_ methods +!> +!> The number of turn is specify using '*' separator.<br/> +!> Example: +!> - cn_varinfo='varname1:flt=2*hamming(@f$cutoff@f$,@f$radius@f$)', +!> 'varname2:flt=gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)' +!> +!> to filter variable value:<br/> +!> @code +!> CALL filter_fill_value( td_var ) +!> @endcode +!> - td_var is variable structure +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE filter + + USE kind ! F90 kind parameter + USE phycst ! physical constant + USE logger ! log file manager + USE fct ! basic usefull function + use att ! attribute manager + USE var ! variable manager + USE extrap ! extrapolation manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + + ! function and subroutine + PUBLIC :: filter_fill_value !< filter variable value + + PRIVATE :: filter__fill_value_wrapper ! + PRIVATE :: filter__fill_value ! + PRIVATE :: filter__3D_fill_value ! + PRIVATE :: filter__2D_fill_value ! + PRIVATE :: filter__2D ! + PRIVATE :: filter__2D_coef ! + PRIVATE :: filter__2D_hann ! + PRIVATE :: filter__2D_hamming ! + PRIVATE :: filter__2D_blackman ! + PRIVATE :: filter__2D_gauss ! + PRIVATE :: filter__2D_butterworth ! + PRIVATE :: filter__1D_fill_value ! + PRIVATE :: filter__1D ! + PRIVATE :: filter__1D_coef ! + PRIVATE :: filter__1D_hann ! + PRIVATE :: filter__1D_hamming ! + PRIVATE :: filter__1D_blackman ! + PRIVATE :: filter__1D_gauss ! + PRIVATE :: filter__1D_butterworth ! + + INTERFACE filter_fill_value + MODULE PROCEDURE filter__fill_value_wrapper + END INTERFACE filter_fill_value + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__fill_value_wrapper(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine filter variable value. + !> + !> @details + !> it checks if filtering method is available, + !> gets parameter value, and launch filter__fill_value + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + CHARACTER(LEN=lc) :: cl_filter + CHARACTER(LEN=lc) :: cl_method + INTEGER(I4) :: il_radius + INTEGER(I4) :: il_nturn + REAL(dp) :: dl_cutoff + REAL(dp) :: dl_alpha + + TYPE(TATT) :: tl_att + + ! loop indices + INTEGER(I4) :: jl + !---------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("FILTER FILL VALUE: no array of value "//& + & "associted to variable "//TRIM(td_var%c_name) ) + ELSE + + SELECT CASE(TRIM(td_var%c_filter(1))) + + CASE DEFAULT + + CALL logger_trace("FILTER FILL VALUE: no filter selected "//& + & "for variable "//TRIM(td_var%c_name)) + + CASE('hann','hamming','blackman','gauss','butterworth') + + cl_method=TRIM(td_var%c_filter(1)) + + ! look for number of turn to be done + READ(td_var%c_filter(2),*) il_nturn + IF( il_nturn < 0 )THEN + CALL logger_error("FILTER FILL VALUE: invalid "//& + & "number of turn ("//TRIM(td_var%c_filter(2))//")") + ENDIF + + ! look for cut-off frequency + dl_cutoff=2 + IF( TRIM(td_var%c_filter(3)) /= '' )THEN + READ(td_var%c_filter(3),*) dl_cutoff + ENDIF + IF( dl_cutoff < 0 )THEN + CALL logger_error("FILTER FILL VALUE: invalid cut-off "//& + & "frequency ("//TRIM(td_var%c_filter(3))//")") + ENDIF + + ! look for halo size + il_radius=1 + IF( TRIM(td_var%c_filter(4)) /= '' )THEN + READ(td_var%c_filter(4),*) il_radius + ENDIF + IF( il_radius < 0 )THEN + CALL logger_error("FILTER FILL VALUE: invalid halo radius "//& + & " ("//TRIM(td_var%c_filter(4))//")") + ENDIF + + IF( REAL(2*il_radius+1,dp) < dl_cutoff )THEN + CALL logger_error("FILTER FILL VALUE: radius of halo and "//& + & "spatial cut-off frequency are not suitable.") + ENDIF + + ! look for alpha parameter + dl_alpha=2 + IF( TRIM(td_var%c_filter(5)) /= '' )THEN + READ(td_var%c_filter(5),*) dl_alpha + ENDIF + + SELECT CASE(TRIM(cl_method)) + CASE('gauss','butterworth') + CALL logger_info("FILTER FILL VALUE: filtering "//& + & " variable "//TRIM(td_var%c_name)//& + & " using "//TRIM(fct_str(il_nturn))//" turn"//& + & " of "//TRIM(cl_method)//" method,"//& + & " with cut-off frequency of "//& + & TRIM(fct_str(REAL(dl_cutoff,sp)))//& + & ", halo's radius of "//& + & TRIM(fct_str(il_radius))//& + & ", and alpha parameter of "//& + & TRIM(fct_str(REAL(dl_alpha,sp))) ) + CASE DEFAULT + CALL logger_info("FILTER FILL VALUE: filtering "//& + & " variable "//TRIM(td_var%c_name)//& + & " using "//TRIM(fct_str(il_nturn))//" turn"//& + & " of "//TRIM(cl_method)//" method,"//& + & " with cut-off frequency of "//& + & TRIM(fct_str(REAL(dl_cutoff,sp)))//& + & " and halo's radius of "//& + & TRIM(fct_str(il_radius)) ) + END SELECT + + IF( .NOT. ANY(td_var%t_dim(1:3)%l_use) )THEN + ! no dimension I-J-K used + CALL logger_debug("FILTER FILL VALUE: no filtering can "//& + & "be done for variable "//TRIM(td_var%c_name)) + ELSE + + ! add attribute to variable + SELECT CASE(TRIM(cl_method)) + CASE('gauss','butterworth') + cl_filter=TRIM(fct_str(il_nturn))//'*'//TRIM(cl_method)//& + & '('//TRIM(fct_str(REAL(dl_cutoff,sp)))//","//& + & TRIM(fct_str(il_radius))//","//& + & TRIM(fct_str(REAL(dl_alpha,sp)))//')' + CASE DEFAULT + cl_filter=TRIM(fct_str(il_nturn))//'*'//TRIM(cl_method)//& + & '('//TRIM(fct_str(REAL(dl_cutoff,sp)))//","//& + & TRIM(fct_str(il_radius))//')' + END SELECT + tl_att=att_init('filter',cl_filter) + CALL var_move_att(td_var,tl_att) + ! clean + CALL att_clean(tl_att) + + DO jl=1,il_nturn + CALL filter__fill_value( td_var, TRIM(cl_method), & + & dl_cutoff, il_radius, dl_alpha ) + ENDDO + ENDIF + + END SELECT + + ENDIF + END SUBROUTINE filter__fill_value_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__fill_value(td_var, cd_name, & + & dd_cutoff, id_radius, dd_alpha) + !------------------------------------------------------------------- + !> @brief + !> This subroutine filtering variable value, given cut-off frequency + !> halo radius and alpha parameter. + !> + !> @details + !> First extrabands are added to array of variable value. + !> Then values are extrapolated, before apply filter. + !> Finally extrabands are removed. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + REAL(dp) , INTENT(IN ) :: dd_cutoff + INTEGER(I4) , INTENT(IN ) :: id_radius + REAL(dp) , INTENT(IN ) :: dd_alpha + + ! local variable + TYPE(TVAR) :: tl_mask + + INTEGER(i1) , DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask + + ! loop indices + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + CALL logger_debug("FILTER: "//TRIM(fct_str(td_var%d_fill)) ) + + !1-add extraband + CALL extrap_add_extrabands(td_var, id_radius, id_radius) + + !2-compute mask + ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + bl_mask(:,:,:,:)=1 + WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0 + + tl_mask=var_init('tmask', bl_mask(:,:,:,:)) + + DEALLOCATE(bl_mask) + + !3-extrapolate + CALL extrap_fill_value( td_var ) !, id_iext=id_radius, id_jext=id_radius ) + + !4-filtering + DO jl=1,td_var%t_dim(4)%i_len + IF( ALL(td_var%t_dim(1:3)%l_use) )THEN + ! dimension I-J-K used + CALL filter__3D_fill_value( td_var%d_value(:,:,:,jl), & + & td_var%d_fill, TRIM(cd_name), & + & dd_cutoff, id_radius, dd_alpha) + ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + ! dimension I-J used + CALL filter__2D_fill_value( td_var%d_value(:,:,1,jl), & + & td_var%d_fill, TRIM(cd_name), & + & dd_cutoff, id_radius, dd_alpha) + ELSE IF( td_var%t_dim(3)%l_use )THEN + ! dimension K used + CALL filter__1D_fill_value( td_var%d_value(1,1,:,jl), & + & td_var%d_fill, TRIM(cd_name), & + & dd_cutoff, id_radius, dd_alpha) + ENDIF + ENDDO + + !5-keep original mask + WHERE( tl_mask%d_value(:,:,:,:) == 0 ) + td_var%d_value(:,:,:,:)=td_var%d_fill + END WHERE + + ! clean + CALL var_clean(tl_mask) + + !6-remove extraband + CALL extrap_del_extrabands(td_var, id_radius, id_radius) + + END SUBROUTINE filter__fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__3D_fill_value(dd_value, dd_fill, cd_name, & + & dd_cutoff, id_radius, dd_alpha) + !------------------------------------------------------------------- + !> @brief This subroutine compute filtered value of 3D array. + !> + !> @details + !> First compute filter coefficient. + !> Then apply it on each level of variable value. + !> + !> @warning array of value should have been already extrapolated before + !> running this subroutine. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value array of value to be filtered + !> @param[in] dd_fill fill value + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + REAL(dp) , INTENT(IN ) :: dd_cutoff + INTEGER(i4) , INTENT(IN ) :: id_radius + REAL(dp) , INTENT(IN ) :: dd_alpha + + ! local variable + INTEGER(i4), DIMENSION(3) :: il_shape + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coef + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(dd_value(:,:,:)) + + ALLOCATE( dl_coef(2*id_radius+1,2*id_radius+1) ) + + dl_coef(:,:)=filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) + + DO jk=1,il_shape(3) + CALL filter__2D(dd_value(:,:,jk), dd_fill,dl_coef(:,:),id_radius) + ENDDO + + DEALLOCATE( dl_coef ) + + END SUBROUTINE filter__3D_fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__2D_fill_value(dd_value, dd_fill, cd_name, & + & dd_cutoff, id_radius, dd_alpha) + !------------------------------------------------------------------- + !> @brief This subroutine compute filtered value of 2D array. + !> + !> @details + !> First compute filter coefficient. + !> Then apply it on variable value. + !> + !> @warning array of value should have been already extrapolated before + !> running this subroutine. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value array of value to be filtered + !> @param[in] dd_fill fill value + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + REAL(dp) , INTENT(IN ) :: dd_cutoff + INTEGER(i4) , INTENT(IN ) :: id_radius + REAL(dp) , INTENT(IN ) :: dd_alpha + + ! local variable + + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_coef + ! loop indices + !---------------------------------------------------------------- + + ALLOCATE( dl_coef(2*id_radius+1,2*id_radius+1) ) + + dl_coef(:,:)=filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) + + CALL filter__2D(dd_value(:,:), dd_fill, dl_coef(:,:), id_radius) + + DEALLOCATE( dl_coef ) + + END SUBROUTINE filter__2D_fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__1D_fill_value(dd_value, dd_fill, cd_name, & + & dd_cutoff, id_radius, dd_alpha) + !------------------------------------------------------------------- + !> @brief This subroutine compute filtered value of 1D array. + !> + !> @details + !> First compute filter coefficient. + !> Then apply it on variable value. + !> + !> @warning array of value should have been already extrapolated before + !> running this subroutine. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value array of value to be filtered + !> @param[in] dd_fill fill value + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + REAL(dp) , INTENT(IN ) :: dd_cutoff + INTEGER(i4) , INTENT(IN ) :: id_radius + REAL(dp) , INTENT(IN ) :: dd_alpha + + ! local variable + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_coef + ! loop indices + !---------------------------------------------------------------- + + ALLOCATE( dl_coef(2*id_radius+1) ) + + dl_coef(:)=filter__1D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) + + CALL filter__1D(dd_value(:), dd_fill, dl_coef(:),id_radius) + + DEALLOCATE( dl_coef ) + + END SUBROUTINE filter__1D_fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__2D(dd_value, dd_fill, dd_coef, id_radius) + !------------------------------------------------------------------- + !> @brief This subroutine filtered 2D array of value + !> + !> @details + !> loop on first and second dimension, + !> and apply coefficient 2D array on each point + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value array of value to be filtered + !> @param[in] dd_fill fill value + !> @param[in] dd_coef filter coefficent array + !> @param[in] id_radius filter halo radius + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_coef + INTEGER(i4) , INTENT(IN ) :: id_radius + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_value + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_halo + + ! loop indices + INTEGER(i4) :: jj + INTEGER(i4) :: ji + !---------------------------------------------------------------- + il_shape(:)=SHAPE(dd_value(:,:)) + + ALLOCATE(dl_value(il_shape(1),il_shape(2))) + dl_value(:,:)=dd_value(:,:) + + ALLOCATE(dl_halo(2*id_radius+1,2*id_radius+1)) + + DO jj=1+id_radius,il_shape(2)-id_radius + DO ji=1+id_radius,il_shape(1)-id_radius + + dl_halo(:,:)=dd_fill + dl_halo(:,:)=dl_value(ji-id_radius:ji+id_radius, & + & jj-id_radius:jj+id_radius) + + dd_value(ji,jj)=SUM(dl_halo(:,:)*dd_coef(:,:)) + + ENDDO + ENDDO + + DEALLOCATE(dl_halo) + DEALLOCATE(dl_value) + + END SUBROUTINE filter__2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE filter__1D(dd_value, dd_fill, dd_coef, id_radius) + !------------------------------------------------------------------- + !> @brief This subroutine filtered 1D array of value + !> + !> @details + !> loop on first dimension, + !> and apply coefficient 1D array on each point + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value array of value to be filtered + !> @param[in] dd_fill fill value + !> @param[in] dd_coef filter coefficent array + !> @param[in] id_radius filter halo radius + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + REAL(dp) , DIMENSION(:), INTENT(IN ) :: dd_coef + INTEGER(i4) , INTENT(IN ) :: id_radius + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_shape + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + il_shape(:)=SHAPE(dd_value(:)) + + ALLOCATE(dl_value(2*id_radius+1)) + + DO ji=1+id_radius,il_shape(1)-id_radius + + dl_value(:)=dd_fill + dl_value(:)=dd_value(ji-id_radius:ji+id_radius) + + dd_value(ji)=SUM(dl_value(:)*dd_coef(:)) + + ENDDO + + DEALLOCATE(dl_value) + + END SUBROUTINE filter__1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute filter coefficient. + !> + !> @details + !> + !> filter could be choose between : + !> - hann + !> - hamming + !> - blackman + !> - gauss + !> - butterworth + !> Cut-off frequency could be specify. + !> As well as a filter parameter for gauss and butterworth filter + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + + ! loop indices + !---------------------------------------------------------------- + IF( REAL(id_radius,dp) < dd_cutoff )THEN + CALL logger_warn("FILTER COEF: radius of the filter halo "//& + & "is lower than cut-off frequency") + ENDIF + + SELECT CASE(TRIM(fct_lower(cd_name))) + CASE('hann') + df_coef(:,:)=filter__2D_hann(dd_cutoff, id_radius) + CASE('hamming') + df_coef(:,:)=filter__2D_hamming(dd_cutoff, id_radius) + CASE('blackman') + df_coef(:,:)=filter__2D_blackman(dd_cutoff, id_radius) + CASE('gauss') + df_coef(:,:)=filter__2D_gauss(dd_cutoff, id_radius, dd_alpha) + CASE('butterworth') + df_coef(:,:)=filter__2D_butterworth(dd_cutoff, id_radius, dd_alpha) + CASE DEFAULT + CALL logger_error("FILTER COEF: invalid filter name :"//TRIM(cd_name)) + END SELECT + + END FUNCTION filter__2D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute filter coefficient. + !> + !> @details + !> + !> filter could be choose between : + !> - hann + !> - hamming + !> - blackman + !> - gauss + !> - butterworth + !> Cut-off frequency could be specify. + !> As well as a filter parameter for gauss an butterworth filter + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_name filter name + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + + ! loop indices + !---------------------------------------------------------------- + + SELECT CASE(TRIM(fct_lower(cd_name))) + CASE('hann') + df_coef(:)=filter__1D_hann(dd_cutoff, id_radius) + CASE('hamming') + df_coef(:)=filter__1D_hamming(dd_cutoff, id_radius) + CASE('blackman') + df_coef(:)=filter__1D_blackman(dd_cutoff, id_radius) + CASE('gauss') + df_coef(:)=filter__1D_gauss(dd_cutoff, id_radius, dd_alpha) + CASE('butterworth') + df_coef(:)=filter__1D_butterworth(dd_cutoff, id_radius, dd_alpha) + CASE DEFAULT + CALL logger_error("FILTER COEF: invalid filter name :"//TRIM(cd_name)) + END SELECT + + END FUNCTION filter__1D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_hann(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for HANN filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of hann filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:)=0. + df_coef(id_radius+1)=1. + ELSE + DO ji=1,2*id_radius+1 + + dl_rad=SQRT(REAL(ji-id_radius+1,dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji)=0 + ENDIF + + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:)) + + df_coef(:)=df_coef(:)/dl_sum + ENDIF + + END FUNCTION filter__1D_hann + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_hann(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for HANN filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of hann filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4), INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( dd_cutoff < 1.0_dp )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:,:)=0. + df_coef(id_radius+1,id_radius+1)=1. + ELSE + DO jj=1,2*id_radius+1 + DO ji=1,2*id_radius+1 + + ! radius + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + & + & REAL(jj-(id_radius+1),dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji,jj)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji,jj)=0 + ENDIF + + ENDDO + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:,:)) + + df_coef(:,:)=df_coef(:,:)/dl_sum + ENDIF + + END FUNCTION filter__2D_hann + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_hamming(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for HAMMING filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of hamming filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:)=0. + df_coef(id_radius+11)=1. + ELSE + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji)= 0.54 + 0.46*COS(dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji)=0 + ENDIF + + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:)) + + df_coef(:)=df_coef(:)/dl_sum + ENDIF + + END FUNCTION filter__1D_hamming + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_hamming(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for HAMMING filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of hamming filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:,:)=0. + df_coef(id_radius+1,id_radius+1)=1. + ELSE + DO jj=1,2*id_radius+1 + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + & + & REAL(jj-(id_radius+1),dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji,jj)= 0.54 + 0.46*COS(dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji,jj)=0 + ENDIF + + ENDDO + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:,:)) + + df_coef(:,:)=df_coef(:,:)/dl_sum + ENDIF + + END FUNCTION filter__2D_hamming + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_blackman(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for BLACKMAN filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of blackman filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:)=0. + df_coef(id_radius+1)=1. + ELSE + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji)= 0.42 + 0.5 *COS( dp_pi*dl_rad/dd_cutoff) & + & + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji)=0 + ENDIF + + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:)) + + df_coef(:)=df_coef(:)/dl_sum + ENDIF + + END FUNCTION filter__1D_blackman + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_blackman(dd_cutoff, id_radius) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for BLACKMAN filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @return array of blackman filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:,:)=0. + df_coef(id_radius+1,id_radius+1)=1. + ELSE + DO jj=1,2*id_radius+1 + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + & + & REAL(jj-(id_radius+1),dp)**2 ) + + IF( dl_rad < dd_cutoff )THEN + df_coef(ji,jj)= 0.42 + 0.5 *COS( dp_pi*dl_rad/dd_cutoff) & + & + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff) + ELSE + df_coef(ji,jj)=0 + ENDIF + + ENDDO + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:,:)) + + df_coef(:,:)=df_coef(:,:)/dl_sum + ENDIF + + END FUNCTION filter__2D_blackman + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_gauss(dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for GAUSS filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of gauss filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:)=0. + df_coef(id_radius+1)=1. + ELSE + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 ) + + df_coef(ji)=EXP(-(dd_alpha*dl_rad**2)/(2*dd_cutoff**2)) + + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:)) + + df_coef(:)=df_coef(:)/dl_sum + ENDIF + + END FUNCTION filter__1D_gauss + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_gauss(dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for GAUSS filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of gauss filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( dd_cutoff < 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than or equal to 1. No filter will be apply ") + df_coef(:,:)=0. + df_coef(id_radius+1,id_radius+1)=1. + ELSE + DO jj=1,2*id_radius+1 + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + & + & REAL(jj-(id_radius+1),dp)**2 ) + + df_coef(ji,jj)=EXP(-(dd_alpha*dl_rad**2)/(2*dd_cutoff**2)) + + ENDDO + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:,:)) + + df_coef(:,:)=df_coef(:,:)/dl_sum + ENDIF + + END FUNCTION filter__2D_gauss + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__1D_butterworth(dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for BUTTERWORTH filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of butterworth filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( dd_cutoff <= 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than 1. No filter will be apply ") + df_coef(:)=0. + df_coef(id_radius+1)=1. + ELSE + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 ) + + df_coef(ji)= 1 / (1+(dl_rad**2/dd_cutoff**2)**dd_alpha) + + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:)) + + df_coef(:)=df_coef(:)/dl_sum + ENDIF + + END FUNCTION filter__1D_butterworth + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION filter__2D_butterworth(dd_cutoff, id_radius, dd_alpha) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief This function compute coefficient for BUTTERWORTH filter. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_cutoff cut-off frequency + !> @param[in] id_radius filter halo radius + !> @param[in] dd_alpha filter parameter + !> @return array of butterworth filter coefficient + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , INTENT(IN) :: dd_cutoff + INTEGER(i4) , INTENT(IN) :: id_radius + REAL(dp) , INTENT(IN) :: dd_alpha + + ! function + REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef + + ! local variable + REAL(dp) :: dl_rad + REAL(dp) :: dl_sum + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( dd_cutoff <= 1 )THEN + CALL logger_error("FILTER COEF: cut-off frequency "//& + & "should be greater than 1. No filter will be apply ") + df_coef(:,:)=0. + df_coef(id_radius+1,id_radius+1)=1. + ELSE + DO jj=1,2*id_radius+1 + DO ji=1,2*id_radius+1 + + dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + & + & REAL(jj-(id_radius+1),dp)**2 ) + + df_coef(ji,jj)= 1 / (1+(dl_rad**2/dd_cutoff**2)**dd_alpha) + + ENDDO + ENDDO + + ! normalize + dl_sum=SUM(df_coef(:,:)) + + df_coef(:,:)=df_coef(:,:)/dl_sum + ENDIF + + END FUNCTION filter__2D_butterworth + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE filter + diff --git a/V4.0/nemo_sources/tools/SIREN/src/function.f90 b/V4.0/nemo_sources/tools/SIREN/src/function.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fb804601b1e0fcb90d02485d894c6c1ba46318fb --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/function.f90 @@ -0,0 +1,1300 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module groups some basic useful function. +!> +!> @details +!> to get free I/O unit number:<br/> +!> @code +!> il_id=fct_getunit() +!> @endcode +!> +!> to convert "numeric" to string character:<br/> +!> @code +!> cl_string=fct_str(numeric) +!> @endcode +!> - "numeric" could be integer, real, or logical +!> +!> to concatenate "numeric" to a string character:<br/> +!> @code +!> cl_str=cd_char//num +!> @endcode +!> - cd_char is the string character +!> - num is the numeric value (integer, real or logical) +!> +!> to concatenate all the element of a character array:<br/> +!> @code +!> cl_string=fct_concat(cd_arr [,cd_sep]) +!> @endcode +!> - cd_arr is a 1D array of character +!> - cd_sep is a separator character to add between each element of cd_arr +!> [optional] +!> +!> to convert character from lower to upper case:<br/> +!> @code +!> cl_upper=fct_upper(cd_var) +!> @endcode +!> +!> to convert character from upper to lower case:<br/> +!> @code +!> cl_lower=fct_lower(cd_var) +!> @endcode +!> +!> to check if character is numeric +!> @code +!> ll_is_num=fct_is_num(cd_var) +!> @endcode +!> +!> to check if character is real +!> @code +!> ll_is_real=fct_is_real(cd_var) +!> @endcode +!> +!> to split string into substring and return one of the element:<br/> +!> @code +!> cl_str=fct_split(cd_string ,id_ind [,cd_sep]) +!> @endcode +!> - cd_string is a string of character +!> - id_ind is the indice of the lement to extract +!> - cd_sep is the separator use to split cd_string (default '|') +!> +!> to get basename (name without path):<br/> +!> @code +!> cl_str=fct_basename(cd_string [,cd_sep]) +!> @endcode +!> - cd_string is the string filename +!> - cd_sep is the separator ti be used (default '/') +!> +!> to get dirname (path of the filename):<br/> +!> @code +!> cl_str=fct_dirname(cd_string [,cd_sep]) +!> @endcode +!> - cd_string is the string filename +!> - cd_sep is the separator ti be used (default '/') +!> +!> to create a pause statement:<br/> +!> @code +!> CALL fct_pause(cd_msg) +!> @endcode +!> - cd_msg : message to be added [optional] +!> +!> to handle frotran error:<br/> +!> @code +!> CALL fct_err(id_status) +!> @endcode +!> +!> to show help message:<br/> +!> @code +!> CALL fct_help(cd_filename, cd_err) +!> @endcode +!> - cd_filename : file name +!> - cd_err : error message [optional] +!> +!> to show Siren's version:<br/> +!> @code +!> CALL fct_version(cd_filename) +!> @endcode +!> - cd_filename : file name +!> +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header +!> @date October, 2019 +!> - add help and version function +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE fct + + USE global ! global variable + USE kind ! F90 kind parameter + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: fct_getunit !< returns free unit number + PUBLIC :: fct_str !< convert numeric to string character + PUBLIC :: OPERATOR(//) !< concatenate operator + PUBLIC :: fct_concat !< concatenate all the element of a character array + PUBLIC :: fct_upper !< convert character from lower to upper case + PUBLIC :: fct_lower !< convert character from upper to lower case + PUBLIC :: fct_is_num !< check if character is numeric + PUBLIC :: fct_is_real !< check if character is real + PUBLIC :: fct_split !< split string into substring + PUBLIC :: fct_basename !< return basename (name without path) + PUBLIC :: fct_dirname !< return dirname (path without filename) + PUBLIC :: fct_pause !< pause statement + PUBLIC :: fct_err !< handle fortran error status + PUBLIC :: fct_help !< show help message + PUBLIC :: fct_version !< show Siren's version + + PRIVATE :: fct__i1_str ! convert integer(1) to string character + PRIVATE :: fct__i2_str ! convert integer(2) to string character + PRIVATE :: fct__i4_str ! convert integer(4) to string character + PRIVATE :: fct__i8_str ! convert integer(8) to string character + PRIVATE :: fct__r4_str ! convert real(4) to string character + PRIVATE :: fct__r8_str ! convert real(8) to string character + PRIVATE :: fct__l_str ! convert logical to string character + PRIVATE :: fct__i1_cat ! concatenate integer(1) to string character + PRIVATE :: fct__i2_cat ! concatenate integer(2) to string character + PRIVATE :: fct__i4_cat ! concatenate integer(4) to string character + PRIVATE :: fct__i8_cat ! concatenate integer(8) to string character + PRIVATE :: fct__r4_cat ! concatenate real(4) to string character + PRIVATE :: fct__r8_cat ! concatenate real(8) to string character + PRIVATE :: fct__l_cat ! concatenate logical to string character + PRIVATE :: fct__split_space ! split string into substring using space as separator + + INTERFACE fct_str + MODULE PROCEDURE fct__i1_str ! convert integer(1) to string character + MODULE PROCEDURE fct__i2_str ! convert integer(2) to string character + MODULE PROCEDURE fct__i4_str ! convert integer(4) to string character + MODULE PROCEDURE fct__i8_str ! convert integer(8) to string character + MODULE PROCEDURE fct__r4_str ! convert real(4) to string character + MODULE PROCEDURE fct__r8_str ! convert real(8) to string character + MODULE PROCEDURE fct__l_str ! convert logical to string character + END INTERFACE fct_str + + INTERFACE OPERATOR(//) + MODULE PROCEDURE fct__i1_cat ! concatenate integer(1) to string character + MODULE PROCEDURE fct__i2_cat ! concatenate integer(2) to string character + MODULE PROCEDURE fct__i4_cat ! concatenate integer(4) to string character + MODULE PROCEDURE fct__i8_cat ! concatenate integer(8) to string character + MODULE PROCEDURE fct__r4_cat ! concatenate real(4) to string character + MODULE PROCEDURE fct__r8_cat ! concatenate real(8) to string character + MODULE PROCEDURE fct__l_cat ! concatenate logical to string character + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i1_cat(cd_char, bd_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and integer(1) (as character). + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] bd_val integer(1) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + INTEGER(i1), INTENT(IN) :: bd_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(bd_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__i1_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i2_cat(cd_char, sd_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and integer(2) (as character). + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] sd_val integer(2) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + INTEGER(i2), INTENT(IN) :: sd_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(sd_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__i2_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i4_cat(cd_char, id_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and integer(4) (as character). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] id_val integer(4) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + INTEGER(i4), INTENT(IN) :: id_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(id_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__i4_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i8_cat(cd_char, kd_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and integer(8) (as character). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] kd_val integer(8) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + INTEGER(i8), INTENT(IN) :: kd_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(kd_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__i8_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__r4_cat(cd_char, rd_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and real(4) (as character). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] rd_val real(4) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + REAL(sp), INTENT(IN) :: rd_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(rd_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__r4_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__r8_cat(cd_char, dd_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and real(8) (as character). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] dd_val real(8) variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + REAL(dp), INTENT(IN) :: dd_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(dd_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__r8_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__l_cat(cd_char, ld_val) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate character and logical (as character). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_char string character + !> @param[in] ld_val logical variable value + !> @return string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! arguments + CHARACTER(LEN=lc), INTENT(IN) :: cd_char + LOGICAL, INTENT(IN) :: ld_val + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_val + !---------------------------------------------------------------- + + cl_val = fct_str(ld_val) + cf_str = TRIM(cd_char)//TRIM(cl_val) + + END FUNCTION fct__l_cat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION fct_getunit() & + & RESULT(if_unit) + !------------------------------------------------------------------- + !> @brief This function returns the next available I/O unit number. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @return file id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! function + INTEGER(i4) :: if_unit + + ! local variable + LOGICAL :: ll_opened + !---------------------------------------------------------------- + ! initialise + if_unit = 10 + + INQUIRE(UNIT=if_unit, OPENED=ll_opened) + DO WHILE( ll_opened ) + if_unit = if_unit + 1 + INQUIRE(UNIT=if_unit, OPENED=ll_opened) + ENDDO + + END FUNCTION fct_getunit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE fct_err(id_status) + !------------------------------------------------------------------- + !> @brief This subroutine handle Fortran status. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] id_status + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: id_status + !---------------------------------------------------------------- + + IF( id_status /= 0 )THEN + !CALL ERRSNS() ! not F95 standard + PRINT *, "FORTRAN ERROR ", id_status + !STOP + ENDIF + + END SUBROUTINE fct_err + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE fct_pause(cd_msg) + !------------------------------------------------------------------- + !> @brief This subroutine create a pause statement + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> + !> @param[in] cd_msg optional message to be added + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_msg + !---------------------------------------------------------------- + + IF( PRESENT(cd_msg) )THEN + WRITE( *, * ) 'Press Enter to continue '//TRIM(cd_msg) + ELSE + WRITE( *, * ) 'Press Enter to continue' + ENDIF + READ( *, * ) + + END SUBROUTINE fct_pause + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__l_str(ld_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert logical to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] ld_var logical variable + !> @return character of this integer variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + LOGICAL, INTENT(IN) :: ld_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) ld_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__l_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i1_str(bd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert integer(1) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] bd_var integer(1) variable + !> @return character of this integer variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i1), INTENT(IN) :: bd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) bd_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__i1_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i2_str(sd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert integer(2) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] sd_var integer(2) variable + !> @return character of this integer variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i2), INTENT(IN) :: sd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) sd_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__i2_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i4_str(id_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert integer(4) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] id_var integer(4) variable + !> @return character of this integer variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: id_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) id_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__i4_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__i8_str(kd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert integer(8) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] kd_var integer(8) variable + !> @return character of this integer variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i8), INTENT(IN) :: kd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) kd_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__i8_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__r4_str(rd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert real(4) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] rd_var real(4) variable + !> @return character of this real variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(sp), INTENT(IN) :: rd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) rd_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__r4_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__r8_str(dd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert real(8) to string character. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_var real(8) variable + !> @return character of this real variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), INTENT(IN) :: dd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + WRITE(cl_tmp,*) dd_var + cf_str=TRIM(ADJUSTL(cl_tmp)) + + END FUNCTION fct__r8_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_concat(cd_arr,cd_sep) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function concatenate all the element of a character array + !> in a character string. + !> @details + !> optionnally a separator could be added between each element. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_arr array of character + !> @param[in] cd_sep separator character + !> @return character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_arr + CHARACTER(*), INTENT(IN), OPTIONAL :: cd_sep + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_sep + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + cl_sep='' + IF(PRESENT(cd_sep)) cl_sep=cd_sep + + il_size=SIZE(cd_arr) + cf_str='' + cl_tmp='' + DO ji=1,il_size + + WRITE(cl_tmp,*) TRIM(cf_str)//TRIM(ADJUSTL(cd_arr(ji)))//TRIM(cl_sep) + cf_str=TRIM(ADJUSTL(cl_tmp)) + + ENDDO + + END FUNCTION fct_concat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_lower(cd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert string character upper case to lower case. + !> + !> @details + !> The function IACHAR returns the ASCII value of the character passed + !> as argument. The ASCII code has the uppercase alphabet starting at + !> code 65, and the lower case one at code 101, therefore + !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase + !> and the lowercase codes. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_var character + !> @return lower case character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(*), INTENT(IN) :: cd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + INTEGER(i4) :: il_nletter ! number of letters in variable + CHARACTER(LEN=lc) :: cl_var + CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp + + INTEGER(i4) :: il_icode ! ASCII value + INTEGER(i4) :: il_lacode ! ASCII value of the lower case 'a' + INTEGER(i4) :: il_uacode ! ASCII value of the upper case 'A' + INTEGER(i4) :: il_uzcode ! ASCII value of the upper case 'z' + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + il_lacode=IACHAR('a') + il_uacode=IACHAR('A') + il_uzcode=IACHAR('Z') + + cl_var=TRIM(ADJUSTL(cd_var)) + il_nletter=LEN(TRIM(cl_var)) + ALLOCATE(cl_tmp(il_nletter)) + DO ji=1,il_nletter + il_icode=IACHAR(cl_var(ji:ji)) + IF( il_icode >= il_uacode .AND. il_icode <= il_uzcode )THEN + ! upper case + cl_tmp(ji)=TRIM(CHAR(il_icode + (il_lacode - il_uacode) )) + ELSE + ! lower case and other character + cl_tmp(ji)=TRIM(CHAR(il_icode)) + ENDIF + ENDDO + + cf_str=TRIM(ADJUSTL(fct_concat(cl_tmp(:)))) + DEALLOCATE(cl_tmp) + + END FUNCTION fct_lower + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_upper(cd_var) & + & RESULT(cf_str) + !------------------------------------------------------------------- + !> @brief This function convert string character lower case to upper case. + !> + !> @details + !> The function IACHAR returns the ASCII value of the character passed + !> as argument. The ASCII code has the uppercase alphabet starting at + !> code 65, and the lower case one at code 101, therefore + !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase + !> and the lowercase codes. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_var character + !> @return upper case character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(*), INTENT(IN) :: cd_var + + ! function + CHARACTER(LEN=lc) :: cf_str + + ! local variable + INTEGER(i4) :: il_nletter ! number of letters in cd_var + CHARACTER(LEN=lc) :: cl_var + CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp + + INTEGER(i4) :: il_icode ! ASCII value + INTEGER(i4) :: il_lacode ! ASCII value of the lower case 'a' + INTEGER(i4) :: il_uacode ! ASCII value of the upper case 'A' + INTEGER(i4) :: il_lzcode ! ASCII value of the lower case 'z' + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + il_lacode=ICHAR('a') + il_uacode=ICHAR('A') + il_lzcode=IACHAR('z') + + cl_var=TRIM(ADJUSTL(cd_var)) + il_nletter=LEN(TRIM(cl_var)) + ALLOCATE(cl_tmp(il_nletter)) + DO ji=1,il_nletter + il_icode=IACHAR(cl_var(ji:ji)) + IF( il_icode >= il_lacode .AND. il_icode <= il_lzcode )THEN + ! lower case + cl_tmp(ji)=CHAR(il_icode - (il_lacode - il_uacode) ) + ELSE + ! upper case and other character + cl_tmp(ji)=CHAR(il_icode) + ENDIF + ENDDO + + cf_str=TRIM(ADJUSTL(fct_concat(cl_tmp(:)))) + DEALLOCATE(cl_tmp) + + END FUNCTION fct_upper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_is_num(cd_var) & + & RESULT(lf_numeric) + !------------------------------------------------------------------- + !> @brief This function check if character is numeric. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_var character + !> @return character is numeric + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_var + + ! function + LOGICAL :: lf_numeric + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,LEN(TRIM(cd_var)) + IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. & + & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN + lf_numeric=.TRUE. + ELSE + lf_numeric=.FALSE. + EXIT + ENDIF + ENDDO + + END FUNCTION fct_is_num + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_is_real(cd_var) & + & RESULT(lf_real) + !------------------------------------------------------------------- + !> @brief This function check if character is real number. + !> + !> @details + !> it permits exponantial and decimal number + !> exemple : 1e6, 2.3 + !> + !> @author J.Paul + !> @date June, 2015 - Initial Version + !> @date April, 2018 + !> - permit negative exposant + !> - permit sign as first character + !> + !> @param[in] cd_var character + !> @return character is real number + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_var + + ! function + LOGICAL :: lf_real + + ! local variables + LOGICAL :: ll_exp + LOGICAL :: ll_dec + + ! loop indices + INTEGER :: ji + !---------------------------------------------------------------- + + ll_exp=.TRUE. + ll_dec=.FALSE. + DO ji=1,LEN(TRIM(cd_var)) + IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. & + & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN + + lf_real=.TRUE. + ll_exp=.FALSE. + + ELSEIF( TRIM(fct_lower(cd_var(ji:ji)))=='e' )THEN + + IF( ll_exp .OR. ji== LEN(TRIM(cd_var)) )THEN + lf_real=.FALSE. + EXIT + ELSE + ll_exp=.TRUE. + ENDIF + + ELSEIF( TRIM(cd_var(ji:ji))=='+' )THEN + IF( ji /= 1 )THEN + lf_real=.FALSE. + EXIT + ELSE + lf_real=.TRUE. + ENDIF + + ELSEIF( TRIM(cd_var(ji:ji))=='-' )THEN + + IF( ji <= 1 )THEN + IF( ji /= 1 )THEN + lf_real=.FALSE. + EXIT + ELSE + lf_real=.TRUE. + ENDIF + ELSE ! ji > 1 + IF( TRIM(fct_lower(cd_var(ji-1:ji-1)))/='e' )THEN + lf_real=.FALSE. + EXIT + ELSE + lf_real=.TRUE. + ENDIF + ENDIF + + ELSEIF( TRIM(cd_var(ji:ji))=='.' )THEN + + IF( ll_dec )THEN + lf_real=.FALSE. + EXIT + ELSE + lf_real=.TRUE. + ll_dec=.TRUE. + ENDIF + + ELSE + + lf_real=.FALSE. + EXIT + + ENDIF + ENDDO + + END FUNCTION fct_is_real + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_split(cd_string, id_ind, cd_sep) & + & RESULT(cf_elt) + !------------------------------------------------------------------- + !> @brief This function split string of character + !> using separator character, by default '|', + !> and return the element on index ind. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_string string of character + !> @param[in] id_ind indice + !> @param[in] cd_sep separator character + !> @return return the element of index id_ind + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_string + INTEGER(i4) , INTENT(IN) :: id_ind + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep + + ! function + CHARACTER(LEN=lc) :: cf_elt + + ! local variable + CHARACTER(LEN=lc) :: cl_sep + CHARACTER(LEN=lc) :: cl_string + + INTEGER(i4) :: il_sep + INTEGER(i4) :: il_lsep + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! initialize + cf_elt='' + cl_string=ADJUSTL(cd_string) + + ! get separator + cl_sep='|' + IF( PRESENT(cd_sep) )THEN + IF( cd_sep==' ')THEN + cl_sep=' ' + ELSE + cl_sep=TRIM(ADJUSTL(cd_sep)) + ENDIF + ENDIF + + IF( cl_sep /= ' ' )THEN + ! get separator index + il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) ) + il_lsep=LEN(TRIM(cl_sep)) + + IF( il_sep /= 0 )THEN + cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) + ELSE + cf_elt=TRIM(ADJUSTL(cl_string)) + ENDIF + + ji=1 + DO WHILE( il_sep /= 0 .AND. ji /= id_ind ) + + ji=ji+1 + + cl_string=TRIM(cl_string(il_sep+il_lsep:)) + il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) ) + + IF( il_sep /= 0 )THEN + cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) + ELSE + cf_elt=TRIM(ADJUSTL(cl_string)) + ENDIF + + ENDDO + + IF( ji /= id_ind ) cf_elt='' + ELSE + cf_elt=fct__split_space(TRIM(cl_string), id_ind) + ENDIF + + END FUNCTION fct_split + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct__split_space(cd_string, id_ind) & + & RESULT(cf_elt) + !------------------------------------------------------------------- + !> @brief This function split string of character + !> using space as separator, + !> and return the element on index ind. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_string string of character + !> @param[in] id_ind indice + !> @return return the element of index id_ind + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_string + INTEGER(i4) , INTENT(IN) :: id_ind + + ! function + CHARACTER(LEN=lc) :: cf_elt + + ! local variable + CHARACTER(LEN=lc) :: cl_string + + INTEGER(i4) :: il_sep + INTEGER(i4) :: il_lsep + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! initialize + cf_elt='' + cl_string=ADJUSTL(cd_string) + + ! get separator index + il_sep=INDEX( TRIM(cl_string), ' ' ) + il_lsep=LEN(' ') + + IF( il_sep /= 0 )THEN + cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) + ELSE + cf_elt=TRIM(ADJUSTL(cl_string)) + ENDIF + + ji=1 + DO WHILE( il_sep /= 0 .AND. ji /= id_ind ) + + ji=ji+1 + + cl_string=TRIM(cl_string(il_sep+il_lsep:)) + il_sep=INDEX( TRIM(cl_string), ' ' ) + + IF( il_sep /= 0 )THEN + cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) + ELSE + cf_elt=TRIM(ADJUSTL(cl_string)) + ENDIF + + ENDDO + + IF( ji /= id_ind ) cf_elt='' + + END FUNCTION fct__split_space + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_basename(cd_string, cd_sep) & + & RESULT(cf_file) + !------------------------------------------------------------------- + !> @brief This function return basename of a filename. + !> + !> @details + !> Actually it splits filename using sperarator '/' + !> and return last string character.<br/> + !> Optionally you could specify another separator. + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_string filename + !> @param[in] cd_sep separator character + !> @return basename (filename without path) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_string + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep + + ! function + CHARACTER(LEN=lc) :: cf_file + + ! local variable + CHARACTER(LEN=lc) :: cl_sep + CHARACTER(LEN=lc) :: cl_string + INTEGER(i4) :: il_sep + + ! loop indices + !---------------------------------------------------------------- + ! initialize + cl_string=TRIM(ADJUSTL(cd_string)) + + ! get separator + cl_sep='/' + IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep)) + + il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.) + cf_file=TRIM(cl_string(il_sep+1:)) + + END FUNCTION fct_basename + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION fct_dirname(cd_string, cd_sep) & + & RESULT(cf_dir) + !------------------------------------------------------------------- + !> @brief This function return dirname of a filename. + !> + !> @details + !> Actually it splits filename using sperarator '/' + !> and return all except last string character.<br/> + !> Optionally you could specify another separator. + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_string filename + !> @param[in] cd_sep separator character + !> @return dirname (path of the filename) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_string + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep + + ! function + CHARACTER(LEN=lc) :: cf_dir + + ! local variable + CHARACTER(LEN=lc) :: cl_sep + CHARACTER(LEN=lc) :: cl_string + INTEGER(i4) :: il_sep + + ! loop indices + !---------------------------------------------------------------- + ! initialize + cl_string=TRIM(ADJUSTL(cd_string)) + + ! get separator + cl_sep='/' + IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep)) + + il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.) + IF( il_sep == 0 )THEN + cf_dir='' + ELSE + cf_dir=TRIM(cl_string(1:il_sep)) + ENDIF + + END FUNCTION fct_dirname + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE fct_help(cd_filename, cd_err) + !------------------------------------------------------------------- + !> @brief + !> This function show help message. + !> + !> @details + !> Optionaly, print error detected + !> + !> @author J.Paul + !> @date October, 2019 - Initial Version + !> + !> @param[in] cd_filename file name + !> @param[in] cd_err error message + !> + !> @return print help message + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_filename + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_err + !---------------------------------------------------------------- + + PRINT '( /, a,/)', 'USAGE: '//TRIM(cd_filename)//' namelist [-v] [-h]' + PRINT '( 2x,a,/)', 'positional arguments:' + PRINT '( 5x,a )', 'namelist '//TRIM(cd_filename)//" namelist" + PRINT '( /,5x,a,/)', 'NB : a template of the namelist could be created running (in templates directory):' + PRINT '( 8x,a )', 'python create_templates.py '//TRIM(cd_filename) + PRINT '( /,2x,a,/)', 'optional arguments:' + PRINT '( 5x,a )', "-h, --help display this help and exit" + PRINT '( 5x,a,/)', "-v, --version output Siren's version information and exit" + IF (PRESENT(cd_err)) THEN + PRINT '(2x,a,/)', 'ERROR DETECTED:' + PRINT '(5x,a,/)', TRIM(cd_err) + ENDIF + + END SUBROUTINE fct_help + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE fct_version(cd_filename) + !------------------------------------------------------------------- + !> @brief + !> This function show the version of Siren. + !> + !> @author J.Paul + !> @date October, 2019 - Initial Version + !> + !> @param[in] cd_filename file name + !> + !> @return print version message + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_filename + !---------------------------------------------------------------- + + PRINT '( /, a,/)', 'PROGRAM: Siren - '//TRIM(cd_filename) + PRINT '(2x,2a )', 'Revision of last commit : ', TRIM(fct_split(fct_split(cp_version,2,'$'),2,'Revision:')) + PRINT '(2x,2a )', 'Author of last commit : ', TRIM(fct_split(fct_split(cp_author,2,'$'),2,'Author:')) + PRINT '(2x,2a )', 'Date of last commit : ', TRIM(fct_split(fct_split(cp_date,2,'$'),2,'Date:')) + PRINT '(2x,2a,/)', 'SVN URL : ', TRIM(fct_split(fct_split(fct_split(cp_url,2,'$'),2,'URL:'),1,'/src/global.f90')) + + END SUBROUTINE fct_version + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE fct + diff --git a/V4.0/nemo_sources/tools/SIREN/src/global.f90 b/V4.0/nemo_sources/tools/SIREN/src/global.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1b8a7fae020b89c3af326f628c8486c5e6446780 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/global.f90 @@ -0,0 +1,150 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module defines global variables and parameters. +!> +!> @author +!> J.paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2015 +!> - define fill value for each variable type +!> @date January, 2019 +!> - define svn URL variable +!> @date October, 2019 +!> - define svn Revision, Date, and Author variable +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE global + + USE kind ! F90 kind parameter + USE netcdf + + IMPLICIT NONE + + PUBLIC :: dp_fill !< default fill value + PUBLIC :: ip_nsep !< number of separator listed + PUBLIC :: ip_ncom !< number of comment character listed + PUBLIC :: cp_sep !< list of separator + PUBLIC :: cp_com !< list of comment character + + PUBLIC :: ip_npoint !< number of point on ARAKAWA C-grid + PUBLIC :: jp_T !< indice for T-point on ARAKAWA C-grid + PUBLIC :: jp_U !< indice for U-point on ARAKAWA C-grid + PUBLIC :: jp_V !< indice for V-point on ARAKAWA C-grid + PUBLIC :: jp_F !< indice for F-point on ARAKAWA C-grid + PUBLIC :: cp_grid_point !< list of grid_point character + + PUBLIC :: ip_maxdim !< maximum number of dimension to be used + PUBLIC :: jp_I !< indice for I-direction + PUBLIC :: jp_J !< indice for J-direction + PUBLIC :: jp_K !< indice for K-direction + PUBLIC :: jp_L !< indice for L-direction + PUBLIC :: cp_dimorder !< dimension order + + PUBLIC :: ip_maxvar !< maximum number of variable + PUBLIC :: ip_maxmtx !< matrix variable maximum dimension + PUBLIC :: ip_maxseg !< maximum number of segment + PUBLIC :: ip_ghost !< number of ghost cell + + PUBLIC :: ip_ninterp !< number of available interpolation method + PUBLIC :: cp_interp_list !< list of interpolation name + + PUBLIC :: ip_nextrap !< number of available extrapolation method + PUBLIC :: cp_extrap_list !< list of extrapolation name + + PUBLIC :: ip_nfilter !< number of available filter + PUBLIC :: cp_filter_list !< list of filter name + + PUBLIC :: ip_ncard !< number of cardinal point + PUBLIC :: cp_card !< array of cardinal point + PUBLIC :: jp_north !< indice for north boundary + PUBLIC :: jp_south !< indice for south boundary + PUBLIC :: jp_east !< indice for east boundary + PUBLIC :: jp_west !< indice for west boundary + + PUBLIC :: ip_maxdimcfg !< maximum dimension in configuration file + PUBLIC :: ip_maxdumcfg !< maximum dummy variable in configuration file + PUBLIC :: cp_url !< svn url + + ! NOTE_avoid_public_variables_if_possible + + INTEGER(i4) , PARAMETER :: ip_maxvar =200 !< maximum number of variable + INTEGER(i4) , PARAMETER :: ip_maxmtx =50 !< matrix variable maximum dimension (cf create_bathy) + INTEGER(i4) , PARAMETER :: ip_maxseg =10 !< maximum number of segment for each boundary + + INTEGER(i4) , PARAMETER :: ip_nsep=2 !< number of separator listed + CHARACTER(1) , DIMENSION(ip_nsep) , PARAMETER :: cp_sep = (/'.','_'/) !< list of separator + + INTEGER(i4) , PARAMETER :: ip_ncom=2 !< number of comment character listed + CHARACTER(1) , DIMENSION(ip_ncom) , PARAMETER :: cp_com = (/'#','!'/) !< list of comment character + + INTEGER(i4) , PARAMETER :: ip_ghost=1 !< number of ghost cell + + INTEGER(i4) , PARAMETER :: ip_ninterp=3 + CHARACTER(LEN=lc), DIMENSION(ip_ninterp), PARAMETER :: cp_interp_list = & + & (/ 'nearest', & + & 'cubic ', & + & 'linear ' /) + + INTEGER(i4) , PARAMETER :: ip_nextrap=2 + CHARACTER(LEN=lc), DIMENSION(ip_nextrap), PARAMETER :: cp_extrap_list = & + & (/ 'dist_weight', & + & 'min_error ' /) + + INTEGER(i4) , PARAMETER :: ip_nfilter=5 + CHARACTER(LEN=lc), DIMENSION(ip_nfilter), PARAMETER :: cp_filter_list = & + & (/ 'butterworth', & + & 'blackman ', & + & 'hamming ', & + & 'hann ', & + & 'gauss '/) + + REAL(dp) , PARAMETER :: dp_fill_i1=NF90_FILL_BYTE !< byte fill value + REAL(dp) , PARAMETER :: dp_fill_i2=NF90_FILL_SHORT !< short fill value + REAL(dp) , PARAMETER :: dp_fill_i4=NF90_FILL_INT !< INT fill value + REAL(dp) , PARAMETER :: dp_fill_sp=NF90_FILL_FLOAT !< real fill value + REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< double fill value + + INTEGER(i4) , PARAMETER :: ip_npoint=4 + INTEGER(i4) , PARAMETER :: jp_T=1 + INTEGER(i4) , PARAMETER :: jp_U=2 + INTEGER(i4) , PARAMETER :: jp_V=3 + INTEGER(i4) , PARAMETER :: jp_F=4 + CHARACTER(LEN=1), DIMENSION(ip_npoint) , PARAMETER :: cp_grid_point = & + & (/ 'T', 'U', 'V', 'F' /) + + + INTEGER(i4) , PARAMETER :: ip_maxdimcfg=10 !< maximum dimension in configuration file + INTEGER(i4) , PARAMETER :: ip_maxdim=4 + INTEGER(i4) , PARAMETER :: jp_I=1 + INTEGER(i4) , PARAMETER :: jp_J=2 + INTEGER(i4) , PARAMETER :: jp_K=3 + INTEGER(i4) , PARAMETER :: jp_L=4 + CHARACTER(LEN=ip_maxdim) , PARAMETER :: cp_dimorder = 'xyzt' !< dimension order to output + + INTEGER(i4) , PARAMETER :: ip_ncard=4 + CHARACTER(LEN=lc), DIMENSION(ip_ncard) , PARAMETER :: cp_card = & + & (/ 'north', & + & 'south', & + & 'east ', & + & 'west ' /) + + INTEGER(i4) , PARAMETER :: jp_north=1 + INTEGER(i4) , PARAMETER :: jp_south=2 + INTEGER(i4) , PARAMETER :: jp_east =3 + INTEGER(i4) , PARAMETER :: jp_west =4 + + INTEGER(i4) , PARAMETER :: ip_maxdumcfg = 10 !< maximum dummy variable, dimension, or attribute + !< in configuration file + + CHARACTER(LEN=lc) , PARAMETER :: cp_url="$URL: https://forge.ipsl.jussieu.fr/nemo/svn/utils/tools_r4.0-HEAD/SIREN/src/global.f90 $" !< svn url + CHARACTER(LEN=lc) , PARAMETER :: cp_version = "$Revision: 12080 $" + CHARACTER(LEN=lc) , PARAMETER :: cp_author = "$Author: jpaul $" + CHARACTER(LEN=lc) , PARAMETER :: cp_date = "$Date: 2019-12-06 09:30:14 +0000 (Fri, 06 Dec 2019) $" + +END MODULE global + diff --git a/V4.0/nemo_sources/tools/SIREN/src/grid.f90 b/V4.0/nemo_sources/tools/SIREN/src/grid.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0150c6358a24847ccad6a6381c0a0f819597fbc4 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/grid.f90 @@ -0,0 +1,6430 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module is grid manager. +!> +!> @details +!> to get NEMO pivot point index:<br/> +!> @code +!> il_pivot=grid_get_pivot(td_file) +!> @endcode +!> - il_pivot is NEMO pivot point index F(0), T(1) +!> - td_file is mpp structure +!> +!> to get NEMO periodicity index:<br/> +!> @code +!> il_perio=grid_get_perio(td_file) +!> @endcode +!> - il_perio is NEMO periodicity index (0,1,2,3,4,5,6) +!> - td_file is mpp structure +!> +!> to check domain validity:<br/> +!> @code +!> CALL grid_check_dom(td_coord, id_imin, id_imax, id_jmin, id_jmax) +!> @endcode +!> - td_coord is coordinates mpp structure +!> - id_imin is i-direction lower left point indice +!> - id_imax is i-direction upper right point indice +!> - id_jmin is j-direction lower left point indice +!> - id_jmax is j-direction upper right point indice +!> +!> to get closest coarse grid indices of fine grid domain:<br/> +!> @code +!> il_index(:,:)=grid_get_coarse_index(td_coord0, td_coord1, +!> [id_rho,] [cd_point]) +!> @endcode +!> or +!> @code +!> il_index(:,:)=grid_get_coarse_index(td_lon0, td_lat0, td_coord1, +!> [id_rho,] [cd_point]) +!> @endcode +!> or +!> @code +!> il_index(:,:)=grid_get_coarse_index(td_coord0, td_lon1, td_lat1, +!> [id_rho,] [cd_point]) +!> @endcode +!> or +!> @code +!> il_index(:,:)=grid_get_coarse_index(td_lon0, td_lat0, td_lon1, td_lat1, +!> [id_rho,] [cd_point]) +!> @endcode +!> - il_index(:,:) is coarse grid indices (/ (/ imin0, imax0 /), +!> (/ jmin0, jmax0 /) /) +!> - td_coord0 is coarse grid coordinate mpp structure +!> - td_coord1 is fine grid coordinate mpp structure +!> - td_lon0 is coarse grid longitude variable structure +!> - td_lat0 is coarse grid latitude variable structure +!> - td_lon1 is fine grid longitude variable structure +!> - td_lat1 is fine grid latitude variable structure +!> - id_rho is array of refinment factor (default 1) +!> - cd_point is Arakawa grid point (default 'T') +!> +!> to know if grid is global:<br/> +!> @code +!> ll_global=grid_is_global(td_lon, td_lat) +!> @endcode +!> - td_lon is longitude variable structure +!> - td_lat is latitude variable structure +!> +!> to know if grid contains north fold:<br/> +!> @code +!> ll_north=grid_is_north_fold(td_lat) +!> @endcode +!> - td_lat is latitude variable structure +!> +!> to get coarse grid indices of the closest point from one fine grid +!> point:<br/> +!> @code +!> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1 +!> [,dd_fill] [,cd_pos]) +!> @endcode +!> - il_index(:) is coarse grid indices (/ i0, j0 /) +!> - dd_lon0 is coarse grid array of longitude value (real(8)) +!> - dd_lat0 is coarse grid array of latitude value (real(8)) +!> - dd_lon1 is fine grid longitude value (real(8)) +!> - dd_lat1 is fine grid latitude value (real(8)) +!> - dd_fill +!> - cd_pos +!> +!> to compute distance between a point A and grid points:<br/> +!> @code +!> il_dist(:,:)=grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA) +!> @endcode +!> - il_dist(:,:) is array of distance between point A and grid points +!> - dd_lon is array of longitude value (real(8)) +!> - dd_lat is array of longitude value (real(8)) +!> - dd_lonA is longitude of point A (real(8)) +!> - dd_latA is latitude of point A (real(8)) +!> +!> to get offset between fine grid and coarse grid:<br/> +!> @code +!> il_offset(:,:)=grid_get_fine_offset(td_coord0, +!> id_imin0, id_jmin0, id_imax0, id_jmax0, +!> td_coord1 +!> [,id_rho] [,cd_point]) +!> @endcode +!> or +!> @code +!> il_offset(:,:)=grid_get_fine_offset(dd_lon0, dd_lat0, +!> id_imin0, id_jmin0,id_imax0, id_jmax0, +!> td_coord1 +!> [,id_rho] [,cd_point]) +!> @endcode +!> or +!> @code +!> il_offset(:,:)=grid_get_fine_offset(td_coord0, +!> id_imin0, id_jmin0, id_imax0, id_jmax0, +!> dd_lon1, dd_lat1 +!> [,id_rho] [,cd_point]) +!> @endcode +!> or +!> @code +!> il_offset(:,:)=grid_get_fine_offset(dd_lon0, dd_lat0, +!> id_imin0, id_jmin0, id_imax0, id_jmax0, +!> dd_lon1, dd_lat1 +!> [,id_rho] [,cd_point]) +!> @endcode +!> - il_offset(:,:) is offset array +!> (/ (/ i_offset_left, i_offset_right /), (/ j_offset_lower, j_offset_upper /) /) +!> - td_coord0 is coarse grid coordinate mpp structure +!> - dd_lon0 is coarse grid longitude array (real(8)) +!> - dd_lat0 is coarse grid latitude array (real(8)) +!> - id_imin0 is coarse grid lower left corner i-indice of fine grid +!> domain +!> - id_jmin0 is coarse grid lower left corner j-indice of fine grid +!> domain +!> - id_imax0 is coarse grid upper right corner i-indice of fine grid +!> domain +!> - id_jmax0 is coarse grid upper right corner j-indice of fine grid +!> domain +!> - td_coord1 is fine grid coordinate mpp structure +!> - dd_lon1 is fine grid longitude array (real(8)) +!> - dd_lat1 is fine grid latitude array (real(8)) +!> - id_rho is array of refinment factor (default 1) +!> - cd_point is Arakawa grid point (default 'T') +!> +!> to check fine and coarse grid coincidence:<br/> +!> @code +!> CALL grid_check_coincidence(td_coord0, td_coord1, +!> id_imin0, id_imax0, id_jmin0, id_jmax0 +!> ,id_rho) +!> @endcode +!> - td_coord0 is coarse grid coordinate mpp structure +!> - td_coord1 is fine grid coordinate mpp structure +!> - id_imin0 is coarse grid lower left corner i-indice of fine grid +!> domain +!> - id_imax0 is coarse grid upper right corner i-indice of fine grid +!> domain +!> - id_jmin0 is coarse grid lower left corner j-indice of fine grid +!> domain +!> - id_jmax0 is coarse grid upper right corner j-indice of fine grid +!> domain +!> - id_rho is array of refinement factor +!> +!> to add ghost cell at boundaries:<br/> +!> @code +!> CALL grid_add_ghost(td_var, id_ghost) +!> @endcode +!> - td_var is array of variable structure +!> - id_ghost is 2D array of ghost cell factor +!> +!> to delete ghost cell at boundaries:<br/> +!> @code +!> CALL grid_del_ghost(td_var, id_ghost) +!> @endcode +!> - td_var is array of variable structure +!> - id_ghost is 2D array of ghost cell factor +!> +!> to get ghost cell factor (use or not):<br/> +!> @code +!> il_factor(:)= grid_get_ghost( td_var ) +!> @endcode +!> or +!> @code +!> il_factor(:)= grid_get_ghost( td_mpp ) +!> @endcode +!> - il_factor(:) is array of ghost cell factor (0 or 1) +!> - td_var is variable structure +!> - td_mpp is mpp sturcture +!> +!> to compute closed sea domain:<br/> +!> @code +!> il_mask(:,:)=grid_split_domain(td_var, [id_level]) +!> @endcode +!> - il_mask(:,:) is domain mask +!> - td_var is variable strucutre +!> - id_level is level to be used [optional] +!> +!> to fill small closed sea with _FillValue:<br/> +!> @code +!> CALL grid_fill_small_dom(td_var, id_mask, [id_minsize]) +!> @endcode +!> - td_var is variable structure +!> - id_mask is domain mask (from grid_split_domain) +!> - id_minsize is minimum size of sea to be kept [optional] +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header +!> @date October, 2014 +!> - use mpp file structure instead of file +!> @date February, 2015 +!> - add function grid_fill_small_msk to fill small domain inside bigger one +!> @date February, 2016 +!> - improve way to check coincidence (bug fix) +!> - manage grid cases for T,U,V or F point, with even or odd refinment (bug fix) +!> @date April, 2016 +!> - add function to get closest grid point using coarse grid coordinates strucutre +!> @date May, 2019 +!> - define as module variable im_max_overlap +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE grid + + USE netcdf + USE kind ! F90 kind parameter + USE fct ! basic usefull function + USE global ! global parameter + USE phycst ! physical constant + USE logger ! log file manager + USE file ! file manager + USE att ! attribute manager + USE var ! variable manager + USE dim ! dimension manager + USE iom ! I/O manager + USE mpp ! MPP manager + USE dom ! domain manager + USE iom_mpp ! MPP I/O manager + USE iom_dom ! DOM I/O manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + INTEGER(i4), PARAMETER :: im_max_overlap = 5 + + ! function and subroutine + PUBLIC :: grid_get_info !< get information about mpp global domain (pivot, perio, ew) + PUBLIC :: grid_get_pivot !< get NEMO pivot point index + PUBLIC :: grid_get_perio !< get NEMO periodicity index + PUBLIC :: grid_get_ew_overlap !< get East West overlap + PUBLIC :: grid_check_dom !< check domain validity + PUBLIC :: grid_get_coarse_index !< get closest coarse grid indices of fine grid domain. + PUBLIC :: grid_is_global !< check if grid is global or not + PUBLIC :: grid_is_north_fold + PUBLIC :: grid_get_closest !< return closest coarse grid point from another point + PUBLIC :: grid_distance !< compute grid distance to a point + PUBLIC :: grid_get_fine_offset !< get fine grid offset + PUBLIC :: grid_check_coincidence !< check fine and coarse grid coincidence + PUBLIC :: grid_add_ghost !< add ghost cell at boundaries. + PUBLIC :: grid_del_ghost !< delete ghost cell at boundaries. + PUBLIC :: grid_get_ghost !< return ghost cell factor + PUBLIC :: grid_split_domain !< compute closed sea domain + PUBLIC :: grid_fill_small_dom !< fill small closed sea with fill value + PUBLIC :: grid_fill_small_msk !< fill small domain inside bigger one + + ! get closest coarse grid indices of fine grid domain + PRIVATE :: grid__get_coarse_index_ff ! - using coarse and fine grid coordinates files + PRIVATE :: grid__get_coarse_index_cf ! - using coarse grid array of lon,lat and fine grid coordinates files + PRIVATE :: grid__get_coarse_index_fc ! - using coarse grid coordinates files, and fine grid array of lon,lat + PRIVATE :: grid__get_coarse_index_cc ! - using coarse and fine grid array of lon,lat + + ! return closest coarse grid point from another point + PRIVATE :: grid__get_closest_str ! - using coarse grid coordinates strucutre + PRIVATE :: grid__get_closest_arr ! - using coarse grid array of lon,lat + + ! get offset between fine and coarse grid + PRIVATE :: grid__get_fine_offset_ff ! - using coarse and fine grid coordinates files + PRIVATE :: grid__get_fine_offset_cf ! - using coarse grid array of lon,lat and fine grid coordinates files + PRIVATE :: grid__get_fine_offset_fc ! - using coarse grid coordinates files, and fine grid array of lon,lat + PRIVATE :: grid__get_fine_offset_cc ! - using coarse and fine grid array of lon,lat + + ! get information about global domain (pivot, perio, ew) + PRIVATE :: grid__get_info_mpp ! - using mpp files structure + PRIVATE :: grid__get_info_file ! - using files structure + + ! get NEMO pivot point index + PRIVATE :: grid__get_pivot_mpp ! - using mpp files structure + PRIVATE :: grid__get_pivot_file ! - using files structure + PRIVATE :: grid__get_pivot_var ! - using variable structure + PRIVATE :: grid__get_pivot_varT ! compute NEMO pivot point index for variable on grid T + PRIVATE :: grid__get_pivot_varU ! compute NEMO pivot point index for variable on grid U + PRIVATE :: grid__get_pivot_varV ! compute NEMO pivot point index for variable on grid V + PRIVATE :: grid__get_pivot_varF ! compute NEMO pivot point index for variable on grid F + + ! get NEMO periodicity index + PRIVATE :: grid__get_perio_mpp ! - using mpp files structure + PRIVATE :: grid__get_perio_file ! - using files structure + PRIVATE :: grid__get_perio_var ! - using variable structure + + ! get East West overlap + PRIVATE :: grid__get_ew_overlap_mpp ! - using mpp files structure + PRIVATE :: grid__get_ew_overlap_file ! - using files structure + PRIVATE :: grid__get_ew_overlap_var ! - using longitude variable structure + + ! return ghost cell factor + PRIVATE :: grid__get_ghost_mpp ! - using mpp files structure + PRIVATE :: grid__get_ghost_var ! - using array of lon,lat + PRIVATE :: grid__check_corner ! check that fine grid is inside coarse grid + PRIVATE :: grid__check_lat ! check that fine grid latitude are inside coarse grid latitude + + INTERFACE grid_get_info + MODULE PROCEDURE grid__get_info_mpp + MODULE PROCEDURE grid__get_info_file + END INTERFACE grid_get_info + + INTERFACE grid_get_pivot + MODULE PROCEDURE grid__get_pivot_mpp + MODULE PROCEDURE grid__get_pivot_file + MODULE PROCEDURE grid__get_pivot_var + END INTERFACE grid_get_pivot + + INTERFACE grid_get_perio + MODULE PROCEDURE grid__get_perio_mpp + MODULE PROCEDURE grid__get_perio_file + MODULE PROCEDURE grid__get_perio_var + END INTERFACE grid_get_perio + + INTERFACE grid_get_ew_overlap + MODULE PROCEDURE grid__get_ew_overlap_mpp + MODULE PROCEDURE grid__get_ew_overlap_file + MODULE PROCEDURE grid__get_ew_overlap_var + END INTERFACE grid_get_ew_overlap + + INTERFACE grid_get_ghost + MODULE PROCEDURE grid__get_ghost_var + MODULE PROCEDURE grid__get_ghost_mpp + END INTERFACE grid_get_ghost + + INTERFACE grid_get_closest + MODULE PROCEDURE grid__get_closest_str + MODULE PROCEDURE grid__get_closest_arr + END INTERFACE grid_get_closest + + INTERFACE grid_get_coarse_index + MODULE PROCEDURE grid__get_coarse_index_ff + MODULE PROCEDURE grid__get_coarse_index_cf + MODULE PROCEDURE grid__get_coarse_index_fc + MODULE PROCEDURE grid__get_coarse_index_cc + END INTERFACE grid_get_coarse_index + + INTERFACE grid_get_fine_offset + MODULE PROCEDURE grid__get_fine_offset_ff + MODULE PROCEDURE grid__get_fine_offset_fc + MODULE PROCEDURE grid__get_fine_offset_cf + MODULE PROCEDURE grid__get_fine_offset_cc + END INTERFACE grid_get_fine_offset + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid__get_info_file(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine get information about global domain, given file + !> strucutre. + !> + !> @details + !> open edge files then: + !> - compute NEMO pivot point + !> - compute NEMO periodicity + !> - compute East West overlap + !> + !> @note need all processor files to be there + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_ew + INTEGER(i4) :: il_pivot + INTEGER(i4) :: il_perio + INTEGER(i4) :: il_attid + + TYPE(TATT) :: tl_att + + TYPE(TFILE) :: tl_file + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! initialise + il_pivot=-1 + il_perio=-1 + il_ew =-1 + + ! copy structure + tl_file=file_copy(td_file) + + ! open file to be used + CALL iom_open(tl_file) + + IF( td_file%i_perio >= 0 .AND. td_file%i_perio <= 6 )THEN + il_perio=td_file%i_perio + ELSE + ! look for attribute in file + il_attid=att_get_index(tl_file%t_att(:),'periodicity') + IF( il_attid /= 0 )THEN + il_perio=INT(tl_file%t_att(il_attid)%d_value(1),i4) + ENDIF + ENDIF + + IF( td_file%i_ew >= 0 )THEN + il_ew=td_file%i_ew + ELSE + ! look for attribute in file + il_attid=att_get_index(tl_file%t_att(:),'ew_overlap') + IF( il_attid /= 0 )THEN + il_ew=INT(tl_file%t_att(il_attid)%d_value(1),i4) + ENDIF + ENDIF + + SELECT CASE(il_perio) + CASE(3,4) + il_pivot=0 + CASE(5,6) + il_pivot=1 + CASE(0,1,2) + il_pivot=1 + END SELECT + + IF( il_pivot < 0 .OR. il_pivot > 1 )THEN + ! get pivot + il_pivot=grid_get_pivot(tl_file) + ENDIF + + IF( il_perio < 0 .OR. il_perio > 6 )THEN + ! get periodicity + il_perio=grid_get_perio(tl_file, il_pivot) + ENDIF + + IF( il_ew < 0 )THEN + ! get periodicity + il_ew=grid_get_ew_overlap(tl_file) + ENDIF + + ! close + CALL iom_close(tl_file) + + !save in file structure + td_file%i_ew=il_ew + td_file%i_pivot=il_pivot + td_file%i_perio=il_perio + + ! save in variable of file structure + tl_att=att_init("ew_overlap",il_ew) + DO ji=1,td_file%i_nvar + IF( td_file%t_var(ji)%t_dim(jp_I)%l_use )THEN + CALL var_move_att(td_file%t_var(ji),tl_att) + ENDIF + ENDDO + + ! clean + CALL file_clean(tl_file) + CALL att_clean(tl_att) + + IF( td_file%i_perio == -1 )THEN + CALL logger_fatal("GRID GET INFO: can not read or compute "//& + & "domain periodicity from file "//TRIM(td_file%c_name)//"."//& + & " you have to inform periodicity in namelist.") + ENDIF + + END SUBROUTINE grid__get_info_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid__get_info_mpp(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine get information about global domain, given mpp + !> structure. + !> + !> @details + !> open edge files then: + !> - compute NEMO pivot point + !> - compute NEMO periodicity + !> - compute East West overlap + !> + !> @note need all processor files + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + + ! local variable + INTEGER(i4) :: il_ew + INTEGER(i4) :: il_pivot + INTEGER(i4) :: il_perio + INTEGER(i4) :: il_attid + + TYPE(TATT) :: tl_att + + TYPE(TMPP) :: tl_mpp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! initialise + il_pivot=-1 + il_perio=-1 + il_ew =-1 + + CALL logger_info("GRID GET INFO: look for "//TRIM(td_mpp%c_name)) + ! copy structure + tl_mpp=mpp_copy(td_mpp) + ! select edge files + CALL mpp_get_contour(tl_mpp) + ! open mpp file to be used + CALL iom_mpp_open(tl_mpp) + + IF( td_mpp%i_perio >= 0 .AND. td_mpp%i_perio <= 6 )THEN + il_perio=td_mpp%i_perio + ELSE + ! look for attribute in mpp files + il_attid=att_get_index(tl_mpp%t_proc(1)%t_att(:),'periodicity') + IF( il_attid /= 0 )THEN + il_perio=INT(tl_mpp%t_proc(1)%t_att(il_attid)%d_value(1),i4) + ENDIF + ENDIF + + IF( td_mpp%i_ew >= 0 )THEN + il_ew=td_mpp%i_ew + ELSE + ! look for attribute in mpp files + il_attid=att_get_index(tl_mpp%t_proc(1)%t_att(:),'ew_overlap') + IF( il_attid /= 0 )THEN + il_ew=INT(tl_mpp%t_proc(1)%t_att(il_attid)%d_value(1),i4) + ENDIF + ENDIF + + CALL logger_info("GRID GET INFO: perio "//TRIM(fct_str(il_perio))) + + SELECT CASE(il_perio) + CASE(3,4) + il_pivot=1 + CASE(5,6) + il_pivot=0 + CASE(0,1,2) + il_pivot=1 + END SELECT + + IF( il_pivot < 0 .OR. il_pivot > 1 )THEN + ! get pivot + CALL logger_info("GRID GET INFO: look for pivot ") + il_pivot=grid_get_pivot(tl_mpp) + ENDIF + + IF( il_perio < 0 .OR. il_perio > 6 )THEN + ! get periodicity + CALL logger_info("GRID GET INFO: look for perio ") + il_perio=grid_get_perio(tl_mpp, il_pivot) + ENDIF + + IF( il_ew < 0 )THEN + ! get periodicity + CALL logger_info("GRID GET INFO: look for overlap ") + il_ew=grid_get_ew_overlap(tl_mpp) + ENDIF + + ! close + CALL iom_mpp_close(tl_mpp) + + !save in mpp structure + td_mpp%i_ew=il_ew + td_mpp%i_pivot=il_pivot + td_mpp%i_perio=il_perio + + ! save in variable of mpp structure + IF( ASSOCIATED(td_mpp%t_proc) )THEN + tl_att=att_init("ew_overlap",il_ew) + DO jj=1,td_mpp%i_nproc + DO ji=1,td_mpp%t_proc(jj)%i_nvar + IF( td_mpp%t_proc(jj)%t_var(ji)%t_dim(jp_I)%l_use )THEN + CALL var_move_att(td_mpp%t_proc(jj)%t_var(ji),tl_att) + ENDIF + ENDDO + ENDDO + ENDIF + + ! clean + CALL mpp_clean(tl_mpp) + CALL att_clean(tl_att) + + IF( td_mpp%i_perio == -1 )THEN + CALL logger_fatal("GRID GET INFO: can not read or compute "//& + & "domain periodicity from mpp "//TRIM(td_mpp%c_name)//"."//& + & " you have to inform periodicity in namelist.") + ENDIF + + END SUBROUTINE grid__get_info_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_var(td_var) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index of the input variable. + !> - F-point : 0 + !> - T-point : 1 + !> + !> @details + !> check north points of latitude grid (indices jpj to jpj-3) depending on which grid point + !> (T,F,U,V) variable is defined + !> + !> @note variable must be at least 2D variable, and should not be coordinate + !> variable (i.e lon, lat) + !> + !> @warning + !> - do not work with ORCA2 grid (T-point) + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date September, 2014 + !> - add dummy loop in case variable not over right point. + !> @date October, 2014 + !> - work on variable structure instead of file structure + !> + !> @param[in] td_lat latitude variable structure + !> @param[in] td_var variable structure + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + IF( .NOT. ASSOCIATED(td_var%d_value) .OR. & + &.NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN + CALL logger_error("GRID GET PIVOT: can not compute pivot point"//& + & " with variable "//TRIM(td_var%c_name)//"."//& + & " no value associated or missing dimension.") + ELSE + il_dim(:)=td_var%t_dim(:)%i_len + + ALLOCATE(dl_value(il_dim(1),4,1,1)) + ! extract value + dl_value(:,:,:,:)=td_var%d_value( 1:il_dim(1), & + & il_dim(2)-3:il_dim(2),& + & 1:1, & + & 1:1 ) + + SELECT CASE(TRIM(td_var%c_point)) + CASE('T') + if_pivot=grid__get_pivot_varT(dl_value) + CASE('U') + if_pivot=grid__get_pivot_varU(dl_value) + CASE('V') + if_pivot=grid__get_pivot_varV(dl_value) + CASE('F') + if_pivot=grid__get_pivot_varF(dl_value) + END SELECT + + ! dummy loop in case variable not over right point + ! (ex: nav_lon over U-point) + IF( if_pivot == -1 )THEN + + ! no pivot point found + CALL logger_warn("GRID GET PIVOT: something wrong "//& + & "when computing pivot point with variable "//& + & TRIM(td_var%c_name)) + + DO jj=1,ip_npoint + SELECT CASE(TRIM(cp_grid_point(jj))) + CASE('T') + CALL logger_debug("GRID GET PIVOT: check variable on point T") + if_pivot=grid__get_pivot_varT(dl_value) + CASE('U') + CALL logger_debug("GRID GET PIVOT: check variable on point U") + if_pivot=grid__get_pivot_varU(dl_value) + CASE('V') + CALL logger_debug("GRID GET PIVOT: check variable on point V") + if_pivot=grid__get_pivot_varV(dl_value) + CASE('F') + CALL logger_debug("GRID GET PIVOT: check variable on point F") + if_pivot=grid__get_pivot_varF(dl_value) + END SELECT + + IF( if_pivot /= -1 )THEN + CALL logger_info("GRID GET PIVOT: variable "//& + & TRIM(td_var%c_name)//" seems to be on grid point "//& + & TRIM(cp_grid_point(jj)) ) + EXIT + ENDIF + + ENDDO + ENDIF + + IF( if_pivot == -1 )THEN + CALL logger_warn("GRID GET PIVOT: not able to found pivot point. "//& + & "Force to use pivot point T.") + if_pivot = 1 + ENDIF + + ! clean + DEALLOCATE(dl_value) + + ENDIF + + END FUNCTION grid__get_pivot_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_varT(dd_value) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index for variable on grid T. + !> + !> @details + !> - F-point : 0 + !> - T-point : 1 + !> + !> @note array of value must be only the top border of the domain. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> + !> @param[in] dd_value array of value + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_midT + INTEGER(i4) :: il_midF + + INTEGER(i4) :: it1 + INTEGER(i4) :: it2 + INTEGER(i4) :: jt1 + INTEGER(i4) :: jt2 + + INTEGER(i4) :: if1 + INTEGER(i4) :: if2 + INTEGER(i4) :: jf1 + INTEGER(i4) :: jf2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_check + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + il_dim(:)=SHAPE(dd_value(:,:,:,:)) + + ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid + jt1=4 ; jt2=2 + il_midT=il_dim(1)/2+1 + + ! F-point pivot !case of ORCA05 grid + jf1=4 ; jf2=3 + il_midF=il_dim(1)/2 + + ! check T-point pivot + DO ji=2,il_midT + ll_check=.TRUE. + it1=ji + it2=il_dim(1)-(ji-2) + IF( dd_value(it1,jt1,1,1) /= dd_value(it2,jt2,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: T-pivot") + if_pivot=1 + ELSE + + ! check F-point pivot + DO ji=1,il_midF + ll_check=.TRUE. + if1=ji + if2=il_dim(1)-(ji-1) + IF( dd_value(if1,jf1,1,1) /= dd_value(if2,jf2,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: F-pivot") + if_pivot=0 + ENDIF + + ENDIF + + END FUNCTION grid__get_pivot_varT + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_varU(dd_value) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index for variable on grid U. + !> + !> @details + !> - F-point : 0 + !> - T-point : 1 + !> + !> @note array of value must be only the top border of the domain. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> + !> @param[in] dd_value array of value + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_midT + INTEGER(i4) :: il_midF + + INTEGER(i4) :: it1 + INTEGER(i4) :: it2 + INTEGER(i4) :: jt1 + INTEGER(i4) :: jt2 + + INTEGER(i4) :: if1 + INTEGER(i4) :: if2 + INTEGER(i4) :: jf1 + INTEGER(i4) :: jf2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_check + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + il_dim(:)=SHAPE(dd_value(:,:,:,:)) + + ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid + jt1=4 ; jt2=2 + il_midT=il_dim(1)/2+1 + + ! F-point pivot !case of ORCA05 grid + jf1=4 ; jf2=3 + il_midF=il_dim(1)/2 + + ! check T-point pivot + DO ji=1,il_midT + ll_check=.TRUE. + it1=ji + it2=il_dim(1)-(ji-2) + IF( dd_value(it1,jt1,1,1) /= dd_value(it2-1,jt2,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: T-pivot") + if_pivot=1 + ELSE + + ! check F-point pivot + DO ji=1,il_midF + ll_check=.TRUE. + if1=ji + if2=il_dim(1)-(ji-1) + IF( dd_value(if1,jf1,1,1) /= dd_value(if2-1,jf2,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: F-pivot") + if_pivot=0 + ENDIF + + ENDIF + + END FUNCTION grid__get_pivot_varU + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_varV(dd_value) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index for variable on grid V. + !> + !> @details + !> - F-point : 0 + !> - T-point : 1 + !> + !> @note array of value must be only the top border of the domain. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> + !> @param[in] dd_value array of value + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_midT + INTEGER(i4) :: il_midF + + INTEGER(i4) :: it1 + INTEGER(i4) :: it2 + INTEGER(i4) :: jt1 + INTEGER(i4) :: jt2 + + INTEGER(i4) :: if1 + INTEGER(i4) :: if2 + INTEGER(i4) :: jf1 + INTEGER(i4) :: jf2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_check + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + il_dim(:)=SHAPE(dd_value(:,:,:,:)) + + ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid + jt1=4 ; jt2=2 + il_midT=il_dim(1)/2+1 + + ! F-point pivot !case of ORCA05 grid + jf1=4 ; jf2=3 + il_midF=il_dim(1)/2 + + ! check T-point pivot + DO ji=2,il_midT + ll_check=.TRUE. + it1=ji + it2=il_dim(1)-(ji-2) + IF( dd_value(it1,jt1,1,1) /= dd_value(it2,jt2-1,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: T-pivot") + if_pivot=1 + ELSE + + ! check F-point pivot + DO ji=1,il_midF + ll_check=.TRUE. + if1=ji + if2=il_dim(1)-(ji-1) + IF( dd_value(if1,jf1,1,1) /= dd_value(if2,jf2-1,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: F-pivot") + if_pivot=0 + ENDIF + + ENDIF + + END FUNCTION grid__get_pivot_varV + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_varF(dd_value) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index for variable on grid F. + !> + !> @details + !> - F-point : 0 + !> - T-point : 1 + !> + !> @note array of value must be only the top border of the domain. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> + !> @param[in] dd_value array of value + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_midT + INTEGER(i4) :: il_midF + + INTEGER(i4) :: it1 + INTEGER(i4) :: it2 + INTEGER(i4) :: jt1 + INTEGER(i4) :: jt2 + + INTEGER(i4) :: if1 + INTEGER(i4) :: if2 + INTEGER(i4) :: jf1 + INTEGER(i4) :: jf2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_check + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + il_dim(:)=SHAPE(dd_value(:,:,:,:)) + + ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid + jt1=4 ; jt2=2 + il_midT=il_dim(1)/2+1 + + ! F-point pivot !case of ORCA05 grid + jf1=4 ; jf2=3 + il_midF=il_dim(1)/2 + + ! check T-point pivot + DO ji=1,il_midT + ll_check=.TRUE. + it1=ji + it2=il_dim(1)-(ji-2) + IF( dd_value(it1,jt1,1,1) /= dd_value(it2-1,jt2-1,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: T-pivot") + if_pivot=1 + ELSE + + ! check F-point pivot + DO ji=1,il_midF + ll_check=.TRUE. + if1=ji + if2=il_dim(1)-(ji-1) + IF( dd_value(if1,jf1,1,1) /= dd_value(if2-1,jf2-1,1,1) )THEN + ll_check=.FALSE. + EXIT + ENDIF + ENDDO + + IF( ll_check )THEN + CALL logger_info("GRID GET PIVOT: F-pivot") + if_pivot=0 + ENDIF + + ENDIF + + END FUNCTION grid__get_pivot_varF + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_file(td_file) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index from input file variable. + !> - F-point : 0 + !> - T-point : 1 + !> + !> @details + !> check north points symmetry of a 2D variable (indices jpj to jpj-3), depending on which grid point + !> (T,F,U,V) variable is defined. + !> + !> @warning + !> - do not work with ORCA2 grid (T-point) + !> + !> @author J.Paul + !> @date Ocotber, 2014 - Initial version + !> @date August, 2017 + !> - if can't find latitude variable, assume there is a north fold + !> - do not use latitude variable to get pivot (to avoid mistake with regular + !> grid) + !> + !> @param[in] td_file file structure + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_varid + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_north + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_lat + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + ! look for north fold + il_varid=var_get_index(td_file%t_var(:), 'latitude') + IF( il_varid == 0 )THEN + CALL logger_error("GRID GET PIVOT: no variable with name "//& + & "or standard name latitude in file structure "//& + & TRIM(td_file%c_name)//". Assume there is north fold and "//& + & "try to get pivot point") + + ll_north=.TRUE. + ELSE + IF( ASSOCIATED(td_file%t_var(il_varid)%d_value) )THEN + tl_lat=var_copy(td_file%t_var(il_varid)) + ELSE + tl_lat=iom_read_var(td_file, 'latitude') + ENDIF + + ll_north=grid_is_north_fold(tl_lat) + ! clean + CALL var_clean(tl_lat) + ENDIF + + IF( ll_north )THEN + ! look for suitable variable + DO ji=1,td_file%i_nvar + IF( .NOT. ALL(td_file%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE + + IF( ASSOCIATED(td_file%t_var(ji)%d_value) )THEN + tl_var=var_copy(td_file%t_var(ji)) + ELSE + il_dim(:)=td_file%t_var(ji)%t_dim(:)%i_len + tl_var=iom_read_var(td_file, & + & td_file%t_var(ji)%c_name, & + & id_start=(/1,il_dim(2)-3,1,1/), & + & id_count=(/il_dim(1),4,1,1/) ) + ENDIF + ENDDO + + IF( ASSOCIATED(tl_var%d_value) )THEN + + if_pivot=grid_get_pivot(tl_var) + + ENDIF + + ! clean + CALL var_clean(tl_var) + ELSE + CALL logger_warn("GRID GET PIVOT: no north fold. force to use T-PIVOT") + if_pivot=1 + ENDIF + + END FUNCTION grid__get_pivot_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_pivot_mpp(td_mpp) & + & RESULT (if_pivot) + !------------------------------------------------------------------- + !> @brief + !> This function compute NEMO pivot point index from input mpp variable. + !> - F-point : 0 + !> - T-point : 1 + !> + !> @details + !> check north points symmetry of a 2D variable (indices jpj to jpj-3), depending + !> on which grid point (T,F,U,V) variable is defined. + !> + !> @warning + !> - do not work with ORCA2 grid (T-point) + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> @date August, 2017 + !> - if can't find latitude variable, assume there is a north fold + !> - do not use latitude variable to get pivot (to avoid mistake with regular + !> grid) + !> + !> @param[in] td_mpp mpp file structure + !> @return pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + + ! function + INTEGER(i4) :: if_pivot + + ! local variable + INTEGER(i4) :: il_varid + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + LOGICAL :: ll_north + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_lat + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! intitalise + if_pivot=-1 + + ! look for north fold + il_varid=var_get_index(td_mpp%t_proc(1)%t_var(:), 'latitude') + IF( il_varid == 0 )THEN + CALL logger_error("GRID GET PIVOT: no variable with name "//& + & "or standard name latitude in mpp structure "//& + & TRIM(td_mpp%c_name)//". Assume there is north fold and "//& + & "try to get pivot point") + + ll_north=.TRUE. + ELSE + IF( ASSOCIATED(td_mpp%t_proc(1)%t_var(il_varid)%d_value) )THEN + ! + tl_lat=mpp_recombine_var(td_mpp, 'latitude') + ELSE + tl_lat=iom_mpp_read_var(td_mpp, 'latitude') + ENDIF + + ll_north=grid_is_north_fold(tl_lat) + ! clean + CALL var_clean(tl_lat) + ENDIF + + IF( ll_north )THEN + + ! look for suitable variable + DO ji=1,td_mpp%t_proc(1)%i_nvar + IF(.NOT. ALL(td_mpp%t_proc(1)%t_var(ji)%t_dim(1:2)%l_use)) CYCLE + + IF( ASSOCIATED(td_mpp%t_proc(1)%t_var(ji)%d_value) )THEN + CALL logger_debug("GRID GET PIVOT: mpp_recombine_var"//& + & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)) + tl_var=mpp_recombine_var(td_mpp, & + & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)) + ELSE + CALL logger_debug("GRID GET PIVOT: iom_mpp_read_var "//& + & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)) + il_dim(:)=td_mpp%t_dim(:)%i_len + + ! read variable + tl_var=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(ji)%c_name, & + & id_start=(/1,il_dim(2)-3,1,1/), & + & id_count=(/il_dim(1),4,1,1/) ) + ENDIF + EXIT + ENDDO + + IF( ASSOCIATED(tl_var%d_value) )THEN + + if_pivot=grid_get_pivot(tl_var) + + ELSE + CALL logger_warn("GRID GET PIVOT: force to use T-PIVOT") + if_pivot=1 + ENDIF + + ! clean + CALL var_clean(tl_var) + ELSE + CALL logger_warn("GRID GET PIVOT: no north fold. force to use T-PIVOT") + if_pivot=1 + ENDIF + + END FUNCTION grid__get_pivot_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_perio_var(td_var, id_pivot) & + & RESULT (if_perio) + !------------------------------------------------------------------- + !> @brief + !> This subroutine search NEMO periodicity index given variable structure and + !> pivot point index. + !> @details + !> The variable must be on T point. + !> + !> 0: closed boundaries + !> 1: cyclic east-west boundary + !> 2: symmetric boundary condition across the equator + !> 3: North fold boundary (with a T-point pivot) + !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary + !> 5: North fold boundary (with a F-point pivot) + !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary + !> + !> @warning pivot point should have been computed before run this script. see grid_get_pivot. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date October, 2014 + !> - work on variable structure instead of file structure + !> + !> @param[in] td_var variable structure + !> @param[in] id_pivot pivot point index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + INTEGER(i4), INTENT(IN) :: id_pivot + + ! function + INTEGER(i4) :: if_perio + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + ! loop indices + !---------------------------------------------------------------- + ! intitalise + if_perio=-1 + + IF( id_pivot < 0 .OR. id_pivot > 1 )THEN + CALL logger_error("GRID GET PERIO: invalid pivot point index. "//& + & "you should use grid_get_pivot to compute it") + ENDIF + + IF( .NOT. ASSOCIATED(td_var%d_value) .OR. & + & .NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN + CALL logger_error("GRID GET PERIO: can not compute periodicity"//& + & " with variable "//TRIM(td_var%c_name)//"."//& + & " no value associated or missing dimension.") + ELSE + + il_dim(:)=td_var%t_dim(:)%i_len + + CALL logger_debug("GRID GET PERIO: use variable "//TRIM(td_var%c_name)) + CALL logger_debug("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill))) + CALL logger_debug("GRID GET PERIO: first value "//TRIM(fct_str(td_var%d_value(1,1,1,1)))) + + IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value(il_dim(1), : ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value( : , 1 ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN + ! no boundary closed + CALL logger_error("GRID GET PERIO: can't determined periodicity. "//& + & "there is no boundary closed for variable "//& + & TRIM(td_var%c_name) ) + ! check pivot + SELECT CASE(id_pivot) + CASE(0) + ! F pivot + CALL logger_warn("GRID GET PERIO: assume domain is global") + if_perio=6 + CASE(1) + ! T pivot + CALL logger_warn("GRID GET PERIO: assume domain is global") + if_perio=4 + END SELECT + ELSE + if_perio=-1 + ! check periodicity + IF(ANY(td_var%d_value( 1 ,:,1,1)/=td_var%d_fill).OR.& + & ANY(td_var%d_value(il_dim(1),:,1,1)/=td_var%d_fill))THEN + ! East-West cyclic (1,4,6) + + IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN + ! South boundary not closed + + CALL logger_debug("GRID GET PERIO: East_West cyclic") + CALL logger_debug("GRID GET PERIO: South boundary not closed") + CALL logger_error("GRID GET PERIO: should have been an "//& + & "impossible case") + + ELSE + ! South boundary closed (1,4,6) + CALL logger_info("GRID GET PERIO: South boundary closed") + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill) )THEN + ! North boundary not closed (4,6) + CALL logger_info("GRID GET PERIO: North boundary not closed") + ! check pivot + SELECT CASE(id_pivot) + CASE(0) + ! F pivot + if_perio=6 + CASE(1) + ! T pivot + if_perio=4 + CASE DEFAULT + CALL logger_error("GRID GET PERIO: invalid pivot ") + END SELECT + ELSE + ! North boundary closed + CALL logger_info("GRID GET PERIO: North boundary closed") + if_perio=1 ! North and South boundaries closed + ENDIF + + ENDIF + + ELSE + ! East-West boundaries closed (0,2,3,5) + CALL logger_info("GRID GET PERIO: East West boundaries closed") + + IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN + ! South boundary not closed (2) + CALL logger_info("GRID GET PERIO: South boundary not closed") + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN + ! North boundary not closed + CALL logger_debug("GRID GET PERIO: East West boundaries "//& + & "closed") + CALL logger_debug("GRID GET PERIO: South boundary not closed") + CALL logger_debug("GRID GET PERIO: North boundary not closed") + CALL logger_error("GRID GET PERIO: should have been "//& + & "an impossible case") + ELSE + ! North boundary closed + if_perio=2 ! East-West and North boundaries closed + ENDIF + + ELSE + ! South boundary closed (0,3,5) + CALL logger_info("GRID GET PERIO: South boundary closed") + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN + ! North boundary not closed (3,5) + CALL logger_info("GRID GET PERIO: North boundary not closed") + ! check pivot + SELECT CASE(id_pivot) + CASE(0) + ! F pivot + if_perio=5 + CASE(1) + ! T pivot + if_perio=3 + CASE DEFAULT + CALL logger_error("GRID GET PERIO: invalid pivot") + END SELECT + ELSE + ! North boundary closed + CALL logger_info("GRID GET PERIO: North boundary closed") + if_perio=0 ! all boundary closed + ENDIF + + ENDIF + + ENDIF + + ENDIF + + ENDIF + + END FUNCTION grid__get_perio_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_perio_file(td_file, id_pivot) & + & RESULT (if_perio) + !------------------------------------------------------------------- + !> @brief + !> This subroutine search NEMO periodicity index given file structure, and + !> optionaly pivot point index. + !> @details + !> The variable used must be on T point. + !> + !> 0: closed boundaries + !> 1: cyclic east-west boundary + !> 2: symmetric boundary condition across the equator + !> 3: North fold boundary (with a F-point pivot) + !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary + !> 5: North fold boundary (with a T-point pivot) + !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary + !> + !> @warning pivot point should have been computed before run this script. see grid_get_pivot. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> @date August, 2017 + !> - read only grid boundaries to handle huge file + !> + !> @param[in] td_file file structure + !> @param[in] id_pivot pivot point index + !> @return NEMO periodicity index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot + + ! function + INTEGER(i4) :: if_perio + + ! local variable + INTEGER(i4) :: il_idx + INTEGER(i4) :: il_pivot + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + !initialise + if_perio=-1 + + IF(PRESENT(id_pivot) )THEN + il_pivot=id_pivot + ELSE + il_pivot=grid_get_pivot(td_file) + ENDIF + + IF( il_pivot < 0 .OR. il_pivot > 1 )THEN + CALL logger_error("GRID GET PERIO: invalid pivot point index. "//& + & "you should use grid_get_pivot to compute it") + ENDIF + + ! look for suitable variable + il_idx=0 + DO ji=1,td_file%i_nvar + IF( .NOT. ALL(td_file%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE + SELECT CASE(TRIM(fct_lower(td_file%t_var(ji)%c_stdname)) ) + CASE('longitude','latitude') + CASE DEFAULT + il_idx=ji + EXIT + END SELECT + ENDDO + + IF( il_idx==0 )THEN + + CALL logger_error("GRID GET PERIO: no suitable variable to compute "//& + & " periodicity in file "//TRIM(td_file%c_name)) + + ELSE + + DO ji=1,ip_maxdim + IF( td_file%t_var(il_idx)%t_dim(ji)%l_use )THEN + il_dim(ji)= td_file%t_var(il_idx)%t_dim(ji)%i_len + ELSE + il_dim(ji)=1 + ENDIF + ENDDO + + ! read variable (full array) + !tl_var=iom_read_var(td_file, & + !& td_file%t_var(il_idx)%c_name, & + !& id_start=(/1,1,1,1/), & + !& id_count=(/il_dim(1),il_dim(2),1,1/) ) + + ! read variable (only usefull part) + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/1,1,1,1/), & + & id_count=(/il_dim(1),1,1,1/) ) + + ! copy variable struct here, to get change done inside read_var too. + tl_var=var_copy(tl_tmp,ld_value=.false.) + ! force dimension to be full domain dimension + ! (instead of proc dimension) + tl_var%t_dim(:)%i_len=il_dim(:) + ALLOCATE(tl_var%d_value(il_dim(jp_I), & + & il_dim(jp_J), & + & il_dim(jp_K), & + & il_dim(jp_L))) + + tl_var%d_value(:,1,1,1)=tl_tmp%d_value(:,1,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/1,il_dim(2),1,1/), & + & id_count=(/il_dim(1),1,1,1/) ) + + tl_var%d_value(:,il_dim(2),1,1)=tl_tmp%d_value(:,1,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/1,1,1,1/), & + & id_count=(/1,il_dim(2),1,1/) ) + + tl_var%d_value(1,:,1,1)=tl_tmp%d_value(1,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/il_dim(1),1,1,1/), & + & id_count=(/1,il_dim(2),1,1/) ) + + tl_var%d_value(il_dim(1),:,1,1)=tl_tmp%d_value(1,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + if_perio=grid_get_perio(tl_var,il_pivot) + + ! clean + CALL var_clean(tl_var) + + ENDIF + + END FUNCTION grid__get_perio_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_perio_mpp(td_mpp, id_pivot) & + & RESULT (if_perio) + !------------------------------------------------------------------- + !> @brief + !> This subroutine search NEMO periodicity given mpp structure and optionaly + !> pivot point index. + !> @details + !> The variable used must be on T point. + !> + !> 0: closed boundaries + !> 1: cyclic east-west boundary + !> 2: symmetric boundary condition across the equator + !> 3: North fold boundary (with a T-point pivot) + !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary + !> 5: North fold boundary (with a F-point pivot) + !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary + !> + !> @warning pivot point should have been computed before run this script. see grid_get_pivot. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> @date August, 2017 + !> - read only grid boundaries to handle huge file + !> @date January, 2019 + !> - do not use silicalim, or silicamax to get pivot point + !> + !> @todo + !> do not check silicalim, or silicamax + !> + !> @param[in] td_mpp mpp file structure + !> @param[in] id_pivot pivot point index + !> @return NEMO periodicity index + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot + + ! function + INTEGER(i4) :: if_perio + + ! local variable + INTEGER(i4) :: il_idx + INTEGER(i4) :: il_pivot + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! initialise + if_perio=-1 + + IF(PRESENT(id_pivot) )THEN + il_pivot=id_pivot + ELSE + il_pivot=grid_get_pivot(td_mpp) + ENDIF + + IF( il_pivot < 0 .OR. il_pivot > 1 )THEN + CALL logger_error("GRID GET PERIO: invalid pivot point index. "//& + & "you should use grid_get_pivot to compute it") + ENDIF + + ! look for suitable variable + il_idx=0 + DO ji=1,td_mpp%t_proc(1)%i_nvar + IF( .NOT. ALL(td_mpp%t_proc(1)%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE + SELECT CASE(TRIM(fct_lower(td_mpp%t_proc(1)%t_var(ji)%c_stdname)) ) + CASE('longitude','latitude') + CASE DEFAULT + SELECT CASE(TRIM(fct_lower(td_mpp%t_proc(1)%t_var(ji)%c_name))) + CASE('silicalim','silicamax') + CASE DEFAULT + il_idx=ji + EXIT + END SELECT + END SELECT + ENDDO + + IF( il_idx==0 )THEN + + CALL logger_error("GRID GET PERIO: no suitable variable to compute "//& + & " periodicity in file "//TRIM(td_mpp%c_name)) + + ELSE + + ! full domain dimension + DO ji=1,ip_maxdim + IF( td_mpp%t_proc(1)%t_var(il_idx)%t_dim(ji)%l_use )THEN + il_dim(ji)=td_mpp%t_dim(ji)%i_len + ELSE + il_dim(ji)=1 + ENDIF + ENDDO + + ! read variable (full array) + !tl_var=iom_mpp_read_var(td_mpp, td_mpp%t_proc(1)%t_var(il_idx)%c_name) + + ! read variable (only usefull part) + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/1,1,1,1/), & + & id_count=(/il_dim(1),1,1,1/) ) + + ! copy variable struct here, to get change done inside read_var too. + tl_var=var_copy(tl_tmp,ld_value=.false.) + ! force dimension to be full domain dimension + ! (instead of proc dimension) + tl_var%t_dim(:)%i_len=il_dim(:) + ALLOCATE(tl_var%d_value(il_dim(jp_I), & + & il_dim(jp_J), & + & il_dim(jp_K), & + & il_dim(jp_L))) + + tl_var%d_value(:,1,1,1)=tl_tmp%d_value(:,1,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/1,il_dim(2),1,1/), & + & id_count=(/il_dim(1),1,1,1/) ) + + tl_var%d_value(:,il_dim(2),1,1)=tl_tmp%d_value(:,1,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/1,1,1,1/), & + & id_count=(/1,il_dim(2),1,1/) ) + + tl_var%d_value(1,:,1,1)=tl_tmp%d_value(1,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/il_dim(1),1,1,1/), & + & id_count=(/1,il_dim(2),1,1/) ) + + tl_var%d_value(il_dim(1),:,1,1)=tl_tmp%d_value(1,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + if_perio=grid_get_perio(tl_var, il_pivot) + + ! clean + CALL var_clean(tl_var) + ENDIF + + END FUNCTION grid__get_perio_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_ew_overlap_var(td_var) & + & RESULT (if_overlap) + !------------------------------------------------------------------- + !> @brief This function get East-West overlap. + !> + !> @details + !> If no East-West wrap return -1, + !> else return the size of the ovarlap band. + !> East-West overlap is computed comparing longitude value of the + !> South part of the domain, to avoid north fold boundary. + !> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date October, 2016 + !> - check longitude as longname + !> + !> @param[in] td_lon longitude variable structure + !> @return East West overlap + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! function + INTEGER(i4) :: if_overlap + + ! local variable + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_value + REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_vare + REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_varw + + REAL(dp) :: dl_delta + REAL(dp) :: dl_varmax + REAL(dp) :: dl_varmin + + INTEGER(i4) :: il_east + INTEGER(i4) :: il_west + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! initialise + if_overlap=-1 + + IF( ASSOCIATED(td_var%d_value) )THEN + + IF( td_var%t_dim(1)%i_len > 1 )THEN + il_west=1 + il_east=td_var%t_dim(1)%i_len + + ALLOCATE( dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len) ) + + dl_value(:,:)=td_var%d_value(:,:,1,1) + + ! we do not use jmax as dimension length due to north fold boundary + IF( td_var%t_dim(2)%i_len > 1 )THEN + il_jmin=1+ip_ghost + il_jmax=(td_var%t_dim(2)%i_len-ip_ghost)/2 + ELSE + il_jmin=1 + il_jmax=1 + ENDIF + + ALLOCATE( dl_vare(il_jmax-il_jmin+1) ) + ALLOCATE( dl_varw(il_jmax-il_jmin+1) ) + + dl_vare(:)=dl_value(il_east,il_jmin:il_jmax) + dl_varw(:)=dl_value(il_west,il_jmin:il_jmax) + + IF( .NOT.( ALL(dl_vare(:)==td_var%d_fill) .AND. & + & ALL(dl_varw(:)==td_var%d_fill) ) )THEN + + IF( TRIM(td_var%c_stdname) == 'longitude' .OR. & + & SCAN( TRIM(td_var%c_longname), 'longitude') == 0 )THEN + WHERE( dl_value(:,:) > 180._dp .AND. & + & dl_value(:,:) /= td_var%d_fill ) + dl_value(:,:)=360.-dl_value(:,:) + END WHERE + + dl_varmax=MAXVAL(dl_value(:,il_jmin:il_jmax)) + dl_varmin=MINVAL(dl_value(:,il_jmin:il_jmax)) + + dl_delta=(dl_varmax-dl_varmin)/td_var%t_dim(1)%i_len + + IF( ALL(ABS(dl_vare(:)) - ABS(dl_varw(:)) == dl_delta) )THEN + if_overlap=0 + ENDIF + ENDIF + + IF( if_overlap == -1 )THEN + DO ji=0,im_max_overlap + + IF( il_east-ji == il_west )THEN + ! case of small domain + EXIT + ELSE + dl_vare(:)=dl_value(il_east-ji,il_jmin:il_jmax) + + IF( ALL( dl_varw(:) == dl_vare(:) ) )THEN + if_overlap=ji+1 + EXIT + ENDIF + ENDIF + + ENDDO + ENDIF + ENDIF + + ENDIF + ELSE + CALL logger_error("GRID GET EW OVERLAP: input variable standard name"//& + & TRIM(td_var%c_stdname)//" can not be used to compute East West "//& + & "overalp. no value associated. ") + ENDIF + + END FUNCTION grid__get_ew_overlap_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_ew_overlap_file(td_file) & + & RESULT (if_overlap) + !------------------------------------------------------------------- + !> @brief This function get East-West overlap. + !> + !> @details + !> If no East-West wrap return -1, + !> else return the size of the ovarlap band. + !> East-West overlap is computed comparing longitude value of the + !> South part of the domain, to avoid north fold boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> @date October, 2016 + !> - check varid for longitude_T + !> @date August, 2017 + !> - read only grid boundaries to handle huge file + !> + !> @param[in] td_file file structure + !> @return East West overlap + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! function + INTEGER(i4) :: if_overlap + + ! local variable + INTEGER(i4) :: il_idx + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + INTEGER(i4) :: j1 + INTEGER(i4) :: j2 + INTEGER(i4) :: ic + INTEGER(i4) :: jc + !---------------------------------------------------------------- + + ! look for suitable variable + il_idx=var_get_index(td_file%t_var(:), 'longitude', 'longitude_T') + IF( il_idx == 0 )THEN + DO jj=1,td_file%i_nvar + IF( ALL(td_file%t_var(jj)%t_dim(1:2)%l_use) )THEN + il_idx=jj + EXIT + ENDIF + ENDDO + ENDIF + + IF( il_idx==0 )THEN + + CALL logger_error("GRID GET EW OVERLAP: no suitable variable to compute "//& + & " east west overlap in file "//TRIM(td_file%c_name)) + + ELSE + ! read variable (full array) + !tl_var=iom_read_var(td_file, td_file%t_var(il_idx)%c_name) + + ! full domain dimension + DO ji=1,ip_maxdim + IF( td_file%t_var(il_idx)%t_dim(ji)%l_use )THEN + il_dim(ji)= td_file%t_var(il_idx)%t_dim(ji)%i_len + ELSE + il_dim(ji)=1 + ENDIF + ENDDO + + ! read variable (only usefull part) + i1=1 ; j1=1 + i2=im_max_overlap ; j2=il_dim(jp_J) + ic=i2-i1+1 ; jc=j2-j1+1 + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/i1,j1,1,1/), & + & id_count=(/ic,jc,1,1/) ) + + ! copy variable struct here, to get change done inside read_var too. + tl_var=var_copy(tl_tmp,ld_value=.false.) + ! force dimension to be full domain dimension + ! (instead of proc dimension) + tl_var%t_dim(:)%i_len=il_dim(:) + ALLOCATE(tl_var%d_value(il_dim(jp_I), & + & il_dim(jp_J), & + & il_dim(jp_K), & + & il_dim(jp_L))) + ! init array + tl_var%d_value(:,:,:,:)=tl_var%d_fill + + tl_var%d_value(i1:i2,:,1,1)=tl_tmp%d_value(:,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + i1=il_dim(jp_I)-im_max_overlap ; j1=1 + i2=il_dim(jp_I) ; j2=il_dim(jp_J) + ic=i2-i1+1 ; jc=j2-j1+1 + tl_tmp=iom_read_var(td_file, & + & td_file%t_var(il_idx)%c_name, & + & id_start=(/i1,j1,1,1/), & + & id_count=(/ic,jc,1,1/) ) + + tl_var%d_value(i1:i2,:,1,1)=tl_tmp%d_value(:,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + if_overlap=grid_get_ew_overlap(tl_var) + + ! clean + CALL var_clean(tl_var) + + ENDIF + + END FUNCTION grid__get_ew_overlap_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_ew_overlap_mpp(td_mpp) & + & RESULT (if_overlap) + !------------------------------------------------------------------- + !> @brief This function get East-West overlap. + !> + !> @details + !> If no East-West wrap return -1, + !> else return the size of the ovarlap band. + !> East-West overlap is computed comparing longitude value of the + !> South part of the domain, to avoid north fold boundary. + !> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date October, 2016 + !> - check varid for longitude_T + !> @date August, 2017 + !> - read only grid boundaries to handle huge file + !> + !> @param[in] td_mpp mpp structure + !> @return East West overlap + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! function + INTEGER(i4) :: if_overlap + + ! local variable + INTEGER(i4) :: il_idx + INTEGER(i4) :: il_ew + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + INTEGER(i4) :: j1 + INTEGER(i4) :: j2 + INTEGER(i4) :: ic + INTEGER(i4) :: jc + !---------------------------------------------------------------- + + ! initialise + if_overlap=td_mpp%i_ew + + il_idx=var_get_index(td_mpp%t_proc(1)%t_var(:), 'longitude', 'longitude_T') + IF( il_idx == 0 )THEN + DO jj=1,td_mpp%t_proc(1)%i_nvar + IF( ALL(td_mpp%t_proc(1)%t_var(jj)%t_dim(1:2)%l_use) )THEN + il_idx=jj + EXIT + ENDIF + ENDDO + ENDIF + + IF( il_idx==0 )THEN + + CALL logger_error("GRID GET EW OVERLAP: no suitable variable to compute "//& + & " east west overlap in mppfile "//TRIM(td_mpp%c_name)) + + ELSE + ! read variable (full array) + !tl_var=iom_mpp_read_var(td_mpp, il_idx) + + ! full domain dimension + DO ji=1,ip_maxdim + IF( td_mpp%t_proc(1)%t_var(il_idx)%t_dim(ji)%l_use )THEN + !il_dim(ji)=td_mpp%t_proc(1)%t_var(il_idx)%t_dim(ji)%i_len + il_dim(ji)=td_mpp%t_dim(ji)%i_len + ELSE + il_dim(ji)=1 + ENDIF + ENDDO + + ! read variable (only usefull part) + i1=1 ; j1=1 + i2=im_max_overlap ; j2=il_dim(jp_J) + ic=i2-i1+1 ; jc=j2-j1+1 + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/i1,j1,1,1/), & + & id_count=(/ic,jc,1,1/) ) + + ! copy variable struct here, to get change done inside read_var too. + tl_var=var_copy(tl_tmp,ld_value=.false.) + ! force dimension to be full domain dimension + ! (instead of proc dimension) + tl_var%t_dim(:)%i_len=il_dim(:) + ALLOCATE(tl_var%d_value(il_dim(jp_I), & + & il_dim(jp_J), & + & il_dim(jp_K), & + & il_dim(jp_L))) + ! init array + tl_var%d_value(:,:,:,:)=tl_var%d_fill + + tl_var%d_value(i1:i2,:,1,1)=tl_tmp%d_value(:,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + ! read variable (only usefull part) + i1=il_dim(jp_I)-im_max_overlap ; j1=1 + i2=il_dim(jp_I) ; j2=il_dim(jp_J) + ic=i2-i1+1 ; jc=j2-j1+1 + tl_tmp=iom_mpp_read_var(td_mpp, & + & td_mpp%t_proc(1)%t_var(il_idx)%c_name, & + & id_start=(/i1,j1,1,1/), & + & id_count=(/ic,jc,1,1/) ) + + tl_var%d_value(i1:i2,:,1,1)=tl_tmp%d_value(:,:,1,1) + ! clean + CALL var_clean(tl_tmp) + + il_ew=grid_get_ew_overlap(tl_var) + IF( il_ew >= 0 )THEN + if_overlap=il_ew + ENDIF + + ! clean + CALL var_clean(tl_var) + + ENDIF + + END FUNCTION grid__get_ew_overlap_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_is_north_fold(td_lat) & + & RESULT (lf_north) + !------------------------------------------------------------------- + !> @brief This subroutine check if there is north fold. + !> + !> @details + !> check if maximum latitude greater than 88°N + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_lat latitude variable structure + !> @return true if there is north fold + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_lat + + ! function + LOGICAL :: lf_north + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + ! init + lf_north=.FALSE. + + IF( .NOT. ASSOCIATED(td_lat%d_value) )THEN + CALL logger_error("GRID IS NORTH FOLD: "//& + & " no value associated to latitude") + ELSE + IF( MAXVAL(td_lat%d_value(:,:,:,:), & + & td_lat%d_value(:,:,:,:)/= td_lat%d_fill) >= 88.0 )THEN + + lf_north=.TRUE. + + ENDIF + ENDIF + + END FUNCTION grid_is_north_fold + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_check_dom(td_coord, id_imin, id_imax, id_jmin, id_jmax) + !------------------------------------------------------------------- + !> @brief This subroutine check domain validity. + !> + !> @details + !> If maximum latitude greater than 88°N, program will stop. + !> @note Not able to manage north fold for now. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] cd_coord coordinate file + !> @param[in] id_imin i-direction lower left point indice + !> @param[in] id_imax i-direction upper right point indice + !> @param[in] id_jmin j-direction lower left point indice + !> @param[in] id_jmax j-direction upper right point indice + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_coord + INTEGER(i4), INTENT(IN) :: id_imin + INTEGER(i4), INTENT(IN) :: id_imax + INTEGER(i4), INTENT(IN) :: id_jmin + INTEGER(i4), INTENT(IN) :: id_jmax + + ! local variable + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_ind + + TYPE(TVAR) :: tl_var + + TYPE(TMPP) :: tl_coord + + TYPE(TDOM) :: tl_dom + ! loop indices + !---------------------------------------------------------------- + + IF( id_jmin > id_jmax .OR. id_jmax == 0 )THEN + + CALL logger_fatal("GRID CHECK DOM: invalid domain. "//& + & "can not create configuration with north pole.") + + ELSE + + IF( id_imin == id_imax .AND. td_coord%i_ew < 0 )THEN + CALL logger_fatal("GRID CHECK DOM: invalid domain."//& + & " can not create east-west cyclic fine grid"//& + & " inside closed coarse grid") + ENDIF + + ! copy structure + tl_coord=mpp_copy(td_coord) + + ! compute domain + tl_dom=dom_init( tl_coord, & + & id_imin, id_imax,& + & id_jmin, id_jmax ) + + ! open mpp files to be used + CALL iom_dom_open(tl_coord, tl_dom) + + ! read variable value on domain + WRITE(cl_name,*) 'latitude' + il_ind=var_get_id(tl_coord%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID CHECK DOM: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord%c_name)//". & + & try to use latitude_T.") + WRITE(cl_name,*) 'latitude_T' + ENDIF + tl_var=iom_dom_read_var(tl_coord,TRIM(cl_name),tl_dom) + + ! close mpp files + CALL iom_dom_close(tl_coord) + + ! clean structure + CALL mpp_clean(tl_coord) + + IF( MAXVAL(tl_var%d_value(:,:,:,:), & + & tl_var%d_value(:,:,:,:)/= tl_var%d_fill) >= 88.0 )THEN + + CALL logger_debug("GRID CHECK DOM: max latitude "//& + & TRIM(fct_str(MAXVAL(tl_var%d_value(:,:,:,:)))) ) + CALL logger_fatal("GRID CHECK DOM: invalid domain. "//& + & "can not create configuration too close from north pole.") + + ENDIF + + ! clean + CALL dom_clean(tl_dom) + CALL var_clean(tl_var) + + ENDIF + + END SUBROUTINE grid_check_dom + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_coarse_index_ff(td_coord0, td_coord1, & + & id_rho, cd_point) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function get closest coarse grid indices of fine grid domain. + !> + !> @details + !> it use coarse and fine grid coordinates files. + !> optionally, you could specify the array of refinment factor (default 1.) + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use grid point to read coordinates variable. + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date February, 2015 + !> - use longitude or latitude as standard name, if can not find + !> longitude_T, latitude_T... + !> + !> @param[in] td_coord0 coarse grid coordinate mpp structure + !> @param[in] td_coord1 fine grid coordinate mpp structure + !> @param[in] id_rho array of refinment factor (default 1.) + !> @param[in] cd_point Arakawa grid point (default 'T'). + !> @return coarse grid indices(/(/imin0, imax0/), (/jmin0, jmax0/)/) + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_coord0 + TYPE(TMPP) , INTENT(IN) :: td_coord1 + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_idx + + ! local variable + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_ind + + INTEGER(i4), DIMENSION(2,2) :: il_xghost0 + INTEGER(i4), DIMENSION(2,2) :: il_xghost1 + + INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + + ! loop indices + !---------------------------------------------------------------- + + ! init + if_idx(:,:)=0 + + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + tl_coord1=mpp_copy(td_coord1) + + IF( .NOT. ASSOCIATED(tl_coord0%t_proc) .OR. & + & .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN + CALL logger_error("GRID GET COARSE INDEX: can not get coarse "//& + & "grid indices. decompsition of mpp file "//TRIM(tl_coord0%c_name)//& + & " and/or "//TRIM(tl_coord1%c_name)//" not defined." ) + ELSE + ! Coarse grid + ! get ghost cell factor on coarse grid + il_xghost0(:,:)=grid_get_ghost( tl_coord0 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! read coarse longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) + CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + ! Fine grid + + ! get ghost cell factor on fine grid + il_xghost1(:,:)=grid_get_ghost( tl_coord1 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! read fine longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + CALL grid_del_ghost(tl_lon1, il_xghost1(:,:)) + CALL grid_del_ghost(tl_lat1, il_xghost1(:,:)) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + ! compute + if_idx(:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,& + & tl_lon1,tl_lat1,& + & il_rho(:) ) + + ! add ghost cell to indices + il_imin0=if_idx(1,1)+il_xghost0(jp_I,1)*ip_ghost + il_imax0=if_idx(1,2)+il_xghost0(jp_I,1)*ip_ghost + + il_jmin0=if_idx(2,1)+il_xghost0(jp_J,1)*ip_ghost + il_jmax0=if_idx(2,2)+il_xghost0(jp_J,1)*ip_ghost + + if_idx(jp_I,1)=il_imin0 + if_idx(jp_I,2)=il_imax0 + if_idx(jp_J,1)=il_jmin0 + if_idx(jp_J,2)=il_jmax0 + + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + + ENDIF + + ! clean + CALL mpp_clean(tl_coord0) + CALL mpp_clean(tl_coord1) + DEALLOCATE(il_rho) + + END FUNCTION grid__get_coarse_index_ff + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_coarse_index_cf(td_lon0, td_lat0, td_coord1, & + & id_rho, cd_point) & + & RESULT (if_id) + !------------------------------------------------------------------- + !> @brief This function get closest coarse grid indices of fine grid domain. + !> + !> @details + !> it use coarse array of longitude and latitude and fine grid coordinates file. + !> optionaly, you could specify the array of refinment factor (default 1.) + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use grid point to read coordinates variable. + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date February, 2015 + !> - use longitude or latitude as standard name, if can not find + !> longitude_T, latitude_T... + !> + !> @param[in] td_longitude0 coarse grid longitude + !> @param[in] td_latitude0 coarse grid latitude + !> @param[in] td_coord1 fine grid coordinate mpp structure + !> @param[in] id_rho array of refinment factor + !> @param[in] cd_point Arakawa grid point (default 'T') + !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR ) , INTENT(IN) :: td_lon0 + TYPE(TVAR ) , INTENT(IN) :: td_lat0 + TYPE(TMPP ) , INTENT(IN) :: td_coord1 + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4), DIMENSION(2,2) :: if_id + + ! local variable + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_ind + + INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho + + INTEGER(i4), DIMENSION(2,2) :: il_xghost + + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + TYPE(TMPP) :: tl_coord1 + + ! loop indices + !---------------------------------------------------------------- + + ! init + if_id(:,:)=0 + + ALLOCATE(il_rho(ip_maxdim) ) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + ! copy structure + tl_coord1=mpp_copy(td_coord1) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + IF( .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN + CALL logger_error("GRID GET COARSE INDEX: decompsition of mpp "//& + & "file "//TRIM(tl_coord1%c_name)//" not defined." ) + + ELSE IF( .NOT. ASSOCIATED(td_lon0%d_value) .OR. & + & .NOT. ASSOCIATED(td_lat0%d_value) )THEN + + CALL logger_error("GRID GET COARSE INDEX: some coarse grid"//& + & " coordinate value are not associated.") + + ELSE + + IF( TRIM(td_lon0%c_point)/='' )THEN + cl_point=TRIM(td_lon0%c_point) + ELSEIF( TRIM(td_lat0%c_point)/='' )THEN + cl_point=TRIM(td_lat0%c_point) + ENDIF + + ! Fine grid + ! get ghost cell factor on fine grid + il_xghost(:,:)=grid_get_ghost( tl_coord1 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! read fine longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + CALL grid_del_ghost(tl_lon1, il_xghost(:,:)) + CALL grid_del_ghost(tl_lat1, il_xghost(:,:)) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + ! compute + if_id(:,:)=grid_get_coarse_index(td_lon0,td_lat0,& + & tl_lon1,tl_lat1,& + & il_rho(:), cl_point ) + + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + + ENDIF + + DEALLOCATE(il_rho) + CALL mpp_clean(tl_coord1) + + END FUNCTION grid__get_coarse_index_cf + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_coarse_index_fc(td_coord0, td_lon1, td_lat1, & + & id_rho, cd_point) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function get closest coarse grid indices of fine grid domain. + !> + !> @details + !> it use coarse grid coordinates file and fine grid array of longitude and latitude. + !> optionaly, you could specify the array of refinment factor (default 1.) + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use grid point to read coordinates variable. + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date February, 2015 + !> - use longitude or latitude as standard name, if can not find + !> longitude_T, latitude_T... + !> + !> @param[in] td_coord0 coarse grid coordinate mpp structure + !> @param[in] td_lon1 fine grid longitude + !> @param[in] td_lat1 fine grid latitude + !> @param[in] id_rho array of refinment factor (default 1.) + !> @param[in] cd_point Arakawa grid point (default 'T') + !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP ) , INTENT(IN) :: td_coord0 + TYPE(TVAR ) , INTENT(IN) :: td_lon1 + TYPE(TVAR ) , INTENT(IN) :: td_lat1 + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_idx + + ! local variable + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_ind + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4), DIMENSION(2,2) :: il_xghost + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + + TYPE(TMPP) :: tl_coord0 + + ! loop indices + !---------------------------------------------------------------- + + ! init + if_idx(:,:)=0 + + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + + IF( .NOT. ASSOCIATED(tl_coord0%t_proc) )THEN + CALL logger_error("GRID GET COARSE INDEX: decompsition of mpp "//& + & "file "//TRIM(tl_coord0%c_name)//" not defined." ) + + ELSE IF( .NOT. ASSOCIATED(td_lon1%d_value) .OR. & + & .NOT. ASSOCIATED(td_lat1%d_value) )THEN + + CALL logger_error("GRID GET COARSE INDEX: some fine grid"//& + & " coordinate value are not associated.") + + ELSE + + IF( TRIM(td_lon1%c_point)/='' )THEN + cl_point=TRIM(td_lon1%c_point) + ELSEIF( TRIM(td_lat1%c_point)/='' )THEN + cl_point=TRIM(td_lat1%c_point) + ENDIF + + ! get ghost cell factor on coarse grid + il_xghost(:,:)=grid_get_ghost( tl_coord0 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! read coarse longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET COARSE INDEX: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + CALL grid_del_ghost(tl_lon0, il_xghost(:,:)) + CALL grid_del_ghost(tl_lat0, il_xghost(:,:)) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + if_idx(:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,& + & td_lon1,td_lat1,& + & il_rho(:), cl_point ) + + ! remove ghost cell + il_imin0=if_idx(1,1)+il_xghost(jp_I,1)*ip_ghost + il_imax0=if_idx(1,2)+il_xghost(jp_I,1)*ip_ghost + + il_jmin0=if_idx(2,1)+il_xghost(jp_J,1)*ip_ghost + il_jmax0=if_idx(2,2)+il_xghost(jp_J,1)*ip_ghost + + if_idx(1,1)=il_imin0 + if_idx(1,2)=il_imax0 + if_idx(2,1)=il_jmin0 + if_idx(2,2)=il_jmax0 + + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + + ENDIF + + CALL mpp_clean(tl_coord0) + DEALLOCATE(il_rho) + + END FUNCTION grid__get_coarse_index_fc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_coarse_index_cc(td_lon0, td_lat0, td_lon1, td_lat1, & + & id_rho, cd_point) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function get closest coarse grid indices of fine grid domain. + ! + !> @details + !> it use coarse and fine grid array of longitude and latitude. + !> optionaly, you could specify the array of refinment factor (default 1.) + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> + !> @note do not use ghost cell + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - check grid point + !> - take into account EW overlap + !> @date February, 2016 + !> - use delta (lon or lat) + !> - manage cases for T,U,V or F point, with even or odd refinment + !> + !> @param[in] td_lon0 coarse grid longitude + !> @param[in] td_lat0 coarse grid latitude + !> @param[in] td_lon1 fine grid longitude + !> @param[in] td_lat1 fine grid latitude + !> @param[in] id_rho array of refinment factor + !> @param[in] cd_point Arakawa grid point ('T','U','V','F') + !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/) + !> + !> @todo + !> -check case boundary domain on overlap band + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_lon0 + TYPE(TVAR) , INTENT(IN) :: td_lat0 + TYPE(TVAR) , INTENT(IN) :: td_lon1 + TYPE(TVAR) , INTENT(IN) :: td_lat1 + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_idx + + ! local variable + CHARACTER(LEN= 1) :: cl_point0 + CHARACTER(LEN= 1) :: cl_point1 + + LOGICAL , DIMENSION(2) :: ll_even + + REAL(dp) :: dl_lon1 + REAL(dp) :: dl_dlon + REAL(dp) :: dl_lat1 + REAL(dp) :: dl_dlat + + INTEGER(i4) :: il_ew0 + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) :: il_ew1 + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4), DIMENSION(2) :: il_ill + INTEGER(i4), DIMENSION(2) :: il_ilr + INTEGER(i4), DIMENSION(2) :: il_iul + INTEGER(i4), DIMENSION(2) :: il_iur + + INTEGER(i4), DIMENSION(2,2) :: il_xghost0 + INTEGER(i4), DIMENSION(2,2) :: il_yghost0 + INTEGER(i4), DIMENSION(2,2) :: il_xghost1 + INTEGER(i4), DIMENSION(2,2) :: il_yghost1 + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + ! loop indices + !---------------------------------------------------------------- + ! init + if_idx(:,:)=0 + + ALLOCATE( il_rho(ip_maxdim) ) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) + + cl_point0='T' + cl_point1='T' + IF( PRESENT(cd_point) )THEN + cl_point0=TRIM(fct_upper(cd_point)) + cl_point1=TRIM(fct_upper(cd_point)) + ENDIF + + IF( .NOT. ASSOCIATED(td_lon0%d_value) .OR. & + & .NOT. ASSOCIATED(td_lat0%d_value) .OR. & + & .NOT. ASSOCIATED(td_lon1%d_value) .OR. & + & .NOT. ASSOCIATED(td_lat1%d_value) )THEN + CALL logger_error("GRID GET COARSE INDEX: some fine or coarse grid"//& + & " coordinate value not associated.") + ELSE + + IF( TRIM(td_lon0%c_point)/='' )THEN + cl_point0=TRIM(td_lon0%c_point) + ELSEIF( TRIM(td_lat0%c_point)/='' )THEN + cl_point0=TRIM(td_lat0%c_point) + ENDIF + IF( TRIM(td_lon1%c_point)/='' )THEN + cl_point1=TRIM(td_lon1%c_point) + ELSEIF( TRIM(td_lat1%c_point)/='' )THEN + cl_point1=TRIM(td_lat1%c_point) + ENDIF + IF( cl_point0 /= cl_point1 )THEN + CALL logger_error("GRID GET COARSE INDEX: fine and coarse grid"//& + & " coordinate not on same grid point.") + ENDIF + + IF( grid_is_global(td_lon1, td_lat1) )THEN + + IF( grid_is_global(td_lon0, td_lat0) )THEN + CALL logger_trace("GRID GET COARSE INDEX: fine grid is global ") + if_idx(:,:) = 1 + if_idx(:,:) = 0 + ELSE + CALL logger_error("GRID GET COARSE INDEX: fine grid is "//& + & "global, coarse grid not.") + ENDIF + + ELSE + + il_xghost0(:,:)=grid_get_ghost( td_lon0 ) + il_yghost0(:,:)=grid_get_ghost( td_lat0 ) + IF( ANY(il_xghost0(:,:) /= il_yghost0(:,:)) )THEN + CALL logger_error("GRID GET COARSE INDEX: coarse grid "//& + & "coordinate do not share same ghost cell") + ENDIF + + tl_lon0=var_copy(td_lon0) + tl_lat0=var_copy(td_lat0) + CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) + CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) + + ! "global" coarse grid indice + il_imin0=1 + il_jmin0=1 + + il_imax0=tl_lon0%t_dim(1)%i_len + il_jmax0=tl_lon0%t_dim(2)%i_len + + ! get east west overlap for coarse grid + il_ew0=tl_lon0%i_ew + IF( il_ew0 >= 0 )THEN + ! last point before overlap + il_imax0=il_imax0-il_ew0 + ENDIF + + il_xghost1(:,:)=grid_get_ghost( td_lon1 ) + il_yghost1(:,:)=grid_get_ghost( td_lat1 ) + IF( ANY(il_xghost1(:,:) /= il_yghost1(:,:)) )THEN + CALL logger_error("GRID GET COARSE INDEX: fine grid "//& + & "coordinate do not share same ghost cell") + ENDIF + + tl_lon1=var_copy(td_lon1) + tl_lat1=var_copy(td_lat1) + CALL grid_del_ghost(tl_lon1, il_xghost1(:,:)) + CALL grid_del_ghost(tl_lat1, il_xghost1(:,:)) + + ! "global" fine grid indice + il_imin1=1 + il_jmin1=1 + + il_imax1=tl_lon1%t_dim(1)%i_len + il_jmax1=tl_lon1%t_dim(2)%i_len + + ! get east west overlap for fine grid + il_ew1=tl_lon1%i_ew + IF( il_ew1 >= 0 )THEN + ! last point before overlap + il_imax1=il_imax1-il_ew1 + ENDIF + + ! get indices for each corner + !1- search lower left corner indices + dl_lon1=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 ) + dl_lat1=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 ) + + IF( dl_lon1 == tl_lon1%d_fill .OR. & + & dl_lat1 == tl_lat1%d_fill )THEN + CALL logger_error("GRID GET COARSE INDEX: lower left corner "//& + & "point is FillValue. remove ghost cell "//& + & "before running grid_get_coarse_index.") + ENDIF + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','U') + dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & + & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & + & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & + & 2. + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','V') + dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & + & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & + & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & + & 2. + ENDIF + + dl_lon1 = dl_lon1 + dl_dlon + dl_lat1 = dl_lat1 + dl_dlat + + ! look for closest point on coarse grid + il_ill(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & tl_lat0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & dl_lon1, dl_lat1, 'll' ) + + + !2- search upper left corner indices + dl_lon1=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 ) + dl_lat1=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 ) + + IF( dl_lon1 == tl_lon1%d_fill .OR. & + & dl_lat1 == tl_lat1%d_fill )THEN + CALL logger_error("GRID GET COARSE INDEX: upper left corner "//& + & "point is FillValue. remove ghost cell "//& + & "running grid_get_coarse_index.") + ENDIF + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','U') + dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & + & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & + & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & + & 2. + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','V') + dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & + & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & + & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & + & 2. + ENDIF + + dl_lon1 = dl_lon1 + dl_dlon + dl_lat1 = dl_lat1 - dl_dlat + + ! look for closest point on coarse grid + il_iul(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & tl_lat0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & dl_lon1, dl_lat1, 'ul' ) + + !3- search lower right corner indices + dl_lon1=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 ) + dl_lat1=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 ) + + IF( dl_lon1 == tl_lon1%d_fill .OR. & + & dl_lat1 == tl_lat1%d_fill )THEN + CALL logger_error("GRID GET COARSE INDEX: lower right corner "//& + & "point is FillValue. remove ghost cell "//& + & "running grid_get_coarse_index.") + ENDIF + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','U') + dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & + & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & + & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & + & 2. + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','V') + dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & + & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & + & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & + & 2. + ENDIF + + dl_lon1 = dl_lon1 - dl_dlon + dl_lat1 = dl_lat1 + dl_dlat + + ! look for closest point on coarse grid + il_ilr(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & tl_lat0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & dl_lon1, dl_lat1, 'lr' ) + + !4- search upper right corner indices + dl_lon1=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 ) + dl_lat1=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 ) + + IF( dl_lon1 == tl_lon1%d_fill .OR. & + & dl_lat1 == tl_lat1%d_fill )THEN + CALL logger_error("GRID GET COARSE INDEX: upper right corner "//& + & "point is FillValue. remove ghost cell "//& + & "before running grid_get_coarse_index.") + ENDIF + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','U') + dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & + & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & + & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & + & 2. + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point1)) + CASE('F','V') + dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & + & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & + & 2. + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & + & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & + & 2. + ENDIF + + dl_lon1 = dl_lon1 - dl_dlon + dl_lat1 = dl_lat1 - dl_dlat + + ! look for closest point on coarse grid + il_iur(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & tl_lat0%d_value(il_imin0:il_imax0, & + & il_jmin0:il_jmax0, & + & 1,1), & + & dl_lon1, dl_lat1, 'ur' ) + + ! coarse grid indices + il_imin = il_imin0-1+MIN(il_ill(1), il_iul(1)) + il_imax = il_imin0-1+MAX(il_ilr(1), il_iur(1)) + + IF( il_imax <= il_ew0 )THEN + !il_imin = 1 + il_imax = tl_lon0%t_dim(1)%i_len - il_ew0 + il_imax + ENDIF + + il_jmin = il_jmin0-1+MIN(il_ill(2), il_ilr(2)) + il_jmax = il_jmin0-1+MAX(il_iul(2), il_iur(2)) + + ! special case if east west overlap + IF( il_ew1 >= 0 )THEN + CALL logger_debug("GRID GET COARSE INDEX: East-West overlap "//& + & "found for fine grid " ) + + il_imin = 1 + il_imax = tl_lon0%t_dim(1)%i_len + + ENDIF + ENDIF + + if_idx(1,1) = il_imin + if_idx(1,2) = il_imax + + if_idx(2,1) = il_jmin + if_idx(2,2) = il_jmax + + ! clean + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + ENDIF + + DEALLOCATE( il_rho ) + + END FUNCTION grid__get_coarse_index_cc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_is_global(td_lon, td_lat) & + & RESULT (lf_global) + !------------------------------------------------------------------- + !> @brief This function check if grid is global or not + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_lon longitude structure + !> @param[in] td_lat latitude structure + !> @return true if grid is global + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_lon + TYPE(TVAR), INTENT(IN) :: td_lat + + ! function + LOGICAL :: lf_global + + ! local variable + INTEGER(i4) :: il_ew + INTEGER(i4) :: il_south + INTEGER(i4) :: il_north + + REAL(dp) :: dl_lat_min + REAL(dp) :: dl_lat_max + + ! loop indices + !---------------------------------------------------------------- + + ! init + lf_global=.FALSE. + + IF( ANY( td_lon%t_dim(:)%i_len /= td_lat%t_dim(:)%i_len ) )THEN + CALL logger_fatal("GRID IS GLOBAL: dimension of longitude and "//& + & " latitude differ") + ENDIF + + IF( .NOT. ASSOCIATED(td_lon%d_value) .OR. & + & .NOT. ASSOCIATED(td_lat%d_value) )THEN + CALL logger_error("GRID IS GLOBAL: no value associated to "//& + & " longitude or latitude strucutre") + ELSE + + il_south=1 + il_north=td_lon%t_dim(2)%i_len + + dl_lat_min=MINVAL(td_lat%d_value(:,il_south,1,1)) + dl_lat_max=MAXVAL(td_lat%d_value(:,il_north,1,1)) + + IF( dl_lat_min < -77.0 .AND. dl_lat_max > 89.0 )THEN + + il_ew=td_lon%i_ew + IF( il_ew >= 0 )THEN + + lf_global=.TRUE. + + ENDIF + + ENDIF + ENDIF + + END FUNCTION grid_is_global + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_closest_str( td_coord0, dd_lon1, dd_lat1, cd_pos, dd_fill ) & + & RESULT(if_idx) + !------------------------------------------------------------------- + !> @brief This function return grid indices of the closest point + !> from point (lon1,lat1) + !> + !> @details + !> + !> @note overlap band should have been already removed from coarse grid array + !> of longitude and latitude, before running this function + !> + !> if you add cd_pos argument, you could choice to return closest point at + !> - lower left (ll) of the point + !> - lower right (lr) of the point + !> - upper left (ul) of the point + !> - upper right (ur) of the point + !> - lower (lo) of the point + !> - upper (up) of the point + !> - left (le) of the point + !> - right (ri) of the point + !> + !> @author J.Paul + !> @date April, 2016 - Initial Version + !> @date October, 2016 + !> - use max of zero and east-west overlap instead of east-west overlap + !> + !> @param[in] td_coord0 coarse grid coordinate mpp structure + !> @param[in] dd_lon1 fine grid longitude + !> @param[in] dd_lat1 fine grid latitude + !> @param[in] cd_pos relative position of grid point from point + !> @param[in] dd_fill fill value + !> @return coarse grid indices of closest point of fine grid point + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP ) , INTENT(IN) :: td_coord0 + REAL(dp), INTENT(IN) :: dd_lon1 + REAL(dp), INTENT(IN) :: dd_lat1 + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_pos + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + INTEGER(i4), DIMENSION(2) :: if_idx + + ! local variable + CHARACTER(LEN=lc) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_ew + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0 + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + TYPE(TMPP) :: tl_coord0 + !---------------------------------------------------------------- + + if_idx(:)=-1 + cl_point='T' + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + + IF( .NOT. ASSOCIATED(tl_coord0%t_proc) )THEN + + CALL logger_error("GRID GET CLOSEST: decompsition of mpp "//& + & "file "//TRIM(tl_coord0%c_name)//" not defined." ) + + ELSE + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! read coarse longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET CLOSEST: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET CLOSEST: no variable "//& + & TRIM(cl_name)//"in file "//TRIM(tl_coord0%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + il_ew=MAX(0,tl_coord0%i_ew) + ALLOCATE(dl_lon0(tl_coord0%t_dim(jp_I)%i_len-il_ew, & + & tl_coord0%t_dim(jp_J)%i_len) ) + ALLOCATE(dl_lat0(tl_coord0%t_dim(jp_I)%i_len-il_ew, & + & tl_coord0%t_dim(jp_J)%i_len) ) + + dl_lon0(:,:)=tl_lon0%d_value(il_ew+1:,:,1,1) + dl_lat0(:,:)=tl_lat0%d_value(il_ew+1:,:,1,1) + + if_idx(:)=grid_get_closest( dl_lon0, dl_lat0, dd_lon1, dd_lat1, cd_pos, dd_fill ) + + DEALLOCATE(dl_lon0, dl_lat0) + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + CALL mpp_clean(tl_coord0) + + ENDIF + + END FUNCTION grid__get_closest_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_closest_arr(dd_lon0, dd_lat0, dd_lon1, dd_lat1, cd_pos, dd_fill) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function return grid indices of the closest point + !> from point (lon1,lat1) + !> + !> @details + !> + !> @note overlap band should have been already removed from coarse grid array + !> of longitude and latitude, before running this function + !> + !> if you add cd_pos argument, you could choice to return closest point at + !> - lower left (ll) of the point + !> - lower right (lr) of the point + !> - upper left (ul) of the point + !> - upper right (ur) of the point + !> - lower (lo) of the point + !> - upper (up) of the point + !> - left (le) of the point + !> - right (ri) of the point + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - change dichotomy method to manage ORCA grid + !> @date February, 2016 + !> - add optional use of relative position + !> + !> @param[in] dd_lon0 coarse grid array of longitude + !> @param[in] dd_lat0 coarse grid array of latitude + !> @param[in] dd_lon1 fine grid longitude + !> @param[in] dd_lat1 fine grid latitude + !> @param[in] cd_pos relative position of grid point from point + !> @param[in] dd_fill fill value + !> @return coarse grid indices of closest point of fine grid point + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lon0 + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lat0 + REAL(dp), INTENT(IN) :: dd_lon1 + REAL(dp), INTENT(IN) :: dd_lat1 + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_pos + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + INTEGER(i4), DIMENSION(2) :: if_idx + + ! local variable + INTEGER(i4) :: il_iinf + INTEGER(i4) :: il_imid + INTEGER(i4) :: il_isup + INTEGER(i4) :: il_jinf + INTEGER(i4) :: il_jmid + INTEGER(i4) :: il_jsup + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(1) :: il_ind + + LOGICAL :: ll_north + LOGICAL :: ll_continue + + REAL(dp) :: dl_lon1 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dist + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 + + ! loop indices + !---------------------------------------------------------------- + + IF( ANY( SHAPE(dd_lon0(:,:)) /= SHAPE(dd_lat0(:,:)) ) )THEN + CALL logger_fatal("GRID GET CLOSEST: dimension of longitude and "//& + & " latitude differ") + ENDIF + + il_shape(:)=SHAPE(dd_lon0(:,:)) + + ALLOCATE( dl_lon0(il_shape(1),il_shape(2)) ) + + dl_lon0(:,:) = dd_lon0(:,:) + WHERE(dd_lon0(:,:) < 0 ) dl_lon0(:,:) = dd_lon0(:,:) + 360. + + dl_lon1 = dd_lon1 + IF( dd_lon1 < 0 ) dl_lon1 = dd_lon1 + 360. + + ! first, use dichotomy to reduce domain + il_iinf = 1 ; il_jinf = 1 + il_isup = il_shape(1) ; il_jsup = il_shape(2) + + il_shape(1)= il_isup - il_iinf + 1 + il_shape(2)= il_jsup - il_jinf + 1 + + ll_north=.FALSE. + ll_continue=.FALSE. + + ! avoid to use fillvalue for reduce domain on first time + IF( PRESENT(dd_fill) )THEN + DO WHILE( ALL(dl_lon0(il_isup,:) == dd_fill) ) + il_isup=il_isup-1 + ENDDO + DO WHILE( ALL(dl_lon0(il_iinf,:) == dd_fill) ) + il_iinf=il_iinf+1 + ENDDO + DO WHILE( ALL(dd_lat0(:,il_jsup) == dd_fill) ) + il_jsup=il_jsup-1 + ENDDO + DO WHILE( ALL(dd_lat0(:,il_jinf) == dd_fill) ) + il_jinf=il_jinf+1 + ENDDO + + il_shape(1)= il_isup - il_iinf + 1 + il_shape(2)= il_jsup - il_jinf + 1 + + ENDIF + + ! special case for north ORCA grid + IF( dd_lat1 > 19. .AND. dl_lon1 < 74. )THEN + ll_north=.TRUE. + ENDIF + + IF( .NOT. ll_north )THEN + ! look for meridian 0°/360° + il_jmid = il_jinf + INT(il_shape(2)/2) + il_ind(:) = MAXLOC( dl_lon0(il_iinf:il_isup,il_jmid), & + & dl_lon0(il_iinf:il_isup,il_jmid) <= 360._dp ) + + il_imid=il_ind(1) + + IF( dl_lon1 == dl_lon0(il_imid,il_jmid) .AND. & + & dd_lat1 == dd_lat0(il_imid,il_jmid) )THEN + + il_iinf = il_imid ; il_isup = il_imid + il_jinf = il_jmid ; il_jsup = il_jmid + + ELSE + IF( ALL(dl_lon0(il_isup,il_jinf:il_jsup) > dl_lon1 ) .AND. & + & il_imid /= il_isup )THEN + ! 0 < lon1 < lon0(isup) + ! point east + il_iinf = il_imid+1 + ll_continue=.TRUE. + + ELSE IF( ALL(dl_lon0(il_iinf,il_jinf:il_jsup) < dl_lon1 ) .AND. & + & il_imid /= il_iinf )THEN + ! lon0(iinf) < lon1 < 360 + ! point west + il_isup = il_imid + ll_continue=.TRUE. + + ENDIF + + il_shape(1)= il_isup - il_iinf + 1 + il_shape(2)= il_jsup - il_jinf + 1 + + il_imid = il_iinf + INT(il_shape(1)/2) + il_jmid = il_jinf + INT(il_shape(2)/2) + + ! exit when close enough of point + IF( ANY(il_shape(:) < 10 ) ) ll_continue=.FALSE. + ENDIF + ENDIF + + ! + DO WHILE( ll_continue .AND. .NOT. ll_north ) + + ll_continue=.FALSE. + IF( dl_lon1 == dl_lon0(il_imid,il_jmid) .AND. & + & dd_lat1 == dd_lat0(il_imid,il_jmid) )THEN + + il_iinf = il_imid ; il_isup = il_imid + il_jinf = il_jmid ; il_jsup = il_jmid + + ELSE + IF( ALL(dl_lon0(il_imid,il_jinf:il_jsup) < dl_lon1) )THEN + + ! point east + il_iinf = il_imid + ll_continue=.TRUE. + + ELSE IF( ALL(dl_lon0(il_imid,il_jinf:il_jsup) > dl_lon1) )THEN + + ! point west + il_isup = il_imid + ll_continue=.TRUE. + + ENDIF + + IF( ALL(dd_lat0(il_iinf:il_isup,il_jmid) < dd_lat1) )THEN + + ! point north + il_jinf = il_jmid + ll_continue=.TRUE. + + ELSE IF( ALL(dd_lat0(il_iinf:il_isup,il_jmid) > dd_lat1) )THEN + + ! point south + il_jsup = il_jmid + ll_continue=.TRUE. + + ENDIF + + il_shape(1)= il_isup - il_iinf + 1 + il_shape(2)= il_jsup - il_jinf + 1 + + il_imid = il_iinf + INT(il_shape(1)/2) + il_jmid = il_jinf + INT(il_shape(2)/2) + + ! exit when close enough of point + IF( ANY(il_shape(:) < 10 ) ) ll_continue=.FALSE. + ENDIF + + ENDDO + + ! then find closest point by computing distances + il_shape(1)= il_isup - il_iinf + 1 + il_shape(2)= il_jsup - il_jinf + 1 + + ALLOCATE( dl_dist(il_shape(1), il_shape(2)) ) + + dl_dist(:,:)=grid_distance(dl_lon0(il_iinf:il_isup,il_jinf:il_jsup), & + & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup), & + & dl_lon1, dd_lat1 ) + + IF( PRESENT(cd_pos) )THEN + ! + SELECT CASE(TRIM(cd_pos)) + CASE('le') + WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('ri') + WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('up') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('lo') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('ll') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & + & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('lr') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & + & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('ul') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & + & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + CASE('ur') + WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & + & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) + dl_dist(:,:)=NF90_FILL_DOUBLE + END WHERE + END SELECT + ENDIF + if_idx(:)=MINLOC(dl_dist(:,:),dl_dist(:,:)/=NF90_FILL_DOUBLE) + + if_idx(1)=if_idx(1)+il_iinf-1 + if_idx(2)=if_idx(2)+il_jinf-1 + + DEALLOCATE( dl_dist ) + DEALLOCATE( dl_lon0 ) + + END FUNCTION grid__get_closest_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA) & + & RESULT (df_dist) + !------------------------------------------------------------------- + !> @brief This function compute the distance between a point A and grid points. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_lon grid longitude array + !> @param[in] dd_lat grid latitude array + !> @param[in] dd_lonA longitude of point A + !> @param[in] dd_latA latitude of point A + !> @param[in] dd_fill + !> @return array of distance between point A and grid points. + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lon + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lat + REAL(dp), INTENT(IN) :: dd_lonA + REAL(dp), INTENT(IN) :: dd_latA + + ! function + REAL(dp), DIMENSION(SIZE(dd_lon(:,:),DIM=1),& + & SIZE(dd_lon(:,:),DIM=2)) :: df_dist + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat + REAL(dp) :: dl_lonA + REAL(dp) :: dl_latA + + REAL(dp) :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( ANY( SHAPE(dd_lon(:,:)) /= SHAPE(dd_lat(:,:)) ) )THEN + CALL logger_fatal("GRID DISTANCE: dimension of longitude and "//& + & " latitude differ") + ENDIF + il_shape(:)=SHAPE(dd_lon(:,:)) + + ALLOCATE(dl_lon(il_shape(1),il_shape(2))) + ALLOCATE(dl_lat(il_shape(1),il_shape(2))) + + dl_lon(:,:) = dd_lon(:,:) + dl_lonA = dd_lonA + + WHERE(dd_lon(:,:) < 0 ) dl_lon(:,:) = dd_lon(:,:) + 360. + IF( dd_lonA < 0 ) dl_lonA = dd_lonA + 360. + + dl_lonA = dd_lonA * dp_deg2rad + dl_latA = dd_latA * dp_deg2rad + + dl_lon(:,:) = dl_lon(:,:) * dp_deg2rad + dl_lat(:,:) = dd_lat(:,:) * dp_deg2rad + + df_dist(:,:)=NF90_FILL_DOUBLE + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + IF( dl_lon(ji,jj) == dl_lonA .AND. & + & dl_lat(ji,jj) == dl_latA )THEN + df_dist(ji,jj)=0.0 + ELSE + dl_tmp= SIN(dl_latA)*SIN(dl_lat(ji,jj)) + & + & COS(dl_latA)*COS(dl_lat(ji,jj)) * & + & COS(dl_lon(ji,jj)-dl_lonA) + ! check to avoid mistake with ACOS + IF( dl_tmp < -1.0 ) dl_tmp = -1.0 + IF( dl_tmp > 1.0 ) dl_tmp = 1.0 + df_dist(ji,jj)=ACOS(dl_tmp)*dp_rearth + ENDIF + ENDDO + ENDDO + + DEALLOCATE(dl_lon) + DEALLOCATE(dl_lat) + + END FUNCTION grid_distance + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_fine_offset_ff(td_coord0, & + & id_imin0, id_jmin0, id_imax0, id_jmax0, & + & td_coord1, id_rho, cd_point) & + & RESULT (if_offset) + !------------------------------------------------------------------- + !> @brief This function get offset between fine grid and coarse grid. + !> + !> @details + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> offset value could be 0,1,..,rho-1 + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] td_coord0 coarse grid coordinate + !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain + !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain + !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain + !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain + !> @param[in] td_coord1 fine grid coordinate + !> @param[in] id_rho array of refinement factor + !> @param[in] cd_point Arakawa grid point + !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_coord0 + TYPE(TMPP) , INTENT(IN) :: td_coord1 + + INTEGER(i4) , INTENT(IN) :: id_imin0 + INTEGER(i4) , INTENT(IN) :: id_jmin0 + INTEGER(i4) , INTENT(IN) :: id_imax0 + INTEGER(i4) , INTENT(IN) :: id_jmax0 + + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_offset + + ! local variable + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_ind + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4), DIMENSION(2,2) :: il_xghost0 + INTEGER(i4), DIMENSION(2,2) :: il_xghost1 + + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1 + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + + ! loop indices + !---------------------------------------------------------------- + ! init + if_offset(:,:)=-1 + + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + tl_coord1=mpp_copy(td_coord1) + + IF( .NOT. ASSOCIATED(tl_coord0%t_proc) .OR. & + & .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN + CALL logger_error("GRID GET FINE OFFSET: can not get coarse "//& + & "grid indices. decompsition of mpp file "//TRIM(tl_coord0%c_name)//& + & " and/or "//TRIM(tl_coord1%c_name)//" not defined." ) + ELSE + !1- Coarse grid + ! get ghost cell factor on coarse grid + il_xghost0(:,:)=grid_get_ghost( tl_coord0 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! read coarse longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) + CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) + + ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, & + & tl_lon0%t_dim(jp_J)%i_len )) + + dl_lon0(:,:)=tl_lon0%d_value(:,:,1,1) + + ALLOCATE(dl_lat0(tl_lat0%t_dim(jp_I)%i_len, & + & tl_lat0%t_dim(jp_J)%i_len )) + + dl_lat0(:,:)=tl_lat0%d_value(:,:,1,1) + + ! clean + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + + ! adjust coarse grid indices + il_imin0=id_imin0-il_xghost0(jp_I,1) + il_imax0=id_imax0-il_xghost0(jp_I,1) + + il_jmin0=id_jmin0-il_xghost0(jp_J,1) + il_jmax0=id_jmax0-il_xghost0(jp_J,1) + + !2- Fine grid + ! get ghost cell factor on fine grid + il_xghost1(:,:)=grid_get_ghost( tl_coord1 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! read fine longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + CALL grid_del_ghost(tl_lon1, il_xghost1(:,:)) + CALL grid_del_ghost(tl_lat1, il_xghost1(:,:)) + + ALLOCATE(dl_lon1(tl_lon1%t_dim(jp_I)%i_len, & + & tl_lon1%t_dim(jp_J)%i_len )) + + dl_lon1(:,:)=tl_lon1%d_value(:,:,1,1) + + ALLOCATE(dl_lat1(tl_lat1%t_dim(jp_I)%i_len, & + & tl_lat1%t_dim(jp_J)%i_len )) + + dl_lat1(:,:)=tl_lat1%d_value(:,:,1,1) + + ! clean + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + + !3- compute + if_offset(:,:)=grid_get_fine_offset( dl_lon0(:,:), dl_lat0(:,:),& + & il_imin0, il_jmin0, & + & il_imax0, il_jmax0, & + & dl_lon1(:,:), dl_lat1(:,:),& + & id_rho(:), cl_point ) + + DEALLOCATE(dl_lon0, dl_lat0) + DEALLOCATE(dl_lon1, dl_lat1) + ENDIF + + ! clean + CALL mpp_clean(tl_coord0) + CALL mpp_clean(tl_coord1) + DEALLOCATE(il_rho) + + END FUNCTION grid__get_fine_offset_ff + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_fine_offset_cf(dd_lon0, dd_lat0, & + & id_imin0, id_jmin0, id_imax0, id_jmax0, & + & td_coord1, id_rho, cd_point) & + & RESULT (if_offset) + !------------------------------------------------------------------- + !> @brief This function get offset between fine grid and coarse grid. + !> + !> @details + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> offset value could be 0,1,..,rho-1 + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] dd_lon0 coarse grid longitude array + !> @param[in] dd_lat0 coarse grid latitude array + !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain + !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain + !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain + !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain + !> @param[in] td_coord1 fine grid coordinate + !> @param[in] id_rho array of refinement factor + !> @param[in] cd_point Arakawa grid point + !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 + TYPE(TMPP) , INTENT(IN) :: td_coord1 + + INTEGER(i4) , INTENT(IN) :: id_imin0 + INTEGER(i4) , INTENT(IN) :: id_jmin0 + INTEGER(i4) , INTENT(IN) :: id_imax0 + INTEGER(i4) , INTENT(IN) :: id_jmax0 + + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_offset + + ! local variable + INTEGER(i4) :: il_ind + INTEGER(i4), DIMENSION(2,2) :: il_xghost1 + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1 + + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + TYPE(TMPP) :: tl_coord1 + ! loop indices + !---------------------------------------------------------------- + ! init + if_offset(:,:)=-1 + + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + ! copy structure + tl_coord1=mpp_copy(td_coord1) + + IF( .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN + CALL logger_error("GRID GET FINE OFFSET: decompsition of mpp "//& + & "file "//TRIM(tl_coord1%c_name)//" not defined." ) + ELSE + + ! Fine grid + ! get ghost cell factor on fine grid + il_xghost1(:,:)=grid_get_ghost( tl_coord1 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! read fine longitue and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + + CALL grid_del_ghost(tl_lon1, il_xghost1(:,:)) + CALL grid_del_ghost(tl_lat1, il_xghost1(:,:)) + + ALLOCATE(dl_lon1(tl_lon1%t_dim(jp_I)%i_len, & + & tl_lon1%t_dim(jp_J)%i_len )) + + dl_lon1(:,:)=tl_lon1%d_value(:,:,1,1) + + ALLOCATE(dl_lat1(tl_lat1%t_dim(jp_I)%i_len, & + & tl_lat1%t_dim(jp_J)%i_len )) + + dl_lat1(:,:)=tl_lat1%d_value(:,:,1,1) + + ! clean + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + + ! compute + if_offset(:,:)=grid_get_fine_offset( dd_lon0(:,:), dd_lat0(:,:),& + & id_imin0, id_jmin0, & + & id_imax0, id_jmax0, & + & dl_lon1(:,:), dl_lat1(:,:),& + & id_rho(:), cl_point ) + + DEALLOCATE(dl_lon1, dl_lat1) + ENDIF + + ! clean + CALL mpp_clean(tl_coord1) + DEALLOCATE(il_rho) + + END FUNCTION grid__get_fine_offset_cf + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_fine_offset_fc(td_coord0, & + & id_imin0, id_jmin0, id_imax0, id_jmax0, & + & dd_lon1, dd_lat1, & + & id_rho, cd_point) & + & RESULT (if_offset) + !------------------------------------------------------------------- + !> @brief This function get offset between fine grid and coarse grid. + !> + !> @details + !> optionally, you could specify on which Arakawa grid point you want to + !> work (default 'T') + !> offset value could be 0,1,..,rho-1 + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] td_coord0 coarse grid coordinate + !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain + !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain + !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain + !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain + !> @param[in] dd_lon1 fine grid longitude array + !> @param[in] dd_lat1 fine grid latitude array + !> @param[in] id_rho array of refinement factor + !> @param[in] cd_point Arakawa grid point + !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_coord0 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 + + INTEGER(i4) , INTENT(IN) :: id_imin0 + INTEGER(i4) , INTENT(IN) :: id_jmin0 + INTEGER(i4) , INTENT(IN) :: id_imax0 + INTEGER(i4) , INTENT(IN) :: id_jmax0 + + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_offset + + ! local variable + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_ind + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4), DIMENSION(2,2) :: il_xghost0 + + CHARACTER(LEN= 1) :: cl_point + CHARACTER(LEN=lc) :: cl_name + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0 + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + + TYPE(TMPP) :: tl_coord0 + ! loop indices + !---------------------------------------------------------------- + ! init + if_offset(:,:)=-1 + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + + IF( .NOT. ASSOCIATED(tl_coord0%t_proc) )THEN + CALL logger_error("GRID GET FINE OFFSET: decompsition of mpp "//& + & "file "//TRIM(tl_coord0%c_name)//" not defined." ) + ELSE + !1- Coarse grid + ! get ghost cell factor on coarse grid + il_xghost0(:,:)=grid_get_ghost( tl_coord0 ) + + ! open mpp files + CALL iom_mpp_open(tl_coord0) + + ! read coarse longitude and latitude + WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use longitude.") + WRITE(cl_name,*) 'longitude' + ENDIF + tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) + il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) + IF( il_ind == 0 )THEN + CALL logger_warn("GRID GET FINE OFFSET: no variable "//& + & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & + & try to use latitude.") + WRITE(cl_name,*) 'latitude' + ENDIF + tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) + + ! close mpp files + CALL iom_mpp_close(tl_coord0) + + CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) + CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) + + + ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, & + & tl_lon0%t_dim(jp_J)%i_len )) + + dl_lon0(:,:)=tl_lon0%d_value(:,:,1,1) + + ALLOCATE(dl_lat0(tl_lat0%t_dim(jp_I)%i_len, & + & tl_lat0%t_dim(jp_J)%i_len )) + + dl_lat0(:,:)=tl_lat0%d_value(:,:,1,1) + + ! clean + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + + ! adjust coarse grid indices + il_imin0=id_imin0-il_xghost0(jp_I,1) + il_imax0=id_imax0-il_xghost0(jp_I,1) + + il_jmin0=id_jmin0-il_xghost0(jp_J,1) + il_jmax0=id_jmax0-il_xghost0(jp_J,1) + + !3- compute + if_offset(:,:)=grid_get_fine_offset( dl_lon0(:,:), dl_lat0(:,:),& + & il_imin0, il_jmin0, & + & il_imax0, il_jmax0, & + & dd_lon1(:,:), dd_lat1(:,:),& + & id_rho(:), cl_point ) + + DEALLOCATE(dl_lon0, dl_lat0) + ENDIF + + ! clean + CALL mpp_clean(tl_coord0) + DEALLOCATE(il_rho) + + END FUNCTION grid__get_fine_offset_fc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_fine_offset_cc(dd_lon0, dd_lat0, & + & id_imin0, id_jmin0, id_imax0, id_jmax0, & + & dd_lon1, dd_lat1, id_rho, cd_point) & + & RESULT (if_offset) + !------------------------------------------------------------------- + !> @brief This function get offset between fine grid and coarse grid. + !> + !> @details + !> offset value could be 0,1,..,rho-1 + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - rename from grid_get_fine_offset + !> @date May, 2015 + !> - improve way to find offset + !> @date July, 2015 + !> - manage case close to greenwich meridian + !> @date February, 2016 + !> - use grid_get_closest to assess offset + !> - use delta (lon or lat) + !> - manage cases for T,U,V or F point, with even or odd refinment + !> - check lower left(upper right) fine grid point inside lower left(upper + !> right) coarse grid cell. + !> + !> @todo check case close from North fold. + !> + !> @param[in] dd_lon0 coarse grid longitude array + !> @param[in] dd_lat0 coarse grid latitude array + !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain + !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain + !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain + !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain + !> @param[in] dd_lon1 fine grid longitude array + !> @param[in] dd_lat1 fine grid latitude array + !> @param[in] id_rho array of refinement factor + !> @param[in] cd_point Arakawa grid point + !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 + + INTEGER(i4) , INTENT(IN) :: id_imin0 + INTEGER(i4) , INTENT(IN) :: id_jmin0 + INTEGER(i4) , INTENT(IN) :: id_imax0 + INTEGER(i4) , INTENT(IN) :: id_jmax0 + + INTEGER(i4) , DIMENSION(:) , INTENT(IN) :: id_rho + CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point + + ! function + INTEGER(i4) , DIMENSION(2,2) :: if_offset + + ! local variable + CHARACTER(LEN= 1) :: cl_point + + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + INTEGER(i4) :: j1 + INTEGER(i4) :: j2 + + INTEGER(i4), DIMENSION(2) :: il_shape0 + INTEGER(i4), DIMENSION(2) :: il_shape1 + + INTEGER(i4), DIMENSION(2) :: il_ind + + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 + + REAL(dp) :: dl_lonmax0 + REAL(dp) :: dl_latmax0 + REAL(dp) :: dl_lonmin0 + REAL(dp) :: dl_latmin0 + + REAL(dp) :: dl_lon0F + REAL(dp) :: dl_lat0F + REAL(dp) :: dl_dlon + REAL(dp) :: dl_dlat + + LOGICAL , DIMENSION(2) :: ll_even + LOGICAL :: ll_greenwich + + ! loop indices + INTEGER(i4) :: ii + INTEGER(i4) :: ij + !---------------------------------------------------------------- + IF( ANY( SHAPE(dd_lon0(:,:)) /= SHAPE(dd_lat0(:,:)) ) )THEN + CALL logger_fatal("GRID GET FINE OFFSET: dimension of coarse "//& + & "longitude and latitude differ") + ENDIF + + IF( ANY( SHAPE(dd_lon1(:,:)) /= SHAPE(dd_lat1(:,:)) ) )THEN + CALL logger_fatal("GRID GET FINE OFFSET: dimension of fine "//& + & "longitude and latitude differ") + ENDIF + + ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) + + cl_point='T' + IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) + + il_shape0(:)=SHAPE(dd_lon0(:,:)) + ALLOCATE( dl_lon0(il_shape0(1),il_shape0(2)) ) + + il_shape1(:)=SHAPE(dd_lon1(:,:)) + ALLOCATE( dl_lon1(il_shape1(1),il_shape1(2)) ) + + dl_lon0(:,:)=dd_lon0(:,:) + WHERE( dd_lon0(:,:) < 0 ) dl_lon0(:,:)=dd_lon0(:,:)+360. + + dl_lon1(:,:)=dd_lon1(:,:) + WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360. + + ! init + if_offset(:,:)=-1 + ll_greenwich=.FALSE. + + IF( il_shape1(jp_J) == 1 )THEN + + if_offset(jp_J,:)=((id_rho(jp_J)-1)/2) + + !!! work on i-direction + !!! look for i-direction left offset + i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) + j1=1 ; j2=1 + + ! check if cross greenwich meridien + IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))<5. .OR. & + & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))>355. )THEN + ! close to greenwich meridien + ll_greenwich=.TRUE. + ! 0:360 => -180:180 + WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) > 180. ) + dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & + & dl_lon0(id_imin0:id_imin0+1,id_jmin0)-360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. + END WHERE + ENDIF + + ! max lognitude of the left cell + dl_lonmax0=dl_lon0(id_imin0+1,id_jmin0) + IF( dl_lon1(1,1) < dl_lonmax0 )THEN + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','U') + dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & + & dl_lon0(id_imin0 ,id_jmin0) ) / & + & ( 2.*id_rho(jp_I) ) + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & + & dl_lon0(id_imin0 ,id_jmin0) ) / & + & ( 2.*id_rho(jp_I) ) + ENDIF + + dl_lon0F= dl_lon0(id_imin0+1,id_jmin0) + dl_dlon + dl_lat0F= dd_lat0(id_imin0+1,id_jmin0) + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'le' ) + + ii=il_ind(1) + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','V') + if_offset(jp_I,1)=id_rho(jp_I)-ii + CASE DEFAULT !'F','U' + if_offset(jp_I,1)=(id_rho(jp_I)+1)-ii + END SELECT + ELSE + ! odd + if_offset(jp_I,1)=(id_rho(jp_I)+1)-ii + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& + & " not match fine grid left corner.") + ENDIF + + IF( ll_greenwich )THEN + ! close to greenwich meridien + ll_greenwich=.FALSE. + ! -180:180 => 0:360 + WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) < 0. ) + dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & + & dl_lon0(id_imin0:id_imin0+1,id_jmin0)+360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. + END WHERE + ENDIF + + !!!!!! look for i-direction right offset !!!!!! + i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) + j1=1 ; j2=1 + + ! check if cross greenwich meridien + IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))<5. .OR. & + & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))>355. )THEN + ! close to greenwich meridien + ll_greenwich=.TRUE. + ! 0:360 => -180:180 + WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) > 180. ) + dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & + & dl_lon0(id_imax0-1:id_imax0,id_jmin0)-360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. + END WHERE + ENDIF + + ! min lognitude of the right cell + dl_lonmin0=dl_lon0(id_imax0-1,id_jmin0) + IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 )THEN + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','U') + dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & + & dl_lon0(id_imax0-1,id_jmin0) ) / & + & ( 2.*id_rho(jp_I) ) + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & + & dl_lon0(id_imax0-1,id_jmin0) ) / & + & ( 2.*id_rho(jp_I) ) + ENDIF + + dl_lon0F= dl_lon0(id_imax0-1,id_jmin0) - dl_dlon + dl_lat0F= dd_lat0(id_imax0-1,id_jmin0) + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'ri' ) + + ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','V') + if_offset(jp_I,2)=id_rho(jp_I)-ii + CASE DEFAULT !'F','U' + if_offset(jp_I,2)=(id_rho(jp_I)+1)-ii + END SELECT + ELSE + ! odd + if_offset(jp_I,2)=(id_rho(jp_I)+1)-ii + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& + & " not match fine grid right corner.") + ENDIF + + IF( ll_greenwich )THEN + ! close to greenwich meridien + ll_greenwich=.FALSE. + ! -180:180 => 0:360 + WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) < 0. ) + dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & + & dl_lon0(id_imax0-1:id_imax0,id_jmin0)+360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. + END WHERE + ENDIF + + ELSEIF( il_shape1(jp_I) == 1 )THEN + + if_offset(jp_I,:)=((id_rho(jp_I)-1)/2) + + !!! work on j-direction + !!! look for j-direction lower offset + i1=1 ; i2=1 + j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) + + + ! max latitude of the lower cell + dl_latmax0=dd_lat0(id_imin0,id_jmin0+1) + IF( dd_lat1(1,1) < dl_latmax0 )THEN + + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','V') + dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & + & dd_lat0(id_imin0,id_jmin0 ) ) / & + & ( 2.*id_rho(jp_J) ) + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & + & dd_lat0(id_imin0,id_jmin0 ) ) / & + & ( 2.*id_rho(jp_J) ) + ENDIF + + dl_lon0F= dl_lon0(id_imin0,id_jmin0+1) + dl_lat0F= dd_lat0(id_imin0,id_jmin0+1) + dl_dlat + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'lo' ) + + ij=il_ind(2) + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','V') + if_offset(jp_J,1)=id_rho(jp_J)-ij + CASE DEFAULT !'F','U' + if_offset(jp_J,1)=(id_rho(jp_J)+1)-ij + END SELECT + ELSE + ! odd + if_offset(jp_J,1)=(id_rho(jp_J)+1)-ij + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& + & " not match fine grid lower corner.") + ENDIF + + !!! look for j-direction upper offset + i1=1 ; i2=1 + j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) + + ! min latitude of the upper cell + dl_latmin0=dd_lat0(id_imin0,id_jmax0-1) + IF( dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN + + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','V') + dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & + & dd_lat0(id_imin0,id_jmax0-1) ) / & + & ( 2.*id_rho(jp_J) ) + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & + & dd_lat0(id_imin0,id_jmax0-1) ) / & + & ( 2*id_rho(jp_J) ) + ENDIF + + dl_lon0F= dl_lon0(id_imin0,id_jmax0-1) + dl_lat0F= dd_lat0(id_imin0,id_jmax0-1) - dl_dlat + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'up' ) + + ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','U') + if_offset(jp_J,2)=id_rho(jp_J)-ij + CASE DEFAULT !'F','V' + if_offset(jp_J,2)=(id_rho(jp_J)+1)-ij + END SELECT + ELSE + ! odd + if_offset(jp_J,2)=(id_rho(jp_J)+1)-ij + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& + & " not match fine grid upper corner.") + ENDIF + + ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 + + !!!!!! look for lower left offset !!!!!! + i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) + j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) + + ! check if cross greenwich meridien + IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))<5. .OR. & + & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))>355. )THEN + ! close to greenwich meridien + ll_greenwich=.TRUE. + ! 0:360 => -180:180 + WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) > 180. ) + dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & + & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)-360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. + END WHERE + ENDIF + + ! max longitude of the lower left cell + dl_lonmax0=MAX(dl_lon0(id_imin0+1,id_jmin0),dl_lon0(id_imin0+1,id_jmin0+1)) + ! max latitude of the lower left cell + dl_latmax0=MAX(dd_lat0(id_imin0,id_jmin0+1),dd_lat0(id_imin0+1,id_jmin0+1)) + IF( dl_lon1(1,1) < dl_lonmax0 .AND. & + & dd_lat1(1,1) < dl_latmax0 )THEN + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','U') + dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & + & dl_lon0(id_imin0 ,id_jmin0+1) ) / & + & ( 2.*id_rho(jp_I) ) + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & + & dl_lon0(id_imin0 ,id_jmin0+1) ) / & + & ( 2.*id_rho(jp_I) ) + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','V') + dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & + & dd_lat0(id_imin0+1,id_jmin0 ) ) / & + & ( 2.*id_rho(jp_J) ) + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & + & dd_lat0(id_imin0+1,id_jmin0 ) ) / & + & ( 2.*id_rho(jp_J) ) + ENDIF + + dl_lon0F= dl_lon0(id_imin0+1,id_jmin0+1) + dl_dlon + dl_lat0F= dd_lat0(id_imin0+1,id_jmin0+1) + dl_dlat + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'll' ) + + ii=il_ind(1) + ij=il_ind(2) + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','V') + if_offset(jp_I,1)=id_rho(jp_I)-ii + CASE DEFAULT !'F','U' + if_offset(jp_I,1)=(id_rho(jp_I)+1)-ii + END SELECT + ELSE + ! odd + if_offset(jp_I,1)=(id_rho(jp_I)+1)-ii + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','U') + if_offset(jp_J,1)=id_rho(jp_J)-ij + CASE DEFAULT !'F','V' + if_offset(jp_J,1)=(id_rho(jp_J)+1)-ij + END SELECT + ELSE + ! odd + if_offset(jp_J,1)=(id_rho(jp_J)+1)-ij + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& + & " not match fine grid lower left corner.") + ENDIF + + IF( ll_greenwich )THEN + ! close to greenwich meridien + ll_greenwich=.FALSE. + ! -180:180 => 0:360 + WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) < 0. ) + dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & + & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)+360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. + END WHERE + ENDIF + + !!!!!! look for upper right offset !!!!!! + i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) + j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) + + ! check if cross greenwich meridien + IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))<5. .OR. & + & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))>355. )THEN + ! close to greenwich meridien + ll_greenwich=.TRUE. + ! 0:360 => -180:180 + WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) > 180. ) + dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & + & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)-360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. + END WHERE + ENDIF + + ! min latitude of the upper right cell + dl_lonmin0=MIN(dl_lon0(id_imax0-1,id_jmax0-1),dl_lon0(id_imax0-1,id_jmax0)) + ! min latitude of the upper right cell + dl_latmin0=MIN(dd_lat0(id_imax0-1,id_jmax0-1),dd_lat0(id_imax0,id_jmax0-1)) + IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 .AND. & + & dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','U') + dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & + & dl_lon0(id_imax0-1,id_jmax0-1) ) / & + & ( 2.*id_rho(jp_I) ) + CASE DEFAULT + dl_dlon=0 + END SELECT + ELSE + ! odd + dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & + & dl_lon0(id_imax0-1,id_jmax0-1) ) / & + & ( 2*id_rho(jp_I) ) + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('F','V') + dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & + & dd_lat0(id_imax0-1,id_jmax0-1) ) / & + & ( 2.*id_rho(jp_J) ) + CASE DEFAULT + dl_dlat=0 + END SELECT + ELSE + ! odd + dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & + & dd_lat0(id_imax0-1,id_jmax0-1) ) / & + & ( 2*id_rho(jp_J) ) + ENDIF + + dl_lon0F= dl_lon0(id_imax0-1,id_jmax0-1) - dl_dlon + dl_lat0F= dd_lat0(id_imax0-1,id_jmax0-1) - dl_dlat + + il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & + & dl_lon0F, dl_lat0F, 'ur' ) + + ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) + ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) + + !!!!! i-direction !!!!! + IF( ll_even(jp_I) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','V') + if_offset(jp_I,2)=id_rho(jp_I)-ii + CASE DEFAULT !'F','U' + if_offset(jp_I,2)=(id_rho(jp_I)+1)-ii + END SELECT + ELSE + ! odd + if_offset(jp_I,2)=(id_rho(jp_I)+1)-ii + ENDIF + + !!!!! j-direction !!!!! + IF( ll_even(jp_J) )THEN + ! even + SELECT CASE(TRIM(cl_point)) + CASE('T','U') + if_offset(jp_J,2)=id_rho(jp_J)-ij + CASE DEFAULT !'F','V' + if_offset(jp_J,2)=(id_rho(jp_J)+1)-ij + END SELECT + ELSE + ! odd + if_offset(jp_J,2)=(id_rho(jp_J)+1)-ij + ENDIF + + ELSE + CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& + & " not match fine grid upper right corner.") + ENDIF + + IF( ll_greenwich )THEN + ! close to greenwich meridien + ll_greenwich=.FALSE. + ! -180:180 => 0:360 + WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) < 0. ) + dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & + & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)+360. + END WHERE + + WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) + dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. + END WHERE + ENDIF + + ENDIF + + DEALLOCATE( dl_lon0 ) + DEALLOCATE( dl_lon1 ) + + IF( ANY(if_offset(:,:)==-1) )THEN + CALL logger_fatal("GRID GET FINE OFFSET: can not found "//& + & " offset between coarse and fine grid.") + ENDIF + + END FUNCTION grid__get_fine_offset_cc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_check_coincidence(td_coord0, td_coord1, & + & id_imin0, id_imax0, & + & id_jmin0, id_jmax0, & + & id_rho) + !------------------------------------------------------------------- + !> @brief This subroutine check fine and coarse grid coincidence. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013- Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> @date February, 2016 + !> - use F-point to check coincidence for even refinment + !> - use F-point estimation, if can not read it. + !> + !> @param[in] td_coord0 coarse grid coordinate file structure + !> @param[in] td_coord1 fine grid coordinate file structure + !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain + !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain + !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain + !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain + !> @param[in] id_rho array of refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_coord0 + TYPE(TMPP) , INTENT(IN) :: td_coord1 + INTEGER(i4) , INTENT(IN) :: id_imin0 + INTEGER(i4) , INTENT(IN) :: id_imax0 + INTEGER(i4) , INTENT(IN) :: id_jmin0 + INTEGER(i4) , INTENT(IN) :: id_jmax0 + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_rho + + ! local variable + INTEGER(i4) :: il_imid1 + INTEGER(i4) :: il_jmid1 + + INTEGER(i4) :: il_ew0 + INTEGER(i4) :: il_ew1 + + INTEGER(i4) :: il_ind + + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + + INTEGER(i4), DIMENSION(2) :: il_ind0 + INTEGER(i4), DIMENSION(2) :: il_ind1 + + INTEGER(i4), DIMENSION(2) :: il_ill1 + INTEGER(i4), DIMENSION(2) :: il_ilr1 + INTEGER(i4), DIMENSION(2) :: il_iul1 + INTEGER(i4), DIMENSION(2) :: il_iur1 + + REAL(dp) :: dl_lon0F + REAL(dp) :: dl_lat0F + REAL(dp) :: dl_lon0 + REAL(dp) :: dl_lat0 + REAL(dp) :: dl_lon1F + REAL(dp) :: dl_lat1F + REAL(dp) :: dl_lon1 + REAL(dp) :: dl_lat1 + + REAL(dp) :: dl_delta + + LOGICAL :: ll_coincidence + LOGICAL :: ll_even + LOGICAL :: ll_grid0F + LOGICAL :: ll_grid1F + + TYPE(TVAR) :: tl_lon0 + TYPE(TVAR) :: tl_lat0 + TYPE(TVAR) :: tl_lon0F + TYPE(TVAR) :: tl_lat0F + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + TYPE(TVAR) :: tl_lon1F + TYPE(TVAR) :: tl_lat1F + + TYPE(TMPP) :: tl_coord0 + TYPE(TMPP) :: tl_coord1 + + TYPE(TDOM) :: tl_dom0 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ll_coincidence=.TRUE. + + ll_even=.FALSE. + IF( MOD(id_rho(jp_I)*id_rho(jp_J),2) == 0 )THEN + ll_even=.TRUE. + ENDIF + + ! copy structure + tl_coord0=mpp_copy(td_coord0) + + ! compute domain + tl_dom0=dom_init( tl_coord0, & + & id_imin0, id_imax0,& + & id_jmin0, id_jmax0 ) + + ! open mpp files + CALL iom_dom_open(tl_coord0, tl_dom0) + + ! read variable value on domain + il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_T') + IF( il_ind /= 0 )THEN + tl_lon0=iom_dom_read_var(tl_coord0,'longitude_T',tl_dom0) + ELSE + tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0) + ENDIF + + il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_T') + IF( il_ind /= 0 )THEN + tl_lat0=iom_dom_read_var(tl_coord0,'latitude_T' ,tl_dom0) + ELSE + tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0) + ENDIF + + IF( ll_even )THEN + + ! look for variable value on domain for F point + il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_F') + IF( il_ind /= 0 )THEN + tl_lon0F=iom_dom_read_var(tl_coord0,'longitude_F',tl_dom0) + ENDIF + + il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_F') + IF( il_ind /= 0 )THEN + tl_lat0F=iom_dom_read_var(tl_coord0,'latitude_F' ,tl_dom0) + ENDIF + + ll_grid0F=.FALSE. + IF( ASSOCIATED(tl_lon0F%d_value) .AND. & + & ASSOCIATED(tl_lat0F%d_value) )THEN + ll_grid0F=.TRUE. + ENDIF + + ENDIF + + ! close mpp files + CALL iom_dom_close(tl_coord0) + + ! clean structure + CALL mpp_clean(tl_coord0) + CALL dom_clean(tl_dom0) + + ! copy structure + tl_coord1=mpp_copy(td_coord1) + + ! open mpp files + CALL iom_mpp_open(tl_coord1) + + ! read fine longitue and latitude + il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lon0%c_longname)) + IF( il_ind /= 0 )THEN + tl_lon1=iom_mpp_read_var(tl_coord1,TRIM(tl_lon0%c_longname)) + ELSE + tl_lon1=iom_mpp_read_var(tl_coord1,'longitude') + ENDIF + il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lat0%c_longname)) + IF( il_ind /= 0 )THEN + tl_lat1=iom_mpp_read_var(tl_coord1,TRIM(tl_lat0%c_longname)) + ELSE + tl_lat1=iom_mpp_read_var(tl_coord1,'latitude') + ENDIF + + IF( ll_even )THEN + + ! look for variable value on domain for F point + il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'longitude_F') + IF( il_ind /= 0 )THEN + tl_lon1F=iom_mpp_read_var(tl_coord1,'longitude_F') + ENDIF + + il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'latitude_F') + IF( il_ind /= 0 )THEN + tl_lat1F=iom_mpp_read_var(tl_coord1,'latitude_F') + ENDIF + + ll_grid1F=.FALSE. + IF( ASSOCIATED(tl_lon1F%d_value) .AND. & + & ASSOCIATED(tl_lat1F%d_value) )THEN + ll_grid1F=.TRUE. + ENDIF + + ENDIF + + ! close mpp files + CALL iom_mpp_close(tl_coord1) + ! clean structure + CALL mpp_clean(tl_coord1) + + CALL logger_debug("GRID CHECK COINCIDENCE:"//& + & " fine grid "//TRIM(td_coord1%c_name) ) + CALL logger_debug("GRID CHECK COINCIDENCE:"//& + & " coarse grid "//TRIM(td_coord0%c_name) ) + + ! check domain + ! check global grid + IF( .NOT. grid_is_global(tl_lon0, tl_lat0) )THEN + IF( grid_is_global(tl_lon1, tl_lat1) )THEN + + ll_coincidence=.FALSE. + CALL logger_fatal("GRID CHECK COINCIDENCE:"//& + & " fine grid is global,"//& + & " coarse grid is not ") + + ELSE + il_ew1=tl_lon1%i_ew + IF( il_ew1 >= 0 )THEN + ! ew overlap + + il_ew0=tl_lon0%i_ew + IF( il_ew0 < 0 )THEN + CALL logger_fatal("GRID CHECK COINCIDENCE: "//& + & "fine grid has east west overlap,"//& + & " coarse grid not ") + ENDIF + + il_jmin1=1+ip_ghost + il_jmax1=tl_lon1%t_dim(2)%i_len-ip_ghost + + ll_coincidence=grid__check_lat(& + & tl_lat0%d_value(1,:,1,1),& + & tl_lat1%d_value(1,il_jmin1:il_jmax1,1,1)) + + ELSE + ! other case + il_imin1=1+ip_ghost + il_jmin1=1+ip_ghost + + il_imax1=tl_lon1%t_dim(1)%i_len-ip_ghost + il_jmax1=tl_lon1%t_dim(2)%i_len-ip_ghost + + ll_coincidence=grid__check_corner(& + & tl_lon0%d_value(:,:,1,1),& + & tl_lat0%d_value(:,:,1,1),& + & tl_lon1%d_value(il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & 1,1),& + & tl_lat1%d_value(il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & 1,1) ) + + ENDIF + + ENDIF + + IF( .NOT. ll_coincidence )THEN + CALL logger_fatal("GRID CHECK COINCIDENCE: no coincidence "//& + & "between fine grid and coarse grid: invalid domain." ) + ENDIF + + ENDIF + + ! check refinement factor + ! select point in middle of fine grid + il_imid1=INT(tl_lon1%t_dim(1)%i_len*0.5) + il_jmid1=INT(tl_lon1%t_dim(2)%i_len*0.5) + + dl_lon1=tl_lon1%d_value(il_imid1, il_jmid1,1,1) + dl_lat1=tl_lat1%d_value(il_imid1, il_jmid1,1,1) + + ! select closest point on coarse grid + il_ind0(:)=grid_get_closest(tl_lon0%d_value(:,:,1,1),& + & tl_lat0%d_value(:,:,1,1),& + & dl_lon1, dl_lat1 ) + + IF( ANY(il_ind0(:)==0) )THEN + CALL logger_fatal("GRID CHECK COINCIDENCE: can not find valid "//& + & "coarse grid indices: invalid domain." ) + ENDIF + + IF( .NOT. ll_even )THEN + ! case odd refinment in both direction + ! work on T-point + + dl_lon0=tl_lon0%d_value(il_ind0(1),il_ind0(2),1,1) + dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2),1,1) + + il_ind1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & dl_lon0, dl_lat0 ) + + ! check i-direction refinement factor + DO ji=0,MIN(3,il_imid1) + + IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN + CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& + & " to check i-direction refinement factor ") + EXIT + ELSE + dl_lon0=tl_lon0%d_value(il_ind0(1)+ji ,il_ind0(2),1,1) + dl_lon1=tl_lon1%d_value(il_ind1(1)+ji*id_rho(jp_I),il_ind1(2),1,1) + + ! assume there could be little difference due to interpolation + IF( ABS(dl_lon1 - dl_lon0) > dp_delta )THEN + ll_coincidence=.FALSE. + CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& + & "i-direction refinement factor ("//& + & TRIM(fct_str(id_rho(jp_I)))//& + & ") between fine grid and coarse grid ") + ENDIF + ENDIF + + ENDDO + + ! check j-direction refinement factor + DO jj=0,MIN(3,il_jmid1) + + IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN + CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& + & " to check j-direction refinement factor ") + EXIT + ELSE + dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2)+jj ,1,1) + dl_lat1=tl_lat1%d_value(il_ind1(1),il_ind1(2)+jj*id_rho(jp_J),1,1) + + ! assume there could be little difference due to interpolation + IF( ABS(dl_lat1-dl_lat0) > dp_delta )THEN + ll_coincidence=.FALSE. + CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& + & "j-direction refinement factor ("//& + & TRIM(fct_str(id_rho(jp_J)))//& + & ") between fine grid and coarse grid ") + ENDIF + ENDIF + + ENDDO + + ELSE + ! case even refinment at least in one direction + ! work on F-point + + dl_delta=dp_delta + ! look for lower left fine point in coarse cell. + IF( ll_grid0F )THEN + + ! lower left corner of coarse cell + dl_lon0F=tl_lon0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) + dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) + + ELSE + + ! approximate lower left corner of coarse cell (with T point) + dl_lon0F=( tl_lon0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & + & tl_lon0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & + & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & + & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 + + dl_lat0F=( tl_lat0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & + & tl_lat0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & + & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & + & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 + + ! as we use approximation of F-point we relax condition + dl_delta=100*dp_delta + + ENDIF + + IF( ll_grid1F )THEN + + il_ind1(:)=grid_get_closest(tl_lon1F%d_value(:,:,1,1),& + & tl_lat1F%d_value(:,:,1,1),& + & dl_lon0F, dl_lat0F ) + + ELSE + + il_ill1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & dl_lon0F, dl_lat0F, 'll' ) + + il_ilr1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & dl_lon0F, dl_lat0F, 'lr' ) + + il_iul1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & dl_lon0F, dl_lat0F, 'ul' ) + + il_iur1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& + & tl_lat1%d_value(:,:,1,1),& + & dl_lon0F, dl_lat0F, 'ur' ) + + ! as we use approximation of F-point we relax condition + dl_delta=100*dp_delta + + ENDIF + + ! check i-direction refinement factor + DO ji=0,MIN(3,il_imid1) + + IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN + CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& + & " to check i-direction refinement factor ") + EXIT + ELSE + IF( ll_grid0F )THEN + dl_lon0F=tl_lon0F%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) + ELSE + dl_lon0F= 0.25 * & + & ( tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2) ,1,1) + & + & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2) ,1,1) + & + & tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2)-1,1,1) + & + & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) ) + ENDIF + + IF( ll_grid1F )THEN + dl_lon1F= tl_lon1F%d_value( il_ind1(1)+ji*id_rho(jp_I), & + & il_ind1(2),1,1) + ELSE + dl_lon1F= 0.25 * & + & ( tl_lon1%d_value( il_ill1(1)+ji*id_rho(jp_I), & + & il_ill1(2),1,1) + & + & tl_lon1%d_value( il_ilr1(1)+ji*id_rho(jp_I), & + & il_ilr1(2),1,1) + & + & tl_lon1%d_value( il_iul1(1)+ji*id_rho(jp_I), & + & il_iul1(2),1,1) + & + & tl_lon1%d_value( il_iur1(1)+ji*id_rho(jp_I), & + & il_iur1(2),1,1) ) + + ENDIF + + ! assume there could be little difference due to interpolation + IF( ABS(dl_lon1F - dl_lon0F) > dl_delta )THEN + ll_coincidence=.FALSE. + CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& + & "i-direction refinement factor ("//& + & TRIM(fct_str(id_rho(jp_I)))//& + & ") between fine grid and coarse grid ") + ENDIF + ENDIF + + ENDDO + + ! check j-direction refinement factor + DO jj=0,MIN(3,il_jmid1) + + IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN + CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& + & " to check j-direction refinement factor ") + EXIT + ELSE + IF( ll_grid0F )THEN + dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) + ELSE + dl_lat0F= 0.25 * & + & ( tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj ,1,1) + & + & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj ,1,1) + & + & tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj-1,1,1) + & + & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) ) + ENDIF + + IF( ll_grid1F )THEN + dl_lat1F= tl_lat1F%d_value( il_ind1(1), & + & il_ind1(2)+jj*id_rho(jp_J),1,1) + ELSE + dl_lat1F= 0.25 * & + & ( tl_lat1%d_value( il_ill1(1), & + & il_ill1(2)+jj*id_rho(jp_J),1,1) + & + & tl_lat1%d_value( il_ilr1(1), & + & il_ilr1(2)+jj*id_rho(jp_J),1,1) + & + & tl_lat1%d_value( il_iul1(1), & + & il_iul1(2)+jj*id_rho(jp_J),1,1) + & + & tl_lat1%d_value( il_iur1(1), & + & il_iur1(2)+jj*id_rho(jp_J),1,1) ) + + ENDIF + + ! assume there could be little difference due to interpolation + IF( ABS(dl_lat1F - dl_lat0F) > dl_delta )THEN + ll_coincidence=.FALSE. + CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& + & "i-direction refinement factor ("//& + & TRIM(fct_str(id_rho(jp_I)))//& + & ") between fine grid and coarse grid ") + ENDIF + ENDIF + + ENDDO + ENDIF + + ! clean + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + CALL var_clean(tl_lon0) + CALL var_clean(tl_lat0) + + IF( .NOT. ll_coincidence )THEN + CALL logger_fatal("GRID CHECK COINCIDENCE: no coincidence "//& + & "between fine and coarse grid: "//& + & "invalid refinement factor" ) + ENDIF + + END SUBROUTINE grid_check_coincidence + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__check_corner(dd_lon0, dd_lat0, & + & dd_lon1, dd_lat1) & + & RESULT (lf_inside) + !------------------------------------------------------------------- + !> @brief This function check that fine grid is + !> inside coarse grid + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_lon0 array of coarse grid longitude + !> @param[in] dd_lat0 array of coarse grid latitude + !> @param[in] dd_lon1 array of fine grid longitude + !> @param[in] dd_lat1 array of fine grid latitude + !> @return true if fine grid is inside coarse grid + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lon0 + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lat0 + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lon1 + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_lat1 + + ! function + LOGICAL :: lf_inside + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape0 + INTEGER(i4), DIMENSION(2) :: il_shape1 + + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmax1 + + REAL(dp) :: dl_lon0 + REAL(dp) :: dl_lat0 + + REAL(dp) :: dl_lon1 + REAL(dp) :: dl_lat1 + ! loop indices + !---------------------------------------------------------------- + + ! init + lf_inside=.TRUE. + + il_shape0=SHAPE(dd_lon0(:,:)) + il_shape1=SHAPE(dd_lon1(:,:)) + + !1- check if fine grid inside coarse grid domain + il_imin0=1 ; il_imax0=il_shape0(1) + il_jmin0=1 ; il_jmax0=il_shape0(2) + + il_imin1=1 ; il_imax1=il_shape1(1) + il_jmin1=1 ; il_jmax1=il_shape1(2) + + ! check lower left corner + dl_lon0 = dd_lon0(il_imin0, il_jmin0) + dl_lat0 = dd_lat0(il_imin0, il_jmin0) + + dl_lon1 = dd_lon1(il_imin1, il_jmin1) + dl_lat1 = dd_lat1(il_imin1, il_jmin1) + + IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 < dl_lon0 ) .OR. & + &(ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 < dl_lat0 ) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid lower left "//& + & "corner not north east of coarse grid (imin,jmin) ") + CALL logger_debug(" fine grid lower left ( "//& + & TRIM(fct_str(dl_lon1))//","//& + & TRIM(fct_str(dl_lat1))//")" ) + CALL logger_debug(" coarse grid lower left ( "//& + & TRIM(fct_str(dl_lon0))//","//& + & TRIM(fct_str(dl_lat0))//")" ) + lf_inside=.FALSE. + + ENDIF + + ! check upper left corner + dl_lon0 = dd_lon0(il_imin0, il_jmax0) + dl_lat0 = dd_lat0(il_imin0, il_jmax0) + + dl_lon1 = dd_lon1(il_imin1, il_jmax1) + dl_lat1 = dd_lat1(il_imin1, il_jmax1) + + IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 < dl_lon0) .OR. & + & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 > dl_lat0) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid upper left "//& + & "corner not south east of coarse grid (imin,jmax) ") + CALL logger_debug(" fine grid upper left ("//& + & TRIM(fct_str(dl_lon1))//","//& + & TRIM(fct_str(dl_lat1))//")") + CALL logger_debug(" coasre grid upper left ("//& + & TRIM(fct_str(dl_lon0))//","//& + & TRIM(fct_str(dl_lat0))//")") + lf_inside=.FALSE. + + ENDIF + + ! check lower right corner + dl_lon0 = dd_lon0(il_imax0, il_jmin0) + dl_lat0 = dd_lat0(il_imax0, il_jmin0) + + dl_lon1 = dd_lon1(il_imax1, il_jmin1) + dl_lat1 = dd_lat1(il_imax1, il_jmin1) + + + IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 > dl_lon0) .OR. & + &(ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 < dl_lat0) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid lower right "//& + & "corner not north west of coarse grid (imax,jmin) ") + CALL logger_debug(" fine grid lower right ( "//& + & TRIM(fct_str(dl_lon1))//","//& + & TRIM(fct_str(dl_lat1))//")" ) + CALL logger_debug(" coarse grid lower right ( "//& + & TRIM(fct_str(dl_lon0))//","//& + & TRIM(fct_str(dl_lat0))//")" ) + lf_inside=.FALSE. + + ENDIF + + ! check upper right corner + dl_lon0 = dd_lon0(il_imax0, il_jmax0) + dl_lat0 = dd_lat0(il_imax0, il_jmax0) + + dl_lon1 = dd_lon1(il_imax1, il_jmax1) + dl_lat1 = dd_lat1(il_imax1, il_jmax1) + + IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 > dl_lon0) .OR. & + & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 > dl_lat0) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid upper right "//& + & "corner not south west of coarse grid (imax,jmax) ") + CALL logger_debug(" fine grid upper right ( "//& + & TRIM(fct_str(dl_lon1))//","//& + & TRIM(fct_str(dl_lat1))//")" ) + CALL logger_debug(" fine imax1 jmax1 ( "//& + & TRIM(fct_str(il_imax1))//","//& + & TRIM(fct_str(il_jmax1))//")" ) + CALL logger_debug(" coarse grid upper right ( "//& + & TRIM(fct_str(dl_lon0))//","//& + & TRIM(fct_str(dl_lat0))//")" ) + CALL logger_debug(" fine imax0 jmax0 ( "//& + & TRIM(fct_str(il_imax0))//","//& + & TRIM(fct_str(il_jmax0))//")" ) + lf_inside=.FALSE. + + ENDIF + + END FUNCTION grid__check_corner + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__check_lat(dd_lat0, dd_lat1) & + & RESULT (lf_inside) + !------------------------------------------------------------------- + !> @brief This function check that fine grid latitude are + !> inside coarse grid latitude + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_lat0 array of coarse grid latitude + !> @param[in] dd_lat1 array of fine grid latitude + !> @return true if fine grid is inside coarse grid + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_lat0 + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_lat1 + + ! function + LOGICAL :: lf_inside + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_shape0 + INTEGER(i4), DIMENSION(1) :: il_shape1 + + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + ! loop indices + !---------------------------------------------------------------- + + ! init + lf_inside=.TRUE. + + il_shape0(:)=SHAPE(dd_lat0(:)) + il_shape1(:)=SHAPE(dd_lat1(:)) + + !1- check if fine grid inside coarse grid domain + il_jmin0=1 ; il_jmax0=il_shape0(1) + il_jmin1=1 ; il_jmax1=il_shape1(1) + + ! check lower left fine grid + IF( ABS(dd_lat1(il_jmin1)-dd_lat0(il_jmin0)) > dp_delta .AND. & + &dd_lat1(il_jmin1) < dd_lat0(il_jmin0) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid lower point"//& + & " not north of coarse grid (jmin) ") + CALL logger_debug(" fine grid lower point ( "//& + & TRIM(fct_str(dd_lat1(il_jmin1)))//")" ) + CALL logger_debug(" coarse grid lower point ( "//& + & TRIM(fct_str(dd_lat0(il_jmin0)))//")" ) + lf_inside=.FALSE. + + ENDIF + + ! check upper left fine grid + IF( ABS(dd_lat1(il_jmax1)-dd_lat0(il_jmax0)) > dp_delta .AND. & + &dd_lat1(il_jmax1) > dd_lat0(il_jmax0) )THEN + + CALL logger_error("GRID CHECK COINCIDENCE: fine grid upper point"//& + & " not south of coarse grid (jmax) ") + CALL logger_debug(" fine grid upper point ("//& + & TRIM(fct_str(dd_lat1(il_jmax1)))//")") + CALL logger_debug(" coasre grid upper point ("//& + & TRIM(fct_str(dd_lat0(il_jmax0)))//")") + lf_inside=.FALSE. + + ENDIF + + END FUNCTION grid__check_lat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_add_ghost(td_var, id_ghost) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add ghost cell at boundaries. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_var array of variable structure + !> @param[in] id_ghost array of ghost cell factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(2,2), INTENT(IN ) :: id_ghost + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmax + + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TVAR) :: tl_var + + ! loop indices + !---------------------------------------------------------------- + + IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + + CALL logger_warn( "ADD GHOST: dimension change in variable "//& + & TRIM(td_var%c_name) ) + + ! copy variable + tl_var=var_copy(td_var) + + CALL var_del_value(td_var) + + ! compute indice to fill center + il_imin=1+id_ghost(jp_I,1)*ip_ghost + il_jmin=1+id_ghost(jp_J,1)*ip_ghost + + il_imax=tl_var%t_dim(1)%i_len+id_ghost(jp_I,1)*ip_ghost + il_jmax=tl_var%t_dim(2)%i_len+id_ghost(jp_J,1)*ip_ghost + + ! compute new dimension + td_var%t_dim(1)%i_len = tl_var%t_dim(1)%i_len + & + & SUM(id_ghost(jp_I,:))*ip_ghost + td_var%t_dim(2)%i_len = tl_var%t_dim(2)%i_len + & + & SUM(id_ghost(jp_J,:))*ip_ghost + + ALLOCATE(dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + dl_value(:,:,:,:)=tl_var%d_fill + + dl_value(il_imin:il_imax, & + & il_jmin:il_jmax, & + & :,:) = tl_var%d_value(:,:,:,:) + + ! add variable value + CALL var_add_value(td_var,dl_value(:,:,:,:)) + + ! save variable type + td_var%i_type=tl_var%i_type + + DEALLOCATE( dl_value ) + + CALL var_clean(tl_var) + + ENDIF + + END SUBROUTINE grid_add_ghost + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_del_ghost(td_var, id_ghost) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete ghost cell at boundaries. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_var array of variable structure + !> @param[in] id_ghost array of ghost cell factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(2,2), INTENT(IN ) :: id_ghost + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmax + + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TVAR) :: tl_var + + ! loop indices + !---------------------------------------------------------------- + + IF( ALL(td_var%t_dim(1:2)%l_use) )THEN + + IF( ANY(id_ghost(:,:)/=0) )THEN + CALL logger_warn( "GRID DEL GHOST: dimension change in variable "//& + & TRIM(td_var%c_name) ) + ENDIF + + ! copy variable + tl_var=var_copy(td_var) + + CALL var_del_value(td_var) + + ! compute indice to get center + il_imin=1+id_ghost(jp_I,1)*ip_ghost + il_jmin=1+id_ghost(jp_J,1)*ip_ghost + + il_imax=tl_var%t_dim(1)%i_len-id_ghost(jp_I,2)*ip_ghost + il_jmax=tl_var%t_dim(2)%i_len-id_ghost(jp_J,2)*ip_ghost + + ! compute new dimension + td_var%t_dim(1)%i_len = il_imax - il_imin +1 + td_var%t_dim(2)%i_len = il_jmax - il_jmin +1 + + ALLOCATE(dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + dl_value(:,:,:,:)=tl_var%d_fill + + dl_value(:,:,:,:) = tl_var%d_value(il_imin:il_imax, & + & il_jmin:il_jmax, & + & :,:) + + ! add variable value + CALL var_add_value(td_var,dl_value(:,:,:,:)) + + ! save variable type + td_var%i_type=tl_var%i_type + + DEALLOCATE( dl_value ) + + CALL var_clean(tl_var) + + ENDIF + + END SUBROUTINE grid_del_ghost + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_ghost_var(td_var) & + & RESULT (if_ghost) + !------------------------------------------------------------------- + !> @brief This function check if ghost cell are used or not, and return ghost + !> cell factor (0,1) in horizontal plan. + !> + !> @details + !> check if domain is global, and if there is an East-West overlap. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] td_var variable sturcture + !> @return array of ghost cell factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + INTEGER(i4), DIMENSION(2,2) :: if_ghost + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + + ! loop indices + !---------------------------------------------------------------- + ! init + if_ghost(:,:)=0 + + IF( .NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN + CALL logger_error("GRID GET GHOST: "//TRIM(td_var%c_name)//" is not a suitable"//& + & " variable to look for ghost cell (not 2D).") + ELSE + IF( .NOT. ASSOCIATED(td_var%d_value) )THEN + CALL logger_error("GRID GET GHOST: no value associated to "//TRIM(td_var%c_name)//& + & ". can't look for ghost cell.") + ELSE + il_dim(:)=td_var%t_dim(:)%i_len + + IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value(il_dim(1), : ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value( : , 1 ,1,1)/=td_var%d_fill).AND.& + & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN + ! no boundary closed + CALL logger_warn("GRID GET GHOST: can't determined ghost cell. "//& + & "there is no boundary closed for variable "//& + & TRIM(td_var%c_name)) + + ELSE + ! check periodicity + IF(ANY(td_var%d_value( 1 ,:,1,1)/=td_var%d_fill).OR.& + & ANY(td_var%d_value(il_dim(1),:,1,1)/=td_var%d_fill))THEN + ! East-West cyclic (1,4,6) + CALL logger_info("GRID GET GHOST: East West cyclic") + if_ghost(jp_I,:)=0 + + IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN + ! South boundary not closed + + CALL logger_debug("GRID GET GHOST: East_West cyclic") + CALL logger_debug("GRID GET GHOST: South boundary not closed") + CALL logger_error("GRID GET GHOST: should have been an "//& + & "impossible case") + + ELSE + ! South boundary closed (1,4,6) + CALL logger_info("GRID GET GHOST: South boundary closed") + if_ghost(jp_J,1)=1 + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill) )THEN + ! North boundary not closed (4,6) + CALL logger_info("GRID GET GHOST: North boundary not closed") + if_ghost(jp_J,2)=0 + ELSE + ! North boundary closed + CALL logger_info("GRID GET GHOST: North boundary closed") + if_ghost(jp_J,2)=1 + ENDIF + + ENDIF + + ELSE + ! East-West boundaries closed (0,2,3,5) + CALL logger_info("GRID GET GHOST: East West boundaries closed") + if_ghost(jp_I,:)=1 + + IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN + ! South boundary not closed (2) + CALL logger_info("GRID GET GHOST: South boundary not closed") + if_ghost(jp_J,1)=0 + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN + ! North boundary not closed + CALL logger_debug("GRID GET GHOST: East West boundaries "//& + & "closed") + CALL logger_debug("GRID GET GHOST: South boundary not closed") + CALL logger_debug("GRID GET GHOST: North boundary not closed") + CALL logger_error("GRID GET GHOST: should have been "//& + & "an impossible case") + ELSE + ! North boundary closed + if_ghost(jp_J,2)=1 + ENDIF + + ELSE + ! South boundary closed (0,3,5) + CALL logger_info("GRID GET GHOST: South boundary closed") + if_ghost(jp_J,1)=1 + + IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN + ! North boundary not closed (3,5) + CALL logger_info("GRID GET GHOST: North boundary not closed") + if_ghost(jp_J,2)=0 + ELSE + ! North boundary closed + CALL logger_info("GRID GET GHOST: North boundary closed") + if_ghost(jp_J,2)=1 + ENDIF + + ENDIF + + ENDIF + + ENDIF + + ENDIF + ENDIF + + END FUNCTION grid__get_ghost_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid__get_ghost_mpp(td_mpp) & + & RESULT (if_ghost) + !------------------------------------------------------------------- + !> @brief This function check if ghost cell are used or not, and return ghost + !> cell factor (0,1) in i- and j-direction. + !> + !> @details + !> get longitude an latitude array, then + !> check if domain is global, and if there is an East-West overlap + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date October, 2014 + !> - work on mpp file structure instead of file structure + !> + !> @param[in] td_file file sturcture + !> @return array of ghost cell factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + + ! function + INTEGER(i4), DIMENSION(2,2) :: if_ghost + + ! local variable + !TYPE(TVAR) :: tl_lon + !TYPE(TVAR) :: tl_lat + + TYPE(TMPP) :: tl_mpp + + !INTEGER(i4) :: il_lonid + !INTEGER(i4) :: il_latid + ! loop indices + !---------------------------------------------------------------- + ! init + if_ghost(:,:)=0 + + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + CALL logger_error("GRID GET GHOST: decomposition of mpp file "//& + & TRIM(td_mpp%c_name)//" not defined." ) + + ELSE + + ! copy structure + tl_mpp=mpp_copy(td_mpp) + + CALL logger_info("GRID GET FINE GHOST perio"//TRIM(fct_str(tl_mpp%i_perio))) + IF( tl_mpp%i_perio < 0 )THEN + ! compute NEMO periodicity index + CALL grid_get_info(tl_mpp) + ENDIF + + SELECT CASE(tl_mpp%i_perio) + CASE(0) + if_ghost(:,:)=1 + CASE(1) + if_ghost(jp_J,:)=1 + CASE(2) + if_ghost(jp_I,:)=1 + if_ghost(jp_J,2)=1 + CASE(3,5) + if_ghost(jp_I,:)=1 + if_ghost(jp_J,1)=1 + CASE(4,6) + if_ghost(jp_J,1)=1 + CASE DEFAULT + END SELECT + + ! clean + CALL mpp_clean(tl_mpp) + + ENDIF + + END FUNCTION grid__get_ghost_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_split_domain(td_var, id_level) & + & RESULT (if_mask) + !------------------------------------------------------------------- + !> @brief This subroutine compute closed sea domain. + !> + !> @details + !> to each domain is associated a negative value id (from -1 to ...)<br/> + !> optionaly you could specify which level use (default 1) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable strucutre + !> @param[in] id_level level + !> @return domain mask + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var + INTEGER(i4), INTENT(IN), OPTIONAL :: id_level + + ! function + INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len ) :: if_mask + + ! local variable + INTEGER(i4) :: il_domid + INTEGER(i4) :: il_level + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(2) :: il_ind + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp + + LOGICAL :: ll_full + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jim + INTEGER(i4) :: jip + INTEGER(i4) :: jj + INTEGER(i4) :: jjm + INTEGER(i4) :: jjp + !---------------------------------------------------------------- + il_level=1 + IF( PRESENT(id_level) ) il_level=id_level + + ! init + il_domid=-1 + + il_shape(:)=td_var%t_dim(1:2)%i_len + if_mask(:,:)=0 + WHERE( td_var%d_value(:,:,il_level,1)/=td_var%d_fill ) if_mask(:,:)=1 + + il_ind(:)=MAXLOC( if_mask(:,:) ) + DO WHILE( if_mask(il_ind(1), il_ind(2)) == 1 ) + + if_mask(il_ind(1),il_ind(2))=il_domid + ll_full=.FALSE. + + ALLOCATE( il_tmp(il_shape(1),il_shape(2)) ) + + DO WHILE( .NOT. ll_full ) + il_tmp(:,:)=0 + + ll_full=.TRUE. + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + IF( if_mask(ji,jj)==il_domid )THEN + jim=MAX(1,ji-1) ; jip=MIN(il_shape(1),ji+1) + jjm=MAX(1,jj-1) ; jjp=MIN(il_shape(2),jj+1) + + WHERE( if_mask(jim:jip,jjm:jjp)==1 ) + if_mask(jim:jip,jjm:jjp)=il_domid + il_tmp(jim:jip,jjm:jjp)=1 + END WHERE + + ENDIF + ENDDO + ENDDO + IF( SUM(il_tmp(:,:))/=0 ) ll_full=.FALSE. + + ENDDO + DEALLOCATE( il_tmp ) + + il_ind(:)=MAXLOC( if_mask(:,:) ) + il_domid=il_domid-1 + + ENDDO + + CALL logger_info("GRID SPLIT DOMAIN: "//TRIM( fct_str(ABS(il_domid+1)) )//& + & " domain found" ) + + END FUNCTION grid_split_domain + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_fill_small_dom(td_var, id_mask, id_minsize) + !------------------------------------------------------------------- + !> @brief This subroutine fill small closed sea with fill value. + !> + !> @details + !> the minimum size (number of point) of closed sea to be kept could be + !> sepcify with id_minsize. + !> By default only the biggest sea is preserve. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] id_mask domain mask (from grid_split_domain) + !> @param[in] id_minsize minimum size of sea to be kept + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_mask + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_minsize + + ! local variable + INTEGER(i4) :: il_ndom + INTEGER(i4) :: il_minsize + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(id_mask(:,:)) + IF( ANY(il_shape(:) /= td_var%t_dim(1:2)%i_len) )THEN + CALL logger_error("GRID FILL SMALL DOM: variable and mask "//& + & "dimension differ") + ELSE + + il_ndom=MINVAL(id_mask(:,:)) + + ALLOCATE( il_tmp(il_shape(1),il_shape(2)) ) + il_tmp(:,:)=0 + DO ji=-1,il_ndom,-1 + WHERE( id_mask(:,:)==ji ) + il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji + END WHERE + ENDDO + + il_minsize=MAXVAL(il_tmp(:,:)) + IF( PRESENT(id_minsize) ) il_minsize=id_minsize + + DO jl=1,td_var%t_dim(4)%i_len + DO jk=1,td_var%t_dim(3)%i_len + WHERE( il_tmp(:,:) < il_minsize ) + td_var%d_value(:,:,jk,jl)=td_var%d_fill + END WHERE + ENDDO + ENDDO + + DEALLOCATE( il_tmp ) + + ENDIF + + END SUBROUTINE grid_fill_small_dom + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_fill_small_msk(id_mask, id_minsize) + !------------------------------------------------------------------- + !> @brief This subroutine fill small domain inside bigger one. + !> + !> @details + !> the minimum size (number of point) of domain sea to be kept + !> is specified by id_minsize. + !> smaller domain are included in the one they are embedded. + !> + !> @author J.Paul + !> @date Ferbruay, 2015 - Initial Version + !> + !> @param[inout] id_mask domain mask (from grid_split_domain) + !> @param[in] id_minsize minimum size of sea to be kept + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), DIMENSION(:,:), INTENT(INOUT) :: id_mask + INTEGER(i4), INTENT(IN ) :: id_minsize + + ! local variable + INTEGER(i4) :: il_ndom + INTEGER(i4) :: il_minsize + INTEGER(i4) :: il_msk + + INTEGER(i4) :: jim + INTEGER(i4) :: jjm + INTEGER(i4) :: jip + INTEGER(i4) :: jjp + + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp + + ! loop indices + INTEGER(i4) :: ii + INTEGER(i4) :: ij + + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(id_mask(:,:)) + il_ndom=MINVAL(id_mask(:,:)) + + ALLOCATE( il_tmp(il_shape(1),il_shape(2)) ) + il_tmp(:,:)=0 + DO ji=-1,il_ndom,-1 + WHERE( id_mask(:,:)==ji ) + il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji + END WHERE + ENDDO + + DO WHILE( id_minsize > MINVAL(il_tmp(:,:)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + + IF( il_tmp(ji,jj) < id_minsize )THEN + jim=MAX(1,ji-1) ; jip=MIN(il_shape(1),ji+1) + jjm=MAX(1,jj-1) ; jjp=MIN(il_shape(2),jj+1) + + il_msk=0 + DO ij=jjm,jjp + DO ii=jim,jip + IF( id_mask(ii,ij) /= id_mask(ji,jj) )THEN + IF( il_msk == 0 )THEN + il_msk=id_mask(ii,ij) + ELSEIF( il_msk /= id_mask(ii,ij) )THEN + CALL logger_error("GRID FILL SMALL MSK:"//& + & " small domain not embedded in bigger one."//& + & " point should be between two different"//& + & " domain.") + ENDIF + ENDIF + ENDDO + ENDDO + IF( il_msk /= 0 ) id_mask(ji,jj)=il_msk + + ENDIF + + ENDDO + ENDDO + + + il_tmp(:,:)=0 + DO ji=-1,il_ndom,-1 + WHERE( id_mask(:,:)==ji ) + il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji + END WHERE + ENDDO + + ENDDO + + DEALLOCATE( il_tmp ) + + END SUBROUTINE grid_fill_small_msk + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE grid + diff --git a/V4.0/nemo_sources/tools/SIREN/src/grid_hgr.f90 b/V4.0/nemo_sources/tools/SIREN/src/grid_hgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7063971e2875aea51462320bbb63d3b875841064 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/grid_hgr.f90 @@ -0,0 +1,1445 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module manage Horizontal grid. +!> +!> @details +!> ** Purpose : Compute the geographical position (in degre) of the +!> model grid-points, the horizontal scale factors (in meters) and +!> the Coriolis factor (in s-1). +!> +!> ** Method : The geographical position of the model grid-points is +!> defined from analytical functions, fslam and fsphi, the derivatives of which gives the horizontal scale factors e1,e2. +!> Defining two function fslam and fsphi and their derivatives in the two horizontal directions (fse1 and fse2), +!> the model grid-point position and scale factors are given by: +!> - t-point: +!> - glamt(i,j) = fslam(i ,j ) e1t(i,j) = fse1(i ,j ) +!> - gphit(i,j) = fsphi(i ,j ) e2t(i,j) = fse2(i ,j ) +!> - u-point: +!> - glamu(i,j) = fslam(i+1/2,j ) e1u(i,j) = fse1(i+1/2,j ) +!> - gphiu(i,j) = fsphi(i+1/2,j ) e2u(i,j) = fse2(i+1/2,j ) +!> - v-point: +!> - glamv(i,j) = fslam(i ,j+1/2) e1v(i,j) = fse1(i ,j+1/2) +!> - gphiv(i,j) = fsphi(i ,j+1/2) e2v(i,j) = fse2(i ,j+1/2) +!> - f-point: +!> - glamf(i,j) = fslam(i+1/2,j+1/2) e1f(i,j) = fse1(i+1/2,j+1/2) +!> - gphif(i,j) = fsphi(i+1/2,j+1/2) e2f(i,j) = fse2(i+1/2,j+1/2) +!> +!> Where fse1 and fse2 are defined by: +!> - fse1(i,j) = ra * rad * SQRT( (cos(phi) di(fslam))**2 +!> + di(fsphi) **2 )(i,j) +!> - fse2(i,j) = ra * rad * SQRT( (cos(phi) dj(fslam))**2 +!> + dj(fsphi) **2 )(i,j) +!> +!> The coriolis factor is given at z-point by: +!> - ff = 2.*omega*sin(gphif) (in s-1)<br/> +!> +!> This routine is given as an example, it must be modified +!> following the user s desiderata. nevertheless, the output as +!> well as the way to compute the model grid-point position and +!> horizontal scale factors must be respected in order to insure +!> second order accuracy schemes. +!> +!> @note If the domain is periodic, verify that scale factors are also +!> periodic, and the coriolis term again. +!> +!> ** Action : +!> - define glamt, glamu, glamv, glamf: longitude of t-, u-, v- and f-points (in degre) +!> - define gphit, gphiu, gphiv, gphit: latitude of t-, u-, v- and f-points (in degre) +!> - define e1t, e2t, e1u, e2u, e1v, e2v, e1f, e2f: horizontal +!> - scale factors (in meters) at t-, u-, v-, and f-points. +!> - define ff: coriolis factor at f-point +!> +!> References : Marti, Madec and Delecluse, 1992, JGR +!> Madec, Imbard, 1996, Clim. Dyn. +!> +!> @author +!> G, Madec +!> +!> @date March, 1988 - Original code +!> @date January, 1996 +!> - terrain following coordinates +!> @date February, 1997 +!> - print mesh informations +!> @date November, 1999 +!> - M. Imbard : NetCDF format with IO-IPSL +!> @date Augustr, 2000 +!> - D. Ludicone : Reduced section at Bab el Mandeb +!> @date September, 2001 +!> - M. Levy : eel config: grid in km, beta-plane +!> @date August, 2002 +!> - G. Madec : F90: Free form and module, namelist +!> @date January, 2004 +!> - A.M. Treguier, J.M. Molines : Case 4 (Mercator mesh) +!> use of parameters in par_CONFIG-Rxx.h90, not in namelist +!> @date May, 2004 +!> - A. Koch-Larrouy : Add Gyre configuration +!> @date February, 2011 +!> - G. Madec : add cell surface (e1e2t) +!> @date September, 2015 +!> - J, Paul : rewrite to SIREN format from $Id: domhgr.F90 5506 2015-06-29 15:19:38Z clevy $ +!> @date October, 2016 +!> - J, Paul : update from trunk (revision 6961): add wetting and drying, ice sheet coupling.. +!> - J, Paul : compute coriolis factor at f-point and at t-point +!> - J, Paul : do not use anymore special case for ORCA grid +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE grid_hgr + + USE netcdf ! nf90 library + USE kind ! F90 kind parameter + USE fct ! basic usefull function + USE global ! global parameter + USE phycst ! physical constant + USE logger ! log file manager + USE file ! file manager + USE var ! variable manager + USE dim ! dimension manager + USE dom ! domain manager + USE grid ! grid manager + USE iom ! I/O manager + USE mpp ! MPP manager + USE iom_mpp ! I/O MPP manager + USE lbc ! lateral boundary conditions + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TNAMH + + PUBLIC :: tg_tmask + PUBLIC :: tg_umask + PUBLIC :: tg_vmask + PUBLIC :: tg_fmask + +! PUBLIC :: tg_wmask +! PUBLIC :: tg_wumask +! PUBLIC :: tg_wvmask + + PUBLIC :: tg_ssmask +! PUBLIC :: tg_ssumask +! PUBLIC :: tg_ssvmask +! PUBLIC :: tg_ssfmask + + PUBLIC :: tg_glamt + PUBLIC :: tg_glamu + PUBLIC :: tg_glamv + PUBLIC :: tg_glamf + + PUBLIC :: tg_gphit + PUBLIC :: tg_gphiu + PUBLIC :: tg_gphiv + PUBLIC :: tg_gphif + + PUBLIC :: tg_e1t + PUBLIC :: tg_e1u + PUBLIC :: tg_e1v + PUBLIC :: tg_e1f + + PUBLIC :: tg_e2t + PUBLIC :: tg_e2u + PUBLIC :: tg_e2v + PUBLIC :: tg_e2f + + PUBLIC :: tg_ff_t + PUBLIC :: tg_ff_f + + PUBLIC :: tg_gcost + PUBLIC :: tg_gcosu + PUBLIC :: tg_gcosv + PUBLIC :: tg_gcosf + + PUBLIC :: tg_gsint + PUBLIC :: tg_gsinu + PUBLIC :: tg_gsinv + PUBLIC :: tg_gsinf + + ! function and subroutine + PUBLIC :: grid_hgr_init + PUBLIC :: grid_hgr_fill + PUBLIC :: grid_hgr_clean + PUBLIC :: grid_hgr_nam + + PRIVATE :: grid_hgr__fill_curv + PRIVATE :: grid_hgr__fill_reg + PRIVATE :: grid_hgr__fill_plan + PRIVATE :: grid_hgr__fill_merc + PRIVATE :: grid_hgr__fill_gyre + PRIVATE :: grid_hgr__fill_coriolis + PRIVATE :: grid_hgr__angle + + TYPE TNAMH + + CHARACTER(LEN=lc) :: c_coord + INTEGER(i4) :: i_perio + + INTEGER(i4) :: i_mshhgr + REAL(dp) :: d_ppglam0 + REAL(dp) :: d_ppgphi0 + + REAL(dp) :: d_ppe1_deg + REAL(dp) :: d_ppe2_deg +! REAL(dp) :: d_ppe1_m +! REAL(dp) :: d_ppe2_m + +! INTEGER(i4) :: i_cla + +! CHARACTER(LEN=lc) :: c_cfg + INTEGER(i4) :: i_cfg + LOGICAL :: l_bench + + END TYPE + + TYPE(TVAR), SAVE :: tg_tmask + TYPE(TVAR), SAVE :: tg_umask + TYPE(TVAR), SAVE :: tg_vmask + TYPE(TVAR), SAVE :: tg_fmask +! TYPE(TVAR), SAVE :: tg_wmask +! TYPE(TVAR), SAVE :: tg_wumask +! TYPE(TVAR), SAVE :: tg_wvmask + + TYPE(TVAR), SAVE :: tg_ssmask +! TYPE(TVAR), SAVE :: tg_ssumask +! TYPE(TVAR), SAVE :: tg_ssvmask +! TYPE(TVAR), SAVE :: tg_ssfmask + + TYPE(TVAR), SAVE :: tg_glamt + TYPE(TVAR), SAVE :: tg_glamu + TYPE(TVAR), SAVE :: tg_glamv + TYPE(TVAR), SAVE :: tg_glamf + + TYPE(TVAR), SAVE :: tg_gphit + TYPE(TVAR), SAVE :: tg_gphiu + TYPE(TVAR), SAVE :: tg_gphiv + TYPE(TVAR), SAVE :: tg_gphif + + TYPE(TVAR), SAVE :: tg_e1t + TYPE(TVAR), SAVE :: tg_e1u + TYPE(TVAR), SAVE :: tg_e1v + TYPE(TVAR), SAVE :: tg_e1f + + TYPE(TVAR), SAVE :: tg_e2t + TYPE(TVAR), SAVE :: tg_e2u + TYPE(TVAR), SAVE :: tg_e2v + TYPE(TVAR), SAVE :: tg_e2f + + TYPE(TVAR), SAVE :: tg_ff_t + TYPE(TVAR), SAVE :: tg_ff_f + + TYPE(TVAR), SAVE :: tg_gcost + TYPE(TVAR), SAVE :: tg_gcosu + TYPE(TVAR), SAVE :: tg_gcosv + TYPE(TVAR), SAVE :: tg_gcosf + + TYPE(TVAR), SAVE :: tg_gsint + TYPE(TVAR), SAVE :: tg_gsinu + TYPE(TVAR), SAVE :: tg_gsinv + TYPE(TVAR), SAVE :: tg_gsinf + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr_init(jpi, jpj, jpk, ld_domcfg) + !------------------------------------------------------------------- + !> @brief This subroutine initialise hgr structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + INTEGER(i4), INTENT(IN) :: jpk + LOGICAL , INTENT(IN) :: ld_domcfg + + REAL(dp), DIMENSION(jpi,jpj) :: dl_tmp2D + REAL(dp), DIMENSION(jpi,jpj,jpk) :: dl_tmp3D + ! loop indices + !---------------------------------------------------------------- + ! variable 2D + dl_tmp2D(:,:) =dp_fill_i1 + + tg_ssmask = var_init('ssmask' ,dl_tmp2D(:,:) , dd_fill=dp_fill_i1, id_type=NF90_BYTE) +! tg_ssumask = var_init('ssumask',dl_tmp2D(:,:) , dd_fill=dp_fill_i1, id_type=NF90_BYTE) +! tg_ssvmask = var_init('ssvmask',dl_tmp2D(:,:) , dd_fill=dp_fill_i1, id_type=NF90_BYTE) +! tg_ssfmask = var_init('ssfmask',dl_tmp2D(:,:) , dd_fill=dp_fill_i1, id_type=NF90_BYTE) + + dl_tmp2D(:,:)=dp_fill + + tg_glamt = var_init('glamt',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_glamu = var_init('glamu',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_glamv = var_init('glamv',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_glamf = var_init('glamf',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + tg_gphit = var_init('gphit',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gphiu = var_init('gphiu',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gphiv = var_init('gphiv',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gphif = var_init('gphif',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + tg_e1t = var_init('e1t' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e1u = var_init('e1u' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e1v = var_init('e1v' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e1f = var_init('e1f' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + tg_e2t = var_init('e2t' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e2u = var_init('e2u' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e2v = var_init('e2v' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e2f = var_init('e2f' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + tg_ff_t = var_init('ff_t' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_ff_f = var_init('ff_f' ,dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + IF( .NOT. ld_domcfg )THEN + tg_gcost =var_init('gcost',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gcosu =var_init('gcosu',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gcosv =var_init('gcosv',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gcosf =var_init('gcosf',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + tg_gsint =var_init('gsint',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gsinu =var_init('gsinu',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gsinv =var_init('gsinv',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gsinf =var_init('gsinf',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + ENDIF + + ! variable 3D + dl_tmp3D(:,:,:)=dp_fill_i1 + + tg_tmask = var_init('tmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) + tg_umask = var_init('umask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) + tg_vmask = var_init('vmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) + IF( .NOT. ld_domcfg )THEN + tg_fmask = var_init('fmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) + ENDIF + +! tg_wmask = var_init('wmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) +! tg_wumask = var_init('wumask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) +! tg_wvmask = var_init('wvmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE) + + END SUBROUTINE grid_hgr_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr_clean(ld_domcfg) + !------------------------------------------------------------------- + !> @brief This subroutine clean hgr structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + LOGICAL , INTENT(IN) :: ld_domcfg + + ! local variable + ! loop indices + !---------------------------------------------------------------- + CALL var_clean(tg_ssmask ) + + CALL var_clean(tg_glamt) + CALL var_clean(tg_glamu) + CALL var_clean(tg_glamv) + CALL var_clean(tg_glamf) + + CALL var_clean(tg_gphit) + CALL var_clean(tg_gphiu) + CALL var_clean(tg_gphiv) + CALL var_clean(tg_gphif) + + CALL var_clean(tg_e1t ) + CALL var_clean(tg_e1u ) + CALL var_clean(tg_e1v ) + CALL var_clean(tg_e1f ) + + CALL var_clean(tg_e2t ) + CALL var_clean(tg_e2u ) + CALL var_clean(tg_e2v ) + CALL var_clean(tg_e2f ) + + CALL var_clean(tg_ff_t ) + CALL var_clean(tg_ff_f ) + + IF( .NOT. ld_domcfg )THEN + CALL var_clean(tg_gcost ) + CALL var_clean(tg_gcosu ) + CALL var_clean(tg_gcosv ) + CALL var_clean(tg_gcosf ) + + CALL var_clean(tg_gsint ) + CALL var_clean(tg_gsinu ) + CALL var_clean(tg_gsinv ) + CALL var_clean(tg_gsinf ) + ENDIF + + CALL var_clean(tg_tmask ) + CALL var_clean(tg_umask ) + CALL var_clean(tg_vmask ) + IF( .NOT. ld_domcfg )THEN + CALL var_clean(tg_fmask ) + ENDIF + END SUBROUTINE grid_hgr_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_hgr_nam(cd_coord, id_perio, cd_namelist) & + & RESULT (tf_namh) + !------------------------------------------------------------------- + !> @brief This function initialise hgr namelist structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] cd_coord + !> @param[in] id_perio + !> @param[in] cd_namelist + !> @return hgr namelist structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_coord + INTEGER(i4) , INTENT(IN) :: id_perio + CHARACTER(LEN=*), INTENT(IN) :: cd_namelist + + ! function + TYPE(TNAMH) :: tf_namh + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + + LOGICAL :: ll_exist + + ! loop indices + ! namelist + + ! namhgr + INTEGER(i4) :: in_mshhgr = 0 + REAL(dp) :: dn_ppglam0 = NF90_FILL_DOUBLE + REAL(dp) :: dn_ppgphi0 = NF90_FILL_DOUBLE + REAL(dp) :: dn_ppe1_deg = NF90_FILL_DOUBLE + REAL(dp) :: dn_ppe2_deg = NF90_FILL_DOUBLE +! REAL(dp) :: dn_ppe1_m = NF90_FILL_DOUBLE +! REAL(dp) :: dn_ppe2_m = NF90_FILL_DOUBLE + +! ! namcla +! INTEGER(i4) :: in_cla = 0 + + ! namgrd +! CHARACTER(LEN=lc) :: cn_cfg = '' + INTEGER(i4) :: in_cfg = 0 + LOGICAL :: ln_bench = .FALSE. + + !---------------------------------------------------------------- + NAMELIST /namhgr/ & + & in_mshhgr, & !< type of horizontal mesh + !< 0: curvilinear coordinate on the sphere read in coordinate.nc + !< 1: geographical mesh on the sphere with regular grid-spacing + !< 2: f-plane with regular grid-spacing + !< 3: beta-plane with regular grid-spacing + !< 4: Mercator grid with T/U point at the equator + !< 5: beta-plane with regular grid-spacing and rotated domain (GYRE configuration) + & dn_ppglam0, & !< longitude of first raw and column T-point (in_mshhgr = 1 or 4) + & dn_ppgphi0, & !< latitude of first raw and column T-point (in_mshhgr = 1 or 4) + & dn_ppe1_deg, & !< zonal grid-spacing (degrees) (in_mshhgr = 1,2,3 or 4) + & dn_ppe2_deg !< meridional grid-spacing (degrees) (in_mshhgr = 1,2,3 or 4) +! & dn_ppe1_m, & !< zonal grid-spacing (degrees) +! & dn_ppe2_m !< meridional grid-spacing (degrees) + +! NAMELIST /namcla/ & +! & in_cla !< =1 cross land advection for exchanges through some straits (ORCA2) + + NAMELIST/namgrd/ & !< orca grid namelist +! & cn_cfg, & !< name of the configuration (orca) + & in_cfg, & !< resolution of the configuration (2,1,025..) + & ln_bench !< benchmark parameter (in_mshhgr = 5 ). + + !---------------------------------------------------------------- + ! read namelist + INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("GRID HGR NAM: error opening "//& + & TRIM(cd_namelist)) + ENDIF + + READ( il_fileid, NML = namhgr ) +! READ( il_fileid, NML = namcla ) +! READ( il_fileid, NML = namgrd ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("GRID HGR NAM: closing "//TRIM(cd_namelist)) + ENDIF + + tf_namh%c_coord = TRIM(cd_coord) + tf_namh%i_perio = id_perio + + tf_namh%i_mshhgr = in_mshhgr + tf_namh%d_ppglam0 = dn_ppglam0 + tf_namh%d_ppgphi0 = dn_ppgphi0 + + tf_namh%d_ppe1_deg= dn_ppe1_deg + tf_namh%d_ppe2_deg= dn_ppe2_deg +! tf_namh%d_ppe1_m = dn_ppe1_m +! tf_namh%d_ppe2_m = dn_ppe2_m + +! tf_namh%i_cla = in_cla + +! tf_namh%c_cfg = TRIM(cn_cfg) + tf_namh%i_cfg = in_cfg + tf_namh%l_bench = ln_bench + + ELSE + + CALL logger_fatal(" GRID HGR NAM: can't find "//TRIM(cd_namelist)) + + ENDIF + + END FUNCTION grid_hgr_nam + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr_fill(td_nam, jpi, jpj, ld_domcfg) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + LOGICAL , INTENT(IN) :: ld_domcfg + + ! local variable + REAL(dp) :: znorme + ! loop indices + !---------------------------------------------------------------- + CALL logger_info('GRID HGR FILL : define the horizontal mesh from the'//& + & ' type of horizontal mesh mshhgr = '//TRIM(fct_str(td_nam%i_mshhgr))) + IF( td_nam%i_mshhgr == 1 )THEN + CALL logger_info(' position of the first row and ppglam0 = '//& + & TRIM(fct_str(td_nam%d_ppglam0 )) ) + CALL logger_info(' column grid-point (degrees) ppgphi0 = '//& + & TRIM(fct_str(td_nam%d_ppgphi0 )) ) + ELSEIF( td_nam%i_mshhgr == 2 .OR. td_nam%i_mshhgr == 3 )THEN + CALL logger_info(' zonal grid-spacing (degrees) ppe1_deg = '//& + & TRIM(fct_str(td_nam%d_ppe1_deg )) ) + CALL logger_info(' meridional grid-spacing (degrees) ppe2_deg = '//& + & TRIM(fct_str(td_nam%d_ppe2_deg )) ) +! CALL logger_info(' zonal grid-spacing (meters) ppe1_m = '//& +! & TRIM(fct_str(td_nam%d_ppe1_m )) ) +! CALL logger_info(' meridional grid-spacing (meters) ppe2_m = '//& +! & TRIM(fct_str(td_nam%d_ppe2_m )) ) + ENDIF + + SELECT CASE( td_nam%i_mshhgr ) ! type of horizontal mesh + + CASE(0) ! curvilinear coordinate on the sphere read in coordinate.nc file + + CALL grid_hgr__fill_curv(td_nam)!,jpi,jpj) + + CASE(1) ! geographical mesh on the sphere with regular grid-spacing + + CALL grid_hgr__fill_reg(td_nam,jpi,jpj) + + CASE(2:3) ! f- or beta-plane with regular grid-spacing + + CALL grid_hgr__fill_plan(td_nam,jpi,jpj) + + CASE(4) ! geographical mesh on the sphere, isotropic MERCATOR type + + CALL grid_hgr__fill_merc(td_nam,jpi,jpj) + + CASE(5) ! beta-plane with regular grid-spacing and rotated domain (GYRE configuration) + + CALL grid_hgr__fill_gyre(td_nam,jpi,jpj) + + CASE DEFAULT + + CALL logger_fatal('GRID HGR FILL : bad flag value for mshhgr = '//& + & TRIM(fct_str(td_nam%i_mshhgr))) + + END SELECT + + ! No Useful associated horizontal metrics + ! --------------------------------------- + + ! create coriolis factor + CALL grid_hgr__fill_coriolis(td_nam,jpi)!,jpj) + + ! Control of domain for symetrical condition + ! ------------------------------------------ + ! The equator line must be the latitude coordinate axe + + IF( td_nam%i_perio == 2 ) THEN + znorme = SQRT( SUM(tg_gphiu%d_value(:,2,1,1)*tg_gphiu%d_value(:,2,1,1)) ) / FLOAT( jpi ) + IF( znorme > 1.e-13 )THEN + CALL logger_fatal( ' ===>>>> : symmetrical condition: rerun with good equator line' ) + ENDIF + ENDIF + + ! compute angles between model grid lines and the North direction + ! --------------------------------------------------------------- + IF( .NOT. ld_domcfg )THEN + CALL grid_hgr__angle(td_nam,jpi,jpj) + ENDIF + + END SUBROUTINE grid_hgr_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_curv(td_nam)!,jpi,jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> for case of curvilinear coordinate on the sphere read in coordinate.nc file + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> @date October, 2016 + !> - do not use anymore special case for ORCA grid + !> + !> @param[in] td_nam + ! @param[in] jpi + ! @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam +! INTEGER(i4), INTENT(IN) :: jpi +! INTEGER(i4), INTENT(IN) :: jpj + + ! local variable +! INTEGER(i4) :: ii0, ii1, ij0, ij1 ! temporary integers +! INTEGER(i4) :: isrow ! index for ORCA1 starting row + + TYPE(TMPP) :: tl_coord + + ! loop indices + !---------------------------------------------------------------- + + ! read coordinates + ! open file + IF( td_nam%c_coord /= '' )THEN + tl_coord=mpp_init( file_init(TRIM(td_nam%c_coord)), id_perio=td_nam%i_perio) + CALL grid_get_info(tl_coord) + ELSE + CALL logger_fatal("GRID HGR FILL: no input coordinates file found. "//& + & "check namelist") + ENDIF + + CALL iom_mpp_open( tl_coord ) + + ! read variable in coordinates + tg_glamt=iom_mpp_read_var(tl_coord, 'glamt') + tg_glamu=iom_mpp_read_var(tl_coord, 'glamu') + tg_glamv=iom_mpp_read_var(tl_coord, 'glamv') + tg_glamf=iom_mpp_read_var(tl_coord, 'glamf') + + tg_gphit=iom_mpp_read_var(tl_coord, 'gphit') + tg_gphiu=iom_mpp_read_var(tl_coord, 'gphiu') + tg_gphiv=iom_mpp_read_var(tl_coord, 'gphiv') + tg_gphif=iom_mpp_read_var(tl_coord, 'gphif') + + ! force output type + tg_glamt%i_type=NF90_DOUBLE + tg_glamu%i_type=NF90_DOUBLE + tg_glamv%i_type=NF90_DOUBLE + tg_glamf%i_type=NF90_DOUBLE + + tg_gphit%i_type=NF90_DOUBLE + tg_gphiu%i_type=NF90_DOUBLE + tg_gphiv%i_type=NF90_DOUBLE + tg_gphif%i_type=NF90_DOUBLE + + tg_e1t =iom_mpp_read_var(tl_coord, 'e1t') + tg_e1u =iom_mpp_read_var(tl_coord, 'e1u') + tg_e1v =iom_mpp_read_var(tl_coord, 'e1v') + tg_e1f =iom_mpp_read_var(tl_coord, 'e1f') + + tg_e2t =iom_mpp_read_var(tl_coord, 'e2t') + tg_e2u =iom_mpp_read_var(tl_coord, 'e2u') + tg_e2v =iom_mpp_read_var(tl_coord, 'e2v') + tg_e2f =iom_mpp_read_var(tl_coord, 'e2f') + + CALL iom_mpp_close( tl_coord ) + ! clean + CALL mpp_clean(tl_coord) + + !! WARNING extended grid have to be correctly fill + +! !! special case for ORCA grid +! ! ORCA R2 configuration +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 2 ) THEN +! IF( td_nam%i_cla == 0 ) THEN +! ! +! ! Gibraltar Strait (e2u = 20 km) +! ii0 = 139 ; ii1 = 140 +! ij0 = 102 ; ij1 = 102 +! ! e2u = 20 km +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 20.e3 +! CALL logger_info('orca_r2: Gibraltar : e2u reduced to 20 km') +! ! +! ! Bab el Mandeb (e2u = 18 km) +! ii0 = 160 ; ii1 = 160 +! ij0 = 88 ; ij1 = 88 +! ! e1v = 18 km +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 18.e3 +! ! e2u = 30 km +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 30.e3 +! +! CALL logger_info('orca_r2: Bab el Mandeb: e2u reduced to 30 km') +! CALL logger_info('e1v reduced to 18 km') +! ENDIF +! ! Danish Straits +! ii0 = 145 ; ii1 = 146 +! ij0 = 116 ; ij1 = 116 +! ! e2u = 10 km +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 10.e3 +! CALL logger_info('orca_r2: Danish Straits : e2u reduced to 10 km') +! ENDIF +! +! ! ORCA R1 configuration +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 1 ) THEN +! ! This dirty section will be suppressed by simplification process: all this will come back in input files +! ! Currently these hard-wired indices relate to configuration with +! ! extend grid (jpjglo=332) +! ! which had a grid-size of 362x292. +! +! isrow = 332 - jpj +! +! ! Gibraltar Strait (e2u = 20 km) +! ii0 = 282 ; ii1 = 283 +! ij0 = 201 + isrow ; ij1 = 241 - isrow +! ! e2u = 20 km +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 20.e3 +! CALL logger_info('orca_r1: Gibraltar : e2u reduced to 20 km') +! +! ! Bhosporus Strait (e2u = 10 km) +! ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u = 10 km) +! ij0 = 208 + isrow ; ij1 = 248 - isrow +! ! Bhosporus Strait (e2u = 10 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 10.e3 +! CALL logger_info('orca_r1: Bhosporus : e2u reduced to 10 km') +! +! ! Lombok Strait (e1v = 13 km) +! ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v = 13 km) +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! ! Lombok Strait (e1v = 13 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 13.e3 +! CALL logger_info('orca_r1: Lombok : e1v reduced to 10 km') +! +! ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] +! ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 8.e3 +! CALL logger_info('orca_r1: Sumba : e1v reduced to 8 km') +! +! ! Ombai Strait (e1v = 13 km) +! ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v = 13 km) +! ij0 = 124 + isrow ; ij1 = 165 - isrow +! ! Ombai Strait (e1v = 13 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 13.e3 +! CALL logger_info('orca_r1: Ombai : e1v reduced to 13 km') +! +! ! Timor Passage (e1v = 20 km) +! ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v = 20 km) +! ij0 = 124 + isrow ; ij1 = 145 - isrow +! ! Timor Passage (e1v = 20 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 20.e3 +! CALL logger_info('orca_r1: Timor Passage : e1v reduced to 20 km') +! +! ! West Halmahera Strait (e1v = 30 km) +! ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v = 30 km) +! ij0 = 141 + isrow ; ij1 = 182 - isrow +! ! West Halmahera Strait (e1v = 30 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 30.e3 +! CALL logger_info('orca_r1: W Halmahera : e1v reduced to 30 km') +! +! ! East Halmahera Strait (e1v = 50 km) +! ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v = 50 km) +! ij0 = 141 + isrow ; ij1 = 182 - isrow +! ! East Halmahera Strait (e1v = 50 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 50.e3 +! CALL logger_info('orca_r1: E Halmahera : e1v reduced to 50 km') +! +! ENDIF +! +! ! ORCA R05 configuration +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 05 ) THEN +! +! ! Gibraltar Strait (e2u = 20 km) +! ii0 = 563 ; ii1 = 564 ! Gibraltar Strait (e2u = 20 km) +! ij0 = 327 ; ij1 = 327 +! ! Gibraltar Strait (e2u = 20 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 20.e3 +! CALL logger_info('orca_r05: Reduced e2u at the Gibraltar Strait') +! ! +! ! Bosphore Strait (e2u = 10 km) +! ii0 = 627 ; ii1 = 628 ! Bosphore Strait (e2u = 10 km) +! ij0 = 343 ; ij1 = 343 +! ! Bosphore Strait (e2u = 10 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 10.e3 +! CALL logger_info('orca_r05: Reduced e2u at the Bosphore Strait') +! ! +! ! Sumba Strait (e2u = 40 km) +! ii0 = 93 ; ii1 = 94 ! Sumba Strait (e2u = 40 km) +! ij0 = 232 ; ij1 = 232 +! ! Sumba Strait (e2u = 40 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 40.e3 +! CALL logger_info('orca_r05: Reduced e2u at the Sumba Strait') +! ! +! ! Ombai Strait (e2u = 15 km) +! ii0 = 103 ; ii1 = 103 ! Ombai Strait (e2u = 15 km) +! ij0 = 232 ; ij1 = 232 +! ! Ombai Strait (e2u = 15 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 15.e3 +! CALL logger_info('orca_r05: Reduced e2u at the Ombai Strait') +! ! +! ! Palk Strait (e2u = 10 km) +! ii0 = 15 ; ii1 = 15 ! Palk Strait (e2u = 10 km) +! ij0 = 270 ; ij1 = 270 +! ! Palk Strait (e2u = 10 km) +! tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) = 10.e3 +! CALL logger_info('orca_r05: Reduced e2u at the Palk Strait') +! ! +! ! Lombok Strait (e1v = 10 km) +! ii0 = 87 ; ii1 = 87 ! Lombok Strait (e1v = 10 km) +! ij0 = 232 ; ij1 = 233 +! ! Lombok Strait (e1v = 10 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 10.e3 +! CALL logger_info('orca_r05: Reduced e1v at the Lombok Strait') +! ! +! ! +! ! Bab el Mandeb (e1v = 25 km) +! ii0 = 662 ; ii1 = 662 ! Bab el Mandeb (e1v = 25 km) +! ij0 = 276 ; ij1 = 276 +! ! Bab el Mandeb (e1v = 25 km) +! tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 25.e3 +! CALL logger_info('orca_r05: Reduced e1v at the Bab el Mandeb') +! +! ENDIF + + END SUBROUTINE grid_hgr__fill_curv + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_reg(td_nam, jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> for case of geographical mesh on the sphere with regular grid-spacing + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp) :: zti, zui, zvi, zfi ! local scalars + REAL(dp) :: ztj, zuj, zvj, zfj ! + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info('GRID HGR FILL : geographical mesh on the sphere with'//& + & ' regular grid-spacing given by ppe1_deg and ppe2_deg') + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 ) ; ztj = FLOAT( jj - 1 ) + zui = FLOAT( ji - 1 ) + 0.5 ; zuj = FLOAT( jj - 1 ) + zvi = FLOAT( ji - 1 ) ; zvj = FLOAT( jj - 1 ) + 0.5 + zfi = FLOAT( ji - 1 ) + 0.5 ; zfj = FLOAT( jj - 1 ) + 0.5 + ! Longitude + tg_glamt%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zti + tg_glamu%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zui + tg_glamv%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zvi + tg_glamf%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zfi + ! Latitude + tg_gphit%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * ztj + tg_gphiu%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zuj + tg_gphiv%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zvj + tg_gphif%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zfj + ! e1 + tg_e1t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + ! e2 + tg_e2t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg + tg_e2u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg + tg_e2v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg + tg_e2f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg + END DO + END DO + + END SUBROUTINE grid_hgr__fill_reg + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_plan(td_nam, jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> for case of f- or beta-plane with regular grid-spacing + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp) :: dl_glam0 + REAL(dp) :: dl_gphi0 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info('GRID HGR FILL : f- or beta-plane with regular'//& + & ' grid-spacing given by ppe1_deg and ppe2_deg') +! & ' grid-spacing given by ppe1_m and ppe2_m') + + ! Position coordinates (in kilometers) + ! ========== + dl_glam0 = 0.e0 + dl_gphi0 = - td_nam%d_ppe2_deg * 1.e-3 +! dl_gphi0 = - td_nam%d_ppe2_m * 1.e-3 + + ! + DO jj = 1, jpj + DO ji = 1, jpi +! tg_glamt%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_m * 1.e-3 * ( FLOAT( ji - 1 ) ) +! tg_glamu%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_m * 1.e-3 * ( FLOAT( ji - 1 ) + 0.5 ) + tg_glamt%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_deg * 1.e-3 * ( FLOAT( ji - 1 ) ) + tg_glamu%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_deg * 1.e-3 * ( FLOAT( ji - 1 ) + 0.5 ) + tg_glamv%d_value(ji,jj,1,1) = tg_glamt%d_value(ji,jj,1,1) + tg_glamf%d_value(ji,jj,1,1) = tg_glamu%d_value(ji,jj,1,1) + + !tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_m * 1.e-3 * ( FLOAT( jj - 1 ) ) + tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_deg * 1.e-3 * ( FLOAT( jj - 1 ) ) + tg_gphiu%d_value(ji,jj,1,1) = tg_gphit%d_value(ji,jj,1,1) + !tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_m * 1.e-3 * ( FLOAT( jj - 1 ) + 0.5 ) + tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_deg * 1.e-3 * ( FLOAT( jj - 1 ) + 0.5 ) + tg_gphif%d_value(ji,jj,1,1) = tg_gphiv%d_value(ji,jj,1,1) + END DO + END DO + + ! Horizontal scale factors (in meters) + ! ====== +! tg_e1t%d_value(:,:,1,1) = td_nam%d_ppe1_m +! tg_e1u%d_value(:,:,1,1) = td_nam%d_ppe1_m +! tg_e1v%d_value(:,:,1,1) = td_nam%d_ppe1_m +! tg_e1f%d_value(:,:,1,1) = td_nam%d_ppe1_m + tg_e1t%d_value(:,:,1,1) = td_nam%d_ppe1_deg + tg_e1u%d_value(:,:,1,1) = td_nam%d_ppe1_deg + tg_e1v%d_value(:,:,1,1) = td_nam%d_ppe1_deg + tg_e1f%d_value(:,:,1,1) = td_nam%d_ppe1_deg + +! tg_e2t%d_value(:,:,1,1) = td_nam%d_ppe2_m +! tg_e2u%d_value(:,:,1,1) = td_nam%d_ppe2_m +! tg_e2v%d_value(:,:,1,1) = td_nam%d_ppe2_m +! tg_e2f%d_value(:,:,1,1) = td_nam%d_ppe2_m + tg_e2t%d_value(:,:,1,1) = td_nam%d_ppe2_deg + tg_e2u%d_value(:,:,1,1) = td_nam%d_ppe2_deg + tg_e2v%d_value(:,:,1,1) = td_nam%d_ppe2_deg + tg_e2f%d_value(:,:,1,1) = td_nam%d_ppe2_deg + + END SUBROUTINE grid_hgr__fill_plan + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_merc(td_nam, jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> for case of geographical mesh on the sphere, isotropic MERCATOR type + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + INTEGER :: ijeq ! index of equator T point (used in case 4) + + REAL(dp) :: zti, zui, zvi, zfi ! local scalars + REAL(dp) :: ztj, zuj, zvj, zfj ! + REAL(dp) :: zarg + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info('GRID HGR FILL : geographical mesh on the sphere, '//& + & 'MERCATOR type longitudinal/latitudinal spacing given by ppe1_deg') + + IF( td_nam%d_ppgphi0 == -90 )THEN + CALL logger_fatal(' Mercator grid cannot start at south pole !!!! ' ) + ENDIF + + ! Find index corresponding to the equator, given the grid spacing e1_deg + ! and the (approximate) southern latitude ppgphi0. + ! This way we ensure that the equator is at a "T / U" point, when in the domain. + ! The formula should work even if the equator is outside the domain. + zarg = dp_pi / 4. - dp_pi / 180. * td_nam%d_ppgphi0 / 2. + ijeq = ABS( 180./dp_pi * LOG( COS( zarg ) / SIN( zarg ) ) / td_nam%d_ppe1_deg ) + IF( td_nam%d_ppgphi0 > 0 ) ijeq = -ijeq + + CALL logger_info('Index of the equator on the MERCATOR grid: '//TRIM(fct_str(ijeq))) + + DO jj = 1, jpj + DO ji = 1, jpi + zti = FLOAT( ji - 1 ) ; ztj = FLOAT( jj - ijeq ) + zui = FLOAT( ji - 1 ) + 0.5 ; zuj = FLOAT( jj - ijeq ) + zvi = FLOAT( ji - 1 ) ; zvj = FLOAT( jj - ijeq ) + 0.5 + zfi = FLOAT( ji - 1 ) + 0.5 ; zfj = FLOAT( jj - ijeq ) + 0.5 + ! Longitude + tg_glamt%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zti + tg_glamu%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zui + tg_glamv%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zvi + tg_glamf%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zfi + ! Latitude + tg_gphit%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* ztj ) ) + tg_gphiu%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zuj ) ) + tg_gphiv%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zvj ) ) + tg_gphif%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zfj ) ) + ! e1 + tg_e1t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e1f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + ! e2 + tg_e2t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e2u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e2v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + tg_e2f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg + END DO + END DO + + END SUBROUTINE grid_hgr__fill_merc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_gyre(td_nam, jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill horizontal mesh (hgr structure) + !> for case of beta-plane with regular grid-spacing and rotated domain (GYRE configuration) + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp) :: zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg + REAL(dp) :: zphi1, zsin_alpha, zim05, zjm05 + + REAL(dp) :: dl_glam0 + REAL(dp) :: dl_gphi0 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info('GRID HGR FILL : beta-plane with regular grid-spacing '//& + & 'and rotated domain (GYRE configuration)') + + ! Position coordinates (in kilometers) + ! + ! angle 45deg and ze1=106.e+3 / jp_cfg forced -> zlam1 = -85deg, zphi1 = 29degN + zlam1 = -85 + zphi1 = 29 + ! resolution in meters + ze1 = 106000. / FLOAT(td_nam%i_cfg) + ! benchmark: forced the resolution to be about 100 km + IF( td_nam%l_bench ) ze1 = 106000.e0 + zsin_alpha = - SQRT( 2. ) / 2. + zcos_alpha = SQRT( 2. ) / 2. + ze1deg = ze1 / (dp_rearth * dp_deg2rad) + dl_glam0 = zlam1 + zcos_alpha * ze1deg * FLOAT( jpj-2 ) + dl_gphi0 = zphi1 + zsin_alpha * ze1deg * FLOAT( jpj-2 ) + + DO jj = 1, jpj + DO ji = 1, jpi + zim1 = FLOAT( ji - 1 ) ; zim05 = FLOAT( ji ) - 1.5 + zjm1 = FLOAT( jj - 1 ) ; zjm05 = FLOAT( jj ) - 1.5 + + tg_glamf%d_value(ji,jj,1,1) = dl_glam0 & + & + zim1 * ze1deg * zcos_alpha & + & + zjm1 * ze1deg * zsin_alpha + tg_gphif%d_value(ji,jj,1,1) = dl_gphi0 & + & - zim1 * ze1deg * zsin_alpha & + & + zjm1 * ze1deg * zcos_alpha + + tg_glamt%d_value(ji,jj,1,1) = dl_glam0 & + & + zim05 * ze1deg * zcos_alpha & + & + zjm05 * ze1deg * zsin_alpha + tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 & + & - zim05 * ze1deg * zsin_alpha & + & + zjm05 * ze1deg * zcos_alpha + + tg_glamu%d_value(ji,jj,1,1) = dl_glam0 & + & + zim1 * ze1deg * zcos_alpha & + & + zjm05 * ze1deg * zsin_alpha + tg_gphiu%d_value(ji,jj,1,1) = dl_gphi0 & + & - zim1 * ze1deg * zsin_alpha & + & + zjm05 * ze1deg * zcos_alpha + + tg_glamv%d_value(ji,jj,1,1) = dl_glam0 & + & + zim05 * ze1deg * zcos_alpha & + & + zjm1 * ze1deg * zsin_alpha + tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 & + & - zim05 * ze1deg * zsin_alpha & + & + zjm1 * ze1deg * zcos_alpha + + END DO + END DO + + ! Horizontal scale factors (in meters) + ! ====== + tg_e1t%d_value(:,:,1,1) = ze1 + tg_e1u%d_value(:,:,1,1) = ze1 + tg_e1v%d_value(:,:,1,1) = ze1 + tg_e1f%d_value(:,:,1,1) = ze1 + + tg_e2t%d_value(:,:,1,1) = ze1 + tg_e2u%d_value(:,:,1,1) = ze1 + tg_e2v%d_value(:,:,1,1) = ze1 + tg_e2f%d_value(:,:,1,1) = ze1 + + END SUBROUTINE grid_hgr__fill_gyre + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__fill_coriolis(td_nam, jpi)!,jpj) + !------------------------------------------------------------------- + !> @brief This subroutine fill coriolis factor + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> @date October, 2016 + !> - compute coriolis factor at f-point and at t-point + !> + !> @param[in] td_nam + !> @param[in] jpi + ! @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi +! INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp) :: zbeta + REAL(dp) :: zphi0 + REAL(dp) :: zf0 + + ! loop indices + !---------------------------------------------------------------- + + ! Coriolis factor + SELECT CASE( td_nam%i_mshhgr ) ! type of horizontal mesh + + CASE ( 0, 1, 4 ) ! mesh on the sphere + + tg_ff_f%d_value(:,:,1,1) = 2. * dp_omega * SIN(dp_deg2rad * tg_gphif%d_value(:,:,1,1)) + tg_ff_t%d_value(:,:,1,1) = 2. * dp_omega * SIN(dp_deg2rad * tg_gphit%d_value(:,:,1,1)) ! at t-point + + CASE ( 2 ) ! f-plane at ppgphi0 + + tg_ff_f%d_value(:,:,1,1) = 2. * dp_omega * SIN( dp_deg2rad * td_nam%d_ppgphi0 ) + tg_ff_t%d_value(:,:,1,1) = 2. * dp_omega * SIN( dp_deg2rad * td_nam%d_ppgphi0 ) + CALL logger_info('f-plane: Coriolis parameter = constant = '//& + & TRIM(fct_str(tg_ff_f%d_value(1,1,1,1))) ) + + CASE ( 3 ) ! beta-plane + + ! beta at latitude ppgphi0 + zbeta = 2. * dp_omega * COS( dp_deg2rad * td_nam%d_ppgphi0 ) / dp_rearth + ! latitude of the first row F-points +! zphi0 = td_nam%d_ppgphi0 - FLOAT( jpi/2 ) * td_nam%d_ppe2_m / ( dp_rearth * dp_deg2rad ) + zphi0 = td_nam%d_ppgphi0 - FLOAT( jpi/2 ) * td_nam%d_ppe2_deg / ( dp_rearth * dp_deg2rad ) + + ! compute f0 1st point south + zf0 = 2. * dp_omega * SIN( dp_deg2rad * zphi0 ) + ! f = f0 +beta* y ( y=0 at south) + tg_ff_f%d_value(:,:,1,1) = zf0 + zbeta * tg_gphif%d_value(:,:,1,1) * 1.e3 + tg_ff_t%d_value(:,:,1,1) = zf0 + zbeta * tg_gphit%d_value(:,:,1,1) * 1.e3 + + CASE ( 5 ) ! beta-plane and rotated domain (gyre configuration) + + ! beta at latitude ppgphi0 + zbeta = 2. * dp_omega * COS( dp_deg2rad * td_nam%d_ppgphi0 ) / dp_rearth + ! latitude of the first row F-points + zphi0 = 15.e0 + ! compute f0 1st point south + zf0 = 2. * dp_omega * SIN( dp_deg2rad * zphi0 ) + + ! f = f0 +beta* y ( y=0 at south) + tg_ff_f%d_value(:,:,1,1) = ( zf0 + zbeta * ABS( tg_gphif%d_value(:,:,1,1) - zphi0 ) & + & * dp_deg2rad * dp_rearth ) + tg_ff_t%d_value(:,:,1,1) = ( zf0 + zbeta * ABS( tg_gphit%d_value(:,:,1,1) - zphi0 ) & + & * dp_deg2rad * dp_rearth ) + + END SELECT + + END SUBROUTINE grid_hgr__fill_coriolis + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_hgr__angle(td_nam, jpi, jpj) + !!---------------------------------------------------------------------- + !> @brief This subroutine compute angles between model grid lines and the North direction + !> + !> @details + !> ** Method : + !> + !> ** Action : Compute (gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf) arrays: + !> sinus and cosinus of the angle between the north-south axe and the + !> j-direction at t, u, v and f-points + !> + !> History : + !> 7.0 ! 96-07 (O. Marti ) Original code + !> 8.0 ! 98-06 (G. Madec ) + !> 8.5 ! 98-06 (G. Madec ) Free form, F90 + opt. + !> 9.2 ! 07-04 (S. Masson) Add T, F points and bugfix in cos lateral boundary + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from geo2ocean + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMH), INTENT(IN) :: td_nam + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp) :: zlam, zphi + REAL(dp) :: zlan, zphh + REAL(dp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole + REAL(dp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole + REAL(dp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole + REAL(dp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole + REAL(dp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point + REAL(dp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point + REAL(dp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point + REAL(dp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !!---------------------------------------------------------------------- + + ! ============================= ! + ! Compute the cosinus and sinus ! + ! ============================= ! + ! (computation done on the north stereographic polar plane) + + DO jj = 2, jpj-1 +!CDIR NOVERRCHK + DO ji = 2, jpi ! vector opt. + + ! north pole direction & modulous (at t-point) + zlam = tg_glamt%d_value(ji,jj,1,1) + zphi = tg_gphit%d_value(ji,jj,1,1) + zxnpt = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + zynpt = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + znnpt = zxnpt*zxnpt + zynpt*zynpt + + ! north pole direction & modulous (at u-point) + zlam = tg_glamu%d_value(ji,jj,1,1) + zphi = tg_gphiu%d_value(ji,jj,1,1) + zxnpu = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + zynpu = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + znnpu = zxnpu*zxnpu + zynpu*zynpu + + ! north pole direction & modulous (at v-point) + zlam = tg_glamv%d_value(ji,jj,1,1) + zphi = tg_gphiv%d_value(ji,jj,1,1) + zxnpv = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + zynpv = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + znnpv = zxnpv*zxnpv + zynpv*zynpv + + ! north pole direction & modulous (at f-point) + zlam = tg_glamf%d_value(ji,jj,1,1) + zphi = tg_gphif%d_value(ji,jj,1,1) + zxnpf = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + zynpf = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) + znnpf = zxnpf*zxnpf + zynpf*zynpf + + ! j-direction: v-point segment direction (around t-point) + zlam = tg_glamv%d_value(ji,jj ,1,1) + zphi = tg_gphiv%d_value(ji,jj ,1,1) + zlan = tg_glamv%d_value(ji,jj-1,1,1) + zphh = tg_gphiv%d_value(ji,jj-1,1,1) + zxvvt = 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + zyvvt = 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt ) ) + znvvt = MAX( znvvt, dp_eps ) + + ! j-direction: f-point segment direction (around u-point) + zlam = tg_glamf%d_value(ji,jj ,1,1) + zphi = tg_gphif%d_value(ji,jj ,1,1) + zlan = tg_glamf%d_value(ji,jj-1,1,1) + zphh = tg_gphif%d_value(ji,jj-1,1,1) + zxffu = 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + zyffu = 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu ) ) + znffu = MAX( znffu, dp_eps ) + + ! i-direction: f-point segment direction (around v-point) + zlam = tg_glamf%d_value(ji ,jj,1,1) + zphi = tg_gphif%d_value(ji ,jj,1,1) + zlan = tg_glamf%d_value(ji-1,jj,1,1) + zphh = tg_gphif%d_value(ji-1,jj,1,1) + zxffv = 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + zyffv = 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv ) ) + znffv = MAX( znffv, dp_eps ) + + ! j-direction: u-point segment direction (around f-point) + zlam = tg_glamu%d_value(ji,jj+1,1,1) + zphi = tg_gphiu%d_value(ji,jj+1,1,1) + zlan = tg_glamu%d_value(ji,jj ,1,1) + zphh = tg_gphiu%d_value(ji,jj ,1,1) + zxuuf = 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + zyuuf = 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp ) & + & - 2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp ) + znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf ) ) + znuuf = MAX( znuuf, dp_eps ) + + ! cosinus and sinus using scalar and vectorial products + tg_gsint%d_value(ji,jj,1,1) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt + tg_gcost%d_value(ji,jj,1,1) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt + + tg_gsinu%d_value(ji,jj,1,1) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu + tg_gcosu%d_value(ji,jj,1,1) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu + + tg_gsinf%d_value(ji,jj,1,1) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf + tg_gcosf%d_value(ji,jj,1,1) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf + + ! (caution, rotation of 90 degres) + tg_gsinv%d_value(ji,jj,1,1) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv + tg_gcosv%d_value(ji,jj,1,1) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv + + END DO + END DO + + ! =============== ! + ! Geographic mesh ! + ! =============== ! + + DO jj = 2, jpj-1 + DO ji = 2, jpi ! vector opt. + IF( MOD( ABS( tg_glamv%d_value(ji,jj,1,1) - tg_glamv%d_value(ji,jj-1,1,1) ), 360._dp ) < 1.e-8 ) THEN + tg_gsint%d_value(ji,jj,1,1) = 0._dp + tg_gcost%d_value(ji,jj,1,1) = 1._dp + ENDIF + IF( MOD( ABS( tg_glamf%d_value(ji,jj,1,1) - tg_glamf%d_value(ji,jj-1,1,1) ), 360._dp ) < 1.e-8 ) THEN + tg_gsinu%d_value(ji,jj,1,1) = 0._dp + tg_gcosu%d_value(ji,jj,1,1) = 1._dp + ENDIF + IF( ABS( tg_gphif%d_value(ji,jj,1,1) - tg_gphif%d_value(ji-1,jj,1,1) ) < 1.e-8 ) THEN + tg_gsinv%d_value(ji,jj,1,1) = 0._dp + tg_gcosv%d_value(ji,jj,1,1) = 1._dp + ENDIF + IF( MOD( ABS( tg_glamu%d_value(ji,jj,1,1) - tg_glamu%d_value(ji,jj+1,1,1) ), 360._dp ) < 1.e-8 ) THEN + tg_gsinf%d_value(ji,jj,1,1) = 0._dp + tg_gcosf%d_value(ji,jj,1,1) = 1._dp + ENDIF + END DO + END DO + + ! =========================== ! + ! Lateral boundary conditions ! + ! =========================== ! + + ! lateral boundary cond.: T-, U-, V-, F-pts, sgn + CALL lbc_lnk( tg_gcost%d_value(:,:,1,1), 'T', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gcosu%d_value(:,:,1,1), 'U', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gcosv%d_value(:,:,1,1), 'V', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gcosf%d_value(:,:,1,1), 'F', td_nam%i_perio, -1._dp ) + + CALL lbc_lnk( tg_gsint%d_value(:,:,1,1), 'T', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gsinu%d_value(:,:,1,1), 'U', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gsinv%d_value(:,:,1,1), 'V', td_nam%i_perio, -1._dp ) + CALL lbc_lnk( tg_gsinf%d_value(:,:,1,1), 'F', td_nam%i_perio, -1._dp ) + + END SUBROUTINE grid_hgr__angle + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE grid_hgr diff --git a/V4.0/nemo_sources/tools/SIREN/src/grid_zgr.f90 b/V4.0/nemo_sources/tools/SIREN/src/grid_zgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..06b46c3cc6706f4f101589e938d8738691147a98 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/grid_zgr.f90 @@ -0,0 +1,4459 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module manage Vertical grid. +!> +!> @details +!> ** 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 +!> +!> @author +!> G, Madec +!> +!> @date December, 1995 - Original code : s vertical coordinate +!> @date July, 1997 +!> - lbc_lnk call +!> @date September, 2002 +!> - A. Bozec, G. Madec : F90: Free form and module +!> @date September, 2002 +!> - A. de Miranda : rigid-lid + islands +!> @date August, 2003 +!> - G. Madec : Free form and module +!> @date October, 2005 +!> - A. Beckmann : modifications for hybrid s-ccordinates & new stretching function +!> @date April, 2006 +!> - R. Benshila, G. Madec : add zgr_zco +!> @date June, 2008 +!> - G. Madec : insertion of domzgr_zps.h90 & conding style +!> @date July, 2009 +!> - R. Benshila : Suppression of rigid-lid option +!> @date November, 2011 +!> - G. Madec : add mbk. arrays associated to the deepest ocean level +!> @date August, 2012 +!> - J. Siddorn : added Siddorn and Furner stretching function +!> @date December, 2012 +!> - R. Bourdalle-Badie and G. Reffray : modify C1D case +!> @date November, 2014 +!> - P. Mathiot and C. Harris : add ice shelf capabilitye +!> @date November, 2015 +!> - H. Liu : Modifications for Wetting/Drying +!> @date October, 2016 +!> - J, Paul : update from trunk (revision 6961): add wetting and drying, ice sheet coupling.. +!> - J, Paul : do not use anymore special case for ORCA grid. +!> @date November, 2016 +!> - J, Paul : vertical scale factors e3. = dk[gdep] or old definition +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE grid_zgr + + USE netcdf ! nf90 library + USE kind ! F90 kind parameter + USE fct ! basic usefull function + USE global ! global parameter + USE phycst ! physical constant + USE logger ! log file manager + USE file ! file manager + USE var ! variable manager + USE dim ! dimension manager + USE dom ! domain manager + USE grid ! grid manager + USE iom ! I/O manager + USE mpp ! MPP manager + USE iom_mpp ! I/O MPP manager + USE lbc ! lateral boundary conditions + USE grid_hgr ! Horizontal mesh + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + ! type and variable + PUBLIC :: TNAMZ + + PUBLIC :: tg_gdepw_1d + PUBLIC :: tg_gdept_1d + PUBLIC :: tg_e3w_1d + PUBLIC :: tg_e3t_1d + PUBLIC :: tg_e3tp + PUBLIC :: tg_e3wp + + PUBLIC :: tg_rx1 + + PUBLIC :: tg_mbathy + PUBLIC :: tg_misfdep + + PUBLIC :: tg_gdept_0 + PUBLIC :: tg_gdepw_0 +! PUBLIC :: tg_gdep3w_0 !useless to create meshmask + PUBLIC :: tg_e3t_0 + PUBLIC :: tg_e3u_0 + PUBLIC :: tg_e3v_0 + PUBLIC :: tg_e3w_0 + PUBLIC :: tg_e3f_0 !useless to create meshmask + PUBLIC :: tg_e3uw_0 !useless to create meshmask + PUBLIC :: tg_e3vw_0 !useless to create meshmask + + PUBLIC :: tg_mbkt +! PUBLIC :: tg_mbku !useless to create meshmask +! PUBLIC :: tg_mbkv !useless to create meshmask + PUBLIC :: tg_mikt +! PUBLIC :: tg_miku !useless to create meshmask +! PUBLIC :: tg_mikv !useless to create meshmask +! PUBLIC :: tg_mikf !useless to create meshmask + + PUBLIC :: tg_hbatt ! sco + PUBLIC :: tg_hbatu ! sco + PUBLIC :: tg_hbatv ! sco + PUBLIC :: tg_hbatf ! sco + + PUBLIC :: tg_gsigt ! sco(tanh) + PUBLIC :: tg_gsigw ! sco(tanh) + PUBLIC :: tg_gsi3w ! sco(tanh) + PUBLIC :: tg_esigt ! sco(tanh) + PUBLIC :: tg_esigw ! sco(tanh) + + ! function and subroutine + PUBLIC :: grid_zgr_init + PUBLIC :: grid_zgr_nam + PUBLIC :: grid_zgr_fill + PUBLIC :: grid_zgr_clean + + PUBLIC :: grid_zgr_zps_init + PUBLIC :: grid_zgr_zps_clean + PUBLIC :: grid_zgr_sco_init + PUBLIC :: grid_zgr_sco_clean + PUBLIC :: grid_zgr_sco_stiff + + PRIVATE :: grid_zgr__z + PRIVATE :: grid_zgr__bat + PRIVATE :: grid_zgr__zco +! PRIVATE :: grid_zgr__bat_zoom + PRIVATE :: grid_zgr__bat_ctl + PRIVATE :: grid_zgr__bot_level + PRIVATE :: grid_zgr__top_level + PRIVATE :: grid_zgr__zps_fill + PRIVATE :: grid_zgr__isf_fill +! PRIVATE :: grid_zgr__isf_fill_e3x + PRIVATE :: grid_zgr__isf_fill_e3uw +! PRIVATE :: grid_zgr__isf_fill_gdep3w_0 + PRIVATE :: grid_zgr__sco_fill + PRIVATE :: grid_zgr__sco_s_sh94 + PRIVATE :: grid_zgr__sco_s_sf12 + PRIVATE :: grid_zgr__sco_s_tanh + PRIVATE :: grid_zgr__sco_fssig !: tanh stretch function + PRIVATE :: grid_zgr__sco_fssig1 !: Song and Haidvogel 1994 stretch function + PRIVATE :: grid_zgr__sco_fgamma !: Siddorn and Furner 2012 stretching function + + TYPE TNAMZ + + CHARACTER(LEN=lc) :: c_coord + INTEGER(i4) :: i_perio + + LOGICAL :: l_zco + LOGICAL :: l_zps + LOGICAL :: l_sco + LOGICAL :: l_isfcav + LOGICAL :: l_iscpl + LOGICAL :: l_wd + INTEGER(i4) :: i_nlevel + + REAL(dp) :: d_ppsur + REAL(dp) :: d_ppa0 + REAL(dp) :: d_ppa1 + REAL(dp) :: d_ppkth + REAL(dp) :: d_ppacr + REAL(dp) :: d_ppdzmin + REAL(dp) :: d_pphmax + LOGICAL :: l_dbletanh + REAL(dp) :: d_ppa2 + REAL(dp) :: d_ppkth2 + REAL(dp) :: d_ppacr2 + + REAL(dp) :: d_hmin + REAL(dp) :: d_isfhmin + + REAL(dp) :: d_e3zps_min + REAL(dp) :: d_e3zps_rat +! INTEGER(i4) :: i_msh + + LOGICAL :: l_s_sh94 + LOGICAL :: l_s_sf12 + REAL(dp) :: d_sbot_min + REAL(dp) :: d_sbot_max + ! Song and Haidvogel 1994 stretching additional parameters + REAL(dp) :: d_rmax + REAL(dp) :: d_hc + REAL(dp) :: d_theta + REAL(dp) :: d_thetb + REAL(dp) :: d_bb + ! Siddorn and Furner stretching additional parameters + LOGICAL :: l_sigcrit + REAL(dp) :: d_alpha + REAL(dp) :: d_efold + REAL(dp) :: d_zs + REAL(dp) :: d_zb_a + REAL(dp) :: d_zb_b + + INTEGER(i4) :: i_cla + + REAL(dp) :: d_wdmin1 + REAL(dp) :: d_wdmin2 + REAL(dp) :: d_wdld + +! CHARACTER(LEN=lc) :: c_cfg +! INTEGER(i4) :: i_cfg +! INTEGER(i4) :: i_bench +! LOGICAL :: l_zoom + LOGICAL :: l_c1d + LOGICAL :: l_e3_dep + +! CHARACTER(LEN=lc) :: c_cfz +! INTEGER(i4) :: i_izoom +! INTEGER(i4) :: i_jzoom +! LOGICAL :: l_zoom_s +! LOGICAL :: l_zoom_e +! LOGICAL :: l_zoom_w +! LOGICAL :: l_zoom_n + + END TYPE + + TYPE(TVAR), SAVE :: tg_gdepw_1d !zco & zps & sco + TYPE(TVAR), SAVE :: tg_gdept_1d !zco & zps & sco + TYPE(TVAR), SAVE :: tg_e3w_1d !zco & zps + TYPE(TVAR), SAVE :: tg_e3t_1d !zco & zps + TYPE(TVAR), SAVE :: tg_e3tp ! zps + TYPE(TVAR), SAVE :: tg_e3wp ! zps + + TYPE(TVAR), SAVE :: tg_rx1 ! sco + + TYPE(TVAR), SAVE :: tg_mbathy !zco & zps & sco + TYPE(TVAR), SAVE :: tg_misfdep + + TYPE(TVAR), SAVE :: tg_gdept_0 ! zps & sco + TYPE(TVAR), SAVE :: tg_gdepw_0 ! zps & sco + !TYPE(TVAR), SAVE :: tg_gdep3w_0 + TYPE(TVAR), SAVE :: tg_e3t_0 ! zps & sco + TYPE(TVAR), SAVE :: tg_e3u_0 ! zps & sco + TYPE(TVAR), SAVE :: tg_e3v_0 ! zps & sco + TYPE(TVAR), SAVE :: tg_e3w_0 ! zps & sco + TYPE(TVAR), SAVE :: tg_e3f_0 + TYPE(TVAR), SAVE :: tg_e3uw_0 + TYPE(TVAR), SAVE :: tg_e3vw_0 + + TYPE(TVAR), SAVE :: tg_mbkt !zco & zps & sco + !TYPE(TVAR), SAVE :: tg_mbku + !TYPE(TVAR), SAVE :: tg_mbkv + TYPE(TVAR), SAVE :: tg_mikt !zco & zps & sco + !TYPE(TVAR), SAVE :: tg_miku + !TYPE(TVAR), SAVE :: tg_mikv + !TYPE(TVAR), SAVE :: tg_mikf + + TYPE(TVAR), SAVE :: tg_hbatt ! sco + TYPE(TVAR), SAVE :: tg_hbatu ! sco + TYPE(TVAR), SAVE :: tg_hbatv ! sco + TYPE(TVAR), SAVE :: tg_hbatf ! sco + + TYPE(TVAR), SAVE :: tg_gsigt ! sco(tanh) + TYPE(TVAR), SAVE :: tg_gsigw ! sco(tanh) + TYPE(TVAR), SAVE :: tg_gsi3w ! sco(tanh) + TYPE(TVAR), SAVE :: tg_esigt ! sco(tanh) + TYPE(TVAR), SAVE :: tg_esigw ! sco(tanh) + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_init(jpi, jpj, jpk, ld_sco) + !------------------------------------------------------------------- + !> @brief This subroutine initialise global variable needed to compute vertical + !> mesh + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] ld_sco + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + INTEGER(i4), INTENT(IN) :: jpk + LOGICAL , INTENT(IN) :: ld_sco + + ! local variable + REAL(dp), DIMENSION(jpk) :: dl_tmp1D + REAL(dp), DIMENSION(jpi,jpj) :: dl_tmp2D + REAL(dp), DIMENSION(jpi,jpj,jpk) :: dl_tmp3D + ! loop indices + !---------------------------------------------------------------- + + ! variable 1D + dl_tmp1D(:) =dp_fill + + tg_gdepw_1d=var_init('gdepw_1d',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gdept_1d=var_init('gdept_1d',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3w_1d =var_init('e3w_1d ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3t_1d =var_init('e3t_1d ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + + !only sco + IF( ld_sco )THEN + tg_gsigt =var_init('gsigt ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gsigw =var_init('gsigw ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gsi3w =var_init('gsi3w ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_esigt =var_init('esigt ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_esigw =var_init('esigw ',dl_tmp1D(:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + ENDIF + + ! variable 2D + dl_tmp2D(:,:) =dp_fill_i2 + + tg_mbkt =var_init('mbkt ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + !tg_mbku =var_init('mbku ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + !tg_mbkv =var_init('mbkv ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + tg_mikt =var_init('mikt ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + !tg_miku =var_init('miku ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + !tg_mikv =var_init('mikv ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + !tg_mikf =var_init('mikf ',dl_tmp2D(:,:) , dd_fill=dp_fill_i2, id_type=NF90_SHORT) + + dl_tmp2D(:,:) =dp_fill_i4 + + tg_mbathy =var_init('mbathy ',dl_tmp2D(:,:) , dd_fill=dp_fill_i4, id_type=NF90_INT) + tg_misfdep =var_init('misfdep ',dl_tmp2D(:,:) , dd_fill=dp_fill_i4, id_type=NF90_INT) + + dl_tmp2D(:,:) =dp_fill + + ! only sco + IF( ld_sco )THEN + tg_hbatt =var_init('hbatt ',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_hbatu =var_init('hbatu ',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_hbatv =var_init('hbatv ',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_hbatf =var_init('hbatf ',dl_tmp2D(:,:) , dd_fill=dp_fill, id_type=NF90_DOUBLE) + ENDIF + + ! variable 3D + dl_tmp3D(:,:,:)=dp_fill + + tg_gdept_0 =var_init('gdept_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_gdepw_0 =var_init('gdepw_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + !tg_gdep3w_0=var_init('gdep3w_0',dl_tmp3D(:,:,:), dd_fill=dp_fill_sp, id_type=NF90_FLOAT) + + tg_e3t_0 =var_init('e3t_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3u_0 =var_init('e3u_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3v_0 =var_init('e3v_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3w_0 =var_init('e3w_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3f_0 =var_init('e3f_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3uw_0 =var_init('e3uw_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3vw_0 =var_init('e3vw_0 ',dl_tmp3D(:,:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + + END SUBROUTINE grid_zgr_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_clean(ld_sco) + !------------------------------------------------------------------- + !> @brief This subroutine clean hgr structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] ld_sco + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + LOGICAL , INTENT(IN) :: ld_sco + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + CALL var_clean(tg_gdepw_1d) + CALL var_clean(tg_gdept_1d) + CALL var_clean(tg_e3w_1d ) + CALL var_clean(tg_e3t_1d ) + + IF( ld_sco )THEN + CALL var_clean(tg_gsigt ) + CALL var_clean(tg_gsigw ) + CALL var_clean(tg_gsi3w ) + CALL var_clean(tg_esigt ) + CALL var_clean(tg_esigw ) + ENDIF + + CALL var_clean(tg_mbathy ) + CALL var_clean(tg_misfdep ) + + CALL var_clean(tg_mbkt ) + !CALL var_clean(tg_mbku ) + !CALL var_clean(tg_mbkv ) + CALL var_clean(tg_mikt ) + !CALL var_clean(tg_miku ) + !CALL var_clean(tg_mikv ) + !CALL var_clean(tg_mikf ) + + IF( ld_sco )THEN + CALL var_clean(tg_hbatt ) + CALL var_clean(tg_hbatu ) + CALL var_clean(tg_hbatv ) + CALL var_clean(tg_hbatf ) + ENDIF + + CALL var_clean(tg_gdept_0 ) + CALL var_clean(tg_gdepw_0 ) + !CALL var_clean(tg_gdep3w_0) + + CALL var_clean(tg_e3t_0 ) + CALL var_clean(tg_e3u_0 ) + CALL var_clean(tg_e3v_0 ) + CALL var_clean(tg_e3f_0 ) + CALL var_clean(tg_e3uw_0 ) + CALL var_clean(tg_e3vw_0 ) + + END SUBROUTINE grid_zgr_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_zgr_nam(cd_coord, id_perio, cd_namelist) & + & RESULT (tf_namz) + !------------------------------------------------------------------- + !> @brief This function initialise zgr namelist structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] cd_coord + !> @param[in] id_perio + !> @param[in] cd_namelist + !> @return hgr namelist structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_coord + INTEGER(i4) , INTENT(IN) :: id_perio + + CHARACTER(LEN=*), INTENT(IN) :: cd_namelist + + ! function + TYPE(TNAMZ) :: tf_namz + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + + LOGICAL :: ll_exist + + ! namelist + ! namzgr + LOGICAL :: ln_zco = .FALSE. + LOGICAL :: ln_zps = .FALSE. + LOGICAL :: ln_sco = .FALSE. + LOGICAL :: ln_isfcav = .FALSE. + LOGICAL :: ln_iscpl = .FALSE. + LOGICAL :: ln_wd = .FALSE. + INTEGER(i4) :: in_nlevel = 75 + + ! namdmin + REAL(dp) :: dn_hmin = NF90_FILL_DOUBLE + REAL(dp) :: dn_isfhmin = NF90_FILL_DOUBLE + + ! namzco + REAL(dp) :: dn_ppsur = -3958.951371276829 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppa0 = 103.953009600000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppa1 = 2.415951269000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppkth = 15.351013700000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppacr = 7.000000000000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppdzmin = 6. !NF90_FILL_DOUBLE + REAL(dp) :: dn_pphmax = 5750. !NF90_FILL_DOUBLE + LOGICAL :: ln_dbletanh = .TRUE. + REAL(dp) :: dn_ppa2 = 100.760928500000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppkth2 = 48.029893720000 !NF90_FILL_DOUBLE + REAL(dp) :: dn_ppacr2 = 13.000000000000 !NF90_FILL_DOUBLE + + ! namzps + REAL(dp) :: dn_e3zps_min= NF90_FILL_DOUBLE + REAL(dp) :: dn_e3zps_rat= NF90_FILL_DOUBLE +! INTEGER(i4) :: in_msh = NF90_FILL_INT + + ! namsco + LOGICAL :: ln_s_sh94 = .FALSE. + LOGICAL :: ln_s_sf12 = .FALSE. + REAL(dp) :: dn_sbot_min = NF90_FILL_DOUBLE + REAL(dp) :: dn_sbot_max = NF90_FILL_DOUBLE + REAL(dp) :: dn_rmax = NF90_FILL_DOUBLE + REAL(dp) :: dn_hc = NF90_FILL_DOUBLE + ! + REAL(dp) :: dn_theta = NF90_FILL_DOUBLE + REAL(dp) :: dn_thetb = NF90_FILL_DOUBLE + REAL(dp) :: dn_bb = NF90_FILL_DOUBLE + ! + LOGICAL :: ln_sigcrit = .FALSE. + REAL(dp) :: dn_alpha = NF90_FILL_DOUBLE + REAL(dp) :: dn_efold = NF90_FILL_DOUBLE + REAL(dp) :: dn_zs = NF90_FILL_DOUBLE + REAL(dp) :: dn_zb_a = NF90_FILL_DOUBLE + REAL(dp) :: dn_zb_b = NF90_FILL_DOUBLE + +! ! namcla +! INTEGER(i4) :: in_cla = 0 + + ! namwd + REAL(dp) :: dn_wdmin1 = NF90_FILL_DOUBLE + REAL(dp) :: dn_wdmin2 = NF90_FILL_DOUBLE + REAL(dp) :: dn_wdld = NF90_FILL_DOUBLE + + ! namgrd +! CHARACTER(LEN=lc) :: cn_cfg = '' +! INTEGER(i4) :: in_cfg = 0 +! INTEGER(i4) :: in_bench = 0 +! LOGICAL :: ln_zoom = .FALSE. + LOGICAL :: ln_c1d = .FALSE. + LOGICAL :: ln_e3_dep = .FALSE. + +! ! namzoom +! CHARACTER(LEN=lc) :: cn_cfz ='' +! INTEGER(i4) :: in_izoom = NF90_FILL_INT +! INTEGER(i4) :: in_jzoom = NF90_FILL_INT +! LOGICAL :: ln_zoom_s = .FALSE. +! LOGICAL :: ln_zoom_e = .FALSE. +! LOGICAL :: ln_zoom_w = .FALSE. +! LOGICAL :: ln_zoom_n = .FALSE. + !---------------------------------------------------------------- + NAMELIST /namzgr/ & + & ln_zco, & !< z-coordinate + & ln_zps, & !< z-coordinate with partial steps + & ln_sco, & !< s-coordinate + & ln_isfcav, & !< presence of ISF + & ln_iscpl, & !< coupling with ice sheet + & ln_wd, & !< Wetting/drying activation + & in_nlevel !< number of vertical level + + NAMELIST /namdmin/ & + & dn_hmin, & !< minimum ocean depth (>0) or minimum number of ocean levels (<0) + & dn_isfhmin !< threshold to discriminate grounded ice to floating ice + + NAMELIST /namzco/ & + & dn_ppsur, & + & dn_ppa0, & + & dn_ppa1, & + & dn_ppkth, & + & dn_ppacr, & + & dn_ppdzmin, & + & dn_pphmax, & + & ln_dbletanh, & + & dn_ppa2, & + & dn_ppkth2, & + & dn_ppacr2 + + NAMELIST /namzps/ & + & dn_e3zps_min, & + & dn_e3zps_rat!, & +! & in_msh + + NAMELIST /namsco/ & + & ln_s_sh94, & !< use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 + & ln_s_sf12, & !< use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma + & dn_sbot_min, & !< minimum depth of s-bottom surface (>0) (m) + & dn_sbot_max, & !< maximum depth of s-bottom surface (= ocean depth) (>0) (m) + & dn_hc, & !< Critical depth for transition from sigma to stretched coordinates + ! Song and Haidvogel 1994 stretching parameters + & dn_rmax, & !< maximum cut-off r-value allowed (0<dn_rmax<1) + & dn_theta, & !< surface control parameter (0<=dn_theta<=20) + & dn_thetb, & !< bottom control parameter (0<=dn_thetb<= 1) + & dn_bb, & !< stretching parameter ( dn_bb=0; top only, dn_bb =1; top and bottom) + ! Siddorn and Furner stretching parameters + & ln_sigcrit, & !< use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch + & dn_alpha, & !< control parameter ( > 1 stretch towards surface, < 1 towards seabed) + & dn_efold, & !< efold length scale for transition to stretched coord + & dn_zs, & !< depth of surface grid box + !< bottom cell depth (Zb) is a linear function of water depth Zb = H*rn_zb_a + rn_zb_b' + & dn_zb_a, & !< bathymetry scaling factor for calculating Zb + & dn_zb_b !< offset for calculating Zb + +! NAMELIST /namcla/ & +! & in_cla !< =1 cross land advection for exchanges through some straits (ORCA2) + + NAMELIST /namwd/ & !< wetting and drying + & dn_wdmin1, & !< minimum water depth on dried cells + & dn_wdmin2, & !< tolerrance of minimum water depth on dried cells + & dn_wdld !< land elevation below which wetting/drying + + NAMELIST/namgrd/ & !< orca grid namelist +! & cn_cfg, & !< name of the configuration (orca) +! & in_cfg, & !< resolution of the configuration (2,1,025..) +! & in_bench, & !< benchmark parameter (in_mshhgr = 5 ) +! & ln_zoom, & !< use zoom + & ln_c1d, & !< use configuration 1D + & ln_e3_dep !< new vertical scale factors [T, F:old definition] + +! NAMELIST /namzoom/& +! & cn_cfz, & !< name of the zoom of configuration +! & in_izoom, & !< left bottom i-indices of the zoom in data domain indices +! & in_jzoom, & !< left bottom j-indices of the zoom in data domain indices +! & ln_zoom_s, & !< South zoom type flag +! & ln_zoom_e, & !< East zoom type flag +! & ln_zoom_w, & !< West zoom type flag +! & ln_zoom_n !< North zoom type flag + !---------------------------------------------------------------- + !1-2 read namelist + INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("GRID ZGR NAM: error opening "//& + & TRIM(cd_namelist)) + ENDIF + + READ( il_fileid, NML = namzgr ) + READ( il_fileid, NML = namdmin ) + READ( il_fileid, NML = namzco ) + + IF( ln_zps ) READ( il_fileid, NML = namzps ) + IF( ln_sco ) READ( il_fileid, NML = namsco ) +! READ( il_fileid, NML = namcla ) + READ( il_fileid, NML = namwd ) + READ( il_fileid, NML = namgrd ) +! IF( ln_zoom ) READ( il_fileid, NML = namzoom ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("GRID ZGR NAM: closing "//TRIM(cd_namelist)) + ENDIF + + tf_namz%c_coord = TRIM(cd_coord) + tf_namz%i_perio = id_perio + + tf_namz%l_zco = ln_zco + tf_namz%l_zps = ln_zps + tf_namz%l_sco = ln_sco + tf_namz%l_isfcav = ln_isfcav + tf_namz%l_iscpl = ln_iscpl + tf_namz%l_wd = ln_wd + tf_namz%i_nlevel = in_nlevel + + tf_namz%d_hmin = dn_hmin + tf_namz%d_isfhmin = dn_isfhmin + + tf_namz%d_ppsur = dn_ppsur + tf_namz%d_ppa0 = dn_ppa0 + tf_namz%d_ppa1 = dn_ppa1 + tf_namz%d_ppkth = dn_ppkth + tf_namz%d_ppacr = dn_ppacr + tf_namz%d_ppdzmin = dn_ppdzmin + tf_namz%d_pphmax = dn_pphmax + + tf_namz%l_dbletanh = ln_dbletanh + tf_namz%d_ppa2 = dn_ppa2 + tf_namz%d_ppkth2 = dn_ppkth2 + tf_namz%d_ppacr2 = dn_ppacr2 + + tf_namz%d_e3zps_min= dn_e3zps_min + tf_namz%d_e3zps_rat= dn_e3zps_rat +! tf_namz%i_msh = in_msh + + tf_namz%l_s_sh94 = ln_s_sh94 + tf_namz%l_s_sf12 = ln_s_sf12 + tf_namz%d_sbot_min = dn_sbot_min + tf_namz%d_sbot_max = dn_sbot_max + tf_namz%d_rmax = dn_rmax + tf_namz%d_hc = dn_hc + ! + tf_namz%d_theta = dn_theta + tf_namz%d_thetb = dn_thetb + tf_namz%d_bb = dn_bb + ! + tf_namz%l_sigcrit = ln_sigcrit + tf_namz%d_alpha = dn_alpha + tf_namz%d_efold = dn_efold + tf_namz%d_zs = dn_zs + tf_namz%d_zb_a = dn_zb_a + tf_namz%d_zb_b = dn_zb_b + +! tf_namz%i_cla = in_cla + + tf_namz%d_wdmin1 = dn_wdmin1 + tf_namz%d_wdmin2 = dn_wdmin2 + tf_namz%d_wdld = dn_wdld + +! tf_namz%c_cfg = TRIM(cn_cfg) +! tf_namz%i_cfg = in_cfg +! tf_namz%i_bench = in_bench +! tf_namz%l_zoom = ln_zoom + tf_namz%l_c1d = ln_c1d + tf_namz%l_e3_dep = ln_e3_dep + +! tf_namz%c_cfz = cn_cfz +! tf_namz%i_izoom = in_izoom +! tf_namz%i_jzoom = in_jzoom +! tf_namz%l_zoom_s = ln_zoom_s +! tf_namz%l_zoom_e = ln_zoom_e +! tf_namz%l_zoom_w = ln_zoom_w +! tf_namz%l_zoom_n = ln_zoom_n + + ELSE + + CALL logger_fatal(" GRID ZGR NAM: can't find "//TRIM(cd_namelist)) + + ENDIF + + END FUNCTION grid_zgr_nam + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_fill(td_nam, jpi, jpj, jpk, td_bathy, td_risfdep) + !------------------------------------------------------------------- + !> @brief This subroutine fill vertical mesh + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> @date October, 2016 + !> - ice shelf cavity + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] td_bathy + !> @param[in] td_risfdep + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + TYPE(TVAR) , INTENT(INOUT) :: td_bathy + TYPE(TVAR) , INTENT(INOUT) :: td_risfdep + + ! local variable + INTEGER(i4) :: il_count + + REAL(dp) :: dl_bat + + ! loop indices + !---------------------------------------------------------------- + + CALL logger_info('GRID ZGR : vertical coordinate') + CALL logger_info('~~~~~~~') + CALL logger_info(' Namelist namzgr : set vertical coordinate') + CALL logger_info(' z-coordinate - full steps ln_zco = '//TRIM(fct_str(td_nam%l_zco))) + CALL logger_info(' z-coordinate - partial steps ln_zps = '//TRIM(fct_str(td_nam%l_zps))) + CALL logger_info(' s- or hybrid z-s-coordinate ln_sco = '//TRIM(fct_str(td_nam%l_sco))) + CALL logger_info(' ice shelf cavities ln_isfcav = '//TRIM(fct_str(td_nam%l_isfcav))) + CALL logger_info(' vertical scale factors ln_e3_dep = '//TRIM(fct_str(td_nam%l_e3_dep))) + + il_count=0 + IF( td_nam%l_zco ) il_count = il_count + 1 + IF( td_nam%l_zps ) il_count = il_count + 1 + IF( td_nam%l_sco ) il_count = il_count + 1 + IF( il_count /= 1 )THEN + CALL logger_fatal(' GRID ZGR : none or several vertical coordinate options used' ) + ENDIF + ! + il_count=0 + IF ( td_nam%l_zco .AND. td_nam%l_isfcav ) il_count = il_count + 1 + IF ( td_nam%l_sco .AND. td_nam%l_isfcav ) il_count = il_count + 1 + IF( il_count > 0 )THEN + CALL logger_fatal(' GRID ZGR : Cavity not tested/compatible with full step (zco) and sigma (ln_sco)' ) + ENDIF + + IF(.NOT. td_nam%l_e3_dep )THEN + CALL logger_info("Obsolescent definition of e3 scale factors is used") + ENDIF + ! Build the vertical coordinate system + ! ------------------------------------ + + ! Reference z-coordinate system (always called) + CALL grid_zgr__z( td_nam,jpk ) + + ! Bathymetry fields (levels and meters) + CALL grid_zgr__bat( td_nam,td_bathy,td_risfdep ) !jpi,jpj,td_bathy,td_risfdep ) + + ! 1D config.: same bathy value over the 3x3 domain + IF( td_nam%l_c1d ) CALL lbc_lnk( td_bathy%d_value(:,:,1,1),'T',td_nam%i_perio,1._dp ) + + ! z-coordinate + IF( td_nam%l_zco ) CALL grid_zgr__zco(jpk) + + ! Partial step z-coordinate + IF( td_nam%l_zps ) CALL grid_zgr__zps_fill( td_nam,jpi,jpj,jpk,td_bathy,td_risfdep ) + + ! s-coordinate or hybrid z-s coordinate + IF( td_nam%l_sco ) CALL grid_zgr__sco_fill( td_nam,jpi,jpj,jpk,td_bathy ) + + ! final adjustment of mbathy & check + ! ---------------------------------- + +! ! correct mbathy in case of zoom subdomain +! IF( td_nam%l_zoom ) CALL grid_zgr__bat_zoom( td_nam,jpi,jpj ) + + ! check bathymetry (mbathy) and suppress isolated ocean points + IF( .NOT. td_nam%l_c1d ) CALL grid_zgr__bat_ctl( td_nam,jpi,jpj,jpk ) + + ! deepest ocean level for t-, u- and v-points + CALL grid_zgr__bot_level( ) !td_nam,jpi,jpj ) + + ! shallowest ocean level for T-, U-, V- points + CALL grid_zgr__top_level( ) !td_nam,jpi,jpj ) + + ! 1D config.: same mbathy value over the 3x3 domain + IF( td_nam%l_c1d ) THEN + dl_bat = tg_mbathy%d_value(2,2,1,1) + tg_mbathy%d_value(:,:,1,1) = dl_bat + END IF + + CALL logger_info(' MIN val mbathy '//TRIM(fct_str(MINVAL( tg_mbathy%d_value(:,:,1,1) )))//& + & ' MAX '//TRIM(fct_str(MAXVAL( tg_mbathy%d_value(:,:,1,1) ))) ) + CALL logger_info(' MIN val depth t '//TRIM(fct_str(MINVAL( tg_gdept_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MINVAL( tg_gdepw_0%d_value(:,:,:,1) )))//& + !& ' 3w '//TRIM(fct_str(MINVAL( tg_gdep3w_0%d_value(:,:,:,1) )))//& + & ' t '//TRIM(fct_str(MINVAL( tg_e3t_0%d_value(:,:,:,1) )))//& + & ' f '//TRIM(fct_str(MINVAL( tg_e3f_0%d_value(:,:,:,1) )))//& + & ' u '//TRIM(fct_str(MINVAL( tg_e3u_0%d_value(:,:,:,1) )))//& + & ' v '//TRIM(fct_str(MINVAL( tg_e3v_0%d_value(:,:,:,1) )))//& + & ' uw '//TRIM(fct_str(MINVAL( tg_e3uw_0%d_value(:,:,:,1) )))//& + & ' vw '//TRIM(fct_str(MINVAL( tg_e3vw_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MINVAL( tg_e3w_0%d_value(:,:,:,1) ))) ) + CALL logger_info(' MAX val depth t '//TRIM(fct_str(MAXVAL( tg_gdept_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MAXVAL( tg_gdepw_0%d_value(:,:,:,1) ))) )!//& + !& ' 3w '//TRIM(fct_str(MAXVAL( tg_gdep3w_0%d_value(:,:,:,1) ))) ) + CALL logger_info(' MAX val e3 t '//TRIM(fct_str(MAXVAL( tg_e3t_0%d_value(:,:,:,1) )))//& + & ' f '//TRIM(fct_str(MAXVAL( tg_e3f_0%d_value(:,:,:,1) )))//& + & ' u '//TRIM(fct_str(MAXVAL( tg_e3u_0%d_value(:,:,:,1) )))//& + & ' v '//TRIM(fct_str(MAXVAL( tg_e3v_0%d_value(:,:,:,1) )))//& + & ' uw '//TRIM(fct_str(MAXVAL( tg_e3uw_0%d_value(:,:,:,1) )))//& + & ' vw '//TRIM(fct_str(MAXVAL( tg_e3vw_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MAXVAL( tg_e3w_0%d_value(:,:,:,1) ))) ) + + END SUBROUTINE grid_zgr_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__z(td_nam, jpk) + !------------------------------------------------------------------- + !> @brief This subroutine set the depth of model levels and the resulting + !> vertical scale factors. + !> + !> @details + !> + !> ** Method : z-coordinate system (use in all type of coordinate) + !> The depth of model levels is defined from an analytical + !> function the derivative of which gives the scale factors. + !> both depth and scale factors only depend on k (1d arrays).<br/> + !> w-level: + !> - gdepw_1d = gdep(k)<br/> + !> - e3w_1d(k) = dk(gdep)(k) = e3(k)<br/> + !> t-level: + !> - gdept_1d = gdep(k+0.5)<br/> + !> - e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5)<br/> + !> + !> + !> ** Action : - gdept_1d, gdepw_1d : depth of T- and W-point (m) + !> - e3t_1d , e3w_1d : scale factors at T- and W-levels (m) + !> + !> !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_z + !> + !> @param[in] td_nam + !> @param[in] jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpk + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + + REAL(dp) :: zsur, za0, za1, zkth ! Values set from parameters in + REAL(dp) :: zacr, zdzmin, zhmax ! par_CONFIG_Rxx.h90 +! REAL(dp) :: zrefdep ! depth of the reference level (~10m) + REAL(dp) :: za2, zkth2, zacr2 ! Values for optional double tanh function set from parameters + REAL(dp) :: zt, zw ! temporary scalars + REAL(dp), PARAMETER :: dp_pp_to_be_computed = NF90_FILL_DOUBLE + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! Set variables from parameters + ! ------------------------------ + zkth = td_nam%d_ppkth + zacr = td_nam%d_ppacr + zdzmin = td_nam%d_ppdzmin + zhmax = td_nam%d_pphmax + zkth2 = td_nam%d_ppkth2 + zacr2 = td_nam%d_ppacr2 + + ! If ppa1 and ppa0 and ppsur are set to pp_to_be_computed + ! za0, za1, zsur are computed from ppdzmin , pphmax, ppkth, ppacr + IF( td_nam%d_ppa1 == dp_pp_to_be_computed .AND. & + & td_nam%d_ppa0 == dp_pp_to_be_computed .AND. & + & td_nam%d_ppsur == dp_pp_to_be_computed ) THEN + ! + za1 = ( zdzmin - zhmax / REAL(jpk-1,dp) ) & + & / ( TANH((1-zkth)/zacr) - zacr/REAL(jpk-1,dp) * ( LOG( COSH( (jpk - zkth) / zacr) ) & + & - LOG( COSH( ( 1 - zkth) / zacr) ) ) ) + za0 = zdzmin - za1 * TANH( (1-zkth) / zacr ) + zsur = - za0 - za1 * zacr * LOG( COSH( (1-zkth) / zacr ) ) + ! za2 ??? + ELSE + za1 = td_nam%d_ppa1 + za0 = td_nam%d_ppa0 + zsur = td_nam%d_ppsur + za2 = td_nam%d_ppa2 ! optional (ldbletanh=T) double tanh parameter + ENDIF + + CALL logger_info(' GRID ZGR Z : Reference vertical z-coordinates') + CALL logger_info('~~~~~~~~~~~') + IF( zkth == 0._dp ) THEN + CALL logger_info('Uniform grid with '//TRIM(fct_str(jpk-1))//' layers') + CALL logger_info('Total depth :'//TRIM(fct_str(zhmax))) + CALL logger_info('Layer thickness:'//TRIM(fct_str(zhmax/(jpk-1)))) + ELSE + IF( za1 == 0._dp .AND. za0 == 0._dp .AND. zsur == 0._dp ) THEN + CALL logger_info('zsur, za0, za1 computed from ') + CALL logger_info(' zdzmin = '//TRIM(fct_str(zdzmin))) + CALL logger_info(' zhmax = '//TRIM(fct_str(zhmax))) + ENDIF + CALL logger_info('Value of coefficients for vertical mesh:') + CALL logger_info(' zsur = '//TRIM(fct_str(zsur))) + CALL logger_info(' za0 = '//TRIM(fct_str(za0))) + CALL logger_info(' za1 = '//TRIM(fct_str(za1))) + CALL logger_info(' zkth = '//TRIM(fct_str(zkth))) + CALL logger_info(' zacr = '//TRIM(fct_str(zacr))) + IF( td_nam%l_dbletanh ) THEN + CALL logger_info(' (Double tanh za2 = '//TRIM(fct_str(za2))) + CALL logger_info(' parameters) zkth2= '//TRIM(fct_str(zkth2))) + CALL logger_info(' zacr2= '//TRIM(fct_str(zacr2))) + ENDIF + ENDIF + + ! Reference z-coordinate (depth - scale factor at T- and W-points) + ! ====================== + ! init + IF( zkth == 0._dp ) THEN ! uniform vertical grid + za1 = zhmax / REAL(jpk-1,dp) + DO jk = 1, jpk + zw = REAL( jk, dp ) + zt = REAL( jk, dp ) + 0.5_dp + tg_gdepw_1d%d_value(1,1,jk,1) = ( zw - 1 ) * za1 + tg_gdept_1d%d_value(1,1,jk,1) = ( zt - 1 ) * za1 + tg_e3w_1d%d_value (1,1,jk,1) = za1 + tg_e3t_1d%d_value (1,1,jk,1) = za1 + END DO + ELSE ! Madec & Imbard 1996 function + IF( .NOT. td_nam%l_dbletanh ) THEN + DO jk = 1, jpk + zw = REAL( jk , dp ) + zt = REAL( jk , dp ) + 0.5_dp + tg_gdepw_1d%d_value(1,1,jk,1) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) ) + tg_gdept_1d%d_value(1,1,jk,1) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) ) + tg_e3w_1d%d_value (1,1,jk,1) = za0 + za1 * TANH( (zw-zkth) / zacr ) + tg_e3t_1d%d_value (1,1,jk,1) = za0 + za1 * TANH( (zt-zkth) / zacr ) + END DO + ELSE + DO jk = 1, jpk + zw = REAL( jk, dp ) + zt = REAL( jk, dp ) + 0.5_dp + ! Double tanh function + tg_gdepw_1d%d_value(1,1,jk,1) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) ) + tg_gdept_1d%d_value(1,1,jk,1) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) & + & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) ) + tg_e3w_1d %d_value(1,1,jk,1) = za0 + za1 * TANH( (zw-zkth ) / zacr ) & + & + za2 * TANH( (zw-zkth2) / zacr2 ) + tg_e3t_1d %d_value(1,1,jk,1) = za0 + za1 * TANH( (zt-zkth ) / zacr ) & + & + za2 * TANH( (zt-zkth2) / zacr2 ) + END DO + ENDIF + tg_gdepw_1d%d_value(1,1,1,1) = 0._dp ! force first w-level to be exactly at zero + ENDIF + + IF ( td_nam%l_isfcav .OR. td_nam%l_e3_dep ) THEN + ! need to be like this to compute the pressure gradient with ISF. + ! If not, level beneath the ISF are not aligned (sum(e3t) /= depth) + ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively + DO jk = 1, jpk-1 + tg_e3t_1d%d_value(1,1,jk,1) = tg_gdepw_1d%d_value(1,1,jk+1,1)-tg_gdepw_1d%d_value(1,1,jk,1) + END DO + ! we don't care because this level is masked in NEMO + tg_e3t_1d%d_value(1,1,jpk,1) = tg_e3t_1d%d_value(1,1,jpk-1,1) + + DO jk = 2, jpk + tg_e3w_1d%d_value(1,1,jk,1) = tg_gdept_1d%d_value(1,1,jk,1) - tg_gdept_1d%d_value(1,1,jk-1,1) + END DO + tg_e3w_1d%d_value(1,1,1,1) = 2._dp * (tg_gdept_1d%d_value(1,1,1,1) - tg_gdepw_1d%d_value(1,1,1,1)) + END IF + +! unused ? +!!!!gm BUG in s-coordinate this does not work! +! ! deepest/shallowest W level Above/Below ~10m +! +! ! ref. depth with tolerance (10% of minimum layer thickness) +! zrefdep = 10._dp - 0.1_dp * MINVAL( tg_e3w_1d%d_value(1,1,:,1) ) +! +! ! shallowest W level Below ~10m +! nlb10 = MINLOC( tg_gdepw_1d%d_value(1,1,:,1), mask = tg_gdepw_1d%d_value(1,1,:,1) > zrefdep, dim = 1 ) +! +! ! deepest W level Above ~10m +! nla10 = nlb10 - 1 +!!!!gm end bug + + ! control print + CALL logger_info(' GRID ZGR Z : Reference z-coordinate depth and scale factors:') + CALL logger_info('~~~~~~~~~~~') + WRITE(cl_tmp, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) + CALL logger_info(cl_tmp) + DO jk=1,jpk + WRITE(cl_tmp, "(10x, i4, 4f9.2)" ) jk, tg_gdept_1d%d_value(1,1,jk,1), tg_gdepw_1d%d_value(1,1,jk,1), & + & tg_e3t_1d%d_value (1,1,jk,1), tg_e3w_1d%d_value (1,1,jk,1) + CALL logger_info(cl_tmp) + ENDDO + + ! control positivity + DO jk = 1, jpk + IF( tg_e3w_1d%d_value (1,1,jk,1) <= 0._dp .OR. tg_e3t_1d%d_value (1,1,jk,1) <= 0._dp )THEN + CALL logger_fatal( 'GRID ZGR Z: e3w_1d or e3t_1d =< 0 ' ) + ENDIF + IF( tg_gdepw_1d%d_value(1,1,jk,1) < 0._dp .OR. tg_gdept_1d%d_value(1,1,jk,1) < 0._dp )THEN + CALL logger_fatal( 'GRID ZGR Z: gdepw_1d or gdept_1d < 0 ' ) + ENDIF + END DO + + END SUBROUTINE grid_zgr__z + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__bat(td_nam, td_bathy, td_risfdep) !jpi,jpj,td_bathy,td_risfdep ) + !------------------------------------------------------------------- + !> @brief This subroutine set bathymetry both in levels and meters + !> + !> @details + !> + !> ** Method : read or define mbathy and bathy arrays + !> * level bathymetry: + !> The ocean basin geometry is given by a two-dimensional array, + !> mbathy, which is defined as follow : + !> mbathy(ji,jj) = 1, ..., jpk-1, the number of ocean level + !> at t-point (ji,jj). + !> = 0 over the continental t-point. + !> The array mbathy is checked to verified its consistency with + !> model option. in particular: + !> mbathy must have at least 1 land grid-points (mbathy<=0) + !> along closed boundary. + !> mbathy must be cyclic IF jperio=1. + !> mbathy must be lower or equal to jpk-1. + !> isolated ocean grid points are suppressed from mbathy + !> since they are only connected to remaining + !> ocean through vertical diffusion. + !> ntopo=-1 : rectangular channel or bassin with a bump + !> ntopo= 0 : flat rectangular channel or basin + !> ntopo= 1 : mbathy is read in 'bathy_level.nc' NetCDF file + !> bathy is read in 'bathy_meter.nc' NetCDF file + !> + !> ** Action : - mbathy: level bathymetry (in level index) + !> - bathy : meter bathymetry (in meters) + !> + !> @warning do not manage case ntopo=-1 or 0 + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_bat + !> @date October, 2016 + !> - do not use anymore special case for ORCA grid. + !> + !> @param[in] td_nam + ! @param[in] jpi + ! @param[in] jpj + !> @param[in] td_bathy + !> @param[in] td_risfdep + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj + TYPE(TVAR) , INTENT(INOUT) :: td_bathy + TYPE(TVAR) , INTENT(INOUT) :: td_risfdep + + ! local variable +! INTEGER(i4) :: ii0, ii1 +! INTEGER(i4) :: ij0, ij1 + + REAL(dp) :: zhmin + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + CALL logger_info(' GRID ZGR BAT : defines level and meter bathymetry') + CALL logger_info(' ~~~~~~~~~~~~~') + CALL logger_info(' GRID ZGR BAT : bathymetry read in file') + + IF( td_nam%l_zco )THEN + ! zco : read level bathymetry + + ! read variable in bathymetry file + tg_mbathy%d_value(:,:,1,1) = INT(td_bathy%d_value(:,:,1,1),i4) + tg_misfdep%d_value(:,:,1,1)=1 + ! ! ===================== +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 2 ) THEN ! ORCA R2 configuration +! ! ! ===================== +! IF( td_nam%i_cla == 0 ) THEN +! ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open +! ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) +! tg_mbathy%d_value(ii0:ii1,ij0:ij1,1,1) = 15 +! CALL logger_info('orca_r2: Gibraltar strait open at i='//& +! & TRIM(fct_str(ii0))//' j='//TRIM(fct_str(ij0)) ) +! ! +! ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open +! ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) +! tg_mbathy%d_value(ii0:ii1,ij0:ij1,1,1) = 12 +! CALL logger_info('orca_r2: Bab el Mandeb strait open at i='//& +! & TRIM(fct_str(ii0))//' j='//TRIM(fct_str(ij0)) ) +! ENDIF +! ! +! ENDIF + + ENDIF + + IF( td_nam%l_zps .OR. td_nam%l_sco )THEN + ! zps or sco : read meter bathymetry + + tg_misfdep%d_value(:,:,:,:)=1 + + IF ( td_nam%l_isfcav ) THEN + WHERE( td_bathy%d_value(:,:,1,1) <= 0._dp ) + td_risfdep%d_value(:,:,1,1) = 0._dp + END WHERE + + ! set grounded point to 0 + ! (a treshold could be set here if needed, or set it offline based on the grounded fraction) + WHERE ( td_bathy%d_value(:,:,1,1) <= td_risfdep%d_value(:,:,1,1) + td_nam%d_isfhmin ) + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0._dp + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0._dp + END WHERE + END IF + ! +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 2 ) THEN ! ORCA R2 configuration +! ! +! IF( td_nam%i_cla == 0 ) THEN +! ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open +! ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) +! td_bathy%d_value(ii0:ii1,ij0:ij1,1,1) = 284._dp +! CALL logger_info('orca_r2: Gibraltar strait open at i='//& +! & TRIM(fct_str(ii0))//' j='//TRIM(fct_str(ij0)) ) +! ! +! ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open +! ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) +! td_bathy%d_value(ii0:ii1,ij0:ij1,1,1) = 137._dp +! CALL logger_info('orca_r2: Bab el Mandeb strait open at i='//& +! & TRIM(fct_str(ii0))//' j='//TRIM(fct_str(ij0)) ) +! ENDIF +! ! +! ENDIF + ! + ENDIF + + !== NO closed seas or lakes ==! + ! already done + + IF ( .NOT. td_nam%l_sco ) THEN + !== set a minimum depth ==! + + IF( td_nam%d_hmin < 0._dp ) THEN + ! from a nb of level + jk = - INT(td_nam%d_hmin, i4) + ELSE + ! from a depth + jk = MINLOC( tg_gdepw_1d%d_value(1,1,:,1), & + & MASK = tg_gdepw_1d%d_value(1,1,:,1) > td_nam%d_hmin, & + & DIM = 1) + ENDIF + + ! minimum depth = ik+1 w-levels + zhmin = tg_gdepw_1d%d_value(1,1,jk+1,1) + WHERE( td_bathy%d_value(:,:,1,1) <= 0._dp ) + ! min=0 over the lands + td_bathy%d_value(:,:,1,1) = 0._dp + ELSE WHERE + ! min=zhmin over the oceans + td_bathy%d_value(:,:,1,1) = MAX(zhmin, td_bathy%d_value(:,:,1,1)) + END WHERE + CALL logger_info('GRID ZGR BAT: Minimum ocean depth: '//& + & TRIM(fct_str(zhmin))//' minimum number of ocean'//& + & ' levels : '//TRIM(fct_str(jk))) + ENDIF + + END SUBROUTINE grid_zgr__bat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__zco(jpk) + !------------------------------------------------------------------- + !> @brief This subroutine define the z-coordinate system + !> + !> @details + !> set 3D coord. arrays to reference 1D array + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_zco + !> + !> @param[in] jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN ) :: jpk + + ! local variable + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + DO jk = 1, jpk + tg_gdept_0%d_value (:,:,jk,1) = tg_gdept_1d%d_value(1,1,jk,1) + tg_gdepw_0%d_value (:,:,jk,1) = tg_gdepw_1d%d_value(1,1,jk,1) + !tg_gdep3w_0%d_value(:,:,jk,1) = tg_gdepw_1d%d_value(1,1,jk,1) + tg_e3t_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value (1,1,jk,1) + tg_e3u_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value (1,1,jk,1) + tg_e3v_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value (1,1,jk,1) + tg_e3f_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value (1,1,jk,1) + tg_e3w_0%d_value (:,:,jk,1) = tg_e3w_1d%d_value (1,1,jk,1) + tg_e3uw_0%d_value (:,:,jk,1) = tg_e3w_1d%d_value (1,1,jk,1) + tg_e3vw_0%d_value (:,:,jk,1) = tg_e3w_1d%d_value (1,1,jk,1) + END DO + + END SUBROUTINE grid_zgr__zco + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE grid_zgr__bat_zoom(td_nam,jpi,jpj) +! !------------------------------------------------------------------- +! !> @brief This subroutine : +! !> - close zoom domain boundary if necessary +! !> - suppress Med Sea from ORCA R2 and R05 arctic zoom +! !> +! !> @author J.Paul +! !> @date September, 2015 - Initial version +! !> +! !> @param[in] td_nam +! !> @param[in] jpi +! !> @param[in] jpj +! !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! TYPE(TNAMZ), INTENT(IN ) :: td_nam +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj +! +! ! local variable +! INTEGER(i4) :: jpizoom +! INTEGER(i4) :: jpjzoom +! +! INTEGER(i4) :: ii0, ii1 +! INTEGER(i4) :: ij0, ij1 +! ! loop indices +! !---------------------------------------------------------------- +! +! CALL logger_info('GRID ZGR BAT ZOOM : modify the level bathymetry for zoom domain') +! CALL logger_info('~~~~~~~~~~~~') +! +! jpizoom=td_nam%i_izoom +! jpjzoom=td_nam%i_jzoom +! +! ! Forced closed boundary if required +! IF( td_nam%l_zoom_s ) tg_mbathy%d_value( : , jpjzoom ,1,1) = 0 +! IF( td_nam%l_zoom_w ) tg_mbathy%d_value( jpizoom , : ,1,1) = 0 +! IF( td_nam%l_zoom_e ) tg_mbathy%d_value( jpi+jpizoom-1, : ,1,1) = 0 +! IF( td_nam%l_zoom_n ) tg_mbathy%d_value( : ,jpj+jpjzoom-1,1,1) = 0 +! +! ! Configuration specific domain modifications +! ! (here, ORCA arctic configuration: suppress Med Sea) +! IF( TRIM(td_nam%c_cfg) == "orca" .AND. & +! & TRIM(td_nam%c_cfz) == "arctic" ) THEN +! SELECT CASE ( td_nam%i_cfg ) +! ! ! ======================= +! CASE ( 2 ) ! ORCA_R2 configuration +! ! ! ======================= +! CALL logger_info('ORCA R2 arctic zoom: suppress the Med Sea') +! ii0 = 141 ; ii1 = 162 ! Sea box i,j indices +! ij0 = 98 ; ij1 = 110 +! ! ! ======================= +! CASE ( 05 ) ! ORCA_R05 configuration +! ! ! ======================= +! CALL logger_info('ORCA R05 arctic zoom: suppress the Med Sea') +! ii0 = 563 ; ii1 = 642 ! zero over the Med Sea boxe +! ij0 = 314 ; ij1 = 370 +! END SELECT +! ! +! tg_mbathy%d_value( ii0:ii1, ij0:ij1, 1, 1) = 0 ! zero over the Med Sea boxe +! ! +! ENDIF +! +! END SUBROUTINE grid_zgr__bat_zoom + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__bat_ctl(td_nam, jpi, jpj, jpk) + !------------------------------------------------------------------- + !> @brief This subroutine check the bathymetry in levels + !> + !> @details + !> + !> + !> ** Method : The array mbathy is checked to verified its consistency + !> with the model options. in particular: + !> mbathy must have at least 1 land grid-points (mbathy<=0) + !> along closed boundary. + !> mbathy must be cyclic IF jperio=1. + !> mbathy must be lower or equal to jpk-1. + !> isolated ocean grid points are suppressed from mbathy + !> since they are only connected to remaining + !> ocean through vertical diffusion. + !> C A U T I O N : mbathy will be modified during the initializa- + !> tion phase to become the number of non-zero w-levels of a water + !> column, with a minimum value of 1. + !> + !> ** Action : - update mbathy: level bathymetry (in level index) + !> - update bathy : meter bathymetry (in meters) + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + + ! local variable + INTEGER(i4) :: icompt, ibtest, ikmax ! temporary integers + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + CALL logger_info('GRID ZGR BAT CTL: check the bathymetry') + CALL logger_info('~~~~~~~~~~~~~~~') + CALL logger_info(' suppress isolated ocean grid points') + CALL logger_info(' -----------------------------------') + + icompt = 0 + DO jl = 1, 2 + IF( td_nam%i_perio == 1 .OR. & + & td_nam%i_perio == 4 .OR. & + & td_nam%i_perio == 6 ) THEN + tg_mbathy%d_value( 1 ,:,1,1) = tg_mbathy%d_value(jpi-1,:,1,1) ! local domain is cyclic east-west + tg_mbathy%d_value(jpi,:,1,1) = tg_mbathy%d_value( 2 ,:,1,1) + ENDIF + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + ibtest = MAX( tg_mbathy%d_value(ji-1,jj ,1,1), & + & tg_mbathy%d_value(ji+1,jj ,1,1), & + & tg_mbathy%d_value(ji ,jj-1,1,1), & + & tg_mbathy%d_value(ji ,jj+1,1,1) ) + IF( ibtest < tg_mbathy%d_value(ji,jj,1,1) ) THEN + CALL logger_info(' the number of ocean level at '//& + & 'grid-point (i,j) = ('//TRIM(fct_str(ji))//& + & ','//TRIM(fct_str(jj))//') is changed from '//& + & TRIM(fct_str(tg_mbathy%d_value(ji,jj,1,1)))//' to '//& + & TRIM(fct_str(ibtest)) ) + tg_mbathy%d_value(ji,jj,1,1) = ibtest + icompt = icompt + 1 + ENDIF + END DO + END DO + END DO + + !! lk_mpp not used + + IF( icompt == 0 ) THEN + CALL logger_info(' no isolated ocean grid points') + ELSE + CALL logger_info(TRIM(fct_str(icompt))//' ocean grid points suppressed') + ENDIF + + !! lk_mpp not used + + ! ! East-west cyclic boundary conditions + IF( td_nam%i_perio == 0 ) THEN + CALL logger_info(' mbathy set to 0 along east and west boundary:'//& + & ' nperio = '//TRIM(fct_str(td_nam%i_perio)) ) + !! lk_mpp not used + IF( td_nam%l_zco .OR. td_nam%l_zps ) THEN + tg_mbathy%d_value( 1 ,:,1,1) = 0 + tg_mbathy%d_value(jpi,:,1,1) = 0 + ELSE + tg_mbathy%d_value( 1 ,:,1,1) = jpk-1 + tg_mbathy%d_value(jpi,:,1,1) = jpk-1 + ENDIF + ELSEIF( td_nam%i_perio == 1 .OR. & + & td_nam%i_perio == 4 .OR. & + & td_nam%i_perio == 6 ) THEN + CALL logger_info(' east-west cyclic boundary conditions on mbathy:'//& + & ' nperio = '//TRIM(fct_str(td_nam%i_perio)) ) + tg_mbathy%d_value( 1 ,:,1,1) = tg_mbathy%d_value(jpi-1,:,1,1) + tg_mbathy%d_value(jpi,:,1,1) = tg_mbathy%d_value( 2 ,:,1,1) + ELSEIF( td_nam%i_perio == 2 ) THEN + CALL logger_info(' equatorial boundary conditions on mbathy:'//& + ' nperio = '//TRIM(fct_str(td_nam%i_perio)) ) + ELSE + CALL logger_info(' e r r o r') + CALL logger_info(' parameter , nperio = '//TRIM(fct_str(td_nam%i_perio)) ) + ! STOP 'dom_mba' + ENDIF + + ! Boundary condition on mbathy +!!gm !!bug ??? think about it ! + ! ... mono- or macro-tasking: T-point, >0, 2D array, no slab + CALL lbc_lnk( tg_mbathy%d_value(:,:,1,1), 'T', td_nam%i_perio, 1._dp ) + + + ! Number of ocean level inferior or equal to jpkm1 + ikmax = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ikmax = MAX( ikmax, INT(tg_mbathy%d_value(ji,jj,1,1),i4) ) + END DO + END DO +!!gm !!! test to do: ikmax = MAX( mbathy(:,:) ) ??? + IF( ikmax > jpk-1 ) THEN + CALL logger_info(' maximum number of ocean level = '//TRIM(fct_str(ikmax))//' > jpk-1') + CALL logger_info(' change jpk to '//TRIM(fct_str(ikmax+1))//' to use the exact ead bathymetry') + ELSE IF( ikmax < jpk-1 ) THEN + CALL logger_info(' maximum number of ocean level = '//TRIM(fct_str(ikmax))//' < jpk-1') + CALL logger_info(' you can decrease jpk to '//TRIM(fct_str(ikmax+1))) + ENDIF + + END SUBROUTINE grid_zgr__bat_ctl + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__bot_level()!td_nam,jpi,jpj) + !------------------------------------------------------------------- + !> @brief This subroutine defines the vertical index of ocean bottom (mbk. arrays) + !> + !> @details + !> + !> ** Method : computes from mbathy with a minimum value of 1 over land + !> + !> ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest + !> ocean level at t-, u- & v-points + !> (min value = 1 over land) + !> + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_bot_level + !> + ! @param[in] td_nam + ! @param[in] jpi + ! @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument +! TYPE(TNAMZ), INTENT(IN ) :: td_nam +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj + + ! local variable + + ! loop indices +! INTEGER(i4) :: ji +! INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info('GRID ZGR BOT LEVEL: ocean bottom k-index of T-, U-, V- and W-levels ') + CALL logger_info(' ~~~~~~~~~~~~~') + + ! bottom k-index of T-level (=1 over land) + tg_mbkt%d_value(:,:,1,1) = MAX( tg_mbathy%d_value(:,:,1,1) , 1._dp ) + +! ! bottom k-index of W-level = mbkt+1 +! ! bottom k-index of u- (v-) level +! DO jj = 1, jpj-1 ! bottom k-index of u- (v-) level +! DO ji = 1, jpi-1 +! tg_mbku%d_value(ji,jj,1,1) = MIN( tg_mbkt%d_value(ji+1,jj ,1,1) , & +! & tg_mbkt%d_value(ji ,jj ,1,1) ) +! +! tg_mbkv%d_value(ji,jj,1,1) = MIN( tg_mbkt%d_value(ji ,jj+1,1,1) , & +! & tg_mbkt%d_value(ji ,jj ,1,1) ) +! END DO +! END DO +! +! CALL lbc_lnk(tg_mbku%d_value(:,:,1,1),'U', td_nam%i_perio, 1._dp) +! CALL lbc_lnk(tg_mbkv%d_value(:,:,1,1),'U', td_nam%i_perio, 1._dp) + + END SUBROUTINE grid_zgr__bot_level + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__top_level()!td_nam,jpi,jpj) + !------------------------------------------------------------------- + !> @brief This subroutine defines the vertical index of ocean top (mik. arrays) + !> + !> @details + !> + !> ** Method : computes from misfdep with a minimum value of 1 + !> + !> ** Action : mikt, miku, mikv : vertical indices of the shallowest + !> ocean level at t-, u- & v-points + !> (min value = 1) + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_top_level + !> + ! @param[in] td_nam + ! @param[in] jpi + ! @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument +! TYPE(TNAMZ), INTENT(IN ) :: td_nam +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj + ! local variable + + ! loop indices +! INTEGER(i4) :: ji +! INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_info(' GRID ZGR TOP LEVEL : ocean top k-index of T-, U-, V- and W-levels ') + CALL logger_info(' ~~~~~~~~~~~~~') + + ! top k-index of T-level (=1) + tg_mikt%d_value(:,:,1,1) = MAX( tg_misfdep%d_value(:,:,1,1) , 1._dp ) + +! ! top k-index of W-level (=mikt) +! ! top k-index of U- (U-) level +! DO jj = 1, jpj-1 ! top k-index of U- (U-) level +! DO ji = 1, jpi-1 +! tg_miku%d_value(ji,jj,1,1) = MAX( tg_mikt%d_value(ji+1,jj ,1,1), & +! & tg_mikt%d_value(ji ,jj ,1,1) ) +! +! tg_mikv%d_value(ji,jj,1,1) = MAX( tg_mikt%d_value(ji ,jj+1,1,1), & +! & tg_mikt%d_value(ji ,jj ,1,1) ) +! +! tg_mikf%d_value(ji,jj,1,1) = MAX( tg_mikt%d_value(ji ,jj+1,1,1), & +! & tg_mikt%d_value(ji ,jj ,1,1), & +! & tg_mikt%d_value(ji+1,jj ,1,1), & +! & tg_mikt%d_value(ji+1,jj+1,1,1) ) +! END DO +! END DO +! +! CALL lbc_lnk(tg_miku%d_value(:,:,1,1),'U',td_nam%i_perio,1._dp) +! CALL lbc_lnk(tg_mikv%d_value(:,:,1,1),'V',td_nam%i_perio,1._dp) +! CALL lbc_lnk(tg_mikf%d_value(:,:,1,1),'F',td_nam%i_perio,1._dp) + + END SUBROUTINE grid_zgr__top_level + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_zps_init(jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine initialise global variable needed to compute vertical + !> mesh + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp), DIMENSION(jpi,jpj) :: dl_tmp + + ! loop indices + !---------------------------------------------------------------- + + dl_tmp(:,:)=dp_fill + + tg_e3tp =var_init('e3t_ps ',dl_tmp(:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + tg_e3wp =var_init('e3w_ps ',dl_tmp(:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + + END SUBROUTINE grid_zgr_zps_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_zps_clean() + !------------------------------------------------------------------- + !> @brief This subroutine clean hgr structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + ! local variable + ! loop indices + !---------------------------------------------------------------- + + CALL var_clean(tg_e3tp ) + CALL var_clean(tg_e3wp ) + + END SUBROUTINE grid_zgr_zps_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__zps_fill(td_nam, jpi, jpj, jpk, td_bathy, td_risfdep) + !------------------------------------------------------------------- + !> @brief This subroutine define the depth and vertical scale factor in partial step + !> z-coordinate case + !> + !> @details + !> ** Method : Partial steps : computes the 3D vertical scale factors + !> of T-, U-, V-, W-, UW-, VW and F-points that are associated with + !> a partial step representation of bottom topography. + !> + !> The reference depth of model levels is defined from an analytical + !> function the derivative of which gives the reference vertical + !> scale factors. + !> From depth and scale factors reference, we compute there new value + !> with partial steps on 3d arrays ( i, j, k ). + !> + !> w-level: gdepw_0(i,j,k) = gdep(k) + !> e3w_0(i,j,k) = dk(gdep)(k) = e3(i,j,k) + !> t-level: gdept_0(i,j,k) = gdep(k+0.5) + !> e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) + !> + !> With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), + !> we find the mbathy index of the depth at each grid point. + !> This leads us to three cases: + !> + !> - bathy = 0 => mbathy = 0 + !> - 1 < mbathy < jpkm1 + !> - bathy > gdepw_0(jpk) => mbathy = jpkm1 + !> + !> Then, for each case, we find the new depth at t- and w- levels + !> and the new vertical scale factors at t-, u-, v-, w-, uw-, vw- + !> and f-points. + !> + !> This routine is given as an example, it must be modified + !> following the user s desiderata. nevertheless, the output as + !> well as the way to compute the model levels and scale factors + !> must be respected in order to insure second order accuracy + !> schemes. + !> + !> @warrning gdept_1d, gdepw_1d and e3._1d are positives + !> gdept_0, gdepw_0 and e3. are positives + !> + !> Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. + !> set 3D coord. arrays to reference 1D array + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_zps + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[inout] td_bathy + !> @param[inout] td_risfdep + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + TYPE(TVAR) , INTENT(INOUT) :: td_bathy + TYPE(TVAR) , INTENT(INOUT) :: td_risfdep + + ! local variable + REAL(dp) :: zmax ! Maximum depth + REAL(dp) :: zdepwp, zdepth ! Ajusted ocean depth to avoid too small e3t + REAL(dp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points + REAL(dp) :: zdiff ! temporary scalar + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + + INTEGER(i4) :: ik + INTEGER(i4) :: it + !---------------------------------------------------------------- + + CALL logger_info('GRID ZGR ZPS : z-coordinate with partial steps') + CALL logger_info('mbathy is recomputed : bathy_level file is NOT used') + + ! bathymetry in level (from bathy_meter) + + ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) + zmax = tg_gdepw_1d%d_value(1,1,jpk,1) + tg_e3t_1d%d_value(1,1,jpk,1) + + ! bounded value of bathy (min already set at the end of zgr_bat) + td_bathy%d_value(:,:,1,1) = MIN(zmax, td_bathy%d_value(:,:,1,1)) + + WHERE( td_bathy%d_value(:,:,1,1) == 0._dp ) + ! land : set mbathy to 0 + tg_mbathy%d_value(:,:,1,1) = 0 + ELSE WHERE + ! ocean : initialize mbathy to the max ocean level + tg_mbathy%d_value(:,:,1,1) = jpk-1 + END WHERE + + ! Compute mbathy for ocean points (i.e. the number of ocean levels) + ! find the number of ocean levels such that the last level thickness + ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where + ! e3t_1d is the reference level thickness + DO jk = jpk-1, 1, -1 + zdepth = tg_gdepw_1d%d_value(1,1,jk,1) + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,jk,1)) + + WHERE( 0._dp < td_bathy%d_value(:,:,1,1) .AND. & + & td_bathy%d_value(:,:,1,1) <= zdepth ) + tg_mbathy%d_value(:,:,1,1) = jk-1 + END WHERE + END DO + + ! Scale factors and depth at T- and W-points + DO jk = 1, jpk + ! intitialization to the reference z-coordinate + tg_gdept_0%d_value(:,:,jk,1) = tg_gdept_1d%d_value(1,1,jk,1) + tg_gdepw_0%d_value(:,:,jk,1) = tg_gdepw_1d%d_value(1,1,jk,1) + tg_e3t_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value (1,1,jk,1) + tg_e3w_0%d_value (:,:,jk,1) = tg_e3w_1d%d_value (1,1,jk,1) + END DO + + IF ( td_nam%l_isfcav )THEN + ! Bathy, iceshelf draft, scale factor and depth at T- and W- points in case of isf + CALL grid_zgr__isf_fill( td_nam, jpi,jpj,jpk, td_bathy, td_risfdep ) + + ELSE ! .NOT. td_nam%l_isfcav + ! + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_mbathy%d_value(ji,jj,1,1) + IF( ik > 0 ) THEN + ! ocean point only + IF( ik == jpk-1 ) THEN + ! max ocean level case + zdepwp = td_bathy%d_value(ji,jj,1,1) + ze3tp = td_bathy%d_value(ji,jj,1,1) - tg_gdepw_1d%d_value(1,1,ik,1) + ze3wp = 0.5_dp * tg_e3w_1d%d_value(1,1,ik,1) & + & * ( 1._dp + ( ze3tp/tg_e3t_1d%d_value(1,1,ik,1) ) ) + tg_e3t_0%d_value (ji,jj,ik ,1) = ze3tp + tg_e3t_0%d_value (ji,jj,ik+1,1) = ze3tp + tg_e3w_0%d_value (ji,jj,ik ,1) = ze3wp + tg_e3w_0%d_value (ji,jj,ik+1,1) = ze3tp + + tg_gdepw_0%d_value(ji,jj,ik+1,1) = zdepwp + tg_gdept_0%d_value(ji,jj,ik ,1) = tg_gdept_1d%d_value( 1, 1,ik-1,1) + ze3wp + tg_gdept_0%d_value(ji,jj,ik+1,1) = tg_gdept_0%d_value (ji,jj,ik ,1) + ze3tp + ! + ELSE + ! standard case + IF( td_bathy%d_value(ji,jj,1,1) <= tg_gdepw_1d%d_value(1,1,ik+1,1) ) THEN + tg_gdepw_0%d_value(ji,jj,ik+1,1) = td_bathy%d_value(ji,jj,1,1) + ELSE + tg_gdepw_0%d_value(ji,jj,ik+1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + ENDIF + !gm Bug? check the gdepw_1d + ! ... on ik + tg_gdept_0%d_value(ji,jj,ik,1) = tg_gdepw_1d%d_value( 1, 1,ik ,1) + & + & ( tg_gdepw_0%d_value(ji,jj,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) & + & * ( (tg_gdept_1d%d_value( 1, 1,ik ,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) & + & / (tg_gdepw_1d%d_value( 1, 1,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) ) + + tg_e3t_0%d_value (ji,jj,ik,1) = tg_e3t_1d%d_value ( 1, 1,ik ,1) & + & * ( tg_gdepw_0%d_value (ji,jj,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) & + & / ( tg_gdepw_1d%d_value( 1, 1,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) + + tg_e3w_0%d_value (ji,jj,ik,1) = 0.5_dp & + & * ( tg_gdepw_0%d_value(ji,jj,ik+1,1) & + & + tg_gdepw_1d%d_value(1,1 ,ik+1,1) & + & - tg_gdepw_1d%d_value(1,1 ,ik ,1) * 2._dp ) & + & * ( tg_e3w_1d%d_value (1 ,1 ,ik ,1) & + & / (tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1)) ) + + ! ... on ik+1 + tg_e3w_0%d_value (ji,jj,ik+1,1) = tg_e3t_0%d_value (ji,jj,ik,1) + tg_e3t_0%d_value (ji,jj,ik+1,1) = tg_e3t_0%d_value (ji,jj,ik,1) + tg_gdept_0%d_value(ji,jj,ik+1,1) = tg_gdept_0%d_value(ji,jj,ik,1) + tg_e3t_0%d_value(ji,jj,ik,1) + ENDIF + ENDIF + END DO + END DO + ! + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_mbathy%d_value(ji,jj,1,1) + IF( ik > 0 ) THEN ! ocean point only + tg_e3tp%d_value (ji,jj,1,1) = tg_e3t_0%d_value(ji,jj,ik,1) + tg_e3wp%d_value (ji,jj,1,1) = tg_e3w_0%d_value(ji,jj,ik,1) + ! test + zdiff= tg_gdepw_0%d_value(ji,jj,ik+1,1) - tg_gdept_0%d_value(ji,jj,ik,1) + IF( zdiff <= 0._dp ) THEN + it = it + 1 + CALL logger_info(' it = '//TRIM(fct_str(it))//& + & ' ik = '//TRIM(fct_str(ik))//& + & ' (i,j) = ('//TRIM(fct_str(ji))//','//TRIM(fct_str(jj))//')') + CALL logger_info(' bathy = '//TRIM(fct_str(td_bathy%d_value(ji,jj,1,1)))) + CALL logger_info(' gdept_0 = '//TRIM(fct_str( tg_gdept_0%d_value(ji,jj,ik ,1) ))//& + & ' gdepw_0 = '//TRIM(fct_str( tg_gdepw_0%d_value(ji,jj,ik+1,1) ))//& + & ' zdiff = '//TRIM(fct_str(zdiff)) ) + CALL logger_info(' e3tp = '//TRIM(fct_str(tg_e3t_0%d_value(ji,jj,ik,1)))//& + & ' e3wp = '//TRIM(fct_str(tg_e3w_0%d_value(ji,jj,ik,1))) ) + ENDIF + ENDIF + END DO + END DO + ENDIF + ! +! IF ( td_nam%l_isfcav ) THEN +! ! (ISF) Definition of e3t, u, v, w for ISF case +! CALL grid_zgr__isf_fill_e3x( jpi,jpj, & +! & td_risfdep ) +! END IF + + ! Scale factors and depth at U-, V-, UW and VW-points + DO jk = 1, jpk + ! initialisation to z-scale factors + tg_e3u_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + tg_e3v_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + tg_e3uw_0%d_value(:,:,jk,1) = tg_e3w_1d%d_value(1,1,jk,1) + tg_e3vw_0%d_value(:,:,jk,1) = tg_e3w_1d%d_value(1,1,jk,1) + END DO + + ! Computed as the minimum of neighbooring scale factors + DO jk = 1,jpk + DO jj = 1, jpj - 1 + DO ji = 1, jpi - 1 + tg_e3u_0%d_value (ji,jj,jk,1) = MIN( tg_e3t_0%d_value(ji,jj,jk,1), tg_e3t_0%d_value(ji+1,jj ,jk,1) ) + tg_e3v_0%d_value (ji,jj,jk,1) = MIN( tg_e3t_0%d_value(ji,jj,jk,1), tg_e3t_0%d_value(ji ,jj+1,jk,1) ) + tg_e3uw_0%d_value(ji,jj,jk,1) = MIN( tg_e3w_0%d_value(ji,jj,jk,1), tg_e3w_0%d_value(ji+1,jj ,jk,1) ) + tg_e3vw_0%d_value(ji,jj,jk,1) = MIN( tg_e3w_0%d_value(ji,jj,jk,1), tg_e3w_0%d_value(ji ,jj+1,jk,1) ) + END DO + END DO + END DO + + IF ( td_nam%l_isfcav ) THEN + ! (ISF) define e3uw (adapted for 2 cells in the water column) + CALL grid_zgr__isf_fill_e3uw(jpi,jpj) + END IF + + ! lateral boundary conditions + CALL lbc_lnk( tg_e3u_0%d_value (:,:,:,1), 'U', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3v_0%d_value (:,:,:,1), 'V', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3uw_0%d_value(:,:,:,1), 'U', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3vw_0%d_value(:,:,:,1), 'V', td_nam%i_perio, 1._dp ) + + ! set to z-scale factor if zero (i.e. along closed boundaries) + DO jk = 1, jpk + WHERE( tg_e3u_0%d_value (:,:,jk,1) == 0._dp ) tg_e3u_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + WHERE( tg_e3v_0%d_value (:,:,jk,1) == 0._dp ) tg_e3v_0%d_value (:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + WHERE( tg_e3uw_0%d_value(:,:,jk,1) == 0._dp ) tg_e3uw_0%d_value(:,:,jk,1) = tg_e3w_1d%d_value(1,1,jk,1) + WHERE( tg_e3vw_0%d_value(:,:,jk,1) == 0._dp ) tg_e3vw_0%d_value(:,:,jk,1) = tg_e3w_1d%d_value(1,1,jk,1) + END DO + + !! Scale factor at F-point + !DO jk = 1, jpk + ! ! initialisation to z-scale factors + ! tg_e3f_0%d_value(:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + !END DO + ! + !! Computed as the minimum of neighbooring V-scale factors + !DO jk = 1, jpk + ! DO jj = 1, jpj - 1 + ! DO ji = 1, jpi - 1 + ! tg_e3f_0%d_value(ji,jj,jk,1) = MIN( tg_e3v_0%d_value(ji,jj,jk,1), tg_e3v_0%d_value(ji+1,jj,jk,1) ) + ! END DO + ! END DO + !END DO + !! Lateral boundary conditions + !CALL lbc_lnk( tg_e3f_0%d_value(:,:,:,1), 'F', td_nam%i_perio, 1._dp ) + ! + !! set to z-scale factor if zero (i.e. along closed boundaries) + !DO jk = 1, jpk + ! WHERE( tg_e3f_0%d_value(:,:,jk,1) == 0._dp ) tg_e3f_0%d_value(:,:,jk,1) = tg_e3t_1d%d_value(1,1,jk,1) + !END DO + +!!gm bug ? : must be a do loop with mj0,mj1 + + ! we duplicate factor scales for jj = 1 and jj = 2 + tg_e3t_0%d_value(:,1,:,1) = tg_e3t_0%d_value(:,2,:,1) + tg_e3w_0%d_value(:,1,:,1) = tg_e3w_0%d_value(:,2,:,1) + tg_e3u_0%d_value(:,1,:,1) = tg_e3u_0%d_value(:,2,:,1) + tg_e3v_0%d_value(:,1,:,1) = tg_e3v_0%d_value(:,2,:,1) + !tg_e3f_0%d_value(:,1,:,1) = tg_e3f_0%d_value(:,2,:,1) + + ! Control of the sign + IF( MINVAL( tg_e3t_0%d_value (:,:,:,:) ) <= 0._dp ) CALL logger_fatal( ' GRID ZGR ZPS: e r r o r e3t_0 <= 0' ) + IF( MINVAL( tg_e3w_0%d_value (:,:,:,:) ) <= 0._dp ) CALL logger_fatal( ' GRID ZGR ZPS: e r r o r e3w_0 <= 0' ) + IF( MINVAL( tg_gdept_0%d_value(:,:,:,:) ) < 0._dp ) CALL logger_fatal( ' GRID ZGR ZPS: e r r o r gdept_0 < 0' ) + IF( MINVAL( tg_gdepw_0%d_value(:,:,:,:) ) < 0._dp ) CALL logger_fatal( ' GRID ZGR ZPS: e r r o r gdepw_0 < 0' ) + + !! Compute gdep3w_0 (vertical sum of e3w) + !IF ( td_nam%l_isfcav ) THEN + ! ! if cavity + ! CALL grid_zgr__isf_fill_gdep3w_0(jpi, jpj, jpk, td_risfdep) + !ELSE + ! ! no cavity + ! tg_gdep3w_0%d_value(:,:,1,1) = 0.5_dp * tg_e3w_0%d_value(:,:,1,1) + ! DO jk = 2, jpk + ! tg_gdep3w_0%d_value(:,:,jk,1) = tg_gdep3w_0%d_value(:,:,jk-1,1) + tg_e3w_0%d_value(:,:,jk,1) + ! END DO + !END IF + + END SUBROUTINE grid_zgr__zps_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__isf_fill(td_nam, jpi,jpj,jpk, td_bathy, td_risfdep) + !------------------------------------------------------------------- + !> @brief This subroutine check the bathymetry in levels + !> + !> @details + !> ** Method : THe water column have to contained at least 2 cells + !> Bathymetry and isfdraft are modified (dig/close) to respect + !> this criterion. + !> + !> + !> ** Action : - test compatibility between isfdraft and bathy + !> - bathy and isfdraft are modified + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_isf + !> @date October, 2016 + !> - add ice sheet coupling case + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] td_bathy + !> @param[in] td_risfdep + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + TYPE(TVAR) , INTENT(INOUT) :: td_bathy + TYPE(TVAR) , INTENT(INOUT) :: td_risfdep + + ! local variable + INTEGER(i4) :: ik, it + INTEGER(i4) :: ibtest, ibtestim1, ibtestip1, ibtestjm1, ibtestjp1 ! (ISF) + + INTEGER(i4), ALLOCATABLE, DIMENSION(:,:) :: zmbathy, zmisfdep ! 2D workspace (ISH) + + REAL(dp) :: zdepth ! Ajusted ocean depth to avoid too small e3t + REAL(dp) :: zmax ! Maximum and minimum depth + REAL(dp) :: zbathydiff, zrisfdepdiff ! isf temporary scalar + REAL(dp) :: zdepwp ! Ajusted ocean depth to avoid too small e3t + REAL(dp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points + REAL(dp) :: zdiff ! temporary scalar + + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zrisfdep, zmask ! 2D workspace (ISH) + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! (ISF) compute misfdep + WHERE( td_risfdep%d_value(:,:,1,1) == 0._dp .AND. & + & td_bathy%d_value (:,:,1,1) /= 0 ) + ! open water : set misfdep to 1 + tg_misfdep%d_value(:,:,1,1) = 1 + ELSEWHERE + ! iceshelf : initialize misfdep to second level + tg_misfdep%d_value(:,:,1,1) = 2 + END WHERE + + ALLOCATE(zmask (jpi,jpj)) + ALLOCATE(zrisfdep(jpi,jpj)) + ALLOCATE(zmisfdep(jpi,jpj)) + + ! Compute misfdep for ocean points (i.e. first wet level) + ! find the first ocean level such that the first level thickness + ! is larger than the bot_level of e3zps_min and e3zps_rat * e3t_0 (where + ! e3t_0 is the reference level thickness + DO jk = 2, jpk-1 + zdepth = tg_gdepw_1d%d_value(1,1,jk+1,1) - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,jk,1) ) + WHERE( 0._dp < td_risfdep%d_value(:,:,1,1) .AND. & + & td_risfdep%d_value(:,:,1,1) >= zdepth ) + tg_misfdep%d_value(:,:,1,1) = jk+1 + END WHERE + END DO + + WHERE( 0._dp < td_risfdep%d_value(:,:,1,1) .AND. & + & td_risfdep%d_value(:,:,1,1) <= tg_e3t_1d%d_value(1,1,1,1) ) + td_risfdep%d_value(:,:,1,1) = 0. + tg_misfdep%d_value(:,:,1,1) = 1 + END WHERE + + ! remove very shallow ice shelf (less than ~ 10m if 75L) + WHERE( td_risfdep%d_value(:,:,1,1) <= 10._dp .AND. & + & tg_misfdep%d_value(:,:,1,1) > 1 ) + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0.0_dp + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0.0_dp + END WHERE + WHERE( td_bathy%d_value(:,:,1,1) <= 30.0_dp .AND. & + & tg_gphit%d_value(:,:,1,1) < -60._dp ) + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0.0_dp + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0.0_dp + END WHERE + + ! basic check for the compatibility of bathy and risfdep. + ! I think it should be offline because it is not perfect and cannot solved all the situation + ! run the bathy check 10 times to be sure all the modif in the bathy or iceshelf draft are compatible together + DO jl = 1, 10 + + WHERE( td_bathy%d_value(:,:,1,1) <= td_risfdep%d_value(:,:,1,1) + td_nam%d_isfhmin ) + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0._dp + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0._dp + END WHERE + + WHERE( tg_mbathy%d_value(:,:,1,1) <= 0 ) + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0._dp + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0._dp + ENDWHERE + + !! lk_mpp not added + + IF( td_nam%i_perio == 1 .OR. & + & td_nam%i_perio == 4 .OR. & + & td_nam%i_perio == 6 )THEN + ! local domain is cyclic east-west + tg_misfdep%d_value( 1 ,:,1,1) = tg_misfdep%d_value(jpi-1,:,1,1) + tg_misfdep%d_value(jpi,:,1,1) = tg_misfdep%d_value( 2 ,:,1,1) + + tg_mbathy%d_value( 1 ,:,1,1) = tg_mbathy%d_value(jpi-1,:,1,1) + tg_mbathy%d_value(jpi,:,1,1) = tg_mbathy%d_value( 2 ,:,1,1) + ENDIF + + ! split last cell if possible (only where water column is 2 cell or less) + ! if coupled to ice sheet, we do not modify the bathymetry (can be discuss). + IF( .NOT. td_nam%l_iscpl )THEN + DO jk = jpk-1, 1, -1 + zmax = tg_gdepw_1d%d_value(1,1,jk,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,jk,1) ) + + WHERE( td_bathy%d_value(:,:,1,1) > tg_gdepw_1d%d_value(1,1,jk,1).AND. & + & td_bathy%d_value(:,:,1,1) <= zmax .AND. & + & tg_misfdep%d_value(:,:,1,1) + 1 >= tg_mbathy%d_value(:,:,1,1) ) + + tg_mbathy%d_value(:,:,1,1) = jk + td_bathy%d_value (:,:,1,1) = zmax + + END WHERE + END DO + ENDIF + + ! split top cell if possible (only where water column is 2 cell or less) + DO jk = 2, jpk-1 + zmax = tg_gdepw_1d%d_value(1,1,jk+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,jk,1) ) + + WHERE( td_risfdep%d_value(:,:,1,1) < tg_gdepw_1d%d_value(1,1,jk+1,1) .AND. & + & td_risfdep%d_value(:,:,1,1) >= zmax .AND. & + & tg_misfdep%d_value(:,:,1,1) + 1 >= tg_mbathy%d_value(:,:,1,1) ) + + tg_misfdep%d_value(:,:,1,1) = jk + td_risfdep%d_value(:,:,1,1) = zmax + + END WHERE + END DO + + ! Case where bathy and risfdep compatible but not the level + ! variable mbathy/misfdep because of partial cell condition + DO jj = 1, jpj + DO ji = 1, jpi + ! find the minimum change option: + ! test bathy + IF( td_risfdep%d_value(ji,jj,1,1) > 1 )THEN + IF( .NOT. td_nam%l_iscpl )THEN + + ik=tg_mbathy%d_value(ji,jj,1,1) + zbathydiff = ABS( td_bathy%d_value(ji,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN(td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat * tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji,jj,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat * tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( td_bathy%d_value (ji,jj,1,1) > td_risfdep%d_value (ji,jj,1,1) .AND. & + & tg_mbathy%d_value(ji,jj,1,1) < tg_misfdep%d_value(ji,jj,1,1) )THEN + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value(ji,jj,1,1) = tg_mbathy%d_value(ji,jj,1,1) + 1 + + ik=tg_mbathy%d_value(ji,jj,1,1) + td_bathy%d_value (ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + + tg_misfdep%d_value(ji,jj,1,1) = tg_misfdep%d_value(ji,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj,1,1) + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1) ) + ENDIF + + ENDIF + + ELSE + + IF( td_bathy%d_value (ji,jj,1,1) > td_risfdep%d_value (ji,jj,1,1) .AND. & + & tg_mbathy%d_value(ji,jj,1,1) < tg_misfdep%d_value(ji,jj,1,1) )THEN + + tg_misfdep%d_value(ji,jj,1,1) = tg_misfdep%d_value(ji,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj,1,1) + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1) ) + ENDIF + + ENDIF + + ENDIF + ENDDO + ENDDO + + ! At least 2 levels for water thickness at T, U, and V point. + DO jj = 1, jpj + DO ji = 1, jpi + ! find the minimum change option: + ! test bathy + IF( tg_misfdep%d_value(ji,jj,1,1) == tg_mbathy%d_value(ji,jj,1,1) .AND. & + & tg_mbathy%d_value (ji,jj,1,1) > 1) THEN + + IF ( .NOT. td_nam%l_iscpl ) THEN + + ik=tg_mbathy%d_value(ji,jj,1,1) + zbathydiff = ABS( td_bathy%d_value(ji,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji,jj,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value(ji,jj,1,1) = tg_mbathy%d_value(ji,jj,1,1) + 1 + + ik=tg_mbathy%d_value(ji,jj,1,1) + td_bathy%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + + tg_misfdep%d_value(ji,jj,1,1) = tg_misfdep%d_value(ji,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj,1,1) + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + ENDIF + + ELSE + + tg_misfdep%d_value(ji,jj,1,1) = tg_misfdep%d_value(ji,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj,1,1) + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + + ENDIF + ENDIF + + ENDDO + ENDDO + + ! point V mbathy(ji,jj ) == misfdep(ji,jj+1) + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + + IF( tg_mbathy%d_value(ji,jj ,1,1) == tg_misfdep%d_value(ji,jj+1,1,1) .AND. & + & tg_mbathy%d_value(ji,jj ,1,1) > 1 )THEN + IF ( .NOT. td_nam%l_iscpl ) THEN + + ik=tg_mbathy%d_value(ji,jj ,1,1) + zbathydiff = ABS( td_bathy%d_value(ji,jj ,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji,jj+1,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji,jj+1,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value(ji,jj ,1,1) = tg_mbathy%d_value(ji,jj ,1,1) + 1 + + ik=tg_mbathy%d_value(ji,jj ,1,1) + td_bathy%d_value (ji,jj ,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + + tg_misfdep%d_value(ji,jj+1,1,1) = tg_misfdep%d_value(ji,jj+1,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj+1,1,1) + td_risfdep%d_value(ji,jj+1,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + ENDIF + + ELSE + tg_misfdep%d_value(ji,jj+1,1,1) = tg_misfdep%d_value(ji,jj+1,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj+1,1,1) + td_risfdep%d_value(ji,jj+1,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + ENDIF + + ENDIF + + ENDDO + ENDDO + + !! lk_mpp not added + + ! point V mbathy(ji,jj+1) == misfdep(ji,jj ) + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + + IF( tg_mbathy%d_value(ji,jj+1,1,1) == tg_misfdep%d_value(ji,jj ,1,1) .AND. & + & tg_mbathy%d_value(ji,jj ,1,1) > 1) THEN + IF ( .NOT. td_nam%l_iscpl ) THEN + + ik=tg_mbathy%d_value(ji,jj+1,1,1) + zbathydiff = ABS( td_bathy%d_value(ji,jj+1,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji,jj ,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value (ji,jj+1,1,1) = tg_mbathy%d_value(ji,jj+1,1,1) + 1 + + ik=tg_mbathy%d_value(ji,jj+1,1,1) + td_bathy%d_value (ji,jj+1,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + + tg_misfdep%d_value(ji,jj ,1,1) = tg_misfdep%d_value(ji,jj ,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj ,1,1) + td_risfdep%d_value(ji,jj ,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + END IF + + ELSE + + tg_misfdep%d_value(ji,jj ,1,1) = tg_misfdep%d_value(ji,jj ,1,1) - 1 + + ik=tg_misfdep%d_value(ji,jj ,1,1) + td_risfdep%d_value(ji,jj ,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + + ENDIF + + ENDIF + + ENDDO + ENDDO + + !! lk_mpp not added + + ! point U mbathy(ji ,jj) EQ misfdep(ji+1,jj) + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + + IF( tg_mbathy%d_value(ji ,jj,1,1) == tg_misfdep%d_value(ji+1,jj,1,1) .AND. & + & tg_mbathy%d_value(ji ,jj,1,1) > 1 )THEN + IF ( .NOT. td_nam%l_iscpl ) THEN + + ik=tg_mbathy%d_value(ji ,jj,1,1) + zbathydiff = ABS( td_bathy%d_value(ji ,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat* tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji+1,jj,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji+1,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value (ji ,jj,1,1) = tg_mbathy%d_value(ji ,jj,1,1) + 1 + + ik=tg_mbathy%d_value(ji ,jj,1,1) + td_bathy%d_value (ji ,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + tg_misfdep%d_value(ji+1,jj,1,1) = tg_misfdep%d_value(ji+1,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji+1,jj,1,1) + td_risfdep%d_value(ji+1,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + END IF + + ELSE + tg_misfdep%d_value(ji+1,jj,1,1)= tg_misfdep%d_value(ji+1,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji+1,jj,1,1) + td_risfdep%d_value(ji+1,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + ENDIF + ENDIF + + ENDDO + ENDDO + + !! lk_mpp not added + + ! point U mbathy(ji+1,jj) == misfdep(ji ,jj) + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + + IF( tg_mbathy%d_value(ji+1,jj,1,1) == tg_misfdep%d_value(ji ,jj,1,1) .AND. & + & tg_mbathy%d_value(ji ,jj,1,1) > 1 )THEN + IF ( .NOT. td_nam%l_iscpl ) THEN + + ik=tg_mbathy%d_value(ji+1,jj,1,1) + zbathydiff = ABS( td_bathy%d_value(ji+1,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik+1,1) & + & + MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1)) )) + + ik=tg_misfdep%d_value(ji ,jj,1,1) + zrisfdepdiff = ABS( td_risfdep%d_value(ji ,jj,1,1) - ( tg_gdepw_1d%d_value(1,1,ik,1) & + & - MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik-1,1)) )) + + IF( zbathydiff <= zrisfdepdiff )THEN + + tg_mbathy%d_value (ji+1,jj,1,1) = tg_mbathy%d_value(ji+1,jj,1,1) + 1 + + ik=tg_mbathy%d_value(ji+1,jj,1,1) + td_bathy%d_value (ji+1,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik+1,1) ) + ELSE + tg_misfdep%d_value(ji ,jj,1,1) = tg_misfdep%d_value(ji ,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji ,jj,1,1) + td_risfdep%d_value(ji ,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + END IF + + ELSE + + tg_misfdep%d_value(ji ,jj,1,1) = tg_misfdep%d_value(ji ,jj,1,1) - 1 + + ik=tg_misfdep%d_value(ji ,jj,1,1) + td_risfdep%d_value(ji ,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & + & MIN( td_nam%d_e3zps_min, & + & td_nam%d_e3zps_rat*tg_e3t_1d%d_value(1,1,ik,1) ) + + ENDIF + + ENDIF + + ENDDO + ENDDO + + END DO ! jl + ! end dig bathy/ice shelf to be compatible + + ! now fill single point in "coastline" of ice shelf, bathy, hole, and test again one cell tickness + DO jl = 1,20 + + ! remove single point "bay" on isf coast line in the ice shelf draft' + DO jk = 2, jpk + WHERE( tg_misfdep%d_value(:,:,1,1) == 0 ) + tg_misfdep%d_value(:,:,1,1)=jpk + END WHERE + + zmask(:,:)=0 + WHERE( tg_misfdep%d_value(:,:,1,1) <= jk ) zmask(:,:)=1 + + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + IF( tg_misfdep%d_value(ji,jj,1,1) == jk )THEN + + ibtest = zmask(ji-1,jj ) & + & + zmask(ji+1,jj ) & + & + zmask(ji ,jj-1) & + & + zmask(ji ,jj+1) + IF( ibtest <= 1 )THEN + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,jk+1,1) + tg_misfdep%d_value(ji,jj,1,1) = jk+1 + IF( tg_misfdep%d_value(ji,jj,1,1) > tg_mbathy%d_value(ji,jj,1,1) )THEN + tg_misfdep%d_value(ji,jj,1,1) = jpk + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + + WHERE( tg_misfdep%d_value(:,:,1,1) == jpk ) + tg_misfdep%d_value(:,:,1,1)=0 + td_risfdep%d_value(:,:,1,1)=0. + tg_mbathy%d_value (:,:,1,1)=0 + td_bathy%d_value (:,:,1,1)=0. + END WHERE + + !! lk_mpp not added + + ! remove single point "bay" on bathy coast line beneath an ice shelf' + DO jk = jpk,1,-1 + + zmask(:,:)=0 + WHERE( tg_mbathy%d_value(:,:,1,1) >= jk ) zmask(:,:)=1 + + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + IF( tg_mbathy%d_value (ji,jj,1,1) == jk .AND. & + & tg_misfdep%d_value(ji,jj,1,1) >= 2 )THEN + + ibtest = zmask(ji-1,jj ) & + & + zmask(ji+1,jj ) & + & + zmask(ji ,jj-1) & + & + zmask(ji ,jj+1) + IF( ibtest <= 1 )THEN + td_bathy%d_value (ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,jk,1) + tg_mbathy%d_value(ji,jj,1,1) = jk-1 + IF( tg_misfdep%d_value(ji,jj,1,1) > tg_mbathy%d_value(ji,jj,1,1) )THEN + tg_mbathy%d_value(ji,jj,1,1) = 0 + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + + WHERE( tg_mbathy%d_value(:,:,1,1) == 0 ) + tg_misfdep%d_value(:,:,1,1)=0 + td_risfdep%d_value(:,:,1,1)=0. + tg_mbathy%d_value (:,:,1,1)=0 + td_bathy%d_value (:,:,1,1)=0. + END WHERE + + !! lk_mpp not added + + ! fill hole in ice shelf + zmisfdep(:,:) = tg_misfdep%d_value(:,:,1,1) + zrisfdep(:,:) = td_risfdep%d_value(:,:,1,1) + WHERE( zmisfdep(:,:) <= 1 ) zmisfdep(:,:)=jpk + + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + + ibtestim1 = zmisfdep(ji-1,jj ) + ibtestip1 = zmisfdep(ji+1,jj ) + + ibtestjm1 = zmisfdep(ji ,jj-1) + ibtestjp1 = zmisfdep(ji ,jj+1) + + IF( zmisfdep(ji,jj) >= tg_mbathy%d_value(ji-1,jj ,1,1) ) ibtestim1 = jpk + IF( zmisfdep(ji,jj) >= tg_mbathy%d_value(ji+1,jj ,1,1) ) ibtestip1 = jpk + IF( zmisfdep(ji,jj) >= tg_mbathy%d_value(ji ,jj-1,1,1) ) ibtestjm1 = jpk + IF( zmisfdep(ji,jj) >= tg_mbathy%d_value(ji ,jj+1,1,1) ) ibtestjp1 = jpk + + ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) + IF( ibtest == jpk .AND. & + & tg_misfdep%d_value(ji,jj,1,1) >= 2 )THEN + tg_mbathy%d_value (ji,jj,1,1) = 0 + td_bathy%d_value (ji,jj,1,1) = 0.0_dp + tg_misfdep%d_value(ji,jj,1,1) = 0 + td_risfdep%d_value(ji,jj,1,1) = 0.0_dp + END IF + + IF( zmisfdep(ji,jj) < ibtest .AND. & + & tg_misfdep%d_value(ji,jj,1,1) >= 2 )THEN + tg_misfdep%d_value(ji,jj,1,1) = ibtest + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ibtest,1) + ENDIF + + ENDDO + ENDDO + + !! lk_mpp not added + + !! fill hole in bathymetry + zmbathy(:,:) = tg_mbathy%d_value(:,:,1,1) + DO jj = 2, jpj-1 + DO ji = 2, jpi-1 + + ibtestim1 = zmbathy(ji-1,jj ) + ibtestip1 = zmbathy(ji+1,jj ) + + ibtestjm1 = zmbathy(ji ,jj-1) + ibtestjp1 = zmbathy(ji ,jj+1) + + IF( zmbathy(ji,jj) < tg_misfdep%d_value(ji-1,jj ,1,1) ) ibtestim1 = 0 + IF( zmbathy(ji,jj) < tg_misfdep%d_value(ji+1,jj ,1,1) ) ibtestip1 = 0 + IF( zmbathy(ji,jj) < tg_misfdep%d_value(ji ,jj-1,1,1) ) ibtestjm1 = 0 + IF( zmbathy(ji,jj) < tg_misfdep%d_value(ji ,jj+1,1,1) ) ibtestjp1 = 0 + + ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) + IF( ibtest == 0 .AND. tg_misfdep%d_value(ji,jj,1,1) >= 2) THEN + tg_mbathy%d_value (ji,jj,1,1) = 0 + td_bathy%d_value (ji,jj,1,1) = 0.0_dp + tg_misfdep%d_value(ji,jj,1,1) = 0 + td_risfdep%d_value(ji,jj,1,1) = 0.0_dp + END IF + + IF( ibtest < zmbathy(ji,jj) .AND. & + & tg_misfdep%d_value(ji,jj,1,1) >= 2) THEN + tg_mbathy%d_value(ji,jj,1,1) = ibtest + td_bathy%d_value (ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ibtest+1,1) + ENDIF + + ENDDO + ENDDO + + !! lk_mpp not added + + ! if not compatible after all check (ie U point water column less than 2 cells), mask U + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + IF( tg_mbathy%d_value(ji ,jj,1,1) == tg_misfdep%d_value(ji+1,jj,1,1) .AND. & + & tg_mbathy%d_value(ji ,jj,1,1) >= 1 .AND. & + & tg_mbathy%d_value(ji+1,jj,1,1) >= 1 )THEN + + tg_mbathy%d_value(ji,jj,1,1) = tg_mbathy%d_value(ji,jj,1,1) - 1 + + ik=tg_mbathy%d_value(ji,jj,1,1) + td_bathy%d_value (ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + ENDIF + ENDDO + ENDDO + + !! lk_mpp not added + + ! if not compatible after all check (ie U point water column less than 2 cells), mask U + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 + IF( tg_misfdep%d_value(ji ,jj,1,1) == tg_mbathy%d_value(ji+1,jj,1,1) .AND. & + & tg_mbathy%d_value (ji ,jj,1,1) >= 1 .AND.& + & tg_mbathy%d_value (ji+1,jj,1,1) >= 1 )THEN + + tg_mbathy%d_value(ji+1,jj,1,1) = tg_mbathy%d_value(ji+1,jj,1,1) - 1 + + ik=tg_mbathy%d_value(ji+1,jj,1,1) + td_bathy%d_value(ji+1,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + ENDIF + ENDDO + ENDDO + + !! lk_mpp not added + + ! if not compatible after all check (ie V point water column less than 2 cells), mask V + DO jj = 1, jpj-1 + DO ji = 1, jpi + IF( tg_mbathy%d_value(ji,jj ,1,1) == tg_misfdep%d_value(ji,jj+1,1,1) .AND. & + & tg_mbathy%d_value(ji,jj ,1,1) >= 1 .AND. & + & tg_mbathy%d_value(ji,jj+1,1,1) >= 1 )THEN + + tg_mbathy%d_value(ji,jj,1,1) = tg_mbathy%d_value(ji,jj,1,1) - 1 + + ik=tg_mbathy%d_value(ji,jj,1,1) + td_bathy%d_value (ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + + ENDIF + ENDDO + ENDDO + + !! lk_mpp not added + + ! if not compatible after all check (ie V point water column less than 2 cells), mask V + DO jj = 1, jpj-1 + DO ji = 1, jpi + IF( tg_misfdep%d_value(ji,jj ,1,1) == tg_mbathy%d_value(ji,jj+1,1,1) .AND.& + & tg_mbathy%d_value (ji,jj ,1,1) >= 1 .AND.& + & tg_mbathy%d_value (ji,jj+1,1,1) >= 1 )THEN + + tg_mbathy%d_value(ji,jj+1,1,1) = tg_mbathy%d_value(ji,jj+1,1,1) - 1 + + ik=tg_mbathy%d_value(ji,jj+1,1,1) + td_bathy%d_value (ji,jj+1,1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + ENDIF + ENDDO + ENDDO + + !! lk_mpp not added + + ! if not compatible after all check, mask T + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_mbathy%d_value(ji,jj,1,1) <= tg_misfdep%d_value(ji,jj,1,1) )THEN + tg_misfdep%d_value(ji,jj,1,1) = 0 + td_risfdep%d_value(ji,jj,1,1) = 0._dp + tg_mbathy%d_value (ji,jj,1,1) = 0 + td_bathy%d_value (ji,jj,1,1) = 0._dp + ENDIF + ENDDO + ENDDO + + WHERE( tg_mbathy%d_value(:,:,1,1) == 1 ) + tg_mbathy%d_value (:,:,1,1) = 0 + td_bathy%d_value (:,:,1,1) = 0.0_dp + tg_misfdep%d_value(:,:,1,1) = 0 + td_risfdep%d_value(:,:,1,1) = 0.0_dp + END WHERE + ENDDO + ! end check compatibility ice shelf/bathy + + ! remove very shallow ice shelf (less than ~ 10m if 75L) + WHERE( td_risfdep%d_value(:,:,1,1) <= 10._dp ) + tg_misfdep%d_value(:,:,1,1) = 1 + td_risfdep%d_value(:,:,1,1) = 0.0_dp; + END WHERE + + DEALLOCATE(zmask ) + DEALLOCATE(zrisfdep) + DEALLOCATE(zmisfdep) + + ! compute scale factor and depth at T- and W- points + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_mbathy%d_value(ji,jj,1,1) + IF( ik > 0 ) THEN ! ocean point only + ! max ocean level case + IF( ik == jpk-1 ) THEN + + zdepwp = td_bathy%d_value(ji,jj,1,1) + ze3tp = td_bathy%d_value(ji,jj,1,1) - tg_gdepw_1d%d_value(1,1,ik,1) + ze3wp = 0.5_dp * tg_e3w_1d%d_value(1,1,ik,1) & + & * ( 1._dp + ( ze3tp/tg_e3t_1d%d_value(1,1,ik,1) ) ) + tg_e3t_0%d_value (ji,jj,ik ,1) = ze3tp + tg_e3t_0%d_value (ji,jj,ik+1,1) = ze3tp + tg_e3w_0%d_value (ji,jj,ik ,1) = ze3wp + tg_e3w_0%d_value (ji,jj,ik+1,1) = ze3wp + + tg_gdepw_0%d_value(ji,jj,ik+1,1) = zdepwp + tg_gdept_0%d_value(ji,jj,ik ,1) = tg_gdept_1d%d_value(1 ,1 ,ik-1,1) + ze3wp + tg_gdept_0%d_value(ji,jj,ik+1,1) = tg_gdept_0%d_value (ji,jj,ik ,1) + ze3tp + ! + ELSE ! standard case + + IF( td_bathy%d_value(ji,jj,1,1) <= tg_gdepw_1d%d_value(1,1,ik+1,1) ) THEN + tg_gdepw_0%d_value(ji,jj,ik+1,1) = td_bathy%d_value(ji,jj,1,1) + ELSE + tg_gdepw_0%d_value(ji,jj,ik+1,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) + ENDIF + ! + !gm Bug? check the gdepw_1d + ! ... on ik + tg_gdept_0%d_value(ji,jj,ik,1) = tg_gdepw_1d%d_value(1,1,ik,1) + & + & ( tg_gdepw_0%d_value(ji,jj,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) & + & * ( ( tg_gdept_1d%d_value(1,1, ik ,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) & + & / ( tg_gdepw_1d%d_value(1,1, ik+1,1) - tg_gdepw_1d%d_value(1,1,ik,1) ) ) + + tg_e3t_0%d_value(ji,jj,ik ,1) = tg_gdepw_0%d_value(ji,jj,ik+1,1) - tg_gdepw_1d%d_value(1,1,ik ,1) + tg_e3w_0%d_value(ji,jj,ik ,1) = tg_gdept_0%d_value(ji,jj,ik ,1) - tg_gdept_1d%d_value(1,1,ik-1,1) + ! ... on ik+1 + tg_e3w_0%d_value(ji,jj,ik+1,1) = tg_e3t_0%d_value(ji,jj,ik,1) + tg_e3t_0%d_value(ji,jj,ik+1,1) = tg_e3t_0%d_value(ji,jj,ik,1) + ! + ENDIF + ENDIF + END DO + END DO + ! + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_mbathy%d_value(ji,jj,1,1) + IF( ik > 0 ) THEN ! ocean point only + tg_e3tp%d_value(ji,jj,1,1) = tg_e3t_0%d_value(ji,jj,ik,1) + tg_e3wp%d_value(ji,jj,1,1) = tg_e3w_0%d_value(ji,jj,ik,1) + ! test + zdiff= tg_gdepw_0%d_value(ji,jj,ik+1,1) - tg_gdept_0%d_value(ji,jj,ik,1) + IF( zdiff <= 0._dp ) THEN + it = it + 1 + CALL logger_info(' it = '//TRIM(fct_str(it))//& + & ' ik = '//TRIM(fct_str(ik))//& + & ' (i,j) = '//trim(fct_str(ji))//' '//TRIM(fct_str(jj))) + CALL logger_info(' bathy = '//TRIM(fct_str(td_bathy%d_value(ji,jj,1,1)))) + CALL logger_info(' gdept_0 = '//TRIM(fct_str(tg_gdept_0%d_value(ji,jj,ik,1)))//& + & ' gdepw_0 = '//TRIM(fct_str(tg_gdepw_0%d_value(ji,jj,ik+1,1)))//& + & ' zdiff = '//TRIM(fct_str(zdiff))) + CALL logger_info(' e3tp = '//TRIM(fct_str(tg_e3t_0%d_value(ji,jj,ik,1)))//& + & ' e3wp = '//TRIM(fct_str(tg_e3w_0%d_value(ji,jj,ik,1)))) + ENDIF + ENDIF + END DO + END DO + ! + ! (ISF) Definition of e3t, u, v, w for ISF case + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_misfdep%d_value(ji,jj,1,1) + IF( ik > 1 ) THEN ! ice shelf point only + + IF( td_risfdep%d_value(ji,jj,1,1) < tg_gdepw_1d%d_value(1,1,ik,1) )THEN + td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) + ENDIF + tg_gdepw_0%d_value(ji,jj,ik,1) = td_risfdep%d_value(ji,jj,1,1) +!gm Bug? check the gdepw_0 + ! ... on ik + tg_gdept_0%d_value(ji,jj,ik,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) & + & - ( tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_0%d_value(ji,jj,ik,1) ) & + & * ( tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdept_1d%d_value(1,1, ik,1) ) & + & / ( tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_1d%d_value(1,1, ik,1) ) + + tg_e3t_0%d_value(ji,jj,ik ,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_0%d_value(ji,jj,ik,1) + tg_e3w_0%d_value(ji,jj,ik+1,1) = tg_gdept_1d%d_value(1,1,ik+1,1) - tg_gdept_0%d_value(ji,jj,ik,1) + + IF( ik + 1 == tg_mbathy%d_value(ji,jj,1,1) )THEN ! ice shelf point only (2 cell water column) + tg_e3w_0%d_value(ji,jj,ik+1,1) = tg_gdept_0%d_value(ji,jj,ik+1,1) - tg_gdept_0%d_value(ji,jj,ik,1) + ENDIF + ! ... on ik / ik-1 + tg_e3w_0%d_value (ji,jj,ik ,1) = tg_e3t_0%d_value (ji,jj,ik,1) + tg_e3t_0%d_value (ji,jj,ik-1,1) = tg_gdepw_0%d_value(ji,jj,ik,1) - tg_gdepw_1d%d_value(1,1,ik-1,1) +! The next line isn't required and doesn't affect results - included for consistency with bathymetry code + tg_gdept_0%d_value(ji,jj,ik-1,1) = tg_gdept_1d%d_value(1,1,ik-1,1) + + ENDIF + END DO + END DO + + it = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ik = tg_misfdep%d_value(ji,jj,1,1) + IF( ik > 1 ) THEN ! ice shelf point only + tg_e3tp%d_value(ji,jj,1,1) = tg_e3t_0%d_value(ji,jj,ik ,1) + tg_e3wp%d_value(ji,jj,1,1) = tg_e3w_0%d_value(ji,jj,ik+1,1) + ! test + zdiff= tg_gdept_0%d_value(ji,jj,ik,1) - tg_gdepw_0%d_value(ji,jj,ik,1) + IF( zdiff <= 0. ) THEN + it = it + 1 + CALL logger_info(' it = '//TRIM(fct_str(it))//& + & ' ik = '//TRIM(fct_str(ik))//& + & ' (i,j) = '//trim(fct_str(ji))//' '//TRIM(fct_str(jj))) + + CALL logger_info(' risfdep = '//TRIM(fct_str(td_risfdep%d_value(ji,jj,1,1)))) + CALL logger_info(' gdept = '//TRIM(fct_str(tg_gdept_0%d_value(ji,jj,ik,1)))//& + & ' gdepw = '//TRIM(fct_str(tg_gdepw_0%d_value(ji,jj,ik+1,1)))//& + & ' zdiff = '//TRIM(fct_str(zdiff))) + CALL logger_info(' e3tp = '//TRIM(fct_str(tg_e3t_0%d_value(ji,jj,ik ,1)))//& + & ' e3wp = '//TRIM(fct_str(tg_e3w_0%d_value(ji,jj,ik+1,1)))) + ENDIF + ENDIF + END DO + END DO + + END SUBROUTINE grid_zgr__isf_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE grid_zgr__isf_fill_e3x( jpi,jpj, & +! & td_risfdep) +! !------------------------------------------------------------------- +! !> @brief This subroutine define e3t, u, v, w for ISF case +! !> +! !> @details +! !> +! !> @author J.Paul +! !> @date September, 2015 - rewrite from zgr_zps +! !> +! !> @param[in] jpi +! !> @param[in] jpj +! !> @param[in] td_risfdep +! !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj +! TYPE(TVAR) , INTENT(INOUT) :: td_risfdep +! +! ! local variable +! REAL(dp) :: zdiff ! temporary scalar +! +! ! loop indices +! INTEGER(i4) :: ji +! INTEGER(i4) :: jj +! INTEGER(i4) :: it +! INTEGER(i4) :: ik +! !---------------------------------------------------------------- +! +! ! (ISF) Definition of e3t, u, v, w for ISF case +! DO jj = 1, jpj +! DO ji = 1, jpi +! ik = tg_misfdep%d_value(ji,jj,1,1) +! +! IF( ik > 1 ) THEN +! ! ice shelf point only +! IF( td_risfdep%d_value(ji,jj,1,1) < tg_gdepw_1d%d_value(1,1,ik,1) )THEN +! td_risfdep%d_value(ji,jj,1,1) = tg_gdepw_1d%d_value(1,1,ik,1) +! ENDIF +! tg_gdepw_0%d_value(ji,jj,ik,1) = td_risfdep%d_value(ji,jj,1,1) +! !gm Bug? check the gdepw_0 +! ! ... on ik +! tg_gdept_0%d_value(ji,jj,ik ,1) = tg_gdepw_1d%d_value(1,1,ik+1,1) - & +! & (tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_0%d_value (ji,jj,ik,1)) * & +! & (tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdept_1d%d_value( 1, 1,ik,1)) / & +! & (tg_gdepw_1d%d_value(1,1,ik+1,1) - tg_gdepw_1d%d_value( 1, 1,ik,1)) +! +! tg_e3t_0%d_value (ji,jj,ik ,1) = tg_gdepw_1d%d_value( 1, 1,ik+1,1) - & +! & tg_gdepw_0%d_value (ji,jj,ik ,1) +! +! tg_e3w_0%d_value (ji,jj,ik+1,1) = tg_gdept_1d%d_value( 1, 1,ik+1,1) - & +! & tg_gdept_0%d_value (ji,jj,ik ,1) +! +! IF( ik + 1 == tg_mbathy%d_value(ji,jj,1,1) ) THEN +! +! ! ice shelf point only (2 cell water column) +! tg_e3w_0%d_value(ji,jj,ik+1,1) = tg_gdept_0%d_value(ji,jj,ik+1,1) - & +! & tg_gdept_0%d_value(ji,jj,ik ,1) +! +! ENDIF +! ! ... on ik / ik-1 +! tg_e3w_0%d_value (ji,jj,ik ,1) = 2._dp * (tg_gdept_0%d_value(ji,jj,ik,1) - & +! & tg_gdepw_0%d_value(ji,jj,ik,1)) +! +! tg_e3t_0%d_value (ji,jj,ik-1,1) = tg_gdepw_0%d_value (ji,jj,ik ,1) - & +! & tg_gdepw_1d%d_value( 1, 1,ik-1,1) +! +! ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code +! tg_gdept_0%d_value(ji,jj,ik-1,1) = tg_gdept_1d%d_value(1,1,ik-1,1) +! ENDIF +! +! END DO +! END DO +! +! it = 0 +! DO jj = 1, jpj +! DO ji = 1, jpi +! ik = tg_misfdep%d_value(ji,jj,1,1) +! IF( ik > 1 ) THEN ! ice shelf point only +! tg_e3tp%d_value(ji,jj,1,1) = tg_e3t_0%d_value(ji,jj,ik ,1) +! tg_e3wp%d_value(ji,jj,1,1) = tg_e3w_0%d_value(ji,jj,ik+1,1) +! ! test +! zdiff= tg_gdept_0%d_value(ji,jj,ik,1) - & +! & tg_gdepw_0%d_value(ji,jj,ik,1) +! +! IF( zdiff <= 0. ) THEN +! it = it + 1 +! CALL logger_info(' it = '//TRIM(fct_str(it))//& +! & ' ik = '//TRIM(fct_str(ik))//& +! & ' (i,j) =('//TRIM(fct_str(ji))//','//TRIM(fct_str(jj))//')') +! CALL logger_info(' risfdep = '//TRIM(fct_str(td_risfdep%d_value(ji,jj,1,1))) ) +! CALL logger_info(' gdept = '//TRIM(fct_str(tg_gdept_0%d_value(ji,jj,ik ,1)))//& +! & ' gdepw = '//TRIM(fct_str(tg_gdepw_0%d_value(ji,jj,ik+1,1)))//& +! & ' zdiff = '//TRIM(fct_str(zdiff)) ) +! CALL logger_info(' e3tp = '//TRIM(fct_str( tg_e3tp%d_value(ji,jj,1,1)))//& +! & ' e3wp = '//TRIM(fct_str( tg_e3wp%d_value(ji,jj,1,1))) ) +! ENDIF +! ENDIF +! END DO +! END DO +! ! END (ISF) +! +! END SUBROUTINE grid_zgr__isf_fill_e3x + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__isf_fill_e3uw(jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine define e3uw + !> (adapted for 2 cells in the water column) for ISF case + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_zps + !> + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4) , INTENT(IN ) :: jpi + INTEGER(i4) , INTENT(IN ) :: jpj + + ! local variable + INTEGER(i4) :: ikb, ikt + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + DO jj = 2, jpj - 1 + DO ji = 2, jpi - 1 + + ikb = MAX(tg_mbathy%d_value (ji,jj,1,1), tg_mbathy%d_value (ji+1,jj,1,1)) + ikt = MAX(tg_misfdep%d_value(ji,jj,1,1), tg_misfdep%d_value(ji+1,jj,1,1)) + IF( ikb == ikt+1 )THEN + tg_e3uw_0%d_value(ji,jj,ikb,1) = MIN( tg_gdept_0%d_value(ji,jj,ikb ,1), tg_gdept_0%d_value(ji+1,jj ,ikb ,1) ) - & + & MAX( tg_gdept_0%d_value(ji,jj,ikb-1,1), tg_gdept_0%d_value(ji+1,jj ,ikb-1,1) ) + ENDIF + + ikb = MAX( tg_mbathy%d_value (ji,jj,1,1), tg_mbathy%d_value (ji,jj+1,1,1)) + ikt = MAX( tg_misfdep%d_value(ji,jj,1,1), tg_misfdep%d_value(ji,jj+1,1,1)) + IF( ikb == ikt+1 )THEN + tg_e3vw_0%d_value(ji,jj,ikb,1) = MIN( tg_gdept_0%d_value(ji,jj,ikb ,1), tg_gdept_0%d_value(ji ,jj+1,ikb ,1) ) - & + & MAX( tg_gdept_0%d_value(ji,jj,ikb-1,1), tg_gdept_0%d_value(ji ,jj+1,ikb-1,1) ) + ENDIF + END DO + END DO + + END SUBROUTINE grid_zgr__isf_fill_e3uw + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE grid_zgr__isf_fill_gdep3w_0( jpi,jpj,jpk,td_risfdep ) +! !------------------------------------------------------------------- +! !> @brief This subroutine compute gdep3w_0 (vertical sum of e3w) +! !> +! !> @details +! !> +! !> @author J.Paul +! !> @date September, 2015 - rewrite from zgr_zps +! !> +! !> @param[in] jpi +! !> @param[in] jpj +! !> @param[in] jpk +! !> @param[in] td_risfdep +! !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! INTEGER(i4), INTENT(IN ) :: jpi +! INTEGER(i4), INTENT(IN ) :: jpj +! INTEGER(i4), INTENT(IN ) :: jpk +! TYPE(TVAR) , INTENT(INOUT) :: td_risfdep +! +! ! local variable +! INTEGER(i4) :: ik +! +! ! loop indices +! INTEGER(i4) :: ji +! INTEGER(i4) :: jj +! INTEGER(i4) :: jk +! !---------------------------------------------------------------- +! +! WHERE( tg_misfdep%d_value(:,:,:,:) == 0 ) tg_misfdep%d_value(:,:,:,:) = 1 +! +! DO jj = 1,jpj +! DO ji = 1,jpi +! +! tg_gdep3w_0%d_value(ji,jj,1,1) = 0.5_dp * tg_e3w_0%d_value(ji,jj,1,1) +! DO jk = 2, INT(tg_misfdep%d_value(ji,jj,1,1),i4) +! tg_gdep3w_0%d_value(ji,jj,jk,1) = tg_gdep3w_0%d_value(ji,jj,jk-1,1) + & +! & tg_e3w_0%d_value (ji,jj,jk ,1) +! END DO +! +! ik=tg_misfdep%d_value(ji,jj,1,1) +! IF( ik >= 2 )THEN +! tg_gdep3w_0%d_value(ji,jj,ik,1) = td_risfdep%d_value(ji,jj, 1,1) + & +! & 0.5_dp * tg_e3w_0%d_value(ji,jj,ik,1) +! ENDIF +! +! DO jk = ik + 1, jpk +! tg_gdep3w_0%d_value(ji,jj,jk,1) = tg_gdep3w_0%d_value(ji,jj,jk-1,1) + & +! & tg_e3w_0%d_value (ji,jj,jk ,1) +! END DO +! +! END DO +! END DO +! +! END SUBROUTINE grid_zgr__isf_fill_gdep3w_0 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_sco_init(jpi, jpj) + !------------------------------------------------------------------- + !> @brief This subroutine initialise global variable needed to compute vertical + !> mesh + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !> @param[in] jpi + !> @param[in] jpj + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), INTENT(IN) :: jpi + INTEGER(i4), INTENT(IN) :: jpj + + ! local variable + REAL(dp), DIMENSION(jpi,jpj) :: dl_tmp + + ! loop indices + !---------------------------------------------------------------- + + dl_tmp(:,:)=dp_fill + + tg_rx1 =var_init('rx1 ',dl_tmp(:,:), dd_fill=dp_fill, id_type=NF90_DOUBLE) + + END SUBROUTINE grid_zgr_sco_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_sco_clean() + !------------------------------------------------------------------- + !> @brief This subroutine clean structure + !> + !> @author J.Paul + !> @date September, 2015 - Initial version + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + ! local variable + ! loop indices + !---------------------------------------------------------------- + + CALL var_clean(tg_rx1 ) + + END SUBROUTINE grid_zgr_sco_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__sco_fill(td_nam, jpi, jpj, jpk, td_bathy) + !------------------------------------------------------------------- + !> @brief This subroutine define the s-coordinate system + !> + !> @details + !> + !> ** Method : s-coordinate + !> The depth of model levels is defined as the product of an + !> analytical function by the local bathymetry, while the vertical + !> scale factors are defined as the product of the first derivative + !> of the analytical function by the bathymetry. + !> (this solution save memory as depth and scale factors are not + !> 3d fields) + !> - Read bathymetry (in meters) at t-point and compute the + !> bathymetry at u-, v-, and f-points. + !> - hbatu = mi( hbatt ) + !> - hbatv = mj( hbatt ) + !> - hbatf = mi( mj( hbatt ) ) + !> - Compute z_gsigt, z_gsigw, z_esigt, z_esigw from an analytical + !> function and its derivative given as function. + !> - z_gsigt(k) = fssig (k ) + !> - z_gsigw(k) = fssig (k-0.5) + !> - z_esigt(k) = fsdsig(k ) + !> - z_esigw(k) = fsdsig(k-0.5) + !> Three options for stretching are give, and they can be modified + !> following the users requirements. Nevertheless, the output as + !> well as the way to compute the model levels and scale factors + !> must be respected in order to insure second order accuracy + !> schemes. + !> + !> The three methods for stretching available are: + !> + !> s_sh94 (Song and Haidvogel 1994) + !> a sinh/tanh function that allows sigma and stretched sigma + !> + !> s_sf12 (Siddorn and Furner 2012?) + !> allows the maintenance of fixed surface and or + !> bottom cell resolutions (cf. geopotential coordinates) + !> within an analytically derived stretched S-coordinate framework. + !> + !> s_tanh (Madec et al 1996) + !> a cosh/tanh function that gives stretched coordinates + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from zgr_sco + !> @date October, 2016 + !> - add wetting and drying boolean + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + TYPE(TVAR) , INTENT(INOUT) :: td_bathy + + ! local variable + INTEGER :: iip1, ijp1, iim1, ijm1 ! temporary integers + + REAL(dp) :: zrmax, zrfact + REAL(dp) :: ztaper + + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hifv !< interface depth between stretching at v--f + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hiff + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hift !< and quasi-uniform spacing t--u points (m) + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hifu + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_scosrf !< ocean surface topography + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_scobot !< ocean bottom topography + +! REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hbatt +! REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hbatu +! REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hbatv +! REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_hbatf + + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zenv + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zri + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zrj + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zhbat + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmpi1 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmpi2 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmpj1 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmpj2 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + CALL logger_info('GRID ZGR SCO: s-coordinate or hybrid z-s-coordinate') + CALL logger_info('~~~~~~~~~~~') + CALL logger_info(' Namelist namzgr_sco') + CALL logger_info(' stretching coeffs ') + CALL logger_info(' maximum depth of s-bottom surface (>0) dn_sbot_max = '//TRIM(fct_str(td_nam%d_sbot_max))) + CALL logger_info(' minimum depth of s-bottom surface (>0) dn_sbot_min = '//TRIM(fct_str(td_nam%d_sbot_min))) + CALL logger_info(' Critical depth dn_hc = '//TRIM(fct_str(td_nam%d_hc))) + CALL logger_info(' maximum cut-off r-value allowed dn_rmax = '//TRIM(fct_str(td_nam%d_rmax))) + CALL logger_info(' Song and Haidvogel 1994 stretching ln_s_sh94 = '//TRIM(fct_str(td_nam%l_s_sh94))) + CALL logger_info(' Song and Haidvogel 1994 stretching coefficients') + CALL logger_info(' surface control parameter (0<=rn_theta<=20) dn_theta = '//TRIM(fct_str(td_nam%d_theta))) + CALL logger_info(' bottom control parameter (0<=rn_thetb<= 1) dn_thetb = '//TRIM(fct_str(td_nam%d_thetb))) + CALL logger_info(' stretching parameter (song and haidvogel) dn_bb = '//TRIM(fct_str(td_nam%d_bb))) + CALL logger_info(' Siddorn and Furner 2012 stretching ln_s_sf12 = '//TRIM(fct_str(td_nam%l_s_sf12))) + CALL logger_info(' switching to sigma (T) or Z (F) at H<Hc ln_sigcrit = '//TRIM(fct_str(td_nam%l_sigcrit))) + CALL logger_info(' Siddorn and Furner 2012 stretching coefficients') + CALL logger_info(' stretchin parameter ( >1 surface; <1 bottom) dn_alpha = '//TRIM(fct_str(td_nam%d_alpha))) + CALL logger_info(' e-fold length scale for transition region dn_efold = '//TRIM(fct_str(td_nam%d_efold))) + CALL logger_info(' Surface cell depth (Zs) (m) dn_zs = '//TRIM(fct_str(td_nam%d_zs))) + CALL logger_info(' Bathymetry multiplier for Zb dn_zb_a = '//TRIM(fct_str(td_nam%d_zb_a))) + CALL logger_info(' Offset for Zb dn_zb_b = '//TRIM(fct_str(td_nam%d_zb_b))) + CALL logger_info(' Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b') + + ALLOCATE(dl_hifv(jpi,jpj)) + ALLOCATE(dl_hiff(jpi,jpj)) + ALLOCATE(dl_hift(jpi,jpj)) + ALLOCATE(dl_hifu(jpi,jpj)) + + ! set the minimum depth for the s-coordinate + dl_hift(:,:) = td_nam%d_sbot_min + dl_hifu(:,:) = td_nam%d_sbot_min + dl_hifv(:,:) = td_nam%d_sbot_min + dl_hiff(:,:) = td_nam%d_sbot_min + + ! set maximum ocean depth + td_bathy%d_value(:,:,1,1) = MIN( td_nam%d_sbot_max, td_bathy%d_value(:,:,1,1) ) + IF( .NOT. td_nam%l_wd )THEN + DO jj = 1, jpj + DO ji = 1, jpi + IF( td_bathy%d_value(ji,jj,1,1) > 0._dp )THEN + td_bathy%d_value(ji,jj,1,1) = MAX(td_nam%d_sbot_min, td_bathy%d_value(ji,jj,1,1)) + ENDIF + END DO + END DO + ENDIF + + ! ============================= + ! Define the envelop bathymetry (hbatt) + ! ============================= + ! use r-value to create hybrid coordinates + ALLOCATE(zenv(jpi,jpj)) + zenv(:,:) = td_bathy%d_value(:,:,1,1) + + IF( .NOT. td_nam%l_wd )THEN + ! set first land point adjacent to a wet cell to sbot_min as this needs to be included in smoothing + DO jj = 1, jpj + DO ji = 1, jpi + IF( td_bathy%d_value(ji,jj,1,1) == 0._dp )THEN + iip1 = MIN( ji+1, jpi ) + ijp1 = MIN( jj+1, jpj ) + iim1 = MAX( ji-1, 1 ) + ijm1 = MAX( jj-1, 1 ) + IF( ( td_bathy%d_value(iim1,ijm1,1,1) + & + & td_bathy%d_value(ji ,ijp1,1,1) + & + & td_bathy%d_value(iip1,ijp1,1,1) + & + & td_bathy%d_value(iim1,jj ,1,1) + & + & td_bathy%d_value(iip1,jj ,1,1) + & + & td_bathy%d_value(iim1,ijm1,1,1) + & + & td_bathy%d_value(ji ,ijm1,1,1) + & + & td_bathy%d_value(iip1,ijp1,1,1) ) > 0._dp )THEN + zenv(ji,jj) = td_nam%d_sbot_min + ENDIF + ENDIF + END DO + END DO + ENDIF + + ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero + ! this is only in mpp case, so here just do nothing + !! CALL lbc_lnk( zenv(:,:), 'T', td_nam%i_perio, 1._dp, 'no0' ) + + ! smooth the bathymetry (if required) + ALLOCATE(dl_scosrf(jpi,jpj)) + ALLOCATE(dl_scobot(jpi,jpj)) + dl_scosrf(:,:) = 0._dp ! ocean surface depth (here zero: no under ice-shelf sea) + dl_scobot(:,:) = td_bathy%d_value(:,:,1,1) ! ocean bottom depth + + jl = 0 + zrmax = 1._dp + + ! set scaling factor used in reducing vertical gradients + zrfact = ( 1._dp - td_nam%d_rmax ) / ( 1._dp + td_nam%d_rmax ) + + ! initialise temporary envelope depth arrays + ALLOCATE(ztmpi1(jpi,jpj)) + ALLOCATE(ztmpi2(jpi,jpj)) + ALLOCATE(ztmpj1(jpi,jpj)) + ALLOCATE(ztmpj2(jpi,jpj)) + + ztmpi1(:,:) = zenv(:,:) + ztmpi2(:,:) = zenv(:,:) + ztmpj1(:,:) = zenv(:,:) + ztmpj2(:,:) = zenv(:,:) + + ! initialise temporary r-value arrays + ALLOCATE(zri(jpi,jpj)) + ALLOCATE(zrj(jpi,jpj)) + zri(:,:) = 1._dp + zrj(:,:) = 1._dp + + ! Iterative loop ! + ! ================ ! + DO WHILE( jl <= 10000 .AND. ( zrmax - td_nam%d_rmax ) > 1.e-8_dp ) + + jl = jl + 1 + zrmax = 0._dp + ! we set zrmax from previous r-values (zri and zrj) first + ! if set after current r-value calculation (as previously) + ! we could exit DO WHILE prematurely before checking r-value + ! of current zenv + DO jj = 1, jpj + DO ji = 1, jpi + zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) + END DO + END DO + zri(:,:) = 0._dp + zrj(:,:) = 0._dp + DO jj = 1, jpj + DO ji = 1, jpi + iip1 = MIN( ji+1, jpi ) ! force zri = 0 on last line (ji=ncli+1 to jpi) + ijp1 = MIN( jj+1, jpj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) + IF( (zenv(ji ,jj) > 0._dp) .AND. & + & (zenv(iip1,jj) > 0._dp) )THEN + zri(ji,jj) = ( zenv(iip1, jj) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) + END IF + IF( (zenv(ji,jj ) > 0._dp) .AND. & + & (zenv(ji,ijp1) > 0._dp) )THEN + zrj(ji,jj) = ( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) + END IF + IF( zri(ji,jj) > td_nam%d_rmax ) ztmpi1(ji ,jj ) = zenv(iip1,jj ) * zrfact + IF( zri(ji,jj) < -td_nam%d_rmax ) ztmpi2(iip1,jj ) = zenv(ji ,jj ) * zrfact + IF( zrj(ji,jj) > td_nam%d_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact + IF( zrj(ji,jj) < -td_nam%d_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact + END DO + END DO + !! + ! + CALL logger_info('zgr_sco : iter= '//TRIM(fct_str(jl))//& + & ' rmax= '//TRIM(fct_str(zrmax)) ) + ! + DO jj = 1, jpj + DO ji = 1, jpi + zenv(ji,jj) = MAX( zenv (ji,jj), & + & ztmpi1(ji,jj), & + & ztmpi2(ji,jj), & + & ztmpj1(ji,jj), & + & ztmpj2(ji,jj) ) + END DO + END DO + ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero + ! this is only in mpp case, so here just do nothing + !!CALL lbc_lnk( zenv, 'T', td_nam%i_perio, 1._dp, 'no0' ) + ENDDO + ! End loop ! + ! ================ ! + + DEALLOCATE(zri) + DEALLOCATE(zrj) + + DEALLOCATE(ztmpi1) + DEALLOCATE(ztmpi2) + DEALLOCATE(ztmpj1) + DEALLOCATE(ztmpj2) + + DO jj = 1, jpj + DO ji = 1, jpi + ! set all points to avoid undefined scale value warnings + zenv(ji,jj) = MAX( zenv(ji,jj), td_nam%d_sbot_min ) + ENDDO + ENDDO + ! + ! Envelope bathymetry saved in hbatt + ! +! ALLOCATE(dl_hbatt(jpi,jpj)) +! ALLOCATE(dl_hbatu(jpi,jpj)) +! ALLOCATE(dl_hbatv(jpi,jpj)) +! ALLOCATE(dl_hbatf(jpi,jpj)) + + tg_hbatt%d_value(:,:,1,1) = zenv(:,:) + IF( MINVAL( tg_gphit%d_value(:,:,1,1) ) * & + & MAXVAL( tg_gphit%d_value(:,:,1,1) ) <= 0._dp ) THEN + CALL logger_warn( ' s-coordinates are tapered in vicinity of the Equator' ) + DO jj = 1, jpj + DO ji = 1, jpi + ztaper = EXP( -(tg_gphit%d_value(ji,jj,1,1)/8._dp)**2._dp ) + tg_hbatt%d_value(ji,jj,1,1) = td_nam%d_sbot_max * ztaper & + & + tg_hbatt%d_value(ji,jj,1,1) * (1._dp - ztaper) + END DO + END DO + ENDIF + + DEALLOCATE(zenv) + + CALL logger_info(' bathy MAX '//TRIM(fct_str(MAXVAL( td_bathy%d_value(:,:,1,1) )))//& + & ' MIN '//TRIM(fct_str(MINVAL( td_bathy%d_value(:,:,1,1) ))) ) + CALL logger_info(' hbatt MAX '//TRIM(fct_str(MAXVAL( tg_hbatt%d_value(:,:,1,1) )))//& + & ' MIN '//TRIM(fct_str(MINVAL( tg_hbatt%d_value(:,:,1,1) ))) ) + ! + ! hbatu, hbatv, hbatf fields + ! + tg_hbatu%d_value(:,:,1,1) = td_nam%d_sbot_min + tg_hbatv%d_value(:,:,1,1) = td_nam%d_sbot_min + tg_hbatf%d_value(:,:,1,1) = td_nam%d_sbot_min + + DO jj = 1, jpj-1 + DO ji = 1, jpi-1 ! NO vector opt. + tg_hbatu%d_value(ji,jj,1,1) = 0.50_dp * ( tg_hbatt%d_value(ji ,jj ,1,1) + & + & tg_hbatt%d_value(ji+1,jj ,1,1) ) + tg_hbatv%d_value(ji,jj,1,1) = 0.50_dp * ( tg_hbatt%d_value(ji ,jj ,1,1) + & + & tg_hbatt%d_value(ji ,jj+1,1,1) ) + tg_hbatf%d_value(ji,jj,1,1) = 0.25_dp * ( tg_hbatt%d_value(ji ,jj ,1,1) + & + & tg_hbatt%d_value(ji ,jj+1,1,1) + & + & tg_hbatt%d_value(ji+1,jj ,1,1) + & + & tg_hbatt%d_value(ji+1,jj+1,1,1) ) + ENDDO + ENDDO + + IF( td_nam%l_wd ) THEN !avoid the zero depth on T- (U-,V-,F-) points + DO jj = 1, jpj + DO ji = 1, jpi + IF( ABS(tg_hbatt%d_value(ji,jj,1,1)) < td_nam%d_wdmin1 )THEN + tg_hbatt%d_value(ji,jj,1,1) = SIGN(1._dp, tg_hbatt%d_value(ji,jj,1,1)) * td_nam%d_wdmin1 + ENDIF + IF( ABS(tg_hbatu%d_value(ji,jj,1,1)) < td_nam%d_wdmin1 )THEN + tg_hbatu%d_value(ji,jj,1,1) = SIGN(1._dp, tg_hbatu%d_value(ji,jj,1,1)) * td_nam%d_wdmin1 + ENDIF + IF( ABS(tg_hbatv%d_value(ji,jj,1,1)) < td_nam%d_wdmin1 )THEN + tg_hbatv%d_value(ji,jj,1,1) = SIGN(1._dp, tg_hbatv%d_value(ji,jj,1,1)) * td_nam%d_wdmin1 + ENDIF + IF( ABS(tg_hbatf%d_value(ji,jj,1,1)) < td_nam%d_wdmin1 )THEN + tg_hbatf%d_value(ji,jj,1,1) = SIGN(1._dp, tg_hbatf%d_value(ji,jj,1,1)) * td_nam%d_wdmin1 + ENDIF + END DO + END DO + ENDIF + + ! Apply lateral boundary condition + ALLOCATE(zhbat(jpi,jpj)) + +!!gm ! CAUTION: retain non zero value in the initial file this should be OK for orca cfg, not for EEL + zhbat(:,:) = tg_hbatu%d_value(:,:,1,1) + CALL lbc_lnk( tg_hbatu%d_value(:,:,1,1), 'U', td_nam%i_perio, 1._dp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_hbatu%d_value(ji,jj,1,1) == 0._dp )THEN + !No worries about the following line when l_wd == .true. + IF( zhbat(ji,jj) == 0._dp ) tg_hbatu%d_value(ji,jj,1,1) = td_nam%d_sbot_min + IF( zhbat(ji,jj) /= 0._dp ) tg_hbatu%d_value(ji,jj,1,1) = zhbat(ji,jj) + ENDIF + ENDDO + ENDDO + + zhbat(:,:) = tg_hbatv%d_value(:,:,1,1) + CALL lbc_lnk( tg_hbatv%d_value(:,:,1,1), 'V', td_nam%i_perio, 1._dp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_hbatv%d_value(ji,jj,1,1) == 0._dp ) THEN + IF( zhbat(ji,jj) == 0._dp ) tg_hbatv%d_value(ji,jj,1,1) = td_nam%d_sbot_min + IF( zhbat(ji,jj) /= 0._dp ) tg_hbatv%d_value(ji,jj,1,1) = zhbat(ji,jj) + ENDIF + ENDDO + ENDDO + + zhbat(:,:) = tg_hbatf%d_value(:,:,1,1) + CALL lbc_lnk( tg_hbatf%d_value(:,:,1,1), 'F', td_nam%i_perio, 1._dp ) + DO jj = 1, jpj + DO ji = 1, jpi + IF( tg_hbatf%d_value(ji,jj,1,1) == 0._dp ) THEN + IF( zhbat(ji,jj) == 0._dp ) tg_hbatf%d_value(ji,jj,1,1) = td_nam%d_sbot_min + IF( zhbat(ji,jj) /= 0._dp ) tg_hbatf%d_value(ji,jj,1,1) = zhbat(ji,jj) + ENDIF + ENDDO + ENDDO + + DEALLOCATE(zhbat) + +!!bug: key_helsinki a verifer + IF( .NOT.td_nam%l_wd )THEN + dl_hift(:,:) = MIN( dl_hift(:,:), tg_hbatt%d_value(:,:,1,1) ) + dl_hifu(:,:) = MIN( dl_hifu(:,:), tg_hbatu%d_value(:,:,1,1) ) + dl_hifv(:,:) = MIN( dl_hifv(:,:), tg_hbatv%d_value(:,:,1,1) ) + dl_hiff(:,:) = MIN( dl_hiff(:,:), tg_hbatf%d_value(:,:,1,1) ) + ENDIF + + CALL logger_info(' MAX val hif t '//TRIM(fct_str(MAXVAL( dl_hift(:,:) )))//& + & ' f '//TRIM(fct_str(MAXVAL( dl_hiff(:,:) )))//& + & ' u '//TRIM(fct_str(MAXVAL( dl_hifu(:,:) )))//& + & ' v '//TRIM(fct_str(MAXVAL( dl_hifv(:,:) ))) ) + CALL logger_info(' MIN val hif t '//TRIM(fct_str(MINVAL( dl_hift(:,:) )))//& + & ' f '//TRIM(fct_str(MINVAL( dl_hiff(:,:) )))//& + & ' u '//TRIM(fct_str(MINVAL( dl_hifu(:,:) )))//& + & ' v '//TRIM(fct_str(MINVAL( dl_hifv(:,:) ))) ) + CALL logger_info(' MAX val hbat t '//TRIM(fct_str(MAXVAL( tg_hbatt%d_value(:,:,1,1) )))//& + & ' f '//TRIM(fct_str(MAXVAL( tg_hbatf%d_value(:,:,1,1) )))//& + & ' u '//TRIM(fct_str(MAXVAL( tg_hbatu%d_value(:,:,1,1) )))//& + & ' v '//TRIM(fct_str(MAXVAL( tg_hbatv%d_value(:,:,1,1) ))) ) + CALL logger_info(' MIN val hbat t '//TRIM(fct_str(MINVAL( tg_hbatt%d_value(:,:,1,1) )))//& + & ' f '//TRIM(fct_str(MINVAL( tg_hbatf%d_value(:,:,1,1) )))//& + & ' u '//TRIM(fct_str(MINVAL( tg_hbatu%d_value(:,:,1,1) )))//& + & ' v '//TRIM(fct_str(MINVAL( tg_hbatv%d_value(:,:,1,1) ))) ) +!! helsinki + + ! ======================= + ! s-ccordinate fields (gdep., e3.) + ! ======================= + ! + ! non-dimensional "sigma" for model level depth at w- and t-levels + +!======================================================================== +! Song and Haidvogel 1994 (ln_s_sh94=T) +! Siddorn and Furner 2012 (ln_sf12=T) +! or tanh function (both false) +!======================================================================== + IF( td_nam%l_s_sh94 ) THEN + CALL grid_zgr__sco_s_sh94( td_nam,jpi,jpj,jpk, & + & dl_scosrf ) + ELSEIF( td_nam%l_s_sf12 ) THEN + CALL grid_zgr__sco_s_sf12( td_nam,jpi,jpj,jpk, & + & dl_scosrf ) + ELSE + CALL grid_zgr__sco_s_tanh( td_nam,jpi,jpj,jpk, & + & dl_scosrf, & + & dl_hift, dl_hifu, dl_hifv, dl_hiff ) + ENDIF + + DEALLOCATE(dl_scosrf) + + DEALLOCATE(dl_hifv) + DEALLOCATE(dl_hiff) + DEALLOCATE(dl_hift) + DEALLOCATE(dl_hifu) + + CALL lbc_lnk( tg_e3t_0%d_value(:,:,:,1) , 'T', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3u_0%d_value(:,:,:,1) , 'U', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3v_0%d_value(:,:,:,1) , 'V', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3f_0%d_value(:,:,:,1) , 'F', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3w_0%d_value(:,:,:,1) , 'W', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3uw_0%d_value(:,:,:,1), 'U', td_nam%i_perio, 1._dp ) + CALL lbc_lnk( tg_e3vw_0%d_value(:,:,:,1), 'V', td_nam%i_perio, 1._dp ) + + IF( .NOT. td_nam%l_wd ) THEN + WHERE( tg_e3t_0%d_value(:,:,:,1) == 0_dp ) tg_e3t_0%d_value(:,:,:,1) = 1._dp + WHERE( tg_e3u_0%d_value(:,:,:,1) == 0_dp ) tg_e3u_0%d_value(:,:,:,1) = 1._dp + WHERE( tg_e3v_0%d_value(:,:,:,1) == 0_dp ) tg_e3v_0%d_value(:,:,:,1) = 1._dp + WHERE( tg_e3f_0%d_value(:,:,:,1) == 0_dp ) tg_e3f_0%d_value(:,:,:,1) = 1._dp + WHERE( tg_e3w_0%d_value(:,:,:,1) == 0_dp ) tg_e3w_0%d_value(:,:,:,1) = 1._dp + WHERE( tg_e3uw_0%d_value(:,:,:,1)== 0_dp ) tg_e3uw_0%d_value(:,:,:,1)= 1._dp + WHERE( tg_e3vw_0%d_value(:,:,:,1)== 0_dp ) tg_e3vw_0%d_value(:,:,:,1)= 1._dp + ENDIF + + ! HYBRID : + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, jpk-1 + IF( dl_scobot(ji,jj) >= tg_gdept_0%d_value(ji,jj,jk,1) )THEN + tg_mbathy%d_value(ji,jj,1,1) = REAL(MAX( 2, jk ),dp) + ENDIF + END DO + + IF( td_nam%l_wd ) THEN + IF( dl_scobot(ji,jj) <= -(td_nam%d_wdld - td_nam%d_wdmin2) )THEN + + tg_mbathy%d_value(ji,jj,1,1) = 0._dp + + ELSEIF( dl_scobot(ji,jj) <= td_nam%d_wdmin1 )THEN + + tg_mbathy%d_value(ji,jj,1,1) = 2._dp + + ENDIF + ELSE + IF( dl_scobot(ji,jj) == 0._dp )THEN + tg_mbathy%d_value(ji,jj,1,1) = 0._dp + ENDIF + ENDIF + + ENDDO + ENDDO + + DEALLOCATE(dl_scobot) + + CALL logger_info(' MIN val mbathy MIN '//TRIM(fct_str(MINVAL( tg_mbathy%d_value(:,:,1,1) )))//& + & ' MAX '//TRIM(fct_str(MAXVAL( tg_mbathy%d_value(:,:,1,1) ))) ) + CALL logger_info(' MIN val depth t '//TRIM(fct_str(MINVAL( tg_gdept_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MINVAL( tg_gdepw_0%d_value(:,:,:,1) ))) )!//& + !& '3w '//TRIM(fct_str(MINVAL( tg_gdep3w_0%d_value(:,:,:,1)))) ) + + CALL logger_info(' MIN val e3 t '//TRIM(fct_str(MINVAL( tg_e3t_0%d_value(:,:,:,1) )))//& + & ' f '//TRIM(fct_str(MINVAL( tg_e3f_0%d_value(:,:,:,1) )))//& + & ' u '//TRIM(fct_str(MINVAL( tg_e3u_0%d_value(:,:,:,1) )))//& + & ' v '//TRIM(fct_str(MINVAL( tg_e3v_0%d_value(:,:,:,1) )))//& + & ' uw '//TRIM(fct_str(MINVAL( tg_e3uw_0%d_value(:,:,:,1) )))//& + & ' vw '//TRIM(fct_str(MINVAL( tg_e3vw_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MINVAL( tg_e3w_0%d_value(:,:,:,1) ))) ) + + CALL logger_info(' MAX val depth t '//TRIM(fct_str(MAXVAL( tg_gdept_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MAXVAL( tg_gdepw_0%d_value(:,:,:,1) ))) )!//& + !& '3w '//TRIM(fct_str(MAXVAL( tg_gdep3w_0%d_value(:,:,:,1) ))) ) + + CALL logger_info(' MAX val e3 t '//TRIM(fct_str(MAXVAL( tg_e3t_0%d_value(:,:,:,1) )))//& + & ' f '//TRIM(fct_str(MAXVAL( tg_e3f_0%d_value(:,:,:,1) )))//& + & ' u '//TRIM(fct_str(MAXVAL( tg_e3u_0%d_value(:,:,:,1) )))//& + & ' v '//TRIM(fct_str(MAXVAL( tg_e3v_0%d_value(:,:,:,1) )))//& + & ' uw '//TRIM(fct_str(MAXVAL( tg_e3uw_0%d_value(:,:,:,1) )))//& + & ' vw '//TRIM(fct_str(MAXVAL( tg_e3vw_0%d_value(:,:,:,1) )))//& + & ' w '//TRIM(fct_str(MAXVAL( tg_e3w_0%d_value(:,:,:,1) ))) ) + +!================================================================================ +! check the coordinate makes sense +!================================================================================ + DO ji = 1, jpi + DO jj = 1, jpj + + IF( tg_hbatt%d_value(ji,jj,1,1) > 0._dp )THEN + DO jk = 1, INT(tg_mbathy%d_value(ji,jj,1,1),i4) + ! check coordinate is monotonically increasing + IF( tg_e3w_0%d_value(ji,jj,jk,1) <= 0._dp .OR. & + & tg_e3t_0%d_value(ji,jj,jk,1) <= 0._dp )THEN + CALL logger_fatal(' GRID ZGR SCO: e3w or e3t =< 0 at point ('//& + & TRIM(fct_str(ji))//","//& + & TRIM(fct_str(jj))//","//& + & TRIM(fct_str(jk))//")" ) + !WRITE(numout,*) 'e3w',fse3w(ji,jj,:) + !WRITE(numout,*) 'e3t',fse3t(ji,jj,:) + ENDIF + ! and check it has never gone negative + IF( tg_gdepw_0%d_value(ji,jj,jk,1) < 0._dp .OR. & + & tg_gdept_0%d_value(ji,jj,jk,1) < 0._dp ) THEN + CALL logger_fatal('GRId ZGR SCO : gdepw or gdept =< 0 at point ('//& + & TRIM(fct_str(ji))//","//& + & TRIM(fct_str(jj))//","//& + & TRIM(fct_str(jk))//")" ) + !WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) + !WRITE(numout,*) 'gdept',fsdept(ji,jj,:) + ENDIF + ! and check it never exceeds the total depth + IF( tg_gdepw_0%d_value(ji,jj,jk,1) > tg_hbatt%d_value(ji,jj,1,1) ) THEN + CALL logger_fatal('GRID ZGR SCO: gdepw > hbatt at point ('//& + & TRIM(fct_str(ji))//","//& + & TRIM(fct_str(jj))//","//& + & TRIM(fct_str(jk))//")" ) + !WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) + ENDIF + ENDDO + + DO jk = 1, INT(tg_mbathy%d_value(ji,jj,1,1),i4)-1 + ! and check it never exceeds the total depth + IF( tg_gdept_0%d_value(ji,jj,jk,1) > tg_hbatt%d_value(ji,jj,1,1) ) THEN + CALL logger_fatal('GRID ZGR SCO: gdept > hbatt at point ('//& + & TRIM(fct_str(ji))//","//& + & TRIM(fct_str(jj))//","//& + & TRIM(fct_str(jk))//")" ) + !WRITE(numout,*) 'gdept',fsdept(ji,jj,:) + ENDIF + ENDDO + ENDIF + + ENDDO + ENDDO + + END SUBROUTINE grid_zgr__sco_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__sco_s_sh94(td_nam, jpi, jpj, jpk, dd_scosrf) + !------------------------------------------------------------------- + !> @brief This subroutine stretch the s-coordinate system + !> + !> @details + !> ** Method : s-coordinate stretch using the Song and Haidvogel 1994 + !> mixed S/sigma coordinate + !> + !> Reference : Song and Haidvogel 1994. + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> @date October, 2016 + !> - add wetting and drying option + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] dd_scosrf + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_scosrf + + ! local variable + REAL(dp) :: zcoeft + REAL(dp) :: zcoefw + + REAL(dp) :: ztmpu + REAL(dp) :: ztmpv + REAL(dp) :: ztmpf + REAL(dp) :: ztmpu1 + REAL(dp) :: ztmpv1 + REAL(dp) :: ztmpf1 + + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsigw3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsigt3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsi3w3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigt3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigw3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtu3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtv3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtf3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigwu3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigwv3 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ALLOCATE( z_gsigw3(jpi,jpj,jpk)) + ALLOCATE( z_gsigt3(jpi,jpj,jpk)) + ALLOCATE( z_gsi3w3(jpi,jpj,jpk)) + ALLOCATE( z_esigt3(jpi,jpj,jpk)) + ALLOCATE( z_esigw3(jpi,jpj,jpk)) + ALLOCATE( z_esigtu3(jpi,jpj,jpk)) + ALLOCATE( z_esigtv3(jpi,jpj,jpk)) + ALLOCATE( z_esigtf3(jpi,jpj,jpk)) + ALLOCATE( z_esigwu3(jpi,jpj,jpk)) + ALLOCATE( z_esigwv3(jpi,jpj,jpk)) + + z_gsigw3(:,:,:) =0._dp + z_gsigt3(:,:,:) =0._dp + z_gsi3w3(:,:,:) =0._dp + z_esigt3(:,:,:) =0._dp + z_esigw3(:,:,:) =0._dp + + z_esigtu3(:,:,:)=0._dp + z_esigtv3(:,:,:)=0._dp + z_esigtf3(:,:,:)=0._dp + z_esigwu3(:,:,:)=0._dp + z_esigwv3(:,:,:)=0._dp + + DO ji = 1, jpi + DO jj = 1, jpj + + IF( tg_hbatt%d_value(ji,jj,1,1) > td_nam%d_hc ) THEN !deep water, stretched sigma + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = -grid_zgr__sco_fssig1( td_nam, jpk, REAL(jk,dp)-0.5_dp, td_nam%d_bb ) + z_gsigt3(ji,jj,jk) = -grid_zgr__sco_fssig1( td_nam, jpk, REAL(jk,dp) , td_nam%d_bb ) + END DO + ELSE ! shallow water, uniform sigma + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,dp) / REAL(jpk-1,dp) + z_gsigt3(ji,jj,jk) = ( REAL(jk-1,dp) + 0.5_dp ) / REAL(jpk-1,dp) + END DO + ENDIF + + DO jk = 1, jpk-1 + z_esigt3(ji,jj,jk ) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) + z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) + END DO + z_esigw3(ji,jj,1 ) = 2._dp * ( z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 ) ) + z_esigt3(ji,jj,jpk) = 2._dp * ( z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk) ) + + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w3(ji,jj,1) = 0.5_dp * z_esigw3(ji,jj,1) + DO jk = 2, jpk + z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) + END DO + ! + DO jk = 1, jpk + zcoeft = ( REAL(jk,dp) - 0.5_dp ) / REAL(jpk-1,dp) + zcoefw = ( REAL(jk,dp) - 1.0_dp ) / REAL(jpk-1,dp) + tg_gdept_0%d_value(ji,jj,jk,1) = ( dd_scosrf(ji,jj) & + & + (tg_hbatt%d_value(ji,jj,1,1)-td_nam%d_hc)*z_gsigt3(ji,jj,jk) & + & + td_nam%d_hc*zcoeft ) + tg_gdepw_0%d_value(ji,jj,jk,1) = ( dd_scosrf(ji,jj) & + & + (tg_hbatt%d_value(ji,jj,1,1)-td_nam%d_hc)*z_gsigw3(ji,jj,jk) & + & + td_nam%d_hc*zcoefw ) + !tg_gdep3w_0%d_value(ji,jj,jk,1) = ( dd_scosrf(ji,jj) & + ! & + (tg_hbatt%d_value(ji,jj,1,1)-td_nam%d_hc)*z_gsi3w3(ji,jj,jk) & + ! & + td_nam%d_hc*zcoeft ) + END DO + + END DO ! for all jj's + END DO ! for all ji's + + DO ji = 1, jpi-1 + DO jj = 1, jpj-1 + ! extended for Wetting/Drying case + ztmpu = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji+1,jj ,1,1) + ztmpv = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji ,jj+1,1,1) + ztmpf = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji+1,jj ,1,1) + & + & tg_hbatt%d_value(ji ,jj+1,1,1) + tg_hbatt%d_value(ji+1,jj+1,1,1) + + ztmpu1 = tg_hbatt%d_value(ji ,jj ,1,1) * tg_hbatt%d_value(ji+1,jj ,1,1) + ztmpv1 = tg_hbatt%d_value(ji ,jj ,1,1) * tg_hbatt%d_value(ji ,jj+1,1,1) + ztmpf1 = MIN(tg_hbatt%d_value(ji ,jj ,1,1), tg_hbatt%d_value(ji+1,jj ,1,1), & + & tg_hbatt%d_value(ji ,jj+1,1,1), tg_hbatt%d_value(ji+1,jj+1,1,1)) & + & * MAX(tg_hbatt%d_value(ji ,jj ,1,1), tg_hbatt%d_value(ji+1,jj ,1,1), & + & tg_hbatt%d_value(ji ,jj+1,1,1), tg_hbatt%d_value(ji+1,jj+1,1,1)) + + DO jk = 1, jpk + + IF( td_nam%l_wd .AND. & + & ( ztmpu1 < 0._dp .OR. ABS(ztmpu) < td_nam%d_wdmin1 ) )THEN + z_esigtu3(ji,jj,jk) = 0.5_dp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji+1,jj,jk) ) + z_esigwu3(ji,jj,jk) = 0.5_dp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji+1,jj,jk) ) + ELSE + z_esigtu3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj,1,1)*z_esigt3(ji ,jj,jk) & + & + tg_hbatt%d_value(ji+1,jj,1,1)*z_esigt3(ji+1,jj,jk) ) / ztmpu + z_esigwu3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj,1,1)*z_esigw3(ji ,jj,jk) & + & + tg_hbatt%d_value(ji+1,jj,1,1)*z_esigw3(ji+1,jj,jk)) / ztmpu + ENDIF + + IF( td_nam%l_wd .AND. & + & ( ztmpv1 < 0._dp .OR. ABS(ztmpv) < td_nam%d_wdmin1 ) )THEN + z_esigtv3(ji,jj,jk) = 0.5_dp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji,jj+1,jk) ) + z_esigwv3(ji,jj,jk) = 0.5_dp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji,jj+1,jk) ) + ELSE + z_esigtv3(ji,jj,jk) = ( tg_hbatt%d_value(ji,jj ,1,1)*z_esigt3(ji,jj ,jk) & + & + tg_hbatt%d_value(ji,jj+1,1,1)*z_esigt3(ji,jj+1,jk)) / ztmpv + z_esigwv3(ji,jj,jk) = ( tg_hbatt%d_value(ji,jj ,1,1)*z_esigw3(ji,jj ,jk) & + & + tg_hbatt%d_value(ji,jj+1,1,1)*z_esigw3(ji,jj+1,jk)) / ztmpv + ENDIF + + IF( td_nam%l_wd .AND. & + & ( ztmpf1 < 0._dp .OR. ABS(ztmpf) < td_nam%d_wdmin1 ) )THEN + z_esigtf3(ji,jj,jk) = 0.25_dp * ( z_esigt3(ji ,jj ,jk) & + & + z_esigt3(ji+1,jj ,jk) & + & + z_esigt3(ji ,jj+1,jk) & + & + z_esigt3(ji+1,jj+1,jk) ) + ELSE + z_esigtf3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj ,1,1)*z_esigt3(ji ,jj ,jk) & + & + tg_hbatt%d_value(ji+1,jj ,1,1)*z_esigt3(ji+1,jj ,jk) & + & + tg_hbatt%d_value(ji ,jj+1,1,1)*z_esigt3(ji ,jj+1,jk) & + & + tg_hbatt%d_value(ji+1,jj+1,1,1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf + ENDIF + ! + tg_e3t_0%d_value(ji,jj,jk,1) = ( ( tg_hbatt%d_value(ji,jj,1,1) - td_nam%d_hc )*z_esigt3 (ji,jj,jk) & + & + td_nam%d_hc / REAL(jpk-1,dp) ) + tg_e3u_0%d_value(ji,jj,jk,1) = ( ( tg_hbatu%d_value(ji,jj,1,1) - td_nam%d_hc )*z_esigtu3(ji,jj,jk) & + & + td_nam%d_hc / REAL(jpk-1,dp) ) + tg_e3v_0%d_value(ji,jj,jk,1) = ( ( tg_hbatv%d_value(ji,jj,1,1) - td_nam%d_hc )*z_esigtv3(ji,jj,jk) & + & + td_nam%d_hc / REAL(jpk-1,dp) ) + tg_e3f_0%d_value(ji,jj,jk,1) = ( ( tg_hbatf%d_value(ji,jj,1,1) - td_nam%d_hc ) *z_esigtf3(ji,jj,jk) & + & + td_nam%d_hc/REAL(jpk-1,dp) ) + + tg_e3w_0%d_value (ji,jj,jk,1)= ( ( tg_hbatt%d_value(ji,jj,1,1) - td_nam%d_hc )*z_esigw3 (ji,jj,jk) & + & + td_nam%d_hc / REAL(jpk-1,dp) ) + tg_e3uw_0%d_value(ji,jj,jk,1)= ( ( tg_hbatu%d_value(ji,jj,1,1) - td_nam%d_hc)*z_esigwu3(ji,jj,jk) & + & + td_nam%d_hc/REAL(jpk-1,dp) ) + tg_e3vw_0%d_value(ji,jj,jk,1)= ( ( tg_hbatv%d_value(ji,jj,1,1) - td_nam%d_hc)*z_esigwv3(ji,jj,jk) & + & + td_nam%d_hc/REAL(jpk-1,dp) ) + END DO + END DO + END DO + + DEALLOCATE( z_gsigw3 ) + DEALLOCATE( z_gsigt3 ) + DEALLOCATE( z_gsi3w3 ) + DEALLOCATE( z_esigt3 ) + DEALLOCATE( z_esigw3 ) + DEALLOCATE( z_esigtu3 ) + DEALLOCATE( z_esigtv3 ) + DEALLOCATE( z_esigtf3 ) + DEALLOCATE( z_esigwu3 ) + DEALLOCATE( z_esigwv3 ) + + END SUBROUTINE grid_zgr__sco_s_sh94 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__sco_s_sf12(td_nam, jpi, jpj, jpk, dd_scosrf) + !------------------------------------------------------------------- + !> @brief This subroutine stretch the s-coordinate system + !> + !> ** Method : s-coordinate stretch using the Siddorn and Furner 2012? + !> mixed S/sigma/Z coordinate + !> + !> This method allows the maintenance of fixed surface and or + !> bottom cell resolutions (cf. geopotential coordinates) + !> within an analytically derived stretched S-coordinate framework. + !> + !> + !> Reference : Siddorn and Furner 2012 (submitted Ocean modelling). + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> @date October, 2016 + !> - add wetting and drying option + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] dd_scosrf + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_scosrf + + ! local variable + REAL(dp) :: zsmth ! smoothing around critical depth + REAL(dp) :: zzs, zzb ! Surface and bottom cell thickness in sigma space + + REAL(dp) :: ztmpu + REAL(dp) :: ztmpv + REAL(dp) :: ztmpf + REAL(dp) :: ztmpu1 + REAL(dp) :: ztmpv1 + REAL(dp) :: ztmpf1 + + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsigw3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsigt3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_gsi3w3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigt3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigw3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtu3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtv3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigtf3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigwu3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z_esigwv3 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + ALLOCATE( z_gsigw3(jpi,jpj,jpk)) + ALLOCATE( z_gsigt3(jpi,jpj,jpk)) + ALLOCATE( z_gsi3w3(jpi,jpj,jpk)) + ALLOCATE( z_esigt3(jpi,jpj,jpk)) + ALLOCATE( z_esigw3(jpi,jpj,jpk)) + ALLOCATE( z_esigtu3(jpi,jpj,jpk)) + ALLOCATE( z_esigtv3(jpi,jpj,jpk)) + ALLOCATE( z_esigtf3(jpi,jpj,jpk)) + ALLOCATE( z_esigwu3(jpi,jpj,jpk)) + ALLOCATE( z_esigwv3(jpi,jpj,jpk)) + + z_gsigw3(:,:,:) =0._dp + z_gsigt3(:,:,:) =0._dp + z_gsi3w3(:,:,:) =0._dp + z_esigt3(:,:,:) =0._dp + z_esigw3(:,:,:) =0._dp + z_esigtu3(:,:,:)=0._dp + z_esigtv3(:,:,:)=0._dp + z_esigtf3(:,:,:)=0._dp + z_esigwu3(:,:,:)=0._dp + z_esigwv3(:,:,:)=0._dp + + DO ji = 1, jpi + DO jj = 1, jpj + + IF( tg_hbatt%d_value(ji,jj,1,1) > td_nam%d_hc )THEN !deep water, stretched sigma + + ! this forces a linear bottom cell depth relationship with H,. + ! could be changed by users but care must be taken to do so carefully + zzb = tg_hbatt%d_value(ji,jj,1,1)*td_nam%d_zb_a + td_nam%d_zb_b + + zzb = 1.0_dp-(zzb/tg_hbatt%d_value(ji,jj,1,1)) + + zzs = td_nam%d_zs / tg_hbatt%d_value(ji,jj,1,1) + + IF( td_nam%d_efold /= 0.0_dp )THEN + zsmth = TANH( (tg_hbatt%d_value(ji,jj,1,1)-td_nam%d_hc ) / td_nam%d_efold ) + ELSE + zsmth = 1.0_dp + ENDIF + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,dp) /REAL(jpk-1,dp) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,dp)+0.5_dp)/REAL(jpk-1,dp) + ENDDO + z_gsigw3(ji,jj,:) = grid_zgr__sco_fgamma( td_nam, jpk, z_gsigw3(ji,jj,:), zzb, zzs, zsmth ) + z_gsigt3(ji,jj,:) = grid_zgr__sco_fgamma( td_nam, jpk, z_gsigt3(ji,jj,:), zzb, zzs, zsmth ) + + ELSE IF( td_nam%l_sigcrit )THEN ! shallow water, uniform sigma + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,dp) /REAL(jpk-1,dp) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,dp)+0.5)/REAL(jpk-1,dp) + END DO + + ELSE ! shallow water, z coordinates + + DO jk = 1, jpk + z_gsigw3(ji,jj,jk) = REAL(jk-1,dp) /REAL(jpk-1,dp)*(td_nam%d_hc/tg_hbatt%d_value(ji,jj,1,1)) + z_gsigt3(ji,jj,jk) = (REAL(jk-1,dp)+0.5_dp)/REAL(jpk-1,dp)*(td_nam%d_hc/tg_hbatt%d_value(ji,jj,1,1)) + END DO + + ENDIF + + DO jk = 1, jpk-1 + z_esigt3(ji,jj,jk ) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) + z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) + END DO + z_esigw3(ji,jj,1 ) = 2.0_dp * (z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 )) + z_esigt3(ji,jj,jpk) = 2.0_dp * (z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk)) + + ! Coefficients for vertical depth as the sum of e3w scale factors + z_gsi3w3(ji,jj,1) = 0.5_dp * z_esigw3(ji,jj,1) + DO jk = 2, jpk + z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) + END DO + + DO jk = 1, jpk + tg_gdept_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatt%d_value(ji,jj,1,1))*z_gsigt3(ji,jj,jk) + tg_gdepw_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatt%d_value(ji,jj,1,1))*z_gsigw3(ji,jj,jk) + !tg_gdep3w_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatt%d_value(ji,jj,1,1))*z_gsi3w3(ji,jj,jk) + END DO + + ENDDO ! for all jj's + ENDDO ! for all ji's + + DO ji=1,jpi-1 + DO jj=1,jpj-1 + + ! extend to suit for Wetting/Drying case + ztmpu = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji+1,jj ,1,1) + ztmpv = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji ,jj+1,1,1) + ztmpf = tg_hbatt%d_value(ji ,jj ,1,1) + tg_hbatt%d_value(ji+1,jj ,1,1) + & + & tg_hbatt%d_value(ji ,jj+1,1,1) + tg_hbatt%d_value(ji+1,jj+1,1,1) + + ztmpu1 = tg_hbatt%d_value(ji ,jj ,1,1) * tg_hbatt%d_value(ji+1,jj ,1,1) + ztmpv1 = tg_hbatt%d_value(ji ,jj ,1,1) * tg_hbatt%d_value(ji ,jj+1,1,1) + ztmpf1 = MIN(tg_hbatt%d_value(ji ,jj ,1,1), tg_hbatt%d_value(ji+1,jj ,1,1), & + & tg_hbatt%d_value(ji ,jj+1,1,1), tg_hbatt%d_value(ji+1,jj+1,1,1)) & + & * MAX(tg_hbatt%d_value(ji ,jj ,1,1), tg_hbatt%d_value(ji+1,jj ,1,1), & + & tg_hbatt%d_value(ji ,jj+1,1,1), tg_hbatt%d_value(ji+1,jj+1,1,1)) + + DO jk = 1, jpk + + IF( td_nam%l_wd .AND. & + & ( ztmpu1 < 0._dp .OR. ABS(ztmpu) < td_nam%d_wdmin1 ) )THEN + z_esigtu3(ji,jj,jk) = 0.5_dp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji+1,jj,jk) ) + z_esigwu3(ji,jj,jk) = 0.5_dp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji+1,jj,jk) ) + ELSE + z_esigtu3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj,1,1)*z_esigt3(ji ,jj,jk) & + & + tg_hbatt%d_value(ji+1,jj,1,1)*z_esigt3(ji+1,jj,jk) ) / ztmpu + z_esigwu3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj,1,1)*z_esigw3(ji ,jj,jk) & + & + tg_hbatt%d_value(ji+1,jj,1,1)*z_esigw3(ji+1,jj,jk) ) / ztmpu + ENDIF + + IF( td_nam%l_wd .AND. & + & ( ztmpv1 < 0._dp .OR. ABS(ztmpv) < td_nam%d_wdmin1 ) )THEN + z_esigtv3(ji,jj,jk) = 0.5_dp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji,jj+1,jk) ) + z_esigwv3(ji,jj,jk) = 0.5_dp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji,jj+1,jk) ) + ELSE + z_esigtv3(ji,jj,jk) = ( tg_hbatt%d_value(ji,jj ,1,1)*z_esigt3(ji,jj ,jk) & + & + tg_hbatt%d_value(ji,jj+1,1,1)*z_esigt3(ji,jj+1,jk)) / ztmpv + z_esigwv3(ji,jj,jk) = ( tg_hbatt%d_value(ji,jj ,1,1)*z_esigw3(ji,jj ,jk) & + & + tg_hbatt%d_value(ji,jj+1,1,1)*z_esigw3(ji,jj+1,jk)) / ztmpv + ENDIF + + IF( td_nam%l_wd .AND. & + & ( ztmpf1 < 0._dp .OR. ABS(ztmpf) < td_nam%d_wdmin1 ) )THEN + z_esigtf3(ji,jj,jk) = 0.25_dp * ( z_esigt3(ji ,jj ,jk) & + & + z_esigt3(ji+1,jj ,jk) & + & + z_esigt3(ji ,jj+1,jk) & + & + z_esigt3(ji+1,jj+1,jk) ) + ELSE + z_esigtf3(ji,jj,jk) = ( tg_hbatt%d_value(ji ,jj ,1,1)*z_esigt3(ji ,jj ,jk) & + & + tg_hbatt%d_value(ji+1,jj ,1,1)*z_esigt3(ji+1,jj ,jk) & + & + tg_hbatt%d_value(ji ,jj+1,1,1)*z_esigt3(ji ,jj+1,jk) & + & + tg_hbatt%d_value(ji+1,jj+1,1,1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf + ENDIF + + tg_e3t_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatt%d_value(ji,jj,1,1))*z_esigt3 (ji,jj,jk) + tg_e3u_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatu%d_value(ji,jj,1,1))*z_esigtu3(ji,jj,jk) + tg_e3v_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatv%d_value(ji,jj,1,1))*z_esigtv3(ji,jj,jk) + tg_e3f_0%d_value(ji,jj,jk,1) = (dd_scosrf(ji,jj)+tg_hbatf%d_value(ji,jj,1,1))*z_esigtf3(ji,jj,jk) + ! + tg_e3w_0%d_value(ji,jj,jk,1) = tg_hbatt%d_value(ji,jj,1,1)*z_esigw3 (ji,jj,jk) + tg_e3uw_0%d_value(ji,jj,jk,1) = tg_hbatu%d_value(ji,jj,1,1)*z_esigwu3(ji,jj,jk) + tg_e3vw_0%d_value(ji,jj,jk,1) = tg_hbatv%d_value(ji,jj,1,1)*z_esigwv3(ji,jj,jk) + END DO + + ENDDO + ENDDO + + CALL lbc_lnk(tg_e3t_0 %d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3u_0 %d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3v_0 %d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3f_0 %d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3w_0 %d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3uw_0%d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + CALL lbc_lnk(tg_e3vw_0%d_value(:,:,:,1),'T', td_nam%i_perio, 1._dp) + + DEALLOCATE( z_gsigw3 ) + DEALLOCATE( z_gsigt3 ) + DEALLOCATE( z_gsi3w3 ) + DEALLOCATE( z_esigt3 ) + DEALLOCATE( z_esigw3 ) + DEALLOCATE( z_esigtu3 ) + DEALLOCATE( z_esigtv3 ) + DEALLOCATE( z_esigtf3 ) + DEALLOCATE( z_esigwu3 ) + DEALLOCATE( z_esigwv3 ) + + END SUBROUTINE grid_zgr__sco_s_sf12 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr__sco_s_tanh(td_nam, jpi, jpj, jpk, & + & dd_scosrf, & + & dd_hift, dd_hifu, dd_hifv, dd_hiff) + !------------------------------------------------------------------- + !> @brief This subroutine stretch the s-coordinate system + !> + !> + !> ** Method : s-coordinate stretch + !> + !> Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !> @param[in] dd_scosrf + !> @param[in] dd_hift + !> @param[in] dd_hifu + !> @param[in] dd_hifv + ! @param[in] dd_hiff + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_scosrf + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_hift + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_hifu + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_hifv + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_hiff + + ! local variable + REAL(dp) :: zcoeft + REAL(dp) :: zcoefw + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + tg_gsigt%d_value(1,1,:,1) =0._dp + tg_gsigw%d_value(1,1,:,1) =0._dp + tg_gsi3w%d_value(1,1,:,1) =0._dp + tg_esigt%d_value(1,1,:,1) =0._dp + tg_esigw%d_value(1,1,:,1) =0._dp + + DO jk = 1, jpk + tg_gsigw%d_value(1,1,jk,1) = -grid_zgr__sco_fssig( td_nam, jpk, REAL(jk,dp)-0.5_dp ) + tg_gsigt%d_value(1,1,jk,1) = -grid_zgr__sco_fssig( td_nam, jpk, REAL(jk,dp) ) + END DO + CALL logger_info('z_gsigw 1 jpk '//TRIM(fct_str(tg_gsigw%d_value(1,1,1,1)))//& + & TRIM(fct_str(tg_gsigw%d_value(1,1,jpk,1))) ) + + ! Coefficients for vertical scale factors at w-, t- levels +!!gm bug : define it from analytical function, not like juste bellow.... +!!gm or betteroffer the 2 possibilities.... + DO jk = 1, jpk-1 + tg_esigt%d_value(1,1,jk ,1) = tg_gsigw%d_value(1,1,jk+1,1) - tg_gsigw%d_value(1,1,jk,1) + tg_esigw%d_value(1,1,jk+1,1) = tg_gsigt%d_value(1,1,jk+1,1) - tg_gsigt%d_value(1,1,jk,1) + END DO + tg_esigw%d_value(1,1, 1 ,1) = 2._dp * ( tg_gsigt%d_value(1,1,1 ,1) - tg_gsigw%d_value(1,1,1 ,1) ) + tg_esigt%d_value(1,1,jpk,1) = 2._dp * ( tg_gsigt%d_value(1,1,jpk,1) - tg_gsigw%d_value(1,1,jpk,1) ) + + ! Coefficients for vertical depth as the sum of e3w scale factors + tg_gsi3w%d_value(1,1,1,1) = 0.5_dp * tg_esigw%d_value(1,1,1,1) + DO jk = 2, jpk + tg_gsi3w%d_value(1,1,jk,1) = tg_gsi3w%d_value(1,1,jk-1,1) + tg_esigw%d_value(1,1,jk,1) + END DO +!!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) + DO jk = 1, jpk + zcoeft = ( REAL(jk,dp) - 0.5_dp ) / REAL(jpk-1,dp) + zcoefw = ( REAL(jk,dp) - 1.0_dp ) / REAL(jpk-1,dp) + tg_gdept_0%d_value (:,:,jk,1) = dd_scosrf(:,:) + ( tg_hbatt%d_value(:,:,1 ,1) - dd_hift(:,:) ) & + & * tg_gsigt%d_value(1,1,jk,1) + dd_hift(:,:)*zcoeft + tg_gdepw_0%d_value (:,:,jk,1) = dd_scosrf(:,:) + ( tg_hbatt%d_value(:,:,1 ,1) - dd_hift(:,:) ) & + & * tg_gsigw%d_value(1,1,jk,1) + dd_hift(:,:)*zcoefw + !tg_gdep3w_0%d_value(:,:,jk,1) = dd_scosrf(:,:) + ( tg_hbatt%d_value(:,:,1 ,1) - dd_hift(:,:)) & + ! * tg_gsi3w%d_value(1,1,jk,1) + dd_hift(:,:)*zcoeft + END DO +!!gm: e3uw, e3vw can be suppressed (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) + DO jj = 1, jpj + DO ji = 1, jpi + DO jk = 1, jpk + tg_e3t_0%d_value(ji,jj,jk,1) = ( (tg_hbatt%d_value(ji,jj,1 ,1) - dd_hift(ji,jj)) & + & * tg_esigt%d_value(1 ,1 ,jk,1) + dd_hift(ji,jj)/REAL(jpk-1,dp) ) + tg_e3u_0%d_value(ji,jj,jk,1) = ( (tg_hbatu%d_value(ji,jj,1 ,1) - dd_hifu(ji,jj)) & + & * tg_esigt%d_value(1 ,1 ,jk,1) + dd_hifu(ji,jj)/REAL(jpk-1,dp) ) + tg_e3v_0%d_value(ji,jj,jk,1) = ( (tg_hbatv%d_value(ji,jj,1 ,1) - dd_hifv(ji,jj)) & + & * tg_esigt%d_value(1 ,1 ,jk,1) + dd_hifv(ji,jj)/REAL(jpk-1,dp) ) + tg_e3f_0%d_value(ji,jj,jk,1) = ( (tg_hbatf%d_value(ji,jj,1 ,1) - dd_hiff(ji,jj)) & + & * tg_esigt%d_value(1 ,1, jk,1) + dd_hiff(ji,jj)/REAL(jpk-1,dp) ) + + tg_e3w_0%d_value (ji,jj,jk,1)= ( (tg_hbatt%d_value(ji,jj,1 ,1) - dd_hift(ji,jj)) & + & * tg_esigw%d_value(1 ,1 ,jk,1) + dd_hift(ji,jj)/REAL(jpk-1,dp) ) + tg_e3uw_0%d_value(ji,jj,jk,1)= ( (tg_hbatu%d_value(ji,jj,1 ,1) - dd_hifu(ji,jj)) & + & * tg_esigw%d_value(1 ,1 ,jk,1) + dd_hifu(ji,jj)/REAL(jpk-1,dp) ) + tg_e3vw_0%d_value(ji,jj,jk,1)= ( (tg_hbatv%d_value(ji,jj,1 ,1) - dd_hifv(ji,jj)) & + & * tg_esigw%d_value(1 ,1 ,jk,1) + dd_hifv(ji,jj)/REAL(jpk-1,dp) ) + END DO + END DO + END DO + + END SUBROUTINE grid_zgr__sco_s_tanh + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_zgr__sco_fssig(td_nam, jpk, pk) & + & RESULT( pf ) + !!---------------------------------------------------------------------- + !> @brief This function provide the analytical function in s-coordinate + !> + !> @details + !> ** Method : the function provide the non-dimensional position of + !> T and W (i.e. between 0 and 1) + !> T-points at integer values (between 1 and jpk) + !> W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> + !> @param[in] td_nam + !> @param[in] jpk + !> @param[in] pk + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , INTENT(IN ) :: pk ! continuous "k" coordinate + REAL(dp) :: pf ! sigma value + !!---------------------------------------------------------------------- + ! + pf = ( TANH( td_nam%d_theta * ( -(pk-0.5_dp) / REAL(jpk-1,dp) + td_nam%d_thetb ) ) & + & - TANH( td_nam%d_thetb * td_nam%d_theta ) ) & + & * ( COSH( td_nam%d_theta ) & + & + COSH( td_nam%d_theta * ( 2._dp * td_nam%d_thetb - 1._dp ) ) ) & + & / ( 2._dp * SINH( td_nam%d_theta ) ) + ! + END FUNCTION grid_zgr__sco_fssig + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_zgr__sco_fssig1(td_nam, jpk, pk1, pbb) & + & RESULT( pf1 ) + !!---------------------------------------------------------------------- + !> @brief This function provide the Song and Haidvogel version of the analytical function in s-coordinate + !> + !> @details + !> ** Method : the function provides the non-dimensional position of + !> T and W (i.e. between 0 and 1) + !> T-points at integer values (between 1 and jpk) + !> W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] pk1 + !> @param[in] pbb + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , INTENT(IN ) :: pk1 ! continuous "k" coordinate + REAL(dp) , INTENT(IN ) :: pbb ! Stretching coefficient + REAL(dp) :: pf1 ! sigma value + !!---------------------------------------------------------------------- + ! + IF ( td_nam%d_theta == 0 ) then ! uniform sigma + pf1 = - ( pk1 - 0.5_dp ) / REAL(jpk-1,dp) + ELSE ! stretched sigma + pf1 = ( 1._dp - pbb ) * ( SINH( td_nam%d_theta*(-(pk1-0.5_dp)/REAL(jpk-1,dp)) ) ) / SINH( td_nam%d_theta ) & + & + pbb * ( (TANH( td_nam%d_theta*( (-(pk1-0.5_dp)/REAL(jpk-1,dp)) + 0.5_dp) ) - TANH( 0.5_dp * td_nam%d_theta ) ) & + & / ( 2._dp * TANH( 0.5_dp * td_nam%d_theta ) ) ) + ENDIF + ! + END FUNCTION grid_zgr__sco_fssig1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION grid_zgr__sco_fgamma(td_nam, jpk, pk1, pzb, pzs, psmth) & + & RESULT( p_gamma ) + !!---------------------------------------------------------------------- + !> @brief This function provide analytical function for the s-coordinate + !> + !> @details + !> ** Method : the function provides the non-dimensional position of + !> T and W (i.e. between 0 and 1) + !> T-points at integer values (between 1 and jpk) + !> W-points at integer values - 1/2 (between 0.5 and jpk-0.5) + !> + !> This method allows the maintenance of fixed surface and or + !> bottom cell resolutions (cf. geopotential coordinates) + !> within an analytically derived stretched S-coordinate framework. + !> + !> Reference : Siddorn and Furner, in prep + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domzgr + !> + !> @param[in] td_nam + !> @param[in] jpk + !> @param[in] pk1 + !> @param[in] pzb + !> @param[in] pzs + !> @param[in] pzsmth + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpk + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: pk1 ! continuous "k" coordinate + + ! function + REAL(dp) , DIMENSION(jpk) :: p_gamma ! stretched coordinate + + ! local variable + REAL(dp) , INTENT(IN ) :: pzb ! Bottom box depth + REAL(dp) , INTENT(IN ) :: pzs ! surface box depth + REAL(dp) , INTENT(IN ) :: psmth ! Smoothing parameter + REAL(dp) :: za1,za2,za3 ! local variables + REAL(dp) :: zn1,zn2 ! local variables + REAL(dp) :: za,zb,zx ! local variables + + ! loop indices + INTEGER(i4) :: jk + !!---------------------------------------------------------------------- + ! + zn1 = 1._dp / REAL(jpk-1,dp) + zn2 = 1._dp - zn1 + + za1 = (td_nam%d_alpha+2.0_dp)*zn1**(td_nam%d_alpha+1.0_dp)-(td_nam%d_alpha+1.0_dp)*zn1**(td_nam%d_alpha+2.0_dp) + za2 = (td_nam%d_alpha+2.0_dp)*zn2**(td_nam%d_alpha+1.0_dp)-(td_nam%d_alpha+1.0_dp)*zn2**(td_nam%d_alpha+2.0_dp) + za3 = (zn2**3.0_dp - za2)/( zn1**3.0_dp - za1) + + za = pzb - za3*(pzs-za1)-za2 + za = za/( zn2-0.5_dp*(za2+zn2**2.0_dp) - za3*(zn1-0.5_dp*(za1+zn1**2.0_dp) ) ) + zb = (pzs - za1 - za*( zn1-0.5_dp*(za1+zn1**2.0_dp ) ) ) / (zn1**3.0_dp - za1) + zx = 1.0_dp-za/2.0_dp-zb + + DO jk = 1, jpk + p_gamma(jk) = za*(pk1(jk)*(1.0_dp-pk1(jk)/2.0_dp))+zb*pk1(jk)**3.0_dp + & + & zx*( (td_nam%d_alpha+2.0_dp)*pk1(jk)**(td_nam%d_alpha+1.0_dp)- & + & (td_nam%d_alpha+1.0_dp)*pk1(jk)**(td_nam%d_alpha+2.0_dp) ) + p_gamma(jk) = p_gamma(jk)*psmth+pk1(jk)*(1.0_dp-psmth) + ENDDO + + ! + END FUNCTION grid_zgr__sco_fgamma + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE grid_zgr_sco_stiff(td_nam, jpi, jpj, jpk) + !------------------------------------------------------------------- + !> @brief This subroutine stretch the s-coordinate system + !> + !> + !> ** Method : s-coordinate stretch + !> + !> Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. + !> + !> @author J.Paul + !> @date September, 2015 - rewrite from domain (dom_stiff) + !> + !> @param[in] td_nam + !> @param[in] jpi + !> @param[in] jpj + !> @param[in] jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TNAMZ), INTENT(IN ) :: td_nam + INTEGER(i4), INTENT(IN ) :: jpi + INTEGER(i4), INTENT(IN ) :: jpj + INTEGER(i4), INTENT(IN ) :: jpk + + ! local variable + REAL(dp) :: zrxmax + REAL(dp), DIMENSION(4) :: zr1 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + tg_rx1%d_value(:,:,1,1) = 0._dp + + zrxmax = 0._dp + zr1(:) = 0._dp + + DO ji = 2, jpi-1 + DO jj = 2, jpj-1 + DO jk = 1, jpk-1 + zr1(1) = tg_umask%d_value(ji-1,jj ,jk,1) & + & * ABS( ( tg_gdepw_0%d_value(ji ,jj ,jk ,1) & + & - tg_gdepw_0%d_value(ji-1,jj ,jk ,1) & + & + tg_gdepw_0%d_value(ji ,jj ,jk+1,1) & + & - tg_gdepw_0%d_value(ji-1,jj ,jk+1,1) ) & + & / ( tg_gdepw_0%d_value(ji ,jj ,jk ,1) & + & + tg_gdepw_0%d_value(ji-1,jj ,jk ,1) & + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1) & + & - tg_gdepw_0%d_value(ji-1,jj ,jk+1,1) & + & + dp_eps) ) + zr1(2) = tg_umask%d_value(ji ,jj ,jk,1) & + & * ABS( ( tg_gdepw_0%d_value(ji+1,jj ,jk ,1) & + & - tg_gdepw_0%d_value(ji ,jj ,jk ,1) & + & + tg_gdepw_0%d_value(ji+1,jj ,jk+1,1) & + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1) ) & + & / ( tg_gdepw_0%d_value(ji+1,jj ,jk ,1)& + & + tg_gdepw_0%d_value(ji ,jj ,jk ,1)& + & - tg_gdepw_0%d_value(ji+1,jj ,jk+1,1)& + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1)& + & + dp_eps) ) + zr1(3) = tg_vmask%d_value(ji ,jj ,jk,1) & + & * ABS( ( tg_gdepw_0%d_value(ji ,jj+1,jk ,1)& + & - tg_gdepw_0%d_value(ji ,jj ,jk ,1)& + & + tg_gdepw_0%d_value(ji ,jj+1,jk+1,1)& + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1) ) & + & / ( tg_gdepw_0%d_value(ji ,jj+1,jk ,1)& + & + tg_gdepw_0%d_value(ji ,jj ,jk ,1)& + & - tg_gdepw_0%d_value(ji ,jj+1,jk+1,1)& + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1)& + & + dp_eps) ) + zr1(4) = tg_vmask%d_value(ji ,jj-1,jk,1) & + & * ABS( ( tg_gdepw_0%d_value(ji ,jj ,jk ,1)& + & - tg_gdepw_0%d_value(ji ,jj-1,jk ,1)& + & + tg_gdepw_0%d_value(ji ,jj ,jk+1,1)& + & - tg_gdepw_0%d_value(ji ,jj-1,jk+1,1) ) & + & / ( tg_gdepw_0%d_value(ji ,jj ,jk ,1)& + & + tg_gdepw_0%d_value(ji ,jj-1,jk ,1)& + & - tg_gdepw_0%d_value(ji ,jj ,jk+1,1)& + & - tg_gdepw_0%d_value(ji ,jj-1,jk+1,1)& + & + dp_eps) ) + zrxmax = MAXVAL(zr1(1:4)) + tg_rx1%d_value(ji,jj,1,1) = MAX(tg_rx1%d_value(ji,jj,1,1), zrxmax) + END DO + END DO + END DO + + CALL lbc_lnk( tg_rx1%d_value(:,:,1,1), 'T', td_nam%i_perio, 1._dp ) + + zrxmax = MAXVAL(tg_rx1%d_value(:,:,1,1)) + CALL logger_info(' GRID ZGR SCO STIFF: maximum grid stiffness ratio: '//& + & TRIM(fct_str(zrxmax)) ) + + END SUBROUTINE grid_zgr_sco_stiff + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE grid_zgr diff --git a/V4.0/nemo_sources/tools/SIREN/src/interp.f90 b/V4.0/nemo_sources/tools/SIREN/src/interp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dd5cfa8fbe46cbeb09fe40df3d7b222ac605c367 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/interp.f90 @@ -0,0 +1,985 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage interpolation on regular grid. +!> +!> @details Interpolation method to be used is specify inside variable +!> strcuture, as array of string character.<br/> +!> - td_var\%c_interp(1) string character is the interpolation name choose between: +!> - 'nearest' +!> - 'cubic ' +!> - 'linear ' +!> - td_var\%c_interp(2) string character is an operation to be used +!> on interpolated value.<br/> +!> operation have to be mulitplication '*' or division '/'.<br/> +!> coefficient have to be refinement factor following i-direction 'rhoi', +!> j-direction 'rhoj', or k-direction 'rhok'.<br/> +!> +!> Examples: '*rhoi', '/rhoj'. +!> +!> @note Those informations are read from namelist or variable configuration file (default).<br/> +!> Interplation method could be specify for each variable in namelist _namvar_, +!> defining string character _cn\_varinfo_.<br/> +!> Example: +!> - cn_varinfo='varname1:int=cubic/rhoi', 'varname2:int=linear' +!> +!> to create mixed grid (with coarse grid point needed to compute +!> interpolation):<br/> +!> @code +!> CALL interp_create_mixed_grid( td_var, td_mix [,id_rho] ) +!> @endcode +!> - td_var is coarse grid variable (should be extrapolated) +!> - td_mix is mixed grid variable structure [output] +!> - id_rho is array of refinment factor [optional] +!> +!> to detected point to be interpolated:<br/> +!> @code +!> il_detect(:,:,:)=interp_detect( td_mix [,id_rho] ) +!> @endcode +!> - il_detect(:,:,:) is 3D array of detected point to be interpolated +!> - td_mix is mixed grid variable +!> - id_rho is array of refinement factor [optional] +!> +!> to interpolate variable value:<br/> +!> @code +!> CALL interp_fill_value( td_var [,id_rho] [,id_offset] ) +!> @endcode +!> - td_var is variable structure +!> - id_rho is array of refinement factor [optional] +!> - id_offset is array of offset between fine and coarse grid [optional] +!> +!> to clean mixed grid (remove points added on mixed grid to compute interpolation):<br/> +!> @code +!> CALL interp_clean_mixed_grid( td_mix, td_var, id_rho ) +!> @endcode +!> - td_mix is mixed grid variable structure +!> - td_var is variable structure [output] +!> - id_rho is array of refinement factor [optional] +!> - id_offset is array of offset between fine and coarse grid [optional] +!> +!> @note It use to work on ORCA grid, as we work only with grid indices. +!> +!> @warning due to the use of second derivative when using cubic interpolation +!> you should add at least 2 extrabands. +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add header +!> - use interpolation method modules +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE interp + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE grid ! grid manager + USE extrap ! extrapolation manager + USE interp_cubic ! cubic interpolation manager + USE interp_linear ! linear interpolation manager + USE interp_nearest ! nearest interpolation manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + ! function and subroutine + PUBLIC :: interp_detect !< detected point to be interpolated + PUBLIC :: interp_fill_value !< interpolate value + PUBLIC :: interp_create_mixed_grid !< create mixed grid + PUBLIC :: interp_clean_mixed_grid !< clean mixed grid + + PRIVATE :: interp__detect ! detected point to be interpolated + PRIVATE :: interp__detect_wrapper ! detected point to be interpolated + PRIVATE :: interp__fill_value_wrapper ! interpolate value over detectected point + PRIVATE :: interp__fill_value ! interpolate value over detectected point + PRIVATE :: interp__clean_even_grid ! clean even mixed grid + PRIVATE :: interp__check_method ! check if interpolation method available + + TYPE TINTERP + CHARACTER(LEN=lc) :: c_name = '' !< interpolation method name + CHARACTER(LEN=lc) :: c_factor = '' !< interpolation factor + CHARACTER(LEN=lc) :: c_divisor= '' !< interpolation divisor + END TYPE TINTERP + + INTERFACE interp_detect + MODULE PROCEDURE interp__detect_wrapper + END INTERFACE interp_detect + + INTERFACE interp_fill_value + MODULE PROCEDURE interp__fill_value_wrapper + END INTERFACE interp_fill_value + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp__check_method(cd_method) & + & RESULT (lf_avail) + !------------------------------------------------------------------- + !> @brief + !> This function check if interpolation method is available. + !> + !> @details + !> check if name of interpolation method is present in global list of string + !> character cp_interp_list (see global.f90). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] cd_method interpolation method + !> @return true if interpolation method is available + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=lc) :: cd_method + + ! function + LOGICAL :: lf_avail + + ! local variable + CHARACTER(LEN=lc) :: cl_interp + CHARACTER(LEN=lc) :: cl_method + + ! loop indices + INTEGER(I4) :: ji + !---------------------------------------------------------------- + + cl_method=fct_lower(cd_method) + + lf_avail=.FALSE. + DO ji=1,ip_ninterp + cl_interp=fct_lower(cp_interp_list(ji)) + IF( TRIM(cl_interp) == TRIM(cl_method) )THEN + lf_avail=.TRUE. + EXIT + ENDIF + ENDDO + + END FUNCTION interp__check_method + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp__detect_wrapper(td_mix, id_rho) & + & RESULT (if_detect) + !------------------------------------------------------------------- + !> @brief + !> This function detected point to be interpolated. + !> + !> @details + !> Actually it checks, the number of dimension used for this variable + !> and launch interp__detect which detected point to be interpolated. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_mix mixed grid variable (to interpolate) + !> @param[in] id_rho array of refinement factor + !> @return 3D array of detected point to be interpolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_mix + INTEGER(I4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + + ! function + INTEGER(i4), DIMENSION(td_mix%t_dim(1)%i_len,& + & td_mix%t_dim(2)%i_len,& + & td_mix%t_dim(3)%i_len ) :: if_detect + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + IF( .NOT. ANY(td_mix%t_dim(1:3)%l_use) )THEN + ! no dimension I-J-K used + CALL logger_debug(" INTERP DETECT: nothing done for variable"//& + & TRIM(td_mix%c_name) ) + + if_detect(:,:,:)=0 + + ELSE IF( ALL(td_mix%t_dim(1:3)%l_use) )THEN + + ! detect point to be interpolated on I-J-K + CALL logger_debug(" INTERP DETECT: detect point "//& + & TRIM(td_mix%c_point)//" for variable "//& + & TRIM(td_mix%c_name) ) + + if_detect(:,:,:)=interp__detect( td_mix, id_rho(:) ) + + ELSE IF( ALL(td_mix%t_dim(1:2)%l_use) )THEN + + ! detect point to be interpolated on I-J + CALL logger_debug(" INTERP DETECT: detect point "//& + & TRIM(td_mix%c_point)//" for variable "//& + & TRIM(td_mix%c_name) ) + + if_detect(:,:,1:1)=interp__detect( td_mix, id_rho(:)) + + ELSE IF( td_mix%t_dim(3)%l_use )THEN + + ! detect point to be interpolated on K + CALL logger_debug(" INTERP DETECT: detect vertical point "//& + & " for variable "//TRIM(td_mix%c_name) ) + + if_detect(1:1,1:1,:)=interp__detect( td_mix, id_rho(:) ) + + ENDIF + + END FUNCTION interp__detect_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp__detect(td_mix, id_rho) & + & RESULT (if_detect) + !------------------------------------------------------------------- + !> @brief + !> This function detected point to be interpolated. + !> + !> @details + !> A special case is done for even refinement on ARAKAWA-C grid. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[in] td_mix mixed grid variable (to interpolate) + !> @param[in] id_rho array of refinement factor + !> @return 3D array of detected point to be interpolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_mix + INTEGER(I4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho + + ! function + INTEGER(i4), DIMENSION(td_mix%t_dim(1)%i_len,& + & td_mix%t_dim(2)%i_len,& + & td_mix%t_dim(3)%i_len ) :: if_detect + + ! local variable + INTEGER(I4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(I4) :: il_xextra + INTEGER(I4) :: il_yextra + INTEGER(I4) :: il_zextra + + INTEGER(i4), DIMENSION(3) :: il_dim + + LOGICAL , DIMENSION(3) :: ll_even + + ! loop indices + INTEGER(I4) :: ji + INTEGER(I4) :: jj + INTEGER(I4) :: jk + !---------------------------------------------------------------- + ALLOCATE( il_rho(ip_maxdim) ) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:) + + ! special case for even refinement on ARAKAWA-C grid + ll_even(:)=.FALSE. + IF( MOD(il_rho(jp_I),2) == 0 ) ll_even(1)=.TRUE. + IF( MOD(il_rho(jp_J),2) == 0 ) ll_even(2)=.TRUE. + IF( MOD(il_rho(jp_K),2) == 0 ) ll_even(3)=.TRUE. + + SELECT CASE(TRIM(td_mix%c_point)) + CASE('U') + ll_even(1)=.FALSE. + CASE('V') + ll_even(2)=.FALSE. + CASE('F') + ll_even(:)=.FALSE. + END SELECT + + IF( ll_even(1) ) il_rho(jp_I)=il_rho(jp_I)+1 + IF( ll_even(2) ) il_rho(jp_J)=il_rho(jp_J)+1 + IF( ll_even(3) ) il_rho(jp_K)=il_rho(jp_K)+1 + + ! special case for cubic interpolation + il_xextra=0 + il_yextra=0 + il_zextra=0 + SELECT CASE(TRIM(td_mix%c_interp(1))) + CASE('cubic') + ! those points can not be compute cause cubic interpolation + ! need second derivative. + IF( il_rho(jp_I) /= 1 ) il_xextra=3*il_rho(jp_I) + IF( il_rho(jp_J) /= 1 ) il_yextra=3*il_rho(jp_J) + IF( il_rho(jp_K) /= 1 ) il_zextra=3*il_rho(jp_K) + END SELECT + + il_dim(:)=td_mix%t_dim(1:3)%i_len + + ! init + if_detect(:,:,:)=1 + + ! do not compute coarse grid point + if_detect(1:td_mix%t_dim(1)%i_len:il_rho(jp_I), & + & 1:td_mix%t_dim(2)%i_len:il_rho(jp_J), & + & 1:td_mix%t_dim(3)%i_len:il_rho(jp_K) ) = 0 + + ! do not compute point near fill value + DO jk=1,il_dim(3),il_rho(jp_K) + DO jj=1,il_dim(2),il_rho(jp_J) + DO ji=1,il_dim(1),il_rho(jp_I) + + IF( td_mix%d_value(ji,jj,jk,1) == td_mix%d_fill )THEN + + ! i-direction + if_detect(MAX(1,ji-il_xextra):MIN(ji+il_xextra,il_dim(1)),& + & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),& + & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0 + ! j-direction + if_detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),& + & MAX(1,jj-il_yextra):MIN(jj+il_yextra,il_dim(2)),& + & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0 + ! k-direction + if_detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),& + & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),& + & MAX(1,jk-il_zextra):MIN(jk+il_zextra,il_dim(3)) )=0 + + ENDIF + + ENDDO + ENDDO + ENDDO + + DEALLOCATE( il_rho ) + + END FUNCTION interp__detect + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_create_mixed_grid(td_var, td_mix, id_rho) + !------------------------------------------------------------------- + !> @brief + !> This subroutine create mixed grid. + !> + !> @details + !> Created grid is fine resolution grid. + !> First and last point are coasre grid point. + !> + !> A special case is done for even refinement on ARAKAWA-C grid. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var coarse grid variable (should be extrapolated) + !> @param[out] td_mix mixed grid variable + !> @param[in] id_rho array of refinment factor (default 1) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN ) :: td_var + TYPE(TVAR) , INTENT( OUT) :: td_mix + INTEGER(I4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho + + ! local variable + INTEGER(I4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4) :: il_xextra + INTEGER(i4) :: il_yextra + INTEGER(i4) :: il_zextra + + LOGICAL, DIMENSION(3) :: ll_even + + ! loop indices + !---------------------------------------------------------------- + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:) + + ! special case for even refinement on ARAKAWA-C grid + ll_even(:)=.FALSE. + IF( MOD(il_rho(jp_I),2) == 0 ) ll_even(1)=.TRUE. + IF( MOD(il_rho(jp_J),2) == 0 ) ll_even(2)=.TRUE. + IF( MOD(il_rho(jp_K),2) == 0 ) ll_even(3)=.TRUE. + + SELECT CASE(TRIM(td_var%c_point)) + CASE('U') + ll_even(1)=.FALSE. + CASE('V') + ll_even(2)=.FALSE. + CASE('F') + ll_even(:)=.FALSE. + END SELECT + + IF( ll_even(1) ) il_rho(jp_I)=il_rho(jp_I)+1 + IF( ll_even(2) ) il_rho(jp_J)=il_rho(jp_J)+1 + IF( ll_even(3) ) il_rho(jp_K)=il_rho(jp_K)+1 + + ! copy variable + td_mix=var_copy(td_var) + + ! compute new dimension length + il_xextra=il_rho(jp_I)-1 + td_mix%t_dim(1)%i_len=td_mix%t_dim(1)%i_len*il_rho(jp_I)-il_xextra + + il_yextra=il_rho(jp_J)-1 + td_mix%t_dim(2)%i_len=td_mix%t_dim(2)%i_len*il_rho(jp_J)-il_yextra + + il_zextra=il_rho(jp_K)-1 + td_mix%t_dim(3)%i_len=td_mix%t_dim(3)%i_len*il_rho(jp_K)-il_zextra + + IF( ASSOCIATED(td_mix%d_value) ) DEALLOCATE( td_mix%d_value ) + ALLOCATE( td_mix%d_value( td_mix%t_dim(1)%i_len, & + & td_mix%t_dim(2)%i_len, & + & td_mix%t_dim(3)%i_len, & + & td_mix%t_dim(4)%i_len) ) + + ! initialise to FillValue + td_mix%d_value(:,:,:,:)=td_mix%d_fill + + ! quid qd coord ou bathy fourni par user ?? (offset ??) + td_mix%d_value(1:td_mix%t_dim(1)%i_len:il_rho(jp_I), & + & 1:td_mix%t_dim(2)%i_len:il_rho(jp_J), & + & 1:td_mix%t_dim(3)%i_len:il_rho(jp_K), :) = & + & td_var%d_value(:,:,:,:) + + DEALLOCATE(il_rho) + + END SUBROUTINE interp_create_mixed_grid + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp__clean_even_grid(td_mix, id_rho) + !------------------------------------------------------------------- + !> @brief + !> This subroutine remove points added to mixed grid to compute + !> interpolation in the special case of even refinement on ARAKAWA-C grid. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_mix mixed grid variable + !> @param[in] id_rho array of refinment factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_mix + INTEGER(I4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho + + ! local variable + INTEGER(I4), DIMENSION(:), ALLOCATABLE :: il_rho + + INTEGER(i4) :: il_xextra + INTEGER(i4) :: il_yextra + INTEGER(i4) :: il_zextra + + LOGICAL, DIMENSION(3) :: ll_even + + LOGICAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ll_mask + + REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_vect + + TYPE(TVAR) :: tl_mix + + ! loop indices + !---------------------------------------------------------------- + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) + + ! special case for even refinement on ARAKAWA-C grid + ll_even(:)=.FALSE. + IF( MOD(il_rho(jp_I),2) == 0 ) ll_even(1)=.TRUE. + IF( MOD(il_rho(jp_J),2) == 0 ) ll_even(2)=.TRUE. + IF( MOD(il_rho(jp_K),2) == 0 ) ll_even(3)=.TRUE. + + SELECT CASE(TRIM(td_mix%c_point)) + CASE('U') + ll_even(1)=.FALSE. + CASE('V') + ll_even(2)=.FALSE. + CASE('F') + ll_even(:)=.FALSE. + END SELECT + + ! remove some point only if refinement in some direction is even + IF( ANY(ll_even(:)) )THEN + + ! copy variable + tl_mix=var_copy(td_mix) + + ALLOCATE( ll_mask( tl_mix%t_dim(1)%i_len, & + & tl_mix%t_dim(2)%i_len, & + & tl_mix%t_dim(3)%i_len, & + & tl_mix%t_dim(4)%i_len) ) + + ll_mask(:,:,:,:)=.TRUE. + + IF( tl_mix%t_dim(1)%l_use .AND. ll_even(1) )THEN + + il_rho(jp_I)=il_rho(jp_I)+1 + + ! locate wrong point on mixed grid + ll_mask(1:td_mix%t_dim(1)%i_len:il_rho(jp_I),:,:,:)=.FALSE. + + ! compute coasre grid dimension length + il_xextra=il_rho(jp_I)-1 + td_mix%t_dim(1)%i_len=(tl_mix%t_dim(1)%i_len+il_xextra)/il_rho(jp_I) + + il_rho(jp_I)=il_rho(jp_I)-1 + ! compute right fine grid dimension length + td_mix%t_dim(1)%i_len=td_mix%t_dim(1)%i_len*il_rho(jp_I)-il_xextra + + ENDIF + + IF( tl_mix%t_dim(2)%l_use .AND. ll_even(2) )THEN + + il_rho(jp_J)=il_rho(jp_J)+1 + + ! locate wrong point on mixed grid + ll_mask(:,1:tl_mix%t_dim(2)%i_len:il_rho(jp_J),:,:)=.FALSE. + + ! compute coasre grid dimension length + il_yextra=il_rho(jp_J)-1 + td_mix%t_dim(2)%i_len=(tl_mix%t_dim(2)%i_len+il_yextra)/il_rho(jp_J) + + il_rho(jp_J)=il_rho(jp_J)-1 + ! compute right fine grid dimension length + td_mix%t_dim(2)%i_len=td_mix%t_dim(2)%i_len*il_rho(jp_J)-il_yextra + + ENDIF + + IF( tl_mix%t_dim(3)%l_use .AND. ll_even(3) )THEN + + il_rho(jp_K)=il_rho(jp_K)+1 + + ! locate wrong point on mixed grid + ll_mask(:,:,1:tl_mix%t_dim(3)%i_len:il_rho(jp_K),:)=.FALSE. + + ! compute coasre grid dimension length + il_zextra=il_rho(jp_K)-1 + td_mix%t_dim(3)%i_len=(tl_mix%t_dim(3)%i_len+il_zextra)/il_rho(jp_K) + + il_rho(jp_K)=il_rho(jp_K)-1 + ! compute right fine grid dimension length + td_mix%t_dim(3)%i_len=td_mix%t_dim(3)%i_len*il_rho(jp_K)-il_zextra + + ENDIF + + IF( ASSOCIATED(td_mix%d_value) ) DEALLOCATE( td_mix%d_value ) + ALLOCATE( td_mix%d_value( td_mix%t_dim(1)%i_len, & + & td_mix%t_dim(2)%i_len, & + & td_mix%t_dim(3)%i_len, & + & td_mix%t_dim(4)%i_len) ) + + ! initialise to FillValue + td_mix%d_value(:,:,:,:)=td_mix%d_fill + + IF( COUNT(ll_mask(:,:,:,:)) /= SIZE(td_mix%d_value(:,:,:,:)) )THEN + + CALL logger_error("INTERP CLEAN EVEN GRID: output value size "//& + & " and mask count differ ") + + ELSE + + ALLOCATE( dl_vect(COUNT(ll_mask(:,:,:,:))) ) + + dl_vect(:)= PACK( tl_mix%d_value(:,:,:,:), & + & MASK=ll_mask(:,:,:,:) ) + + td_mix%d_value(:,:,:,:)=RESHAPE( dl_vect(:), & + & SHAPE=(/td_mix%t_dim(1)%i_len, & + & td_mix%t_dim(2)%i_len, & + & td_mix%t_dim(3)%i_len, & + & td_mix%t_dim(4)%i_len/) ) + + DEALLOCATE( dl_vect ) + + ENDIF + + DEALLOCATE( ll_mask ) + + ! clean + CALL var_clean(tl_mix) + + ENDIF + + ! clean + DEALLOCATE(il_rho) + + END SUBROUTINE interp__clean_even_grid + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_clean_mixed_grid(td_mix, td_var, & + & id_rho, id_offset) + !------------------------------------------------------------------- + !> @brief + !> This subroutine remove points added on mixed grid + !> to compute interpolation. And save interpolated value over domain. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use offset to save useful domain + !> + !> @param[in] td_mix mixed grid variable structure + !> @param[out] td_var variable structure + !> @param[in] id_rho array of refinement factor (default 1) + !> @param[in] id_offset 2D array of offset between fine and coarse grid + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN ) :: td_mix + TYPE(TVAR) , INTENT( OUT) :: td_var + INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(I4), DIMENSION(2,2), INTENT(IN ) :: id_offset + + ! local variable + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmax1 + + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TVAR) :: tl_mix + + ! loop indices + !---------------------------------------------------------------- + ! copy mixed variable in temporary structure + tl_mix=var_copy(td_mix) + + ! remove useless points over mixed grid for even refinement + CALL interp__clean_even_grid(tl_mix, id_rho(:)) + + ! copy cleaned mixed variable + td_var=var_copy(tl_mix) + + ! delete array of value + CALL var_del_value(td_var) + + ! compute domain indices in i-direction + il_imin0=1 ; il_imax0=td_var%t_dim(1)%i_len + + IF( td_var%t_dim(1)%l_use )THEN + il_imin1=il_imin0+id_offset(Jp_I,1) + il_imax1=il_imax0-id_offset(Jp_I,2) + ELSE + + il_imin1=il_imin0 + il_imax1=il_imax0 + + ENDIF + + ! compute domain indices in j-direction + il_jmin0=1 ; il_jmax0=td_var%t_dim(2)%i_len + + IF( td_var%t_dim(2)%l_use )THEN + il_jmin1=il_jmin0+id_offset(Jp_J,1) + il_jmax1=il_jmax0-id_offset(Jp_J,2) + ELSE + + il_jmin1=il_jmin0 + il_jmax1=il_jmax0 + + ENDIF + + ! compute new dimension + td_var%t_dim(1)%i_len=il_imax1-il_imin1+1 + td_var%t_dim(2)%i_len=il_jmax1-il_jmin1+1 + + ALLOCATE(dl_value(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + dl_value( 1:td_var%t_dim(1)%i_len, & + & 1:td_var%t_dim(2)%i_len, & + & :,:) = tl_mix%d_value( il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & :, : ) + + ! add variable value + CALL var_add_value(td_var,dl_value(:,:,:,:)) + + DEALLOCATE(dl_value) + + ! clean + CALL var_clean(tl_mix) + + END SUBROUTINE interp_clean_mixed_grid + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp__fill_value_wrapper(td_var, & + & id_rho, & + & id_offset) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable value. + !> + !> @details + !> Actually it checks, the number of dimension used for this variable + !> and launch interp__fill_value. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] id_rho array of refinement factor + !> @param[in] id_offset 2D array of offset between fine and coarse grid + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(I4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho + INTEGER(I4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset + + ! local variable + CHARACTER(LEN=lc) :: cl_method + INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_rho + INTEGER(i4) , DIMENSION(2,2) :: il_offset + + ! loop indices + !---------------------------------------------------------------- + + ALLOCATE( il_rho(ip_maxdim) ) + il_rho(:)=1 + IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:) + IF( ANY(il_rho(:) < 0) )THEN + CALL logger_error("INTERP FILL VALUE: invalid "//& + & " refinement factor ") + ENDIF + + il_offset(:,:)=0 + IF( PRESENT(id_offset) )THEN + IF( ANY(SHAPE(id_offset(:,:)) /= (/2,2/)) )THEN + CALL logger_error("INTERP FILL VALUE: invalid array of offset") + ELSE + il_offset(:,:)=id_offset(:,:) + ENDIF + ENDIF + + IF( (il_rho(jp_I) /= 1 .AND. td_var%t_dim(1)%l_use) .OR. & + & (il_rho(jp_J) /= 1 .AND. td_var%t_dim(2)%l_use) .OR. & + & (il_rho(jp_K) /= 1 .AND. td_var%t_dim(3)%l_use) )THEN + + SELECT CASE(TRIM(td_var%c_interp(1))) + CASE('cubic','linear','nearest') + cl_method=TRIM(td_var%c_interp(1)) + CASE DEFAULT + CALL logger_warn("INTERP FILL VALUE: interpolation method unknown."//& + & " use linear interpolation") + cl_method='linear' + ! update variable structure value + td_var%c_interp(1)='linear' + END SELECT + + CALL logger_info("INTERP FILL: interpolate "//TRIM(td_var%c_name)//& + & " using "//TRIM(cl_method)//" method." ) + CALL logger_info("INTERP FILL: refinement factor "//& + & TRIM(fct_str(il_rho(jp_I)))//& + & " "//TRIM(fct_str(il_rho(jp_J)))//& + & " "//TRIM(fct_str(il_rho(jp_K))) ) + + CALL interp__fill_value( td_var, cl_method, & + & il_rho(:), il_offset(:,:) ) + + SELECT CASE(TRIM(td_var%c_interp(2))) + CASE('/rhoi') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) / REAL(il_rho(jp_I),dp) + END WHERE + CASE('/rhoj') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) / REAL(il_rho(jp_J),dp) + END WHERE + CASE('/rhok') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) / REAL(il_rho(jp_K),dp) + END WHERE + CASE('*rhoi') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) * REAL(il_rho(jp_I),dp) + END WHERE + CASE('*rhoj') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) * REAL(il_rho(jp_J),dp) + END WHERE + CASE('*rhok') + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:) * REAL(il_rho(jp_K),dp) + END WHERE + CASE DEFAULT + td_var%c_interp(2)='' + END SELECT + + ELSE + td_var%c_interp(:)='' + ENDIF + + DEALLOCATE(il_rho) + + END SUBROUTINE interp__fill_value_wrapper + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp__fill_value(td_var, cd_method, & + & id_rho, id_offset) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate value over mixed grid. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use interpolation method modules + !> + !> @param[inout] td_var variable structure + !> @param[in] cd_method interpolation method + !> @param[in] id_rho array of refinment factor + !> @param[in] id_offset 2D array of offset between fine and coarse grid + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=*) , INTENT(IN ) :: cd_method + INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(I4) , DIMENSION(2,2), INTENT(IN ) :: id_offset + + ! local variable + CHARACTER(LEN=lc) :: cl_interp + + INTEGER(I4) , DIMENSION(:) , ALLOCATABLE :: il_rho + INTEGER(i4) , DIMENSION(:,:,:) , ALLOCATABLE :: il_detect + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + + LOGICAL , DIMENSION(3) :: ll_even + LOGICAL :: ll_discont + + TYPE(TVAR) :: tl_mix + + TYPE(TATT) :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + !1- create mixed grid + CALL interp_create_mixed_grid( td_var, tl_mix, id_rho(:) ) + + ! clean variable structure + CALL var_clean(td_var) + + !2- detect point to be interpolated + ALLOCATE( il_detect( tl_mix%t_dim(1)%i_len, & + & tl_mix%t_dim(2)%i_len, & + & tl_mix%t_dim(3)%i_len) ) + + il_detect(:,:,:)=0 + + il_detect(:,:,:)=interp_detect(tl_mix, id_rho(:) ) + + ! add attribute to variable + cl_interp=fct_concat(tl_mix%c_interp(:)) + tl_att=att_init('interpolation',cl_interp) + CALL var_move_att(tl_mix, tl_att) + + ! clean + CALL att_clean(tl_att) + + ! special case for even refinement on ARAKAWA-C grid + ll_even(:)=.FALSE. + IF( MOD(id_rho(jp_I),2) == 0 ) ll_even(1)=.TRUE. + IF( MOD(id_rho(jp_J),2) == 0 ) ll_even(2)=.TRUE. + IF( MOD(id_rho(jp_K),2) == 0 ) ll_even(3)=.TRUE. + + SELECT CASE(TRIM(tl_mix%c_point)) + CASE('U') + ll_even(1)=.FALSE. + CASE('V') + ll_even(2)=.FALSE. + CASE('F') + ll_even(:)=.FALSE. + END SELECT + + ALLOCATE(il_rho(ip_maxdim)) + il_rho(:)=id_rho(:) + + IF( ll_even(1) ) il_rho(jp_I)=id_rho(jp_I)+1 + IF( ll_even(2) ) il_rho(jp_J)=id_rho(jp_J)+1 + IF( ll_even(3) ) il_rho(jp_K)=id_rho(jp_K)+1 + + ! special case for longitude + ll_discont=.FALSE. + IF( TRIM(tl_mix%c_units) == 'degrees_east' )THEN + dl_min=MINVAL( tl_mix%d_value(:,:,:,:), & + & tl_mix%d_value(:,:,:,:)/=tl_mix%d_fill) + dl_max=MAXVAL( tl_mix%d_value(:,:,:,:), & + & tl_mix%d_value(:,:,:,:)/=tl_mix%d_fill) + IF( dl_min < -170_dp .AND. dl_max > 170_dp .OR. & + & dl_min < 10_dp .AND. dl_max > 350_dp )THEN + ll_discont=.TRUE. + ENDIF + ENDIF + + !3- interpolate + CALL logger_debug("INTERP 2D: interpolation method "//TRIM(cd_method)//& + & " discont "//TRIM(fct_str(ll_discont)) ) + SELECT CASE(TRIM(cd_method)) + CASE('cubic') + CALL interp_cubic_fill(tl_mix%d_value(:,:,:,:), tl_mix%d_fill, & + & il_detect(:,:,:), & + & il_rho(:), ll_even(:), ll_discont ) + CASE('nearest') + CALL interp_nearest_fill(tl_mix%d_value(:,:,:,:), & + & il_detect(:,:,:), & + & il_rho(:) ) + CASE DEFAULT ! linear + CALL interp_linear_fill(tl_mix%d_value(:,:,:,:), tl_mix%d_fill, & + & il_detect(:,:,:), & + & il_rho(:), ll_even(:), ll_discont ) + END SELECT + + IF( ANY(il_detect(:,:,:)==1) )THEN + CALL logger_warn("INTERP FILL: some points can not be interpolated "//& + & "for variable "//TRIM(tl_mix%c_name) ) + ENDIF + + DEALLOCATE(il_detect) + + !4- save useful domain (remove offset) + CALL interp_clean_mixed_grid( tl_mix, td_var, & + & id_rho(:), id_offset(:,:) ) + + ! clean variable structure + DEALLOCATE(il_rho) + CALL var_clean(tl_mix) + + END SUBROUTINE interp__fill_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE interp diff --git a/V4.0/nemo_sources/tools/SIREN/src/interp_cubic.f90 b/V4.0/nemo_sources/tools/SIREN/src/interp_cubic.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1d0b6a1023a2b37614f261394b1c1a6f298da9c3 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/interp_cubic.f90 @@ -0,0 +1,819 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage cubic interpolation on regular grid. +!> +!> +!> @details +!> to compute cubic interpolation:<br/> +!> @code +!> CALL interp_cubic_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] ) +!> @endcode +!> - dd_value is 2D array of variable value +!> - dd_fill is the FillValue of variable +!> - id_detect is 2D array of point to be interpolated (see interp module) +!> - id_rho is array of refinment factor +!> - ld_even indicates even refinment or not +!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not +!> +!> @author +!> J.Paul +!> +!> @date September, 2014 -Initial version +!> @date June, 2015 +!> - use math module +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE interp_cubic + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE math ! mathematical function + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + ! function and subroutine + PUBLIC :: interp_cubic_fill !< compute interpolation using cubic method + + PRIVATE :: interp_cubic__2D !< compute bicubic interpolation on 2D gid + PRIVATE :: interp_cubic__1D !< compute cubic interpolation on 1D gid + PRIVATE :: interp_cubic__2D_coef !< compute coefficient for bicubic interpolation + PRIVATE :: interp_cubic__2D_fill !< fill value using bicubic interpolation + PRIVATE :: interp_cubic__1D_coef !< compute coefficient for cubic interpolation + PRIVATE :: interp_cubic__1D_fill !< fill value using cubic interpolation + PRIVATE :: interp_cubic__get_weight2D !< compute interpoaltion weight for 2D array + PRIVATE :: interp_cubic__get_weight1D !< compute interpoaltion weight for 1D array + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic_fill(dd_value, dd_fill, & + & id_detect, & + & id_rho, & + & ld_even, ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute horizontal cubic interpolation on 4D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date July, 2015 + !> - reinitialise detect array for each level + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rho array of refinment factor + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect + INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho + LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even + LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont + + ! local variable + INTEGER(i4), DIMENSION(4) :: il_shape + + INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect + + LOGICAL :: ll_discont + + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_IJ + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_I + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_J + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + ll_discont=.FALSE. + IF( PRESENT(ld_discont) ) ll_discont=ld_discont + + il_shape(:)=SHAPE(dd_value) + + ! compute vect2D + ALLOCATE(dl_weight_IJ(16,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) ) + CALL interp_cubic__get_weight2D(dl_weight_IJ(:,:), & + & id_rho(:), ld_even(:)) + + ALLOCATE( dl_weight_I( 4,((id_rho(jp_I)+1) )) ) + ALLOCATE( dl_weight_J( 4,( (id_rho(jp_J)+1))) ) + CALL interp_cubic__get_weight1D(dl_weight_I(:,:), & + & id_rho(jp_I), ld_even(jp_I)) + CALL interp_cubic__get_weight1D(dl_weight_J(:,:), & + & id_rho(jp_J), ld_even(jp_J)) + + ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) + + DO jl=1,il_shape(4) + il_detect(:,:,:)=id_detect(:,:,:) + ! loop on vertical level + DO jk=1,il_shape(3) + + ! I-J plan + CALL interp_cubic__2D(dd_value(:,:,jk,jl), dd_fill, & + & il_detect(:,:,jk), & + & dl_weight_IJ(:,:), & + & id_rho(jp_I), id_rho(jp_J), & + & ll_discont) + IF( ANY(il_detect(:,:,jk)==1) )THEN + ! I direction + DO jj=1,il_shape(2) + CALL interp_cubic__1D( dd_value(:,jj,jk,jl), dd_fill, & + & il_detect(:,jj,jk), & + & dl_weight_I(:,:), & + & id_rho(jp_I), ll_discont ) + ENDDO + IF( ALL(il_detect(:,:,jk)==0) )THEN + CYCLE + ELSE + ! J direction + DO ji=1,il_shape(1) + CALL interp_cubic__1D( dd_value(ji,:,jk,jl), dd_fill, & + & il_detect(ji,:,jk), & + & dl_weight_J(:,:), & + & id_rho(jp_J), ll_discont ) + ENDDO + ENDIF + ENDIF + + ENDDO + ENDDO + + id_detect(:,:,:)=il_detect(:,:,:) + DEALLOCATE(il_detect) + + DEALLOCATE(dl_weight_IJ) + DEALLOCATE(dl_weight_I) + DEALLOCATE(dl_weight_J) + + END SUBROUTINE interp_cubic_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__2D(dd_value, dd_fill, & + & id_detect, & + & dd_weight, & + & id_rhoi, id_rhoj, & + & ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute cubic interpolation on 2D array of value. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rhoi refinment factor in i-direction + !> @param[in] id_rhoj refinment factor in j-direction + !> @param[in] id_rhok refinment factor in k-direction + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rhoi + INTEGER(I4) , INTENT(IN ) :: id_rhoj + LOGICAL , INTENT(IN ) :: ld_discont + + ! local variable + INTEGER(I4) :: il_xextra + INTEGER(I4) :: il_yextra + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(2) :: il_dim + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_coef + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coarse + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_tmp + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdx + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdy + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_d2fdxy + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: ii + INTEGER(i4) :: ij + !---------------------------------------------------------------- + + IF( ANY(id_detect(:,:)==1) )THEN + il_shape(:)=SHAPE(dd_value) + + ! compute coarse grid dimension + il_xextra=id_rhoi-1 + il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi + + il_yextra=id_rhoj-1 + il_dim(2)=(il_shape(2)+il_yextra)/id_rhoj + + ALLOCATE( dl_coarse(il_dim(1),il_dim(2)) ) + + ! value on coarse grid + dl_coarse(:,:)=dd_value( 1:il_shape(1):id_rhoi, & + & 1:il_shape(2):id_rhoj ) + + ALLOCATE( dl_dfdx( il_dim(1),il_dim(2)), & + & dl_dfdy( il_dim(1),il_dim(2)), & + & dl_d2fdxy(il_dim(1),il_dim(2)) ) + + ! compute derivative on coarse grid + dl_dfdx(:,:)=math_deriv_2D(dl_coarse(:,:), dd_fill, 'I', ld_discont) + dl_dfdy(:,:)=math_deriv_2D(dl_coarse(:,:), dd_fill, 'J', ld_discont) + + ! compute cross derivative on coarse grid + dl_d2fdxy(:,:)=math_deriv_2D(dl_dfdx(:,:), dd_fill, 'J', ld_discont) + + ALLOCATE( dl_tmp(2,2) ) + ALLOCATE( dl_coef(16) ) + + DO jj=1,il_shape(2)-1,id_rhoj + ij=((jj-1)/id_rhoj)+1 + DO ji=1,il_shape(1)-1,id_rhoi + ii=((ji-1)/id_rhoi)+1 + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj)==0) ) CYCLE + ! check data needed to interpolate + IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) .OR. & + & ANY( dl_dfdx(ii:ii+1,ij:ij+1)==dd_fill) .OR. & + & ANY( dl_dfdy(ii:ii+1,ij:ij+1)==dd_fill) .OR. & + & ANY(dl_d2fdxy(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE + + dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1) + ! check longitude discontinuity + IF( ld_discont )THEN + + dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill ) + dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_tmp(:,:) < 0_dp ) + dl_tmp(:,:) = dl_tmp(:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_tmp(:,:) > 180_dp ) + dl_tmp(:,:) = dl_tmp(:,:)-180._dp + END WHERE + ENDIF + + ENDIF + + ! compute bicubic coefficient + dl_coef(:)=interp_cubic__2D_coef(dl_tmp(:,:),& + & dl_dfdx( ii:ii+1,ij:ij+1),& + & dl_dfdy( ii:ii+1,ij:ij+1),& + & dl_d2fdxy(ii:ii+1,ij:ij+1),& + & dd_fill ) + + ! compute value on detetected point + CALL interp_cubic__2D_fill(dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ), & + & id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj ), & + & dd_weight(:,:), dl_coef(:),& + & dd_fill, id_rhoi, id_rhoj ) + + IF( ld_discont )THEN + WHERE( dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) >= 180._dp .AND. & + & dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) /= dd_fill ) + dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) = & + & dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) - 360._dp + END WHERE + ENDIF + + ENDDO + ENDDO + + DEALLOCATE(dl_coef) + DEALLOCATE(dl_tmp ) + + DEALLOCATE(dl_dfdx, & + & dl_dfdy, & + & dl_d2fdxy ) + + DEALLOCATE( dl_coarse ) + ENDIF + + END SUBROUTINE interp_cubic__2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__1D(dd_value, dd_fill, & + & id_detect, & + & dd_weight, & + & id_rhoi, & + & ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute cubic interpolation on 1D array of value. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 1D array of point to be interpolated + !> @param[in] id_rhoi refinment factor + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:) , INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rhoi + LOGICAL , INTENT(IN ) :: ld_discont + + ! local variable + INTEGER(I4) :: il_xextra + INTEGER(i4), DIMENSION(1) :: il_shape + INTEGER(i4), DIMENSION(1) :: il_dim + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coef + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coarse + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_tmp + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_dfdx + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ii + !---------------------------------------------------------------- + + IF( ANY(id_detect(:)==1) )THEN + il_shape(:)=SHAPE(dd_value) + + ! compute coarse grid dimension + il_xextra=id_rhoi-1 + il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi + + ALLOCATE( dl_coarse(il_dim(1)) ) + + ! value on coarse grid + dl_coarse(:)=dd_value( 1:il_shape(1):id_rhoi ) + + ALLOCATE( dl_dfdx(il_dim(1)) ) + + ! compute derivative on coarse grid + dl_dfdx(:)=math_deriv_1D(dl_coarse(:), dd_fill, ld_discont) + + ALLOCATE( dl_tmp(2) ) + ALLOCATE( dl_coef(4) ) + + DO ji=1,il_shape(1)-1,id_rhoi + ii=((ji-1)/id_rhoi)+1 + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE + ! check data needed to interpolate + IF( ANY(dl_coarse(ii:ii+1)==dd_fill) .OR. & + & ANY( dl_dfdx(ii:ii+1)==dd_fill) ) CYCLE + ! check longitude discontinuity + dl_tmp(:)=dl_coarse(ii:ii+1) + IF( ld_discont )THEN + + dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill ) + dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_tmp(:) < 0_dp ) + dl_tmp(:) = dl_tmp(:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_tmp(:) > 180_dp ) + dl_tmp(:) = dl_tmp(:)-180._dp + END WHERE + ENDIF + + ENDIF + + ! compute bicubic coefficient + dl_coef(:)=interp_cubic__1D_coef(dl_tmp(:), & + & dl_dfdx(ii:ii+1),& + & dd_fill ) + + ! compute value on detetected point + CALL interp_cubic__1D_fill( dd_value( ji:ji+id_rhoi ), & + & id_detect(ji:ji+id_rhoi ), & + & dd_weight(:,:), dl_coef(:), & + & dd_fill, id_rhoi ) + + IF( ld_discont )THEN + WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. & + & dd_value( ji:ji+id_rhoi ) /= dd_fill ) + dd_value(ji:ji+id_rhoi) = dd_value(ji:ji+id_rhoi) - 360._dp + END WHERE + ENDIF + + ENDDO + + DEALLOCATE(dl_coef) + DEALLOCATE(dl_tmp ) + + DEALLOCATE(dl_dfdx ) + DEALLOCATE( dl_coarse ) + ENDIF + + END SUBROUTINE interp_cubic__1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp_cubic__2D_coef(dd_value, & + & dd_dfdx, dd_dfdy, dd_d2fdxy,& + & dd_fill) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute 2D array of coefficient for cubic interpolation. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_value 2D array of value + !> @param[in] dd_dfdx 2D array of first derivative in i-direction + !> @param[in] dd_dfdy 2D array of first derivative in j-direction + !> @param[in] dd_d2fdxy 2D array of cross derivative in i-j-direction + !> @param[in] dd_fill FillValue of variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_value + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdx + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdy + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_d2fdxy + REAL(dp) , INTENT(IN) :: dd_fill + + ! function + REAL(dp), DIMENSION(16) :: df_coef + + ! local variable + REAL(dp), DIMENSION(16,16), PARAMETER :: dl_matrix = RESHAPE( & + & (/ 1 , 0 ,-3 , 2 , 0 , 0 , 0 , 0 ,-3 , 0 , 9 ,-6 , 2 , 0 ,-6 , 4 ,& + 0 , 0 , 3 ,-2 , 0 , 0 , 0 , 0 , 0 , 0 ,-9 , 6 , 0 , 0 , 6 ,-4 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 ,-9 , 6 ,-2 , 0 , 6 ,-4 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 9 ,-6 , 0 , 0 ,-6 , 4 ,& + 0 , 1 ,-2 , 1 , 0 , 0 , 0 , 0 , 0 ,-3 , 6 ,-3 , 0 , 2 ,-4 , 2 ,& + 0 , 0 ,-1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-3 , 0 , 0 ,-2 , 2 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-6 , 3 , 0 ,-2 , 4 ,-2 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-3 , 3 , 0 , 0 , 2 ,-2 ,& + 0 , 0 , 0 , 0 , 1 , 0 ,-3 , 2 ,-2 , 0 , 6 ,-4 , 1 , 0 ,-3 , 2 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-2 , 0 , 0 ,-6 , 4 , 0 , 0 , 3 ,-2 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 0 , 3 ,-2 , 1 , 0 ,-3 , 2 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-3 , 2 , 0 , 0 , 3 ,-2 ,& + 0 , 0 , 0 , 0 , 0 , 1 ,-2 , 1 , 0 ,-2 , 4 ,-2 , 0 , 1 ,-2 , 1 ,& + 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 1 , 0 , 0 , 2 ,-2 , 0 , 0 ,-1 , 1 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 2 ,-1 , 0 , 1 ,-2 , 1 ,& + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 ,-1 , 0 , 0 ,-1 , 1 /), & + & (/ 16, 16 /) ) + + REAL(dp), DIMENSION(16) :: dl_vect + + !---------------------------------------------------------------- + ! init + df_coef(:)=dd_fill + + dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. ) + dl_vect( 5: 8)=PACK(dd_dfdx(:,:),.TRUE. ) + dl_vect( 9:12)=PACK(dd_dfdy(:,:),.TRUE. ) + dl_vect(13:16)=PACK(dd_d2fdxy(:,:),.TRUE. ) + + df_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:)) + + END FUNCTION interp_cubic__2D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__2D_fill(dd_value, id_detect, & + & dd_weight, dd_coef, & + & dd_fill, id_rhoi, id_rhoj) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute cubic interpolation of a 2D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of mixed grid value + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] dd_coef 2D array of coefficient + !> @param[in] dd_fill FillValue of variable + !> @param[in] ld_even even refinment or not + !> @param[in] id_rhoi refinement factor in i-direction + !> @param[in] id_rhoj refinement factor in j-direction + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , INTENT(IN ) :: id_rhoi + INTEGER(I4) , INTENT(IN ) :: id_rhoj + + ! local variable + + ! loop indices + INTEGER(i4) :: ii + + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( ANY( dd_coef(:)==dd_fill ) )THEN + CALL logger_error("INTERP CUBIC FILL: fill value detected in coef . "//& + & "can not compute interpolation.") + ELSE + + ii=0 + DO jj=1,id_rhoj+1 + DO ji=1,id_rhoi+1 + + ii=ii+1 + IF(id_detect(ji,jj)==1)THEN + + dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii)) + id_detect(ji,jj)=0 + + ENDIF + + ENDDO + ENDDO + + ENDIF + + END SUBROUTINE interp_cubic__2D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp_cubic__1D_coef(dd_value, & + & dd_dfdx, & + & dd_fill) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute 1D array of coefficient for cubic interpolation. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_value 1D array of value + !> @param[in] dd_dfdx 1D array of first derivative + !> @param[in] dd_fill FillValue of variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value + REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_dfdx + REAL(dp) , INTENT(IN) :: dd_fill + + ! function + REAL(dp), DIMENSION(4) :: df_coef + + ! local variable + REAL(dp), DIMENSION(4,4), PARAMETER :: dl_matrix = RESHAPE( & + & (/ 1 ,-1 ,-3 , 2 ,& + 0 , 1 , 3 ,-2 ,& + 0 , 0 ,-2 , 1 ,& + 0 , 0 ,-1 , 1 /), & + & (/ 4, 4 /) ) + + REAL(dp), DIMENSION(4) :: dl_vect + + !---------------------------------------------------------------- + ! init + df_coef(:)=dd_fill + + dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. ) + dl_vect( 3: 4)=PACK(dd_dfdx(:),.TRUE. ) + + df_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:)) + + END FUNCTION interp_cubic__1D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__1D_fill(dd_value, id_detect, & + & dd_weight, dd_coef, & + & dd_fill, id_rhoi) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute cubic interpolation of a 1D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of mixed grid value + !> @param[inout] id_detect 1D array of point to be interpolated + !> @param[in] dd_coef 1D array of coefficient + !> @param[in] dd_fill FillValue of variable + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value + INTEGER(i4) , DIMENSION(:) , INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + REAL(dp) , DIMENSION(4) , INTENT(IN ) :: dd_coef + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , INTENT(IN ) :: id_rhoi + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ANY( dd_coef(:)==dd_fill ) )THEN + CALL logger_error("INTERP CUBIC FILL: fill value detected. "//& + & "can not compute interpolation") + ELSE + + DO ji=1,id_rhoi+1 + + IF(id_detect(ji)==1)THEN + + dd_value(ji)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ji)) + id_detect(ji)=0 + + ENDIF + + ENDDO + + ENDIF + + END SUBROUTINE interp_cubic__1D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__get_weight2D(dd_weight, & + & id_rho, ld_even) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute interpoaltion weight for 2D array. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_weight interpolation weight of 2D array + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight + INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho + LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even + + ! local variable + REAL(dp) :: dl_dx + REAL(dp) :: dl_x + REAL(dp) :: dl_x2 + REAL(dp) :: dl_x3 + REAL(dp) :: dl_dy + REAL(dp) :: dl_y + REAL(dp) :: dl_y2 + REAL(dp) :: dl_y3 + + ! loop indices + INTEGER(i4) :: ii + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( ld_even(jp_I) )THEN + dl_dx=1./REAL(id_rho(jp_I)-1) + ELSE ! odd refinement + dl_dx=1./REAL(id_rho(jp_I)) + ENDIF + + IF( ld_even(jp_J) )THEN + dl_dy=1./REAL(id_rho(jp_J)-1) + ELSE ! odd refinement + dl_dy=1./REAL(id_rho(jp_J)) + ENDIF + + ii=0 + DO jj=1,id_rho(jp_J)+1 + + IF( ld_even(jp_J) )THEN + dl_y=(jj-1)*dl_dy - dl_dy*0.5 + ELSE ! odd refinement + dl_y=(jj-1)*dl_dy + ENDIF + dl_y2=dl_y*dl_y + dl_y3=dl_y2*dl_y + + DO ji=1,id_rho(jp_I)+1 + + ! iter + ii=ii+1 + + IF( ld_even(jp_I) )THEN + dl_x=(ji-1)*dl_dx - dl_dx*0.5 + ELSE ! odd refinement + dl_x=(ji-1)*dl_dx + ENDIF + dl_x2=dl_x*dl_x + dl_x3=dl_x2*dl_x + + dd_weight(:,ii)=(/1._dp, dl_x , dl_x2 , dl_x3 , & + & dl_y , dl_x*dl_y , dl_x2*dl_y , dl_x3*dl_y , & + & dl_y2, dl_x*dl_y2, dl_x2*dl_y2, dl_x3*dl_y2, & + & dl_y3, dl_x*dl_y3, dl_x2*dl_y3, dl_x3*dl_y3 /) + + ENDDO + ENDDO + + END SUBROUTINE interp_cubic__get_weight2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_cubic__get_weight1D(dd_weight, & + & id_rho, ld_even) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute interpoaltion weight for 1D array. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_weight interpolation weight of 1D array + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rho + LOGICAL , INTENT(IN ) :: ld_even + + ! local variable + REAL(dp) :: dl_dx + REAL(dp) :: dl_x + REAL(dp) :: dl_x2 + REAL(dp) :: dl_x3 + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ld_even )THEN + dl_dx=1./REAL(id_rho-1) + ELSE ! odd refinement + dl_dx=1./REAL(id_rho) + ENDIF + + DO ji=1,id_rho+1 + IF( ld_even )THEN + dl_x=(ji-1)*dl_dx - dl_dx*0.5 + ELSE ! odd refinement + dl_x=(ji-1)*dl_dx + ENDIF + dl_x2=dl_x*dl_x + dl_x3=dl_x2*dl_x + + dd_weight(:,ji)=(/1._dp, dl_x, dl_x2, dl_x3 /) + ENDDO + + END SUBROUTINE interp_cubic__get_weight1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE interp_cubic diff --git a/V4.0/nemo_sources/tools/SIREN/src/interp_linear.f90 b/V4.0/nemo_sources/tools/SIREN/src/interp_linear.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7b8f1a327b206c13acc474258b25b4313455ff16 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/interp_linear.f90 @@ -0,0 +1,735 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage linear interpolation on regular grid. +!> +!> @details +!> to compute linear interpolation:<br/> +!> @code +!> CALL interp_linear_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] ) +!> @endcode +!> - dd_value is 2D array of variable value +!> - dd_fill is the FillValue of variable +!> - id_detect is 2D array of point to be interpolated (see interp module) +!> - id_rho is array of refinment factor +!> - ld_even indicates even refinment or not +!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not +!> +!> @author +!> J.Paul +!> +!> @date September, 2014 - Initial version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE interp_linear + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE extrap ! extrapolation manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + ! function and subroutine + PUBLIC :: interp_linear_fill !< compute interpolation using linear method + + PRIVATE :: interp_linear__2D !< compute bilinear interpolation on 2D gid + PRIVATE :: interp_linear__1D !< compute linear interpolation on 1D gid + PRIVATE :: interp_linear__2D_coef !< compute coefficient for bilinear interpolation + PRIVATE :: interp_linear__2D_fill !< fill value using bilinear interpolation + PRIVATE :: interp_linear__1D_coef !< compute coefficient for linear interpolation + PRIVATE :: interp_linear__1D_fill !< fill value using linear interpolation + PRIVATE :: interp_linear__get_weight2D !< compute interpoaltion weight for 2D array. + PRIVATE :: interp_linear__get_weight1D !< compute interpoaltion weight for 1D array. + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear_fill(dd_value, dd_fill, id_detect, & + & id_rho, ld_even, ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute horizontal linear interpolation on 4D array of value. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> @date July, 2015 - reinitialise detect array for each level + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rho array of refinment factor + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect + INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho + LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even + LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont + + ! local variable + INTEGER(i4), DIMENSION(4) :: il_shape + + INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect + + LOGICAL :: ll_discont + + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_IJ + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_I + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_weight_J + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + ll_discont=.FALSE. + IF( PRESENT(ld_discont) ) ll_discont=ld_discont + + il_shape(:)=SHAPE(dd_value) + + ! compute vect2D + ALLOCATE(dl_weight_IJ(4,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) ) + CALL interp_linear__get_weight2D(dl_weight_IJ(:,:), & + & id_rho(:), ld_even(:)) + + ALLOCATE( dl_weight_I( 2,((id_rho(jp_I)+1) )) ) + ALLOCATE( dl_weight_J( 2,( (id_rho(jp_J)+1))) ) + CALL interp_linear__get_weight1D(dl_weight_I(:,:), & + & id_rho(jp_I), ld_even(jp_I)) + CALL interp_linear__get_weight1D(dl_weight_J(:,:), & + & id_rho(jp_J), ld_even(jp_J)) + + ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) + + DO jl=1,il_shape(4) + il_detect(:,:,:)=id_detect(:,:,:) + ! loop on vertical level + DO jk=1,il_shape(3) + + ! I-J plan + CALL interp_linear__2D(dd_value(:,:,jk,jl), dd_fill,& + & il_detect(:,:,jk), & + & dl_weight_IJ(:,:), & + & id_rho(jp_I), id_rho(jp_J), & + & ll_discont) + IF( ANY(il_detect(:,:,jk)==1) )THEN + ! I direction + DO jj=1,il_shape(2) + CALL interp_linear__1D( dd_value(:,jj,jk,jl), dd_fill,& + & il_detect(:,jj,jk), & + & dl_weight_I(:,:), & + & id_rho(jp_I), ll_discont ) + ENDDO + IF( ALL(il_detect(:,:,jk)==0) )THEN + CYCLE + ELSE + ! J direction + DO ji=1,il_shape(1) + CALL interp_linear__1D( dd_value(ji,:,jk,jl), dd_fill,& + & il_detect(ji,:,jk), & + & dl_weight_J(:,:), & + & id_rho(jp_J), ll_discont ) + ENDDO + ENDIF + ENDIF + + ENDDO + ENDDO + + id_detect(:,:,:)=il_detect(:,:,:) + DEALLOCATE(il_detect) + + DEALLOCATE(dl_weight_IJ) + DEALLOCATE(dl_weight_I) + DEALLOCATE(dl_weight_J) + + END SUBROUTINE interp_linear_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__2D(dd_value, dd_fill, & + & id_detect, & + & dd_weight, & + & id_rhoi, id_rhoj, & + & ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute linear interpolation on 2D array of value. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rhoi refinment factor in i-direction + !> @param[in] id_rhoj refinment factor in j-direction + !> @param[in] id_rhok refinment factor in k-direction + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rhoi + INTEGER(I4) , INTENT(IN ) :: id_rhoj + LOGICAL , INTENT(IN ) :: ld_discont + + ! local variable + INTEGER(I4) :: il_xextra + INTEGER(I4) :: il_yextra + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(2) :: il_dim + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_coef + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coarse + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: ii + INTEGER(i4) :: ij + + !---------------------------------------------------------------- + + IF( ANY(id_detect(:,:)==1) )THEN + il_shape(:)=SHAPE(dd_value) + + ! compute coarse grid dimension + il_xextra=id_rhoi-1 + il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi + + il_yextra=id_rhoj-1 + il_dim(2)=(il_shape(2)+il_yextra)/id_rhoj + + ALLOCATE( dl_coarse(il_dim(1),il_dim(2)) ) + + ! value on coarse grid + dl_coarse(:,:)=dd_value( 1:il_shape(1):id_rhoi, & + & 1:il_shape(2):id_rhoj ) + + ALLOCATE( dl_tmp(2,2) ) + ALLOCATE( dl_coef(4) ) + + DO jj=1,il_shape(2)-1,id_rhoj + ij=((jj-1)/id_rhoj)+1 + DO ji=1,il_shape(1)-1,id_rhoi + ii=((ji-1)/id_rhoi)+1 + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj)==0) ) CYCLE + ! check data needed to interpolate + IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE + ! check longitude discontinuity + dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1) + IF( ld_discont )THEN + + dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill ) + dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_tmp(:,:) < 0_dp ) + dl_tmp(:,:) = dl_tmp(:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_tmp(:,:) > 180_dp ) + dl_tmp(:,:) = dl_tmp(:,:)-180._dp + END WHERE + ENDIF + + ENDIF + + ! compute bilinear coefficient + dl_coef(:)=interp_linear__2D_coef(dl_tmp(:,:),& + & dd_fill ) + + ! compute value on detetected point + CALL interp_linear__2D_fill(dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ), & + & id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj ), & + & dd_weight(:,:), dl_coef(:),& + & dd_fill, id_rhoi, id_rhoj ) + + IF( ld_discont )THEN + WHERE( dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) >= 180._dp .AND. & + & dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) /= dd_fill ) + dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) = & + & dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) - 360._dp + END WHERE + ENDIF + + ENDDO + ENDDO + + DEALLOCATE(dl_coef) + DEALLOCATE(dl_tmp ) + + DEALLOCATE( dl_coarse ) + ENDIF + + END SUBROUTINE interp_linear__2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__1D(dd_value, dd_fill, & + & id_detect, & + & dd_weight, & + & id_rhoi, & + & ld_discont) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute linear interpolation on 1D array of value. + !> + !> @details + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of variable value + !> @param[in] dd_fill FillValue of variable + !> @param[inout] id_detect 1D array of point to be interpolated + !> @param[in] id_rhoi refinment factor + !> @param[in] ld_even even refinment or not + !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , DIMENSION(:) , INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rhoi + LOGICAL , INTENT(IN ) :: ld_discont + + ! local variable + INTEGER(I4) :: il_xextra + INTEGER(i4), DIMENSION(1) :: il_shape + INTEGER(i4), DIMENSION(1) :: il_dim + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coef + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coarse + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ii + + !---------------------------------------------------------------- + + IF( ANY(id_detect(:)==1) )THEN + il_shape(:)=SHAPE(dd_value) + + ! compute coarse grid dimension + il_xextra=id_rhoi-1 + il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi + + ALLOCATE( dl_coarse(il_dim(1)) ) + + ! value on coarse grid + dl_coarse(:)=dd_value( 1:il_shape(1):id_rhoi ) + + ALLOCATE( dl_tmp(2) ) + ALLOCATE( dl_coef(4) ) + + DO ji=1,il_shape(1)-1,id_rhoi + ii=((ji-1)/id_rhoi)+1 + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE + ! check data needed to interpolate + IF( ANY(dl_coarse(ii:ii+1)==dd_fill) ) CYCLE + ! check longitude discontinuity + dl_tmp(:)=dl_coarse(ii:ii+1) + IF( ld_discont )THEN + + dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill ) + dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_tmp(:) < 0_dp ) + dl_tmp(:) = dl_tmp(:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_tmp(:) > 180_dp ) + dl_tmp(:) = dl_tmp(:)-180._dp + END WHERE + ENDIF + + ENDIF + + ! compute bilinear coefficient + dl_coef(:)=interp_linear__1D_coef(dl_tmp(:), & + & dd_fill ) + + ! compute value on detetected point + CALL interp_linear__1D_fill( dd_value( ji:ji+id_rhoi ), & + & id_detect(ji:ji+id_rhoi ), & + & dd_weight(:,:), dl_coef(:),& + & dd_fill, id_rhoi ) + + IF( ld_discont )THEN + WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. & + & dd_value( ji:ji+id_rhoi ) /= dd_fill ) + dd_value(ji:ji+id_rhoi) = dd_value(ji:ji+id_rhoi) - 360._dp + END WHERE + ENDIF + + ENDDO + + DEALLOCATE(dl_coef) + DEALLOCATE(dl_tmp ) + + DEALLOCATE( dl_coarse ) + ENDIF + + END SUBROUTINE interp_linear__1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp_linear__2D_coef(dd_value, dd_fill) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute 2D array of coefficient for linear interpolation. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_value 2D array of value + !> @param[in] dd_fill FillValue of variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:) , INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + + ! function + REAL(dp), DIMENSION(4) :: df_coef + + ! local variable + REAL(dp), DIMENSION(4,4), PARAMETER :: dl_matrix = RESHAPE( & + & (/ 1 ,-1 ,-1 , 1 ,& + 0 , 1 , 0 ,-1 ,& + 0 , 0 , 1 ,-1 ,& + 0 , 0 , 0 , 1 /), & + & (/ 4, 4 /) ) + + REAL(dp), DIMENSION(4) :: dl_vect + + !---------------------------------------------------------------- + ! init + df_coef(:)=dd_fill + + dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. ) + df_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:)) + + END FUNCTION interp_linear__2D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__2D_fill(dd_value, id_detect, & + & dd_weight, dd_coef, & + & dd_fill, id_rhoi, id_rhoj) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute linear interpolation of a 2D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of mixed grid value + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] dd_coef 2D array of coefficient + !> @param[in] dd_fill FillValue of variable + !> @param[in] ld_even even refinment or not + !> @param[in] id_rhoi refinement factor in i-direction + !> @param[in] id_rhoj refinement factor in j-direction + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , INTENT(IN ) :: id_rhoi + INTEGER(I4) , INTENT(IN ) :: id_rhoj + + ! local variable + + ! loop indices + INTEGER(i4) :: ii + + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( ANY( dd_coef(:)==dd_fill ) )THEN + CALL logger_error("INTERP LINEAR FILL: fill value detected in coef. "//& + & "can not compute interpolation.") + ELSE + + ii=0 + DO jj=1,id_rhoj+1 + DO ji=1,id_rhoi+1 + + ii=ii+1 + IF(id_detect(ji,jj)==1)THEN + + dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii)) + id_detect(ji,jj)=0 + + ENDIF + + ENDDO + ENDDO + + ENDIF + + END SUBROUTINE interp_linear__2D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION interp_linear__1D_coef(dd_value, dd_fill) & + & RESULT (df_coef) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute 1D array of coefficient for linear interpolation. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_value 1D array of value + !> @param[in] dd_fill FillValue of variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + + ! function + REAL(dp), DIMENSION(2) :: df_coef + + ! local variable + REAL(dp), DIMENSION(2,2), PARAMETER :: dl_matrix = RESHAPE( & + & (/ 1 ,-1 ,& + 0 , 1 /), & + & (/ 2, 2 /) ) + + REAL(dp), DIMENSION(2) :: dl_vect + + !---------------------------------------------------------------- + ! init + df_coef(:)=dd_fill + + dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. ) + df_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:)) + + END FUNCTION interp_linear__1D_coef + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__1D_fill(dd_value, id_detect, & + & dd_weight, dd_coef, & + & dd_fill, id_rho) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute linear interpolation of a 1D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of mixed grid value + !> @param[inout] id_detect 1D array of point to be interpolated + !> @param[in] dd_coef 1D array of coefficient + !> @param[in] dd_fill FillValue of variable + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value + INTEGER(i4) , DIMENSION(:) , INTENT(INOUT) :: id_detect + REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef + REAL(dp) , INTENT(IN ) :: dd_fill + INTEGER(I4) , INTENT(IN ) :: id_rho + + ! local variable + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ANY( dd_coef(:)==dd_fill ) )THEN + CALL logger_error("INTERP LINEAR FILL: fill value detected. "//& + & "can not compute interpolation") + ELSE + + DO ji=1,id_rho+1 + + IF(id_detect(ji)==1)THEN + + dd_value(ji)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ji)) + id_detect(ji)=0 + + ENDIF + + ENDDO + + ENDIF + + END SUBROUTINE interp_linear__1D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__get_weight2D(dd_weight, id_rho, ld_even) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute interpoaltion weight for 2D array. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_weight interpolation weight of 2D array + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight + INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho + LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even + + ! local variable + REAL(dp) :: dl_dx + REAL(dp) :: dl_x + REAL(dp) :: dl_dy + REAL(dp) :: dl_y + + ! loop indices + INTEGER(i4) :: ii + + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( ld_even(jp_I) )THEN + dl_dx=1._dp/REAL(id_rho(jp_I)-1,dp) + ELSE ! odd refinement + dl_dx=1._dp/REAL(id_rho(jp_I),dp) + ENDIF + + IF( ld_even(jp_J) )THEN + dl_dy=1._dp/REAL(id_rho(jp_J)-1,dp) + ELSE ! odd refinement + dl_dy=1._dp/REAL(id_rho(jp_J),dp) + ENDIF + + ii=0 + DO jj=1,id_rho(jp_J)+1 + + IF( ld_even(jp_J) )THEN + dl_y=REAL(jj-1,dp)*dl_dy - dl_dy*0.5_dp + ELSE ! odd refinement + dl_y=REAL(jj-1,dp)*dl_dy + ENDIF + + DO ji=1,id_rho(jp_I)+1 + + ! iter + ii=ii+1 + + IF( ld_even(jp_I) )THEN + dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp + ELSE ! odd refinement + dl_x=REAL(ji-1,dp)*dl_dx + ENDIF + + dd_weight(:,ii)=(/1._dp, dl_x, dl_y, dl_x*dl_y /) + + ENDDO + ENDDO + + END SUBROUTINE interp_linear__get_weight2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_linear__get_weight1D(dd_weight, id_rho, ld_even) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute interpoaltion weight for 1D array. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] dd_weight interpolation weight of 1D array + !> @param[in] ld_even even refinment or not + !> @param[in] id_rho refinement factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight + INTEGER(I4) , INTENT(IN ) :: id_rho + LOGICAL , INTENT(IN ) :: ld_even + + ! local variable + REAL(dp) :: dl_dx + REAL(dp) :: dl_x + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ld_even )THEN + dl_dx=1._dp/REAL(id_rho-1,dp) + ELSE ! odd refinement + dl_dx=1._dp/REAL(id_rho,dp) + ENDIF + + DO ji=1,id_rho+1 + IF( ld_even )THEN + dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp + ELSE ! odd refinement + dl_x=REAL(ji-1,dp)*dl_dx + ENDIF + + dd_weight(:,ji)=(/1._dp, dl_x /) + ENDDO + + END SUBROUTINE interp_linear__get_weight1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE interp_linear diff --git a/V4.0/nemo_sources/tools/SIREN/src/interp_nearest.f90 b/V4.0/nemo_sources/tools/SIREN/src/interp_nearest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d39128f0424b5a1963333d447b5537672b210961 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/interp_nearest.f90 @@ -0,0 +1,369 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage nearest interpolation on regular grid. +!> +!> @details +!> to compute nearest interpolation:<br/> +!> @code +!> CALL interp_nearest_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] ) +!> @endcode +!> - dd_value is 2D array of variable value +!> - dd_fill is the FillValue of variable +!> - id_detect is 2D array of point to be interpolated (see interp module) +!> - id_rho is array of refinment factor +!> - ld_even indicates even refinment or not +!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not +!> +!> @author +!> J.Paul +!> +!> @date September, 2014 - Initial version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE interp_nearest + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + ! function and subroutine + PUBLIC :: interp_nearest_fill !< compute interpolation using nearest method + + PRIVATE :: interp_nearest__2D !< compute binearest interpolation on 2D gid + PRIVATE :: interp_nearest__1D !< compute nearest interpolation on 1D gid + PRIVATE :: interp_nearest__2D_fill !< fill value using binearest interpolation + PRIVATE :: interp_nearest__1D_fill !< fill value using nearest interpolation + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_nearest_fill(dd_value, id_detect, id_rho) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute horizontal nearest interpolation on 4D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rho array of refinment factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value + INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect + INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho + + ! local variable + INTEGER(i4), DIMENSION(4) :: il_shape + + INTEGER(I4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(dd_value) + + ALLOCATE(il_detect(il_shape(1),il_shape(2),il_shape(3))) + DO jl=1,il_shape(4) + il_detect(:,:,:)=id_detect(:,:,:) + ! loop on vertical level + DO jk=1,il_shape(3) + + ! I-J plan + CALL interp_nearest__2D(dd_value(:,:,jk,jl),& + & il_detect(:,:,jk), & + & id_rho(jp_I), id_rho(jp_J) ) + IF( ANY(il_detect(:,:,jk)==1) )THEN + ! I direction + DO jj=1,il_shape(2) + CALL interp_nearest__1D( dd_value(:,jj,jk,jl),& + & il_detect(:,jj,jk), & + & id_rho(jp_I) ) + ENDDO + IF( ALL(il_detect(:,:,jk)==0) )THEN + CYCLE + ELSE + ! J direction + DO ji=1,il_shape(1) + CALL interp_nearest__1D( dd_value(ji,:,jk,jl),& + & il_detect(ji,:,jk), & + & id_rho(jp_J) ) + ENDDO + ENDIF + ENDIF + + ENDDO + ENDDO + + id_detect(:,:,:)=il_detect(:,:,:) + DEALLOCATE(il_detect) + + END SUBROUTINE interp_nearest_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_nearest__2D(dd_value, id_detect, id_rhoi, id_rhoj) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute nearest interpolation on 2D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of variable value + !> @param[inout] id_detect 2D array of point to be interpolated + !> @param[in] id_rhoi refinment factor in i-direction + !> @param[in] id_rhoj refinment factor in j-direction + !> @param[in] id_rhok refinment factor in k-direction + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value + INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect + INTEGER(I4) , INTENT(IN ) :: id_rhoi + INTEGER(I4) , INTENT(IN ) :: id_rhoj + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + + !---------------------------------------------------------------- + + IF( ANY(id_detect(:,:)==1) )THEN + + il_shape(:)=SHAPE(dd_value) + + DO jj=1,il_shape(2)-1,id_rhoj + DO ji=1,il_shape(1)-1,id_rhoi + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj)==0) ) CYCLE + + ! compute value on detetected point + CALL interp_nearest__2D_fill(dd_value( ji:ji+id_rhoi, & + & jj:jj+id_rhoj ), & + & id_detect(ji:ji+id_rhoi, & + & jj:jj+id_rhoj ) ) + + ENDDO + ENDDO + + ENDIF + + END SUBROUTINE interp_nearest__2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_nearest__1D(dd_value, id_detect, id_rhoi) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute nearest interpolation on 1D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of variable value + !> @param[inout] id_detect 1D array of point to be interpolated + !> @param[in] id_rhoi refinment factor + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value + INTEGER(I4) , DIMENSION(:), INTENT(INOUT) :: id_detect + INTEGER(I4) , INTENT(IN ) :: id_rhoi + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_shape + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ANY(id_detect(:)==1) )THEN + il_shape(:)=SHAPE(dd_value) + + DO ji=1,il_shape(1)-1,id_rhoi + + ! check if point to be interpolated + IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE + + ! compute value on detetected point + CALL interp_nearest__1D_fill( dd_value( ji:ji+id_rhoi ), & + & id_detect(ji:ji+id_rhoi ) ) + + ENDDO + + ENDIF + + END SUBROUTINE interp_nearest__1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_nearest__2D_fill(dd_value, id_detect) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute nearest interpolation of a 2D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 2D array of mixed grid value + !> @param[inout] id_detect 2D array of point to be interpolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:) , INTENT(INOUT) :: dd_value + INTEGER(i4), DIMENSION(:,:) , INTENT(INOUT) :: id_detect + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape + + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + INTEGER(i4) :: il_j1 + INTEGER(i4) :: il_j2 + + INTEGER(i4) :: il_half1 + INTEGER(i4) :: il_half2 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(dd_value(:,:)) + + il_i1=1 + il_i2=il_shape(1) + + il_j1=1 + il_j2=il_shape(2) + + il_half1=CEILING(il_shape(1)*0.5) + il_half2=CEILING(il_shape(2)*0.5) + + DO jj=1,il_half2 + + DO ji=1,il_half1 + + ! lower left point + IF(id_detect(ji,jj)==1)THEN + + dd_value( ji,jj)=dd_value(il_i1,il_j1) + id_detect(ji,jj)=0 + + ENDIF + + ! lower right point + IF(id_detect(il_shape(1)-ji+1,jj)==1)THEN + + dd_value( il_shape(1)-ji+1,jj)=dd_value(il_i2,il_j1) + id_detect(il_shape(1)-ji+1,jj)=0 + + ENDIF + + ! upper left point + IF(id_detect(ji,il_shape(2)-jj+1)==1)THEN + + dd_value( ji,il_shape(2)-jj+1)=dd_value(il_i1,il_j2) + id_detect(ji,il_shape(2)-jj+1)=0 + + ENDIF + + ! upper right point + IF(id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)==1)THEN + + dd_value( il_shape(1)-ji+1,il_shape(2)-jj+1)=dd_value(il_i2,il_j2) + id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)=0 + + ENDIF + + ENDDO + + ENDDO + + END SUBROUTINE interp_nearest__2D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE interp_nearest__1D_fill(dd_value, id_detect) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute nearest interpolation of a 1D array of value. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] dd_value 1D array of mixed grid value + !> @param[inout] id_detect 1D array of point to be interpolated + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value + INTEGER(i4), DIMENSION(:), INTENT(INOUT) :: id_detect + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_shape + + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + + INTEGER(i4) :: il_half1 + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + il_shape(:)=SHAPE(dd_value) + + il_i1=1 + il_i2=il_shape(1) + + il_half1=CEILING(il_shape(1)*0.5) + + DO ji=1,il_half1 + + ! lower left point + IF(id_detect(ji)==1)THEN + + dd_value( ji)=dd_value(il_i1) + id_detect(ji)=0 + + ENDIF + + ! lower right point + IF(id_detect(il_shape(1)-ji+1)==1)THEN + + dd_value( il_shape(1)-ji+1)=dd_value(il_i2) + id_detect(il_shape(1)-ji+1)=0 + + ENDIF + + ENDDO + + END SUBROUTINE interp_nearest__1D_fill + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE interp_nearest diff --git a/V4.0/nemo_sources/tools/SIREN/src/iom.f90 b/V4.0/nemo_sources/tools/SIREN/src/iom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c36ecd7cd1adce62bc0ad69d73bbaaa20cd0cb0b --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/iom.f90 @@ -0,0 +1,733 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief Input/Output manager : Library to read input files +!> +!> @details +!> to open file:<br/> +!> @code +!> CALL iom_open(td_file) +!> @endcode +!> - td_file is file structure +!> +!> to create file:<br/> +!> @code +!> CALL iom_create(td_file) +!> @endcode +!> - td_file is file structure +!> +!> to write in file:<br/> +!> @code +!> CALL iom_write_file(td_file) +!> @endcode +!> +!> to close file:<br/> +!> @code +!> CALL iom_close(tl_file) +!> @endcode +!> +!> to read one dimension in file:<br/> +!> @code +!> tl_dim = iom_read_dim(tl_file, id_dimid) +!> @endcode +!> or<br/> +!> @code +!> tl_dim = iom_read_dim(tl_file, cd_name) +!> @endcode +!> - id_dimid is dimension id +!> - cd_name is dimension name +!> +!> to read variable or global attribute in file:<br/> +!> @code +!> tl_att = iom_read_att(tl_file, id_varid, id_attid) +!> @endcode +!> or +!> @code +!> tl_att = iom_read_att(tl_file, id_varid, cd_attname) +!> @endcode +!> or +!> @code +!> tl_att = iom_read_att(tl_file, cd_varname, id_attid) +!> @endcode +!> or +!> @code +!> tl_att = iom_read_att(tl_file, cd_varname, cd_attname) +!> @endcode +!> - id_varid is variable id +!> - id_attid is attribute id +!> - cd_attname is attribute name +!> - cd_varname is variable name or standard name +!> +!> to read one variable in file:<br/> +!> @code +!> tl_var = iom_read_var(td_file, id_varid, [id_start, id_count]) +!> @endcode +!> or +!> @code +!> tl_var = iom_read_var(td_file, cd_name, [id_start, [id_count,]]) +!> @endcode +!> - id_varid is variabale id +!> - cd_name is variabale name or standard name. +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date August, 2017 +!> - permit to write header and variable independantly +!> +!> @todo +!> - see lbc_lnk +!> - see goup netcdf4 +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE iom + + USE netcdf ! nf90 library + USE global ! global parameter + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + USE dim ! dimension manager + USE att ! attribute manager + USE var ! variable manager + USE file ! file manager + USE iom_cdf ! netcdf I/O manager + USE iom_rstdimg ! restart dimg I/O manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: iom_open !< open or create file, fill file structure + PUBLIC :: iom_create !< create file, fill file structure + PUBLIC :: iom_close !< close file + PUBLIC :: iom_read_dim !< read one dimension in an opened file + PUBLIC :: iom_read_att !< read one attribute in an opened file + PUBLIC :: iom_read_var !< read one variable in an opened file + PUBLIC :: iom_write_file !< write file structure contents in an opened file + PUBLIC :: iom_write_header!< write header in an opened file + PUBLIC :: iom_write_var !< write variable an opened file + + ! read variable or global attribute in an opened file + PRIVATE :: iom__read_att_varname_id ! given variable name or standard name and attribute id. + PRIVATE :: iom__read_att_varid_id ! given variable id and attribute id. + PRIVATE :: iom__read_att_varname_name ! given variable name or standard name, and attribute name. + PRIVATE :: iom__read_att_varid_name ! given variable id and attribute name. + + PRIVATE :: iom__read_dim_id ! read one dimension in an opened file, given dimension id. + PRIVATE :: iom__read_dim_name ! read one dimension in an opened netcdf file, given dimension name. + PRIVATE :: iom__read_var_id ! read variable value in an opened file, given variable id. + PRIVATE :: iom__read_var_name ! read variable value in an opened file, given variable name or standard name. + + INTERFACE iom_read_var + MODULE PROCEDURE iom__read_var_id + MODULE PROCEDURE iom__read_var_name + END INTERFACE iom_read_var + + INTERFACE iom_read_dim + MODULE PROCEDURE iom__read_dim_id + MODULE PROCEDURE iom__read_dim_name + END INTERFACE iom_read_dim + + INTERFACE iom_read_att !< read variable or global attribute in an opened file + MODULE PROCEDURE iom__read_att_varname_id !< given variable name or standard name and attribute id. + MODULE PROCEDURE iom__read_att_varid_id !< given variable id and attribute id. + MODULE PROCEDURE iom__read_att_varname_name !< given variable name or standard name, and attribute name. + MODULE PROCEDURE iom__read_att_varid_name !< given variable id and attribute name. + END INTERFACE iom_read_att + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_open(td_file) + !------------------------------------------------------------------- + !> @brief This function open a file in read or write mode + !> @details + !> If try to open a file in write mode that did not exist, create it.<br/> + !> + !> If file exist, get information about: + !> - the number of variables + !> - the number of dimensions + !> - the number of global attributes + !> - the ID of the unlimited dimension + !> - the file format + !> and finally read dimensions. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + !---------------------------------------------------------------- + + ! add suffix to file name + td_file%c_name = file_add_suffix( TRIM(td_file%c_name), & + & TRIM(td_file%c_type) ) + ! check type + SELECT CASE(TRIM(ADJUSTL(fct_lower(td_file%c_type)))) + + CASE('cdf') + CALL iom_cdf_open(td_file) + !CASE('cdf4') + CASE('dimg') + CALL iom_rstdimg_open(td_file) + CASE DEFAULT + CALL logger_error("IOM OPEN: unknow type : "//TRIM(td_file%c_name)) + + END SELECT + + END SUBROUTINE iom_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_create(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine create a file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + LOGICAL :: ll_exist + !---------------------------------------------------------------- + + INQUIRE(FILE=TRIM(td_file%c_name), EXIST=ll_exist ) + IF( ll_exist )THEN + CALL logger_fatal("IOM CREATE: can not create file "//& + & TRIM(td_file%c_name)//". file exist already.") + ENDIF + + ! forced to open in write mode + td_file%l_wrt=.TRUE. + ! check type + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + CALL iom_cdf_open(td_file) + CASE('dimg') + CALL iom_rstdimg_open(td_file) + CASE DEFAULT + CALL logger_error( "IOM CREATE: can't create file "//& + & TRIM(td_file%c_name)//": type unknown " ) + END SELECT + + END SUBROUTINE iom_create + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_close(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine close file + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + CALL iom_cdf_close(td_file) + CASE('dimg') + CALL iom_rstdimg_close(td_file) + CASE DEFAULT + CALL logger_debug( "IOM CLOSE: type "//TRIM(td_file%c_type)) + CALL logger_error( "IOM CLOSE: can't close file "//& + & TRIM(td_file%c_name)//": type unknown " ) + END SELECT + + END SUBROUTINE iom_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_att_varname_id(td_file, cd_varname, id_attid) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read attribute (of variable or global) in an opened + !> file, given variable name or standard name and attribute id. + !> @details + !> - to get global attribute use 'GLOBAL' as variable name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_varname variable name. use 'GLOBAL' to read global + !> attribute in a file + !> @param[in] id_attid attribute id + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=lc), INTENT(IN) :: cd_varname + INTEGER(i4), INTENT(IN) :: id_attid + + ! function + TYPE(TATT) :: tf_att + + ! local variable + INTEGER(i4) :: il_varid + !---------------------------------------------------------------- + + ! get variable id + IF( TRIM(fct_upper(cd_varname)) == 'GLOBAL' )THEN + il_varid=NF90_GLOBAL + ELSE + il_varid=var_get_id(td_file%t_var(:), cd_varname) + ENDIF + + IF( il_varid /= 0 .OR. TRIM(fct_upper(cd_varname)) == 'GLOBAL' )THEN + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_att=iom_read_att( td_file, il_varid, id_attid) + CASE('dimg') + CALL logger_warn( " IOM READ ATT: can't read attribute "//& + & "in dimg file : "//TRIM(td_file%c_name) ) + CASE DEFAULT + CALL logger_error( " IOM READ ATT: can't read attribute "//& + & " in file "//TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + ENDIF + + END FUNCTION iom__read_att_varname_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_att_varid_id(td_file, id_varid, id_attid) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read attribute (of variable or global) in an opened + !> file, given variable id and attribute id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id. use NF90_GLOBAL to read global + !> attribute in a file + !> @param[in] id_attid attribute id + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), INTENT(IN) :: id_attid + + ! function + TYPE(TATT) :: tf_att + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_att=iom_cdf_read_att(td_file, id_varid, id_attid) + CASE('dimg') + CALL logger_warn( " IOM READ ATT: can't read attribute in dimg file "//& + & TRIM(td_file%c_name) ) + CASE DEFAULT + CALL logger_error( " IOM READ ATT: can't read attribute in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_att_varid_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_att_varname_name(td_file, cd_varname, cd_attname) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read attribute (of variable or global) in an opened + !> file, given variable name or standard name, and attribute name. + !> @details + !> - to get global attribute use 'GLOBAL' as variable name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_varname variable name or standard name. use 'GLOBAL' to read global + !> attribute in a file + !> @param[in] cd_attname attribute name + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_varname + CHARACTER(LEN=*), INTENT(IN) :: cd_attname + + ! function + TYPE(TATT) :: tf_att + + ! local variable + INTEGER(i4) :: il_varid + !---------------------------------------------------------------- + + ! get variable id + IF( TRIM(fct_upper(cd_varname)) == 'GLOBAL' )THEN + il_varid=NF90_GLOBAL + ELSE + il_varid=var_get_id(td_file%t_var(:), cd_varname) + ENDIF + + IF( il_varid /= 0 .OR. TRIM(fct_upper(cd_varname)) == 'GLOBAL' )THEN + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_att=iom_cdf_read_att(td_file, il_varid, cd_attname) + CASE('dimg') + CALL logger_warn( " IOM READ ATT: can't read attribute "//& + & "in dimg file :"//TRIM(td_file%c_name) ) + CASE DEFAULT + CALL logger_error( " IOM READ ATT: can't read attribute in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + ENDIF + + END FUNCTION iom__read_att_varname_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_att_varid_name(td_file, id_varid, cd_attname) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read attribute (of variable or global) in an opened + !> file, given variable id and attribute name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id. use NF90_GLOBAL to read global + !> attribute in a file + !> @param[in] cd_attname attribute name + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + CHARACTER(LEN=*), INTENT(IN) :: cd_attname + + ! function + TYPE(TATT) :: tf_att + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_att=iom_cdf_read_att(td_file, id_varid, cd_attname) + CASE('dimg') + CALL logger_warn( " IOM READ ATT: can't read attribute in dimg file :"& + & //TRIM(td_file%c_name) ) + CASE DEFAULT + CALL logger_error( " IOM READ ATT: can't read attribute in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_att_varid_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_dim_id(td_file, id_dimid) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened file, + !> given dimension id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_dimid dimension id + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_dimid + + ! function + TYPE(TDIM) :: tf_dim + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_dim=iom_cdf_read_dim(td_file, id_dimid) + CASE('dimg') + tf_dim=iom_rstdimg_read_dim(td_file, id_dimid) + CASE DEFAULT + CALL logger_error( " IOM READ DIM: can't read dimension in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_dim_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_dim_name(td_file, cd_name) & + & RESULT(tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened netcdf file, + !> given dimension name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name dimension name + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + TYPE(TDIM) :: tf_dim + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_dim=iom_cdf_read_dim(td_file, cd_name) + CASE('dimg') + tf_dim=iom_rstdimg_read_dim(td_file, cd_name) + CASE DEFAULT + CALL logger_error( " IOM READ DIM: can't read dimension in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_dim_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_var_id(td_file, id_varid, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> file, given variable id. + !> @details + !> start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_var=iom_cdf_read_var(td_file, id_varid, id_start, id_count) + CASE('dimg') + tf_var=iom_rstdimg_read_var(td_file, id_varid, id_start, id_count) + CASE DEFAULT + CALL logger_error( " IOM READ VAR: can't read variable in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom__read_var_name(td_file, cd_name, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> file, given variable name or standard name. + !> @details + !> start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name variable name or standard name + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(IN) :: td_file + CHARACTER(LEN=*) , INTENT(IN) :: cd_name + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + tf_var=iom_cdf_read_var(td_file, cd_name, id_start, id_count ) + CASE('dimg') + tf_var=iom_rstdimg_read_var(td_file, cd_name, id_start, id_count ) + CASE DEFAULT + CALL logger_error( " IOM READ VAR: can't read variable in file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END FUNCTION iom__read_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_write_file(td_file, cd_dimorder) + !------------------------------------------------------------------- + !> @brief This subroutine write file structure in an opened file. + !> + !> @details + !> optionally, you could specify dimension order (default 'xyzt') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 - add dimension order option + !> @date August, 2017 + !> - split in write_header and write_var + !> + !> @param[in] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder + !---------------------------------------------------------------- + + CALL iom_write_header(td_file, cd_dimorder) + + CALL iom_write_var(td_file) + + END SUBROUTINE iom_write_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_write_header(td_file, cd_dimorder, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine write header from file structure + !> of an opened file. + !> + !> @details + !> optionally, you could specify dimension order (default 'xyzt'), + !> and dimension structure for netcdf case. + !> + !> @author J.Paul + !> @date August, 2017 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_dimorder dimension order + !> @param[in] td_dim array of dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*) , INTENT(IN ), OPTIONAL :: cd_dimorder + TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN ), OPTIONAL :: td_dim + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + CALL iom_cdf_write_header(td_file, cd_dimorder, td_dim) + CASE('dimg') + ! note: can not change dimension order in restart dimg file + CALL iom_rstdimg_write_header(td_file) + CASE DEFAULT + CALL logger_error( " IOM WRITE HEADER: can't write header& + & , file "//TRIM(td_file%c_name)//" : & + & type unknown " ) + END SELECT + + END SUBROUTINE iom_write_header + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_write_var(td_file, cd_dimorder, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine write variables from file structure + !> in an opened file. + !> + !> @details + !> + !> @author J.Paul + !> @date August, 2017 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_dimorder dimension order + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*) , INTENT(IN ), OPTIONAL :: cd_dimorder + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + !---------------------------------------------------------------- + + ! open file + SELECT CASE(TRIM(td_file%c_type)) + CASE('cdf') + CALL iom_cdf_write_var(td_file, cd_dimorder, & + & id_start, id_count) + CASE('dimg') + ! note: can not change dimension order in restart dimg file + CALL iom_rstdimg_write_var(td_file) + CASE DEFAULT + CALL logger_error( " IOM WRITE VAR: can't write variable, file "//& + & TRIM(td_file%c_name)//" : type unknown " ) + END SELECT + + END SUBROUTINE iom_write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE iom + diff --git a/V4.0/nemo_sources/tools/SIREN/src/iom_cdf.f90 b/V4.0/nemo_sources/tools/SIREN/src/iom_cdf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c4624ac919a6d6f1f0c8eadccfa51fe86d962f94 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/iom_cdf.f90 @@ -0,0 +1,2714 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief NETCDF Input/Output manager : Library to read Netcdf input files +!> +!> @details +!> to open netcdf file:<br/> +!> @code +!> CALL iom_cdf_open(td_file) +!> @endcode +!> - td_file is file structure (see @ref file) +!> +!> to write in netcdf file:<br/> +!> @code +!> CALL iom_cdf_write_file(td_file) +!> @endcode +!> +!> to close netcdf file:<br/> +!> @code +!> CALL iom_cdf_close(tl_file) +!> @endcode +!> +!> to read one dimension in netcdf file:<br/> +!> @code +!> tl_dim = iom_cdf_read_dim(tl_file, id_dimid) +!> @endcode +!> or +!> @code +!> tl_dim = iom_cdf_read_dim(tl_file, cd_name) +!> @endcode +!> - id_dimid is dimension id<br/> +!> - cd_name is dimension name +!> +!> to read one attribute in netcdf file:<br/> +!> @code +!> tl_att = iom_cdf_read_att(tl_file, id_varid, id_attid) +!> @endcode +!> or +!> @code +!> tl_att = iom_cdf_read_att(tl_file, id_varid, cd_name) +!> @endcode +!> - id_varid is variable id +!> - id_attid is attribute id<br/> +!> - cd_name is attribute name +!> +!> to read one variable in netcdf file:<br/> +!> @code +!> tl_var = iom_cdf_read_var(td_file, id_varid, [id_start, id_count]) +!> @endcode +!> or +!> @code +!> tl_var = iom_cdf_read_var(td_file, cd_name, [id_start, [id_count,]]) +!> @endcode +!> - id_varid is variabale id +!> - cd_name is variabale name +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date August, 2017 +!> - permit to write header and variable independantly +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE iom_cdf + + USE netcdf ! nf90 library + USE global ! global parameter + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + USE att ! attribute manage + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: iom_cdf_open !< open or create netcdf file, return file structure + PUBLIC :: iom_cdf_close !< close netcdf file + PUBLIC :: iom_cdf_read_dim !< read one dimension in an opened netcdf file, return dimension structure + PUBLIC :: iom_cdf_read_att !< read one attribute in an opened netcdf file, return attribute structure + PUBLIC :: iom_cdf_read_var !< read one variable in an opened netcdf file, return variable structure + PUBLIC :: iom_cdf_fill_var !< fill variable value in an opened netcdf file + PUBLIC :: iom_cdf_write_header !< write header in an opened netcdf file + PUBLIC :: iom_cdf_write_var !< write variables in an opened netcdf file + + PRIVATE :: iom_cdf__check ! provides a simple interface to netcdf error message + PRIVATE :: iom_cdf__get_info ! get global information in an opened netcdf file + PRIVATE :: iom_cdf__get_file_dim ! read dimension on an opened netcdf file, and reorder it + PRIVATE :: iom_cdf__get_file_att ! read global attribute on an opened netcdf file + PRIVATE :: iom_cdf__get_file_var ! read information about variable on an opened netcdf file + PRIVATE :: iom_cdf__read_dim_id ! read one dimension in an opened netcdf file, given dimension id. + PRIVATE :: iom_cdf__read_dim_name ! read one dimension in an opened netcdf file, given dimension name. + PRIVATE :: iom_cdf__read_att_name ! read variable or global attribute in an opened netcdf file, given attribute name. + PRIVATE :: iom_cdf__read_att_id ! read variable or global attribute in an opened netcdf file, given attribute id. + PRIVATE :: iom_cdf__read_var_id ! read variable value in an opened netcdf file, given variable id. + PRIVATE :: iom_cdf__read_var_name ! read variable value in an opened netcdf file, given variable name or standard name. + PRIVATE :: iom_cdf__read_var_meta ! read metadata of a variable in an opened netcdf file. + PRIVATE :: iom_cdf__read_var_dim ! read variable dimension in an opened netcdf file. + PRIVATE :: iom_cdf__read_var_att ! read variable attributes in an opened netcdf file. + PRIVATE :: iom_cdf__read_var_value ! read variable value in an opened netcdf file. + PRIVATE :: iom_cdf__write_dim_def ! write dimension definition in an opened netcdf file. + PRIVATE :: iom_cdf__write_att_def ! write attribute definition in an opened netcdf file. + PRIVATE :: iom_cdf__write_var_def ! write variable definition in an opened netcdf file. + PRIVATE :: iom_cdf__write_var ! write a variable in an opened netcdf file. + PRIVATE :: iom_cdf__write_var_value ! put variable value in an opened netcdf file. + PRIVATE :: iom_cdf__fill_var_id ! fill variable value in an opened netcdf file, given variable id + PRIVATE :: iom_cdf__fill_var_name ! fill variable value in an opened netcdf file, given variable name + PRIVATE :: iom_cdf__fill_var_all ! fill all variable value in an opened netcdf file + PRIVATE :: iom_cdf__del_coord_var ! remove coordinate variable from an opened netcdf file + + INTERFACE iom_cdf_read_var + MODULE PROCEDURE iom_cdf__read_var_id + MODULE PROCEDURE iom_cdf__read_var_name + END INTERFACE iom_cdf_read_var + + INTERFACE iom_cdf_fill_var + MODULE PROCEDURE iom_cdf__fill_var_id + MODULE PROCEDURE iom_cdf__fill_var_name + MODULE PROCEDURE iom_cdf__fill_var_all + END INTERFACE iom_cdf_fill_var + + INTERFACE iom_cdf_read_dim + MODULE PROCEDURE iom_cdf__read_dim_id + MODULE PROCEDURE iom_cdf__read_dim_name + END INTERFACE iom_cdf_read_dim + + INTERFACE iom_cdf_read_att + MODULE PROCEDURE iom_cdf__read_att_id + MODULE PROCEDURE iom_cdf__read_att_name + END INTERFACE iom_cdf_read_att + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__check(id_status, cd_msg) + !------------------------------------------------------------------- + !> @brief This subroutine provides a simple interface to + !> netcdf error message + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date May, 2015 + !> - add optional message to netcdf error message + !> + !> @param[in] id_status error status + !> @param[in] cd_msg message + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4) , INTENT(IN) :: id_status + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_msg + ! local variable + CHARACTER(LEN=lc) :: cl_msg + !---------------------------------------------------------------- + + cl_msg="" + IF( PRESENT(cd_msg) ) cl_msg=cd_msg + + IF( id_status /= NF90_NOERR )THEN + CALL logger_error(TRIM(cl_msg)//TRIM(NF90_STRERROR(id_status))) + ENDIF + + END SUBROUTINE iom_cdf__check + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf_open(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine open a netcdf file in read or write mode. + !> @details + !> if try to open a file in write mode that did not exist, create it.<br/> + !> if file already exist, get information about0:<br/> + !> - the number of variables + !> - the number of dimensions + !> - the number of global attributes + !> - the ID of the unlimited dimension + !> - the file format + !> Finally it read dimensions, and 'longitude' variable to compute East-West + !> overlap. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2018 + !> - write netcdf file as netcdf4 + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + LOGICAL :: ll_exist + LOGICAL :: ll_open + + INTEGER(i4) :: il_status + INTEGER(i4) :: il_oldmode + !---------------------------------------------------------------- + + ! check file existence + INQUIRE(FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open) + ! ll_open do not work for netcdf file, always return FALSE + IF( .NOT. ll_exist .OR. TRIM(td_file%c_type) /= 'cdf' )THEN + + IF( .NOT. td_file%l_wrt )THEN + + CALL logger_fatal( " IOM CDF OPEN: can not open file "//& + & TRIM(td_file%c_name) ) + + ELSE + + CALL logger_info( " IOM CDF CREATE: file "//TRIM(td_file%c_name) ) + + il_status = NF90_CREATE(TRIM(td_file%c_name),& + & cmode=NF90_NETCDF4, & + & ncid=td_file%i_id) + CALL iom_cdf__check(il_status," IOM CDF CREATE: ") + il_status = NF90_SET_FILL(td_file%i_id, & + & NF90_NOFILL, & + & il_oldmode) + CALL iom_cdf__check(il_status," IOM CDF SET FILL: ") + + td_file%l_def=.TRUE. + CALL logger_debug( " IOM CDF CREATE: td_file%l_def"//fct_str(td_file%l_def)) + + ENDIF + + ELSE + + IF( td_file%i_id /= 0 )THEN + + CALL logger_error( " IOM CDF OPEN: file "//& + & TRIM(td_file%c_name)//" already opened") + + ELSE + + IF( .NOT. td_file%l_wrt )THEN + + CALL logger_info( " IOM CDF OPEN: file "//& + & TRIM(td_file%c_name)//" in read only mode" ) + + il_status = NF90_OPEN( TRIM(td_file%c_name), & + & NF90_NOWRITE, & + & td_file%i_id) + CALL iom_cdf__check(il_status," IOM CDF OPEN: ") + + ELSE + + CALL logger_info( "IOM CDF OPEN: file "//& + & TRIM(td_file%c_name)//" in write mode" ) + + il_status = NF90_OPEN( TRIM(td_file%c_name), & + & NF90_WRITE, & + & td_file%i_id) + CALL iom_cdf__check(il_status,"IOM CDF OPEN: ") + + ENDIF + + ! get general information about file + CALL iom_cdf__get_info(td_file) + + ! read dimension in file + CALL iom_cdf__get_file_dim(td_file) + + ! read global attribute in file + CALL iom_cdf__get_file_att(td_file) + + ! get information about variables in file + CALL iom_cdf__get_file_var(td_file) + + ! remove dimension variable from list of variable + CALL iom_cdf__del_coord_var(td_file) + + ENDIF + + ENDIF + + END SUBROUTINE iom_cdf_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf_close(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine close netcdf file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF CLOSE: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + CALL logger_info( & + & " IOM CDF CLOSE: file "//TRIM(td_file%c_name)) + + il_status = NF90_CLOSE(td_file%i_id) + CALL iom_cdf__check(il_status,"IOM CDF CLOSE: ") + + td_file%i_id = 0 + + ENDIF + + END SUBROUTINE iom_cdf_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__get_info(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine get global information in an opened netcdf + !> file. + !> @details + !> It gets the number of variables, the number of dimensions, + !> the number of global attributes, the ID of the unlimited dimension + !> and finally the format version and filled file strucuture with it. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2016 + !> - define cdf4 as cdf. + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_fmt ! format version + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + CALL logger_trace( & + & " IOM CDF GET INFO: about netcdf file "//TRIM(td_file%c_name)) + + il_status=NF90_INQUIRE(td_file%i_id, td_file%i_ndim, & + & td_file%i_nvar, td_file%i_natt, td_file%i_uldid, il_fmt) + CALL iom_cdf__check(il_status,"IOM CDF GET INFO: ") + + SELECT CASE(il_fmt) + CASE(nf90_format_classic, nf90_format_64bit) + td_file%c_type='cdf' + CASE(nf90_format_netcdf4,nf90_format_netcdf4_classic) + td_file%c_type='cdf' + END SELECT + CALL logger_debug("IOM CDF GET INFO: type "//TRIM(td_file%c_type)) + + ! record header infos + td_file%i_rhd=1 + + END SUBROUTINE iom_cdf__get_info + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__get_file_dim(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine read dimension on an opened netcdf file, and + !> reorder dimension to ('x', 'y', 'z', 't'). + !> The dimension structure inside file structure is then completed. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2016 + !> - check unknown dimension + !> @date January, 2019 + !> - clean dimension structure + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + TYPE(TDIM) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ii + !---------------------------------------------------------------- + + ! clean dimension + DO ji=1,ip_maxdim + CALL dim_clean(td_file%t_dim(ji)) + ENDDO + + IF( td_file%i_ndim > 0 )THEN + + ii=1 + DO ji = 1, td_file%i_ndim + ! read dimension information + tl_dim=iom_cdf_read_dim( td_file, ji) + ! sname == 'u' if dimension is unknown (not to be used) + IF( TRIM(tl_dim%c_sname) /= 'u' )THEN + IF( ii > ip_maxdim )THEN + CALL logger_fatal("IOM CDF OPEN: too much dimension "//& + & "to be read. you could choose dimension to be used. see "//& + & " configuration file") + ENDIF + td_file%t_dim(ii)=dim_copy(tl_dim) + ii=ii+1 + ENDIF + ! clean + CALL dim_clean(tl_dim) + ENDDO + + ! inform unlimited dimension + IF( td_file%i_uldid == -1 )THEN + CALL logger_warn( & + & " IOM CDF GET FILE DIM: there is no unlimited dimension in file "//& + & TRIM(td_file%c_name)) + !ELSE + ! td_file%t_dim( td_file%i_uldid )%l_uld=.TRUE. + ENDIF + + ELSE + + CALL logger_warn( & + & " IOM CDF GET FILE DIM: there is no dimension in file "//& + & TRIM(td_file%c_name)) + + ENDIF + + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_file%t_dim(:)) + + END SUBROUTINE iom_cdf__get_file_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__get_file_att(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine read global attribute on an opened netcdf + !> file. + !> The attribute structure inside file structure is then completed. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use attribute periodicity read from the file if present. + !> @date January, 2019 + !> - clean attribute structure + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + TYPE(TATT) :: tl_att + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ii + !---------------------------------------------------------------- + CALL logger_trace("IOM CDF GET FILE ATT : get attr(s) in & + & file "//TRIM(td_file%c_name)) + + IF( td_file%i_natt > 0 )THEN + IF(ASSOCIATED(td_file%t_att))THEN + CALL att_clean(td_file%t_att(:)) + DEALLOCATE(td_file%t_att) + ENDIF + ALLOCATE(td_file%t_att(td_file%i_natt)) + + ii=1 + DO ji = 1, td_file%i_natt + ! read global attribute + tl_att=iom_cdf_read_att( td_file, NF90_GLOBAL, ji) + IF( .NOT. att_is_dummy(tl_att) )THEN + td_file%t_att(ii)=att_copy(tl_att) + ii=ii+1 + ENDIF + ! clean + CALL att_clean(tl_att) + ENDDO + + ELSE + CALL logger_debug( & + & " IOM CDF GET FILE ATT: there is no global attribute in file "//& + & TRIM(td_file%c_name)) + ENDIF + + END SUBROUTINE iom_cdf__get_file_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__get_file_var(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine read information about variable of an + !> opened netcdf file. + !> The variable structure inside file structure is then completed. + !> @note variable value are not read ! + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2015 + !> - manage useless (dummy) variable + !> @date January, 2016 + !> - increment n3d for 4D variable + !> @date October, 2016 + !> - check variable to be used (variable's dimension allowed and variable + !> not "dummy") + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_nvar + + TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: ii + !---------------------------------------------------------------- + + IF( td_file%i_nvar > 0 )THEN + + IF(ASSOCIATED(td_file%t_var))THEN + CALL var_clean(td_file%t_var(:)) + DEALLOCATE(td_file%t_var) + ENDIF + + il_nvar=td_file%i_nvar + ALLOCATE(tl_var(il_nvar)) + DO ji = 1, il_nvar + ! read variable information + tl_var(ji)=iom_cdf__read_var_meta( td_file, ji) + ENDDO + + ! update number of variable used + td_file%i_nvar=COUNT(tl_var(:)%l_use) + + ALLOCATE(td_file%t_var(td_file%i_nvar)) + + ii=0 + DO ji = 1, il_nvar + IF( tl_var(ji)%l_use )THEN + ii=ii+1 + td_file%t_var(ii)=var_copy(tl_var(ji)) + SELECT CASE(td_file%t_var(ii)%i_ndim) + CASE(0) + td_file%i_n0d=td_file%i_n0d+1 + CASE(1) + td_file%i_n1d=td_file%i_n1d+1 + td_file%i_rhd=td_file%i_rhd+1 + CASE(2) + td_file%i_n2d=td_file%i_n2d+1 + td_file%i_rhd=td_file%i_rhd+1 + CASE(3,4) + td_file%i_n3d=td_file%i_n3d+1 + td_file%i_rhd=td_file%i_rhd+td_file%t_dim(3)%i_len + END SELECT + + ! look for depth id + IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'depth')/=0 )THEN + IF( td_file%i_depthid == 0 )THEN + td_file%i_depthid=ji + ELSE + IF( td_file%i_depthid /= ji )THEN + CALL logger_error("IOM CDF GET FILE VAR: find more"//& + & " than one depth variable in file "//& + & TRIM(td_file%c_name) ) + ENDIF + ENDIF + ENDIF + + ! look for time id + IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'time')/=0 )THEN + IF( td_file%i_timeid == 0 )THEN + td_file%i_timeid=ji + ELSE + IF( td_file%i_timeid /= ji )THEN + CALL logger_warn("IOM CDF GET FILE VAR: find more "//& + & "than one time variable in file "//& + & TRIM(td_file%c_name)//". see "//& + & "dummy.cfg configuration file to"//& + & " not used dummy variables.") + ENDIF + il_attid=0 + IF( ASSOCIATED(td_file%t_var(ii)%t_att) )THEN + il_attid=att_get_id(td_file%t_var(ii)%t_att(:),'calendar') + ENDIF + IF( il_attid /= 0 )THEN + td_file%i_timeid=ji + ENDIF + ENDIF + ENDIF + + ENDIF + ENDDO + + CALL var_clean(tl_var(:)) + DEALLOCATE(tl_var) + + ELSE + CALL logger_debug( & + & " IOM CDF GET FILE VAR: there is no variable in file "//& + & TRIM(td_file%c_name)) + ENDIF + + END SUBROUTINE iom_cdf__get_file_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__del_coord_var(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine delete coordinate variable from an + !> opened netcdf file if present. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_sname + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + IF( td_file%i_nvar > 0 )THEN + DO ji=td_file%i_nvar,1,-1 + cl_name=TRIM(td_file%t_var(ji)%c_name) + DO jj=1,ip_maxdim + IF( td_file%t_dim(jj)%l_use )THEN + cl_sname=fct_upper(td_file%t_dim(jj)%c_sname) + IF( TRIM(cl_name) == TRIM(cl_sname) )THEN + CALL file_del_var(td_file,TRIM(cl_name)) + EXIT + ENDIF + ENDIF + ENDDO + ENDDO + ELSE + CALL logger_debug( & + & " IOM CDF DEL VAR DIM: there is no variable in file "//& + & TRIM(td_file%c_name)) + ENDIF + + END SUBROUTINE iom_cdf__del_coord_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_dim_id(td_file, id_dimid) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened netcdf file, + !> given dimension id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 - create unused dimension, when reading dimension + !> of length less or equal to zero + !> + !> @param[in] td_file file structure + !> @param[in] id_dimid dimension id + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_dimid + + ! function + TYPE(TDIM) :: tf_dim + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_len + CHARACTER(LEN=lc) :: cl_name + LOGICAL :: ll_use + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ DIM: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + CALL logger_trace( & + & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//& + & " in file "//TRIM(td_file%c_name)) + + il_status=NF90_INQUIRE_DIMENSION(td_file%i_id, id_dimid, & + & cl_name, il_len ) + CALL iom_cdf__check(il_status,"IOM CDF READ DIM: ") + + ll_use=.TRUE. + IF( il_len <= 0 )THEN + CALL logger_warn( & + & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//& + & " in file "//TRIM(td_file%c_name)//" is less or equel to zero") + il_len=1 + ll_use=.FALSE. + ENDIF + tf_dim=dim_init(cl_name, il_len, ld_use=ll_use) + + ENDIF + + tf_dim%i_id=id_dimid + + END FUNCTION iom_cdf__read_dim_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_dim_name(td_file, cd_name) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened netcdf file, + !> given dimension name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name dimension name + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + TYPE(TDIM) :: tf_dim + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_dimid + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ DIM: no id associated to file "//& + & TRIM(td_file%c_name)) + + ELSE + + il_status=NF90_INQ_DIMID( td_file%i_id, TRIM(ADJUSTL(cd_name)), & + & il_dimid) + CALL iom_cdf__check(il_status,"IOM CDF READ DIM: ") + + tf_dim=iom_cdf_read_dim(td_file, il_dimid) + + ENDIF + + END FUNCTION iom_cdf__read_dim_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_att_name(td_file, id_varid, cd_name) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read variable or global attribute in an opened + !> netcdf file, given attribute name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November 2017 + !> - check if cl_value is not bug + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id. use NF90_GLOBAL to read global + !> attribute in a file + !> @param[in] cd_name attribute name + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + TYPE(TATT) :: tf_att + + ! local variable + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_status + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_type + INTEGER(i4) :: il_len + + CHARACTER(LEN=lc) :: cl_value + + INTEGER(i1), DIMENSION(:), ALLOCATABLE :: bl_value + INTEGER(i2), DIMENSION(:), ALLOCATABLE :: sl_value + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_value + REAL(sp) , DIMENSION(:), ALLOCATABLE :: rl_value + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ ATT: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + cl_name=TRIM(ADJUSTL(cd_name)) + + ! inquire attribute + IF( id_varid == NF90_GLOBAL )THEN + + CALL logger_trace( & + & " IOM CDF READ ATT: inquire global attribute "//& + & " in file "//TRIM(td_file%c_name)) + + ELSE + + CALL logger_trace( & + & " IOM CDF READ ATT: inquire attribute "//& + & " of variable "//TRIM(fct_str(id_varid))//& + & " in file "//TRIM(td_file%c_name)) + + ENDIF + + il_status=NF90_INQUIRE_ATTRIBUTE(td_file%i_id, id_varid, & + & cl_name,& + & il_type,& + & il_len, & + & il_attid ) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + !! get attribute value + CALL logger_debug( " IOM CDF READ ATT: get attribute "//& + & TRIM(cl_name)//" in file "//TRIM(td_file%c_name)) + + SELECT CASE( il_type ) + + CASE(NF90_CHAR) + CALL logger_debug( " IOM CDF READ ATT: get NF90_CHAR ") + + ! check string lengths + IF( LEN(cl_value) < il_len )THEN + + CALL logger_warn( & + & " IOM CDF READ ATT: not enough space to put "//& + & "attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & cl_value ) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + ! check cl_value + CALL logger_trace("IOM CDF READ ATT: value = "//TRIM(cl_value)) + IF( LLT(cl_value,'') ) cl_value = '' + tf_att=att_init(cl_name, cl_value) + + ENDIF + + CASE(NF90_BYTE) + CALL logger_debug( " IOM CDF READ ATT: get NF90_BYTE ") + + ALLOCATE( bl_value(il_len), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( "IOM CDF READ ATT: "//& + & "not enough space to put attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & bl_value(:)) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + tf_att=att_init(cl_name, bl_value(:)) + + ENDIF + + DEALLOCATE(bl_value) + + CASE(NF90_SHORT) + CALL logger_debug( " IOM CDF READ ATT: get NF90_SHORT ") + + ALLOCATE( sl_value(il_len), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM CDF READ ATT: not enough space to put "//& + & "attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & sl_value(:)) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + tf_att=att_init(cl_name, sl_value(:)) + + ENDIF + + DEALLOCATE(sl_value) + + CASE(NF90_INT) + CALL logger_debug( " IOM CDF READ ATT: get NF90_INT ") + + ALLOCATE( il_value(il_len), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM CDF READ ATT: not enough space to put "//& + & "attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & il_value(:)) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + tf_att=att_init(cl_name, il_value(:)) + ENDIF + + DEALLOCATE(il_value) + + CASE(NF90_FLOAT) + CALL logger_debug( " IOM CDF READ ATT: get NF90_FLOAT ") + + ALLOCATE( rl_value(il_len), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM CDF READ ATT: not enough space to put "//& + & "attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & rl_value(:)) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + tf_att=att_init(cl_name, rl_value(:)) + + ENDIF + + DEALLOCATE(rl_value) + + CASE(NF90_DOUBLE) + CALL logger_debug( " IOM CDF READ ATT: get NF90_DOUBLE ") + + ALLOCATE( dl_value(il_len), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM CDF READ ATT: not enough space to put "//& + & "attribute "//TRIM(cl_name) ) + + ELSE + + ! Read the attributes + il_status=NF90_GET_ATT(td_file%i_id, id_varid, & + & cl_name, & + & dl_value(:)) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + tf_att=att_init(cl_name, dl_value(:)) + + ENDIF + + DEALLOCATE(dl_value) + + END SELECT + + tf_att%i_id=il_attid + + ENDIF + + END FUNCTION iom_cdf__read_att_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_att_id(td_file, id_varid, id_attid) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This function read variable or global attribute in an opened + !> netcdf file, given attribute id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id. use NF90_GLOBAL to read global + !> attribute in a file + !> @param[in] id_attid attribute id + !> @return attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), INTENT(IN) :: id_attid + + ! function + TYPE(TATT) :: tf_att + + ! local variable + INTEGER(i4) :: il_status + CHARACTER(LEN=lc) :: cl_name + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & "IOM CDF READ ATT: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + CALL logger_trace( " IOM CDF READ ATT ID: get attribute "//& + & TRIM(fct_str(id_attid))//" of var "//& + & TRIM(fct_str(id_varid))//" in file "//& + & TRIM(td_file%c_name) & + ) + + ! get attribute name + il_status=NF90_INQ_ATTNAME(td_file%i_id, id_varid, id_attid, cl_name) + CALL iom_cdf__check(il_status,"IOM CDF READ ATT: ") + + ! read attribute + tf_att=iom_cdf__read_att_name(td_file, id_varid, cl_name) + + ENDIF + + END FUNCTION iom_cdf__read_att_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_var_id(td_file, id_varid, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> netcdf file, given variable id. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_ind + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + ! look for variable index + il_ind(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid)) + IF( il_ind(1) /= 0 )THEN + + tf_var=var_copy(td_file%t_var(il_ind(1))) + + !!! read variable value + CALL iom_cdf__read_var_value(td_file, tf_var, id_start, id_count) + + ELSE + CALL logger_error( & + & " IOM CDF READ VAR: there is no variable with id "//& + & TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + END FUNCTION iom_cdf__read_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_var_name(td_file, cd_name, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> netcdf file, given variable name or standard name. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name variable name or standard name. + !> @param[in] id_start index in the variable from which the data values will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_name + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_varid + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + IF( .NOT. PRESENT(cd_name) )THEN + + CALL logger_error( & + & " IOM CDF READ VAR: you must specify a variable to read "//& + & " in file "//TRIM(td_file%c_name)) + + ELSE + + il_varid=var_get_index(td_file%t_var(:), cd_name) + IF( il_varid /= 0 )THEN + + tf_var=var_copy(td_file%t_var(il_varid)) + + !!! read variable value + CALL iom_cdf__read_var_value( td_file, tf_var, id_start, id_count) + + ELSE + + CALL logger_error( & + & " IOM CDF READ VAR: there is no variable with "//& + & " name or standard name "//TRIM(cd_name)//& + & " in file "//TRIM(td_file%c_name) ) + ENDIF + + ENDIF + + ENDIF + + END FUNCTION iom_cdf__read_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__fill_var_all(td_file, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine fill all variable value from an opened + !> netcdf file. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + + ! local variable + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + DO ji=1,td_file%i_nvar + CALL iom_cdf_fill_var(td_file, td_file%t_var(ji)%i_id, & + & id_start, id_count) + ENDDO + + ENDIF + + END SUBROUTINE iom_cdf__fill_var_all + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__fill_var_id(td_file, id_varid, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine fill variable value in an opened + !> netcdf file, given variable id. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + ! + !> @author J.Paul + !> @date November, 2013 - Initial Version + ! + !> @param[inout] td_file file structure + !> @param[in] id_varid variable id + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_varid + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & "IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + ! look for variable id + il_varid(:)=MINLOC( td_file%t_var(:)%i_id, & + & mask=(td_file%t_var(:)%i_id==id_varid)) + IF( il_varid(1) /= 0 )THEN + + !!! read variable value + CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_varid(1)), & + & id_start, id_count) + + DO ji=1,td_file%i_nvar + CALL logger_debug(" IOM CDF FILL VAR: var id "//& + & TRIM(td_file%t_var(ji)%c_name)//" "//& + & TRIM(fct_str(td_file%t_var(ji)%i_id)) ) + ENDDO + ELSE + CALL logger_error( & + & " IOM CDF FILL VAR: there is no variable with id "//& + & TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + + END SUBROUTINE iom_cdf__fill_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__fill_var_name(td_file, cd_name, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine fill variable value in an opened + !> netcdf file, given variable name or standard name. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name variable name or standard name + !> @param[in] id_start index in the variable from which the data values will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_varid + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & "IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + il_varid=var_get_index(td_file%t_var(:), cd_name) + IF( il_varid /= 0 )THEN + + !!! read variable value + CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_varid), & + & id_start, id_count) + + ELSE + + CALL logger_error( & + & "IOM CDF FILL VAR: there is no variable with "//& + & "name or standard name"//TRIM(cd_name)//& + & " in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + + END SUBROUTINE iom_cdf__fill_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_var_meta(td_file, id_varid) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read metadata of a variable in an opened + !> netcdf file. + !> + !> @note variable value are not read + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - force to use FillValue=1.e20 if no FillValue for coordinate variable. + !> @date September, 2015 + !> - manage useless (dummy) attribute + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + CHARACTER(LEN=lc) :: cl_name + + INTEGER(i4) :: il_status + INTEGER(i4) :: il_type + INTEGER(i4) :: il_ndim + INTEGER(i4) :: il_natt + INTEGER(i4) :: il_attid + INTEGER(i4), DIMENSION(NF90_MAX_VAR_DIMS) :: il_dimid + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + TYPE(TATT) :: tl_fill + TYPE(TATT) , DIMENSION(:) , ALLOCATABLE :: tl_att + TYPE(TATT) , DIMENSION(:) , ALLOCATABLE :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF READ VAR META: no id associated to file "//& + & TRIM(td_file%c_name)) + + ELSE + + ! inquire variable + CALL logger_debug( & + & " IOM CDF READ VAR META: inquire variable "//& + & TRIM(fct_str(id_varid))//& + & " in file "//TRIM(td_file%c_name)) + + il_dimid(:)=0 + + il_status=NF90_INQUIRE_VARIABLE( td_file%i_id, id_varid, & + & cl_name, & + & il_type, & + & il_ndim, & + & il_dimid(:),& + & il_natt ) + CALL iom_cdf__check(il_status,"IOM CDF READ VAR META: ") + + !!! fill variable dimension structure + tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, cl_name, il_dimid(:) ) + + IF( il_natt /= 0 )THEN + ALLOCATE( tl_att(il_natt) ) + !!! fill variable attribute structure + tl_att(:)=iom_cdf__read_var_att(td_file, id_varid, il_natt) + + !! look for _FillValue. if none add one + il_attid=att_get_id(tl_att(:),'_FillValue') + IF( il_attid == 0 )THEN + CALL logger_info("IOM CDF READ VAR META: no _FillValue for variable "//& + & TRIM(cl_name)//" in file "//TRIM(td_file%c_name) ) + + il_attid=att_get_id(tl_att(:),'missing_value') + IF( il_attid /= 0 )THEN + ! create attribute _FillValue + CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& + & "missing_value for variable "//TRIM(cl_name) ) + tl_fill=att_init('_FillValue',tl_att(il_attid)%d_value(:), & + & id_type=tl_att(il_attid)%i_type) + ELSE + ! create attribute _FillValue + SELECT CASE(TRIM(fct_lower(cl_name))) + CASE DEFAULT + CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& + & "zero for variable "//TRIM(cl_name) ) + tl_fill=att_init('_FillValue',0.) + CASE('nav_lon','nav_lat', 'nav_lev', & + & 'glamt','glamu','glamv','glamf', & + & 'gphit','gphiu','gphiv','gphif') + CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& + & "dummy fillValue (1.e20) for variable "//TRIM(cl_name) ) + tl_fill=att_init('_FillValue',1.e20) + END SELECT + ENDIF + + ALLOCATE( tl_tmp(il_natt) ) + ! save read attribut + tl_tmp(:)=att_copy(tl_att(:)) + ! change number of attribute in array + CALL att_clean(tl_att(:)) + DEALLOCATE( tl_att ) + ALLOCATE( tl_att(il_natt+1) ) + ! copy read attribut + tl_att(1:il_natt)=att_copy(tl_tmp(:)) + ! clean + CALL att_clean(tl_tmp(:)) + DEALLOCATE( tl_tmp ) + + ! create attribute _FillValue + tl_att(il_natt+1)=att_copy(tl_fill) + + ENDIF + + ELSE + ALLOCATE(tl_att(il_natt+1) ) + ! create attribute _FillValue + SELECT CASE(TRIM(fct_lower(cl_name))) + CASE DEFAULT + CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& + & "zero for variable "//TRIM(cl_name) ) + tl_fill=att_init('_FillValue',0.) + CASE('nav_lon','nav_lat', & + & 'glamt','glamu','glamv','glamf', & + & 'gphit','gphiu','gphiv','gphif') + CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//& + & "dummy fillValue (1.e20) for variable "//TRIM(cl_name) ) + tl_fill=att_init('_FillValue',1.e20) + END SELECT + ! create attribute _FillValue + tl_att(il_natt+1)=att_copy(tl_fill) + ENDIF + + !! initialize variable + tf_var=var_init( cl_name, il_type, tl_dim(:), tl_att(:), id_id=id_varid ) + + !! look for dummy attribute + DO ji=il_natt,1,-1 + IF( att_is_dummy(tl_att(ji)) )THEN + CALL var_del_att(tf_var, tl_att(ji)) + ENDIF + ENDDO + + !! check if variable is dummy + IF( var_is_dummy(tf_var) )THEN + tf_var%l_use=.FALSE. + ENDIF + + !! check if all dimensions are allowed + DO ji=1,il_ndim + IF( ALL(td_file%t_dim(:)%i_id /= il_dimid(ji)) )THEN + tf_var%l_use=.FALSE. + ENDIF + ENDDO + + ! clean + CALL dim_clean(tl_dim(:)) + CALL att_clean(tl_fill) + CALL att_clean(tl_att(:)) + DEALLOCATE( tl_att ) + + ENDIF + + END FUNCTION iom_cdf__read_var_meta + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, cd_name, id_dimid) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This subroutine read variable dimension + !> in an opened netcdf file. + !> + !> @details + !> the number of dimension can't exceed 4, + !> and should be 'x', 'y', 'z', 't' (whatever their order).<br/> + !> If the number of dimension read is less than 4, the array of dimension + !> strucure is filled with unused dimension.<br/> + !> So the array of dimension structure of a variable is always compose of 4 + !> dimension (use or not). + !> + !> @warn dummy dimension are not used. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - Bug fix: use order to disorder table (see dim_init) + !> @date September, 2015 + !> - check dummy dimension + !> @date April, 2018 + !> - Bug fix : use dimid to look for the index of the dimension, and not as + !> dimension index + !> + !> @param[in] td_file file structure + !> @param[in] id_ndim number of dimension + !> @param[in] cd_name variable name + !> @param[in] id_dimid array of dimension id + !> @return array dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_ndim + CHARACTER(LEN=*) , INTENT(IN) :: cd_name + INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_dimid + + ! function + TYPE(TDIM), DIMENSION(ip_maxdim) :: tf_dim + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_xyzt2 + INTEGER(i4) :: il_idx + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: ii + !---------------------------------------------------------------- + + IF( id_ndim == 0 )THEN + + tl_dim(:)%l_use=.FALSE. + + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(tl_dim(:)) + + tf_dim(:)=dim_copy(tl_dim(:)) + + ! clean + CALL dim_clean(tl_dim(:)) + + ELSE IF( id_ndim > 0 )THEN + + ii=1 + DO ji = 1, id_ndim + + ! check if dimension to be used, is allowed + IF( ANY(td_file%t_dim(:)%i_id == id_dimid(ji)) )THEN + IF( ii > ip_maxdim )THEN + CALL logger_error(" IOM CDF READ VAR DIM: "//& + & "too much dimensions for variable "//& + & TRIM(cd_name)//". check dummy configuration file.") + ENDIF + + CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& + & "dimension "//TRIM(fct_str(ji)) ) + + ! look for dimension index + DO jj=1,ip_maxdim + IF( td_file%t_dim(jj)%i_id == id_dimid(ji) )THEN + il_idx=jj + EXIT + ENDIF + ENDDO + !il_xyzt2(ii)=td_file%t_dim(id_dimid(ji))%i_xyzt2 + il_xyzt2(ii)=td_file%t_dim(il_idx)%i_xyzt2 + + ! read dimension information + tl_dim(ii) = dim_init( td_file%t_dim(il_xyzt2(ii))%c_name, & + & td_file%t_dim(il_xyzt2(ii))%i_len ) + + ii=ii+1 + ELSE + CALL logger_debug(" IOM CDF READ VAR DIM: dummy variable "//& + & "dimension "//TRIM(fct_str(ji))//" not used.") + ENDIF + ENDDO + + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(tl_dim(:)) + + tf_dim(:)=dim_copy(tl_dim(:)) + + ! clean + CALL dim_clean(tl_dim(:)) + + ENDIF + + END FUNCTION iom_cdf__read_var_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_cdf__read_var_att(td_file, id_varid, id_natt) & + & RESULT (tf_att) + !------------------------------------------------------------------- + !> @brief This subroutine read variable attributes + !> in an opened netcdf file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id + !> @param[in] id_natt number of attributes + !> @return array of attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), INTENT(IN) :: id_natt + + ! function + TYPE(TATT), DIMENSION(id_natt) :: tf_att + + ! local variable + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( id_natt > 0 )THEN + + ! read attributes + DO ji = 1, id_natt + CALL logger_trace( " IOM CDF READ VAR ATT: get attribute "//& + & TRIM(fct_str(ji))//" in file "//& + & TRIM(td_file%c_name) & + ) + + tf_att(ji)=iom_cdf_read_att(td_file, id_varid, ji) + + ENDDO + + ELSE + + CALL logger_debug( " IOM CDF READ VAR ATT: no attribute for variable " ) + + ENDIF + + END FUNCTION iom_cdf__read_var_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__read_var_value(td_file, td_var, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine read variable value + !> in an opened netcdf file. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - use scale factor and offset, as soon as read variable value + !> @date January, 2019 + !> - read array in netcdf file, level by level, and time step by time step + !> - apply scale factor and offset, level by level, and time step by time step + !> + !> @param[in] td_file file structure + !> @param[inout] td_var variable structure + !> @param[in] id_start index in the variable from which the data values will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure completed + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_tmp1 + INTEGER(i4) :: il_tmp2 + INTEGER(i4) :: il_varid + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_ord + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_ord + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_tmp + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_tmp + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! check if variable in file structure + il_varid=var_get_id(td_file%t_var(:),TRIM(td_var%c_name)) + IF( il_varid /= 0 )THEN + + ! check id_count and id_start optionals parameters... + IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. & + ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN + CALL logger_warn( "IOM CDF READ VAR VALUE: id_start and id_count"//& + & " should be both specify") + ENDIF + IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN + + IF( SIZE(id_start(:)) /= ip_maxdim .OR. & + & SIZE(id_count(:)) /= ip_maxdim )THEN + CALL logger_error("IOM CDF READ VAR: dimension of array start"//& + & " or count are invalid to read variable "//& + & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name) ) + ENDIF + + ! change dimension order from ('x','y','z','t') + il_start(:)=dim_reorder_xyzt2(td_var%t_dim, id_start(:)) + il_count(:)=dim_reorder_xyzt2(td_var%t_dim, id_count(:)) + + ! keep ordered array ('x','y','z','t') + il_start_ord(:)=id_start(:) + il_count_ord(:)=id_count(:) + + ELSE + + ! change dimension order from ('x','y','z','t') + il_start(:)=(/1,1,1,1/) + il_count(:)=dim_reorder_xyzt2(td_var%t_dim(:),td_var%t_dim(:)%i_len) + + ! keep ordered array ('x','y','z','t') + il_start_ord(:)=(/1,1,1,1/) + il_count_ord(:)=td_var%t_dim(:)%i_len + + ENDIF + + ! check dimension + IF( .NOT. ALL(il_start_ord(:)>=(/1,1,1,1/)) )THEN + + CALL logger_error( "IOM CDF READ VAR VALUE: start indices should"//& + & " be greater than or equal to 1") + + ENDIF + + IF(.NOT.ALL(il_start_ord(:)+il_count_ord(:)-1 <= & + & (/td_var%t_dim( 1 )%i_len,& + & td_var%t_dim( 2 )%i_len,& + & td_var%t_dim( 3 )%i_len,& + & td_var%t_dim( 4 )%i_len & + & /)) )THEN + + DO ji = 1, ip_maxdim + il_tmp1=il_start_ord(ji)+il_count_ord(ji)-1 + il_tmp2=td_var%t_dim(ji)%i_len + CALL logger_debug( "IOM CDF READ VAR VALUE: start + count -1:"//& + & TRIM(fct_str(il_tmp1))//" variable dimension"//& + & TRIM(fct_str(il_tmp2))) + ENDDO + CALL logger_error( "IOM CDF READ VAR VALUE: start + count exceed "//& + & "variable dimension for "//TRIM(td_var%c_name) ) + + ELSE + + ! Allocate space to hold variable value (disorder) + ALLOCATE(dl_value( il_count(1), & + & il_count(2), & + & il_count(3), & + & il_count(4)),& + & stat=il_status) + IF( il_status /= 0 )THEN + + CALL logger_fatal( & + & "IOM CDF READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)) + + ENDIF + + ! read values + CALL logger_debug( & + & "IOM CDF READ VAR VALUE: get variable "//TRIM(td_var%c_name)//& + & " in file "//TRIM(td_file%c_name)) + + il_start_tmp(:)=il_start(:) + il_count_tmp(:)=il_count(:) + DO jl=il_start(jp_L),il_start(jp_L)+il_count(jp_L)-1 + il_start_tmp(jp_L)=jl + il_count_tmp(jp_L) = 1 + DO jk=il_start(jp_K),il_start(jp_K)+il_count(jp_K)-1 + il_start_tmp(jp_K)=jk + il_count_tmp(jp_K)=1 + il_status = NF90_GET_VAR( td_file%i_id, il_varid, & + & dl_value(:,:,jk,jl),& + & start = il_start_tmp(:),& + & count = il_count_tmp(:) ) + ! il_status = NF90_GET_VAR( td_file%i_id, il_varid, & + ! & dl_value(:,:,:,:),& + CALL iom_cdf__check(il_status,"IOM CDF READ VAR VALUE: ") + ENDDO + ENDDO + + ! Allocate space to hold variable value in structure + IF( ASSOCIATED(td_var%d_value) )THEN + DEALLOCATE(td_var%d_value) + ENDIF + + ! new dimension length + td_var%t_dim(:)%i_len=il_count_ord(:) + +!> dummy patch for pgf95 + ALLOCATE( dl_tmp( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_fatal( & + & "IOM CDF READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + ENDIF + dl_tmp(:,:,:,:)=td_var%d_fill + + ! reshape values to be ordered as ('x','y','z','t') + dl_tmp(:,:,:,:)=dim_reshape_2xyzt(td_var%t_dim(:), & + & dl_value(:,:,:,:)) + + DEALLOCATE(dl_value) + + ALLOCATE(td_var%d_value( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_fatal( & + & "IOM CDF READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF +! ! FillValue by default +! td_var%d_value(:,:,:,:)=td_var%d_fill +! +! ! reshape values to be ordered as ('x','y','z','t') +! td_var%d_value(:,:,:,:)=dim_reshape_2xyzt(td_var%t_dim(:), & +! & dl_value(:,:,:,:)) +! +! DEALLOCATE(dl_value) + + DO jl=1,td_var%t_dim(jp_L)%i_len + DO jk=1,td_var%t_dim(jp_K)%i_len + DO jj=1,td_var%t_dim(jp_J)%i_len + DO ji=1,td_var%t_dim(jp_I)%i_len + td_var%d_value(ji,jj,jk,jl)=dl_tmp(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + DEALLOCATE(dl_tmp) +!< dummy patch for pgf95 + + ! force to change _FillValue to avoid mistake + ! with dummy zero _FillValue + IF( td_var%d_fill == 0._dp )THEN + CALL var_chg_FillValue(td_var) + ENDIF + + ! use scale factor and offset + DO jl=1,td_var%t_dim(jp_L)%i_len + DO jk=1,td_var%t_dim(jp_K)%i_len + WHERE( td_var%d_value(:,:,jk,jl) /= td_var%d_fill ) + td_var%d_value(:,:,jk,jl) = & + & td_var%d_value(:,:,jk,jl)*td_var%d_scf + td_var%d_ofs + END WHERE + ENDDO + ENDDO + + ENDIF + ELSE + CALL logger_error( & + & "IOM CDF READ VAR VALUE: no variable "//TRIM(td_var%c_name)//& + & " in file structure "//TRIM(td_file%c_name)) + ENDIF + + END SUBROUTINE iom_cdf__read_var_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf_write_header(td_file, cd_dimorder, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine write file header in an opened netcdf file. + !> + !> @details + !> optionally, you could specify dimension order (default 'xyzt'), + !> and/or dimension structure to be used. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - add dimension order option + !> @date August, 2017 + !> - split write_file into write_header and write_var + !> - add dimension structure as optional argument + !> @date September, 2017 + !> - do not check variable dimension if dimension forced + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*) , INTENT(IN ), OPTIONAL :: cd_dimorder + TYPE(TDIM ) , DIMENSION(ip_maxdim), INTENT(IN ), OPTIONAL :: td_dim + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_value + + CHARACTER(LEN=lc) :: cl_dimorder + + LOGICAL :: ll_chkdim + + TYPE(TVAR), DIMENSION(ip_maxdim) :: tl_var + + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jvar + !---------------------------------------------------------------- + + cl_dimorder='xyzt' + IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(cd_dimorder) + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF WRITE HEADER: no id associated to file "//& + & TRIM(td_file%c_name)//". Check if file is opened.") + + ELSE + IF( td_file%l_wrt )THEN + + ! remove dummy variable + CALL file_del_var(td_file,'no0d') + CALL file_del_var(td_file,'no1d') + CALL file_del_var(td_file,'no2d') + CALL file_del_var(td_file,'no3d') + + DO ji = 1, td_file%i_nvar + CALL var_check_dim( td_file%t_var(ji) ) + ENDDO + + IF( PRESENT(td_dim) )THEN + ! special case to rebuild mpp layout + DO ji=1,ip_maxdim + IF( td_dim(ji)%l_use ) CALL file_move_dim(td_file, td_dim(ji)) + ENDDO + ELSE + ! save useful dimension + IF( ASSOCIATED(td_file%t_var) )THEN + tl_dim(:) = var_max_dim( td_file%t_var(:) ) + + DO ji=1,ip_maxdim + IF( tl_dim(ji)%l_use ) CALL file_move_dim(td_file, tl_dim(ji)) + ENDDO + ! clean + CALL dim_clean(tl_dim(:)) + ENDIF + ENDIF + + ! Enter in define mode + IF( .NOT. td_file%l_def )THEN + CALL logger_debug( & + & " IOM CDF WRITE HEADER: Enter define mode, file "//& + & TRIM(td_file%c_name)) + + ! Enter define mode + il_status=NF90_REDEF(td_file%i_id) + CALL iom_cdf__check(il_status,"IOM CDF WRITE HEADER: ") + + td_file%l_def=.TRUE. + ENDIF + + ! write dimension definition in header of file + IF( TRIM(cl_dimorder) /= 'xyzt' )THEN + CALL dim_reorder(td_file%t_dim(:),TRIM(cl_dimorder)) + DO jvar=1,td_file%i_nvar + CALL logger_debug("VAR REORDER: "//TRIM(td_file%t_var(jvar)%c_name)) + CALL var_reorder(td_file%t_var(jvar),TRIM(cl_dimorder)) + ENDDO + ENDIF + + ! write dimension in file + DO ji = 1, ip_maxdim + IF( td_file%t_dim(ji)%l_use )THEN + CALL iom_cdf__write_dim_def(td_file, td_file%t_dim(ji)) + + ! write dimension variable + ALLOCATE(il_value(td_file%t_dim(ji)%i_len)) + il_value(:)=(/(jj,jj=1,td_file%t_dim(ji)%i_len)/) + + tl_var(ji)=var_init( fct_upper(td_file%t_dim(ji)%c_sname), & + & il_value(:), & + & td_dim=td_file%t_dim(ji) ) + + DEALLOCATE(il_value) + + ! do not use FillValue for dimension variable + CALL var_del_att(tl_var(ji), "_FillValue") + + ! write dimension variable definition in header of file + CALL iom_cdf__write_var_def(td_file,tl_var(ji)) + + ENDIF + ENDDO + + ! write global attibute in file + DO ji = 1, td_file%i_natt + CALL iom_cdf__write_att_def(td_file, NF90_GLOBAL, td_file%t_att(ji)) + ENDDO + + ! write variable definition in header of file + ll_chkdim=.TRUE. + IF( PRESENT(td_dim) )THEN + ! special case to rebuild mpp layout + ! do not check dimension length of variable + ll_chkdim=.FALSE. + ENDIF + DO ji=1,td_file%i_nvar + CALL iom_cdf__write_var_def(td_file, td_file%t_var(ji),ll_chkdim) + ENDDO + + ! Leave define mode + IF( td_file%l_def )THEN + CALL logger_debug( & + & " IOM CDF WRITE HEADER: Leave define mode, file "//& + & TRIM(td_file%c_name)) + + ! Leave define mode + il_status=NF90_ENDDEF(td_file%i_id) + CALL iom_cdf__check(il_status,"IOM CDF WRITE HEADER: ") + + td_file%l_def=.FALSE. + ENDIF + + ! write dimension variable in file + DO ji = 1, ip_maxdim + IF( td_file%t_dim(ji)%l_use )THEN + ! do not use FillValue for dimension variable + CALL var_del_att(tl_var(ji), "_FillValue") + CALL iom_cdf__write_var(td_file,tl_var(ji)) + ENDIF + ENDDO + ! clean + CALL var_clean(tl_var(:)) + + ELSE + + CALL logger_error( & + & "IOM CDF WRITE HEADER: try to write in file "//TRIM(td_file%c_name)//& + & ", not opened in write mode") + + ENDIF + ENDIF + + END SUBROUTINE iom_cdf_write_header + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf_write_var(td_file, cd_dimorder, id_start, id_count)!, ld_first) + !------------------------------------------------------------------- + !> @brief This subroutine write variable(s) in an opened netcdf file. + !> + !> @details + !> optionally, you could specify dimension order (default 'xyzt') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - add dimension order option + !> @date August, 2017 + !> - add start and count array as optional argument + !> + !> @param[inout] td_file file structure + !> @param[in] td_var array of variable structure + !> @param[in] cd_dimorder dimension order + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + CHARACTER(LEN=*) , INTENT(IN ), OPTIONAL :: cd_dimorder + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + ! local variable + CHARACTER(LEN=lc) :: cl_dimorder + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + cl_dimorder='xyzt' + IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(cd_dimorder) + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " IOM CDF WRITE VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + IF( td_file%l_wrt )THEN + + ! write variable in file + DO ji = 1, td_file%i_nvar + + ! change dimension order + IF( TRIM(cl_dimorder) /= 'xyzt' )THEN + CALL logger_debug("VAR REORDER: "//TRIM(td_file%t_var(ji)%c_name)) + CALL var_reorder(td_file%t_var(ji),TRIM(cl_dimorder)) + ENDIF + + IF( ASSOCIATED(td_file%t_var(ji)%d_value) )THEN + ! write variable value in file + CALL iom_cdf__write_var_value( td_file, td_file%t_var(ji), & + & id_start, id_count) + ENDIF + ENDDO + + ELSE + + CALL logger_error( & + & "IOM CDF WRITE VAR: try to write in file "//TRIM(td_file%c_name)//& + & ", not opened in write mode") + + ENDIF + ENDIF + + END SUBROUTINE iom_cdf_write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__write_dim_def(td_file, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine define a dimension in the header of a netcdf + !> file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date August, 2017 + !> - rename in write_dim_def + !> - do not check define mode here anymore + !> + !> @param[inout] td_file file structure + !> @param[inout] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + TYPE(TDIM), INTENT(INOUT) :: td_dim + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + IF( td_dim%l_use )THEN + IF( td_dim%l_uld )THEN + ! write unlimited dimension + CALL logger_trace( & + & "IOM CDF WRITE FILE DIM: write unlimited dimension "//& + & TRIM(td_dim%c_name)//" in file "//TRIM(td_file%c_name)) + + il_status=NF90_DEF_DIM(td_file%i_id, fct_upper(td_dim%c_sname), & + & NF90_UNLIMITED, td_dim%i_id) + CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE DIM: ") + + ELSE + ! write not unlimited dimension + CALL logger_debug( & + & "IOM CDF WRITE FILE DIM: write dimension "//TRIM(td_dim%c_name)//& + & " in file "//TRIM(td_file%c_name)) + + CALL logger_debug("IOM CDF WRITE FILE DIM: id "//TRIM(fct_str(td_file%i_id))//& + & " sname "//TRIM(td_dim%c_sname)) + il_status=NF90_DEF_DIM(td_file%i_id, fct_upper(td_dim%c_sname), & + & td_dim%i_len, td_dim%i_id) + CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE DIM: ") + + ENDIF + ENDIF + + END SUBROUTINE iom_cdf__write_dim_def + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__write_att_def(td_file, id_varid, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine write a variable attribute in + !> an opened netcdf file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date August, 2017 + !> - rename in write_att_def + !> - do not check define mode here anymore + !> + !> @param[inout] td_file file structure + !> @param[in] id_varid variable id. use NF90_GLOBAL to write + !> global attribute in a file + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + !! put attribute value + CALL logger_trace( & + & "IOM CDF WRITE FILE ATT: write attribute "//TRIM(td_att%c_name)//& + & " of variable "//TRIM(fct_str(id_varid))//& + & " in file "//TRIM(td_file%c_name)) + SELECT CASE( td_att%i_type ) + + CASE(NF90_CHAR) + ! put the attribute + il_status = NF90_PUT_ATT(td_file%i_id, id_varid, & + & td_att%c_name, td_att%c_value ) + CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE ATT: ") + + CASE(NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE) + ! put the attribute + il_status = NF90_PUT_ATT(td_file%i_id, id_varid, & + & td_att%c_name, td_att%d_value ) + CALL iom_cdf__check(il_status,"IOM CDF WRITE FILE ATT: ") + + END SELECT + + END SUBROUTINE iom_cdf__write_att_def + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__write_var(td_file, td_var, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine write a variable in an opened netcdf file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2015 + !> - do not force to use zero as FillValue for any meshmask variable + !> @date August, 2017 + !> - add start and count array as optional argument + !> - variable definition now done in write_var_def + !> + !> @param[inout] td_file file structure + !> @param[inout] td_var variable structure + !> @param[in] id_start index in the variable from which the data + !> values will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + + ! local variable + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + + ! write variable value in file + CALL iom_cdf__write_var_value(td_file, td_var, id_start, id_count) + ENDIF + + END SUBROUTINE iom_cdf__write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__write_var_def(td_file, td_var,ld_chkdim) + !------------------------------------------------------------------- + !> @brief This subroutine define variable in the header of a netcdf + !> file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2017 + !> - add option to not check dimension length + !> @date August, 2017 + !> - extract from write_var + !> @date November, 2019 + !> - compress 2D,3D, and 4D variables in netcdf4 files + !> - set no_fill mode on every variables + !> + !> @param[in] td_file file structure + !> @param[in] td_var variable structure + !> @param[in] ld_chkdim check dimension length + !> @return variable id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN ) :: td_file + TYPE(TVAR), INTENT(INOUT) :: td_var + LOGICAL , INTENT(IN ), OPTIONAL :: ld_chkdim + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_deflate + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dimid + + LOGICAL :: ll_chg + LOGICAL :: ll_defdim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ll_defdim=file_check_var_dim(td_file, td_var, ld_chkdim ) + IF( ll_defdim )THEN + ll_chg=.TRUE. + DO ji=1,ip_maxdim + IF( TRIM(fct_lower(cp_dimorder(ji:ji))) == & + & TRIM(fct_lower(td_var%c_name)) )THEN + ll_chg=.FALSE. + CALL logger_trace(TRIM(fct_lower(td_var%c_name))//' is var dimension') + EXIT + ENDIF + ENDDO + ! ugly patch until NEMO do not force to use 0. as FillValue + IF( ll_chg )THEN + ! not a dimension variable + ! change FillValue + SELECT CASE( TRIM(fct_lower(td_var%c_name)) ) + CASE DEFAULT + CALL var_chg_FillValue(td_var,0._dp) + CASE('nav_lon','nav_lat', & + & 'glamt','glamu','glamv','glamf', & + & 'gphit','gphiu','gphiv','gphif', & + & 'e1t','e1u','e1v','e1f', & + & 'e2t','e2u','e2v','e2f','ff', & + & 'gcost','gcosu','gcosv','gcosf', & + & 'gsint','gsinu','gsinv','gsinf', & + & 'mbathy','misf','isf_draft','isfdraft', & + & 'hbatt','hbatu','hbatv','hbatf', & + & 'gsigt','gsigu','gsigv','gsigf', & + & 'e3t_0','e3u_0','e3v_0','e3w_0', & + & 'e3f_0','gdepw_1d','gdept_1d', & + & 'e3tp','e3wp','gdepw_0','rx1', & + & 'gdept_0','gdepu','gdepv', & + & 'hdept','hdepw','e3w_1d','e3t_1d',& + & 'tmask','umask','vmask','fmask' ) + ! do not change for coordinates and meshmask variables + !CASE('no3','o2','po4','si', & + ! & 'solub','ndepo','dust','fr_par', & + ! & 'alk','dic','doc','fer' ) + ! ! do not change for BGC variables + END SELECT + ENDIF + + ! forced to use float type + IF( td_var%d_unf /= 1. .AND. td_var%i_type==NF90_SHORT )THEN + td_var%i_type=NF90_FLOAT + ENDIF + + IF( ALL( .NOT. td_var%t_dim(:)%l_use ) )THEN + CALL logger_debug( & + & "IOM CDF WRITE VAR DEF scalar: define variable "//& + & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name)) + ! scalar value + il_status = NF90_DEF_VAR(td_file%i_id, & + & TRIM(td_var%c_name), & + & td_var%i_type, & + & varid=td_var%i_id) + CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") + ELSE + + ! check which dimension use + jj=0 + il_dimid(:)=0 + ! reorder dimension, so unused dimension won't be written + DO ji = 1, ip_maxdim + IF( td_var%t_dim(ji)%l_use )THEN + jj=jj+1 + il_dimid(jj)=dim_get_id(td_file%t_dim(:),td_var%t_dim(ji)%c_name) + ENDIF + ENDDO + + CALL logger_debug( & + & "IOM CDF WRITE VAR DEF: define dimension to be used for variable "//& + & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name)) + + DO ji=1,jj + CALL logger_debug("IOM CDF WRITE VAR DEF: dimname : "//TRIM(td_var%t_dim(ji)%c_name)) + CALL logger_debug("IOM CDF WRITE VAR DEF: dimid "//TRIM(fct_str(il_dimid(ji))) ) + ENDDO + + il_deflate=0 + ! compress 2D,3D, and 4D variables + if( jj > 1 ) il_deflate=1 + CALL logger_debug("IOM CDF WRITE VAR DEF: deflate = "//TRIM(fct_str(il_deflate))) + il_status = NF90_DEF_VAR(td_file%i_id, & + & TRIM(td_var%c_name),& + & td_var%i_type, & + & il_dimid(1:jj), & + & varid=td_var%i_id, & + & deflate_level=il_deflate ) + CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") + ENDIF + CALL logger_debug("IOM CDF WRITE VAR DEF: type = "//TRIM(fct_str(td_var%i_type))) + + ! remove useless attribute + il_ind=att_get_index( td_var%t_att(:), "ew_overlap" ) + IF( il_ind /= 0 )THEN + IF( td_var%t_att(il_ind)%d_value(1) == -1 )THEN + CALL var_del_att(td_var, td_var%t_att(il_ind)) + ENDIF + ENDIF + + DO ji = 1, td_var%i_natt + CALL logger_debug( & + & " IOM CDF WRITE VAR DEF: put attribute "//TRIM(td_var%t_att(ji)%c_name)//& + & " for variable "//TRIM(td_var%c_name)//& + & " in file "//TRIM(td_file%c_name) ) + + ! forced FillValue to have same type than variable + IF( TRIM(td_var%t_att(ji)%c_name) == '_FillValue' )THEN + + td_var%t_att(ji)%i_type=td_var%i_type + + SELECT CASE(td_var%t_att(ji)%i_type) + CASE(NF90_BYTE) + il_status = NF90_DEF_VAR_FILL(td_file%i_id, & + & td_var%i_id, & + & 1_i4, & + & INT(td_var%d_fill,i1)) + CASE(NF90_SHORT) + il_status = NF90_DEF_VAR_FILL(td_file%i_id, & + & td_var%i_id, & + & 1_i4, & + & INT(td_var%d_fill,i2)) + CASE(NF90_INT) + il_status = NF90_DEF_VAR_FILL(td_file%i_id, & + & td_var%i_id, & + & 1_i4, & + & INT(td_var%d_fill,i4)) + CASE(NF90_FLOAT) + il_status = NF90_DEF_VAR_FILL(td_file%i_id, & + & td_var%i_id, & + & 1_i4, & + & REAL(td_var%d_fill,sp)) + CASE(NF90_DOUBLE) + il_status = NF90_DEF_VAR_FILL(td_file%i_id, & + & td_var%i_id, & + & 1_i4, & + & REAL(td_var%d_fill,dp)) + END SELECT + CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF FILL: ") + + ELSE + + SELECT CASE(td_var%t_att(ji)%i_type) + CASE(NF90_CHAR) + IF( TRIM(td_var%t_att(ji)%c_value) /= '' )THEN + il_status = NF90_PUT_ATT(td_file%i_id, td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & TRIM(td_var%t_att(ji)%c_value) ) + ENDIF + CASE(NF90_BYTE) + il_status = NF90_PUT_ATT(td_file%i_id, & + & td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & INT(td_var%t_att(ji)%d_value(:),i1)) + CASE(NF90_SHORT) + il_status = NF90_PUT_ATT(td_file%i_id, & + & td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & INT(td_var%t_att(ji)%d_value(:),i2)) + CASE(NF90_INT) + il_status = NF90_PUT_ATT(td_file%i_id, & + & td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & INT(td_var%t_att(ji)%d_value(:),i4)) + CASE(NF90_FLOAT) + il_status = NF90_PUT_ATT(td_file%i_id, & + & td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & REAL(td_var%t_att(ji)%d_value(:),sp)) + CASE(NF90_DOUBLE) + il_status = NF90_PUT_ATT(td_file%i_id, & + & td_var%i_id, & + & TRIM(td_var%t_att(ji)%c_name), & + & REAL(td_var%t_att(ji)%d_value(:),dp)) + END SELECT + CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") + + ENDIF + + ENDDO + + ENDIF + CALL logger_debug("IOM CDF WRITE VAR DEF: type = "//TRIM(fct_str(td_var%i_type))) + + END SUBROUTINE iom_cdf__write_var_def + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_cdf__write_var_value(td_file, td_var, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine put variable value in an opened netcdf file. + !> + !> @details + !> The variable is written in the type define in variable structure. + !> Only dimension used are printed, and fillValue in array are + !> replaced by default fill values defined in module netcdf for each type. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - reuse scale factor and offset, before writing variable + !> @August, 2017 + !> - use start and count array to write variable value + !> + !> @param[in] td_file file structure + !> @param[in] td_var variable structure + !> @param[in] id_start index in the variable from which the data + !> values will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(IN ) :: td_file + TYPE(TVAR) , INTENT(IN ) :: td_var + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4), DIMENSION(ip_maxdim) :: il_order + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_ord + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_ord + ! loop indices + INTEGER(i4) :: ji, jj + !---------------------------------------------------------------- + + ! check which dimension use + CALL logger_debug( & + & "IOM CDF WRITE VAR VALUE: get dimension to be used for variable "//& + & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name)) + + il_start(:)=1 + IF( PRESENT(id_start) ) il_start(:)=id_start(:) + + il_count(:)=td_var%t_dim(:)%i_len + IF( PRESENT(id_count) ) il_count(:)=id_count(:) + + ! use scale factor and offset + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & (td_var%d_value(:,:,:,:)-td_var%d_ofs)/td_var%d_scf + END WHERE + + jj=0 + DO ji = 1, ip_maxdim + IF( td_var%t_dim(ji)%l_use )THEN + jj=jj+1 + il_order(jj)=ji + il_shape(jj)=td_var%t_dim(ji)%i_len + ENDIF + ENDDO + ! dimension not use + DO ji = 1, ip_maxdim + IF( .NOT. td_var%t_dim(ji)%l_use )THEN + jj=jj+1 + il_order(jj)=ji + il_shape(jj)=td_var%t_dim(ji)%i_len + ENDIF + ENDDO + + ALLOCATE( dl_value( il_shape(1),il_shape(2),il_shape(3),il_shape(4) ) ) + + ! reshape array, so useless dimension won't be written + dl_value(:,:,:,:)=RESHAPE(source=td_var%d_value(:,:,:,:),& + & SHAPE = il_shape(:), & + & ORDER = il_order(:)) + + DO ji = 1, ip_maxdim + il_start_ord(il_order(ji))=il_start(ji) + il_count_ord(il_order(ji))=il_count(ji) + ENDDO + + ! put value + CALL logger_debug( & + & "IOM CDF WRITE VAR VALUE: put "//TRIM(td_var%c_name)//" value "//& + & "in file "//TRIM(td_file%c_name)) + il_status = NF90_PUT_VAR( td_file%i_id, td_var%i_id, dl_value(:,:,:,:), & + & start=il_start_ord(:), & + & count=il_count_ord(:) ) + CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE ("//& + & TRIM(td_var%c_name)//") :" ) + + DEALLOCATE( dl_value ) + + END SUBROUTINE iom_cdf__write_var_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE iom_cdf diff --git a/V4.0/nemo_sources/tools/SIREN/src/iom_dom.f90 b/V4.0/nemo_sources/tools/SIREN/src/iom_dom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f2cd6939f6a419bc3bf4c08fd7313457d3e5a331 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/iom_dom.f90 @@ -0,0 +1,754 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module allow to read domain (defined as domain structure) in a mpp files. +!> +!> @details +!> to read one variable in an mpp files over domain defined as domain structure:<br/> +!> @code +!> tl_var=iom_dom_read_var( td_mpp, id_varid, td_dom ) +!> @endcode +!> or +!> @code +!> tl_var=iom_dom_read_var( td_mpp, cd_name, td_dom ) +!> @endcode +!> - td_mpp is a mpp structure +!> - id_varid is a variable id +!> - cd_name is variable name or standard name +!> - td_dom is a domain structure +!> +!> @author +!> J.Paul +!> +!> @date October, 2014 - Initial Version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE iom_dom + + USE netcdf ! nf90 library + USE global ! global parameter + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + USE dim ! dimension manager + USE att ! attribute manager + USE var ! variable manager + USE iom ! I/O manager + USE mpp ! mpp manager + USe dom ! domain manager + USE iom_mpp ! I/O mpp manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: iom_dom_open !< open files composing mpp structure over domain to be used + PUBLIC :: iom_dom_read_var !< read one variable in an mpp structure over domain to be used + PUBLIC :: iom_dom_close !< close file composing mpp structure over domain + + PRIVATE :: iom_dom__read_var_id ! read one variable in an mpp structure, given variable id + PRIVATE :: iom_dom__read_var_name ! read one variable in an mpp structure, given variable name + PRIVATE :: iom_dom__read_var_value ! read variable value in an mpp structure + PRIVATE :: iom_dom__no_pole_no_overlap ! do not overlap north fold boundary or east-west boundary + PRIVATE :: iom_dom__no_pole_cyclic ! do not overlap north fold boundary. However uses cyclic east-west boundary + PRIVATE :: iom_dom__no_pole_overlap ! do not overlap north fold boundary. However overlaps east-west boundary +! PRIVATE :: iom_dom__pole_no_overlap ! overlaps north fold boundary. However do not overlap east-west boundary +! PRIVATE :: iom_dom__pole_cyclic ! overlaps north fold boundary and uses cyclic east-west boundary +! PRIVATE :: iom_dom__pole_overlap ! overlaps north fold boundary and east-west boundary + + INTERFACE iom_dom_read_var ! read one variable in an mpp structure + MODULE PROCEDURE iom_dom__read_var_id ! given variable id + MODULE PROCEDURE iom_dom__read_var_name ! given variable name + END INTERFACE iom_dom_read_var + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom_open(td_mpp, td_dom, id_perio, id_ew) + !------------------------------------------------------------------- + !> @brief This subroutine open files composing mpp structure + !> over domain to be used. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + ! + !> @param[inout] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + TYPE(TDOM) , INTENT(IN) :: td_dom + INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew + + ! local variable + ! loop indices + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM DOM OPEN: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + ! get processor to be used + CALL mpp_get_use( td_mpp, td_dom%i_imin, td_dom%i_imax, & + & td_dom%i_jmin, td_dom%i_jmax ) + + CALL iom_mpp_open(td_mpp, id_perio, id_ew) + + ENDIF + + END SUBROUTINE iom_dom_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom_close(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine close files composing mpp structure. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + ! + !> @param[in] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! loop indices + !---------------------------------------------------------------- + + CALL iom_mpp_close(td_mpp) + + END SUBROUTINE iom_dom_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_dom__read_var_id(td_mpp, id_varid, td_dom) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in opened mpp files, + !> given variable id and domain strcuture. + !> + !> @details + !> Optionally start indices and number of point to be read could be specify. + !> as well as East West ovelap of the global domain. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[in] id_varid variable id + !> @param[in] td_dom domain structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + INTEGER(i4), INTENT(IN) :: id_varid + TYPE(TDOM) , INTENT(IN) :: td_dom + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_ind + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error(" IOM DOM READ VAR: domain decomposition "//& + & "not define in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN + ! look for variable id + il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, & + & mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid)) + IF( il_ind(1) /= 0 )THEN + + tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1))) + + !!! read variable value + CALL iom_dom__read_var_value(td_mpp, tf_var, td_dom) + + ELSE + CALL logger_error( & + & " IOM DOM READ VAR: there is no variable with id "//& + & TRIM(fct_str(id_varid))//" in processor/file "//& + & TRIM(td_mpp%t_proc(1)%c_name)) + ENDIF + ELSE + CALL logger_error(" IOM DOM READ VAR: can't read variable, mpp "//& + & TRIM(td_mpp%c_name)//" not opened") + ENDIF + + ENDIF + + END FUNCTION iom_dom__read_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_dom__read_var_name(td_mpp, cd_name, td_dom) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in opened mpp files, + !> given variable name or standard name, and domain structure. + !> + !> @details + !> Optionally start indices and number of point to be read could be specify. + !> as well as East West ovelap of the global domain. + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> If variable name is not present, check variable standard name.<br/> + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> @date May, 2019 + !> - copy variable struct without array of value, then read array of value. + !> + !> @param[in] td_mpp mpp structure + !> @param[in] cd_name variable name + !> @param[in] td_dom domain structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + CHARACTER(LEN=*), INTENT(IN) :: cd_name + TYPE(TDOM) , INTENT(IN) :: td_dom + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_ind + + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM DOM READ VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name) + IF( il_ind /= 0 )THEN + + tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind), ld_value=.FALSE.) + + !!! read variable value + CALL iom_dom__read_var_value( td_mpp, tf_var, td_dom ) + + ELSE + + CALL logger_error( & + & " IOM DOM READ VAR: there is no variable with "//& + & "name or standard name "//TRIM(cd_name)//& + & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name)) + ENDIF + + ENDIF + + END FUNCTION iom_dom__read_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom__read_var_value(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read variable value + !> in an mpp structure, given domain structure. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @todo + !> - handle north fold + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TDOM), INTENT(IN) :: td_dom + + ! local variable + INTEGER(i4) :: il_status + + TYPE(TATT) :: tl_att + TYPE(TMPP) :: tl_mpp + TYPE(TDOM) :: tl_dom + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + CALL logger_debug(" IOM DOM READ VAR VALUE: name "//& + & TRIM(td_var%c_name)//" "//TRIM(td_var%c_point) ) + CALL logger_debug(" IOM DOM READ VAR VALUE: ndim "//& + & TRIM(fct_str(td_var%i_ndim)) ) + + ! copy mpp structure + tl_mpp=mpp_copy(td_mpp) + ! forced to keep same id + tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id + + ! Allocate space to hold variable value in structure + IF( ASSOCIATED(td_var%d_value) )THEN + DEALLOCATE(td_var%d_value) + ENDIF + + ! copy domain structure + tl_dom=dom_copy(td_dom) + DO jk=1,ip_maxdim + IF( .NOT. td_var%t_dim(jk)%l_use ) tl_dom%t_dim(jk)%i_len = 1 + ENDDO + + ! use domain dimension + td_var%t_dim(1:2)%i_len=tl_dom%t_dim(1:2)%i_len + + ALLOCATE(td_var%d_value( tl_dom%t_dim(1)%i_len, & + & tl_dom%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM DOM READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + CALL logger_debug("IOM DOM READ VAR VALUE: shape ("//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" ) + ! FillValue by default + td_var%d_value(:,:,:,:)=td_var%d_fill + + IF( tl_dom%i_perio0 < 3 .OR. & + & tl_dom%i_jmax /= tl_dom%t_dim0(2)%i_len )THEN + ! no north pole + + IF( (tl_dom%i_perio0 == 1 .OR. & + & tl_dom%i_perio0 == 4 .OR. & + & tl_dom%i_perio0 == 6) .AND. & + & tl_dom%i_imin == 1 .AND. & + & tl_dom%i_imax == tl_dom%t_dim0(1)%i_len )THEN + ! east west cyclic + + CALL iom_dom__no_pole_cyclic(tl_mpp, td_var, tl_dom) + + ELSEIF( tl_dom%i_imin <= tl_dom%i_imax )THEN + ! no east west overlap + + CALL iom_dom__no_pole_no_overlap(tl_mpp, td_var, tl_dom) + + ! no more EW overlap in variable + td_var%i_ew=-1 + + ELSEIF( (tl_dom%i_perio0 == 1 .OR. & + & tl_dom%i_perio0 == 4 .OR. & + & tl_dom%i_perio0 == 6) .AND. & + & tl_dom%i_imin > tl_dom%i_imax )THEN + ! east west overlap + + CALL iom_dom__no_pole_overlap(tl_mpp, td_var, tl_dom) + + ! no more EW overlap in variable + td_var%i_ew=-1 + + ELSE + + CALL logger_fatal(" IOM DOM READ VAR VALUE: invalid domain definition.") + + ENDIF + + ELSE ! tl_dom%i_jmax == tl_dom%t_dim0(2)%i_len + ! north pole + + CALL logger_error("IOM DOM READ VAR VALUE: "//& + & TRIM(fct_str(tl_dom%i_jmin))//" "//& + & TRIM(fct_str(tl_dom%i_jmax)) ) + CALL logger_fatal("IOM DOM READ VAR VALUE: siren is not able to "//& + & "use north pole now, maybe in the next release") + ! IF( tl_dom%i_imin < tl_dom%i_imax )THEN + ! ! no east west overlap + + ! CALL iom_dom__pole_no_overlap(tl_mpp, td_var, tl_dom) + + ! ELSEIF(tl_dom%i_imin == tl_dom%i_imax)THEN + ! ! east west cyclic + + ! CALL iom_dom__pole_cyclic(tl_mpp, td_var, tl_dom) + + ! ELSE ! tl_dom%i_imin > tl_dom%i_imax + ! ! east west overlap + + ! CALL iom_dom__pole_overlap(tl_mpp, td_var, tl_dom) + + ! ENDIF + ENDIF + + ! clean + CALL mpp_clean(tl_mpp) + CALL dom_clean(tl_dom) + + IF( td_var%t_dim(1)%l_use .AND. & + & td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN + IF( td_mpp%i_ew >= 0 )THEN + tl_att=att_init("ew_overlap",td_mpp%i_ew) + CALL var_move_att(td_var,tl_att) + ! clean + CALL att_clean(tl_att) + ENDIF + ENDIF + + ! force to change _FillValue to avoid mistake + ! with dummy zero _FillValue + IF( td_var%d_fill == 0._dp )THEN + CALL var_chg_FillValue(td_var) + ENDIF + + END SUBROUTINE iom_dom__read_var_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom__no_pole_no_overlap(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read variable value + !> in an mpp structure. + !> @details + !> The output domain do not overlap + !> north fold boundary or east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TDOM), INTENT(IN) :: td_dom + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + TYPE(TDOM) :: tl_dom + + ! loop indices + !---------------------------------------------------------------- + + ! copy domain structure + tl_dom=dom_copy(td_dom) + + ! change dimension length if not use + IF( .NOT. td_var%t_dim(1)%l_use )THEN + tl_dom%i_imin=1 ; tl_dom%i_imax=1 + ENDIF + IF( .NOT. td_var%t_dim(2)%l_use )THEN + tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 + ENDIF + + il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/) + + il_count(:)=(/tl_dom%i_imax-tl_dom%i_imin+1, & + & tl_dom%i_jmax-tl_dom%i_jmin+1, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len/) + + td_var=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), & + & il_start(:), il_count(:) ) + + CALL dom_clean(tl_dom) + + END SUBROUTINE iom_dom__no_pole_no_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom__no_pole_cyclic(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read cyclic variable value + !> in an mpp structure. + !> @details + !> The output domain do not overlap north fold boundary. + !> However it uses cyclic east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN ) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TDOM), INTENT(IN ) :: td_dom + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + TYPE(TDOM) :: tl_dom + + ! loop indices + !---------------------------------------------------------------- + + ! copy domain structure + tl_dom=dom_copy(td_dom) + + ! cyclic domain + tl_dom%i_imin=1 + tl_dom%i_imax=tl_dom%t_dim(1)%i_len + + ! change dimension length if not use + IF( .NOT. td_var%t_dim(1)%l_use )THEN + tl_dom%i_imin=1 ; tl_dom%i_imax=1 + ENDIF + IF( .NOT. td_var%t_dim(2)%l_use )THEN + tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 + ENDIF + + il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/) + + il_count(:)=(/tl_dom%i_imax-tl_dom%i_imin+1, & + & tl_dom%i_jmax-tl_dom%i_jmin+1, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len /) + + td_var=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), & + & il_start(:), il_count(:) ) + + ! clean + CALL dom_clean(tl_dom) + + END SUBROUTINE iom_dom__no_pole_cyclic + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_dom__no_pole_overlap(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read East West overlap variable value + !> in an mpp structure. + !> @details + !> The output domain do not overlap north fold boundary. + !> However it overlaps east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + INTEGER(i4) :: il_dim1 + INTEGER(i4) :: il_dim2 + + TYPE(TVAR) :: tl_var1 + TYPE(TVAR) :: tl_var2 + + TYPE(TDOM) :: tl_dom + + ! loop indices + !---------------------------------------------------------------- + + ! copy domain structure + tl_dom=dom_copy(td_dom) + + ! change dimension length if not use + IF( .NOT. td_var%t_dim(1)%l_use )THEN + tl_dom%i_imin=1 ; tl_dom%i_imax=1 + ENDIF + IF( .NOT. td_var%t_dim(2)%l_use )THEN + tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 + ENDIF + + ! get first part of domain + tl_var1=var_copy(td_var) + DEALLOCATE(tl_var1%d_value) + + il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/) + + il_dim1 = td_mpp%t_dim(1)%i_len - td_mpp%i_ew - tl_dom%i_imin + 1 + + il_count(:)=(/il_dim1, & + & tl_dom%i_jmax-tl_dom%i_jmin+1, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len /) + + ! dimension part 1 + tl_var1%t_dim(:)%i_len=il_count(:) + + ALLOCATE(tl_var1%d_value(tl_var1%t_dim(1)%i_len, & + & tl_var1%t_dim(2)%i_len, & + & tl_var1%t_dim(3)%i_len, & + & tl_var1%t_dim(4)%i_len) ) + + tl_var1=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), & + & il_start(:), il_count(:) ) + + IF( td_var%t_dim(jp_I)%l_use )THEN + ! get second part of domain + tl_var2=var_copy(td_var) + DEALLOCATE(tl_var2%d_value) + + il_start(:)=(/1,tl_dom%i_jmin,1,1/) + + il_dim2 = tl_dom%i_imax + + il_count(:)=(/il_dim2, & + & tl_dom%i_jmax-tl_dom%i_jmin+1, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len /) + + ! dimension part 2 + tl_var2%t_dim(:)%i_len=il_count(:) + + ALLOCATE(tl_var2%d_value(tl_var2%t_dim(1)%i_len, & + & tl_var2%t_dim(2)%i_len, & + & tl_var2%t_dim(3)%i_len, & + & tl_var2%t_dim(4)%i_len) ) + + tl_var2=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), & + & il_start(:), il_count(:) ) + + ! concatenate both part + td_var=var_concat(tl_var1, tl_var2, jp_I) + + ! clean + CALL var_clean(tl_var1) + CALL var_clean(tl_var2) + ELSE + td_var=var_copy(tl_var1) + ! clean + CALL var_clean(tl_var1) + ENDIF + + ! clean + CALL dom_clean(tl_dom) + + END SUBROUTINE iom_dom__no_pole_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE iom_dom__pole_no_overlap(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read north fold variable value + !> in an mpp structure. + !> @details + !> The output domain overlaps + !> north fold boundary. However it do not overlap east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! TYPE(TMPP), INTENT(IN) :: td_mpp +! TYPE(TVAR), INTENT(INOUT) :: td_var +! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom +! +! ! local variable +! +! ! loop indices +! !---------------------------------------------------------------- +! +! END SUBROUTINE iom_dom__pole_no_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE iom_dom__pole_cyclic(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read semi global variable value + !> in an mpp structure. + !> @details + !> The output domain overlaps north fold boundary. + !> and uses cyclic east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !> @return variable structure completed + !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! TYPE(TMPP), INTENT(IN) :: td_mpp +! TYPE(TVAR), INTENT(INOUT) :: td_var +! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom +! +! ! local variable +! +! ! loop indices +! !---------------------------------------------------------------- +! +! END SUBROUTINE iom_dom__pole_cyclic + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SUBROUTINE iom_dom__pole_overlap(td_mpp, td_var, td_dom) + !------------------------------------------------------------------- + !> @brief This subroutine read north fold East West overlap variable value + !> in an mpp structure. + !> @details + !> The output domain overlaps north fold boundary. + !> and east-west boundary. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] td_dom domain structure + !> @return variable structure completed + !------------------------------------------------------------------- +! +! IMPLICIT NONE +! +! ! Argument +! TYPE(TMPP), INTENT(IN) :: td_mpp +! TYPE(TVAR), INTENT(INOUT) :: td_var +! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom +! +! ! local variable +! +! ! loop indices +! !---------------------------------------------------------------- +! +! END SUBROUTINE iom_dom__pole_overlap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE iom_dom diff --git a/V4.0/nemo_sources/tools/SIREN/src/iom_mpp.f90 b/V4.0/nemo_sources/tools/SIREN/src/iom_mpp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2275f755ddb2bef25cf1bacc28e366a4c14066db --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/iom_mpp.f90 @@ -0,0 +1,896 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module manage massively parallel processing Input/Output manager. +!> Library to read/write mpp files. +!> +!> @details +!> to open mpp files (only file to be used (see mpp_get_use) +!> will be open):<br/> +!> @code +!> CALL iom_mpp_open(td_mpp) +!> @endcode +!> - td_mpp is a mpp structure +!> +!> to creates mpp files:<br/> +!> @code +!> CALL iom_mpp_create(td_mpp) +!> @endcode +!> - td_mpp is a mpp structure +!> +!> to write in mpp files :<br/> +!> @code +!> CALL iom_mpp_write_file(td_mpp) +!> @endcode +!> - td_mpp is a mpp structure +!> +!> to close mpp files:<br/> +!> @code +!> CALL iom_mpp_close(td_mpp) +!> @endcode +!> +!> to read one variable in an mpp files:<br/> +!> @code +!> tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] ) +!> @endcode +!> or +!> @code +!> tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] ) +!> @endcode +!> - td_mpp is a mpp structure +!> - id_varid is a variable id +!> - cd_name is variable name or standard name +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> - id_ew East West overlap [optional] +!> +!> to fill variable value in mpp structure:<br/> +!> @code +!> CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] ) +!> @endcode +!> or<br/> +!> @code +!> CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] ) +!> @endcode +!> - td_mpp is mpp structure +!> - id_varid is variable id +!> - cd_name is variable name or standard name +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> - id_ew East West overlap [optional] +!> +!> to fill all variable in mpp structure:<br/> +!> @code +!> CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] ) +!> @endcode +!> - td_mpp is mpp structure +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> - id_ew East West overlap +!> +!> to write files composong mpp strucutre:<br/> +!> @code +!> CALL iom_mpp_write_file(td_mpp) +!> @endcode +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE iom_mpp + + USE netcdf ! nf90 library + USE global ! global parameter + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + USE dim ! dimension manager + USE att ! attribute manager + USE var ! variable manager + USE file ! file manager + USE iom ! I/O manager + USE mpp ! mpp manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: iom_mpp_open !< open all files composing mpp structure + PUBLIC :: iom_mpp_create !< creates files composing mpp structure + PUBLIC :: iom_mpp_close !< close file composing mpp structure + PUBLIC :: iom_mpp_read_var !< read one variable in an mpp structure + PUBLIC :: iom_mpp_write_file !< write mpp structure in files + + PRIVATE :: iom_mpp__read_var_id ! read one variable in an mpp structure, given variable id + PRIVATE :: iom_mpp__read_var_name ! read one variable in an mpp structure, given variable name + PRIVATE :: iom_mpp__read_var_value ! read variable value in an mpp structure + + INTERFACE iom_mpp_read_var ! read one variable in an mpp structure + MODULE PROCEDURE iom_mpp__read_var_id ! given variable id + MODULE PROCEDURE iom_mpp__read_var_name ! given variable name + END INTERFACE iom_mpp_read_var + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew) + !------------------------------------------------------------------- + !> @brief This subroutine open files composing mpp structure to be used. + !> @details + !> If try to open a file in write mode that did not exist, create it.<br/> + !> + !> If file already exist, get information about: + !> - the number of variables + !> - the number of dimensions + !> - the number of global attributes + !> - the ID of the unlimited dimension + !> - the file format + !> and finally read dimensions. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date August, 2017 + !> - handle use of domain decomposition for monoproc file + !> + !> @param[inout] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew + + ! local variable + CHARACTER(LEN=lc) :: cl_name + INTEGER(i4) :: il_pid + INTEGER(i4) :: il_impp + INTEGER(i4) :: il_jmpp + INTEGER(i4) :: il_lci + INTEGER(i4) :: il_lcj + INTEGER(i4) :: il_ldi + INTEGER(i4) :: il_ldj + INTEGER(i4) :: il_lei + INTEGER(i4) :: il_lej + LOGICAL :: ll_ctr + LOGICAL :: ll_use + LOGICAL :: ll_create + INTEGER(i4) :: il_iind + INTEGER(i4) :: il_jind + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM MPP OPEN: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + ! + td_mpp%i_id=1 + + ! if no processor file selected + ! force to open all files + IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN + td_mpp%t_proc(:)%l_use=.TRUE. + ENDIF + + ! add suffix to mpp name + td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), & + & TRIM(td_mpp%c_type) ) + + td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type) + IF( td_mpp%i_nproc > 1 .AND. td_mpp%l_usempp )THEN + DO ji=1,td_mpp%i_nproc + IF( td_mpp%t_proc(ji)%l_use )THEN + + SELECT CASE(TRIM(td_mpp%c_type)) + CASE('cdf') + cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) ) + CASE('dimg') + cl_name=TRIM( file_rename(td_mpp%c_name, ji) ) + CASE DEFAULT + CALL logger_fatal("IOM MPP OPEN: can not open file "//& + & "of type "//TRIM(td_mpp%c_type)) + END SELECT + + td_mpp%t_proc(ji)%c_name=TRIM(cl_name) + + CALL iom_open(td_mpp%t_proc(ji)) + + ENDIF + ENDDO + ELSE ! td_mpp%i_nproc == 1 + cl_name=TRIM( file_rename(td_mpp%c_name) ) + td_mpp%t_proc(1)%c_name=TRIM(cl_name) + + CALL iom_open(td_mpp%t_proc(1)) + + IF( .NOT. td_mpp%l_usempp )THEN + ! copy file structure of first proc, except layout decomposition + ! do not do it when creating output file. + ll_create=( ALL(td_mpp%t_proc(:)%l_wrt) .AND. & + & ALL(td_mpp%t_proc(:)%l_use) ) + IF( .NOT. ll_create )THEN + DO ji=2,td_mpp%i_nproc + IF( td_mpp%t_proc(ji)%l_use )THEN + il_pid = td_mpp%t_proc(ji)%i_pid + il_impp = td_mpp%t_proc(ji)%i_impp + il_jmpp = td_mpp%t_proc(ji)%i_jmpp + il_lci = td_mpp%t_proc(ji)%i_lci + il_lcj = td_mpp%t_proc(ji)%i_lcj + il_ldi = td_mpp%t_proc(ji)%i_ldi + il_ldj = td_mpp%t_proc(ji)%i_ldj + il_lei = td_mpp%t_proc(ji)%i_lei + il_lej = td_mpp%t_proc(ji)%i_lej + ll_ctr = td_mpp%t_proc(ji)%l_ctr + ll_use = td_mpp%t_proc(ji)%l_use + il_iind = td_mpp%t_proc(ji)%i_iind + il_jind = td_mpp%t_proc(ji)%i_jind + + td_mpp%t_proc(ji)=file_copy(td_mpp%t_proc(1)) + td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id + td_mpp%t_proc(ji)%l_def=.FALSE. + + td_mpp%t_proc(ji)%i_pid = il_pid + td_mpp%t_proc(ji)%i_impp = il_impp + td_mpp%t_proc(ji)%i_jmpp = il_jmpp + td_mpp%t_proc(ji)%i_lci = il_lci + td_mpp%t_proc(ji)%i_lcj = il_lcj + td_mpp%t_proc(ji)%i_ldi = il_ldi + td_mpp%t_proc(ji)%i_ldj = il_ldj + td_mpp%t_proc(ji)%i_lei = il_lei + td_mpp%t_proc(ji)%i_lej = il_lej + td_mpp%t_proc(ji)%l_ctr = ll_ctr + td_mpp%t_proc(ji)%l_use = ll_use + td_mpp%t_proc(ji)%i_iind = il_iind + td_mpp%t_proc(ji)%i_jind = il_jind + ENDIF + ENDDO + ELSE + ! keep file id + DO ji=2,td_mpp%i_nproc + IF( td_mpp%t_proc(ji)%l_use )THEN + td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id + td_mpp%t_proc(ji)%l_def=.FALSE. + ENDIF + ENDDO + ENDIF + ENDIF + + ENDIF + + IF( PRESENT(id_ew) )THEN + td_mpp%i_ew=id_ew + ! add east west overlap to each variable + DO ji=1,td_mpp%i_nproc + WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use) + td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew + ENDWHERE + ENDDO + ENDIF + + IF( PRESENT(id_perio) )THEN + td_mpp%i_perio=id_perio + ENDIF + + ENDIF + + END SUBROUTINE iom_mpp_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp_create(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine create files, composing mpp structure to be used, + !> in write mode. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM MPP CREATE: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + ! forced to open in write mode + td_mpp%t_proc(:)%l_wrt=.TRUE. + td_mpp%t_proc(:)%l_use=.TRUE. + CALL iom_mpp_open(td_mpp) + ENDIF + + END SUBROUTINE iom_mpp_create + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp_close(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine close files composing mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM MPP CLOSE: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + ! + td_mpp%i_id=0 + + IF( td_mpp%l_usempp )THEN + DO ji=1,td_mpp%i_nproc + IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN + CALL iom_close(td_mpp%t_proc(ji)) + ENDIF + ENDDO + ELSE + IF( td_mpp%t_proc(1)%i_id /= 0 )THEN + CALL iom_close(td_mpp%t_proc(1)) + td_mpp%t_proc(:)%i_id=0 + ENDIF + ENDIF + td_mpp%t_proc(:)%l_use=.FALSE. + + ENDIF + + END SUBROUTINE iom_mpp_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_mpp__read_var_id(td_mpp, id_varid, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in opened mpp files, + !> given variable id. + !> + !> @details + !> Optionally start indices and number of point to be read could be specify. + !> as well as East West ovelap of the global domain. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - use start and count array instead of domain structure. + !> + !> @param[in] td_mpp mpp structure + !> @param[in] id_varid variable id + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_ind + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSEIF( td_mpp%i_id == 0 )THEN + + CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//& + & " can not read variable in "//TRIM(td_mpp%c_name)) + + ELSE + + + IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN + ! look for variable id + il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, & + & mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid)) + IF( il_ind(1) /= 0 )THEN + + tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1))) + + !!! read variable value + CALL iom_mpp__read_var_value(td_mpp, tf_var, id_start, id_count) + + ELSE + CALL logger_error( & + & " IOM MPP READ VAR: there is no variable with id "//& + & TRIM(fct_str(id_varid))//" in processor/file "//& + & TRIM(td_mpp%t_proc(1)%c_name)) + ENDIF + ELSE + CALL logger_error(" IOM MPP READ VAR: can't read variable, mpp "//& + & TRIM(td_mpp%c_name)//" not opened") + ENDIF + + ENDIF + + END FUNCTION iom_mpp__read_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in opened mpp files, + !> given variable name or standard name. + !> + !> @details + !> Optionally start indices and number of point to be read could be specify. + !> as well as East West ovelap of the global domain. + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> If variable name is not present, check variable standard name.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - use start and count array instead of domain structure. + !> + !> @param[in] td_mpp mpp structure + !> @param[in] cd_name variable name + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_ind + !---------------------------------------------------------------- + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSEIF( td_mpp%i_id == 0 )THEN + + CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//& + & " can not read variable in "//TRIM(td_mpp%c_name)) + + ELSE + + il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name) + IF( il_ind /= 0 )THEN + + tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind)) + + !!! read variable value + CALL iom_mpp__read_var_value( td_mpp, tf_var, id_start, id_count) + + ELSE + + CALL logger_fatal( & + & " IOM MPP READ VAR: there is no variable with "//& + & "name or standard name "//TRIM(cd_name)//& + & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name)) + ENDIF + + ENDIF + + END FUNCTION iom_mpp__read_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine read variable value + !> in an mpp structure. + !> + !> @details + !> Optionally start indices and number of point to be read could be specify. + !> as well as East West ovelap of the global domain. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - use start and count array instead of domain structure. + !> + !> @param[in] td_mpp mpp structure + !> @param[inout] td_var variable structure + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN ) :: td_mpp + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4), DIMENSION(4) :: il_ind + INTEGER(i4) :: il_i1p + INTEGER(i4) :: il_i2p + INTEGER(i4) :: il_j1p + INTEGER(i4) :: il_j2p + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + INTEGER(i4) :: il_j1 + INTEGER(i4) :: il_j2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_end + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt + INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt + + TYPE(TATT) :: tl_att + TYPE(TVAR) :: tl_var + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_start(:)=1 + IF( PRESENT(id_start) ) il_start(:)=id_start(:) + + il_count(:)=td_mpp%t_dim(:)%i_len + IF( PRESENT(id_count) ) il_count(:)=id_count(:) + + CALL logger_debug("IOM MPP READ VAR VALUE: start "//& + & TRIM(fct_str(il_start(jp_I)))//","//& + & TRIM(fct_str(il_start(jp_J)))//","//& + & TRIM(fct_str(il_start(jp_K)))//","//& + & TRIM(fct_str(il_start(jp_L))) ) + CALL logger_debug("IOM MPP READ VAR VALUE: count "//& + & TRIM(fct_str(il_count(jp_I)))//","//& + & TRIM(fct_str(il_count(jp_J)))//","//& + & TRIM(fct_str(il_count(jp_K)))//","//& + & TRIM(fct_str(il_count(jp_L))) ) + + !IF( td_mpp%l_usempp .AND. (PRESENT(id_start) .OR. PRESENT(id_count)))THEN + ! CALL logger_fatal("IOM MPP READ VAR VALUE: should not use"//& + ! & " start or count arguments when usempp is False.") + !ENDIF + + DO jk=1,ip_maxdim + IF( .NOT. td_var%t_dim(jk)%l_use )THEN + il_start(jk) = 1 + il_count(jk) = 1 + ENDIF + + il_end(jk)=il_start(jk)+il_count(jk)-1 + ENDDO + + IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN + CALL logger_debug("IOM MPP READ VAR VALUE: start + count "//& + & TRIM(fct_str(il_end(jp_I)))//","//& + & TRIM(fct_str(il_end(jp_J)))//","//& + & TRIM(fct_str(il_end(jp_K)))//","//& + & TRIM(fct_str(il_end(jp_L))) ) + CALL logger_debug("IOM MPP READ VAR VALUE: dimension "//& + & TRIM(fct_str(td_mpp%t_dim(jp_I)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(jp_J)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(jp_K)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(jp_L)%i_len)) ) + CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//& + & "exceed dimension bound.") + ENDIF + + ! use domain dimension + td_var%t_dim(:)%i_len=il_count(:) + + ! Allocate space to hold variable value in structure + IF( ASSOCIATED(td_var%d_value) )THEN + DEALLOCATE(td_var%d_value) + ENDIF + + ALLOCATE(td_var%d_value( il_count(1), & + & il_count(2), & + & il_count(3), & + & il_count(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " IOM MPP READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//& + & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" ) + ! FillValue by default + td_var%d_value(:,:,:,:)=td_var%d_fill + + ! read processor + DO jk=1,td_mpp%i_nproc + IF( td_mpp%t_proc(jk)%l_use )THEN + + ! get processor indices + il_ind(:)=mpp_get_proc_index( td_mpp, jk ) + il_i1p = il_ind(1) + il_i2p = il_ind(2) + il_j1p = il_ind(3) + il_j2p = il_ind(4) + + IF( .NOT. td_var%t_dim(1)%l_use )THEN + il_i1p=il_start(1) ; il_i2p=il_end(1) + ENDIF + IF( .NOT. td_var%t_dim(2)%l_use )THEN + il_j1p=il_start(2) ; il_j2p=il_end(2) + ENDIF + + il_i1=MAX(il_i1p, il_start(1)) + il_i2=MIN(il_i2p, il_end(1)) + + il_j1=MAX(il_j1p, il_start(2)) + il_j2=MIN(il_j2p, il_end(2)) + + IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN + IF( td_mpp%l_usempp )THEN + il_strt(:)=(/ il_i1-il_i1p+1, & + & il_j1-il_j1p+1, & + & 1,1 /) + ELSE + il_strt(:)=(/ il_i1, & + & il_j1, & + & 1,1 /) + ENDIF + + il_cnt(:)=(/ il_i2-il_i1+1, & + & il_j2-il_j1+1, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len /) + + tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,& + & il_strt(:), il_cnt(:) ) + ! replace value in output variable structure + td_var%d_value( il_i1 - il_start(1) + 1 : & + & il_i2 - il_start(1) + 1, & + & il_j1 - il_start(2) + 1 : & + & il_j2 - il_start(2) + 1, & + & :,:) = tl_var%d_value(:,:,:,:) + + ! clean + CALL var_clean(tl_var) + ENDIF + + ENDIF + ENDDO + + IF( td_var%t_dim(1)%l_use .AND. & + & td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN + IF( td_mpp%i_ew >= 0 )THEN + tl_att=att_init("ew_overlap",td_mpp%i_ew) + CALL var_move_att(td_var,tl_att) + ! clean + CALL att_clean(tl_att) + ENDIF + ENDIF + + ! force to change _FillValue to avoid mistake + ! with dummy zero _FillValue + IF( td_var%d_fill == 0._dp )THEN + CALL var_chg_FillValue(td_var) + ENDIF + + END SUBROUTINE iom_mpp__read_var_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp_write_file(td_mpp, cd_dimorder) + !------------------------------------------------------------------- + !> @brief This subroutine write files composing mpp structure. + !> + !> @details + !> optionally, you could specify the dimension order (default 'xyzt') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - add dimension order option + !> @date August, 2017 + !> - handle use of domain decomposition for monoproc file + !> + !> @param[inout] td_mpp mpp structure + !> @param[in] cd_dimorder dimension order + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( " MPP WRITE: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + IF( td_mpp%l_usempp )THEN + DO ji=1, td_mpp%i_nproc + IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN + CALL logger_debug("MPP WRITE: proc "//TRIM(fct_str(ji))) + CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder) + ELSE + CALL logger_debug( " MPP WRITE: no id associated to file "//& + & TRIM(td_mpp%t_proc(ji)%c_name) ) + ENDIF + ENDDO + ELSE + CALL iom_write_header(td_mpp%t_proc(1), cd_dimorder, td_mpp%t_dim(:)) + + CALL iom_mpp__write_var(td_mpp, cd_dimorder) + ENDIF + ENDIF + + END SUBROUTINE iom_mpp_write_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_mpp__write_var(td_mpp, cd_dimorder) + !------------------------------------------------------------------- + !> @brief This subroutine write variables from mpp structure in one output + !> file. + !> + !> @details + !> optionally, you could specify the dimension order (default 'xyzt') + !> + !> @author J.Paul + !> @date August, 2017 - Initial Version + !> + !> @param[inout] td_mpp mpp structure + !> @param[in] cd_dimorder dimension order + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder + + ! local variable + INTEGER(i4), DIMENSION(4) :: il_ind + INTEGER(i4) :: il_i1p + INTEGER(i4) :: il_i2p + INTEGER(i4) :: il_j1p + INTEGER(i4) :: il_j2p + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + INTEGER(i4) :: il_j1 + INTEGER(i4) :: il_j2 + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt + INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt + + REAL(dp) :: dl_fill + + TYPE(TFILE) :: tl_file + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! write variable in file + DO jj = 1, td_mpp%i_nproc + + ! link + tl_file=td_mpp%t_proc(jj) + CALL logger_debug("IOM MPP WRITE: proc "//fct_str(jj)) + + ! get processor indices + il_ind(:)=mpp_get_proc_index( td_mpp, jj ) + il_i1p = il_ind(1) + il_i2p = il_ind(2) + il_j1p = il_ind(3) + il_j2p = il_ind(4) + + IF( jj > 1 )THEN + ! force to use id from variable write on first proc + tl_file%t_var(:)%i_id=td_mpp%t_proc(1)%t_var(:)%i_id + ENDIF + + DO ji = 1, tl_file%i_nvar + + IF( jj > 1 )THEN + ! check _FillValue + dl_fill=td_mpp%t_proc(1)%t_var(ji)%d_fill + IF( tl_file%t_var(ji)%d_fill /= dl_fill )THEN + CALL var_chg_FillValue( tl_file%t_var(ji), dl_fill ) + ENDIF + ENDIF + + il_start(:)=1 + il_count(:)=td_mpp%t_dim(:)%i_len + + IF( .NOT. tl_file%t_var(ji)%t_dim(1)%l_use )THEN + il_i1p=1 ; il_i2p=1 + il_count(1) = 1 + ENDIF + IF( .NOT. tl_file%t_var(ji)%t_dim(2)%l_use )THEN + il_j1p=1 ; il_j2p=1 + il_count(2) = 1 + ENDIF + + il_i1=MAX(il_i1p, il_start(1)) + il_i2=MIN(il_i2p, il_count(1)) + + il_j1=MAX(il_j1p, il_start(2)) + il_j2=MIN(il_j2p, il_count(2)) + + IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN + il_strt(:)=(/ il_i1, & + & il_j1, & + & 1,1 /) + + il_cnt(:)=(/ il_i2-il_i1+1, & + & il_j2-il_j1+1, & + & tl_file%t_var(ji)%t_dim(3)%i_len, & + & tl_file%t_var(ji)%t_dim(4)%i_len /) + + CALL iom_write_var(tl_file, cd_dimorder, & + & id_start=il_strt(:), & + & id_count=il_cnt(:)) + ENDIF + + ENDDO + ENDDO + + END SUBROUTINE iom_mpp__write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE iom_mpp diff --git a/V4.0/nemo_sources/tools/SIREN/src/iom_rstdimg.f90 b/V4.0/nemo_sources/tools/SIREN/src/iom_rstdimg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ba4edea2c7275de083a699d822a5723c492e4706 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/iom_rstdimg.f90 @@ -0,0 +1,1867 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module is a library to read/write dimg file. +!> +!> @details +!> to open dimg file (create file structure):<br/> +!> @code +!> CALL iom_rstdimg_open(td_file) +!> @endcode +!> - td_file is file structure (see file.f90) +!> +!> to write in dimg file:<br/> +!> @code +!> CALL iom_rstdimg_write_file(td_file) +!> @endcode +!> +!> to close dimg file:<br/> +!> @code +!> CALL iom_rstdimg_close(tl_file) +!> @endcode +!> +!> to read one dimension in dimg file:<br/> +!> @code +!> tl_dim = iom_rstdimg_read_dim(tl_file, id_dimid) +!> @endcode +!> or +!> @code +!> tl_dim = iom_rstdimg_read_dim(tl_file, cd_name) +!> @endcode +!> - id_dimid is dimension id<br/> +!> - cd_name is dimension name +!> +!> to read one variable in dimg file:<br/> +!> @code +!> tl_var = iom_rstdimg_read_var(td_file, id_varid, [id_start, id_count]) +!> @endcode +!> or +!> @code +!> tl_var = iom_rstdimg_read_var(td_file, cd_name, [id_start, [id_count]]) +!> @endcode +!> - id_varid is variabale id +!> - cd_name is variabale name or standard name +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> +!> to get sub domain decomppistion in a dimg file:<br/> +!> @code +!> CALL iom_rstdimg_get_mpp(td_file) +!> @endcode +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date August, 2017 +!> - handle use of domain decomposition for monoproc file +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE iom_rstdimg + + USE netcdf ! nf90 library + USE global ! global parameter + USE kind ! F90 kind parameter + USE fct ! basic useful function + USE logger ! log file manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PRIVATE :: im_vnl !< variable name length + + ! function and subroutine + PUBLIC :: iom_rstdimg_open !< open or create dimg file, return file structure + PUBLIC :: iom_rstdimg_close !< close dimg file + PUBLIC :: iom_rstdimg_read_dim !< read one dimension in an opened dimg file, return variable structure + PUBLIC :: iom_rstdimg_read_var !< read one variable in an opened dimg file, return dimension structure + PUBLIC :: iom_rstdimg_write_header!< write header in an opened dimg file + PUBLIC :: iom_rstdimg_write_var !< write variable in an opened dimg file + PUBLIC :: iom_rstdimg_get_mpp !< get sub domain decomppistion in a dimg file + + PRIVATE :: iom_rstdimg__get_info ! get global information in an opened dimg file + PRIVATE :: iom_rstdimg__get_file_var ! read information about variable on an opened dimg file. + PRIVATE :: iom_rstdimg__get_file_var_0d ! put information about scalar variable in file structure + PRIVATE :: iom_rstdimg__get_file_var_1d ! put information about variable 1D in file structure + PRIVATE :: iom_rstdimg__get_file_var_2d ! put information about variable 2D in file structure + PRIVATE :: iom_rstdimg__get_file_var_3d ! put information about variable 3D in file structure + PRIVATE :: iom_rstdimg__read_dim_id ! read dimension structure in an opened dimg file, given variable id. + PRIVATE :: iom_rstdimg__read_dim_name ! read dimension structure in an opened dimg file, given variable name or standard name. + PRIVATE :: iom_rstdimg__read_var_id ! read variable value in an opened dimg file, given variable id. + PRIVATE :: iom_rstdimg__read_var_name ! read variable value in an opened dimg file, given variable name or standard name. + PRIVATE :: iom_rstdimg__read_var_value ! read variable value in an opened dimg file, for variable 1,2,3d + PRIVATE :: iom_rstdimg__get_rec ! compute record number before writing file + PRIVATE :: iom_rstdimg__write_header ! write header in an opened dimg file + PRIVATE :: iom_rstdimg__write_var ! write variables in an opened dimg file + + ! module variable + INTEGER(i4), PARAMETER :: im_vnl = 32 ! variable name length + + INTERFACE iom_rstdimg_read_dim + MODULE PROCEDURE iom_rstdimg__read_dim_id + MODULE PROCEDURE iom_rstdimg__read_dim_name + END INTERFACE iom_rstdimg_read_dim + + INTERFACE iom_rstdimg_read_var + MODULE PROCEDURE iom_rstdimg__read_var_id + MODULE PROCEDURE iom_rstdimg__read_var_name + END INTERFACE iom_rstdimg_read_var + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg_open(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine open a dimg file in read or write mode. + !> @details + !> if try to open a file in write mode that did not exist, create it.<br/> + !> if file already exist, get information about: + !> - the number of variables + !> - the number of dimensions + !> - the number of global attributes + !> - the ID of the unlimited dimension + !> - the file format + !> Finally it read dimensions, and 'longitude' variable to compute East-West + !> overlap. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + LOGICAL :: ll_exist + LOGICAL :: ll_open + + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + ! check file existence + ! WARNING may be some issue with dimg file !!! + INQUIRE(FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open) + IF( .NOT. ll_exist .OR. TRIM(td_file%c_type) /= 'dimg' )THEN + + IF( .NOT. td_file%l_wrt )THEN + + CALL logger_fatal( " OPEN: can not open dimg file "//& + & TRIM(td_file%c_name) ) + + ELSE + + CALL logger_info( " CREATE: dimg file "//TRIM(td_file%c_name) ) + + ! get free unit + td_file%i_id=fct_getunit() + + OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),& + & FORM='UNFORMATTED', & + & ACCESS='DIRECT', & + & STATUS='NEW', & + & ACTION='WRITE', & + & RECL=8, & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CREATE: dimg file "//& + & TRIM(td_file%c_name)) + ENDIF + + ENDIF + + ELSE + + IF( ll_open )THEN + + CALL logger_error( " OPEN: dimg file "//& + & TRIM(td_file%c_name)//" already opened") + + ELSE + + ! get free unit + td_file%i_id=fct_getunit() + + ! open temporary in read only mode + OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),& + & FORM='UNFORMATTED', & + & ACCESS='DIRECT', & + & STATUS='OLD', & + & ACTION='READ', & + & RECL=8, & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("OPEN: file "//TRIM(td_file%c_name)) + ENDIF + + ! get record length + READ( td_file%i_id, IOSTAT=il_status, & + & REC=1) td_file%i_recl + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("OPEN: read record length : "//& + & TRIM(fct_str(td_file%i_recl))//" in file "//& + & TRIM(td_file%c_name) ) + ENDIF + + CLOSE( td_file%i_id, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("OPEN: close file "//TRIM(td_file%c_name)) + ENDIF + + IF( .NOT. td_file%l_wrt )THEN + + CALL logger_info( " OPEN: dimg file "//& + & TRIM(td_file%c_name)//" in read only mode" ) + + ! open file in read mode + OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),& + & FORM='UNFORMATTED', & + & ACCESS='DIRECT', & + & STATUS='OLD', & + & ACTION='READ', & + & RECL=td_file%i_recl, & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_debug("IOM RSTDIMG OPEN: open staus "//& + & TRIM(fct_str(il_status))) + CALL logger_fatal("IOM RSTDIMG OPEN: file "//& + & TRIM(td_file%c_name)& + & //" with record length "//TRIM(fct_str(td_file%i_recl))) + ENDIF + + ELSE + + CALL logger_info( " OPEN: dimg file "//& + & TRIM(td_file%c_name)//& + & " in read and write mode") + + ! open file in read mode + OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),& + & FORM='UNFORMATTED', & + & ACCESS='DIRECT', & + & STATUS='OLD', & + & ACTION='READWRITE', & + & RECL=td_file%i_recl, & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_debug("IOM RSTDIMG OPEN: open staus "//& + & TRIM(fct_str(il_status))) + CALL logger_error("IOM RSTDIMG OPEN: file "//& + & TRIM(td_file%c_name)) + ENDIF + + ENDIF + + ! get general information about file + CALL iom_rstdimg__get_info(td_file) + + ! get domain decomposition in file + CALL iom_rstdimg_get_mpp(td_file) + + ! get information about variables in file + CALL iom_rstdimg__get_file_var(td_file) + + ENDIF + + ENDIF + + END SUBROUTINE iom_rstdimg_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg_close(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine close dimg file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " CLOSE: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + CALL logger_info( & + & " CLOSE: file "//TRIM(td_file%c_name)) + + CLOSE( td_file%i_id, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("CLOSE "//TRIM(td_file%c_name)) + ENDIF + + td_file%i_id = 0 + + ENDIF + + END SUBROUTINE iom_rstdimg_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_info(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine get global information in an opened dimg + !> file. + !> @details + !> It gets the number of variables, the domain decompistion, + !> the record of the header.<br/> + !> It read dimensions, and add it to dimension structure inside + !> file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January,2019 + !> - clean dimension structure + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_recl ! record length + INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension + INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables + INTEGER(i4) :: il_rhd ! record of the header infos + + TYPE(TDIM) :: tl_dim ! dimension structure + !---------------------------------------------------------------- + + CALL logger_debug( & + & " IOM RSTDIMG GET INFO: about dimg file "//TRIM(td_file%c_name)) + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=1 )& + & il_recl, & + & il_nx, il_ny, il_nz, & + & il_n0d, il_n1d, il_n2d, il_n3d, & + & il_rhd + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_debug(" READ status: "//TRIM(fct_str(il_status))) + CALL logger_fatal("IOM RSTDIMG GET INFO: read first line of "//& + & TRIM(td_file%c_name)) + ENDIF + + td_file%c_type='dimg' + + ! add dimension to file structure + tl_dim=dim_init('X', il_nx) + CALL file_move_dim(td_file, tl_dim) + tl_dim=dim_init('Y', il_ny) + CALL file_move_dim(td_file, tl_dim) + tl_dim=dim_init('Z', il_nz) + CALL file_move_dim(td_file, tl_dim) + + ! reorder dimension to ('x','y','z','t') + ! actually fill unused dimension + CALL dim_reorder(td_file%t_dim) + + ! save total number of variable + td_file%i_n0d=il_n0d + td_file%i_n1d=il_n1d + td_file%i_n2d=il_n2d + td_file%i_n3d=il_n3d + td_file%i_nvar=il_n0d+il_n1d+il_n2d+il_n3d + + ! record header infos + td_file%i_rhd=il_rhd + + ! clean + CALL dim_clean(tl_dim) + + END SUBROUTINE iom_rstdimg__get_info + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg_get_mpp(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine get sub domain decomposition in a dimg file. + !> @details + !> domain decomposition informations are saved in attributes. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2016 + !> - mismatch with "halo" indices + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + TYPE(TATT) :: tl_att + INTEGER(i4) :: il_status + INTEGER(i4) :: il_recl ! record length + INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension + INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables + INTEGER(i4) :: il_iglo, il_jglo ! domain global size + INTEGER(i4) :: il_rhd ! record of the header infos + INTEGER(i4) :: il_niproc, il_njproc, il_nproc ! domain decomposition + INTEGER(i4) :: il_area ! domain index + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej + !---------------------------------------------------------------- + + CALL logger_debug( " IOM RSTDIMG GET MPP: dimg file "//& + & TRIM(td_file%c_name)) + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=1 )& + & il_recl, & + & il_nx, il_ny, il_nz, & + & il_n0d, il_n1d, il_n2d, il_n3d, & + & il_rhd, & + & il_niproc, il_njproc, il_nproc, & + & il_area, & + & il_iglo, il_jglo + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//& + & TRIM(fct_str(il_status))) + CALL logger_error(" IOM RSTDIMG GET MPP: read first line of "//& + & TRIM(td_file%c_name)) + ENDIF + + ! create attributes to save mpp value + tl_att=att_init( "DOMAIN_number_total", il_nproc) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "DOMAIN_I_number_total", il_niproc) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "DOMAIN_J_number_total", il_njproc) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "DOMAIN_number", il_area) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "DOMAIN_size_global", (/il_iglo, il_jglo/)) + CALL file_move_att(td_file, tl_att) + + ! allocate local variable + ALLOCATE( il_impp(il_nproc), il_jmpp(il_nproc),& + & il_lci(il_nproc), il_lcj(il_nproc), & + & il_ldi(il_nproc), il_ldj(il_nproc), & + & il_lei(il_nproc), il_lej(il_nproc), & + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( " IOM RSTDIMG GET MPP: not enough space to put "//& + & "domain decomposition in file "//TRIM(td_file%c_name) ) + + ENDIF + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=1 )& + & il_recl, & + & il_nx, il_ny, il_nz, & + & il_n0d, il_n1d, il_n2d, il_n3d, & + & il_rhd, & + & il_niproc, il_njproc, il_nproc, & + & il_area, & + & il_iglo, il_jglo, & + & il_lci(:), il_lcj(:), & + & il_ldi(:), il_ldj(:), & + & il_lei(:), il_lej(:), & + & il_impp(:),il_jmpp(:) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//& + & TRIM(fct_str(il_status))) + CALL logger_fatal("IOM RSTDIMG GET MPP: read domain decomposition "//& + & "on first line of "//TRIM(td_file%c_name)) + ENDIF + + tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", il_impp(:) ) + CALL file_move_att(td_file, tl_att) + tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", il_jmpp(:) ) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "SUBDOMAIN_I_dimensions", il_lci(:)) + CALL file_move_att(td_file, tl_att) + tl_att=att_init( "SUBDOMAIN_J_dimensions", il_lcj(:)) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", il_ldi(:)) + CALL file_move_att(td_file, tl_att) + tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", il_ldj(:)) + CALL file_move_att(td_file, tl_att) + + tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", il_lei(:)) + CALL file_move_att(td_file, tl_att) + tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", il_lej(:)) + CALL file_move_att(td_file, tl_att) + + ! clean + CALL att_clean(tl_att) + + DEALLOCATE( il_impp, il_jmpp,& + & il_lci, il_lcj, & + & il_ldi, il_ldj, & + & il_lei, il_lej ) + + END SUBROUTINE iom_rstdimg_get_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_file_var(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine read information about variable on an + !> opened dimg file. + !> @details + !> The variables structures inside file structure are then completed. + !> Variables no0d, no1d, no2d, no3d are deleted from file strucutre. + !> @note variable value are read only for scalar variable (0d). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + CHARACTER(LEN=im_vnl), DIMENSION(:), ALLOCATABLE :: cl_name + + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_start + INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_count + !---------------------------------------------------------------- + + IF( td_file%i_nvar > 0 )THEN + + ALLOCATE( il_start(4), il_count(4) ) + + il_start(1) = 1 + il_count(1) = td_file%i_n0d + + il_start(2) = 1 + il_count(1) + il_count(2) = il_start(2) - 1 + td_file%i_n1d + + il_start(3) = 1 + il_count(2) + il_count(3) = il_start(3) - 1 + td_file%i_n2d + + il_start(4) = 1 + il_count(3) + il_count(4) = il_start(4) - 1 + td_file%i_n3d + + ALLOCATE( cl_name(td_file%i_nvar), dl_value(td_file%i_nvar) ) + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=td_file%i_rhd )& + & cl_name(il_start(1):il_count(1)), dl_value(il_start(1):il_count(1)),& + & cl_name(il_start(2):il_count(2)), dl_value(il_start(2):il_count(2)),& + & cl_name(il_start(3):il_count(3)), dl_value(il_start(3):il_count(3)),& + & cl_name(il_start(4):il_count(4)), dl_value(il_start(4):il_count(4)) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("GET FILE: reading headers in file "//& + & TRIM(td_file%c_name)) + ENDIF + + DEALLOCATE( il_start, il_count ) + + IF(ASSOCIATED(td_file%t_var))THEN + CALL var_clean(td_file%t_var(:)) + DEALLOCATE(td_file%t_var) + ENDIF + ALLOCATE(td_file%t_var(td_file%i_nvar)) + + ! put information about variable 0D inside file structure + CALL iom_rstdimg__get_file_var_0d(td_file, cl_name(:), dl_value(:)) + + ! put information about variable 1D inside file structure + CALL iom_rstdimg__get_file_var_1d(td_file, cl_name(:), dl_value(:)) + + ! put information about variable 2D inside file structure + CALL iom_rstdimg__get_file_var_2d(td_file, cl_name(:), dl_value(:)) + + ! put information about variable 3D inside file structure + CALL iom_rstdimg__get_file_var_3d(td_file, cl_name(:), dl_value(:)) + + DEALLOCATE( cl_name, dl_value ) + + ! delete dummy variable + CALL file_del_var( td_file, 'no0d' ) + CALL file_del_var( td_file, 'no1d' ) + CALL file_del_var( td_file, 'no2d' ) + CALL file_del_var( td_file, 'no3d' ) + + ELSE + + CALL logger_debug( & + & " GET FILE VAR: there is no variable in file "//& + & TRIM(td_file%c_name)) + + ENDIF + + END SUBROUTINE iom_rstdimg__get_file_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_file_var_0d(td_file, cd_name, dd_value) + !------------------------------------------------------------------- + !> @brief This subroutine put informations about scalar variable + !> inside file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name array of variable name + !> @param[in] dd_value array of variable value + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value + + ! local variable + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! define same dimension as in file + tl_dim(:)=dim_copy(td_file%t_dim(:)) + ! do not use any dimension + tl_dim(:)%l_use=.FALSE. + tl_dim(:)%i_len=1 + + ! case scalar variable + DO ji = 1, td_file%i_n0d + + td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, & + & tl_dim(:), dd_fill=0._dp, & + & id_id=ji, id_rec=1 ) + + ! get value of scalar + IF( ASSOCIATED(td_file%t_var(ji)%d_value) )THEN + DEALLOCATE(td_file%t_var(ji)%d_value) + ENDIF + ALLOCATE(td_file%t_var(ji)%d_value(1,1,1,1)) + + td_file%t_var(ji)%d_value(1,1,1,1)=dd_value(ji) + + ENDDO + + ! clean + CALL dim_clean(tl_dim(:)) + + END SUBROUTINE iom_rstdimg__get_file_var_0d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_file_var_1d(td_file, cd_name, dd_value) + !------------------------------------------------------------------- + !> @brief This subroutine put informations about variable 1D + !> inside file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2016 + !> - change right dimension struct + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name array of variable name + !> @param[in] dd_value array of variable record + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value + + ! local variable + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! case variable 1D + DO ji = td_file%i_n0d + 1, & + & td_file%i_n0d + td_file%i_n1d + + ! define same dimension as in file + tl_dim(:)=dim_copy(td_file%t_dim(:)) + ! do not use X and Y dimension + tl_dim(1:2)%l_use=.FALSE. + tl_dim(1:2)%i_len=1 + + td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, & + & tl_dim(:), dd_fill=0._dp, & + & id_id=ji, id_rec=INT(dd_value(ji),i4) ) + + ! clean + CALL dim_clean(tl_dim(:)) + + ENDDO + + END SUBROUTINE iom_rstdimg__get_file_var_1d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_file_var_2d(td_file, cd_name, dd_value) + !------------------------------------------------------------------- + !> @brief This subroutine put informations about variable 2D + !> inside file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name array of variable name + !> @param[in] dd_value array of variable record + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value + + ! local variable + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! case variable 2D (X,Y) + DO ji = td_file%i_n0d + td_file%i_n1d + 1 , & + & td_file%i_n0d + td_file%i_n1d + td_file%i_n2d + + ! define same dimension as in file + tl_dim(:)=dim_copy(td_file%t_dim(:)) + ! do not use Z dimension + tl_dim(3)%l_use=.FALSE. + tl_dim(3)%i_len=1 + + td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, & + & tl_dim(:), dd_fill=0._dp, & + & id_id=ji, id_rec=INT(dd_value(ji),i4) ) + + ! clean + CALL dim_clean(tl_dim(:)) + + ENDDO + + END SUBROUTINE iom_rstdimg__get_file_var_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_file_var_3d(td_file, cd_name, dd_value) + !------------------------------------------------------------------- + !> @brief This subroutine put informations about variable 3D + !> inside file structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_file file structure + !> @param[in] cd_name array of variable name + !> @param[in] dd_value array of variable record + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value + + ! local variable + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! case variable 3D (X,Y,Z) + DO ji = td_file%i_n0d + td_file%i_n1d + td_file%i_n2d +1 , & + & td_file%i_n0d + td_file%i_n1d + td_file%i_n2d + td_file%i_n3d + + ! define same dimension as in file + tl_dim(:)=dim_copy(td_file%t_dim(:)) + + td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, & + & tl_dim(:), dd_fill=0._dp, & + & id_id=ji, id_rec=INT(dd_value(ji),i4) ) + + ! clean + CALL dim_clean(tl_dim(:)) + + ENDDO + + END SUBROUTINE iom_rstdimg__get_file_var_3d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_rstdimg__read_dim_id(td_file, id_dimid) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened netcdf file, + !> given dimension id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_dimid dimension id + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_dimid + + ! function + TYPE(TDIM) :: tf_dim + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " READ DIM: no id associated to dimg file "//TRIM(td_file%c_name)) + + ELSE + + tf_dim%i_id=id_dimid + + CALL logger_debug( & + & " READ DIM: dimension "//TRIM(fct_str(id_dimid))//& + & " in file "//TRIM(td_file%c_name)) + + IF( id_dimid <= 4 )THEN + tf_dim=td_file%t_dim(id_dimid) + ELSE + CALL logger_error( & + & " READ DIM: no dimension with id "//TRIM(fct_str(id_dimid))//& + & " in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + + END FUNCTION iom_rstdimg__read_dim_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_rstdimg__read_dim_name(td_file, cd_name) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief This function read one dimension in an opened netcdf file, + !> given dimension name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name dimension name + !> @return dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + TYPE(TDIM) :: tf_dim + + ! local variable + INTEGER(i4) :: il_dimid + !---------------------------------------------------------------- + + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " READ DIM: no id associated to dimg file "//TRIM(td_file%c_name)) + + ELSE + + il_dimid=dim_get_id(td_file%t_dim(:), TRIM(cd_name)) + IF( il_dimid /= 0 )THEN + tf_dim=iom_rstdimg_read_dim(td_file, il_dimid) + ELSE + CALL logger_error( & + & " READ DIM: no dimension "//TRIM(cd_name)//& + & " in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + + END FUNCTION iom_rstdimg__read_dim_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_rstdimg__read_var_id(td_file, id_varid, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> dimg file, given variable id. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] id_varid variable id + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN) :: id_varid + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(1) :: il_varid + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " READ VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + ! look for variable id + il_varid(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid)) + IF( il_varid(1) /= 0 )THEN + + tf_var=var_copy(td_file%t_var(il_varid(1))) + + IF( tf_var%i_ndim /= 0 )THEN + !!! read variable value + CALL iom_rstdimg__read_var_value( td_file, tf_var, id_start, id_count) + ELSE + CALL logger_debug( " READ VAR: variable 0d "//& + & TRIM(td_file%t_var(il_varid(1))%c_name)//& + & " should be already read ") + ENDIF + + ELSE + CALL logger_error( & + & " READ VAR: there is no variable with id "//& + & TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name)) + ENDIF + + ENDIF + END FUNCTION iom_rstdimg__read_var_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION iom_rstdimg__read_var_name(td_file, cd_name, id_start, id_count) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function read variable value in an opened + !> dimg file, given variable name or standard name. + !> @details + !> Optionaly, start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> look first for variable name. If it doesn't + !> exist in file, look for variable standard name.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file file structure + !> @param[in] cd_name variable name or standard name + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_varid + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " READ VAR: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + + il_varid=var_get_index(td_file%t_var(:), cd_name) + IF( il_varid /= 0 )THEN + + tf_var=var_copy(td_file%t_var(il_varid)) + + IF( td_file%t_var(il_varid)%i_ndim /= 0 )THEN + !!! read variable value + CALL iom_rstdimg__read_var_value( td_file, tf_var, id_start, id_count) + ELSE + CALL logger_debug( " READ VAR: variable 0d "//& + & TRIM(td_file%t_var(il_varid)%c_name)//& + & " should have been already read ") + ENDIF + + ELSE + + CALL logger_error( & + & " READ VAR NAME: there is no variable with "//& + & " name or standard name "//TRIM(cd_name)//& + & " in file "//TRIM(td_file%c_name) ) + + ENDIF + + ENDIF + + END FUNCTION iom_rstdimg__read_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__read_var_value(td_file, td_var, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine read variable value in an opened dimg file, for + !> variable 1,2,3d. + !> @details + !> Optionaly,start indices and number of indices selected along each dimension + !> could be specify in a 4 dimension array (/'x','y','z','t'/) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2016 + !> - use temporary array to read value from file + !> + !> @param[in] td_file file structure + !> @param[inout] td_var variable structure + !> @param[in] id_start index in the variable from which the data values will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_tmp1, il_tmp2 + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: dl_tmp + REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check id_count and id_start optionals parameters... + IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. & + ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN + CALL logger_warn( & + & " READ VAR VALUE: id_start and id_count should be both specify") + ENDIF + + IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN + + IF( SIZE(id_start(:)) /= ip_maxdim .OR. & + & SIZE(id_count(:)) /= ip_maxdim )THEN + CALL logger_error("READ VAR: dimension of array start or count "//& + & " are invalid to read variable "//TRIM(td_var%c_name)//& + & " in file "//TRIM(td_file%c_name) ) + ENDIF + + ! dimension order assume to be ('x','y','z','t') + il_start(:)=id_start(:) + il_count(:)=id_count(:) + + ELSE + + ! dimension order assume to be ('x','y','z','t') + il_start(:)=(/1,1,1,1/) + il_count(:)=td_var%t_dim(:)%i_len + + ENDIF + + ! check dimension + IF( .NOT. ALL(il_start(:)>=(/1,1,1,1/)) )THEN + + CALL logger_error( " READ VAR VALUE: "//& + & " start indices should be greater than or equal to 1") + + ENDIF + + IF(.NOT.ALL(il_start(:)+il_count(:)-1<=(/td_var%t_dim(1)%i_len,& + & td_var%t_dim(2)%i_len,& + & td_var%t_dim(3)%i_len,& + & td_var%t_dim(4)%i_len & + & /)) )THEN + + CALL logger_error( " READ VAR VALUE: "//& + & "start + count exceed variable dimension" ) + + DO ji = 1, ip_maxdim + il_tmp1=il_start(ji)+il_count(ji)-1 + il_tmp2=td_var%t_dim(ji)%i_len + CALL logger_debug( & + & " READ VAR VALUE: start + count - 1 "//TRIM(fct_str(il_tmp1))//& + & " variable dimension"//TRIM(fct_str(il_tmp2))) + ENDDO + + ELSE + + ! Allocate space to hold variable value + ALLOCATE(dl_value( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in temporary array") + + ENDIF + + ! read values + CALL logger_trace( & + & " READ VAR VALUE: get variable "//TRIM(td_var%c_name)//& + & " in file "//TRIM(td_file%c_name)) + + IF( ALL(td_var%t_dim(1:3)%l_use) )THEN + ! 3D variable (X,Y,Z) + ALLOCATE(dl_tmp( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(4)%i_len) ) + DO ji=1,td_var%t_dim(3)%i_len + READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec +ji-1) & + & dl_tmp(:,:,:) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("READ VAR VALUE: reading 3D variable "//& + & TRIM(td_var%c_name)) + ENDIF + dl_value(:,:,ji,:)=dl_tmp(:,:,:) + ENDDO + DEALLOCATE(dl_tmp) + ELSEIF( ALL(td_var%t_dim(1:2)%l_use) )THEN + ! 2D variable (X,Y) + READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec ) & + & dl_value(:,:,:,:) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("READ VAR VALUE: reading 2D variable "//& + & TRIM(td_var%c_name)) + ENDIF + ELSEIF( td_var%t_dim(3)%l_use )THEN + ! 1D variable (Z) + READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec ) & + & dl_value(:,:,:,:) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("READ VAR VALUE: reading 1D variable "//& + & TRIM(td_var%c_name)) + ENDIF + ENDIF + + ! Allocate space to hold variable value in structure + IF( ASSOCIATED(td_var%d_value) )THEN + DEALLOCATE(td_var%d_value) + ENDIF + + ALLOCATE(td_var%d_value( il_count(1), & + & il_count(2), & + & il_count(3), & + & il_count(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " READ VAR VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + ! FillValue by default + td_var%d_value(:,:,:,:)=td_var%d_fill + + ! new dimension length + td_var%t_dim(:)%i_len=il_count(:) + + ! extract value + td_var%d_value(:,:,:,:) = dl_value(il_start(1):il_start(1)+il_count(1)-1,& + & il_start(2):il_start(2)+il_count(2)-1,& + & il_start(3):il_start(3)+il_count(3)-1,& + & il_start(4):il_start(4)+il_count(4)-1) + + DEALLOCATE(dl_value) + + ENDIF + + ! force to change _FillValue to avoid mistake + ! with dummy zero _FillValue + IF( td_var%d_fill == 0._dp )THEN + CALL var_chg_FillValue(td_var) + ENDIF + + ! use scale factor and offset + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:) = & + & td_var%d_value(:,:,:,:)*td_var%d_scf + td_var%d_ofs + END WHERE + + END SUBROUTINE iom_rstdimg__read_var_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg_write_header(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine write header of dimg file from file structure. + !> + !> @details + !> dimg file have to be already opened in write mode. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use iom_rstdimg__get_rec + !> @date August, 2017 + !> - split in write_header and write_var + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " WRITE FILE: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + IF( td_file%l_wrt )THEN + + ! check dimension + IF( td_file%t_dim(jp_L)%l_use .AND. & + & td_file%t_dim(jp_L)%i_len /= 1 )THEN + CALL logger_fatal("WRITE FILE: can not write dimg file with "//& + & " several time step.") + ENDIF + + ! close and open file with right record length + CALL iom_rstdimg_close(td_file) + + ! compute record number to be used + ! and add variable no0d, no1d,.. if need be + CALL iom_rstdimg__get_rec(td_file) + + ! compute record length + il_ind=att_get_index(td_file%t_att(:),"DOMAIN_number_total") + IF( il_ind /= 0 )THEN + td_file%i_recl = MAX( & + & td_file%t_dim(1)%i_len * td_file%t_dim(2)%i_len * 8, & + & ( 8 * INT(td_file%t_att(il_ind)%d_value(1)) + 15 ) * 4 ) + ELSE + td_file%i_recl = td_file%t_dim(1)%i_len * & + & td_file%t_dim(2)%i_len * 8 + ENDIF + ! check record length + IF( td_file%i_nvar*(im_vnl+dp) > td_file%i_recl )THEN + CALL logger_fatal("WRITE FILE: record length is too small. "//& + & " Try to reduce the output number of processor.") + ENDIF + + ! get free unit + td_file%i_id=fct_getunit() + + OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),& + & FORM='UNFORMATTED', & + & ACCESS='DIRECT', & + & STATUS='REPLACE', & + & ACTION='WRITE', & + & RECL=td_file%i_recl, & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//& + & " with record length "//TRIM(fct_str(td_file%i_recl))) + ELSE + CALL logger_debug("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//& + & " with record length "//TRIM(fct_str(td_file%i_recl))) + ENDIF + + ! write header + CALL iom_rstdimg__write_header(td_file) + + ELSE + + CALL logger_error( & + & " WRITE FILE: try to write in file "//TRIM(td_file%c_name)//& + & ", not opened in write mode") + + ENDIF + ENDIF + + END SUBROUTINE iom_rstdimg_write_header + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg_write_var(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine write variable in dimg file from file structure. + !> + !> @details + !> dimg file have to be already opened in write mode. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2014 + !> - use iom_rstdimg__get_rec + !> @date August, 2017 + !> - split in write_header and write_var + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + !---------------------------------------------------------------- + ! check if file opened + IF( td_file%i_id == 0 )THEN + + CALL logger_error( & + & " WRITE FILE: no id associated to file "//TRIM(td_file%c_name)) + + ELSE + IF( td_file%l_wrt )THEN + + ! write variable in file + CALL iom_rstdimg__write_var(td_file) + + ELSE + + CALL logger_error( & + & " WRITE FILE: try to write in file "//TRIM(td_file%c_name)//& + & ", not opened in write mode") + + ENDIF + ENDIF + + END SUBROUTINE iom_rstdimg_write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__get_rec(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine compute record number to be used. + !> + !> @details + !> Moreover it adds variable no0d, no1d, no2d and no3d if need be. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_rec + TYPE(TVAR) :: tl_var + + INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_tmp1d + INTEGER(i4), DIMENSION(:,:) , ALLOCATABLE :: il_tmp2d + INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_tmp3d + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! add dummy variable if necessary + IF( td_file%i_n0d == 0 )THEN + ! create var + tl_var=var_init('no0d') + + CALL file_add_var( td_file, tl_var ) + ENDIF + + IF( td_file%i_n1d == 0 )THEN + ! create var + ALLOCATE( il_tmp1d( td_file%t_dim(3)%i_len ) ) + il_tmp1d(:)=-1 + + tl_var=var_init( 'no1d', il_tmp1d(:)) + + DEALLOCATE( il_tmp1d ) + + CALL file_add_var( td_file, tl_var ) + ENDIF + + IF( td_file%i_n2d == 0 )THEN + ! create var + ALLOCATE( il_tmp2d( td_file%t_dim(1)%i_len, & + & td_file%t_dim(2)%i_len ) ) + il_tmp2d(:,:)=-1 + + tl_var=var_init('no2d', il_tmp2d(:,:) ) + + DEALLOCATE( il_tmp2d ) + + CALL file_add_var( td_file, tl_var ) + + ENDIF + + IF( td_file%i_n3d == 0 )THEN + ! create var + ALLOCATE( il_tmp3d( td_file%t_dim(1)%i_len, & + & td_file%t_dim(2)%i_len, & + & td_file%t_dim(3)%i_len ) ) + il_tmp3d(:,:,:)=-1 + + tl_var=var_init('no3d', il_tmp3d(:,:,:) ) + + DEALLOCATE( il_tmp3d ) + + CALL file_add_var( td_file, tl_var ) + ENDIF + + ! clean + CALL var_clean(tl_var) + + il_rec=2 + DO ji=1,td_file%i_nvar + SELECT CASE(td_file%t_var(ji)%i_ndim) + CASE(0) + IF( INDEX(td_file%t_var(ji)%c_name, 'no0d' ) == 0 )THEN + td_file%t_var(ji)%i_rec=il_rec + il_rec = il_rec + 0 + ENDIF + CASE(1) + IF( INDEX(td_file%t_var(ji)%c_name, 'no1d' ) == 0 )THEN + td_file%t_var(ji)%i_rec=il_rec + il_rec = il_rec + 1 + ENDIF + CASE(2) + IF( INDEX(td_file%t_var(ji)%c_name, 'no2d' ) == 0 )THEN + td_file%t_var(ji)%i_rec=il_rec + il_rec = il_rec + 1 + ENDIF + CASE(3) + IF( INDEX(td_file%t_var(ji)%c_name, 'no3d' ) == 0 )THEN + td_file%t_var(ji)%i_rec=il_rec + il_rec = il_rec + td_file%t_dim(3)%i_len + ENDIF + END SELECT + ENDDO + td_file%i_rhd = il_rec + + END SUBROUTINE iom_rstdimg__get_rec + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__write_header(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine write header in an opened dimg + !> file in write mode. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2016 + !> - mismatch with "halo" indices + !> + !> @param[inout] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_nproc + INTEGER(i4) :: il_niproc + INTEGER(i4) :: il_njproc + INTEGER(i4) :: il_area + INTEGER(i4) :: il_iglo + INTEGER(i4) :: il_jglo + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + ! check record length + IF( td_file%i_recl <= 8 )THEN + CALL logger_warn(" WRITE FILE: record length seems to be tiny!! & + & ("//TRIM(fct_str(td_file%i_recl))//")") + ENDIF + + ! check dimension + IF( ANY(td_file%t_dim(1:3)%i_len <= 0 ) )THEN + CALL logger_error(" WRITE FILE: at least one dimension size is less & + & than or equal to zero !! ") + DO ji=1,3 + CALL logger_debug(" WRITE FILE: dimension "//& + & TRIM(td_file%t_dim(ji)%c_name)//" : "//& + & TRIM(fct_str(td_file%t_dim(ji)%i_len)) ) + ENDDO + ENDIF + + ! get domain decomposition + il_ind=att_get_index( td_file%t_att, "DOMAIN_number_total" ) + il_nproc = 1 + IF( il_ind /= 0 )THEN + il_nproc = INT(td_file%t_att(il_ind)%d_value(1)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "DOMAIN_I_number_total" ) + il_niproc = 0 + IF( il_ind /= 0 )THEN + il_niproc = INT(td_file%t_att(il_ind)%d_value(1)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "DOMAIN_J_number_total" ) + il_njproc = 0 + IF( il_ind /= 0 )THEN + il_njproc = INT(td_file%t_att(il_ind)%d_value(1)) + ENDIF + + ! check domain decomposition + IF( il_niproc <= 0 .OR. & + & il_njproc <= 0 .OR. & + & il_nproc <= 0 .OR. & + & il_nproc > il_niproc * il_njproc )THEN + + CALL logger_error(" WRITE FILE: invalid domain splitting ") + + CALL logger_debug(" WRITE FILE: niproc "//TRIM(fct_str(il_niproc)) ) + CALL logger_debug(" WRITE FILE: njproc "//TRIM(fct_str(il_njproc)) ) + CALL logger_debug(" WRITE FILE: nproc "//TRIM(fct_str(il_nproc)) ) + + ENDIF + + ! get domain number + il_ind=att_get_index( td_file%t_att, "DOMAIN_number" ) + il_area = 0 + IF( il_ind /= 0 )THEN + il_area = INT(td_file%t_att(il_ind)%d_value(1)) + ENDIF + + ! get domain global size + il_ind=att_get_index( td_file%t_att, "DOMAIN_size_global" ) + il_iglo = 0 + il_jglo = 0 + IF( il_ind /= 0 )THEN + il_iglo = INT(td_file%t_att(il_ind)%d_value(1)) + il_jglo = INT(td_file%t_att(il_ind)%d_value(2)) + ENDIF + + ! check domain global size + IF( il_iglo < td_file%t_dim(1)%i_len .OR. & + & il_jglo < td_file%t_dim(2)%i_len )THEN + CALL logger_error(" WRITE FILE: invalid global domain ") + + CALL logger_debug(" WRITE FILE: global domain : "//& + & TRIM(fct_str(il_iglo))//" x "//& + & TRIM(fct_str(il_jglo)) ) + CALL logger_debug(" WRITE FILE: local domain : "//& + & TRIM(fct_str(td_file%t_dim(1)%i_len))//" x "//& + & TRIM(fct_str(td_file%t_dim(2)%i_len)) ) + ENDIF + + ! allocate local variable + ALLOCATE( il_impp(il_nproc), il_jmpp(il_nproc),& + & il_lci(il_nproc), il_lcj(il_nproc), & + & il_ldi(il_nproc), il_ldj(il_nproc), & + & il_lei(il_nproc), il_lej(il_nproc) ) + + ! get left bottom indices + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_left_bottom_indices" ) + il_impp(:) = 0 + IF( il_ind /= 0 )THEN + il_impp(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_left_bottom_indices" ) + il_jmpp(:) = 0 + IF( il_ind /= 0 )THEN + il_jmpp(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + ! check left bottom indices + IF( ANY(il_impp(:)==0) .OR. ANY(il_jmpp(:)==0) )THEN + CALL logger_warn("WRITE FILE: no data for subdomain left bottom indices") + ENDIF + + ! get subdomain dimensions + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_dimensions" ) + il_lci(:) = 0 + IF( il_ind /= 0 )THEN + il_lci(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_dimensions" ) + il_lcj(:) = 0 + IF( il_ind /= 0 )THEN + il_lcj(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + ! check subdomain dimension + IF( ANY(il_lci(:)==0) .OR. ANY(il_lcj(:)==0) )THEN + CALL logger_warn("WRITE FILE: no data for subdomain dimensions") + ENDIF + + ! get first indoor indices + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_first_indoor_indices" ) + il_ldi(:) = 0 + IF( il_ind /= 0 )THEN + il_ldi(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_first_indoor_indices" ) + il_ldj(:) = 0 + IF( il_ind /= 0 )THEN + il_ldj(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + ! check first indoor indices + IF( ANY(il_ldi(:)==0) .OR. ANY(il_ldj(:)==0) )THEN + CALL logger_warn("WRITE FILE: no data for subdomain first indoor indices") + ENDIF + + ! get last indoor indices + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_last_indoor_indices" ) + il_lei(:) = 0 + IF( il_ind /= 0 )THEN + il_lei(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_last_indoor_indices" ) + il_lej(:) = 0 + IF( il_ind /= 0 )THEN + il_lej(:) = INT(td_file%t_att(il_ind)%d_value(:)) + ENDIF + + ! check last indoor indices + IF( ANY(il_lei(:)==0) .OR. ANY(il_lej(:)==0) )THEN + CALL logger_warn("WRITE FILE: no data for subdomain last indoor indices") + ENDIF + + ! write file header + WRITE(td_file%i_id, IOSTAT=il_status, REC=1 )& + & td_file%i_recl, & + & td_file%t_dim(1)%i_len, & + & td_file%t_dim(2)%i_len, & + & td_file%t_dim(3)%i_len, & + & td_file%i_n0d, & + & td_file%i_n1d, & + & td_file%i_n2d, & + & td_file%i_n3d, & + & td_file%i_rhd, & + & il_niproc, il_njproc, il_nproc, & + & il_area, & + & il_iglo, il_jglo, & + & il_lci(:), il_lcj(:), & + & il_ldi(:), il_ldj(:), & + & il_lei(:), il_lej(:), & + & il_impp(:), il_jmpp(:) + + DEALLOCATE( il_impp, il_jmpp,& + & il_lci, il_lcj, & + & il_ldi, il_ldj, & + & il_lei, il_lej ) + + END SUBROUTINE iom_rstdimg__write_header + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE iom_rstdimg__write_var(td_file) + !------------------------------------------------------------------- + !> @brief This subroutine write variables in an opened dimg file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - bug fix: do not use scale factor an offset for case no0d, no1d... + !> + !> @param[in] td_file file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(INOUT) :: td_file + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_rec + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_start + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_count + CHARACTER(LEN=im_vnl), DIMENSION(:), ALLOCATABLE :: cl_name + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! reform name and record + ALLOCATE( cl_name(td_file%i_nvar), dl_value(td_file%i_nvar) ) + + DO ji=1,td_file%i_nvar + + ! change FillValue to 0. + CALL var_chg_FillValue(td_file%t_var(ji),0._dp) + + cl_name(ji) = TRIM(td_file%t_var(ji)%c_name) + dl_value(ji) = REAL(td_file%t_var(ji)%i_rec,dp) + + SELECT CASE (TRIM(td_file%t_var(ji)%c_name)) + CASE('no0d','no1d','no2d','no3d') + CASE DEFAULT + + ! use scale factor and offset + WHERE( td_file%t_var(ji)%d_value(:,:,:,:) /= & + & td_file%t_var(ji)%d_fill ) + td_file%t_var(ji)%d_value(:,:,:,:) = & + & ( td_file%t_var(ji)%d_value(:,:,:,:) - & + & td_file%t_var(ji)%d_ofs ) / & + & td_file%t_var(ji)%d_scf + END WHERE + + DO jk=1,td_file%t_var(ji)%t_dim(3)%i_len + SELECT CASE (td_file%t_var(ji)%i_ndim) + CASE(0) + ! special case for 0d, value save in rec + dl_value(ji)=td_file%t_var(ji)%d_value(1,1,1,1) + il_rec = td_file%t_var(ji)%i_rec + CASE(1,2) + il_rec = td_file%t_var(ji)%i_rec + CASE(3) + il_rec = td_file%t_var(ji)%i_rec + jk -1 + END SELECT + WRITE( td_file%i_id, IOSTAT=il_status, REC=il_rec ) & + & td_file%t_var(ji)%d_value(:,:,jk,1) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//& + & "write variable "//TRIM(td_file%t_var(ji)%c_name)//& + & " in record "//TRIM(fct_str(il_rec))) + ENDIF + ENDDO + END SELECT + + ENDDO + + ALLOCATE( il_start(4), il_count(4) ) + + il_start(1) = 1 + il_count(1) = td_file%i_n0d + + il_start(2) = 1 + il_count(1) + il_count(2) = il_start(2) - 1 + td_file%i_n1d + + il_start(3) = 1 + il_count(2) + il_count(3) = il_start(3) - 1 + td_file%i_n2d + + il_start(4) = 1 + il_count(3) + il_count(4) = il_start(4) - 1 + td_file%i_n3d + + WRITE(td_file%i_id, IOSTAT=il_status, REC=td_file%i_rhd )& + & cl_name(il_start(1):il_count(1)), dl_value(il_start(1):il_count(1)),& + & cl_name(il_start(2):il_count(2)), dl_value(il_start(2):il_count(2)),& + & cl_name(il_start(3):il_count(3)), dl_value(il_start(3):il_count(3)),& + & cl_name(il_start(4):il_count(4)), dl_value(il_start(4):il_count(4)) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//& + & "write restart header in record "//TRIM(fct_str(td_file%i_rhd))) + ENDIF + + ! clean + DEALLOCATE( cl_name, dl_value ) + DEALLOCATE( il_start, il_count ) + + END SUBROUTINE iom_rstdimg__write_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE iom_rstdimg diff --git a/V4.0/nemo_sources/tools/SIREN/src/kind.f90 b/V4.0/nemo_sources/tools/SIREN/src/kind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5ab49cd812b9cc1809c64c5a4852b40cd7a2e42f --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/kind.f90 @@ -0,0 +1,45 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> This module defines the F90 kind parameter for common data types. +!> +!> +!> @author +!> G. Madec +! REVISION HISTORY: +!> @date June, 2006 - Initial Version +!> @date December, 2012 - G. Madec +!> - add a standard length of character strings +!> +!> @todo +!> - check i8 max value +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE kind + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! !!** Floating point ** + ! SELECTED_REAL_KIND(P,R) returns the kind value of a real data type + ! with decimal precision of at least P digits, exponent range of at least R + 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 ** + ! SELECTED_INT_KIND(R) return the kind value of the smallest integer type + ! that can represent all values ranging ] -10^R , 10^R [ + INTEGER, PUBLIC, PARAMETER :: i1 = SELECTED_INT_KIND( 1) !< single precision (integer 1) + INTEGER, PUBLIC, PARAMETER :: i2 = SELECTED_INT_KIND( 4) !< single precision (integer 2) + 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 !< Length of Character strings + +END MODULE kind + diff --git a/V4.0/nemo_sources/tools/SIREN/src/lbc.f90 b/V4.0/nemo_sources/tools/SIREN/src/lbc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..14ed6f9590573f8fc230268c16358ea8f407d23c --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/lbc.f90 @@ -0,0 +1,825 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module groups lateral boundary conditions subroutine. +!> +!> @details +!> +!> @warning keep only non mpp case +!> +!> @author +!> G. Madec +!> +!> @date June, 1997 - Original code +!> @date September, 2002 +!> - F90: Free form and module +!> @date Marsh, 2009 +!> - R. Benshila : External north fold treatment +!> @date December, 2012 +!> - S.Mocavero, I. Epicoco : Add 'lbc_bdy_lnk' and lbc_obc_lnk' routine to optimize the BDY/OBC communications +!> @date December, 2012 +!> - R. Bourdalle-Badie and G. Reffray : add a C1D case +!> @date January, 2015 +!> - J.Paul : rewrite with SIREN coding rules +!> @date Marsh, 2015 +!> - J.Paul : add hide subroutine +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE lbc + + USE kind ! F90 kind parameter + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: lbc_lnk + PUBLIC :: lbc_nfd + PUBLIC :: lbc_hide + + PRIVATE :: lbc__lnk_3d + PRIVATE :: lbc__lnk_2d + PRIVATE :: lbc__nfd_3d + PRIVATE :: lbc__nfd_2d + PRIVATE :: lbc__hide_lnk_2d + PRIVATE :: lbc__hide_nfd + PRIVATE :: lbc__hide_nfd_2d + + INTERFACE lbc_lnk + MODULE PROCEDURE lbc__lnk_3d + MODULE PROCEDURE lbc__lnk_2d + END INTERFACE + + INTERFACE lbc_nfd + MODULE PROCEDURE lbc__nfd_3d + MODULE PROCEDURE lbc__nfd_2d + END INTERFACE + + INTERFACE lbc_hide + MODULE PROCEDURE lbc__hide_lnk_2d + END INTERFACE + + INTERFACE lbc__hide_nfd + MODULE PROCEDURE lbc__hide_nfd_2d + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__lnk_3d(dd_array, cd_type, id_perio, dd_psgn, dd_fill) + !------------------------------------------------------------------- + !> @brief This subroutine set lateral boundary conditions on a 3D array (non mpp case) + !> + !> @details + !> dd_psign = -1 : change the sign across the north fold + !> = 1 : no change of the sign across the north fold + !> = 0 : no change of the sign across the north fold and + !> strict positivity preserved: use inner row/column + !> for closed boundaries. + !> @author J.Paul + !> - January, 2015- rewrite with SIREN coding rules + !> + !> @param[inout] dd_array 3D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !> @param[in] dd_fill fillValue + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp), INTENT(IN ) :: dd_psgn + REAL(dp), INTENT(IN ), OPTIONAL :: dd_fill + + ! local variable + REAL(dp) :: dl_fill + + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpim1 + !---------------------------------------------------------------- + IF( PRESENT( dd_fill ) ) THEN ; dl_fill = dd_fill ! set FillValue (zero by default) + ELSE ; dl_fill = 0._dp + ENDIF + + il_jpi=SIZE(dd_array(:,:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:,:),DIM=2) + + il_jpim1=il_jpi-1 + ! + ! ! East-West boundaries + ! ! ==================== + SELECT CASE ( id_perio ) + ! + CASE ( 1 , 4 , 6 ) !** cyclic east-west + dd_array( 1 ,:,:) = dd_array(il_jpim1,:,:) ! all points + dd_array(il_jpi,:,:) = dd_array( 2 ,:,:) + ! + CASE DEFAULT !** East closed -- West closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array( 1 ,:,:) = dl_fill + dd_array(il_jpi,:,:) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(il_jpi,:,:) = dl_fill + END SELECT + ! + END SELECT + ! + ! ! North-South boundaries + ! ! ====================== + SELECT CASE ( id_perio ) + ! + CASE ( 2 ) !** South symmetric -- North closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points + dd_array(:, 1 ,:) = dd_array(:,3,:) + dd_array(:,il_jpj,:) = dl_fill + CASE ( 'V' , 'F' ) ! V-, F-points + dd_array(:, 1 ,:) = dd_psgn * dd_array(:,2,:) + dd_array(:,il_jpj,:) = dl_fill + END SELECT + ! + CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed + SELECT CASE ( TRIM(cd_type) ) ! South : closed + CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point + dd_array(:, 1 ,:) = dl_fill + END SELECT + ! ! North fold + CALL lbc_nfd( dd_array(:,:,:), cd_type, id_perio, dd_psgn ) + ! + CASE DEFAULT !** North closed -- South closed + SELECT CASE ( cd_type ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ,:) = dl_fill + dd_array(:,il_jpj,:) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj,:) = dl_fill + END SELECT + ! + END SELECT + + END SUBROUTINE lbc__lnk_3d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__lnk_2d(dd_array, cd_type, id_perio, dd_psgn, dd_fill) + !------------------------------------------------------------------- + !> @brief This subroutine set lateral boundary conditions on a 2D array (non mpp case) + !> + !> @details + !> dd_psign = -1 : change the sign across the north fold + !> = 1 : no change of the sign across the north fold + !> = 0 : no change of the sign across the north fold and + !> strict positivity preserved: use inner row/column + !> for closed boundaries. + !> @author J.Paul + !> - January, 2015- rewrite with SIREN coding rules + !> + !> @param[inout] dd_array 2D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !> @param[in] dd_fill fillValue + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp) , INTENT(IN ) :: dd_psgn + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill + + ! local variable + REAL(dp) :: dl_fill + + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpim1 + !---------------------------------------------------------------- + IF( PRESENT( dd_fill ) ) THEN ; dl_fill = dd_fill ! set FillValue (zero by default) + ELSE ; dl_fill = 0._dp + ENDIF + + il_jpi=SIZE(dd_array(:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:),DIM=2) + + il_jpim1=il_jpi-1 + + ! + ! ! East-West boundaries + ! ! ==================== + SELECT CASE ( id_perio ) + ! + CASE ( 1 , 4 , 6 ) !** cyclic east-west + dd_array( 1 ,:) = dd_array(il_jpim1,:) ! all points + dd_array(il_jpi,:) = dd_array( 2 ,:) + ! + CASE DEFAULT !** East closed -- West closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array( 1 ,:) = dl_fill + dd_array(il_jpi,:) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(il_jpi,:) = dl_fill + END SELECT + ! + END SELECT + ! + ! ! North-South boundaries + ! ! ====================== + SELECT CASE ( id_perio ) + ! + CASE ( 2 ) !** South symmetric -- North closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points + dd_array(:, 1 ) = dd_array(:,3) + dd_array(:,il_jpj) = dl_fill + CASE ( 'V' , 'F' ) ! V-, F-points + dd_array(:, 1 ) = dd_psgn * dd_array(:,2) + dd_array(:,il_jpj) = dl_fill + END SELECT + ! + CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed + SELECT CASE ( TRIM(cd_type) ) ! South : closed + CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point + dd_array(:, 1 ) = dl_fill + END SELECT + ! ! North fold + CALL lbc_nfd( dd_array(:,:), cd_type, id_perio, dd_psgn ) + ! + CASE DEFAULT !** North closed -- South closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ) = dl_fill + dd_array(:,il_jpj) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj) = dl_fill + END SELECT + ! + END SELECT + + END SUBROUTINE lbc__lnk_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__nfd_3d(dd_array, cd_type, id_perio, dd_psgn) + !------------------------------------------------------------------- + !> @brief This subroutine manage 3D lateral boundary condition : + !> North fold treatment without processor exchanges. + !> + !> @warning keep only non mpp case + !> + !> @author J.Paul + !> - January, 2015- rewrite with SIREN coding rules + !> + !> @param[inout] dd_array 3D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp) , INTENT(IN ) :: dd_psgn + + ! local variable + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpk + INTEGER(i4) :: il_jpim1 + INTEGER(i4) :: il_jpjm1 + + INTEGER(i4) :: ijt + INTEGER(i4) :: iju + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_jpi=SIZE(dd_array(:,:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:,:),DIM=2) + il_jpk=SIZE(dd_array(:,:,:),DIM=3) + + il_jpim1=il_jpi-1 + il_jpjm1=il_jpj-1 + + DO jk = 1, il_jpk + ! + SELECT CASE ( id_perio ) + ! + CASE ( 3 , 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 2, il_jpi + ijt = il_jpi-ji+2 + dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk) + END DO + dd_array(1,il_jpj,jk) = dd_psgn * dd_array(3,il_jpj-2,jk) + DO ji = il_jpi/2+1, il_jpi + ijt = il_jpi-ji+2 + dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(ijt,il_jpjm1,jk) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk) + END DO + dd_array( 1 ,il_jpj,jk) = dd_psgn * dd_array( 2 ,il_jpj-2,jk) + dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(il_jpi-1,il_jpj-2,jk) + DO ji = il_jpi/2, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(iju,il_jpjm1,jk) + END DO + CASE ( 'V' ) ! V-point + DO ji = 2, il_jpi + ijt = il_jpi-ji+2 + dd_array(ji,il_jpj-1,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk) + dd_array(ji,il_jpj ,jk) = dd_psgn * dd_array(ijt,il_jpj-3,jk) + END DO + dd_array(1,il_jpj,jk) = dd_psgn * dd_array(3,il_jpj-3,jk) + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpj-1,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk) + dd_array(ji,il_jpj ,jk) = dd_psgn * dd_array(iju,il_jpj-3,jk) + END DO + dd_array( 1 ,il_jpj,jk) = dd_psgn * dd_array( 2 ,il_jpj-3,jk) + dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(il_jpi-1,il_jpj-3,jk) + END SELECT + ! + CASE ( 5 , 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-1,jk) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(iju,il_jpj-1,jk) + END DO + dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(1,il_jpj-1,jk) + CASE ( 'V' ) ! V-point + DO ji = 1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk) + END DO + DO ji = il_jpi/2+1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(ijt,il_jpjm1,jk) + END DO + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpj ,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk) + END DO + dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(1,il_jpj-2,jk) + DO ji = il_jpi/2+1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(iju,il_jpjm1,jk) + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( TRIM(cd_type)) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ,jk) = 0.e0 + dd_array(:,il_jpj,jk) = 0.e0 + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj,jk) = 0.e0 + END SELECT + ! + END SELECT ! id_perio + ! + END DO + + END SUBROUTINE lbc__nfd_3d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__nfd_2d(dd_array, cd_type, id_perio, dd_psgn) + !------------------------------------------------------------------- + !> @brief This subroutine manage 2D lateral boundary condition : + !> North fold treatment without processor exchanges. + !> + !> @warning keep only non mpp case + !> @warning do not use additional halos + !> + !> @author J.Paul + !> - January, 2015- rewrite with SIREN coding rules + !> + !> @param[inout] dd_array 2D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp) , INTENT(IN ) :: dd_psgn + + ! local variable + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpim1 + INTEGER(i4) :: il_jpjm1 + + INTEGER(i4) :: ijt + INTEGER(i4) :: iju + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + il_jpi=SIZE(dd_array(:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:),DIM=2) + + il_jpim1=il_jpi-1 + il_jpjm1=il_jpj-1 + + SELECT CASE ( id_perio ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + ! + CASE ( 'T' , 'W' ) ! T- , W-points + DO ji = 2, il_jpi + ijt=il_jpi-ji+2 + dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-2) + END DO + dd_array(1,il_jpj) = dd_psgn * dd_array(3,il_jpj-2) + dd_array(1,il_jpj-1) = dd_psgn * dd_array(3,il_jpj-1) + DO ji = il_jpi/2+1, il_jpi + ijt=il_jpi-ji+2 + dd_array(ji,il_jpj-1) = dd_psgn * dd_array(ijt,il_jpj-1) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-2) + END DO + dd_array( 1 ,il_jpj ) = dd_psgn * dd_array( 2 ,il_jpj-2) + dd_array(il_jpi,il_jpj ) = dd_psgn * dd_array(il_jpi-1,il_jpj-2) + dd_array(1 ,il_jpj-1) = dd_psgn * dd_array(il_jpi ,il_jpj-1) + DO ji = il_jpi/2, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpjm1) = dd_psgn * dd_array(iju,il_jpjm1) + END DO + CASE ( 'V' ) ! V-point + DO ji = 2, il_jpi + ijt = il_jpi-ji+2 + dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-3) + END DO + dd_array( 1 ,il_jpj) = dd_psgn * dd_array( 3 ,il_jpj-3) + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji+1 + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-3) + END DO + dd_array( 1 ,il_jpj) = dd_psgn * dd_array( 2 ,il_jpj-3) + dd_array(il_jpi,il_jpj) = dd_psgn * dd_array(il_jpi-1,il_jpj-3) + dd_array(il_jpi,il_jpj-1) = dd_psgn * dd_array(il_jpi-1,il_jpj-2) + dd_array( 1 ,il_jpj-1) = dd_psgn * dd_array( 2 ,il_jpj-2) + CASE ( 'I' ) ! ice U-V point (I-point) + dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1) + DO ji = 3, il_jpi + iju = il_jpi - ji + 3 + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1) + END DO + CASE ( 'J' ) ! first ice U-V point + dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1) + DO ji = 3, il_jpi + iju = il_jpi - ji + 3 + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1) + END DO + CASE ( 'K' ) ! second ice U-V point + dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1) + DO ji = 3, il_jpi + iju = il_jpi - ji + 3 + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1) + END DO + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-1) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1) + END DO + dd_array(il_jpi,il_jpj) = dd_psgn * dd_array(1,il_jpj-1) + CASE ( 'V' ) ! V-point + DO ji = 1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-2) + END DO + DO ji = il_jpi/2+1, il_jpi + ijt = il_jpi-ji+1 + dd_array(ji,il_jpjm1) = dd_psgn * dd_array(ijt,il_jpjm1) + END DO + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-2) + END DO + dd_array(il_jpi,il_jpj) = dd_psgn * dd_array(1,il_jpj-2) + DO ji = il_jpi/2+1, il_jpi-1 + iju = il_jpi-ji + dd_array(ji,il_jpjm1) = dd_psgn * dd_array(iju,il_jpjm1) + END DO + CASE ( 'I' ) ! ice U-V point (I-point) + dd_array( 2 ,il_jpj) = 0.e0 + DO ji = 2 , il_jpi-1 + ijt = il_jpi - ji + 2 + dd_array(ji,il_jpj)= 0.5 * ( dd_array(ji,il_jpj-1) + dd_psgn * dd_array(ijt,il_jpj-1) ) + END DO + CASE ( 'J' ) ! first ice U-V point + dd_array( 2 ,il_jpj) = 0.e0 + DO ji = 2 , il_jpi-1 + ijt = il_jpi - ji + 2 + dd_array(ji,il_jpj)= dd_array(ji,il_jpj-1) + END DO + CASE ( 'K' ) ! second ice U-V point + dd_array( 2 ,il_jpj) = 0.e0 + DO ji = 2 , il_jpi-1 + ijt = il_jpi - ji + 2 + dd_array(ji,il_jpj)= dd_array(ijt,il_jpj-1) + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ) = 0.e0 + dd_array(:,il_jpj) = 0.e0 + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj) = 0.e0 + CASE ( 'I' ) ! ice U-V point + dd_array(:, 1 ) = 0.e0 + dd_array(:,il_jpj) = 0.e0 + CASE ( 'J' ) ! first ice U-V point + dd_array(:, 1 ) = 0.e0 + dd_array(:,il_jpj) = 0.e0 + CASE ( 'K' ) ! second ice U-V point + dd_array(:, 1 ) = 0.e0 + dd_array(:,il_jpj) = 0.e0 + END SELECT + ! + END SELECT + + END SUBROUTINE lbc__nfd_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__hide_lnk_2d(dd_array, cd_type, id_perio, dd_psgn, dd_fill) + !------------------------------------------------------------------- + !> @brief This subroutine hide lateral boundary conditions on a 2D array (non mpp case) + !> + !> @details + !> dd_psign = -1 : change the sign across the north fold + !> = 1 : no change of the sign across the north fold + !> = 0 : no change of the sign across the north fold and + !> strict positivity preserved: use inner row/column + !> for closed boundaries. + !> @author J.Paul + !> - Marsh, 2015- initial version + !> + !> @param[inout] dd_array 2D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !> @param[in] dd_fill fillValue + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp) , INTENT(IN ) :: dd_psgn + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill + + ! local variable + REAL(dp) :: dl_fill + + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpim1 + !---------------------------------------------------------------- + IF( PRESENT( dd_fill ) ) THEN ; dl_fill = dd_fill ! set FillValue (zero by default) + ELSE ; dl_fill = 0._dp + ENDIF + + il_jpi=SIZE(dd_array(:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:),DIM=2) + + il_jpim1=il_jpi-1 + + ! + ! ! East-West boundaries + ! ! ==================== + SELECT CASE ( id_perio ) + ! + CASE ( 1 , 4 , 6 ) !** cyclic east-west + dd_array( 1 ,:) = dl_fill ! all points + dd_array(il_jpi,:) = dl_fill + ! + CASE DEFAULT !** East closed -- West closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array( 1 ,:) = dl_fill + dd_array(il_jpi,:) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(il_jpi,:) = dl_fill + END SELECT + ! + END SELECT + ! + ! ! North-South boundaries + ! ! ====================== + SELECT CASE ( id_perio ) + ! + CASE ( 2 ) !** South symmetric -- North closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points + dd_array(:, 1 ) = dl_fill + dd_array(:,il_jpj) = dl_fill + CASE ( 'V' , 'F' ) ! V-, F-points + dd_array(:, 1 ) = dl_fill + dd_array(:,il_jpj) = dl_fill + END SELECT + ! + CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed + SELECT CASE ( TRIM(cd_type) ) ! South : closed + CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point + dd_array(:, 1 ) = dl_fill + END SELECT + ! ! North fold + CALL lbc__hide_nfd( dd_array(:,:), cd_type, id_perio, dd_psgn, & + & dd_fill=dl_fill ) + ! + CASE DEFAULT !** North closed -- South closed + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ) = dl_fill + dd_array(:,il_jpj) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj) = dl_fill + END SELECT + ! + END SELECT + + END SUBROUTINE lbc__hide_lnk_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE lbc__hide_nfd_2d(dd_array, cd_type, id_perio, dd_psgn, dd_fill) + !------------------------------------------------------------------- + !> @brief This subroutine manage 2D lateral boundary condition : + !> hide North fold treatment without processor exchanges. + !> + !> @warning keep only non mpp case + !> @warning do not use additional halos + !> + !> @author J.Paul + !> - Marsh, 2015- initial version + !> + !> @param[inout] dd_array 2D array + !> @param[in] cd_type point grid + !> @param[in] id_perio NEMO periodicity of the grid + !> @param[in] dd_psgn + !> @param[in] dd_fill + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array + CHARACTER(LEN=*) , INTENT(IN ) :: cd_type + INTEGER(i4) , INTENT(IN ) :: id_perio + REAL(dp) , INTENT(IN ) :: dd_psgn + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill + + ! local variable + REAL(dp) :: dl_fill + + INTEGER(i4) :: il_jpi + INTEGER(i4) :: il_jpj + INTEGER(i4) :: il_jpim1 + INTEGER(i4) :: il_jpjm1 + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + IF( PRESENT( dd_fill ) ) THEN ; dl_fill = dd_fill ! set FillValue (zero by default) + ELSE ; dl_fill = 0._dp + ENDIF + + il_jpi=SIZE(dd_array(:,:),DIM=1) + il_jpj=SIZE(dd_array(:,:),DIM=2) + + il_jpim1=il_jpi-1 + il_jpjm1=il_jpj-1 + + SELECT CASE ( id_perio ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + ! + CASE ( 'T' , 'W' ) ! T- , W-points + DO ji = 2, il_jpi + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array(1,il_jpj) = dl_fill + DO ji = il_jpi/2+2, il_jpi + dd_array(ji,il_jpj-1) = dl_fill + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array( 1 ,il_jpj ) = dl_fill + dd_array(il_jpi,il_jpj ) = dl_fill + dd_array(1 ,il_jpj-1) = dl_fill + DO ji = il_jpi/2+1, il_jpi-1 + dd_array(ji,il_jpjm1) = dl_fill + END DO + CASE ( 'V' ) ! V-point + DO ji = 2, il_jpi + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array( 1 ,il_jpj) = dl_fill + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array( 1 ,il_jpj) = dl_fill + dd_array(il_jpi,il_jpj) = dl_fill + dd_array(il_jpi,il_jpj-1) = dl_fill + dd_array( 1 ,il_jpj-1) = dl_fill + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, il_jpi + dd_array(ji,il_jpj) = dl_fill + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, il_jpi-1 + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array(il_jpi,il_jpj) = dl_fill + CASE ( 'V' ) ! V-point + DO ji = 1, il_jpi + dd_array(ji,il_jpj) = dl_fill + END DO + DO ji = il_jpi/2+2, il_jpi + dd_array(ji,il_jpjm1) = dl_fill + END DO + CASE ( 'F' ) ! F-point + DO ji = 1, il_jpi-1 + dd_array(ji,il_jpj) = dl_fill + END DO + dd_array(il_jpi,il_jpj) = dl_fill + DO ji = il_jpi/2+2, il_jpi-1 + dd_array(ji,il_jpjm1) = dl_fill + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( TRIM(cd_type) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + dd_array(:, 1 ) = dl_fill + dd_array(:,il_jpj) = dl_fill + CASE ( 'F' ) ! F-point + dd_array(:,il_jpj) = dl_fill + END SELECT + ! + END SELECT + + END SUBROUTINE lbc__hide_nfd_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE lbc diff --git a/V4.0/nemo_sources/tools/SIREN/src/logger.f90 b/V4.0/nemo_sources/tools/SIREN/src/logger.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1a33a28484cab8ffe22c6b8be40db3e094a1ef55 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/logger.f90 @@ -0,0 +1,789 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module manage log file. +!> @details +!> This module create log file and fill it depending of verbosity. +!> +!> verbosity could be choosen between : +!> - trace : Most detailed information. +!> - debug : Detailed information on the flow through the system. +!> - info : Interesting runtime events (startup/shutdown). +!> - warning: Use of deprecated APIs, poor use of API, 'almost' errors, +!> other runtime situations that are undesirable or unexpected, +!> but not necessarily "wrong". +!> - error : Other runtime errors or unexpected conditions. +!> - fatal : Severe errors that cause premature termination. +!> - none : to not create and write any information in logger file.<br /> +!> @warn in this case only FATAL ERROR will be detected.<br /> +!> +!> @note default verbosity is warning +!> +!> If total number of error exceeded maximum number +!> authorized, program stop. +!> +!> to open/create logger file:<br/> +!> @code +!> CALL logger_open(cd_file, [cd_verbosity,] [id_maxerror,] [id_loggerid]) +!> @endcode +!> - cd_file is logger file name +!> - cd_verbosity is verbosity to be used [optional, default 'warning'] +!> - id_loggerid is file id [optional, use only to flush] +!> - id_maxerror is the maximum number of error authorized before program stop [optional, default 5] +!> +!> to close logger file:<br/> +!> @code +!> CALL logger_close() +!> @endcode +!> +!> to clean logger file:<br/> +!> @code +!> CALL logger_clean() +!> @endcode +!> +!> to write header in logger file:<br/> +!> @code +!> CALL logger_header() +!> @endcode +!> +!> to write footer in logger file:<br/> +!> @code +!> CALL logger_footer() +!> @endcode +!> +!> to flushing output:<br/> +!> @code +!> CALL logger_flush() +!> @endcode +!> +!> to write TRACE message in logger file:<br/> +!> @code +!> CALL logger_trace(cd_msg [,ld_flush]) +!> @endcode +!> - cd_msg is TRACE message +!> - ld_flush to flush output [optional] +!> +!> to write DEBUG message in logger file:<br/> +!> @code +!> CALL logger_debug(cd_msg [,ld_flush]) +!> @endcode +!> - cd_msg is DEBUG message +!> - ld_flush to flush output [optional] +!> +!> to write INFO message in logger file:<br/> +!> @code +!> CALL logger_info(cd_msg [,ld_flush]) +!> @endcode +!> - cd_msg is INFO message +!> - ld_flush to flush output [optional] +!> +!> to write WARNING message in logger file:<br/> +!> @code +!> CALL logger_warn(cd_msg [,ld_flush]) +!> @endcode +!> - cd_msg is WARNING message +!> - ld_flush to flush output [optional] +!> +!> to write ERROR message in logger file:<br/> +!> @code +!> CALL logger_error(cd_msg [,ld_flush]) +!> @endcode +!> - cd_msg is ERROR message +!> - ld_flush to flush output [optional] +!> +!> to write FATAL message in logger file:<br/> +!> @code +!> CALL logger_fatal(cd_msg) +!> @endcode +!> - cd_msg is FATAL message +!> +!> Examples :<br /> +!> @code +!> CALL logger_open('loggerfile.txt','info') +!> +!> CALL logger_header() +!> CALL logger_debug('une info de debug') +!> CALL logger_info('une info') +!> CALL logger_warn('un warning') +!> CALL logger_error('une erreur') +!> CALL logger_footer() +!> CALL logger_close() +!> CALL logger_clean() +!> @endcode +!> +!> @code +!> CALL logger_open('loggerfile.txt') +!> +!> CALL logger_header() +!> CALL logger_debug('une info de debug') +!> CALL logger_info('une info') +!> CALL logger_warn('un warning') +!> CALL logger_error('une erreur') +!> CALL logger_footer() +!> CALL logger_close() +!> CALL logger_clean() +!> @endcode +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date February, 2015 +!> - check verbosity validity +!> - add 'none' verbosity level to not used logger file +!> @date January, 2016 +!> - add logger_clean subroutine +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE logger + + USE kind ! F90 kind parameter + USE fct ! basic useful function + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PRIVATE :: TLOGGER !< logger structure + + PRIVATE :: tm_logger !< logger structure + PRIVATE :: im_nverbosity !< number of log level + PRIVATE :: cm_verbosity !< verbosity array + + ! function and subroutine + PUBLIC :: logger_open !< create a log file with given verbosity + PUBLIC :: logger_close !< close log file + PUBLIC :: logger_clean !< clean log structure + PUBLIC :: logger_header !< write header on log file + PUBLIC :: logger_footer !< write footer on log file + PUBLIC :: logger_flush !< flushing output + PUBLIC :: logger_trace !< write trace message in log file + PUBLIC :: logger_debug !< write debug message in log file + PUBLIC :: logger_info !< write info message in log file + PUBLIC :: logger_warn !< write warning message in log file + PUBLIC :: logger_error !< write error message in log file + PUBLIC :: logger_fatal !< write fatal message in log file, and stop + + PRIVATE :: logger__write ! cut message to get maximum of 80 character by line in log file + PRIVATE :: logger__check_verb! check verbosity validity + + TYPE TLOGGER !< logger structure + INTEGER(i4) :: i_id = 0 !< log file id + LOGICAL :: l_use=.TRUE. !< use logger or not + CHARACTER(LEN=lc) :: c_name !< log file name + CHARACTER(LEN=lc) :: c_verbosity = "warning" !< verbosity choose + CHARACTER(LEN=lc) :: c_verb = "" !< array of "verbosities" to used + INTEGER(i4) :: i_nerror = 0 !< number of error + INTEGER(i4) :: i_nfatal = 0 !< number of fatal error + INTEGER(i4) :: i_maxerror = 5 !< maximum number of error before stoping program + END TYPE TLOGGER + + ! module variable + INTEGER(i4), PARAMETER :: im_nverbosity=7 !< number of log level + CHARACTER(len=*), DIMENSION(im_nverbosity), PARAMETER :: cm_verbosity= & !< verbosity array + & (/ 'trace ',& + & 'debug ',& + & 'info ',& + & 'warning ',& + & 'error ',& + & 'fatal ',& + & 'none '/) + + TYPE(TLOGGER), SAVE :: tm_logger !< logger structure + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_open(cd_file, cd_verbosity, id_maxerror, id_logid) + !------------------------------------------------------------------- + !> @brief This subroutine create a log file with default verbosity + !> ('warning'). + !> @details + !> Optionally verbosity could be change to + !> ('trace','debug','info',warning','error','fatal').<br/> + !> Optionally maximum number of error allowed could be change. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_file log file name + !> @param[in] cd_verbosity log file verbosity + !> @param[in] id_maxerror maximum number of error + !> @param[in] id_logid log file id (use to flush) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(len=*), INTENT(IN) :: cd_file ! log file name + CHARACTER(len=*), INTENT(IN), OPTIONAL :: cd_verbosity ! log file verbosity + INTEGER(i4), INTENT(IN), OPTIONAL :: id_maxerror ! log max error + INTEGER(i4), INTENT(IN), OPTIONAL :: id_logid ! log file id + + ! local variable + INTEGER(i4) :: il_status + + LOGICAL :: ll_valid + + ! loop + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! if present, change verbosity value + IF( PRESENT(cd_verbosity) )THEN + ll_valid=logger__check_verb(TRIM(ADJUSTL(cd_verbosity))) + IF( ll_valid )THEN + tm_logger%c_verbosity=TRIM(ADJUSTL(cd_verbosity)) + ENDIF + ENDIF + + IF( TRIM(tm_logger%c_verbosity) == 'none' ) tm_logger%l_use=.FALSE. + + IF( tm_logger%l_use )THEN + + ! get id if not already define + IF( PRESENT(id_logid) )THEN + tm_logger%i_id=id_logid + ELSE + tm_logger%i_id=fct_getunit() + ENDIF + + ! open log file + OPEN( tm_logger%i_id, & + & STATUS="unknown", & + & FILE=TRIM(ADJUSTL(cd_file)), & + & ACTION="write", & + & POSITION="append", & + & IOSTAT=il_status) + CALL fct_err(il_status) + + ! keep filename + tm_logger%c_name=TRIM(ADJUSTL(cd_file)) + + ! compute "tab" of verbosity to be used + IF( TRIM(ADJUSTL(tm_logger%c_verb)) == "" )THEN + DO ji=im_nverbosity,1,-1 + tm_logger%c_verb = & + & TRIM(tm_logger%c_verb)//" "//TRIM(ADJUSTL(cm_verbosity(ji))) + IF( TRIM(tm_logger%c_verbosity) == TRIM(cm_verbosity(ji)) )THEN + EXIT + ENDIF + ENDDO + ENDIF + + IF( PRESENT(id_maxerror) )THEN + tm_logger%i_maxerror=id_maxerror + ENDIF + + ENDIF + + END SUBROUTINE logger_open + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_close() + !------------------------------------------------------------------- + !> @brief This subroutine close a log file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + !tm_logger%i_id = 0 + CLOSE( tm_logger%i_id, & + & IOSTAT=il_status) + CALL fct_err(il_status) + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_close') + ENDIF + ENDIF + + END SUBROUTINE logger_close + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_clean() + !------------------------------------------------------------------- + !> @brief This subroutine clean a log structure. + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! local variable + TYPE(TLOGGER) :: tl_logger + !---------------------------------------------------------------- + + tm_logger = tl_logger + + END SUBROUTINE logger_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !------------------------------------------------------------------- + !> @brief This subroutine flushing output into log file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !------------------------------------------------------------------- + SUBROUTINE logger_flush() + + IMPLICIT NONE + + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + CALL logger_close() + CALL logger_open( tm_logger%c_name, tm_logger%c_verbosity, & + & tm_logger%i_maxerror, tm_logger%i_id ) + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_flush') + ENDIF + ENDIF + + END SUBROUTINE logger_flush + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + RECURSIVE SUBROUTINE logger_header() + !------------------------------------------------------------------- + !> @brief This subroutine write header on log file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + WRITE( tm_logger%i_id, & + & FMT='(4(a/))', & + & IOSTAT=il_status ) & + & "--------------------------------------------------",& + & "INIT : verbosity "//TRIM(tm_logger%c_verbosity),& + & "INIT : max error "//TRIM(fct_str(tm_logger%i_maxerror)), & + & "--------------------------------------------------" + CALL fct_err(il_status) + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_header') + ENDIF + ENDIF + + END SUBROUTINE logger_header + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_footer() + !------------------------------------------------------------------- + !> @brief This subroutine write footer on log file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! local variable + INTEGER(i4) :: il_status + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + WRITE( tm_logger%i_id, & + & FMT='(4(/a))', & + & IOSTAT=il_status ) & + & "--------------------------------------------------",& + & "END : log ended ", & + & "END : "//TRIM(fct_str(tm_logger%i_nerror))// & + & " ERROR detected ", & + & "END : "//TRIM(fct_str(tm_logger%i_nfatal))// & + & " FATAL detected ", & + & "--------------------------------------------------" + CALL fct_err(il_status) + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_footer') + ENDIF + ENDIF + + END SUBROUTINE logger_footer + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_trace(cd_msg, ld_flush) + !------------------------------------------------------------------- + !> @brief This subroutine write trace message on log file. + !> @details + !> Optionally you could flush output. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_msg message to write + !> @param[in] ld_flush flushing ouput + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + LOGICAL, INTENT(IN), OPTIONAL :: ld_flush + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + IF( INDEX(TRIM(tm_logger%c_verb),'trace')/=0 )THEN + + CALL logger__write("TRACE :",cd_msg) + + IF( PRESENT(ld_flush) )THEN + IF( ld_flush )THEN + CALL logger_flush() + ENDIF + ENDIF + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_trace') + ENDIF + ENDIF + + END SUBROUTINE logger_trace + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_debug(cd_msg, ld_flush) + !------------------------------------------------------------------- + !> @brief This subroutine write debug message on log file. + !> @details + !> Optionally you could flush output. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_msg message to write + !> @param[in] ld_flush flushing ouput + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + LOGICAL, INTENT(IN), OPTIONAL :: ld_flush + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + IF( INDEX(TRIM(tm_logger%c_verb),'debug')/=0 )THEN + + CALL logger__write("DEBUG :",cd_msg) + + IF( PRESENT(ld_flush) )THEN + IF( ld_flush )THEN + CALL logger_flush() + ENDIF + ENDIF + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_debug') + ENDIF + ENDIF + + END SUBROUTINE logger_debug + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_info(cd_msg, ld_flush) + !------------------------------------------------------------------- + !> @brief This subroutine write info message on log file. + !> @details + !> Optionally you could flush output. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_msg message to write + !> @param[in] ld_flush flushing ouput + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + LOGICAL, INTENT(IN), OPTIONAL :: ld_flush + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + IF( INDEX(TRIM(tm_logger%c_verb),'info')/=0 )THEN + + CALL logger__write("INFO :",cd_msg) + + IF( PRESENT(ld_flush) )THEN + IF( ld_flush )THEN + CALL logger_flush() + ENDIF + ENDIF + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_info') + ENDIF + ENDIF + END SUBROUTINE logger_info + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_warn(cd_msg, ld_flush) + !------------------------------------------------------------------- + !> @brief This subroutine write warning message on log file. + !> @details + !> Optionally you could flush output. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_msg message to write + !> @param[in] ld_flush flushing ouput + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + LOGICAL, INTENT(IN), OPTIONAL :: ld_flush + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + IF( INDEX(TRIM(tm_logger%c_verb),'warn')/=0 )THEN + + CALL logger__write("WARNING :",cd_msg) + + IF( PRESENT(ld_flush) )THEN + IF( ld_flush )THEN + CALL logger_flush() + ENDIF + ENDIF + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_warn') + ENDIF + ENDIF + + END SUBROUTINE logger_warn + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger_error(cd_msg, ld_flush) + !------------------------------------------------------------------- + !> @brief This subroutine write error message on log file. + !> @details + !> Optionally you could flush output. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_msg message to write + !> @param[in] ld_flush flushing ouput + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + LOGICAL, INTENT(IN), OPTIONAL :: ld_flush + + ! local variable + CHARACTER(LEN=lc) :: cl_nerror + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + ! increment the error number + tm_logger%i_nerror=tm_logger%i_nerror+1 + + IF( INDEX(TRIM(tm_logger%c_verb),'error')/=0 )THEN + + CALL logger__write("ERROR :",cd_msg) + + IF( PRESENT(ld_flush) )THEN + IF( ld_flush )THEN + CALL logger_flush() + ENDIF + ENDIF + ENDIF + + IF( tm_logger%i_nerror >= tm_logger%i_maxerror )THEN + WRITE(cl_nerror,*) tm_logger%i_maxerror + CALL logger_fatal(& + & 'Error count reached limit of '//TRIM(ADJUSTL(cl_nerror)) ) + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_error') + ENDIF + ENDIF + + END SUBROUTINE logger_error + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + RECURSIVE SUBROUTINE logger_fatal(cd_msg) + !------------------------------------------------------------------- + !> @brief This subroutine write fatal error message on log file, + !> close log file and stop process. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September, 2015 + !> - stop program for FATAL ERROR if verbosity is none + !> + !> @param[in] cd_msg message to write + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + !---------------------------------------------------------------- + + IF( tm_logger%l_use )THEN + IF( tm_logger%i_id /= 0 )THEN + IF( INDEX(TRIM(tm_logger%c_verb),'fatal')/=0 )THEN + ! increment the error number + tm_logger%i_nfatal=tm_logger%i_nfatal+1 + + CALL logger__write("FATAL :",cd_msg) + + CALL logger_footer() + CALL logger_close() + + WRITE(*,*) 'FATAL ERROR, see ',TRIM(tm_logger%c_name) + STOP + ENDIF + ELSE + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('you must have create logger to use logger_fatal') + ENDIF + ELSE + PRINT *,"FATAL ERROR :"//TRIM(cd_msg) + STOP + ENDIF + + END SUBROUTINE logger_fatal + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE logger__write(cd_verb, cd_msg) + !------------------------------------------------------------------- + !> @brief This subroutine cut message to get maximum of 80 character + !> by line in log file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] cd_verb verbosity of the message to write + !> @param[in] cd_msg message to write + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_verb + CHARACTER(LEN=*), INTENT(IN) :: cd_msg + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_verb + INTEGER(i4) :: il_msg + CHARACTER(LEN=lc) :: cl_verb + CHARACTER(LEN=lc) :: cl_msg + CHARACTER(LEN=lc) :: cl_tmp + !---------------------------------------------------------------- + + cl_verb=TRIM(ADJUSTL(cd_verb)) + cl_msg=TRIM(ADJUSTL(cd_msg)) + + il_verb=LEN_TRIM(cl_verb) + il_msg=LEN_TRIM(cl_msg) + DO WHILE( il_verb + il_msg > 78 ) + cl_tmp=TRIM(cl_verb)//' '//TRIM(cl_msg(1:78-il_verb)) + + WRITE( tm_logger%i_id, & + & FMT=*, & + & IOSTAT=il_status & + & ) TRIM(cl_tmp) + CALL fct_err(il_status) + + + cl_msg=cl_msg(78-il_verb+1:il_msg) + cl_verb=" :" + + il_msg=LEN_TRIM(cl_msg) + + ENDDO + + cl_tmp=TRIM(cl_verb)//' '//TRIM(cl_msg) + WRITE( tm_logger%i_id, & + & FMT=*, & + & IOSTAT=il_status & + & ) TRIM(cl_tmp) + CALL fct_err(il_status) + + END SUBROUTINE logger__write + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION logger__check_verb(cd_verb) & + & RESULT (lf_show) + !------------------------------------------------------------------- + !> @brief This function check validity of verbosity. + !> + !> @author J.Paul + !> @date February, 2015 - Initial Version + !> + !> @param[in] cd_verb verbosity of the message to write + !> @return verbosity is valid or not + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_verb + + !function + LOGICAL :: lf_show + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_show=.FALSE. + + DO ji=1,im_nverbosity + IF( TRIM(cd_verb) == TRIM(cm_verbosity(ji)) )THEN + lf_show=.TRUE. + EXIT + ENDIF + ENDDO + + IF( .NOT. lf_show )THEN + CALL logger_open('logger.log') + CALL logger_header() + CALL logger_fatal('LOGGER : invalid verbosity, check namelist.'//& + & ' default one will be used.') + CALL logger_footer() + ENDIF + + END FUNCTION logger__check_verb + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE logger + diff --git a/V4.0/nemo_sources/tools/SIREN/src/math.f90 b/V4.0/nemo_sources/tools/SIREN/src/math.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0435cec813fae23140d89bef0b4766c9bcb6febd --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/math.f90 @@ -0,0 +1,1450 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module groups some useful mathematical function. +!> +!> @details +!> +!> to compute the mean of an array:<br/> +!> @code +!> dl_value=math_mean( dl_value, dd_fill ) +!> @endcode +!> - dl_value is 1D or 2D array +!> - dd_fill is FillValue +!> +!> to compute the median of an array:<br/> +!> @code +!> dl_value=math_median( dl_value, dd_fill ) +!> @endcode +!> - dl_value is 1D or 2D array +!> - dd_fill is FillValue +!> +!> to compute the mean without extremum of an array:<br/> +!> @code +!> dl_value=math_mwe( dl_value, id_next, dd_fill ) +!> @endcode +!> - dl_value is 1D or 2D array +!> - id_next is the number of extremum to be removed +!> - dd_fill is FillValue +!> +!> to sort an 1D array:<br/> +!> @code +!> CALL math_QsortC(dl_value) +!> @endcode +!> - dl_value is 1D array +!> +!> to correct phase angles to produce smoother phase:<br/> +!> @code +!> CALL math_unwrap(dl_value, [dl_discont]) +!> @endcode +!> - dl_value is 1D array +!> - dl_discont maximum discontinuity between values, default pi +!> +!> to compute simple operation +!> @code +!> dl_res=math_compute(cl_var) +!> @endcode +!> - cl_var operation to compute (string of character) +!> - dl_res result of the operation, real(dp) +!> +!> to compute first derivative of 1D array:<br/> +!> @code +!> dl_value(:)=math_deriv_1D( dd_value(:), dd_fill, [ld_discont] ) +!> @endcode +!> - dd_value is 1D array of variable +!> - dd_fill is FillValue of variable +!> - ld_discont is logical to take into account longitudinal +!> East-West discontinuity [optional] +!> +!> to compute first derivative of 2D array:<br/> +!> @code +!> dl_value(:,:)=math_deriv_2D( dd_value(:,:), dd_fill, cd_dim, +!> [ld_discont] ) +!> @endcode +!> - dd_value is 2D array of variable +!> - dd_fill is FillValue of variable +!> - cd_dim is character to compute derivative on first (I) or +!> second (J) dimension +!> - ld_discont is logical to take into account longitudinal +!> East-West discontinuity [optional] +!> +!> to compute first derivative of 3D array:<br/> +!> @code +!> dl_value(:,:,:)=math_deriv_3D( dd_value(:,:,:), dd_fill, cd_dim, +!> [ld_discont] ) +!> @endcode +!> - dd_value is 3D array of variable +!> - dd_fill is FillValue of variable +!> - cd_dim is character to compute derivative on first (I), second (J), +!> or third (K) dimension +!> - ld_discont is logical to take into account longitudinal East-West +!> discontinuity [optional] +!> +!> +!> @author +!> J.Paul +!> +!> @date January, 2015 - Initial version +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE math + + USE kind ! F90 kind parameter + USE global ! global variable + USE phycst ! physical constant + USE fct ! basic useful function + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! function and subroutine + PUBLIC :: math_mean !< return mean of an array + PUBLIC :: math_median !< return median of an array + PUBLIC :: math_mwe !< return mean without extremum of an array + PUBLIC :: math_QsortC !< sort an 1D array + PUBLIC :: math_unwrap !< correct phase angles to produce smoother phase + PUBLIC :: math_compute !< compute simple operation + PUBLIC :: math_deriv_1D !< compute first derivative of 1D array + PUBLIC :: math_deriv_2D !< compute first derivative of 2D array + PUBLIC :: math_deriv_3D !< compute first derivative of 3D array + PUBLIC :: math_ortho !< compute orthodome distance + PUBLIC :: math_euclid !< compute euclidian distance + + PRIVATE :: math__Partition + PRIVATE :: math__mean_1d + PRIVATE :: math__mean_2d + PRIVATE :: math__median_1d + PRIVATE :: math__median_2d + PRIVATE :: math__mwe_1d + PRIVATE :: math__mwe_2d + PRIVATE :: math__parentheses + + + INTERFACE math_mean + MODULE PROCEDURE math__mean_1d ! return mean of an array 1D + MODULE PROCEDURE math__mean_2d ! return mean of an array 2D + END INTERFACE math_mean + + INTERFACE math_median + MODULE PROCEDURE math__median_1d ! return median of an array 1D + MODULE PROCEDURE math__median_2d ! return median of an array 2D + END INTERFACE math_median + + INTERFACE math_mwe + MODULE PROCEDURE math__mwe_1d ! return mean without extremum of an array 1D + MODULE PROCEDURE math__mwe_2d ! return mean without extremum of an array 2D + END INTERFACE math_mwe + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__mean_1d(dd_array, dd_fill) & + & RESULT (df_mean) + !------------------------------------------------------------------- + !> @brief This function compute the mean of a 1D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 1D array + !> @param[in] dd_fill fillValue + !> @return mean value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + REAL(dp) :: df_mean + + ! local variable + INTEGER(i4) :: il_count + REAL(dp) :: dl_sum + REAL(dp) :: dl_count + !---------------------------------------------------------------- + + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:)/=dd_fill) + IF( il_count > 0 )THEN + dl_sum =SUM ( dd_array(:), dd_array(:)/= dd_fill ) + dl_count=REAL( il_count, dp) + + df_mean=dl_sum/dl_count + ELSE + df_mean=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array(:)) + IF( il_count > 0 )THEN + dl_sum =SUM ( dd_array(:) ) + dl_count=REAL( il_count, dp) + + df_mean=dl_sum/dl_count + ELSE + df_mean=0 + ENDIF + ENDIF + + END FUNCTION math__mean_1d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__mean_2d(dd_array, dd_fill) & + & RESULT (df_mean) + !------------------------------------------------------------------- + !> @brief This function compute the mean of a 2D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 2D array + !> @param[in] dd_fill fillValue + !> @return mean value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + REAL(dp) :: df_mean + + ! local variable + INTEGER(i4) :: il_count + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list + !---------------------------------------------------------------- + + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:,:)/=dd_fill) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill) + ELSE + df_mean=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.) + ELSE + df_mean=0 + ENDIF + ENDIF + + IF( ALLOCATED(dl_list) )THEN + df_mean=math_mean(dl_list(:)) + DEALLOCATE( dl_list ) + ENDIF + + END FUNCTION math__mean_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__median_1d(dd_array, dd_fill) & + & RESULT (df_median) + !------------------------------------------------------------------- + !> @brief This function compute the median of a 1D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 1D array + !> @param[in] dd_fill fillValue + !> @return median value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + REAL(dp) :: df_median + + ! local variable + INTEGER(i4) :: il_count + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list + !---------------------------------------------------------------- + + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:)/=dd_fill) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:),dd_array(:)/=dd_fill) + ELSE + df_median=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array(:)) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=dd_array(:) + ELSE + df_median=0 + ENDIF + ENDIF + + IF( ALLOCATED(dl_list) )THEN + CALL math_QsortC(dl_list(:)) + + IF( MOD(il_count,2) == 0 )THEN + df_median=(dl_list(il_count/2+1)+dl_list(il_count/2))/2_dp + ELSE + df_median=dl_list(il_count/2+1) + ENDIF + + DEALLOCATE(dl_list) + ENDIF + + END FUNCTION math__median_1d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__median_2d(dd_array, dd_fill) & + & RESULT (df_median) + !------------------------------------------------------------------- + !> @brief This function compute the median of a 2D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 2D array + !> @param[in] dd_fill fillValue + !> @return median value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! funtion + REAL(dp) :: df_median + + ! local variable + INTEGER(i4) :: il_count + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list + !---------------------------------------------------------------- + + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:,:)/=dd_fill) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill) + ELSE + df_median=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array(:,:)) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.) + ELSE + df_median=0 + ENDIF + ENDIF + + IF( ALLOCATED(dl_list) )THEN + df_median=math_median(dl_list(:)) + DEALLOCATE(dl_list) + ENDIF + + END FUNCTION math__median_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__mwe_1d(dd_array, id_next, dd_fill) & + & RESULT (df_mwe) + !------------------------------------------------------------------- + !> @brief This function compute the mean without extremum of a 1D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 1D array + !> @param[in] id_next number of extremum to be removed + !> @param[in] dd_fill fillValue + !> @return median value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_next + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + REAL(dp) :: df_mwe + + ! local variable + INTEGER(i4) :: il_next + INTEGER(i4) :: il_count + INTEGER(i4) :: il_size + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list + !---------------------------------------------------------------- + + il_next=2 + IF( PRESENT(id_next) ) il_next=id_next + + il_size=SIZE(dd_array(:)) + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:)/=dd_fill) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:),dd_array(:)/=dd_fill) + ELSE + df_mwe=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array(:)) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=dd_array(:) + ELSE + df_mwe=0 + ENDIF + ENDIF + + IF( ALLOCATED(dl_list) )THEN + CALL math_QsortC(dl_list(:)) + + IF( il_count == il_size )THEN + ! no fillValue + df_mwe=math_mean(dl_list(il_next+1:il_size-il_next)) + ELSEIF( il_count > il_size-2*il_next )THEN + ! remove one extremum each side + df_mwe=math_mean(dl_list(2:il_size-1)) + ELSE ! il_count <= il_size-2*il_next + ! more than 2*il_next fillValue + ! compute mean only + df_mwe=math_mean(dl_list(:)) + ENDIF + + DEALLOCATE(dl_list) + ENDIF + + END FUNCTION math__mwe_1d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math__mwe_2d(dd_array, id_next, dd_fill) & + & RESULT (df_mwe) + !------------------------------------------------------------------- + !> @brief This function compute the mean without extremum of a 2D array. + !> + !> @author J.Paul + !> @date January, 2015 - Initial Version + !> + !> @param[in] dd_array 2D array + !> @param[in] id_next number of extremum to be removed + !> @param[in] dd_fill fillValue + !> @return median value, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_next + REAL(dp), INTENT(IN), OPTIONAL :: dd_fill + + ! function + REAL(dp) :: df_mwe + + ! local variable + INTEGER(i4) :: il_count + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list + !---------------------------------------------------------------- + + IF( PRESENT(dd_fill) )THEN + il_count=COUNT(dd_array(:,:)/=dd_fill) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill) + + df_mwe=math_mwe(dl_list(:), id_next) + ELSE + df_mwe=dd_fill + ENDIF + ELSE + il_count=SIZE(dd_array(:,:)) + IF( il_count > 0 )THEN + ALLOCATE( dl_list(il_count) ) + dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.) + + df_mwe=math_mwe(dl_list(:), id_next) + ELSE + df_mwe=0 + ENDIF + ENDIF + + IF( ALLOCATED(dl_list) ) DEALLOCATE(dl_list) + + END FUNCTION math__mwe_2d + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE RECURSIVE SUBROUTINE math_QsortC(dd_array) + !------------------------------------------------------------------- + !> @brief This subroutine sort a 1D array. + !> + !> @details + !> Recursive Fortran 95 quicksort routine + !> sorts real numbers into ascending numerical order + !> Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03 + !> Based on algorithm from Cormen et al., Introduction to Algorithms, + !> 1997 printing + !> + !> @author J.Paul + !> @date January, 2015 - Rewrite with SIREN coding rules + !> + !> @param[inout] dd_array 1D array + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_array + + ! local variable + INTEGER(i4) :: il_iq + !---------------------------------------------------------------- + + IF( SIZE(dd_array(:)) > 1 )THEN + CALL math__Partition(dd_array, il_iq) + CALL math_QsortC(dd_array(:il_iq-1)) + CALL math_QsortC(dd_array(il_iq:)) + ENDIF + + END SUBROUTINE math_QsortC + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE SUBROUTINE math__Partition(dd_array, id_marker) + !------------------------------------------------------------------- + !> @brief This subroutine partition a 1D array. + !> + !> @details + !> Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03 + !> Based on algorithm from Cormen et al., Introduction to Algorithms, + !> 1997 printing + !> + !> @author J.Paul + !> @date January, 2015 - Rewrite with SIREN coding rules + !> @date November, 2017 + !> - use the correct loop index to look for element bigger than pivot point. + !> + !> @param[inout] dd_array 1D array + !> @param[in] id_marker + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_array + INTEGER(i4), INTENT( OUT) :: id_marker + + ! local variable + REAL(dp) :: dl_temp + REAL(dp) :: dl_x ! pivot point + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + dl_x = dd_array(1) + ji= 0 + jj= SIZE(dd_array(:)) + 1 + + DO + jj=jj-1 + DO + IF( dd_array(jj) <= dl_x ) EXIT + jj=jj-1 + ENDDO + ji=ji+1 + DO + IF( dd_array(ji) >= dl_x ) EXIT + ji=ji+1 + ENDDO + IF( ji < jj )THEN + ! exchange dd_array(ji) and dd_array(jj) + dl_temp= dd_array(ji) + dd_array(ji) = dd_array(jj) + dd_array(jj) = dl_temp + ELSEIF( ji==jj )THEN + id_marker=ji+1 + RETURN + ELSE + id_marker=ji + RETURN + ENDIF + ENDDO + + END SUBROUTINE math__Partition + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE SUBROUTINE math_unwrap(dd_array, dd_discont) + !------------------------------------------------------------------- + !> @brief This subroutine correct phase angles to produce smoother + !> phase plots. + !> + !> @details + !> This code is based on numpy unwrap function + !> + !> Unwrap by changing deltas between values to 2*pi complement. + !> + !> Unwrap radian phase `dd_array` by changing absolute jumps greater than + !> `dd_discont` to their 2*pi complement. + !> + !> @note If the discontinuity in `dd_array` is smaller than ``pi``, + !> but larger than `dd_discont`, no unwrapping is done because taking + !> the 2*pi complement would only make the discontinuity larger. + !> + !> @author J.Paul + !> @date Marsh, 2015 - Rewrite in fortran, with SIREN coding rules + !> + !> @param[inout] dd_array 1D array + !> @param[in] dd_discont maximum discontinuity between values, default pi + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_array + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_discont + + ! local variable + INTEGER(i4) :: il_size + + REAL(dp) :: dl_discont + + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_diff + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_mod + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_correct + REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_tmp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + dl_discont=dp_pi + IF( PRESENT(dd_discont) ) dl_discont=dd_discont + + il_size=SIZE(dd_array) + ALLOCATE(dl_diff(il_size-1)) + DO ji=1,il_size-1 + dl_diff(ji)=dd_array(ji+1)-dd_array(ji) + ENDDO + + ALLOCATE(dl_mod(il_size-1)) + DO ji=1,il_size-1 + dl_mod(ji) = MOD(dl_diff(ji) + dp_pi, 2*dp_pi) - dp_pi + ENDDO + + WHERE( (dl_mod(:) == -dp_pi) .AND. (dl_diff(:) > 0._dp ) ) + dl_mod(:)=dp_pi + END WHERE + + ALLOCATE(dl_correct(il_size-1)) + dl_correct(:)=dl_mod(:)-dl_diff(:) + + DEALLOCATE(dl_mod) + + WHERE( ABS(dl_diff(:)) < dl_discont ) + dl_correct(:)=0._dp + END WHERE + + DEALLOCATE(dl_diff) + + ALLOCATE(dl_tmp(il_size)) + dl_tmp(:)=dd_array(:) + + DO ji=1,il_size-1 + dd_array(ji+1)=dl_tmp(ji+1)+SUM(dl_correct(1:ji)) + ENDDO + + DEALLOCATE(dl_correct) + DEALLOCATE(dl_tmp) + + END SUBROUTINE math_unwrap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + RECURSIVE FUNCTION math_compute(cd_var) & + & RESULT(df_res) + !------------------------------------------------------------------- + !> @brief This function compute simple operation + !> + !> @details + !> - operation should be write as a string of character. + !> - operators allowed are : +,-,*,/ + !> - to ordered operation you should use parentheses + !> + !> exemples: '1e6/(16/122)', '(3/2)*(2+1)' + !> + !> @author J.Paul + !> @date June, 2015 - initial version + !> + !> @param[in] cd_var operation to compute (string of character) + !> @return result of the operation, real(dp) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_var + + ! fucntion + REAL(dp) :: df_res + + ! local variables + CHARACTER(LEN=lc) :: cl_var + CHARACTER(LEN=lc) :: cl_str1 + CHARACTER(LEN=lc) :: cl_str2 + + INTEGER(i4) :: il_ind + ! loop indices + !---------------------------------------------------------------- + + + IF(fct_is_real(cd_var))THEN + READ(cd_var,*) df_res + ELSE + + + CALL math__parentheses(cd_var, cl_var) + + IF(fct_is_real(cl_var))THEN + READ(cl_var,*) df_res + ELSE + il_ind=SCAN(TRIM(cl_var),'*') + IF( il_ind /= 0 )THEN + cl_str1=cl_var(1:il_ind-1) + cl_str2=cl_var(il_ind+1:) + df_res=math_compute(cl_str1)*math_compute(cl_str2) + ELSE + il_ind=SCAN(TRIM(cl_var),'/') + IF( il_ind /= 0 )THEN + cl_str1=cl_var(1:il_ind-1) + cl_str2=cl_var(il_ind+1:) + df_res=math_compute(cl_str1)/math_compute(cl_str2) + ELSE + il_ind=SCAN(TRIM(cl_var),'+') + IF( il_ind /= 0 )THEN + cl_str1=cl_var(1:il_ind-1) + cl_str2=cl_var(il_ind+1:) + df_res=math_compute(cl_str1)+math_compute(cl_str2) + ELSE + il_ind=SCAN(TRIM(cl_var),'-') + IF( il_ind /= 0 )THEN + cl_str1=cl_var(1:il_ind-1) + cl_str2=cl_var(il_ind+1:) + df_res=math_compute(cl_str1)-math_compute(cl_str2) + ELSE + df_res=dp_fill + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + END FUNCTION math_compute + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE math__parentheses(cd_varin, cd_varout) + !------------------------------------------------------------------- + !> @brief This subroutine replace sub string inside parentheses + !> by the value of the operation inside. + !> + !> @details + !> exemple : + !> - '2.6+(3/2)' => '2.6+1.5000' + !> + !> @author J.Paul + !> @date June, 2015 - initial version + !> + !> @param[in] cd_varin string of character with operation inside + !> parentheses + !> @param[out] cd_varout string of character with result of + !> operation inside parentheses + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*) , INTENT(IN) :: cd_varin + CHARACTER(LEN=lc), INTENT(OUT) :: cd_varout + + ! local variables + CHARACTER(LEN=lc) :: cl_cpt + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_count + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + il_ind=INDEX(cd_varin,'(') + IF( il_ind /= 0 )THEN + il_count=0 + DO ji=il_ind+1,LEN(cd_varin) + IF( cd_varin(ji:ji) == '(' )THEN + il_count=il_count+1 + ELSEIF( cd_varin(ji:ji) == ')' )THEN + IF( il_count == 0 )THEN + WRITE(cl_cpt,*) math_compute(cd_varin(il_ind+1:ji-1)) + cd_varout=TRIM(cd_varin(1:il_ind-1))//TRIM(ADJUSTL(cl_cpt))//& + & TRIM(cd_varin(ji+1:)) + EXIT + ELSE + il_count=il_count-1 + ENDIF + ENDIF + ENDDO + ELSE + cd_varout=TRIM(cd_varin) + ENDIF + + END SUBROUTINE math__parentheses + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math_deriv_1D(dd_value, dd_fill, ld_discont) & + & RESULT (df_deriv) + !------------------------------------------------------------------- + !> @brief + !> This function compute derivative of 1D array. + !> + !> @details + !> optionaly you could specify to take into account east west discontinuity + !> (-180° 180° or 0° 360° for longitude variable) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_value 1D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[in] ld_discont logical to take into account east west discontinuity + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:), INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + LOGICAL , INTENT(IN), OPTIONAL :: ld_discont + + ! function + REAL(dp), DIMENSION(SIZE(dd_value,DIM=1) ) :: df_deriv + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4), DIMENSION(1) :: il_shape + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value + + LOGICAL :: ll_discont + + ! loop indices + INTEGER(i4) :: ji + + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + !---------------------------------------------------------------- + ! init + df_deriv(:)=dd_fill + + ll_discont=.FALSE. + IF( PRESENT(ld_discont) ) ll_discont=ld_discont + + il_shape(:)=SHAPE(dd_value(:)) + + ALLOCATE( dl_value(3)) + + ! compute derivative in i-direction + DO ji=1,il_shape(1) + + il_imin=MAX(ji-1,1) + il_imax=MIN(ji+1,il_shape(1)) + + IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN + i1=1 ; i2=3 + ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN + i1=1 ; i2=2 + ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN + i1=2 ; i2=3 + ENDIF + + dl_value(i1:i2)=dd_value(il_imin:il_imax) + IF( il_imin == 1 )THEN + dl_value(:)=EOSHIFT( dl_value(:), & + & DIM=1, & + & SHIFT=-1, & + & BOUNDARY=dl_value(1) ) + ENDIF + IF( il_imax == il_shape(1) )THEN + dl_value(:)=EOSHIFT( dl_value(:), & + & DIM=1, & + & SHIFT=1, & + & BOUNDARY=dl_value(3)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:), dl_value(:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:), dl_value(:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:) < 0._dp ) + dl_value(:) = dl_value(:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:) > 180._dp ) + dl_value(:) = dl_value(:)-180._dp + END WHERE + ENDIF + ENDIF + + IF( dl_value( 2) /= dd_fill .AND. & ! ji + & dl_value( 3) /= dd_fill .AND. & ! ji+1 + & dl_value( 1) /= dd_fill )THEN ! ji-1 + + df_deriv(ji)= (dl_value(3) - dl_value(1)) / REAL(il_imax-il_imin,dp) + + ENDIF + + ENDDO + + DEALLOCATE( dl_value ) + + END FUNCTION math_deriv_1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION math_deriv_2D(dd_value, dd_fill, cd_dim, ld_discont) & + & RESULT (df_deriv) + !------------------------------------------------------------------- + !> @brief + !> This function compute derivative of 2D array. + !> you have to specify in which direction derivative have to be computed: + !> first (I) or second (J) dimension. + !> + !> @details + !> optionaly you could specify to take into account east west discontinuity + !> (-180° 180° or 0° 360° for longitude variable) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] dd_value 2D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[in] cd_dim compute derivative on first (I) or second (J) dimension + !> @param[in] ld_discont logical to take into account east west discontinuity + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + CHARACTER(LEN=*) , INTENT(IN) :: cd_dim + LOGICAL , INTENT(IN), OPTIONAL :: ld_discont + + ! function + REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), & + & SIZE(dd_value,DIM=2) ) :: df_deriv + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_value + + LOGICAL :: ll_discont + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + + INTEGER(i4) :: j1 + INTEGER(i4) :: j2 + !---------------------------------------------------------------- + ! init + df_deriv(:,:)=dd_fill + + ll_discont=.FALSE. + IF( PRESENT(ld_discont) ) ll_discont=ld_discont + + il_shape(:)=SHAPE(dd_value(:,:)) + + SELECT CASE(TRIM(fct_upper(cd_dim))) + + CASE('I') + + ALLOCATE( dl_value(3,il_shape(2)) ) + ! compute derivative in i-direction + DO ji=1,il_shape(1) + + ! init + dl_value(:,:)=dd_fill + + il_imin=MAX(ji-1,1) + il_imax=MIN(ji+1,il_shape(1)) + + IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN + i1=1 ; i2=3 + ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN + i1=1 ; i2=2 + ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN + i1=2 ; i2=3 + ENDIF + + dl_value(i1:i2,:)=dd_value(il_imin:il_imax,:) + IF( il_imin == 1 )THEN + dl_value(:,:)=EOSHIFT( dl_value(:,:), & + & DIM=1, & + & SHIFT=-1, & + & BOUNDARY=dl_value(1,:) ) + ENDIF + IF( il_imax == il_shape(1) )THEN + dl_value(:,:)=EOSHIFT( dl_value(:,:), & + & DIM=1, & + & SHIFT=1, & + & BOUNDARY=dl_value(3,:)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:,:) < 0_dp ) + dl_value(:,:) = dl_value(:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:,:) > 180 ) + dl_value(:,:) = dl_value(:,:)-180._dp + END WHERE + ENDIF + ENDIF + + WHERE( dl_value(2,:) /= dd_fill .AND. & ! ji + & dl_value(3,:) /= dd_fill .AND. & ! ji+1 + & dl_value(1,:) /= dd_fill ) ! ji-1 + + df_deriv(ji,:)= (dl_value(3,:) - dl_value(1,:)) / REAL(il_imax-il_imin,dp) + + END WHERE + + ENDDO + + CASE('J') + + ALLOCATE( dl_value(il_shape(1),3) ) + ! compute derivative in j-direction + DO jj=1,il_shape(2) + + il_jmin=MAX(jj-1,1) + il_jmax=MIN(jj+1,il_shape(2)) + + IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN + j1=1 ; j2=3 + ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN + j1=1 ; j2=2 + ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN + j1=2 ; j2=3 + ENDIF + + dl_value(:,j1:j2)=dd_value(:,il_jmin:il_jmax) + IF( il_jmin == 1 )THEN + dl_value(:,:)=EOSHIFT( dl_value(:,:), & + & DIM=2, & + & SHIFT=-1, & + & BOUNDARY=dl_value(:,1)) + ENDIF + IF( il_jmax == il_shape(2) )THEN + dl_value(:,:)=EOSHIFT( dl_value(:,:), & + & DIM=2, & + & SHIFT=1, & + & BOUNDARY=dl_value(:,3)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:,:) < 0_dp ) + dl_value(:,:) = dl_value(:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:,:) > 180 ) + dl_value(:,:) = dl_value(:,:)-180._dp + END WHERE + ENDIF + ENDIF + + WHERE( dl_value(:, 2) /= dd_fill .AND. & ! jj + & dl_value(:, 3) /= dd_fill .AND. & ! jj+1 + & dl_value(:, 1) /= dd_fill ) ! jj-1 + + df_deriv(:,jj)= (dl_value(:,3) - dl_value(:,1)) / REAL(il_jmax-il_jmin,dp) + + END WHERE + + ENDDO + + END SELECT + + DEALLOCATE( dl_value ) + + END FUNCTION math_deriv_2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + PURE FUNCTION math_deriv_3D(dd_value, dd_fill, cd_dim, ld_discont) & + & RESULT (df_deriv) + !------------------------------------------------------------------- + !> @brief + !> This function compute derivative of 3D array. + !> you have to specify in which direction derivative have to be computed: + !> first (I), second (J) or third (K) dimension. + !> + !> @details + !> optionaly you could specify to take into account east west discontinuity + !> (-180° 180° or 0° 360° for longitude variable) + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] dd_value 3D array of variable to be extrapolated + !> @param[in] dd_fill FillValue of variable + !> @param[in] cd_dim compute derivative on first (I) second (J) or third (K) dimension + !> @param[in] ld_discont logical to take into account east west discontinuity + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value + REAL(dp) , INTENT(IN) :: dd_fill + CHARACTER(LEN=*) , INTENT(IN) :: cd_dim + LOGICAL , INTENT(IN), OPTIONAL :: ld_discont + + ! function + REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), & + & SIZE(dd_value,DIM=2), & + & SIZE(dd_value,DIM=3)) :: df_deriv + + ! local variable + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + INTEGER(i4) :: il_kmin + INTEGER(i4) :: il_kmax + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_value + + LOGICAL :: ll_discont + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + + INTEGER(i4) :: i1 + INTEGER(i4) :: i2 + + INTEGER(i4) :: j1 + INTEGER(i4) :: j2 + + INTEGER(i4) :: k1 + INTEGER(i4) :: k2 + !---------------------------------------------------------------- + ! init + df_deriv(:,:,:)=dd_fill + + ll_discont=.FALSE. + IF( PRESENT(ld_discont) ) ll_discont=ld_discont + + il_shape(:)=SHAPE(dd_value(:,:,:)) + + + SELECT CASE(TRIM(fct_upper(cd_dim))) + + CASE('I') + + ALLOCATE( dl_value(3,il_shape(2),il_shape(3)) ) + ! compute derivative in i-direction + DO ji=1,il_shape(1) + + il_imin=MAX(ji-1,1) + il_imax=MIN(ji+1,il_shape(1)) + + IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN + i1=1 ; i2=3 + ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN + i1=1 ; i2=2 + ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN + i1=2 ; i2=3 + ENDIF + + dl_value(i1:i2,:,:)=dd_value(il_imin:il_imax,:,:) + IF( il_imin == 1 )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=1, & + & SHIFT=-1, & + & BOUNDARY=dl_value(1,:,:) ) + ENDIF + IF( il_imax == il_shape(1) )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=1, & + & SHIFT=1, & + & BOUNDARY=dl_value(3,:,:)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:,:,:) < 0_dp ) + dl_value(:,:,:) = dl_value(:,:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:,:,:) > 180 ) + dl_value(:,:,:) = dl_value(:,:,:)-180._dp + END WHERE + ENDIF + ENDIF + + WHERE( dl_value(2,:,:) /= dd_fill .AND. & ! ji + & dl_value(3,:,:) /= dd_fill .AND. & !ji+1 + & dl_value(1,:,:) /= dd_fill ) !ji-1 + + df_deriv(ji,:,:)= (dl_value(3,:,:) - dl_value(1,:,:)) / REAL(il_imax-il_imin,dp) + + END WHERE + + ENDDO + + CASE('J') + + ALLOCATE( dl_value(il_shape(1),3,il_shape(3)) ) + ! compute derivative in j-direction + DO jj=1,il_shape(2) + + il_jmin=MAX(jj-1,1) + il_jmax=MIN(jj+1,il_shape(2)) + + IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN + j1=1 ; j2=3 + ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN + j1=1 ; j2=2 + ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN + j1=2 ; j2=3 + ENDIF + + dl_value(:,j1:j2,:)=dd_value(:,il_jmin:il_jmax,:) + IF( il_jmin == 1 )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=2, & + & SHIFT=-1, & + & BOUNDARY=dl_value(:,1,:) ) + ENDIF + IF( il_jmax == il_shape(2) )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=2, & + & SHIFT=1, & + & BOUNDARY=dl_value(:,3,:)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:,:,:) < 0_dp ) + dl_value(:,:,:) = dl_value(:,:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:,:,:) > 180 ) + dl_value(:,:,:) = dl_value(:,:,:)-180._dp + END WHERE + ENDIF + ENDIF + + WHERE( dl_value(:, 2,:) /= dd_fill .AND. & ! jj + & dl_value(:, 3,:) /= dd_fill .AND. & ! jj+1 + & dl_value(:, 1,:) /= dd_fill ) ! jj-1 + + df_deriv(:,jj,:)= (dl_value(:,3,:) - dl_value(:,1,:)) / REAL(il_jmax - il_jmin,dp) + + END WHERE + + ENDDO + + CASE('K') + + ALLOCATE( dl_value(il_shape(1),il_shape(2),3) ) + ! compute derivative in k-direction + DO jk=1,il_shape(3) + + il_kmin=MAX(jk-1,1) + il_kmax=MIN(jk+1,il_shape(3)) + + IF( il_kmin==jk-1 .AND. il_kmax==jk+1 )THEN + k1=1 ; k2=3 + ELSEIF( il_kmin==jk .AND. il_kmax==jk+1 )THEN + k1=1 ; k2=2 + ELSEIF( il_kmin==jk-1 .AND. il_kmax==jk )THEN + k1=2 ; k2=3 + ENDIF + + dl_value(:,:,k1:k2)=dd_value(:,:,il_kmin:il_kmax) + IF( il_kmin == 1 )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=3, & + & SHIFT=-1, & + & BOUNDARY=dl_value(:,:,1) ) + ENDIF + IF( il_kmax == il_shape(3) )THEN + dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), & + & DIM=3, & + & SHIFT=1, & + & BOUNDARY=dl_value(:,:,3)) + ENDIF + + IF( ll_discont )THEN + dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill ) + IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN + WHERE( dl_value(:,:,:) < 0_dp ) + dl_value(:,:,:) = dl_value(:,:,:)+360._dp + END WHERE + ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN + WHERE( dl_value(:,:,:) > 180 ) + dl_value(:,:,:) = dl_value(:,:,:)-180._dp + END WHERE + ENDIF + ENDIF + + WHERE( dl_value(:,:,2) /= dd_fill .AND. & ! jk + & dl_value(:,:,3) /= dd_fill .AND. & ! jk+1 + & dl_value(:,:,1) /= dd_fill ) ! jk-1 + + df_deriv(:,:,jk)= (dl_value(:,:,3) - dl_value(:,:,1)) / REAL(il_kmax-il_kmin,dp) + + END WHERE + + ENDDO + + END SELECT + + DEALLOCATE( dl_value ) + + END FUNCTION math_deriv_3D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION math_ortho(dd_latm) & + & RESULT(df_ortho) + !------------------------------------------------------------------- + !> @brief + !> This function compute orthodome distance between opposite point of a cell + !> of one degree. + !> + !> @details + !> + !> @author J.Paul + !> @date April, 2017 - Initial Version + !> + !> @param[in] dd_latm mean latitude of the cell + !> @return orthodome distance + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), TARGET :: dd_latm + + ! function + REAL(dp) :: df_ortho + + ! local + REAL(dp) :: dl_dlat + REAL(dp) :: dl_dlon + REAL(dp) :: dl_lat1 + REAL(dp) :: dl_lat2 + REAL(dp) :: dl_tmp + !---------------------------------------------------------------- + + ! one degree cell + dl_dlat= 1._dp * dp_deg2rad + dl_dlon= 1._dp * dp_deg2rad + + ! + dl_lat1 = (dd_latm - 0.5_dp) * dp_deg2rad + dl_lat2 = (dd_latm + 0.5_dp) * dp_deg2rad + + dl_tmp = SQRT( SIN(dl_dlat*0.5)**2 + & + & COS(dl_lat1)*COS(dl_lat2)*SIN(dl_dlon*0.5)**2 ) + + df_ortho= 2* dp_rearth * ASIN( dl_tmp ) + + END FUNCTION math_ortho + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION math_euclid(dd_lonm,dd_latm) & + & RESULT(df_euclid) + !------------------------------------------------------------------- + !> @brief + !> This function compute euclidian distance between opposite point of a cell + !> of one degree, center on (lonm,latm). + !> + !> @details + !> + !> @author J.Paul + !> @date April, 2017 - Initial Version + !> + !> @param[in] dd_lonm mean longitude of the cell + !> @param[in] dd_latm mean latitude of the cell + !> @return orthodome distance + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), TARGET :: dd_lonm + REAL(dp), TARGET :: dd_latm + + ! function + REAL(dp) :: df_euclid + + ! local + REAL(dp) :: dl_lata + REAL(dp) :: dl_lona + REAL(dp) :: dl_latb + REAL(dp) :: dl_lonb + REAL(dp) :: xa,ya,za + REAL(dp) :: xb,yb,zb + !---------------------------------------------------------------- + + dl_lata=(dd_latm-0.5)*dp_deg2rad + dl_lona=(dd_lonm-0.5)*dp_deg2rad + + xa = dp_rearth * COS(dl_lata) * COS(dl_lona) + ya = dp_rearth * COS(dl_lata) * SIN(dl_lona) + za = dp_rearth * SIN(dl_lata) + + dl_latb=(dd_latm+0.5)*dp_deg2rad + dl_lonb=(dd_lonm+0.5)*dp_deg2rad + + xb = dp_rearth * COS(dl_latb) * COS(dl_lonb) + yb = dp_rearth * COS(dl_latb) * SIN(dl_lonb) + zb = dp_rearth * SIN(dl_latb) + + df_euclid = ((xb-xa)**2 + (yb-ya)**2 + (zb-za)**2) + + END FUNCTION math_euclid + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE math diff --git a/V4.0/nemo_sources/tools/SIREN/src/merge_bathy.f90 b/V4.0/nemo_sources/tools/SIREN/src/merge_bathy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8fdc0b0f802c635e223ddd65b366a44e19a7aeb4 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/merge_bathy.f90 @@ -0,0 +1,1198 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @file +!> @brief +!> this program merges bathymetry file at boundaries. +!> +!> @details +!> @section sec1 method +!> coarse grid bathymetry is interpolated on fine grid +!> (nearest interpolation method is used).<br/> +!> then fine bathymetry and refined coarse bathymetry are merged at boundaries.<br/> +!> @f[BathyFine= Weight * BathyCoarse + (1-Weight)*BathyFine@f] +!> the weight function used is :<br/> +!> @f[Weight = 0.5 + 0.5*COS( \frac{\pi*dist}{width} )@f]<br/> +!> with +!> - dist : number of point to border +!> - width : boundary size +!> +!> @section sec2 how to +!> USAGE: merge_bathy merge_bathy.nam [-v] [-h]<br/> +!> - positional arguments:<br/> +!> - merge_bathy.nam<br/> +!> namelist of merge_bathy +!> @note +!> a template of the namelist could be created running (in templates directory): +!> @code{.sh} +!> python create_templates.py merge_bathy +!> @endcode +!> +!> - optional arguments:<br/> +!> - -h, --help<br/> +!> show this help message (and exit)<br/> +!> - -v, --version<br/> +!> show Siren's version (and exit) +!> +!> @section sec_merge merge_bathy.nam +!> merge_bathy.nam contains 7 namelists: +!> - **namlog** to set logger parameters +!> - **namcfg** to set configuration file parameters +!> - **namsrc** to set source/coarse grid parameters +!> - **namtgt** to set target/fine grid parameters +!> - **namnst** to set sub domain and nesting paramters +!> - **nambdy** to set boundary parameters +!> - **namout** to set output parameters +!> +!> here after, each sub-namelist parameters is detailed. +!> @note +!> default values are specified between brackets +!> +!> @subsection sublog namlog +!> the logger sub-namelist parameters are : +!> +!> - **cn_logfile** [@a merge_bathy.log]<br/> +!> logger filename +!> +!> - **cn_verbosity** [@a warning]<br/> +!> verbosity level, choose between : +!> - trace +!> - debug +!> - info +!> - warning +!> - error +!> - fatal +!> - none +!> +!> - **in_maxerror** [@a 5]<br/> +!> maximum number of error allowed +!> +!> @subsection subcfg namcfg +!> the configuration sub-namelist parameters are : +!> +!> - **cn_varcfg** [@a ./cfg/variable.cfg]<br/> +!> path to the variable configuration file.<br/> +!> the variable configuration file defines standard name, +!> default interpolation method, axis,... +!> to be used for some known variables.<br/> +!> +!> - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/> +!> path to the dimension configuration file.<br/> +!> the dimension configuration file defines dimensions allowed.<br/> +!> +!> - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/> +!> path to the useless (dummy) configuration file.<br/> +!> the dummy configuration file defines useless +!> dimension or variable. these dimension(s) or variable(s) will not be +!> processed.<br/> +!> +!> @subsection subsrc namsrc +!> the source/coarse grid sub-namelist parameters are : +!> +!> - **cn_bathy0** [@a ]<br/> +!> path to the bathymetry file +!> @warning +!> variable name must be __Bathymetry__ here. +!> +!> - **in_perio0** [@a ]<br/> +!> NEMO periodicity index<br/> +!> the NEMO periodicity could be choose between 0 to 6: +!> <dl> +!> <dt>in_perio=0</dt> +!> <dd>standard regional model</dd> +!> <dt>in_perio=1</dt> +!> <dd>east-west cyclic model</dd> +!> <dt>in_perio=2</dt> +!> <dd>model with symmetric boundary condition across the equator</dd> +!> <dt>in_perio=3</dt> +!> <dd>regional model with North fold boundary and T-point pivot</dd> +!> <dt>in_perio=4</dt> +!> <dd>global model with a T-point pivot.<br/> +!> example: ORCA2, ORCA025, ORCA12</dd> +!> <dt>in_perio=5</dt> +!> <dd>regional model with North fold boundary and F-point pivot</dd> +!> <dt>in_perio=6</dt> +!> <dd>global model with a F-point pivot<br/> +!> example: ORCA05</dd> +!> </dd> +!> </dl> +!> @sa For more information see @ref md_src_docsrc_6_perio +!> and Model Boundary Condition paragraph in the +!> [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf) +!> +!> @subsection subtgt namtgt +!> the target/fine grid sub-namelist parameters are : +!> +!> - **cn_bathy1** [@a ]<br/> +!> path to bathymetry file +!> @warning +!> variable name must be __Bathymetry__ here. +!> +!> - **in_perio1** [@a ]<br/> +!> NEMO periodicity index (see above) +!> @note if the fine/target coordinates file (cn_coord1) was created by SIREN, you do +!> not need to fill this parameter. SIREN will read it on the global attributes of +!> the coordinates file. +!> +!> @subsection subnst namnst +!> the nesting sub-namelist parameters are (default value are specified between brackets): +!> - **in_rhoi** [@a 1]<br/> +!> refinement factor in i-direction +!> +!> - **in_rhoj** [@a 1]<br/> +!> refinement factor in j-direction +!> +!> @note +!> coarse grid indices will be deduced from fine grid +!> coordinate file. +!> +!> @subsection subbdy nambdy +!> the boundary sub-namelist parameters are : +!> +!> - **ln_north** [@a .TRUE.]<br/> +!> logical to use north boundary or not +!> - **ln_south** [@a .TRUE.]<br/> +!> logical to use south boundary or not +!> - **ln_east** [@a .TRUE.]<br/> +!> logical to use east boundary or not +!> - **ln_west** [@a .TRUE.]<br/> +!> logical to use west boundary or not +!> <br/> <br/> +!> - **cn_north** [@a ]<br/> +!> north boundary indices on fine grid<br/> +!> - **cn_south** [@a ]<br/> +!> south boundary indices on fine grid<br/> +!> - **cn_east** [@a ]<br/> +!> east boundary indices on fine grid<br/> +!> - **cn_west** [@a ]<br/> +!> west boundary indices on fine grid<br/> +!> +!> *cn_north* is a string character defining boundary +!> segmentation.<br/> +!> segments are separated by '|'.<br/> +!> each segments of the boundary is composed of: +!> - indice of velocity (orthogonal to boundary .ie. +!> for north boundary, J-indice). +!> - indice of segment start (I-indice for north boundary) +!> - indice of segment end (I-indice for north boundary)<br/> +!> indices must be separated by ':' .<br/> +!> - optionally, boundary size could be added between '(' and ')' +!> in the first segment defined. +!> @note +!> boundary size is the same for all segments of one boundary. +!> +!> Examples: +!> - cn_north='index1,first1:last1(width)' +!> - cn_north='index1(width),first1:last1|index2,first2:last2' +!> +!> @image html boundary_50.png +!> <center>@image latex boundary_50.png +!> </center> +!> +!> - **in_ncrs** [@a 2]<br/> +!> number of point(s) with coarse value save at boundaries +!> +!> - **ln_oneseg** [@a .TRUE.]<br/> +!> logical to use only one segment for each boundary or not +!> +!> @subsection subout namout +!> the output sub-namelist parameter is : +!> +!> - **cn_fileout** [@a bathy_merged.nc]<br/> +!> output bathymetry filename +!> +!> <hr> +!> @author J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date Sepember, 2014 +!> - add header for user +!> @date July, 2015 +!> - extrapolate all land points +!> - add attributes with boundary string character (as in namelist) +!> @date September, 2015 +!> - manage useless (dummy) variable, attributes, and dimension +!> @date October, 2016 +!> - allow to choose the number of boundary point with coarse grid value. +!> - dimension to be used select from configuration file +!> @date January, 2019 +!> - add url path to global attributes of output file(s) +!> @date February, 2019 +!> - rename sub namelist namcrs to namsrc +!> - rename sub namelist namfin to namtgt +!> @date May, 2019 +!> - create and clean file structure to avoid memory leaks +!> @date Ocober, 2019 +!> - add help and version optional arguments +!> +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +PROGRAM merge_bathy + + USE netcdf ! nf90 library + USE global ! global variable + USE phycst ! physical constant + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE date ! date manager + USE att ! attribute manager + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE boundary ! boundary manager + USE iom ! I/O manager + USE grid ! grid manager + USE extrap ! extrapolation manager + USE interp ! interpolation manager + USE filter ! filter manager + USE mpp ! MPP manager + USE dom ! domain manager + USE iom_mpp ! MPP I/O manager + USE iom_dom ! DOM I/O manager + + IMPLICIT NONE + + ! parameters + CHARACTER(LEN=lc), PARAMETER :: cp_myname = "merge_bathy" + + ! local variable + CHARACTER(LEN=lc) :: cl_arg + CHARACTER(LEN=lc) :: cl_namelist + CHARACTER(LEN=lc) :: cl_date + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_url + CHARACTER(LEN=lc) :: cl_errormsg + + INTEGER(i4) :: il_narg + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_attind + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + INTEGER(i4) :: il_shift + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho + INTEGER(i4) , DIMENSION(2,2) :: il_ind + + LOGICAL :: ll_exist + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_refined + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_weight + + TYPE(TMPP) :: tl_bathy0 + TYPE(TMPP) :: tl_bathy1 + + TYPE(TFILE) :: tl_file + TYPE(TFILE) :: tl_fileout + + TYPE(TATT) :: tl_att + + TYPE(TVAR) :: tl_var + TYPE(TVAR) :: tl_lon + TYPE(TVAR) :: tl_lat + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + INTEGER(i4) :: jl + + ! namelist variable + ! namlog + CHARACTER(LEN=lc) :: cn_logfile = 'merge_bathy.log' + CHARACTER(LEN=lc) :: cn_verbosity = 'warning' + INTEGER(i4) :: in_maxerror = 5 + + ! namcfg + CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' + CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg' + CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' + + ! namsrc + CHARACTER(LEN=lc) :: cn_bathy0 = '' + INTEGER(i4) :: in_perio0 = -1 + + ! namtgt + CHARACTER(LEN=lc) :: cn_bathy1 = '' + INTEGER(i4) :: in_perio1 = -1 + +! ! namvar +! CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' + + ! namnst + INTEGER(i4) :: in_rhoi = 1 + INTEGER(i4) :: in_rhoj = 1 + + ! nambdy + LOGICAL :: ln_north = .TRUE. + LOGICAL :: ln_south = .TRUE. + LOGICAL :: ln_east = .TRUE. + LOGICAL :: ln_west = .TRUE. + CHARACTER(LEN=lc) :: cn_north = '' + CHARACTER(LEN=lc) :: cn_south = '' + CHARACTER(LEN=lc) :: cn_east = '' + CHARACTER(LEN=lc) :: cn_west = '' + INTEGER(i4) :: in_ncrs = 2 + LOGICAL :: ln_oneseg= .TRUE. + + ! namout + CHARACTER(LEN=lc) :: cn_fileout = 'bathy_merged.nc' + !------------------------------------------------------------------- + + NAMELIST /namlog/ & !< logger namelist + & cn_logfile, & !< log file + & cn_verbosity, & !< log verbosity + & in_maxerror !< logger maximum error + + NAMELIST /namcfg/ & !< configuration namelist + & cn_varcfg, & !< variable configuration file + & cn_dimcfg, & !< dimension configuration file + & cn_dumcfg !< dummy configuration file + + NAMELIST /namsrc/ & !< source/coarse grid namelist + & cn_bathy0, & !< bathymetry file + & in_perio0 !< periodicity index + + NAMELIST /namtgt/ & !< target/fine grid namelist + & cn_bathy1, & !< bathymetry file + & in_perio1 !< periodicity index + +! NAMELIST /namvar/ & !< variable namelist +! & cn_varinfo !< list of variable and interpolation +! !< method to be used. +! !< (ex: 'votemper|linear','vosaline|cubic' ) + + NAMELIST /namnst/ & !< nesting namelist + & in_rhoi, & !< refinement factor in i-direction + & in_rhoj !< refinement factor in j-direction + + NAMELIST /nambdy/ & !< boundary namelist + & ln_north, & !< use north boundary + & ln_south, & !< use south boundary + & ln_east , & !< use east boundary + & ln_west , & !< use west boundary + & cn_north, & !< north boundary indices on fine grid + & cn_south, & !< south boundary indices on fine grid + & cn_east , & !< east boundary indices on fine grid + & cn_west , & !< west boundary indices on fine grid + & in_ncrs, & !< number of point with coarse value save at boundaries + & ln_oneseg !< use only one segment for each boundary or not + + NAMELIST /namout/ & !< output namelist + & cn_fileout !< fine grid merged bathymetry file + !------------------------------------------------------------------- + + ! + ! Initialisation + ! -------------- + ! + il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec + + ! Traitement des arguments fournis + ! -------------------------------- + IF( il_narg /= 1 )THEN + WRITE(cl_errormsg,*) ' ERROR : one argument is needed ' + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ELSE + + CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec + SELECT CASE (cl_arg) + CASE ('-v', '--version') + + CALL fct_version(cp_myname) + CALL EXIT(0) + + CASE ('-h', '--help') + + CALL fct_help(cp_myname) + CALL EXIT(0) + + CASE DEFAULT + + cl_namelist=cl_arg + + ! read namelist + INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cl_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + ENDIF + + READ( il_fileid, NML = namlog ) + ! define log file + CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) + CALL logger_header() + + READ( il_fileid, NML = namcfg ) + ! get variable extra information + CALL var_def_extra(TRIM(cn_varcfg)) + + ! get dimension allowed + CALL dim_def_extra(TRIM(cn_dimcfg)) + + ! get dummy variable + CALL var_get_dummy(TRIM(cn_dumcfg)) + ! get dummy dimension + CALL dim_get_dummy(TRIM(cn_dumcfg)) + ! get dummy attribute + CALL att_get_dummy(TRIM(cn_dumcfg)) + + READ( il_fileid, NML = namsrc ) + READ( il_fileid, NML = namtgt ) +! READ( il_fileid, NML = namvar ) +! ! add user change in extra information +! CALL var_chg_extra(cn_varinfo) + + READ( il_fileid, NML = namnst ) + READ( il_fileid, NML = nambdy ) + + READ( il_fileid, NML = namout ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("MERGE BATHY: ERROR closing "//TRIM(cl_namelist)) + ENDIF + + ELSE + + WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist) + CALL fct_help(cp_myname,cl_errormsg) + CALL EXIT(1) + + ENDIF + + END SELECT + ENDIF + + ! open files + IF( TRIM(cn_bathy0) /= '' )THEN + tl_file=file_init(TRIM(cn_bathy0)) + tl_bathy0=mpp_init( tl_file, id_perio=in_perio0) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_bathy0) + ELSE + CALL logger_fatal("MERGE BATHY: can not find coarse grid bathymetry "//& + & "file. check namelist") + ENDIF + + IF( TRIM(cn_bathy1) /= '' )THEN + tl_file=file_init(TRIM(cn_bathy1)) + tl_bathy1=mpp_init( tl_file, id_perio=in_perio1) + ! clean + CALL file_clean(tl_file) + CALL grid_get_info(tl_bathy1) + ELSE + CALL logger_fatal("MERGE BATHY: can not find fine grid bathymetry "//& + & "file. check namelist") + ENDIF + + ! check + ! check output file do not already exist + INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist) + IF( ll_exist )THEN + CALL logger_fatal("CREATE BATHY: output file "//TRIM(cn_fileout)//& + & " already exist.") + ENDIF + + ! check namelist + ! check refinament factor + il_rho(:)=1 + IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN + CALL logger_error("MERGE BATHY: invalid refinement factor."//& + & " check namelist "//TRIM(cl_namelist)) + ELSE + il_rho(jp_I)=in_rhoi + il_rho(jp_J)=in_rhoj + ENDIF + + ! check domain indices + ! compute coarse grid indices around fine grid + il_ind(:,:)=grid_get_coarse_index(tl_bathy0, tl_bathy1, & + & id_rho=il_rho(:) ) + + il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2) + il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2) + + ! check domain validity + CALL grid_check_dom(tl_bathy0, il_imin0, il_imax0, il_jmin0, il_jmax0) + + ! check coincidence between coarse and fine grid + CALL grid_check_coincidence( tl_bathy0, tl_bathy1, & + & il_imin0, il_imax0, & + & il_jmin0, il_jmax0, & + & il_rho(:) ) + + ! open mpp files + CALL iom_mpp_open(tl_bathy1) + + ! read or compute boundary + tl_var=iom_mpp_read_var(tl_bathy1,'Bathymetry') + + ! close mpp files + CALL iom_mpp_close(tl_bathy1) + + tl_bdy(:)=boundary_init(tl_var, ln_north, ln_south, ln_east, ln_west, & + & cn_north, cn_south, cn_east, cn_west, & + & ln_oneseg ) + + ! get boundary on coarse grid + ! define refined bathymetry array (for coarse grid) + dl_fill=tl_var%d_fill + ALLOCATE( dl_refined(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & tl_var%t_dim(3)%i_len, & + & tl_var%t_dim(4)%i_len) ) + + dl_refined(:,:,:,:)=dl_fill + + ! define weight array + ALLOCATE( dl_weight(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & 1,1) ) + + dl_weight(:,:,:,:)=dl_fill + + ! compute coarse grid refined bathymetry on boundary. + DO jk=1,ip_ncard + CALL merge_bathy_get_boundary(tl_bathy0, tl_bathy1, tl_bdy(jk), & + & il_rho(:), in_ncrs, & + & dl_refined(:,:,:,:), dl_weight(:,:,:,:), & + & dl_fill) + + ENDDO + + ! merge bathy on boundary + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + WHERE( dl_refined(:,:,jk,jl) /= dl_fill .AND. & + & tl_var%d_value(:,:,jk,jl)/= tl_var%d_fill ) + tl_var%d_value(:,:,jk,jl)= & + & dl_weight(:,:,1,1) * dl_refined(:,:,jk,jl) + & + & (1-dl_weight(:,:,1,1))*tl_var%d_value(:,:,jk,jl) + ELSE WHERE( dl_refined(:,:,jk,jl)== dl_fill .AND. & + & dl_weight(:,:,1,1) /= dl_fill ) + ! to keep coarse grid mask on boundary + tl_var%d_value(:,:,jk,jl)=dl_fill + END WHERE + ENDDO + ENDDO + + DEALLOCATE(dl_refined) + + ! create file + tl_fileout=file_init(TRIM(cn_fileout),id_perio=in_perio1) + + ! add dimension + tl_dim(:)=dim_copy(tl_var%t_dim(:)) + + DO ji=1,ip_maxdim + IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji)) + ENDDO + + ! add variables + IF( ALL( tl_dim(1:2)%l_use ) )THEN + ! open mpp files + CALL iom_mpp_open(tl_bathy1) + + ! add longitude + tl_lon=iom_mpp_read_var(tl_bathy1,'longitude') + CALL file_add_var(tl_fileout, tl_lon) + CALL var_clean(tl_lon) + + ! add latitude + tl_lat=iom_mpp_read_var(tl_bathy1,'latitude') + CALL file_add_var(tl_fileout, tl_lat) + CALL var_clean(tl_lat) + + ! close mpp files + CALL iom_mpp_close(tl_bathy1) + ENDIF + + CALL file_add_var(tl_fileout, tl_var) + CALL var_clean(tl_var) + + ! only 2 first dimension to be used + tl_dim(:)=dim_copy(tl_fileout%t_dim(:)) + tl_dim(3:4)%l_use=.FALSE. + tl_var=var_init('weight',dl_weight(:,:,:,:),td_dim=tl_dim(:),dd_fill=dl_fill) + CALL file_add_var(tl_fileout, tl_var) + CALL var_clean(tl_var) + + ! add some attribute + tl_att=att_init("Created_by","SIREN merge_bathy") + CALL file_add_att(tl_fileout, tl_att) + + !add source url + cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:') + tl_att=att_init("SIREN_url",cl_url) + CALL file_add_att(tl_fileout, tl_att) + + ! add date of creation + cl_date=date_print(date_now()) + tl_att=att_init("Creation_date",cl_date) + CALL file_add_att(tl_fileout, tl_att) + + tl_att=att_init("coarse_grid_source_file",TRIM(fct_basename(tl_bathy0%c_name))) + CALL file_add_att(tl_fileout, tl_att) + + tl_att=att_init("fine_grid_source_file",TRIM(fct_basename(tl_bathy1%c_name))) + CALL file_add_att(tl_fileout, tl_att) + + ! add attribute periodicity + il_attind=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attind=att_get_index(tl_fileout%t_att(:),'periodicity') + ENDIF + IF( tl_bathy1%i_perio >= 0 .AND. il_attind == 0 )THEN + tl_att=att_init('periodicity',tl_bathy1%i_perio) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + + il_attind=0 + IF( ASSOCIATED(tl_fileout%t_att) )THEN + il_attind=att_get_index(tl_fileout%t_att(:),'ew_overlap') + ENDIF + IF( tl_bathy1%i_ew >= 0 .AND. il_attind == 0 )THEN + tl_att=att_init('ew_overlap',tl_bathy1%i_ew) + CALL file_add_att(tl_fileout,tl_att) + ENDIF + + + IF( tl_bdy(jp_north)%l_use )THEN + ! add shift on north boundary + ! boundary compute on T point but express on U or V point + il_shift=1 + + cl_tmp=TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_index-il_shift))//','//& + & TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_last))//& + & '('//TRIM(fct_str(tl_bdy(jp_north)%t_seg(1)%i_width))//')' + DO ji=2,tl_bdy(jp_north)%i_nseg + cl_tmp=TRIM(cl_tmp)//'|'//& + & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_index-il_shift))//','//& + & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_north)%t_seg(ji)%i_last)) + ENDDO + tl_att=att_init("bdy_north",TRIM(cl_tmp)) + CALL file_add_att(tl_fileout, tl_att) + ENDIF + + IF( tl_bdy(jp_south)%l_use )THEN + + cl_tmp=TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_index))//','//& + & TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_last))//& + & '('//TRIM(fct_str(tl_bdy(jp_south)%t_seg(1)%i_width))//')' + DO ji=2,tl_bdy(jp_south)%i_nseg + cl_tmp=TRIM(cl_tmp)//'|'//& + & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_index))//','//& + & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_south)%t_seg(ji)%i_last)) + ENDDO + + tl_att=att_init("bdy_south",TRIM(cl_tmp)) + CALL file_add_att(tl_fileout, tl_att) + ENDIF + + IF( tl_bdy(jp_east)%l_use )THEN + ! add shift on east boundary + ! boundary compute on T point but express on U or V point + il_shift=1 + + cl_tmp=TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_index-il_shift))//','//& + & TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_last))//& + & '('//TRIM(fct_str(tl_bdy(jp_east)%t_seg(1)%i_width))//')' + DO ji=2,tl_bdy(jp_east)%i_nseg + cl_tmp=TRIM(cl_tmp)//'|'//& + & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_index-il_shift))//','//& + & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_east)%t_seg(ji)%i_last)) + ENDDO + + tl_att=att_init("bdy_east",TRIM(cl_tmp)) + CALL file_add_att(tl_fileout, tl_att) + ENDIF + + IF( tl_bdy(jp_west)%l_use )THEN + + cl_tmp=TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_index))//','//& + & TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_last))//& + & '('//TRIM(fct_str(tl_bdy(jp_west)%t_seg(1)%i_width))//')' + DO ji=2,tl_bdy(jp_west)%i_nseg + cl_tmp=TRIM(cl_tmp)//'|'//& + & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_index))//','//& + & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_first))//':'//& + & TRIM(fct_str(tl_bdy(jp_west)%t_seg(ji)%i_last)) + ENDDO + + tl_att=att_init("bdy_west",TRIM(cl_tmp)) + CALL file_add_att(tl_fileout, tl_att) + ENDIF + + ! create file + CALL iom_create(tl_fileout) + + ! write file + CALL iom_write_file(tl_fileout) + + ! close file + CALL iom_close(tl_fileout) + + ! clean + CALL att_clean(tl_att) + CALL file_clean(tl_fileout) + CALL mpp_clean(tl_bathy1) + CALL mpp_clean(tl_bathy0) + DEALLOCATE(dl_weight) + CALL boundary_clean(tl_bdy(:)) + CALL var_clean_extra() + + ! close log file + CALL logger_footer() + CALL logger_close() + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE merge_bathy_get_boundary(td_bathy0, td_bathy1, td_bdy, & + & id_rho, id_ncrs, & + & dd_refined, dd_weight, dd_fill) + !------------------------------------------------------------------- + !> @brief + !> This subroutine compute refined bathymetry on boundary from coarse grid. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_bathy0 coarse grid bathymetry file structure + !> @param[in] td_bathy1 fine grid bathymetry file structure + !> @param[in] td_bdy boundary structure + !> @param[in] id_rho array of refinement factor + !> @param[in] id_ncrs number of point with coarse value save at boundaries + !> @param[inout] dd_refined array of refined bathymetry + !> @param[inout] dd_weight array of weight + !> @param[in] dd_fill fillValue + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN ) :: td_bathy0 + TYPE(TMPP) , INTENT(IN ) :: td_bathy1 + TYPE(TBDY) , INTENT(IN ) :: td_bdy + INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4) , INTENT(IN ) :: id_ncrs + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_refined + REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_weight + REAL(dp) , INTENT(IN ) :: dd_fill + + ! local variable + INTEGER(i4) :: il_imin1 + INTEGER(i4) :: il_imax1 + INTEGER(i4) :: il_jmin1 + INTEGER(i4) :: il_jmax1 + + INTEGER(i4) :: il_imin0 + INTEGER(i4) :: il_imax0 + INTEGER(i4) :: il_jmin0 + INTEGER(i4) :: il_jmax0 + + INTEGER(i4) :: il_width + + INTEGER(i4), DIMENSION(2,2) :: il_offset + INTEGER(i4), DIMENSION(2,2) :: il_ind + + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_tmp1d + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_tmp2d + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_wseg + + TYPE(TVAR) :: tl_var0 + TYPE(TVAR) :: tl_lon1 + TYPE(TVAR) :: tl_lat1 + + TYPE(TMPP) :: tl_bathy1 + TYPE(TMPP) :: tl_bathy0 + + TYPE(TDOM) :: tl_dom1 + TYPE(TDOM) :: tl_dom0 + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( td_bdy%l_use )THEN + DO jl=1,td_bdy%i_nseg + ! get boundary definition + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north') + + il_imin1=td_bdy%t_seg(jl)%i_first + il_imax1=td_bdy%t_seg(jl)%i_last + il_jmin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1) + il_jmax1=td_bdy%t_seg(jl)%i_index + + ! do not used grid point to compute + ! boundaries indices (cf create_boundary) + ! as Bathymetry always on T point + + CASE('south') + + il_imin1=td_bdy%t_seg(jl)%i_first + il_imax1=td_bdy%t_seg(jl)%i_last + il_jmin1=td_bdy%t_seg(jl)%i_index + il_jmax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1) + + CASE('east') + + il_imin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1) + il_imax1=td_bdy%t_seg(jl)%i_index + il_jmin1=td_bdy%t_seg(jl)%i_first + il_jmax1=td_bdy%t_seg(jl)%i_last + + ! do not used grid point to compute + ! boundaries indices (cf create_boundary) + ! as Bathymetry always on T point + + CASE('west') + + il_imin1=td_bdy%t_seg(jl)%i_index + il_imax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1) + il_jmin1=td_bdy%t_seg(jl)%i_first + il_jmax1=td_bdy%t_seg(jl)%i_last + + END SELECT + + ! -read fine grid domain + tl_bathy1=mpp_copy(td_bathy1) + + ! compute domain + tl_dom1=dom_init( tl_bathy1, & + & il_imin1, il_imax1,& + & il_jmin1, il_jmax1,& + & TRIM(td_bdy%c_card)) + + ! add extra band to fine grid domain (if possible) + ! to avoid dimension of one and so be able to compute offset + CALL dom_add_extra(tl_dom1, id_rho(jp_I), id_rho(jp_J)) + + ! open mpp files over domain + CALL iom_dom_open(tl_bathy1, tl_dom1) + + ! read variable value on domain + tl_lon1=iom_dom_read_var(tl_bathy1,'longitude',tl_dom1) + tl_lat1=iom_dom_read_var(tl_bathy1,'latitude' ,tl_dom1) + + ! close mpp files + CALL iom_dom_close(tl_bathy1) + + ! clean structure + CALL mpp_clean(tl_bathy1) + + ! get coarse grid indices + il_ind(:,:)=grid_get_coarse_index(td_bathy0, tl_lon1, tl_lat1, & + & id_rho=id_rho(:)) + + il_imin0=il_ind(1,1) + il_imax0=il_ind(1,2) + + il_jmin0=il_ind(2,1) + il_jmax0=il_ind(2,2) + + ! read coarse grid bathymetry on domain + tl_bathy0=mpp_copy(td_bathy0) + + ! compute domain + tl_dom0=dom_init( tl_bathy0, & + & il_imin0, il_imax0,& + & il_jmin0, il_jmax0 ) + + il_offset(:,:)= grid_get_fine_offset(tl_bathy0, & + & il_imin0, il_jmin0,& + & il_imax0, il_jmax0,& + & tl_lon1%d_value(:,:,1,1), & + & tl_lat1%d_value(:,:,1,1), & + & id_rho=id_rho(:)) + + ! clean + CALL var_clean(tl_lon1) + CALL var_clean(tl_lat1) + + ! add extra band (if possible) to compute interpolation + CALL dom_add_extra(tl_dom0) + + ! open mpp files over domain + CALL iom_dom_open(tl_bathy0, tl_dom0) + + ! read variable value on domain + tl_var0=iom_dom_read_var(tl_bathy0,'Bathymetry',tl_dom0) + + ! force to use nearest interpolation + tl_var0%c_interp(1)='nearest' + + ! close mpp files + CALL iom_dom_close(tl_bathy0) + + ! clean structure + CALL mpp_clean(tl_bathy0) + + ! interpolate variable + CALL merge_bathy_interp( tl_var0, & + & id_rho(:), & + & il_offset(:,:) ) + + ! remove extraband added to domain + CALL dom_del_extra( tl_var0, tl_dom0, id_rho(:) ) + + ! remove extraband added to domain + CALL dom_clean_extra( tl_dom0 ) + + ! remove extraband added to fine grid domain + CALL dom_del_extra( tl_var0, tl_dom1 ) + + ! remove extraband added to fine grid domain + CALL dom_clean_extra( tl_dom1 ) + + ! fill refined array + dd_refined( il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & :,: )= tl_var0%d_value(:,:,:,:) + + ! clean + CALL var_clean(tl_var0) + + ! compute weight function + ALLOCATE( dl_tmp1d(td_bdy%t_seg(jl)%i_width) ) + + SELECT CASE(TRIM(td_bdy%c_card)) + CASE('north') + + + ! save n coarse point + il_width=td_bdy%t_seg(jl)%i_width-id_ncrs + ! compute "distance" + dl_tmp1d(:)=(/(ji,ji=il_width,1,-1),(0,ji=1,id_ncrs)/) + + ! compute weight on segment + dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & + & (il_width) ) + + ALLOCATE( dl_wseg(tl_dom1%t_dim(1)%i_len, & + & tl_dom1%t_dim(2)%i_len) ) + dl_wseg(:,:)=dd_fill + dl_wseg(:,:)=SPREAD( dl_tmp1d(:), & + & DIM=1, & + & NCOPIES=tl_dom1%t_dim(1)%i_len ) + + CASE('south') + + ! save n coarse point + il_width=td_bdy%t_seg(jl)%i_width-id_ncrs + ! compute "distance" + dl_tmp1d(:)=(/(0,ji=1,id_ncrs),(ji,ji=1,il_width)/) + + ! compute weight on segment + dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & + & (il_width) ) + + ALLOCATE( dl_wseg(tl_dom1%t_dim(1)%i_len, & + & tl_dom1%t_dim(2)%i_len) ) + dl_wseg(:,:)=dd_fill + dl_wseg(:,:)=SPREAD( dl_tmp1d(:), & + & DIM=1, & + & NCOPIES=tl_dom1%t_dim(1)%i_len ) + + CASE('east') + + ! save n coarse point + il_width=td_bdy%t_seg(jl)%i_width-id_ncrs + ! compute "distance" + dl_tmp1d(:)=(/(ji,ji=il_width,1,-1),(0,ji=1,id_ncrs)/) + + ! compute weight on segment + dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & + & (il_width) ) + + ALLOCATE( dl_wseg(tl_dom1%t_dim(1)%i_len, & + & tl_dom1%t_dim(2)%i_len) ) + dl_wseg(:,:)=dd_fill + dl_wseg(:,:)=SPREAD( dl_tmp1d(:), & + & DIM=2, & + & NCOPIES=tl_dom1%t_dim(2)%i_len ) + + CASE('west') + + ! save n coarse point + il_width=td_bdy%t_seg(jl)%i_width-id_ncrs + ! compute "distance" + dl_tmp1d(:)=(/(0,ji=1,id_ncrs),(ji,ji=1,il_width)/) + + ! compute weight on segment + dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & + & (il_width) ) + + ALLOCATE( dl_wseg(tl_dom1%t_dim(1)%i_len, & + & tl_dom1%t_dim(2)%i_len) ) + dl_wseg(:,:)=dd_fill + dl_wseg(:,:)=SPREAD( dl_tmp1d(:), & + & DIM=2, & + & NCOPIES=tl_dom1%t_dim(2)%i_len ) + + END SELECT + + DEALLOCATE( dl_tmp1d ) + + ! fill weight array + ALLOCATE( dl_tmp2d( tl_dom1%t_dim(1)%i_len, & + & tl_dom1%t_dim(2)%i_len) ) + + dl_tmp2d(:,:)=dd_weight( il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & 1,1 ) + + WHERE( dl_tmp2d(:,:) == dd_fill ) + dl_tmp2d(:,:)= dl_wseg(:,:) + ELSE WHERE + dl_tmp2d(:,:)= MAX( dl_tmp2d(:,:), dl_wseg(:,:) ) + END WHERE + + dd_weight( il_imin1:il_imax1, & + & il_jmin1:il_jmax1, & + & 1,1 ) = dl_tmp2d(:,:) + + DEALLOCATE( dl_wseg ) + DEALLOCATE( dl_tmp2d ) + + ENDDO + ENDIF + END SUBROUTINE merge_bathy_get_boundary + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE merge_bathy_interp(td_var, id_rho, id_offset, id_iext, id_jext) + !------------------------------------------------------------------- + !> @brief + !> This subroutine interpolate variable. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] id_rho array of refinment factor + !> @param[in] id_offset array of offset between fine and coarse grid + !> @param[in] id_iext i-direction size of extra bands (default=im_minext) + !> @param[in] id_jext j-direction size of extra bands (default=im_minext) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho + INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext + INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext + + ! local variable + TYPE(TVAR) :: tl_mask + + INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask + + INTEGER(i4) :: il_iext + INTEGER(i4) :: il_jext + + ! loop indices + !---------------------------------------------------------------- + + !WARNING: two extrabands are required for cubic interpolation + il_iext=3 + IF( PRESENT(id_iext) ) il_iext=id_iext + + il_jext=3 + IF( PRESENT(id_jext) ) il_jext=id_jext + + IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("MERGE BATHY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_iext=2 + ENDIF + + IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN + CALL logger_warn("MERGE BATHY INTERP: at least extrapolation "//& + & "on two points are required with cubic interpolation ") + il_jext=2 + ENDIF + + ! work on mask + ! create mask + ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len) ) + + bl_mask(:,:,:,:)=1 + WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0 + + SELECT CASE(TRIM(td_var%c_point)) + CASE DEFAULT ! 'T' + tl_mask=var_init('tmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& + & id_ew=td_var%i_ew ) + CASE('U','V','F') + CALL logger_fatal("MERGE BATHY INTERP: can not computed "//& + & "interpolation on "//TRIM(td_var%c_point)//& + & " grid point (variable "//TRIM(td_var%c_name)//& + & "). check namelist.") + END SELECT + + DEALLOCATE(bl_mask) + + ! interpolate mask + CALL interp_fill_value( tl_mask, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! work on variable + ! add extraband + CALL extrap_add_extrabands(td_var, il_iext, il_iext) + + ! extrapolate variable + CALL extrap_fill_value( td_var ) + + ! interpolate Bathymetry + CALL interp_fill_value( td_var, id_rho(:), & + & id_offset=id_offset(:,:) ) + + ! remove extraband + CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) + + ! keep original mask + WHERE( tl_mask%d_value(:,:,:,:) == 0 ) + td_var%d_value(:,:,:,:)=td_var%d_fill + END WHERE + + END SUBROUTINE merge_bathy_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END PROGRAM merge_bathy diff --git a/V4.0/nemo_sources/tools/SIREN/src/mpp.f90 b/V4.0/nemo_sources/tools/SIREN/src/mpp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..33b32057cea339c97e120de39a25d8a9a7a6aaac --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/mpp.f90 @@ -0,0 +1,4450 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage massively parallel processing. +!> +!> @details +!> define type TMPP:<br/> +!> @code +!> TYPE(TMPP) :: tl_mpp +!> @endcode +!> +!> to initialise a mpp structure:<br/> +!> @code +!> tl_mpp=mpp_init( cd_file, id_mask, +!> [id_niproc,] [id_njproc,] [id_nproc,] +!> [id_preci,] [id_precj,] +!> [cd_type,] [id_ew]) +!> @endcode +!> or +!> @code +!> tl_mpp=mpp_init( cd_file, td_var, +!> [id_niproc,] [id_njproc,] [id_nproc,] +!> [id_preci,] [id_precj,] +!> [cd_type] ) +!> @endcode +!> or +!> @code +!> tl_mpp=mpp_init( td_file [,id_ew] ) +!> @endcode +!> - cd_file is the filename of the global domain file, in which +!> MPP will be done (example: Bathymetry) +!> - td_file is the file structure of one processor file composing an MPP +!> - id_mask is the 2D mask of global domain [optional] +!> - td_var is a variable structure (on T-point) from global domain file. +!> mask of the domain will be computed using FillValue [optional] +!> - id_niproc is the number of processor following I-direction to be used +!> [optional] +!> - id_njproc is the number of processor following J-direction to be used +!> [optional] +!> - id_nproc is the total number of processor to be used [optional] +!> - id_preci is the size of the overlap region following I-direction [optional] +!> - id_precj is the size of the overlap region following J-direction [optional] +!> - cd_type is the type of files composing MPP [optional] +!> - id_ew is east-west overlap [optional]<br/> +!> +!> to get mpp name:<br/> +!> - tl_mpp\%c_name +!> +!> to get the total number of processor:<br/> +!> - tl_mpp\%i_nproc +!> +!> to get the number of processor following I-direction:<br/> +!> - tl_mpp\%i_niproc +!> +!> to get the number of processor following J-direction:<br/> +!> - tl_mpp\%i_njproc +!> +!> to get the length of the overlap region following I-direction:<br/> +!> - tl_mpp\%i_preci +!> +!> to get the length of the overlap region following J-direction:<br/> +!> - tl_mpp\%i_precj +!> +!> to get the type of files composing mpp structure:<br/> +!> - tl_mpp\%c_type +!> +!> to get the type of the global domain:<br/> +!> - tl_mpp\%c_dom +!> +!> MPP dimensions (global domain)<br/> +!> to get the number of dimensions to be used in mpp strcuture:<br/> +!> - tl_mpp\%i_ndim +!> +!> to get the array of dimension structure (4 elts) associated to the +!> mpp structure:<br/> +!> - tl_mpp\%t_dim(:) +!> +!> MPP processor (files composing domain)<br/> +!> - tl_mpp\%t_proc(:) +!> +!> to clean a mpp structure:<br/> +!> @code +!> CALL mpp_clean(tl_mpp) +!> @endcode +!> +!> to print information about mpp:<br/> +!> @code +!> CALL mpp_print(tl_mpp) +!> @endcode +!> +!> to add variable to mpp:<br/> +!> @code +!> CALL mpp_add_var(td_mpp, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> to add dimension to mpp:<br/> +!> @code +!> CALL mpp_add_dim(td_mpp, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to add attribute to mpp:<br/> +!> @code +!> CALL mpp_add_att(td_mpp, td_att) +!> @endcode +!> - td_att is a attribute structure +!> +!> to delete variable from mpp:<br/> +!> @code +!> CALL mpp_del_var(td_mpp, td_var) +!> @endcode +!> or +!> @code +!> CALL mpp_del_var(td_mpp, cd_name) +!> @endcode +!> - td_var is a variable structure +!> - cd_name is variable name or standard name +!> +!> to delete dimension from mpp:<br/> +!> @code +!> CALL mpp_del_dim(td_mpp, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to delete attribute from mpp:<br/> +!> @code +!> CALL mpp_del_att(td_mpp, td_att) +!> @endcode +!> or +!> @code +!> CALL mpp_del_att(td_mpp, cd_name) +!> @endcode +!> - td_att is a attribute structure +!> - cd_name is attribute name +!> +!> to overwrite variable to mpp:<br/> +!> @code +!> CALL mpp_move_var(td_mpp, td_var) +!> @endcode +!> - td_var is a variable structure +!> +!> to overwrite dimension to mpp:<br/> +!> @code +!> CALL mpp_move_dim(td_mpp, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to overwrite attribute to mpp:<br/> +!> @code +!> CALL mpp_move_att(td_mpp, td_att) +!> @endcode +!> - td_att is a attribute structure +!> +!> to determine domain decomposition type:<br/> +!> @code +!> CALL mpp_get_dom(td_mpp) +!> @endcode +!> +!> to get processors to be used:<br/> +!> @code +!> CALL mpp_get_use( td_mpp, id_imin, id_imax, & +!> & id_jmin, id_jmax ) +!> @endcode +!> - id_imin +!> - id_imax +!> - id_jmin +!> - id_jmax +!> +!> to get sub domains which form global domain contour:<br/> +!> @code +!> CALL mpp_get_contour( td_mpp ) +!> @endcode +!> +!> to get global domain indices of one processor:<br/> +!> @code +!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid ) +!> @endcode +!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2) +!> - id_procid is the processor id +!> +!> to get the processor domain size:<br/> +!> @code +!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid ) +!> @endcode +!> - il_size(1:2) are the size of domain following I and J +!> - id_procid is the processor id +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date November, 2014 +!> - Fix memory leaks bug +!> @date October, 2015 +!> - improve way to compute domain layout +!> @date January, 2016 +!> - allow to print layout file (use lm_layout, hard coded) +!> - add mpp__compute_halo and mpp__read_halo +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!> +!> @todo +!> - ECRIRE ET TESTER add_proc_array pour optimiser codes (voir old/MO_mpp.f90) +!---------------------------------------------------------------------- +MODULE mpp + + USE global ! global parameter + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE dim ! dimension manager + USE att ! attribute manager + USE var ! variable manager + USE file ! file manager + USE iom ! I/O manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TMPP !< mpp structure + PRIVATE :: TLAY !< domain layout structure + + ! function and subroutine + PUBLIC :: mpp_copy !< copy mpp structure + PUBLIC :: mpp_init !< initialise mpp structure + PUBLIC :: mpp_clean !< clean mpp strcuture + PUBLIC :: mpp_print !< print information about mpp structure + PUBLIC :: mpp_add_var !< split/add one variable strucutre in mpp structure + PUBLIC :: mpp_add_dim !< add one dimension to mpp structure + PUBLIC :: mpp_add_att !< add one attribute strucutre in mpp structure + PUBLIC :: mpp_del_var !< delete one variable strucutre in mpp structure + PUBLIC :: mpp_del_dim !< delete one dimension strucutre in mpp structure + PUBLIC :: mpp_del_att !< delete one attribute strucutre in mpp structure + PUBLIC :: mpp_move_var !< overwrite variable structure in mpp structure + PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure + PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure + PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure + PUBLIC :: mpp_get_index !< return index of mpp + + PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap) + PUBLIC :: mpp_get_use !< get sub domains to be used (which cover "zoom domain") + PUBLIC :: mpp_get_contour !< get sub domains which form global domain contour + PUBLIC :: mpp_get_proc_index !< get processor domain indices + PUBLIC :: mpp_get_proc_size !< get processor domain size + + PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure + PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure + PRIVATE :: mpp__add_proc_arr ! add array of proc strucutre in mpp structure + PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure + PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id + PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure + PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure + PRIVATE :: mpp__create_layout ! create mpp structure using domain layout + PRIVATE :: mpp__optimiz ! compute optimum domain decomposition + PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension + PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension + PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension + PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name + PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure + PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure + PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name + PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure + PRIVATE :: mpp__split_var ! extract variable part that will be written in processor + PRIVATE :: mpp__copy_unit ! copy mpp structure + PRIVATE :: mpp__copy_arr ! copy array of mpp structure + PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain") + PRIVATE :: mpp__init_mask ! initialise mpp structure, given mask array + PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture + PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure + PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file + PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file + PRIVATE :: mpp__clean_unit ! clean mpp strcuture + PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture + PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo + PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo + + PRIVATE :: layout__init ! initialise domain layout structure + PRIVATE :: layout__copy ! clean domain layout structure + PRIVATE :: layout__clean ! copy domain layout structure + + TYPE TMPP !< mpp structure + ! general + CHARACTER(LEN=lc) :: c_name = '' !< base name + INTEGER(i4) :: i_id = 0 !< mpp id + + INTEGER(i4) :: i_niproc = 0 !< number of processors following i + INTEGER(i4) :: i_njproc = 0 !< number of processors following j + INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used + INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length + INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length + INTEGER(i4) :: i_ew = -1 !< east-west overlap + INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index + INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1) + + CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) + CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap) + + INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp + TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension + + TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp + + LOGICAL :: l_usempp = .TRUE. !< use mpp decomposition for writing netcdf + END TYPE + + TYPE TLAY !< domain layout structure + INTEGER(i4) :: i_niproc = 0 !< number of processors following i + INTEGER(i4) :: i_njproc = 0 !< number of processors following j + INTEGER(i4) :: i_nland = 0 !< number of land processors + INTEGER(i4) :: i_nsea = 0 !< number of sea processors + INTEGER(i4) :: i_mean = 0 !< mean sea point per proc + INTEGER(i4) :: i_min = 0 !< min sea point per proc + INTEGER(i4) :: i_max = 0 !< max sea point per proc + INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask + INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom + INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom + INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain + INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain + END TYPE + + ! module variable + INTEGER(i4) :: im_psize = 2000 !< processor dimension length for huge file + + INTEGER(i4) :: im_iumout = 44 + LOGICAL :: lm_layout =.FALSE. + + INTERFACE mpp_get_use + MODULE PROCEDURE mpp__get_use_unit + END INTERFACE mpp_get_use + + INTERFACE mpp__add_proc + MODULE PROCEDURE mpp__add_proc_unit + MODULE PROCEDURE mpp__add_proc_arr + END INTERFACE mpp__add_proc + + INTERFACE mpp_clean + MODULE PROCEDURE mpp__clean_unit + MODULE PROCEDURE mpp__clean_arr + END INTERFACE mpp_clean + + INTERFACE mpp__check_dim + MODULE PROCEDURE mpp__check_proc_dim !< check if processor and mpp structure use same dimension + MODULE PROCEDURE mpp__check_var_dim !< check if variable and mpp structure use same dimension + END INTERFACE mpp__check_dim + + INTERFACE mpp__del_proc + MODULE PROCEDURE mpp__del_proc_id + MODULE PROCEDURE mpp__del_proc_str + END INTERFACE mpp__del_proc + + INTERFACE mpp_del_var + MODULE PROCEDURE mpp__del_var_name + MODULE PROCEDURE mpp__del_var_str + MODULE PROCEDURE mpp__del_var_mpp + END INTERFACE mpp_del_var + + INTERFACE mpp_del_att + MODULE PROCEDURE mpp__del_att_name + MODULE PROCEDURE mpp__del_att_str + END INTERFACE mpp_del_att + + INTERFACE mpp_init + MODULE PROCEDURE mpp__init_mask + MODULE PROCEDURE mpp__init_var + MODULE PROCEDURE mpp__init_file + END INTERFACE mpp_init + + INTERFACE mpp_copy + MODULE PROCEDURE mpp__copy_unit ! copy mpp structure + MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__copy_unit(td_mpp) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy mpp structure in another one + !> @details + !> mpp file are copied in a temporary array, + !> so input and output mpp structure do not point on the same + !> "memory cell", and so on are independant. + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_file=file_copy(file_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + !> @date January, 2019 + !> - clean file structure + !> + !> @param[in] td_mpp mpp structure + !> @return copy of input mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + TYPE(TFILE) :: tl_file + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//& + & TRIM(tf_mpp%c_name)) + + ! copy mpp variable + tf_mpp%c_name = TRIM(td_mpp%c_name) + tf_mpp%i_id = td_mpp%i_id + tf_mpp%i_niproc = td_mpp%i_niproc + tf_mpp%i_njproc = td_mpp%i_njproc + tf_mpp%i_nproc = td_mpp%i_nproc + tf_mpp%i_preci = td_mpp%i_preci + tf_mpp%i_precj = td_mpp%i_precj + tf_mpp%c_type = TRIM(td_mpp%c_type) + tf_mpp%c_dom = TRIM(td_mpp%c_dom) + tf_mpp%i_ndim = td_mpp%i_ndim + tf_mpp%i_ew = td_mpp%i_ew + tf_mpp%i_perio = td_mpp%i_perio + tf_mpp%i_pivot = td_mpp%i_pivot + tf_mpp%l_usempp = td_mpp%l_usempp + + ! copy dimension + tf_mpp%t_dim(:) = dim_copy(td_mpp%t_dim(:)) + + ! copy file structure + IF( ASSOCIATED(tf_mpp%t_proc) )THEN + CALL file_clean(tf_mpp%t_proc(:)) + DEALLOCATE(tf_mpp%t_proc) + ENDIF + IF( ASSOCIATED(td_mpp%t_proc) .AND. tf_mpp%i_nproc > 0 )THEN + ALLOCATE( tf_mpp%t_proc(tf_mpp%i_nproc) ) + DO ji=1,tf_mpp%i_nproc + tl_file = file_copy(td_mpp%t_proc(ji)) + tf_mpp%t_proc(ji) = file_copy(tl_file) + ENDDO + ! clean + CALL file_clean(tl_file) + ENDIF + + END FUNCTION mpp__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__copy_arr(td_mpp) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy an array of mpp structure in another one + !> @details + !> mpp file are copied in a temporary array, + !> so input and output mpp structure do not point on the same + !> "memory cell", and so on are independant. + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_file=file_copy(file_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + !> + !> @param[in] td_mpp mpp structure + !> @return copy of input array of mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp + + ! function + TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: tf_mpp + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_mpp(:)) + tf_mpp(ji)=mpp_copy(td_mpp(ji)) + ENDDO + + END FUNCTION mpp__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_print(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine print some information about mpp strucutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + + ! local variable + INTEGER(i4), PARAMETER :: ip_freq = 4 + INTEGER(i4), PARAMETER :: ip_min = 5 + + INTEGER(i4) :: il_min + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lci + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lcj + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + INTEGER(i4) :: jm + !---------------------------------------------------------------- + + WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')& + & "MPP : ",TRIM(td_mpp%c_name), & + & " type : ",TRIM(td_mpp%c_type), & + & " dom : ",TRIM(td_mpp%c_dom), & + & " nproc : ",td_mpp%i_nproc, & + & " niproc : ",td_mpp%i_niproc, & + & " njproc : ",td_mpp%i_njproc, & + & " preci : ",td_mpp%i_preci, & + & " precj : ",td_mpp%i_precj, & + & " ndim : ",td_mpp%i_ndim, & + & " overlap: ",td_mpp%i_ew, & + & " perio : ",td_mpp%i_perio, & + & " pivot : ",td_mpp%i_pivot + + ! print dimension + IF( td_mpp%i_ndim /= 0 )THEN + WRITE(*,'(/a)') " MPP dimension" + DO ji=1,ip_maxdim + IF( td_mpp%t_dim(ji)%l_use )THEN + CALL dim_print(td_mpp%t_dim(ji)) + ENDIF + ENDDO + ENDIF + + ! print file + IF( td_mpp%i_nproc /= 0 .AND. ASSOCIATED(td_mpp%t_proc) )THEN + IF( ALL( td_mpp%t_proc(:)%i_iind==0 ) .OR. & + & ALL( td_mpp%t_proc(:)%i_jind==0 ) )THEN + + il_min=MIN(td_mpp%i_nproc,ip_min) + DO ji=1,il_min + CALL file_print(td_mpp%t_proc(ji)) + WRITE(*,'((a),(/3x,a,i0),2(/3x,a,a),4(/3x,a,i0,a,i0)/)')& + & " Domain decomposition : ", & + & " id : ",td_mpp%t_proc(ji)%i_pid, & + & " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)), & + & " contour : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_ctr)), & + & " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',& + & td_mpp%t_proc(ji)%i_jmpp, & + & " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',& + & td_mpp%t_proc(ji)%i_lcj, & + & " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,', ',& + & td_mpp%t_proc(ji)%i_ldj, & + & " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',& + & td_mpp%t_proc(ji)%i_lej + + ENDDO + IF( td_mpp%i_nproc > ip_min )THEN + WRITE(*,'(a)') "...etc" + ENDIF + + IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN + WRITE(*,'(/a)') " Variable(s) used : " + DO ji=1,td_mpp%t_proc(1)%i_nvar + WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) + ENDDO + ENDIF + + ELSE + + il_min=MIN(td_mpp%i_nproc,ip_min) + DO ji=1,il_min + CALL file_print(td_mpp%t_proc(ji)) + WRITE(*,'((a, a),(/3x,a,i0),(/3x,a,a),4(/3x,a,i0,a,i0)/)')& + & " Domain decomposition : ",TRIM(td_mpp%t_proc(ji)%c_name),& + & " id : ",td_mpp%t_proc(ji)%i_pid, & + & " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)),& + & " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',& + & td_mpp%t_proc(ji)%i_jmpp, & + & " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',& + & td_mpp%t_proc(ji)%i_lcj, & + & " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,',',& + & td_mpp%t_proc(ji)%i_ldj, & + & " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',& + & td_mpp%t_proc(ji)%i_lej + + ENDDO + IF( td_mpp%i_nproc > ip_min )THEN + WRITE(*,'(a)') "...etc" + ENDIF + + IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN + WRITE(*,'(/a)') " Variable(s) used : " + DO ji=1,td_mpp%t_proc(1)%i_nvar + WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) + ENDDO + ENDIF + + IF( td_mpp%l_usempp )THEN + ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) ) + ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) + ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) + il_proc(:,:)=-1 + il_lci(:,:) =-1 + il_lcj(:,:) =-1 + + DO jk=1,td_mpp%i_nproc + ji=td_mpp%t_proc(jk)%i_iind + jj=td_mpp%t_proc(jk)%i_jind + il_proc(ji,jj)=jk-1 + il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci + il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj + ENDDO + + jl = 1 + DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1 + jm = MIN(td_mpp%i_niproc, jl+ip_freq-1) + WRITE(*,*) + WRITE(*,9401) (ji, ji = jl,jm) + WRITE(*,9400) ('***', ji = jl,jm-1) + DO jj = 1, td_mpp%i_njproc + WRITE(*,9403) (' ', ji = jl,jm-1) + WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm) + WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm) + WRITE(*,9403) (' ', ji = jl,jm-1) + WRITE(*,9400) ('***', ji = jl,jm-1) + ENDDO + jl = jl+ip_freq + ENDDO + + DEALLOCATE( il_proc ) + DEALLOCATE( il_lci ) + DEALLOCATE( il_lcj ) + ENDIF + + ENDIF + ELSE + WRITE(*,'(/a)') " Domain decomposition : none" + ENDIF + +9400 FORMAT(' ***',20('*************',a3)) +9403 FORMAT(' * ',20(' * ',a3)) +9401 FORMAT(' ',20(' ',i3,' ')) +9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) +9404 FORMAT(' * ',20(' ',i3,' * ')) + + END SUBROUTINE mpp_print + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__init_mask(cd_file, id_mask, & + & id_niproc, id_njproc, id_nproc, & + & id_preci, id_precj, & + & cd_type, id_ew, id_perio, id_pivot, & + & td_dim, ld_usempp) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief + !> This function initialise mpp structure, given file name, + !> and optionaly mask and number of processor following I and J + !> @detail + !> - If no total number of processor is defined (id_nproc), optimize + !> the domain decomposition (look for the domain decomposition with + !> the most land processor to remove) + !> - length of the overlap region (id_preci, id_precj) could be specify + !> in I and J direction (default value is 1) + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date September, 2015 + !> - allow to define dimension with array of dimension structure + !> @date January, 2016 + !> - use RESULT to rename output + !> - mismatch with "halo" indices + !> + !> @param[in] cd_file file name of one file composing mpp domain + !> @param[in] id_mask domain mask + !> @param[in] id_niproc number of processors following i + !> @param[in] id_njproc number of processors following j + !> @param[in] id_nproc total number of processors + !> @param[in] id_preci i-direction overlap region + !> @param[in] id_precj j-direction overlap region + !> @param[in] cd_type type of the files (cdf, cdf4, dimg) + !> @param[in] id_ew east-west overlap + !> @param[in] id_perio NEMO periodicity index + !> @param[in] id_pivot NEMO pivot point index F(0),T(1) + !> @param[in] td_dim array of dimension structure + !> @return mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask + INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci + INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type + INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew + INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot + TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim + LOGICAL , INTENT(IN), OPTIONAL :: ld_usempp + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) , DIMENSION(2) :: il_shape + INTEGER(i4) :: il_niproc + INTEGER(i4) :: il_njproc + + TYPE(TDIM) :: tl_dim + + TYPE(TATT) :: tl_att + + TYPE(TLAY) :: tl_lay + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean mpp + CALL mpp_clean(tf_mpp) + + ! check type + cl_type='' + IF( PRESENT(cd_type) ) cl_type=TRIM(ADJUSTL(cd_type)) + + IF( TRIM(cl_type) /= '' )THEN + SELECT CASE(TRIM(cd_type)) + CASE('cdf') + tf_mpp%c_type='cdf' + CASE('dimg') + tf_mpp%c_type='dimg' + CASE DEFAULT + CALL logger_warn("MPP INIT: type "//TRIM(cd_type)//& + & " unknown. type dimg will be used for mpp "//& + & TRIM(tf_mpp%c_name) ) + tf_mpp%c_type='dimg' + END SELECT + ELSE + tf_mpp%c_type=TRIM(file_get_type(cd_file)) + ENDIF + + ! get mpp name + tf_mpp%c_name=TRIM(file_rename(cd_file)) + + ! get global domain dimension + il_shape(:)=SHAPE(id_mask) + + IF( PRESENT(td_dim) )THEN + DO ji=1,ip_maxdim + IF( td_dim(ji)%l_use )THEN + CALL mpp_add_dim(tf_mpp, td_dim(ji)) + ENDIF + ENDDO + ELSE + tl_dim=dim_init('X',il_shape(1)) + CALL mpp_add_dim(tf_mpp, tl_dim) + + tl_dim=dim_init('Y',il_shape(2)) + CALL mpp_add_dim(tf_mpp, tl_dim) + + ! clean + CALL dim_clean(tl_dim) + ENDIF + + IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & + ((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN + CALL logger_warn( "MPP INIT: number of processors following I and J "//& + & "should be both specified") + ELSE + ! get number of processors following I and J + IF( PRESENT(id_niproc) ) tf_mpp%i_niproc=id_niproc + IF( PRESENT(id_njproc) ) tf_mpp%i_njproc=id_njproc + ENDIF + + ! get maximum number of processors to be used + IF( PRESENT(id_nproc) ) tf_mpp%i_nproc = id_nproc + + ! get overlap region length + IF( PRESENT(id_preci) ) tf_mpp%i_preci= id_preci + IF( PRESENT(id_precj) ) tf_mpp%i_precj= id_precj + + ! east-west overlap + IF( PRESENT(id_ew) ) tf_mpp%i_ew= id_ew + ! NEMO periodicity + IF( PRESENT(id_perio) ) tf_mpp%i_perio= id_perio + IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot + ! + IF( PRESENT(ld_usempp) ) tf_mpp%l_usempp = ld_usempp + + IF( tf_mpp%i_nproc /= 0 .AND. & + & tf_mpp%i_niproc /= 0 .AND. & + & tf_mpp%i_njproc /= 0 .AND. & + & tf_mpp%i_nproc > tf_mpp%i_niproc * tf_mpp%i_njproc )THEN + + CALL logger_error("MPP INIT: invalid domain decomposition ") + CALL logger_debug("MPP INIT: "// & + & TRIM(fct_str(tf_mpp%i_nproc))//" > "//& + & TRIM(fct_str(tf_mpp%i_niproc))//" x "//& + & TRIM(fct_str(tf_mpp%i_njproc)) ) + + ELSE + IF( lm_layout )THEN + OPEN(im_iumout,FILE='processor.layout') + WRITE(im_iumout,*) + WRITE(im_iumout,*) ' optimisation de la partition' + WRITE(im_iumout,*) ' ----------------------------' + WRITE(im_iumout,*) + ENDIF + + IF( tf_mpp%i_niproc /= 0 .AND. tf_mpp%i_njproc /= 0 .AND. & + &(tf_mpp%i_niproc > 1 .OR. tf_mpp%i_njproc > 1) )THEN + + ! compute domain layout + tl_lay=layout__init(tf_mpp, id_mask, & + & tf_mpp%i_niproc, tf_mpp%i_njproc) + ! create mpp domain layout + CALL mpp__create_layout( tf_mpp, tl_lay ) + + ! clean + CALL layout__clean( tl_lay ) + + ELSEIF( tf_mpp%i_nproc > 1 )THEN + + ! optimiz + CALL mpp__optimiz( tf_mpp, id_mask, tf_mpp%i_nproc ) + + ELSE + + CALL logger_warn("MPP INIT: number of processor to be used "//& + & "not specify. force output on one file.") + ! number of proc to get proc size close to im_psize + il_niproc=INT(il_shape(jp_I)/im_psize)+1 + il_njproc=INT(il_shape(jp_J)/im_psize)+1 + + tf_mpp%l_usempp=.FALSE. + tl_lay=layout__init( tf_mpp, id_mask, & + & il_niproc, il_njproc ) + + ! create mpp domain layout + CALL mpp__create_layout( tf_mpp, tl_lay ) + + ! clean + CALL layout__clean( tl_lay ) + + ENDIF + + CALL logger_info("MPP INIT: domain decoposition : "//& + & 'niproc('//TRIM(fct_str(tf_mpp%i_niproc))//') * '//& + & 'njproc('//TRIM(fct_str(tf_mpp%i_njproc))//') = '//& + & 'nproc('//TRIM(fct_str(tf_mpp%i_nproc))//')' ) + + ! get domain type + CALL mpp_get_dom( tf_mpp ) + + DO ji=1,tf_mpp%i_nproc + + ! get processor size + il_shape(:)=mpp_get_proc_size( tf_mpp, ji ) + + tl_dim=dim_init('X',il_shape(1)) + CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim) + + tl_dim=dim_init('Y',il_shape(2)) + CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim) + + IF( PRESENT(td_dim) )THEN + IF( td_dim(jp_K)%l_use )THEN + CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_K)) + ENDIF + IF( td_dim(jp_L)%l_use )THEN + CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_L)) + ENDIF + ENDIF + ! add type + tf_mpp%t_proc(ji)%c_type=TRIM(tf_mpp%c_type) + + ! clean + CALL dim_clean(tl_dim) + + ENDDO + + ! add global attribute + tl_att=att_init("DOMAIN_number_total",tf_mpp%i_nproc) + CALL mpp_add_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_LOCAL",TRIM(tf_mpp%c_dom)) + CALL mpp_add_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_I_number_total",tf_mpp%i_niproc) + CALL mpp_add_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_J_number_total",tf_mpp%i_njproc) + CALL mpp_add_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_size_global",tf_mpp%t_dim(1:2)%i_len) + CALL mpp_add_att(tf_mpp, tl_att) + + CALL mpp__compute_halo(tf_mpp) + ENDIF + + END FUNCTION mpp__init_mask + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__init_var(cd_file, td_var, & + & id_niproc, id_njproc, id_nproc,& + & id_preci, id_precj, cd_type, & + & id_perio, id_pivot, ld_usempp) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief + !> This function initialise mpp structure, given variable strcuture + !> and optionaly number of processor following I and J + !> @detail + !> - If no total number of processor is defined (id_nproc), optimize + !> the domain decomposition (look for the domain decomposition with + !> the most land processor to remove) + !> - length of the overlap region (id_preci, id_precj) could be specify + !> in I and J direction (default value is 1) + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[in] cd_file file name of one file composing mpp domain + !> @param[in] td_var variable structure + !> @param[in] id_niproc number of processors following i + !> @param[in] id_njproc number of processors following j + !> @param[in] id_nproc total number of processors + !> @param[in] id_preci i-direction overlap region + !> @param[in] id_precj j-direction overlap region + !> @param[in] cd_type type of the files (cdf, cdf4, dimg) + !> @param[in] id_perio NEMO periodicity index + !> @param[in] id_pivot NEMO pivot point index F(0),T(1) + !> @return mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + TYPE(TVAR), INTENT(IN) :: td_var + INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc + INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci + INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type + INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot + LOGICAL, INTENT(IN), OPTIONAL :: ld_usempp + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + ALLOCATE( il_mask(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len) ) + il_mask(:,:,:)=var_get_mask(td_var) + + CALL logger_info("MPP INIT: mask compute from variable "//& + & TRIM(td_var%c_name)) + tf_mpp = mpp_init( cd_file, il_mask(:,:,1), & + & id_niproc, id_njproc, id_nproc,& + & id_preci, id_precj, cd_type, & + & id_ew=td_var%i_ew, & + & id_perio=id_perio, id_pivot=id_pivot,& + & ld_usempp=ld_usempp) + + DEALLOCATE(il_mask) + ELSE + CALL logger_error("MPP INIT: variable value not define.") + ENDIF + + END FUNCTION mpp__init_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__init_file(td_file, id_ew, id_perio, id_pivot) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief This function initalise a mpp structure given file structure. + !> @details + !> It reads restart dimg files, or some netcdf files. + !> + !> @warning + !> netcdf file must contains some attributes: + !> - DOMAIN_number_total + !> - DOMAIN_size_global + !> - DOMAIN_number + !> - DOMAIN_position_first + !> - DOMAIN_position_last + !> - DOMAIN_halo_size_start + !> - DOMAIN_halo_size_end + !> or the file is assume to be no mpp file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2016 + !> - mismatch with "halo" indices, use mpp__compute_halo + !> @date Marsh, 2017 + !> - netcdf proc indices from zero to N-1 + !> - copy file periodicity to mpp structure + !> @date August, 2017 + !> - force to use domain decomposition to enhance read of monoproc file + !> + !> @param[in] td_file file strcuture + !> @param[in] id_ew east-west overlap + !> @param[in] id_perio NEMO periodicity index + !> @param[in] id_pivot NEMO pivot point index F(0),T(1) + !> @return mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew + INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio + INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + INTEGER(i4) :: il_nproc + INTEGER(i4) :: il_attid + INTEGER(i4), DIMENSION(2) :: il_shape + + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask + INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim + INTEGER(i4) :: il_niproc + INTEGER(i4) :: il_njproc + + TYPE(TDIM) :: tl_dim + + TYPE(TATT) :: tl_att + + TYPE(TFILE) :: tl_file + + TYPE(TMPP) :: tl_mpp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean mpp + CALL mpp_clean(tf_mpp) + + ! check file type + SELECT CASE( TRIM(td_file%c_type) ) + CASE('cdf') + ! need to read all file to get domain decomposition + tl_file=file_copy(td_file) + + ! open file + CALL iom_open(tl_file) + + ! read first file domain decomposition + tl_mpp=mpp__init_file_cdf(tl_file) + + ! get number of processor/file to be read + il_nproc = 1 + il_attid = 0 + + IF( ASSOCIATED(tl_file%t_att) )THEN + il_attid=att_get_id( tl_file%t_att, "DOMAIN_number_total" ) + ENDIF + IF( il_attid /= 0 )THEN + il_nproc = INT(tl_file%t_att(il_attid)%d_value(1)) + ENDIF + + ! close file + CALL iom_close(tl_file) + + IF( il_nproc /= 1 )THEN + DO ji=1,il_nproc + + ! clean mpp strcuture + CALL mpp_clean(tl_mpp) + + ! get filename (from 0 to n-1) + tl_file=file_rename(td_file,ji-1) + + ! open file + CALL iom_open(tl_file) + + ! read domain decomposition + tl_mpp = mpp__init_file_cdf(tl_file) + IF( ji == 1 )THEN + tf_mpp=mpp_copy(tl_mpp) + ELSE + IF( ANY( tf_mpp%t_dim(1:2)%i_len /= & + tl_mpp%t_dim(1:2)%i_len) )THEN + + CALL logger_error("MPP INIT READ: dimension from file "//& + & TRIM(tl_file%c_name)//" and mpp strcuture "//& + & TRIM(tf_mpp%c_name)//"differ ") + + ELSE + + ! add processor to mpp strcuture + CALL mpp__add_proc(tf_mpp, tl_mpp%t_proc(1)) + + ENDIF + ENDIF + + ! close file + CALL iom_close(tl_file) + + ENDDO + IF( tf_mpp%i_nproc /= il_nproc )THEN + CALL logger_error("MPP INIT READ: some processors can't be added & + & to mpp structure") + ENDIF + + ELSE + + ! force to use domain decomposition to enhance read of input + + ! create pseudo mask + il_dim(:)=tl_mpp%t_dim(:)%i_len + ALLOCATE(il_mask(il_dim(jp_I),il_dim(jp_J))) + il_mask(:,:)=1 + + ! number of proc to get proc size close to im_psize + il_niproc=INT(il_dim(jp_I)/im_psize)+1 + il_njproc=INT(il_dim(jp_J)/im_psize)+1 + + ! compute domain layout + ! output will be written on one file + tf_mpp=mpp_init(tl_mpp%c_name, il_mask, il_niproc, il_njproc,& + & id_perio=tl_file%i_perio, & + & ld_usempp=.FALSE. ) + + ! add var + DO ji=1,tl_mpp%t_proc(1)%i_nvar + CALL mpp_add_var(tf_mpp, tl_mpp%t_proc(1)%t_var(ji)) + ENDDO + + ENDIF + + ! mpp type + tf_mpp%c_type=TRIM(td_file%c_type) + + ! mpp domain type + CALL mpp_get_dom(tf_mpp) + + ! create some attributes for domain decomposition (use with dimg file) + tl_att=att_init( "DOMAIN_number_total", tf_mpp%i_nproc ) + CALL mpp_move_att(tf_mpp, tl_att) + + CALL mpp__compute_halo(tf_mpp) + + ! clean + CALL mpp_clean(tl_mpp) + CALL att_clean(tl_att) + + CASE('dimg') + ! domain decomposition could be read in one file + + tl_file=file_copy(td_file) + ! open file + CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name)) + CALL iom_open(tl_file) + + CALL logger_debug("MPP INIT READ: read mpp structure ") + ! read mpp structure + tf_mpp=mpp__init_file_rstdimg(tl_file) + + ! mpp type + tf_mpp%c_type=TRIM(td_file%c_type) + + ! mpp domain type + CALL logger_debug("MPP INIT READ: mpp_get_dom ") + CALL mpp_get_dom(tf_mpp) + + ! get processor size + CALL logger_debug("MPP INIT READ: get processor size ") + DO ji=1,tf_mpp%i_nproc + + il_shape(:)=mpp_get_proc_size( tf_mpp, ji ) + + tl_dim=dim_init('X',il_shape(1)) + CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim) + + tl_dim=dim_init('Y',il_shape(2)) + CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim) + + ! clean + CALL dim_clean(tl_dim) + + ENDDO + + ! close file + CALL iom_close(tl_file) + + CASE DEFAULT + CALL logger_error("MPP INIT READ: invalid type for file "//& + & TRIM(tl_file%c_name)) + END SELECT + + ! east west overlap + IF( PRESENT(id_ew) ) tf_mpp%i_ew=id_ew + ! NEMO periodicity + IF( PRESENT(id_perio) )THEN + tf_mpp%i_perio= id_perio + SELECT CASE(id_perio) + CASE(3,4) + tf_mpp%i_pivot=1 + CASE(5,6) + tf_mpp%i_pivot=0 + CASE DEFAULT + tf_mpp%i_pivot=1 + END SELECT + ENDIF + + IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot + + ! clean + CALL file_clean(tl_file) + + END FUNCTION mpp__init_file + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__init_file_cdf(td_file) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief This function initalise a mpp structure, + !> reading some netcdf files. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - add only use dimension in MPP structure + !> @date January, 2016 + !> - mismatch with "halo" indices, use mpp__read_halo + !> + !> @param[in] td_file file strcuture + !> @return mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + INTEGER(i4) :: il_attid ! attribute id + + LOGICAL :: ll_exist + LOGICAL :: ll_open + + TYPE(TATT) :: tl_att + + TYPE(TDIM) :: tl_dim + + TYPE(TFILE) :: tl_proc + !---------------------------------------------------------------- + + CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)) + + INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open ) + ! ll_open do not work for netcdf file, return always FALSE + IF( ll_exist )THEN + + IF( td_file%i_id == 0 )THEN + CALL logger_info(" id "//TRIM(fct_str(td_file%i_id))) + CALL logger_error("MPP INIT READ: netcdf file "//& + & TRIM(td_file%c_name)//" not opened") + ELSE + + ! get mpp name + tf_mpp%c_name=TRIM( file_rename(td_file%c_name) ) + + ! add type + tf_mpp%c_type="cdf" + + ! global domain size + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_size_global" ) + ENDIF + IF( il_attid /= 0 )THEN + tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1))) + CALL mpp_add_dim(tf_mpp,tl_dim) + + tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2))) + CALL mpp_add_dim(tf_mpp,tl_dim) + ELSE ! assume only one file (not mpp) + tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len) + CALL mpp_add_dim(tf_mpp,tl_dim) + + tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len) + CALL mpp_add_dim(tf_mpp,tl_dim) + ENDIF + + IF( td_file%t_dim(3)%l_use )THEN + tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len) + CALL mpp_add_dim(tf_mpp,tl_dim) + ENDIF + + IF( td_file%t_dim(4)%l_use )THEN + tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len) + CALL mpp_add_dim(tf_mpp,tl_dim) + ENDIF + + ! initialise file/processor + tl_proc=file_copy(td_file) + + ! processor id + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_number" ) + ENDIF + IF( il_attid /= 0 )THEN + tl_proc%i_pid = INT(td_file%t_att(il_attid)%d_value(1)) + ELSE + tl_proc%i_pid = 1 + ENDIF + + ! processor dimension + tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) + + CALL mpp__read_halo(tl_proc, tf_mpp%t_dim(:) ) + + ! add attributes + tl_att=att_init( "DOMAIN_size_global", tf_mpp%t_dim(:)%i_len) + CALL file_move_att(tl_proc, tl_att) + + tl_att=att_init( "DOMAIN_number", tl_proc%i_pid ) + CALL file_move_att(tl_proc, tl_att) + + ! add processor to mpp structure + CALL mpp__add_proc(tf_mpp, tl_proc) + + ! clean + CALL file_clean(tl_proc) + CALL dim_clean(tl_dim) + CALL att_clean(tl_att) + ENDIF + + ELSE + + CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//& + & " do not exist") + + ENDIF + + END FUNCTION mpp__init_file_cdf + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__init_file_rstdimg(td_file) & + & RESULT(tf_mpp) + !------------------------------------------------------------------- + !> @brief This function initalise a mpp structure, + !> reading one dimg restart file. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2016 + !> - mismatch with "halo" indices, use mpp__compute_halo + !> @date January,2019 + !> - clean file structure + !> + !> @param[in] td_file file strcuture + !> @return mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE), INTENT(IN) :: td_file + + ! function + TYPE(TMPP) :: tf_mpp + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_recl ! record length + INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension + INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables + INTEGER(i4) :: il_iglo, il_jglo ! domain global size + INTEGER(i4) :: il_rhd ! record of the header infos + INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition + INTEGER(i4) :: il_area ! domain index + + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp + + LOGICAL :: ll_exist + LOGICAL :: ll_open + + CHARACTER(LEN=lc) :: cl_file + + TYPE(TDIM) :: tl_dim ! dimension structure + TYPE(TATT) :: tl_att + TYPE(TFILE) :: tl_proc + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open) + IF( ll_exist )THEN + + IF( .NOT. ll_open )THEN + CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//& + & " not opened") + ELSE + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=1 )& + & il_recl, & + & il_nx, il_ny, il_nz, & + & il_n0d, il_n1d, il_n2d, il_n3d, & + & il_rhd, & + & il_pni, il_pnj, il_pnij, & + & il_area + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("MPP INIT READ: read first line header of "//& + & TRIM(td_file%c_name)) + ENDIF + + ! get mpp name + tf_mpp%c_name=TRIM( file_rename(td_file%c_name) ) + + ! add type + tf_mpp%c_type="dimg" + + ! number of processors to be read + tf_mpp%i_nproc = il_pnij + tf_mpp%i_niproc = il_pni + tf_mpp%i_njproc = il_pnj + + IF( ASSOCIATED(tf_mpp%t_proc) )THEN + CALL file_clean(tf_mpp%t_proc(:)) + DEALLOCATE(tf_mpp%t_proc) + ENDIF + ALLOCATE( tf_mpp%t_proc(il_pnij) , stat=il_status ) + + ALLOCATE(il_lci (il_pnij)) + ALLOCATE(il_lcj (il_pnij)) + ALLOCATE(il_ldi (il_pnij)) + ALLOCATE(il_ldj (il_pnij)) + ALLOCATE(il_lei (il_pnij)) + ALLOCATE(il_lej (il_pnij)) + ALLOCATE(il_impp(il_pnij)) + ALLOCATE(il_jmpp(il_pnij)) + + tl_proc=file_copy(td_file) + ! remove dimension from file + CALL dim_clean(tl_proc%t_dim(:)) + ! initialise file/processors + DO ji=1,tf_mpp%i_nproc + tf_mpp%t_proc(ji)=file_copy(tl_proc) + ENDDO + + IF( il_status /= 0 )THEN + CALL logger_error("MPP INIT READ: not enough space to read domain & + & decomposition in file "//TRIM(td_file%c_name)) + ENDIF + + ! read first record + READ( td_file%i_id, IOSTAT=il_status, REC=1 )& + & il_recl, & + & il_nx, il_ny, il_nz, & + & il_n0d, il_n1d, il_n2d, il_n3d, & + & il_rhd, & + & il_pni, il_pnj, il_pnij, & + & il_area, & + & il_iglo, il_jglo, & + & il_lci(1:il_pnij), & + & il_lcj(1:il_pnij), & + & il_ldi(1:il_pnij), & + & il_ldj(1:il_pnij), & + & il_lei(1:il_pnij), & + & il_lej(1:il_pnij), & + & il_impp(1:il_pnij), & + & il_jmpp(1:il_pnij) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("MPP INIT READ: read first line of "//& + & TRIM(td_file%c_name)) + ENDIF + + tf_mpp%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) + tf_mpp%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij) + + DEALLOCATE(il_lci) + DEALLOCATE(il_lcj) + DEALLOCATE(il_ldi) + DEALLOCATE(il_ldj) + DEALLOCATE(il_lei) + DEALLOCATE(il_lej) + DEALLOCATE(il_impp) + DEALLOCATE(il_jmpp) + + ! global domain size + tl_dim=dim_init('X',il_iglo) + CALL mpp_add_dim(tf_mpp,tl_dim) + tl_dim=dim_init('Y',il_jglo) + CALL mpp_add_dim(tf_mpp,tl_dim) + + tl_dim=dim_init('Z',il_nz) + CALL mpp_add_dim(tf_mpp,tl_dim) + + DO ji=1,tf_mpp%i_nproc + + ! get file name + cl_file = file_rename(td_file%c_name,ji) + tf_mpp%t_proc(ji)%c_name = TRIM(cl_file) + ! update processor id + tf_mpp%t_proc(ji)%i_pid=ji + + ! add attributes + tl_att=att_init( "DOMAIN_number", ji ) + CALL file_move_att(tf_mpp%t_proc(ji), tl_att) + + ENDDO + + ! add type + tf_mpp%t_proc(:)%c_type="dimg" + + ! add attributes + tl_att=att_init("DOMAIN_size_global", tf_mpp%t_dim(:)%i_len) + CALL mpp_move_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_number_total", tf_mpp%i_nproc) + CALL mpp_move_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_I_number_total", tf_mpp%i_niproc) + CALL mpp_move_att(tf_mpp, tl_att) + + tl_att=att_init("DOMAIN_J_number_total", tf_mpp%i_njproc) + CALL mpp_move_att(tf_mpp, tl_att) + + CALL mpp_get_dom( tf_mpp ) + + CALL mpp__compute_halo( tf_mpp ) + + ! clean + CALL dim_clean(tl_dim) + CALL att_clean(tl_att) + CALL file_clean(tl_proc) + ENDIF + + ELSE + + CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//& + & " do not exist") + + ENDIF + + END FUNCTION mpp__init_file_rstdimg + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__check_proc_dim(td_mpp, td_proc) & + & RESULT(lf_check) + !------------------------------------------------------------------- + !> @brief This function check if variable and mpp structure use same + !> dimension. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[in] td_proc processor structure + !> @return dimension of processor and mpp structure agree (or not) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TFILE), INTENT(IN) :: td_proc + + !function + LOGICAL :: lf_check + + ! local variable + INTEGER(i4) :: il_isize !< i-direction maximum sub domain size + INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size + !---------------------------------------------------------------- + + lf_check=.TRUE. + ! check used dimension + IF( td_mpp%i_niproc /= 0 .AND. td_mpp%i_njproc /= 0 )THEN + ! check with maximum size of sub domain + il_isize = ( td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + & + & (td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci + il_jsize = ( td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + & + & (td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj + + IF( il_isize < td_proc%i_lci .OR. & + &il_jsize < td_proc%i_lcj )THEN + + lf_check=.FALSE. + + CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) + + ENDIF + + ELSE + ! check with global domain size + IF( td_mpp%t_dim(1)%i_len < td_proc%i_lci .OR. & + &td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN + + lf_check=.FALSE. + + CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) + + ENDIF + ENDIF + + END FUNCTION mpp__check_proc_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_add_var(td_mpp, td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add variable in all files of mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date January, 2019 + !> - do not split variable on domain decomposition, if only one procesor + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_var variable strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_var + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( "MPP ADD VAR: processor decomposition not "//& + & "define for mpp "//TRIM(td_mpp%c_name)) + + ELSE + ! check if variable exist + IF( TRIM(td_var%c_name) == '' .AND. & + & TRIM(td_var%c_stdname) == '' )THEN + CALL logger_error("MPP ADD VAR: variable not define ") + ELSE + ! check if variable already in mpp structure + il_varid=0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN + il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & + & td_var%c_name, td_var%c_stdname ) + ENDIF + + IF( il_varid /= 0 )THEN + + DO ji=1,td_mpp%t_proc(1)%i_nvar + CALL logger_debug( " MPP ADD VAR: in mpp structure : & + & variable "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//& + & ", standard name "//& + & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) ) + ENDDO + CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//& + & ", standard name "//TRIM(td_var%c_stdname)//& + & ", already in mpp "//TRIM(td_mpp%c_name) ) + + ELSE + + CALL logger_info( & + & " MPP ADD VAR: add variable "//TRIM(td_var%c_name)//& + & ", standard name "//TRIM(td_var%c_stdname)//& + & ", in mpp "//TRIM(td_mpp%c_name) ) + ! check used dimension + IF( mpp__check_dim(td_mpp, td_var) )THEN + + ! check variable dimension expected + CALL var_check_dim(td_var) + + ! update dimension if need be + DO ji=1,ip_maxdim + IF( td_var%t_dim(ji)%l_use .AND. & + & .NOT. td_mpp%t_dim(ji)%l_use )THEN + CALL mpp_add_dim(td_mpp,td_var%t_dim(ji)) + ENDIF + ENDDO + + ! add variable in each processor + IF( td_mpp%i_nproc == 1 )THEN + CALL file_add_var(td_mpp%t_proc(1), td_var) + ELSE + DO ji=1,td_mpp%i_nproc + ! split variable on domain decomposition + tl_var=mpp__split_var(td_mpp, td_var, ji) + + CALL file_add_var(td_mpp%t_proc(ji), tl_var) + + ! clean + CALL var_clean(tl_var) + ENDDO + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF + + END SUBROUTINE mpp_add_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__split_var(td_mpp, td_var, id_procid) & + & RESULT(tf_var) + !------------------------------------------------------------------- + !> @brief This function extract, from variable structure, part that will + !> be written in processor id_procid.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_mpp mpp structure + !> @param[in] td_var variable structure + !> @param[in] id_procid processor id + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TVAR), INTENT(IN) :: td_var + INTEGER(i4), INTENT(IN) :: id_procid + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TDIM) :: tl_dim + + INTEGER(i4), DIMENSION(4) :: il_ind + INTEGER(i4), DIMENSION(2) :: il_size + INTEGER(i4) :: il_i1 + INTEGER(i4) :: il_i2 + INTEGER(i4) :: il_j1 + INTEGER(i4) :: il_j2 + !---------------------------------------------------------------- + + ! copy mpp + tf_var=var_copy(td_var, ld_value=.FALSE.) + + ! get processor indices + il_ind(:)=mpp_get_proc_index( td_mpp, id_procid ) + il_i1 = il_ind(1) + il_i2 = il_ind(2) + il_j1 = il_ind(3) + il_j2 = il_ind(4) + + IF( .NOT. td_var%t_dim(1)%l_use )THEN + il_i1=1 + il_i2=1 + ENDIF + + IF( .NOT. td_var%t_dim(2)%l_use )THEN + il_j1=1 + il_j2=1 + ENDIF + + IF( ASSOCIATED(td_var%d_value) )THEN + ! remove value over global domain from pointer + !CALL var_del_value( tf_var ) + + ! get processor dimension + il_size(:)=mpp_get_proc_size( td_mpp, id_procid ) + + ! define new dimension in variable structure + IF( td_var%t_dim(1)%l_use )THEN + tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) ) + CALL var_move_dim( tf_var, tl_dim ) + ENDIF + IF( td_var%t_dim(2)%l_use )THEN + tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) ) + CALL var_move_dim( tf_var, tl_dim ) + ENDIF + + ! add variable value on processor + CALL var_add_value( tf_var, & + & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) + + ELSE + + tf_var%t_dim(jp_I)%i_len=il_i2-il_i1+1 + tf_var%t_dim(jp_J)%i_len=il_j2-il_j1+1 + + ENDIF + + END FUNCTION mpp__split_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_var_mpp(td_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete all variable in mpp strcuture. + !> + !> @author J.Paul + !> @date October, 2014 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + CALL logger_info( & + & "MPP CLEAN VAR: reset all variable "//& + & "in mpp strcuture "//TRIM(td_mpp%c_name) ) + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + DO ji=td_mpp%t_proc(1)%i_nvar,1,-1 + CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji)) + ENDDO + ENDIF + + END SUBROUTINE mpp__del_var_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_var_str(td_mpp, td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete variable in mpp structure, given variable + !> structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_var variable strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TVAR), INTENT(IN) :: td_var + + ! local variable + INTEGER(i4) :: il_varid + CHARACTER(LEN=lc) :: cl_name + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( "MPP DEL VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + ! check if variable already in mpp structure + il_varid = 0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN + il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & + & td_var%c_name, td_var%c_stdname ) + ENDIF + IF( il_varid == 0 )THEN + CALL logger_error( & + & "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//& + & ", in mpp structure "//TRIM(td_mpp%c_name) ) + + DO ji=1,td_mpp%t_proc(1)%i_nvar + CALL logger_debug( "MPP DEL VAR: in mpp structure : & + & variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//& + & ", standard name "//& + & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) ) + ENDDO + + ELSE + + cl_name=TRIM(td_var%c_name) + DO ji=1,td_mpp%i_nproc + CALL file_del_var(td_mpp%t_proc(ji), TRIM(cl_name)) + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE mpp__del_var_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_var_name(td_mpp, cd_name) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete variable in mpp structure, given variable name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date February, 2015 + !> - define local variable structure to avoid mistake with pointer + !> @date January, 2019 + !> - clean variable strcuture + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] cd_name variable name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + + ! local variable + INTEGER(i4) :: il_varid + TYPE(TVAR) :: tl_var + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( "MPP DEL VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN + CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp & + & structure "//TRIM(td_mpp%c_name) ) + ELSE + + ! get the variable id, in file variable structure + il_varid=0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN + il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & + & cd_name ) + ENDIF + + IF( il_varid == 0 )THEN + + CALL logger_warn( & + & "MPP DEL VAR : there is no variable with name "//& + & "or standard name "//TRIM(ADJUSTL(cd_name))//& + & " in mpp structure "//TRIM(td_mpp%c_name)) + + ELSE + + tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) + CALL mpp_del_var(td_mpp, tl_var) + ! clean + CALL var_clean(tl_var) + ENDIF + ENDIF + ENDIF + + END SUBROUTINE mpp__del_var_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_move_var(td_mpp, td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine overwrite variable in mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TVAR), INTENT(IN) :: td_var + + !local variable + TYPE(TVAR) :: tl_var + !---------------------------------------------------------------- + + ! copy variablie + tl_var=var_copy(td_var) + + ! remove processor + CALL mpp_del_var(td_mpp, tl_var) + + ! add processor + CALL mpp_add_var(td_mpp, tl_var) + + ! clean + CALL var_clean(tl_var) + + END SUBROUTINE mpp_move_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__add_proc_unit(td_mpp, td_proc) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add processor to mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date January, 2019 + !> - deallocate file structure whatever happens + ! + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_proc processor strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + TYPE(TFILE), INTENT(IN) :: td_proc + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_procid + INTEGER(i4) , DIMENSION(1) :: il_ind + + TYPE(TFILE) , DIMENSION(:), ALLOCATABLE :: tl_proc + + CHARACTER(LEN=lc) :: cl_name + !---------------------------------------------------------------- + + ! check file name + cl_name=TRIM( file_rename(td_proc%c_name) ) + IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN + CALL logger_warn("MPP ADD PROC: processor name do not match mpp name") + ENDIF + + il_procid=0 + IF( ASSOCIATED(td_mpp%t_proc) )THEN + ! check if processor already in mpp structure + il_ind(:)=MINLOC( td_mpp%t_proc(:)%i_pid, & + mask=(td_mpp%t_proc(:)%i_pid==td_proc%i_pid) ) + il_procid=il_ind(1) + ENDIF + + IF( il_procid /= 0 )THEN + + CALL logger_error( & + & "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//& + & ", already in mpp structure " ) + + ELSE + + CALL logger_trace("MPP ADD PROC: add processor "//& + & TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure") + + IF( td_mpp%i_nproc > 0 )THEN + ! + il_ind(:)=MAXLOC( td_mpp%t_proc(:)%i_pid, & + mask=(td_mpp%t_proc(:)%i_pid < td_proc%i_pid) ) + il_procid=il_ind(1) + + ! already other processor in mpp structure + ALLOCATE( tl_proc(td_mpp%i_nproc), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( "MPP ADD PROC: not enough space to put processor & + & in mpp structure") + + ELSE + ! save temporary mpp structure + tl_proc(:)=file_copy(td_mpp%t_proc(:)) + + CALL file_clean( td_mpp%t_proc(:) ) + DEALLOCATE(td_mpp%t_proc) + ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( "MPP ADD PROC: not enough space to put "//& + & "processor in mpp structure ") + + ENDIF + + ! copy processor in mpp before + ! processor with lower id than new processor + td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid )) + + ! processor with greater id than new processor + td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = & + & file_copy(tl_proc( il_procid : td_mpp%i_nproc )) + + ! clean + CALL file_clean(tl_proc(:)) + ENDIF + DEALLOCATE(tl_proc) + + ELSE + + ! no processor in mpp structure + IF( ASSOCIATED(td_mpp%t_proc) )THEN + CALL file_clean(td_mpp%t_proc(:)) + DEALLOCATE(td_mpp%t_proc) + ENDIF + ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( "MPP ADD PROC: not enough space to put "//& + & "processor in mpp structure " ) + + ENDIF + ENDIF + + ! check dimension + IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN + CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//& + & " dimension differ. ") + CALL logger_debug("MPP ADD PROC: mpp dimension ("//& + & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" ) + CALL logger_debug("MPP ADD PROC: processor dimension ("//& + & TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" ) + ELSE + td_mpp%i_nproc=td_mpp%i_nproc+1 + + ! add new processor + td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc) + ENDIF + + ENDIF + + END SUBROUTINE mpp__add_proc_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__add_proc_arr(td_mpp, td_proc) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add array of processor to mpp structure. + !> @note mpp structure should be empty + !> + !> @author J.Paul + !> @date August, 2017 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_proc array of processor strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_proc + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_nproc + + CHARACTER(LEN=lc) :: cl_name + !---------------------------------------------------------------- + + ! check file name + cl_name=TRIM( file_rename(td_proc(1)%c_name) ) + IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN + CALL logger_warn("MPP ADD PROC: processor name do not match mpp name") + ENDIF + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + CALL logger_error( & + & "MPP ADD PROC: some processor(s) already in mpp structure " ) + + ELSE + + CALL logger_trace("MPP ADD PROC: add array of processor "//& + & " in mpp structure") + + il_nproc=SIZE(td_proc) + ALLOCATE( td_mpp%t_proc(il_nproc), stat=il_status ) + IF(il_status /= 0 )THEN + CALL logger_error( "MPP ADD PROC: not enough space to put "//& + & "processor in mpp structure " ) + ENDIF + + ! check dimension + IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc(1)%t_dim(1:2)%i_len) )THEN + CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//& + & " dimension differ. ") + CALL logger_debug("MPP ADD PROC: mpp dimension ("//& + & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" ) + CALL logger_debug("MPP ADD PROC: processor dimension ("//& + & TRIM(fct_str(td_proc(1)%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_proc(1)%t_dim(2)%i_len))//")" ) + ELSE + td_mpp%i_nproc=il_nproc + + ! add new processor + td_mpp%t_proc(:)=file_copy(td_proc(:)) + ENDIF + + ENDIF + + END SUBROUTINE mpp__add_proc_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_proc_id(td_mpp, id_procid) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete processor in mpp structure, given processor id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date January, 2019 + !> - clean file structure + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] id_procid processor id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + INTEGER(i4), INTENT(IN) :: id_procid + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_procid + INTEGER(i4), DIMENSION(1) :: il_ind + TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc + + ! loop indices + !---------------------------------------------------------------- + + il_ind(:)=MINLOC(td_mpp%t_proc(:)%i_pid,td_mpp%t_proc(:)%i_pid==id_procid) + il_procid=il_ind(1) + IF( il_procid == 0 )THEN + CALL logger_error("MPP DEL PROC: no processor "//& + & TRIM(fct_str(id_procid))//& + & " associated to mpp structure") + ELSE + CALL logger_trace("DEL PROC: remove processor "//& + & TRIM(fct_str(id_procid))) + + IF( td_mpp%i_nproc > 1 )THEN + ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status ) + IF(il_status /= 0 )THEN + CALL logger_error( "MPP DEL PROC: not enough space to put & + & processor in temporary mpp structure") + + ELSE + + ! save temporary processor's mpp structure + IF( il_procid > 1 )THEN + tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1)) + ENDIF + + IF( il_procid < td_mpp%i_nproc )THEN + tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:)) + ENDIF + + ! new number of processor in mpp + td_mpp%i_nproc=td_mpp%i_nproc-1 + + CALL file_clean( td_mpp%t_proc(:) ) + DEALLOCATE(td_mpp%t_proc) + ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( "MPP DEL PROC: not enough space & + & to put processors in mpp structure " ) + + ELSE + + ! copy processor in mpp before + td_mpp%t_proc(:)=file_copy(tl_proc(:)) + + ! update processor id + td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid = & + & td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid - 1 + + ENDIF + ENDIF + ! clean + CALL file_clean( tl_proc(:) ) + DEALLOCATE(tl_proc) + ELSE + CALL file_clean( td_mpp%t_proc(:) ) + DEALLOCATE(td_mpp%t_proc) + + ! new number of processor in mpp + td_mpp%i_nproc=td_mpp%i_nproc-1 + ENDIF + ENDIF + + END SUBROUTINE mpp__del_proc_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_proc_str(td_mpp, td_proc) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete processor in mpp structure, given processor + !> structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp : mpp strcuture + !> @param[in] td_proc : file/processor structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TFILE), INTENT(IN) :: td_proc + !---------------------------------------------------------------- + + IF( td_proc%i_pid >= 0 )THEN + CALL mpp__del_proc( td_mpp, td_proc%i_pid ) + ELSE + CALL logger_error("MPP DEL PROC: processor not defined") + ENDIF + + END SUBROUTINE mpp__del_proc_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__move_proc(td_mpp, td_proc) + !------------------------------------------------------------------- + !> @brief + !> This subroutine overwrite processor in mpp structure. + !> + !> @detail + !> + !> @author J.Paul + !> @date Nov, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] id_procid processor id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TFILE), INTENT(IN) :: td_proc + !---------------------------------------------------------------- + + ! remove processor + CALL mpp__del_proc(td_mpp, td_proc) + + ! add processor + CALL mpp__add_proc(td_mpp, td_proc) + + END SUBROUTINE mpp__move_proc + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_add_dim(td_mpp, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine add a dimension structure in a mpp + !> structure. + !> Do not overwrite, if dimension already in mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - rewrite the same as way var_add_dim + !> + !> @param[inout] td_mpp mpp structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TDIM), INTENT(IN) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + + ! loop indices + !---------------------------------------------------------------- + + IF( td_mpp%i_ndim <= ip_maxdim )THEN + + ! check if dimension already used in mpp structure + il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) + IF( il_ind == 0 )THEN + CALL logger_warn( & + & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", will not be added in mpp "//TRIM(td_mpp%c_name) ) + ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN + CALL logger_error( & + & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", already used in mpp "//TRIM(td_mpp%c_name) ) + ELSE + + ! back to disorder dimension array + CALL dim_disorder(td_mpp%t_dim(:)) + + ! add new dimension + td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim) + + ! update number of attribute + td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) + + ENDIF + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_mpp%t_dim(:)) + + ELSE + CALL logger_error( & + & "MPP ADD DIM: too much dimension in mpp "//& + & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") + ENDIF + + END SUBROUTINE mpp_add_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_del_dim(td_mpp, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine delete a dimension structure in a mpp + !> structure.<br/> + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - rewrite the same as way var_del_dim + !> + !> @param[inout] td_mpp mpp structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TDIM), INTENT(IN) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + TYPE(TDIM) :: tl_dim + + ! loop indices + !---------------------------------------------------------------- + + IF( td_mpp%i_ndim <= ip_maxdim )THEN + + CALL logger_trace( & + & " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", in mpp "//TRIM(td_mpp%c_name) ) + + ! check if dimension already in variable structure + il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) + + ! replace dimension by empty one + td_mpp%t_dim(il_ind)=dim_copy(tl_dim) + + ! update number of dimension + td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) + + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_mpp%t_dim) + + ELSE + CALL logger_error( & + & " MPP DEL DIM: too much dimension in mpp "//& + & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") + ENDIF + + END SUBROUTINE mpp_del_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_move_dim(td_mpp, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine move a dimension structure + !> in mpp structure. + !> @warning dimension order may have changed + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_mpp mpp structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TDIM), INTENT(IN) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_dimid + !---------------------------------------------------------------- + + IF( td_mpp%i_ndim <= ip_maxdim )THEN + + ! check if dimension already in mpp structure + il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) + IF( il_ind /= 0 )THEN + + il_dimid=td_mpp%t_dim(il_ind)%i_id + ! replace dimension + td_mpp%t_dim(il_ind)=dim_copy(td_dim) + td_mpp%t_dim(il_ind)%i_id=il_dimid + td_mpp%t_dim(il_ind)%l_use=.TRUE. + + ELSE + CALL mpp_add_dim(td_mpp, td_dim) + ENDIF + + ELSE + CALL logger_error( & + & "MPP MOVE DIM: too much dimension in mpp "//& + & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") + ENDIF + + END SUBROUTINE mpp_move_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_add_att(td_mpp, td_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add global attribute to mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_att attribute strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_attid + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_error( "MPP ADD ATT: domain decomposition not define "//& + & "for mpp "//TRIM(td_mpp%c_name)) + + ELSE + ! check if variable exist + IF( TRIM(td_att%c_name) == '' )THEN + CALL logger_error("MPP ADD ATT: attribute not define ") + ELSE + ! check if attribute already in mpp structure + il_attid=0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN + il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), & + & td_att%c_name ) + ENDIF + IF( il_attid /= 0 )THEN + + CALL logger_error( " MPP ADD ATT: attribute "//& + & TRIM(td_att%c_name)//& + & ", already in mpp "//TRIM(td_mpp%c_name) ) + + DO ji=1,td_mpp%t_proc(1)%i_natt + CALL logger_debug( " MPP ADD ATT: in mpp structure : & + & attribute "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) ) + ENDDO + + ELSE + + CALL logger_info( & + & " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//& + & ", in mpp "//TRIM(td_mpp%c_name) ) + + ! add attribute in each processor + DO ji=1,td_mpp%i_nproc + + CALL file_add_att(td_mpp%t_proc(ji), td_att) + + ENDDO + + ENDIF + ENDIF + ENDIF + + END SUBROUTINE mpp_add_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_att_str(td_mpp, td_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete attribute in mpp structure, given attribute + !> structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_att attribute strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_attid + CHARACTER(LEN=lc) :: cl_name + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + ! check if attribute already in mpp structure + il_attid=0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN + il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), & + & td_att%c_name ) + ENDIF + IF( il_attid == 0 )THEN + CALL logger_warn( & + & "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//& + & ", in mpp structure "//TRIM(td_mpp%c_name) ) + + IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN + DO ji=1,td_mpp%t_proc(1)%i_natt + CALL logger_debug( "MPP DEL ATT: in mpp structure : & + & attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) ) + ENDDO + ENDIF + + ELSE + + cl_name=TRIM(td_att%c_name) + CALL logger_debug( "MPP DEL ATT: delete in mpp structure : & + & attribute : "//TRIM(cl_name) ) + DO ji=1,td_mpp%i_nproc + CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name)) + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE mpp__del_att_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__del_att_name(td_mpp, cd_name) + !------------------------------------------------------------------- + !> @brief + !> This subroutine delete attribute in mpp structure, given attribute name. + !> + !> @detail + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date February, 2015 + !> - define local attribute structure to avoid mistake with pointer + !> @date January, 2019 + !> - clean attributes structure + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] cd_name attribute name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + CHARACTER(LEN=*) , INTENT(IN ) :: cd_name + + ! local variable + INTEGER(i4) :: il_attid + TYPE(TATT) :: tl_att + !---------------------------------------------------------------- + + ! check if mpp exist + IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN + + CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//& + & " in mpp strcuture "//TRIM(td_mpp%c_name)) + + ELSE + + IF( td_mpp%t_proc(1)%i_natt == 0 )THEN + CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp & + & structure "//TRIM(td_mpp%c_name) ) + ELSE + + ! get the attribute id, in file variable structure + il_attid=0 + IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN + il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), & + & cd_name ) + ENDIF + + IF( il_attid == 0 )THEN + + CALL logger_debug( & + & "MPP DEL ATT : there is no attribute with "//& + & "name "//TRIM(cd_name)//" in mpp structure "//& + & TRIM(td_mpp%c_name)) + + ELSE + + tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid)) + CALL mpp_del_att(td_mpp, tl_att) + ! clean + CALL att_clean(tl_att) + ENDIF + ENDIF + ENDIF + + END SUBROUTINE mpp__del_att_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_move_att(td_mpp, td_att) + !------------------------------------------------------------------- + !> @brief + !> This subroutine overwrite attribute in mpp structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TATT), INTENT(IN) :: td_att + + !local variable + TYPE(TATT) :: tl_att + !---------------------------------------------------------------- + + ! copy variable + tl_att=att_copy(td_att) + + ! remove processor + CALL mpp_del_att(td_mpp, tl_att) + + ! add processor + CALL mpp_add_att(td_mpp, tl_att) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE mpp_move_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION layout__init(td_mpp, id_mask, id_niproc, id_njproc) & + & RESULT(tf_lay) + !------------------------------------------------------------------- + !> @brief + !> This function initialise domain layout + !> + !> @detail + !> Domain layout is first computed, with domain dimension, overlap between subdomain, + !> and the number of processors following I and J. + !> Then the number of sea/land processors is compute with mask + !> + !> @author J.Paul + !> @date October, 2015 - Initial version + !> @date October, 2016 + !> - compare index to tf_lay number of proc instead of td_mpp (bug fix) + !> + !> @param[in] td_mpp mpp strcuture + !> @param[in] id_mask sub domain mask (sea=1, land=0) + !> @pâram[in] id_niproc number of processors following I + !> @pâram[in] id_njproc number of processors following J + !> @return domain layout structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask + INTEGER(i4) , INTENT(IN) :: id_niproc + INTEGER(i4) , INTENT(IN) :: id_njproc + + ! function + TYPE(TLAY) :: tf_lay + + ! local variable + INTEGER(i4) :: ii1, ii2 + INTEGER(i4) :: ij1, ij2 + + INTEGER(i4) :: il_ldi + INTEGER(i4) :: il_ldj + INTEGER(i4) :: il_lei + INTEGER(i4) :: il_lej + + INTEGER(i4) :: il_isize !< i-direction maximum sub domain size + INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size + INTEGER(i4) :: il_resti !< + INTEGER(i4) :: il_restj !< + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! intialise + tf_lay%i_niproc=id_niproc + tf_lay%i_njproc=id_njproc + + CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& + & TRIM(fct_str(tf_lay%i_niproc))//" x "//& + & TRIM(fct_str(tf_lay%i_njproc))//" processors") + + ! maximum size of sub domain + il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (tf_lay%i_niproc-1))/ & + & tf_lay%i_niproc) + 2*td_mpp%i_preci + il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (tf_lay%i_njproc-1))/ & + & tf_lay%i_njproc) + 2*td_mpp%i_precj + + il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, tf_lay%i_niproc) + il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, tf_lay%i_njproc) + IF( il_resti == 0 ) il_resti = tf_lay%i_niproc + IF( il_restj == 0 ) il_restj = tf_lay%i_njproc + + ! compute dimension of each sub domain + ALLOCATE( tf_lay%i_lci(tf_lay%i_niproc,tf_lay%i_njproc) ) + ALLOCATE( tf_lay%i_lcj(tf_lay%i_niproc,tf_lay%i_njproc) ) + + tf_lay%i_lci( 1 : il_resti , : ) = il_isize + tf_lay%i_lci( il_resti+1 : tf_lay%i_niproc, : ) = il_isize-1 + + tf_lay%i_lcj( : , 1 : il_restj ) = il_jsize + tf_lay%i_lcj( : , il_restj+1 : tf_lay%i_njproc) = il_jsize-1 + + ! compute first index of each sub domain + ALLOCATE( tf_lay%i_impp(tf_lay%i_niproc,tf_lay%i_njproc) ) + ALLOCATE( tf_lay%i_jmpp(tf_lay%i_niproc,tf_lay%i_njproc) ) + + tf_lay%i_impp(:,:)=1 + tf_lay%i_jmpp(:,:)=1 + + IF( tf_lay%i_niproc > 1 )THEN + DO jj=1,tf_lay%i_njproc + DO ji=2,tf_lay%i_niproc + tf_lay%i_impp(ji,jj) = tf_lay%i_impp(ji-1,jj) + & + & tf_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci + ENDDO + ENDDO + ENDIF + + IF( tf_lay%i_njproc > 1 )THEN + DO jj=2,tf_lay%i_njproc + DO ji=1,tf_lay%i_niproc + tf_lay%i_jmpp(ji,jj) = tf_lay%i_jmpp(ji,jj-1) + & + & tf_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj + ENDDO + ENDDO + ENDIF + + ALLOCATE( tf_lay%i_msk(tf_lay%i_niproc,tf_lay%i_njproc) ) + tf_lay%i_msk(:,:)=0 + ! init number of sea/land proc + tf_lay%i_nsea=0 + tf_lay%i_nland=tf_lay%i_njproc*tf_lay%i_niproc + + ! check if processor is land or sea + DO jj = 1,tf_lay%i_njproc + DO ji = 1,tf_lay%i_niproc + + ! compute first and last indoor indices + ! west boundary + IF( ji == 1 )THEN + il_ldi = 1 + ELSE + il_ldi = 1 + td_mpp%i_preci + ENDIF + + ! south boundary + IF( jj == 1 )THEN + il_ldj = 1 + ELSE + il_ldj = 1 + td_mpp%i_precj + ENDIF + + ! east boundary + IF( ji == tf_lay%i_niproc )THEN + il_lei = tf_lay%i_lci(ji,jj) + ELSE + il_lei = tf_lay%i_lci(ji,jj) - td_mpp%i_preci + ENDIF + + ! north boundary + IF( jj == tf_lay%i_njproc )THEN + il_lej = tf_lay%i_lcj(ji,jj) + ELSE + il_lej = tf_lay%i_lcj(ji,jj) - td_mpp%i_precj + ENDIF + + ii1=tf_lay%i_impp(ji,jj) + il_ldi - 1 + ii2=tf_lay%i_impp(ji,jj) + il_lei - 1 + + ij1=tf_lay%i_jmpp(ji,jj) + il_ldj - 1 + ij2=tf_lay%i_jmpp(ji,jj) + il_lej - 1 + + tf_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) + IF( tf_lay%i_msk(ji,jj) > 0 )THEN ! sea + tf_lay%i_nsea =tf_lay%i_nsea +1 + tf_lay%i_nland=tf_lay%i_nland-1 + ENDIF + + ENDDO + ENDDO + + CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(tf_lay%i_nsea))) + CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(tf_lay%i_nland))) + CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(tf_lay%i_msk(:,:))))) + + tf_lay%i_mean= SUM(tf_lay%i_msk(:,:)) / tf_lay%i_nsea + tf_lay%i_min = MINVAL(tf_lay%i_msk(:,:),tf_lay%i_msk(:,:)/=0) + tf_lay%i_max = MAXVAL(tf_lay%i_msk(:,:)) + + IF( lm_layout )THEN + ! print info + WRITE(im_iumout,*) ' ' + WRITE(im_iumout,*) " jpni=",tf_lay%i_niproc ," jpnj=",tf_lay%i_njproc + WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize + WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj + + + WRITE(im_iumout,*) ' nombre de processeurs ',tf_lay%i_niproc*tf_lay%i_njproc + WRITE(im_iumout,*) ' nombre de processeurs mer ',tf_lay%i_nsea + WRITE(im_iumout,*) ' nombre de processeurs terre ',tf_lay%i_nland + WRITE(im_iumout,*) ' moyenne de recouvrement ',tf_lay%i_mean + WRITE(im_iumout,*) ' minimum de recouvrement ',tf_lay%i_min + WRITE(im_iumout,*) ' maximum de recouvrement ',tf_lay%i_max + ENDIF + + END FUNCTION layout__init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE layout__clean(td_lay) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean domain layout strcuture. + !> + !> @author J.Paul + !> @date October, 2015 - Initial version + !> @date January, 2019 + !> - nullify array in layout structure + !> + !> @param[inout] td_lay domain layout strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TLAY), INTENT(INOUT) :: td_lay + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_lay%i_msk) )THEN + DEALLOCATE(td_lay%i_msk) + NULLIFY(td_lay%i_msk) + ENDIF + IF( ASSOCIATED(td_lay%i_impp) )THEN + DEALLOCATE(td_lay%i_impp) + NULLIFY(td_lay%i_impp) + ENDIF + IF( ASSOCIATED(td_lay%i_jmpp) )THEN + DEALLOCATE(td_lay%i_jmpp) + NULLIFY(td_lay%i_jmpp) + ENDIF + IF( ASSOCIATED(td_lay%i_lci) )THEN + DEALLOCATE(td_lay%i_lci) + NULLIFY(td_lay%i_lci) + ENDIF + IF( ASSOCIATED(td_lay%i_lcj) )THEN + DEALLOCATE(td_lay%i_lcj) + NULLIFY(td_lay%i_lcj) + ENDIF + + td_lay%i_niproc=0 + td_lay%i_njproc=0 + td_lay%i_nland =0 + td_lay%i_nsea =0 + + td_lay%i_mean =0 + td_lay%i_min =0 + td_lay%i_max =0 + + END SUBROUTINE layout__clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION layout__copy(td_lay) & + & RESULT(tf_lay) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy domain layout structure in another one. + !> + !> @warning do not use on the output of a function who create or read a + !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date October, 2015 - Initial Version + !> + !> @param[in] td_lay domain layout structure + !> @return copy of input domain layout structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TLAY), INTENT(IN) :: td_lay + ! function + TYPE(TLAY) :: tf_lay + + ! local variable + INTEGER(i4), DIMENSION(2) :: il_shape + INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp + ! loop indices + !---------------------------------------------------------------- + + ! copy scalar + tf_lay%i_niproc = td_lay%i_niproc + tf_lay%i_njproc = td_lay%i_njproc + tf_lay%i_nland = td_lay%i_nland + tf_lay%i_nsea = td_lay%i_nsea + tf_lay%i_mean = td_lay%i_mean + tf_lay%i_min = td_lay%i_min + tf_lay%i_max = td_lay%i_max + + ! copy pointers + IF( ASSOCIATED(tf_lay%i_msk) )THEN + DEALLOCATE(tf_lay%i_msk) + ENDIF + IF( ASSOCIATED(td_lay%i_msk) )THEN + il_shape(:)=SHAPE(td_lay%i_msk(:,:)) + ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_msk(:,:)=td_lay%i_msk(:,:) + ENDIF + + IF( ASSOCIATED(tf_lay%i_msk) ) DEALLOCATE(tf_lay%i_msk) + IF( ASSOCIATED(td_lay%i_msk) )THEN + il_shape(:)=SHAPE(td_lay%i_msk(:,:)) + ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) + il_tmp(:,:)=td_lay%i_msk(:,:) + + ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_msk(:,:)=il_tmp(:,:) + + DEALLOCATE(il_tmp) + ENDIF + + IF( ASSOCIATED(tf_lay%i_impp) ) DEALLOCATE(tf_lay%i_impp) + IF( ASSOCIATED(td_lay%i_impp) )THEN + il_shape(:)=SHAPE(td_lay%i_impp(:,:)) + ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) + il_tmp(:,:)=td_lay%i_impp(:,:) + + ALLOCATE( tf_lay%i_impp(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_impp(:,:)=il_tmp(:,:) + + DEALLOCATE(il_tmp) + ENDIF + + IF( ASSOCIATED(tf_lay%i_jmpp) ) DEALLOCATE(tf_lay%i_jmpp) + IF( ASSOCIATED(td_lay%i_jmpp) )THEN + il_shape(:)=SHAPE(td_lay%i_jmpp(:,:)) + ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) + il_tmp(:,:)=td_lay%i_jmpp(:,:) + + ALLOCATE( tf_lay%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_jmpp(:,:)=il_tmp(:,:) + + DEALLOCATE(il_tmp) + ENDIF + + IF( ASSOCIATED(tf_lay%i_lci) ) DEALLOCATE(tf_lay%i_lci) + IF( ASSOCIATED(td_lay%i_lci) )THEN + il_shape(:)=SHAPE(td_lay%i_lci(:,:)) + ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) + il_tmp(:,:)=td_lay%i_lci(:,:) + + ALLOCATE( tf_lay%i_lci(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_lci(:,:)=il_tmp(:,:) + + DEALLOCATE(il_tmp) + ENDIF + + IF( ASSOCIATED(tf_lay%i_lcj) ) DEALLOCATE(tf_lay%i_lcj) + IF( ASSOCIATED(td_lay%i_lcj) )THEN + il_shape(:)=SHAPE(td_lay%i_lcj(:,:)) + ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) + il_tmp(:,:)=td_lay%i_lcj(:,:) + + ALLOCATE( tf_lay%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) + tf_lay%i_lcj(:,:)=il_tmp(:,:) + + DEALLOCATE(il_tmp) + ENDIF + + END FUNCTION layout__copy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__create_layout(td_mpp, td_lay) + !------------------------------------------------------------------- + !> @brief + !> This subroutine create mpp structure using domain layout + !> + !> @detail + !> + !> @author J.Paul + !> @date October, 2015 - Initial version + !> @date August, 2017 + !> - handle use of domain decomposition for monoproc file + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] td_lay domain layout structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + TYPE(TLAY), INTENT(IN ) :: td_lay + + ! local variable + CHARACTER(LEN=lc) :: cl_file + TYPE(TATT) :: tl_att + + TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! intialise + td_mpp%i_nproc=0 + + CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//& + & TRIM(fct_str(td_lay%i_niproc))//" x "//& + & TRIM(fct_str(td_lay%i_njproc))//" = "//& + & TRIM(fct_str(td_lay%i_nsea))//" processors") + + IF( lm_layout )THEN + WRITE(im_iumout,*) ' choix optimum' + WRITE(im_iumout,*) ' =============' + WRITE(im_iumout,*) + ! print info + WRITE(im_iumout,*) ' ' + WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc + WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj + + + WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc + WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea + WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland + WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean + WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min + WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max + ENDIF + + td_mpp%i_niproc=td_lay%i_niproc + td_mpp%i_njproc=td_lay%i_njproc + !td_mpp%i_nproc =td_lay%i_nsea + + IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN + IF( td_lay%i_nsea == 1 )THEN + td_mpp%c_dom='full' + ELSE + td_mpp%c_dom='nooverlap' + ENDIF + ELSE + td_mpp%c_dom='noextra' + ENDIF + + ALLOCATE(tl_proc(td_lay%i_nsea)) + jk=1 + DO jj=1,td_lay%i_njproc + DO ji=1,td_lay%i_niproc + + IF( td_lay%i_msk(ji,jj) >= 1 )THEN + + ! get processor file name + IF( td_mpp%l_usempp )THEN + cl_file=file_rename(td_mpp%c_name,jk) + ELSE + cl_file=TRIM(td_mpp%c_name) + ENDIF + ! initialise file structure + tl_proc(jk)=file_init(cl_file,td_mpp%c_type) + + ! procesor id + tl_proc(jk)%i_pid=jk-1 + + tl_att=att_init("DOMAIN_number",tl_proc(jk)%i_pid) + CALL file_add_att(tl_proc(jk), tl_att) + + ! processor indices + tl_proc(jk)%i_iind=ji + tl_proc(jk)%i_jind=jj + + ! fill processor dimension and first indices + tl_proc(jk)%i_impp = td_lay%i_impp(ji,jj) + tl_proc(jk)%i_jmpp = td_lay%i_jmpp(ji,jj) + + tl_proc(jk)%i_lci = td_lay%i_lci(ji,jj) + tl_proc(jk)%i_lcj = td_lay%i_lcj(ji,jj) + + ! compute first and last indoor indices + + ! west boundary + IF( ji == 1 )THEN + tl_proc(jk)%i_ldi = 1 + tl_proc(jk)%l_ctr = .TRUE. + ELSE + tl_proc(jk)%i_ldi = 1 + td_mpp%i_preci + ENDIF + + ! south boundary + IF( jj == 1 )THEN + tl_proc(jk)%i_ldj = 1 + tl_proc(jk)%l_ctr = .TRUE. + ELSE + tl_proc(jk)%i_ldj = 1 + td_mpp%i_precj + ENDIF + + ! east boundary + IF( ji == td_mpp%i_niproc )THEN + tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) + tl_proc(jk)%l_ctr = .TRUE. + ELSE + tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci + ENDIF + + ! north boundary + IF( jj == td_mpp%i_njproc )THEN + tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) + tl_proc(jk)%l_ctr = .TRUE. + ELSE + tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj + ENDIF + + ! clean + CALL att_clean(tl_att) + + ! update proc number + jk=jk+1 + + ENDIF + ENDDO + ENDDO +! + CALL mpp__add_proc(td_mpp, tl_proc(:)) + DEALLOCATE(tl_proc) + + END SUBROUTINE mpp__create_layout + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__optimiz(td_mpp, id_mask, id_nproc) + !------------------------------------------------------------------- + !> @brief + !> This subroutine optimize the number of sub domain to be used, given mask. + !> @details + !> Actually it get the domain decomposition with the most land + !> processors removed. + !> If no land processor could be removed, it get the decomposition with the + !> most sea processors. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date October, 2015 + !> - improve way to compute domain layout + !> @date February, 2016 + !> - new criteria for domain layout in case no land proc + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] id_mask sub domain mask (sea=1, land=0) + !> @pram[in] id_nproc maximum number of processor to be used + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask + INTEGER(i4) , INTENT(IN) :: id_nproc + + ! local variable + TYPE(TLAY) :: tl_lay + TYPE(TLAY) :: tl_sav + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) :: dl_ratio + REAL(dp) :: dl_sav + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition") + dl_sav=0 + ! + DO ji=1,id_nproc + DO jj=1,id_nproc + + ! compute domain layout + tl_lay=layout__init( td_mpp, id_mask, ji,jj ) + IF( tl_lay%i_nsea <= id_nproc )THEN + + IF( ASSOCIATED(tl_sav%i_lci) )THEN + IF( tl_sav%i_nland /= 0 )THEN + ! look for layout with most land proc + IF( tl_lay%i_nland > tl_sav%i_nland .OR. & + & ( tl_lay%i_nland == tl_sav%i_nland .AND. & + & tl_lay%i_min > tl_sav%i_min ) )THEN + ! save optimiz layout + CALL logger_info("MPP OPTIMIZ:save this decomposition "//& + & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& + & TRIM(fct_str(tl_lay%i_nsea)) ) + + tl_sav=layout__copy(tl_lay) + ENDIF + ELSE ! tl_sav%i_nland == 0 + ! look for layout with most sea proc + ! and "square" cell + dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) + dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) + dl_ratio=dl_min/dl_max + IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. & + & ( tl_lay%i_nsea == tl_sav%i_nsea .AND. & + & dl_ratio > dl_sav ) )THEN + ! save optimiz layout + CALL logger_info("MPP OPTIMIZ:save this decomposition "//& + & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& + & TRIM(fct_str(tl_lay%i_nsea)) ) + + tl_sav=layout__copy(tl_lay) + dl_sav=dl_ratio + ENDIF + ENDIF + ELSE + ! init tl_sav + tl_sav=layout__copy(tl_lay) + + dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) + dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) + dl_sav=dl_min/dl_max + ENDIF + + ENDIF + + ! clean + CALL layout__clean( tl_lay ) + + ENDDO + ENDDO + + ! create mpp domain layout + CALL mpp__create_layout(td_mpp, tl_sav) + + ! clean + CALL layout__clean( tl_sav ) + + END SUBROUTINE mpp__optimiz + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__clean_unit(td_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean mpp strcuture. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> @date January, 2019 + !> - nullify file structure inside mpp structure + !> + !> @param[inout] td_mpp mpp strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! local variable + TYPE(TMPP) :: tl_mpp ! empty mpp structure + + ! loop indices + !---------------------------------------------------------------- + + CALL logger_info( & + & "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) ) + + ! del dimension + IF( td_mpp%i_ndim /= 0 )THEN + CALL dim_clean( td_mpp%t_dim(:) ) + ENDIF + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + ! clean array of file processor + CALL file_clean( td_mpp%t_proc(:) ) + DEALLOCATE(td_mpp%t_proc) + NULLIFY(td_mpp%t_proc) + ENDIF + + ! replace by empty structure + td_mpp=mpp_copy(tl_mpp) + + END SUBROUTINE mpp__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean mpp strcuture. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !------------------------------------------------------------------- + SUBROUTINE mpp__clean_arr(td_mpp) + + IMPLICIT NONE + ! Argument + TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_mpp(:)),1,-1 + CALL mpp_clean(td_mpp(ji)) + ENDDO + + END SUBROUTINE mpp__clean_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__get_use_unit(td_mpp, id_imin, id_imax, id_jmin, id_jmax) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get sub domains which cover "zoom domain". + !> proc use in "zoom domain" + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !> @param[in] id_imin i-direction lower indice + !> @param[in] id_imax i-direction upper indice + !> @param[in] id_jmin j-direction lower indice + !> @param[in] id_jmax j-direction upper indice + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin + INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax + INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin + INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax + + ! local variable + LOGICAL :: ll_iuse + LOGICAL :: ll_juse + + INTEGER(i4) :: il_imin + INTEGER(i4) :: il_imax + INTEGER(i4) :: il_jmin + INTEGER(i4) :: il_jmax + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + + il_imin=1 + il_imax=td_mpp%t_dim(1)%i_len + IF( PRESENT(id_imin) ) il_imin=id_imin + IF( PRESENT(id_imax) ) il_imax=id_imax + il_jmin=1 + il_jmax=td_mpp%t_dim(2)%i_len + IF( PRESENT(id_jmin) ) il_jmin=id_jmin + IF( PRESENT(id_jmax) ) il_jmax=id_jmax + + ! check domain + IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. & + & il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. & + & il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. & + & il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN + CALL logger_debug("MPP GET USE: mpp gloabl size "//& + & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& + & TRIM(fct_str(td_mpp%t_dim(2)%i_len))) + CALL logger_debug("MPP GET USE: i-indices "//& + & TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax))) + CALL logger_debug("MPP GET USE: j-indices "//& + & TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax))) + CALL logger_error("MPP GET USE: invalid indices ") + ELSE + td_mpp%t_proc(:)%l_use=.FALSE. + DO jk=1,td_mpp%i_nproc + + ! check i-direction + ll_iuse=.FALSE. + IF( il_imin < il_imax )THEN + + ! not overlap east west boundary + IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > & + & il_imin .AND. & + & td_mpp%t_proc(jk)%i_impp < il_imax )THEN + ll_iuse=.TRUE. + ENDIF + + ELSEIF( il_imin == il_imax )THEN + + ! east west cyclic + ll_iuse=.TRUE. + + ELSE ! il_imin > id_imax + + ! overlap east west boundary + IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > & + & il_imin ) & + & .OR. & + & ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN + ll_iuse=.TRUE. + ENDIF + + ENDIF + + ! check j-direction + ll_juse=.FALSE. + IF( il_jmin < il_jmax )THEN + + ! not overlap north fold + IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > & + & il_jmin .AND. & + & td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN + ll_juse=.TRUE. + ENDIF + + ELSE ! id_jmin >= id_jmax + + IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > & + & il_jmin )THEN + ll_juse=.TRUE. + ENDIF + + ENDIF + + IF( ll_iuse .AND. ll_juse ) td_mpp%t_proc(jk)%l_use=.TRUE. + + ENDDO + ENDIF + + ELSE + CALL logger_error("MPP GET USE: mpp decomposition not define.") + ENDIF + + END SUBROUTINE mpp__get_use_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_get_contour(td_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine get sub domains which form global domain border. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + + td_mpp%t_proc(:)%l_use = .FALSE. + DO jk=1,td_mpp%i_nproc + IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. & + & td_mpp%t_proc(jk)%i_ldj == 1 .OR. & + & td_mpp%t_proc(jk)%i_lei == td_mpp%t_proc(jk)%i_lci .OR. & + & td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN + + td_mpp%t_proc(jk)%l_use = .TRUE. + + ENDIF + ENDDO + + ELSE + CALL logger_error("MPP GET CONTOUR: domain decomposition not define.") + ENDIF + + END SUBROUTINE mpp_get_contour + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp_get_proc_index(td_mpp, id_procid) & + & RESULT(if_idx) + !------------------------------------------------------------------- + !> @brief + !> This function return processor indices, without overlap boundary, + !> given processor id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[in] td_mpp mpp strcuture + !> @param[in] id_procid processor id + !> @return array of index (/ i1, i2, j1, j2 /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + INTEGER(i4), INTENT(IN) :: id_procid + + ! function + INTEGER(i4), DIMENSION(4) :: if_idx + + ! local variable + INTEGER(i4) :: il_i1, il_i2 + INTEGER(i4) :: il_j1, il_j2 + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + + IF( TRIM(td_mpp%c_dom) == '' )THEN + CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//& + & "you should ahve run mpp_get_dom before.") + ENDIF + + SELECT CASE(TRIM(td_mpp%c_dom)) + CASE('full') + il_i1 = 1 + il_j1 = 1 + + il_i2 = td_mpp%t_dim(1)%i_len + il_j2 = td_mpp%t_dim(2)%i_len + CASE('noextra') + il_i1 = td_mpp%t_proc(id_procid)%i_impp + il_j1 = td_mpp%t_proc(id_procid)%i_jmpp + + il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 + il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 + CASE('nooverlap') + il_i1 = td_mpp%t_proc(id_procid)%i_impp + & + & td_mpp%t_proc(id_procid)%i_ldi - 1 + il_j1 = td_mpp%t_proc(id_procid)%i_jmpp + & + & td_mpp%t_proc(id_procid)%i_ldj - 1 + + il_i2 = td_mpp%t_proc(id_procid)%i_impp + & + & td_mpp%t_proc(id_procid)%i_lei - 1 + il_j2 = td_mpp%t_proc(id_procid)%i_jmpp + & + & td_mpp%t_proc(id_procid)%i_lej - 1 + CASE DEFAULT + CALL logger_error("MPP GET PROC INDEX: invalid "//& + & "decomposition type.") + END SELECT + + if_idx(:)=(/il_i1, il_i2, il_j1, il_j2/) + + ELSE + CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.") + ENDIF + + END FUNCTION mpp_get_proc_index + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp_get_proc_size(td_mpp, id_procid) & + & RESULT(if_size) + !------------------------------------------------------------------- + !> @brief + !> This function return processor domain size, depending of domain + !> decompisition type, given sub domain id. + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[in] td_mpp mpp strcuture + !> @param[in] id_procid sub domain id + !> @return array of index (/ isize, jsize /) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + INTEGER(i4), INTENT(IN) :: id_procid + + ! function + INTEGER(i4), DIMENSION(2) :: if_size + + ! local variable + INTEGER(i4) :: il_isize + INTEGER(i4) :: il_jsize + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + + IF( TRIM(td_mpp%c_dom) == '' )THEN + CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//& + & "you should ahve run mpp_get_dom before.") + ENDIF + + SELECT CASE(TRIM(td_mpp%c_dom)) + CASE('full') + + il_isize = td_mpp%t_dim(1)%i_len + il_jsize = td_mpp%t_dim(2)%i_len + + CASE('noextra') + + il_isize = td_mpp%t_proc(id_procid)%i_lci + il_jsize = td_mpp%t_proc(id_procid)%i_lcj + + CASE('nooverlap') + il_isize = td_mpp%t_proc(id_procid)%i_lei - & + & td_mpp%t_proc(id_procid)%i_ldi + 1 + il_jsize = td_mpp%t_proc(id_procid)%i_lej - & + & td_mpp%t_proc(id_procid)%i_ldj + 1 + CASE DEFAULT + CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//& + & TRIM(td_mpp%c_dom) ) + END SELECT + + if_size(:)=(/il_isize, il_jsize/) + + ELSE + CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.") + ENDIF + + END FUNCTION mpp_get_proc_size + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp_get_dom(td_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine determine domain decomposition type. + !> (full, overlap, noverlap) + !> + !> @author J.Paul + !> @date November, 2013 - Initial version + !> + !> @param[inout] td_mpp mpp strcuture + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(INOUT) :: td_mpp + + ! local variable + INTEGER(i4) :: il_isize + INTEGER(i4) :: il_jsize + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_mpp%t_proc) )THEN + + IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN + CALL logger_info("MPP GET DOM: use indoor indices to get domain "//& + & "decomposition type.") + IF((td_mpp%t_proc(1)%t_dim(1)%i_len == & + & td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1) .AND. & + & (td_mpp%t_proc(1)%t_dim(2)%i_len == & + & td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1) )THEN + + td_mpp%c_dom='nooverlap' + + ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == & + & td_mpp%t_proc(1)%i_lci ) .AND. & + & (td_mpp%t_proc(1)%t_dim(2)%i_len == & + & td_mpp%t_proc(1)%i_lcj ) )THEN + + td_mpp%c_dom='noextra' + + ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == & + & td_mpp%t_dim(1)%i_len ) .AND. & + & (td_mpp%t_proc(1)%t_dim(2)%i_len == & + & td_mpp%t_dim(2)%i_len ) )THEN + + td_mpp%c_dom='full' + + ELSE + + CALL logger_error("MPP GET DOM: should have been an impossible case") + + il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len + il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len + CALL logger_debug("MPP GET DOM: proc size "//& + & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) + + il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1 + il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1 + CALL logger_debug("MPP GET DOM: no overlap size "//& + & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) + + il_isize=td_mpp%t_proc(1)%i_lci + il_jsize=td_mpp%t_proc(1)%i_lcj + CALL logger_debug("MPP GET DOM: overlap size "//& + & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) + + il_isize=td_mpp%t_dim(1)%i_len + il_jsize=td_mpp%t_dim(2)%i_len + CALL logger_debug("MPP GET DOM: full size "//& + & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) + + ENDIF + + ELSE + + CALL logger_info("MPP GET DOM: use number of processors following "//& + & "I and J to get domain decomposition type.") + IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN + IF( td_mpp%i_nproc == 1 )THEN + td_mpp%c_dom='full' + ENDIF + td_mpp%c_dom='nooverlap' + ELSE + td_mpp%c_dom='noextra' + ENDIF + + ENDIF + + ELSE + CALL logger_error("MPP GET DOM: domain decomposition not define.") + ENDIF + + END SUBROUTINE mpp_get_dom + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp__check_var_dim(td_mpp, td_var) & + & RESULT(lf_check) + !------------------------------------------------------------------- + !> @brief This function check if variable and mpp structure use same + !> dimension. + !> + !> @details + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date September 2015 + !> - do not check used dimension here + !> + !> @param[in] td_mpp mpp structure + !> @param[in] td_var variable structure + !> @return dimension of variable and mpp structure agree (or not) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP), INTENT(IN) :: td_mpp + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + LOGICAL :: lf_check + + ! local variable + CHARACTER(LEN=lc) :: cl_dim + LOGICAL :: ll_error + LOGICAL :: ll_warn + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_check=.TRUE. + + ! check used dimension + ll_error=.FALSE. + ll_warn=.FALSE. + DO ji=1,ip_maxdim + il_ind=dim_get_index( td_mpp%t_dim(:), & + & TRIM(td_var%t_dim(ji)%c_name), & + & TRIM(td_var%t_dim(ji)%c_sname)) + IF( il_ind /= 0 )THEN + IF( td_var%t_dim(ji)%l_use .AND. & + &td_mpp%t_dim(il_ind)%l_use .AND. & + &td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN + IF( INDEX( TRIM(td_var%c_axis), & + & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN + ll_warn=.TRUE. + ELSE + ll_error=.TRUE. + ENDIF + ENDIF + ENDIF + ENDDO + + IF( ll_error )THEN + + cl_dim='(/' + DO ji = 1, td_mpp%i_ndim + IF( td_mpp%t_dim(ji)%l_use )THEN + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//& + & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//',' + ENDIF + ENDDO + cl_dim=TRIM(cl_dim)//'/)' + CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) ) + + cl_dim='(/' + DO ji = 1, td_var%i_ndim + IF( td_var%t_dim(ji)%l_use )THEN + cl_dim=TRIM(cl_dim)//& + & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& + & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' + ENDIF + ENDDO + cl_dim=TRIM(cl_dim)//'/)' + CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) + + lf_check=.FALSE. + + CALL logger_error( & + & " MPP CHECK VAR DIM: variable and file dimension differ"//& + & " for variable "//TRIM(td_var%c_name)//& + & " and file "//TRIM(td_mpp%c_name)) + + ELSEIF( ll_warn )THEN + CALL logger_warn( & + & " MPP CHECK VAR DIM: variable and file dimension differ"//& + & " for variable "//TRIM(td_var%c_name)//& + & " and file "//TRIM(td_mpp%c_name)//". you should use"//& + & " var_check_dim to remove useless dimension.") + ELSE + + IF( td_var%i_ndim > td_mpp%i_ndim )THEN + CALL logger_info("MPP CHECK VAR DIM: variable "//& + & TRIM(td_var%c_name)//" use more dimension than file "//& + & TRIM(td_mpp%c_name)//" do until now.") + ENDIF + + ENDIF + + END FUNCTION mpp__check_var_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp_get_index(td_mpp, cd_name) & + & RESULT(if_idx) + !------------------------------------------------------------------- + !> @brief This function return the mpp id, in a array of mpp + !> structure, given mpp base name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_file array of file structure + !> @param[in] cd_name file name + !> @return file id in array of file structure (0 if not found) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + ! function + INTEGER(i4) :: if_idx + + ! local variable + CHARACTER(LEN=lc) :: cl_name + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + if_idx=0 + il_size=SIZE(td_mpp(:)) + + cl_name=TRIM( file_rename(cd_name) ) + + ! check if mpp is in array of mpp structure + DO ji=1,il_size + ! look for file name + IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN + + if_idx=ji + EXIT + + ENDIF + ENDDO + + END FUNCTION mpp_get_index + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION mpp_recombine_var(td_mpp, cd_name) & + & RESULT(tf_var) + !------------------------------------------------------------------- + !> @brief This function recombine variable splitted in mpp structure. + !> + !> @author J.Paul + !> @date October, 2014 - Initial Version + !> + !> @param[in] td_mpp mpp file structure + !> @param[in] cd_name variable name + !> @return variable strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_mpp + CHARACTER(LEN=*), INTENT(IN) :: cd_name + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_varid + INTEGER(i4) :: il_status + INTEGER(i4) :: il_i1p + INTEGER(i4) :: il_i2p + INTEGER(i4) :: il_j1p + INTEGER(i4) :: il_j2p + INTEGER(i4), DIMENSION(4) :: il_ind + + INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt + INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt + + TYPE(TVAR) :: tl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name) + IF( il_varid /= 0 )THEN + + tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) + ! Allocate space to hold variable value in structure + IF( ASSOCIATED(tf_var%d_value) )THEN + DEALLOCATE(tf_var%d_value) + ENDIF + ! + DO ji=1,ip_maxdim + IF( tf_var%t_dim(ji)%l_use )THEN + tf_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len + ENDIF + ENDDO + + ALLOCATE(tf_var%d_value( tf_var%t_dim(1)%i_len, & + & tf_var%t_dim(2)%i_len, & + & tf_var%t_dim(3)%i_len, & + & tf_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " MPP RECOMBINE VAR: not enough space to put variable "//& + & TRIM(tf_var%c_name)//" in variable structure") + + ENDIF + + ! FillValue by default + tf_var%d_value(:,:,:,:)=tf_var%d_fill + + ! read processor + DO jk=1,td_mpp%i_nproc + IF( td_mpp%t_proc(jk)%l_use )THEN + ! get processor indices + il_ind(:)=mpp_get_proc_index( td_mpp, jk ) + il_i1p = il_ind(1) + il_i2p = il_ind(2) + il_j1p = il_ind(3) + il_j2p = il_ind(4) + + il_strt(:)=(/ 1,1,1,1 /) + + il_cnt(:)=(/ il_i2p-il_i1p+1, & + & il_j2p-il_j1p+1, & + & tf_var%t_dim(3)%i_len, & + & tf_var%t_dim(4)%i_len /) + + tl_tmp=iom_read_var( td_mpp%t_proc(jk), tf_var%c_name,& + & il_strt(:), il_cnt(:) ) + + ! replace value in output variable structure + tf_var%d_value( il_i1p : il_i2p, & + & il_j1p : il_j2p, & + & :,:) = tl_tmp%d_value(:,:,:,:) + + ! clean + CALL var_clean(tl_tmp) + + ENDIF + ENDDO + + ELSE + + CALL logger_error( & + & " MPP RECOMBINE VAR: there is no variable with "//& + & "name or standard name"//TRIM(cd_name)//& + & " in mpp file "//TRIM(td_mpp%c_name)) + ENDIF + + END FUNCTION mpp_recombine_var + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__read_halo(td_file, td_dimglo) + !------------------------------------------------------------------- + !> @brief This subroutine read subdomain indices defined with halo + !> (NEMO netcdf way) + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !> + !> @param[inout] td_file mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TFILE) , INTENT(INOUT) :: td_file + TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo + + ! local variable + INTEGER(i4) :: il_attid + INTEGER(i4) :: il_ifirst + INTEGER(i4) :: il_jfirst + INTEGER(i4) :: il_ilast + INTEGER(i4) :: il_jlast + INTEGER(i4) :: il_ihalostart + INTEGER(i4) :: il_jhalostart + INTEGER(i4) :: il_ihaloend + INTEGER(i4) :: il_jhaloend + + CHARACTER(LEN=lc) :: cl_dom + !---------------------------------------------------------------- + + ! DOMAIN_position_first + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) + ENDIF + IF( il_attid /= 0 )THEN + il_ifirst = INT(td_file%t_att(il_attid)%d_value(1)) + il_jfirst = INT(td_file%t_att(il_attid)%d_value(2)) + ELSE + il_ifirst = 1 + il_jfirst = 1 + ENDIF + + ! DOMAIN_position_last + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) + ENDIF + IF( il_attid /= 0 )THEN + il_ilast = INT(td_file%t_att(il_attid)%d_value(1)) + il_jlast = INT(td_file%t_att(il_attid)%d_value(2)) + ELSE + il_ilast = td_file%t_dim(1)%i_len + il_jlast = td_file%t_dim(2)%i_len + ENDIF + + ! DOMAIN_halo_size_start + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) + ENDIF + IF( il_attid /= 0 )THEN + il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1)) + il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2)) + ELSE + il_ihalostart = 0 + il_jhalostart = 0 + ENDIF + + ! DOMAIN_halo_size_end + il_attid = 0 + IF( ASSOCIATED(td_file%t_att) )THEN + il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) + ENDIF + IF( il_attid /= 0 )THEN + il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1)) + il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2)) + ELSE + il_ihaloend = 0 + il_jhaloend = 0 + ENDIF + + IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. & + & (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN + cl_dom='full' + ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. & + & il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN + cl_dom='nooverlap' + ELSE + cl_dom='noextra' + ENDIF + + SELECT CASE(TRIM(cl_dom)) + CASE('full') + td_file%i_impp = il_ifirst + td_file%i_jmpp = il_jfirst + td_file%i_lci = td_file%t_dim(jp_I)%i_len + td_file%i_lcj = td_file%t_dim(jp_J)%i_len + td_file%i_ldi = il_ihalostart + 1 + td_file%i_ldj = il_jhalostart + 1 + td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend + td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend + CASE('noextra') + td_file%i_impp = il_ifirst + td_file%i_jmpp = il_jfirst + td_file%i_lci = td_file%t_dim(jp_I)%i_len + td_file%i_lcj = td_file%t_dim(jp_J)%i_len + td_file%i_ldi = il_ihalostart + 1 + td_file%i_ldj = il_jhalostart + 1 + td_file%i_lei = td_file%i_lci - il_ihaloend + td_file%i_lej = td_file%i_lcj - il_jhaloend + CASE('nooverlap') !!!????? + td_file%i_impp = il_ifirst + td_file%i_jmpp = il_jfirst + td_file%i_lci = td_file%t_dim(jp_I)%i_len + td_file%i_lcj = td_file%t_dim(jp_J)%i_len + td_file%i_ldi = 1 + td_file%i_ldj = 1 + td_file%i_lei = td_file%t_dim(jp_I)%i_len + td_file%i_lej = td_file%t_dim(jp_J)%i_len + END SELECT + + END SUBROUTINE mpp__read_halo + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mpp__compute_halo(td_mpp) + !------------------------------------------------------------------- + !> @brief This subroutine compute subdomain indices defined with halo + !> (NEMO netcdf way) + !> + !> @author J.Paul + !> @date January, 2016 - Initial Version + !> + !> @param[inout] td_mpp mpp structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(INOUT) :: td_mpp + + ! local variable + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend + INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend + + TYPE(TATT) :: tl_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ALLOCATE( il_ifirst (td_mpp%i_nproc) ) + ALLOCATE( il_jfirst (td_mpp%i_nproc) ) + + ALLOCATE( il_ilast (td_mpp%i_nproc) ) + ALLOCATE( il_jlast (td_mpp%i_nproc) ) + + ALLOCATE( il_ihalostart(td_mpp%i_nproc) ) + ALLOCATE( il_jhalostart(td_mpp%i_nproc) ) + + ALLOCATE( il_ihaloend (td_mpp%i_nproc) ) + ALLOCATE( il_jhaloend (td_mpp%i_nproc) ) + + SELECT CASE(TRIM(td_mpp%c_dom)) + CASE('full') + + il_ifirst(:)=td_mpp%t_proc(:)%i_impp + il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + + il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1 + il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1 + + il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 + il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 + + il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei + il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej + + CASE('noextra') + + il_ifirst(:)=td_mpp%t_proc(:)%i_impp + il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + + il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1 + il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1 + + il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 + il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 + + il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei + il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej + + CASE('nooverlap') + + il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1 + il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1 + + il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1 + il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1 + + il_ihalostart(:)=0 + il_jhalostart(:)=0 + + il_ihaloend(:)=0 + il_jhaloend(:)=0 + + CASE DEFAULT + CALL logger_fatal("MPP INIT: invalid "//& + & "decomposition type.") + END SELECT + + DO ji=1,td_mpp%i_nproc + tl_att=att_init( "DOMAIN_position_first", & + & (/ il_ifirst(ji), il_jfirst(ji) /) ) + CALL file_move_att(td_mpp%t_proc(ji), tl_att) + + tl_att=att_init( "DOMAIN_position_last", & + & (/ il_ilast(ji), il_jlast(ji) /) ) + CALL file_move_att(td_mpp%t_proc(ji), tl_att) + + tl_att=att_init( "DOMAIN_halo_size_start", & + & (/ il_ihalostart(ji), il_jhalostart(ji) /) ) + CALL file_move_att( td_mpp%t_proc(ji), tl_att) + + tl_att=att_init( "DOMAIN_halo_size_end", & + & (/ il_ihaloend(ji), il_jhaloend(ji) /) ) + CALL file_move_att( td_mpp%t_proc(ji), tl_att) + ENDDO + + DEALLOCATE( il_ifirst ) + DEALLOCATE( il_jfirst ) + + DEALLOCATE( il_ilast ) + DEALLOCATE( il_jlast ) + + DEALLOCATE( il_ihalostart) + DEALLOCATE( il_jhalostart) + + DEALLOCATE( il_ihaloend ) + DEALLOCATE( il_jhaloend ) + + !impp + tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp) + CALL mpp_move_att(td_mpp, tl_att) + + tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp) + CALL mpp_move_att(td_mpp, tl_att) + + ! lci + tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci) + CALL mpp_move_att(td_mpp, tl_att) + + tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj) + CALL mpp_move_att(td_mpp, tl_att) + + ! ldi + tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi) + CALL mpp_move_att(td_mpp, tl_att) + + tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj) + CALL mpp_move_att(td_mpp, tl_att) + + ! lei + tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei) + CALL mpp_move_att(td_mpp, tl_att) + + tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej) + CALL mpp_move_att(td_mpp, tl_att) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE mpp__compute_halo + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE mpp + diff --git a/V4.0/nemo_sources/tools/SIREN/src/multi.f90 b/V4.0/nemo_sources/tools/SIREN/src/multi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5384208b95d84bcac06473f4732fd7451a1c4529 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/multi.f90 @@ -0,0 +1,719 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> This module manage multi file structure. +!> +!> @details +!> define type TMULTI:<br/> +!> @code +!> TYPE(TMULTI) :: tl_multi +!> @endcode +!> +!> to initialize a multi-file structure:<br/> +!> @code +!> tl_multi=multi_init(cd_varfile(:)) +!> @endcode +!> - cd_varfile : array of variable with file path +!> ('var1:file1','var2:file2')<br/> +!> file path could be replaced by a matrix of value.<br/> +!> separators used to defined matrix are: +!> - ',' for line +!> - '/' for row +!> - '\' for level<br/> +!> Example:<br/> +!> - 'var1:3,2,3/1,4,5' +!> - 3,2,3/1,4,5 => +!> @f$ \left( \begin{array}{ccc} +!> 3 & 2 & 3 \\ +!> 1 & 4 & 5 \end{array} \right) @f$<br/> +!> +!> to get the number of mpp file in mutli file structure:<br/> +!> - tl_multi\%i_nmpp +!> +!> to get the total number of variable in mutli file structure:<br/> +!> - tl_multi\%i_nvar +!> +!> @note number of variable and number of file could differ cause several variable +!> could be in the same file. +!> +!> to get array of mpp structure in mutli file structure:<br/> +!> - tl_multi\%t_mpp(:) +!> +!> to print information about multi structure:<br/> +!> @code +!> CALL multi_print(td_multi) +!> @endcode +!> +!> to clean multi file strucutre:<br/> +!> @code +!> CALL multi_clean(td_multi) +!> @endcode +!> - td_multi is multi file structure +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date October, 2014 +!> - use mpp file structure instead of file +!> @date November, 2014 +!> - Fix memory leaks bug +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE multi + + USE kind ! F90 kind parameter + USE logger ! log file manager + USE fct ! basic useful function + USE dim ! dimension manager + USE var ! variable manager + USE file ! file manager + USE iom ! I/O manager + USE mpp ! MPP manager + USE iom_mpp ! MPP I/O manager + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TMULTI !< multi file structure + + ! function and subroutine + PUBLIC :: multi_copy !< copy multi structure + PUBLIC :: multi_init !< initialise multi structure + PUBLIC :: multi_clean !< clean multi strcuture + PUBLIC :: multi_print !< print information about milti structure + + PRIVATE :: multi__add_mpp !< add file strucutre to multi file structure + PRIVATE :: multi__copy_unit !< copy multi file structure + PRIVATE :: multi__get_perio !< read periodicity from namelist + + TYPE TMULTI !< multi file structure + ! general + INTEGER(i4) :: i_nmpp = 0 !< number of mpp files + INTEGER(i4) :: i_nvar = 0 !< total number of variables + TYPE(TMPP) , DIMENSION(:), POINTER :: t_mpp => NULL() !< mpp files composing multi + END TYPE + + INTERFACE multi_copy + MODULE PROCEDURE multi__copy_unit ! copy multi file structure + END INTERFACE + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION multi__copy_unit(td_multi) & + & RESULT (tf_multi) + !------------------------------------------------------------------- + !> @brief + !> This function copy multi mpp structure in another one + !> @details + !> file variable value are copied in a temporary array, + !> so input and output file structure value do not point on the same + !> "memory cell", and so on are independant. + !> + !> @warning do not use on the output of a function who create or read an + !> attribute (ex: tl_att=att_copy(att_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator (to avoid memory leak) + !> + !> @param[in] td_multi mpp structure + !> @return copy of input multi structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMULTI), INTENT(IN) :: td_multi + + ! function + TYPE(TMULTI) :: tf_multi + + ! local variable + TYPE(TMPP) :: tl_mpp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + tf_multi%i_nmpp = td_multi%i_nmpp + tf_multi%i_nvar = td_multi%i_nvar + + ! copy variable structure + IF( ASSOCIATED(tf_multi%t_mpp) )THEN + CALL mpp_clean(tf_multi%t_mpp(:)) + DEALLOCATE(tf_multi%t_mpp) + ENDIF + IF( ASSOCIATED(td_multi%t_mpp) .AND. tf_multi%i_nmpp > 0 )THEN + ALLOCATE( tf_multi%t_mpp(tf_multi%i_nmpp) ) + DO ji=1,tf_multi%i_nmpp + tl_mpp = mpp_copy(td_multi%t_mpp(ji)) + tf_multi%t_mpp(ji) = mpp_copy(tl_mpp) + ENDDO + ! clean + CALL mpp_clean(tl_mpp) + ENDIF + + END FUNCTION multi__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION multi_init(cd_varfile) & + & RESULT (tf_multi) + !------------------------------------------------------------------- + !> @brief This subroutine initialize multi file structure. + !> + !> @details + !> if variable name is 'all', add all the variable of the file in mutli file + !> structure. + !> Optionnaly, periodicity could be read behind filename. + !> + !> @note if first character of filename is numeric, assume matrix is given as + !> input.<br/> + !> create pseudo file named 'data-*', with matrix read as variable value. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - check if variable to be read is in file + !> @date January, 2016 + !> - read variable dimensions + !> @date July, 2016 + !> - get variable to be read and associated file first + !> @date August, 2017 + !> - get perio from namelist + !> @date January, 2019 + !> - create and clean file structure to avoid memory leaks + !> - fill value read from array of variable structure + !> @date May, 2019 + !> - compare each elt of cl_tabfile to cl_file + !> @date August, 2019 + !> - use periodicity read from namelist, and store in multi structure + !> + !> @param[in] cd_varfile variable location information (from namelist) + !> @return multi file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile + + ! function + TYPE(TMULTI) :: tf_multi + + ! parameters + INTEGER(i4) , PARAMETER :: ip_nmaxfiles = 50 + INTEGER(i4) , PARAMETER :: ip_nmaxvars = 100 + + ! local variable + INTEGER(i4) :: il_nvar + INTEGER(i4) :: il_nvarin + INTEGER(i4) :: il_nfiles + INTEGER(i4) :: il_varid + INTEGER(i4) :: il_perio + + REAL(dp) :: dl_fill + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_varname + CHARACTER(LEN=lc) :: cl_lower + CHARACTER(LEN=lc) :: cl_file + CHARACTER(LEN=lc) :: cl_matrix + + CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles) :: cl_tabfile + CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles, ip_nmaxvars) :: cl_tabvar + + LOGICAL :: ll_dim + + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TVAR) :: tl_var + TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_varin + + TYPE(TMPP) :: tl_mpp + + TYPE(TFILE) :: tl_file + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + INTEGER(i4) :: jf + INTEGER(i4) , DIMENSION(ip_nmaxvars) :: jv + !---------------------------------------------------------------- + + ji=1 + jf=0 + jv(:)=0 + cl_tabfile(:)='' + DO WHILE( TRIM(cd_varfile(ji)) /= '' ) + + cl_name=fct_split(cd_varfile(ji),1,':') + IF( TRIM(cl_name) == '' )THEN + CALL logger_error("MULTI INIT: variable name "//& + & "is empty. check namelist.") + ENDIF + + cl_file=fct_split(cd_varfile(ji),2,':') + IF( TRIM(cl_file) == '' )THEN + CALL logger_error("MULTI INIT: file name matching variable "//& + & TRIM(cl_name)//" is empty. check namelist.") + ENDIF + IF( LEN(TRIM(cl_file)) >= lc )THEN + CALL logger_fatal("MULTI INIT: file name too long (>"//& + & TRIM(fct_str(lc))//"). check namelist.") + ENDIF + + IF( TRIM(cl_file) /= '' )THEN + jk=0 + DO jj=1,jf + IF( TRIM(cl_file) == TRIM(cl_tabfile(jj)) )THEN + jk=jj + EXIT + ENDIF + ENDDO + IF ( jk /= 0 )then + jv(jk)=jv(jk)+1 + cl_tabvar(jk,jv(jk))=TRIM(cl_name) + ELSE ! jk == 0 + jf=jf+1 + IF( jf > ip_nmaxfiles )THEN + CALL logger_fatal("MULTI INIT: too much files in "//& + & "varfile (>"//TRIM(fct_str(ip_nmaxfiles))//& + & "). check namelist.") + ENDIF + cl_tabfile(jf)=TRIM(cl_file) + jv(jf)=jv(jf)+1 + cl_tabvar(jf,jv(jf))=TRIM(cl_name) + ENDIF + ENDIF + + ji=ji+1 + ENDDO + +!print *,'============' +!print *,jf,' files ','============' +!DO ji=1,jf +! print *,'file ',trim(cl_tabfile(ji)) +! print *,jv(ji),' vars ' +! DO jj=1,jv(ji) +! print *,'var ',trim(cl_tabvar(ji,jj)) +! ENDDO +!ENDDO +!print *,'============' + + + il_nfiles=jf + il_nvar=0 + DO ji=1,il_nfiles + cl_file=TRIM(cl_tabfile(ji)) + + cl_matrix='' + IF( fct_is_num(cl_file(1:1)) )THEN + cl_matrix=TRIM(cl_file) + WRITE(cl_file,'(a,i2.2)')'data-',ji + + DO jj=1,jv(ji) + cl_name=TRIM(cl_tabvar(ji,jv(ji))) + cl_lower=TRIM(fct_lower(cl_name)) + + tl_var=var_init(TRIM(cl_name)) + CALL var_read_matrix(tl_var, cl_matrix) + + IF( jj == 1 )THEN + ! create mpp structure + tl_mpp=mpp_init(TRIM(cl_file), tl_var) + ENDIF + + ! add variable + CALL mpp_add_var(tl_mpp,tl_var) + ! number of variable + il_nvar=il_nvar+1 + + ENDDO + + ELSE + CALL multi__get_perio(cl_file, il_perio) + + tl_file=file_init(TRIM(cl_file), id_perio=il_perio) + tl_mpp=mpp_init( tl_file, id_perio=il_perio ) + ! clean + CALL file_clean(tl_file) + + il_nvarin=tl_mpp%t_proc(1)%i_nvar + ALLOCATE(tl_varin(il_nvarin)) + DO jj=1,il_nvarin + tl_varin(jj)=var_copy(tl_mpp%t_proc(1)%t_var(jj)) + DO jl=1,ip_maxdim + IF( tl_varin(jj)%t_dim(jl)%l_use )THEN + tl_varin(jj)%t_dim(jl)=dim_copy(tl_mpp%t_dim(jl)) + ENDIF + ENDDO + ENDDO + + ! clean all varible + CALL mpp_del_var(tl_mpp) + + DO jj=1,jv(ji) + cl_name=TRIM(cl_tabvar(ji,jj)) + cl_lower=TRIM(fct_lower(cl_name)) + ! define variable + IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN + + ! check if variable is in file + il_varid=var_get_index(tl_varin(:),cl_lower) + IF( il_varid == 0 )THEN + CALL logger_fatal("MULTI INIT: variable "//& + & TRIM(cl_name)//" not in file "//& + & TRIM(cl_file) ) + ENDIF + + ! get (global) variable dimension + tl_dim(jp_I)=dim_copy(tl_varin(il_varid)%t_dim(jp_I)) + tl_dim(jp_J)=dim_copy(tl_varin(il_varid)%t_dim(jp_J)) + tl_dim(jp_K)=dim_copy(tl_varin(il_varid)%t_dim(jp_K)) + tl_dim(jp_L)=dim_copy(tl_varin(il_varid)%t_dim(jp_L)) + + cl_varname=tl_varin(il_varid)%c_name + dl_fill=tl_varin(il_varid)%d_fill + + tl_var=var_init(TRIM(cl_varname), td_dim=tl_dim(:), & + & dd_fill=dl_fill) + + ! add variable + CALL mpp_add_var(tl_mpp,tl_var) + + ! number of variable + il_nvar=il_nvar+1 + + ! clean structure + CALL var_clean(tl_var) + + ELSE ! cl_lower == 'all' + + DO jk=il_nvarin,1,-1 + + ! check if variable is dimension + ll_dim=.FALSE. + DO jl=1,ip_maxdim + IF( TRIM(tl_mpp%t_proc(1)%t_dim(jl)%c_name) == & + & TRIM(tl_varin(jk)%c_name) )THEN + ll_dim=.TRUE. + CALL logger_trace("MULTI INIT: "//& + & TRIM(tl_varin(jk)%c_name)//& + & ' is var dimension') + EXIT + ENDIF + ENDDO + ! do not use variable dimension + IF( ll_dim )THEN + tl_var=var_init( TRIM(tl_varin(jk)%c_name) ) + ! delete variable + CALL mpp_del_var(tl_mpp,tl_var) + ! clean structure + CALL var_clean(tl_var) + ELSE + ! add variable + CALL mpp_add_var(tl_mpp, tl_varin(jk)) + ! number of variable + il_nvar=il_nvar+1 + ENDIF + + ENDDO + + ENDIF + ENDDO + ! clean structure + CALL var_clean(tl_varin) + DEALLOCATE(tl_varin) + + ENDIF + + CALL multi__add_mpp(tf_multi, tl_mpp) + + ! update total number of variable + tf_multi%i_nvar=tf_multi%i_nvar+tl_mpp%t_proc(1)%i_nvar + + ! clean + CALL mpp_clean(tl_mpp) + + ENDDO + + END FUNCTION multi_init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE multi_clean(td_multi) + !------------------------------------------------------------------- + !> @brief This subroutine clean multi file strucutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - nullify mpp structure in multi file structure + !> + !> @param[in] td_multi multi file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMULTI), INTENT(INOUT) :: td_multi + + ! local variable + TYPE(TMULTI) :: tl_multi ! empty multi file structure + + ! loop indices + !---------------------------------------------------------------- + + CALL logger_info( " CLEAN: reset multi file " ) + + IF( ASSOCIATED( td_multi%t_mpp ) )THEN + CALL mpp_clean(td_multi%t_mpp(:)) + DEALLOCATE(td_multi%t_mpp) + NULLIFY(td_multi%t_mpp) + ENDIF + + ! replace by empty structure + td_multi=multi_copy(tl_multi) + + END SUBROUTINE multi_clean + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE multi_print(td_multi) + !------------------------------------------------------------------- + !> @brief This subroutine print some information about mpp strucutre. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - print periodicity + !> @date May, 2019 + !> - specify format output + !> + !> @param[in] td_multi multi file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMULTI), INTENT(IN) :: td_multi + + ! local variable + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! print file + IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN + WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',& + & td_multi%i_nmpp + WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',& + & td_multi%i_nvar + DO ji=1,td_multi%i_nmpp + WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),& + & ' CONTAINS' + DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar + IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN + WRITE(*,'(6x,a)') & + & TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) + !WRITE(*,'(6x,a,i0)') 'perio ',td_multi%t_mpp(ji)%t_proc(1)%i_perio + ENDIF + ENDDO + ENDDO + ENDIF + + END SUBROUTINE multi_print + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE multi__add_mpp(td_multi, td_mpp) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add file to multi file structure. + !> + !> @detail + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date October, 2014 + !> - use mpp file structure instead of file + !> @date January, 2019 + !> - deallocate mpp structure whatever happens + !> + !> @param[inout] td_multi multi mpp file strcuture + !> @param[in] td_mpp mpp file strcuture + !> @return mpp file id in multi mpp file structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMULTI), INTENT(INOUT) :: td_multi + TYPE(TMPP) , INTENT(IN) :: td_mpp + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_mppid + + TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + il_mppid=0 + IF( ASSOCIATED(td_multi%t_mpp) )THEN + il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name)) + ENDIF + + IF( il_mppid /= 0 )THEN + + CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//& + & " already in multi mpp file structure") + + ! add new variable + DO ji=1,td_mpp%t_proc(1)%i_nvar + CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji)) + ENDDO + + ELSE + + CALL logger_trace("MULTI ADD MPP: add mpp "//& + & TRIM(td_mpp%c_name)//" in multi mpp file structure") + + IF( td_multi%i_nmpp > 0 )THEN + ! + ! already other mpp file in multi file structure + ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( " MULTI ADD MPP FILE: not enough space to put & + & mpp file in multi mpp file structure") + + ELSE + ! save temporary multi file structure + tl_mpp(:)=mpp_copy(td_multi%t_mpp(:)) + + CALL mpp_clean(td_multi%t_mpp(:)) + DEALLOCATE( td_multi%t_mpp ) + ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( " MULTI ADD MPP FILE: not enough space "//& + & "to put mpp file in multi mpp file structure ") + + ENDIF + + ! copy mpp file in multi mpp file before + td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:)) + + ! clean + CALL mpp_clean(tl_mpp(:)) + ENDIF + DEALLOCATE(tl_mpp) + + ELSE + ! no file in multi file structure + IF( ASSOCIATED(td_multi%t_mpp) )THEN + CALL mpp_clean(td_multi%t_mpp(:)) + DEALLOCATE(td_multi%t_mpp) + ENDIF + ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( " MULTI ADD MPP FILE: not enough space "//& + & "to put mpp file in multi mpp file structure " ) + + ENDIF + ENDIF + + ! update number of mpp + td_multi%i_nmpp=td_multi%i_nmpp+1 + + ! add new mpp + td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp) + + ENDIF + + END SUBROUTINE multi__add_mpp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE multi__get_perio(cd_file, id_perio) + !------------------------------------------------------------------- + !> @brief + !> This subroutine check if variable file, read in namelist, contains + !> periodicity value and return it if true. + !> + !> @details + !> periodicity value is assume to follow string "perio =" + !> + !> @author J.Paul + !> @date January, 2019 - Initial Version + !> @date August, 209 + !> - rewrite function to subroutine + !> - output filename string contains only filename (no more periodicity if + !> given) + !> + !> @param[inout] cd_file file name + !> @param[ out] id_perio NEMO periodicity + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(INOUT) :: cd_file + INTEGER(i4) , INTENT( OUT) :: id_perio + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_perio + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! init + cl_perio='' + id_perio=-1 + + ji=1 + cl_tmp=fct_split(cd_file,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'perio') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('perio') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_perio=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_file,ji,';') + ENDDO + cd_file=fct_split(cd_file,1,';') + + IF( TRIM(cl_perio) /= '' )THEN + IF( fct_is_num(cl_perio) )THEN + READ(cl_perio,*) id_perio + CALL logger_debug("MULTI GET PERIO: will use periodicity value of "//& + & TRIM(fct_str(id_perio))//" for file "//TRIM(cd_file) ) + ELSE + CALL logger_error("MULTI GET PERIO: invalid periodicity value ("//& + & TRIM(cl_perio)//") for file "//TRIM(cd_file)//& + & ". check namelist." ) + ENDIF + ENDIF + + END SUBROUTINE multi__get_perio + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE multi + diff --git a/V4.0/nemo_sources/tools/SIREN/src/phycst.f90 b/V4.0/nemo_sources/tools/SIREN/src/phycst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f16f74c588e570b2a407ce0eabdcbcfb6ebabf1e --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/phycst.f90 @@ -0,0 +1,56 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module defines physical constant. +!> +!> @author +!> J.paul +! REVISION HISTORY: +!> @date November, 2013 - Initial Version +!> @date September, 2015 +!> - add physical constant to compute meshmask +!> @date January, 2019 +!> - half reduce epsilon value +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE phycst + + USE kind ! F90 kind parameter + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + PUBLIC :: dp_pi !< pi + PUBLIC :: dp_eps !< epsilon value + PUBLIC :: dp_rearth !< earth radius [m] + PUBLIC :: dp_deg2rad !< degree to radian ratio + PUBLIC :: dp_rad2deg !< radian to degree ratio + PUBLIC :: dp_delta !< + PUBLIC :: dp_omega !< earth rotation parameter [s-1] + PUBLIC :: dp_day !< day [s] + PUBLIC :: dp_siyea !< sideral year [s] + PUBLIC :: dp_siday !< sideral day [s] + + REAL(dp), PUBLIC :: rday = 24.*60.*60. !: day [s] + REAL(dp), PUBLIC :: rsiyea !: sideral year [s] + REAL(dp), PUBLIC :: rsiday !: sideral day [s] + + REAL(dp), PARAMETER :: dp_pi = 3.14159274101257_dp + REAL(dp), PARAMETER :: dp_eps = 0.5 * EPSILON(1._dp) + REAL(dp), PARAMETER :: dp_rearth = 6371229._dp !m + REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0 + REAL(dp), PARAMETER :: dp_rad2deg = 180.0/dp_pi + + REAL(dp), PARAMETER :: dp_day = 24.*60.*60. + REAL(dp), PARAMETER :: dp_siyea = 365.25_dp * dp_day * & + & 2._dp * dp_pi / 6.283076_dp + REAL(dp), PARAMETER :: dp_siday = dp_day / ( 1._dp + dp_day / dp_siyea ) + + REAL(dp), PARAMETER :: dp_delta=1.e-6 + REAL(dp), PARAMETER :: dp_omega= 2._dp * dp_pi / dp_siday + +END MODULE phycst + diff --git a/V4.0/nemo_sources/tools/SIREN/src/variable.f90 b/V4.0/nemo_sources/tools/SIREN/src/variable.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7193ba61e948c9fac51eebae68fa21fe49088797 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/variable.f90 @@ -0,0 +1,9705 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief +!> This module manage variable structure. +!> +!> @details +!> to define type TVAR:<br/> +!> @code +!> TYPE(TVAR) :: tl_var +!> @endcode +!> +!> @note the variable value inside structure will always be 4D array of real(8).<br/> +!> However the variable value could be initialised with +!> array of real(4), real(8), integer(4) or integer(8). +!> +!> to initialise a variable structure:<br/> +!> @code +!> tl_var=var_init( cd_name, [value,] [id_start, [id_count,]] [id_type,] [td_dim,] [td_att]... ) +!> @endcode +!> - cd_name is the variable name +!> - value is a 1D,2D,3D or 4D array, see var_init for more information [optional] +!> - id_start is a integer(4) 1D array of index from which the data +!> values will be read [optional] +!> - id_count is a integer(4) 1D array of the number of indices selected +!> along each dimension [optional] +!> - id_type is the type of the variable to be used [optional] +!> - td_dim is the array of dimension structure [optional] +!> - td_att is the array of attribute structure [optional] +!> Note:<br/> +!> - others optionals arguments could be added, see var_init. +!> - to put scalar variable (OD), use td_dim with all dimension unused +!> (td_dim(:)%l_use=.FALSE.) +!> +!> to print information about variable structure:<br/> +!> @code +!> CALL var_print(td_var [,ld_more]) +!> @endcode +!> - td_var is the variable structure +!> - ld_more to print more information about variable +!> +!> to clean variable structure:<br/> +!> @code +!> CALL var_clean(tl_var) +!> @endcode +!> +!> to copy variable structure in another one (using different memory cell):<br/> +!> @code +!> tl_var2=var_copy(tl_var1) +!> @endcode +!> @note as we use pointer for the value array of the variable structure, +!> the use of the assignment operator (=) to copy variable structure +!> create a pointer on the same array. +!> This is not the case with this copy function. +!> +!> to get variable name:<br/> +!> - tl_var\%c_name +!> +!> to get grid point of the variable +!> - tl_var\%c_point +!> +!> to get EW overlap:<br/> +!> - tl_var\%i_ew +!> +!> to get variable value:<br/> +!> - tl_var\%d_value(:,:,:,:) +!> +!> to get the type number (based on NETCDF type constants) of the variable +!> (as define initially or read in file):<br/> +!> - tl_var\%i_type +!> +!> to get variable id (read from a file):<br/> +!> - tl_var\%i_id +!> +!> **Variable dimension**<br/> +!> to get the number of dimension used in the variable:<br/> +!> - tl_var\%i_ndim +!> +!> to get the array of dimension structure (4 elts) associated to the +!> variable:<br/> +!> - tl_var\%t_dim(:) +!> +!> **Variable attributes**<br/> +!> @note attribue value are always character or real(8) 1D array.<br/> +!> +!> to get the number of attributes of the variable:<br/> +!> - tl_var\%i_natt +!> +!> to get the array of attribute structure associated to the +!> variable:<br/> +!> - tl_var\%t_att(:) +!> +!> Some attribute are highlight, to be easily used. +!> to get variable standard name:<br/> +!> - tl_var\%c_stdname +!> +!> to get variable longname:<br/> +!> - tl_var\%c_longname +!> +!> to get variable units:<br/> +!> - tl_var\%c_units +!> +!> to get variable axis:<br/> +!> - tl_var\%c_axis +!> +!> to get variable scale factor:<br/> +!> - tl_var\%d_scf +!> +!> to get variable add offset:<br/> +!> - tl_var\%d_ofs +!> +!> to get variable FillValue:<br/> +!> - tl_var\%d_fill +!> +!> to add value to a variable structure:<br/> +!> @code +!> CALL var_add_value(tl_var, value, [id_type,] [id_start, [id_count]]) +!> @endcode +!> - value : 4D array of value (real(4), real(8), integer(1), integer(2), integer(4), integer(8)) +!> - id_type is the type of the variable to be used (default is the type +!> of array value) +!> - id_start : 1D array of the index in the variable from which the data +!> values will be read (integer(4), optional) +!> - id_count : 1D array of the number of indices selected along each +!> dimension (integer(4), optional) +!> +!> to add attribute to a variable structure:<br/> +!> @code +!> CALL var_add_att(tl_var, td_att) +!> @endcode +!> - td_att is an attribute structure, or array of attribute structure +!> +!> to add dimension to a variable structure:<br/> +!> @code +!> CALL var_add_dim(tl_var, td_dim) +!> @endcode +!> - td_dim is a dimension structure, or array of dimension structure +!> +!> to delete value of a variable structure:<br/> +!> @code +!> CALL var_del_value(tl_var) +!> @endcode +!> +!> to delete one attribute of a variable structure:<br/> +!> @code +!> CALL var_del_att(tl_var, td_att) +!> @endcode +!> - td_att is an attribute structure +!> or +!> @code +!> CALL var_del_att(tl_var, cd_name) +!> @endcode +!> - cd_name is attribute name +!> +!> to delete one dimension of a variable structure:<br/> +!> @code +!> CALL var_del_dim(tl_var, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to overwrite one attribute structure in variable structure:<br/> +!> @code +!> CALL var_move_att(tl_var, td_att) +!> @endcode +!> - td_att is an attribute structure +!> +!> to overwrite one dimension structure in variable structure:<br/> +!> @code +!> CALL var_move_dim(tl_var, td_dim) +!> @endcode +!> - td_dim is a dimension structure +!> +!> to get the mask of a variable strucutre, (based on its FillValue):<br/> +!> @code +!> mask(:,:)=var_get_mask(tl_var) +!> @endcode +!> +!> to change FillValue to standard NETCDF Fill Value:<br/> +!> @code +!> CALL var_chg_FillValue(tl_var, [dd_fill]) +!> @endcode +!> - dd_fill is the FillValue to be used [optional] +!> +!> to concatenate two variables:<br/> +!> @code +!> tl_var=var_concat(tl_var1, tl_var2, [DIM]) +!> @endcode +!> - tl_var1 : variable structure +!> - tl_var2 : variable structure +!> - DIM : number of the dimension following which concatenate (1=>I, 2=>J, 3=>Z, 4=>T) [optional, default=4] +!> +!> to forced min and max value of a variable:<br/> +!> - define min and max value of the variable:<br/> +!> - tl_var\%d_min=min<br/> +!> - tl_var\%d_max=max<br/> +!> - min and max : real(8) value +!> - then <br/> +!> @code +!> CALL var_limit_value( tl_var ) +!> @endcode +!> +!> to get the biggest dimensions use in a array of variable:<br/> +!> @code +!> tl_dim(:)=var_max_dim(tl_var(:)) +!> @endcode +!> - tl_var(:) : array of variable structure +!> - tl_dim(:) : array (4 elts) of dimension structure +!> +!> to reorder dimension of a variable (default 'x','y','z','t'):<br/> +!> @code +!> CALL var_reorder( td_var, cd_dimorder ) +!> @endcode +!> - td_var is variable structure +!> - cd_dimorder string character(LEN=4) of dimension order to be used (example: +!> 'yxzt') [optional] +!> +!> to get variable index, in an array of variable structure:<br/> +!> @code +!> il_index=var_get_index( td_var, cd_name ) +!> @endcode +!> - td_var array of variable structure +!> - cd_name variable name +!> +!> to get variable id, read from a file:<br/> +!> @code +!> il_id=var_get_id( td_var, cd_name ) +!> @endcode +!> - td_var array of variable structure +!> - cd_name variable name +!> +!> to get free variable unit in an array of variable structure:<br/> +!> @code +!> il_unit=var_get_unit(td_var) +!> @endcode +!> - td_var array of variable structure +!> +!> to convert time variable structure in date structure:<br/> +!> @code +!> tl_date=var_to_date(td_var) +!> @endcode +!> - td_var is time variable structure +!> - tl_date is date structure +!> +!> to read matrix value from character string in namelist +!> @code +!> CALL var_read_matrix(td_var, cd_matrix) +!> @endcode +!> - td_var is variable structure +!> - cd_matrix is matrix value +!> +!> to read variable configuration file ('variable.cfg') and fill global array +!> of variable structure:<br/> +!> @code +!> CALL var_def_extra( cd_file ) +!> @endcode +!> - cd_file is filename +!> +!> to add variable information get from namelist, in global array of variable +!> structure: +!> @code +!> CALL var_chg_extra( cd_varinfo ) +!> @endcode +!> - cd_varinfo is variable information from namelist +!> +!> to clean global array of variable structure:<br/> +!> @code +!> CALL var_clean_extra( ) +!> @endcode +!> +!> to check variable dimension expected, as defined in file 'variable.cfg':<br/> +!> @code +!> CALL var_check_dim( td_var ) +!> @endcode +!> - td_var is variable structure +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date September, 2014 +!> - add var_reorder +!> @date November, 2014 +!> - Fix memory leaks bug +!> @date June, 2015 +!> - change way to get variable information in namelist +!> @date July, 2015 +!> - add subroutine var_chg_unit to change unit of output variable +!> @date Spetember, 2015 +!> - manage useless (dummy) variable +!> @date October, 2016 +!> - add subroutine to clean global array of extra information. +!> - define logical for variable to be used +!> @date May, 2019 +!> - read number of element for each dummy array in configuration file +!> +!> @todo +!> - var_copy_value qui copie le tableau de valeur mais verifie que tous les +!> attribut sont egaux +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE var + + USE netcdf ! nf90 library + USE global ! global variable + USE kind ! F90 kind parameter + USE logger ! log file manager + USE date ! date manager + USE fct ! basic useful function + USE att ! attribute manager + USE dim ! dimension manager + USE math ! mathematical function + + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + PUBLIC :: TVAR !< variable structure + + PUBLIC :: tg_varextra !< array of variable structure with extra information. + + PRIVATE :: im_ndumvar !< number of elt in dummy variable array + PRIVATE :: cm_dumvar !< dummy variable array + + ! function and subroutine + PUBLIC :: var_init !< initialize variable structure + PUBLIC :: var_print !< print variable information + PUBLIC :: var_clean !< clean variable structure + PUBLIC :: var_copy !< copy variable structure + PUBLIC :: var_add_value !< add array of value in variable structure + PUBLIC :: var_add_att !< add attribute structure in variable structure + PUBLIC :: var_add_dim !< add dimension structure in variable structure + PUBLIC :: var_del_value !< delete array of value of variable structure + PUBLIC :: var_del_att !< delete one attribute structure of variable structure + PUBLIC :: var_del_dim !< delete one dimension structure of variable structure + PUBLIC :: var_move_att !< overwrite one attribute structure in variable structure + PUBLIC :: var_move_dim !< overwrite one dimension structure in variable structure + PUBLIC :: var_get_mask !< return the mask of variable + PUBLIC :: var_chg_FillValue !< change FillValue to standard NETCDF Fill Value + PUBLIC :: var_concat !< concatenate two variables + PUBLIC :: var_limit_value !< forced min and max value + PUBLIC :: var_chg_unit !< change variable unit and value + PUBLIC :: var_chg_name !< change variable name + PUBLIC :: var_max_dim !< get array of maximum dimension use + PUBLIC :: var_reorder !< reorder table of value in variable structure + PUBLIC :: var_get_index !< return the variable index, in an array of variable structure + PUBLIC :: var_get_id !< return the variable id, read from a file + PUBLIC :: var_get_unit !< get free variable unit in an array of variable structure + PUBLIC :: var_to_date !< convert time variable structure in date structure + PUBLIC :: var_read_matrix !< read matrix value from character string in namelist + PUBLIC :: var_def_extra !< read variable configuration file, and save extra information. + PUBLIC :: var_chg_extra !< read variable namelist information, and modify extra information. + PUBLIC :: var_clean_extra !< clean gloabl array of extra information. + PUBLIC :: var_check_dim !< check variable dimension expected + PUBLIC :: var_get_dummy !< fill dummy variable array + PUBLIC :: var_is_dummy !< check if variable is defined as dummy variable + + PRIVATE :: var__init ! initialize variable structure without array of value + PRIVATE :: var__init_dp ! initialize variable structure with real(8) 4D array of value + PRIVATE :: var__init_1D_dp ! initialize variable structure with real(8) 1D array of value + PRIVATE :: var__init_2D_dp ! initialize variable structure with real(8) 2D array of value + PRIVATE :: var__init_3D_dp ! initialize variable structure with real(8) 3D array of value + PRIVATE :: var__init_sp ! initialize variable structure with real(4) 4D array of value + PRIVATE :: var__init_1D_sp ! initialize variable structure with real(4) 1D array of value + PRIVATE :: var__init_2D_sp ! initialize variable structure with real(4) 2D array of value + PRIVATE :: var__init_3D_sp ! initialize variable structure with real(4) 3D array of value + PRIVATE :: var__init_i1 ! initialize variable structure with integer(1) 4D array of value + PRIVATE :: var__init_1D_i1 ! initialize variable structure with integer(1) 1D array of value + PRIVATE :: var__init_2D_i1 ! initialize variable structure with integer(1) 2D array of value + PRIVATE :: var__init_3D_i1 ! initialize variable structure with integer(1) 3D array of value + PRIVATE :: var__init_i2 ! initialize variable structure with integer(2) 4D array of value + PRIVATE :: var__init_1D_i2 ! initialize variable structure with integer(2) 1D array of value + PRIVATE :: var__init_2D_i2 ! initialize variable structure with integer(2) 2D array of value + PRIVATE :: var__init_3D_i2 ! initialize variable structure with integer(2) 3D array of value + PRIVATE :: var__init_i4 ! initialize variable structure with integer(4) 4D array of value + PRIVATE :: var__init_1D_i4 ! initialize variable structure with integer(4) 1D array of value + PRIVATE :: var__init_2D_i4 ! initialize variable structure with integer(4) 2D array of value + PRIVATE :: var__init_3D_i4 ! initialize variable structure with integer(4) 3D array of value + PRIVATE :: var__init_i8 ! initialize variable structure with integer(8) 4D array of value + PRIVATE :: var__init_1D_i8 ! initialize variable structure with integer(8) 1D array of value + PRIVATE :: var__init_2D_i8 ! initialize variable structure with integer(8) 2D array of value + PRIVATE :: var__init_3D_i8 ! initialize variable structure with integer(8) 3D array of value + PRIVATE :: var__print_unit ! print information on one variable + PRIVATE :: var__print_arr ! print information on a array of variables + PRIVATE :: var__clean_unit ! clean variable structure + PRIVATE :: var__clean_arr_1D ! clean 1D array of variable structure + PRIVATE :: var__clean_arr_2D ! clean 2D array of variable structure + PRIVATE :: var__clean_arr_3D ! clean 3D array of variable structure + PRIVATE :: var__add_value_dp ! add array of value real(8) in variable structure + PRIVATE :: var__add_value_rp ! add array of value real(4) in variable structure + PRIVATE :: var__add_value_i1 ! add array of value integer(1) in variable structure + PRIVATE :: var__add_value_i2 ! add array of value integer(2) in variable structure + PRIVATE :: var__add_value_i4 ! add array of value integer(4) in variable structure + PRIVATE :: var__add_value_i8 ! add array of value integer(8) in variable structure + PRIVATE :: var__add_att_unit ! add one attribute structure in variable structure + PRIVATE :: var__add_att_arr ! add a array of attribute structure in variable structure + PRIVATE :: var__del_att_name ! delete one attribute given attribute name + PRIVATE :: var__del_att_str ! delete one attribute given attribute structure + PRIVATE :: var__add_dim_unit ! add one dimension structure in variable structure + PRIVATE :: var__add_dim_arr ! add a array of dimension structure in variable structure + PRIVATE :: var__add_value ! add a 4D array of real(8) value in a variable structure. + PRIVATE :: var__copy_unit ! copy variable structure + PRIVATE :: var__copy_arr ! copy a array of variable structure + PRIVATE :: var__get_extra ! add extra information in variable structure + PRIVATE :: var__concat_i ! concatenate varibales in i-direction + PRIVATE :: var__concat_j ! concatenate varibales in j-direction + PRIVATE :: var__concat_k ! concatenate varibales in k-direction + PRIVATE :: var__concat_l ! concatenate varibales in l-direction + PRIVATE :: var__get_max ! get maximum value from namelist + PRIVATE :: var__get_min ! get minimum value from namelist + PRIVATE :: var__get_unf ! get scale factor value from namelist + PRIVATE :: var__get_unt ! get output unit from namelist + PRIVATE :: var__get_namout ! get output variable name from namelist + PRIVATE :: var__get_interp ! get interpolation method from namelist + PRIVATE :: var__get_extrap ! get extrapolation method from namelist + PRIVATE :: var__get_filter ! get filter method from namelist + + TYPE TVAR !< variable structure + + CHARACTER(LEN=lc) :: c_name = '' !< variable name + CHARACTER(LEN=lc) :: c_point = 'T' !< ARAKAWA C-grid point name (T,U,V,F) + INTEGER(i4) :: i_id = 0 !< variable id + INTEGER(i4) :: i_ew = -1 !< east-west overlap + + REAL(dp) , DIMENSION(:,:,:,:), POINTER :: d_value => NULL() !< variable value + + !!! netcdf + INTEGER(i4) :: i_type = 0 !< variable type + INTEGER(i4) :: i_natt = 0 !< number of attributes + INTEGER(i4) :: i_ndim = 0 !< number of dimensions + TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< variable attributes + TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< variable dimension + + LOGICAL :: l_file = .FALSE. !< variable read in a file + LOGICAL :: l_use = .TRUE. !< variable to be used + + ! highlight some attributes + CHARACTER(LEN=lc) :: c_stdname = ''!< variable standard name + CHARACTER(LEN=lc) :: c_longname = ''!< variable long name + CHARACTER(LEN=lc) :: c_units = ''!< variable units + CHARACTER(LEN=lc) :: c_axis = ''!< variable axis + REAL(dp) :: d_scf = 1. !< scale factor + REAL(dp) :: d_ofs = 0. !< offset + REAL(dp) :: d_fill= 0. !< fill value ! NF90_FILL_DOUBLE + REAL(dp) :: d_min = dp_fill !< minimum value + REAL(dp) :: d_max = dp_fill !< maximum value + + ! will be changed in output + CHARACTER(LEN=lc) :: c_unt = '' !< output variable unit (linked to unit factor) + REAL(dp) :: d_unf = 1._dp !< unit factor + + CHARACTER(LEN=lc) :: c_namout = '' !< output variable name (renamed variable) + + !!! netcdf4 + LOGICAL :: l_contiguous = .FALSE. !< use contiguous storage or not + LOGICAL :: l_shuffle = .FALSE. !< shuffle filter is turned on or not + LOGICAL :: l_fletcher32 = .FALSE. !< fletcher32 filter is turned on or not + INTEGER(i4) :: i_deflvl = 0 !< deflate level from 0 to 9, 0 indicates no deflation is in use + INTEGER(i4), DIMENSION(ip_maxdim) :: i_chunksz = (/1,1,1,1/) !< chunk size + + !!! dimg + INTEGER(i4) :: i_rec = 0 !< record number + + CHARACTER(LEN=lc), DIMENSION(2) :: c_interp = '' !< interpolation method + CHARACTER(LEN=lc), DIMENSION(1) :: c_extrap = '' !< extrapolation method + CHARACTER(LEN=lc), DIMENSION(5) :: c_filter = '' !< filter method + + END TYPE TVAR + + TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tg_varextra !< array of variable structure with extra information. + !< fill when running var_def_extra() + + INTEGER(i4) , SAVE :: im_ndumvar !< number of elt in dummy variable array + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg), SAVE :: cm_dumvar !< dummy variable + + INTERFACE var_init + MODULE PROCEDURE var__init ! initialize variable structure without array of value + MODULE PROCEDURE var__init_dp ! initialize variable structure with real(8) 4D array of value + MODULE PROCEDURE var__init_1D_dp ! initialize variable structure with real(8) 1D array of value + MODULE PROCEDURE var__init_2D_dp ! initialize variable structure with real(8) 2D array of value + MODULE PROCEDURE var__init_3D_dp ! initialize variable structure with real(8) 3D array of value + MODULE PROCEDURE var__init_sp ! initialize variable structure with real(4) 4D array of value + MODULE PROCEDURE var__init_1D_sp ! initialize variable structure with real(4) 1D array of value + MODULE PROCEDURE var__init_2D_sp ! initialize variable structure with real(4) 2D array of value + MODULE PROCEDURE var__init_3D_sp ! initialize variable structure with real(4) 3D array of value + MODULE PROCEDURE var__init_i1 ! initialize variable structure with integer(1) 4D array of value + MODULE PROCEDURE var__init_1D_i1 ! initialize variable structure with integer(1) 1D array of value + MODULE PROCEDURE var__init_2D_i1 ! initialize variable structure with integer(1) 2D array of value + MODULE PROCEDURE var__init_3D_i1 ! initialize variable structure with integer(1) 3D array of value + MODULE PROCEDURE var__init_i2 ! initialize variable structure with integer(2) 4D array of value + MODULE PROCEDURE var__init_1D_i2 ! initialize variable structure with integer(2) 1D array of value + MODULE PROCEDURE var__init_2D_i2 ! initialize variable structure with integer(2) 2D array of value + MODULE PROCEDURE var__init_3D_i2 ! initialize variable structure with integer(2) 3D array of value + MODULE PROCEDURE var__init_i4 ! initialize variable structure with integer(4) 4D array of value + MODULE PROCEDURE var__init_1D_i4 ! initialize variable structure with integer(4) 1D array of value + MODULE PROCEDURE var__init_2D_i4 ! initialize variable structure with integer(4) 2D array of value + MODULE PROCEDURE var__init_3D_i4 ! initialize variable structure with integer(4) 3D array of value + MODULE PROCEDURE var__init_i8 ! initialize variable structure with integer(8) 4D array of value + MODULE PROCEDURE var__init_1D_i8 ! initialize variable structure with integer(8) 1D array of value + MODULE PROCEDURE var__init_2D_i8 ! initialize variable structure with integer(8) 2D array of value + MODULE PROCEDURE var__init_3D_i8 ! initialize variable structure with integer(8) 3D array of value + END INTERFACE var_init + + INTERFACE var_print + MODULE PROCEDURE var__print_unit ! print information on one variable + MODULE PROCEDURE var__print_arr ! print information on a array of variables + END INTERFACE var_print + + INTERFACE var_clean + MODULE PROCEDURE var__clean_unit + MODULE PROCEDURE var__clean_arr_1D + MODULE PROCEDURE var__clean_arr_2D + MODULE PROCEDURE var__clean_arr_3D + END INTERFACE + + INTERFACE var_add_value + MODULE PROCEDURE var__add_value_dp ! add array of value real(8) in variable structure + MODULE PROCEDURE var__add_value_rp ! add array of value real(4) in variable structure + MODULE PROCEDURE var__add_value_i1 ! add array of value integer(1) in variable structure + MODULE PROCEDURE var__add_value_i2 ! add array of value integer(2) in variable structure + MODULE PROCEDURE var__add_value_i4 ! add array of value integer(4) in variable structure + MODULE PROCEDURE var__add_value_i8 ! add array of value integer(8) in variable structure + END INTERFACE var_add_value + + INTERFACE var_add_att + MODULE PROCEDURE var__add_att_unit ! add one attribute structure in variable structure + MODULE PROCEDURE var__add_att_arr ! add a array of attribute structure in variable structure + END INTERFACE var_add_att + + INTERFACE var_del_att ! delete one attribute in variable structure + MODULE PROCEDURE var__del_att_name ! - given attribute name + MODULE PROCEDURE var__del_att_str ! - given attribute structure + END INTERFACE var_del_att + + INTERFACE var_add_dim + MODULE PROCEDURE var__add_dim_unit ! add one dimension structure in variable structure + MODULE PROCEDURE var__add_dim_arr ! add a array of dimension structure in variable structure + END INTERFACE var_add_dim + + INTERFACE var_copy + MODULE PROCEDURE var__copy_unit ! copy variable structure + MODULE PROCEDURE var__copy_arr ! copy variable structure + END INTERFACE +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__copy_unit(td_var, ld_value) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy variable structure in another one + !> @details + !> variable values are copied in a transitional variable, so input and output + !> variable structure values do not point on the same "memory cell", and so + !> are independant. + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_var=var_copy(var_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator (to avoid memory leak) + !> @date July, 2017 + !> - permit to copy variable structure without value + !> @date January, 2019 + !> - use scalar instead of array, as transitional variable + !> @date February, 2019 + !> - copy namout + !> + !> @param[in] td_var variable structure + !> @param[in] ld_value copy variable value (default .TRUE.) + !> @return copy of input variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + LOGICAL , INTENT(IN), OPTIONAL :: ld_value + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TATT) :: tl_att + REAL(dp) :: dl_value + LOGICAL :: ll_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ll_value=.TRUE. + IF( PRESENT(ld_value) ) ll_value=ld_value + ! copy variable name, id, .. + tf_var%c_name = TRIM(td_var%c_name) + tf_var%c_point = TRIM(td_var%c_point) + tf_var%i_id = td_var%i_id + tf_var%i_ew = td_var%i_ew + + tf_var%d_min = td_var%d_min + tf_var%d_max = td_var%d_max + + tf_var%c_unt = TRIM(td_var%c_unt) + tf_var%d_unf = td_var%d_unf + + tf_var%c_namout = TRIM(td_var%c_namout) + + tf_var%i_type = td_var%i_type + tf_var%i_natt = td_var%i_natt + tf_var%i_ndim = td_var%i_ndim + tf_var%i_ndim = td_var%i_ndim + + ! copy dimension + tf_var%t_dim(:) = dim_copy(td_var%t_dim(:)) + + ! copy attribute + IF( ASSOCIATED(tf_var%t_att) )THEN + CALL att_clean( tf_var%t_att(:) ) + DEALLOCATE(tf_var%t_att) + ENDIF + IF( ASSOCIATED(td_var%t_att) .AND. tf_var%i_natt > 0 )THEN + ALLOCATE( tf_var%t_att(tf_var%i_natt) ) + DO ji=1,tf_var%i_natt + tl_att=att_copy(td_var%t_att(ji)) + tf_var%t_att(ji)=att_copy(tl_att) + ENDDO + ! clean + CALL att_clean(tl_att) + ENDIF + + tf_var%l_file = td_var%l_file + tf_var%l_use = td_var%l_use + + ! copy highlight attribute + tf_var%c_stdname = TRIM(td_var%c_stdname) + tf_var%c_longname = TRIM(td_var%c_longname) + tf_var%c_units = TRIM(td_var%c_units) + tf_var%c_axis = TRIM(td_var%c_axis) + tf_var%d_unf = td_var%d_unf + tf_var%d_scf = td_var%d_scf + tf_var%d_ofs = td_var%d_ofs + tf_var%d_fill = td_var%d_fill + + ! copy netcdf4 variable + tf_var%l_contiguous = td_var%l_contiguous + tf_var%l_shuffle = td_var%l_shuffle + tf_var%l_fletcher32 = td_var%l_fletcher32 + tf_var%i_deflvl = td_var%i_deflvl + tf_var%i_chunksz(:) = td_var%i_chunksz(:) + + ! copy dimg variable + tf_var%i_rec = td_var%i_rec + + ! copy pointer in an independant variable + IF( ASSOCIATED(tf_var%d_value) ) DEALLOCATE(tf_var%d_value) + IF( ll_value .AND. ASSOCIATED(td_var%d_value) )THEN + ALLOCATE( tf_var%d_value( tf_var%t_dim(1)%i_len, & + & tf_var%t_dim(2)%i_len, & + & tf_var%t_dim(3)%i_len, & + & tf_var%t_dim(4)%i_len ) ) + DO jl=1,td_var%t_dim(4)%i_len + DO jk=1,td_var%t_dim(3)%i_len + DO jj=1,td_var%t_dim(2)%i_len + DO ji=1,td_var%t_dim(1)%i_len + dl_value=td_var%d_value(ji,jj,jk,jl) + tf_var%d_value(ji,jj,jk,jl)=dl_value + ENDDO + ENDDO + ENDDO + ENDDO + + ENDIF + + tf_var%c_interp(:)=td_var%c_interp(:) + tf_var%c_extrap(:)=td_var%c_extrap(:) + tf_var%c_filter(:)=td_var%c_filter(:) + + END FUNCTION var__copy_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__copy_arr(td_var) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine copy a array of variable structure in another one + !> @details + !> see var__copy_unit + !> + !> @warning do not use on the output of a function who create or read an + !> structure (ex: tl_var=var_copy(var_init()) is forbidden). + !> This will create memory leaks. + !> @warning to avoid infinite loop, do not use any function inside + !> this subroutine + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date November, 2014 + !> - use function instead of overload assignment operator + !> (to avoid memory leak) + !> + !> @param[in] td_var array of variable structure + !> @return copy of input array of variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_var + + ! function + TYPE(TVAR), DIMENSION(SIZE(td_var(:))) :: tf_var + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_var(:)) + tf_var(ji)=var_copy(td_var(ji)) + ENDDO + + END FUNCTION var__copy_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__clean_unit(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine clean variable structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - nullify attributes structure inside variable strcuture + !> + !> @param[inout] td_var variable strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + TYPE(TVAR) :: tl_var ! empty variable strucutre + + ! loop indices + !---------------------------------------------------------------- + + ! del attribute + IF( ASSOCIATED(td_var%t_att) )THEN + CALL att_clean( td_var%t_att(:) ) + DEALLOCATE(td_var%t_att) + NULLIFY(td_var%t_att) + ENDIF + + ! del dimension + IF( td_var%i_ndim /= 0 )THEN + CALL dim_clean(td_var%t_dim(:)) + ENDIF + + ! del value + IF( ASSOCIATED(td_var%d_value) )THEN + CALL var_del_value(td_var) + ENDIF + + ! replace by empty structure + td_var=var_copy(tl_var) + + END SUBROUTINE var__clean_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__clean_arr_1D(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine clean 1D array of variable structure + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] td_var array of variable strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(INOUT) :: td_var + + ! local variable + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=SIZE(td_var(:)),1,-1 + CALL var_clean(td_var(ji)) + ENDDO + + END SUBROUTINE var__clean_arr_1D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__clean_arr_2D(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine clean 2D array of variable structure + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] td_var array of variable strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:,:), INTENT(INOUT) :: td_var + + ! local variable + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + DO jj=SIZE(td_var(:,:),DIM=2),1,-1 + DO ji=SIZE(td_var(:,:),DIM=1),1,-1 + CALL var_clean(td_var(ji,jj)) + ENDDO + ENDDO + + END SUBROUTINE var__clean_arr_2D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__clean_arr_3D(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine clean 3D array of variable structure + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[inout] td_var array of variable strucutre + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:,:,:), INTENT(INOUT) :: td_var + + ! local variable + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + DO jk=SIZE(td_var(:,:,:),DIM=3),1,-1 + DO jj=SIZE(td_var(:,:,:),DIM=2),1,-1 + DO ji=SIZE(td_var(:,:,:),DIM=1),1,-1 + CALL var_clean(td_var(ji,jj,jk)) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE var__clean_arr_3D + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init(cd_name, id_type, td_dim, & + & td_att, dd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, given variable name. + !> + !> @details + !> Optionally you could add 1D,2D,3D or 4D array of value, + !> see var__init_1D_dp, var__init_2D_dp... for more information. + !> + !> you could also add more information with the following optional arguments: + !> - id_type : integer(4) variable type, (as defined by NETCDF type constants). + !> - td_dim : array of dimension structure. + !> - td_att : array of attribute structure. + !> - dd_fill : real(8) variable FillValue. if none NETCDF FillValue will be used. + !> - cd_units : string character of units. + !> - cd_axis : string character of axis expected to be used + !> - cd_stdname : string character of variable standard name. + !> - cd_longname : string character of variable long name. + !> - cd_point : one character for ARAKAWA C-grid point name (T,U,V,F). + !> - id_id : variable id (read from a file). + !> - id_ew : number of point composing east west wrap band. + !> - dd_unf : real(8) value for units factor attribute. + !> - dd_scf : real(8) value for scale factor attribute. + !> - dd_ofs : real(8) value for add offset attribute. + !> - id_rec : record id (for rstdimg file). + !> - dd_min : real(8) value for minimum value. + !> - dd_max : real(8) value for maximum value. + !> - ld_contiguous : use contiguous storage or not (for netcdf4). + !> - ld_shuffle : shuffle filter is turned on or not (for netcdf4). + !> - ld_fletcher32 : fletcher32 filter is turned on or not (for netcdf4). + !> - id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use (for netcdf4). + !> - id_chunksz : chunk size (for netcdf4). + !> - cd_interp : a array of character defining interpolation method. + !> - cd_extrap : a array of character defining extrapolation method. + !> - cd_filter : a array of character defining filtering method. + !> - cd_unt : a string character to define output unit + !> - dd_unf : real(8) factor applied to change unit + !> + !> @note most of these optionals arguments will be inform automatically, + !> when reading variable from a file, or using confiuguration file variable.cfg. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - Bug fix: conversion of the FillValue type (float case) + !> @date June, 2015 + !> - add unit factor (to change unit) + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] dd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt output unit (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_ind + + TYPE(TATT) :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + tf_var%c_name=TRIM(ADJUSTL(cd_name)) + + ! standard name + IF( PRESENT(cd_stdname) )THEN + tf_var%c_stdname=TRIM(ADJUSTL(cd_stdname)) + ENDIF + + ! long name + IF( PRESENT(cd_longname) )THEN + tf_var%c_longname=TRIM(ADJUSTL(cd_longname)) + ENDIF + + ! point + IF( PRESENT(cd_point) )THEN + tf_var%c_point=TRIM(ADJUSTL(cd_point)) + ENDIF + + ! variable id + IF( PRESENT(id_id) )THEN + tf_var%i_id=id_id + ENDIF + + ! east west wrap + IF( PRESENT(id_ew) )THEN + tf_var%i_ew=id_ew + ENDIF + + ! type + IF( PRESENT(id_type) )THEN + tf_var%i_type=id_type + ELSE + tf_var%i_type=NF90_DOUBLE + ENDIF + + ! add attribute + IF( PRESENT(td_att) )THEN + CALL var_add_att(tf_var, td_att(:)) + ENDIF + + ! add _FillValue + IF( PRESENT(dd_fill) )THEN + SELECT CASE( tf_var%i_type ) + CASE(NF90_BYTE) + tl_att=att_init('_FillValue', INT(dd_fill,i1) ) + CASE(NF90_SHORT) + tl_att=att_init('_FillValue', INT(dd_fill,i2) ) + CASE(NF90_INT) + tl_att=att_init('_FillValue', INT(dd_fill,i4) ) + CASE(NF90_FLOAT) + tl_att=att_init('_FillValue', REAL(dd_fill,sp) ) + CASE DEFAULT ! NF90_DOUBLE + tl_att=att_init('_FillValue', dd_fill ) + END SELECT + CALL var_move_att(tf_var, tl_att) + ELSE + il_ind=0 + IF( ASSOCIATED(tf_var%t_att) )THEN + il_ind=att_get_index(tf_var%t_att(:),'_FillValue') + ENDIF + IF( il_ind == 0 )THEN + SELECT CASE( tf_var%i_type ) + CASE(NF90_BYTE) + tl_att=att_init('_FillValue',NF90_FILL_BYTE) + CASE(NF90_SHORT) + tl_att=att_init('_FillValue',NF90_FILL_SHORT) + CASE(NF90_INT) + tl_att=att_init('_FillValue',NF90_FILL_INT) + CASE(NF90_FLOAT) + tl_att=att_init('_FillValue',NF90_FILL_FLOAT) + CASE DEFAULT ! NF90_DOUBLE + tl_att=att_init('_FillValue',NF90_FILL_DOUBLE) + END SELECT + CALL var_add_att(tf_var, tl_att) + ENDIF + ENDIF + + ! scale factor + IF( PRESENT(dd_scf) )THEN + tl_att=att_init('scale_factor',dd_scf) + CALL var_move_att(tf_var, tl_att) + ENDIF + + ! add offset + IF( PRESENT(dd_ofs) )THEN + tl_att=att_init('add_offset',dd_ofs) + CALL var_move_att(tf_var, tl_att) + ENDIF + + IF( PRESENT(cd_units) )THEN + tl_att=att_init('units',cd_units) + CALL var_move_att(tf_var, tl_att) + ENDIF + + IF( PRESENT(cd_axis) )THEN + tf_var%c_axis=TRIM(cd_axis) + ENDIF + + ! add dimension + IF( PRESENT(td_dim) )THEN + CALL var_add_dim(tf_var, td_dim(:)) + ELSE + CALL var_add_dim(tf_var, dim_fill_unused()) + ENDIF + + IF( PRESENT(id_rec) )THEN + tf_var%i_rec=id_rec + ENDIF + + ! add minimum value + IF( PRESENT(dd_min) )THEN + tf_var%d_min=dd_min + ENDIF + + ! add maximum value + IF( PRESENT(dd_max) )THEN + tf_var%d_max=dd_max + ENDIF + + ! netcdf4 + IF( PRESENT(ld_contiguous) )THEN + tf_var%l_contiguous=ld_contiguous + ENDIF + + IF( PRESENT(ld_shuffle) )THEN + tf_var%l_shuffle=ld_shuffle + ENDIF + + IF( PRESENT(ld_fletcher32) )THEN + tf_var%l_fletcher32=ld_fletcher32 + ENDIF + + IF( PRESENT(id_deflvl) )THEN + tf_var%i_deflvl=id_deflvl + ENDIF + + IF( PRESENT(id_chunksz) )THEN + tf_var%i_chunksz(:)=id_chunksz(:) + ENDIF + + ! interp + IF( PRESENT(cd_interp) )THEN + tf_var%c_interp(:)=cd_interp(:) + ENDIF + + !extrap + IF( PRESENT(cd_extrap) )THEN + tf_var%c_extrap(:)=cd_extrap(:) + ENDIF + + !filter + IF( PRESENT(cd_filter) )THEN + tf_var%c_filter(:)=cd_filter(:) + ENDIF + + ! unit factor + IF( PRESENT(dd_unf) )THEN + tl_att=att_init('units_factor',dd_unf) + CALL var_move_att(tf_var, tl_att) + ENDIF + + ! output unit (linked to unit factor) + IF( PRESENT(cd_unt) )THEN + tl_att=att_init('new_units',cd_unt) + CALL var_move_att(tf_var, tl_att) + ENDIF + + ! output name (renamed variable) + IF( PRESENT(cd_unt) )THEN + tl_att=att_init('output_name',cd_namout) + CALL var_move_att(tf_var, tl_att) + ENDIF + + ! add extra information + CALL var__get_extra(tf_var) + + ! delete some attribute cause linked to file where variable come from + CALL var_del_att(tf_var, 'refinment_factor') + CALL var_del_att(tf_var, 'interpolation') + CALL var_del_att(tf_var, 'extrapolation') + CALL var_del_att(tf_var, 'filter') + CALL var_del_att(tf_var, 'src_file') + CALL var_del_att(tf_var, 'src_i_indices') + CALL var_del_att(tf_var, 'src_j_indices') + CALL var_del_att(tf_var, 'valid_min') + CALL var_del_att(tf_var, 'valid_max') + CALL var_del_att(tf_var, 'missing_value') + + ! clean + CALL att_clean(tl_att) + + END FUNCTION var__init + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_dp(cd_name, dd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, dd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(8) 1D array of value. + !> @details + !> Optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date November, 2016 + !> - allow to add scalar value + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] dd_value 1D array of real(8) value + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] dd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , DIMENSION(:) , INTENT(IN) :: dd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + ! dummy call to avoid warning + il_type=NF90_DOUBLE + IF( PRESENT(id_type) ) il_type=id_type + + tl_dim(1)=dim_init( 'Z', id_len=SIZE(dd_value(:)) ) + IF( PRESENT(td_dim) )THEN + tl_dim(1)=dim_copy(td_dim) + ENDIF + + il_start(:)=1 + IF( PRESENT(id_start) )THEN + il_start(1)=id_start + ENDIF + + il_count(:)=tl_dim(:)%i_len + IF( PRESENT(id_count) )THEN + il_count(1)=id_count + ENDIF + + ! reorder dimension + CALL dim_reorder(tl_dim(:)) + ! reorder array + il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:)) + il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:)) + + tf_var=var__init( cd_name, id_type=il_type, & + & td_dim=tl_dim(:), td_att=td_att, & + & dd_fill=dd_fill, cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + ! add value + ALLOCATE( dl_value(tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + IF( tl_dim(1)%l_use )THEN + dl_value(:,1,1,1) = dd_value(:) + ELSEIF( tl_dim(2)%l_use )THEN + dl_value(1,:,1,1) = dd_value(:) + ELSEIF( tl_dim(3)%l_use )THEN + dl_value(1,1,:,1) = dd_value(:) + ELSEIF( tl_dim(4)%l_use )THEN + dl_value(1,1,1,:) = dd_value(:) + ELSE + IF( SIZE(dd_value(:)) > 1 )THEN + CALL logger_fatal("VAR INIT: can not add value from variable "//& + & TRIM(cd_name)//". invalid dimension to be used") + ELSE + dl_value(1,1,1,1) = dd_value(1) + CALL logger_warn("VAR INIT: add scalar value for variable "//& + & TRIM(cd_name)) + + ENDIF + ENDIF + + CALL var_add_value( tf_var, dl_value(:,:,:,:), il_type, & + & il_start(:), il_count(:) ) + + ! clean + DEALLOCATE( dl_value ) + CALL dim_clean(tl_dim) + + END FUNCTION var__init_1D_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_dp(cd_name, dd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, dd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(8) 2D array of value. + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> @details + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - bug fix: array initialise with dimension + !> array not only one value + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> - Bux fix: dimension array initialise not only one value + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] dd_value 1D array of real(8) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] dd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates + !> no deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , DIMENSION(:,:) , INTENT(IN) :: dd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + ! dummy call to avoid warning + il_type=NF90_DOUBLE + IF( PRESENT(id_type) ) il_type=id_type + + tl_dim(1)=dim_init( 'X', id_len=SIZE(dd_value(:,:),DIM=1) ) + tl_dim(2)=dim_init( 'Y', id_len=SIZE(dd_value(:,:),DIM=2) ) + IF( PRESENT(td_dim) )THEN + IF( SIZE(td_dim(:)) /= 2 )THEN + CALL logger_error("VAR INIT: dimension of dimension structure "//& + & " not conform") + ELSE + tl_dim(1)=dim_copy(td_dim(1)) + tl_dim(2)=dim_copy(td_dim(2)) + ENDIF + ENDIF + + il_start(:)=1 + IF( PRESENT(id_start) )THEN + IF( SIZE(id_start(:)) /= 2 )THEN + CALL logger_error("VAR INIT: dimension of start array "//& + & " not conform") + ELSE + il_start(1)=id_start(1) + il_start(2)=id_start(2) + ENDIF + ENDIF + + il_count(:)=tl_dim(:)%i_len + IF( PRESENT(id_count) )THEN + IF( SIZE(id_count(:)) /= 2 )THEN + CALL logger_error("VAR INIT: dimension of count array "//& + & " not conform") + ELSE + il_count(1)=id_count(1) + il_count(2)=id_count(2) + ENDIF + ENDIF + + ! reorder dimension + CALL dim_reorder(tl_dim(:)) + ! reorder array + il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:)) + il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:)) + + tf_var=var__init( cd_name, id_type=il_type, & + & td_dim=tl_dim(:), td_att=td_att, & + & dd_fill=dd_fill, cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + ! add value + ALLOCATE( dl_value(tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + IF( tl_dim(1)%l_use .AND. tl_dim(2)%l_use )THEN + dl_value(:,:,1,1)=dd_value(:,:) + ELSEIF( tl_dim(1)%l_use .AND. tl_dim(3)%l_use )THEN + dl_value(:,1,:,1)=dd_value(:,:) + ELSEIF( tl_dim(1)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(:,1,1,:)=dd_value(:,:) + ELSEIF( tl_dim(2)%l_use .AND. tl_dim(3)%l_use )THEN + dl_value(1,:,:,1)=dd_value(:,:) + ELSEIF( tl_dim(2)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(1,:,1,:)=dd_value(:,:) + ELSEIF( tl_dim(3)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(1,1,:,:)=dd_value(:,:) + ELSE + CALL logger_fatal("VAR INIT: can not add value from variable "//& + & TRIM(cd_name)//". invalid dimension to be used") + ENDIF + + CALL var_add_value( tf_var, dl_value(:,:,:,:), il_type, & + & il_start(:), il_count(:) ) + + ! clean + DEALLOCATE( dl_value ) + CALL dim_clean(tl_dim) + + END FUNCTION var__init_2D_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_dp(cd_name, dd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, dd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(8) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] dd_value 1D array of real(8) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] dd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , DIMENSION(:,:,:) , INTENT(IN) :: dd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + ! dummy call to avoid warning + il_type=NF90_DOUBLE + IF( PRESENT(id_type) ) il_type=id_type + + tl_dim(1)=dim_init( 'X', id_len=SIZE(dd_value(:,:,:),DIM=1) ) + tl_dim(2)=dim_init( 'Y', id_len=SIZE(dd_value(:,:,:),DIM=2) ) + tl_dim(3)=dim_init( 'Z', id_len=SIZE(dd_value(:,:,:),DIM=3) ) + IF( PRESENT(td_dim) )THEN + IF( SIZE(td_dim(:)) /= 3 )THEN + CALL logger_error("VAR INIT: dimension of dimension structure "//& + & " not conform") + ELSE + tl_dim(1)=dim_copy(td_dim(1)) + tl_dim(2)=dim_copy(td_dim(2)) + tl_dim(3)=dim_copy(td_dim(3)) + ENDIF + ENDIF + + il_start(:)=1 + IF( PRESENT(id_start) )THEN + IF( SIZE(id_start(:)) /= 3 )THEN + CALL logger_error("VAR INIT: dimension of start array "//& + & " not conform") + ELSE + il_start(1)=id_start(1) + il_start(2)=id_start(2) + il_start(3)=id_start(3) + ENDIF + ENDIF + + il_count(:)=tl_dim(:)%i_len + IF( PRESENT(id_count) )THEN + IF( SIZE(id_count(:)) /= 3 )THEN + CALL logger_error("VAR INIT: dimension of count array "//& + & " not conform") + ELSE + il_count(1)=id_count(1) + il_count(2)=id_count(2) + il_count(3)=id_count(3) + ENDIF + ENDIF + + ! reorder dimension + CALL dim_reorder(tl_dim(:)) + ! reorder array + il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:)) + il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:)) + + tf_var=var__init( cd_name, id_type=il_type, & + & td_dim=tl_dim(:), td_att=td_att, & + & dd_fill=dd_fill, cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + ! add value + ALLOCATE( dl_value(tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len) ) + + IF( tl_dim(1)%l_use .AND. tl_dim(2)%l_use .AND. tl_dim(3)%l_use )THEN + dl_value(:,:,:,1)=dd_value(:,:,:) + ELSEIF( tl_dim(1)%l_use .AND. tl_dim(2)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(:,:,1,:)=dd_value(:,:,:) + ELSEIF( tl_dim(1)%l_use .AND. tl_dim(3)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(:,1,:,:)=dd_value(:,:,:) + ELSEIF( tl_dim(2)%l_use .AND. tl_dim(3)%l_use .AND. tl_dim(4)%l_use )THEN + dl_value(1,:,:,:)=dd_value(:,:,:) + ELSE + CALL logger_fatal("VAR INIT: can not add value from variable "//& + & TRIM(cd_name)//". invalid dimension to be used") + ENDIF + + CALL var_add_value( tf_var, dl_value(:,:,:,:), il_type, & + & il_start(:), il_count(:) ) + + ! clean + DEALLOCATE( dl_value ) + CALL dim_clean(tl_dim) + + END FUNCTION var__init_3D_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_dp(cd_name, dd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, dd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(8) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] dd_value 4D array of real(8) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] dd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(dp) , DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + TYPE(TDIM) :: tl_dim + + INTEGER(i4) :: il_type + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + ! dummy call to avoid warning + il_type=NF90_DOUBLE + IF( PRESENT(id_type) ) il_type=id_type + + tf_var=var__init( cd_name, id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dd_fill, cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + ! add value + IF( .NOT. PRESENT(td_dim) )THEN + il_shape(:)=SHAPE(dd_value(:,:,:,:)) + DO ji=1,ip_maxdim + tl_dim=dim_init( cp_dimorder(ji:ji), id_len=il_shape(ji)) + CALL var_add_dim(tf_var, tl_dim) + ENDDO + ENDIF + + CALL var_add_value( tf_var, dd_value(:,:,:,:), il_type, & + & id_start(:), id_count(:) ) + + ! clean + CALL dim_clean(tl_dim) + + END FUNCTION var__init_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_sp(cd_name, rd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, rd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(4) 1D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] rd_value 1D array of real(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] rd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp) , DIMENSION(:) , INTENT(IN) :: rd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_FLOAT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_FLOAT + IF( PRESENT(rd_fill) ) dl_fill=REAL(rd_fill,dp) + + il_shape=SIZE(rd_value(:)) + ALLOCATE( dl_value( il_shape) ) + + DO ji=1,il_shape + dl_value(ji)=REAL(rd_value(ji),dp) + ENDDO + + tf_var=var_init( cd_name, dl_value(:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_1D_sp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_sp(cd_name, rd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, rd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(4) 2D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name : variable name + !> @param[in] rd_value : 2D array of real(4) value + !> @param[in] id_start : index in the variable from which the + !> data values will be read + !> @param[in] id_count : number of indices selected along + !> each dimension + !> @param[in] id_type : variable type + !> @param[in] td_dim : array of dimension structure + !> @param[in] td_att : array of attribute structure + !> @param[in] rd_fill : fill value + !> @param[in] cd_units : units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname : variable standard name + !> @param[in] cd_longname : variable long name + !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id : variable id + !> @param[in] id_ew : east west wrap + !> @param[in] dd_scf : scale factor + !> @param[in] dd_ofs : add offset + !> @param[in] id_rec : record id (for rstdimg file) + !> @param[in] dd_min : minimum value + !> @param[in] dd_max : maximum value + !> @param[in] ld_contiguous : use contiguous storage or not + !> @param[in] ld_shuffle : shuffle filter is turned on or not + !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not + !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz : chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp) , DIMENSION(:,:) , INTENT(IN) :: rd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_FLOAT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_FLOAT + IF( PRESENT(rd_fill) ) dl_fill=REAL(rd_fill,dp) + + il_shape(:)=SHAPE(rd_value(:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj)=REAL(rd_value(ji,jj),dp) + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_2D_sp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_sp(cd_name, rd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, rd_fill, cd_units, cd_axis,& + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle,& + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(4) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name : variable name + !> @param[in] rd_value : 2D array of real(4) value + !> @param[in] id_start : index in the variable from which the + !> data values will be read + !> @param[in] id_count : number of indices selected along + !> each dimension + !> @param[in] id_type : variable type + !> @param[in] td_dim : array of dimension structure + !> @param[in] td_att : array of attribute structure + !> @param[in] rd_fill : fill value + !> @param[in] cd_units : units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname : variable standard name + !> @param[in] cd_longname : variable long name + !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id : variable id + !> @param[in] id_ew : east west wrap + !> @param[in] dd_scf : scale factor + !> @param[in] dd_ofs : add offset + !> @param[in] id_rec : record id (for rstdimg file) + !> @param[in] dd_min : minimum value + !> @param[in] dd_max : maximum value + !> @param[in] ld_contiguous : use contiguous storage or not + !> @param[in] ld_shuffle : shuffle filter is turned on or not + !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not + !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz : chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp) , DIMENSION(:,:,:) , INTENT(IN) :: rd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_FLOAT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_FLOAT + IF( PRESENT(rd_fill) ) dl_fill=REAL(rd_fill,dp) + + il_shape(:)=SHAPE(rd_value(:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk)=REAL(rd_value(ji,jj,jk),dp) + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_3D_sp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_sp(cd_name, rd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, rd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a real(4) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] rd_value 4D array of real(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] rd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + REAL(sp) , DIMENSION(:,:,:,:), INTENT(IN) :: rd_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_FLOAT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_FLOAT + IF( PRESENT(rd_fill) ) dl_fill=REAL(rd_fill,dp) + + il_shape(:)=SHAPE(rd_value(:,:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3), & + & il_shape(4)) ) + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(rd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_sp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_i8(cd_name, kd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, kd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(8) 1D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name : variable name + !> @param[in] kd_value : 1D array of integer(8) value + !> @param[in] id_start : index in the variable from which the + !> data values will be read + !> @param[in] id_count : number of indices selected along + !> each dimension + !> @param[in] id_type : variable type + !> @param[in] td_dim : array of dimension structure + !> @param[in] td_att : array of attribute structure + !> @param[in] kd_fill : fill value + !> @param[in] cd_units : units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname : variable standard name + !> @param[in] cd_longname : variable long name + !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id : variable id + !> @param[in] id_ew : east west wrap + !> @param[in] dd_scf : scale factor + !> @param[in] dd_ofs : add offset + !> @param[in] id_rec : record id (for rstdimg file) + !> @param[in] dd_min : minimum value + !> @param[in] dd_max : maximum value + !> @param[in] ld_contiguous : use contiguous storage or not + !> @param[in] ld_shuffle : shuffle filter is turned on or not + !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not + !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz : chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8) , DIMENSION(:) , INTENT(IN) :: kd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(kd_fill) ) dl_fill=REAL(kd_fill,dp) + + il_shape=SIZE(kd_value(:)) + ALLOCATE( dl_value( il_shape) ) + + DO ji=1,il_shape + dl_value(ji)=REAL(kd_value(ji),dp) + ENDDO + + tf_var=var_init( cd_name, dl_value(:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_1D_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_i8(cd_name, kd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, kd_fill, cd_units, cd_axis,& + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle,& + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(8) 2D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] kd_value 2D array of integer(8) value + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] kd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8) , DIMENSION(:,:) , INTENT(IN) :: kd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(kd_fill) ) dl_fill=REAL(kd_fill,dp) + + il_shape(:)=SHAPE(kd_value(:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj)=REAL(kd_value(ji,jj),dp) + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_2D_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_i8(cd_name, kd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, kd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(8) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] kd_value 2D array of integer(8) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] kd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8) , DIMENSION(:,:,:) , INTENT(IN) :: kd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(kd_fill) ) dl_fill=REAL(kd_fill,dp) + + il_shape(:)=SHAPE(kd_value(:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk)=REAL(kd_value(ji,jj,jk),dp) + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_3D_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_i8(cd_name, kd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, kd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(8) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] kd_value 4D array of integer(8) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] kd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i8) , DIMENSION(:,:,:,:), INTENT(IN) :: kd_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(kd_fill) ) dl_fill=REAL(kd_fill,dp) + + il_shape(:)=SHAPE(kd_value(:,:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3), & + & il_shape(4)) ) + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(kd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_i4(cd_name, id_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, id_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(4) 1D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] id_value 1D array of integer(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] id_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4) , DIMENSION(:) , INTENT(IN) :: id_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(id_fill) ) dl_fill=REAL(id_fill,dp) + + il_shape=SIZE(id_value(:)) + ALLOCATE( dl_value( il_shape) ) + + DO ji=1,il_shape + dl_value(ji)=REAL(id_value(ji),dp) + ENDDO + + tf_var=var_init( cd_name, dl_value(:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_1D_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_i4(cd_name, id_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, id_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(4) 2D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] id_value 2D array of integer(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] id_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4) , DIMENSION(:,:) , INTENT(IN) :: id_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(id_fill) ) dl_fill=REAL(id_fill,dp) + + il_shape(:)=SHAPE(id_value(:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj)=REAL(id_value(ji,jj),dp) + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_2D_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_i4(cd_name, id_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, id_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(4) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] id_value 3D array of integer(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] id_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4) , DIMENSION(:,:,:) , INTENT(IN) :: id_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(id_fill) ) dl_fill=REAL(id_fill,dp) + + il_shape(:)=SHAPE(id_value(:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk)=REAL(id_value(ji,jj,jk),dp) + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_3D_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_i4(cd_name, id_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, id_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(4) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] id_value 4D array of integer(4) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] id_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i4) , DIMENSION(:,:,:,:), INTENT(IN) :: id_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_INT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_INT + IF( PRESENT(id_fill) ) dl_fill=REAL(id_fill,dp) + + il_shape(:)=SHAPE(id_value(:,:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3), & + & il_shape(4)) ) + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(id_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_i2(cd_name, sd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, sd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(2) 1D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] sd_value 1D array of integer(2) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] sd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2) , DIMENSION(:) , INTENT(IN) :: sd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_SHORT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_SHORT + IF( PRESENT(sd_fill) ) dl_fill=REAL(sd_fill,dp) + + il_shape=SIZE(sd_value(:)) + ALLOCATE( dl_value( il_shape) ) + + DO ji=1,il_shape + dl_value(ji)=REAL(sd_value(ji),dp) + ENDDO + + tf_var=var_init( cd_name, dl_value(:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_1D_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_i2(cd_name, sd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, sd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(2) 2D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] sd_value 2D array of integer(2) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] sd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2) , DIMENSION(:,:) , INTENT(IN) :: sd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_SHORT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_SHORT + IF( PRESENT(sd_fill) ) dl_fill=REAL(sd_fill,dp) + + il_shape(:)=SHAPE(sd_value(:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj)=REAL(sd_value(ji,jj),dp) + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_2D_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_i2(cd_name, sd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, sd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(2) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] sd_value 3D array of integer(2) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] sd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2) , DIMENSION(:,:,:) , INTENT(IN) :: sd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_SHORT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_SHORT + IF( PRESENT(sd_fill) ) dl_fill=REAL(sd_fill,dp) + + il_shape(:)=SHAPE(sd_value(:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk)=REAL(sd_value(ji,jj,jk),dp) + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_3D_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_i2(cd_name, sd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, sd_fill, cd_units, cd_axis,& + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle,& + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(2) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] sd_value 4D array of integer(2) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] sd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i2) , DIMENSION(:,:,:,:), INTENT(IN) :: sd_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_SHORT + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_SHORT + IF( PRESENT(sd_fill) ) dl_fill=REAL(sd_fill,dp) + + il_shape(:)=SHAPE(sd_value(:,:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3), & + & il_shape(4)) ) + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(sd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_1D_i1(cd_name, bd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, bd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(1) 1D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] bd_value 1D array of integer(1) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] bd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1) , DIMENSION(:) , INTENT(IN) :: bd_value + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_BYTE + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_BYTE + IF( PRESENT(bd_fill) ) dl_fill=REAL(bd_fill,dp) + + il_shape=SIZE(bd_value(:)) + ALLOCATE( dl_value( il_shape) ) + + DO ji=1,il_shape + dl_value(ji)=REAL(bd_value(ji),dp) + ENDDO + + tf_var=var_init( cd_name, dl_value(:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_1D_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_2D_i1(cd_name, bd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, bd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(1) 2D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 2 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] bd_value 2D array of integer(1) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] bd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1) , DIMENSION(:,:) , INTENT(IN) :: bd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(2) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_BYTE + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_BYTE + IF( PRESENT(bd_fill) ) dl_fill=REAL(bd_fill,dp) + + il_shape(:)=SHAPE(bd_value(:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2)) ) + + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj)=REAL(bd_value(ji,jj),dp) + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_2D_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_3D_i1(cd_name, bd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, bd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(1) 3D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> array of 3 dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] bd_value 3D array of integer(1) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] bd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1) , DIMENSION(:,:,:) , INTENT(IN) :: bd_value + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_att + INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(3) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_BYTE + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_BYTE + IF( PRESENT(bd_fill) ) dl_fill=REAL(bd_fill,dp) + + il_shape(:)=SHAPE(bd_value(:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3)) ) + + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(:,:,:)=REAL(bd_value(:,:,:),dp) + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_3D_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__init_i1(cd_name, bd_value, & + & id_start, id_count, id_type, td_dim, & + & td_att, bd_fill, cd_units, cd_axis, & + & cd_stdname, cd_longname, & + & cd_point, id_id, id_ew, & + & dd_scf, dd_ofs, id_rec, & + & dd_min, dd_max, & + & ld_contiguous, ld_shuffle, & + & ld_fletcher32, id_deflvl, id_chunksz, & + & cd_interp, cd_extrap, cd_filter, & + & cd_unt, dd_unf, & + & cd_namout) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function initialize a variable structure, + !> with a integer(1) 4D array of value. + !> @details + !> optionally could be added:<br/> + !> - dimension structure. + !> - attribute structure. + !> + !> Dimension structure is needed to put value in variable structure. + !> If none is given, we assume array is ordered as ('x','y','z','t') and we + !> use array size as lentgh dimension. + !> + !> indices in the variable where value will be written could be specify if + !> start and count array are given. Dimension structure is needed in that + !> case. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add interp, extrap, and filter argument + !> @date July, 2015 + !> - add unit factor (to change unit) + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> @date February, 2019 + !> - add output name (to change name) + !> + !> @param[in] cd_name variable name + !> @param[in] bd_value 4D array of integer(1) value + !> @param[in] id_start index in the variable from which the + !> data values will be read + !> @param[in] id_count number of indices selected along + !> each dimension + !> @param[in] id_type variable type + !> @param[in] td_dim array of dimension structure + !> @param[in] td_att array of attribute structure + !> @param[in] bd_fill fill value + !> @param[in] cd_units units + !> @param[in] cd_axis axis expected to be used + !> @param[in] cd_stdname variable standard name + !> @param[in] cd_longname variable long name + !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F) + !> @param[in] id_id variable id + !> @param[in] id_ew east west wrap + !> @param[in] dd_scf scale factor + !> @param[in] dd_ofs add offset + !> @param[in] id_rec record id (for rstdimg file) + !> @param[in] dd_min minimum value + !> @param[in] dd_max maximum value + !> @param[in] ld_contiguous use contiguous storage or not + !> @param[in] ld_shuffle shuffle filter is turned on or not + !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not + !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no + !> deflation is in use + !> @param[in] id_chunksz chunk size + !> @param[in] cd_interp interpolation method + !> @param[in] cd_extrap extrapolation method + !> @param[in] cd_filter filter method + !> @param[in] cd_unt new units (linked to units factor) + !> @param[in] dd_unf units factor + !> @param[in] cd_namout output name (renamed variable) + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_name + INTEGER(i1) , DIMENSION(:,:,:,:), INTENT(IN) :: bd_value + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type + TYPE(TDIM) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim + TYPE(TATT) , DIMENSION(:), INTENT(IN), OPTIONAL :: td_att + INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_point + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_id + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew + REAL(dp) , INTENT(IN), OPTIONAL :: dd_scf + REAL(dp) , INTENT(IN), OPTIONAL :: dd_ofs + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_rec + REAL(dp) , INTENT(IN), OPTIONAL :: dd_min + REAL(dp) , INTENT(IN), OPTIONAL :: dd_max + LOGICAL , INTENT(IN), OPTIONAL :: ld_contiguous + LOGICAL , INTENT(IN), OPTIONAL :: ld_shuffle + LOGICAL , INTENT(IN), OPTIONAL :: ld_fletcher32 + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_deflvl + INTEGER(i4) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_chunksz + CHARACTER(LEN=*), DIMENSION(2) , INTENT(IN), OPTIONAL :: cd_interp + CHARACTER(LEN=*), DIMENSION(1) , INTENT(IN), OPTIONAL :: cd_extrap + CHARACTER(LEN=*), DIMENSION(5) , INTENT(IN), OPTIONAL :: cd_filter + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_unt + REAL(dp) , INTENT(IN), OPTIONAL :: dd_unf + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namout + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_type + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) :: dl_fill + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! clean variable + CALL var_clean(tf_var) + + il_type=NF90_BYTE + IF( PRESENT(id_type) ) il_type=id_type + + dl_fill=NF90_FILL_BYTE + IF( PRESENT(bd_fill) ) dl_fill=REAL(bd_fill,dp) + + il_shape(:)=SHAPE(bd_value(:,:,:,:)) + + ALLOCATE( dl_value( il_shape(1), & + & il_shape(2), & + & il_shape(3), & + & il_shape(4)) ) + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(bd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + tf_var=var_init( cd_name, dl_value(:,:,:,:), & + & id_start=id_start, & + & id_count=id_count, & + & id_type=il_type, & + & td_dim=td_dim, td_att=td_att, & + & dd_fill=dl_fill, & + & cd_units=cd_units, & + & cd_axis=cd_axis, & + & cd_stdname=cd_stdname, & + & cd_longname=cd_longname, & + & cd_point=cd_point, id_id=id_id, & + & id_ew=id_ew, dd_scf=dd_scf, & + & dd_ofs=dd_ofs, id_rec=id_rec, & + & dd_min=dd_min, dd_max=dd_max, & + & ld_contiguous=ld_contiguous, & + & ld_shuffle=ld_shuffle, & + & ld_fletcher32=ld_fletcher32, & + & id_deflvl=id_deflvl, & + & id_chunksz=id_chunksz(:), & + & cd_interp=cd_interp(:), & + & cd_extrap=cd_extrap(:), & + & cd_filter=cd_filter(:), & + & cd_unt=cd_unt, dd_unf=dd_unf, & + & cd_namout=cd_namout ) + + DEALLOCATE( dl_value ) + + END FUNCTION var__init_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_concat(td_var1, td_var2, id_dim) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function concatenate variable value following id_dim direction. + !> + !> @details + !> By default variable are concatenate following time dimension. To + !> concatenate following another dimension, specify id_dim=x where x is the + !> dimension number (jp_I, jp_J,jp_K, jp_L). + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var1 variable structure + !> @param[in] td_var2 variable structure + !> @param[in] DIM dimension following which concatenate + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var1 + TYPE(TVAR) , INTENT(IN) :: td_var2 + INTEGER(i4), INTENT(IN), OPTIONAL :: id_dim + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + INTEGER(i4) :: il_dim + !---------------------------------------------------------------- + il_dim=4 + IF( PRESENT(id_dim) ) il_dim=id_dim + + IF( .NOT. ASSOCIATED(td_var1%d_value) )THEN + CALL logger_error("VAR CONCAT: no value associated to variable "//& + & TRIM(td_var1%c_name) ) + ELSEIF( .NOT. ASSOCIATED(td_var2%d_value) )THEN + CALL logger_error("VAR CONCAT: no value associated to variable "//& + & TRIM(td_var2%c_name) ) + ELSEIF( il_dim < 0 .OR. il_dim > 4 )THEN + CALL logger_error("VAR CONCAT: invalid concatenate dimension ") + ELSE + ! check other dimension + SELECT CASE(il_dim) + CASE(jp_I) + tf_var=var__concat_i(td_var1, td_var2) + CASE(jp_J) + tf_var=var__concat_j(td_var1, td_var2) + CASE(jp_K) + tf_var=var__concat_k(td_var1, td_var2) + CASE(jp_L) + tf_var=var__concat_l(td_var1, td_var2) + END SELECT + ENDIF + + END FUNCTION var_concat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__concat_i(td_var1, td_var2) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function concatenate variable value following i-direction. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array copy on each dimension + !> + !> @param[in] td_var1 variable structure + !> @param[in] td_var2 variable structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var1 + TYPE(TVAR) , INTENT(IN) :: td_var2 + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TVAR) :: tl_var + CHARACTER(LEN=lc) :: cl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + IF( .NOT. td_var1%t_dim(1)%l_use .OR. & + &.NOT. td_var1%t_dim(1)%l_use )THEN + + CALL logger_error("VAR CONCAT: can not concatenate variable "//& + & TRIM(td_var1%c_name)//" on an unused dimension I") + + ELSEIF( ANY(td_var1%t_dim(2:4)%i_len /= td_var2%t_dim(2:4)%i_len) )THEN + + cl_tmp='('//":"//","//& + & TRIM(fct_str(td_var1%t_dim(2)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(3)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: first variable dimensions "//& + & TRIM(cl_tmp) ) + cl_tmp='('//":"//","//& + & TRIM(fct_str(td_var2%t_dim(2)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(3)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: second variable dimensions "//& + & TRIM(cl_tmp) ) + + CALL logger_error("VAR CONCAT: dimension not conform") + + ELSE + tl_var=var_copy(td_var1) + + DEALLOCATE(tl_var%d_value) + ! change dimension length + tl_var%t_dim(1)%i_len=td_var1%t_dim(1)%i_len+td_var2%t_dim(1)%i_len + + ALLOCATE(tl_var%d_value(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & tl_var%t_dim(3)%i_len, & + & tl_var%t_dim(4)%i_len) ) + + ! copy first variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,td_var1%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk,jl) = td_var1%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + ! tl_var%d_value(1:td_var1%t_dim(1)%i_len,:,:,:) = & + !& td_var1%d_value(:,:,:,:) + + ! copy second variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,td_var2%t_dim(1)%i_len + tl_var%d_value(ji+td_var1%t_dim(1)%i_len,jj,jk,jl) = td_var2%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + !tl_var%d_value(td_var1%t_dim(1)%i_len+1:tl_var%t_dim(1)%i_len,:,:,:)=& + !& td_var2%d_value(:,:,:,:) + + ! save result + tf_var=var_copy(tl_var) + + ! clean + CALL var_clean(tl_var) + ENDIF + + END FUNCTION var__concat_i + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__concat_j(td_var1, td_var2) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function concatenate variable value following j-direction. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array copy on each dimension + !> + !> @param[in] td_var1 variable structure + !> @param[in] td_var2 variable structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var1 + TYPE(TVAR) , INTENT(IN) :: td_var2 + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TVAR) :: tl_var + CHARACTER(LEN=lc) :: cl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + IF( .NOT. td_var1%t_dim(2)%l_use .OR. & + & .NOT. td_var1%t_dim(2)%l_use )THEN + + CALL logger_error("VAR CONCAT: can not concatenate variable "//& + & TRIM(td_var1%c_name)//" on an unused dimension J") + + ELSEIF( td_var1%t_dim(1)%i_len /= td_var2%t_dim(1)%i_len .OR. & + & ANY(td_var1%t_dim(3:4)%i_len /= td_var2%t_dim(3:4)%i_len) )THEN + + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & ":"//','//& + & TRIM(fct_str(td_var1%t_dim(3)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: first variable dimensions "//& + & TRIM(cl_tmp) ) + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & ":"//','//& + & TRIM(fct_str(td_var2%t_dim(3)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: second variable dimensions "//& + & TRIM(cl_tmp) ) + + CALL logger_error("VAR CONCAT: dimension not conform") + + ELSE + tl_var=var_copy(td_var1) + + DEALLOCATE(tl_var%d_value) + ! change dimension length + tl_var%t_dim(2)%i_len=td_var1%t_dim(2)%i_len+td_var2%t_dim(2)%i_len + + ALLOCATE(tl_var%d_value(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & tl_var%t_dim(3)%i_len, & + & tl_var%t_dim(4)%i_len) ) + + ! copy first variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,td_var1%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk,jl) = td_var1%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + ! tl_var%d_value(:,1:td_var1%t_dim(2)%i_len,:,:)= & + !& td_var1%d_value(:,:,:,:) + + ! copy second variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,td_var2%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj+td_var2%t_dim(2)%i_len,jk,jl) = td_var2%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + ! tl_var%d_value(:,td_var1%t_dim(2)%i_len+1:tl_var%t_dim(2)%i_len,:,:)=& + !& td_var2%d_value(:,:,:,:) + + ! save result + tf_var=var_copy(tl_var) + + ! clean + CALL var_clean(tl_var) + ENDIF + + END FUNCTION var__concat_j + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__concat_k(td_var1, td_var2) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function concatenate variable value following k-direction. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array copy on each dimension + ! + !> @param[in] td_var1 variable structure + !> @param[in] td_var2 variable structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var1 + TYPE(TVAR) , INTENT(IN) :: td_var2 + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TVAR) :: tl_var + CHARACTER(LEN=lc) :: cl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + IF( .NOT. td_var1%t_dim(3)%l_use .OR. & + & .NOT. td_var1%t_dim(3)%l_use )THEN + + CALL logger_error("VAR CONCAT: can not concatenate variable "//& + & TRIM(td_var1%c_name)//" on an unused dimension K") + + ELSEIF( td_var1%t_dim(4)%i_len /= td_var2%t_dim(4)%i_len .OR. & + & ANY(td_var1%t_dim(1:2)%i_len /= td_var2%t_dim(1:2)%i_len) )THEN + + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(2)%i_len))//','//& + & ":"//','//& + & TRIM(fct_str(td_var1%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: first variable dimensions "//& + & TRIM(cl_tmp) ) + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(2)%i_len))//','//& + & ":"//','//& + & TRIM(fct_str(td_var2%t_dim(4)%i_len))//')' + CALL logger_debug("VAR CONCAT: second variable dimensions "//& + & TRIM(cl_tmp) ) + + CALL logger_error("VAR CONCAT: dimension not conform") + + ELSE + tl_var=var_copy(td_var1) + + DEALLOCATE(tl_var%d_value) + ! change dimension length + tl_var%t_dim(3)%i_len=td_var1%t_dim(3)%i_len+td_var2%t_dim(3)%i_len + + ALLOCATE(tl_var%d_value(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & tl_var%t_dim(3)%i_len, & + & tl_var%t_dim(4)%i_len) ) + + ! copy first variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,td_var1%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk,jl) = td_var1%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + !tl_var%d_value(:,:,1:td_var1%t_dim(3)%i_len,:)= & + ! & td_var1%d_value(:,:,:,:) + + ! copy second variable value + DO jl=1,tl_var%t_dim(4)%i_len + DO jk=1,td_var2%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk+td_var1%t_dim(3)%i_len,jl) = td_var2%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + !tl_var%d_value(:,:,td_var1%t_dim(3)%i_len+1:tl_var%t_dim(3)%i_len,:)=& + !& td_var2%d_value(:,:,:,:) + + ! save result + tf_var=var_copy(tl_var) + + ! clean + CALL var_clean(tl_var) + ENDIF + + END FUNCTION var__concat_k + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__concat_l(td_var1, td_var2) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function concatenate variable value following l-direction. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array copy on each dimension + !> + !> @param[in] td_var1 variable structure + !> @param[in] td_var2 variable structure + !> @return variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(IN) :: td_var1 + TYPE(TVAR) , INTENT(IN) :: td_var2 + + ! function + TYPE(TVAR) :: tf_var + + ! local variable + TYPE(TVAR) :: tl_var + CHARACTER(LEN=lc) :: cl_tmp + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + IF( .NOT. td_var1%t_dim(4)%l_use .OR. & + & .NOT. td_var1%t_dim(4)%l_use )THEN + + CALL logger_error("VAR CONCAT: can not concatenate variable "//& + & TRIM(td_var1%c_name)//" on an unused dimension L") + + ELSEIF( ANY(td_var1%t_dim(1:3)%i_len /= td_var2%t_dim(1:3)%i_len) )THEN + + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(2)%i_len))//','//& + & TRIM(fct_str(td_var1%t_dim(3)%i_len))//','//& + & ":"//','//')' + CALL logger_debug("VAR CONCAT: first variable dimensions "//& + & TRIM(cl_tmp) ) + cl_tmp='('//& + & TRIM(fct_str(td_var1%t_dim(1)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(2)%i_len))//','//& + & TRIM(fct_str(td_var2%t_dim(3)%i_len))//','//& + & ":"//','//')' + CALL logger_debug("VAR CONCAT: second variable dimensions "//& + & TRIM(cl_tmp) ) + + CALL logger_error("VAR CONCAT: dimension not conform") + + ELSE + tl_var=var_copy(td_var1) + + DEALLOCATE(tl_var%d_value) + ! change dimension length + tl_var%t_dim(4)%i_len=td_var1%t_dim(4)%i_len+td_var2%t_dim(4)%i_len + + ALLOCATE(tl_var%d_value(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & tl_var%t_dim(3)%i_len, & + & tl_var%t_dim(4)%i_len) ) + + ! copy first variable value + DO jl=1,td_var1%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk,jl) = td_var1%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + !tl_var%d_value(:,:,1:td_var1%t_dim(4)%i_len,:)= & + !& td_var1%d_value(:,:,:,:) + + ! copy second variable value + DO jl=1,td_var2%t_dim(4)%i_len + DO jk=1,tl_var%t_dim(3)%i_len + DO jj=1,tl_var%t_dim(2)%i_len + DO ji=1,tl_var%t_dim(1)%i_len + tl_var%d_value(ji,jj,jk,jl+td_var2%t_dim(4)%i_len) = td_var2%d_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + !tl_var%d_value(:,:,td_var1%t_dim(4)%i_len+1:tl_var%t_dim(4)%i_len,:)=& + !& td_var2%d_value(:,:,:,:) + + ! save result + tf_var=var_copy(tl_var) + + ! clean + CALL var_clean(tl_var) + ENDIF + + END FUNCTION var__concat_l + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_att_arr(td_var, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine add an array of attribute structure + !> in a variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - add all element of the array in the same time + !> @date January, 2019 + !> - deallocate attribute strucure whatever happens + !> + !> @param[inout] td_var variable structure + !> @param[in] td_att array of attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_natt + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + il_natt=SIZE(td_att(:)) + + IF( td_var%i_natt > 0 )THEN + ! already other attribute in variable structure + ALLOCATE( tl_att(td_var%i_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD ATT: not enough space to put attributes from "//& + & TRIM(td_var%c_name)//" in temporary attribute structure") + + ELSE + + ! save temporary global attribute's variable structure + tl_att(:)=att_copy(td_var%t_att(:)) + + CALL att_clean(td_var%t_att(:)) + DEALLOCATE( td_var%t_att ) + ALLOCATE( td_var%t_att(td_var%i_natt+il_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD ATT: not enough space to put attributes "//& + & "in variable structure "//TRIM(td_var%c_name) ) + + ENDIF + + ! copy attribute in variable before + td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:)) + + ! clean + CALL att_clean(tl_att(:)) + ENDIF + DEALLOCATE(tl_att) + + ELSE + ! no attribute in variable structure + IF( ASSOCIATED(td_var%t_att) )THEN + CALL att_clean(td_var%t_att(:)) + DEALLOCATE(td_var%t_att) + ENDIF + ALLOCATE( td_var%t_att(td_var%i_natt+il_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD ATT: not enough space to put attributes "//& + & "in variable structure "//TRIM(td_var%c_name) ) + + ENDIF + ENDIF + + ALLOCATE( tl_att(il_natt) ) + tl_att(:)=att_copy(td_att(:)) + + ! check if attribute already in variable structure + DO ji=1,il_natt + il_ind=0 + il_ind=att_get_index( td_var%t_att(:), tl_att(ji)%c_name ) + IF( il_ind /= 0 )THEN + CALL logger_error( & + & " VAR ADD ATT: attribute "//TRIM(tl_att(ji)%c_name)//& + & ", already in variable "//TRIM(td_var%c_name) ) + CALL att_clean(tl_att(ji)) + ENDIF + ENDDO + + ! add new attributes + td_var%t_att(td_var%i_natt+1:td_var%i_natt+il_natt)=att_copy(tl_att(:)) + + DEALLOCATE(tl_att) + + DO ji=1,il_natt + ! highlight some attribute + IF( ASSOCIATED(td_var%t_att(td_var%i_natt+ji)%d_value) .OR. & + & td_var%t_att(td_var%i_natt+ji)%c_value /= 'none' )THEN + SELECT CASE(TRIM(td_var%t_att(td_var%i_natt+ji)%c_name)) + + CASE("add_offset") + td_var%d_ofs = td_var%t_att(td_var%i_natt+ji)%d_value(1) + CASE("scale_factor") + td_var%d_scf = td_var%t_att(td_var%i_natt+ji)%d_value(1) + CASE("_FillValue") + td_var%d_fill = td_var%t_att(td_var%i_natt+ji)%d_value(1) + CASE("ew_overlap") + td_var%i_ew = INT(td_var%t_att(td_var%i_natt+ji)%d_value(1),i4) + CASE("standard_name") + td_var%c_stdname = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) + CASE("long_name") + td_var%c_longname = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) + CASE("units") + td_var%c_units = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) + CASE("grid_point") + td_var%c_point = TRIM(td_var%t_att(td_var%i_natt+ji)%c_value) + + END SELECT + ENDIF + ENDDO + + ! update number of attribute + td_var%i_natt=td_var%i_natt+il_natt + + + END SUBROUTINE var__add_att_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_att_unit(td_var, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine add an attribute structure + !> in a variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - use var__add_att_arr subroutine + !> @date January, 2019 + !> - clean attribute strucure + !> + !> @param[inout] td_var variable structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + TYPE(TATT), DIMENSION(1) :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + ! copy structure in an array + tl_att(1)=att_copy(td_att) + + ! + CALL var_add_att( td_var, tl_att(:) ) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE var__add_att_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__del_att_name(td_var, cd_name) + !------------------------------------------------------------------- + !> @brief This subroutine delete an attribute + !> from variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date February, 2015 + !> - define local attribute structure to avoid mistake + !> with pointer + !> @date January, 2019 + !> - clean attribute strucure + !> + !> @param[inout] td_var variable structure + !> @param[in] cd_name attribute name + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + + ! local variable + INTEGER(i4) :: il_ind + + TYPE(TATT) :: tl_att + ! loop indices + !---------------------------------------------------------------- + + ! check if attribute already in variable structure + il_ind=0 + IF( ASSOCIATED(td_var%t_att) )THEN + il_ind=att_get_index( td_var%t_att(:), TRIM(cd_name) ) + ENDIF + + IF( il_ind == 0 )THEN + + CALL logger_debug( & + & " VAR DEL ATT: no attribute "//TRIM(cd_name)//& + & ", in variable "//TRIM(td_var%c_name) ) + + ELSE + + tl_att=att_copy(td_var%t_att(il_ind)) + CALL var_del_att(td_var, tl_att) + ! clean + CALL att_clean(tl_att) + ENDIF + + END SUBROUTINE var__del_att_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__del_att_str(td_var, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine delete an attribute + !> from variable structure. + !> + !> @author J.Paul + !> @date November, 2013- Initial Version + !> @date February, 2015 + !> - delete highlight attribute too, when attribute + !> is deleted + !> + !> @param[inout] td_var variable structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4) :: il_ind + TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + ! check if attribute already in variable structure + il_ind=0 + IF( ASSOCIATED(td_var%t_att) )THEN + il_ind=att_get_index( td_var%t_att(:), td_att%c_name ) + ENDIF + + IF( il_ind == 0 )THEN + + CALL logger_debug( & + & " VAR DEL ATT: no attribute "//TRIM(td_att%c_name)//& + & ", in variable "//TRIM(td_var%c_name) ) + + ELSE + + CALL logger_trace( & + & " VAR DEL ATT: del attribute "//TRIM(td_att%c_name)//& + & ", in var "//TRIM(td_var%c_name) ) + + IF( td_var%i_natt == 1 )THEN + + CALL att_clean(td_var%t_att(:)) + DEALLOCATE(td_var%t_att) + + ! new number of attribute in variable + td_var%i_natt=td_var%i_natt-1 + + ELSE + ALLOCATE( tl_att(td_var%i_natt-1), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD ATT: not enough space to put attributes from "//& + & TRIM(td_var%c_name)//" in temporary attribute structure") + + ELSE + + ! save temporary global attribute's variable structure + tl_att(1:il_ind-1)=att_copy(td_var%t_att(1:il_ind-1)) + IF( il_ind < td_var%i_natt )THEN + tl_att(il_ind:)=att_copy(td_var%t_att(il_ind+1:)) + ENDIF + + CALL att_clean(td_var%t_att(:)) + DEALLOCATE( td_var%t_att ) + + ! new number of attribute in variable + td_var%i_natt=td_var%i_natt-1 + + ALLOCATE( td_var%t_att(td_var%i_natt), stat=il_status ) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD ATT: not enough space to put attributes "//& + & "in variable structure "//TRIM(td_var%c_name) ) + + ENDIF + + ! copy attribute in variable before + td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:)) + + ! clean + CALL att_clean(tl_att(:)) + ENDIF + DEALLOCATE(tl_att) + ENDIF + + ! highlight attribute + SELECT CASE( TRIM(td_att%c_name) ) + + CASE("add_offset") + td_var%d_ofs = 0._dp + CASE("scale_factor") + td_var%d_scf = 1._dp + CASE("_FillValue") + td_var%d_fill = 0._dp + CASE("ew_overlap") + td_var%i_ew = -1 + CASE("standard_name") + td_var%c_stdname = '' + CASE("long_name") + td_var%c_longname = '' + CASE("units") + td_var%c_units = '' + CASE("grid_point") + td_var%c_point = '' + + END SELECT + + ENDIF + + END SUBROUTINE var__del_att_str + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_move_att(td_var, td_att) + !------------------------------------------------------------------- + !> @brief This subroutine move an attribute structure + !> from variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_att attribute structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TATT), INTENT(IN) :: td_att + + ! local variable + TYPE(TATT) :: tl_att + + !---------------------------------------------------------------- + ! copy attribute + tl_att=att_copy(td_att) + + ! remove attribute with same name + CALL var_del_att(td_var, tl_att) + + ! add new attribute + CALL var_add_att(td_var, tl_att) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE var_move_att + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_dim_arr(td_var, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine add an array of dimension structure in a variable + !> structure. + !> - number of dimension in variable can't be greater than 4 + !> - dimension can't be already uses in variable structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim + + ! local variable + INTEGER(i4) :: il_ndim + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + il_ndim=SIZE(td_dim(:)) + IF( il_ndim <= ip_maxdim )THEN + + DO ji=1,il_ndim + CALL var_add_dim(td_var, td_dim(ji)) + ENDDO + + ELSE + CALL logger_error( & + & " VAR ADD DIM: too much dimension to put in structure "//& + & "("//TRIM(fct_str(il_ndim))//")" ) + ENDIF + + END SUBROUTINE var__add_dim_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_dim_unit(td_var, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine add one dimension in a variable + !> structure. + !> @details + !> - number of dimension in variable can't be greater than 4 + !> - dimension can't be already uses in variable structure + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + !---------------------------------------------------------------- + + IF( td_var%i_ndim <= ip_maxdim )THEN + + ! check if dimension already used in variable structure + il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) + IF( il_ind == 0 )THEN + CALL logger_warn( & + & " VAR ADD DIM: dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", will not be added in variable "//TRIM(td_var%c_name) ) + ELSEIF( td_var%t_dim(il_ind)%l_use )THEN + CALL logger_error( & + & " VAR ADD DIM: dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", already used in variable "//TRIM(td_var%c_name) ) + ELSE + + ! back to disorder dimension array + CALL dim_disorder(td_var%t_dim(:)) + + ! add new dimension + td_var%t_dim(td_var%i_ndim+1)=dim_copy(td_dim) + + ! update number of attribute + td_var%i_ndim=COUNT(td_var%t_dim(:)%l_use) + + ENDIF + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_var%t_dim(:)) + + ELSE + CALL logger_error( & + & " VAR ADD DIM: too much dimension in variable "//& + & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")") + ENDIF + + END SUBROUTINE var__add_dim_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_del_dim(td_var, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine delete a dimension structure in a variable + !> structure. + !> + !> @warning delete variable value too. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + TYPE(TDIM) :: tl_dim ! empty dimension structure + !---------------------------------------------------------------- + + IF( td_var%i_ndim <= ip_maxdim )THEN + + CALL logger_trace( & + & " VAR DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& + & ", short name "//TRIM(td_dim%c_sname)//& + & ", in variable "//TRIM(td_var%c_name) ) + + ! check if dimension already in variable structure + il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) + + ! replace dimension by empty one + td_var%t_dim(il_ind)=dim_copy(tl_dim) + + ! update number of dimension + td_var%i_ndim=COUNT(td_var%t_dim(:)%l_use) + + ! remove variable value using this dimension + IF( ASSOCIATED(td_var%d_value) )THEN + il_shape(:)=SHAPE(td_var%d_value(:,:,:,:)) + IF(il_shape(il_ind)/=td_dim%i_len)THEN + CALL logger_warn("VAR DEL DIM: remove value of variable "//& + & TRIM(td_var%c_name) ) + CALL var_del_value(td_var) + ENDIF + ENDIF + + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_var%t_dim) + + ELSE + CALL logger_error( & + & " VAR DEL DIM: too much dimension in variable "//& + & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")") + ENDIF + + END SUBROUTINE var_del_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_move_dim(td_var, td_dim) + !------------------------------------------------------------------- + !> @brief This subroutine move a dimension structure + !> in variable structure. + !> + !> @warning + !> - dimension order could be changed + !> - delete variable value + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] td_dim dimension structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + TYPE(TDIM) , INTENT(IN ) :: td_dim + + ! local variable + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_dimid + !---------------------------------------------------------------- + + IF( td_var%i_ndim <= ip_maxdim )THEN + + ! check if dimension already in mpp structure + il_ind=dim_get_index(td_var%t_dim(:), td_dim%c_name, td_dim%c_sname) + IF( il_ind /= 0 )THEN + + il_dimid=td_var%t_dim(il_ind)%i_id + ! replace dimension + td_var%t_dim(il_ind)=dim_copy(td_dim) + td_var%t_dim(il_ind)%i_id=il_dimid + td_var%t_dim(il_ind)%l_use=.TRUE. + + ELSE + CALL var_add_dim(td_var, td_dim) + ENDIF + + ELSE + CALL logger_error( & + & "VAR MOVE DIM: too much dimension in variale "//& + & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")") + ENDIF + + END SUBROUTINE var_move_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__print_arr(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine print informations of an array of variables. + !> + !> @author J.Paul + !> @date June, 2014 - Initial Version + !> + !> @param[in] td_var array of variables structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_var + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + DO ji=1,SIZE(td_var(:)) + CALL var_print(td_var(ji)) + ENDDO + + END SUBROUTINE var__print_arr + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__print_unit(td_var, ld_more) + !------------------------------------------------------------------- + !> @brief This subroutine print variable information.</br/> + !> @details + !> If ld_more is TRUE (default), print information about variable dimensions + !> and variable attributes. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var variable structure + !> @param[in] ld_more print more infomration about variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + LOGICAL, INTENT(IN), OPTIONAL :: ld_more + + ! local vairbale + CHARACTER(LEN=lc) :: cl_type + REAL(dp) :: dl_min + REAL(dp) :: dl_max + LOGICAL :: ll_more + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + ll_more=.TRUE. + IF( PRESENT(ld_more) )THEN + ll_more=ld_more + ENDIF + + SELECT CASE( td_var%i_type ) + + CASE(NF90_CHAR) + cl_type='CHAR' + CASE(NF90_BYTE) + cl_type='BYTE' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE DEFAULT + !cl_type='unknown' + cl_type='' + END SELECT + + WRITE(*,'((/a,a),4(/3x,a,a),4(/3x,a,i3),& + & (/3x,a,a),3(/3x,a,ES12.4))')& + & " Variable : ",TRIM(td_var%c_name), & + & " standard name : ",TRIM(td_var%c_stdname), & + & " long name : ",TRIM(td_var%c_longname), & + & " units : ",TRIM(td_var%c_units), & + & " point : ",TRIM(td_var%c_point), & + & " id : ",td_var%i_id, & + & " rec : ",td_var%i_rec, & + & " ndim : ",td_var%i_ndim, & + & " natt : ",td_var%i_natt, & + & " type : ",TRIM(cl_type), & + & " scale factor : ",td_var%d_scf, & + & " add offset : ",td_var%d_ofs, & + & " _FillValue : ",td_var%d_fill + + IF( ASSOCIATED(td_var%d_value) )THEN + dl_min=MINVAL(td_var%d_value(:,:,:,:), & + & mask=(td_var%d_value(:,:,:,:)/=td_var%d_fill) )& + & *td_var%d_scf+td_var%d_ofs + dl_max=MAXVAL(td_var%d_value(:,:,:,:), & + & mask=(td_var%d_value(:,:,:,:)/=td_var%d_fill) )& + & *td_var%d_scf+td_var%d_ofs + + WRITE(*,'((3x,a),2(/3x,a,ES12.4))')& + & "VALUE ASSOCIATED" , & + & " min value : ",dl_min,& + & " max value : ",dl_max + ENDIF + + IF( ll_more )THEN + ! print dimension + IF( td_var%i_ndim /= 0 )THEN + WRITE(*,'(a)') " Variable dimension" + DO ji=1,ip_maxdim + IF( td_var%t_dim(ji)%l_use )THEN + CALL dim_print(td_var%t_dim(ji)) + ENDIF + ENDDO + ENDIF + + ! print attribute + IF( td_var%i_natt /= 0 )THEN + WRITE(*,'(a)') " Variable attribute" + DO ji=1,td_var%i_natt + CALL att_print(td_var%t_att(ji)) + ENDDO + ENDIF + ENDIF + + END SUBROUTINE var__print_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value(td_var, dd_value, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of real(8) value in a variable + !> structure. + !> + !> @details + !> indices in the variable where value will be written could be specify if + !> start and count array are given. + !> @warning Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array copy on each dimension + !> + !> @param[inout] td_var variable structure + !> @param[in] dd_value array of variable value + !> @param[in] id_start index in the variable from which the data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + INTEGER(i4) :: il_status + INTEGER(i4), DIMENSION(ip_maxdim) :: il_start + INTEGER(i4), DIMENSION(ip_maxdim) :: il_count + INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + ! check id_count and id_start optionals parameters... + IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. & + ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN + CALL logger_warn( & + & " VAR ADD VALUE: id_start and id_count should be both specified") + ENDIF + + IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN + + ! keep ordered array ('x','y','z','t') + il_start(:)=id_start(:) + il_count(:)=id_count(:) + + ELSE + + ! keep ordered array ('x','y','z','t') + il_start(:)=(/1,1,1,1/) + il_count(:)=td_var%t_dim(:)%i_len + + ENDIF + + ! check dimension of input array + il_shape(:)=SHAPE(dd_value(:,:,:,:)) + IF(.NOT.ALL( il_count(:) == il_shape(:)) )THEN + + CALL logger_debug(" ADD VALUE: check dimension order !!") + DO ji = 1, ip_maxdim + CALL logger_debug( & + & " VAR ADD VALUE: count : "//TRIM(fct_str(il_count(ji)))//& + & " array dimension : "//TRIM(fct_str(il_shape(ji)))) + ENDDO + CALL logger_error( & + & " VAR ADD VALUE: dimension of input array, and count array differ " ) + + ELSE + + ! check dimension of variable + IF(.NOT.ALL(il_start(:)+il_count(:)-1 <= td_var%t_dim(:)%i_len) )THEN + + CALL logger_debug(" VAR ADD VALUE: check dimension order !!") + DO ji = 1, ip_maxdim + CALL logger_debug( & + & " VAR ADD VALUE: start ("//TRIM(fct_str(il_start(ji)))//") "//& + & "+ count ("//TRIM(fct_str(il_count(ji)))//") "//& + & "variable dimension "//TRIM(fct_str(td_var%t_dim(ji)%i_len))) + ENDDO + + CALL logger_error( & + & " VAR ADD VALUE: start + count exceed variable dimension bound. " ) + ELSE + + ! special case for scalar variable + IF( td_var%i_ndim == 0 )THEN + ! reorder dimension to ('x','y','z','t') + CALL dim_reorder(td_var%t_dim) + ENDIF + + IF( ASSOCIATED(td_var%d_value) )THEN + + CALL logger_warn( & + & "VAR ADD VALUE: value already in variable "//& + & TRIM(td_var%c_name)//& + & " (standard name "//TRIM(td_var%c_stdname)//")" ) + + ELSE + + ! Allocate space to hold variable value in structure + ALLOCATE(td_var%d_value( td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len, & + & td_var%t_dim(4)%i_len),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + ! initialise array + CALL logger_trace( & + & " VAR ADD VALUE: value in variable "//TRIM(td_var%c_name)//& + & ", initialise to FillValue "//TRIM(fct_str(td_var%d_fill)) ) + td_var%d_value(:,:,:,:)=td_var%d_fill + + ENDIF + + CALL logger_debug( & + & " VAR ADD VALUE: put value in variable "//TRIM(td_var%c_name)//& + & " (standard name "//TRIM(td_var%c_stdname)//")" ) + + ! put value in variable structure + DO jl=1,il_count(4) + DO jk=1,il_count(3) + DO jj=1,il_count(2) + DO ji=1,il_count(1) + td_var%d_value(ji+il_start(1)-1, & + & jj+il_start(2)-1, & + & jk+il_start(3)-1, & + & jl+il_start(4)-1 ) = dd_value(ji,jj,jk,jl) + ENDDO + ENDDO + ENDDO + ENDDO + +! td_var%d_value( il_start(1):il_start(1)+il_count(1)-1, & +! & il_start(2):il_start(2)+il_count(2)-1, & +! & il_start(3):il_start(3)+il_count(3)-1, & +! & il_start(4):il_start(4)+il_count(4)-1 ) = dd_value(:,:,:,:) + + ENDIF + ENDIF + + END SUBROUTINE var__add_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_dp(td_var, dd_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of real(8) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default real(8)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] dd_value array of variable value + !> @param[in] id_type type of the variable to be used (default real(8)) + !> @param[in] id_start start indices of the variable where data values + !> will be written + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + CALL var__add_value(td_var, dd_value, id_start, id_count) + + END SUBROUTINE var__add_value_dp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_rp(td_var, rd_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of real(4) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default real(4)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> + !> @param[inout] td_var variable structure + !> @param[in] rd_value array of variable value + !> @param[in] id_type type of the variable to be used (default real(4)) + !> @param[in] id_start start indices of the variable where data values + !> will be written + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + REAL(sp), DIMENSION(:,:,:,:), INTENT(IN) :: rd_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + il_shape=SHAPE(rd_value) + ALLOCATE( dl_value(il_shape(1), il_shape(2), il_shape(3), il_shape(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(rd_value(ji,jj,jk,jl), dp) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL var__add_value(td_var, dl_value(:,:,:,:), id_start(:), id_count(:)) + + DEALLOCATE(dl_value) + + END SUBROUTINE var__add_value_rp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_i1(td_var, bd_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of integer(1) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default integer(1)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @note variable type is forced to BYTE + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> + !> @param[inout] td_var variabele structure + !> @param[in] bd_value array of variable value + !> @param[in] id_type type of the variable to be used (default integer(1)) + !> @param[in] id_start start indices of the variable where data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + INTEGER(i1), DIMENSION(:,:,:,:), INTENT(IN) :: bd_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + il_shape=SHAPE(bd_value) + ALLOCATE( dl_value(il_shape(1), il_shape(2), il_shape(3), il_shape(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(bd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL var__add_value(td_var, dl_value(:,:,:,:), id_start(:), id_count(:)) + + DEALLOCATE(dl_value) + + END SUBROUTINE var__add_value_i1 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_i2(td_var, sd_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of integer(2) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default integer(2)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @note variable type is forced to SHORT + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> + !> @param[inout] td_var variabele structure + !> @param[in] sd_value array of variable value + !> @param[in] id_type type of the variable to be used (default integer(2)) + !> @param[in] id_start start indices of the variable where data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + INTEGER(i2), DIMENSION(:,:,:,:), INTENT(IN) :: sd_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + il_shape=SHAPE(sd_value) + ALLOCATE( dl_value(il_shape(1), il_shape(2), il_shape(3), il_shape(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(sd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL var__add_value(td_var, dl_value(:,:,:,:), id_start(:), id_count(:)) + + DEALLOCATE(dl_value) + + END SUBROUTINE var__add_value_i2 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_i4(td_var, id_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of integer(4) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default integer(4)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @note variable type is forced to INT + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> + !> @param[inout] td_var variabele structure + !> @param[in] id_value array of variable value + !> @param[in] id_type type of the variable to be used (default integer(4)) + !> @param[in] id_start start indices of the variable where data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + INTEGER(i4), DIMENSION(:,:,:,:), INTENT(IN) :: id_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + il_shape=SHAPE(id_value) + ALLOCATE( dl_value(il_shape(1), il_shape(2), il_shape(3), il_shape(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(id_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL var__add_value(td_var, dl_value(:,:,:,:), id_start(:), id_count(:)) + + DEALLOCATE(dl_value) + + END SUBROUTINE var__add_value_i4 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__add_value_i8(td_var, kd_value, id_type, id_start, id_count) + !------------------------------------------------------------------- + !> @brief This subroutine add a 4D array of integer(8) value in a variable + !> structure. Dimension of the array must be ordered as ('x','y','z','t') + !> + !> @details + !> Optionally, you could specify the type of the variable to be used (default integer(4)), + !> and indices of the variable where value will be written with start and count array. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - decompose array conversion on each dimension + !> + !> @param[inout] td_var variable structure + !> @param[in] kd_value array of variable value + !> @param[in] id_type type of the variable to be used (default integer(8)) + !> @param[in] id_start start indices of the variable where data values + !> will be read + !> @param[in] id_count number of indices selected along each dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + INTEGER(i8), DIMENSION(:,:,:,:), INTENT(IN) :: kd_value + INTEGER(i4), INTENT(IN), OPTIONAL :: id_type + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start + INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count + + ! local variable + CHARACTER(LEN=lc) :: cl_type + + INTEGER(i4) :: il_status + INTEGER(i4) , DIMENSION(ip_maxdim) :: il_shape + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + IF( PRESENT(id_type) )THEN + td_var%i_type=id_type + + cl_type='' + SELECT CASE(td_var%i_type) + CASE(NF90_DOUBLE) + cl_type='DOUBLE' + CASE(NF90_FLOAT) + cl_type='FLOAT' + CASE(NF90_INT) + cl_type='INT' + CASE(NF90_SHORT) + cl_type='SHORT' + CASE(NF90_BYTE) + cl_type='BYTE' + END SELECT + CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//& + & " value will be saved as "//TRIM(cl_type)) + ENDIF + + il_shape=SHAPE(kd_value) + ALLOCATE( dl_value(il_shape(1), il_shape(2), il_shape(3), il_shape(4)),& + & stat=il_status) + IF(il_status /= 0 )THEN + + CALL logger_error( & + & " VAR ADD VALUE: not enough space to put variable "//& + & TRIM(td_var%c_name)//& + & " in variable structure") + + ENDIF + + DO jl=1,il_shape(4) + DO jk=1,il_shape(3) + DO jj=1,il_shape(2) + DO ji=1,il_shape(1) + dl_value(ji,jj,jk,jl)=REAL(kd_value(ji,jj,jk,jl),dp) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL var__add_value(td_var, dl_value, id_start, id_count) + + DEALLOCATE(dl_value) + + END SUBROUTINE var__add_value_i8 + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_del_value(td_var) + !------------------------------------------------------------------- + !> @brief This subroutine remove variable value in a variable + !> structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - nullify array inside variable structure + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + !---------------------------------------------------------------- + CALL logger_debug( & + & " VAR DEL VALUE: value in variable "//TRIM(td_var%c_name)//& + & ", standard name "//TRIM(td_var%c_stdname)//& + & " will be remove ") + + DEALLOCATE(td_var%d_value) + NULLIFY(td_var%d_value) + + END SUBROUTINE var_del_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_get_index(td_var, cd_name, cd_stdname) & + & RESULT (if_idx) + !------------------------------------------------------------------- + !> @brief This function return the variable index, in a array of variable + !> structure, given variable name or standard name. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] td_var array of variable structure + !> @param[in] cd_name variable name + !> @param[in] cd_stdname variable standard name + !> @return variable index in array of variable structure (0 if not found) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , DIMENSION(:), INTENT(IN) :: td_var + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + + ! function + INTEGER(i4) :: if_idx + + ! local variable + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + if_idx=0 + il_size=SIZE(td_var(:)) + + ! check if variable is in array of variable structure + DO ji=1,il_size + + ! look for variable name + IF( fct_lower(td_var(ji)%c_name) == fct_lower(cd_name) )THEN + + if_idx=ji + EXIT + + ! look for variable standard name + ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.& + & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN + + if_idx=ji + EXIT + + ELSE IF( PRESENT(cd_stdname) )THEN + + IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_stdname) .AND.& + &TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN + + if_idx=ji + EXIT + ENDIF + + ENDIF + + ! look for variable longname + IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_name) .AND.& + &TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN + + if_idx=ji + EXIT + + ELSE IF( PRESENT(cd_stdname) )THEN + + IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_stdname) .AND.& + &TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN + + if_idx=ji + EXIT + ENDIF + + ENDIF + + ENDDO + + END FUNCTION var_get_index + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_get_id(td_var, cd_name, cd_stdname) & + & RESULT (if_id) + !------------------------------------------------------------------- + !> @brief This function return the variable id, + !> given variable name or standard name. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - check long name + !> + !> @param[in] td_var array of variable structure + !> @param[in] cd_name variable name + !> @param[in] cd_stdname variable standard name + !> @return variable id in array of variable structure (0 if not found) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , DIMENSION(:), INTENT(IN) :: td_var + CHARACTER(LEN=*), INTENT(IN) :: cd_name + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname + + ! function + INTEGER(i4) :: if_id + + ! local variable + INTEGER(i4) :: il_size + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + if_id=0 + il_size=SIZE(td_var(:)) + + ! check if variable is in array of variable structure + DO ji=1,il_size + + ! look for variable name + IF( fct_lower(td_var(ji)%c_name) == fct_lower(cd_name) )THEN + + if_id=td_var(ji)%i_id + EXIT + + ! look for variable standard name + ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.& + & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN + + if_id=td_var(ji)%i_id + EXIT + + ELSE IF( PRESENT(cd_stdname) )THEN + + IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_stdname) .AND.& + &TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN + + if_id=td_var(ji)%i_id + EXIT + ENDIF + + ENDIF + + ! look for variable long name + IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_name) .AND.& + &TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN + + if_id=td_var(ji)%i_id + EXIT + + ELSE IF( PRESENT(cd_stdname) )THEN + + IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_stdname) .AND.& + &TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN + + if_id=td_var(ji)%i_id + EXIT + ENDIF + + ENDIF + + ENDDO + + END FUNCTION var_get_id + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_get_mask(td_var) & + & RESULT (if_mask) + !------------------------------------------------------------------- + !> @brief + !> This function return the mask 3D of variable, given variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var array of variable structure + !> @return variable mask(3D) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len, & + & td_var%t_dim(2)%i_len, & + & td_var%t_dim(3)%i_len ) :: if_mask + + ! local variable + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + + CALL logger_debug( "VAR GET MASK: create mask from variable "//& + & TRIM(td_var%c_name)//", FillValue ="//& + & TRIM(fct_str(td_var%d_fill))) + if_mask(:,:,:)=1 + WHERE( td_var%d_value(:,:,:,1) == td_var%d_fill ) + if_mask(:,:,:)=0 + ENDWHERE + + ELSE + CALL logger_error("VAR GET MASK: variable value not define.") + ENDIF + + END FUNCTION var_get_mask + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_chg_FillValue(td_var, dd_fill) + !------------------------------------------------------------------- + !> @brief + !> This subroutine change FillValue of the variable to + !> standard NETCDF FillValue. + !> + !> @details + !> optionally, you could specify a dummy _FillValue to be used + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date January, 2019 + !> - write fill value on array level by level + !> + !> @param[inout] td_var array of variable structure + !> @param[in] dd_fill _FillValue to be used + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + REAL(dp) , INTENT(IN) , OPTIONAL :: dd_fill + + ! local variable + TYPE(TATT) :: tl_att + + INTEGER(i1) :: bl_fill + INTEGER(i2) :: sl_fill + INTEGER(i4) :: il_fill + REAL(sp) :: rl_fill + + ! loop indices + INTEGER(i4) :: jl + !---------------------------------------------------------------- + + CALL logger_trace( "VAR CHG FILL VALUE: change _FillValue in variable "//& + & TRIM(td_var%c_name) ) + + ! define attribute FillValue + SELECT CASE( td_var%i_type ) + + CASE(NF90_BYTE) + IF( PRESENT(dd_fill) )THEN + bl_fill=INT(dd_fill,i1) + tl_att=att_init('_FillValue',bl_fill) + ELSE + tl_att=att_init('_FillValue',NF90_FILL_BYTE) + ENDIF + CASE(NF90_SHORT) + IF( PRESENT(dd_fill) )THEN + sl_fill=INT(dd_fill,i2) + tl_att=att_init('_FillValue',sl_fill) + ELSE + tl_att=att_init('_FillValue',NF90_FILL_SHORT) + ENDIF + CASE(NF90_INT) + IF( PRESENT(dd_fill) )THEN + il_fill=INT(dd_fill,i4) + tl_att=att_init('_FillValue',il_fill) + ELSE + tl_att=att_init('_FillValue',NF90_FILL_INT) + ENDIF + CASE(NF90_FLOAT) + IF( PRESENT(dd_fill) )THEN + rl_fill=REAL(dd_fill,sp) + tl_att=att_init('_FillValue',rl_fill) + ELSE + tl_att=att_init('_FillValue',NF90_FILL_FLOAT) + ENDIF + CASE DEFAULT ! NF90_DOUBLE + IF( PRESENT(dd_fill) )THEN + tl_att=att_init('_FillValue',dd_fill) + ELSE + tl_att=att_init('_FillValue',NF90_FILL_DOUBLE) + ENDIF + + END SELECT + + IF( ASSOCIATED(td_var%d_value) )THEN + ! change FillValue in variable value + DO jl=1,td_var%t_dim(jp_L)%i_len + WHERE( td_var%d_value(:,:,:,jl) == td_var%d_fill ) + td_var%d_value(:,:,:,jl)=tl_att%d_value(1) + END WHERE + ENDDO + ENDIF + + ! change attribute _FillValue + CALL var_move_att(td_var, tl_att) + + ! clean + CALL att_clean(tl_att) + + END SUBROUTINE var_chg_FillValue + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_def_extra( cd_file ) + !------------------------------------------------------------------- + !> @brief + !> This subroutine read variable configuration file. And save + !> global array of variable structure with extra information: tg_varextra. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - new namelist format to get extra information (interpolation,...) + !> + !> @param[in] cd_file configuration file of variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_file + + ! local variable + CHARACTER(LEN=lc) :: cl_line + CHARACTER(LEN=lc) :: cl_interp + + INTEGER(i4) :: il_nvar + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_status + + LOGICAL :: ll_exist + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ALLOCATED(tg_varextra) )THEN + CALL var_clean(tg_varextra(:)) + DEALLOCATE(tg_varextra) + ENDIF + + ! read config variable file + INQUIRE(FILE=TRIM(cd_file), EXIST=ll_exist) + IF( ll_exist )THEN + + ! get number of variable to be read + + il_fileid=fct_getunit() + OPEN( il_fileid, FILE=TRIM(cd_file), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL',& + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("VAR DEF EXTRA: can not open file "//& + & TRIM(cd_file)) + ENDIF + + ! read file + READ( il_fileid, FMT='(a)', IOSTAT=il_status ) cl_line + cl_line=TRIM(ADJUSTL(cl_line)) + il_nvar=0 + DO WHILE( il_status == 0 ) + + ! search line not beginning with comment character + IF( SCAN( TRIM(fct_concat(cp_com(:))) ,cl_line(1:1)) == 0 )THEN + il_nvar=il_nvar+1 + ENDIF + + READ( il_fileid, FMT='(a)', IOSTAT=il_status ) cl_line + cl_line=TRIM(ADJUSTL(cl_line)) + ENDDO + + IF( il_nvar <= 0 )THEN + CALL logger_warn("VAR DEF EXTRA: no variable to be read") + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("VAR DEF EXTRA: closing file "//TRIM(cd_file)) + ENDIF + + ELSE + CALL logger_info("VAR DEF EXTRA: "//TRIM(fct_str(il_nvar))//& + & " variable to be read on varaible config file"//& + & TRIM(cd_file)) + + CALL logger_trace("VAR DEF EXTRA: rewind "//TRIM(cd_file)) + REWIND( il_fileid, IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("VAR DEF EXTRA: opening file "//TRIM(cd_file)) + ENDIF + + ALLOCATE( tg_varextra(il_nvar) ) + + ! read file + READ( il_fileid, FMT='(a)', IOSTAT=il_status ) cl_line + cl_line=TRIM(ADJUSTL(cl_line)) + ji=1 + DO WHILE( il_status == 0 ) + + IF( SCAN( TRIM(fct_concat(cp_com(:))) ,cl_line(1:1)) == 0 )THEN + tg_varextra(ji)%i_id = ji + tg_varextra(ji)%c_name =TRIM(fct_split(cl_line,1)) + tg_varextra(ji)%c_units =TRIM(fct_split(cl_line,2)) + tg_varextra(ji)%c_axis =TRIM(fct_split(cl_line,3)) + tg_varextra(ji)%c_point =TRIM(fct_split(cl_line,4)) + + cl_interp='int='//TRIM(fct_split(cl_line,5)) + tg_varextra(ji)%c_interp(:) = & + & var__get_interp(TRIM(tg_varextra(ji)%c_name), cl_interp) + CALL logger_debug("VAR DEF EXTRA: "//& + & TRIM(tg_varextra(ji)%c_name)//& + & " "//TRIM(tg_varextra(ji)%c_interp(1))) + + tg_varextra(ji)%c_longname=TRIM(fct_split(cl_line,6)) + tg_varextra(ji)%c_stdname =TRIM(fct_split(cl_line,7)) + ELSE + ji=ji-1 + ENDIF + + READ( il_fileid, FMT='(a)', IOSTAT=il_status ) cl_line + cl_line=TRIM(ADJUSTL(cl_line)) + ji=ji+1 + ENDDO + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("VAR DEF EXTRA: closing file "//TRIM(cd_file)) + ENDIF + ENDIF + + ELSE + + CALL logger_error("VAR DEF EXTRA: can't find file "//TRIM(cd_file)) + + ENDIF + + END SUBROUTINE var_def_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_chg_extra( cd_varinfo ) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add variable information get from namelist in + !> global array of variable structure with extra information: tg_varextra. + !> + !> @details + !> string character format must be : <br/> + !> "varname:int=interp; flt=filter; ext=extrap; min=min; max=max"<br/> + !> you could specify only interpolation, filter or extrapolation method, + !> whatever the order. you could find more + !> information about available method in \ref interp, \ref filter, and + !> \ref extrap module.<br/> + !> Examples: + !> cn_varinfo='Bathymetry:flt=2*hamming(2,3); min=10.' + !> cn_varinfo='votemper:int=cubic; ext=dist_weight; max=40.' + !> + !> + !> @warning variable should be define in tg_varextra (ie in configuration + !> file, to be able to add information from namelist + !> + !> @note If you do not specify a method which is required, default one is + !> apply. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date July, 2015 + !> - get unit and unit factor (to change unit) + !> @date February, 2019 + !> - get variable output name + !> + !> @param[in] cd_varinfo variable information from namelist + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varinfo + + ! local variable + CHARACTER(LEN=lc) :: cl_name + CHARACTER(LEN=lc) :: cl_method + CHARACTER(LEN=lc), DIMENSION(2) :: cl_interp + CHARACTER(LEN=lc), DIMENSION(1) :: cl_extrap + CHARACTER(LEN=lc), DIMENSION(5) :: cl_filter + CHARACTER(LEN=lc) :: cl_unt + CHARACTER(LEN=lc) :: cl_namout + + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_nvar + + REAL(dp) :: dl_min + REAL(dp) :: dl_max + REAL(dp) :: dl_unf + + TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_varextra + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ALLOCATED(tg_varextra) )THEN + ji=1 + DO WHILE( TRIM(cd_varinfo(ji)) /= '' ) + + cl_name =fct_lower(fct_split(cd_varinfo(ji),1,':')) + cl_method=fct_split(cd_varinfo(ji),2,':') + + dl_min=var__get_min(cl_name, cl_method) + dl_max=var__get_max(cl_name, cl_method) + dl_unf=var__get_unf(cl_name, cl_method) + cl_interp(:)=var__get_interp(cl_name, cl_method) + cl_extrap(:)=var__get_extrap(cl_name, cl_method) + cl_filter(:)=var__get_filter(cl_name, cl_method) + cl_unt=var__get_unt(cl_name, cl_method) + cl_namout=var__get_namout(cl_name, cl_method) + + + il_ind=var_get_index(tg_varextra(:), TRIM(cl_name)) + IF( il_ind /= 0 )THEN + IF( dl_min /= dp_fill ) tg_varextra(il_ind)%d_min=dl_min + IF( dl_max /= dp_fill ) tg_varextra(il_ind)%d_max=dl_max + IF( dl_unf /= dp_fill ) tg_varextra(il_ind)%d_unf=dl_unf + IF(cl_unt /='') tg_varextra(il_ind)%c_unt =cl_unt + IF(cl_namout /='') tg_varextra(il_ind)%c_namout =cl_namout + IF(cl_interp(1)/='') tg_varextra(il_ind)%c_interp(:)=cl_interp(:) + IF(cl_extrap(1)/='') tg_varextra(il_ind)%c_extrap(:)=cl_extrap(:) + IF(cl_filter(1)/='') tg_varextra(il_ind)%c_filter(:)=cl_filter(:) + ELSE + + IF( ALLOCATED(tg_varextra) )THEN + il_nvar=SIZE(tg_varextra(:)) + ! save older variable + ALLOCATE( tl_varextra(il_nvar) ) + tl_varextra(:)=var_copy(tg_varextra(:)) + + CALL var_clean(tg_varextra(:)) + DEALLOCATE(tg_varextra) + ALLOCATE( tg_varextra(il_nvar+1) ) + + tg_varextra(1:il_nvar)=var_copy(tl_varextra(:)) + + ! clean + CALL var_clean(tl_varextra(:)) + DEALLOCATE(tl_varextra) + + ELSE + + il_nvar=0 + ALLOCATE( tg_varextra(1) ) + + ENDIF + + ! add new variable + il_ind=il_nvar+1 + tg_varextra(il_ind)=var_init( TRIM(cl_name), & + & cd_interp=cl_interp(:), & + & cd_extrap=cl_extrap(:), & + & cd_filter=cl_filter(:), & + & dd_min = dl_min, & + & dd_max = dl_max, & + & cd_unt = cl_unt, & + & dd_unf = dl_unf, & + & cd_namout = cl_namout ) + + ENDIF + + ji=ji+1 + CALL logger_debug( "VAR CHG EXTRA: name "//& + & TRIM(tg_varextra(il_ind)%c_name) ) + CALL logger_debug( "VAR CHG EXTRA: interp "//& + & TRIM(tg_varextra(il_ind)%c_interp(1)) ) + CALL logger_debug( "VAR CHG EXTRA: filter "//& + & TRIM(tg_varextra(il_ind)%c_filter(1)) ) + CALL logger_debug( "VAR CHG EXTRA: extrap "//& + & TRIM(tg_varextra(il_ind)%c_extrap(1)) ) + IF( tg_varextra(il_ind)%d_min /= dp_fill )THEN + CALL logger_debug( "VAR CHG EXTRA: min value "//& + & TRIM(fct_str(tg_varextra(il_ind)%d_min)) ) + ENDIF + IF( tg_varextra(il_ind)%d_max /= dp_fill )THEN + CALL logger_debug( "VAR CHG EXTRA: max value "//& + & TRIM(fct_str(tg_varextra(il_ind)%d_max)) ) + ENDIF + IF( TRIM(tg_varextra(il_ind)%c_unt) /= '' )THEN + CALL logger_debug( "VAR CHG EXTRA: new unit "//& + & TRIM(tg_varextra(il_ind)%c_unt) ) + ENDIF + IF( tg_varextra(il_ind)%d_unf /= 1. )THEN + CALL logger_debug( "VAR CHG EXTRA: new unit factor "//& + & TRIM(fct_str(tg_varextra(il_ind)%d_unf)) ) + ENDIF + IF( TRIM(tg_varextra(il_ind)%c_namout) /= '' )THEN + CALL logger_debug( "VAR CHG EXTRA: new name output "//& + & TRIM(tg_varextra(il_ind)%c_namout) ) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE var_chg_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_clean_extra( ) + !------------------------------------------------------------------- + !> @brief + !> This subroutine clean global array of variable structure + !> with extra information: tg_varextra. + !> + !> @author J.Paul + !> @date October, 2016 - Initial Version + !> @date January, 2019 + !> - check if tg_varextra is allocated before clean it + !> + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + !---------------------------------------------------------------- + + IF( ALLOCATED(tg_varextra) )THEN + CALL var_clean(tg_varextra(:)) + DEALLOCATE(tg_varextra) + ENDIF + + END SUBROUTINE var_clean_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_read_matrix(td_var, cd_matrix) + !------------------------------------------------------------------- + !> @brief + !> This subroutine read matrix value from character string in namelist + !> and fill variable structure value. + !> + !> @details + !> to split matrix, separator use are:<br/> + !> - ',' for line + !> - '/' for row + !> - '\' for level<br/> + !> Example:<br/> + !> 3,2,3/1,4,5 => + !> @f$ \left( \begin{array}{ccc} + !> 3 & 2 & 3 \\ + !> 1 & 4 & 5 \end{array} \right) @f$ + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !> @param[in] cd_matrix matrix value + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=*), INTENT(IN ) :: cd_matrix + + ! local variable + CHARACTER(LEN=lc) :: cl_array + CHARACTER(LEN=lc) :: cl_line + CHARACTER(LEN=lc) :: cl_elt + + REAL(dp) , DIMENSION(:,:,:) , ALLOCATABLE :: dl_matrix + REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value + + TYPE(TDIM) , DIMENSION(:) , ALLOCATABLE :: tl_dim + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + IF( TRIM(cd_matrix) == '' )THEN + CALL logger_debug("VAR READ MATRIX: no matrix to be read") + ELSE + + !1- read matrix + ALLOCATE( dl_matrix(ip_maxmtx, ip_maxmtx, ip_maxmtx) ) + dl_matrix(:,:,:)=td_var%d_fill + + jk=1 + cl_array=fct_split(TRIM(cd_matrix),jk,'\ ') + CALL logger_debug("VAR MATRIX array "//TRIM(cl_array) ) + DO WHILE( TRIM(cl_array) /= '' ) + jj=1 + cl_line=fct_split(TRIM(cl_array),jj,'/') + CALL logger_debug("VAR MATRIX line "//TRIM(cl_line) ) + DO WHILE( TRIM(cl_line) /= '' ) + ji=1 + cl_elt=fct_split(TRIM(cl_line),ji,',') + CALL logger_debug("VAR MATRIX elt "//TRIM(cl_elt) ) + DO WHILE( TRIM(cl_elt) /= '') + READ(cl_elt,*) dl_matrix(ji,jj,jk) + ji=ji+1 + cl_elt=fct_split(TRIM(cl_line),ji,',') + CALL logger_debug("VAR MATRIX elt "//TRIM(cl_elt) ) + ENDDO + jj=jj+1 + cl_line=fct_split(TRIM(cl_array),jj,'/') + CALL logger_debug("VAR MATRIX line "//TRIM(cl_line) ) + ENDDO + jk=jk+1 + cl_array=fct_split(TRIM(cd_matrix),jk,'\ ') + CALL logger_debug("VAR MATRIX array "//TRIM(cl_array) ) + ENDDO + + ! save useful value + ALLOCATE( dl_value(ji-1,jj-1,jk-1,1) ) + dl_value(:,:,:,1)=dl_matrix(1:ji-1,1:jj-1,1:jk-1) + + DEALLOCATE(dl_matrix) + + ALLOCATE( tl_dim(3) ) + + IF( ji-1 > 0 ) tl_dim(1)=dim_init('x',ji-1) + IF( jj-1 > 0 ) tl_dim(2)=dim_init('y',jj-1) + IF( jk-1 > 0 ) tl_dim(3)=dim_init('z',jk-1) + + CALL var_add_dim(td_var, tl_dim(:)) + ! clean + CALL dim_clean(tl_dim) + DEALLOCATE( tl_dim ) + + IF( ASSOCIATED(td_var%d_value) ) DEALLOCATE(td_var%d_value) + CALL var_add_value(td_var, dl_value(:,:,:,:), id_type=NF90_FLOAT) + + DEALLOCATE( dl_value ) + ENDIF + + END SUBROUTINE var_read_matrix + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var__get_extra(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine add extra information in variable structure. + !> + !> @details + !> if variable name is informed in global array of variable structure (tg_varextra). + !> fill empty parameter on variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + + INTEGER(i4) :: il_ind + + TYPE(TATT) :: tl_att + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( ALLOCATED(tg_varextra) )THEN + + il_ind=var_get_index( tg_varextra(:), TRIM(td_var%c_name), & + TRIM(td_var%c_stdname)) + IF( il_ind /= 0 )THEN + + ! name + IF( TRIM(td_var%c_name) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_name) /= '' )THEN + td_var%c_name=TRIM(tg_varextra(il_ind)%c_name) + ENDIF + + ! standard name + IF( TRIM(tg_varextra(il_ind)%c_stdname) /= '' .AND. & + & ( TRIM(td_var%c_stdname) == '' .OR. & + & TRIM(tg_varextra(il_ind)%c_stdname) /= & + & TRIM(td_var%c_stdname) ) )THEN + td_var%c_stdname=TRIM(tg_varextra(il_ind)%c_stdname) + ! create attibute + tl_att=att_init('standard_name',TRIM(td_var%c_stdname)) + CALL var_move_att(td_var, tl_att) + ENDIF + + ! long_name + IF( TRIM(tg_varextra(il_ind)%c_longname) /= '' .AND. & + & ( TRIM(td_var%c_longname) == '' .OR. & + & TRIM(tg_varextra(il_ind)%c_longname) /= & + & TRIM(td_var%c_longname) ) )THEN + td_var%c_longname=TRIM(tg_varextra(il_ind)%c_longname) + ! create attibute + tl_att=att_init('long_name',TRIM(td_var%c_longname)) + CALL var_move_att(td_var, tl_att) + ENDIF + + ! units + IF( TRIM(td_var%c_units) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_units) /= '' )THEN + td_var%c_units=TRIM(tg_varextra(il_ind)%c_units) + ! create attibute + tl_att=att_init('units',TRIM(td_var%c_units)) + CALL var_move_att(td_var, tl_att) + ENDIF + + ! axis + IF( TRIM(tg_varextra(il_ind)%c_axis) /= '' .AND. & + & ( TRIM(td_var%c_axis) == '' .OR. & + & TRIM(tg_varextra(il_ind)%c_axis) /= & + & TRIM(td_var%c_axis) ) )THEN + td_var%c_axis=TRIM(tg_varextra(il_ind)%c_axis) + ! create attibute + IF( TRIM(fct_upper(td_var%c_name)) == TRIM(td_var%c_axis) )THEN + tl_att=att_init('axis',TRIM(td_var%c_axis)) + ELSE + cl_tmp="" + DO ji=LEN(TRIM(td_var%c_axis)),1,-1 + cl_tmp=TRIM(cl_tmp)//" "//TRIM(td_var%c_axis(ji:ji)) + ENDDO + tl_att=att_init('associate',TRIM(ADJUSTL(cl_tmp))) + ENDIF + CALL var_move_att(td_var, tl_att) + ENDIF + + ! grid point + IF( TRIM(tg_varextra(il_ind)%c_point) /= '' .AND. & + & ( TRIM(td_var%c_point) == '' .OR. & + & TRIM(tg_varextra(il_ind)%c_point) /= & + & TRIM(td_var%c_point) ) )THEN + td_var%c_point=TRIM(tg_varextra(il_ind)%c_point) + ELSE + IF( TRIM(td_var%c_point) == '' )THEN + CALL logger_warn("VAR GET EXTRA: unknown grid point "//& + & "for variable "//TRIM(td_var%c_name)//& + & ". assume it is a T-point.") + td_var%c_point='T' + ENDIF + ENDIF + ! create attibute + tl_att=att_init('grid_point',TRIM(td_var%c_point)) + CALL var_move_att(td_var, tl_att) + + ! clean + CALL att_clean(tl_att) + + ! interp + IF( TRIM(td_var%c_interp(1)) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_interp(1)) /= '' )THEN + td_var%c_interp(:)=tg_varextra(il_ind)%c_interp(:) + ENDIF + + ! extrap + IF( TRIM(td_var%c_extrap(1)) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_extrap(1)) /= '' )THEN + td_var%c_extrap(:)=tg_varextra(il_ind)%c_extrap(:) + ENDIF + + ! filter + IF( TRIM(td_var%c_filter(1)) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_filter(1)) /= '' )THEN + td_var%c_filter(:)=tg_varextra(il_ind)%c_filter(:) + ENDIF + + ! min value + IF( td_var%d_min == dp_fill .AND. & + & tg_varextra(il_ind)%d_min /= dp_fill )THEN + td_var%d_min=tg_varextra(il_ind)%d_min + ENDIF + + ! max value + IF( td_var%d_max == dp_fill .AND. & + & tg_varextra(il_ind)%d_max /= dp_fill )THEN + td_var%d_max=tg_varextra(il_ind)%d_max + ENDIF + + ! unt + IF( TRIM(td_var%c_unt) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_unt) /= '' )THEN + td_var%c_unt=TRIM(tg_varextra(il_ind)%c_unt) + ENDIF + + ! units factor + IF( td_var%d_unf == 1._dp .AND. & + & tg_varextra(il_ind)%d_unf /= 1._dp )THEN + td_var%d_unf=tg_varextra(il_ind)%d_unf + ENDIF + + ! namout + IF( TRIM(td_var%c_namout) == '' .AND. & + & TRIM(tg_varextra(il_ind)%c_namout) /= '' )THEN + td_var%c_namout=TRIM(tg_varextra(il_ind)%c_namout) + ENDIF + + ELSE + CALL logger_warn("VAR GET EXTRA: no extra information on "//& + & "variable "//TRIM(td_var%c_name)//". you should define it"//& + & " (see variable.cfg).") + ENDIF + + ELSE + + CALL logger_debug("VAR GET EXTRA: no extra information on variable "//& + & " you should have run var_def_extra. ") + + ENDIF + + END SUBROUTINE var__get_extra + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_min(cd_name, cd_varinfo) & + & RESULT (df_min) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> minimum value and return it if true. + !> + !> @details + !> minimum value is assume to follow string "min =" + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - change way to get information in namelist, + !> value follows string "min =" + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return minimum value to be used (FillValue if none) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + REAL(dp) :: df_min + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_min + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! init + cl_min='' + df_min=dp_fill + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'min') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('min') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_min=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_min) /= '' )THEN + IF( fct_is_real(cl_min) )THEN + READ(cl_min,*) df_min + CALL logger_debug("VAR GET MIN: will use minimum value of "//& + & TRIM(fct_str(df_min))//" for variable "//TRIM(cd_name) ) + ELSE + CALL logger_error("VAR GET MIN: invalid minimum value ("//& + & TRIM(cl_min)//") for variable "//TRIM(cd_name)//& + & ". check namelist." ) + ENDIF + ENDIF + + END FUNCTION var__get_min + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_max(cd_name, cd_varinfo) & + & RESULT (df_max) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> maximum value and return it if true. + !> + !> @details + !> maximum value is assume to follow string "max =" + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - change way to get information in namelist, + !> value follows string "max =" + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return maximum value to be used (FillValue if none) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + REAL(dp) :: df_max + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_max + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! init + cl_max='' + df_max=dp_fill + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'max') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('max') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_max=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_max) /= '' )THEN + IF( fct_is_real(cl_max) )THEN + READ(cl_max,*) df_max + CALL logger_debug("VAR GET MAX: will use maximum value of "//& + & TRIM(fct_str(df_max))//" for variable "//TRIM(cd_name) ) + ELSE + CALL logger_error("VAR GET MAX: invalid maximum value for "//& + & "variable "//TRIM(cd_name)//". check namelist." ) + ENDIF + ENDIF + + END FUNCTION var__get_max + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_unf(cd_name, cd_varinfo) & + & RESULT (df_unf) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> units factor value and return it if true. + !> + !> @details + !> units factor value is assume to follow string "unf =" + !> + !> @author J.Paul + !> @date June, 2015 - Initial Version + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return untis factor value to be used (FillValue if none) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + REAL(dp) :: df_unf + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_unf + + INTEGER(i4) :: il_ind + + REAL(dp) :: dl_unf + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + ! init + cl_unf='' + df_unf=dp_fill + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'unf') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('unf') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_unf=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_unf) /= '' )THEN + dl_unf=math_compute(cl_unf) + IF( dl_unf /= dp_fill )THEN + df_unf = dl_unf + CALL logger_debug("VAR GET UNITS FACTOR: will use units factor "//& + & "value of "//TRIM(fct_str(df_unf))//" for variable "//& + & TRIM(cd_name) ) + ELSE + CALL logger_error("VAR GET UNITS FACTOR: invalid units factor "//& + & "value for variable "//TRIM(cd_name)//". check namelist." ) + ENDIF + ENDIF + + END FUNCTION var__get_unf + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_interp(cd_name, cd_varinfo) & + & RESULT (cf_interp) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> interpolation method and return it if true. + !> + !> @details + !> interpolation method is assume to follow string "int =" + !> + !> compare method name with the list of interpolation method available (see + !> module global). + !> check if factor (*rhoi, /rhoj..) are present.<br/> + !> Example:<br/> + !> - int=cubic/rhoi ; ext=dist_weight + !> - int=bilin + !> see @ref interp module for more information. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - change way to get information in namelist, + !> value follows string "int =" + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return array of character information about interpolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + CHARACTER(LEN=lc), DIMENSION(2) :: cf_interp + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_int + CHARACTER(LEN=lc) :: cl_factor + + INTEGER(i4) :: il_ind + INTEGER(i4) :: il_len + + INTEGER(i4) :: il_mul + INTEGER(i4) :: il_div + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + cf_interp(:)='' + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'int') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('int') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_int=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_int) /= '' )THEN + DO jj=1,ip_ninterp + il_ind= INDEX(fct_lower(cl_int),TRIM(cp_interp_list(jj))) + IF( il_ind /= 0 )THEN + + cf_interp(1)=TRIM(cp_interp_list(jj)) + il_len=LEN(TRIM(cp_interp_list(jj))) + + ! look for factor + IF( il_ind==1 )THEN + cl_factor=cl_int(il_len+1:) + ELSE + cl_factor=cl_int(1:il_ind-1) + ENDIF + il_mul=SCAN(TRIM(cl_factor),'*') + il_div=SCAN(TRIM(cl_factor),'/') + + il_len=LEN(cl_factor) + IF( il_mul /= 0 )THEN + IF( il_mul==1 )THEN + cl_factor=cl_factor(2:il_len) + ELSE + cl_factor=cl_factor(1:il_mul-1) + ENDIF + + ELSE IF( il_div /=0 )THEN + IF( il_div==1 )THEN + cl_factor=cl_factor(2:il_len) + ELSE + cl_factor=cl_factor(1:il_div-1) + ENDIF + + ELSE + cl_factor='' + ENDIF + + SELECT CASE(TRIM(cl_factor)) + CASE('rhoi','rhoj','rhok') + IF( il_mul /= 0 ) cf_interp(2)='*'//TRIM(cl_factor) + IF( il_div /= 0 ) cf_interp(2)='/'//TRIM(cl_factor) + CASE('') + cf_interp(2)='' + CASE DEFAULT + cf_interp(2)='' + CALL logger_error("VAR GET INTERP: variable "//& + & TRIM(cd_name)//& + & " invalid factor coefficient. check namelist. "//& + & " factor should be choose between rhox rhoy rhoz.") + END SELECT + + EXIT + ENDIF + ENDDO + ENDIF + + END FUNCTION var__get_interp + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_extrap(cd_name, cd_varinfo) & + & RESULT (cf_extrap) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> extrapolation method and return it if true. + !> + !> @details + !> extrapolation method is assume to follow string "ext =" + !> + !> compare method name with the list of extrapolation method available (see + !> module global).<br/> + !> Example:<br/> + !> - int=cubic ; ext=dist_weight + !> - ext=min_error + !> see @ref extrap module for more information. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - change way to get information in namelist, + !> value follows string "ext =" + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return array of character information about extrapolation + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + CHARACTER(LEN=lc), DIMENSION(1) :: cf_extrap + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_ext + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + cf_extrap(:)='' + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'ext') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('ext') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_ext=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_ext) /= '' )THEN + DO jj=1,ip_nextrap + IF( TRIM(fct_lower(cl_ext)) == TRIM(cp_extrap_list(jj)) )THEN + cf_extrap(1)=TRIM(cp_extrap_list(jj)) + + CALL logger_trace("VAR GET EXTRAP: variable "//TRIM(cd_name)//& + & " will use extrapolation method "//TRIM(cf_extrap(1)) ) + + EXIT + ENDIF + ENDDO + ENDIF + + + END FUNCTION var__get_extrap + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_filter(cd_name, cd_varinfo) & + & RESULt (cf_filter) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> filter method and return it if true + !> + !> @details + !> filter method is assume to follow string "flt =" + !> + !> compare method name with the list of filter method available (see + !> module global). + !> look for the number of run, using '*' separator, and method parameters inside + !> bracket.<br/> + !> Example:<br/> + !> - int=cubic ; flt=2*hamming(2,3) + !> - flt=hann + !> see @ref filter module for more information. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> @date June, 2015 + !> - change way to get information in namelist, + !> value follows string "flt =" + !> @date Feb, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + CHARACTER(LEN=lc), DIMENSION(5) :: cf_filter + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + CHARACTER(LEN=lc) :: cl_flt + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + cf_filter(:)='' + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'flt') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('flt') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cl_flt=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cl_flt) /= '' )THEN + DO jj=1,ip_nfilter + il_ind=INDEX(fct_lower(cl_flt),TRIM(cp_filter_list(jj))) + IF( il_ind /= 0 )THEN + cf_filter(1)=TRIM(cp_filter_list(jj)) + + ! look for number of run + il_ind=SCAN(fct_lower(cl_flt),'*') + IF( il_ind /=0 )THEN + IF( fct_is_num(cl_flt(1:il_ind-1)) )THEN + cf_filter(2)=TRIM(cl_flt(1:il_ind-1)) + ELSE IF( fct_is_num(cl_flt(il_ind+1:)) )THEN + cf_filter(2)=TRIM(cl_flt(il_ind+1:)) + ELSE + cf_filter(2)='1' + ENDIF + ELSE + cf_filter(2)='1' + ENDIF + + ! look for filter parameter + il_ind=SCAN(fct_lower(cl_flt),'(') + IF( il_ind /=0 )THEN + cl_flt=TRIM(cl_flt(il_ind+1:)) + il_ind=SCAN(fct_lower(cl_flt),')') + IF( il_ind /=0 )THEN + cl_flt=TRIM(cl_flt(1:il_ind-1)) + ! look for cut-off frequency + cf_filter(3)=fct_split(cl_flt,1,',') + ! look for halo size + cf_filter(4)=fct_split(cl_flt,2,',') + ! look for alpha parameter + cf_filter(5)=fct_split(cl_flt,3,',') + ELSE + CALL logger_error("VAR GET FILTER: variable "//& + & TRIM(cd_name)//& + & " unclosed parentheses. check namelist. ") + ENDIF + ELSE + cf_filter(3)='' + cf_filter(4)='' + cf_filter(5)='' + ENDIF + + CALL logger_trace("VAR GET FILTER: name "//TRIM(cf_filter(1))) + CALL logger_trace("VAR GET FILTER: nturn "//TRIM(cf_filter(2))) + CALL logger_trace("VAR GET FILTER: cutoff "//TRIM(cf_filter(3))) + CALL logger_trace("VAR GET FILTER: halo "//TRIM(cf_filter(4))) + CALL logger_trace("VAR GET FILTER: alpha "//TRIM(cf_filter(5))) + + EXIT + ENDIF + ENDDO + ENDIF + + END FUNCTION var__get_filter + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_unt(cd_name, cd_varinfo) & + & RESULT (cf_unt) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> output unit and return it if true. + !> + !> @details + !> output unit is assume to follow string "unt =" + !> + !> @author J.Paul + !> @date June, 2015 - Initial Version + !> @date February, 2016 + !> - check character just after keyword + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return unit string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + CHARACTER(LEN=lc) :: cf_unt + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + cf_unt='' + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'unt') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('unt') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cf_unt=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cf_unt) /= '' )THEN + CALL logger_debug("VAR GET UNIT: will use output unit "//& + & TRIM(cf_unt)//" for variable "//& + & TRIM(cd_name) ) + ENDIF + + END FUNCTION var__get_unt + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var__get_namout(cd_name, cd_varinfo) & + & RESULT (cf_namout) + !------------------------------------------------------------------- + !> @brief + !> This function check if variable information read in namelist contains + !> variable ouptut name and return it if true. + !> + !> @details + !> output name is assume to follow string "out =" + !> + !> @author J.Paul + !> @date February, 2019 - Initial Version + !> + !> @param[in] cd_name variable name + !> @param[in] cd_varinfo variable information read in namelist + !> @return ouptut name string character + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN ) :: cd_name + CHARACTER(LEN=*), INTENT(IN ) :: cd_varinfo + + ! function + CHARACTER(LEN=lc) :: cf_namout + + ! local variable + CHARACTER(LEN=lc) :: cl_tmp + + INTEGER(i4) :: il_ind + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + cf_namout='' + + ji=1 + cl_tmp=fct_split(cd_varinfo,ji,';') + DO WHILE( TRIM(cl_tmp) /= '' ) + il_ind=INDEX(TRIM(cl_tmp),'out') + IF( il_ind /= 0 )THEN + ! check character just after + jj=il_ind+LEN('out') + IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & + & TRIM(cl_tmp(jj:jj)) == '=' )THEN + cf_namout=fct_split(cl_tmp,2,'=') + EXIT + ENDIF + ENDIF + ji=ji+1 + cl_tmp=fct_split(cd_varinfo,ji,';') + ENDDO + + IF( TRIM(cf_namout) /= '' )THEN + CALL logger_debug("VAR GET NAMOUT: will use output name "//& + & TRIM(cf_namout)//" for variable "//& + & TRIM(cd_name) ) + ENDIF + + END FUNCTION var__get_namout + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_max_dim(td_var) & + & RESULT (tf_dim) + !------------------------------------------------------------------- + !> @brief + !> This function search and save the biggest dimensions use + !> in an array of variable structure. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_var array of variable structure + !> @return array of dimension + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_var + + ! function + TYPE(TDIM), DIMENSION(ip_maxdim) :: tf_dim + + ! local variable + INTEGER(i4) :: il_nvar + + ! loop indices + INTEGER(i4) :: ji + !------------------------------------------------------------------- + + il_nvar=SIZE(td_var(:)) + + tf_dim(:)=dim_copy(td_var(1)%t_dim(:)) + + IF( il_nvar > 1 )THEN + DO ji=2,il_nvar + + IF( td_var(ji)%t_dim(1)%l_use .AND. & + & td_var(ji)%t_dim(1)%i_len >= tf_dim(1)%i_len )THEN + tf_dim(1)=dim_copy(td_var(ji)%t_dim(1)) + ENDIF + + IF( td_var(ji)%t_dim(2)%l_use .AND. & + & td_var(ji)%t_dim(2)%i_len >= tf_dim(2)%i_len )THEN + tf_dim(2)=dim_copy(td_var(ji)%t_dim(2)) + ENDIF + + IF( td_var(ji)%t_dim(3)%l_use .AND. & + & td_var(ji)%t_dim(3)%i_len >= tf_dim(3)%i_len )THEN + tf_dim(3)=dim_copy(td_var(ji)%t_dim(3)) + ENDIF + + IF( td_var(ji)%t_dim(4)%l_use .AND. & + & td_var(ji)%t_dim(4)%i_len >= tf_dim(4)%i_len )THEN + tf_dim(4)=dim_copy(td_var(ji)%t_dim(4)) + ENDIF + + ENDDO + ENDIF + + END FUNCTION var_max_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_limit_value(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine forced minimum and maximum value of variable, + !> with value of variable structure attribute d_min and d_max. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + + ! loop indices + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + !1- forced minimum value + IF( td_var%d_min /= dp_fill )THEN + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill .AND. & + & td_var%d_value(:,:,:,:) < td_var%d_min ) + td_var%d_value(:,:,:,:)=td_var%d_min + END WHERE + ENDIF + + !2- forced maximum value + IF( td_var%d_max /= dp_fill )THEN + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill .AND. & + & td_var%d_value(:,:,:,:) > td_var%d_max ) + td_var%d_value(:,:,:,:)=td_var%d_max + END WHERE + ENDIF + + ENDIF + + END SUBROUTINE var_limit_value + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_chg_name(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine replace name of the variable, + !> + !> @details + !> output name (namout) is read from the namelist. + !> + !> @note the variable value should be already read. + !> + !> @author J.Paul + !> @date February, 2019 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + !- change variable name + IF( TRIM(td_var%c_namout) /= TRIM(td_var%c_name) .AND. & + & TRIM(td_var%c_namout) /= '' )THEN + td_var%c_name = TRIM(td_var%c_namout) + ENDIF + + ENDIF + + END SUBROUTINE var_chg_name + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_chg_unit(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine replace unit name of the variable, + !> and apply unit factor to the value of this variable. + !> + !> @details + !> new unit name (unt) and unit factor (unf) are read from the namelist. + !> + !> @note the variable value should be already read. + !> + !> @author J.Paul + !> @date June, 2015 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + TYPE(TATT) :: tl_att + + ! loop indices + !---------------------------------------------------------------- + + IF( ASSOCIATED(td_var%d_value) )THEN + !- change value + IF( td_var%d_unf /= 1._dp )THEN + WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill ) + td_var%d_value(:,:,:,:)=td_var%d_value(:,:,:,:)*td_var%d_unf + END WHERE + + !- change scale factor and offset to avoid mistake + tl_att=att_init('scale_factor',1._dp) + CALL var_move_att(td_var, tl_att) + + tl_att=att_init('add_offset',0._dp) + CALL var_move_att(td_var, tl_att) + ENDIF + + !- change unit name + IF( TRIM(td_var%c_unt) /= TRIM(td_var%c_units) .AND. & + & TRIM(td_var%c_unt) /= '' )THEN + tl_att=att_init('units',TRIM(td_var%c_unt)) + CALL var_move_att(td_var,tl_att) + ENDIF + ! clean + CALL att_clean(tl_att) + + ENDIF + + END SUBROUTINE var_chg_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_check_dim(td_var) + !------------------------------------------------------------------- + !> @brief + !> This subroutine check variable dimension expected, as defined in + !> file 'variable.cfg'. + !> + !> @details + !> compare dimension used in variable structure with string character + !> axis from configuration file. + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[inout] td_var variable structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(INOUT) :: td_var + + ! local variable + INTEGER(i4) :: il_naxis + INTEGER(i4) :: il_ndim + CHARACTER(LEN=lc) :: cl_dim + + LOGICAL :: ll_warn + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + IF( TRIM(td_var%c_axis) /= '' )THEN + + cl_dim='' + DO ji=1,ip_maxdim + IF( td_var%t_dim(ji)%l_use )THEN + cl_dim=TRIM(cl_dim)//TRIM(fct_upper(td_var%t_dim(ji)%c_sname)) + ENDIF + ENDDO + + il_naxis=LEN( TRIM(ADJUSTL(td_var%c_axis)) ) + il_ndim =LEN( TRIM(ADJUSTL(cl_dim)) ) + IF( il_naxis >= il_ndim )THEN + ll_warn=.FALSE. + DO ji=1,il_naxis + IF( INDEX(TRIM(cl_dim),td_var%c_axis(ji:ji)) == 0 )THEN + CALL logger_debug("VAR CHECK DIM: "//TRIM(cl_dim)//& + & " "//TRIM(td_var%c_axis(ji:ji)) ) + ll_warn=.TRUE. + EXIT + ENDIF + ENDDO + + IF( ll_warn )THEN + CALL logger_warn("VAR CHECK DIM: variable dimension ("//& + & TRIM(cl_dim)//") not conform with dimension"//& + & " expected ("//TRIM(td_var%c_axis)//"). ") + ENDIF + ELSE + ! too much dimension + CALL logger_warn("VAR CHECK DIM: too much dimension for "//& + & "variable "//TRIM(td_var%c_name)//".") + cl_dim=TRIM(fct_upper(cp_dimorder)) + il_ndim =LEN( TRIM(ADJUSTL(cl_dim)) ) + DO ji=1,il_ndim + IF( INDEX(TRIM(td_var%c_axis),cl_dim(ji:ji)) == 0 )THEN + IF( td_var%t_dim(ji)%l_use )THEN + IF( td_var%t_dim(ji)%i_len == 1 )THEN + ! remove useless dimension + CALL var_del_dim(td_var,td_var%t_dim(ji)) + ELSE + CALL logger_warn("VAR CHECK DIM: variable "//& + & TRIM(td_var%c_name)//" should not use"//& + & " dimension "//TRIM(td_var%t_dim(ji)%c_name)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + + ELSE + ! no information on variable dimension expected + ENDIF + + END SUBROUTINE var_check_dim + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_reorder(td_var, cd_dimorder) + !------------------------------------------------------------------- + !> @brief + !> This subroutine reshape variable value and dimension + !> in variable structure. + !> @details + !> output dimension will be ordered as defined in + !> input array of dimension + !> Optionaly you could specify output dimension order with + !> string character of dimension + !> + !> @author J.Paul + !> @date August, 2014 - Initial Version + !> @date July 2015 + !> - do not use dim_disorder anymore + !> + !> @param[inout] td_var variable structure + !> @param[in] cd_dimorder string character of dimension order to be used + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR) , INTENT(INOUT) :: td_var + CHARACTER(LEN=ip_maxdim), INTENT(IN ), OPTIONAL :: cd_dimorder + + ! local variable + CHARACTER(LEN=lc) :: cl_dimorder + + REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value + + TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim + + ! loop indices + !---------------------------------------------------------------- + + cl_dimorder=TRIM(cp_dimorder) + IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(ADJUSTL(cd_dimorder)) + + CALL logger_debug("VAR REORDER: work on "//TRIM(td_var%c_name)//& + & " new dimension order "//TRIM(cl_dimorder)) + + tl_dim(:)=dim_copy(td_var%t_dim(:)) + + CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder)) + + ALLOCATE(dl_value(tl_dim(1)%i_len, & + & tl_dim(2)%i_len, & + & tl_dim(3)%i_len, & + & tl_dim(4)%i_len )) + + dl_value(:,:,:,:)=dim_reshape_2xyzt(tl_dim, & + & td_var%d_value(:,:,:,:)) + + ! change dimension + td_var%t_dim(:)=dim_copy(tl_dim(:)) + ! change value + DEALLOCATE( td_var%d_value ) + CALL var_add_value(td_var, dl_value(:,:,:,:)) + + ! clean + DEALLOCATE(dl_value) + CALL dim_clean(tl_dim(:)) + + END SUBROUTINE var_reorder + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_get_unit(td_var) & + & RESULT (if_unit) + !------------------------------------------------------------------- + !> @brief + !> This function get the next unused unit in array of variable structure. + !> + !> @author J.Paul + !> @date September, 2014 - Initial Version + !> + !> @param[in] td_var array of variable structure + !> @return free variable id + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_var + + ! function + INTEGER(i4) :: if_unit + + ! local variable + ! loop indices + !---------------------------------------------------------------- + + if_unit=MAXVAL(td_var(:)%i_id)+1 + + END FUNCTION var_get_unit + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_to_date(td_var) & + & RESULT (tf_date) + !------------------------------------------------------------------- + !> @brief + !> This function convert a time variable structure in date structure. + !> + !> @author J.Paul + !> @date November, 2014 - Initial Version + !> @date January, 2019 + !> - add case for units in hours + !> + !> @param[in] td_var time variable structure + !> @return date structure + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + TYPE(TDATE) :: tf_date + + ! local variable + CHARACTER(LEN=lc) :: cl_step + CHARACTER(LEN=lc) :: cl_date + + INTEGER(i4) :: il_attid + + INTEGER(i8) :: kl_nsec + + TYPE(TDATE) :: tl_dateo + ! loop indices + !---------------------------------------------------------------- + + IF( INDEX(TRIM(td_var%c_name),'time') /= 0 )THEN + IF( ASSOCIATED(td_var%d_value) )THEN + + il_attid=att_get_index(td_var%t_att(:),'units') + IF( il_attid /=0 )THEN + cl_step=fct_split(td_var%t_att(il_attid)%c_value,1,'since') + cl_date=fct_split(td_var%t_att(il_attid)%c_value,2,'since') + + SELECT CASE(TRIM(cl_step)) + CASE('seconds') + kl_nsec=INT(td_var%d_value(1,1,1,1),i8) + CASE('hours') + kl_nsec=INT(td_var%d_value(1,1,1,1)*3600,i8) + CASE('days') + kl_nsec=INT(td_var%d_value(1,1,1,1)*86400,i8) + CASE DEFAULT + CALL logger_error("VAR TO DATE: unknown units format "//& + & "in variable "//TRIM(td_var%c_name)) + END SELECT + + CALL logger_trace("VAR TO DATE: "//fct_str(kl_nsec)//& + & "seconds since "//TRIM(cl_date)) + + tl_dateo=date_init(cl_date) + + tf_date=date_init(kl_nsec,tl_dateo) + + ELSE + CALL logger_error("VAR TO DATE: no attribute units in "//& + & "variable "//TRIM(td_var%c_name)) + ENDIF + ELSE + CALL logger_error("VAR TO DATE: no value associated to "//& + & "variable "//TRIM(td_var%c_name)) + ENDIF + ELSE + CALL logger_error("VAR TO DATE: variable "//TRIM(td_var%c_name)//& + & "can not be convert in date.") + ENDIF + + END FUNCTION var_to_date + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE var_get_dummy(cd_dummy) + !------------------------------------------------------------------- + !> @brief This subroutine fill dummy variable array + !> + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date May, 2019 + !> - read number of dummy element + !> + !> @param[in] cd_dummy dummy configuration file + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + CHARACTER(LEN=*), INTENT(IN) :: cd_dummy + + ! local variable + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_status + + LOGICAL :: ll_exist + + ! loop indices + ! namelist + INTEGER(i4) :: in_ndumvar + INTEGER(i4) :: in_ndumdim + INTEGER(i4) :: in_ndumatt + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumvar + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumdim + CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumatt + + !---------------------------------------------------------------- + NAMELIST /namdum/ & !< dummy namelist + & in_ndumvar,& !< number of variable name + & in_ndumdim,& !< number of dimension name + & in_ndumatt,& !< number of attribute name + & cn_dumvar, & !< variable name + & cn_dumdim, & !< dimension name + & cn_dumatt !< attribute name + !---------------------------------------------------------------- + + ! init + cm_dumvar(:)='' + + ! read namelist + INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_dummy), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) + ENDIF + + READ( il_fileid, NML = namdum ) + im_ndumvar = in_ndumvar + cm_dumvar(:)= cn_dumvar(:) + + CLOSE( il_fileid ) + + IF( im_ndumvar > ip_maxdumcfg )THEN + CALL logger_fatal("VAR GET dUMMY : too much dummy variables & + & ( >"//fct_str(ip_maxdumcfg)//" ). & + & set ip_maxdumcfg to higher value.") + ENDIF + + ENDIF + + END SUBROUTINE var_get_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION var_is_dummy(td_var) & + & RESULT (lf_dummy) + !------------------------------------------------------------------- + !> @brief This function check if variable is defined as dummy variable + !> in configuraton file + !> + !> @author J.Paul + !> @date September, 2015 - Initial Version + !> @date, May, 2019 + !> - use number of dummy elt in do-loop + !> + !> @param[in] td_var variable structure + !> @return true if variable is dummy variable + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TVAR), INTENT(IN) :: td_var + + ! function + LOGICAL :: lf_dummy + + ! loop indices + INTEGER(i4) :: ji + !---------------------------------------------------------------- + + lf_dummy=.FALSE. + DO ji=1,im_ndumvar !ip_maxdumcfg + IF( fct_lower(td_var%c_name) == fct_lower(cm_dumvar(ji)) )THEN + lf_dummy=.TRUE. + EXIT + ENDIF + ENDDO + + END FUNCTION var_is_dummy + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE var + diff --git a/V4.0/nemo_sources/tools/SIREN/src/vgrid.f90 b/V4.0/nemo_sources/tools/SIREN/src/vgrid.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b57e6f04ce6091708d0c1f5ab6a8ddf619a5b858 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/src/vgrid.f90 @@ -0,0 +1,872 @@ +!---------------------------------------------------------------------- +! NEMO system team, System and Interface for oceanic RElocable Nesting +!---------------------------------------------------------------------- +! +! DESCRIPTION: +!> @brief This module manage vertical grid. +!> +!> @details +!> to set the depth of model levels and the resulting vertical scale +!> factors:<br/> +!> @code +!> CALL vgrid_zgr_z(dd_gdepw(:), dd_gdept(:), dd_e3w(:), dd_e3t(:), +!> dd_ppkth, dd_ppkth2, dd_ppacr, dd_ppacr2, +!> dd_ppdzmin, dd_pphmax, dd_pp_to_be_computed, +!> dd_ppa0, dd_ppa1, dd_ppa2, dd_ppsur) +!> @endcode +!> - dd_gdepw is array of depth value on W point +!> - dd_gdept is array of depth value on T point +!> - dd_e3w is array of vertical mesh size on W point +!> - dd_e3t is array of vertical mesh size on T point +!> - dd_ppkth see NEMO documentation +!> - dd_ppkth2 see NEMO documentation +!> - dd_ppacr see NEMO documentation +!> - dd_ppdzmin see NEMO documentation +!> - dd_pphmax see NEMO documentation +!> - dd_pp_to_be_computed see NEMO documentation +!> - dd_ppa1 see NEMO documentation +!> - dd_ppa2 see NEMO documentation +!> - dd_ppa0 see NEMO documentation +!> - dd_ppsur see NEMO documentation +!> +!> +!> to set the depth and vertical scale factor in partial step z-coordinate +!> case:<br/> +!> @code +!> CALL vgrid_zgr_zps(id_mbathy(:,:), dd_bathy(:,:), id_jpkmax, dd_gdepw(:), +!> dd_e3t(:), dd_e3zps_min, dd_e3zps_rat) +!> @endcode +!> - id_mbathy is array of bathymetry level +!> - dd_bathy is array of bathymetry +!> - id_jpkmax is the maximum number of level to be used +!> - dd_gdepw is array of vertical mesh size on W point +!> - dd_e3t is array of vertical mesh size on T point +!> - dd_e3zps_min see NEMO documentation +!> - dd_e3zps_rat see NEMO documentation +!> +!> to check the bathymetry in levels:<br/> +!> @code +!> CALL vgrid_zgr_bat_ctl(id_mbathy, id_jpkmax, id_jpk) +!> @endcode +!> - id_mbathy is array of bathymetry level +!> - id_jpkmax is the maximum number of level to be used +!> - id_jpk is the number of level +!> +!> to compute bathy level in T,U,V,F point from Bathymetry file:<br/> +!> @code +!> tl_level(:)=vgrid_get_level(td_bathy, [cd_namelist,] [td_dom,] [id_nlevel]) +!> @endcode +!> - td_bathy is Bathymetry file structure +!> - cd_namelist is namelist [optional] +!> - td_dom is domain structure [optional] +!> - id_nlevel is number of lelvel to be used [optional] +!> +!> @author +!> J.Paul +!> +!> @date November, 2013 - Initial Version +!> @date Spetember, 2014 +!> - add header +!> @date June, 2015 - update subroutine with NEMO 3.6 +!> +!> @todo +!> - fusionner vgrid et grid_zgr +!> +!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) +!---------------------------------------------------------------------- +MODULE vgrid + + USE netcdf ! nf90 library + USE kind ! F90 kind parameter + USE fct ! basic usefull function + USE global ! global parameter + USE phycst ! physical constant + USE logger ! log file manager + USE file ! file manager + USE var ! variable manager + USE dim ! dimension manager + USE dom ! domain manager + USE grid ! grid manager + USE iom ! I/O manager + USE mpp ! MPP manager + USE iom_mpp ! I/O MPP manager + IMPLICIT NONE + ! NOTE_avoid_public_variables_if_possible + + ! type and variable + + ! function and subroutine + PUBLIC :: vgrid_zgr_z + PUBLIC :: vgrid_zgr_zps + PUBLIC :: vgrid_zgr_bat_ctl + PUBLIC :: vgrid_get_level + +CONTAINS + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE vgrid_zgr_z(dd_gdepw, dd_gdept, dd_e3w, dd_e3t, & + & dd_e3w_1d, dd_e3t_1d, & + & dd_ppkth, dd_ppkth2, dd_ppacr, dd_ppacr2, & + & dd_ppdzmin, dd_pphmax, dd_pp_to_be_computed, & + & dd_ppa0, dd_ppa1, dd_ppa2, dd_ppsur ) + !------------------------------------------------------------------- + !> @brief This subroutine set the depth of model levels and the resulting + !> vertical scale factors. + !> + !> @details + !> ** Method : z-coordinate system (use in all type of coordinate) + !> The depth of model levels is defined from an analytical + !> function the derivative of which gives the scale factors. + !> both depth and scale factors only depend on k (1d arrays). <br/> + !> w-level: gdepw = fsdep(k) <br/> + !> e3w(k) = dk(fsdep)(k) = fse3(k) <br/> + !> t-level: gdept = fsdep(k+0.5) <br/> + !> e3t(k) = dk(fsdep)(k+0.5) = fse3(k+0.5) <br/> + !> + !> ** Action : - gdept, gdepw : depth of T- and W-point (m) <br/> + !> - e3t, e3w : scale factors at T- and W-levels (m) <br/> + !> + !> @author G. Madec + !> @date Marsh,2008 - F90: Free form and module + !> + !> @note Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !> + !> @param[inout] dd_gdepw + !> @param[inout] dd_gedpt + !> @param[inout] dd_e3w + !> @param[inout] dd_e2t + !> @param[in] dd_ppkth + !> @param[in] dd_ppkth2 + !> @param[in] dd_ppacr + !> @param[in] dd_ppacr2 + !> @param[in] dd_ppdzmin + !> @param[in] dd_pphmax + !> @param[in] dd_pp_to_be_computed + !> @param[in] dd_ppa1 + !> @param[in] dd_ppa2 + !> @param[in] dd_ppa0 + !> @param[in] dd_ppsur + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_gdepw + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_gdept + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3w + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3t + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3w_1d + REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_e3t_1d + + REAL(dp) , INTENT(IN ) :: dd_ppkth + REAL(dp) , INTENT(IN ) :: dd_ppkth2 + REAL(dp) , INTENT(IN ) :: dd_ppacr + REAL(dp) , INTENT(IN ) :: dd_ppacr2 + + REAL(dp) , INTENT(IN ) :: dd_ppdzmin + REAL(dp) , INTENT(IN ) :: dd_pphmax + REAL(dp) , INTENT(IN ) :: dd_pp_to_be_computed + + REAL(dp) , INTENT(IN ) :: dd_ppa0 + REAL(dp) , INTENT(IN ) :: dd_ppa1 + REAL(dp) , INTENT(IN ) :: dd_ppa2 + REAL(dp) , INTENT(IN ) :: dd_ppsur + + ! local variable + REAL(dp) :: dl_zkth + REAL(dp) :: dl_zkth2 + REAL(dp) :: dl_zdzmin + REAL(dp) :: dl_zhmax + REAL(dp) :: dl_zacr + REAL(dp) :: dl_zacr2 + + REAL(dp) :: dl_ppacr + REAL(dp) :: dl_ppacr2 + + REAL(dp) :: dl_za0 + REAL(dp) :: dl_za1 + REAL(dp) :: dl_za2 + REAL(dp) :: dl_zsur + REAL(dp) :: dl_zw + REAL(dp) :: dl_zt + + INTEGER(i4) :: il_jpk + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + dl_ppacr = dd_ppacr + IF( dd_ppa1 == 0._dp ) dl_ppacr =1.0 + dl_ppacr2= dd_ppacr2 + IF( dd_ppa2 == 0._dp ) dl_ppacr2=1.0 + + ! Set variables from parameters + ! ------------------------------ + dl_zkth = dd_ppkth ; dl_zacr = dl_ppacr + dl_zdzmin = dd_ppdzmin ; dl_zhmax = dd_pphmax + dl_zkth2 = dd_ppkth2 ; dl_zacr2 = dl_ppacr2 + + il_jpk = SIZE(dd_gdepw(:)) + + ! If ppa1 and ppa0 and ppsur are et to pp_to_be_computed + ! za0, za1, zsur are computed from ppdzmin , pphmax, ppkth, ppacr + ! + IF( dd_ppa1 == dd_pp_to_be_computed .AND. & + & dd_ppa0 == dd_pp_to_be_computed .AND. & + & dd_ppsur == dd_pp_to_be_computed ) THEN + dl_za1 = ( dl_zdzmin - dl_zhmax / REAL((il_jpk-1),dp) ) & + & / ( TANH((1-dl_zkth)/dl_zacr) - dl_zacr/REAL((il_jpk-1),dp) & + & * ( LOG( COSH( (REAL(il_jpk,dp) - dl_zkth) / dl_zacr) ) & + & - LOG( COSH(( 1.0 - dl_zkth) / dl_zacr) ) ) ) + + dl_za0 = dl_zdzmin - dl_za1 * TANH( (1.0-dl_zkth) / dl_zacr ) + dl_zsur = - dl_za0 - dl_za1 * dl_zacr * LOG( COSH( (1-dl_zkth) / dl_zacr ) ) + + ELSE + dl_za1 = dd_ppa1 ; dl_za0 = dd_ppa0 ; dl_zsur = dd_ppsur + dl_za2 = dd_ppa2 + ENDIF + + ! Reference z-coordinate (depth - scale factor at T- and W-points) + ! ====================== + IF( dd_ppkth == 0. )THEN ! uniform vertical grid + + dl_za1 = dl_zhmax/REAL((il_jpk-1),dp) + DO jk = 1, il_jpk + dl_zw = REAL(jk,dp) + dl_zt = REAL(jk,dp) + 0.5_dp + dd_gdepw(jk) = ( dl_zw - 1.0 ) * dl_za1 + dd_gdept(jk) = ( dl_zt - 1.0 ) * dl_za1 + dd_e3w (jk) = dl_za1 + dd_e3t (jk) = dl_za1 + END DO + + ELSE + + DO jk = 1, il_jpk + dl_zw = REAL( jk,dp) + dl_zt = REAL( jk,dp) + 0.5_dp + dd_gdepw(jk) = ( dl_zsur + dl_za0 * dl_zw + & + & dl_za1 * dl_zacr * LOG( COSH( (dl_zw-dl_zkth)/dl_zacr ) ) + & + & dl_za2 * dl_zacr2* LOG( COSH( (dl_zw-dl_zkth2)/dl_zacr2 ) ) ) + dd_gdept(jk) = ( dl_zsur + dl_za0 * dl_zt + & + & dl_za1 * dl_zacr * LOG( COSH( (dl_zt-dl_zkth)/dl_zacr ) ) + & + & dl_za2 * dl_zacr2* LOG( COSH( (dl_zt-dl_zkth2)/dl_zacr2 ) ) ) + dd_e3w (jk) = dl_za0 + & + & dl_za1 * TANH( (dl_zw-dl_zkth)/dl_zacr ) + & + & dl_za2 * TANH( (dl_zw-dl_zkth2)/dl_zacr2 ) + dd_e3t (jk) = dl_za0 + & + & dl_za1 * TANH( (dl_zt-dl_zkth)/dl_zacr ) + & + & dl_za2 * TANH( (dl_zt-dl_zkth2)/dl_zacr2 ) + END DO + dd_gdepw(1) = 0.e0 ! force first w-level to be exactly at zero + + ENDIF + + ! need to be like this to compute the pressure gradient with ISF. + ! If not, level beneath the ISF are not aligned (sum(e3t) /= depth) + ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively + DO jk = 1, il_jpk-1 + dd_e3t_1d(jk) = dd_gdepw(jk+1)-dd_gdepw(jk) + END DO + dd_e3t_1d(il_jpk) = dd_e3t_1d(il_jpk-1) ! we don't care because this level is masked in NEMO + + DO jk = 2, il_jpk + dd_e3w_1d(jk) = dd_gdept(jk) - dd_gdept(jk-1) + END DO + dd_e3w_1d(1 ) = 2._dp * (dd_gdept(1) - dd_gdepw(1)) + + ! Control and print + ! ================== + + DO jk = 1, il_jpk + IF( dd_e3w(jk) <= 0. .OR. dd_e3t(jk) <= 0. )then + CALL logger_debug("VGRID ZGR Z: e3w or e3t <= 0 ") + ENDIF + + IF( dd_e3w_1d(jk) <= 0. .OR. dd_e3t_1d(jk) <= 0. )then + CALL logger_debug("VGRID ZGR Z: e3w_1d or e3t_1d <= 0 ") + ENDIF + + IF( dd_gdepw(jk) < 0. .OR. dd_gdept(jk) < 0. )then + CALL logger_debug("VGRID ZGR Z: gdepw or gdept < 0 ") + ENDIF + END DO + + END SUBROUTINE vgrid_zgr_z + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE vgrid_zgr_bat(dd_bathy, dd_gdepw, dd_hmin, dd_fill) + !------------------------------------------------------------------- + !> @brief This subroutine + !> + !> @todo add subroutine description + !> + !> @param[inout] dd_bathy + !> @param[in] dd_gdepw + !> @param[in] dd_hmin + !> @param[in] dd_fill + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_bathy + REAL(dp), DIMENSION(:) , INTENT(IN ) :: dd_gdepw + REAL(dp) , INTENT(IN ) :: dd_hmin + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill + + ! local + INTEGER(i4) :: il_jpk + + REAL(dp) :: dl_hmin + REAL(dp) :: dl_fill + + ! loop indices + INTEGER(i4) :: jk + !---------------------------------------------------------------- + il_jpk = SIZE(dd_gdepw(:)) + + dl_fill=0._dp + IF( PRESENT(dd_fill) ) dl_fill=dd_fill + + IF( dd_hmin < 0._dp ) THEN + jk = - INT( dd_hmin ) ! from a nb of level + ELSE + jk = MINLOC( dd_gdepw, mask = dd_gdepw > dd_hmin, dim = 1 ) ! from a depth + ENDIF + + dl_hmin = dd_gdepw(jk+1) ! minimum depth = ik+1 w-levels + WHERE( dd_bathy(:,:) <= 0._wp .OR. dd_bathy(:,:) == dl_fill ) + dd_bathy(:,:) = dl_fill ! min=0 over the lands + ELSE WHERE + dd_bathy(:,:) = MAX( dl_hmin , dd_bathy(:,:) ) ! min=dl_hmin over the oceans + END WHERE + WRITE(*,*) 'Minimum ocean depth: ', dl_hmin, ' minimum number of ocean levels : ', jk + + END SUBROUTINE vgrid_zgr_bat + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE vgrid_zgr_zps(id_mbathy, dd_bathy, id_jpkmax, & + & dd_gdepw, dd_e3t, & + & dd_e3zps_min, dd_e3zps_rat, & + & dd_fill ) + !------------------------------------------------------------------- + !> @brief This subroutine set the depth and vertical scale factor in partial step + !> z-coordinate case + !> + !> @details + !> ** Method : Partial steps : computes the 3D vertical scale factors + !> of T-, U-, V-, W-, UW-, VW and F-points that are associated with + !> a partial step representation of bottom topography. + !> + !> The reference depth of model levels is defined from an analytical + !> function the derivative of which gives the reference vertical + !> scale factors. + !> From depth and scale factors reference, we compute there new value + !> with partial steps on 3d arrays ( i, j, k ). + !> + !> w-level: + !> - gdepw_ps(i,j,k) = fsdep(k) + !> - e3w_ps(i,j,k) = dk(fsdep)(k) = fse3(i,j,k) + !> t-level: + !> - gdept_ps(i,j,k) = fsdep(k+0.5) + !> - e3t_ps(i,j,k) = dk(fsdep)(k+0.5) = fse3(i,j,k+0.5) + !> + !> With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), + !> we find the mbathy index of the depth at each grid point. + !> This leads us to three cases: + !> - bathy = 0 => mbathy = 0 + !> - 1 < mbathy < jpkm1 + !> - bathy > gdepw(jpk) => mbathy = jpkm1 + !> + !> Then, for each case, we find the new depth at t- and w- levels + !> and the new vertical scale factors at t-, u-, v-, w-, uw-, vw- + !> and f-points. + !> + !> This routine is given as an example, it must be modified + !> following the user s desiderata. nevertheless, the output as + !> well as the way to compute the model levels and scale factors + !> must be respected in order to insure second order accuracy + !> schemes. + !> + !> @warning + !> - gdept, gdepw and e3 are positives + !> - gdept_ps, gdepw_ps and e3_ps are positives + !> + !> @author A. Bozec, G. Madec + !> @date February, 2009 - F90: Free form and module + !> @date February, 2009 + !> - A. de Miranda : rigid-lid + islands + !> + !> @note Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. + !> + !> @param[inout] id_mbathy + !> @param[inout] dd_bathy + !> @param[inout] id_jpkmax + !> @param[in] dd_gdepw + !> @param[in] dd_e3t + !> @param[in] dd_e3zps_min + !> @param[in] dd_e3zps_rat + !> @param[in] dd_fill + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), DIMENSION(:,:), INTENT( OUT) :: id_mbathy + REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_bathy + INTEGER(i4) , INTENT(INOUT) :: id_jpkmax + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_gdepw + REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_e3t + REAL(dp) , INTENT(IN ) :: dd_e3zps_min + REAL(dp) , INTENT(IN ) :: dd_e3zps_rat + REAL(dp) , INTENT(IN ), OPTIONAL :: dd_fill + + ! local variable + REAL(dp) :: dl_zmax ! Maximum depth + !REAL(dp) :: dl_zmin ! Minimum depth + REAL(dp) :: dl_zdepth ! Ajusted ocean depth to avoid too small e3t + REAL(dp) :: dl_fill + + INTEGER(i4) :: il_jpk + INTEGER(i4) :: il_jpkm1 + INTEGER(i4) :: il_jpiglo + INTEGER(i4) :: il_jpjglo + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + INTEGER(i4) :: jk + !---------------------------------------------------------------- + + il_jpk=SIZE(dd_gdepw(:)) + il_jpiglo=SIZE(id_mbathy(:,:),DIM=1) + il_jpjglo=SIZE(id_mbathy(:,:),DIM=2) + + dl_fill=0._dp + IF( PRESENT(dd_fill) ) dl_fill=dd_fill + + ! Initialization of constant + dl_zmax = dd_gdepw(il_jpk) + dd_e3t(il_jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) + + ! bounded value of bathy (min already set at the end of zgr_bat) + WHERE( dd_bathy(:,:) /= dl_fill ) + dd_bathy(:,:) = MIN( dl_zmax , dd_bathy(:,:) ) + END WHERE + + ! bathymetry in level (from bathy_meter) + ! =================== + il_jpkm1=il_jpk-1 + ! initialize mbathy to the maximum ocean level available + id_mbathy(:,:) = il_jpkm1 + + ! storage of land and island's number (zera and negative values) in mbathy + DO jj = 1, il_jpjglo + DO ji= 1, il_jpiglo + IF( dd_bathy(ji,jj) <= 0._dp )THEN + id_mbathy(ji,jj) = INT(dd_bathy(ji,jj),i4) + ELSEIF( dd_bathy(ji,jj) == dl_fill )THEN + id_mbathy(ji,jj) = 0_i4 + ENDIF + END DO + END DO + + ! Compute mbathy for ocean points (i.e. the number of ocean levels) + ! find the number of ocean levels such that the last level thickness + ! is larger than the minimum of e3zps_min and e3zps_rat * e3t (where + ! e3t is the reference level thickness + + DO jk = il_jpkm1, 1, -1 + dl_zdepth = dd_gdepw(jk) + MIN( dd_e3zps_min, dd_e3t(jk)*dd_e3zps_rat ) + + DO jj = 1, il_jpjglo + DO ji = 1, il_jpiglo + IF( dd_bathy(ji,jj) /= dl_fill )THEN + IF( 0. < dd_bathy(ji,jj) .AND. & + & dd_bathy(ji,jj) <= dl_zdepth ) id_mbathy(ji,jj) = jk-1 + ENDIF + END DO + END DO + END DO + + ! ================ + ! Bathymetry check + ! ================ + + CALL vgrid_zgr_bat_ctl( id_mbathy, id_jpkmax, il_jpk) + + END SUBROUTINE vgrid_zgr_zps + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE vgrid_zgr_bat_ctl(id_mbathy, id_jpkmax, id_jpk) + !------------------------------------------------------------------- + !> @brief This subroutine check the bathymetry in levels + !> + !> @details + !> ** Method : The array mbathy is checked to verified its consistency + !> with the model options. in particular: + !> mbathy must have at least 1 land grid-points (mbathy<=0) + !> along closed boundary. + !> mbathy must be cyclic IF jperio=1. + !> mbathy must be lower or equal to jpk-1. + !> isolated ocean grid points are suppressed from mbathy + !> since they are only connected to remaining + !> ocean through vertical diffusion. + !> C A U T I O N : mbathy will be modified during the initializa- + !> tion phase to become the number of non-zero w-levels of a water + !> column, with a minimum value of 1. + !> + !> ** Action : - update mbathy: level bathymetry (in level index) + !> - update bathy : meter bathymetry (in meters) + !> + !> @author G.Madec + !> @date Marsh, 2008 - Original code + !> + !> @param[in] id_mbathy + !> @param[in] id_jpkmax + !> @param[in] id_jpk + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + INTEGER(i4), DIMENSION(:,:), INTENT(INOUT) :: id_mbathy + INTEGER(i4) , INTENT(INOUT) :: id_jpkmax + INTEGER(i4) , INTENT(INOUT) :: id_jpk + + ! local variable + INTEGER(i4) :: il_jpiglo + INTEGER(i4) :: il_jpjglo + + INTEGER(i4) :: il_icompt + INTEGER(i4) :: il_ibtest + INTEGER(i4) :: il_ikmax + INTEGER(i4) :: il_jpkm1 + + INTEGER(i4) :: il_jim + INTEGER(i4) :: il_jip + INTEGER(i4) :: il_jjm + INTEGER(i4) :: il_jjp + + ! loop indices + INTEGER(i4) :: jl + INTEGER(i4) :: ji + INTEGER(i4) :: jj + !---------------------------------------------------------------- + + il_jpiglo=SIZE(id_mbathy(:,:),DIM=1) + il_jpjglo=SIZE(id_mbathy(:,:),DIM=2) + + ! ================ + ! Bathymetry check + ! ================ + + ! suppress isolated ocean grid points' + il_icompt = 0 + + DO jl = 1, 2 + DO jj = 1, il_jpjglo + DO ji = 1, il_jpiglo + il_jim=max(ji-1,1) ; il_jip=min(ji+1,il_jpiglo) + il_jjm=max(jj-1,1) ; il_jjp=min(jj+1,il_jpjglo) + + if(il_jim==ji) il_jim=il_jip ; if(il_jip==ji) il_jip=il_jim + if(il_jjm==jj) il_jjm=il_jjp ; if(il_jjp==jj) il_jjp=il_jjm + + il_ibtest = MAX( id_mbathy(il_jim,jj), id_mbathy(il_jip,jj), & + id_mbathy(ji,il_jjm),id_mbathy(ji,il_jjp) ) + + IF( il_ibtest < id_mbathy(ji,jj) ) THEN + id_mbathy(ji,jj) = il_ibtest + il_icompt = il_icompt + 1 + ENDIF + END DO + END DO + + END DO + IF( il_icompt == 0 ) THEN + CALL logger_info("VGRID ZGR BAT CTL: no isolated ocean grid points") + ELSE + CALL logger_info("VGRID ZGR BAT CTL:"//TRIM(fct_str(il_icompt))//& + & " ocean grid points suppressed") + ENDIF + + id_mbathy(:,:) = MAX( 0, id_mbathy(:,:)) + + ! Number of ocean level inferior or equal to jpkm1 + + il_ikmax = 0 + DO jj = 1, il_jpjglo + DO ji = 1, il_jpiglo + il_ikmax = MAX( il_ikmax, id_mbathy(ji,jj) ) + END DO + END DO + + id_jpkmax=id_jpk + + il_jpkm1=id_jpk-1 + IF( il_ikmax > il_jpkm1 ) THEN + CALL logger_error("VGRID ZGR BAT CTL: maximum number of ocean level = "//& + & TRIM(fct_str(il_ikmax))//" > jpk-1."//& + & " Change jpk to "//TRIM(fct_str(il_ikmax+1))//& + & " to use the exact ead bathymetry" ) + ELSE IF( il_ikmax < il_jpkm1 ) THEN + id_jpkmax=il_ikmax+1 + ENDIF + + END SUBROUTINE vgrid_zgr_bat_ctl + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + FUNCTION vgrid_get_level(td_bathy, cd_namelist, td_dom, id_nlevel) & + & RESULT (tf_var) + !------------------------------------------------------------------- + !> @brief This function compute bathy level in T,U,V,F point, and return + !> them as array of variable structure + !> + !> @details + !> Bathymetry is read on Bathymetry file, then bathy level is computed + !> on T point, and finally fit to U,V,F point. + !> + !> you could specify :<br/> + !> - namelist where find parameter to set the depth of model levels + !> (default use GLORYS 75 levels parameters) + !> - domain structure to specify on e area to work on + !> - number of level to be used + !> + !> @author J.Paul + !> @date November, 2013 - Initial Version + !> + !> @param[in] td_bathy Bathymetry file structure + !> @param[in] cd_namelist namelist + !> @param[in] td_dom domain structure + !> @param[in] id_nlevel number of lelvel to be used + !> @return array of level on T,U,V,F point (variable structure) + !------------------------------------------------------------------- + + IMPLICIT NONE + + ! Argument + TYPE(TMPP) , INTENT(IN) :: td_bathy + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namelist + TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom + INTEGER(i4) , INTENT(IN), OPTIONAL :: id_nlevel + + ! function + TYPE(TVAR), DIMENSION(ip_npoint) :: tf_var + + ! local variable + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_gdepw + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_gdept + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3w + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3t + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3w_1d + REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_e3t_1d + + INTEGER(i4) :: il_status + INTEGER(i4) :: il_fileid + INTEGER(i4) :: il_jpkmax + INTEGER(i4), DIMENSION(2,2) :: il_xghost + INTEGER(i4), DIMENSION(:,:) , ALLOCATABLE :: il_mbathy + INTEGER(i4), DIMENSION(:,:,:,:), ALLOCATABLE :: il_level + + LOGICAL :: ll_exist + + TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim + + TYPE(TDOM) :: tl_dom + + TYPE(TVAR) :: tl_var + + TYPE(TMPP) :: tl_bathy + + ! loop indices + INTEGER(i4) :: ji + INTEGER(i4) :: jj + + INTEGER(i4) :: jip + INTEGER(i4) :: jjp + + !namelist (intialise with GLORYS 75 levels parameters) + REAL(dp) :: dn_pp_to_be_computed = 0._dp + REAL(dp) :: dn_ppsur = -3958.951371276829_dp + REAL(dp) :: dn_ppa0 = 103.9530096000000_dp + REAL(dp) :: dn_ppa1 = 2.4159512690000_dp + REAL(dp) :: dn_ppa2 = 100.7609285000000_dp + REAL(dp) :: dn_ppkth = 15.3510137000000_dp + REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp + REAL(dp) :: dn_ppacr = 7.0000000000000_dp + REAL(dp) :: dn_ppacr2 = 13.000000000000_dp + REAL(dp) :: dn_ppdzmin = 6._dp + REAL(dp) :: dn_pphmax = 5750._dp + INTEGER(i4) :: in_nlevel = 75 + + REAL(dp) :: dn_e3zps_min = 25._dp + REAL(dp) :: dn_e3zps_rat = 0.2_dp + !---------------------------------------------------------------- + NAMELIST /namzgr/ & + & dn_pp_to_be_computed, & + & dn_ppsur, & + & dn_ppa0, & + & dn_ppa1, & + & dn_ppa2, & + & dn_ppkth, & + & dn_ppkth2, & + & dn_ppacr, & + & dn_ppacr2, & + & dn_ppdzmin, & + & dn_pphmax, & + & in_nlevel + + NAMELIST /namzps/ & + & dn_e3zps_min, & + & dn_e3zps_rat + !---------------------------------------------------------------- + + IF( PRESENT(cd_namelist) )THEN + !1- read namelist + INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist) + IF( ll_exist )THEN + + il_fileid=fct_getunit() + + OPEN( il_fileid, FILE=TRIM(cd_namelist), & + & FORM='FORMATTED', & + & ACCESS='SEQUENTIAL', & + & STATUS='OLD', & + & ACTION='READ', & + & IOSTAT=il_status) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_fatal("VGRID GET LEVEL: ERROR opening "//& + & TRIM(cd_namelist)) + ENDIF + + READ( il_fileid, NML = namzgr ) + READ( il_fileid, NML = namzps ) + + CLOSE( il_fileid, IOSTAT=il_status ) + CALL fct_err(il_status) + IF( il_status /= 0 )THEN + CALL logger_error("VGRID GET LEVELL: ERROR closing "//& + & TRIM(cd_namelist)) + ENDIF + + ELSE + + CALL logger_fatal("VGRID GET LEVEL: ERROR. can not find "//& + & TRIM(cd_namelist)) + + ENDIF + ENDIF + + ! copy structure + tl_bathy=mpp_copy(td_bathy) + + ! get domain + IF( PRESENT(td_dom) )THEN + tl_dom=dom_copy(td_dom) + ELSE + CALL logger_debug("VGRID GET LEVEL: get dom from "//& + & TRIM(tl_bathy%c_name)) + tl_dom=dom_init(tl_bathy) + ENDIF + + ! get ghost cell + il_xghost(:,:)=grid_get_ghost(tl_bathy) + + ! open mpp files + CALL iom_dom_open(tl_bathy, tl_dom) + + ! check namelist + IF( PRESENT(id_nlevel) ) in_nlevel=id_nlevel + IF( in_nlevel == 0 )THEN + CALL logger_fatal("VGRID GET LEVEL: number of level to be used "//& + & "is not specify. check namelist.") + ENDIF + + ! read bathymetry + tl_var=iom_dom_read_var(tl_bathy,'bathymetry',tl_dom) + ! clean + CALL dom_clean(tl_dom) + + ! remove ghost cell + CALL grid_del_ghost(tl_var, il_xghost(:,:)) + + ! force _FillValue (land) to be 0 + WHERE( tl_var%d_value(:,:,1,1) == tl_var%d_fill ) + tl_var%d_value(:,:,1,1)=0 + END WHERE + + ! clean + CALL iom_dom_close(tl_bathy) + CALL mpp_clean(tl_bathy) + + ! compute vertical grid + ALLOCATE( dl_gdepw(in_nlevel), dl_gdept(in_nlevel) ) + ALLOCATE( dl_e3w(in_nlevel), dl_e3t(in_nlevel) ) + ALLOCATE( dl_e3w_1d(in_nlevel), dl_e3t_1d(in_nlevel) ) + CALL vgrid_zgr_z( dl_gdepw(:), dl_gdept(:), dl_e3w(:), dl_e3t(:), & + & dl_e3w_1d, dl_e3t_1d, & + & dn_ppkth, dn_ppkth2, dn_ppacr, dn_ppacr2, & + & dn_ppdzmin, dn_pphmax, dn_pp_to_be_computed, & + & dn_ppa0, dn_ppa1, dn_ppa2, dn_ppsur ) + + ! compute bathy level on T point + ALLOCATE( il_mbathy(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len ) ) + CALL vgrid_zgr_zps( il_mbathy(:,:), tl_var%d_value(:,:,1,1), il_jpkmax, & + & dl_gdepw(:), dl_e3t(:), & + & dn_e3zps_min, dn_e3zps_rat ) + + DEALLOCATE( dl_gdepw, dl_gdept ) + DEALLOCATE( dl_e3w, dl_e3t ) + + ! compute bathy level in T,U,V,F point + ALLOCATE( il_level(tl_var%t_dim(1)%i_len, & + & tl_var%t_dim(2)%i_len, & + & ip_npoint,1) ) + + DO jj=1,tl_var%t_dim(2)%i_len + DO ji= 1,tl_var%t_dim(1)%i_len + + jip=MIN(ji+1,tl_var%t_dim(1)%i_len) + jjp=MIN(jj+1,tl_var%t_dim(2)%i_len) + + ! T point + il_level(ji,jj,jp_T,1)=il_mbathy(ji,jj) + ! U point + il_level(ji,jj,jp_U,1)=MIN( il_mbathy(ji, jj ), il_mbathy(jip, jj )) + ! V point + il_level(ji,jj,jp_V,1)=MIN( il_mbathy(ji, jj ), il_mbathy(ji , jjp)) + ! F point + il_level(ji,jj,jp_F,1)=MIN( il_mbathy(ji, jj ), il_mbathy(jip, jj ), & + & il_mbathy(ji, jjp), il_mbathy(jip, jjp)) + + ENDDO + ENDDO + + DEALLOCATE( il_mbathy ) + + tl_dim(:)=dim_copy(tl_var%t_dim(:)) + ! clean + CALL var_clean(tl_var) + + ! only 2 first dimension to be used + tl_dim(3:4)%l_use=.FALSE. + + tf_var(jp_T)=var_init('tlevel', il_level(:,:,jp_T:jp_T,:), td_dim=tl_dim(:)) + tf_var(jp_U)=var_init('ulevel', il_level(:,:,jp_U:jp_U,:), td_dim=tl_dim(:)) + tf_var(jp_V)=var_init('vlevel', il_level(:,:,jp_V:jp_V,:), td_dim=tl_dim(:)) + tf_var(jp_F)=var_init('flevel', il_level(:,:,jp_F:jp_F,:), td_dim=tl_dim(:)) + + DEALLOCATE( il_level ) + + CALL grid_add_ghost( tf_var(jp_T), il_xghost(:,:) ) + CALL grid_add_ghost( tf_var(jp_U), il_xghost(:,:) ) + CALL grid_add_ghost( tf_var(jp_V), il_xghost(:,:) ) + CALL grid_add_ghost( tf_var(jp_F), il_xghost(:,:) ) + + ! clean + CALL dim_clean(tl_dim(:)) + + END FUNCTION vgrid_get_level + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END MODULE vgrid + diff --git a/V4.0/nemo_sources/tools/SIREN/templates/README b/V4.0/nemo_sources/tools/SIREN/templates/README new file mode 100644 index 0000000000000000000000000000000000000000..5aa56abb30487cd6a25dea10650e091bd2d815ed --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/templates/README @@ -0,0 +1,7 @@ + +To be sure to use a template of namelist up to date, +run create_templates.py on the Siren program you want to use. + +Exemple: +python create_templates.py create_bathy.f90 create_bathy.nam + diff --git a/V4.0/nemo_sources/tools/SIREN/templates/create_templates.py b/V4.0/nemo_sources/tools/SIREN/templates/create_templates.py new file mode 100644 index 0000000000000000000000000000000000000000..852a5ee16ab81dc81701ea8e19acbbbbdbd66f86 --- /dev/null +++ b/V4.0/nemo_sources/tools/SIREN/templates/create_templates.py @@ -0,0 +1,114 @@ +#!/usr/bin/python +# -*- coding:Utf-8 -*- +""" +This script create template of namelist for Siren. + +see create_templates.py --help +""" +import os +import argparse +import re + +def get_default(i,var): + """ + Parameters + ---------- + i: str + input filename + var: str + variable name + """ + with open(i) as f: + for line in f: + line=line.strip() + if re.match('.*::.*'+var+'.*', line): + return line.split("::")[1].split("=")[1] + + +def get_nam(i,o,d): + """ + Copy input file in output file, line by line. + + If line contains filterlist parameter and src: + - copy the line without the src option + - copy the file to be include line by line + + Parameters + ---------- + i: str + input filename + o: str + output filename + d: bool + added default value + """ + with open(i) as f: + inRecordingMode = False + for line in f: + line=line.strip() + if not inRecordingMode: + if line.startswith('NAMELIST'): + inRecordingMode = True + nam='&'+line.split('/')[1] + cmt='' + if re.match('^.*!<.*$', line): + cmt='!< '+line.split('!<')[1] + print("{0:10} {1}".format(nam,cmt),file=o) + else: + if line.startswith('NAMELIST') or not line: + inRecordingMode = False + print("/",file=o) + else: + if not line.startswith('!'): + var=line.split('&')[1].split(',')[0].split()[0] + if re.match('^.*!<.*$', line): + cmt='!< '+line.split('!<')[1] + if d: + val=get_default(i,var) + print("\t {0:12} = {1:30} {2}".format(var,val,cmt),file=o) + else: + print("\t {0:12} = {1:30} {2}".format(var,"",cmt),file=o) + + + +def main(): + """ + Read Fortran src file and create template of namelist from it. + """ + # define parser + parser = argparse.ArgumentParser( + prog="create_templates.py", description="Create template of namelist from Fortran src." + ) + # positional arguments + parser.add_argument("input" , type=str, help="Fortran filename, to be read in Siren/src directory") + parser.add_argument("output", type=str, help="Output filename, to be written in Siren/templates directory") + # optional arguments + parser.add_argument("-v", "--verbose", action="store_true", help="show more things") + parser.add_argument("-d", "--default", action="store_true", help="add default value for some variables") + + # parse arguments + args = parser.parse_args() + + if re.match('.*/.*', args.output): + raise NameError( + "Output filename must not be a path (should not contains /)." + ) + print(args.output.split("/")[1]) + fin=os.path.abspath(os.path.join("../src",args.input)) + fout=os.path.abspath(os.path.join("../templates",args.output)) + if args.verbose: + print("Input file : {0}".format(fin)) + print("Output file : {0}".format(fout)) + if args.default: + print("\nAdd default value to some variables") + + if not os.path.isfile(fin): + raise NameError( + "Can not find {0} in src directory".format(os.path.basename(fin)) + ) + + with open(args.output,'w') as fout: + get_nam(fin,fout,args.default) + +if __name__ == "__main__": + main() diff --git a/V4.0/nemo_sources/tools/TOYATM/EXP/grids.nc b/V4.0/nemo_sources/tools/TOYATM/EXP/grids.nc new file mode 100644 index 0000000000000000000000000000000000000000..e728348cc573dc61bd3941920bbdb73e9bec8889 Binary files /dev/null and b/V4.0/nemo_sources/tools/TOYATM/EXP/grids.nc differ diff --git a/V4.0/nemo_sources/tools/TOYATM/EXP/masks.nc b/V4.0/nemo_sources/tools/TOYATM/EXP/masks.nc new file mode 100644 index 0000000000000000000000000000000000000000..edce6309194676c00c6d703cf96208dc965c9a72 Binary files /dev/null and b/V4.0/nemo_sources/tools/TOYATM/EXP/masks.nc differ diff --git a/V4.0/nemo_sources/tools/TOYATM/EXP/namcouple b/V4.0/nemo_sources/tools/TOYATM/EXP/namcouple new file mode 100755 index 0000000000000000000000000000000000000000..fd6441839a19c1fb5bd846b941c34b6f94319fc5 --- /dev/null +++ b/V4.0/nemo_sources/tools/TOYATM/EXP/namcouple @@ -0,0 +1,124 @@ +# This is a typical input file for OASIS3-MCT, using NetCDF +# format for restart input files. OASIS3-MCT reads in this file +# at run time. Don't hesitate to ask precisions or make +# suggestions (oasishelp@cerfacs.fr) +# +# Any line beginning with # is ignored. Blank lines are not allowed +#################################################################### + $NFIELDS +12 + $END +############################################ + $RUNTIME +259200 + $END +############################################ + $NLOGPRT +1 0 + $END +############################################ + $STRINGS +O_SSTSST ATSSTSST 1 28800 3 rst.nc EXPORTED +182 149 180 90 torc lmdz +P 2 P 0 +CHECKIN SCRIPR CHECKOUT +INT=1 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_QnsMix 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +10. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_QnsIce 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +10. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_QsrIce 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +10. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_QsrMix 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +10. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_dQnsdT 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +0. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_OTaux1 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +0. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATSOLFLX O_OTauy1 1 28800 4 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN BLASOLD SCRIPR CHECKOUT +INT=1 +0. 0 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATFLXEMP OTotRain 1 28800 3 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN SCRIPR CHECKOUT +INT=1 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATFLXEMP OTotSnow 1 28800 3 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN SCRIPR CHECKOUT +INT=1 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATFLXEMP OTotEvap 1 28800 3 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN SCRIPR CHECKOUT +INT=1 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# +ATFLXEMP OIceEvap 1 28800 3 rst.nc EXPORTED +180 90 182 149 lmdz torc +P 0 P 2 +CHECKIN SCRIPR CHECKOUT +INT=1 +BILINEAR LR SCALAR LATLON 1 +INT=1 +# + $END diff --git a/V4.0/nemo_sources/tools/TOYATM/src/toyatm.F90 b/V4.0/nemo_sources/tools/TOYATM/src/toyatm.F90 new file mode 100755 index 0000000000000000000000000000000000000000..7c69436045c673fc1deb080466bef6a87f50271e --- /dev/null +++ b/V4.0/nemo_sources/tools/TOYATM/src/toyatm.F90 @@ -0,0 +1,337 @@ +!------------------------------------------------------------------------ +! Copyright 2018/03, CERFACS, Toulouse, France. +! All rights reserved. Use is subject to OASIS3 license terms. +!============================================================================= +! +PROGRAM TOYATM + ! + USE netcdf + USE mod_oasis + ! + IMPLICIT NONE + ! + INTEGER, PARAMETER :: wp = 8 + ! + CHARACTER(len=30), PARAMETER :: data_gridname='grids.nc' ! file with the grids + CHARACTER(len=30), PARAMETER :: data_maskname='masks.nc' ! file with the masks + ! + ! Component name (6 characters) same as in the namcouple + CHARACTER(len=6) :: comp_name = 'toyatm' + CHARACTER(len=128) :: comp_out ! name of the output log file + CHARACTER(len=4) :: cl_grd_src ! name of the source grid + ! + ! Global grid parameters : + INTEGER, PARAMETER :: nlon = 180 + INTEGER, PARAMETER :: nlat = 90 + + REAL (kind=wp) :: gg_lon(nlon,nlat) + REAL (kind=wp) :: gg_lat(nlon,nlat) + INTEGER :: gg_mask(nlon,nlat) + ! + ! Exchanged local fields arrays + REAL (kind=wp), ALLOCATABLE :: field_send(:,:) + ! + REAL (kind=wp), ALLOCATABLE :: field_recv(:,:) + + INTEGER :: mype, npes ! rank and number of pe + INTEGER :: localComm ! local MPI communicator and Initialized + INTEGER :: comp_id ! component identification + ! + INTEGER :: il_paral(3) ! Decomposition for each proc + ! + INTEGER :: ierror, ios + INTEGER, PARAMETER :: w_unit = 711 + INTEGER :: FILE_Debug=1 + ! + ! Names of exchanged Fields + CHARACTER(len=8), DIMENSION(3), PARAMETER :: var_name = (/'ATSSTSST','ATSOLFLX','ATFLXEMP'/) ! 8 characters field + ! + ! Used in oasis_def_var and oasis_def_var + INTEGER :: var_id(3) + INTEGER :: var_nodims(2) + INTEGER :: var_type + ! + INTEGER :: niter, time_step, ib, it_sec + ! + ! Grid parameters definition + INTEGER :: part_id ! use to connect the partition to the variables + INTEGER :: var_sh(4) ! local dimensions of the arrays; 2 x rank (=4) + INTEGER :: ji, jj + INTEGER :: auxfileid, auxdimid(2), auxvarid(2) + ! + ! NEMO namelist parameters + INTEGER :: numnam_cfg=80, nn_it000, nn_itend + INTEGER :: nn_stocklist, nn_rstctl, nn_no + LOGICAL :: ln_rst_list, ln_mskland , ln_clobber,ln_cfmeta, ln_iscpl, ln_xios_read + LOGICAL :: ln_rstart, nn_date0, nn_time0, nn_leapy , nn_istate, nn_stock, nn_write ,nn_chunksz, nn_euler,nn_wxios + CHARACTER (len=256) :: cn_exp , cn_ocerst_in, cn_ocerst_indir, cn_ocerst_out, cn_ocerst_outdir + REAL (kind=wp) :: rn_rdt + LOGICAL :: ln_linssh, ln_crs, ln_meshmask + REAL (kind=wp) :: rn_isfhmin, rn_atfp + ! + ! NEMO namelists +!! NAMELIST/namrun/ nn_it000, nn_itend +!! NAMELIST/namdom/ rn_rdt + 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 + NAMELIST/namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask + ! + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! INITIALISATION + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + CALL oasis_init_comp (comp_id, comp_name, ierror ) + IF (ierror /= 0) THEN + WRITE(0,*) 'oasis_init_comp abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_init_comp') + ENDIF + ! + CALL oasis_get_localcomm ( localComm, ierror ) + IF (ierror /= 0) THEN + WRITE (0,*) 'oasis_get_localcomm abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_get_localcomm') + ENDIF + ! + ! Get MPI size and rank + CALL MPI_Comm_Size ( localComm, npes, ierror ) + IF (ierror /= 0) THEN + WRITE(0,*) 'MPI_comm_size abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at MPI_Comm_Size') + ENDIF + ! + CALL MPI_Comm_Rank ( localComm, mype, ierror ) + IF (ierror /= 0) THEN + WRITE (0,*) 'MPI_Comm_Rank abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at MPI_Comm_Rank') + ENDIF + ! + IF (mype == 0) THEN + FILE_Debug = 2 + comp_out=comp_name//'.root' + OPEN(w_unit,file=TRIM(comp_out),form='formatted') + ENDIF + ! + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) '-----------------------------------------------------------' + WRITE(w_unit,*) TRIM(comp_name), ' running with reals compiled as kind ',wp + WRITE(w_unit,*) '----------------------------------------------------------' + WRITE (w_unit,*) 'Number of processors :',npes + WRITE(w_unit,*) '----------------------------------------------------------' + CALL FLUSH(w_unit) + ENDIF + ! + ! Simulation length definition (according to NEMO namelist_cfg) + ! + OPEN (UNIT=numnam_cfg, FILE='namelist_cfg', STATUS='OLD' ) + READ ( numnam_cfg, namrun, IOSTAT = ios ) + REWIND(numnam_cfg) + READ ( numnam_cfg, namdom, IOSTAT = ios ) + CLOSE(numnam_cfg) + ! +! Get time step and number of iterations from ocean + time_step = INT(rn_rdt) + niter = nn_itend - nn_it000 + 1 + ! + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) '-----------------------------------------------------------' + WRITE (w_unit,*) 'Total time step # :', niter + WRITE (w_unit,*) 'Simulation length :', niter*time_step + WRITE(w_unit,*) '----------------------------------------------------------' + CALL FLUSH(w_unit) + ENDIF + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! GRID DEFINITION + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! Reading global grids.nc and masks.nc netcdf files + ! Get arguments giving source grid acronym and field type + ! + cl_grd_src = 'lmdz' + ! + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) 'Source grid name : ',cl_grd_src + CALL flush(w_unit) + ENDIF + ! + ! + ! Define global grid longitudes, latitudes, mask + DO jj = 1, nlat + DO ji = 1, nlon + gg_lon(ji ,jj) = ( ji - 1 ) * ( 360. / nlon ) + gg_lat(ji ,jj) = ( jj - 1 ) * ( 180. / nlon ) + ENDDO + ENDDO + + gg_mask(:,:) = 0. + + ! Complete OASIS auxiliary files with yoy grid data + ! + IF (mype == 0) THEN + ! Define longitude and latitude + CALL check_nf90( nf90_open( data_gridname, nf90_write, auxfileid ) ) + CALL check_nf90( nf90_redef( auxfileid ) ) + CALL check_nf90( nf90_def_dim( auxfileid, "toylon", nlon, auxdimid(1)) ) + CALL check_nf90( nf90_def_dim( auxfileid, "toylat", nlat, auxdimid(2)) ) + CALL check_nf90( nf90_def_var( auxfileid, cl_grd_src//'.lon', NF90_DOUBLE, auxdimid, auxvarid(1))) + CALL check_nf90( nf90_def_var( auxfileid, cl_grd_src//'.lat', NF90_DOUBLE, auxdimid, auxvarid(2))) + CALL check_nf90( nf90_enddef( auxfileid ) ) + CALL check_nf90( nf90_put_var( auxfileid, auxvarid(1), gg_lon ) ) + CALL check_nf90( nf90_put_var( auxfileid, auxvarid(2), gg_lat ) ) + CALL check_nf90( nf90_close( auxfileid ) ) + + ! Define mask + CALL check_nf90( nf90_open( data_maskname, nf90_write, auxfileid ) ) + CALL check_nf90( nf90_redef( auxfileid ) ) + CALL check_nf90( nf90_def_dim( auxfileid, "toylon", nlon, auxdimid(1)) ) + CALL check_nf90( nf90_def_dim( auxfileid, "toylat", nlat, auxdimid(2)) ) + CALL check_nf90( nf90_def_var( auxfileid, cl_grd_src//'.msk', NF90_INT, auxdimid, auxvarid(1))) + CALL check_nf90( nf90_enddef( auxfileid ) ) + CALL check_nf90( nf90_put_var( auxfileid, auxvarid(1), gg_mask ) ) + CALL check_nf90( nf90_close( auxfileid ) ) + ENDIF + ! + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) 'After grid and mask reading' + CALL FLUSH(w_unit) + ENDIF + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! PARTITION DEFINITION + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! + ! + il_paral(1) = 1 ! Apple decomposition + il_paral(2) = mype * nlon * nlat / npes + il_paral(3) = nlon * nlat / npes + IF ( mype > ( npes - 1 ) ) & + il_paral(3) = nlon * nlat - ( mype * ( nlon * nlat / npes ) ) + ! + CALL oasis_def_partition (part_id, il_paral, ierror) + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! COUPLING LOCAL FIELD DECLARATION + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + var_nodims(1) = 2 ! Rank of the field array is 2 + var_nodims(2) = 1 ! Bundles always 1 for OASIS3 + var_type = OASIS_Real + ! + var_sh(1) = 1 + var_sh(2) = il_paral(3) + var_sh(3) = 1 + var_sh(4) = 1 + ! + ! Declaration of the field associated with the partition (recv) + CALL oasis_def_var (var_id(1), var_name(1), part_id, & + var_nodims, OASIS_In, var_sh, var_type, ierror) + IF (ierror /= 0) THEN + WRITE(w_unit,*) 'oasis_def_var abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_def_var') + ENDIF + + ! Declaration of the field associated with the partition (send) + CALL oasis_def_var (var_id(2), var_name(2), part_id, & + var_nodims, OASIS_Out, var_sh, var_type, ierror) + IF (ierror /= 0) THEN + WRITE(w_unit,*) 'oasis_def_var abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_def_var') + ENDIF + CALL oasis_def_var (var_id(3), var_name(3), part_id, & + var_nodims, OASIS_Out, var_sh, var_type, ierror) + IF (ierror /= 0) THEN + WRITE(w_unit,*) 'oasis_def_var abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_def_var') + ENDIF + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) 'After def_var' + CALL FLUSH(w_unit) + ENDIF + ! + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! TERMINATION OF DEFINITION PHASE + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + CALL oasis_enddef ( ierror ) + IF (ierror /= 0) THEN + WRITE(w_unit,*) 'oasis_enddef abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_enddef') + ENDIF + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) 'After enddef' + CALL FLUSH(w_unit) + ENDIF + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! SEND ARRAYS + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! Allocate the fields send and received by the model1 + ! + ALLOCATE(field_send(var_sh(2),var_sh(4)), STAT=ierror ) + IF ( ierror /= 0 ) WRITE(w_unit,*) 'Error allocating field_send' + ALLOCATE(field_recv(var_sh(2),var_sh(4)), STAT=ierror ) + IF ( ierror /= 0 ) WRITE(w_unit,*) 'Error allocating field_recv' + ! + DO ib=1, niter + it_sec = time_step * (ib-1) ! Time + + ! QNS + field_send(:,:) = 1. + ! + CALL oasis_put(var_id(2), it_sec, field_send, ierror ) + ! EMPs + field_send(:,:) = 10./ 86400. + CALL oasis_put(var_id(3), it_sec, field_send, ierror ) + ! SST + CALL oasis_get(var_id(1), it_sec, & + field_recv, & + ierror ) + ! + END DO + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! TERMINATION + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + IF (FILE_Debug >= 2) THEN + WRITE(w_unit,*) 'End of the program, before oasis_terminate' + CALL FLUSH(w_unit) + ENDIF + ! + CALL oasis_terminate (ierror) + IF (ierror /= 0) THEN + WRITE(w_unit,*) 'oasis_terminate abort by toyatm compid ',comp_id + CALL oasis_abort(comp_id,comp_name,'Problem at oasis_terminate') + ENDIF + ! +CONTAINS + + + SUBROUTINE check_nf90(status, errorFlag) + !--------------------------------------------------------------------- + ! Checks return code from nf90 library calls and warns if needed + ! If errorFlag is present then it just increments this flag (OMP use) + ! + !--------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: status + INTEGER, INTENT(INOUT), OPTIONAL :: errorFlag + !--------------------------------------------------------------------- + + IF( status /= nf90_noerr ) THEN + WRITE(w_unit,*) 'ERROR! : '//TRIM(nf90_strerror(status)) + IF( PRESENT( errorFlag ) ) THEN + errorFlag = errorFlag + status + ELSE + WRITE(w_unit,*) "*** TOYATM failed on netcdf ***" + WRITE(w_unit,*) + STOP 5 + ENDIF + ENDIF + + END SUBROUTINE check_nf90 + ! +END PROGRAM TOYATM +! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/README b/V4.0/nemo_sources/tools/WEIGHTS/README new file mode 100644 index 0000000000000000000000000000000000000000..f38eb29585d66aad2ed4b14dd3c0309051ebadfe --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/README @@ -0,0 +1,316 @@ +nocsSCRIP v1.1 03/11/2010 +------------------------- + +Author: NOCS NEMO Team +Contacts: Steven Alderson (sga@noc.soton.ac.uk) + Andrew Coward (acc@noc.soton.ac.uk) + +Disclaimer + +This directory contains software for generating and manipulating interpolation +weights for use with the Interpolation On the Fly (IOF) option in NEMO +v3 onwards. The utilities rely heavily on the Spherical Coordinate Remapping +and Interpolation Package (SCRIP) which is freely available from Los Alamos +(see copyright file). We make no claim to authorship of those parts of the +SCRIP package we have used and included with this distribution. + +Unless otherwise indicated, all other software has been authored by an +employee or employees of the National Oceanography Centre, Southampton, UK +(NOCS). NOCS operates as a collaboration between the Natural Environment +Research Council (NERC) and the University of Southampton. The public may +copy and use this software without charge, provided that this Notice and any +statement of authorship are reproduced on all copies. Neither NERC nor the +University makes any warranty, express or implied, or assumes any liability +or responsibility for the use of this software. + +Introduction + +The IOF option enables forced ocean runs without the need to provide surface +boundary data on the nemo grid. Atmospheric data are kept on their original +grid(s) which typically have a coarser resolution than the ocean grid. IOF +supports multiple source (atmospheric) grids and two interpolation methods +(bilinear and bicubic). Different combinations of source grid and method can +be selected for each variable. IOF is also compatible with AGRIF; allowing +AGRIF nests to be used without the need to provide separate forcing data +(only a separate set of weights fields). Operational details are provided +in the SBC chapter of the NEMO reference manual. + +Please note that the methods described here assume that the forcing datasets +are unmasked. Where the original sources are masked it is the users' +responsibility to ensure that an unmasked set is produced on the source +grid with appropriate oceanic values in previously masked locations. This +is particularly important for atmospheric variables which experience step +changes at the land-sea boundary. For these, care must be taken to avoid +contaminating oceanic values. + +The software is divided into several sub-directories: + + ./ + | + +-------------+--------------+--------------+ + SCRIP1.4 nocsutil src bin + +SCRIP1.4 contains the unmodified copy (apart from compression of two sample netcdf +files) of SCRIP version 1.4 from Los Alamos. +(http://climate.lanl.gov/Software/SCRIP). + +The bin directory contains python script freeform.py. +This is run to reformat the code for use within the NEMO 3.3 fcm framework. +It creates and populates a directory called 'src' with copied and modified versions +of the SCRIP library routines (and derived programs from the nocsutil directory). +Changes are described in the src/CHANGES file. +This script has already been run and only needs to be re-executed if SCRIP is updated. + +The src directory also contains the three programs used to generate a weights file. +The three programs are: + +scripgrid.exe (scripgrid.F90) which creates two grid description files suitable for +input to the scrip package. + +scrip.exe (scrip.F90) which takes these descriptions and generates the required +weights in the standard SCRIP format. This program is a version of the SCRIP +program: scrip.f which has been modified to accept the name of its namelist +file on the command line. + +scripshape.exe (scripshape.F90) which takes the output from scrip and rearranges +the fields into a series of 2D fields more suited for input into NEMO using +the iom_get routine. + +All three FORTRAN90 programs read domain information from their respective +netCDF input files and dynamically allocate internal storage. They are +thus independent of the target configuration and have been successfully +tested with both ORCA2 and ORCA025 grids. Their suitably for use with larger +grids has not been tested but should only be subject to limitations of +the operating system and the memory available to the processing element. + +A separate tar file is available containing test data. +This comprises an ORCA2 coordinates file and sample DFS4.1 input field that +can be used for testing. Reference weights files generated using the two +example namelists provided are located in its refout subdirectory. + +Installation is by use of the maketools script. +E.g. change to the NEMOGCM/TOOLS directory and type: + +./maketools -help + +and, for example: + +./maketools -m gfortran_linux -n WEIGHTS + + +Example Use +----------- + + cd data + ../scripgrid.exe namelist_reshape_bilin (creates remap_data_grid.nc + and remap_nemo_grid.nc) + ../scrip.exe namelist_reshape_bilin (creates data_nemo_bilin.nc) + + ../scripshape.exe namelist_reshape_bilin (creates reshape_orca2_bilinear.nc) + +[Note that because the gfortran compiler does not understand the iargc function +and getarg subroutine calls, command line namelist names can only be supplied if +symbol ARGC is defined during compilation (eg add '#define ARGC' to the top of +the relevant program). If not, the program asks for the name instead during execution.] + +Only the final output file is required for use with NEMO but the intermediate +files can be checked against the examples in the test data (available separately). + +For bicubic mapping only scrip and scripshape need to be rerun (because the grid_inputs namelist +entries are identical in the two namelist files, see Controls section below): + + ../scrip.exe namelist_reshape_bicubic (creates data_nemo_bicubic.nc) + + ../scripshape.exe namelist_reshape_bicubic (creates reshape_orca2_bicubic.nc) + +Controls +-------- + +The SCRIP derived utilities use SCRIP-style namelists to control their +operation. In the example above the same named file is used for both but within that +file are two separate namelists: + +&grid_inputs + input_file = './snow_1m_TRP_1958.nc' + nemo_file = 'coordinates.nc' + datagrid_file = 'remap_data_grid.nc' + nemogrid_file = 'remap_nemo_grid.nc' + method = 'regular' + input_lon = 'lon' + input_lat = 'lat' + nemo_lon = 'glamt' + nemo_lat = 'gphit' + nemo_mask = 'none' + nemo_mask_value = 10 + input_mask = 'none' + input_mask_value = 10 +/ + +which is used by scripgrid, and: + +&remap_inputs + num_maps = 1 + grid1_file = 'remap_data_grid.nc' + grid2_file = 'remap_nemo_grid.nc' + interp_file1 = 'data_nemo_bilin.nc' + interp_file2 = 'nemo_data_bilin.nc' + map1_name = 'data to nemo bilin Mapping' + map2_name = 'nemo to data bilin Mapping' + map_method = 'bilinear' + normalize_opt = 'frac' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. +/ + +which is used by scrip. + +scripshape also reads information from a namelist: + +&shape_inputs + interp_file = 'data_nemo_bilin.nc' + output_file = 'weights_bilin.nc' + ew_wrap = 0 +/ + +scripgrid.exe +------------- + +scripgrid accesses the named files and coordinate data in order to produce +the grid centre and corner locations required by scrip. In the example given, +a file called 'coordinates.nc' must exist in the current directory. This is +used by scripgrid as a nemo coordinates file and the correct corner +locations appropriate to the named grid centres are obtained (i.e. since +glamt is named, glamf and gphif will be used to provide corner coordinates). +The nemo file need not be called 'coordinates.nc' (e.g. '1_coordinates.nc' instead), +but must have longitude and latitude variables which start with the four +characters 'gphi' and 'glam' respectively. +"input_file" file must contain at least one variable on a grid whose axes are +described by the netcdf coordinate variables named in input_lon and input_lat. +The program produces two grid description files, one corresponding to each +input file, for use by the scrip program to calculate weights required to +go from one to the other and back again. + +This step is independent of the mapping method (e.g. bilinear or bicubic) +and so only one set of remap_data_grid.nc and remap_nemo_grid.nc files needs +to be produced for each pair of source and destination grids. + +scrip.exe +--------- + +scrip takes the output files from scripgrid and creates a file of weights +to use to interpolate between the two grids described. The example given +only requests 1 map (from data to nemo); setting num_maps=2 will provide +the reverse weights if required. + + - num_maps is either 1 or 2 depending on whether the reverse + transformation is required + + - grid1_file, grid2_file: two remap grid files are required + as output by scripgrid + + - interp_file1, interp_file2: one or two interp_file names are + then supplied; these hold the weights to convert one grid to another + + - map1_name, map2_name: the map_name variables are just descriptive + + - map_method: can be 'bilinear' or 'bicubic' + + - normalize_opt: should usually be 'frac' or else the user needs to do + this scaling manually (this seems to the case for fractional ice cover) + + - output_opt may be supplied and set to either 'scrip' or 'ncar-csm' + + - restrict_type: should be 'latitude' or 'latlon' in which case + num_srch_bins only are used in one or two directions + + - use_grid_area fields override the scrip calculation of area in + case the model gets slightly different answers, but the area needs + to be supplied in the input files + +A conservative mapping scheme exists but is not yet working with NEMO grids. +See the scrip package documentation for more details of these parameters. +(http://climate.lanl.gov/Software/SCRIP/SCRIPusers.pdf) + +scripshape.exe +-------------- + +scripshape takes the output from scrip (e.g. data_nemo_bilin.nc ) and +rearranges the source and destination indices and associated weights into +sets of 2D fields each spanning the nemo grid. Each set is associated with +each node involved in the interpolation scheme. Thus for a bilinear mapping +the weights file required by the IOF option includes the following fields: + + double src01(lat, lon) ; double dst01(lat, lon) ; double wgt01(lat, lon) ; + double src02(lat, lon) ; double dst02(lat, lon) ; double wgt02(lat, lon) ; + double src03(lat, lon) ; double dst03(lat, lon) ; double wgt03(lat, lon) ; + double src04(lat, lon) ; double dst04(lat, lon) ; double wgt04(lat, lon) ; + +For a bicubic mapping the required fields are: + + double src01(lat, lon) ; double dst01(lat, lon) ; double wgt01(lat, lon) ; + double src02(lat, lon) ; double dst02(lat, lon) ; double wgt02(lat, lon) ; + double src03(lat, lon) ; double dst03(lat, lon) ; double wgt03(lat, lon) ; + double src04(lat, lon) ; double dst04(lat, lon) ; double wgt04(lat, lon) ; + double src05(lat, lon) ; double dst05(lat, lon) ; double wgt05(lat, lon) ; + double src06(lat, lon) ; double dst06(lat, lon) ; double wgt06(lat, lon) ; + double src07(lat, lon) ; double dst07(lat, lon) ; double wgt07(lat, lon) ; + double src08(lat, lon) ; double dst08(lat, lon) ; double wgt08(lat, lon) ; + double src09(lat, lon) ; double dst09(lat, lon) ; double wgt09(lat, lon) ; + double src10(lat, lon) ; double dst10(lat, lon) ; double wgt10(lat, lon) ; + double src11(lat, lon) ; double dst11(lat, lon) ; double wgt11(lat, lon) ; + double src12(lat, lon) ; double dst12(lat, lon) ; double wgt12(lat, lon) ; + double src13(lat, lon) ; double dst13(lat, lon) ; double wgt13(lat, lon) ; + double src14(lat, lon) ; double dst14(lat, lon) ; double wgt14(lat, lon) ; + double src15(lat, lon) ; double dst15(lat, lon) ; double wgt15(lat, lon) ; + double src16(lat, lon) ; double dst16(lat, lon) ; double wgt16(lat, lon) ; + +This program also adds an attribute to the weights file for use by the fld_interp +routine in fldread.F90. This tells the model about the east-west cyclicity of the source grid. +The value needs to be supplied in the scripshape namelist via the variable ew_wrap. +It should have one of the values -1, 0, 1 or 2. -1 means that the input grid is not +cyclic; 0 means that it is cyclic but with no overlapping columns; and a value greater +than zero represents the number of columns that overlap. In fact it only has an effect +when using bicubic interpolation in which the model needs to know which additional columns +have to be read in to correctly calculate gradient values. +The weights file produced by scripshape is ready for use in NEMO. This file +needs to by placed in the nemo working directory and needs to be named in the +appropriate SBC namelist entry (e.g. namsbc_clio, namsbc_flux or namsbc_core). + +scripinterp.exe +--------------- + +Take data on an input grid and interpolate to the nemo grid using the weights +calculated by the scrip program. +Method +Two namelists are used for configuration, eg + +&interp_inputs + input_file = "../data/wsx_av.nc" + interp_file = "data_nemo_bilin.nc" + input_name = "wsx" + input_start = 1,1,1,1 + input_stride = 1,1,1,1 + input_stop = 0,0,0,1 + input_vars = 'time' +/ + +&interp_outputs + output_file = "taux_1m.nc" + output_mode = "create" + output_dims = 'x', 'y', 'time_counter' + output_scaling = "sozotaux|1.0", "time_counter|86400.0" + output_name = 'sozotaux' + output_lon = 'x' + output_lat = 'y' + output_vars = 'time_counter' + output_attributes = 'time_counter|units|seconds since 1995-00-00 00:00:00', + 'time_counter|calendar|noleap', + 'sozotaux|units|N/m2' +/ + +This program just multiplies by weights and sums over each contributing point, +and then formats the output correctly for the model. + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/RELEASE_1.1 b/V4.0/nemo_sources/tools/WEIGHTS/RELEASE_1.1 new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/.log.dti b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/.log.dti new file mode 100644 index 0000000000000000000000000000000000000000..57e0ccbe3fced220e1f4c8cd4c9e42862f22f964 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/.log.dti @@ -0,0 +1,16 @@ +96/10/22 13:08:53 opened .log.dti +96/10/22 13:08:53 debug explicitly set to 0 +96/10/22 13:08:58 opened .log.dti +96/10/22 13:08:58 debug explicitly set to 0 +96/10/22 13:09:56 opened .log.dti +96/10/22 13:09:56 debug explicitly set to 0 +96/11/18 11:29:28 opened .log.dti +96/11/18 11:29:28 debug explicitly set to 0 +96/11/18 11:29:31 opened .log.dti +96/11/18 11:29:31 debug explicitly set to 0 +96/11/18 11:31:34 opened .log.dti +96/11/18 11:31:34 debug explicitly set to 0 +96/11/20 09:09:51 opened .log.dti +96/11/20 09:09:51 debug explicitly set to 0 +96/11/20 09:09:55 opened .log.dti +96/11/20 09:09:55 debug explicitly set to 0 diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/bugs b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/bugs new file mode 100644 index 0000000000000000000000000000000000000000..16432740158b9b8412110ed40ce8ef5c37c14346 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/bugs @@ -0,0 +1,58 @@ +************************************************************************ + +Bug or issue Reported Fixed +---------------------------------------------------- -------- -------- + +Outstanding: + +Need parallel implementation of SCRIP 07/01/00 +Latitude bins not very robust for sparse grids 10/27/98 +Deal with extrapolation for bilinear, bicubic 12/02/98 +Remove cyclic bndy assumptions from bilin, bicubic 12/02/98 +Problem with coordinate transform when both grids + contain pole point as cell edge (note that in + such a case, turning off the coordinate transform + by setting thresholds >pi, <-pi may fix this) 12/03/98 +Bug in test configuration when SH transformation on 12/03/98 + +Fixed in release 1.4: + +Conversion from polar projection back to lat/lon + space extremely sensitive near pole 07/01/01 08/20/01 +Bilinear/cubic fails when cells overlap longitude cut 08/13/01 08/20/01 +Bilinear/cubic iteration converges to bad solution + for skewed cells 08/21/01 08/21/01 +Nearest-neighbor backup to bilinear/cubic fails 08/13/01 08/20/01 +Added feature to use input areas for normalization 06/20/00 07/01/00 +Added error checks on weights for conservative maps 06/20/00 07/01/00 + +Fixed in release 1.3: + +Added new binning options to restrict searches ...do not know... +Optimized code for resizing arrays ................. + +Fixed in release 1.2: + +Changed namelist input for map type to character 05/31/99 06/04/99 +Added new output option for CSM coupler 05/31/99 06/04/99 +Added additional normalization options for conserv 05/31/99 06/04/99 +Improper handling of grid pairs which share corners 01/29/99 02/04/99 +Uninitialized variables and subscripts out of range 01/22/99 01/25/99 + +Fixed in release 1.1: + +Conservative remap assumed num_maps = 2 12/16/98 12/17/98 +Change units of grid quantities back to input units 12/04/98 12/17/98 +Add option for unnormalized conservative weights 12/04/98 12/17/98 +Update user's guide for recent changes 12/02/98 12/17/98 +Add different test fields 11/18/98 12/02/98 +Add support for multiple remap test 11/18/98 12/02/98 +Add bicubic module 11/18/98 12/17/98 + +Fixed in release 1.02: + +Problems setting up latitude bins for polar cells 10/22/98 10/27/98 +Input latitudes out of range (due to machine pi/2) 10/27/98 10/27/98 +Bad coordinate transformation in south pole 10/22/98 11/02/98 + +************************************************************************ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/README b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/README new file mode 100644 index 0000000000000000000000000000000000000000..3d5e06922465369ec2524a5a269900fd95674ee9 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/README @@ -0,0 +1,17 @@ + + This directory contains some grid files in netCDF format + for use in the SCRIP remapping package. + + In addition, there are several source codes for creating + netCDF files for use in SCRIP: + + convertPOPT.f - converts input grid files for the POP + ocean model to SCRIP netCDF format + + convertgauss.f - creates a SCRIP netCDF grid file for + a Gaussian lat/lon grid that a global + spectral model would use + + convert_old.f - converts old grid files from a previous + version of the SCRIP routines + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertPOPT.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertPOPT.f new file mode 100644 index 0000000000000000000000000000000000000000..d5f860ac2c91e97a1e94ce82e456d52dbd25ba1d --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertPOPT.f @@ -0,0 +1,447 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This file converts a POP grid.dat file to a remapping grid file +! in netCDF format. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: convertPOPT.f,v 1.4 2001/08/21 21:22:56 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +!*********************************************************************** + + program convertPOPT + +!----------------------------------------------------------------------- +! +! This file converts a POP grid.dat file to a remapping grid file. +! +!----------------------------------------------------------------------- + + use kinds_mod + use constants + use iounits + use netcdf_mod + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe the grid +! 4/3 nx = 192, ny = 128 +! 2/3 (mod) nx = 384, ny = 288 +! x3p Greenland DP nx = 100, ny = 116 +! x2p Greenland DP nx = 160, ny = 192 +! x1p Greenland DP nx = 320, ny = 384 +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & nx = 320, ny = 384, + & grid_size = nx*ny, + & grid_rank = 2, + & grid_corners = 4 + + integer (kind=int_kind), dimension(2) :: + & grid_dims ! size of each dimension + + character(char_len), parameter :: + & grid_name = 'Greenland DP x1p', + & grid_file_in = '/scratch/pwjones/grid.320x384.da', + & grid_topo_in = '/scratch/pwjones/kmt.320x384.da', + & grid_file_out = '/scratch/pwjones/Greenland_DP_x1p.nc' + + real (kind=dbl_kind), parameter :: + & radius = 6370.0e5_dbl_kind ! radius of Earth (cm) + &, area_norm = one/(radius*radius) + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(grid_size) :: + & grid_imask + + real (kind=dbl_kind), dimension(grid_size) :: + & grid_area , ! area as computed in POP + & grid_center_lat, ! lat/lon coordinates for + & grid_center_lon ! each grid center in radians + + real (kind=dbl_kind), dimension(grid_corners,grid_size) :: + & grid_corner_lat, ! lat/lon coordinates for + & grid_corner_lon ! each grid corner in radians + + real (kind=dbl_kind), dimension(nx,ny) :: + & HTN, HTE ! T-cell grid lengths + +!----------------------------------------------------------------------- +! +! other local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: i, j, n, iunit, ocn_add, im1, jm1 + + integer (kind=int_kind) :: + & ncstat, ! general netCDF status variable + & nc_grid_id, ! netCDF grid dataset id + & nc_gridsize_id, ! netCDF grid size dim id + & nc_gridcorn_id, ! netCDF grid corner dim id + & nc_gridrank_id, ! netCDF grid rank dim id + & nc_griddims_id, ! netCDF grid dimensions id + & nc_grdcntrlat_id, ! netCDF grid center lat id + & nc_grdcntrlon_id, ! netCDF grid center lon id + & nc_grdimask_id, ! netCDF grid mask id + & nc_gridarea_id, ! netCDF grid area id + & nc_grdcrnrlat_id, ! netCDF grid corner lat id + & nc_grdcrnrlon_id ! netCDF grid corner lon id + + integer (kind=int_kind), dimension(2) :: + & nc_dims2_id ! netCDF dim id array for 2-d arrays + + real (kind=dbl_kind) :: tmplon, dxt, dyt + +!----------------------------------------------------------------------- +! +! read in grid info +! lat/lon info is on velocity points which correspond +! to the NE corner (in logical space) of the grid cell. +! +!----------------------------------------------------------------------- + + call get_unit(iunit) + open(unit=iunit, file=grid_topo_in, status='old', + & form='unformatted', access='direct', recl=grid_size*4) + read (unit=iunit,rec=1) grid_imask + call release_unit(iunit) + + call get_unit(iunit) + open(unit=iunit, file=grid_file_in, status='old', + & form='unformatted', access='direct', recl=grid_size*8) + read (unit=iunit, rec=1) grid_corner_lat(3,:) + read (unit=iunit, rec=2) grid_corner_lon(3,:) + read (unit=iunit, rec=3) HTN + read (unit=iunit, rec=4) HTE + call release_unit(iunit) + + grid_dims(1) = nx + grid_dims(2) = ny + +!----------------------------------------------------------------------- +! +! convert KMT field to integer grid mask +! +!----------------------------------------------------------------------- + + grid_imask = min(grid_imask, 1) + +!----------------------------------------------------------------------- +! +! compute remaining corners +! +!----------------------------------------------------------------------- + + do j=1,ny + do i=1,nx + ocn_add = (j-1)*nx + i + if (i .ne. 1) then + im1 = ocn_add - 1 + else + im1 = ocn_add + nx - 1 + endif + + grid_corner_lat(4,ocn_add) = grid_corner_lat(3,im1) + grid_corner_lon(4,ocn_add) = grid_corner_lon(3,im1) + end do + end do + + do j=2,ny + do i=1,nx + ocn_add = (j-1)*nx + i + jm1 = (j-2)*nx + i + + grid_corner_lat(2,ocn_add) = grid_corner_lat(3,jm1) + grid_corner_lat(1,ocn_add) = grid_corner_lat(4,jm1) + + grid_corner_lon(2,ocn_add) = grid_corner_lon(3,jm1) + grid_corner_lon(1,ocn_add) = grid_corner_lon(4,jm1) + end do + end do + +!----------------------------------------------------------------------- +! +! mock up the lower row boundaries +! +!----------------------------------------------------------------------- + + do i=1,nx + grid_corner_lat(1,i) = -pih + tiny + grid_corner_lat(2,i) = -pih + tiny + + grid_corner_lon(1,i) = grid_corner_lon(4,i) + grid_corner_lon(2,i) = grid_corner_lon(3,i) + end do + +!----------------------------------------------------------------------- +! +! correct for 0,2pi longitude crossings +! +!----------------------------------------------------------------------- + + do ocn_add=1,grid_size + if (grid_corner_lon(1,ocn_add) > pi2) + & grid_corner_lon(1,ocn_add) = + & grid_corner_lon(1,ocn_add) - pi2 + if (grid_corner_lon(1,ocn_add) < 0.0) + & grid_corner_lon(1,ocn_add) = + & grid_corner_lon(1,ocn_add) + pi2 + do n=2,grid_corners + tmplon = grid_corner_lon(n ,ocn_add) - + & grid_corner_lon(n-1,ocn_add) + if (tmplon < -three*pih) grid_corner_lon(n,ocn_add) = + & grid_corner_lon(n,ocn_add) + pi2 + if (tmplon > three*pih) grid_corner_lon(n,ocn_add) = + & grid_corner_lon(n,ocn_add) - pi2 + end do + end do + +!----------------------------------------------------------------------- +! +! compute ocean cell centers by averaging corner values +! +!----------------------------------------------------------------------- + + do ocn_add=1,grid_size + grid_center_lat(ocn_add) = grid_corner_lat(1,ocn_add) + grid_center_lon(ocn_add) = grid_corner_lon(1,ocn_add) + do n=2,grid_corners + grid_center_lat(ocn_add) = grid_center_lat(ocn_add) + + & grid_corner_lat(n,ocn_add) + grid_center_lon(ocn_add) = grid_center_lon(ocn_add) + + & grid_corner_lon(n,ocn_add) + end do + grid_center_lat(ocn_add) = grid_center_lat(ocn_add)/ + & float(grid_corners) + grid_center_lon(ocn_add) = grid_center_lon(ocn_add)/ + & float(grid_corners) + if (grid_center_lon(ocn_add) > pi2) + & grid_center_lon(ocn_add) = grid_center_lon(ocn_add) - pi2 + if (grid_center_lon(ocn_add) < 0.0) + & grid_center_lon(ocn_add) = grid_center_lon(ocn_add) + pi2 + end do + +!----------------------------------------------------------------------- +! +! compute cell areas in same way as POP +! +!----------------------------------------------------------------------- + + n = 0 + do j=1,ny + if (j > 1) then + jm1 = j-1 + else + jm1 = 1 + endif + do i=1,nx + if (i > 1) then + im1 = i-1 + else + im1 = nx + endif + + n = n+1 + + dxt = half*(HTN(i,j) + HTN(i,jm1)) + dyt = half*(HTE(i,j) + HTE(im1,j)) + if (dxt == zero) dxt=one + if (dyt == zero) dyt=one + + grid_area(n) = dxt*dyt*area_norm + end do + end do + +!----------------------------------------------------------------------- +! +! set up attributes for netCDF file +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset for this grid + !*** + + ncstat = nf_create (grid_file_out, NF_CLOBBER, + & nc_grid_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title', + & len_trim(grid_name), grid_name) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_size', grid_size, + & nc_gridsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_rank', grid_rank, + & nc_gridrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_corners', grid_corners, + & nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dim size array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT, + & 1, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lat', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lon', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_area', NF_DOUBLE, + & 1, nc_gridsize_id, nc_gridarea_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_imask', NF_INT, + & 1, nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdimask_id, 'units', + & 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner latitude array + !*** + + nc_dims2_id(1) = nc_gridcorn_id + nc_dims2_id(2) = nc_gridsize_id + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lat', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlat_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lon', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlon_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write grid data +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + ncstat = nf_put_var_int(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_gridarea_id, + & grid_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, + & grid_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlat_id, + & grid_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlon_id, + & grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_close(nc_grid_id) + +!*********************************************************************** + + end program convertPOPT + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convert_old.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convert_old.f new file mode 100644 index 0000000000000000000000000000000000000000..9a6278215e2544de4df73a8b9500853e51c1db4b --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convert_old.f @@ -0,0 +1,287 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This file converts a POP grid.dat file to a remapping grid file +! in netCDF format. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: convert_old.f,v 1.2 2000/04/19 22:05:57 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +!*********************************************************************** + + program convertPOPT + +!----------------------------------------------------------------------- +! +! This file converts a POP grid.dat file to a remapping grid file. +! +!----------------------------------------------------------------------- + + use kinds_mod + use constants + use iounits + use netcdf_mod + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe the grid +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & grid_size, grid_rank, grid_corners + + integer (kind=int_kind), dimension(2) :: + & grid_dims ! size of each dimension + + character(char_len) :: + & grid_name + + character(char_len), parameter :: + & grid_file_in = 'remap_grid_WWice.dat', + & grid_file_out = 'remap_grid_WWice.nc' + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(:), allocatable :: + & grid_imask + + real (kind=dbl_kind), dimension(:), allocatable :: + & grid_center_lat, ! lat/lon coordinates for + & grid_center_lon ! each grid center in radians + + real (kind=dbl_kind), dimension(:,:), allocatable :: + & grid_corner_lat, ! lat/lon coordinates for + & grid_corner_lon ! each grid corner in radians + +!----------------------------------------------------------------------- +! +! other local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: i, j, n, iunit, ocn_add, im1, jm1 + + integer (kind=int_kind) :: + & ncstat, ! general netCDF status variable + & nc_grid_id, ! netCDF grid dataset id + & nc_gridsize_id, ! netCDF grid size dim id + & nc_gridcorn_id, ! netCDF grid corner dim id + & nc_gridrank_id, ! netCDF grid rank dim id + & nc_griddims_id, ! netCDF grid dimensions id + & nc_grdcntrlat_id, ! netCDF grid center lat id + & nc_grdcntrlon_id, ! netCDF grid center lon id + & nc_grdimask_id, ! netCDF grid mask id + & nc_grdcrnrlat_id, ! netCDF grid corner lat id + & nc_grdcrnrlon_id ! netCDF grid corner lon id + + integer (kind=int_kind), dimension(2) :: + & nc_dims2_id ! netCDF dim id array for 2-d arrays + + real (kind=dbl_kind) :: tmplon + +!----------------------------------------------------------------------- +! +! read in grid info +! lat/lon info is on velocity points which correspond +! to the NE corner (in logical space) of the grid cell. +! +!----------------------------------------------------------------------- + + call get_unit(iunit) + open(unit=iunit, file=grid_file_in, status='old', + & form='unformatted') + + read(iunit) grid_name + read(iunit) grid_size, grid_corners, grid_rank, grid_dims + + allocate( grid_center_lat(grid_size), + & grid_center_lon(grid_size), + & grid_imask (grid_size), + & grid_corner_lat(grid_corners, grid_size), + & grid_corner_lon(grid_corners, grid_size) ) + + read(iunit) grid_center_lat + read(iunit) grid_center_lon + read(iunit) grid_corner_lat + read(iunit) grid_corner_lon + read(iunit) grid_imask + call release_unit(iunit) + +!----------------------------------------------------------------------- +! +! set up attributes for netCDF file +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset for this grid + !*** + + ncstat = nf_create (grid_file_out, NF_CLOBBER, + & nc_grid_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title', + & len_trim(grid_name), grid_name) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_size', grid_size, + & nc_gridsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_rank', grid_rank, + & nc_gridrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_corners', grid_corners, + & nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dim size array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT, + & 1, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lat', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lon', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_imask', NF_INT, + & 1, nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdimask_id, 'units', + & 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner latitude array + !*** + + nc_dims2_id(1) = nc_gridcorn_id + nc_dims2_id(2) = nc_gridsize_id + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lat', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlat_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lon', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlon_id, 'units', + & 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write grid data +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + ncstat = nf_put_var_int(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, + & grid_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlat_id, + & grid_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlon_id, + & grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_close(nc_grid_id) + +!*********************************************************************** + + end program convertPOPT + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertgauss.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertgauss.f new file mode 100644 index 0000000000000000000000000000000000000000..aad0262b9c0d3160af0dfd5841821973a853a20e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/convertgauss.f @@ -0,0 +1,506 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This program creates a remapping grid file for Gaussian lat/lon +! grids (for spectral transform codes). +! +!----------------------------------------------------------------------- +! +! CVS:$Id: convertgauss.f,v 1.3 2000/04/19 22:05:57 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +!*********************************************************************** + + program convert_gauss + +!----------------------------------------------------------------------- +! +! This file creates a remapping grid file for a Gaussian grid +! +!----------------------------------------------------------------------- + + use kinds_mod + use constants + use iounits + use netcdf_mod + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe the grid +! +! T42: nx=128 ny=64 +! T62: nx=192 ny=94 +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & nx = 192, ny = 94, + & grid_size = nx*ny, + & grid_rank = 2, + & grid_corners = 4 + + character(char_len), parameter :: + & grid_name = 'T62 Gaussian Grid', + & grid_file_out = 'remap_grid_T62.nc' + + integer (kind=int_kind), dimension(grid_rank) :: + & grid_dims + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(grid_size) :: + & grid_imask + + real (kind=dbl_kind), dimension(grid_size) :: + & grid_center_lat, ! lat/lon coordinates for + & grid_center_lon ! each grid center in degrees + + real (kind=dbl_kind), dimension(grid_corners,grid_size) :: + & grid_corner_lat, ! lat/lon coordinates for + & grid_corner_lon ! each grid corner in degrees + +!----------------------------------------------------------------------- +! +! other local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: i, j, iunit, atm_add + + integer (kind=int_kind) :: + & ncstat, ! general netCDF status variable + & nc_grid_id, ! netCDF grid dataset id + & nc_gridsize_id, ! netCDF grid size dim id + & nc_gridcorn_id, ! netCDF grid corner dim id + & nc_gridrank_id, ! netCDF grid rank dim id + & nc_griddims_id, ! netCDF grid dimension size id + & nc_grdcntrlat_id, ! netCDF grid center lat id + & nc_grdcntrlon_id, ! netCDF grid center lon id + & nc_grdimask_id, ! netCDF grid mask id + & nc_grdcrnrlat_id, ! netCDF grid corner lat id + & nc_grdcrnrlon_id ! netCDF grid corner lon id + + integer (kind=int_kind), dimension(2) :: + & nc_dims2_id ! netCDF dim id array for 2-d arrays + + real (kind=dbl_kind) :: dlon, minlon, maxlon, centerlon, + & minlat, maxlat, centerlat + + real (kind=dbl_kind), dimension(ny) :: gauss_root, gauss_wgt + +!----------------------------------------------------------------------- +! +! compute longitudes of cell centers and corners. set up alon +! array for search routine. +! +!----------------------------------------------------------------------- + + grid_dims(1) = nx + grid_dims(2) = ny + + dlon = 360./nx + + do i=1,nx + + centerlon = (i-1)*dlon + minlon = centerlon - half*dlon + maxlon = centerlon + half*dlon + + do j=1,ny + atm_add = (j-1)*nx + i + + grid_center_lon(atm_add ) = centerlon + grid_corner_lon(1,atm_add) = minlon + grid_corner_lon(2,atm_add) = maxlon + grid_corner_lon(3,atm_add) = maxlon + grid_corner_lon(4,atm_add) = minlon + end do + + end do + +!----------------------------------------------------------------------- +! +! compute Gaussian latitudes and store in gauss_wgt. +! +!----------------------------------------------------------------------- + + call gquad(ny, gauss_root, gauss_wgt) + do j=1,ny + gauss_wgt(j) = pih - gauss_root(ny+1-j) + end do + +!----------------------------------------------------------------------- +! +! compute latitudes at cell centers and corners. set up alat +! array for search routine. +! +!----------------------------------------------------------------------- + + do j=1,ny + centerlat = gauss_wgt(j) + + if (j .eq. 1) then + minlat = -pih + else + minlat = ATAN((COS(gauss_wgt(j-1)) - + & COS(gauss_wgt(j )))/ + & (SIN(gauss_wgt(j )) - + & SIN(gauss_wgt(j-1)))) + endif + + if (j .eq. ny) then + maxlat = pih + else + maxlat = ATAN((COS(gauss_wgt(j )) - + & COS(gauss_wgt(j+1)))/ + & (SIN(gauss_wgt(j+1)) - + & SIN(gauss_wgt(j )))) + endif + + do i=1,nx + atm_add = (j-1)*nx + i + grid_center_lat(atm_add ) = centerlat*360./pi2 + grid_corner_lat(1,atm_add) = minlat*360./pi2 + grid_corner_lat(2,atm_add) = minlat*360./pi2 + grid_corner_lat(3,atm_add) = maxlat*360./pi2 + grid_corner_lat(4,atm_add) = maxlat*360./pi2 + end do + + end do + +!----------------------------------------------------------------------- +! +! define mask +! +!----------------------------------------------------------------------- + + grid_imask = 1 + +!----------------------------------------------------------------------- +! +! set up attributes for netCDF file +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset for this grid + !*** + + ncstat = nf_create (grid_file_out, NF_CLOBBER, + & nc_grid_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title', + & len_trim(grid_name), grid_name) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_size', grid_size, + & nc_gridsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_corners', grid_corners, + & nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_rank', grid_rank, + & nc_gridrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dimension size array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT, + & 1, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lat', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lon', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_imask', NF_INT, + & 1, nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdimask_id, 'units', + & 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner latitude array + !*** + + nc_dims2_id(1) = nc_gridcorn_id + nc_dims2_id(2) = nc_gridsize_id + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lat', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlat_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lon', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlon_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write grid data +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, + & grid_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlat_id, + & grid_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlon_id, + & grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_close(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end program convert_gauss + +!*********************************************************************** + + subroutine gquad(l,root,w) + +!----------------------------------------------------------------------- +! +! This subroutine finds the l roots (in theta) and gaussian weights +! associated with the legendre polynomial of degree l > 1. +! +!----------------------------------------------------------------------- + + use kinds_mod + use constants + + implicit none + +!----------------------------------------------------------------------- +! +! intent(in) +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: l + +!----------------------------------------------------------------------- +! +! intent(out) +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), dimension(l), intent(out) :: + & root, w + +!----------------------------------------------------------------------- +! +! local +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: l1, l2, l22, l3, k, i, j + + real (kind=dbl_kind) :: + & del,co,p1,p2,p3,t1,t2,slope,s,c,pp1,pp2,p00 + +!----------------------------------------------------------------------- +! +! Define useful constants. +! +!----------------------------------------------------------------------- + + del= pi/float(4*l) + l1 = l+1 + co = float(2*l+3)/float(l1**2) + p2 = 1.0 + t2 = -del + l2 = l/2 + k = 1 + p00 = one/sqrt(two) + +!----------------------------------------------------------------------- +! +! Start search for each root by looking for crossing point. +! +!----------------------------------------------------------------------- + + do i=1,l2 + 10 t1 = t2 + t2 = t1+del + p1 = p2 + s = sin(t2) + c = cos(t2) + pp1 = 1.0 + p3 = p00 + do j=1,l1 + pp2 = pp1 + pp1 = p3 + p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- + & sqrt(float((2*j+1)*(j-1)*(j-1))/ + & float((2*j-3)*j*j))*pp2 + end do + p2 = pp1 + if ((k*p2).gt.0) goto 10 + +!----------------------------------------------------------------------- +! +! Now converge using Newton-Raphson. +! +!----------------------------------------------------------------------- + + k = -k + 20 continue + slope = (t2-t1)/(p2-p1) + t1 = t2 + t2 = t2-slope*p2 + p1 = p2 + s = sin(t2) + c = cos(t2) + pp1 = 1.0 + p3 = p00 + do j=1,l1 + pp2 = pp1 + pp1 = p3 + p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- + & sqrt(float((2*j+1)*(j-1)*(j-1))/ + & float((2*j-3)*j*j))*pp2 + end do + p2 = pp1 + if (abs(p2).gt.1.e-10) goto 20 + root(i) = t2 + w(i) = co*(sin(t2)/p3)**2 + end do + +!----------------------------------------------------------------------- +! +! If l is odd, take care of odd point. +! +!----------------------------------------------------------------------- + + l22 = 2*l2 + if (l22 .ne. l) then + l2 = l2+1 + t2 = pi/2.0 + root(l2) = t2 + s = sin(t2) + c = cos(t2) + pp1 = 1.0 + p3 = p00 + do j=1,l1 + pp2 = pp1 + pp1 = p3 + p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- + & sqrt(float((2*j+1)*(j-1)*(j-1))/ + & float((2*j-3)*j*j))*pp2 + end do + p2 = pp1 + w(l2) = co/p3**2 + endif + +!----------------------------------------------------------------------- +! +! Use symmetry to compute remaining roots and weights. +! +!----------------------------------------------------------------------- + + l3 = l2+1 + do i=l3,l + root(i) = pi-root(l-i+1) + w(i) = w(l-i+1) + end do + +!----------------------------------------------------------------------- + + end subroutine gquad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/create_latlon.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/create_latlon.f new file mode 100644 index 0000000000000000000000000000000000000000..1ec99a9528d5fdc4a8696b7a00908268f4a7308b --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/create_latlon.f @@ -0,0 +1,305 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This program creates a remapping grid file for a lat/lon grid. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: create_latlon.f,v 1.1 2000/04/19 22:05:58 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +!*********************************************************************** + + program create_latlon + +!----------------------------------------------------------------------- +! +! This file creates a remapping grid file for a Gaussian grid +! +!----------------------------------------------------------------------- + + use kinds_mod + use constants + use iounits + use netcdf_mod + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe the grid +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & nx = 360, ny = 180, + & grid_size = nx*ny, + & grid_rank = 2, + & grid_corners = 4 + + character(char_len), parameter :: + & grid_name = 'Lat/lon 1 degree Grid', + & grid_file_out = 'll1deg_grid.nc' + + integer (kind=int_kind), dimension(grid_rank) :: + & grid_dims + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(grid_size) :: + & grid_imask + + real (kind=dbl_kind), dimension(grid_size) :: + & grid_center_lat, ! lat/lon coordinates for + & grid_center_lon ! each grid center in degrees + + real (kind=dbl_kind), dimension(grid_corners,grid_size) :: + & grid_corner_lat, ! lat/lon coordinates for + & grid_corner_lon ! each grid corner in degrees + +!----------------------------------------------------------------------- +! +! other local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: i, j, iunit, atm_add + + integer (kind=int_kind) :: + & ncstat, ! general netCDF status variable + & nc_grid_id, ! netCDF grid dataset id + & nc_gridsize_id, ! netCDF grid size dim id + & nc_gridcorn_id, ! netCDF grid corner dim id + & nc_gridrank_id, ! netCDF grid rank dim id + & nc_griddims_id, ! netCDF grid dimension size id + & nc_grdcntrlat_id, ! netCDF grid center lat id + & nc_grdcntrlon_id, ! netCDF grid center lon id + & nc_grdimask_id, ! netCDF grid mask id + & nc_grdcrnrlat_id, ! netCDF grid corner lat id + & nc_grdcrnrlon_id ! netCDF grid corner lon id + + integer (kind=int_kind), dimension(2) :: + & nc_dims2_id ! netCDF dim id array for 2-d arrays + + real (kind=dbl_kind) :: dlon, minlon, maxlon, centerlon, + & dlat, minlat, maxlat, centerlat + +!----------------------------------------------------------------------- +! +! compute longitudes and latitudes of cell centers and corners. +! +!----------------------------------------------------------------------- + + grid_dims(1) = nx + grid_dims(2) = ny + + dlon = 360./nx + dlat = 180./ny + + do j=1,ny + + minlat = -90._dbl_kind + (j-1)*dlat + maxlat = -90._dbl_kind + j *dlat + centerlat = minlat + half*dlat + + do i=1,nx + centerlon = (i-1)*dlon + minlon = centerlon - half*dlon + maxlon = centerlon + half*dlon + + atm_add = (j-1)*nx + i + + grid_center_lat(atm_add ) = centerlat + grid_corner_lat(1,atm_add) = minlat + grid_corner_lat(2,atm_add) = minlat + grid_corner_lat(3,atm_add) = maxlat + grid_corner_lat(4,atm_add) = maxlat + + grid_center_lon(atm_add ) = centerlon + grid_corner_lon(1,atm_add) = minlon + grid_corner_lon(2,atm_add) = maxlon + grid_corner_lon(3,atm_add) = maxlon + grid_corner_lon(4,atm_add) = minlon + end do + end do + +!----------------------------------------------------------------------- +! +! define mask +! +!----------------------------------------------------------------------- + + grid_imask = 1 + +!----------------------------------------------------------------------- +! +! set up attributes for netCDF file +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset for this grid + !*** + + ncstat = nf_create (grid_file_out, NF_CLOBBER, + & nc_grid_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title', + & len_trim(grid_name), grid_name) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_size', grid_size, + & nc_gridsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_corners', grid_corners, + & nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + ncstat = nf_def_dim (nc_grid_id, 'grid_rank', grid_rank, + & nc_gridrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dimension size array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT, + & 1, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lat', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_center_lon', NF_DOUBLE, + & 1, nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_imask', NF_INT, + & 1, nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdimask_id, 'units', + & 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner latitude array + !*** + + nc_dims2_id(1) = nc_gridcorn_id + nc_dims2_id(2) = nc_gridsize_id + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lat', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlat_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner longitude array + !*** + + ncstat = nf_def_var (nc_grid_id, 'grid_corner_lon', NF_DOUBLE, + & 2, nc_dims2_id, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_grid_id, nc_grdcrnrlon_id, 'units', + & 7, 'degrees') + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write grid data +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, + & grid_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, + & grid_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlat_id, + & grid_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_grid_id, nc_grdcrnrlon_id, + & grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_close(nc_grid_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end program create_latlon + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/makefile b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/makefile new file mode 100644 index 0000000000000000000000000000000000000000..93c4d137a9e0d09b22d6062b1b480c8d7311384a --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/makefile @@ -0,0 +1,59 @@ +# +# Makefile for interpolation code +# CVS:$Id: makefile,v 1.3 2000/04/19 22:05:59 pwjones Exp $ +# +#COMP = xlf +COMP = f90 +FLAGS = -O3 -64 -r10000 -I/usr/local/include +#FLAGS = -g +LIB = -lnetcdf +INCL = +SRCDIR = ../source +EXEDIR = . +OBJ = \ + kinds_mod.o \ + constants.o \ + iounits.o \ + netcdf.o + +all: convertPOPT convertgauss create_latlon + +convertold: $(OBJ) convert_old.o + $(COMP) $(FLAGS) $(OBJ) convert_old.o $(LIB) -o $(EXEDIR)/convertold + +convertPOPT: $(OBJ) convertPOPT.o + $(COMP) $(FLAGS) $(OBJ) convertPOPT.o $(LIB) -o $(EXEDIR)/convertPOPT + +convertgauss: $(OBJ) convertgauss.o + $(COMP) $(FLAGS) $(OBJ) convertgauss.o $(LIB) -o $(EXEDIR)/convertgauss + +create_latlon: $(OBJ) create_latlon.o + $(COMP) $(FLAGS) $(OBJ) create_latlon.o $(LIB) -o $(EXEDIR)/create_latlon + +kinds_mod.o: $(SRCDIR)/kinds_mod.f $(INCL) + $(COMP) $(FLAGS) -c $(SRCDIR)/kinds_mod.f + +constants.o: $(SRCDIR)/constants.f kinds_mod.o $(INCL) + $(COMP) $(FLAGS) -c $(SRCDIR)/constants.f + +iounits.o: $(SRCDIR)/iounits.f kinds_mod.o constants.o $(INCL) + $(COMP) $(FLAGS) -c $(SRCDIR)/iounits.f + +netcdf.o: $(SRCDIR)/netcdf.f kinds_mod.o constants.o $(INCL) + $(COMP) $(FLAGS) -c $(SRCDIR)/netcdf.f + +convert_old.o: convert_old.f kinds_mod.o constants.o iounits.o netcdf.o $(INCL) + $(COMP) $(FLAGS) -c convert_old.f + +convertPOPT.o: convertPOPT.f kinds_mod.o constants.o iounits.o netcdf.o $(INCL) + $(COMP) $(FLAGS) -c convertPOPT.f + +convertgauss.o: convertgauss.f kinds_mod.o constants.o iounits.o netcdf.o $(INCL) + $(COMP) $(FLAGS) -c convertgauss.f + +create_latlon.o: create_latlon.f kinds_mod.o constants.o iounits.o netcdf.o $(INCL) + $(COMP) $(FLAGS) -c create_latlon.f + +clean: + /bin/rm *.o *.mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_POP43.nc.bz2 b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_POP43.nc.bz2 new file mode 100644 index 0000000000000000000000000000000000000000..1f768b188c7fb62873722a0f214c3aa8c0a6a57f Binary files /dev/null and b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_POP43.nc.bz2 differ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_T42.nc.bz2 b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_T42.nc.bz2 new file mode 100644 index 0000000000000000000000000000000000000000..ade466ea1e8d4daf184807855f33663a1eede9b4 Binary files /dev/null and b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/grids/remap_grid_T42.nc.bz2 differ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_in b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_in new file mode 100644 index 0000000000000000000000000000000000000000..360054d42b883f035a34d890a9478bd23f0e14fc --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_in @@ -0,0 +1,16 @@ +&remap_inputs + num_maps = 2 + grid1_file = 'grids/remap_grid_POP43.nc' + grid2_file = 'grids/remap_grid_T42.nc' + interp_file1 = 'rmp_POP43_to_T42_conserv.nc' + interp_file2 = 'rmp_T42_to_POP43_conserv.nc' + map1_name = 'POP43 to T42 Conservative Mapping' + map2_name = 'T42 to POP43 Conservative Mapping' + map_method = 'conservative' + normalize_opt = 'frac' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. +/ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_test_in b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_test_in new file mode 100644 index 0000000000000000000000000000000000000000..987d0876812825577e620f4168671aedb15413f3 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/scrip_test_in @@ -0,0 +1,5 @@ +&remap_inputs + field_choice = 2 + interp_file = 'rmp_T42_to_POP43_conserv.nc' + output_file = 'out_T42_to_POP43_conserv.nc' +/ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/constants.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/constants.f new file mode 100644 index 0000000000000000000000000000000000000000..7a684277df089024d45f219e8778a37580ff2853 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/constants.f @@ -0,0 +1,65 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module defines common constants used in many routines. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: constants.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module constants + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + + implicit none + + save + +!----------------------------------------------------------------------- + + real (kind = dbl_kind), parameter :: + & zero = 0.0_dbl_kind, + & one = 1.0_dbl_kind, + & two = 2.0_dbl_kind, + & three = 3.0_dbl_kind, + & four = 4.0_dbl_kind, + & five = 5.0_dbl_kind, + & half = 0.5_dbl_kind, + & quart = 0.25_dbl_kind, + & bignum = 1.e+20_dbl_kind, + & tiny = 1.e-14_dbl_kind, + & pi = 3.14159265359_dbl_kind, + & pi2 = two*pi, + & pih = half*pi + +!----------------------------------------------------------------------- + + end module constants + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/copyright b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/copyright new file mode 100644 index 0000000000000000000000000000000000000000..64f69fca38de389f4b31807b57f9149f5c83087e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/copyright @@ -0,0 +1,26 @@ +!----------------------------------------------------------------------- +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!----------------------------------------------------------------------- diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/grids.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/grids.f new file mode 100644 index 0000000000000000000000000000000000000000..d498929abacd1e2d88a8b09c17ea5b4065b7e455 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/grids.f @@ -0,0 +1,831 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module reads in and initializes two grids for remapping. +! NOTE: grid1 must be the master grid -- the grid that determines +! which cells participate (e.g. land mask) and the fractional +! area of grid2 cells that participate in the remapping. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: grids.f,v 1.6 2001/08/21 21:06:41 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module grids + +!----------------------------------------------------------------------- + + use kinds_mod ! defines data types + use constants ! common constants + use iounits ! I/O unit manager + use netcdf_mod ! netCDF stuff + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe each grid +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), save :: + & grid1_size, grid2_size, ! total points on each grid + & grid1_rank, grid2_rank, ! rank of each grid + & grid1_corners, grid2_corners ! number of corners + ! for each grid cell + + integer (kind=int_kind), dimension(:), allocatable, save :: + & grid1_dims, grid2_dims ! size of each grid dimension + + character(char_len), save :: + & grid1_name, grid2_name ! name for each grid + + character (char_len), save :: + & grid1_units, ! units for grid coords (degs/radians) + & grid2_units ! units for grid coords + + real (kind=dbl_kind), parameter :: + & deg2rad = pi/180. ! conversion for deg to rads + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(:), allocatable, save :: + & grid1_mask, ! flag which cells participate + & grid2_mask ! flag which cells participate + + real (kind=dbl_kind), dimension(:), allocatable, save :: + & grid1_center_lat, ! lat/lon coordinates for + & grid1_center_lon, ! each grid center in radians + & grid2_center_lat, + & grid2_center_lon, + & grid1_area, ! tot area of each grid1 cell + & grid2_area, ! tot area of each grid2 cell + & grid1_area_in, ! area of grid1 cell from file + & grid2_area_in, ! area of grid2 cell from file + & grid1_frac, ! fractional area of grid cells + & grid2_frac ! participating in remapping + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: + & grid1_corner_lat, ! lat/lon coordinates for + & grid1_corner_lon, ! each grid corner in radians + & grid2_corner_lat, + & grid2_corner_lon + + logical (kind=log_kind), save :: + & luse_grid_centers ! use centers for bounding boxes + &, luse_grid1_area ! use area from grid file + &, luse_grid2_area ! use area from grid file + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: + & grid1_bound_box, ! lat/lon bounding box for use + & grid2_bound_box ! in restricting grid searches + +!----------------------------------------------------------------------- +! +! bins for restricting searches +! +!----------------------------------------------------------------------- + + character (char_len), save :: + & restrict_type ! type of bins to use + + integer (kind=int_kind), save :: + & num_srch_bins ! num of bins for restricted srch + + integer (kind=int_kind), dimension(:,:), allocatable, save :: + & bin_addr1, ! min,max adds for grid1 cells in this lat bin + & bin_addr2 ! min,max adds for grid2 cells in this lat bin + + real(kind=dbl_kind), dimension(:,:), allocatable, save :: + & bin_lats ! min,max latitude for each search bin + &, bin_lons ! min,max longitude for each search bin + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine grid_init(grid1_file, grid2_file) + +!----------------------------------------------------------------------- +! +! this routine reads grid info from grid files and makes any +! necessary changes (e.g. for 0,2pi longitude range) +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: + & grid1_file, grid2_file ! grid data files + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & n ! loop counter + &, nele ! element loop counter + &, iunit ! unit number for opening files + &, i,j ! logical 2d addresses + &, ip1,jp1 + &, n_add, e_add, ne_add + &, nx, ny + + integer (kind=int_kind) :: + & ncstat, ! netCDF status variable + & nc_grid1_id, ! netCDF grid file id + & nc_grid2_id, ! netCDF grid file id + & nc_grid1size_id, ! netCDF grid size dim id + & nc_grid2size_id, ! netCDF grid size dim id + & nc_grid1corn_id, ! netCDF grid corner dim id + & nc_grid2corn_id, ! netCDF grid corner dim id + & nc_grid1rank_id, ! netCDF grid rank dim id + & nc_grid2rank_id, ! netCDF grid rank dim id + & nc_grid1area_id, ! netCDF grid rank dim id + & nc_grid2area_id, ! netCDF grid rank dim id + & nc_grid1dims_id, ! netCDF grid dimension size id + & nc_grid2dims_id, ! netCDF grid dimension size id + & nc_grd1imask_id, ! netCDF grid imask var id + & nc_grd2imask_id, ! netCDF grid imask var id + & nc_grd1crnrlat_id, ! netCDF grid corner lat var id + & nc_grd2crnrlat_id, ! netCDF grid corner lat var id + & nc_grd1crnrlon_id, ! netCDF grid corner lon var id + & nc_grd2crnrlon_id, ! netCDF grid corner lon var id + & nc_grd1cntrlat_id, ! netCDF grid center lat var id + & nc_grd2cntrlat_id, ! netCDF grid center lat var id + & nc_grd1cntrlon_id, ! netCDF grid center lon var id + & nc_grd2cntrlon_id ! netCDF grid center lon var id + + integer (kind=int_kind), dimension(:), allocatable :: + & imask ! integer mask read from file + + real (kind=dbl_kind) :: + & dlat,dlon ! lat/lon intervals for search bins + + real (kind=dbl_kind), dimension(4) :: + & tmp_lats, tmp_lons ! temps for computing bounding boxes + +!----------------------------------------------------------------------- +! +! open grid files and read grid size/name data +! +!----------------------------------------------------------------------- + + ncstat = nf_open(grid1_file, NF_NOWRITE, nc_grid1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_open(grid2_file, NF_NOWRITE, nc_grid2_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id, 'grid_size', nc_grid1size_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id, nc_grid1size_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id, 'grid_size', nc_grid2size_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id, nc_grid2size_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id, 'grid_rank', nc_grid1rank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id, nc_grid1rank_id, grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id, 'grid_rank', nc_grid2rank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id, nc_grid2rank_id, grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id,'grid_corners',nc_grid1corn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id,nc_grid1corn_id,grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id,'grid_corners',nc_grid2corn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id,nc_grid2corn_id,grid2_corners) + call netcdf_error_handler(ncstat) + + allocate( grid1_dims(grid1_rank), + & grid2_dims(grid2_rank)) + + ncstat = nf_get_att_text(nc_grid1_id, nf_global, 'title', + & grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_grid2_id, nf_global, 'title', + & grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! allocate grid coordinates/masks and read data +! +!----------------------------------------------------------------------- + + allocate( grid1_mask (grid1_size), + & grid2_mask (grid2_size), + & grid1_center_lat(grid1_size), + & grid1_center_lon(grid1_size), + & grid2_center_lat(grid2_size), + & grid2_center_lon(grid2_size), + & grid1_area (grid1_size), + & grid2_area (grid2_size), + & grid1_frac (grid1_size), + & grid2_frac (grid2_size), + & grid1_corner_lat(grid1_corners, grid1_size), + & grid1_corner_lon(grid1_corners, grid1_size), + & grid2_corner_lat(grid2_corners, grid2_size), + & grid2_corner_lon(grid2_corners, grid2_size), + & grid1_bound_box (4 , grid1_size), + & grid2_bound_box (4 , grid2_size)) + + allocate(imask(grid1_size)) + + ncstat = nf_inq_varid(nc_grid1_id, 'grid_dims', nc_grid1dims_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_imask', nc_grd1imask_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_center_lat', + & nc_grd1cntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_center_lon', + & nc_grd1cntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_corner_lat', + & nc_grd1crnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_corner_lon', + & nc_grd1crnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid1_id, nc_grid1dims_id, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid1_id, nc_grd1imask_id, imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1cntrlat_id, + & grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1cntrlon_id, + & grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1crnrlat_id, + & grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1crnrlon_id, + & grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (luse_grid1_area) then + allocate (grid1_area_in(grid1_size)) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_area', nc_grid1area_id) + call netcdf_error_handler(ncstat) + ncstat = nf_get_var_double(nc_grid1_id, nc_grid1area_id, + & grid1_area_in) + call netcdf_error_handler(ncstat) + endif + + grid1_area = zero + grid1_frac = zero + +!----------------------------------------------------------------------- +! +! initialize logical mask and convert lat/lon units if required +! +!----------------------------------------------------------------------- + + where (imask == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + deallocate(imask) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_grid1_id, nc_grd1cntrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + + end select + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_grid1_id, nc_grd1crnrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + + end select + + ncstat = nf_close(nc_grid1_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! read data for grid 2 +! +!----------------------------------------------------------------------- + + allocate(imask(grid2_size)) + + ncstat = nf_inq_varid(nc_grid2_id, 'grid_dims', nc_grid2dims_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_imask', nc_grd2imask_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_center_lat', + & nc_grd2cntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_center_lon', + & nc_grd2cntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_corner_lat', + & nc_grd2crnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_corner_lon', + & nc_grd2crnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid2_id, nc_grid2dims_id, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid2_id, nc_grd2imask_id, imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2cntrlat_id, + & grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2cntrlon_id, + & grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2crnrlat_id, + & grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2crnrlon_id, + & grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + allocate (grid2_area_in(grid2_size)) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_area', nc_grid2area_id) + call netcdf_error_handler(ncstat) + ncstat = nf_get_var_double(nc_grid2_id, nc_grid2area_id, + & grid2_area_in) + call netcdf_error_handler(ncstat) + endif + + grid2_area = zero + grid2_frac = zero + +!----------------------------------------------------------------------- +! +! initialize logical mask and convert lat/lon units if required +! +!----------------------------------------------------------------------- + + where (imask == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(imask) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_grid2_id, nc_grd2cntrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + + end select + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_grid2_id, nc_grd2crnrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'no units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + + end select + + ncstat = nf_close(nc_grid2_id) + call netcdf_error_handler(ncstat) + + +!----------------------------------------------------------------------- +! +! convert longitudes to 0,2pi interval +! +!----------------------------------------------------------------------- + + where (grid1_center_lon .gt. pi2) grid1_center_lon = + & grid1_center_lon - pi2 + where (grid1_center_lon .lt. zero) grid1_center_lon = + & grid1_center_lon + pi2 + where (grid2_center_lon .gt. pi2) grid2_center_lon = + & grid2_center_lon - pi2 + where (grid2_center_lon .lt. zero) grid2_center_lon = + & grid2_center_lon + pi2 + where (grid1_corner_lon .gt. pi2) grid1_corner_lon = + & grid1_corner_lon - pi2 + where (grid1_corner_lon .lt. zero) grid1_corner_lon = + & grid1_corner_lon + pi2 + where (grid2_corner_lon .gt. pi2) grid2_corner_lon = + & grid2_corner_lon - pi2 + where (grid2_corner_lon .lt. zero) grid2_corner_lon = + & grid2_corner_lon + pi2 + +!----------------------------------------------------------------------- +! +! make sure input latitude range is within the machine values +! for +/- pi/2 +! +!----------------------------------------------------------------------- + + where (grid1_center_lat > pih) grid1_center_lat = pih + where (grid1_corner_lat > pih) grid1_corner_lat = pih + where (grid1_center_lat < -pih) grid1_center_lat = -pih + where (grid1_corner_lat < -pih) grid1_corner_lat = -pih + + where (grid2_center_lat > pih) grid2_center_lat = pih + where (grid2_corner_lat > pih) grid2_corner_lat = pih + where (grid2_center_lat < -pih) grid2_center_lat = -pih + where (grid2_corner_lat < -pih) grid2_corner_lat = -pih + +!----------------------------------------------------------------------- +! +! compute bounding boxes for restricting future grid searches +! +!----------------------------------------------------------------------- + + if (.not. luse_grid_centers) then + grid1_bound_box(1,:) = minval(grid1_corner_lat, DIM=1) + grid1_bound_box(2,:) = maxval(grid1_corner_lat, DIM=1) + grid1_bound_box(3,:) = minval(grid1_corner_lon, DIM=1) + grid1_bound_box(4,:) = maxval(grid1_corner_lon, DIM=1) + + grid2_bound_box(1,:) = minval(grid2_corner_lat, DIM=1) + grid2_bound_box(2,:) = maxval(grid2_corner_lat, DIM=1) + grid2_bound_box(3,:) = minval(grid2_corner_lon, DIM=1) + grid2_bound_box(4,:) = maxval(grid2_corner_lon, DIM=1) + + else + + nx = grid1_dims(1) + ny = grid1_dims(2) + + do n=1,grid1_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + if (abs(grid1_center_lat(e_add) - + & grid1_center_lat(n )) > pih) then + ip1 = i + endif + endif + + if (j < ny) then + jp1 = j+1 + else + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + if (abs(grid1_center_lat(n_add) - + & grid1_center_lat(n )) > pih) then + jp1 = j + endif + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid1_center_lat(n) + tmp_lats(2) = grid1_center_lat(e_add) + tmp_lats(3) = grid1_center_lat(ne_add) + tmp_lats(4) = grid1_center_lat(n_add) + + tmp_lons(1) = grid1_center_lon(n) + tmp_lons(2) = grid1_center_lon(e_add) + tmp_lons(3) = grid1_center_lon(ne_add) + tmp_lons(4) = grid1_center_lon(n_add) + + grid1_bound_box(1,n) = minval(tmp_lats) + grid1_bound_box(2,n) = maxval(tmp_lats) + grid1_bound_box(3,n) = minval(tmp_lons) + grid1_bound_box(4,n) = maxval(tmp_lons) + end do + + nx = grid2_dims(1) + ny = grid2_dims(2) + + do n=1,grid2_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + if (abs(grid2_center_lat(e_add) - + & grid2_center_lat(n )) > pih) then + ip1 = i + endif + endif + + if (j < ny) then + jp1 = j+1 + else + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + if (abs(grid2_center_lat(n_add) - + & grid2_center_lat(n )) > pih) then + jp1 = j + endif + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid2_center_lat(n) + tmp_lats(2) = grid2_center_lat(e_add) + tmp_lats(3) = grid2_center_lat(ne_add) + tmp_lats(4) = grid2_center_lat(n_add) + + tmp_lons(1) = grid2_center_lon(n) + tmp_lons(2) = grid2_center_lon(e_add) + tmp_lons(3) = grid2_center_lon(ne_add) + tmp_lons(4) = grid2_center_lon(n_add) + + grid2_bound_box(1,n) = minval(tmp_lats) + grid2_bound_box(2,n) = maxval(tmp_lats) + grid2_bound_box(3,n) = minval(tmp_lons) + grid2_bound_box(4,n) = maxval(tmp_lons) + end do + + endif + + where (abs(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) + grid1_bound_box(3,:) = zero + grid1_bound_box(4,:) = pi2 + end where + + where (abs(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) + grid2_bound_box(3,:) = zero + grid2_bound_box(4,:) = pi2 + end where + + !*** + !*** try to check for cells that overlap poles + !*** + + where (grid1_center_lat > grid1_bound_box(2,:)) + & grid1_bound_box(2,:) = pih + + where (grid1_center_lat < grid1_bound_box(1,:)) + & grid1_bound_box(1,:) = -pih + + where (grid2_center_lat > grid2_bound_box(2,:)) + & grid2_bound_box(2,:) = pih + + where (grid2_center_lat < grid2_bound_box(1,:)) + & grid2_bound_box(1,:) = -pih + +!----------------------------------------------------------------------- +! +! set up and assign address ranges to search bins in order to +! further restrict later searches +! +!----------------------------------------------------------------------- + + select case (restrict_type) + + case ('latitude') + write(stdout,*) 'Using latitude bins to restrict search.' + + allocate(bin_addr1(2,num_srch_bins)) + allocate(bin_addr2(2,num_srch_bins)) + allocate(bin_lats (2,num_srch_bins)) + allocate(bin_lons (2,num_srch_bins)) + + dlat = pi/num_srch_bins + + do n=1,num_srch_bins + bin_lats(1,n) = (n-1)*dlat - pih + bin_lats(2,n) = n*dlat - pih + bin_lons(1,n) = zero + bin_lons(2,n) = pi2 + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + end do + + do nele=1,grid1_size + do n=1,num_srch_bins + if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and. + & grid1_bound_box(2,nele) >= bin_lats(1,n)) then + bin_addr1(1,n) = min(nele,bin_addr1(1,n)) + bin_addr1(2,n) = max(nele,bin_addr1(2,n)) + endif + end do + end do + + do nele=1,grid2_size + do n=1,num_srch_bins + if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and. + & grid2_bound_box(2,nele) >= bin_lats(1,n)) then + bin_addr2(1,n) = min(nele,bin_addr2(1,n)) + bin_addr2(2,n) = max(nele,bin_addr2(2,n)) + endif + end do + end do + + case ('latlon') + write(stdout,*) 'Using lat/lon boxes to restrict search.' + + dlat = pi /num_srch_bins + dlon = pi2/num_srch_bins + + allocate(bin_addr1(2,num_srch_bins*num_srch_bins)) + allocate(bin_addr2(2,num_srch_bins*num_srch_bins)) + allocate(bin_lats (2,num_srch_bins*num_srch_bins)) + allocate(bin_lons (2,num_srch_bins*num_srch_bins)) + + n = 0 + do j=1,num_srch_bins + do i=1,num_srch_bins + n = n + 1 + + bin_lats(1,n) = (j-1)*dlat - pih + bin_lats(2,n) = j*dlat - pih + bin_lons(1,n) = (i-1)*dlon + bin_lons(2,n) = i*dlon + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + end do + end do + + num_srch_bins = num_srch_bins**2 + + do nele=1,grid1_size + do n=1,num_srch_bins + if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and. + & grid1_bound_box(2,nele) >= bin_lats(1,n) .and. + & grid1_bound_box(3,nele) <= bin_lons(2,n) .and. + & grid1_bound_box(4,nele) >= bin_lons(1,n)) then + bin_addr1(1,n) = min(nele,bin_addr1(1,n)) + bin_addr1(2,n) = max(nele,bin_addr1(2,n)) + endif + end do + end do + + do nele=1,grid2_size + do n=1,num_srch_bins + if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and. + & grid2_bound_box(2,nele) >= bin_lats(1,n) .and. + & grid2_bound_box(3,nele) <= bin_lons(2,n) .and. + & grid2_bound_box(4,nele) >= bin_lons(1,n)) then + bin_addr2(1,n) = min(nele,bin_addr2(1,n)) + bin_addr2(2,n) = max(nele,bin_addr2(2,n)) + endif + end do + end do + + case default + stop 'unknown search restriction method' + end select + +!----------------------------------------------------------------------- + + end subroutine grid_init + +!*********************************************************************** + + end module grids + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/iounits.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/iounits.f new file mode 100644 index 0000000000000000000000000000000000000000..ab00c31958b2bcaabb70d7384bdbe053c974c0c4 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/iounits.f @@ -0,0 +1,154 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module is a dynamic I/O unit manager. It keeps track of +! which units are in use and reserves units for stdin, stdout, and +! stderr. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: iounits.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module iounits + +!----------------------------------------------------------------------- + + use kinds_mod ! defines data types + + implicit none + +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(99), save :: + & unit_free ! flags to determine whether unit is free for use + + integer (kind=int_kind), parameter :: + & stdin = 5, ! reserves unit for standard input + & stdout = 6, ! reserves unit for standard output + & stderr = 6 ! reserves unit for standard error + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine get_unit(iunit) + +!----------------------------------------------------------------------- +! +! This routine returns the next available I/O unit number. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(out) :: + & iunit ! next free I/O unit + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n + + logical (kind=log_kind), save :: first_call = .true. + +!----------------------------------------------------------------------- +! +! if this is the first call, reserve stdout, stdin and stderr +! +!----------------------------------------------------------------------- + + if (first_call) then + unit_free = .true. + unit_free(stdin) = .false. + unit_free(stdout) = .false. + unit_free(stderr) = .false. + first_call = .false. + endif + +!----------------------------------------------------------------------- +! +! search for next available unit +! +!----------------------------------------------------------------------- + + srch_unit: do n=1,99 + if (unit_free(n)) then + iunit = n + unit_free(n) = .false. + exit srch_unit + endif + end do srch_unit + +!----------------------------------------------------------------------- + + end subroutine get_unit + +!*********************************************************************** + + subroutine release_unit(iunit) + +!----------------------------------------------------------------------- +! +! This routine releases the specified unit and closes the file. +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & iunit ! I/O unit to release + +!----------------------------------------------------------------------- +! +! closes I/O unit and declares it free +! +!----------------------------------------------------------------------- + + unit_free(iunit) = .true. + close(iunit) + +!----------------------------------------------------------------------- + + end subroutine release_unit + +!*********************************************************************** + + end module iounits + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/kinds_mod.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/kinds_mod.f new file mode 100644 index 0000000000000000000000000000000000000000..d9538dd0b8839316ed55fa24ccb48a2d1b13de7b --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/kinds_mod.f @@ -0,0 +1,53 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module defines the F90 kind parameter for common data types. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: kinds_mod.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module kinds_mod + +!----------------------------------------------------------------------- + + implicit none + save + +!----------------------------------------------------------------------- + + integer, parameter :: char_len = 80, + & int_kind = kind(1), + & log_kind = kind(.true.), + & real_kind = selected_real_kind(6), + & dbl_kind = selected_real_kind(13) + +!----------------------------------------------------------------------- + + end module kinds_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/makefile b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/makefile new file mode 100644 index 0000000000000000000000000000000000000000..55e544385b202ee49db1a9e1940655b5413fe84a --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/makefile @@ -0,0 +1,122 @@ +#!/bin/csh +# +# Makefile for interpolation code +# +# CVS:$Id: makefile,v 1.7 2000/04/19 21:46:44 pwjones Exp $ +# +#COMPILE = xlf +COMPILE = f90 +FLAGS = -O3 -r10000 -64 -I/usr/local/include +#FLAGS = -g -DEBUG:div_check=3:subscript_check=ON:trap_uninitialized=ON:verbose_runtime=ON -r10000 -64 -I/usr/local/include +LIB = -lnetcdf +INCLUDE = +SRCDIR = . +EXEDIR = .. +OBJSET = \ + kinds_mod.o \ + constants.o \ + iounits.o \ + netcdf.o \ + grids.o \ + remap_vars.o \ + remap_distwgt.o \ + remap_conserv.o \ + remap_bilinear.o \ + remap_bicubic.o \ + timers.o \ + remap_write.o \ + scrip.o + +OBJTEST = \ + kinds_mod.o \ + constants.o \ + iounits.o \ + netcdf.o \ + grids.o \ + timers.o \ + remap_vars.o \ + remap_read.o \ + remap.o + +all: $(EXEDIR)/scrip $(EXEDIR)/scrip_test + +$(EXEDIR)/scrip: $(OBJSET) + $(COMPILE) $(FLAGS) $(OBJSET) $(LIB) -o $(EXEDIR)/scrip + +$(EXEDIR)/scrip_test: $(OBJTEST) scrip_test.o + $(COMPILE) $(FLAGS) $(OBJTEST) scrip_test.o $(LIB) \ + -o $(EXEDIR)/scrip_test + +scrip_test_repeat: $(OBJTEST) scrip_test_repeat.o + $(COMPILE) $(FLAGS) $(OBJTEST) scrip_test_repeat.o $(LIB) \ + -o $(EXEDIR)/scrip_test_repeat + +kinds_mod.o: $(SRCDIR)/kinds_mod.f $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/kinds_mod.f + +constants.o: $(SRCDIR)/constants.f kinds_mod.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/constants.f + +iounits.o: $(SRCDIR)/iounits.f kinds_mod.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/iounits.f + +netcdf.o: $(SRCDIR)/netcdf.f kinds_mod.o constants.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/netcdf.f + +grids.o: $(SRCDIR)/grids.f kinds_mod.o constants.o iounits.o netcdf.o \ + $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/grids.f + +remap_vars.o: $(SRCDIR)/remap_vars.f kinds_mod.o constants.o grids.o \ + $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_vars.f + +remap_conserv.o: $(SRCDIR)/remap_conserv.f kinds_mod.o constants.o \ + timers.o remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_conserv.f + +remap_distwgt.o: $(SRCDIR)/remap_distwgt.f kinds_mod.o constants.o \ + remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_distwgt.f + +remap_bilinear.o: $(SRCDIR)/remap_bilinear.f kinds_mod.o constants.o \ + remap_vars.o grids.o timers.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_bilinear.f + +remap_bicubic.o: $(SRCDIR)/remap_bicubic.f kinds_mod.o constants.o \ + remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_bicubic.f + +timers.o: $(SRCDIR)/timers.f kinds_mod.o constants.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/timers.f + +remap_write.o: $(SRCDIR)/remap_write.f kinds_mod.o constants.o \ + netcdf.o remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_write.f + +remap_read.o: $(SRCDIR)/remap_read.f kinds_mod.o constants.o netcdf.o \ + remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap_read.f + +remap.o: $(SRCDIR)/remap.f kinds_mod.o constants.o + $(COMPILE) $(FLAGS) -c $(SRCDIR)/remap.f + +scrip.o: $(SRCDIR)/scrip.f kinds_mod.o constants.o iounits.o timers.o \ + remap_vars.o grids.o remap_conserv.o remap_distwgt.o \ + remap_bilinear.o remap_bicubic.o remap_write.o \ + $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/scrip.f + +scrip_test.o: $(SRCDIR)/scrip_test.f kinds_mod.o constants.o iounits.o \ + netcdf.o remap_vars.o grids.o remap.o remap_read.o \ + $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/scrip_test.f + +scrip_test_repeat.o: $(SRCDIR)/scrip_test_repeat.f kinds_mod.o \ + constants.o netcdf.o \ + iounits.o remap_vars.o grids.o $(INCLUDE) + $(COMPILE) $(FLAGS) -c $(SRCDIR)/scrip_test_repeat.f + +clean: + /bin/rm *.o *.mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/netcdf.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/netcdf.f new file mode 100644 index 0000000000000000000000000000000000000000..dd6da0e1c760254408aa73c2b8dd01e958c9e5ce --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/netcdf.f @@ -0,0 +1,79 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains the netCDF include file and a netcdf error +! handling routine. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: netcdf.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module netcdf_mod + +!----------------------------------------------------------------------- + + use kinds_mod + use constants + + implicit none + + include 'netcdf.inc' + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine netcdf_error_handler(istat) + +!----------------------------------------------------------------------- +! +! This routine provides a simple interface to netCDF error message +! routine. +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & istat ! integer status returned by netCDF function call + +!----------------------------------------------------------------------- + + if (istat /= NF_NOERR) then + print *,'Error in netCDF: ',nf_strerror(istat) + stop + endif + +!----------------------------------------------------------------------- + + end subroutine netcdf_error_handler + +!*********************************************************************** + + end module netcdf_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap.f new file mode 100644 index 0000000000000000000000000000000000000000..1cee1c407ad9dbca284eb673db4cfec62d19e6ea --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap.f @@ -0,0 +1,165 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this routine performs a remapping based on addresses and weights +! computed in a setup phase +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap.f,v 1.5 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_mod + +!----------------------------------------------------------------------- +! +! this module contains the routines for performing the actual +! remappings +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + + implicit none + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap(dst_array, map_wts, dst_add, src_add, + & src_array, src_grad1, src_grad2, src_grad3) + +!----------------------------------------------------------------------- +! +! performs the remapping based on weights computed elsewhere +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input arrays +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(:), intent(in) :: + & dst_add, ! destination address for each link + & src_add ! source address for each link + + real (kind=dbl_kind), dimension(:,:), intent(in) :: + & map_wts ! remapping weights for each link + + real (kind=dbl_kind), dimension(:), intent(in) :: + & src_array ! array with source field to be remapped + + real (kind=dbl_kind), dimension(:), intent(in), optional :: + & src_grad1 ! gradient arrays on source grid necessary for + &, src_grad2 ! higher-order remappings + &, src_grad3 + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), dimension(:), intent(inout) :: + & dst_array ! array for remapped field on destination grid + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, iorder + +!----------------------------------------------------------------------- +! +! check the order of the interpolation +! +!----------------------------------------------------------------------- + + if (present(src_grad1)) then + iorder = 2 + else + iorder = 1 + endif + +!----------------------------------------------------------------------- +! +! first order remapping +! +!----------------------------------------------------------------------- + + dst_array = zero + + select case (iorder) + case(1) + + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + + & src_array(src_add(n))*map_wts(1,n) + end do + +!----------------------------------------------------------------------- +! +! second order remapping +! +!----------------------------------------------------------------------- + + case(2) + + if (size(map_wts,DIM=1) == 3) then + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + + & src_array(src_add(n))*map_wts(1,n) + + & src_grad1(src_add(n))*map_wts(2,n) + + & src_grad2(src_add(n))*map_wts(3,n) + end do + else if (size(map_wts,DIM=1) == 4) then + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + + & src_array(src_add(n))*map_wts(1,n) + + & src_grad1(src_add(n))*map_wts(2,n) + + & src_grad2(src_add(n))*map_wts(3,n) + + & src_grad3(src_add(n))*map_wts(4,n) + end do + endif + + end select + +!----------------------------------------------------------------------- + + end subroutine remap + +!*********************************************************************** + + end module remap_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bicubic.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bicubic.f new file mode 100644 index 0000000000000000000000000000000000000000..1a4adb7d8a07416664fa47001a180cba6ad6f462 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bicubic.f @@ -0,0 +1,844 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! bicubic interpolation. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_bicubic.f,v 1.5 2001/08/22 18:20:41 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_bicubic + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & max_iter = 100 ! max iteration count for i,j iteration + + real (kind=dbl_kind), parameter :: + & converge = 1.e-10_dbl_kind ! convergence criterion + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_bicub + +!----------------------------------------------------------------------- +! +! this routine computes the weights for a bicubic interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n,icount, + & dst_add, ! destination address + & iter, ! iteration counter + & nmap ! index of current map being computed + + integer (kind=int_kind), dimension(4) :: + & src_add ! address for the four source points + + real (kind=dbl_kind), dimension(4) :: + & src_lats, ! latitudes of four bilinear corners + & src_lons ! longitudes of four bilinear corners + + real (kind=dbl_kind), dimension(4,4) :: + & wgts ! bicubic weights for four corners + + real (kind=dbl_kind) :: + & plat, plon, ! lat/lon coords of destination point + & iguess, jguess, ! current guess for bilinear coordinate + & thguess, phguess, ! current guess for lat/lon coordinate + & deli, delj, ! corrections to i,j + & dth1, dth2, dth3, ! some latitude differences + & dph1, dph2, dph3, ! some longitude differences + & dthp, dphp, ! difference between point and sw corner + & mat1, mat2, mat3, mat4, ! matrix elements + & determinant, ! matrix determinant + & sum_wgts, ! sum of weights for normalization + & w1,w2,w3,w4,w5,w6,w7,w8, ! 16 bicubic weight functions + & w9,w10,w11,w12,w13,w14,w15,w16 + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + if (grid1_rank /= 2) then + stop 'Can not do bicubic interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + +!----------------------------------------------------------------------- +! +! find nearest square of grid points on source grid +! +!----------------------------------------------------------------------- + + call grid_search_bicub(src_add, src_lats, src_lons, + & plat, plon, grid1_dims, + & grid1_center_lat, grid1_center_lon, + & grid1_bound_box, bin_addr1, bin_addr2) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid1_mask(src_add(n))) src_add(1) = 0 + end do + endif + +!----------------------------------------------------------------------- +! +! if point found, find local i,j coordinates for weights +! +!----------------------------------------------------------------------- + + if (src_add(1) > 0) then + + grid2_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bicubic approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > three*pih) dph1 = dph1 - pi2 + if (dph2 > three*pih) dph2 = dph2 - pi2 + if (dph3 > three*pih) dph3 = dph3 - pi2 + if (dph1 < -three*pih) dph1 = dph1 + pi2 + if (dph2 < -three*pih) dph2 = dph2 + pi2 + if (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = half + jguess = half + + iter_loop1: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - + & dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > three*pih) dphp = dphp - pi2 + if (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - + & dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. + & abs(delj) < converge) exit iter_loop1 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop1 + + if (iter <= max_iter) then + +!----------------------------------------------------------------------- +! +! successfully found i,j - compute weights +! +!----------------------------------------------------------------------- + + wgts(1,1) = (one - jguess**2*(three-two*jguess))* + & (one - iguess**2*(three-two*iguess)) + wgts(1,2) = (one - jguess**2*(three-two*jguess))* + & iguess**2*(three-two*iguess) + wgts(1,3) = jguess**2*(three-two*jguess)* + & iguess**2*(three-two*iguess) + wgts(1,4) = jguess**2*(three-two*jguess)* + & (one - iguess**2*(three-two*iguess)) + wgts(2,1) = (one - jguess**2*(three-two*jguess))* + & iguess*(iguess-one)**2 + wgts(2,2) = (one - jguess**2*(three-two*jguess))* + & iguess**2*(iguess-one) + wgts(2,3) = jguess**2*(three-two*jguess)* + & iguess**2*(iguess-one) + wgts(2,4) = jguess**2*(three-two*jguess)* + & iguess*(iguess-one)**2 + wgts(3,1) = jguess*(jguess-one)**2* + & (one - iguess**2*(three-two*iguess)) + wgts(3,2) = jguess*(jguess-one)**2* + & iguess**2*(three-two*iguess) + wgts(3,3) = jguess**2*(jguess-one)* + & iguess**2*(three-two*iguess) + wgts(3,4) = jguess**2*(jguess-one)* + & (one - iguess**2*(three-two*iguess)) + wgts(4,1) = iguess*(iguess-one)**2* + & jguess*(jguess-one)**2 + wgts(4,2) = iguess**2*(iguess-one)* + & jguess*(jguess-one)**2 + wgts(4,3) = iguess**2*(iguess-one)* + & jguess**2*(jguess-one) + wgts(4,4) = iguess*(iguess-one)**2* + & jguess**2*(jguess-one) + + call store_link_bicub(dst_add, src_add, wgts, nmap) + + else + stop 'Iteration for i,j exceed max iteration count' + endif + +!----------------------------------------------------------------------- +! +! search for bilinear failed - use a distance-weighted +! average instead (this is typically near the pole) +! +!----------------------------------------------------------------------- + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + + icount = 0 + do n=1,4 + if (grid1_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1,1) = src_lats(1)/sum_wgts + wgts(1,2) = src_lats(2)/sum_wgts + wgts(1,3) = src_lats(3)/sum_wgts + wgts(1,4) = src_lats(4)/sum_wgts + wgts(2:4,:) = zero + + grid2_frac(dst_add) = one + call store_link_bicub(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop1 + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + if (grid2_rank /= 2) then + stop 'Can not do bicubic interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + plat = grid1_center_lat(dst_add) + plon = grid1_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bicub(src_add, src_lats, src_lons, + & plat, plon, grid2_dims, + & grid2_center_lat, grid2_center_lon, + & grid2_bound_box, bin_addr2, bin_addr1) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid2_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid1_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > pi) dph1 = dph1 - pi2 + if (dph2 > pi) dph2 = dph2 - pi2 + if (dph3 > pi) dph3 = dph3 - pi2 + if (dph1 < -pi) dph1 = dph1 + pi2 + if (dph2 < -pi) dph2 = dph2 + pi2 + if (dph3 < -pi) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = zero + jguess = zero + + iter_loop2: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - + & dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > pi) dphp = dphp - pi2 + if (dphp < -pi) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - + & dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. + & abs(delj) < converge) exit iter_loop2 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop2 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1,1) = (one - jguess**2*(three-two*jguess))* + & (one - iguess**2*(three-two*iguess)) + wgts(1,2) = (one - jguess**2*(three-two*jguess))* + & iguess**2*(three-two*iguess) + wgts(1,3) = jguess**2*(three-two*jguess)* + & iguess**2*(three-two*iguess) + wgts(1,4) = jguess**2*(three-two*jguess)* + & (one - iguess**2*(three-two*iguess)) + wgts(2,1) = (one - jguess**2*(three-two*jguess))* + & iguess*(iguess-one)**2 + wgts(2,2) = (one - jguess**2*(three-two*jguess))* + & iguess**2*(iguess-one) + wgts(2,3) = jguess**2*(three-two*jguess)* + & iguess**2*(iguess-one) + wgts(2,4) = jguess**2*(three-two*jguess)* + & iguess*(iguess-one)**2 + wgts(3,1) = jguess*(jguess-one)**2* + & (one - iguess**2*(three-two*iguess)) + wgts(3,2) = jguess*(jguess-one)**2* + & iguess**2*(three-two*iguess) + wgts(3,3) = jguess**2*(jguess-one)* + & iguess**2*(three-two*iguess) + wgts(3,4) = jguess**2*(jguess-one)* + & (one - iguess**2*(three-two*iguess)) + wgts(4,1) = iguess*(iguess-one)**2* + & jguess*(jguess-one)**2 + wgts(4,2) = iguess**2*(iguess-one)* + & jguess*(jguess-one)**2 + wgts(4,3) = iguess**2*(iguess-one)* + & jguess**2*(jguess-one) + wgts(4,4) = iguess*(iguess-one)**2* + & jguess**2*(jguess-one) + + call store_link_bicub(dst_add, src_add, wgts, nmap) + + else + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - us a distance-weighted + !*** average instead + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + + icount = 0 + do n=1,4 + if (grid2_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1,1) = src_lats(1)/sum_wgts + wgts(1,2) = src_lats(2)/sum_wgts + wgts(1,3) = src_lats(3)/sum_wgts + wgts(1,4) = src_lats(4)/sum_wgts + wgts(2:4,:) = zero + + grid1_frac(dst_add) = one + call store_link_bicub(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop2 + + endif ! nmap=2 + +!----------------------------------------------------------------------- + + end subroutine remap_bicub + +!*********************************************************************** + + subroutine grid_search_bicub(src_add, src_lats, src_lons, + & plat, plon, src_grid_dims, + & src_center_lat, src_center_lon, + & src_bound_box, + & src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the location of the search point plat, plon +! in the source grid and returns the corners needed for a bicubic +! interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(4), intent(out) :: + & src_add ! address of each corner point enclosing P + + real (kind=dbl_kind), dimension(4), intent(out) :: + & src_lats, ! latitudes of the four corner points + & src_lons ! longitudes of the four corner points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: + & plat, ! latitude of the search point + & plon ! longitude of the search point + + integer (kind=int_kind), dimension(2), intent(in) :: + & src_grid_dims ! size of each src grid dimension + + real (kind=dbl_kind), dimension(:), intent(in) :: + & src_center_lat, ! latitude of each src grid center + & src_center_lon ! longitude of each src grid center + + real (kind=dbl_kind), dimension(:,:), intent(in) :: + & src_bound_box ! bounding box for src grid search + + integer (kind=int_kind), dimension(:,:), intent(in) :: + & src_bin_add, ! search bins for restricting + & dst_bin_add ! searches + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, srch_add, ! dummy indices + & nx, ny, ! dimensions of src grid + & min_add, max_add, ! addresses for restricting search + & i, j, jp1, ip1, n_add, e_add, ne_add ! addresses + + real (kind=dbl_kind) :: ! vectors for cross-product check + & vec1_lat, vec1_lon, + & vec2_lat, vec2_lon, cross_product, cross_product_last, + & coslat_dst, sinlat_dst, coslon_dst, sinlon_dst, + & dist_min, distance ! for computing dist-weighted avg + +!----------------------------------------------------------------------- +! +! restrict search first using search bins. +! +!----------------------------------------------------------------------- + + src_add = 0 + + min_add = size(src_center_lat) + max_add = 1 + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. + & plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then + min_add = min(min_add, src_bin_add(1,n)) + max_add = max(max_add, src_bin_add(2,n)) + endif + end do + +!----------------------------------------------------------------------- +! +! now perform a more detailed search +! +!----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + srch_loop: do srch_add = min_add,max_add + + if (plat <= src_bound_box(2,srch_add) .and. + & plat >= src_bound_box(1,srch_add) .and. + & plon <= src_bound_box(4,srch_add) .and. + & plon >= src_bound_box(3,srch_add)) then + + !*** + !*** we are within bounding box so get really serious + !*** + + !*** find N,S and NE points to this grid point + + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + ip1 = 1 + endif + + if (j < ny) then + jp1 = j+1 + else + jp1 = 1 + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** + !*** find N,S and NE lat/lon coords and check bounding box + !*** + + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + + vec1_lon = src_lons(1) - plon + if (vec1_lon > pi) then + src_lons(1) = src_lons(1) - pi2 + else if (vec1_lon < -pi) then + src_lons(1) = src_lons(1) + pi2 + endif + do n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + if (vec1_lon > pi) then + src_lons(n) = src_lons(n) - pi2 + else if (vec1_lon < -pi) then + src_lons(n) = src_lons(n) + pi2 + endif + end do + + corner_loop: do n=1,4 + next_n = MOD(n,4) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** same sign, the point is contained in the box. + !*** + + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > three*pih) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -three*pih) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > three*pih) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -three*pih) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (n==1) cross_product_last = cross_product + if (cross_product*cross_product_last < zero) then + exit corner_loop + else + cross_product_last = cross_product + endif + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > 4) then + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + + return + endif + + !*** + !*** otherwise move on to next cell + !*** + + endif !bounding box check + end do srch_loop + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + + coslat_dst = cos(plat) + sinlat_dst = sin(plat) + coslon_dst = cos(plon) + sinlon_dst = sin(plon) + + dist_min = bignum + src_lats = bignum + do srch_add = min_add,max_add + distance = acos(coslat_dst*cos(src_center_lat(srch_add))* + & (coslon_dst*cos(src_center_lon(srch_add)) + + & sinlon_dst*sin(src_center_lon(srch_add)))+ + & sinlat_dst*sin(src_center_lat(srch_add))) + + if (distance < dist_min) then + sort_loop: do n=1,4 + if (distance < src_lats(n)) then + do i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + end do + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + exit sort_loop + endif + end do sort_loop + endif + end do + + src_lons = one/(src_lats + tiny) + distance = sum(src_lons) + src_lats = src_lons/distance + +!----------------------------------------------------------------------- + + end subroutine grid_search_bicub + +!*********************************************************************** + + subroutine store_link_bicub(dst_add, src_add, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for four links +! associated with one destination point in the appropriate address +! and weight arrays and resizes those arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & dst_add, ! address on destination grid + & nmap ! identifies which direction for mapping + + integer (kind=int_kind), dimension(4), intent(in) :: + & src_add ! addresses on source grid + + real (kind=dbl_kind), dimension(4,4), intent(in) :: + & weights ! array of remapping weights for these links + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, ! dummy index + & num_links_old ! placeholder for old link number + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + if (num_links_map1 > max_links_map1) + & call resize_remap_vars(1,resize_increment) + + do n=1,4 + grid1_add_map1(num_links_old+n) = src_add(n) + grid2_add_map1(num_links_old+n) = dst_add + wts_map1 (:,num_links_old+n) = weights(:,n) + end do + + case(2) + + num_links_old = num_links_map2 + num_links_map2 = num_links_old + 4 + + if (num_links_map2 > max_links_map2) + & call resize_remap_vars(2,resize_increment) + + do n=1,4 + grid1_add_map2(num_links_old+n) = dst_add + grid2_add_map2(num_links_old+n) = src_add(n) + wts_map2 (:,num_links_old+n) = weights(:,n) + end do + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_bicub + +!*********************************************************************** + + end module remap_bicubic + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bilinear.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bilinear.f new file mode 100644 index 0000000000000000000000000000000000000000..b4fe1df1dd43473eb568f805860ed24c05b2f2e8 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_bilinear.f @@ -0,0 +1,781 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! bilinear interpolation. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_bilinear.f,v 1.6 2001/08/22 18:20:40 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_bilinear + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & max_iter = 100 ! max iteration count for i,j iteration + + real (kind=dbl_kind), parameter :: + & converge = 1.e-10_dbl_kind ! convergence criterion + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_bilin + +!----------------------------------------------------------------------- +! +! this routine computes the weights for a bilinear interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n,icount, + & dst_add, ! destination address + & iter, ! iteration counter + & nmap ! index of current map being computed + + integer (kind=int_kind), dimension(4) :: + & src_add ! address for the four source points + + real (kind=dbl_kind), dimension(4) :: + & src_lats, ! latitudes of four bilinear corners + & src_lons, ! longitudes of four bilinear corners + & wgts ! bilinear weights for four corners + + real (kind=dbl_kind) :: + & plat, plon, ! lat/lon coords of destination point + & iguess, jguess, ! current guess for bilinear coordinate + & thguess, phguess, ! current guess for lat/lon coordinate + & deli, delj, ! corrections to i,j + & dth1, dth2, dth3, ! some latitude differences + & dph1, dph2, dph3, ! some longitude differences + & dthp, dphp, ! difference between point and sw corner + & mat1, mat2, mat3, mat4, ! matrix elements + & determinant, ! matrix determinant + & sum_wgts ! sum of weights for normalization + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + if (grid1_rank /= 2) then + stop 'Can not do bilinear interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bilin(src_add, src_lats, src_lons, + & plat, plon, grid1_dims, + & grid1_center_lat, grid1_center_lon, + & grid1_bound_box, bin_addr1, bin_addr2) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid1_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find local i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid2_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > three*pih) dph1 = dph1 - pi2 + if (dph2 > three*pih) dph2 = dph2 - pi2 + if (dph3 > three*pih) dph3 = dph3 - pi2 + if (dph1 < -three*pih) dph1 = dph1 + pi2 + if (dph2 < -three*pih) dph2 = dph2 + pi2 + if (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = half + jguess = half + + iter_loop1: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - + & dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > three*pih) dphp = dphp - pi2 + if (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - + & dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. + & abs(delj) < converge) exit iter_loop1 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop1 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1) = (one-iguess)*(one-jguess) + wgts(2) = iguess*(one-jguess) + wgts(3) = iguess*jguess + wgts(4) = (one-iguess)*jguess + + call store_link_bilin(dst_add, src_add, wgts, nmap) + + else + print *,'Point coords: ',plat,plon + print *,'Dest grid lats: ',src_lats + print *,'Dest grid lons: ',src_lons + print *,'Dest grid addresses: ',src_add + print *,'Current i,j : ',iguess, jguess + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - use a distance-weighted + !*** average instead (this is typically near the pole) + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + icount = 0 + do n=1,4 + if (grid1_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1) = src_lats(1)/sum_wgts + wgts(2) = src_lats(2)/sum_wgts + wgts(3) = src_lats(3)/sum_wgts + wgts(4) = src_lats(4)/sum_wgts + + grid2_frac(dst_add) = one + call store_link_bilin(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop1 + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + if (grid2_rank /= 2) then + stop 'Can not do bilinear interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + plat = grid1_center_lat(dst_add) + plon = grid1_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bilin(src_add, src_lats, src_lons, + & plat, plon, grid2_dims, + & grid2_center_lat, grid2_center_lon, + & grid2_bound_box, bin_addr2, bin_addr1) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid2_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid1_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > pi) dph1 = dph1 - pi2 + if (dph2 > pi) dph2 = dph2 - pi2 + if (dph3 > pi) dph3 = dph3 - pi2 + if (dph1 < -pi) dph1 = dph1 + pi2 + if (dph2 < -pi) dph2 = dph2 + pi2 + if (dph3 < -pi) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = zero + jguess = zero + + iter_loop2: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - + & dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > pi) dphp = dphp - pi2 + if (dphp < -pi) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - + & dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. + & abs(delj) < converge) exit iter_loop2 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop2 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1) = (one-iguess)*(one-jguess) + wgts(2) = iguess*(one-jguess) + wgts(3) = iguess*jguess + wgts(4) = (one-iguess)*jguess + + call store_link_bilin(dst_add, src_add, wgts, nmap) + + else + print *,'Point coords: ',plat,plon + print *,'Dest grid lats: ',src_lats + print *,'Dest grid lons: ',src_lons + print *,'Dest grid addresses: ',src_add + print *,'Current i,j : ',iguess, jguess + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - us a distance-weighted + !*** average instead + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + icount = 0 + do n=1,4 + if (grid2_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1) = src_lats(1)/sum_wgts + wgts(2) = src_lats(2)/sum_wgts + wgts(3) = src_lats(3)/sum_wgts + wgts(4) = src_lats(4)/sum_wgts + + grid1_frac(dst_add) = one + call store_link_bilin(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop2 + + endif ! nmap=2 + +!----------------------------------------------------------------------- + + end subroutine remap_bilin + +!*********************************************************************** + + subroutine grid_search_bilin(src_add, src_lats, src_lons, + & plat, plon, src_grid_dims, + & src_center_lat, src_center_lon, + & src_grid_bound_box, + & src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the location of the search point plat, plon +! in the source grid and returns the corners needed for a bilinear +! interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(4), intent(out) :: + & src_add ! address of each corner point enclosing P + + real (kind=dbl_kind), dimension(4), intent(out) :: + & src_lats, ! latitudes of the four corner points + & src_lons ! longitudes of the four corner points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: + & plat, ! latitude of the search point + & plon ! longitude of the search point + + integer (kind=int_kind), dimension(2), intent(in) :: + & src_grid_dims ! size of each src grid dimension + + real (kind=dbl_kind), dimension(:), intent(in) :: + & src_center_lat, ! latitude of each src grid center + & src_center_lon ! longitude of each src grid center + + real (kind=dbl_kind), dimension(:,:), intent(in) :: + & src_grid_bound_box ! bound box for source grid + + integer (kind=int_kind), dimension(:,:), intent(in) :: + & src_bin_add, ! latitude bins for restricting + & dst_bin_add ! searches + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, srch_add, ! dummy indices + & nx, ny, ! dimensions of src grid + & min_add, max_add, ! addresses for restricting search + & i, j, jp1, ip1, n_add, e_add, ne_add ! addresses + + real (kind=dbl_kind) :: ! vectors for cross-product check + & vec1_lat, vec1_lon, + & vec2_lat, vec2_lon, cross_product, cross_product_last, + & coslat_dst, sinlat_dst, coslon_dst, sinlon_dst, + & dist_min, distance ! for computing dist-weighted avg + +!----------------------------------------------------------------------- +! +! restrict search first using bins +! +!----------------------------------------------------------------------- + + src_add = 0 + + min_add = size(src_center_lat) + max_add = 1 + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. + & plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then + min_add = min(min_add, src_bin_add(1,n)) + max_add = max(max_add, src_bin_add(2,n)) + endif + end do + +!----------------------------------------------------------------------- +! +! now perform a more detailed search +! +!----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + srch_loop: do srch_add = min_add,max_add + + !*** first check bounding box + + if (plat <= src_grid_bound_box(2,srch_add) .and. + & plat >= src_grid_bound_box(1,srch_add) .and. + & plon <= src_grid_bound_box(4,srch_add) .and. + & plon >= src_grid_bound_box(3,srch_add)) then + + !*** + !*** we are within bounding box so get really serious + !*** + + !*** determine neighbor addresses + + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + ip1 = 1 + endif + + if (j < ny) then + jp1 = j+1 + else + jp1 = 1 + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + + vec1_lon = src_lons(1) - plon + if (vec1_lon > pi) then + src_lons(1) = src_lons(1) - pi2 + else if (vec1_lon < -pi) then + src_lons(1) = src_lons(1) + pi2 + endif + do n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + if (vec1_lon > pi) then + src_lons(n) = src_lons(n) - pi2 + else if (vec1_lon < -pi) then + src_lons(n) = src_lons(n) + pi2 + endif + end do + + corner_loop: do n=1,4 + next_n = MOD(n,4) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the box. + !*** + + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > three*pih) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -three*pih) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > three*pih) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -three*pih) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (n == 1) cross_product_last = cross_product + if (cross_product*cross_product_last < zero) + & exit corner_loop + cross_product_last = cross_product + + end do corner_loop + + !*** + !*** if cross products all same sign, we found the location + !*** + + if (n > 4) then + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + + return + endif + + !*** + !*** otherwise move on to next cell + !*** + + endif !bounding box check + end do srch_loop + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + + !print *,'Could not find location for ',plat,plon + !print *,'Using nearest-neighbor average for this point' + + coslat_dst = cos(plat) + sinlat_dst = sin(plat) + coslon_dst = cos(plon) + sinlon_dst = sin(plon) + + dist_min = bignum + src_lats = bignum + do srch_add = min_add,max_add + distance = acos(coslat_dst*cos(src_center_lat(srch_add))* + & (coslon_dst*cos(src_center_lon(srch_add)) + + & sinlon_dst*sin(src_center_lon(srch_add)))+ + & sinlat_dst*sin(src_center_lat(srch_add))) + + if (distance < dist_min) then + sort_loop: do n=1,4 + if (distance < src_lats(n)) then + do i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + end do + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + exit sort_loop + endif + end do sort_loop + endif + end do + + src_lons = one/(src_lats + tiny) + distance = sum(src_lons) + src_lats = src_lons/distance + +!----------------------------------------------------------------------- + + end subroutine grid_search_bilin + +!*********************************************************************** + + subroutine store_link_bilin(dst_add, src_add, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for four links +! associated with one destination point in the appropriate address +! and weight arrays and resizes those arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & dst_add, ! address on destination grid + & nmap ! identifies which direction for mapping + + integer (kind=int_kind), dimension(4), intent(in) :: + & src_add ! addresses on source grid + + real (kind=dbl_kind), dimension(4), intent(in) :: + & weights ! array of remapping weights for these links + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, ! dummy index + & num_links_old ! placeholder for old link number + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + if (num_links_map1 > max_links_map1) + & call resize_remap_vars(1,resize_increment) + + do n=1,4 + grid1_add_map1(num_links_old+n) = src_add(n) + grid2_add_map1(num_links_old+n) = dst_add + wts_map1 (1,num_links_old+n) = weights(n) + end do + + case(2) + + num_links_old = num_links_map2 + num_links_map2 = num_links_old + 4 + + if (num_links_map2 > max_links_map2) + & call resize_remap_vars(2,resize_increment) + + do n=1,4 + grid1_add_map2(num_links_old+n) = dst_add + grid2_add_map2(num_links_old+n) = src_add(n) + wts_map2 (1,num_links_old+n) = weights(n) + end do + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_bilin + +!*********************************************************************** + + end module remap_bilinear + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_conserv.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_conserv.f new file mode 100644 index 0000000000000000000000000000000000000000..c40bb79ac51c4ab5a54aa53f371eadb661fc9d0a --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_conserv.f @@ -0,0 +1,2197 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for computing addresses +! and weights for a conservative interpolation between any two +! grids on a sphere. the weights are computed by performing line +! integrals around all overlap regions of the two grids. see +! Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and +! Jones, P.W. Monthly Weather Review (submitted). +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_conserv.f,v 1.10 2001/08/21 21:05:13 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_conservative + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use timers ! module for timing + use grids ! module containing grid information + use remap_vars ! module containing remap information + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), save :: + & num_srch_cells ! num cells in restricted search arrays + + integer (kind=int_kind), dimension(:), allocatable, save :: + & srch_add ! global address of cells in srch arrays + + real (kind=dbl_kind), parameter :: + & north_thresh = 1.45_dbl_kind, ! threshold for coord transf. + & south_thresh =-2.00_dbl_kind ! threshold for coord transf. + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: + & srch_corner_lat, ! lat of each corner of srch cells + & srch_corner_lon ! lon of each corner of srch cells + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_conserv + +!----------------------------------------------------------------------- +! +! this routine traces the perimeters of every grid cell on each +! grid checking for intersections with the other grid and computing +! line integrals for each subsegment. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & max_subseg = 10000 ! max number of subsegments per segment + ! to prevent infinite loop + + integer (kind=int_kind) :: + & grid1_add, ! current linear address for grid1 cell + & grid2_add, ! current linear address for grid2 cell + & min_add, ! addresses for restricting search of + & max_add, ! destination grid + & n, nwgt, ! generic counters + & corner, ! corner of cell that segment starts from + & next_corn, ! corner of cell that segment ends on + & num_subseg ! number of subsegments + + logical (kind=log_kind) :: + & lcoinc, ! flag for coincident segments + & lrevers, ! flag for reversing direction of segment + & lbegin ! flag for first integration of a segment + + logical (kind=log_kind), dimension(:), allocatable :: + & srch_mask ! mask for restricting searches + + real (kind=dbl_kind) :: + & intrsct_lat, intrsct_lon, ! lat/lon of next intersect + & beglat, endlat, beglon, endlon, ! endpoints of current seg. + & norm_factor ! factor for normalizing wts + + real (kind=dbl_kind), dimension(:), allocatable :: + & grid2_centroid_lat, grid2_centroid_lon, ! centroid coords + & grid1_centroid_lat, grid1_centroid_lon ! on each grid + + real (kind=dbl_kind), dimension(2) :: begseg ! begin lat/lon for + ! full segment + + real (kind=dbl_kind), dimension(6) :: weights ! local wgt array + +!----------------------------------------------------------------------- +! +! initialize centroid arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_centroid_lat(grid1_size), + & grid1_centroid_lon(grid1_size), + & grid2_centroid_lat(grid2_size), + & grid2_centroid_lon(grid2_size)) + + grid1_centroid_lat = zero + grid1_centroid_lon = zero + grid2_centroid_lat = zero + grid2_centroid_lon = zero + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid1 +! +!----------------------------------------------------------------------- + + allocate(srch_mask(grid2_size)) + + print *,'grid1 sweep ' + do grid1_add = 1,grid1_size + + !*** + !*** restrict searches first using search bins + !*** + + call timer_start(1) + min_add = grid2_size + max_add = 1 + do n=1,num_srch_bins + if (grid1_add >= bin_addr1(1,n) .and. + & grid1_add <= bin_addr1(2,n)) then + min_add = min(min_add, bin_addr2(1,n)) + max_add = max(max_add, bin_addr2(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells = 0 + do grid2_add = min_add,max_add + srch_mask(grid2_add) = (grid2_bound_box(1,grid2_add) <= + & grid1_bound_box(2,grid1_add)) .and. + & (grid2_bound_box(2,grid2_add) >= + & grid1_bound_box(1,grid1_add)) .and. + & (grid2_bound_box(3,grid2_add) <= + & grid1_bound_box(4,grid1_add)) .and. + & (grid2_bound_box(4,grid2_add) >= + & grid1_bound_box(3,grid1_add)) + + if (srch_mask(grid2_add)) num_srch_cells = num_srch_cells+1 + end do + + !*** + !*** create search arrays + !*** + + allocate(srch_add(num_srch_cells), + & srch_corner_lat(grid2_corners,num_srch_cells), + & srch_corner_lon(grid2_corners,num_srch_cells)) + + n = 0 + gather1: do grid2_add = min_add,max_add + if (srch_mask(grid2_add)) then + n = n+1 + srch_add(n) = grid2_add + srch_corner_lat(:,n) = grid2_corner_lat(:,grid2_add) + srch_corner_lon(:,n) = grid2_corner_lon(:,grid2_add) + endif + end do gather1 + call timer_stop(1) + + !*** + !*** integrate around this cell + !*** + + do corner = 1,grid1_corners + next_corn = mod(corner,grid1_corners) + 1 + + !*** + !*** define endpoints of the current segment + !*** + + beglat = grid1_corner_lat(corner,grid1_add) + beglon = grid1_corner_lon(corner,grid1_add) + endlat = grid1_corner_lat(next_corn,grid1_add) + endlon = grid1_corner_lon(next_corn,grid1_add) + lrevers = .false. + + !*** + !*** to ensure exact path taken during both + !*** sweeps, always integrate segments in the same + !*** direction (SW to NE). + !*** + + if ((endlat < beglat) .or. + & (endlat == beglat .and. endlon < beglon)) then + beglat = grid1_corner_lat(next_corn,grid1_add) + beglon = grid1_corner_lon(next_corn,grid1_add) + endlat = grid1_corner_lat(corner,grid1_add) + endlon = grid1_corner_lon(corner,grid1_add) + lrevers = .true. + endif + + begseg(1) = beglat + begseg(2) = beglon + lbegin = .true. + num_subseg = 0 + + !*** + !*** if this is a constant-longitude segment, skip the rest + !*** since the line integral contribution will be zero. + !*** + + if (endlon /= beglon) then + + !*** + !*** integrate along this segment, detecting intersections + !*** and computing the line integral for each sub-segment + !*** + + do while (beglat /= endlat .or. beglon /= endlon) + + !*** + !*** prevent infinite loops if integration gets stuck + !*** near cell or threshold boundary + !*** + + num_subseg = num_subseg + 1 + if (num_subseg > max_subseg) then + stop 'integration stalled: num_subseg exceeded limit' + endif + + !*** + !*** find next intersection of this segment with a grid + !*** line on grid 2. + !*** + + call timer_start(2) + call intersection(grid2_add,intrsct_lat,intrsct_lon,lcoinc, + & beglat, beglon, endlat, endlon, begseg, + & lbegin, lrevers) + call timer_stop(2) + lbegin = .false. + + !*** + !*** compute line integral for this subsegment. + !*** + + call timer_start(3) + if (grid2_add /= 0) then + call line_integral(weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & grid1_center_lat(grid1_add), + & grid1_center_lon(grid1_add), + & grid2_center_lat(grid2_add), + & grid2_center_lon(grid2_add)) + else + call line_integral(weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & grid1_center_lat(grid1_add), + & grid1_center_lon(grid1_add), + & grid1_center_lat(grid1_add), + & grid1_center_lon(grid1_add)) + endif + call timer_stop(3) + + !*** + !*** if integrating in reverse order, change + !*** sign of weights + !*** + + if (lrevers) then + weights = -weights + endif + + !*** + !*** store the appropriate addresses and weights. + !*** also add contributions to cell areas and centroids. + !*** + + !if (grid1_add == 119247) then + ! print *,grid1_add,grid2_add,corner,weights(1) + ! print *,grid1_corner_lat(:,grid1_add) + ! print *,grid1_corner_lon(:,grid1_add) + ! print *,grid2_corner_lat(:,grid2_add) + ! print *,grid2_corner_lon(:,grid2_add) + ! print *,beglat,beglon,intrsct_lat,intrsct_lon + !endif + + if (grid2_add /= 0) then + if (grid1_mask(grid1_add)) then + call timer_start(4) + call store_link_cnsrv(grid1_add, grid2_add, weights) + call timer_stop(4) + grid1_frac(grid1_add) = grid1_frac(grid1_add) + + & weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + + & weights(num_wts+1) + endif + + endif + + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = + & grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = + & grid1_centroid_lon(grid1_add) + weights(3) + + !*** + !*** reset beglat and beglon for next subsegment. + !*** + + beglat = intrsct_lat + beglon = intrsct_lon + end do + + endif + + !*** + !*** end of segment + !*** + + end do + + !*** + !*** finished with this cell: deallocate search array and + !*** start on next cell + + deallocate(srch_add, srch_corner_lat, srch_corner_lon) + + end do + + deallocate(srch_mask) + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid2 +! +!----------------------------------------------------------------------- + + allocate(srch_mask(grid1_size)) + + print *,'grid2 sweep ' + do grid2_add = 1,grid2_size + + !*** + !*** restrict searches first using search bins + !*** + + call timer_start(5) + min_add = grid1_size + max_add = 1 + do n=1,num_srch_bins + if (grid2_add >= bin_addr2(1,n) .and. + & grid2_add <= bin_addr2(2,n)) then + min_add = min(min_add, bin_addr1(1,n)) + max_add = max(max_add, bin_addr1(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells = 0 + do grid1_add = min_add, max_add + srch_mask(grid1_add) = (grid1_bound_box(1,grid1_add) <= + & grid2_bound_box(2,grid2_add)) .and. + & (grid1_bound_box(2,grid1_add) >= + & grid2_bound_box(1,grid2_add)) .and. + & (grid1_bound_box(3,grid1_add) <= + & grid2_bound_box(4,grid2_add)) .and. + & (grid1_bound_box(4,grid1_add) >= + & grid2_bound_box(3,grid2_add)) + + if (srch_mask(grid1_add)) num_srch_cells = num_srch_cells+1 + end do + + allocate(srch_add(num_srch_cells), + & srch_corner_lat(grid1_corners,num_srch_cells), + & srch_corner_lon(grid1_corners,num_srch_cells)) + + n = 0 + gather2: do grid1_add = min_add,max_add + if (srch_mask(grid1_add)) then + n = n+1 + srch_add(n) = grid1_add + srch_corner_lat(:,n) = grid1_corner_lat(:,grid1_add) + srch_corner_lon(:,n) = grid1_corner_lon(:,grid1_add) + endif + end do gather2 + call timer_stop(5) + + !*** + !*** integrate around this cell + !*** + + do corner = 1,grid2_corners + next_corn = mod(corner,grid2_corners) + 1 + + beglat = grid2_corner_lat(corner,grid2_add) + beglon = grid2_corner_lon(corner,grid2_add) + endlat = grid2_corner_lat(next_corn,grid2_add) + endlon = grid2_corner_lon(next_corn,grid2_add) + lrevers = .false. + + !*** + !*** to ensure exact path taken during both + !*** sweeps, always integrate in the same direction + !*** + + if ((endlat < beglat) .or. + & (endlat == beglat .and. endlon < beglon)) then + beglat = grid2_corner_lat(next_corn,grid2_add) + beglon = grid2_corner_lon(next_corn,grid2_add) + endlat = grid2_corner_lat(corner,grid2_add) + endlon = grid2_corner_lon(corner,grid2_add) + lrevers = .true. + endif + + begseg(1) = beglat + begseg(2) = beglon + lbegin = .true. + + !*** + !*** if this is a constant-longitude segment, skip the rest + !*** since the line integral contribution will be zero. + !*** + + if (endlon /= beglon) then + num_subseg = 0 + + !*** + !*** integrate along this segment, detecting intersections + !*** and computing the line integral for each sub-segment + !*** + + do while (beglat /= endlat .or. beglon /= endlon) + + !*** + !*** prevent infinite loops if integration gets stuck + !*** near cell or threshold boundary + !*** + + num_subseg = num_subseg + 1 + if (num_subseg > max_subseg) then + stop 'integration stalled: num_subseg exceeded limit' + endif + + !*** + !*** find next intersection of this segment with a line + !*** on grid 2. + !*** + + call timer_start(6) + call intersection(grid1_add,intrsct_lat,intrsct_lon,lcoinc, + & beglat, beglon, endlat, endlon, begseg, + & lbegin, lrevers) + call timer_stop(6) + lbegin = .false. + + !*** + !*** compute line integral for this subsegment. + !*** + + call timer_start(7) + if (grid1_add /= 0) then + call line_integral(weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & grid1_center_lat(grid1_add), + & grid1_center_lon(grid1_add), + & grid2_center_lat(grid2_add), + & grid2_center_lon(grid2_add)) + else + call line_integral(weights, num_wts, + & beglon, intrsct_lon, beglat, intrsct_lat, + & grid2_center_lat(grid2_add), + & grid2_center_lon(grid2_add), + & grid2_center_lat(grid2_add), + & grid2_center_lon(grid2_add)) + endif + call timer_stop(7) + + if (lrevers) then + weights = -weights + endif + + !*** + !*** store the appropriate addresses and weights. + !*** also add contributions to cell areas and centroids. + !*** if there is a coincidence, do not store weights + !*** because they have been captured in the previous loop. + !*** the grid1 mask is the master mask + !*** + + !if (grid1_add == 119247) then + ! print *,grid1_add,grid2_add,corner,weights(1) + ! print *,grid1_corner_lat(:,grid1_add) + ! print *,grid1_corner_lon(:,grid1_add) + ! print *,grid2_corner_lat(:,grid2_add) + ! print *,grid2_corner_lon(:,grid2_add) + ! print *,beglat,beglon,intrsct_lat,intrsct_lon + !endif + + if (.not. lcoinc .and. grid1_add /= 0) then + if (grid1_mask(grid1_add)) then + call timer_start(8) + call store_link_cnsrv(grid1_add, grid2_add, weights) + call timer_stop(8) + grid1_frac(grid1_add) = grid1_frac(grid1_add) + + & weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + + & weights(num_wts+1) + endif + + endif + + grid2_area(grid2_add) = grid2_area(grid2_add) + + & weights(num_wts+1) + grid2_centroid_lat(grid2_add) = + & grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = + & grid2_centroid_lon(grid2_add) + weights(num_wts+3) + + !*** + !*** reset beglat and beglon for next subsegment. + !*** + + beglat = intrsct_lat + beglon = intrsct_lon + end do + + endif + + !*** + !*** end of segment + !*** + + end do + + !*** + !*** finished with this cell: deallocate search array and + !*** start on next cell + + deallocate(srch_add, srch_corner_lat, srch_corner_lon) + + end do + + deallocate(srch_mask) + +!----------------------------------------------------------------------- +! +! correct for situations where N/S pole not explicitly included in +! grid (i.e. as a grid corner point). if pole is missing from only +! one grid, need to correct only the area and centroid of that +! grid. if missing from both, do complete weight calculation. +! +!----------------------------------------------------------------------- + + !*** North Pole + weights(1) = pi2 + weights(2) = pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = pi*pi + weights(6) = zero + + grid1_add = 0 + pole_loop1: do n=1,grid1_size + if (grid1_area(n) < -three*pih .and. + & grid1_center_lat(n) > zero) then + grid1_add = n + exit pole_loop1 + endif + end do pole_loop1 + + grid2_add = 0 + pole_loop2: do n=1,grid2_size + if (grid2_area(n) < -three*pih .and. + & grid2_center_lat(n) > zero) then + grid2_add = n + exit pole_loop2 + endif + end do pole_loop2 + + if (grid1_add /=0) then + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = + & grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = + & grid1_centroid_lon(grid1_add) + weights(3) + endif + + if (grid2_add /=0) then + grid2_area(grid2_add) = grid2_area(grid2_add) + + & weights(num_wts+1) + grid2_centroid_lat(grid2_add) = + & grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = + & grid2_centroid_lon(grid2_add) + weights(num_wts+3) + endif + + if (grid1_add /= 0 .and. grid2_add /=0) then + call store_link_cnsrv(grid1_add, grid2_add, weights) + + grid1_frac(grid1_add) = grid1_frac(grid1_add) + + & weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + + & weights(num_wts+1) + endif + + !*** South Pole + weights(1) = pi2 + weights(2) = -pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = -pi*pi + weights(6) = zero + + grid1_add = 0 + pole_loop3: do n=1,grid1_size + if (grid1_area(n) < -three*pih .and. + & grid1_center_lat(n) < zero) then + grid1_add = n + exit pole_loop3 + endif + end do pole_loop3 + + grid2_add = 0 + pole_loop4: do n=1,grid2_size + if (grid2_area(n) < -three*pih .and. + & grid2_center_lat(n) < zero) then + grid2_add = n + exit pole_loop4 + endif + end do pole_loop4 + + if (grid1_add /=0) then + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = + & grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = + & grid1_centroid_lon(grid1_add) + weights(3) + endif + + if (grid2_add /=0) then + grid2_area(grid2_add) = grid2_area(grid2_add) + + & weights(num_wts+1) + grid2_centroid_lat(grid2_add) = + & grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = + & grid2_centroid_lon(grid2_add) + weights(num_wts+3) + endif + + if (grid1_add /= 0 .and. grid2_add /=0) then + call store_link_cnsrv(grid1_add, grid2_add, weights) + + grid1_frac(grid1_add) = grid1_frac(grid1_add) + + & weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + + & weights(num_wts+1) + endif + +!----------------------------------------------------------------------- +! +! finish centroid computation +! +!----------------------------------------------------------------------- + + where (grid1_area /= zero) + grid1_centroid_lat = grid1_centroid_lat/grid1_area + grid1_centroid_lon = grid1_centroid_lon/grid1_area + end where + + where (grid2_area /= zero) + grid2_centroid_lat = grid2_centroid_lat/grid2_area + grid2_centroid_lon = grid2_centroid_lon/grid2_area + end where + +!----------------------------------------------------------------------- +! +! include centroids in weights and normalize using destination +! area if requested +! +!----------------------------------------------------------------------- + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + do nwgt=1,num_wts + weights( nwgt) = wts_map1(nwgt,n) + if (num_maps > 1) then + weights(num_wts+nwgt) = wts_map2(nwgt,n) + endif + end do + + select case(norm_opt) + case (norm_opt_dstarea) + if (grid2_area(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = one/grid2_area_in(grid2_add) + else + norm_factor = one/grid2_area(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid2_frac(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = grid2_area(grid2_add)/ + & (grid2_frac(grid2_add)* + & grid2_area_in(grid2_add)) + else + norm_factor = one/grid2_frac(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map1(1,n) = weights(1)*norm_factor + wts_map1(2,n) = (weights(2) - weights(1)* + & grid1_centroid_lat(grid1_add))* + & norm_factor + wts_map1(3,n) = (weights(3) - weights(1)* + & grid1_centroid_lon(grid1_add))* + & norm_factor + + if (num_maps > 1) then + select case(norm_opt) + case (norm_opt_dstarea) + if (grid1_area(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = one/grid1_area_in(grid1_add) + else + norm_factor = one/grid1_area(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid1_frac(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = grid1_area(grid1_add)/ + & (grid1_frac(grid1_add)* + & grid1_area_in(grid1_add)) + else + norm_factor = one/grid1_frac(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map2(1,n) = weights(num_wts+1)*norm_factor + wts_map2(2,n) = (weights(num_wts+2) - weights(num_wts+1)* + & grid2_centroid_lat(grid2_add))* + & norm_factor + wts_map2(3,n) = (weights(num_wts+3) - weights(num_wts+1)* + & grid2_centroid_lon(grid2_add))* + & norm_factor + endif + + end do + + print *, 'Total number of links = ',num_links_map1 + + where (grid1_area /= zero) grid1_frac = grid1_frac/grid1_area + where (grid2_area /= zero) grid2_frac = grid2_frac/grid2_area + +!----------------------------------------------------------------------- +! +! perform some error checking on final weights +! +!----------------------------------------------------------------------- + + grid2_centroid_lat = zero + grid2_centroid_lon = zero + + do n=1,grid1_size + if (grid1_area(n) < -.01) then + print *,'Grid 1 area error: ',n,grid1_area(n) + endif + if (grid1_centroid_lat(n) < -pih-.01 .or. + & grid1_centroid_lat(n) > pih+.01) then + print *,'Grid 1 centroid lat error: ',n,grid1_centroid_lat(n) + endif + grid1_centroid_lat(n) = zero + grid1_centroid_lon(n) = zero + end do + + do n=1,grid2_size + if (grid2_area(n) < -.01) then + print *,'Grid 2 area error: ',n,grid2_area(n) + endif + if (grid2_centroid_lat(n) < -pih-.01 .or. + & grid2_centroid_lat(n) > pih+.01) then + print *,'Grid 2 centroid lat error: ',n,grid2_centroid_lat(n) + endif + grid2_centroid_lat(n) = zero + grid2_centroid_lon(n) = zero + end do + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + + if (wts_map1(1,n) < -.01) then + print *,'Map 1 weight < 0 ',grid1_add,grid2_add,wts_map1(1,n) + endif + if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > 1.01) then + print *,'Map 1 weight > 1 ',grid1_add,grid2_add,wts_map1(1,n) + endif + grid2_centroid_lat(grid2_add) = + & grid2_centroid_lat(grid2_add) + wts_map1(1,n) + + if (num_maps > 1) then + if (wts_map2(1,n) < -.01) then + print *,'Map 2 weight < 0 ',grid1_add,grid2_add, + & wts_map2(1,n) + endif + if (norm_opt /= norm_opt_none .and. wts_map2(1,n) > 1.01) then + print *,'Map 2 weight < 0 ',grid1_add,grid2_add, + & wts_map2(1,n) + endif + grid1_centroid_lat(grid1_add) = + & grid1_centroid_lat(grid1_add) + wts_map2(1,n) + endif + end do + + do n=1,grid2_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid2_frac(grid2_add) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid2_area) then + norm_factor = grid2_area_in(grid2_add) + else + norm_factor = grid2_area(grid2_add) + endif + end select + if (abs(grid2_centroid_lat(grid2_add)-norm_factor) > .01) then + print *,'Error: sum of wts for map1 ',grid2_add, + & grid2_centroid_lat(grid2_add),norm_factor + endif + end do + + if (num_maps > 1) then + do n=1,grid1_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid1_frac(grid1_add) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid1_area) then + norm_factor = grid1_area_in(grid1_add) + else + norm_factor = grid1_area(grid1_add) + endif + end select + if (abs(grid1_centroid_lat(grid1_add)-norm_factor) > .01) then + print *,'Error: sum of wts for map2 ',grid1_add, + & grid1_centroid_lat(grid1_add),norm_factor + endif + end do + endif +!----------------------------------------------------------------------- + + end subroutine remap_conserv + +!*********************************************************************** + + subroutine intersection(location,intrsct_lat,intrsct_lon,lcoinc, + & beglat, beglon, endlat, endlon, begseg, + & lbegin, lrevers) + +!----------------------------------------------------------------------- +! +! this routine finds the next intersection of a destination grid +! line with the line segment given by beglon, endlon, etc. +! a coincidence flag is returned if the segment is entirely +! coincident with an ocean grid line. the cells in which to search +! for an intersection must have already been restricted in the +! calling routine. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), intent(in) :: + & lbegin, ! flag for first integration along this segment + & lrevers ! flag whether segment integrated in reverse + + real (kind=dbl_kind), intent(in) :: + & beglat, beglon, ! beginning lat/lon endpoints for segment + & endlat, endlon ! ending lat/lon endpoints for segment + + real (kind=dbl_kind), dimension(2), intent(inout) :: + & begseg ! begin lat/lon of full segment + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(out) :: + & location ! address in destination array containing this + ! segment + + logical (kind=log_kind), intent(out) :: + & lcoinc ! flag segments which are entirely coincident + ! with a grid line + + real (kind=dbl_kind), intent(out) :: + & intrsct_lat, intrsct_lon ! lat/lon coords of next intersect. + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, cell, srch_corners, pole_loc + + integer (kind=int_kind), save :: + & last_loc ! save location when crossing threshold + + logical (kind=log_kind) :: + & loutside ! flags points outside grid + + logical (kind=log_kind), save :: + & lthresh = .false. ! flags segments crossing threshold bndy + + real (kind=dbl_kind) :: + & lon1, lon2, ! local longitude variables for segment + & lat1, lat2, ! local latitude variables for segment + & grdlon1, grdlon2, ! local longitude variables for grid cell + & grdlat1, grdlat2, ! local latitude variables for grid cell + & vec1_lat, vec1_lon, ! vectors and cross products used + & vec2_lat, vec2_lon, ! during grid search + & cross_product, + & eps, offset, ! small offset away from intersect + & s1, s2, determ, ! variables used for linear solve to + & mat1, mat2, mat3, mat4, rhs1, rhs2 ! find intersection + + real (kind=dbl_kind), save :: + & intrsct_lat_off, intrsct_lon_off ! lat/lon coords offset + ! for next search + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + location = 0 + lcoinc = .false. + intrsct_lat = endlat + intrsct_lon = endlon + + if (num_srch_cells == 0) return + + if (beglat > north_thresh .or. beglat < south_thresh) then + + if (lthresh) location = last_loc + call pole_intersection(location, + & intrsct_lat,intrsct_lon,lcoinc,lthresh, + & beglat, beglon, endlat, endlon, begseg, lrevers) + if (lthresh) then + last_loc = location + intrsct_lat_off = intrsct_lat + intrsct_lon_off = intrsct_lon + endif + return + + endif + + loutside = .false. + if (lbegin) then + lat1 = beglat + lon1 = beglon + else + lat1 = intrsct_lat_off + lon1 = intrsct_lon_off + endif + lat2 = endlat + lon2 = endlon + if ((lon2-lon1) > three*pih) then + lon2 = lon2 - pi2 + else if ((lon2-lon1) < -three*pih) then + lon2 = lon2 + pi2 + endif + s1 = zero + +!----------------------------------------------------------------------- +! +! search for location of this segment in ocean grid using cross +! product method to determine whether a point is enclosed by a cell +! +!----------------------------------------------------------------------- + + call timer_start(12) + srch_corners = size(srch_corner_lat,DIM=1) + srch_loop: do + + !*** + !*** if last segment crossed threshold, use that location + !*** + + if (lthresh) then + do cell=1,num_srch_cells + if (srch_add(cell) == last_loc) then + location = last_loc + eps = tiny + exit srch_loop + endif + end do + endif + + !*** + !*** otherwise normal search algorithm + !*** + + cell_loop: do cell=1,num_srch_cells + corner_loop: do n=1,srch_corners + next_n = MOD(n,srch_corners) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each cell side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the cell. + !*** + + vec1_lat = srch_corner_lat(next_n,cell) - + & srch_corner_lat(n ,cell) + vec1_lon = srch_corner_lon(next_n,cell) - + & srch_corner_lon(n ,cell) + vec2_lat = lat1 - srch_corner_lat(n,cell) + vec2_lon = lon1 - srch_corner_lon(n,cell) + + !*** + !*** if endpoint coincident with vertex, offset + !*** the endpoint + !*** + + if (vec2_lat == 0 .and. vec2_lon == 0) then + lat1 = lat1 + 1.d-10*(lat2-lat1) + lon1 = lon1 + 1.d-10*(lon2-lon1) + vec2_lat = lat1 - srch_corner_lat(n,cell) + vec2_lon = lon1 - srch_corner_lon(n,cell) + endif + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. otherwise perform + !*** another cross product between the side and the + !*** segment itself. + !*** if this cross product is also zero, the line is + !*** coincident with the cell boundary - perform the + !*** dot product and only choose the cell if the dot + !*** product is positive (parallel vs anti-parallel). + !*** + + if (cross_product == zero) then + if (vec1_lat /= zero .or. vec1_lon /= zero) then + vec2_lat = lat2 - lat1 + vec2_lon = lon2 - lon1 + + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + else + cross_product = one + endif + + if (cross_product == zero) then + lcoinc = .true. + cross_product = vec1_lon*vec2_lon + vec1_lat*vec2_lat + if (lrevers) cross_product = -cross_product + endif + endif + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (cross_product < zero) exit corner_loop + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > srch_corners) then + location = srch_add(cell) + + !*** + !*** if the beginning of this segment was outside the + !*** grid, invert the segment so the intersection found + !*** will be the first intersection with the grid + !*** + + if (loutside) then + lat2 = beglat + lon2 = beglon + location = 0 + eps = -tiny + else + eps = tiny + endif + + exit srch_loop + endif + + !*** + !*** otherwise move on to next cell + !*** + + end do cell_loop + + !*** + !*** if still no cell found, the point lies outside the grid. + !*** take some baby steps along the segment to see if any + !*** part of the segment lies inside the grid. + !*** + + loutside = .true. + s1 = s1 + 0.001_dbl_kind + lat1 = beglat + s1*(endlat - beglat) + lon1 = beglon + s1*(lon2 - beglon) + + !*** + !*** reached the end of the segment and still outside the grid + !*** return no intersection + !*** + + if (s1 >= one) return + + end do srch_loop + call timer_stop(12) + +!----------------------------------------------------------------------- +! +! now that a cell is found, search for the next intersection. +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + call timer_start(13) + intrsct_loop: do n=1,srch_corners + next_n = mod(n,srch_corners) + 1 + + grdlon1 = srch_corner_lon(n ,cell) + grdlon2 = srch_corner_lon(next_n,cell) + grdlat1 = srch_corner_lat(n ,cell) + grdlat2 = srch_corner_lat(next_n,cell) + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = lat2 - lat1 + mat2 = grdlat1 - grdlat2 + mat3 = lon2 - lon1 + mat4 = grdlon1 - grdlon2 + rhs1 = grdlat1 - lat1 + rhs2 = grdlon1 - lon1 + + if (mat3 > pi) then + mat3 = mat3 - pi2 + else if (mat3 < -pi) then + mat3 = mat3 + pi2 + endif + if (mat4 > pi) then + mat4 = mat4 - pi2 + else if (mat4 < -pi) then + mat4 = mat4 + pi2 + endif + if (rhs2 > pi) then + rhs2 = rhs2 - pi2 + else if (rhs2 < -pi) then + rhs2 = rhs2 + pi2 + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident. coincidences were detected + !*** above so do nothing. + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0<s1,s2<1 then the segment intersects with this side. + !*** return the point of intersection (adding a small + !*** number so the intersection is off the grid line). + !*** + + if (abs(determ) > 1.e-30) then + + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (s2 >= zero .and. s2 <= one .and. + & s1 > zero. and. s1 <= one) then + + !*** + !*** recompute intersection based on full segment + !*** so intersections are consistent for both sweeps + !*** + + if (.not. loutside) then + mat1 = lat2 - begseg(1) + mat3 = lon2 - begseg(2) + rhs1 = grdlat1 - begseg(1) + rhs2 = grdlon1 - begseg(2) + else + mat1 = begseg(1) - endlat + mat3 = begseg(2) - endlon + rhs1 = grdlat1 - endlat + rhs2 = grdlon1 - endlon + endif + + if (mat3 > pi) then + mat3 = mat3 - pi2 + else if (mat3 < -pi) then + mat3 = mat3 + pi2 + endif + if (rhs2 > pi) then + rhs2 = rhs2 - pi2 + else if (rhs2 < -pi) then + rhs2 = rhs2 + pi2 + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** sometimes due to roundoff, the previous + !*** determinant is non-zero, but the lines + !*** are actually coincident. if this is the + !*** case, skip the rest. + !*** + + if (determ /= zero) then + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + offset = s1 + eps/determ + if (offset > one) offset = one + + if (.not. loutside) then + intrsct_lat = begseg(1) + mat1*s1 + intrsct_lon = begseg(2) + mat3*s1 + intrsct_lat_off = begseg(1) + mat1*offset + intrsct_lon_off = begseg(2) + mat3*offset + else + intrsct_lat = endlat + mat1*s1 + intrsct_lon = endlon + mat3*s1 + intrsct_lat_off = endlat + mat1*offset + intrsct_lon_off = endlon + mat3*offset + endif + exit intrsct_loop + endif + + endif + endif + + !*** + !*** no intersection this side, move on to next side + !*** + + end do intrsct_loop + call timer_stop(13) + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude. only check if this was not a +! threshold segment since sometimes coordinate transform can end +! up on other side of threshold again. +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat < north_thresh .or. intrsct_lat > south_thresh) + & lthresh = .false. + else if (lat1 > zero .and. intrsct_lat > north_thresh) then + intrsct_lat = north_thresh + tiny + intrsct_lat_off = north_thresh + eps*mat1 + s1 = (intrsct_lat - begseg(1))/mat1 + intrsct_lon = begseg(2) + s1*mat3 + intrsct_lon_off = begseg(2) + (s1+eps)*mat3 + last_loc = location + lthresh = .true. + else if (lat1 < zero .and. intrsct_lat < south_thresh) then + intrsct_lat = south_thresh - tiny + intrsct_lat_off = south_thresh + eps*mat1 + s1 = (intrsct_lat - begseg(1))/mat1 + intrsct_lon = begseg(2) + s1*mat3 + intrsct_lon_off = begseg(2) + (s1+eps)*mat3 + last_loc = location + lthresh = .true. + endif + +!----------------------------------------------------------------------- + + end subroutine intersection + +!*********************************************************************** + + subroutine pole_intersection(location, + & intrsct_lat,intrsct_lon,lcoinc,lthresh, + & beglat, beglon, endlat, endlon, begseg, lrevers) + +!----------------------------------------------------------------------- +! +! this routine is identical to the intersection routine except +! that a coordinate transformation (using a Lambert azimuthal +! equivalent projection) is performed to treat polar cells more +! accurately. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: + & beglat, beglon, ! beginning lat/lon endpoints for segment + & endlat, endlon ! ending lat/lon endpoints for segment + + real (kind=dbl_kind), dimension(2), intent(inout) :: + & begseg ! begin lat/lon of full segment + + logical (kind=log_kind), intent(in) :: + & lrevers ! flag true if segment integrated in reverse + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(inout) :: + & location ! address in destination array containing this + ! segment -- also may contain last location on + ! entry + + logical (kind=log_kind), intent(out) :: + & lcoinc ! flag segment coincident with grid line + + logical (kind=log_kind), intent(inout) :: + & lthresh ! flag segment crossing threshold boundary + + real (kind=dbl_kind), intent(out) :: + & intrsct_lat, intrsct_lon ! lat/lon coords of next intersect. + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, cell, srch_corners, pole_loc + + logical (kind=log_kind) :: loutside ! flags points outside grid + + real (kind=dbl_kind) :: pi4, rns, ! north/south conversion + & x1, x2, ! local x variables for segment + & y1, y2, ! local y variables for segment + & begx, begy, ! beginning x,y variables for segment + & endx, endy, ! beginning x,y variables for segment + & begsegx, begsegy, ! beginning x,y variables for segment + & grdx1, grdx2, ! local x variables for grid cell + & grdy1, grdy2, ! local y variables for grid cell + & vec1_y, vec1_x, ! vectors and cross products used + & vec2_y, vec2_x, ! during grid search + & cross_product, eps, ! eps=small offset away from intersect + & s1, s2, determ, ! variables used for linear solve to + & mat1, mat2, mat3, mat4, rhs1, rhs2 ! find intersection + + real (kind=dbl_kind), dimension(:,:), allocatable :: + & srch_corner_x, ! x of each corner of srch cells + & srch_corner_y ! y of each corner of srch cells + + !*** + !*** save last intersection to avoid roundoff during coord + !*** transformation + !*** + + logical (kind=log_kind), save :: luse_last = .false. + + real (kind=dbl_kind), save :: + & intrsct_x, intrsct_y ! x,y for intersection + + !*** + !*** variables necessary if segment manages to hit pole + !*** + + integer (kind=int_kind), save :: + & avoid_pole_count = 0 ! count attempts to avoid pole + + real (kind=dbl_kind), save :: + & avoid_pole_offset = tiny ! endpoint offset to avoid pole + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + if (.not. lthresh) location = 0 + lcoinc = .false. + intrsct_lat = endlat + intrsct_lon = endlon + + loutside = .false. + s1 = zero + +!----------------------------------------------------------------------- +! +! convert coordinates +! +!----------------------------------------------------------------------- + + allocate(srch_corner_x(size(srch_corner_lat,DIM=1), + & size(srch_corner_lat,DIM=2)), + & srch_corner_y(size(srch_corner_lat,DIM=1), + & size(srch_corner_lat,DIM=2))) + + if (beglat > zero) then + pi4 = quart*pi + rns = one + else + pi4 = -quart*pi + rns = -one + endif + + if (luse_last) then + x1 = intrsct_x + y1 = intrsct_y + else + x1 = rns*two*sin(pi4 - half*beglat)*cos(beglon) + y1 = two*sin(pi4 - half*beglat)*sin(beglon) + luse_last = .true. + endif + x2 = rns*two*sin(pi4 - half*endlat)*cos(endlon) + y2 = two*sin(pi4 - half*endlat)*sin(endlon) + srch_corner_x = rns*two*sin(pi4 - half*srch_corner_lat)* + & cos(srch_corner_lon) + srch_corner_y = two*sin(pi4 - half*srch_corner_lat)* + & sin(srch_corner_lon) + + begx = x1 + begy = y1 + endx = x2 + endy = y2 + begsegx = rns*two*sin(pi4 - half*begseg(1))*cos(begseg(2)) + begsegy = two*sin(pi4 - half*begseg(1))*sin(begseg(2)) + intrsct_x = endx + intrsct_y = endy + +!----------------------------------------------------------------------- +! +! search for location of this segment in ocean grid using cross +! product method to determine whether a point is enclosed by a cell +! +!----------------------------------------------------------------------- + + call timer_start(12) + srch_corners = size(srch_corner_lat,DIM=1) + srch_loop: do + + !*** + !*** if last segment crossed threshold, use that location + !*** + + if (lthresh) then + do cell=1,num_srch_cells + if (srch_add(cell) == location) then + eps = tiny + exit srch_loop + endif + end do + endif + + !*** + !*** otherwise normal search algorithm + !*** + + cell_loop: do cell=1,num_srch_cells + corner_loop: do n=1,srch_corners + next_n = MOD(n,srch_corners) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each cell side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the cell. + !*** + + vec1_x = srch_corner_x(next_n,cell) - + & srch_corner_x(n ,cell) + vec1_y = srch_corner_y(next_n,cell) - + & srch_corner_y(n ,cell) + vec2_x = x1 - srch_corner_x(n,cell) + vec2_y = y1 - srch_corner_y(n,cell) + + !*** + !*** if endpoint coincident with vertex, offset + !*** the endpoint + !*** + + if (vec2_x == 0 .and. vec2_y == 0) then + x1 = x1 + 1.d-10*(x2-x1) + y1 = y1 + 1.d-10*(y2-y1) + vec2_x = x1 - srch_corner_x(n,cell) + vec2_y = y1 - srch_corner_y(n,cell) + endif + + cross_product = vec1_x*vec2_y - vec2_x*vec1_y + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the length of a side + !*** is zero. if the length is zero set det > 0. + !*** otherwise, perform another cross + !*** product between the side and the segment itself. + !*** if this cross product is also zero, the line is + !*** coincident with the cell boundary - perform the + !*** dot product and only choose the cell if the dot + !*** product is positive (parallel vs anti-parallel). + !*** + + if (cross_product == zero) then + if (vec1_x /= zero .or. vec1_y /= 0) then + vec2_x = x2 - x1 + vec2_y = y2 - y1 + cross_product = vec1_x*vec2_y - vec2_x*vec1_y + else + cross_product = one + endif + + if (cross_product == zero) then + lcoinc = .true. + cross_product = vec1_x*vec2_x + vec1_y*vec2_y + if (lrevers) cross_product = -cross_product + endif + endif + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (cross_product < zero) exit corner_loop + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > srch_corners) then + location = srch_add(cell) + + !*** + !*** if the beginning of this segment was outside the + !*** grid, invert the segment so the intersection found + !*** will be the first intersection with the grid + !*** + + if (loutside) then + x2 = begx + y2 = begy + location = 0 + eps = -tiny + else + eps = tiny + endif + + exit srch_loop + endif + + !*** + !*** otherwise move on to next cell + !*** + + end do cell_loop + + !*** + !*** if no cell found, the point lies outside the grid. + !*** take some baby steps along the segment to see if any + !*** part of the segment lies inside the grid. + !*** + + loutside = .true. + s1 = s1 + 0.001_dbl_kind + x1 = begx + s1*(x2 - begx) + y1 = begy + s1*(y2 - begy) + + !*** + !*** reached the end of the segment and still outside the grid + !*** return no intersection + !*** + + if (s1 >= one) then + deallocate(srch_corner_x, srch_corner_y) + luse_last = .false. + return + endif + + end do srch_loop + call timer_stop(12) + +!----------------------------------------------------------------------- +! +! now that a cell is found, search for the next intersection. +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + call timer_start(13) + intrsct_loop: do n=1,srch_corners + next_n = mod(n,srch_corners) + 1 + + grdy1 = srch_corner_y(n ,cell) + grdy2 = srch_corner_y(next_n,cell) + grdx1 = srch_corner_x(n ,cell) + grdx2 = srch_corner_x(next_n,cell) + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = x2 - x1 + mat2 = grdx1 - grdx2 + mat3 = y2 - y1 + mat4 = grdy1 - grdy2 + rhs1 = grdx1 - x1 + rhs2 = grdy1 - y1 + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident or one segment has zero length. + !*** coincidences were detected above so do nothing. + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0<s1,s2<1 then the segment intersects with this side. + !*** return the point of intersection (adding a small + !*** number so the intersection is off the grid line). + !*** + + if (abs(determ) > 1.e-30) then + + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (s2 >= zero .and. s2 <= one .and. + & s1 > zero. and. s1 <= one) then + + !*** + !*** recompute intersection using entire segment + !*** for consistency between sweeps + !*** + + if (.not. loutside) then + mat1 = x2 - begsegx + mat3 = y2 - begsegy + rhs1 = grdx1 - begsegx + rhs2 = grdy1 - begsegy + else + mat1 = x2 - endx + mat3 = y2 - endy + rhs1 = grdx1 - endx + rhs2 = grdy1 - endy + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** sometimes due to roundoff, the previous + !*** determinant is non-zero, but the lines + !*** are actually coincident. if this is the + !*** case, skip the rest. + !*** + + if (determ /= zero) then + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (.not. loutside) then + intrsct_x = begsegx + s1*mat1 + intrsct_y = begsegy + s1*mat3 + else + intrsct_x = endx + s1*mat1 + intrsct_y = endy + s1*mat3 + endif + + !*** + !*** convert back to lat/lon coordinates + !*** + + intrsct_lon = rns*atan2(intrsct_y,intrsct_x) + if (intrsct_lon < zero) + & intrsct_lon = intrsct_lon + pi2 + + if (abs(intrsct_x) > 1.d-10) then + intrsct_lat = (pi4 - + & asin(rns*half*intrsct_x/cos(intrsct_lon)))*two + else if (abs(intrsct_y) > 1.d-10) then + intrsct_lat = (pi4 - + & asin(half*intrsct_y/sin(intrsct_lon)))*two + else + intrsct_lat = two*pi4 + endif + + !*** + !*** add offset in transformed space for next pass. + !*** + + if (s1 - eps/determ < one) then + intrsct_x = intrsct_x - mat1*(eps/determ) + intrsct_y = intrsct_y - mat3*(eps/determ) + else + if (.not. loutside) then + intrsct_x = endx + intrsct_y = endy + intrsct_lat = endlat + intrsct_lon = endlon + else + intrsct_x = begsegx + intrsct_y = begsegy + intrsct_lat = begseg(1) + intrsct_lon = begseg(2) + endif + endif + + exit intrsct_loop + endif + endif + endif + + !*** + !*** no intersection this side, move on to next side + !*** + + end do intrsct_loop + call timer_stop(13) + + deallocate(srch_corner_x, srch_corner_y) + +!----------------------------------------------------------------------- +! +! if segment manages to cross over pole, shift the beginning +! endpoint in order to avoid hitting pole directly +! (it is ok for endpoint to be pole point) +! +!----------------------------------------------------------------------- + + if (abs(intrsct_x) < 1.e-10 .and. abs(intrsct_y) < 1.e-10 .and. + & (endx /= zero .and. endy /=0)) then + if (avoid_pole_count > 2) then + avoid_pole_count = 0 + avoid_pole_offset = 10.*avoid_pole_offset + endif + + cross_product = begsegx*(endy-begsegy) - begsegy*(endx-begsegx) + intrsct_lat = begseg(1) + if (cross_product*intrsct_lat > zero) then + intrsct_lon = beglon + avoid_pole_offset + begseg(2) = begseg(2) + avoid_pole_offset + else + intrsct_lon = beglon - avoid_pole_offset + begseg(2) = begseg(2) - avoid_pole_offset + endif + + avoid_pole_count = avoid_pole_count + 1 + luse_last = .false. + else + avoid_pole_count = 0 + avoid_pole_offset = tiny + endif + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude and do not reuse x,y intersect +! on next entry. only check if did not cross threshold last +! time - sometimes the coordinate transformation can place a +! segment on the other side of the threshold again +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat > north_thresh .or. intrsct_lat < south_thresh) + & lthresh = .false. + else if (beglat > zero .and. intrsct_lat < north_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 + intrsct_lat = north_thresh - tiny + s1 = (north_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + luse_last = .false. + lthresh = .true. + else if (beglat < zero .and. intrsct_lat > south_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 + intrsct_lat = south_thresh + tiny + s1 = (south_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + luse_last = .false. + lthresh = .true. + endif + + !*** + !*** if reached end of segment, do not use x,y intersect + !*** on next entry + !*** + + if (intrsct_lat == endlat .and. intrsct_lon == endlon) then + luse_last = .false. + endif + +!----------------------------------------------------------------------- + + end subroutine pole_intersection + +!*********************************************************************** + + subroutine line_integral(weights, num_wts, + & in_phi1, in_phi2, theta1, theta2, + & grid1_lat, grid1_lon, grid2_lat, grid2_lon) + +!----------------------------------------------------------------------- +! +! this routine computes the line integral of the flux function +! that results in the interpolation weights. the line is defined +! by the input lat/lon of the endpoints. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & num_wts ! number of weights to compute + + real (kind=dbl_kind), intent(in) :: + & in_phi1, in_phi2, ! longitude endpoints for the segment + & theta1, theta2, ! latitude endpoints for the segment + & grid1_lat, grid1_lon, ! reference coordinates for each + & grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), dimension(2*num_wts), intent(out) :: + & weights ! line integral contribution to weights + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind) :: dphi, sinth1, sinth2, costh1, costh2, fac, + & phi1, phi2, phidiff1, phidiff2, sinint + real (kind=dbl_kind) :: f1, f2, fint + +!----------------------------------------------------------------------- +! +! weights for the general case based on a trapezoidal approx to +! the integrals. +! +!----------------------------------------------------------------------- + + sinth1 = SIN(theta1) + sinth2 = SIN(theta2) + costh1 = COS(theta1) + costh2 = COS(theta2) + + dphi = in_phi1 - in_phi2 + if (dphi > pi) then + dphi = dphi - pi2 + else if (dphi < -pi) then + dphi = dphi + pi2 + endif + dphi = half*dphi + +!----------------------------------------------------------------------- +! +! the first weight is the area overlap integral. the second and +! fourth are second-order latitude gradient weights. +! +!----------------------------------------------------------------------- + + weights( 1) = dphi*(sinth1 + sinth2) + weights(num_wts+1) = dphi*(sinth1 + sinth2) + weights( 2) = dphi*(costh1 + costh2 + (theta1*sinth1 + + & theta2*sinth2)) + weights(num_wts+2) = dphi*(costh1 + costh2 + (theta1*sinth1 + + & theta2*sinth2)) + +!----------------------------------------------------------------------- +! +! the third and fifth weights are for the second-order phi gradient +! component. must be careful of longitude range. +! +!----------------------------------------------------------------------- + + f1 = half*(costh1*sinth1 + theta1) + f2 = half*(costh2*sinth2 + theta2) + + phi1 = in_phi1 - grid1_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid1_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(3) = half*phi1*(phi1-fac)*f1 - + & half*phi2*(phi2+fac)*f2 + + & half*fac*(phi1+phi2)*fint + endif + + phi1 = in_phi1 - grid2_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid2_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(num_wts+3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(num_wts+3) = half*phi1*(phi1-fac)*f1 - + & half*phi2*(phi2+fac)*f2 + + & half*fac*(phi1+phi2)*fint + endif + +!----------------------------------------------------------------------- + + end subroutine line_integral + +!*********************************************************************** + + subroutine store_link_cnsrv(add1, add2, weights) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for this link in +! the appropriate address and weight arrays and resizes those +! arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & add1, ! address on grid1 + & add2 ! address on grid2 + + real (kind=dbl_kind), dimension(:), intent(in) :: + & weights ! array of remapping weights for this link + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: nlink, min_link, max_link ! link index + + integer (kind=int_kind), dimension(:,:), allocatable, save :: + & link_add1, ! min,max link add to restrict search + & link_add2 ! min,max link add to restrict search + + logical (kind=log_kind), save :: first_call = .true. + +!----------------------------------------------------------------------- +! +! if all weights are zero, do not bother storing the link +! +!----------------------------------------------------------------------- + + if (all(weights == zero)) return + +!----------------------------------------------------------------------- +! +! restrict the range of links to search for existing links +! +!----------------------------------------------------------------------- + + if (first_call) then + allocate(link_add1(2,grid1_size), link_add2(2,grid2_size)) + link_add1 = 0 + link_add2 = 0 + first_call = .false. + min_link = 1 + max_link = 0 + else + min_link = min(link_add1(1,add1),link_add2(1,add2)) + max_link = max(link_add1(2,add1),link_add2(2,add2)) + if (min_link == 0) then + min_link = 1 + max_link = 0 + endif + endif + +!----------------------------------------------------------------------- +! +! if the link already exists, add the weight to the current weight +! arrays +! +!----------------------------------------------------------------------- + + do nlink=min_link,max_link + if (add1 == grid1_add_map1(nlink)) then + if (add2 == grid2_add_map1(nlink)) then + + wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts) + if (num_maps == 2) then + wts_map2(:,nlink) = wts_map2(:,nlink) + + & weights(num_wts+1:2*num_wts) + endif + return + + endif + endif + end do + +!----------------------------------------------------------------------- +! +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate +! the new link. then store the link. +! +!----------------------------------------------------------------------- + + num_links_map1 = num_links_map1 + 1 + if (num_links_map1 > max_links_map1) + & call resize_remap_vars(1,resize_increment) + + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = weights(1:num_wts) + + if (num_maps > 1) then + num_links_map2 = num_links_map2 + 1 + if (num_links_map2 > max_links_map2) + & call resize_remap_vars(2,resize_increment) + + grid1_add_map2(num_links_map2) = add1 + grid2_add_map2(num_links_map2) = add2 + wts_map2 (:,num_links_map2) = weights(num_wts+1:2*num_wts) + endif + + if (link_add1(1,add1) == 0) link_add1(1,add1) = num_links_map1 + if (link_add2(1,add2) == 0) link_add2(1,add2) = num_links_map1 + link_add1(2,add1) = num_links_map1 + link_add2(2,add2) = num_links_map1 + +!----------------------------------------------------------------------- + + end subroutine store_link_cnsrv + +!*********************************************************************** + + end module remap_conservative + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_distwgt.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_distwgt.f new file mode 100644 index 0000000000000000000000000000000000000000..e0745e9cbfedeff8ab3a8601937bdd74d98b2566 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_distwgt.f @@ -0,0 +1,498 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! interpolation using a distance-weighted average of n nearest +! neighbors. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_distwgt.f,v 1.3 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_distance_weight + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & num_neighbors=4 ! num nearest neighbors to interpolate from + + real (kind=dbl_kind), dimension(:), allocatable, save :: + & coslat, sinlat, ! cosine, sine of grid lats (for distance) + & coslon, sinlon, ! cosine, sine of grid lons (for distance) + & wgtstmp ! an array to hold the link weight + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_distwgt + +!----------------------------------------------------------------------- +! +! this routine computes the inverse-distance weights for a +! nearest-neighbor interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(num_neighbors) :: + & nbr_mask ! mask at nearest neighbors + + integer (kind=int_kind) :: n, + & dst_add, ! destination address + & nmap ! index of current map being computed + + integer (kind=int_kind), dimension(num_neighbors) :: + & nbr_add ! source address at nearest neighbors + + real (kind=dbl_kind), dimension(num_neighbors) :: + & nbr_dist ! angular distance four nearest neighbors + + real (kind=dbl_kind) :: + & coslat_dst, ! cos(lat) of destination grid point + & coslon_dst, ! cos(lon) of destination grid point + & sinlat_dst, ! sin(lat) of destination grid point + & sinlon_dst, ! sin(lon) of destination grid point + & dist_tot ! sum of neighbor distances (for normalizing) + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + + !*** + !*** allocate wgtstmp to be consistent with store_link interface + !*** + + allocate (wgtstmp(num_wts)) + + !*** + !*** compute cos, sin of lat/lon on source grid for distance + !*** calculations + !*** + + allocate (coslat(grid1_size), coslon(grid1_size), + & sinlat(grid1_size), sinlon(grid1_size)) + + coslat = cos(grid1_center_lat) + coslon = cos(grid1_center_lon) + sinlat = sin(grid1_center_lat) + sinlon = sin(grid1_center_lon) + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + coslat_dst = cos(grid2_center_lat(dst_add)) + coslon_dst = cos(grid2_center_lon(dst_add)) + sinlat_dst = sin(grid2_center_lat(dst_add)) + sinlon_dst = sin(grid2_center_lon(dst_add)) + + !*** + !*** find nearest grid points on source grid and + !*** distances to each point + !*** + + call grid_search_nbr(nbr_add, nbr_dist, + & grid2_center_lat(dst_add), + & grid2_center_lon(dst_add), + & coslat_dst, coslon_dst, + & sinlat_dst, sinlon_dst, + & bin_addr1, bin_addr2) + + !*** + !*** compute weights based on inverse distance + !*** if mask is false, eliminate those points + !*** + + dist_tot = zero + do n=1,num_neighbors + if (grid1_mask(nbr_add(n))) then + nbr_dist(n) = one/nbr_dist(n) + dist_tot = dist_tot + nbr_dist(n) + nbr_mask(n) = .true. + else + nbr_mask(n) = .false. + endif + end do + + !*** + !*** normalize weights and store the link + !*** + + do n=1,num_neighbors + if (nbr_mask(n)) then + wgtstmp(1) = nbr_dist(n)/dist_tot + call store_link_nbr(nbr_add(n), dst_add, wgtstmp, nmap) + grid2_frac(dst_add) = one + endif + end do + + end do grid_loop1 + + deallocate (coslat, coslon, sinlat, sinlon) + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + + !*** + !*** compute cos, sin of lat/lon on source grid for distance + !*** calculations + !*** + + allocate (coslat(grid2_size), coslon(grid2_size), + & sinlat(grid2_size), sinlon(grid2_size)) + + coslat = cos(grid2_center_lat) + coslon = cos(grid2_center_lon) + sinlat = sin(grid2_center_lat) + sinlon = sin(grid2_center_lon) + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + coslat_dst = cos(grid1_center_lat(dst_add)) + coslon_dst = cos(grid1_center_lon(dst_add)) + sinlat_dst = sin(grid1_center_lat(dst_add)) + sinlon_dst = sin(grid1_center_lon(dst_add)) + + !*** + !*** find four nearest grid points on source grid and + !*** distances to each point + !*** + + call grid_search_nbr(nbr_add, nbr_dist, + & grid1_center_lat(dst_add), + & grid1_center_lon(dst_add), + & coslat_dst, coslon_dst, + & sinlat_dst, sinlon_dst, + & bin_addr2, bin_addr1) + + !*** + !*** compute weights based on inverse distance + !*** if mask is false, eliminate those points + !*** + + dist_tot = zero + do n=1,num_neighbors + if (grid2_mask(nbr_add(n))) then + nbr_dist(n) = one/nbr_dist(n) + dist_tot = dist_tot + nbr_dist(n) + nbr_mask(n) = .true. + else + nbr_mask(n) = .false. + endif + end do + + !*** + !*** normalize weights and store the link + !*** + + do n=1,num_neighbors + if (nbr_mask(n)) then + wgtstmp(1) = nbr_dist(n)/dist_tot + call store_link_nbr(dst_add, nbr_add(n), wgtstmp, nmap) + grid1_frac(dst_add) = one + endif + end do + + end do grid_loop2 + + deallocate (coslat, coslon, sinlat, sinlon) + + endif + + deallocate(wgtstmp) + +!----------------------------------------------------------------------- + + end subroutine remap_distwgt + +!*********************************************************************** + + subroutine grid_search_nbr(nbr_add, nbr_dist, plat, plon, + & coslat_dst, coslon_dst, sinlat_dst, sinlon_dst, + & src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the closest num_neighbor points to a search +! point and computes a distance to each of the neighbors. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(num_neighbors), intent(out) :: + & nbr_add ! address of each of the closest points + + real (kind=dbl_kind), dimension(num_neighbors), intent(out) :: + & nbr_dist ! distance to each of the closest points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(:,:), intent(in) :: + & src_bin_add, ! search bins for restricting search + & dst_bin_add + + real (kind=dbl_kind), intent(in) :: + & plat, ! latitude of the search point + & plon, ! longitude of the search point + & coslat_dst, ! cos(lat) of the search point + & coslon_dst, ! cos(lon) of the search point + & sinlat_dst, ! sin(lat) of the search point + & sinlon_dst ! sin(lon) of the search point + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, nmax, nadd, nchk, ! dummy indices + & min_add, max_add, nm1, np1, i, j, ip1, im1, jp1, jm1 + + real (kind=dbl_kind) :: + & distance ! angular distance + +!----------------------------------------------------------------------- +! +! loop over source grid and find nearest neighbors +! +!----------------------------------------------------------------------- + + !*** + !*** restrict the search using search bins + !*** expand the bins to catch neighbors + !*** + + select case (restrict_type) + case('latitude') + + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n)) then + min_add = src_bin_add(1,n) + max_add = src_bin_add(2,n) + + nm1 = max(n-1,1) + np1 = min(n+1,num_srch_bins) + + min_add = min(min_add,src_bin_add(1,nm1)) + max_add = max(max_add,src_bin_add(2,nm1)) + min_add = min(min_add,src_bin_add(1,np1)) + max_add = max(max_add,src_bin_add(2,np1)) + endif + end do + + case('latlon') + + n = 0 + nmax = nint(sqrt(real(num_srch_bins))) + do j=1,nmax + jp1 = min(j+1,nmax) + jm1 = max(j-1,1) + do i=1,nmax + ip1 = min(i+1,nmax) + im1 = max(i-1,1) + + n = n+1 + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. + & plon >= bin_lons(1,n) .and. plon <= bin_lons(3,n)) then + min_add = src_bin_add(1,n) + max_add = src_bin_add(2,n) + + nm1 = (jm1-1)*nmax + im1 + np1 = (jp1-1)*nmax + ip1 + nm1 = max(nm1,1) + np1 = min(np1,num_srch_bins) + + min_add = min(min_add,src_bin_add(1,nm1)) + max_add = max(max_add,src_bin_add(2,nm1)) + min_add = min(min_add,src_bin_add(1,np1)) + max_add = max(max_add,src_bin_add(2,np1)) + endif + end do + end do + + end select + + !*** + !*** initialize distance and address arrays + !*** + + nbr_add = 0 + nbr_dist = bignum + + do nadd=min_add,max_add + + !*** + !*** find distance to this point + !*** + + distance = acos(sinlat_dst*sinlat(nadd) + + & coslat_dst*coslat(nadd)* + & (coslon_dst*coslon(nadd) + + & sinlon_dst*sinlon(nadd)) ) + + !*** + !*** store the address and distance if this is one of the + !*** smallest four so far + !*** + + check_loop: do nchk=1,num_neighbors + if (distance .lt. nbr_dist(nchk)) then + do n=num_neighbors,nchk+1,-1 + nbr_add(n) = nbr_add(n-1) + nbr_dist(n) = nbr_dist(n-1) + end do + nbr_add(nchk) = nadd + nbr_dist(nchk) = distance + exit check_loop + endif + end do check_loop + + end do + +!----------------------------------------------------------------------- + + end subroutine grid_search_nbr + +!*********************************************************************** + + subroutine store_link_nbr(add1, add2, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for this link in +! the appropriate address and weight arrays and resizes those +! arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & add1, ! address on grid1 + & add2, ! address on grid2 + & nmap ! identifies which direction for mapping + + real (kind=dbl_kind), dimension(:), intent(in) :: + & weights ! array of remapping weights for this link + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_map1 = num_links_map1 + 1 + + if (num_links_map1 > max_links_map1) + & call resize_remap_vars(1,resize_increment) + + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = weights + + case(2) + + num_links_map2 = num_links_map2 + 1 + + if (num_links_map2 > max_links_map2) + & call resize_remap_vars(2,resize_increment) + + grid1_add_map2(num_links_map2) = add1 + grid2_add_map2(num_links_map2) = add2 + wts_map2 (:,num_links_map2) = weights + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_nbr + +!*********************************************************************** + + end module remap_distance_weight + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_read.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_read.f new file mode 100644 index 0000000000000000000000000000000000000000..7501b46af6d16a26246dca34c2a4c02d41b6c727 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_read.f @@ -0,0 +1,1027 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This routine reads remapping information from files written +! by remap_setup. If remapping in both directions are required, +! two input files must be specified. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_read.f,v 1.6 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_read + +!----------------------------------------------------------------------- +! +! contains routines for reading a remap file +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines useful constants + use grids ! includes all grid information + use netcdf_mod ! module with netcdf vars and utilities + use remap_vars ! module for all required remapping variables + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! various netCDF ids for files variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), private :: ! netCDF ids + & ncstat, nc_file_id, + & nc_srcgrdsize_id, nc_dstgrdsize_id, + & nc_srcgrdcorn_id, nc_dstgrdcorn_id, + & nc_srcgrdrank_id, nc_dstgrdrank_id, + & nc_srcgrddims_id, nc_dstgrddims_id, + & nc_numlinks_id, nc_numwgts_id, + & nc_srcgrdimask_id, nc_dstgrdimask_id, + & nc_srcgrdcntrlat_id, nc_srcgrdcntrlon_id, + & nc_srcgrdcrnrlat_id, nc_srcgrdcrnrlon_id, + & nc_srcgrdarea_id, nc_srcgrdfrac_id, + & nc_dstgrdcntrlat_id, nc_dstgrdcntrlon_id, + & nc_dstgrdcrnrlat_id, nc_dstgrdcrnrlon_id, + & nc_dstgrdarea_id, nc_dstgrdfrac_id, + & nc_srcgrdadd_id, nc_dstgrdadd_id, nc_rmpmatrix_id + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine read_remap(map_name, interp_file) + +!----------------------------------------------------------------------- +! +! this driver routine reads some global attributes and then +! calls a specific read routine based on file conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: + & interp_file ! filename for remap data + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(out) :: + & map_name ! name for mapping + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: + & map_method ! character string for map_type + &, normalize_opt ! character string for normalization option + &, convention ! character string for output convention + +!----------------------------------------------------------------------- +! +! open file and read some global information +! +!----------------------------------------------------------------------- + + ncstat = nf_open(interp_file, NF_NOWRITE, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + map_name = ' ' + ncstat = nf_get_att_text(nc_file_id, NF_GLOBAL, 'title', + & map_name) + call netcdf_error_handler(ncstat) + + print *,'Reading remapping:',trim(map_name) + print *,'From file:',trim(interp_file) + + !*** + !*** normalization option + !*** + normalize_opt = ' ' + ncstat = nf_get_att_text(nc_file_id, NF_GLOBAL, 'normalization', + & normalize_opt) + call netcdf_error_handler(ncstat) + + select case(normalize_opt) + case ('none') + norm_opt = norm_opt_none + case ('fracarea') + norm_opt = norm_opt_frcarea + case ('destarea') + norm_opt = norm_opt_dstarea + case default + print *,'normalize_opt = ',normalize_opt + stop 'Invalid normalization option' + end select + + !*** + !*** map method + !*** + map_method = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'map_method', + & map_method) + call netcdf_error_handler(ncstat) + + select case(map_method) + case('Conservative remapping') + map_type = map_type_conserv + case('Bilinear remapping') + map_type = map_type_bilinear + case('Distance weighted avg of nearest neighbors') + map_type = map_type_distwgt + case('Bicubic remapping') + map_type = map_type_bicubic + case default + print *,'map_type = ',map_method + stop 'Invalid Map Type' + end select + + !*** + !*** file convention + !*** + convention = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'conventions', + & convention) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! call appropriate read routine based on output convention +! +!----------------------------------------------------------------------- + + select case(convention) + case ('SCRIP') + call read_remap_scrip + case ('NCAR-CSM') + call read_remap_csm + case default + print *,'convention = ',convention + stop 'unknown output file convention' + end select + +!----------------------------------------------------------------------- + + end subroutine read_remap + +!*********************************************************************** + + subroutine read_remap_scrip + +!----------------------------------------------------------------------- +! +! the routine reads a netCDF file to extract remapping info +! in SCRIP format +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: + & grid1_name ! grid name for source grid + &, grid2_name ! grid name for dest grid + + integer (kind=int_kind) :: + & n ! dummy index + + integer (kind=int_kind), dimension(:), allocatable :: + & grid1_mask_int, ! integer masks to determine + & grid2_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! read some additional global attributes +! +!----------------------------------------------------------------------- + + !*** + !*** source and destination grid names + !*** + + grid1_name = ' ' + grid2_name = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'source_grid', + & grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'dest_grid', + & grid2_name) + call netcdf_error_handler(ncstat) + + print *,' ' + print *,'Remapping between:',trim(grid1_name) + print *,'and ',trim(grid2_name) + print *,' ' + +!----------------------------------------------------------------------- +! +! read dimension information +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_size', + & nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdsize_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_size', + & nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdsize_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_corners', + & nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdcorn_id, + & grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_corners', + & nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdcorn_id, + & grid2_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_rank', + & nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdrank_id, + & grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_rank', + & nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdrank_id, + & grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_links', + & nc_numlinks_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numlinks_id, + & num_links_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts', + & nc_numwgts_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numwgts_id, num_wts) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_dims (grid1_rank), + & grid1_center_lat(grid1_size), + & grid1_center_lon(grid1_size), + & grid1_area (grid1_size), + & grid1_frac (grid1_size), + & grid1_mask (grid1_size), + & grid1_mask_int (grid1_size), + & grid1_corner_lat(grid1_corners, grid1_size), + & grid1_corner_lon(grid1_corners, grid1_size) ) + + allocate( grid2_dims (grid2_rank), + & grid2_center_lat(grid2_size), + & grid2_center_lon(grid2_size), + & grid2_area (grid2_size), + & grid2_frac (grid2_size), + & grid2_mask (grid2_size), + & grid2_mask_int (grid2_size), + & grid2_corner_lat(grid2_corners, grid2_size), + & grid2_corner_lon(grid2_corners, grid2_size) ) + + allocate( grid1_add_map1(num_links_map1), + & grid2_add_map1(num_links_map1), + & wts_map1(num_wts,num_links_map1) ) + +!----------------------------------------------------------------------- +! +! get variable ids +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_dims', + & nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_imask', + & nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_center_lat', + & nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_center_lon', + & nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_corner_lat', + & nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_corner_lon', + & nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_area', + & nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_frac', + & nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_dims', + & nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_imask', + & nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_center_lat', + & nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_center_lon', + & nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_corner_lat', + & nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_corner_lon', + & nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_area', + & nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_frac', + & nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_address', + & nc_srcgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_address', + & nc_dstgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'remap_matrix', + & nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! read all variables +! +!----------------------------------------------------------------------- + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrddims_id, + & grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdimask_id, + & grid1_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlat_id, + & grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlon_id, + & grid1_center_lon) + call netcdf_error_handler(ncstat) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcntrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlat_id, + & grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlon_id, + & grid1_corner_lon) + call netcdf_error_handler(ncstat) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcrnrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdarea_id, + & grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdfrac_id, + & grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrddims_id, + & grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdimask_id, + & grid2_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlat_id, + & grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlon_id, + & grid2_center_lon) + call netcdf_error_handler(ncstat) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcntrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlat_id, + & grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlon_id, + & grid2_corner_lon) + call netcdf_error_handler(ncstat) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcrnrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdarea_id, + & grid2_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdfrac_id, + & grid2_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdadd_id, + & grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdadd_id, + & grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix_id, + & wts_map1) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! initialize logical mask +! +!----------------------------------------------------------------------- + + where (grid1_mask_int == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + where (grid2_mask_int == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(grid1_mask_int, grid2_mask_int) + +!----------------------------------------------------------------------- +! +! close input file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine read_remap_scrip + +!*********************************************************************** + + subroutine read_remap_csm + +!----------------------------------------------------------------------- +! +! the routine reads a netCDF file to extract remapping info +! in NCAR-CSM format +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: + & grid1_name ! grid name for source grid + &, grid2_name ! grid name for dest grid + + integer (kind=int_kind) :: + & nc_numwgts1_id ! extra netCDF id for num_wgts > 1 + &, nc_rmpmatrix2_id ! extra netCDF id for high-order remap matrix + + real (kind=dbl_kind), dimension(:),allocatable :: + & wts1 ! CSM wants single array for 1st-order wts + + real (kind=dbl_kind), dimension(:,:),allocatable :: + & wts2 ! write remaining weights in different array + + integer (kind=int_kind) :: + & n ! dummy index + + integer (kind=int_kind), dimension(:), allocatable :: + & grid1_mask_int, ! integer masks to determine + & grid2_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! read some additional global attributes +! +!----------------------------------------------------------------------- + + !*** + !*** source and destination grid names + !*** + + grid1_name = ' ' + grid2_name = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'domain_a', + & grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'domain_b', + & grid2_name) + call netcdf_error_handler(ncstat) + + print *,' ' + print *,'Remapping between:',trim(grid1_name) + print *,'and ',trim(grid2_name) + print *,' ' + +!----------------------------------------------------------------------- +! +! read dimension information +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_dimid(nc_file_id, 'n_a', nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdsize_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'n_b', nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdsize_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'nv_a', nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdcorn_id, + & grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'nv_b', nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdcorn_id, + & grid2_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_rank', + & nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdrank_id, + & grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_rank', + & nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdrank_id, + & grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'n_s', + & nc_numlinks_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numlinks_id, + & num_links_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts', + & nc_numwgts_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numwgts_id, num_wts) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts1', + & nc_numwgts1_id) + call netcdf_error_handler(ncstat) + endif + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_dims (grid1_rank), + & grid1_center_lat(grid1_size), + & grid1_center_lon(grid1_size), + & grid1_area (grid1_size), + & grid1_frac (grid1_size), + & grid1_mask (grid1_size), + & grid1_mask_int (grid1_size), + & grid1_corner_lat(grid1_corners, grid1_size), + & grid1_corner_lon(grid1_corners, grid1_size) ) + + allocate( grid2_dims (grid2_rank), + & grid2_center_lat(grid2_size), + & grid2_center_lon(grid2_size), + & grid2_area (grid2_size), + & grid2_frac (grid2_size), + & grid2_mask (grid2_size), + & grid2_mask_int (grid2_size), + & grid2_corner_lat(grid2_corners, grid2_size), + & grid2_corner_lon(grid2_corners, grid2_size) ) + + allocate( grid1_add_map1(num_links_map1), + & grid2_add_map1(num_links_map1), + & wts_map1(num_wts,num_links_map1), + & wts1(num_links_map1), + & wts2(num_wts-1,num_links_map1) ) + +!----------------------------------------------------------------------- +! +! get variable ids +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_dims', + & nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'mask_a', + & nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yc_a', nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xc_a', nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yv_a', nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xv_a', nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'area_a', nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'frac_a', nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_dims', + & nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'mask_b', + & nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yc_b', nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xc_b', nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yv_b', nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xv_b', nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'area_b', nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'frac_b', nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'col', nc_srcgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'row', nc_dstgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'S', nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_inq_varid(nc_file_id, 'S2', nc_rmpmatrix2_id) + call netcdf_error_handler(ncstat) + endif + +!----------------------------------------------------------------------- +! +! read all variables +! +!----------------------------------------------------------------------- + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrddims_id, + & grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdimask_id, + & grid1_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlat_id, + & grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlon_id, + & grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcntrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlat_id, + & grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlon_id, + & grid1_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcrnrlat_id, 'units', + & grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdarea_id, + & grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdfrac_id, + & grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrddims_id, + & grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdimask_id, + & grid2_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlat_id, + & grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlon_id, + & grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcntrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlat_id, + & grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlon_id, + & grid2_corner_lon) + call netcdf_error_handler(ncstat) + + + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcrnrlat_id, 'units', + & grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdarea_id, + & grid2_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdfrac_id, + & grid2_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdadd_id, + & grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdadd_id, + & grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix_id, + & wts1) + wts_map1(1,:) = wts1 + deallocate(wts1) + + if (num_wts > 1) then + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix2_id, + & wts2) + wts_map1(2:,:) = wts2 + deallocate(wts2) + endif + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! initialize logical mask +! +!----------------------------------------------------------------------- + + where (grid1_mask_int == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + where (grid2_mask_int == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(grid1_mask_int, grid2_mask_int) + +!----------------------------------------------------------------------- +! +! close input file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine read_remap_csm + +!*********************************************************************** + + end module remap_read + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_vars.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_vars.f new file mode 100644 index 0000000000000000000000000000000000000000..a5e082c5c2d00b7e1e4dc812ac98f70698f5aac7 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_vars.f @@ -0,0 +1,302 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary variables for remapping between +! two grids. also routines for resizing and initializing these +! variables. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_vars.f,v 1.5 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_vars + + use kinds_mod + use constants + use grids + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: + & norm_opt_none = 1 + &, norm_opt_dstarea = 2 + &, norm_opt_frcarea = 3 + + integer (kind=int_kind), parameter :: + & map_type_conserv = 1 + &, map_type_bilinear = 2 + &, map_type_bicubic = 3 + &, map_type_distwgt = 4 + + integer (kind=int_kind), save :: + & max_links_map1 ! current size of link arrays + &, num_links_map1 ! actual number of links for remapping + &, max_links_map2 ! current size of link arrays + &, num_links_map2 ! actual number of links for remapping + &, num_maps ! num of remappings for this grid pair + &, num_wts ! num of weights used in remapping + &, map_type ! identifier for remapping method + &, norm_opt ! option for normalization (conserv only) + &, resize_increment ! default amount to increase array size + + integer (kind=int_kind), dimension(:), allocatable, save :: + & grid1_add_map1, ! grid1 address for each link in mapping 1 + & grid2_add_map1, ! grid2 address for each link in mapping 1 + & grid1_add_map2, ! grid1 address for each link in mapping 2 + & grid2_add_map2 ! grid2 address for each link in mapping 2 + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: + & wts_map1, ! map weights for each link (num_wts,max_links) + & wts_map2 ! map weights for each link (num_wts,max_links) + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine init_remap_vars + +!----------------------------------------------------------------------- +! +! this routine initializes some variables and provides an initial +! allocation of arrays (fairly large so frequent resizing +! unnecessary). +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! determine the number of weights +! +!----------------------------------------------------------------------- + + select case (map_type) + case(map_type_conserv) + num_wts = 3 + case(map_type_bilinear) + num_wts = 1 + case(map_type_bicubic) + num_wts = 4 + case(map_type_distwgt) + num_wts = 1 + end select + +!----------------------------------------------------------------------- +! +! initialize num_links and set max_links to four times the largest +! of the destination grid sizes initially (can be changed later). +! set a default resize increment to increase the size of link +! arrays if the number of links exceeds the initial size +! +!----------------------------------------------------------------------- + + num_links_map1 = 0 + max_links_map1 = 4*grid2_size + if (num_maps > 1) then + num_links_map2 = 0 + max_links_map1 = max(4*grid1_size,4*grid2_size) + max_links_map2 = max_links_map1 + endif + + resize_increment = 0.1*max(grid1_size,grid2_size) + +!----------------------------------------------------------------------- +! +! allocate address and weight arrays for mapping 1 +! +!----------------------------------------------------------------------- + + allocate (grid1_add_map1(max_links_map1), + & grid2_add_map1(max_links_map1), + & wts_map1(num_wts, max_links_map1)) + +!----------------------------------------------------------------------- +! +! allocate address and weight arrays for mapping 2 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + allocate (grid1_add_map2(max_links_map2), + & grid2_add_map2(max_links_map2), + & wts_map2(num_wts, max_links_map2)) + endif + +!----------------------------------------------------------------------- + + end subroutine init_remap_vars + +!*********************************************************************** + + subroutine resize_remap_vars(nmap, increment) + +!----------------------------------------------------------------------- +! +! this routine resizes remapping arrays by increasing(decreasing) +! the max_links by increment +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & nmap, ! identifies which mapping array to resize + & increment ! the number of links to add(subtract) to arrays + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & ierr, ! error flag + & mxlinks ! size of link arrays + + integer (kind=int_kind), dimension(:), allocatable :: + & add1_tmp, ! temp array for resizing address arrays + & add2_tmp ! temp array for resizing address arrays + + real (kind=dbl_kind), dimension(:,:), allocatable :: + & wts_tmp ! temp array for resizing weight arrays + +!----------------------------------------------------------------------- +! +! resize map 1 arrays if required. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + !*** + !*** allocate temporaries to hold original values + !*** + + mxlinks = size(grid1_add_map1) + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), + & wts_tmp(num_wts,mxlinks)) + + add1_tmp = grid1_add_map1 + add2_tmp = grid2_add_map1 + wts_tmp = wts_map1 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + deallocate (grid1_add_map1, grid2_add_map1, wts_map1) + max_links_map1 = mxlinks + increment + allocate (grid1_add_map1(max_links_map1), + & grid2_add_map1(max_links_map1), + & wts_map1(num_wts,max_links_map1)) + + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + + mxlinks = min(mxlinks, max_links_map1) + grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks) + grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks) + wts_map1 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + deallocate(add1_tmp, add2_tmp, wts_tmp) + +!----------------------------------------------------------------------- +! +! resize map 2 arrays if required. +! +!----------------------------------------------------------------------- + + case(2) + + !*** + !*** allocate temporaries to hold original values + !*** + + mxlinks = size(grid1_add_map2) + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), + & wts_tmp(num_wts,mxlinks),stat=ierr) + if (ierr .ne. 0) then + print *,'error allocating temps in resize: ',ierr + stop + endif + + add1_tmp = grid1_add_map2 + add2_tmp = grid2_add_map2 + wts_tmp = wts_map2 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + deallocate (grid1_add_map2, grid2_add_map2, wts_map2) + max_links_map2 = mxlinks + increment + allocate (grid1_add_map2(max_links_map2), + & grid2_add_map2(max_links_map2), + & wts_map2(num_wts,max_links_map2),stat=ierr) + if (ierr .ne. 0) then + print *,'error allocating new arrays in resize: ',ierr + stop + endif + + + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + + mxlinks = min(mxlinks, max_links_map2) + grid1_add_map2(1:mxlinks) = add1_tmp (1:mxlinks) + grid2_add_map2(1:mxlinks) = add2_tmp (1:mxlinks) + wts_map2 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + deallocate(add1_tmp, add2_tmp, wts_tmp) + + end select + +!----------------------------------------------------------------------- + + end subroutine resize_remap_vars + +!*********************************************************************** + + end module remap_vars + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_write.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_write.f new file mode 100644 index 0000000000000000000000000000000000000000..e3045a7fe7a3c0805d034ee37d9386950163c70b --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/remap_write.f @@ -0,0 +1,1763 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains routines for writing the remapping data to +! a file. Before writing the data for each mapping, the links are +! sorted by destination grid address. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_write.f,v 1.7 2001/08/21 21:06:42 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_write + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common scalar constants + use grids ! module containing grid information + use remap_vars ! module containing remap information + use netcdf_mod ! module with netCDF stuff + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character(char_len), private :: + & map_method ! character string for map_type + &, normalize_opt ! character string for normalization option + &, history ! character string for history information + &, convention ! character string for output convention + + character(8), private :: + & cdate ! character date string + + integer (kind=int_kind), dimension(:), allocatable, private :: + & src_mask_int ! integer masks to determine + &, dst_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! various netCDF identifiers used by output routines +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), private :: + & ncstat ! error flag for netCDF calls + &, nc_file_id ! id for netCDF file + &, nc_srcgrdsize_id ! id for source grid size + &, nc_dstgrdsize_id ! id for destination grid size + &, nc_srcgrdcorn_id ! id for number of source grid corners + &, nc_dstgrdcorn_id ! id for number of dest grid corners + &, nc_srcgrdrank_id ! id for source grid rank + &, nc_dstgrdrank_id ! id for dest grid rank + &, nc_numlinks_id ! id for number of links in mapping + &, nc_numwgts_id ! id for number of weights for mapping + &, nc_srcgrddims_id ! id for source grid dimensions + &, nc_dstgrddims_id ! id for dest grid dimensions + &, nc_srcgrdcntrlat_id ! id for source grid center latitude + &, nc_dstgrdcntrlat_id ! id for dest grid center latitude + &, nc_srcgrdcntrlon_id ! id for source grid center longitude + &, nc_dstgrdcntrlon_id ! id for dest grid center longitude + &, nc_srcgrdimask_id ! id for source grid mask + &, nc_dstgrdimask_id ! id for dest grid mask + &, nc_srcgrdcrnrlat_id ! id for latitude of source grid corners + &, nc_srcgrdcrnrlon_id ! id for longitude of source grid corners + &, nc_dstgrdcrnrlat_id ! id for latitude of dest grid corners + &, nc_dstgrdcrnrlon_id ! id for longitude of dest grid corners + &, nc_srcgrdarea_id ! id for area of source grid cells + &, nc_dstgrdarea_id ! id for area of dest grid cells + &, nc_srcgrdfrac_id ! id for area fraction on source grid + &, nc_dstgrdfrac_id ! id for area fraction on dest grid + &, nc_srcadd_id ! id for map source address + &, nc_dstadd_id ! id for map destination address + &, nc_rmpmatrix_id ! id for remapping matrix + + integer (kind=int_kind), dimension(2), private :: + & nc_dims2_id ! netCDF ids for 2d array dims + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine write_remap(map1_name, map2_name, + & interp_file1, interp_file2, output_opt) + +!----------------------------------------------------------------------- +! +! calls correct output routine based on output format choice +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: + & map1_name, ! name for mapping grid1 to grid2 + & map2_name, ! name for mapping grid2 to grid1 + & interp_file1, ! filename for map1 remap data + & interp_file2, ! filename for map2 remap data + & output_opt ! option for output conventions + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! define some common variables to be used in all routines +! +!----------------------------------------------------------------------- + + select case(norm_opt) + case (norm_opt_none) + normalize_opt = 'none' + case (norm_opt_frcarea) + normalize_opt = 'fracarea' + case (norm_opt_dstarea) + normalize_opt = 'destarea' + end select + + select case(map_type) + case(map_type_conserv) + map_method = 'Conservative remapping' + case(map_type_bilinear) + map_method = 'Bilinear remapping' + case(map_type_distwgt) + map_method = 'Distance weighted avg of nearest neighbors' + case(map_type_bicubic) + map_method = 'Bicubic remapping' + case default + stop 'Invalid Map Type' + end select + + call date_and_time(date=cdate) + write (history,1000) cdate(5:6),cdate(7:8),cdate(1:4) + 1000 format('Created: ',a2,'-',a2,'-',a4) + +!----------------------------------------------------------------------- +! +! sort address and weight arrays +! +!----------------------------------------------------------------------- + + call sort_add(grid2_add_map1, grid1_add_map1, wts_map1) + if (num_maps > 1) then + call sort_add(grid1_add_map2, grid2_add_map2, wts_map2) + endif + +!----------------------------------------------------------------------- +! +! call appropriate output routine +! +!----------------------------------------------------------------------- + + select case(output_opt) + case ('scrip') + call write_remap_scrip(map1_name, interp_file1, 1) + case ('ncar-csm') + call write_remap_csm (map1_name, interp_file1, 1) + case default + stop 'unknown output file convention' + end select + +!----------------------------------------------------------------------- +! +! call appropriate output routine for second mapping if required +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + select case(output_opt) + case ('scrip') + call write_remap_scrip(map2_name, interp_file2, 2) + case ('ncar-csm') + call write_remap_csm (map2_name, interp_file2, 2) + case default + stop 'unknown output file convention' + end select + endif + +!----------------------------------------------------------------------- + + end subroutine write_remap + +!*********************************************************************** + + subroutine write_remap_scrip(map_name, interp_file, direction) + +!----------------------------------------------------------------------- +! +! writes remap data to a netCDF file using SCRIP conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: + & map_name ! name for mapping + &, interp_file ! filename for remap data + + integer (kind=int_kind), intent(in) :: + & direction ! direction of map (1=grid1 to grid2 + ! 2=grid2 to grid1) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: + & grid1_ctmp ! character temp for grid1 names + &, grid2_ctmp ! character temp for grid2 names + + integer (kind=int_kind) :: + & itmp1 ! integer temp + &, itmp2 ! integer temp + &, itmp3 ! integer temp + &, itmp4 ! integer temp + +!----------------------------------------------------------------------- +! +! create netCDF file for mapping and define some global attributes +! +!----------------------------------------------------------------------- + + ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title', + & len_trim(map_name), map_name) + call netcdf_error_handler(ncstat) + + !*** + !*** normalization option + !*** + ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization', + & len_trim(normalize_opt), normalize_opt) + call netcdf_error_handler(ncstat) + + !*** + !*** map method + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method', + & len_trim(map_method), map_method) + call netcdf_error_handler(ncstat) + + !*** + !*** history + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history', + & len_trim(history), history) + call netcdf_error_handler(ncstat) + + !*** + !*** file convention + !*** + convention = 'SCRIP' + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions', + & len_trim(convention), convention) + call netcdf_error_handler(ncstat) + + !*** + !*** source and destination grid names + !*** + + if (direction == 1) then + grid1_ctmp = 'source_grid' + grid2_ctmp = 'dest_grid' + else + grid1_ctmp = 'dest_grid' + grid2_ctmp = 'source_grid' + endif + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp), + & len_trim(grid1_name), grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp), + & len_trim(grid2_name), grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! prepare netCDF dimension info +! +!----------------------------------------------------------------------- + + !*** + !*** define grid size dimensions + !*** + + if (direction == 1) then + itmp1 = grid1_size + itmp2 = grid2_size + else + itmp1 = grid2_size + itmp2 = grid1_size + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_size', itmp1, + & nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_size', itmp2, + & nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + if (direction == 1) then + itmp1 = grid1_corners + itmp2 = grid2_corners + else + itmp1 = grid2_corners + itmp2 = grid1_corners + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_corners', + & itmp1, nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_corners', + & itmp2, nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + if (direction == 1) then + itmp1 = grid1_rank + itmp2 = grid2_rank + else + itmp1 = grid2_rank + itmp2 = grid1_rank + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', + & itmp1, nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', + & itmp2, nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define map size dimensions + !*** + + if (direction == 1) then + itmp1 = num_links_map1 + else + itmp1 = num_links_map2 + endif + + ncstat = nf_def_dim (nc_file_id, 'num_links', + & itmp1, nc_numlinks_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'num_wgts', + & num_wts, nc_numwgts_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dimensions + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT, + & 1, nc_srcgrdrank_id, nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT, + & 1, nc_dstgrdrank_id, nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! define all arrays for netCDF descriptors +! +!----------------------------------------------------------------------- + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_center_lat', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lat', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_center_lon', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lon', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner lat/lon arrays + !*** + + nc_dims2_id(1) = nc_srcgrdcorn_id + nc_dims2_id(2) = nc_srcgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lat', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lon', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_dstgrdcorn_id + nc_dims2_id(2) = nc_dstgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lat', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lon', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define units for all coordinate arrays + !*** + + if (direction == 1) then + grid1_ctmp = grid1_units + grid2_ctmp = grid2_units + else + grid1_ctmp = grid2_units + grid2_ctmp = grid1_units + endif + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_imask', NF_INT, + & 1, nc_srcgrdsize_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_imask', NF_INT, + & 1, nc_dstgrdsize_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_area', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, + & 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_area', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, + & 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_frac', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_frac', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define mapping arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_address', + & NF_INT, 1, nc_numlinks_id, + & nc_srcadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_address', + & NF_INT, 1, nc_numlinks_id, + & nc_dstadd_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_numwgts_id + nc_dims2_id(2) = nc_numlinks_id + + ncstat = nf_def_var (nc_file_id, 'remap_matrix', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! compute integer masks +! +!----------------------------------------------------------------------- + + if (direction == 1) then + allocate (src_mask_int(grid1_size), + & dst_mask_int(grid2_size)) + + where (grid2_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid1_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + else + allocate (src_mask_int(grid2_size), + & dst_mask_int(grid1_size)) + + where (grid1_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid2_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + endif + +!----------------------------------------------------------------------- +! +! change units of lat/lon coordinates if input units different +! from radians +! +!----------------------------------------------------------------------- + + if (grid1_units(1:7) == 'degrees' .and. direction == 1) then + grid1_center_lat = grid1_center_lat/deg2rad + grid1_center_lon = grid1_center_lon/deg2rad + grid1_corner_lat = grid1_corner_lat/deg2rad + grid1_corner_lon = grid1_corner_lon/deg2rad + endif + + if (grid2_units(1:7) == 'degrees' .and. direction == 1) then + grid2_center_lat = grid2_center_lat/deg2rad + grid2_center_lon = grid2_center_lon/deg2rad + grid2_corner_lat = grid2_corner_lat/deg2rad + grid2_corner_lon = grid2_corner_lon/deg2rad + endif + +!----------------------------------------------------------------------- +! +! write mapping data +! +!----------------------------------------------------------------------- + + if (direction == 1) then + itmp1 = nc_srcgrddims_id + itmp2 = nc_dstgrddims_id + else + itmp2 = nc_srcgrddims_id + itmp1 = nc_dstgrddims_id + endif + + ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, + & src_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id, + & dst_mask_int) + call netcdf_error_handler(ncstat) + + deallocate(src_mask_int, dst_mask_int) + + if (direction == 1) then + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + else + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + else + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_srcgrdarea_id + itmp2 = nc_srcgrdfrac_id + itmp3 = nc_dstgrdarea_id + itmp4 = nc_dstgrdfrac_id + else + itmp1 = nc_dstgrdarea_id + itmp2 = nc_dstgrdfrac_id + itmp3 = nc_srcgrdarea_id + itmp4 = nc_srcgrdfrac_id + endif + + if (luse_grid1_area) then + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, + & grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, + & grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts_map1) + call netcdf_error_handler(ncstat) + else + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, + & grid2_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, + & grid1_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts_map2) + call netcdf_error_handler(ncstat) + endif + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine write_remap_scrip + +!*********************************************************************** + + subroutine write_remap_csm(map_name, interp_file, direction) + +!----------------------------------------------------------------------- +! +! writes remap data to a netCDF file using NCAR-CSM conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: + & map_name ! name for mapping + &, interp_file ! filename for remap data + + integer (kind=int_kind), intent(in) :: + & direction ! direction of map (1=grid1 to grid2 + ! 2=grid2 to grid1) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: + & grid1_ctmp ! character temp for grid1 names + &, grid2_ctmp ! character temp for grid2 names + + integer (kind=int_kind) :: + & itmp1 ! integer temp + &, itmp2 ! integer temp + &, itmp3 ! integer temp + &, itmp4 ! integer temp + &, nc_numwgts1_id ! extra netCDF id for additional weights + &, nc_src_isize_id ! extra netCDF id for ni_a + &, nc_src_jsize_id ! extra netCDF id for nj_a + &, nc_dst_isize_id ! extra netCDF id for ni_b + &, nc_dst_jsize_id ! extra netCDF id for nj_b + &, nc_rmpmatrix2_id ! extra netCDF id for high-order remap matrix + + real (kind=dbl_kind), dimension(:),allocatable :: + & wts1 ! CSM wants single array for 1st-order wts + + real (kind=dbl_kind), dimension(:,:),allocatable :: + & wts2 ! write remaining weights in different array + +!----------------------------------------------------------------------- +! +! create netCDF file for mapping and define some global attributes +! +!----------------------------------------------------------------------- + + ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title', + & len_trim(map_name), map_name) + call netcdf_error_handler(ncstat) + + !*** + !*** normalization option + !*** + ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization', + & len_trim(normalize_opt), normalize_opt) + call netcdf_error_handler(ncstat) + + !*** + !*** map method + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method', + & len_trim(map_method), map_method) + call netcdf_error_handler(ncstat) + + !*** + !*** history + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history', + & len_trim(history), history) + call netcdf_error_handler(ncstat) + + !*** + !*** file convention + !*** + convention = 'NCAR-CSM' + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions', + & len_trim(convention), convention) + call netcdf_error_handler(ncstat) + + !*** + !*** source and destination grid names + !*** + + if (direction == 1) then + grid1_ctmp = 'domain_a' + grid2_ctmp = 'domain_b' + else + grid1_ctmp = 'domain_b' + grid2_ctmp = 'domain_a' + endif + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp), + & len_trim(grid1_name), grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp), + & len_trim(grid2_name), grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! prepare netCDF dimension info +! +!----------------------------------------------------------------------- + + !*** + !*** define grid size dimensions + !*** + + if (direction == 1) then + itmp1 = grid1_size + itmp2 = grid2_size + else + itmp1 = grid2_size + itmp2 = grid1_size + endif + + ncstat = nf_def_dim (nc_file_id, 'n_a', itmp1, nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'n_b', itmp2, nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + if (direction == 1) then + itmp1 = grid1_corners + itmp2 = grid2_corners + else + itmp1 = grid2_corners + itmp2 = grid1_corners + endif + + ncstat = nf_def_dim (nc_file_id, 'nv_a', itmp1, nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nv_b', itmp2, nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + if (direction == 1) then + itmp1 = grid1_rank + itmp2 = grid2_rank + else + itmp1 = grid2_rank + itmp2 = grid1_rank + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', + & itmp1, nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', + & itmp2, nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define first two dims as if 2-d cartesian domain + !*** + + if (direction == 1) then + itmp1 = grid1_dims(1) + if (grid1_rank > 1) then + itmp2 = grid1_dims(2) + else + itmp2 = 0 + endif + itmp3 = grid2_dims(1) + if (grid2_rank > 1) then + itmp4 = grid2_dims(2) + else + itmp4 = 0 + endif + else + itmp1 = grid2_dims(1) + if (grid2_rank > 1) then + itmp2 = grid2_dims(2) + else + itmp2 = 0 + endif + itmp3 = grid1_dims(1) + if (grid1_rank > 1) then + itmp4 = grid1_dims(2) + else + itmp4 = 0 + endif + endif + + ncstat = nf_def_dim (nc_file_id, 'ni_a', itmp1, nc_src_isize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nj_a', itmp2, nc_src_jsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'ni_b', itmp3, nc_dst_isize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nj_b', itmp4, nc_dst_jsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define map size dimensions + !*** + + if (direction == 1) then + itmp1 = num_links_map1 + else + itmp1 = num_links_map2 + endif + + ncstat = nf_def_dim (nc_file_id, 'n_s', itmp1, nc_numlinks_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'num_wgts', + & num_wts, nc_numwgts_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_def_dim (nc_file_id, 'num_wgts1', + & num_wts-1, nc_numwgts1_id) + call netcdf_error_handler(ncstat) + endif + + !*** + !*** define grid dimensions + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT, + & 1, nc_srcgrdrank_id, nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT, + & 1, nc_dstgrdrank_id, nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! define all arrays for netCDF descriptors +! +!----------------------------------------------------------------------- + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'yc_a', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'yc_b', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'xc_a', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xc_b', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner lat/lon arrays + !*** + + nc_dims2_id(1) = nc_srcgrdcorn_id + nc_dims2_id(2) = nc_srcgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'yv_a', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xv_a', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_dstgrdcorn_id + nc_dims2_id(2) = nc_dstgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'yv_b', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xv_b', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** CSM wants all in degrees + !*** + + grid1_units = 'degrees' + grid2_units = 'degrees' + + if (direction == 1) then + grid1_ctmp = grid1_units + grid2_ctmp = grid2_units + else + grid1_ctmp = grid2_units + grid2_ctmp = grid1_units + endif + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, + & 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, + & 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_file_id, 'mask_a', NF_INT, + & 1, nc_srcgrdsize_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'mask_b', NF_INT, + & 1, nc_dstgrdsize_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'area_a', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, + & 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'area_b', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, + & 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'frac_a', + & NF_DOUBLE, 1, nc_srcgrdsize_id, + & nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'frac_b', + & NF_DOUBLE, 1, nc_dstgrdsize_id, + & nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define mapping arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'col', + & NF_INT, 1, nc_numlinks_id, + & nc_srcadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'row', + & NF_INT, 1, nc_numlinks_id, + & nc_dstadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'S', + & NF_DOUBLE, 1, nc_numlinks_id, + & nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + nc_dims2_id(1) = nc_numwgts1_id + nc_dims2_id(2) = nc_numlinks_id + + ncstat = nf_def_var (nc_file_id, 'S2', + & NF_DOUBLE, 2, nc_dims2_id, + & nc_rmpmatrix2_id) + call netcdf_error_handler(ncstat) + endif + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! compute integer masks +! +!----------------------------------------------------------------------- + + if (direction == 1) then + allocate (src_mask_int(grid1_size), + & dst_mask_int(grid2_size)) + + where (grid2_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid1_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + else + allocate (src_mask_int(grid2_size), + & dst_mask_int(grid1_size)) + + where (grid1_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid2_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + endif + +!----------------------------------------------------------------------- +! +! change units of lat/lon coordinates if input units different +! from radians. if this is the second mapping, the conversion has +! alread been done. +! +!----------------------------------------------------------------------- + + if (grid1_units(1:7) == 'degrees' .and. direction == 1) then + grid1_center_lat = grid1_center_lat/deg2rad + grid1_center_lon = grid1_center_lon/deg2rad + grid1_corner_lat = grid1_corner_lat/deg2rad + grid1_corner_lon = grid1_corner_lon/deg2rad + endif + + if (grid2_units(1:7) == 'degrees' .and. direction == 1) then + grid2_center_lat = grid2_center_lat/deg2rad + grid2_center_lon = grid2_center_lon/deg2rad + grid2_corner_lat = grid2_corner_lat/deg2rad + grid2_corner_lon = grid2_corner_lon/deg2rad + endif + +!----------------------------------------------------------------------- +! +! write mapping data +! +!----------------------------------------------------------------------- + + if (direction == 1) then + itmp1 = nc_srcgrddims_id + itmp2 = nc_dstgrddims_id + else + itmp2 = nc_srcgrddims_id + itmp1 = nc_dstgrddims_id + endif + + ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, + & src_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id, + & dst_mask_int) + call netcdf_error_handler(ncstat) + + deallocate(src_mask_int, dst_mask_int) + + if (direction == 1) then + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + else + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + else + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_srcgrdarea_id + itmp2 = nc_srcgrdfrac_id + itmp3 = nc_dstgrdarea_id + itmp4 = nc_dstgrdfrac_id + else + itmp1 = nc_dstgrdarea_id + itmp2 = nc_dstgrdfrac_id + itmp3 = nc_srcgrdarea_id + itmp4 = nc_srcgrdfrac_id + endif + + if (luse_grid1_area) then + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + else + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, + & grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, + & grid2_add_map1) + call netcdf_error_handler(ncstat) + + if (num_wts == 1) then + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts_map1) + call netcdf_error_handler(ncstat) + else + allocate(wts1(num_links_map1),wts2(num_wts-1,num_links_map1)) + + wts1 = wts_map1(1,:) + wts2 = wts_map1(2:,:) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts1) + call netcdf_error_handler(ncstat) + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, + & wts2) + call netcdf_error_handler(ncstat) + deallocate(wts1,wts2) + endif + else + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, + & grid2_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, + & grid1_add_map2) + call netcdf_error_handler(ncstat) + + if (num_wts == 1) then + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts_map2) + call netcdf_error_handler(ncstat) + else + allocate(wts1(num_links_map2),wts2(num_wts-1,num_links_map2)) + + wts1 = wts_map2(1,:) + wts2 = wts_map2(2:,:) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, + & wts1) + call netcdf_error_handler(ncstat) + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, + & wts2) + call netcdf_error_handler(ncstat) + deallocate(wts1,wts2) + endif + endif + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine write_remap_csm + +!*********************************************************************** + + subroutine sort_add(add1, add2, weights) + +!----------------------------------------------------------------------- +! +! this routine sorts address and weight arrays based on the +! destination address with the source address as a secondary +! sorting criterion. the method is a standard heap sort. +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common scalar constants + + implicit none + +!----------------------------------------------------------------------- +! +! Input and Output arrays +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(inout), dimension(:) :: + & add1, ! destination address array (num_links) + & add2 ! source address array + + real (kind=dbl_kind), intent(inout), dimension(:,:) :: + & weights ! remapping weights (num_wts, num_links) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & num_links, ! num of links for this mapping + & num_wts, ! num of weights for this mapping + & add1_tmp, add2_tmp, ! temp for addresses during swap + & nwgt, + & lvl, final_lvl, ! level indexes for heap sort levels + & chk_lvl1, chk_lvl2, max_lvl + + real (kind=dbl_kind), dimension(SIZE(weights,DIM=1)) :: + & wgttmp ! temp for holding wts during swap + +!----------------------------------------------------------------------- +! +! determine total number of links to sort and number of weights +! +!----------------------------------------------------------------------- + + num_links = SIZE(add1) + num_wts = SIZE(weights, DIM=1) + +!----------------------------------------------------------------------- +! +! start at the lowest level (N/2) of the tree and sift lower +! values to the bottom of the tree, promoting the larger numbers +! +!----------------------------------------------------------------------- + + do lvl=num_links/2,1,-1 + + final_lvl = lvl + add1_tmp = add1(lvl) + add2_tmp = add2(lvl) + wgttmp(:) = weights(:,lvl) + + !*** + !*** loop until proper level is found for this link, or reach + !*** bottom + !*** + + sift_loop1: do + + !*** + !*** find the largest of the two daughters + !*** + + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1 + + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. + & ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. + & (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif + + !*** + !*** if the parent is greater than both daughters, + !*** the correct level has been found + !*** + + if ((add1_tmp .GT. add1(max_lvl)) .OR. + & ((add1_tmp .EQ. add1(max_lvl)) .AND. + & (add2_tmp .GT. add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl > num_links) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + endif + endif + end do sift_loop1 + end do + +!----------------------------------------------------------------------- +! +! now that the heap has been sorted, strip off the top (largest) +! value and promote the values below +! +!----------------------------------------------------------------------- + + do lvl=num_links,3,-1 + + !*** + !*** move the top value and insert it into the correct place + !*** + + add1_tmp = add1(lvl) + add1(lvl) = add1(1) + + add2_tmp = add2(lvl) + add2(lvl) = add2(1) + + wgttmp(:) = weights(:,lvl) + weights(:,lvl) = weights(:,1) + + !*** + !*** as above this loop sifts the tmp values down until proper + !*** level is reached + !*** + + final_lvl = 1 + + sift_loop2: do + + !*** + !*** find the largest of the two daughters + !*** + + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1 + + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. + & ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. + & (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif + + !*** + !*** if the parent is greater than both daughters, + !*** the correct level has been found + !*** + + if ((add1_tmp > add1(max_lvl)) .OR. + & ((add1_tmp == add1(max_lvl)) .AND. + & (add2_tmp > add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl >= lvl) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + endif + endif + end do sift_loop2 + end do + + !*** + !*** swap the last two entries + !*** + + + add1_tmp = add1(2) + add1(2) = add1(1) + add1(1) = add1_tmp + + add2_tmp = add2(2) + add2(2) = add2(1) + add2(1) = add2_tmp + + wgttmp (:) = weights(:,2) + weights(:,2) = weights(:,1) + weights(:,1) = wgttmp (:) + +!----------------------------------------------------------------------- + + end subroutine sort_add + +!*********************************************************************** + + end module remap_write + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip.f new file mode 100644 index 0000000000000000000000000000000000000000..13475d9535313b4f671628d45be0e9c2e7a09a6e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip.f @@ -0,0 +1,214 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This routine is the driver for computing the addresses and weights +! for interpolating between two grids on a sphere. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: scrip.f,v 1.6 2001/08/21 21:06:44 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + program scrip + +!----------------------------------------------------------------------- + + use kinds_mod ! module defining data types + use constants ! module for common constants + use iounits ! I/O unit manager + use timers ! CPU timers + use grids ! module with grid information + use remap_vars ! common remapping variables + use remap_conservative ! routines for conservative remap + use remap_distance_weight ! routines for dist-weight remap + use remap_bilinear ! routines for bilinear interp + use remap_bicubic ! routines for bicubic interp + use remap_write ! routines for remap output + + implicit none + +!----------------------------------------------------------------------- +! +! input namelist variables +! +!----------------------------------------------------------------------- + + character (char_len) :: + & grid1_file, ! filename of grid file containing grid1 + & grid2_file, ! filename of grid file containing grid2 + & interp_file1, ! filename for output remap data (map1) + & interp_file2, ! filename for output remap data (map2) + & map1_name, ! name for mapping from grid1 to grid2 + & map2_name, ! name for mapping from grid2 to grid1 + & map_method, ! choice for mapping method + & normalize_opt,! option for normalizing weights + & output_opt ! option for output conventions + + integer (kind=int_kind) :: + & nmap ! number of mappings to compute (1 or 2) + + namelist /remap_inputs/ grid1_file, grid2_file, + & interp_file1, interp_file2, + & map1_name, map2_name, num_maps, + & luse_grid1_area, luse_grid2_area, + & map_method, normalize_opt, output_opt, + & restrict_type, num_srch_bins + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, ! dummy counter + & iunit ! unit number for namelist file + +!----------------------------------------------------------------------- +! +! initialize timers +! +!----------------------------------------------------------------------- + + call timers_init + do n=1,max_timers + call timer_clear(n) + end do + +!----------------------------------------------------------------------- +! +! read input namelist +! +!----------------------------------------------------------------------- + + grid1_file = 'unknown' + grid2_file = 'unknown' + interp_file1 = 'unknown' + interp_file2 = 'unknown' + map1_name = 'unknown' + map2_name = 'unknown' + luse_grid1_area = .false. + luse_grid2_area = .false. + num_maps = 2 + map_type = 1 + normalize_opt = 'fracarea' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 900 + + call get_unit(iunit) + open(iunit, file='scrip_in', status='old', form='formatted') + read(iunit, nml=remap_inputs) + call release_unit(iunit) + + select case(map_method) + case ('conservative') + map_type = map_type_conserv + luse_grid_centers = .false. + case ('bilinear') + map_type = map_type_bilinear + luse_grid_centers = .true. + case ('bicubic') + map_type = map_type_bicubic + luse_grid_centers = .true. + case ('distwgt') + map_type = map_type_distwgt + luse_grid_centers = .true. + case default + stop 'unknown mapping method' + end select + + select case(normalize_opt(1:4)) + case ('none') + norm_opt = norm_opt_none + case ('frac') + norm_opt = norm_opt_frcarea + case ('dest') + norm_opt = norm_opt_dstarea + case default + stop 'unknown normalization option' + end select + +!----------------------------------------------------------------------- +! +! initialize grid information for both grids +! +!----------------------------------------------------------------------- + + call grid_init(grid1_file, grid2_file) + + write(stdout, *) ' Computing remappings between: ',grid1_name + write(stdout, *) ' and ',grid2_name + +!----------------------------------------------------------------------- +! +! initialize some remapping variables. +! +!----------------------------------------------------------------------- + + call init_remap_vars + +!----------------------------------------------------------------------- +! +! call appropriate interpolation setup routine based on type of +! remapping requested. +! +!----------------------------------------------------------------------- + + select case(map_type) + case(map_type_conserv) + call remap_conserv + case(map_type_bilinear) + call remap_bilin + case(map_type_distwgt) + call remap_distwgt + case(map_type_bicubic) + call remap_bicub + case default + stop 'Invalid Map Type' + end select + +!----------------------------------------------------------------------- +! +! reduce size of remapping arrays and then write remapping info +! to a file. +! +!----------------------------------------------------------------------- + + if (num_links_map1 /= max_links_map1) then + call resize_remap_vars(1, num_links_map1-max_links_map1) + endif + if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then + call resize_remap_vars(2, num_links_map2-max_links_map2) + endif + + call write_remap(map1_name, map2_name, + & interp_file1, interp_file2, output_opt) + +!----------------------------------------------------------------------- + + end program scrip + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test.f new file mode 100644 index 0000000000000000000000000000000000000000..25e740e4ea9d8a5dc28a09b2685640216e17bb77 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test.f @@ -0,0 +1,981 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this program is a short driver that tests the remappings using +! a simple analytic field. the results are written in netCDF +! format. +! +! CVS: $Id: scrip_test.f,v 1.6 2000/04/19 21:45:09 pwjones Exp $ +! +!----------------------------------------------------------------------- +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + program remap_test + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use iounits ! I/O unit manager + use netcdf_mod ! netcdf I/O stuff + use grids ! module containing grid info + use remap_vars ! module containing remapping info + use remap_mod ! module containing remapping routines + use remap_read ! routines for reading remap files + + implicit none + +!----------------------------------------------------------------------- +! +! input namelist variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & field_choice ! choice of field to be interpolated + + character (char_len) :: + & interp_file, ! filename containing remap data (map1) + & output_file ! filename for test results + + namelist /remap_inputs/ field_choice, interp_file, output_file + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: + & map_name ! name for mapping from grid1 to grid2 + + integer (kind=int_kind) :: ! netCDF ids for files and arrays + & ncstat, nc_outfile_id, + & nc_srcgrdcntrlat_id, nc_srcgrdcntrlon_id, + & nc_dstgrdcntrlat_id, nc_dstgrdcntrlon_id, + & nc_srcgrdrank_id, nc_dstgrdrank_id, + & nc_srcgrdimask_id, nc_dstgrdimask_id, + & nc_srcgrdarea_id, nc_dstgrdarea_id, + & nc_srcgrdfrac_id, nc_dstgrdfrac_id, + & nc_srcarray_id, nc_srcgradlat_id, nc_srcgradlon_id, + & nc_dstarray1_id, nc_dstarray1a_id, nc_dstarray2_id, + & nc_dsterror1_id, nc_dsterror1a_id, nc_dsterror2_id + + integer (kind=int_kind), dimension(:), allocatable :: + & nc_grid1size_id, nc_grid2size_id + +!----------------------------------------------------------------------- + + character (char_len) :: + & dim_name ! netCDF dimension name + + integer (kind=int_kind) :: i,j,n,imin,imax,idiff, + & ip1,im1,jp1,jm1,nx,ny, ! for computing bicub gradients + & in,is,ie,iw,ine,inw,ise,isw, + & iunit ! unit number for namelist file + + integer (kind=int_kind), dimension(:), allocatable :: + & grid1_imask, grid2_imask, grid2_count + + real (kind=dbl_kind) :: + & delew, delns, ! variables for computing bicub gradients + & length ! length scale for cosine hill test field + + real (kind=dbl_kind), dimension(:), allocatable :: + & grid1_array, + & grid1_tmp, + & grad1_lat, + & grad1_lon, + & grad1_latlon, + & grad1_lat_zero, + & grad1_lon_zero, + & grid2_array, + & grid2_err, + & grid2_tmp + +!----------------------------------------------------------------------- +! +! read namelist for file and mapping info +! +!----------------------------------------------------------------------- + + call get_unit(iunit) + open(iunit, file='scrip_test_in', status='old', form='formatted') + read(iunit, nml=remap_inputs) + call release_unit(iunit) + write(*,nml=remap_inputs) + +!----------------------------------------------------------------------- +! +! read remapping data +! +!----------------------------------------------------------------------- + + call read_remap(map_name, interp_file) + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate (grid1_array (grid1_size), + & grid1_tmp (grid1_size), + & grad1_lat (grid1_size), + & grad1_lon (grid1_size), + & grad1_lat_zero (grid1_size), + & grad1_lon_zero (grid1_size), + & grid1_imask (grid1_size), + & grid2_array (grid2_size), + & grid2_err (grid2_size), + & grid2_tmp (grid2_size), + & grid2_imask (grid2_size), + & grid2_count (grid2_size)) + + where (grid1_mask) + grid1_imask = 1 + elsewhere + grid1_imask = 0 + endwhere + where (grid2_mask) + grid2_imask = 1 + elsewhere + grid2_imask = 0 + endwhere + +!----------------------------------------------------------------------- +! +! setup a NetCDF file for output +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset + !*** + + ncstat = nf_create (output_file, NF_CLOBBER, nc_outfile_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, NF_GLOBAL, 'title', + & len_trim(map_name), map_name) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimensions + !*** + + allocate( nc_grid1size_id(grid1_rank), + & nc_grid2size_id(grid2_rank)) + + do n=1,grid1_rank + write(dim_name,1000) 'grid1_dim',n + ncstat = nf_def_dim (nc_outfile_id, dim_name, + & grid1_dims(n), nc_grid1size_id(n)) + call netcdf_error_handler(ncstat) + end do + + do n=1,grid2_rank + write(dim_name,1000) 'grid2_dim',n + ncstat = nf_def_dim (nc_outfile_id, dim_name, + & grid2_dims(n), nc_grid2size_id(n)) + call netcdf_error_handler(ncstat) + end do + 1000 format(a9,i1) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_center_lat', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdcntrlat_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_center_lat', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdcntrlat_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_center_lon', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdcntrlon_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_center_lon', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdcntrlon_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_imask', NF_INT, + & grid1_rank, nc_grid1size_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_imask', NF_INT, + & grid2_rank, nc_grid2size_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_area', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_area', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_frac', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_frac', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define source array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_array', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcarray_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define gradient arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grad_lat', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgradlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'src_grad_lon', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgradlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define destination arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'dst_array1', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstarray1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_array1a', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstarray1a_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_array2', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstarray2_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define error arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'dst_error1', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dsterror1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_error1a', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dsterror1a_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_error2', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dsterror2_id) + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_outfile_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write some grid info +! +!----------------------------------------------------------------------- + + !*** + !*** write grid center latitude array + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdcntrlat_id, + & grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdcntrlat_id, + & grid2_center_lat) + call netcdf_error_handler(ncstat) + + !*** + !*** write grid center longitude array + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdcntrlon_id, + & grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdcntrlon_id, + & grid2_center_lon) + call netcdf_error_handler(ncstat) + + !*** + !*** write grid mask + !*** + + ncstat = nf_put_var_int(nc_outfile_id, nc_srcgrdimask_id, + & grid1_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_outfile_id, nc_dstgrdimask_id, + & grid2_imask) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdarea_id, + & grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdarea_id, + & grid2_area) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdfrac_id, + & grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdfrac_id, + & grid2_frac) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! set up fields for test cases based on user choice +! +!----------------------------------------------------------------------- + + select case (field_choice) + case(1) !*** cosine hill at lon=pi and lat=0 + + length = 0.1*pi2 + + grid1_array = cos(grid1_center_lat)*cos(grid1_center_lon) + grid2_array = cos(grid2_center_lat)*cos(grid2_center_lon) + + grid1_tmp = acos(-grid1_array)/length + grid2_tmp = acos(-grid2_array)/length + + where (grid1_tmp <= one) + grad1_lat = (pi/length)*sin(pi*grid1_tmp)* + & sin(grid1_center_lat)*cos(grid1_center_lon)/ + & sqrt(one-grid1_array**2) + grad1_lon = (pi/length)*sin(pi*grid1_tmp)* + & sin(grid1_center_lon)/ + & sqrt(one-grid1_array**2) + grid1_array = two + cos(pi*grid1_tmp) + elsewhere + grid1_array = one + grad1_lat = zero + grad1_lon = zero + endwhere + + where (grid2_tmp <= one) + grid2_array = two + cos(pi*grid2_tmp) + elsewhere + grid2_array = one + endwhere + + where (.not. grid1_mask) + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (grid2_frac < .001) grid2_array = zero + + case(2) !*** pseudo-spherical harmonic l=2,m=2 + + where (grid1_mask) + grid1_array = two + cos(grid1_center_lat)**2* + & cos(two*grid1_center_lon) + grad1_lat = -sin(two*grid1_center_lat)* + & cos(two*grid1_center_lon) + grad1_lon = -two*cos(grid1_center_lat)* + & sin(two*grid1_center_lon) + elsewhere + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (grid2_frac > .001) + grid2_array = two + cos(grid2_center_lat)**2* + & cos(two*grid2_center_lon) + elsewhere + grid2_array = zero + end where + + case(3) !*** pseudo-spherical harmonic l=32, m=16 + + where (grid1_mask) + grid1_array = two + sin(two*grid1_center_lat)**16* + & cos(16.*grid1_center_lon) + grad1_lat = 32.*sin(two*grid1_center_lat)**15* + & cos(two*grid1_center_lat)* + & cos(16.*grid1_center_lon) + grad1_lon = -32.*sin(two*grid1_center_lat)**15* + & sin(grid1_center_lat)* + & sin(16.*grid1_center_lon) + elsewhere + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (grid2_frac > .001) + grid2_array = two + sin(two*grid2_center_lat)**16* + & cos(16.*grid2_center_lon) + elsewhere + grid2_array = zero + end where + + case default + + stop 'Bad choice for field to interpolate' + + end select + +!----------------------------------------------------------------------- +! +! if bicubic, we need 3 gradients in logical space +! +!----------------------------------------------------------------------- + + if (map_type == map_type_bicubic) then + allocate (grad1_latlon (grid1_size)) + + nx = grid1_dims(1) + ny = grid1_dims(2) + + do n=1,grid1_size + + grad1_lat(n) = zero + grad1_lon(n) = zero + grad1_latlon(n) = zero + + if (grid1_mask(n)) then + + delew = half + delns = half + + j = (n-1)/nx + 1 + i = n - (j-1)*nx + + ip1 = i+1 + im1 = i-1 + jp1 = j+1 + jm1 = j-1 + + if (ip1 > nx) ip1 = ip1 - nx + if (im1 < 1 ) im1 = nx + if (jp1 > ny) then + jp1 = j + delns = one + endif + if (jm1 < 1 ) then + jm1 = j + delns = one + endif + + in = (jp1-1)*nx + i + is = (jm1-1)*nx + i + ie = (j -1)*nx + ip1 + iw = (j -1)*nx + im1 + + ine = (jp1-1)*nx + ip1 + inw = (jp1-1)*nx + im1 + ise = (jm1-1)*nx + ip1 + isw = (jm1-1)*nx + im1 + + !*** compute i-gradient + + if (.not. grid1_mask(ie)) then + ie = n + delew = one + endif + if (.not. grid1_mask(iw)) then + iw = n + delew = one + endif + + grad1_lat(n) = delew*(grid1_array(ie) - grid1_array(iw)) + + !*** compute j-gradient + + if (.not. grid1_mask(in)) then + in = n + delns = one + endif + if (.not. grid1_mask(is)) then + is = n + delns = one + endif + + grad1_lon(n) = delns*(grid1_array(in) - grid1_array(is)) + + !*** compute ij-gradient + + delew = half + if (jp1 == j .or. jm1 == j) then + delns = one + else + delns = half + endif + + if (.not. grid1_mask(ine)) then + if (in /= n) then + ine = in + delew = one + else if (ie /= n) then + ine = ie + inw = iw + if (inw == n) delew = one + delns = one + else + ine = n + inw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(inw)) then + if (in /= n) then + inw = in + delew = one + else if (iw /= n) then + inw = iw + ine = ie + if (ie == n) delew = one + delns = one + else + inw = n + ine = ie + delew = one + delns = one + endif + endif + + grad1_lat_zero(n) = delew*(grid1_array(ine) - + & grid1_array(inw)) + + if (.not. grid1_mask(ise)) then + if (is /= n) then + ise = is + delew = one + else if (ie /= n) then + ise = ie + isw = iw + if (isw == n) delew = one + delns = one + else + ise = n + isw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(isw)) then + if (is /= n) then + isw = is + delew = one + else if (iw /= n) then + isw = iw + ise = ie + if (ie == n) delew = one + delns = one + else + isw = n + ise = ie + delew = one + delns = one + endif + endif + + grad1_lon_zero(n) = delew*(grid1_array(ise) - + & grid1_array(isw)) + + grad1_latlon(n) = delns*(grad1_lat_zero(n) - + & grad1_lon_zero(n)) + + endif + enddo + endif + +!----------------------------------------------------------------------- +! +! test a first-order map from grid1 to grid2 +! +!----------------------------------------------------------------------- + + grad1_lat_zero = zero + grad1_lon_zero = zero + + if (map_type /= map_type_bicubic) then + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_array) + else + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_array, src_grad1=grad1_lat, + & src_grad2=grad1_lon, + & src_grad3=grad1_latlon) + endif + + if (map_type == map_type_conserv) then + select case (norm_opt) + case (norm_opt_none) + grid2_err = grid2_frac*grid2_area + where (grid2_err /= zero) + grid2_tmp = grid2_tmp/grid2_err + else where + grid2_tmp = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_tmp = grid2_tmp/grid2_frac + else where + grid2_tmp = zero + end where + end select + end if + + where (grid2_frac > .999) + grid2_err = (grid2_tmp - grid2_array)/grid2_array + elsewhere + grid2_err = zero + end where + + print *,'First order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_tmp ),maxval(grid2_tmp ) + print *,' Err2 min,max: ',minval(grid2_err),maxval(grid2_err) + print *,' Err2 mean: ',sum(abs(grid2_err))/ + & count(grid2_frac > .999) + + !*** + !*** Conservation Test + !*** + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_tmp *grid2_area*grid2_frac) + +!----------------------------------------------------------------------- +! +! write results to NetCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcarray_id, + & grid1_array) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstarray1_id, + & grid2_tmp ) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dsterror1_id, + & grid2_err) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! for conservative mappings: +! test a second-order map from grid1 to grid2 with only lat grads +! +!----------------------------------------------------------------------- + + if (map_type == map_type_conserv) then + + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_array, src_grad1=grad1_lat, + & src_grad2=grad1_lon_zero) + + select case (norm_opt) + case (norm_opt_none) + grid2_err = grid2_frac*grid2_area + where (grid2_err /= zero) + grid2_tmp = grid2_tmp/grid2_err + else where + grid2_tmp = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_tmp = grid2_tmp/grid2_frac + else where + grid2_tmp = zero + end where + end select + + where (grid2_frac > .999) + grid2_err = (grid2_tmp - grid2_array)/grid2_array + elsewhere + grid2_err = zero + end where + + print *,'Second order mapping from grid1 to grid2 (lat only):' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array), + & maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_tmp ), + & maxval(grid2_tmp ) + print *,' Err2 min,max: ',minval(grid2_err),maxval(grid2_err) + print *,' Err2 mean: ',sum(abs(grid2_err))/ + & count(grid2_frac > .999) + + !*** + !*** Conservation Test + !*** + + print *,'Conservation:' + print *,'Grid1 Integral = ', + & sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ', + & sum(grid2_tmp *grid2_area*grid2_frac) + +!----------------------------------------------------------------------- +! +! write results to NetCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgradlat_id, + & grad1_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstarray1a_id, + & grid2_tmp ) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dsterror1a_id, + & grid2_err) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! for conservative mappings: +! test a second-order map from grid1 to grid2 +! +!----------------------------------------------------------------------- + + call remap(grid2_tmp,wts_map1,grid2_add_map1,grid1_add_map1, + & grid1_array, src_grad1=grad1_lat, + & src_grad2=grad1_lon) + + select case (norm_opt) + case (norm_opt_none) + grid2_err = grid2_frac*grid2_area + where (grid2_err /= zero) + grid2_tmp = grid2_tmp/grid2_err + else where + grid2_tmp = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_tmp = grid2_tmp/grid2_frac + else where + grid2_tmp = zero + end where + end select + + where (grid2_frac > .999) + grid2_err = (grid2_tmp - grid2_array)/grid2_array + elsewhere + grid2_err = zero + end where + + print *,'Second order mapping from grid1 to grid2:' + print *,'-----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array), + & maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_tmp ), + & maxval(grid2_tmp ) + print *,' Err2 min,max: ',minval(grid2_err),maxval(grid2_err) + print *,' Err2 mean: ',sum(abs(grid2_err))/ + & count(grid2_frac > .999) + + !*** + !*** Conservation Test + !*** + + print *,'Conservation:' + print *,'Grid1 Integral = ', + & sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ', + & sum(grid2_tmp *grid2_area*grid2_frac) + +!----------------------------------------------------------------------- +! +! write results to NetCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgradlon_id, + & grad1_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstarray2_id, + & grid2_tmp ) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dsterror2_id, + & grid2_err) + call netcdf_error_handler(ncstat) + + endif + +!----------------------------------------------------------------------- +! +! close netCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_outfile_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! calculate some statistics +! +!----------------------------------------------------------------------- + + grid2_count = zero + grid2_tmp = zero + grid2_err = zero + + print *,'number of sparse matrix entries ',num_links_map1 + do n=1,num_links_map1 + grid2_count(grid2_add_map1(n)) = + & grid2_count(grid2_add_map1(n)) + 1 + if (wts_map1(1,n) > one .or. wts_map1(1,n) < zero) then + grid2_tmp(grid2_add_map1(n)) = + & grid2_tmp(grid2_add_map1(n)) + 1 + grid2_err(grid2_add_map1(n)) = max(abs(wts_map1(1,n)), + & grid2_err(grid2_add_map1(n)) ) + endif + end do + + do n=1,grid2_size + if (grid2_tmp(n) > zero) print *,n,grid2_err(n) + end do + + imin = minval(grid2_count, mask=(grid2_count > 0)) + imax = maxval(grid2_count) + idiff = (imax - imin)/10 + 1 + print *,'total number of dest cells ',grid2_size + print *,'number of cells participating in remap ', + & count(grid2_count > zero) + print *,'min no of entries/row = ',imin + print *,'max no of entries/row = ',imax + + imax = imin + idiff + do n=1,10 + print *,'num of rows with entries between ',imin,' - ',imax-1, + & count(grid2_count >= imin .and. grid2_count < imax) + imin = imin + idiff + imax = imax + idiff + end do + +!----------------------------------------------------------------------- + + end program remap_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test_repeat.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test_repeat.f new file mode 100644 index 0000000000000000000000000000000000000000..e273baf044e1194370db732d88415783ec125b49 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/scrip_test_repeat.f @@ -0,0 +1,709 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this program is a short driver that tests the remappings using +! a simple analytic field. the results are written in netCDF +! format. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: scrip_test_repeat.f,v 1.3 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + program remap_test_repeat + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use iounits ! I/O unit manager + use netcdf_mod ! netcdf I/O stuff + use grids ! module containing grid info + use remap_vars ! module containing remapping info + + implicit none + +!----------------------------------------------------------------------- +! +! interface for remap routine +! +!----------------------------------------------------------------------- + + interface + subroutine remap(dst_array, map_wts, dst_add, src_add, + & src_array, src_grad1, src_grad2, src_grad3) + + use kinds_mod + use constants + + implicit none + + integer (kind=int_kind), dimension(:), intent(in) :: + & dst_add, src_add + + real (kind=dbl_kind), dimension(:,:), intent(in) :: map_wts + + real (kind=dbl_kind), dimension(:), intent(in) :: src_array + + real (kind=dbl_kind), dimension(:), intent(in), optional :: + & src_grad1, src_grad2, src_grad3 + + real (kind=dbl_kind), dimension(:), intent(inout) :: dst_array + + end subroutine remap + end interface + +!----------------------------------------------------------------------- +! +! input namelist variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: + & field_choice, ! choice of field to be interpolated + & num_repeats ! number of times to repeat remappings + + character (char_len) :: + & interp_file1, ! filename containing remap data (map1) + & interp_file2, ! filename containing remap data (map2) + & output_file ! filename containing output test data + + namelist /remap_inputs/ field_choice, num_repeats, + & interp_file1, interp_file2, output_file + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: + & map_name1, ! name for mapping from grid1 to grid2 + & map_name2 ! name for mapping from grid2 to grid1 + + integer (kind=int_kind) :: ! netCDF ids for files and arrays + & n, ncstat, nc_outfile_id, + & nc_srcgrdcntrlat_id, nc_srcgrdcntrlon_id, + & nc_dstgrdcntrlat_id, nc_dstgrdcntrlon_id, + & nc_srcgrdrank_id, nc_dstgrdrank_id, + & nc_srcgrdimask_id, nc_dstgrdimask_id, + & nc_srcgrdarea_id, nc_dstgrdarea_id, + & nc_srcgrdfrac_id, nc_dstgrdfrac_id, + & nc_srcarray_id, nc_srcgradlat_id, nc_srcgradlon_id, + & nc_dstarray1_id, nc_dstarray2_id, + & nc_dsterror1_id, nc_dsterror2_id + + integer (kind=int_kind), dimension(:), allocatable :: + & nc_grid1size_id, nc_grid2size_id + +!----------------------------------------------------------------------- + + character (char_len) :: + & dim_name ! netCDF dimension name + + integer (kind=int_kind) :: i,j,n, + & iunit ! unit number for namelist file + + integer (kind=int_kind), dimension(:), allocatable :: + & grid1_imask, grid2_imask + + real (kind=dbl_kind) :: + & length ! length scale for cosine hill test field + + real (kind=dbl_kind), dimension(:), allocatable :: + & grid1_array, + & grid1_tmp, + & grad1_lat, + & grad1_lon, + & grid2_array, + & grid2_err, + & grid2_tmp, + & grad2_lat, + & grad2_lon + +!----------------------------------------------------------------------- +! +! read namelist for file and mapping info +! +!----------------------------------------------------------------------- + + call get_unit(iunit) + open(iunit, file='repeat_test_in', status='old', form='formatted') + read(iunit, nml=remap_inputs) + call release_unit(iunit) + write(*,nml=remap_inputs) + +!----------------------------------------------------------------------- +! +! read remapping data +! +!----------------------------------------------------------------------- + + num_maps = 2 + + call read_remap(map_name1, map_name2, interp_file1, interp_file2) + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate (grid1_array (grid1_size), + & grid1_tmp (grid1_size), + & grad1_lat (grid1_size), + & grad1_lon (grid1_size), + & grid1_imask (grid1_size), + & grid2_array (grid2_size), + & grid2_err (grid2_size), + & grid2_tmp (grid2_size), + & grad2_lat (grid2_size), + & grad2_lon (grid2_size), + & grid2_imask (grid2_size)) + + where (grid1_mask) + grid1_imask = 1 + elsewhere + grid1_imask = 0 + endwhere + where (grid2_mask) + grid2_imask = 1 + elsewhere + grid2_imask = 0 + endwhere + +!----------------------------------------------------------------------- +! +! setup a NetCDF file for output +! +!----------------------------------------------------------------------- + + !*** + !*** create netCDF dataset + !*** + + ncstat = nf_create (output_file, NF_CLOBBER, nc_outfile_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, NF_GLOBAL, 'title', + & len_trim(map_name1), map_name1) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid size dimensions + !*** + + allocate( nc_grid1size_id(grid1_rank), + & nc_grid2size_id(grid2_rank)) + + do n=1,grid1_rank + write(dim_name,1000) 'grid1_dim',n + ncstat = nf_def_dim (nc_outfile_id, dim_name, + & grid1_dims(n), nc_grid1size_id(n)) + call netcdf_error_handler(ncstat) + end do + + do n=1,grid2_rank + write(dim_name,1000) 'grid2_dim',n + ncstat = nf_def_dim (nc_outfile_id, dim_name, + & grid2_dims(n), nc_grid2size_id(n)) + call netcdf_error_handler(ncstat) + end do + 1000 format(a9,i1) + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_center_lat', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdcntrlat_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_center_lat', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdcntrlat_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_center_lon', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdcntrlon_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_center_lon', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdcntrlon_id, + & 'units', 7, 'radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_imask', NF_INT, + & grid1_rank, nc_grid1size_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_srcgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_imask', NF_INT, + & grid2_rank, nc_grid2size_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_outfile_id, nc_dstgrdimask_id, + & 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_area', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_area', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grid_frac', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_grid_frac', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define source array + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_array', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcarray_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define gradient arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'src_grad_lat', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgradlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'src_grad_lon', + & NF_DOUBLE, grid1_rank, nc_grid1size_id, + & nc_srcgradlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define destination arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'dst_array1', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstarray1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_array2', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dstarray2_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define error arrays + !*** + + ncstat = nf_def_var (nc_outfile_id, 'dst_error1', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dsterror1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_outfile_id, 'dst_error2', + & NF_DOUBLE, grid2_rank, nc_grid2size_id, + & nc_dsterror2_id) + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_outfile_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! write some grid info +! +!----------------------------------------------------------------------- + + !*** + !*** write grid center latitude array + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdcntrlat_id, + & grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdcntrlat_id, + & grid2_center_lat) + call netcdf_error_handler(ncstat) + + !*** + !*** write grid center longitude array + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdcntrlon_id, + & grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdcntrlon_id, + & grid2_center_lon) + call netcdf_error_handler(ncstat) + + !*** + !*** write grid mask + !*** + + ncstat = nf_put_var_int(nc_outfile_id, nc_srcgrdimask_id, + & grid1_imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_outfile_id, nc_dstgrdimask_id, + & grid2_imask) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdarea_id, + & grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdarea_id, + & grid2_area) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgrdfrac_id, + & grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstgrdfrac_id, + & grid2_frac) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! set up fields for test cases based on user choice +! +!----------------------------------------------------------------------- + + select case (field_choice) + case(1) !*** cosine hill at lon=pi and lat=0 + + length = 0.1*pi2 + + grid1_array = cos(grid1_center_lat)*cos(grid1_center_lon) + grid2_array = cos(grid2_center_lat)*cos(grid2_center_lon) + + grid1_tmp = acos(-grid1_array)/length + grid2_tmp = acos(-grid2_array)/length + + where (grid1_tmp <= one) + grad1_lat = (pi/length)*sin(pi*grid1_tmp)* + & sin(grid1_center_lat)*cos(grid1_center_lon)/ + & sqrt(one-grid1_array**2) + grad1_lon = (pi/length)*sin(pi*grid1_tmp)* + & sin(grid1_center_lon)/ + & sqrt(one-grid1_array**2) + grid1_array = two + cos(pi*grid1_tmp) + elsewhere + grid1_array = one + grad1_lat = zero + grad1_lon = zero + endwhere + + where (grid2_tmp <= one) + grad2_lat = (pi/length)*sin(pi*grid2_tmp)* + & sin(grid2_center_lat)*cos(grid2_center_lon)/ + & sqrt(one-grid2_array**2) + grad2_lon = (pi/length)*sin(pi*grid2_tmp)* + & sin(grid2_center_lon)/ + & sqrt(one-grid2_array**2) + grid2_array = two + cos(pi*grid2_tmp) + elsewhere + grid2_array = one + grad2_lat = zero + grad2_lon = zero + endwhere + + where (.not. grid1_mask) + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (.not. grid2_mask) + grid2_array = zero + grad2_lat = zero + grad2_lon = zero + end where + + case(2) !*** pseudo-spherical harmonic l=2,m=2 + + where (grid1_mask) + grid1_array = two + cos(grid1_center_lat)**2* + & cos(two*grid1_center_lon) + grad1_lat = -sin(two*grid1_center_lat)* + & cos(two*grid1_center_lon) + grad1_lon = -two*cos(grid1_center_lat)* + & sin(two*grid1_center_lon) + elsewhere + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (grid2_mask) + grid2_array = two + cos(grid2_center_lat)**2* + & cos(two*grid2_center_lon) + grad2_lat = -sin(two*grid2_center_lat)* + & cos(two*grid2_center_lon) + grad2_lon = -two*cos(grid2_center_lat)* + & sin(two*grid2_center_lon) + elsewhere + grid2_array = zero + grad2_lat = zero + grad2_lon = zero + end where + + case(3) !*** pseudo-spherical harmonic l=32, m=16 + + where (grid1_mask) + grid1_array = two + sin(two*grid1_center_lat)**16* + & cos(16.*grid1_center_lon) + grad1_lat = 32.*sin(two*grid1_center_lat)**15* + & cos(two*grid1_center_lat)* + & cos(16.*grid1_center_lon) + grad1_lon = -32.*sin(two*grid1_center_lat)**15* + & sin(grid1_center_lat)* + & sin(16.*grid1_center_lon) + elsewhere + grid1_array = zero + grad1_lat = zero + grad1_lon = zero + end where + + where (grid2_mask) + grid2_array = two + sin(two*grid2_center_lat)**16* + & cos(16.*grid2_center_lon) + grad2_lat = 32.*sin(two*grid2_center_lat)**15* + & cos(two*grid2_center_lat)* + & cos(16.*grid2_center_lon) + grad2_lon = -32.*sin(two*grid2_center_lat)**15* + & sin(grid2_center_lat)* + & sin(16.*grid2_center_lon) + elsewhere + grid2_array = zero + grad2_lat = zero + grad2_lon = zero + end where + + case default + + stop 'Bad choice for field to interpolate' + + end select + +!----------------------------------------------------------------------- +! +! test repeated first-order maps between grid1 and grid2 +! +!----------------------------------------------------------------------- + + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_array) + do n=1,num_repeats + call remap(grid1_tmp, wts_map2, grid1_add_map2, grid2_add_map2, + & grid2_tmp) + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_tmp) + end do + + where (grid2_frac > .999) + grid2_err = (grid2_tmp - grid2_array)/grid2_array + elsewhere + grid2_err = zero + end where + + print *,'First order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_tmp ),maxval(grid2_tmp ) + print *,' Err2 min,max: ',minval(grid2_err),maxval(grid2_err) + print *,' Err2 mean: ',sum(abs(grid2_err))/ + & count(grid2_frac > .001) + + !*** + !*** Conservation Test + !*** + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_tmp *grid2_area*grid2_frac) + +!----------------------------------------------------------------------- +! +! write results to NetCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcarray_id, + & grid1_array) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstarray1_id, + & grid2_tmp ) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dsterror1_id, + & grid2_err) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! test repeated second-order mapppings between grid1 and grid2 +! +!----------------------------------------------------------------------- + + if (num_wts > 1) then + + call remap(grid2_tmp , wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_array, src_grad1=grad1_lat, + & src_grad2=grad1_lon) + + do n=1,num_repeats + call remap(grid1_tmp, wts_map2, grid1_add_map2, grid2_add_map2, + & grid2_tmp, src_grad1=grad2_lat, + & src_grad2=grad2_lon) + + call remap(grid2_tmp, wts_map1, grid2_add_map1, grid1_add_map1, + & grid1_tmp, src_grad1=grad1_lat, + & src_grad2=grad1_lon) + + end do + + where (grid2_frac > .999) + grid2_err = (grid2_tmp - grid2_array)/grid2_array + elsewhere + grid2_err = zero + end where + + print *,'Second order mapping from grid1 to grid2:' + print *,'-----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_tmp ),maxval(grid2_tmp ) + print *,' Err2 min,max: ',minval(grid2_err),maxval(grid2_err) + print *,' Err2 mean: ',sum(abs(grid2_err))/ + & count(grid2_frac > .001) + + !*** + !*** Conservation Test + !*** + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_tmp *grid2_area*grid2_frac) + +!----------------------------------------------------------------------- +! +! write results to NetCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_put_var_double(nc_outfile_id, nc_srcgradlon_id, + & grad1_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dstarray2_id, + & grid2_tmp ) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_outfile_id, nc_dsterror2_id, + & grid2_err) + call netcdf_error_handler(ncstat) + + endif + +!----------------------------------------------------------------------- +! +! close netCDF file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_outfile_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end program remap_test_repeat + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/timers.f b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/timers.f new file mode 100644 index 0000000000000000000000000000000000000000..5304964c42b6beda4035a3fafe813483ca42054b --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/SCRIP1.4/source/timers.f @@ -0,0 +1,343 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module uses F90 cpu time routines to allowing setting of +! multiple CPU timers. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: timers.f,v 1.2 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module timers + +!----------------------------------------------------------------------- + + use kinds_mod + + implicit none + + integer (kind=int_kind), parameter :: + & max_timers = 99 ! max number of timers allowed + + integer (kind=int_kind), save :: + & cycles_max ! max value of clock allowed by system + + integer (kind=int_kind), dimension(max_timers), save :: + & cycles1, ! cycle number at start for each timer + & cycles2 ! cycle number at stop for each timer + + real (kind=real_kind), save :: + & clock_rate ! clock_rate in seconds for each cycle + + real (kind=real_kind), dimension(max_timers), save :: + & cputime ! accumulated cpu time in each timer + + character (len=8), dimension(max_timers), save :: + & status ! timer status string + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine timer_check(timer) + +!----------------------------------------------------------------------- +! +! This routine checks a given timer. This is primarily used to +! periodically accumulate time in the timer to prevent timer cycles +! from wrapping around max_cycles. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'running') then + call timer_stop (timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end subroutine timer_check + +!*********************************************************************** + + subroutine timer_clear(timer) + +!----------------------------------------------------------------------- +! +! This routine resets a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- + + cputime(timer) = 0.0_real_kind ! clear the timer + +!----------------------------------------------------------------------- + + end subroutine timer_clear + +!*********************************************************************** + + function timer_get(timer) + +!----------------------------------------------------------------------- +! +! This routine returns the result of a given timer. This can be +! called instead of timer_print so that the calling routine can +! print it in desired format. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- +! +! Output Variables: +! +!----------------------------------------------------------------------- + + real (kind=real_kind) :: + & timer_get ! accumulated cputime in given timer + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'stopped') then + timer_get = cputime(timer) + else + call timer_stop(timer) + timer_get = cputime(timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end function timer_get + +!*********************************************************************** + + subroutine timer_print(timer) + +!----------------------------------------------------------------------- +! +! This routine prints the accumulated cpu time in given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- + + !--- + !--- print the cputime accumulated for timer + !--- make sure timer is stopped + !--- + + if (status(timer) .eq. 'stopped') then + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") + & timer,cputime(timer) + else + call timer_stop(timer) + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") + & timer,cputime(timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end subroutine timer_print + +!*********************************************************************** + + subroutine timer_start(timer) + +!----------------------------------------------------------------------- +! +! This routine starts a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- + + !--- + !--- Start the timer and change timer status. + !--- + + if (status(timer) .eq. 'stopped') then + call system_clock(count=cycles1(timer)) + status(timer) = 'running' + endif + +!----------------------------------------------------------------------- + + end subroutine timer_start + +!*********************************************************************** + + subroutine timer_stop(timer) + +!----------------------------------------------------------------------- +! +! This routine stops a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: + & timer ! timer number + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'running') then + + !--- + !--- Stop the desired timer. + !--- + + call system_clock(count=cycles2(timer)) + + !--- + !--- check and correct for cycle wrapping + !--- + + if (cycles2(timer) .ge. cycles1(timer)) then + cputime(timer) = cputime(timer) + clock_rate* + & (cycles2(timer) - cycles1(timer)) + else + cputime(timer) = cputime(timer) + clock_rate* + & (cycles2(timer) - cycles1(timer) + cycles_max) + endif + + !--- + !--- Change timer status. + !--- + + status(timer)='stopped' + + endif + +!----------------------------------------------------------------------- + + end subroutine timer_stop + +!*********************************************************************** + + subroutine timers_init + +!----------------------------------------------------------------------- +! +! This routine initializes some machine parameters necessary for +! computing cpu time from F90 intrinsics. +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: cycles ! count rate return by sys_clock + +!----------------------------------------------------------------------- + + !--- + !--- Initialize timer arrays and clock_rate. + !--- + + clock_rate = 0.0_real_kind + cycles1 = 0 + cycles2 = 0 + cputime = 0.0_real_kind + status = 'stopped' + + !--- + !--- Call F90 intrinsic system_clock to determine clock rate + !--- and maximum cycles. If no clock available, print message. + !--- + + call system_clock(count_rate=cycles, count_max=cycles_max) + + if (cycles /= 0) then + clock_rate = 1.0_real_kind/real(cycles) + else + clock_rate = 0.0_real_kind + print *, '--- No system clock available ---' + endif + +!----------------------------------------------------------------------- + + end subroutine timers_init + +!*********************************************************************** + + end module timers + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/bin/freeform.py b/V4.0/nemo_sources/tools/WEIGHTS/bin/freeform.py new file mode 100755 index 0000000000000000000000000000000000000000..94f6c9fa348a0e99b48c3f7c1912a44305e479e7 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/bin/freeform.py @@ -0,0 +1,115 @@ +#!/usr/bin/env python2.6 + +import os +import shutil + +def freer(oldname, newname, fdir, edits): + + fin = file(os.path.join(fdir,oldname)) + lines = fin.readlines() + fin.close() + + if not os.path.exists('src'): + print "creating src directory" + os.mkdir('src') + fout = file(os.path.join('src',newname), 'w') + + lastline = None + for nextline in lines: + for edit in edits: + nextline = nextline.replace(edit[0],edit[1]) + if nextline.strip().startswith('&'): + parts = lastline.split('!') + if parts[0].endswith('\n'): + parts[0] = parts[0].replace('\n',' &\n') + else: + parts[0] = parts[0] + ' & ' + lastline = '!'.join(parts) + nextline = nextline.replace('&',' ') + if lastline is not None: + fout.write(lastline) + lastline = nextline + + # - write out last line (this assumes it is not a continuation line) + fout.write(lastline) + +def scrip(adir, apairs, edits=[]): + + if not os.path.exists('src'): + print "creating src directory" + os.mkdir('src') + + for (f1,f2) in apairs: + if not f2.endswith('.f90'): + shutil.copy(os.path.join(adir,f1), os.path.join('src',f2)) + else: + freer(f1,f2,adir,edits) + +if __name__ == "__main__": + + # - changes to scrip routines made here + + pairs = [('constants.f', 'constants.f90'), + ('copyright', 'copyright'), + ('grids.f', 'grids.f90'), + ('iounits.f', 'iounits.f90'), + ('kinds_mod.f', 'kinds_mod.f90'), + ('netcdf.f', 'netcdf_mod.f90'), + ('remap.f', 'remap.f90'), + ('remap_bicubic.f', 'remap_bicubic.f90'), + ('remap_bilinear.f', 'remap_bilinear.f90'), + ('remap_conserv.f', 'remap_conserv.f90'), + ('remap_distwgt.f', 'remap_distwgt.f90'), + ('remap_read.f', 'remap_read.f90'), + ('remap_vars.f', 'remap_vars.f90'), + ('remap_write.f', 'remap_write.f90'), + ('timers.f', 'timers.f90')] + + # - add some edits + # - note that this is very crude method since every line is inspected for the first string + # - in every input file + # - you have been warned! + + ed1 = [" .and."] + ed2 = ["subroutine netcdf_error_handler(istat, mess)"] + ed3 = [" & istat ! integer status returned by netCDF function call", + " character (len=*), intent(in), optional :: mess"] + ed4 = [" if (present(mess)) then", + " print *,'Error in netCDF: ',nf_strerror(istat), 'Message: ',mess", + " else", + " print *,'Error in netCDF: ',nf_strerror(istat)", + " endif"] + + edits = [(". and.",'\n'.join(ed1)), + ("subroutine netcdf_error_handler(istat)", '\n'.join(ed2)), + (" & istat ! integer status returned by netCDF function call", '\n'.join(ed3)), + (" print *,'Error in netCDF: ',nf_strerror(istat)", '\n'.join(ed4)) + ] + scrip('SCRIP1.4/source', pairs, edits) + + + # - on to NOCS routines + + pairs = [('scrip.F90', 'scrip.F90'), + ('scripgrid.F90', 'scripgrid.F90'), + ('scripgrid_mod.F90', 'scripgrid_mod.F90'), + ('scripinterp.F90', 'scripinterp.F90'), + ('scripinterp_mod.F90', 'scripinterp_mod.F90'), + ('scripshape.F90', 'scripshape.F90')] + scrip('nocsutil', pairs) + + changes = """ + SCRIP code, version 1.4, from Los Alamos National Laboratory (http://climate.lanl.gov/Software/SCRIP) + + Changes made at NOCS for inclusion of weights generation code in NEMO 3.3 and later: + + - File extensions changed from '.f' to '.f90' + - File netcdf.f renamed as netcdf_mod.f90 to avoid clash with netcdf library module filename + - File netcdf.f modified to add error message to netcdf_error_handler + - Small bug in remap_conserv when using gfortran compiler: replace ". and." with " .and." + - continuation lines reformatted with '&' moved from the start of the continuation line to + the end of the line before + """ + fp = file("src/CHANGES_BY_NOCS","w") + fp.write(changes) + fp.close() diff --git a/V4.0/nemo_sources/tools/WEIGHTS/namelist_bicub b/V4.0/nemo_sources/tools/WEIGHTS/namelist_bicub new file mode 100644 index 0000000000000000000000000000000000000000..904a9cdfae748e02ecc95bc2b75340deb5432dfa --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/namelist_bicub @@ -0,0 +1,101 @@ +&comments + ----------------------------------------------------------------------------------- + - grid_inputs holds parameters for the scripgrid routine which reformats information + about the input grids + - scripgrid always needs a coordinates.nc file in the + current directory and creates the remapped grid file correspondingly + - it uses the following namelist block to determine its actions + method: only 'regular' is yet implemented, this assumes a cartesian grid + input_lon: name of longitude variable in the input_file + input_lat: name of latitude variable in the input_file + nemo_lon: name of longitude variable in the coordinates.nc + nemo_lat: name of latitude variable in the coordinates.nc +/ +&grid_inputs + input_file = 'u_10.15JUNE2009_fill.nc' + nemo_file = 'coordinates_nordic1.nc' + datagrid_file = 'remap_core2_grid.nc' + nemogrid_file = 'remap_nordic1_grid.nc' + method = 'regular' + input_lon = 'lon' + input_lat = 'lat' + nemo_lon = 'glamt' + nemo_lat = 'gphit' + nemo_mask = 'none' + nemo_mask_value = 10 + input_mask = 'none' + input_mask_value = 10 +/ +&comments + ----------------------------------------------------------------------------------- + - remap_inputs holds parameters for the scrip routine which calculates the weights + needed to convert between two grids + - two remap grid files are required as output by scripgrid + - num_maps is either 1 or 2 depending on whether the reverse transformation is required + - one or two interp_file names are then supplied; these hold the weights to convert + one grid to another + - the map_name variable is just descriptive + - map_method can be 'bilinear' 'bicubic' or 'conservative' (the latter untested) + - normalize_opt should usually be 'frac' or else the user needs to do this scaling + manually (this seems to the case for fractional ice cover) + - restrict_type should be 'latitude' or 'latlon' in which case num_srch_bins only are + used in one or two directions + - use_grid_area fields override the scrip calculation of area in case the model gets + slightly different answers, but the area needs to be supplied in the input files + - output_opt may be supplied and set to either 'scrip' or 'ncar-csm' +/ +&remap_inputs + num_maps = 1 + grid1_file = 'remap_core2_grid.nc' + grid2_file = 'remap_nordic1_grid.nc' + interp_file1 = 'core2_nordic1_bicub.nc' + interp_file2 = 'nordic1_core2_bicub.nc' + map1_name = 'orca2 to nordic1 bicub Mapping' + map2_name = 'nordic1 to orca2 bicub Mapping' + map_method = 'bicubic' + normalize_opt = 'frac' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. +/ + +&interp_inputs + input_file = "u_10.15JUNE2009_fill.nc" + interp_file = "core2_nordic1_bicub.nc" + input_name = "U_10_MOD" + input_start = 1,1,1,1 + input_stride = 1,1,1,1 + input_stop = 0,0,0,1 + input_vars = 'initial_time0_hours' +/ + +&interp_outputs + output_file = "u_10.15JUNE2009_nordic1.nc" + output_mode = "create" + output_dims = 'x', 'y', 'time_counter' + output_scaling = "U_10_MOD|1.0", "time_counter|86400.0" + output_name = 'U_10_MOD' + output_lon = 'x' + output_lat = 'y' + output_vars = 'time_counter' + output_attributes = 'time_counter|units|seconds since 1995-00-00 00:00:00', + 'time_counter|calendar|noleap', + 'U_10_MOD|units|mm/s' +/ + +&comments + ----------------------------------------------------------------------------------- + - shape_inputs are the input fields required by scripshape.f90 + - first is the interpolation file created by scrip.f90 mapping data to model grid + - second is the name of the output weights file to create + - third is the east-west wrap to assume in the model (needed when calculating gradient + terms in the bicubic scheme); the number is just the number of columns on one side + that are repeats of those on the opposite side (-1 for not cyclic) +/ +&shape_inputs + interp_file = 'core2_nordic1_bicub.nc' + output_file = 'weights_core2_nordic1_bicub.nc' + ew_wrap = 0 +/ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/namelist_bilin b/V4.0/nemo_sources/tools/WEIGHTS/namelist_bilin new file mode 100644 index 0000000000000000000000000000000000000000..ca6aecb0d4efbf6f66e2e76103d9a50227012164 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/namelist_bilin @@ -0,0 +1,101 @@ +&comments + ----------------------------------------------------------------------------------- + - grid_inputs holds parameters for the scripgrid routine which reformats information + about the input grids + - scripgrid always needs a coordinates.nc file in the + current directory and creates the remapped grid file correspondingly + - it uses the following namelist block to determine its actions + method: only 'regular' is yet implemented, this assumes a cartesian grid + input_lon: name of longitude variable in the input_file + input_lat: name of latitude variable in the input_file + nemo_lon: name of longitude variable in the coordinates.nc + nemo_lat: name of latitude variable in the coordinates.nc +/ +&grid_inputs + input_file = 't_10.15JUNE2009_fill.nc' + nemo_file = 'coordinates_nordic1.nc' + datagrid_file = 'remap_core2_grid.nc' + nemogrid_file = 'remap_nordic1_grid.nc' + method = 'regular' + input_lon = 'lon' + input_lat = 'lat' + nemo_lon = 'glamt' + nemo_lat = 'gphit' + nemo_mask = 'none' + nemo_mask_value = 10 + input_mask = 'none' + input_mask_value = 10 +/ +&comments + ----------------------------------------------------------------------------------- + - remap_inputs holds parameters for the scrip routine which calculates the weights + needed to convert between two grids + - two remap grid files are required as output by scripgrid + - num_maps is either 1 or 2 depending on whether the reverse transformation is required + - one or two interp_file names are then supplied; these hold the weights to convert + one grid to another + - the map_name variable is just descriptive + - map_method can be 'bilinear' 'bicubic' or 'conservative' (the latter untested) + - normalize_opt should usually be 'frac' or else the user needs to do this scaling + manually (this seems to the case for fractional ice cover) + - restrict_type should be 'latitude' or 'latlon' in which case num_srch_bins only are + used in one or two directions + - use_grid_area fields override the scrip calculation of area in case the model gets + slightly different answers, but the area needs to be supplied in the input files + - output_opt may be supplied and set to either 'scrip' or 'ncar-csm' +/ +&remap_inputs + num_maps = 1 + grid1_file = 'remap_core2_grid.nc' + grid2_file = 'remap_nordic1_grid.nc' + interp_file1 = 'core2_nordic1_bilin.nc' + interp_file2 = 'nordic1_core2_bilin.nc' + map1_name = 'orca2 to nordic1 bilin Mapping' + map2_name = 'nordic1 to orca2 bilin Mapping' + map_method = 'bilinear' + normalize_opt = 'frac' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. +/ + +&interp_inputs + input_file = "t_10.15JUNE2009_fill.nc" + interp_file = "core2_nordic1_bilin.nc" + input_name = "T_10_MOD" + input_start = 1,1,1,1 + input_stride = 1,1,1,1 + input_stop = 0,0,0,1 + input_vars = 'initial_time0_hours' +/ + +&interp_outputs + output_file = "t_10.15JUNE2009_nordic1.nc" + output_mode = "create" + output_dims = 'x', 'y', 'time_counter' + output_scaling = "T_10_MOD|1.0", "time_counter|86400.0" + output_name = 'T_10_MOD' + output_lon = 'x' + output_lat = 'y' + output_vars = 'time_counter' + output_attributes = 'time_counter|units|seconds since 1995-00-00 00:00:00', + 'time_counter|calendar|noleap', + 'T_10_MOD|units|mm/s' +/ + +&comments + ----------------------------------------------------------------------------------- + - shape_inputs are the input fields required by scripshape.f90 + - first is the interpolation file created by scrip.f90 mapping data to model grid + - second is the name of the output weights file to create + - third is the east-west wrap to assume in the model (needed when calculating gradient + terms in the bicubic scheme); the number is just the number of columns on one side + that are repeats of those on the opposite side (-1 for not cyclic) +/ +&shape_inputs + interp_file = 'core2_nordic1_bilin.nc' + output_file = 'weights_core2_nordic1_bilin.nc' + ew_wrap = 0 +/ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/CHANGES b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/CHANGES new file mode 100644 index 0000000000000000000000000000000000000000..032fd94c7749aaa8467cb942b99f3405138a271a --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/CHANGES @@ -0,0 +1,20 @@ +Release 1.1 +=========== +Modified for compilation by fcm in NEMO 3.3 framework. +SCRIP 1.4 package included in unmodified form. +python script added to transform into correct shape for fcm, producing copied code in 'src' directory + +scripshape.F90 now has one possible command line argument: the namelist file + from which it reads the names of the input and output files + as well as the value for the cyclicity attribute + +Because gfortran doesnt understand ICHAR and GETCHAR system routines default behaviour of all programs +is to ask for namelist filename during execution rather than reading it from the command line. +Define symbol ARGC at compilation to return to original command line behaviour. + +Release 1.0 +=========== +Routines written by sga and acc at NOCS to use SCRIP library to produce weights + +Compilation by makefile and explicit compiler and options. + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/namelist_example_bilin b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/namelist_example_bilin new file mode 100644 index 0000000000000000000000000000000000000000..88f32000ea6a8626e242f5c25b3ef672267f6897 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/namelist_example_bilin @@ -0,0 +1,101 @@ +&comments + ----------------------------------------------------------------------------------- + - grid_inputs holds parameters for the scripgrid routine which reformats information + about the input grids + - scripgrid always needs a coordinates.nc file in the + current directory and creates the remapped grid file correspondingly + - it uses the following namelist block to determine its actions + method: only 'regular' is yet implemented, this assumes a cartesian grid + input_lon: name of longitude variable in the input_file + input_lat: name of latitude variable in the input_file + nemo_lon: name of longitude variable in the coordinates.nc + nemo_lat: name of latitude variable in the coordinates.nc +/ +&grid_inputs + input_file = 'snow_1m_DUM_1958.nc' + nemo_file = 'coordinates.nc' + datagrid_file = 'remap_data_grid.nc' + nemogrid_file = 'remap_nemo_grid.nc' + method = 'regular' + input_lon = 'lon' + input_lat = 'lat' + nemo_lon = 'glamt' + nemo_lat = 'gphit' + nemo_mask = 'none' + nemo_mask_value = 10 + input_mask = 'none' + input_mask_value = 10 +/ +&comments + ----------------------------------------------------------------------------------- + - remap_inputs holds parameters for the scrip routine which calculates the weights + needed to convert between two grids + - two remap grid files are required as output by scripgrid + - num_maps is either 1 or 2 depending on whether the reverse transformation is required + - one or two interp_file names are then supplied; these hold the weights to convert + one grid to another + - the map_name variable is just descriptive + - map_method can be 'bilinear' 'bicubic' or 'conservative' (the latter untested) + - normalize_opt should usually be 'frac' or else the user needs to do this scaling + manually (this seems to the case for fractional ice cover) + - restrict_type should be 'latitude' or 'latlon' in which case num_srch_bins only are + used in one or two directions + - use_grid_area fields override the scrip calculation of area in case the model gets + slightly different answers, but the area needs to be supplied in the input files + - output_opt may be supplied and set to either 'scrip' or 'ncar-csm' +/ +&remap_inputs + num_maps = 1 + grid1_file = 'remap_data_grid.nc' + grid2_file = 'remap_nemo_grid.nc' + interp_file1 = 'data_nemo_bilin.nc' + interp_file2 = 'nemo_data_bilin.nc' + map1_name = 'data to nemo bilin Mapping' + map2_name = 'nemo to data bilin Mapping' + map_method = 'bilinear' + normalize_opt = 'frac' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. +/ + +&interp_inputs + input_file = "snow_1m_DUM_1958.nc" + interp_file = "data_nemo_bilin.nc" + input_name = "snow" + input_start = 1,1,1,1 + input_stride = 1,1,1,1 + input_stop = 0,0,0,1 + input_vars = 'initial_time0_hours' +/ + +&interp_outputs + output_file = "snow_orca.nc" + output_mode = "create" + output_dims = 'x', 'y', 'time_counter' + output_scaling = "snow|1.0", "time_counter|86400.0" + output_name = 'snow' + output_lon = 'x' + output_lat = 'y' + output_vars = 'time_counter' + output_attributes = 'time_counter|units|seconds since 1995-00-00 00:00:00', + 'time_counter|calendar|noleap', + 'snow|units|mm/s' +/ + +&comments + ----------------------------------------------------------------------------------- + - shape_inputs are the input fields required by scripshape.f90 + - first is the interpolation file created by scrip.f90 mapping data to model grid + - second is the name of the output weights file to create + - third is the east-west wrap to assume in the model (needed when calculating gradient + terms in the bicubic scheme); the number is just the number of columns on one side + that are repeats of those on the opposite side (-1 for not cyclic) +/ +&shape_inputs + interp_file = 'data_nemo_bilin.nc' + output_file = 'weights_bilin.nc' + ew_wrap = 0 +/ diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scrip.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scrip.F90 new file mode 100644 index 0000000000000000000000000000000000000000..291a657feb26011b5f83b129674fb764265e7438 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scrip.F90 @@ -0,0 +1,232 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This routine is the driver for computing the addresses and weights +! for interpolating between two grids on a sphere. +! +! Modified slightly to get name of namelist file from command line - sga 2/12/05 +! +!----------------------------------------------------------------------- +! +! CVS:$Id: scrip.f,v 1.6 2001/08/21 21:06:44 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + program scrip + +!----------------------------------------------------------------------- + + use kinds_mod ! module defining data types + use constants ! module for common constants + use iounits ! I/O unit manager + use timers ! CPU timers + use grids ! module with grid information + use remap_vars ! common remapping variables + use remap_conservative ! routines for conservative remap + use remap_distance_weight ! routines for dist-weight remap + use remap_bilinear ! routines for bilinear interp + use remap_bicubic ! routines for bicubic interp + use remap_write ! routines for remap output + + implicit none + +!----------------------------------------------------------------------- +! +! input namelist variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + grid1_file, & ! filename of grid file containing grid1 + grid2_file, & ! filename of grid file containing grid2 + interp_file1, & ! filename for output remap data (map1) + interp_file2, & ! filename for output remap data (map2) + map1_name, & ! name for mapping from grid1 to grid2 + map2_name, & ! name for mapping from grid2 to grid1 + map_method, & ! choice for mapping method + normalize_opt, & ! option for normalizing weights + output_opt ! option for output conventions + + integer (kind=int_kind) :: & + nmap ! number of mappings to compute (1 or 2) + + namelist /remap_inputs/ grid1_file, grid2_file, & + interp_file1, interp_file2, & + map1_name, map2_name, num_maps, & + luse_grid1_area, luse_grid2_area, & + map_method, normalize_opt, output_opt, & + restrict_type, num_srch_bins + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, & ! dummy counter + iunit ! unit number for namelist file + + character (char_len) :: nm_in +#if defined ARGC + integer :: iargc + external iargc + + if (iargc() == 1) then + call getarg(1, nm_in) + else + write(6,*) 'need name of namelist file' + stop + endif +#else + write(6,*) 'enter name for namelist file' + read(5,*) nm_in +#endif + +!----------------------------------------------------------------------- +! +! initialize timers +! +!----------------------------------------------------------------------- + + call timers_init + do n=1,max_timers + call timer_clear(n) + end do + +!----------------------------------------------------------------------- +! +! read input namelist +! +!----------------------------------------------------------------------- + + grid1_file = 'unknown' + grid2_file = 'unknown' + interp_file1 = 'unknown' + interp_file2 = 'unknown' + map1_name = 'unknown' + map2_name = 'unknown' + luse_grid1_area = .false. + luse_grid2_area = .false. + num_maps = 2 + map_type = 1 + normalize_opt = 'fracarea' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 900 + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=remap_inputs) + call release_unit(iunit) + + select case(map_method) + case ('conservative') + map_type = map_type_conserv + luse_grid_centers = .false. + case ('bilinear') + map_type = map_type_bilinear + luse_grid_centers = .true. + case ('bicubic') + map_type = map_type_bicubic + luse_grid_centers = .true. + case ('distwgt') + map_type = map_type_distwgt + luse_grid_centers = .true. + case default + stop 'unknown mapping method' + end select + + select case(normalize_opt(1:4)) + case ('none') + norm_opt = norm_opt_none + case ('frac') + norm_opt = norm_opt_frcarea + case ('dest') + norm_opt = norm_opt_dstarea + case default + stop 'unknown normalization option' + end select + +!----------------------------------------------------------------------- +! +! initialize grid information for both grids +! +!----------------------------------------------------------------------- + + call grid_init(grid1_file, grid2_file) + + write(stdout, *) ' Computing remappings between: ',grid1_name + write(stdout, *) ' and ',grid2_name + +!----------------------------------------------------------------------- +! +! initialize some remapping variables. +! +!----------------------------------------------------------------------- + + call init_remap_vars + +!----------------------------------------------------------------------- +! +! call appropriate interpolation setup routine based on type of +! remapping requested. +! +!----------------------------------------------------------------------- + + select case(map_type) + case(map_type_conserv) + call remap_conserv + case(map_type_bilinear) + call remap_bilin + case(map_type_distwgt) + call remap_distwgt + case(map_type_bicubic) + call remap_bicub + case default + stop 'Invalid Map Type' + end select + +!----------------------------------------------------------------------- +! +! reduce size of remapping arrays and then write remapping info +! to a file. +! +!----------------------------------------------------------------------- + + if (num_links_map1 /= max_links_map1) then + call resize_remap_vars(1, num_links_map1-max_links_map1) + endif + if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then + call resize_remap_vars(2, num_links_map2-max_links_map2) + endif + + call write_remap(map1_name, map2_name, & + interp_file1, interp_file2, output_opt) + +!----------------------------------------------------------------------- + + end program scrip + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid.F90 new file mode 100755 index 0000000000000000000000000000000000000000..e9744f8e3880c202c486bee8c9e33d7121c18dd4 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid.F90 @@ -0,0 +1,26 @@ +! ============================================================================== + +PROGRAM scripgrid + + USE scripgrid_mod + + CHARACTER(char_len) :: infile + +#if defined ARGC + INTEGER :: IARGC + EXTERNAL IARGC + + if (IARGC() == 1) then + CALL GETARG(1, infile) + CALL convert( infile ) + ELSE + write(6,*) 'need to supply a namelist file' + ENDIF +#else + write(6,*) 'enter name of namelist file' + read(5,*) infile + + CALL convert( infile ) +#endif + +END PROGRAM scripgrid diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid_mod.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..70157352fc05874cf2c47cd23dae507e18696e2e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripgrid_mod.F90 @@ -0,0 +1,759 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module creates grid description files for input to the SCRIP code +! +!----------------------------------------------------------------------- + +MODULE scripgrid_mod + + USE kinds_mod + USE constants + USE iounits + USE netcdf + USE netcdf_mod + + IMPLICIT NONE + + !----------------------------------------------------------------------- + ! module variables that describe the grid + + INTEGER (kind=int_kind), parameter :: & + grid_rank = 2, & + grid_corners = 4 + INTEGER (kind=int_kind) :: nx, ny, grid_size + INTEGER (kind=int_kind), dimension(2) :: & + grid_dims, & ! size of x, y dimensions + grid_dim_ids ! ids of the x, y dimensions + INTEGER (kind=int_kind), ALLOCATABLE, DIMENSION(:) :: & + grid_imask ! land-sea mask + REAL (kind=int_kind), ALLOCATABLE, DIMENSION(:) :: & + grid_center_lat, & ! lat/lon coordinates for + grid_center_lon ! each grid center in degrees + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + grid_corner_lat, & ! lat/lon coordinates for + grid_corner_lon ! each grid corner in degrees + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:,:) :: & + corner_lon, & + corner_lat + REAL (kind=dbl_kind), PARAMETER :: circle = 360.0 + + !----------------------------------------------------------------------- + ! module variables that describe the netcdf file + + INTEGER (kind=int_kind) :: & + ncstat, & ! general netCDF status variable + ncid_in + +CONTAINS + + ! ============================================================================== + + SUBROUTINE convert(nm_in) + + ! ----------------------------------------------------------------------------- + ! - input variables + + CHARACTER(char_len), INTENT(in) :: & + nm_in + + ! ----------------------------------------------------------------------------- + ! - local variables + + CHARACTER(char_len) :: & + nemo_file, input_file, method, input_lon, input_lat, datagrid_file, & + nemogrid_file, nemo_lon, nemo_lat, corn_lon, corn_lat, nemo_mask, input_mask + INTEGER (kind=int_kind), dimension(2) :: & + offset + INTEGER (kind=int_kind) :: & + iunit, nemo_mask_value, input_mask_value + + namelist /grid_inputs/ nemo_file, input_file, datagrid_file, nemogrid_file, & + method, input_lon, input_lat, nemo_lon, nemo_lat, & + nemo_mask, nemo_mask_value, input_mask, input_mask_value + + !----------------------------------------------------------------------- + ! - namelist describing the processing + ! note that mask_value is the minimum good value, + ! so that where the mask is less than the value is masked + + nemo_file = "coordinates.nc" + nemo_lon = "glamt" + nemo_lat = "gphit" + input_lon = "lon" + input_lat = "lat" + input_mask = "none" + input_mask_value = 0 + datagrid_file = 'remap_data_grid.nc' + nemogrid_file = 'remap_nemo_grid.nc' + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=grid_inputs) + call release_unit(iunit) + + if (nemo_lon(1:4) .ne. 'glam' .or. nemo_lat(1:4) .ne. 'gphi') then + write(6,*) 'lon name does not start with "glam" or lat name does not start with "gphi"' + stop + endif + + ! set up the names of the corner variables for a given input + ! the offset represents what needs to be added to (i,j) to get to the correct + ! element in the corner arrays to correspond to the point northeast of the center + if (nemo_lon(5:5) == "t") then + corn_lon = "glamf" + corn_lat = "gphif" + offset = (/ 0,0 /) + else if (nemo_lon(5:5) == "u") then + corn_lon = "glamv" + corn_lat = "gphiv" + offset = (/ 1,0 /) + else if (nemo_lon(5:5) == "v") then + corn_lon = "glamu" + corn_lat = "gphiu" + offset = (/ 0,1 /) + else + write(6,*) 'unknown nemo_lon name' + stop + endif + + write(6,*) "processing " // trim(nemo_file) + call convertNEMO(nemo_file, nemo_lon, nemo_lat, corn_lon, corn_lat, & + offset, nemogrid_file) + + write(6,*) "processing regular grid" + call convertFLUX(input_file, input_lon, input_lat, & + input_mask, input_mask_value, datagrid_file) + + END SUBROUTINE convert + + ! ============================================================================== + + SUBROUTINE convertNEMO(grid_file_in, cent_lon, cent_lat, corn_lon, corn_lat, & + off, grid_file_out) + + !----------------------------------------------------------------------- + ! + ! This routine converts a NEMO coordinates.nc file to a remapping grid file. + ! + + CHARACTER(char_len), INTENT(in) :: cent_lon, cent_lat, corn_lon, corn_lat + INTEGER (kind=int_kind), INTENT(in), DIMENSION(2) :: off + CHARACTER(char_len), INTENT(in) :: grid_file_out + CHARACTER(char_len), INTENT(in) :: grid_file_in + + !----------------------------------------------------------------------- + ! module variables that describe the grid + + CHARACTER(char_len), parameter :: & + grid_name = 'Remapped NEMO grid for SCRIP' + + !----------------------------------------------------------------------- + ! grid coordinates and masks + + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + clon, clat, & ! expanded corner arrays + glam, & ! center longitude + gphi, & ! center latitude + glamc, & ! corner longitude + gphic ! corner latitude + + !----------------------------------------------------------------------- + ! other local variables + + INTEGER (kind=int_kind) :: i, j, n, iunit, im1, jm1, imid, isame, ic, jc + INTEGER (kind=int_kind) :: varid_lam, varid_phi, varid_lamc, varid_phic + INTEGER (kind=int_kind) :: jdim + INTEGER (kind=int_kind), dimension(4) :: grid_dimids ! input fields have 4 dims + REAL (kind=dbl_kind) :: tmplon, dxt, dyt + + !----------------------------------------------------------------------- + ! read in grid info + ! + ! For NEMO input grids, assume that variable names are glam, glamc etc. + ! Assume that 1st 2 dimensions of these variables are x and y directions. + ! These assumptions are made by NEMO, so should be valid for coordinates.nc. + ! + ! write in nf90 calls (without error handling) and then think about + ! making more readable by taking chunks into ncutil + ! + + ncstat = nf90_open( grid_file_in, NF90_NOWRITE, ncid_in ) + call netcdf_error_handler(ncstat) + + ! find dimids for 'glam' + ! use dimids to get dimlengths + ! allocate glam array + ! get glam from file + + ncstat = nf90_inq_varid( ncid_in, cent_lon, varid_lam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, corn_lon, varid_lamc ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, cent_lat, varid_phi ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, corn_lat, varid_phic ) + call netcdf_error_handler(ncstat) + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:) ) + call netcdf_error_handler(ncstat) + DO jdim = 1, SIZE(grid_dims) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(jdim), & + len=grid_dims(jdim) ) + call netcdf_error_handler(ncstat) + END DO + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ! assume that dimensions are all the same as glam + ALLOCATE( glam(nx,ny), glamc(nx,ny), gphi(nx,ny), gphic(nx,ny) ) + ncstat = nf90_get_var( ncid_in, varid_lam, glam(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_lamc, glamc(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, gphi(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phic, gphic(:,:) ) + call netcdf_error_handler(ncstat) + + !----------------------------------------------------------------------- + ! - Mask is all ocean for now + + ALLOCATE( grid_imask(grid_size) ) + grid_imask(:) = 1 + + !----------------------------------------------------------------------- + ! corners are arranged as follows: 4 3 + ! 1 2 + ! + ! Assume that cyclic grids have 2 wrap columns in coordinates.nc + ! (this is the case for ORCA grids) + ! + + ! ----------------------------------------------------------------------------- + ! create a single pair of arrays for the corners where clon(1,1) corresponds + ! to the south west corner of a box containing glam(1,1) + ! various special cases then apply + ! bottom row: assume clon(:,j) = clon(:,j+1) + + ALLOCATE ( clon(nx+1,ny+1), clat(nx+1,ny+1) ) + + ! first the easy internal points + DO j = 2,ny + DO i = 2,nx + ic = i + off(1) - 1 + jc = j + off(2) - 1 + clon(i,j) = glamc(ic,jc) + clat(i,j) = gphic(ic,jc) + ENDDO + ENDDO + + ! then the tricky boundary points + imid = (nx-1)/2 + 1 + DO j = 1,ny+1,ny + DO i = 1,nx+1,nx + ic = i + off(1) - 1 + jc = j + off(2) - 1 + if (ic == 0 .and. jc == 0) then + clon(i,j) = glamc(nx,1) + clat(i,j) = gphic(nx,1) - (gphic(nx,2)-gphic(nx,1)) + else if (ic == nx+1 .and. jc == 0) then + clon(i,j) = glamc(1,1) + clat(i,j) = gphic(1,1) - (gphic(1,2)-gphic(1,1)) + else if (ic == 0 .and. jc == ny+1) then + isame = 2*imid - nx + 1 + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + else if (ic == nx+1 .and. jc == ny+1) then + isame = 2*imid + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + else if (ic == 0) then + clon(i,j) = glamc(nx,jc) + clat(i,j) = gphic(nx,jc) + else if (jc == 0) then + clon(i,j) = glamc(ic,1) + clat(i,j) = gphic(ic,1) - (gphic(ic,2)-gphic(ic,1)) + else if (ic == nx+1) then + clon(i,j) = glamc(1,jc) + clat(i,j) = gphic(1,jc) + else if (jc == ny+1) then + isame = 2*imid - ic + 1 + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + endif + ENDDO + ENDDO + + ALLOCATE ( corner_lon(4,nx,ny), corner_lat(4,nx,ny) ) + + ! top-right corner + corner_lon(3,:,:) = clon(2:nx+1,2:ny+1) + corner_lat(3,:,:) = clat(2:nx+1,2:ny+1) + + ! top-left corner + corner_lon(4,:,:) = clon(1:nx,2:ny+1) + corner_lat(4,:,:) = clat(1:nx,2:ny+1) + + ! bottom-right corner + corner_lon(2,:,:) = clon(2:nx+1,1:ny) + corner_lat(2,:,:) = clat(2:nx+1,1:ny) + + ! bottom-left corner + corner_lon(1,:,:) = clon(1:nx,1:ny) + corner_lat(1,:,:) = clat(1:nx,1:ny) + + ! For [N, E, W]-ward extrapolation near the poles, should we use stereographic (or + ! similar) projection? This issue will come for V,F interpolation, and for all + ! grids with non-cyclic grids. + + ! ----------------------------------------------------------------------------- + ! correct for 0,2pi longitude crossings + ! (In practice this means putting all corners into 0,2pi range + ! and ensuring that no box corners are miles from each other. + ! 3pi/2 is used as threshold - I think this is quite arbitrary.) + + corner_lon(:,:,:) = MODULO( corner_lon(:,:,:), circle ) + DO n = 2, grid_corners + WHERE ( corner_lon(n,:,:) - corner_lon(n-1,:,:) < -three*circle*0.25 ) + corner_lon(n,:,:) = corner_lon(n,:,:) + circle + ELSEWHERE( corner_lon(n,:,:) - corner_lon(n-1,:,:) > three*circle*0.25 ) + corner_lon(n,:,:) = corner_lon(n,:,:) - circle + END WHERE + END DO + + ! ----------------------------------------------------------------------------- + ! - put longitudes on smooth grid + + ! call mouldlon(glam,nx,ny) + ! call mouldlon(corner_lon(1,:,:),nx,ny) + ! call mouldlon(corner_lon(2,:,:),nx,ny) + ! call mouldlon(corner_lon(3,:,:),nx,ny) + ! call mouldlon(corner_lon(4,:,:),nx,ny) + + ! ----------------------------------------------------------------------------- + ! - reshape for SCRIP input format + + ALLOCATE( grid_center_lon(grid_size), grid_center_lat(grid_size) ) + + grid_center_lon(:) = RESHAPE( glam(:,:), (/ grid_size /) ) + grid_center_lat(:) = RESHAPE( gphi(:,:), (/ grid_size /) ) + + DEALLOCATE( glam, gphi, glamc, gphic ) + + ALLOCATE( grid_corner_lon(4, grid_size), grid_corner_lat(4, grid_size) ) + + grid_corner_lon(:,:) = RESHAPE( corner_lon(:,:,:), (/ 4, grid_size /) ) + grid_corner_lat(:,:) = RESHAPE( corner_lat(:,:,:), (/ 4, grid_size /) ) + + DEALLOCATE( corner_lon, corner_lat ) + + CALL createSCRIPgrid(grid_file_out, grid_name) + + END SUBROUTINE convertNEMO + + ! ============================================================================== + + SUBROUTINE convertFLUX(grid_file_in, name_lon, name_lat, & + name_mask, value_mask, grid_file_out) + + !----------------------------------------------------------------------- + ! + ! This routine creates a remapping grid file from an input grid. + ! + !----------------------------------------------------------------------- + + CHARACTER(char_len), INTENT(in) :: & + grid_file_in, name_lon, name_lat, name_mask, grid_file_out + INTEGER (kind=int_kind) :: value_mask + + !----------------------------------------------------------------------- + ! variables that describe the grid + + CHARACTER(char_len), parameter :: & + grid_name = 'Remapped regular grid for SCRIP' + + !----------------------------------------------------------------------- + ! grid coordinates (note that a flux file just has lon and lat) + + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:) :: & + lam, phi + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + glam, & ! longitude + gphi, & ! latitude + glamc, & + gphic + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: mask + + !----------------------------------------------------------------------- + ! other local variables + + INTEGER (kind=int_kind) :: i, j, n, iunit, im1, jm1 + INTEGER (kind=int_kind) :: varid_lam, varid_phi, varid_mask + INTEGER (kind=int_kind) :: jdim, nspace + INTEGER (kind=int_kind), dimension(4) :: grid_dimids ! input fields have 4 dims + REAL (kind=dbl_kind) :: tmplon, dxt, dyt + + !----------------------------------------------------------------------- + ! read in grid info + ! + ! For NEMO input grids, assume that variable names are glam, glamc etc. + ! Assume that 1st 2 dimensions of these variables are x and y directions. + ! These assumptions are made by NEMO, so should be valid for coordinates.nc. + ! + ! write in nf90 calls (without error handling) and then think about + ! making more readable by taking chunks into ncutil + + ncstat = nf90_open( grid_file_in, NF90_NOWRITE, ncid_in ) + call netcdf_error_handler(ncstat) + + ! find dimids for 'glamt' + ! use dimids to get dimlengths + ! allocate glam array + ! get glam from file + + ncstat = nf90_inq_varid( ncid_in, name_lat, varid_phi ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, name_lon, varid_lam ) + call netcdf_error_handler(ncstat) + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, ndims=nspace ) + call netcdf_error_handler(ncstat) + + if (nspace == 1) then + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_variable( ncid_in, varid_phi, dimids=grid_dimids(2:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(1), len=grid_dims(1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(2), len=grid_dims(2) ) + call netcdf_error_handler(ncstat) + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ALLOCATE( lam(nx), phi(ny) ) + write(6,*) 'double' + ncstat = nf90_get_var( ncid_in, varid_lam, lam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, phi ) + call netcdf_error_handler(ncstat) + + ALLOCATE( glam(nx,ny), gphi(nx,ny)) + write(6,*) shape(lam),shape(phi) + glam(:,:) = SPREAD(lam,2,ny) + gphi(:,:) = SPREAD(phi,1,nx) + else + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:2) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(1), len=grid_dims(1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(2), len=grid_dims(2) ) + call netcdf_error_handler(ncstat) + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ALLOCATE( glam(nx,ny), gphi(nx,ny)) + ncstat = nf90_get_var( ncid_in, varid_lam, glam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, gphi ) + call netcdf_error_handler(ncstat) + + endif + write(6,*) grid_size,nx,ny + + ALLOCATE(glamc(0:nx,0:ny), gphic(0:nx,0:ny) ) + + ! - for now a simple average to get top right box corners + ! - glamc(i,j), gphic(i,j) are top right coordinates of box containing + ! - glam(i,j),gphi(i,j) + write(6,*) 'averaging' + write(6,*) size(gphic),size(gphi) + gphic(1:nx,1:ny-1) = 0.5*(gphi(:,1:ny-1)+gphi(:,2:ny)) + write(6,*) size(glamc),size(glam) + glamc(1:nx-1,1:ny) = 0.5*(glam(1:nx-1,:)+glam(2:nx,:)) + + ! - left and right column of longitudes + write(6,*) 'columns' + glamc(nx,1:ny) = 1.5*glam(nx,:)-0.5*glam(nx-1,:) + glamc( 0,1:ny) = 1.5*glam(1,:)-0.5*glam(2,:) + glamc(nx, 0) = glamc(nx,1) + glamc( 0, 0) = glamc( 0,1) + + ! - top and bottom row of latitudes by extrapolation + write(6,*) 'rows' + gphic(1:nx,ny) = 1.5*gphi(:,ny)-0.5*gphi(:,ny-1) + gphic(1:nx, 0) = 1.5*gphi(:,1)-0.5*gphi(:,2) + gphic( 0,ny) = gphic(1,ny) + gphic( 0, 0) = gphic(1, 0) + + !----------------------------------------------------------------------- + + write(6,*) 'allocating' + ALLOCATE( grid_imask(grid_size) ) + grid_imask(:) = 1 + write(6,*) name_mask + if (trim(name_mask) /= "none") then + write(6,*) 'masking' + ncstat = nf90_inq_varid( ncid_in, name_mask, varid_mask ) + call netcdf_error_handler(ncstat) + ALLOCATE( mask(nx,ny) ) + write(6,*) 'reading mask' + ncstat = nf90_get_var( ncid_in, varid_mask, mask ) + call netcdf_error_handler(ncstat) + write(6,*) 'setting mask' + WHERE ( RESHAPE(mask(:,:),(/ grid_size /)) < value_mask) + grid_imask = 0 + END WHERE + write(6,*) 'masked' + END IF + + !----------------------------------------------------------------------- + ! corners are arranged as follows: 4 3 + ! 1 2 + + ALLOCATE ( corner_lon(4,nx,ny), corner_lat(4,nx,ny) ) + + ! - bottom-left corner + corner_lon(1,:,:) = glamc(0:nx-1, 0:ny-1 ) + corner_lat(1,:,:) = gphic(0:nx-1, 0:ny-1 ) + + ! - bottom-right corner + corner_lon(2,:,:) = glamc(1:nx, 0:ny-1 ) + corner_lat(2,:,:) = gphic(1:nx, 0:ny-1 ) + + ! - top-right corner + corner_lon(3,:,:) = glamc(1:nx,1:ny) + corner_lat(3,:,:) = gphic(1:nx,1:ny) + write(6,*) corner_lat(3,nx-2:nx,ny) + + ! - top-left corner + corner_lon(4,:,:) = glamc(0:nx-1, 1:ny ) + corner_lat(4,:,:) = gphic(0:nx-1, 1:ny ) + + ! For [N, E, W]-ward extrapolation near the poles, should we use stereographic (or + ! similar) projection? This issue will come for V,F interpolation, and for all + ! grids with non-cyclic grids. + + ! ----------------------------------------------------------------------------- + ! correct for 0,2pi longitude crossings + ! (In practice this means putting all corners into 0,2pi range + ! and ensuring that no box corners are miles from each other. + ! 3pi/2 is used as threshold - I think this is quite arbitrary.) + + ! corner_lon(:,:,:) = MODULO( corner_lon(:,:,:), circle ) + ! DO n = 2, grid_corners + ! WHERE ( corner_lon(n,:,:) - corner_lon(n-1,:,:) < -three*circle*0.25 ) + ! corner_lon(n,:,:) = corner_lon(n,:,:) + circle + ! ELSEWHERE( corner_lon(n,:,:) - corner_lon(n-1,:,:) > three*circle*0.25 ) + ! corner_lon(n,:,:) = corner_lon(n,:,:) - circle + ! END WHERE + ! END DO + + ! ----------------------------------------------------------------------------- + ! - reshape for SCRIP input format + + ALLOCATE( grid_center_lon(grid_size), grid_center_lat(grid_size) ) + + grid_center_lon(:) = RESHAPE( glam(:,:), (/ grid_size /) ) + grid_center_lat(:) = RESHAPE( gphi(:,:), (/ grid_size /) ) + + DEALLOCATE( glam, gphi, glamc, gphic ) + + ALLOCATE( grid_corner_lon(4, grid_size), grid_corner_lat(4, grid_size) ) + + grid_corner_lon(:,:) = RESHAPE( corner_lon(:,:,:), (/ 4, grid_size /) ) + grid_corner_lat(:,:) = RESHAPE( corner_lat(:,:,:), (/ 4, grid_size /) ) + + DEALLOCATE( corner_lon, corner_lat ) + + CALL createSCRIPgrid(grid_file_out, grid_name) + + END SUBROUTINE convertFLUX + + ! ============================================================================== + + SUBROUTINE mouldlon(lon_grid, nx, ny) + + ! ----------------------------------------------------------------------------- + ! - input variables + + INTEGER, INTENT(in) :: nx, ny + REAL (kind=dbl_kind), INTENT(inout), DIMENSION(nx,ny) :: & + lon_grid + + ! ----------------------------------------------------------------------------- + ! - local variables + + INTEGER :: ix, iy + REAL (kind=dbl_kind), DIMENSION(:,:), ALLOCATABLE :: & + dlon + REAL :: step + + ! ----------------------------------------------------------------------------- + ! - try to eliminate any 360 degree steps in a grid of longitudes + + ALLOCATE(dlon(nx,ny)) + + step = 0.75*circle + dlon(:,:) = 0 + dlon(2:,:) = lon_grid(2:,:) - lon_grid(:nx-1,:) + WHERE (dlon > -step .AND. dlon < step) + dlon = 0.0 + ELSEWHERE + dlon = -SIGN(circle,dlon) + END WHERE + + ! - close your eyes this is nasty + DO ix = 2,nx + dlon(ix,:) = dlon(ix,:) + dlon(ix-1,:) + END DO + lon_grid = lon_grid + dlon + + END SUBROUTINE mouldlon + + ! ============================================================================== + + SUBROUTINE createSCRIPgrid(grid_file_out, grid_name) + + ! ----------------------------------------------------------------------------- + ! - input variables + + CHARACTER(char_len), INTENT(in) :: & + grid_name, grid_file_out + + ! ----------------------------------------------------------------------------- + ! - local variables that describe the netcdf file + + INTEGER (kind=int_kind) :: & + nc_grid_id, & ! netCDF grid dataset id + nc_gridsize_id, & ! netCDF grid size dim id + nc_gridcorn_id, & ! netCDF grid corner dim id + nc_gridrank_id, & ! netCDF grid rank dim id + nc_griddims_id, & ! netCDF grid dimensions id + nc_grdcntrlat_id, & ! netCDF grid center lat id + nc_grdcntrlon_id, & ! netCDF grid center lon id + nc_grdimask_id, & ! netCDF grid mask id + nc_gridarea_id, & ! netCDF grid area id + nc_grdcrnrlat_id, & ! netCDF grid corner lat id + nc_grdcrnrlon_id ! netCDF grid corner lon id + + ! ----------------------------------------------------------------------------- + ! - create netCDF dataset for this grid + ! - rewrite in nf90 + ! - (bring out functional blocks into ncclear for readability) + + ncstat = nf90_create (grid_file_out, NF90_CLOBBER, nc_grid_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att (nc_grid_id, NF90_GLOBAL, 'title', grid_name) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid size dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_size', grid_size, nc_gridsize_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid rank dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_rank', grid_rank, nc_gridrank_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_corners', grid_corners, nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid dim size array + + ncstat = nf90_def_var(nc_grid_id, 'grid_dims', NF90_INT, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid mask + + ncstat = nf90_def_var(nc_grid_id, 'grid_imask', NF90_INT, & + nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdimask_id, 'units', 'unitless') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid center latitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_center_lat', NF90_DOUBLE, & + nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcntrlat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid center longitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_center_lon', NF90_DOUBLE, & + nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcntrlon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner latitude array + + grid_dim_ids = (/ nc_gridcorn_id, nc_gridsize_id /) + ncstat = nf90_def_var(nc_grid_id, 'grid_corner_lat', NF90_DOUBLE, & + grid_dim_ids, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcrnrlat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner longitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_corner_lon', NF90_DOUBLE, & + grid_dim_ids, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcrnrlon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! end definition stage + + ncstat = nf90_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! write grid data + + ncstat = nf90_put_var(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcntrlat_id, grid_center_lat) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcntrlon_id, grid_center_lon) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcrnrlat_id, grid_corner_lat) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcrnrlon_id, grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf90_close(nc_grid_id) + call netcdf_error_handler(ncstat) + + DEALLOCATE( grid_imask, grid_center_lon, grid_center_lat, & + grid_corner_lon, grid_corner_lat ) + + + END SUBROUTINE createSCRIPgrid + +END MODULE scripgrid_mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..74724980439e4fb7de3a364a4bc394ae942318ed --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp.F90 @@ -0,0 +1,24 @@ +! ========================================================================== + +program scripinterp + + use scripinterp_mod + + character (char_len) :: nm_in +#if defined ARGC + integer :: iargc + external iargc + + if (iargc() == 1) then + call getarg(1, nm_in) + call process_grid(nm_in) + else + write(6,*) 'need the name of an input namelist' + endif +#else + write(6,*) 'enter the name of an input namelist' + read(5,*) nm_in + call process_grid(nm_in) +#endif + +end program scripinterp diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp_mod.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9a5558551df8576e46f79a2d64927c33f7d8a045 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripinterp_mod.F90 @@ -0,0 +1,1031 @@ +! ************************************************************************** + + module scripinterp_mod + +! ========================================================================== + + use kinds_mod ! defines common data types + use constants ! defines common constants + use iounits ! I/O unit manager + use netcdf + use netcdf_mod ! netcdf I/O stuff + use grids ! module containing grid info + use remap_vars ! module containing remapping info + use remap_mod ! module containing remapping routines + use remap_read ! routines for reading remap files + + implicit none + + real(kind=dbl_kind), dimension(:), allocatable :: & + grid_out + + integer(kind=int_kind) :: & ! netCDF ids for files and arrays + ncstat, nc_outfile_id, nc_infile_id + integer (kind=int_kind), dimension(4) :: & + input_dims, input_dimids, input_count + real (kind=dbl_kind), dimension(:), allocatable :: & + scale + integer (kind=int_kind), dimension(:), allocatable :: & + nc_xysize_id, nc_gridsize_id, nc_gridsize, & + nc_variable_id + integer :: nc_lon_id, nc_lat_id, nc_array_id + + character (char_len) :: & + map_name ! name for mapping from grid1 to grid2 + character (1), parameter :: & + separator = '|' + + ! - input namelist variables + + character (char_len) :: & + input_file, & ! filename containing input fields + interp_file, & ! filename containing remap data (map1) + input_name ! name of variable to grid + integer (kind=int_kind), dimension(4) :: & + input_stride, & ! how much of input array to process + input_start, & ! where to start + input_stop ! and where to stop + character (char_len), dimension(4) :: & + input_vars ! input variables to be copied + + ! - output namelist variables + + character (char_len) :: & + output_file, & ! filename for test results + output_mode, & ! 'create' or 'append' + output_name, & ! name of new grid variable + output_lat, & ! as it says + output_lon, & ! as it says + output_ydir ! choose to invert output arrays in y direction + character (char_len), dimension(4) :: & + output_dims, & ! name of new grid variable + output_vars ! variables to copy + character (char_len), dimension(10) :: & + output_attributes, & ! attributes of stuff in output file + output_scaling ! scaling factor to apply to input data to get + ! correct units in output file +contains + +! ========================================================================== + + subroutine process_grid(nm_in) + + !----------------------------------------------------------------------- + ! - dummy variables + + character (char_len) :: & + nm_in ! name of input namelist file + + !----------------------------------------------------------------------- + ! - local variables + + integer (kind=int_kind), dimension(4) :: & + astart, acount, plus_one + integer (kind=int_kind), dimension(3) :: & + write_dims + integer (kind=int_kind) :: & + i1, i2, jdim, n, nx, ny, nloop, & + nc_input_id, nc_input_rank, & + vstart, vstride, numv + + real (kind=dbl_kind), dimension(:), allocatable :: & + grid1_array + real (kind=dbl_kind), dimension(:,:), allocatable :: & + var_out + + plus_one(:) = 1 + + !----------------------------------------------------------------------- + + call read_mappings(nm_in) + + !----------------------------------------------------------------------- + ! - read input grid + ! - WARNING - lots of assumptions here at the moment + + ncstat = nf90_open( input_file, NF90_NOWRITE, nc_infile_id ) + call netcdf_error_handler(ncstat,"open") + + ncstat = nf90_inq_varid( nc_infile_id, input_name, nc_input_id ) + call netcdf_error_handler(ncstat,"inq_varid") + + input_dims(:) = 0 + ncstat = nf90_inquire_variable( nc_infile_id, nc_input_id, & + ndims=nc_input_rank, dimids=input_dimids(:) ) + call netcdf_error_handler(ncstat,"inquire_variable") + + do jdim = 1,nc_input_rank + ncstat = nf90_inquire_dimension(nc_infile_id, & + input_dimids(jdim), len=input_dims(jdim) ) + call netcdf_error_handler(ncstat,"inquire_dimension") + enddo + + ! - dimids seem to be returned in storage order so the outer dimension of + ! - the array as described by the netcdf file becomes the first dimension + ! - as far as f90 is concerned (confused? you will be!) + + do jdim = 1,nc_input_rank + if (input_stop(jdim) == 0) then + input_stop(jdim) = input_dims(jdim) + endif + input_count(jdim) = input_stop(jdim) - input_start(jdim) + 1 + enddo + + ! - rashly we assume x followed by y + nx = input_dims(1) + ny = input_dims(2) + write(*,fmt='("Input grid dimensions are:",2i6)') nx, ny + if (nx*ny /= grid1_size) then + write(6,*) "mismatch between input grid and remap data" + stop + endif + + ! - calculate number of horizontal slices to process + ! - at the moment this is not very general and will only work with 3 dimensions + + acount(1:nc_input_rank) = & + (input_stop(1:nc_input_rank)-input_start(1:nc_input_rank)+1) / & + input_stride(1:nc_input_rank) + nloop = 1 + do jdim = 1,nc_input_rank + nloop = nloop*acount(jdim) + enddo + nloop = nloop/grid1_size + write(6,*) "total slices requested: ",nloop + + vstart = input_start(nc_input_rank) ! ie extra var has outer dimension + vstride = input_stride(nc_input_rank) + + ! - in general we cant read in the whole array so do it slice by slice + ! - slow but sure + + write(6,*) "allocating input and output grids" + allocate( grid1_array(grid1_size)) + allocate( grid_out(grid2_size) ) + + numv = 0 + do n = 1,4 + if (trim(input_vars(n)) /= '-' .and. & + trim(output_vars(n)) /= '-') numv = numv + 1 + enddo + + write_dims(1) = grid2_dims(1) + write_dims(2) = grid2_dims(2) + write_dims(3) = nloop + call define_grid(write_dims(1:3) , 2+numv) + + astart(:) = input_start(:) + astart(3) = astart(3) - input_stride(3) + acount(:) = 1 + acount(1) = nx + acount(2) = ny + + do n = 1,nloop + + write(6,*) "processing slice: ",n + astart(3) = astart(3) + input_stride(3) + ncstat = nf90_get_var(nc_infile_id, nc_input_id, grid1_array, & + start=astart(1:nc_input_rank), & + count=acount(1:nc_input_rank)) + call netcdf_error_handler(ncstat,"get_var") + + call calculate_grid(grid1_array, grid_out) + + call write_grid(grid_out, n, write_dims(1:2) , 2) + + enddo + + ! --------------------------------------------------------------------- + ! - now for any extra variables to copy + + if (numv > 0) then + + write(6,*) "reading ",numv," extra variables" + allocate( var_out(nloop,numv) ) + + do n = 1,numv + write(6,*) "looking for variable: ",trim(input_vars(n)) + ncstat = nf90_inq_varid( nc_infile_id, trim(input_vars(n)), nc_input_id ) + call netcdf_error_handler(ncstat,"inq_varid") + + input_dims(:) = 0 + ncstat = nf90_inquire_variable( nc_infile_id, nc_input_id, & + ndims=nc_input_rank, dimids=input_dimids(:) ) + call netcdf_error_handler(ncstat,"inquire_variable") + + if (nc_input_rank /= 1) then + write(6,*) 'sorry, only rank 1 variables can be copied' + cycle + endif + ncstat = nf90_inquire_dimension(nc_infile_id, & + input_dimids(1), len=input_dims(1) ) + call netcdf_error_handler(ncstat,"inquire_dimension") + + ncstat = nf90_get_var(nc_infile_id, nc_input_id, var_out(1:nloop,n), & + start=(/ vstart /), stride=(/ vstride /)) + call netcdf_error_handler(ncstat,"get_var") + enddo + + call write_extra(var_out, numv+2) + deallocate(var_out) + + endif + + ncstat = nf90_close(nc_outfile_id) + call netcdf_error_handler(ncstat,"out close") + ncstat = nf90_close(nc_infile_id) + call netcdf_error_handler(ncstat,"in close") + + ! --------------------------------------------------------------------- + + deallocate( grid1_array, grid_out) + + ! --------------------------------------------------------------------- + + end subroutine process_grid + + ! ========================================================================== + + subroutine define_grid(thedims, therank) + + !----------------------------------------------------------------------- + ! - dummy variables + + integer (kind=int_kind) :: & + therank + integer (kind=int_kind), dimension(therank) :: & + thedims + + !----------------------------------------------------------------------- + ! - local variables + + integer :: & + k, n, ilon, ilat, icolon, i1, i2, natt, nvar, id, jd, kd, nd + character (char_len) :: & + aname, vname, att + real (kind=dbl_kind) :: s + + ! - netcdf variables + + integer :: xtype + + !----------------------------------------------------------------------- + ! - define grid size dimensions + + allocate(nc_xysize_id(grid2_rank)) + allocate(nc_gridsize_id(therank)) + allocate(nc_gridsize(therank)) + allocate(nc_variable_id(therank-2)) + + !----------------------------------------------------------------------- + ! - setup a NetCDF file for output + + xtype = NF90_FLOAT + + write(6,*) 'creating output file' + ncstat = nf90_create (output_file, NF90_CLOBBER, nc_outfile_id) + call netcdf_error_handler(ncstat,"create") + + write(6,*) 'setting global attributes' + ncstat = nf90_put_att(nc_outfile_id, NF90_GLOBAL, 'title', map_name) + call netcdf_error_handler(ncstat,"put_att") + + write(6,*) 'setting dimensions' + do n=1,therank + if (n .eq. therank .and. therank .gt. 2) then + write(6,*) ' unlimited dim ',trim(output_dims(n)),' size: ',thedims(n) + ncstat = nf90_def_dim (nc_outfile_id, output_dims(n), NF90_UNLIMITED, & + nc_gridsize_id(n)) + else + write(6,*) ' dim ',trim(output_dims(n)),' size: ',thedims(n) + ncstat = nf90_def_dim (nc_outfile_id, output_dims(n), thedims(n), & + nc_gridsize_id(n)) + endif + call netcdf_error_handler(ncstat,"def_dim") + end do + nc_gridsize(:) = thedims(1:therank) + + ! - at the moment there is an assumption here that the ordering is (lon,lat) + + ilon = 1 + ilat = 2 + nc_xysize_id(1) = nc_gridsize_id(ilon) + nc_xysize_id(2) = nc_gridsize_id(ilat) + + ! ---------------------------------------------------------------- + ! - define grid center longitude array + + write(6,*) 'defining longitude variable' + ncstat = nf90_def_var (nc_outfile_id, output_lon, & + xtype, nc_xysize_id, & + nc_lon_id) + call netcdf_error_handler(ncstat,"def_var") + + ncstat = nf90_put_att (nc_outfile_id, nc_lon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat,"put_att") + + ! ---------------------------------------------------------------- + ! - define grid center latitude array + + write(6,*) 'defining latitude variable' + ncstat = nf90_def_var (nc_outfile_id, output_lat, & + xtype, nc_xysize_id, & + nc_lat_id) + call netcdf_error_handler(ncstat,"def_var") + + ncstat = nf90_put_att (nc_outfile_id, nc_lat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat,"put_att") + + ! ---------------------------------------------------------------- + ! - define copy variables array + + write(6,*) 'defining copy variables' + do n = 3,therank + ncstat = nf90_def_var (nc_outfile_id, output_vars(n-2), & + xtype, nc_gridsize_id(n), & + nc_variable_id(n-2)) + call netcdf_error_handler(ncstat,"def_var") + enddo + + ! ---------------------------------------------------------------- + ! - define output array + + write(6,*) 'defining grid variable' + ncstat = nf90_def_var (nc_outfile_id, output_name, & + xtype, nc_gridsize_id, & + nc_array_id) + call netcdf_error_handler(ncstat,"def_var") + + ! ---------------------------------------------------------------- + ! - output attributes has to come after all other definitions + ! - this code currently a bit murky, needs a rewrite + + ncstat = nf90_inquire (nc_outfile_id, nVariables=nvar) + call netcdf_error_handler(ncstat,"inquire") + do n = 1,10 + att = trim(output_attributes(n)) + natt = len(att) + if (att /= '-') then + i1 = index(att,separator) + aname = att(1:i1-1) + do k = 1,nvar + ncstat = nf90_inquire_variable(nc_outfile_id, k, vname) + call netcdf_error_handler(ncstat,"inquire_variable") + if (vname == aname) then + i2 = index(att,separator,.true.) + ncstat = nf90_put_att (nc_outfile_id, k, & + att(i1+1:i2-1), att(i2+1:natt)) + call netcdf_error_handler(ncstat,"put_att") + exit ! from innermost do + endif + enddo + endif + enddo + + ! output scaling + + allocate (scale(nvar)) + scale(:) = 1.0 + + do n = 1,10 + att = trim(output_scaling(n)) + natt = len(att) + if (att /= '-') then + i1 = index(att,separator) + aname = att(1:i1-1) + do k = 1,nvar + ncstat = nf90_inquire_variable(nc_outfile_id, k, vname) + call netcdf_error_handler(ncstat,"inquire_variable") + if (vname == aname) then + i2 = index(att,separator,.true.) + read(att(i2+1:natt),*) scale(k) + call netcdf_error_handler(ncstat,"put_att") + exit ! from innermost do + endif + enddo + endif + enddo + + ! ---------------------------------------------------------------- + ! - end definition stage + + ncstat = nf90_enddef(nc_outfile_id) + call netcdf_error_handler(ncstat,"enddef") + + end subroutine define_grid + + ! ========================================================================== + + subroutine write_grid(thegrid, thelevel, thedims, therank) + + !----------------------------------------------------------------------- + ! - dummy variables + + integer (kind=int_kind), intent(in) :: & + therank, thelevel + real (kind=dbl_kind), dimension(:), intent(in) :: & + thegrid + integer (kind=int_kind), dimension(therank) :: & + thedims + + !----------------------------------------------------------------------- + ! - local variables + + integer :: & + k, n, ilon, ilat, icolon, j1, j2, dj, natt, nvar, id, jd, kd, nd + character (char_len) :: & + aname, vname, att + real (kind=dbl_kind), dimension(:,:,:), allocatable :: & + data + real (kind=dbl_kind) :: s + real (kind=dbl_kind), parameter :: todeg = 57.295779513082323 + integer (kind=int_kind), dimension(3) :: & + start + + ! - netcdf variables + + integer :: xtype + + !----------------------------------------------------------------------- + ! - write results to NetCDF file + + allocate (data(thedims(1),thedims(2),1)) + if (output_ydir .eq. 'invert') then + j1 = thedims(2) + j2 = 1 + dj = -1 + else + j1 = 1 + j2 = thedims(2) + dj = 1 + endif + + if (thelevel .eq. 1) then + + ! - grid center latitude array + + write(6,*) 'writing latitude variable' + s = scale(nc_lat_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = s*todeg*grid2_center_lat(nd) + enddo + enddo + ncstat = nf90_put_var(nc_outfile_id, nc_lat_id, data(:,:,1)) + call netcdf_error_handler(ncstat,"put_var") + + ! - grid center longitude array + + write(6,*) 'writing longitude variable' + s = scale(nc_lon_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = s*todeg*grid2_center_lon(nd) + enddo + enddo + ncstat = nf90_put_var(nc_outfile_id, nc_lon_id, data(:,:,1)) + call netcdf_error_handler(ncstat,"put_var") + + endif + + !----------------------------------------------------------------------- + ! - new grid + + write(6,*) 'writing grid variable' + n = therank + s = scale(nc_array_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = thegrid(nd) + enddo + enddo + write(6,*) 'scaling data ' + data(:,:,1) = s*data(:,:,1) + start(:) = (/ 1, 1, thelevel /) + ncstat = nf90_put_var(nc_outfile_id, nc_array_id, data, start) + call netcdf_error_handler(ncstat,"put_var") + deallocate(data) + + end subroutine write_grid + + ! ========================================================================== + + subroutine write_extra(thevars, therank) + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + thevars + real (kind=dbl_kind), dimension(:), allocatable :: & + thedata + integer (kind=int_kind), intent(in) :: & + therank + real (kind=dbl_kind) :: s + integer :: n + + allocate( thedata(size(thevars,1)) ) + + ! - copy variable arrays + + write(6,*) 'writing copy variables' + do n = 3,therank + s = scale(nc_variable_id(n-2)) + thedata(:) = s*thevars(:,n-2) + ncstat = nf90_put_var(nc_outfile_id, nc_variable_id(n-2), thedata) + call netcdf_error_handler(ncstat,"put_var") + enddo + + deallocate( thedata ) + + end subroutine write_extra + + ! ========================================================================== + + subroutine close_grid() + + ! close netCDF file + + write(6,*) 'closing file' + ncstat = nf90_close(nc_outfile_id) + call netcdf_error_handler(ncstat,"close") + + end subroutine close_grid + + ! ========================================================================== + + subroutine read_mappings(nm_in) + + !----------------------------------------------------------------------- + ! - dummy variables + + character (char_len) :: & + nm_in ! name of input namelist file + + !----------------------------------------------------------------------- + ! - local variables + + character (char_len) :: & + dim_name ! netCDF dimension name + + integer (kind=int_kind) :: & + iunit ! unit number for namelist file + + !----------------------------------------------------------------------- + ! - namelist block + + namelist /interp_inputs/ input_file, interp_file, input_name, & + input_stride, input_start, input_stop, & + input_vars + namelist /interp_outputs/ output_dims, output_file, output_mode, output_name, & + output_lat, output_lon, output_ydir, & + output_scaling, output_vars, output_attributes + + !----------------------------------------------------------------------- + ! - read namelist for file and mapping info + + input_stride(:) = 1 + input_start(:) = 1 + input_stop(:) = 0 + output_scaling(:) = '-' + input_vars(:) = '-' + output_lon = '-' + output_lat = '-' + output_vars(:) = '-' + output_ydir = 'none' + output_attributes(:) = '-' + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=interp_inputs) + read(iunit, nml=interp_outputs) + call release_unit(iunit) + write(*,nml=interp_inputs) + write(*,nml=interp_outputs) + if (trim(output_mode) == "create") then + if (trim(output_lon) == '-' .or. trim(output_lat) == '-') then + write(6,*) 'if creating, need to supply lon and lat names' + stop + endif + endif + + !----------------------------------------------------------------------- + ! - read remapping data + ! - via the scrip package this sets variables: + ! grid1_size, grid2_size: sizes of input and output grids + ! grid1_mask, grid2_mask: masks + ! grid1_rank, grid2_rank: ranks + + call read_remap(map_name, interp_file) + + end subroutine read_mappings + + ! ========================================================================== + + subroutine calculate_grid(grid1_array, grid2_array) + + !----------------------------------------------------------------------- + ! - dummy variables + + real (kind=dbl_kind), intent(in), dimension(:) :: & + grid1_array + real (kind=dbl_kind), intent(out), dimension(:) :: & + grid2_array + + !----------------------------------------------------------------------- + ! - local variables + + integer (kind=int_kind), dimension(:), allocatable :: & + grid1_imask, grid2_imask, grid2_count + + real (kind=dbl_kind), dimension(:), allocatable :: & + grid1_tmp, & + grad1_lat, & + grad1_lon, & + grad1_latlon, & + grad1_lat_zero, & + grad1_lon_zero, & + grid2_tmp1, & + grid2_tmp2 + + real (kind=dbl_kind) :: & + delew, delns ! variables for computing bicub gradients + + integer (kind=int_kind) :: & + i,j,n,imin,imax,idiff, & + ip1,im1,jp1,jm1,nx,ny, & ! for computing bicub gradients + in,is,ie,iw,ine,inw,ise,isw + + logical, parameter :: lat_gradient = .false. + + write(6,*) 'starting' + + !----------------------------------------------------------------------- + ! - allocate arrays + + allocate (grid1_tmp (grid1_size), & + grad1_lat (grid1_size), & + grad1_lon (grid1_size), & + grad1_lat_zero (grid1_size), & + grad1_lon_zero (grid1_size), & + grid1_imask (grid1_size), & + grid2_tmp1 (grid2_size), & + grid2_tmp2 (grid2_size), & + grid2_imask (grid2_size), & + grid2_count (grid2_size)) + + write(6,*) 'allocated' + write(6,*) grid1_size,grid2_size + + grid1_imask(:) = 1 + grid2_imask(:) = 1 + where (grid1_mask) + grid1_imask = 1 + elsewhere + grid1_imask = 0 + endwhere + where (grid2_mask) + grid2_imask = 1 + elsewhere + grid2_imask = 0 + endwhere + + write(6,*) 'masked' + + grad1_lat_zero = zero + grad1_lon_zero = zero + nx = input_dims(1) + ny = input_dims(2) + write(6,*) nx,ny + + !----------------------------------------------------------------------- + ! - if bicubic, we need 3 gradients in logical space + + if (map_type == map_type_bicubic) then + + write(6,*) 'bicubic' + write(6,*) grid1_size + + allocate (grad1_latlon (grid1_size)) + + do n=1,grid1_size + + grad1_lat(n) = zero + grad1_lon(n) = zero + grad1_latlon(n) = zero + +! if (n.ge.8000) write(6,*) 0,grid1_mask(n),nx + if (grid1_mask(n)) then + + delew = half + delns = half + + j = (n-1)/nx + 1 + i = n - (j-1)*nx + + ip1 = i+1 + im1 = i-1 + jp1 = j+1 + jm1 = j-1 + + if (ip1 > nx) ip1 = ip1 - nx + if (im1 < 1 ) im1 = nx + if (jp1 > ny) then + jp1 = j + delns = one + endif + if (jm1 < 1 ) then + jm1 = j + delns = one + endif + + in = (jp1-1)*nx + i + is = (jm1-1)*nx + i + ie = (j -1)*nx + ip1 + iw = (j -1)*nx + im1 + + ine = (jp1-1)*nx + ip1 + inw = (jp1-1)*nx + im1 + ise = (jm1-1)*nx + ip1 + isw = (jm1-1)*nx + im1 + + ! - compute i-gradient + + if (.not. grid1_mask(ie)) then + ie = n + delew = one + endif + if (.not. grid1_mask(iw)) then + iw = n + delew = one + endif + + grad1_lat(n) = delew*(grid1_array(ie) - grid1_array(iw)) +! if (n.ge.8000) write(6,*) 1,grad1_lat(n) + + ! - compute j-gradient + + if (.not. grid1_mask(in)) then + in = n + delns = one + endif + if (.not. grid1_mask(is)) then + is = n + delns = one + endif + + grad1_lon(n) = delns*(grid1_array(in) - grid1_array(is)) +! if (n.ge.8000) write(6,*) 2,grad1_lon(n) + + ! - compute ij-gradient + + delew = half + if (jp1 == j .or. jm1 == j) then + delns = one + else + delns = half + endif + + if (.not. grid1_mask(ine)) then + if (in /= n) then + ine = in + delew = one + else if (ie /= n) then + ine = ie + inw = iw + if (inw == n) delew = one + delns = one + else + ine = n + inw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(inw)) then + if (in /= n) then + inw = in + delew = one + else if (iw /= n) then + inw = iw + ine = ie + if (ie == n) delew = one + delns = one + else + inw = n + ine = ie + delew = one + delns = one + endif + endif + + grad1_lat_zero(n) = delew*(grid1_array(ine) - grid1_array(inw)) +! if (n.ge.8000) write(6,*) 3,grad1_lat_zero(n) + + if (.not. grid1_mask(ise)) then + if (is /= n) then + ise = is + delew = one + else if (ie /= n) then + ise = ie + isw = iw + if (isw == n) delew = one + delns = one + else + ise = n + isw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(isw)) then + if (is /= n) then + isw = is + delew = one + else if (iw /= n) then + isw = iw + ise = ie + if (ie == n) delew = one + delns = one + else + isw = n + ise = ie + delew = one + delns = one + endif + endif + + grad1_lon_zero(n) = delew*(grid1_array(ise) - grid1_array(isw)) + grad1_latlon(n) = delns*(grad1_lat_zero(n) - grad1_lon_zero(n)) +! if (n.ge.8000) write(6,*) 4,grad1_lon_zero(n),grad1_latlon(n) + + endif + enddo + + write(6,*) 'remapping' + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1, & + grid1_array, src_grad1=grad1_lat, & + src_grad2=grad1_lon, src_grad3=grad1_latlon) + + print *,'Third order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array *grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - a first-order map from grid1 to grid2 + + else if (map_type /= map_type_conserv .AND.map_type /= map_type_bicubic) then + + write(6,*) 'bilinear or conservative' + + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1,grid1_array) + + print *,'First order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array *grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - conservative mappings: + ! - a second-order map from grid1 to grid2 with only lat grads + + else if (map_type == map_type_conserv .AND. lat_gradient) then + + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1, & + grid1_array, src_grad1=grad1_lat,src_grad2=grad1_lon_zero) + + select case (norm_opt) + case (norm_opt_none) + grid2_tmp2 = grid2_frac*grid2_area + where (grid2_tmp2 /= zero) + grid2_array = grid2_array/grid2_tmp2 + elsewhere + grid2_array = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_array = grid2_array/grid2_frac + elsewhere + grid2_array = zero + end where + end select + + print *,'Second order mapping from grid1 to grid2 (lat only):' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array*grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - conservative mappings: + ! - a second-order map from grid1 to grid2 both gradients + + else if (map_type == map_type_conserv .AND..NOT. lat_gradient) then + + call remap(grid2_array,wts_map1,grid2_add_map1,grid1_add_map1, & + grid1_array, src_grad1=grad1_lat,src_grad2=grad1_lon) + + select case (norm_opt) + case (norm_opt_none) + grid2_tmp2 = grid2_frac*grid2_area + where (grid2_tmp2 /= zero) + grid2_array = grid2_array/grid2_tmp2 + elsewhere + grid2_array = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_array = grid2_array/grid2_frac + elsewhere + grid2_array = zero + end where + end select + + print *,'Second order mapping from grid1 to grid2:' + print *,'-----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array*grid2_area*grid2_frac) + + endif + + !----------------------------------------------------------------------- + ! calculate some statistics + + grid2_count = zero + grid2_tmp1 = zero + grid2_tmp2 = zero + + print *,'number of sparse matrix entries ',num_links_map1 + do n=1,num_links_map1 + grid2_count(grid2_add_map1(n)) = grid2_count(grid2_add_map1(n)) + 1 + if (wts_map1(1,n) > one .or. wts_map1(1,n) < zero) then + grid2_tmp1(grid2_add_map1(n)) = grid2_tmp1(grid2_add_map1(n)) + 1 + grid2_tmp2(grid2_add_map1(n)) = max(abs(wts_map1(1,n)),grid2_tmp2(grid2_add_map1(n)) ) + endif + end do + + do n=1,grid2_size + if (grid2_tmp1(n) > zero) print *,n,grid2_tmp2(n) + end do + + imin = minval(grid2_count, mask=(grid2_count > 0)) + imax = maxval(grid2_count) + idiff = (imax - imin)/10 + 1 + print *,'total number of dest cells ',grid2_size + print *,'number of cells participating in remap ',count(grid2_count > zero) + print *,'min no of entries/row = ',imin + print *,'max no of entries/row = ',imax + + imax = imin + idiff + do n=1,10 + print *,'num of rows with entries between ',imin,' - ',imax-1, & + count(grid2_count >= imin .and. grid2_count < imax) + imin = imin + idiff + imax = imax + idiff + end do + + !----------------------------------------------------------------------- + ! - deallocate arrays + + deallocate (grid1_tmp, grad1_lat, grad1_lon, & + grad1_lat_zero, grad1_lon_zero, grid1_imask, & + grid2_tmp1, grid2_tmp2, & + grid2_imask, grid2_count) + + end subroutine calculate_grid + + ! ========================================================================== + +end module scripinterp_mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripshape.F90 b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripshape.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2837627659ec69d3bb49f5b9f792a6379892c619 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/nocsutil/scripshape.F90 @@ -0,0 +1,419 @@ + PROGRAM scripshape +! +! program to take output from the SCRIP weights generator +! and rearrange the data into a series of 2D fields suitable +! for reading with iom_get in NEMO configurations using the +! interpolation on the fly option +! + USE netcdf + IMPLICIT none + INTEGER :: ncId, VarId, status + INTEGER :: start(4), count(4) + CHARACTER(LEN=1) :: y + INTEGER :: nd, ns, nl, nw, sx, sy, dx, dy + INTEGER :: i, j, k, m, n, smax +! +! ifort -O2 -o scripshape scripshape.f90 \ +! -I/nerc/packages/netcdfifort/v3.6.0-pl1/include \ +! -L/nerc/packages/netcdfifort/v3.6.0-pl1/lib -lnetcdf +! +! + INTEGER(KIND=4), ALLOCATABLE :: src(:) + INTEGER(KIND=4), ALLOCATABLE :: dst(:) + REAL(KIND=8), ALLOCATABLE :: wgt(:,:) + REAL(KIND=8), ALLOCATABLE :: src1(:,:),dst1(:,:),wgt1(:,:) + LOGICAL :: around, verbose +#if defined ARGC + INTEGER(KIND=4) :: iargc + EXTERNAL :: iargc +#endif + + CHARACTER(LEN=256) :: interp_file, output_file, name_file + INTEGER :: ew_wrap + NAMELIST /shape_inputs/ interp_file, output_file, ew_wrap + +! scripshape requires 1 arguments; the name of the file containing +! the input namelist. +! This namelist contains: +! the name of the input file containing the weights ! produced by SCRIP in its format; +! the name of the new output file which ! is to contain the reorganized fields ready for input to NEMO. +! the east-west wrapping of the input grid (-1, 0, 1 and 2 are accepted values) +! +! E.g. +! interp_file = 'data_nemo_bilin.nc' +! output_file = 'weights_bilin.nc' +! ew_wrap = 2 +! +#if defined ARGC + IF (iargc() == 1) THEN + CALL getarg(1, name_file) + ELSE + WRITE(*,*) 'Usage: scripshape namelist_file' + STOP + ENDIF +#else + WRITE(6,*) 'enter name of namelist file' + READ(5,*) name_file +#endif + interp_file = 'none' + output_file = 'none' + ew_wrap = 0 + OPEN(12, FILE=name_file, STATUS='OLD', FORM='FORMATTED') + READ(12, NML=shape_inputs) + CLOSE(12) +! + INQUIRE(FILE = TRIM(interp_file), EXIST=around) + IF (.not.around) THEN + WRITE(*,*) 'Input file: '//TRIM(interp_file)//' not found' + STOP + ENDIF +! + INQUIRE(FILE = TRIM(output_file), EXIST=around) + IF (around) THEN + WRITE(*,*) 'Output file: '//TRIM(output_file)//' exists' + WRITE(*,*) 'Ok to overwrite (y/n)?' + READ(5,'(a)') y + IF ( y .ne. 'y' .AND. y .ne. 'Y' ) STOP + ENDIF +! + verbose = .true. +! +! Obtain grid size information from interp_file +! + CALL ncgetsize +! +! Allocate array spaces +! + ALLOCATE(src(nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('src') + ALLOCATE(dst(nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('dst') + ALLOCATE(wgt(nw,nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('wgt') + ALLOCATE(src1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('src1') + ALLOCATE(dst1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('dst1') + ALLOCATE(wgt1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('wgt1') +! +! Read all required data from interp_file +! + CALL ncgetfields +! +! Check that dst is monotonically increasing +! + DO k = 1,nl-1 + IF(dst(k+1).lt.dst(k)) THEN + WRITE(*,*) 'non-monotonic at ',k + WRITE(*,*) dst(k-4:k+16) + STOP + ENDIF + END DO +! +! Remove references to the top row of src +! + IF(verbose) WRITE(*,*) & + 'Removing references to the top row of the source grid' + smax = (sy-1)*sx + n = 0 + DO k = 1,nl + IF(src(k).gt.smax-1) THEN + src(k) = src(k)-sx + n = n + 1 + ENDIF + END DO + IF(verbose) WRITE(*,*) n,' values changed (',100.*n/nl,'%)' +! +! Loop through weights for each corner in turn and +! rearrange weight fields into separate 2D fields for +! reading with iom_get in NEMO +! + DO k = 1,nw + DO n = 1,4 + + i = 0 + j = 1 + DO m = n,nl,4 + i = i+1 + IF(i.gt.dx) THEN + i = 1 + j = j + 1 + ENDIF + src1(i,j) = src(m) + dst1(i,j) = dst(m) + wgt1(i,j) = wgt(k,m) + END DO +! +! Write out this set which will be labelled with +! a 2 digit number equal to n+4*(k-1) +! + CALL wrwgts +! + END DO + END DO + STOP + CONTAINS +! +!----------------------------------------------------------------------* + SUBROUTINE ncgetsize +! +! Access grid size information in interp_file and set the +! following integers: +! +! nd = dst_grid_size +! ns = src_grid_size +! nl = num_links +! nw = num_wgts +! sx,sy = src_grid_dims +! dx,dy = dst_grid_dims +! + INTEGER idims(2) +! + status = nf90_open(interp_file, nf90_NoWrite, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'dst_grid_size', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nd) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'src_grid_size', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = ns) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'num_links', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nl) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'num_wgts', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nw) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + start = 1 + count = 2 + status = nf90_inq_varid(ncid, 'src_grid_dims', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_get_var(ncid, VarId, idims, start, count) + IF(status /= nf90_NoErr) CALL handle_err(status) + sx = idims(1) ; sy = idims(2) +! + status = nf90_inq_varid(ncid, 'dst_grid_dims', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_get_var(ncid, VarId, idims, start, count) + IF(status /= nf90_NoErr) CALL handle_err(status) + dx = idims(1) ; dy = idims(2) +! + status = nf90_close(ncid) + IF (status /= nf90_noerr) CALL handle_err(status) +! + IF(verbose) THEN + WRITE(*,*) 'Detected sizes: ' + WRITE(*,*) 'dst_grid_size: ', nd + WRITE(*,*) 'src_grid_size: ', ns + WRITE(*,*) 'num_links : ', nl + WRITE(*,*) 'num_wgts : ', nw + WRITE(*,*) 'src_grid_dims: ', sx, ' x ', sy + WRITE(*,*) 'dst_grid_dims: ', dx, ' x ', dy + ENDIF +! + END SUBROUTINE ncgetsize + +!----------------------------------------------------------------------* + SUBROUTINE ncgetfields +! +! Read all required data from interp_file. The data read are: +! +! netcdf variable size internal array +!-----------------+-------+-------------- +! src_address nl src +! dst_address nl dst +! remap_matrix (nw,nl) wgt +! + status = nf90_open(interp_file, nf90_NoWrite, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'src_address', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for src + status = nf90_get_var(ncid, VarId, src, & + start = (/ 1 /), & + count = (/ nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'dst_address', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for dst + status = nf90_get_var(ncid, VarId, dst, & + start = (/ 1 /), & + count = (/ nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'remap_matrix', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for wgt + status = nf90_get_var(ncid, VarId, wgt, & + start = (/ 1, 1 /), & + count = (/ nw, nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_close(ncid) + IF (status /= nf90_noerr) CALL handle_err(status) +! + END SUBROUTINE ncgetfields + +!----------------------------------------------------------------------* + SUBROUTINE handle_err(status) +! +! Simple netcdf error checking routine +! + INTEGER, intent ( in) :: status +! + IF(status /= nf90_noerr) THEN + IF(trim(nf90_strerror(status)) .eq. 'Attribute not found') THEN +! ignore + ELSE + WRITE(*,*) trim(nf90_strerror(status)) + STOP "Stopped" + END IF + END IF + END SUBROUTINE handle_err + +!----------------------------------------------------------------------* + SUBROUTINE alloc_err(arname) +! +! Simple allocation error checking routine +! + CHARACTER(LEN=*) :: arname +! + WRITE(*,*) 'Allocation error attempting to ALLOCATE '//arname + STOP "Stopped" + END SUBROUTINE alloc_err + +! +!----------------------------------------------------------------------* + SUBROUTINE wrwgts +! +! Write out each set of 2D fields to output_file. +! Each call will write out a set of srcXX, dstXX and wgtXX fields +! where XX is a two digit number equal to n + 4*(k-1). The first +! and last calls to this routine initialise and close the output +! file respectively. The first call is detected when k*n=1 and the +! last call is detected when k*n=4*nw. The outfile file remains +! open between the first and last calls. +! + INTEGER :: status, ncid, ncin + INTEGER :: Lontdid, Lattdid + INTEGER :: tvid, tvid2, tvid3 + INTEGER :: ioldfill + CHARACTER(LEN=2) :: cs + SAVE ncid, Lontdid, Lattdid +! + IF(k*n.eq.1) THEN +! +! Create output_file and set the dimensions +! + status = nf90_create(output_file, nf90_Clobber, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_set_fill(ncid, nf90_NoFill, ioldfill) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_dim(ncid, "lon", dx, Lontdid) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_def_dim(ncid, "lat", dy, Lattdid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_att(ncid, nf90_global, 'ew_wrap', ew_wrap) + IF(status /= nf90_NoErr) CALL handle_err(status) + ELSE +! +! Reenter define mode +! + status = nf90_redef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + ENDIF +! + WRITE(cs,'(i2.2)') n + 4*(k-1) +! +! Define new variables +! + status = nf90_def_var(ncid, "src"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_var(ncid, "dst"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid2) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_var(ncid, "wgt"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid3) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Leave define mode +! + status = nf90_enddef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Write the data +! + status = nf90_put_var(ncid, tvid, src1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_var(ncid, tvid2, dst1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_var(ncid, tvid3, wgt1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + IF(k*n.eq.4*nw) THEN +! +! -- Reenter define mode +! + status = nf90_redef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Reopen interp_file and transfer some global attributes +! + status = nf90_open(interp_file, nf90_NoWrite, ncin) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'title', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'normalization',ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'map_method', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'conventions', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'history', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Close interp_file +! + status = nf90_close(ncin) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Close output_file +! + status = nf90_close(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + ENDIF + + END SUBROUTINE wrwgts + END PROGRAM scripshape diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/CHANGES_BY_NOCS b/V4.0/nemo_sources/tools/WEIGHTS/src/CHANGES_BY_NOCS new file mode 100644 index 0000000000000000000000000000000000000000..2237d3f4379b8255e8bbccfb9d64bdb892f66b15 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/CHANGES_BY_NOCS @@ -0,0 +1,12 @@ + + SCRIP code, version 1.4, from Los Alamos National Laboratory (http://climate.lanl.gov/Software/SCRIP) + + Changes made at NOCS for inclusion of weights generation code in NEMO 3.3 and later: + + - File extensions changed from '.f' to '.f90' + - File netcdf.f renamed as netcdf_mod.f90 to avoid clash with netcdf library module filename + - File netcdf.f modified to add error message to netcdf_error_handler + - Small bug in remap_conserv when using gfortran compiler: replace ". and." with " .and." + - continuation lines reformatted with '&' moved from the start of the continuation line to + the end of the line before + \ No newline at end of file diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/constants.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/constants.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7e611c9f31bd0daa04a4374cdf6ff6bee8bbfe16 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/constants.f90 @@ -0,0 +1,65 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module defines common constants used in many routines. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: constants.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module constants + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + + implicit none + + save + +!----------------------------------------------------------------------- + + real (kind = dbl_kind), parameter :: & + zero = 0.0_dbl_kind, & + one = 1.0_dbl_kind, & + two = 2.0_dbl_kind, & + three = 3.0_dbl_kind, & + four = 4.0_dbl_kind, & + five = 5.0_dbl_kind, & + half = 0.5_dbl_kind, & + quart = 0.25_dbl_kind, & + bignum = 1.e+20_dbl_kind, & + tiny = 1.e-14_dbl_kind, & + pi = 3.14159265359_dbl_kind, & + pi2 = two*pi, & + pih = half*pi + +!----------------------------------------------------------------------- + + end module constants + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/copyright b/V4.0/nemo_sources/tools/WEIGHTS/src/copyright new file mode 100644 index 0000000000000000000000000000000000000000..64f69fca38de389f4b31807b57f9149f5c83087e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/copyright @@ -0,0 +1,26 @@ +!----------------------------------------------------------------------- +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!----------------------------------------------------------------------- diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/grids.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/grids.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b14c5b3449d83338e6b5455d9fddac340cb5d397 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/grids.f90 @@ -0,0 +1,831 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module reads in and initializes two grids for remapping. +! NOTE: grid1 must be the master grid -- the grid that determines +! which cells participate (e.g. land mask) and the fractional +! area of grid2 cells that participate in the remapping. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: grids.f,v 1.6 2001/08/21 21:06:41 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module grids + +!----------------------------------------------------------------------- + + use kinds_mod ! defines data types + use constants ! common constants + use iounits ! I/O unit manager + use netcdf_mod ! netCDF stuff + + implicit none + +!----------------------------------------------------------------------- +! +! variables that describe each grid +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), save :: & + grid1_size, grid2_size, & ! total points on each grid + grid1_rank, grid2_rank, & ! rank of each grid + grid1_corners, grid2_corners ! number of corners + ! for each grid cell + + integer (kind=int_kind), dimension(:), allocatable, save :: & + grid1_dims, grid2_dims ! size of each grid dimension + + character(char_len), save :: & + grid1_name, grid2_name ! name for each grid + + character (char_len), save :: & + grid1_units, & ! units for grid coords (degs/radians) + grid2_units ! units for grid coords + + real (kind=dbl_kind), parameter :: & + deg2rad = pi/180. ! conversion for deg to rads + +!----------------------------------------------------------------------- +! +! grid coordinates and masks +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(:), allocatable, save :: & + grid1_mask, & ! flag which cells participate + grid2_mask ! flag which cells participate + + real (kind=dbl_kind), dimension(:), allocatable, save :: & + grid1_center_lat, & ! lat/lon coordinates for + grid1_center_lon, & ! each grid center in radians + grid2_center_lat, & + grid2_center_lon, & + grid1_area, & ! tot area of each grid1 cell + grid2_area, & ! tot area of each grid2 cell + grid1_area_in, & ! area of grid1 cell from file + grid2_area_in, & ! area of grid2 cell from file + grid1_frac, & ! fractional area of grid cells + grid2_frac ! participating in remapping + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: & + grid1_corner_lat, & ! lat/lon coordinates for + grid1_corner_lon, & ! each grid corner in radians + grid2_corner_lat, & + grid2_corner_lon + + logical (kind=log_kind), save :: & + luse_grid_centers & ! use centers for bounding boxes + , luse_grid1_area & ! use area from grid file + , luse_grid2_area ! use area from grid file + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: & + grid1_bound_box, & ! lat/lon bounding box for use + grid2_bound_box ! in restricting grid searches + +!----------------------------------------------------------------------- +! +! bins for restricting searches +! +!----------------------------------------------------------------------- + + character (char_len), save :: & + restrict_type ! type of bins to use + + integer (kind=int_kind), save :: & + num_srch_bins ! num of bins for restricted srch + + integer (kind=int_kind), dimension(:,:), allocatable, save :: & + bin_addr1, & ! min,max adds for grid1 cells in this lat bin + bin_addr2 ! min,max adds for grid2 cells in this lat bin + + real(kind=dbl_kind), dimension(:,:), allocatable, save :: & + bin_lats & ! min,max latitude for each search bin + , bin_lons ! min,max longitude for each search bin + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine grid_init(grid1_file, grid2_file) + +!----------------------------------------------------------------------- +! +! this routine reads grid info from grid files and makes any +! necessary changes (e.g. for 0,2pi longitude range) +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: & + grid1_file, grid2_file ! grid data files + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: & + n & ! loop counter + , nele & ! element loop counter + , iunit & ! unit number for opening files + , i,j & ! logical 2d addresses + , ip1,jp1 & + , n_add, e_add, ne_add & + , nx, ny + + integer (kind=int_kind) :: & + ncstat, & ! netCDF status variable + nc_grid1_id, & ! netCDF grid file id + nc_grid2_id, & ! netCDF grid file id + nc_grid1size_id, & ! netCDF grid size dim id + nc_grid2size_id, & ! netCDF grid size dim id + nc_grid1corn_id, & ! netCDF grid corner dim id + nc_grid2corn_id, & ! netCDF grid corner dim id + nc_grid1rank_id, & ! netCDF grid rank dim id + nc_grid2rank_id, & ! netCDF grid rank dim id + nc_grid1area_id, & ! netCDF grid rank dim id + nc_grid2area_id, & ! netCDF grid rank dim id + nc_grid1dims_id, & ! netCDF grid dimension size id + nc_grid2dims_id, & ! netCDF grid dimension size id + nc_grd1imask_id, & ! netCDF grid imask var id + nc_grd2imask_id, & ! netCDF grid imask var id + nc_grd1crnrlat_id, & ! netCDF grid corner lat var id + nc_grd2crnrlat_id, & ! netCDF grid corner lat var id + nc_grd1crnrlon_id, & ! netCDF grid corner lon var id + nc_grd2crnrlon_id, & ! netCDF grid corner lon var id + nc_grd1cntrlat_id, & ! netCDF grid center lat var id + nc_grd2cntrlat_id, & ! netCDF grid center lat var id + nc_grd1cntrlon_id, & ! netCDF grid center lon var id + nc_grd2cntrlon_id ! netCDF grid center lon var id + + integer (kind=int_kind), dimension(:), allocatable :: & + imask ! integer mask read from file + + real (kind=dbl_kind) :: & + dlat,dlon ! lat/lon intervals for search bins + + real (kind=dbl_kind), dimension(4) :: & + tmp_lats, tmp_lons ! temps for computing bounding boxes + +!----------------------------------------------------------------------- +! +! open grid files and read grid size/name data +! +!----------------------------------------------------------------------- + + ncstat = nf_open(grid1_file, NF_NOWRITE, nc_grid1_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_open(grid2_file, NF_NOWRITE, nc_grid2_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id, 'grid_size', nc_grid1size_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id, nc_grid1size_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id, 'grid_size', nc_grid2size_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id, nc_grid2size_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id, 'grid_rank', nc_grid1rank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id, nc_grid1rank_id, grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id, 'grid_rank', nc_grid2rank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id, nc_grid2rank_id, grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid1_id,'grid_corners',nc_grid1corn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid1_id,nc_grid1corn_id,grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_grid2_id,'grid_corners',nc_grid2corn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_grid2_id,nc_grid2corn_id,grid2_corners) + call netcdf_error_handler(ncstat) + + allocate( grid1_dims(grid1_rank), & + grid2_dims(grid2_rank)) + + ncstat = nf_get_att_text(nc_grid1_id, nf_global, 'title', & + grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_grid2_id, nf_global, 'title', & + grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! allocate grid coordinates/masks and read data +! +!----------------------------------------------------------------------- + + allocate( grid1_mask (grid1_size), & + grid2_mask (grid2_size), & + grid1_center_lat(grid1_size), & + grid1_center_lon(grid1_size), & + grid2_center_lat(grid2_size), & + grid2_center_lon(grid2_size), & + grid1_area (grid1_size), & + grid2_area (grid2_size), & + grid1_frac (grid1_size), & + grid2_frac (grid2_size), & + grid1_corner_lat(grid1_corners, grid1_size), & + grid1_corner_lon(grid1_corners, grid1_size), & + grid2_corner_lat(grid2_corners, grid2_size), & + grid2_corner_lon(grid2_corners, grid2_size), & + grid1_bound_box (4 , grid1_size), & + grid2_bound_box (4 , grid2_size)) + + allocate(imask(grid1_size)) + + ncstat = nf_inq_varid(nc_grid1_id, 'grid_dims', nc_grid1dims_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_imask', nc_grd1imask_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_center_lat', & + nc_grd1cntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_center_lon', & + nc_grd1cntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_corner_lat', & + nc_grd1crnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_corner_lon', & + nc_grd1crnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid1_id, nc_grid1dims_id, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid1_id, nc_grd1imask_id, imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1cntrlat_id, & + grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1cntrlon_id, & + grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1crnrlat_id, & + grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid1_id, nc_grd1crnrlon_id, & + grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (luse_grid1_area) then + allocate (grid1_area_in(grid1_size)) + ncstat = nf_inq_varid(nc_grid1_id, 'grid_area', nc_grid1area_id) + call netcdf_error_handler(ncstat) + ncstat = nf_get_var_double(nc_grid1_id, nc_grid1area_id, & + grid1_area_in) + call netcdf_error_handler(ncstat) + endif + + grid1_area = zero + grid1_frac = zero + +!----------------------------------------------------------------------- +! +! initialize logical mask and convert lat/lon units if required +! +!----------------------------------------------------------------------- + + where (imask == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + deallocate(imask) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_grid1_id, nc_grd1cntrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + + end select + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_grid1_id, nc_grd1crnrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + + end select + + ncstat = nf_close(nc_grid1_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! read data for grid 2 +! +!----------------------------------------------------------------------- + + allocate(imask(grid2_size)) + + ncstat = nf_inq_varid(nc_grid2_id, 'grid_dims', nc_grid2dims_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_imask', nc_grd2imask_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_center_lat', & + nc_grd2cntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_center_lon', & + nc_grd2cntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_corner_lat', & + nc_grd2crnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_corner_lon', & + nc_grd2crnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid2_id, nc_grid2dims_id, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_grid2_id, nc_grd2imask_id, imask) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2cntrlat_id, & + grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2cntrlon_id, & + grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2crnrlat_id, & + grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_grid2_id, nc_grd2crnrlon_id, & + grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + allocate (grid2_area_in(grid2_size)) + ncstat = nf_inq_varid(nc_grid2_id, 'grid_area', nc_grid2area_id) + call netcdf_error_handler(ncstat) + ncstat = nf_get_var_double(nc_grid2_id, nc_grid2area_id, & + grid2_area_in) + call netcdf_error_handler(ncstat) + endif + + grid2_area = zero + grid2_frac = zero + +!----------------------------------------------------------------------- +! +! initialize logical mask and convert lat/lon units if required +! +!----------------------------------------------------------------------- + + where (imask == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(imask) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_grid2_id, nc_grd2cntrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + + end select + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_grid2_id, nc_grd2crnrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + + case ('radians') + + !*** no conversion necessary + + case default + + print *,'no units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + + end select + + ncstat = nf_close(nc_grid2_id) + call netcdf_error_handler(ncstat) + + +!----------------------------------------------------------------------- +! +! convert longitudes to 0,2pi interval +! +!----------------------------------------------------------------------- + + where (grid1_center_lon .gt. pi2) grid1_center_lon = & + grid1_center_lon - pi2 + where (grid1_center_lon .lt. zero) grid1_center_lon = & + grid1_center_lon + pi2 + where (grid2_center_lon .gt. pi2) grid2_center_lon = & + grid2_center_lon - pi2 + where (grid2_center_lon .lt. zero) grid2_center_lon = & + grid2_center_lon + pi2 + where (grid1_corner_lon .gt. pi2) grid1_corner_lon = & + grid1_corner_lon - pi2 + where (grid1_corner_lon .lt. zero) grid1_corner_lon = & + grid1_corner_lon + pi2 + where (grid2_corner_lon .gt. pi2) grid2_corner_lon = & + grid2_corner_lon - pi2 + where (grid2_corner_lon .lt. zero) grid2_corner_lon = & + grid2_corner_lon + pi2 + +!----------------------------------------------------------------------- +! +! make sure input latitude range is within the machine values +! for +/- pi/2 +! +!----------------------------------------------------------------------- + + where (grid1_center_lat > pih) grid1_center_lat = pih + where (grid1_corner_lat > pih) grid1_corner_lat = pih + where (grid1_center_lat < -pih) grid1_center_lat = -pih + where (grid1_corner_lat < -pih) grid1_corner_lat = -pih + + where (grid2_center_lat > pih) grid2_center_lat = pih + where (grid2_corner_lat > pih) grid2_corner_lat = pih + where (grid2_center_lat < -pih) grid2_center_lat = -pih + where (grid2_corner_lat < -pih) grid2_corner_lat = -pih + +!----------------------------------------------------------------------- +! +! compute bounding boxes for restricting future grid searches +! +!----------------------------------------------------------------------- + + if (.not. luse_grid_centers) then + grid1_bound_box(1,:) = minval(grid1_corner_lat, DIM=1) + grid1_bound_box(2,:) = maxval(grid1_corner_lat, DIM=1) + grid1_bound_box(3,:) = minval(grid1_corner_lon, DIM=1) + grid1_bound_box(4,:) = maxval(grid1_corner_lon, DIM=1) + + grid2_bound_box(1,:) = minval(grid2_corner_lat, DIM=1) + grid2_bound_box(2,:) = maxval(grid2_corner_lat, DIM=1) + grid2_bound_box(3,:) = minval(grid2_corner_lon, DIM=1) + grid2_bound_box(4,:) = maxval(grid2_corner_lon, DIM=1) + + else + + nx = grid1_dims(1) + ny = grid1_dims(2) + + do n=1,grid1_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + if (abs(grid1_center_lat(e_add) - & + grid1_center_lat(n )) > pih) then + ip1 = i + endif + endif + + if (j < ny) then + jp1 = j+1 + else + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + if (abs(grid1_center_lat(n_add) - & + grid1_center_lat(n )) > pih) then + jp1 = j + endif + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid1_center_lat(n) + tmp_lats(2) = grid1_center_lat(e_add) + tmp_lats(3) = grid1_center_lat(ne_add) + tmp_lats(4) = grid1_center_lat(n_add) + + tmp_lons(1) = grid1_center_lon(n) + tmp_lons(2) = grid1_center_lon(e_add) + tmp_lons(3) = grid1_center_lon(ne_add) + tmp_lons(4) = grid1_center_lon(n_add) + + grid1_bound_box(1,n) = minval(tmp_lats) + grid1_bound_box(2,n) = maxval(tmp_lats) + grid1_bound_box(3,n) = minval(tmp_lons) + grid1_bound_box(4,n) = maxval(tmp_lons) + end do + + nx = grid2_dims(1) + ny = grid2_dims(2) + + do n=1,grid2_size + + !*** find N,S and NE points to this grid point + + j = (n - 1)/nx +1 + i = n - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + !*** assume cyclic + ip1 = 1 + !*** but if it is not, correct + e_add = (j - 1)*nx + ip1 + if (abs(grid2_center_lat(e_add) - & + grid2_center_lat(n )) > pih) then + ip1 = i + endif + endif + + if (j < ny) then + jp1 = j+1 + else + !*** assume cyclic + jp1 = 1 + !*** but if it is not, correct + n_add = (jp1 - 1)*nx + i + if (abs(grid2_center_lat(n_add) - & + grid2_center_lat(n )) > pih) then + jp1 = j + endif + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** find N,S and NE lat/lon coords and check bounding box + + tmp_lats(1) = grid2_center_lat(n) + tmp_lats(2) = grid2_center_lat(e_add) + tmp_lats(3) = grid2_center_lat(ne_add) + tmp_lats(4) = grid2_center_lat(n_add) + + tmp_lons(1) = grid2_center_lon(n) + tmp_lons(2) = grid2_center_lon(e_add) + tmp_lons(3) = grid2_center_lon(ne_add) + tmp_lons(4) = grid2_center_lon(n_add) + + grid2_bound_box(1,n) = minval(tmp_lats) + grid2_bound_box(2,n) = maxval(tmp_lats) + grid2_bound_box(3,n) = minval(tmp_lons) + grid2_bound_box(4,n) = maxval(tmp_lons) + end do + + endif + + where (abs(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) + grid1_bound_box(3,:) = zero + grid1_bound_box(4,:) = pi2 + end where + + where (abs(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) + grid2_bound_box(3,:) = zero + grid2_bound_box(4,:) = pi2 + end where + + !*** + !*** try to check for cells that overlap poles + !*** + + where (grid1_center_lat > grid1_bound_box(2,:)) & + grid1_bound_box(2,:) = pih + + where (grid1_center_lat < grid1_bound_box(1,:)) & + grid1_bound_box(1,:) = -pih + + where (grid2_center_lat > grid2_bound_box(2,:)) & + grid2_bound_box(2,:) = pih + + where (grid2_center_lat < grid2_bound_box(1,:)) & + grid2_bound_box(1,:) = -pih + +!----------------------------------------------------------------------- +! +! set up and assign address ranges to search bins in order to +! further restrict later searches +! +!----------------------------------------------------------------------- + + select case (restrict_type) + + case ('latitude') + write(stdout,*) 'Using latitude bins to restrict search.' + + allocate(bin_addr1(2,num_srch_bins)) + allocate(bin_addr2(2,num_srch_bins)) + allocate(bin_lats (2,num_srch_bins)) + allocate(bin_lons (2,num_srch_bins)) + + dlat = pi/num_srch_bins + + do n=1,num_srch_bins + bin_lats(1,n) = (n-1)*dlat - pih + bin_lats(2,n) = n*dlat - pih + bin_lons(1,n) = zero + bin_lons(2,n) = pi2 + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + end do + + do nele=1,grid1_size + do n=1,num_srch_bins + if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and. & + grid1_bound_box(2,nele) >= bin_lats(1,n)) then + bin_addr1(1,n) = min(nele,bin_addr1(1,n)) + bin_addr1(2,n) = max(nele,bin_addr1(2,n)) + endif + end do + end do + + do nele=1,grid2_size + do n=1,num_srch_bins + if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and. & + grid2_bound_box(2,nele) >= bin_lats(1,n)) then + bin_addr2(1,n) = min(nele,bin_addr2(1,n)) + bin_addr2(2,n) = max(nele,bin_addr2(2,n)) + endif + end do + end do + + case ('latlon') + write(stdout,*) 'Using lat/lon boxes to restrict search.' + + dlat = pi /num_srch_bins + dlon = pi2/num_srch_bins + + allocate(bin_addr1(2,num_srch_bins*num_srch_bins)) + allocate(bin_addr2(2,num_srch_bins*num_srch_bins)) + allocate(bin_lats (2,num_srch_bins*num_srch_bins)) + allocate(bin_lons (2,num_srch_bins*num_srch_bins)) + + n = 0 + do j=1,num_srch_bins + do i=1,num_srch_bins + n = n + 1 + + bin_lats(1,n) = (j-1)*dlat - pih + bin_lats(2,n) = j*dlat - pih + bin_lons(1,n) = (i-1)*dlon + bin_lons(2,n) = i*dlon + bin_addr1(1,n) = grid1_size + 1 + bin_addr1(2,n) = 0 + bin_addr2(1,n) = grid2_size + 1 + bin_addr2(2,n) = 0 + end do + end do + + num_srch_bins = num_srch_bins**2 + + do nele=1,grid1_size + do n=1,num_srch_bins + if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and. & + grid1_bound_box(2,nele) >= bin_lats(1,n) .and. & + grid1_bound_box(3,nele) <= bin_lons(2,n) .and. & + grid1_bound_box(4,nele) >= bin_lons(1,n)) then + bin_addr1(1,n) = min(nele,bin_addr1(1,n)) + bin_addr1(2,n) = max(nele,bin_addr1(2,n)) + endif + end do + end do + + do nele=1,grid2_size + do n=1,num_srch_bins + if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and. & + grid2_bound_box(2,nele) >= bin_lats(1,n) .and. & + grid2_bound_box(3,nele) <= bin_lons(2,n) .and. & + grid2_bound_box(4,nele) >= bin_lons(1,n)) then + bin_addr2(1,n) = min(nele,bin_addr2(1,n)) + bin_addr2(2,n) = max(nele,bin_addr2(2,n)) + endif + end do + end do + + case default + stop 'unknown search restriction method' + end select + +!----------------------------------------------------------------------- + + end subroutine grid_init + +!*********************************************************************** + + end module grids + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/iounits.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/iounits.f90 new file mode 100644 index 0000000000000000000000000000000000000000..27c71a62694ffde2f7e70bda8da6bbf9ebcc3715 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/iounits.f90 @@ -0,0 +1,154 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module is a dynamic I/O unit manager. It keeps track of +! which units are in use and reserves units for stdin, stdout, and +! stderr. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: iounits.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module iounits + +!----------------------------------------------------------------------- + + use kinds_mod ! defines data types + + implicit none + +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(99), save :: & + unit_free ! flags to determine whether unit is free for use + + integer (kind=int_kind), parameter :: & + stdin = 5, & ! reserves unit for standard input + stdout = 6, & ! reserves unit for standard output + stderr = 6 ! reserves unit for standard error + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine get_unit(iunit) + +!----------------------------------------------------------------------- +! +! This routine returns the next available I/O unit number. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(out) :: & + iunit ! next free I/O unit + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n + + logical (kind=log_kind), save :: first_call = .true. + +!----------------------------------------------------------------------- +! +! if this is the first call, reserve stdout, stdin and stderr +! +!----------------------------------------------------------------------- + + if (first_call) then + unit_free = .true. + unit_free(stdin) = .false. + unit_free(stdout) = .false. + unit_free(stderr) = .false. + first_call = .false. + endif + +!----------------------------------------------------------------------- +! +! search for next available unit +! +!----------------------------------------------------------------------- + + srch_unit: do n=1,99 + if (unit_free(n)) then + iunit = n + unit_free(n) = .false. + exit srch_unit + endif + end do srch_unit + +!----------------------------------------------------------------------- + + end subroutine get_unit + +!*********************************************************************** + + subroutine release_unit(iunit) + +!----------------------------------------------------------------------- +! +! This routine releases the specified unit and closes the file. +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + iunit ! I/O unit to release + +!----------------------------------------------------------------------- +! +! closes I/O unit and declares it free +! +!----------------------------------------------------------------------- + + unit_free(iunit) = .true. + close(iunit) + +!----------------------------------------------------------------------- + + end subroutine release_unit + +!*********************************************************************** + + end module iounits + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/kinds_mod.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/kinds_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5c7a1a46f67bc31aef811a9c93dbac787d604ab0 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/kinds_mod.f90 @@ -0,0 +1,53 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module defines the F90 kind parameter for common data types. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: kinds_mod.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module kinds_mod + +!----------------------------------------------------------------------- + + implicit none + save + +!----------------------------------------------------------------------- + + integer, parameter :: char_len = 80, & + int_kind = kind(1), & + log_kind = kind(.true.), & + real_kind = selected_real_kind(6), & + dbl_kind = selected_real_kind(13) + +!----------------------------------------------------------------------- + + end module kinds_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/netcdf_mod.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/netcdf_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fad58d1d2c4198d93d29ca9bfb1f30d4521cac61 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/netcdf_mod.f90 @@ -0,0 +1,84 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains the netCDF include file and a netcdf error +! handling routine. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: netcdf.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module netcdf_mod + +!----------------------------------------------------------------------- + + use kinds_mod + use constants + + implicit none + + include 'netcdf.inc' + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine netcdf_error_handler(istat, mess) + +!----------------------------------------------------------------------- +! +! This routine provides a simple interface to netCDF error message +! routine. +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + istat ! integer status returned by netCDF function call + character (len=*), intent(in), optional :: mess + +!----------------------------------------------------------------------- + + if (istat /= NF_NOERR) then + if (present(mess)) then + print *,'Error in netCDF: ',nf_strerror(istat), 'Message: ',mess + else + print *,'Error in netCDF: ',nf_strerror(istat) + endif + stop + endif + +!----------------------------------------------------------------------- + + end subroutine netcdf_error_handler + +!*********************************************************************** + + end module netcdf_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b8818e7d9370f841f15f254fd95edae511c0a3f9 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap.f90 @@ -0,0 +1,165 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this routine performs a remapping based on addresses and weights +! computed in a setup phase +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap.f,v 1.5 2000/04/19 21:56:25 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_mod + +!----------------------------------------------------------------------- +! +! this module contains the routines for performing the actual +! remappings +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + + implicit none + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap(dst_array, map_wts, dst_add, src_add, & + src_array, src_grad1, src_grad2, src_grad3) + +!----------------------------------------------------------------------- +! +! performs the remapping based on weights computed elsewhere +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input arrays +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(:), intent(in) :: & + dst_add, & ! destination address for each link + src_add ! source address for each link + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + map_wts ! remapping weights for each link + + real (kind=dbl_kind), dimension(:), intent(in) :: & + src_array ! array with source field to be remapped + + real (kind=dbl_kind), dimension(:), intent(in), optional :: & + src_grad1 & ! gradient arrays on source grid necessary for + , src_grad2 & ! higher-order remappings + , src_grad3 + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), dimension(:), intent(inout) :: & + dst_array ! array for remapped field on destination grid + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, iorder + +!----------------------------------------------------------------------- +! +! check the order of the interpolation +! +!----------------------------------------------------------------------- + + if (present(src_grad1)) then + iorder = 2 + else + iorder = 1 + endif + +!----------------------------------------------------------------------- +! +! first order remapping +! +!----------------------------------------------------------------------- + + dst_array = zero + + select case (iorder) + case(1) + + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + & + src_array(src_add(n))*map_wts(1,n) + end do + +!----------------------------------------------------------------------- +! +! second order remapping +! +!----------------------------------------------------------------------- + + case(2) + + if (size(map_wts,DIM=1) == 3) then + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + & + src_array(src_add(n))*map_wts(1,n) + & + src_grad1(src_add(n))*map_wts(2,n) + & + src_grad2(src_add(n))*map_wts(3,n) + end do + else if (size(map_wts,DIM=1) == 4) then + do n=1,size(dst_add) + dst_array(dst_add(n)) = dst_array(dst_add(n)) + & + src_array(src_add(n))*map_wts(1,n) + & + src_grad1(src_add(n))*map_wts(2,n) + & + src_grad2(src_add(n))*map_wts(3,n) + & + src_grad3(src_add(n))*map_wts(4,n) + end do + endif + + end select + +!----------------------------------------------------------------------- + + end subroutine remap + +!*********************************************************************** + + end module remap_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bicubic.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bicubic.f90 new file mode 100644 index 0000000000000000000000000000000000000000..89f710d6665f9b8b31dde4b4b53f72a85d0ed14d --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bicubic.f90 @@ -0,0 +1,844 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! bicubic interpolation. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_bicubic.f,v 1.5 2001/08/22 18:20:41 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_bicubic + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: & + max_iter = 100 ! max iteration count for i,j iteration + + real (kind=dbl_kind), parameter :: & + converge = 1.e-10_dbl_kind ! convergence criterion + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_bicub + +!----------------------------------------------------------------------- +! +! this routine computes the weights for a bicubic interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n,icount, & + dst_add, & ! destination address + iter, & ! iteration counter + nmap ! index of current map being computed + + integer (kind=int_kind), dimension(4) :: & + src_add ! address for the four source points + + real (kind=dbl_kind), dimension(4) :: & + src_lats, & ! latitudes of four bilinear corners + src_lons ! longitudes of four bilinear corners + + real (kind=dbl_kind), dimension(4,4) :: & + wgts ! bicubic weights for four corners + + real (kind=dbl_kind) :: & + plat, plon, & ! lat/lon coords of destination point + iguess, jguess, & ! current guess for bilinear coordinate + thguess, phguess, & ! current guess for lat/lon coordinate + deli, delj, & ! corrections to i,j + dth1, dth2, dth3, & ! some latitude differences + dph1, dph2, dph3, & ! some longitude differences + dthp, dphp, & ! difference between point and sw corner + mat1, mat2, mat3, mat4, & ! matrix elements + determinant, & ! matrix determinant + sum_wgts, & ! sum of weights for normalization + w1,w2,w3,w4,w5,w6,w7,w8, & ! 16 bicubic weight functions + w9,w10,w11,w12,w13,w14,w15,w16 + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + if (grid1_rank /= 2) then + stop 'Can not do bicubic interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + +!----------------------------------------------------------------------- +! +! find nearest square of grid points on source grid +! +!----------------------------------------------------------------------- + + call grid_search_bicub(src_add, src_lats, src_lons, & + plat, plon, grid1_dims, & + grid1_center_lat, grid1_center_lon, & + grid1_bound_box, bin_addr1, bin_addr2) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid1_mask(src_add(n))) src_add(1) = 0 + end do + endif + +!----------------------------------------------------------------------- +! +! if point found, find local i,j coordinates for weights +! +!----------------------------------------------------------------------- + + if (src_add(1) > 0) then + + grid2_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bicubic approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > three*pih) dph1 = dph1 - pi2 + if (dph2 > three*pih) dph2 = dph2 - pi2 + if (dph3 > three*pih) dph3 = dph3 - pi2 + if (dph1 < -three*pih) dph1 = dph1 + pi2 + if (dph2 < -three*pih) dph2 = dph2 + pi2 + if (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = half + jguess = half + + iter_loop1: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - & + dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > three*pih) dphp = dphp - pi2 + if (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. & + abs(delj) < converge) exit iter_loop1 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop1 + + if (iter <= max_iter) then + +!----------------------------------------------------------------------- +! +! successfully found i,j - compute weights +! +!----------------------------------------------------------------------- + + wgts(1,1) = (one - jguess**2*(three-two*jguess))* & + (one - iguess**2*(three-two*iguess)) + wgts(1,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(three-two*iguess) + wgts(1,3) = jguess**2*(three-two*jguess)* & + iguess**2*(three-two*iguess) + wgts(1,4) = jguess**2*(three-two*jguess)* & + (one - iguess**2*(three-two*iguess)) + wgts(2,1) = (one - jguess**2*(three-two*jguess))* & + iguess*(iguess-one)**2 + wgts(2,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(iguess-one) + wgts(2,3) = jguess**2*(three-two*jguess)* & + iguess**2*(iguess-one) + wgts(2,4) = jguess**2*(three-two*jguess)* & + iguess*(iguess-one)**2 + wgts(3,1) = jguess*(jguess-one)**2* & + (one - iguess**2*(three-two*iguess)) + wgts(3,2) = jguess*(jguess-one)**2* & + iguess**2*(three-two*iguess) + wgts(3,3) = jguess**2*(jguess-one)* & + iguess**2*(three-two*iguess) + wgts(3,4) = jguess**2*(jguess-one)* & + (one - iguess**2*(three-two*iguess)) + wgts(4,1) = iguess*(iguess-one)**2* & + jguess*(jguess-one)**2 + wgts(4,2) = iguess**2*(iguess-one)* & + jguess*(jguess-one)**2 + wgts(4,3) = iguess**2*(iguess-one)* & + jguess**2*(jguess-one) + wgts(4,4) = iguess*(iguess-one)**2* & + jguess**2*(jguess-one) + + call store_link_bicub(dst_add, src_add, wgts, nmap) + + else + stop 'Iteration for i,j exceed max iteration count' + endif + +!----------------------------------------------------------------------- +! +! search for bilinear failed - use a distance-weighted +! average instead (this is typically near the pole) +! +!----------------------------------------------------------------------- + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + + icount = 0 + do n=1,4 + if (grid1_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1,1) = src_lats(1)/sum_wgts + wgts(1,2) = src_lats(2)/sum_wgts + wgts(1,3) = src_lats(3)/sum_wgts + wgts(1,4) = src_lats(4)/sum_wgts + wgts(2:4,:) = zero + + grid2_frac(dst_add) = one + call store_link_bicub(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop1 + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + if (grid2_rank /= 2) then + stop 'Can not do bicubic interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + plat = grid1_center_lat(dst_add) + plon = grid1_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bicub(src_add, src_lats, src_lons, & + plat, plon, grid2_dims, & + grid2_center_lat, grid2_center_lon, & + grid2_bound_box, bin_addr2, bin_addr1) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid2_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid1_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > pi) dph1 = dph1 - pi2 + if (dph2 > pi) dph2 = dph2 - pi2 + if (dph3 > pi) dph3 = dph3 - pi2 + if (dph1 < -pi) dph1 = dph1 + pi2 + if (dph2 < -pi) dph2 = dph2 + pi2 + if (dph3 < -pi) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = zero + jguess = zero + + iter_loop2: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - & + dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > pi) dphp = dphp - pi2 + if (dphp < -pi) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. & + abs(delj) < converge) exit iter_loop2 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop2 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1,1) = (one - jguess**2*(three-two*jguess))* & + (one - iguess**2*(three-two*iguess)) + wgts(1,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(three-two*iguess) + wgts(1,3) = jguess**2*(three-two*jguess)* & + iguess**2*(three-two*iguess) + wgts(1,4) = jguess**2*(three-two*jguess)* & + (one - iguess**2*(three-two*iguess)) + wgts(2,1) = (one - jguess**2*(three-two*jguess))* & + iguess*(iguess-one)**2 + wgts(2,2) = (one - jguess**2*(three-two*jguess))* & + iguess**2*(iguess-one) + wgts(2,3) = jguess**2*(three-two*jguess)* & + iguess**2*(iguess-one) + wgts(2,4) = jguess**2*(three-two*jguess)* & + iguess*(iguess-one)**2 + wgts(3,1) = jguess*(jguess-one)**2* & + (one - iguess**2*(three-two*iguess)) + wgts(3,2) = jguess*(jguess-one)**2* & + iguess**2*(three-two*iguess) + wgts(3,3) = jguess**2*(jguess-one)* & + iguess**2*(three-two*iguess) + wgts(3,4) = jguess**2*(jguess-one)* & + (one - iguess**2*(three-two*iguess)) + wgts(4,1) = iguess*(iguess-one)**2* & + jguess*(jguess-one)**2 + wgts(4,2) = iguess**2*(iguess-one)* & + jguess*(jguess-one)**2 + wgts(4,3) = iguess**2*(iguess-one)* & + jguess**2*(jguess-one) + wgts(4,4) = iguess*(iguess-one)**2* & + jguess**2*(jguess-one) + + call store_link_bicub(dst_add, src_add, wgts, nmap) + + else + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - us a distance-weighted + !*** average instead + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + + icount = 0 + do n=1,4 + if (grid2_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1,1) = src_lats(1)/sum_wgts + wgts(1,2) = src_lats(2)/sum_wgts + wgts(1,3) = src_lats(3)/sum_wgts + wgts(1,4) = src_lats(4)/sum_wgts + wgts(2:4,:) = zero + + grid1_frac(dst_add) = one + call store_link_bicub(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop2 + + endif ! nmap=2 + +!----------------------------------------------------------------------- + + end subroutine remap_bicub + +!*********************************************************************** + + subroutine grid_search_bicub(src_add, src_lats, src_lons, & + plat, plon, src_grid_dims, & + src_center_lat, src_center_lon, & + src_bound_box, & + src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the location of the search point plat, plon +! in the source grid and returns the corners needed for a bicubic +! interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(4), intent(out) :: & + src_add ! address of each corner point enclosing P + + real (kind=dbl_kind), dimension(4), intent(out) :: & + src_lats, & ! latitudes of the four corner points + src_lons ! longitudes of the four corner points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: & + plat, & ! latitude of the search point + plon ! longitude of the search point + + integer (kind=int_kind), dimension(2), intent(in) :: & + src_grid_dims ! size of each src grid dimension + + real (kind=dbl_kind), dimension(:), intent(in) :: & + src_center_lat, & ! latitude of each src grid center + src_center_lon ! longitude of each src grid center + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + src_bound_box ! bounding box for src grid search + + integer (kind=int_kind), dimension(:,:), intent(in) :: & + src_bin_add, & ! search bins for restricting + dst_bin_add ! searches + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, srch_add, & ! dummy indices + nx, ny, & ! dimensions of src grid + min_add, max_add, & ! addresses for restricting search + i, j, jp1, ip1, n_add, e_add, ne_add ! addresses + + real (kind=dbl_kind) :: & ! vectors for cross-product check + vec1_lat, vec1_lon, & + vec2_lat, vec2_lon, cross_product, cross_product_last, & + coslat_dst, sinlat_dst, coslon_dst, sinlon_dst, & + dist_min, distance ! for computing dist-weighted avg + +!----------------------------------------------------------------------- +! +! restrict search first using search bins. +! +!----------------------------------------------------------------------- + + src_add = 0 + + min_add = size(src_center_lat) + max_add = 1 + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. & + plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then + min_add = min(min_add, src_bin_add(1,n)) + max_add = max(max_add, src_bin_add(2,n)) + endif + end do + +!----------------------------------------------------------------------- +! +! now perform a more detailed search +! +!----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + srch_loop: do srch_add = min_add,max_add + + if (plat <= src_bound_box(2,srch_add) .and. & + plat >= src_bound_box(1,srch_add) .and. & + plon <= src_bound_box(4,srch_add) .and. & + plon >= src_bound_box(3,srch_add)) then + + !*** + !*** we are within bounding box so get really serious + !*** + + !*** find N,S and NE points to this grid point + + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + ip1 = 1 + endif + + if (j < ny) then + jp1 = j+1 + else + jp1 = 1 + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + !*** + !*** find N,S and NE lat/lon coords and check bounding box + !*** + + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + + vec1_lon = src_lons(1) - plon + if (vec1_lon > pi) then + src_lons(1) = src_lons(1) - pi2 + else if (vec1_lon < -pi) then + src_lons(1) = src_lons(1) + pi2 + endif + do n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + if (vec1_lon > pi) then + src_lons(n) = src_lons(n) - pi2 + else if (vec1_lon < -pi) then + src_lons(n) = src_lons(n) + pi2 + endif + end do + + corner_loop: do n=1,4 + next_n = MOD(n,4) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** same sign, the point is contained in the box. + !*** + + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > three*pih) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -three*pih) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > three*pih) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -three*pih) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (n==1) cross_product_last = cross_product + if (cross_product*cross_product_last < zero) then + exit corner_loop + else + cross_product_last = cross_product + endif + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > 4) then + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + + return + endif + + !*** + !*** otherwise move on to next cell + !*** + + endif !bounding box check + end do srch_loop + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + + coslat_dst = cos(plat) + sinlat_dst = sin(plat) + coslon_dst = cos(plon) + sinlon_dst = sin(plon) + + dist_min = bignum + src_lats = bignum + do srch_add = min_add,max_add + distance = acos(coslat_dst*cos(src_center_lat(srch_add))* & + (coslon_dst*cos(src_center_lon(srch_add)) + & + sinlon_dst*sin(src_center_lon(srch_add)))+ & + sinlat_dst*sin(src_center_lat(srch_add))) + + if (distance < dist_min) then + sort_loop: do n=1,4 + if (distance < src_lats(n)) then + do i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + end do + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + exit sort_loop + endif + end do sort_loop + endif + end do + + src_lons = one/(src_lats + tiny) + distance = sum(src_lons) + src_lats = src_lons/distance + +!----------------------------------------------------------------------- + + end subroutine grid_search_bicub + +!*********************************************************************** + + subroutine store_link_bicub(dst_add, src_add, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for four links +! associated with one destination point in the appropriate address +! and weight arrays and resizes those arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + dst_add, & ! address on destination grid + nmap ! identifies which direction for mapping + + integer (kind=int_kind), dimension(4), intent(in) :: & + src_add ! addresses on source grid + + real (kind=dbl_kind), dimension(4,4), intent(in) :: & + weights ! array of remapping weights for these links + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, & ! dummy index + num_links_old ! placeholder for old link number + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + if (num_links_map1 > max_links_map1) & + call resize_remap_vars(1,resize_increment) + + do n=1,4 + grid1_add_map1(num_links_old+n) = src_add(n) + grid2_add_map1(num_links_old+n) = dst_add + wts_map1 (:,num_links_old+n) = weights(:,n) + end do + + case(2) + + num_links_old = num_links_map2 + num_links_map2 = num_links_old + 4 + + if (num_links_map2 > max_links_map2) & + call resize_remap_vars(2,resize_increment) + + do n=1,4 + grid1_add_map2(num_links_old+n) = dst_add + grid2_add_map2(num_links_old+n) = src_add(n) + wts_map2 (:,num_links_old+n) = weights(:,n) + end do + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_bicub + +!*********************************************************************** + + end module remap_bicubic + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bilinear.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bilinear.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99406788f6c4d6fc1ada98c7c60b66507eeaf3a2 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_bilinear.f90 @@ -0,0 +1,781 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! bilinear interpolation. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_bilinear.f,v 1.6 2001/08/22 18:20:40 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_bilinear + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: & + max_iter = 100 ! max iteration count for i,j iteration + + real (kind=dbl_kind), parameter :: & + converge = 1.e-10_dbl_kind ! convergence criterion + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_bilin + +!----------------------------------------------------------------------- +! +! this routine computes the weights for a bilinear interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n,icount, & + dst_add, & ! destination address + iter, & ! iteration counter + nmap ! index of current map being computed + + integer (kind=int_kind), dimension(4) :: & + src_add ! address for the four source points + + real (kind=dbl_kind), dimension(4) :: & + src_lats, & ! latitudes of four bilinear corners + src_lons, & ! longitudes of four bilinear corners + wgts ! bilinear weights for four corners + + real (kind=dbl_kind) :: & + plat, plon, & ! lat/lon coords of destination point + iguess, jguess, & ! current guess for bilinear coordinate + thguess, phguess, & ! current guess for lat/lon coordinate + deli, delj, & ! corrections to i,j + dth1, dth2, dth3, & ! some latitude differences + dph1, dph2, dph3, & ! some longitude differences + dthp, dphp, & ! difference between point and sw corner + mat1, mat2, mat3, mat4, & ! matrix elements + determinant, & ! matrix determinant + sum_wgts ! sum of weights for normalization + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + if (grid1_rank /= 2) then + stop 'Can not do bilinear interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + plat = grid2_center_lat(dst_add) + plon = grid2_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bilin(src_add, src_lats, src_lons, & + plat, plon, grid1_dims, & + grid1_center_lat, grid1_center_lon, & + grid1_bound_box, bin_addr1, bin_addr2) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid1_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find local i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid2_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > three*pih) dph1 = dph1 - pi2 + if (dph2 > three*pih) dph2 = dph2 - pi2 + if (dph3 > three*pih) dph3 = dph3 - pi2 + if (dph1 < -three*pih) dph1 = dph1 + pi2 + if (dph2 < -three*pih) dph2 = dph2 + pi2 + if (dph3 < -three*pih) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = half + jguess = half + + iter_loop1: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - & + dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > three*pih) dphp = dphp - pi2 + if (dphp < -three*pih) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. & + abs(delj) < converge) exit iter_loop1 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop1 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1) = (one-iguess)*(one-jguess) + wgts(2) = iguess*(one-jguess) + wgts(3) = iguess*jguess + wgts(4) = (one-iguess)*jguess + + call store_link_bilin(dst_add, src_add, wgts, nmap) + + else + print *,'Point coords: ',plat,plon + print *,'Dest grid lats: ',src_lats + print *,'Dest grid lons: ',src_lons + print *,'Dest grid addresses: ',src_add + print *,'Current i,j : ',iguess, jguess + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - use a distance-weighted + !*** average instead (this is typically near the pole) + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + icount = 0 + do n=1,4 + if (grid1_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1) = src_lats(1)/sum_wgts + wgts(2) = src_lats(2)/sum_wgts + wgts(3) = src_lats(3)/sum_wgts + wgts(4) = src_lats(4)/sum_wgts + + grid2_frac(dst_add) = one + call store_link_bilin(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop1 + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + if (grid2_rank /= 2) then + stop 'Can not do bilinear interpolation when grid_rank /= 2' + endif + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + plat = grid1_center_lat(dst_add) + plon = grid1_center_lon(dst_add) + + !*** + !*** find nearest square of grid points on source grid + !*** + + call grid_search_bilin(src_add, src_lats, src_lons, & + plat, plon, grid2_dims, & + grid2_center_lat, grid2_center_lon, & + grid2_bound_box, bin_addr2, bin_addr1) + + !*** + !*** check to see if points are land points + !*** + + if (src_add(1) > 0) then + do n=1,4 + if (.not. grid2_mask(src_add(n))) src_add(1) = 0 + end do + endif + + !*** + !*** if point found, find i,j coordinates for weights + !*** + + if (src_add(1) > 0) then + + grid1_frac(dst_add) = one + + !*** + !*** iterate to find i,j for bilinear approximation + !*** + + dth1 = src_lats(2) - src_lats(1) + dth2 = src_lats(4) - src_lats(1) + dth3 = src_lats(3) - src_lats(2) - dth2 + + dph1 = src_lons(2) - src_lons(1) + dph2 = src_lons(4) - src_lons(1) + dph3 = src_lons(3) - src_lons(2) + + if (dph1 > pi) dph1 = dph1 - pi2 + if (dph2 > pi) dph2 = dph2 - pi2 + if (dph3 > pi) dph3 = dph3 - pi2 + if (dph1 < -pi) dph1 = dph1 + pi2 + if (dph2 < -pi) dph2 = dph2 + pi2 + if (dph3 < -pi) dph3 = dph3 + pi2 + + dph3 = dph3 - dph2 + + iguess = zero + jguess = zero + + iter_loop2: do iter=1,max_iter + + dthp = plat - src_lats(1) - dth1*iguess - & + dth2*jguess - dth3*iguess*jguess + dphp = plon - src_lons(1) + + if (dphp > pi) dphp = dphp - pi2 + if (dphp < -pi) dphp = dphp + pi2 + + dphp = dphp - dph1*iguess - dph2*jguess - & + dph3*iguess*jguess + + mat1 = dth1 + dth3*jguess + mat2 = dth2 + dth3*iguess + mat3 = dph1 + dph3*jguess + mat4 = dph2 + dph3*iguess + + determinant = mat1*mat4 - mat2*mat3 + + deli = (dthp*mat4 - mat2*dphp)/determinant + delj = (mat1*dphp - dthp*mat3)/determinant + + if (abs(deli) < converge .and. & + abs(delj) < converge) exit iter_loop2 + + iguess = iguess + deli + jguess = jguess + delj + + end do iter_loop2 + + if (iter <= max_iter) then + + !*** + !*** successfully found i,j - compute weights + !*** + + wgts(1) = (one-iguess)*(one-jguess) + wgts(2) = iguess*(one-jguess) + wgts(3) = iguess*jguess + wgts(4) = (one-iguess)*jguess + + call store_link_bilin(dst_add, src_add, wgts, nmap) + + else + print *,'Point coords: ',plat,plon + print *,'Dest grid lats: ',src_lats + print *,'Dest grid lons: ',src_lons + print *,'Dest grid addresses: ',src_add + print *,'Current i,j : ',iguess, jguess + stop 'Iteration for i,j exceed max iteration count' + endif + + !*** + !*** search for bilinear failed - us a distance-weighted + !*** average instead + !*** + + else if (src_add(1) < 0) then + + src_add = abs(src_add) + icount = 0 + do n=1,4 + if (grid2_mask(src_add(n))) then + icount = icount + 1 + else + src_lats(n) = zero + endif + end do + + if (icount > 0) then + !*** renormalize weights + + sum_wgts = sum(src_lats) + wgts(1) = src_lats(1)/sum_wgts + wgts(2) = src_lats(2)/sum_wgts + wgts(3) = src_lats(3)/sum_wgts + wgts(4) = src_lats(4)/sum_wgts + + grid1_frac(dst_add) = one + call store_link_bilin(dst_add, src_add, wgts, nmap) + endif + + endif + end do grid_loop2 + + endif ! nmap=2 + +!----------------------------------------------------------------------- + + end subroutine remap_bilin + +!*********************************************************************** + + subroutine grid_search_bilin(src_add, src_lats, src_lons, & + plat, plon, src_grid_dims, & + src_center_lat, src_center_lon, & + src_grid_bound_box, & + src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the location of the search point plat, plon +! in the source grid and returns the corners needed for a bilinear +! interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(4), intent(out) :: & + src_add ! address of each corner point enclosing P + + real (kind=dbl_kind), dimension(4), intent(out) :: & + src_lats, & ! latitudes of the four corner points + src_lons ! longitudes of the four corner points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: & + plat, & ! latitude of the search point + plon ! longitude of the search point + + integer (kind=int_kind), dimension(2), intent(in) :: & + src_grid_dims ! size of each src grid dimension + + real (kind=dbl_kind), dimension(:), intent(in) :: & + src_center_lat, & ! latitude of each src grid center + src_center_lon ! longitude of each src grid center + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + src_grid_bound_box ! bound box for source grid + + integer (kind=int_kind), dimension(:,:), intent(in) :: & + src_bin_add, & ! latitude bins for restricting + dst_bin_add ! searches + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, srch_add, & ! dummy indices + nx, ny, & ! dimensions of src grid + min_add, max_add, & ! addresses for restricting search + i, j, jp1, ip1, n_add, e_add, ne_add ! addresses + + real (kind=dbl_kind) :: & ! vectors for cross-product check + vec1_lat, vec1_lon, & + vec2_lat, vec2_lon, cross_product, cross_product_last, & + coslat_dst, sinlat_dst, coslon_dst, sinlon_dst, & + dist_min, distance ! for computing dist-weighted avg + +!----------------------------------------------------------------------- +! +! restrict search first using bins +! +!----------------------------------------------------------------------- + + src_add = 0 + + min_add = size(src_center_lat) + max_add = 1 + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. & + plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then + min_add = min(min_add, src_bin_add(1,n)) + max_add = max(max_add, src_bin_add(2,n)) + endif + end do + +!----------------------------------------------------------------------- +! +! now perform a more detailed search +! +!----------------------------------------------------------------------- + + nx = src_grid_dims(1) + ny = src_grid_dims(2) + + srch_loop: do srch_add = min_add,max_add + + !*** first check bounding box + + if (plat <= src_grid_bound_box(2,srch_add) .and. & + plat >= src_grid_bound_box(1,srch_add) .and. & + plon <= src_grid_bound_box(4,srch_add) .and. & + plon >= src_grid_bound_box(3,srch_add)) then + + !*** + !*** we are within bounding box so get really serious + !*** + + !*** determine neighbor addresses + + j = (srch_add - 1)/nx +1 + i = srch_add - (j-1)*nx + + if (i < nx) then + ip1 = i + 1 + else + ip1 = 1 + endif + + if (j < ny) then + jp1 = j+1 + else + jp1 = 1 + endif + + n_add = (jp1 - 1)*nx + i + e_add = (j - 1)*nx + ip1 + ne_add = (jp1 - 1)*nx + ip1 + + src_lats(1) = src_center_lat(srch_add) + src_lats(2) = src_center_lat(e_add) + src_lats(3) = src_center_lat(ne_add) + src_lats(4) = src_center_lat(n_add) + + src_lons(1) = src_center_lon(srch_add) + src_lons(2) = src_center_lon(e_add) + src_lons(3) = src_center_lon(ne_add) + src_lons(4) = src_center_lon(n_add) + + !*** + !*** for consistency, we must make sure all lons are in + !*** same 2pi interval + !*** + + vec1_lon = src_lons(1) - plon + if (vec1_lon > pi) then + src_lons(1) = src_lons(1) - pi2 + else if (vec1_lon < -pi) then + src_lons(1) = src_lons(1) + pi2 + endif + do n=2,4 + vec1_lon = src_lons(n) - src_lons(1) + if (vec1_lon > pi) then + src_lons(n) = src_lons(n) - pi2 + else if (vec1_lon < -pi) then + src_lons(n) = src_lons(n) + pi2 + endif + end do + + corner_loop: do n=1,4 + next_n = MOD(n,4) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each box side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the box. + !*** + + vec1_lat = src_lats(next_n) - src_lats(n) + vec1_lon = src_lons(next_n) - src_lons(n) + vec2_lat = plat - src_lats(n) + vec2_lon = plon - src_lons(n) + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > three*pih) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -three*pih) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > three*pih) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -three*pih) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (n == 1) cross_product_last = cross_product + if (cross_product*cross_product_last < zero) & + exit corner_loop + cross_product_last = cross_product + + end do corner_loop + + !*** + !*** if cross products all same sign, we found the location + !*** + + if (n > 4) then + src_add(1) = srch_add + src_add(2) = e_add + src_add(3) = ne_add + src_add(4) = n_add + + return + endif + + !*** + !*** otherwise move on to next cell + !*** + + endif !bounding box check + end do srch_loop + + !*** + !*** if no cell found, point is likely either in a box that + !*** straddles either pole or is outside the grid. fall back + !*** to a distance-weighted average of the four closest + !*** points. go ahead and compute weights here, but store + !*** in src_lats and return -add to prevent the parent + !*** routine from computing bilinear weights + !*** + + !print *,'Could not find location for ',plat,plon + !print *,'Using nearest-neighbor average for this point' + + coslat_dst = cos(plat) + sinlat_dst = sin(plat) + coslon_dst = cos(plon) + sinlon_dst = sin(plon) + + dist_min = bignum + src_lats = bignum + do srch_add = min_add,max_add + distance = acos(coslat_dst*cos(src_center_lat(srch_add))* & + (coslon_dst*cos(src_center_lon(srch_add)) + & + sinlon_dst*sin(src_center_lon(srch_add)))+ & + sinlat_dst*sin(src_center_lat(srch_add))) + + if (distance < dist_min) then + sort_loop: do n=1,4 + if (distance < src_lats(n)) then + do i=4,n+1,-1 + src_add (i) = src_add (i-1) + src_lats(i) = src_lats(i-1) + end do + src_add (n) = -srch_add + src_lats(n) = distance + dist_min = src_lats(4) + exit sort_loop + endif + end do sort_loop + endif + end do + + src_lons = one/(src_lats + tiny) + distance = sum(src_lons) + src_lats = src_lons/distance + +!----------------------------------------------------------------------- + + end subroutine grid_search_bilin + +!*********************************************************************** + + subroutine store_link_bilin(dst_add, src_add, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for four links +! associated with one destination point in the appropriate address +! and weight arrays and resizes those arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + dst_add, & ! address on destination grid + nmap ! identifies which direction for mapping + + integer (kind=int_kind), dimension(4), intent(in) :: & + src_add ! addresses on source grid + + real (kind=dbl_kind), dimension(4), intent(in) :: & + weights ! array of remapping weights for these links + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, & ! dummy index + num_links_old ! placeholder for old link number + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_old = num_links_map1 + num_links_map1 = num_links_old + 4 + + if (num_links_map1 > max_links_map1) & + call resize_remap_vars(1,resize_increment) + + do n=1,4 + grid1_add_map1(num_links_old+n) = src_add(n) + grid2_add_map1(num_links_old+n) = dst_add + wts_map1 (1,num_links_old+n) = weights(n) + end do + + case(2) + + num_links_old = num_links_map2 + num_links_map2 = num_links_old + 4 + + if (num_links_map2 > max_links_map2) & + call resize_remap_vars(2,resize_increment) + + do n=1,4 + grid1_add_map2(num_links_old+n) = dst_add + grid2_add_map2(num_links_old+n) = src_add(n) + wts_map2 (1,num_links_old+n) = weights(n) + end do + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_bilin + +!*********************************************************************** + + end module remap_bilinear + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_conserv.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_conserv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..765dbd59c5cc2200efa08bd7d3e31cf87ef8cc90 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_conserv.f90 @@ -0,0 +1,2197 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for computing addresses +! and weights for a conservative interpolation between any two +! grids on a sphere. the weights are computed by performing line +! integrals around all overlap regions of the two grids. see +! Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and +! Jones, P.W. Monthly Weather Review (submitted). +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_conserv.f,v 1.10 2001/08/21 21:05:13 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_conservative + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use timers ! module for timing + use grids ! module containing grid information + use remap_vars ! module containing remap information + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), save :: & + num_srch_cells ! num cells in restricted search arrays + + integer (kind=int_kind), dimension(:), allocatable, save :: & + srch_add ! global address of cells in srch arrays + + real (kind=dbl_kind), parameter :: & + north_thresh = 1.45_dbl_kind, & ! threshold for coord transf. + south_thresh =-2.00_dbl_kind ! threshold for coord transf. + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: & + srch_corner_lat, & ! lat of each corner of srch cells + srch_corner_lon ! lon of each corner of srch cells + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_conserv + +!----------------------------------------------------------------------- +! +! this routine traces the perimeters of every grid cell on each +! grid checking for intersections with the other grid and computing +! line integrals for each subsegment. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: & + max_subseg = 10000 ! max number of subsegments per segment + ! to prevent infinite loop + + integer (kind=int_kind) :: & + grid1_add, & ! current linear address for grid1 cell + grid2_add, & ! current linear address for grid2 cell + min_add, & ! addresses for restricting search of + max_add, & ! destination grid + n, nwgt, & ! generic counters + corner, & ! corner of cell that segment starts from + next_corn, & ! corner of cell that segment ends on + num_subseg ! number of subsegments + + logical (kind=log_kind) :: & + lcoinc, & ! flag for coincident segments + lrevers, & ! flag for reversing direction of segment + lbegin ! flag for first integration of a segment + + logical (kind=log_kind), dimension(:), allocatable :: & + srch_mask ! mask for restricting searches + + real (kind=dbl_kind) :: & + intrsct_lat, intrsct_lon, & ! lat/lon of next intersect + beglat, endlat, beglon, endlon, & ! endpoints of current seg. + norm_factor ! factor for normalizing wts + + real (kind=dbl_kind), dimension(:), allocatable :: & + grid2_centroid_lat, grid2_centroid_lon, & ! centroid coords + grid1_centroid_lat, grid1_centroid_lon ! on each grid + + real (kind=dbl_kind), dimension(2) :: begseg ! begin lat/lon for + ! full segment + + real (kind=dbl_kind), dimension(6) :: weights ! local wgt array + +!----------------------------------------------------------------------- +! +! initialize centroid arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_centroid_lat(grid1_size), & + grid1_centroid_lon(grid1_size), & + grid2_centroid_lat(grid2_size), & + grid2_centroid_lon(grid2_size)) + + grid1_centroid_lat = zero + grid1_centroid_lon = zero + grid2_centroid_lat = zero + grid2_centroid_lon = zero + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid1 +! +!----------------------------------------------------------------------- + + allocate(srch_mask(grid2_size)) + + print *,'grid1 sweep ' + do grid1_add = 1,grid1_size + + !*** + !*** restrict searches first using search bins + !*** + + call timer_start(1) + min_add = grid2_size + max_add = 1 + do n=1,num_srch_bins + if (grid1_add >= bin_addr1(1,n) .and. & + grid1_add <= bin_addr1(2,n)) then + min_add = min(min_add, bin_addr2(1,n)) + max_add = max(max_add, bin_addr2(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells = 0 + do grid2_add = min_add,max_add + srch_mask(grid2_add) = (grid2_bound_box(1,grid2_add) <= & + grid1_bound_box(2,grid1_add)) .and. & + (grid2_bound_box(2,grid2_add) >= & + grid1_bound_box(1,grid1_add)) .and. & + (grid2_bound_box(3,grid2_add) <= & + grid1_bound_box(4,grid1_add)) .and. & + (grid2_bound_box(4,grid2_add) >= & + grid1_bound_box(3,grid1_add)) + + if (srch_mask(grid2_add)) num_srch_cells = num_srch_cells+1 + end do + + !*** + !*** create search arrays + !*** + + allocate(srch_add(num_srch_cells), & + srch_corner_lat(grid2_corners,num_srch_cells), & + srch_corner_lon(grid2_corners,num_srch_cells)) + + n = 0 + gather1: do grid2_add = min_add,max_add + if (srch_mask(grid2_add)) then + n = n+1 + srch_add(n) = grid2_add + srch_corner_lat(:,n) = grid2_corner_lat(:,grid2_add) + srch_corner_lon(:,n) = grid2_corner_lon(:,grid2_add) + endif + end do gather1 + call timer_stop(1) + + !*** + !*** integrate around this cell + !*** + + do corner = 1,grid1_corners + next_corn = mod(corner,grid1_corners) + 1 + + !*** + !*** define endpoints of the current segment + !*** + + beglat = grid1_corner_lat(corner,grid1_add) + beglon = grid1_corner_lon(corner,grid1_add) + endlat = grid1_corner_lat(next_corn,grid1_add) + endlon = grid1_corner_lon(next_corn,grid1_add) + lrevers = .false. + + !*** + !*** to ensure exact path taken during both + !*** sweeps, always integrate segments in the same + !*** direction (SW to NE). + !*** + + if ((endlat < beglat) .or. & + (endlat == beglat .and. endlon < beglon)) then + beglat = grid1_corner_lat(next_corn,grid1_add) + beglon = grid1_corner_lon(next_corn,grid1_add) + endlat = grid1_corner_lat(corner,grid1_add) + endlon = grid1_corner_lon(corner,grid1_add) + lrevers = .true. + endif + + begseg(1) = beglat + begseg(2) = beglon + lbegin = .true. + num_subseg = 0 + + !*** + !*** if this is a constant-longitude segment, skip the rest + !*** since the line integral contribution will be zero. + !*** + + if (endlon /= beglon) then + + !*** + !*** integrate along this segment, detecting intersections + !*** and computing the line integral for each sub-segment + !*** + + do while (beglat /= endlat .or. beglon /= endlon) + + !*** + !*** prevent infinite loops if integration gets stuck + !*** near cell or threshold boundary + !*** + + num_subseg = num_subseg + 1 + if (num_subseg > max_subseg) then + stop 'integration stalled: num_subseg exceeded limit' + endif + + !*** + !*** find next intersection of this segment with a grid + !*** line on grid 2. + !*** + + call timer_start(2) + call intersection(grid2_add,intrsct_lat,intrsct_lon,lcoinc, & + beglat, beglon, endlat, endlon, begseg, & + lbegin, lrevers) + call timer_stop(2) + lbegin = .false. + + !*** + !*** compute line integral for this subsegment. + !*** + + call timer_start(3) + if (grid2_add /= 0) then + call line_integral(weights, num_wts, & + beglon, intrsct_lon, beglat, intrsct_lat, & + grid1_center_lat(grid1_add), & + grid1_center_lon(grid1_add), & + grid2_center_lat(grid2_add), & + grid2_center_lon(grid2_add)) + else + call line_integral(weights, num_wts, & + beglon, intrsct_lon, beglat, intrsct_lat, & + grid1_center_lat(grid1_add), & + grid1_center_lon(grid1_add), & + grid1_center_lat(grid1_add), & + grid1_center_lon(grid1_add)) + endif + call timer_stop(3) + + !*** + !*** if integrating in reverse order, change + !*** sign of weights + !*** + + if (lrevers) then + weights = -weights + endif + + !*** + !*** store the appropriate addresses and weights. + !*** also add contributions to cell areas and centroids. + !*** + + !if (grid1_add == 119247) then + ! print *,grid1_add,grid2_add,corner,weights(1) + ! print *,grid1_corner_lat(:,grid1_add) + ! print *,grid1_corner_lon(:,grid1_add) + ! print *,grid2_corner_lat(:,grid2_add) + ! print *,grid2_corner_lon(:,grid2_add) + ! print *,beglat,beglon,intrsct_lat,intrsct_lon + !endif + + if (grid2_add /= 0) then + if (grid1_mask(grid1_add)) then + call timer_start(4) + call store_link_cnsrv(grid1_add, grid2_add, weights) + call timer_stop(4) + grid1_frac(grid1_add) = grid1_frac(grid1_add) + & + weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + & + weights(num_wts+1) + endif + + endif + + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = & + grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = & + grid1_centroid_lon(grid1_add) + weights(3) + + !*** + !*** reset beglat and beglon for next subsegment. + !*** + + beglat = intrsct_lat + beglon = intrsct_lon + end do + + endif + + !*** + !*** end of segment + !*** + + end do + + !*** + !*** finished with this cell: deallocate search array and + !*** start on next cell + + deallocate(srch_add, srch_corner_lat, srch_corner_lon) + + end do + + deallocate(srch_mask) + +!----------------------------------------------------------------------- +! +! integrate around each cell on grid2 +! +!----------------------------------------------------------------------- + + allocate(srch_mask(grid1_size)) + + print *,'grid2 sweep ' + do grid2_add = 1,grid2_size + + !*** + !*** restrict searches first using search bins + !*** + + call timer_start(5) + min_add = grid1_size + max_add = 1 + do n=1,num_srch_bins + if (grid2_add >= bin_addr2(1,n) .and. & + grid2_add <= bin_addr2(2,n)) then + min_add = min(min_add, bin_addr1(1,n)) + max_add = max(max_add, bin_addr1(2,n)) + endif + end do + + !*** + !*** further restrict searches using bounding boxes + !*** + + num_srch_cells = 0 + do grid1_add = min_add, max_add + srch_mask(grid1_add) = (grid1_bound_box(1,grid1_add) <= & + grid2_bound_box(2,grid2_add)) .and. & + (grid1_bound_box(2,grid1_add) >= & + grid2_bound_box(1,grid2_add)) .and. & + (grid1_bound_box(3,grid1_add) <= & + grid2_bound_box(4,grid2_add)) .and. & + (grid1_bound_box(4,grid1_add) >= & + grid2_bound_box(3,grid2_add)) + + if (srch_mask(grid1_add)) num_srch_cells = num_srch_cells+1 + end do + + allocate(srch_add(num_srch_cells), & + srch_corner_lat(grid1_corners,num_srch_cells), & + srch_corner_lon(grid1_corners,num_srch_cells)) + + n = 0 + gather2: do grid1_add = min_add,max_add + if (srch_mask(grid1_add)) then + n = n+1 + srch_add(n) = grid1_add + srch_corner_lat(:,n) = grid1_corner_lat(:,grid1_add) + srch_corner_lon(:,n) = grid1_corner_lon(:,grid1_add) + endif + end do gather2 + call timer_stop(5) + + !*** + !*** integrate around this cell + !*** + + do corner = 1,grid2_corners + next_corn = mod(corner,grid2_corners) + 1 + + beglat = grid2_corner_lat(corner,grid2_add) + beglon = grid2_corner_lon(corner,grid2_add) + endlat = grid2_corner_lat(next_corn,grid2_add) + endlon = grid2_corner_lon(next_corn,grid2_add) + lrevers = .false. + + !*** + !*** to ensure exact path taken during both + !*** sweeps, always integrate in the same direction + !*** + + if ((endlat < beglat) .or. & + (endlat == beglat .and. endlon < beglon)) then + beglat = grid2_corner_lat(next_corn,grid2_add) + beglon = grid2_corner_lon(next_corn,grid2_add) + endlat = grid2_corner_lat(corner,grid2_add) + endlon = grid2_corner_lon(corner,grid2_add) + lrevers = .true. + endif + + begseg(1) = beglat + begseg(2) = beglon + lbegin = .true. + + !*** + !*** if this is a constant-longitude segment, skip the rest + !*** since the line integral contribution will be zero. + !*** + + if (endlon /= beglon) then + num_subseg = 0 + + !*** + !*** integrate along this segment, detecting intersections + !*** and computing the line integral for each sub-segment + !*** + + do while (beglat /= endlat .or. beglon /= endlon) + + !*** + !*** prevent infinite loops if integration gets stuck + !*** near cell or threshold boundary + !*** + + num_subseg = num_subseg + 1 + if (num_subseg > max_subseg) then + stop 'integration stalled: num_subseg exceeded limit' + endif + + !*** + !*** find next intersection of this segment with a line + !*** on grid 2. + !*** + + call timer_start(6) + call intersection(grid1_add,intrsct_lat,intrsct_lon,lcoinc, & + beglat, beglon, endlat, endlon, begseg, & + lbegin, lrevers) + call timer_stop(6) + lbegin = .false. + + !*** + !*** compute line integral for this subsegment. + !*** + + call timer_start(7) + if (grid1_add /= 0) then + call line_integral(weights, num_wts, & + beglon, intrsct_lon, beglat, intrsct_lat, & + grid1_center_lat(grid1_add), & + grid1_center_lon(grid1_add), & + grid2_center_lat(grid2_add), & + grid2_center_lon(grid2_add)) + else + call line_integral(weights, num_wts, & + beglon, intrsct_lon, beglat, intrsct_lat, & + grid2_center_lat(grid2_add), & + grid2_center_lon(grid2_add), & + grid2_center_lat(grid2_add), & + grid2_center_lon(grid2_add)) + endif + call timer_stop(7) + + if (lrevers) then + weights = -weights + endif + + !*** + !*** store the appropriate addresses and weights. + !*** also add contributions to cell areas and centroids. + !*** if there is a coincidence, do not store weights + !*** because they have been captured in the previous loop. + !*** the grid1 mask is the master mask + !*** + + !if (grid1_add == 119247) then + ! print *,grid1_add,grid2_add,corner,weights(1) + ! print *,grid1_corner_lat(:,grid1_add) + ! print *,grid1_corner_lon(:,grid1_add) + ! print *,grid2_corner_lat(:,grid2_add) + ! print *,grid2_corner_lon(:,grid2_add) + ! print *,beglat,beglon,intrsct_lat,intrsct_lon + !endif + + if (.not. lcoinc .and. grid1_add /= 0) then + if (grid1_mask(grid1_add)) then + call timer_start(8) + call store_link_cnsrv(grid1_add, grid2_add, weights) + call timer_stop(8) + grid1_frac(grid1_add) = grid1_frac(grid1_add) + & + weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + & + weights(num_wts+1) + endif + + endif + + grid2_area(grid2_add) = grid2_area(grid2_add) + & + weights(num_wts+1) + grid2_centroid_lat(grid2_add) = & + grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = & + grid2_centroid_lon(grid2_add) + weights(num_wts+3) + + !*** + !*** reset beglat and beglon for next subsegment. + !*** + + beglat = intrsct_lat + beglon = intrsct_lon + end do + + endif + + !*** + !*** end of segment + !*** + + end do + + !*** + !*** finished with this cell: deallocate search array and + !*** start on next cell + + deallocate(srch_add, srch_corner_lat, srch_corner_lon) + + end do + + deallocate(srch_mask) + +!----------------------------------------------------------------------- +! +! correct for situations where N/S pole not explicitly included in +! grid (i.e. as a grid corner point). if pole is missing from only +! one grid, need to correct only the area and centroid of that +! grid. if missing from both, do complete weight calculation. +! +!----------------------------------------------------------------------- + + !*** North Pole + weights(1) = pi2 + weights(2) = pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = pi*pi + weights(6) = zero + + grid1_add = 0 + pole_loop1: do n=1,grid1_size + if (grid1_area(n) < -three*pih .and. & + grid1_center_lat(n) > zero) then + grid1_add = n + exit pole_loop1 + endif + end do pole_loop1 + + grid2_add = 0 + pole_loop2: do n=1,grid2_size + if (grid2_area(n) < -three*pih .and. & + grid2_center_lat(n) > zero) then + grid2_add = n + exit pole_loop2 + endif + end do pole_loop2 + + if (grid1_add /=0) then + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = & + grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = & + grid1_centroid_lon(grid1_add) + weights(3) + endif + + if (grid2_add /=0) then + grid2_area(grid2_add) = grid2_area(grid2_add) + & + weights(num_wts+1) + grid2_centroid_lat(grid2_add) = & + grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = & + grid2_centroid_lon(grid2_add) + weights(num_wts+3) + endif + + if (grid1_add /= 0 .and. grid2_add /=0) then + call store_link_cnsrv(grid1_add, grid2_add, weights) + + grid1_frac(grid1_add) = grid1_frac(grid1_add) + & + weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + & + weights(num_wts+1) + endif + + !*** South Pole + weights(1) = pi2 + weights(2) = -pi*pi + weights(3) = zero + weights(4) = pi2 + weights(5) = -pi*pi + weights(6) = zero + + grid1_add = 0 + pole_loop3: do n=1,grid1_size + if (grid1_area(n) < -three*pih .and. & + grid1_center_lat(n) < zero) then + grid1_add = n + exit pole_loop3 + endif + end do pole_loop3 + + grid2_add = 0 + pole_loop4: do n=1,grid2_size + if (grid2_area(n) < -three*pih .and. & + grid2_center_lat(n) < zero) then + grid2_add = n + exit pole_loop4 + endif + end do pole_loop4 + + if (grid1_add /=0) then + grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1) + grid1_centroid_lat(grid1_add) = & + grid1_centroid_lat(grid1_add) + weights(2) + grid1_centroid_lon(grid1_add) = & + grid1_centroid_lon(grid1_add) + weights(3) + endif + + if (grid2_add /=0) then + grid2_area(grid2_add) = grid2_area(grid2_add) + & + weights(num_wts+1) + grid2_centroid_lat(grid2_add) = & + grid2_centroid_lat(grid2_add) + weights(num_wts+2) + grid2_centroid_lon(grid2_add) = & + grid2_centroid_lon(grid2_add) + weights(num_wts+3) + endif + + if (grid1_add /= 0 .and. grid2_add /=0) then + call store_link_cnsrv(grid1_add, grid2_add, weights) + + grid1_frac(grid1_add) = grid1_frac(grid1_add) + & + weights(1) + grid2_frac(grid2_add) = grid2_frac(grid2_add) + & + weights(num_wts+1) + endif + +!----------------------------------------------------------------------- +! +! finish centroid computation +! +!----------------------------------------------------------------------- + + where (grid1_area /= zero) + grid1_centroid_lat = grid1_centroid_lat/grid1_area + grid1_centroid_lon = grid1_centroid_lon/grid1_area + end where + + where (grid2_area /= zero) + grid2_centroid_lat = grid2_centroid_lat/grid2_area + grid2_centroid_lon = grid2_centroid_lon/grid2_area + end where + +!----------------------------------------------------------------------- +! +! include centroids in weights and normalize using destination +! area if requested +! +!----------------------------------------------------------------------- + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + do nwgt=1,num_wts + weights( nwgt) = wts_map1(nwgt,n) + if (num_maps > 1) then + weights(num_wts+nwgt) = wts_map2(nwgt,n) + endif + end do + + select case(norm_opt) + case (norm_opt_dstarea) + if (grid2_area(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = one/grid2_area_in(grid2_add) + else + norm_factor = one/grid2_area(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid2_frac(grid2_add) /= zero) then + if (luse_grid2_area) then + norm_factor = grid2_area(grid2_add)/ & + (grid2_frac(grid2_add)* & + grid2_area_in(grid2_add)) + else + norm_factor = one/grid2_frac(grid2_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map1(1,n) = weights(1)*norm_factor + wts_map1(2,n) = (weights(2) - weights(1)* & + grid1_centroid_lat(grid1_add))* & + norm_factor + wts_map1(3,n) = (weights(3) - weights(1)* & + grid1_centroid_lon(grid1_add))* & + norm_factor + + if (num_maps > 1) then + select case(norm_opt) + case (norm_opt_dstarea) + if (grid1_area(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = one/grid1_area_in(grid1_add) + else + norm_factor = one/grid1_area(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_frcarea) + if (grid1_frac(grid1_add) /= zero) then + if (luse_grid1_area) then + norm_factor = grid1_area(grid1_add)/ & + (grid1_frac(grid1_add)* & + grid1_area_in(grid1_add)) + else + norm_factor = one/grid1_frac(grid1_add) + endif + else + norm_factor = zero + endif + case (norm_opt_none) + norm_factor = one + end select + + wts_map2(1,n) = weights(num_wts+1)*norm_factor + wts_map2(2,n) = (weights(num_wts+2) - weights(num_wts+1)* & + grid2_centroid_lat(grid2_add))* & + norm_factor + wts_map2(3,n) = (weights(num_wts+3) - weights(num_wts+1)* & + grid2_centroid_lon(grid2_add))* & + norm_factor + endif + + end do + + print *, 'Total number of links = ',num_links_map1 + + where (grid1_area /= zero) grid1_frac = grid1_frac/grid1_area + where (grid2_area /= zero) grid2_frac = grid2_frac/grid2_area + +!----------------------------------------------------------------------- +! +! perform some error checking on final weights +! +!----------------------------------------------------------------------- + + grid2_centroid_lat = zero + grid2_centroid_lon = zero + + do n=1,grid1_size + if (grid1_area(n) < -.01) then + print *,'Grid 1 area error: ',n,grid1_area(n) + endif + if (grid1_centroid_lat(n) < -pih-.01 .or. & + grid1_centroid_lat(n) > pih+.01) then + print *,'Grid 1 centroid lat error: ',n,grid1_centroid_lat(n) + endif + grid1_centroid_lat(n) = zero + grid1_centroid_lon(n) = zero + end do + + do n=1,grid2_size + if (grid2_area(n) < -.01) then + print *,'Grid 2 area error: ',n,grid2_area(n) + endif + if (grid2_centroid_lat(n) < -pih-.01 .or. & + grid2_centroid_lat(n) > pih+.01) then + print *,'Grid 2 centroid lat error: ',n,grid2_centroid_lat(n) + endif + grid2_centroid_lat(n) = zero + grid2_centroid_lon(n) = zero + end do + + do n=1,num_links_map1 + grid1_add = grid1_add_map1(n) + grid2_add = grid2_add_map1(n) + + if (wts_map1(1,n) < -.01) then + print *,'Map 1 weight < 0 ',grid1_add,grid2_add,wts_map1(1,n) + endif + if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > 1.01) then + print *,'Map 1 weight > 1 ',grid1_add,grid2_add,wts_map1(1,n) + endif + grid2_centroid_lat(grid2_add) = & + grid2_centroid_lat(grid2_add) + wts_map1(1,n) + + if (num_maps > 1) then + if (wts_map2(1,n) < -.01) then + print *,'Map 2 weight < 0 ',grid1_add,grid2_add, & + wts_map2(1,n) + endif + if (norm_opt /= norm_opt_none .and. wts_map2(1,n) > 1.01) then + print *,'Map 2 weight < 0 ',grid1_add,grid2_add, & + wts_map2(1,n) + endif + grid1_centroid_lat(grid1_add) = & + grid1_centroid_lat(grid1_add) + wts_map2(1,n) + endif + end do + + do n=1,grid2_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid2_frac(grid2_add) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid2_area) then + norm_factor = grid2_area_in(grid2_add) + else + norm_factor = grid2_area(grid2_add) + endif + end select + if (abs(grid2_centroid_lat(grid2_add)-norm_factor) > .01) then + print *,'Error: sum of wts for map1 ',grid2_add, & + grid2_centroid_lat(grid2_add),norm_factor + endif + end do + + if (num_maps > 1) then + do n=1,grid1_size + select case(norm_opt) + case (norm_opt_dstarea) + norm_factor = grid1_frac(grid1_add) + case (norm_opt_frcarea) + norm_factor = one + case (norm_opt_none) + if (luse_grid1_area) then + norm_factor = grid1_area_in(grid1_add) + else + norm_factor = grid1_area(grid1_add) + endif + end select + if (abs(grid1_centroid_lat(grid1_add)-norm_factor) > .01) then + print *,'Error: sum of wts for map2 ',grid1_add, & + grid1_centroid_lat(grid1_add),norm_factor + endif + end do + endif +!----------------------------------------------------------------------- + + end subroutine remap_conserv + +!*********************************************************************** + + subroutine intersection(location,intrsct_lat,intrsct_lon,lcoinc, & + beglat, beglon, endlat, endlon, begseg, & + lbegin, lrevers) + +!----------------------------------------------------------------------- +! +! this routine finds the next intersection of a destination grid +! line with the line segment given by beglon, endlon, etc. +! a coincidence flag is returned if the segment is entirely +! coincident with an ocean grid line. the cells in which to search +! for an intersection must have already been restricted in the +! calling routine. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), intent(in) :: & + lbegin, & ! flag for first integration along this segment + lrevers ! flag whether segment integrated in reverse + + real (kind=dbl_kind), intent(in) :: & + beglat, beglon, & ! beginning lat/lon endpoints for segment + endlat, endlon ! ending lat/lon endpoints for segment + + real (kind=dbl_kind), dimension(2), intent(inout) :: & + begseg ! begin lat/lon of full segment + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(out) :: & + location ! address in destination array containing this + ! segment + + logical (kind=log_kind), intent(out) :: & + lcoinc ! flag segments which are entirely coincident + ! with a grid line + + real (kind=dbl_kind), intent(out) :: & + intrsct_lat, intrsct_lon ! lat/lon coords of next intersect. + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, cell, srch_corners, pole_loc + + integer (kind=int_kind), save :: & + last_loc ! save location when crossing threshold + + logical (kind=log_kind) :: & + loutside ! flags points outside grid + + logical (kind=log_kind), save :: & + lthresh = .false. ! flags segments crossing threshold bndy + + real (kind=dbl_kind) :: & + lon1, lon2, & ! local longitude variables for segment + lat1, lat2, & ! local latitude variables for segment + grdlon1, grdlon2, & ! local longitude variables for grid cell + grdlat1, grdlat2, & ! local latitude variables for grid cell + vec1_lat, vec1_lon, & ! vectors and cross products used + vec2_lat, vec2_lon, & ! during grid search + cross_product, & + eps, offset, & ! small offset away from intersect + s1, s2, determ, & ! variables used for linear solve to + mat1, mat2, mat3, mat4, rhs1, rhs2 ! find intersection + + real (kind=dbl_kind), save :: & + intrsct_lat_off, intrsct_lon_off ! lat/lon coords offset + ! for next search + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + location = 0 + lcoinc = .false. + intrsct_lat = endlat + intrsct_lon = endlon + + if (num_srch_cells == 0) return + + if (beglat > north_thresh .or. beglat < south_thresh) then + + if (lthresh) location = last_loc + call pole_intersection(location, & + intrsct_lat,intrsct_lon,lcoinc,lthresh, & + beglat, beglon, endlat, endlon, begseg, lrevers) + if (lthresh) then + last_loc = location + intrsct_lat_off = intrsct_lat + intrsct_lon_off = intrsct_lon + endif + return + + endif + + loutside = .false. + if (lbegin) then + lat1 = beglat + lon1 = beglon + else + lat1 = intrsct_lat_off + lon1 = intrsct_lon_off + endif + lat2 = endlat + lon2 = endlon + if ((lon2-lon1) > three*pih) then + lon2 = lon2 - pi2 + else if ((lon2-lon1) < -three*pih) then + lon2 = lon2 + pi2 + endif + s1 = zero + +!----------------------------------------------------------------------- +! +! search for location of this segment in ocean grid using cross +! product method to determine whether a point is enclosed by a cell +! +!----------------------------------------------------------------------- + + call timer_start(12) + srch_corners = size(srch_corner_lat,DIM=1) + srch_loop: do + + !*** + !*** if last segment crossed threshold, use that location + !*** + + if (lthresh) then + do cell=1,num_srch_cells + if (srch_add(cell) == last_loc) then + location = last_loc + eps = tiny + exit srch_loop + endif + end do + endif + + !*** + !*** otherwise normal search algorithm + !*** + + cell_loop: do cell=1,num_srch_cells + corner_loop: do n=1,srch_corners + next_n = MOD(n,srch_corners) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each cell side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the cell. + !*** + + vec1_lat = srch_corner_lat(next_n,cell) - & + srch_corner_lat(n ,cell) + vec1_lon = srch_corner_lon(next_n,cell) - & + srch_corner_lon(n ,cell) + vec2_lat = lat1 - srch_corner_lat(n,cell) + vec2_lon = lon1 - srch_corner_lon(n,cell) + + !*** + !*** if endpoint coincident with vertex, offset + !*** the endpoint + !*** + + if (vec2_lat == 0 .and. vec2_lon == 0) then + lat1 = lat1 + 1.d-10*(lat2-lat1) + lon1 = lon1 + 1.d-10*(lon2-lon1) + vec2_lat = lat1 - srch_corner_lat(n,cell) + vec2_lon = lon1 - srch_corner_lon(n,cell) + endif + + !*** + !*** check for 0,2pi crossings + !*** + + if (vec1_lon > pi) then + vec1_lon = vec1_lon - pi2 + else if (vec1_lon < -pi) then + vec1_lon = vec1_lon + pi2 + endif + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the side is degenerate + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. otherwise perform + !*** another cross product between the side and the + !*** segment itself. + !*** if this cross product is also zero, the line is + !*** coincident with the cell boundary - perform the + !*** dot product and only choose the cell if the dot + !*** product is positive (parallel vs anti-parallel). + !*** + + if (cross_product == zero) then + if (vec1_lat /= zero .or. vec1_lon /= zero) then + vec2_lat = lat2 - lat1 + vec2_lon = lon2 - lon1 + + if (vec2_lon > pi) then + vec2_lon = vec2_lon - pi2 + else if (vec2_lon < -pi) then + vec2_lon = vec2_lon + pi2 + endif + + cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat + else + cross_product = one + endif + + if (cross_product == zero) then + lcoinc = .true. + cross_product = vec1_lon*vec2_lon + vec1_lat*vec2_lat + if (lrevers) cross_product = -cross_product + endif + endif + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (cross_product < zero) exit corner_loop + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > srch_corners) then + location = srch_add(cell) + + !*** + !*** if the beginning of this segment was outside the + !*** grid, invert the segment so the intersection found + !*** will be the first intersection with the grid + !*** + + if (loutside) then + lat2 = beglat + lon2 = beglon + location = 0 + eps = -tiny + else + eps = tiny + endif + + exit srch_loop + endif + + !*** + !*** otherwise move on to next cell + !*** + + end do cell_loop + + !*** + !*** if still no cell found, the point lies outside the grid. + !*** take some baby steps along the segment to see if any + !*** part of the segment lies inside the grid. + !*** + + loutside = .true. + s1 = s1 + 0.001_dbl_kind + lat1 = beglat + s1*(endlat - beglat) + lon1 = beglon + s1*(lon2 - beglon) + + !*** + !*** reached the end of the segment and still outside the grid + !*** return no intersection + !*** + + if (s1 >= one) return + + end do srch_loop + call timer_stop(12) + +!----------------------------------------------------------------------- +! +! now that a cell is found, search for the next intersection. +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + call timer_start(13) + intrsct_loop: do n=1,srch_corners + next_n = mod(n,srch_corners) + 1 + + grdlon1 = srch_corner_lon(n ,cell) + grdlon2 = srch_corner_lon(next_n,cell) + grdlat1 = srch_corner_lat(n ,cell) + grdlat2 = srch_corner_lat(next_n,cell) + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = lat2 - lat1 + mat2 = grdlat1 - grdlat2 + mat3 = lon2 - lon1 + mat4 = grdlon1 - grdlon2 + rhs1 = grdlat1 - lat1 + rhs2 = grdlon1 - lon1 + + if (mat3 > pi) then + mat3 = mat3 - pi2 + else if (mat3 < -pi) then + mat3 = mat3 + pi2 + endif + if (mat4 > pi) then + mat4 = mat4 - pi2 + else if (mat4 < -pi) then + mat4 = mat4 + pi2 + endif + if (rhs2 > pi) then + rhs2 = rhs2 - pi2 + else if (rhs2 < -pi) then + rhs2 = rhs2 + pi2 + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident. coincidences were detected + !*** above so do nothing. + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0<s1,s2<1 then the segment intersects with this side. + !*** return the point of intersection (adding a small + !*** number so the intersection is off the grid line). + !*** + + if (abs(determ) > 1.e-30) then + + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (s2 >= zero .and. s2 <= one .and. & + s1 > zero .and. s1 <= one) then + + !*** + !*** recompute intersection based on full segment + !*** so intersections are consistent for both sweeps + !*** + + if (.not. loutside) then + mat1 = lat2 - begseg(1) + mat3 = lon2 - begseg(2) + rhs1 = grdlat1 - begseg(1) + rhs2 = grdlon1 - begseg(2) + else + mat1 = begseg(1) - endlat + mat3 = begseg(2) - endlon + rhs1 = grdlat1 - endlat + rhs2 = grdlon1 - endlon + endif + + if (mat3 > pi) then + mat3 = mat3 - pi2 + else if (mat3 < -pi) then + mat3 = mat3 + pi2 + endif + if (rhs2 > pi) then + rhs2 = rhs2 - pi2 + else if (rhs2 < -pi) then + rhs2 = rhs2 + pi2 + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** sometimes due to roundoff, the previous + !*** determinant is non-zero, but the lines + !*** are actually coincident. if this is the + !*** case, skip the rest. + !*** + + if (determ /= zero) then + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + offset = s1 + eps/determ + if (offset > one) offset = one + + if (.not. loutside) then + intrsct_lat = begseg(1) + mat1*s1 + intrsct_lon = begseg(2) + mat3*s1 + intrsct_lat_off = begseg(1) + mat1*offset + intrsct_lon_off = begseg(2) + mat3*offset + else + intrsct_lat = endlat + mat1*s1 + intrsct_lon = endlon + mat3*s1 + intrsct_lat_off = endlat + mat1*offset + intrsct_lon_off = endlon + mat3*offset + endif + exit intrsct_loop + endif + + endif + endif + + !*** + !*** no intersection this side, move on to next side + !*** + + end do intrsct_loop + call timer_stop(13) + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude. only check if this was not a +! threshold segment since sometimes coordinate transform can end +! up on other side of threshold again. +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat < north_thresh .or. intrsct_lat > south_thresh) & + lthresh = .false. + else if (lat1 > zero .and. intrsct_lat > north_thresh) then + intrsct_lat = north_thresh + tiny + intrsct_lat_off = north_thresh + eps*mat1 + s1 = (intrsct_lat - begseg(1))/mat1 + intrsct_lon = begseg(2) + s1*mat3 + intrsct_lon_off = begseg(2) + (s1+eps)*mat3 + last_loc = location + lthresh = .true. + else if (lat1 < zero .and. intrsct_lat < south_thresh) then + intrsct_lat = south_thresh - tiny + intrsct_lat_off = south_thresh + eps*mat1 + s1 = (intrsct_lat - begseg(1))/mat1 + intrsct_lon = begseg(2) + s1*mat3 + intrsct_lon_off = begseg(2) + (s1+eps)*mat3 + last_loc = location + lthresh = .true. + endif + +!----------------------------------------------------------------------- + + end subroutine intersection + +!*********************************************************************** + + subroutine pole_intersection(location, & + intrsct_lat,intrsct_lon,lcoinc,lthresh, & + beglat, beglon, endlat, endlon, begseg, lrevers) + +!----------------------------------------------------------------------- +! +! this routine is identical to the intersection routine except +! that a coordinate transformation (using a Lambert azimuthal +! equivalent projection) is performed to treat polar cells more +! accurately. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), intent(in) :: & + beglat, beglon, & ! beginning lat/lon endpoints for segment + endlat, endlon ! ending lat/lon endpoints for segment + + real (kind=dbl_kind), dimension(2), intent(inout) :: & + begseg ! begin lat/lon of full segment + + logical (kind=log_kind), intent(in) :: & + lrevers ! flag true if segment integrated in reverse + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(inout) :: & + location ! address in destination array containing this + ! segment -- also may contain last location on + ! entry + + logical (kind=log_kind), intent(out) :: & + lcoinc ! flag segment coincident with grid line + + logical (kind=log_kind), intent(inout) :: & + lthresh ! flag segment crossing threshold boundary + + real (kind=dbl_kind), intent(out) :: & + intrsct_lat, intrsct_lon ! lat/lon coords of next intersect. + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, next_n, cell, srch_corners, pole_loc + + logical (kind=log_kind) :: loutside ! flags points outside grid + + real (kind=dbl_kind) :: pi4, rns, & ! north/south conversion + x1, x2, & ! local x variables for segment + y1, y2, & ! local y variables for segment + begx, begy, & ! beginning x,y variables for segment + endx, endy, & ! beginning x,y variables for segment + begsegx, begsegy, & ! beginning x,y variables for segment + grdx1, grdx2, & ! local x variables for grid cell + grdy1, grdy2, & ! local y variables for grid cell + vec1_y, vec1_x, & ! vectors and cross products used + vec2_y, vec2_x, & ! during grid search + cross_product, eps, & ! eps=small offset away from intersect + s1, s2, determ, & ! variables used for linear solve to + mat1, mat2, mat3, mat4, rhs1, rhs2 ! find intersection + + real (kind=dbl_kind), dimension(:,:), allocatable :: & + srch_corner_x, & ! x of each corner of srch cells + srch_corner_y ! y of each corner of srch cells + + !*** + !*** save last intersection to avoid roundoff during coord + !*** transformation + !*** + + logical (kind=log_kind), save :: luse_last = .false. + + real (kind=dbl_kind), save :: & + intrsct_x, intrsct_y ! x,y for intersection + + !*** + !*** variables necessary if segment manages to hit pole + !*** + + integer (kind=int_kind), save :: & + avoid_pole_count = 0 ! count attempts to avoid pole + + real (kind=dbl_kind), save :: & + avoid_pole_offset = tiny ! endpoint offset to avoid pole + +!----------------------------------------------------------------------- +! +! initialize defaults, flags, etc. +! +!----------------------------------------------------------------------- + + if (.not. lthresh) location = 0 + lcoinc = .false. + intrsct_lat = endlat + intrsct_lon = endlon + + loutside = .false. + s1 = zero + +!----------------------------------------------------------------------- +! +! convert coordinates +! +!----------------------------------------------------------------------- + + allocate(srch_corner_x(size(srch_corner_lat,DIM=1), & + size(srch_corner_lat,DIM=2)), & + srch_corner_y(size(srch_corner_lat,DIM=1), & + size(srch_corner_lat,DIM=2))) + + if (beglat > zero) then + pi4 = quart*pi + rns = one + else + pi4 = -quart*pi + rns = -one + endif + + if (luse_last) then + x1 = intrsct_x + y1 = intrsct_y + else + x1 = rns*two*sin(pi4 - half*beglat)*cos(beglon) + y1 = two*sin(pi4 - half*beglat)*sin(beglon) + luse_last = .true. + endif + x2 = rns*two*sin(pi4 - half*endlat)*cos(endlon) + y2 = two*sin(pi4 - half*endlat)*sin(endlon) + srch_corner_x = rns*two*sin(pi4 - half*srch_corner_lat)* & + cos(srch_corner_lon) + srch_corner_y = two*sin(pi4 - half*srch_corner_lat)* & + sin(srch_corner_lon) + + begx = x1 + begy = y1 + endx = x2 + endy = y2 + begsegx = rns*two*sin(pi4 - half*begseg(1))*cos(begseg(2)) + begsegy = two*sin(pi4 - half*begseg(1))*sin(begseg(2)) + intrsct_x = endx + intrsct_y = endy + +!----------------------------------------------------------------------- +! +! search for location of this segment in ocean grid using cross +! product method to determine whether a point is enclosed by a cell +! +!----------------------------------------------------------------------- + + call timer_start(12) + srch_corners = size(srch_corner_lat,DIM=1) + srch_loop: do + + !*** + !*** if last segment crossed threshold, use that location + !*** + + if (lthresh) then + do cell=1,num_srch_cells + if (srch_add(cell) == location) then + eps = tiny + exit srch_loop + endif + end do + endif + + !*** + !*** otherwise normal search algorithm + !*** + + cell_loop: do cell=1,num_srch_cells + corner_loop: do n=1,srch_corners + next_n = MOD(n,srch_corners) + 1 + + !*** + !*** here we take the cross product of the vector making + !*** up each cell side with the vector formed by the vertex + !*** and search point. if all the cross products are + !*** positive, the point is contained in the cell. + !*** + + vec1_x = srch_corner_x(next_n,cell) - & + srch_corner_x(n ,cell) + vec1_y = srch_corner_y(next_n,cell) - & + srch_corner_y(n ,cell) + vec2_x = x1 - srch_corner_x(n,cell) + vec2_y = y1 - srch_corner_y(n,cell) + + !*** + !*** if endpoint coincident with vertex, offset + !*** the endpoint + !*** + + if (vec2_x == 0 .and. vec2_y == 0) then + x1 = x1 + 1.d-10*(x2-x1) + y1 = y1 + 1.d-10*(y2-y1) + vec2_x = x1 - srch_corner_x(n,cell) + vec2_y = y1 - srch_corner_y(n,cell) + endif + + cross_product = vec1_x*vec2_y - vec2_x*vec1_y + + !*** + !*** if the cross product for a side is zero, the point + !*** lies exactly on the side or the length of a side + !*** is zero. if the length is zero set det > 0. + !*** otherwise, perform another cross + !*** product between the side and the segment itself. + !*** if this cross product is also zero, the line is + !*** coincident with the cell boundary - perform the + !*** dot product and only choose the cell if the dot + !*** product is positive (parallel vs anti-parallel). + !*** + + if (cross_product == zero) then + if (vec1_x /= zero .or. vec1_y /= 0) then + vec2_x = x2 - x1 + vec2_y = y2 - y1 + cross_product = vec1_x*vec2_y - vec2_x*vec1_y + else + cross_product = one + endif + + if (cross_product == zero) then + lcoinc = .true. + cross_product = vec1_x*vec2_x + vec1_y*vec2_y + if (lrevers) cross_product = -cross_product + endif + endif + + !*** + !*** if cross product is less than zero, this cell + !*** doesn't work + !*** + + if (cross_product < zero) exit corner_loop + + end do corner_loop + + !*** + !*** if cross products all positive, we found the location + !*** + + if (n > srch_corners) then + location = srch_add(cell) + + !*** + !*** if the beginning of this segment was outside the + !*** grid, invert the segment so the intersection found + !*** will be the first intersection with the grid + !*** + + if (loutside) then + x2 = begx + y2 = begy + location = 0 + eps = -tiny + else + eps = tiny + endif + + exit srch_loop + endif + + !*** + !*** otherwise move on to next cell + !*** + + end do cell_loop + + !*** + !*** if no cell found, the point lies outside the grid. + !*** take some baby steps along the segment to see if any + !*** part of the segment lies inside the grid. + !*** + + loutside = .true. + s1 = s1 + 0.001_dbl_kind + x1 = begx + s1*(x2 - begx) + y1 = begy + s1*(y2 - begy) + + !*** + !*** reached the end of the segment and still outside the grid + !*** return no intersection + !*** + + if (s1 >= one) then + deallocate(srch_corner_x, srch_corner_y) + luse_last = .false. + return + endif + + end do srch_loop + call timer_stop(12) + +!----------------------------------------------------------------------- +! +! now that a cell is found, search for the next intersection. +! loop over sides of the cell to find intersection with side +! must check all sides for coincidences or intersections +! +!----------------------------------------------------------------------- + + call timer_start(13) + intrsct_loop: do n=1,srch_corners + next_n = mod(n,srch_corners) + 1 + + grdy1 = srch_corner_y(n ,cell) + grdy2 = srch_corner_y(next_n,cell) + grdx1 = srch_corner_x(n ,cell) + grdx2 = srch_corner_x(next_n,cell) + + !*** + !*** set up linear system to solve for intersection + !*** + + mat1 = x2 - x1 + mat2 = grdx1 - grdx2 + mat3 = y2 - y1 + mat4 = grdy1 - grdy2 + rhs1 = grdx1 - x1 + rhs2 = grdy1 - y1 + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** if the determinant is zero, the segments are either + !*** parallel or coincident or one segment has zero length. + !*** coincidences were detected above so do nothing. + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line + !*** segment. + !*** if 0<s1,s2<1 then the segment intersects with this side. + !*** return the point of intersection (adding a small + !*** number so the intersection is off the grid line). + !*** + + if (abs(determ) > 1.e-30) then + + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (s2 >= zero .and. s2 <= one .and. & + s1 > zero .and. s1 <= one) then + + !*** + !*** recompute intersection using entire segment + !*** for consistency between sweeps + !*** + + if (.not. loutside) then + mat1 = x2 - begsegx + mat3 = y2 - begsegy + rhs1 = grdx1 - begsegx + rhs2 = grdy1 - begsegy + else + mat1 = x2 - endx + mat3 = y2 - endy + rhs1 = grdx1 - endx + rhs2 = grdy1 - endy + endif + + determ = mat1*mat4 - mat2*mat3 + + !*** + !*** sometimes due to roundoff, the previous + !*** determinant is non-zero, but the lines + !*** are actually coincident. if this is the + !*** case, skip the rest. + !*** + + if (determ /= zero) then + s1 = (rhs1*mat4 - mat2*rhs2)/determ + s2 = (mat1*rhs2 - rhs1*mat3)/determ + + if (.not. loutside) then + intrsct_x = begsegx + s1*mat1 + intrsct_y = begsegy + s1*mat3 + else + intrsct_x = endx + s1*mat1 + intrsct_y = endy + s1*mat3 + endif + + !*** + !*** convert back to lat/lon coordinates + !*** + + intrsct_lon = rns*atan2(intrsct_y,intrsct_x) + if (intrsct_lon < zero) & + intrsct_lon = intrsct_lon + pi2 + + if (abs(intrsct_x) > 1.d-10) then + intrsct_lat = (pi4 - & + asin(rns*half*intrsct_x/cos(intrsct_lon)))*two + else if (abs(intrsct_y) > 1.d-10) then + intrsct_lat = (pi4 - & + asin(half*intrsct_y/sin(intrsct_lon)))*two + else + intrsct_lat = two*pi4 + endif + + !*** + !*** add offset in transformed space for next pass. + !*** + + if (s1 - eps/determ < one) then + intrsct_x = intrsct_x - mat1*(eps/determ) + intrsct_y = intrsct_y - mat3*(eps/determ) + else + if (.not. loutside) then + intrsct_x = endx + intrsct_y = endy + intrsct_lat = endlat + intrsct_lon = endlon + else + intrsct_x = begsegx + intrsct_y = begsegy + intrsct_lat = begseg(1) + intrsct_lon = begseg(2) + endif + endif + + exit intrsct_loop + endif + endif + endif + + !*** + !*** no intersection this side, move on to next side + !*** + + end do intrsct_loop + call timer_stop(13) + + deallocate(srch_corner_x, srch_corner_y) + +!----------------------------------------------------------------------- +! +! if segment manages to cross over pole, shift the beginning +! endpoint in order to avoid hitting pole directly +! (it is ok for endpoint to be pole point) +! +!----------------------------------------------------------------------- + + if (abs(intrsct_x) < 1.e-10 .and. abs(intrsct_y) < 1.e-10 .and. & + (endx /= zero .and. endy /=0)) then + if (avoid_pole_count > 2) then + avoid_pole_count = 0 + avoid_pole_offset = 10.*avoid_pole_offset + endif + + cross_product = begsegx*(endy-begsegy) - begsegy*(endx-begsegx) + intrsct_lat = begseg(1) + if (cross_product*intrsct_lat > zero) then + intrsct_lon = beglon + avoid_pole_offset + begseg(2) = begseg(2) + avoid_pole_offset + else + intrsct_lon = beglon - avoid_pole_offset + begseg(2) = begseg(2) - avoid_pole_offset + endif + + avoid_pole_count = avoid_pole_count + 1 + luse_last = .false. + else + avoid_pole_count = 0 + avoid_pole_offset = tiny + endif + +!----------------------------------------------------------------------- +! +! if the segment crosses a pole threshold, reset the intersection +! to be the threshold latitude and do not reuse x,y intersect +! on next entry. only check if did not cross threshold last +! time - sometimes the coordinate transformation can place a +! segment on the other side of the threshold again +! +!----------------------------------------------------------------------- + + if (lthresh) then + if (intrsct_lat > north_thresh .or. intrsct_lat < south_thresh) & + lthresh = .false. + else if (beglat > zero .and. intrsct_lat < north_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 + intrsct_lat = north_thresh - tiny + s1 = (north_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + luse_last = .false. + lthresh = .true. + else if (beglat < zero .and. intrsct_lat > south_thresh) then + mat4 = endlat - begseg(1) + mat3 = endlon - begseg(2) + if (mat3 > pi) mat3 = mat3 - pi2 + if (mat3 < -pi) mat3 = mat3 + pi2 + intrsct_lat = south_thresh + tiny + s1 = (south_thresh - begseg(1))/mat4 + intrsct_lon = begseg(2) + s1*mat3 + luse_last = .false. + lthresh = .true. + endif + + !*** + !*** if reached end of segment, do not use x,y intersect + !*** on next entry + !*** + + if (intrsct_lat == endlat .and. intrsct_lon == endlon) then + luse_last = .false. + endif + +!----------------------------------------------------------------------- + + end subroutine pole_intersection + +!*********************************************************************** + + subroutine line_integral(weights, num_wts, & + in_phi1, in_phi2, theta1, theta2, & + grid1_lat, grid1_lon, grid2_lat, grid2_lon) + +!----------------------------------------------------------------------- +! +! this routine computes the line integral of the flux function +! that results in the interpolation weights. the line is defined +! by the input lat/lon of the endpoints. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! intent(in): +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + num_wts ! number of weights to compute + + real (kind=dbl_kind), intent(in) :: & + in_phi1, in_phi2, & ! longitude endpoints for the segment + theta1, theta2, & ! latitude endpoints for the segment + grid1_lat, grid1_lon, & ! reference coordinates for each + grid2_lat, grid2_lon ! grid (to ensure correct 0,2pi interv. + +!----------------------------------------------------------------------- +! +! intent(out): +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind), dimension(2*num_wts), intent(out) :: & + weights ! line integral contribution to weights + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (kind=dbl_kind) :: dphi, sinth1, sinth2, costh1, costh2, fac, & + phi1, phi2, phidiff1, phidiff2, sinint + real (kind=dbl_kind) :: f1, f2, fint + +!----------------------------------------------------------------------- +! +! weights for the general case based on a trapezoidal approx to +! the integrals. +! +!----------------------------------------------------------------------- + + sinth1 = SIN(theta1) + sinth2 = SIN(theta2) + costh1 = COS(theta1) + costh2 = COS(theta2) + + dphi = in_phi1 - in_phi2 + if (dphi > pi) then + dphi = dphi - pi2 + else if (dphi < -pi) then + dphi = dphi + pi2 + endif + dphi = half*dphi + +!----------------------------------------------------------------------- +! +! the first weight is the area overlap integral. the second and +! fourth are second-order latitude gradient weights. +! +!----------------------------------------------------------------------- + + weights( 1) = dphi*(sinth1 + sinth2) + weights(num_wts+1) = dphi*(sinth1 + sinth2) + weights( 2) = dphi*(costh1 + costh2 + (theta1*sinth1 + & + theta2*sinth2)) + weights(num_wts+2) = dphi*(costh1 + costh2 + (theta1*sinth1 + & + theta2*sinth2)) + +!----------------------------------------------------------------------- +! +! the third and fifth weights are for the second-order phi gradient +! component. must be careful of longitude range. +! +!----------------------------------------------------------------------- + + f1 = half*(costh1*sinth1 + theta1) + f2 = half*(costh2*sinth2 + theta2) + + phi1 = in_phi1 - grid1_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid1_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(3) = half*phi1*(phi1-fac)*f1 - & + half*phi2*(phi2+fac)*f2 + & + half*fac*(phi1+phi2)*fint + endif + + phi1 = in_phi1 - grid2_lon + if (phi1 > pi) then + phi1 = phi1 - pi2 + else if (phi1 < -pi) then + phi1 = phi1 + pi2 + endif + + phi2 = in_phi2 - grid2_lon + if (phi2 > pi) then + phi2 = phi2 - pi2 + else if (phi2 < -pi) then + phi2 = phi2 + pi2 + endif + + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then + weights(num_wts+3) = dphi*(phi1*f1 + phi2*f2) + else + if (phi1 > zero) then + fac = pi + else + fac = -pi + endif + fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi) + weights(num_wts+3) = half*phi1*(phi1-fac)*f1 - & + half*phi2*(phi2+fac)*f2 + & + half*fac*(phi1+phi2)*fint + endif + +!----------------------------------------------------------------------- + + end subroutine line_integral + +!*********************************************************************** + + subroutine store_link_cnsrv(add1, add2, weights) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for this link in +! the appropriate address and weight arrays and resizes those +! arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + add1, & ! address on grid1 + add2 ! address on grid2 + + real (kind=dbl_kind), dimension(:), intent(in) :: & + weights ! array of remapping weights for this link + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: nlink, min_link, max_link ! link index + + integer (kind=int_kind), dimension(:,:), allocatable, save :: & + link_add1, & ! min,max link add to restrict search + link_add2 ! min,max link add to restrict search + + logical (kind=log_kind), save :: first_call = .true. + +!----------------------------------------------------------------------- +! +! if all weights are zero, do not bother storing the link +! +!----------------------------------------------------------------------- + + if (all(weights == zero)) return + +!----------------------------------------------------------------------- +! +! restrict the range of links to search for existing links +! +!----------------------------------------------------------------------- + + if (first_call) then + allocate(link_add1(2,grid1_size), link_add2(2,grid2_size)) + link_add1 = 0 + link_add2 = 0 + first_call = .false. + min_link = 1 + max_link = 0 + else + min_link = min(link_add1(1,add1),link_add2(1,add2)) + max_link = max(link_add1(2,add1),link_add2(2,add2)) + if (min_link == 0) then + min_link = 1 + max_link = 0 + endif + endif + +!----------------------------------------------------------------------- +! +! if the link already exists, add the weight to the current weight +! arrays +! +!----------------------------------------------------------------------- + + do nlink=min_link,max_link + if (add1 == grid1_add_map1(nlink)) then + if (add2 == grid2_add_map1(nlink)) then + + wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts) + if (num_maps == 2) then + wts_map2(:,nlink) = wts_map2(:,nlink) + & + weights(num_wts+1:2*num_wts) + endif + return + + endif + endif + end do + +!----------------------------------------------------------------------- +! +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate +! the new link. then store the link. +! +!----------------------------------------------------------------------- + + num_links_map1 = num_links_map1 + 1 + if (num_links_map1 > max_links_map1) & + call resize_remap_vars(1,resize_increment) + + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = weights(1:num_wts) + + if (num_maps > 1) then + num_links_map2 = num_links_map2 + 1 + if (num_links_map2 > max_links_map2) & + call resize_remap_vars(2,resize_increment) + + grid1_add_map2(num_links_map2) = add1 + grid2_add_map2(num_links_map2) = add2 + wts_map2 (:,num_links_map2) = weights(num_wts+1:2*num_wts) + endif + + if (link_add1(1,add1) == 0) link_add1(1,add1) = num_links_map1 + if (link_add2(1,add2) == 0) link_add2(1,add2) = num_links_map1 + link_add1(2,add1) = num_links_map1 + link_add2(2,add2) = num_links_map1 + +!----------------------------------------------------------------------- + + end subroutine store_link_cnsrv + +!*********************************************************************** + + end module remap_conservative + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_distwgt.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_distwgt.f90 new file mode 100644 index 0000000000000000000000000000000000000000..51202116c50039cc33089132f4c469078e9b2e46 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_distwgt.f90 @@ -0,0 +1,498 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary routines for performing an +! interpolation using a distance-weighted average of n nearest +! neighbors. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_distwgt.f,v 1.3 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_distance_weight + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common constants + use grids ! module containing grid info + use remap_vars ! module containing remap info + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: & + num_neighbors=4 ! num nearest neighbors to interpolate from + + real (kind=dbl_kind), dimension(:), allocatable, save :: & + coslat, sinlat, & ! cosine, sine of grid lats (for distance) + coslon, sinlon, & ! cosine, sine of grid lons (for distance) + wgtstmp ! an array to hold the link weight + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine remap_distwgt + +!----------------------------------------------------------------------- +! +! this routine computes the inverse-distance weights for a +! nearest-neighbor interpolation. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + logical (kind=log_kind), dimension(num_neighbors) :: & + nbr_mask ! mask at nearest neighbors + + integer (kind=int_kind) :: n, & + dst_add, & ! destination address + nmap ! index of current map being computed + + integer (kind=int_kind), dimension(num_neighbors) :: & + nbr_add ! source address at nearest neighbors + + real (kind=dbl_kind), dimension(num_neighbors) :: & + nbr_dist ! angular distance four nearest neighbors + + real (kind=dbl_kind) :: & + coslat_dst, & ! cos(lat) of destination grid point + coslon_dst, & ! cos(lon) of destination grid point + sinlat_dst, & ! sin(lat) of destination grid point + sinlon_dst, & ! sin(lon) of destination grid point + dist_tot ! sum of neighbor distances (for normalizing) + +!----------------------------------------------------------------------- +! +! compute mappings from grid1 to grid2 +! +!----------------------------------------------------------------------- + + nmap = 1 + + !*** + !*** allocate wgtstmp to be consistent with store_link interface + !*** + + allocate (wgtstmp(num_wts)) + + !*** + !*** compute cos, sin of lat/lon on source grid for distance + !*** calculations + !*** + + allocate (coslat(grid1_size), coslon(grid1_size), & + sinlat(grid1_size), sinlon(grid1_size)) + + coslat = cos(grid1_center_lat) + coslon = cos(grid1_center_lon) + sinlat = sin(grid1_center_lat) + sinlon = sin(grid1_center_lon) + + !*** + !*** loop over destination grid + !*** + + grid_loop1: do dst_add = 1, grid2_size + + if (.not. grid2_mask(dst_add)) cycle grid_loop1 + + coslat_dst = cos(grid2_center_lat(dst_add)) + coslon_dst = cos(grid2_center_lon(dst_add)) + sinlat_dst = sin(grid2_center_lat(dst_add)) + sinlon_dst = sin(grid2_center_lon(dst_add)) + + !*** + !*** find nearest grid points on source grid and + !*** distances to each point + !*** + + call grid_search_nbr(nbr_add, nbr_dist, & + grid2_center_lat(dst_add), & + grid2_center_lon(dst_add), & + coslat_dst, coslon_dst, & + sinlat_dst, sinlon_dst, & + bin_addr1, bin_addr2) + + !*** + !*** compute weights based on inverse distance + !*** if mask is false, eliminate those points + !*** + + dist_tot = zero + do n=1,num_neighbors + if (grid1_mask(nbr_add(n))) then + nbr_dist(n) = one/nbr_dist(n) + dist_tot = dist_tot + nbr_dist(n) + nbr_mask(n) = .true. + else + nbr_mask(n) = .false. + endif + end do + + !*** + !*** normalize weights and store the link + !*** + + do n=1,num_neighbors + if (nbr_mask(n)) then + wgtstmp(1) = nbr_dist(n)/dist_tot + call store_link_nbr(nbr_add(n), dst_add, wgtstmp, nmap) + grid2_frac(dst_add) = one + endif + end do + + end do grid_loop1 + + deallocate (coslat, coslon, sinlat, sinlon) + +!----------------------------------------------------------------------- +! +! compute mappings from grid2 to grid1 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + + nmap = 2 + + !*** + !*** compute cos, sin of lat/lon on source grid for distance + !*** calculations + !*** + + allocate (coslat(grid2_size), coslon(grid2_size), & + sinlat(grid2_size), sinlon(grid2_size)) + + coslat = cos(grid2_center_lat) + coslon = cos(grid2_center_lon) + sinlat = sin(grid2_center_lat) + sinlon = sin(grid2_center_lon) + + !*** + !*** loop over destination grid + !*** + + grid_loop2: do dst_add = 1, grid1_size + + if (.not. grid1_mask(dst_add)) cycle grid_loop2 + + coslat_dst = cos(grid1_center_lat(dst_add)) + coslon_dst = cos(grid1_center_lon(dst_add)) + sinlat_dst = sin(grid1_center_lat(dst_add)) + sinlon_dst = sin(grid1_center_lon(dst_add)) + + !*** + !*** find four nearest grid points on source grid and + !*** distances to each point + !*** + + call grid_search_nbr(nbr_add, nbr_dist, & + grid1_center_lat(dst_add), & + grid1_center_lon(dst_add), & + coslat_dst, coslon_dst, & + sinlat_dst, sinlon_dst, & + bin_addr2, bin_addr1) + + !*** + !*** compute weights based on inverse distance + !*** if mask is false, eliminate those points + !*** + + dist_tot = zero + do n=1,num_neighbors + if (grid2_mask(nbr_add(n))) then + nbr_dist(n) = one/nbr_dist(n) + dist_tot = dist_tot + nbr_dist(n) + nbr_mask(n) = .true. + else + nbr_mask(n) = .false. + endif + end do + + !*** + !*** normalize weights and store the link + !*** + + do n=1,num_neighbors + if (nbr_mask(n)) then + wgtstmp(1) = nbr_dist(n)/dist_tot + call store_link_nbr(dst_add, nbr_add(n), wgtstmp, nmap) + grid1_frac(dst_add) = one + endif + end do + + end do grid_loop2 + + deallocate (coslat, coslon, sinlat, sinlon) + + endif + + deallocate(wgtstmp) + +!----------------------------------------------------------------------- + + end subroutine remap_distwgt + +!*********************************************************************** + + subroutine grid_search_nbr(nbr_add, nbr_dist, plat, plon, & + coslat_dst, coslon_dst, sinlat_dst, sinlon_dst, & + src_bin_add, dst_bin_add) + +!----------------------------------------------------------------------- +! +! this routine finds the closest num_neighbor points to a search +! point and computes a distance to each of the neighbors. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(num_neighbors), intent(out) :: & + nbr_add ! address of each of the closest points + + real (kind=dbl_kind), dimension(num_neighbors), intent(out) :: & + nbr_dist ! distance to each of the closest points + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), dimension(:,:), intent(in) :: & + src_bin_add, & ! search bins for restricting search + dst_bin_add + + real (kind=dbl_kind), intent(in) :: & + plat, & ! latitude of the search point + plon, & ! longitude of the search point + coslat_dst, & ! cos(lat) of the search point + coslon_dst, & ! cos(lon) of the search point + sinlat_dst, & ! sin(lat) of the search point + sinlon_dst ! sin(lon) of the search point + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, nmax, nadd, nchk, & ! dummy indices + min_add, max_add, nm1, np1, i, j, ip1, im1, jp1, jm1 + + real (kind=dbl_kind) :: & + distance ! angular distance + +!----------------------------------------------------------------------- +! +! loop over source grid and find nearest neighbors +! +!----------------------------------------------------------------------- + + !*** + !*** restrict the search using search bins + !*** expand the bins to catch neighbors + !*** + + select case (restrict_type) + case('latitude') + + do n=1,num_srch_bins + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n)) then + min_add = src_bin_add(1,n) + max_add = src_bin_add(2,n) + + nm1 = max(n-1,1) + np1 = min(n+1,num_srch_bins) + + min_add = min(min_add,src_bin_add(1,nm1)) + max_add = max(max_add,src_bin_add(2,nm1)) + min_add = min(min_add,src_bin_add(1,np1)) + max_add = max(max_add,src_bin_add(2,np1)) + endif + end do + + case('latlon') + + n = 0 + nmax = nint(sqrt(real(num_srch_bins))) + do j=1,nmax + jp1 = min(j+1,nmax) + jm1 = max(j-1,1) + do i=1,nmax + ip1 = min(i+1,nmax) + im1 = max(i-1,1) + + n = n+1 + if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and. & + plon >= bin_lons(1,n) .and. plon <= bin_lons(3,n)) then + min_add = src_bin_add(1,n) + max_add = src_bin_add(2,n) + + nm1 = (jm1-1)*nmax + im1 + np1 = (jp1-1)*nmax + ip1 + nm1 = max(nm1,1) + np1 = min(np1,num_srch_bins) + + min_add = min(min_add,src_bin_add(1,nm1)) + max_add = max(max_add,src_bin_add(2,nm1)) + min_add = min(min_add,src_bin_add(1,np1)) + max_add = max(max_add,src_bin_add(2,np1)) + endif + end do + end do + + end select + + !*** + !*** initialize distance and address arrays + !*** + + nbr_add = 0 + nbr_dist = bignum + + do nadd=min_add,max_add + + !*** + !*** find distance to this point + !*** + + distance = acos(sinlat_dst*sinlat(nadd) + & + coslat_dst*coslat(nadd)* & + (coslon_dst*coslon(nadd) + & + sinlon_dst*sinlon(nadd)) ) + + !*** + !*** store the address and distance if this is one of the + !*** smallest four so far + !*** + + check_loop: do nchk=1,num_neighbors + if (distance .lt. nbr_dist(nchk)) then + do n=num_neighbors,nchk+1,-1 + nbr_add(n) = nbr_add(n-1) + nbr_dist(n) = nbr_dist(n-1) + end do + nbr_add(nchk) = nadd + nbr_dist(nchk) = distance + exit check_loop + endif + end do check_loop + + end do + +!----------------------------------------------------------------------- + + end subroutine grid_search_nbr + +!*********************************************************************** + + subroutine store_link_nbr(add1, add2, weights, nmap) + +!----------------------------------------------------------------------- +! +! this routine stores the address and weight for this link in +! the appropriate address and weight arrays and resizes those +! arrays if necessary. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + add1, & ! address on grid1 + add2, & ! address on grid2 + nmap ! identifies which direction for mapping + + real (kind=dbl_kind), dimension(:), intent(in) :: & + weights ! array of remapping weights for this link + +!----------------------------------------------------------------------- +! +! increment number of links and check to see if remap arrays need +! to be increased to accomodate the new link. then store the +! link. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + num_links_map1 = num_links_map1 + 1 + + if (num_links_map1 > max_links_map1) & + call resize_remap_vars(1,resize_increment) + + grid1_add_map1(num_links_map1) = add1 + grid2_add_map1(num_links_map1) = add2 + wts_map1 (:,num_links_map1) = weights + + case(2) + + num_links_map2 = num_links_map2 + 1 + + if (num_links_map2 > max_links_map2) & + call resize_remap_vars(2,resize_increment) + + grid1_add_map2(num_links_map2) = add1 + grid2_add_map2(num_links_map2) = add2 + wts_map2 (:,num_links_map2) = weights + + end select + +!----------------------------------------------------------------------- + + end subroutine store_link_nbr + +!*********************************************************************** + + end module remap_distance_weight + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_read.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_read.f90 new file mode 100644 index 0000000000000000000000000000000000000000..18d4113d0ac2a3da36932ebd058769bc6a84f825 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_read.f90 @@ -0,0 +1,1027 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This routine reads remapping information from files written +! by remap_setup. If remapping in both directions are required, +! two input files must be specified. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_read.f,v 1.6 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_read + +!----------------------------------------------------------------------- +! +! contains routines for reading a remap file +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines useful constants + use grids ! includes all grid information + use netcdf_mod ! module with netcdf vars and utilities + use remap_vars ! module for all required remapping variables + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! various netCDF ids for files variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), private :: & ! netCDF ids + ncstat, nc_file_id, & + nc_srcgrdsize_id, nc_dstgrdsize_id, & + nc_srcgrdcorn_id, nc_dstgrdcorn_id, & + nc_srcgrdrank_id, nc_dstgrdrank_id, & + nc_srcgrddims_id, nc_dstgrddims_id, & + nc_numlinks_id, nc_numwgts_id, & + nc_srcgrdimask_id, nc_dstgrdimask_id, & + nc_srcgrdcntrlat_id, nc_srcgrdcntrlon_id, & + nc_srcgrdcrnrlat_id, nc_srcgrdcrnrlon_id, & + nc_srcgrdarea_id, nc_srcgrdfrac_id, & + nc_dstgrdcntrlat_id, nc_dstgrdcntrlon_id, & + nc_dstgrdcrnrlat_id, nc_dstgrdcrnrlon_id, & + nc_dstgrdarea_id, nc_dstgrdfrac_id, & + nc_srcgrdadd_id, nc_dstgrdadd_id, nc_rmpmatrix_id + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine read_remap(map_name, interp_file) + +!----------------------------------------------------------------------- +! +! this driver routine reads some global attributes and then +! calls a specific read routine based on file conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: & + interp_file ! filename for remap data + +!----------------------------------------------------------------------- +! +! output variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(out) :: & + map_name ! name for mapping + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: & + map_method & ! character string for map_type + , normalize_opt & ! character string for normalization option + , convention ! character string for output convention + +!----------------------------------------------------------------------- +! +! open file and read some global information +! +!----------------------------------------------------------------------- + + ncstat = nf_open(interp_file, NF_NOWRITE, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + map_name = ' ' + ncstat = nf_get_att_text(nc_file_id, NF_GLOBAL, 'title', & + map_name) + call netcdf_error_handler(ncstat) + + print *,'Reading remapping:',trim(map_name) + print *,'From file:',trim(interp_file) + + !*** + !*** normalization option + !*** + normalize_opt = ' ' + ncstat = nf_get_att_text(nc_file_id, NF_GLOBAL, 'normalization', & + normalize_opt) + call netcdf_error_handler(ncstat) + + select case(normalize_opt) + case ('none') + norm_opt = norm_opt_none + case ('fracarea') + norm_opt = norm_opt_frcarea + case ('destarea') + norm_opt = norm_opt_dstarea + case default + print *,'normalize_opt = ',normalize_opt + stop 'Invalid normalization option' + end select + + !*** + !*** map method + !*** + map_method = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'map_method', & + map_method) + call netcdf_error_handler(ncstat) + + select case(map_method) + case('Conservative remapping') + map_type = map_type_conserv + case('Bilinear remapping') + map_type = map_type_bilinear + case('Distance weighted avg of nearest neighbors') + map_type = map_type_distwgt + case('Bicubic remapping') + map_type = map_type_bicubic + case default + print *,'map_type = ',map_method + stop 'Invalid Map Type' + end select + + !*** + !*** file convention + !*** + convention = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'conventions', & + convention) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! call appropriate read routine based on output convention +! +!----------------------------------------------------------------------- + + select case(convention) + case ('SCRIP') + call read_remap_scrip + case ('NCAR-CSM') + call read_remap_csm + case default + print *,'convention = ',convention + stop 'unknown output file convention' + end select + +!----------------------------------------------------------------------- + + end subroutine read_remap + +!*********************************************************************** + + subroutine read_remap_scrip + +!----------------------------------------------------------------------- +! +! the routine reads a netCDF file to extract remapping info +! in SCRIP format +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + grid1_name & ! grid name for source grid + , grid2_name ! grid name for dest grid + + integer (kind=int_kind) :: & + n ! dummy index + + integer (kind=int_kind), dimension(:), allocatable :: & + grid1_mask_int, & ! integer masks to determine + grid2_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! read some additional global attributes +! +!----------------------------------------------------------------------- + + !*** + !*** source and destination grid names + !*** + + grid1_name = ' ' + grid2_name = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'source_grid', & + grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'dest_grid', & + grid2_name) + call netcdf_error_handler(ncstat) + + print *,' ' + print *,'Remapping between:',trim(grid1_name) + print *,'and ',trim(grid2_name) + print *,' ' + +!----------------------------------------------------------------------- +! +! read dimension information +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_size', & + nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdsize_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_size', & + nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdsize_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_corners', & + nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdcorn_id, & + grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_corners', & + nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdcorn_id, & + grid2_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_rank', & + nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdrank_id, & + grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_rank', & + nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdrank_id, & + grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_links', & + nc_numlinks_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numlinks_id, & + num_links_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts', & + nc_numwgts_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numwgts_id, num_wts) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_dims (grid1_rank), & + grid1_center_lat(grid1_size), & + grid1_center_lon(grid1_size), & + grid1_area (grid1_size), & + grid1_frac (grid1_size), & + grid1_mask (grid1_size), & + grid1_mask_int (grid1_size), & + grid1_corner_lat(grid1_corners, grid1_size), & + grid1_corner_lon(grid1_corners, grid1_size) ) + + allocate( grid2_dims (grid2_rank), & + grid2_center_lat(grid2_size), & + grid2_center_lon(grid2_size), & + grid2_area (grid2_size), & + grid2_frac (grid2_size), & + grid2_mask (grid2_size), & + grid2_mask_int (grid2_size), & + grid2_corner_lat(grid2_corners, grid2_size), & + grid2_corner_lon(grid2_corners, grid2_size) ) + + allocate( grid1_add_map1(num_links_map1), & + grid2_add_map1(num_links_map1), & + wts_map1(num_wts,num_links_map1) ) + +!----------------------------------------------------------------------- +! +! get variable ids +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_dims', & + nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_imask', & + nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_center_lat', & + nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_center_lon', & + nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_corner_lat', & + nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_corner_lon', & + nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_area', & + nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_frac', & + nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_dims', & + nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_imask', & + nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_center_lat', & + nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_center_lon', & + nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_corner_lat', & + nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_corner_lon', & + nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_area', & + nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_frac', & + nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'src_address', & + nc_srcgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_address', & + nc_dstgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'remap_matrix', & + nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! read all variables +! +!----------------------------------------------------------------------- + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrddims_id, & + grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdimask_id, & + grid1_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlat_id, & + grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlon_id, & + grid1_center_lon) + call netcdf_error_handler(ncstat) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcntrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlat_id, & + grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlon_id, & + grid1_corner_lon) + call netcdf_error_handler(ncstat) + + grid1_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcrnrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdarea_id, & + grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdfrac_id, & + grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrddims_id, & + grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdimask_id, & + grid2_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlat_id, & + grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlon_id, & + grid2_center_lon) + call netcdf_error_handler(ncstat) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcntrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlat_id, & + grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlon_id, & + grid2_corner_lon) + call netcdf_error_handler(ncstat) + + grid2_units = ' ' + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcrnrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdarea_id, & + grid2_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdfrac_id, & + grid2_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdadd_id, & + grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdadd_id, & + grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix_id, & + wts_map1) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! initialize logical mask +! +!----------------------------------------------------------------------- + + where (grid1_mask_int == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + where (grid2_mask_int == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(grid1_mask_int, grid2_mask_int) + +!----------------------------------------------------------------------- +! +! close input file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine read_remap_scrip + +!*********************************************************************** + + subroutine read_remap_csm + +!----------------------------------------------------------------------- +! +! the routine reads a netCDF file to extract remapping info +! in NCAR-CSM format +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + grid1_name & ! grid name for source grid + , grid2_name ! grid name for dest grid + + integer (kind=int_kind) :: & + nc_numwgts1_id & ! extra netCDF id for num_wgts > 1 + , nc_rmpmatrix2_id ! extra netCDF id for high-order remap matrix + + real (kind=dbl_kind), dimension(:),allocatable :: & + wts1 ! CSM wants single array for 1st-order wts + + real (kind=dbl_kind), dimension(:,:),allocatable :: & + wts2 ! write remaining weights in different array + + integer (kind=int_kind) :: & + n ! dummy index + + integer (kind=int_kind), dimension(:), allocatable :: & + grid1_mask_int, & ! integer masks to determine + grid2_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! read some additional global attributes +! +!----------------------------------------------------------------------- + + !*** + !*** source and destination grid names + !*** + + grid1_name = ' ' + grid2_name = ' ' + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'domain_a', & + grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text (nc_file_id, NF_GLOBAL, 'domain_b', & + grid2_name) + call netcdf_error_handler(ncstat) + + print *,' ' + print *,'Remapping between:',trim(grid1_name) + print *,'and ',trim(grid2_name) + print *,' ' + +!----------------------------------------------------------------------- +! +! read dimension information +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_dimid(nc_file_id, 'n_a', nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdsize_id, grid1_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'n_b', nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdsize_id, grid2_size) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'nv_a', nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdcorn_id, & + grid1_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'nv_b', nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdcorn_id, & + grid2_corners) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'src_grid_rank', & + nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_srcgrdrank_id, & + grid1_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'dst_grid_rank', & + nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_dstgrdrank_id, & + grid2_rank) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'n_s', & + nc_numlinks_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numlinks_id, & + num_links_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts', & + nc_numwgts_id) + call netcdf_error_handler(ncstat) + ncstat = nf_inq_dimlen(nc_file_id, nc_numwgts_id, num_wts) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_inq_dimid(nc_file_id, 'num_wgts1', & + nc_numwgts1_id) + call netcdf_error_handler(ncstat) + endif + +!----------------------------------------------------------------------- +! +! allocate arrays +! +!----------------------------------------------------------------------- + + allocate( grid1_dims (grid1_rank), & + grid1_center_lat(grid1_size), & + grid1_center_lon(grid1_size), & + grid1_area (grid1_size), & + grid1_frac (grid1_size), & + grid1_mask (grid1_size), & + grid1_mask_int (grid1_size), & + grid1_corner_lat(grid1_corners, grid1_size), & + grid1_corner_lon(grid1_corners, grid1_size) ) + + allocate( grid2_dims (grid2_rank), & + grid2_center_lat(grid2_size), & + grid2_center_lon(grid2_size), & + grid2_area (grid2_size), & + grid2_frac (grid2_size), & + grid2_mask (grid2_size), & + grid2_mask_int (grid2_size), & + grid2_corner_lat(grid2_corners, grid2_size), & + grid2_corner_lon(grid2_corners, grid2_size) ) + + allocate( grid1_add_map1(num_links_map1), & + grid2_add_map1(num_links_map1), & + wts_map1(num_wts,num_links_map1), & + wts1(num_links_map1), & + wts2(num_wts-1,num_links_map1) ) + +!----------------------------------------------------------------------- +! +! get variable ids +! +!----------------------------------------------------------------------- + + ncstat = nf_inq_varid(nc_file_id, 'src_grid_dims', & + nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'mask_a', & + nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yc_a', nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xc_a', nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yv_a', nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xv_a', nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'area_a', nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'frac_a', nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'dst_grid_dims', & + nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'mask_b', & + nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yc_b', nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xc_b', nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'yv_b', nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'xv_b', nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'area_b', nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'frac_b', nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'col', nc_srcgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'row', nc_dstgrdadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_inq_varid(nc_file_id, 'S', nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_inq_varid(nc_file_id, 'S2', nc_rmpmatrix2_id) + call netcdf_error_handler(ncstat) + endif + +!----------------------------------------------------------------------- +! +! read all variables +! +!----------------------------------------------------------------------- + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrddims_id, & + grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdimask_id, & + grid1_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlat_id, & + grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcntrlon_id, & + grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcntrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_center_lat = grid1_center_lat*deg2rad + grid1_center_lon = grid1_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlat_id, & + grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdcrnrlon_id, & + grid1_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_srcgrdcrnrlat_id, 'units', & + grid1_units) + call netcdf_error_handler(ncstat) + + select case (grid1_units(1:7)) + case ('degrees') + grid1_corner_lat = grid1_corner_lat*deg2rad + grid1_corner_lon = grid1_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid1 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdarea_id, & + grid1_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_srcgrdfrac_id, & + grid1_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrddims_id, & + grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdimask_id, & + grid2_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlat_id, & + grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcntrlon_id, & + grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcntrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_center_lat = grid2_center_lat*deg2rad + grid2_center_lon = grid2_center_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 center lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlat_id, & + grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdcrnrlon_id, & + grid2_corner_lon) + call netcdf_error_handler(ncstat) + + + ncstat = nf_get_att_text(nc_file_id, nc_dstgrdcrnrlat_id, 'units', & + grid2_units) + call netcdf_error_handler(ncstat) + + select case (grid2_units(1:7)) + case ('degrees') + grid2_corner_lat = grid2_corner_lat*deg2rad + grid2_corner_lon = grid2_corner_lon*deg2rad + case ('radians') + !*** no conversion necessary + case default + print *,'unknown units supplied for grid2 corner lat/lon: ' + print *,'proceeding assuming radians' + end select + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdarea_id, & + grid2_area) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_dstgrdfrac_id, & + grid2_frac) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_srcgrdadd_id, & + grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_int(nc_file_id, nc_dstgrdadd_id, & + grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix_id, & + wts1) + wts_map1(1,:) = wts1 + deallocate(wts1) + + if (num_wts > 1) then + ncstat = nf_get_var_double(nc_file_id, nc_rmpmatrix2_id, & + wts2) + wts_map1(2:,:) = wts2 + deallocate(wts2) + endif + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! initialize logical mask +! +!----------------------------------------------------------------------- + + where (grid1_mask_int == 1) + grid1_mask = .true. + elsewhere + grid1_mask = .false. + endwhere + where (grid2_mask_int == 1) + grid2_mask = .true. + elsewhere + grid2_mask = .false. + endwhere + deallocate(grid1_mask_int, grid2_mask_int) + +!----------------------------------------------------------------------- +! +! close input file +! +!----------------------------------------------------------------------- + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine read_remap_csm + +!*********************************************************************** + + end module remap_read + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_vars.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_vars.f90 new file mode 100644 index 0000000000000000000000000000000000000000..950f63e232f4f7c1312fd1deabe7059694f502c3 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_vars.f90 @@ -0,0 +1,302 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this module contains necessary variables for remapping between +! two grids. also routines for resizing and initializing these +! variables. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_vars.f,v 1.5 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_vars + + use kinds_mod + use constants + use grids + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), parameter :: & + norm_opt_none = 1 & + , norm_opt_dstarea = 2 & + , norm_opt_frcarea = 3 + + integer (kind=int_kind), parameter :: & + map_type_conserv = 1 & + , map_type_bilinear = 2 & + , map_type_bicubic = 3 & + , map_type_distwgt = 4 + + integer (kind=int_kind), save :: & + max_links_map1 & ! current size of link arrays + , num_links_map1 & ! actual number of links for remapping + , max_links_map2 & ! current size of link arrays + , num_links_map2 & ! actual number of links for remapping + , num_maps & ! num of remappings for this grid pair + , num_wts & ! num of weights used in remapping + , map_type & ! identifier for remapping method + , norm_opt & ! option for normalization (conserv only) + , resize_increment ! default amount to increase array size + + integer (kind=int_kind), dimension(:), allocatable, save :: & + grid1_add_map1, & ! grid1 address for each link in mapping 1 + grid2_add_map1, & ! grid2 address for each link in mapping 1 + grid1_add_map2, & ! grid1 address for each link in mapping 2 + grid2_add_map2 ! grid2 address for each link in mapping 2 + + real (kind=dbl_kind), dimension(:,:), allocatable, save :: & + wts_map1, & ! map weights for each link (num_wts,max_links) + wts_map2 ! map weights for each link (num_wts,max_links) + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine init_remap_vars + +!----------------------------------------------------------------------- +! +! this routine initializes some variables and provides an initial +! allocation of arrays (fairly large so frequent resizing +! unnecessary). +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! determine the number of weights +! +!----------------------------------------------------------------------- + + select case (map_type) + case(map_type_conserv) + num_wts = 3 + case(map_type_bilinear) + num_wts = 1 + case(map_type_bicubic) + num_wts = 4 + case(map_type_distwgt) + num_wts = 1 + end select + +!----------------------------------------------------------------------- +! +! initialize num_links and set max_links to four times the largest +! of the destination grid sizes initially (can be changed later). +! set a default resize increment to increase the size of link +! arrays if the number of links exceeds the initial size +! +!----------------------------------------------------------------------- + + num_links_map1 = 0 + max_links_map1 = 4*grid2_size + if (num_maps > 1) then + num_links_map2 = 0 + max_links_map1 = max(4*grid1_size,4*grid2_size) + max_links_map2 = max_links_map1 + endif + + resize_increment = 0.1*max(grid1_size,grid2_size) + +!----------------------------------------------------------------------- +! +! allocate address and weight arrays for mapping 1 +! +!----------------------------------------------------------------------- + + allocate (grid1_add_map1(max_links_map1), & + grid2_add_map1(max_links_map1), & + wts_map1(num_wts, max_links_map1)) + +!----------------------------------------------------------------------- +! +! allocate address and weight arrays for mapping 2 if necessary +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + allocate (grid1_add_map2(max_links_map2), & + grid2_add_map2(max_links_map2), & + wts_map2(num_wts, max_links_map2)) + endif + +!----------------------------------------------------------------------- + + end subroutine init_remap_vars + +!*********************************************************************** + + subroutine resize_remap_vars(nmap, increment) + +!----------------------------------------------------------------------- +! +! this routine resizes remapping arrays by increasing(decreasing) +! the max_links by increment +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + nmap, & ! identifies which mapping array to resize + increment ! the number of links to add(subtract) to arrays + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: & + ierr, & ! error flag + mxlinks ! size of link arrays + + integer (kind=int_kind), dimension(:), allocatable :: & + add1_tmp, & ! temp array for resizing address arrays + add2_tmp ! temp array for resizing address arrays + + real (kind=dbl_kind), dimension(:,:), allocatable :: & + wts_tmp ! temp array for resizing weight arrays + +!----------------------------------------------------------------------- +! +! resize map 1 arrays if required. +! +!----------------------------------------------------------------------- + + select case (nmap) + case(1) + + !*** + !*** allocate temporaries to hold original values + !*** + + mxlinks = size(grid1_add_map1) + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), & + wts_tmp(num_wts,mxlinks)) + + add1_tmp = grid1_add_map1 + add2_tmp = grid2_add_map1 + wts_tmp = wts_map1 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + deallocate (grid1_add_map1, grid2_add_map1, wts_map1) + max_links_map1 = mxlinks + increment + allocate (grid1_add_map1(max_links_map1), & + grid2_add_map1(max_links_map1), & + wts_map1(num_wts,max_links_map1)) + + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + + mxlinks = min(mxlinks, max_links_map1) + grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks) + grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks) + wts_map1 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + deallocate(add1_tmp, add2_tmp, wts_tmp) + +!----------------------------------------------------------------------- +! +! resize map 2 arrays if required. +! +!----------------------------------------------------------------------- + + case(2) + + !*** + !*** allocate temporaries to hold original values + !*** + + mxlinks = size(grid1_add_map2) + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), & + wts_tmp(num_wts,mxlinks),stat=ierr) + if (ierr .ne. 0) then + print *,'error allocating temps in resize: ',ierr + stop + endif + + add1_tmp = grid1_add_map2 + add2_tmp = grid2_add_map2 + wts_tmp = wts_map2 + + !*** + !*** deallocate originals and increment max_links then + !*** reallocate arrays at new size + !*** + + deallocate (grid1_add_map2, grid2_add_map2, wts_map2) + max_links_map2 = mxlinks + increment + allocate (grid1_add_map2(max_links_map2), & + grid2_add_map2(max_links_map2), & + wts_map2(num_wts,max_links_map2),stat=ierr) + if (ierr .ne. 0) then + print *,'error allocating new arrays in resize: ',ierr + stop + endif + + + !*** + !*** restore original values from temp arrays and + !*** deallocate temps + !*** + + mxlinks = min(mxlinks, max_links_map2) + grid1_add_map2(1:mxlinks) = add1_tmp (1:mxlinks) + grid2_add_map2(1:mxlinks) = add2_tmp (1:mxlinks) + wts_map2 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) + deallocate(add1_tmp, add2_tmp, wts_tmp) + + end select + +!----------------------------------------------------------------------- + + end subroutine resize_remap_vars + +!*********************************************************************** + + end module remap_vars + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/remap_write.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_write.f90 new file mode 100644 index 0000000000000000000000000000000000000000..10af9fbde667e080913d147a90d601918bd2a49d --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/remap_write.f90 @@ -0,0 +1,1763 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains routines for writing the remapping data to +! a file. Before writing the data for each mapping, the links are +! sorted by destination grid address. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: remap_write.f,v 1.7 2001/08/21 21:06:42 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module remap_write + +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common scalar constants + use grids ! module containing grid information + use remap_vars ! module containing remap information + use netcdf_mod ! module with netCDF stuff + + implicit none + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character(char_len), private :: & + map_method & ! character string for map_type + , normalize_opt & ! character string for normalization option + , history & ! character string for history information + , convention ! character string for output convention + + character(8), private :: & + cdate ! character date string + + integer (kind=int_kind), dimension(:), allocatable, private :: & + src_mask_int & ! integer masks to determine + , dst_mask_int ! cells that participate in map + +!----------------------------------------------------------------------- +! +! various netCDF identifiers used by output routines +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), private :: & + ncstat & ! error flag for netCDF calls + , nc_file_id & ! id for netCDF file + , nc_srcgrdsize_id & ! id for source grid size + , nc_dstgrdsize_id & ! id for destination grid size + , nc_srcgrdcorn_id & ! id for number of source grid corners + , nc_dstgrdcorn_id & ! id for number of dest grid corners + , nc_srcgrdrank_id & ! id for source grid rank + , nc_dstgrdrank_id & ! id for dest grid rank + , nc_numlinks_id & ! id for number of links in mapping + , nc_numwgts_id & ! id for number of weights for mapping + , nc_srcgrddims_id & ! id for source grid dimensions + , nc_dstgrddims_id & ! id for dest grid dimensions + , nc_srcgrdcntrlat_id & ! id for source grid center latitude + , nc_dstgrdcntrlat_id & ! id for dest grid center latitude + , nc_srcgrdcntrlon_id & ! id for source grid center longitude + , nc_dstgrdcntrlon_id & ! id for dest grid center longitude + , nc_srcgrdimask_id & ! id for source grid mask + , nc_dstgrdimask_id & ! id for dest grid mask + , nc_srcgrdcrnrlat_id & ! id for latitude of source grid corners + , nc_srcgrdcrnrlon_id & ! id for longitude of source grid corners + , nc_dstgrdcrnrlat_id & ! id for latitude of dest grid corners + , nc_dstgrdcrnrlon_id & ! id for longitude of dest grid corners + , nc_srcgrdarea_id & ! id for area of source grid cells + , nc_dstgrdarea_id & ! id for area of dest grid cells + , nc_srcgrdfrac_id & ! id for area fraction on source grid + , nc_dstgrdfrac_id & ! id for area fraction on dest grid + , nc_srcadd_id & ! id for map source address + , nc_dstadd_id & ! id for map destination address + , nc_rmpmatrix_id ! id for remapping matrix + + integer (kind=int_kind), dimension(2), private :: & + nc_dims2_id ! netCDF ids for 2d array dims + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine write_remap(map1_name, map2_name, & + interp_file1, interp_file2, output_opt) + +!----------------------------------------------------------------------- +! +! calls correct output routine based on output format choice +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: & + map1_name, & ! name for mapping grid1 to grid2 + map2_name, & ! name for mapping grid2 to grid1 + interp_file1, & ! filename for map1 remap data + interp_file2, & ! filename for map2 remap data + output_opt ! option for output conventions + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! define some common variables to be used in all routines +! +!----------------------------------------------------------------------- + + select case(norm_opt) + case (norm_opt_none) + normalize_opt = 'none' + case (norm_opt_frcarea) + normalize_opt = 'fracarea' + case (norm_opt_dstarea) + normalize_opt = 'destarea' + end select + + select case(map_type) + case(map_type_conserv) + map_method = 'Conservative remapping' + case(map_type_bilinear) + map_method = 'Bilinear remapping' + case(map_type_distwgt) + map_method = 'Distance weighted avg of nearest neighbors' + case(map_type_bicubic) + map_method = 'Bicubic remapping' + case default + stop 'Invalid Map Type' + end select + + call date_and_time(date=cdate) + write (history,1000) cdate(5:6),cdate(7:8),cdate(1:4) + 1000 format('Created: ',a2,'-',a2,'-',a4) + +!----------------------------------------------------------------------- +! +! sort address and weight arrays +! +!----------------------------------------------------------------------- + + call sort_add(grid2_add_map1, grid1_add_map1, wts_map1) + if (num_maps > 1) then + call sort_add(grid1_add_map2, grid2_add_map2, wts_map2) + endif + +!----------------------------------------------------------------------- +! +! call appropriate output routine +! +!----------------------------------------------------------------------- + + select case(output_opt) + case ('scrip') + call write_remap_scrip(map1_name, interp_file1, 1) + case ('ncar-csm') + call write_remap_csm (map1_name, interp_file1, 1) + case default + stop 'unknown output file convention' + end select + +!----------------------------------------------------------------------- +! +! call appropriate output routine for second mapping if required +! +!----------------------------------------------------------------------- + + if (num_maps > 1) then + select case(output_opt) + case ('scrip') + call write_remap_scrip(map2_name, interp_file2, 2) + case ('ncar-csm') + call write_remap_csm (map2_name, interp_file2, 2) + case default + stop 'unknown output file convention' + end select + endif + +!----------------------------------------------------------------------- + + end subroutine write_remap + +!*********************************************************************** + + subroutine write_remap_scrip(map_name, interp_file, direction) + +!----------------------------------------------------------------------- +! +! writes remap data to a netCDF file using SCRIP conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: & + map_name & ! name for mapping + , interp_file ! filename for remap data + + integer (kind=int_kind), intent(in) :: & + direction ! direction of map (1=grid1 to grid2 + ! 2=grid2 to grid1) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: & + grid1_ctmp & ! character temp for grid1 names + , grid2_ctmp ! character temp for grid2 names + + integer (kind=int_kind) :: & + itmp1 & ! integer temp + , itmp2 & ! integer temp + , itmp3 & ! integer temp + , itmp4 ! integer temp + +!----------------------------------------------------------------------- +! +! create netCDF file for mapping and define some global attributes +! +!----------------------------------------------------------------------- + + ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title', & + len_trim(map_name), map_name) + call netcdf_error_handler(ncstat) + + !*** + !*** normalization option + !*** + ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization', & + len_trim(normalize_opt), normalize_opt) + call netcdf_error_handler(ncstat) + + !*** + !*** map method + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method', & + len_trim(map_method), map_method) + call netcdf_error_handler(ncstat) + + !*** + !*** history + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history', & + len_trim(history), history) + call netcdf_error_handler(ncstat) + + !*** + !*** file convention + !*** + convention = 'SCRIP' + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions', & + len_trim(convention), convention) + call netcdf_error_handler(ncstat) + + !*** + !*** source and destination grid names + !*** + + if (direction == 1) then + grid1_ctmp = 'source_grid' + grid2_ctmp = 'dest_grid' + else + grid1_ctmp = 'dest_grid' + grid2_ctmp = 'source_grid' + endif + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp), & + len_trim(grid1_name), grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp), & + len_trim(grid2_name), grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! prepare netCDF dimension info +! +!----------------------------------------------------------------------- + + !*** + !*** define grid size dimensions + !*** + + if (direction == 1) then + itmp1 = grid1_size + itmp2 = grid2_size + else + itmp1 = grid2_size + itmp2 = grid1_size + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_size', itmp1, & + nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_size', itmp2, & + nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + if (direction == 1) then + itmp1 = grid1_corners + itmp2 = grid2_corners + else + itmp1 = grid2_corners + itmp2 = grid1_corners + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_corners', & + itmp1, nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_corners', & + itmp2, nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + if (direction == 1) then + itmp1 = grid1_rank + itmp2 = grid2_rank + else + itmp1 = grid2_rank + itmp2 = grid1_rank + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', & + itmp1, nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', & + itmp2, nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define map size dimensions + !*** + + if (direction == 1) then + itmp1 = num_links_map1 + else + itmp1 = num_links_map2 + endif + + ncstat = nf_def_dim (nc_file_id, 'num_links', & + itmp1, nc_numlinks_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'num_wgts', & + num_wts, nc_numwgts_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid dimensions + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT, & + 1, nc_srcgrdrank_id, nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT, & + 1, nc_dstgrdrank_id, nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! define all arrays for netCDF descriptors +! +!----------------------------------------------------------------------- + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_center_lat', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lat', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_center_lon', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lon', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner lat/lon arrays + !*** + + nc_dims2_id(1) = nc_srcgrdcorn_id + nc_dims2_id(2) = nc_srcgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lat', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lon', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_dstgrdcorn_id + nc_dims2_id(2) = nc_dstgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lat', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lon', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define units for all coordinate arrays + !*** + + if (direction == 1) then + grid1_ctmp = grid1_units + grid2_ctmp = grid2_units + else + grid1_ctmp = grid2_units + grid2_ctmp = grid1_units + endif + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_imask', NF_INT, & + 1, nc_srcgrdsize_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_imask', NF_INT, & + 1, nc_dstgrdsize_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_area', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, & + 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_area', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, & + 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_frac', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_frac', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define mapping arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'src_address', & + NF_INT, 1, nc_numlinks_id, & + nc_srcadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_address', & + NF_INT, 1, nc_numlinks_id, & + nc_dstadd_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_numwgts_id + nc_dims2_id(2) = nc_numlinks_id + + ncstat = nf_def_var (nc_file_id, 'remap_matrix', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! compute integer masks +! +!----------------------------------------------------------------------- + + if (direction == 1) then + allocate (src_mask_int(grid1_size), & + dst_mask_int(grid2_size)) + + where (grid2_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid1_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + else + allocate (src_mask_int(grid2_size), & + dst_mask_int(grid1_size)) + + where (grid1_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid2_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + endif + +!----------------------------------------------------------------------- +! +! change units of lat/lon coordinates if input units different +! from radians +! +!----------------------------------------------------------------------- + + if (grid1_units(1:7) == 'degrees' .and. direction == 1) then + grid1_center_lat = grid1_center_lat/deg2rad + grid1_center_lon = grid1_center_lon/deg2rad + grid1_corner_lat = grid1_corner_lat/deg2rad + grid1_corner_lon = grid1_corner_lon/deg2rad + endif + + if (grid2_units(1:7) == 'degrees' .and. direction == 1) then + grid2_center_lat = grid2_center_lat/deg2rad + grid2_center_lon = grid2_center_lon/deg2rad + grid2_corner_lat = grid2_corner_lat/deg2rad + grid2_corner_lon = grid2_corner_lon/deg2rad + endif + +!----------------------------------------------------------------------- +! +! write mapping data +! +!----------------------------------------------------------------------- + + if (direction == 1) then + itmp1 = nc_srcgrddims_id + itmp2 = nc_dstgrddims_id + else + itmp2 = nc_srcgrddims_id + itmp1 = nc_dstgrddims_id + endif + + ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, & + src_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id, & + dst_mask_int) + call netcdf_error_handler(ncstat) + + deallocate(src_mask_int, dst_mask_int) + + if (direction == 1) then + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + else + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + else + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_srcgrdarea_id + itmp2 = nc_srcgrdfrac_id + itmp3 = nc_dstgrdarea_id + itmp4 = nc_dstgrdfrac_id + else + itmp1 = nc_dstgrdarea_id + itmp2 = nc_dstgrdfrac_id + itmp3 = nc_srcgrdarea_id + itmp4 = nc_srcgrdfrac_id + endif + + if (luse_grid1_area) then + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, & + grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, & + grid2_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts_map1) + call netcdf_error_handler(ncstat) + else + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, & + grid2_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, & + grid1_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts_map2) + call netcdf_error_handler(ncstat) + endif + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine write_remap_scrip + +!*********************************************************************** + + subroutine write_remap_csm(map_name, interp_file, direction) + +!----------------------------------------------------------------------- +! +! writes remap data to a netCDF file using NCAR-CSM conventions +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! input variables +! +!----------------------------------------------------------------------- + + character(char_len), intent(in) :: & + map_name & ! name for mapping + , interp_file ! filename for remap data + + integer (kind=int_kind), intent(in) :: & + direction ! direction of map (1=grid1 to grid2 + ! 2=grid2 to grid1) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character(char_len) :: & + grid1_ctmp & ! character temp for grid1 names + , grid2_ctmp ! character temp for grid2 names + + integer (kind=int_kind) :: & + itmp1 & ! integer temp + , itmp2 & ! integer temp + , itmp3 & ! integer temp + , itmp4 & ! integer temp + , nc_numwgts1_id & ! extra netCDF id for additional weights + , nc_src_isize_id & ! extra netCDF id for ni_a + , nc_src_jsize_id & ! extra netCDF id for nj_a + , nc_dst_isize_id & ! extra netCDF id for ni_b + , nc_dst_jsize_id & ! extra netCDF id for nj_b + , nc_rmpmatrix2_id ! extra netCDF id for high-order remap matrix + + real (kind=dbl_kind), dimension(:),allocatable :: & + wts1 ! CSM wants single array for 1st-order wts + + real (kind=dbl_kind), dimension(:,:),allocatable :: & + wts2 ! write remaining weights in different array + +!----------------------------------------------------------------------- +! +! create netCDF file for mapping and define some global attributes +! +!----------------------------------------------------------------------- + + ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id) + call netcdf_error_handler(ncstat) + + !*** + !*** map name + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title', & + len_trim(map_name), map_name) + call netcdf_error_handler(ncstat) + + !*** + !*** normalization option + !*** + ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization', & + len_trim(normalize_opt), normalize_opt) + call netcdf_error_handler(ncstat) + + !*** + !*** map method + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method', & + len_trim(map_method), map_method) + call netcdf_error_handler(ncstat) + + !*** + !*** history + !*** + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history', & + len_trim(history), history) + call netcdf_error_handler(ncstat) + + !*** + !*** file convention + !*** + convention = 'NCAR-CSM' + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions', & + len_trim(convention), convention) + call netcdf_error_handler(ncstat) + + !*** + !*** source and destination grid names + !*** + + if (direction == 1) then + grid1_ctmp = 'domain_a' + grid2_ctmp = 'domain_b' + else + grid1_ctmp = 'domain_b' + grid2_ctmp = 'domain_a' + endif + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp), & + len_trim(grid1_name), grid1_name) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp), & + len_trim(grid2_name), grid2_name) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! prepare netCDF dimension info +! +!----------------------------------------------------------------------- + + !*** + !*** define grid size dimensions + !*** + + if (direction == 1) then + itmp1 = grid1_size + itmp2 = grid2_size + else + itmp1 = grid2_size + itmp2 = grid1_size + endif + + ncstat = nf_def_dim (nc_file_id, 'n_a', itmp1, nc_srcgrdsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'n_b', itmp2, nc_dstgrdsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner dimension + !*** + + if (direction == 1) then + itmp1 = grid1_corners + itmp2 = grid2_corners + else + itmp1 = grid2_corners + itmp2 = grid1_corners + endif + + ncstat = nf_def_dim (nc_file_id, 'nv_a', itmp1, nc_srcgrdcorn_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nv_b', itmp2, nc_dstgrdcorn_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid rank dimension + !*** + + if (direction == 1) then + itmp1 = grid1_rank + itmp2 = grid2_rank + else + itmp1 = grid2_rank + itmp2 = grid1_rank + endif + + ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', & + itmp1, nc_srcgrdrank_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', & + itmp2, nc_dstgrdrank_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define first two dims as if 2-d cartesian domain + !*** + + if (direction == 1) then + itmp1 = grid1_dims(1) + if (grid1_rank > 1) then + itmp2 = grid1_dims(2) + else + itmp2 = 0 + endif + itmp3 = grid2_dims(1) + if (grid2_rank > 1) then + itmp4 = grid2_dims(2) + else + itmp4 = 0 + endif + else + itmp1 = grid2_dims(1) + if (grid2_rank > 1) then + itmp2 = grid2_dims(2) + else + itmp2 = 0 + endif + itmp3 = grid1_dims(1) + if (grid1_rank > 1) then + itmp4 = grid1_dims(2) + else + itmp4 = 0 + endif + endif + + ncstat = nf_def_dim (nc_file_id, 'ni_a', itmp1, nc_src_isize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nj_a', itmp2, nc_src_jsize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'ni_b', itmp3, nc_dst_isize_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'nj_b', itmp4, nc_dst_jsize_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define map size dimensions + !*** + + if (direction == 1) then + itmp1 = num_links_map1 + else + itmp1 = num_links_map2 + endif + + ncstat = nf_def_dim (nc_file_id, 'n_s', itmp1, nc_numlinks_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_dim (nc_file_id, 'num_wgts', & + num_wts, nc_numwgts_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + ncstat = nf_def_dim (nc_file_id, 'num_wgts1', & + num_wts-1, nc_numwgts1_id) + call netcdf_error_handler(ncstat) + endif + + !*** + !*** define grid dimensions + !*** + + ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT, & + 1, nc_srcgrdrank_id, nc_srcgrddims_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT, & + 1, nc_dstgrdrank_id, nc_dstgrddims_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! define all arrays for netCDF descriptors +! +!----------------------------------------------------------------------- + + !*** + !*** define grid center latitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'yc_a', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'yc_b', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdcntrlat_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid center longitude array + !*** + + ncstat = nf_def_var (nc_file_id, 'xc_a', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xc_b', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdcntrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid corner lat/lon arrays + !*** + + nc_dims2_id(1) = nc_srcgrdcorn_id + nc_dims2_id(2) = nc_srcgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'yv_a', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_srcgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xv_a', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_srcgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + nc_dims2_id(1) = nc_dstgrdcorn_id + nc_dims2_id(2) = nc_dstgrdsize_id + + ncstat = nf_def_var (nc_file_id, 'yv_b', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_dstgrdcrnrlat_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'xv_b', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_dstgrdcrnrlon_id) + call netcdf_error_handler(ncstat) + + !*** + !*** CSM wants all in degrees + !*** + + grid1_units = 'degrees' + grid2_units = 'degrees' + + if (direction == 1) then + grid1_ctmp = grid1_units + grid2_ctmp = grid2_units + else + grid1_ctmp = grid2_units + grid2_ctmp = grid1_units + endif + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, & + 'units', 7, grid1_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, & + 'units', 7, grid2_ctmp) + call netcdf_error_handler(ncstat) + + !*** + !*** define grid mask + !*** + + ncstat = nf_def_var (nc_file_id, 'mask_a', NF_INT, & + 1, nc_srcgrdsize_id, nc_srcgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'mask_b', NF_INT, & + 1, nc_dstgrdsize_id, nc_dstgrdimask_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid area arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'area_a', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, & + 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'area_b', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdarea_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, & + 'units', 14, 'square radians') + call netcdf_error_handler(ncstat) + + !*** + !*** define grid fraction arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'frac_a', & + NF_DOUBLE, 1, nc_srcgrdsize_id, & + nc_srcgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'frac_b', & + NF_DOUBLE, 1, nc_dstgrdsize_id, & + nc_dstgrdfrac_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, & + 'units', 8, 'unitless') + call netcdf_error_handler(ncstat) + + !*** + !*** define mapping arrays + !*** + + ncstat = nf_def_var (nc_file_id, 'col', & + NF_INT, 1, nc_numlinks_id, & + nc_srcadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'row', & + NF_INT, 1, nc_numlinks_id, & + nc_dstadd_id) + call netcdf_error_handler(ncstat) + + ncstat = nf_def_var (nc_file_id, 'S', & + NF_DOUBLE, 1, nc_numlinks_id, & + nc_rmpmatrix_id) + call netcdf_error_handler(ncstat) + + if (num_wts > 1) then + nc_dims2_id(1) = nc_numwgts1_id + nc_dims2_id(2) = nc_numlinks_id + + ncstat = nf_def_var (nc_file_id, 'S2', & + NF_DOUBLE, 2, nc_dims2_id, & + nc_rmpmatrix2_id) + call netcdf_error_handler(ncstat) + endif + + !*** + !*** end definition stage + !*** + + ncstat = nf_enddef(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- +! +! compute integer masks +! +!----------------------------------------------------------------------- + + if (direction == 1) then + allocate (src_mask_int(grid1_size), & + dst_mask_int(grid2_size)) + + where (grid2_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid1_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + else + allocate (src_mask_int(grid2_size), & + dst_mask_int(grid1_size)) + + where (grid1_mask) + dst_mask_int = 1 + elsewhere + dst_mask_int = 0 + endwhere + + where (grid2_mask) + src_mask_int = 1 + elsewhere + src_mask_int = 0 + endwhere + endif + +!----------------------------------------------------------------------- +! +! change units of lat/lon coordinates if input units different +! from radians. if this is the second mapping, the conversion has +! alread been done. +! +!----------------------------------------------------------------------- + + if (grid1_units(1:7) == 'degrees' .and. direction == 1) then + grid1_center_lat = grid1_center_lat/deg2rad + grid1_center_lon = grid1_center_lon/deg2rad + grid1_corner_lat = grid1_corner_lat/deg2rad + grid1_corner_lon = grid1_corner_lon/deg2rad + endif + + if (grid2_units(1:7) == 'degrees' .and. direction == 1) then + grid2_center_lat = grid2_center_lat/deg2rad + grid2_center_lon = grid2_center_lon/deg2rad + grid2_corner_lat = grid2_corner_lat/deg2rad + grid2_corner_lon = grid2_corner_lon/deg2rad + endif + +!----------------------------------------------------------------------- +! +! write mapping data +! +!----------------------------------------------------------------------- + + if (direction == 1) then + itmp1 = nc_srcgrddims_id + itmp2 = nc_dstgrddims_id + else + itmp2 = nc_srcgrddims_id + itmp1 = nc_dstgrddims_id + endif + + ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, & + src_mask_int) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id, & + dst_mask_int) + call netcdf_error_handler(ncstat) + + deallocate(src_mask_int, dst_mask_int) + + if (direction == 1) then + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + else + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid1_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid1_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_dstgrdcntrlat_id + itmp2 = nc_dstgrdcntrlon_id + itmp3 = nc_dstgrdcrnrlat_id + itmp4 = nc_dstgrdcrnrlon_id + else + itmp1 = nc_srcgrdcntrlat_id + itmp2 = nc_srcgrdcntrlon_id + itmp3 = nc_srcgrdcrnrlat_id + itmp4 = nc_srcgrdcrnrlon_id + endif + + ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_corner_lat) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_corner_lon) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + itmp1 = nc_srcgrdarea_id + itmp2 = nc_srcgrdfrac_id + itmp3 = nc_dstgrdarea_id + itmp4 = nc_dstgrdfrac_id + else + itmp1 = nc_dstgrdarea_id + itmp2 = nc_dstgrdfrac_id + itmp3 = nc_srcgrdarea_id + itmp4 = nc_srcgrdfrac_id + endif + + if (luse_grid1_area) then + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in) + else + ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac) + call netcdf_error_handler(ncstat) + + if (luse_grid2_area) then + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + else + ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area) + endif + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac) + call netcdf_error_handler(ncstat) + + if (direction == 1) then + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, & + grid1_add_map1) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, & + grid2_add_map1) + call netcdf_error_handler(ncstat) + + if (num_wts == 1) then + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts_map1) + call netcdf_error_handler(ncstat) + else + allocate(wts1(num_links_map1),wts2(num_wts-1,num_links_map1)) + + wts1 = wts_map1(1,:) + wts2 = wts_map1(2:,:) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts1) + call netcdf_error_handler(ncstat) + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, & + wts2) + call netcdf_error_handler(ncstat) + deallocate(wts1,wts2) + endif + else + ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, & + grid2_add_map2) + call netcdf_error_handler(ncstat) + + ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, & + grid1_add_map2) + call netcdf_error_handler(ncstat) + + if (num_wts == 1) then + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts_map2) + call netcdf_error_handler(ncstat) + else + allocate(wts1(num_links_map2),wts2(num_wts-1,num_links_map2)) + + wts1 = wts_map2(1,:) + wts2 = wts_map2(2:,:) + + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, & + wts1) + call netcdf_error_handler(ncstat) + ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, & + wts2) + call netcdf_error_handler(ncstat) + deallocate(wts1,wts2) + endif + endif + + ncstat = nf_close(nc_file_id) + call netcdf_error_handler(ncstat) + +!----------------------------------------------------------------------- + + end subroutine write_remap_csm + +!*********************************************************************** + + subroutine sort_add(add1, add2, weights) + +!----------------------------------------------------------------------- +! +! this routine sorts address and weight arrays based on the +! destination address with the source address as a secondary +! sorting criterion. the method is a standard heap sort. +! +!----------------------------------------------------------------------- + + use kinds_mod ! defines common data types + use constants ! defines common scalar constants + + implicit none + +!----------------------------------------------------------------------- +! +! Input and Output arrays +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(inout), dimension(:) :: & + add1, & ! destination address array (num_links) + add2 ! source address array + + real (kind=dbl_kind), intent(inout), dimension(:,:) :: & + weights ! remapping weights (num_wts, num_links) + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: & + num_links, & ! num of links for this mapping + num_wts, & ! num of weights for this mapping + add1_tmp, add2_tmp, & ! temp for addresses during swap + nwgt, & + lvl, final_lvl, & ! level indexes for heap sort levels + chk_lvl1, chk_lvl2, max_lvl + + real (kind=dbl_kind), dimension(SIZE(weights,DIM=1)) :: & + wgttmp ! temp for holding wts during swap + +!----------------------------------------------------------------------- +! +! determine total number of links to sort and number of weights +! +!----------------------------------------------------------------------- + + num_links = SIZE(add1) + num_wts = SIZE(weights, DIM=1) + +!----------------------------------------------------------------------- +! +! start at the lowest level (N/2) of the tree and sift lower +! values to the bottom of the tree, promoting the larger numbers +! +!----------------------------------------------------------------------- + + do lvl=num_links/2,1,-1 + + final_lvl = lvl + add1_tmp = add1(lvl) + add2_tmp = add2(lvl) + wgttmp(:) = weights(:,lvl) + + !*** + !*** loop until proper level is found for this link, or reach + !*** bottom + !*** + + sift_loop1: do + + !*** + !*** find the largest of the two daughters + !*** + + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1 + + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & + ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & + (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif + + !*** + !*** if the parent is greater than both daughters, + !*** the correct level has been found + !*** + + if ((add1_tmp .GT. add1(max_lvl)) .OR. & + ((add1_tmp .EQ. add1(max_lvl)) .AND. & + (add2_tmp .GT. add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl > num_links) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + endif + endif + end do sift_loop1 + end do + +!----------------------------------------------------------------------- +! +! now that the heap has been sorted, strip off the top (largest) +! value and promote the values below +! +!----------------------------------------------------------------------- + + do lvl=num_links,3,-1 + + !*** + !*** move the top value and insert it into the correct place + !*** + + add1_tmp = add1(lvl) + add1(lvl) = add1(1) + + add2_tmp = add2(lvl) + add2(lvl) = add2(1) + + wgttmp(:) = weights(:,lvl) + weights(:,lvl) = weights(:,1) + + !*** + !*** as above this loop sifts the tmp values down until proper + !*** level is reached + !*** + + final_lvl = 1 + + sift_loop2: do + + !*** + !*** find the largest of the two daughters + !*** + + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1 + + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & + ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & + (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif + + !*** + !*** if the parent is greater than both daughters, + !*** the correct level has been found + !*** + + if ((add1_tmp > add1(max_lvl)) .OR. & + ((add1_tmp == add1(max_lvl)) .AND. & + (add2_tmp > add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl >= lvl) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + endif + endif + end do sift_loop2 + end do + + !*** + !*** swap the last two entries + !*** + + + add1_tmp = add1(2) + add1(2) = add1(1) + add1(1) = add1_tmp + + add2_tmp = add2(2) + add2(2) = add2(1) + add2(1) = add2_tmp + + wgttmp (:) = weights(:,2) + weights(:,2) = weights(:,1) + weights(:,1) = wgttmp (:) + +!----------------------------------------------------------------------- + + end subroutine sort_add + +!*********************************************************************** + + end module remap_write + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scrip.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scrip.F90 new file mode 100644 index 0000000000000000000000000000000000000000..291a657feb26011b5f83b129674fb764265e7438 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scrip.F90 @@ -0,0 +1,232 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This routine is the driver for computing the addresses and weights +! for interpolating between two grids on a sphere. +! +! Modified slightly to get name of namelist file from command line - sga 2/12/05 +! +!----------------------------------------------------------------------- +! +! CVS:$Id: scrip.f,v 1.6 2001/08/21 21:06:44 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + program scrip + +!----------------------------------------------------------------------- + + use kinds_mod ! module defining data types + use constants ! module for common constants + use iounits ! I/O unit manager + use timers ! CPU timers + use grids ! module with grid information + use remap_vars ! common remapping variables + use remap_conservative ! routines for conservative remap + use remap_distance_weight ! routines for dist-weight remap + use remap_bilinear ! routines for bilinear interp + use remap_bicubic ! routines for bicubic interp + use remap_write ! routines for remap output + + implicit none + +!----------------------------------------------------------------------- +! +! input namelist variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + grid1_file, & ! filename of grid file containing grid1 + grid2_file, & ! filename of grid file containing grid2 + interp_file1, & ! filename for output remap data (map1) + interp_file2, & ! filename for output remap data (map2) + map1_name, & ! name for mapping from grid1 to grid2 + map2_name, & ! name for mapping from grid2 to grid1 + map_method, & ! choice for mapping method + normalize_opt, & ! option for normalizing weights + output_opt ! option for output conventions + + integer (kind=int_kind) :: & + nmap ! number of mappings to compute (1 or 2) + + namelist /remap_inputs/ grid1_file, grid2_file, & + interp_file1, interp_file2, & + map1_name, map2_name, num_maps, & + luse_grid1_area, luse_grid2_area, & + map_method, normalize_opt, output_opt, & + restrict_type, num_srch_bins + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: n, & ! dummy counter + iunit ! unit number for namelist file + + character (char_len) :: nm_in +#if defined ARGC + integer :: iargc + external iargc + + if (iargc() == 1) then + call getarg(1, nm_in) + else + write(6,*) 'need name of namelist file' + stop + endif +#else + write(6,*) 'enter name for namelist file' + read(5,*) nm_in +#endif + +!----------------------------------------------------------------------- +! +! initialize timers +! +!----------------------------------------------------------------------- + + call timers_init + do n=1,max_timers + call timer_clear(n) + end do + +!----------------------------------------------------------------------- +! +! read input namelist +! +!----------------------------------------------------------------------- + + grid1_file = 'unknown' + grid2_file = 'unknown' + interp_file1 = 'unknown' + interp_file2 = 'unknown' + map1_name = 'unknown' + map2_name = 'unknown' + luse_grid1_area = .false. + luse_grid2_area = .false. + num_maps = 2 + map_type = 1 + normalize_opt = 'fracarea' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 900 + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=remap_inputs) + call release_unit(iunit) + + select case(map_method) + case ('conservative') + map_type = map_type_conserv + luse_grid_centers = .false. + case ('bilinear') + map_type = map_type_bilinear + luse_grid_centers = .true. + case ('bicubic') + map_type = map_type_bicubic + luse_grid_centers = .true. + case ('distwgt') + map_type = map_type_distwgt + luse_grid_centers = .true. + case default + stop 'unknown mapping method' + end select + + select case(normalize_opt(1:4)) + case ('none') + norm_opt = norm_opt_none + case ('frac') + norm_opt = norm_opt_frcarea + case ('dest') + norm_opt = norm_opt_dstarea + case default + stop 'unknown normalization option' + end select + +!----------------------------------------------------------------------- +! +! initialize grid information for both grids +! +!----------------------------------------------------------------------- + + call grid_init(grid1_file, grid2_file) + + write(stdout, *) ' Computing remappings between: ',grid1_name + write(stdout, *) ' and ',grid2_name + +!----------------------------------------------------------------------- +! +! initialize some remapping variables. +! +!----------------------------------------------------------------------- + + call init_remap_vars + +!----------------------------------------------------------------------- +! +! call appropriate interpolation setup routine based on type of +! remapping requested. +! +!----------------------------------------------------------------------- + + select case(map_type) + case(map_type_conserv) + call remap_conserv + case(map_type_bilinear) + call remap_bilin + case(map_type_distwgt) + call remap_distwgt + case(map_type_bicubic) + call remap_bicub + case default + stop 'Invalid Map Type' + end select + +!----------------------------------------------------------------------- +! +! reduce size of remapping arrays and then write remapping info +! to a file. +! +!----------------------------------------------------------------------- + + if (num_links_map1 /= max_links_map1) then + call resize_remap_vars(1, num_links_map1-max_links_map1) + endif + if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then + call resize_remap_vars(2, num_links_map2-max_links_map2) + endif + + call write_remap(map1_name, map2_name, & + interp_file1, interp_file2, output_opt) + +!----------------------------------------------------------------------- + + end program scrip + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid.F90 new file mode 100755 index 0000000000000000000000000000000000000000..e9744f8e3880c202c486bee8c9e33d7121c18dd4 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid.F90 @@ -0,0 +1,26 @@ +! ============================================================================== + +PROGRAM scripgrid + + USE scripgrid_mod + + CHARACTER(char_len) :: infile + +#if defined ARGC + INTEGER :: IARGC + EXTERNAL IARGC + + if (IARGC() == 1) then + CALL GETARG(1, infile) + CALL convert( infile ) + ELSE + write(6,*) 'need to supply a namelist file' + ENDIF +#else + write(6,*) 'enter name of namelist file' + read(5,*) infile + + CALL convert( infile ) +#endif + +END PROGRAM scripgrid diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid_mod.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..70157352fc05874cf2c47cd23dae507e18696e2e --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scripgrid_mod.F90 @@ -0,0 +1,759 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module creates grid description files for input to the SCRIP code +! +!----------------------------------------------------------------------- + +MODULE scripgrid_mod + + USE kinds_mod + USE constants + USE iounits + USE netcdf + USE netcdf_mod + + IMPLICIT NONE + + !----------------------------------------------------------------------- + ! module variables that describe the grid + + INTEGER (kind=int_kind), parameter :: & + grid_rank = 2, & + grid_corners = 4 + INTEGER (kind=int_kind) :: nx, ny, grid_size + INTEGER (kind=int_kind), dimension(2) :: & + grid_dims, & ! size of x, y dimensions + grid_dim_ids ! ids of the x, y dimensions + INTEGER (kind=int_kind), ALLOCATABLE, DIMENSION(:) :: & + grid_imask ! land-sea mask + REAL (kind=int_kind), ALLOCATABLE, DIMENSION(:) :: & + grid_center_lat, & ! lat/lon coordinates for + grid_center_lon ! each grid center in degrees + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + grid_corner_lat, & ! lat/lon coordinates for + grid_corner_lon ! each grid corner in degrees + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:,:) :: & + corner_lon, & + corner_lat + REAL (kind=dbl_kind), PARAMETER :: circle = 360.0 + + !----------------------------------------------------------------------- + ! module variables that describe the netcdf file + + INTEGER (kind=int_kind) :: & + ncstat, & ! general netCDF status variable + ncid_in + +CONTAINS + + ! ============================================================================== + + SUBROUTINE convert(nm_in) + + ! ----------------------------------------------------------------------------- + ! - input variables + + CHARACTER(char_len), INTENT(in) :: & + nm_in + + ! ----------------------------------------------------------------------------- + ! - local variables + + CHARACTER(char_len) :: & + nemo_file, input_file, method, input_lon, input_lat, datagrid_file, & + nemogrid_file, nemo_lon, nemo_lat, corn_lon, corn_lat, nemo_mask, input_mask + INTEGER (kind=int_kind), dimension(2) :: & + offset + INTEGER (kind=int_kind) :: & + iunit, nemo_mask_value, input_mask_value + + namelist /grid_inputs/ nemo_file, input_file, datagrid_file, nemogrid_file, & + method, input_lon, input_lat, nemo_lon, nemo_lat, & + nemo_mask, nemo_mask_value, input_mask, input_mask_value + + !----------------------------------------------------------------------- + ! - namelist describing the processing + ! note that mask_value is the minimum good value, + ! so that where the mask is less than the value is masked + + nemo_file = "coordinates.nc" + nemo_lon = "glamt" + nemo_lat = "gphit" + input_lon = "lon" + input_lat = "lat" + input_mask = "none" + input_mask_value = 0 + datagrid_file = 'remap_data_grid.nc' + nemogrid_file = 'remap_nemo_grid.nc' + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=grid_inputs) + call release_unit(iunit) + + if (nemo_lon(1:4) .ne. 'glam' .or. nemo_lat(1:4) .ne. 'gphi') then + write(6,*) 'lon name does not start with "glam" or lat name does not start with "gphi"' + stop + endif + + ! set up the names of the corner variables for a given input + ! the offset represents what needs to be added to (i,j) to get to the correct + ! element in the corner arrays to correspond to the point northeast of the center + if (nemo_lon(5:5) == "t") then + corn_lon = "glamf" + corn_lat = "gphif" + offset = (/ 0,0 /) + else if (nemo_lon(5:5) == "u") then + corn_lon = "glamv" + corn_lat = "gphiv" + offset = (/ 1,0 /) + else if (nemo_lon(5:5) == "v") then + corn_lon = "glamu" + corn_lat = "gphiu" + offset = (/ 0,1 /) + else + write(6,*) 'unknown nemo_lon name' + stop + endif + + write(6,*) "processing " // trim(nemo_file) + call convertNEMO(nemo_file, nemo_lon, nemo_lat, corn_lon, corn_lat, & + offset, nemogrid_file) + + write(6,*) "processing regular grid" + call convertFLUX(input_file, input_lon, input_lat, & + input_mask, input_mask_value, datagrid_file) + + END SUBROUTINE convert + + ! ============================================================================== + + SUBROUTINE convertNEMO(grid_file_in, cent_lon, cent_lat, corn_lon, corn_lat, & + off, grid_file_out) + + !----------------------------------------------------------------------- + ! + ! This routine converts a NEMO coordinates.nc file to a remapping grid file. + ! + + CHARACTER(char_len), INTENT(in) :: cent_lon, cent_lat, corn_lon, corn_lat + INTEGER (kind=int_kind), INTENT(in), DIMENSION(2) :: off + CHARACTER(char_len), INTENT(in) :: grid_file_out + CHARACTER(char_len), INTENT(in) :: grid_file_in + + !----------------------------------------------------------------------- + ! module variables that describe the grid + + CHARACTER(char_len), parameter :: & + grid_name = 'Remapped NEMO grid for SCRIP' + + !----------------------------------------------------------------------- + ! grid coordinates and masks + + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + clon, clat, & ! expanded corner arrays + glam, & ! center longitude + gphi, & ! center latitude + glamc, & ! corner longitude + gphic ! corner latitude + + !----------------------------------------------------------------------- + ! other local variables + + INTEGER (kind=int_kind) :: i, j, n, iunit, im1, jm1, imid, isame, ic, jc + INTEGER (kind=int_kind) :: varid_lam, varid_phi, varid_lamc, varid_phic + INTEGER (kind=int_kind) :: jdim + INTEGER (kind=int_kind), dimension(4) :: grid_dimids ! input fields have 4 dims + REAL (kind=dbl_kind) :: tmplon, dxt, dyt + + !----------------------------------------------------------------------- + ! read in grid info + ! + ! For NEMO input grids, assume that variable names are glam, glamc etc. + ! Assume that 1st 2 dimensions of these variables are x and y directions. + ! These assumptions are made by NEMO, so should be valid for coordinates.nc. + ! + ! write in nf90 calls (without error handling) and then think about + ! making more readable by taking chunks into ncutil + ! + + ncstat = nf90_open( grid_file_in, NF90_NOWRITE, ncid_in ) + call netcdf_error_handler(ncstat) + + ! find dimids for 'glam' + ! use dimids to get dimlengths + ! allocate glam array + ! get glam from file + + ncstat = nf90_inq_varid( ncid_in, cent_lon, varid_lam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, corn_lon, varid_lamc ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, cent_lat, varid_phi ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, corn_lat, varid_phic ) + call netcdf_error_handler(ncstat) + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:) ) + call netcdf_error_handler(ncstat) + DO jdim = 1, SIZE(grid_dims) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(jdim), & + len=grid_dims(jdim) ) + call netcdf_error_handler(ncstat) + END DO + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ! assume that dimensions are all the same as glam + ALLOCATE( glam(nx,ny), glamc(nx,ny), gphi(nx,ny), gphic(nx,ny) ) + ncstat = nf90_get_var( ncid_in, varid_lam, glam(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_lamc, glamc(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, gphi(:,:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phic, gphic(:,:) ) + call netcdf_error_handler(ncstat) + + !----------------------------------------------------------------------- + ! - Mask is all ocean for now + + ALLOCATE( grid_imask(grid_size) ) + grid_imask(:) = 1 + + !----------------------------------------------------------------------- + ! corners are arranged as follows: 4 3 + ! 1 2 + ! + ! Assume that cyclic grids have 2 wrap columns in coordinates.nc + ! (this is the case for ORCA grids) + ! + + ! ----------------------------------------------------------------------------- + ! create a single pair of arrays for the corners where clon(1,1) corresponds + ! to the south west corner of a box containing glam(1,1) + ! various special cases then apply + ! bottom row: assume clon(:,j) = clon(:,j+1) + + ALLOCATE ( clon(nx+1,ny+1), clat(nx+1,ny+1) ) + + ! first the easy internal points + DO j = 2,ny + DO i = 2,nx + ic = i + off(1) - 1 + jc = j + off(2) - 1 + clon(i,j) = glamc(ic,jc) + clat(i,j) = gphic(ic,jc) + ENDDO + ENDDO + + ! then the tricky boundary points + imid = (nx-1)/2 + 1 + DO j = 1,ny+1,ny + DO i = 1,nx+1,nx + ic = i + off(1) - 1 + jc = j + off(2) - 1 + if (ic == 0 .and. jc == 0) then + clon(i,j) = glamc(nx,1) + clat(i,j) = gphic(nx,1) - (gphic(nx,2)-gphic(nx,1)) + else if (ic == nx+1 .and. jc == 0) then + clon(i,j) = glamc(1,1) + clat(i,j) = gphic(1,1) - (gphic(1,2)-gphic(1,1)) + else if (ic == 0 .and. jc == ny+1) then + isame = 2*imid - nx + 1 + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + else if (ic == nx+1 .and. jc == ny+1) then + isame = 2*imid + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + else if (ic == 0) then + clon(i,j) = glamc(nx,jc) + clat(i,j) = gphic(nx,jc) + else if (jc == 0) then + clon(i,j) = glamc(ic,1) + clat(i,j) = gphic(ic,1) - (gphic(ic,2)-gphic(ic,1)) + else if (ic == nx+1) then + clon(i,j) = glamc(1,jc) + clat(i,j) = gphic(1,jc) + else if (jc == ny+1) then + isame = 2*imid - ic + 1 + clon(i,j) = glamc(isame,jc-1) + clat(i,j) = gphic(isame,jc-1) + endif + ENDDO + ENDDO + + ALLOCATE ( corner_lon(4,nx,ny), corner_lat(4,nx,ny) ) + + ! top-right corner + corner_lon(3,:,:) = clon(2:nx+1,2:ny+1) + corner_lat(3,:,:) = clat(2:nx+1,2:ny+1) + + ! top-left corner + corner_lon(4,:,:) = clon(1:nx,2:ny+1) + corner_lat(4,:,:) = clat(1:nx,2:ny+1) + + ! bottom-right corner + corner_lon(2,:,:) = clon(2:nx+1,1:ny) + corner_lat(2,:,:) = clat(2:nx+1,1:ny) + + ! bottom-left corner + corner_lon(1,:,:) = clon(1:nx,1:ny) + corner_lat(1,:,:) = clat(1:nx,1:ny) + + ! For [N, E, W]-ward extrapolation near the poles, should we use stereographic (or + ! similar) projection? This issue will come for V,F interpolation, and for all + ! grids with non-cyclic grids. + + ! ----------------------------------------------------------------------------- + ! correct for 0,2pi longitude crossings + ! (In practice this means putting all corners into 0,2pi range + ! and ensuring that no box corners are miles from each other. + ! 3pi/2 is used as threshold - I think this is quite arbitrary.) + + corner_lon(:,:,:) = MODULO( corner_lon(:,:,:), circle ) + DO n = 2, grid_corners + WHERE ( corner_lon(n,:,:) - corner_lon(n-1,:,:) < -three*circle*0.25 ) + corner_lon(n,:,:) = corner_lon(n,:,:) + circle + ELSEWHERE( corner_lon(n,:,:) - corner_lon(n-1,:,:) > three*circle*0.25 ) + corner_lon(n,:,:) = corner_lon(n,:,:) - circle + END WHERE + END DO + + ! ----------------------------------------------------------------------------- + ! - put longitudes on smooth grid + + ! call mouldlon(glam,nx,ny) + ! call mouldlon(corner_lon(1,:,:),nx,ny) + ! call mouldlon(corner_lon(2,:,:),nx,ny) + ! call mouldlon(corner_lon(3,:,:),nx,ny) + ! call mouldlon(corner_lon(4,:,:),nx,ny) + + ! ----------------------------------------------------------------------------- + ! - reshape for SCRIP input format + + ALLOCATE( grid_center_lon(grid_size), grid_center_lat(grid_size) ) + + grid_center_lon(:) = RESHAPE( glam(:,:), (/ grid_size /) ) + grid_center_lat(:) = RESHAPE( gphi(:,:), (/ grid_size /) ) + + DEALLOCATE( glam, gphi, glamc, gphic ) + + ALLOCATE( grid_corner_lon(4, grid_size), grid_corner_lat(4, grid_size) ) + + grid_corner_lon(:,:) = RESHAPE( corner_lon(:,:,:), (/ 4, grid_size /) ) + grid_corner_lat(:,:) = RESHAPE( corner_lat(:,:,:), (/ 4, grid_size /) ) + + DEALLOCATE( corner_lon, corner_lat ) + + CALL createSCRIPgrid(grid_file_out, grid_name) + + END SUBROUTINE convertNEMO + + ! ============================================================================== + + SUBROUTINE convertFLUX(grid_file_in, name_lon, name_lat, & + name_mask, value_mask, grid_file_out) + + !----------------------------------------------------------------------- + ! + ! This routine creates a remapping grid file from an input grid. + ! + !----------------------------------------------------------------------- + + CHARACTER(char_len), INTENT(in) :: & + grid_file_in, name_lon, name_lat, name_mask, grid_file_out + INTEGER (kind=int_kind) :: value_mask + + !----------------------------------------------------------------------- + ! variables that describe the grid + + CHARACTER(char_len), parameter :: & + grid_name = 'Remapped regular grid for SCRIP' + + !----------------------------------------------------------------------- + ! grid coordinates (note that a flux file just has lon and lat) + + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:) :: & + lam, phi + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: & + glam, & ! longitude + gphi, & ! latitude + glamc, & + gphic + REAL (kind=dbl_kind), ALLOCATABLE, DIMENSION(:,:) :: mask + + !----------------------------------------------------------------------- + ! other local variables + + INTEGER (kind=int_kind) :: i, j, n, iunit, im1, jm1 + INTEGER (kind=int_kind) :: varid_lam, varid_phi, varid_mask + INTEGER (kind=int_kind) :: jdim, nspace + INTEGER (kind=int_kind), dimension(4) :: grid_dimids ! input fields have 4 dims + REAL (kind=dbl_kind) :: tmplon, dxt, dyt + + !----------------------------------------------------------------------- + ! read in grid info + ! + ! For NEMO input grids, assume that variable names are glam, glamc etc. + ! Assume that 1st 2 dimensions of these variables are x and y directions. + ! These assumptions are made by NEMO, so should be valid for coordinates.nc. + ! + ! write in nf90 calls (without error handling) and then think about + ! making more readable by taking chunks into ncutil + + ncstat = nf90_open( grid_file_in, NF90_NOWRITE, ncid_in ) + call netcdf_error_handler(ncstat) + + ! find dimids for 'glamt' + ! use dimids to get dimlengths + ! allocate glam array + ! get glam from file + + ncstat = nf90_inq_varid( ncid_in, name_lat, varid_phi ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inq_varid( ncid_in, name_lon, varid_lam ) + call netcdf_error_handler(ncstat) + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, ndims=nspace ) + call netcdf_error_handler(ncstat) + + if (nspace == 1) then + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_variable( ncid_in, varid_phi, dimids=grid_dimids(2:) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(1), len=grid_dims(1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(2), len=grid_dims(2) ) + call netcdf_error_handler(ncstat) + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ALLOCATE( lam(nx), phi(ny) ) + write(6,*) 'double' + ncstat = nf90_get_var( ncid_in, varid_lam, lam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, phi ) + call netcdf_error_handler(ncstat) + + ALLOCATE( glam(nx,ny), gphi(nx,ny)) + write(6,*) shape(lam),shape(phi) + glam(:,:) = SPREAD(lam,2,ny) + gphi(:,:) = SPREAD(phi,1,nx) + else + + ncstat = nf90_inquire_variable( ncid_in, varid_lam, dimids=grid_dimids(:2) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(1), len=grid_dims(1) ) + call netcdf_error_handler(ncstat) + ncstat = nf90_inquire_dimension( ncid_in, grid_dimids(2), len=grid_dims(2) ) + call netcdf_error_handler(ncstat) + nx = grid_dims(1) + ny = grid_dims(2) + grid_size = nx * ny + WRITE(*,FMT='("Input grid dimensions are:",2i6)') nx, ny + + ALLOCATE( glam(nx,ny), gphi(nx,ny)) + ncstat = nf90_get_var( ncid_in, varid_lam, glam ) + call netcdf_error_handler(ncstat) + ncstat = nf90_get_var( ncid_in, varid_phi, gphi ) + call netcdf_error_handler(ncstat) + + endif + write(6,*) grid_size,nx,ny + + ALLOCATE(glamc(0:nx,0:ny), gphic(0:nx,0:ny) ) + + ! - for now a simple average to get top right box corners + ! - glamc(i,j), gphic(i,j) are top right coordinates of box containing + ! - glam(i,j),gphi(i,j) + write(6,*) 'averaging' + write(6,*) size(gphic),size(gphi) + gphic(1:nx,1:ny-1) = 0.5*(gphi(:,1:ny-1)+gphi(:,2:ny)) + write(6,*) size(glamc),size(glam) + glamc(1:nx-1,1:ny) = 0.5*(glam(1:nx-1,:)+glam(2:nx,:)) + + ! - left and right column of longitudes + write(6,*) 'columns' + glamc(nx,1:ny) = 1.5*glam(nx,:)-0.5*glam(nx-1,:) + glamc( 0,1:ny) = 1.5*glam(1,:)-0.5*glam(2,:) + glamc(nx, 0) = glamc(nx,1) + glamc( 0, 0) = glamc( 0,1) + + ! - top and bottom row of latitudes by extrapolation + write(6,*) 'rows' + gphic(1:nx,ny) = 1.5*gphi(:,ny)-0.5*gphi(:,ny-1) + gphic(1:nx, 0) = 1.5*gphi(:,1)-0.5*gphi(:,2) + gphic( 0,ny) = gphic(1,ny) + gphic( 0, 0) = gphic(1, 0) + + !----------------------------------------------------------------------- + + write(6,*) 'allocating' + ALLOCATE( grid_imask(grid_size) ) + grid_imask(:) = 1 + write(6,*) name_mask + if (trim(name_mask) /= "none") then + write(6,*) 'masking' + ncstat = nf90_inq_varid( ncid_in, name_mask, varid_mask ) + call netcdf_error_handler(ncstat) + ALLOCATE( mask(nx,ny) ) + write(6,*) 'reading mask' + ncstat = nf90_get_var( ncid_in, varid_mask, mask ) + call netcdf_error_handler(ncstat) + write(6,*) 'setting mask' + WHERE ( RESHAPE(mask(:,:),(/ grid_size /)) < value_mask) + grid_imask = 0 + END WHERE + write(6,*) 'masked' + END IF + + !----------------------------------------------------------------------- + ! corners are arranged as follows: 4 3 + ! 1 2 + + ALLOCATE ( corner_lon(4,nx,ny), corner_lat(4,nx,ny) ) + + ! - bottom-left corner + corner_lon(1,:,:) = glamc(0:nx-1, 0:ny-1 ) + corner_lat(1,:,:) = gphic(0:nx-1, 0:ny-1 ) + + ! - bottom-right corner + corner_lon(2,:,:) = glamc(1:nx, 0:ny-1 ) + corner_lat(2,:,:) = gphic(1:nx, 0:ny-1 ) + + ! - top-right corner + corner_lon(3,:,:) = glamc(1:nx,1:ny) + corner_lat(3,:,:) = gphic(1:nx,1:ny) + write(6,*) corner_lat(3,nx-2:nx,ny) + + ! - top-left corner + corner_lon(4,:,:) = glamc(0:nx-1, 1:ny ) + corner_lat(4,:,:) = gphic(0:nx-1, 1:ny ) + + ! For [N, E, W]-ward extrapolation near the poles, should we use stereographic (or + ! similar) projection? This issue will come for V,F interpolation, and for all + ! grids with non-cyclic grids. + + ! ----------------------------------------------------------------------------- + ! correct for 0,2pi longitude crossings + ! (In practice this means putting all corners into 0,2pi range + ! and ensuring that no box corners are miles from each other. + ! 3pi/2 is used as threshold - I think this is quite arbitrary.) + + ! corner_lon(:,:,:) = MODULO( corner_lon(:,:,:), circle ) + ! DO n = 2, grid_corners + ! WHERE ( corner_lon(n,:,:) - corner_lon(n-1,:,:) < -three*circle*0.25 ) + ! corner_lon(n,:,:) = corner_lon(n,:,:) + circle + ! ELSEWHERE( corner_lon(n,:,:) - corner_lon(n-1,:,:) > three*circle*0.25 ) + ! corner_lon(n,:,:) = corner_lon(n,:,:) - circle + ! END WHERE + ! END DO + + ! ----------------------------------------------------------------------------- + ! - reshape for SCRIP input format + + ALLOCATE( grid_center_lon(grid_size), grid_center_lat(grid_size) ) + + grid_center_lon(:) = RESHAPE( glam(:,:), (/ grid_size /) ) + grid_center_lat(:) = RESHAPE( gphi(:,:), (/ grid_size /) ) + + DEALLOCATE( glam, gphi, glamc, gphic ) + + ALLOCATE( grid_corner_lon(4, grid_size), grid_corner_lat(4, grid_size) ) + + grid_corner_lon(:,:) = RESHAPE( corner_lon(:,:,:), (/ 4, grid_size /) ) + grid_corner_lat(:,:) = RESHAPE( corner_lat(:,:,:), (/ 4, grid_size /) ) + + DEALLOCATE( corner_lon, corner_lat ) + + CALL createSCRIPgrid(grid_file_out, grid_name) + + END SUBROUTINE convertFLUX + + ! ============================================================================== + + SUBROUTINE mouldlon(lon_grid, nx, ny) + + ! ----------------------------------------------------------------------------- + ! - input variables + + INTEGER, INTENT(in) :: nx, ny + REAL (kind=dbl_kind), INTENT(inout), DIMENSION(nx,ny) :: & + lon_grid + + ! ----------------------------------------------------------------------------- + ! - local variables + + INTEGER :: ix, iy + REAL (kind=dbl_kind), DIMENSION(:,:), ALLOCATABLE :: & + dlon + REAL :: step + + ! ----------------------------------------------------------------------------- + ! - try to eliminate any 360 degree steps in a grid of longitudes + + ALLOCATE(dlon(nx,ny)) + + step = 0.75*circle + dlon(:,:) = 0 + dlon(2:,:) = lon_grid(2:,:) - lon_grid(:nx-1,:) + WHERE (dlon > -step .AND. dlon < step) + dlon = 0.0 + ELSEWHERE + dlon = -SIGN(circle,dlon) + END WHERE + + ! - close your eyes this is nasty + DO ix = 2,nx + dlon(ix,:) = dlon(ix,:) + dlon(ix-1,:) + END DO + lon_grid = lon_grid + dlon + + END SUBROUTINE mouldlon + + ! ============================================================================== + + SUBROUTINE createSCRIPgrid(grid_file_out, grid_name) + + ! ----------------------------------------------------------------------------- + ! - input variables + + CHARACTER(char_len), INTENT(in) :: & + grid_name, grid_file_out + + ! ----------------------------------------------------------------------------- + ! - local variables that describe the netcdf file + + INTEGER (kind=int_kind) :: & + nc_grid_id, & ! netCDF grid dataset id + nc_gridsize_id, & ! netCDF grid size dim id + nc_gridcorn_id, & ! netCDF grid corner dim id + nc_gridrank_id, & ! netCDF grid rank dim id + nc_griddims_id, & ! netCDF grid dimensions id + nc_grdcntrlat_id, & ! netCDF grid center lat id + nc_grdcntrlon_id, & ! netCDF grid center lon id + nc_grdimask_id, & ! netCDF grid mask id + nc_gridarea_id, & ! netCDF grid area id + nc_grdcrnrlat_id, & ! netCDF grid corner lat id + nc_grdcrnrlon_id ! netCDF grid corner lon id + + ! ----------------------------------------------------------------------------- + ! - create netCDF dataset for this grid + ! - rewrite in nf90 + ! - (bring out functional blocks into ncclear for readability) + + ncstat = nf90_create (grid_file_out, NF90_CLOBBER, nc_grid_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att (nc_grid_id, NF90_GLOBAL, 'title', grid_name) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid size dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_size', grid_size, nc_gridsize_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid rank dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_rank', grid_rank, nc_gridrank_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner dimension + + ncstat = nf90_def_dim (nc_grid_id, 'grid_corners', grid_corners, nc_gridcorn_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid dim size array + + ncstat = nf90_def_var(nc_grid_id, 'grid_dims', NF90_INT, nc_gridrank_id, nc_griddims_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid mask + + ncstat = nf90_def_var(nc_grid_id, 'grid_imask', NF90_INT, & + nc_gridsize_id, nc_grdimask_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdimask_id, 'units', 'unitless') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid center latitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_center_lat', NF90_DOUBLE, & + nc_gridsize_id, nc_grdcntrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcntrlat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid center longitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_center_lon', NF90_DOUBLE, & + nc_gridsize_id, nc_grdcntrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcntrlon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner latitude array + + grid_dim_ids = (/ nc_gridcorn_id, nc_gridsize_id /) + ncstat = nf90_def_var(nc_grid_id, 'grid_corner_lat', NF90_DOUBLE, & + grid_dim_ids, nc_grdcrnrlat_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcrnrlat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! - define grid corner longitude array + + ncstat = nf90_def_var(nc_grid_id, 'grid_corner_lon', NF90_DOUBLE, & + grid_dim_ids, nc_grdcrnrlon_id) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_att(nc_grid_id, nc_grdcrnrlon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! end definition stage + + ncstat = nf90_enddef(nc_grid_id) + call netcdf_error_handler(ncstat) + + ! ----------------------------------------------------------------------------- + ! write grid data + + ncstat = nf90_put_var(nc_grid_id, nc_griddims_id, grid_dims) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdimask_id, grid_imask) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcntrlat_id, grid_center_lat) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcntrlon_id, grid_center_lon) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcrnrlat_id, grid_corner_lat) + call netcdf_error_handler(ncstat) + ncstat = nf90_put_var(nc_grid_id, nc_grdcrnrlon_id, grid_corner_lon) + call netcdf_error_handler(ncstat) + + ncstat = nf90_close(nc_grid_id) + call netcdf_error_handler(ncstat) + + DEALLOCATE( grid_imask, grid_center_lon, grid_center_lat, & + grid_corner_lon, grid_corner_lat ) + + + END SUBROUTINE createSCRIPgrid + +END MODULE scripgrid_mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp.F90 new file mode 100644 index 0000000000000000000000000000000000000000..74724980439e4fb7de3a364a4bc394ae942318ed --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp.F90 @@ -0,0 +1,24 @@ +! ========================================================================== + +program scripinterp + + use scripinterp_mod + + character (char_len) :: nm_in +#if defined ARGC + integer :: iargc + external iargc + + if (iargc() == 1) then + call getarg(1, nm_in) + call process_grid(nm_in) + else + write(6,*) 'need the name of an input namelist' + endif +#else + write(6,*) 'enter the name of an input namelist' + read(5,*) nm_in + call process_grid(nm_in) +#endif + +end program scripinterp diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp_mod.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..9a5558551df8576e46f79a2d64927c33f7d8a045 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scripinterp_mod.F90 @@ -0,0 +1,1031 @@ +! ************************************************************************** + + module scripinterp_mod + +! ========================================================================== + + use kinds_mod ! defines common data types + use constants ! defines common constants + use iounits ! I/O unit manager + use netcdf + use netcdf_mod ! netcdf I/O stuff + use grids ! module containing grid info + use remap_vars ! module containing remapping info + use remap_mod ! module containing remapping routines + use remap_read ! routines for reading remap files + + implicit none + + real(kind=dbl_kind), dimension(:), allocatable :: & + grid_out + + integer(kind=int_kind) :: & ! netCDF ids for files and arrays + ncstat, nc_outfile_id, nc_infile_id + integer (kind=int_kind), dimension(4) :: & + input_dims, input_dimids, input_count + real (kind=dbl_kind), dimension(:), allocatable :: & + scale + integer (kind=int_kind), dimension(:), allocatable :: & + nc_xysize_id, nc_gridsize_id, nc_gridsize, & + nc_variable_id + integer :: nc_lon_id, nc_lat_id, nc_array_id + + character (char_len) :: & + map_name ! name for mapping from grid1 to grid2 + character (1), parameter :: & + separator = '|' + + ! - input namelist variables + + character (char_len) :: & + input_file, & ! filename containing input fields + interp_file, & ! filename containing remap data (map1) + input_name ! name of variable to grid + integer (kind=int_kind), dimension(4) :: & + input_stride, & ! how much of input array to process + input_start, & ! where to start + input_stop ! and where to stop + character (char_len), dimension(4) :: & + input_vars ! input variables to be copied + + ! - output namelist variables + + character (char_len) :: & + output_file, & ! filename for test results + output_mode, & ! 'create' or 'append' + output_name, & ! name of new grid variable + output_lat, & ! as it says + output_lon, & ! as it says + output_ydir ! choose to invert output arrays in y direction + character (char_len), dimension(4) :: & + output_dims, & ! name of new grid variable + output_vars ! variables to copy + character (char_len), dimension(10) :: & + output_attributes, & ! attributes of stuff in output file + output_scaling ! scaling factor to apply to input data to get + ! correct units in output file +contains + +! ========================================================================== + + subroutine process_grid(nm_in) + + !----------------------------------------------------------------------- + ! - dummy variables + + character (char_len) :: & + nm_in ! name of input namelist file + + !----------------------------------------------------------------------- + ! - local variables + + integer (kind=int_kind), dimension(4) :: & + astart, acount, plus_one + integer (kind=int_kind), dimension(3) :: & + write_dims + integer (kind=int_kind) :: & + i1, i2, jdim, n, nx, ny, nloop, & + nc_input_id, nc_input_rank, & + vstart, vstride, numv + + real (kind=dbl_kind), dimension(:), allocatable :: & + grid1_array + real (kind=dbl_kind), dimension(:,:), allocatable :: & + var_out + + plus_one(:) = 1 + + !----------------------------------------------------------------------- + + call read_mappings(nm_in) + + !----------------------------------------------------------------------- + ! - read input grid + ! - WARNING - lots of assumptions here at the moment + + ncstat = nf90_open( input_file, NF90_NOWRITE, nc_infile_id ) + call netcdf_error_handler(ncstat,"open") + + ncstat = nf90_inq_varid( nc_infile_id, input_name, nc_input_id ) + call netcdf_error_handler(ncstat,"inq_varid") + + input_dims(:) = 0 + ncstat = nf90_inquire_variable( nc_infile_id, nc_input_id, & + ndims=nc_input_rank, dimids=input_dimids(:) ) + call netcdf_error_handler(ncstat,"inquire_variable") + + do jdim = 1,nc_input_rank + ncstat = nf90_inquire_dimension(nc_infile_id, & + input_dimids(jdim), len=input_dims(jdim) ) + call netcdf_error_handler(ncstat,"inquire_dimension") + enddo + + ! - dimids seem to be returned in storage order so the outer dimension of + ! - the array as described by the netcdf file becomes the first dimension + ! - as far as f90 is concerned (confused? you will be!) + + do jdim = 1,nc_input_rank + if (input_stop(jdim) == 0) then + input_stop(jdim) = input_dims(jdim) + endif + input_count(jdim) = input_stop(jdim) - input_start(jdim) + 1 + enddo + + ! - rashly we assume x followed by y + nx = input_dims(1) + ny = input_dims(2) + write(*,fmt='("Input grid dimensions are:",2i6)') nx, ny + if (nx*ny /= grid1_size) then + write(6,*) "mismatch between input grid and remap data" + stop + endif + + ! - calculate number of horizontal slices to process + ! - at the moment this is not very general and will only work with 3 dimensions + + acount(1:nc_input_rank) = & + (input_stop(1:nc_input_rank)-input_start(1:nc_input_rank)+1) / & + input_stride(1:nc_input_rank) + nloop = 1 + do jdim = 1,nc_input_rank + nloop = nloop*acount(jdim) + enddo + nloop = nloop/grid1_size + write(6,*) "total slices requested: ",nloop + + vstart = input_start(nc_input_rank) ! ie extra var has outer dimension + vstride = input_stride(nc_input_rank) + + ! - in general we cant read in the whole array so do it slice by slice + ! - slow but sure + + write(6,*) "allocating input and output grids" + allocate( grid1_array(grid1_size)) + allocate( grid_out(grid2_size) ) + + numv = 0 + do n = 1,4 + if (trim(input_vars(n)) /= '-' .and. & + trim(output_vars(n)) /= '-') numv = numv + 1 + enddo + + write_dims(1) = grid2_dims(1) + write_dims(2) = grid2_dims(2) + write_dims(3) = nloop + call define_grid(write_dims(1:3) , 2+numv) + + astart(:) = input_start(:) + astart(3) = astart(3) - input_stride(3) + acount(:) = 1 + acount(1) = nx + acount(2) = ny + + do n = 1,nloop + + write(6,*) "processing slice: ",n + astart(3) = astart(3) + input_stride(3) + ncstat = nf90_get_var(nc_infile_id, nc_input_id, grid1_array, & + start=astart(1:nc_input_rank), & + count=acount(1:nc_input_rank)) + call netcdf_error_handler(ncstat,"get_var") + + call calculate_grid(grid1_array, grid_out) + + call write_grid(grid_out, n, write_dims(1:2) , 2) + + enddo + + ! --------------------------------------------------------------------- + ! - now for any extra variables to copy + + if (numv > 0) then + + write(6,*) "reading ",numv," extra variables" + allocate( var_out(nloop,numv) ) + + do n = 1,numv + write(6,*) "looking for variable: ",trim(input_vars(n)) + ncstat = nf90_inq_varid( nc_infile_id, trim(input_vars(n)), nc_input_id ) + call netcdf_error_handler(ncstat,"inq_varid") + + input_dims(:) = 0 + ncstat = nf90_inquire_variable( nc_infile_id, nc_input_id, & + ndims=nc_input_rank, dimids=input_dimids(:) ) + call netcdf_error_handler(ncstat,"inquire_variable") + + if (nc_input_rank /= 1) then + write(6,*) 'sorry, only rank 1 variables can be copied' + cycle + endif + ncstat = nf90_inquire_dimension(nc_infile_id, & + input_dimids(1), len=input_dims(1) ) + call netcdf_error_handler(ncstat,"inquire_dimension") + + ncstat = nf90_get_var(nc_infile_id, nc_input_id, var_out(1:nloop,n), & + start=(/ vstart /), stride=(/ vstride /)) + call netcdf_error_handler(ncstat,"get_var") + enddo + + call write_extra(var_out, numv+2) + deallocate(var_out) + + endif + + ncstat = nf90_close(nc_outfile_id) + call netcdf_error_handler(ncstat,"out close") + ncstat = nf90_close(nc_infile_id) + call netcdf_error_handler(ncstat,"in close") + + ! --------------------------------------------------------------------- + + deallocate( grid1_array, grid_out) + + ! --------------------------------------------------------------------- + + end subroutine process_grid + + ! ========================================================================== + + subroutine define_grid(thedims, therank) + + !----------------------------------------------------------------------- + ! - dummy variables + + integer (kind=int_kind) :: & + therank + integer (kind=int_kind), dimension(therank) :: & + thedims + + !----------------------------------------------------------------------- + ! - local variables + + integer :: & + k, n, ilon, ilat, icolon, i1, i2, natt, nvar, id, jd, kd, nd + character (char_len) :: & + aname, vname, att + real (kind=dbl_kind) :: s + + ! - netcdf variables + + integer :: xtype + + !----------------------------------------------------------------------- + ! - define grid size dimensions + + allocate(nc_xysize_id(grid2_rank)) + allocate(nc_gridsize_id(therank)) + allocate(nc_gridsize(therank)) + allocate(nc_variable_id(therank-2)) + + !----------------------------------------------------------------------- + ! - setup a NetCDF file for output + + xtype = NF90_FLOAT + + write(6,*) 'creating output file' + ncstat = nf90_create (output_file, NF90_CLOBBER, nc_outfile_id) + call netcdf_error_handler(ncstat,"create") + + write(6,*) 'setting global attributes' + ncstat = nf90_put_att(nc_outfile_id, NF90_GLOBAL, 'title', map_name) + call netcdf_error_handler(ncstat,"put_att") + + write(6,*) 'setting dimensions' + do n=1,therank + if (n .eq. therank .and. therank .gt. 2) then + write(6,*) ' unlimited dim ',trim(output_dims(n)),' size: ',thedims(n) + ncstat = nf90_def_dim (nc_outfile_id, output_dims(n), NF90_UNLIMITED, & + nc_gridsize_id(n)) + else + write(6,*) ' dim ',trim(output_dims(n)),' size: ',thedims(n) + ncstat = nf90_def_dim (nc_outfile_id, output_dims(n), thedims(n), & + nc_gridsize_id(n)) + endif + call netcdf_error_handler(ncstat,"def_dim") + end do + nc_gridsize(:) = thedims(1:therank) + + ! - at the moment there is an assumption here that the ordering is (lon,lat) + + ilon = 1 + ilat = 2 + nc_xysize_id(1) = nc_gridsize_id(ilon) + nc_xysize_id(2) = nc_gridsize_id(ilat) + + ! ---------------------------------------------------------------- + ! - define grid center longitude array + + write(6,*) 'defining longitude variable' + ncstat = nf90_def_var (nc_outfile_id, output_lon, & + xtype, nc_xysize_id, & + nc_lon_id) + call netcdf_error_handler(ncstat,"def_var") + + ncstat = nf90_put_att (nc_outfile_id, nc_lon_id, 'units', 'degrees') + call netcdf_error_handler(ncstat,"put_att") + + ! ---------------------------------------------------------------- + ! - define grid center latitude array + + write(6,*) 'defining latitude variable' + ncstat = nf90_def_var (nc_outfile_id, output_lat, & + xtype, nc_xysize_id, & + nc_lat_id) + call netcdf_error_handler(ncstat,"def_var") + + ncstat = nf90_put_att (nc_outfile_id, nc_lat_id, 'units', 'degrees') + call netcdf_error_handler(ncstat,"put_att") + + ! ---------------------------------------------------------------- + ! - define copy variables array + + write(6,*) 'defining copy variables' + do n = 3,therank + ncstat = nf90_def_var (nc_outfile_id, output_vars(n-2), & + xtype, nc_gridsize_id(n), & + nc_variable_id(n-2)) + call netcdf_error_handler(ncstat,"def_var") + enddo + + ! ---------------------------------------------------------------- + ! - define output array + + write(6,*) 'defining grid variable' + ncstat = nf90_def_var (nc_outfile_id, output_name, & + xtype, nc_gridsize_id, & + nc_array_id) + call netcdf_error_handler(ncstat,"def_var") + + ! ---------------------------------------------------------------- + ! - output attributes has to come after all other definitions + ! - this code currently a bit murky, needs a rewrite + + ncstat = nf90_inquire (nc_outfile_id, nVariables=nvar) + call netcdf_error_handler(ncstat,"inquire") + do n = 1,10 + att = trim(output_attributes(n)) + natt = len(att) + if (att /= '-') then + i1 = index(att,separator) + aname = att(1:i1-1) + do k = 1,nvar + ncstat = nf90_inquire_variable(nc_outfile_id, k, vname) + call netcdf_error_handler(ncstat,"inquire_variable") + if (vname == aname) then + i2 = index(att,separator,.true.) + ncstat = nf90_put_att (nc_outfile_id, k, & + att(i1+1:i2-1), att(i2+1:natt)) + call netcdf_error_handler(ncstat,"put_att") + exit ! from innermost do + endif + enddo + endif + enddo + + ! output scaling + + allocate (scale(nvar)) + scale(:) = 1.0 + + do n = 1,10 + att = trim(output_scaling(n)) + natt = len(att) + if (att /= '-') then + i1 = index(att,separator) + aname = att(1:i1-1) + do k = 1,nvar + ncstat = nf90_inquire_variable(nc_outfile_id, k, vname) + call netcdf_error_handler(ncstat,"inquire_variable") + if (vname == aname) then + i2 = index(att,separator,.true.) + read(att(i2+1:natt),*) scale(k) + call netcdf_error_handler(ncstat,"put_att") + exit ! from innermost do + endif + enddo + endif + enddo + + ! ---------------------------------------------------------------- + ! - end definition stage + + ncstat = nf90_enddef(nc_outfile_id) + call netcdf_error_handler(ncstat,"enddef") + + end subroutine define_grid + + ! ========================================================================== + + subroutine write_grid(thegrid, thelevel, thedims, therank) + + !----------------------------------------------------------------------- + ! - dummy variables + + integer (kind=int_kind), intent(in) :: & + therank, thelevel + real (kind=dbl_kind), dimension(:), intent(in) :: & + thegrid + integer (kind=int_kind), dimension(therank) :: & + thedims + + !----------------------------------------------------------------------- + ! - local variables + + integer :: & + k, n, ilon, ilat, icolon, j1, j2, dj, natt, nvar, id, jd, kd, nd + character (char_len) :: & + aname, vname, att + real (kind=dbl_kind), dimension(:,:,:), allocatable :: & + data + real (kind=dbl_kind) :: s + real (kind=dbl_kind), parameter :: todeg = 57.295779513082323 + integer (kind=int_kind), dimension(3) :: & + start + + ! - netcdf variables + + integer :: xtype + + !----------------------------------------------------------------------- + ! - write results to NetCDF file + + allocate (data(thedims(1),thedims(2),1)) + if (output_ydir .eq. 'invert') then + j1 = thedims(2) + j2 = 1 + dj = -1 + else + j1 = 1 + j2 = thedims(2) + dj = 1 + endif + + if (thelevel .eq. 1) then + + ! - grid center latitude array + + write(6,*) 'writing latitude variable' + s = scale(nc_lat_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = s*todeg*grid2_center_lat(nd) + enddo + enddo + ncstat = nf90_put_var(nc_outfile_id, nc_lat_id, data(:,:,1)) + call netcdf_error_handler(ncstat,"put_var") + + ! - grid center longitude array + + write(6,*) 'writing longitude variable' + s = scale(nc_lon_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = s*todeg*grid2_center_lon(nd) + enddo + enddo + ncstat = nf90_put_var(nc_outfile_id, nc_lon_id, data(:,:,1)) + call netcdf_error_handler(ncstat,"put_var") + + endif + + !----------------------------------------------------------------------- + ! - new grid + + write(6,*) 'writing grid variable' + n = therank + s = scale(nc_array_id) + nd = 0 + do jd = j1,j2,dj + do id =1,thedims(1) + nd = nd + 1 + data(id,jd,1) = thegrid(nd) + enddo + enddo + write(6,*) 'scaling data ' + data(:,:,1) = s*data(:,:,1) + start(:) = (/ 1, 1, thelevel /) + ncstat = nf90_put_var(nc_outfile_id, nc_array_id, data, start) + call netcdf_error_handler(ncstat,"put_var") + deallocate(data) + + end subroutine write_grid + + ! ========================================================================== + + subroutine write_extra(thevars, therank) + + real (kind=dbl_kind), dimension(:,:), intent(in) :: & + thevars + real (kind=dbl_kind), dimension(:), allocatable :: & + thedata + integer (kind=int_kind), intent(in) :: & + therank + real (kind=dbl_kind) :: s + integer :: n + + allocate( thedata(size(thevars,1)) ) + + ! - copy variable arrays + + write(6,*) 'writing copy variables' + do n = 3,therank + s = scale(nc_variable_id(n-2)) + thedata(:) = s*thevars(:,n-2) + ncstat = nf90_put_var(nc_outfile_id, nc_variable_id(n-2), thedata) + call netcdf_error_handler(ncstat,"put_var") + enddo + + deallocate( thedata ) + + end subroutine write_extra + + ! ========================================================================== + + subroutine close_grid() + + ! close netCDF file + + write(6,*) 'closing file' + ncstat = nf90_close(nc_outfile_id) + call netcdf_error_handler(ncstat,"close") + + end subroutine close_grid + + ! ========================================================================== + + subroutine read_mappings(nm_in) + + !----------------------------------------------------------------------- + ! - dummy variables + + character (char_len) :: & + nm_in ! name of input namelist file + + !----------------------------------------------------------------------- + ! - local variables + + character (char_len) :: & + dim_name ! netCDF dimension name + + integer (kind=int_kind) :: & + iunit ! unit number for namelist file + + !----------------------------------------------------------------------- + ! - namelist block + + namelist /interp_inputs/ input_file, interp_file, input_name, & + input_stride, input_start, input_stop, & + input_vars + namelist /interp_outputs/ output_dims, output_file, output_mode, output_name, & + output_lat, output_lon, output_ydir, & + output_scaling, output_vars, output_attributes + + !----------------------------------------------------------------------- + ! - read namelist for file and mapping info + + input_stride(:) = 1 + input_start(:) = 1 + input_stop(:) = 0 + output_scaling(:) = '-' + input_vars(:) = '-' + output_lon = '-' + output_lat = '-' + output_vars(:) = '-' + output_ydir = 'none' + output_attributes(:) = '-' + + call get_unit(iunit) + open(iunit, file=nm_in, status='old', form='formatted') + read(iunit, nml=interp_inputs) + read(iunit, nml=interp_outputs) + call release_unit(iunit) + write(*,nml=interp_inputs) + write(*,nml=interp_outputs) + if (trim(output_mode) == "create") then + if (trim(output_lon) == '-' .or. trim(output_lat) == '-') then + write(6,*) 'if creating, need to supply lon and lat names' + stop + endif + endif + + !----------------------------------------------------------------------- + ! - read remapping data + ! - via the scrip package this sets variables: + ! grid1_size, grid2_size: sizes of input and output grids + ! grid1_mask, grid2_mask: masks + ! grid1_rank, grid2_rank: ranks + + call read_remap(map_name, interp_file) + + end subroutine read_mappings + + ! ========================================================================== + + subroutine calculate_grid(grid1_array, grid2_array) + + !----------------------------------------------------------------------- + ! - dummy variables + + real (kind=dbl_kind), intent(in), dimension(:) :: & + grid1_array + real (kind=dbl_kind), intent(out), dimension(:) :: & + grid2_array + + !----------------------------------------------------------------------- + ! - local variables + + integer (kind=int_kind), dimension(:), allocatable :: & + grid1_imask, grid2_imask, grid2_count + + real (kind=dbl_kind), dimension(:), allocatable :: & + grid1_tmp, & + grad1_lat, & + grad1_lon, & + grad1_latlon, & + grad1_lat_zero, & + grad1_lon_zero, & + grid2_tmp1, & + grid2_tmp2 + + real (kind=dbl_kind) :: & + delew, delns ! variables for computing bicub gradients + + integer (kind=int_kind) :: & + i,j,n,imin,imax,idiff, & + ip1,im1,jp1,jm1,nx,ny, & ! for computing bicub gradients + in,is,ie,iw,ine,inw,ise,isw + + logical, parameter :: lat_gradient = .false. + + write(6,*) 'starting' + + !----------------------------------------------------------------------- + ! - allocate arrays + + allocate (grid1_tmp (grid1_size), & + grad1_lat (grid1_size), & + grad1_lon (grid1_size), & + grad1_lat_zero (grid1_size), & + grad1_lon_zero (grid1_size), & + grid1_imask (grid1_size), & + grid2_tmp1 (grid2_size), & + grid2_tmp2 (grid2_size), & + grid2_imask (grid2_size), & + grid2_count (grid2_size)) + + write(6,*) 'allocated' + write(6,*) grid1_size,grid2_size + + grid1_imask(:) = 1 + grid2_imask(:) = 1 + where (grid1_mask) + grid1_imask = 1 + elsewhere + grid1_imask = 0 + endwhere + where (grid2_mask) + grid2_imask = 1 + elsewhere + grid2_imask = 0 + endwhere + + write(6,*) 'masked' + + grad1_lat_zero = zero + grad1_lon_zero = zero + nx = input_dims(1) + ny = input_dims(2) + write(6,*) nx,ny + + !----------------------------------------------------------------------- + ! - if bicubic, we need 3 gradients in logical space + + if (map_type == map_type_bicubic) then + + write(6,*) 'bicubic' + write(6,*) grid1_size + + allocate (grad1_latlon (grid1_size)) + + do n=1,grid1_size + + grad1_lat(n) = zero + grad1_lon(n) = zero + grad1_latlon(n) = zero + +! if (n.ge.8000) write(6,*) 0,grid1_mask(n),nx + if (grid1_mask(n)) then + + delew = half + delns = half + + j = (n-1)/nx + 1 + i = n - (j-1)*nx + + ip1 = i+1 + im1 = i-1 + jp1 = j+1 + jm1 = j-1 + + if (ip1 > nx) ip1 = ip1 - nx + if (im1 < 1 ) im1 = nx + if (jp1 > ny) then + jp1 = j + delns = one + endif + if (jm1 < 1 ) then + jm1 = j + delns = one + endif + + in = (jp1-1)*nx + i + is = (jm1-1)*nx + i + ie = (j -1)*nx + ip1 + iw = (j -1)*nx + im1 + + ine = (jp1-1)*nx + ip1 + inw = (jp1-1)*nx + im1 + ise = (jm1-1)*nx + ip1 + isw = (jm1-1)*nx + im1 + + ! - compute i-gradient + + if (.not. grid1_mask(ie)) then + ie = n + delew = one + endif + if (.not. grid1_mask(iw)) then + iw = n + delew = one + endif + + grad1_lat(n) = delew*(grid1_array(ie) - grid1_array(iw)) +! if (n.ge.8000) write(6,*) 1,grad1_lat(n) + + ! - compute j-gradient + + if (.not. grid1_mask(in)) then + in = n + delns = one + endif + if (.not. grid1_mask(is)) then + is = n + delns = one + endif + + grad1_lon(n) = delns*(grid1_array(in) - grid1_array(is)) +! if (n.ge.8000) write(6,*) 2,grad1_lon(n) + + ! - compute ij-gradient + + delew = half + if (jp1 == j .or. jm1 == j) then + delns = one + else + delns = half + endif + + if (.not. grid1_mask(ine)) then + if (in /= n) then + ine = in + delew = one + else if (ie /= n) then + ine = ie + inw = iw + if (inw == n) delew = one + delns = one + else + ine = n + inw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(inw)) then + if (in /= n) then + inw = in + delew = one + else if (iw /= n) then + inw = iw + ine = ie + if (ie == n) delew = one + delns = one + else + inw = n + ine = ie + delew = one + delns = one + endif + endif + + grad1_lat_zero(n) = delew*(grid1_array(ine) - grid1_array(inw)) +! if (n.ge.8000) write(6,*) 3,grad1_lat_zero(n) + + if (.not. grid1_mask(ise)) then + if (is /= n) then + ise = is + delew = one + else if (ie /= n) then + ise = ie + isw = iw + if (isw == n) delew = one + delns = one + else + ise = n + isw = iw + delew = one + delns = one + endif + endif + + if (.not. grid1_mask(isw)) then + if (is /= n) then + isw = is + delew = one + else if (iw /= n) then + isw = iw + ise = ie + if (ie == n) delew = one + delns = one + else + isw = n + ise = ie + delew = one + delns = one + endif + endif + + grad1_lon_zero(n) = delew*(grid1_array(ise) - grid1_array(isw)) + grad1_latlon(n) = delns*(grad1_lat_zero(n) - grad1_lon_zero(n)) +! if (n.ge.8000) write(6,*) 4,grad1_lon_zero(n),grad1_latlon(n) + + endif + enddo + + write(6,*) 'remapping' + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1, & + grid1_array, src_grad1=grad1_lat, & + src_grad2=grad1_lon, src_grad3=grad1_latlon) + + print *,'Third order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array *grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - a first-order map from grid1 to grid2 + + else if (map_type /= map_type_conserv .AND.map_type /= map_type_bicubic) then + + write(6,*) 'bilinear or conservative' + + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1,grid1_array) + + print *,'First order mapping from grid1 to grid2:' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array *grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - conservative mappings: + ! - a second-order map from grid1 to grid2 with only lat grads + + else if (map_type == map_type_conserv .AND. lat_gradient) then + + call remap(grid2_array, wts_map1, grid2_add_map1, grid1_add_map1, & + grid1_array, src_grad1=grad1_lat,src_grad2=grad1_lon_zero) + + select case (norm_opt) + case (norm_opt_none) + grid2_tmp2 = grid2_frac*grid2_area + where (grid2_tmp2 /= zero) + grid2_array = grid2_array/grid2_tmp2 + elsewhere + grid2_array = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_array = grid2_array/grid2_frac + elsewhere + grid2_array = zero + end where + end select + + print *,'Second order mapping from grid1 to grid2 (lat only):' + print *,'----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array*grid2_area*grid2_frac) + + !----------------------------------------------------------------------- + ! - conservative mappings: + ! - a second-order map from grid1 to grid2 both gradients + + else if (map_type == map_type_conserv .AND..NOT. lat_gradient) then + + call remap(grid2_array,wts_map1,grid2_add_map1,grid1_add_map1, & + grid1_array, src_grad1=grad1_lat,src_grad2=grad1_lon) + + select case (norm_opt) + case (norm_opt_none) + grid2_tmp2 = grid2_frac*grid2_area + where (grid2_tmp2 /= zero) + grid2_array = grid2_array/grid2_tmp2 + elsewhere + grid2_array = zero + end where + case (norm_opt_frcarea) + case (norm_opt_dstarea) + where (grid2_frac /= zero) + grid2_array = grid2_array/grid2_frac + elsewhere + grid2_array = zero + end where + end select + + print *,'Second order mapping from grid1 to grid2:' + print *,'-----------------------------------------' + print *,'Grid1 min,max: ',minval(grid1_array),maxval(grid1_array) + print *,'Grid2 min,max: ',minval(grid2_array ),maxval(grid2_array ) + + ! - Conservation Test + + print *,'Conservation:' + print *,'Grid1 Integral = ',sum(grid1_array*grid1_area*grid1_frac) + print *,'Grid2 Integral = ',sum(grid2_array*grid2_area*grid2_frac) + + endif + + !----------------------------------------------------------------------- + ! calculate some statistics + + grid2_count = zero + grid2_tmp1 = zero + grid2_tmp2 = zero + + print *,'number of sparse matrix entries ',num_links_map1 + do n=1,num_links_map1 + grid2_count(grid2_add_map1(n)) = grid2_count(grid2_add_map1(n)) + 1 + if (wts_map1(1,n) > one .or. wts_map1(1,n) < zero) then + grid2_tmp1(grid2_add_map1(n)) = grid2_tmp1(grid2_add_map1(n)) + 1 + grid2_tmp2(grid2_add_map1(n)) = max(abs(wts_map1(1,n)),grid2_tmp2(grid2_add_map1(n)) ) + endif + end do + + do n=1,grid2_size + if (grid2_tmp1(n) > zero) print *,n,grid2_tmp2(n) + end do + + imin = minval(grid2_count, mask=(grid2_count > 0)) + imax = maxval(grid2_count) + idiff = (imax - imin)/10 + 1 + print *,'total number of dest cells ',grid2_size + print *,'number of cells participating in remap ',count(grid2_count > zero) + print *,'min no of entries/row = ',imin + print *,'max no of entries/row = ',imax + + imax = imin + idiff + do n=1,10 + print *,'num of rows with entries between ',imin,' - ',imax-1, & + count(grid2_count >= imin .and. grid2_count < imax) + imin = imin + idiff + imax = imax + idiff + end do + + !----------------------------------------------------------------------- + ! - deallocate arrays + + deallocate (grid1_tmp, grad1_lat, grad1_lon, & + grad1_lat_zero, grad1_lon_zero, grid1_imask, & + grid2_tmp1, grid2_tmp2, & + grid2_imask, grid2_count) + + end subroutine calculate_grid + + ! ========================================================================== + +end module scripinterp_mod + diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/scripshape.F90 b/V4.0/nemo_sources/tools/WEIGHTS/src/scripshape.F90 new file mode 100644 index 0000000000000000000000000000000000000000..2837627659ec69d3bb49f5b9f792a6379892c619 --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/scripshape.F90 @@ -0,0 +1,419 @@ + PROGRAM scripshape +! +! program to take output from the SCRIP weights generator +! and rearrange the data into a series of 2D fields suitable +! for reading with iom_get in NEMO configurations using the +! interpolation on the fly option +! + USE netcdf + IMPLICIT none + INTEGER :: ncId, VarId, status + INTEGER :: start(4), count(4) + CHARACTER(LEN=1) :: y + INTEGER :: nd, ns, nl, nw, sx, sy, dx, dy + INTEGER :: i, j, k, m, n, smax +! +! ifort -O2 -o scripshape scripshape.f90 \ +! -I/nerc/packages/netcdfifort/v3.6.0-pl1/include \ +! -L/nerc/packages/netcdfifort/v3.6.0-pl1/lib -lnetcdf +! +! + INTEGER(KIND=4), ALLOCATABLE :: src(:) + INTEGER(KIND=4), ALLOCATABLE :: dst(:) + REAL(KIND=8), ALLOCATABLE :: wgt(:,:) + REAL(KIND=8), ALLOCATABLE :: src1(:,:),dst1(:,:),wgt1(:,:) + LOGICAL :: around, verbose +#if defined ARGC + INTEGER(KIND=4) :: iargc + EXTERNAL :: iargc +#endif + + CHARACTER(LEN=256) :: interp_file, output_file, name_file + INTEGER :: ew_wrap + NAMELIST /shape_inputs/ interp_file, output_file, ew_wrap + +! scripshape requires 1 arguments; the name of the file containing +! the input namelist. +! This namelist contains: +! the name of the input file containing the weights ! produced by SCRIP in its format; +! the name of the new output file which ! is to contain the reorganized fields ready for input to NEMO. +! the east-west wrapping of the input grid (-1, 0, 1 and 2 are accepted values) +! +! E.g. +! interp_file = 'data_nemo_bilin.nc' +! output_file = 'weights_bilin.nc' +! ew_wrap = 2 +! +#if defined ARGC + IF (iargc() == 1) THEN + CALL getarg(1, name_file) + ELSE + WRITE(*,*) 'Usage: scripshape namelist_file' + STOP + ENDIF +#else + WRITE(6,*) 'enter name of namelist file' + READ(5,*) name_file +#endif + interp_file = 'none' + output_file = 'none' + ew_wrap = 0 + OPEN(12, FILE=name_file, STATUS='OLD', FORM='FORMATTED') + READ(12, NML=shape_inputs) + CLOSE(12) +! + INQUIRE(FILE = TRIM(interp_file), EXIST=around) + IF (.not.around) THEN + WRITE(*,*) 'Input file: '//TRIM(interp_file)//' not found' + STOP + ENDIF +! + INQUIRE(FILE = TRIM(output_file), EXIST=around) + IF (around) THEN + WRITE(*,*) 'Output file: '//TRIM(output_file)//' exists' + WRITE(*,*) 'Ok to overwrite (y/n)?' + READ(5,'(a)') y + IF ( y .ne. 'y' .AND. y .ne. 'Y' ) STOP + ENDIF +! + verbose = .true. +! +! Obtain grid size information from interp_file +! + CALL ncgetsize +! +! Allocate array spaces +! + ALLOCATE(src(nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('src') + ALLOCATE(dst(nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('dst') + ALLOCATE(wgt(nw,nl), STAT=status) + IF(status /= 0 ) CALL alloc_err('wgt') + ALLOCATE(src1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('src1') + ALLOCATE(dst1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('dst1') + ALLOCATE(wgt1(dx,dy), STAT=status) + IF(status /= 0 ) CALL alloc_err('wgt1') +! +! Read all required data from interp_file +! + CALL ncgetfields +! +! Check that dst is monotonically increasing +! + DO k = 1,nl-1 + IF(dst(k+1).lt.dst(k)) THEN + WRITE(*,*) 'non-monotonic at ',k + WRITE(*,*) dst(k-4:k+16) + STOP + ENDIF + END DO +! +! Remove references to the top row of src +! + IF(verbose) WRITE(*,*) & + 'Removing references to the top row of the source grid' + smax = (sy-1)*sx + n = 0 + DO k = 1,nl + IF(src(k).gt.smax-1) THEN + src(k) = src(k)-sx + n = n + 1 + ENDIF + END DO + IF(verbose) WRITE(*,*) n,' values changed (',100.*n/nl,'%)' +! +! Loop through weights for each corner in turn and +! rearrange weight fields into separate 2D fields for +! reading with iom_get in NEMO +! + DO k = 1,nw + DO n = 1,4 + + i = 0 + j = 1 + DO m = n,nl,4 + i = i+1 + IF(i.gt.dx) THEN + i = 1 + j = j + 1 + ENDIF + src1(i,j) = src(m) + dst1(i,j) = dst(m) + wgt1(i,j) = wgt(k,m) + END DO +! +! Write out this set which will be labelled with +! a 2 digit number equal to n+4*(k-1) +! + CALL wrwgts +! + END DO + END DO + STOP + CONTAINS +! +!----------------------------------------------------------------------* + SUBROUTINE ncgetsize +! +! Access grid size information in interp_file and set the +! following integers: +! +! nd = dst_grid_size +! ns = src_grid_size +! nl = num_links +! nw = num_wgts +! sx,sy = src_grid_dims +! dx,dy = dst_grid_dims +! + INTEGER idims(2) +! + status = nf90_open(interp_file, nf90_NoWrite, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'dst_grid_size', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nd) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'src_grid_size', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = ns) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'num_links', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nl) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_dimid(ncid, 'num_wgts', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_inquire_dimension(ncid, VarId, LEN = nw) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + start = 1 + count = 2 + status = nf90_inq_varid(ncid, 'src_grid_dims', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_get_var(ncid, VarId, idims, start, count) + IF(status /= nf90_NoErr) CALL handle_err(status) + sx = idims(1) ; sy = idims(2) +! + status = nf90_inq_varid(ncid, 'dst_grid_dims', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_get_var(ncid, VarId, idims, start, count) + IF(status /= nf90_NoErr) CALL handle_err(status) + dx = idims(1) ; dy = idims(2) +! + status = nf90_close(ncid) + IF (status /= nf90_noerr) CALL handle_err(status) +! + IF(verbose) THEN + WRITE(*,*) 'Detected sizes: ' + WRITE(*,*) 'dst_grid_size: ', nd + WRITE(*,*) 'src_grid_size: ', ns + WRITE(*,*) 'num_links : ', nl + WRITE(*,*) 'num_wgts : ', nw + WRITE(*,*) 'src_grid_dims: ', sx, ' x ', sy + WRITE(*,*) 'dst_grid_dims: ', dx, ' x ', dy + ENDIF +! + END SUBROUTINE ncgetsize + +!----------------------------------------------------------------------* + SUBROUTINE ncgetfields +! +! Read all required data from interp_file. The data read are: +! +! netcdf variable size internal array +!-----------------+-------+-------------- +! src_address nl src +! dst_address nl dst +! remap_matrix (nw,nl) wgt +! + status = nf90_open(interp_file, nf90_NoWrite, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'src_address', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for src + status = nf90_get_var(ncid, VarId, src, & + start = (/ 1 /), & + count = (/ nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'dst_address', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for dst + status = nf90_get_var(ncid, VarId, dst, & + start = (/ 1 /), & + count = (/ nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_inq_varid(ncid, 'remap_matrix', VarId) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Read the values for wgt + status = nf90_get_var(ncid, VarId, wgt, & + start = (/ 1, 1 /), & + count = (/ nw, nl /)) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_close(ncid) + IF (status /= nf90_noerr) CALL handle_err(status) +! + END SUBROUTINE ncgetfields + +!----------------------------------------------------------------------* + SUBROUTINE handle_err(status) +! +! Simple netcdf error checking routine +! + INTEGER, intent ( in) :: status +! + IF(status /= nf90_noerr) THEN + IF(trim(nf90_strerror(status)) .eq. 'Attribute not found') THEN +! ignore + ELSE + WRITE(*,*) trim(nf90_strerror(status)) + STOP "Stopped" + END IF + END IF + END SUBROUTINE handle_err + +!----------------------------------------------------------------------* + SUBROUTINE alloc_err(arname) +! +! Simple allocation error checking routine +! + CHARACTER(LEN=*) :: arname +! + WRITE(*,*) 'Allocation error attempting to ALLOCATE '//arname + STOP "Stopped" + END SUBROUTINE alloc_err + +! +!----------------------------------------------------------------------* + SUBROUTINE wrwgts +! +! Write out each set of 2D fields to output_file. +! Each call will write out a set of srcXX, dstXX and wgtXX fields +! where XX is a two digit number equal to n + 4*(k-1). The first +! and last calls to this routine initialise and close the output +! file respectively. The first call is detected when k*n=1 and the +! last call is detected when k*n=4*nw. The outfile file remains +! open between the first and last calls. +! + INTEGER :: status, ncid, ncin + INTEGER :: Lontdid, Lattdid + INTEGER :: tvid, tvid2, tvid3 + INTEGER :: ioldfill + CHARACTER(LEN=2) :: cs + SAVE ncid, Lontdid, Lattdid +! + IF(k*n.eq.1) THEN +! +! Create output_file and set the dimensions +! + status = nf90_create(output_file, nf90_Clobber, ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_set_fill(ncid, nf90_NoFill, ioldfill) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_dim(ncid, "lon", dx, Lontdid) + IF(status /= nf90_NoErr) CALL handle_err(status) + status = nf90_def_dim(ncid, "lat", dy, Lattdid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_att(ncid, nf90_global, 'ew_wrap', ew_wrap) + IF(status /= nf90_NoErr) CALL handle_err(status) + ELSE +! +! Reenter define mode +! + status = nf90_redef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + ENDIF +! + WRITE(cs,'(i2.2)') n + 4*(k-1) +! +! Define new variables +! + status = nf90_def_var(ncid, "src"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_var(ncid, "dst"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid2) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_def_var(ncid, "wgt"//cs, nf90_double, & + (/ Lontdid, Lattdid /), tvid3) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Leave define mode +! + status = nf90_enddef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! Write the data +! + status = nf90_put_var(ncid, tvid, src1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_var(ncid, tvid2, dst1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_put_var(ncid, tvid3, wgt1, & + start = (/ 1, 1 /), & + count = (/ dx, dy /) ) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + IF(k*n.eq.4*nw) THEN +! +! -- Reenter define mode +! + status = nf90_redef(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Reopen interp_file and transfer some global attributes +! + status = nf90_open(interp_file, nf90_NoWrite, ncin) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'title', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'normalization',ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'map_method', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'conventions', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! + status = nf90_copy_att(ncin,NF90_GLOBAL,'history', ncid,NF90_GLOBAL) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Close interp_file +! + status = nf90_close(ncin) + IF(status /= nf90_NoErr) CALL handle_err(status) +! +! -- Close output_file +! + status = nf90_close(ncid) + IF(status /= nf90_NoErr) CALL handle_err(status) + ENDIF + + END SUBROUTINE wrwgts + END PROGRAM scripshape diff --git a/V4.0/nemo_sources/tools/WEIGHTS/src/timers.f90 b/V4.0/nemo_sources/tools/WEIGHTS/src/timers.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eb90f6ddb2b4452a6e409aa45581f647e3259e2a --- /dev/null +++ b/V4.0/nemo_sources/tools/WEIGHTS/src/timers.f90 @@ -0,0 +1,343 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module uses F90 cpu time routines to allowing setting of +! multiple CPU timers. +! +!----------------------------------------------------------------------- +! +! CVS:$Id: timers.f,v 1.2 2000/04/19 21:56:26 pwjones Exp $ +! +! Copyright (c) 1997, 1998 the Regents of the University of +! California. +! +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated +! LA-CC Number 98-45. +! +! Unless otherwise indicated, this software has been authored +! by an employee or employees of the University of California, +! operator of the Los Alamos National Laboratory under Contract +! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. +! Government has rights to use, reproduce, and distribute this +! software. The public may copy and use this software without +! charge, provided that this Notice and any statement of authorship +! are reproduced on all copies. Neither the Government nor the +! University makes any warranty, express or implied, or assumes +! any liability or responsibility for the use of this software. +! +! If software is modified to produce derivative works, such modified +! software should be clearly marked, so as not to confuse it with +! the version available from Los Alamos National Laboratory. +! +!*********************************************************************** + + module timers + +!----------------------------------------------------------------------- + + use kinds_mod + + implicit none + + integer (kind=int_kind), parameter :: & + max_timers = 99 ! max number of timers allowed + + integer (kind=int_kind), save :: & + cycles_max ! max value of clock allowed by system + + integer (kind=int_kind), dimension(max_timers), save :: & + cycles1, & ! cycle number at start for each timer + cycles2 ! cycle number at stop for each timer + + real (kind=real_kind), save :: & + clock_rate ! clock_rate in seconds for each cycle + + real (kind=real_kind), dimension(max_timers), save :: & + cputime ! accumulated cpu time in each timer + + character (len=8), dimension(max_timers), save :: & + status ! timer status string + +!*********************************************************************** + + contains + +!*********************************************************************** + + subroutine timer_check(timer) + +!----------------------------------------------------------------------- +! +! This routine checks a given timer. This is primarily used to +! periodically accumulate time in the timer to prevent timer cycles +! from wrapping around max_cycles. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'running') then + call timer_stop (timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end subroutine timer_check + +!*********************************************************************** + + subroutine timer_clear(timer) + +!----------------------------------------------------------------------- +! +! This routine resets a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- + + cputime(timer) = 0.0_real_kind ! clear the timer + +!----------------------------------------------------------------------- + + end subroutine timer_clear + +!*********************************************************************** + + function timer_get(timer) + +!----------------------------------------------------------------------- +! +! This routine returns the result of a given timer. This can be +! called instead of timer_print so that the calling routine can +! print it in desired format. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- +! +! Output Variables: +! +!----------------------------------------------------------------------- + + real (kind=real_kind) :: & + timer_get ! accumulated cputime in given timer + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'stopped') then + timer_get = cputime(timer) + else + call timer_stop(timer) + timer_get = cputime(timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end function timer_get + +!*********************************************************************** + + subroutine timer_print(timer) + +!----------------------------------------------------------------------- +! +! This routine prints the accumulated cpu time in given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- + + !--- + !--- print the cputime accumulated for timer + !--- make sure timer is stopped + !--- + + if (status(timer) .eq. 'stopped') then + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") & + timer,cputime(timer) + else + call timer_stop(timer) + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") & + timer,cputime(timer) + call timer_start(timer) + endif + +!----------------------------------------------------------------------- + + end subroutine timer_print + +!*********************************************************************** + + subroutine timer_start(timer) + +!----------------------------------------------------------------------- +! +! This routine starts a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- + + !--- + !--- Start the timer and change timer status. + !--- + + if (status(timer) .eq. 'stopped') then + call system_clock(count=cycles1(timer)) + status(timer) = 'running' + endif + +!----------------------------------------------------------------------- + + end subroutine timer_start + +!*********************************************************************** + + subroutine timer_stop(timer) + +!----------------------------------------------------------------------- +! +! This routine stops a given timer. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! Input Variables: +! +!----------------------------------------------------------------------- + + integer (kind=int_kind), intent(in) :: & + timer ! timer number + +!----------------------------------------------------------------------- + + if (status(timer) .eq. 'running') then + + !--- + !--- Stop the desired timer. + !--- + + call system_clock(count=cycles2(timer)) + + !--- + !--- check and correct for cycle wrapping + !--- + + if (cycles2(timer) .ge. cycles1(timer)) then + cputime(timer) = cputime(timer) + clock_rate* & + (cycles2(timer) - cycles1(timer)) + else + cputime(timer) = cputime(timer) + clock_rate* & + (cycles2(timer) - cycles1(timer) + cycles_max) + endif + + !--- + !--- Change timer status. + !--- + + status(timer)='stopped' + + endif + +!----------------------------------------------------------------------- + + end subroutine timer_stop + +!*********************************************************************** + + subroutine timers_init + +!----------------------------------------------------------------------- +! +! This routine initializes some machine parameters necessary for +! computing cpu time from F90 intrinsics. +! +!----------------------------------------------------------------------- + + integer (kind=int_kind) :: cycles ! count rate return by sys_clock + +!----------------------------------------------------------------------- + + !--- + !--- Initialize timer arrays and clock_rate. + !--- + + clock_rate = 0.0_real_kind + cycles1 = 0 + cycles2 = 0 + cputime = 0.0_real_kind + status = 'stopped' + + !--- + !--- Call F90 intrinsic system_clock to determine clock rate + !--- and maximum cycles. If no clock available, print message. + !--- + + call system_clock(count_rate=cycles, count_max=cycles_max) + + if (cycles /= 0) then + clock_rate = 1.0_real_kind/real(cycles) + else + clock_rate = 0.0_real_kind + print *, '--- No system clock available ---' + endif + +!----------------------------------------------------------------------- + + end subroutine timers_init + +!*********************************************************************** + + end module timers + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/V4.0/nemo_sources/tools/maketools b/V4.0/nemo_sources/tools/maketools new file mode 100755 index 0000000000000000000000000000000000000000..64f61c8ebadd0687d4eb3f6012add0b4c063a852 --- /dev/null +++ b/V4.0/nemo_sources/tools/maketools @@ -0,0 +1,186 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# =============== +# maketools +# =============== +# +# -------------------------- +# Compile NEMO +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ maketools +# +# +# DESCRIPTION +# =========== +# +# +# This script aims : +# +# - to choose a tool to compile +# - to choose compiler options +# - to compile this tool +# +# Variables used : +# +# From user input +# +# - NEW_CONF : configuration to be created +# - CMP_NAM : compiler name +# - NBR_PRC : number of processes used to compile +# +# Locally defined : +# +# - MAIN_DIR : self explaining +# - MODELES_DIR : " " " +# - TOOLS_DIR : " " " +# - NEMO_DIR : " " " +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./maketools -t ifort_osx - j3 -n NESTING +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: maketools 11926 2019-11-18 17:55:49Z nicolasmartin $ +# +# +# +# * creation +# +#- + +#- Local variables --- +b_n=$(basename ${0}) +export MAIN_DIR=${PWD%/tools*} +export TOOLS_DIR=${MAIN_DIR}/tools +export COMPIL_DIR=${MAIN_DIR}/mk +export NEMO_DIR=${MAIN_DIR}/NEMO +#- +#- FCM and functions location --- +export PATH=${MAIN_DIR}/ext/FCM/bin:$PATH + +#- +#- Choice of the options --- +x_h=""; +x_n=""; +x_m=""; +x_t=""; +x_c=""; +x_j=1; +while getopts :hm:n:r:j:t: V + do + case $V in + (h) x_h=${OPTARG}; + echo "Usage : "${b_n} \ + " [-h] [-n name] [-m arch] [-j No] [-t tmpdir]"; + echo " -h : help"; + echo " -h institute : specific help for consortium members"; + echo " -n name : tool name, [-n help] to list existing tools"; + echo " -m arch : choose compiler, [-m help] to list exiting compilers"; + echo " -j No : number of processes used to compile (0=nocompilation)"; + echo " -t dir : remporary directory for compilation" + echo ""; + echo "Example to compile Agrif Nesting tools"; + echo "maketools -n NESTING" ; + echo ""; + printf "%s\n" "Available tools :" `ls ${TOOLS_DIR}|grep -v COMPILE | grep -v maketools`; + echo ""; + . ${COMPIL_DIR}/Flist_archfile.sh ${x_h}; + echo ""; + echo "Default : previous tool and compiler"; + exit 0;; + (n) x_n=${OPTARG};; + (m) x_m=${OPTARG};; + (j) x_j=${OPTARG};; + (t) x_t=${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 the clean option +[[ "${#@}" -ne 0 && "${@}" != clean ]] && echo "Invalid option "$@" " && exit +[ "${#@}" -ne 0 ] && x_c="--$@" + +#- +#- Go to NEMOGCM/tools directory --- +cd ${TOOLS_DIR} + +#- +#- Initialisation from input --- +export NEW_CONF=${x_n} +NBR_PRC=${x_j} +CMP_NAM=${x_m} +NEMO_TDIR=${x_t:-$NEMO_TDIR} +export NEMO_TDIR=${NEMO_TDIR:-$TOOLS_DIR} + +#- Check if the tool or the compiler exist or list it +[ "${NEW_CONF}" == help ] && printf "%s\n" "Available tools :" `ls ${TOOLS_DIR}|grep -v COMPILE | grep -v maketools` && exit +[ "${CMP_NAM}" == help ] && . ${COMPIL_DIR}/Flist_archfile.sh all && exit + +#- When used for the first time, choose a compiler --- +. ${COMPIL_DIR}/Fcheck_archfile.sh arch_tools.fcm cpp.fcm ${CMP_NAM} || exit + +#- Choose a default tool if needed --- +#- REBUILD or last one used --- +. ${COMPIL_DIR}/Fcheck_config.sh tools.txt ${NEW_CONF} || exit + +#- Save new configuration --- +echo "${NEW_CONF} " > ${COMPIL_DIR}/tools.txt + +#- Make the building directory +. ${COMPIL_DIR}/Fmake_bld.sh ${TOOLS_DIR} ${NEW_CONF} ${NEMO_TDIR} || exit + +#- +#_ END OF CONFIGURATION PHASE +#_ + +#- +#- Compile --- + +if [ "${NBR_PRC}" -gt 0 ]; then +cd ${NEMO_TDIR}/${NEW_CONF} || cd - + +fcm build ${x_c} --ignore-lock -v 1 -j ${NBR_PRC} ${COMPIL_DIR}/bld_tools.cfg || cd - +if [ -n "$(ls ${NEMO_TDIR}/${NEW_CONF}/BLD/bin/*.exe)" ]; then +for i in `ls ${NEMO_TDIR}/${NEW_CONF}/BLD/bin/*.exe` + do + ln -sf ${i} ${TOOLS_DIR}/${NEW_CONF}/. + done +fi +fi +#- +#- Come back to original directory --- +cd - + +#- +#- Unset variables +${COMPIL_DIR}/Fclean_var.sh + +exit 0; diff --git a/V4.0/parameters.cfg b/V4.0/parameters.cfg new file mode 100644 index 0000000000000000000000000000000000000000..d3118ceedec36317bd20182a9ee96e77cad0fc9c --- /dev/null +++ b/V4.0/parameters.cfg @@ -0,0 +1,79 @@ +model = nemo +# Branch to profile +model_branch = 4.2.0 +# Configuration name +configuration_name = OCE_SI3 +# Details of the configuration which you would put after makenemo, excluding the arch file +output_cfgs_folder = ORCA2_OCE_ICE + +configuration_details = -r ORCA2_ICE_PISCES -d 'OCE ICE' del_key 'key_top' add_key 'key_asminc key_netcdf4 key_sms key_xios2' + +mixed_configuration_details = -r ORCA2_ICE_PISCES -d 'OCE ICE' del_key 'key_top' add_key 'key_asminc key_netcdf4 key_sms key_xios2 key_single' + + +#mixed_configuration_details = -r ORCA2_ICE_PISCES -d 'OCE' del_key 'key_top key_si3' add_key 'key_single' + +ICE = true + +XIOS = false + +rpe_test_steps = 80 + +spinup_steps = 17520 + +member_steps = 17520 + +longterm_steps = 8760 + +analysis_node_step = 288 +# Grid names +grids = grid_T grid_U grid_W grid_V scalar icemod + +# Test only with 2 +members = 10 + +xios_version = xios-2.5 + +AutoRPE_branch = origin/run_a5ar + +arch = mn4 + +warmings_flag = -w + +database_name = vault.pkl + +member_cores = 384 + +xios_cores = 48 + +spinup_cores = 768 + +#./rebuild_nemo eORCA1_19541231_000000_restart_out 384 + +#time mpirun -n 384 ./model_binary : -np 48 ./xios_server + +#module load intel/2018.3 mkl/2018.3 netcdf/4.4.1.1 udunits/2.2.25 gsl/2.4 nco/4.6.7 ncview + +#/gpfs/projects/bsc32/bsc32252/NEMO4/input/ORCA1_trunk/ + +# gcc/7.2.0 intel/2018.3 impi/2018.3 mkl/2018.3 netcdf/4.4.1.1 hdf5/1.8.19 perl python/3.7.4 + + # modules=( perl/5.26 gcc/4.8.5 impi/2018.3 hdf5/1.8.19 netcdf/4.4.1.1 + +# modules=( perl/5.26 gcc/7.2.0 openmpi/3.1.1 hdf5/1.10.1-ts netcdf/4.6.1 ) + +#makenemo -r ORCA2_OCE_ICE_RPE_TEST -m mn4-debug + +#/gpfs/scratch/bsc32/bsc32402/a5x6/analysis/rpe_test + +#/gpfs/scratch/bsc32/bsc32402/INPUT/eORCA1_OCE_ICE_INPUT/ + +#/gpfs/scratch/bsc32/bsc32681/eORCA1/namelists/eO12_namelists + +#/gpfs/scratch/bsc32/bsc32331/a63q/LOG_a63q/a63q_20000101_08_ensemble_reference.20230629103734.err + +#/gpfs/projects/bsc32/bsc32655/Earth/DestinE/inputdata/ifsbased/eORCA12/ + +##SBATCH --exclude=nid001688,nid001689,nid001785,nid001786,nid001787,nid001569,nid001571,nid001759,nid001763,nid001764,nid001659,nid001665,nid001981,nid001377,nid001682,nid001869,nid001424,nid001876,nid001578,nid001579,nid001357,nid001607,nid001478,nid001622,nid001624,nid001324,nid001331,nid001332,nid001835,nid001837,nid001839,nid001931,nid001935,nid001936,nid001937,nid001939,nid001950,nid001951,nid001952,nid001956,nid001599,nid001600,nid001601,nid001896,nid001502,nid001503,nid001504,nid001593,nid001908,nid001909,nid001968,nid001969,nid001435,nid001451,nid001924,nid001927,nid001728,nid001828,nid001431,nid001845,nid001057,nid001061,nid001190,nid001191,nid001341,nid001342,nid001638,nid001053,nid001445,nid001446,nid001549,nid001089,nid002009,nid001062,nid001284,nid001071,nid001068,nid001738,nid001740 + +# python EvaluationScripts/ensemble/compute_members_RMSE_multip.py --ensemble-files ensemble_mean_mixed/ensemble_grid_T.nc ensemble_mean_mixed/ensemble_grid_U.nc ensemble_mean_mixed/ensemble_grid_V.nc ensemble_mean_mixed/ensemble_grid_W.nc ensemble_mean_mixed/ensemble_scalar.nc ensemble_mean_mixed/ensemble_icemod.nc --member-files ensemble_mixed/member_0007/member_0007_grid_T.nc ensemble_mixed/member_0007/member_0007_grid_U.nc ensemble_mixed/member_0007/member_0007_grid_V.nc ensemble_mixed/member_0007/member_0007_grid_W.nc ensemble_mixed/member_0007/member_0007_icemod.nc ensemble_mixed/member_0007/member_0007_scalar.nc --output-file ensemble_RMSE_mixed/member_0007_RMSE.pkl --mask-file initial_condition/mesh_mask.nc diff --git a/V4.0/utils/add_key_single_to_call.py b/V4.0/utils/add_key_single_to_call.py new file mode 100644 index 0000000000000000000000000000000000000000..446d691fd96fc369f116166df1b62ede6e9c3c81 --- /dev/null +++ b/V4.0/utils/add_key_single_to_call.py @@ -0,0 +1,60 @@ +import re + +# Getting Command line options +from optparse import OptionParser +parser = OptionParser() +parser.add_option("-f", "--file", dest="file_path", default=None, metavar="FILE") +parser.add_option("-r", "--routine", dest="routine_name", default=None) +parser.add_option("-s", "--save", dest="save_result", default=False, action="store_true") + +(options, args) = parser.parse_args() + +file_path = options.file_path +routine_name = options.routine_name + +if file_path is None or routine_name is None: + parser.print_help() + exit(1) + +call_pattern = r"call.*\b%s\b" % routine_name +function_pattern = r"\b%s\b *\(" % routine_name + +preprocessor_directives = "#if ! defined key_single\n%s\n#endif\n" +something_changed = False +with open(file_path, "r") as f: + lines = [l for l in f] + for index, line in enumerate(lines): + m = re.search(call_pattern, line, re.I) + if m: + if line.strip()[0] == "&": + line = lines[index-1] + line + lines[index-1] = "" + ii = index + while line.strip()[-1] == "&": + ii += 1 + line += lines[ii] + lines[ii] = "" + lines[index] = preprocessor_directives % line + something_changed = True + elif re.search(function_pattern, line, re.I): + if line.strip()[0] == "&": + line = lines[index-1] + line + lines[index-1] = "" + if line.lower().strip().find("function") == 0: + continue + ii = index + while line.strip()[-1] == "&": + ii += 1 + line += lines[ii] + lines[ii] = "" + lines[index] = preprocessor_directives % line + something_changed = True + + +text = "".join(lines) +if options.save_result: + output_file = file_path +else: + output_file = False +with open(output_file, "w") as of: + of.write(text) diff --git a/V4.0/utils/arch/arch-O0_trace.fcm b/V4.0/utils/arch/arch-O0_trace.fcm new file mode 100644 index 0000000000000000000000000000000000000000..72d31d05e3059a971a8c6d1ff5e67b58add5a655 --- /dev/null +++ b/V4.0/utils/arch/arch-O0_trace.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -O0 -fp-model strict -extend-source 132 -heap-arrays -g -finstrument-functions +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-O0_vanilla.fcm b/V4.0/utils/arch/arch-O0_vanilla.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d84a7dcf38588226d09996ba54a1f41f81af16d4 --- /dev/null +++ b/V4.0/utils/arch/arch-O0_vanilla.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -O0 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-O1_trace.fcm b/V4.0/utils/arch/arch-O1_trace.fcm new file mode 100644 index 0000000000000000000000000000000000000000..6245ddda196924dc05b1b6b7205c5630a63a389f --- /dev/null +++ b/V4.0/utils/arch/arch-O1_trace.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O1 +%FCFLAGS -r8 -O1 -fp-model strict -extend-source 132 -heap-arrays -g -finstrument-functions +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-O1_vanilla.fcm b/V4.0/utils/arch/arch-O1_vanilla.fcm new file mode 100644 index 0000000000000000000000000000000000000000..b4cd5d45eea63ea27fa7a7b4da051f2127cf4694 --- /dev/null +++ b/V4.0/utils/arch/arch-O1_vanilla.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O1 +%FCFLAGS -r8 -O1 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-gnu-debug.fcm b/V4.0/utils/arch/arch-gnu-debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..db26b2c5aa75e7a445dbb2c83eb48d5df0cebc83 --- /dev/null +++ b/V4.0/utils/arch/arch-gnu-debug.fcm @@ -0,0 +1,29 @@ + + +%XIOS_HOME /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I/apps/NETCDF/4.6.1/GCC/OPENMPI/include +%NCDF_LIB -L/apps/NETCDF/4.6.1/GCC/OPEN/lib -lnetcdf -lnetcdff + +%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 -Dkey_nosignedzero +%FC mpif90 -c -cpp +%FCFLAGS -Wno-argument-mismatch -fno-range-check -O3 -fdefault-double-8 -fdefault-real-8 -funroll-all-loops -fcray-pointer -ffree-line-length-none -march=core-avx2 -mtune=core-avx2 -g -traceback +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O3 diff --git a/V4.0/utils/arch/arch-gnu.fcm b/V4.0/utils/arch/arch-gnu.fcm new file mode 100644 index 0000000000000000000000000000000000000000..2758de4e6d4feb7a8f52d24a2bcb5c579d429428 --- /dev/null +++ b/V4.0/utils/arch/arch-gnu.fcm @@ -0,0 +1,29 @@ + + +%XIOS_HOME /gpfs/scratch/bsc32/bsc32331/a63q/precisionoptimizationworkflow4nemo/xios_sources/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I/apps/NETCDF/4.6.1/GCC/OPENMPI/include +%NCDF_LIB -L/apps/NETCDF/4.6.1/GCC/OPEN/lib -lnetcdf -lnetcdff + +%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 -Dkey_nosignedzero +%FC mpif90 -c -cpp +%FCFLAGS -Wno-argument-mismatch -fno-range-check -O3 -fdefault-double-8 -fdefault-real-8 -funroll-all-loops -fcray-pointer -ffree-line-length-none -march=core-avx2 -mtune=core-avx2 +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O3 diff --git a/V4.0/utils/arch/arch-mn4-debug-O3.fcm b/V4.0/utils/arch/arch-mn4-debug-O3.fcm new file mode 100644 index 0000000000000000000000000000000000000000..725ade56fe5733cbdaf1a12c1103aedbae24fb43 --- /dev/null +++ b/V4.0/utils/arch/arch-mn4-debug-O3.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -g -traceback -fpe0 +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-mn4-debug.fcm b/V4.0/utils/arch/arch-mn4-debug.fcm new file mode 100644 index 0000000000000000000000000000000000000000..83b16218e8ae06f59e1d9c8979e71a4fb25a1399 --- /dev/null +++ b/V4.0/utils/arch/arch-mn4-debug.fcm @@ -0,0 +1,39 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp + +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/OPENMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/OPENMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + + +%FC mpif90 +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -g -traceback +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/utils/arch/arch-mn4-r8.fcm b/V4.0/utils/arch/arch-mn4-r8.fcm new file mode 100644 index 0000000000000000000000000000000000000000..797816d2e90e6a867e3728c0ec6d198120ad06e5 --- /dev/null +++ b/V4.0/utils/arch/arch-mn4-r8.fcm @@ -0,0 +1,36 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-mn4.fcm b/V4.0/utils/arch/arch-mn4.fcm new file mode 100644 index 0000000000000000000000000000000000000000..bac185a315eecc67722ea5685794878e98dabcc8 --- /dev/null +++ b/V4.0/utils/arch/arch-mn4.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB -L%XIOS_DIR/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + diff --git a/V4.0/utils/arch/arch-prod_trace.fcm b/V4.0/utils/arch/arch-prod_trace.fcm new file mode 100644 index 0000000000000000000000000000000000000000..d01ab09e57098b2552a9d621a1a4af9137d12658 --- /dev/null +++ b/V4.0/utils/arch/arch-prod_trace.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -ip -r8 -O3 -fp-model strict -extend-source 132 -heap-arrays -g -finstrument-functions +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-prod_vanilla.fcm b/V4.0/utils/arch/arch-prod_vanilla.fcm new file mode 100644 index 0000000000000000000000000000000000000000..74a0ea4a7e652b941d5d488ddc16e337847ef3cb --- /dev/null +++ b/V4.0/utils/arch/arch-prod_vanilla.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -ip -r8 -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-xHost_trace.fcm b/V4.0/utils/arch/arch-xHost_trace.fcm new file mode 100644 index 0000000000000000000000000000000000000000..eeacf069465d9cd70bc1c16f9b73e8bffe12e886 --- /dev/null +++ b/V4.0/utils/arch/arch-xHost_trace.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -ip -r8 -O3 -fp-model strict -extend-source 132 -heap-arrays -xHost -g -finstrument-functions +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-xHost_vanilla.fcm b/V4.0/utils/arch/arch-xHost_vanilla.fcm new file mode 100644 index 0000000000000000000000000000000000000000..8e44792c8186edcdb8d33fa8702a71792a410909 --- /dev/null +++ b/V4.0/utils/arch/arch-xHost_vanilla.fcm @@ -0,0 +1,37 @@ +# 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<lib dir> 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<include dir> +# USER_LIB additional libraries to pass to the linker, e.g. -l<library> + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR __XIOS_DIR__ +%XIOS_INC -I%XIOS_DIR/inc +%XIOS_LIB %XIOS_DIR/lib/libxios.a + + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -ip -r8 -O3 -fp-model strict -extend-source 132 -heap-arrays -xHost +%FFFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB diff --git a/V4.0/utils/arch/arch-xios_gnu_mn4.env b/V4.0/utils/arch/arch-xios_gnu_mn4.env new file mode 100644 index 0000000000000000000000000000000000000000..4d955327d103f48e5f9a1160b33db2ca4e6a3e1d --- /dev/null +++ b/V4.0/utils/arch/arch-xios_gnu_mn4.env @@ -0,0 +1,7 @@ +module purge +module load perl/5.26 +module load gcc/7.2.0 +module load openmpi/3.1.1 +module load hdf5/1.10.1-ts +module load netcdf/4.6.1 + diff --git a/V4.0/utils/arch/arch-xios_gnu_mn4.fcm b/V4.0/utils/arch/arch-xios_gnu_mn4.fcm new file mode 100644 index 0000000000000000000000000000000000000000..7c94f3375fc49a2ac3e5327331f2947af360b32b --- /dev/null +++ b/V4.0/utils/arch/arch-xios_gnu_mn4.fcm @@ -0,0 +1,20 @@ +%CCOMPILER mpicc +%FCOMPILER mpif90 +%LINKER mpif90 + +%BASE_CFLAGS -fPIC -std=c++11 +%PROD_CFLAGS -O3 -D BOOST_DISABLE_ASSERTS +%DEV_CFLAGS -g -traceback +%DEBUG_CFLAGS -DBZ_DEBUG -g -traceback -fno-inline + +%BASE_FFLAGS -D__NONE__ +%PROD_FFLAGS -O3 +%DEV_FFLAGS -g -O2 -traceback +%DEBUG_FFLAGS -g -traceback + +%BASE_INC -D__NONE__ +%BASE_LD -lstdc++ + +%CPP mpicc -EP +%FPP cpp -P +%MAKE gmake diff --git a/V4.0/utils/arch/arch-xios_gnu_mn4.path b/V4.0/utils/arch/arch-xios_gnu_mn4.path new file mode 100644 index 0000000000000000000000000000000000000000..0a8b5ccc6d406ed147923f2addad5f561c1c1c73 --- /dev/null +++ b/V4.0/utils/arch/arch-xios_gnu_mn4.path @@ -0,0 +1,10 @@ + +NETCDF_DIR="/apps/NETCDF/4.6.1/GCC/OPENMPI" +HDF5_DIR="/apps/HDF5/1.10.1_ts/GCC/OPENMPI" + +NETCDF_INCDIR="-I${NETCDF_DIR}/include" +NETCDF_LIBDIR="-L${NETCDF_DIR}/lib" +NETCDF_LIB="-lnetcdf -lnetcdff" +HDF5_INCDIR="-I${HDF5_DIR}/include" +HDF5_LIBDIR="-L${HDF5_DIR}/lib" +HDF5_LIB="-lhdf5_hl -lhdf5 -lhdf5 -lz" diff --git a/V4.0/utils/arch/arch-xios_ifort_mn4.env b/V4.0/utils/arch/arch-xios_ifort_mn4.env new file mode 100644 index 0000000000000000000000000000000000000000..a9b5d64258b987a0fd68eca4bc5630e7e34c0ce9 --- /dev/null +++ b/V4.0/utils/arch/arch-xios_ifort_mn4.env @@ -0,0 +1,6 @@ +module purge +module load intel/2021.4 +module load impi/2018.3 +module load netcdf/4.4.1.1 +module load hdf5/1.8.19 +module load perl/5.26 diff --git a/V4.0/utils/arch/arch-xios_ifort_mn4.fcm b/V4.0/utils/arch/arch-xios_ifort_mn4.fcm new file mode 100644 index 0000000000000000000000000000000000000000..a1aba481e3e7d0cd66e71851498ef19ac81a4b7f --- /dev/null +++ b/V4.0/utils/arch/arch-xios_ifort_mn4.fcm @@ -0,0 +1,20 @@ +%CCOMPILER mpicc +%FCOMPILER mpif90 +%LINKER mpif90 -nofor-main + +%BASE_CFLAGS +%PROD_CFLAGS -O3 -D BOOST_DISABLE_ASSERTS +%DEV_CFLAGS -g -traceback +%DEBUG_CFLAGS -DBZ_DEBUG -g -traceback -fno-inline + +%BASE_FFLAGS -D__NONE__ +%PROD_FFLAGS -O3 +%DEV_FFLAGS -g -O2 -traceback +%DEBUG_FFLAGS -g -traceback + +%BASE_INC -D__NONE__ +%BASE_LD -lstdc++ + +%CPP mpicc -EP +%FPP cpp -P +%MAKE gmake diff --git a/V4.0/utils/arch/arch-xios_ifort_mn4.path b/V4.0/utils/arch/arch-xios_ifort_mn4.path new file mode 100644 index 0000000000000000000000000000000000000000..7dec02f04535a2db6c637bb6b7373e508b542762 --- /dev/null +++ b/V4.0/utils/arch/arch-xios_ifort_mn4.path @@ -0,0 +1,9 @@ +NETCDF_DIR="/apps/NETCDF/4.4.1.1/INTEL/IMPI" +HDF5_DIR="/apps/HDF5/1.8.19/INTEL/IMPI" + +NETCDF_INCDIR="-I${NETCDF_DIR}/include" +NETCDF_LIBDIR="-L${NETCDF_DIR}/lib" +NETCDF_LIB="-lnetcdf -lnetcdff" +HDF5_INCDIR="-I${HDF5_DIR}/include" +HDF5_LIBDIR="-L${HDF5_DIR}/lib" +HDF5_LIB="-lhdf5_hl -lhdf5 -lhdf5 -lz" diff --git a/V4.0/utils/functions.sh b/V4.0/utils/functions.sh new file mode 100644 index 0000000000000000000000000000000000000000..09644713cf6e68f8e49eb6d90b275df8fd90c69e --- /dev/null +++ b/V4.0/utils/functions.sh @@ -0,0 +1,116 @@ +FUNCTION_PATH=`readlink -f ${BASH_SOURCE:-$0}` +perturbation_script=`dirname ${FUNCTION_PATH}`/gener_perturbation.bash +echo $perturbation_script + + +function set_environment { + # Sets the proper environment loading the modules and setting the adding the main project folder to the PYTHONPATH + # Usage: set_environment + + # Loading modules + echo "Setting environment" + module purge &> /dev/null + modules=(gcc/7.2.0 intel/2021.4 impi/2018.3 mkl/2021.4 netcdf/4.4.1.1 hdf5/1.8.19 perl/5.26 python/3.7.4 ) + for m in ${modules[@]} ; do + module load ${m} &> /dev/null + done + # Adding main directory to PYTHONPATH + main_dir=$(dirname $(dirname $(readlink -f ${BASH_SOURCE} ) ) ) + export PYTHONPATH=${PYTHONPATH}:${main_dir} + + # Adding language information + export LANG=ca_ES.UTF-8 +} + +function load_nco { + # Load all modules necessary to use ncks command + echo "Loading nco" + module purge &> /dev/null + modules=( intel mkl netcdf udunits gsl nco ) + for m in ${modules[@]} ; do + module load ${m} &> /dev/null + done +} + +function set_environment_gnu { + # Sets the proper environment loading the modules and setting the adding the main project folder to the PYTHONPATH + # Usage: set_environment + + # Loading modules + echo "Setting environment" + module purge &> /dev/null + modules=( perl/5.26 gcc/7.2.0 openmpi/3.1.1 hdf5/1.10.1-ts netcdf/4.6.1 mkl/2018.3 python/3.7.4) + for m in ${modules[@]} ; do + module load ${m} &> /dev/null + done + +} + +function load_nco { + # Load all modules necessary to use ncks command + echo "Loading nco" + module purge &> /dev/null + modules=( intel mkl netcdf udunits gsl nco ) + for m in ${modules[@]} ; do + module load ${m} &> /dev/null + done +} + +function replace_namelist_parameter { + # Replaces the value of a given parameter on a given namelist + # Usage: replace_namelist_parameter NAMELIST_PATH PARAMETER_NAME NEW_VALUE + # Example: replace_namelist_parameter namelist_cfg ln_icebergs .false. + filepath=$1 + parameter=$2 + value=$3 + # Find parameter in namelist + sed -i "s/\(${parameter} *= *\)[^ ]*/\1 ${value}/g" ${filepath} +} + +function check_internet_connection { + # Checks that the script can access internet + # Usage: check_internet_connection + # Example: [[ $(check_internet_connection) -eq "Offline" ]] && echo "No connection" && exit 1 + + wget -q --spider http://google.com + if [ $? -eq 0 ]; then + echo "Online" + else + echo "Offline" + fi +} + +function prepare_rundir { + # Creates a new directory and puts all the components needed to launch a simulation with the exception of the binary. + # Usage: prepare_rundir RUNDIR_NAME + # Example: prepare_rundir rundir_spinup + + rundir=$1 + sources=$2 + inidata_folder=$3 + model_binary=$4 + io_server=$5 + + configuration=${output_cfgs_folder} + reference_folder=${sources}/cfgs/${configuration}/EXP00/ + + if [ ! -d ${reference_folder} ] ; then + configuration=${output_cfgs_folder}_RPE + reference_folder=${sources}/cfgs/${configuration}/EXP00/ + fi + + # Link inidata.sh + ln -rsf ${inidata_folder}/* ${rundir} + rsync -rv --exclude=*.nc ${inidata_folder}/ ${rundir} + # Copy everything from reference folder + #cp --remove-destination ${reference_folder}/* ${rundir} + # Copy IO server + cp --remove-destination ${io_server} ${rundir} + # Copy nemo binary + cp --remove-destination ${model_binary} ${rundir} + # Copy namelist_precisions + # Only necessary for RPE simulations, since we might use this function for the spinup before namelist_precisions is cretaed we'll only try to copy it if it exists + [[ -f namelist_precisions ]] && cp --remove-destination namelist_precisions ${rundir} + # Remove nemo binary + rm -f ${rundir}/nemo +} diff --git a/V4.0/utils/functions_nemo.sh b/V4.0/utils/functions_nemo.sh new file mode 100644 index 0000000000000000000000000000000000000000..26fa4a8f5b2962b613c030dbc446f8d762d41283 --- /dev/null +++ b/V4.0/utils/functions_nemo.sh @@ -0,0 +1,159 @@ +############################################# +# Collection of bash functions that are used in several workflow steps + +function clone_repo { +# +# Copies the basic NEMO structure to compile and run NEMO, from the BSC-ES mirror +# Usage: clone-nemo NEMO_BRANCH +# Example: clone-nemo NEMO-4.0.2 svn/NEMO/releases/release-4.0.2 +# Created by Miguel Castrillo <miguel.castrillo@bsc.es> +# + + if [ $# -lt "1" ] + then + echo "You must introduce 1 argument [BRANCH]" + else + + branch=$1 + + # Clone NEMO repository + git clone https://earth.bsc.es/gitlab/svn/nemo-mirror.git . + + # Checkout and copy tools/ + mkdir _tools + git checkout svn/utils/tools + mv [a-zA-Z]* _tools + + # Checkout and copy ext/ + mkdir -p _ext/AGRIF + git checkout svn/vendors/AGRIF + mv [a-zA-Z]* _ext/AGRIF/ + mkdir -p _ext/FCM + git checkout svn/vendors/FCM + mv [a-zA-Z]* _ext/FCM/ + git checkout svn/vendors/IOIPSL + mkdir -p _ext/IOIPSL + mv [a-zA-Z]* _ext/IOIPSL/ + git checkout svn/vendors/IOIPSL + + # Checkout and copy arch/ and makenemo + mkdir _build + git checkout svn/utils/build + mv [a-zA-Z]* _build + + mkdir -p _ext/PPR + git checkout svn/vendors/PPR + mv [a-zA-Z]* _ext/PPR/ + + # Checkout NEMO revision + git checkout ${branch} + + mv _build/* . + rm -rf _build + + mv _ext ext + mv _tools tools + cd - + fi +} + +function copy_arch_files { + + add_rpe=$1 + dir=$2 + xios_sources=$3 + # Copy arch files + cp utils/arch/arch-${arch}.fcm ${dir}/arch/arch-${arch}.fcm + cp utils/arch/arch-${arch}-debug.fcm ${dir}/arch/arch-${arch}-debug.fcm + + # Replace with correct path + current_path=$(pwd) + xios_dir=${current_path}/${xios_sources}/${xios_version} + + sed -i "s#__XIOS_DIR__#$xios_dir#g" ${dir}/arch/arch-${arch}* + + # Check if we need to add RPE includes + if [[ "$add_rpe" -eq 1 ]]; then + + rpe_dir=${current_path}/rpe + + append=" +%RPE_DIR $rpe_dir +%RPE_INC -I%RPE_DIR/modules +%RPE_LIB %RPE_DIR/lib/librpe.a + " + + # Append at the beginning of the files + echo -e "$append\n$(cat ${dir}/arch/arch-${arch}.fcm)" > ${dir}/arch/arch-${arch}.fcm + echo -e "$append\n$(cat ${dir}/arch/arch-${arch}-debug.fcm)" > ${dir}/arch/arch-${arch}-debug.fcm + + sed -i '/%USER_INC/ s/$/ %RPE_INC/' ${dir}/arch/arch-${arch}* + sed -i '/%USER_LIB/ s/$/ %RPE_LIB/' ${dir}/arch/arch-${arch}* + + fi + +} + +function add_exclude_rpe_dependencies { + + mk_dir=$1 + + if [[ ! -d "$mk_dir" ]]; then + echo "$mn_dir does not exist" + exit 1 + fi + + rpe_dependency=" +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + " + + files=( $mk_dir/bld*.cfg ) + for f in ${files[@]} ; do + already_present=`grep -rin rp_emulator ${f} | wc -l` + # If the statement was not yet insert, append it + if [[ ${already_present} -eq 0 ]]; then + echo "${rpe_dependency}" >> ${f} + fi + done + +} + +function update_namelist_values { + # Modifies both reference and cfg namelist + cfg_namelist_file=$1 + ref_namelist_file=$2 + # The length of the simulation depends often on the target + nn_itend=$3 + ice=$4 + ln_restart=$5 + # Set simulation length + replace_namelist_parameter ${cfg_namelist_file} nn_itend ${nn_itend} + # Disable internal wave-induced mixing + replace_namelist_parameter ${cfg_namelist_file} ln_zdfiwm .false. + # Disable icebergs + replace_namelist_parameter ${cfg_namelist_file} ln_icebergs .false. + # Disable mesh_mask file generation + replace_namelist_parameter ${ref_namelist_file} ln_meshmask .false. + + # With no ice nn_mxlice must be 0 + if [ "${ICE}" = false ] + then + replace_namelist_parameter ${cfg_namelist_file} nn_mxlice 0 + fi + + # Enable start from restart + if [ "${ln_restart}" = true ] + then + replace_namelist_parameter ${cfg_namelist_file} ln_rstart .true. + replace_namelist_parameter ${ref_namelist_file} ln_rstart .true. + else + replace_namelist_parameter ${cfg_namelist_file} ln_rstart .false. + replace_namelist_parameter ${ref_namelist_file} ln_rstart .false. + + fi + # Enable global budget diagnostics + replace_namelist_parameter ${cfg_namelist_file} ln_diahsb .true. + replace_namelist_parameter ${ref_namelist_file} ln_diahsb .true. + +} diff --git a/V4.0/utils/gener_perturbation.bash b/V4.0/utils/gener_perturbation.bash new file mode 100755 index 0000000000000000000000000000000000000000..5667e9b65ae758e017d9fbb72f2172caa8b5cbeb --- /dev/null +++ b/V4.0/utils/gener_perturbation.bash @@ -0,0 +1,90 @@ +#!/bin/bash +# +# -- Author : François Massonnet, francois.massonnet@ic3.cat +# -- Date : 30 Jan 2015 +# -- At : IC3, Barcelona +# -- Modified : 19 Jan 2016, omar.bellprat@bsc.es +# -- Modified : 12 Feb 2020, change library ncdf to ncdf4, Yohan Ruprich-Robert, yohan.ruprich@bsc.es +# +# -- Purpose: Generation of an arbitrary number of NEMO oceanic restarts that are copies of a reference, plus a perturbation +# +# -- Method : The reference file is duplicated in this script, then read by a R script. The perturbation is introduced and finally written to this latter file. +# The script must be placed into the restart directory (e.g. NEMO_Restart_23). The generated restarts have to be renamed after generation. This +# script has been tested on MareNostrum3. +# +# -- Input : NEMO ocean restart from an EC-Earth 3.1 run +# -- Output : N restarts with the same name,but with an index fc0, fc1, ... fcN-1 appended +# +# -- Limitations: Only the surface conditions are perturbed (level index: 1) but this can be changed in the R script + +module load R/3.6.1 + +set -o errexit +set -o nounset +set -x + + +if [ $# == 0 ] ; then + echo "gener_perturbation.bash ocean_restart_file Nmembers" + exit +fi + +filein=$1 +nmemb=$2 +# If a seed is provided use it +seed=${3--1} + + +# --------------------------------------------------------- + +var=tn # Variable to be perturbed +per=0.0001 # Standard deviation of gaussian perturbation to be applied, + # in units of the variable (for tn: in K for example) + +for jmemb in `seq 0 $(( $nmemb -1 ))` +do + echo $jmemb + # 1. Make a copy of the original file, with the new name + filenew="${filein%.nc}_fc${jmemb}.nc" + cp $filein ${filein}.backup + cp $filein $filenew + + # 2. Prepare the R script + + echo "#!/usr/bin/env Rscript + library(ncdf4) + + # François Massonnet, 30 Jan 2015 + # Adds a gaussian perturbation at the first level of a 3D field + # Tested only for NEMO restarts + # + # This script should be called by a bash script so that the variable and file names are specified, as well as the perturbation + + varname='$var' + filein <- '$filenew' + ex.nc <- nc_open(filein,write=TRUE) + spert <- $per + expseed <- $seed + if ( expseed != -1 ){ + set.seed(expseed) + } + + myvar <- ncvar_get(ex.nc, varname) + myvarpert <- myvar + for (i in seq(1,dim(myvar)[1])){ + for (j in seq(1,dim(myvar)[2])){ + if (myvar[i,j,1] != 0){ + myvarpert[i,j,1] = myvarpert[i,j,1] + rnorm(1,sd=spert) + } + } + } + + ncvar_put(ex.nc,varname,myvarpert) + nc_close(ex.nc)" > Rtmpfile.R + + chmod 744 Rtmpfile.R + + # 3. Run the R script, that produces the new NetCDF + ./Rtmpfile.R +done + diff --git a/V4.0/utils/job_template.sh b/V4.0/utils/job_template.sh new file mode 100644 index 0000000000000000000000000000000000000000..14ab7a5a8c179a4b6e366a011eca34421380332c --- /dev/null +++ b/V4.0/utils/job_template.sh @@ -0,0 +1,85 @@ +#!/bin/bash +############################################################################### +# SBATCH HEADER TEMPLATE +############################################################################### +#SBATCH --ntasks 48 +#SBATCH -J %JOBNAME% +#SBATCH --output %LOGDIR%/log_%j.out +#SBATCH --error %LOGDIR%/log_%j.err +#SBATCH --time 00:25:00 +#SBATCH --qos=debug + +set -xuve + +JOB_ID=${SLURM_JOB_ID:-$LSB_JOBID} + +ABSPATH=%REMOTE_PATH% +PROJPATH=${ABSPATH}/precisionoptimizationworkflow4nemo +RUNDIR=${ABSPATH}/analysis/%RUNHASH% +NAMELIST=%NAMELIST% +binary=model_binary_rpe +io_server=io_server + +# ============================================================================= +# *** END of User configuration +# ============================================================================= + +set -xuve + +if [[ -d $RUNDIR ]]; then + rm -rf $RUNDIR +fi + +mkdir -p $RUNDIR + +cd $RUNDIR + +# Copy the cmd in the run folder +cp %LOGDIR%/%RUNHASH%.cmd . + +echo ${JOB_ID} > job_id.txt + +INIDATA_PATH=${PROJPATH}/analysis_inidata + +# Load utils +source ${PROJPATH}/utils/functions.sh + +set_environment + + +ln -sf ${INIDATA_PATH}/* . + + +cp --remove-destination ${NAMELIST} namelist_precisions + +set +xuve +time mpirun -n 48 ./${binary} + +if [[ -f time.step ]]; then + ts=$(cat time.step) + if [[ ${ts} -eq 160 ]]; then + RMSE_SCRIPT=${PROJPATH}/EvaluationScripts/ensemble/compute_members_RMSE.py + + python ${RMSE_SCRIPT} --ensemble-files ${PROJPATH}/ensemble_mean_reference_short/* --member-files ORCA2_5d_* --mask-file mesh_mask.nc --output-file ${RUNDIR}/simulation_RMSE.pkl + + rm ORCA2_5d_????????_????????_*.nc + rm ORCA2_????????_restart_????.nc + else + exit 1 + fi +else + # Remove old error files if any + rm -f ./*.error + file_not_found=$(grep -c 'not found' ocean.output) + if [[ ${file_not_found} -gt 0 ]]; then + grep 'not found' ocean.output > AutoRPE_analysis.error + exit 1 + fi + errors=$(grep -c 'E R R O R' ocean.output) + if [[ ${errors} -gt 0 ]]; then + grep 'E R R O R' ocean.output > NEMO_analysis.error + exit 1 + fi + exit 1 +fi + diff --git a/V4.0/utils/job_template_ORCA1.sh b/V4.0/utils/job_template_ORCA1.sh new file mode 100644 index 0000000000000000000000000000000000000000..97b3b10e075e7714c59578158a6bb014d03ce195 --- /dev/null +++ b/V4.0/utils/job_template_ORCA1.sh @@ -0,0 +1,87 @@ +#!/bin/bash +############################################################################### +# SBATCH HEADER TEMPLATE +############################################################################### +#SBATCH --ntasks 432 +#SBATCH -J %JOBNAME% +#SBATCH --output %LOGDIR%/log_%j.out +#SBATCH --error %LOGDIR%/log_%j.err +#SBATCH --time 00:25:00 +#SBATCH --qos=debug + +set -xuve + +JOB_ID=${SLURM_JOB_ID:-$LSB_JOBID} + +ABSPATH=%REMOTE_PATH% +PROJPATH=${ABSPATH}/precisionoptimizationworkflow4nemo +RUNDIR=${ABSPATH}/analysis/%RUNHASH% +NAMELIST=%NAMELIST% +binary=model_binary_rpe +io_server=xios_server + +# ============================================================================= +# *** END of User configuration +# ============================================================================= + +set -xuve + +if [[ -d $RUNDIR ]]; then + rm -rf $RUNDIR +fi + +mkdir -p $RUNDIR + +cd $RUNDIR + +# Copy the cmd in the run folder +cp %LOGDIR%/%RUNHASH%.cmd . + +echo ${JOB_ID} > job_id.txt + +INIDATA_PATH=${PROJPATH}/analysis_inidata + +# Load utils +source ${PROJPATH}/utils/functions.sh + +set_environment + + +ln -sf ${INIDATA_PATH}/* . + + +cp --remove-destination ${NAMELIST} namelist_precisions + +set +xuve +time mpirun -n 432 ./${binary} +#time mpirun -n 368 ./${binary} : -n 46 ./${io_server} + +if [[ -f time.step ]]; then + ts=$(cat time.step) + if [[ ${ts} -eq 160 ]]; then + RMSE_SCRIPT=${PROJPATH}/EvaluationScripts/ensemble/compute_members_RMSE.py + + python ${RMSE_SCRIPT} --ensemble-files ${PROJPATH}/ensemble_mean_reference_short/* --member-files ORCA*_3d_* --mask-file mesh_mask.nc --output-file ${RUNDIR}/simulation_RMSE.pkl + + rm -f eORCA*_????????_??????_restart_????.nc + rm -f eORCA*_????????_??????_restart_ice_????.nc + + else + exit 1 + fi +else + # Remove old error files if any + rm -f ./*.error + file_not_found=$(grep -c 'not found' ocean.output) + if [[ ${file_not_found} -gt 0 ]]; then + grep 'not found' ocean.output > AutoRPE_analysis.error + exit 1 + fi + errors=$(grep -c 'E R R O R' ocean.output) + if [[ ${errors} -gt 0 ]]; then + grep 'E R R O R' ocean.output > NEMO_analysis.error + exit 1 + fi + exit 1 +fi +